diff --git a/gramps-clim2.asd b/gramps-clim2.asd index ccdd147815be52b2e14826b75841a2c0a60dbd52..7bb890ccfa0f6c5710c991b5a029fd6f7792eae5 100644 --- a/gramps-clim2.asd +++ b/gramps-clim2.asd @@ -129,7 +129,8 @@ ;;; based on `clim-silica' (defsystem #:gramps-clim2/silica - :depends-on (#:gramps-clim2/utils) + :depends-on (#:gramps-clim2/utils + #:closer-mop) :components ((:module "silica" :components diff --git a/silica/classes.lisp b/silica/classes.lisp index 4f5bd6c180b6663c8b4d2aa8d28399174e7adbbe..2490b7791b84ee7b626dee8f3aa099cf37208c7f 100644 --- a/silica/classes.lisp +++ b/silica/classes.lisp @@ -147,7 +147,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 +246,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 +262,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/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..d2ef53b5c1e6b367f03c0c4a75c5c055cc060552 100644 --- a/silica/framem.lisp +++ b/silica/framem.lisp @@ -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/graphics.lisp b/silica/graphics.lisp index 6e013959462bc017ac8fa0a9cf643df6281592cc..369c937de8a2d8ee9a6141d52698b5f788defbb5 100644 --- a/silica/graphics.lisp +++ b/silica/graphics.lisp @@ -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/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/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..98babdde75280513b26c1d56a37923296414c0ce 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)) diff --git a/utils/defun-utilities.lisp b/utils/defun-utilities.lisp index e5ffa7193baff026d27a84c44cae6d69c64285e1..bece22ac5b2bfeebb34f30097bb5af77160775ce 100644 --- a/utils/defun-utilities.lisp +++ b/utils/defun-utilities.lisp @@ -15,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