;     Fortran Friends 2018
;                            update logs
;   qsort routines moved to fortlib                             3/2/2019
;   changed "MAIN" to "main" in TRACEP                           27/6/2018
;   added COPY2L & COPY2U                                       11/4/2007
;   allow fldire to read up to 1023 files                        1/4/2010
;   fldire returns err=-2 if can not access directory           23/5/2011
:   added FLTIME                                               10/10/2015
;   variable local area in oscli                                22/8/2016
;   added QSORTC                                               09/04/2018
;
    TTL    arcswi
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
R9  RN     9
OS_Byte                 EQU &06
OS_CallASWIR12          EQU &71
XOS_SWINumberFromString EQU &20039
    AREA   Utils_DATA,DATA,COMMON,NOINIT
    %      256
    AREA   |C$$data|,DATA
vrs %      4               ;RISC-OS version
    AREA   |C$$code|,CODE,READONLY
;
    EXPORT arcswi_         ;(N,IREGS,IERNUM,ERRMSG)
; perform SWI NUMB, with registers set to
; IREGS(0:9). Returns IREGS(0:9)
; and IERR=0 if OK, otherwise error message in ERRMSG
    DCB    "arcswi_",0,8,0,0,255
arcswi_
    MOV    ip,sp
    STMDB  sp!,{R1-R9,fp,ip,lr,pc};preserve arguments
    SUB    fp,ip,#4
    LDRB   R3,[R0,#3]      ;byte 4 of SWI number
    TST    R3,#&FF         ;test for text
    LDREQ  ip,[fp,#4]      ;length of ERRMSG
    LDRNE  R1,ptr          ;space for name
    LDMNEIB fp,{R2,ip}     ;lengths of name and ERRMSG
    STR    ip,[sp,#-4]!    ;store LEN(ERRMSG) on stack
    LDREQ  R3,[R0]         ;whole SWI number
    BEQ    num             ;SWI is number
    CMP    R2,#255
    ADRGT  R0,em1
    BGT    err
    MOV    lr,#0
lp1 STRB   lr,[R1,R2]
    SUBS   R2,R2,#1
    LDRGEB lr,[R0,R2]
    BGE    lp1
    SWI    XOS_SWINumberFromString
    BVS    err             ;error finding number
    MOV    R3,R0           ;R3 contains the SWI number
num LDR    R4,ver
    LDR    R1,[R4]         ;RISC-OS version
    CMP    R1,#0
    BNE    nm1
    MOV    R0,#129
    MOV    R1,#0
    MOV    R2,#&FF
    SWI    OS_Byte         ;get RISC-OS version number
    STR    R1,[R4]         ;store it for next time
nm1 CMP    R1,#&A6         ;check for RISC-OS-SA
    LDRLE  R2,swi          ;SWI template
    ORRLE  R0,R3,R2        ;make SWI instruction
    LDRLE  R2,ret          ;return instruction
    ORRGT  ip,R3,#&20000   ;SWI number in R12 (ip)
    STMDB  sp!,{R0,R2}     ;store (garbage if RISC-OS-SA)
    LDR    lr,[sp,#12]     ;address of IREGS
    LDMIA  lr,{R0-R9}      ;load registers from IREGS
    ADRLE  lr,rst          ;return from stack
    MOVLE  pc,sp           ;branch to pre-RISC-OS-SA code
    SWI    OS_CallASWIR12  ;RISC-OS-SA method
rst ADD    sp,sp,#8        ;restore stack
    LDMIB  sp,{ip,lr}      ;address of IREGS,IERR
    STMIA  ip,{R0-R9}      ;store registers in IREGS
    MOVVC  R0,#0
    STRVC  R0,[lr]         ;no error
    LDMVCDB fp,{R4-R9,fp,sp,pc} ;return - no error
err LDMIA  sp,{R1-R4}      ;length of ERRMSG & addresses of IREGS,IERNUM,ERRMSG
    LDR    lr,[R0],#4      ;error number
    STR    lr,[R3]         ;store in IERNUM
    CMP    lr,#0
    CMPNE  R1,#1
    LDMEQDB fp,{R4-R9,fp,sp,pc} ;return if no error, or ERRMSG length 1
lp2 LDRB   lr,[R0]         ;transfer error message
    CMP    lr,#31
    ADDGT  R0,R0,#1
    MOVLE  lr,#" "
    STRB   lr,[R4],#1
    SUBS   R1,R1,#1
    BGT    lp2
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
ptr DCD    Utils_DATA      ;pointer to temporary space
ver DCD    vrs             ;pointer to RISC-OS version
swi SWI    &20000          ;SWI template
ret MOV    pc,lr           ;return template
em1 DCB    255,255,255,255,"SWI name too long",0,0,0
    END
;
    TTL    beep
pc  RN     15
lr  RN     14
;
    AREA   |C$$code|,CODE,READONLY
; SUBROUTINE BEEP
    EXPORT beep_           ;rings the 'bell'
beep_
    SWI    &107
    MOV    pc,lr
    END
;
    TTL   COPY2L
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 copy2l_;(A,B) copies string A to B converting to lower case
    DCB    "copy2l_",0,8,0,0,255
copy2l_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUBS   R3,R3,#1
    SUBGES R2,R2,#1
    LDMLTDB  fp,{fp,sp,pc} ;return if no input
    MOV    ip,#" "     ;blank for fill
lp1 CMP    R3,R2
    STRGTB ip,[R1,R3]
    SUBGT  R3,R3,#1
    BGT    lp1
lp2 LDRB   ip,[R0,R3]    
    CMP    ip,#"A"     ;check for upper case
    RSBGES R2,ip,#"Z"
    ADDGE  ip,ip,#32   ;convert to lower
    STRB   ip,[R1,R3]
    SUBS   R3,R3,#1
    BGE    lp2         ;loop over string
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL   COPY2U
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 copy2u_;(A,B) copies string A to B converting to lower case
    DCB    "copy2u_",0,8,0,0,255
copy2u_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUBS   R3,R3,#1
    SUBGES R2,R2,#1
    LDMLTDB  fp,{fp,sp,pc} ;return if no input
    MOV    ip,#" "     ;blank for fill
lp1 CMP    R3,R2
    STRGTB ip,[R1,R3]
    SUBGT  R3,R3,#1
    BGT    lp1
lp2 LDRB   ip,[R0,R3]    
    CMP    ip,#"a"     ;check for lower case
    RSBGES R2,ip,#"z"
    SUBGE  ip,ip,#32   ;convert to upper
    STRB   ip,[R1,R3]
    SUBS   R3,R3,#1
    BGE    lp2         ;loop over string
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL   evalf
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
R8  RN    8
F0  FN    0
F1  FN    1
F2  FN    2
maxop EQU  8               ;maximum # operators (<=12)
nkeys EQU  14              ;number of key words
;
    AREA   |C$$data|,DATA
    %      24              ;space for extended versions of uservar and pi
; keywords inverted and zero filled
keyw DCB    0,0,0,0,"IP",0,0,"TRQS","GOL",0,"XGOL","PXE",0
    DCB    "NIS",0,"SOC",0,"NAT",0,"NISA","SOCA","NATA","SBA",0,"TNIA"
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT evalf_          ;(TEXT,IERR) evaluate the expression
    EXPORT jvalk_          ;(TEXT,NAME) set up keyword NAME => error
    IMPORT __rt_stkovf_split_small
;
; VALSET error returns
;  0: OK
; -1: too many characters in NAME
; -2: non-alphabetic character in NAME
; >0: see EVALF errors
    DCB    "jvalk_",0,0,8,0,0,255
jvalk_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STMDB  sp!,{R0,R3}     ;save length of keyword also
    MOV    R1,sp           ;space for error
    BL     evalf_          ;evaluate expression
    CMP    R0,#0
    LDMNEDB fp,{R4,fp,sp,pc} ;return if error
    LDR    R3,[sp,#4]      ;length of keyword text (R3)
    LDR    R1,[sp,#12]     ;address of keyword text (R1)
    MOV    R4,#0           ;keyword accumulator
lv1 LDRB   ip,[R1],#1
    CMP    ip,#"a"
    RSBGES lr,ip,#"z"
    SUBGE  ip,ip,#32       ;convert to upper case
    CMP    ip,#"A"-1
    RSBGTS lr,ip,#"Z"+1    ;check for alphabetic
    ORRGT  R4,ip,R4,LSL#8  ;accumulate keyword
    RSBLES lr,ip,#" "      ;skip blanks
    MOVLT  R0,#-2          ;error -2 for non-alphabetic
    LDMLTDB fp,{R4,fp,sp,pc} ;return if error
    SUBS   R3,R3,#1
    RSBGTS lr,R4,#&1000000 ;check if full
    BGT    lv1
    MOVLT  R0,#-1          ;too many characters
    LDREQ  R1,pkey
    STREQ  R4,[R1]         ;store keyword
    STFEQE F0,[R1,#-24]    ;and store value
    LDMDB  fp,{R4,fp,sp,pc} ;return
;
; EVALF error returns
; 0: OK
; 1: unknown character
; 2: found an operator when expecting a value
; 3: expression does not end with a value
; 4: found a value when expecting an operator
; 5: parentheses not closed
; 6: expression too long
; 7: unknown keyword
; 8: function followed by function
    DCB    "evalf_",0,0,8,0,0,255
evalf_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,R4-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    CMP    sp,sl
    BLLT   __rt_stkovf_split_small
    SUB    sp,sp,#4*(maxop*4+4);space needed for possible expression
    BIC    sp,sp,#&F       ;make stack multiple of 16
    ADD    R6,sp,#4*(maxop*4);last possible word for operator
    ADD    R4,sp,#4        ;pointer to first value in expression
    LDR    R3,pkey
    LDR    lr,[R3,#-12]    ;check if extended data for pi has been set up
    CMP    lr,#0
    MNFEQE F0,#1
    ACSEQE F1,F0
    STFEQE F1,[R3,#-12]    ;store pi  = acos(-1)
    MOV    lr,#0
    STR    lr,[sp]         ;clear initial virtual operator
    ADD    R2,R0,R2        ;end of input
; check first character is not a sign
    LDRB   ip,[R0]
    CMP    ip,#"+"
    ADDEQ  R0,R0,#1    ;ignore initial "+"
    CMP    ip,#"-"     ;if first character is "-"
    STREQ  lr,[R4],#4      ;put in dummy 0.0
    STREQ  lr,[R4],#4
    STREQ  lr,[R4],#4
; now look through text string
lp1 CMP    R0,R2           ;input accounting
    BGE    p90             ;all read in, go evaluate expression
    LDRB   ip,[R0],#1      ;get character
    CMP    ip,#" "
    BEQ    lp1             ;skip blanks
    CMP    ip,#"("
    BEQ    p20             ;new expression
    CMP    ip,#"."
    CMPNE  ip,#"0"
    RSBGES lr,ip,#"9"
    BGE    p30             ;numeric
    CMP    ip,#"a"
    RSBGES lr,ip,#"z"
    SUBGE  ip,ip,#32       ;convert to upper
    CMP    ip,#"A"
    RSBGES lr,ip,#"Z"
    BGE    p40             ;alphabetic
    ADR    R3,ops
    MOV    R5,R3
lp2 LDRB   lr,[R3],#1
    CMP    lr,#0
    MOVEQ  R0,#1           ;error 1: unknown character
    BEQ    err
    CMP    lr,ip
    BNE    lp2
    SUB    R3,R3,R5        ;operator number
    CMP    ip,#"*"     ;check for "*"
    LDREQB ip,[R0]
    CMPEQ  ip,#"*"     ;check for "**"
    MOVEQ  R3,#1       ;substitute "^"
    ADDEQ  R0,R0,#1
    TST    R4,#12
    MOVNE  R0,#2           ;error 2: wrong parity for operator
    BNE    err
    CMP    R6,R4
    MOVLE  R0,#6           ;error 6: expression too long
    STRGT  R3,[R4],#4      ;store operator
    BGT    lp1
err; error return
    STR    R0,[R1]
    MVFS   F0,#0
    LDMDB  fp,{R4-R8,fp,sp,pc} 
;
p20; found "(", look for ")"
    ADD    R3,R0,#1        ;save 'position'
    MOV    R5,#1           ;parenthesis depth
lp3 CMP    R0,R2           ;account
    MOVGE  R0,#5           ;error 5: too many left parentheses
    BGE    err         ;no ")"
    LDRB   ip,[R0],#1
    CMP    ip,#"("
    ADDEQ  R5,R5,#1
    CMP    ip,#")"
    BNE    lp3
    SUBS   R5,R5,#1
    BNE    lp3
    STMFD  sp!,{R0,R2}     ;save registers
    SUB    R2,R0,R3        ;#characters between parentheses
    SUB    R0,R3,#1        ;pointer to first character
    BL     evalf_          ;go evaluate expression
    CMP    R0,#0
    BNE    err
    LDMFD  sp!,{R0,R2}     ;restore registers
    TST    R4,#4
    STFNEE F0,[R4],#12
    BNE    lp1
;
p30; evaluate numeric expression
    TST    R4,#4
    MOVEQ  R0,#4           ;error 4: wrong parity for value
    BEQ    err
    MVFE   F0,#0           ;accumulator
    MVFE   F2,#0           ;exponent
lp4 CMP    ip,#"."
    MVFEQE F2,#1           ;initialse exponent multiplier
    CMPNE  ip,#" "
    BEQ    p31             ;skip blank and decimal point
    RSBS   ip,ip,#"9"
    RSBGES ip,ip,#9
    FLTGEE F1,ip
    MUFGEE F0,F0,#10
    ADFGEE F0,F0,F1
    MUFGEE F2,F2,#10
p31 CMPGE  R2,R0
    LDRGTB ip,[R0],#1
    BGT    lp4
    SUBLT  R0,R0,#1        ;go back one character if not numeral
    CMFE   F2,#0
    DVFNEE F0,F0,F2        ;divide by 10**(#decimals)
    STFE   F0,[R4],#12
    B      lp1
; key word?
lp5 CMP    R5,#"a"
    RSBGES lr,R5,#"z"
    SUBGE  R5,R5,#32       ;convert lower to upper case alphabetic
    CMP    R5,#"A"-1
    RSBGTS lr,R5,#"Z"+1    ;check for alphabetic
    ORRGT  ip,R5,ip,LSL#8  ;accumulate keyword (backwards)
    RSBLES lr,R5,#" "      ;check for blank
p40 CMPGE  R2,R0           ;check for more input characters
    LDRGTB R5,[R0],#1
    RSBGTS lr,ip,#&1000000 ;check if already got 4 characters
    BGT    lp5
    SUBLT  R0,R0,#1        ;have read one too many, back up one
    TST    R4,#4
    MOVEQ  R0,#4           ;error 4: wrong parity for value
    BEQ    err
    LDR    R3,pkey
    MOV    R5,#nkeys
lp6 SUBS   R5,R5,#1
    MOVLT  R0,#7           ;error 7: unknown keyword
    BLT    err
    LDR    lr,[R3,R5,LSL#2]
    CMP    lr,ip
    BNE    lp6
    CMP    R5,#1           ;check for immediate value
    SUBLT  ip,R3,#24       ;address of user keyword value
    SUBEQ  ip,R3,#12       ;address of pi
    LDMLEIA ip,{R3,R5,lr}
    STMLEIA R4!,{R3,R5,lr} ;store immediate value (user or pi)
    BLE    lp1
    LDR    ip,[R4,#-4]
    TST    ip,#&FF0000     ;check there is no keyword operator already
    MOVNE  R0,#8
    BNE    err
    ORR    ip,ip,R5,LSL#16 ;add key to operator
    STR    ip,[R4,#-4]
    B      lp1             ;go evaluate argument
p90; all parsed, evaluate expression
    TST    R4,#12
    MOVNE  R0,#3           ;error 3: expression does not end with value
    BNE    err
    MOV    R3,sp           ;position of zeroth operator
lp7 LDR    ip,[R3],#16     ;get operator
    MOVS   ip,ip,LSR#16    ;get key
    BEQ    p94             ;no key, so skip function evaluation
    LDFE   F1,[R3,#-12]    ;get value on right
    ADR    R0,p92-16       ;ip=2 for SQRT etc.
    ADD    pc,R0,ip,LSL#3  ;jump to appropriate function
; evaluate function
p92 SQTE   F0,F1           ;SQRT
    B      p93
    LGNE   F0,F1           ;LOG
    B      p93
    LOGE   F0,F1           ;LOGX
    B      p93
    EXPE   F0,F1           ;EXP
    B      p93
    SINE   F0,F1           ;SIN
    B      p93
    COSE   F0,F1           ;COS
    B      p93
    TANE   F0,F1           ;TAN
    B      p93
    ASNE   F0,F1           ;ASIN
    B      p93
    ACSE   F0,F1           ;ACOS
    B      p93
    ATNE   F0,F1           ;ATAN
    B      p93
    ABSE   F0,F1           ;ABS
    B      p93
    RNDEZ  F0,F1           ;AINT
p93 STFE   F0,[R3,#-12]    ;store results of function
p94 CMP    R3,R4
    BLT    lp7
    MOV    R3,R4
    MOV    R5,#1       ;do "^" backwards
lp8 SUB    R3,R3,#16       ;point to operator
    CMP    R3,sp
    BLE    lp9
    BL     p96
    B      lp8
lp9 MOV    R3,sp
    ADD    R5,R5,#1    ;do "/","*","-","+" forwards
lpa ADD    R3,R3,#16
    CMP    R3,R4
    BGE    lpb
    BL     p96
    B      lpa
lpb CMP    R5,#5
    BLT    lp9
fin; all done
    LDFE   F0,[sp,#4]
    MOV    R0,#0
    STR    R0,[R1]
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
p96; do operation
    LDR    ip,[R3]         ;get operator
    AND    R0,ip,#255
    CMP    R0,R5
    MOVNE  pc,lr           ;not wanted operator
    LDFE   F0,[R3,#4]      ;get value on right
    LDFE   F1,[R3,#-12]    ;get value on left
    CMP    R5,#2           ;operate
    POWLTE F2,F1,F0        ;a**b
    DVFEQE F2,F1,F0        ;a/b
    CMP    R5,#3
    MUFEQE F2,F1,F0        ;a*b
    CMP    R5,#4
    SUFEQE F2,F1,F0        ;a-b
    ADFGTE F2,F1,F0        ;a+b
    STFE   F2,[R3,#-12]    ;write back answer to the left
; now squeeze out part to the right
    SUB    R4,R4,#16
    CMP    R4,R3
    MOVLE  pc,lr
    MOV    R0,R3
    ADD    R2,R0,#16
p98 LDMIA  R2!,{R6-R8,ip}
    STMIA  R0!,{R6-R8,ip}
    CMP    R4,R0
    BGT    p98
    B      p96             ;try again
;
pkey DCD    keyw
ops DCB    "^/*-+",0,0,0
    END
;
    TTL    flaccs
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_File EQU &08
    AREA   |C$$code|,CODE,READONLY
    EXPORT flaccs_         ;(SET,NAME,ACCESS,IERR) gets/set the file access.
    IMPORT UT_GetF
; IERR returned 0 for OK
; -1: file does not exist
; +1: file is a directory and you can not change the access
; +2: unknown character in ACCESS string ('RWLrw')
    DCB    "flaccs_",0,8,0,0,255
flaccs_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R4,R1           ;address of NAME
    LDR    R5,[fp,#4]      ;length of name
    LDR    ip,[R0]         ;SET
    BL     UT_GetF         ;get file info
    BLT    err             ;file does not exist
    LDR    R2,[sp,#8]      ;address of ACCESS
    LDR    R3,[fp,#8]      ;length of ACCESS
    CMP    ip,#0
    BNE    set             ;branch to set the access
    AND    R5,R5,#&3B      ;mask out the useful attributes
    CMP    R0,#0
    MOVGT  R0,#"D"
    STRGTB R0,[R2],#1      ;insert 'D' for directory
    SUBGT  R3,R3,#1
    ADR    R4,str
lp1 CMP    R3,#0
    BLE    ner             ;no more space in ACCESS
    MOVS   R5,R5,LSR#1
    LDRB   R0,[R4],#1
    STRCSB R0,[R2],#1      ;insert access letter
    SUBCS  R3,R3,#1
    BNE    lp1             ;more access bits
    MOV    R0,#" "
lp2 SUBS   R3,R3,#1
    STRGEB R0,[R2],#1      ;blank fill
    BGT    lp2
ner MOV    R0,#0           ;no error here
err LDR    R3,[sp,#12]     ;address of IERR
    STR    R0,[R3]         ;store IERR
    LDMDB  fp,{R4-R5,fp,sp,pc} 
set; set access bits here
    CMP    R0,#0
    BNE    err             ;not a file
    MOV    R5,#0           ;initialise attributes
lp3 LDRB   ip,[R2],#1      ;get access character
    CMP    ip,#" "
    BEQ    fn1             ;finished at blank
    ADR    R4,str          ;search string
    MOV    lr,#1           ;bit
lp4 LDRB   R0,[R4],#1
    CMP    R0,#0
    MOVEQ  R0,#2
    BEQ    err             ;unknown character
    CMP    ip,R0
    MOVNE  lr,lr,LSL#1     ;shift attribute bit
    BNE    lp4
    ORR    R5,R5,lr        ;insert bit
    SUBS   R3,R3,#1
    BGT    lp3             ;loop over ACCESS characters
fn1 MOV    R0,#4
    SWI    OS_File         ;set attributes
    B      ner
str DCB    "RW Lrw",0,0    ;access characters
    END
;
    TTL    fldate
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_ConvertDateAndTime EQU &C1
    AREA   |C$$code|,CODE,READONLY
    EXPORT fldate_         ;(NAME,DATE,IERR) gets date of file NAME
; error codes:
; -1: file not found
    IMPORT UT_GetF
    DCB    "fldate_",0,8,0,0,255
fldate_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,#0
    STR    ip,[R2]         ;preset IERR=0
    MOV    R4,R0           ;address of NAME
    MOV    R5,R3           ;length of NAME
    BL     UT_GetF         ;get file name in R1
    LDRLT  R3,[sp,#8]      ;restore address of IERR
    STRLT  R0,[R3]         ;store error
    LDMLTDB fp,{R4-R5,fp,sp,pc} ;return
    MOV    R0,R1
    STR    R3,[R1],#4
    STR    R2,[R1],#4
    MOV    R2,#128
    ADR    R3,fmt
    SWI    OS_ConvertDateAndTime
    LDR    R2,[sp,#4]      ;address of DATE
    LDR    R3,[fp,#4]      ;length of date
lp1 LDRB   ip,[R0]
    CMP    ip,#0
    ADDGT  R0,R0,#1
    MOVEQ  ip,#" "
    STRB   ip,[R2],#1      ;move date
    SUBS   R3,R3,#1
    BNE    lp1
    LDMDB  fp,{R4-R5,fp,sp,pc} 
fmt DCB    "%24:%MI:%SE %DY %M3 %CE%YR %WN %MN",0
    END
;
    TTL    fldire
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
XOS_GBPB EQU &2000C
    AREA   |C$$code|,CODE,READONLY
    EXPORT fldire_         ;(NUMB,DNAME,FNAME,IRES) gets a file name
    IMPORT UT_GetF
; IRES returned:
; -1: DNAME is not a directory
;  0: file NUMB does not exist
; +1: FNAME contains file name
; +2: FNAME contains directory name
    DCB    "fldire_",0,8,0,0,255
fldire_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R4,R1           ;address of DNAME
    LDR    R5,[fp,#4]      ;length of DNAME
    LDR    ip,[R0]         ;NUMB
    CMP    ip,#1024
    RSBLTS R6,ip,#1        ;ensure it is range [1:1024]
    MOVGT  R0,#0
    BGT    err
    BL     UT_GetF         ;get directory info
    MOVLE  R0,#-1
    BLE    err             ;not a directory
    MOV    R0,#10          ;get file attributes and name
    SUB    sp,sp,#128
    MOV    R2,sp           ;space for result
    MOV    R3,#1
    SUB    R4,ip,#1        ;entry to find
    MOV    R5,#128
    MOV    R6,#0
    SWI    XOS_GBPB
    MOVVS  R0,#-2
    BVS    err
    MOVS   R0,R3
    LDRNEB R0,[R2,#16]     ;object type  (1:file, 2:directory)
    CMPNE  R0,#0
    BEQ    err             ;no file found
    LDR    R3,[fp,#-32]    ;address of FNAME
    LDR    R4,[fp,#8]      ;length of FNAME
    ADD    R2,R2,#20       ;pointer to name
lp1 LDRB   ip,[R2]
    CMP    ip,#0
    ADDGT  R2,R2,#1
    MOVLE  ip,#" "
    STRB   ip,[R3],#1
    SUBS   R4,R4,#1
    BGT    lp1             ;transfer name to FNAME
err LDR    R3,[fp,#-28]    ;address of IRES
    STR    R0,[R3]         ;store IRES
    LDMDB  fp,{R4-R6,fp,sp,pc} 
    END
;
    TTL    fllist
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
XOS_GBPB EQU &2000C
    AREA   |C$$code|,CODE,READONLY
    EXPORT fllist_         ;(DNAME,FNAME,NUMB) gets list of file names in FNAME
;   NUMB is the maximum number of files to read
;   NUMB returned:
; -1: DNAME is not a directory
;  n: number of files listed
    DCB    "fllist_",0,8,0,0,255
fllist_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,R2,R3,R4,R5,R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R4,R0           ;address of DNAME
    MOV    R5,R3           ;length of DNAME
    LDR    R3,[R2]         ;NUMB of files to read
    MOV    R2,R1           ;address of FNAME
    AND    R5,R5,#255      ;limit to 255 characters
    SUB    sp,sp,#256      ;space for directory name
    MOV    R1,sp
    MOV    R0,#0
lp1 STRB   R0,[R1,R5]       ;store null-terminated directory name at R1
    SUBS   R5,R5,#1
    LDRGEB R0,[R4,R5] 
    BGE    lp1
    MOV    R0,#9           ;get file names only
    MOV    R4,#0           ;first file number
    LDR    R5,[fp,#4]      ;length of buffer
    MOV    R6,#0           ;no mask
    SWI    XOS_GBPB
    MOVVS  R0,#-1
    BVS    err
    MOV    R0,R3
err LDR    R3,[fp,#-32]    ;address of NUMB
    STR    R0,[R3]         ;store NUMB
    LDMDB  fp,{R4-R6,fp,sp,pc} 
    END
;
    TTL    flload
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_GBPB EQU &0C
XOS_Find EQU &2000D
    AREA   |C$$code|,CODE,READONLY
    EXPORT flload_         ;(NAME,BUF,LENG,IERR) loads file into buf (length LEN
    IMPORT UT_GetF
; error codes:
; -1: file not found
; -2: file can not be read
; +1: file is directory
    DCB    "flload_",0,8,0,0,255
flload_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R4,R0           ;address of NAME
    LDR    R5,[fp,#4]      ;length of NAME
    BL     UT_GetF         ;get file length in R4
    LDR    R5,[sp,#12]     ;address of IERR
    STR    R0,[R5]         ;store error
    CMP    R0,#0
    LDMNEDB fp,{R4-R5,fp,sp,pc} ;return if error
    MOV    R0,#&4F
    LDR    R1,ptr          ;pointer to name set up by UT_GetF
    SWI    XOS_Find
    MOVVS  R0,#-2
    STRVS  R0,[R5]         ;set IERR=-2 if can't open file to read
    LDMVSDB fp,{R4-R5,fp,sp,pc} ;return if can't open file
    MOV    R1,R0           ;file handle
    LDMIB  sp,{R2,R5}      ;addresses of BUF and LENG
    LDR    R3,[R5]         ;LENG
    CMP    R3,R4
    MOVGT  R3,R4           ;reduce length to read if file is shorter than BUF
    MOV    R0,#4           ;to read from current position
    SWI    OS_GBPB         ;read file
    MOV    R0,#0
    SWI    XOS_Find        ;close file
    LDMDB  fp,{R4-R5,fp,sp,pc} ;return
ptr DCD    txt
    AREA   Utils_DATA,DATA,COMMON,NOINIT
txt %      256
    END
;
    TTL    flsave
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
XOS_File EQU &20008
    AREA   |C$$code|,CODE,READONLY
    EXPORT flsave_         ;(NAME,BUF,LENG,ITYPE,IERR)
; writes file (type ITYPE) from BUF (length LENG bytes)
; error codes:
; +1: can not write file
; +2: file name too long
    DCB    "flsave_",0,8,0,0,255
flsave_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[ip,#4]      ;length of name
    CMP    ip,#255
    MOVGT  R0,#2
    BGT    err
    LDR    R4,ptr          ;space for null terminated name
lp1 LDRB   lr,[R0],#1
    STRB   lr,[R4],#1
    SUBS   ip,ip,#1
    BGT    lp1
    STRB   ip,[R4]         ;null terminate
    MOV    R0,#10          ;to save file with type
    MOV    R4,R1           ;beginning address
    LDR    R5,[R2]         ;LENG
    ADD    R5,R5,R4        ;end address
    LDR    R1,ptr          ;name
    LDR    R2,[R3]         ;ITYPE
    CMP    R2,#&1000
    RSBCCS ip,R2,#0
    MOVCS  R2,#&FD
    ORRCS  R2,R2,#&0F00    ;default file type &FFD (data)
    SWI    XOS_File        ;save file
    MOVVC  R0,#0           ;set up error number
    MOVVS  R0,#1
err LDR    R3,[fp,#4]      ;address of IERR
    STR    R0,[R3]         ;store IERR
    LDMDB  fp,{R4-R5,fp,sp,pc} ;return
ptr DCD    txt
    AREA   Utils_DATA,DATA,COMMON,NOINIT
txt %      256
    END
;
    TTL    flsize
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
    AREA   |C$$code|,CODE,READONLY
    EXPORT flsize_         ;(NAME,LENG,IERR) gets size of file NAME
; error codes:
; -1: file not found
; +1: file is directory
    IMPORT UT_GetF
    DCB    "flsize_",0,8,0,0,255
flsize_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R4,R0           ;address of NAME
    MOV    R5,R3           ;length of NAME
    BL     UT_GetF         ;get file length in R4
    LDMIB  sp,{R2,R3}      ;restore addresses of LEN & IERR
    STR    R4,[R2]         ;store length
    STR    R0,[R3]         ;store error
    LDMDB  fp,{R4-R5,fp,sp,pc} ;return
    END
;    
    TTL    fltime
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_File EQU &08
    AREA   |C$$code|,CODE,READONLY
    EXPORT fltime_         ;(SET,NAME,ITIM,IERR) gets/sets the file type.
    IMPORT UT_GetF
; IERR returned 0 for OK
; -1: file does not exist
; +1: file is a directory
; ITIM is a integer pair: 8-bit, 32-bit
    DCB    "fltime_",0,8,0,0,255
fltime_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R4,R1           ;address of NAME
    LDR    R5,[fp,#4]      ;length of name
    LDR    ip,[R0]         ;SET
    BL     UT_GetF         ;get file info
    BNE    err             ;not a real file
    CMP    ip,#0
    LDR    ip,[sp,#8]      ;address of ITIM
    ANDEQ  R2,R2,#255      ;extract ms 8-bits of time
    STMEQIA ip,{R2,R3}     ;store ITIM
    BEQ    ner
    LDMIA  ip,{R0,R3}      ;get itim
    AND    R0,R0,#255
    BIC    R2,R2,#255
    ORR    R2,R2,R0
    MOV    R0,#1
    SWI    OS_File         ;set date/time
ner MOV    R0,#0           ;no error here
err LDR    R3,[sp,#12]     ;address of IERR
    STR    R0,[R3]         ;store IERR
    LDMDB  fp,{R4-R5,fp,sp,pc}^
    END
;
    TTL    fltype
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_File EQU &08
    AREA   |C$$code|,CODE,READONLY
    EXPORT fltype_         ;(SET,NAME,TYPE,IERR) gets/sets the file type.
    IMPORT UT_GetF
; IERR returned 0 for OK
; -1: file does not exist
; +1: file is a directory
; +2: TYPE not in the range [&000:&FFF]
    DCB    "fltype_",0,8,0,0,255
fltype_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R4,R1           ;address of NAME
    LDR    R5,[fp,#4]      ;length of name
    LDR    ip,[R0]         ;SET
    BL     UT_GetF         ;get file info
    BNE    err             ;not a real file
    LDR    R4,[sp,#8]      ;address of TYPE
    CMP    ip,#0
    MOVEQ  R2,R2,LSL#12    ;extract type
    MOVEQ  R2,R2,LSR#20
    STREQ  R2,[R4]         ;store type
    BEQ    ner
    LDR    R2,[R4]         ;get type
    CMP    R2,#&1000
    MOVHS  R0,#2
    BHS    err
    MOV    R0,#18
    SWI    OS_File         ;set type
ner MOV    R0,#0           ;no error here
err LDR    R3,[sp,#12]     ;address of IERR
    STR    R0,[R3]         ;store IERR
    LDMDB  fp,{R4-R5,fp,sp,pc} 
    END
;
    TTL    fpstat
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 fpstat_         ;(INX,UFL,OFL,DVZ,IVO)
    DCB    "fpstat_",0,8,0,0,255
fpstat_
    MOV    ip,sp
    STMDB  sp!,{R0-R3}     ;make contiguous string of args
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#20
    RFS    R0
    MOV    R0,R0,LSR#16    ;get IVO into l.s. bit
    MOV    R1,#5           ;5 results
l1  LDR    R2,[fp,R1,LSL#2];argument address
    AND    R3,R0,#1
    STR    R3,[R2]         ;store bit
    SUBS   R1,R1,#1
    MOV    R0,R0,LSR#1
    BGT    l1
    LDMDB  fp,{fp,sp,pc} 
;
    EXPORT fpsset_         ;(INX,UFL,OFL,DVZ,IVO)
    DCB    "fpsset_",0,8,0,0,255
fpsset_
    MOV    ip,sp
    STMDB  sp!,{R0-R3}     ;make contiguous string of args
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#20
    RFS    R0              ;read status word
    BIC    R0,R0,#&1F0000  ;clear trap enable flags
    MOV    ip,#&200000     ;bit to store
    MOV    R1,#5           ;5 arguments
l2  LDR    R2,[fp,R1,LSL#2];argument address
    LDR    R3,[R2]         ;get arg
    CMP    R3,#1
    LDMHIDB fp,{fp,sp,pc}  ;return if illegal
    ORREQ  R0,R0,ip,LSR R1 ;set bit if .TRUE.
    SUBS   R1,R1,#1
    BGT    l2
    WFS    R0              ;store status word
    LDMDB  fp,{fp,sp,pc} 
    END
;
    TTL    gtargs
pc  RN     15
lr  RN     14
ip  RN     12
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
OS_GetEnv EQU &10
    AREA   |C$$code|,CODE,READONLY
; SUBROUTINE GTARGS(STRING)
    EXPORT gtargs_         ;returns program argument string
gtargs_
    MOV    R3,R0           ;address of STRING
    MOV    ip,R1           ;length of STRING
    SWI    OS_GetEnv       ;get environment
lp1 LDRB   R1,[R0]         ;byte of command line
    CMP    R1,#32          ;test for terminator
    ADDGE  R0,R0,#1
    MOVLT  R1,#" "
    SUBS   ip,ip,#1        ;count O/P bytes
    STRB   R1,[R3],#1      ;store in STRING
    BGE    lp1
    MOV    pc,lr           ;return
    END
;
    TTL    iget
pc  RN     15
lr  RN     14
OS_ReadC EQU &04
    AREA   |C$$code|,CODE,READONLY
    EXPORT iget_           ;waits for a key press & returns an ASCII character
iget_
    SWI    OS_ReadC
    MOV    pc,lr
    END
;
    TTL    inkey
pc  RN     15
lr  RN     14
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
OS_Byte EQU &06
    AREA   |C$$code|,CODE,READONLY
    EXPORT inkey_          ;returns an ASCII character within a timelimit or
; if argument is -ve checks for that character
inkey_
    LDR    R3,[R0]         ;get NUM
    CMP    R3,#0           ;check + or -ve
    AND    R1,R3,#&FF      ;low byte of time
    MOVGE  R2,R3,LSR#8     ;2nd byte of time
    ANDGE  R2,R2,#&7F      ;ensure it is +ve
    MOVLT  R2,#&FF         ;flag for key search
    MOV    R0,#129         ;for OSByte 129
    SWI    OS_Byte
    CMP    R3,#0           ;check + or -ve (again)
    MOVLT  R0,R1           ;store TRUE or FALSE from OSBYTE for -ve
    MOVLT  pc,lr           ;return if -ve argument
    CMP    R2,#&FF         ;check for timeout
    MOVEQ  R1,#-1          ;set ans -1 if timeout
    MOV    R0,R1           ;store ans
    MOV    pc,lr           ;return to fortran
    END
;
    TTL MesgUtils
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
XMessageTrans_FileInfo  EQU &61500
MessageTrans_OpenFile   EQU &41501
MessageTrans_Lookup     EQU &41502
XMessageTrans_Lookup    EQU &61502
XMessageTrans_CloseFile EQU &61504
XMessageTrans_GSLookup  EQU &61507
    AREA   |C$$data|,DATA
des %     20               ;open file descriptor and flag
    AREA   |C$$code|,CODE,READONLY
    EXPORT msgcls_         ;close current file (if open)
    EXPORT msgget_         ;ier=msgget(nsubs,token,[sub1,sub2,sub3,sub4],res)
    EXPORT msgggs_         ;ier=msgggs(nsubs,token,[sub1,sub2,sub3,sub4],res)
    EXPORT msgopn_         ;ier=msgopn(fname,mem) opens a file into mem(CHAR)
    EXPORT msgsiz_         ;isiz=msgsiz(fname) returns size for a file
;
    DCB    "msgsiz_",0,8,0,0,255
msgsiz_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R2,R1           ;length of file name
    BL     get_fname       ;get file name in R1
    SWI    XMessageTrans_FileInfo
    TST    R0,#1
    MOVNE  R2,#0           ;file exists in memory
    MOVVC  R0,R2
    MOVVS  R0,#-1          ;error -1: can not find file
    LDMDB  fp,{fp,sp,pc} 
;
get_fname
    SUB    sp,sp,R2
    SUB    sp,sp,#1
    MOV    R1,sp
    MOV    ip,#0
lf1 STRB   ip,[R1,R2]
    SUBS   R2,R2,#1
    LDRGEB ip,[R0,R2]
    BGE    lf1
    MOV    pc,lr
;
    DCB    "msgopn_",0,8,0,0,255
msgopn_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     get_fname       ;get file name in R1
    LDR    R4,ptr          ;address of descriptor
    LDR    R0,[R4,#16]     ;'open' flag
    CMP    R0,#0
    MOVNE  R0,#2           ;error 2: file already open
    LDMNEDB fp,{R4-R4,fp,sp,pc} 
    SWI    XMessageTrans_FileInfo
    MOVVS  R0,#1           ;error 1: can not find file
    LDMVSDB fp,{R4-R4,fp,sp,pc} 
    TST    R0,#1
    MOVNE  R2,#0
    CMP    R2,R3
    MOVGT  R0,#3           ;error 3: not enough memory
    LDMGTDB fp,{R4,fp,sp,pc} 
    MOV    R0,R4           ;pointer to new file descriptor
    LDR    R2,[fp,#-28]    ;address of mem
    SWI    MessageTrans_OpenFile
    STR    R4,[R4,#16]     ;flag file open
    MOV    R0,#0
    LDMDB  fp,{R4,fp,sp,pc} 
;
    DCB    "msgcls_",0,8,0,0,255
msgcls_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,ptr
    LDR    R1,[R0,#16]
    CMP    R1,#0
    LDMEQDB  fp,{fp,sp,pc} 
    SWI    XMessageTrans_CloseFile
    MOV    R1,#0
    STR    R1,[R0,#16]     ;set 'file closed' flag
    LDMDB  fp,{fp,sp,pc} 
;
;                   stack usage relative to frame pointer
;      contents -> tn [s1 s2 s3 s4] res lt  [ls1 ls2 ls3 ls4] lr
;#words from fp ->  1 [ 2  3  4  5] n+2 n+3 [n+4 n+5 n+6 n+7] 2n+4
;
    DCB    "MSGGGS",0,0,8,0,0,255
msgggs_
    MOV    ip,sp
    STMDB  sp!,{R1-R3}
    STMDB  sp!,{R4-R7,fp,ip,lr,pc}
    MOV    R7,#1
    B      mgs
;
    DCB    "MSGGET",0,0,8,0,0,255
msgget_
    MOV    ip,sp
    STMDB  sp!,{R1-R3}
    STMDB  sp!,{R4-R7,fp,ip,lr,pc}
    MOV    R7,#0
mgs SUB    fp,ip,#16
    LDR    R6,[R0]         ;nsubs
    ADD    R5,fp,#12
    ADD    R5,R5,R6,LSL#2  ;pointer to length of 'token'
    ADD    R4,fp,#4        ;pointer to 'token'
    CMP    R6,#0
    RSBGES R6,R6,#4        ;4-nsubs
    MOVLT  R0,#6           ;error 6: wrong # args
    LDMLTDB fp,{R4-R7,fp,sp,pc} 
    SUB    sp,sp,#20       ;space for text args
    MOV    R0,sp           ;pointer to text args
    MOV    R1,#4           ;count of text items
lp1 MOV    lr,#0
    CMP    R1,R6
    LDRGE  R2,[R4],#4      ;address of text
    LDRGE  R3,[R5],#4      ;length of text
    SUBGE  sp,sp,R3
    SUBGE  sp,sp,#1
    STRGE  sp,[R0],#4      ;store address of text
    STRLT  lr,[R0],#4      ;or zero if no text
lp2 STRGEB lr,[sp,R3]      ;transfer text null terminated
    SUBGES R3,R3,#1
    LDRGEB lr,[R2,R3]
    BGE    lp2
    SUBS   R1,R1,#1
    BGE    lp1
    LDR    R2,[R4]         ;pointer to 'result'
    LDR    R3,[R5]         ;length of 'result'
    MOV    ip,R2           ;save address of 'result'
    MOV    lr,R3           ;save length of 'result'
    CMP    R7,#0           ;check whether msgget or msgggs
    LDMDB  R0,{R1,R4-R7}   ;get text args
    LDR    R0,ptr          ;file info pointer
    BEQ    Lup             ;have to do this because of MessageTrans bug
    SWI    XMessageTrans_GSLookup
    B      Lnd
Lup SWI    XMessageTrans_Lookup
Lnd MOVVS  R0,#5           ;error 5: unable to find token
    LDMVSDB fp,{R4-R7,fp,sp,pc} 
    SUBS   R0,lr,R3        ;excess length in 'result'
    MOV    lr,#" "
    STRGTB lr,[ip,R3]!     ;blank fill
lp3 SUBGTS R0,R0,#1
    STRGTB lr,[ip,#1]!
    BGT    lp3
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return (R0=0)
;
ptr DCD    des             ;file descriptor
    END
;
    TTL    mouse
pc  RN     15
lr  RN     14
sp  RN     13
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
OS_Mouse EQU &1C
    AREA   |C$$code|,CODE,READONLY
; MOUSE button operations
    EXPORT mouse_          ;(MX,MY,MBUTN)
mouse_
    STMFD  sp!,{R0-R2,R4,R5,lr};save addresses of arguments
    SWI    OS_Mouse
    LDMFD  sp!,{R3-R5}     ;retrieve arg addresses
    STR    R0,[R3]         ;store MX
    STR    R1,[R4]         ;store MY
    STR    R2,[R5]         ;store MBUTN
    LDMFD  sp!,{R4,R5,pc}  ;RETURN to FORTRAN
    END
;
    TTL    nextwd
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
sep EQU    " "             ;separator is blank
    AREA   |C$$code|,CODE,READONLY
    EXPORT nextwd_         ;(STRING,JS,WORD,LW)
; Input:  STRING with pointer JS to where to start
; Output: WORD filled with left justifed next word with length LW
; JS updated to blank after word or LEN(STRING)+1 if none
; LW=0 if no next word
; LW=-length of substring if it not all fit in WORD
    DCB     "nextwd_",0,8,0,0,255
nextwd_
    MOV     ip,sp
    STMDB   sp!,{R0-R7,fp,ip,lr,pc}
    SUB     fp,ip,#4
    LDMIB   fp,{R4,R5}     ;lengths of STRING and WORD
    LDR     R6,[R1]        ;JS
    MOV     R7,R5          ;initialise WORD byte count
    ADD     R0,R0,R6
    SUB     R0,R0,#1       ;pointer to first byte to search
    SUBS    R6,R4,R6       ;#bytes left in STRING -1
    BLT     pt1            ;no more bytes
lp1 LDRB    ip,[R0],#1     ;get byte of STRING
    CMP     ip,#sep
    BNE     lp3            ;found non-sep
    SUBS    R6,R6,#1
    BGE     lp1            ;look for non-sep
pt1 SUB     R5,R5,R7       ;calculate LW
    CMP     R7,#0          ;check that WORD has no overflow
    RSBLT   R5,R5,#0       ;if so, set LW negative
    STR     R5,[R3]        ;store LW
    SUB     R6,R4,R6       ;next value of JS
    STR     R6,[R1]        ;store
    MOV     ip,#" "
lp2 SUBS    R7,R7,#1
    STRGEB  ip,[R2],#1     ;fill WORD with blanks
    BGT     lp2
    LDMDB   fp,{R4-R7,fp,sp,pc} ;return
lp3 SUBS    R7,R7,#1       ;decrement WORD byte count
    STRGEB  ip,[R2],#1     ;store byte in WORD if room
    SUBS    R6,R6,#1       ;count down bytes in string
    BLT     pt1            ;STRING is empty
    LDRB    ip,[R0],#1     ;get byte of STRING
    CMP     ip,#sep        ;check for separator
    BNE     lp3
    B       pt1            ;found separator
    END
;
    TTL    osbyte
pc  RN     15
lr  RN     14
sp  RN     13
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
OS_Byte EQU   &06
    AREA   |C$$code|,CODE,READONLY
    EXPORT osbyte_         ;(IFUNC,IARG1,IARG2)
osbyte_
    LDR    R0,[R0]
    LDR    R1,[R1]
    LDR    R2,[R2]
    SWI    OS_Byte
    MOV    pc,lr
;
    EXPORT osbyte1_        ;(IFUNC,IARG1,IARG2,IRES1)
osbyte1_
    LDR    R0,[R0]
    LDR    R1,[R1]
    LDR    R2,[R2]
    SWI    OS_Byte
    STR    R1,[R3]
    MOV    pc,lr
;
    EXPORT osbyte2_        ;(IFUNC,IARG1,IARG2,IRES1,IRES3)
osbyte2_
    LDR    R0,[R0]
    LDR    R1,[R1]
    LDR    R2,[R2]
    SWI    OS_Byte
    STR    R1,[R3]
    LDR    R0,[sp]
    STR    R2,[R0]
    MOV    pc,lr
    END
;
    TTL    oscli
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
XOS_CLI EQU   &20005
    AREA   |C$$code|,CODE,READONLY
    IMPORT  __rt_stkovf_split_big
    EXPORT oscli_          ;(TEXT)
    EXPORT e_ptr
    DCB    "oscli_",0,0,8,0,0,255
oscli_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUB    sp,sp,R1
    SUB    sp,sp,#1
    BIC    sp,sp,#3        ;space for null-terminated argument
    CMP     ip,sl
    BLLT    __rt_stkovf_split_big
    MOV    R2,sp
l1  LDRB   R3,[R0],#1      ;move command string
    STRB   R3,[R2],#1      ;to local area
    SUBS   R1,R1,#1
    BGT    l1
    STRB   R1,[R2],#1
    MOV    R0,sp
    SWI    XOS_CLI         ;call OSCLI
    LDR    R1,e_ptr
    STRVS  R0,[R1]         ;store error pointer
    MOVVS  R0,#0           ;fail = .FALSE.
    MOVVC  R0,#1           ;good = .TRUE.
    STRVC  R0,[R1]         ;flag no error
    LDMDB  fp,{fp,sp,pc}   ;return
e_ptr DCD    err
;
    EXPORT osgeterror_     ;(IERR,ERRMSG)
    DCB    "osgeterror_",0,12,0,0,255
osgeterror_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,e_ptr
    LDR    R3,[R3]         ;pointer to error message
    SUBS   ip,R3,#1        ;check for no error
    LDRNE  ip,[R3],#4      ;error number
    LDREQ  R3,e_ptr
    STR    ip,[R0]         ;store IERR
l2  LDRB   ip,[R3]
    CMP    ip,#31
    ADDGT  R3,R3,#1
    MOVLE  ip,#" "
    STRB   ip,[R1],#1
    SUBS   R2,R2,#1
    BGT    l2
    LDMDB  fp,{fp,sp,pc}   ;return
    AREA   |C$$data|,DATA
err DCD    1
    END
;
    TTL    osword
pc  RN     15
lr  RN     14
R0  RN     0
OS_Word EQU   &07
    AREA   |C$$code|,CODE,READONLY
    EXPORT osword_         ;(ICODE,IARRAY)
osword_
    LDR    R0,[R0]
    SWI    OS_Word
    MOV    pc,lr
    END
;
     TTL   prinfo
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
F0 FN  0
PDriver_Info           EQU &A0140
     AREA  |C$$code|,CODE,READONLY
     EXPORT prinfo_;(TYPE,VERS,NAME,IXDPI,IYDPI,IXTONE,IYTONE,JFEAT)
;      returns: TYPE (CHARACTER)
;               VERS, the printer driver version (-1.0 if no printer driver)
;               NAME, (CHARACTER*(<21)) name of driver
;               (IXDPI,IYDPI), resolution in DPI
;               (IXTONE,IYTONE), half-tone resolution /inch
;               JFEAT, printer features bits (p 3-306)
     DCB    "prinfo_",0,8,0,0,255
;
prinfo_
     MOV    ip,sp
     STMDB  sp!,{R0-R9,fp,ip,lr,pc}
     SUB    fp,ip,#4
     SWI    PDriver_Info
     LDMIA  sp,{R8,R9}  ;addresses of TYPE,VERS
     MNFVSS F0,#1       ;vers=-1.0 if no printer driver
     MOVVC  ip,R0,LSR#16;type word
     BICVC  R0,R0,ip,LSL#16;version number
     FLTVCS F0,R0
     FDVVCS F0,F0,#10
     FDVVCS F0,F0,#10
     STFS   F0,[R9]     ;store VERS
     LDMVSDB fp,{R4-R9,fp,sp,pc} ;return on error
     CMP    ip,#99
     MOVEQ  ip,#npr+2
     CMPNE  ip,#npr
     MOVGT  ip,#npr+1
     ADR    R0,types
     CMP    ip,#0
     BLE    pt1
lp1  LDRB   lr,[R0],#1
     CMP    lr,#0
     BGT    lp1
     SUBS   ip,ip,#1
     BGT    lp1
pt1  LDR    R9,[fp,#20] ;length of TYPE
lp2  LDRB   lr,[R0],#1
     CMP    lr,#31
     STRGTB lr,[R8],#1
     SUBGTS R9,R9,#1
     BGT    lp2
     MOV    lr,#" "
lp3  SUBS   R9,R9,#1
     STRGEB lr,[R8],#1
     BGT    lp3
     LDR    R0,[sp,#12] ;address of IXDPI
     STR    R1,[R0]     ;store IXDPI
     LDMIB  fp,{R0,R1,R8,R9};addresses of IYDPI,IXTONE,IYTONE,JFEAT
     STR    R2,[R0]     ;store IYDPI
     STR    R5,[R1]     ;store IXTONE
     STR    R6,[R8]     ;store IYTONE
     STR    R3,[R9]     ;store JFEAT
     LDR    R0,[sp,#8]  ;(NAME)
     LDR    R9,[fp,#24] ;length of name
lp4  LDRB   lr,[R4],#1
     CMP    lr,#0
     STRGTB lr,[R0],#1
     SUBGTS R9,R9,#1
     BGT    lp4
     MOV    lr,#" "
lp5  SUBS   R9,R9,#1
     STRGEB lr,[R0],#1
     BGT    lp5
     LDMDB  fp,{R4-R9,fp,sp,pc} ;return
npr  EQU    7
types;  printer driver types each null terminated
     DCB    "PostScript",0                 ;0
     DCB    "Epson FX80",0                 ;1
     DCB    "HP LaserJet",0                ;2
     DCB    "Integrex ColourJet",0         ;3
     DCB    "FAX modem",0                  ;4
     DCB    "Direct drive laser printer",0 ;5
     DCB    "Caspel graphics language",0   ;6
     DCB    "PDumper interface",0          ;7 = npr
     DCB    "Unknown",0                    ;8
     DCB    "Ace Computing Epson JX/Star LC10 or PaintJet",0   ;99
     END
;
     TTL   printer
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
F0 FN  0
F4 FN  4
F5 FN  5
F6 FN  6
F7 FN  7
Hourglass_On           EQU &606C0
Hourglass_Off          EQU &606C1
OS_Find                EQU &2000D
PDriver_CheckFeatures  EQU &A0142
PDriver_PageSize       EQU &A0143
PDriver_SelectJob      EQU &80145
PDriver_EndJob         EQU &A0148
PDriver_GiveRectangle  EQU &8014B
PDriver_DrawPage       EQU &A014C
PDriver_GetRectangle   EQU &A014D
PDriver_DeclareFont    EQU &A0155
     AREA  |C$$code|,CODE,READONLY
;
     IMPORT __rt_sdiv; R0 = R1/R0  (and R1=|remainder|)
     EXPORT propen_;(JOBNAM,ORIENT,SCALE,IERR)
;      starts a print job with name JOBNAM (may be ' ')
;      ORIENT = 'P' or 'L'
;      SCALE scales the output from OS-units
;      IERR returned 0 if OK
;      =1 if no printer driver
;      =2 if ORIENT is neither P nor L
;      =3 printer is already open
     DCB    "propen_",0,8,0,0,255
propen_
     MOV    ip,sp
     STMDB  sp!,{R0-R8,fp,ip,lr,pc}
     SUB    fp,ip,#4
     LDR    R8,ptrh
     LDR    R0,[R8],#4
     CMP    R0,#0
     MOVNE  R0,#3
     BNE    ret         ;file already opened
     LDR    R3,[fp,#8] ;length of ORIENT
     LDRB   R7,[R1]     ;ORIENT
     CMP    R7,#"a"
     SUBGE  R7,R7,#32   ;convert to upper case
     CMP    R7,#"L"
     CMPNE  R7,#"P"
     CMPEQ  R3,#1
     MOVNE  R0,#2
     BNE    ret         ;ORIENT is neither P nor L
     SWI    PDriver_PageSize
     MOVVS  R0,#1
     BVS    ret         ;no printer driver
     CMP    R7,#"P"
     STMEQIA R8!,{R3,R4}; portrait origin
     STMNEIA R8!,{R3,R6}; landscape origin
     STMEQIA R8!,{R3-R6}; portrait print area
     STRNE   R4,[R8],#4;  landscape print area
     STMNEIA R8!,{R3,R6}
     STRNE   R5,[R8],#4
;        now get the transform
     LDR    R1,[sp,#8]
     LDR    R1,[R1]     ;scale (1.0 => &3F800000)
     MOV    R1,R1,LSL#1 ;remove sign
     MOV    R3,R1,LSR#24;exponent
     BIC    R1,R1,#&FF,8;mantissa
     ORR    R1,R1,#&01,8;restore m.s. bit
     RSBS   R3,R3,#135  ;right shift
     RSBLT  R3,R3,#0
     MOVGE  R1,R1,LSR R3;set magnitude so 1.0 => &00010000
     MOVLT  R1,R1,LSL R3
     CMP    R7,#"P"
     MOV    R2,#0
     MOV    R3,#0
     MOV    R4,R1
     STMEQIA R8!,{R1-R4};store Portrait transform (1,0,0,1)
     RSBNE  R3,R1,#0
     STMNEIA R8!,{R2-R4};store Landscape transform (0,-1,1,0)
     STRNE  R2,[R8],#4
;         scale the rectangle
     ADD    R6,R1,R1,LSL#2
     ADD    R6,R6,R6,LSL#2
     MOV    R6,R6,LSR#4   ;scale*102400
     MOV    R5,#-32       ;# coordinates to transform
lp3  LDR    R1,[R8,R5]
     MOV    R1,R1,LSL#8   ;coordinate*256
     MOV    R0,R6
*     MOV    R0,#400
     BL     __rt_sdiv    ;get coordinate/400
     STR    R0,[R8,R5]    ;store print rectangle in OS-units
     ADD    R5,R5,#4
     CMP    R5,#-16
     BLT    lp3
;        open printer stream
     MOV    R0,#&83
     ADR    R1,pfil
     SWI    OS_Find     ;try to open stream
     MOVVS  R0,#0
     CMP    R0,#0
     MOVEQ  R0,#3
     BEQ    ret         ;can't open file
     STR    R0,[R8,#-44];store file handle
;        get job name
     MOV    R1,#0
     LDR    R3,[sp]     ;address of JOBNAM
     LDR    R2,[fp,#4]  ;length of JOBNAM
     CMP    R2,#19
     MOVGT  R2,#19      ;limit length of job name
lp4  LDRB   lr,[R3],#1
     STRB   lr,[R8,R1]
     ADD    R1,R1,#1
     SUBS   R2,R2,#1
     BGT    lp4
     STRB   R2,[R8,R1]  ;null terminate
     STR    R2,[R8,#20] ;zero the loop flag
     ADD    R1,R1,lr
     SUBS   R1,R1,#" "+1;R1=0 if null name
     MOVNE  R1,R8       ;else R1 points to name
;        start print job
     SWI    PDriver_SelectJob
;        do we need to send fonts?
     MOV    R0,#&2,4    ;bit 29 for DeclareFont support
     MOV    R1,R0
     SWI    PDriver_CheckFeatures
     BVS    ret         ;fonts not supported
     LDR    R3,ptrs
     LDR    R4,[R3]     ;#fonts
     MOV    R1,#0       ;send handle, not font name
     MOV    R2,#0
     CMP    R4,#0
lp5  LDRGT  R0,[R3,R4,LSL#2];get font handle
     MOVLE  R0,#0       ;or zero to terminate
     SWI    PDriver_DeclareFont
     SUBS   R4,R4,#1
     BGE    lp5
ret  LDR    R4,[sp,#12] ;address of IERR
     STR    R0,[R4]     ;store IERR
     LDMDB  fp,{R4-R8,fp,sp,pc} ;return
ptrs DCD    font_handles;pointer to font handles
ptrh DCD    hand        ;pointer to handle
pfil DCB    "printer:",0
     ALIGN
;
     EXPORT prpbeg_;(NCOPY,BGCOLR,IXY,IERR) starts print PRPBEG
;      NCOPY  = # copies to print
;      BGCOLR = background colour BBGGRRxx
;      IXY    = returned graphics window
;      IERR   = returned error
     DCB    "prpbeg_",0,8,0,0,255
prpbeg_
     MOV    ip,sp
     STMDB  sp!,{R0-R3,R4,fp,ip,lr,pc}
     LDR   R3,ptrf
     LDR   R2,[R3],#4  ;flag
     STFE  F4,[R3],#12  ;save floating registers
     STFE  F5,[R3],#12
     STFE  F6,[R3],#12
     STFE  F7,[R3],#12
     STMIA R3,{R4-R9,sl,fp,ip,lr};save 10 important integer registers
     SUB   fp,ip,#4
     CMP   R2,#0        ;get flag should be 0
     MOVNE R0,#1
     BNE   errb
     LDR   R2,[R3,#-sep-52];get file handle
     CMP   R2,#0        ;return error if it is zero
     MOVEQ R0,#2
     BEQ   errb
     LDR   R2,[sp,#8]   ; (IXY)
     STR   R2,[R3,#-52]   ;store flag=(IXY)

;        set print area, transform, origin, background
     MOV    R0,#1
     SUB    R1,R3,#104  ;rectangle
     SUB    R2,R3,#88   ;transform
     SUB    R3,R3,#112  ;origin
     LDR    R4,[sp,#4]  ;pointer to BGCOLR
     LDR    R4,[R4]     ;BGCOLR
     BIC    R4,R4,#&FF
     SWI    PDriver_GiveRectangle
     LDR    R0,[sp]
     LDR    R0,[R0]     ;# copies
     LDR    R1,ptrf
     LDR    R1,[R1]     ;pointer to IXY
     MOV    R2,#0
     MOV    R3,#0
     SWI    PDriver_DrawPage
;         print page started so return to await call to PRPEND
     MOV    R0,#0
errb LDR    R3,[sp,#12]  ;(IERR)
     STR    R0,[R3]      ;IERR
     LDMDB  fp,{R4,fp,sp,pc} ;return
ptrf DCD    frm         ;pointer to frame
;
     EXPORT prpend_; called when finished printing page
     DCB    "prpend_",0,8,0,0,255
prpend_
     MOV    ip,sp
     STMDB  sp!,{fp,ip,lr,pc}
     SUB    fp,ip,#4
     LDR    R3,ptrf     ;pointer to frame
     LDR    R1,[R3],#4  ;get flag (should be non-zero)
     CMP    R1,#0
     BEQ    pe1
     LDR    R0,[R3,#-sep-4];get file handle
     CMP    R0,#0
     SWINE  PDriver_GetRectangle
     CMP    R0,#0       ;check if more is required
pe1  STREQ  R0,[R3,#-4]  ;zero the flag
     LDMEQDB fp,{fp,sp,pc} ;return if no more needed
;        restore frame as it was at call to PRPBEG
     LDFE   F4,[R3],#12 ;restore floating and integer registers
     LDFE   F5,[R3],#12
     LDFE   F6,[R3],#12
     LDFE   F7,[R3],#12
     LDMIA  R3,{R4-R9,sl,fp,sp,pc} ;returns as if from CALL PRPBEG
;
     EXPORT prclos_; called when finished printing altogether
     DCB    "prclos_",0,8,0,0,255
prclos_
     MOV    ip,sp
     STMDB  sp!,{fp,ip,lr,pc}
     SUB    fp,ip,#4
     LDR    R3,ptrh
     LDR    R0,[R3]     ;get file handle
     CMP    R0,#0
     LDMEQDB fp,{fp,sp,pc} ;return
     SWI    PDriver_EndJob;end the print job
     MOV    R0,#0
     LDR    R1,[R3]     ;get file handle
     STR    R0,[R3]     ;reset the file handle
     SWI    OS_Find     ;close the file
     LDMDB  fp,{fp,sp,pc} ;return
;
     AREA   print_handles,COMMON
hand %      4           ;file handle (initially 0)
     %      8           ;origin in millipoints
rect %      16          ;print limits in OS-units (=plot rectangle)
     %      16          ;transform
     %      20          ;jobname
frm  %      4           ;flag for being in PRBEG/PREND loop or (IXY)
     %      48          ;preserved fp registers
     %      40          ;preserved R4-R9,sl,fp,sp,lr
sep  EQU    frm-hand
;
     AREA   font_handles,COMMON  ; zeroed by the loader
     %      4           ;# font handles stored
     %      80          ;space for 20 font handles
     END
;
     TTL   prkill
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_Find                EQU &2000D
PDriver_AbortJob       EQU &A0149
;
     AREA   print_handles,COMMON
hand %      4           ;file handle (initially 0)
     %      8           ;origin in millipoints
rect %      16          ;print limits in OS-units (=plot rectangle)
     %      16          ;transform
     %      20          ;jobname
frm  %      4           ;flag for being in PRBEG/PREND loop
     %      48          ;preserved fp registers
     %      40          ;preserved R0,R4-R9,fp,sp,lr
sep  EQU    frm-hand
;
     AREA  |C$$code|,CODE,READONLY
;
     EXPORT prkill_; to kill off current print job
;
     DCB    "prkill_",0,8,0,0,255
prkill_
     MOV    ip,sp
     STMDB  sp!,{fp,ip,lr,pc}
     SUB    fp,ip,#4
     LDR    R3,ptrh
     LDR    R0,[R3]
     CMP    R0,#0         ;check printer handle
     LDMEQDB fp,{fp,sp,pc} ;return if none
     SWI    PDriver_AbortJob
     LDR    R1,[R3]
     MOV    R0,#0
     STR    R0,[R3]       ;reset printer handle
     SWI    OS_Find
     LDMDB  fp,{fp,sp,pc} ;return if not
ptrh DCD    hand      ;pointer to handle
     END
;
      TTL   prsize
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
PDriver_PageSize       EQU &A0143
     AREA  |C$$code|,CODE,READONLY
;
     IMPORT __rt_sdiv; R0 = R1/R0  (and R1=|remainder|)
     EXPORT prsize_;(IPSIZE(2),IPAREA(2,2))
;         returns the page size in OS units
;         the printable area in OS units
     DCB    "prsize_",0,8,0,0,255
prsize_
     MOV    ip,sp
     STMDB  sp!,{R0-R6,fp,ip,lr,pc}
     SUB    fp,ip,#4
     SWI    PDriver_PageSize
     BVS    err
     STMDB  sp!,{R1-R6}
     MOV    R5,#5
lp1  LDR    R1,[sp,R5,LSL#2]
     MOV    R0,#400
     BL     __rt_sdiv   ;convert all numbers to OS units
     STR    R0,[sp,R5,LSL#2]
     SUBS   R5,R5,#1
     BGE    lp1
     LDMIA  sp,{R1-R6,ip,lr}
     STMIA  ip,{R1,R2}   ;store IPSIZE
     LDR    R2,ptrh
     LDR    R1,[R2],#12  ;file handle: =0 if not printing
     CMP    R1,#0
     LDMNEIA R2,{R3-R6}  ;load (possibly) transformed area
     STMIA  lr,{R3-R6}   ;store IPAREA
     LDMDB  fp,{R4-R6,fp,sp,pc} ;return
;        error finding printer driver
err  MOV    R1,#-1
     MOV    R2,#-1
     LDR    ip,[sp]
     STMIA  ip,{R1,R2}   ;store -1,-1 in IPSIZE
     LDMDB  fp,{R4-R6,fp,sp,pc} ;return
ptrh DCD    hand        ;pointer to handle
;
     AREA   print_handles,COMMON
hand %      4           ;file handle (initially 0)
     %      8           ;origin in millipoints
rect %      16          ;print limits in OS-units (=plot rectangle)
     %      16          ;transform
     %      20          ;jobname
frm  %      4           ;flag for being in PRBEG/PREND loop
     %      48          ;preserved fp registers
     %      40          ;preserved R0,R4-R9,fp,sp,lr
sep  EQU    frm-hand
     END
;
    TTL   rspace
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
    AREA   |C$$code|,CODE,READONLY
    EXPORT rspace_         ;(SUB,NWD [,a,b])
    IMPORT __rt_stkovf_split_big
    DCB    "rspace_",0,8,0,0,255
rspace_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R4,[R1]         ;space needed
    ADD    R4,R4,#128      ;allow 512 bytes stack for called program  14/12/00
    SUB    ip,sp,R4,LSL#2  ;bottom of stack to request
    CMP    ip,sl
    BLLT   __rt_stkovf_split_big
    SUB    sp,sp,R4,LSL#2  ;reserve space
    MOV    R0,sp           ;point to it
    LDR    ip,[fp,#-32]    ;CALL SUB(ARRAY,NWD [,a,b])
    LDMDB  fp,{R4,fp,sp,lr};reset stack
    MOV    pc,ip    ;CALL SUB(ARRAY,NWD [,a,b])
    END
;
    TTL   SOUND
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
Sound_AttachVoice EQU &40185
Sound_Control EQU &40189
Sound_Enable EQU &40141
Sound_InstallVoice EQU &40183
Sound_ReadControlBlock EQU &4018B
Sound_Speaker EQU &40143
Sound_Stereo EQU &40142
    AREA   |C$$code|,CODE,READONLY
    EXPORT sound_          ;(IAMPL,IPITCH,LENGTH)
    EXPORT voice_          ;(IVOICE,ISTERE)
    DCB    "sound_",0,0,8,0,0,255
sound_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc};save arguments
    SUB    fp,ip,#4
    MOV    R0,#1
    MOV    R1,#0
w1  SWI    Sound_ReadControlBlock
    TST    R2,#&FF000000
    BNE    w1
    LDMFD  sp,{R0-R2}
    LDR    R3,[R2]         ;LENGTH
    CMP    R3,#1
    MOVLT  R3,#1           ;make >=1
    CMP    R3,#254
    MOVGT  R3,#254         ;make <=254
    LDR    R2,[R1]         ;IPITCH
    ADDS   R2,R2,#48
    MOVLE  R2,#1           ;make >=-47
    CMP    R2,#95
    MOVGT  R2,#95          ;make <=47
    MOV    R1,#0
ll  SUBS   R2,R2,#12
    ADDGE  R1,R1,#&1000    ;count octaves
    BGE    ll
    ADR    ip,tb+48
    LDR    R2,[ip,R2,LSL#2];get semitones
    ADD    R2,R2,R1
    LDR    R1,[R0]         ;IAMPL
    CMP    R1,#0
    MOVLT  R1,#0           ;make >=0
    CMP    R1,#127
    MOVGT  R1,#127         ;make <=127
    ADD    R1,R1,#&100
    MOV    R0,#1           ;channel 1
    SWI    Sound_Control
    LDMDB  fp,{fp,sp,pc} 
tb  DCD    &000,&155,&2AB
    DCD    &400,&555,&6AB
    DCD    &800,&955,&AAB
    DCD    &C00,&D55,&EAB
;
    DCB    "voice_",0,0,8,0,0,255
voice_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc};save arguments
    SUB    fp,ip,#4
    MOV    R0,#1
    MOV    R1,#0
w2  SWI    Sound_ReadControlBlock
    TST    R2,#&FF000000
    BNE    w2
    LDR    ip,pt
    LDR    R3,[ip]         ;read standard voice etc.
    CMP    R3,#-1
    BNE    vc1              ;already set up
    MOV    R0,#1
    MOV    R1,#0
    SWI    Sound_AttachVoice
    MOV    R3,R1           ;old voice
    MOV    R1,#-128
    SWI    Sound_Stereo
    ADD    R1,R1,#128
    ORR    R3,R3,R1,LSL#8  ;old stereo
    MOV    R0,#2
    SWI    Sound_Enable    ;turn on audio
    ORR    R3,R3,R0,LSL#24 ;old audio
    STR    R3,[ip]         ;save old values
vc1 LDMFD  sp,{R0,R1}      ;restore arguments
    LDR    R0,[R0]         ;IVOICE
    CMP    R0,#0
    BLT    vc2             ;reset values
    LDR    R2,[R1]         ;ISTERE
    MOV    R1,R0
    MOV    R0,#0
    SWI    Sound_InstallVoice;check voice exists
    CMP    R0,#0
    MOVNE  R0,#1           ;if so, attach to channel 1
    SWINE  Sound_AttachVoice
    MOV    R1,R2           ;ISTERE
    CMP    R1,#-127
    MOVLT  R1,#-127        ;make >=-127
    CMP    R1,#127
    MOVGT  R1,#127         ;make <=127
    MOV    R0,#1           ;channel 1
    SWI    Sound_Stereo    ;set stereo
    LDMDB  fp,{fp,sp,pc} 
vc2; restore old state
    AND    R1,R3,#63       ;voice
    MOV    R0,#1
    SWI    Sound_AttachVoice
    MOV    R1,R3,LSR#8
    AND    R1,R1,#255
    SUB    R1,R1,#128
    MOV    R0,#1
    SWI    Sound_Stereo    ;restore stereo
    CMP    R3,#&2000000
    MOVGT  R0,#2           ;audio on
    MOVLE  R0,#1           ;or audio off
    SWI    Sound_Enable
    MOV    R3,#-1
    STR    R3,[ip]         ;reinitialise
    LDMDB  fp,{fp,sp,pc} 
pt  DCD    vc
    AREA   VOICE_DATA,DATA
vc  DCD    -1              ;original voice, stereo, speaker, audio
    END
;
    TTL    TRACEP
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT tracep_         ;(N,NAME,LB,LC) name, (start) and (call) of Nth trace
    DCB    "tracep_",0,8,0,0,255
tracep_
    MOV    ip,sp
    STMDB  sp!,{R4-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R4,[fp,#4]      ;length of NAME
    LDR    R0,[R0]         ;N
    MOV    R5,fp           ;current frame pointer
lp1 LDR    R6,[R5]         ;program counter at entry
    BIC    R6,R6,#255,6    ;clear non-PSR bits
lp2 LDR    ip,[R6,#-4]!
    AND    lr,ip,#255,8
    CMP    lr,#255,8
    BNE    lp2             ;search for introduction
    AND    ip,ip,#&FC
    SUB    R6,R6,ip        ;beginning of introduction
    LDR    ip,[R5,#-4]
    BIC    ip,ip,#255,6    ;clear all but pc
    CMP    ip,#&31,14
    LDRGE  R5,[R5,#-12]    ;next frame pointer
    SUBS   R0,R0,#1
    BLT    pt1             ;found entry
    LDR    ip,[R6]         ;get beginning of name
    LDR    lr,man
    SUBS   lr,lr,ip
    LDRNE  R5,[R5,#-12]    ;next frame pointer
    BNE    lp1
    STR    lr,[R2]         ;flag 'end of trace'
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
pt1; found required entry
    STR    R6,[R2]         ;store location of beginning
    LDR    ip,[R5,#-4]
    SUB    ip,ip,#4
    BIC    ip,ip,#255,6    ;clear all but pc
    STR    ip,[R3]         ;store where called from
lp3 LDRB   lr,[R6],#1
    CMP    lr,#"a"
    SUBGE  lr,lr,#32
    CMP    lr,#0
    CMPNE  lr,#"_"
    STRNEB lr,[R1],#1      ;transfer name
    SUBNES R4,R4,#1
    BNE    lp3
    MOV    lr,#" "
lp4 SUBS   R4,R4,#1
    STRGEB lr,[R1],#1      ;blank fill
    BGT    lp4
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
man DCB   "main"
    END
;
    TTL    UT_GetF
pc  RN     15
lr  RN     14
R5  RN     5
R4  RN     4
R1  RN     1
R0  RN     0
XOS_File EQU &20008
    AREA   |C$$code|,CODE,READONLY
    IMPORT e_ptr
    EXPORT UT_GetF         ;gets file info in R2-R5 from name/length in R4,R5
; returns status=R0= -1: not found, 0: file, 1: directory
; R1 pointer to null terminated name
; R2 = load address       :FFFtttdd  ) ttt = type
; R3 = exec address       :dddddddd  ) dddddddddd = time/date
; R4 = length
; R5 = attributes         :..wrL.WR  (bits)
UT_GetF
    LDR    R1,ptr          ;pointer to space for name
    CMP    R5,#255
    MOVGT  R5,#255         ;limit name length to 255
    MOV    R0,#0
lp1 STRB   R0,[R1,R5]
    SUBS   R5,R5,#1
    LDRGEB R0,[R4,R5]
    BGE    lp1
    MOV    R0,#17
    SWI    XOS_File
    LDRVS  ip,e_ptr
    STRVS  R0,[ip]         ;store error pointer
    MOVVS  R0,#0
    SUBS   R0,R0,#1
    MOV    pc,lr           ;return with status
ptr DCD    text
    AREA   Utils_DATA,DATA,COMMON,NOINIT
text %      256
    END
