[closure-cvs] CVS closure/src/glisp
dlichteblau
dlichteblau at common-lisp.net
Sun Dec 31 13:11:44 UTC 2006
Update of /project/closure/cvsroot/closure/src/glisp
In directory clnet:/tmp/cvs-serv15409/src/glisp
Added Files:
dep-scl.lisp
Removed Files:
dep-cmucl-dtc.lisp
Log Message:
Based on the assumption that (and cmucl pthread) is actually code for
Scieneer CL, rename dep-cmucl-dtc to dep-scl.
--- /project/closure/cvsroot/closure/src/glisp/dep-scl.lisp 2006/12/31 13:11:44 NONE
+++ /project/closure/cvsroot/closure/src/glisp/dep-scl.lisp 2006/12/31 13:11:44 1.1
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; -*-
;;; ---------------------------------------------------------------------------
;;; Title: [Originally CMUCL dependent stuff + fixups], probably for SCL
;;; Created: 1999-05-25 22:32
;;; Author: Gilbert Baumann <gilbert at base-engineering.com>
;;; License: MIT style (see below)
;;; ---------------------------------------------------------------------------
;;; (c) copyright 1999 by Gilbert Baumann
;;; Permission is hereby granted, free of charge, to any person obtaining
;;; a copy of this software and associated documentation files (the
;;; "Software"), to deal in the Software without restriction, including
;;; without limitation the rights to use, copy, modify, merge, publish,
;;; distribute, sublicense, and/or sell copies of the Software, and to
;;; permit persons to whom the Software is furnished to do so, subject to
;;; the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
(export 'glisp::read-byte-sequence :glisp)
(export 'glisp::read-char-sequence :glisp)
(export 'glisp::run-unix-shell-command :glisp)
(export 'glisp::getenv :glisp)
(defun glisp::read-byte-sequence (&rest ap)
(apply #'read-sequence ap))
(defun glisp::read-char-sequence (&rest ap)
(apply #'read-sequence ap))
(defun glisp::read-byte-sequence (sequence input &key (start 0) (end (length sequence)))
(let (c (i start))
(loop
(cond ((= i end) (return i)))
(setq c (read-byte input nil :eof))
(cond ((eql c :eof) (return i)))
(setf (aref sequence i) c)
(incf i) )))
(defun glisp::read-byte-sequence (sequence input &key (start 0) (end (length sequence)))
(let ((r (read-sequence sequence input :start start :end end)))
(cond ((and (= r start) (> end start))
(let ((byte (read-byte input nil :eof)))
(cond ((eq byte :eof)
r)
(t
(setf (aref sequence start) byte)
(incf start)
(if (> end start)
(glisp::read-byte-sequence sequence input :start start :end end)
start)))))
(t
r))))
#||
(defun glisp::read-char-sequence (sequence input &key (start 0) (end (length sequence)))
(let (c (i start))
(loop
(cond ((= i end) (return i)))
(setq c (read-byte input nil :eof))
(cond ((eql c :eof) (return i)))
(setf (aref sequence i) c)
(incf i) )))
||#
(defmacro glisp::with-timeout ((&rest ignore) &body body)
(declare (ignore ignore))
`(progn
, at body))
(defun glisp::open-inet-socket (hostname port)
(let ((fd (extensions:connect-to-inet-socket hostname port)))
(values
(sys:make-fd-stream fd
:input t
:output t
:element-type '(unsigned-byte 8)
:name (format nil "Network connection to ~A:~D" hostname port))
:byte)))
(defun glisp::g/make-string (length &rest options)
(apply #'make-array length :element-type 'base-char options))
#||
RUN-PROGRAM is an external symbol in the EXTENSIONS package.
Function: #<Function RUN-PROGRAM {12E7B79}>
Function arguments:
(program args &key (env *environment-list*) (wait t) pty input
if-input-does-not-exist output (if-output-exists :error) (error :output)
(if-error-exists :error) status-hook)
Function documentation:
Run-program creates a new process and runs the unix progam in the
file specified by the simple-string program. Args are the standard
arguments that can be passed to a Unix program, for no arguments
use NIL (which means just the name of the program is passed as arg 0).
Run program will either return NIL or a PROCESS structure. See the CMU
Common Lisp Users Manual for details about the PROCESS structure.
The keyword arguments have the following meanings:
:env -
An A-LIST mapping keyword environment variables to simple-string
values.
:wait -
If non-NIL (default), wait until the created process finishes. If
NIL, continue running Lisp until the program finishes.
:pty -
Either T, NIL, or a stream. Unless NIL, the subprocess is established
under a PTY. If :pty is a stream, all output to this pty is sent to
this stream, otherwise the PROCESS-PTY slot is filled in with a stream
connected to pty that can read output and write input.
:input -
Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
input for the current process is inherited. If NIL, /dev/null
is used. If a pathname, the file so specified is used. If a stream,
all the input is read from that stream and send to the subprocess. If
:STREAM, the PROCESS-INPUT slot is filled in with a stream that sends
its output to the process. Defaults to NIL.
:if-input-does-not-exist (when :input is the name of a file) -
can be one of:
:error - generate an error.
:create - create an empty file.
nil (default) - return nil from run-program.
:output -
Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
output for the current process is inherited. If NIL, /dev/null
is used. If a pathname, the file so specified is used. If a stream,
all the output from the process is written to this stream. If
:STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
be read to get the output. Defaults to NIL.
:if-output-exists (when :input is the name of a file) -
can be one of:
:error (default) - generates an error if the file already exists.
:supersede - output from the program supersedes the file.
:append - output from the program is appended to the file.
nil - run-program returns nil without doing anything.
:error and :if-error-exists -
Same as :output and :if-output-exists, except that :error can also be
specified as :output in which case all error output is routed to the
same place as normal output.
:status-hook -
This is a function the system calls whenever the status of the
process changes. The function takes the process as an argument.
Its defined argument types are:
(T T &KEY (:ENV T) (:WAIT T) (:PTY T) (:INPUT T) (:IF-INPUT-DOES-NOT-EXIST T)
(:OUTPUT T) (:IF-OUTPUT-EXISTS T) (:ERROR T) (:IF-ERROR-EXISTS T)
(:STATUS-HOOK T))
Its result type is:
(OR EXTENSIONS::PROCESS NULL)
On Wednesday, 7/1/98 12:48:51 pm [-1] it was compiled from:
target:code/run-program.lisp
Created: Saturday, 6/20/98 07:13:08 pm [-1]
Comment: $Header: /project/closure/cvsroot/closure/src/glisp/dep-scl.lisp,v 1.1 2006/12/31 13:11:44 dlichteblau Exp $
||#
;; (process-exit-code (run-program "/bin/sh" (list "-c" "ls") :wait t :input nil :output nil))
(defun glisp:run-unix-shell-command (command)
(ext:process-exit-code (ext:run-program "/bin/sh" (list "-c" command) :wait t :input nil :output nil)))
;;; MP
(export 'glisp::mp/process-yield :glisp)
(export 'glisp::mp/process-wait :glisp)
(export 'glisp::mp/process-run-function :glisp)
(export 'glisp::mp/make-lock :glisp)
(export 'glisp::mp/current-process :glisp)
(export 'glisp::mp/process-kill :glisp)
(defun glisp::mp/make-lock (&key name)
(pthread::make-lock name))
(defmacro glisp::mp/with-lock ((lock) &body body)
`(pthread::with-lock-held (,lock)
, at body))
(defun glisp::mp/process-yield (&optional process-to-run)
(declare (ignore process-to-run))
(PTHREAD:SCHED-YIELD))
(defun glisp::mp/process-wait (whostate predicate)
(do ()
((funcall predicate))
(sleep .1)))
(defun glisp::mp/process-run-function (name fun &rest args)
(pthread::thread-create
(lambda ()
(apply fun args))
:name name))
(defun glisp::mp/current-process ()
'blah)
(defun glisp::mp/process-kill (process)
(warn "*** Define GLISP:MP/PROCESS-KILL for CMUCL."))
(defun glisp::getenv (string)
(cdr (assoc string ext:*environment-list* :test #'string-equal)))
More information about the Closure-cvs
mailing list