TTL > SystemA - The runtime system file for Tutu's ARM ISO-Pascal GBLL arm2 arm2 SETL {TRUE} GBLL arthur arthur SETL {TRUE} GET $.Hdr.EnvNumbers GBLL debset ; Set stuff debugging flag debset SETL 1=0 GBLL debarr ; Array access debugging flag debarr SETL 1=0 GBLL debfile ; General I/O system debugging flag debfile SETL 1=0 GBLL debheap ; Heap debugging flag debheap SETL 1=0 GBLL debin ; Input system debugging flag debin SETL 1=0 GBLL debout ; Output system debugging flag debout SETL 1=0 ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Origin * &60000 ; So we don't crap on Aasm, Lobj or Twin when testing ! ^ 0 ; Set variable origin for manifest declarations Nil * 0 falsch * 0 troo * 1 ; ASCII/BBC character codes LF * 10 newpage * 12 CR * 13 do_mode * 22 do_plot * 25 space * " " ; Pascal I/O system manifests openin * &40 ; Operations for osfind openout * &80 eof_char * &80 ; For eof on console input stream Default_TotalWidth_Integer * 12 ; As per BBC ISO manual p.162 Default_TotalWidth_Real * 12 Default_TotalWidth_Boolean * 5 ExpDigits * 3 ExpChar * "e" ; The one we print out AltExpChar * "E" ; Also accept this one on input is_debug # 1 ; Unique manifests; values irrelevant is_print # 1 temp_file # 1 perm_file # 1 bit0 * 1 :SHL: 0 bit1 * 1 :SHL: 1 bit31 * 1 :SHL: 31 t_proc * bit0 t_line * bit1 ; ARM related things N_bit * 1 :SHL: 31 ; Processor condition flags Z_bit * 1 :SHL: 30 C_bit * 1 :SHL: 29 V_bit * 1 :SHL: 28 I_bit * 1 :SHL: 27 F_bit * 1 :SHL: 26 USR_mode * 0 ; Processor mode bits FIQ_mode * 1 IRQ_mode * 2 SVC_mode * 3 ARM_cc_mask * N_bit:OR:Z_bit:OR:C_bit:OR:V_bit:OR:I_bit:OR:F_bit:OR:SVC_mode ; SWI values - as of Brazil -.03 (3rd Jan 86) WriteC * 0 WriteS * 1 Write0 * 2 Newline * 3 ReadC * 4 Cli * 5 Byte * 6 Word * 7 File * 8 Args * 9 Bget * 10 Bput * 11 Gbpb * 12 Open * 13 Readline * 14 Control * 15 GetEnv * 16 Exit * 17 SetEnv * 18 IntOn * 19 IntOff * 20 CallBack * 21 EnterSVC * 22 BreakPt * 23 BreakCtrl * 24 UnusedSWI * 25 OS_Plot * &45 OS_ChangeEnvironment * &40 WriteI * &100 XFPEmulator_Version * &40480 :OR: (1 :SHL: 17) r2 RN 2 ; Processor registers r3 RN 3 r4 RN 4 r5 RN 5 r6 RN 6 r7 RN 7 r8 RN 8 r9 RN 9 r10 RN 10 r11 RN 11 r12 RN 12 r13 RN 13 r14 RN 14 r15 RN 15 ; Register allocation r0 RN 0 ; R0 - R6 may be trashed with impunity by BCPL r1 RN 1 ; = A1 temp RN 2 t0 RN 3 t1 RN 4 t2 RN 5 t3 RN 6 arga RN 7 ; = RGB. It's ok for BCPL to splatter this frame RN 8 ; = RB count RN 9 ; = RG. Have to load it on each BCPL call currbase RN 10 ; = RP. BCPL will preserve this sp RN 11 ; = RTS. BCPL will preserve this globalbase RN 12 ; = RL. BCPL will preserve this hasp RN 13 link RN 14 pc RN 15 R0 RN 0 ; Where we need to have proper register numbers R1 RN 1 R2 RN 2 R3 RN 3 ara RN t0 ; Arithmetic aliases arb RN t1 arc RN t2 ars RN t3 osbA RN 0 ; Osbyte regs osbX RN 1 osbY RN 2 oswA RN 0 ; Osword regs oswXY RN 1 addr RN arga ; Heap aliases size RN count arse RN t0 bp RN t1 tp RN t2 ;addr RN arga ; Array access aliases baseptr RN t0 ; Order important descptr RN t1 ; for these two ! indexptr RN t2 idash RN t3 argp RN t0 ; I/O system alias ;addr RN arga GBLS setmask ; 8 regs to use for block moves, use $setmask to expand setmask SETS "r1, temp, t0, t1, t2, t3, arga, count" ; Floating point registers fa FN 0 fb FN 1 ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; Offsets within a housekeeping frame - LDM/STM order important (entry/return) ^ 0 hkfdisplay # 4 ; Old display contents at this textual level hkflevel # 4 ; Textual level of the current procedure hkfprocname # 4 ; Pointer to name of the current procedure hkflink # 4 ; Dynamic link to caller's stack frame base hkfreturn # 4 ; Return code link to caller hkffcbref # 4 ; Current FCB reference hkfsize # 0 ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; System variables are accessed via {LD|ST}R , [globalbase, #-] ; or (preferably) via the LV and SV macros. // := ; To locate them, do SUB , globalbase, # // := @ ^ 0 Distable # (8*4) ; The display : xxR reg, [globalbase, #-level] debuglevel # 4 currline # 4 ; Last line visited when debug active textptr # 4 starttime # 4 ; Time the program was run / settime executed mkchhead # 4 shwm # 4 htop # 4 memtop # 4 freelist # 4 straccptr # 4 stracc # 256 varp # 4 ; Pointer to the string to be used linbufptr # 4 ; Pointers to input console line linbfX # 4 FracDigits # 4 ; Output variables TotalWidth # 4 strlen # 4 format # 4 ; Exponential or fixed point DecPlaces # 4 intdigits # 4 intsigfigs # 4 totaldigits # 4 LZC # 4 ; Leading zero count want_type # 4 ; Input variables firstchar # 4 filetype # 4 ; General i/o variables permflag # 4 fileop # 4 debug_or_print # 4 stashed_fcb_addr # 4 tfuw # 4 vfuw # 4 ; Valid file usage # 4 ; Necessary for zero offsets xxR rn, [rb, #-0] vFtfid # 4*32 ; Locate these with SUB rn, globalbase, vFxxx # 4 vFhandle # 4*32 ; and use -ve indexing on the offsets # 4 vFaddr # 4*32 bcplglobalbase # 4 ; Load this into rg before calling BCPL procs maxvbl # 0 ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; Assorted macros ; Load a system variable MACRO $label LV $reg, $vbl $label LDR $reg, [globalbase, #-($vbl)] MEND MACRO $label SV $reg, $vbl $label STR $reg, [globalbase, #-($vbl)] MEND MACRO $label POP $reg $label LDR $reg, [sp, #-4]! MEND MACRO $label PUSH $reg $label STR $reg, [sp], #4 MEND MACRO $label POP2 $r1, $r2 $label LDMDB sp!, {$r1, $r2} MEND MACRO $label RETURN $label MOV pc, link MEND MACRO $label STASH $reglist $label STMIA hasp!, {$reglist} MEND MACRO $label GRAB $reglist $label LDMDB hasp!, {$reglist} MEND MACRO $label GRABS $reglist $label LDMDB hasp!, {$reglist}^ MEND MACRO $label INCSP $value $label ADD sp, sp, #($value) MEND MACRO $label DECSP $value $label SUB sp, sp, #($value) MEND MACRO $label MULT $rc, $ra, $rb $label MOV $rc, #0 [ 1=1 ; Tutu's MULT - not exactly as fast as Roger's but it does check for overflow ! B %FT02 01 ADDS $rc, $rc, $rb BVS eMulOverflow 05 ADD $rb, $rb, $rb 02 MOVS $ra, $ra, LSR #1 BCS %BT01 BNE %BT05 | ; Roger's MULT. This doesn't check for overflow 01 MOVS $ra, $ra, LSR #1 ADDCS $rc, $rc, $rb ADD $rb, $rb, $rb BNE %BT01 ] MEND ; DIVREM - result in $rc, remainder in $ra. Corrupts count. No overflow poss ! MACRO $label DIVREM $rc, $ra, $rb $label MOV count, #1 01 CMP $rb, #bit31 CMPCC $rb, $ra MOVCC $rb, $rb, ASL #1 MOVCC count, count, ASL #1 BCC %BT01 MOV $rc, #0 02 CMP $ra, $rb SUBCS $ra, $ra, $rb ADDCS $rc, $rc, count MOVS count, count, LSR #1 MOVNE $rb, $rb, LSR #1 BNE %BT02 MEND ; ABSARGS - ra,b := abs(ra,b); sign bit in rs. MUST set flags set on 2nd arg. MACRO $label ABSARGS $ra, $rb $label EOR ars, $ra, $rb TEQ $ra, #0 RSBMI $ra, $ra, #0 TEQ $rb, #0 RSBMI $rb, $rb, #0 MEND ; Push a signed result to stack, using rs from ABSARGS or wherever MACRO $label RESULT $ra $label TEQ ars, #0 RSBMI $ra, $ra, #0 PUSH $ra MEND ; Internal error routine - don't change without looking at Naffup/PostMortem MACRO $label ERROR $string $label STMIA hasp!, {r0-pc} BL Naffup = "$string", 0 ALIGN MEND MACRO $label STRIM $string [ :LEN: "$string" = 1 $label SWI WriteI+"$string" | $label SWI WriteS = "$string", 0 ALIGN ] MEND MACRO $label WRLN $string $label SWI WriteS = "$string", LF,CR, 0 ALIGN MEND MACRO $label ADDR $reg, $dest ASSERT $reg <> pc ASSERT ($dest-.-8) < &10000 $label ADD $reg, pc, #($dest-.-8) :AND: &FF ADD $reg, $reg, #($dest-.-4) :AND: &FF00 MEND MACRO $label DREG $reg $label SWI WriteI+" " [ $reg = R0 STASH link BL HexLongWord GRAB link | STMIA hasp!, {R0, link} [ $reg = hasp SUB R0, hasp, #8 | MOV R0, $reg ] BL HexLongWord LDMDB hasp!, {R0, link} ] MEND MACRO $label CallGlobal $globno $label LV rg, bcplglobalbase MOVS link, pc ; Point just after the LDR ... LDR pc, [rg, #($globno :SHL: 2)] MEND ; Move a block downwards in memory from $src+0..count to $dst+0..count ; ie. moves (count + 1) bytes ; Corrupts R0, count. Must preserve all other regs MACRO $label MOVEBLK $dst, $src [ ($src = R0) :LOR: ($src = count) :LOR: ($dst = R0) :LOR: ($dst = count) ! 1, "Can't use R0 or count as src/dest for move" ] $label 10 LDRB R0, [$dst, count] STRB R0, [$src, count] SUBS count, count, #1 BPL %BT10 MEND ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; Ok, the code starts here ... ORG Origin B RunCli ; +0 : Gets patched to BNV internally when we *PasLib B Runner ; +4 : Entry when program loaded on end by previous 'p' B PostMortem ; +8 : Says it all, doesn't it ? RunCli ROUT ; +C : Entry for 'p' and 'paslib' commands MOV R1, #&FA ; Patch main entry to BNV RunProg STRB R1, Origin+3 ; st. *GO Origin will rerun the loaded program SWI XFPEmulator_Version BVC %FT05 SWI WriteS = 7, "+++ Warning: FPE not yet active !", LF,CR, 0 05 ADDR link, CmdTail SWI GetEnv MOV R2, R0 MOV R1, R0 10 LDRB R0, [R1], #1 ; Skip command name till NUL or space CMP R0, #0 BEQ RunError CMP R0, #space BNE %BT10 15 LDRB R0, [R1], #1 ; Skip spaces after the command name CMP R0, #space BEQ %BT15 CMP R0, #0 ; Was it all pointless ? BEQ RunError 20 STRB R0, [link], #1 ; Copy the rest of the command tail to our buff LDRB R0, [R1], #1 CMP R0, #0 BNE %BT20 MOV R1, #CR ; Terminate string STRB R1, [link] MOV R0, #&FF ; *LOAD ADDR R1, CmdTail ; Point to filename string ADDR R2, PasLength ; Load address MOV R3, #0 ; Load at given address in R2 SWI File B Runner RunError SWI WriteS = "+++ Error: Nothing to run", LF,CR, 0 SWI Exit ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; Set up system vars before entering user program Runner ROUT ADDR R0, PasLength ; How long is the loaded code ? LDR R1, [R0] ADD R1, R1, R0 ADD globalbase, R1, #maxvbl MOV R0, #0 ; Clear variable workspace to 0 10 STR R0, [R1], #4 CMP R1, globalbase BNE %BT10 ADDR R0, CmdTail SV R0, linbufptr SUB R0, globalbase, #(stracc+256) ; Find lowest address in stracc SV R0, straccptr MOV R0, #0 SV R0, currline ; Line number for debug info on errors SV R0, vfuw ; No valid files SV R0, tfuw ; No valid temporary files SV R0, linbfX ; No command tail pltb SV R0, TotalWidth SV R0, FracDigits MOV R0, #Nil ; No free blocks yet SV R0, freelist LDR R0, =&87654321 ; Pretty bad address - see if mark chain ok SV R0, mkchhead SWI GetEnv SV R0, textptr SUB hasp, r1, #&400 ; 1k for internal stack SV hasp, memtop SV hasp, htop LDRB R0, [R2], #1 ; Read start time of run LDRB R1, [R2], #1 ORR R0, R0, R1, LSL #8 LDRB R1, [R2], #1 ORR R0, R0, R1, LSL #16 LDRB R1, [R2], #1 ORR R0, R0, R1, LSL #24 SV R0, starttime LDRB R0, [R2] SV R0, starttime+4 MOV frame, globalbase ; Set up the base stack ADD sp, frame, #hkfsize MOV currbase, #0 ; Marks the base stack frame for backtrace BL PasEntry ; Call the main procedure of the user program iPasExit ; Main program should branch to here when it wants to exit [ debfile STRIM " PasExit" ] [ debheap BL ShowHeap ] ; Close any files here SWI Exit LTORG ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; Called on runtime error. Previous regs already stacked on hasp ; Error routines should do things like: ; BVS eXxxYyy in a library routine ; BLVS eXxxYyy in the mainline code ; This tries to ensure that the stashed link register points somewhere into the ; mainline code for error reporting. However, internal library routines must ; try to get the link register back to some coherent user state before dying. ; Sacrifice hasp to give internal/system error information Naffup ROUT TEQP pc, #0 ; Make sure we're in USR mode ; Copy register dump from hasp to Arthur's dump area MOV count, #0 SUB temp, hasp, #16*4 ; Point to register dump [ arthur MOV r0, #ExceptionDumpArea ; r1 := read base of dump area MOV r1, #0 SWI OS_ChangeEnvironment | MOV r1, #&E40 ; Base of Brazil's dump area ] 50 LDR r0, [temp, count, LSL #2] CMP count, #13 ; hasp tbs -> Internal error MOVEQ r0, link ; also -> error string ORREQ r0, r0, #bit31 CMP count, #14 ; Subtract 4 from link register SUBEQ r0, r0, #4 ; to point back to caller STR r0, [r1, count, LSL #2] ; Stick in Brazil's dump area ADD count, count, #1 CMP count, #16 BNE %BT50 SWI WriteI+7 ; Beep ! ; ............................................................................. PostMortem ROUT ADDR hasp, CmdTail ; Not a bad idea as hasp will be UND on pm [ arthur ; Restore a few registers from dump for diagnostics MOV r0, #ExceptionDumpArea ; r1 := read base of dump area MOV r1, #0 SWI OS_ChangeEnvironment | MOV r1, #&E40 ; Restore a few registers from dump for diagnostics ] LDR currbase, [r1, #(currbase*4)] LDR globalbase, [r1, #(globalbase*4)] LDR t0, [r1, #(hasp*4)] ; Was this an internal or a system error ? MOV r0, #218 ; Abandon VDU queue MOV r1, #0 MOV r2, #0 SWI Byte SWI WriteS = 4, LF,CR, "pm: ", 0 ; Join cursors, newline, title: ALIGN TEQ t0, #0 ; tbs -> internal error BMI %FT02 SWI WriteS = "System detected fault", 0 ALIGN B %FT03 02 SWI WriteS = "Pascal run-time exception: ", 0 ALIGN BIC r0, t0, #ARM_cc_mask ; Write out the inline error string SWI Write0 03 TST globalbase, #ARM_cc_mask BNE GlobNaff ; Can't print line number if globalbase naff LV r0, currline ; Did we ever reference a line number in debug CMP r0, #0 BEQ %FT10 STRIM " at line " MOV temp, #is_debug BL R0decimal 10 SWI Newline TST currbase, #ARM_cc_mask BLNE CurrNaff ; Can't backtrace if currbase naff BNE %FT50 MVN t0, #1 ; Somehow, not a very good frame base ! ; Loop down stack till we hit the base frame - DynLink = 0 ; Give info as '+++ Frame base XXXXXXXX, routine name SSSSS' NaffLoop SWI Newline STRIM "+++ Frame base " MOV r0, currbase BL HexLongWord STRIM ", routine name " LDR r0, [currbase, #hkfprocname] ; Check routine name ptr ok TST r0, #ARM_cc_mask BLNE ACCMnaff SWI Write0 CMP t0, currbase ; Have we got a duplicate frame ? BLEQ LinkNaff BEQ %FT50 TST currbase, #ARM_cc_mask ; Is this frame corrupted ? BLNE ACCMnaff BNE %FT50 MOV t0, currbase ; Store for above security test LDR currbase, [currbase, #hkflink] CMP currbase, #0 BNE NaffLoop SWI WriteS = LF,CR, "+++ Base of stack", 0 ALIGN 50 ; Give a nice reassuring register dump out of Brazil's workspace SWI WriteS = LF,CR, LF,CR, "Registers:", LF,CR, 0 ALIGN MOV count, #0 [ arthur MOV r0, #ExceptionDumpArea ; r1 := read base of dump area MOV r1, #0 SWI OS_ChangeEnvironment | MOV temp, #&E40 ; Base of Brazil's dump area ] ADR t0, RegStrings 60 SWI WriteI+space MOV r0, t0 ; Reg string SWI Write0 STRIM " = " LDR r0, [r1, count, LSL #2] CMP count, #14*4 ; Subtract 4 from link register SUBEQ r0, r0, #4 BL HexLongWord ADD t0, t0, #8 ADD count, count, #1 TST count, #3 ; Line break if appropriate else ';' SWINE WriteI+";" SWIEQ Newline ; 4, 8, 12, 16 CMP count, #16 BNE %BT60 SWI Exit GlobNaff SWI WriteS = LF,CR, LF,CR, "Global base corrupted", 0 ALIGN B %BT10 LinkNaff ; Come here if we have a ratty link SWI WriteS = " same as above routine - Panic !", 0 ALIGN MOVS pc, link CurrNaff SWI WriteS = LF,CR, "Frame base ", 0 ALIGN ACCMnaff ; Or here if we have condition codes/unaligned frame link/name ptr SWI WriteS = "has CC or Mode bits set - Panic !", LF,CR, 0 ALIGN MOVS pc, link RegStrings ; NB. If register allocation changes, modify the order of these ! ASSERT .-RegStrings = r0*8 = " r0", 0 ASSERT .-RegStrings = r1*8 = " r1", 0 ASSERT .-RegStrings = temp*8 = " temp", 0 ASSERT .-RegStrings = t0*8 = " t0", 0 ASSERT .-RegStrings = t1*8 = " t1", 0 ASSERT .-RegStrings = t2*8 = " t2", 0 ASSERT .-RegStrings = t3*8 = " t3", 0 ASSERT .-RegStrings = arga*8 = " arga", 0 ASSERT .-RegStrings = frame*8 = " frame", 0 ASSERT .-RegStrings = count*8 = " count", 0 ASSERT .-RegStrings = currbase*8 = "currbas", 0 ASSERT .-RegStrings = sp*8 = " sp", 0 ASSERT .-RegStrings = globalbase*8 = "globbas", 0 ASSERT .-RegStrings = hasp*8 = " hasp", 0 ASSERT .-RegStrings = link*8 = " lr", 0 ASSERT .-RegStrings = pc*8 = " pc", 0 ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; My debugging routines HexLongLine STASH "r0, link" ; Get round 3um ARM LDM bug BL HexLongWord SWI Newline GRABS "r0, pc" HexLongSlash STASH "r0, link" ; Get round 3um ARM LDM bug BL HexLongWord SWI WriteI+"/" GRABS "r0, pc" HexLongWord STASH "r0, link" MOV r0, r0, LSR #16 BL HexWord LDR r0, [hasp, #-8] BL HexWord GRABS "r0, pc" HexWord STASH "r0, link" MOV r0, r0, LSR #8 BL HexByte LDR r0, [hasp, #-8] BL HexByte GRABS "r0, pc" HexByte STASH "r0, link" MOV r0, r0, LSR #4 BL HexNibble LDR r0, [hasp, #-8] BL HexNibble GRABS "r0, pc" HexNibble STASH "r0, link" AND r0, r0, #15 CMP r0, #10 ADDCC r0, r0, #"0" ADDCS r0, r0, #"A"-10 BL PasWrch GRABS "r0, pc" PasWrch STASH "r0, link" ; If funny, then give as escaped sequence TST r0, #&80 SWINE WriteI+"|" ; tbs are preceded by |! SWINE WriteI+"!" ANDNE r0, r0, #&7F CMP r0, #&7E SWIGE WriteI+"|" MOVEQ r0, #"|" ; Solidus is || MOVGT r0, #"?" ; Delete is |? CMP r0, #space-1 ; Control chars SWILE WriteI+"|" ADDLE r0, r0, #"@" ; NUL == |@ etc. SWI WriteC GRABS "r0, pc" ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ LNK "Sys.ArithSet"