[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