Raymond Toy pushed to branch rtoy-unix-core at cmucl / cmucl
Commits:
-
3a837db1
by Raymond Toy
at 2015-05-06T21:01:31Z
Add support for hemlock.
With these additions, hemlock builds now and runs. (I only tested that
hemlock starts and that text can be entered.)
1 changed file:
Changes:
src/code/unix-glibc2.lisp
--- a/src/code/unix-glibc2.lisp
+++ b/src/code/unix-glibc2.lisp
@@ -1001,6 +1001,10 @@
(declare (type (signed-byte 32) code))
(void-syscall ("exit" int) code))
+(def-alien-routine ("getuid" unix-getuid) int
+ _N"Unix-getuid returns the real user-id associated with the
+ current process.")
+
;;; Unix-chdir accepts a directory name and makes that the
;;; current working directory.
@@ -1109,6 +1113,43 @@
(defconstant prot_exec 4)
(defconstant prot_none 0)
+(defconstant map_shared 1)
+(defconstant map_private 2)
+(defconstant map_fixed 16)
+(defconstant map_anonymous 32)
+
+(defconstant ms_async 1)
+(defconstant ms_sync 4)
+(defconstant ms_invalidate 2)
+
+;; The return value from mmap that means mmap failed.
+(defconstant map_failed (int-sap (1- (ash 1 vm:word-bits))))
+
+(defun unix-mmap (addr length prot flags fd offset)
+ (declare (type (or null system-area-pointer) addr)
+ (type (unsigned-byte 32) length)
+ (type (integer 1 7) prot)
+ (type (unsigned-byte 32) flags)
+ (type (or null unix-fd) fd)
+ (type (signed-byte 32) offset))
+ ;; Can't use syscall, because the address that is returned could be
+ ;; "negative". Hence we explicitly check for mmap returning
+ ;; MAP_FAILED.
+ (let ((result
+ (alien-funcall (extern-alien "mmap" (function system-area-pointer
+ system-area-pointer
+ size-t int int int off-t))
+ (or addr +null+) length prot flags (or fd -1) offset)))
+ (if (sap= result map_failed)
+ (values nil (unix-errno))
+ (values result 0))))
+
+(defun unix-msync (addr length flags)
+ (declare (type system-area-pointer addr)
+ (type (unsigned-byte 32) length)
+ (type (signed-byte 32) flags))
+ (syscall ("msync" system-area-pointer size-t int) t addr length flags))
+
;;; Unix-rename accepts two files names and renames the first to the second.
(defun unix-rename (name1 name2)
@@ -1196,6 +1237,15 @@
(define-ioctl-command TIOCSPGRP #\T #x10)
(define-ioctl-command TIOCGPGRP #\T #x0F)
+;;; ioctl-types.h
+
+(def-alien-type nil
+ (struct winsize
+ (ws-row unsigned-short) ; rows, in characters
+ (ws-col unsigned-short) ; columns, in characters
+ (ws-xpixel unsigned-short) ; horizontal size, pixels
+ (ws-ypixel unsigned-short))) ; veritical size, pixels
+
(defconstant f-getfl 3 _N"Get file flags")
(defconstant f-setfl 4 _N"Set file flags")
@@ -1736,3 +1786,68 @@
(slot (slot itvo 'it-value) 'tv-usec))
which (alien-sap (addr itvn))(alien-sap (addr itvo))))))
+
+(def-alien-type cc-t unsigned-char)
+(def-alien-type speed-t unsigned-int)
+(def-alien-type tcflag-t unsigned-int)
+
+(defconstant +NCCS+ 32
+ _N"Size of control character vector.")
+
+(def-alien-type nil
+ (struct termios
+ (c-iflag tcflag-t)
+ (c-oflag tcflag-t)
+ (c-cflag tcflag-t)
+ (c-lflag tcflag-t)
+ (c-line cc-t)
+ (c-cc (array cc-t #.+NCCS+))
+ (c-ispeed speed-t)
+ (c-ospeed speed-t)))
+
+;; c_cc characters
+
+(defmacro def-enum (inc cur &rest names)
+ (flet ((defform (name)
+ (prog1 (when name `(defconstant ,name ,cur))
+ (setf cur (funcall inc cur 1)))))
+ `(progn ,@(mapcar #'defform names))))
+
+(def-enum + 0 vintr vquit verase
+ vkill veof vtime
+ vmin vswtc vstart
+ vstop vsusp veol
+ vreprint vdiscard vwerase
+ vlnext veol2)
+(defvar vdsusp vsusp)
+
+(def-enum + 0 tcsanow tcsadrain tcsaflush)
+
+;; c_iflag bits
+(def-enum ash 1 tty-ignbrk tty-brkint tty-ignpar tty-parmrk tty-inpck
+ tty-istrip tty-inlcr tty-igncr tty-icrnl tty-iuclc
+ tty-ixon tty-ixany tty-ixoff
+ tty-imaxbel)
+
+;; c_oflag bits
+(def-enum ash 1 tty-opost tty-olcuc tty-onlcr tty-ocrnl tty-onocr
+ tty-onlret tty-ofill tty-ofdel tty-nldly)
+
+;; c_lflag bits
+(def-enum ash 1 tty-isig tty-icanon tty-xcase tty-echo tty-echoe
+ tty-echok tty-echonl tty-noflsh
+ tty-tostop tty-echoctl tty-echoprt
+ tty-echoke tty-flusho
+ tty-pendin tty-iexten)
+
+(defun unix-tcgetattr (fd termios)
+ _N"Get terminal attributes."
+ (declare (type unix-fd fd))
+ (void-syscall ("tcgetattr" int (* (struct termios))) fd termios))
+
+(defun unix-tcsetattr (fd opt termios)
+ _N"Set terminal attributes."
+ (declare (type unix-fd fd))
+ (void-syscall ("tcsetattr" int int (* (struct termios))) fd opt termios))
+
+(defconstant writeown #o200 _N"Write by owner")