path: root/drmaa/v1/low.scm

;;; Guile DRMAA --- Guile bindings for DRMAA
;;; Copyright © 2020, 2021 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of Guile DRMAA.
;;;
;;; Guile DRMAA is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Guile DRMAA is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Guile DRMAA.  If not, see <http://www.gnu.org/licenses/>.

(define-module (drmaa v1 low)
  #:use-module (drmaa v1 ffi)
  #:use-module (drmaa errors)
  #:use-module (bytestructures guile)
  #:use-module (system foreign)
  #:use-module (system ffi-help-rt)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs enums)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:export (DRMAA

            get-next-attr-name!
            get-next-attr-value!
            get-next-job-id!
            get-num-attr-names
            get-num-attr-values
            get-num-job-ids
            release-attr-names!
            release-attr-values!
            release-job-ids!

            init-session!
            exit-session!

            allocate-job-template!
            delete-job-template!
            set-attribute!
            get-attribute
            set-vector-attribute!
            get-vector-attribute
            get-attribute-names
            get-vector-attribute-names

            run-job
            run-bulk-jobs

            control
            job-ps
            synchronize
            wait

            w-if-exited?
            w-exit-status
            w-if-signaled?
            w-termsig
            w-coredump?
            w-if-aborted?

            get-contact
            drmaa-version
            get-drm-system
            get-drmaa-implementation))

