[cmucl/cmucl][master] Move more unix support to core for asdf and slime.

Raymond Toy rtoy at common-lisp.net
Fri Jun 12 04:28:57 UTC 2015


Raymond Toy pushed to branch master at cmucl / cmucl


Commits:
1a20bb57 by Raymond Toy at 2015-06-11T21:28:39Z
Move more unix support to core for asdf and slime.

o The upcoming version of asdf wants to use unix-getenv, so add that
  to the core, removing from the unix contrib.
o Slime wants to use unix-execve and unix-fork, so import that and the
  necessary support routines in to the core from the unix contrib.

- - - - -


4 changed files:

- src/code/exports.lisp
- src/code/unix.lisp
- src/contrib/unix/unix-glibc2.lisp
- src/contrib/unix/unix.lisp


Changes:

=====================================
src/code/exports.lisp
=====================================
--- a/src/code/exports.lisp
+++ b/src/code/exports.lisp
@@ -357,6 +357,15 @@
 	   "FIONREAD"
 	   "TERMINAL-SPEEDS"
 	   )
+  (:export
+   ;; For asdf
+   "UNIX-GETENV"
+   "UNIX-SETENV"
+   "UNIX-PUTENV"
+   "UNIX-UNSETENV"
+   ;; For slime
+   "UNIX-EXECVE"
+   "UNIX-FORK")
   #-(or linux solaris)
   (:export "TCHARS"
 	   "LTCHARS"


=====================================
src/code/unix.lisp
=====================================
--- a/src/code/unix.lisp
+++ b/src/code/unix.lisp
@@ -2517,3 +2517,150 @@
 		      (cast (slot names 'machine) c-string))
 	      #+freebsd 256
 	      (addr names))))
+

