gash/gash/compat.scm

;;; Gash -- Guile As SHell
;;; Copyright © 2019, 2022 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of Gash.
;;;
;;; Gash 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.
;;;
;;; Gash 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 Gash.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gash compat)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-14)
  #:export (if-guile-version-below
            when-mes))

;;; Commentary:
;;;
;;; This module fills in for features that are missing in older
;;; versions of the '(guile)' module.
;;;
;;; Code:

(cond-expand
 (guile
  (define-syntax if-guile-version-below
    (lambda (x)
      (define (guile-version<? major minor micro)
        (let ((g-major (string->number (major-version)))
              (g-minor (string->number (minor-version)))
              (g-micro (string->number (micro-version))))
          (or (< g-major major)
              (and (= g-major major)
                   (< g-minor minor))
              (and (= g-major major)
                   (= g-minor minor)
                   (< g-micro micro)))))

      (syntax-case x ()
        ((_ (maj min mic) consequent alternate)
         (if (guile-version<? (syntax->datum #'maj)
                              (syntax->datum #'min)
                              (syntax->datum #'mic))
             #'consequent
             #'alternate))
        ((_ (maj min mic) consequent)
         #'(if-guile-version-below (maj min mic)
             consequent
             (if #f #t))))))
  (define-syntax-rule (when-mes . forms) (if #f #t)))
 (mes
  (define-macro (if-guile-version-below . forms)
    '(begin))
  (define-macro (when-mes . forms)
    `(begin ,@forms))))

(if-guile-version-below (2 0 10)
  (begin
    (define-public EXIT_SUCCESS 0)

    (define-public EXIT_FAILURE 1)

    (define-public (exact-integer? x)
      (and (integer? x) (exact? x)))))

(if-guile-version-below (2 2 0)
  (begin
    (define* (setvbuf port mode #:optional size)
      (let ((mode (match mode
                    ('none _IONBF)
                    ('line _IOLBF)
                    ('block _IOFBF))))
        ((@ (guile) setvbuf) port mode size)))
    (export! setvbuf)))

(when-mes
  (export define-inlinable
          make-parameter
          parameterize
          set-port-line!
          string-for-each
          string-every
          string-any
          noop
          make-prompt-tag
          call-with-prompt
          abort-to-prompt
          canonicalize-path
          X_OK
          program-arguments
          delete-duplicates!
          flush-all-ports
          file-port?
          input-port?
          output-port?
          thunk?
          EXIT_SUCCESS
          EXIT_FAILURE
          usleep
          exact?
          exact-integer?
          set-program-arguments
          open-file
          tmpfile)

  (define-macro (define-inlinable . rest)
    `(define ,@rest))

  ;; This is cute, but maybe a record would be better.
  (define *fluid-accessor* (list 'fluid-accessor))

  (define (make-parameter init)
    (define fluid (make-fluid init))
    (lambda args
      (if (null? args)
          (fluid-ref fluid)
          (let ((new-value (car args)))
            (if (eq? new-value *fluid-accessor*)
                fluid
                (let ((old-value (fluid-ref fluid)))
                  (fluid-set! fluid new-value)
                  old-value))))))

  (define-syntax-rule (parameterize ((param value) ...) body ...)
    (with-fluids (((param (@@ (gash compat) *fluid-accessor*)) value) ...)
      body ...))

  (define (set-port-line! port line)
    #f)

  (define (char-pred pred)
    (cond
     ((char? pred) (lambda (x) (char=? x pred)))
     ((char-set? pred) (lambda (x) (char-set-contains? pred x)))
     ((procedure? pred) pred)
     (else (error "Invalid character predicate."))))

  (define (string-for-each proc str)
    (for-each proc (string->list str)))

  (define* (string-every pred str #:optional (start 0)
                         (end (string-length str)))
    (let ((pred (char-pred pred)))
      (let loop ((k start))
        (if (= k end)
            #t
            (and (pred (string-ref str k))
                 (loop (+ k 1)))))))

  (define* (string-any pred str #:optional (start 0)
                       (end (string-length str)))
    (let ((pred (char-pred pred)))
      (let loop ((k start))
        (and (< k end)
             (if (pred (string-ref str k))
                 #t
                 (loop (+ k 1)))))))

  (define (noop . args) #f)

  (define* (make-prompt-tag #:optional (stem "prompt"))
    (make-fluid (lambda args (error "Abort to unknown prompt"))))

  (define (abort-to-prompt tag . args)
    (call-with-current-continuation
     (lambda (cc)
       (apply (fluid-ref tag) cc args))))

  (define (call-with-prompt tag thunk handler)
    ;; We are going to wrap THUNK and HANDLER so that they both adhere
    ;; to the same interface.  They will both return a list, with the
    ;; first element being a procedure to apply to the rest of the
    ;; elements.  Then, in the normal case, we will set the first
    ;; element to the identity procedure so that it just passes along
    ;; what THUNK would have returned.  In the case where the thunk
    ;; aborts to the prompt, we set the first element to HANDLER so that
    ;; it can be invoked after te stack has been unwound.

    ;; XXX: We should handle multiple values, but Mes has some bugs
    ;; which makes this difficult.

    ;; This is the normal case: collect the values returned by THUNK,
    ;; and wrap them with a "handler" procedure ('identity'), which will
    ;; just return them as-is.
    (define (return-normally)
      (cons identity (list (thunk))))

    ;; Here the thunk has aborted to the prompt, so we need to unwind
    ;; the stack (using KONT), and use HANDLER itself as the handler
    ;; procedure.
    (define (make-handler-return kont)
      (lambda args
        (kont (cons handler args))))

    ;; This is the part the invokes the handlers described above.
    (let* ((handler+args (call-with-current-continuation
                          (lambda (kont)
                            (with-fluids ((tag (make-handler-return kont)))
                              (return-normally)))))
           (handler (car handler+args))
           (args (cdr handler+args)))
      (apply handler args)))

  ;; XXX: Actually implement this.
  (define (canonicalize-path path) path)

  (define X_OK 1)

  (define program-arguments command-line)

  (define delete-duplicates! (@ (srfi srfi-1) delete-duplicates))

  ;; Mes does not have port buffers.
  (define flush-all-ports noop)

  ;; Mes uses raw file descriptors for file ports.
  (define file-port? number?)

  ;; This is probably OK...?
  (define (input-port? port) #f)
  (define (output-port? port) #f)

  ;; Fix 'dup' interface.
  (let ((mes/dup dup))
    (define* (guile/dup fd #:optional new)
      (if new (dup2 fd new) (mes/dup fd)))
    (set! dup guile/dup))

  (define (thunk? obj)
    (and (closure? obj)
         (let ((args (cadr (core:cdr obj))))
           (or (null? args) (symbol? args)))))

  (define EXIT_SUCCESS 0)
  (define EXIT_FAILURE 1)

  ;; Mes doesn't have sleep, so we just spin the tires a bit.
  (define (usleep n)
    (let loop ((n n))
      (if (<= n 0)
          #t
          (loop (- n 1)))))

  ;; Mes only has exact integers.
  (define exact? integer?)
  (define exact-integer? integer?)

  (define (set-program-arguments args)
    (set! %argv args))

  (define (open-file filename mode)
    (cond
     ((or (string=? mode "r")
          (string=? mode "rb"))
      (open-input-file filename))
     ((or (string=? mode "w")
          (string=? mode "wb"))
      (open-output-file filename))
     (else (error "Unsupported file mode" mode))))

  ;; Because Mes is not careful when resolving syntax, this will
  ;; shadow its built-in 'false-if-exception' shim even though we
  ;; don't export it (which would result in a warning).
  (define-syntax-rule (false-if-exception body1 body2 ...)
    (catch #t
      (lambda () body1 body2 ...)
      (lambda _ #f)))

  (define hex-digits "0123456789abcdef")

  (define (char->hex-string c)
    (define b (char->integer c))
    (string (string-ref hex-digits (logand (ash b -4) #xf))
            (string-ref hex-digits (logand b #xf))))

  (define (make-random-file-name)
    (let* ((p (open-input-file "/dev/urandom"))
           (dir (or (getenv "TMPDIR") "/tmp"))
           (name (string-append dir "/mes-tmp-"
                                (char->hex-string (read-char p))
                                (char->hex-string (read-char p))
                                (char->hex-string (read-char p))
                                (char->hex-string (read-char p)))))
      (close-port p)
      name))

  (define (tmpfile)
    (define flags (logior O_EXCL O_CREAT O_RDWR))
    ;; XXX: Mes provides no way to check for EEXIST, so we can't loop
    ;; to ensure we get a fresh name.  Hence, we cross our fingers and
    ;; hope we don't crash because of a name collision.
    (let* ((name (make-random-file-name))
           (port (open name flags)))
      ;; Delete the file so that it's gone when we're done.
      (delete-file name)
      port)))