The attached patches, and the files Lisp-Dep/fix-scl.lisp and Lisp-Dep/mp-scl.lisp,
add support for the Scieneer CL implementation.
Regards
Douglas Crosher
Index: README
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/README,v
retrieving revision 1.2
diff -c -r1.2 README
*** README 20 Dec 2004 15:47:32 -0000 1.2
--- README 14 Mar 2006 02:15:55 -0000
***************
*** 2,8 ****
This is McCLIM, an implementation of the "Common Lisp Interface
Manager CLIM II Specification." It currently works on X Windows using
! CLX. It works with CMUCL, SBCL, CLISP, OpenMCL, Allegro CL and LispWorks.
The INSTALL files in this directory give instructions for each Lisp
implementation. Release notes for each release of McCLIM are in the
ReleaseNotes directory.
--- 2,10 ----
This is McCLIM, an implementation of the "Common Lisp Interface
Manager CLIM II Specification." It currently works on X Windows using
! CLX. It works with CMUCL, SBCL, CLISP, OpenMCL, Allegro CL, LispWorks,
! and the Scieneer CL.
!
The INSTALL files in this directory give instructions for each Lisp
implementation. Release notes for each release of McCLIM are in the
ReleaseNotes directory.
***************
*** 22,28 ****
address-book - the canonical CLIM application
clim-fig - a drawing program
! postscript-test - shows of the CLIM PostScript stream
gadget-test - fun with CLIM gadgets
calculator - a gadget-based calculator
goatee-test - Hacks with Goatee, the Emacs-like editor used in McCLIM
--- 24,30 ----
address-book - the canonical CLIM application
clim-fig - a drawing program
! postscript-test - shows off the CLIM PostScript stream
gadget-test - fun with CLIM gadgets
calculator - a gadget-based calculator
goatee-test - Hacks with Goatee, the Emacs-like editor used in McCLIM
Index: mcclim.asd
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/mcclim.asd,v
retrieving revision 1.8
diff -c -r1.8 mcclim.asd
*** mcclim.asd 10 Mar 2006 21:58:13 -0000 1.8
--- mcclim.asd 14 Mar 2006 02:15:56 -0000
***************
*** 85,90 ****
--- 85,91 ----
:depends-on ("patch")
:components
((:file #+cmu "fix-cmu"
+ #+scl "fix-scl"
#+excl "fix-acl"
#+sbcl "fix-sbcl"
#+openmcl "fix-openmcl"
***************
*** 101,106 ****
--- 102,108 ----
:components
((:file #.(or
#+(and :cmu :mp (not :pthread)) "mp-cmu"
+ #+scl "mp-scl"
#+sb-thread "mp-sbcl"
#+excl "mp-acl"
#+openmcl "mp-openmcl"
***************
*** 289,295 ****
:depends-on (:clim
;; If we're on an implementation that ships CLX, use
;; it. Same if the user has loaded CLX already.
! #+(or sbcl openmcl ecl clx allegro) :clim-clx
#+gl :clim-opengl
;; OpenMCL and MCL support the beagle backend (native
;; OS X look&feel on OS X).
--- 291,297 ----
:depends-on (:clim
;; If we're on an implementation that ships CLX, use
;; it. Same if the user has loaded CLX already.
! #+(or sbcl scl openmcl ecl clx allegro) :clim-clx
#+gl :clim-opengl
;; OpenMCL and MCL support the beagle backend (native
;; OS X look&feel on OS X).
Index: package.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/package.lisp,v
retrieving revision 1.52
diff -c -r1.52 package.lisp
*** package.lisp 28 Jan 2006 00:38:04 -0000 1.52
--- package.lisp 14 Mar 2006 02:15:56 -0000
***************
*** 219,224 ****
--- 219,225 ----
(gray-packages
`(#+clisp ,@'(:gray)
#+cmu ,@'(:ext)
+ #+scl ,@'(:ext)
#+mcl ,@'(:ccl)
#+allegro ,@'(:common-lisp :excl :stream)
#+harlequin-common-lisp ,@'(:stream)
Index: presentations.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/presentations.lisp,v
retrieving revision 1.73
diff -c -r1.73 presentations.lisp
*** presentations.lisp 12 Mar 2006 23:09:27 -0000 1.73
--- presentations.lisp 14 Mar 2006 02:15:57 -0000
***************
*** 910,915 ****
--- 910,916 ----
(defvar *standard-object-class* (find-class 'standard-object))
+ #-scl
(defmethod clim-mop:compute-applicable-methods-using-classes :around
((gf presentation-generic-function) classes)
(multiple-value-bind (methods success)
***************
*** 924,930 ****
*standard-object-class*))
methods)
t)))))
!
(defun method-applicable (method arguments)
(loop for arg in arguments
for specializer in (clim-mop:method-specializers method)
--- 925,948 ----
*standard-object-class*))
methods)
t)))))
!
! #+scl
! (defmethod clim-mop:compute-applicable-methods-using-classes :around
! ((gf presentation-generic-function) classes)
! (multiple-value-bind (methods success non-class-positions)
! (call-next-method)
! (let ((ptype-class (car classes)))
! (if (or (null success)
! (not (typep ptype-class 'presentation-type-class)))
! (values methods non-class-positions non-class-positions)
! (values (remove-if #'(lambda (method)
! (eq (car (clim-mop:method-specializers
! method))
! *standard-object-class*))
! methods)
! t
! non-class-positions)))))
!
(defun method-applicable (method arguments)
(loop for arg in arguments
for specializer in (clim-mop:method-specializers method)
Index: system.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/system.lisp,v
retrieving revision 1.113
diff -c -r1.113 system.lisp
*** system.lisp 10 Mar 2006 21:58:13 -0000 1.113
--- system.lisp 14 Mar 2006 02:15:57 -0000
***************
*** 80,85 ****
--- 80,86 ----
;; First possible patches
"patch"
#+cmu "Lisp-Dep/fix-cmu"
+ #+scl "Lisp-Dep/fix-scl"
#+excl "Lisp-Dep/fix-acl"
#+sbcl "Lisp-Dep/fix-sbcl"
#+openmcl "Lisp-Dep/fix-openmcl"
***************
*** 100,105 ****
--- 101,107 ----
#+excl "Lisp-Dep/mp-acl"
#+openmcl "Lisp-Dep/mp-openmcl"
#+lispworks "Lisp-Dep/mp-lw"
+ #+scl "Lisp-Dep/mp-scl"
#| fall back |# "Lisp-Dep/mp-nil")
"utils"
"defresource"
Index: utils.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/utils.lisp,v
retrieving revision 1.43
diff -c -r1.43 utils.lisp
*** utils.lisp 10 Mar 2006 21:58:13 -0000 1.43
--- utils.lisp 14 Mar 2006 02:15:57 -0000
***************
*** 21,32 ****
(defun get-environment-variable (string)
#+excl (sys:getenv string)
! #+cmu (cdr (assoc string ext:*environment-list* :test #'string=))
#+clisp (ext:getenv (string string))
#+sbcl (sb-ext::posix-getenv string)
#+openmcl (ccl::getenv string)
#+lispworks (lw:environment-variable string)
! #-(or excl cmu clisp sbcl openmcl lispworks)
(error "GET-ENVIRONMENT-VARIABLE not implemented"))
;;; It would be nice to define this macro in terms of letf, but that
--- 21,32 ----
(defun get-environment-variable (string)
#+excl (sys:getenv string)
! #+(or cmu scl) (cdr (assoc string ext:*environment-list* :test #'string=))
#+clisp (ext:getenv (string string))
#+sbcl (sb-ext::posix-getenv string)
#+openmcl (ccl::getenv string)
#+lispworks (lw:environment-variable string)
! #-(or excl cmu scl clisp sbcl openmcl lispworks)
(error "GET-ENVIRONMENT-VARIABLE not implemented"))
;;; It would be nice to define this macro in terms of letf, but that
Index: Apps/Listener/dev-commands.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp,v
retrieving revision 1.32
diff -c -r1.32 dev-commands.lisp
*** Apps/Listener/dev-commands.lisp 6 Dec 2005 16:21:58 -0000 1.32
--- Apps/Listener/dev-commands.lisp 14 Mar 2006 02:15:58 -0000
***************
*** 672,678 ****
#+clisp (clos:specializer-direct-generic-functions specializer)
#+openmcl-partial-mop
(openmcl-mop:specializer-direct-generic-functions specializer)
! #-(or PCL SBCL clisp openmcl-partial-mop)
(error "Sorry, not supported in your CL implementation. See the function X-SPECIALIZER-DIRECT-GENERIC-FUNCTION if you are interested in fixing this."))
(defun class-funcs (class)
--- 672,679 ----
#+clisp (clos:specializer-direct-generic-functions specializer)
#+openmcl-partial-mop
(openmcl-mop:specializer-direct-generic-functions specializer)
! #+scl (clos:specializer-direct-generic-functions specializer)
! #-(or PCL SBCL scl clisp openmcl-partial-mop)
(error "Sorry, not supported in your CL implementation. See the function X-SPECIALIZER-DIRECT-GENERIC-FUNCTION if you are interested in fixing this."))
(defun class-funcs (class)
***************
*** 941,950 ****
"Return the number of internal symbols in PACKAGE."
;; We take only the first value, the symbol count, and discard the second, the
;; hash table capacity
! #+cmu (values (lisp::internal-symbol-count package))
#+sbcl (values (sb-int:package-internal-symbol-count package))
#+clisp (svref (sys::%record-ref *package* 1) 2)
! #-(or cmu sbcl clisp) (portable-internal-symbol-count package))
(defun portable-external-symbol-count (package)
(let ((n 0))
--- 942,951 ----
"Return the number of internal symbols in PACKAGE."
;; We take only the first value, the symbol count, and discard the second, the
;; hash table capacity
! #+(or cmu scl) (values (lisp::internal-symbol-count package))
#+sbcl (values (sb-int:package-internal-symbol-count package))
#+clisp (svref (sys::%record-ref *package* 1) 2)
! #-(or cmu scl sbcl clisp) (portable-internal-symbol-count package))
(defun portable-external-symbol-count (package)
(let ((n 0))
***************
*** 955,964 ****
(defun count-external-symbols (package)
"Return the number of external symbols in PACKAGE."
! #+cmu (values (lisp::external-symbol-count package))
#+sbcl (values (sb-int:package-external-symbol-count package))
#+clisp (svref (sys::%record-ref *package* 0) 2)
! #-(or cmu sbcl clisp) (portable-external-symbol-count package))
(defun package-grapher (stream package inferior-fun)
"Draw package hierarchy graphs for `Show Package Users' and `Show Used Packages'."
--- 956,965 ----
(defun count-external-symbols (package)
"Return the number of external symbols in PACKAGE."
! #+(or cmu scl) (values (lisp::external-symbol-count package))
#+sbcl (values (sb-int:package-external-symbol-count package))
#+clisp (svref (sys::%record-ref *package* 0) 2)
! #-(or cmu scl sbcl clisp) (portable-external-symbol-count package))
(defun package-grapher (stream package inferior-fun)
"Draw package hierarchy graphs for `Show Package Users' and `Show Used Packages'."
Index: Apps/Listener/listener.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp,v
retrieving revision 1.22
diff -c -r1.22 listener.lisp
*** Apps/Listener/listener.lisp 6 Dec 2005 16:21:11 -0000 1.22
--- Apps/Listener/listener.lisp 14 Mar 2006 02:15:58 -0000
***************
*** 72,87 ****
(declare (ignore frame))
(let* ((*standard-output* pane)
(username (or #+cmu (cdr (assoc :user ext:*environment-list*))
#+allegro (sys:getenv "USER")
! #-(or allegro cmu) (getenv "USER")
"luser")) ; sorry..
(sitename (machine-instance))
! (memusage #+cmu (lisp::dynamic-usage)
#+sbcl (sb-kernel:dynamic-usage)
#+lispworks (getf (system:room-values) :total-allocated)
#+openmcl (+ (ccl::%usedbytes) (ccl::%freebytes))
#+clisp (values (sys::%room))
! #-(or cmu sbcl lispworks openmcl clisp) 0))
(with-text-family (T :serif)
(formatting-table (T :x-spacing '(3 :character))
(formatting-row (T)
--- 72,89 ----
(declare (ignore frame))
(let* ((*standard-output* pane)
(username (or #+cmu (cdr (assoc :user ext:*environment-list*))
+ #+scl (cdr (assoc "USER" ext:*environment-list*
+ :test 'string=))
#+allegro (sys:getenv "USER")
! #-(or allegro cmu scl) (getenv "USER")
"luser")) ; sorry..
(sitename (machine-instance))
! (memusage #+(or cmu scl) (lisp::dynamic-space-usage)
#+sbcl (sb-kernel:dynamic-usage)
#+lispworks (getf (system:room-values) :total-allocated)
#+openmcl (+ (ccl::%usedbytes) (ccl::%freebytes))
#+clisp (values (sys::%room))
! #-(or cmu scl sbcl lispworks openmcl clisp) 0))
(with-text-family (T :serif)
(formatting-table (T :x-spacing '(3 :character))
(formatting-row (T)
Index: Apps/Listener/util.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp,v
retrieving revision 1.19
diff -c -r1.19 util.lisp
*** Apps/Listener/util.lisp 13 Oct 2005 14:32:13 -0000 1.19
--- Apps/Listener/util.lisp 14 Mar 2006 02:15:58 -0000
***************
*** 63,68 ****
--- 63,69 ----
(defun getenv (var)
(or
#+cmu (cdr (assoc var ext:*environment-list*))
+ #+scl (cdr (assoc var ext:*environment-list* :test #'string=))
#+sbcl (sb-ext:posix-getenv var)
#+lispworks (lw:environment-variable var)
#+openmcl (ccl::getenv var)
***************
*** 73,78 ****
--- 74,80 ----
(defun change-directory (pathname)
"Ensure that the current directory seen by RUN-PROGRAM has changed, and update *default-pathname-defaults*"
#+CMU (unix:unix-chdir (namestring pathname))
+ #+scl (unix:unix-chdir (ext:unix-namestring pathname))
#+clisp (ext:cd pathname)
; SBCL FIXME?
(setf *default-pathname-defaults* pathname))
***************
*** 85,91 ****
;;; LIST-DIRECTORY is a wrapper for the CL DIRECTORY function, which really doesn't
;;; do what I'd like (resolves symbolic links, tends to be horribly buggy, etc.)
! #+CMU
(defun list-directory (pathname)
(directory pathname :truenamep nil))
--- 87,93 ----
;;; LIST-DIRECTORY is a wrapper for the CL DIRECTORY function, which really doesn't
;;; do what I'd like (resolves symbolic links, tends to be horribly buggy, etc.)
! #+(or CMU scl)
(defun list-directory (pathname)
(directory pathname :truenamep nil))
***************
*** 143,149 ****
(directory pathname :directories-are-files nil))
;; Fallback to ANSI CL
! #-(OR CMU SBCL OPENMCL ALLEGRO)
(defun list-directory (pathname)
(directory pathname))
--- 145,151 ----
(directory pathname :directories-are-files nil))
;; Fallback to ANSI CL
! #-(OR CMU scl SBCL OPENMCL ALLEGRO)
(defun list-directory (pathname)
(directory pathname))
***************
*** 167,174 ****
;;; (see above)
(defun run-program (program args &key (wait T) (output *standard-output*) (input *standard-input*))
! #+CMU (ext:run-program program args :input input
! :output output :wait wait)
#+SBCL (sb-ext:run-program program args :input input :search T
:output output :wait wait)
--- 169,176 ----
;;; (see above)
(defun run-program (program args &key (wait T) (output *standard-output*) (input *standard-input*))
! #+(or CMU scl) (ext:run-program program args :input input
! :output output :wait wait)
#+SBCL (sb-ext:run-program program args :input input :search T
:output output :wait wait)
***************
*** 179,185 ****
:wait wait)
#+clisp (ext:run-program program :arguments args :wait wait)
! #-(or CMU SBCL lispworks clisp)
(format T "~&Sorry, don't know how to run programs in your CL.~%"))
;;;; CLIM/UI utilities
--- 181,187 ----
:wait wait)
#+clisp (ext:run-program program :arguments args :wait wait)
! #-(or CMU scl SBCL lispworks clisp)
(format T "~&Sorry, don't know how to run programs in your CL.~%"))
;;;; CLIM/UI utilities
***************
*** 256,280 ****
(defun gen-wild-pathname (pathname)
"Build a pathname with appropriate :wild components for the directory listing."
! (make-pathname :host (pathname-host pathname)
! :device (pathname-device pathname)
! :directory (pathname-directory pathname)
! :name (or (pathname-name pathname) :wild)
:type (or (pathname-type pathname) :wild)
:version (or #+allegro :unspecific
:wild
;#-SBCL (pathname-version pathname)
;#+SBCL :newest
! )))
(defun strip-filespec (pathname)
"Removes name, type, and version components from a pathname."
! (make-pathname :host (pathname-host pathname)
! :device (pathname-device pathname)
! :directory (pathname-directory pathname)
! :name nil
:type nil
! :version nil))
;; Oops, should I be doing something with relative pathnames here?
(defun parent-directory (pathname)
--- 258,280 ----
(defun gen-wild-pathname (pathname)
"Build a pathname with appropriate :wild components for the directory listing."
! (make-pathname :name (or (pathname-name pathname) :wild)
:type (or (pathname-type pathname) :wild)
:version (or #+allegro :unspecific
:wild
;#-SBCL (pathname-version pathname)
;#+SBCL :newest
! )
! #+scl :query #+scl nil
! :defaults pathname))
(defun strip-filespec (pathname)
"Removes name, type, and version components from a pathname."
! (make-pathname :name nil
:type nil
! :version nil
! #+scl :query #+scl nil
! :defaults pathname))
;; Oops, should I be doing something with relative pathnames here?
(defun parent-directory (pathname)
***************
*** 282,293 ****
(let ((dir (pathname-directory (truename (strip-filespec pathname)))))
(when (and (eq (first dir) :absolute)
(not (zerop (length (rest dir)))))
! (make-pathname :host (pathname-host pathname)
! :device (pathname-device pathname)
! :directory `(:absolute ,@(nreverse (rest (reverse (rest dir)))))
! :name (pathname-name pathname)
! :type (pathname-type pathname)
! :version (pathname-version pathname)))))
;;;; Abbreviating item formatter
--- 282,289 ----
(let ((dir (pathname-directory (truename (strip-filespec pathname)))))
(when (and (eq (first dir) :absolute)
(not (zerop (length (rest dir)))))
! (make-pathname :directory `(:absolute ,@(nreverse (rest (reverse (rest dir)))))
! :defaults pathname))))
;;;; Abbreviating item formatter
;;; -*- 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))
;;;; 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))))