+;;; For asdf.  Well, only getenv, but might as well make it symmetric.
+
+;; Environment manipulation; man getenv(3)
+(def-alien-routine ("getenv" unix-getenv) c-call:c-string
+  (name c-call:c-string) 
+  _N"Get the value of the environment variable named Name.  If no such
+  variable exists, Nil is returned.")
+
+;; This doesn't exist in Solaris 8 but does exist in Solaris 10.
+(def-alien-routine ("setenv" unix-setenv) c-call:int
+  (name c-call:c-string)
+  (value c-call:c-string)
+  (overwrite c-call:int)
+  _N"Adds the environment variable named Name to the environment with
+  the given Value if Name does not already exist. If Name does exist,
+  the value is changed to Value if Overwrite is non-zero.  Otherwise,
+  the value is not changed.")
+
+
+(def-alien-routine ("putenv" unix-putenv) c-call:int
+  (name-value c-call:c-string)
+  _N"Adds or changes the environment.  Name-value must be a string of
+  the form \"name=value\".  If the name does not exist, it is added.
+  If name does exist, the value is updated to the given value.")
+
+(def-alien-routine ("unsetenv" unix-unsetenv) c-call:int
+  (name c-call:c-string)
+  _N"Removes the variable Name from the environment")
+
+

+;;; For slime, which wants to use unix-execve.
+
+(defmacro round-bytes-to-words (n)
+  `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3)))
+
+;;;
+;;; STRING-LIST-TO-C-STRVEC	-- Internal
+;;; 
+;;; STRING-LIST-TO-C-STRVEC is a function which takes a list of
+;;; simple-strings and constructs a C-style string vector (strvec) --
+;;; a null-terminated array of pointers to null-terminated strings.
+;;; This function returns two values: a sap and a byte count.  When the
+;;; memory is no longer needed it should be deallocated with
+;;; vm_deallocate.
+;;; 
+(defun string-list-to-c-strvec (string-list)
+  ;;
+  ;; Make a pass over string-list to calculate the amount of memory
+  ;; needed to hold the strvec.
+  (let ((string-bytes 0)
+	(vec-bytes (* 4 (1+ (length string-list)))))
+    (declare (fixnum string-bytes vec-bytes))
+    (dolist (s string-list)
+      (check-type s simple-string)
+      (incf string-bytes (round-bytes-to-words (1+ (length s)))))
+    ;;
+    ;; Now allocate the memory and fill it in.
+    (let* ((total-bytes (+ string-bytes vec-bytes))
+	   (vec-sap (system:allocate-system-memory total-bytes))
+	   (string-sap (sap+ vec-sap vec-bytes))
+	   (i 0))
+      (declare (type (and unsigned-byte fixnum) total-bytes i)
+	       (type system:system-area-pointer vec-sap string-sap))
+      (dolist (s string-list)
+	(declare (simple-string s))
+	(let ((n (length s)))
+	  ;; 
+	  ;; Blast the string into place
+	  #-unicode
+	  (kernel:copy-to-system-area (the simple-string s)
+				      (* vm:vector-data-offset vm:word-bits)
+				      string-sap 0
+				      (* (1+ n) vm:byte-bits))
+	  #+unicode
+	  (progn
+	    ;; FIXME: Do we need to apply some kind of transformation
+	    ;; to convert Lisp unicode strings to C strings?  Utf-8?
+	    (dotimes (k n)
+	      (setf (sap-ref-8 string-sap k)
+		    (logand #xff (char-code (aref s k)))))
+	    (setf (sap-ref-8 string-sap n) 0))
+	  ;; 
+	  ;; Blast the pointer to the string into place
+	  (setf (sap-ref-sap vec-sap i) string-sap)
+	  (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n))))
+	  (incf i 4)))
+      ;; Blast in last null pointer
+      (setf (sap-ref-sap vec-sap i) (int-sap 0))
+      (values vec-sap total-bytes))))
+
+(defun sub-unix-execve (program arg-list env-list)
+  (let ((argv nil)
+	(argv-bytes 0)
+	(envp nil)
+	(envp-bytes 0)
+	result error-code)
+    (unwind-protect
+	(progn
+	  ;; Blast the stuff into the proper format
+	  (multiple-value-setq
+	      (argv argv-bytes)
+	    (string-list-to-c-strvec arg-list))
+	  (multiple-value-setq
+	      (envp envp-bytes)
+	    (string-list-to-c-strvec env-list))
+	  ;;
+	  ;; Now do the system call
+	  (multiple-value-setq
+	      (result error-code)
+	    (int-syscall ("execve"
+			  c-string system-area-pointer system-area-pointer)
+			 program argv envp)))
+      ;; 
+      ;; Deallocate memory
+      (when argv
+	(system:deallocate-system-memory argv argv-bytes))
+      (when envp
+	(system:deallocate-system-memory envp envp-bytes)))
+    (values result error-code)))
+
+;;;; UNIX-EXECVE
+(defun unix-execve (program &optional arg-list
+			    (environment *environment-list*))
+  _N"Executes the Unix execve system call.  If the system call suceeds, lisp
+   will no longer be running in this process.  If the system call fails this
+   function returns two values: NIL and an error code.  Arg-list should be a
+   list of simple-strings which are passed as arguments to the exec'ed program.
+   Environment should be an a-list mapping symbols to simple-strings which this
+   function bashes together to form the environment for the exec'ed program."
+  (check-type program simple-string)
+  (let ((env-list (let ((envlist nil))
+		    (dolist (cons environment)
+		      (push (if (cdr cons)
+				(concatenate 'simple-string
+					     (string (car cons)) "="
+					     (cdr cons))
+				(car cons))
+			    envlist))
+		    envlist)))
+    (sub-unix-execve (%name->file program) arg-list env-list)))
+
+(defun unix-fork ()
+  _N"Executes the unix fork system call.  Returns 0 in the child and the pid
+   of the child in the parent if it works, or NIL and an error number if it
+   doesn't work."
+  (int-syscall ("fork")))


=====================================
src/contrib/unix/unix-glibc2.lisp
=====================================
--- a/src/contrib/unix/unix-glibc2.lisp
+++ b/src/contrib/unix/unix-glibc2.lisp
@@ -1129,61 +1129,6 @@ length LEN and type TYPE."
 
 ;;; unistd.h
 
-(defun sub-unix-execve (program arg-list env-list)
-  (let ((argv nil)
-	(argv-bytes 0)
-	(envp nil)
-	(envp-bytes 0)
-	result error-code)
-    (unwind-protect
-	(progn
-	  ;; Blast the stuff into the proper format
-	  (multiple-value-setq
-	      (argv argv-bytes)
-	    (string-list-to-c-strvec arg-list))
-	  (multiple-value-setq
-	      (envp envp-bytes)
-	    (string-list-to-c-strvec env-list))
-	  ;;
-	  ;; Now do the system call
-	  (multiple-value-setq
-	      (result error-code)
-	    (int-syscall ("execve"
-			  c-string system-area-pointer system-area-pointer)
-			 program argv envp)))
-      ;; 
-      ;; Deallocate memory
-      (when argv
-	(system:deallocate-system-memory argv argv-bytes))
-      (when envp
-	(system:deallocate-system-memory envp envp-bytes)))
-    (values result error-code)))
-
-;;;; UNIX-EXECVE
-
-(defun unix-execve (program &optional arg-list
-			    (environment *environment-list*))
-  _N"Executes the Unix execve system call.  If the system call suceeds, lisp
-   will no longer be running in this process.  If the system call fails this
-   function returns two values: NIL and an error code.  Arg-list should be a
-   list of simple-strings which are passed as arguments to the exec'ed program.
-   Environment should be an a-list mapping symbols to simple-strings which this
-   function bashes together to form the environment for the exec'ed program."
-  (check-type program simple-string)
-  (let ((env-list (let ((envlist nil))
-		    (dolist (cons environment)
-		      (push (if (cdr cons)
-				(concatenate 'simple-string
-					     (string (car cons)) "="
-					     (cdr cons))
-				(car cons))
-			    envlist))
-		    envlist)))
-    (sub-unix-execve (%name->file program) arg-list env-list)))
-
-
-(defmacro round-bytes-to-words (n)
-  `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3)))
 
 (defun unix-chown (path uid gid)
   _N"Given a file path, an integer user-id, and an integer group-id,
@@ -1328,37 +1273,6 @@ length LEN and type TYPE."
    returned if the call fails."
   (void-syscall ("setregid" int int) rgid egid))
 
-(defun unix-fork ()
-  _N"Executes the unix fork system call.  Returns 0 in the child and the pid
-   of the child in the parent if it works, or NIL and an error number if it
-   doesn't work."
-  (int-syscall ("fork")))
-
-;; Environment maninpulation; man getenv(3)
-(def-alien-routine ("getenv" unix-getenv) c-call:c-string
-  (name c-call:c-string) 
-  _N"Get the value of the environment variable named Name.  If no such
-  variable exists, Nil is returned.")
-
-(def-alien-routine ("setenv" unix-setenv) c-call:int
-  (name c-call:c-string)
-  (value c-call:c-string)
-  (overwrite c-call:int)
-  _N"Adds the environment variable named Name to the environment with
-  the given Value if Name does not already exist. If Name does exist,
-  the value is changed to Value if Overwrite is non-zero.  Otherwise,
-  the value is not changed.")
-
-(def-alien-routine ("putenv" unix-putenv) c-call:int
-  (name c-call:c-string)
-  _N"Adds or changes the environment.  Name-value must be a string of
-  the form \"name=value\".  If the name does not exist, it is added.
-  If name does exist, the value is updated to the given value.")
-
-(def-alien-routine ("unsetenv" unix-unsetenv) c-call:int
-  (name c-call:c-string)
-  _N"Removes the variable Name from the environment")
-
 ;;; Unix-link creates a hard link from name2 to name1.
 
 (defun unix-link (name1 name2)
@@ -1888,61 +1802,6 @@ in at a time in poll.")
 (export '(unix-file-kind unix-maybe-prepend-current-directory
 	  unix-resolve-links unix-simplify-pathname))
 
-;;;
-;;; STRING-LIST-TO-C-STRVEC	-- Internal
-;;; 
-;;; STRING-LIST-TO-C-STRVEC is a function which takes a list of
-;;; simple-strings and constructs a C-style string vector (strvec) --
-;;; a null-terminated array of pointers to null-terminated strings.
-;;; This function returns two values: a sap and a byte count.  When the
-;;; memory is no longer needed it should be deallocated with
-;;; vm_deallocate.
-;;; 
-(defun string-list-to-c-strvec (string-list)
-  ;;
-  ;; Make a pass over string-list to calculate the amount of memory
-  ;; needed to hold the strvec.
-  (let ((string-bytes 0)
-	(vec-bytes (* 4 (1+ (length string-list)))))
-    (declare (fixnum string-bytes vec-bytes))
-    (dolist (s string-list)
-      (check-type s simple-string)
-      (incf string-bytes (round-bytes-to-words (1+ (length s)))))
-    ;;
-    ;; Now allocate the memory and fill it in.
-    (let* ((total-bytes (+ string-bytes vec-bytes))
-	   (vec-sap (system:allocate-system-memory total-bytes))
-	   (string-sap (sap+ vec-sap vec-bytes))
-	   (i 0))
-      (declare (type (and unsigned-byte fixnum) total-bytes i)
-	       (type system:system-area-pointer vec-sap string-sap))
-      (dolist (s string-list)
-	(declare (simple-string s))
-	(let ((n (length s)))
-	  ;; 
-	  ;; Blast the string into place
-	  #-unicode
-	  (kernel:copy-to-system-area (the simple-string s)
-				      (* vm:vector-data-offset vm:word-bits)
-				      string-sap 0
-				      (* (1+ n) vm:byte-bits))
-	  #+unicode
-	  (progn
-	    ;; FIXME: Do we need to apply some kind of transformation
-	    ;; to convert Lisp unicode strings to C strings?  Utf-8?
-	    (dotimes (k n)
-	      (setf (sap-ref-8 string-sap k)
-		    (logand #xff (char-code (aref s k)))))
-	    (setf (sap-ref-8 string-sap n) 0))
-	  ;; 
-	  ;; Blast the pointer to the string into place
-	  (setf (sap-ref-sap vec-sap i) string-sap)
-	  (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n))))
-	  (incf i 4)))
-      ;; Blast in last null pointer
-      (setf (sap-ref-sap vec-sap i) (int-sap 0))
-      (values vec-sap total-bytes))))
-
 ;;; Stuff not yet found in the header files...
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


=====================================
src/contrib/unix/unix.lisp
=====================================
--- a/src/contrib/unix/unix.lisp
+++ b/src/contrib/unix/unix.lisp
@@ -634,159 +634,12 @@
    group leader. NIL and an error number are returned upon failure."
   (void-syscall ("setpgid" int int) pid pgrp))
 
-(defun unix-fork ()
-  _N"Executes the unix fork system call.  Returns 0 in the child and the pid
-   of the child in the parent if it works, or NIL and an error number if it
-   doesn't work."
-  (int-syscall ("fork")))
-
-;; Environment manipulation; man getenv(3)
-(def-alien-routine ("getenv" unix-getenv) c-call:c-string
-  (name c-call:c-string) 
-  _N"Get the value of the environment variable named Name.  If no such
-  variable exists, Nil is returned.")
-
-;; This doesn't exist in Solaris 8 but does exist in Solaris 10.
-(def-alien-routine ("setenv" unix-setenv) c-call:int
-  (name c-call:c-string)
-  (value c-call:c-string)
-  (overwrite c-call:int)
-  _N"Adds the environment variable named Name to the environment with
-  the given Value if Name does not already exist. If Name does exist,
-  the value is changed to Value if Overwrite is non-zero.  Otherwise,
-  the value is not changed.")
-
-
-(def-alien-routine ("putenv" unix-putenv) c-call:int
-  (name-value c-call:c-string)
-  _N"Adds or changes the environment.  Name-value must be a string of
-  the form \"name=value\".  If the name does not exist, it is added.
-  If name does exist, the value is updated to the given value.")
-
-;; This doesn't exist in Solaris 8 but does exist in Solaris 10.
-(def-alien-routine ("unsetenv" unix-unsetenv) c-call:int
-  (name c-call:c-string)
-  _N"Removes the variable Name from the environment")
-
 

 ;;;; Support routines for dealing with unix pathnames.
 
 (export '(unix-file-kind unix-maybe-prepend-current-directory
 	  unix-resolve-links unix-simplify-pathname))
 
-

-;;;; UNIX-EXECVE
-
-(defun unix-execve (program &optional arg-list
-			    (environment *environment-list*))
-  _N"Executes the Unix execve system call.  If the system call suceeds, lisp
-   will no longer be running in this process.  If the system call fails this
-   function returns two values: NIL and an error code.  Arg-list should be a
-   list of simple-strings which are passed as arguments to the exec'ed program.
-   Environment should be an a-list mapping symbols to simple-strings which this
-   function bashes together to form the environment for the exec'ed program."
-  (check-type program simple-string)
-  (let ((env-list (let ((envlist nil))
-		    (dolist (cons environment)
-		      (push (if (cdr cons)
-				(concatenate 'simple-string
-					     (string (car cons)) "="
-					     (cdr cons))
-				(car cons))
-			    envlist))
-		    envlist)))
-    (sub-unix-execve (%name->file program) arg-list env-list)))
-
-
-(defmacro round-bytes-to-words (n)
-  `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3)))
-
-;;;
-;;; STRING-LIST-TO-C-STRVEC	-- Internal
-;;; 
-;;; STRING-LIST-TO-C-STRVEC is a function which takes a list of
-;;; simple-strings and constructs a C-style string vector (strvec) --
-;;; a null-terminated array of pointers to null-terminated strings.
-;;; This function returns two values: a sap and a byte count.  When the
-;;; memory is no longer needed it should be deallocated with
-;;; vm_deallocate.
-;;; 
-(defun string-list-to-c-strvec (string-list)
-  ;;
-  ;; Make a pass over string-list to calculate the amount of memory
-  ;; needed to hold the strvec.
-  (let ((string-bytes 0)
-	(vec-bytes (* 4 (1+ (length string-list)))))
-    (declare (fixnum string-bytes vec-bytes))
-    (dolist (s string-list)
-      (check-type s simple-string)
-      (incf string-bytes (round-bytes-to-words (1+ (length s)))))
-    ;;
-    ;; Now allocate the memory and fill it in.
-    (let* ((total-bytes (+ string-bytes vec-bytes))
-	   (vec-sap (system:allocate-system-memory total-bytes))
-	   (string-sap (sap+ vec-sap vec-bytes))
-	   (i 0))
-      (declare (type (and unsigned-byte fixnum) total-bytes i)
-	       (type system:system-area-pointer vec-sap string-sap))
-      (dolist (s string-list)
-	(declare (simple-string s))
-	(let ((n (length s)))
-	  ;; 
-	  ;; Blast the string into place
-	  #-unicode
-	  (kernel:copy-to-system-area (the simple-string s)
-				      (* vm:vector-data-offset vm:word-bits)
-				      string-sap 0
-				      (* (1+ n) vm:byte-bits))
-	  #+unicode
-	  (progn
-	    ;; FIXME: Do we need to apply some kind of transformation
-	    ;; to convert Lisp unicode strings to C strings?  Utf-8?
-	    (dotimes (k n)
-	      (setf (sap-ref-8 string-sap k)
-		    (logand #xff (char-code (aref s k)))))
-	    (setf (sap-ref-8 string-sap n) 0))
-	  
-	  ;; 
-	  ;; Blast the pointer to the string into place
-	  (setf (sap-ref-sap vec-sap i) string-sap)
-	  (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n))))
-	  (incf i 4)))
-      ;; Blast in last null pointer
-      (setf (sap-ref-sap vec-sap i) (int-sap 0))
-      (values vec-sap total-bytes))))
-
-(defun sub-unix-execve (program arg-list env-list)
-  (let ((argv nil)
-	(argv-bytes 0)
-	(envp nil)
-	(envp-bytes 0)
-	result error-code)
-    (unwind-protect
-	(progn
-	  ;; Blast the stuff into the proper format
-	  (multiple-value-setq
-	      (argv argv-bytes)
-	    (string-list-to-c-strvec arg-list))
-	  (multiple-value-setq
-	      (envp envp-bytes)
-	    (string-list-to-c-strvec env-list))
-	  ;;
-	  ;; Now do the system call
-	  (multiple-value-setq
-	      (result error-code)
-	    (int-syscall ("execve"
-			  c-string system-area-pointer system-area-pointer)
-			 program argv envp)))
-      ;; 
-      ;; Deallocate memory
-      (when argv
-	(system:deallocate-system-memory argv argv-bytes))
-      (when envp
-	(system:deallocate-system-memory envp envp-bytes)))
-    (values result error-code)))
-
 
 

 ;;;



View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/1a20bb5731c5774c29f25ef3d0a2fb6cd1561aac
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20150612/4e638031/attachment-0001.html>


More information about the cmucl-cvs mailing list