;;; New profiler.  The profiler lets you get and set properties in a permanent way.

;;; All the profile datum are saved on a global called *profile-datum*  The global *profile-location*
;;; tell the profiler where (under your home directory) to find profile files.  *profile-ports* has the
;;; the names and ports for all the open profiles known.

(defparameter *profile-datum* ())
(defparameter *profile-location* "PROFILES>")
(defparameter *profile-ports* ())

(defmacro strassoc (what where)
  `(assoc (symbol-name ,what) ,where :test #'string-equal))

(defun pro-get (system id property)
  (cdr (strassoc property (cadr (strassoc id (get-profile-alist system))))))

(defun pro-set (system id property value &aux port)
  (get-profile-alist system) ; ensure that the profile is property loaded.
  (setq port (ensure-profile system)) ; get the port handle
  (file-position port :end) ; point to the end to append the new value
  (update-internal-profile system (print (list (symbol-name id)
                                               (symbol-name property)
                                               value)
                                         port)))

(defun get-profile-alist (system)
  (or (cadr (strassoc system *profile-datum*))
      (load-up-profile system)))

(defun make-profile-name (system)
  (concatenate 'string (il:directoryname ()) *profile-location* (symbol-name system) ".PRO"))

;;; The profile file entries are triples of (id prop value).  These are decoded on read into the
;;; appropriate internal form of nested alists.

(defun load-up-profile (system &aux port r)
  (setq port (ensure-profile system))
  (file-position port :start)
  (prog (d)
   loop (or (setq d (read port () ()))
            (return t))
        (update-internal-profile system d)
        (go loop))
  (cadr (assoc system *profile-datum*)))

(defun update-internal-profile (system datum &aux l m n)
        ;; If the system has an entry...
  (cond ((setq l (strassoc system *profile-datum*))
               ;; If the entry already has an alist...
         (cond ((setq m (assoc (car datum) (cadr l)))
                      ;; If the prop already has a value...
                (cond ((setq n (assoc (cadr datum) (cadr m)))
                       ;; smash it!
                       (rplacd n (caddr datum)))
                      ;; No value, push one on the item's proplist.
                      (t (push (cons (cadr datum) (caddr datum)) (cadr m)))
                 )
                )
               ;; If no entry yet then add one.
               (t (push (list (car datum) (list (cons (cadr datum) (caddr datum)))) (cadr l)))
           )
         )
        ;; If no entry, make this the first one.
        (t (push (list system (list (list (car datum) (list (cons (cadr datum) (caddr datum))))))
                 *profile-datum*)
           )
    ))

;;; Ensure-profile leaves the file at the end.  A file is created if one doesn't exist.

(defun ensure-profile (system &aux p)
  (cond ((setq p (cdr (strassoc system *profile-ports*)))
         (cond ((il:openp p) (file-position p :end))
               (t (rplacd (strassoc system *profile-ports*)
                          (setq p (open (make-profile-name system) :direction :io
                                                                   :if-exists :overwrite
                                                                   :if-does-not-exist :create)))
                  (file-position p :end)
                ))
         p)
        (t (setq p (open (make-profile-name system) :direction :io
                                                   :if-exists :overwrite
                                                    :if-does-not-exist :create))
           (file-position p :end)
           (push (cons system p) *profile-ports*)
           p)
   ))


(defun reset-profiler () 
  (setq *profile-datum* ())
  (setq *profile-ports* ())
  (mapcar #'close (il:openp)))