;     Fortran Friends 2018
;    latest fixes
;
;  remove trailing blanks from vdu output  (sb7)                04/07/2021
;  added io_do_rsne  (read namelist)                            21/12/2020
;  added io_do_wsne  (write namelist)                           06/12/2020
;  added h_bits and h_shftc                                     05/09/2020
;  augmented I/O error 42 text                                  10/05/2020
;  correction to backspace, endfile & rewind                    19/03/2020
;  corrections to io_endfile                                    30/11/2019
;  added entries for _mvbits, i_shftc & i_bits                  25/03/2019
;  added dummy setbuf                                           03/02/2019
;  qsort routines moved in from utiliyies                       03/02/2019
;  separated the functions in btest etc.                        28/01/2018
;  wimpprint "MAIN" renamed "main"  and "s_st" as "_sto"        27/06/2018
;  s_paus renamed _pause                                        24/06/2018
;  add ROOL's kernel functions                                  08/04/2018
;  io_do_singl   correct sign on byte output                    28/11/2017
;  io_err_chk    new for 32-bit compiler                        18/10/2017
;  divide      new enty points for 32-bit compiler              17/10/2017
;  main   new enty points for 32-bit compiler                   28/11/2017
;  divide entry __rt_sdiv10                                     02/12/2017
;
      TTL   main
pc RN 15
lr RN 14
sp RN 13
ip RN 12
fp RN 11
sl RN 10
R9 RN  9
R8 RN  8
R7 RN  7
R6 RN  6
R5 RN  5
R4 RN  4
R3 RN  3
R2 RN  2
R1 RN  1
R0 RN  0
XOS_Args   EQU &20009
XOS_File   EQU &20008
XOS_BPut   EQU &2000B
XOS_Find   EQU &2000D
XFont_LoseFont EQU &60082
XWimp_SlotSize EQU &600EC
XOS_SpriteOp   EQU &2002E
OS_WriteS  EQU &01
OS_Write0  EQU &02
OS_GetEnv  EQU &10
OS_Exit    EQU &11
OS_ChangeEnvironment  EQU &40
PDriver_AbortJob      EQU &A0149
Load_Address  EQU &8000  ;standard load address
buf_len    EQU 512
lregs      EQU 4*3*4     ;space necessary to store 4 registers for 3 handlers
stackx     EQU &210      ;spare space below stack limit
minstack   EQU &800+stackx;minimum length for stack
;
     AREA  |Main$$data|,DATA,NOINIT
    %     8              ;top and bottom of reserved memory (initially 0)
hregs
    %     4              ;end of memory
    %     lregs          ;space for old handler data
    %     256            ;error handler buffer
;
    AREA   |IO$$data|,DATA,NOINIT
    EXPORT buffer_io
       GET s.MaxFl
buffer_io
    %      max_fl*8      ;status of I/O units 1 to max_fl
    %      24            ;I/O status words
    %      buf_len       ;formatted buffer
    %      8             ;space for problems
    %      4             ;escape status during I/O
;
    AREA   |SpOp_state|,COMMON
    %      4; flags redirection of VDU O/P to sprite or mask
;
    AREA   font_handles,COMMON  ; zeroed by the loader
    %      4        ;# font handles stored
    %      80       ;space for 20 font handles
;
    AREA   print_handles,COMMON
    %      4         ;file handle (initially 0)
;
    AREA   DW_common,COMMON
    %      4         ;draw file handle (initially 0)
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT __rt_stkovf_split_big
    EXPORT __rt_stkovf_split_small
    EXPORT fortran_exit;(ierr)
    EXPORT io_close; (UNIT,*STATUS)
    EXPORT key_word;
    EXPORT get_stack
    EXPORT change_memory
    EXPORT __rt_io_init    
    EXPORT __rt_io_final
    EXPORT __main
    IMPORT wimpprint
    IMPORT main
;
;        * * * * * *  Fortran program flow * * * * * * *
;
;              code starts here
    ENTRY
    SWI   OS_GetEnv
    MOV   sp,R1          ;initialise stack
    MOV   fp,#0          ;initial frame does not exist
;         find space available for stack
    MOV   R2,#8
    MOV   R1,#Load_Address
    ADD   sl,R1,#stackx
