/[cmucl]/src/code/run-program.lisp
ViewVC logotype

Diff of /src/code/run-program.lisp

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

revision 1.26 by emarsden, Tue Feb 25 17:22:06 2003 UTC revision 1.26.32.4 by rtoy, Sat Nov 1 22:40:35 2008 UTC
# Line 268  Line 268 
268  #-irix  #-irix
269  (defun find-a-pty ()  (defun find-a-pty ()
270    "Returns the master fd, the slave fd, and the name of the tty"    "Returns the master fd, the slave fd, and the name of the tty"
271    (dolist (char '(#\p #\q))    (multiple-value-bind (error master-fd slave-fd)
272      (dotimes (digit 16)        (unix:unix-openpty nil nil nil)
273        (let* ((master-name (format nil "/dev/pty~C~X" char digit))      (when (zerop error)
274               (master-fd (unix:unix-open master-name        #-glibc2
275                                          unix:o_rdwr        (alien:with-alien ((stuff (alien:struct unix:sgttyb)))
276                                          #o666)))          (let ((sap (alien:alien-sap stuff)))
277          (when master-fd            (unix:unix-ioctl slave-fd unix:TIOCGETP sap)
278            (let* ((slave-name (format nil "/dev/tty~C~X" char digit))            (setf (alien:slot stuff 'unix:sg-flags) #o300) ; EVENP|ODDP
279                   (slave-fd (unix:unix-open slave-name            (unix:unix-ioctl slave-fd unix:TIOCSETP sap)
280                                             unix:o_rdwr            (unix:unix-ioctl master-fd unix:TIOCGETP sap)
281                                             #o666)))            (setf (alien:slot stuff 'unix:sg-flags)
282              (when slave-fd                  (logand (alien:slot stuff 'unix:sg-flags)
283                ; Maybe put a vhangup here?                          (lognot 8)))    ; ~ECHO
284                #-glibc2            (unix:unix-ioctl master-fd unix:TIOCSETP sap)))
285                (alien:with-alien ((stuff (alien:struct unix:sgttyb)))        (return-from find-a-pty
286                  (let ((sap (alien:alien-sap stuff)))                     (values master-fd
287                    (unix:unix-ioctl slave-fd unix:TIOCGETP sap)                             slave-fd
288                    (setf (alien:slot stuff 'unix:sg-flags) #o300) ; EVENP|ODDP                             (unix:unix-ttyname slave-fd))))
289                    (unix:unix-ioctl slave-fd unix:TIOCSETP sap)      (error "Could not find a pty.")))
                   (unix:unix-ioctl master-fd unix:TIOCGETP sap)  
                   (setf (alien:slot stuff 'unix:sg-flags)  
                         (logand (alien:slot stuff 'unix:sg-flags)  
                                 (lognot 8))) ; ~ECHO  
                   (unix:unix-ioctl master-fd unix:TIOCSETP sap)))  
               (return-from find-a-pty  
                            (values master-fd  
                                    slave-fd  
                                    slave-name)))  
           (unix:unix-close master-fd))))))  
   (error "Could not find a pty."))  
290    
291  #+irix  #+irix
292  (alien:def-alien-routine ("_getpty" c-getpty) c-call:c-string  (alien:def-alien-routine ("_getpty" c-getpty) c-call:c-string
# Line 381  Line 370 
370          (let ((n (length s)))          (let ((n (length s)))
371            ;;            ;;
372            ;; Blast the string into place            ;; Blast the string into place
373              #-unicode
374            (kernel:copy-to-system-area (the simple-string s)            (kernel:copy-to-system-area (the simple-string s)
375                                        (* vm:vector-data-offset vm:word-bits)                                        (* vm:vector-data-offset vm:word-bits)
376                                        string-sap 0                                        string-sap 0
377                                        (* (1+ n) vm:byte-bits))                                        (* (1+ n) vm:byte-bits))
378              #+unicode
379              (progn
380                ;; FIXME: Do we need to apply some kind of transformation
381                ;; to convert Lisp unicode strings to C strings?  Utf-8?
382                (dotimes (k n)
383                  (setf (sap-ref-8 string-sap k)
384                        (logand #xff (char-code (aref s k)))))
385                (setf (sap-ref-8 string-sap n) 0))
386            ;;            ;;
387            ;; Blast the pointer to the string into place            ;; Blast the pointer to the string into place
388            (setf (sap-ref-sap vec-sap i) string-sap)            (setf (sap-ref-sap vec-sap i) string-sap)
# Line 625  Line 623 
623                               (error "Could not read input from sub-process: ~A"                               (error "Could not read input from sub-process: ~A"
624                                      (unix:get-unix-error-msg errno)))                                      (unix:get-unix-error-msg errno)))
625                              (t                              (t
626                                 #-unicode
627                               (kernel:copy-from-system-area                               (kernel:copy-from-system-area
628                                (alien-sap buf) 0                                (alien-sap buf) 0
629                                string (* vm:vector-data-offset vm:word-bits)                                string (* vm:vector-data-offset vm:word-bits)
630                                (* count vm:byte-bits))                                (* count vm:byte-bits))
631                                 #+unicode
632                                 (let ((sap (alien-sap buf)))
633                                   (dotimes (k count)
634                                     (setf (aref string k)
635                                           (code-char (sap-ref-8 sap k)))))
636                               (write-string string stream                               (write-string string stream
637                                             :end count)))))))))))                                             :end count)))))))))))
638    

Legend:
Removed from v.1.26  
changed lines
  Added in v.1.26.32.4

  ViewVC Help
Powered by ViewVC 1.1.5