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 ,@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 ,@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")) ,@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")) ,@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))