src/glisp/dep-cmucl-dtc.lisp

   1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; -*-
   2 ;;; ---------------------------------------------------------------------------
   3 ;;;     Title: CMUCL dependent stuff + fixups
   4 ;;;   Created: 1999-05-25 22:32
   5 ;;;    Author: Gilbert Baumann <gilbert@base-engineering.com>
   6 ;;;   License: MIT style (see below)
   7 ;;; ---------------------------------------------------------------------------
   8 ;;;  (c) copyright 1999 by Gilbert Baumann
   9
  10 ;;;  Permission is hereby granted, free of charge, to any person obtaining
  11 ;;;  a copy of this software and associated documentation files (the
  12 ;;;  "Software"), to deal in the Software without restriction, including
  13 ;;;  without limitation the rights to use, copy, modify, merge, publish,
  14 ;;;  distribute, sublicense, and/or sell copies of the Software, and to
  15 ;;;  permit persons to whom the Software is furnished to do so, subject to
  16 ;;;  the following conditions:
  17 ;;;
  18 ;;;  The above copyright notice and this permission notice shall be
  19 ;;;  included in all copies or substantial portions of the Software.
  20 ;;;
  21 ;;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  22 ;;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  23 ;;;  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  24 ;;;  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  25 ;;;  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  26 ;;;  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  27 ;;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  28
  29 (export 'glisp::read-byte-sequence :glisp)
  30 (export 'glisp::read-char-sequence :glisp)
  31 (export 'glisp::run-unix-shell-command :glisp)
  32
  33 (export 'glisp::getenv :glisp)
  34
  35 (defun glisp::read-byte-sequence (&rest ap)
  36   (apply #'read-sequence ap))
  37
  38 (defun glisp::read-char-sequence (&rest ap)
  39   (apply #'read-sequence ap))
  40
  41 (defun glisp::read-byte-sequence (sequence input &key (start 0) (end (length sequence)))
  42   (let (c (i start))
  43     (loop
  44       (cond ((= i end) (return i)))
  45       (setq c (read-byte input nil :eof))
  46       (cond ((eql c :eof) (return i)))
  47       (setf (aref sequence i) c)
  48       (incf i) )))
  49
  50 (defun glisp::read-byte-sequence (sequence input &key (start 0) (end (length sequence)))
  51   (let ((r (read-sequence sequence input :start start :end end)))
  52     (cond ((and (= r start) (> end start))
  53            (let ((byte (read-byte input nil :eof)))
  54              (cond ((eq byte :eof)
  55                     r)
  56                    (t
  57                     (setf (aref sequence start) byte)
  58                     (incf start)
  59                     (if (> end start)
  60                         (glisp::read-byte-sequence sequence input :start start :end end)
  61                       start)))))
  62           (t
  63            r))))
  64
  65 #||
  66 (defun glisp::read-char-sequence (sequence input &key (start 0) (end (length sequence)))
  67   (let (c (i start))
  68     (loop
  69       (cond ((= i end) (return i)))
  70       (setq c (read-byte input nil :eof))
  71       (cond ((eql c :eof) (return i)))
  72       (setf (aref sequence i) c)
  73       (incf i) )))
  74 ||#
  75
  76 (defmacro glisp::with-timeout ((&rest ignore) &body body)
  77   (declare (ignore ignore))
  78   `(progn
  79      ,@body))
  80
  81 (defun glisp::open-inet-socket (hostname port)
  82   (let ((fd (extensions:connect-to-inet-socket hostname port)))
  83     (values
  84      (sys:make-fd-stream fd
  85                          :input t
  86                          :output t
  87                          :element-type '(unsigned-byte 8)
  88                          :name (format nil "Network connection to ~A:~D" hostname port))
  89      :byte)))
  90
  91 (defun glisp::g/make-string (length &rest options)
  92   (apply #'make-array length :element-type 'base-char options))
  93
  94 #||
  95
  96 RUN-PROGRAM is an external symbol in the EXTENSIONS package.
  97 Function: #<Function RUN-PROGRAM {12E7B79}>
  98 Function arguments:
  99   (program args &key (env *environment-list*) (wait t) pty input
 100    if-input-does-not-exist output (if-output-exists :error) (error :output)
 101    (if-error-exists :error) status-hook)
 102 Function documentation:
 103   Run-program creates a new process and runs the unix progam in the
 104    file specified by the simple-string program.  Args are the standard
 105    arguments that can be passed to a Unix program, for no arguments
 106    use NIL (which means just the name of the program is passed as arg 0).
 107
 108    Run program will either return NIL or a PROCESS structure.  See the CMU
 109    Common Lisp Users Manual for details about the PROCESS structure.
 110
 111    The keyword arguments have the following meanings:
 112      :env -
 113         An A-LIST mapping keyword environment variables to simple-string
 114         values.
 115      :wait -
 116         If non-NIL (default), wait until the created process finishes.  If
 117         NIL, continue running Lisp until the program finishes.
 118      :pty -
 119         Either T, NIL, or a stream.  Unless NIL, the subprocess is established
 120         under a PTY.  If :pty is a stream, all output to this pty is sent to
 121         this stream, otherwise the PROCESS-PTY slot is filled in with a stream
 122         connected to pty that can read output and write input.
 123      :input -
 124         Either T, NIL, a pathname, a stream, or :STREAM.  If T, the standard
 125         input for the current process is inherited.  If NIL, /dev/null
 126         is used.  If a pathname, the file so specified is used.  If a stream,
 127         all the input is read from that stream and send to the subprocess.  If
 128         :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends
 129         its output to the process. Defaults to NIL.
 130      :if-input-does-not-exist (when :input is the name of a file) -
 131         can be one of:
 132            :error - generate an error.
 133            :create - create an empty file.
 134            nil (default) - return nil from run-program.
 135      :output -
 136         Either T, NIL, a pathname, a stream, or :STREAM.  If T, the standard
 137         output for the current process is inherited.  If NIL, /dev/null
 138         is used.  If a pathname, the file so specified is used.  If a stream,
 139         all the output from the process is written to this stream. If
 140         :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
 141         be read to get the output. Defaults to NIL.
 142      :if-output-exists (when :input is the name of a file) -
 143         can be one of:
 144            :error (default) - generates an error if the file already exists.
 145            :supersede - output from the program supersedes the file.
 146            :append - output from the program is appended to the file.
 147            nil - run-program returns nil without doing anything.
 148      :error and :if-error-exists -
 149         Same as :output and :if-output-exists, except that :error can also be
 150         specified as :output in which case all error output is routed to the
 151         same place as normal output.
 152      :status-hook -
 153         This is a function the system calls whenever the status of the
 154         process changes.  The function takes the process as an argument.
 155 Its defined argument types are:
 156   (T T &KEY (:ENV T) (:WAIT T) (:PTY T) (:INPUT T) (:IF-INPUT-DOES-NOT-EXIST T)
 157    (:OUTPUT T) (:IF-OUTPUT-EXISTS T) (:ERROR T) (:IF-ERROR-EXISTS T)
 158    (:STATUS-HOOK T))
 159 Its result type is:
 160   (OR EXTENSIONS::PROCESS NULL)
 161 On Wednesday, 7/1/98 12:48:51 pm [-1] it was compiled from:
 162 target:code/run-program.lisp
 163   Created: Saturday, 6/20/98 07:13:08 pm [-1]
 164   Comment: $Header: /home/david/closure-cvs/cvsroot/closure/src/glisp/Attic/dep-cmucl-dtc.lisp,v 1.3 2006-12-31 12:14:36 dlichteblau Exp $
 165 ||#
 166
 167 ;; (process-exit-code (run-program "/bin/sh" (list "-c" "ls") :wait t :input nil :output nil))
 168
 169 (defun glisp:run-unix-shell-command (command)
 170   (ext:process-exit-code (ext:run-program "/bin/sh" (list "-c" command) :wait t :input nil :output nil)))
 171
 172
 173 ;;; MP
 174
 175 (export 'glisp::mp/process-yield :glisp)
 176 (export 'glisp::mp/process-wait :glisp)
 177 (export 'glisp::mp/process-run-function :glisp)
 178 (export 'glisp::mp/make-lock :glisp)
 179 (export 'glisp::mp/current-process :glisp)
 180 (export 'glisp::mp/process-kill :glisp)
 181
 182 (defun glisp::mp/make-lock (&key name)
 183   (pthread::make-lock name))
 184
 185 (defmacro glisp::mp/with-lock ((lock) &body body)
 186   `(pthread::with-lock-held (,lock)
 187      ,@body))
 188
 189 (defun glisp::mp/process-yield (&optional process-to-run)
 190   (declare (ignore process-to-run))
 191   (PTHREAD:SCHED-YIELD))
 192
 193 (defun glisp::mp/process-wait (whostate predicate)
 194   (do ()
 195       ((funcall predicate))
 196     (sleep .1)))
 197
 198 (defun glisp::mp/process-run-function (name fun &rest args)
 199   (pthread::thread-create
 200    (lambda ()
 201      (apply fun args))
 202    :name name))
 203
 204 (defun glisp::mp/current-process ()
 205   'blah)
 206
 207 (defun glisp::mp/process-kill (process)
 208   (warn "*** Define GLISP:MP/PROCESS-KILL for CMUCL."))
 209
 210 (defun glisp::getenv (string)
 211   (cdr (assoc string ext:*environment-list* :test #'string-equal)))
 212