[mcclim-cvs] CVS mcclim/Lisp-Dep

[tmoore]

Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep
In directory clnet:/tmp/cvs-serv7770/Lisp-Dep

Added Files:
	fix-scl.lisp mp-scl.lisp 
Log Message:
Patches from dtc for Scieneer Common Lisp, and a few other fixes too.


--- /project/mcclim/cvsroot/mcclim/Lisp-Dep/fix-scl.lisp	2006/03/15 22:56:55	NONE
+++ /project/mcclim/cvsroot/mcclim/Lisp-Dep/fix-scl.lisp	2006/03/15 22:56:55	1.1
;;;; Support for the Scieneer Common Lisp.


;;;; Gray streams can be defined as subclass of the native stream classes.

(in-package :ext)

(export '(fundamental-stream
	  fundamental-input-stream
	  fundamental-output-stream
	  fundamental-character-stream
	  fundamental-binary-stream
	  fundamental-character-input-stream
	  fundamental-character-output-stream
	  fundamental-binary-input-stream
	  fundamental-binary-output-stream
	  stream-read-line
	  stream-start-line-p
	  stream-write-string
	  stream-terpri
	  stream-fresh-line
	  stream-advance-to-column
	  )
	:ext)

(defclass fundamental-stream (stream)
  ()
  (:documentation "Base class for all CLOS streams"))

;;; Define the stream classes.
(defclass fundamental-input-stream (fundamental-stream ext:input-stream) ())

(defclass fundamental-output-stream (fundamental-stream ext:output-stream) ())

(defclass fundamental-character-stream (fundamental-stream ext:character-stream) ())

(defclass fundamental-binary-stream (fundamental-stream ext:binary-stream) ())

(defclass fundamental-character-input-stream (fundamental-input-stream
					      fundamental-character-stream
					      ext:character-input-stream)
  ())

(defclass fundamental-character-output-stream (fundamental-output-stream
					       fundamental-character-stream
					       ext:character-output-stream)
  ())

(defclass fundamental-binary-input-stream (fundamental-input-stream
					   fundamental-binary-stream
					   ext:binary-input-stream)
  ())

(defclass fundamental-binary-output-stream (fundamental-output-stream
					    fundamental-binary-stream
					    ext:binary-output-stream)
  ())