lm1 LDR   R0,[R1,R2,LSL#2]
    ADD   sl,sl,R0
    SUB   R2,R2,#1
    CMP   R2,#4
    BGT   lm1
    LDR   R4,hrg         ;pointer to local storage for error handlers
    STR   sp,[R4]        ;store top of stack = end of memory
    SUB   R0,sp,sl       ;useable stack length
    RSBS  R5,R0,#&800    ;check stack is big enough to start
    BLE   lm2
    BL    change_memory  ;no, then ask for more
    LDR   sp,[R4]        ;and reset stack pointer
lm2 STR   fp,[sl,#4-stackx];bottom of old stack (0 = does not exist)
    STR   sp,[sl,#-stackx];top of stack
;
;         set up event handlers
;
;          error handler
    MOV   R0,#6
    ADR   R1,errh
    MOV   R2,#&100
    ADD   R3,R4,#lregs+4
    SWI   OS_ChangeEnvironment
    STMIB R4!,{R0-R3}    ;store old error handler
;          exit handler
    MOV   R0,#11
    ADR   R1,exih
    MOV   R2,#&100
    SWI   OS_ChangeEnvironment
    STMIB R4!,{R0-R3}    ;store old exit handler
;          UpCall handler
    MOV   R0,#16
    ADR   R1,upch
    MOV   R2,#&100
    SWI   OS_ChangeEnvironment
    STMIB R4!,{R0-R3}    ;store old UpCall handler
;
;          initialise io streams
;
    LDR    R0,ptr
    MOV    R2,#&400000   ;for interactive unit
    MOV    R3,#buf_len   ;buffer length for interactive unit
    ADD    R1,R0,#4*8    ;start of unit 5
    STMIA  R1!,{R2,R3}   ;initialize standard input unit 5
    ORR    R2,R2,#1,4    ;for interactive and write
    STMIA  R1,{R2,R3}    ;initialize standard output unit 6
    MOV    R2,#-256
    STR    R2,[R0,#max_fl*8] ;I/O inactive flag
;
;        call fortran main program
;
    BL     main
;
fortran_exit
    MOV    R9,R0         ;save error code
;        lose fonts
    LDR    R1,pfh
    LDR    R2,[R1],#4    ;# existing fonts
lp1 SUBS   R2,R2,#1
    LDRGE  R0,[R1,R2,LSL#2]
    SWIGE  XFont_LoseFont
    CMP    R2,#0
    BGT    lp1           ;loop over existing fonts
;        close draw file stream
    LDR    R0,pdf
    LDR    R1,[R0]       ;draw file handle
    CMP    R1,#0
    MOVNE  R0,#0
    SWINE  XOS_Find      ;close draw file
;        move O/P to screen from sprite
    LDR    R0,sps
    LDR    R3,[R0]
    CMP    R3,#0         ;check that output is to screen (not sprite)
    MOVNE  R3,#1
    MOVNE  R2,#0
    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    lx2
    SWI    PDriver_AbortJob;kill print job
    LDR    R1,[R3]
    MOV    R0,#0
    SWI    XOS_Find      ;close print stream
;       close any open files
lx2 LDR    R0,ptr
    MOV    R1,#-256
    STR    R1,[R0,#max_fl*8] ;set inactive flag
    MOV    R0,#max_fl
lp2 MOV    R1,#0
    BL     io_close      ;close all files
    SUBS   R0,R1,#1      ;io_close returns R0 in R1
    BGT    lp2
;        Fortran has finished
    B      oldhandx      ;restore old handlers and exit
;
__main
__rt_io_init
__rt_io_final
      MOV pc,lr          ; unneeded entries called by new compiler
;
ptr DCD    buffer_io
;
;                 * * * * event handlers * * * *
;
sps DCD    |SpOp_state|
pdf DCD    DW_common
pfh DCD    font_handles
prh DCD    print_handles
tst DCD    buffer_io+8*max_fl+24+buf_len+8 ; space for emergency stack
errh;    the error handler
    LDR    sp,tst        ;set up new stack in case old one is corrupted
    LDR    R4,hrg        ;pointer to old handler registers
    LDR    lr,[R4]       ;end of memory
    CMP    lr,#0
    BLE    errp          ;problem in that we have been here before
    MOV    R2,#0
    STR    R2,[R4]       ;flag that we have been through error handler
    LDR    R0,sps
    LDR    R3,[R0]
    CMP    R3,#0         ;check that output is to screen (not sprite)
    BEQ    er0
    MOV    R3,#1
    STR    R2,[R0]       ;reset flag so it is not done again
    MOV    R0,#60
    SWI    XOS_SpriteOp  ;force output to screen
er0 LDR    R3,prh
    LDR    R0,[R3]
    CMP    R0,#0         ;check that output is to screen (not printer)
    BEQ    er1
    SWI    PDriver_AbortJob;kill print job
    LDR    R1,[R3]
    MOV    R0,#0
    STR    R0,[R3]       ;reset print flag
    SWI    XOS_Find      ;close print stream
er1 ADD    R0,R4,#60     ;address of error text
    LDR    lr,[R4,#52]   ;pc value at error
    TEQ    pc,pc
    BICNE  lr,lr,#&FC000003  ;remove status bits
    LDR    R2,[lr,#-4]!  ;get instruction with error (allowing for pipeline)
    LDR    R1,[R4,#56]   ;error number
    BIC    R1,R1,#&FF000000
    SUBS   R1,R1,#&200
    RSBGES ip,R1,#4
    ANDGE  R3,R2,#&0F000000
    CMPGE  R3,#&0E000000
    ANDEQ  R3,R2,#&F00
    CMPEQ  R3,#&100
    BNE    wimpprint     ;not floating data processing instruction
    TST    R2,#&10       ;test for compare
    ADRNE  R1,cmp
    BNE    eh1
    AND    R3,R2,#&F00000
    AND    R2,R2,#&8000
    MOV    R2,R2,LSR#11
    ORR    R2,R2,R3,LSR#20;form instruction 5-bit code
    ADR    R3,etable
    LDRB   R2,[R3,R2]    ;pointer to message
    CMP    R2,#dvf-erm
    CMPEQ  R1,#2
    BEQ    wimpprint     ;true divide by zero
    ADR    R3,erm
    ADD    R1,R2,R3      ;address of message
eh1 SUB    R3,R0,#1
eh2 LDRB   ip,[R3,#1]!
    CMP    ip,#0
    BNE    eh2           ;find end of message
    ADR    R2,emx        ;additional message
eh3 LDRB   ip,[R2],#1
    STRB   ip,[R3],#1
    CMP    ip,#0
    BNE    eh3
    B      wimpprint     ;print message and die (stack OK)
;
etable;   table of pointers to error messages
    DCB    adf-erm,muf-erm,suf-erm,suf-erm,dvf-erm,dvf-erm,pow-erm,pow-erm
    DCB    rem-erm,muf-erm,dvf-erm,dvf-erm,pol-erm,und-erm,und-erm,und-erm
    DCB    mvf-erm,mvf-erm,abs-erm,int-erm,sqr-erm,log-erm,lgn-erm,exp-erm
    DCB    sin-erm,cos-erm,tan-erm,asn-erm,acs-erm,atn-erm,nrm-erm,nrm-erm
erm;       error messages
adf DCB    "add",0
muf DCB    "multiply",0
suf DCB    "subtract",0
dvf DCB    "divide",0
pow DCB    "X**Y",0
rem DCB    "AMOD",0
pol DCB    "ATAN2",0
und DCB    "undefined",0
mvf DCB    "move",0
abs DCB    "ABS",0
int DCB    "INT",0
sqr DCB    "SQRT",0
log DCB    "LOG10",0
lgn DCB    "LOG",0
exp DCB    "EXP",0
sin DCB    "SIN",0
cos DCB    "COS",0
tan DCB    "TAN",0
asn DCB    "ASIN",0
acs DCB    "ACOS",0
atn DCB    "ATAN",0
nrm DCB    "normalise",0
cmp DCB    "compare",0
;
emx DCB    13,10,"caused by %s instruction",0
    ALIGN
hrg DCD    hregs
;
errp;    problem in error handler
    BLT    errd          ;total disaster
    MOV    R0,#-1
    STR    R0,[R4]       ;flag for second pass at error handling
    ADD    R0,R4,#60     ;address of error text
    SWI    OS_Write0
    SWI    OS_WriteS
    DCB    13,10,"Trap while error handling, close files and exit",13,10,0
    MOV    R0,#2
    B      fortran_exit
;
errd;         total disaster, can't close files
    SWI    OS_WriteS
    DCB    "Failed again...  files NOT CLOSED.",13,10,0
    MOV    R9,#16        ;return code 16!
    B      oldhandx
;
exih;    the exit handler
    MOV    R0,#0
    B      fortran_exit  ;just die
;
upch;    the upcall handler
    CMP    R0,#256
    MOVNE  pc,lr
    MOV    R9,#8
;
oldhandx;      restore old handlers and exit with code in R9
    LDR    R4,hrg        ;pointer to old handler registers
    MOV    ip,#3         ;# handlers to restore
lm3 LDMIB  R4!,{R0-R3}
    SWI    OS_ChangeEnvironment
    SUBS   ip,ip,#1
    BGT    lm3
    MOV    R0,#0
    MOVS   R2,R9         ;retrieve fortran return code
    MOVEQ  R1,#0         ;flag for no error
    LDRNE  R1,abx        ;flag for abend
    SWI    OS_Exit       ;exit
abx DCB    "ABEX"
;
;                 * * * * stack handling * * * *
;
__rt_stkovf_split_small;       called when sp<sl
    STMFD  sp!,{R0-R8,lr}
    MOV    R5,#minstack  ;required increment
    B      extend
;
__rt_stkovf_split_big;     called with ip as the required new stack limit
    STMFD  sp!,{R0-R8,lr}
    SUB    R5,sp,ip
    ADD    R5,R5,#minstack;required increment
    BIC    R5,R5,#3      ;ensure a round number of words
;
extend;  create new stack of size R5, first check we are in the right stack
    BL     get_stack     ;returns: sl, R6=top of stack, R2=top of memory
    SUB    R1,sp,sl      ;real current stack size
    CMP    R1,R5
    LDMGEFD sp!,{R0-R8,pc};skip decrease in stack
    ADD    R0,R5,R6      ;required end of stack address
    CMP    R7,sp         ;check if there is a reserved area above stack
    MOVLT  R8,R6         ; no, address for bottom of new stack
    BLT    ex1
    CMP    R7,R0         ;is there space below the reserved area
    ADDLT  R0,R5,R8      ; no, so look for space above the reserved area
    MOVLT  R6,R8         ; new bottom-of-stack
    BLT    ex1
    MOV    R2,R7         ; yes, new top-of-stack
    MOV    R8,R6         ; new bottom-of-stack
    B      ex2
ex1 SUBS   R5,R0,R2      ;check if enough
    BLE    ex2
    BL     change_memory ;no, then ask for more
;         set up new stack
    LDR    R2,[R4]       ;reload top-of-memory
ex2 STMIA  R6,{R2,sl}    ;store top-of-new & bottom-of-old stack
    ADD    sl,R8,#stackx ;new stack limit
    MOV    R0,sp         ;address of old stack to pick up return registers
    MOV    sp,R2         ;stack pointer = new top-of-stack
    LDMIA  R0,{R0-R8,pc};all done
;
get_stack;    get into the right stack
    CMP    sl,#0
    ADREQ  R0,sp1
    BEQ    wimpprint     ;failed
    SUB    R6,sl,#stackx ;real bottom of 'current' stack
    CMP    R6,sp         ;check it is the true current stack
    LDRGT  sl,[R6,#4]    ;previous stack limit
    BGT    get_stack
    LDR    R4,hrg
    LDR    R6,[R6]       ;top of current stack
    LDR    R2,[R4]       ;top of memory
    LDMDB  R4,{R7,R8}    ;reserved area
    MOV    pc,lr
;
change_memory;    change memory by R5 (returns R5 the actual amount changed)
;                 assumes hrg is in R4 and uses R0-R3
;        first increase Wimp Slot
    MOV    R0,#-1
    MOVS   R1,#-1        ;sets N flag
    SWI    XWimp_SlotSize;get current size
    BVS    cm1
    ADD    R0,R0,R5      ;required new size
    MOV    R3,R0         ;keep copy
    SWI    XWimp_SlotSize;extend current slot size
    BVS    cm1
    SUBS   R0,R0,R3      ;excess we have been granted (should clear N flag)
    BPL    cm2
cm1 ADR    R0,sp2
    B      wimpprint     ;failed
cm2 ADD    R5,R5,R0      ;use any extra we have been kindly given
    LDR    R0,[R4]       ;current top-of-memory
    ADD    R1,R0,R5      ;add the extension
    STR    R1,[R4]       ;store new top-of-memory
;        inform management of new upper limit
    MOV    R0,#0
    SWI    OS_ChangeEnvironment
    MOV    pc,lr
;
sp1 DCB    "System error in stack linking",0
sp2 DCB    "No more memory; try to make more space",0
;
;         * * * * * *  Fortran CLOSE * * * * * * *
;
m12 DCB    "Unknown close ACCESS for unit %d",0
m13 DCB    "Illegal unit to close: %d",0
m30 DCB    "Can not close unit %d while using I/O",0
m70 DCB    "Problem closing file on unit %d",0
    ALIGN
;
err;   error detected
    LDR    R1,[sp]       ;get unit
    TST    R1,#&80000000 ;test for ERR=
    LDMNEDB fp,{R4-R6,fp,sp,pc};return error code
    SUBS   R2,R0,#13
    ADRLT  R0,m12
    ADREQ  R0,m13
    CMPGE  R2,#17
    ADREQ  R0,m30
    ADRGT  R0,m70
    BL     wimpprint     ;print message
    LDMDB  fp,{R1,R4-R6,fp,sp,pc}; never gets here
;
    DCB    "io_close",0,0,0,0,12,0,0,255
io_close
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    ADDS   R0,R1,#0
    BEQ    ic1
    BL     key_word
    CMP    R0,#-1
    MOVGT  R0,#12        ;error 12: unknown access code
    BGT    err
ic1 MOV    R3,R0         ;save status code
    LDR    R0,[sp]       ;restore unit #
    LDR    R1,ptr
    LDR    lr,[R1,#8*max_fl]  ;get I/O status word
    CMP    lr,#-256
    MOVNE  R0,#30        ;error 30: recursive I/O
    BNE    err
    BIC    R0,R0,#15,4
    SUBS   R0,R0,#1
    RSBGES R4,R0,#max_fl-1
    MOVLT  R0,#13        ;error 13: illegal unit number
    BLT    err
    ADD    R4,R1,#8*max_fl+24  ;pointer to workspace
    LDR    R6,[R1,R0,LSL#3];get control word
    MOV    R5,#0
    STR    R5,[R1,R0,LSL#3];clear control word
    ANDS   R1,R6,#&FF
    BEQ    fin           ;file not open
    TST    R6,#&2000000  ;test for "printer" file
    MOVNE  R0,#10
    SWINE  XOS_BPut      ;then terminate last line
    AND    R0,R6,#&C000000;get OPEN status bits
    CMP    R3,#0         ;if no STATUS request,
    CMPEQ  R0,#&C000000
    MOVEQ  R3,#-1        ;flag SCRATCH files for deletion
    MOV    R0,#7         ;to get name from handle
    MOV    R2,R4         ;workspace
    MOV    R5,#512       ;length of workspace
    SWI    XOS_Args      ;Get file name ***** RISC-OS 3
                         ; returns R5= # bytes(+null) unused in buffer
    MOVVS  R4,#0         ;flag for no name
    MOV    R0,#0
    SWI    XOS_Find      ;close file
;    BVS    fin           ;can do no more
    MOVVS  R0,#70        ;error 70: problem closing file   04 Dec 2000
    BVS    err
    MOVS   R1,R4         ;pointer to name
    BEQ    fin           ;no name available
    TST    R6,#&1000000  ;test FORMATTED
    MOV    R2,#&1000
    SUBEQ  R2,R2,#1      ;text file (&FFF)
    SUBNE  R2,R2,#3      ;data file (&FFD)
    CMP    R3,#-1        ;check for DELETE
    MOVNE  R0,#18        ;for set type
    MOVEQ  R0,#6         ;for delete
    MVN    R6,R6         ;complement status          17/11/96
    TSTNE  R6,#&8000000  ;if set type, test for new  17/11/96
    SWIEQ  XOS_File      ;set type if new, or delete
fin MOV    R0,#0
    LDMDB  fp,{R1,R4-R6,fp,sp,pc};return OK
;
key_word
;        searches for an OPEN or CLOSE keyword
;        enters with pointer to keyword in R0
;        returns index in R0 (0 if not found)
;        R0=-1,-2 for CLOSE, +1 to +12 for OPEN keywords
    STR   lr,[sp,#-4]!
    ADR   lr,key         ;pointer to keywords
    MOV   R1,R0
    MOV   R0,#-2         ;keyword counter
lk1 SUB   R2,R1,#1       ;pointer to search string
lk2 LDRB  R3,[lr],#1     ;character from test keyword
lk3 LDRB  ip,[R2,#1]!    ;character from search string
    CMP   ip,#" "
    BEQ   lk3            ;skip blanks
    CMP   ip,#96
    SUBGT ip,ip,#32      ;convert to upper case
    CMP   ip,R3          ;check for agreement
    BNE   pt1
    CMP   ip,#0          ;check if word is complete
    BNE   lk2
    LDREQ pc,[sp],#4     ;return when found
pt1 CMP   R2,R1          ;check if first character
    CMPEQ R3,#0          ;and test character is zero
    MOVEQ R0,#0          ;then fail
    LDREQ pc,[sp],#4     ;return
    ADDS  R0,R0,#1
    ADDEQ R0,R0,#1       ;skip zero answer
lk4 CMP   R3,#0          ;find end of test string
    BEQ   lk1
    LDRB  R3,[lr],#1
    B     lk4
;                test keywords (must be upper case)
key DCB   "KEEP",0,"DELETE",0                        ;STATUS(CLOSE)
    DCB   "FORMATTED",0,"UNFORMATTED",0,"PRINTER",0  ;FORM
    DCB   "UNKNOWN",0,"OLD",0,"NEW",0,"SCRATCH",0    ;STATUS(OPEN)
    DCB   "SEQUENTIAL",0,"DIRECT",0,"APPEND",0       ;ACCESS
    DCB   "NULL",0,"ZERO",0,0                        ;BLANK
    END
;
    TTL    io_backspace
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R8  RN     8
R7  RN     7
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
XOS_Args   EQU &20009
XOS_GBPB   EQU &2000C
OS_Byte    EQU &6
buf_len    EQU 512
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT io_backspace; (UNIT)  write end-of-file
       GET s.MaxFl
    IMPORT buffer_io
    IMPORT wimpprint
    DCB    "io_backspace",0,0,0,0,16,0,0,255
;
io_backspace
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BIC    R4,R0,#15,4     ;extract unit number
    MOV    R0,#229
    MOV    R1,#0
    MOV    R2,#0
    SWI    OS_Byte         ;enable escape
    MOV    R6,R1           ;store old escape status
    CMP    R4,#0
    CMPNE  R4,#max_fl+1    ;check unit number
    MOVHS  R0,#5           ;error 5: illegal unit
    BGE    err
    LDR    R3,ptr
    LDR    ip,[R3,#8*max_fl+8]    ;status word
    CMP    ip,#-256
    BEQ    bs1
    LDR    ip,[R3,#8*max_fl+28]    ;unit in use
    CMP    ip,R4
    MOVEQ  R0,#30          ;error 30: unit already in use
    BEQ    err
bs1 LDR    R7,[R3,R4,LSL#3]!;status word
    TST    R7,#&20000000
    MOVNE  R0,#18          ;error 18: backspace direct access file
    BNE    err
    ANDS   R1,R7,#&FF      ; file unit
    BNE    pt1             ;open file
    TST    R7,#&400000     ;test for vdu
    TSTNE  R7,#&10000000
    MOVEQ  R0,#19          ;error 19: file not open
    BEQ    err
    SWI    &10B            ;VDU11 (vertical tab)
    B      fin
pt1 MOV    R0,#0
    SWI    XOS_Args        ;get current file pointer (R2)
    BVS    fin             ;should not happen!
    MOV    R5,R2           ;save file pointer
    SUBS   R4,R5,#2        ;skip last character
    BLT    pt2             ;rewind if no more than 1 byte read
    LDR    R8,buf          ;buffer pointer
    TST    R7,#&1000000    ;test for unformatted
    BNE    unf
lp1 MOV    R3,#1
    BL     read            ;check for escape
    LDRB   ip,[R8]
    CMP    ip,#32          ;for control character
    BLT    fin
    SUBS   R4,R4,#2
    BGE    lp1
pt2 MOV    R2,#0
    MOV    R0,#1
    SWI    XOS_Args        ;'rewind'
    B      fin
;
unf MOV    R4,#0           ;file pointer (start at beginning of file)
    STR    R4,[R8,#-2]     ;clear first word
    LDR    ip,uf
lp2 MOV    R3,#6
    BL     read            ;check for escape
    LDR    lr,[R8,#-2]
    CMP    lr,ip
    MOVNE  R0,#27          ;error 27: wrong header
    BNE    err
    LDR    lr,[R8,#2]      ;record length
    CMP    lr,#0           ;check for end-of-file
    ADDGT  R4,R4,lr        ;skip record body
    CMP    R4,R5
    BLT    lp2             ;loop until reached end
    CMP    lr,#0
    SUBGT  R4,R4,lr
    SUB    R2,R4,#6        ;file address of penultimate record
    MOV    R0,#1
    SWI    XOS_Args        ;set file pointer
;
fin;                 finished
    BL     restore         ;restore escape status
    MOV    R0,#0
    LDMDB  fp,{R4-R8,fp,sp,pc}
;
restore;      restore old escape status
    STMFD  sp!,{R0,lr}
    MOV    R0,#229
    MOV    R1,R6
    MOV    R2,#0
    SWI    OS_Byte
    MOV    R0,#124
    SWI    OS_Byte        ;clear escape
    LDMFD  sp!,{R0,pc}
;
read;      check for escape and read bytes
    MOV    R0,#126
    SWI    OS_Byte        ;check for escape
    CMP    R1,#0
    BNE    rd1
    MOV    R2,R8          ;restore buffer pointer
    AND    R1,R7,#&FF     ;restore file handle
    MOV    R0,#3
    SWI    XOS_GBPB       ;read bytes(s)
    MOV    pc,lr          ;return if no escape
;      escape detected, kill off job
rd1 BL     restore        ;restore old escape status
    ADR    R0,ers
    BL     wimpprint
;
err;                 error, illegal unit etc.
    BL     restore        ;restore old escape status
    LDR    R1,[sp],#4
    TST    R1,#&80000000
    LDMNEDB fp,{R4-R8,fp,sp,pc}
    BIC    R1,R1,#15,4
    CMP    R0,#27
    ADREQ  R0,er4
    ADRGT  R0,er5
    CMP    R0,#18
    ADRLT  R0,er1
    ADREQ  R0,er2
    CMP    R0,#19
    ADREQ  R0,er3
    BL     wimpprint
    LDMDB  fp,{R4-R8,fp,sp,pc} ; never gets here

;
buf DCD    buffer_io+24+(max_fl*8)+buf_len+2
ptr DCD    buffer_io-8
uf  DCB    0,0,"UF"
ers DCB    "Escape during BACKSPACE",0
er1 DCB    "Illegal unit %d to BACKSPACE",0
er2 DCB    "BACKSPACE not allowed on direct access unit %d",0
er3 DCB    "File on unit %d not open for BACKSPACE",0
er4 DCB    "illegal UNFORMATTED record for BACKSPACE; unit %d",0
er5 DCB    "Can not backspace unit %d while in use",0
    END
;
    EXPORT buffer_io
buf_len    EQU 512
       GET s.MaxFl
buffer_io
    %      max_fl*8      ;status of I/O units 1 to max_fl
    %      24            ;I/O status words
    %      buf_len       ;formatted buffer
    %      8             ;space for problems
    %      4             ;escape status during I/O
;
    TTL    io_err_chk
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    GET s.MaxFl
    IMPORT buffer_io
    EXPORT io_err_chk
    DCB    "io_err_chk",0,0,12,0,0,255
io_err_chk
    MOV   ip,sp
    STMDB sp!,{fp,ip,lr,pc}
    SUB   fp,ip,#4
    LDR   ip,ptr
    LDR   R0,[ip]
    AND   R0,R0,#&FF00  ;errorbyte
    MOV   R0,R0,LSR#8   ;extract error
    LDMDB fp,{fp,sp,pc};return
ptr DCD   buffer_io+max_fl*8
    END
;
    TTL    io_do_array
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 io_do_array;(N,*WORD,L,TYPE)
    IMPORT io_do_single
       GET s.MaxFl
    IMPORT buffer_io
    DCB    "io_do_array",0,12,0,0,255
;
io_do_array
    MOV    ip,sp
    STMDB  sp!,{R1-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,ptr
    MOV    R4,R0         ;save count (N)
    LDR    ip,[ip,#max_fl*8]  ;get control word
    LDMIA  sp!,{R0-R2}   ;get (*WORD,L,TYPE)
    TST    ip,#&1000000  ;test for unformatted
    MULNE  R1,R4,R1      ;make L the full length for unformatted
    MOVNE  R4,#1         ;    and only 1 block
lp1 BL     io_do_single  ;(preserves R0-R2)
    SUBS   R4,R4,#1      ;decrement count
    ADDGT  R0,R0,R1      ;increment *WORD by L
    BGT    lp1           ;loop over words
    LDMDB  fp,{R4,fp,sp,pc};return
ptr DCD    buffer_io
    END
;
    TTL    io_do_single
; corrected sign of output byte     28 Nov 2017
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R9  RN     9
R8  RN     8
R7  RN     7
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F2  FN     2
F1  FN     1
F0  FN     0
OS_Byte    EQU &6
XOS_GBPB   EQU &2000C
XOS_BinaryToDecimal EQU &20028
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT io_do_single;(*WORD,L,TYPE)
    IMPORT io_end
       GET s.MaxFl
    IMPORT buffer_io
    IMPORT format_io
    IMPORT get_buffer
    IMPORT send_buffer
    IMPORT format_next
    IMPORT format_write
    IMPORT format_read
    DCB    "io_do_single",0,0,0,0,16,0,0,255
;
io_do_single
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,ptr
    MOV    R0,#126
    LDMIA  ip,{R4-R8}    ;read parameters
    SWI    OS_Byte       ;check for escape
    CMP    R1,#0
    BNE    escape        ;escape detected
    TST    R4,#&FF00     ;check error
    LDMNEDB fp,{R0-R2,R4-R9,fp,sp,pc};then skip
    LDMIA  sp,{R0-R2}    ;restore arguments after OS_Byte
    TST    R4,#&10000000 ;test for write
    BNE    write
;
;    ******       READ COMMANDS       ******
;
    TST    R4,#&1000000  ;test for formatted
    BNE    read_unformatted
    TST    R4,#&100000   ;test for list directed
    BNE    read_list_directed
;
;       ========= start of format controlled input ===============
;               ordinary formatted read
    LDR    R9,ifm
rf1 BL     format_next   ;get next format request
rf2 LDMIA  R9,{ip,lr}    ;format code and width
    CMP    ip,#0
    ORRLT  R4,R4,#&3000  ;error 48: syntax error
    BLT    fin
    BLEQ   get_buffer
    BVS    fin
    BEQ    rf1
    CMP    ip,#8         ;check for data
    BGE    rfd           ;not numeric data
    ADD    R1,R8,#1
    MOV    R3,#" "
    CMP    R1,R7         ;check for overflow of data
    ADD    R0,R6,R8      ;address in buffer
rf3 CMPLE  R7,R5
    ORRGT  R4,R4,#&2900  ;error 41: input format exceeds buffer size
    SUBLE  R1,R7,R8      ;available length
    BGT    fin
    CMP    R1,lr
    STRLTB R3,[R6,R7]    ;extend input with blanks
    ADDLT  R7,R7,#1
    BLT    rf3
    MOVGT  R1,lr         ;length
    CMP    ip,#2
    ADD    R8,R8,R1      ;update buffer pointer
    BLT    integ_rd      ;I format
    BEQ    rf5           ;Z,O,B format
    CMP    ip,#3
    BEQ    logic_rd      ;L format
;       F,E,D and G format read
rf4 BL     float_rd      ;read floating point number into F0
    LDMIA  sp,{R0,R2}    ;restore parameters
    SUB    R8,R8,R1      ;account for any character not used ("," found)
    CMP    R2,#4
    STFEQS F0,[R0]       ;store REAL*4
    BEQ    fin
    CMP    R2,#8
    STFEQD F0,[R0]       ;store REAL*8
    BEQ    fin
    B      wrong_length
;       Z, O or B format
rf5 ADD    R0,R0,R1      ;point to end of field in input buffer
    STMFD  sp!,{R5-R7}   ;save R5 to R7
    LDR    R6,[R9,#12]   ;nibble length =4 for Hex, =3 for O, =1 for B
rf6 SUB    R9,R1,#1      ;save input length-1
    ADD    ip,sp,#12
    LDMIA  ip,{R2,R3}    ;get address and length for result
    MOV    R5,#0         ;accumulator
rf7 MOV    R7,#0         ;nibble pointer
rf8 SUBS   R1,R1,#1      ;input accounting
    BLT    rf9
    LDRB   lr,[R0,#-1]!  ;get ASCII hex
    CMP    lr,#" "
    MOVEQ  lr,#"0"
    TSTEQ  R4,#&800000   ;test for 'NULL'
    BEQ    rf8           ;so skip
    CMP    lr,#","
    SUBEQ  R9,R9,R1      ;found comma, so
    SUBEQ  R8,R8,R9      ;move end of field in input buffer
    BEQ    rf6           ;and start again
    CMP    lr,#"a"
    SUBGE  lr,lr,#32     ;convert to upper case
    CMP    lr,#"A"
    SUBLT  ip,lr,#"0"    ;convert decimal type digit
    SUBGE  ip,lr,#"7"    ;convert alphabetic digit (A - F) to (10 - 15)
    RSBLTS lr,lr,#"9"    ;if < "A" ensure it is also < "9"
    MOVGES lr,ip,LSR R6  ;should remove the whole lot           20/11/96
    ORRNE  R4,R4,#&3C00  ;error 61:
    ADDNE  R4,R4,R6,LSL#8; 63: or 64: for illegal character in B, O or Z
    LDMNEFD sp!,{R5-R7}  ;restore R5-R7 on error
    BNE    fin           ;illegal character input
    ORR    R5,R5,ip,LSL R7;accumulate nibbles
    ADD    R7,R7,R6      ;account for nibbles
    CMP    R7,#24        ;up to a total of 24 bits
    BLT    rf8
rf9 STRB   R5,[R2],#1    ;store l.s. byte
    MOV    R5,R5,LSR#8   ;shift in middle byte
    SUBS   R3,R3,#2      ;output accounting
    STRGEB R5,[R2],#1    ;store middle byte
    MOVGE  R5,R5,LSR#8   ;shift in m.s. byte
    STRGTB R5,[R2],#1    ;store m.s. byte
    MOVGT  R5,#0         ;no more bytes
    SUBGTS R3,R3,#1      ;output accounting
    BGT    rf7
    CMP    R5,#0
    LDMFD  sp!,{R5-R7}   ;restore R5-R7
    CMPEQ  R1,#0         ;ensure that all the input digits have been used
    BLE    fin
    B      wrong_length  ;too may significant hex digits for word
;
rfd LDMIA  sp,{R0,R1}    ;input parameters
    BGT    rfg           ;not A format
    CMP    lr,#0         ;if (A)
    MOVEQ  lr,R1         ;substitute length from input
    ADD    R2,R6,R8      ;input address
    SUB    ip,R7,R8      ;remaining buffer length
    CMP    lr,ip
    MOVGT  lr,ip         ;limit input to buffer length
    ADD    R8,R8,lr      ;accounting
    SUBS   R3,lr,R1      ;excess length in input buffer
    ADDGT  R2,R2,R3      ;skip any excess length
rfe SUBS   lr,lr,#1
    LDRGEB ip,[R2],#1
    SUBGES R1,R1,#1
    STRGEB ip,[R0],#1    ;transfer ASCII
    BGT    rfe
    MOV    lr,#" "
rff SUBS   R1,R1,#1
    STRGEB lr,[R0],#1    ;blank fill
    BGT    rff
    B      fin
;
rfg CMP    ip,#9         ;check for Q
    SUBLE  R0,R7,R8      ;bytes remaining in buffer
    BLE    ir6           ;go store
;
    CMP    ip,#12
    ORRLT  R4,R4,#&2A00  ;error 42: Hollerith illegal on input
    BLGE   format_read   ;search for data transfer descriptor
    TST    R4,#&FF00
    BEQ    rf2
    B      fin
;       ========== end of format controlled input ================
;
;       ================= list-directed input ====================
rlstc;   get here if found a count (in R3) followed by '*'
    ADD    R8,R8,#1      ;note: this may be beyond the buffer but is correct
    CMP    R2,#12
    CMPEQ  R7,R8
    BLE    rlc           ;end of buffer
    LDRB   lr,[R6,R8]    ;get first byte in character string
    CMP    lr,#"'"
    CMPNE  lr,#""""
    BNE    rl5           ;'count' is part of string
;        store count for list directed input
rlc LDR    R1,ilr        ;pointer to count
    STMIA  R1,{R3,R8}    ;store count and address
;
read_list_directed
;
; get here pointing to a) separator which may be:
; 1) end of record (R8 >= R7)
; 2) a space (may be a 'counted' item)
; 3) the first comma (may be a 'counted' item)
; 4) a /
;                   or b) something else which means that
;                         this is a counted item or a count
;
    LDR    R1,ilr        ;pointer to count
    LDR    R9,[R1]       ;get count
    SUBS   R9,R9,#1
    BLT    rl1           ;normal processing
    STR    R9,[R1]       ;counted item, decrement count
    LDR    R9,[R1,#4]    ;get pointer
    CMP    R9,R7
    LDRNEB lr,[R6,R9]
    TSTNE  lr,#","
    TSTNE  lr,#" "
    BEQ    fin           ;skip this item
    TST    lr,#"/"
    ORREQ  R4,R4,#&FD00  ;error 253: flag end of read
    BEQ    fin           ;skip this item
    B      rl5           ;process field
;
rl1;     real beginning, skip separator
    CMP    R9,#-2
    MOV    R9,#0         ;new record (equivalent to <space>)
    STREQ  R9,[R1]
    MOVEQ  R9,#","
rl2 CMP    R8,R7         ;R8 is current pointer, R7 is #bytes in buffer
    BLGE   get_buffer
    BVS    fin           ;error getting buffer
    LDRB   lr,[R6,R8]    ;get separator value
;      search for beginning of data
    CMP    lr,#"/"
    ORREQ  R4,R4,#&FD00  ;error 253: flag end of read
    CMPNE  lr,R9         ;check for double comma
    BEQ    fin           ;skip
    CMP    lr,#","
    MOVEQ  R9,lr
    CMPNE  lr,#" "
    ADDEQ  R8,R8,#1
    BEQ    rl2
;
rl3;    not separator, check for possible count
    MOV    R3,#0         ;accumulator
    MOV    R9,R8         ;save pointer
rl4 RSBS   R0,lr,#"9"
    RSBGES R0,R0,#9
    ADDGE  R3,R3,R3,LSL#2
    ADDGE  R8,R8,#1
    ADDGE  R3,R0,R3,LSL#1;accumulate
    CMPGE  R7,R8
    LDRGTB lr,[R6,R8]
    BGT    rl4           ;loop over digits
    CMP    lr,#"*"
    BEQ    rlstc         ;store count
;
rl5 MOV    R8,R9         ;not count, so restore pointer
    CMP    R2,#12
    BNE    rlnum         ;not Character string request
    LDRB   lr,[R6,R8]
    LDMIA  sp,{R0-R1}    ;restore parameters
    CMP    lr,#"'"
    CMPNE  lr,#""""
    MOVEQ  R9,lr         ;save opening quotes type
    MOVNE  R9,#-1
    SUBNE  R8,R8,#1
rl6 ADD    R8,R8,#1
    CMP    R8,R7
    BLT    rl7
    CMP    R9,#0
    BLT    rlf
    BL     get_buffer
    BVS    fin
rl7 LDRB   lr,[R6,R8]
    CMP    R9,#0
    BLT    rlt           ;text does not begin with quote
    CMP    lr,R9
    BEQ    rlq           ;found possibly terminating quote
rls SUBS   R1,R1,#1
    STRGEB lr,[R0],#1    ;store character
    B      rl6
rlt CMP    lr,#" "       ;check for normal terminator
    CMPNE  lr,#","
    CMPNE  lr,#"/"
    BNE    rls
rlf MOV    lr,#" "
rll SUBS   R1,R1,#1
    STRGEB lr,[R0],#1    ;blank fill
    BGT    rll
    B      fin
rlq ADD    R8,R8,#1
    CMP    R8,R7
    BGE    rlf
    LDRB   lr,[R6,R8]
    CMP    lr,R9         ;check for double quote
    BEQ    rls
    B      rlf
;
rlnum;        read numeric/logical (R8=R9 = pointer to first character)
    LDRB   lr,[R6,R8]    ;search for end of field
    CMP    lr,#"/"
    CMPNE  lr,#","
    CMPNE  lr,#" "
    ADDNE  R8,R8,#1
    CMPNE  R8,R7         ;R8 is current pointer, R7 is #bytes in buffer
    BNE    rlnum
    SUBS   R1,R8,R9      ;# characters in field
    ADD    R0,R6,R9      ;pointer to input string
    BLE    fin
    LDR    lr,ifm
    MOV    R9,#0
    STR    R9,[lr,#16]   ;no scaling
    SUBS   R9,R2,#3      ;test for
    BLE    integ_rd      ;integer
    SUBS   R9,R2,#5      ;test for real
    BLE    rf4           ;go read real number
    SUBS   R9,R2,#8      ;test for complex
    BGT    logic_rd      ;no, then must be logical
;       read complex numbers here
    LDRB   lr,[R0]       ;read over 1st character
    CMP    lr,#"("
    BNE    rc6           ;must be '('
;        now we have to sort out the mess
;        because there may be blanks, new-lines in the middle
    SUB    R8,R0,R6
    MOV    R2,#0         ;for real part
rc1 ADD    R8,R8,#1
    CMP    R8,R7         ;R8 is current pointer, R7 is #bytes in buffer
    BLGE   get_buffer
    BVS    fin           ;error getting buffer
    LDRB   lr,[R6,R8]
    CMP    lr,#" "
    BEQ    rc1
    CMP    lr,#"/"
    ORREQ  R4,R4,#&FD00
    CMPNE  lr,#")"
    BEQ    fin
    CMP    lr,#","
    CMPEQ  R9,#0         ;(anything useful is > comma)
    MOVLE  R1,#0
    BLE    rc4           ;skip real part
rc2 ADD    R0,R8,R6      ;pointer to first useful character
rc3 ADD    R8,R8,#1
    CMP    R8,R7         ;R8 is current pointer, R7 is #bytes in buffer
    LDRNEB lr,[R6,R8]
    CMPNE  lr,#" "
    CMPNE  lr,#","
    CMPNE  lr,#")"
    CMPNE  lr,#"/"
    BNE    rc3           ;not terminator
    ADD    R1,R8,R6
    SUB    R1,R1,R0
    BL     float_rd
    LDR    R0,[sp]
    MOV    R1,R2         ;R1 is 0 for the real part, >0 for the imaginary
    ADD    R0,R0,R2      ;move to imaginary part if necessary
    CMP    R9,#0
    STFEQD F0,[R0]
    STFLTS F0,[R0]
rc4 ADDEQ  R2,R2,#8
    ADDLT  R2,R2,#4
    SUB    R8,R8,#1
    MOV    R0,#-1
rc5 ADD    R8,R8,#1
    CMP    R8,R7         ;R8 is current pointer, R7 is #bytes in buffer
    BLGE   get_buffer
    BVS    fin           ;error getting buffer
    LDRB   lr,[R6,R8]
    CMP    lr,#" "
    BEQ    rc5
    CMP    lr,#"/"
    ORREQ  R4,R4,#&FD00
    CMPNE  lr,#")"
    BEQ    fin
    CMP    R1,#0
    BGT    rc6           ;only <space> ")" or "/" allowed after imag. part
    CMP    lr,R0
    BEQ    rc6
    CMP    lr,#","
    MOVEQ  R0,lr
    BEQ    rc5           ;allow one comma between real and imaginary parts
    B      rc2
;
rc6 ORR    R4,R4,#&4300  ;error 67: illegal character input for complex
    B      fin
;       ============== end of list-directed input =================
;
write;    ******       WRITE COMMANDS       ******
;
    TST    R4,#&1000000  ;test for formatted
    BNE    write_unformatted
    TST    R4,#&100000   ;test for list directed
    BNE    write_list_directed
;
;       ========= start format controlled output =================
    LDR    R9,ifm
wf0 BL     format_next   ;get next format request
wf1 LDR    ip,[R9]       ;format code
    CMP    ip,#0
    ORRLT  R4,R4,#&3000  ;error 48: syntax error in FORMAT
    BLT    fin           ;syntax error
    BEQ    wfs           ;end of record
    CMP    ip,#9
    BGT    wfndt         ;no data transfer
    BEQ    fin           ;Q is skipped on output
    LDMIB  R9,{R2,R3}    ;get width and d
    ADD    lr,R2,R8
    CMP    lr,R5         ;check for space
    BGT    buf_ovfl
    CMP    lr,R7
    MOVGT  R7,lr
    LDMIA  sp,{R0,R1}    ;get address and length of data for transfer
    CMP    ip,#2
    BGE    wf2           ;not I format
;        write I format
    CMP    R1,#3
    CMPNE  R1,#5
    BGE    wrong_length
    CMP    R1,#2
    LDREQB ip,[R0,#1]    ;ms byte of int*2
    LDRLEB R0,[R0]       ;ls byte of int*2 or BYTE
    LDRGT  R0,[R0]       ;int*4
    ORREQ  R0,R0,ip,LSL#8;insert m.s. byte of INTEGER*2
    ADD    R1,R6,R8      ;where to store ASCII
    MOVEQ  R0,R0,LSL#16
    MOVEQ  R0,R0,ASR#16  ;fix up sign on INTEGER*2
    MOVLT  R0,R0,LSL#24
    MOVLT  R0,R0,ASR#24  ;fix up sign on BYTE
    BL     integ_wr
    ADD    R8,R8,R0
    B      fin
;        write Hex, Octal or Binary
wf2 BGT    wfd           ;not Z/O/B
    STR    R5,[sp,#-4]!  ;save R5
    LDR    R5,[R9,#12]   ;# bits / nibble
    SUB    R3,R2,R3      ;max # leading blanks
    ADD    R9,R6,R8      ;address for output
    ADD    R8,R8,R2      ;accounting
wf3 SUBS   R1,R1,#2      ;try to load 3 bytes (8 octal or 6 hex)
    LDRB   lr,[R0],#1    ;get byte 1
    LDRGEB ip,[R0],#1
    ORRGE  lr,lr,ip,LSL#8;add byte 2
    SUBGES R1,R1,#1
    LDRGEB ip,[R0],#1
    ORRGE  lr,lr,ip,LSL#16;add byte 3
    ORRGE  lr,lr,#&80000000;flag that there may be more to come
wf4 MOV    ip,#-1
    BIC    ip,lr,ip,LSL R5;get nibble
    CMP    ip,#9
    ADDGT  ip,ip,#7      ;accomodate letters in Hex
    SUBS   R2,R2,#1
    ADD    ip,ip,#"0"    ;convert to ASCII
    BLT    wf8           ;overflow output buffer?
    STRB   ip,[R9,R2]    ;store digit
    MOVS   lr,lr,ASR R5  ;move to next nibble while extending flags
    CMPMI  lr,#-128      ;check if all collected nibbles are used
    BNE    wf4           ;carry on with collected nibbles
    CMP    R1,#0
    BGT    wf3
wf5 MOV    lr,#"0"
wf6 SUBS   R2,R2,#1
    STRGEB lr,[R9,R2]    ;zero fill
    BGT    wf6
    MOV    lr,#" "
wf7 LDRB   ip,[R9]
    RSBS   ip,ip,#"0"
    SUBGES R3,R3,#1
    STRGEB lr,[R9],#1    ;blank fill
    BGT    wf7
    B      wfc
wf8 MOVS   lr,lr,LSL#1
    BMI    wf8           ;remove flags
wf9 CMP    lr,#0         ;check that remainder of input is zero
    BNE    wfa           ;overflow
    SUBS   R1,R1,#1
    LDRGTB lr,[R0],#1
    BGT    wf9
    B      wf5
wfa MOV    lr,#"*"
    ADD    R2,R6,R8
wfb STRB   lr,[R9],#1    ;overflow, fill with "*"
    CMP    R9,R2
    BLT    wfb
wfc LDR    R5,[sp],#4    ;restore R5
    B      fin
;       write logical format
wfd CMP    ip,#3
    BGT    wff           ;not logical
    LDRB   R0,[R0]       ;get byte
    ADD    R8,R8,R2      ;accounting
    ADD    R1,R6,R8
    CMP    R0,#0
    MOVEQ  ip,#"F"
    MOVNE  ip,#"T"
    STRB   ip,[R1,#-1]!  ;store variable
    MOV    lr,#" "
wfe SUBS   R2,R2,#1
    STRGTB lr,[R1,#-1]!  ;blank fill
    BGT    wfe
    B      fin
;        write F,E,D,G format
wff CMP    ip,#8
    BEQ    wfg           ;A format
    CMP    R1,#4
    LDFEQS F0,[R0]       ;get REAL*4
    CMPNE  R1,#8
    BNE    wrong_length
    CMP    R1,#8
    LDFEQD F0,[R0]       ;get REAL*8
    ADD    R1,R6,R8      ;address to write to
    BL     float_wr      ;write it
    ADD    R8,R8,R0      ;accounting
    B      fin
;        write A format
wfg CMP    R2,#0         ;check for A with no width
    MOVEQ  R2,R1         ;then use string length
    ADD    lr,R2,R8
    CMP    lr,R5         ;check for space
    BGT    buf_ovfl
    CMP    lr,R7
    MOVGT  R7,lr         ;extend buffer if required
    ADD    R3,R6,R8      ;address to store in buffer
    MOV    R8,lr         ;accounting
    SUBS   R2,R2,R1      ;length of blank padding
    ADDLT  R1,R1,R2      ;truncate text if longer than format
    MOV    lr,#" "
wfh SUBS   R2,R2,#1
    STRGEB lr,[R3],#1    ;blank padding comes first!
    BGT    wfh
wfi LDRB   lr,[R0],#1
    SUBS   R1,R1,#1
    STRGEB lr,[R3],#1    ;transfer ASCII
    BGT    wfi
    B      fin
;
wfndt;        no data transfer
    MOV    R0,#0
    BL     format_write  ;write from format until next data transfer
    TST    R4,#&FF00     ;check there is a data transfer (no error)
    BEQ    wf1
    B      fin
;
wfs MOV    R0,#0         ;more output to come
    BL     send_buffer
    BVC    wf0           ;OK, go back to next format
    B      fin           ;dead
;       ========== end format controlled output ==================
;
;       =========== start list-directed output ===================
write_list_directed
;       determine whether to precede output with a " "
    TST    R4,#&400000
    TSTEQ  R4,#&FF
    BNE    wl1           ;external file
    CMP    R7,#0         ;for internal file, put " " if not 1st entry
;    CMPNE  R2,#12        ;and not character variable
    B      wl2
;        external file
wl1 SUB    lr,R5,R7      ;remaining space                             18/11/96
    CMP    R2,#12        ;check for character O/P                     18/11/96
    SUBEQ  lr,lr,R1      ;subtract string length if character O/P     18/11/96
    SUBNE  lr,lr,#30     ;or allow 30 for numeric                     18/11/96
    CMP    R2,#8         ;                                            18/11/96
    SUBEQ  lr,lr,#16     ;and another 16 for COMPLEX*16               18/11/96
    CMP    lr,#0         ;                                            18/11/96
    BLLE   send_buffer   ;output buffer if insufficient
    BVS    fin
    LDMIA  sp,{R0-R2}    ;restore arguments
    CMP    R7,#1         ;for external file, put " " if first entry
    CMPGE  R2,#12        ;or not character variable
;        external and internal file
wl2 MOVNE  lr,#" "
    STRNEB lr,[R6,R7]    ;add " "
    ADDNE  R7,R7,#1
    SUBS   R9,R5,R7      ;space left
    BLE    buf_ovfl
    CMP    R2,#3
    BGT    wlr
;
    LDREQ  R0,[R0]       ;integer*4
    CMP    R2,#2
    LDREQB ip,[R0,#1]    ;int*2 more significant
    ADD    R1,R6,R7      ;pointer to output buffer
    LDRLEB R0,[R0]       ;int*2 less significant (or byte)
    MOV    R2,R9         ;max length
    ORREQ  R0,R0,ip,LSL#8;insert m.s. byte of int*2
    MOVEQ  R0,R0,LSL#16  ;correct the sign
    MOVEQ  R0,R0,ASR#16
    MOVLT  R0,R0,LSL#24
    MOVLT  R0,R0,ASR#24  ;fix up sign on BYTE
    BL     integ_wr
    ADD    R7,R7,R2
    B      fin
;
wlr SUBS   R8,R2,#5
    CMPGT  R8,#3
    BGT    wll           ;not real nor complex
    CMP    R8,#0         ;check for complex
    MOVGT  lr,#"("
    SUBGT  R9,R9,#3      ;allow for "(,)"
    STRGTB lr,[R6,R7]
    ADDGT  R7,R7,#1
    CMPGT  R8,#3         ;flag COMPLEX*8 with LT
    LDR    R0,[sp]       ;address of floating word
    BL     wlf           ;print real part
    CMP    R8,#2
    BLT    fin           ;done if real
    MOV    lr,#","
    SUB    R9,R9,R0      ;subtract actual space used on real part
    STRB   lr,[R6,R7]
    ADD    R7,R7,#1
    LDR    R0,[sp]
    CMP    R8,#3
    ADDEQ  R0,R0,#8      ;address of 8-byte imaginary part
    ADDLT  R0,R0,#4      ;address of 4-byte imaginary part
    BL     wlf           ;print imaginary part
    MOV    lr,#")"
    STRB   lr,[R6,R7]
    ADD    R7,R7,#1
    B      fin
;        set up format and print floating
wlf LDFEQD F0,[R0]
    LDFLTS F0,[R0]       ;load word to print
    MOV    R0,#7         ;G format
    MOVEQ  R1,#21
    MOVLT  R1,#13        ;width
    MOVEQ  R2,#14
    MOVLT  R2,#6         ;decimal width
    SUBS   R3,R9,R1      ;check width
    MOV    ip,#1         ;scaling
    ADDLT  R1,R1,R3      ;compress to fit into space
    ADDLT  R2,R2,R3      ;reduce d accordingly
    CMPLE  R1,#7
    MOVLES R1,R1         ;remove N flag
    MOV    R3,#2         ;exponent width
    CMFGT F0,#0         ;if =0 then
    MOVEQ  R0,#4         ;P0,F3.1 format
    MOVEQ  R1,#3
    MOVEQ  R2,#1
    MOVEQ  ip,#0
    CMP    R9,R1
    BLT    buf_ovfl
    STR    lr,[sp,#-4]!
    LDR    lr,ifm
    STMIA  lr,{R0-R3,ip} ;store formats (1P,G14.6E2) or (1P,G22.14E2)
    ADD    R1,R6,R7      ;*STRING for output
    BL     float_wr      ;write it
    ADD    R7,R7,R0      ;accounting
    LDR    pc,[sp],#4
;
wll CMP    R2,#11
    BGT    wla           ;not logical
    LDRB   R0,[R0]
    CMP    R0,#0
    MOVEQ  lr,#"F"       ;.FALSE.
    MOVNE  lr,#"T"
    STRB   lr,[R6,R7]
    ADD    R7,R7,#1
    B      fin
wla CMP    R9,R1         ;character string, check space
    BLT    buf_ovfl
wa1 LDRB   lr,[R0],#1
    SUBS   R1,R1,#1
    STRB   lr,[R6,R7]
    ADD    R7,R7,#1
    BGT    wa1
    B      fin
;       ============ end list-directed output ====================
;
;          ********   UNFORMATTED IO   ****************
;
read_unformatted
    ADD    R7,R7,R1      ;new # bytes read
    SUBS   R3,R7,R5
    ORRGT  R4,R4,#&2F00  ;error 47: input record overflow
    SUBGT  R1,R1,R3      ;then reduce length to transfer
    MOVS   R3,R1         ;length
    MOVGT  R2,R0         ;address to store
    ANDGT  R1,R4,#&FF    ;file handle
    MOVGT  R0,#4
    MOV    ip,R4
    SWIGT  XOS_GBPB      ;read data from file
    BICVS  R4,ip,#&FF00
    ORRVS  R4,R4,#&1C00  ;error 28: can not read file
    B      wu1
;
write_unformatted;
    ADD    R7,R7,R1      ;increment length
    CMP    R7,R5         ;(R5 is -1 for sequential file so do unsigned check)
    ORRHI  R4,R4,#&2E00  ;error 46: direct-access unformatted output overflow
    MOVLS  R3,R1         ;length
    MOVLS  R2,R0         ;address to write from
    ANDLS  R1,R4,#&FF    ;file handle
    MOVLS  R0,#2         ;consecutive write
    MOV    ip,R4
    SWILS  XOS_GBPB      ;write data to file
    ORRVS  R4,ip,#&1500  ;error 21: can not write to unformatted file
wu1 MOVVC  R4,ip
;
;          *************  ALL DONE HERE - RETURN  ***************
;
fin LDR    ip,ptr
    STMIA  ip,{R4-R8}      ;store current control parameters
    LDMDB  fp,{R0-R2,R4-R9,fp,sp,pc};return
;
wrong_length
    ORR    R4,R4,#&2700  ;error 39: format incompatible with data length
    B      fin
;
buf_ovfl
    ORR    R4,R4,#&2600  ;error 38: output buffer overflow
    B      fin
;
escape;       escape condition detected. kill job!
    MOV    R4,#&2200     ;error 34: escape detected
    LDR    ip,ptr
    STMIA  ip,{R4-R8}    ;store current control parameters
    LDMDB  fp,{R0-R2,R4-R9,fp,sp,lr}
    B      io_end        ;Kill!
;
ifm DCD    format_io
ptr DCD    buffer_io+max_fl*8
ilr DCD    format_io+20  ;pointer to list-directed repeat count
;
;         *************  UTILITIES  ****************
;
logic_rd;                                                      LOGICAL READ
;         called with address in R0, length in R1
    MOV    R3,R0
lr1 SUBS   R1,R1,#1      ;count characters in the input field
    BLT    lre
    LDRB   ip,[R3],#1    ;get next character
    CMP    ip,#" "
    CMPNE  ip,#"."
    BEQ    lr1           ;skip . and blank
    CMP    ip,#"a"
    SUBGE  ip,ip,#32     ;convert to upper case
    SUBS   R0,ip,#"F"
    MOVNE  R0,#1         ;.TRUE. (otherwise R0=0 : .FALSE.)
    CMPNE  ip,#"T"
lre ORRNE  R4,R4,#&3E00  ;error 62: illegal character in logical input
    BNE    fin           ;neither = error
lr2 SUBS   R1,R1,#1
    BLT    ir6
    LDRB   ip,[R3],#1
    CMP    ip,#","       ;search for terminating comma
    BNE    lr2
    B      ir5           ;go store it
;
integ_rd;                                            INTEGER READ
;         called with address in R0, length in R1
    MOV    R2,#1         ;sign
    MOV    R3,R0
    MOV    R0,#0         ;accumulator
ir1 SUBS   R1,R1,#1
    BLT    ir6
    LDRB   ip,[R3],#1
    CMP    ip,#" "
    BEQ    ir1           ;skip initial blanks
    ADD    R1,R1,#1
    CMP    ip,#"-"
    MOVEQ  R2,#-1
    LDREQB ip,[R3],#1
    SUBEQS R1,R1,#1
    BEQ    ir6
    CMP    ip,#"+"
    CMPEQ  R2,#1
    LDREQB ip,[R3],#1
    SUBEQS R1,R1,#1
    BEQ    ir6
ir2 CMP    ip,#" "       ;test if 'significant' blank
    MOVEQ  ip,#"0"       ;substitute "0"
    TSTEQ  R4,#&800000   ;test bit 23 (BLANK=NULL/ZERO)
    BEQ    ir3           ;skip blank if NULL selected
    CMP    ip,#","
    SUBEQ  R1,R1,#1
    BEQ    ir4           ;stop if found ","
    RSBS   ip,ip,#"9"
    RSBGES ip,ip,#9
    ORRLT  R4,R4,#&4100  ;error 65: illegal character in integer input
    BLT    fin
    CMP    R0,#&0CD00000
    BHI    ir7
    ADD    R0,R0,R0,LSL#2
    ADDS   R0,ip,R0,LSL#1
    BMI    ir8
ir3 SUBS   R1,R1,#1
    LDRGTB ip,[R3],#1
    BGT    ir2
ir4 CMP    R2,#0
    RSBLT  R0,R0,#0
ir5 SUB    R8,R8,R1      ;account for any character not used ("," found)
ir6 LDMIA  sp,{R1,R2}    ;restore parameters
    CMP    R2,#4
    STREQ  R0,[R1]       ;store integer*4
    BEQ    fin
    CMP    R2,#2
    BHI    wrong_length
    STRB   R0,[R1]       ;store l.s. byte (byte and integer*2)
    MOVEQ  R0,R0,ASR#8   ;                                        05/06/99
    STREQB R0,[R1,#1]    ;store m.s. byte for integer*2
    MOV    R0,R0,ASR#7   ;move out last significant byte          22/11/96
    CMP    R0,#-1        ;negative allowed only if fits in word   05/06/99
    CMPNE  R0,#0
ir7 ORRNE  R4,R4,#&2B00  ;error 43: formatted integer read overflow
    B      fin
ir8 CMP    R2,#0
    BGT    ir7
    TEQ    R0,#&80000000
    BNE    ir7
    B      ir3
;
integ_wr;                                             INTEGER WRITE
;          writes integer (R0) left justified to STRING (R1, length(w) R2)
;          (#digits(d) in R3);    length returned in R0
    STMFD  sp!,{R5,R6,lr}
    MOV    R6,R2         ;save the string length
;    TST    R4,#&100000   ;test for list-directed        07/10/99
    MOV    R5,R0         ;not list-dirested so save R0
;    CMPEQ  R0,#0                                        07/10/99
;    RSBMI  R0,R0,#0      ;   and make it +ve            07/10/99
    SWI    XOS_BinaryToDecimal
    BVS    iw5
    TST    R4,#&100000   ;test for list-directed
    MOVNE  R0,R2
    LDMNEFD sp!,{R5,R6,pc} ;return if list-directed
    CMP    R5,#0
    MOVEQ  R2,#0         ;no digits if number is zero
    SUB    R0,R6,R2      ;amount for right shift
    ADD    ip,R1,R2      ;where to start
iw1 CMP    ip,R1
    LDRGTB lr,[ip,#-1]!
    STRGTB lr,[ip,R0]    ;move to end of string
    BGT    iw1
    CMP    R3,R6         ;R3 contains d (of Iw.d)
    BGT    iw5           ;d>w => overflow
    MOV    lr,#"0"
iw2 CMP    R3,R2
    SUBGT  R0,R0,#1
    STRGTB lr,[R1,R0]    ;insert zeros
    ADDGT  R2,R2,#1
    BGT    iw2
    CMP    R5,#0
;    MOVLT  lr,#"-"       ;minus sign required               07/10/99
    TSTGT  R4,#&80000    ;test if + sign is needed
    MOVGT  lr,#"+"       ;plus sign required
;    BEQ    iw3           ;no sign                           07/10/99
    BLE    iw3           ;no sign
    SUBS   R0,R0,#1
    BLT    iw5           ;no room for sign
    STRB   lr,[R1,R0]
iw3 MOV    lr,#" "
iw4 SUBS   R0,R0,#1
    STRGEB lr,[R1,R0]    ;blank fill
    BGT    iw4
    MOV    R0,R6
    LDMFD  sp!,{R5,R6,pc};return
iw5 MOV    ip,#"*"       ;failed, fill with ***
    MOV    R0,R6
iw6 SUBS   R6,R6,#1
    STRGEB ip,[R1,R6]
    BGT    iw6
    LDMFD  sp!,{R5,R6,pc};return
;
float_rd;                                     READ FLOATING
;            called with address in R0 and length in R1
;            returns result in F0 and length not used in R1
    STMFD  sp!,{R2,R5-R8,lr}
    MOV    R2,#1         ;sign
    MOV    R3,#-1        ;decimal counter
    MOV    R7,#1         ;exponent sign
    MOV    R5,#0         ;exponent magnitude
    LDR    lr,ifm
    LDR    R6,[lr,#16]   ;scale factor
    LDR    R8,[lr,#8]    ;decimal position
    MVFE   F0,#0         ;accumulator
fr1 LDRB   ip,[R0],#1
    CMP    ip,#" "       ;skip leading blanks
    BNE    fr2
    SUBS   R1,R1,#1
    BGT    fr1
    MOV    R1,#0
    LDMFD  sp!,{R2,R5-R8,pc} ;all blank
fr2 CMP    ip,#"-"
    MOVEQ  R2,#-1
    LDREQB ip,[R0],#1
    SUBEQS R1,R1,#1
    LDMEQFD sp!,{R2,R5-R8,pc};return
    CMP    ip,#"+"
    CMPEQ  R2,#1
    LDREQB ip,[R0],#1
    SUBEQS R1,R1,#1
    LDMEQFD sp!,{R2,R5-R8,pc};return
fr3 CMP    ip,#" "
    MOVEQ  ip,#"0"
    TSTEQ  R4,#&800000   ;test bit 23 (BLANK=NULL/ZERO)
    BEQ    fr4
    RSBS   lr,ip,#"9"
    RSBGES lr,lr,#9
    BLT    fr7           ;not digit
    FLTE   F1,lr
    MUFE   F0,F0,#10
    ADFE   F0,F0,F1      ;accumulate
    CMP    R3,#0
    ADDGE  R3,R3,#1      ;count decimal places
fr4 SUBS   R1,R1,#1
    LDRGTB ip,[R0],#1
    BGT    fr3
fr5 CMP    R2,#0
    MNFLTE F0,F0         ;fix sign
    CMP    R3,#-1
    MOVEQ  R3,R8
    CMP    R7,#0
    RSBLT  R5,R5,#0      ;fix exponent sign
    ADD    R3,R3,R6      ;allow for scaling
    SUBS   R3,R5,R3
    LDMEQFD sp!,{R2,R5-R8,pc};no decimal scaling
;            now divide by 10**R3
    MVFE   F1,#10
    RDFLTE F1,F1,#1
    RSBLT  R3,R3,#0
fr6 MOVS   R3,R3,LSR#1
    MUFCSE F0,F0,F1
    MUFNEE F1,F1,F1
    BNE    fr6
    LDMFD  sp!,{R2,R5-R8,pc};return
fr7 CMP    ip,#"."       ;check for decimal
    BNE    fr8
    CMP    R3,#-1
    BNE    frd           ;check not >1 decimal point
    MOV    R3,#0         ;start decimal count
    B      fr4
fr8 CMP    ip,#","
    SUBEQ  R1,R1,#1
    BEQ    fr5           ;found comma, so stop
;        only exponents allowed here
    MOV    R6,#0         ;no external scaling if explicit exponential
    MOV    R8,#0         ;no assumed decimal position
    CMP    ip,#"a"
    SUBGE  ip,ip,#32     ;convert to upper case
    CMP    ip,#"E"
    CMPNE  ip,#"D"       ;check for exponent flag
    BNE    frc
    LDRB   ip,[R0],#1    ;get next character
    SUBS   R1,R1,#1
    BEQ    fr5
fr9 CMP    ip,#"-"
    MOVEQ  R7,#-1        ;negative exponent
    LDREQB ip,[R0],#1
    SUBEQS R1,R1,#1
    BEQ    fr5
    CMP    ip,#"+"
    CMPEQ  R7,#1
    LDREQB ip,[R0],#1
    SUBEQS R1,R1,#1
    BEQ    fr5
fra CMP    ip,#" "       ;check for blank
    MOVEQ  ip,#"0"
    TSTEQ  R4,#&800000   ;test bit 23 (BLANK=NULL/ZERO)
    BEQ    frb
    CMP    ip,#","
    SUBEQ  R1,R1,#1
    BEQ    fr5           ;found comma, so stop
    RSBS   lr,ip,#"9"
    RSBGES lr,lr,#9
    BLT    frd           ;not digit
    ADD    R5,R5,R5,LSL#2
    ADD    R5,lr,R5,LSL#1;accumulate exponent
frb SUBS   R1,R1,#1
    LDRGTB ip,[R0],#1
    BGT    fra
    B      fr5
;
frc CMP    ip,#"-"       ;exponents beginning with "+" or "-" are allowed
    CMPNE  ip,#"+"
    BEQ    fr9
;
frd LDMFD  sp!,{R2,R5-R8,lr}
    ORR    R4,R4,#&4200  ;error 66: illegal character input for floating
    B      fin
;
;                                                 FLOATING WRITE
float_wr
    STMFD  sp!,{R1,R4-R9,lr}
    MOV    R2,R4         ;status word
    LDR    R3,ifm
    LDMIA  R3,{R4-R8}    ;code,w,d,e,p
;                set scale for encoding
    ABSE   F1,F0         ;|R|
    CMFE   F1,#0
    LOGNEE F2,F1
    FIXNEM ip,F2         ;'n-1'
    MOVEQ  ip,#-1        ;or 0 if R = 0
;                fix up G format to F or E
fw1 CMP    R4,#7
    BNE    fw2           ;not G
    CMP    ip,#-2        ;check for n > -1
    CMFGT F1,#0
    CMPGT  R6,ip         ;and d > (n-1)
    MOVGT  R4,#4         ;then 'F' format
    SUBGT  R5,R5,R7
    SUBGT  R5,R5,#2      ;w' = w-e-2
    SUBGT  R6,R6,ip
    SUBGT  R6,R6,#1      ;d' = d-n
    MOVGT  R8,#0         ;p' = 0
    MOVLE  R4,#5         ;otherwise make 'E' format
;             find # digits before decimal
fw2 CMP    R4,#4
    BNE    fw3           ;not F format (E or D)
    MOV    R7,#-2        ;exponent "length"
    ADD    R9,ip,R8      ;n+p-1
    ADDS   R9,R9,#1      ;n+p
    ADDLT  R8,R8,#1      ;scale exponent is (1+p) if (n+p)<0
    RSBGE  R8,ip,#0      ;scale exponent is (1-n) if (n+p)>=0
    MOVLT  R9,#0         ;MAX(0,n+p)
    B      fw4
;
fw3 ADD    lr,R6,#2
    CMP    lr,R8         ;d+2 must be > p
    CMNGT  R8,R6
    BLE    fwl           ;p+d must be > 0
    MOVS   R9,R8
    SUBLT  R8,R8,ip      ;scale exponent is (1-n+p) if p<=0
    RSBGE  R8,ip,#0      ;scale exponent is (1-n) if p>=0
    SUB    ip,ip,R9
    ADD    ip,ip,#1      ;exponent to write out is (n-p)
    MOVLT  R9,#0         ;MAX(0,p)
    SUBGES lr,R9,#1
    SUBGT  R6,R6,lr      ;reduce decimal part according to 13.5.9.2.2
fw4 CMFE   F0,#0
    MOVEQ  R9,#0         ;bodge for writing 0.0 with nP
    TSTGE  R2,#&80000    ;test for SP
    ADDNE  R9,R9,#1      ;add space for sign gives needed space
    SUB    R0,R5,R6
    SUB    R0,R0,R7
    SUB    R0,R0,#3      ;available space (w-d-e-3)
;            check space for integral part and sign
    CMP    R0,R9
    BLT    fwl           ;insufficient space for integral part
    BEQ    fw5           ;no room for leading zero
;            fix for leading zero
    CMP    R9,#1
    BGT    fw5
    CMFEQ  F0,#0
    TSTGE  R2,#&80000    ;test for SP
    ADDNE  R9,R9,#1      ;fix for leading zero
    SUBNE  R8,R8,#1
;            scale for printing
fw5 CMP    R8,#0
    MVFNEE F2,#10
    RDFLTE F2,F2,#1
    RSBLT  R8,R8,#0
fw6 MOVS   R8,R8,LSR#1
    MUFCSE F1,F1,F2      ;scale
    MUFNEE F2,F2,F2
    BNE    fw6
    CMFE   F1,#10
    BGE    fwk           ;should not be >=10, but may be rounding problem
;
; useful variables are:
; F0  the original number with sign
; F1  |F0| scaled by the factor of 10 to make integral part 1st digit
; R0  space available before decimal point
; R1  pointer to output buffer
; R2  io status word
; R3  pointer to buffer_io
; R4  =4 for F, =5 for E, =6 for D
; R5  w' space for output (may be less than original w)
; R6  d (number of decimal places)
; R7  e (number of exponential places) (-2 for F format)
; R8  unused
; R9  space needed before decimal point
; ip  exponent to write out
;
;
;         now start to write to buffer
    SUB    R8,R0,R9      ;blank space at beginning
    TST    R2,#&100000
    SUBNE  R5,R5,R8
    MOVNE  R8,#0         ;kill it if list-directed output
    MOV    lr,#" "
fw7 SUBS   R8,R8,#1
    STRGEB lr,[R1],#1
    BGT    fw7
    CMFE   F0,#0
    MOVLT  lr,#"-"
    TSTGE  R2,#&80000
    MOVGT  lr,#"+"
    STRNEB lr,[R1],#1    ;store sign
    SUBNE  R9,R9,#1
    MOV    R8,R1         ;remember position of 1st digit
    CMP    R9,#0
    ADDLE  R8,R8,#1
;         integral part
fw8 SUBS   R9,R9,#1
    FIXGEZ lr,F1
    FLTGEE F2,lr
    SUFGEE F1,F1,F2
    MUFGEE F1,F1,#10
    ADDGE  lr,lr,#"0"
    STRGEB lr,[R1],#1
    BGT    fw8
;         decimal point
    MOV    lr,#"."
    STRB   lr,[R1],#1
;         fractional part
fw9 SUBS   R6,R6,#1
    FIXGEZ lr,F1
    FLTGEE F2,lr
    SUFGEE F1,F1,F2
    MUFGEE F1,F1,#10
    ADDGE  lr,lr,#"0"
    STRGEB lr,[R1],#1
    BGT    fw9
;         rounding
    MOV    R9,R1         ;pointer after last digit
    MOV    R6,#"0"
    CMFE   F1,#5
    BLE    fwb
fwa LDRB   lr,[R9,#-1]!
    ADD    lr,lr,#1
    STRB   lr,[R9]
    CMP    R9,R8
    BLE    fwi           ;have rounded first digit -> more checks
    CMP    lr,#"9"+1
    STRGEB R6,[R9]
    BGE    fwa
    CMP    lr,#"."+1     ;check we have not "rounded" the decimal point
    MOVEQ  lr,#"."
    STREQB lr,[R9]
    BEQ    fwa
;         remove trailing zeros if list-directed
fwb TST    R2,#&100000
    BEQ    fwd
    SUB    R8,R1,#2
fwc LDRB   lr,[R1,#-1]!
    CMP    lr,#"0"
    BEQ    fwc           ;skip trailing zeros
    CMP    R8,R1
    RSBGES lr,lr,#"0"
    ADC    R1,R1,#1      ;restore zero after decimal point
;         exponent (if any)
fwd MOV    R8,R2         ;save list-directed flag
    ADDS   R2,R7,#1      ;end of exponent
    BLE    fwf           ;no exponent
    MOVS   R0,ip
    RSBMI  R0,R0,#0      ;|exponent|
    SWI    XOS_BinaryToDecimal
    BVS    fwl           ;exponent too long
    ADD    R0,R7,#1      ;end of exponent
    TST    R8,#&100000
    ADDNE  lr,R2,#1      ;needed end of exponent
    CMPNE  R0,lr
    MOVGT  R0,lr         ;reduce space if possible
    ADD    R6,R0,#1      ;space used by exponent
fwe SUBS   R2,R2,#1
    LDRGEB lr,[R1,R2]
    MOVLT  lr,#"0"
    STRB   lr,[R1,R0]    ;move to end of field
    SUBS   R0,R0,#1
    BGT    fwe
    CMP    lr,#"0"
    MOVEQ  R0,#1
    CMPEQ  R4,#6
    MOVLT  lr,#"E"
    MOVEQ  lr,#"D"
    STRLEB lr,[R1]       ;store E or D
    CMP    ip,#0
    MOVLT  lr,#"-"
    MOVGE  lr,#"+"
    STRB   lr,[R1,R0]    ;store sign
    ADD    R1,R1,R6
;         finished, do accounting
fwf LDR    R2,[sp]       ;original pointer to string
    TST    R8,#&100000   ;if list-directed then
    SUBNE  R0,R1,R2      ;length stored
    LDMNEFD sp!,{R1,R4-R9,pc};return if list-directed
    LDR    R5,[R3,#4]    ;get w
    MOV    R0,R5         ;length to return
    ADD    R5,R5,R2      ;end of string
    MOV    lr,#" "
fwg CMP    R1,R5
    STRLTB lr,[R1],#1    ;blank fill
    BLT    fwg
    LDMFD  sp!,{R1,R4-R9,pc};return
;        checks on rounding the first digits which is liable to problems
fwi CMP    lr,#"9"       ;was it 9?
    BGT    fwk           ;yes, so try again
    CMP    lr,#"1"       ;IF: the rounded number wasn't "0"
    RSBLES lr,R4,#5      ;or it is F format
    LDRLE  lr,ifm
    LDRLE  lr,[lr,#16]
    CMPLE  lr,#0         ;or p>0
    BGT    fwb           ;THEN: OK, go back to truncating
;        fix up the E,D case
    MOV    R6,#"0"
    STRB   R6,[R9],#1    ;make the first digit "0"
    MOV    R6,#"1"       ;the next digit "1"
    ADD    ip,ip,#1      ;fix exponent
fwj LDRB   lr,[R9],#1
    CMP    lr,#"."
    STRNEB R6,[R9,#-1]
    MOVNE  R6,#"0"       ;subsequent digits "0"
    CMP    R9,R1
    BLT    fwj
    B      fwb
;         start again!
fwk LDR    R2,[sp,#4]    ;status word
    LDR    R3,ifm
    LDMIA  R3,{R4-R8}    ;code,w,d,e,p
    LDR    R1,[sp]       ;pointer to output
;                set scale for encoding
    ABSE   F1,F0         ;|R|
    LOGE   F2,F1
    FIXM   ip,F2         ;'n-1'
    ADD    ip,ip,#1      ;but this time increase n by 1
    B      fw1
;
fwl LDR    R5,[R3,#4]    ;error, get w
    MOV    R0,R5
    LDR    R1,[sp]       ;address of result
    MOV    lr,#"*"
fwm SUBS   R5,R5,#1
    STRGEB lr,[R1,R5]    ;fill with '*'
    BGT    fwm
    LDMFD  sp!,{R1,R4-R9,pc}
    END
;
    TTL    io_do_rsne
; to do
;     everything
;
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
sl  RN    10
R9  RN     9
R8  RN     8
R7  RN     7
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    GET s.MaxFl
    AREA   |C$$code|,CODE,READONLY
    EXPORT io_do_rsne;(NUNIT,BLOC,D1,D2,,,,)
    IMPORT io_end
    IMPORT io_start_re
    IMPORT io_do_single
    IMPORT __rt_stkovf_split_small
    IMPORT buffer_io
    DCB    "io_do_rsne",0,0,12,0,0,255
;
io_do_rsne
    MOV    ip,sp
    STMDB  sp!,{R2,R3}   ;store first two result locations on stack
    STMDB  sp!,{R0,R1,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#12     ;pointer to new frame (below R3,R2)
    CMP    sp,sl         ;check stack space
    BLMI   __rt_stkovf_split_small
    MOV    R5,R1         ;address of NAMELIST control block
    LDR    R4,ptr        ;pointer to formatted data buffer
    MVN    R1,#0         ;-1 for list-directed (R0 still points to UNIT)
    BL     io_start_re   ;start reading to stream R0, list directed
    LDR    ip,[R4,#-24]  ;get control word and then check for problems
    TST    ip,#&FF00
    BNE    ret     ; has error set
;       bits must be: 0-7>0, 8-15=0, 24,25=0, 28=0, 29=0
    TST    ip,#&FF
    BEQ    err     ; not open
    TST    ip,#&3000000
    BNE    err     ; not FORMATTED
    MOV    R1,#1
    STR    R1,[R4,#-8]    ;start at column 2
;               now try to find header in file
pt1 BL     find           ;look for "$"; returns R1 as position in buffer
    CMP    R0,#"="
    BEQ    pt1
    BL     compare        ;check name against that of NAMELIST
    BNE    pt1            ;failed,  try next namelist block on file
;
pt2 BL     find           ;look for "="; returns R1 as position in buffer
    CMP    R0,#"="
    BNE    ret            ;found "$" or "&"
    MOV    R9,R1          ;save pointer character after to "=" in data
; search for beginning of name
    SUB    R1,R1,#2
pt3 LDRB   ip,[R4,R1]
    CMP    ip,#" "
    SUBEQ  R1,R1,#1
    BEQ    pt3            ;skip trailing blanks
pt4 LDRB   ip,[R4,R1]
    CMP    ip,#" "
    SUBNE  R1,R1,#1
    BNE    pt4            ;find preceeding blank
    ADD    R1,R1,#1       ;first character of name
    MOV    R8,R1          ;save it
    LDR    R5,[fp,#-40]   ;namelist
    ADD    R5,R5,#17*4    ;go to first entry
    ADD    R6,fp,#4       ;pointer to start of argument list of input addresses
pt5 LDR    ip,[R5]
    CMP    ip,#0
    MOVEQ  R1,R9          ;Restore R1 to point after =
    BEQ    pt2            ;no more entries, so skip this data line
    LDR    R7,[R5,#17*4]  ;load address to read data into
    CMP    R7,#0
    LDREQ  R7,[R6],#4     ;or read it from stack
    BL     compare
    ADD    R5,R5,#20*4    ;point to next entry in namelist    
    MOVNE  R1,R8
    BNE    pt5            ;go try next entry in namelist     
;               match between data and namelist entry
    MOV    R1,R9          ;restore file pointer to after "="
    LDMDB  R5,{R8,R9}     ;load 2 more control words of good entry  
    MOV    R1,R8,LSR#16   ;length
    RSB    R2,R8,#0
    AND    R2,R2,#&FF     ;R2 is type
    CMP    R9,#0          ;check for array
    LDRNE  R9,[R9,#4]     ;get length of array
    MOVEQ  R9,#1          ;if not, only one word
    MOV    R0,R7          ;address to receive data
pt6 BL     io_do_single
    LDRB   ip,[R4,#-23]
    CMP    ip,#0
    BNE    ret            ;return on error
    SUBS   R9,R9,#1
    ADDGT  R0,R0,R1
    BGT    pt6            ;loop through array
    B      pt2
;
compare                   ;compare string at R5 with that at [R4,R1]
;                         ;until zero byte on R5 case insensitive
    MOV    R3,R5
cp1 LDRB   R0,[R3],#1
    CMP    R0,#0
    MOVEQ  pc,lr          ;found, return zero
    CMP    R0,#96
    SUBGT  R0,R0,#32
    LDRB   ip,[R4,R1]
    ADD    R1,R1,#1
    CMP    R1,R2          ;R2 is buffer length, set by "find"
    MOVGT  pc,lr          ;failed
    CMP    ip,#96
    SUBGT  ip,ip,#32
    CMP    R0,ip
    BEQ    cp1            ;loop through aggreeing characters
    MOV    pc,lr          ;failed    
;
ret BL     io_end         ;finished reading
rt1 LDMDB  fp,{R4-R9,fp,sp,pc};return
err MOV    R0,#28         ;error 28
    STRB   R0,[R4,#-23]
    B      ret
ptr DCD    buffer_io+8*max_fl+24      ;address of i/o data
        IMPORT  work__
wrk DCD    work__
;
find                ; find next control character in input (expects R4 to point to buffer)
    STR    lr,[sp,#-4]!
    MOV    R3,#0          ;no apostophe found
pf1 LDR    R1,[R4,#-8]    ;current location in buffer
    LDR    R2,[R4,#-12]   ;length of buffer
    CMP    R1,R2
    BGE    pf4
pf2 LDRB   R0,[R4,R1]
    ADD    R1,R1,#1
    CMP    R0,#"'"        ;check for apostrophe
    EOREQ  R3,R3,#1
    CMP    R3,#0
    BNE    pf3            ;within apostrophies so don't check for R0
    CMP    R0,#"$"
    CMPNE  R0,#"&"
    CMPNE  R0,#"="        ;check for $, & or =
    STREQ  R1,[R4,#-8]    ;store location in buffer
    LDREQ  pc,[sp],#4     ; & return (R1 points to character found)
pf3 CMP    R1,R2
    BLT    pf2            ;look at next character
;           get next buffer
pf4 BL     io_end
    CMP    R0,#0
    BNE    rt1            ;error
    LDR    R0,[fp,#-44]   ;reload unit number             
    MVN    R1,#0          ;-1 for list-directed
    BL     io_start_re    ;read next record
    LDRB   R0,[R4,#-23]   ;error byte
    CMP    R0,#0
    BNE    ret            ;failed, no need to restore stack pointer
    MOV    R1,#1
    STR    R1,[R4,#-8]    ;start at column 2
    B      pf1            ;start looking at next buffer
    END
;
    TTL    io_do_wsne

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 io_do_wsne;(NUNIT,BLOC,D1,D2,,,,)
    IMPORT io_end
    IMPORT io_start_we
    IMPORT io_do_single
    IMPORT io_do_array;(N,*WORD,L,TYPE)
    IMPORT __rt_stkovf_split_small
    GET s.MaxFl
    IMPORT buffer_io
    DCB    "io_do_wsne",0,0,12,0,0,255
;
io_do_wsne
    MOV    ip,sp
    STMDB  sp!,{R2,R3}   ;store first two result locations on stack
    STMDB  sp!,{R0,R1,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#12     ;pointer to new frame (below R3,R2)
    CMP    sp,sl         ;check stack space
    BLMI   __rt_stkovf_split_small
;    LDR    R6,wrk        ; COMMON/WORK/
    MOV    R5,R1         ;address of NAMELIST control block
    ADD    R6,fp,#4      ;pointer to start of argument list of input addresses
    LDR    R4,ptr        ;pointer to formatted data buffer
    MVN    R1,#0         ;-1 for list-directed (R0 still points to UNIT)
    BL     io_start_we   ;start writing to stream R0, list directed
    LDR    ip,[R4,#-24]  ;get control word and then check for problems
    TST    ip,#&FF00
    BNE    ret     ; has error set
;       bits must be: 0-7>0, 8-15=0, 24,25=0, 28=1, 29=0
    TST    ip,#&FF
    BEQ    err     ; not open
    TST    ip,#&3000000
    BNE    err     ; not FORMATTED
    TST    ip,#&10000000
    BEQ    err     ; not open for write
    ADR    R0,hd1
    BL     store   ;write " ="
    MOV    R0,R5   ;address of name of namelist
    BL     store   ;and write iy out
    ADD    R5,R5,#17*4    ;point to first entry
lp1 BL     io_end         ;finished writing this line
    CMP    R0,#0
    LDMNEDB  fp,{R4-R9,fp,sp,pc};return on error
    LDR    R0,[fp,#-44]   ;reload unit number             
    MVN    R1,#0          ;-1 for list-directed
    BL     io_start_we    ;start writing to stream R0, list directed
    LDRB   ip,[R4,#-23]
    CMP    ip,#0
    BNE    ret            ;return on error
    LDR    ip,[R5]
    CMP    ip,#0
    BEQ    fin            ;no more entries
    ADR    R0,hd2
    BL     store
    MOV    R0,R5          ; block name
    BL     store
    ADR    R0,hd3         ;"="
    BL     store
    ADD    R5,R5,#17*4    ;point to control wards
    LDMIA  R5!,{R7-R9}    ; load control words
    CMP    R9,#0          ;check for array
    LDRNE  R9,[R9,#4]
    MOVEQ  R9,#1          ;only one word in "array"
    CMP    R7,#0
    MOVNE  R0,R7          ;address to get data
    LDREQ  R0,[R6],#4
    MOV    R1,R8,LSR#16   ;length
    RSB    R2,R8,#0
    AND    R2,R2,#&FF     ;R2 is type
pt1 CMP    R2,#12         ;test for character string
    BEQ    wrchar
    BL     io_do_single
pt2 SUBS   R9,R9,#1
    BLE    lp1
;           more words in array here
    ADD    R0,R0,R1       ;go to next word
    MOV    ip,#","
pt3 LDR    R3,[R4,#-12]
    STRB   ip,[R4,R3]     ;insert comma
    ADD    R3,R3,#1
    STR    R3,[R4,#-12]   ;update count
;                         check for output overflow
    CMP    R3,#256
    BLT    pt1
    STMFD  sp!,{R0-R2}
    BL     io_end         ;write out line
    LDR    R0,[fp,#-44]   ;reload unit number             
    MVN    R1,#0          ;-1 for list-directed
    BL     io_start_we    ;start next line
    LDMFD  sp!,{R0-R2}
    LDRB   ip,[R4,#-23]
    CMP    ip,#0
    BNE    ret            ;return on error
    MOV    ip,#" "        ;blank first character
    B      pt3
;
fin ADR    R0,hd4
    BL     store
ret BL     io_end         ;finished writing
    LDMDB  fp,{R4-R9,fp,sp,pc};return
err MOV    R0,#21         ;error 21
    STRB   R0,[R4,#1]
    B      ret
ptr DCD    buffer_io+8*max_fl+24      ;address of i/o data
hd1 DCB    " $",0
hd2 DCB    " ",0
hd3 DCB    " = ",0
hd4 DCB    " $","END",0
hd5 DCB    "'",0
    ALIGN
;wrk DCD    work__
;
store  ; store bytes in buffer
    LDR    R1,[R4,#-12]
lps LDRB   ip,[R0],#1
    CMP    ip,#"a"
    RSBGES R3,ip,#"z"
    SUBGE  ip,ip,#"a"-"A"  ; convert to upper case
    CMP    ip,#0
    STRNEB ip,[R4,R1]
    ADDNE  R1,R1,#1
    BNE    lps
    STR    R1,[R4,#-12]  ; new count of bytes in buffer
    MOV    pc,lr
;
wrchar  ; write character string
;  R0 points to input string, R1 is length
    LDR    R3,[R4,#-12] ;get position in output buffer
    ADD    lr,R1,#1
wr1 MOV    ip,#"'"      ;enclosing quotes
wr2 STRB   ip,[R4,R3]
    ADD    R3,R3,#1
    SUBS   lr,lr,#1
    BEQ    wr1
    BLT    wr3          ;finished with a '
    LDRB   ip,[R0],#1
    CMP    ip,#"'"
    STREQB ip,[R4,R3]   ;double a ' in string output
    ADDEQ  R3,R3,#1
    B      wr2
wr3 STR    R3,[R4,#-12] ;store new buffer position
    SUB    R0,R0,R1     ;restore address
    B      pt2     ;return
    END
;
    TTL    io_endfile
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
XOS_Args   EQU &20009
XOS_BPut   EQU &2000B
XOS_GBPB   EQU &2000C
;
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT io_endfile; (UNIT)  write end-of-file
       GET s.MaxFl
    IMPORT buffer_io
    IMPORT wimpprint
    DCB    "io_endfile",0,0,12,0,0,255
;
io_endfile
    MOV    ip,sp
    STMDB  sp!,{R0,R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    AND    ip,R0,#15,4     ;extract flags from unit
    BICS   R1,R0,ip        ;extract unit number
    RSBGTS R0,R1,#max_fl+1 ;check unit number
    MOVLE  R0,#5           ;error 5: illegal unit
    BLE    err
    LDR    R3,ptr
    LDR    R4,[R3,#8*max_fl+8]    ;status word (30/11/2019)
    CMP    R4,#-256
    BEQ    ef1
    LDR    R4,[R3,#8*max_fl+28]    ;unit in use (30/11/2019)
    CMP    R4,R1
    MOVEQ  R0,#30
    BEQ    err
ef1 LDR    R4,[R3,R1,LSL#3]!;status word
    TST    R4,#&20000000
    MOVNE  R0,#16          ;error 16: end-of-file direct access file
    BNE    err
    TST    R4,#&FF         ;  (30/11/2019)
    MOVEQ  R0,#17          ;error 17: file not open
    BEQ    err
    AND    R1,R4,#&FF      ;get stream to write  (30/11/2019)
    TST    R4,#&1000000    ;test for unformatted
    BEQ    pt2
    MOV    R0,#2           ;sequential write
    ADR    R2,eof
    MOV    R3,#6
    SWI    XOS_GBPB        ;write unformatted end-of-file marker
    B      pt3
pt2 MOV    R0,#4
    SWI    XOS_BPut        ;write formatted end-of-file
pt3 MOV    R0,#0
    SWI    XOS_Args        ;get file pointer
    MOV    R0,#3
    SWI    XOS_Args        ;set file extent
;
fin;                 finished
    MOV    R0,#0
    LDMDB  fp,{R4,fp,sp,pc}
;
err;                 error, illegal unit
    TST    ip,#&80000000
    LDMNEDB fp,{R4,fp,sp,pc}
    CMP    R0,#17
    ADREQ  R0,er3
    ADRGT  R0,er4
    CMP    R0,#16
    ADRLT  R0,er1
    ADREQ  R0,er2
    BL     wimpprint
    LDMDB  fp,{R4,fp,sp,pc} ; never gets here
;
ptr DCD    buffer_io-8
er1 DCB    "Illegal unit %d to ENDFILE",0
er2 DCB    "ENDFILE not allowed on direct access unit %d",0
er3 DCB    "File on unit %d not open for ENDFILE",0
er4 DCB    "Can not endfile unit %d while in use",0
eof DCB    "UF",255,255,255,255
    END
;
    TTL   ffsize
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
XOS_Args   EQU &20009
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT ffsize_;(UNIT,NWR,JREC,ISTAT)
;                      returns -1 if illegal unit or file not open
       GET s.MaxFl
    IMPORT buffer_io
    IMPORT __rt_sdiv; R0 = R1/R0  (and R1=|remainder|)
    DCB    "ffsize_",0,8,0,0,255
;
ffsize_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R0]         ;unit #
    CMP    R1,#0
    RSBGTS lr,R1,#max_fl+1 ;check it is legal
    LDRGT  lr,ptr
    LDRGT  R1,[lr,R1,LSL#3];get status word
    ANDGTS R1,R1,#&FF      ;file handle (check it is open)
    BLE    ff0
    MOV    R0,#2           ;to get extent
    SWI    XOS_Args        ;current file extent (R2)
    LDMIB  sp,{R0,R4,ip}   ;(NWR,JREC,ISTAT)
    LDRVC  R0,[R0]         ;NWR
    CMPVC  R0,#0           ;check it is >0
    MOVVSS R0,#0
ff0 MOVLE  R1,#1
    STR    R1,[ip]         ;store ISTAT
    LDMLEDB fp,{R4,fp,sp,pc}
    MOV    R1,R2,LSR#2     ;extent (in 4-byte words)
    BL     __rt_sdiv      ;extent/NWR
    STR    R0,[R4]         ;store JREC
    LDMDB  fp,{R4,fp,sp,pc}
;
ptr DCD    buffer_io-8
    END
;
    TTL   flgetp
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
XOS_Args   EQU &20009
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT flgetp_;(UNIT,KPOINT) get open file pointer in KPOINT
;                      returns -1 if illegal unit or file not open
       GET s.MaxFl
    IMPORT buffer_io
    DCB    "flgetp_",0,8,0,0,255
;
flgetp_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R3,R1           ;save address of KPOINT
    MOV    ip,#0
    BL     args            ;get file pointer in R2
    MOVLE  R2,#-1          ;set -1 if bad file
    STR    R2,[R3]         ;store KPOINT
    LDMDB  fp,{fp,sp,pc}
;
    EXPORT flsetp_;(UNIT,KPOINT) set open file pointer to KPOINT
;                      does nothing if illegal unit, file not open or
;                      KPOINT is not within the size of the file
    DCB    "flsetp_",0,8,0,0,255
;
flsetp_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R1]         ;KPOINT
    MOV    ip,#2
    BL     args            ;get file extent
    LDMLEDB fp,{fp,sp,pc} ;return if bad file
    CMP    R3,R2           ;check that (32-bit) KPOINT <= extent
    MOVLS  R2,R3
    MOVLS  R0,#1
    SWILS  XOS_Args        ;set file pointer
    LDMDB  fp,{fp,sp,pc}
;
args;    do OS_Args
    LDR    R1,[R0]         ;unit #
    MOV    R0,ip           ;command
    CMP    R1,#0
    RSBGTS ip,R1,#max_fl+1 ;check it is legal
    LDRGT  ip,ptr
    LDRGT  R1,[ip,R1,LSL#3];get status word
    ANDGTS R1,R1,#&FF      ;file handle (check it is open)
    MOVLE  pc,lr           ;return LE if no good
    SWI    XOS_Args        ;current file pointer (R2)
    MOVVSS R0,#-1          ;LT   if no good
    MOVVCS R0,#+1          ;GT   if OK
    MOV    pc,lr
;
ptr DCD    buffer_io-8
    END
;
    TTL   flskip
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
XOS_BGet   EQU &2000A
XOS_GBPB   EQU &2000C
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT flskip_;(UNIT,IER) skip to end of file
;       returns IER>0 for error
;                   -1 for physical end-of-file
;                   -2 for logical end-of-file (positions file after it)
       GET s.MaxFl
    IMPORT buffer_io
    DCB    "flskip_",0,8,0,0,255
;
flskip_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,R4,R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]         ;unit #
    SUBS   R0,R0,#1
    RSBGES lr,R0,#max_fl-1       ;check it is legal
    LDRGE  lr,ptr
    LDRGE  R4,[lr,R0,LSL#3];get status word
    ANDGES R1,R4,#&FF      ;file handle (check it is open)
    MOVEQ  R0,#1           ;error 1 if file not open
    MOVLT  R0,#2           ;error 2 for illegal unit number
    BLE    fin
    TST    R4,#&20000000   ;test for direct access
    MOVNE  R0,#3           ;error 3 if direct access file
    BNE    fin
    TST    R4,#&1000000    ;test for formatted
    BNE    unformatted
;       formatted skip here
fm1 SWI    XOS_BGet
    BCS    eof             ;end of file
    BVS    err             ;error reading
    CMP    R0,#4
    BNE    fm1
    B      pof
;
unformatted
    ADD    R5,lr,#32+8*max_fl ;work space +8
    MOV    R0,#0
    STR    R0,[R5,#-8]     ;clear first word
    LDR    lr,uf           ;header test word
    MOV    R0,#4           ;to read from current position
uf1 MOV    R3,#6           ;6 bytes
    SUB    R2,R5,#6        ;to <R5 - 6>
    SWI    XOS_GBPB        ;read header
    BCS    eof             ;end of file
    BVS    err             ;error reading
    LDR    R0,[R2,#-8]     ;get the first 2 bytes
    CMP    R0,lr           ;compare with "UF"
    MOVNE  R0,#5
    BNE    fin             ;not unformatted file!
    LDR    R3,[R2,#-4]     ;record length
    CMP    R3,#-1
    ADDNE  R4,R4,R3        ;skip record contents
    MOVNE  R0,#3           ;to read from R4
    BNE    uf1             ;go to read next record header
;
pof MOV    R0,#-2
    B      fin             ;found logical end-of-file
err MOV    R0,#4
    B      fin
eof MOV    R0,#-1
fin LDR    R1,[sp,#4]
    STR    R0,[R1]         ;store IER
    LDMDB  fp,{R4,R5,fp,sp,pc};and return
;
uf  DCB    0,0,"UF"
ptr DCD    buffer_io
    END
;
    TTL    io_inqu
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R9  RN     9
R8  RN     8
R7  RN     7
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
XOS_Args   EQU &20009
XOS_File   EQU &20008
XOS_Find   EQU &2000D
XOS_GBPB   EQU &2000C
XOS_GSTrans    EQU &20027
XOS_ReadVarVal EQU &20023
    AREA   |C$$code|,CODE,READONLY
    EXPORT io_inqu; (structure)  INQUIRE
    IMPORT wimpprint
       GET s.MaxFl
    IMPORT buffer_io
    IMPORT __rt_sdiv
;
; Structure contains 1 4-byte word for each entry with
;CHARACTER entries immediately followed by their lengths.
;   Input variables (4 entries)
;inerr   ; =0 for no error return, >0 for return error
;UNIT
;*FILE,L          (L=0 if UNIT is defined)
;   Output variables (22 entries)
;        (all passed by reference apart from CHARACTER lengths)
;        (address = 0 if not required result)
;*EXIST       *OPENED        *NUM              *NAMED
;*NAME        LEN            *ACCESS           LEN
;*SEQUENTIAL  LEN            *DIRECT           LEN
;*FORM        LEN            *FORMATTED        LEN
;*UNFORMATTED LEN            *RECL             *NEXTREC
;*BLANK       LEN
;
    DCB    "io_inqu",0,8,0,0,255
io_inqu
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R4,#0
    MOV    R7,R0          ;save pointer to structure
    LDR    R6,[R7,#12]    ;length of file name
    CMP    R6,#0
    BNE    fnam           ;called with file name
;         called with unit, get control words
    LDR    R8,[R7,#4]     ;unit
    CMP    R8,#1
    RSBGES lr,R8,#max_fl
    MOVLT  R6,#-1
    BLT    start          ;illegal unit (R6=-1)
    LDR    ip,ptr
    LDR    R4,[ip,R8,LSL#3]!  ;control word
    ANDS   R1,R4,#&FF     ;file handle
    BEQ    un1            ;not open
    MOV    R0,#7          ;to get name from handle
    LDR    R2,bf1         ;workspace
    MOV    R5,#512        ;length of workspace
    SWI    XOS_Args       ;Get file name ***** RISC-OS 3
    MOVVS  R6,#-2         ;can not find file (R6=-2)
    RSBVC  R6,R5,#512     ;length of name (excluding null)
    LDMIA  ip,{R4,R5}     ;control words
    B      start
;        unit is not open, see if FTnnF001 exists
un1 LDR    R1,bf1
    ADR    R0,tap
    LDMIA  R0,{R2,R3,R6}
    STMIA  R1,{R2,R3,R6}  ;move dummy tape name to buf
    MOV    R2,#10
    MOV    R0,R8
    ADD    R3,R1,#2
un2 MOV    lr,#"0"
un3 SUBS   R0,R0,R2
    ADDGE  lr,lr,#1
    BGT    un3
    ADDLT  R0,R0,R2
    STRB   lr,[R3],#1     ;insert file number
    SUBS   R2,R2,#9
    BGT    un2
    B      nla            ;go and try to read the file
tap DCB    "FT  F001"
    DCD    0
fss DCB    "FileSwitch$CurrentFilingSystem",0
fsn DCB    "FileSwitch$","$CSD",0,"$Lib",0
;
    ALIGN
fnam;     called with file name
    LDR    R1,[R7,#8]     ;address of file name
    LDR    R2,bf1         ;where to store
nl1 LDRB   lr,[R1],#1
    CMP    lr,#" "        ;until blank
    STRGTB lr,[R2],#1
    SUBGTS R6,R6,#1
    BGT    nl1            ;or end of name
    SUBS   R6,R6,#1
    BLE    nl3
nl2 LDRB   lr,[R1],#1
    CMP    lr,#" "
    LDRNE  R1,[R7,#8]     ;         12/02/99
    BNE    err
    SUBS   R6,R6,#1
    BGT    nl2
nl3 MOV    lr,#0
    STRB   lr,[R2]        ;null terminate
    LDR    R0,bf1
    MOV    R8,#-1
    CMP    R2,R0
    BLE    start          ;blank name
    LDR    R1,buf
    MOV    R2,#224
    SWI    XOS_GSTrans    ;translate it to buf, expanding <...>
    BVS    start          ;bad name
    MOV    R5,#0          ;flag for "$" in name
nl4 LDRB   lr,[R1,R2]
    CMP    lr,#"$"
    MOVEQ  R5,#1          ;set $ flag
    SUBS   R2,R2,#1
    BGE    nl4
    CMP    lr,#"@"
    MOVEQ  R5,#0          ;add CSD
    CMP    lr,#"%"
    MOVEQ  R5,#5          ;add Library
    CMP    R5,#1
    LDREQ  R1,bf1
    LDREQ  R3,buf
    BEQ    nl5            ;complete name (includes $)
;        get CSD or Library compete name
    ADR    R0,fss
    LDR    R1,bf1
    MOV    R2,#8
    MOV    R3,#0
    MOV    R4,#0
    SWI    XOS_ReadVarVal
    BVS    start          ;dead
    CMP    R2,#7
    BGT    start
    ADR    R4,fsn
    LDR    R3,bf2         ;set up name "FileSwitch$"+fsname+"$CSD" in bf2
    MOV    R0,#11
fs1 LDRB   lr,[R4],#1
    STRB   lr,[R3],#1     ;transfer "FileSwitch$"
    SUBS   R0,R0,#1
    BGT    fs1
    MOV    R0,R1
    LDR    R1,bf1
fs2 LDRB   lr,[R0],#1
    STRB   lr,[R3],#1     ;transfer fsname
    STRB   lr,[R1],#1     ;also to final output
    SUBS   R2,R2,#1
    BGT    fs2
    ADD    R4,R4,R5
    MOV    R2,#5
fs3 LDRB   lr,[R4],#1
    STRB   lr,[R3],#1     ;transfer "$CSD" ot "$Lib"
    SUBS   R2,R2,#1
    BGT    fs3
    MOV    R0,#":"
    STRB   R0,[R1],#1     ;add ":" after filing system name
    LDR    R0,bf2
    MOV    R2,#256
    MOV    R3,#0
    MOV    R4,#0
    SWI    XOS_ReadVarVal
    BVS    start
    LDR    R3,buf
    ADD    R1,R1,R2       ;end of path name
;
    CMP    ip,#"@"
    CMPNE  ip,#"%"
    ADDEQ  R3,R3,#1       ;either: remove "@" or "%" prefix
    MOVNE  lr,#"."        ;or,
    STRNEB lr,[R1],#1     ;add "." between leaf name and directory
;          add given name to prefix
nl5 LDRB   R0,[R3],#1
    CMP    R0,#" "
    STRGEB R0,[R1],#1
    BGE    nl5
;        loop through open units
    LDR    R9,bf1
    SUB    R6,R1,R9       ;length of name
    CMP    R6,#256
    MOVGE  R8,#0
    BGE    start          ;file name is too long
    MOV    R8,#max_fl     ;changed from #99  22/12/2017
    LDR    ip,pte
nl6 LDR    R4,[ip,#-8]!   ;control word
    ANDS   R1,R4,#&FF     ;file handle
    BEQ    nl8            ;not open
    MOV    R0,#7          ;to get name from handle
    LDR    R2,buf         ;workspace
    MOV    R5,#256        ;length of workspace
    SWI    XOS_Args       ;Get file name ***** RISC-OS 3
    BVS    nl8
    RSB    R3,R5,#256     ;length of name
    CMP    R3,R6
    BNE    nl8            ;different length
nl7 SUBS   R3,R3,#1
    LDMEQIA ip,{R4,R5}    ;get status and record length
    BEQ    start          ;found name
    LDRB   R0,[R2,R3]
    LDRB   R1,[R9,R3]     ; address exception here
    CMP    R0,R1
    BEQ    nl7
nl8 SUBS   R8,R8,#1
    BGT    nl6            ;try next unit
;         not an opened unit, try to see if it exists
    MOV    R1,R9          ;pointer to full file name
nla MOV    R0,#17
    SWI    XOS_File       ;read catalogue info
    BVS    err
    CMP    R0,#1
    MOVNE  R4,#-1
    BNE    start          ;file does not exist
    CMP    R6,#0          ;check if called with non-opened unit number
    MOVEQ  R6,#8          ;set length of dummy name
    MOVEQ  R8,#0          ;initialise non-existence flag
    MOV    ip,R2,LSL#12
    MOV    ip,ip,LSR#20   ;file type
    MOV    R0,#&4F
    SWI    XOS_Find       ;open file
    BVS    start          ;file already open!
    MOV    R1,R0
    MOV    R0,#4
    LDR    R2,bf2
    ADD    R2,R2,#2
    MOV    R3,#6
    SWI    XOS_GBPB       ;read 6 bytes
    MOV    R0,#0
    SWI    XOS_Find       ;close file
    LDR    R0,[R2,#-8]
    MOV    R0,R0,LSR#16   ;get the 2 bytes
    MOV    R4,#0          ;no status yet
    LDR    R1,da
    CMP    R1,R0
    LDREQ  R5,[R2,#-4]    ;get the 'record length' for direct access
    ORREQ  R4,R4,#&20000000;set 'direct access' bit
    CMP    R8,#0
    MOVEQ  R8,#256        ;flag file exists but not open
    SUB    R2,ip,#&FF0
    CMP    R2,#&D         ;check for data file type (&FFD)
    BNE    nlb
    LDR    lr,uf
    CMP    lr,R0          ;and UF
    CMPNE  R1,R0          ;or DA
    ORREQ  R4,R4,#&1000000;set 'unformatted' bit
nlb CMPNE  R2,#&F         ;check for formatted text file
    ORRNE  R4,R4,#&3000000;set 'unknown' format
;
start;        found out what's going on:
;
;  R7    :pointer to control structure
;
;               called with unit #
;  R6  -2: opened file but can't find it (should never happen)
;       0: unit given but not found
;      >0: length of file name (in bf1)
;  R8    : unit #
;
;               called with name
;  R6     : effective length of name (=0 if R8=-1)
;  R8  -1 : blank name
;       0 : file does not exist
;     1->max_fl: unit number
;      256: file exists but is not open
;
;       EXIST
    CMP    R6,#0
    CMPGE  R8,#0
    MOVGT  R0,#1          ;does exist
    MOVLE  R0,#0          ;does not exist
    LDR    R1,[R7,#16]!
    CMP    R1,#0
    STRGT  R0,[R1]
;       OPENED
    CMP    R8,#0
    RSBGTS lr,R8,#100
    CMPGT  R6,#0
    MOVGT  R0,#1          ;file is open
    MOVLE  R0,#0          ;file not open
    LDMIB  R7!,{R1-R3,ip,lr}
    CMP    R1,#0
    STRGT  R0,[R1]
;       NUMBER
    MOVS   R0,R8
    RSBGTS R1,R8,#100
    MOVLE  R0,#0          ;unit number or zero
    CMP    R2,#0
    STRGT  R0,[R2]
;       NAMED      (units 5 and 6 are not named)
    CMP    R6,#0
    MOVLE  R0,#0
    MOVGT  R0,#1
    CMP    R3,#0
    STRGT  R0,[R3]
;       NAME
    CMP    ip,#0
    BLE    sp1            ;no name
    LDR    R1,bf1         ;temporary store for null-terminated file name
    MOV    R2,R6
ls1 SUBS   R2,R2,#1
    LDRGEB R0,[R1],#1
    MOVLT  R0,#" "
    SUBS   lr,lr,#1
    STRGEB R0,[ip],#1     ;transfer name
    BGT    ls1
;       ACCESS
sp1 MOV    R9,R4,LSR#29
    AND    R9,R9,#1       ;SEQUENTIAL or DIRECT
    MOV    R2,R9
    CMP    R6,#0
    CMPGT  R8,#0
    MOVLE  R2,#2          ;UNKNOWN
    BL     get_name
;       SEQUENTIAL
    ADD    R2,R9,#3       ;SEQUENTIAL or DIRECT (YES/NO)
    CMP    R6,#0
    CMPGT  R8,#0
    MOVLE  R2,#2          ;UNKNOWN
    BL     get_name
;       DIRECT
    RSB    R2,R9,#4       ;SEQUENTIAL or DIRECT (NO/YES)
    CMP    R6,#0
    CMPGT  R8,#0
    MOVLE  R2,#2          ;UNKNOWN
    BL     get_name
;       FORM
    MOV    R9,R4,LSR#24
    AND    R9,R9,#3
    ADD    R2,R9,#5       ;FORMATTED, UNFORMATTED, PRINTER
    RSBS   lr,R6,#0
    CMPLT  R9,#3
    MOVGE  R2,#2          ;UNKNOWN
    BL     get_name
;       FORMATTED
    AND    R2,R9,#1       ;FORMATTED, UNFORMATTED (YES/NO)
    ADD    R2,R2,#3
    RSBS   lr,R6,#0
    CMPLT  R9,#3
    MOVGE  R2,#2          ;UNKNOWN
    BL     get_name
;       UNFORMATTED
    AND    R2,R9,#1       ;FORMATTED, UNFORMATTED (NO/YES)
    RSB    R2,R2,#4
    RSBS   lr,R6,#0
    CMPLT  R9,#3
    MOVGE  R2,#2          ;UNKNOWN
    BL     get_name
;       RECL
    LDMIB  R7!,{R0,ip}
    ANDS   R2,R4,#&20000000
    MOVNE  R2,R5
    CMP    R0,#0
    STRNE  R2,[R0]
;       NEXTREC
    MOV    R0,#0
    AND    R1,R4,#&FF
    CMP    ip,#1
    CMPGT  R1,#0
    TSTGT  R4,#&20000000  ;check it is direct access
    STREQ  R0,[ip]
    BLE    sp3
    SWI    XOS_Args       ;get file pointer
    SUB    R1,R2,#6       ;take off header
    MOV    R0,R5
    BL     __rt_sdiv     ;divide R1 by R0
    ADD    R0,R0,#1
    LDR    ip,[R7]
    STR    R0,[ip]
;       BLANK
sp3 MOV    R2,R4,LSR#23
    AND    R2,R2,#1       ;NULL, ZERO
    ADD    R2,R2,#8
    CMP    R6,#0
    CMPGT  R8,#0
    MOVLE  R2,#2          ;UNKNOWN
    BL     get_name
    MOV    R0,#0          ;no error
    LDMDB  fp,{R4-R9,fp,sp,pc};return
;
get_name;  get name (R2) from list and store it in string {R7}
    LDMIB  R7!,{R0,R1}
    CMP    R0,#0
    MOVLE  pc,lr          ;not needed
    ADR    R3,lst
gl1 SUBS   R2,R2,#1
    LDRB   ip,[R3],#1
    ADDGE  R3,R3,ip
    BGE    gl1
gl2 SUBS   ip,ip,#1
    LDRGEB R2,[R3],#1
    MOVLT  R2,#" "
    SUBS   R1,R1,#1
    STRGEB R2,[R0],#1
    BGT    gl2
    MOV    pc,lr
;
ptr DCD    buffer_io-8
pte DCD    buffer_io+max_fl*8
buf DCD    buffer_io+max_fl*8+24
bf1 DCD    buffer_io+max_fl*8+24+256
bf2 DCD    buffer_io+max_fl*8+24+224
da  DCB    "DA",0,0
uf  DCB    "UF",0,0
;
lst DCB    10,"SEQUENTIAL"
    DCB    6,"DIRECT"
    DCB    7,"UNKNOWN"
    DCB    3,"YES"
    DCB    2,"NO"
    DCB    9,"FORMATTED"
    DCB    11,"UNFORMATTED"
    DCB    7,"PRINTER"
    DCB    4,"NULL"
    DCB    4,"ZERO"
;
    ALIGN
err;    error in file name
    LDR    R7,[sp]
    LDR    R0,[R7]        ;input error flag
    CMP    R0,#0
    MOVNE  R0,#101
    LDMNEDB fp,{R4-R9,fp,sp,pc};return error = 101
    ADR    R0,erm
    BL     wimpprint
    LDMDB  fp,{R4-R9,fp,sp,pc}; never gets here
erm DCB    "INQUIRE given illegal FILE: %s",0
;
    END
;
    TTL    io_rewind
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
XOS_Args   EQU &20009
;
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT io_rewind; (UNIT)  rewind external
       GET s.MaxFl
    IMPORT buffer_io
    IMPORT wimpprint
    DCB    "io_rewind",0,0,0,12,0,0,255
;
io_rewind
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    AND    ip,R0,#15,4     ;extract flags from unit
    BICS   R1,R0,ip        ;extract unit number
    RSBGTS R0,R1,#max_fl+1 ;check unit number
    MOVLE  R0,#5           ;error 5: illegal unit
    BLE    err
    LDR    R3,ptr
    LDR    ip,[R3,#8*max_fl+8];I/O status word
    CMP    ip,#-256
    BEQ    rw1
    LDR    ip,[R3,#8*max_fl+28];currently used unit
    CMP    ip,R1
    MOVEQ  R0,#30          ;error 30: recursive use of unit
    BEQ    err
rw1 LDR    ip,[R3,R1,LSL#3]!;status word
    TST    ip,#&20000000
    MOVNE  R0,#14          ;error 14: rewinding direct access file
    BNE    err             ;direct access file
    ANDS   R1,ip,#&FF
    BNE    pt1             ;open file
    TST    ip,#&400000     ;test for vdu
    TSTNE  ip,#&10000000
    MOVEQ  R0,#15          ;error 15: file not open
    BEQ    err
    SWI    &11E            ;VDU30 (home)
    B      fin
;
err;     errors here
    TST    ip,#&80000000
    LDMNEDB fp,{fp,sp,pc}
    CMP    R0,#15
    ADREQ  R0,er3
    ADRGT  R0,er4
    CMP    R0,#14
    ADRLT  R0,er1
    ADREQ  R0,er2
    BL     wimpprint
    LDMDB  fp,{fp,sp,pc} ; never gets here
er1 DCB    "Illegal unit %d to REWIND",0
er2 DCB    "REWIND not allowed on direct access unit %d",0
er3 DCB    "File on unit %d not open to REWIND",0
er4 DCB    "Can not rewind unit %d while in use",0
    ALIGN
;
pt1 MOV    R2,#0
    MOV    R0,#1
    SWI    XOS_Args        ;set file pointer to zero
;
fin;                 finished
    MOV    R0,#0
    LDMDB  fp,{fp,sp,pc}
;
ptr DCD    buffer_io-8
    END
;
    TTL    io_start_end
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R9  RN     9
R8  RN     8
R7  RN     7
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
XOS_Args    EQU &20009
XOS_BGet    EQU &2000A
XOS_BPut    EQU &2000B
XOS_Find    EQU &2000D
XOS_GBPB    EQU &2000C
OS_Byte     EQU &6
OS_ReadLine EQU &0E
OS_WriteN   EQU &46
OS_WriteCR  EQU &10D
OS_WriteLF  EQU &10A
XOS_ReadVarVal EQU &20023
buf_len     EQU 512  ; size of ASCII buffer (also defined in main)
maxpar      EQU 10   ; maximum parenthesis depth
    AREA   |C$$data|,DATA
format_io
    %     20  ;5 result words
    %      4  ;pointer to current position in format
    %      4  ;current count
    %      4  ;parenthesis depth
;         then for each parenthesis
    %      8*maxpar ;position and remaining count
dumtap
    DCB    "FT  F001",0,0,0,0
;
    AREA   |C$$code|,CODE,READONLY
;         communications with Fortran
    EXPORT io_opens; (UNIT,*STATUS,*FILE,LFILE)
    EXPORT io_open;(UNIT,*STATUS,*FILE,LFILE,*ACCESS,*FORM,*BLANK,LRECL)
    EXPORT io_start_ri; (*BUF,*FORMAT,LBUF,NBUF) start internal input
    EXPORT io_start_wi; (*BUF,*FORMAT,LBUF,NBUF) start internal output
    EXPORT io_start_re; (UNIT,*FORMAT,IREC) start external input
    EXPORT io_start_we; (UNIT,*FORMAT,IREC) start external output
    EXPORT io_end; => error code
;         communications with io_do_single
    EXPORT format_io
    EXPORT get_buffer;   fills buffer for formatted I/O
    EXPORT send_buffer;   write buffer for formatted I/O
    EXPORT format_next;
    EXPORT format_write;(IOFLG)
    EXPORT format_read;
;
    IMPORT io_close
    IMPORT wimpprint
    IMPORT key_word
       GET s.MaxFl
    IMPORT buffer_io
;
    DCB    "io_opens",0,0,0,0,12,0,0,255
;
io_opens
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R4,#0
    B      pt3
;
    DCB    "io_open",0,8,0,0,255
;
io_open
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[sp,#44]    ;*ACCESS
    CMP    R0,#0
    MOVEQ  R4,#0
    BEQ    pt1
    BL     key_word
    SUBS   R0,R0,#8
    RSBGES R1,R0,#2
    MOVLT  R0,#1
    BLT    err            ;unknown ACCESS
    MOV    R4,R0,LSL#29   ;start unit control word image
pt1 LDR    R0,[sp,#52]    ;*BLANK
    CMP    R0,#0
    BEQ    pt2
    BL     key_word
    SUBS   R0,R0,#11
    RSBGES R1,R0,#1
    MOVLT  R0,#2
    BLT    err            ;unknown BLANK
    ORR    R4,R4,R0,LSL#23;store blank bit
pt2 LDR    R0,[sp,#48]    ;*FORM
    CMP    R0,#0          ;if no FORM= then                       23/11/98
    MOVEQ  R0,R4,LSR#29   ; set to default: FORMATTED for sequential access
    ANDEQ  R0,R0,#1       ; remove APPEND bit                     19/12/98
    BEQ    ptf            ; or UNFORMATTED for DIRECT access      23/11/98
    BL     key_word
    SUBS   R0,R0,#1
    RSBGES R1,R0,#2
    MOVLT  R0,#3
    BLT    err            ;unknown FORM
    CMP    R0,#1          ;test for 'PRINTER'
    TSTGT  R4,#&20000000  ;test for 'DIRECT' access
    MOVGT  R0,#1
    BGT    err            ;'PRINTER' and 'DIRECT' not allowed
ptf ORR    R4,R4,R0,LSL#24;store 2 form bits
pt3 LDR    R0,[sp,#4]     ;*STATUS
    MOVS   R6,R0
    BEQ    pt4            ;UNKNOWN
    BL     key_word
    SUBS   R6,R0,#4       ;STATUS 0: Unknown, 1: Old, 2: New, 3: Scratch
    RSBGES R1,R6,#3
    MOVLT  R0,#4
    BLT    err            ;illegal STATUS
pt4 LDR    R0,[sp]        ;UNIT
    BIC    R0,R0,#15,4
    CMP    R0,#max_fl
    RSBLES R1,R0,#1
    MOVGT  R0,#5
    BGT    err            ;illegal unit #
opn LDR    ip,ptr
    LDR    R1,[ip,#8*max_fl+8]   ;get i/o status
    CMP    R1,#-256
    MOVNE  R0,#30
    BNE    err
    LDR    R1,[ip,R0,LSL#3]! ;get old status
    TST    R1,#&400000    ;test for interactive unit
    MOVNE  R0,#9          ;error 9: not allowed to open interactive unit
    BNE    err
    TST    R1,#&FF        ;check if file open
    BEQ    op1
    MOV    R1,#0
    BL     io_close       ;close (with no STATUS) it if it is open
    MOV    R0,R1          ;restore unit #
    LDR    ip,ptr
    ADD    ip,ip,R0,LSL#3 ;restore status pointer
op1 LDR    R2,[sp,#12]    ;file name length
    CMP    R2,#0
    LDRNE  R0,[sp,#8]     ;file name address
    BNE    pt5
    LDR    R1,fnn
    MOV    R5,#10
op2 MOV    lr,#"0"
op3 SUBS   R0,R0,R5
    ADDGE  lr,lr,#1
    BGT    op3
    ADDLT  R0,R0,R5
    STRB   lr,[R1],#1
    SUBS   R5,R5,#9
    BGT    op2
    SUB    R0,R1,#4       ;address of 'FORnnF001'
;
    LDR    R1,buf         ;address for new name
    MOV    R2,#256
    MOV    R3,#0
    STMFD  sp!,{R0,R4}    ;save R0,R4
    MOV    R4,#0
    SWI    XOS_ReadVarVal
    LDMFD  sp!,{R0,R4}    ;restore R0,R4
    CMP    R2,#0
    MOVGT  R0,R1          ;found variable
;
    MOVLE  R2,#8
pt5 CMP    R2,#512
    MOVHI  R2,#512
    LDR    R1,buf         ;temporary store for null-terminated file name
    MOV    R5,#0
lp1 STRB   R5,[R1,R2]
    SUBS   R2,R2,#1
    LDRGEB R5,[R0,R2]
    BGE    lp1
;       check new RECL for direct access
    TST    R4,#&20000000
    LDRNE  R5,[sp,#56]
    CMPNE  R5,#1
    BLT    ptd            ;RECL<=0 for direct access
;        try to open exisiting file
    MOV    R0,#&CF
    SWI    XOS_Find
    BVC    ptb            ;file exists
    CMP    R6,#1          ;does not exist, check for OLD
    MOVEQ  R0,#6
    BEQ    err            ;OLD does not exist
    MOVLT  R6,#2          ;make UNKNOWN into NEW
;        try to open new file
    MOV    R0,#&8F
    SWI    XOS_Find
    MOVVS  R0,#7
    BVS    err            ;can not open new file
pt7 TST    R4,#&1000000   ;test for formatted
    MOVEQ  R5,#buf_len    ;length of formatted buffer
    MOVNE  R5,#-1         ;dummy for unformatted
    MOV    R1,R0          ;file handle into R1 for OS_Args/OS_GBPB
    ORR    R4,R4,R0       ;insert file handle
    ORR    R4,R4,R6,LSL#26;store 2 STATUS bits
    TST    R4,#&20000000  ;test for DIRECT
    BEQ    pt8
    LDR    R2,buf
    LDR    R0,dac         ;direct access code
    LDR    R5,[sp,#56]    ;LRECL
    AND    lr,R4,#&1000000
    TEQ    lr,#&1000000   ;test for formatted
    RSBNES lr,R5,#buf_len ;check for formatted record longer than buffer
    CMPGE  R5,#1          ;check for positive length
    BLT    ptc            ;illegal record length
    STMIA  R2,{R0,R5}     ;store code and length
    ADD    R2,R2,#2
    CMP    R6,#1          ;test for old
    MOV    R3,#6          ;6 bytes in header
    MOVNE  R0,#2          ;code to write
    MOVEQ  R0,#4          ;code to read
    MOV    lr,R4
    SWI    XOS_GBPB       ;transfer data
    MOV    R4,lr
    CMP    R6,#1          ;test for old (again)
    BNE    pt8
    LDMDB  R2,{R2,R3}
    LDR    R0,dac         ;direct access code
    CMP    R2,R0
    BEQ    ptm
    MOV    R0,#0
    SWI    XOS_Find       ;close the file
    MOV    R0,#10         ;error 10: old file is not direct access
    B      err
ptm CMP    R3,R5
    MOVGT  R5,R3          ;set record length to the old value
    BLT    ptc            ;illegal record length
pt8 TST    R4,#&40000000  ;test for APPEND
    BICNE  R4,R4,#&40000000
    CMPNE  R6,#2          ;if APPEND, test for OLD also
;        position file for APPEND
    BGE    ptn
    MOV    R0,#2
    SWI    XOS_Args       ;read extent into R2
    MOV    R0,#1
    SWI    XOS_Args       ;set pointer to extent
ptn STMIA  ip,{R4,R5}     ;store unit control words
    MOV    R0,#0
    LDMIB  sp,{R1-R6,fp,sp,pc}; all done OK
;
io_open_new;               open new file for io_start
    STMFD  sp!,{R3,lr}
    CMP    R1,#0
    ORREQ  R4,R4,#&1000000;Formatted/unformatted
    ADR    lr,pta
    ORR    R0,R9,#2,2     ;unit # with ERR=
    MOV    ip,sp
    MOV    R3,#0          ;no file name
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}; keep the io_start frame
    MOV    R0,R9          ;unit # without ERR=
    TST    R4,#&10000000  ;test for write
    MOVEQ  R6,#1          ;read => OLD
    MOVNE  R6,#0          ;write => UNKNOWN
    B      opn            ;open new file
pta CMP    R0,#0          ;check for error
    LDMFD  sp!,{R3,lr}
    RSBGTS R0,R0,#0       ; set N flag on error
    LDMEQIA ip,{R0,R5}    ;restore unit control words for io_start
    MOV    pc,lr          ;return
;
ptb;     existing file opened
    CMP    R6,#1
    MOVLT  R6,#1          ;make UNKNOWN into OLD
    BLE    pt7
    MOV    R1,R0
    MOV    R0,#0
    SWI    XOS_Find       ;close the file (it exists illegally)
    MOV    R0,#8          ;error 8: NEW file exists
    B      err
;
ptc;     illegal direct access record length
    MOV    R0,#0
    SWI    XOS_Find       ;close the file
ptd MOV    R0,#11         ;error 11: requested LRECL is in error
    MOV    R1,R5          ;LRECL
    TST    R4,#&1000000
    ADR    R2,ufm         ;unformatted
    ADDEQ  R2,R2,#2       ;formatted
;
err;                    error
    LDR    ip,[sp]        ;get ERR= flag
    TST    ip,#&80000000
    LDMNEIB sp,{R1-R6,fp,sp,pc};report error to calling program
    CMP    R0,#11
    MOVNE  R1,ip
    MOVEQ  R3,ip
    CMP    R0,#30
    ADRNE  lr,erp-4
    LDRNE  R0,[lr,R0,LSL#2]
    ADREQ  R0,m30
    BL     wimpprint      ;print message
    LDMIB  sp,{R1-R6,fp,sp,pc}; never gets here
;
erp DCD    ms1
    DCD    ms2
    DCD    ms3
    DCD    ms4
    DCD    ms5
    DCD    ms6
    DCD    ms7
    DCD    ms8
    DCD    ms9
    DCD    m10
    DCD    m11
;
fnn DCD    dumtap+2
dac DCB    0,0,"DA"
ufm DCB    "unformatted",0
UF  DCB    0,0,"UF"
;
m30 DCB    "Can not open unit %d while using I/O",0
ms1 DCB    "Illegal ACCESS code in OPEN for unit %d",0
ms2 DCB    "Illegal BLANK code in OPEN for unit %d",0
ms3 DCB    "Illegal FORM code in OPEN for unit %d",0
ms4 DCB    "Illegal STATUS code in OPEN for unit %d",0
ms5 DCB    "Illegal unit number in OPEN: %d",0
ms6 DCB    "Can not open OLD file for unit %d",0
ms7 DCB    "Can not open NEW file for unit %d",0
ms8 DCB    "Can not open existing file as NEW (or SCRATCH) on unit %d",0
ms9 DCB    "Can not open an interactive unit (%d)",0
m10 DCB    "OLD file is not direct access on unit %d",0
m11 DCB    "illegal record length (%d) for %s direct access file"
    DCB    " on unit %d",0
    ALIGN
;
    DCB    "io_start_ri",0,12,0,0,255
;
io_start_ri
    MOV    ip,sp
    STMDB  sp!,{R1,R4-R9,fp,ip,lr,pc}
    MOVS   R4,#0          ;clear status word for read
    B      wi1
;
    DCB    "io_start_wi",0,12,0,0,255
;
io_start_wi
    MOV    ip,sp
    STMDB  sp!,{R1,R4-R9,fp,ip,lr,pc}
    MOVS   R4,#&10000000  ;bit 28 for writing
wi1 SUB    fp,ip,#4
    MOV    R6,R0          ;'buffer' address
    RSB    R9,R3,#0       ;-(number of 'buffers')
    AND    lr,R2,#15,4    ;extract flags from LBUF
    ORR    R4,R4,lr       ;store in status word
    BIC    R5,R2,lr       ;extract 'buffer' length
    SUBEQ  R9,R9,#1       ;back down 1 buffer for first read
    SUBEQ  R6,R6,R5
    CMP    R1,#0          ;check *FORMAT
    ORREQ  R4,R4,#&1D00   ;error 29: unformatted is not allowed
    BEQ    fin
    B      st2
;
    DCB    "io_start_re",0,12,0,0,255
;
io_start_re
    MOV    ip,sp
    STMDB  sp!,{R1,R4-R9,fp,ip,lr,pc}
    MOV    R4,#0          ;clear status word for read
    B      we1
;
    DCB    "io_start_we",0,12,0,0,255
;
io_start_we
    MOV    ip,sp
    STMDB  sp!,{R1,R4-R9,fp,ip,lr,pc}
    MOV    R4,#&10000000  ;bit 28 for writing
we1 SUB    fp,ip,#4
    AND    lr,R0,#15,4    ;extract flags from unit
    ORR    R4,R4,lr       ;store in status word
    BICS   R9,R0,lr       ;extract unit number
    RSBNES ip,R9,#max_fl+1;check unit number
    ORRLE  R4,R4,#&1700   ;error 23: illegal unit
    BLE    fin
    LDR    R0,ptr
    ADD    R0,R0,R9,LSL#3
    LDMIA  R0,{R0,R5}     ;load control words for unit
    TST    R0,#&FF        ;check file is open
    TSTEQ  R0,#&400000    ;or is on-line
    BLEQ   io_open_new
    ORRMI  R4,R4,#&1600   ;error 22: can not open file
    BMI    fin            ;failed
    AND    ip,R4,#&20000000;direct access bit from input UNIT
    AND    lr,R0,#&20000000;direct access bit control word
    EORS   ip,ip,lr
    ORRNE  R4,R4,#&1800   ;error 24 for direct access clash
    BNE    fin
    TST    R1,lr,LSL #2   ;test for direct access and list directed   07/10/99
    ORRNE  R4,R4,#&1F00   ;error 31 for list-directed i/o to direct access file
    BNE    fin            ; end fix for 07/10/99
    ORR    R4,R4,R0       ;insert control info
    TST    R4,#&20000000  ;test direct access bit
    BEQ    st1
    SUBS   R3,R2,#1
    MULGE  ip,R5,R3
    ADDGE  ip,ip,#6       ;address of direct access record
    ANDGE  R1,R4,#&FF     ;file handle
    TSTGE  R4,#&10000000  ;test for reading
    BNE    st0
    MOV    R0,#2
    SWI    XOS_Args       ;get extent
    CMP    R2,ip
st0 ORRLE  R4,R4,#&1400   ;error 20: direct access read beyond file
    MOVLE  R8,R9          ;unit #
    ADDLE  R9,R3,#1       ;record number
    BLT    fin
    MOV    R0,#1
    MOV    R2,ip
    SWI    XOS_Args       ;point to record
    ORRVS  R4,R4,#&1C00   ;error 28: can not access file
    BVS    fin
st1 LDR    R1,[sp]        ;restore *FORMAT
    CMP    R1,#0          ;check *FORMAT
    BEQ    unf            ;unformatted
    LDR    R6,buf         ;buffer address
st2 MOV    R7,#0
    MOV    R8,#0
    MOV    R0,#0
    LDR    ip,frw         ;pointer to format_io+16
    STMIA  ip,{R0,R1,R7,R8};zero (p) and initialise FORMAT
    STR    R0,[ip,#-8]    ;zero (d)
    ORRLT  R4,R4,#&100000 ;set list-directed bit
    MOVLT  lr,#-1
    STRLT  lr,[ip,#4]     ;initialise the list-directed repeat count
    LDR    ip,buf
    LDR    lr,[ip,#-24]   ;get status word
    CMP    lr,#-256
    MOVNE  R4,#&1E00      ;error 30: IO is active
    BNE    fin
    TST    R4,#&1000000   ;test UNFORMATTED bit
    ORRNE  R4,R4,#&1900   ;error 25 for unformatted file
    TSTEQ  R4,#&10000000  ;test for reading
    BNE    fin
    STR    R9,[ip,#-4]
    BL     get_buffer     ;fill formatted buffer
    LDR    ip,buf
    LDR    R9,[ip,#-4]
    B      fin
;        unformatted record
unf TST    R4,#&1000000   ;test UNFORMATTED bit
    ORREQ  R4,R4,#&1A00   ;error 26 for formatted file
    BEQ    fin
    AND    R1,R4,#&FF
    MOV    R0,#0
    SWI    XOS_Args       ;read file pointer
    MOV    R6,R2          ;and save it
    MOV    R7,#0          ;no bytes read
    TST    R4,#&20000000  ;test for direct-access
    BNE    fin
    TST    R4,#&10000000  ;test for write
    MOVNE  R0,#2          ;write
    ADRNE  R2,UF          ;UFxxxx
    MOVEQ  R0,#4          ;read
    LDREQ  R2,buf         ;to workspace
    ADD    R2,R2,#2
    MOV    R3,#6          ;6 bytes
    MOV    ip,R4
    SWI    XOS_GBPB       ;read/write header
    MOV    R4,ip
    ORRCS  R4,R4,#&FF00   ;set end-of-file flag
    BCS    fin
    ORRVS  R4,R4,#&1500   ;error 21: can not write to file
    BVS    fin
    TST    R4,#&10000000  ;test for write (again)
    MOVNE  R5,#-1
    BNE    fin            ;writing
    LDMDB  R2,{R0,R5}
    MOV    R0,R0,LSR#16
    LDR    lr,UF
    CMP    lr,R0,LSL#16
    ORRNE  R4,R4,#&1B00   ;error 27: for not unformatted record
    BNE    fin
    CMP    R5,#0
    ORRLE  R4,R4,#&FE00   ;software end-of-file
;
fin;                 finished, store control words
    LDR    ip,buf
    STMDB  ip,{R4-R9}     ;store 6 control words
    MOV    R0,#229
    MOV    R1,#0
    MOV    R2,#0
    SWI    OS_Byte        ;enable escape
    STR    R1,[ip,#buf_len+8];store old escape status
    LDMDB  fp,{R4-R9,fp,sp,pc}
;
firsterr  EQU  20         ;first error expected by io_end
lasterr   EQU  61         ;last error expected by io_end
;
    DCB    "io_end",0,0,8,0,0,255
;
io_end
    MOV    ip,sp
    STMDB  sp!,{R4-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,buf
    MOV    R0,#229
    LDR    R1,[ip,#buf_len+8];restore old escape status
    MOV    R2,#0
    SWI    OS_Byte
    MOV    R0,#124
    SWI    OS_Byte        ;clear escape
    LDMDB  ip,{R4-R8,lr}  ;control words
    CMP    R4,#-256       ;check I/O is active
    LDMEQDB fp,{R4-R8,fp,sp,pc};return if not to avoid recursive problems
    TST    R4,#&FF00      ;check for no error
    BNE    nd1
    TST    R4,#&1000000
    BNE    unformatted    ;unformatted
    TST    R4,#&10000000  ;test for WRITE
    BNE    wre            ;writing                      start 25/10/1999
    TST    R4,#&100000
    BNE    nd1            ;list-directed
rb1 BL     format_next
    LDMIA  R0,{R1,R2}
    CMP    R1,#0
    CMPEQ  R2,#1          ;check for '/'
    BNE    nd1
    BL     get_buffer
    BVS    nd1
    B      rb1
wre TST    R4,#&100000    ;test for not list-directed
    BNE    wrs
    BL     format_next
    MOV    R0,#1          ;signifies no more buffers
    BL     format_write   ;then satisfy trailing part of format
    B      nd1
wrs BL     send_buffer
nd1 LDR    ip,buf
    MOV    R0,#-256
    STR    R0,[ip,#-24]   ;make I/O inactive
    ANDS   R0,R4,#&FF00   ;extract error code
    SUBNES R0,R0,#&FD00   ;skip end of list-directed input
    LDMEQDB fp,{R4-R8,fp,sp,pc};return if no error
    MOV    R0,R4,LSL#16
    MOVS   R0,R0,ASR#24   ;extract error number with sign
    MOVMIS lr,R4,LSL#1    ;if end-of-file, check for "END="
    LDMMIDB fp,{R4-R8,fp,sp,pc};return end-of-file (-1,-2) if END= or IOSTAT
    LDR    R1,[ip,#-4]    ;first arg is unit number
    CMP    R0,#-1         ;check for end-of-file
    ADRLT  R0,em2         ;end of logical file
    ADREQ  R0,em1         ;real end of file
    BLLE   wimpprint      ;send 'end-of-file' message and die
;
    CMP    R0,#48         ;check for format syntax error
    MOVNE  R2,R8          ;other 2 arguments if needed
    MOVNE  R3,R7
    BNE    er1
    LDR    R3,res
    LDR    lr,[R3]        ;format error number
    CMP    lr,#-256
    ANDLT  R2,lr,#&FF     ;ASCII character
    ADDGE  R0,lr,#49+12   ;convert format error -12 into code 49 etc
    ADR    R1,em3
er1 TST    R4,#&80000000
    LDMNEDB fp,{R4-R8,fp,sp,pc};return error number if ERR= or IOSTAT
    CMP    R0,#61         ;check for illegal input error
    RSBGES ip,R0,#67
    BLT    er2
    ADR    R1,bin
el1 CMP    R0,#61         ;find appropriate message
    BEQ    er2
    LDRB   R3,[R1],#1
    CMP    R3,#0
    BNE    el1
    SUB    R0,R0,#1
    B      el1
er2 SUBS   R0,R0,#firsterr;protect against stupid errors
    RSBGES R4,R0,#lasterr-firsterr
    ADDLT  R1,R0,#firsterr
    ADRLT  R0,em4
    ADRGE  R4,erl
    LDRGE  R0,[R4,R0,LSL#2]
    BL     wimpprint      ;send error message and die
    LDMDB  fp,{R4-R8,fp,sp,pc}; never gets here
    
em2 DCB    "software "
em1 DCB    "end-of-file detected on unit %d",0
em3 DCB    "Error decoding FORMAT",13,10,0
bin DCB    "binary",0,"logical",0,"octal",0,"hexadecimal",0
    DCB    "integer",0,"floating",0,"complex",0
em4 DCB    "Unknown I/O error %d",0
;
    ALIGN
erl DCD    e20
    DCD    e21
    DCD    e22
    DCD    e23
    DCD    e24
    DCD    e25
    DCD    e26
    DCD    e27
    DCD    e28
    DCD    e29
    DCD    e30
    DCD    e31
    DCD    e32
    DCD    e33
    DCD    e34
    DCD    e35
    DCD    e36
    DCD    e37
    DCD    e38
    DCD    e39
    DCD    e40
    DCD    e41
    DCD    e42
    DCD    e43
    DCD    e44
    DCD    e45
    DCD    e46
    DCD    e47
    DCD    e48
    DCD    e49
    DCD    e50
    DCD    e51
    DCD    e52
    DCD    e53
    DCD    e54
    DCD    e55
    DCD    e56
    DCD    e57
    DCD    e58
    DCD    e59
    DCD    e60
    DCD    e61
;
buf DCD    buffer_io+8*max_fl+24;       816
ptr DCD    buffer_io-8
;      (io_start)
e20 DCB    "Direct access record %d illegal for unit %d",0
e21 DCB    "Can not write to unformatted file on unit %d",0
e22 DCB    "Can not open file on unit %d",0
e23 DCB    "Illegal unit %d",0
e24 DCB    "ACCESS conflict on unit %d",0
e25 DCB    "Formatted I/O on unformatted file; unit %d",0
e26 DCB    "Unformatted I/O on formatted file; unit %d",0
e27 DCB    "Incorrect unformatted record header; unit %d",0
e28 DCB    "Can not read file; unit %d",0
e29 DCB    "Unformatted internal I/O not allowed",0
e30 DCB    "Attempted recursive I/O",0
e31 DCB    "List-directed I/O to direct access file",0
;     (get_buffer)
e32 DCB    "Formatted record is too long (>512 bytes) on unit %d",0
e33 DCB    "Keyboard input record is too long (>254 bytes)",0
e34 DCB    "Escape pressed",0
e35 DCB    "No more records to read from internal file",0
;     (send_buffer)
e36 DCB    "Can not write to formatted file on unit %d",0
e37 DCB    "No more records to write to in internal file",0
;     (do_single)
e38 DCB    "Formatted output buffer overflow",0
e39 DCB    "Data word length incompatible with format descriptor",0
e40 DCB    "Format has no data-transfer descriptor",0
e41 DCB    "Formatted input buffer overflow",0
e42 DCB    "Hollerith/ASCII illegal in input format",0
e43 DCB    "Input integer overflow",0
e44 DCB    "Tab outside formatted input record",0
e45 DCB    "Tab before formatted output record",0
e46 DCB    "Unformatted (direct) output record overflow",0
e47 DCB    "Unformatted input record overflow",0
;     (format_next)
e48 DCB    "%sUnexpected ASCII character '%c'",0
e49 DCB    "%sNon-positive tab",0
e50 DCB    "%sNon-positive X-skip",0
e51 DCB    "%sNon-positive Hollerith field",0
e52 DCB    "%sNegative repeat count for data transfer",0
e53 DCB    "%sNegative repeat count for parenthesis",0
e54 DCB    "%sB not followed by N or Z",0
e55 DCB    "%sNo count after tab descriptor",0
e56 DCB    "%sNo e count in Ew.dEe etc.",0
e57 DCB    "%sDecimal width missing from F,E,D or G",0
e58 DCB    "%sWidth missing from numeric or logical descriptor",0
e59 DCB    "%sUnexpected right parenthesis"
e60 DCB    "%sToo deep (>10) parenthesis structure",0
;     (more do_single, errors 61 to 67)
e61 DCB    "Illegal character in %s input",0
;
    ALIGN
;                        4-byte  constants
frw DCD    format_io+16   ;pointer to last format result word (p)
;
unformatted
    AND    R1,R4,#&FF   ;file handle
    TST    R4,#&10000000;test for WRITE
    BEQ    uf3          ;reading
    TST    R4,#&20000000;test for direct access
    BNE    nd1
;           write record header
    MOV    R0,#0
    SWI    XOS_Args     ;get current file pointer
    SUB    lr,R2,R6     ;file length
    SUB    lr,lr,#6
    STR    lr,[ip]      ;write length -6 to temporary space
    MOV    lr,R2        ;save pointer
    MOV    R0,#1
    MOV    R2,ip        ;address of length
    MOV    R3,#4        ;4 bytes
    ADD    R4,R6,#2     ;pointer (after UF)
    SWI    XOS_GBPB     ;write length to specified pointer
    MOV    R2,lr
    SWI    XOS_Args     ;restore file pointer
    MOV    R0,#3
    SWI    XOS_Args     ;and set extent
    LDR    R4,[ip,#-24] ;restore R4
    B      nd1
;        reading unformatted file, skip unused portion
uf3 TST    R4,#&20000000;not needed for direct access
    SUBEQS R3,R7,R5     ;- #(bytes unread)
    BPL    nd1
    MOV    R0,#0
    SWI    XOS_Args     ;get current file pointer
    SUB    R2,R2,R3     ;point to end of record
    MOV    R0,#1
    SWI    XOS_Args     ;set pointer to end of record
    B      nd1
;
pws DCD    format_io+20   ;pointer to format working storage
res DCD    format_io      ;pointer to 5 format result words
;
;           UTILITIES
;
;          list of acceptable format codes
;   results             T T
;                       R L
list DCB   "IZOLFEDGAQH':XTBSP$$/,()"
;                     1          2
;           12 3456789012345678 9012
llist EQU  ?list      ;length of 'list'
     ALIGN
;
format_next;
    STMFD  sp!,{R4-R9,lr}
    LDR    R6,pws      ;address of storage
    LDMIA  R6!,{R0-R2} ;current position, count and parenthesis depth
fn1 LDRB   R3,[R0],#1  ;get character
    CMP    R3,#32      ;                        !!!  08/11/95
    BEQ    fn1         ;ignore space            !!!  08/11/95
    CMP    R3,#96
    SUBGT  R3,R3,#32   ;in upper case
    BL     count       ;see if count
    MOVVC  R1,ip       ;store it
    ADR    ip,list-1   ;list of codes
    MOV    R5,#llist   ;pointer in list
fn2 LDRB   lr,[ip,R5]
    CMP    lr,R3
    SUBNES R5,R5,#1
    BNE    fn2
    CMP    R5,#0
    LDREQB R3,[R0,#-1] ;restore original ASCII
    SUBEQ  R5,R3,#512
    BEQ    fn9         ;fail
    CMP    R5,#llist-2 ;check for internal control code
    BLT    fn5         ;external code for action
    BEQ    fn1         ;skip comma
    CMP    R5,#llist
    BEQ    fn3         ;close parenthesis
;                open parenthesis
    CMP    R2,#maxpar
    MOVGE  R5,#-1
    BGE    fn9         ;fail -1 if too many parentheses
    CMP    R1,#0
    MOVLT  R5,#-8
    BLT    fn9         ;fail -8: negative count before parenthesis
    ADD    lr,R6,R2,LSL#3
    STMIA  lr,{R0,R1}  ;store beginning of parenthesis and count
    ADD    R2,R2,#1
;    MOV    R1,#1
    MOV    R1,#0       ;   10/11/96
    B      fn1
;                close parenthesis
fn3 ADD    lr,R6,R2,LSL#3
    LDMDB  lr,{R4,R5}  ;get its parameters
    SUBS   R5,R5,#1    ;decrement count
    MOVLT  R5,#-1
    STRNE  R5,[lr,#-4] ;store decremented count
    MOVNE  R0,R4       ;point back to beginning
    MOVLT  R5,#0       ;flag for start of new record
    MOVLT  R8,#0       ;and also flag for ')'
    BLT    fn9
    BGT    fn1
    SUBS   R2,R2,#1    ;decrement parenthesis depth
    BGE    fn1
    MOV    R5,#-2
    B      fn9         ;fail -2 if too many right parentheses
;
count;    calculate integer into ip, leave new character in R3
    CMP    R3,#" "          ;skip blanks        12/02/1999
    LDREQB R3,[R0],#1
    BEQ    count            ;                   12/02/1999
    CMP    R3,#"+"
    LDREQB R3,[R0],#1       ;skip "+"
    CMP    R3,#"-"
    MOV    R4,R3
    LDREQB R3,[R0],#1       ;skip "-"
    RSBS   ip,R3,#"9"
    SUBGES ip,R3,#"0"
    MOVLT  ip,#&70000000
    ADDLTS ip,ip,ip         ;set V flag
    MOVVS  pc,lr
    STR    lr,[sp,#-4]!
fn4 LDRB   R3,[R0],#1
    CMP    R3,#32
    BEQ    fn4              ;skip blanks
    CMP    R3,#96
    SUBGT  R3,R3,#32        ;convert to upper case
    RSBS   lr,R3,#"9"
    RSBGES lr,lr,#9         ;check for integer
    ADDGE  ip,ip,ip,LSL#2
    ADDGE  ip,lr,ip,LSL#1   ;accumulate in ip
    BGE    fn4
    CMP    R4,#"-"
    RSBEQ  ip,ip,#0         ;fix sign
    MOVS   ip,ip            ;set Z and N appropriately (V not set)
    LDR    pc,[sp],#4       ;return with new flags
;
fn5;     external character (index in R5)
    SUB    R7,R0,#1    ;keep its address
    SUB    R5,R5,#1    ;allow for Z/O ambiguity (I and Z now too small by 1)
    CMP    R5,#8
    BGE    fna         ;character or editing
;          arithmetic descriptor (needs width)
    CMP    R1,#0
    MOVLT  R5,#-9
    BLT    fn9         ;fail -9: negative count
    LDRB   R3,[R0],#1
fn6 BL     count       ;leaves next character in R3 and R0 pointing to next
    MOVVS  R5,#-3
    BVS    fn9         ;fail -3 no width for numeric descriptor
    MOVLE  R5,#-3
    BLE    fn9         ;also fail if the count is not positive
    MOV    R8,ip       ;width
    CMP    R5,#3
    BEQ    fn8         ;L format has nothing else
    CMP    R3,#"."
    CMPNE  R5,#3
    MOVGT  R5,#-4
    BGT    fn9         ;fail -4 no decimal part for floating
    CMP    R3,#"."
    MOVNE  R9,#1       ;default d=1 for Iw, Zw, Ow and Bw
    BNE    fn7
    LDRB   R3,[R0],#1
    BL     count
    MOVVS  R5,#-4
    BVS    fn9         ;fail -4 no numerical part after decimal
    CMPGE  R8,ip       ;check w >= d
    MOVLT  R5,#-4
    BLT    fn9
    MOV    R9,ip       ;decimal width
fn7 CMP    R5,#2       ;check for Z/O
    MOVLT  ip,#4       ;'E' = 4 for Z (unused for I format)
    MOVEQ  ip,#3       ;'E' = 3 for O
    MOVGT  ip,#2       ;default 'E' of 2
    ADDLT  R5,R5,#1    ;correct index for Z and I
    CMP    R5,#0       ;check for binary
    MOVEQ  R5,#2       ;special check for Bw.d
    MOVEQ  ip,#1       ;'E' = 1 for B
    CMP    R5,#4
    BLE    fn8         ;F format has no E part
    CMP    R3,#"E"
    BNE    fn8         ;no exponent width
    LDRB   R3,[R0],#1
    BL     count
    MOVVS  R5,#-5
    BVS    fn9         ;fail -5 no numerical part after exponent
fn8 SUBS   R1,R1,#1    ;decrement count
    MOVGT  R0,R7       ;if more to come, reset pointer
    SUBLE  R0,R0,#1    ;otherwise point to next character
    MOVLE  R1,#0       ;and reset count
fn9;      all done, tidy up...
    STMDB  R6,{R0-R2}  ;store pointers
    LDR    R0,res      ;get results pointer
    STMIA  R0,{R5,R8,R9,ip}; store results
    LDMFD  sp!,{R4-R9,pc};return
;
fna BGT    fnb         ;not A
    CMP    R1,#0
    MOVLT  R5,#-9
    BLT    fn9         ;fail -9: negative repeat count
    LDRB   R3,[R0],#1
    BL     count
    MOVVS  R8,#0
    MOVVC  R8,ip
    B      fn8
;
fnb CMP    R5,#10
    BLT    fn9         ;Q
    BGT    fnc         ;not H
    MOV    R8,R0       ;where to start
    MOVS   R9,R1       ;Hollerith count
    MOVLE  R5,#-10     ;non-postitive hollerith width
    ADD    R0,R8,R1    ;point to next
    MOV    R1,#0       ;no repetition for Hollerith
    B      fn9         ;H or Q
;
fnc CMP    R5,#12
    BEQ    fn9         ; :
    BGT    fne         ;not '
    MOV    R8,R0       ;start point
fnd LDRB   R3,[R0],#1
    CMP    R3,#"'"
    BNE    fnd
    LDRB   R3,[R0]
    CMP    R3,#"'"     ;check for double quote
    ADDEQ  R0,R0,#1
    BEQ    fnd         ;skip double quote
    SUB    R9,R0,R8    ;count
    SUB    R9,R9,#1
    MOV    R1,#0       ;no repetition for string
    B      fn9
;
fne CMP    R5,#14
    BGE    fnf
    MOVS   R8,R1       ;X-count
    MOVLE  R5,#-11     ;count must be >0
    MOV    R1,#0
    B      fn9
;
fnf BGT    fng         ;not T
    LDRB   R3,[R0],#1
    CMP    R3,#"a"
    SUBGE  R3,R3,#32
    CMP    R3,#"L"     ;check for TL
    MOVEQ  R5,#15
    CMP    R3,#"R"     ;check for TR
    MOVEQ  R5,#13
    CMP    R5,#14
    LDRNEB R3,[R0],#1
    BL     count
    MOVVS  R5,#-6
    BVS    fn9
    MOVS   R8,ip
    MOVLE  R5,#-12     ;count must be >0
    SUB    R0,R0,#1    ;move back character
    B      fn9         ;fail -6: no count after T
;
fng LDR    R4,[sp]     ;status word
    CMP    R5,#16
    BGE    fnh         ;not B
    LDRB   R3,[R0],#1
    CMP    R3,#"0"
    RSBGES lr,R3,#"9"
    MOVGE  R5,#-1      ;flag Bw.d with index -1
    BGE    fn6         ;binary
    CMP    R3,#96
    SUBGT  R3,R3,#32
    BIC    R4,R4,#&800000;clear BZ bit
    CMP    R3,#"Z"
    ORREQ  R4,R4,#&800000;set bit for BZ
    CMPNE  R3,#"N"
    MOVNE  R5,#-7      ;fail -7: B not followed by N or Z
    BNE    fn9
    STR    R4,[sp]     ;store new status word
    B      fn1
;
fnh BGT    fni         ;not S
    LDRB   R3,[R0]     ;S, look at next character
    CMP    R3,#96
    SUBGT  R3,R3,#32
    BIC    R4,R4,#&80000;clear S bit
    CMP    R3,#"P"
    ORREQ  R4,R4,#&80000;set SP bit
    CMPNE  R3,#"S"
    ADDEQ  R0,R0,#1    ;skip over subscripts P or S
    STR    R4,[sp]     ;store new status word
    B      fn1
;
fni CMP    R5,#18
    LDRLT  ip,res
    STRLT  R1,[ip,#16] ;store P-count in result
    MOVLT  R1,#0
    BLT    fn1         ;go look for next
    ORREQ  R4,R4,#&200000; set $ bit
    STREQ  R4,[sp]     ;store new status word
    BEQ    fn1
    MOV    R5,#0       ;flag / as new record
    MOV    R8,#1       ;and also flag for '/'
    B      fn9
;
format_write; write out format until:
;  if R0=0 then next data transfer
;  if R0<>0 then next data transfer, :, or end of format
    STMFD  sp!,{R0,R9,lr}
    LDR    lr,pws
    LDR    R9,[lr]        ;start position in format (for loop checking)
fw1 LDR    R3,res
    LDMIA  R3,{R0-R2}     ;get code, w and d
    CMP    R0,#0
    BEQ    fw9            ;end of record
    ORRLT  R4,R4,#&3000   ;error 48: format syntax
    LDMLTFD sp!,{R0,R9,pc}; finished with error
    CMP    R0,#10
    BLT    fwa            ;data transfer request
    CMP    R0,#12
    BGE    fw4            ;not Hollerith or '...'
    CMP    R2,#0
    BLT    fw3
fw2 CMP    R8,R5
    BGE    buf_ovfl
    LDRB   lr,[R1],#1
    CMP    lr,#"'"
    CMPEQ  R0,#11
    LDREQB lr,[R1],#1     ;skip first ' in ASCII string
    SUBEQ  R2,R2,#1
    STRB   lr,[R6,R8]     ;store in output
    ADD    R8,R8,#1
    SUBS   R2,R2,#1
    BGT    fw2
    CMP    R8,R7
    MOVGT  R7,R8          ;set buffer extent
;
fw3 BL     format_next    ;get next format
    BL     format_loop
    B      fw1
;
fw4 BGT    fw5            ;not :
    LDR    R0,[sp]        ;get incident argument
    CMP    R0,#0
    BEQ    fw3
    BL     send_buffer
    LDMFD  sp!,{R0,R9,pc}; finished
;
fw5 CMP    R0,#14
    BGE    fw8            ;not X
    ADD    R8,R8,R1       ;increment pointer
fw6 CMP    R8,R5
    BGT    buf_ovfl       ;was 'BGE     buf_ovfl'                   07/11/98
    MOV    lr,#" "
fw7 CMP    R7,R8
    STRLTB lr,[R6,R7]     ;blank fill
    ADDLT  R7,R7,#1
    BLT    fw7
    B      fw3
;
fw8 SUBEQ  R8,R1,#1       ;tab (start at 1)
    SUBGT  R8,R8,R1       ;tab left
    CMP    R8,#0
    BGE    fw6
    ORR    R4,R4,#&2D00   ;error 45: negative tab
    LDMFD  sp!,{R0,R9,pc}
;
fw9;    end-of-record
    LDR    R0,[sp]
    CMP    R0,#0
    LDRNE  lr,res
    LDRNE  R1,[lr,#4]
    CMPNE  R1,#1          ;check also for '/'
    MOVEQS R0,#0
    BL     send_buffer
    CMP    R0,#0
    TSTEQ  R4,#&FF00      ;test for error
    BEQ    fw3            ;carry on until data transfer
    LDMFD  sp!,{R0,R9,pc}; finished
;
fwa;     data-transfer request
    LDR    R0,[sp]
    CMP    R0,#0
    BLNE   send_buffer    ;empty buffer if requested
    LDMFD  sp!,{R0,R9,pc}; finished
;
buf_ovfl
    ORR    R4,R4,#&2600   ;error 38: output buffer overflow
    LDMFD  sp!,{R0,R9,pc}
;
format_read; read format until data transfer request
    STMFD  sp!,{R0,R9,lr}
    LDR    lr,pws
    LDR    R9,[lr]        ;start position in format (for loop checking)
fr1 LDR    R3,res
    LDMIA  R3,{R0-R1}     ;get code and w
    CMP    R0,#0
    ORRLT  R4,R4,#&3000   ;error 48: format syntax
    LDMLTFD sp!,{R0,R9,pc}
    BGT    fr2
    BL     get_buffer     ;end of record
    LDMVSFD sp!,{R0,R9,pc}; failed
    B      fr3
fr2 CMP    R0,#10
    LDMLTFD sp!,{R0,R9,pc};data transfer request
    CMP    R0,#12
    BGT    fr5
    ORRLT  R4,R4,#&2A00   ;error 42: no hollerith on input
    LDMLTFD sp!,{R0,R9,pc}
;
fr3 BL     format_next    ;get next format
    ADR    lr,fr1
;
format_loop; test for format loop
    LDR    R0,pws
    LDR    R0,[R0]        ;position in format
    CMP    R0,R9          ;compare with original
    MOVNE  pc,lr
    ORR    R4,R4,#&2800   ;error 40: loop in format
    LDMFD  sp!,{R0,R9,pc}
;
fr5 CMP    R0,#14
    ADDLT  R8,R8,R1       ;X or TR
    SUBEQ  R8,R1,#1       ;T (start at 1)
    SUBGT  R8,R8,R1       ;TL
    CMP    R8,#-1
    CMPGT  R5,R8
;  was    CMPGT  R7,R8     24/1/96
    BGT    fr3
    ORR    R4,R4,#&2C00   ;error 44: tab outside input record
    LDMFD  sp!,{R0,R9,pc}
;
get_buffer;
    STMFD  sp!,{R0-R2,lr} ;save R0-R2 for "io_do_single"
    TST    R4,#&FF00      ;check for error
    BNE    gb61
    AND    R1,R4,#&FF     ;file handle
    MVN    ip,R4          ;inverse status for list-directed test
    TST    R4,#&400000    ;test for keyboard
    BNE    gb4
    TST    R1,#&FF        ;test for internal read
    BEQ    gb5
    TST    R4,#&20000000  ;test for direct access
    BNE    gb8
gb0 MOV    R7,#-1         ;count
gb1 ADD    R7,R7,#1
    SWI    XOS_BGet
    BCS    gb3
    BVS    gb3
    CMP    R0,#4
    BEQ    gb7            ;software end-of-file
    CMP    R7,R5
    STRLEB R0,[R6,R7]     ;allow the CR/LF to go one beyond the buffer
    CMP    R0,#13
    CMPNE  R0,#10
    BNE    gb1
    RSB    lr,R0,#23      ;opposite to current terminator
    MOV    R0,#0
    SWI    XOS_Args       ;get current file pointer
    SWI    XOS_BGet
    BCS    gb2
    BVS    gb2
    CMP    R0,lr
    ADDEQ  R2,R2,#1       ;allow for <CR><LF> or <LF><CR>
gb2 MOV    R0,#1
    SWI    XOS_Args       ;restore pointer
    CMP    R7,R5
    ORRGT  R4,R4,#&2000   ;error 32: for buffer overflow
    TSTEQ  ip,#&100000    ;test for list-directed null record
    BEQ    gb0            ;yes, so try again
    B      gb6
;        hit end of file
gb3 CMP    R7,#0          ;test for bytes in buffer
    ORRLE  R4,R4,#&FF00   ;set end-of-file flag if none
    B      gb6
;       read line from keyboard
gb4 MOV    R0,R6          ;address of buffer
    MOV    R1,R5          ;buffer size
    MOVS   R2,#0,2        ;clear carry
    MOV    R3,#255
    SWI    OS_ReadLine
    BCS    gb9            ;escape pressed
    CMP    R1,#254
    ORRGT  R4,R4,#&2100   ;error 33: buffer overflow
    MOVLES R7,R1
    TSTEQ  ip,#&100000    ;test for list-directed and zero length
    BEQ    gb4
    B      gb6
;        read from memory
gb5 LDR    ip,buf
    LDR    R0,[ip,#-4]    ;get buffer #
    MOV    R7,R5          ;#bytes in buffer
    ADDS   R0,R0,#1       ;account for subsequent "buffers"
    ADDLT  R6,R6,R5       ;move to next "buffer"
    STRLT  R0,[ip,#-4]    ;store buffer number
    ORRGE  R4,R4,#&2300   ;error 35: no more buffers
;        finished get-buffer
gb6 MOV    R8,#0
    TST    R4,#&FF00
gb61 MOVNE R0,#&70000000
    ADDNES R0,R0,R0      ;set V on error
    LDMFD  sp!,{R0-R2,pc}
;        found software end-of-file
gb7 CMP    R7,#0
    ORRLE  R4,R4,#&FE00   ;no bytes in buffer
    BLE    gb6
    MOV    R0,#0
    SWI    XOS_Args       ;get current file pointer
    SUB    R2,R2,#1
    B      gb2            ;back up before eof marker
;
gb8;     direct access formatted input
    MOV    R0,#4
    MOV    R2,R6
    MOV    R3,R5
    MOV    lr,R4
    SWI    XOS_GBPB      ;read complete record
    MOV    R4,lr
    MOV    R7,R5
    B      gb6
;
gb9 ORRCS  R4,R4,#&2200   ;error 34: escape pressed
    MOV    R0,#124
    SWI    OS_Byte        ;clear escape condition
    B      gb6
;
send_buffer;
    STMFD  sp!,{R0,lr}
    TST    R4,#&FF00      ;check for error
    MOVNE  R0,#&70000000
    ADDNES R0,R0,R0       ;set V flag on error
    LDMVSFD sp!,{R0,pc}
    TST    R4,#&400000    ;test for vdu
    BNE    sb7
    ANDS   R1,R4,#&FF
    BEQ    sb8            ;internal file
;
;         write to external file
    TST    R4,#&20000000  ;test for direct access
    BEQ    sb2
    MOV    R0,#" "
sb1 CMP    R7,R5
    STRLTB R0,[R6,R7]     ;blank fill direct access record
    ADD    R7,R7,#1
    BLT    sb1
    MOV    R3,R5
    B      sb5
sb2 SUBS   R7,R7,#1
    LDRGEB R0,[R6,R7]
    CMPGE  R0,#" "
    BEQ    sb2            ;remove trailing blanks from sequential file
    ADD    R7,R7,#1
    TST    R4,#&2000000   ;test for FORM='PRINTER'
    BEQ    sb4            ;not printer file
    CMP    R7,#0
    BNE    sbx
    MOV    R0,#10
    SWI    XOS_BPut       ;just put <LF> for zero length record
    B      sb6
sbx LDRB   R3,[R6],#1     ;get carriage control character
    CMP    R3,#"1"
    BNE    sby
    MOV    R0,#10         ;                                       08/11/98
    SWI    XOS_BPut       ;"1" -> <LF> (10)                       08/11/98
    MOV    R0,#12
    SWI    XOS_BPut       ;"1" -> <FF> (12)
    BVS    sb6
    B      sb3
sby CMP    R3,#"0"
    MOVEQ  R0,#10
    SWIEQ  XOS_BPut       ;extra <LF> for "0"
    BVS    sb6
    MOV    R0,#0
    SWI    XOS_Args       ;check for first record (R2=0)
    BVS    sb6
    CMP    R2,#0
    BEQ    sb3            ;do nothing else for first record
    CMP    R3,#"+"
    MOVEQ  R0,#13         ;put <CR> if "+"
    MOVNE  R0,#10         ;else put <LF>
    SWI    XOS_BPut
    BVS    sb6
sb3 SUBS   R3,R7,#1       ;# characters remaining in record
    BLE    sba
    B      sb5
sb4 MOV    R0,#10
    STRB   R0,[R6,R7]     ;stick <LF> on end of file output
    ADD    R3,R7,#1
sb5 MOV    R2,R6
    MOV    R0,#2
    STR    R4,[sp,#-4]!   ;save status word
    SWI    XOS_GBPB       ;write record to file
    MOVVC  R2,R4          ;save file pointer
    LDR    R4,[sp],#4     ;restore status word
    TST    R4,#&20000000  ;test for direct access
    BNE    sb6
    MOVVC  R0,#3
    SWIVC  XOS_Args       ;set extent to end of last record
sb6 ORRVS  R4,R4,#&2400   ;error 36: can not write to file
    B      sba
;
sb7;                      ;write to vdu
    SUBS   R7,R7,#1       ;                              04/07/2021
    LDRGEB R0,[R6,R7]     ;                              04/07/2021
    CMPGE  R0,#" "        ;                              04/07/2021
    TSTEQ  R4,#&200000    ;check $ not used, then        04/07/2021
    BEQ    sb7            ;remove trailing blanks        04/07/2021
    ADD    R1,R7,#1
    MOV    R0,R6
    SWI    OS_WriteN      ;write to vdu
    TST    R4,#&200000    ;check $ not used, then
    BNE    sba
    SWI    OS_WriteCR     ;send <CR>
    SWI    OS_WriteLF     ;send <LF>
    B      sba
;
sb8;   write to internal file
    LDR    ip,buf
    LDR    R1,[ip,#-4]    ;count
    CMP    R0,#0
    ADDEQS R1,R1,#1
    STR    R1,[ip,#-4]    ;count
    ORREQ  R4,R4,#&2500   ;error 37: too many internal records written
    MOVEQ  R1,#&70000000
    ADDEQS R1,R1,R1       ;set V flag on error
    LDMVSFD sp!,{R0,pc}
    MOV    R1,#" "
sb9 CMP    R7,R5
    STRLTB R1,[R6,R7]
    ADD    R7,R7,#1
    BLT    sb9
    ADD    R6,R6,R5       ;update buffer pointer
;
sba MOV    R7,#0          ;no bytes in new buffer
    MOV    R8,#0          ;point to first byte
    LDMFD sp!,{R0,pc}
    END
;
    TTL    kernel  ; from ROOL
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 &06
OS_CallASWIR12          EQU &71
    AREA   |C$$data|,DATA
vrs %      4               ;RISC-OS version
    %      4               ;pointer to error block
    AREA   |C$$code|,CODE,READONLY
;
    EXPORT kernel_last_oserror_ ;(IERR,TEXT)
    EXPORT kernel_swi_ ;(NUMB,IREGS,OREGS) => LOGICAL(error)
    EXPORT kernel_swi_c_; (NUMB,IREGS,OREGS,ICARRY)
    DCB    "kernel_swi_",0,12,0,0,255
;
kernel_swi_
    MOV    R3,#0          ;nullify ICARRY when not needed
kernel_swi_c_
    MOV    ip,sp
    STMDB  sp!,{R1-R9,fp,ip,lr,pc};preserve arguments
    SUB    fp,ip,#4
    LDR    R3,[R0]         ;SWI number
    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 pre-RISC-OS-StrongArm)
    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
    LDR    ip,[sp,#4]      ;address of OREGS
    STMIA  ip,{R0-R9}      ;store registers in OREGS
    LDR    ip,ver          ;V flag set on error
    MOVVC  R0,#0           ;.FALSE. if no error
    STR    R0,[ip,#4]      ;save address of error block or 0 if none
    MOVVS  R0,#1           ;.TRUE. if error
    LDR    R3,[sp,#8]      ;address of ICARRY
    MOVCC  R2,#0           ;no C flag
    MOVCS  R2,#1           ;yes, C flag
    CMP    R3,#0
    LDRNE  ip,[R3]
    STRNE  R2,[R3]         ;store C flag in ICARRY
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
    DCB    "kernel_last_oserror_ ",0,0,0,24,0,0,255
kernel_last_oserror_ ;(IERR,TEXT)
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc};preserve arguments
    SUB    fp,ip,#4
    LDR    R3,ver
    LDR    R3,[R3,#4]      ;address of error block  
    CMP    R3,#0           ;check for no error
    STREQ  R3,[R0]         ;store 0 in IERR
    LDMEQDB fp,{fp,sp,pc}  ;return no error
    LDR    ip,[R3],#4      ;error number
    STR    ip,[R0]         ;store in IERR
lp1 LDRB   ip,[R3],#1
    CMP    ip,#0                     
    STRGTB ip,[R1],#1      ;store byte of TEXT
    SUBGTS R2,R2,#1        ;reduce count in TEXT
    BGT    lp1
    MOV    ip,#32          ;blank for fill
lp2 STRGEB ip,[R1],#1      ;fill
    SUBS   R2,R2,#1
    BGT    lp2
    LDMDB  fp,{fp,sp,pc}   ;return
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    wimpprint
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
PDriver_AbortJob   EQU &A0149
Wimp_SlotSize      EQU &400EC
XOS_SpriteOp       EQU &2002E
XOS_Find           EQU &2000D
;
    AREA   |C$$DATA|,DATA
depth DCD  6                ;maximum depth of trace back
;
    AREA   |SpOp_state|,COMMON
    %      4; flags redirection of VDU O/P to sprite or mask
;
    AREA   print_handles,COMMON
    %      4         ;file handle (initially 0)
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT wimpprint; (format,...) C type fprint format
    EXPORT tracedepth_;(JDEPTH) sets trace-back depth
    IMPORT fortran_exit
       GET s.MaxFl
    IMPORT buffer_io
;
    DCB    "tracedepth_",0,12,0,0,255
tracedepth_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;JDEPTH
    LDR    R1,ptd      ;address of depth
    STR    R0,[R1]
    LDMDB  fp,{fp,sp,pc};return to fortran
;
buf DCD    buffer_io+8*max_fl+24; 816
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    lp1
    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
;        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    pt0
    SWI    OS_WriteC
    MOV    R7,R0            ;last useful character
    B       lp1
pt0 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    ptx
    SWI    OS_WriteC        ;print character
    B      lp1
ptx CMP    ip,#"S"
    BNE    pty
    SWI    OS_Write0        ;print string
    B      lp1
;        translate integer
pty CMP    ip,#"D"
    BNE    ptz
    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
ptz 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
    BIC    R2,R2,#&FC000003 ;remove status bits
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,stop
    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
    BNE    ptw
    ADR    R0,at
    ADD    R0,R0,R8
    SWI    OS_Write0        ;print "    at &"
    TEQ    pc,pc            ;test for 32-bit
    BICNE  R0,lr,#&FC000003 ;clear system bits from address
    BL     Hex7
ptw SWI    OS_NewLine
    BNE    pt5
    CMP    R9,#0
    BEQ    pt5              ;not doing argument prints
    LDR    R0,[R7]
    TEQ    pc,pc            ;test for 32-bit
    BICNE  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"
stop 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 number 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    setbuf
pc  RN    15
lr  RN    14
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT setbuf_;(IUNIT,N) dummy for setting buffering mode
setbuf_
    MOV   R0,#0   ; return zero
    MOV   pc,lr
    END
;
;             VAX bit manipulation functions and subroutine
;
    TTL    btest
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 btest_;(I,J) returns bit J of I
    EXPORT bjtest_;(I,J) returns bit J of I in Integer*4
    DCB    "btest_",0,0,8,0,0,255
btest_
bjtest_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]
    LDR    R1,[R1]
    MOV    R0,R0,LSR R1
    AND    R0,R0,#1
    LDMDB  fp,{fp,sp,pc};return to fortran
    END
;
    TTL    bitest
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 bitest_;(I,J) returns bit J of I in Integer*2
    DCB    "bitest_",0,8,0,0,255
bitest_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDRB   R1,[R1]     ; only the ls byte can contain the count
    CMP    R1,#7       ; check if bit is in first byte of I
    LDRLEB R0,[R0]     ; in first byte
    LDRGTB R0,[R0,#1]  ; in second byte
    AND    R1,R1,#7
    MOV    R0,R0,LSR R1
    AND    R0,R0,#1
    LDMDB  fp,{fp,sp,pc};return to fortran
    END
;
    TTL    iand
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 iand_;(I,J) returns logical I and J
    EXPORT jiand_;(I,J) returns logical I and J in Integer*4
    DCB    "iand_",0,0,0,8,0,0,255
iand_
jiand_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]
    LDR    R1,[R1]
    AND    R0,R0,R1
    LDMDB  fp,{fp,sp,pc};return to fortran
    END
;
    TTL    iiand
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 iiand_;(I,J) returns logical I and J in Integer*2
    DCB    "iiand_",0,0,8,0,0,255
iiand_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDRB   ip,[R0,#1]    ; ms byte of I
    LDRB   R0,[R0]       ; ls byte of I
    ORR    R0,R0,ip,LSL#8; I
    LDRB   ip,[R1,#1]    ; ms byte of J
    LDRB   R1,[R1]       ; ls byte of J
    ORR    R1,R1,ip,LSL#8; J
    AND    R0,R0,R1
    LDMDB  fp,{fp,sp,pc};return to fortran
    END
;
    TTL    ibclr
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 ibclr_;(I,J) returns I with bit J cleared
    EXPORT jibclr_;(I,J) returns I with bit J cleared in Integer*4
    DCB    "ibclr_",0,0,8,0,0,255
ibclr_
jibclr_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]
    LDR    R1,[R1]
    MOV    ip,#1
    BIC    R0,R0,ip,LSL R1
    LDMDB  fp,{fp,sp,pc};return to fortran
    END
;
    TTL    iibclr
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 iibclr_;(I,J) returns I with bit J cleared in Integer*2
    DCB    "iibclr_",0,8,0,0,255
iibclr_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDRB   R1,[R1]   ;J (only ls byte is relevant)
    LDRB   ip,[R0,#1]; ms byte of I
    LDRB   R0,[R0]   ;ls byte of I
    ORR    R0,R0,ip,LSL#8 ; I
    MOV    ip,#1
    BIC    R0,R0,ip,LSL R1
    LDMDB  fp,{fp,sp,pc};return to fortran
    END
;
    TTL    ibits
pc  RN    15
lr  RN    14
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT ibits_;(I,J,K) returns k-bit byte at J of I
    EXPORT i_bits
    EXPORT jibits_;(I,J,K) returns k-bit byte at J of I in Integer*4
    DCB    "ibits_",0,0,8,0,0,255
ibits_
i_bits
jibits_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]
    LDR    R1,[R1]
    LDR    R2,[R2]
    MOV    R0,R0,LSR R1
    MVN    R1,#0
    BIC    R0,R0,R1,LSL R2
    LDMDB  fp,{fp,sp,pc};return to fortran
    END
;
    TTL    iibits
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 iibits_;(I,J,K) returns k-bit byte at J of I in Integer*2
    EXPORT h_bits;(I,J,K) returns k-bit byte at J of I in Integer*2
    DCB    "iibits_",0,8,0,0,255
h_bits
iibits_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDRB   ip,[R0,#1]
    LDRB   R0,[R0]
    LDRB   R1,[R1]        ; J
    LDRB   R2,[R2]        ; K
    ORR    R0,R0,ip,LSL#8 ; I
    MOV    R0,R0,LSR R1
    MVN    R1,#0
    BIC    R0,R0,R1,LSL R2
    LDMDB  fp,{fp,sp,pc};return to fortran
    END
;
    TTL    ibset
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 ibset_;(I,J) returns I with bit J set
    EXPORT jibset_;(I,J) returns I with bit J set in Integer*4
    DCB    "ibset_",0,0,8,0,0,255
ibset_
jibset_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]
    LDR    R1,[R1]
    MOV    ip,#1
    ORR    R0,R0,ip,LSL R1
    LDMDB  fp,{fp,sp,pc};return to fortran
    END
;
    TTL    iibset
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 iibset_;(I,J) returns I with bit J set in Integer*2
    DCB    "iibset_",0,8,0,0,255
iibset_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDRB   ip,[R0,#1]
    LDRB   R0,[R0]
    LDRB   R1,[R1]
    ORR    R0,R0,ip,LSL#8
    MOV    ip,#1
    ORR    R0,R0,ip,LSL R1
    LDMDB  fp,{fp,sp,pc};return to fortran
    END
;
    TTL    ieor
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 ieor_;(I,J) returns logical I eor J
    EXPORT jieor_;(I,J) returns logical I eor J in Integer*4
    DCB    "ieor_",0,0,0,8,0,0,255
ieor_
jieor_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]
    LDR    R1,[R1]
    EOR    R0,R0,R1
    LDMDB  fp,{fp,sp,pc};return to fortran
    END
;
    TTL    iieor
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 iieor_;(I,J) returns logical I eor J in Integer*2
    DCB    "iieor_",0,0,8,0,0,255
iieor_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDRB   ip,[R0,#1]
    LDRB   R0,[R0]
    ORR    R0,R0,ip,LSL#8
    LDRB   ip,[R1,#1]
    LDRB   R1,[R1]
    ORR    R1,R1,ip,LSL#8
    EOR    R0,R0,R1
    LDMDB  fp,{fp,sp,pc};return to fortran
    END
;
    TTL    ior
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 ior_;(I,J) returns logical I or J
    EXPORT jior_;(I,J) returns logical I or J in Integer*4
    DCB    "ior_",0,0,0,0,8,0,0,255
ior_
jior_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]
    LDR    R1,[R1]
    ORR    R0,R0,R1
    LDMDB  fp,{fp,sp,pc};return to fortran
    END
;
    TTL    iior
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 iior_;(I,J) returns logical I or J in Integer*2
    DCB    "iior_",0,0,0,8,0,0,255
iior_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDRB   ip,[R0,#1]
    LDRB   R0,[R0]
    ORR    R0,R0,ip,LSL#8
    LDRB   ip,[R1,#1]
    LDRB   R1,[R1]
    ORR    R1,R1,ip,LSL#8
    ORR    R0,R0,R1
    LDMDB  fp,{fp,sp,pc};return to fortran
    END
;
    TTL    ishft
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 ishft_;(I,J) returns I shifted left J bits
    EXPORT jishft_;(I,J) returns I shifted left J bits in Integer*4
    DCB    "ishft_",0,0,8,0,0,255
ishft_
jishft_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]
    LDR    R1,[R1]
    CMP    R1,#0
    RSBLT  R1,R1,#0
    MOVGT  R0,R0,LSL R1
    MOVLT  R0,R0,LSR R1
    LDMDB  fp,{fp,sp,pc};return to fortran
    END
;
    TTL    iishft
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 iishft_;(I,J) returns I shifted left J bits in Integer*2
    DCB    "iishft_",0,8,0,0,255
iishft_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDRB   ip,[R0,#1]
    LDRB   R0,[R0]
    ORR    R0,R0,ip,LSL#8   ;I
    LDRB   ip,[R1,#1]
    LDRB   R1,[R1]
    ORR    R1,R1,ip,LSL#8
    TST    R1,#32768        ;test sign bit
    RSBNE  R1,R1,#65536
    MOVEQ  R0,R0,LSL R1
    MOVNE  R0,R0,LSR R1
    LDMDB  fp,{fp,sp,pc};return to fortran
    END
;
    TTL    not
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 not_;(I) returns boolean complement of I
    EXPORT jnot_;(I) returns boolean complement of I in Integer*4
    DCB    "not_",0,0,0,0,8,0,0,255
not_
jnot_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]
    MVN    R0,R0
    LDMDB  fp,{fp,sp,pc};return to fortran
    END
;
    TTL    inot
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 inot_;(I) returns boolean complement of I in Integer*2
    DCB    "inot_",0,0,0,8,0,0,255
inot_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDRB   ip,[R0,#1]
    LDRB   R0,[R0]
    ORR    R0,R0,ip,LSL#8
    MVN    R0,R0
    LDMDB  fp,{fp,sp,pc};return to fortran
    END
;
    TTL    ishftc
pc  RN    15
lr  RN    14
ip  RN    12
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT ishftc_;(M,K,IC) returns M with least sig. 
    EXPORT i_shftc
;         IC bits rotated left by K
    EXPORT jishftc_;(M,K,IC) returns M with least sig. 
;         IC bits rotated left by K in Integer*4
    DCB    "ishftc_",0,8,0,0,255
ishftc_
i_shftc
jishftc_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]        ;IC
    MOV    R3,#-1
    LDR    R0,[R0]        ;M
    LDR    R1,[R1]        ;K
    BIC    R3,R3,R3,LSL R2;mask
    AND    ip,R0,R3       ;active piece of M
    BIC    R0,R0,R3       ;passive piece of M
    CMP    R1,#0          ;check sign of K
    ADDLTS R1,R2,R1       ;invert if right shift
    AND    R3,R3,ip,LSL R1
    SUBNE  R1,R2,R1
    ORRNE  R3,R3,ip,LSR R1
    ORR    R0,R0,R3       ;restore passive piece
    LDMDB  fp,{fp,sp,pc};return to fortran
    END
;
    TTL    iishftc
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 iishftc_;(M,K,IC) returns M with least sig. 
;         IC bits rotated left by K in Integer*2
    EXPORT h_shftc
    DCB    "iishftc_",8,0,0,255
h_shftc
iishftc_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDRB   R2,[R2]        ;IC
    MOV    R3,#-1
    LDRB   ip,[R0,#1]
    LDRB   R0,[R0]
    ORR    R0,R0,ip,LSL#8    ;M
    LDRB   ip,[R1,#1]
    LDRB   R1,[R1]
    ORR    R1,R1,ip,LSL#8 ;K
    BIC    R3,R3,R3,LSL R2;mask
    MOV    R1,R1,LSL#16
    AND    ip,R0,R3       ;active piece of M
    MOV    R1,R1,ASR#16   ;properly signed K
    BIC    R0,R0,R3       ;passive piece of M
    CMP    R1,#0          ;check sign of K
    ADDLTS R1,R2,R1       ;invert if right shift
    AND    R3,R3,ip,LSL R1
    SUBNE  R1,R2,R1
    ORRNE  R3,R3,ip,LSR R1
    ORR    R0,R0,R3       ;restore passive piece
    LDMDB  fp,{fp,sp,pc};return to fortran
    END
;
;        end of VAX bit manipulation functions and subroutine
;
    TTL    cdate
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_ConvertDateAndTime EQU &C1
OS_Word               EQU &07
;
    AREA   |C$$Code|,CODE,READONLY
                   ; SUBROUTINE CDATE(string)
    EXPORT cdate_; returns 24 byte ASCII date in form on p 560 PRM
    DCB    "cdate_",0,0,8,0,0,255
cdate_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,sp
    SUB    sp,sp,#36     ;working space
    MOV    R0,#3
    MOV    R1,sp
    STR    R0,[R1]       ;1st word of block = 3
    MOV    R0,#14        ;OSWord 14,3
    SWI    OS_Word       ;call OSWord
    MOV    R0,R1
    ADD    R1,sp,#8
    MOV    R2,#28
    ADR    R3,fmt
    SWI    OS_ConvertDateAndTime
    LDMIA  ip,{R2,R3}    ;get address and length of 'string'
cd1 CMP    R1,R0
    LDRGTB ip,[R0],#1    ;move to users string
    MOVLE  ip,#" "       ;with blank fill
    STRB   ip,[R2],#1
    SUBS   R3,R3,#1
    BGT    cd1
    LDMDB  fp,{fp,sp,pc};return to fortran
fmt DCB    "%W3,%DY %M3 %CE%YR.%24:%MI:%SE",0
    END
;
    TTL    comp_stack
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R8  RN     8
R7  RN     7
R6  RN     6
R5  RN     5
R4  RN     4
R2  RN     2
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT compact_stack_; removes unused portions of stack and
;                          returns the number of bytes removed
    IMPORT get_stack
    IMPORT change_memory
    DCB    "compact_stack_",0,0,16,0,0,255
compact_stack_; to remove any unused sections of stack => integer reduction
    MOV    ip,sp
    STMDB  sp!,{R4-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     get_stack     ;returns: sl, R6=top of stack, R2=top of memory
                         ;    R7,R8 are reserved memory
    CMP    R8,R6         ;check for reserved memory
    MOVGT  R6,R8
    SUBS   R5,R6,R2      ; - (extra memory)
    BLLT   change_memory ;remove any extra memory
    RSB    R0,R5,#0      ;stack reduction
    LDMDB  fp,{R4-R8,fp,sp,pc};return
    END
;
    TTL    cpu
pc  RN    15
lr  RN    14
R0  RN     0
F0  FN     0
F1  FN     1
F2  FN     2
OS_ReadMonotonicTime EQU &42
    AREA   |C$$code|,CODE,READONLY
    EXPORT cpu_;(old) returns current cputime - OLD in seconds
    DCB    "cpu_",0,0,0,0,8,0,0,255
cpu_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R0]       ;OLD
    SWI    OS_ReadMonotonicTime; get current time in R0 (centisec)
    FLTS   F1,R0
    LDFS   F2,=0.01
    FMLS   F1,F1,F2      ;current time in seconds
    SUFS   F0,F1,F0
    LDMDB  fp,{fp,sp,pc};return to fortran
    END
;
    TTL    divide
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT __rt_sdiv10
    EXPORT __rt_sdiv; R0 = R1/R0  (and R1=|remainder|)
    EXPORT __rt_udiv; as above but using bytes
    EXPORT __rt_divtest; test 1/R0
    IMPORT wimpprint
;
__rt_udiv
    MOV   R1,R1,LSL#24  ; fill words with byte sign
    MOV   R0,R0,LSL#24
    MOV   R1,R1,ASR#24
    MOV   R0,R0,ASR#24
    B     __rt_sdiv
__rt_sdiv10   ; divide R0 by 10
    MOV   R1,R0
    MOV   R0,#10
__rt_sdiv
    MOVS   ip,R0
    BEQ    er1           ;zero denominator
    EOR    R3,ip,R1      ;resultant sign
    RSBMI  ip,ip,#0      ;|R0|
    CMP    R1,#0
    RSBLT  R1,R1,#0      ;|R1|
    MOV    R2,ip         ;keep copy of denominator
;         shift up denominator until would be > numerator
    CMP    ip,R1,LSR#1
lp1 MOVLS  ip,ip,LSL#1
    CMP    ip,R1,LSR#1
    BLS    lp1
    MOV    R0,#0
lp2 CMP    R1,ip
    SUBCS  R1,R1,ip
    MOV    ip,ip,LSR#1
    ADC    R0,R0,R0
    CMP    ip,R2
    BHS    lp2
    CMP    R3,#0
    RSBLT  R0,R0,#0
    MOV    pc,lr
;
__rt_divtest
    CMP    R0,#0
er1 ADREQ  R0,err
    BLEQ    wimpprint
    MOV    pc,lr
;
err DCB    "integer divide by 0",13,10,0
    END
;
    TTL    _goto_err
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT |_goto_err|
    IMPORT wimpprint
|_goto_err|
    ADR    R0,mes
    BL      wimpprint
    MOV    pc,lr    ;never gets here
mes DCB    "Assigned GOTO not valid",0
    END

;
    TTL    lnblnk
pc  RN    15
lr  RN    14
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT lnblnk_;(CHV) find last non-blank in CHV
    DCB    "lnblnk_",0,8,0,0,255
lnblnk_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
pt1 SUBS   R1,R1,#1
    LDRGEB R2,[R0,R1]
    CMPGE  R2,#" "
    BEQ    pt1
    ADD    R0,R1,#1
    LDMDB  fp,{fp,sp,pc};return to fortran
    END
;
    TTL    loc
pc  RN    15
lr  RN    14
    AREA   |C$$code|,CODE,READONLY
    EXPORT loc_;(I) returns byte address of I
    EXPORT locc_;(S) returns byte address of String
locc_
loc_
    MOV    pc,lr
    END
;
    TTL   memcmp
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT memcmp;(I,J,N) compare string_I with string_J
memcmp
    MOV    R3,R0
    MOV    R0,#0
l1  SUBS   R2,R2,#1
    LDRGEB ip,[R3],#1
    LDRGEB R0,[R1],#1
    SUBGES R0,ip,R0
    BEQ    l1
    MOV    pc,lr
    END
;
    TTL    memcpy
pc  RN    15
lr  RN    14
ip  RN    12
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT memcpy;(I,J,N) string_I = string_J
    EXPORT memmove;(I,J,N) string_I = string_J
memmove
    CMP    R0,R1
    MOVEQ  pc,lr        ;strings are identical
    BGT    memcpy
    MOV    R3,R0
l1  SUBS   R2,R2,#1
    LDRGEB ip,[R1],#1
    STRGEB ip,[R3],#1
    BGT    l1
    MOV    pc,lr
memcpy
    SUBS   R2,R2,#1
    LDRGEB ip,[R1,R2]
    STRGEB ip,[R0,R2]
    BGT    memcpy
    MOV    pc,lr
    END
;
    TTL   mvbits
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT mvbits_;(M,I,LEN,N,J) moves LEN bits from bit I in M to bit J in N
    EXPORT _mvbits
    DCB    "_mvbits",0,8,0,0,255
mvbits_
_mvbits
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]        ;M
    LDR    R1,[R1]        ;I
    LDR    R2,[R2]        ;LEN
    MOV    ip,#-1
    BIC    ip,ip,ip,LSL R2;LEN-bit mask
    AND    R0,ip,R0,LSR R1;bits of M rightshifted
    LDR    R1,[R3]        ;N
    LDR    R2,[fp,#4]     ;address of J
    LDR    R2,[R2]        ;J
    BIC    R1,R1,ip,LSL R2;mask out bits of N
    ORR    R1,R1,R0,LSL R2;insert bits of M
    STR    R1,[R3]        ;store in N
    LDMDB  fp,{fp,sp,pc}  ;return to fortran
    END
;
    TTL    rnd01
pc  RN    15
lr  RN    14
sp  RN    13
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F0  FN     0
    AREA   seed,DATA
    DCD    207207         ;random seed (equivalent to setrnd(1))
    DCD    69069          ;multiplier
    AREA   |C$$code|,CODE,READONLY
    EXPORT rnd01_;() returns random real*4 (0.0 <= R < 1.0)
    DCB    "rnd01_",0,0,8,0,0,255
rnd01_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,ptr         ;address of seed
    LDMIA  R0,{R1,R2}     ;get seed and multiplier
    MUL    R2,R1,R2
    STR    R2,[R0]        ;store new seed
    BICS   R2,R2,#&FF     ;need this to ensure uniform distribution
    BEQ    lx             ;     at the low end
    MOV    R1,#&3F000000  ;initial exponent
lp  ADDS   R2,R2,R2       ;move up seed 1 bit
    SUBCC  R1,R1,#&800000 ;reduce exponent if no carry
    BCC    lp             ;test next bit
    ORR    R2,R1,R2,LSR#9 ;insert exponent
lx  STR    R2,[sp,#-4]!   ;store answer
    LDFS   F0,[sp],#4     ;load it into result register
    LDMDB  fp,{fp,sp,pc} ;return to fortran
ptr DCD    seed           ;address of seed
;
OS_ReadMonotonicTime EQU &42
    EXPORT setrnd_;(I) set initial number to I
;                      if I=0, set it randomly
    DCB    "setrnd_",0,8,0,0,255
setrnd_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]        ;I
    LDR    R1,ptr         ;pointer to seed
    CMP    R0,#0
    SWIEQ  OS_ReadMonotonicTime ;set random number here if EQ
    ADC    R3,R0,R0       ;multiply by 2 and add 1
    LDR    R2,[R1,#4]     ;multiplier
    MUL    R3,R2,R3       ;take 1 step
    STR    R3,[R1]        ;store new seed
    LDMDB  fp,{fp,sp,pc}  ;return to fortran
    END
;
    TTL    s_catx
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT s_catx;(I,J,K,...) string_I = string_J + string_K + ...
;     arguments are: [I],LEN(I),#components to cat,
;            [J],[K],...,LEN(J),LEN(K)...
s_catx
    STMFD  sp!,{R4-R5,lr}
    ADD    R4,sp,#8       ;pointer to where [J] ought to be
    ADD    R5,R4,R2,LSL#2 ;pointer to LEN(J)
l1  LDR    lr,[R5],#4     ;length of J
;          move J to I
l2  SUBS   lr,lr,#1       ;count characters in J       12/02/99
    LDRGEB ip,[R3],#1
    SUBGES R1,R1,#1       ;count characters in I
    STRGEB ip,[R0],#1
    BGT    l2
    CMP    R1,#0
    LDMLEFD sp!,{R4-R5,pc} ;string_I is full
    SUBS   R2,R2,#1       ;count strings
    LDRGT  R3,[R4,#4]!    ;address of next string
    BGT    l1
;                    blank fill
    MOV    ip,#" "
l3  STRB   ip,[R0],#1
    SUBS   R1,R1,#1
    BGT    l3
    LDMFD  sp!,{R4-R5,pc}
    END
;
    TTL    s_cmp
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT s_cmp;(I,J) compare string_I with string_J
s_cmp
    STMFD  sp!,{R4,lr}
    MOV    R4,R0
l1  LDRB   ip,[R1],#1
    LDRB   lr,[R4],#1
    SUBS   R0,lr,ip
    LDMNEFD sp!,{R4,pc}
    SUB    R2,R2,#1
    SUBS   R3,R3,#1
    CMPGT  R2,#0
    BGT    l1
    SUBS   R0,R2,R3
    LDMEQFD sp!,{R4,pc}
    BGT    l3
l2  LDRB   ip,[R1],#1
    RSBS   R0,ip,#" "
    LDMLTFD sp!,{R4,pc}
    SUBS   R3,R3,#1
    BGT    l2
    LDMFD  sp!,{R4,pc}
l3  LDRB   ip,[R4],#1
    SUBS   R0,ip,#" "
    LDMGTFD sp!,{R4,pc}
    SUBS   R2,R2,#1
    BGT    l3
    LDMFD  sp!,{R4,pc}
    END
;
    TTL    s_copy
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT s_copy;(I,J) string_I = string_J
s_copy
;          move J to I
l1  LDRB   ip,[R1],#1
    SUBS   R2,R2,#1
    STRB   ip,[R0],#1
    SUBGTS R3,R3,#1
    BGT    l1
    CMP    R2,#0
    MOVLE  pc,lr         ;string_I is full
;                    blank fill
    MOV    ip,#" "
l3  STRB   ip,[R0],#1
    SUBS   R2,R2,#1
    BGT    l3
    MOV    pc,lr
    END
;
    TTL    s_index
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT s_index;(I,J) search for string_J in string_I
s_index
    STMFD  sp!,{R4-R5,lr}
    MOV    R4,R0
    MOV    R0,#0         ;result
;               first get length of I to search
    SUBS   R2,R2,R3
    LDMLTFD sp!,{R4-R5,pc} ;string_J is longer than string_I
l1  MOV    R5,R3         ;copy length of J
    ADD    R0,R0,#1
l2  LDRB   ip,[R4],#1
    LDRB   lr,[R1],#1
    CMP    ip,lr
    BNE    pt1
    SUBS   R5,R5,#1
    BGT    l2
    LDMFD  sp!,{R4-R5,pc};found
pt1;        not yet found
    SUBS   R2,R2,#1
    SUBGE  ip,R3,R5      ;# successful bytes
    SUBGE  R4,R4,ip      ;restore to next character in I
    SUBGE  R1,R1,ip
    SUBGE  R1,R1,#1      ;restore to beginning of J
    BGE    l1
    MOV    R0,#0
    LDMFD  sp!,{R4-R5,pc};not there at all
    END
;
    TTL    s_len
pc  RN    15
lr  RN    14
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT s_len;(I) gets length of string_I
s_len
    MOV    R0,R1
    MOV    pc,lr
    END
;
    TTL    s_paus
pc  RN    15
lr  RN    14
R1  RN     1
R0  RN     0
OS_NewLine EQU  3
OS_ReadC   EQU  4
OS_WriteC  EQU  0
OS_WriteN  EQU 70
OS_WriteS  EQU  1
    AREA   |C$$code|,CODE,READONLY
    EXPORT _pause;(MESG,L)
    IMPORT fortran_exit
_pause
    SWI    OS_WriteS
    DCB    13,10,"Pause: ",0,0,0
    CMP    R0,#0
    CMPEQ  R1,#0
    BEQ    lp1
    SWI    OS_WriteN
    SWI    OS_NewLine
lp1 SWI    OS_WriteS
    DCB    "Continue? (Y or N) ",0
    SWI    OS_ReadC
    CMP    R0,#96
    SUBGE  R0,R0,#32;convert to upper
    SWI    OS_WriteC
    SWI    OS_NewLine
    SUBS   R0,R0,#"N"
    BLEQ   fortran_exit  ;stop if "N"
    CMP    R0,#"Y"-"N"
    BNE    lp1
    MOV    pc,lr         ;return if "Y"
    END
;
    TTL    s_rnge
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT s_rnge;(INDX)
    IMPORT wimpprint
s_rnge
    MOV    R1,R0    ;INDX
    ADR    R0,mes
    BL      wimpprint
    MOV    pc,lr    ;never gets here
mes DCB    "*** Range check failure, index = %d ***",13,10,0,0,0
    END
;
    TTL    s_stop
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R2  RN     2
R1  RN     1
R0  RN     0
OS_NewLine EQU  3
OS_Write0  EQU  2
OS_WriteN  EQU 70
OS_WriteS  EQU  1
    AREA   |C$$code|,CODE,READONLY
    EXPORT _stop;(MESG,L)
    IMPORT fortran_exit
    IMPORT wimpprint
    DCB    "_stop",0,0,0,8,0,0,255
_stop
    MOV    ip,sp
    STMFD  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOVS   R2,R0     ;address of string
    CMPNE  R1,#0     ;length of string
    BEQ    fortran_exit
    ADR    R0,fmt
    B      wimpprint
fmt DCB    13,10,"Stop: %.*s",0
*    ADR    R0,fmt
*    SWI    OS_Write0 ;print "stop: "
*    MOVNE  R0,R2
*    SWINE  OS_Write0 ;print message
*    SWI    OS_NewLine
*    MOV    R0,#0     ;no error
*    B      fortran_exit
*fmt DCB    13,10,"Stop: ",0,0
    END
;
     TTL   c_abs
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
F1   FN    1
     AREA   |C$$code|,CODE,READONLY
     EXPORT c_abs; find |c|
c_abs
     LDFS   F0,[R0]
     LDFS   F1,[R0,#4]
     MUFD   F0,F0,F0
     MUFD   F1,F1,F1
     ADFD   F0,F0,F1
     SQTD   F0,F0
     MOV    pc,lr
     END
;
     TTL   c_cnjg
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
R2   RN    2
R3   RN    3
     AREA   |C$$code|,CODE,READONLY
     EXPORT c_cnjg; find conjugate(c)
c_cnjg
     LDMIA  R1,{R2,R3}
     EOR    R3,R3,#&80000000
     STMIA  R0,{R2,R3}
     MOV    pc,lr
     END
;
     TTL   c_cos
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
F0   FN    0
F1   FN    1
F2   FN    2
F3   FN    3
     AREA   |C$$code|,CODE,READONLY
     EXPORT c_cos; find cos(c)
c_cos
     LDFS   F1,[R1,#4]  ;y
     LDFS   F0,[R1]     ;x
     EXPD   F1,F1       ;exp(y)
     COSD   F3,F0       ;cos(x)
     MUFD   F2,F3,F1
     DVFD   F3,F3,F1
     ADFD   F2,F2,F3
     MUFD   F2,F2,#0.5
     STFS   F2,[R0]     ;u = (cosx)(coshy)
     SIND   F3,F0       ;sin(x)
     MUFD   F2,F3,F1
     DVFD   F3,F3,F1
     SUFD   F2,F3,F2
     MUFD   F2,F2,#0.5
     STFS   F2,[R0,#4]  ;v = -(sinx)(sinhy)
     MOV    pc,lr
     END
;
     TTL   c_exp
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
F0   FN    0
F1   FN    1
F2   FN    2
     AREA   |C$$code|,CODE,READONLY
     EXPORT c_exp; find exp(c)
c_exp
     LDFS   F0,[R1]
     LDFS   F1,[R1,#4]
     EXPD   F0,F0      ;exp(x)
     COSD   F2,F1      ;cos(y)
     SIND   F1,F1      ;sin(y)
     MUFD   F2,F2,F0
     MUFD   F1,F1,F0
     STFS   F2,[R0]    ;w = exp(x){cos(y)+i*sin(y)}
     STFS   F1,[R0,#4]
     MOV    pc,lr
     END
;
     TTL   c_log
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
F0   FN    0
F1   FN    1
F2   FN    2
F3   FN    3
     AREA   |C$$code|,CODE,READONLY
     EXPORT c_log; find loge(c)
c_log
     LDFS   F0,[R1]
     LDFS   F1,[R1,#4]
     MUFD   F2,F0,F0
     MUFD   F3,F1,F1
     ADFD   F2,F2,F3    ;|c|**2
     LGND   F2,F2
     MUFD   F2,F2,#0.5
     STFS   F2,[R0]     ;u = log|c|
     POLD   F0,F0,F1
     STFS   F0,[R0,#4]  ;v = arg(c)
     MOV    pc,lr
     END
;
     TTL   c_sin
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
F0   FN    0
F1   FN    1
F2   FN    2
F3   FN    3
     AREA   |C$$code|,CODE,READONLY
     EXPORT c_sin; find sin(c)
c_sin
     LDFS   F1,[R1,#4]  ;y
     LDFS   F0,[R1]     ;x
     EXPD   F1,F1       ;exp(y)
     SIND   F3,F0       ;sin(x)
     MUFD   F2,F3,F1
     DVFD   F3,F3,F1
     ADFD   F2,F2,F3
     MUFD   F2,F2,#0.5
     STFS   F2,[R0]     ;u = (sinx)(coshy)
     COSD   F3,F0       ;cos(x)
     MUFD   F2,F3,F1
     DVFD   F3,F3,F1
     SUFD   F2,F2,F3
     MUFD   F2,F2,#0.5
     STFS   F2,[R0,#4]  ;v = (cosx)(sinhy)
     MOV    pc,lr
     END
;
     TTL   c_sqrt
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
F0   FN    0
F1   FN    1
F2   FN    2
F3   FN    3
     AREA   |C$$code|,CODE,READONLY
     EXPORT c_sqrt; find sqrt(c)
c_sqrt
     LDFS   F0,[R1]
     LDFS   F1,[R1,#4]
     MUFD   F2,F0,F0
     MUFD   F3,F1,F1
     ADFD   F2,F2,F3
     SQTD   F2,F2         ;|c|
     ADFD   F3,F2,F0
     MUFD   F3,F3,#0.5
     SQTD   F3,F3
     STFS   F3,[R0]       ;u = +sqrt((|c|+x)/2)
     CMFE   F3,#0
     DVFNED F1,F1,F3
     MUFNED F3,F1,#0.5    ;v = y/(2u)
     SQTEQD F3,F2         ;or v = +sqrt(|c|) (if u=0)
     STFS   F3,[R0,#4]
     MOV    pc,lr
     END
;
     TTL   div_c
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
R2   RN    2
F0   FN    0
F1   FN    1
F2   FN    2
F3   FN    3
     AREA   |C$$code|,CODE,READONLY
     EXPORT div_c; find a=b/c
div_c
     LDFS   F0,[R2]       ;R(c)
     LDFS   F1,[R2,#4]    ;I(c)
     MUFD   F2,F0,F0
     MUFD   F3,F1,F1
     ADFD   F2,F2,F3      ;|c|**2
     LDFS   F3,[R1]       ;R(b)
     MUFD   F0,F0,F3      ;R(c)R(b)
     LDFS   F3,[R1,#4]    ;I(b)
     MUFD   F1,F1,F3      ;I(b)I(c)
     ADFD   F0,F0,F1
     DVFD   F1,F0,F2
     LDFS   F0,[R2]       ;R(c)
     STFS   F1,[R0]       ;->R(a)
     MUFD   F0,F0,F3      ;I(b)R(c)
     LDFS   F1,[R2,#4]    ;I(c)
     LDFS   F3,[R1]       ;R(b)
     MUFD   F1,F1,F3      ;R(b)I(c)
     SUFD   F0,F0,F1
     DVFD   F0,F0,F2
     STFS   F0,[R0,#4]    ;->I(a)
     MOV    pc,lr
     END
;
     TTL   div_z
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
R2   RN    2
F0   FN    0
F1   FN    1
F2   FN    2
F3   FN    3
     AREA   |C$$code|,CODE,READONLY
     EXPORT div_z; find a=b/c
div_z
     LDFD   F0,[R2]       ;R(c)
     LDFD   F1,[R2,#8]    ;I(c)
     MUFE   F2,F0,F0
     MUFE   F3,F1,F1
     ADFE   F2,F2,F3      ;|c|**2
     LDFD   F3,[R1]       ;R(b)
     MUFE   F0,F0,F3      ;R(c)R(b)
     LDFD   F3,[R1,#8]    ;I(b)
     MUFE   F1,F1,F3      ;I(b)I(c)
     ADFE   F0,F0,F1
     DVFE   F1,F0,F2
     LDFD   F0,[R2]       ;R(c)
     STFD   F1,[R0]       ;->R(a)
     MUFE   F0,F0,F3      ;I(b)R(c)
     LDFD   F1,[R2,#8]    ;I(c)
     LDFD   F3,[R1]       ;R(b)
     MUFE   F1,F1,F3      ;R(b)I(c)
     SUFE   F0,F0,F1
     DVFE   F0,F0,F2
     STFD   F0,[R0,#8]    ;->I(a)
     MOV    pc,lr
     END
;
     TTL   z_abs
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
F1   FN    1
     AREA   |C$$code|,CODE,READONLY
     EXPORT z_abs; find |z|
z_abs
     LDFD   F0,[R0]
     LDFD   F1,[R0,#8]
     MUFE   F0,F0,F0
     MUFE   F1,F1,F1
     ADFE   F0,F0,F1
     SQTE   F0,F0
     MOV    pc,lr
     END
;
     TTL   z_cnjg
pc   RN    15
lr   RN    14
ip   RN    12
R0   RN    0
R1   RN    1
R2   RN    2
R3   RN    3
     AREA   |C$$code|,CODE,READONLY
     EXPORT z_cnjg; find conjugate(z)
z_cnjg
     LDMIA  R1,{R1-R3,ip}
     EOR    R3,R3,#&80000000
     STMIA  R0,{R1-R3,ip}
     MOV    pc,lr
     END
;
     TTL   z_cos
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
F0   FN    0
F1   FN    1
F2   FN    2
F3   FN    3
     AREA   |C$$code|,CODE,READONLY
     EXPORT z_cos; find cos(z)
z_cos
     LDFD   F1,[R1,#8]
     LDFD   F0,[R1]     ;x
     EXPE   F1,F1       ;exp(y)
     COSE   F3,F0
     MUFE   F2,F3,F1
     DVFE   F3,F3,F1
     ADFE   F2,F2,F3
     MUFE   F2,F2,#0.5
     STFD   F2,[R0]     ;u = (cosx)(coshy)
     SINE   F3,F0
     MUFE   F2,F3,F1
     DVFE   F3,F3,F1
     SUFE   F2,F3,F2
     MUFE   F2,F2,#0.5
     STFD   F2,[R0,#8]  ;v = -(sinx)(sinhy)
     MOV    pc,lr
     END
;
     TTL   z_exp
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
F0   FN    0
F1   FN    1
F2   FN    2
     AREA   |C$$code|,CODE,READONLY
     EXPORT z_exp; find exp(z)
z_exp
     LDFD   F0,[R1]
     LDFD   F1,[R1,#8]
     EXPE   F0,F0      ;exp(x)
     COSE   F2,F1
     SINE   F1,F1
     MUFE   F2,F2,F0
     MUFE   F1,F1,F0
     STFD   F2,[R0]    ;w = exp(x){cos(y)+i*sin(y)}
     STFD   F1,[R0,#8]
     MOV    pc,lr
     END
;
     TTL   z_imag
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT z_imag; find imaginary part of z
z_imag
     LDFD   F0,[R0,#8]
     MOV    pc,lr
     END
;
     TTL   z_log
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
F0   FN    0
F1   FN    1
F2   FN    2
F3   FN    3
     AREA   |C$$code|,CODE,READONLY
     EXPORT z_log; find loge(z)
z_log
     LDFD   F0,[R1]
     LDFD   F1,[R1,#8]
     MUFE   F2,F0,F0
     MUFE   F3,F1,F1
     ADFE   F2,F2,F3    ;|z|**2
     LGNE   F2,F2
     MUFE   F2,F2,#0.5
     STFD   F2,[R0]     ;u = log|z|
     POLE   F0,F0,F1
     STFD   F0,[R0,#8]  ;v = arg(z)
     MOV    pc,lr
     END
;
     TTL   z_sin
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
F0   FN    0
F1   FN    1
F2   FN    2
F3   FN    3
     AREA   |C$$code|,CODE,READONLY
     EXPORT z_sin; find sin(z)
z_sin
     LDFD   F1,[R1,#8]
     LDFD   F0,[R1]     ;x
     EXPE   F1,F1       ;exp(y)
     SINE   F3,F0
     MUFE   F2,F3,F1
     DVFE   F3,F3,F1
     ADFE   F2,F2,F3
     MUFE   F2,F2,#0.5
     STFD   F2,[R0]     ;u = (sinx)(coshy)
     COSE   F3,F0
     MUFE   F2,F3,F1
     DVFE   F3,F3,F1
     SUFE   F2,F2,F3
     MUFE   F2,F2,#0.5
     STFD   F2,[R0,#8]  ;v = (cosx)(sinhy)
     MOV    pc,lr
     END
;
     TTL   z_sqrt
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
F0   FN    0
F1   FN    1
F2   FN    2
F3   FN    3
     AREA   |C$$code|,CODE,READONLY
     EXPORT z_sqrt; find sqrt(z)
z_sqrt
     LDFD   F0,[R1]
     LDFD   F1,[R1,#8]
     MUFE   F2,F0,F0
     MUFE   F3,F1,F1
     ADFE   F2,F2,F3
     SQTE   F2,F2
     ADFE   F3,F2,F0
     MUFE   F3,F3,#0.5
     SQTE   F3,F3
     STFD   F3,[R0]
     CMFE   F3,#0
     DVFNEE F1,F1,F3
     MUFNEE F3,F1,#0.5
     SQTEQE F3,F2
     STFD   F3,[R0,#8]
     MOV    pc,lr
     END
;
     TTL   d_abs
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT d_abs; find |d|
d_abs
     LDFD   F0,[R0]
     ABSD   F0,F0
     MOV    pc,lr
     END
;
     TTL   d_acos
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT d_acos; find arccos(d)
d_acos
     LDFD   F0,[R0]
     ACSD   F0,F0
     MOV    pc,lr
     END
;
     TTL   d_asin
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT d_asin; find arcsin(d)
d_asin
     LDFD   F0,[R0]
     ASND   F0,F0
     MOV    pc,lr
     END
;
     TTL   d_atan
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
F1   FN    1
     AREA   |C$$code|,CODE,READONLY
     EXPORT d_atan; find arctan(d)
d_atan
     LDFD   F0,[R0]
     ATND   F0,F0
     MOV    pc,lr
     END
;
     TTL   d_atn2
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
F0   FN    0
F1   FN    1
     AREA   |C$$code|,CODE,READONLY
     EXPORT d_atn2; find ATAN2(y,x)
d_atn2
     LDFD   F0,[R0]
     LDFD   F1,[R1]
     POLD   F0,F1,F0
     MOV    pc,lr
     END
;
     TTL   d_cos
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT d_cos; find cos(d)
d_cos
     LDFD   F0,[R0]
     COSD   F0,F0
     MOV    pc,lr
     END
;
     TTL   d_cosh
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
F1   FN    1
     AREA   |C$$code|,CODE,READONLY
     EXPORT d_cosh; find cosh(d)
d_cosh
     LDFD   F0,[R0]
     EXPE   F1,F0
     RDFE   F0,F1,#1
     ADFE   F1,F1,F0
     MUFE   F0,F1,#0.5
     MOV    pc,lr
     END
;
     TTL   d_dim
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
F0   FN    0
F1   FN    1
     AREA   |C$$code|,CODE,READONLY
     EXPORT d_dim; find DIM(a,b)
d_dim
     LDFD   F0,[R0]
     LDFD   F1,[R1]
     SUFD   F0,F0,F1
     CMFE   F0,#0
     MVFLTD F0,#0
     MOV    pc,lr
     END
;
     TTL   d_exp
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT d_exp; find exp(d)
d_exp
     LDFD   F0,[R0]
     EXPD   F0,F0
     MOV    pc,lr
     END
;
     TTL   d_int
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT d_int; find int(d)
d_int
     LDFD   F0,[R0]
     RNDDZ  F0,F0
     MOV    pc,lr
     END
;
     TTL   d_lg10
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT d_lg10; find log10(d)
d_lg10
     LDFD   F0,[R0]
     LOGD   F0,F0
     MOV    pc,lr
     END
;
     TTL   d_log
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT d_log; find loge(d)
d_log
     LDFD   F0,[R0]
     LGND   F0,F0
     MOV    pc,lr
     END
;
     TTL   d_mod
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
F0   FN    0
F1   FN    1
F2   FN    2
F3   FN    3
     AREA   |C$$code|,CODE,READONLY
     EXPORT d_mod; find mod(d,g)
d_mod
     LDFD   F2,[R0]
     LDFD   F1,[R1]
     RMFE   F0,F2,F1
;            RMF function sometimes gets wrong sign
;            so must do this explicitly.
     FMLS   F3,F2,F0
     CMFE   F3,#0
     MOVGE  pc,lr
     ABSE   F1,F1
     CMFE   F2,#0
     SUFLTE F0,F0,F1
     ADFGTE F0,F0,F1
     MOV    pc,lr
     END
;
     TTL   d_nint
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT d_nint; find nint(d)
d_nint
     LDFD   F0,[R0]
     RNDD   F0,F0
     MOV    pc,lr
     END
;
     TTL   d_prod
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
F0   FN    0
F1   FN    1
     AREA   |C$$code|,CODE,READONLY
     EXPORT d_prod; find product of 2 real*4
d_prod
     LDFS   F0,[R0]
     LDFS   F1,[R1]
     MUFE   F0,F0,F1
     MOV    pc,lr
     END
;
     TTL   d_sign
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT d_sign; find sign(d,g)
d_sign
     LDFD   F0,[R0]
     LDR    R1,[R1]
     ABSD   F0,F0
     CMP    R1,#0
     MNFLTD F0,F0
     MOV    pc,lr
     END
;
     TTL   d_sin
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT d_sin; find sin(d)
d_sin
     LDFD   F0,[R0]
     SIND   F0,F0
     MOV    pc,lr
     END
;
     TTL   d_sinh
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
F1   FN    1
     AREA   |C$$code|,CODE,READONLY
     EXPORT d_sinh; find sinh(d)
d_sinh
     LDFD   F0,[R0]
     EXPE   F1,F0
     RDFE   F0,F1,#1
     SUFE   F1,F1,F0
     MUFE   F0,F1,#0.5
     MOV    pc,lr
     END
;
     TTL   d_sqrt
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT d_sqrt; find sqrt(d)
d_sqrt
     LDFD   F0,[R0]
     SQTD   F0,F0
     MOV    pc,lr
     END
;
     TTL   d_tan
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT d_tan; find tan(d)
d_tan
     LDFD   F0,[R0]
     TAND   F0,F0
     MOV    pc,lr
     END
;
     TTL   d_tanh
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
F1   FN    1
F2   FN    2
     AREA   |C$$code|,CODE,READONLY
     EXPORT d_tanh; find tanh(d)
d_tanh
     LDFD   F0,[R0]
     ADFD   F2,F0,F0
     EXPE   F1,F2
     SUFE   F2,F1,#1
     ADFE   F1,F1,#1
     DVFE   F0,F2,F1
     MOV    pc,lr
     END
;
     TTL   acosh
pc   RN    15
lr   RN    14
sp   RN    13
ip   RN    12
fp   RN    11
R0   RN     0
F0   FN     0
F1   FN     1
     AREA   |C$$code|,CODE,READONLY
     EXPORT acosh_
     EXPORT dacosh_
     DCB    "acosh_",0,0,8,0,0,255
acosh_
     MOV    ip,sp
     STMDB  sp!,{R0,fp,ip,lr,pc}
     SUB    fp,ip,#4
     LDFS   F0,[R0]
     B      pt1
;
     DCB    "dacosh_",0,8,0,0,255
dacosh_
     MOV    ip,sp
     STMDB  sp!,{R0,fp,ip,lr,pc}
     SUB    fp,ip,#4
     LDFD   F0,[R0]
pt1  MUFE   F1,F0,F0
     SUFE   F1,F1,#1
     SQTE   F1,F1
     ADFE   F1,F1,F0
     LGND   F0,F1
     LDMDB  fp,{fp,sp,pc} ;return
     END
;
     TTL   asinh
pc   RN    15
lr   RN    14
sp   RN    13
ip   RN    12
fp   RN    11
R0   RN     0
F0   FN     0
F1   FN     1
     AREA   |C$$code|,CODE,READONLY
     EXPORT asinh_
     EXPORT dasinh_
     DCB    "asinh_",0,0,8,0,0,255
asinh_
     MOV    ip,sp
     STMDB  sp!,{R0,fp,ip,lr,pc}
     SUB    fp,ip,#4
     LDFS   F0,[R0]
     B      pt1
;
     DCB    "dasinh_",0,8,0,0,255
dasinh_
     MOV    ip,sp
     STMDB  sp!,{R0,fp,ip,lr,pc}
     SUB    fp,ip,#4
     LDFD   F0,[R0]
pt1  MUFE   F1,F0,F0
     ADFE   F1,F1,#1
     SQTE   F1,F1
     ADFE   F1,F1,F0
     LGND   F0,F1
     LDMDB  fp,{fp,sp,pc} ;return
     END
;
     TTL   atanh
pc   RN    15
lr   RN    14
sp   RN    13
ip   RN    12
fp   RN    11
R0   RN     0
F0   FN     0
F1   FN     1
     AREA   |C$$code|,CODE,READONLY
     EXPORT atanh_
     EXPORT datanh_
     DCB    "atanh_",0,0,8,0,0,255
atanh_
     MOV    ip,sp
     STMDB  sp!,{R0,fp,ip,lr,pc}
     SUB    fp,ip,#4
     LDFS   F0,[R0]
     B      pt1
;
     DCB    "datanh_",0,8,0,0,255
datanh_
     MOV    ip,sp
     STMDB  sp!,{R0,fp,ip,lr,pc}
     SUB    fp,ip,#4
     LDFD   F0,[R0]
pt1  ADFE   F1,F0,#1
     RSFE   F0,F0,#1
     DVFE   F1,F1,F0
     LGND   F0,F1
     MUFD   F0,F0,#0.5
     LDMDB  fp,{fp,sp,pc} ;return
     END
;
     TTL   h_abs
pc   RN    15
lr   RN    14
R1   RN    1
R0   RN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT h_abs; find |i|
h_abs
     LDRB   R1,[R0,#1]  ;m.s. byte of i
     LDRB   R0,[R0]     ;l.s. byte of i
     ADD    R0,R0,R1,LSL#8 ;all of i
     TST    R1,#128     ;check for 'negative'
     RSBNE  R0,R0,#&10000
     MOV    pc,lr
     END
;
     TTL   h_dim
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
R2   RN    2
R3   RN    3
     AREA   |C$$code|,CODE,READONLY
     EXPORT h_dim; find DIM(a,b)
h_dim
     LDRB   R2,[R0,#1]  ;m.s. byte of a
     LDRB   R3,[R1,#1]  ;m.s. byte of b
     LDRB   R0,[R0]     ;l.s. byte of a
     LDRB   R1,[R1]     ;l.s. byte of b
     ADD    R0,R0,R2,LSL#8 ;a
     ADD    R1,R1,R3,LSL#8 ;b
     MOV    R0,R0,LSL#16
     MOV    R1,R1,LSL#16
     SUBS   R0,R0,R1
     MOVLT  R0,#0
     MOV    R0,R0,ASR#16
     MOV    pc,lr
     END
;
     TTL   h_mod
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
R2   RN    2
R3   RN    3
     AREA   |C$$code|,CODE,READONLY
     EXPORT h_mod; find mod(i,j)
     IMPORT wimpprint
h_mod
     LDRB   R2,[R0,#1]  ;m.s. byte of i
     LDRB   R3,[R1,#1]  ;m.s. byte of j
     LDRB   R0,[R0]     ;l.s. byte of i
     LDRB   R1,[R1]     ;l.s. byte of j
     ADD    R0,R0,R2,LSL#8 ;i
     ADDS   R2,R1,R3,LSL#8 ;j
     BEQ    err
     MOV    R1,R0       ;copy of i (for sign bit)
     TST    R0,#&8000
     RSBNE  R0,R0,#&10000;|i|
     TST    R2,#&8000
     RSBNE  R2,R2,#&10000;|j|
     MOV    R3,R2     ;copy of |j|
     CMP    R3,R0,LSR#1
l1   MOVLS  R3,R3,LSL#1
     CMP    R3,R0,LSR#1
     BLS    l1
l2   CMP    R0,R3
     SUBCS  R0,R0,R3
     MOV    R3,R3,LSR#1
     CMP    R3,R2
     BHS    l2
     TST    R1,#&8000
     RSBNE  R0,R0,#0
     MOV    pc,lr
err  MOV    R1,R0,LSL#16
     MOV    R1,R1,ASR#16     ;fill sign
     ADR    R0,erm
     BL     wimpprint
     MOV    pc,lr    ;never gets here
erm  DCB    "INTEGER*2 MOD(%d,0)",13,10,0
     END
;
     TTL   h_sign
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
R2   RN    2
R3   RN    3
     AREA   |C$$code|,CODE,READONLY
     EXPORT h_sign; find isign(i,j)
h_sign
     LDRB   R2,[R0,#1]  ;m.s. byte of i
     LDRB   R3,[R1,#1]  ;m.s. byte of j
     LDRB   R0,[R0]     ;l.s. byte of i
     LDRB   R1,[R1]     ;l.s. byte of j
     ADD    R0,R0,R2,LSL#8 ;i
     ADD    R1,R1,R3,LSL#8 ;j
     EOR    R2,R1,R0       ;sign difference
     MOV    R0,R0,LSL#16   ;extend sign of i
     MOV    R0,R0,ASR#16
     TST    R2,#&8000
     RSBNE  R0,R0,#0
     MOV    pc,lr
     END
;
     TTL   i_abs
pc   RN    15
lr   RN    14
R0   RN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT i_abs; find |i|
i_abs
     LDR    R0,[R0]
     CMP    R0,#0
     RSBLT  R0,R0,#0
     MOV    pc,lr
     END
;
     TTL   i_dim
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
     AREA   |C$$code|,CODE,READONLY
     EXPORT i_dim; find DIM(a,b)
i_dim
     LDR    R0,[R0]
     LDR    R1,[R1]
     SUBS   R0,R0,R1
     MOVLT  R0,#0
     MOV    pc,lr
     END
;
     TTL   i_dnnt
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT i_dnnt; find nint(d)
i_dnnt
     LDFD   F0,[R0]
     FIX    R0,F0
     MOV    pc,lr
     END
;
     TTL   i_mod
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
R2   RN    2
R3   RN    3
     AREA   |C$$code|,CODE,READONLY
     EXPORT i_mod; find mod(i,j)
     IMPORT wimpprint
i_mod
     LDR    R2,[R1]   ;j (denominator)
     LDR    R1,[R0]   ;i (numerator)
     CMP    R2,#0
     ADREQ  R0,err
     BLEQ   wimpprint ; does not return
     RSBLT  R2,R2,#0  ;|j|
     MOV    R3,R2     ;copy of |j|
     MOV    R0,R1
     RSBMI  R0,R0,#0  ;|i|
     CMP    R3,R0,LSR#1
l1   MOVLS  R3,R3,LSL#1
     CMP    R3,R0,LSR#1
     BLS    l1
l2   CMP    R0,R3
     SUBCS  R0,R0,R3
     MOV    R3,R3,LSR#1
     CMP    R3,R2
     BHS    l2
     CMP    R1,#0
     RSBLT  R0,R0,#0
     MOV    pc,lr
err  DCB    "INTEGER*4 MOD(%d,0)",13,10,0
     END
;
     TTL   i_rnnt
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT i_rnnt; find nint(r)
i_rnnt
     LDFS   F0,[R0]
     FIX    R0,F0
     MOV    pc,lr
     END
;
     TTL   i_sign
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
     AREA   |C$$code|,CODE,READONLY
     EXPORT i_sign; find isign(i,g)
i_sign
     LDR    R0,[R0]
     LDR    R1,[R1]
     EORS   R1,R1,R0
     RSBMI  R0,R0,#0
     MOV    pc,lr
     END
;
     TTL   pow_cc
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
R2   RN    2
F0   FN    0
F1   FN    1
F2   FN    2
F3   FN    3
     AREA   |C$$code|,CODE,READONLY
     EXPORT pow_cc; find z**w (z & w are complex)
;          addresses of z in R1, and w in R2
;          returns answer to R0
pow_cc
     LDFS   F0,[R1]      ;x
     LDFS   F1,[R1,#4]   ;y
     MUFD   F2,F0,F0
     MUFD   F3,F1,F1
     ADFD   F3,F2,F3     ;|z|**2
     LGND   F3,F3        ;log(|z|**2)
     POLD   F2,F0,F1     ;phi  [note: log(z)=log(|z|) + i*phi]
     MUFD   F3,F3,#0.5   ;log(|z|)
     LDFS   F0,[R2]      ;u
     LDFS   F1,[R2,#4]   ;v
     MUFD   F0,F0,F3     ;u*log(|z|)
     MUFD   F3,F3,F1     ;v*log(|z|)
     MUFD   F1,F1,F2     ;v*phi
     SUFD   F0,F0,F1     ;R(w*log(z))
     LDFS   F1,[R2]      ;u (again)
     MUFD   F2,F2,F1     ;u*phi
     ADFD   F3,F3,F2     ;I(w*log(z))
     EXPD   F0,F0
     COSD   F2,F3
     SIND   F3,F3
     MUFD   F2,F2,F0
     MUFD   F3,F3,F0
     STFS   F2,[R0]      ;result = exp[w*log(z)]
     STFS   F3,[R0,#4]
     MOV    pc,lr
     END
;
     TTL   pow_ci
pc   RN    15
lr   RN    14
sp   RN    13
R0   RN    0
R1   RN    1
R2   RN    2
F0   FN    0
F1   FN    1
F2   FN    2
F3   FN    3
F4   FN    4
F5   FN    5
     AREA   |C$$code|,CODE,READONLY
     EXPORT pow_ci; find z**n (z is complex)
;          address of z in R1, n in R2
;          returns answer to R0
pow_ci
     LDFS   F2,[R1]        ;multiplier (w)
     LDFS   F3,[R1,#4]
     MVFS   F0,#1          ;initialise answer
     MVFS   F1,#0
     CMP    R2,#0
     BEQ    ret            ;return
     STFE   F4,[sp,#-12]!
     STFE   F5,[sp,#-12]!
     MUFLTD F4,F2,F2
     MUFLTD F5,F3,F3
     ADFLTD F4,F4,F5
     DVFLTD F2,F2,F4
     DVFLTD F3,F3,F4
     MNFLTD F3,F3          ;w = 1/w if exponent is negative
     RSBLT  R2,R2,#0
l2   MOVS   R2,R2,LSR#1
     MUFCSD F4,F1,F3
     MUFCSD F5,F1,F2
     MUFCSD F1,F0,F3
     ADFCSD F1,F1,F5
     MUFCSD F0,F0,F2
     SUFCSD F0,F0,F4        ;z=z*w
     MUFNED F4,F3,F3
     MUFNED F3,F3,F2
     MUFNED F2,F2,F2
     SUFNED F2,F2,F4
     ADFNED F3,F3,F3        ;w=w*w
     BNE    l2
     LDFE   F5,[sp],#12
     LDFE   F4,[sp],#12
ret  STFS   F0,[R0]
     STFS   F1,[R0,#4]
     MOV    pc,lr
     END
;
     TTL   pow_dd
pc   RN    15
lr   RN    14
sp   RN    13
R0   RN    0
R1   RN    1
R2   RN    2
R3   RN    3
F0   FN    0
F1   FN    1
     AREA   |C$$code|,CODE,READONLY
     EXPORT pow_dd; find d**g (d&g are double precision)
;          d in R0,R1 g in R2,R3
;          returns answer in F0
pow_dd
     STMFD  sp!,{R0-R3} ;transfer d and g
     LDFD   F0,[sp],#8  ;to F0
     LDFD   F1,[sp],#8  ;and F1
     POWD   F0,F0,F1
     MOV    pc,lr
     END
;
     TTL   pow_di
pc   RN    15
lr   RN    14
sp   RN    13
R0   RN    0
R1   RN    1
R2   RN    2
F0   FN    0
F1   FN    1
     AREA   |C$$code|,CODE,READONLY
     EXPORT pow_di; find d**n (d is double precision)
;          d in R0,R1, n in R2
;          returns answer in F0
pow_di
     STMFD  sp!,{R0,R1}  ;extract d from R1,R2
     LDFD   F1,[sp],#8
     MVFE   F0,#1        ;initialise answer
     CMP    R2,#0
     MOVEQ  pc,lr
     RDFLTE F1,F1,#1     ;1/x if exponent is negative
     RSBLT  R2,R2,#0
l2   MOVS   R2,R2,LSR#1
     MUFCSE F0,F0,F1
     MUFNEE F1,F1,F1
     BNE    l2
     MOV    pc,lr
     END
;
     TTL   pow_ii
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
R2   RN    2
R3   RN    3
     AREA   |C$$code|,CODE,READONLY
     EXPORT pow_ii; find i**n (i is an integer)
;           i in R0, n in R1
pow_ii
     MOV    R2,R0        ;multiplier
     MOV    R0,#1        ;initialise answer
     CMP    R1,#0        ;also sets 'C' bit
     MOVLT  R0,#0
     MOVLE  pc,lr
l2   MOVS   R1,R1,LSR#1
     MULCS  R0,R2,R0
     MOVNE  R3,R2
     MULNE  R2,R3,R2
     BNE    l2
     MOV    pc,lr
     END
;
     TTL   pow_ri
pc   RN    15
lr   RN    14
sp   RN    13
R0   RN    0
R1   RN    1
R2   RN    2
F0   FN    0
F1   FN    1
     AREA   |C$$code|,CODE,READONLY
     EXPORT pow_ri; find x**n (x is real*4)
;             x in R0,R1, n in R2, answer returned in F0
pow_ri
     STMFD  sp!,{R0,R1}  ;extract x from R1,R2
     LDFD   F1,[sp],#8   ;multiplier
     MVFD   F0,#1        ;initialise answer
     CMP    R2,#0
     MOVEQ  pc,lr
     RDFLTD F1,F1,#1     ;1/x if exponent is negative
     RSBLT  R2,R2,#0
l2   MOVS   R2,R2,LSR#1
     MUFCSD F0,F0,F1
     MUFNED F1,F1,F1
     BNE    l2
     MOV    pc,lr
     END
;
     TTL   pow_rr
pc   RN    15
lr   RN    14
sp   RN    13
R0   RN    0
R1   RN    1
R2   RN    2
R3   RN    3
F0   FN    0
F1   FN    1
     AREA   |C$$code|,CODE,READONLY
     EXPORT pow_rr; find r**g (r&g are real*4)
;          r in R0,R1, g in R2,R3
;          returns answer in F0
pow_rr
     STMFD  sp!,{R0-R3}  ;extract r and g
     LDFD   F0,[sp],#8   ;to F0
     LDFD   F1,[sp],#8   ;and F1
     POWS   F0,F0,F1
     MOV    pc,lr
     END
;
     TTL   pow_zi
pc   RN    15
lr   RN    14
sp   RN    13
R0   RN    0
R1   RN    1
R2   RN    2
F0   FN    0
F1   FN    1
F2   FN    2
F3   FN    3
F4   FN    4
F5   FN    5
     AREA   |C$$code|,CODE,READONLY
     EXPORT pow_zi; find z**n ( is complex*16)
;        address of z is in R1, n is in R2
;        answer returned to R0
pow_zi
     LDFD   F2,[R1]        ;multiplier (w)
     LDFD   F3,[R1,#8]
     MVFD   F0,#1          ;initialise answer
     MVFD   F1,#0
     CMP    R2,#0
     BEQ    ret
     STFE   F4,[sp,#-12]!
     STFE   F5,[sp,#-12]!
     MUFLTE F4,F2,F2
     MUFLTE F5,F3,F3
     ADFLTE F4,F4,F5
     DVFLTE F2,F2,F4
     DVFLTE F3,F3,F4
     MNFLTE F3,F3          ;w = 1/w if exponent is negative
     RSBLT  R2,R2,#0
l2   MOVS   R2,R2,LSR#1
     MUFCSE F4,F1,F3
     MUFCSE F5,F1,F2
     MUFCSE F1,F0,F3
     ADFCSE F1,F1,F5
     MUFCSE F0,F0,F2
     SUFCSE F0,F0,F4        ;z=z*w
     MUFNEE F4,F3,F3
     MUFNEE F3,F3,F2
     MUFNEE F2,F2,F2
     SUFNEE F2,F2,F4
     ADFNEE F3,F3,F3        ;w=w*w
     BNE    l2
     LDFE   F5,[sp],#12
     LDFE   F4,[sp],#12
ret  STFD   F0,[R0]
     STFD   F1,[R0,#8]
     MOV    pc,lr
     END
;
     TTL   pow_zz
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
R2   RN    2
F0   FN    0
F1   FN    1
F2   FN    2
F3   FN    3
     AREA   |C$$code|,CODE,READONLY
     EXPORT pow_zz; find z**w (z & w are complex*16)
;          addresses of z in R1, and w in R2
;          returns answer to R0
pow_zz
     LDFD   F0,[R1]      ;x
     LDFD   F1,[R1,#8]   ;y
     MUFE   F2,F0,F0
     MUFE   F3,F1,F1
     ADFE   F3,F2,F3     ;|z|**2
     LGNE   F3,F3        ;log(|z|**2)
     POLE   F2,F0,F1     ;phi  [note: log(z)=log(|z|) + i*phi]
     MUFE   F3,F3,#0.5   ;log(|z|)
     LDFD   F0,[R2]      ;u
     LDFD   F1,[R2,#8]   ;v
     MUFE   F0,F0,F3     ;u*log(|z|)
     MUFE   F3,F3,F1     ;v*log(|z|)
     MUFE   F1,F1,F2     ;v*phi
     SUFE   F0,F0,F1     ;R(w*log(z))
     LDFD   F1,[R2]      ;u (again)
     MUFE   F2,F2,F1     ;u*phi
     ADFE   F3,F3,F2     ;I(w*log(z))
     EXPE   F0,F0
     COSE   F2,F3
     SINE   F3,F3
     MUFE   F2,F2,F0
     MUFE   F3,F3,F0
     STFD   F2,[R0]
     STFD   F3,[R0,#8]
     MOV    pc,lr
     END
;
     TTL   r_abs
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT r_abs; find |r|
r_abs
     LDFS   F0,[R0]
     ABSS   F0,F0
     MOV    pc,lr
     END
;
     TTL   r_acos
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT r_acos; find arccos(r)
r_acos
     LDFS   F0,[R0]
     ACSS   F0,F0
     MOV    pc,lr
     END
;
     TTL   r_asin
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT r_asin; find arcsin(r)
r_asin
     LDFS   F0,[R0]
     ASNS   F0,F0
     MOV    pc,lr
     END
;
     TTL   r_atan
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
F1   FN    1
     AREA   |C$$code|,CODE,READONLY
     EXPORT r_atan; find arctan(r)
r_atan
     LDFS   F0,[R0]
     ATNS   F0,F0
     MOV    pc,lr
     END
;
     TTL   r_atn2
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
F0   FN    0
F1   FN    1
     AREA   |C$$code|,CODE,READONLY
     EXPORT r_atn2; find ATAN2(y,x)
r_atn2
     LDFS   F0,[R0]
     LDFS   F1,[R1]
     POLS   F0,F1,F0
     MOV    pc,lr
     END
;
     TTL   r_cos
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT r_cos; find cos(r)
r_cos
     LDFS   F0,[R0]
     COSS   F0,F0
     MOV    pc,lr
     END
;
     TTL   r_cosh
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
F1   FN    1
     AREA   |C$$code|,CODE,READONLY
     EXPORT r_cosh; find cosh(r)
r_cosh
     LDFS   F0,[R0]
     EXPD   F1,F0
     RDFD   F0,F1,#1
     ADFD   F1,F1,F0
     FMLD   F0,F1,#0.5
     MOV    pc,lr
     END
;
     TTL   r_dim
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
F0   FN    0
F1   FN    1
     AREA   |C$$code|,CODE,READONLY
     EXPORT r_dim; find DIM(a,b)
r_dim
     LDFS   F0,[R0]
     LDFS   F1,[R1]
     SUFS   F0,F0,F1
     CMFE   F0,#0
     MVFLTS F0,#0
     MOV    pc,lr
     END

     TTL   r_exp
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT r_exp; find exp(r)
r_exp
     LDFS   F0,[R0]
     EXPS   F0,F0
     MOV    pc,lr
     END
;
     TTL   r_imag
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT r_imag; find imag(r)
r_imag
     LDFS   F0,[R0,#4]
     MOV    pc,lr
     END
;
     TTL   r_int
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT r_int; find int(r)
r_int
     LDFS   F0,[R0]
     RNDSZ  F0,F0
     MOV    pc,lr
     END
;
     TTL   r_lg10
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT r_lg10; find log10(r)
r_lg10
     LDFS   F0,[R0]
     LOGS   F0,F0
     MOV    pc,lr
     END
;
     TTL   r_log
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT r_log; find loge(r)
r_log
     LDFS   F0,[R0]
     LGNS   F0,F0
     MOV    pc,lr
     END
;
     TTL   r_mod
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
F0   FN    0
F1   FN    1
F2   FN    2
F3   FN    3
     AREA   |C$$code|,CODE,READONLY
     EXPORT r_mod; find mod(r,g)
r_mod
     LDFS   F2,[R0]
     LDFS   F1,[R1]
     RMFS   F0,F2,F1
;            RMF function sometimes gets wrong sign
;            so must do this explicitly.
     FMLS   F3,F2,F0
     CMFE   F3,#0
     MOVGE  pc,lr
     ABSS   F1,F1
     CMFE   F2,#0
     SUFLTS F0,F0,F1
     ADFGTS F0,F0,F1
;            end of bodge
     MOV    pc,lr
     END
;
     TTL   r_nint
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT r_nint; find nint(r)
r_nint
     LDFS   F0,[R0]
     RNDS   F0,F0
     MOV    pc,lr
     END
;
     TTL   r_sign
pc   RN    15
lr   RN    14
R0   RN    0
R1   RN    1
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT r_sign; find sign(r,g)
r_sign
     LDFS   F0,[R0]
     LDR    R1,[R1]
     ABSS   F0,F0
     CMP    R1,#0
     MNFLTS F0,F0
     MOV    pc,lr
     END
;
     TTL   r_sin
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT r_sin; find sin(r)
r_sin
     LDFS   F0,[R0]
     SINS   F0,F0
     MOV    pc,lr
     END
;
     TTL   r_sinh
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
F1   FN    1
     AREA   |C$$code|,CODE,READONLY
     EXPORT r_sinh; find sinh(r)
r_sinh
     LDFS   F0,[R0]
     EXPD   F1,F0
     RDFD   F0,F1,#1
     SUFD   F1,F1,F0
     FMLD   F0,F1,#0.5
     MOV    pc,lr
     END
;
     TTL   r_sqrt
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT r_sqrt; find sqrt(r)
r_sqrt
     LDFS   F0,[R0]
     SQTS   F0,F0
     MOV    pc,lr
     END
;
     TTL   r_tan
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
     AREA   |C$$code|,CODE,READONLY
     EXPORT r_tan; find tan(r)
r_tan
     LDFS   F0,[R0]
     TANS   F0,F0
     MOV    pc,lr
     END
;
     TTL   r_tanh
pc   RN    15
lr   RN    14
R0   RN    0
F0   FN    0
F1   FN    1
F2   FN    2
     AREA   |C$$code|,CODE,READONLY
     EXPORT r_tanh; find tanh(r)
r_tanh
     LDFS   F0,[R0]
     ADFS   F2,F0,F0
     EXPD   F1,F2     ;exp(2*r)
     SUFD   F2,F1,#1
     ADFD   F1,F1,#1
     DVFD   F0,F2,F1
     MOV    pc,lr
     END
;
    TTL   rsvmem
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
sl  RN    10
R8  RN     8
R7  RN     7
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
stackx     EQU &210      ;spare space below stack limit
    AREA   |C$$code|,CODE,READONLY
    EXPORT rsvmem_;(NW,COMMON,IAD) reserves memory
    IMPORT get_stack
    IMPORT change_memory
    DCB    "rsvmem_",0,8,0,0,255
rsvmem_;
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R5,[R0]       ;NW
    BL     get_stack     ;returns: sl, R6=top of stack, R2=top of memory
                         ;    R7,R8 are reserved memory
    MOVS   R5,R5,LSL#2   ;NB = NW*4 (#bytes required)
    STREQ  R5,[R4,#-4]
    STREQ  R5,[R4,#-8]   ;clear reserved area
    LDMEQDB fp,{R4-R8,fp,sp,pc}; and return without looking at extra args
    CMP    R7,#0         ;check there is no current reserved area
    MOVNE  R5,#0
    BNE    ret
;        search stack for gaps
    MOV    R8,sl
    MOV    R3,R2         ;bottom of previous stack
lp1 SUB    R0,R8,#stackx ;real bottom of current stack
    LDMIA  R0,{R7,R8}    ;address of top of stack and bottom of previous
    SUB    lr,R3,R7      ;available space above stack
    CMP    lr,R5         ;check if there is enough space here
    ADDGT  R8,R7,R5      ; yes
    BGT    sto
    CMP    R8,#0         ; no, check for first stack
    MOVGT  R3,R0
    BGT    lp1           ;try next stack
;       no gaps available so put it at the end
    MOV    R7,R6         ;start of reserved memory = top of last stack
    SUB    R2,R2,R6      ;currently available memory
    SUB    R5,R5,R2      ;extra memory required
    ADD    R8,R7,R5      ;end of reserved memory
    BL     change_memory ;request more memory
sto STMDB  R4,{R7,R8}    ;store reserved area
    LDR    R1,[sp,#4]    ;(COMMON)
    SUB    R5,R7,R1      ;new address relative to COMMON
    MOV    R5,R5,ASR#2
ret LDR    R2,[sp,#8]    ;(IAD)
    STR    R5,[R2]       ;store IAD
    LDMDB  fp,{R4-R8,fp,sp,pc};return
    END
;
    TTL    qsortc
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
    AREA   |C$$code|,CODE,READONLY
    EXPORT qsortc_         ;(CHAR,INDEX,N) sorts INDEX of pointers to character array array
    IMPORT __rt_stkovf_split_big
; so that the strings are selected in ascending order
    DCB    "qsortc_",0,8,0,0,255
qsortc_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
; initialise variables
    LDR    R2,[R2]         ;N
    SUB    ip,sp,R2,LSL#2  ;possible space needed for stack
    CMP    ip,sl           ;check there is room
    BLLT   __rt_stkovf_split_big;ask for more if necessary
    SUBS   R2,R2,#1        ;N-1
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;finished if N<2
    ADD    R5,R1,R2,LSL#2  ;R = address of INDEX(N)
    SUB    R0,R0,R3        ;address of CHAR(0)
    MOV    ip,sp           ;initialise local stack
; main loop over sections
;
l1  MOV    R2,R1           ;range is R1 -> R5 inclusive (bytes in INDEX)
    ADD    R4,R5,#4
    SUB    R6,R5,R1        ;size of range in bytes
    MOV    R6,R6,LSR#3     ;1/2 size of range
    LDR    R6,[R1,R6,LSL#2];get INDEX of central point
    MLA    R6,R3,R6,R0     ;address of central CHAR(M)
l3  LDR    R3,[fp,#-40]    ;restore LEN(CHAR)
    LDR    R7,[R2],#4      ;INDEX(I)
    MLA    R7,R3,R7,R0     ;address of CHAR(INDEX(I))
    MOV    R8,R6
lc1 LDRB   R9,[R7],#1
    LDRB   lr,[R8],#1
    CMP    R9,lr
    BLT    l3
    BGT    l4
    SUBS   R3,R3,#1
    BGT    lc1              ;loop until it is >= CHAR(M)
;
l4  LDR    R0,[fp,#-52]    ;restore R0 (address of CHAR)
    LDR    R3,[fp,#-40]    ;restore LEN(CHAR)
    SUB    R0,R0,R3        ;address of CHAR(0)
    LDR    R8,[R4,#-4]!    ;INDEX(J)
    MLA    R8,R3,R8,R0     ;address of CHAR(INDEX(J))
;    LDR    R9,[R0,R8,LSL#2];K(INDEX(J))
    MOV    R0,R6
lc2 LDRB   R9,[R8],#1
    LDRB   lr,[R0],#1
    CMP    lr,R9
    BLT    l4
    BGT    l5
    SUBS   R3,R3,#1
    BGT    lc2
l5  LDR    R0,[fp,#-52]    ;restore R0
    LDR    R3,[fp,#-40]    ;restore LEN(CHAR)
    SUB    R0,R0,R3        ;address of CHAR(0)
    CMP    R2,R4           ;I>J if finished
    LDR    R7,[R2,#-4]     ;restore R7
    LDR    R8,[R4]         ;restore R8
    STRLE  R7,[R4]         ;swap I & Jth elements of INDEX
    STRLE  R8,[R2,#-4]
    BLT    l3              ;search for next pair to swap
    SUBGT  R7,R2,#4
    CMPGT  R7,R4
    SUBLE  R4,R4,#4        ;decrement j if no overlap
    MOVGT  R2,R7           ;restore i if overlap
;
    SUB    R7,R1,R4        ;-size of left section
    SUB    R8,R5,R2        ;size of right section
    CMN    R8,R7           ;pick the bigger section to store
    MOVGE  R5,R4           ;right is bigger,
    ADDGE  R4,R8,R2        ;so swap r & j
    MOVLT  R1,R2           ;left is bigger,
    ADDLT  R2,R7,R4        ;so swap l & i
    CMP    R4,R2
    STMGTFD sp!,{R2,R4}    ;store bigger section if more than 1 element
    CMP    R5,R1
    BGT    l1              ;sort smaller section if more than 1 element
    CMP    sp,ip           ;if more entries in stack
    LDMLTFD sp!,{R1,R5}    ;get new interval from stack
    BLT    l1              ;go sort it
    LDMDB  fp,{R4-R9,fp,sp,pc} ;else finished
    END
;
    TTL    qsortd
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 qsortd_         ;(Z,INDEX,N) sorts INDEX of pointers to real*8 array
; so that the Z's are selected in ascending order
    DCB    "qsortd_",0,8,0,0,255
qsortd_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
; initialise variables
    LDR    R2,[R2]         ;N
    SUBS   R2,R2,#1
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;finished if N<2
    ADD    R5,R1,R2,LSL#2  ;R = address of INDEX(N)
    SUB    R0,R0,#8        ;address of Z(0)
    ADD    lr,R0,#4        ;address of 2nd half of Z(0)
    MOV    R3,sp           ;initialise local stack
; main loop over sections
l1  MOV    R2,R1
    ADD    R4,R5,#4
    SUB    R6,R5,R1
    MOV    R6,R6,LSR#3     ;1/2 size of range
    LDR    ip,[R1,R6,LSL#2];get index of central point
    LDR    R6,[R0,ip,LSL#3];get its value (M)
    EORS   R6,R6,R6,ASR#32
    ORRCS  R6,R6,#&80000000;correct value if negative
    LDR    R8,[lr,ip,LSL#3];l.s. part of (M)
    MVNCS  R8,R8           ;correct sign
l3  LDR    R7,[R2],#4      ;INDEX(I)
    CMP    R7,ip
    BEQ    l4              ;skip if same as M
    LDR    R9,[R0,R7,LSL#3];Z(INDEX(I))
    EORS   R9,R9,R9,ASR#32
    ORRCS  R9,R9,#&80000000;correct -ve Z
    CMP    R9,R6
    BLT    l3              ;loop until it is >= M
    BEQ    e2              ;if equal, test l.s. half
l4  LDR    R7,[R4,#-4]!    ;INDEX(J)
    CMP    R7,ip
    BEQ    l5              ;skip if same as M
    LDR    R9,[R0,R7,LSL#3];Z(INDEX(J))
    EORS   R9,R9,R9,ASR#32
    ORRCS  R9,R9,#&80000000;correct -ve Z
    CMP    R9,R6
    BGT    l4              ;loop until it is <= M
    BEQ    e3              ;if equal, test l.s. half
l5  CMP    R2,R4           ;I>J if finished
    LDRLE  R9,[R2,#-4]
    STRLE  R9,[R4]         ;swap I & Jth elements of INDEX
    STRLE  R7,[R2,#-4]
    BLT    l3              ;search for next pair to swap
    SUBGT  R7,R2,#4
    CMPGT  R7,R4
    SUBLE  R4,R4,#4        ;decrement j if no overlap
    MOVGT  R2,R7           ;restore i if overlap
;
    SUB    R7,R1,R4        ;-size of left section
    SUB    R8,R5,R2        ;size of right section
    CMN    R8,R7           ;pick the bigger section to store
    MOVGE  R5,R4           ;right is bigger,
    ADDGE  R4,R8,R2        ;so swap r & j
    MOVLT  R1,R2           ;left is bigger,
    ADDLT  R2,R7,R4        ;so swap l & i
    CMP    R4,R2
    STMGTFD sp!,{R2,R4}    ;store bigger section if more than 1 element
    CMP    R5,R1
    BGT    l1              ;sort smaller section if more than 1 element
    CMP    sp,R3           ;if more entries in stack
    LDMLTFD sp!,{R1,R5}    ;get new interval from stack
    BLT    l1              ;go sort it
    LDMDB  fp,{R4-R9,fp,sp,pc} ;else finished
; test less significant halves whem m.s. are equal
e2  TST    R9,#&80000000   ;check whether m.s. was -ve
    LDR    R9,[lr,R7,LSL#3];get l.s. half
    MVNNE  R9,R9           ;adjust sign
    CMP    R9,R8
    BLO    l3              ;loop if unsigned word is smaller
    B      l4              ;carry on if greater or same
e3  TST    R9,#&80000000   ;check whether m.s. was -ve
    LDR    R9,[lr,R7,LSL#3];get l.s. half
    MVNNE  R9,R9           ;adjust sign
    CMP    R9,R8
    BHI    l4              ;loop if unsigned word is greater
    B      l5              ;carry on if smaller or same
    END
;
    TTL    qsorti
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 qsorti_         ;(K,INDEX,N) sorts INDEX of pointers to integer array
; so that the K's are selected in ascending order
    DCB    "qsorti_",0,8,0,0,255
qsorti_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
; initialise variables
    LDR    R2,[R2]         ;N
    SUBS   R2,R2,#1
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;finished if N<2
    ADD    R5,R1,R2,LSL#2  ;R = address of INDEX(N)
    SUB    R0,R0,#4        ;address of K(0)
    MOV    R3,sp           ;initialise local stack
; main loop over sections
l1  MOV    R2,R1
    ADD    R4,R5,#4
    SUB    R6,R5,R1
    MOV    R6,R6,LSR#3     ;1/2 size of range
    LDR    R8,[R1,R6,LSL#2];get index of central point
    LDR    R6,[R0,R8,LSL#2];get its value (M)
l3  LDR    R7,[R2],#4      ;INDEX(I)
    LDR    R9,[R0,R7,LSL#2];K(INDEX(I))
    CMP    R9,R6
    BLT    l3              ;loop until it is >= M
l4  LDR    R8,[R4,#-4]!    ;INDEX(J)
    LDR    R9,[R0,R8,LSL#2];K(INDEX(J))
    CMP    R9,R6
    BGT    l4              ;loop until it is <= M
    CMP    R2,R4           ;I>J if finished
    STRLE  R7,[R4]         ;swap I & Jth elements of INDEX
    STRLE  R8,[R2,#-4]
    BLT    l3              ;search for next pair to swap
    SUBGT  R7,R2,#4
    CMPGT  R7,R4
    SUBLE  R4,R4,#4        ;decrement j if no overlap
    MOVGT  R2,R7           ;restore i if overlap
;
    SUB    R7,R1,R4        ;-size of left section
    SUB    R8,R5,R2        ;size of right section
    CMN    R8,R7           ;pick the bigger section to store
    MOVGE  R5,R4           ;right is bigger,
    ADDGE  R4,R8,R2        ;so swap r & j
    MOVLT  R1,R2           ;left is bigger,
    ADDLT  R2,R7,R4        ;so swap l & i
    CMP    R4,R2
    STMGTFD sp!,{R2,R4}    ;store bigger section if more than 1 element
    CMP    R5,R1
    BGT    l1              ;sort smaller section if more than 1 element
    CMP    sp,R3           ;if more entries in stack
    LDMLTFD sp!,{R1,R5}    ;get new interval from stack
    BLT    l1              ;go sort it
    LDMDB  fp,{R4-R9,fp,sp,pc} ;else finished
    END
;
    TTL    qsortr
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 qsortr_         ;(Z,INDEX,N) sorts INDEX of pointers to real array Z
; so that the Z's are selected in ascending order
qsortr_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
; initialise variables
    LDR    R2,[R2]         ;N
    SUBS   R2,R2,#1
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;finished if N<2
    ADD    R5,R1,R2,LSL#2  ;R = address of INDEX(N)
    SUB    R0,R0,#4        ;address of Z(0)
    MOV    R3,sp           ;initialise local stack
; main loop over sections
l1  MOV    R2,R1
    ADD    R4,R5,#4
    SUB    R6,R5,R1
    MOV    R6,R6,LSR#3     ;1/2 size of range
    LDR    R8,[R1,R6,LSL#2];get index of central point
    LDR    R6,[R0,R8,LSL#2];get its value (M)
    MVNS   R7,R6
    ORRPL  R6,R7,#&80000000;correct value if negative
l3  LDR    R7,[R2],#4      ;INDEX(I)
    LDR    R9,[R0,R7,LSL#2];Z(INDEX(I))
    MVNS   ip,R9
    ORRPL  R9,ip,#&80000000;correct -ve Z
    CMP    R9,R6
    BLT    l3              ;loop until it is >= M
l4  LDR    R8,[R4,#-4]!    ;INDEX(J)
    LDR    R9,[R0,R8,LSL#2];Z(INDEX(J))
    MVNS   ip,R9
    ORRPL  R9,ip,#&80000000;correct -ve Z
    CMP    R9,R6
    BGT    l4              ;loop until it is <= M
    CMP    R2,R4           ;I>J if finished
    STRLE  R7,[R4]         ;swap I & Jth elements of INDEX
    STRLE  R8,[R2,#-4]
    BLT    l3              ;search for next pair to swap
    SUBGT  R7,R2,#4
    CMPGT  R7,R4
    SUBLE  R4,R4,#4        ;decrement j if no overlap
    MOVGT  R2,R7           ;restore i if overlap
;
    SUB    R7,R1,R4        ;-size of left section
    SUB    R8,R5,R2        ;size of right section
    CMN    R8,R7           ;pick the bigger section to store
    MOVGE  R5,R4           ;right is bigger,
    ADDGE  R4,R8,R2        ;so swap r & j
    MOVLT  R1,R2           ;left is bigger,
    ADDLT  R2,R7,R4        ;so swap l & i
    CMP    R4,R2
    STMGTFD sp!,{R2,R4}    ;store bigger section if more than 1 element
    CMP    R5,R1
    BGT    l1              ;sort smaller section if more than 1 element
    CMP    sp,R3           ;if more entries in stack
    LDMLTFD sp!,{R1,R5}    ;get new interval from stack
    BLT    l1              ;go sort it
    LDMDB  fp,{R4-R9,fp,sp,pc} ;else finished
    END
