X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Funix.lisp;h=b011c9e6632db48b2d4ab23b8d05379bd42a30b9;hb=dfe6138af5c38d92568b6dac48e852c01be0ec8e;hp=db787af2a7fb82676124c2e99c202a7db6a3fb99;hpb=96399d44ad75b2ee2e36b14d1e0ac773652e80c1;p=sbcl.git

diff --git a/src/code/unix.lisp b/src/code/unix.lisp
index db787af..b011c9e 100644
--- a/src/code/unix.lisp
+++ b/src/code/unix.lisp
@@ -64,21 +64,25 @@
 ;;; implemented using SB!XC:DEFMACRO wrapped in EVAL-WHEN.
 
 (defmacro syscall ((name &rest arg-types) success-form &rest args)
-  `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
+  `(locally
+    (declare (optimize (sb!c::float-accuracy 0)))
+    (let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
 				,@args)))
-     (if (minusp result)
-	 (values nil (get-errno))
-        ,success-form)))
+      (if (minusp result)
+	  (values nil (get-errno))
+	  ,success-form))))
 
 ;;; This is like SYSCALL, but if it fails, signal an error instead of
 ;;; returning error codes. Should only be used for syscalls that will
 ;;; never really get an error.
 (defmacro syscall* ((name &rest arg-types) success-form &rest args)
-  `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
-				,@args)))
-     (if (minusp result)
-	 (error "Syscall ~A failed: ~A" ,name (strerror))
-	 ,success-form)))
+  `(locally
+    (declare (optimize (sb!c::float-accuracy 0)))
+    (let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
+				 ,@args)))
+      (if (minusp result)
+	  (error "Syscall ~A failed: ~A" ,name (strerror))
+	  ,success-form))))
 
 (/show0 "unix.lisp 109")
 
@@ -237,7 +241,7 @@
 
 ;;; UNIX-WRITE accepts a file descriptor, a buffer, an offset, and the
 ;;; length to write. It attempts to write len bytes to the device
-;;; associated with fd from the the buffer starting at offset. It returns
+;;; associated with fd from the buffer starting at offset. It returns
 ;;; the actual number of bytes written.
 (defun unix-write (fd buf offset len)
   (declare (type unix-fd fd)
@@ -293,14 +297,14 @@
   ;; a constant. Going the grovel_headers route doesn't seem to be
   ;; helpful, either, as Solaris doesn't export PATH_MAX from
   ;; unistd.h.
-  #!-(or linux openbsd freebsd sunos osf1 darwin) (,stub,)
-  #!+(or linux openbsd freebsd sunos osf1 darwin)
+  #!-(or linux openbsd freebsd netbsd sunos osf1 darwin) (,stub,)
+  #!+(or linux openbsd freebsd netbsd sunos osf1 darwin)
   (or (newcharstar-string (alien-funcall (extern-alien "getcwd"
 						       (function (* char)
 								 (* char)
 								 size-t))
 					 nil 
-					 #!+(or linux openbsd freebsd darwin) 0
+					 #!+(or linux openbsd freebsd netbsd darwin) 0
 					 #!+(or sunos osf1) 1025))
       (simple-perror "getcwd")))
 
@@ -390,12 +394,6 @@
 	     (cast buf c-string)
 	     (cast buf (* char)) 256)))
 
-;;; Write the core image of the file described by FD to disk.
-(defun unix-fsync (fd)
-  (declare (type unix-fd fd))
-  (void-syscall ("fsync" int) fd))
-
-
 (defun unix-setsid ()
   (int-syscall ("setsid")))
 
@@ -651,19 +649,13 @@
 
 (define-alien-routine get-timezone sb!alien:void
   (when sb!alien:long :in)
-  (minutes-west sb!alien:int :out)
+  (seconds-west sb!alien:int :out)
   (daylight-savings-p sb!alien:boolean :out))
 
-(defun unix-get-minutes-west (secs)
-  (multiple-value-bind (ignore minutes dst) (get-timezone secs)
+(defun unix-get-seconds-west (secs)
+  (multiple-value-bind (ignore seconds dst) (get-timezone secs)
     (declare (ignore ignore) (ignore dst))
-    (values minutes)))
-
-(defun unix-get-timezone (secs)
-  (multiple-value-bind (ignore minutes dst) (get-timezone secs)
-    (declare (ignore ignore) (ignore minutes))
-    (values (deref unix-tzname (if dst 1 0)))))
-
+    (values seconds)))
 
 ;;;; sys/time.h
 
@@ -819,7 +811,7 @@ previous timer after the body has finished executing"
 ;;; paths have been converted to absolute paths, so we don't need to
 ;;; try to handle any more generality than that.
 (defun unix-resolve-links (pathname)
-  (declare (type simple-string pathname))
+  (declare (type simple-base-string pathname))
   (aver (not (relative-unix-pathname? pathname)))
   (/noshow "entering UNIX-RESOLVE-LINKS")
   (loop with previous-pathnames = nil do
@@ -845,7 +837,7 @@ previous timer after the body has finished executing"
 							:from-end t)))
 				 (dir (subseq pathname 0 dir-len)))
 			    (/noshow dir)
-			    (concatenate 'string dir link))
+			    (concatenate 'base-string dir link))
 			  link))))
 		(if (unix-file-kind new-pathname)
 		    (setf pathname new-pathname)
@@ -861,9 +853,9 @@ previous timer after the body has finished executing"
 	    (push pathname previous-pathnames))))
 
 (defun unix-simplify-pathname (src)
-  (declare (type simple-string src))
+  (declare (type simple-base-string src))
   (let* ((src-len (length src))
-	 (dst (make-string src-len))
+	 (dst (make-string src-len :element-type 'base-char))
 	 (dst-len 0)
 	 (dots 0)
 	 (last-slash nil))
@@ -937,7 +929,8 @@ previous timer after the body has finished executing"
 		  (position #\/ dst :end last-slash :from-end t)))
 	     (if prev-prev-slash
 		 (setf dst-len (1+ prev-prev-slash))
-		 (return-from unix-simplify-pathname "./")))))))
+		 (return-from unix-simplify-pathname
+		   (coerce "./" 'simple-base-string))))))))
     (cond ((zerop dst-len)
 	   "./")
 	  ((= dst-len src-len)
@@ -976,7 +969,9 @@ previous timer after the body has finished executing"
     `(multiple-value-bind (,word ,bit) (floor ,offset 32)
        (setf (deref (slot ,fd-set 'fds-bits) ,word)
 	     (logand (deref (slot ,fd-set 'fds-bits) ,word)
-		     (sb!kernel:32bit-logical-not
+                     ;; FIXME: This may not be quite right for 64-bit
+                     ;; ports of SBCL.  --njf, 2004-08-04
+		     (sb!kernel:word-logical-not
 		      (truly-the (unsigned-byte 32) (ash 1 ,bit))))))))
 
 ;;; not checked for linux...