(defgeneric stream-read-line (stream)
  (:documentation
   "Used by 'read-line.  A string is returned as the first value.  The
  second value is true if the string was terminated by end-of-file
  instead of the end of a line.  The default method uses repeated
  calls to 'stream-read-char."))

(defmethod stream-read-line ((stream fundamental-character-input-stream))
  (let ((res (make-string 80))
	(len 80)
	(index 0))
    (loop
     (let ((ch (stream-read-char stream)))
       (cond ((eq ch :eof)
	      (return (values (cl::shrink-vector res index) t)))
	     (t
	      (when (char= ch #\newline)
		(return (values (cl::shrink-vector res index) nil)))
	      (when (= index len)
		(setq len (* len 2))
		(let ((new (make-string len)))
		  (replace new res)
		  (setq res new)))
	      (setf (schar res index) ch)
	      (incf index)))))))

(defgeneric stream-start-line-p (stream))

(defmethod stream-start-line-p ((stream fundamental-character-output-stream))
  (eql (stream-line-column stream) 0))

(defgeneric stream-terpri (stream)
  (:documentation
   "Writes an end of line, as for TERPRI.  Returns NIL.  The default
  method does (STREAM-WRITE-CHAR stream #\NEWLINE)."))

(defmethod stream-terpri ((stream fundamental-character-output-stream))
  (stream-write-char stream #\Newline))

(defgeneric stream-fresh-line (stream)
  (:documentation
   "Outputs a new line to the Stream if it is not positioned at the
  begining of a line.  Returns 't if it output a new line, nil
  otherwise. Used by 'fresh-line. The default method uses
  'stream-start-line-p and 'stream-terpri."))

(defmethod stream-fresh-line ((stream fundamental-character-output-stream))
  (unless (stream-start-line-p stream)
    (stream-terpri stream)
    t))

(defgeneric stream-advance-to-column (stream column)
  (:documentation
   "Writes enough blank space so that the next character will be
  written at the specified column.  Returns true if the operation is
  successful, or NIL if it is not supported for this stream.  This is
  intended for use by by PPRINT and FORMAT ~T.  The default method uses
  STREAM-LINE-COLUMN and repeated calls to STREAM-WRITE-CHAR with a
  #\SPACE character; it returns NIL if STREAM-LINE-COLUMN returns NIL."))

(defmethod stream-advance-to-column ((stream fundamental-character-output-stream)
				     column)
  (let ((current-column (stream-line-column stream)))
    (when current-column
      (let ((fill (- column current-column)))
	(dotimes (i fill)
	  (stream-write-char stream #\Space)))
      t)))



(defpackage :clim-mop
  (:use :common-lisp :clos))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (loop for sym being the symbols of :clim-mop
	do (export sym :clim-mop)))

(in-package :clim-mop)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (export '(clim-lisp-patch::defconstant
            clim-lisp-patch::defclass)
          :clim-lisp-patch))

(defmacro clim-lisp-patch:defconstant (symbol value &optional docu)
  `(defvar ,symbol ,value ,@(and docu (list docu))))

(defvar clim-lisp-patch::*compile-time-clos-names* (make-hash-table))

(defun clim-lisp-patch::compile-time-clos-class-p (name)
  (gethash name clim-lisp-patch::*compile-time-clos-names* nil))

(defmacro clim-lisp-patch:defclass (name &rest args)
  `(progn
     (eval-when (:compile-toplevel)
       (setf (gethash ',name clim-lisp-patch::*compile-time-clos-names*) t))
     (eval-when (:compile-toplevel :load-toplevel :execute)
       (cl:defclass ,name , at args))))


--- /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-scl.lisp	2006/03/15 22:56:55	NONE
+++ /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-scl.lisp	2006/03/15 22:56:55	1.1
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: clim-internals; -*-
;;; ---------------------------------------------------------------------------
;;;     Title: CLIM-2, Chapter 32.2 Multi-processing
;;;            for the Scieneer Common Lisp
;;;   Created: 2006-03-12
;;;    Author: Scieneer Pty Ltd
;;;   Based on mp-acl, created 2001-05-22 by Gilbert Baumann
;;;   License: LGPL (See file COPYING for details).
;;; ---------------------------------------------------------------------------
;;;  (c) copyright 2006 by Scieneer Pty Ltd

;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the 
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
;;; Boston, MA  02111-1307  USA.

(in-package :clim-internals)

(defconstant *multiprocessing-p* t)

(eval-when (:load-toplevel :compile-toplevel :execute)
  (pushnew :clim-mp *features*))

(defun make-process (function &key name)
  (mp:make-process function :name name))

(defun restart-process (process)
  (mp:restart-process process))

(defun destroy-process (process)
  (mp:destroy-process process))

(defun current-process ()
  (mp:current-process))

(defun all-processes ()
  (mp:all-processes))

(defun processp (object)
  (mp:processp object))

(defun process-name (process)
  (mp:process-name process))

(defun process-state (process)
  (mp:process-state process))

(defun process-whostate (process)
  (mp:process-whostate process))

(defun process-wait (reason predicate)
  (mp:process-wait reason predicate))

(defun process-wait-with-timeout (reason timeout predicate)
  (mp:process-wait-with-timeout reason timeout predicate))

(defun process-yield ()
  (mp:process-yield))

(defun process-interrupt (process function)
  (mp:process-interrupt process function))

(defun disable-process (process)
  (mp:disable-process process))

(defun enable-process (process)
  (mp:enable-process process))

(defmacro without-scheduling (&body body)
  `(mp:without-scheduling , at body))

(defmacro atomic-incf (place)
  `(mp:atomic-incf ,place))

(defmacro atomic-decf (place) 
  `(mp:atomic-decf ,place))

;;; 32.3 Locks

(defun make-lock (&optional name)
  (mp:make-lock name :type :error-check))

(defmacro with-lock-held ((place &optional state) &body body)
  `(mp:with-lock-held (,place (or ,state "Lock Wait"))
    , at body))

(defun make-recursive-lock (&optional name)
  (mp:make-lock name :type :recursive))

(defmacro with-recursive-lock-held ((place &optional state) &body body)
  `(mp:with-lock-held (,place (or ,state "Lock Wait"))
    , at body))

(defun make-condition-variable ()
  (thread:make-cond-var))

(defun condition-wait (condition-variable lock &optional timeout)
  (cond (timeout
	 (thread:cond-var-timedwait condition-variable lock timeout))
	(t
	 (thread:cond-var-wait condition-variable lock)
	 t)))

(defun condition-notify (condition-variable)
  (thread:cond-var-broadcast condition-variable))