src/glisp/dep-cmucl.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 <unk6@rz.uni-karlsruhe.de>
   6 ;;;   License: GPL (See file COPYING for details).
   7 ;;; ---------------------------------------------------------------------------
   8 ;;;  (c) copyright 1999 by Gilbert Baumann
   9
  10 ;;; This program is free software; you can redistribute it and/or modify
  11 ;;; it under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 2 of the License, or
  13 ;;; (at your option) any later version.
  14 ;;;
  15 ;;; This program is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with this program; if not, write to the Free Software
  22 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  23
  24 (export 'glisp::read-byte-sequence :glisp)
  25 (export 'glisp::read-char-sequence :glisp)
  26 (export 'glisp::run-unix-shell-command :glisp)
  27
  28 (export 'glisp::getenv :glisp)
  29
  30 (export 'glisp::make-server-socket :glisp)
  31 (export 'glisp::close-server-socket :glisp)
  32
  33 (defun glisp::read-byte-sequence (&rest ap)
  34   (apply #'read-sequence ap))
  35
  36 (defun glisp::read-char-sequence (&rest ap)
  37   (apply #'read-sequence ap))
  38
  39 (defun glisp::read-byte-sequence (sequence input &key (start 0) (end (length sequence)))
  40   (let (c (i start))
  41     (loop
  42       (cond ((= i end) (return i)))
  43       (setq c (read-byte input nil :eof))
  44       (cond ((eql c :eof) (return i)))
  45       (setf (aref sequence i) c)
  46       (incf i) )))
  47
  48 (defun glisp::read-byte-sequence (sequence input &key (start 0) (end (length sequence)))
  49   (let ((r (read-sequence sequence input :start start :end end)))
  50     (cond ((and (= r start) (> end start))
  51            (let ((byte (read-byte input nil :eof)))
  52              (cond ((eq byte :eof)
  53                     r)
  54                    (t
  55                     (setf (aref sequence start) byte)
  56                     (incf start)
  57                     (if (> end start)
  58                         (glisp::read-byte-sequence sequence input :start start :end end)
  59                       start)))))
  60           (t
  61            r))))
  62
  63 #||
  64 (defun glisp::read-char-sequence (sequence input &key (start 0) (end (length sequence)))
  65   (let (c (i start))
  66     (loop
  67       (cond ((= i end) (return i)))
  68       (setq c (read-byte input nil :eof))
  69       (cond ((eql c :eof) (return i)))
  70       (setf (aref sequence i) c)
  71       (incf i) )))
  72 ||#
  73
  74 (defmacro glisp::with-timeout ((&rest ignore) &body body)
  75   (declare (ignore ignore))
  76   `(progn
  77      ,@body))
  78
  79 (defun glisp::open-inet-socket (hostname port)
  80   (let ((fd (extensions:connect-to-inet-socket hostname port)))
  81     (values
  82      (sys:make-fd-stream fd
  83                          :input t
  84                          :output t
  85                          :element-type '(unsigned-byte 8)
  86                          :name (format nil "Network connection to ~A:~D" hostname port))
  87      :byte)))
  88
  89 (defstruct (server-socket (:constructor make-server-socket-struct))
  90   fd
  91   element-type
  92   port)
  93
  94 (defun glisp::make-server-socket (port &key (element-type '(unsigned-byte 8)))
  95   (make-server-socket-struct :fd (ext:create-inet-listener port)
  96                              :element-type element-type
  97                              :port port))
  98
  99 (defun glisp::accept-connection/low (socket)
 100   (mp:process-wait-until-fd-usable (server-socket-fd socket) :input)
 101   (values
 102    (sys:make-fd-stream (ext:accept-tcp-connection (server-socket-fd socket))
 103                        :input t :output t
 104                        :element-type (server-socket-element-type socket))
 105    (cond ((subtypep (server-socket-element-type socket) 'integer)
 106           :byte)
 107          (t
 108           :char))))
 109
 110 (defun glisp::close-server-socket (socket)
 111   (unix:unix-close (server-socket-fd socket)))
 112
 113 ;;;;;;
 114
 115 (defun glisp::g/make-string (length &rest options)
 116   (apply #'make-array length :element-type 'base-char options))
 117
 118
 119
 120 #||
 121
 122 RUN-PROGRAM is an external symbol in the EXTENSIONS package.
 123 Function: #<Function RUN-PROGRAM {12E7B79}>
 124 Function arguments:
 125   (program args &key (env *environment-list*) (wait t) pty input
 126    if-input-does-not-exist output (if-output-exists :error) (error :output)
 127    (if-error-exists :error) status-hook)
 128 Function documentation:
 129   Run-program creates a new process and runs the unix progam in the
 130    file specified by the simple-string program.  Args are the standard
 131    arguments that can be passed to a Unix program, for no arguments
 132    use NIL (which means just the name of the program is passed as arg 0).
 133
 134    Run program will either return NIL or a PROCESS structure.  See the CMU
 135    Common Lisp Users Manual for details about the PROCESS structure.
 136
 137    The keyword arguments have the following meanings:
 138      :env -
 139         An A-LIST mapping keyword environment variables to simple-string
 140         values.
 141      :wait -
 142         If non-NIL (default), wait until the created process finishes.  If
 143         NIL, continue running Lisp until the program finishes.
 144      :pty -
 145         Either T, NIL, or a stream.  Unless NIL, the subprocess is established
 146         under a PTY.  If :pty is a stream, all output to this pty is sent to
 147         this stream, otherwise the PROCESS-PTY slot is filled in with a stream
 148         connected to pty that can read output and write input.
 149      :input -
 150         Either T, NIL, a pathname, a stream, or :STREAM.  If T, the standard
 151         input for the current process is inherited.  If NIL, /dev/null
 152         is used.  If a pathname, the file so specified is used.  If a stream,
 153         all the input is read from that stream and send to the subprocess.  If
 154         :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends
 155         its output to the process. Defaults to NIL.
 156      :if-input-does-not-exist (when :input is the name of a file) -
 157         can be one of:
 158            :error - generate an error.
 159            :create - create an empty file.
 160            nil (default) - return nil from run-program.
 161      :output -
 162         Either T, NIL, a pathname, a stream, or :STREAM.  If T, the standard
 163         output for the current process is inherited.  If NIL, /dev/null
 164         is used.  If a pathname, the file so specified is used.  If a stream,
 165         all the output from the process is written to this stream. If
 166         :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
 167         be read to get the output. Defaults to NIL.
 168      :if-output-exists (when :input is the name of a file) -
 169         can be one of:
 170            :error (default) - generates an error if the file already exists.
 171            :supersede - output from the program supersedes the file.
 172            :append - output from the program is appended to the file.
 173            nil - run-program returns nil without doing anything.
 174      :error and :if-error-exists -
 175         Same as :output and :if-output-exists, except that :error can also be
 176         specified as :output in which case all error output is routed to the
 177         same place as normal output.
 178      :status-hook -
 179         This is a function the system calls whenever the status of the
 180         process changes.  The function takes the process as an argument.
 181 Its defined argument types are:
 182   (T T &KEY (:ENV T) (:WAIT T) (:PTY T) (:INPUT T) (:IF-INPUT-DOES-NOT-EXIST T)
 183    (:OUTPUT T) (:IF-OUTPUT-EXISTS T) (:ERROR T) (:IF-ERROR-EXISTS T)
 184    (:STATUS-HOOK T))
 185 Its result type is:
 186   (OR EXTENSIONS::PROCESS NULL)
 187 On Wednesday, 7/1/98 12:48:51 pm [-1] it was compiled from:
 188 target:code/run-program.lisp
 189   Created: Saturday, 6/20/98 07:13:08 pm [-1]
 190   Comment: $Header: /home/david/closure-cvs/cvsroot/closure/src/glisp/dep-cmucl.lisp,v 1.1.1.1 2002-07-22 02:27:22 gilbert Exp $
 191 ||#
 192
 193 ;; (process-exit-code (run-program "/bin/sh" (list "-c" "ls") :wait t :input nil :output nil))
 194
 195 (defun glisp:run-unix-shell-command (command)
 196   (ext:process-exit-code (ext:run-program "/bin/sh" (list "-c" command) :wait t :input nil :output nil)))
 197
 198 (defmacro glisp::defsubst (name args &body body)
 199   `(progn
 200      (declaim (inline ,name))
 201      (defun ,name ,args .,body)))
 202
 203
 204 ;;; MP
 205
 206 (export 'glisp::mp/process-yield :glisp)
 207 (export 'glisp::mp/process-wait :glisp)
 208 (export 'glisp::mp/process-run-function :glisp)
 209 (export 'glisp::mp/make-lock :glisp)
 210 (export 'glisp::mp/current-process :glisp)
 211 (export 'glisp::mp/process-kill :glisp)
 212
 213 (defun glisp::mp/make-lock (&key name)
 214   (mp:make-lock name))
 215
 216 (defmacro glisp::mp/with-lock ((lock) &body body)
 217   `(mp:with-lock-held (,lock)
 218      ,@body))
 219
 220 (defun glisp::mp/process-yield (&optional process-to-run)
 221   (declare (ignore process-to-run))
 222   (mp:process-yield))
 223
 224 (defun glisp::mp/process-wait (whostate predicate)
 225   (mp:process-wait whostate predicate))
 226
 227 (defun glisp::mp/process-run-function (name fun &rest args)
 228   (mp:make-process
 229    (lambda ()
 230      (apply fun args))
 231    :name name))
 232
 233 (defun glisp::mp/current-process ()
 234   mp:*current-process*)
 235
 236 (defun glisp::mp/process-kill (process)
 237   (mp:destroy-process process))
 238
 239 (defun glisp::getenv (string)
 240   (cdr (assoc string ext:*environment-list* :test #'string-equal)))
 241