X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/5e04ac396871d9b15a4cbcdb7de9084b650176f0..ad8995ca2397db9b5d9e1d3357d5e1a6730fdfe4:/unix.lisp

diff --git a/unix.lisp b/unix.lisp
index 8f9cd3e..3a01dd2 100644
--- a/unix.lisp
+++ b/unix.lisp
@@ -26,8 +26,12 @@
 (defpackage #:mdw.unix
   (:use #:common-lisp #:mdw.base #:mdw.collect)
   (:export #:unix-error #:errno-value #:with-errno-handlers
-	   #:unix-try-func #:unix-try
-	   #:stat
+	   #:syscall #:syscall*
+	   #:stat #:sys-stat
+	   #:sys-open #:sys-close #:sys-read #:sys-write
+	   #:sys-chown #:sys-fchown #:sys-chmod #:sys-fchmod
+	   #:sys-utimes #:sys-unlink #:sys-rename
+	   #:sys-gettimeofday #:sys-gethostname
 	   #:with-unix-open #:copy-file))
 (in-package #:mdw.unix)
 
@@ -42,6 +46,7 @@ buffer of LEN bytes."
 	     (setf ,var (system:allocate-system-memory ,lenvar))
 	     ,@body)
 	 (when ,var (system:deallocate-system-memory ,var ,lenvar))))))
+
 (define-condition unix-error (error)
   ((func :initform 'unknown :initarg :func :reader unix-error-func)
    (args :initform nil :initarg :args :reader unix-error-args)
@@ -52,11 +57,13 @@ buffer of LEN bytes."
 		     (unix:get-unix-error-msg (unix-error-errno c))
 		     (unix-error-errno c))))
   (:documentation "Reports an error from a Unix system call."))
+
 (compile-time-defun errno-value (err)
     "Returns the numeric value corresponding to an errno name."
     (etypecase err
       (integer err)
       (symbol (symbol-value (intern (symbol-name err) :unix)))))
+
 (defmacro with-errno-handlers ((&key cond
 				     (errno (gensym))
 				     errstring)
@@ -101,7 +108,8 @@ numbers."
 				       (progn ,@(cdr cl)))))
 			 clauses
 			 labels)))))))))
-(defun unix-try-func (name func &rest args)
+
+(defun syscall* (name func &rest args)
   "Call Unix system call FUNC, passing it ARGS.  If it returns an error,
 signal the unix-error condition, with NAME and ARGS."
   (multiple-value-call (lambda (rc &rest stuff)
@@ -112,29 +120,48 @@ signal the unix-error condition, with NAME and ARGS."
 				  :errno (car stuff)))
 			 (apply #'values rc stuff))
 		       (apply func args)))
-(defmacro unix-try (syscall &rest args)
-  "Wrapper for unix-try-func.  Call Unix system-call SYSCALL (without the
-`unix-' prefix or other stuff), passing it ARGS."
-  (let ((func (intern (format nil "UNIX-~A" (symbol-name syscall)) :unix)))
-    `(unix-try-func ',syscall #',func ,@args)))
-(macrolet ((doit (slots)
+(defmacro syscall (func &rest args)
+  "Call Unix system call FUNC, passing it ARGS.  If it returns an error,
+signal the unix-error condition, with FUNC and ARGS."
+  `(syscall* ',func ,func ,@args))
+
+(macrolet ((doit (doc slots)
 	     `(defstruct (stat (:predicate statp)
 			       (:conc-name st-)
 			       (:constructor %make-stat-boa ,slots))
-		"Structure representing all the useful information `stat'
-returns about a file."
-		,@slots)))
-  (doit (dev ino mode nlink uid gid rdev size
-	 atime mtime ctime blksize blocks)))
-(defun stat (file)
+	        ,doc
+	        ,@slots)))
+  (doit
+   "Structure representing all the useful information `stat' returns about
+a file."
+   (dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks)))
+(defun sys-stat (file)
   "Return information about FILE in a structure rather than as inconvenient
 multiple values."
-  (multiple-value-call (lambda (rc &rest results)
-			 (unless rc
-			   (error 'unix-error :func 'stat :args (list file)
-				  :error (car results)))
-			 (apply #'%make-stat-boa results))
-		       (unix:unix-stat file)))
+  (multiple-value-call
+      (lambda (rc &rest results)
+	(unless rc
+	  (error 'unix-error
+		 :func 'sys-stat :args (list file)
+		 :error (car results)))
+	(apply #'%make-stat-boa results))
+    (unix:unix-stat file)))
+
+(defmacro defsyscall (name)
+  (let ((sysname (intern (format nil "SYS-~:@(~A~)" name)))
+	(unixname (intern (format nil "UNIX-~:@(~A~)" name) :unix)))
+    `(defun ,sysname (&rest args)
+       (apply #'syscall* ',sysname #',unixname args))))
+
+(macrolet ((defsys (&rest names)
+	     `(progn ,@(mapcar (lambda (name) 
+				 `(defsyscall ,name))
+			       names))))
+  (defsys open close read write
+	  chown fchown chmod fchmod utimes
+	  unlink rename
+	  gethostname gettimeofday))
+
 (defmacro with-unix-open ((fd file how &optional (mode #o666)) &body body)
   "Evaluate BODY with FD bound to a file descriptor obtained from a Unix
 `open' syscall with arguments FILE, HOW and MODE.  Close the file descriptor
@@ -142,29 +169,30 @@ when BODY is done."
   `(let (,fd)
      (unwind-protect
 	 (progn
-	   (setf ,fd (unix-try open ,file ,how ,mode))
+	   (setf ,fd (sys-open ,file ,how ,mode))
 	   ,@body)
-       (when ,fd (unix-try close ,fd)))))
+       (when ,fd (sys-close ,fd)))))
+
 (defun copy-file (from to &optional (how 0))
   "Make a copy of the file FROM called TO.  The copy has the same permissions
 and timestamps (except for ctime) and attempts to have the same owner and
 group as the original."
-  (let ((st (stat from)))
-    (with-unix-open (in from unix:o_rdonly)
+  (let ((st (sys-stat from)))
+    (with-unix-open (in from unix:O_RDONLY)
       (with-unix-open (out
 		       to
-		       (logior unix:o_wronly unix:o_creat how)
+		       (logior unix:O_WRONLY unix:O_CREAT how)
 		       (logand (st-mode st) #o777))
-        (unix-try fchmod out (st-mode st))
-	(unix-try utimes to (st-atime st) 0 (st-mtime st) 0)
+        (sys-fchmod out (st-mode st))
+	(sys-utimes to (st-atime st) 0 (st-mtime st) 0)
 	(with-errno-handlers ()
-	  (unix-try fchown out (st-uid st) (st-gid st))
+	  (sys-fchown out (st-uid st) (st-gid st))
 	  (eperm nil))
 	(with-buffer (buf 16384)
 	  (loop
-	    (let ((n (unix-try read in buf 16384)))
+	    (let ((n (sys-read in buf 16384)))
 	      (when (zerop n)
 		(return))
-	      (unix-try write out buf 0 n))))))))
+	      (sys-write out buf 0 n))))))))
 
 ;;;----- That's all, folks --------------------------------------------------