;; XXX: patch (drmaa v1 ffi) because it uses an undefined
;; procedure.  The generated code for drmaa_set_vector_attribute uses
;; unwrap~array, which is not implemented in ffi-help-rt.
;; (This may not be necessary for nyacc 1.03.1+.)
(module-define! (resolve-module '(drmaa v1 ffi))
                'unwrap~array
                (@@ (drmaa v1 ffi) unwrap~pointer))

(define (make-cstr-array string-list)
  "Return a bytevector containing pointers to each of the strings in
STRING-LIST."
  (let* ((n (length string-list))
         (pointers (map string->pointer string-list))
         (addresses (map pointer-address pointers))
         ;; Make it one item longer, because it needs to be a
         ;; NULL-terminated array.
	     (bv (make-bytevector (* (1+ n) (sizeof '*)) 0))
	     (bv-set! (case (sizeof '*)
		            ((4) bytevector-u32-native-set!)
		            ((8) bytevector-u64-native-set!))))
    (for-each (lambda (address index)
                (bv-set! bv (* (sizeof '*) index) address))
              addresses (iota n))
    bv))

(define-syntax-rule (return ret success error-message)
  (cond
   ((eq? ret (DRMAA 'ERRNO_SUCCESS)) success)
   (else
    (raise (condition
            (&drmaa-error (code ret))
            (&message
             (message
              (format #false "~a"
                      (char*->string error-message)))))))))

(define (DRMAA sym)
  "Return the DRMAA value corresponding to SYM as defined in the DRMAA
headers."
  (or (drmaa-v1-ffi-symbol-val (symbol-append 'DRMAA_ sym))
      (raise (condition
              (&message
               (message
                (format #false "Unknown DRMAA symbol: ~a" sym)))))))


;;; String vector helpers

(define (get-next-attr-name! names)
  "Return the next attribute name from the opaque list of attribute
NAMES."
  (let* ((name
          (make-char* (bytevector->pointer
                       (make-bytevector (DRMAA 'ATTR_BUFFER)))))
         (ret (drmaa_get_next_attr_name
               names name
               (DRMAA 'ATTR_BUFFER))))
    (and (eq? ret (DRMAA 'ERRNO_SUCCESS))
         (char*->string name))))

(define (get-next-attr-value! values)
  "Return the next attribute value from the opaque list of attribute
VALUES."
  (let* ((value
          (make-char* (bytevector->pointer
                       (make-bytevector (DRMAA 'ATTR_BUFFER)))))
         (ret (drmaa_get_next_attr_value
               values value
               (DRMAA 'ATTR_BUFFER))))
    (and (eq? ret (DRMAA 'ERRNO_SUCCESS))
         (char*->string value))))

(define (get-next-job-id! values)
  "Return the next job identifier from the opaque list of job name
VALUES."
  (let* ((value
          (make-char* (bytevector->pointer
                       ;; TODO: Perhaps not correct to use JOBNAME_BUFFER here
                       (make-bytevector (DRMAA 'JOBNAME_BUFFER)))))
         (ret (drmaa_get_next_job_id
               values value
               ;; TODO: Perhaps not correct to use JOBNAME_BUFFER here
               (DRMAA 'JOBNAME_BUFFER))))
    (and (eq? ret (DRMAA 'ERRNO_SUCCESS))
         (char*->string value))))

(define (get-num-attr-names values)
  "Return the number of attribute names in the opaque list VALUES."
  (let* ((size (make-size_t))
         (ret (drmaa_get_num_attr_names
               values (pointer-to size))))
    (and (eq? ret (DRMAA 'ERRNO_SUCCESS))
         (fh-object-ref size))))

(define (get-num-attr-values values)
  "Return the number of attribute values in the opaque list VALUES."
  (let* ((size (make-size_t))
         (ret (drmaa_get_num_attr_values
               values (pointer-to size))))
    (and (eq? ret (DRMAA 'ERRNO_SUCCESS))
         (fh-object-ref size))))

(define (get-num-job-ids values)
  "Return the number of job identifiers in the opaque list VALUES."
  (let* ((size (make-size_t))
         (ret (drmaa_get_num_job_ids
               values (pointer-to size))))
    (and (eq? ret (DRMAA 'ERRNO_SUCCESS))
         (fh-object-ref size))))

(define (release-attr-names! values)
  "Tell the DRMAA library that the attribute names in VALUES can be
destroyed."
  (drmaa_release_attr_names values)
  #true)

(define (release-attr-values! values)
  "Tell the DRMAA library that the attribute values in VALUES can be
destroyed."
  (drmaa_release_attr_values values)
  #true)

(define (release-job-ids! values)
  "Tell the DRMAA library that the job identifiers in VALUES can be
destroyed."
  (drmaa_release_job_ids values)
  #true)

(define (extract type)
  (define next
    (match type
      ('job-id get-next-job-id!)
      ('name   get-next-attr-name!)
      ('value  get-next-attr-value!)))
  (define release
    (match type
      ('job-id release-job-ids!)
      ('name   release-attr-names!)
      ('value  release-attr-values!)))
  (lambda (values)
    (let loop ((res '()))
      (let ((item (next values)))
        (if item
            (loop (cons item res))
            (begin
              (release values)
              (reverse res)))))))

(define extract-job-ids
  (extract 'job-id))
(define extract-names
  (extract 'name))
(define extract-values
  (extract 'value))


;;; Session management

(define* (init-session! #:optional contact)
  "Initialize the DRMAA library and create a new DRMAA session.  If
the binary module provides only one DRMAA implementation, the string
CONTACT need not be provided; in that case the default implementation
will be used."
  (let ((error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
    (return (drmaa_init (or contact %null-pointer)
                        error-message
                        (DRMAA 'ERROR_STRING_BUFFER))
            #true
            error-message)))

(define (exit-session!)
  "Terminate an existing DRMAA session.  Queued and running jobs will
not be affected by this."
  (let ((error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
    (return (drmaa_exit error-message
                        (DRMAA 'ERROR_STRING_BUFFER))
            #true
            error-message)))


;;; Job templates

(define (allocate-job-template!)
  "Allocate a job template and return the opaque template value.
Remember to call DELETE-JOB-TEMPLATE! to destroy it."
  (let ((template (make-drmaa_job_template_t*))
        (error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
    (return (drmaa_allocate_job_template (pointer-to template)
                                         error-message
                                         (DRMAA 'ERROR_STRING_BUFFER))
            template
            error-message)))

(define (delete-job-template! template)
  "Destroy the job TEMPLATE that has previously been created with
ALLOCATE-JOB-TEMPLATE!."
  ;; TODO: Call this in a finalizer.
  (let ((error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
    (return (drmaa_delete_job_template template
                                       error-message
                                       (DRMAA 'ERROR_STRING_BUFFER))
            #true
            error-message)))

(define (set-attribute! template name value)
  "Modify TEMPLATE by setting its attribute NAME to VALUE."
  (let ((valid (get-attribute-names)))
    (unless (member name valid)
      (raise (condition
              (&formatted-message
               (format "This DRMAA implementation does not support the attribute `~a'.~%")
               (arguments (list name))))))
    (let ((error-message
           (make-char* (bytevector->pointer
                        (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
      (return (drmaa_set_attribute template
                                   (string->pointer name) value
                                   error-message
                                   (DRMAA 'ERROR_STRING_BUFFER))
              #true
              error-message))))

(define (get-attribute template name)
  "Return the TEMPLATE value's attribute identified by NAME."
  (let ((error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER)))))
        (value
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ATTR_BUFFER))))))
    (return (drmaa_get_attribute template
                                 (string->pointer name)
                                 value
                                 (DRMAA 'ATTR_BUFFER)
                                 error-message
                                 (DRMAA 'ERROR_STRING_BUFFER))
            (char*->string value)
            error-message)))

(define (set-vector-attribute! template name . values)
  "Modify the TEMPLATE by setting its vector attribute identified by
NAME to the provided VALUES."
  (let ((valid (get-vector-attribute-names)))
    (unless (member name valid)
      (raise (condition
              (&formatted-message
               (format "This DRMAA implementation does not support the vector attribute `~a'.~%")
               (arguments (list name))))))
    (let ((error-message
           (make-char* (bytevector->pointer
                        (make-bytevector (DRMAA 'ERROR_STRING_BUFFER)))))
          (array (make-cstr-array values)))
      (return (drmaa_set_vector_attribute template
                                          name
                                          (bytevector->pointer array)
                                          error-message
                                          (DRMAA 'ERROR_STRING_BUFFER))
              #true
              error-message))))

(define (get-vector-attribute template name)
  "Return the list of values stored for the TEMPLATE value's vector
attribute identified by NAME."
  (let ((error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER)))))
        (values (make-drmaa_attr_values_t*)))
    (return (drmaa_get_vector_attribute template
                                        name
                                        (pointer-to values)
                                        error-message
                                        (DRMAA 'ERROR_STRING_BUFFER))
            (extract-values values)
            error-message)))

(define (get-attribute-names)
  "Return the list of names of all singular attributes."
  (let ((error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER)))))
        (names (make-drmaa_attr_names_t*)))
    (return (drmaa_get_attribute_names (pointer-to names)
                                       error-message
                                       (DRMAA 'ERROR_STRING_BUFFER))
            (extract-names names)
            error-message)))

(define (get-vector-attribute-names)
  "Return the list of names of all vector attributes."
  (let ((error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER)))))
        (names (make-drmaa_attr_names_t*)))
    (return (drmaa_get_vector_attribute_names (pointer-to names)
                                              error-message
                                              (DRMAA 'ERROR_STRING_BUFFER))
            (extract-names names)
            error-message)))


;;; Job submission

(define (run-job template)
  "Submit a single job with the attributes defined in the job
template.  Upon success return the job identifier."
  (let ((error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER)))))
        (job-id
         (make-char* (bytevector->pointer
                      ;; TODO: Perhaps not correct to use JOBNAME_BUFFER here
                      (make-bytevector (DRMAA 'JOBNAME_BUFFER))))))
    (return (drmaa_run_job job-id
                           ;; TODO: Perhaps not correct to use JOBNAME_BUFFER here
                           (DRMAA 'JOBNAME_BUFFER)
                           template
                           error-message
                           (DRMAA 'ERROR_STRING_BUFFER))
            (char*->string job-id)
            error-message)))

(define* (run-bulk-jobs template end
                        #:key
                        (start 1) (increment 1))
  "Submit a set of parametric jobs, which can be run concurrently.
The attributes defined in TEMPLATE are used for every job in the set.
Each job is identical except for its index.  The first job has an
index equal to START; the next has an index equal to the sum of START
and INCREMENT.  END is the maximum value of the index, but the value
of the last job's index may not be equal to END if the difference
between START and END is not evenly divisible by INCREMENT.

Return a list of job identifiers."
  (unless (positive? start)
    (raise (condition
            (&message
             (message "`start' must be greater than or equal to 1")))))
  (unless (<= start end)
    (raise (condition
            (&message
             (message "`start' must be less than or equal to `end'")))))
  (let ((error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER)))))
        (job-ids (make-drmaa_job_ids_t*)))
    (return (drmaa_run_bulk_jobs
             (pointer-to job-ids)
             template
             start end increment
             error-message
             (DRMAA 'ERROR_STRING_BUFFER))
            (extract-job-ids job-ids)
            error-message)))


;;; Job status and control

(define (control job-id action)
  "Enact the ACTION on the job identified by JOB-ID.  The following
symbols are considered valid actions: suspend, resume, hold, release,
and terminate.  If JOB-ID is the symbol *, all jobs submitted during
the current session will be affected."
  (unless (member action '(suspend resume hold release terminate))
    (raise (condition
            (&message
             (message
              (format #false "Invalid action: ~a" action))))))
  (let ((error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER)))))
        (action
         (DRMAA (symbol-append 'CONTROL_
                               (string->symbol
                                (string-upcase
                                 (symbol->string action)))))))
    (return (drmaa_control (match job-id
                             ('* (DRMAA 'JOB_IDS_SESSION_ALL))
                             (_ job-id))
                           action
                           error-message
                           (DRMAA 'ERROR_STRING_BUFFER))
            #true
            error-message)))

(define (job-status->symbol status-code)
  (cond
   ((eq? status-code (DRMAA 'PS_FAILED))
    'failed)
   ((eq? status-code (DRMAA 'PS_DONE))
    'done)
   ((eq? status-code (DRMAA 'PS_USER_SYSTEM_SUSPENDED))
    'user-system-suspended)
   ((eq? status-code (DRMAA 'PS_USER_SUSPENDED))
    'user-suspended)
   ((eq? status-code (DRMAA 'PS_RUNNING))
    'running)
   ((eq? status-code (DRMAA 'PS_USER_SYSTEM_ON_HOLD))
    'user-system-on-hold)
   ((eq? status-code (DRMAA 'PS_USER_ON_HOLD))
    'user-on-hold)
   ((eq? status-code (DRMAA 'PS_SYSTEM_ON_HOLD))
    'system-on-hold)
   ((eq? status-code (DRMAA 'PS_QUEUED_ACTIVE))
    'queued-active)
   ((eq? status-code (DRMAA 'PS_UNDETERMINED))
    'undetermined)
   (else
    (raise (condition
            (&message
             (message
              (format #false "Unexpected status: ~a" status-code))))))))

(define (job-ps job-id)
  "Return a symbol corresponding to the current status of the job
identified by JOB-ID (a string).  The return value is one of the
following symbols: FAILED, DONE, USER-SYSTEM-SUSPENDED,
USER-SUSPENDED, RUNNING, USER-SYSTEM-ON-HOLD, USER-ON-HOLD,
QUEUED-ACTIVE, UNDETERMINED."
  (let ((error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER)))))
        (status-code (make-uint8)))
    (return (drmaa_job_ps job-id
                          (pointer-to status-code)
                          error-message
                          (DRMAA 'ERROR_STRING_BUFFER))
            (job-status->symbol status-code)
            error-message)))

(define* (synchronize job-ids #:optional timeout dispose?)
  "Wait for all jobs with the given JOB-IDS to run to completion.
Wait forever unless TIMEOUT, an integer representing seconds, is
provided.  When DISPOSE? is provided, the status code for each of the
jobs will be discarded."
  (let ((timeout
         (or timeout (DRMAA 'TIMEOUT_WAIT_FOREVER)))
        (job-ids (make-cstr-array job-ids))
        (error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
    (return (drmaa_synchronize (bytevector->pointer job-ids)
                               timeout
                               (if dispose? 1 0)
                               error-message
                               (DRMAA 'ERROR_STRING_BUFFER))
            #true error-message)))

(define* (wait job-id #:optional timeout)
  "Wait for the completion of a job with identifier JOB-ID.  If the
JOB-ID is the special symbol '*, wait for the completion of any job
that has been submitted during this session.

TIMEOUT (an integer) specifies the number of seconds to block.  If it
is not provided or is #FALSE this procedure will block forever.

This procedure returns three values: the identifier of the job that
has completed, a list of keyword-indexed status information, and an
alist of resource usage statistics."
  (let ((timeout
         (or timeout (DRMAA 'TIMEOUT_WAIT_FOREVER)))
        (job-id-out
         (make-char* (bytevector->pointer
                      ;; TODO: Perhaps not correct to use JOBNAME_BUFFER here
                      (make-bytevector (DRMAA 'JOBNAME_BUFFER)))))
        (status-code (make-uint8))
        (rusage (make-drmaa_attr_values_t*))
        (error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
    (return (drmaa_wait (match job-id
                          ('* (DRMAA 'JOB_IDS_SESSION_ANY))
                          (_ job-id))
                        job-id-out
                        ;; TODO: Perhaps not correct to use JOBNAME_BUFFER here
                        (DRMAA 'JOBNAME_BUFFER)
                        (pointer-to status-code)
                        timeout
                        (pointer-to rusage)
                        error-message
                        (DRMAA 'ERROR_STRING_BUFFER))
            (values (char*->string job-id-out)
                    (let ((code (fh-object-ref status-code)))
                      (list #:exit-status (w-exit-status code)
                            #:coredump? (w-coredump? code)
                            #:exited? (w-if-exited? code)
                            #:aborted? (w-if-aborted? code)
                            #:signaled? (and (w-if-signaled? code)
                                             (w-termsig code))))
                    (map (lambda (value)
                           (or (and=> (string-index value #\=)
                                      (lambda (split-point)
                                        (cons (string-take value split-point)
                                              (string-drop value (1+ split-point)))))
                               (cons value value)))
                         (extract-values rusage)))
            error-message)))

(define (w-if-exited? status-code)
  "Return #TRUE if the STATUS-CODE indicates that the job has exited."
  (let ((exited (make-uint8))
        (error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
    (return (drmaa_wifexited (pointer-to exited)
                             status-code
                             error-message
                             (DRMAA 'ERROR_STRING_BUFFER))
            (positive? (fh-object-ref exited))
            error-message)))

(define (w-exit-status status-code)
  "Return the numeric value of STATUS-CODE."
  (let ((exit-status (make-uint8))
        (error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
    (return (drmaa_wexitstatus (pointer-to exit-status)
                               status-code
                               error-message
                               (DRMAA 'ERROR_STRING_BUFFER))
            (fh-object-ref exit-status)
            error-message)))

(define (w-if-signaled? status-code)
  "Return #TRUE if the job was terminated because it received a signal."
  (let ((signaled (make-uint8))
        (error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
    (return (drmaa_wifsignaled (pointer-to signaled)
                               status-code
                               error-message
                               (DRMAA 'ERROR_STRING_BUFFER))
            (positive? (fh-object-ref signaled))
            error-message)))

(define (w-termsig status-code)
  "Return the name of the signal that terminated the job."
  (let ((signal
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'SIGNAL_BUFFER)))))
        (error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
    (return (drmaa_wtermsig signal
                            (DRMAA 'SIGNAL_BUFFER)
                            status-code
                            error-message
                            (DRMAA 'ERROR_STRING_BUFFER))
            (char*->string signal)
            error-message)))

(define (w-coredump? status-code)
  "Return #TRUE if the STATUS-CODE indicates that a core image of the
terminated job was created."
  (let ((core-dumped (make-uint8))
        (error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
    (return (drmaa_wcoredump (pointer-to core-dumped)
                             status-code
                             error-message
                             (DRMAA 'ERROR_STRING_BUFFER))
            (positive? (fh-object-ref core-dumped))
            error-message)))

(define (w-if-aborted? status-code)
  "Return #TRUE if the STATUS-CODE indicates that the job ended before
entering the running state."
  (let ((aborted (make-uint8))
        (error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
    (return (drmaa_wifaborted (pointer-to aborted)
                              status-code
                              error-message
                              (DRMAA 'ERROR_STRING_BUFFER))
            (positive? (fh-object-ref aborted))
            error-message)))


;;; Auxilliary functions

(define (get-contact)
  "When called before INIT-SESSION! return a string containing a
comma-delimited list of default DRMAA implementation contact strings,
one per DRM implementation provided.  If called after INIT-SESSION!
return the contact string for the DRM system for which the library has
been initialized."
  (let ((contact
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'CONTACT_BUFFER)))))
        (error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
    (return (drmaa_get_DRM_system contact
                                  (DRMAA 'CONTACT_BUFFER)
                                  error-message
                                  (DRMAA 'ERROR_STRING_BUFFER))
            (char*->string contact)
            error-message)))

(define (drmaa-version)
  "Return as a pair the major and minor version of the DRMAA C binding
specification implemented by the selected DRMAA implementation."
  (let ((major (make-uint8))
        (minor (make-uint8))
        (error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
    (return (drmaa_version (pointer-to major)
                           (pointer-to minor)
                           error-message
                           (DRMAA 'ERROR_STRING_BUFFER))
            (cons (fh-object-ref major)
                  (fh-object-ref minor))
            error-message)))

(define (get-drm-system)
  "When called before INIT-SESSION! return a string containing a
comma-delimited list of DRM system identifiers, one per DRM system
implementation provided.  If called after INIT-SESSION! return the
selected DRM system."
  (let ((drm-system
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'DRM_SYSTEM_BUFFER)))))
        (error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
    (return (drmaa_get_DRM_system drm-system
                                  (DRMAA 'DRM_SYSTEM_BUFFER)
                                  error-message
                                  (DRMAA 'ERROR_STRING_BUFFER))
            (char*->string drm-system)
            error-message)))

(define (get-drmaa-implementation)
  "When called before INIT-SESSION! return a string containing a
comma-delimited list of DRMAA implementations, one per DRMAA
implementation provided.  If called after INIT-SESSION! return the
selected DRMAA implementation."
  (let ((drmaa-implementation
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'DRMAA_IMPL_BUFFER)))))
        (error-message
         (make-char* (bytevector->pointer
                      (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
    (return (drmaa_get_DRMAA_implementation drmaa-implementation
                                            (DRMAA 'DRMAA_IMPL_BUFFER)
                                            error-message
                                            (DRMAA 'ERROR_STRING_BUFFER))
            (char*->string drmaa-implementation)
            error-message)))