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

(filecreated " 5-Oct-87 14:45:51" {erinyes}<lispusers>lyric>preemptive.\;4
 2595   

      |changes| |to:|  (fns preemptive.block)

      |previous| |date:| "29-Sep-87 11:03:31" {phylum}<lispusers>lyric>preemptive.\;1)


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

(prettycomprint preemptivecoms)

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

(preemptive.block

(lambda nil (* \; "Edited  5-Oct-87 14:44 by Masinter") (cond ((and \\interruptable (uninterruptably (and (not (|fetch| (process procsystemp) |of| (this.process))) (prog ((n -1) name) lp (selectq (setq name (stkname n)) ((preemptive.block si::*unwind-protect* \\periodic.interruptframe typename dspdestination imod) (* \; "go back another frame")) ((interrupt \\interrupted \\interruptframe) (* \; "doing an interrupt already, don't do another one") (return nil)) ((getkey ttwaitforinput getmousestate menu.handler \\bltshade.display \\bitblt.display \\bitblt.bitmap \\bltshade.bitmap \\totopwds \\bitbltsub) (* \; "don't interrupt these ") (return nil)) (|if| (not (gensym? name)) |then| (return t))) (setq n (sub1 n)) (go lp)) (or (eq lastmousebuttons 0) (progn (getmousestate) (eq lastmousebuttons 0)))))) (block))))
)

(preemptive

(cl:lambda (&optional state) (cl:block preemptive (prog1 (cond ((eq \\periodic.interrupt (quote preemptive.block)) (quote :on)) (t (quote :off))) (and state (selectq (cl:intern (string state) (quote keyword)) ((:on) (setq \\periodic.interrupt.frequency 14) (setq \\periodic.interrupt (quote preemptive.block))) ((:off) (setq \\periodic.interrupt nil)) (error state "not valid argument"))))))
)
)
(declare\: donteval@load docopy 
(preemptive (quote :on))
)
(declare\: eval@compile dontcopy 
(or (hasdef (quote process) (quote records)) (eval (sysreclook1 (quote process))))
)
(xcl:reinstall-advice (quote messagedisplayer) :before (quote ((:last (allow.button.events)) (:last (allow.button.events)))))
(readvise messagedisplayer)
(declare\: donteval@load doeval@compile dontcopy compilervars 

(addtovar nlama
 )

(addtovar nlaml
 )

(addtovar lama
 preemptive)
)
(putprops preemptive copyright ("Xerox Corporation" 1987))
(declare\: dontcopy
  (filemap (nil (771 2037 (preemptive.block 781 . 1624) (preemptive 1626 . 2035)))))
stop