cl-adams/adams/core/resource-container.lisp

Tag - branch -0.1-stable0.2-stablemaster- tag -adams-0.3.2adams-0.3.1adams-0.3adams-0.2adams-0.1

• Show log

  Commit

• Hash : 491297af
  Author : Thomas de Grivel
  Date : 2018-07-26T14:31:45
  

  resource-additional-specs
  

Download

• core/resource-container.lisp

• ;;
  ;;  adams - system administrator written in Common Lisp
  ;;
  ;;  Copyright 2013,2014,2018 Thomas de Grivel <thoxdg@gmail.com>
  ;;
  ;;  Permission to use, copy, modify, and distribute this software for any
  ;;  purpose with or without fee is hereby granted, provided that the above
  ;;  copyright notice and this permission notice appear in all copies.
  ;;
  ;;  THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  ;;  WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
  ;;  MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
  ;;  ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
  ;;  WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
  ;;  ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  ;;  OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  ;;
  
  (in-package :adams)
  
  ;;  Resource registry
  
  (defun resource-registry-count (rr)
    (hash-table-count rr))
  
  (defun clear-resource-registry (rr)
    (clrhash rr))
  
  (defun get-resource (type id &optional (container *parent-resource*))
    (gethash (cons type id)
             (typecase container
               (resource-container (resource-registry container))
               (t container))))
  
  (defsetf get-resource (type id &optional (container '*parent-resource*))
      (value)
    `(setf (gethash (cons ,type ,id)
                    (typecase ,container
                      (resource-container (resource-registry ,container))
                      (t ,container)))
           ,value))
  
  (defun add-resource (parent child)
    (setf (get-resource (resource-type child)
                        (resource-id child)
  		      parent)
  	child))
  
  (defmacro do-resources% ((var) container &body body)
    (let ((x (gensym)))
      `(maphash (lambda (,x ,var)
                  (declare (ignore ,x))
                  ,@body)
                (resource-registry ,container))))
  
  (defmethod sorted-resources ((res resource-container))
    (let ((resources))
      (do-resources% (child) res
        (push child resources))
      (sort resources #'resource-before-p)))
  
  (defmacro do-resources ((var) container &body body)
    (let ((resources (gensym "RESOURCES-")))
      `(let ((,resources (sorted-resources ,container)))
         (loop (when (endp ,resources) (return))
            (let ((,var (pop ,resources)))
              (declare (type resource ,var))
              ,@body)))))
  
  (defmethod print-object ((rc resource-container) stream)
    (print-unreadable-object (rc stream :type t :identity (not *print-pretty*))
      (format stream "~S ~D spec ~D probed ~D resources" (resource-id rc)
  	    (/ (length (specified-properties rc)) 2)
  	    (/ (length (probed-properties rc)) 2)
  	    (resource-registry-count (resource-registry rc)))))
  
  (defmethod clear-resources% ((rc resource-container))
    (clear-resource-registry (resource-registry rc)))
  
  (defun clear-resources (&optional (resource-container *parent-resource*))
    (clear-resources% resource-container))
  
  (defmethod resource-before-p ((r1 resource) (r2 resource))
    nil)
  
  (defmethod resource-additional-specs ((res resource-container) (os t))
    (call-next-method)
    (with-parent-resource res
      (do-resources (child) res
        (resource-additional-specs child os))))
  
  (defmethod sync :after ((res resource-container))
    (with-parent-resource res
      (let ((sorted-resources (sorted-resources res)))
        (loop
           (when (endp sorted-resources)
             (return))
           (let ((child (pop sorted-resources)))
             (sync child))))))
  

Download