/[meta-cvs]/meta-cvs/F-6BD7679FED76D6E5A7D36DC36C205FC1.lisp
ViewVC logotype

Diff of /meta-cvs/F-6BD7679FED76D6E5A7D36DC36C205FC1.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.9 by kaz, Sun Oct 6 05:19:54 2002 UTC revision 1.9.2.8 by kaz, Tue Apr 15 07:19:00 2003 UTC
# Line 2  Line 2 
2  ;;; which is distributed under the GNU license.  ;;; which is distributed under the GNU license.
3  ;;; Copyright 2002 Kaz Kylheku  ;;; Copyright 2002 Kaz Kylheku
4    
5    (require "chatter.lisp")
6    (require "posix")
7  (provide "clisp-unix")  (provide "clisp-unix")
8    
9  ;;; Null pointer handling  ;;; Null pointer handling
# Line 67  Line 69 
69      ((null-to-nil (unix-funcs:opendir dir)))      ((null-to-nil (unix-funcs:opendir dir)))
70      (t (error (make-condition 'open-dir-error :dir dir)))))      (t (error (make-condition 'open-dir-error :dir dir)))))
71    
72    (declaim (inline closedir))
73  (defun closedir (dir-stream)  (defun closedir (dir-stream)
74    (when-not-null dir-stream (unix-funcs:closedir dir-stream)))    (when-not-null dir-stream (unix-funcs:closedir dir-stream)))
75    
 (declaim (inline closedir))  
76    
77  (defun readdir (dir-stream)  (defun readdir (dir-stream)
78    (let ((dir-entry (unix-funcs:readdir dir-stream)))    (let ((dir-entry (unix-funcs:readdir dir-stream)))
# Line 104  Line 106 
106                             :dir (format nil "[file descriptor ~a]" descr))))                             :dir (format nil "[file descriptor ~a]" descr))))
107      (values))      (values))
108    
109  (defun getcwd ()  (define-condition getcwd-error (system-error) ())
110    (unix-funcs:getcwd))  
111    (defmethod initialize-instance :after ((c getcwd-error) &rest args)
112      (declare (ignore args))
113      (with-slots (message) c
114        (setf message (format nil "Unable to determine current directory: ~A."
115                              (unix-funcs:strerror unix-funcs:errno)))))
116    
117  (declaim (inline getcwd))  (declaim (inline getcwd))
118    (defun getcwd ()
119      (or (unix-funcs:getcwd)
120          (error (make-condition 'getcwd-error))))
121    
122  (defmacro current-dir-restore (&body forms)  (defmacro current-dir-restore (&body forms)
123    (let ((saved-dir (gensym "SAVED-DIR-")))    (let ((saved-dir (gensym "SAVED-DIR-")))
# Line 319  Line 330 
330    
331  ;;; Coprocesses  ;;; Coprocesses
332    
 (defconstant *argument-limit* (* 64 1024))  
   
333  (defun shell-interpreter (command)  (defun shell-interpreter (command)
334    (case (shell command)    (case (shell command)
335      ((0) T)      ((0) T)
336      (otherwise nil)))      (otherwise nil)))
337    
338  (defun execute-program (arglist)  (defun execute-program (arglist)
339    (case (run-program (first arglist) :arguments (rest arglist))    (chatter-debug "invoking ~s in directory ~s~%" arglist (getcwd))
340      ((0) T)    (case (unix-funcs:run-program (first arglist) :arguments (rest arglist))
341      (otherwise nil)))      ((0) (chatter-debug "successful termination~%") T)
342        (otherwise (chatter-debug "unsuccessful or abnormal termination~%") nil)))
343    
344  (defmacro with-input-from-program ((stream-var arg-list) &body forms)  (defmacro with-input-from-program ((stream-var arg-list) &body forms)
345   `(let* ((,stream-var (make-pipe-input-stream    (let ((arg-list-sym (gensym "ARG-LIST-")))
346                          (arglist-to-command-string ,arg-list))))      `(let ((,arg-list-sym ,arg-list))
347      (declare (dynamic-extent ,stream-var))         (chatter-debug "piping from ~s in directory ~s~%" ,arg-list-sym (getcwd))
348      (when ,stream-var         (unix-funcs:default-sigchld)
349        (unwind-protect (progn ,@forms) (close ,stream-var)))))         (let* ((,stream-var (make-pipe-input-stream
350                                 (arglist-to-command-string ,arg-list-sym))))
351             (declare (dynamic-extent ,stream-var))
352             (when ,stream-var
353               (unwind-protect (progn ,@forms) (close ,stream-var)))))))
354    
355  (defmacro with-output-to-program ((stream-var arg-list) &body forms)  (defmacro with-output-to-program ((stream-var arg-list) &body forms)
356   `(let* ((,stream-var (make-pipe-output-stream   `(progn
357        (unix-funcs:default-sigchld)
358        (let* ((,stream-var (make-pipe-output-stream
359                          (arglist-to-command-string ,arg-list))))                          (arglist-to-command-string ,arg-list))))
360      (declare (dynamic-extent ,stream-var))        (declare (dynamic-extent ,stream-var))
361      (when ,stream-var        (when ,stream-var
362        (unwind-protect (progn ,@forms) (close ,stream-var)))))          (unwind-protect (progn ,@forms) (close ,stream-var))))))
363    
364  ;;; GUID generation  ;;; GUID generation
365    

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.9.2.8

  ViewVC Help
Powered by ViewVC 1.1.5