SECTION PDTK DATA 0 NOLIST INCLUDE 'QDOS_inc' LIST ; -------------------------------------------------------------- ; PDTK_asm - Freeware toolkit ; - last modified 08/09/95 ; ... by Mark J Swift - All rights reserved. ; to compile with the GST/QUANTA assembler use the command line: ; PDTK_asm -nolink -nolist -bin PDTK_rext ; to compile with HISOFT DEVPAC remove the SECTION directive, ; and change the line "bra.l TK_START" to "bra TK_START" ; -------------------------------------------------------------- BASE: ; *** Comment out ONE of the following two lines to *** ; *** create either a ROM or a BASIC toolkit. *** bra.l TK_START ; ...If I'm a BASIC toolkit! ; dc.l $4AFB0001 ; ...If I'm a ROM! dc.w PROC_DEF-BASE dc.w ROM_START-BASE BANNER: dc.b 0,72,'PDTK Freeware BASIC toolkit v1.12',$A dc.b '1995 M J Swift - All rights reserved',$A ; -------------------------------------------------------------- ; start of ROM code ; -------------------------------------------------------------- TK_START: movem.l d1-d3/a0-a3,-(a7) lea PROC_DEF(pc),a1 move.w BP.INIT,a2 jsr (a2) lea BANNER(pc),a1 ; start of message suba.l a0,a0 ; output channel 0 move.w UT.MTEXT,a2 jsr (a2) ; print it bra.s TK_DOIT ROM_START: movem.l d1-d3/a0-a3,-(a7) TK_DOIT: bsr TKILL moveq #ERR.OK,d0 movem.l (a7)+,d1-d3/a0-a3 rts ; ------------------------------------------------------------- PROC_DEF: dc.w 11 dc.w PDTK_EXT-* dc.b 8,'PDTK_EXT',0 dc.w EXTRAS-* dc.b 6,'EXTRAS',0 dc.w TOOLKILL-* dc.b 8,'TOOLKILL',0 dc.w P_TRACE-* dc.b 7,'P_TRACE' dc.w J_TRACE-* dc.b 7,'J_TRACE' dc.w J_TRACE_W-* dc.b 9,'J_TRACE_W' ; dc.w MC_TRACE-* ; dc.b 8,'MC_TRACE',0 dc.w 0 dc.w 4 dc.w PDTK_VER-* dc.b 9,'PDTK_VER$' dc.w WHERE-* dc.b 5,'WHERE' dc.w F_TRACE-* dc.b 7,'F_TRACE' dc.w 0 ; ------------------------------------------------------------- PDTK_EXT: lea PDTK_DEF(pc),a1 move.w $110,a2 jsr (a2) bra.s TKILL ; ------------------------------------------------------------- EXTRAS: moveq #1,d1 bsr FETCH_CH bne.s EXTRASX cmp.l a3,a5 bne RPORT.BP move.l a0,a4 ; channel ID move.l BV_NTBAS(a6),a3 move.l BV_NTP(a6),a5 EX_TYPE: move.w 0(a6,a3.l),d3 beq.s EX_SKIP cmp.w #$0800,d3 beq.s EX_CONT cmp.w #$0900,d3 bne.s EX_SKIP EX_CONT: cmp.l #$C000,4(a6,a3.l) blt.s EX_SKIP move.l BV_NLBAS(a6),a1 adda.w 2(a6,a3.l),a1 move.b 0(a6,a1.l),d2 ext.w d2 ; length of string beq.s EX_SKIP addq.l #1,a1 ; address of string move.l a4,a0 ; channel ID moveq #-1,d3 trap #4 ; relative to a6 moveq #IO.SSTRG,d0 trap #3 ; print string tst.l d0 bne.s EXTRASX moveq #$0A,d1 ; linefeed moveq #-1,d3 moveq #IO.SBYTE,d0 trap #3 tst.l d0 bne.s EXTRASX EX_SKIP: addq.l #8,a3 cmp.l a3,a5 bne EX_TYPE moveq #0,d0 EXTRASX: rts ; ------------------------------------------------------------- TOOLKILL: cmp.l a3,a5 bne RPORT.BP TKILL: move.l BV_NTBAS(a6),a2 move.l BV_NTP(a6),a5 bra TK_TYPNXT TK_TYPLUP: move.w 0(a6,a5.l),d3 beq TK_TYPNXT cmp.w #$0900,d3 beq.s TK_CONT cmp.w #$0800,d3 bne TK_TYPNXT TK_CONT: move.l a5,a3 bra TK_FNPRC TK_DUPLUP: move.w 0(a6,a3.l),d4 beq TK_DUPNXT cmp.w #$0800,d4 beq.s TK_NPTR cmp.w #$0900,d4 beq.s TK_NPTR cmp.w #$0303,d4 bgt.s TK_DUPNXT TK_NPTR: move.l BV_NLBAS(a6),a1 move.l a1,a0 adda.w 2(a6,a4.l),a1 ; name list entry adda.w 2(a6,a3.l),a0 move.b 0(a6,a1.l),d1 ; length of name cmp.b 0(a6,a0.l),d1 bne.s TK_DUPNXT ext.w d1 beq.s TK_DUPNXT subq.w #1,d1 TK_NAMLUP: addq.l #1,a1 addq.l #1,a0 move.b 0(a6,a0.l),d0 move.b 0(a6,a1.l),d2 eor.b d2,d0 andi.b #223,d0 ; compare name bne.s TK_DUPNXT dbra d1,TK_NAMLUP cmp.w #$0303,d4 ble.s TK_TYP3 cmp.b #'$',d2 bne.s TK_TYP1 move.w #$0001,d4 ; set to unset $ var bra.s TK_TYP3 TK_TYP1: cmp.b #'%',d2 bne.s TK_TYP2 move.w #$0003,d4 ; set to unset % var bra.s TK_TYP3 TK_TYP2: move.w #$0002,d4 ; set to unset FP var TK_TYP3: move.w 0(a6,a4.l),0(a6,a3.l) ; copy old to new move.w d4,0(a6,a4.l) ; & set old type ; move.w 2(a6,a3.l),d0 ; move.w 2(a6,a4.l),2(a6,a3.l) ; move.w d0,2(a6,a4.l) ; swap name pointer ; move.l 4(a6,a3.l),d0 move.l 4(a6,a4.l),4(a6,a3.l) move.l d0,4(a6,a4.l) ; swap 'value' TK_FNPRC: move.l a3,a4 ; new fn/proc TK_DUPNXT: subq.l #8,a3 cmp.l a3,a2 ble TK_DUPLUP TK_TYPNXT: subq.l #8,a5 cmp.l a5,a2 ble TK_TYPLUP TK_EXIT: moveq #0,d0 rts ; ------------------------------------------------------------- PDTK_VER: cmp.l a3,a5 bne RPORT.BP move.l #'1.12',d1 bra RET_4S ; ------------------------------------------------------------- J_TRACE: moveq #0,d5 bra J_TRC1 J_TRACE_W: moveq #-1,d5 J_TRC1: moveq #1,d7 ; old shared device bsr FL_ID bne FEXIT move.l a4,d4 ; channel ID to close bsr HEDR1 ; read file header moveq #ERR.BP,d0 cmp.l a3,a5 bne SDONE1 moveq #MT.CJOB,d0 ; create job in trns prog moveq #-1,d1 ; owner of job move.l 0(a2),d2 ; length move.l 6(a2),d3 ; dataspace suba.l a1,a1 ; start address trap #1 movea.l a0,a4 ; allocated start tst.l d0 bne SDONE1 move.l d1,d6 ; save Job ID move.l d4,a0 ; File ID move.l a4,a1 ; location to load moveq #-1,d3 ; infinite timeout moveq #FS.LOAD,d0 trap #3 ; load file bsr SDONE1 tst.l d0 bne J_TRCR ori.w #$8000,-JB_END+JB_SR(a4) ; trace on moveq #MT.ACTIV,d0 ; activate the job move.l d6,d1 ; restore Job ID moveq #$20,d2 ; priority move.l d5,d3 ; timeout trap #1 tst.l d0 bne.s J_TRCR tst.l d5 bne.s J_TRCX moveq #MT.SUSJB,d0 ; suspend a job moveq #-1,d1 ; me (usually BASIC) moveq #$19,d3 ; timeout suba.l a1,a1 ; no flag trap #1 J_TRCX: rts J_TRCR: move.l d0,d7 ; save error code moveq #MT.RJOB,d0 ; remove job move.l d6,d1 ; restore Job ID trap #1 move.l d7,d0 ; restore error code rts ; ------------------------------------------------------------- F_TRACE: bsr FETCH_S bne.s TRACEX bsr.s WHEREIS ; find address of FN/PROC cmpi.w #$0900,d0 beq.s TRACEON bra RPORT.BP ; ------------------------------------------------------------- P_TRACE: bsr FETCH_S bne.s TRACEX bsr.s WHEREIS ; find address of FN/PROC cmpi.w #$0800,d0 bne RPORT.BP ; ------------------------------------------------------------- TRACEON: trap #0 ; enter supervisor mode ori.w #$8000,sr ; trace on andi.w #$DFFF,sr ; enter user mode jsr (a0) ; do FN/PROC TRACEOFF: trap #0 ; enter supervisor mode andi.w #$1FFF,sr ; clear trace, exit supervisor TRACEX: rts ; ------------------------------------------------------------- ;MC_TRACE: ; bsr FETCH_W ; bne.s MC_TXIT ; tst.w d1 ; beq.s MC_TOFF ; trap #0 ; ori.w #$8000,sr ; andi.w #$DFFF,sr ; rts ;MC_TOFF: ; trap #0 ; andi.w #$1FFF,sr ;MC_TXIT: ; rts ; ------------------------------------------------------------- WHERE: bsr FETCH_S bne.s WHEREX cmp.l a3,a5 bne RPORT.NO bsr.s WHEREIS move.l a0,d1 bra RET_L WHEREX: ; ------------------------------------------------------------- ; Enter: A1=pointer to fn/proc NAME (string) on math stack ; Exit: A1=updated pointer ; D0=NAME type (i.e. proc=$0800, fn=$0900) ; A0=address of fn/proc WHEREIS: movem.l d1-d2/a2-a5,-(a7) move.w 0(a6,a1.l),d0 beq.s WHER_FAIL cmp.w #256,d0 bcc.s WHER_FAIL addq.l #1,a1 move.l a1,a3 move.l BV_NTBAS(a6),a4 move.l BV_NTP(a6),a5 WHER_LUP1: move.l BV_NLBAS(a6),a2 add.w 2(a6,a4.l),a2 move.b 0(a6,a1.l),d0 cmp.b 0(a6,a2.l),d0 bne.s WHER_NXT ext.w d0 subq.w #1,d0 WHER_LUP2: addq.l #1,a1 addq.l #1,a2 move.b 0(a6,a1.l),d1 move.b 0(a6,a2.l),d2 eor.b d2,d1 andi.b #$DF,d1 bne.s WHER_NXT dbra d0,WHER_LUP2 move.w 0(a6,a4.l),d0 ; type move.l 4(a6,a4.l),a0 ; address bra.s WHER_RTS WHER_NXT: move.l a3,a1 addq.l #8,a4 cmp.l a5,a4 bne WHER_LUP1 WHER_FAIL: moveq #0,d0 move.l d0,a0 WHER_RTS: move.l a3,a1 subq.l #1,a1 moveq #3,d1 ; get total length of string add.w 0(a6,a1.l),d1 bclr #0,d1 add.l d1,a1 ; and update a1 movem.l (a7)+,d1-d2/a2-a5 rts ; ------------------------------------------------------------- PDTK_DEF: dc.w 15 dc.w RESET-* dc.b 5,'RESET' dc.w RECHP-* dc.b 5,'RECHP' dc.w CLCHP-* dc.b 5,'CLCHP' dc.w LRESPR-* dc.b 6,'LRESPR',0 dc.w DDLIST-* dc.b 6,'DDLIST',0 dc.w SACS-* dc.b 9,'SET_FACCS' dc.w STYP-* dc.b 8,'SET_FTYP',0 dc.w SDAT-* dc.b 8,'SET_FDAT',0 dc.w SXTRA-* dc.b 9,'SET_FXTRA' dc.w CURSEN-* dc.b 6,'CURSEN',0 dc.w CURDIS-* dc.b 6,'CURDIS',0 dc.w 0 dc.w 23 dc.w QDOS-* dc.b 5,'QDOS$' dc.w SYSBASE-* dc.b 7,'SYSBASE' dc.w ALCHP-* dc.b 5,'ALCHP' dc.w FREE_MEM-* dc.b 8,'FREE_MEM',0 dc.w FLEN-* dc.b 4,'FLEN',0 dc.w FACS-* dc.b 5,'FACCS' dc.w FTYP-* dc.b 4,'FTYP',0 dc.w FDAT-* dc.b 4,'FDAT',0 dc.w FXTRA-* dc.b 5,'FXTRA' dc.w FTEST-* dc.b 5,'FTEST' dc.w DDTEST-* dc.b 6,'DDTEST',0 dc.w HEXS-* dc.b 4,'HEX$',0 dc.w HEX-* dc.b 3,'HEX' dc.w INTEGERS-* dc.b 8,'INTEGER$',0 dc.w LONGINTS-* dc.b 8,'LONGINT$',0 dc.w FLOATS-* dc.b 6,'FLOAT$',0 dc.w STRINGS-* dc.b 7,'STRING$' dc.w STRINGI-* dc.b 7,'STRING%' dc.w STRINGL-* dc.b 7,'STRINGL' dc.w STRINGF-* dc.b 7,'STRINGF' dc.w 0 ; ------------------------------------------------------------- QDOS: cmp.l a3,a5 bne RPORT.BP moveq #MT.INF,d0 trap #1 move.l d2,d1 bra RET_4S ; ------------------------------------------------------------- SYSBASE: cmp.l a3,a5 bne RPORT.BP moveq #MT.INF,d0 trap #1 move.l a0,d1 bra RET_L ; ------------------------------------------------------------- RESET: cmp.l a3,a5 bne RPORT.BP trap #0 ori.w #$0700,sr move.l $0,a7 ; reset supervisor stack move.l a7,d0 andi.l #$FFFF8000,d0 move.l d0,a6 suba.l a0,a0 tst.b 161(a6) ; skip if not 010+ beq.s RESET2 dc.w $4E7A,$8801 ; movec vbr,a0 RESET2: move.l $4(a0),-(a7) ; jump to reset routine rts ; ------------------------------------------------------------- RECHP: bsr FETCH_L bne.s RECHX cmp.l a3,a5 bne RPORT.BP subq.l #4,d1 ; compensate for link lea $E0(a6),a1 ; BASICs list of allocations RECHL: move.l (a1),d0 beq RPORT.OR ; indicate error if no link move.l d0,a1 cmp.l d0,d1 ; look for allocation in list bne.s RECHL move.l d1,a0 ; address of link lea $E0(a6),a1 ; BASICs list of allocations move.w UT.UNLNK,a4 jsr (a4) ; remove from linked list moveq #MT.RECHP,d0 trap #1 ; release memory RECHX: rts ; ------------------------------------------------------------- CLCHP: cmp.l a3,a5 bne RPORT.BP lea $E0(a6),a1 ; BASICs list of allocations move.l (a1),d0 beq.s CLCHPX clr.l (a1) CLCHPL: move.l d0,a4 move.l d0,a0 moveq #MT.RECHP,d0 trap #1 move.l (a4),d0 bne.s CLCHPL CLCHPX: rts ; ------------------------------------------------------------- ; ALCHP(HP.REQ) ; or ALCHP(JB.ID,HP.REQ) ; or ALCHP(JB.NUM,JB.TAG,HP.REQ) ALCHP: move.l a5,d5 sub.l a3,d5 beq RPORT.BP moveq #-1,d2 ; default job ID cmp.w #1*8,d5 ; one parameter? beq.s ALCH1P cmp.w #3*8,d5 bgt RPORT.BP move.l a5,-(a7) lea -8(a5),a5 bsr FETCH_ID ; get job ID movea.l a5,a3 movea.l (a7)+,a5 bne.s ALCHX move.l d1,d2 ; in d2! ALCH1P: bsr FETCH_L bne.s ALCHX tst.l d1 ble RPORT.OR ; shouldn't allocate nought addq.l #4,d1 ; room for link moveq #MT.ALCHP,d0 trap #1 tst.l d0 bne.s ALCHX lea $E0(a6),a1 ; BASICs list of allocations move.w UT.LINK,a4 jsr (a4) ; add to linked list move.l a0,d1 ; address of allocation addq.l #4,d1 ; skip over link bra RET_L ALCHX: rts ; ------------------------------------------------------------- FREE_MEM: moveq #MT.INF,d0 trap #1 move.l SV_BASIC(a0),d1 sub.l SV_FREE(a0),d1 subi.l #$400,d1 ; a bit of lea-way bra RET_L ; ------------------------------------------------------------- LRESPR: moveq #1,d7 ; old shared device bsr FL_ID bne FEXIT move.l a4,d4 ; channel ID to close bsr HEDR1 ; read file header moveq #ERR.BP,d0 cmp.l a3,a5 bne SDONE1 move.l 0(a2),d1 ; get length of file movem.l d1/a2,-(a7) ; save len & header buffer moveq #MT.ALRES,d0 trap #1 ; allocate space move.l a0,a1 ; location movem.l (a7)+,d2/a2 ; restore len & header buffer tst.l d0 bne SDONE1 ; no room so quit move.l a1,-(a7) ; stack return address move.l a4,a0 ; File ID moveq #-1,d3 ; infinite timeout moveq #FS.LOAD,d0 trap #3 ; load file tst.l d0 beq SDONE1 ; no errors. addq.l #4,a7 ; failed to load bra SDONE1 ; ------------------------------------------------------------- FLEN: moveq #1,d7 ; old shared device bsr FGEN bne SDONE1 moveq #ERR.BP,d0 cmp.l a3,a5 bne SDONE1 move.l 0(a2),d6 bra.s FDONE ; ------------------------------------------------------------- FACS: moveq #1,d7 ; old shared device bsr FGEN bne SDONE1 moveq #ERR.BP,d0 cmp.l a3,a5 bne SDONE1 move.b 4(a2),d6 ext.w d6 ext.l d6 bra.s FDONE ; ------------------------------------------------------------- FTYP: moveq #1,d7 ; old shared device bsr FGEN bne SDONE1 moveq #ERR.BP,d0 cmp.l a3,a5 bne SDONE1 move.b 5(a2),d6 ext.w d6 ext.l d6 bra.s FDONE ; ------------------------------------------------------------- FDAT: moveq #1,d7 ; old shared device bsr FGEN bne SDONE1 moveq #ERR.BP,d0 cmp.l a3,a5 bne SDONE1 move.l 6(a2),d6 bra.s FDONE ; ------------------------------------------------------------- FXTRA: moveq #1,d7 ; old shared device bsr FGEN bne SDONE1 moveq #ERR.BP,d0 cmp.l a3,a5 bne.s SDONE1 move.l $A(a2),d6 ; ------------------------------------------------------------- FDONE: moveq #ERR.OK,d0 ; no errors bsr.s SDONE1 FDONE1: move.l d6,d1 bra RET_L ; ------------------------------------------------------------- FEXIT: rts ; ------------------------------------------------------------- SACS: moveq #0,d7 ; old exclusive device bsr FGEN bne.s SDONE1 bsr FETCH_W bne.s SDONE1 moveq #ERR.BP,d0 cmp.l a3,a5 bne.s SDONE1 move.b d1,4(a2) bra.s SDONE ; ------------------------------------------------------------- STYP: moveq #0,d7 ; old exclusive device bsr.s FGEN bne.s SDONE1 bsr FETCH_W bne.s SDONE1 moveq #ERR.BP,d0 cmp.l a3,a5 bne.s SDONE1 move.b d1,5(a2) bra.s SDONE ; ------------------------------------------------------------- SDAT: moveq #0,d7 ; old exclusive device bsr.s FGEN bne.s SDONE1 bsr FETCH_L bne.s SDONE1 moveq #ERR.BP,d0 cmp.l a3,a5 bne.s SDONE1 move.l d1,6(a2) bra.s SDONE ; ------------------------------------------------------------- SXTRA: moveq #0,d7 ; old exclusive device bsr.s FGEN bne.s SDONE1 bsr FETCH_L bne.s SDONE1 moveq #ERR.BP,d0 cmp.l a3,a5 bne.s SDONE1 move.l d1,$A(a2) ; ------------------------------------------------------------- SDONE: moveq #ERR.OK,d0 ; no errors move.l a4,a0 ; channel ID move.l a2,a1 ; location of header moveq #14,d2 moveq #-1,d3 moveq #FS.HEADS,d0 ; set header trap #3 SDONE1: move.l d0,d7 ; save error code move.l a2,d0 beq.s SDONE2 move.l a2,a0 moveq #MT.RECHP,d0 trap #1 ; release buffer SDONE2: tst.l d4 beq.s SEXIT move.l d4,a0 moveq #IO.CLOSE,d0 ; close file trap #2 SEXIT: move.l d7,d0 ; restore error code rts ; ------------------------------------------------------------- FGEN: moveq #0,d4 ; no channel to close yet bsr BKSLSH beq.s FGEN1 moveq #1,d1 ; default channel bsr FETCH_CH bne.s FGENX move.l a0,a4 ; store channel ID bra.s FGEN3 FGEN1: bsr FETCH_N bne.s FGENX FGEN2: bsr.s FL_ID bne.s FGENX move.l a4,d4 ; channel ID to close FGEN3: bsr.s HEDR1 ; read file header FGENX: rts ; ------------------------------------------------------------- FL_ID: bsr GET1_FNAMES bne.s FL_IDX FL_ID1: moveq #0,d1 move.w 0(a6,a1.l),d1 ; length of filename move.l a1,a0 ; address of filename move.l d7,d3 ; shared or exclusive... moveq #-1,d1 ; current job trap #4 ; relative to a6 moveq #IO.OPEN,d0 ; try to open file trap #2 tst.l d0 bne.s FL_IDX ; error move.l a0,a4 ; store channel ID FL_IDX: rts ; ------------------------------------------------------------- HEDR1: movem.l d2-d3/d7/a1/a3,-(a7) moveq #64,d1 ; space required moveq #-1,d2 ; owner job = me moveq #MT.ALCHP,d0 trap #1 tst.l d0 bne.s HEDRX move.l a0,a2 ; address of buffer move.l a4,a0 ; channel ID move.l a2,a1 ; location for header moveq #64,d2 moveq #-1,d3 moveq #FS.HEADR,d0 ; get 64 bytes of header trap #3 tst.l d0 beq.s HEDRX ; no errors... exit move.l d0,d7 ; save error code move.l a2,a0 moveq #MT.RECHP,d0 trap #1 ; release buffer suba.l a2,a2 ; indicate no buffer move.l d7,d0 ; restore error HEDRX: movem.l (a7)+,d2-d3/d7/a1/a3 rts ; ------------------------------------------------------------- FTEST: bsr GET1_FNAMES bne RPORT.BP cmp.l a3,a5 bne RPORT.BP moveq #0,d1 move.w 0(a6,a1.l),d1 ; length of filename move.l a1,a0 ; address of filename moveq #0,d3 ; old exclusive device moveq #-1,d1 ; current job trap #4 ; relative to a6 moveq #IO.OPEN,d0 ; try to open file trap #2 move.l d0,d6 bne.s FTEST1 moveq #IO.CLOSE,d0 ; close file trap #2 FTEST1: move.l d6,d1 bra RET_L ; ------------------------------------------------------------- DDTEST: bsr FETCH_S bne RPORT.BP cmp.l a3,a5 bne RPORT.BP moveq #MT.INF,d0 trap #1 move.l SV_DDLST(a0),a0 bra.s DDTST1 DDTSTL: move.l (a0),a0 DDTST1: move.l a0,d0 beq.s DDTST.NF ; device not in list lea $24(a0),a4 ; address of name move.l a1,a2 move.w (a4)+,d0 cmp.w 0(a6,a2.l),d0 bne.s DDTSTL addq.l #2,a2 bra.s DDTST2 DDTSTL2: move.b (a4)+,d1 move.b 0(a6,a2.l),d2 eor.b d2,d1 andi.b #$DF,d1 bne.s DDTSTL addq.l #1,a2 DDTST2: dbra d0,DDTSTL2 moveq #ERR.OK,d1 bra.s DDTSTX DDTST.NF: moveq #ERR.NF,d1 DDTSTX: bra RET_L ; ------------------------------------------------------------- DDLIST: moveq #1,d1 bsr FETCH_CH bne.s DDLISTX cmp.l a3,a5 bne RPORT.BP move.l a0,a3 ; save channel id moveq #MT.INF,d0 trap #1 ; get address of sys vars in a0 move.l SV_DDLST(a0),a4 ; address of first device driver move.l a3,a0 ; restore channel id DDLISTL: lea $24(a4),a1 bsr IOSTRG bne.s DDLISTX moveq #$0A,d1 ; linefeed moveq #-1,d3 moveq #IO.SBYTE,d0 trap #3 tst.l d0 bne.s DDLISTX move.l (a4),a4 move.l a4,d0 tst.l d0 bne.s DDLISTL DDLISTX: rts ; ------------------------------------------------------------- HEXS: bsr FETCH_L bne.s HEXSX move.l d1,d2 bsr FETCH_W bne.s HEXSX cmp.l a3,a5 bne RPORT.BP cmp.w #32,d1 bgt RPORT.OR addq.w #3,d1 lsr.w #2,d1 ; number of digits beq RPORT.OR move.l BV_RIP(a6),a1 btst #0,d1 beq.s HEXS1 subq.l #1,a1 HEXS1: move.w d1,d3 subq.w #1,d3 HEXSL: move.l d2,d0 andi.b #15,d0 cmpi.b #10,d0 blt.s HEXS2 addq.b #7,d0 HEXS2: addi.b #48,d0 subq.l #1,a1 move.b d0,0(a6,a1.l) lsr.l #4,d2 dbra d3,HEXSL subq.l #2,a1 move.w d1,0(a6,a1.l) move.l a1,BV_RIP(a6) moveq #1,d4 moveq #ERR.OK,d0 HEXSX: rts ; ------------------------------------------------------------- HEX: bsr FETCH_S bne RPORT.BP cmp.l a3,a5 bne RPORT.BP move.w 0(a6,a1.l),d1 beq RPORT.BP cmp.w #8,d1 bgt RPORT.BP addq.l #2,a1 subq.w #1,d1 moveq #0,d2 HEXL: move.b 0(a6,a1.l),d0 addq.l #1,a1 subi.b #48,d0 bmi RPORT.OR cmpi.b #10,d0 blt.s HEX1 andi.b #223,d0 cmpi.b #17,d0 blt RPORT.OR subq.b #7,d0 cmpi.b #15,d0 bgt RPORT.OR HEX1: lsl.l #4,d2 or.b d0,d2 dbra d1,HEXL move.l d2,d1 bra RET_L ; ------------------------------------------------------------- STRINGL: bsr FETCH_S bne RPORT.BP cmp.l a3,a5 bne RPORT.BP move.w 0(a6,a1.l),d1 cmp.w #4,d1 bne RPORT.BP move.l 2(a6,a1.l),d1 bra RET_L ; ------------------------------------------------------------- STRINGI: bsr FETCH_S bne RPORT.BP cmp.l a3,a5 bne RPORT.BP moveq #2,d2 moveq #3,d4 bra.s NUMFORM ; ------------------------------------------------------------- STRINGF: bsr FETCH_S bne RPORT.BP cmp.l a3,a5 bne RPORT.BP moveq #6,d2 moveq #2,d4 NUMFORM: move.w 0(a6,a1.l),d1 cmp.w d2,d1 bne RPORT.BP addq.l #2,a1 move.l a1,BV_RIP(a6) rts ; ------------------------------------------------------------- INTEGERS: bsr FETCH_W bne RPORT.BP cmp.l a3,a5 bne RPORT.BP moveq #2,d4 bra.s STRFORM ; ------------------------------------------------------------- LONGINTS: move.w CA.GTLIN,a2 bsr GET_ONE bne RPORT.BP cmp.l a3,a5 bne RPORT.BP moveq #4,d4 bra.s STRFORM ; ------------------------------------------------------------- FLOATS: bsr FETCH_F bne RPORT.BP cmp.l a3,a5 bne RPORT.BP moveq #6,d4 bra.s STRFORM ; ------------------------------------------------------------- STRINGS: bsr FETCH_S bne RPORT.BP cmp.l a3,a5 bne RPORT.BP move.w 0(a6,a1.l),d4 addq.w #2,d4 STRFORM: ; moveq.l #2,d1 ; move.w BV.CHRIX,a2 ; jsr (a2) subq.l #2,a1 ; 2 bytes for string len move.l a1,BV_RIP(a6) move.w d4,0(a6,a1.l) moveq #1,d4 moveq #0,d0 rts ; ------------------------------------------------------------- CURSEN: moveq #SD.CURE,d5 bra.s CURSR CURDIS: moveq #SD.CURS,d5 CURSR: moveq #1,d1 bsr FETCH_CH bne.s CURSR_X cmp.l a3,a5 bne RPORT.BP move.w #-1,d3 move.b d5,d0 trap #3 CURSR_X: rts ; ------------------------------------------------------------- ; Entry: A3.L pointer to first parameter ; A5.L pointer to last parameter ; ; Exit: A3.L updated ; A5.L updated ; A1.L pointer to result ; D0.L...error code ; D1.W result (or mantissa or string length) ; Fetch one null parameter FETCH_N: move.b 1(a6,a1.l),d0 andi.w #$0F,d0 bne RPORT.BP addq.l #8,a3 rts ; -------------------------------------------------------------- ; Fetch one Word FETCH_W: movem.l a2,-(a7) move.w CA.GTINT,a2 bsr GET_ONE bne.s FETCH_WX move.l a1,BV_RIP(a6) moveq #0,d1 move.w 0(a6,a1.l),d1 addq.l #2,BV_RIP(a6) FETCH_WX: movem.l (a7)+,a2 tst.l d0 rts ; -------------------------------------------------------------- ; Fetch one long word FETCH_L: movem.l a2,-(a7) move.w CA.GTLIN,a2 bsr.s GET_ONE bne.s FETCH_LX move.l a1,BV_RIP(a6) move.l 0(a6,a1.l),d1 addq.l #4,BV_RIP(a6) FETCH_LX: movem.l (a7)+,a2 tst.l d0 rts ; -------------------------------------------------------------- ; Fetch one floating point number FETCH_F: movem.l a2,-(a7) move.w CA.GTFP,a2 bsr.s GET_ONE bne.s FETCH_FX move.l a1,BV_RIP(a6) move.w 0(a6,a1.l),d1 move.l 2(a6,a1.l),d2 addq.l #6,BV_RIP(a6) FETCH_FX: movem.l (a7)+,a2 tst.l d0 rts ; -------------------------------------------------------------- ; Fetch one string FETCH_S: movem.l a2,-(a7) move.w CA.GTSTR,a2 bsr.s GET_ONE bne.s FETCH_SX move.l a1,BV_RIP(a6) moveq #3,d1 ; get total length of string add.w 0(a6,a1.l),d1 bclr #0,d1 add.l d1,BV_RIP(a6) ; and reset ri stack pointer FETCH_SX: movem.l (a7)+,a2 tst.l d0 rts ; -------------------------------------------------------------- ; This routine gets one parameter and returns it on the maths ; stack, pointed to by (A1). ; ; Entry: A2.L routine to call (i.e. CA.GTINT) ; A3.L pointer to first parameter ; A5.L pointer to last parameter ; ; Exit: A3.L updated ; A5.L updated ; A1.L updated pointer to top of maths stack ; D0.L error code ; GET_ONE: movem.l d1-d6/a0/a2,-(a7) lea 8(a3),a0 cmp.l a0,a5 blt.s GET_ONEBp move.l BV_RIP(a6),a1 move.l a5,-(a7) move.l a0,a5 move.l a5,-(a7) jsr (a2) movem.l (a7)+,a0/a5 tst.l d0 bne.s GET_ONEX move.l a0,a3 move.l a1,BV_RIP(a6) bra.s GET_ONEX GET_ONEBp: moveq #ERR.BP,d0 GET_ONEX: movem.l (a7)+,d1-d6/a0/a2 tst.l d0 rts ; -------------------------------------------------------------- ; Get a filename on the stack ; ; Entry: A3.L pointer to first parameter ; A5.L pointer to last parameter ; ; Exit: A3.L updated ; A5.L updated ; D0.L...error code ; A1.L pointer to string on math stack GET1_FNAMES: movem.l d1/d4/d6/a2,-(a7) cmp.l a3,a5 beq GET1_BP move.l BV_RIP(a6),a1 tst.w 2(a6,a3.l) ; Test for parameter name bmi.s GET1_STR ; none? ...must be exprssn. moveq #$0f,d0 ; extract type of parameter. and.b 1(a6,a3.l),d0 subq.b #1,d0 ; is it a string? bne.s GET1_NAM ; no, use name instead GET1_STR: move.l a5,-(sp) ; save the top pointer lea 8(a3),a5 ; get just one string move.w CA.GTSTR,a2 jsr (a2) move.l (sp)+,a5 ; restore top pointer tst.l d0 bne.s GET1_RTS move.l a1,BV_RIP(a6) moveq #3,d1 ; get total length of string add.w 0(a6,a1.l),d1 bclr #0,d1 add.l d1,BV_RIP(a6) ; and reset ri stack pointer bra.s GET1_OK GET1_NAM: moveq #0,d1 move.w 2(a6,a3.l),d1 ; pointer to real entry bmi.s GET1_BP ; ... expression is no good lsl.l #3,d1 ; in multiples of 8 bytes add.l BV_NTBAS(a6),d1 moveq #0,d6 move.w 2(a6,d1.l),d6 ; pointer to the name add.l BV_NLBAS(a6),d6 moveq #0,d1 ; get the length of the name move.b 0(a6,d6.l),d1 ; as a long word. addq.l #1,d1 ; rounded up bclr #0,d1 move.w d1,d4 ; and save it addq.l #2,d1 ; space required is +2 bytes move.w BV.CHRIX,a2 ; on ri stack jsr (a2) move.l BV_RIP(a6),a1 add.w d4,d6 ; move to end of string GET1_NMLUP: subq.l #1,a1 ; copy one byte at a time move.b 0(a6,d6.l),0(a6,a1.l) subq.l #1,d6 dbra d4,GET1_NMLUP ; including the (byte) name * length subq.l #1,a1 ; put a zero on to make it a clr.b 0(a6,a1.l) ; word GET1_OK: lea 8(a3),a3 ; update parameter pointer moveq #ERR.OK,d0 bra.s GET1_RTS GET1_BP: moveq #ERR.BP,d0 GET1_RTS: tst.l d0 movem.l (a7)+,d1/d4/d6/a2 rts ; -------------------------------------------------------------- ; Get channel parameter ; Entry: A3.L pointer to first parameter ; A5.L pointer to last parameter ; D1.L default channel # ; ; Exit: A0.L CH.ID (default d1) ; A2.L CH.BASE ; A3.L updated ; A5.L updated ; D0.L error code ; FETCH_CH: movem.l d1/d3/a1,-(a7) move.l BV_RIP(a6),a1 cmp.l a3,a5 beq.s FETCH_CH1 btst #7,1(a6,a3.l) beq.s FETCH_CH1 bsr FETCH_W bne.s FETCH_CHX FETCH_CH1: mulu #$28,d1 add.l BV_CHBAS(a6),d1 cmp.l BV_CHP(a6),d1 bge.s FETCH_CHNO move.l d1,a2 move.l 0(a6,a2.l),a0 move.w a0,d1 bmi.s FETCH_CHNO moveq #ERR.OK,d0 bra.s FETCH_CHX FETCH_CHNO: moveq #ERR.NO,d0 FETCH_CHX: movem.l (a7)+,d1/d3/a1 rts ; ------------------------------------------------------------- ; Get a job ID ; ; Entry: a3.L pointer to first parameter ; a5.L pointer to last parameter ; ; Exit: d1.l JOB ID ; a3.L updated ; a5.L updated ; d0.L error code FETCH_ID: movem.l d2/d5,-(a7) move.l a5,d5 sub.l a3,d5 beq.s ID_BP subq.w #8,d5 bne.s ID_1 bsr FETCH_L ; JOB ID bra.s ID_X ID_1: subq.w #8,d5 bne.s ID_BP bsr.s COMMA bne.s ID_BP bsr FETCH_W ; JOB No bne.s ID_X move.w d1,d2 swap d2 bsr FETCH_W ; JOB tag bne.s ID_X move.w d1,d2 move.l d2,d1 moveq #ERR.OK,d0 bra.s ID_X ID_BP: moveq #ERR.BP,d0 ID_X: movem.l (a7)+,d2/d5 rts ; ------------------------------------------------------------- COMMA: move.b 1(a6,a3.l),d0 and.w #$70,d0 cmpi.b #$10,d0 ; ',' rts BKSLSH: move.b 1(a6,a3.l),d0 and.w #$70,d0 cmpi.b #$30,d0 ; '\' rts ; ------------------------------------------------------------- ; Return true or false back to BASIC RET_FLS: moveq #0,d1 bra.s RET_W RET_TRU: moveq #1,d1 ; -------------------------------------------------------------- ; Return word d1.w to BASIC RET_W: move.l d1,d4 moveq.l #2,d1 move.w BV.CHRIX,a2 jsr (a2) move.l d4,d1 move.l BV_RIP(a6),a1 ; Get arith stack pointer subq.l #2,a1 ; room for 2 bytes move.l a1,BV_RIP(a6) move.w d1,0(a6,a1.l) ; Put int number on stack moveq.l #3,d4 ; set Integer type moveq.l #ERR.OK,d0 ; no errors rts ; ------------------------------------------------------------- ; Return long Integer d1.l to BASIC RET_L: move.l d1,d4 moveq.l #6,d1 move.w BV.CHRIX,a2 jsr (a2) move.l d4,d1 bsr.s CONV_L2F subq.l #6,BV_RIP(a6) move.l BV_RIP(a6),a1 move.w d2,0(a6,a1.l) move.l d1,2(a6,a1.l) moveq.l #2,d4 moveq.l #ERR.OK,d0 rts ; ------------------------------------------------------------- ; convert long Integer to floating point form. ; Entry: d1.l = long int ; Exit: d1.w = mantissa ; d2.l = exponent CONV_L2F: move.l d1,d2 beq.s CONV_L2FX move.w #$81F,d2 move.l d1,-(a7) CONV_L2F1: add.l d1,d1 bvs.s CONV_L2F2 subq.w #1,d2 move.l d1,(a7) bra.s CONV_L2F1 CONV_L2F2: move.l (a7)+,d1 CONV_L2FX: rts ; ------------------------------------------------------------- ; Return 4 character string d1.l to BASIC RET_4S: move.l d1,d4 moveq.l #6,d1 move.w BV.CHRIX,a2 jsr (a2) move.l d4,d1 subq.l #6,BV_RIP(a6) move.l BV_RIP(a6),a1 move.w #4,0(a6,a1.l) move.l d1,2(a6,a1.l) moveq #1,d4 moveq #ERR.OK,d0 rts ; ------------------------------------------------------------- ; print string at (a1) to channel with id a0 IOSTRG: movem.l d1-d3/a1-a2,-(a7) move.w UT.MTEXT,a2 jsr (a2) movem.l (a7)+,d1-d3/a1-a2 rts ; -------------------------------------------------------------- RPORT.OR moveq #ERR.OR,d0 rts RPORT.NO moveq #ERR.NO,d0 rts RPORT.BP moveq #ERR.BP,d0 rts ; -------------------------------------------------------------- END