Skip to content
Snippets Groups Projects
Commit f68ccdb3 authored by duane's avatar duane
Browse files

See 2.2.1.9 changelog entry for Tue Mar 17 12:26:36 1998

parent a14b1310
No related branches found
No related tags found
No related merge requests found
...@@ -10,6 +10,21 @@ Tests for new features: <`no new features', `no tests for new features', or ...@@ -10,6 +10,21 @@ Tests for new features: <`no new features', `no tests for new features', or
<standard changelog date stamp> <standard changelog date stamp>
* <changes go here...> * <changes go here...>
*******************************************************************************
2.2.1.9
Documentation changes: none
Tests for new features: no new features
Tue Mar 17 12:26:36 1998 Duane Rettig <duane@beta>
* Makefile:
* Makefile.alpha:
* demo/process-browser.lisp:
* test/test-driver.lisp: Fix os-threads feature
* utils/packages.lisp: increment version
******************************************************************************* *******************************************************************************
2.2.1.8 2.2.1.8
......
# $Header: /repo/cvs.copy/clim2/Makefile,v 1.81 1997/02/05 01:41:43 tomj Exp $ # $Header: /repo/cvs.copy/clim2/Makefile,v 1.82 1998/03/17 23:32:03 duane Exp $
# If ../makefile.top doesn't exist, then you must specify HOST=xxx on the
# `make' command line.
include ../makefile.top
ifeq ($(OS_NAME),sunos)
ifeq ($(MACHINE),sparc)
HOST = sun4-svr4
endif
endif
ifeq ($(OS_NAME),osf1)
ifeq ($(MACHINE),alpha)
HOST = alpha
endif
endif
# If no HOST specified then we'd like to get an error immediately # If no HOST specified then we'd like to get an error immediately
# rather than ploughing on with an inappropriate default # rather than ploughing on with an inappropriate default
ifndef HOST
HOST = unknown HOST = unknown
endif
include Makefile.$(HOST) include Makefile.$(HOST)
# $Header: /repo/cvs.copy/clim2/Makefile.alpha,v 1.4 1997/02/07 00:20:43 tomj Exp $ # $Header: /repo/cvs.copy/clim2/Makefile.alpha,v 1.5 1998/03/17 23:32:03 duane Exp $
# #
# Makefile.alpha for CLIM 2.0 # Makefile.alpha for CLIM 2.0
# #
include Makefile.defs include Makefile.defs
CL_HOME=/fi/scm/4.3/dec/src
CL=$(CL_HOME)/dcl
CLIM_HOME=$(CL_HOME) CLIM_HOME=$(CL_HOME)
Makefile=Makefile.alpha Makefile=Makefile.alpha
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
;; $Header: /repo/cvs.copy/clim2/demo/process-browser.lisp,v 1.11 1997/10/20 23:11:02 layer Exp $ ;; $Header: /repo/cvs.copy/clim2/demo/process-browser.lisp,v 1.12 1998/03/17 23:32:03 duane Exp $
(in-package :clim-demo) (in-package :clim-demo)
...@@ -16,7 +16,7 @@ ...@@ -16,7 +16,7 @@
(:default-initargs :delay 5)) (:default-initargs :delay 5))
(defmethod read-frame-command :around ((frame process-browser) &key) (defmethod read-frame-command :around ((frame process-browser) &key)
(with-accessors ((timer process-browser-timer)) frame (with-accessors ((timer process-browser-timer)) frame
(unwind-protect (unwind-protect
(progn (progn
(install-process-browser-timer frame) (install-process-browser-timer frame)
...@@ -25,7 +25,7 @@ ...@@ -25,7 +25,7 @@
(defun install-process-browser-timer (frame) (defun install-process-browser-timer (frame)
(with-accessors ((timer process-browser-timer) (with-accessors ((timer process-browser-timer)
(delay process-browser-delay)) frame (delay process-browser-delay)) frame
(when timer (clim-utils:delete-timer timer)) (when timer (clim-utils:delete-timer timer))
(setq timer (clim-internals::make-command-timer (setq timer (clim-internals::make-command-timer
frame '(com-update-process-browser) frame '(com-update-process-browser)
...@@ -37,7 +37,7 @@ ...@@ -37,7 +37,7 @@
(with-accessors ((timer process-browser-timer) (with-accessors ((timer process-browser-timer)
(delay process-browser-delay)) frame (delay process-browser-delay)) frame
(accepting-values (*query-io* :own-window t) (accepting-values (*query-io* :own-window t)
(setf delay (accept '(integer 1 *) (setf delay (accept '(integer 1 *)
:prompt "Enter new delay" :prompt "Enter new delay"
:default delay :default delay
:stream *query-io*)) :stream *query-io*))
...@@ -89,16 +89,16 @@ ...@@ -89,16 +89,16 @@
#'>= :key #'caddr))) #'>= :key #'caddr)))
(dolist (p processes) (dolist (p processes)
(destructuring-bind (times-resumed msec-used msec-used-d . process) p (destructuring-bind (times-resumed msec-used msec-used-d . process) p
(let ((profilep (let ((profilep
#-target=os-threads #-os-threads
(let ((stack-group (mp::process-stack-group process))) (let ((stack-group (mp::process-stack-group process)))
(and stack-group (and stack-group
(mp::profile-stack-group-p stack-group))) (mp::profile-stack-group-p stack-group)))
#+target=os-threads #+os-threads
(mp:profile-process-p process))) (mp:profile-process-p process)))
(updating-output (t :unique-id process (updating-output (t :unique-id process
:cache-test #'equal :cache-test #'equal
:cache-value :cache-value
(list p (list p
profilep profilep
(mp::process-active-p process) (mp::process-active-p process)
......
...@@ -41,7 +41,7 @@ ...@@ -41,7 +41,7 @@
(defmethod initialize-instance :after ((inv frame-invocation) &key class initargs frame) (defmethod initialize-instance :after ((inv frame-invocation) &key class initargs frame)
(let ((process nil)) (let ((process nil))
(if frame (if frame
(setq process (clim-internals::frame-top-level-process frame)) (setq process (clim-internals::frame-top-level-process frame))
(setq frame (apply #'make-application-frame class initargs))) (setq frame (apply #'make-application-frame class initargs)))
(setf (invocation-frame inv) frame) (setf (invocation-frame inv) frame)
...@@ -81,7 +81,7 @@ ...@@ -81,7 +81,7 @@
(unless process (unless process
(setq process (mp:process-run-function (setq process (mp:process-run-function
(format nil "~A Test process for" frame) (format nil "~A Test process for" frame)
#'run-frame-top-level-almost #'run-frame-top-level-almost
frame))) frame)))
(setf (invocation-process inv) process) (setf (invocation-process inv) process)
(wait-for-clim-input-state inv))) (wait-for-clim-input-state inv)))
...@@ -99,27 +99,27 @@ ...@@ -99,27 +99,27 @@
(when port #-acl86win32 (xm-silica::port-finish-output port))) (when port #-acl86win32 (xm-silica::port-finish-output port)))
(mp:process-allow-schedule) (mp:process-allow-schedule)
(flet ((input-state-p (process) (flet ((input-state-p (process)
(or #-target=os-threads (or #-os-threads
(not (mp::process-stack-group process)) (not (mp::process-stack-group process))
#+target=os-threads #+os-threads
(not (mp:process-thread process)) (not (mp:process-thread process))
(member (mp::process-whostate process) (member (mp::process-whostate process)
'("Returned value" '("Returned value"
"Waiting for dialog" "Waiting for dialog"
"CLIM Input") "CLIM Input")
:test #'string-equal)))) :test #'string-equal))))
(if timeout (if timeout
(let ((done nil)) (let ((done nil))
(mp:process-wait-with-timeout (mp:process-wait-with-timeout
"Waiting for process to sleep" "Waiting for process to sleep"
timeout timeout
#'(lambda () #'(lambda ()
(setq done (input-state-p process)))) (setq done (input-state-p process))))
(unless done (unless done
(error "Timed out after ~D seconds" timeout))) (error "Timed out after ~D seconds" timeout)))
(mp:process-wait (mp:process-wait
"Waiting for process to sleep" "Waiting for process to sleep"
#'(lambda () #'(lambda ()
(input-state-p process))))))) (input-state-p process)))))))
(defvar *death-timeout* 30) (defvar *death-timeout* 30)
...@@ -128,9 +128,9 @@ ...@@ -128,9 +128,9 @@
(with-slots (process) invocation (with-slots (process) invocation
(write-line "Terminating frame") (write-line "Terminating frame")
(unless (progn (unless (progn
#-target=os-threads #-os-threads
(mp::process-stack-group process) (mp::process-stack-group process)
#+target=os-threads #+os-threads
(mp::process-thread process)) (mp::process-thread process))
(error "Frame terminated abnormally")) (error "Frame terminated abnormally"))
(execute-one-command invocation exit-command) (execute-one-command invocation exit-command)
...@@ -140,13 +140,13 @@ ...@@ -140,13 +140,13 @@
(defun wait-for-death (process) (defun wait-for-death (process)
(let (done) (let (done)
(mp:process-wait-with-timeout (mp:process-wait-with-timeout
"Waiting for death" "Waiting for death"
*death-timeout* *death-timeout*
#'(lambda () #'(lambda ()
(setq done (setq done
(not (not
#-target=os-threads (mp::process-stack-group process) #-os-threads (mp::process-stack-group process)
#+target=os-threads (mp::process-thread process))))) #+os-threads (mp::process-thread process)))))
done)) done))
(defvar *execute-one-command-hook* nil) (defvar *execute-one-command-hook* nil)
...@@ -184,7 +184,7 @@ ...@@ -184,7 +184,7 @@
`(let ((,frame (with-slots (process avv-frame) invocation `(let ((,frame (with-slots (process avv-frame) invocation
(or avv-frame (invocation-frame invocation))))) (or avv-frame (invocation-frame invocation)))))
,@body)) ,@body))
(define-test-step character-event (x) (define-test-step character-event (x)
(with-invocation-sheet (sheet) (with-invocation-sheet (sheet)
...@@ -210,7 +210,7 @@ ...@@ -210,7 +210,7 @@
(make-instance 'key-press-event (make-instance 'key-press-event
:sheet sheet :sheet sheet
:character nil :character nil
:key-name keysym :key-name keysym
:modifier-state modifiers)))))))) :modifier-state modifiers))))))))
(defun execute-a-command (command) (defun execute-a-command (command)
...@@ -237,7 +237,7 @@ ...@@ -237,7 +237,7 @@
(:presentation-click (:presentation-click
(apply #'click-on-presentation (cdr command))) (apply #'click-on-presentation (cdr command)))
(:presentation-press (:presentation-press
(apply #'click-on-presentation (apply #'click-on-presentation
(second command) (third command) :release nil (cdddr command))) (second command) (third command) :release nil (cdddr command)))
(:click (:click
(apply #'click-on-window (cdr command))) (apply #'click-on-window (cdr command)))
...@@ -266,11 +266,11 @@ ...@@ -266,11 +266,11 @@
(note-test-succeeded ,tname)))))) (note-test-succeeded ,tname))))))
(defun exercise-frame (test-name (defun exercise-frame (test-name
class class
initargs initargs
command-continuation command-continuation
exit-command exit-command
&key (#+acl86win32 anerror #-acl86win32 error *catch-errors-in-tests*) &key (#+acl86win32 anerror #-acl86win32 error *catch-errors-in-tests*)
(invocation-class 'frame-invocation)) (invocation-class 'frame-invocation))
(flet ((doit () (flet ((doit ()
...@@ -280,7 +280,7 @@ ...@@ -280,7 +280,7 @@
(etypecase command-continuation (etypecase command-continuation
(null (sleep 5)) (null (sleep 5))
(list (list
(execute-commands-in-invocation (execute-commands-in-invocation
invocation command-continuation)) invocation command-continuation))
(function (funcall command-continuation))) (function (funcall command-continuation)))
(unwind-protect (unwind-protect
...@@ -293,26 +293,26 @@ ...@@ -293,26 +293,26 @@
(with-test-success-expected (test-name) (with-test-success-expected (test-name)
(doit)) (doit))
(doit)) (doit))
#+ignore #+ignore
(progn (progn
(format t "Port mapping ~S~%" (silica::port-mirror->sheet-table (clim:find-port))) (format t "Port mapping ~S~%" (silica::port-mirror->sheet-table (clim:find-port)))
#+verbose #+verbose
(maphash #'(lambda (x y) (maphash #'(lambda (x y)
(print y)) (print y))
(silica::port-mirror->sheet-table (clim:find-port))) (silica::port-mirror->sheet-table (clim:find-port)))
(format t "Port framem ~S~%" (find-frame-manager :port (clim:find-port))) (format t "Port framem ~S~%" (find-frame-manager :port (clim:find-port)))
(format t "Port framem frames ~S~%" (frame-manager-frames (format t "Port framem frames ~S~%" (frame-manager-frames
(find-frame-manager :port (clim:find-port)))) (find-frame-manager :port (clim:find-port))))
(format t " Address mapping ~S~%" tk::*address->object-mapping*) (format t " Address mapping ~S~%" tk::*address->object-mapping*)
#+verbose #+verbose
(maphash #'(lambda (x y) (print y)) (maphash #'(lambda (x y) (print y))
tk::*address->object-mapping*)) tk::*address->object-mapping*))
)) ))
...@@ -347,13 +347,13 @@ ...@@ -347,13 +347,13 @@
(format t "The following tests failed:~%") (format t "The following tests failed:~%")
(dolist (x *test-failures*) (dolist (x *test-failures*)
(format t "~10t~A : ~A~%" (car x) (cdr x)))) (format t "~10t~A : ~A~%" (car x) (cdr x))))
(when (probe-file file) (when (probe-file file)
(let (old-successes old-failures) (let (old-successes old-failures)
(with-open-file (*standard-input* file) (with-open-file (*standard-input* file)
(let ((*package* (find-package :clim-user))) (let ((*package* (find-package :clim-user)))
(setq old-successes (read) old-failures (read)))) (setq old-successes (read) old-failures (read))))
(let ((first t)) (let ((first t))
(dolist (x *test-failures*) (dolist (x *test-failures*)
(when (member (car x) old-successes) (when (member (car x) old-successes)
...@@ -361,7 +361,7 @@ ...@@ -361,7 +361,7 @@
(format t "The following tests have for failed the first time:~%") (format t "The following tests have for failed the first time:~%")
(setq first nil)) (setq first nil))
(format t "~10t~A : ~A~%" (car x) (cdr x))))) (format t "~10t~A : ~A~%" (car x) (cdr x)))))
(let ((first t)) (let ((first t))
(dolist (x *test-failures*) (dolist (x *test-failures*)
(when (member (car x) old-failures) (when (member (car x) old-failures)
...@@ -369,7 +369,7 @@ ...@@ -369,7 +369,7 @@
(format t "The following tests have failed again:~%") (format t "The following tests have failed again:~%")
(setq first nil)) (setq first nil))
(format t "~10t~A : ~A~%" (car x) (cdr x))))) (format t "~10t~A : ~A~%" (car x) (cdr x)))))
(let ((first t)) (let ((first t))
(dolist (x *test-successes*) (dolist (x *test-successes*)
(when (member x old-failures) (when (member x old-failures)
...@@ -377,12 +377,12 @@ ...@@ -377,12 +377,12 @@
(format t "The following tests have succeeded finally:~%") (format t "The following tests have succeeded finally:~%")
(setq first nil)) (setq first nil))
(format t "~10t~A~%" x)))))) (format t "~10t~A~%" x))))))
(when *test-successes* (when *test-successes*
(format t "The following tests succeeded:~%") (format t "The following tests succeeded:~%")
(dolist (x *test-successes*) (dolist (x *test-successes*)
(format t "~10t~A ~%" x))) (format t "~10t~A ~%" x)))
(with-open-file (*standard-output* file (with-open-file (*standard-output* file
:direction :output :if-exists :supersede) :direction :output :if-exists :supersede)
...@@ -397,9 +397,9 @@ ...@@ -397,9 +397,9 @@
(with-open-file (*standard-input* file) (with-open-file (*standard-input* file)
(values (read) (read))) (values (read) (read)))
(let ((expected-failures nil)) (let ((expected-failures nil))
(let ((unexpected-failures (let ((unexpected-failures
(set-difference failures expected-failures)) (set-difference failures expected-failures))
(unexpected-successes (unexpected-successes
(intersection successes expected-failures))) (intersection successes expected-failures)))
;; use *error-output* so it goes to stderr and is seen even ;; use *error-output* so it goes to stderr and is seen even
;; though make-dist redirects stdout to a file ;; though make-dist redirects stdout to a file
...@@ -411,15 +411,15 @@ ...@@ -411,15 +411,15 @@
"~D CLIM 2.0 tests failed unexpectedly:~{~20t~A~%~}~%" "~D CLIM 2.0 tests failed unexpectedly:~{~20t~A~%~}~%"
(length unexpected-failures) (length unexpected-failures)
unexpected-failures)) unexpected-failures))
(when unexpected-successes (when unexpected-successes
(format *error-output* (format *error-output*
"~D tests succeeded unexpectedly: ~{~20t~A~%~}~%" "~D tests succeeded unexpectedly: ~{~20t~A~%~}~%"
(length unexpected-successes) (length unexpected-successes)
unexpected-successes))))))) unexpected-successes)))))))
(defun walk-over-presentations (function output-record) (defun walk-over-presentations (function output-record)
(labels ((find-object-1 (record x-offset y-offset) (labels ((find-object-1 (record x-offset y-offset)
(with-bounding-rectangle* (left top right bottom) record (with-bounding-rectangle* (left top right bottom) record
...@@ -446,8 +446,8 @@ ...@@ -446,8 +446,8 @@
(define-condition cannot-find-presentation-error (simple-error) ()) (define-condition cannot-find-presentation-error (simple-error) ())
(define-test-step click-on-presentation (pane-name (define-test-step click-on-presentation (pane-name
presentation-type presentation-type
&key gesture &key gesture
(press t) (press t)
(release t) (release t)
(modifier 0) (modifier 0)
...@@ -465,7 +465,7 @@ ...@@ -465,7 +465,7 @@
(expanded-presentation-type (expanded-presentation-type
(expand-presentation-type-abbreviation presentation-type))) (expand-presentation-type-abbreviation presentation-type)))
(flet ((doit (record left top right bottom) (flet ((doit (record left top right bottom)
(when (and (presentation-subtypep (when (and (presentation-subtypep
(presentation-type record) (presentation-type record)
expanded-presentation-type) expanded-presentation-type)
(funcall test record)) (funcall test record))
...@@ -505,7 +505,7 @@ ...@@ -505,7 +505,7 @@
(warp-the-pointer pane (+ left x-offset) (warp-the-pointer pane (+ left x-offset)
(+ top y-offset)) (+ top y-offset))
(wait-for-clim-input-state invocation) (wait-for-clim-input-state invocation)
(when (clim-internals::stream-highlighted-presentation pane) (when (clim-internals::stream-highlighted-presentation pane)
(return)) (return))
(warp-the-pointer pane (+ left 1 x-offset) (+ top 1 y-offset)) (warp-the-pointer pane (+ left 1 x-offset) (+ top 1 y-offset))
(sleep 1)) (sleep 1))
...@@ -559,7 +559,7 @@ ...@@ -559,7 +559,7 @@
(apply #'button-event-on-window invocation pane-name left top (apply #'button-event-on-window invocation pane-name left top
:up t :down nil args)) :up t :down nil args))
(defun button-event-on-window (invocation pane-name left top (defun button-event-on-window (invocation pane-name left top
&key gesture (modifier 0) (button +pointer-left-button+) &key gesture (modifier 0) (button +pointer-left-button+)
up down) up down)
(with-slots (process) invocation (with-slots (process) invocation
...@@ -587,7 +587,7 @@ ...@@ -587,7 +587,7 @@
:x :?? :y :?? :x :?? :y :??
:modifier-state modifier))) :modifier-state modifier)))
(when up (when up
(distribute-event port (distribute-event port
(make-instance 'pointer-button-release-event (make-instance 'pointer-button-release-event
:sheet ma :sheet ma
:pointer (port-pointer port) :pointer (port-pointer port)
...@@ -602,15 +602,15 @@ ...@@ -602,15 +602,15 @@
(defun simulate-accept (invocation pane-name presentation-type &key (defun simulate-accept (invocation pane-name presentation-type &key
stream stream
default provide-default default provide-default
x-offset y-offset &allow-other-keys) x-offset y-offset &allow-other-keys)
;; We a choice. ;; We a choice.
;; 1. Send the characters or ;; 1. Send the characters or
;; 2. Click on a presentation ;; 2. Click on a presentation
(declare (ignore provide-default default stream invocation)) (declare (ignore provide-default default stream invocation))
(assert (click-on-presentation pane-name (assert (click-on-presentation pane-name
presentation-type presentation-type
:x-offset x-offset :x-offset x-offset
:y-offset y-offset) :y-offset y-offset)
() "Clicking failed")) () "Clicking failed"))
...@@ -620,13 +620,13 @@ ...@@ -620,13 +620,13 @@
(when delim (when delim
(execute-one-command invocation " "))) (execute-one-command invocation " ")))
(define-test-step test-a-command (pane-name command &key colon-prefix (define-test-step test-a-command (pane-name command &key colon-prefix
(x-offset 0) (x-offset 0)
(y-offset 0)) (y-offset 0))
(with-slots (process) invocation (with-slots (process) invocation
(let ((stream (get-invocation-pane invocation pane-name))) (let ((stream (get-invocation-pane invocation pane-name)))
(flet ((accept-function (stream presentation-type &rest args) (flet ((accept-function (stream presentation-type &rest args)
(apply #'simulate-accept invocation pane-name (apply #'simulate-accept invocation pane-name
presentation-type :stream stream :x-offset x-offset :y-offset y-offset args)) presentation-type :stream stream :x-offset x-offset :y-offset y-offset args))
(send-it-function (x) (send-it-function (x)
(send-it invocation x))) (send-it invocation x)))
...@@ -654,7 +654,7 @@ ...@@ -654,7 +654,7 @@
`(progn `(progn
(pushnew ',name *frame-tests*) (pushnew ',name *frame-tests*)
(defun ,name () (defun ,name ()
(exercise-frame ',name ',class ',initargs (exercise-frame ',name ',class ',initargs
',commands ',commands
',exit-command)))) ',exit-command))))
...@@ -662,7 +662,7 @@ ...@@ -662,7 +662,7 @@
`(progn `(progn
(pushnew ',name *frame-tests*) (pushnew ',name *frame-tests*)
(defun ,name () (defun ,name ()
(exercise-frame ',name ',class ',initargs (exercise-frame ',name ',class ',initargs
',commands ',commands
',exit-command ',exit-command
:invocation-class 'activity-invocation)))) :invocation-class 'activity-invocation))))
...@@ -676,7 +676,7 @@ ...@@ -676,7 +676,7 @@
(format t "Doing test ~A~%" test) (format t "Doing test ~A~%" test)
(if errorp (if errorp
(handler-case (funcall test) (handler-case (funcall test)
(error (c) (error (c)
(format t "~&The following error occurred in ~S: ~A~%" test (format t "~&The following error occurred in ~S: ~A~%" test
c))) c)))
(funcall test)))) (funcall test))))
...@@ -700,7 +700,7 @@ ...@@ -700,7 +700,7 @@
(exercise-frame 'test-it (exercise-frame 'test-it
'clim-user::clim-tests 'clim-user::clim-tests
'(:width 600 :height 400 :left 0 :top 0) '(:width 600 :height 400 :left 0 :top 0)
`(((clim-user::run-benchmarks `(((clim-user::run-benchmarks
:pathname ,pathname) :timeout 1800)) :pathname ,pathname) :timeout 1800))
`(clim-user::exit-clim-tests) `(clim-user::exit-clim-tests)
#+acl86win32 :anerror #-acl86win32 :error errorp)) #+acl86win32 :anerror #-acl86win32 :error errorp))
...@@ -715,7 +715,7 @@ ...@@ -715,7 +715,7 @@
(declare (dynamic-extent args)) (declare (dynamic-extent args))
;; This code is to handle the case where a partial command has been ;; This code is to handle the case where a partial command has been
;; passed in. PARSE-NORMAL-ARG needs to be called with a :DEFAULT of ;; passed in. PARSE-NORMAL-ARG needs to be called with a :DEFAULT of
;; the appropriate element of the partial command structure. ;; the appropriate element of the partial command structure.
(let* ((default (if copy-partial-command (let* ((default (if copy-partial-command
(pop copy-partial-command) (pop copy-partial-command)
*unsupplied-argument-marker*))) *unsupplied-argument-marker*)))
...@@ -726,7 +726,7 @@ ...@@ -726,7 +726,7 @@
command-table))) command-table)))
(return-from arg-parser (values command-name presentation-type))) (return-from arg-parser (values command-name presentation-type)))
(cond ((not (clim-internals::unsupplied-argument-p default)) (cond ((not (clim-internals::unsupplied-argument-p default))
(cond ((eq type-name 'keyword-argument-name) (cond ((eq type-name 'keyword-argument-name)
default) default)
(t (handler-case (apply #'parse-normal-arg (t (handler-case (apply #'parse-normal-arg
stream presentation-type stream presentation-type
...@@ -739,7 +739,7 @@ ...@@ -739,7 +739,7 @@
(let ((name (intern (symbol-name (caar parameters)) clim-internals::*keyword-package*))) (let ((name (intern (symbol-name (caar parameters)) clim-internals::*keyword-package*)))
(send-it name) (send-it name)
name)) name))
(t (t
(apply #'parse-normal-arg (apply #'parse-normal-arg
stream presentation-type stream presentation-type
:provide-default nil args)))))) :provide-default nil args))))))
...@@ -810,7 +810,7 @@ ...@@ -810,7 +810,7 @@
(with-slots (process avv-frame) invocation (with-slots (process avv-frame) invocation
(let ((query (find-avv-query (if pane-name (let ((query (find-avv-query (if pane-name
(car (gethash (get-invocation-pane invocation pane-name) (car (gethash (get-invocation-pane invocation pane-name)
(clim-internals::frame-pane-to-avv-stream-table (clim-internals::frame-pane-to-avv-stream-table
(invocation-frame invocation)))) (invocation-frame invocation))))
(slot-value avv-frame 'stream)) (slot-value avv-frame 'stream))
prompt))) prompt)))
...@@ -863,7 +863,7 @@ ...@@ -863,7 +863,7 @@
(funcall continuation) (funcall continuation)
(progn (progn
(unwind-protect (unwind-protect
(progn (progn
(prof::start-profiler :type type :verbose nil) (prof::start-profiler :type type :verbose nil)
(funcall continuation)) (funcall continuation))
(profiler:stop-profiler)) (profiler:stop-profiler))
...@@ -876,8 +876,8 @@ ...@@ -876,8 +876,8 @@
(let ((*execute-one-command-hook* #'profiling-hook)) (let ((*execute-one-command-hook* #'profiling-hook))
(funcall test)))) (funcall test))))
(defun wait-for-frame (&key (type t) (defun wait-for-frame (&key (type t)
(framem (find-frame-manager)) (framem (find-frame-manager))
timeout timeout
(state :enabled) (state :enabled)
(errorp t)) (errorp t))
...@@ -892,8 +892,8 @@ ...@@ -892,8 +892,8 @@
frame))) frame)))
(defun find-frame (&key (type t) (defun find-frame (&key (type t)
(framem (find-frame-manager)) (framem (find-frame-manager))
(state :enabled)) (state :enabled))
(find-if #'(lambda (frame) (find-if #'(lambda (frame)
(and (typep frame type) (and (typep frame type)
...@@ -932,7 +932,7 @@ ...@@ -932,7 +932,7 @@
(map-over-sheets #'(lambda (sheet) (map-over-sheets #'(lambda (sheet)
(dotimes (i n) (dotimes (i n)
(when (and (not (nth i result)) (when (and (not (nth i result))
(sheet-matches-specification-p (sheet-matches-specification-p
sheet (nth i specifications))) sheet (nth i specifications)))
(setf (nth i result) sheet)))) (setf (nth i result) sheet))))
(frame-top-level-sheet frame)) (frame-top-level-sheet frame))
...@@ -993,7 +993,7 @@ ...@@ -993,7 +993,7 @@
((null clauses) ((null clauses)
`(case ,which ,@(reverse res))) `(case ,which ,@(reverse res)))
(let ((clause (car clauses))) (let ((clause (car clauses)))
(push `(,(incf i) (push `(,(incf i)
(destructuring-bind ,(second clause) ,result (destructuring-bind ,(second clause) ,result
,@(cddr clause))) ,@(cddr clause)))
res)))))) res))))))
...@@ -1003,7 +1003,7 @@ ...@@ -1003,7 +1003,7 @@
;;; make the training selective. ;;; make the training selective.
(locally (declare (special si::*clos-preload-packages*)) (locally (declare (special si::*clos-preload-packages*))
(setq si::*clos-preload-packages* (setq si::*clos-preload-packages*
(mapcar #'find-package (mapcar #'find-package
'(:clim :clim-utils :clim-internals :silica :tk #-acl86win32 :xm-silica)))) '(:clim :clim-utils :clim-internals :silica :tk #-acl86win32 :xm-silica))))
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*-
;; $Header: /repo/cvs.copy/clim2/utils/packages.lisp,v 1.80 1998/03/06 19:06:42 layer Exp $ ;; $Header: /repo/cvs.copy/clim2/utils/packages.lisp,v 1.81 1998/03/17 23:32:06 duane Exp $
(in-package :common-lisp-user) (in-package :common-lisp-user)
...@@ -3301,7 +3301,7 @@ ...@@ -3301,7 +3301,7 @@
(cl:defvar *clim-major-version* 2) (cl:defvar *clim-major-version* 2)
(cl:defvar *clim-minor-version* 2) (cl:defvar *clim-minor-version* 2)
(cl:defvar *clim-generation-version* 1) (cl:defvar *clim-generation-version* 1)
(cl:defvar *clim-build-version* 8) (cl:defvar *clim-build-version* 9)
(cl:defparameter *clim-version* (cl:defparameter *clim-version*
(cl:format () "CLIM ~d.~d.~d.~a" (cl:format () "CLIM ~d.~d.~d.~a"
...@@ -3309,4 +3309,4 @@ ...@@ -3309,4 +3309,4 @@
*clim-generation-version* *clim-build-version*)) *clim-generation-version* *clim-build-version*))
#-aclpc #-aclpc
(si::rcsnote *clim-version* "$Id: packages.lisp,v 1.80 1998/03/06 19:06:42 layer Exp $") (si::rcsnote *clim-version* "$Id: packages.lisp,v 1.81 1998/03/17 23:32:06 duane Exp $")
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment