  -*- Mode : LISP ; Syntax : ANSI - Common - Lisp ; Base : 10 -*-
;; See the file LICENCE for licence information.

;; SDLE-STORE now has a concept of backends.
;; store and restore now take an optional  backend as an
;;  argument to do the actual restoring. Examples of use are 
;; in default-backend.lisp and xml-backend.lisp

(in-package :sdle-store)

(defun required-arg (name)
  (error "~S is a required argument" name))

(defclass backend ()
  ((name                     :accessor name
                             :initform "Unknown"
                             :initarg  :name
                             :type     symbol)
   
   (magic-number             :accessor magic-number
                             :initarg  :magic-number
                             :type     (or null integer))
   
   (compatible-magic-numbers :accessor compatible-magic-numbers
                             :initarg  :compatible-magic-numbers
                             :type     list)
   
   (old-magic-numbers        :accessor old-magic-numbers
                             :initarg  :old-magic-numbers
                             :type     list)
   
   (stream-type              :accessor stream-type
                             :initarg  :stream-type
                             :type     (or symbol cons)
                             :initform (required-arg :stream-type))
   )
  (:documentation "Core class which custom backends must extend"))

(defmethod collect-slots ((backend backend))
  (list :name                     (name backend)
        :magic-number             (magic-number backend)
        :compatible-magic-numbers (compatible-magic-numbers backend)
        :old-magic-numbers        (old-magic-numbers backend)
        :stream-type              (stream-type backend)))

(defmethod copy-backend ((backend backend) &rest initargs)
  (apply 'make-instance (class-of backend)
         (append initargs (collect-slots backend))))

