aboutsummaryrefslogtreecommitdiff
path: root/guix/build/syscalls.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/build/syscalls.scm')
-rw-r--r--guix/build/syscalls.scm594
1 files changed, 465 insertions, 129 deletions
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 69a507def8..4e543d70d8 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -46,6 +47,21 @@
mount-points
swapon
swapoff
+
+ file-system?
+ file-system-type
+ file-system-block-size
+ file-system-block-count
+ file-system-blocks-free
+ file-system-blocks-available
+ file-system-file-count
+ file-system-free-file-nodes
+ file-system-identifier
+ file-system-maximum-name-length
+ file-system-fragment-size
+ file-system-mount-flags
+ statfs
+
processes
mkdtemp!
pivot-root
@@ -82,7 +98,31 @@
interface-address
interface-netmask
interface-broadcast-address
- network-interfaces))
+ network-interfaces
+
+ termios?
+ termios-input-flags
+ termios-output-flags
+ termios-control-flags
+ termios-local-flags
+ termios-line-discipline
+ termios-control-chars
+ termios-input-speed
+ termios-output-speed
+ local-flags
+ TCSANOW
+ TCSADRAIN
+ TCSAFLUSH
+ tcgetattr
+ tcsetattr
+
+ window-size?
+ window-size-rows
+ window-size-columns
+ window-size-x-pixels
+ window-size-y-pixels
+ terminal-window-size
+ terminal-columns))
;;; Commentary:
;;;
@@ -92,6 +132,155 @@
;;;
;;; Code:
+
+;;;
+;;; Packed structures.
+;;;
+
+(define-syntax sizeof*
+ ;; XXX: This duplicates 'compile-time-value'.
+ (syntax-rules (int128 array)
+ ((_ int128)
+ 16)
+ ((_ (array type n))
+ (* (sizeof* type) n))
+ ((_ type)
+ (let-syntax ((v (lambda (s)
+ (let ((val (sizeof type)))
+ (syntax-case s ()
+ (_ val))))))
+ v))))
+
+(define-syntax alignof*
+ ;; XXX: This duplicates 'compile-time-value'.
+ (syntax-rules (int128 array)
+ ((_ int128)
+ 16)
+ ((_ (array type n))
+ (alignof* type))
+ ((_ type)
+ (let-syntax ((v (lambda (s)
+ (let ((val (alignof type)))
+ (syntax-case s ()
+ (_ val))))))
+ v))))
+
+(define-syntax align ;as found in (system foreign)
+ (syntax-rules (~)
+ "Add to OFFSET whatever it takes to get proper alignment for TYPE."
+ ((_ offset (type ~ endianness))
+ (align offset type))
+ ((_ offset type)
+ (1+ (logior (1- offset) (1- (alignof* type)))))))
+
+(define-syntax type-size
+ (syntax-rules (~)
+ ((_ (type ~ order))
+ (sizeof* type))
+ ((_ type)
+ (sizeof* type))))
+
+(define-syntax struct-alignment
+ (syntax-rules ()
+ "Compute the alignment for the aggregate made of TYPES at OFFSET. The
+result is the alignment of the \"most strictly aligned component\"."
+ ((_ offset types ...)
+ (max (align offset types) ...))))
+
+(define-syntax struct-size
+ (syntax-rules ()
+ "Return the size in bytes of the structure made of TYPES."
+ ((_ offset (types-processed ...))
+ ;; The SysV ABI P.S. says: "Aggregates (structures and arrays) and unions
+ ;; assume the alignment of their most strictly aligned component." As an
+ ;; example, a struct such as "int32, int16" has size 8, not 6.
+ (1+ (logior (1- offset)
+ (1- (struct-alignment offset types-processed ...)))))
+ ((_ offset (types-processed ...) type0 types ...)
+ (struct-size (+ (type-size type0) (align offset type0))
+ (type0 types-processed ...)
+ types ...))))
+
+(define-syntax write-type
+ (syntax-rules (~ array)
+ ((_ bv offset (type ~ order) value)
+ (bytevector-uint-set! bv offset value
+ (endianness order) (sizeof* type)))
+ ((_ bv offset (array type n) value)
+ (let loop ((i 0)
+ (value value)
+ (o offset))
+ (unless (= i n)
+ (match value
+ ((head . tail)
+ (write-type bv o type head)
+ (loop (+ 1 i) tail (+ o (sizeof* type))))))))
+ ((_ bv offset type value)
+ (bytevector-uint-set! bv offset value
+ (native-endianness) (sizeof* type)))))
+
+(define-syntax write-types
+ (syntax-rules ()
+ ((_ bv offset () ())
+ #t)
+ ((_ bv offset (type0 types ...) (field0 fields ...))
+ (begin
+ (write-type bv (align offset type0) type0 field0)
+ (write-types bv
+ (+ (align offset type0) (type-size type0))
+ (types ...) (fields ...))))))
+
+(define-syntax read-type
+ (syntax-rules (~ array quote *)
+ ((_ bv offset '*)
+ (make-pointer (bytevector-uint-ref bv offset
+ (native-endianness)
+ (sizeof* '*))))
+ ((_ bv offset (type ~ order))
+ (bytevector-uint-ref bv offset
+ (endianness order) (sizeof* type)))
+ ((_ bv offset (array type n))
+ (unfold (lambda (i) (= i n))
+ (lambda (i)
+ (read-type bv (+ offset (* i (sizeof* type))) type))
+ 1+
+ 0))
+ ((_ bv offset type)
+ (bytevector-uint-ref bv offset
+ (native-endianness) (sizeof* type)))))
+
+(define-syntax read-types
+ (syntax-rules ()
+ ((_ return bv offset () (values ...))
+ (return values ...))
+ ((_ return bv offset (type0 types ...) (values ...))
+ (read-types return
+ bv
+ (+ (align offset type0) (type-size type0))
+ (types ...)
+ (values ... (read-type bv
+ (align offset type0)
+ type0))))))
+
+(define-syntax define-c-struct
+ (syntax-rules ()
+ "Define SIZE as the size in bytes of the C structure made of FIELDS. READ
+as a deserializer and WRITE! as a serializer for the C structure with the
+given TYPES. READ uses WRAP-FIELDS to return its value."
+ ((_ name size wrap-fields read write! (fields types) ...)
+ (begin
+ (define size
+ (struct-size 0 () types ...))
+ (define (write! bv offset fields ...)
+ (write-types bv offset (types ...) (fields ...)))
+ (define* (read bv #:optional (offset 0))
+ (read-types wrap-fields bv offset (types ...) ()))))))
+
+
+;;;
+;;; FFI.
+;;;
+
(define %libc-errno-pointer
;; Glibc's 'errno' pointer.
(let ((errno-loc (dynamic-func "__errno_location" (dynamic-link))))
@@ -137,6 +326,24 @@
"Evaluate EXPR and restart upon EINTR. Return the value of EXPR."
(call-with-restart-on-EINTR (lambda () expr)))
+(define (syscall->procedure return-type name argument-types)
+ "Return a procedure that wraps the C function NAME using the dynamic FFI.
+If an error occurs while creating the binding, defer the error report until
+the returned procedure is called."
+ (catch #t
+ (lambda ()
+ (let ((ptr (dynamic-func name (dynamic-link))))
+ (pointer->procedure return-type ptr argument-types)))
+ (lambda args
+ (lambda _
+ (error (format #f "~a: syscall->procedure failed: ~s"
+ name args))))))
+
+
+;;;
+;;; File systems.
+;;;
+
(define (augment-mtab source target type options)
"Augment /etc/mtab with information about the given mount point."
(let ((port (open-file "/etc/mtab" "a")))
@@ -185,8 +392,7 @@
(define UMOUNT_NOFOLLOW 8)
(define mount
- (let* ((ptr (dynamic-func "mount" (dynamic-link)))
- (proc (pointer->procedure int ptr `(* * * ,unsigned-long *))))
+ (let ((proc (syscall->procedure int "mount" `(* * * ,unsigned-long *))))
(lambda* (source target type #:optional (flags 0) options
#:key (update-mtab? #f))
"Mount device SOURCE on TARGET as a file system TYPE. Optionally, FLAGS
@@ -214,8 +420,7 @@ error."
(augment-mtab source target type options))))))
(define umount
- (let* ((ptr (dynamic-func "umount2" (dynamic-link)))
- (proc (pointer->procedure int ptr `(* ,int))))
+ (let ((proc (syscall->procedure int "umount2" `(* ,int))))
(lambda* (target #:optional (flags 0)
#:key (update-mtab? #f))
"Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_*
@@ -242,8 +447,7 @@ constants from <sys/mount.h>."
(loop (cons mount-point result))))))))))
(define swapon
- (let* ((ptr (dynamic-func "swapon" (dynamic-link)))
- (proc (pointer->procedure int ptr (list '* int))))
+ (let ((proc (syscall->procedure int "swapon" (list '* int))))
(lambda* (device #:optional (flags 0))
"Use the block special device at DEVICE for swapping."
(let ((ret (proc (string->pointer device) flags))
@@ -254,8 +458,7 @@ constants from <sys/mount.h>."
(list err)))))))
(define swapoff
- (let* ((ptr (dynamic-func "swapoff" (dynamic-link)))
- (proc (pointer->procedure int ptr '(*))))
+ (let ((proc (syscall->procedure int "swapoff" '(*))))
(lambda (device)
"Stop using block special device DEVICE for swapping."
(let ((ret (proc (string->pointer device)))
@@ -304,6 +507,65 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'."
(list err)))
(pointer->string result)))))
+
+(define-record-type <file-system>
+ (file-system type block-size blocks blocks-free
+ blocks-available files free-files identifier
+ name-length fragment-size mount-flags spare)
+ file-system?
+ (type file-system-type)
+ (block-size file-system-block-size)
+ (blocks file-system-block-count)
+ (blocks-free file-system-blocks-free)
+ (blocks-available file-system-blocks-available)
+ (files file-system-file-count)
+ (free-files file-system-free-file-nodes)
+ (identifier file-system-identifier)
+ (name-length file-system-maximum-name-length)
+ (fragment-size file-system-fragment-size)
+ (mount-flags file-system-mount-flags)
+ (spare file-system--spare))
+
+(define-syntax fsword ;fsword_t
+ (identifier-syntax long))
+
+(define-c-struct %statfs ;<bits/statfs.h>
+ sizeof-statfs ;slightly overestimated
+ file-system
+ read-statfs
+ write-statfs!
+ (type fsword)
+ (block-size fsword)
+ (blocks uint64)
+ (blocks-free uint64)
+ (blocks-available uint64)
+ (files uint64)
+ (free-files uint64)
+ (identifier (array int 2))
+ (name-length fsword)
+ (fragment-size fsword)
+ (mount-flags fsword)
+ (spare (array fsword 4)))
+
+(define statfs
+ (let ((proc (syscall->procedure int "statfs64" '(* *))))
+ (lambda (file)
+ "Return a <file-system> data structure describing the file system
+mounted at FILE."
+ (let* ((stat (make-bytevector sizeof-statfs))
+ (ret (proc (string->pointer file) (bytevector->pointer stat)))
+ (err (errno)))
+ (if (zero? ret)
+ (read-statfs stat)
+ (throw 'system-error "statfs" "~A: ~A"
+ (list file (strerror err))
+ (list err)))))))
+
+
+;;;
+;;; Containers.
+;;;
+
;; Linux clone flags, from linux/sched.h
(define CLONE_CHILD_CLEARTID #x00200000)
(define CLONE_CHILD_SETTID #x01000000)
@@ -319,18 +581,18 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'."
;; declared in <unistd.h> as a variadic function; in practice, it expects 6
;; pointer-sized arguments, as shown in, e.g., x86_64/syscall.S.
(define clone
- (let* ((ptr (dynamic-func "syscall" (dynamic-link)))
- (proc (pointer->procedure long ptr
- (list long ;sysno
- unsigned-long ;flags
- '* '* '*
- '*)))
+ (let* ((proc (syscall->procedure int "syscall"
+ (list long ;sysno
+ unsigned-long ;flags
+ '* '* '*
+ '*)))
;; TODO: Don't do this.
(syscall-id (match (utsname:machine (uname))
("i686" 120)
("x86_64" 56)
("mips64" 5055)
- ("armv7l" 120))))
+ ("armv7l" 120)
+ (_ #f))))
(lambda (flags)
"Create a new child process by duplicating the current parent process.
Unlike the fork system call, clone accepts FLAGS that specify which resources
@@ -365,8 +627,7 @@ there is no such limitation."
(list err))))))))
(define pivot-root
- (let* ((ptr (dynamic-func "pivot_root" (dynamic-link)))
- (proc (pointer->procedure int ptr (list '* '*))))
+ (let ((proc (syscall->procedure int "pivot_root" (list '* '*))))
(lambda (new-root put-old)
"Change the root file system to NEW-ROOT and move the current root file
system to PUT-OLD."
@@ -380,107 +641,6 @@ system to PUT-OLD."
;;;
-;;; Packed structures.
-;;;
-
-(define-syntax sizeof*
- ;; XXX: This duplicates 'compile-time-value'.
- (syntax-rules (int128)
- ((_ int128)
- 16)
- ((_ type)
- (let-syntax ((v (lambda (s)
- (let ((val (sizeof type)))
- (syntax-case s ()
- (_ val))))))
- v))))
-
-(define-syntax alignof*
- ;; XXX: This duplicates 'compile-time-value'.
- (syntax-rules (int128)
- ((_ int128)
- 16)
- ((_ type)
- (let-syntax ((v (lambda (s)
- (let ((val (alignof type)))
- (syntax-case s ()
- (_ val))))))
- v))))
-
-(define-syntax align ;as found in (system foreign)
- (syntax-rules (~)
- "Add to OFFSET whatever it takes to get proper alignment for TYPE."
- ((_ offset (type ~ endianness))
- (align offset type))
- ((_ offset type)
- (1+ (logior (1- offset) (1- (alignof* type)))))))
-
-(define-syntax type-size
- (syntax-rules (~)
- ((_ (type ~ order))
- (sizeof* type))
- ((_ type)
- (sizeof* type))))
-
-(define-syntax write-type
- (syntax-rules (~)
- ((_ bv offset (type ~ order) value)
- (bytevector-uint-set! bv offset value
- (endianness order) (sizeof* type)))
- ((_ bv offset type value)
- (bytevector-uint-set! bv offset value
- (native-endianness) (sizeof* type)))))
-
-(define-syntax write-types
- (syntax-rules ()
- ((_ bv offset () ())
- #t)
- ((_ bv offset (type0 types ...) (field0 fields ...))
- (begin
- (write-type bv (align offset type0) type0 field0)
- (write-types bv
- (+ (align offset type0) (type-size type0))
- (types ...) (fields ...))))))
-
-(define-syntax read-type
- (syntax-rules (~ quote *)
- ((_ bv offset '*)
- (make-pointer (bytevector-uint-ref bv offset
- (native-endianness)
- (sizeof* '*))))
- ((_ bv offset (type ~ order))
- (bytevector-uint-ref bv offset
- (endianness order) (sizeof* type)))
- ((_ bv offset type)
- (bytevector-uint-ref bv offset
- (native-endianness) (sizeof* type)))))
-
-(define-syntax read-types
- (syntax-rules ()
- ((_ return bv offset () (values ...))
- (return values ...))
- ((_ return bv offset (type0 types ...) (values ...))
- (read-types return
- bv
- (+ (align offset type0) (type-size type0))
- (types ...)
- (values ... (read-type bv
- (align offset type0)
- type0))))))
-
-(define-syntax define-c-struct
- (syntax-rules ()
- "Define READ as a deserializer and WRITE! as a serializer for the C
-structure with the given TYPES. READ uses WRAP-FIELDS to return its value."
- ((_ name wrap-fields read write! (fields types) ...)
- (begin
- (define (write! bv offset fields ...)
- (write-types bv offset (types ...) (fields ...)))
- (define (read bv offset)
- (read-types wrap-fields bv offset (types ...) ()))))))
-
-
-;;;
;;; Network interfaces.
;;;
@@ -527,6 +687,7 @@ structure with the given TYPES. READ uses WRAP-FIELDS to return its value."
32))
(define-c-struct sockaddr-in ;<linux/in.h>
+ sizeof-sockaddrin
(lambda (family port address)
(make-socket-address family address port))
read-sockaddr-in
@@ -536,6 +697,7 @@ structure with the given TYPES. READ uses WRAP-FIELDS to return its value."
(address (int32 ~ big)))
(define-c-struct sockaddr-in6 ;<linux/in6.h>
+ sizeof-sockaddr-in6
(lambda (family port flowinfo address scopeid)
(make-socket-address family address port flowinfo scopeid))
read-sockaddr-in6
@@ -800,6 +962,7 @@ an <interface> object, and whose cdr is the pointer NEXT."
next))
(define-c-struct ifaddrs ;<ifaddrs.h>
+ %sizeof-ifaddrs
values->interface
read-ifaddrs
write-ifaddrs!
@@ -811,14 +974,6 @@ an <interface> object, and whose cdr is the pointer NEXT."
(broadcastaddr '*)
(data '*))
-(define-syntax %struct-ifaddrs-type
- (identifier-syntax
- `(* * ,unsigned-int * * * *)))
-
-(define-syntax %sizeof-ifaddrs
- (identifier-syntax
- (sizeof* %struct-ifaddrs-type)))
-
(define (unfold-interface-list ptr)
"Call 'read-ifaddrs' on PTR and all its 'next' fields, recursively, and
return the list of resulting <interface> objects."
@@ -826,8 +981,7 @@ return the list of resulting <interface> objects."
(result '()))
(if (null-pointer? ptr)
(reverse result)
- (match (read-ifaddrs (pointer->bytevector ptr %sizeof-ifaddrs)
- 0)
+ (match (read-ifaddrs (pointer->bytevector ptr %sizeof-ifaddrs))
((ifaddr . ptr)
(loop ptr (cons ifaddr result)))))))
@@ -853,4 +1007,186 @@ network interface. This is implemented using the 'getifaddrs' libc function."
(let ((ptr (dynamic-func "freeifaddrs" (dynamic-link))))
(pointer->procedure void ptr '(*))))
+
+;;;
+;;; Terminals.
+;;;
+
+(define-syntax bits->symbols-body
+ (syntax-rules ()
+ ((_ bits () ())
+ '())
+ ((_ bits (name names ...) (value values ...))
+ (let ((result (bits->symbols-body bits (names ...) (values ...))))
+ (if (zero? (logand bits value))
+ result
+ (cons 'name result))))))
+
+(define-syntax define-bits
+ (syntax-rules (define)
+ "Define the given numerical constants under CONSTRUCTOR, such that
+ (CONSTRUCTOR NAME) returns VALUE. Define BITS->SYMBOLS as a procedure that,
+given an integer, returns the list of names of the constants that are or'd."
+ ((_ constructor bits->symbols (define names values) ...)
+ (begin
+ (define-syntax constructor
+ (syntax-rules (names ...)
+ ((_ names) values) ...
+ ((_ several (... ...))
+ (logior (constructor several) (... ...)))))
+ (define (bits->symbols bits)
+ (bits->symbols-body bits (names ...) (values ...)))
+ (define names values) ...))))
+
+;; 'local-flags' bits from <bits/termios.h>
+(define-bits local-flags
+ local-flags->symbols
+ (define ISIG #o0000001)
+ (define ICANON #o0000002)
+ (define XCASE #o0000004)
+ (define ECHO #o0000010)
+ (define ECHOE #o0000020)
+ (define ECHOK #o0000040)
+ (define ECHONL #o0000100)
+ (define NOFLSH #o0000200)
+ (define TOSTOP #o0000400)
+ (define ECHOCTL #o0001000)
+ (define ECHOPRT #o0002000)
+ (define ECHOKE #o0004000)
+ (define FLUSHO #o0010000)
+ (define PENDIN #o0040000)
+ (define IEXTEN #o0100000)
+ (define EXTPROC #o0200000))
+
+;; "Actions" values for 'tcsetattr'.
+(define TCSANOW 0)
+(define TCSADRAIN 1)
+(define TCSAFLUSH 2)
+
+(define-record-type <termios>
+ (termios input-flags output-flags control-flags local-flags
+ line-discipline control-chars
+ input-speed output-speed)
+ termios?
+ (input-flags termios-input-flags)
+ (output-flags termios-output-flags)
+ (control-flags termios-control-flags)
+ (local-flags termios-local-flags)
+ (line-discipline termios-line-discipline)
+ (control-chars termios-control-chars)
+ (input-speed termios-input-speed)
+ (output-speed termios-output-speed))
+
+(define-c-struct %termios ;<bits/termios.h>
+ sizeof-termios
+ termios
+ read-termios
+ write-termios!
+ (input-flags unsigned-int)
+ (output-flags unsigned-int)
+ (control-flags unsigned-int)
+ (local-flags unsigned-int)
+ (line-discipline uint8)
+ (control-chars (array uint8 32))
+ (input-speed unsigned-int)
+ (output-speed unsigned-int))
+
+(define tcgetattr
+ (let ((proc (syscall->procedure int "tcgetattr" (list int '*))))
+ (lambda (fd)
+ "Return the <termios> structure for the tty at FD."
+ (let* ((bv (make-bytevector sizeof-termios))
+ (ret (proc fd (bytevector->pointer bv)))
+ (err (errno)))
+ (if (zero? ret)
+ (read-termios bv)
+ (throw 'system-error "tcgetattr" "~A"
+ (list (strerror err))
+ (list err)))))))
+
+(define tcsetattr
+ (let ((proc (syscall->procedure int "tcsetattr" (list int int '*))))
+ (lambda (fd actions termios)
+ "Use TERMIOS for the tty at FD. ACTIONS is one of 'TCSANOW',
+'TCSADRAIN', or 'TCSAFLUSH'; see tcsetattr(3) for details."
+ (define bv
+ (make-bytevector sizeof-termios))
+
+ (let-syntax ((match/write (syntax-rules ()
+ ((_ fields ...)
+ (match termios
+ (($ <termios> fields ...)
+ (write-termios! bv 0 fields ...)))))))
+ (match/write input-flags output-flags control-flags local-flags
+ line-discipline control-chars input-speed output-speed))
+
+ (let ((ret (proc fd actions (bytevector->pointer bv)))
+ (err (errno)))
+ (unless (zero? ret)
+ (throw 'system-error "tcgetattr" "~A"
+ (list (strerror err))
+ (list err)))))))
+
+(define-syntax TIOCGWINSZ ;<asm-generic/ioctls.h>
+ (identifier-syntax #x5413))
+
+(define-record-type <window-size>
+ (window-size rows columns x-pixels y-pixels)
+ window-size?
+ (rows window-size-rows)
+ (columns window-size-columns)
+ (x-pixels window-size-x-pixels)
+ (y-pixels window-size-y-pixels))
+
+(define-c-struct winsize ;<bits/ioctl-types.h>
+ sizeof-winsize
+ window-size
+ read-winsize
+ write-winsize!
+ (rows unsigned-short)
+ (columns unsigned-short)
+ (x-pixels unsigned-short)
+ (y-pixels unsigned-short))
+
+(define* (terminal-window-size #:optional (port (current-output-port)))
+ "Return a <window-size> structure describing the terminal at PORT, or raise
+a 'system-error' if PORT is not backed by a terminal. This procedure
+corresponds to the TIOCGWINSZ ioctl."
+ (let* ((size (make-bytevector sizeof-winsize))
+ (ret (%ioctl (fileno port) TIOCGWINSZ
+ (bytevector->pointer size)))
+ (err (errno)))
+ (if (zero? ret)
+ (read-winsize size)
+ (throw 'system-error "terminal-window-size" "~A"
+ (list (strerror err))
+ (list err)))))
+
+(define* (terminal-columns #:optional (port (current-output-port)))
+ "Return the best approximation of the number of columns of the terminal at
+PORT, trying to guess a reasonable value if all else fails. The result is
+always a positive integer."
+ (define (fall-back)
+ (match (and=> (getenv "COLUMNS") string->number)
+ (#f 80)
+ ((? number? columns)
+ (if (> columns 0) columns 80))))
+
+ (catch 'system-error
+ (lambda ()
+ (if (file-port? port)
+ (match (window-size-columns (terminal-window-size port))
+ ;; Things like Emacs shell-mode return 0, which is unreasonable.
+ (0 (fall-back))
+ ((? number? columns) columns))
+ (fall-back)))
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ ;; ENOTTY is what we're after but 2012-and-earlier Linux versions
+ ;; would return EINVAL instead in some cases:
+ ;; <https://bugs.ruby-lang.org/issues/10494>.
+ (if (or (= errno ENOTTY) (= errno EINVAL))
+ (fall-back)
+ (apply throw args))))))
+
;;; syscalls.scm ends here
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-22 07:46:41 +0000