* QL WORLD DIY TOOLKIT - ALIAS, CODEVEC and INVERSE * Version 0.4, SAILA, Copyright 1991 Simon N Goodwin. * start lea.l define,a1 Point A1 at definition move.w $110,a2 BP.INIT vector jmp (a2) Link code to SuperBASIC * * INVERSE [ #ch% ] - exchanges channel INK & STRIP colours * inverse moveq #1,d0 Assume channel 1 at first cmp.l a3,a5 Any parameters? beq.s pick_chan move.w $112,a2 Vector to get integers jsr (a2) CA.GTINT bne.s give_up subq.w #1,d3 One parameter expected bne.s bad_param Otherwise, complain move.w 0(a1,a6.l),d0 Get BASIC channel No. bmi.s what_chan It must be 0 or more pick_chan mulu #40,d0 Scale for Channel table add.l 48(a6),d0 Add the base offset cmp.l 52(a6),d0 Check it is within table bge.s what_chan Reject if past the end move.l 0(a6,d0.l),d0 Pick up the channel ID bmi.s what_chan Negative if closed got_id move.l d0,a0 Now A0 is channel ID lea.l colour_ext,a2 A2 -> extension code moveq #-1,d3 Infinite timeout moveq #9,d0 SD.EXTOP trap key trap #3 Call QDOS IO system tst.l d0 Check for any error bne.s give_up moveq #40,d0 SD.SETST trap key trap #3 Set STRIP colour in D1.B swap d1 moveq #41,d0 SD.SETIN trap key trap #3 Set INK colour give_up rts * colour_ext moveq #0,d1 Clear odd bytes of result move.b 69(a0),d1 Pick up STRIP colour byte swap d1 Prepare other half of D1 move.b 70(a0),d1 Pick up INK colour byte moveq #0,d0 OK, no error rts * * ALIAS NEW_NAME TO "OLD_NAME" for Resident Procs & Functions * alias lea.l 16(a3),a4 cmpa.l a4,a5 Two parameters please bne.s bad_param tst.b 0(a3,a6.l) Check type of parameter 1 bne.s bad_param Reject unless it is unset moveq #0,d5 move.w 2(a3,a6.l),d5 Pick up the name's index bmi.s bad_param lsl.l #3,d5 Scale: 8 bytes per entry add.l 24(a6),d5 Add NT base offset move.l d5,-(a7) lea.l 8(a3),a3 Isolate remaining parameter bsr.s lookup Evaluate parameter 2 move.l (a7)+,a5 bne.s bad_exit move.w 0(a6,a0.l),0(a6,a5.l) move.l 4(a6,a0.l),4(a6,a5.l) moveq #0,d0 rts * bad_param moveq #-15,d0 Signal BAD PARAMETER error bad_exit rts Error code is in D0 what_chan moveq #-6,d0 CHANNEL NOT OPEN error rts * * CODEVEC("NAME") returns code address for any Resident NAME * codevec bsr.s lookup Try to find the name bne.s bad_exit move.l 4(a0,a6.l),d1 Pick up its code address * * RETURN_FP stacks D1.L in SuperBasic floating-point form * return_fp move.w d1,d4 D4 will be exponent move.l d1,d5 D5 will be mantissa beq.s normalised Zero is a trivial case move.w #2079,d4 First guess at exponent add.l d1,d1 Already normalised? bvs.s normalised subq.w #1,d4 No, halve exponent weight move.l d1,d5 Double mantissa to match moveq #16,d0 Try a 16 bit shift normalise move.l d5,d1 Take copy of mantissa asl.l d0,d1 Shift mantissa D0 places bvs.s too_far Overflow; must shift less sub.w d0,d4 Correct exponent for shift move.l d1,d5 New mantissa is more normal too_far asr.w #1,d0 Halve shift distance bne.s normalise Try shift of 8, 4, 2 and 1 * * Check there's six bytes of space for the result * normalised moveq #6,d1 No. of bytes needed move.w $11A,a0 BV.CHRIX vector jsr (a0) move.l $58(a6),a1 Get a safe A1 value subq.l #6,a1 move.l a1,$58(a6) Grab 6 more bytes move.l d5,2(a1,a6.l) Stack mantissa move.w d4,0(a1,a6.l) Stack exponent moveq #2,d4 Floating point result moveq #0,d0 rts * * LOOKUP "string parameter" -- NT entry @ (A6,A0) or error * lookup move.w $116,a0 Fetch CA.GTSTR vector jsr (a0) Fetch string parameter bne.s bad_exit Quit unless it worked subq.w #1,d3 Check for ONE parameter bne.s bad_param Moan, otherwise move.w 0(a1,a6.l),d0 beq.s bad_param Reject a null parameter move.w d0,d5 Save length for later lea.l 2(a1),a5 Save offset of text * * Equate UPPER/lower case; set bit 5 of parameter bytes * moveq #32,d7 Case conversion mask moveq #1,d2 Odd/even length mask and.l d0,d2 D2=1 if length is odd lock_case or.b d7,2(a1,a6.l) addq.l #1,a1 Advance through text subq.w #1,d0 Count down length bne.s lock_case Convert all characters lea.l 2(a1,d2.l),a1 move.l a1,$58(a6) Tidy the RI stack * * This version assumes the calling task has its own Name * Table for examination by CODEVEC and ALIAS, so it does * not need to find SuperBasic, task (0,0)... * * Now find SuperBASIC task (0,0) and its Name Table * * moveq #0,d2 Search entire task tree * moveq #0,d1 Look for SuperBASIC * moveq #2,d0 MT.JINF Trap key * trap #1 A0 := base of task 0,0 * move.l a0,a2 A2 -> BASIC system vars * * This version uses A6, rather than A2, hereafter, so it * looks in the current task for Name text & other details * move.l 24(a6),a0 A0 -> Name Table Start move.l 28(a6),d0 D0 -> Name Table End move.l 32(a6),d3 D3 -> Name List Start * * Scan the Name Table for names with the right length * next_name move.w 2(a0,a6.l),a3 Pick up offset in NL adda.l d3,a3 (A3,A6.L) -> Name cmp.b 0(a3,a6.l),d5 Compare length beq.s got_length Length matches! advance_nl addq.l #8,a0 Advance through NL cmp.l a0,d0 Stop at the end bhi.s next_name moveq #-7,d0 Signal NOT FOUND rts * * Check the name text to see if it matches the parameter * got_length move.b 1(a3,a6.l),d4 or.b d7,d4 Ensure consistent case cmp.b 0(a5,a6.l),d4 bne.s advance_nl Mismatch, try another move.w d5,d6 Save residual length subq.w #2,d6 DBRA count for the rest bmi.s found_it Found name, length 1 move.l a5,a4 D4 & A4 are temporary check_name move.b 2(a3,a6.l),d4 or.b d7,d4 Convert case of name addq.l #1,a3 Step through Name List addq.l #1,a4 Step through parameter cmp.b 0(a4,a6.l),d4 dbne d6,check_name bne.s advance_nl Name mismatch, go on * * Check that the name is a Resident Procedure or Function * found_it move.b 0(a0,a6.l),d1 subq.b #8,d1 Expected type code 8 or 9 bmi.s wrong_type subq.b #2,d1 Check type code <= 9 (!) bpl.s wrong_type moveq #0,d0 No error, CODEVEC is in D1 rts * wrong_type moveq #-12,d0 BAD NAME error code rts * define dc.w 2 Two procedures dc.w alias-* dc.b 5,'ALIAS' dc.w inverse-* dc.b 7,'INVERSE' dc.w 0 dc.w 1 One function dc.w codevec-* dc.b 7,'CODEVEC' dc.w 0 end