diff --git a/Makefile.defs b/Makefile.defs index 119a0fb1b4852bdcc245c78e0254cb740ced2940..64b7431aa305d7d27fc423d47fe7c84814b47d90 100644 --- a/Makefile.defs +++ b/Makefile.defs @@ -9,35 +9,6 @@ SHARED_EXT = so LISP = ../src/lispi$(exe) DCL = dcli -# Set the case mode when building and dumping an image -# case_mode: -# ansi -- traditional case-insensitive upper-case CL -# modern -- case-sensitive lower-case CL -case_mode = modern - -ifeq ($(case_mode),ansi) -CASE_MODE = :case-insensitive-upper -endif - -ifeq ($(case_mode),modern) -CASE_MODE = :case-sensitive-lower -endif - -ifndef CASE_MODE -..........................case_mode not defined or bad value................... -endif - -# This controls whether patches are loaded before dumping an image. -# They should be loaded except during development -# load_patches: -# yes -- load them -# no -- don't load -load_patches = yes - -ifeq ($(load_patches),no) -STOP_PATCHES = '(pushnew :clim-dont-load-patches *features*)' -endif - CL = $(LISP) -I $(DCL) CLOPTS = -qq -batch -backtrace-on-error -locale japan.euc @@ -73,10 +44,6 @@ endif # Used for tags ALL_SRC = *.lisp */*.lisp *.cl */*.cl *.c */*.c *.h */*.h -# These are the files that make up the source code product. -PRODUCT_SRC_FILES = sys/*.lisp utils/*.lisp silica/*.lisp clim/*.lisp \ - demo/*.lisp test/test-suite.lisp - ifneq ($(OS_NAME),windows) # This has to be kept consistent with xlib/xlib-funs.lisp UNDEFS=misc/undefinedsymbols diff --git a/Makefile.generic b/Makefile.generic index 5872eb9795f8cf1eabe28a023af35ec6a779287b..4a52d157676790ef90fcb26d4b95662c247a112e 100644 --- a/Makefile.generic +++ b/Makefile.generic @@ -18,8 +18,6 @@ compile: FORCE $(PRODUCT-OBJS) $(ICS-PRODUCT-OBJS) $(compile_depends) echo '(setq sys::*libxt-pathname* "$(XTLIB)")' >> build.tmp echo '(setq sys::*libx11-pathname* "$(XLIB)")' >> build.tmp echo '(setq sys::*libwnn-pathname* "$(WNNLIB)")' >> build.tmp - echo '(excl:set-case-mode $(CASE_MODE))' >> build.tmp - echo $(STOP_PATCHES) >> build.tmp echo '(load "misc/compile-1.lisp")' >> build.tmp echo '(declaim (optimize (speed $(SPEED)) (debug $(DEBUG)) (safety $(SAFETY))))' >> build.tmp echo '(setq *compile-print* $(compile_print))' >> build.tmp @@ -204,9 +202,6 @@ install_obj: install_clim: install_obj cp $(PRODUCT-FASLS) $(ICS-PRODUCT-FASLS) $(DEST) -echo_src_files: - @echo $(PRODUCT_SRC_FILES) - include Makefile.cobjs include Makefile.wnn diff --git a/aclpc/acl-frames.lisp b/aclpc/acl-frames.lisp index ffd2db2809708f2ba3fdc992e5ca08608934d3b6..5f6717bff6f8fbe8ef2603ded5703e4d22f8b194 100644 --- a/aclpc/acl-frames.lisp +++ b/aclpc/acl-frames.lisp @@ -288,7 +288,7 @@ (setf (aref stringvar newlen) #\null) (setf (fill-pointer stringvar) newlen)) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defconstant *nstringify-buffer-default-size* 2048) (defvar nstringify-buffer (make-array *nstringify-buffer-default-size* :fill-pointer t @@ -1127,7 +1127,7 @@ to be run from another." (car dotted-pair) (cdr dotted-pair) (code-char 0) (cdr dotted-pair) (code-char 0)))) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) ;; All pathnames returned by SELECT-FILE must fit in the scratch string, ;; so make it pretty big. (defconstant *scratch-string-length* 2048) @@ -1139,7 +1139,7 @@ to be run from another." (defparameter *scratch-c-string* (ff:allocate-fobject-c `(:array :char ,*scratch-string-length*))) -(eval-when (compile eval load) +(eval-when (:compile-toplevel :execute :load-toplevel) ;; this type useful since we don't open code anonymous types well yet: (ff:def-foreign-type foreign-string (:array :char 1)) ) diff --git a/aclpc/acl-medium.lisp b/aclpc/acl-medium.lisp index ff4a20ee98f7d46970fc84dfc810e3ee503c8f20..52c19ebd54ddfca797b1a00ced53fd78082a7f54 100644 --- a/aclpc/acl-medium.lisp +++ b/aclpc/acl-medium.lisp @@ -155,15 +155,12 @@ (color-rgb (wincolor->color (win:GetSysColor win:COLOR_BTNFACE)))) (defmethod dc-image-for-ink ((medium acl-medium) (ink (eql +foreground-ink+))) - (declare (values image created-bitmap created-mask-bitmap)) (dc-image-for-ink medium (medium-foreground medium))) (defmethod dc-image-for-ink ((medium acl-medium) (ink (eql +background-ink+))) - (declare (values image created-bitmap created-mask-bitmap)) (dc-image-for-ink medium (medium-background medium))) (defmethod dc-image-for-ink ((medium acl-medium) (ink t)) - (declare (values image created-bitmap created-mask-bitmap)) ;; Don't blow out if somebody tries to use a fancy ink like compose-in. (dc-image-for-ink medium (medium-foreground medium))) @@ -209,7 +206,6 @@ (convert blue)))))) (defmethod dc-image-for-ink ((medium acl-medium) (ink color)) - (declare (values image created-bitmap created-mask-bitmap)) (let ((cache (port-dc-cache (port medium)))) (or (gethash ink cache) (setf (gethash ink cache) @@ -235,17 +231,14 @@ *blank-image*) (defmethod dc-image-for-ink ((medium acl-medium) (ink (eql +everywhere+))) - (declare (values image created-bitmap created-mask-bitmap)) (dc-image-for-ink medium +foreground-ink+)) (defmethod dc-image-for-ink ((medium acl-medium) (ink standard-opacity)) - (declare (values image created-bitmap created-mask-bitmap)) (if (>= (opacity-value ink) 0.5) (dc-image-for-ink medium +foreground-ink+) *blank-image*)) (defmethod dc-image-for-ink ((medium acl-medium) (ink region)) - (declare (values image created-bitmap created-mask-bitmap)) (dc-image-for-ink medium +foreground-ink+)) ;;; ink for patterns, tiles, etc @@ -439,7 +432,6 @@ (color->wincolor (elt designs tcolor)))))) (defmethod dc-image-for-ink ((medium acl-medium) (ink pattern)) - (declare (values image created-bitmap created-mask-bitmap)) ;; The "pattern" part of the ink is put into the brush. ;; This will return a list of two DCs if one of the inks is transparent. (let ((cache (port-dc-cache (port medium)))) @@ -506,7 +498,6 @@ draw icons and mouse cursors on the screen. |# (defmethod dc-image-for-ink ((medium acl-medium) (ink rectangular-tile)) - (declare (values image created-bitmap created-mask-bitmap)) ;; The only case we handle right now is stipples (let ((cache (port-dc-cache (port medium)))) (or (gethash ink cache) @@ -541,7 +532,6 @@ draw icons and mouse cursors on the screen. (error "This NT CLIM operation is NYI (Not Yet Implemented).")) (defmethod dc-image-for-ink ((medium acl-medium) (ink flipping-ink)) - (declare (values image created-bitmap created-mask-bitmap)) (let ((cache (port-dc-cache (port medium)))) (or (gethash ink cache) (setf (gethash ink cache) @@ -565,7 +555,6 @@ draw icons and mouse cursors on the screen. :background-color nil)))))))) (defmethod dc-image-for-ink ((medium acl-medium) (ink contrasting-ink)) - (declare (values image created-bitmap created-mask-bitmap)) (dc-image-for-ink medium (make-color-for-contrasting-ink ink))) (defmethod dc-image-for-ink ((medium acl-medium) (ink composite-out)) @@ -1819,7 +1808,7 @@ device-independent bitmap, an icon, nor a cursor.")) (setf (gethash "magenta" table) +magenta+) table)) -(eval-when (load eval) +(eval-when (:load-toplevel :execute) (initialize-named-colors)) (defun clim-internals::kana-process-gesture (istream gesture type) diff --git a/aclpc/acl-scroll.lisp b/aclpc/acl-scroll.lisp index 208a21932d30b5886339e7e36b3b9ee703ab350f..3775d441dd2b820dd492889e4a4eb32108800c2d 100644 --- a/aclpc/acl-scroll.lisp +++ b/aclpc/acl-scroll.lisp @@ -16,7 +16,7 @@ (in-package :silica) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (define-event-class scrollbar-event (event) ((sheet :reader event-sheet :initarg :sheet) (orientation :initarg :orientation :reader scrollbar-event-orientation) @@ -474,7 +474,7 @@ (resize-sheet child nwidth nheight) ;;; get the viewport sized correctly! (allocate-space child nwidth nheight))) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) ;; Turn this on as long as it gets turned off in pkgdcl.lisp (setq excl:*enable-package-locked-errors* common-lisp-user::*lock-preference*) (provide :climnt)) diff --git a/aclpc/acl-widget.lisp b/aclpc/acl-widget.lisp index 561e98728289e7cf6f2b9f13b26c5002c4414d58..9932990ed510be071d7a6e390d8100519dd61ce0 100644 --- a/aclpc/acl-widget.lisp +++ b/aclpc/acl-widget.lisp @@ -486,7 +486,6 @@ ;;; Retreive the start and end position of the ;;; selection in a mswin-text-edit gadget. (defmethod get-selection ((pane mswin-text-edit)) - (declare (values startpos endpos)) (let ((mirror (sheet-direct-mirror pane))) (cond (mirror (let ((startptr diff --git a/aclpc/pkgdcl.lisp b/aclpc/pkgdcl.lisp index 1882e804161af2abeef6d776243eaba4a003f101..f429f76f3f569d8f5df4ba8cb6dcd42b84784794 100644 --- a/aclpc/pkgdcl.lisp +++ b/aclpc/pkgdcl.lisp @@ -15,7 +15,7 @@ #-(and mswindows 64bit) t) ;; Invite everybody to the party. -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (require :climg) ;; [rfe4951]: not needed anymore: ;; (require :ffcompat) @@ -48,7 +48,7 @@ #:make-windows-font-named ;make a windows font from a name )) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :aclmerge *features*) (pushnew :os-threads *features*)) diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index 37d12877ebcb57ff05414a4cd52e18d2d18c76a6..e59d12ecc9b680cc446b0b05fe5abfccf4708a68 100644 --- a/clim/accept-values.lisp +++ b/clim/accept-values.lisp @@ -28,7 +28,6 @@ (:default-initargs :query-table (make-hash-table :test #'equal))) (defmethod find-query ((record accept-values-output-record) query-identifier) - (declare (values query found-p)) (gethash query-identifier (slot-value record 'query-table))) ;; We are in control of the AVV code, and we know that there is only 1 AVV @@ -1144,12 +1143,6 @@ &body body &environment env) #+Genera (declare (zwei:indentation 1 3 2 1)) #-(or Genera Minima) (declare (ignore env)) - #-acl3.0 ; temporary restriction? - (declare (arglist ((&optional stream - &key documentation query-identifier - (cache-value t) (cache-test #'eql) - view resynchronize) - prompt &body body))) (default-input-stream stream accept-values-command-button) (with-keywords-removed (options options '(:view)) (let ((constant-prompt-p diff --git a/clim/accept.lisp b/clim/accept.lisp index 930240259a31ddc25ebf81fde5071194a2b9ce46..38c526e02c102eac4c184af6958d22738dc708bf 100644 --- a/clim/accept.lisp +++ b/clim/accept.lisp @@ -24,7 +24,6 @@ (insert-default nil) (replace-input t) (present-p nil) (active-p t)) (declare (dynamic-extent accept-args)) - (declare (values object type)) (declare (ignore prompt-mode display-default activation-gestures additional-activation-gestures delimiter-gestures additional-delimiter-gestures @@ -336,7 +335,6 @@ (delimiter-gestures nil delimiter-gestures-p) (additional-delimiter-gestures nil) (start 0) (end nil)) - (declare (values object type index)) ;; Allow the arguments to be presentation type abbreviations (multiple-value-bind (expansion expanded) diff --git a/clim/basic-translators.lisp b/clim/basic-translators.lisp index 6ba5a75e4deb3e865900916ea02e811326398c09..b6a2a94f6d0b280ff08237a2d4e9581376121116 100644 --- a/clim/basic-translators.lisp +++ b/clim/basic-translators.lisp @@ -43,7 +43,7 @@ (presentation-subtypep-1 type-name context-name) (presentation-typep object context-type)))))))) -(eval-when (compile eval load) +(eval-when (:compile-toplevel :execute :load-toplevel) ;; Only the PRESENTATION-MENU translator lives in this (unless (find-command-table 'presentation-menu-command-table :errorp nil) (make-command-table 'presentation-menu-command-table :inherit-from nil)) diff --git a/clim/clim-defs.lisp b/clim/clim-defs.lisp index c1048995b60e6d88a6cfca93e8414904c8647fd6..0916b7e66ff894f286f8ba4d31c7b6f03eafb693 100644 --- a/clim/clim-defs.lisp +++ b/clim/clim-defs.lisp @@ -88,7 +88,7 @@ ,(if record-supplied record `(stream-recording-p ,new-stream)) ,(if draw-supplied draw `(stream-drawing-p ,new-stream))))))) -(eval-when (compile eval load) +(eval-when (:compile-toplevel :execute :load-toplevel) (defvar *output-record-constructor-cache* (make-hash-table)) (defmacro construct-output-record (type &rest initargs &environment env) @@ -292,8 +292,7 @@ &key partial-completers allow-any-input possibility-printer (help-displays-possibilities t)) &body body) - (declare (values object success string nmatches) - (ignore allow-any-input possibility-printer help-displays-possibilities)) + (declare (ignore allow-any-input possibility-printer help-displays-possibilities)) #+Genera (declare (zwei:indentation 0 3 1 1)) (let ((string '#:string) (action '#:action)) @@ -345,14 +344,6 @@ ;;; From ACCEPTING-VALUES.LISP (defmacro accepting-values ((&optional stream &rest args) &body body) - (declare (arglist (&optional stream - &key frame-class command-table own-window - background foreground text-style - exit-boxes resize-frame align-prompts - initially-select-query-identifier modify-initial-query - resynchronize-every-pass (check-overlapping t) - label x-position y-position width height (scroll-bars nil)) - &body body)) #+Genera (declare (zwei:indentation 0 3 1 1)) (default-input-stream stream accepting-values) `(flet ((accepting-values-body (,stream) ,@body)) diff --git a/clim/command.lisp b/clim/command.lisp index 81c1ae43012a48c743013dbe9fe722ad60a031a9..3d0b31dbea86585ee6bb6b83ecc572de4eb8c54d 100644 --- a/clim/command.lisp +++ b/clim/command.lisp @@ -313,7 +313,6 @@ (gethash command-name (slot-value command-table 'commands))) (defun command-accessible-in-command-table-p (command-name command-table) - (declare (values command-table)) (do-command-table-inheritance (comtab command-table) (when (command-present-in-command-table-p command-name comtab) (return-from command-accessible-in-command-table-p comtab))) @@ -385,7 +384,6 @@ (slot-value (find-command-table command-table) 'command-line-names)))) (defun find-command-from-command-line-name (name command-table &key (errorp t)) - (declare (values command command-table)) (do-command-table-inheritance (comtab command-table) ;;--- Use binary search on COMMAND-LINE-NAMES (completion aarrays) (let ((item (find name (slot-value comtab 'command-line-names) @@ -549,7 +547,6 @@ (slot-value (find-command-table command-table) 'menu))) (defun find-menu-item (menu-name command-table &key (errorp t)) - (declare (values menu-item command-table)) (let* ((command-table (find-command-table command-table)) (item (find menu-name (slot-value command-table 'menu) :test #'menu-name-equal :key #'first))) @@ -786,7 +783,6 @@ (defun find-keystroke-item (keystroke command-table &key (test #'keyboard-event-matches-gesture-name-p) (errorp t)) - (declare (values menu-item command-table)) (let* ((command-table (find-command-table command-table)) (entry (block find-entry ;; Do it the hard way so that GESTURE-SPEC-EQL doesn't see NILs @@ -805,7 +801,6 @@ (defun lookup-keystroke-item (keystroke command-table &key (test #'keyboard-event-matches-gesture-name-p)) - (declare (values menu-item command-table)) (labels ((map-menu (command-table) (map nil #'(lambda (entry) (let ((item (third entry))) @@ -919,7 +914,6 @@ (funcall function translator)))))) (defun find-presentation-translator (translator-name command-table &key (errorp t)) - (declare (values command command-table)) (when (presentation-translator-p translator-name) (setq translator-name (presentation-translator-name translator-name))) (do-command-table-inheritance (comtab command-table) @@ -1178,7 +1172,6 @@ (defvar *define-command-options* '(:command-table :name :menu :keystroke)) (defun decode-name-and-options (name-and-options &optional command-table-name) - (declare (values command-name command-options)) (if (symbolp name-and-options) (values name-and-options nil) (let ((name (first name-and-options)) diff --git a/clim/completer.lisp b/clim/completer.lisp index f99face190d38a3cf7adb039a812afbe6af9586e..a8a0ee790a51f6de2499380e656a70a4c6b4471f 100644 --- a/clim/completer.lisp +++ b/clim/completer.lisp @@ -44,7 +44,6 @@ &key partial-completers allow-any-input possibility-printer (help-displays-possibilities t)) (declare (dynamic-extent function)) - (declare (values answer-object success string)) (with-temporary-string (stuff-so-far :length 100 :adjustable t) (with-delimiter-gestures (partial-completers) (with-activation-gestures (*magic-completion-gestures*) @@ -278,7 +277,6 @@ (defun complete-from-possibilities (string completions delimiters &key (action :complete) predicate (name-key #'first) (value-key #'second)) - (declare (values string success object nmatches possibilities)) (when (and (not (eq action :possibilities)) (not (eq action :apropos-possibilities)) (zerop (length string))) @@ -318,7 +316,6 @@ ;; gotten by funcalling a generator rather than from a completion alist. (defun complete-from-generator (string generator delimiters &key (action :complete) predicate) - (declare (values string success object nmatches possibilities)) (declare (dynamic-extent generator)) (when (and (not (eq action :possibilities)) (not (eq action :apropos-possibilities)) @@ -356,7 +353,6 @@ (defun chunkwise-complete-string (string completion object action delimiters best-completion best-length best-object nmatches possibilities) - (declare (values best-completion best-length best-object nmatches possibilities)) (let* ((length (length string)) (matches (if (eq action :apropos-possibilities) (if (search string completion :test #'char-equal) length 0) @@ -408,7 +404,6 @@ ;; where the strings mismatches and the index of the last character that was ;; unambiguous. When MERGE-P, STRING1 gets side-effected. (defun chunkwise-string-compare (string1 string2 delimiters &optional merge-p end1) - (declare (values matched ambiguous)) (let ((len1 (or end1 (length string1))) (len2 (length string2)) (matched 0) diff --git a/clim/cursor.lisp b/clim/cursor.lisp index b105ce03354ba8535a3ec795a17a5b69ed0d430a..5fa958d14e39712338f7aca4ea54228765ae872a 100644 --- a/clim/cursor.lisp +++ b/clim/cursor.lisp @@ -51,15 +51,14 @@ ;; cares?? --CIM (values x y (+ x width) (+ y width)))) -(defconstant cursor_active (byte 1 0)) -(defconstant cursor_state (byte 1 1)) -(defconstant cursor_focus (byte 1 2)) +(defparameter +cursor-active+ (byte 1 0)) +(defparameter +cursor-state+ (byte 1 1)) +(defparameter +cursor-focus+ (byte 1 2)) (defun decode-cursor-flags (flags) - #+Genera (declare (values active state focus)) - (values (ldb-test cursor_active flags) - (ldb-test cursor_state flags) - (ldb-test cursor_focus flags))) + (values (ldb-test +cursor-active+ flags) + (ldb-test +cursor-state+ flags) + (ldb-test +cursor-focus+ flags))) ;;; Required method (defmethod (setf cursor-stream) (new-value (cursor standard-text-cursor)) @@ -96,33 +95,33 @@ (multiple-value-bind (active state focus) (decode-cursor-flags flags) (declare (ignore active focus)) - (setf (ldb cursor_state flags) (if new-state 1 0)) + (setf (ldb +cursor-state+ flags) (if new-state 1 0)) (note-cursor-change cursor 'cursor-state state new-state)))) (defmethod cursor-state ((cursor standard-text-cursor)) - (ldb-test cursor_state (slot-value cursor 'flags))) + (ldb-test +cursor-state+ (slot-value cursor 'flags))) (defmethod (setf cursor-active) (new-active (cursor standard-text-cursor)) (with-slots (flags) cursor (multiple-value-bind (active state focus) (decode-cursor-flags flags) (declare (ignore state focus)) - (setf (ldb cursor_active flags) (if new-active 1 0)) + (setf (ldb +cursor-active+ flags) (if new-active 1 0)) (note-cursor-change cursor 'cursor-active active new-active)))) (defmethod cursor-active ((cursor standard-text-cursor)) - (ldb-test cursor_active (slot-value cursor 'flags))) + (ldb-test +cursor-active+ (slot-value cursor 'flags))) (defmethod (setf cursor-focus) (new-focus (cursor standard-text-cursor)) (with-slots (flags) cursor (multiple-value-bind (active state focus) (decode-cursor-flags flags) (declare (ignore active state)) - (setf (ldb cursor_focus flags) (if new-focus 1 0)) + (setf (ldb +cursor-focus+ flags) (if new-focus 1 0)) (note-cursor-change cursor 'cursor-focus focus new-focus)))) (defmethod cursor-focus ((cursor standard-text-cursor)) - (ldb-test cursor_focus (slot-value cursor 'flags))) + (ldb-test +cursor-focus+ (slot-value cursor 'flags))) (defmethod (setf cursor-color) (color (cursor standard-text-cursor)) (with-slots (flipping-ink flags) cursor diff --git a/clim/db-menu.lisp b/clim/db-menu.lisp index ca1293c7e8060d3e137ddd5f8350be712b3259da..aef0faa9bfb8e110a54cd90c44a07a661c9f90ca 100644 --- a/clim/db-menu.lisp +++ b/clim/db-menu.lisp @@ -27,7 +27,7 @@ ((next-menu :initform nil :initarg :next-menu))) ;;;#+(or aclpc acl86win32) -;;;(eval-when (compile load eval) +;;;(eval-when (:compile-toplevel :load-toplevel :execute) ;;; ;;mm: 11Jan95 - this is defined later in ??? ;;; (unless (ignore-errors (find-class 'pull-down-menu)) ;;; (defclass pull-down-menu () ()))) @@ -285,8 +285,10 @@ (make-pane 'menu-bar-button-logic :label name :next-menu value) - (error "not yet implemented") - ))) + (make-pane 'push-button + :label name) + ;(error "not yet implemented") + ))) (make-command-table-menu command-table)))) (make-pane 'hbox-pane :contents buttons :min-height 2 :height 2)))) diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp index 5d6c77e178524aec73ece0f817e20ca6f0632f21..0b454275dbd871b5aa9dddfa97560d4801fb01d8 100644 --- a/clim/db-stream.lisp +++ b/clim/db-stream.lisp @@ -137,7 +137,6 @@ (setf display-time value))) (defmethod pane-needs-redisplay ((pane clim-stream-pane)) - (declare (values needs-redisplay clear)) (with-slots (display-time) pane (ecase display-time ((t) @@ -379,7 +378,7 @@ () (:default-initargs :default-view +gadget-dialog-view+)) -(eval-when (compile) +(eval-when (:compile-toplevel) ;; defined later in the compilation... (declaim (special *default-menu-text-style*)) ) @@ -454,8 +453,10 @@ :name name :thickness 1 :contents pane - :background background) - :background background))) + ;; :background background + ) + ;; :background background -- NOTE this actually should work! + ))) (values pane stream)))) (defmacro make-clim-interactor-pane (&rest options) diff --git a/clim/design-recording.lisp b/clim/design-recording.lisp index 36ecc4c714df72954a4aedac4393f6b04b8dbc20..1e0f97b05b6107dc9922300a959e3c3ff8500213 100644 --- a/clim/design-recording.lisp +++ b/clim/design-recording.lisp @@ -28,9 +28,7 @@ (map-over-output-records #'make-design record)) (make-instance 'composite-over :designs (apply #'vector designs)))) -(defgeneric draw-design (design stream &rest args) - #-(or aclpc acl86win32) (declare (arglist design stream &key . #.(all-drawing-options-lambda-list nil)))) - +(defgeneric draw-design (design stream &rest args)) ;;; Simple composite designs (defmethod draw-design ((composite composite-over) stream &rest args) diff --git a/clim/dragging-output.lisp b/clim/dragging-output.lisp index e9d715c9f97d216670e1e71657b35029fdec7355..e1e5e95e7b51410210b99282e22e05aaaca3f823 100644 --- a/clim/dragging-output.lisp +++ b/clim/dragging-output.lisp @@ -26,7 +26,6 @@ &key (repaint t) multiple-window (erase #'erase-output-record erase-sp) feedback (finish-on-release *dragging-output-finish-on-release*)) - (declare (values final-x final-y delta-x delta-y)) (let (last-x last-y (delta-x 0) (delta-y 0) diff --git a/clim/frames.lisp b/clim/frames.lisp index 2ae4cc0b6ca0e7c039110ffca9c11f7bc18736c9..633e732914b0a02058ac9711b520608709c065d4 100644 --- a/clim/frames.lisp +++ b/clim/frames.lisp @@ -138,7 +138,7 @@ (frame standard-application-frame)) (adjust-layout-requirements frame (frame-current-layout frame))) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defun define-application-frame-1 (name state-variables pane-descriptions &key top-level layouts command-table) @@ -233,7 +233,7 @@ `',layout))) layouts)))) `(progn - (eval-when (compile) + (eval-when (:compile-toplevel) (when ',command-table (setf (compile-time-property ',(first command-table) 'command-table-name) t)) (define-application-frame-1 ',name ',slots ,pane-constructors @@ -907,69 +907,69 @@ (defmethod default-frame-top-level ((frame standard-application-frame) &key command-parser command-unparser - partial-command-parser - (prompt "Command: ")) + partial-command-parser + (prompt "Command: ")) (unless (eq (frame-state frame) :enabled) (enable-frame frame)) (loop - (let* ((*standard-output* - (or (frame-standard-output frame) *standard-output*)) - (*standard-input* - (or (frame-standard-input frame) *standard-input*)) - (*query-io* - (or (frame-query-io frame) *query-io*)) - (*error-output* - (or (frame-error-output frame) *error-output*)) - (*pointer-documentation-output* - (frame-pointer-documentation-output frame)) - (interactor - (not (null (find-frame-pane-of-type frame 'interactor-pane)))) - (*command-parser* - (or command-parser - (if interactor - #'command-line-command-parser - #'menu-command-parser))) - (*command-unparser* - (or command-unparser - #'command-line-command-unparser)) - (*partial-command-parser* - (or partial-command-parser - (if interactor - #'command-line-read-remaining-arguments-for-partial-command - #'menu-read-remaining-arguments-for-partial-command))) - (command-stream - ;;--- We have to ask the frame since we do not want to - ;;--- just pick up a stream from the dynamic environment - (let ((si (or (frame-standard-input frame) - (frame-standard-output frame)))) - (typecase si - (output-protocol-mixin si) - (t (frame-top-level-sheet frame))))) - (*avv-refreshed* nil)) - ;; The read-eval-print loop for applications... - (letf-globally (((frame-actual-pointer-documentation-pane frame) - *pointer-documentation-output*)) - (loop - ;; Redisplay all the panes - (catch-abort-gestures ("Return to ~A command level" (frame-pretty-name frame)) - (redisplay-frame-panes frame) - (when (not *avv-refreshed*) - ;;; This needs to happen after the - ;;; call to redisplay-frame-panes - ;;; but only do it the first time. - (force-refresh-avv-streams frame) - (setq *avv-refreshed* t)) - (when interactor - (fresh-line *standard-input*) - (if (stringp prompt) - (write-string prompt *standard-input*) - (funcall prompt *standard-input* frame))) - (let ((command (read-frame-command frame :stream command-stream))) - (when interactor - (terpri *standard-input*)) - ;; Need this check in case the user aborted out of a command menu - (when command - (execute-frame-command frame command))))))))) + (let* ((*standard-output* + (or (frame-standard-output frame) *standard-output*)) + (*standard-input* + (or (frame-standard-input frame) *standard-input*)) + (*query-io* + (or (frame-query-io frame) *query-io*)) + (*error-output* + (or (frame-error-output frame) *error-output*)) + (*pointer-documentation-output* + (frame-pointer-documentation-output frame)) + (interactor + (not (null (find-frame-pane-of-type frame 'interactor-pane)))) + (*command-parser* + (or command-parser + (if interactor + #'command-line-command-parser + #'menu-command-parser))) + (*command-unparser* + (or command-unparser + #'command-line-command-unparser)) + (*partial-command-parser* + (or partial-command-parser + (if interactor + #'command-line-read-remaining-arguments-for-partial-command + #'menu-read-remaining-arguments-for-partial-command))) + (command-stream + ;;--- We have to ask the frame since we do not want to + ;;--- just pick up a stream from the dynamic environment + (let ((si (or (frame-standard-input frame) + (frame-standard-output frame)))) + (typecase si + (output-protocol-mixin si) + (t (frame-top-level-sheet frame))))) + (*avv-refreshed* nil)) + ;; The read-eval-print loop for applications... + (letf-globally (((frame-actual-pointer-documentation-pane frame) + *pointer-documentation-output*)) + (loop + ;; Redisplay all the panes + (catch-abort-gestures ("Return to ~A command level" (frame-pretty-name frame)) + (redisplay-frame-panes frame) + (when (not *avv-refreshed*) +;;; This needs to happen after the +;;; call to redisplay-frame-panes +;;; but only do it the first time. + (force-refresh-avv-streams frame) + (setq *avv-refreshed* t)) + (when interactor + (fresh-line *standard-input*) + (if (stringp prompt) + (write-string prompt *standard-input*) + (funcall prompt *standard-input* frame))) + (let ((command (read-frame-command frame :stream command-stream))) + (when interactor + (terpri *standard-input*)) + ;; Need this check in case the user aborted out of a command menu + (when command + (execute-frame-command frame command))))))))) (defmethod force-refresh-avv-streams (frame) ;;; NOTE: Not using get-frame-pane-to-avv-stream-table. @@ -1278,7 +1278,10 @@ (re-enable-menu-items ,frame))) (defmethod execute-frame-command ((frame standard-application-frame) command) - (apply (command-name command) (command-arguments command)) + ;; NOTE WORKAROUND added a when clause because demo sometimes passes :timeout + ;; as `command', which is obviously not a list. -- jacek.zlydach, 2017-05-14 + (when (listp command) + (apply (command-name command) (command-arguments command))) #+ignore ;; from jeff on 4/8/99 (with-menu-disabled frame (apply (command-name command) (command-arguments command)))) @@ -1370,7 +1373,7 @@ (process-command-event sheet event)) ;;;#+(or aclpc acl86win32) -;;;(eval-when (compile load eval) +;;;(eval-when (:compile-toplevel :load-toplevel :execute) ;;; ;;mm: 11Jan95 - this is defined later in ??? ;;; (unless (ignore-errors (find-class 'activity-frame)) ;;; (defclass activity-frame () ()))) @@ -1489,13 +1492,18 @@ (defun find-frame-pane-of-type (frame type) (map-over-sheets #'(lambda (sheet) - (when (typep sheet type) - (return-from find-frame-pane-of-type sheet))) - (frame-top-level-sheet frame))) + (when (typep sheet type) + (return-from find-frame-pane-of-type sheet))) + (frame-top-level-sheet frame))) (defmethod frame-standard-output ((frame standard-application-frame)) - (if (not (member '*standard-output* (slot-value frame - 'non-frame-stream-names))) + ;; NOTE WORKAROUND returning `*standard-output*' instead of executing the following block, + ;; because the value found by it (during initialization of the demo) causes a "app pane not a stream" + ;; error. + *standard-output* + ;; commented out because it causes frame-not-a-stream error + #+nil(if (not (member '*standard-output* (slot-value frame + 'non-frame-stream-names))) (or (find-frame-pane-of-type frame 'application-pane) (find-frame-pane-of-type frame 'interactor-pane)) @@ -1503,9 +1511,9 @@ (defmethod frame-standard-input ((frame standard-application-frame)) (if (not (member '*standard-input* (slot-value frame - 'non-frame-stream-names))) + 'non-frame-stream-names))) (or (find-frame-pane-of-type frame 'interactor-pane) - (frame-standard-output frame)))) + (frame-standard-output frame)))) (defmethod frame-query-io ((frame standard-application-frame)) (if (not (member '*query-io* (slot-value frame diff --git a/clim/gestures.lisp b/clim/gestures.lisp index d86ef06b124982ccc6b6075ba517fb39caaff318..7288d190ec855f96e3533e4098d86948786f48a3 100644 --- a/clim/gestures.lisp +++ b/clim/gestures.lisp @@ -15,7 +15,7 @@ ;;; as per CLtL. ;;; 2) The set of possible "mouse buttons" is :LEFT, :MIDDLE, and :RIGHT. -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) ;; Button indices are 0, 1, or 2 (defun-inline button-index (name) @@ -85,7 +85,6 @@ ,@body)))))) (defun gesture-name-button-and-modifiers (gesture-name) - (declare (values button modifier-state)) (do-button-and-modifier-state (button modifier-state bucket) (when (member gesture-name bucket) (return-from gesture-name-button-and-modifiers @@ -94,7 +93,6 @@ nil) (defun gesture-name-keysym-and-modifiers (gesture-name) - (declare (values keysym modifier-state)) (dotimes (index (ash 1 (length *modifier-keys*))) (let ((bucket (aref *keysym-and-modifier-key->gesture* index))) (dolist (entry bucket) @@ -241,7 +239,6 @@ (= m1 m2))))) (defun parse-gesture-spec (gesture-spec) - (declare (values keysym modifier-state)) (when (atom gesture-spec) (return-from parse-gesture-spec (if (and (characterp gesture-spec) @@ -267,7 +264,6 @@ ;; A slower, more careful version of the above that gets used to ;; validate programmer input (defun decode-gesture-spec (gesture-spec &key (errorp t)) - (declare (values keysym modifiers)) (when (atom gesture-spec) (return-from decode-gesture-spec (values gesture-spec nil))) diff --git a/clim/histories.lisp b/clim/histories.lisp index c35f464cdd885b43f6d2bbe7f640aae4773c89ad..cfdea3aa61be050d6b423451baf5bd13fd6f1d8f 100644 --- a/clim/histories.lisp +++ b/clim/histories.lisp @@ -97,7 +97,6 @@ ;; Get the element from HISTORY indexed by INDEX. (defmethod history-element ((history basic-history) index &optional fixup-p) - (declare (values element index)) (let ((delta 0)) (with-slots (elements current-length temporary-element) history (without-scheduling @@ -119,8 +118,6 @@ ;; of one argument, the element. (defmacro do-history-elements ((history element-var index-var &rest options) &body body) - (declare (arglist (history element-var index-var - &key index offset cutoff-length test) &body body)) `(flet ((do-history-elements-body (,element-var ,index-var) ,@body)) (declare (dynamic-extent #'do-history-elements-body)) (do-history-elements-1 ,history #'do-history-elements-body ,@options))) @@ -363,11 +360,11 @@ (view nil)) #+(and allegro aclpc) -(eval-when (compile load) +(eval-when (:compile-toplevel :load-toplevel) (setf (find-class 'presentation-history-element) nil)) #+(and allegro aclpc) -(eval-when (compile) +(eval-when (:compile-toplevel) (warn "~S structure hacked for bug2419" 'presentation-history-element)) (defun make-presentation-type-history (type &key (maximum-length *default-history-length*) diff --git a/clim/incremental-redisplay.lisp b/clim/incremental-redisplay.lisp index 8b4d7772120747b679cc3d8a4281c9633d600516..e275a47bab0906018ecee6346a8bb9a7bb26e8e2 100644 --- a/clim/incremental-redisplay.lisp +++ b/clim/incremental-redisplay.lisp @@ -13,7 +13,9 @@ ;;; We use the term "extent" here to mean a bounding rectangle... ;; A fixnum, incremented only with ATOMIC-INCF -(defvar *generation-tick* 0) +(declaim (type fixnum *generation-tick*)) +#+sbcl(sb-ext:defglobal *generation-tick* 0) +#-sbcl(defvar *generation-tick* 0) (define-protocol-class updating-output-record (output-record)) @@ -315,8 +317,14 @@ `(letf-globally (((stream-redisplaying-p ,stream) t)) ;; the generation is only necessary for output-records that move ;; in the hierarchy. - (let ((*generation-tick* (atomic-incf *generation-tick*))) - ,@body))) + + ;; NOTE not sure if this is a proper workaround due to SBCL requiring + ;; *generation-tick* to be "global", i.e. not special. -- jacek.zlydach, 2017-05-06 + #-sbcl (let ((*generation-tick* (atomic-incf *generation-tick*))) + ,@body) + #+sbcl (progn + (atomic-incf *generation-tick*) + ,@body))) (defun redisplay (record stream &key (check-overlapping t)) (unless (redisplayable-stream-p stream) @@ -445,7 +453,6 @@ (x-offset (coordinate 0)) (y-offset (coordinate 0)) (old-x-offset (coordinate 0)) (old-y-offset (coordinate 0))) (declare (type coordinate x-offset y-offset old-x-offset old-y-offset)) - (declare (values erases moves draws erase-overlapping move-overlapping)) #-aclpc (declare (ignore check-overlapping)) #+ignore (when (eq record wt::*c*) (break "found it")) (let ((erases nil) @@ -549,7 +556,6 @@ &optional (x-offset (coordinate 0)) (y-offset (coordinate 0)) (old-x-offset (coordinate 0)) (old-y-offset (coordinate 0))) (declare (type coordinate x-offset y-offset old-x-offset old-y-offset)) - (declare (values erases moves draws erase-overlapping move-overlapping)) (let ((new-draws nil)) (labels ((augment-draws (record x-offset y-offset old-x-offset old-y-offset) (let ((erases-that-overlap nil)) @@ -815,8 +821,6 @@ (old-child-extent (output-record-old-bounding-rectangle child)) erases moves draws erase-overlapping move-overlapping) - (declare (values new-mode new-erases new-moves new-draws - new-erase-overlapping new-move-overlapping)) #-aclpc (declare (ignore move-overlapping erase-overlapping draws moves erases old-child-extent old-child-position)) ;--- Why ;; If :DELETE, and deleted all children, delete self, @@ -930,7 +934,6 @@ &optional check-overlapping (x-offset (coordinate 0)) (y-offset (coordinate 0)) (old-x-offset (coordinate 0)) (old-y-offset (coordinate 0))) - (declare (values erases moves draws erase-overlapping move-overlapping)) #-aclpc (declare (ignore old-x-offset old-y-offset check-overlapping)) (with-slots (all-new old-bounding-rectangle contents-ok old-parent) record ;; if it's all-new, don't bother walking the hierarchy, just redraw. diff --git a/clim/input-defs.lisp b/clim/input-defs.lisp index 4319a5f15a102d5aeadccbf7f168049a87a3bcaa..3d2a8e7518ec291282de9a7887ca4f32e2fa3e31 100644 --- a/clim/input-defs.lisp +++ b/clim/input-defs.lisp @@ -264,7 +264,6 @@ (pointer-y-position pointer) y-position)))))) (defmethod query-pointer ((pointer standard-pointer)) - (declare (values sheet x y)) (with-slots (sheet x-position y-position) pointer (values sheet x-position y-position))) diff --git a/clim/input-editor-commands.lisp b/clim/input-editor-commands.lisp index 7307fca2aeb4a71cec37053a3c81fc13861ee8d6..9aab205cf0b73fc64060e7b6a8dc0325998c767b 100644 --- a/clim/input-editor-commands.lisp +++ b/clim/input-editor-commands.lisp @@ -10,7 +10,7 @@ ;;; on INPUT-EDITING-STREAM-MIXIN rather than on our specific implementation of ;;; an input editor. This may prove to be a foolish decision down the pike. -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defvar *ie-command-arglist* '(stream input-buffer gesture numeric-argument)) ) @@ -334,7 +334,6 @@ This may confused the input editor" gestures)) (queue-rescan stream ':activation)))) (defun complete-symbol-name (stream input-buffer &aux (colon-string ":")) - (declare (values string ambiguous word-start)) (multiple-value-bind (word-start word-end colon) (word-start-and-end input-buffer '(#\space #\( #\) #\") (stream-insertion-pointer stream)) @@ -1068,7 +1067,6 @@ This may confused the input editor" gestures)) ;;; Lispy input editing commands (defun function-arglist (function) - (declare (values arglist found-p)) #+Clozure (values (ccl:arglist function) t) #+Genera (values (sys:arglist function) T) #+Cloe-Runtime (sys::arglist function) @@ -1076,7 +1074,6 @@ This may confused the input editor" gestures)) #+Lucid (values (lucid-common-lisp:arglist function) t)) (defun word-start-and-end (string start-chars &optional (start 0)) - (declare (values word-start word-end colon)) (flet ((open-paren-p (thing) (or (not (characterp thing)) ;noise strings and blips are delimiters (member thing start-chars))) @@ -1108,7 +1105,6 @@ This may confused the input editor" gestures)) colon)))) (defun symbol-at-position (stream input-buffer delimiters) - (declare (values symbol package start end)) (multiple-value-bind (word-start word-end) (word-start-and-end input-buffer delimiters (stream-insertion-pointer stream)) diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp index 685ce4a66e8f6137cae67b9de93dbe720d3c9209..11d488ae76c0375a0551cdae3d0149e1372024fa 100644 --- a/clim/input-protocol.lisp +++ b/clim/input-protocol.lisp @@ -413,7 +413,7 @@ (process-abort-gesture stream gesture)))) ;;;#+(or aclpc acl86win32) -;;;(eval-when (compile load eval) +;;;(eval-when (:compile-toplevel :load-toplevel :execute) ;;; ;;mm: 11Jan95 - this is defined later in ??? ;;; (unless (ignore-errors (find-class 'interactor-pane)) ;;; (defclass interactor-pane () ())) @@ -458,10 +458,6 @@ ;;; keyword :STREAM argument to *standard-input*. The application can call ;;; stream-read-gesture directly. (defun read-gesture (&rest args &key (stream *standard-input*) &allow-other-keys) - (declare (arglist &rest args - &key (stream *standard-input*) - timeout peek-p input-wait-test input-wait-handler - pointer-button-press-handler)) (declare (dynamic-extent args)) (with-keywords-removed (keywords args '(:stream)) (apply #'stream-read-gesture stream keywords))) diff --git a/clim/interactive-defs.lisp b/clim/interactive-defs.lisp index 2f488c7db61b2d6efde8b1d9e6318e00091c28d7..bceed9443a97ac44a7caf7bd31c9ef723d9dd24d 100644 --- a/clim/interactive-defs.lisp +++ b/clim/interactive-defs.lisp @@ -22,7 +22,7 @@ ;; Noise strings and ACCEPT results -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defstruct (noise-string (:constructor make-noise-string-1)) display-string text-style diff --git a/clim/interactive-protocol.lisp b/clim/interactive-protocol.lisp index 03da2395bc407d1c1fe07f6de501b0acdd9a6029..bf93c93bfba2b402d09194fb646971c2452515db 100644 --- a/clim/interactive-protocol.lisp +++ b/clim/interactive-protocol.lisp @@ -591,7 +591,6 @@ ;; the result does not want to include the space, but which succeeds on a ;; balancing open-paren and the result does want to include the paren. (defun forward-or-backward (input-buffer start-position reverse-p predicate) - (declare (values new-position)) (let ((position start-position) (adjustment (if reverse-p -1 +1)) (limit (if reverse-p 0 (fill-pointer input-buffer)))) @@ -1059,7 +1058,7 @@ ;;;#+(or aclpc acl86win32) -;;;(eval-when (compile load eval) +;;;(eval-when (:compile-toplevel :load-toplevel :execute) ;;; ;;mm: 11Jan95 - this is defined later in ??? ;;; (unless (ignore-errors (find-class 'accept-values-pane)) ;;; (defclass accept-values-pane () ())) diff --git a/clim/japanese-input-editor.lisp b/clim/japanese-input-editor.lisp index 2ffa3ef0994a529fd0bab5db008adaa1cff9a0ed..21fdf1d971bd2254c6c0b82b56a96cad1ba0be2e 100644 --- a/clim/japanese-input-editor.lisp +++ b/clim/japanese-input-editor.lisp @@ -5,7 +5,7 @@ (in-package :clim-internals) #-ics -(eval-when (compile) +(eval-when (:compile-toplevel) (warn "~S contains fat strings but is being compiled with a non-ICS lisp" excl:*source-pathname*)) diff --git a/clim/lucid-after.lisp b/clim/lucid-after.lisp index 9e2e6e735ae1f42d2bc46044df41cd714af035ea..d6d29d713fec2dff04a57c5f66dcdbbf7b51c4c1 100644 --- a/clim/lucid-after.lisp +++ b/clim/lucid-after.lisp @@ -43,7 +43,7 @@ (pushnew 'rehash-ptypes *restart-cleanup-functions*)) -(eval-when (load) +(eval-when (:load-toplevel) (pushnew :clim-2-0 *features*) (defparameter *clim-repacking-date* (universal-time-string (get-universal-time))) #+ignore ;breaks in 2.0 diff --git a/clim/menus.lisp b/clim/menus.lisp index a546737f4ce1db3f680b23f70532ae7d6a192ad3..bca8b2641b6f737aba8f69dc10c01475dbaeb673 100644 --- a/clim/menus.lisp +++ b/clim/menus.lisp @@ -274,7 +274,6 @@ (cell-align-x ':left) (cell-align-y ':top) pointer-documentation menu-type gesture x-position y-position) - (declare (values value chosen-item gesture)) (declare (ignore text-style default-item foreground background label scroll-bars printer presentation-type cache unique-id id-test cache-value cache-test @@ -301,7 +300,6 @@ (cell-align-x ':left) (cell-align-y ':top) pointer-documentation menu-type gesture background foreground) - (declare (values value chosen-item gesture)) (declare (ignore #-aclpc keys gesture)) (flet ((present-item (item stream) (present item presentation-type :stream stream))) @@ -498,7 +496,6 @@ x-spacing y-spacing (row-wise nil) (cell-align-x ':left) (cell-align-y ':top) menu-type) - (declare (values value chosen-item gesture)) (flet ((present-item (item stream) (present item presentation-type :stream stream))) (declare (dynamic-extent #'present-item)) @@ -614,7 +611,6 @@ label text-style (scroll-bars t) pointer-documentation menu-type &allow-other-keys) - (declare (values value chosen-item gesture)) (declare (dynamic-extent keys)) (with-slots (name menu-contents items default-presentation root-window) static-menu diff --git a/clim/output-protocol.lisp b/clim/output-protocol.lisp index 4ac4fce6241871447fdd541038270372934103db..b2d69c8d2b3fe24e0dc3bb1417c1bd917a0e0e09 100644 --- a/clim/output-protocol.lisp +++ b/clim/output-protocol.lisp @@ -587,7 +587,6 @@ (defmethod text-size ((stream output-protocol-mixin) string &key (text-style (medium-merged-text-style stream)) (start 0) end) - (declare (values largest-x total-height last-x last-y baseline)) (when (characterp string) (setq string (string string) start 0 @@ -602,7 +601,6 @@ ;;; useful as that might be. (defmethod stream-string-output-size ((stream output-protocol-mixin) string &key (start 0) end text-style) - (declare (values last-x largest-x last-y total-height baseline)) (when (characterp string) (setq string (string string))) (unless end (setf end (length string))) (let ((style (or text-style (medium-merged-text-style stream))) @@ -725,7 +723,6 @@ ;; Damnable string streams! (defmethod text-size ((stream t) string &key text-style (start 0) end) - (declare (values largest-x total-height last-x last-y baseline)) (declare (ignore text-style)) (let ((char-width 8) (line-height 12) @@ -769,8 +766,6 @@ ;;; A few utilities for string writing. (defmethod decode-stream-for-writing ((stream output-protocol-mixin) &optional brief-p) - (declare (values cursor-x cursor-y baseline line-height - style max-x record-p draw-p glyph-buffer)) (multiple-value-bind (cursor-x cursor-y) (stream-cursor-position stream) (let ((baseline (stream-baseline stream)) (line-height (stream-current-line-height stream)) @@ -806,7 +801,6 @@ (medium medium) string start end style cursor-x max-x &optional glyph-buffer) - (declare (values write-char next-char-index new-cursor-x new-baseline new-height font)) (declare (type coordinate cursor-x max-x)) (declare (type fixnum start end)) (block stream-scan-string-for-writing @@ -898,7 +892,6 @@ ;;; characters; they are handled in WRITE-CHAR instead. (defmethod stream-scan-character-for-writing ((stream output-protocol-mixin) medium character style cursor-x max-x) - (declare (values char-normal new-cursor-x new-baseline new-height font)) (declare (type coordinate cursor-x max-x)) (multiple-value-bind (index font escapement-x escapement-y origin-x origin-y bb-x bb-y) (port-glyph-for-character (port medium) character style) @@ -926,7 +919,6 @@ (defmethod stream-handle-line-wrap ((stream output-protocol-mixin) cursor-y height max-x draw-p record-p) - (declare (values cursor-x cursor-y baseline line-height)) (when record-p (stream-close-text-output-record stream t)) (when draw-p (draw-character-wrap-indicator stream cursor-y height max-x record-p)) diff --git a/clim/pixmap-streams.lisp b/clim/pixmap-streams.lisp index 48eac4d17ad73890f32433f43d91220226a526d4..39510c21ae6c17a5516ac6d6e1c1c02e9140572b 100644 --- a/clim/pixmap-streams.lisp +++ b/clim/pixmap-streams.lisp @@ -73,7 +73,7 @@ (funcall continuation pixmap-stream)) (slot-value pixmap-medium 'silica::pixmap)))) -(defconstant +gray-out-ink+ +(defparameter +gray-out-ink+ (compose-in (make-opacity .5) +background-ink+)) (defun pixmap-from-menu-item (associated-window menu-item printer presentation-type diff --git a/clim/present.lisp b/clim/present.lisp index b9fa3f25d57fbb5607ac929d7913553baa1213db..21d1728d4da143fb8c72e48407594445fb8329dc 100644 --- a/clim/present.lisp +++ b/clim/present.lisp @@ -15,17 +15,6 @@ &allow-other-keys) #-acl86win32 (declare (dynamic-extent present-args)) - (declare (arglist object &optional (presentation-type (presentation-type-of object)) - &rest present-args - &key (stream *standard-output*) - (view (stream-default-view stream)) - (modifier nil) (acceptably nil) - (for-context-type presentation-type) (single-box nil) - (allow-sensitive-inferiors *allow-sensitive-inferiors*) - (sensitive *allow-sensitive-inferiors*) - prompt query-identifier - (record-type 'standard-presentation) - &allow-other-keys)) (multiple-value-bind (expansion expanded) (expand-presentation-type-abbreviation presentation-type) (when expanded diff --git a/clim/ptypes1.lisp b/clim/ptypes1.lisp index 01e96eca8228718f6c01d4977f36038c94e203fd..c1f760be5a95c93ad10d30e6cf1fe2b071e18ffa 100644 --- a/clim/ptypes1.lisp +++ b/clim/ptypes1.lisp @@ -23,7 +23,6 @@ ;;; actually was incorporated into the result. ;;; We use uninterned symbols as the dummy values. (defun meta-evaluate-form (form lambda-list &optional another-lambda-list) - (declare (values value bindings more-bindings)) (let ((bindings nil) (more-bindings nil)) (labels ((do-lambda-list (lambda-list) (dolist (item lambda-list) @@ -301,8 +300,13 @@ ((class presentation-type-class) (meta standard-class)) t) +#+ (or sbcl ccl) +(defmethod closer-mop:validate-superclass + ((class presentation-type-class) (meta standard-class)) + t) + ;;;#+(or aclpc acl86win32) -;;;(eval-when (compile load eval) +;;;(eval-when (:compile-toplevel :load-toplevel :execute) ;;; ;;mm: 11Jan95 - this is defined later in ??? ;;; (unless (ignore-errors (find-class 'basic-history)) ;;; (defclass basic-history () ()))) @@ -319,11 +323,11 @@ ',(class-presentation-type-name object #+Symbolics 'compile-file) ',(presentation-type-parameters object) ',(presentation-type-options object) - ',(let ((superclasses (class-direct-superclasses object))) + ',(let ((superclasses (closer-mop:class-direct-superclasses object))) (if (cdr superclasses) (mapcar #'(lambda (class) (class-presentation-type-name class #+Symbolics 'compile-file)) - (class-direct-superclasses object)) + (closer-mop:class-direct-superclasses object)) ;; Use an atom instead of a one-element list to work around a Lucid bug ;; where it blows up if anything here is a list that gets consed freshly ;; each time make-load-form is called, because make-load-form gets called @@ -416,14 +420,8 @@ *class-prototype-for-t*) (t ;; Finalization is necessary according to AMOP. -smh 18may93 - (unless (#+aclpc acl:class-finalized-p - #+Clozure ccl:class-finalized-p - #-(or aclpc Clozure) clos:class-finalized-p - class) - (#+aclpc acl:finalize-inheritance - #+Clozure ccl:finalize-inheritance - #-(or aclpc Clozure) clos:finalize-inheritance - class)) + (unless (closer-mop:class-finalized-p class) + (closer-mop:finalize-inheritance class)) (class-prototype class)))) (defun-inline find-class-precedence-list (class) @@ -432,15 +430,9 @@ ;; can come up with structure classes #+Symbolics (find-class-prototype class) ;; Finalization is necessary according to AMOP. -smh 18may93 - (unless (#+aclpc acl:class-finalized-p - #+Clozure ccl:class-finalized-p - #-(or aclpc Clozure) clos:class-finalized-p - class) - (#+aclpc acl:finalize-inheritance - #+Clozure ccl:finalize-inheritance - #-(or aclpc Clozure) clos:finalize-inheritance - class)) - (class-precedence-list class)) + (unless (closer-mop:class-finalized-p class) + (closer-mop:finalize-inheritance class)) + (closer-mop:class-precedence-list class)) ;;; Hide the long name when printing these (defmethod print-object ((object presentation-type-class) stream) @@ -492,9 +484,6 @@ ;;; Given a presentation type class get its internal inheritance information (defun presentation-type-inheritance (class &optional environment) - (declare (values direct-supertypes ;These three values are lists of - parameter-massagers ;equal length and parallel contents. - options-massagers)) (let ((list (cond ((eq class (second *presentation-type-being-defined*)) (cddddr *presentation-type-being-defined*)) ((and (compile-file-environment-p environment) @@ -577,7 +566,7 @@ the same name as a CLOS class."))) ;; Generate the expander function and pass it to load-presentation-type-abbreviation `(define-group ,name define-presentation-type-abbreviation - (eval-when (compile) + (eval-when (:compile-toplevel) #+(or Genera Cloe-Runtime Minima (and MCL CCL-2)) (setf (compile-time-property ',name 'presentation-type-abbreviation) ,function) @@ -614,7 +603,6 @@ ;;; Like macroexpand-1 (defun expand-presentation-type-abbreviation-1 (type &optional environment) - (declare (values expansion expanded)) (with-presentation-type-decoded (name parameters options) type (let ((expander (or (and (compile-file-environment-p environment) (compile-time-property name 'presentation-type-abbreviation)) @@ -654,7 +642,6 @@ ;;; Like macroexpand (defun expand-presentation-type-abbreviation (type &optional environment) - (declare (values expansion expanded)) (let ((flag nil)) (loop (multiple-value-bind (expansion expanded) @@ -715,7 +702,7 @@ (direct-superclasses (and class (mapcar #'(lambda (class) (class-proper-name class environment)) - (class-direct-superclasses class)))) + (closer-mop:class-direct-superclasses class)))) ;; Default the supertype if unsupplied or nil ;; This assumes consistency of the compile-time and load-time environments. Okay? (inherit-from (cond (inherit-from) @@ -760,7 +747,7 @@ ;; Generate the form that stores all the information and defines the ;; automatically-defined presentation methods `(progn - (eval-when (compile) + (eval-when (:compile-toplevel) (ensure-presentation-type ',name ',parameters ',options ',direct-supertypes ',description ',history ',parameters-are-types @@ -824,7 +811,7 @@ (class (find-presentation-type-class name nil environment)) #-CLIM-extends-CLOS (old-direct-superclasses (if class - (class-direct-superclasses class) + (closer-mop:class-direct-superclasses class) direct-superclasses)) #+(or (and MCL CCL-2) aclpc Clozure) (registered-class-name @@ -865,8 +852,7 @@ name (class-proper-name superclass environment) 'define-presentation-type (typecase superclass - #-Clozure (funcallable-standard-class 'defgeneric) - #+Clozure (ccl:funcallable-standard-class 'defgeneric) + (closer-mop:funcallable-standard-class 'defgeneric) (standard-class 'defclass) #+Symbolics ;Symbolics CLOS, that is (clos:structure-class 'defstruct) @@ -889,8 +875,8 @@ #+(or aclpc (and MCL CCL-2) Clozure) :name #+(and MCL CCL-2) class-name #+(or aclpc Clozure) registered-class-name - #-(or PCL aclpc (and MCL CCL-2) allegro Clozure) :slots - #+(or PCL aclpc (and MCL CCL-2) allegro Clozure) :direct-slots + #-(or PCL aclpc (and MCL CCL-2) allegro Clozure sbcl ccl) :slots + #+(or PCL aclpc (and MCL CCL-2) allegro Clozure sbcl ccl) :direct-slots nil) #+Lucid (make-instance 'presentation-type-class :direct-superclasses direct-superclasses @@ -899,17 +885,19 @@ ;; very bad things to happen #+(and MCL CCL-2) (setf (slot-value class 'ccl::slots) (cons nil (vector))) ;; If the class name couldn't be set while making the class, set it now - #-(or Genera Cloe-Runtime Lucid aclpc (and MCL CCL-2) Clozure) - (setf (class-name class) class-name) + + ;; FIXME not sure what to do with this, commenting out for now. -- jacek.zlydach, 2017-05-06 + ;; #-(or Genera Cloe-Runtime Lucid aclpc (and MCL CCL-2) Clozure) + ;; (setf (class-name class) class-name) )) - ((not (or (equal (class-direct-superclasses class) direct-superclasses) + ((not (or (equal (closer-mop:class-direct-superclasses class) direct-superclasses) ;; The above equal would suffice if it were not for the fact that when ;; a CLOS class in the compile-file environment has a superclass in the ;; runtime environment, CLOS uses a forward-referenced-class instead ;; of using the run-time class (every #'(lambda (class type) (eq (class-proper-name class environment) type)) - (class-direct-superclasses class) supertypes-list) + (closer-mop:class-direct-superclasses class) supertypes-list) (presentation-type-class-p class))) ;; Inheritance must be consistent between CLOS and CLIM classes, ;; but only when CLOS and CLIM use the same class object. @@ -920,7 +908,7 @@ name supertypes-list class (mapcar #'(lambda (class) (class-proper-name class environment)) - (class-direct-superclasses class))))) + (closer-mop:class-direct-superclasses class))))) ;; This used to be done only in the case where we were creating a class ;; "de novo". However, CCL-2 currently doesn't record anything about @@ -1038,64 +1026,69 @@ ;;; If there is parameterized inheritance, compile code to do it efficiently ;;; rather than interpreting the inheritance information at run time. (defun generate-map-over-presentation-type-supertypes-method-if-needed - (name class function-var parameters-var options-var type-var - &optional environment) + (name class function-var parameters-var options-var type-var + &optional environment) (let ((superclasses - #-(or aclpc allegro) (cdr (class-precedence-list class)) - #+aclpc - (progn - (unless (acl:class-finalized-p class) - (acl:finalize-inheritance class)) - (cdr (class-precedence-list class))) - #+allegro ;; Work around bug in CLOS compilation environments... - (multiple-value-bind (no-errorp result) - (excl:errorset (progn - ;; Finalization is necessary according to AMOP. -smh 18may93 - (unless (clos:class-finalized-p class) - (clos:finalize-inheritance class)) - (cdr (class-precedence-list class))) - nil) - (if no-errorp - result - (return-from generate-map-over-presentation-type-supertypes-method-if-needed))))) + ;;#-(or allegro aclpc) (cdr (closer-mop:class-precedence-list class)) ;; FIXME dropping? + #+ (or sbcl ccl) + (progn + (unless (closer-mop:class-finalized-p class) + (closer-mop:finalize-inheritance class)) + (cdr (closer-mop:class-precedence-list class))) + #+aclpc + (progn + (unless (acl:class-finalized-p class) + (acl:finalize-inheritance class)) + (cdr (class-precedence-list class))) + #+allegro ;; Work around bug in CLOS compilation environments... + (multiple-value-bind (no-errorp result) + (excl:errorset (progn + ;; Finalization is necessary according to AMOP. -smh 18may93 + (unless (clos:class-finalized-p class) + (clos:finalize-inheritance class)) + (cdr (class-precedence-list class))) + nil) + (if no-errorp + result + (return-from generate-map-over-presentation-type-supertypes-method-if-needed))))) #+Minima (setq superclasses (elide-nonessential-superclasses superclasses)) (multiple-value-bind (bindings alist) (generate-type-massagers class superclasses parameters-var options-var t environment) (unless (every #'(lambda (class) (let ((massage-forms (cdr (assoc class alist)))) - (and (null (first massage-forms)) ;no parameters - (null (second massage-forms))))) ;no options + (and (null (first massage-forms)) ;no parameters + (null (second massage-forms))))) ;no options superclasses) `((define-presentation-method-without-massaging - map-over-presentation-type-supertypes - (,parameters-var ,options-var (,type-var ,name) ,function-var) - ,parameters-var ,options-var ;might not be used + map-over-presentation-type-supertypes + (,parameters-var ,options-var (,type-var ,name) ,function-var) + ,parameters-var ,options-var ;might not be used (funcall ,function-var ',name ,type-var) ,@(make-stack-list-bindings bindings - (mapcan #'(lambda (class) - (let* ((massage-forms (cdr (assoc class alist))) - (parameters (first massage-forms)) - (options (second massage-forms)) - (type-name (class-presentation-type-name class))) - (if (or options parameters) - (make-stack-list-bindings - `((type ,(if options - (if (constantp parameters) - (if (constantp options) - `',(cons (cons type-name - (eval parameters)) - (eval options)) - `(cons ',(cons type-name - (eval parameters)) - ,options)) - `(cons (cons ',type-name ,parameters) - ,options)) - (if (constantp parameters) - `',(cons type-name (eval parameters)) - `(cons ',type-name ,parameters))))) - `((funcall ,function-var ',type-name type))) - `((funcall ,function-var ',type-name ',type-name))))) - superclasses)) + (mapcan #'(lambda (class) + (let* ((massage-forms (cdr (assoc class alist))) + (parameters (first massage-forms)) + (options (second massage-forms)) + (type-name (class-presentation-type-name class))) + (if (or options parameters) + (make-stack-list-bindings + `((type ,(if options + (if (constantp parameters) + (if (constantp options) + `',(cons (cons type-name + (eval parameters)) + (eval options)) + `(cons ',(cons type-name + (eval parameters)) + ,options)) + `(cons (cons ',type-name ,parameters) + ,options)) + (if (constantp parameters) + `',(cons type-name (eval parameters)) + `(cons ',type-name ,parameters))))) + `((funcall ,function-var ',type-name type))) + `((funcall ,function-var ',type-name ',type-name))))) + superclasses)) nil)))))) ;;; Wrap some let* bindings around some forms @@ -1140,7 +1133,6 @@ ;;; The second value is a list of elements (class parameters-form options-form) (defun generate-type-massagers (class superclasses parameters-var options-var accuratep &optional environment) - (declare (values bindings alist)) (let ((paths nil) (classes-seen nil) (class-bindings-used nil) ;((class parameters-count options-count)...) @@ -1149,7 +1141,7 @@ (labels ((map-over-superclasses (function class &rest trail) (declare (dynamic-extent trail)) (funcall function class trail) - (dolist (superclass (class-direct-superclasses class)) + (dolist (superclass (closer-mop:class-direct-superclasses class)) (apply #'map-over-superclasses function superclass class trail))) (note-path (class trail) (unless (assoc class paths) @@ -1304,7 +1296,6 @@ ;;; if the length is 1, each value is just the list element, to save space in ;;; compiled files. (defun analyze-inherit-from (backquote parameters-ll options-ll) - (declare (values direct-supertypes parameter-massagers options-massagers)) (multiple-value-bind (expansion parameters-bindings options-bindings) (meta-evaluate-form backquote parameters-ll options-ll) (with-presentation-type-decoded (expanded-name expanded-parameters expanded-options) @@ -1400,7 +1391,12 @@ (defun generate-presentation-type-inheritance-methods (name class parameters-var options-var &optional environment) (let ((superclasses - #-(or allegro aclpc) (cdr (class-precedence-list class)) + ;;#-(or allegro aclpc) (cdr (closer-mop:class-precedence-list class)) ;; FIXME dropping? + #+ (or sbcl ccl) + (progn + (unless (closer-mop:class-finalized-p class) + (closer-mop:finalize-inheritance class)) + (cdr (closer-mop:class-precedence-list class))) #+aclpc (progn (unless (acl:class-finalized-p class) @@ -1562,13 +1558,12 @@ ;;; Presentation generic functions have their own class just so we can define ;;; one method that aids in implementing presentation-method-combination #-(and MCL CCL-2) -(eval-when (eval load compile) +(eval-when (:execute :load-toplevel :compile-toplevel) (defclass presentation-generic-function (standard-generic-function #+Minima-Developer standard-object) () - (:metaclass #-Clozure funcallable-standard-class - #+Clozure ccl:funcallable-standard-class)) -) ;end of (eval-when (eval load compile) + (:metaclass closer-mop:funcallable-standard-class)) +) ;end of (eval-when (:execute :load-toplevel :compile-toplevel) #+CLIM-extends-CLOS (defvar *presentation-method-argument-class*) @@ -1609,7 +1604,7 @@ ;;; extension to call-method ;;;--- If combined methods were generated during compile-file, this would need ;;;--- to get an environment argument from somewhere -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (define-method-combination presentation-method-combination () ((around (:around)) (before (:before)) @@ -1677,7 +1672,7 @@ (if bindings `(let* ,bindings ,form) form))))))) -) ;end of (eval-when (compile load eval) +) ;end of (eval-when (:compile-toplevel :load-toplevel :execute) ;;;; Definitions of Presentation Generic Functions @@ -1693,9 +1688,7 @@ ;; &key &allow-other-keys allows methods to receive only the keyword arguments ;; that they are interested in. We know the caller will never supply ;; misspelled keywords since only the CLIM system calls this. - #-(or aclpc acl86win32 (and MCL CCL-2)) - (declare (arglist type-key parameters options object type stream view - &key acceptably for-context-type))) +) (define-presentation-generic-function accept-method accept @@ -1704,10 +1697,7 @@ ;; &key &allow-other-keys allows methods to receive only the keyword arguments ;; that they are interested in. We know the caller will never supply ;; misspelled keywords since only the CLIM system calls this. - #-(or aclpc acl86win32 (and MCL CCL-2)) - (declare (arglist type-key parameters options type stream view - &key default default-type) - (values object type))) +) (define-presentation-generic-function describe-presentation-type-method describe-presentation-type @@ -1719,9 +1709,7 @@ (define-presentation-generic-function presentation-subtypep-method presentation-subtypep - (type-key type putative-supertype) - #-(or aclpc (and MCL CCL-2)) - (declare (values subtype-p known-p))) + (type-key type putative-supertype)) (define-presentation-generic-function presentation-type-history-method presentation-type-history @@ -1733,9 +1721,7 @@ ;; &key &allow-other-keys allows methods to receive only the keyword arguments ;; that they are interested in. We know the caller will never supply ;; misspelled keywords since only the CLIM system calls this. - #-(or aclpc acl86win32 (and MCL CCL-2)) - (declare (arglist type-key default type &key default-type) - (values default default-type))) +) (define-presentation-generic-function presentation-type-specifier-p-method presentation-type-specifier-p @@ -1746,26 +1732,15 @@ (type-key parameters options type stream view default default-supplied-p present-p query-identifier - &key &allow-other-keys) - #-(or aclpc acl86win32 (and MCL CCL-2)) - (declare (arglist type-key parameters options type - stream view default default-supplied-p - present-p query-identifier - &key (prompt t) (active-p t)))) + &key &allow-other-keys)) (define-presentation-generic-function gadget-includes-prompt-p-method gadget-includes-prompt-p - (type-key parameters options type stream view) - #-(or aclpc acl86win32 (and MCL CCL-2)) - (declare (arglist type-key parameters options type stream view))) + (type-key parameters options type stream view)) (define-presentation-generic-function decode-indirect-view-method decode-indirect-view - (type-key parameters options type view frame-manager &key &allow-other-keys) - #-(or aclpc acl86win32 (and MCL CCL-2)) - (declare (arglist type-key parameters options type - view frame-manager - &key query-identifier read-only))) + (type-key parameters options type view frame-manager &key &allow-other-keys)) (define-presentation-generic-function presentation-refined-position-test-method presentation-refined-position-test @@ -1785,7 +1760,6 @@ ;;; lexical bindings of the presentation type parameters and options. (defmacro define-presentation-method (presentation-function-name &rest body &environment environment) - (declare (arglist presentation-function-name [qualifiers]* specialized-lambda-list &body body)) (define-presentation-method-1 presentation-function-name body ':massage environment)) ;;; The next level down from define-presentation-method, this doesn't create @@ -1794,7 +1768,6 @@ ;;; a type-key or type-class parameter. (defmacro define-presentation-method-without-massaging (presentation-function-name &rest body &environment environment) - (declare (arglist presentation-function-name [qualifiers]* specialized-lambda-list &body body)) (define-presentation-method-1 presentation-function-name body nil environment)) ;;; Define a default method for a presentation generic function. @@ -1802,7 +1775,6 @@ ;;; There is no parameters/options processing, this macro just exists for abstraction. (defmacro define-default-presentation-method (presentation-function-name &rest body &environment environment) - (declare (arglist presentation-function-name [qualifiers]* specialized-lambda-list &body body)) (define-presentation-method-1 presentation-function-name body ':default environment)) ;;; Common subroutine of the three forms of define-presentation-method diff --git a/clim/ptypes2.lisp b/clim/ptypes2.lisp index d96c639f1c60c9906f6dac788231f313cc0f860b..55193d8af9ef4e5f8acf0aee9a81dad5366bd7e1 100644 --- a/clim/ptypes2.lisp +++ b/clim/ptypes2.lisp @@ -351,7 +351,6 @@ ;; NIL,NIL => Don't know, the answer cannot definitively be determined ;; T,NIL => Can't ever happen (defun presentation-subtypep (type putative-supertype) - (declare (values subtype-p known-p)) (multiple-value-bind (subtype-p known-p) (presentation-subtypep-1 type putative-supertype) (when (and (eq subtype-p nil) @@ -368,7 +367,6 @@ ;; The guts of the above, but faster since we don't worry about the case ;; where a type abbreviation was passed in. (defun presentation-subtypep-1 (type putative-supertype) - (declare (values subtype-p known-p)) (with-presentation-type-decoded (type-name type-parameters) type (with-presentation-type-decoded (supertype-name supertype-parameters) putative-supertype diff --git a/clim/r-tree.lisp b/clim/r-tree.lisp index b6cc55dfac50844d83b3ca0b5f3553008f301429..bc097c8d21454077af2e1e146a9f129001b7aa7b 100644 --- a/clim/r-tree.lisp +++ b/clim/r-tree.lisp @@ -225,7 +225,6 @@ ;; Add a record to an R tree, and return the (possibly new) root (defun r-tree-insert (root record) - (declare (values new-root)) (let ((leaf root)) (loop (when (r-tree-leaf-node-p leaf) @@ -451,7 +450,6 @@ ;; Remove an object from the R tree and trim it appropriately (defun r-tree-delete (root record) - (declare (values new-root found-p)) (with-stack-array (orphans 20 :fill-pointer 0) (multiple-value-bind (found-p delete-p) (r-tree-delete-1 root record orphans) diff --git a/clim/recording-protocol.lisp b/clim/recording-protocol.lisp index c3abc592e45ae7cba36a782cd1fe72e5a13d84ec..9714d5913573a0a80de6f981c363584086530b38 100644 --- a/clim/recording-protocol.lisp +++ b/clim/recording-protocol.lisp @@ -324,8 +324,7 @@ #+Genera (zwei:defindentation (map-over-output-records-overlapping-region 2 1)) (defgeneric map-over-output-records-overlapping-region (function record region - &optional x-offset y-offset &rest continuation-args) - (declare (dynamic-extent function continuation-args))) + &optional x-offset y-offset &rest continuation-args)) ;;; This must map over the children in such a way that, when it maps over ;;; overlapping children, the topmost (most recently inserted) child is @@ -336,8 +335,7 @@ #+Genera (zwei:defindentation (map-over-output-records-containing-position 3 1)) (defgeneric map-over-output-records-containing-position (function record x y - &optional x-offset y-offset &rest continuation-args) - (declare (dynamic-extent function continuation-args))) + &optional x-offset y-offset &rest continuation-args)) ;;; X-offset and Y-offset represent the accumulated offset between the ;;; regions's native coordinates and "our" coordinates and must be added @@ -425,7 +423,6 @@ ;; to be ADDED to any coordinates relative to OUTPUT-RECORD to give you ;; absolute coordinates. (defun convert-from-relative-to-absolute-coordinates (stream output-record) - (declare (values x-offset y-offset)) (cond ((null output-record) ;;--- Why on earth do we need this now? (values (coordinate 0) (coordinate 0))) @@ -449,7 +446,6 @@ ;; to be ADDED to any absolute coordinates to give you coordinates ;; relative to OUTPUT-RECORD. (defun convert-from-absolute-to-relative-coordinates (stream output-record) - (declare (values x-offset y-offset)) (cond ((null output-record) ;;--- Why on earth do we need this now? (values (coordinate 0) (coordinate 0))) @@ -474,7 +470,6 @@ ;; relative to ANCESTOR in order to get coordinates relative to ;; DESCENDANT. (defun convert-from-ancestor-to-descendant-coordinates (ancestor descendant) - (declare (values x-offset y-offset)) (cond ((eq descendant ancestor) (values (coordinate 0) (coordinate 0))) ((null descendant) @@ -495,7 +490,6 @@ ;; relative to DESCENDANT in order to get coordinates relative to ;; ANCESTOR. (defun convert-from-descendant-to-ancestor-coordinates (descendant ancestor) - (declare (values x-offset y-offset)) (cond ((eq descendant ancestor) (values (coordinate 0) (coordinate 0))) ((null descendant) diff --git a/clim/standard-types.lisp b/clim/standard-types.lisp index 509c6778f67d5f0a00cb39b65cc17ea0980da45f..5081bd98125665531d46c93bcb50b5c4f3ac4d64 100644 --- a/clim/standard-types.lisp +++ b/clim/standard-types.lisp @@ -811,7 +811,6 @@ (defun accept-comma (stream desired-type view &key (delimiter-character #\,) echo-space echo-string-before-blip) - (declare (values more-to-come object type)) (with-input-context (desired-type) (object type) (loop (let ((char (read-gesture :stream stream))) @@ -953,12 +952,20 @@ ;;;; Sequence Presentation Types -(define-presentation-type sequence (element-type) - :inherit-from t ;enforce CL definition +#+sbcl(define-presentation-type sequence (element-type) + :inherit-from (find-class 't) ;enforce CL definition ; NOTE changed "t" to "(find-class 't)" -- jacek.zlydach, 2017-05-06 + :parameters-are-types t + :options ((separator #\,) + (echo-space t))) + +;;; NOTE CCL seems to like it the old way -- jacek.zlydach, 2017-05-06 +#-sbcl(define-presentation-type sequence (element-type) + :inherit-from t ;enforce CL definition :parameters-are-types t :options ((separator #\,) (echo-space t))) + (define-presentation-method describe-presentation-type :after ((type sequence) stream plural-count) (declare (ignore plural-count)) ;primary method gets it @@ -1073,7 +1080,6 @@ (defun accept-sequence-element (stream element-type view separators element-default element-default-type default-supplied-p) - (declare (values object object-type)) (multiple-value-bind (object object-type) (with-input-context (element-type) (object object-type) (with-delimiter-gestures (separators) @@ -1726,7 +1732,6 @@ #+Genera (defun dw-type-to-clim-type (object dw-type) - (declare (values new-object clim-type changed-p)) (dw:with-type-decoded (type-name data-args pr-args) dw-type (let ((new (assoc type-name *dw-type-to-clim-type-alist*))) (if new diff --git a/clim/stream-defprotocols.lisp b/clim/stream-defprotocols.lisp index 74b65fec855b0d019ffa3f7b7013b0ea6f3bdd2f..8bf42e3771b586878bb49e0d6562335a8f12ce2b 100644 --- a/clim/stream-defprotocols.lisp +++ b/clim/stream-defprotocols.lisp @@ -114,8 +114,7 @@ ((stream basic-extended-input-protocol) &key timeout input-wait-test)) (defoperation stream-pointer-position basic-extended-input-protocol - ((stream basic-extended-input-protocol) &key (timeout 0) pointer) - #-aclpc (declare (values x y))) + ((stream basic-extended-input-protocol) &key (timeout 0) pointer)) (defoperation stream-set-pointer-position basic-extended-input-protocol ((stream basic-extended-input-protocol) x y &key pointer)) @@ -124,12 +123,10 @@ ((stream basic-extended-input-protocol) pointer button modifier-state x y)) (defoperation stream-pointer-input-rectangle* basic-extended-input-protocol - ((stream basic-extended-input-protocol) pointer &key left top right bottom) - #-aclpc (declare (values left top right bottom))) + ((stream basic-extended-input-protocol) pointer &key left top right bottom)) (defoperation stream-accept basic-extended-input-protocol - ((stream basic-extended-input-protocol) presentation-type &rest accept-args) - #-aclpc (declare (values object type))) + ((stream basic-extended-input-protocol) presentation-type &rest accept-args)) (defoperation prompt-for-accept basic-extended-input-protocol ((stream basic-extended-input-protocol) type view &rest accept-args)) @@ -261,12 +258,10 @@ (defoperation text-size basic-extended-output-protocol ((stream basic-extended-output-protocol) string &key text-style start end) - #-aclpc (declare (values largest-x total-height last-x last-y baseline)) (:no-defgeneric t)) (defoperation stream-cursor-position basic-extended-output-protocol - ((stream basic-extended-output-protocol)) - #-aclpc (declare (values x y))) + ((stream basic-extended-output-protocol))) (defoperation stream-set-cursor-position basic-extended-output-protocol ((stream basic-extended-output-protocol) x y)) @@ -409,8 +404,7 @@ ((window window-mixin) x y)) (defoperation window-inside-size window-mixin - ((window window-mixin)) - #-aclpc (declare (values width height))) + ((window window-mixin))) (defoperation window-set-inside-size window-mixin ((window window-mixin) new-width new-height)) diff --git a/clim/surround-output.lisp b/clim/surround-output.lisp index 61b1a9d8c06f5cc34c97e8b26974144ce2f4758c..d90fa07b56237b4165be07ff35699677d09d0d40 100644 --- a/clim/surround-output.lisp +++ b/clim/surround-output.lisp @@ -9,7 +9,7 @@ (defvar *border-shape-drawer-alist* nil) -(eval-when (eval compile load) +(eval-when (:execute :compile-toplevel :load-toplevel) (defparameter *border-shape-drawer-arglist* '(stream record left top right bottom)) diff --git a/clim/tracking-pointer.lisp b/clim/tracking-pointer.lisp index 7a6e50d683757ea82dff0e6193d3f40655175e17..29d728e93f159d7b810b40dd783a19adea160f42 100644 --- a/clim/tracking-pointer.lisp +++ b/clim/tracking-pointer.lisp @@ -7,7 +7,7 @@ ;;;"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved. ;;; Portions copyright (c) 1988, 1989, 1990 International Lisp Associates." -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) ;;; For compile-time checking. (defvar *tracking-pointer-clauses* nil) ;each clause looks like (name arglist) @@ -16,7 +16,6 @@ `(push-unique '(,name ,arglist) *tracking-pointer-clauses* :key #'car)) (defun validate-tracking-pointer-clause (name arglist) - (declare (values new-arglist ignores)) (let ((item (find name *tracking-pointer-clauses* :key #'car))) (unless item (error "~S is not a known TRACKING-POINTER clause." name)) diff --git a/clim/translators.lisp b/clim/translators.lisp index 724b200a3a170c4716de94623ed9b068970b3409..5c63ec8d44ef8e57dfe3dca8a05bef089b7e5cea 100644 --- a/clim/translators.lisp +++ b/clim/translators.lisp @@ -20,7 +20,7 @@ (setq clos-internals::*invalidate-clim-handler-caches* #'invalidate-presentation-caches) ;;; maybe this wants to be taken out after the load-only phase? -(eval-when (compile load #+(or aclpc acl86win32) eval) +(eval-when (:compile-toplevel :load-toplevel #+(or aclpc acl86win32) :execute) (defvar *translator-function-arglist* '(object presentation context-type frame event window x y))) @@ -510,7 +510,6 @@ (defun presentation-matches-context-type (presentation context-type frame window x y &key event (modifier-state 0)) - (declare (values translator any-match-p)) (let ((one-matched nil) (translators (find-presentation-translators diff --git a/clim/view-defs.lisp b/clim/view-defs.lisp index adbefd1b488842e74bf7f7ec39e5af1e91c16a8f..b81f2afcbaff94256188947e36138b52e02c832b 100644 --- a/clim/view-defs.lisp +++ b/clim/view-defs.lisp @@ -45,7 +45,6 @@ (defmethod initialize-instance :after ((view actual-gadget-view) &rest initargs &key &allow-other-keys) - #-(or aclpc Clozure) (declare (non-dynamic-extent initargs)) (setf (slot-value view 'initargs) initargs)) (defmacro define-gadget-view (name) diff --git a/clim/window-stream.lisp b/clim/window-stream.lisp index 219ec619e401a18709a659cca3327a20c475745c..0adeef1c2a506ed3be318a372d139139247295ac 100644 --- a/clim/window-stream.lisp +++ b/clim/window-stream.lisp @@ -32,7 +32,9 @@ nil) -#-silica ;--- no such slots in Silica +;;; NOTE disabled for sbcl and ccl because :silica seems not to be in features anyway, +;;; and this print-object is presently broken. -- jacek.zlydach 2017-05-14 +#- (or silica sbcl ccl) ;--- no such slots in Silica (defmethod print-object ((window window-stream) stream) (print-unreadable-object (window stream :type t :identity t) (let ((left (safe-slot-value window 'left)) @@ -41,6 +43,13 @@ (bottom (safe-slot-value window 'bottom))) (format stream "/x ~D:~D y ~D:~D/" left right top bottom)))) +;;; NOTE FIXME this needs a proper implementation. +;;; -- jacek.zlydach 2017-05-14 +#+ (or silica sbcl ccl) +(defmethod print-object ((window window-stream) stream) + (print-unreadable-object (window stream :type t :identity t) + (format stream "a window stream"))) + (defmethod window-stream-class-name ((window-stream window-stream)) (class-name (class-of window-stream))) diff --git a/clx/clx-port.lisp b/clx/clx-port.lisp index 43effd5ab34085f5ecaa236801db808b76880e72..d242c1c47080739bf2ec1c049f871bd6baa8bc44 100644 --- a/clx/clx-port.lisp +++ b/clx/clx-port.lisp @@ -62,6 +62,7 @@ #+Allegro (or (system:getenv "DISPLAY") (short-site-name)) #+Lucid (or (lcl:environment-variable "DISPLAY") (machine-instance)) #+CCL (or (ccl:getenv "DISPLAY") (machine-instance)) + #+sbcl (or (sb-posix:getenv "DISPLAY") (machine-instance)) )) (multiple-value-bind (host display-number nscreen) (disassemble-display-spec host (or display-number 0) (or screen 0)) @@ -105,7 +106,6 @@ :background *clx-white-color*)))))))) (defun disassemble-display-spec (display &optional (default-display 0) (default-screen 0)) - (declare (values host display-number nscreen)) (let ((host-n (position #\: display))) (unless host-n (return-from disassemble-display-spec @@ -322,7 +322,6 @@ (defmethod port-glyph-for-character ((port clx-port) character text-style &optional our-font) - (declare (values index font escapement-x escapement-y origin-x origin-y bb-x bb-y)) (multiple-value-bind (character-set index) (char-character-set-and-index character) (when (eq character-set *standard-character-set*) diff --git a/clx/pkgdcl.lisp b/clx/pkgdcl.lisp index 1618e8a548d4c571606fa2b8c9be4abeec8a1dac..5088f47fb79e48f47e73bb1c6a95eb3b014b2c07 100644 --- a/clx/pkgdcl.lisp +++ b/clx/pkgdcl.lisp @@ -2,11 +2,11 @@ ;; See the file LICENSE for the full license governing this code. ;; -(in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) +(in-package :cl-user) ;;;"Copyright (c) 1992 Symbolics, Inc. All rights reserved." -(#-(or ANSI-90 Lucid) clim-lisp::defpackage #+(or ANSI-90 Lucid) defpackage clx-clim +(defpackage clx-clim (:use clim-lisp clim-sys clim clim-utils clim-silica) (:shadowing-import-from clim-utils diff --git a/compatibility/clim1-compatibility.lisp b/compatibility/clim1-compatibility.lisp index 118b1006ea99c2c762c5574f8e721c5ca69a25f4..122048e9298a8ebf86d027fd908dd9d01d837160 100644 --- a/compatibility/clim1-compatibility.lisp +++ b/compatibility/clim1-compatibility.lisp @@ -9,7 +9,7 @@ ;;; Compatibility stubs for CLIM 1.1 -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) ;; We use this below to flag the compatibility code... (pushnew :CLIM-1-compatibility *features*)) @@ -130,7 +130,7 @@ (transform-position transform x y)) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defun probably-stream-or-medium-p (symbol) (and (symbolp symbol) ;;--- This is really not completely safe @@ -842,7 +842,6 @@ (insert-default nil) (replace-input t) (present-p nil) (active-p t)) (declare (dynamic-extent accept-args)) - (declare (values object type)) (declare (ignore prompt-mode display-default query-identifier activation-gestures additional-activation-gestures delimiter-gestures additional-delimiter-gestures @@ -1183,7 +1182,6 @@ &key event (modifier-state 0) #+CLIM-1-compatibility (shift-mask 0 shift-mask-p)) - (declare (values translator any-match-p)) #+CLIM-1-compatibility (when shift-mask-p (setq modifier-state shift-mask)) @@ -1596,7 +1594,6 @@ #+CLIM-1-compatibility default-style #+CLIM-1-compatibility inter-row-spacing #+CLIM-1-compatibility inter-column-spacing) - (declare (values value chosen-item gesture)) (declare (ignore associated-window text-style default-item label printer presentation-type @@ -1653,7 +1650,6 @@ #+CLIM-1-compatibility default-style #+CLIM-1-compatibility inter-row-spacing #+CLIM-1-compatibility inter-column-spacing) - (declare (values value chosen-item gesture)) (declare (ignore keys)) #+CLIM-1-compatibility (when default-style @@ -1718,7 +1714,6 @@ #+CLIM-1-compatibility default-style #+CLIM-1-compatibility inter-row-spacing #+CLIM-1-compatibility inter-column-spacing) - (declare (values value chosen-item gesture)) #+CLIM-1-compatibility (when default-style (setq text-style default-style)) diff --git a/compatibility/packages.lisp b/compatibility/packages.lisp index 5708817d4ba6077b3536612104628b7b97c82d90..5f0b56f2509fedec2abc2f29949eae81ec784cf0 100644 --- a/compatibility/packages.lisp +++ b/compatibility/packages.lisp @@ -7,7 +7,7 @@ ;;;"Copyright (c) 1992 Symbolics, Inc. All rights reserved." -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defvar *clim-1-symbols* '(*abort-characters* *activation-characters* @@ -109,7 +109,7 @@ `(progn ,@body)) ;; Import the above symbols into the CLIM package, then export them -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (let ((clim (find-package :clim))) (dolist (symbol *clim-1-symbols*) (import symbol clim) diff --git a/demo/browser.lisp b/demo/browser.lisp index 64459df4e9f8205c763441c2d68fe89a7d3237ce..2a30e8feb7208fe1f64d638f5b4e07aedd8e570e 100644 --- a/demo/browser.lisp +++ b/demo/browser.lisp @@ -109,8 +109,7 @@ (defgeneric display-node (call-node stream)) (defgeneric node-generate-inferior-objects (call-node subtype)) (defgeneric node-any-inferior-objects-p (call-node subtype)) -(defgeneric node-arc-drawer (call-node) - #+genera (declare (values arc-drawer arc-drawing-options))) +(defgeneric node-arc-drawer (call-node)) (defclass basic-call-node () @@ -170,13 +169,13 @@ ;; This is the most basic instantiable sort of call node. ;; Commands and translators are written on this, not on BASIC-CALL-NODE. -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defclass call-node (basic-call-node) ()) ) ;; CALL-SUBNODEs are a stripped-down version of CALL-NODEs, which mostly ;; means that most commands and translators don't operate on subnodes. -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defclass call-subnode (basic-call-node) ()) ) @@ -189,7 +188,7 @@ ;; Ellipsis nodes -(eval-when (load compile eval) +(eval-when (:load-toplevel :compile-toplevel :execute) (defclass ellipsis-call-node (basic-call-node) ((replaced-node :reader ellipsis-node-replaced-node :initarg :replaced-node))) @@ -219,9 +218,7 @@ (defvar *browser-types* nil) (defgeneric browser-type-subtypes (type)) -(defgeneric browser-type-information (type subtype) - #+genera (declare (values node-maker root-node-maker - graph-type grapher-args presentation-type options))) +(defgeneric browser-type-information (type subtype)) (defmacro define-browser-type (type presentation-type graph-type options &body subtypes) #+genera (declare (zwei:indentation 3 3 4 1)) diff --git a/demo/cad-demo.lisp b/demo/cad-demo.lisp index 23df5f6855ccc5990c8e4679f428e3b2c3fefd7d..5ded3174b1b8ac6eb11b66f02113cadd3749e3b3 100644 --- a/demo/cad-demo.lisp +++ b/demo/cad-demo.lisp @@ -183,7 +183,7 @@ (defclass input (connection) ()) #+allegro -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defclass input (connection) ())) (defmethod presentation-type ((input input)) @@ -206,7 +206,7 @@ (defclass output (connection) ()) #+allegro -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defclass output (connection) ())) (defmethod presentation-type ((output output)) @@ -230,7 +230,7 @@ (:default-initargs :size *component-size*)) #+allegro -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defclass component (basic-thing) ((inputs :initform nil) diff --git a/demo/custom-records.lisp b/demo/custom-records.lisp index 3c9bd205934f96e7bfbad4acd9e97887bca07f73..217d415d78e813657c7b2ca243a5a0e54b8c7ce1 100644 --- a/demo/custom-records.lisp +++ b/demo/custom-records.lisp @@ -137,7 +137,7 @@ ;; Eat up the initargs that records are supposed to handle (declare (ignore object type single-box))) -(eval-when (compile) +(eval-when (:compile-toplevel) (proclaim '(inline make-data-point))) (defun make-data-point (u v) @@ -318,7 +318,6 @@ (defun bsearch (number vector &key (key #'identity) (start 0) (end (1- (length vector)))) ;; If a number is in between two values, return the first of the two - (declare (values index element)) (if (< end start) (values nil 0) (let (#+Genera (vector vector) @@ -397,7 +396,6 @@ internal-time-units-per-second)))))) (defun display-sample-dataset (dataset &optional (stream *standard-output*)) - (declare (values output-record elapsed-time)) (terpri stream) (elapsed-time (display-data dataset stream))) diff --git a/demo/demo-driver.lisp b/demo/demo-driver.lisp index 3bffeb8082e84c3523732c7f9805953f663f6a01..5ac68b3b903a8d61b4f92411bb418586f344cf0b 100644 --- a/demo/demo-driver.lisp +++ b/demo/demo-driver.lisp @@ -8,6 +8,8 @@ (defvar *demos* nil) +(define-presentation-type demo ()) ;<-- ?? It seems to help though. - jacek.zlydach, 2017-05-04. + (defclass demo () ((name :reader demo-name :initarg :name) (class :reader demo-class :initarg :class) @@ -46,8 +48,12 @@ ;; which occurs while printing the demos name. ;; In particular, this can occur when listing ;; the Japanese graphics-editor when the correct - ;; Japanese fonts are not accessible. - (let ((result (catch 'excl::printer-error + ;; Japanese fonts are not accessible. + + ;; NOTE WORKAROUND added #'error clause for non-Allegro Lisps, because + ;; that seems to be the closest equivalent as far as I can tell without access + ;; to Allegro environment. -- jacek.zlydach, 2017-05-14 + (let ((result (catch #-allegro 'error #+Allegro 'excl::printer-error (with-output-as-presentation (stream demo 'demo) (format stream "~A~%" name)) nil))) @@ -84,25 +90,23 @@ (when (or force (null frame)) (setq frame (apply (if activity-p #'make-instance - #'make-application-frame) + #'make-application-frame) (demo-class demo) :frame-manager (find-frame-manager :port port) (demo-initargs demo)))) (if entry (setf (cdr entry) frame) - (push (cons port frame) (demo-frames demo))) + (push (cons port frame) (demo-frames demo))) (if (slot-value frame 'clim-internals::top-level-process) (unless activity-p (when (eq (frame-state frame) :shrunk) (note-frame-deiconified (frame-manager frame) frame)) (raise-frame frame)) - (run-frame-top-level frame))))) - (if background - (mp:process-run-function - `(:name ,(demo-name demo) - :initial-bindings ((*package* . ',*package*))) - #'do-it) - (do-it)))) + (run-frame-top-level frame))))) + (if background + (let ((bt:*default-special-bindings* `((*package* . ',*package*)))) + (bt:make-thread #'do-it :name (demo-name demo))) + (do-it)))) (defvar *demo-frame* nil) diff --git a/demo/graphics-demos.lisp b/demo/graphics-demos.lisp index 54b0711925ae7eea6fa5d20c0bfef0ac9a6c2f7c..400a7ab60f334efac85deafc054f006a4317f924 100644 --- a/demo/graphics-demos.lisp +++ b/demo/graphics-demos.lisp @@ -180,9 +180,9 @@ rotation and scaling." :ink (if (oddp i) +background-ink+ +foreground-ink+)))) (demo-sleep stream 2)))))) -(defconstant *random-ink-list* - (list +red+ +green+ +blue+ - +cyan+ +magenta+ +yellow+ +black+)) +(defparameter *random-ink-list* + (list +red+ +green+ +blue+ + +cyan+ +magenta+ +yellow+ +black+)) (defun random-ink () (nth (random (length *random-ink-list*)) *random-ink-list*)) diff --git a/demo/japanese-graphics-editor.lisp b/demo/japanese-graphics-editor.lisp index bf1d9b9edde806bcbce600b1d5a3c532e629dedc..7cbcab17d650ce07edb65e0954ef731c0486cafa 100644 --- a/demo/japanese-graphics-editor.lisp +++ b/demo/japanese-graphics-editor.lisp @@ -10,12 +10,12 @@ ;;; Ensure that the japanese characters are compiled ;;; with the correct external-format. -(eval-when (compile) +(eval-when (:compile-toplevel) (when (streamp comp::*compile-file-stream*) (setf (stream-external-format comp::*compile-file-stream*) :utf8))) #-ics -(eval-when (compile) +(eval-when (:compile-toplevel) (warn "~S contains fat strings but is being compiled with a non-ICS lisp" excl:*source-pathname*)) diff --git a/demo/listener.lisp b/demo/listener.lisp index 60ddb56f428615e9717f1edd45bdeddaa8c3ae11..971543ee77cc61f6330db375f7d4e753519cd515 100644 --- a/demo/listener.lisp +++ b/demo/listener.lisp @@ -653,8 +653,9 @@ (define-demo "Lisp Listener" lisp-listener :width 600 :height 500) +;;; NOTE WORKAROUND deleted the \210 literal character, because it broke the SBCL reader for me. -- jacek.zlydach, 2017-05-14 #+Genera (define-genera-application lisp-listener :pretty-name "CLIM Lisp Listener" - :select-key #\ˆ + :select-key #\ [FIXME insert character 210] :width +fill+ :height +fill+) diff --git a/demo/navfun.lisp b/demo/navfun.lisp index e728cc892a2eda0a716f59cdee6b69d8593e9b8e..ec21ce3f096c58d3672c866c20f133dc854fa39b 100644 --- a/demo/navfun.lisp +++ b/demo/navfun.lisp @@ -61,7 +61,7 @@ :accessor position-deviation))) #+allegro -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defclass fp-point () ((latitude :initarg :latitude :accessor point-latitude) @@ -106,7 +106,7 @@ :accessor position-longname))) #+allegro -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defclass named-position (ground-position) ((name :initarg :name :accessor position-name) @@ -125,7 +125,7 @@ (write (position-name position) :stream stream :escape nil)))) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defun degminsec (degrees &optional (minutes 0) (seconds 0)) (float (/ (+ (* degrees 3600) (* minutes 60) seconds) 3600))) @@ -235,7 +235,7 @@ (defclass airport (named-position) ()) #+allegro -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defclass airport (named-position) ())) (defmethod draw-position ((airport airport) stream &optional label) @@ -255,7 +255,7 @@ (defclass vor (named-position) ()) #+allegro -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defclass waypoint (named-position) ()) (defclass vor (named-position) ())) @@ -299,7 +299,7 @@ (defclass ndb (named-position) ()) #+allegro -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defclass ndb (named-position) ())) (defmethod describe-position-object ((ndb ndb) stream) @@ -310,7 +310,7 @@ (defclass named-intersection (named-position) ()) #+allegro -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defclass named-intersection (named-position) ())) (defmethod draw-position ((intersection named-intersection) stream &optional label) @@ -327,7 +327,7 @@ (defclass visual-checkpoint (named-position) ()) #+allegro -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defclass visual-checkpoint (named-position) ())) @@ -395,7 +395,7 @@ (legs :initarg :legs :accessor route-legs))) #+allegro -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defclass basic-route-segment () ((at :initarg :at :accessor route-segment-at))) @@ -438,7 +438,7 @@ (defclass route (basic-route) ()) #+allegro -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defclass route (basic-route) ())) (defun route-segment-position-name (route-segment) @@ -473,7 +473,7 @@ (defclass victor-airway (basic-route) ()) #+allegro -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defclass victor-airway-segment (basic-route-segment) ((properties :accessor victor-airway-segment-properties) (next-leg :accessor victor-airway-segment-next-leg))) @@ -575,7 +575,7 @@ :accessor aircraft-hobs-or-tach))) #+allegro -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defclass aircraft () ((identification :initarg :identification ; Aircraft tail number :accessor aircraft-identification) @@ -689,7 +689,7 @@ (color :initarg :color :accessor flight-plan-color))) #+allegro -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defclass flight-plan () ((type :initarg :type :accessor flight-plan-type) (aircraft-id :initarg :aircraft-id :accessor flight-plan-aircraft-id) diff --git a/demo/output-record.lisp b/demo/output-record.lisp index c7fef8e0d00482dc855df7e07edc3f2cb5101d21..3d9755e8d9804fc9a6c2b581f14fbf45bf4e2698 100644 --- a/demo/output-record.lisp +++ b/demo/output-record.lisp @@ -18,7 +18,6 @@ (end (1- (length array)))) "Binary search to find a number in a sorted array." ;; If a number is inbetween two values, return the first of the two. - (declare (values index element)) (if (< end start) (values nil 0) (let ((array array) mid Nmid found) diff --git a/demo/packages.lisp b/demo/packages.lisp index ccf851e50842bdf237657f41314315f2a9c0387e..24cb8774d1f861e428a1a37b626a8bb223d88350 100644 --- a/demo/packages.lisp +++ b/demo/packages.lisp @@ -2,12 +2,12 @@ ;; See the file LICENSE for the full license governing this code. ;; -(in-package #-ansi-90 :user #+ansi-90 :common-lisp-user) +(in-package :cl-user) ;;;"Copyright (c) 1990, 1991 Symbolics, Inc. All rights reserved. ;;; Portions copyright (c) 1988, 1989, 1990 International Lisp Associates." -(#-ansi-90 clim-lisp::defpackage #+ansi-90 defpackage clim-demo +(defpackage clim-demo (:use clim-lisp clim) (:shadowing-import-from clim-utils @@ -23,7 +23,7 @@ start-demo)) -(#-ansi-90 clim-lisp::defpackage #+ansi-90 defpackage clim-graphics-editor +(defpackage clim-graphics-editor (:use clim-lisp clim clim-demo) (:shadowing-import-from clim-utils diff --git a/genera/genera-mirror.lisp b/genera/genera-mirror.lisp index 18b80f8a6e61713b9063dd1450f103074c8dfcc5..110fcab5384f0da71823a57752f3913e4dc001db 100644 --- a/genera/genera-mirror.lisp +++ b/genera/genera-mirror.lisp @@ -414,7 +414,6 @@ (defvar *old-mouse-chord-shifts* 0) (defun-inline buttons-up (old-buttons new-buttons) - (declare (values buttons-up buttons-down)) (values (boole boole-andc2 old-buttons new-buttons) (boole boole-andc2 new-buttons old-buttons))) @@ -741,7 +740,6 @@ ;; See general comments about sheet-native-native-region* and ;; sheet-native-region* about functions vs macros, etc. (defun genera-window-margins (mirror) - (declare (values left top inside-width inside-height)) (multiple-value-bind (left top) (scl:send mirror :margins) (multiple-value-bind (width height) diff --git a/genera/genera-port.lisp b/genera/genera-port.lisp index 22108eb03917e3e7e7ebbaa069031a64606acb1f..dac96553cab8581feea37ae97bcf3cccbf9f6f2e 100644 --- a/genera/genera-port.lisp +++ b/genera/genera-port.lisp @@ -301,7 +301,6 @@ (defmethod port-glyph-for-character ((port genera-port) character style &optional our-font) - (declare (values index font escapement-x escapement-y origin-x origin-y bb-x bb-y fixed-width-font-p)) (with-genera-glyph-for-character (port-glyph-for-character port character style our-font))) diff --git a/gramps-clim2.asd b/gramps-clim2.asd new file mode 100644 index 0000000000000000000000000000000000000000..806fd2163912babd78cd9c34696979d3a9e7b443 --- /dev/null +++ b/gramps-clim2.asd @@ -0,0 +1,224 @@ + +(in-package #:asdf-user) + +(defsystem #:gramps-clim2 + :description "CLIM 2 implementation released by Franz Inc." + :license "BSD-4-Clause" + :depends-on (#:gramps-clim2/core)) + +;;; based on `clim-standalone' in sys/sysdcl.lisp +(defsystem #:gramps-clim2/core + :description "Core functionality (doesn't contain backends)." + :depends-on (#:gramps-clim2/silica) + :components ((:module "clim" + :components + (;; Basic tools + (:file "gestures") + (:file "defprotocol") + (:file "stream-defprotocols") + (:file "defresource") + (:file "temp-strings") + (:file "clim-defs") + + ;; Definitions and protocols + (:file "stream-class-defs") + (:file "interactive-defs") + (:file "cursor") + (:file "view-defs") + (:file "input-defs") + (:file "input-protocol") + (:file "output-protocol") + + ;; Output recording + (:file "recording-defs") + (:file "formatted-output-defs") + (:file "recording-protocol") + (:file "text-recording") + (:file "graphics-recording") + (:file "design-recording") + + ;; Input editing + (:file "interactive-protocol") + (:file "input-editor-commands") + #+(and allegro (not acl86win32)) (:file "japanese-input-editor") + + ;; Incremental redisplay + (:file "incremental-redisplay") + + ;; Windows (sheets) + (:file "coordinate-sorted-set") + (:file "r-tree") + (:file "window-stream") + (:file "pixmap-streams") + + ;; Presentation types + (:file "ptypes1") + (:file "completer") + (:file "presentations") + (:file "translators") + (:file "histories") + (:file "ptypes2") + (:file "standard-types") + #+allegro (:file "excl-presentations") + + ;; Formatted output + (:file "table-formatting") + (:file "graph-formatting") + (:file "surround-output") + (:file "text-formatting") + + ;; Pointer tracking + (:file "tracking-pointer") + (:file "dragging-output") + + ;; Gadgets + (:file "db-stream") + (:file "gadget-output") + + ;; Application building substrate + (:file "accept") + (:file "present") + (:file "command") + (:file "command-processor") + (:file "basic-translators") + (:file "frames") + (:file "panes") + (:file "default-frame") + (:file "activities") + (:file "db-menu") + #+acl86win32 (:file "db-list") + #+acl86win32 (:file "db-text") + (:file "noting-progress") + (:file "menus") + (:file "accept-values") + (:file "drag-and-drop") + (:file "item-list-manager") + + ;; Bootstrap everything + (:file "stream-trampolines"))))) + +;;; based on `clim-utils' +(defsystem #:gramps-clim2/utils + :depends-on (#:closer-mop) + :components + ((:module "utils" + :components ((:file "packages") + (:file "defun-utilities") + (:file "reader") + (:file "clos-patches") + (:file "clos") + + ;; General lisp extensions + (:file "utilities") + (:file "lisp-utilities") + (:file "processes") + (:file "queue") + (:file "timers") + (:file "protocols") + + ;; Establish a uniform stream model + #+ (or) (:file "trivial-gray-streams") + (:file "clim-streams") + (:file "cl-streams") + + ;; Basic utilities for Silica and CLIM + (:file "clim-macros") + (:file "transformations") + (:file "regions") + (:file "region-arithmetic") + (:file "extended-regions") + (:file "base-designs") + (:file "designs"))))) + +;;; based on `clim-silica' +(defsystem #:gramps-clim2/silica + :depends-on (#:gramps-clim2/utils + #:closer-mop) + :components + ((:module "silica" + :components + (;; Silica + (:file "macros") + (:file "classes") + (:file "text-style") + (:file "sheet") + (:file "mirror") + (:file "event") + (:file "port") + (:file "medium") + (:file "framem") + (:file "graphics") + (:file "pixmaps") + (:file "std-sheet") + + ;; "Windshield", aka "DashBoard" + ;; Layout gadgets + (:file "layout") + (:file "db-layout") + (:file "db-box") + (:file "db-table") + + ;; 'Physical' gadgets + (:file "gadgets") + (:file "db-border") + (:file "db-scroll") + (:file "db-button") + (:file "db-label") + (:file "scroll-pane"))))) + +#+ (or) +(defsystem #:gramps-clim2/homegrown + :depends-on (#:gramps-clim2/silica) + :components + ((:module "homegrown" + :components + ;; not fully compatible with silica (???) + ((:file "scroll-pane") + (:file "db-button") + (:file "db-label") + (:file "db-slider") + (:file "db-menu") + (:file "db-list" :depends-on ("db-menu")) + (:file "db-text") + (:file "last"))))) + +(defsystem #:gramps-clim2/postscript + :description "Draw-only backend as defined in the specification.") + +;;; based on `clx-clim' in clx/sysdcl.lisp +(defsystem #:gramps-clim2/clx-backend + :description "Reference backend for X-Window system." + :depends-on (#:clx #:gramps-clim2/core) + :components + ((:module "clx" + :components + ((:file "pkgdcl") + (:file "clx-port") + (:file "clx-mirror") + (:file "clx-medium") + (:file "clx-pixmaps") + (:file "clx-frames"))))) + +;;; based on `clim-demo' in demo/sysdcl.lisp +(defsystem #:gramps-clim2/examples + :description "Applications bundled in gramps-clim2 repository." + :depends-on (#:gramps-clim2/core + #:bordeaux-threads) + + :components + ((:module "demo" + :components + ((:file "packages") + (:file "demo-driver" :depends-on ("packages")) + (:file "listener" :depends-on ("demo-driver")) + (:file "graphics-demos" :depends-on ("demo-driver")) + ;(:file "cad-demo" :depends-on ("demo-driver")) + ;(:file "navdata" :depends-on ("packages")) + ;(:file "navfun" :depends-on ("navdata")) + ;(:file "puzzle" :depends-on ("demo-driver")) + ;(:file "address-book" :depends-on ("demo-driver")) + ;(:file "thinkadot" :depends-on ("demo-driver")) + ;(:file "plot" :depends-on ("demo-driver")) + ;(:file "color-editor" :depends-on ("demo-driver")) + ;(:file "graphics-editor" :depends-on ("demo-driver")) + )))) diff --git a/hpgl/hpgl-medium.lisp b/hpgl/hpgl-medium.lisp index eb405941008433e74e4aa5d58c8ad882b5827be1..5531415f99dc0c04a63d33bb19b182013f96e191 100644 --- a/hpgl/hpgl-medium.lisp +++ b/hpgl/hpgl-medium.lisp @@ -701,7 +701,6 @@ a point. Hence we have 72dpi resolution printer. (defmethod port-glyph-for-character ((port hpgl-port) character appearance &optional our-font) #+Genera - (declare (values index font escapement-x escapement-y origin-x origin-y bb-x bb-y)) (with-hpgl-port-glyph-for-character (port) (port-glyph-for-character medium character appearance our-font))) @@ -722,8 +721,6 @@ a point. Hence we have 72dpi resolution printer. string start end style cursor-x max-x &optional glyph-buffer) - #+Genera (declare (values write-char next-char-index new-cursor-x - new-baseline new-height font)) ;;(declare (ignore stream)) (let (#+ignore (port (port medium))) (with-hpgl-port-glyph-for-character (port) diff --git a/misc/clos-preload.cl b/misc/clos-preload.cl index 1637b5cadede7a17f3235086deb150f4f8031a29..7f43f50932bda0a73732c86b3a97afd82d3db943 100644 --- a/misc/clos-preload.cl +++ b/misc/clos-preload.cl @@ -22,7 +22,7 @@ (in-package :clos) -(eval-when (compile) +(eval-when (:compile-toplevel) (unless (boundp 'si::*clos-preload-packages*) (setq si::*clos-preload-packages* nil))) diff --git a/misc/compile-1.lisp b/misc/compile-1.lisp index 02168ae4050a694d09e08aebbbbdba5e6018aeeb..be4c5510dd54d7d5c25da77344151e8ce5d48c2b 100644 --- a/misc/compile-1.lisp +++ b/misc/compile-1.lisp @@ -1,9 +1,9 @@ -;; -*- mode: common-lisp; package: user -*- +;; -*- mode: common-lisp; package: cl-user -*- ;; ;; See the file LICENSE for the full license governing this code. ;; -(in-package :user) +(in-package :cl-user) ;;; This should not matter ;;; (setq *ignore-package-name-case* t) @@ -12,33 +12,9 @@ (pushnew :ansi-90 *features*) #+(and allegro microsoft) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :acl86win32 *features*)) -#-(version>= 6 0) -(setq comp:generate-call-count-code-switch - (named-function |(> debug 1)| - (lambda (safety size speed debug) - (declare (ignore safety size speed)) - (> debug 1)))) - -#-(version>= 8 2) -(setq comp:declared-fixnums-remain-fixnums-switch - (named-function |(> speed 2)| - (lambda (safety size speed debug) - (declare (ignore safety size debug)) - (> speed 2)))) - - -;; [bug18430]: -#+(version>= 8 2) -(setq comp:declared-fixnums-remain-fixnums-switch - (named-function |(> speed 2)| - (lambda (safety size speed debug compilation-speed) - (declare (ignore safety size debug compilation-speed)) - (> speed 2)))) - - ;;;; Set up translations so we can find stuff. ;;; (setf (logical-pathname-translations "clim2") diff --git a/misc/pixmaps.lisp b/misc/pixmaps.lisp index a9bad9555456fd47340cf1f40f8670f0682cb9ea..41cadca98872622bd5accd0ee4590ef6b0fc030f 100644 --- a/misc/pixmaps.lisp +++ b/misc/pixmaps.lisp @@ -86,7 +86,7 @@ #+Genera (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES "-*- Mode: LISP; Syntax: Common-lisp; Package: CLIM; Base: 10; Lowercase: Yes -*-") -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (scl:export 'clim::(with-output-to-pixmap-stream) 'clim)) (defmacro with-output-to-pixmap-stream ((stream) &body body) @@ -102,7 +102,7 @@ #+Genera (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES "-*- Mode: LISP; Syntax: Common-lisp; Package: CLIM; Base: 10; Lowercase: Yes -*-") -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (scl:export 'clim::(copy-area allocate-pixmap deallocate-pixmap copy-to-pixmap copy-from-pixmap diff --git a/postscript/postscript-medium.lisp b/postscript/postscript-medium.lisp index bcacba4db7572a2ad6135ba3ea79039ad98053ff..ab2c68c189f753a725c8038dc904731813f09f85 100644 --- a/postscript/postscript-medium.lisp +++ b/postscript/postscript-medium.lisp @@ -550,11 +550,8 @@ (defmethod port-glyph-for-character ((port postscript-port) character style &optional our-font) - (declare (values index font escapement-x escapement-y origin-x origin-y bb-x bb-y - fixed-width-font-p)) (with-postscript-glyph-for-character - (port-glyph-for-character port character style our-font))) -) + (port-glyph-for-character port character style our-font)))) ;;-- Is this needed?? diff --git a/postscript/postscript-port.lisp b/postscript/postscript-port.lisp index fe21e90c86d508e3391d694492c18617d33f3d38..6e66505462a723a60b3ec9e3cc5a349503b30e7e 100644 --- a/postscript/postscript-port.lisp +++ b/postscript/postscript-port.lisp @@ -1164,7 +1164,7 @@ end } def ;;;********************************************************************** ;;; This needs to be loaded before the next form is compiled. -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (define-graphics-generic draw-postscript-literal (string x y) :positions-to-transform (x y) ) ) diff --git a/pre-silica/cloe-implementation.lisp b/pre-silica/cloe-implementation.lisp index ff813a8b7558cab3f00c6f895b0a5855c76235c5..c4665221ec16aace705ef3154b3297a5a053e605 100644 --- a/pre-silica/cloe-implementation.lisp +++ b/pre-silica/cloe-implementation.lisp @@ -47,7 +47,7 @@ ;;; -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) ;; Define the new key chars for Cloe CLIM. Regular Cloe defines 0-127, we define ;; 128-139 as the F-keys (F1 thru F12), 140 for c-sh-A, and 141 as c-sh-V diff --git a/pre-silica/clx-implementation.lisp b/pre-silica/clx-implementation.lisp index 32f5f38b134a551e0e4ab7480d99b103d0183b09..284fe5c77be9b59f2f2e37b098db9f2413a7b721 100644 --- a/pre-silica/clx-implementation.lisp +++ b/pre-silica/clx-implementation.lisp @@ -124,7 +124,6 @@ (:default-initargs :input-buffer nil)) (defun disassemble-display-spec (display &optional (default-display 0) (default-screen 0)) - (declare (values host display-number nscreen)) (let ((host-n (position #\: display))) (unless host-n (return-from disassemble-display-spec @@ -1788,7 +1787,6 @@ ;; TEXT-STYLE must be a fully merged text style (defmethod stream-glyph-for-character ((stream clx-window) character text-style &optional our-font) - (declare (values index font escapement-x escapement-y origin-x origin-y bb-x bb-y)) (with-slots (window display-device-type) stream (multiple-value-bind (character-set index) (char-character-set-and-index character) @@ -1835,7 +1833,6 @@ ;;; Too bad we have to copy the glyphs again, but that's life... (defun noop-translate-function (src src-start src-end font dst dst-start) - (declare (values ending-index horizontal-motion width)) (declare (ignore font)) (replace dst src :start1 dst-start :start2 src-start :end2 src-end) (values src-end nil nil)) diff --git a/pre-silica/define-application.lisp b/pre-silica/define-application.lisp index 6bfa9a54533bfad13f26656ca42904baaa3c47c4..33c614d658573d7c39653baaff6608b1018f85e9 100644 --- a/pre-silica/define-application.lisp +++ b/pre-silica/define-application.lisp @@ -52,7 +52,7 @@ #-Genera t (setf (window-label top-level-sheet) name)))) -(eval-when (eval compile load) +(eval-when (:execute :compile-toplevel :load-toplevel) (defstruct (frame-descriptor (:print-function print-frame-descriptor)) name @@ -176,7 +176,7 @@ `(list ',name ',type ,@options))) pane-descriptions))) `(progn - (eval-when (compile) + (eval-when (:compile-toplevel) (when ',command-table (setf (compile-time-property ',(first command-table) 'command-table-name) t)) (define-application-frame-1 ',name ',slots ,pane-descriptions diff --git a/pre-silica/defs-graphics-generics.lisp b/pre-silica/defs-graphics-generics.lisp index 47534df24e465a5a86a51fcaa5829b69de9a66a4..e518a2b9d843f97cb8bd82ffc69535b4f79248cd 100644 --- a/pre-silica/defs-graphics-generics.lisp +++ b/pre-silica/defs-graphics-generics.lisp @@ -6,7 +6,7 @@ "Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved. Portions copyright (c) 1989, 1990 International Lisp Associates." -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) ;; NOTE: if you change this list of keywords, you also have to change the keyword arguments ;; accepted by (CLOS:METHOD INVOKE-WITH-DRAWING-OPTIONS (DRAWING-STATE-MIXIN T)) diff --git a/pre-silica/genera-implementation.lisp b/pre-silica/genera-implementation.lisp index e348dc1f1554a2f468e7b2e1e93e0f57b7e93504..0b77757ee8ab38b6fa8d280fdbf08b10a6b3a718 100644 --- a/pre-silica/genera-implementation.lisp +++ b/pre-silica/genera-implementation.lisp @@ -6,7 +6,7 @@ "Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." ;;; Defined below -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (proclaim '(special *sheet-device*)) #+IMach (proclaim '(special *small-sheet-device*))) @@ -888,8 +888,6 @@ (defmethod stream-glyph-for-character ((stream sheet-implementation-mixin) character style &optional our-font) - (declare (values index font escapement-x escapement-y origin-x origin-y bb-x bb-y - fixed-width-font-p)) (with-sheet-stream-glyph-for-character (stream-glyph-for-character stream character style our-font))) @@ -1021,7 +1019,6 @@ ;;; Interface to Genera scroll bars. (scl:defmethod (:y-scroll-position clim-sheet) () - (declare (values top-displayed height-displayed minimum-y maximum-y)) (let* ((stream (sheet-for-genera-window scl:self :error-if-no-match nil)) (history (and stream (stream-output-history stream))) (viewport (and stream (window-viewport stream)))) @@ -1048,7 +1045,6 @@ (defun calculate-new-viewport-position (stream x-or-y type position &optional (context-nlines 1)) (declare (ignore context-nlines)) - (declare (values viewport-left viewport-top)) (let ((viewport (window-viewport stream))) (ecase x-or-y (:y diff --git a/pre-silica/postscript-implementation.lisp b/pre-silica/postscript-implementation.lisp index e6de148a683527f4734e3f9e2f588ff81dd7abd3..2270df3a1ad8162e48970bb9d2c2e4bbeb825e08 100644 --- a/pre-silica/postscript-implementation.lisp +++ b/pre-silica/postscript-implementation.lisp @@ -908,8 +908,6 @@ x y translate xra yra scale 0 0 1 sa ea arcp setmatrix end} def (defmethod stream-glyph-for-character ((stream postscript-implementation-mixin) character style &optional our-font) - (declare (values index font escapement-x escapement-y origin-x origin-y bb-x bb-y - fixed-width-font-p)) (with-ps-stream-glyph-for-character (stream-glyph-for-character stream character style our-font))) diff --git a/silica/classes.lisp b/silica/classes.lisp index 4f5bd6c180b6663c8b4d2aa8d28399174e7adbbe..6c7aa9e566121e9b9c8b3cae6d7abce06072c48b 100644 --- a/silica/classes.lisp +++ b/silica/classes.lisp @@ -43,7 +43,7 @@ (mapping-cache :initform #+(or aclpc acl86win32) (cons nil nil) #-(or aclpc acl86win32) (mapping-cache-initform)) -#+(or aclpc acl86win32) +#+(or aclpc acl86win32 (and)) (undefined-text-style :initform *undefined-text-style* :accessor port-undefined-text-style) ;; When this is true, the text style to device font mapping is done @@ -74,6 +74,12 @@ v)) (:-ics (make-hash-table :test #'equal)))) +;;; NOTE temporary definition to make examples work; not sure +;;; what implementation would be right. -- jacek.zlydach, 2017-05-06 +#+ (or sbcl ccl) +(defun mapping-table-initform () + (make-hash-table :test #'equal)) + #+(and Allegro (not (or aclpc acl86win32))) (defun mapping-cache-initform () (excl:ics-target-case @@ -84,6 +90,12 @@ v)) (:-ics (cons nil nil)))) +;;; NOTE temporary definition to make examples work; not sure +;;; what implementation would be right. -- jacek.zlydach, 2017-05-06 +#+ (or sbcl ccl) +(defun mapping-cache-initform () + (cons nil nil)) + (define-protocol-class sheet ()) (defclass basic-sheet (sheet) @@ -147,7 +159,9 @@ *keyword-package*)))) ;; A fixnum, incremented only with ATOMIC-INCF -(defvar *event-timestamp* 0) +(declaim (type fixnum *event-timestamp*)) +#+sbcl (sb-ext:defglobal *event-timestamp* 0) +#-sbcl (defvar *event-timestamp* 0) (define-event-class event () ((timestamp :reader event-timestamp @@ -244,7 +258,7 @@ (defconstant +pointer-right-button+ (ash 1 10)) ;; The order of this must match the values above -(defconstant *pointer-buttons* '#(:left :middle :right)) +(defparameter *pointer-buttons* '#(:left :middle :right)) (deftype button-name () '(member :left :middle :right)) @@ -260,7 +274,7 @@ (defconstant +double-key+ (ash 1 5)) ;; The order of this must match the values above -(defconstant *modifier-keys* '#(:shift :control :meta :super :hyper :double)) +(defparameter *modifier-keys* '#(:shift :control :meta :super :hyper :double)) (deftype shift-keysym () '(member :left-shift :right-shift)) (deftype double-keysym () '(member :left-double :right-double)) diff --git a/silica/db-box.lisp b/silica/db-box.lisp index c66e3c485321c1c7193fcd87fcfa5621f30fa977..ae10bc1869339673c4c414339503195514ff2a82 100644 --- a/silica/db-box.lisp +++ b/silica/db-box.lisp @@ -21,16 +21,19 @@ (defmethod initialize-instance :after ((pane box-pane) &key contents &allow-other-keys) (dolist (child contents) - (etypecase child + ;;NOTE WORKAROUND temporarily changed etypecase to typecase, to avoid a runtime error in demo. + ;; Should be restored to etypecase after the source of that error is found. + ;; -- jacek.zlydach, 2017-05-14 + (typecase child (number) ((member :fill)) (pane (sheet-adopt-child pane child)) (cons - ;; Handle top-down layout syntax - (unless (and (typep (first child) '(or (member :fill) (real 0 *))) - (panep (second child))) - (error "Invalid box child: ~S" child)) - (sheet-adopt-child pane (second child))))) + ;; Handle top-down layout syntax + (unless (and (typep (first child) '(or (member :fill) (real 0 *))) + (panep (second child))) + (error "Invalid box child: ~S" child)) + (sheet-adopt-child pane (second child))))) (setf (slot-value pane 'contents) contents)) (defmethod handle-event :after ((pane box-pane) (event pointer-motion-event)) @@ -59,40 +62,44 @@ (minor-max most-positive-fixnum) scale) (dolist (entry contents) - (cond ((eq entry :fill) (incf major+ +fill+)) - ((numberp entry) (incf major entry)) - (t - (if (consp entry) - (psetf entry (second entry) - scale (let ((n (first entry))) - (if (numberp n) (float n) n))) - (setf scale 1.0)) - (let ((space-req (apply #'compose-space entry width-or-height))) - (flet ((scale (x) - (if (and (numberp scale) (< x +fill+)) (/ x scale) x))) - (declare (dynamic-extent #'scale)) - (cond ((eq scale :fill) - (incf major+ +fill+) - (incf major (scale (funcall fn-major space-req))) - (incf major- (scale (funcall fn-major- space-req)))) - ((= scale 1.0) - (incf major+ (scale (funcall fn-major+ space-req))) - (incf major (scale (funcall fn-major space-req))) - (incf major- (scale (funcall fn-major- space-req)))) - ((> scale 1.0) - (incf major+ scale) - (incf major scale) - (incf major- scale)) - (t - ;; It is maxf because we use the scaling - ;; to calculate the desired size of the - ;; overall pane - (maxf major+ (scale (funcall fn-major+ space-req))) - (maxf major (scale (funcall fn-major space-req))) - (maxf major- (scale (funcall fn-major- space-req))))) - (setq minor (max minor (funcall fn-minor space-req))) - (maxf minor-min (funcall fn-minor- space-req)) - (minf minor-max (funcall fn-minor+ space-req))))))) + ;; NOTE WORKAROUND wrapped the whole cond in a when block, to avoid error caused + ;; by `entry' being NIL for some reason during initialization of the demo. + ;; -- jacek.zlydach, 2017-05-14 + (when entry + (cond ((eq entry :fill) (incf major+ +fill+)) + ((numberp entry) (incf major entry)) + (t + (if (consp entry) + (psetf entry (second entry) + scale (let ((n (first entry))) + (if (numberp n) (float n) n))) + (setf scale 1.0)) + (let ((space-req (apply #'compose-space entry width-or-height))) + (flet ((scale (x) + (if (and (numberp scale) (< x +fill+)) (/ x scale) x))) + (declare (dynamic-extent #'scale)) + (cond ((eq scale :fill) + (incf major+ +fill+) + (incf major (scale (funcall fn-major space-req))) + (incf major- (scale (funcall fn-major- space-req)))) + ((= scale 1.0) + (incf major+ (scale (funcall fn-major+ space-req))) + (incf major (scale (funcall fn-major space-req))) + (incf major- (scale (funcall fn-major- space-req)))) + ((> scale 1.0) + (incf major+ scale) + (incf major scale) + (incf major- scale)) + (t + ;; It is maxf because we use the scaling + ;; to calculate the desired size of the + ;; overall pane + (maxf major+ (scale (funcall fn-major+ space-req))) + (maxf major (scale (funcall fn-major space-req))) + (maxf major- (scale (funcall fn-major- space-req))))) + (setq minor (max minor (funcall fn-minor space-req))) + (maxf minor-min (funcall fn-minor- space-req)) + (minf minor-max (funcall fn-minor+ space-req)))))))) ;;--- These calcs lead to weirdness when fills are involved. ;;--- This looks like a leftover from the time when +/- were relative ;;(setq minor- (max 0 (- minor minor-min))) @@ -173,23 +180,26 @@ (defmethod allocate-space ((box-pane vbox-pane) width height) (with-slots (contents spacing) box-pane (let ((space-requirement - (compose-space box-pane :width width :height height))) + (compose-space box-pane :width width :height height))) (flet ((compose (x) - (cond ((atom x) (compose-space x :width width)) - ((eq (car x) :fill) :fill) - (t (car x))))) + (cond + ;;NOTE WORKAROUND added null clause as a safeguard for NIL showing up during initialization of the demo -- jacek.zlydach, 2017-05-14 + ((null x) :fill) + ((atom x) (compose-space x :width width)) + ((eq (car x) :fill) :fill) + (t (car x))))) (declare (dynamic-extent #'compose)) (let* ((adjust (* spacing (1- (length (sheet-children box-pane))))) (sizes (allocate-space-to-items - (- height adjust) - (space-requirement+* space-requirement :height (- adjust)) - contents - #'space-requirement-min-height - #'space-requirement-height - #'space-requirement-max-height - #'compose)) - (y 0)) + (- height adjust) + (space-requirement+* space-requirement :height (- adjust)) + contents + #'space-requirement-min-height + #'space-requirement-height + #'space-requirement-max-height + #'compose)) + (y 0)) (mapc #'(lambda (sheet size) (when (or (panep sheet) (and (consp sheet) diff --git a/silica/db-button.lisp b/silica/db-button.lisp index 5241b4825b2d4b007999340a66d3ff6ac4a5db96..ca7acff0da366a20d2493b4c399a95edb6167947 100644 --- a/silica/db-button.lisp +++ b/silica/db-button.lisp @@ -577,44 +577,44 @@ toggle button base. This way they can share the draw code. (maxf new-height original-height) (multiple-value-bind (result foundp) (gethash (list original-pattern new-width new-height) *grow-button-pattern-cache*) - (when foundp + (when foundp (return-from grow-button-pattern result))) (multiple-value-bind (original-array designs) (decode-pattern original-pattern) (let ((center-x (floor original-width 2)) (center-y (floor original-height 2)) (intermediate-array - (make-array (list original-height new-width) - :element-type `(unsigned-byte ,(integer-length (1- (length designs)))) - :initial-element 0)) - (final-array - (make-array (list new-height new-width) - :element-type `(unsigned-byte ,(integer-length (1- (length designs)))) - :initial-element 0))) + (make-array (list original-height new-width) + :element-type `(unsigned-byte ,(integer-length (1- (length designs)))) + :initial-element 0)) + (final-array + (make-array (list new-height new-width) + :element-type `(unsigned-byte ,(integer-length (1- (length designs)))) + :initial-element 0))) (loop for x from 0 to center-x - do (loop for y from 0 to (1- original-height) - do (setf (aref intermediate-array y x) (aref original-array y x)))) + do (loop for y from 0 to (1- original-height) + do (setf (aref intermediate-array y x) (aref original-array y x)))) (loop for x from (1- new-width) downto (- new-width center-x) - for old-x from (1- original-width) by -1 - do (loop for y from 0 to (1- original-height) - do (setf (aref intermediate-array y x) (aref original-array y old-x)))) + for old-x downfrom (1- original-width) by 1 + do (loop for y from 0 to (1- original-height) + do (setf (aref intermediate-array y x) (aref original-array y old-x)))) (loop for x from (1+ center-x) to (- new-width center-x 1) - do (loop for y from 0 to (1- original-height) - do (setf (aref intermediate-array y x) - (aref original-array y center-x)))) + do (loop for y from 0 to (1- original-height) + do (setf (aref intermediate-array y x) + (aref original-array y center-x)))) ;; Now the other direction (loop for y from 0 to center-y - do (loop for x from 0 to (1- new-width) - do (setf (aref final-array y x) (aref intermediate-array y x)))) + do (loop for x from 0 to (1- new-width) + do (setf (aref final-array y x) (aref intermediate-array y x)))) (loop for y from (1- new-height) downto (- new-height center-y) - for old-y from (1- original-height) by -1 - do (loop for x from 0 to (1- new-width) - do (setf (aref final-array y x) (aref intermediate-array old-y x)))) + for old-y downfrom (1- original-height) by 1 + do (loop for x from 0 to (1- new-width) + do (setf (aref final-array y x) (aref intermediate-array old-y x)))) (loop for y from (1+ center-y) to (- new-height center-y 1) - do (loop for x from 0 to (1- new-width) - do (setf (aref final-array y x) (aref intermediate-array center-y x)))) + do (loop for x from 0 to (1- new-width) + do (setf (aref final-array y x) (aref intermediate-array center-y x)))) (let ((result-pattern (make-pattern final-array designs))) - (setf (gethash (list original-pattern new-width new-height) + (setf (gethash (list original-pattern new-width new-height) *grow-button-pattern-cache*) result-pattern)))))) diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp index 5ee6f9d10e6afb7d263b140f4a808b7a8493c204..5e0f0c386cfc2aecfa040d4abb8fec6275884761 100644 --- a/silica/db-scroll.lisp +++ b/silica/db-scroll.lisp @@ -317,7 +317,6 @@ ;;; Given min1, max1 and value1 which is between them it will return ;;; value2 which would be proportionally between min2 and max2. (defun compute-symmetric-value (min1 max1 value1 min2 max2) - (declare (values value2)) (let* ((distance1 (- max1 min1)) (fraction1 (if (zerop distance1) 0 diff --git a/silica/event.lisp b/silica/event.lisp index 15725639a3fada6e3bdb056541b813acf2ebf3c0..08f01233360fd9eedfb393ca4a9ae69925df9cd6 100644 --- a/silica/event.lisp +++ b/silica/event.lisp @@ -701,21 +701,10 @@ ;; Gosh, this macro is bad style, and violates the MOP. ;; Piling warts upon warts, we have to force finalization at ;; macroexpand time... - smh 18may93 - (#+Allegro clos:finalize-inheritance - #+aclpc acl:finalize-inheritance - #+Clozure ccl:finalize-inheritance - #-(or Allegro aclpc Clozure) cl:finalize-inheritance - (find-class event-class)) ;smh 18may93 - (let* ((slots #+aclpc (acl:class-slots (find-class event-class)) - #+(and MCL CCL-2) (ccl:class-slots (find-class event-class)) - #+Clozure (ccl:class-slots (find-class event-class)) - #-(or (and MCL CCL-2) aclpc Clozure) (clos:class-slots (find-class event-class)) - ) - (slot-names #+aclpc (mapcar #'acl:slot-definition-name slots) - #+(and MCL CCL-2) (mapcar #'ccl:slot-definition-name slots) - #+Clozure (mapcar #'ccl:slot-definition-name slots) - #-(or (and MCL CCL-2) aclpc Clozure) (mapcar #'clos:slot-definition-name slots) - ) + (closer-mop:finalize-inheritance + (find-class event-class)) ;smh 18may93 + (let* ((slots (closer-mop:class-slots (find-class event-class))) + (slot-names (mapcar #'closer-mop:slot-definition-name slots)) (resource-name (fintern "*~A-~A*" event-class 'resource))) `(progn (defvar ,resource-name nil) @@ -723,25 +712,25 @@ ,@(mapcar #'(lambda (slot) (if (eq slot 'timestamp) `(setf (slot-value event ',slot) - (or ,slot (atomic-incf *event-timestamp*))) - `(setf (slot-value event ',slot) ,slot))) + (or ,slot (atomic-incf *event-timestamp*))) + `(setf (slot-value event ',slot) ,slot))) slot-names)) (let ((old (assoc ',event-class *resourced-events*))) (unless old (setq *resourced-events* - (append *resourced-events* - (list (list ',event-class ',resource-name - ;; Allocates, misses, creates, deallocates - #+meter-events ,@(list 0 0 0 0))))))) + (append *resourced-events* + (list (list ',event-class ',resource-name + ;; Allocates, misses, creates, deallocates + #+meter-events ,@(list 0 0 0 0))))))) ;; When an event is in the event resource, we use the timestamp ;; to point to the next free event (let ((previous-event (make-instance ',event-class))) (setq ,resource-name previous-event) (repeat ,(1- nevents) - (let ((event (make-instance ',event-class - :timestamp nil))) - (setf (slot-value previous-event 'timestamp) event) - (setq previous-event event))))))) + (let ((event (make-instance ',event-class + :timestamp nil))) + (setf (slot-value previous-event 'timestamp) event) + (setq previous-event event))))))) (define-event-resource pointer-motion-event 20) (define-event-resource pointer-enter-event 20) @@ -829,15 +818,9 @@ (defun copy-event (event) (let* ((class (class-of event)) (copy (allocate-instance class))) - (dolist (slot (#+aclpc acl:class-slots - #+Clozure ccl:class-slots - #-(or aclpc Clozure) clos:class-slots class)) - (let ((name (#+aclpc acl:slot-definition-name - #+Clozure ccl:slot-definition-name - #-(or aclpc Clozure) clos:slot-definition-name slot)) - (allocation (#+aclpc acl:slot-definition-allocation - #+Clozure ccl:slot-definition-allocation - #-(or aclpc Clozure) clos:slot-definition-allocation slot))) + (dolist (slot (closer-mop:class-slots class)) + (let ((name (closer-mop:slot-definition-name slot)) + (allocation (closer-mop:slot-definition-allocation slot))) (when (and (eql allocation :instance) (slot-boundp event name)) (setf (slot-value copy name) (slot-value event name))))) diff --git a/silica/framem.lisp b/silica/framem.lisp index 371d2c5acd102c6c28b00ad42bf8e055b4564a4b..ee6d8cc85cb5c32c0018cda8aa0665eb04baad1e 100644 --- a/silica/framem.lisp +++ b/silica/framem.lisp @@ -106,8 +106,8 @@ :region (multiple-value-bind (width height) (bounding-rectangle-size top-pane) (make-bounding-rectangle 0 0 width height)) -#-(or aclpc acl86win32) :background #-(or aclpc acl86win32) (frame-background frame) -#-(or aclpc acl86win32) :foreground #-(or aclpc acl86win32) (frame-foreground frame) +#-(or aclpc acl86win32 (and)) :background #-(or aclpc acl86win32 (and)) (frame-background frame) +#-(or aclpc acl86win32 (and)) :foreground #-(or aclpc acl86win32 (and)) (frame-foreground frame) :text-style (frame-text-style frame))))) (sheet-adopt-child (find-graft :port (port frame)) sheet) (setf (frame-top-level-sheet frame) sheet @@ -220,5 +220,5 @@ options)))) (defmethod make-pane-arglist ((framem standard-frame-manager) type &rest options) - (declare (ignore type) #-Clozure (non-dynamic-extent options)) + (declare (ignore type)) options) diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index bbefb32bdea0d40cff7649bf3c72835ad837b3f3..8708c4e0dadbf9b5522d0c0548e1dc9d1501aa6d 100644 --- a/silica/gadgets.lisp +++ b/silica/gadgets.lisp @@ -478,13 +478,11 @@ ;;; (defclass push-button - (action-gadget labelled-gadget-mixin) - ((show-as-default :initform nil :initarg :show-as-default - :accessor push-button-show-as-default) - #+(or aclpc acl86win32) - (pattern :initarg :pattern) - #+(or aclpc acl86win32) - (icon-pattern :initarg :icon-pattern))) + (action-gadget labelled-gadget-mixin) + ((show-as-default :initform nil :initarg :show-as-default + :accessor push-button-show-as-default) + (pattern :initarg :pattern) + (icon-pattern :initarg :icon-pattern))) ;;; Toggle button @@ -784,7 +782,7 @@ The text-field must have the focus before you can call this function.")) :height h :min-height 0 :max-height max-height)))) ;;;#+(or aclpc acl86win32) -;;;(eval-when (compile load eval) +;;;(eval-when (:compile-toplevel :load-toplevel :execute) ;;; ;;mm: 11Jan95 - this is defined later in clim\db-strea ;;; (unless (ignore-errors (find-class 'clim-stream-pane)) ;;; (defclass clim-stream-pane () ()))) diff --git a/silica/graphics.lisp b/silica/graphics.lisp index 6e013959462bc017ac8fa0a9cf643df6281592cc..37098315c5911fc58ae4c81b1bd4e76bff4bef85 100644 --- a/silica/graphics.lisp +++ b/silica/graphics.lisp @@ -8,7 +8,7 @@ ;;; Portions copyright (c) 1991, 1992 Franz, Inc. All rights reserved." -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) ;; NOTE: if you change this list of keywords, you also have to change the keyword arguments ;; accepted by (CLOS:METHOD INVOKE-WITH-DRAWING-OPTIONS (DRAWING-STATE-MIXIN T)) @@ -66,7 +66,7 @@ ) ;eval-when -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defun write-graphics-function-transformer (name medium-graphics-function-name @@ -525,10 +525,6 @@ &key (from-head nil) (to-head t) (head-length 10) (head-width 5) &allow-other-keys) (declare (dynamic-extent args)) - (declare (arglist medium x1 y1 x2 y2 - &rest args - &key (from-head nil) (to-head t) (head-length 10) (head-width 5) - . #.(all-drawing-options-lambda-list :line-cap))) (flet ((draw-arrow () (let* ((dx (- x2 x1)) (dy (- y2 y1)) @@ -568,10 +564,6 @@ (defun draw-arrow (medium point1 point2 &rest args) (declare (dynamic-extent args)) - (declare (arglist medium x1 y1 x2 y2 - &rest args - &key (from-head nil) (to-head t) (head-length 10) (head-width 5) - . #.(all-drawing-options-lambda-list :line-cap))) (apply #'draw-arrow* medium (point-x point1) (point-y point1) (point-x point2) (point-y point2) args)) @@ -642,10 +634,6 @@ (defun draw-regular-polygon* (medium x1 y1 x2 y2 nsides &rest args &key (handedness :left) (closed t) &allow-other-keys) (declare (dynamic-extent args)) - (declare (arglist medium x1 y1 x2 y2 nsides - &rest args - &key (filled t) (handedness :left) (closed t) - . #.(all-drawing-options-lambda-list :line-joint-cap))) (let* ((theta (* (float (* pi (/ 2.0 nsides)) 0.0) (ecase handedness (:left +1) @@ -669,10 +657,6 @@ (defun draw-regular-polygon (medium point1 point2 nsides &rest args) (declare (dynamic-extent args)) - (declare (arglist medium point1 point2 nsides - &rest args - &key (handedness :left) (closed t) (filled t) - . #.(all-drawing-options-lambda-list :line-joint-cap))) (apply #'draw-regular-polygon* medium (point-x point1) (point-y point1) (point-x point2) (point-y point2) @@ -680,17 +664,11 @@ (defun draw-triangle (medium p1 p2 p3 &rest args) (declare (dynamic-extent args)) - (declare (arglist medium p1 p2 p3 - &rest args - &key (filled t) . #.(all-drawing-options-lambda-list :line-joint))) (with-stack-list (points p1 p2 p3) (apply #'draw-polygon medium points :closed t args))) (defun draw-triangle* (medium x1 y1 x2 y2 x3 y3 &rest args) (declare (dynamic-extent args)) - (declare (arglist medium x1 y1 x2 y2 x3 y3 - &rest args - &key (filled t) . #.(all-drawing-options-lambda-list :line-joint))) (with-stack-list (points x1 y1 x2 y2 x3 y3) (apply #'draw-polygon* medium points :closed t args))) @@ -705,10 +683,6 @@ (defun draw-circle (medium center radius &rest args) (declare (dynamic-extent args)) - (declare (arglist medium center radius - &rest args - &key start-angle end-angle (filled t) - . #.(all-drawing-options-lambda-list :line-cap))) (apply #'draw-ellipse medium center radius 0 0 radius args)) (define-compiler-macro draw-circle (medium center radius &rest args) @@ -722,10 +696,6 @@ (defun draw-circle* (medium center-x center-y radius &rest args) (declare (dynamic-extent args)) - (declare (arglist medium center-x center-y radius - &rest args - &key start-angle end-angle (filled t) - . #.(all-drawing-options-lambda-list :line-cap))) (apply #'draw-ellipse* medium center-x center-y radius 0 0 radius args)) (define-compiler-macro draw-circle* (medium center-x center-y radius &rest args) @@ -742,9 +712,6 @@ (defun draw-oval* (medium center-x center-y x-radius y-radius &rest args &key (filled t) &allow-other-keys) (declare (dynamic-extent args)) - (declare (arglist medium center-x center-y x-radius y-radius - &rest args - . #.(all-drawing-options-lambda-list :line-cap))) (flet ((draw-oval () (let ((left (- center-x x-radius)) (right (+ center-x x-radius)) @@ -794,9 +761,6 @@ (defun draw-oval (medium center x-radius y-radius &rest args) (declare (dynamic-extent args)) - (declare (arglist medium point x-radius y-radius - &rest args - . #.(all-drawing-options-lambda-list :line-cap))) (apply #'draw-oval* medium (point-x center) (point-y center) x-radius y-radius args)) diff --git a/silica/macros.lisp b/silica/macros.lisp index 42f993b5178cf93b021c810866df9712204878ed..a13f4799e7d1202a6ab50a61149a56d139b59a13 100644 --- a/silica/macros.lisp +++ b/silica/macros.lisp @@ -7,16 +7,14 @@ ;;;"Copyright (c) 1991, 1992 Franz, Inc. All rights reserved. ;;; Portions copyright (c) 1992 Symbolics, Inc. All rights reserved." -(defgeneric invoke-with-sheet-medium (sheet continuation) - (declare (dynamic-extent continuation))) +(defgeneric invoke-with-sheet-medium (sheet continuation)) (defmacro with-sheet-medium ((medium sheet) &body body) `(flet ((with-sheet-medium-body (,medium) ,@body)) (declare (dynamic-extent #'with-sheet-medium-body)) (invoke-with-sheet-medium ,sheet #'with-sheet-medium-body))) -(defgeneric invoke-with-sheet-medium-bound (sheet medium continuation) - (declare (dynamic-extent continuation))) +(defgeneric invoke-with-sheet-medium-bound (sheet medium continuation)) (defmacro with-sheet-medium-bound ((sheet medium) &body body) `(flet ((with-sheet-medium-bound-body () ,@body)) diff --git a/silica/medium.lisp b/silica/medium.lisp index 98da1216c03b8bb8f812627953343ec1dd80ce7d..598788dc767593ee73cee8a75b3a87f1a8d576a1 100644 --- a/silica/medium.lisp +++ b/silica/medium.lisp @@ -107,7 +107,7 @@ (defclass sheet-with-resources-mixin () ((foreground :initform nil :accessor pane-foreground) (background :initform nil :accessor pane-background) - (text-style :initform nil :accessor pane-text-style) + (text-style :initform nil :initarg :text-style :accessor pane-text-style) (initargs :initform nil :reader sheet-with-resources-initargs))) (defmethod initialize-instance :after @@ -487,7 +487,6 @@ (defoperation text-size medium-protocol ((medium medium) string &key text-style start end) - (declare (values largest-x total-height last-x last-y baseline)) (:no-defgeneric t)) diff --git a/silica/mirror.lisp b/silica/mirror.lisp index 13cf1351f004bd14f149eefc7462f7f405b1b5c3..2827d0c07a027189411eead8f97cdb6097c12a40 100644 --- a/silica/mirror.lisp +++ b/silica/mirror.lisp @@ -173,14 +173,12 @@ ;; Returns the coordinates of sheet's mirror in the coordinates of the ;; parent of the mirror -(defgeneric mirror-region* (port sheet) - #-aclpc (declare (values left top right bottom))) +(defgeneric mirror-region* (port sheet)) ;; Returns the coordinates of sheet's mirror in the coordinates of the ;; mirror itself. That is, it will return 0,0,WIDTH,HEIGHT for most ;; known window systems -(defgeneric mirror-inside-region* (port sheet) - (declare (values left top right bottom))) +(defgeneric mirror-inside-region* (port sheet)) (defgeneric mirror-native-edges* (port sheet)) (defgeneric mirror-inside-edges* (port sheet)) diff --git a/silica/port.lisp b/silica/port.lisp index 9496658ebe196637faaf4f258816ff6b52e40c41..f459327b6d6ed60046fdba243714356f7071321c 100644 --- a/silica/port.lisp +++ b/silica/port.lisp @@ -10,12 +10,12 @@ ;; Ports and grafts -(defvar *default-server-path* #+(and allegro (not microsoft)) '(:motif) - #+Lucid '(:clx) - #+Genera `(:genera) - #+Cloe-Runtime `(:cloe) - #+(and allegro microsoft) '(:aclpc) - #-(or allegro Lucid Genera Cloe-Runtime) nil) +(defvar *default-server-path* + #+(and allegro (not microsoft)) '(:motif) + #+Genera `(:genera) + #+Cloe-Runtime `(:cloe) + #+(and allegro microsoft) '(:aclpc) + #-(or allegro Lucid Genera Cloe-Runtime) '(:clx)) (defvar *ports* nil) @@ -230,7 +230,6 @@ (defun fit-region*-in-region* (left1 top1 right1 bottom1 left2 top2 right2 bottom2) - #+Genera (declare (values left1 top1 right1 bottom1 adjusted-p)) (let* ((adjusted-p nil) (w (- right1 left1)) (h (- bottom1 top1)) diff --git a/silica/protocols.lisp b/silica/protocols.lisp index 2737d34bdac5584ff1d377204d3bd35ab2a2f77e..f0086f24c31dfe93c1c17383f752183c30b50c53 100644 --- a/silica/protocols.lisp +++ b/silica/protocols.lisp @@ -50,13 +50,13 @@ (defmacro defprotocol (name supers &rest options) (declare (ignore supers options)) - `(eval-when (compile eval load) + `(eval-when (:compile-toplevel :execute :load-toplevel) (setf (find-protocol ',name) (make-instance 'protocol :name ',name)))) (defmacro defrole (class supers slots &rest options) (declare (ignore supers options)) - `(eval-when (compile eval load) + `(eval-when (:compile-toplevel :execute :load-toplevel) #+PCL (pcl::do-standard-defsetf ,@(mapcan #'(lambda (slot) @@ -88,7 +88,7 @@ t)) required-arg-specs)) (extra-args (and pos (subseq arg-specs pos)))) - `(eval-when (compile eval load) + `(eval-when (:compile-toplevel :execute :load-toplevel) ;; Define a group named (OPERATION PROTOCOL NAME), since we can ;; have multiple DEFOPERATIONs for the same operation in ;; different protocols (used to just be named NAME). diff --git a/silica/scroll-pane.lisp b/silica/scroll-pane.lisp index a64f76046d7c0a91605a46b391f5157ddc82b34e..84e3bfebb1893546a21bd322dc0222e0332fe1b9 100644 --- a/silica/scroll-pane.lisp +++ b/silica/scroll-pane.lisp @@ -239,7 +239,18 @@ (:horizontal (- right left)) (:vertical (- bottom top)))))) -(defmethod scroll-up-line-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation) +;;; NOTE WORKAROUND +;;; The following methods requires 4 parameters. Added `workaround' parameter for that, +;;; but the methods should be further reviewed for correctness. +;;; - scroll-up-line-callback +;;; - scroll-down-line-callback +;;; - scroll-up-page-callback +;;; - scroll-down-page-callback +;;; - scroll-to-top-callback +;;; - scroll-to-bottom-callback +;;; +;;; -- jacek.zlydach 2017-05-14 +(defmethod scroll-up-line-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation whatever) (with-slots (current-size current-value port) scroll-bar (with-slots (viewport contents) scroller-pane (let* ((contents-range (contents-range scroller-pane orientation)) @@ -252,7 +263,7 @@ (scroll-bar-value-changed-callback scroll-bar scroller-pane orientation new-value current-size))))) -(defmethod scroll-down-line-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation) +(defmethod scroll-down-line-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation whatever) (with-slots (current-size current-value port) scroll-bar (with-slots (viewport contents) scroller-pane (let* ((contents-range (contents-range scroller-pane orientation)) @@ -265,7 +276,7 @@ (scroll-bar-value-changed-callback scroll-bar scroller-pane orientation new-value current-size))))) -(defmethod scroll-up-page-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation) +(defmethod scroll-up-page-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation whatever) (with-slots (current-size current-value) scroll-bar (with-slots (viewport contents) scroller-pane (let* ((contents-range (contents-range scroller-pane orientation)) @@ -279,7 +290,7 @@ (scroll-bar-value-changed-callback scroll-bar scroller-pane orientation new-value current-size))))) -(defmethod scroll-down-page-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation) +(defmethod scroll-down-page-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation whatever) (with-slots (current-size current-value) scroll-bar (with-slots (viewport contents) scroller-pane (let* ((contents-range (contents-range scroller-pane orientation)) @@ -293,11 +304,11 @@ (scroll-bar-value-changed-callback scroll-bar scroller-pane orientation new-value current-size))))) -(defmethod scroll-to-top-callback ((scroll-bar scroll-bar-pane) client id) +(defmethod scroll-to-top-callback ((scroll-bar scroll-bar-pane) client id whatever) (with-slots (current-size current-value) scroll-bar (scroll-bar-value-changed-callback scroll-bar client id 0 current-size))) -(defmethod scroll-to-bottom-callback ((scroll-bar scroll-bar-pane) client id) +(defmethod scroll-to-bottom-callback ((scroll-bar scroll-bar-pane) client id whatever) (with-slots (current-size current-value) scroll-bar (scroll-bar-value-changed-callback scroll-bar client id 1.0 current-size))) diff --git a/silica/sheet.lisp b/silica/sheet.lisp index 72960ac7aab948f264f891c5700b67b3fdb2e221..f27dc45707ea7f216df51f913ffe353450f1482c 100644 --- a/silica/sheet.lisp +++ b/silica/sheet.lisp @@ -220,8 +220,7 @@ (sheet-transformation child) left top right bottom)))) (sheet-children sheet))))) -(defgeneric map-over-sheets-containing-position (function sheet x y) - (declare (dynamic-extent function))) +(defgeneric map-over-sheets-containing-position (function sheet x y)) (defmethod map-over-sheets-containing-position (function (sheet basic-sheet) x y) (declare (dynamic-extent function)) (dolist (child (sheet-children sheet)) @@ -231,8 +230,7 @@ (region-contains-position-p (sheet-region child) x y))) (funcall function child)))) -(defgeneric map-over-sheets-overlapping-region (function sheet region) - (declare (dynamic-extent function))) +(defgeneric map-over-sheets-overlapping-region (function sheet region)) (defmethod map-over-sheets-overlapping-region (function (sheet basic-sheet) region) (declare (dynamic-extent function)) (if (or (null region) ;--- kludge diff --git a/silica/text-style.lisp b/silica/text-style.lisp index 2b52a3749ba49403dfdba0b58692a842cc741e13..1209efdf24fbacaecf10dee4b2f5f2eae3f79490 100644 --- a/silica/text-style.lisp +++ b/silica/text-style.lisp @@ -346,9 +346,9 @@ (setf (cdr mapping-pair) underlying) (push (cons logical underlying) (cdr pair))))))) -(defconstant %%face-code-no-merge (byte 1 28)) -(defconstant %%face-code-class (byte 4 24)) -(defconstant %%face-code-faces (byte 24 0)) +(defparameter %%face-code-no-merge (byte 1 28)) +(defparameter %%face-code-class (byte 4 24)) +(defparameter %%face-code-faces (byte 24 0)) (defun face->face-code (face) (when (null face) (return-from face->face-code nil)) @@ -494,7 +494,6 @@ (defmethod text-size ((medium basic-medium) string &key (text-style (medium-merged-text-style medium)) (start 0) end) - (declare (values largest-x total-height last-x last-y baseline)) ;; this shouldn't be necessary because of trampolines directly above ;; 31jan97 tjm w/colin #+(or aclpc acl86win32) @@ -815,7 +814,6 @@ #-(or aclpc acl86win32) (defun-inline char-character-set-and-index (character) - (declare (values character-set index)) (values #+Allegro (excl:ics-target-case (:-ics *standard-character-set*) @@ -830,7 +828,6 @@ #+(or aclpc acl86win32) ;;; For now, only standard character set characters are understood... (defun-inline char-character-set-and-index (character) - (declare (values character-set index)) (values *standard-character-set* (char-code character))) diff --git a/specs/clim-sys.tex b/specs/clim-sys.tex index fb1ea6662cd6ac4915e9b3af4c916b751280372c..7cfe6996d8df137d001f2681924e9d0108f71f94 100644 --- a/specs/clim-sys.tex +++ b/specs/clim-sys.tex @@ -260,7 +260,6 @@ called \cl{sample-output-record} might be defined as follows: \begin{verbatim} (defgeneric output-record-position (record) - (declare (values x y))) (defgeneric* (setf output-record-position) (x y record)) (defmethod output-record-position ((record sample-output-record)) diff --git a/specs/design-classes.lisp b/specs/design-classes.lisp index c3c7026eb0046468efd2015373a1a0a16d849936..4a302ff043f0ff8fdf90a092866d7cf21051d503 100644 --- a/specs/design-classes.lisp +++ b/specs/design-classes.lisp @@ -2,7 +2,7 @@ (defvar *classes*) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :eps-bbox cl:*features*)) (defmacro with-postscript-stream ((stream pathname) &body body) diff --git a/specs/rendering-conventions.lisp b/specs/rendering-conventions.lisp index ee272a35aa9361285279e6c21a6e0490b2dd7684..4aef6eb0f519d5f49fd928c0efdf6cc7fea26135 100644 --- a/specs/rendering-conventions.lisp +++ b/specs/rendering-conventions.lisp @@ -51,7 +51,7 @@ (loop for y from dtop below dbottom do (graphics:draw-point (+ x .5) (+ y .5))))))))))) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :eps-bbox cl:*features*)) (defmacro with-postscript-stream ((stream pathname) &body body) diff --git a/sys/compile.lisp b/sys/compile.lisp index 408ef0d0a5e88f52d2a1dbdcf6d5d62ac9b66944..059ddac55c6ab43ea613d89b1bd1fc1e2b87cea3 100644 --- a/sys/compile.lisp +++ b/sys/compile.lisp @@ -10,7 +10,7 @@ (proclaim '(optimize (speed 3) (safety 1) (debug 1))) #+(and allegro microsoft) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :acl86win32 *features*)) #+microsoft @@ -27,7 +27,7 @@ ;; should probably change ANSI-90 to ANSI-CL throughout the CLIM code but ;; until then... (aclpc gets this feature in defsystem) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :ansi-90 *features*) (setf (logical-pathname-translations "clim2") `((";**;*.*" ,*clim-root*))) diff --git a/sys/defsystem.lisp b/sys/defsystem.lisp index 3c7d82b7a8fd287b6ca3b05ca19055b74134f757..2c135b2716c468b7137907389a64492113fc45f5 100644 --- a/sys/defsystem.lisp +++ b/sys/defsystem.lisp @@ -35,7 +35,7 @@ ;; ANSI-90, corresponding to what we think the spec will be, in late 1990. #+Allegro -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (warn "This file is no longer used in the Allegro port. \ Something is wrong if this warning appears!")) @@ -45,7 +45,7 @@ Something is wrong if this warning appears!")) (pushnew :ansi-90 *features*)) #+Genera -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (multiple-value-bind (major minor) (sct:get-system-version) (declare (ignore minor)) (when (>= major 437) @@ -111,7 +111,7 @@ Something is wrong if this warning appears!")) ;;; *** A temporary workaround, easier than fixing all references to ;;; *** LISP:<foo>. --RWK 20.Nov.90 #+ANSI-90 -(eval-when (eval compile load) +(eval-when (:execute :compile-toplevel :load-toplevel) (flet ((fix-package (pack-name add-name) (setq add-name (string add-name)) (let ((pack (find-package pack-name))) @@ -136,12 +136,12 @@ Something is wrong if this warning appears!")) ;;; #-(or Minima Genera) -(eval-when (eval load compile) +(eval-when (:execute :load-toplevel :compile-toplevel) (shadow (list (intern (symbol-name :make-pathname) :lisp) (intern (symbol-name :pathname-directory) :lisp)))) #-(or Minima Genera) -(eval-when (eval load compile) +(eval-when (:execute :load-toplevel :compile-toplevel) (export (list (intern (symbol-name :make-pathname) :clim-defsystem) (intern (symbol-name :pathname-directory) :clim-defsystem)))) @@ -1211,7 +1211,7 @@ pathname fields are evaluated." ;; The following are used to prevent multiple compilations/loads from occuring ;; during a single call to LOAD-SYSTEM or COMPILE-SYSTEM. -(eval-when (eval compile) +(eval-when (:execute :compile-toplevel) (proclaim '(special *loaded-systems* *loaded-modules* *compiled-systems* *compiled-modules* *tracep*))) diff --git a/sys/load-clim2.lisp b/sys/load-clim2.lisp index 9591caa0f81ffd7800d2fa251d16cbe79b91ec82..bbf07d788d42aa29ee2e5b0695c94f52215d3b3b 100644 --- a/sys/load-clim2.lisp +++ b/sys/load-clim2.lisp @@ -10,7 +10,7 @@ ;; CLIM 2.0 clim-sys clim-silica clim-internals clx-clim genera-clim ;; CLIM 0.9 - clim-conditions clim-shared clim-stream + clim-shared clim-stream silica windshield on-x on-genera)) (when (find-package pkg) (delete-package pkg))) diff --git a/sys/load.lisp b/sys/load.lisp index 9e6d6e9d2d8e8813cabc6706130eb50114d64b6b..807b7ba6103c27402034d35bde842c9875bac0a0 100644 --- a/sys/load.lisp +++ b/sys/load.lisp @@ -4,7 +4,7 @@ (in-package :user) #+(and Allegro (or microsoft mswindows)) -(eval-when (compile load eval) (push :acl86win32 *features*)) +(eval-when (:compile-toplevel :load-toplevel :execute) (push :acl86win32 *features*)) #+acl86win32 (let ((excl::*enable-package-locked-errors* nil)) diff --git a/sys/sysdcl-pc.lisp b/sys/sysdcl-pc.lisp index 3e967c7c3e0c08c6412525231db479e792691ea0..fd705997acdf907f3e49513bdebb8e717ecf5572 100644 --- a/sys/sysdcl-pc.lisp +++ b/sys/sysdcl-pc.lisp @@ -6,7 +6,7 @@ "Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) ;;; Tell the world that we're here ;;;--- These need to be in the CLIM.fasl also. @@ -43,7 +43,7 @@ ;;; our own trampolines which will call our generic function, and then write default ;;; methods which will invoke the COMMON-LISP package equivalents. -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) #+(or Allegro Minima) @@ -56,11 +56,6 @@ CCL-2) ;Except for CLOSE (and WITH-OPEN-STREAM) (pushnew :clim-uses-lisp-stream-functions *features*) -;;; CLIM-ANSI-Conditions means this lisp truly supports the ANSI CL condition system -;;; CLIM-Conditions means that it has a macro called DEFINE-CONDITION but that it works -;;; like Allegro 3.1.13 or Lucid. -(pushnew :CLIM-ANSI-Conditions *features*) - #+Allegro (pushnew :allegro-v4.0-constructors *features*) diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp index 6ff30dc30fcb33bfc14c709b7c9036898f814027..4d9f3072dcb4eaeed0e8387b3a89d79669e000bb 100644 --- a/sys/sysdcl.lisp +++ b/sys/sysdcl.lisp @@ -17,7 +17,7 @@ "Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) ;;; Tell the world that we're here ;;;--- These need to be in the CLIM.fasl also. @@ -57,7 +57,7 @@ ;;; our own trampolines which will call our generic function, and then write default ;;; methods which will invoke the COMMON-LISP package equivalents. -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) #+(or allegro Minima @@ -74,11 +74,6 @@ SBCL) (pushnew :clim-uses-lisp-stream-functions *features*) -;;; CLIM-ANSI-Conditions means this lisp truly supports the ANSI CL condition system -;;; CLIM-Conditions means that it has a macro called DEFINE-CONDITION but that it works -;;; like allegro 3.1.13 or Lucid. -(pushnew :clim-ansi-conditions *features*) - #+allegro (pushnew :allegro-v4.0-constructors *features*) @@ -126,7 +121,6 @@ "reader" "clos-patches" "clos" - #+CLIM-conditions "condpat" ;get the define-condition macro ;; General Lisp extensions "utilities" @@ -148,7 +142,7 @@ ;; Basic utilities for Silica and CLIM "clim-macros" - ("transformations" #+CLIM-conditions (:load-before-compile "condpat")) + "transformations" "regions" "region-arithmetic" "extended-regions" @@ -206,7 +200,6 @@ "stream-defprotocols" "defresource" "temp-strings" - #+(and MCL CCL-2) "coral-defs" "clim-defs" ;; Definitions and protocols diff --git a/test/test-driver.lisp b/test/test-driver.lisp index e680312a90408596d39f2cd33216a23a21837445..963043870824d5485c642e7822bf07e8bcf11673 100644 --- a/test/test-driver.lisp +++ b/test/test-driver.lisp @@ -843,7 +843,7 @@ ;; How can we wait for a frame to be created. Grab hold of it and then ;; run some commands on it. -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (require :prof)) (defun do-frame-test-with-profiling (test &key (type :time) prefix) diff --git a/test/test-suite.lisp b/test/test-suite.lisp index 8002cbf8ec63f32f1933426aef527934e5ad845e..8e41d355574c5335b41e03f6d1b77f3a44750419 100644 --- a/test/test-suite.lisp +++ b/test/test-suite.lisp @@ -2708,7 +2708,7 @@ Luke Luck licks the lakes Luke's duck likes.")) ;; First collect the data files ;; DATA is ((short-name long-name results flavors-p)...) (let ((data - (clim-utils:with-standard-io-environment + (with-standard-io-syntax (let ((data nil) (*package* (or (find-package :common-lisp-user) (error "Package COMMON-LISP-USER not found")))) diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp index 9af87cb42ca0ea770a5a64d2ea9686ff1a4825ba..79889a9b163de1f5a837ab1bdf9fd76bb5c5bdff 100644 --- a/tk-silica/xt-frames.lisp +++ b/tk-silica/xt-frames.lisp @@ -103,7 +103,6 @@ default-item ;; bug12221/spr25238 ) - (declare (values value chosen-item gesture)) ;; let's degrade to CLIM 1 style menus if we need scroll-bars (if scroll-bars (call-next-method) diff --git a/tk/convenience.lisp b/tk/convenience.lisp index 276598955ac85890aa80bb0c515ee2238c2931e7..ec47011404b5f39eb8a4c30eff7a6c074ec25921 100644 --- a/tk/convenience.lisp +++ b/tk/convenience.lisp @@ -5,13 +5,13 @@ (in-package :tk) #-(version>= 6 1) -(eval-when (eval compile) +(eval-when (:execute :compile-toplevel) (defmacro define-convenience-class (class superclasses entry-point) (let ((c-function-name (intern (substitute #\_ #\- (lispify-tk-name entry-point :package nil))))) `(progn - (eval-when (eval compile) + (eval-when (:execute :compile-toplevel) (defforeign ',c-function-name :entry-point (ff:convert-foreign-name ,entry-point) :call-direct t @@ -39,13 +39,13 @@ (xt_manage_child o)) o)))))))) #+(version>= 6 1) -(eval-when (eval compile) +(eval-when (:execute :compile-toplevel) (defmacro define-convenience-class (class superclasses entry-point) (let ((c-function-name (intern (substitute #\_ #\- (lispify-tk-name entry-point :package nil))))) `(progn - (eval-when (eval compile) + (eval-when (:execute :compile-toplevel) (def-foreign-call (,c-function-name ,entry-point) ((w :foreign-address) (x :foreign-address) (y :foreign-address) (z :int fixnum)) :returning :foreign-address diff --git a/tk/gcontext.lisp b/tk/gcontext.lisp index dc2023463333f2839c890640a5810485c7ab71c5..4db0aa01463771b50476784cebc2c02af5eb8bf1 100644 --- a/tk/gcontext.lisp +++ b/tk/gcontext.lisp @@ -4,7 +4,7 @@ (in-package :tk) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) #+ignore (defconstant *gcontext-components* '((function :int) @@ -41,7 +41,7 @@ (defun make-xgcvalues () (clim-utils::allocate-cstruct 'x11::xgcvalues :initialize t)) -(eval-when (compile eval) +(eval-when (:compile-toplevel :execute) #+ignore (defun gcontext-component-to-slot-definition (x) (destructuring-bind diff --git a/tk/load-xm.lisp b/tk/load-xm.lisp index b7f1a1747121ddcedf740cd4b031754f9e8021d8..cab334f1ba1a17def218d6ec48c5442322c6825e 100644 --- a/tk/load-xm.lisp +++ b/tk/load-xm.lisp @@ -4,7 +4,7 @@ (cl:in-package #:user) -(eval-when (compile eval load) +(eval-when (:compile-toplevel :execute :load-toplevel) (require :climg)) (defvar sys::*clim-library-search-path* '("/usr/X11/lib/" "/usr/X11R6/lib/" "/usr/local/lib/" diff --git a/tk/xlib.lisp b/tk/xlib.lisp index 1108bb3825e4aca7e0b62bbb811147e0678b675d..9c7de55d50f8acb569833ffb302e1e29fe8cbf81 100644 --- a/tk/xlib.lisp +++ b/tk/xlib.lisp @@ -30,7 +30,7 @@ (defclass window (drawable) ((plist :accessor window-property-list :initform nil))) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defconstant *window-set-attributes-bit-mask* '(background-pixmap background-pixel border-pixmap border-pixel bit-gravity win-gravity backing-store backing-planes backing-pixel @@ -46,7 +46,7 @@ (defun make-xwindowattributes () (clim-utils::allocate-cstruct 'x11::xwindowattributes :initialize t)) -(eval-when (compile eval) +(eval-when (:compile-toplevel :execute) (defmacro define-window-reader (name &optional decoder &rest args) `(defmethod ,(intern (format nil "~A-~A" 'window name)) ((window window)) ,(let ((body @@ -292,7 +292,7 @@ (setq *x-io-error-handler-address* (register-foreign-callable 'x-io-error-handler))))) -(eval-when (load) +(eval-when (:load-toplevel) (setup-error-handlers)) (define-condition x-colormap-full (serious-condition) ()) diff --git a/tk/xm-widgets.lisp b/tk/xm-widgets.lisp index 7884689b3362ce4db7c46c5cabd48caccb3fc72c..e31d812e607e8c1062e00fb838963049bd9609ef 100644 --- a/tk/xm-widgets.lisp +++ b/tk/xm-widgets.lisp @@ -110,7 +110,7 @@ (defvar *empty-compound-string* nil) - (eval-when (compile) (declaim (special *font-list-tags*))) + (eval-when (:compile-toplevel) (declaim (special *font-list-tags*))) (defun partition-compound-string (s f &key (start 0) (end (length s))) (unless (eql (length s) 0) diff --git a/utils/autoconstructor.lisp b/utils/autoconstructor.lisp index 2a4897789922b5c53b98add3df66861fa5fed146..4e9967736826b355c6bd05c703892caea974353d 100644 --- a/utils/autoconstructor.lisp +++ b/utils/autoconstructor.lisp @@ -93,7 +93,7 @@ ;; the compile time environment that a function with this name and ;; this argument list has been defined. The portable way to do this ;; is with defun. - (eval-when (compile load eval) + (eval-when (:compile-toplevel :load-toplevel :execute) (proclaim '(notinline ,name)) (proclaim '(function ,name))) #+++ignore ;; See if FUNCTION proclamation is sufficient. diff --git a/utils/base-designs.lisp b/utils/base-designs.lisp index 5928553df40357cfedd208bc1930c0c125f1a9c1..126d7b796612c94660cb4226cd233d3eed4b49a1 100644 --- a/utils/base-designs.lisp +++ b/utils/base-designs.lisp @@ -171,7 +171,7 @@ ;;; Foreground and background (indirect) inks -(defconstant +foreground-ink+ (make-instance 'design)) +(defparameter +foreground-ink+ (make-instance 'design)) (defmethod make-load-form ((design (eql (symbol-value '+foreground-ink+))) #-aclpc &optional #-aclpc environment) @@ -180,7 +180,7 @@ #+aclpc '(symbol-value '+foreground-ink+)) -(defconstant +background-ink+ (make-instance 'design)) +(defparameter +background-ink+ (make-instance 'design)) (defmethod make-load-form ((design (eql (symbol-value '+background-ink+))) #-aclpc &optional #-aclpc environment) diff --git a/utils/cl-stream-functions.lisp b/utils/cl-stream-functions.lisp index 19a0993ff54e40c42611a13e998b4675b2303030..725358a86b3f8b885625b6507790bb29d2bf1dd4 100644 --- a/utils/cl-stream-functions.lisp +++ b/utils/cl-stream-functions.lisp @@ -47,7 +47,7 @@ (when (eq (first optional-args) '&optional) (pop optional-args)) `(define-group ,name write-forwarding-cl-output-stream-function - (eval-when (compile load eval) (proclaim '(inline ,name))) + (eval-when (:compile-toplevel :load-toplevel :execute) (proclaim '(inline ,name))) (defun ,name (,@required-args &optional stream ,@optional-args) (cond ((null stream) (setq stream *standard-output*)) ((eq stream t) (setq stream *terminal-io*))) @@ -96,7 +96,7 @@ (when (member (first (last method-lambda-list)) lambda-list-keywords) (setf method-lambda-list (butlast method-lambda-list))) `(define-group ,name write-forwarding-cl-input-stream-function - (eval-when (compile load eval) (proclaim '(inline ,name))) + (eval-when (:compile-toplevel :load-toplevel :execute) (proclaim '(inline ,name))) ,(if eof (let ((args `(eof-error-p eof-value ,@(and (not (eq eof :no-recursive)) '(recursive-p))))) diff --git a/utils/cl-streams.lisp b/utils/cl-streams.lisp index 24cc0feb520fcf3992e3d6f3decf78cf0e2b44a1..dda1d5c6db5903067d9ce28c4a4a9899a08f147f 100644 --- a/utils/cl-streams.lisp +++ b/utils/cl-streams.lisp @@ -98,8 +98,8 @@ (progn (defmacro write-forwarding-cl-output-stream-function (name args &key #+Genera message) - (let* ((cl-name (find-symbol (symbol-name name) (find-package :lisp))) - (method-name (intern (lisp:format nil "~A-~A" 'stream (symbol-name name)))) + (let* ((cl-name (find-symbol (symbol-name name) (find-package :cl))) + (method-name (intern (cl:format nil "~A-~A" 'stream (symbol-name name)))) (optional-args (or (member '&optional args) (member '&key args))) (required-args (ldiff args optional-args)) (optional-parameters (mapcan #'(lambda (arg) @@ -126,7 +126,7 @@ ;; Shadow the Common Lisp function with one that calls the generic function, ;; except in Genera and Cloe where the Common Lisp function will work #-(or Genera (and MCL CCL-2)) - (eval-when (compile load eval) (proclaim '(inline ,name))) + (eval-when (:compile-toplevel :load-toplevel :execute) (proclaim '(inline ,name))) #-(or Genera (and MCL CCL-2)) (defun ,name (,@required-args &optional stream ,@optional-args) (case stream @@ -172,7 +172,7 @@ ;;; -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defun order-preserving-set-difference (set-one set-two) #-(and MCL CCL-2) (set-difference set-one set-two) #+(and MCL CCL-2) (nreverse (set-difference set-one set-two))) @@ -182,8 +182,8 @@ &key eof #+Genera message additional-arguments) - (let* ((cl-name (find-symbol (symbol-name name) (find-package :lisp))) - (method-name (intern (lisp:format nil "~A-~A" 'stream (symbol-name name)))) + (let* ((cl-name (find-symbol (symbol-name name) (find-package :cl))) + (method-name (intern (cl:format nil "~A-~A" 'stream (symbol-name name)))) (args (mapcar #'(lambda (var) (if (atom var) var (first var))) (order-preserving-set-difference lambda-list lambda-list-keywords))) (stream-args (remove 'stream args)) @@ -196,7 +196,7 @@ ;; Shadow the Common Lisp function with one that calls the generic function, ;; except in Genera or Cloe where the Common Lisp function will work #-(or Genera (and MCL CCL-2)) - (eval-when (compile load eval) (proclaim '(inline ,name))) + (eval-when (:compile-toplevel :load-toplevel :execute) (proclaim '(inline ,name))) #-(or Genera (and MCL CCL-2)) ,(if eof (let ((args `(eof-error-p eof-value ,@(and (not (eq eof :no-recursive)) @@ -264,10 +264,10 @@ (cond ((streamp stream) ;; this isn't going to quite work for ~&, ;; but it's better than nothing. - (write-string (apply #'lisp:format nil format-control format-args) stream) + (write-string (apply #'cl:format nil format-control format-args) stream) nil) (t - (apply #'lisp:format stream format-control format-args)))) + (apply #'cl:format stream format-control format-args)))) ) ;; #-Cloe-Runtime diff --git a/utils/clim-macros.lisp b/utils/clim-macros.lisp index f349eb11c4e0a76f0e45d1d7a42131962dc17db9..e18ebd80e9eeeb5e7b0fe2493cf6223e8a563f6b 100644 --- a/utils/clim-macros.lisp +++ b/utils/clim-macros.lisp @@ -50,7 +50,7 @@ (invoke-with-clipping-region ,stream #'with-clipping-region-body ,region))) (defmacro with-drawing-options ((medium &rest options) &body body) - (declare (arglist (medium + #+Genera(declare (arglist (medium &key ink clipping-region transformation line-style line-unit line-thickness line-dashes line-joint-shape line-cap-shape diff --git a/utils/clos-patches.lisp b/utils/clos-patches.lisp index 312bcd642f010626b954fa753f4cc00e6da1a2e2..0d439b25114742af23d4513b87b2a6a6cf02adad 100644 --- a/utils/clos-patches.lisp +++ b/utils/clos-patches.lisp @@ -35,7 +35,7 @@ sys::*compile-file-environment*)) #+(and allegro never-in-a-million-years) -(eval-when (compile) +(eval-when (:compile-toplevel) (warn "~S hacked for lack of environment support in 4.1" 'compile-file-environment-p)) #+(or (and MCL CCL-2) Clozure) @@ -45,6 +45,12 @@ #-Clozure t (ccl:augment-environment environment))) +#+ (or sbcl ccl) +(defun-inline compile-file-environment-p (environment) + (declare (ignore environment)) + ;; FIXME this shouldn't even need to exist, I think. -- jacek.zlydach, 2017-05-06 + nil) + #+(and allegro (not (version>= 4 1))) (defgeneric make-load-form (object)) @@ -84,7 +90,7 @@ ;;; by load-reference-to-presentation-type-class isn't sufficient without this, ;;; because a MAKE-LOAD-FORM form for a presentatation type class could be evaluated ;;; before a superclass has been defined. -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (setq compiler::.random-forms-max. 0)) @@ -93,7 +99,6 @@ #+(and allegro (not (version>= 4 1))) (lisp:defun slot-value-alist (body) - (declare (values real-body alist)) (let ((alist nil)) (do* ((real-body body (cdr real-body)) (form (car real-body) (car real-body))) diff --git a/utils/clos.lisp b/utils/clos.lisp index f7fda0b541a4e58e6a57bb0a6a5f78fc7d504398..6fb70d5f3cdeb833ce4fa00245e58653ca930aa3 100644 --- a/utils/clos.lisp +++ b/utils/clos.lisp @@ -11,7 +11,7 @@ (in-package :clim-utils) #+Allegro-v4.0-constructors -(eval-when (compile eval load) (require :constructor)) +(eval-when (:compile-toplevel :execute :load-toplevel) (require :constructor)) ;;; ---------------- ;;; Constructors @@ -36,7 +36,7 @@ (defmacro define-constructor (name class lambda-list &body initargs) (let ((rest-arg (member '&rest lambda-list))) `(progn - (eval-when (compile load eval) (proclaim '(inline ,name))) + (eval-when (:compile-toplevel :load-toplevel :execute) (proclaim '(inline ,name))) (defun ,name ,lambda-list ,@(when rest-arg `((declare (dynamic-extent ,(second rest-arg))))) @@ -106,7 +106,7 @@ ;(defvar *dynamic-classes* (make-hash-table :test #'equal)) ; -;(eval-when (compile load eval) (proclaim '(inline %make-standard-class))) +;(eval-when (:compile-toplevel :load-toplevel :execute) (proclaim '(inline %make-standard-class))) ;(defun %make-standard-class (name supers) ; ; #+Lucid @@ -224,7 +224,6 @@ (values `(setf ,accessor-name) t)) (defun make-setf*-function-name (accessor-name) - (declare (values setf-function-name defsetf-done-p)) (let ((writer (get accessor-name 'setf-function-name)) (old-p nil)) (when writer @@ -276,8 +275,6 @@ ;; For example, (DEFMETHOD* (SETF CURSOR-POSITION) (NX NY (CURSOR T)) ...) ;; Then (SETF (CURSOR-POSITION cursor) (VALUES nx ny)) (defmacro defmethod* (name &body quals-lambda-list-and-body) - (declare (arglist name [qualifiers]* lambda-list &body body)) - #+Genera (declare (zwei:indentation . zwei:indent-for-clos-defmethod)) (assert (and (listp name) (eq (first name) 'setf) (null (cddr name))) () "Syntax error in ~S: This only works on ~S methods" 'defmethod* 'setf) (let (qualifiers real-arglist body accessor-arg diff --git a/utils/condpat.lisp b/utils/condpat.lisp deleted file mode 100644 index 3d8956d89685b8a5a27482dd70984d1f75da4d99..0000000000000000000000000000000000000000 --- a/utils/condpat.lisp +++ /dev/null @@ -1,50 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; See the file LICENSE for the full license governing this code. -;; - -(in-package :clim-utils) - -;;;"Copyright (c) 1990 International Lisp Associates. All rights reserved." - -;;; Lucid and Franz have an old syntax for defining conditions. We define -;;; a macro here which supports [a subset of] the ANSI syntax and which -;;; forwards to their syntax. Then we can just write DEFINE-CONDITION -;;; with [relative] impunity. I suppose there is some question about -;;; whether this macro should be in all implementations so that we can -;;; detect the non-portable cases more easily. I'll think about it. -(defmacro define-condition (name parent-types &optional slots &rest options) - (let ((readers nil) - (real-slots slots) - (trampoline-define-condition - (intern (symbol-name 'define-condition) - (find-package #+Lucid :lucid-common-lisp - #-Lucid :conditions))) - (conc-name (format nil "~A-~A-" name 'accessor-for))) - (unless parent-types - (setq parent-types '(condition))) - (unless (keywordp (first slots)) - (setq real-slots nil) - (dolist (slot slots) - (let ((reader (getf (rest slot) ':reader))) - (when reader - (let ((trampoline (intern (format nil "~A~A" conc-name (first slot)) - (symbol-package name)))) - ;; Not likely to be EQL, but can causes an infinite loop - ;; in Lucid if it is... - (unless (eq trampoline reader) - (push `(eval-when (compile load eval) - (proclaim '(inline ,reader))) readers) - (push `(defun ,reader (condition) - (,trampoline condition)) readers))))) - (let ((initarg (getf (rest slot) ':initarg))) - (unless (eq initarg (intern (symbol-name (first slot)) *keyword-package*)) - (error "We can't support initargs to DEFINE-CONDITION that ~ - don't match the slot name."))) - (let ((initform (getf (rest slot) ':initform))) - (if initform - (push `(,(first slot) ,initform) real-slots) - (push `(,(first slot)) real-slots))))) - `(progn (,trampoline-define-condition ,name ,parent-types ,(nreverse real-slots) - (:conc-name ,conc-name) - ,@options) - ,@(nreverse readers)))) diff --git a/utils/defpackage.lisp b/utils/defpackage.lisp index 70054898dafc80bc5f27ee7799f0be8b345dd64c..ecdbbeb59f749206b0712a53da7815a574b7cfd1 100644 --- a/utils/defpackage.lisp +++ b/utils/defpackage.lisp @@ -12,7 +12,7 @@ #+(or Allegro Lucid) (defpackage :clim-lisp) #-(or Allegro Lucid) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package :clim-lisp) (make-package "CLIM-LISP" :use '("COMMON-LISP")))) @@ -61,7 +61,7 @@ :key #'first))) (when bad-option (warn "Unknown ~S option: ~S" 'defpackage (first bad-option)))) - `(eval-when (compile load eval) + `(eval-when (:compile-toplevel :load-toplevel :execute) (let ((,package-var (make-package-aux ',package-name :use nil ,@(when nicknames `(:nicknames ',(mapcar #'string nicknames))) diff --git a/utils/defun-utilities.lisp b/utils/defun-utilities.lisp index 2663b02ada8672c4e83a60d2b337c0fbb8acfeb2..2109daa8c4a5d8c227c010801bd969924c1f7d57 100644 --- a/utils/defun-utilities.lisp +++ b/utils/defun-utilities.lisp @@ -6,18 +6,6 @@ ;;;"Copyright (c) 1991 International Lisp Associates. All rights reserved." -;;; Useful proclamations, very early on - -;; not part of ANSI CL, but they're nice to have around -#+(or (and MCL CCL-2) allegro Minima Clozure SBCL) -(eval-when (compile load eval) - (proclaim '(declaration values)) - (proclaim '(declaration arglist))) - -#+aclpc -(eval-when (compile load eval) - (proclaim '(declaration arglist))) - ;;; Moved here from DEFUN. DEFUN now only contains the portable implementation ;;; of the DYNAMIC-EXTENT declaration, and so is not loaded into Lisps which ;;; implement that declaration. @@ -27,7 +15,6 @@ (defparameter *declarations-may-be-exposed-by-macro-expansion* nil) (cl:defun extract-declarations (body &optional environment) - (declare (values documentation declarations body)) (let ((declarations nil) (documentation nil)) (block process-declarations @@ -88,7 +75,7 @@ ;;;; don't use define-group, because it does a excl::record-source-file, ;;;; which will be also done by defun! This causes duplicate definition in ;;;; file warnings. - (eval-when (compile load eval) (proclaim '(inline ,name))) + (eval-when (:compile-toplevel :load-toplevel :execute) (proclaim '(inline ,name))) (defun ,name ,lambda-list ,@body))) @@ -114,7 +101,7 @@ `(let ((,native-string-var ,string-exp)) ,@body)) - (eval-when (compile load eval) (export 'with-native-string)) + (eval-when (:compile-toplevel :load-toplevel :execute) (export 'with-native-string)) (defun mb-to-string (mb-vector) (let* ((lgth (length mb-vector)) @@ -122,4 +109,4 @@ (dotimes (i lgth string) (setf (schar string i) (code-char (aref mb-vector i)))))) - (eval-when (compile load eval) (export 'mb-to-string))) + (eval-when (:compile-toplevel :load-toplevel :execute) (export 'mb-to-string))) diff --git a/utils/defun.lisp b/utils/defun.lisp index f03320da04454673bf28f04b6fb8693575b094cf..52422b4d167989cfc7a1b2cdf3550657c54b872c 100644 --- a/utils/defun.lisp +++ b/utils/defun.lisp @@ -57,7 +57,6 @@ ;;; The heart of function body processing: (lisp:defun decode-function (lambda-list body environment &key clos-method-p function-name downward-p generic-function-p) - (declare (values new-lambda-list new-body)) #-Genera (declare (ignore function-name)) (let* ((ignores nil) (new-lambda-list nil) @@ -220,7 +219,7 @@ :downward-p ,downward-p) ,@body)) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (lisp:defun lintern (symbol) (intern (symbol-name symbol) #+Genera :future-common-lisp #-Genera :lisp)) ) @@ -357,7 +356,7 @@ #-PCL `(cl:method ,function-name ,specifier-list ,@qualifiers))) #+(and allegro (not acl86win32) (version>= 4 1)) -(eval-when (compile load eval) (require :scm)) +(eval-when (:compile-toplevel :load-toplevel :execute) (require :scm)) #+(and allegro (not acl86win32) (version>= 4 1)) (excl::define-simple-parser defmethod scm::defmethod-parser) diff --git a/utils/designs.lisp b/utils/designs.lisp index 42c7d577f2daa54b9de8a08c109d73b987d4d731..ba6e29a29d78daa0fc80afdfb20787c0f31a7c1f 100644 --- a/utils/designs.lisp +++ b/utils/designs.lisp @@ -33,8 +33,8 @@ ;; Black and white are the same everywhere -(defconstant +black+ (make-gray-color-1 0f0)) -(defconstant +white+ (make-gray-color-1 1f0)) +(defparameter +black+ (make-gray-color-1 0f0)) +(defparameter +white+ (make-gray-color-1 1f0)) ;;; Gray colors @@ -115,8 +115,8 @@ ;;; Color constants (defmacro define-primary-color (color-name r g b) - `(defconstant ,color-name - (make-rgb-color-1 (float ,r 0f0) (float ,g 0f0) (float ,b 0f0)))) + `(defparameter ,color-name + (make-rgb-color-1 (float ,r 0f0) (float ,g 0f0) (float ,b 0f0)))) ;; The primary colors, constant across all platforms (define-primary-color +red+ 1 0 0) @@ -331,7 +331,7 @@ Try closing color-intensive applications such as Netscape, or try~%~ setting the colormap X resource to yes to get a private colormap,~%~ then restart your application.") -(eval-when (#-allegro compile load eval) +(eval-when (#-allegro :compile-toplevel :load-toplevel :execute) (define-condition palette-full (error) ((palette :initarg :palette :reader palette-full-palette) (color :initarg :color :reader palette-full-color)) @@ -562,7 +562,7 @@ then restart your application.") (with-slots (design1 design2) design (cl:format stream "~A and ~A" design1 design2)))) -(defconstant +flipping-ink+ (make-flipping-ink-1 +foreground-ink+ +background-ink+)) +(defparameter +flipping-ink+ (make-flipping-ink-1 +foreground-ink+ +background-ink+)) (defmethod make-flipping-ink (design1 design2) (cond ((eq design1 design2) @@ -712,7 +712,6 @@ then restart your application.") ;;; This could be done with methods, but there is very little point to that #-(or aclpc acl86win32) (defun decode-tile-as-stipple (rectangular-tile) - (declare (values array width height)) (multiple-value-bind (pattern width height) (decode-rectangular-tile rectangular-tile) (when (typep pattern 'pattern) @@ -727,7 +726,6 @@ then restart your application.") #+(or aclpc acl86win32) (defun decode-tile-as-stipple (rectangular-tile) - (declare (values array width height)) (multiple-value-bind (pattern width height) (decode-rectangular-tile rectangular-tile) (declare (ignore width height)) diff --git a/utils/excl-verification.lisp b/utils/excl-verification.lisp index 5de85be10991fd74e2bc9e7badaa70dfb9061a2a..3e147bfdbdcbfe8ce4d6b29e86bc7ffa0c66b04c 100644 --- a/utils/excl-verification.lisp +++ b/utils/excl-verification.lisp @@ -26,11 +26,11 @@ v5: Fix postscript, GC cursor, Windows text field bugs, speed up (in-package :sys) #+ignore -(eval-when (compile) +(eval-when (:compile-toplevel) (assert (member excl::*current-case-mode* '(:case-insensitive-lower :case-insensitive-upper)))) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :clim *features*) (pushnew :clim-2 *features*) (pushnew :clim-2.1 *features*) diff --git a/utils/last.lisp b/utils/last.lisp index 42b9a8cd05bb374e9a8f7dab56a29b2988d447b3..7e4b021dfe4a5de866a98a4b8930d86ccb7f78e4 100644 --- a/utils/last.lisp +++ b/utils/last.lisp @@ -5,24 +5,6 @@ (in-package :system) -;;; This is, perhaps, a temporary hack to get the EUC stuff loaded at -;;; a non-bad time. -;; -;; This is no longer needed, since we're using native-to-* interface now -;; The euc module may be autoloaded due to process-code usage, but the -;; autoload no longer produces a mesage at inopportune times. -#+ignore -(eval-when (:load-toplevel :execute) - (require :euc) - (find-external-format :euc)) - -#-(version>= 5 0 pre-final 16) -(load-patches "patch" "sys:;update-clim;*.fasl") -#+(and (version>= 5 0 pre-final 16) - (not clim-dont-load-patches)) -(load-patches :product #.*patch-product-code-clim* - :version #.excl::*cl-patch-version-char*) - (provide #+mswindows :climnt #-mswindows diff --git a/utils/lisp-package-fixups.lisp b/utils/lisp-package-fixups.lisp index 26475402b889afdc3b70e3888e052ef93339dfa2..ce36809d33564f1d87aba698fafd186b14e946b1 100644 --- a/utils/lisp-package-fixups.lisp +++ b/utils/lisp-package-fixups.lisp @@ -42,7 +42,7 @@ ;;; I left a copy of this form in defsystem.lisp so that defsystem ;;; can be compiled (it has lots of references to LISP: symbols). #+(and ANSI-90 (not Allegro)) -(eval-when (eval compile load) +(eval-when (:execute :compile-toplevel :load-toplevel) (flet ((fix-package (pack-name add-name) (setq add-name (string add-name)) (let ((pack (find-package pack-name))) @@ -65,7 +65,7 @@ ;;; is really to add the ANSI names COMMON-LISP and COMMON-LISP-USER ;;; to the LISP and USER packages found in non-ANSI Lisps. #-(or Allegro aclpc) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (flet ((clean-up-package (old-package-name primary-name required-nicknames) (let* ((package (or (find-package old-package-name) (find-package primary-name))) diff --git a/utils/lisp-utilities.lisp b/utils/lisp-utilities.lisp index ad6f661b09c3f77824296579d329ff91a3301cc9..f5bbff18dd3e1d353e082974d0686dd981edf1fd 100644 --- a/utils/lisp-utilities.lisp +++ b/utils/lisp-utilities.lisp @@ -48,7 +48,7 @@ (reverse ,run-time-vals)) ,wrapped-body))))) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defun decode-once-only-arguments (variables) (let ((vars nil) (env nil) @@ -316,48 +316,6 @@ (or (char-equal char #\Space) (eql char #\Tab)))) -;;; Make sure we don't get screwed by environments like Coral's that -;;; have *print-case* set to :downcase by default. -#+(or (not ansi-90) aclpc) -(defvar *standard-io-environment-val-cache* nil) - -#+(or (not ansi-90) aclpc) -(defun standard-io-environment-vars-and-vals () - (unless *standard-io-environment-val-cache* - (setq *standard-io-environment-val-cache* - (list 10 ;*read-base* - (copy-readtable nil) ;*readtable* - (find-package :user) ;*package* - t ;*print-escape* - nil ;*print-pretty* - nil ;*print-radix* - 10 ;*print-base* - nil ;*print-circle* - nil ;*print-level* - nil ;*print-length* - :upcase ;*print-case* - t ;*print-gensym* - t ;*print-array* - nil))) ;*read-suppress* - (values - '(*read-base* *readtable* *package* *print-escape* *print-pretty* - *print-radix* *print-base* *print-circle* *print-level* *print-length* - *print-case* *print-gensym* *print-array* *read-suppress*) - *standard-io-environment-val-cache*)) - -(defmacro with-standard-io-environment (&body body) - #+(or (not ansi-90) aclpc) - `(multiple-value-bind (vars vals) - (standard-io-environment-vars-and-vals) - (progv vars vals - ,@body)) - #-(or (not ansi-90) aclpc) - `(with-standard-io-syntax ,@body)) - -#+(and (or (not ansi-90) aclpc) (not Clozure) (not Genera)) -(defmacro with-standard-io-syntax (&body body) - `(with-standard-io-environment ,@body)) - ;; Define this so we don't have to deal with stupid warnings about ;; the iteration variable being used, or not used, or what not (defmacro repeat (n &body body) @@ -388,7 +346,7 @@ (let ((aborted-variable (gensymbol 'aborted-p)) (temporary-stream-variable (gensymbol 'stream))) (multiple-value-bind (documentation declarations actual-body) - (extract-declarations body env) + (extract-declarations body env) ;;; FIXME this here breaks file compilation on SBCL; should we compile this macro anyway? -- jacek.zlydach, 2017-05-06 (declare (ignore documentation)) `(let (,temporary-stream-variable (,aborted-variable t)) @@ -404,16 +362,10 @@ (defun follow-synonym-stream (stream) #+Genera (si:follow-syn-stream stream) - #+(and ansi-90 (not Genera)) (typecase stream - (synonym-stream - (symbol-value (synonym-stream-symbol stream))) - (t stream)) - #-(or Genera ansi-90) stream) - -#-(or Genera ansi-90) -(eval-when (compile) - (warn "You haven't defined ~S for this implementation. A stub has been provided." - 'follow-synonym-stream)) + #-Genera (typecase stream + (synonym-stream + (symbol-value (synonym-stream-symbol stream))) + (t stream))) ;;; Interning. There are three places where the package matters here: ;;; the current package, the package that is current when FORMAT is @@ -430,7 +382,7 @@ ;; this argument order is unfortunate. (declare (dynamic-extent format-args)) (intern (let ((pkg *package*)) - (with-standard-io-environment + (with-standard-io-syntax (let ((*package* pkg)) (apply #'cl:format () format-string (mapcar #'(lambda (x) @@ -447,7 +399,7 @@ (defvar *gensymbol* 0) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defun gensymbol (&rest parts) (declare (dynamic-extent parts)) (when (null parts) (setf parts '(gensymbol))) @@ -555,11 +507,11 @@ (when ,condition-value (setf ,@unwind-forms))))))) #-(and ansi-90 (not allegro) (not Symbolics)) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (proclaim '(declaration non-dynamic-extent))) #+aclpc -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (proclaim '(declaration non-dynamic-extent ignorable))) #+(and ansi-90 (not allegro) (not aclpc) (not Symbolics)) @@ -914,7 +866,6 @@ (defun canonicalize-and-match-lambda-lists (canonical-order user-specified &optional allow-user-keys) - (declare (values lambda-list ignores)) (check-type canonical-order list) (check-type user-specified list) (let* ((new-lambda-list nil) @@ -972,7 +923,7 @@ (let ((function-name (make-symbol (cl:format nil "~A-~A-~A" symbol indicator 'property)))) `(progn (defun ,function-name ,lambda-list ,@body) - (eval-when (load eval) (setf (get ',symbol ',indicator) #',function-name))))) + (eval-when (:load-toplevel :execute) (setf (get ',symbol ',indicator) #',function-name))))) (defmacro do-delimited-substrings (((string &key (start 0) end) (start-index-var end-index-var &optional char-var)) @@ -1125,12 +1076,6 @@ ,arglist))))))))) -#-(or Genera Clozure (and ansi-90 (not (and allegro (not (version>= 4 1)))))) -(defmacro define-compiler-macro (name lambda-list &body body &environment env) - env - #+Allegro `(excl::defcmacro ,name ,lambda-list ,@body) - #-(or Genera allegro) (progn name lambda-list body env nil)) ;Suppress compiler warnings. - #+aclpc (defmacro define-compiler-macro (name lambda-list &body body &environment env) env @@ -1145,52 +1090,6 @@ (mapc #'compiler:function-defined (cdr decl))) -#-(or Genera ansi-90) -(defmacro print-unreadable-object ((object stream &key type identity) &body body) - `(flet ((print-unreadable-object-body () ,@body)) - (declare (dynamic-extent #'print-unreadable-object-body)) - (print-unreadable-object-1 ,object ,stream ,type ,identity - #'print-unreadable-object-body - ',(not (null body))))) - -#-(or Genera ansi-90) -;;; EXTRA-SPACE-REQUIRED is optional because old compiled code didn't always supply it. -(defun print-unreadable-object-1 (object stream type identity continuation - &optional (extra-space-required t)) - (write-string "#<" stream) - ;; wish TYPE-OF worked in PCL - (when type (cl:format stream "~S " (class-name (class-of object)))) - (funcall continuation) - (when identity - (when extra-space-required (write-char #\space stream)) - (#+PCL pcl::printing-random-thing-internal ;; I assume PCL gets this right. -- rsl - #-PCL print-unreadable-object-identity - object stream)) - (write-string ">" stream)) - -#-(or PCL Genera ansi-90) -(defun print-unreadable-object-identity (object stream) - #+Genera (format stream "~O" (sys:%pointer object)) - #+Allegro (format stream "@~X" (excl::pointer-to-address object)) - ;; Lucid prints its addresses out in Hex. - #+Lucid (format stream "~X" (sys:%pointer object)) - ;; Probably aren't any #+(and (not Genera) (not allegro) (not PCL) (not ansi-90)) - ;; implementations (actually, this is false: Lispworks). - #-(or Genera allegro Lucid) (declare (ignore object)) - #-(or Genera allegro Lucid) (cl:format stream "???")) - -#-(or Genera ansi-90 Lucid) -(defvar *print-readably* nil) - -#-(or Genera Lucid ansi-90) -(deftype real (&optional (min '*) (max '*)) - (labels ((convert (limit floatp) - (typecase limit - (number (if floatp (float limit 0f0) (rational limit))) - (list (map 'list #'convert limit)) - (otherwise limit)))) - `(or (float ,(convert min t) ,(convert max t)) - (rational ,(convert min nil) ,(convert max nil))))) #+Genera-Release-8-1 (defun realp (x) @@ -1366,7 +1265,7 @@ (find-class name errorp environment))) #+(and allegro never-never-and-never) -(eval-when (compile) +(eval-when (:compile-toplevel) (warn "~S hacked for lack of environment support in 4.1" 'find-class-that-works)) @@ -1408,7 +1307,6 @@ ;; The idiom for using this is ;; (MULTIPLE-VALUE-SETQ (VECTOR FP) (SIMPLE-VECTOR-PUSH-EXTEND ELEMENT VECTOR FP)). (defun simple-vector-push-extend (element vector fill-pointer &optional extension) - (declare (values vector fill-pointer)) (declare (type fixnum fill-pointer) (type simple-vector vector)) (let ((length (array-dimension vector 0))) @@ -1425,7 +1323,6 @@ (values vector fill-pointer))) (defun simple-vector-insert-element (element index vector fill-pointer &optional extension) - (declare (values vector fill-pointer)) (declare (type fixnum index fill-pointer) (type simple-vector vector)) (let ((length (array-dimension vector 0))) diff --git a/utils/lucid-stream-functions.lisp b/utils/lucid-stream-functions.lisp index 160afb29ddd60ba2b5311a6d2d03faaed03c234f..3c54fc9000e53b1024f064237a0b980b0601f541 100644 --- a/utils/lucid-stream-functions.lisp +++ b/utils/lucid-stream-functions.lisp @@ -15,7 +15,7 @@ ;;; just for development #+ignore -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defparameter sym-list '("PEEK-CHAR" "READ-BYTE" "READ-CHAR" "UNREAD-CHAR" "READ-CHAR-NO-HANG" "LISTEN" "READ-LINE" "CLEAR-INPUT" "WRITE-BYTE" "WRITE-CHAR" @@ -200,7 +200,7 @@ ;;; Higher level lisp printing functions. -(eval-when (load) +(eval-when (:load-toplevel) (let ((original-lucid-closure (or (getf (symbol-plist 'lisp:format) :original-lucid-closure) (setf (getf (symbol-plist 'lisp:format) :original-lucid-closure) diff --git a/utils/packages.lisp b/utils/packages.lisp index 1cba4dd7879cac59e3ad7638e1fc91dbd5b0b43c..ac9b4846feeb2e2fd246ce66e4d1999cc0149406 100644 --- a/utils/packages.lisp +++ b/utils/packages.lisp @@ -34,6 +34,8 @@ (:import-from :ccl #:atomic-incf #:atomic-decf #:class-prototype #:class-direct-superclasses #:class-precedence-list) + (:import-from :closer-mop :class-prototype) + (:export &allow-other-keys &aux @@ -2821,7 +2823,6 @@ with-stack-copy-of-list with-stack-list with-stack-list* - with-standard-io-environment with-warnings-for-definition writing-clauses @@ -3006,7 +3007,7 @@ modifier-key-index-name)) #+(or aclpc acl86win32) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (intern '#:non-dynamic-extent (find-package :clim-utils))) (defpackage clim-silica @@ -3032,7 +3033,7 @@ *ports* *standard-character-set* *all-character-sets* - #+(or aclpc acl86win32) *undefined-text-style* + #+(or aclpc acl86win32 (and)) *undefined-text-style* +highlighting-line-style+ activate-gadget-event add-sheet-callbacks @@ -3185,7 +3186,7 @@ port-set-sheet-grabbed-pointer-cursor port-terminated port-trace-thing - #+(or aclpc acl86win32) port-undefined-text-style + #+(or aclpc acl86win32 (and)) port-undefined-text-style process-event-locally pull-down-menu pull-down-menu-button diff --git a/utils/processes.lisp b/utils/processes.lisp index 85f57ab76656f0edbe2321e2b0575303295415bc..ac9bf024cff094a8d6b50b6213d99ea12ec722a2 100644 --- a/utils/processes.lisp +++ b/utils/processes.lisp @@ -11,7 +11,7 @@ ;;; Locks #+Allegro -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) ;;; (require :mdproc) (require :process)) @@ -231,7 +231,7 @@ (warn "No implementation of MAKE-PROCESS for this system.") )) -(eval-when (compile load eval) (proclaim '(inline processp))) +(eval-when (:compile-toplevel :load-toplevel :execute) (proclaim '(inline processp))) (defun processp (object) #+(and MCL CCL-2) (member object '(:user :event :interrupt)) #+Lucid (lcl:processp object) @@ -265,7 +265,7 @@ #+(and MCL CCL-2) (defvar *current-process* :user) -(eval-when (compile load eval) (proclaim '(inline current-process))) +(eval-when (:compile-toplevel :load-toplevel :execute) (proclaim '(inline current-process))) (defun current-process () #+Lucid lcl:*current-process* #+Allegro mp:*current-process* @@ -280,7 +280,7 @@ #+SBCL sb-thread:*current-thread* ) -(eval-when (compile load eval) (proclaim '(inline all-processes))) +(eval-when (:compile-toplevel :load-toplevel :execute) (proclaim '(inline all-processes))) (defun all-processes () #+Lucid lcl:*all-processes* #+Allegro mp:*all-processes* @@ -299,7 +299,7 @@ #-(or Lucid Genera) (all-processes) ) -(eval-when (compile load eval) (proclaim '(inline process-yield))) +(eval-when (:compile-toplevel :load-toplevel :execute) (proclaim '(inline process-yield))) (defun process-yield () #+Lucid (lcl:process-allow-schedule) #+Allegro (mp:process-allow-schedule) diff --git a/utils/protocols.lisp b/utils/protocols.lisp index 178f2f51069d256ae498c93e3d6e57e528dd84c7..f37f23129f17cb2c5fae5342c5d70babb238f2cd 100644 --- a/utils/protocols.lisp +++ b/utils/protocols.lisp @@ -28,7 +28,7 @@ (defmacro defprotocol (name supers &rest options) (declare (ignore supers options)) - `(eval-when (compile eval load) + `(eval-when (:compile-toplevel :execute :load-toplevel) (setf (find-protocol ',name) (make-instance 'protocol :name ',name)))) @@ -47,7 +47,7 @@ (defmacro defrole (class supers slots &rest options) (declare (ignore supers options)) - `(eval-when (compile eval load) + `(eval-when (:compile-toplevel :execute :load-toplevel) #+PCL (pcl::do-standard-defsetf ,@(mapcan #'(lambda (slot) @@ -106,7 +106,7 @@ (setq trampoline-extra-args (append (ldiff extra-args keyword-args) (unless (member '&rest extra-args) `(&rest keyword-arguments))))) - `(eval-when (compile eval load) + `(eval-when (:compile-toplevel :execute :load-toplevel) #-VDPCL ,@defgeneric ;PCL's defgeneric fails. (let* ((protocol (find-protocol ',protocol)) (operation diff --git a/utils/queue.lisp b/utils/queue.lisp index 64559e23acb8faca8e0e5cc385f19e05c49d38ac..a0a6a56f2cc8e124b2ff4f090934c5e70688f268 100644 --- a/utils/queue.lisp +++ b/utils/queue.lisp @@ -78,8 +78,7 @@ "return a list of all the queue contents" (copy-list (queue-head queue))) -(defgeneric map-over-queue (function queue) - (declare (dynamic-extent function))) +(defgeneric map-over-queue (function queue)) (defmethod map-over-queue (function (queue queue)) (declare (dynamic-extent function)) diff --git a/utils/regions.lisp b/utils/regions.lisp index 8af70ed39ce67b1c7eabbe4d17a3d5f9dae56288..709508498e7f9423cfac705ea0d4324e85243bef 100644 --- a/utils/regions.lisp +++ b/utils/regions.lisp @@ -11,8 +11,7 @@ (defgeneric transform-region (transformation region)) (defgeneric untransform-region (transformation region)) -(defgeneric point-position (point) - #-aclpc (declare (values x y))) +(defgeneric point-position (point)) (defgeneric point-x (point)) (defgeneric point-y (point)) @@ -24,8 +23,7 @@ (defgeneric region-set-function (region)) (defgeneric region-set-regions (region &key normalize)) -(defgeneric map-over-region-set-regions (function region &key normalize) - (declare (dynamic-extent function))) +(defgeneric map-over-region-set-regions (function region &key normalize)) (defgeneric region-union (region1 region2)) (defgeneric region-intersection (region1 region2)) @@ -33,10 +31,8 @@ (defgeneric polyline-closed (polyline)) (defgeneric polygon-points (polygon)) -(defgeneric map-over-polygon-coordinates (function polygon) - (declare (dynamic-extent function))) -(defgeneric map-over-polygon-segments (function polygon) - (declare (dynamic-extent function))) +(defgeneric map-over-polygon-coordinates (function polygon)) +(defgeneric map-over-polygon-segments (function polygon)) (defgeneric line-start-point (line)) (defgeneric line-end-point (line)) @@ -45,34 +41,27 @@ (defgeneric rectangle-min-point (rectangle)) (defgeneric rectangle-max-point (rectangle)) -(defgeneric rectangle-edges* (rectangle) - #-aclpc (declare (values min-x min-y max-x max-y))) +(defgeneric rectangle-edges* (rectangle)) (defgeneric rectangle-min-x (rectangle)) (defgeneric rectangle-min-y (rectangle)) (defgeneric rectangle-max-x (rectangle)) (defgeneric rectangle-max-y (rectangle)) (defgeneric rectangle-width (rectangle)) (defgeneric rectangle-height (rectangle)) -(defgeneric rectangle-size (rectangle) - #-aclpc (declare (values width height))) +(defgeneric rectangle-size (rectangle)) (defgeneric ellipse-center-point (ellipse)) (defgeneric ellipse-center-point* (ellipse)) -(defgeneric ellipse-radii (ellipse) - #-aclpc (declare (values radius-1-dx radius-1-dy radius-2-dx radius-2-dy))) +(defgeneric ellipse-radii (ellipse)) (defgeneric ellipse-start-angle (ellipse)) (defgeneric ellipse-end-angle (ellipse)) (defgeneric opacity-value (opacity)) -(defgeneric bounding-rectangle* (region) - #-aclpc (declare (values left top right bottom))) -(defgeneric bounding-rectangle-set-edges (region left top right bottom) - #-aclpc (declare (values region))) -(defgeneric bounding-rectangle-set-position (region x y) - #-aclpc (declare (values region))) -(defgeneric bounding-rectangle-set-size (region width height) - #-aclpc (declare (values region))) +(defgeneric bounding-rectangle* (region)) +(defgeneric bounding-rectangle-set-edges (region left top right bottom)) +(defgeneric bounding-rectangle-set-position (region x y)) +(defgeneric bounding-rectangle-set-size (region width height)) (defmacro define-symmetric-region-method (name (region1 region2) &body body) `(progn @@ -668,7 +657,6 @@ ;; Make a new bounding rectangle for the region, and shift its position by DX,DY, ;; and return the new rectangle. (defun bounding-rectangle-shift-position (region dx dy &optional reuse-rectangle) - (declare (values region)) (declare (type real dx dy)) (let ((rectangle (bounding-rectangle region reuse-rectangle)) (dx (coordinate dx)) @@ -721,7 +709,6 @@ (- bottom top))) (#-acl86win32 defun-inline #+acl86win32 defun bounding-rectangle-size (region) - (declare (values width height)) (with-bounding-rectangle* (left top right bottom) region #||(when (> right 10000) (setq *reg* region) @@ -756,7 +743,6 @@ (+ top (/ (- bottom top) 2))))) (defun bounding-rectangle-ltrb (region) - (declare (values left top right bottom)) (with-bounding-rectangle* (left top right bottom) region (values left top right bottom))) @@ -776,30 +762,30 @@ top)) (define-bounding-rectangle-setf top) -(defun-inline bounding-rectangle-right (region) - (with-bounding-rectangle-ltrb (left top right bottom) region +(defun-inline bounding-rectangle-right (region) + (with-bounding-rectangle-ltrb (left top right bottom) region (declare (ignore left top bottom)) right)) (define-bounding-rectangle-setf right) -(defun-inline bounding-rectangle-bottom (region) - (with-bounding-rectangle-ltrb (left top right bottom) region +(defun-inline bounding-rectangle-bottom (region) + (with-bounding-rectangle-ltrb (left top right bottom) region (declare (ignore left top right)) bottom)) (define-bounding-rectangle-setf bottom) (defgeneric* (setf bounding-rectangle*) (left top right bottom region)) -(defmethod* (setf bounding-rectangle*) - (left top right bottom (region standard-bounding-rectangle)) +(defmethod* (setf bounding-rectangle*) + (left top right bottom (region standard-bounding-rectangle)) (bounding-rectangle-set-edges region left top right bottom)) (defgeneric* (setf bounding-rectangle-position) (x y region)) -(defmethod* (setf bounding-rectangle-position) +(defmethod* (setf bounding-rectangle-position) (x y (region standard-bounding-rectangle)) (bounding-rectangle-set-position region x y)) (defgeneric* (setf bounding-rectangle-size) (width height region)) -(defmethod* (setf bounding-rectangle-size) +(defmethod* (setf bounding-rectangle-size) (width height (region standard-bounding-rectangle)) (bounding-rectangle-set-size region width height)) diff --git a/utils/transformations.lisp b/utils/transformations.lisp index f66719f3dccc35e71889a820c3202148659d68aa..85388c18f55bd187e30d8bf538b37048383af3c5 100644 --- a/utils/transformations.lisp +++ b/utils/transformations.lisp @@ -25,20 +25,14 @@ (defgeneric compose-scaling-with-transformation (transform mx my &optional origin)) (defgeneric compose-rotation-with-transformation (transform angle &optional origin)) -(defgeneric transform-position (transform x y) - #-aclpc (declare (values x y))) -(defgeneric untransform-position (transform x y) - #-aclpc (declare (values x y))) - -(defgeneric transform-distance (transform dx dy) - #-aclpc (declare (values dx dy))) -(defgeneric untransform-distance (transform dx dy) - #-aclpc (declare (values dx dy))) - -(defgeneric transform-rectangle* (transform x1 y1 x2 y2) - #-aclpc (declare (values x1 y1 x2 y2))) -(defgeneric untransform-rectangle* (transform x1 y1 x2 y2) - #-aclpc (declare (values x1 y1 x2 y2))) +(defgeneric transform-position (transform x y)) +(defgeneric untransform-position (transform x y)) + +(defgeneric transform-distance (transform dx dy)) +(defgeneric untransform-distance (transform dx dy)) + +(defgeneric transform-rectangle* (transform x1 y1 x2 y2)) +(defgeneric untransform-rectangle* (transform x1 y1 x2 y2)) ;;; Transformations diff --git a/utils/utilities.lisp b/utils/utilities.lisp index 68f53561d1f3880858d04c8f2056323c05a00674..e15d5b5c03df1abd3f0e9a9dcc814d75a2fc5b5f 100644 --- a/utils/utilities.lisp +++ b/utils/utilities.lisp @@ -20,7 +20,7 @@ (warn warn-string) nil) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro with-collection (&body body) `(let (($with-collection-result$ nil) $with-collection-tail$) diff --git a/xlib/ffi.lisp b/xlib/ffi.lisp index 2517b8385ba02c7d1564adb44be2bd702683e9e8..138a7c4191d4f4eb37860c3f1caf1a0c2e1768f3 100644 --- a/xlib/ffi.lisp +++ b/xlib/ffi.lisp @@ -9,11 +9,11 @@ (defmacro def-exported-constant (name value) ;; define the constant and export it from :x11 `(progn - (eval-when (eval load compile) + (eval-when (:execute :load-toplevel :compile-toplevel) (export ',name)) (defconstant ,name ,value))) -(eval-when (compile load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (defun transmogrify-ff-type (type) (if (consp type) (case (car type) @@ -27,7 +27,7 @@ (defmacro def-exported-foreign-synonym-type (new-name old-name) `(progn - (eval-when (eval load compile) + (eval-when (:execute :load-toplevel :compile-toplevel) (export ',new-name)) (ff::def-c-typedef ,new-name ,@(transmogrify-ff-type old-name)))) @@ -47,7 +47,7 @@ (mapcar #'(lambda (x) (fintern "~A-~A" name (car x))) slots)))) - `(eval-when (eval load compile) + `(eval-when (:execute :load-toplevel :compile-toplevel) (export '(,@(make-exports name) ,@(make-exports array-name))))) ,(flet ((foo-slot (slot) @@ -144,9 +144,9 @@ #-(version>= 6 1) (defmacro def-exported-foreign-function ((name &rest options) &rest args) `(progn - (eval-when (eval load compile) + (eval-when (:execute :load-toplevel :compile-toplevel) (export ',name)) - (eval-when (compile eval load) + (eval-when (:compile-toplevel :execute :load-toplevel) ,(let ((c-name (ff:convert-foreign-name (second (assoc :name options)))) (return-type (or (second (assoc :return-type options)) 'void))) @@ -195,9 +195,9 @@ #+(version>= 6 1) (defmacro def-exported-foreign-function ((name &rest options) &rest args) `(progn - (eval-when (eval load compile) + (eval-when (:execute :load-toplevel :compile-toplevel) (export ',name)) - (eval-when (compile eval load) + (eval-when (:compile-toplevel :execute :load-toplevel) ,(let ((c-name (second (assoc :name options))) (return-type (or (second (assoc :return-type options)) 'void)))