Skip to content
Snippets Groups Projects
Commit 23f5eab4 authored by cer's avatar cer
Browse files

Initial revision

parent d5d5323a
No related branches found
No related tags found
No related merge requests found
;; -*- mode: common-lisp; package: clim-demo -*-
;;
;; -[]-
;;
;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved.
;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc. They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader$
(in-package :clim-demo)
(define-application-frame bitmap-editor ()
((rows :initarg :rows :initform 8)
(cell-size :initarg :cell-size :initform 10)
(columns :initarg :columns :initform 8)
(array :initarg :array :initform nil)
(current-color :initarg :current-color :initform 0)
(colors :initarg :colors :initform
(list +background-ink+ +foreground-ink+)))
(:panes
(palette :accept-values :scroll-bars :vertical :width :compute :height :compute
:display-function '(accept-values-pane-displayer
:displayer display-palette))
(edit-pane :application :scroll-bars :both :width :compute :height :compute)
(pattern-pane :application :scroll-bars nil :width :compute :height :compute))
(:layouts (default (horizontally () palette edit-pane pattern-pane))))
(defun display-palette (frame stream)
(with-slots (colors current-color) frame
(flet ((display-color (object stream)
(with-room-for-graphics (stream)
(draw-rectangle* stream 0 0 30 10 :ink object))))
(setf current-color
(position
(accept `((completion ,colors)
:name-key ,#'identity
:printer ,#'display-color)
:view '(clim-internals::radio-box-view :orientation
:vertical :toggle-button-options (:indicator-type nil))
:stream stream
:default (nth current-color colors)
:prompt "Colors")
colors))
(terpri stream)
(accept-values-command-button (stream)
"Add Color"
(add-color-to-palette frame))
(terpri stream)
(accept-values-command-button (stream)
"Edit Color"
(replace-current-color frame))
(terpri stream)
(accept-values-command-button (stream)
"Delete Color"
(delete-current-color frame)))))
(defun replace-current-color (frame)
;;--- Exercise for the read
)
(defun delete-current-color (frame)
;;--- Exercise for the reader
)
(defun add-color-to-palette (frame)
(let ((fr (make-application-frame 'color-chooser)))
(run-frame-top-level fr)
(with-slots (colors) frame
(setq colors (append colors (list (color fr)))))))
(define-bitmap-editor-command (com-display-options :menu t)
()
(let* ((frame *application-frame*)
(rows (slot-value frame 'rows))
(columns (slot-value frame 'columns))
(cell-size (slot-value frame 'cell-size))
(view '(clim-internals::slider-view :show-value-p t)))
(accepting-values (*query-io* :own-window t :label "Editor options")
(setq rows (accept '(integer 1 256)
:view view
:default rows
:prompt "Rows"
:stream *query-io*))
(terpri *query-io*)
(setq columns (accept '(integer 1 256)
:view view
:default columns
:prompt "Columns"
:stream *query-io*))
(terpri *query-io*)
(setq cell-size (accept '(integer 10 100)
:view view
:default cell-size
:prompt "Cell Size"
:stream *query-io*))
(terpri *query-io*))
(setf (slot-value frame 'rows) rows
(slot-value frame 'columns) columns
(slot-value frame 'cell-size) cell-size
(slot-value frame 'array)
(adjust-array (slot-value frame 'array) (list rows columns)
:initial-element 0))
(display-everything frame)))
(defmethod initialize-instance :after ((frame bitmap-editor) &key)
(with-slots (rows columns array) frame
(setf array (make-array (list rows columns) :initial-element 0))))
(defmethod display-grid (frame pane)
(with-slots (rows columns cell-size) frame
(let ((maxx (* rows (1+ cell-size)))
(maxy (* columns (1+ cell-size))))
(dotimes (i (1+ rows))
(draw-line* pane 0 (* i (1+ cell-size)) maxx (* i (1+ cell-size))))
(dotimes (i (1+ columns))
(draw-line* pane (* i (1+ cell-size)) 0 (* i (1+ cell-size)) maxy)))))
(defmethod display-cells (frame pane)
(with-slots (rows columns cell-size) frame
(dotimes (i rows)
(dotimes (j columns)
(display-cell frame pane i j)))))
(define-presentation-type bitmap-editor-cell ())
(define-presentation-method presentation-typep (object (type bitmap-editor-cell))
(and (listp object) (= 2 (length object))))
(defun display-cell (frame pane i j)
(with-slots (cell-size array colors) frame
(let ((x (* j (1+ cell-size)))
(y (* i (1+ cell-size))))
(with-output-as-presentation (pane (list i j) 'bitmap-editor-cell)
(draw-rectangle* pane (+ x 2)
(+ y 2)
(+ x (- cell-size 2))
(+ y (- cell-size 2))
:ink (nth (aref array i j) colors)
:filled t)))))
(defun display-pattern (frame)
(let ((stream (get-frame-pane frame 'pattern-pane)))
(with-slots (array rows columns colors) frame
(window-clear stream)
(surrounding-output-with-border (stream)
(draw-rectangle* stream 10 10 (+ 10 rows) (+ 10 columns)
:ink
(make-pattern array colors))))))
(defmethod run-frame-top-level :before ((frame bitmap-editor))
(display-everything frame))
(defun display-everything (frame)
(let ((stream (get-frame-pane frame 'edit-pane)))
(window-clear stream)
(display-grid frame stream)
(display-cells frame stream)
(display-pattern frame)))
(define-presentation-to-command-translator toggle-cell
(bitmap-editor-cell com-toggle-cell bitmap-editor :gesture :select)
(presentation object)
(list presentation object))
(define-bitmap-editor-command com-toggle-cell
((presentation 'presentation)
(cell 'bitmap-editor-cell))
(let ((frame *application-frame*))
(destructuring-bind (i j) cell
(with-slots (array current-color) frame
(setf (aref array i j) current-color))
(let ((stream (get-frame-pane frame 'edit-pane)))
(erase-output-record presentation stream)
(display-cell frame stream i j)
(display-pattern frame)))))
;; -*- mode: common-lisp; package: clim-demo -*-
;;
;; -[]-
;;
;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved.
;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc. They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader$
(in-package :clim-demo)
(define-application-frame process-browser ()
((timer :accessor process-browser-timer :initform nil)
(delay :initarg :delay :accessor process-browser-delay))
(:panes
(processes :application
:incremental-redisplay '(t :check-overlapping nil)
:display-function 'display-processes
:width :compute :height :compute))
(:layouts
(default processes))
(:default-initargs :delay 5))
(defmethod read-frame-command :around ((frame process-browser) &key)
(with-accessors ((timer process-browser-timer)) frame
(unwind-protect
(progn
(install-process-browser-timer frame)
(call-next-method))
(when timer (clim-utils::delete-timer timer)))))
(defun install-process-browser-timer (frame)
(with-accessors ((timer process-browser-timer)
(delay process-browser-delay)) frame
(when timer (clim-utils::delete-timer timer))
(setq timer (clim-internals::make-command-timer frame 'com-update-process-browser nil
delay))))
(define-process-browser-command (com-change-delay-browser :menu t)
()
(let ((frame *application-frame*))
(with-accessors ((timer process-browser-timer)
(delay process-browser-delay)) frame
(accepting-values (*query-io* :own-window t)
(setf delay (accept '(integer 1 *)
:prompt "Enter new delay"
:default delay
:stream *query-io*))
(terpri *query-io*)))))
(define-process-browser-command com-update-process-browser
()
;;-- We have to do this because of the asynchronous updates
(unhighlight-highlighted-presentation *standard-output*))
(define-process-browser-command (com-refresh-process-browser :menu t)
()
(window-clear *standard-output*))
#+:composer-v2.0
(define-process-browser-command com-inspect-process
((process 'mp::process :gesture :select))
(wt::winspect process))
(defun display-processes (frame pane &key &allow-other-keys)
(declare (ignore frame))
(with-text-size (t :small)
(let ((*standard-output* pane))
(formatting-table ()
(with-text-face (t :bold)
(updating-output (t :unique-id 'headings)
(formatting-row ()
(formatting-cell () (write-string "P"))
(formatting-cell () (write-string "Dis"))
(formatting-cell () (write-string "Sec"))
(formatting-cell () (write-string "dSec"))
(formatting-cell () (write-string "Priority"))
(formatting-cell () (write-string "State"))
(formatting-cell () (write-string "Name,Whostate,Arrest")))))
;;-- snarfed from toplevel.cl
(let* ((processes mp:*all-processes*)
(processes
(sort (mp:without-scheduling ;assure consistent data
(mapcar #'(lambda (p)
(let* ((times (mp::process-times-resumed p))
(dtimes (- times (mp::process-times-resumed-1 p)))
(msec (mp::process-cpu-msec-used p))
(dmsec (- msec (mp::process-cpu-msec-used-1 p))))
(prog1 (list* dtimes msec dmsec p)
(setf (mp::process-times-resumed-1 p) times
(mp::process-cpu-msec-used-1 p) msec))))
processes))
#'>= :key #'caddr)))
(dolist (p processes)
(destructuring-bind (times-resumed msec-used msec-used-d . process) p
(let ((profilep
(let ((stack-group (mp::process-stack-group process)))
(and stack-group
(mp::profile-stack-group-p stack-group)))))
(updating-output (t :unique-id process
:cache-test #'equal
:cache-value
(list p
profilep
(mp::process-active-p process)
(mp::process-runnable-p process)
(mp::process-wait-function process)
(mp::process-name process)
(mp::process-whostate process)
(mp::process-arrest-reasons process)))
(formatting-row ()
(with-output-as-presentation (t
process
'mp::process
:single-box t)
(updating-output (t :cache-value profilep)
(formatting-cell ()
(princ profilep)))
(updating-output (t :cache-value times-resumed)
(formatting-cell ()
(princ times-resumed)))
(updating-output (t :cache-value msec-used)
(formatting-cell ()
(princ (round msec-used 1000))))
(updating-output (t :cache-value msec-used-d)
(formatting-cell ()
(princ (/ msec-used-d 1000.0))))
(updating-output (t :cache-value (mp::process-priority process))
(formatting-cell ()
(princ (mp::process-priority process))))
(let ((state
(cond ((not (mp::process-active-p process)) "inactive")
((mp::process-runnable-p process) "runnable")
((mp::process-wait-function process) "waiting ")
(t " ? "))))
(updating-output (t :cache-value state :cache-test #'equal)
(formatting-cell ()
(princ state))))
(updating-output (t :cache-value
(mp::process-name process)
:cache-test #'equal)
(formatting-cell ()
(with-text-face (t :bold)
(princ (mp::process-name process)))))
(updating-output (t :cache-value (mp::process-whostate process))
(formatting-cell ()
(princ (mp::process-whostate
process))))
(updating-output (t :cache-value (mp::process-arrest-reasons process)
:cache-test #'equal)
(formatting-cell ()
(when (mp::process-arrest-reasons process)
(princ (mp::process-arrest-reasons process))))))))))))))))
(defvar *process-browsers* nil)
(defun do-process-browser (&key (port (find-port)) (force nil))
(let* ((framem (find-frame-manager :port port))
(frame
(let* ((entry (assoc port *process-browsers*))
(frame (cdr entry)))
(when (or force (null frame))
(setq frame (make-application-frame 'process-browser
:frame-manager framem)))
(if entry
(setf (cdr entry) frame)
(push (cons port frame) *process-browsers*))
frame)))
(run-frame-top-level frame)))
(define-demo "Process Browser" do-process-browser)
;; -*- mode: common-lisp; package: clim-internals -*-
;;
;; -[]-
;;
;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved.
;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc. They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader$
(in-package :clim-internals)
(defmethod frame-manager-accepting-values-frame-class ((framem xm-silica::motif-frame-manager))
'motif-accept-values-own-window)
(define-application-frame motif-accept-values-own-window (accept-values-own-window)
()
(:pane
(with-slots (stream own-window exit-button-stream) *application-frame*
(vertically ()
(progn
(setq stream
(make-instance 'accept-values-stream
:stream (setf own-window
(make-pane 'clim-stream-pane
:initial-cursor-visibility :off))))
own-window)
(make-pane 'silica::separator :orientation :horizontal)
(setf exit-button-stream
(make-pane 'clim-stream-pane
:initial-cursor-visibility nil)))))
(:menu-bar nil)
(:top-level (accept-values-top-level))
(:command-table accept-values)
(:command-definer nil))
;;;---- The rest of what in here is dreaming right now
;;;---- It would be nice to use more
;#+ignore
;(define-application-frame xm-silica::motif-accepting-values-frame (accept-values-own-window)
; ()
; (:panes
; (control-area :application :scroll-bars nil)
; (action-area (make-pane 'xm-silica::motif-form-pane)))
; (:menu-bar nil)
; (:top-level (accept-values-top-level))
; (:command-table accept-values)
; (:command-definer nil)
; (:layouts
; (:default
; (let ((frame *application-frame*)
; (view +gadget-dialog-view+))
; (let ((vp
; (make-pane 'xm-silica::motif-paned-pane
; :children (list control-area action-area))))
; (let ((labels (frame-manager-exit-box-labels (frame-manager frame) frame view)))
; (with-slots (exit-boxes) frame
; (dolist (exit-box exit-boxes)
; (let* ((value (if (consp exit-box) (car exit-box) exit-box))
; (label (or (if (consp exit-box) (second exit-box))
; (second (assoc value labels)))))
; (make-pane 'push-button
; :parent action-area
; :label label
; :client frame :id value
; :activate-callback
; #'handle-exit-box-callback))))
; (setf (slot-value action-area 'xm-silica::fraction-base)
; (1+ (* 2 (length labels))))
; (setf (slot-value action-area 'xm-silica::attachments)
; (let ((i 0))
; (mapcar #'(lambda (label)
; (declare (ignore label))
; (prog1
; `(,i :top-attachment :form
; :bottom-attachment :form
; :left-attachment :position
; :left-position ,(1+ (* 2 i))
; :right-attachment :position
; :right-position ,(+ 2 (* 2 i)))
; (incf i)))
; labels)))
;
; vp))))))
;
;
;
;
;(defmethod generate-panes :after ((framem standard-frame-manager)
; (frame xm-silica::motif-accepting-values-frame))
; (setf (slot-value frame 'stream)
; (make-instance 'accept-values-stream
; :stream (setf (slot-value frame 'own-window)
; (get-frame-pane frame 'control-area))))
; (setf (slot-value frame 'exit-button-stream) nil))
;
;(defmethod display-exit-boxes ((frame xm-silica::motif-accepting-values-frame)
; stream
; (view view))
; ;;-- Nothing should have changed
; nil)
;
;;;; Need to hook up the constraint resources and set the min-max size
;;;; of the action-pane to be just large enough to contain the buttons.
;
;(defmethod accept-values-top-level ((frame xm-silica::motif-accepting-values-frame) &rest args)
; (declare (ignore args))
; ;; this might want to use table-formatting or equivalent
; ;; to make sure that the rows line up properly.
; ;; This requires formatting-table and friends to return their bodies' values properly.
; (with-slots (stream continuation resynchronize-every-pass check-overlapping
; selected-item initially-select-query-identifier
; own-window own-window-x-position own-window-y-position
; own-window-width own-window-height
; own-window-right-margin own-window-bottom-margin
; exit-button-stream) frame
;
; (unless own-window (return-from accept-values-top-level (call-next-method)))
;
; (let* ((original-view (stream-default-view stream))
; (return-values nil)
; (initial-query nil)
; exit-button-record
; avv avv-record)
; (letf-globally (((stream-default-view stream)
; (frame-manager-dialog-view (frame-manager frame)))
; ((cursor-state (stream-text-cursor stream)) nil))
; (labels ((run-continuation (stream avv-record)
; (setf (slot-value stream 'avv-record) avv-record)
; (setf (slot-value stream 'avv-frame) frame)
; (with-output-recording-options (stream :draw nil :record t)
; (setq return-values (multiple-value-list
; (let ((*application-frame* *avv-calling-frame*))
; (funcall continuation stream))))
; (unless own-window
; (display-exit-boxes frame stream
; (stream-default-view stream)))))
; (run-avv ()
; (when (and initially-select-query-identifier
; (setq initial-query
; (find-query avv-record
; (car initially-select-query-identifier))))
; (if (cdr initially-select-query-identifier)
; (com-modify-avv-choice initial-query)
; (com-edit-avv-choice initial-query))
; (redisplay avv stream :check-overlapping check-overlapping))
; (loop
; (let ((command
; (let ((command-stream (slot-value stream 'stream)))
; ;; While we're reading commands, restore the view
; ;; to what it was before we started.
; (letf-globally (((stream-default-view command-stream)
; original-view))
; (read-frame-command frame :stream command-stream)))))
; (if (and command (not (keyboard-event-p command)))
; (execute-frame-command frame command)
; (beep stream)))
; (with-deferred-gadget-updates
; (when (or resynchronize-every-pass
; (slot-value avv-record 'resynchronize))
; ;; When the user has asked to resynchronize every pass, that
; ;; means we should run the continuation an extra time to see
; ;; that all visible stuff is up to date. That's all!
; (with-output-recording-options (stream :draw nil)
; (redisplay avv stream :check-overlapping check-overlapping)))
; (setf (slot-value avv-record 'resynchronize) nil)
;
;; (when exit-button-record
;; (redisplay exit-button-record exit-button-stream))
;
; (redisplay avv stream :check-overlapping check-overlapping)
;
; (when (ecase (frame-resizable frame)
; ((nil) nil)
; ((t) t)
; (:grow
; (and own-window
; (multiple-value-bind (width height)
; (bounding-rectangle-size
; (stream-output-history own-window))
; (multiple-value-bind (vwidth vheight)
; (bounding-rectangle-size
; (or (pane-viewport own-window) own-window))
; (or (> width vwidth) (> height vheight)))))))
; (size-panes-appropriately)))))
;
; (size-panes-appropriately ()
; (changing-space-requirements ()
; ;; We really want to specify the min/max sizes of
; ;; the exit-button pane
; ;; also
;; (when exit-button-stream
;; (size-frame-from-contents exit-button-stream
;; :size-setter
;; #'(lambda (pane w h)
;; (change-space-requirements
;; pane
;; :width w :min-width w :max-width w
;; :height h :min-height h :max-height h))))
; (when own-window
; (size-frame-from-contents own-window
; :width own-window-width
; :height own-window-height
; :right-margin own-window-right-margin
; :bottom-margin own-window-bottom-margin)))))
; (declare (dynamic-extent #'run-continuation #'run-avv
; #'size-panes-appropriately))
; (with-simple-restart (frame-exit "Exit from the ACCEPT-VALUES dialog")
; (setq avv
; (updating-output (stream)
; (setq avv-record
; (with-end-of-line-action (stream :allow)
; (with-end-of-page-action (stream :allow)
; (with-new-output-record
; (stream 'accept-values-output-record avv-record)
; (run-continuation stream avv-record)))))))
; ;; In own window dialogs the buttons are displayed separately
;; (when (and own-window exit-button-stream)
;; (setq exit-button-record
;; (updating-output (exit-button-stream)
;; (with-end-of-line-action (exit-button-stream :allow)
;; (with-end-of-page-action (exit-button-stream :allow)
;; (display-exit-boxes frame exit-button-stream
;; (stream-default-view stream)))))))
;
; (unwind-protect
; (cond (own-window
; (size-panes-appropriately)
; (multiple-value-bind (x y)
; #+++ignore (pointer-position (port-pointer (port own-window)))
; #---ignore (values 100 100)
; (when (and own-window-x-position own-window-y-position)
; (setq x own-window-x-position
; y own-window-y-position))
; (position-sheet-carefully
; (frame-top-level-sheet (pane-frame own-window)) x y))
; (window-expose own-window)
; (with-input-focus (own-window)
; (when exit-button-record
; (replay exit-button-record exit-button-stream))
; (replay avv stream)
; (run-avv)))
; (t
; ;; Ensure that bottom of the AVV is visible. I think that
; ;; this is OK even if the AVV is bigger than the viewport.
; (move-cursor-beyond-output-record (slot-value stream 'stream) avv)
; (stream-ensure-cursor-visible stream)
; (replay avv stream)
; (run-avv)))
; (deactivate-all-gadgets avv-record)
; (unless own-window
; (move-cursor-beyond-output-record (slot-value stream 'stream) avv))))
; (values-list return-values))))))
;; -*- mode: common-lisp; package: clim-utils -*-
;;
;; -[]-
;;
;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved.
;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc. They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader$
(in-package :clim-utils)
;;;---- Perhaps this should be elsewhere
;;; Implementation of timers
;;; Its lame but its ugly.
;;; You can:
;;; make-instance 'timer
;;; queue-timer
;;; delete-time
(defclass timer ()
((delay :initarg :delay :reader timer-delay)
(repeat :initarg :repeat :initform nil :reader timer-repeat)
(function :initarg :function :reader timer-function)
(when :accessor timer-when))
)
(defvar *timer-input-queue* (make-queue))
(defun add-timer (timer)
(ensure-timer-process)
(setf (timer-when timer)
(+ (get-internal-real-time)
(* internal-time-units-per-second
(timer-delay timer))))
(queue-put *timer-input-queue* timer))
(defun delete-timer (timer)
(queue-put *timer-input-queue* `(:delete ,timer)))
(defvar *timers* nil)
(defvar *timer-process* nil)
(defun queue-process-function ()
(unwind-protect
(progn
(setq *timer-process* (Current-process))
(flet ((add-timer-to-queue (timer)
(setq *timers* (merge 'list (list timer) *timers* '< :key #'timer-when))))
(declare (dynamic-extent #'add-timer-to-queue))
(loop
(let ((head (car *timers*)))
(if head
(let* ((time-now (get-internal-real-time))
(time-to-wait (- (timer-when head) time-now)))
(process-wait-with-timeout
"Waiting"
(float (/ time-to-wait internal-time-units-per-second))
#'(lambda () (not (queue-empty-p *timer-input-queue*)))))
(process-wait
"Waiting"
#'(lambda () (not (queue-empty-p *timer-input-queue*)))))
(loop
(let ((head (queue-pop *timer-input-queue*)))
(etypecase head
(null (return nil))
(timer (add-timer-to-queue head))
(cons
(ecase (first head)
(:delete (setf *timers* (delete (second head) *timers*))))))))
(loop
(unless *timers* (return nil))
(let ((time-now (get-internal-real-time))
(timer (car *timers*)))
(if (< (timer-when timer) time-now)
(progn
(pop *timers*)
(funcall (timer-function timer) timer)
(when (timer-repeat timer)
(setf (timer-when timer)
(+ (get-internal-real-time)
(* internal-time-units-per-second
(timer-repeat timer))))
(add-timer-to-queue timer)))
(return nil))))))))
(setq *timer-process* nil)))
(defun ensure-timer-process ()
(unless *timer-process*
(make-process #'queue-process-function :name "Timer")))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment