guile-hurd/mach/macros.lisp

(define-condition-type &port-invalid &assertion make-port-invalid
  port-invalid?
  (expression port-invalid-expression)
  (return     port-invalid-return))
;; (:documentation "Signals an error if the returned port is invalid.")

(define-report ((condition &port-invalid) stream)
  (format stream "Port returned by the expression ~s (~s) is not valid."
          (port-invalid-expression condition)
          (port-invalid-return condition)))

(define (%get-nil-task task)
  "Returns (task-self) if 'task' is nil, 'task' otherwise."
  (if (null? task)
      #'(task-self)
      task))

(define (with-port-generic destroy port-name creation task body)
  "Generates code for port using and releasing."
  #`(let ((#,port-name #,creation))
      (cond
       ((port-valid-p #,port-name)
        (with-cleanup #,(destroy port-name (%get-nil-task task))
                      #,@body))
       (#t (raise (make-port-invalid '#,creation #,port-name))))))

(define-syntax with-port-deallocate
  (lambda (s)
    "Uses a port and then port-deallocate's"
    (syntax-case s ()
      ((_ port-name creation #:body body task)
       (with-port-generic (lambda (port task)
			    #`(port-deallocate! #,port #,task))
			  #'port-name #'creation #'task #'body))
      ((_ port-name creation #:body body)
       #'(with-port-deallocate port-name creation #nil #:body body)))))

(define-syntax with-port-destroy
  (lambda (s)
    "Uses a port and then port-destroy's"
    (syntax-case s ()
      ((_ port-name creation task #:body body)
       (with-port-generic (lambda (port task)
			    #`(port-destroy #,port #,task))
			  #'port-name #'creation #'task #'body))
      ((_ port-name creation #:body body)
       #'(with-port-destroy port-name creation body #nil)))))

(define (%generate-release-list port task ls)
  "Generate code for port and port rights releasing based on the 'ls'
list syntax."
  (define (generate-release right)
    (syntax-case right ()
      ((#:deallocate) #`(port-deallocate! #,port #,task))
      (_ #`(port-mod-refs #,port #,right -1 #,task))))
  (syntax-map generate-release (syntax-cadr ls)))

(define* (with-port port-name creation #:optional (task #nil)
                    (release-list #nil) #:key body)
  "Generic with-port, uses a port initialized with 'creation'
and then releases rights.
release-list can have #:deallocate or any port right specified to port-mod-rights."
  (with-port-generic (lambda (port task)
                       #`(progn #,@(%generate-release-list port task release-list)))
                     port-name creation task body))