;     Fortran Friends 2018
;             corrections history
;   wimpprint MAIN -> main and s_st -> _sto for ROOL compiler       27/06/2018
;   wploop_ (saveclik) close menu tree after 'Cancel' with <Select> 26/2/2007
;   wpgtth_ new routine to find task handle
;
    TTL    wimp_data
    EXPORT WP_bloc
    AREA   |C$$data|,DATA
WP_bloc
    %      300             ;Wimp communications block (44 + 255 byte filename)
    %      256             ;temporary store
    DCD    0               ;0 before init, 1 before poll, -1 after poll (556)
    DCD    0               ;task handle (560)
    DCD    0,0,0,0,0       ;task name (564)
    DCD    0               ;pointer to wimp poll mask (584)
    DCD    0               ;poll idle time (588)
    DCD    0               ;poll quit flag (592)
    DCD    0               ;address of current top menu (596)
    DCD    0               ;x of current top menu (600)
    DCD    0               ;y of current top menu (604)
    DCD    0               ;address of baricon menu (608)
    DCD    0               ;baricon handle (612)
    DCD    0               ;start of real time (616)
    DCD    0               ;start of CPU time (620)
    DCD    0               ;handle of save window(624)
    DCD    0               ;address of file name in save box (628)
    DCD    0               ;address of leaf name in save box (632)
    DCD    0               ;maximum length of save name (636)
    DCD    0               ;estimated file length (640)
    DCD    0               ;file type (644)
    DCD    0               ;wimp version (648)
    DCD    0               ;shut-down task handle (652)
    DCD    0               ;shut-down type (656)
    DCD    0               ;reference number (660)
    DCD    0               ;# save boxes (664)
    %      16*4            ;space for 16 save windows (668)
    DCB    0               ;# panes (732)
    %      7               ;sides for panes (733)
    %      2*4*7           ;pane handle, host handle (740)
    DCD    0               ;drawing in progress flag (796)
    DCD    0               ;number of sprite windows (800)
    DCD    0               ;pointer to active sprite window data (804)
    DCB    "    F77_WimpXXXX    ";handle(4), name(12), height(4) (808)
    DCB    "    F77_WimpXXXX    ";(828)
    DCB    "    F77_WimpXXXX    ";(848)
    DCB    "    F77_WimpXXXX    ";(868)
    DCB    "    F77_WimpXXXX    ";(888)
    DCB    "    F77_WimpXXXX    ";(908)
    DCB    "    F77_WimpXXXX    ";(928)
    DCB    "    F77_WimpXXXX    ";(948)
    DCD    0               ;wploop's fp for emergencies (968)  06/02/97
    DCD    0               ;file type sent to WQRFIL (972) 11/8/97
    %      24              ;caret position while saving files (976) 14/01/98
    %      4*2*5           ;handle/address of (up to) 5-level menu (1000)
;                         (1040)
    END
;
;                     U T I L I T I E S
;
    TTL    WP_err1
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
depth              EQU    2;trace back depth
OS_BinaryToDecimal EQU    &28
Wimp_ReportError   EQU &400DF
    AREA   |C$$code|,CODE,READONLY
    EXPORT WP_err1         ;internal error report
    EXPORT WP_err2         ;internal error report with integer
    EXPORT WP_err3         ;standard error message
    IMPORT WP_kill
    IMPORT WP_bloc
;        ip points to error string
;        if it includes  include string at R0 here
;        or decoded integer R0 for WP_err2
;        calls WP_kill if 'Cancel' requested
WP_err3
    STMFD  sp!,{R0-R6,lr}
    ADR    ip,sms
    ADD    R0,R0,#4
    B      er1
WP_err2
    STMFD  sp!,{R0-R6,lr}
    LDR    R1,ptr
    ADD    R1,R1,#240      ;move it out the way
    MOV    R2,#12
    SWI    OS_BinaryToDecimal
    MOV    R3,#0
    STRB   R3,[R1,R2]
    MOV    R0,R1
    B      er1
WP_err1
    STMFD  sp!,{R0-R6,lr}
er1 LDR    R2,ptr
    LDRB   R1,[ip],#1      ;flag byte
    STR    R1,[R2],#4      ;store error number
    MOV    R5,#depth       ;trace back depth
lp1 LDRB   R3,[ip],#1
    CMP    R3,#""         ;check for ""
    STRNEB R3,[R2],#1      ;transfer to buffer
    BLEQ   lp3
    CMP    R3,#0
    BNE    lp1             ;loop until terminator
    TST    R1,#128
    BNE    ntb             ;no trace-back
