* QL WORLD DIY TOOLKIT - Direct Qdos TRAP access routines * Version 0.9, Copyright 1991 Simon N Goodwin * initialise lea.l define,a1 A1 -> extension details movea.w $110\w,a2 Fetch BP.INIT word vector jmp (a2) Add these extensions * * MTRAP TRAP1_KEY [ ,D1 | \JobNum ] [ , D2 , D3 , A0 & A3 , A1 ] * mtrap cmpa.l a3,a5 At least one parameter? beq.s bad_param If not, moan at once moveq #112,d5 Separator bit mask: 01110000 and.b 1(a3,a6.l),d5 Read the first separator subi.b #48,d5 Binary "\" pattern: 00110000 * * D5 is Zero if the (assumed) first parameter separator is "\" * movea.w $118\w,a2 Fetch CA.GTLIN vector jsr (a2) Get long integers bne.s bad_return Give up if fetch fails cmp.w #6,d3 Too many parameters? bhi.s bad_param movem.l 0(a1,a6.l),d0/d1 Pick up a couple tst.b d5 Job Number parameter? bne.s get_regs * move.l d1,d5 Save the Job Number in D5 moveq #0,d0 MT.INF trap key trap #1 Find the system variables move.w d5,d1 Make ID from the Job Number swap d1 Prepare to receive the Tag lsl.w #2,d5 Scale offset for long words add.l 104(a0),d5 Add job table base offset cmp.l 108(a0),d5 Check total against the end bge.s off_job Offset beyond end of table? movea.l d5,a0 Dn/An is not so orthogonal move.l (a0),d5 Pick up the Job base address bmi.s off_job That Job is not running! movea.l d5,a0 A0 points to the job header move.w 16(a0),d1 Copy the tag from JB.TAG swap d1 D1 = TAG:NUM = Qdos Task ID move.l 0(a1,a6.l),d0 Restore first parameter D0.L * get_regs movem.l 8(a1,a6.l),d2/d3/a0/a1 movea.l a0,a3 Help for MT.IPCOM trap #1 lea.l regtable,a2 Store registers in table movem.l d0-d3/a0,(a2) N.B: A0 is saved by TRAP #1 moveq #0,d0 rts * off_job moveq #-2,d0 Report "invalid Job" bra.s bad_return Route all errors one way not_open moveq #-6,d0 Report "channel not open" bra.s bad_return bad_param moveq #-15,d0 Report "bad parameter" bad_return rts * * BTRAP | QTRAP # CHANNEL% , TRAP3_KEY [ , D1, D2, D3, A1, A2 ] * btrap moveq #1,d7 Addresses are inside Basic bra.s trap3 Lau might start there: "D7=0!" qtrap moveq #-1,d7 Indicate absolute addressing trap3 movea.w $118\w,a2 Fetch CA.GTLIN vector jsr (a2) Get some long integers bne.s bad_return Give up if that fails subq.w #2,d3 Too few? Minimum is A0 , D0 bmi.s bad_param Channel & Trap Key needed move.w 2(a1,a6.l),d0 Get LOW word of parameter 1 mulu #40,d0 add.l 48(a6),d0 Add channel base offset cmp.l 52(a6),d0 Check it is within the table bge.s not_open move.l 0(a6,d0.l),d0 Pick up the Qdos channel ID bmi.s not_open Oops, the channel is closed! move.l d0,a0 Set A0 for the call * subq.w #3,d3 D1, D2, D3 required? bpl.s get_set Yes - so read the lot movem.l 4(a1,a6.l),d0-d2 moveq #-1,d3 Default timeout -1, forever bra.s relatively No need to set A1 or A2 get_set subq.w #2,d3 Too many parameters? bhi.s bad_param movem.l 4(a1,a6.l),d0-d3/a1/a2 relatively tst.l d7 Is this a BTRAP? bmi.s all_set No: QTRAP is ready trap #4 Warn Qdos of A6 offsets all_set trap #3 lea.l regtable,a2 Find register storage area movem.l d0-d3/a1,(a2) N.B: TRAP #3 saves A1 moveq #0,d0 rts * * Functions to read register values from the REGTABLE area * addreg cmpa.l a3,a5 No parameters expected bne.s bad_param moveq #16,d5 Skip stored D0.L .. D3.L bra.s default Continue as for DATAREG * datareg clr.w d5 Default = D0, report code cmpa.l a3,a5 No parameter? beq.s default move.w $112\w,a2 Get integer parameters jsr (a2) bne.s bad_return subq.w #1,d3 Just one parameter? bne.s bad_param move.w 0(a1,a6.l),d5 cmp.w #3,d5 Permit access to D0 .. D3 bhi.s bad_param addq.l #2,$58(a6) Update BV.RIP stack pointer lsl.w #2,d5 D5 := D5 * 4 (LONG offset) default lea.l regtable,a2 move.l (a2,d5.w),d0 Read stored register value * * Make D0.L into a 6 byte decimal on the RI stack * return_fp move.w d0,d4 D4.W will be exponent move.l d0,d5 D5.L will be mantissa beq.s normalised Zero is a trivial case move.w #2079,d4 First guess at exponent add.l d0,d0 Already normalised? bvs.s normalised subq.w #1,d4 No, halve exponent weight move.l d0,d5 Double mantissa to match moveq #16,d1 Try a 16 bit shift * normalise move.l d5,d0 Take copy of mantissa asl.l d1,d0 Shift mantissa d1 places bvs.s too_far Overflow; must shift less sub.w d1,d4 Correct exponent for shift move.l d0,d5 New mantissa is more normal too_far asr.w #1,d1 Halve shift distance bne.s normalise Try shift of 8, 4, 2 and 1 normalised moveq #6,d1 Six bytes please move.w $11A\w,a2 Check space with BV.CHRIX jsr (a2) No error return possible move.l $58(a6),a1 Get revised BV.RIP value subq.l #6,a1 Make room for one float move.l a1,$58(a6) move.l d5,2(a1,a6.l) Stack mantissa move.w d4,0(a1,a6.l) Stack exponent moveq #2,d4 Floating point result job_done moveq #0,d0 rts * * N.B: Register values D0-D3 & one address, total 20 bytes, * re-use the DEFINE table RAM space. Move REGTABLE for ROM! * regtable define dc.w 3 Three procedures dc.w qtrap-* dc.b 5,'QTRAP' dc.w btrap-* dc.b 5,'BTRAP' dc.w mtrap-* dc.b 5,'MTRAP' dc.w 0 End of procedures dc.w 2 Two functions dc.w datareg-* dc.b 7,'DATAREG' dc.w addreg-* dc.b 6,'ADDREG' dc.w 0 End of functions end