342 lines
11 KiB
Scheme
342 lines
11 KiB
Scheme
;;; 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-file
|
|
call-with-input-string
|
|
thunk?
|
|
EXIT_SUCCESS
|
|
EXIT_FAILURE
|
|
usleep
|
|
exact?
|
|
exact-integer?
|
|
set-program-arguments
|
|
open-file
|
|
tmpfile
|
|
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! 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 (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-file file proc)
|
|
(let ((port (open-input-file file)))
|
|
(call-with-values (lambda () (proc port))
|
|
(lambda results
|
|
(close-port port)
|
|
(apply values results)))))
|
|
|
|
(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 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
|
|
((string=? mode "r") (open-input-file filename))
|
|
((string=? mode "w") (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))
|
|
|
|
;; 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)))))))
|