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-concatenate-reverse
          string-every
          string-any
          the-eof-object
          noop
          make-prompt-tag
          canonicalize-path
          X_OK
          program-arguments
          delete-duplicates!
          flush-all-ports
          file-port?
          input-port?
          output-port?
          call-with-input-string
          thunk?
          EXIT_SUCCESS
          EXIT_FAILURE)

  (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! 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 (string-concatenate-reverse lst)
    (apply string-append (reverse lst)))

  (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-every pred str)
    ((@ (srfi srfi-1) every) (char-pred pred) (string->list str)))

  (define (string-any pred str)
    ((@ (srfi srfi-1) any) (char-pred pred) (string->list str)))

  (define the-eof-object (integer->char -1))

  (define (noop . args) #f)

  (define* (make-prompt-tag #:optional (stem "prompt"))
    (list stem))

  ;; 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)

  (define (call-with-input-string str proc)
    (let ((port (open-input-string str)))
      (call-with-values (lambda () (proc port))
        (lambda results
          (close-port port)
          (apply values results)))))

  ;; 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))