;           now put in trace back
    CMP    R5,#depth
    ADR    ip,erm
    ADDLT  ip,ip,#6
    MOVEQ  R6,fp           ;pointer to first frame
    LDRLT  R6,[R6,#-12]    ;pointer to next frame
    LDR    R0,[R6]         ;stored pc
    BIC    R0,R0,#&FC000003
lp2 LDR    R4,[R0,#-4]!
    CMP    R4,#&FF000000
    BCC    lp2             ;find header pointer
    BIC    R4,R4,#&FF000000
    SUB    R0,R0,R4        ;pointer to name
    SUBS   R5,R5,#1
    SUBGE  R2,R2,#1
    BGE    lp1
ntb LDR    R0,ptr
    STR    R3,[R0]         ;set error to zero                24/02/97
    AND    R1,R1,#3
    ADD    R2,R0,#264      ;pointer to task name
    SWI    Wimp_ReportError
    CMP    R1,#2
    BEQ    WP_kill
    LDMFD  sp!,{R0-R6,pc} 
;
lp3 LDRB   R4,[R0],#1      ;get string at R0
    CMP    R5,#depth-1
    BGE    lp4
    CMP    R4,#"_"         ;fortran routine, make upper case
    MOVEQ  pc,lr
    SUBGT  R4,R4,#32
lp4 CMP    R4,#0
    STRNEB R4,[R2],#1      ;transfer to buffer
    BNE    lp3
    MOV    pc,lr
ptr DCD    WP_bloc+300     ;space for message
sms DCB    3,"",0
erm DCB    " in ",0," called from ",0
    END
;
    TTL    WP_drck
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R8  RN     8
R9  RN     9
temp              EQU  300 ;this must be the same as in wpupdt
Wimp_GetRectangle EQU &400CA
    AREA   |C$$code|,CODE,READONLY
    EXPORT WP_drck         ;check we are not drawing
    IMPORT wimpprint
    IMPORT WP_bloc
    IMPORT WP_orig
WP_drck
    STMFD  sp!,{R8,R9,lr}
    LDR    R8,ptr
    LDR    R9,[R8,#796]    ;get drawing status
    CMP    R9,#0           ;test state and save it
    LDMEQFD sp!,{R8,R9,pc} ;OK
    LDR    R1,ptr          ;set up R1 for WPPLOT loop
    ADDLT  R1,R1,#temp     ;or for the WPUPDT loop
    MOV    R2,#0
    MOV    R3,#0
    BL     WP_orig         ;restore origin
drl SWI    Wimp_GetRectangle;get next rectangle to draw
    CMP    R0,#0
    BNE    drl
;           killed redraw loop
    STR    R0,[R8,#796]    ;reset drawing status
;
    LDR    R2,[fp]         ;pc of frame with problem
    TEQ    pc,pc
    BICNE  R2,R2,#&FC000003;remove status bits
lp4 LDR    R1,[R2,#-4]!
    CMP    R1,#&FF000000
    BCC    lp4             ;find header pointer
    BIC    R1,R1,#&FF000000
    SUB    R1,R2,R1        ;pointer to name
    CMP    R9,#0
    ADRGT  R2,em3
    ADRLE  R2,em2
    ADR    R0,em1
    LDMDB  fp,{fp,sp,lr}   ;point to previous frame
    B      wimpprint
;
ptr DCD    WP_bloc
em1 DCB    "You cannot call %s in %s",0
em2 DCB    "WQUPDT",0
em3 DCB    "WQPLOT",0
    END
;
    TTL    WP_GetI
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
R1  RN     1
R0  RN     0
Wimp_GetIconState  EQU  &600CE
Wimp_GetWindowInfo EQU  &600CC
    AREA   |C$$code|,CODE,READONLY
    EXPORT WP_GetI         ;finds indirected text
    IMPORT WP_bloc
    IMPORT WP_err2
    IMPORT WP_err3
;    input  R0: *(window handle),  R1: *(icon handle)
;    output R0: address of text,  R1: length of buffer
;    NE if no good with R0=-1 for not found, =-2 for not indirected text
;                         >0 for wrong wimp version for title
WP_GetI
    STR    lr,[sp,#-4]!
    LDR    R0,[R0]         ;window handle
    LDR    ip,[R1]         ;icon handle
    LDR    R1,ptr
    STMIA  R1,{R0,ip}      ;set initial block
    CMP    ip,#-1          ;check if window title
    BEQ    titl
    SWI    Wimp_GetIconState;ordinary
    BVS    err3
inf LDR    ip,[R1,#24]     ;icon flags
    AND    ip,ip,ip,LSR#8
    TST    ip,#1           ;check for indirected text
    BNE    GT2
    ADR    ip,em1
    LDR    R0,[R1,#4]      ;icon number
    BL     WP_err2         ;error message
    MOVS   R0,#-2
    LDR    pc,[sp],#4
GT2 LDR    R0,[R1,#28]     ;address of text
    LDR    R1,[R1,#36]     ;buffer length
    CMP    R0,R0           ;set EQ
    LDR    pc,[sp],#4
titl;    title icon
    LDR    R0,[R1,#648-300];Wimp version
    CMP    R0,#300         ;check for RISC_OS 3
    BGE    RO3
    ADR    ip,em2
    BL     WP_err2
    MOVS   R0,#-3
    LDR    pc,[sp],#4
RO3 ORR    R1,R1,#1        ;set bit 0 for just window header
    SWI    Wimp_GetWindowInfo
    BIC    R1,R1,#1
    LDR    lr,[R1,#60]     ;Title bar icon flags
    STR    lr,[R1,#72]
    ADD    R1,R1,#48       ;pointer to pseudo-icon block
    STR    ip,[R1,#4]
    BVC    inf
;
err3 BL     WP_err3
    MOVS   R0,#-1
    LDR    pc,[sp],#4      ;icon not found
ptr DCD    WP_bloc+300     ;working space
em1 DCB    3,"Icon () does not contain indirected text",0
em2 DCB    3,"You can not write to a window title with RISC-OS 2",0
    END
;
    TTL    wp_kill
R0  RN     0
Wimp_CloseDown        EQU &400DD
    AREA   |C$$code|,CODE,READONLY
    EXPORT WP_kill         ;kills off the job pronto
    IMPORT WP_bloc
    IMPORT fortran_exit
WP_kill
    LDR    R0,ptr          ;block space
    LDR    R0,[R0,#556]    ;get status
    CMP    R0,#0
    SWINE  Wimp_CloseDown
    MOV    R0,#1           ;error status
    B      fortran_exit
ptr DCD    WP_bloc
    END
;
    TTL    wp_menu
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
R0  RN     0
R1  RN     1
R2  RN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT WP_menu         ;finds the address of a menu entry
    IMPORT WP_err2
;        I/P  R1: menu block, R2 : address of index
;        O/P  R1: pointer to entry, return EQ
;           or return NE if index out of bounds
WP_menu
    STMFD  sp!,{R0,lr}
    LDR    R0,[R2]         ;index
    ADD    R1,R1,#28       ;pointer to entry 0
lm1 CMP    R0,#0
    LDMEQFD sp!,{R0,pc}    ;finished OK
    SUBS   R0,R0,#1
    LDRGEB ip,[R1],#24
    TSTGE  ip,#&80
    BEQ    lm1             ;try next
    ADR    ip,erm
    LDR    R0,[R2]         ;faulty index
    BL     WP_err2
    MOVS   R0,#-1          ;flag failure
    LDMFD  sp!,{R0,pc}     ;hit end of block
erm DCB    3,"Index () out of range",0
    END
;
    TTL    wp_savw
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT WP_savw         ;finds the address of a menu entry
    IMPORT WP_bloc
;        I/P  R0: window handle
;        O/P    : EQ if save window, LT if not
WP_savw
    STMFD  sp!,{R1-R3,lr}
    LDR    R1,ptr
    LDR    R2,[R1],#4      ;#save windows
ls1 SUBS   R2,R2,#1
    LDMLTFD sp!,{R1-R3,pc} ;no save windows
    LDR    R3,[R1],#4      ;get save window handle
    CMP    R3,R0
    BNE    ls1             ;not the required one, try again
    LDMFD  sp!,{R1-R3,pc}
ptr DCD    WP_bloc+664
    END
;
    TTL    WP_SetI
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
Wimp_SetIconState     EQU  &600CD
Wimp_GetCaretPosition EQU  &600D3
Wimp_SetCaretPosition EQU  &600D2
    AREA   |C$$code|,CODE,READONLY
    EXPORT WP_SetI         ;displays the icon
    IMPORT WP_drck          ;                          17/03/97
    IMPORT WP_bloc
WP_SetI;
    BL     WP_drck         ;                           17/03/97
    LDMIA  sp,{R0,R1}      ;restore pointers to window and icon handles
    LDR    R3,[R1]         ;icon handle
    LDR    R2,[R0]         ;window handle
    LDR    R1,tmp          ;block space
    MOV    ip,#1
    MOV    lr,#1
    STMIA  R1,{R2,R3,ip,lr};store window/icon handles, EOR & clear words
    CMP    R3,#-1          ;check for window title
    BEQ    SI1
    SWI    Wimp_SetIconState
    LDMDB  fp,{R4,R5,fp,sp,pc} ;return OK
SI1 ADD    R1,R1,#32       ;move to new space
    MOV    ip,R1
    SWI    Wimp_GetCaretPosition;preserve current caret position
    LDR    R0,[ip,#-32]    ;window handle
    MOV    R1,#-1
    MOV    R2,#0
    MOV    R3,#0
    MOV    R4,#0
    MOV    R5,#0
    SWI    Wimp_SetCaretPosition;redraw title
    LDMIA  ip,{R0-R5}
    SWI    Wimp_SetCaretPosition;restore current caret position
    LDMDB  fp,{R4,R5,fp,sp,pc} ;return OK
tmp DCD    WP_bloc+300
    END
;
;             PAUSE for the wimp
;
    TTL s_paus
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
OS_Byte           EQU &06
OS_ReadC          EQU &20004
OS_Write0         EQU &02
OS_WriteC         EQU &00
OS_WriteN         EQU &46
Wimp_ReportError  EQU &400DF
    AREA   |C$$code|,CODE,READONLY
    EXPORT s_paus          ;(string)
    IMPORT WP_drck
    IMPORT WP_bloc
    IMPORT WP_kill
    DCB    "PAUSE ",0,0,8,0,0,255
s_paus
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
;          set up message
    LDR    R3,tmp
    ADR    R2,pse
lp1 LDRB   lr,[R2],#1
    CMP    lr,#":"
    CMPEQ  R1,#0
    STRNEB lr,[R3],#1      ;skip ":" if no message
    CMP    lr,#" "
    BNE    lp1
lp2 SUBS   R1,R1,#1
    LDRGEB lr,[R0],#1
    STRGEB lr,[R3],#1
    BGT    lp2
    LDR    R0,tmp          ;pointer to message
    LDR    ip,[R0,#556-300];get wimp status
    CMP    ip,#0
    BNE    wimp            ;in the wimp
    SUB    R1,R3,R0        ;length of message
    SWI    OS_WriteN
lp3 ADR    R0,msg
    SWI    OS_Write0       ;send prompt
    MOV    R0,#15
    MOV    R1,#1
    SWI    OS_Byte         ;flush I/P buffer
    SWI    OS_ReadC        ;read character
    BVS    WP_kill
    SWI    OS_WriteC
    CMP    R0,#"y"
    CMPNE  R0,#"n"
    BNE    lp3
    CMP    R0,#"n"
    BEQ    WP_kill
    LDMDB  fp,{fp,sp,pc}   ;return
wimp;   wimp environment here
    MOV    ip,#0           ;                                  24/02/97
    STR    ip,[R0,#-4]!    ;allow for error code              24/02/97
    MOV    R1,#&13
    LDR    R2,tit
    SWI    Wimp_ReportError
    CMP    R1,#1
    BNE    WP_kill
    LDMDB  fp,{fp,sp,pc}   ;return
tmp DCD    WP_bloc+300
tit DCD    WP_bloc+564
pse DCB    "Pause: "
msg DCB    13,10," Continue? (y/n) ",0
    END
;
;             W P x x x x R O U T I N E S
;
    TTL    wpadni
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
R9  RN     9
Wimp_CreateIcon  EQU &600C2
Wimp_TextOp      EQU &600F9
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpadni_         ;(IWH,IX,IY,ITYPE,STRING,IH)
    IMPORT WP_drck
    IMPORT WP_err2
    IMPORT WP_err3
;      IH>= 0: OK
;          -1: Illegal window handle
;          -2: Illegal ITYPE
;          -3: STRING not null terminated
    DCB    "WPADNI",0,0,8,0,0,255
wpadni_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R9,[R3]         ;ITYPE
    MOV    ip,#31          ;maximum ESG
lp1 SUBS   R9,R9,#100
    SUBGES ip,ip,#1
    BGT    lp1
    ADDS   R9,R9,#100      ;restore MOD(ITYPE,100)
    RSBGES lr,R9,#12
    CMPGE  ip,#0           ;ESG>31 or IT<0  or IT>12-> fail
    BGE    AI1
    ADR    ip,em1
    LDR    R0,[R3]
    BL     WP_err2
    MOV    R0,#-2
    B      fin
AI1 MOV    R4,#48          ;basic height of icon
    RSB    ip,ip,#31       ;ESG#
    ADR    R5,icf          ;standard icon flags
    LDR    R5,[R5,R9,LSL#2];icon flags
    ORR    R5,R5,ip,LSL#16 ;add in ESG
    CMP    R9,#9           ;if ITYPE>9 then no text
    MOVGT  R7,#48          ;width of no-text sprite
    ADRGT  R6,vs1          ;address of null text
    MOVGT  R8,#1           ;length of no-text
    BGT    pt1
    LDMIB  fp,{R6-R8}      ;(STRING), (IH)(not used), LEN(STRING)
lp2 SUBS   R8,R8,#1
    LDRGEB lr,[R6,R8]
    CMPGE  lr,#0           ;check for null terminator
    BGT    lp2
    BEQ    AI2
    ADR    ip,em2          ;no null terminator
    BL     WP_err2
    MOV    R0,#-3
    B      fin
AI2 ADD    R8,R8,#1        ;correct length of text
    MOV    R0,#1
    MOV    R1,R6
    SWI    Wimp_TextOp     ;get length of text
    ADDVC  R7,R0,#32       ;icon width = text length + 16
    MOVVS  R7,#16
    ADDVS  R7,R7,R8,LSL#4  ; or 16*LEN+16 if TextOp fails
    CMP    R9,#6           ;for default slab
    CMPNE  R9,#7           ;or editable field,
    ADDEQ  R7,R7,#16       ;increase width of icon
    CMPNE  R9,#3           ;also height for 'ridge'
    CMPNE  R9,#4           ;and 'channel'
    ADDEQ  R4,R4,#16
    CMP    R9,#8
    CMPNE  R9,#9
    ADDEQ  R7,R7,#32       ; allow for radio/opt sprite    19/08/01
    LDMIA  sp,{R0-R2}      ;restore arguments
pt1 LDR    R0,[R0]         ;window handle (=IWH)
    LDR    R1,[R1]         ;X low (=IX)
    LDR    R2,[R2]         ;Y low (=IY)
    ADD    R3,R7,R1        ;X high
    ADD    R4,R4,R2        ;Y high
    ADR    R7,vs1          ;initial validation string
lp3 LDRB   lr,[R7],#1
    CMP    lr,#0
    BNE    lp3
    SUBS   R9,R9,#1
    BGE    lp3
    STMFD  sp!,{R0-R8}     ;store icon block
    MOV    R1,sp
    SWI    Wimp_CreateIcon
    BLVS   WP_err3
    MOVVS  R0,#-1          ;error icon handle
fin LDR    ip,[fp,#8]      ;(IH)
    STR    R0,[ip]         ;store icon handle
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
icf DCD    &17000119       ;basic icon flags
    DCD    &1700013D       ;1 slab out
    DCD    &1700013D       ;2 slab in
    DCD    &1700011D       ;3 ridge
    DCD    &1700011D       ;4 channel
    DCD    &1700313D       ;5 action
    DCD    &1700313D       ;6 default action
    DCD    &0700F13D       ;7 editable
    DCD    &1700B113       ;8 option
    DCD    &1700B113       ;9 radio
    DCD    &1700311B       ;10 menu
    DCD    &1100211B       ;11 up
    DCD    &1100211B       ;12 down
em1 DCB    3,"Illegal icon type: ",0
em2 DCB    3,"icon text not null terminated",0
    ALIGN
vs1 DCB    0,0,"R1",0,"R2",0,"R3",0,"R4",0,"R5,3",0,"R6,3",0,"R7",0
    DCB    "Soptoff,opton",0,"Sradiooff,radioon",0,"sgright,pgright",0
    DCB    "sup,pup",0,"sdown,pdown",0
    END

;
    TTL    wpadsi
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
OS_ReadModeVariable EQU &35
OS_SpriteOp         EQU &2002E
Wimp_CreateIcon     EQU &600C2
Wimp_SpriteOp       EQU &600E9
Wimp_GetWindowInfo  EQU  &600CC
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpadsi_         ;(IWH,IWX,IWY,SN,IH)
    IMPORT WP_drck
    IMPORT WP_err1
    IMPORT WP_err3
    IMPORT WP_win
    IMPORT WP_bloc
    DCB    "WPADSI",0,0,8,0,0,255
wpadsi_
    MOV    ip,sp
    STMDB  sp!,{R4-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R4,[ip,#4]      ;length of name
    LDR    ip,[ip]         ;pointer to IH
    LDR    R0,[R0]         ;IWH
    LDR    R1,[R1]         ;IWX
    LDR    R2,[R2]         ;IWY
    STMFD  sp!,{R0-R2}     ;save IWH,IWX,IWY
    MOV    R1,#-1
    STR    R1,[ip]         ;pre-set IH to -1
    CMP    R4,#12
    BLE    AI1
    ADR    ip,em1
    BL     WP_err1
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return if name is too long
AI1 LDR    R2,tmp
    MOV    R5,#0
ls1 STRB   R5,[R2,R4]
    SUBS   R4,R4,#1
    LDRGEB R5,[R3,R4]
    BGE    ls1             ;move name
    ADD    R1,R2,#12       ;space for window block         02/05/97
    STR    R0,[R1],#1      ;store window handle
    SWI    Wimp_GetWindowInfo
    BVS    err
    BIC    R1,R1,#1
    LDR    R1,[R1,#68]     ;sprite control block           02/05/97
    MOV    R0,#40          ;SpriteOp #40
    CMP    R1,#1
    ADDGT  R0,R0,#256      ;add 256 for user area
    BNE    AI2
    SWI    Wimp_SpriteOp
    B      AI3
AI2 SWI    OS_SpriteOp
AI3 BVS    err
    LDMIA  R2,{R1,R2,R5}
    LDR    R0,nam
    STMIA  R0,{R1,R2,R5}   ;store name in icon block
    MOV    R0,R6           ;sprite screen mode
    MOV    R1,#4           ;x-scaling
    SWI    OS_ReadModeVariable
    MOV    R5,R3,LSL R2    ;x-size of sprite (OS units)
    MOV    R1,#5           ;y-scaling
    SWI    OS_ReadModeVariable
    MOV    R6,R4,LSL R2    ;y-size of sprite (OS units)
    LDMIA  sp!,{R0,R2,R3}  ;restore IWH,IWX,IWY
    ADD    R5,R5,R2        ;IXHigh
    ADD    R6,R6,R3        ;IYHigh
    LDR    R1,ptr
    STMIA  R1,{R0,R2,R3,R5,R6};store sprite position
    SWI    Wimp_CreateIcon
    STRVC  R0,[ip]         ;store good icon handle
;        error here
err BLVS   WP_err3
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
tmp DCD    WP_bloc+256     ;space for sprite name
win DCD    WP_win
ptr DCD    WP_spicon
nam DCD    icn
em1 DCB    3,"sprite name >12 characters",0
;
    EXPORT WP_spicon
    AREA   WP_spicon,DATA
    %      4               ;window handle
    %      4               ;x-low
    %      4               ;y-low
    %      4               ;x-high
    %      4               ;y-high
    DCD    &0700B01E       ;icon flags
icn %     12               ;icon name
    END
;
    TTL    wpadti
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
Wimp_CreateIcon  EQU &600C2
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpadti_         ;(IWH,IX,IY,ISX,ISY,ST,SV,IH)
    IMPORT WP_drck
    IMPORT WP_err1
    IMPORT WP_err2
    IMPORT WP_err3
    DCB    "WPADTI",0,0,8,0,0,255
wpadti_
    MOV    ip,sp
    STMDB  sp!,{R4-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDMIA  ip,{R4-R8}      ;get the other 4 arg addresses & length of ST
    LDR    R0,[R0]         ;IWH
    LDR    R1,[R1]         ;IX
    LDR    R2,[R2]         ;IY
    LDR    R3,[R3]         ;ISX
    LDR    R4,[R4]         ;ISY
    ADD    R3,R3,R1        ;IX-end
    ADD    R4,R4,R2        ;IY-top
    LDR    ip,ptr
    STMIA  ip!,{R0-R4}     ;1st five words of icon block
    LDR    R0,[ip],#4      ;get flags
    MOV    R2,R0           ;save flags
    SUBS   R1,ip,#24       ;pointer to block (& clear overflow)
    TST    R0,#&100        ;test indirection bit
    CMPEQ  R8,#12
    BLE    ad1             ;normal string
    STMIA  ip,{R5,R6,R8}   ;store pointers for indirected string
    SUB    R8,R8,#1
la1 LDRB   lr,[R5,R8]
    CMP    lr,#0           ;check for null terminator
    BEQ    ad0
    SUBS   R8,R8,#1
    BGE    la1
    ADR    ip,erm
er1 BL     WP_err1
    MOV    R0,#-1
    B      ad3
ad0 ORR    R0,R0,#&100
    STR    R0,[ip,#-4]     ;set indirected bit
    B      ad2
ad1 MOV    R0,#0           ;store text in icon
    STRLTB R0,[ip,R8]      ;null terminator
la2 SUBS   R8,R8,#1
    LDRB   R0,[R5,R8]
    STRB   R0,[ip,R8]
    BGT    la2
ad2 SWI    Wimp_CreateIcon
    STR    R2,[R1,#20]     ;restore flags
;       error here
    BLVS   WP_err3
    MOVVS  R0,#-1          ;error icon handle
ad3 STR    R0,[R7]         ;store icon handle
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
ptr DCD    WP_txicon
erm DCB    3,"no null terminator in indirected string",0
;
    EXPORT WP_txicon
    AREA   WP_txicon,DATA
    %      4               ;window handle
    %      4               ;x-low
    %      4               ;y-low
    %      4               ;x-high
    %      4               ;y-high
    DCD    &C700B03D       ;icon flags
    %     12               ;icon data
    END
;
    TTL    wpaint
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R4  RN     4
R6  RN     6
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpaint_         ;(STRING) send file to !Paint
    IMPORT WP_sfile6
    DCB    "WPAINT",0,0,8,0,0,255
wpaint_
    MOV    ip,sp
    STMDB  sp!,{R4-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R6,#&FF0
    ADD    R6,R6,#&9       ;paint filetype is FF9
    B      WP_sfile6
    END
;
    TTL    wpam2m
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpam2m_         ;(IMB2,IMB,INDEX)
    IMPORT WP_menu
    DCB    "WPAM2M",0,0,8,0,0,255
wpam2m_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_menu
    STREQ  R0,[R1,#4]      ;store new pointer
    LDMDB  fp,{fp,sp,pc}   ;return
    END
;
    TTL    wpaw2m
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
Wimp_GetWindowState  EQU &600CB
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpaw2m_         ;(IWH,IMB,INDEX)
    IMPORT WP_menu
    IMPORT WP_err3
    IMPORT WP_bloc
    DCB    "WPAW2M",0,0,8,0,0,255
wpaw2m_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_menu
    LDMNEDB fp,{fp,sp,pc}  ;return error
    LDR    R2,[R0]         ;get window handle
    ADD    R3,R1,#4        ;address for pointer
    LDR    R1,ptr
    STR    R2,[R1]
    SWI    Wimp_GetWindowState
    STRVC  R2,[R3]         ;store new pointer
    BLVS   WP_err3
    LDMDB  fp,{fp,sp,pc}   ;return
ptr DCD    WP_bloc+300
    END
;
    TTL    wpaz2m
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpaz2m_         ;(IMB,INDEX)
    IMPORT WP_menu
    DCB    "WPAZ2M",0,0,8,0,0,255
wpaz2m_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIA  sp,{R1,R2}      ;move up arguments
    BL     WP_menu
    MOVEQ  R0,#-1          ;no pointer
    STREQ  R0,[R1,#4]      ;store new pointer
    LDMDB  fp,{fp,sp,pc}   ;return
    END
;
    TTL    wpbari
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
Wimp_CreateIcon  EQU &600C2
Wimp_SpriteOp   EQU &600E9
Wimp_TextOp     EQU &600F9
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpbari_         ;(SN,IP,IMB,IH)
    EXPORT wpbart_         ;(SN,IP,IMB,TXT,IH)
    IMPORT WP_err1
    IMPORT WP_err2
    IMPORT WP_err3
    IMPORT WP_bloc
    IMPORT WP_drck
    DCB    "WPBART",0,0,8,0,0,255
wpbart_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R5,ptr
    STR    R3,[R5,#24]     ;store pointer to TXT
    LDR    lr,[fp,#12]
    STR    lr,[R5,#32]     ;store length of TXT
    MOV    R1,R3
lb1 LDRB   R0,[R3],#1
    CMP    R0,#31
    SUBGTS lr,lr,#1
    BGT    lb1
    CMP    lr,#0
    STREQB lr,[R3,#-1]     ;null terminate if not already done
    SUB    lr,R3,R1
    MOV    R0,#1
    MOV    R2,#0
    SWI    Wimp_TextOp     ;get length of text
    MOVVC  lr,R0           ;icon width = text length
    MOVVS  lr,lr,LSL#4
    SUBVS  lr,lr,#16
    CMP    lr,#68
    MOVLE  lr,#68
    STR    lr,[R5,#12]     ;width of icon
    LDMIA  sp,{R0-R2}      ;restore registers
    LDR    R3,[fp,#4]      ;(IH)
    ADD    R4,R5,#40       ;space for name
    STR    R4,[R5,#28]     ;store address
    MOV    lr,#"S"
    STRB   lr,[R4],#1      ;"S" validation string
    MOV    lr,#88
    STR    lr,[R5,#16]     ;height of icon (32+sprite)
    MOV    lr,#-16
    STR    lr,[R5,#8]
    LDR    ip,[fp,#8]      ;length of SN
    MOV    R6,#4
    B      br1
;
    DCB    "WPBARI",0,0,8,0,0,255
wpbari_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R5,ptr
    ADD    R4,R5,#24       ;pointer to name
    LDR    ip,[ip]         ;length of SNAME
    MOV    lr,#68          ;standard sprite size
    STR    lr,[R5,#12]     ;x-sprite
    STR    lr,[R5,#16]     ;y-sprite
    MOV    R6,#0           ;flag wpbari
    STR    R6,[R5,#8]      ;y-min
br1 MOV    lr,#-1
    STR    lr,[R3]         ;preset IH illegal
    CMP    ip,#12
    ADRGT  ip,em1
    BGT    err1            ; SNAME too long
    ADR    lr,flg
    LDR    lr,[lr,R6]
    STR    lr,[R5,#20]     ;store icon flags
    MOV    lr,#0
lb2 STRB   lr,[R4,ip]
    SUBS   ip,ip,#1
    LDRGEB lr,[R0,ip]
    BGE    lb2
    LDR    lr,[R1]         ;IP
    ADDS   R1,lr,#2        ;test for -2
    RSBGES R1,R1,#1        ;or -1
    BGE    BI2
    MOV    R0,lr
    ADR    ip,em2
    BL     WP_err2
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return if IP not -1 or -2
BI2 STR    lr,[R5]       ;store "window handle"
    LDR    lr,[R2]
    CMP    lr,#0
    MOVEQ  R2,lr
    LDR    R6,blk
    LDR    lr,[R6,#612]    ;get previous icon handle
    CMP    lr,#0
    ADRNE  ip,em3
    BNE    err1
    STR    R2,[R6,#608]    ;store address of menu
    MOV    R0,#40
    STMFD  sp!,{R3-R6}  ;save registers
    MOV    R2,R4
    SWI    Wimp_SpriteOp   ;check sprite exists
    LDMFD  sp!,{R3-R6}  ;restore registers
    ADRVS  ip,em4
    MOVVS  R0,R2
    BVS    err1
    MOV    R1,R5
    SWI    Wimp_CreateIcon
    STRVC  R0,[R6,#612]    ;store good icon handle in common
    STRVC  R0,[R3]         ;return icon handle
    BLVS   WP_err3
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
;
err1 BL     WP_err1
    LDMDB  fp,{R4-R6,fp,sp,pc}
;
blk DCD    WP_bloc
ptr DCD    icn
flg DCD    &1700300A,&1700310B
em1 DCB    3,"sprite name >12 characters",0
em2 DCB    3,"IPOS () not allowed",0
em3 DCB    3,"Icon already on icon-bar",0
em4 DCB    3,"sprite '' not found",0
    AREA   |C$$data|,DATA
icn DCD    0,0,0,68,68,&1700300A
    %     16               ;sprite name
    %     16               ;space for indirected names
    END
;
    TTL    wpbegs
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
OS_SpriteOp          EQU &2002E
    AREA   |SpOp_state|,COMMON
    %      4               ;flag: 0 normally, <>0 if pointing to sprite or mask
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpbegs_         ;(IWHAN)
    EXPORT wpends_         ;(IXL,IYL,IXH,IYH)
    IMPORT wpupdt_
    IMPORT WP_err1
    IMPORT WP_bloc
    IMPORT WP_drck
    DCB    "WPBEGS",0,0,8,0,0,255
wpbegs_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R0,[R0]         ;window handle
    LDR    ip,pts          ;pointer to work space
    MOV    R1,ip
    LDR    R2,[ip],#-12    ;number of sprite windows already set up
lp1 SUBS   R2,R2,#1
    ADRLT  ip,em1
    BLT    bad             ;sprite not initialised
    LDR    lr,[ip,#20]!    ;get stored window handle
    CMP    lr,R0           ;look for this window handle in current list
    BNE    lp1
    STR    ip,[R1,#4]      ;store current pointer
    MOV    R0,#60
    ADD    R2,ip,#4        ;pointer to name
    MOV    R3,#0
    SWI    OS_SpriteOp     ;send O/P to sprite
    LDRVC  R1,p60
    STRVC  R0,[R1]         ;flag that VDU is to sprite
    LDMVCDB fp,{fp,sp,pc} ;return
    ADD    R0,ip,#4
    ADR    ip,em2
bad BL     WP_err1
    LDMDB  fp,{fp,sp,pc} ;return
pts DCD    WP_bloc+800     ;pointer to sprite info
em1 DCB    3,"Sprite not initialised by WPMAKS",0
em2 DCB    3,"Problem opening window sprite ()",0
    ALIGN
;
    DCB    "WPENDS",0,0,8,0,0,255
wpends_; restore output to screen and display sprite
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R0,#60
    MOV    R2,#0           ;switch O/P to VDU
    MOV    R3,#1
    LDR    ip,p60
    STR    R2,[ip]         ;set flag to 0 (screen)
    SWI    OS_SpriteOp
    LDR    R4,pts
    LDR    R0,[R4,#4]      ;pointer to window handle
    LDMIA  sp,{R1-R3,ip}   ;addresses of IXL,IYL,IXH,IYH
    LDR    lr,[R1]         ;IXL WPUPDT
    CMP    lr,#0           ;check it is positive
    LDRGE  lr,[R0,#16]     ;window height
    LDRGE  R2,[R2]         ;IYL
    SUBGE  R2,R2,lr        ;IYL - window heigh
    STRGE  R2,[sp,#12]     ;store on stack
    ADDGE  R2,sp,#12       ;pointer to IYL - window height
    LDRGE  ip,[ip]         ;IYH
    SUBGE  ip,ip,lr        ;IYH - window height
    STRGE  ip,[sp,#8]      ;store on stack
    ADDGE  ip,sp,#8        ;pointer to IYH - window height
    STRGE  ip,[sp]         ;last argument on stack
    BL     wpupdt_         ;update window
    MOV    R2,#0
    STR    R2,[R4,#4]      ;kill pointer to sprite window handle
    LDMDB  fp,{R4,fp,sp,pc} 
p60 DCD    |SpOp_state|    ;pointer to screen state
    END
;
    TTL    wpchft
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
Font_SetFont  EQU &6008A
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpchft_         ;(IFONT) change icon text font
    IMPORT WP_txicon
    IMPORT WP_err3
    DCB    "WPCHFT",0,0,8,0,0,255
wpchft_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]         ;IFONT
    SWI    Font_SetFont    ;check font handle is good
    LDRVC  R2,ptr
    LDRVC  R3,[R2,#20]     ;get flag word
    ORRVC  R3,R3,#&40      ;set bit 6
    BICVC  R3,R3,#&FF000000;clear font
    ORRVC  R3,R3,R0,LSL#24 ;insert new font
    STRVC  R3,[R2,#20]     ;store font in flag word
    BLVS   WP_err3
    LDMDB  fp,{fp,sp,pc}   ;return
ptr DCD    WP_txicon
    END
;
    TTL    wpchsa
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpchsa_         ;(IAREA)
    IMPORT WP_err1
    IMPORT WP_win
    DCB    "WPCHSA",0,0,8,0,0,255
wpchsa_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[R0]         ;1st word of new sprite area
    CMP    ip,#0
    MOVLT  R0,#1           ;wimp sprite area
    MOVEQ  R0,#0           ;system sprite area
    RSBGTS ip,ip,#16
    LDRLE  R1,ptr
    STRLE  R0,[R1,#64]     ;store sprite area pointer
    ADRGT  ip,erm
    BLGT   WP_err1
    LDMDB  fp,{fp,sp,pc}   ;return
ptr DCD    WP_win
erm DCB    3,"IAREA is not sprite area",0
    END
;
    TTL    wpchsf
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpchsf_         ;(INDX,SET) change flag
    IMPORT WP_err2
    IMPORT WP_spicon
    DCB    "WPCHSF",0,0,8,0,0,255
wpchsf_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]         ;INDEX
    CMP    R0,#0           ;check for range [0:231]
    RSBGES ip,R0,#231
    BLT    err
    LDR    R2,ptr
    LDR    R3,[R2,#20]     ;flag word
    CMP    R0,#31
    BGT    ntf             ;not flag
    MOV    ip,#1
    MOV    ip,ip,LSL R0    ;required bit
    LDR    R1,[R1]         ;SET
    CMP    R1,#1           ;set Carry if SET is .TRUE.
    LDR    R1,msk
    TST    ip,R1           ;check if bit is allowed
    BNE    err
    ORRCS  R3,R3,ip        ;set bit
    BICCC  R3,R3,ip        ;or clear bit
    B      fin
ntf SUBS   R1,R0,#100
    BLT    err
    CMP    R1,#15
    BGT    ntb             ;not button type
    BIC    R3,R3,#&F000
    ORR    R3,R3,R1,LSL#12 ;store new button type
    B      fin
ntb SUBS   R1,R1,#100
    BLT    err
    BIC    R3,R3,#&1F0000
    ORR    R3,R3,R1,LSL#16 ;store ESG
fin STR    R3,[R2,#20]     ;store flag word
    LDMDB  fp,{fp,sp,pc}   ;return
err ADR    ip,em4
    BL     WP_err2
    LDMDB  fp,{fp,sp,pc}   ;return
ptr DCD    WP_spicon
msk DCD    &FF1FF3DB       ;bits not allowed
em4 DCB    3,"INDEX () out of range",0
    END
;
    TTL    wpchtc
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpchtc_         ;(INDX,KOL) change colour
    IMPORT WP_txicon
    IMPORT WP_err2
    DCB    "WPCHTC",0,0,8,0,0,255
wpchtc_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R0]         ;INDEX
    CMP    R2,#1           ;check for range [0:1]
    ADRHI  ip,em2
    BHI    er2             ;failed
    LDR    R0,[R1]         ;KOLOUR
    CMP    R0,#15
    ADRHI  ip,em3
    BHI    er2             ;failed
    LDR    R1,ptr
    LDR    R3,[R1,#20]     ;get flag word
    BIC    R3,R3,#&40      ;clear font bit
    MOV    R2,R2,LSL#2
    ADD    R2,R2,#24       ;bit position
    MOV    ip,#15          ;mask
    BIC    R3,R3,ip,LSL R2 ;remove old colour
    ORR    R3,R3,R0,LSL R2 ;insert new colour
    STR    R3,[R1,#20]     ;store new flag word
    LDMDB  fp,{fp,sp,pc}   ;return
er2 BL     WP_err2         ;failed
    LDMDB  fp,{fp,sp,pc}   ;return
ptr DCD    WP_txicon
em2 DCB    3,"INDEX () out of range",0
em3 DCB    3,"KOLOUR () out of range",0
    END
;
    TTL    wpchtf
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpchtf_         ;(INDX,SET) change flag
    IMPORT WP_txicon
    IMPORT WP_err2
    DCB    "WPCHTF",0,0,8,0,0,255
wpchtf_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]         ;INDEX
    CMP    R0,#0           ;check for range [0:231]
    RSBGES ip,R0,#231
    BLT    err
    LDR    R2,ptr
    LDR    R3,[R2,#20]     ;flag word
    CMP    R0,#31
    BGT    ntf             ;not flag
    MOV    ip,#1
    MOV    ip,ip,LSL R0    ;required bit
    LDR    R1,[R1]         ;SET
    CMP    R1,#1           ;set Carry if SET is .TRUE.
    LDR    R1,msk
    TST    ip,R1           ;check if bit is allowed
    BNE    err
    ORRCS  R3,R3,ip        ;set bit
    BICCC  R3,R3,ip        ;or clear bit
    B      fin
ntf SUBS   R0,R0,#100
    BLT    err
    CMP    R0,#15
    BGT    ntb             ;not button type
    BIC    R3,R3,#&F000
    ORR    R3,R3,R0,LSL#12 ;store new button type
    ORREQ  R3,R3,#&100     ;set bit 8 if button type 15
    B      fin
ntb SUBS   R0,R0,#100
    BLT    err
    BIC    R3,R3,#&1F0000
    ORR    R3,R3,R0,LSL#16 ;store ESG
fin STR    R3,[R2,#20]     ;store flag word
    LDMDB  fp,{fp,sp,pc}   ;return
err ADR    ip,em2
er2 BL     WP_err2         ;failed
    LDMDB  fp,{fp,sp,pc}   ;return
msk DCD    &FF1FF8C3       ;bits not allowed
ptr DCD    WP_txicon
em2 DCB    3,"INDEX () out of range",0
    END
;
    TTL    wpchwc
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpchwc_         ;(INDEX,KOLOUR)
    IMPORT WP_win
    IMPORT WP_err2
    DCB    "WPCHWC",0,0,8,0,0,255
wpchwc_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R0]         ;INDEX
    CMP    R2,#6
    BLS    CC1
    ADR    ip,em4
    MOV    R0,R2
    BL     WP_err2
    LDMDB  fp,{fp,sp,pc}  ;return if INDEX out of range
CC1 LDR    R0,[R1]         ;KOLOUR
    CMP    R2,#3           ;check for work area background
    CMPEQ  R0,#255         ;then allow 255 (transparent)
    BEQ    tst
    CMP    R0,#15
tst LDRLS  R1,ptr
    ADDLS  R1,R1,#32       ;address of colour 0
    STRLSB R0,[R1,R2]      ;store new colour
    ADRHI  ip,em5
    BLHI   WP_err2
    LDMDB  fp,{fp,sp,pc}   ;return
ptr DCD    WP_win
em4 DCB    3,"INDEX () out of range",0
em5 DCB    3,"KOLOUR () out of range",0
    END
;
    TTL    wpchwf
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpchwf_         ;(INDEX,SET)
    IMPORT WP_err2
    IMPORT WP_win
    DCB    "WPCHWF",0,0,8,0,0,255
wpchwf_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]         ;INDEX
    LDR    R2,ptr
    CMP    R0,#0
    BLT    ewf
    CMP    R0,#30
    BGT    stb
    LDR    R1,[R1]         ;set
    LDR    R3,[R2,#28]     ;get flag word
    MOV    ip,#1
    CMP    R1,#0
    ORRNE  R3,R3,ip,LSL R0 ;set bit
    BICEQ  R3,R3,ip,LSL R0 ;clear bit
    STR    R3,[R2,#28]     ;store flag word
    LDMDB  fp,{fp,sp,pc}   ;return
stb SUBS   R3,R0,#100
    RSBGE  ip,R3,#15
    BLT    ewf
    LDR    R0,[R2,#60]     ;get button
    BIC    R0,R0,#&F000    ;clear button type
    ORR    R0,R0,R3,LSL#12 ;store new button type
    STR    R0,[R2,#60]     ;store button
    LDMDB  fp,{fp,sp,pc}   ;return
ewf ADR    ip,em4
    BL     WP_err2
    LDMDB  fp,{fp,sp,pc}   ;return
ptr DCD    WP_win
em4 DCB    3,"INDEX () out of range",0
    END
;
    TTL    wpclst
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
Wimp_CloseTemplate EQU &400DA
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpclst_         ;close template file
    IMPORT WP_drck
    DCB    "WPCLST",0,0,8,0,0,255
wpclst_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    SWI    Wimp_CloseTemplate
    LDMDB  fp,{fp,sp,pc}   ;return
    END
;
    TTL    wpclsw
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
Wimp_CloseWindow      EQU &600C6
Wimp_GetWindowState   EQU &600CB
Wimp_SetCaretPosition EQU &600D2
tmp              EQU 300
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpclsw_         ;(IWH) close window
    IMPORT WP_bloc
    IMPORT WP_err3
    IMPORT WP_drck
    IMPORT WP_savw
    DCB    "WPCLSW",0,0,8,0,0,255
wpclsw_
    MOV    ip,sp
    STMDB  sp!,{R4,R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R0,[R0]         ;window handle
    LDR    R1,ptr          ;space
    STR    R0,[R1]
    SWI    Wimp_GetWindowState;
    BVC    CW1
    BL     WP_err3
    LDMDB  fp,{R4,R5,fp,sp,pc} ;return on error
CW1 LDR    lr,[R1,#32]     ;status word
    TST    lr,#&10000      ;test if open 
    BEQ    pn1
    SWI    Wimp_CloseWindow
    LDR    R0,[R1]         ;restore window handle 
    BL     WP_savw         ;check if save window
    BNE    pn1
    ADD    ip,R1,#976-tmp  ;pointer to caret info
    LDMIA  ip,{R0-R5}      ;caret info
    SWI    Wimp_SetCaretPosition
    LDR    R1,ptr          ;restore pointer to space
pn1 ADD    R2,R1,#732-tmp  ;pointer to pane info
    LDRB   R3,[R2]         ;#panes
    CMP    R3,#0
    LDMEQDB fp,{R4,R5,fp,sp,pc} ;return if none
    ADD    ip,R2,R3,LSL#3
    ADD    ip,ip,#8        ;pointer to end of list
    LDR    lr,[R1]         ;window handle
lp1 LDMDB  ip!,{R4,R5}     ;get pane and host
    CMP    R5,lr
    STREQ  R4,[R1]
    SWIEQ  Wimp_CloseWindow;close associated pane
    CMP    R4,lr
    LDREQB R4,[R2,R3]
    BICEQ  R4,R4,#&80
    STREQB R4,[R2,R3]      ;un-flag pane
    SUBS   R3,R3,#1
    BGT    lp1             ;loop over panes
    LDMDB  fp,{R4,R5,fp,sp,pc} ;return
ptr DCD    WP_bloc+tmp
    END
;
    TTL    wpcltx
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN      0
Wimp_CommandWindow  EQU &600EF
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpcltx_         ;(ISTOP) closes text window
    IMPORT WP_drck
    DCB    "WPCLTX",0,0,8,0,0,255
wpcltx_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R0,[R0]
    CMP    R0,#0           ;R0=0 if ISTOP is FALSE
    MOVNE  R0,#-1          ;R0=-1 if ISTOP is TRUE
    SWI    Wimp_CommandWindow
    LDMDB  fp,{fp,sp,pc}   ;return
    END
;
    TTL    wpcopy
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN      0
R1  RN      1
R2  RN      2
R3  RN      3
R4  RN      4
R5  RN      5
R6  RN      6
Wimp_BlockCopy  EQU &600EB
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpcopy_         ;(IWH,IX1,IY1,IX2,IY2,NX,NY) copy rectangle
    IMPORT WP_err3
    IMPORT WP_bloc
    IMPORT WP_drck
    DCB    "WPCOPY",0,0,8,0,0,255
wpcopy_
    MOV    ip,sp
    STMDB  sp!,{R4-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDMIA  ip,{R4-R6}      ;addresses of last 3 arguments
    LDR    R0,[R0]         ;IWH
    LDR    R1,[R1]         ;IX1
    LDR    R2,[R2]         ;IY1
    LDR    R3,[R3]         ;IX2
    LDR    R4,[R4]         ;IY2
    LDR    R5,[R5]         ;NX
    LDR    R6,[R6]         ;NY
    SWI    Wimp_BlockCopy
    BLVS   WP_err3         ;report error
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    wpdeli
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
Wimp_SetIconState EQU &600CD
Wimp_DeleteIcon   EQU &600C4
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpdeli_         ;(IWH,ICH) delete icon
    IMPORT WP_bloc
    IMPORT WP_drck
    IMPORT WP_err3
    DCB    "WPDELI",0,0,8,0,0,255
wpdeli_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R0,[R0]         ;window handle
    LDR    R2,[R1]         ;icon handle
    LDR    R1,ptr          ;space
    LDR    R3,=&00800080
    MOV    ip,R3
    STMIA  R1,{R0,R2,R3,ip}
    SWI    Wimp_SetIconState;remove from view
    SWIVC  Wimp_DeleteIcon ;delete it altogether
    BVC    DI1
    BL     WP_err3
    LDMDB  fp,{fp,sp,pc}  ;return on error
DI1 CMP    R2,#0           ;check for icon bar
    LDMGEDB fp,{fp,sp,pc}  ;return if not
    LDR    R0,[R1,#312]    ;baricon handle
    SUBS   R3,R0,R3
    STREQ  R3,[R1,#312]    ;reset baricon icon handle
    LDMDB  fp,{fp,sp,pc}   ;return
ptr DCD    WP_bloc+300
    END
;
    TTL    wpdels
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
OS_ChangeDynamicArea EQU &2002A
OS_SpriteOp          EQU &2002E
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpdels_         ;(IWH) delete window sprite
    IMPORT WP_bloc
    IMPORT WP_drck
    DCB    "WPDELS",0,0,8,0,0,255
wpdels_
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R0,[R0]         ;window handle
    LDR    ip,pts          ;pointer to sprite window info
    LDR    lr,[ip],#-12    ;#sprite windows
lp1 SUBS   lr,lr,#1
    LDMLTDB fp,{R4-R5,fp,sp,pc} ;return if not a sprite window
    LDR    R2,[ip,#20]!
    CMP    R2,R0           ;check if current window is a sprite window
    BNE    lp1
; sprite window, first remove the sprite
    MOV    R0,#25          ;SpriteOp 25 removes sprite
    ADD    R2,ip,#4        ;pointer to name
    SWI    OS_SpriteOp     ;remove sprite
; compact the sprite windows list
    ADD    R5,ip,#20
lp2 SUBS   lr,lr,#1
    LDMGEIA R5!,{R0-R4}
    STMGEIA ip!,{R0-R4}
    BGT    lp2
    LDR    R1,pts
    LDR    R2,[R1]
    SUB    R2,R2,#1        ;decrement count of sprite windows
    STR    R2,[R1]
; lastly, compact the system sprite area
    MOV    R0,#8
    SWI    OS_SpriteOp     ;get sizes of area
    TEQ    R3,#0           ;check for no sprites
    RSBEQ  R1,R2,#0        ;- area size if no sprites
    RSBNE  R1,R2,R5        ;used - area size otherise
    MOV    R0,#3           ;for system sprite area
    SWIVC  OS_ChangeDynamicArea
    LDMDB  fp,{R4-R5,fp,sp,pc} ;return
pts DCD    WP_bloc+800
mn1 DCD    -1
    END
;
    TTL    wpdelw
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
R9  RN     9
tmp EQU 300
Wimp_DeleteWindow    EQU &600C3
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpdelw_         ;(IWH) delete window
    IMPORT wpdels_         ;(IWH) delete window sprite
    IMPORT WP_bloc
    IMPORT WP_err3
    IMPORT WP_drck
    DCB    "WPDELW",0,0,8,0,0,255
wpdelw_
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R0,[R0]         ;window handle
    LDR    R1,ptr          ;space
    STR    R0,[R1]
    SWI    Wimp_DeleteWindow
    BVC    DW1
    BL     WP_err3
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return on error
DW1 MOV    R0,R1
    BL     wpdels_         ;delete sprite (if any)
    LDR    R1,ptr          ;get back space pointer
; now for the panes
pt1 ADD    R2,R1,#732-tmp  ;pointer to pane info
    LDRB   R3,[R2]         ;#panes
    CMP    R3,#0
    BEQ    pt2             ;return if none                        24/02/97
    ADD    ip,R2,R3,LSL#3
    ADD    ip,ip,#8        ;pointer to end of list
    LDR    R6,[R1]         ;window handle
lp3 LDMDB  ip!,{R4,R5}     ;get pane and host
    CMP    R5,R6
    BLEQ   delpane         ;delete a subpordinate pane
    CMP    R4,R6
    BLEQ   delpane2        ;correct pane list if pane deleted
    SUBS   R3,R3,#1
    BGT    lp3
pt2 LDR    R0,[fp,#-40]    ;address of IWH                         24/02/97
    STR    R3,[R0]         ;set IWH=0                              24/02/97
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
delpane;   delete pane R4
    STR    R4,[R1]
    SWI    Wimp_DeleteWindow
delpane2;  remove pane R4 from pane list
    LDRB   R0,[R2]         ;#panes
    SUB    R0,R0,#1
    STRB   R0,[R2]         ;decrement # of panes
    CMP    R0,R3
    MOVLT  pc,lr           ;forget if last pane
    ADD    R9,ip,#16
    MOV    R5,R3
lp4 LDMDB  R9!,{R7,R8}
    STMDB  R9!,{R7,R8}     ;move down the window handles
    ADD    R9,R9,#24       ;prepare for next
    ADD    R8,R2,R5
    LDRB   R7,[R8,#1]
    STRB   R7,[R8]         ;move down side #
    ADD    R5,R5,#1
    CMP    R5,R0
    BLE    lp4
    MOV    pc,lr
ptr DCD    WP_bloc+tmp
    END
;
    TTL    wpdraw
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R4  RN     4
R6  RN     6
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpdraw_         ;(STRING) send file to !Draw
    IMPORT WP_sfile6
    DCB    "WPDRAW",0,0,8,0,0,255
wpdraw_
    MOV    ip,sp
    STMDB  sp!,{R4-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R6,#&AF0
    ADD    R6,R6,#&F       ;draw filetype is AFF
    B      WP_sfile6
    END
;
    TTL    wpdrag
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
Wimp_DragBox          EQU &600D0
    AREA   |C$$code|,CODE,READONLY
    IMPORT WP_err2
    IMPORT WP_drck
    EXPORT wpdrag_         ;(IBLK)
    DCB    "WPDRAG",0,0,8,0,0,255
wpdrag_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    MOV    R1,R0           ;pointer to block
    LDR    R0,[R1,#4]      ;get drag type
    CMP    R0,#5
    RSBGES ip,R0,#7
    BGE    DG1
    ADR    ip,em1          ;drag type not in range [5-7]
    BL     WP_err2
    LDMDB  fp,{fp,sp,pc}   ;return
DG1 SWI    Wimp_DragBox
    LDMDB  fp,{fp,sp,pc}   ;return
em1 DCB    3,"Illegal drag type ()",0
    END
;
    TTL    wpdrgi
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R4  RN     4
R9  RN     9
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpdrgi_         ;(IWH,ICH)
    IMPORT WP_err3
    IMPORT WP_drck
    IMPORT wp_dbox
    DCB    "WPDRGI",0,0,8,0,0,255
wpdrgi_
    MOV    ip,sp
    STMDB  sp!,{R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R0,[R0]         ;IWH
    LDR    ip,[R1]         ;ICH
    SUB    sp,sp,#40       ;buffer
    MOV    R1,sp
    STMIA  R1,{R0,ip}      ;window and icon handles
    BL     wp_dbox
    BLVS   WP_err3         ;error - illegal/icon window
    LDMDB  fp,{R4-R9,fp,sp,pc} 
    END
;
    TTL    wpedit
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
Wimp_SendMessage  EQU &600E7
OS_File           EQU &08
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpedit_         ;(STRING) send file to editor
    EXPORT WP_sfile6
    IMPORT WP_bloc
    IMPORT WP_err1
    IMPORT WP_err3
    IMPORT WP_drck
    DCB    "WPEDIT",0,0,8,0,0,255
wpedit_
    MOV    ip,sp
    STMDB  sp!,{R4-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R6,#&FF0
    ADD    R6,R6,#&F       ;text filetype is FFF
WP_sfile6;        entry from wpaint and wpdraw
    BL     WP_drck         ;check we are not drawing
    LDR    R3,ptr
    MOV    R2,#0
    MOV    ip,#40
lp1 STR    R2,[R3,ip]
    SUBS   ip,ip,#4
    BGT    lp1             ;clear Blk
    MOV    R2,#5
    STR    R2,[R3,#16]
    MOV    lr,#-1
    STR    lr,[R3,#20]     ;broadcast message to all tasks
    STR    R6,[R3,#40]     ;file type
    ORR    R6,R6,lr,LSL#12 ;FFFFFttt where ttt is file type
    CMP    R1,#211
    MOVGT  R1,#211         ;limit name length to message
    ADD    R2,R3,#44
lp2 LDRB   lr,[R0],#1
    CMP    lr,#" "
    STRGTB lr,[R2],#1
    SUBGTS R1,R1,#1
    BGT    lp2
    STRB   ip,[R2],#4      ;null terminate
    SUB    R2,R2,R3
    BIC    R2,R2,#3
    STR    R2,[R3]         ;store length
    ADD    R1,R3,#44       ;point to message
    MOV    R0,#17
    SWI    OS_File         ;check file
    CMP    R6,#-1
    MOVEQ  R2,R6           ;allow file of any type to go to edit  14/08/97
    CMP    R0,#1
    CMPEQ  R6,R2,ASR#8
    BEQ    ED1
    MOV    R0,R1
    ADR    ip,erm
    BL     WP_err1
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
ED1 MOV    R0,#18
    SUB    R1,R1,#44       ;restore pointer to message block
    MOV    R2,#0
    SWI    Wimp_SendMessage
    LDRVC  R0,[R1,#8]
    STRVC  R0,[R1,#(660-300)]
;       reference number in WP_Bloc+660
    BLVS   WP_err3
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
ptr DCD    WP_bloc+300
erm DCB    3,"bad file ''",0
    END
;
    TTL    wperr
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
Wimp_ReportError EQU &400DF
    AREA   |C$$code|,CODE,READONLY
    EXPORT wperr_          ;(INF,STRING,LFG) error window
    IMPORT WP_bloc
    IMPORT WP_drck
    DCB    "WPERR ",0,0,8,0,0,255
wperr_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R4,ptr          ;work space
    CMP    R3,#251
    MOVGT  R3,#251
    MOV    ip,#0           ;terminator test                     18/08/97
    STR    ip,[R4],#4      ;zero error number                   24/02/97
    B      pe1             ;                                    18/08/97
le1 LDRB   lr,[R1,R3]      ;                                    18/08/97
    CMP    ip,#0           ;                                    18/08/97
    CMPLE  lr,#" "         ;search for last non-blank           18/08/97
    MOVGT  ip,lr           ;found sig character                 18/08/97
pe1 STRB   ip,[R4,R3]      ;store the message (or 0)            18/08/97
    SUBS   R3,R3,#1
    BGE    le1             ;move the string
    LDR    R1,[R0]         ;flags
    BIC    lr,R1,#&90      ;ignore bits to kill "error from" etc. 20/03/97
    CMP    lr,#1           ;make 1 if outside range
    RSBGES lr,lr,#3        ;                                    21/02/97
    MOVLT  R1,#1
    SUB    R0,R4,#4        ;pointer to error block
    MOV    R4,R2           ;address of LFG
    ADD    R2,R0,#264      ;pointer to task name
    SWI    Wimp_ReportError
    STR    R1,[R4]         ;store LFG
    LDMDB  fp,{R4,fp,sp,pc}   ;return
ptr DCD    WP_bloc+300
    END
;
    TTL    wpftyp
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpftyp_         ;(ITYPE)
    IMPORT WP_bloc
    DCB    "WPFTYP",0,0,8,0,0,255
wpftyp_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[R0]        ;ITYPE
    LDR    R0,ptr         ;location in common
    STR    ip,[R0]        ;store ITYPE
    LDMDB  fp,{fp,sp,pc}  ;return
ptr DCD    WP_bloc+972    ;pointer to file type storage
    END
;
    TTL    wpgetp
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
Wimp_ReadPalette EQU &400E5
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpgetp_         ;(IPAL) get palette
    DCB    "WPGETP",0,0,8,0,0,255
wpgetp_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R1,R0
    SWI    Wimp_ReadPalette
    LDMDB  fp,{fp,sp,pc}   ;return
    END
;
    TTL    wpgtcp
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN      0
R1  RN      1
R2  RN      2
R3  RN      3
Wimp_GetCaretPosition  EQU &600D3
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpgtcp_         ;(IWH,IH,IPOS) get caret position
    DCB    "WPGTCP",0,0,8,0,0,255
wpgtcp_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUB    sp,sp,#24       ;space for results
    MOV    R1,sp
    SWI    Wimp_GetCaretPosition
    LDMVCIA sp!,{R0-R3,ip,lr}
    LDMVCIA sp!,{R2-R3,ip}
    STRVC  lr,[ip]         ;store IPOS
    STRVC  R0,[R2]         ;store IWH
    STRVC  R1,[R3]         ;store IH
    LDMDB  fp,{fp,sp,pc}   ;return
    END
;
    TTL    wpgtif
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
Wimp_GetIconState EQU &600CE
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpgtif_         ;(IWH,ICH,IND,SET) get icon flag
    IMPORT WP_bloc
    IMPORT WP_err1
    IMPORT WP_err3
    DCB    "WPGTIF",0,0,8,0,0,255
wpgtif_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[R1]         ;Icon handle
    LDR    R0,[R0]         ;Window handle
    LDR    R1,ptr
    STMIA  R1,{R0,ip}
    SWI    Wimp_GetIconState
    BVC    GF1
    BL     WP_err3
    LDMDB  fp,{fp,sp,pc}   ;return on error
GF1 LDR    R0,[R2]         ;IND
    CMP    R0,#31
    BLS    GF2
    ADR    ip,em2
    BL     WP_err1
    LDMDB  fp,{fp,sp,pc}   ;return on illegal index
GF2 LDR    R2,[R1,#24]     ;icon flag word
    MOV    R2,R2,LSR R0
    AND    R2,R2,#1
    STR    R2,[R3]         ;store bit in SET
    LDMDB  fp,{fp,sp,pc}   ;return
ptr DCD    WP_bloc+300
em2 DCB    3,"INDEX () illegal",0
    END
;
    TTL    wpgtil
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN      0
R1  RN      1
R2  RN      2
R3  RN      3
Wimp_WhichIcon  EQU &600D6
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpgtil_         ;(IWH,INDEX,LIST,NL) make list of flagged icons
    IMPORT WP_err3
    IMPORT WP_err2
    IMPORT WP_err1
    DCB    "WPGTIL",0,0,8,0,0,255
wpgtil_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,#0
    STR    ip,[R3]         ;preset NL to zero
    LDR    R0,[R0]         ;window handle
    LDR    R1,[R1]         ;INDEX
    LDR    ip,msk
    MOV    ip,ip,LSR R1
    ANDS   ip,ip,#1
    BNE    GL1
    ADR    ip,em1
    MOV    R0,R1
    BL     WP_err2         ;bit not in mask
    LDMDB  fp,{fp,sp,pc}  ;return
GL1 MOV    ip,ip,LSL R1    ;bit mask
    MOV    R1,R2           ;address of list
    MOV    R2,ip           ;bit mask
    MOV    ip,R3           ;save address of NL
    MOV    R3,R2           ;bit settings to match
    SWI    Wimp_WhichIcon
    BVC    GL2
    BL     WP_err3         ;report error
    LDMDB  fp,{fp,sp,pc}  ;and return
GL2 MOV    R0,#0
lp1 LDR    R2,[R1,R0,LSL#2]
    CMP    R2,#0
    ADDGE  R0,R0,#1        ;count entries
    BGE    lp1
    STR    R0,[ip]         ;store NL
    LDMDB  fp,{fp,sp,pc}   ;return OK
msk DCD    &E00F3F
em1 DCB    3,"Illegal index ()",0
    END
;
    TTL    wpgtis
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R2  RN     2
R1  RN     1
R0  RN     0
Wimp_GetIconState  EQU  &600CE
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpgtis_         ;(IWH,IH,IBLOCK) gets icon state block
    IMPORT WP_err3
    IMPORT WP_drck
    DCB    "WPGTIS",0,0,8,0,0,255
wpgtis_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck
    LDR    R0,[R0]         ;window handle
    LDR    ip,[R1]         ;icon handle
    MOV    R1,R2
    STMIA  R1,{R0,ip}      ;set initial block
    SWI    Wimp_GetIconState
    LDMVCDB fp,{fp,sp,pc}  ;return if OK
    BL     WP_err3         ;report error
    MOV    R0,#-1
    STR    R0,[R1,#4]      ;on error set the icon number -1
    LDMDB  fp,{fp,sp,pc}   ;return
    END
;
    TTL    wpgtmf
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpgtmf_         ;(NFLAG,IMBLOC,INDEX,SET)
    IMPORT WP_err2
    IMPORT WP_menu
    DCB    "WPGTMF",0,0,8,0,0,255
wpgtmf_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_menu         ;find menu item
    LDMNEDB fp,{fp,sp,pc}  ;return on bad index
    LDR    R0,[R0]         ;NFLAG
    CMP    R0,#0
    RSBGES ip,R0,#3
    BGE    GF1
    ADR    ip,em2
    BL     WP_err2
    LDMDB  fp,{fp,sp,pc}  ;return on bad nflag
GF1 MOV    ip,#1           ;mask
    CMP    R0,#2
    LDRNEB R2,[R1]         ;menu flags
    ANDNE  R2,ip,R2,LSR R0 ;get bit
    LDREQ  R2,[R1,#8]      ;icon flags
    ANDEQ  R2,ip,R2,LSR#22
    STR    R2,[R3]         ;store in SET
    LDMDB  fp,{fp,sp,pc}   ;return
em2 DCB    3,"NFLAG () out of range",0
    END
;
    TTL    wpgtms
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
Wimp_GetMenuState EQU &600F4
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpgtms_         ;(ITEMS,NMENU)
    DCB    "wpgtms",0,0,8,0,0,255
wpgtms_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R1,R0           ;address for icon list
    MOV    R0,#0           ;just the icons
    SWI    Wimp_GetMenuState
    LDR    R3,[sp,#4]      ;restore (NMENU)
    MOV    R0,#0
    STRVS  R0,[R3]         ;NMENU=0 on error
    LDMVSDB  fp,{fp,sp,pc} ;return
lp1 LDR    R2,[R1],#4
    CMP    R2,#0
    ADDGE  R0,R0,#1
    BGE    lp1
    STR    R0,[R3]         ;store NMENU
    LDMDB  fp,{fp,sp,pc}   ;return
    END
;
    TTL    wpgtpi
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN      0
R1  RN      1
R2  RN      2
R3  RN      3
Wimp_GetPointerInfo  EQU &400CF
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpgtpi_         ;(IWH,IH,IX,IY,IB) get mouse pointer info
    IMPORT WP_bloc
    DCB    "WPGTPI",0,0,8,0,0,255
wpgtpi_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,ptr
    SWI    Wimp_GetPointerInfo
    LDR    R0,[R1],#4      ;get x
    STR    R0,[R2]         ;store IX
    LDR    R0,[R1],#4      ;get y
    STR    R0,[R3]         ;store IY
    LDMIA  R1,{R0,R2,R3}
    LDR    ip,[ip]         ;address of IB
    STR    R0,[ip]         ;store IB
    LDMIA  sp!,{R0,R1}     ;restore addresses of IWH and IH
    STR    R2,[R0]         ;store IWH
    STR    R3,[R1]         ;store IH
    LDMDB  fp,{fp,sp,pc}   ;return OK
ptr DCD    WP_bloc+300
    END
;
    TTL    wpgtss
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN      0
R1  RN      1
R2  RN      2
R3  RN      3
Wimp_SlotSize  EQU &400EC
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpgtss_         ;(NCS,NNS,NFP) get slot sizes
    DCB    "WPGTSS",0,0,8,0,0,255
wpgtss_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R0,#-1
    MOV    R1,#-1
    SWI    Wimp_SlotSize   ;corrupts R4!
    LDMIA  sp!,{R3,ip,lr}
    STR    R0,[R3]         ;store current slot size
    STR    R1,[ip]         ;store next slot size
    STR    R2,[lr]         ;store free pool
    LDMDB  fp,{R4,fp,sp,pc}   ;return OK
    END
;
    TTL    wpgtth
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN      0
R1  RN      1
R2  RN      2
R3  RN      3
TaskManager_EnumerateTasks  EQU &42681
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpgtth_         ;(NAME,IHANDL) get task handle of 'NAME'
    DCB    "WPGTTH",0,0,8,0,0,255
wpgtth_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIA  sp,{R4-R6}      ;preserve arguments
    SUB    sp,sp,#16       ;space for results
    MOV    R0,#0           ;first task
lp1 MOV    R1,sp           ;pointer to buffer
    MOV    R2,#16          ;buffer length
    SWI    TaskManager_EnumerateTasks
    LDRB   ip,[sp,#12]     ;flags
    TST    ip,#1           ;check for application task
    BNE    nxt
    MOV    R1,sp        
    LDR    ip,[R1],#4      ;task handle
    STR    ip,[R5]         ;store in IHANDL
    MOV    R2,#0
    LDR    R1,[R1]        ;address of task name
lp2 LDRB   R3,[R1,R2]     ;get byte of task
    LDRB   ip,[R4,R2]     ;get byte of NAME
    CMP    R3,ip
    BNE    nxt
    ADD    R2,R2,#1       ;count bytes in NAME
    CMP    R2,R6
    BLT    lp2
    LDRB   R2,[R1,R2]     ;check for terminator
    CMP    R2,#0
    LDMEQDB  fp,{R4-R6,fp,sp,pc}   ;return with answer
nxt CMP    R0,#0
    BGT    lp1
    MOV    R0,#0
    STR    R0,[R5]        ;null result
    LDMDB  fp,{R4-R6,fp,sp,pc}   ;return null
    END
;
    TTL    wpgtwo
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN      0
R1  RN      1
R2  RN      2
R3  RN      3
Wimp_GetWindowOutline  EQU &600E0
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpgtwo_         ;(IWH,IX1,IY1,IX2,IY2) get window outline
    IMPORT WP_bloc
    IMPORT WP_err3
    IMPORT WP_drck
    DCB    "WPGTWO",0,0,8,0,0,255
wpgtwo_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    MOV    lr,R1           ;save address of IX1
    LDR    R1,ptr          ;working space
    LDR    R0,[R0]         ;IWH
    STR    R0,[R1]
    SWI    Wimp_GetWindowOutline
    BVC    GO1
    BL     WP_err3
    LDMDB  fp,{fp,sp,pc}  ;return on error
GO1 LDR    R0,[R1,#4]!
    STR    R0,[lr]         ;store IX1
    LDMIB  R1!,{R0,lr}
    STR    R0,[R2]         ;store IY1
    STR    lr,[R3]         ;store IX2
    LDR    lr,[R1,#4]
    LDR    R0,[ip]
    STR    lr,[R0]         ;store IY2
    LDMDB  fp,{fp,sp,pc}   ;return OK
ptr DCD    WP_bloc+300
    END
;
    TTL    wpgtws
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
Wimp_GetWindowState  EQU &600CB
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpgtws_         ;(IWHAN,IBLK)
    IMPORT WP_err3
;    IMPORT WP_drck
    DCB    "WPGTWS",0,0,8,0,0,255
wpgtws_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
;    BL     WP_drck         ;check we are not drawing
    LDR    R0,[R0]         ;window handle
    STR    R0,[R1]         ;store in IBLK(1)
    SWI    Wimp_GetWindowState
    BLVS   WP_err3
    LDMDB  fp,{fp,sp,pc}   ;or return
    END
;
    TTL    wpinit
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
R9  RN     9
OS_BinaryToDecimal EQU &28
OS_ConvertHex8     EQU &D4
OS_ConvertInteger4 EQU &DC
OS_WriteC          EQU &00
OS_WriteS          EQU &01
OS_Write0          EQU &02
OS_NewLine         EQU &03
OS_WriteN          EQU &46
OS_ReadMonotonicTime EQU &42
PDriver_AbortJob   EQU &A0149
XOS_SpriteOp       EQU &2002E
XOS_Find           EQU &2000D
Wimp_Initialise    EQU &400C0
Wimp_CloseDown     EQU &400DD
XWimp_CloseWindow  EQU &600C6
Wimp_SlotSize      EQU &400EC
Wimp_GetCaretPosition EQU &400D3
temp               EQU 300 ;displacement to temporary workspace
;
    AREA   |C$$data|,DATA
depth DCD  6               ;maximum depth of trace back
;
    AREA   |SpOp_state|,COMMON
    %      4               ;flags VDU to sprite or to screen
;
    AREA   print_handles,COMMON
    %      4         ;file handle (initially 0)
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT wimpprint       ;(format,...) C type fprint format
;                  this is used in preference to the one in Fortlib for wimp programs
    EXPORT wpinit_         ;(TITLE) initialise the wimp
    EXPORT tracedepth_     ;(JDEPTH) sets trace-back depth
;                  this is used in preference to the one in Fortlib for wimp programs
    EXPORT in_wimp         ;() returns status
;                     0: before init, 1: after init, -1: after poll
;                     (2: if not wimp program)
    IMPORT fortran_exit
    IMPORT WP_bloc
    IMPORT WP_kill
    IMPORT WP_err1
    DCB    "WPINIT",0,0,8,0,0,255
wpinit_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,stt
    LDR    ip,[R2],#8      ;get status
    CMP    ip,#0
    ADRNE  ip,erm          ;send error if not zero
    ADDNE  R0,R2,#4
    BNE    WP_err1         ;fatal error
    MOV    ip,#1
    STR    ip,[R2,#-8]     ;set status to +1
    CMP    R1,#19
    MOVGT  R1,#19          ;truncate title length to 19 chars
    MOV    ip,#0
lpi STRB   ip,[R2,R1]
    SUBS   R1,R1,#1
    LDRB   ip,[R0,R1]      ;transfer title, null terminated
    BGE    lpi
    SWI    OS_ReadMonotonicTime
    STR    R0,[R2,#616-564];store initial time
    STR    R0,[R2,#620-564]
    LDR    R0,mxv          ;last known wimp version
    LDR    R1,tsk
    ADR    R3,msg
    SWI    Wimp_Initialise
    STR    R1,[R2,#-4]     ;store task handle
    STR    R0,[R2,#(648-564)];wimp version
    LDMDB  fp,{fp,sp,pc}   ;return
tsk DCB    "TASK"
mxv DCD    310             ;highest allowed wimp version
stt DCD    WP_bloc+556     ;status pointer
msg DCD    0               ;null messages -> accept all
erm DCB    2," has already been initialised",0
    ALIGN
;
in_wimp;     returns status
    LDR    R0,stt
    LDR    R0,[R0]         ;get status
    MOV    pc,lr
;
tracedepth_
    LDR    R0,[R0]         ;JDEPTH
    LDR    R1,ptd          ;address of depth
    STR    R0,[R1]
    MOV    pc,lr
;
buf DCD    WP_bloc+temp
ptd DCD    depth
prh DCD    print_handles
sps DCD    |SpOp_state|
;
wimpprint
    STMFD  sp!,{R1-R3}     ;stick all arguments on stack
    MOV    R4,R0           ;pointer to format
    MOV    R5,sp           ;argument list
    LDR    R0,sps
    LDR    R2,[R0]
    CMP    R2,#0           ;check that output is to screen
    MOVNE  R2,#0
    STRNE  R2,[R0]         ;flag for O/P not to sprite
    MOVNE  R3,#1
    MOVNE  R0,#60
    SWINE  XOS_SpriteOp    ;force output to screen
;        move O/P to screen from printer
    LDR    R3,prh
    LDR    R0,[R3]
    CMP    R0,#0           ;check that output is to screen (not printer)
    BEQ    WP0
    SWI    PDriver_AbortJob;kill print job
    LDR    R1,[R3]
    MOV    R0,#0
    STR    R0,[R3]         ;flag for no printer
    SWI    XOS_Find        ;close print stream
;
WP0 LDR    ip,stt
    LDR    ip,[ip]         ;get status
    CMP    ip,#0
    MOVNE  R0,#0
    SWINE  Wimp_CloseDown  ;close down wimp
;       transfer the 'C' type message (assumes no more than 3 arguments)
lp1 LDRB   R0,[R4],#1
    CMP    R0,#"%"         ;check for substitution
    CMPNE  R0,#0
    BEQ    WP1
    SWI    OS_WriteC
    MOV    R7,R0           ;last useful character
    B      lp1
WP1 CMP    R0,#0
    BEQ    pt1             ;finished decoding message
    LDR    R0,[R5],#4      ;get variable
    LDRB   ip,[R4],#1      ;get variable type
    CMP    ip,#"a"
    SUBGE  ip,ip,#32       ;convert to upper case
    CMP    ip,#"C"
    BNE    WP2
    SWI    OS_WriteC       ;print character
    B      lp1
WP2 CMP    ip,#"S"
    BNE    WP3
    SWI    OS_Write0       ;print string
    B      lp1
;       translate integer
WP3 CMP    ip,#"D"
    BNE    WP4
    LDR    R1,buf          ;address to store
    MOV    R2,#12          ;maximum ASCII length
    SWI    OS_BinaryToDecimal
    MOV    R0,R1
    MOV    R1,R2
    SWI    OS_WriteN       ;print coded string
    B      lp1
WP4 CMP    ip,#"."
    BNE    lp1
;       special for John's s_stop
    LDRB   ip,[R4],#1      ;get variable type
    CMP    ip,#"*"
    LDREQB ip,[R4],#1
    CMP    ip,#"s"
    SUBNE  R4,R4,#1        ;this is not John's %.*s
    SUBNE  R5,R5,#4
    MOVEQ  R1,R0
    LDREQ  R0,[R5],#4
    SWIEQ  OS_WriteN       ;print coded string
    B      lp1
;
pt1 CMP    R7,#" "
    SWIGE  OS_NewLine      ;extra new line if none on end of message
    SWI    OS_NewLine
;
;       printed the error message, now do the trace-back
    LDR    R0,ptd
    LDR    R6,[R0]         ;get maximum trace depth
    MOVS   R7,fp           ;pointer to frame of routine in trouble
    BEQ    prt             ;skip if no frames
    MOV    R0,#-1
    MOV    R1,#-1
    SWI    Wimp_SlotSize
    ADD    R9,R0,#&8000    ;address of end of current program
    ADR    R0,fst           ; " In routine "
;       find address of routine name
lp3 LDR    R2,[R7]         ;stored pc
    TEQ    pc,pc
    BICNE  R2,R2,#&FC000003;remove status bits for 26-bit addressing
lp4 LDR    R1,[R2,#-4]!
    CMP    R1,#&FF000000
    BCC    lp4             ;find header pointer
    AND    R1,R1,#&FC
    SUB    R3,R2,R1        ;pointer to name
    LDR    R5,[R3]         ;1st 4 characters of original name
    LDR    R4,stp
    CMP    R5,R4           ;check for _stop
    BEQ    prt             ;skip print if called from _stop
;       insert introduction
    SWI    OS_Write0
;       check name
lp5 LDRB   R4,[R2,#-1]!
    CMP    R4,#0
    BEQ    lp5             ;skip trailing zeros
    CMP    R4,#"_"         ;check last character
    ADDNE  R2,R2,#1        ;don't skip if not "_"
    SUB    R1,R2,R3        ;length of name
    CMP    R1,#12
    MOVGT  R1,#12          ;limit it to 12 characters
;       insert name (upper case and no "_" for Fortran)
    MOV    R8,R1           ;character count
lp6 LDRB   R0,[R3],#1
    CMP    R4,#"_"         ;check if Fortran name
    BNE    pt2
    CMP    R0,#"a"
    SUBGE  R0,R0,#32       ;convert Fortran to upper case
pt2 CMP    R0,#32
    RSBGTS ip,R0,#127      ;remove garbage
    SWIGT  OS_WriteC       ;print name
    SUBS   R1,R1,#1
    BGT    lp6
    CMP    R4,#"_"
;        print calling address if Fortran
    SWINE  OS_NewLine
    CMP    R4,#"_"
    BNE    pt5
    ADR    R0,at
    ADD    R0,R0,R8
    SWI    OS_Write0        ;print "    at &"
    TEQ    pc,pc
    BICNE  R0,lr,#&FC000003 ;clear system bits from address
    BL     Hex7
    SWI    OS_NewLine
    CMP    R9,#0
    BEQ    pt5              ;not doing argument prints
    LDR    R0,[R7]
    BIC    R0,R0,#&FC000003 ;clear system bits from address
    LDR    R2,=&3A4B76
    LDR    R4,[R0,#-12]     ;get current STMDB instruction (ARM convention)
    CMP    R2,R4,LSR#10     ;compare leftmost 22 bits (0:9 for saved regs.)
    LDRNE  R4,[R0,#-8]      ;get current STMDB instruction (StrongARM)
    CMPNE  R2,R4,LSR#10     ;compare leftmost 22 bits
    BNE    pt5              ;not STMDB  sp!{,,,fp,ip,lr,pc}
    LDR    ip,[R7,#-8]      ;stack pointer before STMDB
    SUB    ip,ip,#16        ;allow for fp,ip,lr and pc
    MOV    R2,#&200         ;bit for R9
lp7 TST    R4,R2
    SUBNE  ip,ip,#4        ;allow for saved registers
    MOVS   R2,R2,LSR#1
    BNE    lp7
    AND    R4,R4,#15       ;only look for registers R0 to R3
    MOV    R3,#0           ;argument #
lp8 ADD    R3,R3,#1
    MOVS   R4,R4,LSR#1
    BCC    pt4
    SWI    OS_WriteS
    DCB    "    Argument ",0
    ADD    R0,R3,#"0"
    SWI    OS_WriteC
    SWI    OS_WriteS
    DCB    " (&",0
    LDR    R0,[ip]         ;get argument
    BL     Hex7            ;print it
    SWI    OS_WriteS
    DCB    ")",0
    LDR    lr,[ip],#4      ;get argument again
    CMP    lr,#&8000       ;check for bounds
    RSBGTS R0,lr,R9
    BLE    pt3             ;address out of range
    SWI    OS_WriteS
    DCB    " is &",0
    LDR    R0,[lr]         ;get scalar argument
    SWI    OS_ConvertHex8
    SWI    OS_Write0
    SWI    OS_WriteS
    DCB    ",  ",0
    LDR    R0,[lr]         ;get scalar argument
    SWI    OS_ConvertInteger4
    SWI    OS_Write0
pt3 SWI    OS_NewLine
    B      lp8
pt4 MOV    R9,#0           ;only one routine with argument prints
;        check if we have finished
pt5 CMP    R8,#4
    LDREQ  R2,MAIN
    CMPEQ  R2,R5
    SUBNES R6,R6,#1
    LDRGT  lr,[R7,#-4]     ;calling address
    LDRGT  R7,[R7,#-12]    ;pointer to next frame
;       loop over trace-back
    ADRGT  R0,txt          ; "Called from "
    BGT    lp3             ;not finished
;
prt LDMFD  sp!,{R1-R3}     ;restore stack
    MOV    R0,#1           ;error for fortran_exit
    B      fortran_exit
MAIN DCB   "main"
stp DCB   "_sto"
nl  DCB    13,10,0,0       ;new line sequence
fst DCB    " In routine ",0;NL + 12 bytes of text
txt DCB    "Called from ",0;NL + 12 bytes of text
    ALIGN
at  DCB    "             at &",0  ;12 blanks + " at &"
    ALIGN
Hex7;   print nummer in R0 in format Z7.7
    LDR    R1,buf
    MOV    R2,#64
    SWI    OS_ConvertHex8
    ADD    R0,R0,#1
    SWI    OS_Write0       ;print address Z7.7
    MOV    pc,lr
    END
;
    TTL    wphndl
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT wphndl_         ;(IHAND) get task handle
    IMPORT WP_bloc
    DCB    "WPHNDL",0,0,8,0,0,255
wphndl_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,ptr
    LDR    R1,[R1,#560]
    STR    R1,[R0]         ;handle
    LDMDB  fp,{fp,sp,pc}   ;return
ptr DCD    WP_bloc
    END
;
    TTL    wpkeyp
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
Wimp_ProcessKey EQU &400DC
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpkeyp_         ;(KEY) pass on unwanted key-press
    DCB    "WPKEYP",0,0,8,0,0,255
wpkeyp_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]         ;KEY
    SWI    Wimp_ProcessKey
    LDMDB  fp,{fp,sp,pc}   ;return
    END
;
    TTL    wpldtw
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
Wimp_LoadTemplate  EQU &600DB
Wimp_CreateWindow  EQU &600C1
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpldtw_         ;(SNAME,IBUF,SIND,IWH)
    IMPORT WP_win          ;                               07/05/97
    IMPORT WP_bloc
    IMPORT WP_err1
    IMPORT WP_drck
    DCB    "WPLDTW",0,0,8,0,0,255
wpldtw_
    MOV    ip,sp
    STMDB  sp!,{R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    MOV    R7,R3           ;save address of IWH
    LDR    R5,ptr          ;address of name
    LDR    R6,[ip]         ;length of name
    MOV    lr,#0
ll1 STRB   lr,[R5,R6]
    SUBS   R6,R6,#1
    LDRGEB lr,[R0,R6]      ;move name, null terminated
    BGE    ll1
    LDR    lr,[ip,#4]      ;length of SIND
    ADD    R3,lr,R2        ;1 after end of SIND
    MOV    R4,#-1          ;no font array
    MOV    R6,#0           ;start from beginning
    SWI    Wimp_LoadTemplate
    BVS    er1
    CMP    R6,#0
    ADREQ  ip,em2
    BEQ    er2
    LDR    lr,win          ;                               07/05/97
    LDR    ip,[lr,#64]     ;transfer sprite area pointer   07/05/97
    STR    ip,[R1,#64]     ;                               07/05/97
pt1 SWI    Wimp_CreateWindow
    STRVC  R0,[R7]         ;store window handle
    LDMVCDB fp,{R4-R7,fp,sp,pc} ;return if no error
    ADD    ip,R0,#4
    B      er2
er1 LDR    ip,[R0]         ;error loading template
    CMP    ip,#&284        ;check if definition won't fit
    ADREQ  ip,em1
    ADDNE  ip,R0,#4
er2 LDR    R0,ptr
    BL     WP_err1
    MOV    R0,#-1
    STR    R0,[R7]         ;store window handle -1
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
ptr DCD    WP_bloc+400
win DCD    WP_win          ;                              07/05/97
em1 DCB    3,"Window '' definition won't fit",0
em2 DCB    3,"Can't find Window template ''",0
    END
;
    TTL    wploop
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
R9  RN     9
XOS_File              EQU &20008
OS_ReadMonotonicTime  EQU &42
OS_SpriteOp           EQU &2002E
OS_WriteC             EQU &00
OS_WriteI             EQU &100
Wimp_CloseDown        EQU &400DD
Wimp_CreateMenu       EQU &400D4
Wimp_CreateSubMenu    EQU &400E8
Wimp_DragBox          EQU &400D0
Wimp_GetCaretPosition EQU &400D3
Wimp_GetIconState     EQU &600CE
Wimp_GetMenuState     EQU &600F4
Wimp_GetRectangle     EQU &400CA
Wimp_GetPointerInfo   EQU &400CF
Wimp_GetWindowInfo    EQU &400CC
Wimp_GetWindowState   EQU &600CB
Wimp_Poll             EQU &400C7
Wimp_PollIdle         EQU &400E1
Wimp_RedrawWindow     EQU &400C8
Wimp_SetCaretPosition EQU &600D2
Wimp_SendMessage      EQU &400E7
Wimp_StartTask        EQU &400DE
    AREA   |C$$code|,CODE,READONLY
    EXPORT wploop_         ;(IFLAG) enter the wimp poll loop
    EXPORT WP_orig
    EXPORT WP_sprite
    EXPORT re_draw      ;       06/02/97
    EXPORT wp_dbox      ;       23/04/97
    EXPORT wp_quit      ;       06/02/97
    IMPORT WP_err1
    IMPORT WP_err2
    IMPORT WP_err3
    IMPORT WP_bloc
    IMPORT WP_savw
    IMPORT wpquit_
    IMPORT wqclik_
    IMPORT wqclsw_
    IMPORT wqplot_
    IMPORT wqhelp_
    IMPORT wqlgct_
    IMPORT wqmodc_
    IMPORT wqmodf_
    IMPORT wqmwrn_
    IMPORT wqmenu_
    IMPORT wqmesg_
    IMPORT wqnull_
    IMPORT wqopnw_
    IMPORT wqpalc_
    IMPORT wqkeyp_
    IMPORT wqpreq_
    IMPORT wqptww_
    IMPORT wqquit_
    IMPORT wqrfil_
    IMPORT wqscrl_
    IMPORT wqdrag_
    IMPORT wqwfil_
em1 DCB    2,"you can only call WPLOOP once",0
em2 DCB    2,"you must call WPINIT before WPLOOP",0
    ALIGN
;         start standard fortran entry sequence
    DCB    "WPLOOP",0,0,8,0,0,255
wploop_
    MOV    ip,sp
    STMDB  sp!,{R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,blk
    STR    fp,[R1,#968]    ;store fp for emergency returns    06/02/97
    STR    R0,[R1,#584]    ;save pointer to poll flag
    LDR    R0,[R1,#556]    ;status
    RSBS   R0,R0,#0        ;should be +1
    ADRGT  ip,em1
    ADREQ  ip,em2
    BGE    WP_err1         ;fatal error
    STR    R0,[R1,#556]    ;set status -1
loop;   start of wimp poll loop
    LDR    R1,blk          ;pointer to block
    ADD    R0,R1,#584      ;address of mask
    LDMIA  R0,{R3,ip,lr}   ;mask address, poll time, quit flag
    SUBS   lr,lr,#1        ;check quit flag
    BNE    LP1
    STR    lr,[R1,#556]    ;set status and quit back to zero
    STR    lr,[R1,#592]
    SWI    Wimp_CloseDown  ;normal termination
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
LP1 SWI    OS_ReadMonotonicTime
    CMP    ip,#0           ;check poll time
    ADDGT  R2,ip,R0        ;set up return time from PollIdle
    MOV    R8,R0           ;keep time
    LDR    R0,[R3]         ;get mask
    LDR    R3,msk          ;get super-mask
    AND    R0,R0,R3        ;fix up mask
    BLE    LP2
    SWI    Wimp_PollIdle   ;call the time-delayed wimp manager
    B      LP3
LP2 SWI    Wimp_Poll       ;or call the normal wimp manager
LP3 MOV    R9,R0
    SWI    OS_ReadMonotonicTime
    SUBS   R0,R0,R8        ;time lost in wimp manager
    LDR    R2,[R1,#620]
    ADD    R2,R2,R0
    STR    R2,[R1,#620]    ;account for time lost
    ADR    lr,loop
    CMP    R9,#1
    BLT    wqnull_         ;call WQNULL for reason 0
    BEQ    re_draw         ;branch to redraw loop                06/02/97
    CMP    R9,#3           ;check for open/close window requests
    MOVLE  R0,R1
    BLT    wqopnw_         ;open window request
    BEQ    wqclsw_         ;close window request
    CMP    R9,#5           ;check for pointer leaving/entering window
    SUBLE  R3,R9,#4
    MOVLE  R0,R1           ;address of 'IWHAN'
    STRLE  R3,[R1,#4]!     ;store 'ENTER'
    BLE    wqptww_         ;call WQPTWW
    CMP    R9,#7
    BLT    click           ;mouse click
    BEQ    userdb          ;user drag box
    CMP    R9,#9
    BLT    key             ;key press
    BEQ    menu            ;go deal with menu call
    CMP    R9,#10
    MOVEQ  R0,R1
    BEQ    wqscrl_         ;scroll request
    CMP    R9,#12
    SUBLE  R2,R9,#11
    ADDLE  R0,R1,#296      ;place to store GAIN
    STRLE  R2,[R0]
    BLE    wqlgct_         ;call WQLGCT
    ADD    R0,R1,#296      ;place to store MTYPE
    STR    R9,[R0]
    CMP    R9,#18          ;message received (type in R8)
    BGT    reply
    LDMIA  R1,{R4-R8}      ;get useful numbers
    STR    R6,[R1,#12]     ;set your_ref to my_ref
    CMP    R8,#0           ;check for quit
    BNE    wp_quit
    BL     wqquit_         ;warn user
    BL     wpquit_         ;set quit flag
    B      loop
wp_quit;    (external loop has been requested to stop)      06/02/97
    CMP    R8,#8
    BLT    datatran        ;data transfer protocol
    BEQ    prequit
    CMP    R8,#9
    BLEQ   wqpalc_         ;call WQPALC
    LDR    R0,=&502
    CMP    R8,R0
    BEQ    Help            ;call from !Help
    TSTNE  R8,#&40000
    BEQ    umsg            ;unknown message
    AND    R8,R8,#&FF
    CMP    R8,#&C0
    BEQ    mwarn           ;menu warning
    CMP    R8,#&C1
    BNE    QT1
    BL     wqmodc_         ;call WQMODC
    B      loop            ;return (no acknowledegment)
QT1 CMP    R8,#&CF
    BNE    umsg
    ADD    R0,R1,#20
    BL     wqmodf_         ;call WQMODF(JFONT)
    B      loop            ;return (no acknowledegment)
;
click;  mouse click
    LDR    R0,[R1,#12]     ;get window handle
    BL     WP_savw         ;see if save window
    BEQ    saveclik
    CMP    R0,#-2          ;check for icon bar
    LDREQ  R0,[R1,#16]     ;if so, get icon handle
    LDREQ  R2,[R1,#612]    ;and baricon handle
    CMPEQ  R0,R2
    LDREQ  R0,[R1,#8]      ;if so, get buttons
    CMPEQ  R0,#2           ;check for menu
    BEQ    barmnu
cl2 MOV    R2,R1           ;mouse x
    ADD    R3,R1,#4        ;mouse y
    ADD    R0,R1,#8        ;buttons
    STR    R0,[sp,#-4]!    ;buttons is 5th arg
    ADD    R0,R1,#12       ;window handle
    ADD    R1,R1,#16       ;icon handle
    BL     wqclik_         ;call WQCLIK
    ADD    sp,sp,#4        ;restore stack
    B      loop
barmnu; 'menu' over baricon
    LDR    R0,[R1,#608]
    CMP    R0,#0
    BEQ    cl2             ;no menu set up
    LDR    R2,[R1]         ;mouse x
    SUB    R2,R2,#64       ;move to the left a bit
    MOV    ip,#28
    MOV    R3,#144         ;height with 1 entry
bml LDRB   lr,[R0,ip]
    TST    lr,#&80
    ADDEQ  ip,ip,#24
    ADDEQ  R3,R3,#44       ;add height of each entry
    BEQ    bml
    ADD    ip,R1,#596      ;address of current menu
    MOV    R1,R0
    STMIA  ip,{R1-R3}      ;store menu data
    SWI    Wimp_CreateMenu
    STR    R0,[ip,#1000-596];store top menu window handle
    STR    R1,[ip,#1004-596];store top menu block address
    LDR    R1,blk          ;pointer to block
    B      cl2
saveclik; click over save window (handle is in R0)
    LDR    R2,[R1,#16]     ;icon handle
    CMP    R2,#3           ;check for 'Cancel'
    BNE    SK1
    LDR    R4,[R1,#8]      ;get button pressed
    ADD    R0,R1,#12       ;pointer to window handle
    BL     wqclsw_
    CMP    R4,#1           ;if not 'adjust' then
    MOVNE  R1,#-1
    SWINE  Wimp_CreateMenu ;close any open menu
    B      loop
SK1 CMP    R2,#1
    BEQ    saveOK          ;click over 'Save' box
    LDRGT  R3,[R1,#8]      ;button
    RSBGTS R3,R3,#5
    BLE    loop            ;file name or button>4
    STR    R0,[R1]
    SWI    Wimp_GetWindowInfo;get whole window information
    ADD    R3,R1,#112
    LDMIA  R3,{R4-R6}      ;get file name icon data
    ADD    R3,R1,#624
    LDR    R0,[R1]
    STMIA  R3!,{R0,R4}     ;store handle and file address in COMMON
    SUB    R5,R4,#1
sc1 LDRB   lr,[R5,#1]!
    CMP    lr,#"."         ;look for leaf name
    ADDEQ  R4,R5,#1
    CMP    lr,#32
    BGE    sc1
    CMP    R5,R4
    BGT    SC2
    ADR    ip,em3
    BL     WP_err1
    B      loop
SC2 LDR    R7,[R1,#240]    ;get isize                         20/03/97
    LDR    R8,[R1,#244]    ;get itype                         20/03/97
    STMIA  R3,{R4,R6-R8}   ;store leaf address, length, isize & itype
    STR    R2,[R1,#4]
    ADR    lr,loop
;
wp_dbox; entry to set up drag box, window/icon handles in [R1],[R1,#4]
    SWI    Wimp_GetIconState
    LDMVCIB R1,{R2-R6}
    SWIVC  Wimp_GetWindowState
    LDMVCIB R1,{R0,R2,R7-R9,ip}
    MOVVC  R2,#5           ;set up drag box type 5
    SUBVC  R7,R0,R9        ;dx
    SUBVC  R8,R8,ip        ;dy
    ADDVC  R3,R3,R7
    ADDVC  R4,R4,R8
    ADDVC  R5,R5,R7
    ADDVC  R6,R6,R8
    MOVVC  R7,#0
    MOVVC  R8,#0
    MOVVC  R9,#&7F000000
    MOVVC  ip,#&7F000000
    STMVCIB R1,{R2-R9,ip}
    SWIVC  Wimp_DragBox
    MOV    pc,lr
;
key LDR    R0,[R1]         ;key press, get window handle
    BL     WP_savw         ;check if save window
    LDREQ  R2,[R1,#24]     ;yes, get code
    CMPEQ  R2,#13          ;check for <Return>
    LDREQ  R2,[R1,#4]      ;icon handle
    CMPEQ  R2,#0           ;check for file name icon
    BEQ    saveOK          ;same as clicking 'OK'
    ADD    R2,R1,#24
    ADD    R0,R1,#20
    STMFD  sp!,{R0,R2}     ;pointers to ICIND,KEY (5th and 6th args)
    ADD    R2,R1,#8        ;IX
    ADD    R3,R1,#12       ;IY
    MOV    R0,R1           ;IWHAN
    ADD    R1,R1,#4        ;ICONH
    BL     wqkeyp_         ;call WQKEYP
    ADD    sp,sp,#8        ;restore stack
    B      loop
em3 DCB    129,"please enter a legal file name before dragging",0
em4 DCB    129,"please enter complete path & file name,"
    DCB    " or drag icon to filer window",0
em6 DCB    129,"You can not overwrite a file of a different type",0
    ALIGN
saveOK; click over save 'OK' button or <Return>
    STR    R0,[R1]
    SWI    Wimp_GetWindowInfo;get whole window information
    MOV    R0,R1           ;address of window handle
    LDR    R9,[R1,#244]    ;new file type                     20/03/97
    LDR    R1,[R1,#112]    ;address of file name
    MOVS   R2,#-1          ;name length
    MOV    R8,#0           ;flag for not OK
sl1 CMPGT  R4,#"$"
    CMPNE  R4,#"@"
    CMPNE  R4,#"%"
    ADD    R2,R2,#1
    LDRB   R4,[R1,R2]
    CMPEQ  R4,#"."
    MOVEQ  R8,#1           ;flag OK
    CMP    R4,#32
    BGT    sl1
    CMP    R8,#0
    BNE    writefile
    ADR    ip,em4          ;not OK, complain
    BL     WP_err1
    B      loop            ;done
writefile;   CALL WQWFIL etc.
    STMFD  sp!,{R0-R2}     ;save arguments for WQWFIL
    MOV    R0,#17
    SWI    XOS_File        ;check for existing file
    BVC    WF1
    BL     WP_err3
    B      nwr             ;error in file name
WF1 CMP    R0,#1           ;check for none, file or directory
    BLT    wOK             ;none, so OK
    MOVGT  R2,#&1000       ;directory has  type &1000           07/08/98
    MOVEQ  R2,R2,LSL#12
    MOVEQ  R2,R2,LSR#20    ;get current type
    CMP    R2,R9
    BEQ    wOK
    ADR    ip,em6          ;not same type
    BL     WP_err1
    B      nwr
wOK LDMFD  sp,{R0-R2}      ;restore arguments for WQWFIL
    BL     wqwfil_
    MOV    R2,R9           ;file type
    CMP    R2,#&1000       ;check for directory                 07/08/98
    LDRLT  R1,[sp,#4]      ;pointer to file name
    MOVLT  R0,#18
    SWILT  XOS_File        ;set file type
nwr MOV    R1,#-1
    SWI    Wimp_CreateMenu ;close menu
    LDMFD  sp!,{R0-R2}     ;restore args
    BL     wqclsw_         ;close save window
    CMP    R8,#0
    BGT    loop            ;not called from drag
dta LDR    R1,blk
    ADD    R4,R1,#12
    LDR    R0,[R1,#8]
    MOV    R2,#3
    STMIA  R4!,{R0,R2}     ;my_ref & DataLoad message
    LDMIA  R4,{R2,R3}      ;get window & icon
    MOV    R0,#18          ;Recorded message
    SWI    Wimp_SendMessage
    B      loop            ;return
;
menu;   item selected
    LDR    R0,[R1,#596]    ;menu pointer
    MOV    R3,#1
ml1 LDR    R2,[R1,R3,LSL#2]
    CMP    R2,#0
    ADDGE  R3,R3,#1        ;count menu lists
    BGE    ml1
    ADD    R2,R1,#296      ;suitable address for NMENU
    STR    R3,[R2]
    BL     wqmenu_         ;CALL WQMENU
    LDR    R1,blk
    SWI    Wimp_GetPointerInfo
    LDR    R0,[R1,#8]      ;get button state
    TST    R0,#1           ;see if adjust
    ADDNE  R0,R1,#596
    LDMNEIA R0,{R1-R3}     ;restore menu data
    SWINE  Wimp_CreateMenu
    B      loop
blk DCD    WP_bloc
msk DCD    &E1973          ;allowed bits in poll mask
;
reply;   returned message
    LDR    R0,[R1,#660]    ;get original reference number
    LDR    R2,[R1,#8]      ;get reference number in message
    CMP    R0,R2
    BNE    umsg
    LDR    R2,Run
    STR    R2,[R1,#40]
    ADD    R0,R1,#40
    SWI    Wimp_StartTask
    B      loop            ;return
umsg;   user message?
    LDR    R1,blk          ;restore block pointer (R1)
    ADD    R0,R1,#296      ;address for MTYPE
    SUB    R9,R9,#18
    STR    R9,[R0]         ;MTYPE
    STR    R7,[R1,#12]     ;restore your_ref
    ADD    R2,R1,#8        ;(MREF)
    ADD    R3,R1,#12       ;(MREP)
    ADD    R5,R1,#20       ;(MESSG)
    SUB    R6,R4,#20       ;message length
    ADD    R4,R1,#16       ;(MACT)
    ADD    R1,R1,#4        ;(MFROM)
    STMFD  sp!,{R4-R6}     ;store extra args on stack
    BL     wqmesg_
    ADD    sp,sp,#12       ;restore stack
    B      loop
Run DCB    "run "
;
datatran; data transfer protocol
    CMP    R8,#4
    BEQ    loop            ;ignore DataLoadAck
    CMP    R8,#5           ;5 = DataLoad from double-clicked file
    BGT    umsg            ;try user if not file message
    BLT    qrf
    LDR    R0,[R1,#972]    ;double-clicked file: get expected file type
    LDR    R2,[R1,#40]     ;transmitted file type
    SUBS   R0,R0,R2
    BNE    umsg            ;user message? WQRFIL
    STR    R0,[R1,#24]     ;zero for icon handle of double-clicked file
qrf ADD    R5,R1,#44       ;start of name
    MOV    ip,R5
dl1 LDRB   lr,[ip,#1]!
    CMP    lr,#0
    BNE    dl1             ;find end of name
    SUB    ip,ip,R5        ;length of name (excl. zero terminator)
    CMP    R8,#3
    BLT    dt3             ;not DataLoad or DataOpen
    ADD    R0,R1,#20       ;destination window handle
    ADDGT  R0,R1,#24       ; or zero for double-clicked file
    ADD    R2,R1,#36       ;size
    ADD    R3,R1,#40       ;type
    STMFD  sp!,{R0-R3,R5,ip};store arg 5 & length on stack
    MOV    R0,#17
    MOV    R1,R5
    SWI    XOS_File        ;read catalogue info
    LDMFD  sp!,{R0-R3}     ;restore registers
    STRVC  R4,[R2]         ;store size
    ADD    R1,R1,#24       ;Icon handle
    BL     wqrfil_         ;call WQRFIL(IWH,IH,ISZ,ITYP,SF)
    LDMFD  sp!,{R5,ip}     ;restore stack etc.
    LDR    R1,blk          ;restore block pointer (R1)
    MOV    R0,#4           ;DataLoadAck
    STR    R0,[R1,#16]
    MOV    R0,#17
    LDR    R2,[R1,#4]      ;sender's task handle
    SWI    Wimp_SendMessage;acknowledge receipt of file
    ADR    R1,dts          ; delete scrapfile if this is what it is
    MOV    R2,#12          ;4 words in name
dl2 LDR    R3,[R1,R2]
    LDR    R4,[R5,R2]
    CMP    R3,R4
    BNE    loop            ;not <Wimp$Scrap>
    SUBS   R2,R2,#4
    BGE    dl2
    MOV    R0,#6
    SWI    XOS_File        ;delete scrap file                     02/03/98
    B      loop            ;return
dt3 CMP    R8,#2           ;start drag-handling
    BLT    datasave        ;DataSave -> initiate app to app transfer
    LDR    R1,blk          ;restore block pointer (R1)
    MOV    R8,#0           ;flag drag
    ADR    lr,dts          ; delete scrapfile if this is what it is
    MOV    R2,#12          ;4 words in name
dl4 LDR    R3,[lr,R2]
    LDR    R4,[R5,R2]
    CMP    R3,R4
    BNE    dl5             ;not <Wimp$Scrap>
    SUBS   R2,R2,#4
    BGE    dl4
    ADD    R0,R1,#624      ;address of handle of save window
    LDR    R9,[R1,#644]    ;new file type
    ADR    R1,dts          ;address of <Wimp$Scrap>
    MOV    R2,#12
    STMFD  sp!,{R0-R2}     ;save arguments for WQWFIL
    B      wOK             ;go write scrap file
dl5 LDR    R0,[R1,#636]    ;maximum length of users file name string
    CMP    R0,ip
    BGT    DL6
    ADD    R0,ip,#1
    ADR    ip,em7
    BL     WP_err2
    B      dta             ;no good, but must still acknowledge
DL6 ADD    R3,R1,#44       ;address of returned name
    ADD    R0,R1,#624      ;address of handle of save window
    LDR    R9,[R1,#644]    ;new file type
    LDR    R1,[R1,#628]    ;address for file name
    MOV    R2,ip           ;length of file name
    LDRB   lr,[R3]         ;check nane does not start with "<"      22/04/99
    CMP    lr,#"<"
    MOVEQ  R1,R3
    BEQ    writefile       ;then, don't copy it to icon.  end mod   22/04/99
dl6 LDRB   lr,[R3,ip]
    STRB   lr,[R1,ip]
    SUBS   ip,ip,#1
    BGE    dl6             ;move file name to icon
    B      writefile       ;go write file
datasave;   initiate save from another application to this one
    ADR    R0,dts
    LDMIA  R0,{R2,R3,R4,R6}
    STMIA  R5,{R2,R3,R4,R6};store scrap file name
    MOV    R0,#60
    STR    R0,[R1]         ;message size
    MOV    R0,#2           ;DataSaveAck
    STR    R0,[R1,#16]
    MOV    R0,#17
    LDR    R2,[R1,#4]      ;sender's task handle
    LDR    R3,[R1,#560]    ;our task handle        01/01/97
    CMP    R2,R3
    SWINE  Wimp_SendMessage;acknowledge receipt of file
    B      loop            ;return
dts DCB    "<Wimp$Scrap>",0,0,0,0  ;scrap file name (16 characters)
;
prequit;   pre-quit request received
    LDR    R0,[R1,#652]    ;get shut-down task handle
    CMP    R0,#0
    BNE    loop            ;return if already set
    STR    R4,[R1,#652]    ;store sender's task handle
    LDR    R0,[R1,#20]
    STR    R0,[R1,#656]    ;store flag word
    ADD    R0,R1,#128      ;space for return argument
    MOV    R2,#1
    STR    R2,[R0]         ;set arg .TRUE.
    BL     wqpreq_         ;call WQPREQ(.TRUE.)
    LDR    R1,blk          ;restore block pointer (R1)
    LDR    R2,[R1,#128]    ;get returned argument
    CMP    R2,#0           ;see if it has been set to .FALSE.
    MOVEQ  R0,#19          ;if so, send complaint to wimp
    LDREQ  R2,[R1,#4]      ;sender's task handle
    SWIEQ  Wimp_SendMessage;acknowledge message
    B      loop            ;return
;
mwarn;  pointer moving over menu arrow
    LDR    R0,[R1,#596]    ;menu pointer
    MOV    R4,#1
    ADD    R1,R1,#32       ;pointer to menu lists
ml2 LDR    R2,[R1,R4,LSL#2]
    CMP    R2,#0
    ADDGE  R4,R4,#1        ;count menu lists                26/02/98
    BGE    ml2
    ADD    R2,R1,#220      ;suitable address for NMENU
    STR    R4,[R2]
    BL     wqmwrn_         ;CALL WQMWRN
    LDR    R1,blk          ;restore block pointer (R1)
    ADD    ip,R1,#20
    LDMIA  ip,{R1-R3}      ;get pointer, x, y
    SWI    Wimp_CreateSubMenu
    CMP    R4,#5
    ADDLE  ip,ip,R4,LSL#3  ;move to correct submenu
    STRLE  R0,[ip,#1000-20];store sub-menu window handle    08/03/98
    STRLE  R1,[ip,#1004-20];store sub-menu address          08/03/98
    B      loop            ;return (no acknowledegment)
;
Help;   call from !Help
    ADD    R8,R8,#1
    STR    R8,[R1,#16]     ;return message type &503
    STR    R6,[R1,#12]     ;reference number
    LDR    R0,[R1,#32]
    BL     WP_savw         ;check for save window
    ADD    R0,R1,#20
    BEQ    helpsave        ;go make help for a save window
    LDMIA  R0,{R2-R6}      ;get x,y,button,window,icon
    ADD    R1,R1,#(24+240) ;move to spare space   +264
    MOV    R0,#0           ;just the icons
    SWI    Wimp_GetMenuState
    BVS    hl2             ;not menu
    SUB    R0,R1,#4
lp1 LDR    lr,[R0,#4]!
    CMP    lr,#0
    BGE    lp1
    SUBS   ip,R0,R1        ;4*(tree depth)
    RSBGTS lr,ip,#24       ;check >0 and <6
    BLE    hl2             ;not a menu
    ADD    R7,R1,ip,LSL#1
    LDR    lr,[R7,#992-24-240]!;current menu handle
    CMP    lr,R5
    LDREQ  R9,[R7,#4]      ;save menu address (R9 was <19)    10/03/98
    LDREQ  R6,[R0,#-4]     ;substitute icon number
hl2 STMIA  R1!,{R2-R6}     ;(R1 increased by 20)  +284
    CMP    R5,#0           ;check for over window
    SUBLE  R1,R1,#20       ;(restore R1 by subtracting 20) +264
    BLE    LP4
    STR    R5,[R1]
    SWI    Wimp_GetWindowState
    LDMIB  R1,{R0,R4-R8}
    SUB    R2,R2,R0
    ADD    R2,R2,R7        ;transform x to work area
    SUB    R3,R3,R6
    ADD    R3,R3,R8        ;transform y to work area
    SUB    R1,R1,#20       ;(restore R1 by subtracting 20) +264
    STMIA  R1,{R2,R3}     ;store them again
LP4 MOV    R2,#240
    SUB    R0,R1,#(240+4)  ;    +20
    STMFD  sp!,{R0,R2}     ;store address and length for text for WQHELP
    MOV    R4,#240
    LDR    R5,spc
hl3 STR    R5,[R0],#4
    SUBS   R4,R4,#4
    BGT    hl3             ;blank out message
    ADD    R3,R1,#4        ;address of iy
    MOV    R2,R1           ;address of ix
    CMP    R9,#19          ;check if menu                     10/03/98
    ADDLT  R0,R1,#12       ;address of window handle          10/03/98
    MOVGE  R0,R9           ;or address of menu                10/03/98
    ADD    R1,R1,#16       ;address of icon handle
    BL     wqhelp_         ;go get help WQHELP
    ADD    sp,sp,#8        ;restore stack
    LDR    R1,blk          ;restore block pointer (R1)
    MOV    R0,#264         ;maximum length of message
    ADD    R2,R1,#260      ;last word in message
hl4 LDR    ip,[R2,#-4]!
    CMP    ip,R5
    SUBEQ  R0,R0,#4
    BEQ    hl4
    MOV    R3,#0
    STR    R3,[R2,#4]      ;null terminate
hl5 STR    R0,[R1]
    LDR    R2,[R1,#4]
    MOV    R0,#17          ;User message
    SWI    Wimp_SendMessage;send message to !Help
    B      loop            ;return (no acknowledegment)
;
helpsave;         help for a save window
    ADR    R2,svm
hl6 LDRB   lr,[R2],#1
    STRB   lr,[R0],#1
    CMP    lr,#0
    BNE    hl6
    ADD    R0,R0,#3
    BIC    R0,R0,#3
    SUB    R0,R0,R1
    B      hl5
svm DCB    "Drag the filer icon to a filer window or|Mtype in the full file"
    DCB    " name and click 'Save' or|Mclick 'Cancel' if you do not want"
    DCB    " to save the file.",0
    ALIGN
;
userdb; User Drag Box
    LDR    R4,[R1,#632]    ;address of leaf name
    CMP    R4,#0
    BEQ    user_dragbox    ;not my drag box, so call user
    SWI    Wimp_GetPointerInfo
    ADD    R2,R1,#44       ;address to store leaf name
db1 LDRB   R3,[R4],#1
    STRB   R3,[R2],#1
    CMP    R3,#0
    BNE    db1
    STR    R3,[R1,#632]    ;clear my drag box flag
    SUB    R2,R2,R1        ;#bytes
    ADD    R2,R2,#3
    BIC    R0,R2,#3        ;round up
    LDMIA  R1,{R8,R9}      ;x & y
    ADD    R2,R1,#12
    LDMIA  R2,{R6,R7}      ;window & icon handles
    MOV    R4,#0           ;my_ref
    MOV    R5,#1           ;message type 1 = DataSave
    ADD    R2,R1,#640
    LDMIA  R2,{ip,lr}      ;file length & type
    MOV    R2,#0
    MOV    R3,#0
    STMIA  R1,{R0,R2-R9,ip,lr};fill in rest of message
    MOV    R2,R6           ;window handle
    MOV    R3,R7           ;icon handle
    MOV    R0,#17          ;User message
    SWI    Wimp_SendMessage
    B      loop
;
user_dragbox               ;real user drag box    changed   22/04/97
    LDMIA  R1,{R2-R5}      ;xl,yl,xh,yl in screen coordinates
    SWI    Wimp_GetPointerInfo
    LDR    R0,[R1,#12]     ;window handle
    CMP    R0,#0
    STR    R0,[R1,#20]!
    BLT    DX1
    SWI    Wimp_GetWindowState;find current window state
    LDMIB  R1,{R6-R9,ip,lr};get dimensions
    SUB    R8,ip,R6        ;dx
    SUB    R9,lr,R9        ;dy
    ADD    R2,R2,R8        ;transform to window
    ADD    R3,R3,R9
    ADD    R4,R4,R8
    ADD    R5,R5,R9
DX1 STMIA  R1,{R2-R5}      ;store transformed coords
    MOV    R2,R1           ;(IBOX)
    SUB    R0,R1,#8        ;(IWH)
    SUB    R1,R1,#4        ;(ICH)
    BL     wqdrag_         ;CALL WQDRAG(IWH,ICH,IBOX)
    B      loop
spc DCB    "    "
em7 DCB    3,"file name too long () for icon",0
    ALIGN
;
re_draw;                                      06/02/97
    STR    lr,[sp,#-4]!    ;                  06/02/97
    MOV    R0,#1
    STR    R0,[R1,#796]    ;set drawing flag
    SWI    Wimp_RedrawWindow
    LDR    R2,[R1,#800]    ;# sprite windows
    LDR    R3,[R1]         ;this window handle
    ADD    R9,R1,#788
rd1 SUBS   R2,R2,#1
    MOVLT  R9,#0
    BLT    rd2
    LDR    R4,[R9,#20]!    ;get sprite window handle & point to block
    CMP    R4,R3
    BNE    rd1
rd2 CMP    R0,#0           ;any more?
    STREQ  R0,[R1,#796]    ;reset drawing flag
    LDREQ  pc,[sp],#4      ;none, so return                  06/02/97
    LDMIB  R1!,{R2-R7}     ;load useful coordinates
    SUB    R2,R2,R6        ;x-transform
    SUB    R3,R5,R7        ;y-transform
    CMP    R9,#0
    BLNE   WP_sprite       ;sprite window update
    BL     WP_orig         ;move origin to R2,R3
    LDMIB  R1,{R4-R7}      ;get graphics window
    SUB    R4,R4,R2        ;correct for moved origin
    SUB    R5,R5,R3
    SUB    R6,R6,R2
    SUB    R7,R7,R3
    STMIA  R1,{R4-R7}      ;store transformed graphics window
    ADD    R2,R1,#4        ;pointer to IY1
    ADD    R3,R1,#8        ;pointer to IX2
    ADD    R4,R1,#12       ;pointer to IY2
    LDR    R0,blk          ;address of window handle
    STR    R4,[sp,#-4]!    ;store 5th arg on stack
    BL     wqplot_         ;do the drawing
    ADD    sp,sp,#4        ;restore stack
    LDR    R1,blk          ;pointer to block
    MOV    R2,#0
    MOV    R3,#0
    BL     WP_orig         ;restore origin
    SWI    Wimp_GetRectangle;get next rectangle to draw
    B      rd2
;
WP_orig; move origin to R2,R3
    STMFD  sp!,{R0,R1,lr}
    MOV    R1,#&FF         ;mask
    SWI    OS_WriteI+29    ;VDU29
    AND    R0,R1,R2        ;xl
    SWI    OS_WriteC
    AND    R0,R1,R2,ASR#8  ;xh
    SWI    OS_WriteC
    AND    R0,R1,R3        ;yl
    SWI    OS_WriteC
    AND    R0,R1,R3,ASR#8  ;yh
    SWI    OS_WriteC
    LDMFD  sp!,{R0,R1,pc}  ;return
;
WP_sprite; sprite window update (R2,R3) are OS coords of top left of work area
    STMFD  sp!,{R1-R3,lr}
    LDR    R0,[R9,#16]     ;y size
    SUB    R4,R3,R0        ;y
    MOV    R3,R2           ;x
    MOV    R5,#0           ;gcol action
    MOV    R0,#34          ;for spriteop 34
    ADD    R2,R9,#4        ;pointer to sprite name
    SWI    OS_SpriteOp
    LDMFD  sp!,{R1-R3,pc} 
    END
;
;         end of wploop !!!!!
;
    TTL    wpmaks
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
R9  RN     9
OS_Byte              EQU 6
OS_ChangeDynamicArea EQU &2002A;error return bit set
OS_ReadModeVariable  EQU &35
OS_CheckModeValid    EQU &3F
OS_SpriteOp          EQU &2002E
Wimp_GetWindowState  EQU &600CB
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpmaks_         ;(IWHAN,ISX,ISY,MODE)
    IMPORT wpdels_
    IMPORT WP_err1
    IMPORT WP_err2
    IMPORT WP_err3
    IMPORT WP_bloc
    IMPORT WP_drck
    DCB    "WPMAKS",0,0,8,0,0,255
wpmaks_
    MOV    ip,sp
    STMDB  sp!,{R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R4,[R0]         ;window handle
    LDR    R7,[R1]         ;ISX
    LDR    R8,[R2]         ;ISY
    LDR    R6,[R3]         ;mode
    MOV    R0,R6
    CMP    R0,#-1
    BEQ    pt1
    SWI    OS_CheckModeValid
    BCC    pt1
    ADR    ip,em1          ;invalid mode
    MOV    R0,R6
    BL     WP_err2
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
pt1 LDR    R9,pts          ;pointer to sprite window data
;
; sprite window data have:
; #sprite windows (max 8),
; pointer to current sprite window info record (0 if none),
; then for each sprite window, 20 byte info records:
; the window handle (4 bytes)
; the sprite name (12 bytes) "F77_WimpX",0,0,0  where X=a,b,c...
; the height of the window in OS units (4 bytes)
;
    LDR    ip,[R9],#8      ;number of sprite windows already set up
    MOV    R2,ip
lp1 SUBS   R2,R2,#1
    BLT    new             ;new window handle
    LDR    lr,[R9],#20     ;get stored window handle
    CMP    lr,R4           ;look for this window handle in current list
    BNE    lp1
    SUB    R0,R9,#20       ;pointer to window handle
    BL     wpdels_         ;sprite exists, so delete it
    B      pt1             ;and start again
em1 DCB    2,"invalid mode () for sprite",0
em2 DCB    2,"too many sprite windows",0
em3 DCB    2,"window must have user redraw facility",0
    ALIGN
; set up new sprite
new SUB    sp,sp,#36       ;set up 36-byte block for window state
    MOV    R1,sp
    STR    R4,[R1]
    SWI    Wimp_GetWindowState
    BVS    err3
    LDR    R0,[R1,#32]     ;get window flags
    RSBS   R1,ip,#7
    ADRLT  ip,em2          ;too many sprite windows
    TSTGE  R0,#16          ;window must not have auto-redraw bit
    ADRNE  ip,em3
    BNE    err1
    STR    R4,[R9]         ;save window handle
    STR    R8,[R9,#16]     ;store y-size (OS-units) for plotting
    MOV    R0,R6           ;required mode
    MOV    R1,#4           ;x-scaling
    SWI    OS_ReadModeVariable
    MOV    R7,R7,LSR R2    ;x-size of window (pixels)
    MOV    R1,#5           ;y-scaling
    SWI    OS_ReadModeVariable
    MOV    R8,R8,LSR R2    ;y-size of window (pixels)
    MOV    R1,#9
    SWI    OS_ReadModeVariable
    RSB    lr,R2,#5
    MOV    R2,R7,LSR lr    ;x-size in words
    CMP    R7,R2,LSL lr    ;check for no odd pixels beyond word boundary
    ADDNE  R2,R2,#1        ;     then allow 1 extra word
    MOV    R2,R2,LSL#2     ;x-space in bytes
    MUL    lr,R2,R8
    ADD    lr,lr,#44       ;space needed for sprite
    MOV    R0,#8
    SWI    OS_SpriteOp     ;get system area space (R2-R5)
    MOVVS  R0,#-16
    SUBVC  R0,R2,R5        ;free space in system sprite area
    SUBS   R1,lr,R0        ;required memory increase
    BLE    MS1
    MOV    R2,R1
    MOV    R0,#3           ;for system sprite area
    SWI    OS_ChangeDynamicArea
    CMP    R2,R1           ;check there is enough space
    ADRGT  ip,em4
    BGT    err1
;          set up new sprite name
MS1 MOV    lr,#"a"
    MOV    R0,#24
    ADD    R2,R9,#4        ;pointer to sprite name
lp2 STR    lr,[R9,#12]     ;final letter of name
    SWI    OS_SpriteOp     ;select sprite (to test if it exists)
    ADDVC  lr,lr,#1
    BVC    lp2             ;loop until it fails
    CMP    R6,#0           ;has user selected a mode?
    BGE    MS2
    MOV    R0,#135         ;  no, so
    SWI    OS_Byte         ;  get current mode
    MOV    R6,R2           ;  put it into R6
MS2 MOV    R0,#15          ;SpriteOp number
    ADD    R2,R9,#4        ;pointer to new sprite name
    MOV    R3,#0           ;no palette
    MOV    R4,R7           ;width
    MOV    R5,R8           ;height
    SWI    OS_SpriteOp     ;initialise sprite
    BVS    err3
    LDR    R0,pts
    ADD    R8,ip,#1
    STR    R8,[R0]         ;store new count of sprite windows     04/05/97
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
err1 BL     WP_err1
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
err3 BL     WP_err3
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
pts DCD    WP_bloc+800     ;pointer to sprite info
em4 DCB    2,"not enough memory to make window sprite",0
    END
;
    TTL    wpmesg
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
Wimp_SendMessage EQU &600E7
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpmesg_         ;(MTYPE,MTO,MREF,MACT,MESG)
    IMPORT WP_bloc
    IMPORT WP_err3
    DCB    "WPMESG",0,0,8,0,0,255
wpmesg_
    MOV    ip,sp
    STMDB  sp!,{R4-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]         ;MTYPE
    CMP    R0,#-1
    RSBGES lr,R0,#1
    LDMLTDB fp,{R4-R5,fp,sp,pc} ;return on illegal MTYPE
    ADD    R0,R0,#18       ;set up the reason code
    LDMIA  ip,{R4,R5}      ;(MESG) & LEN(MESG)
    LDR    ip,[R2]         ;Reference number
    LDR    lr,[R3]         ;action
    LDR    R2,[R1]         ;task handle of recipient
    LDR    R1,ptr          ;block for message
    ADD    R3,R1,#12       ;where to start storing data
    STMIA  R3!,{ip,lr}     ;store reference # and action
    CMP    R5,#236
    MOVGT  R5,#236         ;limit message to 236 characters
    MOVGE  ip,R5
    ADDLT  ip,R5,#4
    BICLT  ip,ip,#3        ;length rounded up to multiple of 4
    ADD    lr,ip,#20
    STR    lr,[R1]         ;length of message
    MOVLT  lr,#0
lp1 SUBLT  ip,ip,#1
    STRLTB lr,[R3,ip]
    CMP    R5,ip
    BLT    lp1
lp2 SUBS   ip,ip,#1
    LDRB   lr,[R4,ip]
    STRB   lr,[R3,ip]
    BGT    lp2
    SWI    Wimp_SendMessage
    BLVS   WP_err3
    LDMDB  fp,{R4-R5,fp,sp,pc} ;return
ptr DCD    WP_bloc+300     ;address of temporary work space
    END
;
    TTL     wpmkmb
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
R9  RN     9
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpmkmb_         ;(SDATA,IMBLK)
    IMPORT WP_bloc
    IMPORT WP_err1
    DCB    "WPMKMB",0,0,8,0,0,255
wpmkmb_
    MOV    ip,sp
    STMDB  sp!,{R1,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R3,#0           ;maximum string length
    BL     store           ;store title
    ADRLT  ip,em1
    BLT    WP_err1         ;fatal error
    ADR    R5,sw           ;address of standard words
    LDMIA  R5!,{R6-R9}
    STMIA  R1!,{R6-R9}     ;4 words of prologue
    LDMIA  R5,{R6-R8}      ;entry prologue
    MOV    R5,#2+8         ;underline flag ???
lm1 STMIA  R1!,{R6-R8}     ;store entry prologue
    BL     store           ;store name
    BGE    lm1             ;loop over entries
    MOV    ip,#&88
    STRB   ip,[R1,#-24]    ;last entry flag
    ADD    R3,R3,#1        ;allow extra width
    MOV    R3,R3,LSL#4     ;16 per character
    LDR    R1,[sp]         ;restore IMBLK address
    STR    R3,[R1,#16]     ;store width
    LDMDB  fp,{R1,R4-R9,fp,sp,pc} ;return
;       standard words
sw  DCD    &00070207       ;colours
    DCD    0               ;width (overwitten)
    DCD    44              ;height
    DCD    0               ;vertical gap
    DCD    8               ;flags (call submenu)
    DCD    -1              ;no sub-menu
    DCD    &07009031       ;icon flags
store;  store text in mbloc
;       reads from [R0], stores in [R1], stores maximum length in R3
    MOV    R4,#0           ;length
ls1 SUBS   R2,R2,#1
    BLT    ps1             ;end of data
    LDRB   ip,[R0],#1
    CMP    ip,#","
    BEQ    ps1
    CMP    R4,#0           ;first byte?
    CMPEQ  ip,#"_"         ; is it '_'?
    STREQB R5,[R1,#-12]    ; then store underline
    BEQ    ls1             ;      and skip
    ADD    R4,R4,#1
    CMP    R4,#12
    STRLEB ip,[R1],#1
    BLE    ls1
;       error >12 characters, move to temporary space
    LDR    R1,ptr
    ADD    R2,R2,R4
    SUB    R0,R0,R4
    CMP    R2,#40
    MOVGT  R2,#40          ;limit length to 40 characters
ls2 LDRB   ip,[R0],#1
    CMP    ip,#","
    STRNEB ip,[R1],#1
    SUBNES R2,R2,#1
    BNE    ls2
    MOV    ip,#0
    STRB   ip,[R1]
    LDR    R0,ptr
    ADR    ip,em2
    B      WP_err1         ;terminate program
ps1 CMP    R4,R3
    MOVGT  R3,R4           ;find greatest length
    MOV    ip,#0
    RSBS   R4,R4,#12
ls3 STRGTB ip,[R1],#1
    SUBS   R4,R4,#1
    BGT    ls3
    CMP    R2,#0
    MOV    pc,lr           ;return LT when finished
ptr DCD    WP_bloc         ;address of temporary work space
em1 DCB    2,"SDATA contains no menu items",0,0,0
em2 DCB    2,"menu item '' > 12 characters",0,0
    END
;
    TTL    wpmknw
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
R9  RN     9
Wimp_CreateWindow  EQU &400C1
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpmknw_         ;(IX,IY,JX,JY,KX,KY,LX,LY,TITL,IW)
    IMPORT WP_err1
    IMPORT WP_drck
    DCB    "WPMKNW",0,0,8,0,0,255
wpmknw_
    MOV    ip,sp
    STMDB  sp!,{R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDMIA  ip,{R4-R9,lr}   ;address of KX to IW & length of TITL
    LDR    R0,[R0]         ;IX  ;work area size
    LDR    R1,[R1]         ;IY
    LDR    R2,[R2]         ;JX  ;corner of window
    LDR    R3,[R3]         ;JY
    LDR    R4,[R4]         ;KX  ;size of window
    LDR    R5,[R5]         ;KY
    LDR    R6,[R6]         ;LX  ;scroll offsets
    LDR    R7,[R7]         ;LY
    MOV    ip,#-1
    STR    ip,[R9]         ;set window handle to -1
    LDR    ip,ptr
    STR    R0,[ip,#48]     ;maximum x of work area
    RSB    R1,R1,#0
    STR    R1,[ip,#44]     ;minimum y of area (<0)
    CMP    R4,#4           ;check window x-size
    ADRLT  R0,x
    ADRLT  ip,em1
    BLT    err
    CMP    R5,#4           ;check window y-size
    ADRLT  R0,y
    ADRLT  ip,em1
    BLT    err
    SUBS   R0,R0,R4        ;work-x - window-x
    ADRLT  R0,x
    ADRLT  ip,em2
    BLT    err
    ADDS   R1,R1,R5        ;-(work-y - window-y)
    ADRGT  R0,y
    ADRGT  ip,em2
    BGT    err
    CMP    R6,#0           ;check scroll x
    ADRLT  R0,x
    ADRLT  ip,em3
    BLT    err
    CMP    R0,R6           ;check scroll x
    ADRLT  R0,x
    ADRLT  ip,em4
    BLT    err
    CMP    R1,R7           ;check scroll y
    ADRGT  R0,y
    ADRGT  ip,em3
    BGT    err
    CMP    R7,#0           ;check scroll y
    ADRGT  R0,y
    ADRGT  ip,em4
    BGT    err
    ADD    R4,R4,R2        ;top corner of window
    ADD    R5,R5,R3
    STMIA  ip,{R2-R7}      ;store visible area & scroll offsets
    MOV    R1,ip
    STR    R8,[R1,#72]     ;address of title
    STR    lr,[R1,#80]     ;length of title
    SWI    Wimp_CreateWindow
    STR    R0,[R9]         ;store window handle
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
err BL     WP_err1
    MOV    R0,#-1
    STR    R0,[R9]
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
ptr DCD    WP_win
x   DCB    "x",0
y   DCB    "y",0
em1 DCB    3,"-size of visible window too small",0
em2 DCB    3,"work area -size smaller than window",0
em3 DCB    3,"scroll- is too small",0
em4 DCB    3,"scroll- is too big",0
;
    AREA   WP_win,DATA
    EXPORT WP_win          ;window data area
    DCD    0,0,0,0         ;visible area             (00)
    DCD    0,0             ;scroll offsets           (16)
    DCD    -1              ;open on top              (24)
    DCD    &FF000002       ;window flags             (28)
    DCB    7,2,7,1         ;colours                  (32)
    DCB    3,1,12,0        ;colours                  (36)
    DCD    0,0,0,0         ;work area                (40)
    DCD    &13D            ;title flags              (56)
    DCD    &3000           ;window button type       (60)
    DCD    1               ;sprite area control block(64)
    DCD    &00000000       ;mimium size of window    (68)
    DCD    0,-1,0          ;title data               (72)
    DCD    0               ;#icons                   (84)
    END
;
    TTL    wpmnws
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpmnws_         ;(IXMIN,IYMIN) set minimum window size for WPMKNW
    IMPORT WP_win
    DCB    "WPMNWS",0,0,8,0,0,255
wpmnws_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]         ;get IXMIN
    CMP    R0,#&10000
    MOVHS  R0,#0
    LDR    R1,[R1]         ;get IYMIN
    CMP    R1,#&10000
    MOVHS  R1,#0
    ORR    R0,R1,R0,LSL#16 ;make into xxxxyyyy (hex)
    LDR    R1,ptr
    STR    R0,[R1,#68]     ;store
    LDMDB  fp,{fp,sp,pc}   ;return
ptr DCD    WP_win
    END
;
    TTL    wpnult
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpnult_         ;(ITIME) set pollidle time
    IMPORT WP_bloc
    DCB    "WPNULT",0,0,8,0,0,255
wpnult_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]         ;get ITIME
    LDR    R1,ptr
    STR    R0,[R1,#588]    ;store
    LDMDB  fp,{fp,sp,pc}   ;return
ptr DCD    WP_bloc
    END
;
    TTL    wpopnt
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
Wimp_OpenTemplate EQU &600D9
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpopnt_         ;(SFILE) open template file
    IMPORT WP_bloc
    IMPORT WP_err3
    IMPORT WP_drck
    DCB    "WPOPNT",0,0,8,0,0,255
wpopnt_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    MOV    R2,R1           ;length of file name
    LDR    R1,ptr          ;buffer to receive file name
    CMP    R2,#255
    MOVGT  R2,#255         ;limit size
    MOV    ip,#0
lo1 STRB   ip,[R1,R2]
    SUBS   R2,R2,#1
    LDRGEB ip,[R0,R2]
    BGE    lo1             ;move file name
    SWI    Wimp_OpenTemplate
    BLVS   WP_err3
    LDMDB  fp,{fp,sp,pc}   ;return
ptr DCD    WP_bloc+300
    END
;
    TTL    wpoptx
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN      0
R1  RN      1
R2  RN      2
Wimp_CommandWindow  EQU &400EF
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpoptx_         ;(STITL) open text window
    IMPORT WP_bloc
    IMPORT WP_drck
    DCB    "WPOPTX",0,0,8,0,0,255
wpoptx_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R2,ptr          ;work space
    MOV    ip,#0
    STRB   ip,[R2,R1]      ;null terminate
lp1 SUBS   R1,R1,#1
    LDRGEB ip,[R0,R1]      ;copy title
    STRGEB ip,[R2,R1]
    BGT    lp1
    MOV    R0,R2           ;address of title
    SWI    Wimp_CommandWindow
    LDMDB  fp,{fp,sp,pc}   ;return
ptr DCD    WP_bloc+300
    END
;
    TTL    wppane
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
Wimp_GetWindowState EQU &600CB
tmp EQU 300                ;skip to working space
    AREA   |C$$code|,CODE,READONLY
    EXPORT wppane_         ;(IWPANE,IWHOST,SIDE)
    IMPORT wpopnw_
    IMPORT wpclsw_
    IMPORT WP_err1
    IMPORT WP_err2
    IMPORT WP_bloc
    IMPORT WP_drck
    DCB    "WPPANE",0,0,8,0,0,255
wppane_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,R4-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R3,[R0]         ;IWPANE
    LDR    R4,[R1]         ;IWHOST
    LDR    R1,ptr
    STR    R3,[R1]
    SWI    Wimp_GetWindowState
    MOVVS  R0,R3
    ADRVS  ip,em1
    BVS    err2         ;pane handle does not exist
    ADD    R6,R1,#732-tmp  ;pointer to # panes
    LDRB   R0,[R6]         ;# panes
lp1 CMP    R0,#0
    LDRNE  ip,[R6,R0,LSL#3];get pane handle
    CMPNE  ip,R3
    SUBNES R0,R0,#1
    BNE    lp1             ;loop over attached panes
    CMP    R4,#-1          ;check for detach
    BEQ    detach
;       attach here
    CMP    R0,#0           ;check it is not already attached
    MOVNE  R0,R3
    ADRNE  ip,em2
    BNE    err2         ;pane already attached
    STR    R4,[R1]
    SWI    Wimp_GetWindowState
    MOVVS  R0,R4
    ADRVS  ip,em3
    BVS    err2         ;host handle does not exist
    LDRB   R2,[R2]         ;get side
    CMP    R2,#96
    SUBGT  R2,R2,#32       ;convert to upper case
    ADR    R0,sds
    MOV    R5,#0
lp2 LDRB   ip,[R0,R5]
    ADD    R5,R5,#1
    CMP    ip,R2
    CMPNE  R5,#4
    BNE    lp2
    CMP    ip,R2
    ADDNE  R0,R1,#128
    STRNE  R2,[R0]
    ADRNE  ip,em4
    BNE    err1
;       see if host/pane/side has been used before
    LDRB   R0,[R6]         ;# panes
    CMP    R0,#0
    BEQ    pt1
    ADD    ip,R6,#1        ;pointer to side
    ADD    R2,R6,#8        ;pointer to pane
lp3 LDR    lr,[R2],#4      ;get pane
    CMP    lr,R4           ;compare to new host
    ADREQ  ip,em7          ;host already pane
    MOVEQ  R0,R4
    BEQ    err2
    LDR    lr,[R2],#4      ;get host
    CMP    lr,R3           ;compare to new pane
    ADREQ  ip,em8          ;pane already host
    MOVEQ  R0,R3
    BEQ    err2
    CMP    lr,R4           ;compare to new host
    LDRB   lr,[ip],#1      ;get side
    ANDEQ  lr,lr,#127      ;strip relevant bits
    CMPEQ  lr,R5
    ADREQ  ip,em9          ;pane already host
    MOVEQ  R0,R4
    BEQ    err2
    SUBS   R0,R0,#1
    BGT    lp3
    LDRB   R0,[R6]         ;# panes
pt1 ADD    R0,R0,#1
    CMP    R0,#7
    ADRGT  ip,em5
    BGT    err1         ;too many pane attachments
;       at last! Store new pane attachment
    STRB   R0,[R6]         ;# panes
;            move up any old panes
lp4 SUBS   R0,R0,#1
    ADDGT  R7,R6,R0
    ADDGT  R8,R6,R0,LSL#3
    LDRGTB ip,[R7],#1
    STRGTB ip,[R7]
    LDMGTIA R8!,{ip,lr}
    STMGTIA R8,{ip,lr}
    BGT    lp4
;            store new pane
    STRB   R5,[R6,#1]      ;side flag (1:4)
    STR    R3,[R6,#8]      ;pane handle
    STR    R4,[R6,#12]     ;host handle
;       now see whether host is open
    LDR    R0,[R1,#32]     ;get host window flags
    TST    R0,#&10000
    LDRNE  R0,[sp,#4]      ;pointer to IWHOST
    BLNE   wpopnw_         ;re-open host
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
detach; detach pane here
    CMP    R0,#0           ;check pane is attached
    MOVEQ  R0,R3
    ADREQ  ip,em6
    BEQ    err2         ;pane not attached
    LDRB   R1,[R6]         ;current # attached panes
    SUB    R1,R1,#1        ;decrement
    STRB   R1,[R6]
    ADD    R5,R6,#4
lp5 ADD    R2,R0,#1
    CMP    R1,R0
    LDRGEB ip,[R6,R2]
    STRGEB ip,[R6,R0]      ;shift down side flags
    LDRGE  ip,[R6,R2,LSL#3]
    STRGE  ip,[R6,R0,LSL#3];shift down pane handles
    LDRGE  ip,[R5,R2,LSL#3]
    STRGE  ip,[R5,R0,LSL#3];shift down host handles
    MOVGE  R0,R2
    BGT    lp5
    LDR    R0,[sp]         ;address of pane handle
    BL     wpclsw_         ;close the pane
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
;
err1 BL     WP_err1         ;unknown side definition
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return after error
;
err2 BL     WP_err2         ;pane handle does not exist
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return after error
;
ptr DCD    WP_bloc+tmp
sds DCB    "LBRT"
em1 DCB    3,"pane handle () unknown",0
    ALIGN
em2 DCB    3,"pane (handle ) already attached",0
    ALIGN
em3 DCB    3,"host handle () unknown",0
    ALIGN
em4 DCB    3,"unknown side definition ''",0
    ALIGN
em5 DCB    3,"tried to attach >7 panes",0
    ALIGN
em6 DCB    3,"pane (handle ) not attached",0
    ALIGN
em7 DCB    3,"host (handle ) is already a pane",0
    ALIGN
em8 DCB    3,"pane (handle ) is already a host",0
    ALIGN
em9 DCB    3,"host (handle ) has side already used",0
    END
;
    TTL    wppicc
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
sl  RN     10
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
R9  RN     9
ColourPicker_OpenDialogue  EQU &67702
ColourPicker_CloseDialogue EQU &67703
Wimp_Poll                  EQU &400C7
XWimp_SetCaretPosition     EQU &600D2
Wimp_GetCaretPosition      EQU &400D3
    AREA   |C$$code|,CODE,READONLY
    EXPORT wppicc_         ;(IX,IY,TIT,IR,IG,IB)
    IMPORT __rt_stkovf_split_small
    IMPORT WP_drck
    IMPORT WP_err1
    IMPORT WP_bloc
    IMPORT re_draw
    IMPORT wp_quit
    IMPORT wqopnw_
    IMPORT wqclsw_
    DCB    "WPPICC",0,0,8,0,0,255
wppicc_
    MOV    ip,sp
    STR    R3,[sp,#-4]!    ;store (IR) on stack next to (IG) & (IB)
    STMDB  sp!,{R0-R2,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#8
    BL     WP_drck         ;check we are not drawing
    SUB    sp,sp,#200      ;space for:
;      picker window title     40  (0)
;      dialogue handle          4  (40)
;      picker window handle     4  (44)
;      colour picker block     64  (48)
;      colour descriptor       64
;      caret position          24 (176)
    CMP    sp,sl
    BLLT   __rt_stkovf_split_small
    LDR    R5,[R1]         ;IY
    MOV    R6,R0           ;save R0 from the wimp
    ADD    R1,sp,#176      ;get current caret position
    SWI    Wimp_GetCaretPosition
    LDR    R3,[fp,#16]     ;length of TIT
    CMP    R3,#39
    MOVGT  R3,#39          ;limit length to 39
    MOV    R1,sp           ;space for null terminated title
    LDRB   lr,[R2]
    CMP    lr,#0
    MOVEQ  R1,#0           ;null title
    BEQ    pt1
    MOV    lr,#0
lp1 STRB   lr,[R1,R3]      ;transfer null terminated title
    SUBS   R3,R3,#1
    LDRGEB lr,[R2,R3]
    BGE    lp1
pt1 LDR    R2,[R6]         ;IX
    MOV    R0,#1           ;allow 'None' icon
    MOV    R3,fp
    MOV    R8,#&800000
lp2 LDR    R4,[R3,#4]!     ;get (IR) etc.
    LDR    R6,[R4]         ;get IR etc.
    CMP    R6,#-1
    ORREQ  R0,R0,#2        ;select 'None'
    MOVS   R8,R8,LSR#8
    ORR    R8,R8,R6,LSL#24
    BCC    lp2             ;loop over colours
    MOV    R3,#&8,4
    MVN    R4,R3
    MOV    R6,#0
    MOV    R9,#0
    ADD    ip,sp,#48       ;place for colour picker block         10/02/97
    STMIA  ip,{R0-R9}      ;store colour picker block
    MOV    R1,ip           ;pointer to block
    MOV    R0,#0
    SWI    ColourPicker_OpenDialogue
    BVC    CP1
    ADR    ip,em1
    BL     WP_err1
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return on error
CP1 STMDB  ip,{R0,R1}      ;store dialogue and window handles
;        now set up new wimp poll for colour dialogue
lp3 MOV    R0,#&71         ;poll mask  (redraw and messages)
    LDR    R1,blk
    SWI    Wimp_Poll
    CMP    R0,#3
    LDRLE  ip,[R1]         ;handle of window to be redrawn etc.
    LDRLE  lr,[sp,#44]     ;handle of colour picker window
    CMPLE  ip,lr
    BEQ    lp3             ;don't do window ops on colour picker
    ADR    lr,lp3          ;return address
    CMP    R0,#1
    BEQ    re_draw         ;do redrawing
    CMP    R0,#3
    MOVLE  R0,R1
    BLT    wqopnw_         ;open window
    BEQ    wqclsw_         ;close window
    CMP    R0,#17
    RSBGE  ip,R0,#18
    BLT    lp3             ;skip all other events except incoming messages
    LDMIB  R1,{R3-R9}      ;get useful numbers
    CMP    R6,#0           ;check for quit
    LDREQ  fp,[R1,#968]    ;restore wploop's frame
    BEQ    wp_quit         ;and quit job (must have Z-flag set)
    LDR    R1,[sp,#40]     ;dialogue handle
    CMP    R1,R7
    BNE    lp3             ;not our colour dialogue
    SUBS   R6,R6,#&47000
    SUBGES R6,R6,#&700
    ANDEQ  R8,R8,#1        ;only use bit 0 of returned flags
    BEQ    pt2             ;&47700
    CMPGT  R6,#2
    BNE    lp3             ;not &47702
    MOV    R8,#2           ;CloseRequest   no colour selected
pt2 MOV    R0,#3           ;colour count
lp4 LDR    ip,[fp,R0,LSL#2];(IB) etc
    RSBS   R5,R8,#0        ;-1 for 'None', -2 for no selection
    MOVEQ  R5,R9,LSR#24    ;or BGR value [0:255]
    MOVEQ  R9,R9,LSL#8
    STR    R5,[ip]         ;store IB etc
    SUBS   R0,R0,#1
    BGT    lp4
    SWI    ColourPicker_CloseDialogue
    ADD    sp,sp,#176
    LDMIA  sp!,{R0-R5}     ;restore caret
    SWI    XWimp_SetCaretPosition
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
blk DCD    WP_bloc         ;normal space for wimp-poll data
em1 DCB    3,"Colour picker module not available",0
    END
;
    TTL    wpplot
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
Wimp_ForceRedraw EQU &600D1
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpplot_         ;(IWH,IXL,IYL,IXH,IYH) mark area for redraw
    IMPORT WP_err3
    IMPORT WP_drck
    DCB    "WPPLOT",0,0,8,0,0,255
wpplot_
    MOV    ip,sp
    STMDB  sp!,{R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R4,[ip]         ;address of IYH
    LDR    R0,[R0]         ;window handle
    LDR    R1,[R1]         ;IXL
    CMP    R1,#0
    MOVLT  R1,#0
    MOVLT  R2,#&FF000000
    MOVLT  R3,#&00FF0000
    MOVLT  R4,#0
    LDRGE  R2,[R2]
    LDRGE  R3,[R3]
    LDRGE  R4,[R4]
    SWI    Wimp_ForceRedraw
    BLVS   WP_err3
    LDMDB  fp,{R4,fp,sp,pc} ;return
    END
;
    TTL    wppreq
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
Wimp_ProcessKey  EQU &400DC
    AREA   |C$$code|,CODE,READONLY
    EXPORT wppreq_         ;continue with shut down sequence
    IMPORT WP_bloc
    IMPORT wqquit_
    IMPORT wpquit_
    IMPORT WP_drck
    DCB    "WPPREQ",0,0,8,0,0,255
wppreq_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R1,ptr          ;get space for message
    ADD    R0,R1,#652      ;address of shut-down task handle
    LDMIA  R0,{R2,R3}      ;get task handle and type
    CMP    R2,#0
    LDMEQDB fp,{fp,sp,pc}  ;do nothing if WQPREQ not called
    TST    R3,#1
    BNE    PQ1
    MOV    R0,#&1FC
    SWI    Wimp_ProcessKey
    LDMDB  fp,{fp,sp,pc}   ;return
PQ1 BL     wqquit_
    BL     wpquit_
    LDMDB  fp,{fp,sp,pc}   ;return
ptr DCD    WP_bloc
    END
;
    TTL    wpquit
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R4  RN     4
R5  RN     5
Wimp_CloseDown EQU &400DD
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpquit_         ;organise closing the wimp
    IMPORT WP_bloc
    IMPORT WP_drck
    IMPORT wpdelw_
    DCB    "WPQUIT",0,0,8,0,0,255
wpquit_
    MOV    ip,sp
    STMDB  sp!,{R4,R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    SUB    sp,sp,#4        ;space for argument of WPDELW
    LDR    R5,ptr
    LDR    R4,[R5,#800]    ;number of sprite windows
lp1 SUBS   R4,R4,#1
    LDRGE  R0,[R5,#808]    ;sprite window handle
    STRGE  R0,[sp]
    MOVGE  R0,sp
    BLGE   wpdelw_         ;remove sprite & window
    CMP    R4,#0
    BGT    lp1
    MOV    R1,R5
    LDR    R0,[R1,#556]    ;status
    RSBS   R0,R0,#0        ;invert and test
    STRGT  R0,[R1,#592]    ;set quit flag for WPPOLL
    MOVLT  R0,#0
    STRLT  R0,[R1,#556]    ;set status zero
    SWILT  Wimp_CloseDown
    LDMDB  fp,{R4,R5,fp,sp,pc} ;return
ptr DCD    WP_bloc
    END
;
    TTL    wprdin
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT wprdin_         ;(IWH,IH,INT,IERR) read decimal integer from icon
    IMPORT WP_GetI
;   IERR:
;     +1: icon contains non-numeric(or " +-") characters
;      0: integer is read OK
;     -1: icon/window handles don't exist
;     -2; icon does not contain indirected text
    DCB    "WPRDIN",0,0,8,0,0,255
wprdin_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_GetI
    STRNE  R0,[R3]         ;store error
    LDMNEDB fp,{fp,sp,pc}  ;return error
    MOV    R1,#0           ;accumulator for INT
lp1 LDRB   lr,[R0],#1
    CMP    lr,#" "
    BEQ    lp1             ;skip blanks
    BLT    fin             ;no number, so leave as zero
    MOV    ip,lr           ;save possible sign
    CMP    lr,#"-"
    CMPNE  lr,#"+"
    LDREQB lr,[R0],#1      ;skip sign
lp2 RSBS   lr,lr,#"9"
    RSBGES lr,lr,#9
    MOVLT  R0,#1
    BLT    bad             ;illegal character
    CMP    R1,#&CC,12
    MOVGT  R0,#2
    BGT    bad             ;about to overflow
    ADDS   R1,R1,R1,LSL#2
    ADDS   R1,lr,R1,LSL#1  ;accumulate INT
    LDRB   lr,[R0],#1
    CMP    lr,#" "
    BGT    lp2
fin CMP    ip,#"-"
    RSBEQ  R1,R1,#0        ;set negative
    STR    R1,[R2]         ;store answer
    MOV    R0,#0
bad STR    R0,[R3]         ;store IERR
    LDMDB  fp,{fp,sp,pc}   ;return OK
    END
;
    TTL    wprdtx
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT wprdtx_         ;(IWH,IH,STRING,LEN) read text from icon
    IMPORT WP_GetI
;     LEN:
;    >=0: text is read OK (LEN is 0 for null icon)
;     -1: icon/window handles don't exist
;     -2; icon does not contain indirected text
    DCB    "WPRDTX",0,0,8,0,0,255
wprdtx_
    MOV    ip,sp
    STMDB  sp!,{R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_GetI
    STRNE  R0,[R3]         ;store error
    LDMNEDB fp,{R4,fp,sp,pc} ;return error
    LDR    ip,[sp,#20]     ;length of STRING
    MOV    R4,ip
lp1 LDRB   lr,[R0],#1
    CMP    lr,#31
    STRGTB lr,[R2],#1      ;transfer text to STRING
    SUBGTS ip,ip,#1
    SUBGTS R1,R1,#1
    BGT    lp1
    SUB    R4,R4,ip        ;length of string
    STR    R4,[R3]         ;store LEN
    MOV    lr,#" "
lp2 SUBS   ip,ip,#1
    STRGEB lr,[R2],#1      ;blank fill
    BGT    lp2
    LDMDB  fp,{R4,fp,sp,pc} ;return OK
    END
;
    TTL    wpsave
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
Wimp_CreateWindow  EQU &400C1
Wimp_SpriteOp      EQU &600E9
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpsave_         ;(SFTYPE,ISIZE,SFNAM,IWHAN)
    IMPORT WP_err1
    IMPORT WP_err2
    IMPORT WP_bloc
    IMPORT WP_drck
    DCB    "WPSAVE",0,0,8,0,0,255
wpsave_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc};must save to R6 for SpriteOp #40
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    MOV    R6,#-1
    STR    R6,[R3]         ;preset IWHAN to -1
    LDR    R6,[fp,#4]      ;length of SFTYPE
    CMP    R6,#3
    BEQ    SE1
    MOV    R0,R6
    ADR    ip,em1
    BL     WP_err2
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return if not 3-digit type
SE1 MOV    R3,#0           ;file type accumulator          from     07/08/98
    MOV    R5,#"_",8
lp1 LDRB   lr,[R0],#1
    CMP    lr,#"A"
    RSBGES R1,lr,#"Z"
    ADDGE  lr,lr,#32       ;make lower case
    MOV    R1,lr,LSL#24
    ORR    R5,R1,R5,LSR#8  ;make up word: "_xxx" (xxx = hex file type)
    CMP    lr,#"a"
    SUBGE  lr,lr,#39       ;correct "a" to 10, "f" to 15 etc.
    SUB    lr,lr,#"0"      ;hex digit
    ORR    R3,lr,R3,LSL#4  ;accumulate file type
    SUBS   R6,R6,#1
    BGT    lp1             ;move in name
    LDR    R1,ptr
    CMP    R3,#0           ;check for directory (type='000')
    MOVEQ  R3,#&1000       ;directory has type &1000
    STR    R3,[R1,#240]    ;store ITYPE
    ADR    R2,ftp
    LDMEQDB R2,{R4-R6}     ;sprite name is 'directory'
    LDRNE  R4,[R2]         ;sprite name is 'file_xxx'
    ADD    R2,R1,#172
    STMIA  R2,{R4-R6}      ;store sprite name               to      07/08/98
    MOV    R0,#40          ;SpriteOp #40
    SWI    Wimp_SpriteOp
    LDRVS  R1,ptr
    ADDVS  R0,R1,#172
    ADRVS  ip,em2
    BVS    err1
    LDR    R0,sav
    LDR    R1,[R0]
    CMP    R1,#16          ;check for too many save windows
    ADRGE  ip,em3
    BGE    err1
    ADD    R1,R1,#1
    STR    R1,[R0]
    ADD    R4,R0,R1,LSL#2  ;pointer to window handle info
    LDMIB  sp,{R1,R2}      ;restore addresses of ISIZE & SFNAM
    LDR    R5,[R1]         ;ISIZE
    LDR    R1,ptr
    STR    R5,[R1,#236]    ;store ISIZE                            20/03/97
    STR    R2,[R1,#108]    ;store address of file name
    LDR    R6,[fp,#8]      ;length of SFNAM
    STR    R6,[R1,#116]    ;store
    MOV    R3,#0
lp2 LDRB   lr,[R2],#1
    CMP    lr,#32
    RSBGTS lr,lr,#127      ;check for legal & > " "
    STRLEB R3,[R2,#-1]     ;or null terminate
    SUBGTS R6,R6,#1
    BGT    lp2
    SWI    Wimp_CreateWindow
    LDR    R3,[sp,#12]     ;restore address of IWHAN
    STR    R0,[R3]         ;store IWHAN
    STR    R0,[R4]         ;and store it in window info
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
;
err1 BL    WP_err1
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return if sprite not found
sav DCD    WP_bloc+664
ptr DCD    win
vld DCB    "A~ ",0
    DCB    "directory",0,0,0
ftp DCB    "file"
em1 DCB    3,"SFTYP has wrong length ()",0
em2 DCB    3,"sprite '' not found in wimp pool",0
em3 DCB    3,">16 'save' windows requested",0
;                                new icon data follow              20/03/97
svi DCB    "Save",0        ;indirected 'save' text                 20/03/97
svr DCB    "R6,3",0        ;'save' default action box              20/03/97
cli DCB    "Cancel",0      ;indirected 'cancel text                20/03/97
clr DCB    "R5,3",0        ;'cancel' action box                    20/03/97
;
    AREA   |C$$data|,DATA
win DCD    0,0,296,240     ;visible area        (was 0,0,264,224)  20/03/97
    DCD    0,0             ;scroll offsets
    DCD    -1              ;open on top
    DCD    &84000012       ;window flags
    DCB    7,2,7,1         ;colours
    DCB    3,1,12,0        ;colours
    DCD    0,-240,296,0    ;work area           (was 0,-224,264,0)  20/03/97
    DCD    &03D            ;title flags
    DCD    0               ;window button type
    DCD    1               ;sprite area control block
    DCD    0               ;mimium size of window
    DCB    "Save as",0,0,0,0,0;title data (colon removed)           20/03/97
    DCD    5               ;#icons
;       icon 0 is the file name (88)
    DCD    40,-156,240,-108;size of icon     ( was 32,-156,232,-108)20/03/97
    DCD    &0700F12D       ;icon flags (indirected text)
    DCD    0               ;address of file name (108)
    DCD    vld             ;pointer to validation string
    DCD    0               ;length (116)
;       icon 1 is 'Save' box (120)
    DCD    152,-232,280,-168;size of icon    (was 140,-216,256,-168)20/03/97
    DCD    &1701913D       ;icon flags (was &C701903D)              20/03/97
    DCD    svi             ;(140)      (was "Save",0,0)             20/03/97
    DCD    svr             ;"default action" validation (144)
    DCD    4               ;buffer length (148)
;       icon 2 is file sprite (152)
    DCD    116,-92,184,-24 ;size of icon (was 100,-92,168,-24)      20/03/97
    DCD    &6002           ;icon flags (ordinary sprite)
    DCB    "file_xxx",0,0,0,0;name (172)
;       icon 3 is 'Cancel' (184)
    DCD    12,-228,136,-172 ;size of icon (was 8,-216,124,-168)     20/03/97
    DCD    &1701913D       ;icon flags (was &C701903D)              20/03/97
    DCD    cli             ;(204) (was "Cancel")                    20/03/97
    DCD    clr             ;"action button" validation (208)
    DCD    6               ;buffer length (212)
;        icon 4 is dummy (216)  (new)                               20/03/97
    DCD    0,0,0,0,0       ;(216,220,224,228,232)
    DCD    0,0,0           ;(xxx isize in 236 xxx) (itype in 240)
    END
;
    TTL    wpsetc
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
Wimp_SetColour EQU &400E6
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpsetc_         ;(IACT,KOLOUR) organise closing the wimp
    IMPORT WP_err2
    DCB    "WPSETC",0,0,8,0,0,255
wpsetc_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]         ;IACT
    ADDS   R2,R0,#0        ;check for range [0:7]
    RSBGES ip,R2,#7
    ADRLT  ip,em1
    BLT    err2
    LDR    R0,[R1]         ;KOLOUR
    BIC    ip,R0,#&80      ;remove background bit
    CMP    ip,#0           ;check for range [0:15]
    RSBGES ip,ip,#15
    ADRLT  ip,em2
    BLT    err2
    ORR    R0,R0,R2,LSL#4  ;insert action
    SWI    Wimp_SetColour
    LDMDB  fp,{fp,sp,pc}   ;return
err2 BL    WP_err2
    LDMDB  fp,{fp,sp,pc}  ;return if IACT out of range
em1 DCB    3,"IACT () out of range",0
em2 DCB    3,"KOLOUR () out of range",0
    END
;
    TTL    wpsetp
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
Wimp_SetPalette EQU &400E4
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpsetp_         ;(IPAL) set palette
    DCB    "WPSETP",0,0,8,0,0,255
wpsetp_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    ADD    R1,R0,#40
    MOV    ip,#0
lp1 STRB   ip,[R1,#-4]!    ;set l.s. byte zero
    CMP    R1,R0
    BGT    lp1
    SWI    Wimp_SetPalette
    LDMDB  fp,{fp,sp,pc}   ;return
    END
;
    TTL    wpshwm
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
Wimp_CreateMenu EQU &400D4
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpshwm_         ;(IMBLK,IX,IY)
    IMPORT WP_bloc
    IMPORT WP_drck
    DCB    "WPSHWM",0,0,8,0,0,255
wpshwm_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    ip,[R0]
    CMP    ip,#-1
    LDRNE  R3,[R2]         ;IY
    LDRNE  R2,[R1]         ;IX
    MOVNE  R1,R0           ;IMBLK
    MOVEQ  R1,ip
    LDR    lr,ptr
    STMIA  lr,{R1-R3}      ;store address,x,y of menu top level
    SWI    Wimp_CreateMenu
    STR    R0,[lr,#1000-596];store top level menu window handle
    STR    R1,[lr,#1004-596];store top level menu window handle
    LDMDB  fp,{fp,sp,pc}   ;return
ptr DCD    WP_bloc+596
    END
;
    TTL    wpstcp
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN      0
R1  RN      1
R2  RN      2
R3  RN      3
R4  RN      4
R5  RN      5
Wimp_SetCaretPosition  EQU &600D2
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpstcp_         ;(IWH,IH,IPOS) set caret position
    IMPORT WP_err3
    IMPORT WP_drck
    DCB    "WPSTCP",0,0,8,0,0,255
wpstcp_
    MOV    ip,sp
    STMDB  sp!,{R4,R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R0,[R0]         ;window handle
    CMP    R0,#-1
    LDRNE  R1,[R1]         ;icon handle
    MOVNE  R4,#-1
    LDRNE  R5,[R2]         ;IPOS
    SWI    Wimp_SetCaretPosition
    BLVS   WP_err3         ;report error
    LDMDB  fp,{R4,R5,fp,sp,pc} ;return
    END
;
    TTL    wpstic
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
Wimp_GetIconState EQU &600CE
Wimp_SetIconState EQU &600CD
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpstic_         ;(IWH,ICH,KOL) set icon colour WPSETC
    IMPORT WP_bloc
    IMPORT WP_err3
    IMPORT WP_err2
    IMPORT WP_drck
    DCB    "WPSTIC",0,0,8,0,0,255
wpstic_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R3,[R2]         ;KOL
    BICS   lr,R3,#&8F      ;check for legal colour (0-15 with possible 128)
    ADRNE  ip,em1
    MOVNE  R0,R3
    BNE    err2
    LDR    R0,[R0]         ;IWH
    LDR    R2,[R1]         ;ICH
    LDR    R1,ptr
    STMIA  R1,{R0,R2}
    SWI    Wimp_GetIconState
    BVC    SC1
    BL     WP_err3
    LDMDB  fp,{fp,sp,pc}  ;return
SC1 LDR    ip,[R1,#24]     ;icon flags
    TST    ip,#&40         ;test if font, not colours
    ADRNE  ip,em2
    BLNE   WP_err2
    TST    R3,#128
    MOV    R3,R3,LSL#28
    MOVEQ  R3,R3,LSR#4     ;colour in right position
    MOVNE  ip,#15,4        ;mask
    MOVEQ  ip,#15,8
    STMIB  R1,{R2,R3,ip}
    SWI    Wimp_SetIconState
    BLVS   WP_err3
    LDMDB  fp,{fp,sp,pc}   ;return
err2 BL    WP_err2
    LDMDB fp,{fp,sp,pc}   ;return
ptr DCD    WP_bloc+300
em1 DCB    3,"Colour () illegal",0
em2 DCB    3,"Can not change colours for font text",0
    END
;
    TTL    wpstif
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
Wimp_SetIconState EQU &600CD
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpstif_         ;(IWH,ICH,IND,SET) set icon flag
    IMPORT WP_bloc
    IMPORT WP_err3
    IMPORT WP_err2
    IMPORT WP_drck
    DCB    "WPSTIF",0,0,8,0,0,255
wpstif_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R2,[R2]         ;INDex
    CMP    R2,#23          ;check it is not too big
    BHI    st1             ;not flag
    MOV    ip,#1
    MOV    ip,ip,LSL R2    ;bit
    LDR    R3,[R3]         ;SET
    CMP    R3,#1           ;set C flag if .TRUE.
    LDR    R3,msk
    ANDS   R3,R3,ip        ;test against mask
    MOVCS  R3,ip           ;'set' mask if set .TRUE.
    BEQ    ok
bad MOV    R0,R2           ;failed
    ADR    ip,em1
    BL     WP_err2
    LDMDB  fp,{fp,sp,pc}   ;return
st1 SUBS   R3,R2,#100
    BLT    bad
    CMP    R3,#15
    BGT    st2             ;not button type
    MOV    ip,R3,LSL#12
    MOV    R3,#&F000       ;'set' mask for button type
    B      ok
st2 SUBS   R3,R2,#200
    RSBGES ip,R3,#31
    BLT    bad             ;not anything
    MOV    ip,R3,LSL#16
    MOV    R3,#&1F0000     ;'set' mask for ESG
ok  LDR    R2,[R1]         ;Icon handle
    LDR    R0,[R0]         ;Window handle
    LDR    R1,ptr          ;temp space
    STMIA  R1,{R0,R2,R3,ip}
    SWI    Wimp_SetIconState
    BLVS   WP_err3
    LDMDB  fp,{fp,sp,pc}   ;return
ptr DCD    WP_bloc+300
msk DCD    &1FF1C3         ;bits not allowed
em1 DCB    3,"INDEX () illegal",0
    END
;
    TTL    wpstis
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
Wimp_ResizeIcon EQU &600FC
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpstis_         ;(IWHAN,ICONH,IWX,IWY,ISX,ISY)
    DCB    "WPSTIS",0,0,8,0,0,255
wpstis_
    MOV    ip,sp
    STMDB  sp!,{R4-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]         ;IWHAN
    LDR    R1,[R1]         ;ICONH
    LDR    R2,[R2]         ;IWX
    LDR    R3,[R3]         ;IWY
    LDMIA  ip,{R4,R5}      ;addresses of ISX,ISY
    LDR    R4,[R4]         ;ISX
    LDR    R5,[R5]         ;ISY
    ADD    R4,R4,R2        ;X end
    ADD    R5,R5,R3        ;Y end
    SWI    Wimp_ResizeIcon
    LDMDB  fp,{R4-R5,fp,sp,pc} ;return
    END
;
    TTL    wpstmd
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
Wimp_SetMode  EQU &600E3
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpstmd_         ;(MODE) set mode
    IMPORT WP_err3
    IMPORT WP_drck
    DCB    "WPSTMD",0,0,8,0,0,255
wpstmd_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R0,[R0]         ;mode
    SWI    Wimp_SetMode
    BLVS   WP_err3         ;report error
    LDMDB  fp,{fp,sp,pc}   ;return
    END
;
    TTL    wpstmf
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpstmf_         ;(NFLAG,IMBLOC,INDEX,SET) store menu flag
    IMPORT WP_err2
    IMPORT WP_menu
    DCB    "WPSTMF",0,0,8,0,0,255
wpstmf_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_menu         ;find menu item
    LDMNEDB fp,{fp,sp,pc}  ;return on bad index
    LDR    R0,[R0]         ;NFLAG
    CMP    R0,#0
    RSBGES ip,R0,#3
    BGE    SF1
    ADR    ip,em2
    BL     WP_err2
    LDMDB  fp,{fp,sp,pc}  ;return on bad NFLAG
SF1 LDR    R3,[R3]         ;SET
    MOV    ip,#1           ;mask
    CMP    R0,#2
    MOVNE  ip,ip,LSL R0
    MOVEQ  ip,#&400000
    LDRNEB R2,[R1]         ;menu flags
    LDREQ  R2,[R1,#8]      ;icon flags
    CMP    R3,#0
    ORRNE  R2,R2,ip        ;set flag
    BICEQ  R2,R2,ip        ;or clear flag
    CMP    R0,#2
    STRNEB R2,[R1]         ;menu flags
    STREQ  R2,[R1,#8]      ;icon flags
    LDMDB  fp,{fp,sp,pc}   ;return
em2 DCB    3,"NFLAG () out of range",0,0,0
    END
;
    TTL    wpstns
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
Wimp_SlotSize  EQU &600EC
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpstns_         ;(NNS) set next slot size
    IMPORT WP_err3
    DCB    "WPSTNS",0,0,8,0,0,255
wpstns_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R0]         ;NNS
    MOV    R0,#-1          ;no new current size
    SWI    Wimp_SlotSize
    BLVS   WP_err3
    LDMDB  fp,{fp,sp,pc}   ;return
    END
;
    TTL    wpsttc
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
Wimp_TextColour  EQU &400F0
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpsttc_         ;(IC) set text colour
    IMPORT WP_err2
    DCB    "WPSTTC",0,0,8,0,0,255
wpsttc_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]         ;IC
    AND    R1,R0,#&8F      ;mask off useful bits
    TEQ    R0,R1           ;check there are no others
    BEQ    SC1
    ADR    ip,em
    BL     WP_err2         ;illegal colour
    LDMDB  fp,{fp,sp,pc}   ;return
SC1 SWI    Wimp_TextColour
    LDMDB  fp,{fp,sp,pc}   ;return
em  DCB    3,"illegal colour ()",0
    END
;
    TTL    wpstwa
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
Wimp_SetExtent  EQU &600D7
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpstwa_         ;(IWH,IX,IY) change work area size
    IMPORT WP_err3
    IMPORT WP_bloc
    IMPORT WP_drck
    DCB    "WPSTWA",0,0,8,0,0,255
wpstwa_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R0,[R0]         ;IWH
    LDR    R3,[R2]         ;IY
    LDR    ip,[R1]         ;IX
    LDR    R1,ptr          ;work space
    RSB    R3,R3,#0        ;minimum y (=-IY)
    MOV    R2,#0           ;minimum x
    STMIA  R1,{R2,R3,ip}   ;store minx, miny, maxx
    STR    R2,[R1,#12]     ;store maxy (=0)
    SWI    Wimp_SetExtent
    BLVS   WP_err3         ;report error
    LDMDB  fp,{fp,sp,pc}   ;return
ptr DCD    WP_bloc+300
    END
;
    TTL    wpstws
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
R9  RN     9
Wimp_GetWindowOutline EQU &600E0
Wimp_GetWindowState   EQU &600CB
Wimp_OpenWindow       EQU &600C5
Wimp_SetCaretPosition EQU &600D2
Wimp_GetCaretPosition EQU &600D3
tmp EQU 300
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpopnw_         ;(IWH) open window IWH
    IMPORT WP_savw
    IMPORT WP_GetI
    IMPORT WP_bloc
    IMPORT WP_err3
    IMPORT WP_drck
    DCB    "WPOPNW",0,0,8,0,0,255
wpopnw_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R0,[R0]         ;get window handle
    LDR    R1,ptr
    STR    R0,[R1]         ;store
    SWI    Wimp_GetWindowState
    STMVCDB sp!,{R1,R4-R9}
    BVC    st1
    BL     WP_err3
    LDMDB  fp,{fp,sp,pc}  ;return on error
;
    EXPORT wpstws_         ;(IBLK) open window with block IBLK
    DCB    "WPSTWS",0,0,8,0,0,255
wpstws_
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    MOV    R1,R0           ;address of block
;
;      check for pane
;    DCB    0               ;# panes (732)
;    %      7               ;sides for panes (bit 7 set if active) (733)
;    %      2*4*7           ;pane handle, host handle (740)
;
st1 LDR    R4,[R1]         ;window handle
    LDR    R9,[R1,#28]     ;handle of window in front
    LDR    R2,ptr
    LDRB   ip,[R2,#732-tmp]!;#panes
    CMP    ip,#1
    BLT    main            ;no panes at all, so skip all this pane stuff
    ADD    R3,R2,#4        ;pointer to hosts
lp1 LDR    R0,[R2,ip,LSL#3];get pane handle
    CMP    R4,R0
    SUBNES ip,ip,#1
    BNE    lp1
    CMP    R4,R0
    BEQ    SS1
    SWI    Wimp_OpenWindow ;open main window                    04/05/00
    LDRB   ip,[R2]         ;#panes
    B      pt1             ;not a pane
SS1 LDRB   lr,[R2,ip]      ;  get pane flags
    TST    lr,#128
    LDMNEDB fp,{R4-R9,fp,sp,pc} ;return if active pane
    ORR    lr,lr,#128
    STRB   lr,[R2,ip]      ;else make it active
    LDR    R4,[R3,ip,LSL#3];host handle
pt1 LDR    R5,[R1]         ;original window handle
    SUB    R1,R2,#732-tmp-36;temporary space
    STR    R4,[R1]
    SWI    Wimp_GetWindowState
    LDR    lr,[R1,#32]     ;window flags
    CMP    R4,R5           ;check we are dealing with the original window
    MVNNE  R5,lr
    TSTNE  R5,#&10000      ;or window is open
    LDMNEDB fp,{R4-R9,fp,sp,pc} ;return if not
    LDMIB  R1,{R5-R8}      ;get dimensions
;    TST    lr,#&04,8                          13/04/00
;    ADDNE  R8,R8,#40       ;allow for title bar
    TST    lr,#&40,8
    SUBNE  R6,R6,#40       ;allow for horizontal scroll bar
    TST    lr,#&10,8
    ADDNE  R7,R7,#40       ;allow for vertical scroll bar
    STMFD  sp!,{R5-R8}     ;store on stack
lp2 LDR    lr,[R3,ip,LSL#3];get handle of host of pane
    CMP    lr,R4
    BNE    pt3             ;not pane belonging to host
    LDRB   lr,[R2,ip]
    TST    lr,#128
    BEQ    pt3             ;not active
    LDR    R0,[R2,ip,LSL#3];pane handle
    STR    R0,[R1]
    SWI    Wimp_GetWindowState;find state of pane
    LDMIB  R1,{R5-R8}      ;get dimensions of pane
    SUB    R7,R7,R5        ;x-size
    SUB    R8,R8,R6        ;y-size
    LDR    R5,[sp]         ;host left x
    LDR    R6,[sp,#12]     ;host top y
    CMP    lr,#129         ;check for left side
    SUBEQ  R5,R5,R7        ;x = x(host:left) - dx
    SUBEQ  R6,R6,R8        ;y = y(host:top) - dy
    SUBEQ  R5,R5,#2        ;allow for line thickness
    CMP    lr,#130         ;check for bottom
    LDREQ  R6,[sp,#4]      ;host bottom y
    SUBEQ  R6,R6,R8        ;y = y(host:bottom) - dy
    SUBEQ  R6,R6,#2
    CMP    lr,#131         ;check for right
    LDREQ  R5,[sp,#8]      ;x = x(host:right)
    ADDEQ  R5,R5,#2
    SUBEQ  R6,R6,R8        ;y = y(host:top) - dy
    CMP    lr,#132         ;check for top
    ADDEQ  R6,R6,#2
    ADD    R7,R5,R7
    ADD    R8,R6,R8
    STMIB  R1,{R5-R8}      ;set position for pane
    STR    R9,[R1,#28]     ;window to open pane behind
    LDR    R9,[R1]
    SWI    Wimp_OpenWindow ; open pane
pt3 SUBS   ip,ip,#1
    BGT    lp2             ;go try next pane
main;      open main window
    LDR    R1,[fp,#-40]
    LDR    R0,[R1]
    CMP    R0,R4
    LDMNEDB fp,{R4-R9,fp,sp,pc} ;return if not original window
    STR    R9,[R1,#28]     ;window to open pane behind
    SWI    Wimp_OpenWindow ; open main window
;  normal window opened, now check if it is a 'save' window
    MOV    R0,R4           ;restore window handle
    BL     WP_savw         ;check if SAVE window
    LDMLTDB fp,{R4-R9,fp,sp,pc} ;return if not
    MOV    R1,#0           ;icon handle of text
    STMFD  sp!,{R0,R1}     ;store window and icon handles on stack
    MOV    R0,sp           ;pointer to window handle
    ADD    R1,R0,#4        ;pointer to icon handle
    BL     WP_GetI         ;find text
    LDMNEDB fp,{R4-R9,fp,sp,pc} ;return if no good
    MOV    R5,#0
ck1 LDRB   lr,[R0,R5]
    CMP    lr,#31
    SUBGTS R1,R1,#1
    ADDGT  R5,R5,#1
    BGT    ck1
    LDR    R1,ptr          ;                                   14/01/98
    ADD    R1,R1,#976-tmp  ;pointer to caret save block
    SWI    Wimp_GetCaretPosition;                              14/01/98
    LDMFD  sp!,{R0,R1}     ;restore window and icon handles
    MOV    R4,#-1          ;calculate caret position from R5
    SWI    Wimp_SetCaretPosition
    BLVS   WP_err3
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
ptr DCD    WP_bloc+tmp
    END
;
    TTL    wptask
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
Wimp_StartTask EQU &600DE
    AREA   |C$$code|,CODE,READONLY
    EXPORT wptask_         ;(STASK) start task
    IMPORT WP_bloc
    IMPORT WP_err3
    IMPORT WP_drck
    DCB    "WPTASK",0,0,8,0,0,255
wptask_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    R2,ptr          ;work space
    CMP    R1,#255
    MOVGT  R1,#255         ;limit line to 240 characters
    MOV    ip,#0
    STRB   ip,[R2,R1]      ;null terminate
lp1 SUBS   R1,R1,#1
    LDRGEB ip,[R0,R1]      ;copy task string
    STRGEB ip,[R2,R1]
    BGT    lp1
    MOV    R0,R2           ;address of task
    SWI    Wimp_StartTask
    BLVS   WP_err3
    LDMDB  fp,{fp,sp,pc}   ;return
ptr DCD    WP_bloc+300
    END
;
    TTL    wptext
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
OS_WriteN EQU &46
OS_Plot   EQU &45
    AREA   |C$$code|,CODE,READONLY
    EXPORT wptext_         ;(IX,IY,STRING)
    DCB    "WPTEXT",0,0,8,0,0,255
wptext_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,R2           ;save address of string
    LDR    R2,[R1]         ;IY
    LDR    R1,[R0]         ;IX
    MOV    R0,#4           ;MOVE command
    SWI    OS_Plot
    MOV    R0,ip           ;address of STRING
    MOV    R1,R3           ;length
    SWI    OS_WriteN       ;print it
    LDMDB  fp,{fp,sp,pc}   ;return
    END
;
    TTL    wptime
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
F0  FN     0
F1  FN     1
F2  FN     2
OS_ReadMonotonicTime EQU &42
    AREA   |C$$code|,CODE,READONLY
    EXPORT wptime_         ;(REALT,CPUT)
    IMPORT WP_bloc
    DCB    "WPTIME",0,0,8,0,0,255
wptime_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,R0
    SWI    OS_ReadMonotonicTime
    LDR    R2,ptr
    LDR    R3,[R2]
    SUB    R3,R0,R3        ;real time in centisec
    LDFS   F0,=0.01
    FLTS   F1,R3
    FMLS   F2,F1,F0
    STFS   F2,[ip]         ;store real time
    LDR    R3,[R2,#4]
    SUB    R3,R0,R3        ;cpu time in centisec
    FLTS   F1,R3
    FMLS   F2,F1,F0
    STFS   F2,[R1]         ;store cpu time
    LDMDB  fp,{fp,sp,pc}   ;return
ptr DCD    WP_bloc+616
    END
;
    TTL    wptxtc
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
Wimp_TextOp         EQU &600F9
ColourTrans_SetGCOL EQU &60743
    AREA   |C$$code|,CODE,READONLY
    EXPORT wptxtc_         ;(IRF,IGF,IBF,IRB,IGB,IBB)
    DCB    "WPTXTB",0,0,8,0,0,255
wptxtc_
    MOV    ip,sp
    STMDB  sp!,{R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDRB   R0,[R0]         ;IRF
    LDRB   R1,[R1]         ;IGF
    LDRB   R2,[R2]         ;IBF
    MOV    R1,R1,LSL#16
    ORR    R1,R1,R0,LSL#8
    ORR    R1,R1,R2,LSL#24 ;build foreground colour
    LDMIA  ip,{R0,R2}      ;addresses of IGB & IBB
    LDRB   R3,[R3]         ;IRB
    LDRB   R0,[R0]         ;IGB
    LDRB   R2,[R2]         ;IBB
    MOV    R2,R2,LSL#24
    ORR    R2,R2,R0,LSL#16
    ORR    R2,R2,R3,LSL#8  ;build background colour
    MOV    R0,#0
    SWI    Wimp_TextOp     ;set text colour
    MOVVS  R0,R1           ;if fails, do colour trans instead
    MOVVS  R4,#0
    MOVVS  R3,#0
    SWIVS  ColourTrans_SetGCOL
    LDMDB  fp,{R4,fp,sp,pc} ;return
    END
;
    TTL    wptxtf
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
OS_WriteN   EQU &46
OS_Plot     EQU &45
Wimp_TextOp EQU &600F9
Wimp_GetWindowState EQU &600CB
Wimp_ReadSysinfo    EQU &600F2
    AREA   |C$$code|,CODE,READONLY
    EXPORT wptxtf_         ;(IX,IY,IWH,STRING)
    IMPORT WP_err3
    DCB    "WPTXTF",0,0,8,0,0,255
wptxtf_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R0,#8           ;check to see if system font
    SWI    Wimp_ReadSysinfo
    BVS    pt1
    CMP    R0,#0
    BEQ    pt1
    LDMIA  sp,{R0,R1}      ;restore addresses of IX & IY
    LDR    R4,[R0]         ;IX
    LDR    R5,[R1]         ;IY
    SUB    R5,R5,#24       ;subtract 24 to give the bottom left
    SUB    sp,sp,#256
    MOV    R1,sp           ;temporary store for text
    LDR    R2,[R2]         ;window handle
    STR    R2,[R1]
    SWI    Wimp_GetWindowState
    BVC    TF1
    BL     WP_err3
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return on illegal window handle
TF1 LDMIB  R1,{R0,R2,R6-R8,lr};get useful numbers
    ADD    R4,R4,R0        ;transform x
    SUB    R4,R4,R8
    ADD    R5,R5,R7        ;transform y
    SUB    R5,R5,lr
    MOV    R0,#&40000002   ;op code 2 with vertical justification
    LDR    R2,[ip]         ;get length of string
    CMP    R2,#255
    MOVGT  R2,#255
    MOV    lr,#0
lp1 STRB   lr,[R1,R2]      ;store null terminated string
    SUBS   R2,R2,#1
    LDRGEB lr,[R3,R2]
    BGE    lp1
    MOV    R2,#-1
    MOV    R3,#-1
    SWI    Wimp_TextOp     ;try to write string
    LDMVCDB fp,{R4-R8,fp,sp,pc} ;return if OK
;       otherwise do WPTEXT
pt1 SUB    sp,fp,#48       ;restore sp
    LDMIA  sp,{R0,R1}      ;restore addresses of IX & IY
    LDR    R2,[R1]         ;IY
    LDR    R1,[R0]         ;IX
    MOV    R0,#4           ;MOVE command
    SWI    OS_Plot
    LDR    R0,[sp,#12]     ;address of STRING
    LDR    R1,[ip]         ;length
    SWI    OS_WriteN       ;print it
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    wptxtw
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
Wimp_TextOp EQU &600F9
    AREA   |C$$code|,CODE,READONLY
    EXPORT wptxtw_         ;(STRING,IW)
;           returns text width in OS units for desktop font
    DCB    "WPTXTW",0,0,8,0,0,255
wptxtw_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUB    sp,sp,#256
    MOV    R1,sp           ;temporary store for text
    CMP    R2,#255
    MOVGT  R2,#255
    MOV    lr,#0
lp1 STRB   lr,[R1,R2]      ;store null terminated string
    SUBS   R2,R2,#1
    LDRGEB lr,[R0,R2]
    BGE    lp1
    MOV    R0,#1           ;to get text width
    SWI    Wimp_TextOp     ;try to get string length
    LDR    R1,[fp,#-20]    ;restore pointer to IW
;       if it fails just multiply length by standard character width of 16
    LDRVS  R2,[fp,#-16]
    MOVVS  R0,R2,LSL#4
    STR    R0,[R1]         ;store width
    LDMDB  fp,{fp,sp,pc}   ;return
    END
;
    TTL    wpupdt
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R9  RN     9
temp              EQU  300 ; this must be the same as in WP_drck
OS_WriteC         EQU  &00
OS_WriteI         EQU  &100
OS_SpriteOp       EQU  &2002E
Wimp_GetRectangle EQU  &400CA
Wimp_UpdateWindow EQU  &400C9
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpupdt_         ;(IWH,IXL,IYL,IXH,IYH) redraw area
    IMPORT wqupdt_
    IMPORT WP_orig
    IMPORT WP_sprite
    IMPORT WP_bloc
    IMPORT WP_drck
    DCB    "WPUPDT",0,0,8,0,0,255
wpupdt_
    MOV    ip,sp
    STMDB  sp!,{R4-R7,R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    ip,[ip]         ;pointer to IYH
    LDR    R4,[R0]         ;window handle
    LDR    R5,[R1]         ;IXL
    CMP    R5,#0           ;check if IXL<0
    MOVLT  R5,#0           ;set to defaults
    MOVLT  R6,#&FF000000
    MOVLT  R7,#&00FF0000
    MOVLT  R9,#0
    LDRGE  R6,[R2]         ;IYL
    LDRGE  R7,[R3]         ;IXH
    LDRGE  R9,[ip]         ;IYH
    LDR    R1,ptr
    STMIA  R1,{R4-R7,R9}    ;block contents
    LDR    R9,[R1,#804-temp];pointer to 'current' sprite window
    MOV    R0,#-1
    STR    R0,[R1,#796-temp];set updating flag
    SWI    Wimp_UpdateWindow
rd2 CMP    R0,#0           ;any more?
    STREQ  R0,[R1,#796-temp];reset updating flag
    LDMEQDB fp,{R4-R7,R9,fp,sp,pc} ;none, so return
    LDMIB  R1!,{R2-R7}     ;load useful coordinates
    SUB    R2,R2,R6        ;x-transform
    SUB    R3,R5,R7        ;y-transform
    CMP    R9,#0
    BLNE   WP_sprite       ;sprite window update
    BL     WP_orig         ;move origin to R2,R3
    LDMIB  R1,{R4-R7}      ;get graphics window
    SUB    R4,R4,R2        ;correct for moved origin
    SUB    R5,R5,R3
    SUB    R6,R6,R2
    SUB    R7,R7,R3
    STMIA  R1,{R4-R7}      ;store transformed graphics window
    ADD    R2,R1,#4        ;pointer to IY1
    ADD    R3,R1,#8        ;pointer to IX2
    ADD    R4,R1,#12       ;pointer to IY2
    LDR    R0,ptr          ;address of window handle
    STR    R4,[sp,#-4]!    ;store 5th arg on stack
    BL     wqupdt_         ;update window
    ADD    sp,sp,#4        ;restore stack
    LDR    R1,ptr          ;restore R1
    MOV    R2,#0
    MOV    R3,#0
    BL     WP_orig         ;restore origin
    SWI    Wimp_GetRectangle;get next rectangle to draw
    B      rd2
ptr DCD    WP_bloc+temp
    END
;
    TTL    wpvrsn
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpvrsn_         ;(IVRSN) get wimp version #
    IMPORT WP_bloc
    DCB    "WPVRSN",0,0,8,0,0,255
wpvrsn_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,ptr
    LDR    R1,[R1,#648]    ;version number
    STR    R1,[R0]         ;store in IVRSN
    LDMDB  fp,{fp,sp,pc}   ;return
ptr DCD    WP_bloc
    END
;
    TTL    wpwrin
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
OS_BinaryToDecimal  EQU &20028
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpwrin_         ;(IWH,IH,INT,IERR) write decimal integer to icon
    IMPORT WP_GetI
    IMPORT WP_SetI
;   IERR:
;     +1: integer too big for icon
;      0: integer is written OK
;     -1: icon/window handles don't exist
;     -2; icon does not contain indirected text
    DCB    "WPWRIN",0,0,8,0,0,255
wpwrin_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_GetI
    STRNE  R0,[R3]         ;store error
    LDMNEDB fp,{R4,R5,fp,sp,pc} ;return error
    LDR    ip,[R2]         ;INT
    SUB    R2,R1,#1        ;length of buffer (without null)
    MOV    R1,R0           ;address of buffer
    MOV    R0,ip           ;INT
    SWI    OS_BinaryToDecimal
    MOVVC  R0,#0
    STRVCB R0,[R1,R2]      ;store terminating null
    MOVVS  R0,#1
    STR    R0,[R3]         ;store IERR
    BVC    WP_SetI         ;go plot icon
    LDMDB  fp,{R4,R5,fp,sp,pc} ;or return on error
    END
;
    TTL    wpwrtx
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpwrtx_         ;(IWH,IH,STRING,LEN) write text to icon
    IMPORT WP_GetI
    IMPORT WP_SetI
;     LEN:
;    >=0: text is written OK (LEN actually sent)
;     -1: icon/window handles don't exist
;     -2; icon does not contain indirected text
    DCB    "WPWRTX",0,0,8,0,0,255
wpwrtx_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_GetI
    STRNE  R0,[R3]         ;store error
    LDMNEDB fp,{R4,R5,fp,sp,pc} ;return error
    LDR    ip,[fp,#4]      ;length of STRING
    SUB    R2,R2,#1
lp1 LDRB   lr,[R2,ip]
    RSBS   lr,lr,#33
    SUBGTS ip,ip,#1
    BGT    lp1             ;find last non-blank
    CMP    ip,R1
    SUBGE  ip,R1,#1        ;actual length to transfer (excluding null)
    STR    ip,[R3]         ;store length
    MOV    lr,#0
    CMP    ip,#0
lp2 STRB   lr,[R0,ip]      ;transfer string to icon
    LDRGTB lr,[R2,ip]
    SUBS   ip,ip,#1
    BGE    lp2
    B      WP_SetI         ;go draw icon
    END
;
    TTL    wpxy2s
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
Wimp_GetWindowState  EQU &600CB
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpxy2s_         ;(IWH,IX,IY,JX,JY) transform window to screen
    IMPORT WP_bloc
    IMPORT WP_err3
    IMPORT WP_drck
    DCB    "WPXY2S",0,0,8,0,0,255
wpxy2s_
    MOV    ip,sp
    STMDB  sp!,{R4-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    ip,[ip]         ;address of JY
    LDR    R4,[R1]         ;IX
    LDR    R2,[R2]         ;IY
    LDR    R0,[R0]         ;window handle
    LDR    R1,ptr          ;temporary space
    STR    R0,[R1]         ;store in IBLK(1)
    SWI    Wimp_GetWindowState
    LDMVCIB R1,{R0,R1,R5-R8};get useful numbers
    ADDVC  R4,R4,R0        ;transform x
    SUBVC  R4,R4,R7
    STRVC  R4,[R3]         ;store JX
    ADDVC  R2,R2,R6        ;transform y
    SUBVC  R2,R2,R8
    STRVC  R2,[ip]         ;store JY
    BLVS   WP_err3
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
ptr DCD    WP_bloc+300
    END
;
    TTL    wpxy2w
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
Wimp_GetWindowState  EQU &600CB
    AREA   |C$$code|,CODE,READONLY
    EXPORT wpxy2w_         ;(IWH,IX,IY,JX,JY) transform screen to window
    IMPORT WP_bloc
    IMPORT WP_err3
    IMPORT WP_drck
    DCB    "WPXY2W",0,0,8,0,0,255
wpxy2w_
    MOV    ip,sp
    STMDB  sp!,{R4-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     WP_drck         ;check we are not drawing
    LDR    ip,[ip]         ;address of JY
    LDR    R4,[R1]         ;IX
    LDR    R2,[R2]         ;IY
    LDR    R0,[R0]         ;window handle
    LDR    R1,ptr          ;temporary space
    STR    R0,[R1]         ;store in IBLK(1)
    SWI    Wimp_GetWindowState
    LDMVCIB R1,{R0,R1,R5-R8};get useful numbers
    SUBVC  R4,R4,R0        ;transform x
    ADDVC  R4,R4,R7
    STRVC  R4,[R3]         ;store JX
    SUBVC  R2,R2,R6        ;transform y
    ADDVC  R2,R2,R8
    STRVC  R2,[ip]         ;store JY
    BLVS   WP_err3
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
ptr DCD    WP_bloc+300
    END
;
;               D E F A U L T  W Q x x x x  R O U T I N E S
;
    TTL    wqclik
pc  RN     15
lr  RN     14
    AREA   |C$$code|,CODE,READONLY
    EXPORT wqclik_         ;dummy WQCLIK does nothing
wqclik_ MOV  pc,lr
    END
;
    TTL    wqclsw
pc  RN     15
lr  RN     14
    AREA   |C$$code|,CODE,READONLY
    EXPORT wqclsw_         ;dummy WQCLSW calls WPCLSW
    IMPORT wpclsw_
wqclsw_ B     wpclsw_
    END
;
    TTL    wqdrag
pc  RN     15
lr  RN     14
    AREA   |C$$code|,CODE,READONLY
    EXPORT wqdrag_         ;dummy WQDRAG does nothing
wqdrag_ MOV  pc,lr
    END
;
    TTL    wqplot
pc  RN     15
lr  RN     14
    AREA   |C$$code|,CODE,READONLY
    EXPORT wqplot_         ;dummy WQPLOT does nothing
wqplot_ MOV  pc,lr
    END
;
    TTL    wqhelp
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
R0  RN     0
R2  RN     2
R3  RN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT wqhelp_         ;(IWH,ICH,IX,IY,SHELP) default routine
wqhelp_
    LDR    R0,[sp]         ;address of SHELP
    MOV    R2,#?msg        ;length of message
    ADR    R3,msg          ;address of message
lh1 LDRB   ip,[R3],#1
    STRB   ip,[R0],#1      ;move message
    SUBS   R2,R2,#1
    BGT    lh1
    MOV    pc,lr
msg DCB    "Sorry, no help available"
    END
;
    TTL    wqkeyp
sp  RN     13
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT wqkeyp_         ;default WQKEYP calls WPKEYP
    IMPORT wpkeyp_
wqkeyp_
    LDR    R0,[sp,#4]      ;pointer to KEY
    B      wpkeyp_
    END
;
    TTL    wqlgct
pc  RN     15
lr  RN     14
    AREA   |C$$code|,CODE,READONLY
    EXPORT wqlgct_         ;dummy WQLGCT does nothing
wqlgct_ MOV  pc,lr
    END
;
    TTL    wqmenu
pc  RN     15
lr  RN     14
    AREA   |C$$code|,CODE,READONLY
    EXPORT wqmenu_         ;dummy WQMENU does nothing
wqmenu_ MOV  pc,lr
    END
;
    TTL    wqmesg
pc  RN     15
lr  RN     14
    AREA   |C$$code|,CODE,READONLY
    EXPORT wqmesg_         ;default WQMESG does nothing
wqmesg_ MOV  pc,lr
    END
;
    TTL    wqmodc
pc  RN     15
lr  RN     14
    AREA   |C$$code|,CODE,READONLY
    EXPORT wqmodc_         ;dummy WQMODC does nothing
wqmodc_ MOV  pc,lr
    END
;
    TTL    wpmodf
pc  RN     15
lr  RN     14
    AREA   |C$$code|,CODE,READONLY
    EXPORT wqmodf_         ;(JFONT) dummy
wqmodf_ MOV  pc,lr
    END
;
    TTL    wqmwrn
pc  RN     15
lr  RN     14
    AREA   |C$$code|,CODE,READONLY
    EXPORT wqmwrn_         ;dummy WQMWRN does nothing
wqmwrn_ MOV  pc,lr
    END
;
    TTL    wqnull
pc  RN     15
lr  RN     14
    AREA   |C$$code|,CODE,READONLY
    EXPORT wqnull_         ;dummy WQNULL does nothing
wqnull_ MOV  pc,lr
    END
;
    TTL    wqopnw
pc  RN     15
lr  RN     14
    AREA   |C$$code|,CODE,READONLY
    EXPORT wqopnw_         ;dummy WQOPNW calls WPSTWS
    IMPORT wpstws_
wqopnw_ B     wpstws_
    END
;
    TTL    wqpalc
pc  RN     15
lr  RN     14
    AREA   |C$$code|,CODE,READONLY
    EXPORT wqpalc_         ;dummy WQPALC does nothing
wqpalc_ MOV  pc,lr
    END
;
    TTL    wqpreq
pc  RN     15
lr  RN     14
    AREA   |C$$code|,CODE,READONLY
    EXPORT wqpreq_         ;dummy WQPREQ does nothing
wqpreq_ MOV  pc,lr
    END
;
    TTL    wqptww
pc  RN     15
lr  RN     14
    AREA   |C$$code|,CODE,READONLY
    EXPORT wqptww_         ;dummy WQPTWW does nothing
wqptww_ MOV  pc,lr
    END
;
    TTL    wqquit
pc  RN     15
lr  RN     14
    AREA   |C$$code|,CODE,READONLY
    EXPORT wqquit_         ;dummy WQQUIT does nothing
wqquit_ MOV  pc,lr
    END
;
    TTL    wqrfil
sp  RN     13
ip  RN     12
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT wqrfil_         ;dummy WQRFIL displays error window
    IMPORT WP_err1
wqrfil_
    LDR    R0,[sp]         ;pointer to file name
    ADR    ip,erm
    B      WP_err1         ;display message
erm DCB    129,"File:  not accepted",0,0,0
    END
;
    TTL    wqscrl
pc  RN     15
lr  RN     14
    AREA   |C$$code|,CODE,READONLY
    EXPORT wqscrl_         ;dummy WQSCRL does nothing
wqscrl_ MOV  pc,lr
    END
;
    TTL    wqupdt
pc  RN     15
lr  RN     14
    AREA   |C$$code|,CODE,READONLY
    EXPORT wqupdt_         ;dummy WQUPDT does nothing
wqupdt_ MOV  pc,lr
    END
;
    TTL    wqwfil
ip  RN     12
R0  RN     0
R1  RN     1
    AREA   |C$$code|,CODE,READONLY
    EXPORT wqwfil_         ;dummy WQWFIL displays error window
    IMPORT WP_err1
wqwfil_
    MOV    R0,R1
    ADR    ip,erm
    B      WP_err1         ;display message
erm DCB    129,"File  not written",0
    END
