github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-01-13 15:37:38 +00:00
Code Issues Projects Releases Wiki Activity

lmm57 interrupts clipboard wheelscroll (#1634)

Browse Source 
* Changes to interrupt initialization for CLIPBOARD and WHEELSCROLL

* fixed initialization
This commit is contained in:
Larry Masinter 2024-04-01 15:18:40 -07:00 committed by GitHub
parent e92381b706
commit 9b82f1a7c2
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
6 changed files with 167 additions and 180 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
library/CLIPBOARD
View File

@ -1,20 +1,21 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "19-Oct-2023 00:20:01" {WMEDLEY}<library>CLIPBOARD.;8 9130
(FILECREATED "31-Mar-2024 06:51:14" {DSK}<home>larry>il>medley>library>CLIPBOARD.;2 8932
:EDIT-BY rmk
:EDIT-BY "lmm"
:CHANGES-TO (FNS TEDIT.EXTRACTTOCLIPBOARD)
:CHANGES-TO (FNS INSTALL-CLIPBOARD)
(VARS CLIPBOARDCOMS)
:PREVIOUS-DATE " 7-Jul-2022 23:53:01" {WMEDLEY}<library>CLIPBOARD.;7)
:PREVIOUS-DATE "19-Oct-2023 00:20:01" {DSK}<home>larry>il>medley>library>CLIPBOARD.;1)
(PRETTYCOMPRINT CLIPBOARDCOMS)
(RPAQQ CLIPBOARDCOMS
[ (* ; "Enable copy and paste")
(FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD LISPINTERRUPTS.PASTE
CLIPBOARD-COPY-STREAM CLIPBOARD-PASTE-STREAM)
(FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD CLIPBOARD-COPY-STREAM
CLIPBOARD-PASTE-STREAM)
(FNS TEDIT.COPYTOCLIPBOARD TEDIT.EXTRACTTOCLIPBOARD)
(FNS SEDIT.COPYTOCLIPBOARD)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILES (SYSLOAD)
@ -31,19 +32,22 @@
(DEFINEQ
(INSTALL-CLIPBOARD
[LAMBDA NIL (* ; "Edited 24-Jun-2021 21:14 by rmk:")
(* ; "Edited 19-Apr-2020 12:15 by rmk:")
(* ; "Edited 18-Apr-2018 23:00 by rmk:")
(CL:WHEN (GETD 'LISPINTERRUPTS.PASTE)
(MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG)
(MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS))
[LAMBDA NIL (* ; "Edited 30-Mar-2024 22:22 by lmm")
(* ; "Edited 24-Jun-2021 21:14 by rmk:")
(* ; "Edited 19-Apr-2020 12:15 by rmk:")
(* ; "Edited 18-Apr-2018 23:00 by rmk:")
(INTERRUPTCHAR (CHARCODE "Meta,v")
'(PASTEFROMCLIPBOARD))
(INTERRUPTCHAR (CHARCODE "Meta,V")
'(PASTEFROMCLIPBOARD))
(CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT")
(/PUTASSOC 'PASTE [LIST (LIST (CHARCODE "1,v")
'(PASTEFROMCLIPBOARD))
(LIST (CHARCODE "1,V")
'(PASTEFROMCLIPBOARD]
LISPINTERRUPTS)
(CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT")
(* ;; "Paste")
(* ;; "Paste")
(TEDIT.SETFUNCTION (CHARCODE "Meta,v")
(FUNCTION PASTEFROMCLIPBOARD)
@ -52,7 +56,7 @@
(FUNCTION PASTEFROMCLIPBOARD)
TEDIT.READTABLE)
(* ;; "Copy")
(* ;; "Copy")
(TEDIT.SETFUNCTION (CHARCODE "Meta,c")
(FUNCTION TEDIT.COPYTOCLIPBOARD)
@ -61,7 +65,7 @@
(FUNCTION TEDIT.COPYTOCLIPBOARD)
TEDIT.READTABLE)
(* ;; "Extract")
(* ;; "Extract")
(TEDIT.SETFUNCTION (CHARCODE "Meta,X")
(FUNCTION TEDIT.EXTRACTTOCLIPBOARD)
@ -69,8 +73,8 @@
(TEDIT.SETFUNCTION (CHARCODE "Meta,x")
(FUNCTION TEDIT.EXTRACTTOCLIPBOARD)
TEDIT.READTABLE))
(CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ;
 "SEDIT copy: INTERRUPTCHAR does paste")
(CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ;
 "SEDIT copy: INTERRUPTCHAR does paste")
(SEDIT:ADD-COMMAND "Meta,c" 'SEDIT.COPYTOCLIPBOARD "M-c" "Copy to clipboard")
(SEDIT:ADD-COMMAND "Meta,C" 'SEDIT.COPYTOCLIPBOARD)
(SEDIT:RESET-COMMANDS))])
@ -104,17 +108,6 @@
THEN (COPYINSERT STR)
ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C])
(LISPINTERRUPTS.PASTE
[LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:")
(* ;; "So paste interrupts will be installed in every process")
(APPEND [LIST (LIST (CHARCODE "1,v")
'(PASTEFROMCLIPBOARD))
(LIST (CHARCODE "1,V")
'(PASTEFROMCLIPBOARD]
(LISPINTERRUPTS.ORIG])
(CLIPBOARD-COPY-STREAM
[LAMBDA NIL (* ; "Edited 7-Jul-2022 23:51 by rmk")
(* ; "Edited 23-Feb-2021 22:11 by rmk:")
@ -196,10 +189,9 @@
(ADDTOVAR LAMA )
)
(PUTPROPS CLIPBOARD COPYRIGHT (NONE))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1196 6505 (INSTALL-CLIPBOARD 1206 . 3138) (GETCLIPBOARD 3140 . 3514) (PUTCLIPBOARD 3516
. 3921) (PASTEFROMCLIPBOARD 3923 . 4841) (LISPINTERRUPTS.PASTE 4843 . 5264) (CLIPBOARD-COPY-STREAM
5266 . 5781) (CLIPBOARD-PASTE-STREAM 5783 . 6503)) (6506 7273 (TEDIT.COPYTOCLIPBOARD 6516 . 6797) (
TEDIT.EXTRACTTOCLIPBOARD 6799 . 7271)) (7274 8813 (SEDIT.COPYTOCLIPBOARD 7284 . 8811)))))
(FILEMAP (NIL (1243 6345 (INSTALL-CLIPBOARD 1253 . 3401) (GETCLIPBOARD 3403 . 3777) (PUTCLIPBOARD 3779
. 4184) (PASTEFROMCLIPBOARD 4186 . 5104) (CLIPBOARD-COPY-STREAM 5106 . 5621) (CLIPBOARD-PASTE-STREAM
5623 . 6343)) (6346 7113 (TEDIT.COPYTOCLIPBOARD 6356 . 6637) (TEDIT.EXTRACTTOCLIPBOARD 6639 . 7111)) (
7114 8653 (SEDIT.COPYTOCLIPBOARD 7124 . 8651)))))
STOP

BIN
library/CLIPBOARD.LCOM
View File

Binary file not shown.

33
lispusers/WHEELSCROLL
View File

@ -1,20 +1,19 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 2-Oct-2023 10:15:55" {WMEDLEY}<lispusers>WHEELSCROLL.;24 10480
(FILECREATED "31-Mar-2024 06:57:25" {DSK}<home>larry>il>medley>lispusers>WHEELSCROLL.;2 9911
:EDIT-BY rmk
:EDIT-BY "lmm"
:CHANGES-TO (VARS WHEELSCROLLCOMS)
(FNS ENABLEWHEELSCROLL)
:PREVIOUS-DATE " 6-Apr-2023 18:34:48" {WMEDLEY}<lispusers>WHEELSCROLL.;22)
:PREVIOUS-DATE " 2-Oct-2023 10:15:55" {DSK}<home>larry>il>medley>lispusers>WHEELSCROLL.;1)
(PRETTYCOMPRINT WHEELSCROLLCOMS)
(RPAQQ WHEELSCROLLCOMS
[(FNS ENABLEWHEELSCROLL WHEELSCROLL WHEELSCROLL.DOIT INSTALL-WHEELSCROLL
LISPINTERRUPTS.WHEELSCROLL)
[(FNS ENABLEWHEELSCROLL WHEELSCROLL WHEELSCROLL.DOIT INSTALL-WHEELSCROLL)
(* ;; "These are the highest meta-ctrl characters, they will be unaffected by teh state of ctrl and meta mode keys")
@ -35,7 +34,8 @@
(DEFINEQ
(ENABLEWHEELSCROLL
[LAMBDA (ON EXCLUDEHORIZONTAL) (* ; "Edited 2-Oct-2023 10:05 by rmk")
[LAMBDA (ON EXCLUDEHORIZONTAL) (* ; "Edited 31-Mar-2024 06:30 by lmm")
(* ; "Edited 2-Oct-2023 10:05 by rmk")
(* ; "Edited 23-Oct-2021 16:31 by larry")
(* ; "Edited 11-Jun-2021 12:50 by rmk:")
(* ; "Edited 28-May-2021 11:46 by rmk:")
@ -43,11 +43,7 @@
(* ;; "So we can toggle this scrolling.")
(if ON
then (CL:UNLESS (EQP (GETD 'LISPINTERRUPTS)
(GETD 'LISPINTERRUPTS.WHEELSCROLL))
(CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL) (* ; "In case of LOADFROM?")
(MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG)
(MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS)))
then (/PUTASSOC 'WHEELSCROLL WHEELSCROLLINTERRUPTS LISPINTERRUPTS)
(* ;; "In some situations these other keyactions seem to be installed, hit them all.")
@ -73,9 +69,7 @@
(CADR I)
(CADDR I)))
(SETQ WHEELSCROLLENABLED T)
else (CL:WHEN (EQP (GETD 'LISPINTERRUPTS.WHEELSCROLL)
(GETD 'LISPINTERRUPTS))
(MOVD 'LISPINTERRUPTS.WSORIG 'LISPINTERRUPTS))
else (/PUTASSOC 'WHEELSCROLL NIL LISPINTERRUPTS)
(for I in WHEELSCROLLINTERRUPTS do (INTERRUPTCHAR (CAR I)
NIL))
(for KAT in (LIST \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION)
@ -159,13 +153,6 @@
(,\WSRIGHT (WHEELSCROLL 'HORIZONTAL (OR HWHEELSCROLLDELTA
WHEELSCROLLDELTA)
WHEELSCROLLDELTA T])
(LISPINTERRUPTS.WHEELSCROLL
[LAMBDA NIL (* ; "Edited 17-Feb-2021 11:09 by rmk:")
(* ;; "So wheelscroll interrupts will be installed in every process")
(APPEND WHEELSCROLLINTERRUPTS (LISPINTERRUPTS.WSORIG])
)
@ -227,6 +214,6 @@
(ENABLEWHEELSCROLL T)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1459 9251 (ENABLEWHEELSCROLL 1469 . 4512) (WHEELSCROLL 4514 . 7115) (WHEELSCROLL.DOIT
7117 . 7753) (INSTALL-WHEELSCROLL 7755 . 8972) (LISPINTERRUPTS.WHEELSCROLL 8974 . 9249)))))
(FILEMAP (NIL (1452 8682 (ENABLEWHEELSCROLL 1462 . 4220) (WHEELSCROLL 4222 . 6823) (WHEELSCROLL.DOIT
6825 . 7461) (INSTALL-WHEELSCROLL 7463 . 8680)))))
STOP

BIN
lispusers/WHEELSCROLL.LCOM
View File

Binary file not shown.

254
sources/AINTERRUPT
View File

@ -1,12 +1,13 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED "17-Sep-92 10:42:38" "{Pele:mv:envos}<LispCore>Sources>AINTERRUPT.;4" 41128
|changes| |to:| (FNS INTCHAR GETINTERRUPT)
(FILECREATED "31-Mar-2024 09:38:10" |{DSK}<home>larry>il>medley>sources>AINTERRUPT.;7| 41133
|previous| |date:| "28-Jun-90 18:45:07" "{Pele:mv:envos}<LispCore>Sources>AINTERRUPT.;3")
:EDIT-BY "lmm"
:CHANGES-TO (VARS AINTERRUPTCOMS)
:PREVIOUS-DATE "31-Mar-2024 09:27:57" |{DSK}<home>larry>il>medley>sources>AINTERRUPT.;5|)
; Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1989, 1990, 1992 by Venue & Xerox Corporation. All rights reserved.
(PRETTYCOMPRINT AINTERRUPTCOMS)
@ -16,7 +17,14 @@
\\DOHELPINTERRUPT1 \\DOINTERRUPTHERE \\PROC.FINDREALFRAME \\SETPRINTLEVEL
\\SETRECLAIMMIN GETINTERRUPT CURRENTINTERRUPTS SETINTERRUPT RESET.INTERRUPTS
INTERRUPTABLE))
(DECLARE\: DONTEVAL@LOAD DOCOPY (P (INTCHAR T)))
(INITVARS (LISPINTERRUPTS '((LISPINTERRUPTS (2 BREAK MOUSE)
(4 RESET MOUSE)
(5 ERROR MOUSE)
(7 HELP T)
(16 PRINTLEVEL)
(20 (CONTROL-T))
(127 RUBOUT T)))))
(GLOBALVARS LISPINTERRUPTS)
(COMS
(* |;;| "^T this is actually not very useful any more, and the percentages are wrong")
@ -46,7 +54,8 @@
DONTCOPY
(EXPORT (RECORDS INTERRUPTSTATE)
(PROP DMACRO \\TAKEINTERRUPT))
(MACROS \\SYSTEMINTERRUPTP))))
(MACROS \\SYSTEMINTERRUPTP))
(DECLARE\: DONTEVAL@LOAD DOCOPY (P (INTCHAR T)))))
@ -55,43 +64,44 @@
(DEFINEQ
(INTCHAR
(LAMBDA (CHAR TYP/FORM HARDFLG TABLE) (* \; "Edited 17-Sep-92 10:41 by jds")
(LAMBDA (CHAR TYP/FORM HARDFLG TABLE) (* \; "Edited 31-Mar-2024 09:16 by lmm")
(* \; "Edited 17-Sep-92 10:41 by jds")
(* |;;| "this function is the non-undoable version of INTERRUPTCHAR; INTERRUPTCHAR calls it")
(PROG (VAL SYSDEF OLDINT)
(SELECTQ CHAR
(NIL (* \;
 "this is illegal, so don't do anything about it")
 "this is illegal, so don't do anything about it")
(RETURN))
(T (* \;
 "(INTCHAR T) means restore interrupts to the 'standard' setting")
(UNINTERRUPTABLY
(|for| CHAR |in| (GETINTERRUPT NIL TABLE)
|do| (SETQ VAL (NCONC (INTCHAR CHAR NIL NIL TABLE)
VAL))) (* \;
 "turn off all user interrupts --- (GETINTERRUPT) returns list of user interrupts")
(MAPC (LISPINTERRUPTS)
(FUNCTION (LAMBDA (LST)
(SETQ VAL (NCONC (INTCHAR (CAR LST)
(CADR LST)
(CADDR LST)
TABLE)
VAL)))))
(T
(* |;;| "(INTCHAR T) means restore interrupts to the 'standard' setting")
(* |;;| "and reset all SYSTEM interrupts to default --- (LISPINTERRUPTS) returns a list of argument lists for INTCHAR")
(|for| CHAR |in| (GETINTERRUPT NIL TABLE)
|do| (SETQ VAL (NCONC (INTCHAR CHAR NIL NIL TABLE)
VAL))) (* \;
 "turn off all user interrupts --- (GETINTERRUPT) returns list of user interrupts")
(MAPC (LISPINTERRUPTS)
(FUNCTION (LAMBDA (LST)
(SETQ VAL (NCONC (INTCHAR (CAR LST)
(CADR LST)
(CADDR LST)
TABLE)
VAL)))))
(* |;;| "and reset all SYSTEM interrupts to default --- (LISPINTERRUPTS) returns a list of argument lists for INTCHAR")
(* \;
 "and VAL has been set to a valid arg list for INTCHAR")
(RETURN VAL)))
 "and VAL has been set to a valid arg list for INTCHAR")
(RETURN VAL))
NIL)
(COND
((LISTP CHAR) (* \;
 "Call from undoing or resetform. CHAR is a list of characters followed by typ/form arguments.")
 "Call from undoing or resetform. CHAR is a list of characters followed by typ/form arguments.")
(|while| CHAR |do| (SETQ VAL (NCONC (INTCHAR (|pop| CHAR)
(|pop| CHAR)
(|pop| CHAR)
TABLE)
VAL)))
(|pop| CHAR)
(|pop| CHAR)
TABLE)
VAL)))
(RETURN VAL)))
(COND
((NOT (FIXP CHAR))
@ -103,26 +113,26 @@
(SETQ CHAR (OR (GETINTERRUPT CHAR TABLE)
(ERRORX (LIST 27 CHAR)))))
(T (* \;
 "turn single character into character code")
 "turn single character into character code")
(SETQ CHAR (APPLY* 'CHARCODE CHAR))))))
(SETQ VAL (AND (SETQ OLDINT (GETINTERRUPT CHAR TABLE))
(LIST CHAR (CAR OLDINT)
(CADR OLDINT))))
(COND
((EQ TYP/FORM T) (* \;
 "just return value indicating what it was.")
 "just return value indicating what it was.")
(RETURN VAL))
((AND TYP/FORM (LITATOM TYP/FORM)
(SETQ SYSDEF (ASSOC TYP/FORM \\SYSTEMINTERRUPTS)))
(* \;
 "System interrupt -- get its default HARDFLG")
 "System interrupt -- get its default HARDFLG")
(OR HARDFLG (SETQ HARDFLG (CADR SYSDEF)))))
(COND
((AND (EQ (CAR OLDINT)
TYP/FORM)
(EQ (CADR OLDINT)
HARDFLG)) (* \;
 "if the character is already set up, just return")
 "if the character is already set up, just return")
(RETURN)))
(COND
(OLDINT (SETINTERRUPT CHAR NIL TABLE)))
@ -251,20 +261,15 @@
 "Couldn't build frame, so leave interrupt pending")
(SETQ \\PENDINGINTERRUPT T)))))))))))))
(lispinterrupts
(lambda nil (* |jds| "30-Sep-85 12:35")
(* * |Returns| \a |list| |of| |the| "standard" |interrupt-character|
 |settings| |for| |Interlisp-D.| |These| |are| |used,| |e.g.,| |in| intchar
 |to| |reset| |things| |to| |the| |default| |state.|)
(LISPINTERRUPTS
(LAMBDA NIL (* \; "Edited 31-Mar-2024 06:25 by lmm")
(* |jds| "30-Sep-85 12:35")
'((2 break mouse)
(4 reset mouse)
(5 error mouse)
(7 help t)
(16 printlevel)
(20 (control-t))
(127 rubout t))))
(* * |Returns| \a |list| |of| |the| "standard" |interrupt-character| |settings|
 |for| |Interlisp-D.| |These| |are| |used,| |e.g.,| |in| INTCHAR |to| |reset|
 |things| |to| |the| |default| |state.|)
(FOR R IN LISPINTERRUPTS JOIN (APPEND (CDR R)))))
(\\dohelpinterrupt
(lambda nil (* |bvm:| "27-JUL-83 18:37")
@ -427,7 +432,8 @@
(setq \\linbuf olb))))
(GETINTERRUPT
(LAMBDA (CHAR TABLE) (* \; "Edited 17-Sep-92 10:41 by jds")
(LAMBDA (CHAR TABLE) (* \; "Edited 31-Mar-2024 09:20 by lmm")
(* \; "Edited 17-Sep-92 10:41 by jds")
(* |;;| "Return the interrupt, if any, defined for CHAR in keyaction table TABLE.")
@ -438,20 +444,16 @@
(OR TABLE (SETQ TABLE \\CURRENTKEYACTION))
(SELECTQ CHAR
(NIL (* \; "Non-system interrupts")
(|for| X |in| (|fetch| (KEYACTION INTERRUPTLIST)
TABLE) |unless| (\\SYSTEMINTERRUPTP (CADR X))
|collect| (CAR X)))
(|for| X |in| (|fetch| (KEYACTION INTERRUPTLIST) OF TABLE)
|unless| (\\SYSTEMINTERRUPTP (CADR X)) |collect| (CAR X)))
(T (* \; "All system interrupts")
(|for| X |in| (|fetch| (KEYACTION INTERRUPTLIST)
TABLE) |collect| (CAR X)))
(|for| X |in| (|fetch| (KEYACTION INTERRUPTLIST) OF TABLE) |collect| (CAR X)))
(COND
((NUMBERP CHAR)
(CDR (FASSOC CHAR (|fetch| (KEYACTION INTERRUPTLIST)
TABLE))))
(T (|for| X |in| (|fetch| (KEYACTION INTERRUPTLIST)
TABLE) |when| (EQ CHAR (CADR X))
|do| (* \; "Find CHAR in system class.")
(RETURN (CAR X))))))))
(CDR (FASSOC CHAR (|fetch| (KEYACTION INTERRUPTLIST) OF TABLE))))
(T (|for| X |in| (|fetch| (KEYACTION INTERRUPTLIST) OF TABLE)
|when| (EQ CHAR (CADR X)) |do| (* \; "Find CHAR in system class.")
(RETURN (CAR X))))))))
(currentinterrupts
(lambda (table) (* |bvm:| "18-Jul-85 12:37")
@ -535,9 +537,18 @@
(lambda (flag) (* |lmm| "18-APR-82 13:52")
(prog1 \\interruptable (setq \\interruptable flag))))
)
(DECLARE\: DONTEVAL@LOAD DOCOPY
(INTCHAR T)
(RPAQ? LISPINTERRUPTS
'((LISPINTERRUPTS (2 BREAK MOUSE)
(4 RESET MOUSE)
(5 ERROR MOUSE)
(7 HELP T)
(16 PRINTLEVEL)
(20 (CONTROL-T))
(127 RUBOUT T))))
(DECLARE\: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS LISPINTERRUPTS)
)
@ -679,16 +690,16 @@
(ADDTOVAR FONTVARS (INTERUPTMENUFONT DEFAULTFONT T))
(RPAQQ \\SYSTEMINTERRUPTS ((BREAK MOUSE)
(CONTROL-T)
(ERROR MOUSE)
(ERRORX)
(HELP T)
(OUTPUTBUFFER T)
(PRINTLEVEL)
(RAID T)
(RESET MOUSE)
(RUBOUT T)
(STORAGE)))
(CONTROL-T)
(ERROR MOUSE)
(ERRORX)
(HELP T)
(OUTPUTBUFFER T)
(PRINTLEVEL)
(RAID T)
(RESET MOUSE)
(RUBOUT T)
(STORAGE)))
(DECLARE\: EVAL@COMPILE DONTCOPY
(ADDTOVAR NOFIXFNSLST CONTROL-T)
@ -710,9 +721,9 @@
(PUTPROPS UNINTERRUPTABLY INFO EVAL)
(PUTPROPS UNINTERRUPTABLY DMACRO ((X . Y)
((LAMBDA (\\INTERRUPTABLE)
(PROGN X . Y))
NIL)))
((LAMBDA (\\INTERRUPTABLE)
(PROGN X . Y))
NIL)))
(ADDTOVAR PRETTYPRINTMACROS
(UNINTERRUPTABLY
@ -731,57 +742,52 @@ DONTCOPY
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE\: EVAL@COMPILE
(BLOCKRECORD INTERRUPTSTATE (
(* |;;| "This is the structure used to communicate between the emulator and Lisp re interrupts. There is a bit per interrupt type, plus space for the character code that caused a keyboard interrupt.")
(* |;;| "This is the structure used to communicate between the emulator and Lisp re interrupts. There is a bit per interrupt type, plus space for the character code that caused a keyboard interrupt.")
(* |;;| "This must match the INTSTAT definition in lispemul.h")
(* |;;| "This must match the INTSTAT definition in lispemul.h")
(* |;;| "PENDING-INTERRUPT FLAGS:")
(* |;;| "PENDING-INTERRUPT FLAGS:")
(LOGMSGSPENDING FLAG) (* \;
 " Log/Console msgs need printing.")
(ETHERINTERRUPT FLAG) (* \; "Ether packet read finished.")
(IOINTERRUPT FLAG)
(GCDISABLED FLAG) (* \; "No mroe room in GC tables.")
(VMEMFULL FLAG) (* \; "VMEM is full!!")
(STACKOVERFLOW FLAG) (* \; "Stack overflowed.")
(STORAGEFULL FLAG) (* \;
 "Ran out of storage, atoms, etc.")
(WAITINGINTERRUPT FLAG)
(LOGMSGSPENDING FLAG) (* \; " Log/Console msgs need printing.")
(ETHERINTERRUPT FLAG) (* \; "Ether packet read finished.")
(IOINTERRUPT FLAG)
(GCDISABLED FLAG) (* \; "No mroe room in GC tables.")
(VMEMFULL FLAG) (* \; "VMEM is full!!")
(STACKOVERFLOW FLAG) (* \; "Stack overflowed.")
(STORAGEFULL FLAG) (* \; "Ran out of storage, atoms, etc.")
(WAITINGINTERRUPT FLAG)
(* |;;| "INTERRUPTS-IN-PROCESS MASK:")
(* |;;| "INTERRUPTS-IN-PROCESS MASK:")
(P-LOGMSGSPENDING FLAG) (* \;
 " Log/Console msgs need printing.")
(P-ETHERINTERRUPT FLAG) (* \; "Ether packet read finished.")
(P-IOINTERRUPT FLAG)
(P-GCDISABLED FLAG) (* \; "No mroe room in GC tables.")
(P-VMEMFULL FLAG) (* \; "VMEM is full!!")
(P-STACKOVERFLOW FLAG) (* \; "Stack overflowed.")
(P-STORAGEFULL FLAG) (* \;
 "Ran out of storage, atoms, etc.")
(P-WAITINGINTERRUPT FLAG)
(INTCHARCODE WORD))
(BLOCKRECORD INTERRUPTSTATE (
(* |;;|
 "Alternative view of the structure:")
(P-LOGMSGSPENDING FLAG) (* \; " Log/Console msgs need printing.")
(P-ETHERINTERRUPT FLAG) (* \; "Ether packet read finished.")
(P-IOINTERRUPT FLAG)
(P-GCDISABLED FLAG) (* \; "No mroe room in GC tables.")
(P-VMEMFULL FLAG) (* \; "VMEM is full!!")
(P-STACKOVERFLOW FLAG) (* \; "Stack overflowed.")
(P-STORAGEFULL FLAG) (* \; "Ran out of storage, atoms, etc.")
(P-WAITINGINTERRUPT FLAG)
(INTCHARCODE WORD))
(BLOCKRECORD INTERRUPTSTATE (
(* |;;| "Alternative view of the structure:")
(PENDING BITS 8)
(PENDING BITS 8)
(* \; "Pending-interrupt flags")
(IN-PROGRESS BITS 8)
(IN-PROGRESS BITS 8)
(* \;
 "Mask to prevent re-interrupt for an interrupt in progress")
(NIL WORD))))
 "Mask to prevent re-interrupt for an interrupt in progress")
(NIL WORD))))
)
(PUTPROPS \\TAKEINTERRUPT DMACRO ((PREFORM POSTFORM)
(DECLARE (GLOBALVARS \\PENDINGINTERRUPT))
(COND
((AND \\PENDINGINTERRUPT (INTERRUPTABLE~=NILUPTHESTACK))
PREFORM
((LAMBDA (\\INTERRUPTABLE)
(\\CALLINTERRUPTED))
T)
POSTFORM))))
(DECLARE (GLOBALVARS \\PENDINGINTERRUPT))
(COND
((AND \\PENDINGINTERRUPT (INTERRUPTABLE~=NILUPTHESTACK))
PREFORM
((LAMBDA (\\INTERRUPTABLE)
(\\CALLINTERRUPTED))
T)
POSTFORM))))
(* "END EXPORTED DEFINITIONS")
@ -789,16 +795,18 @@ DONTCOPY
(DECLARE\: EVAL@COMPILE
(PUTPROPS \\SYSTEMINTERRUPTP MACRO ((KEY)
(ASSOC KEY \\SYSTEMINTERRUPTS)))
(ASSOC KEY \\SYSTEMINTERRUPTS)))
)
)
(PUTPROPS AINTERRUPT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1989 1990
1992))
(DECLARE\: DONTEVAL@LOAD DOCOPY
(INTCHAR T)
)
(DECLARE\: DONTCOPY
(FILEMAP (NIL (2572 28843 (INTCHAR 2582 . 7650) (INTERRUPTCHAR 7652 . 7926) (INTERRUPTED 7928 . 15507)
(LISPINTERRUPTS 15509 . 16026) (\\DOHELPINTERRUPT 16028 . 16926) (\\DOHELPINTERRUPT1 16928 . 18326) (
\\DOINTERRUPTHERE 18328 . 19508) (\\PROC.FINDREALFRAME 19510 . 20314) (\\SETPRINTLEVEL 20316 . 22268)
(\\SETRECLAIMMIN 22270 . 23143) (GETINTERRUPT 23145 . 24519) (CURRENTINTERRUPTS 24521 . 24731) (
SETINTERRUPT 24733 . 26711) (RESET.INTERRUPTS 26713 . 28670) (INTERRUPTABLE 28672 . 28841)) (28991
34975 (CONTROL-T 29001 . 34442) (\\CONTROL-T.PRINTRATIO 34444 . 34973)))))
(FILEMAP (NIL (2924 29142 (INTCHAR 2934 . 7957) (INTERRUPTCHAR 7959 . 8233) (INTERRUPTED 8235 . 15814)
(LISPINTERRUPTS 15816 . 16343) (\\DOHELPINTERRUPT 16345 . 17243) (\\DOHELPINTERRUPT1 17245 . 18643) (
\\DOINTERRUPTHERE 18645 . 19825) (\\PROC.FINDREALFRAME 19827 . 20631) (\\SETPRINTLEVEL 20633 . 22585)
(\\SETRECLAIMMIN 22587 . 23460) (GETINTERRUPT 23462 . 24818) (CURRENTINTERRUPTS 24820 . 25030) (
SETINTERRUPT 25032 . 27010) (RESET.INTERRUPTS 27012 . 28969) (INTERRUPTABLE 28971 . 29140)) (29562
35546 (CONTROL-T 29572 . 35013) (\\CONTROL-T.PRINTRATIO 35015 . 35544)))))
STOP

BIN
sources/AINTERRUPT.LCOM
View File

Binary file not shown.