(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)

(filecreated " 4-Apr-88 12:40:00" {erinyes}<lispusers>medley>preemptive.\;3
 5218   

      |changes| |to:|  (fns preemptive preemptive.block)
                       (vars preemptivecoms)
                       (variables no-periodic-interrupt-functions)

      |previous| |date:| " 4-Apr-88 12:27:36" {erinyes}<lispusers>medley>preemptive.\;2)


; Copyright (c) 1987, 1988 by Xerox Corporation.  All rights reserved.

(prettycomprint preemptivecoms)

(rpaqq preemptivecoms
 ((fns preemptive.block preemptive)
                           (variables no-periodic-interrupt-functions)
                           (declare\: donteval@load docopy (p (preemptive ':on)))
                           (declare\: eval@compile dontcopy (p (or (hasdef 'process 'records)
                                                                   (eval (sysreclook1 'process)))))
                           (advise messagedisplayer)
                           (declare\: donteval@load doeval@compile dontcopy compilervars
                                  (addvars (nlama)
                                         (nlaml)
                                         (lama preemptive)))))
(defineq

(preemptive.block

  (lambda nil
                                            (* \; "Edited  4-Apr-88 12:26 by drc:")


    (cond
       ((and \\interruptable (uninterruptably
                                 (and (not (|fetch|
 (process procsystemp) |of|
 (this.process)
                                                  ))
                                      (or (eq lastmousebuttons 0)
                                          (progn (getmousestate)
                                                 (eq lastmousebuttons 0)))
                                      (prog (name (frame (|fetch|
 (fx clink)
                                                                (\\myalink))))
                                        sampleloop
                                            (cond
                                               ((and (litatom (setq name (\\stkname frame)))
                                                     (fmemb name no-periodic-interrupt-functions))
                                                (return nil)))
                                            (cond
                                               ((not (|fetch|
 (fx invalidp)
                                                            (setq frame (|fetch|
 (fx clink)
                                                                               frame))))
                                                (go sampleloop))
                                               (t (return t)))))))
        (block)))))

(preemptive

  (lambda (state)
                                        (* \; "Edited  4-Apr-88 12:37 by drc:")


    (prog1 (cond
              ((eq \\periodic.interrupt 'preemptive.block)
               ':on)
              (t ':off))
           (and state (selectq (cl:intern (string state)
                                      'keyword)
                          ((:on) 
                               (setq \\periodic.interrupt.frequency 25)
                               (setq \\periodic.interrupt 'preemptive.block))
                          ((:off) 
                               (setq \\periodic.interrupt nil))
                          (error state "not valid argument"))))))
)

(defglobalvar no-periodic-interrupt-functions
 '(getkey ttwaitforinput getmousestate menu.handler 
                                                          \\bltshade.display \\bitblt.display 
                                                          \\bitblt.bitmap \\bltshade.bitmap 
                                                          \\totopwds \\bitbltsub menu) )

(declare\: donteval@load docopy 
(preemptive ':on)
)
(declare\: eval@compile dontcopy 
(or (hasdef 'process 'records)
    (eval (sysreclook1 'process)))
)
(xcl:reinstall-advice 'messagedisplayer :before '((:last (allow.button.events))))
(readvise messagedisplayer)
(declare\: donteval@load doeval@compile dontcopy compilervars 

(addtovar nlama
 )

(addtovar nlaml
 )

(addtovar lama
 preemptive)
)
(prettycomprint preemptivecoms)

(rpaqq preemptivecoms
 ((fns preemptive.block preemptive)
                           (variables no-periodic-interrupt-functions)
                           (declare\: donteval@load docopy (p (preemptive ':on)))
                           (declare\: eval@compile dontcopy (p (or (hasdef 'process 'records)
                                                                   (eval (sysreclook1 'process)))))
                           (advise messagedisplayer)
                           (declare\: donteval@load doeval@compile dontcopy compilervars
                                  (addvars (nlama)
                                         (nlaml)
                                         (lama)))))
(declare\: donteval@load doeval@compile dontcopy compilervars 

(addtovar nlama
 )

(addtovar nlaml
 )

(addtovar lama
 )
)
(putprops preemptive copyright ("Xerox Corporation" 1987 1988))
(declare\: dontcopy
  (filemap (nil (1236 3474 (preemptive.block 1246 . 2773) (preemptive 2775 . 3472)))))
stop