Let's begin!

2 files changed, 675 insertions, 0 deletions

diff --git a/drmaa/v1/ffi.ffi b/drmaa/v1/ffi.ffi
new file mode 100644
index 0000000..4327926
--- /dev/null
+++ b/drmaa/v1/ffi.ffi
@@ -0,0 +1,20 @@
+;;; 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-ffi-module (drmaa v1 ffi)
+  #:include '("include/drmaa.h"))
diff --git a/drmaa/v1/low.scm b/drmaa/v1/low.scm
new file mode 100644
index 0000000..76f0e73
--- /dev/null
+++ b/drmaa/v1/low.scm
@@ -0,0 +1,655 @@
+;;; 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 (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))
+	     (bv (make-bytevector (* (1+ n) (sizeof '*))))
+	     (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))
+    ;; The vector must be NULL-terminated
+    (bv-set! bv (1+ n) 0)
+    bv))
+
+(define-syntax-rule (return ret success error-message)
+  (cond
+   ((eq? ret (DRMAA 'ERRNO_SUCCESS)) success)
+   (else
+    (raise (condition
+            (&message
+             (message
+              (format #false "~a (~a)"
+                      (char*->string error-message)
+                      ret))))))))
+
+(define (DRMAA sym)
+  (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)
+  (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)
+  (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)
+  (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)
+  (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)
+  (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)
+  (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)
+  (drmaa_release_attr_names values)
+  #true)
+
+(define (release-attr-values! values)
+  (drmaa_release_attr_values values)
+  #true)
+
+(define (release-job-ids! values)
+  (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!)
+  (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)
+  ;; 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)
+  (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)
+  (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)
+  (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)
+  (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)
+  (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)
+  (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)
+  (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)
+  (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 timeout dispose?)
+  (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 timeout)
+  (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 job-id-out status-code (extract-values rusage))
+            error-message)))
+
+(define (w-if-exited? status-code)
+  (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? exited)
+            error-message)))
+
+(define (w-exit-status 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))
+            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? 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? 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? 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)))