(defmethod copy-backend ((backend symbol) &rest initargs)
  (apply 'copy-backend (find-backend backend) initargs))


(deftype backend-designator ()
  `(or symbol backend))

(defparameter *registered-backends* nil 
  "An assoc list mapping backend-names to the backend objects")

(defun find-backend (name &optional errorp)
  (declare (type symbol name))
  "Return backup called NAME. If there is no such backend NIL is returned 
if ERRORP is false, otherwise an error is signalled."
  (or (cdr (assoc name *registered-backends*))
      (if errorp 
          (error "Backend named ~S does not exist." name)
          nil)))

(defun backend-designator->backend (designator)
  (check-type designator backend-designator)
  (etypecase designator
    (symbol (find-backend designator t))
    (backend designator)))


#+:lispworks
(defun get-store-macro (name)
  "Return the defstore-? macro which will be used by a custom backend"
  (let ((macro-name (symb 'defstore- name)))
    `(defmacro ,macro-name ((var type stream &optional qualifier) 
                            &body body)
       (with-gensyms (gbackend)
         `(dspec:def (,',macro-name (,var ,type ,stream))
            (defmethod internal-store-object ,@(if qualifier (list qualifier) nil)
              ((,gbackend ,',name) (,var ,type) ,stream)
              ,(format nil "Definition for storing an object of type ~A with ~
backend ~A" type ',name)
              (declare (ignorable ,gbackend))
              ,@body))))))

#-:lispworks
(defun get-store-macro (name)
  "Return the defstore-? macro which will be used by a custom backend"
  (let ((macro-name (symb 'defstore- name)))
    `(defmacro ,macro-name ((var type stream &optional qualifier) 
                            &body body)
       (with-gensyms (gbackend)
         `(defmethod internal-store-object ,@(if qualifier (list qualifier) nil)
              ((,gbackend ,',name) (,var ,type) ,stream)
              ,(format nil "Definition for storing an object of type ~A with ~
 backend ~A" type ',name)
              (declare (ignorable ,gbackend))
              ,@body)))))

#+:lispworks
(defun get-restore-macro (name)
  "Return the defrestore-? macro which will be used by a custom backend"
  (let ((macro-name (symb 'defrestore- name)))
    `(defmacro ,macro-name ((type place &optional qualifier) &body body)
       (with-gensyms (gbackend gtype)
         `(dspec:def (,',macro-name (,type ,place))
            (defmethod internal-restore-object ,@(if qualifier (list qualifier) nil)
              ((,gbackend ,',name) (,gtype (eql ',type)) (,place t))
              (declare (ignorable ,gbackend ,gtype))
              ,@body))))))

#-:lispworks
(defun get-restore-macro (name)
  "Return the defrestore-? macro which will be used by a custom backend"
  (let ((macro-name (symb 'defrestore- name)))
    `(defmacro ,macro-name ((type place &optional qualifier) &body body)
       (with-gensyms (gbackend gtype)
         `(defmethod internal-restore-object ,@(if qualifier (list qualifier) nil)
            ((,gbackend ,',name) (,gtype (eql ',type)) (,place t))
            (declare (ignorable ,gbackend ,gtype))
            ,@body)))))


(defun register-backend (name class magic-number stream-type old-magic-numbers 
                              compatible-magic-numbers)
  (declare (type symbol name))
  (let ((instance (make-instance class
                                 :name                     name
                                 :magic-number             magic-number
                                 :old-magic-numbers        old-magic-numbers
                                 :compatible-magic-numbers compatible-magic-numbers
                                 :stream-type              stream-type)))
    (if (assoc name *registered-backends*)
        (cerror "Redefine backend" "Backend ~A is already defined." name)
        (push (cons name instance) *registered-backends*))
    instance))

(defun alias-backend (old alias)
  (let ((backend (find-backend old t)))
    (pushnew (cons alias backend) *registered-backends*
             :test #'equalp)
    t))

(defun get-class-form (name fields extends)
  `(defclass ,name ,extends
    ,fields
    (:documentation ,(format nil "Autogenerated sdle-store class for backend ~(~A~)."
                             name))))


#+:lispworks
(defun get-dspec-alias-and-parser (name)
  (let ((store-name   (symb 'defstore-   name))
        (restore-name (symb 'defrestore- name)))
    `( (dspec:define-dspec-alias ,store-name (arglist)
         `(method sdle-store::internal-store-object ,arglist))
       (dspec:define-form-parser ,store-name (arglist)
         `(,,store-name ,arglist))

       (dspec:define-dspec-alias ,restore-name (arglist)
         `(method sdle-store::internal-restore-object ,arglist))

       (dspec:define-form-parser ,restore-name (arglist)
         `(,,restore-name ,arglist)))))


(defmacro defbackend (name &key
                           (stream-type ''(unsigned-byte 8))
                           (magic-number nil)
                           fields
                           (extends '(backend))
                           (old-magic-numbers nil)
                           (compatible-magic-numbers nil))
  "Defines a new backend called NAME. Stream type must be either 'char or 'binary. 
FIELDS is a list of legal slots for defclass. MAGIC-NUMBER, when supplied, will
be written down stream as verification and checked on restoration.
EXTENDS is a class to extend, which must be backend or a class which extends
backend"
  (assert (symbolp name))
  `(eval-when (:load-toplevel :execute)
     (eval-when (:compile-toplevel :load-toplevel :execute)
       #+:lispworks ,@(get-dspec-alias-and-parser name)
       ,(get-class-form name fields extends)
       ,(get-store-macro name)
       ,(get-restore-macro name))
     (register-backend ',name ',name ,magic-number 
                       ,stream-type ',old-magic-numbers ',compatible-magic-numbers)))

(defmacro with-backend (backend &body body)
  "Run BODY with *default-backend* bound to BACKEND"
  `(let* ((*default-backend* (backend-designator->backend ,backend)))
    ,@body))

  EOF

 Syntax : ANSI - Common - Lisp ; Base : 10 -*-
 See the file LICENCE for licence information.
 SDLE-STORE now has a concept of backends.
 store and restore now take an optional  backend as an
  argument to do the actual restoring. Examples of use are 
 in default-backend.lisp and xml-backend.lisp


(in-package :sdle-store)

(defun required-arg (name)
  (error "~S is a required argument" name))

(defclass backend ()
  ((name                     :accessor name
                             :initform "Unknown"
                             :initarg  :name
                             :type     symbol)
   
   (magic-number             :accessor magic-number
                             :initarg  :magic-number
                             :type     (or null integer))
   
   (compatible-magic-numbers :accessor compatible-magic-numbers
                             :initarg  :compatible-magic-numbers
                             :type     list)
   
   (old-magic-numbers        :accessor old-magic-numbers
                             :initarg  :old-magic-numbers
                             :type     list)
   
   (stream-type              :accessor stream-type
                             :initarg  :stream-type
                             :type     (or symbol cons)
                             :initform (required-arg :stream-type))
   )
  (:documentation "Core class which custom backends must extend"))

(defmethod collect-slots ((backend backend))
  (list :name                     (name backend)
        :magic-number             (magic-number backend)
        :compatible-magic-numbers (compatible-magic-numbers backend)
        :old-magic-numbers        (old-magic-numbers backend)
        :stream-type              (stream-type backend)))

(defmethod copy-backend ((backend backend) &rest initargs)
  (apply 'make-instance (class-of backend)
         (append initargs (collect-slots backend))))

(defmethod copy-backend ((backend symbol) &rest initargs)
  (apply 'copy-backend (find-backend backend) initargs))


(deftype backend-designator ()
  `(or symbol backend))

(defparameter *registered-backends* nil 
  "An assoc list mapping backend-names to the backend objects")

(defun find-backend (name &optional errorp)
  (declare (type symbol name))
  "Return backup called NAME. If there is no such backend NIL is returned 
if ERRORP is false, otherwise an error is signalled."
  (or (cdr (assoc name *registered-backends*))
      (if errorp 
          (error "Backend named ~S does not exist." name)
          nil)))

(defun backend-designator->backend (designator)
  (check-type designator backend-designator)
  (etypecase designator
    (symbol (find-backend designator t))
    (backend designator)))


#+:lispworks
(defun get-store-macro (name)
  "Return the defstore-? macro which will be used by a custom backend"
  (let ((macro-name (symb 'defstore- name)))
    `(defmacro ,macro-name ((var type stream &optional qualifier) 
                            &body body)
       (with-gensyms (gbackend)
         `(dspec:def (,',macro-name (,var ,type ,stream))
            (defmethod internal-store-object ,@(if qualifier (list qualifier) nil)
              ((,gbackend ,',name) (,var ,type) ,stream)
              ,(format nil "Definition for storing an object of type ~A with ~
backend ~A" type ',name)
              (declare (ignorable ,gbackend))
              ,@body))))))

#-:lispworks
(defun get-store-macro (name)
  "Return the defstore-? macro which will be used by a custom backend"
  (let ((macro-name (symb 'defstore- name)))
    `(defmacro ,macro-name ((var type stream &optional qualifier) 
                            &body body)
       (with-gensyms (gbackend)
         `(defmethod internal-store-object ,@(if qualifier (list qualifier) nil)
              ((,gbackend ,',name) (,var ,type) ,stream)
              ,(format nil "Definition for storing an object of type ~A with ~
 backend ~A" type ',name)
              (declare (ignorable ,gbackend))
              ,@body)))))

#+:lispworks
(defun get-restore-macro (name)
  "Return the defrestore-? macro which will be used by a custom backend"
  (let ((macro-name (symb 'defrestore- name)))
    `(defmacro ,macro-name ((type place &optional qualifier) &body body)
       (with-gensyms (gbackend gtype)
         `(dspec:def (,',macro-name (,type ,place))
            (defmethod internal-restore-object ,@(if qualifier (list qualifier) nil)
              ((,gbackend ,',name) (,gtype (eql ',type)) (,place t))
              (declare (ignorable ,gbackend ,gtype))
              ,@body))))))

#-:lispworks
(defun get-restore-macro (name)
  "Return the defrestore-? macro which will be used by a custom backend"
  (let ((macro-name (symb 'defrestore- name)))
    `(defmacro ,macro-name ((type place &optional qualifier) &body body)
       (with-gensyms (gbackend gtype)
         `(defmethod internal-restore-object ,@(if qualifier (list qualifier) nil)
            ((,gbackend ,',name) (,gtype (eql ',type)) (,place t))
            (declare (ignorable ,gbackend ,gtype))
            ,@body)))))


(defun register-backend (name class magic-number stream-type old-magic-numbers 
                              compatible-magic-numbers)
  (declare (type symbol name))
  (let ((instance (make-instance class
                                 :name                     name
                                 :magic-number             magic-number
                                 :old-magic-numbers        old-magic-numbers
                                 :compatible-magic-numbers compatible-magic-numbers
                                 :stream-type              stream-type)))
    (if (assoc name *registered-backends*)
        (cerror "Redefine backend" "Backend ~A is already defined." name)
        (push (cons name instance) *registered-backends*))
    instance))

(defun alias-backend (old alias)
  (let ((backend (find-backend old t)))
    (pushnew (cons alias backend) *registered-backends*
             :test #'equalp)
    t))

(defun get-class-form (name fields extends)
  `(defclass ,name ,extends
    ,fields
    (:documentation ,(format nil "Autogenerated sdle-store class for backend ~(~A~)."
                             name))))


#+:lispworks
(defun get-dspec-alias-and-parser (name)
  (let ((store-name   (symb 'defstore-   name))
        (restore-name (symb 'defrestore- name)))
    `( (dspec:define-dspec-alias ,store-name (arglist)
         `(method sdle-store::internal-store-object ,arglist))
       (dspec:define-form-parser ,store-name (arglist)
         `(,,store-name ,arglist))

       (dspec:define-dspec-alias ,restore-name (arglist)
         `(method sdle-store::internal-restore-object ,arglist))

       (dspec:define-form-parser ,restore-name (arglist)
         `(,,restore-name ,arglist)))))


(defmacro defbackend (name &key
                           (stream-type ''(unsigned-byte 8))
                           (magic-number nil)
                           fields
                           (extends '(backend))
                           (old-magic-numbers nil)
                           (compatible-magic-numbers nil))
  "Defines a new backend called NAME. Stream type must be either 'char or 'binary. 
FIELDS is a list of legal slots for defclass. MAGIC-NUMBER, when supplied, will
be written down stream as verification and checked on restoration.
EXTENDS is a class to extend, which must be backend or a class which extends
backend"
  (assert (symbolp name))
  `(eval-when (:load-toplevel :execute)
     (eval-when (:compile-toplevel :load-toplevel :execute)
       #+:lispworks ,@(get-dspec-alias-and-parser name)
       ,(get-class-form name fields extends)
       ,(get-store-macro name)
       ,(get-restore-macro name))
     (register-backend ',name ',name ,magic-number 
                       ,stream-type ',old-magic-numbers ',compatible-magic-numbers)))

(defmacro with-backend (backend &body body)
  "Run BODY with *default-backend* bound to BACKEND"
  `(let* ((*default-backend* (backend-designator->backend ,backend)))
    ,@body))

  EOF
