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-concatenate-reverse
          string-every
          string-any
          the-eof-object
          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?
          call-with-input-string
          thunk?
          EXIT_SUCCESS
          EXIT_FAILURE
          exact-integer?
          sort)

  (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-for-each proc str)
    (for-each proc (string->list str)))

  (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"))
    (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)

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

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

  ;; A simple (slow!) sort procedure.  It's needed for globbing.
  (define (sort items less)
    (define (split-reverse lst)
      (let loop ((lst lst) (acc1 '()) (acc2 '()))
        (cond
         ((null? lst) (values acc1 acc2))
         ((null? (cdr lst)) (values (cons (car lst) acc1) acc2))
         (else (loop (cddr lst)
                     (cons (car lst) acc1)
                     (cons (cadr lst) acc2))))))

    (define (merge alist blist less)
      (let loop ((alist alist) (blist blist) (acc '()))
        (cond
         ((null? alist) (reverse (append-reverse blist acc)))
         ((null? blist) (reverse (append-reverse alist acc)))
         (else (let ((a (car alist))
                     (b (car blist)))
                 (if (less a b)
                     (loop (cdr alist) blist (cons a acc))
                     (loop alist (cdr blist) (cons b acc))))))))

    (cond
     ((null? items) items)
     ((null? (cdr items)) items)
     (else (call-with-values (lambda () (split-reverse items))
             (lambda (alist blist)
               (merge (sort alist less) (sort blist less) less)))))))