[cmucl/cmucl][rtoy-unix-core] Add support for hemlock.

[Raymond Toy]

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:

- src/code/unix-glibc2.lisp


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



View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/3a837db16fced7579d6cf12d492fb60ec0e5326b
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20150507/f162a708/attachment.html>