mt_alchp equ $18 mt_rechp equ $19 ut_mtext equ $d0 ut_cstr equ $e6 bp_init equ $110 ca_gtint equ $112 ca_gtfp equ $114 ca_gtstr equ $116 ca_gtlin equ $118 ri_exec equ $11c ri_nint equ $02 ri_int equ $04 ri_nlint equ $06 ri_float equ $08 ri_add equ $0a ri_sub equ $0c ri_mult equ $0e ri_div equ $10 ri_abs equ $12 ri_neg equ $14 ri_dup equ $16 ri_cot equ $1e ri_atan equ $24 ri_sqrt equ $28 ri_ln equ $2a bv_ntbas equ $18 bv_nlbas equ $20 bv_vvbas equ $28 bv_rip equ $58 bv_rand equ $80 bv_chrix equ $11a io_sstrg equ 7 err_ni equ -19 err_ov equ -18 err_bp equ -15 err_nf equ -7 err_om equ -3 err_or equ -4 myself equ -1 lea proc_tab,a1 move.w bp_init,a2 jsr (a2) moveq #$1a,d2 ; 26 bytes moveq #-1,d3 ; no timeout sub.l a0,a0 ; channel 0 lea msg,a1 moveq #io_sstrg,d0 ; send a string of bytes trap #3 moveq #0,d0 rts msg dc.b 'Chipsi math package v2.05' dc.b $a proc_tab dc.w 18 dc.w matinv-* dc.b 6 dc.b 'MATINV' align dc.w matmult-* dc.b 7 dc.b 'MATMULT' dc.w matpoint-* dc.b 7 dc.b 'MATPLOT' dc.w matpoint_r-* dc.b 9 dc.b 'MATPLOT_R' align dc.w matinput-* dc.b 8 dc.b 'MATINPUT' align dc.w matread-* dc.b 7 dc.b 'MATREAD' dc.w mattrn-* dc.b 6 dc.b 'MATTRN' align dc.w matrnd-* dc.b 6 dc.b 'MATRND' align dc.w matseq-* dc.b 6 dc.b 'MATSEQ' align dc.w matadd-* dc.b 6 dc.b 'MATADD' align dc.w matsub-* dc.b 6 dc.b 'MATSUB' align dc.w matidn-* dc.b 6 dc.b 'MATIDN' align dc.w matequ-* dc.b 6 dc.b 'MATEQU' align dc.w swap-* dc.b 4 dc.b 'SWAP' align dc.w 0 dc.w 32 dc.w size-* dc.b 4 dc.b 'SIZE' align dc.w det-* dc.b 3 dc.b 'DET' dc.w matmin-* dc.b 6 dc.b 'MATMIN' align dc.w matmax-* dc.b 6 dc.b 'MATMAX' align dc.w matcount-* dc.b 8 dc.b 'MATCOUNT' align dc.w matcount1-* dc.b 9 dc.b 'MATCOUNT1' dc.w matsum-* dc.b 6 dc.b 'MATSUM' align dc.w matprod-* dc.b 7 dc.b 'MATPROD' dc.w matmean-* dc.b 7 dc.b 'MATMEAN' dc.w matdev-* dc.b 6 dc.b 'MATDEV' align dc.w matdev1-* dc.b 7 dc.b 'MATDEV1' dc.w ndim-* dc.b 4 dc.b 'NDIM' align dc.w gregor-* dc.b 6 dc.b 'GREGOR' align dc.w easter-* dc.b 6 dc.b 'EASTER' align dc.w gcd-* dc.b 3 dc.b 'GCD' dc.w lcm-* dc.b 3 dc.b 'LCM' dc.w atn-* dc.b 3 dc.b 'ATN' dc.w sqr-* dc.b 3 dc.b 'SQR' dc.w sgn-* dc.b 3 dc.b 'SGN' dc.w inf-* dc.b 3 dc.b 'INF' dc.w eps-* dc.b 3 dc.b 'EPS' dc.w intmax-* dc.b 6 dc.b 'INTMAX' align dc.w ceil-* dc.b 4 dc.b 'CEIL' align dc.w max-* dc.b 3 dc.b 'MAX' dc.w min-* dc.b 3 dc.b 'MIN' dc.w atn2-* dc.b 4 dc.b 'ATN2' align dc.w log2-* dc.b 4 dc.b 'LOG2' align dc.w fact-* dc.b 4 dc.b 'FACT' align dc.w binom-* dc.b 5 dc.b 'BINOM' dc.w div-* dc.b 3 dc.b 'DIV' dc.w mod-* dc.b 3 dc.b 'MOD' dc.w 0 sqrmat move.w 0(a6,a3.l),d2 and.b #$f,d2 cmp.w #$302,d2 bne bp ; must be float array cmp.w #1,$c(a6,a4.l) bne ni cmp.w #2,4(a6,a4.l) bne bp ; must be 2 dimensions move.w 6(a6,a4.l),d5 ; side length cmp.w $a(a6,a4.l),d5 bne bp ; must be square moveq #0,d0 rts inv4 sub.l d0,a0 bra invnext matinv move.w #0,d7 ; code for inversion sub.l a3,a5 cmp.l #$10,a5 bne bp ; must be two parameters bsr twoarr ; establish array parameters bne bp ; oops addq #8,a3 ; check source ... bsr.s sqrmat ; ... for squareness bne bp ; oops move.l a2,a4 ; rename destination array base bra.s invdet nf moveq #err_nf,d0 rts detold lea detlast,a5 ; load table tst.b 1(a5) ; any inversion this session? beq nf ; no: report not found bsr chrix ; yes; reserve RI stack space subq #6,a1 ; push ... move.w 2(a5),0(a6,a1.l); ... saved determinant value move.l 4(a5),2(a6,a1.l) bra retnflt ; return it detlast dc.l 0 ; 8-byte table for ... dc.l 0 ; ... DET without argument det move.w #1,d7 ; code for determinant cmp.l a3,a5 beq.s detold ; special case: no argument sub.l a3,a5 cmp.l #8,a5 bne bp ; must be one parameter bsr loct ; establish array parameters bne bp bsr sqrmat ; check for squareness bne bp ; oops invdet addq #1,d5 ; allow for subscript 0 bsr chrix ; room for 3 floats on RI stack move.l a1,-(a7) moveq #mt_alchp,d0 ; reserve space on common heap move.l d6,d1 ; number of elements asl.l #2,d1 ; * 2 * 6 move.l d1,d4 asl.l #1,d4 add.l d4,d1 move.l d1,d4 ; copy moveq #-1,d2 ; for myself add.l d5,d1 ; + no. of bytes in flag array add.l #$10,d1 ; for temporary values trap #1 move.l (a7)+,a1 tst.b d0 ; no can do? bne invom add.l #$10,a0 ; top of auxiliary values ... add.l d4,a0 add.l d5,a0 ; top of flag array move.w d5,d3 subq #1,d3 ; initialise flag loop variable invflaglp move.b #0,-(a0) ; clear flag array dbra d3,invflaglp ; a0 = flag base = scratch top move.l a0,a2 ; copy asr.l #1,d4 ; compute pointer to ... add.l d4,a5 ; top of source array move.w d5,d3 subq #1,d3 ; initialise row loop variable invblp move.w d5,d4 subq #1,d4 ; initialise column loop var. invidnlp subq #6,a0 ; update pointer move.l #0,(a0) ; 0 in R/H half of scratch arr. cmp.l d3,d4 bne.s inv9 ; except in diagonal, ... move.l #$8014000,(a0) ; ... where we put 1 inv9 move.w #0,4(a0) dbra d4,invidnlp ; next column move.w d5,d4 subq #1,d4 ; initialise column loop var. invcopylp subq #6,a0 ; update pointers subq #6,a5 move.w 0(a6,a5.l),(a0) ; copy from source array ... move.l 2(a6,a5.l),2(a0); ... to scratch array dbra d4,invcopylp ; next column dbra d3,invblp ; next row move.w d7,-8(a0) ; copy det/inv code move.w d5,-$a(a0) ; number of outer-loop passes subq #6,a1 ; prepare arithmetic stack ... move.w ri_exec,a3 ; ... and RI operations move.l #$8014000,-$10(a0) ; initialise determinant = 1 move.w #0,-$c(a0) invdegreelp moveq #0,d1 ; initialise maximum = 0 moveq.l #0,d2 move.w d5,d3 ; initialise row loop variable subq #1,d3 move.l a2,a0 ; restore scratch pointer top invcmplp1 move.w d5,d0 mulu #6,d0 ; compute 6 * n bytes sub.l d0,a0 ; pointer to top of L/H half tst.b 0(a2,d3.w) ; current row of flag arr. set? bne inv4 move.w d5,d4 subq #1,d4 ; initialise column loop var. invcmplp2 subq #6,a0 ; update pointer move.w d1,0(a6,a1.l) ; old maximum on RI stack move.l d2,2(a6,a1.l) moveq #ri_abs,d0 ; absolute value jsr (a3) subq #6,a1 ; push ... move.w (a0),0(a6,a1.l) ; ... new element move.l 2(a0),2(a6,a1.l) moveq #ri_abs,d0 ; absolute value jsr (a3) moveq #ri_sub,d0 jsr (a3) ; compute difference btst #7,2(a6,a1.l) ; do the following only if ... beq.s inv8 ; ... |element| > |max| move.w (a0),d1 ; store new maximum, ... move.l 2(a0),d2 move.w d3,d6 ; ... current row, ... move.l d4,d7 ; ... and current column inv8 dbra d4,invcmplp2 ; next column invnext dbra d3,invcmplp1 ; next row tst.l d2 ; is maximum 0? bne.s inv2 ; no, OK tst.b -7(a0) ; yes, then ... beq detov ; ... inversion is impossible moveq #0,d0 ; and determinant ... bra retnflt ; ... is zero inv2 move.b #1,0(a2,d6.l) ; set 'used' flag for row move.w d6,d0 ; compute pointer for ... mulu d5,d0 asl.l #1,d0 add.l d7,d0 asl.l #1,d0 move.w d0,d1 asl.l #1,d1 add.l d1,d0 ; pivot move.w 0(a0,d0.l),-6(a0) ; store pivot move.l 2(a0,d0.l),-4(a0) move.w -$10(a0),0(a6,a1.l) ; put determinant on stack move.l -$e(a0),2(a6,a1.l) subq #6,a1 ; push ... move.w -6(a0),0(a6,a1.l) ; ... pivot move.l -4(a0),2(a6,a1.l) moveq #ri_mult,d0 ; multiply ... jsr (a3) ; ... to yield new determinant bne invov move.w 0(a6,a1.l),-$10(a0) ; store it move.l 2(a6,a1.l),-$e(a0) move.l d6,d1 ; compute pointer offset ... addq #1,d1 mulu d5,d1 asl.l #2,d1 move.l d1,d0 asl.l #1,d0 add.l d0,d1 ; ... beyond end of current row moveq.l #0,d4 ; initialise column loop var... move.w d5,d4 asl.l #1,d4 subq #1,d4 ; ... for pivot row invpivlp subq #6,d1 ; update pointer move.w 0(a0,d1.l),0(a6,a1.l) ; put element on RI stack move.l 2(a0,d1.l),2(a6,a1.l) subq #6,a1 ; push ... move.w -6(a0),0(a6,a1.l) ; ... pivot as divisor move.l -4(a0),2(a6,a1.l) moveq #ri_div,d0 jsr (a3) ; divide bne ov move.w 0(a6,a1.l),0(a0,d1.l) ; overwrite old element move.l 2(a6,a1.l),2(a0,d1.l) dbra d4,invpivlp ; next column move.w d5,d3 ; initialise row loop variable subq #1,d3 invgenlp1 cmp.w d3,d6 beq invnext1 ; skip pivot row move.w d3,d1 ; compute pointer to ... mulu d5,d1 ; ... element of current row .. asl.l #1,d1 add.w d7,d1 ; in pivot column asl.l #1,d1 move.l d1,d0 asl.l #1,d0 add.l d0,d1 move.w 0(a0,d1.l),-6(a0) ; call it auxiliary value move.l 2(a0,d1.l),-4(a0) move.w d5,d4 asl.l #1,d4 subq.l #1,d4 ; initialise column loop var. move.w d3,d1 ; compute pointer to ... addq #1,d1 mulu d5,d1 asl.l #2,d1 move.l d1,d0 asl.l #1,d0 add.l d0,d1 ; ... end of current row move.w d6,d2 ; compute pointer to ... addq #1,d2 mulu d5,d2 asl.l #2,d2 move.l d2,d0 asl.l #1,d0 add.l d0,d2 ; ... end of pivot row invgenlp2 subq #6,d1 ; update pointers subq #6,d2 move.w 0(a0,d1.l),0(a6,a1.l) ; current elem. on stack move.l 2(a0,d1.l),2(a6,a1.l) subq #6,a1 ; push ... move.w 0(a0,d2.l),0(a6,a1.l) ; ... pivot row element move.l 2(a0,d2.l),2(a6,a1.l) subq #6,a1 ; push ... move.w -6(a0),0(a6,a1.l) ; auxiliary value move.l -4(a0),2(a6,a1.l) moveq #ri_mult,d0 ; compute ... jsr (a3) bne invov ; oops moveq #ri_sub,d0 jsr (a3) ; .. new value of current elem. bne invov ; oops move.w 0(a6,a1.l),0(a0,d1.l) ; overwrite move.l 2(a6,a1.l),2(a0,d1.l) dbra d4,invgenlp2 ; next column invnext1 dbra d3,invgenlp1 ; next row subq #1,-$a(a0) bne invdegreelp ; next outer loop tst.b -$7(a0) ; is it DET or MATINV? beq.s inv7 move.w -$10(a0),0(a6,a1.l) ; put determinant on stack move.l -$e(a0),2(a6,a1.l) moveq #mt_rechp,d0 ; release reserved space sub.l #$10,a0 ; restore original address move.l a1,-(a7) trap #1 move.l (a7)+,a1 moveq #0,d0 ; no error bra retnflt ; return as float value detov lea detlast,a5 ; store 0 ... move.b #1,1(a5) move.w #0,2(a5) ; for next call of DET move.l #0,4(a5) invov add.l #$10,a0 ; restore original address moveq #mt_rechp,d0 ; release reserved space trap #1 moveq #err_ov,d0 ; report overflow rts invom add.l #$10,a0 ; restore original address moveq #mt_rechp,d0 ; release reserved space trap #1 moveq #err_om,d0 ; report out of memory rts inv7 move.l a4,-4(a0) ; save destination pointer move.w d5,d3 subq #1,d3 ; initialise row loop variable invwritelp move.w d3,d0 ; compute pointer ... mulu d5,d0 asl.l #2,d0 move.l d0,d1 asl.l #1,d1 add.l d1,d0 ; ... to start of current row move.w d5,d4 subq #1,d4 ; initialise column loop var. move.w d4,d6 ; copy max. subscript invwritelp1 cmp.w #$800,0(a0,d0.l); is element >.5? (should be 1) blt.s inv6 sub.w d4,d6 ; yes: set to dest. array row bra.s inv5 inv6 addq.l #6,d0 ; no: update pointer dbra d4,invwritelp1 ; next column moveq #err_or,d0 ; no 1 detected, must be a bug rts inv5 move.w d3,d0 ; compute pointer to ... addq #1,d0 mulu d5,d0 asl.l #2,d0 move.l d0,d1 asl.l #1,d1 add.l d1,d0 ; R/H half of scratch array row move.w d6,d2 ; compute pointer to ... addq #1,d2 mulu d5,d2 asl.l #1,d2 move.l d2,d1 asl.l #1,d1 add.l d1,d2 ; ... row in destination array move.w d5,d4 subq #1,d4 ; initialise column loop var. invwritelp2 subq #6,d0 ; update pointers subq #6,d2 move.l -4(a0),a4 ; restore destination pointer add.l d2,a4 move.w 0(a0,d0.l),0(a6,a4.l) ; transfer to dest. array move.l 2(a0,d0.l),2(a6,a4.l) dbra d4,invwritelp2 ; next column dbra d3,invwritelp ; next row lea detlast,a5 ; store determinant ... move.b #1,1(a5) ; ... for next call of DET move.w -$10(a0),2(a5) move.l -$e(a0),4(a5) moveq #mt_rechp,d0 ; release reserved space sub.l #$10,a0 ; restore original address move.l a1,-(a7) trap #1 move.l (a7)+,a1 moveq #0,d0 ; no error rts matmult move.l a3,-(a7) bsr chrix move.l (a7)+,a3 sub.w a3,a5 ; must be 3 parameters cmp.w #$18,a5 bne bp moveq #2,d4 mmlp0 move.w 0(a6,a3.l),d3 and.b #$f,d3 ; ignore separators cmp.w #$302,d3 ; all float arrays bne bp addq #8,a3 dbra d4,mmlp0 move.l bv_vvbas(a6),a2 ; establish descriptor bases move.l a2,a4 move.l a2,a5 add.l -4(a6,a3.l),a4 ; second source add.l -$c(a6,a3.l),a2 ; first source add.l -$14(a6,a3.l),a5; target cmp.w #2,4(a6,a2.l) ; number of dimensions bgt bp ; only 1 or 2 allowed beq mm2xy cmp.w #2,4(a6,a4.l) ; 1xy bgt bp beq mm12y cmp.w #2,4(a6,a5.l) ; 11y bgt bp beq mm112 move.w 6(a6,a2.l),d2 ; 111 move.w 6(a6,a4.l),d4 move.w 6(a6,a5.l),d5 bne.s mm111a cmp.w d2,d4 ; m m 0 -> 0 m 0 bne or clr.w d2 bra mmyes mm111a tst.w 8(a6,a4.l) ; k 0 k -> k 0 0 bne.s mm111b cmp.w d2,d5 bne or clr.w d5 bra mmyes mm111b tst.w 6(a6,a2.l) ; 0 n n -> 0 0 n bne or cmp.w d4,d5 bne or clr.w d3 bra mmyes mm112 move.w 6(a6,a2.l),d2 move.w 6(a6,a4.l),d4 move.w $a(a6,a5.l),d5 bne.s mm112a tst.w 6(a6,a4.l) ; m m 00 -> 0 m 0 bne or cmp.w d2,d4 bne or clr.w d2 bra mmyes mm112a cmp.w d4,d5 ; k n kn -> k 0 n bne or cmp.w 6(a6,a5.l),d2 bne or clr.w d4 bra mmyes mm12y cmp.w #2,4(a6,a5.l) bgt bp beq.s mm122 move.w 6(a6,a2.l),d2 ; 121 move.w 6(a6,a5.l),d5 move.w 6(a6,a4.l),d4 bne.s mm121a tst.w $a(a6,a4.l) ; k 00 k -> k 0 0 bne or cmp.w d2,d5 bne or clr.w d5 bra mmyes mm121a cmp.w d2,d4 ; m mn n -> 0 m n bne or cmp.w $a(a6,a4.l),d5 bne or clr.w d2 bra mmyes mm122 move.w 6(a6,a2.l),d2 move.w $a(a6,a5.l),d5 move.w 6(a6,a4.l),d4 bne.s mm122a cmp.w $6(a6,a5.l),d2 ; k 0n kn -> k 0 n bne or cmp.w $a(a6,a4.l),d5 bne or bra mmyes mm122a tst.w 6(a6,a5.l) ; m mn 0n -> 0 m n bne or cmp.w d2,d4 bne or cmp.w $a(a6,a4.l),d5 bne or clr.w d2 bra mmyes mm2xy cmp.w #2,4(a6,a4.l) bgt bp beq mm22y cmp.w #2,4(a6,a5.l) ; 21y bgt bp beq mm212 move.w 6(a6,a4.l),d4 ; 211 move.w 6(a6,a5.l),d5 move.w 6(a6,a2.l),d2 bne.s mm211a tst.w $a(a6,a2.l) ; 00 n n -> 0 0 n bne or cmp.w d4,d5 bne or clr.w d4 bra mmyes mm211a cmp.w d2,d5 ; km m k -> k m 0 bne or cmp.w $a(a6,a2.l),d4 bne or clr.w d5 bra mmyes mm212 move.w 6(a6,a2.l),d2 move.w 6(a6,a4.l),d4 move.w $a(a6,a5.l),d5 bne.s mm212a cmp.w 6(a6,a5.l),d2 ; km m k0 -> k m 0 bne or cmp.w $a(a6,a2.l),d4 bne or clr.w d5 bra mmyes mm212a tst.w 6(a6,a2.l) ; k0 n kn -> k 0 n bne or cmp.w 6(a6,a5.l),d2 bne or cmp.w d4,d5 bne or clr.w d4 bra.s mmyes mm22y cmp.w #2,4(a6,a5.l) bgt bp beq mm222 move.w 6(a6,a4.l),d4 ; 221 move.w 6(a6,a5.l),d5 move.w 6(a6,a2.l),d2 bne.s mm221a cmp.w $a(a6,a2.l),d4 ; 0m mn n -> 0 m n bne or cmp.w $a(a6,a4.l),d5 bne or bra.s mmyes mm221a tst.w $a(a6,a4.l) ; km m0 k -> k m 0 bne or cmp.w d2,d5 bne or cmp.w $a(a6,a2.l),d4 bne or clr.w d5 bra.s mmyes mm222 move.w 6(a6,a2.l),d2 ; km mn kn -> k m n move.w 6(a6,a4.l),d4 move.w $a(a6,a5.l),d5 cmp.w 6(a6,a5.l),d2 bne bp cmp.w $a(a6,a2.l),d4 bne bp cmp.w $a(a6,a4.l),d5 bne bp mmyes cmp.w #1,4(a6,a2.l) ; check '1' beq.s mmchk1 cmp.w #1,$c(a6,a2.l) bne ni move.w $a(a6,a2.l),d7 addq #1,d7 cmp.w 8(a6,a2.l),d7 bne ni mmchk1 cmp.w #1,4(a6,a4.l) ; check '2' beq.s mmchk2 cmp.w #1,$c(a6,a4.l) bne ni move.w $a(a6,a4.l),d7 addq #1,d7 cmp.w 8(a6,a4.l),d7 bne ni mmchk2 cmp.w #1,4(a6,a5.l) ; check '3' beq.s mmchk3 cmp.w #1,$c(a6,a5.l) bne ni move.w $a(a6,a5.l),d7 addq #1,d7 cmp.w 8(a6,a5.l),d7 bne ni mmchk3 move.l bv_vvbas(a6),a3 ; convert descriptor bases ... move.l 0(a6,a2.l),a2 add.l a3,a2 ; ... into array bases move.l 0(a6,a4.l),a4 add.l a3,a4 move.l 0(a6,a5.l),a5 add.l a3,a5 sub.l #6,a1 ; room for 1 float on RI st move.w d5,d7 ; compute 3 aux. multipliers addq #1,d7 move.w d4,d1 addq #1,d1 move.w d1,d6 mulu d7,d6 asl.l #1,d1 asl.l #1,d6 asl.l #1,d7 move.l d1,d3 asl.l #1,d3 add.l d3,d1 ; 6*(d4+1) move.l d6,d3 asl.l #1,d3 add.l d3,d6 ; 6*(d2+1)*(d5+1) move.l d7,d3 asl.l #1,d3 add.l d3,d7 ; 6*(d5+1) move.w ri_exec,a3 ; prepare RI operations clr d3 ; target array is separate movem.w d2/d4/d5,-(a7) ; save registers cmp.l a2,a5 ; target array = 1st source? beq.s mm9 cmp.l a4,a5 ; target array = 2nd source? bne.s mmklp mm9 moveq #1,d3 ; flag for same arrays movem.l d1/d2/d3/d5/a1/a2/a3,-(a7) ; save registers moveq #mt_alchp,d0 ; reserve space on common heap move.l d6,d1 ; number of bytes moveq #-1,d2 ; for myself trap #1 movem.l (a7)+,d1/d2/d3/d5/a1/a2/a3 ; restore registers tst d0 bne mmom ; oops mmklp mmnlp clr.w $0(a6,a1.l) ; clear summation variable clr.l $2(a6,a1.l) mmmlp sub.l #$c,a1 ; room for 2 more floats move.w 0(a6,a2.l),0(a6,a1.l) ; put on source 1 elem. move.l 2(a6,a2.l),2(a6,a1.l) move.w 0(a6,a4.l),6(a6,a1.l) ; and source 2 element move.l 2(a6,a4.l),8(a6,a1.l) moveq #ri_mult,d0 jsr (a3) ; multiply elements bne mmov ; oops moveq #ri_add,d0 jsr (a3) ; and add into summation var. bne.s mmov ; oops addq #6,a2 ; update pointers add.l d7,a4 dbra d4,mmmlp ; next pair of elements tst.b d3 bne.s mm6 move.w $0(a6,a1.l),0(a6,a5.l) ; write result move.l $2(a6,a1.l),2(a6,a5.l) bra.s mm5 mm6 move.w $0(a6,a1.l),(a0)+ move.l $2(a6,a1.l),(a0)+ mm5 sub.l d1,a2 ; adjust pointers sub.l d6,a4 addq #6,a4 addq #6,a5 move.w 2(a7),d4 ; restore loop variable dbra d5,mmnlp ; next column of source 2 sub.l d7,a4 ; update pointers add.l d1,a2 move.w 4(a7),d5 ; restore loop variable dbra d2,mmklp tst.b d3 beq.s mm7 ; following: for equal arrays move.w (a7),d3 ; old d2 addq #1,d3 add.w #1,4(a7) ; old d5 mulu 4(a7),d3 ; no. of elems in target array mmretnlp subq #6,a5 ; go back one element subq #6,a0 move.w (a0),0(a6,a5.l) ; copy one element move.l 2(a0),2(a6,a5.l) subq.l #1,d3 ; no dbra for long integer bne.s mmretnlp ; next element mmrechp moveq #mt_rechp,d0 ; release reserved space trap #1 mm7 moveq #0,d0 ; no error mmend addq.l #6,a7 ; clean up user stack rts mmom moveq #err_om,d0 ; report out of memory bra.s mmend mmov moveq #err_ov,d0 ; report overflow tst.b d3 ; was space reserved? beq.s mmend bra.s mmrechp mminplace moveq #0,d0 ; provisional rts minputstk sub.l d5,a1 ; push element move.w 0(a6,a5.l),0(a6,a1.l) cmp.b #6,d5 beq minputstk2 moveq #ri_float,d0 ; if integer, float it ... jsr (a2) bra.s minx minputstk2 move.l 2(a6,a5.l),2(a6,a1.l) ; else put on mantissa minx rts matmin moveq #1,d7 ; flag for minimum bra.s max9 matmax moveq #0,d7 ; flag for maximum max9 bsr onepara ; needs one parameter bsr loct ; establish array parameters cmp.b #$a,d5 ; is it a string? bge bp ; yes, error bsr chrix ; save space for RI stack move.w ri_exec,a2 ; prepare RI operations bsr.s minputstk ; put element on RI stack subq #1,d6 ; adjust loop variable beq retnflt ; just one element; return it minlp move.w 0(a6,a1.l),d1 ; save top of stack move.l 2(a6,a1.l),d2 add.l d5,a5 ; pointer to next element bsr.s minputstk ; put element on RI stack move.w 0(a6,a1.l),d3 ; save new top of stack move.l 2(a6,a1.l),d4 moveq #ri_sub,d0 ; subtract jsr (a2) moveq #0,d0 ; no error tst.b d7 ; is it max or min? bne.s max5 tas.b 2(a6,a1.l) ; test sign of difference blt.s amax bra.s max4 max5 tas.b 2(a6,a1.l) bgt.s amax max4 move.w d1,0(a6,a1.l) ; restore NOS ... move.l d2,2(a6,a1.l) bra.s maxy amax move.w d3,0(a6,a1.l) ; ... or TOS move.l d4,2(a6,a1.l) maxy subq.l #1,d6 ; no dbra for long integer bne.s minlp ; next element bra retnflt ; return as float rts ctrts rts matcount move.b #0,d7 ; code for 'equal' bra.s ct9 matcount1 move.b #1,d7 ; code for 'nearly equal' ct9 add.l #$10,a3 cmp.l a3,a5 bne bp ; must be two parameters bsr chrix ; reserve space on RI stack move.l a5,a3 ; restore pointers sub.l #$10,a3 cmp.b #3,0(a6,a3.l) ; 1st parameter must be array bne bp move.b 8(a6,a3.l),d3 ; supertype of 2nd parameter: cmp.b #3,d3 ; an array? beq ctarr cmp.b #2,d3 ; a variable or expression? beq.s ctscal cmp.b #6,d3 ; a loop variable? beq.s ctscal cmp.b #7,d3 bne bp ; none of these; error ctscal bsr loct ; establish array parameters bne bp ; oops movem.l d6/a5,-(a7) ; because of gt routine clr.l d4 ; initialise counter addq #8,a3 ; treat scalar (2nd) parameter move.l a3,a5 addq.l #8,a5 ; restore upper pointer asl.w #1,d3 ; convert type ... neg.w d3 add.w #$118,d3 ; ... 3,2,1 -> $112,$114,$116 move.w d3,a2 move.w (a2),a2 jsr (a2) ; place argument on RI stack movem.l (a7)+,d6/a5 ; restore loop var., array base bne ctrts ; oops cmp.w #2,d3 ; distinguish types: blt ctscalstr ; a string beq.s ctscalflt ; a floating point move.w 0(a6,a1.l),d1 ; duplicate constant ctscalintlp cmp.w 0(a6,a5.l),d1 ; match? bne.s ctscalint9 ; no, do not ... addq.l #1, d4 ; ... increment counter ctscalint9 addq.l #2,a5 ; update pointer subq.l #1,d6 ; no dbra for long integer bne.s ctscalintlp ; next element subq #4,a1 ; from integer to float bra.s ctretnctr nearequal move.w d1,0(a6,a1.l) ; restore onto RI stack (y, x) move.l d2,2(a6,a1.l) moveq #ri_sub,d0 jsr (a2) ; y-x moveq #ri_abs,d0 jsr (a2) ; |y-x| tst.b 2(a6,a1.l) ; zero difference? beq.s nearequal9 ; match tst.b d7 ; exact equality required? beq.s nearequal8 ; no match subq #6,a1 ; push copied value move.w d1,0(a6,a1.l) move.l d2,2(a6,a1.l) ; y, |y-x| subq #6,a1 ; push c = 1e-7 move.w #$7e9,0(a6,a1.l) move.l #$6b5fca6b,2(a6,a1.l) ; c,y,|y-x| moveq #ri_mult,d0 jsr (a2) ; c*y,|y-x| moveq #ri_abs,d0 jsr (a2) ; |c*y|,|y-x| moveq #ri_sub,d0 jsr (a2) ; |c*y|-|y-x| tas 2(a6,a1.l) ; test sign of difference bge.s nearequal8 ; positive, no match nearequal9 addq.l #1,d4 ; match; increment counter nearequal8 addq.l #6,a5 ; update pointer subq #1,d6 ; no dbra for long integer rts ctscalflt move.w ri_exec,a2 ; prepare for RI operations move.w 0(a6,a1.l),-(a7); save constant move.l 2(a6,a1.l),-(a7) ctscalfltlp move.w 4(a7),d1 ; copy constant move.l (a7),d2 move.w 0(a6,a5.l),0(a6,a1.l) ; put array element ... move.l 2(a6,a5.l),2(a6,a1.l) ; ... on RI stack subq #6,a1 ; push next element bsr.s nearequal ; check for match bne.s ctscalfltlp ; next element addq #6,a7 ; remove constant addq #6,a1 ; from 2 floats to 1 float ctretnctr move.w #0,0(a6,a1.l) ; initialise with zero move.l d4,2(a6,a1.l) ; put mantissa on RI stack beq.s ct7 ; if zero, return 0 move.w #$81f,0(a6,a1.l); initialise exponent ctlp btst.l #$1e,d4 ; normalised yet? bne.s ct7 ; yes, done asl.l #1,d4 ; no, double mantissa ... sub.w #1,0(a6,a1.l) ; ... and reduce exponent bra.s ctlp ; try again ct7 move.l d4,2(a6,a1.l) ; put normalised value on bra retnflt ; and return it as float size subq #8,a5 cmp.w a3,a5 ; must be one parameter bne bp move.l a3,-(a7) bsr chrix ; reserve space on RI stack move.l (a7)+,a3 subq #6,a1 ; ... for 1 float number moveq #0,d4 ; will be function value move.b 0(a6,a3.l),d3 ; supertype beq.s ctretnctr ; 0 for unset variable moveq #1,d4 ; provisionally 1 cmp.b #3,d3 ; is it an array? bne.s size9 move.l 4(a6,a3.l),a4 add.l bv_vvbas(a6),a4 ; array descriptor base move.b 1(a6,a3.l),d3 ; type and.b #$f,d3 ; mask out separator move.w 4(a6,a4.l),d2 ; number of dimensions cmp.w #2,d3 ; if string array, ... bge.s size8 subq #1,d2 ; ignore length dimension size8 subq #1,d2 ; adjust and ... move.w d2,d1 ; ... copy as loop variable asl.w #2,d2 ; compute pointer addq #6,d2 add.l d2,a4 sizelp move.w 0(a6,a4.l),d5 ; current max. subscript addq #1,d5 ; allow for subscript 0 mulu d5,d4 ; multiply into function value subq #4,a4 dbra d1,sizelp ; next subscript bra ctretnctr ; normalize and return float size9 cmp.b #2,d3 beq ctretnctr ; variable or expression cmp.b #6,d3 beq ctretnctr ; loop variables cmp.b #7,d3 beq ctretnctr bra bp ctscalstr move.l a5,a0 ; base for ut_cstr move.w 0(a6,a1.l),d3 ; scalar string length ctscalstr5 move.w ut_cstr,a2 ; prepare string comparison ctscalstrlp move.b d7,d0 ; string comparison type jsr (a2) bne.s ctscalstr9 ; no ... addq.l #1,d4 ; ... match ctscalstr9 add.l d5,a0 ; update pointer subq #1,d6 ; no dbra for long integer bne.s ctscalstrlp ; next element ctscalstr8 add.l d5,a1 ; from string ... subq #6,a1 ; ... to float moveq #0,d0 ; no error bra ctretnctr ; return counter ctarr bsr twoarr ; establish array parameters clr.l d4 ; initialise counter move.l a2,a0 ; rename 2nd descriptor base cmp.b #2,d3 ; array type? blt.s ctarrstr ; string beq.s ctarrflt ; float ctarrintlp move.w 0(a6,a5.l),d3 ; element of array 1 cmp.w 0(a6,a0.l),d3 ; and of array 2 bne.s ctarrint9 ; no ... addq #1,d4 ; ... match ctarrint9 addq.l #2,a0 ; update pointers addq.l #2,a5 subq.l #1,d6 ; no dbra for long integer bne.s ctarrintlp ctoneflt sub.l d5,a1 ; room for one floating point bra ctretnctr ; return counter ctarrflt move.w ri_exec,a2 ; prepare for RI operations subq #6,a1 ; push array 1 element ctarrfltlp move.w 0(a6,a5.l),0(a6,a1.l) move.l 2(a6,a5.l),2(a6,a1.l) subq #6,a1 ; and array 2 element move.w 0(a6,a0.l),d1 move.l 2(a6,a0.l),d2 bsr nearequal ; check for match addq.l #6,a0 ; update pointer tst.l d6 ; done? bne.s ctarrfltlp ; no, next element bra.s ctoneflt ctarrstr move.l a1,-(a7) ; save RI stack pointer move.l a5,a1 ; needed for ut_cstr move.w ut_cstr,a2 ctarrstrlp move.b d7,d0 ; string comparison type jsr (a2) bne.s ctarrstr9 ; no ... addq.l #1,d4 ; ... match ctarrstr9 add.l d5,a0 ; update pointers add.l d5,a1 subq.l #1,d6 ; no dbra for long integer bne.s ctarrstrlp ; next element move.l (a7)+,a1 ; restore RI stack pointer moveq #0,d0 ; no error bra.s ctoneflt matstart bsr onepara ; just one parameter bne.s startrts ; oops bsr loct ; establish array parameters bne.s startrts ; oops move.l a3,a5 ; re-establish a5 at ... addq.l #8,a5 ; ... a3+8 cmp.b #1,d3 ; is it a string array? beq.s startend ; no move.b #2,0(a6,a3.l) ; variable, not array move.l 0(a6,a4.l),4(a6,a3.l) ; address of element startend move.l bv_ntbas(a6),a0 ; base of name table moveq #0,d0 startrts rts matinput bsr.s matstart bne.s matinputrts inputlp1 move.l bv_nlbas(a6),a2 ; start of namelist add.w 2(a6,a0.l),a2 cmp.b #5,0(a6,a2.l) ; five-letter name? bne.s inputnext ; no cmp.b #$49,1(a6,a2.l) ; I bne.s inputnext cmp.b #$4e,2(a6,a2.l) ; N bne.s inputnext cmp.b #$50,3(a6,a2.l) ; P bne.s inputnext cmp.b #$55,4(a6,a2.l) ; U bne.s inputnext cmp.b #$54,5(a6,a2.l) ; T beq.s readfound ; a0 is name table entry INPUT inputnext addq #8,a0 ; next name table entry bra.s inputlp1 ; and loop matinputrts rts matread bsr matstart bne.s matreadrts1 readlp1 move.l bv_nlbas(a6),a2 ; start of namelist add.w 2(a6,a0.l),a2 cmp.b #4,0(a6,a2.l) ; four-letter name? bne.s readnext ; no cmp.b #$52,1(a6,a2.l) ; R bne.s readnext cmp.b #$45,2(a6,a2.l) ; E bne.s readnext cmp.b #$41,3(a6,a2.l) ; A bne.s readnext cmp.b #$44,4(a6,a2.l) ; D beq.s readfound ; a0 is name table entry READ readnext addq #8,a0 ; next name table entry bra.s readlp1 ; and loop readfound move.l 0(a6,a4.l),4(a6,a3.l) ; address of element readx move.l 4(a6,a0.l),a0 ; address of found procedure readlp2 movem.l d3/d4/d5/a0/a3/a4,-(a7) ; save registers jsr (a0) ; do selected routine movem.l (a7)+,d3/d4/d5/a0/a3/a4 ; restore registers bne matreadrts1 ; error in READ / INPUT cmp.b #1,d3 ; is it numeric? beq.s ready add.l d5,4(a6,a3.l) ; update pointer in name table bra.s readz ; ready add.l d5,0(a6,a4.l) ; update pointer in descriptor readz subq #1,d6 ; no dbra for long integer bne.s readlp2 ; loop move.w #0,d0 ; no error matreadrts1 rts matpoint_r moveq #7,d7 ; code for 'relative' bra.s point9 matpoint moveq #5,d7 ; code for 'absolute' point9 bsr onepara ; need one parameter bne.s matreadrts1 ; oops bsr loct ; establish array parameters bne.s matreadrts1 ; oops cmp.b #6,d5 ; must be float bne bp cmp.w #2,d4 ; 2 dimensions required ... bne bp cmp.w #2,8(a6,a4.l) ; ... and 2 columns bne or move.l bv_ntbas(a6),a0 ; base of name table ... move.w 0(a6,a3.l),d4 ; determine input separator ... asr.w #4,d4 ; ... by shifting ... and.w #7,d4 ; ... and masking cmp.b #2,d4 ; only none, comma, semicolon bgt bp ; ... permitted, ... blt.s line6 ; but semicolon not ... cmp.b #7,d7 ; ... if MATPLOT_R beq bp line6 tst.b d4 ; no separator? beq pointlp1 ; then unconnected points subq #1,d7 ; 'LINE' shorter than 'POINT' linelp1 move.l bv_nlbas(a6),a2 ; base of namelist add.w 2(a6,a0.l),a2 ; add pointer from name table cmp.b 0(a6,a2.l),d7 ; keyword of correct length? bne.s linenext ; no cmp.b #$4c,1(a6,a2.l) ; L bne.s linenext cmp.b #$49,2(a6,a2.l) ; I bne.s linenext cmp.b #$4e,3(a6,a2.l) ; N bne.s linenext cmp.b #$45,4(a6,a2.l) ; E bne.s linenext cmp.b #4,d7 ; is it absolute? beq.s linefound ; yes cmp.b #$5f,5(a6,a2.l) ; no, check underscore bne.s linenext cmp.b #$52,6(a6,a2.l) ; R beq.s linefound linenext addq #8,a0 ; next name table entry bra.s linelp1 ; and loop linefound move.l a3,a5 ; set a5 ... add.l #$18,a5 ; ... 3 * 8 bytes above a3 move.l 0(a6,a3.l),8(a6,a3.l) ; move 1st to 2nd ... clr.l 0(a6,a3.l) ; because 1st needs 0 for LINE cmp.b #5,d7 ble.s line5 move.l #$500000,0(a6,a3.l) ; or 'TO' for LINE_R line5 clr.l 4(a6,a3.l) move.l 0(a6,a4.l),$c(a6,a3.l) ; addresss of 1st point move.l 8(a6,a3.l),$10(a6,a3.l) ; same header as 1st move.l $c(a6,a3.l),$14(a6,a3.l); but address must ... add.l #6,$14(a6,a3.l) ; ... be incremented move.l 4(a6,a0.l),a0 ; address of LINE procedure asr.l #1,d6 ; 2 elements per loop pass linelp2 movem.l d4/d5/d6/d7/a0/a3/a4,-(a7) ; store registers move.b #2,8(a6,a3.l) ; spurious variables move.b #2,$10(a6,a3.l) ; ('2' gets masked out by (a0)) jsr (a0) ; execute LINE(_R) routine movem.l (a7)+,d4/d5/d6/d7/a0/a3/a4 ; restore registers add.l #$c,$c(a6,a3.l) ; update pointers add.l #$c,$14(a6,a3.l) move.l #$500000,0(a6,a3.l) ; simulate 'TO' subq #1,d6 ; no dbra for long integer bne.s linelp2 ; next pair of elements cmp.b #1,d4 ; if input had comma, ... beq.s line8 ; we're done move.l 0(a6,a4.l),$c(a6,a3.l) ; restore coordinates move.l 0(a6,a4.l),$14(a6,a3.l) ; ... of first point add.l #6,$14(a6,a3.l) move.b #2,8(a6,a3.l) ; spurious variables move.b #2,$10(a6,a3.l) jsr (a0) line8 move.w #0,d0 ; no error rts pointlp1 move.l bv_nlbas(a6),a2 ; ... and of namelist add.w 2(a6,a0.l),a2 ; add pointer from name table cmp.b 0(a6,a2.l),d7 ; keyword of correct length? bne.s pointnext ; no cmp.b #$50,1(a6,a2.l) ; P bne.s pointnext cmp.b #$4f,2(a6,a2.l) ; O bne.s pointnext cmp.b #$49,3(a6,a2.l) ; I bne.s pointnext cmp.b #$4e,4(a6,a2.l) ; N bne.s pointnext cmp.b #$54,5(a6,a2.l) ; T bne.s pointnext cmp.b #5,d7 ; is it absolute? beq.s pointfound ; yes cmp.b #$5f,6(a6,a2.l) ; no, check underscore bne.s pointnext cmp.b #$52,7(a6,a2.l) ; R beq.s pointfound pointnext addq #8,a0 ; next name table entry bra.s pointlp1 ; and loop pointfound move.l a3,a5 ; upper pointer for 2 params addq #8,a5 addq #8,a5 move.l 0(a6,a4.l),4(a6,a3.l) ; address of 1st elemt move.l 0(a6,a3.l),8(a6,a3.l) ; 2nd element like 1st move.l 4(a6,a3.l),$c(a6,a3.l) add.l #6,$c(a6,a3.l) ; except pointer to next float move.l 4(a6,a0.l),a0 ; address of POINT procedure asr.l #1,d6 ; two elements per loop pass pointlp2 movem.l d5/d6/a0/a3/a4,-(a7) ; save registers move.b #2,0(a6,a3.l) ; spurious variables move.b #2,8(a6,a3.l) ; ('2' gets masked out by (a0)) jsr (a0) ; execute POINT(_R) routine movem.l (a7)+,d5/d6/a0/a3/a4 ; restore registers add.l #$c,4(a6,a3.l) ; update pointers add.l #$c,$c(a6,a3.l) subq #1,d6 ; no dbra for long integer bne.s pointlp2 ; next two elements move.w #0,d0 ; no error pointrts rts mattrn move.l a5,d1 sub.l a3,d1 cmp.w #$10,d1 ; must be two parameters bne bp cmp.b #3,0(a6,a3.l) bne bp cmp.b #3,8(a6,a3.l) bne bp ; both must be arrays move.b 1(a6,a3.l),d5 ; types of target array ... and.b #$f,d5 move.b 9(a6,a3.l),d3 ; ... and of source array ... and.b #$f,d3 ; (with separators masked out) beq ni ; (nix on string array slice) cmp.b d5,d3 ; ... must be equal bne bp moveq #2,d4 ; required no. of dimensions cmp.b #1,d3 bne.s trn4 moveq #3,d4 trn4 and.w #3,d4 ; convert into word asl.w #2,d5 sub.w #$e,d5 neg.w d5 move.l bv_vvbas(a6),a5 move.l a5,a2 move.l 4(a6,a3.l),a4 ; destination descriptor base move.l $c(a6,a3.l),a0 ; source descriptor base add.l a5,a4 add.l a2,a0 add.l 0(a6,a4.l),a5 ; destination array base add.l 0(a6,a0.l),a2 ; source array base cmp.w 4(a6,a4.l),d4 ; must have 2 or 3 dims. bne bp cmp.w 4(a6,a0.l),d4 bne bp cmp.b #1,d3 ; if string array, ... bne.s trn9 move.w $c(a6,a4.l),d5 ; ... correct element length trn9 move.l #0,d2 subq #1,d4 ; adjust loop variable move.w d4,d2 ; compute pointer asl.l #2,d2 add.l #4,d2 add.l d2,a4 add.l d2,a0 moveq #1,d6 ; initialise product moveq #1,d0 trnlp9 cmp.w 4(a6,a4.l),d6 ; must equal previous multiplr bne ni cmp.w 4(a6,a0.l),d0 ; .. on both arrays bne ni move.w 2(a6,a4.l),d2 ; current max. subscript addq #1,d2 ; (allow for subscript 0) cmp.b #2,d4 ; (on last dimension ...) bne.s trn00 cmp.b #1,d3 ; (... of string array ...) bne.s trn00 addq #1,d2 ; (... allow another byte) trn00 mulu d2,d6 ; multiply into product move.w 2(a6,a0.l),d2 ; same for other array addq #1,d2 cmp.b #2,d4 bne.s trn01 cmp.b #1,d3 bne.s trn01 addq #1,d2 trn01 mulu d2,d0 subq #4,a4 ; update pointers subq #4,a0 dbra d4,trnlp9 ; next subscript move.w 6(a6,a4.l),d2 ; subscripts must be ... cmp.w $a(a6,a0.l),d2 ; ... crosswise equal bne bp move.w 6(a6,a0.l),d1 cmp.w $a(a6,a4.l),d1 bne bp cmp.b #1,d3 ; if string array, ... bne.s trn6 divu d5,d6 ; .. correct number of elements trn6 asr.w #1,d5 ; element length in words tst.w d1 ; is either dimension one? beq trnsimple ; need but copy tst.w d2 beq trnsimple addq #1,d1 ; no. of dest. rows/source cols addq #1,d2 ; no. of source rows/dest. cols move.w #0,-(a7) ; set flag 0 ... cmp.l a2,a5 ; ... if 2 different arrays, .. bne.s trn1 move.w #1,(a7) ; ... but 1 if same array trn1 move.w d5,d4 ; copy words per element asl.w #1,d4 ; -> bytes per element subq #1,d4 ; adjust loop variable trnlp add.l d6,a5 ; move pointer to end of array dbra d4,trnlp subq #2,a5 ; and one word back subq #1,d6 ; adjust loop variable trnlp2 move.l a2,a4 ; copy source array base move.l d6,d7 ; compute target subscript divu d1,d7 ; div. by no. of source columns swap d7 move.w d7,d0 ; save remainder ... move.w d7,d3 ; ... twice mulu d2,d3 ; times number of source rows swap d7 add.w d7,d3 ; + remainder for target subscr add.w #1,d3 ; on to next subscript move.w d5,d4 ; copy no. of words per element asl.w #1,d4 ; -> no. of bytes per element mulu d4,d3 ; offset from target base subq #2,d3 ; now one word back add.l d3,a4 ; move pointer asr.w #1,d4 ; reconvert to words subq #1,d4 ; adjust loop variable tst.w (a7) ; test flag bne.s trn2 trnlp3 move.w 0(a6,a4.l),0(a6,a5.l) ; copy one word subq #2,a5 ; update pointers subq #2,a4 dbra d4,trnlp3 ; next word bra.s trn3 trn2 cmp.w d7,d0 ; var DIV side >= var MOD side? bge.s trnlp4 ; yes, forget this pass trnlp1 move.w 0(a6,a5.l),d7 ; no, exchange source & target move.w 0(a6,a4.l),0(a6,a5.l) move.w d7,0(a6,a4.l) subq #2,a5 ; update pointers subq #2,a4 dbra d4,trnlp1 ; next word bra.s trn3 trnlp4 subq #2,a5 ; update pointers only subq #2,a4 dbra d4,trnlp4 ; next word trn3 subq.l #1,d6 ; no dbra for long integer cmp.l #-1,d6 ; done? bgt.s trnlp2 ; no, next subscript addq #2,a7 ; clean up user stack moveq #0,d0 ; yes, no error rts trnsimple move.w d5,d4 ; copy # of words per element subq #1,d4 ; adjust loop variable trnlp0 move.w 0(a6,a2.l),0(a6,a5.l) ; copy one word addq #2,a2 ; update pointers addq #2,a5 dbra d4,trnlp0 ; next word subq #1,d6 ; no dbra for long integer bne.s trnsimple moveq #0,d0 ; no error rts matdev1 move.w #$30a,d4 ; std. deviation for sample bra.s sum8 matdev move.w #$20a,d4 ; std. deviation for population bra.s sum8 matmean move.w #$10a,d4 bra.s sum8 matprod moveq #ri_mult,d4 ; float multiplication bra.s sum8 matsum moveq #ri_add,d4 ; float addition sum8 bsr onepara ; need 1 parameter bne sumrts swap d4 ; loct uses d4 for no. of dims bsr loct ; establish array parameters bne sumrts ; not an array? swap d4 cmp.b #6,d5 bgt bp ; not numeric? bsr chrix ; need space on RI stack move.l a5,a4 ; duplicate array base for dev move.w ri_exec,a2 ; prepare RI package subq #6,a1 ; put on one float #: clr.w 0(a6,a1.l) ; either 0 ... clr.l 2(a6,a1.l) cmp.b #$a,d4 ; ... for sum ... beq.s sum7 move.w #$801,0(a6,a1.l) ; ... or 1 ... move.w #$4000,2(a6,a1.l) ; ... for product sum7 move.l d6,d7 ; save no. of elements .. move.l d6,d3 ; ... twice for dev sumlp sub.l d5,a1 ; prepare new TOS move.w 0(a6,a5.l),0(a6,a1.l) ; transfer 1 word cmp.b #6,d5 beq.s sumflt moveq #ri_float,d0 ; if integer, ... jsr (a2) ; ... must be converted bra.s sum9 sumflt move.l 2(a6,a5.l),2(a6,a1.l) ; else: 4 more bytes sum9 move.w d4,d0 ; add or multiply and.w #$ff,d0 ; mask out code for mean jsr (a2) bne sumrts ; overflow? add.w d5,a5 ; point to next element subq.l #1,d6 ; and loop bne.s sumlp ; (no dbra for long word) cmp.w #$10a,d4 ; code for mean blt retnflt bsr divlint ; which is in d7 as l.int. cmp.w #$20a,d4 ; check for dev/dev1 code blt retnflt move.w 0(a6,a1.l),d6 ; save mean move.l 2(a6,a1.l),d7 move.w #0,d1 ; initialise sum move.l #0,d2 swap d5 move.w d4,d5 ; pack code onto type swap d5 move.l d3,d4 ; save no. of elements again devlp sub.w d5,a1 ; element will go on stack move.w 0(a6,a4.l),0(a6,a1.l) cmp.b #6,d5 ; must it be floated? beq.s devflt moveq #ri_float,d0 ; if integer, yes jsr (a2) bra.s dev9 devflt move.l 2(a6,a4.l),2(a6,a1.l) ; else use mantissa dev9 moveq #ri_sub,d0 ; compute difference jsr (a2) bne ov ; overflow? moveq #ri_dup,d0 ; square difference jsr (a2) moveq #ri_mult,d0 jsr (a2) bne.s ov ; overflow? subq #6,a1 ; put old sum on stack move.w d1,0(a6,a1.l) move.l d2,2(a6,a1.l) moveq #ri_add,d0 ; update it jsr (a2) bne.s ov move.w 0(a6,a1.l),d1 ; and store it move.l 2(a6,a1.l),d2 move.w d6,0(a6,a1.l) ; put mean on stack again move.l d7,2(a6,a1.l) add.w d5,a4 ; update array pointer subq #1,d3 ; no dbra for long integer bne.s devlp move.w d1,0(a6,a1.l) ; now sum on stack move.l d2,2(a6,a1.l) move.l d4,d7 ; ... to where divlint wants it btst #24,d5 ; check for dev1 code beq.s devpop ; divide by n for population .. subq.l #1,d7 ; or by n-1 for sample ... devpop bsr.s divlint ; ... the long-integer way move.w #0,d7 ; old ROMs need it for sqrt, .. move.w #ri_sqrt,d0 ; ... which is computed last jsr (a2) bra retnflt ; return float # sumrts rts normal tst.l d7 bne.s normal9 move.w #0,0(a6,a1.l) ; if zero, return it bra.s normalend normal9 move.w #$81f,0(a6,a1.l); neutral exponent normallp btst.l #30,d7 ; mantissa normalised yet? bne.s normalend ; yes; skip asl.l #1,d7 ; no, double mantissa ... subq.w #1,0(a6,a1.l) ; and reduce exponent bra.s normallp ; next try normalend move.l d7,2(a6,a1.l) ; put mantissa on stack rts ; and return divlint subq #6,a1 ; make room for divisor bsr.s normal ; convert l.int. d7 to float moveq #ri_div,d0 ; and divide jsr (a2) moveq #0,d0 ; pos. divisor; no error rts ov moveq #err_ov,d0 ; overflow error rts matrnd cmp.l a3,a5 ; no parameters? ... beq bp ; ... impossible! addq #8,a3 ; ignore array for the moment move.w ca_gtint,a2 ; obtain integers jsr (a2) bne rndrts ; oops subq #8,a3 ; back to array swap d3 ; d3 corrupted by loct bsr loct ; obtain its parameters bne rndrts ; oops swap d3 cmp.b #6,d5 ; non-numeric? bgt bp ; too bad! move.w d6,d4 ; rearrange registers ... move.w d3,d6 ; so bv_chrix won't hurt bsr chrix ; reserve space on RI stack rndlp moveq #1,d7 ; obtain 'oddified' ... or.l bv_rand(a6),d7 ; ... last BASIC random # move.l d7,d3 ; save it mulu #$163,d7 ; multiply long word by 355 swap d3 mulu #$163,d3 swap d3 clr.w d3 ; zero is default first param. add.l d3,d7 ; that's the new random # move.l d7,bv_rand(a6) ; store it cmp.w #2,d6 ; more than two rnd params? bgt bp ; you must be joking! beq.s rndtwo ; two? cmp.w #1,d6 beq.s rndone ; one? cmp.b #2,d5 ; zero! beq intarr ; int array? use rnd # as is lsr.l #1,d7 ; float array: normalise move.w #$800,d0 ; assume point at left moveq #0,d2 tst.l d7 bvs.s rnd01 beq.s rnd02 move.l d7,d3 add.l d3,d3 bvs.s rnd03 sub.l d2,d3 bvc.s rnd04 ; all this is copied from ROM add.l d2,d3 rnd04 subq #1,d0 move.l d3,d7 moveq #$10,d2 rnd07 move.l d7,d3 asl.l d2,d3 bvs.s rnd05 move.l d3,d7 sub.w d2,d0 blt.s rnd06 rnd05 asr.l #1,d2 bne.s rnd07 bra.s rnd03 rnd01 roxr.l #1,d7 addq.w #1,d0 btst #$c,d0 beq.s rnd03 bra ov rnd06 neg.w d0 asr.l d0,d7 rnd02 clr.w d0 rnd03 move.w d0,0(a6,a5.l) ; write normalised number ... move.l d7,2(a6,a5.l) ; into array addq #6,a5 ; next element bra.s rnd9 ; and loop rndtwo move.w 0(a6,a1.l),d3 ; 1st rnd param. from RI stack addq.w #2,a1 ; (= offset, default was zero) rndone cmp.b #2,d5 ; extra parameters only make .. bne bp ; ... sense for integer array move.w 0(a6,a1.l),d2 ; 2nd move.l d2,d1 ; save it sub.w d3,d2 blt bp ; wrong order? addq #1,d2 ; x = how many different #s? swap d7 ; multiply by high word ... mulu d2,d7 ; ... of random number swap d7 ; now low word is less than x add.w d3,d7 ; add offset cmp.b #2,d5 ; is it an integer array? beq.s intarr ; yes move.w d7,0(a6,a1.l) ; else must float move.w ri_exec,a2 moveq #ri_float,d0 jsr (a2) move.w 0(a6,a1.l),0(a6,a5.l) ; write into array move.l 2(a6,a1.l),2(a6,a5.l) addq #6,a5 ; prepare for next element addq #4,a1 ; clean up RI stack cmp.w #1,d6 beq.s rnd9 subq #2,a1 bra.s rnd9 intarr move.w d7,0(a6,a5.l) ; write random # into array addq #2,a5 ; prepare for next element cmp.w #1,d6 beq.s rnd9 ; was there one rnd param? subq #2,a1 ; yes, then clean up RI stack rnd9 subq #1,d4 ; decrement ... bne rndlp ; and loop (no dbra for l.int.) moveq #0,d0 ; no error rndrts rts matseq bsr onepara ; just one parameter bne.s seqrts bsr loct ; establish array parameters bne.s seqrts clr.l d4 ; initialise counter cmp.b #6,d5 ; is it numeric? bgt bp ; no, bad parameter beq seqlp2 ; is it floating-point? seqlp1 addq #1,d4 ; for int: increment counter bvs ov ; mustn't exceed 32767 move.w d4,0(a6,a5.l) ; insert counter value in array addq.l #2,a5 ; update array pointer subq.l #1,d6 ; and loop variable (l.int.) bne.s seqlp1 ; next number bra.s seqend seqlp2 addq.l #1,d4 ; for float: increment counter move.w #$81f,d3 ; set standard exponent move.l d4,d2 ; copy counter into mantissa seqlintlp btst.l #30,d2 ; normalised yet? bne.s seqlintend ; yes; done asl.l #1,d2 ; no, double mantissa ... subq #1,d3 ; ... and decrement exponent bra.s seqlintlp ; now try again seqlintend move.w d3,0(a6,a5.l) ; insert exponent ... move.l d2,2(a6,a5.l) ; ... and mantissa addq.l #6,a5 ; update array pointer subq.l #1,d6 ; and loop variable (l.int.) bne.s seqlp2 ; next number seqend moveq #0,d0 ; no error seqrts rts mat1bp moveq #err_bp,d0 rts nirts addq #8,a7 ; clean up user stack moveq #err_ni,d0 ; report not implemented rts matadd moveq #ri_add,d7 ; save 'add' opcode bra.s add9 matsub moveq #ri_sub,d7 ; save 'sub' opcode add9 sub.l a3,a5 cmp.l #$18,a5 ; must be 3 parameters bne bp bsr loct ; establish 1st array params bne bp ; oops cmp.b #$2,d3 ; a float array ... beq.s add8 cmp.b #$3,d3 ; or an integer array? bne bp ; what, neither? add8 and.b #$f,9(a6,a3.l) ; second must be an array ... cmp.b 9(a6,a3.l),d3 ; ... of same type as first ... bne bp and.b #$f,$11(a6,a3.l); ... as must be third cmp.b $11(a6,a3.l),d3 bne bp move.l a3,d1 ; copy parameter base move.l bv_vvbas(a6),a0 ; and '2' move.l a0,a3 ; and '3' move.l $c(a6,d1.l),d0 add.l a3,d0 ; descriptor base '2' add.l 0(a6,d0.l),a3 ; array base '2' move.l $14(a6,d1.l),a2 add.l a0,a2 ; descriptor base '3' add.l 0(a6,a2.l),a0 ; array base '3' cmp.w 4(a6,d0.l),d4 ; must have same no. of dims... bne or ; ... in '1' and '2' ... cmp.w 4(a6,a2.l),d4 ; ... and '3' bne or move.l #0,d2 subq #1,d4 ; adjust loop variable move.w d4,d2 ; compute pointer asl.l #2,d2 add.l #4,d2 add.l d2,a4 add.l d2,d0 add.l d2,a2 moveq #1,d3 ; initialise product addlp1 cmp.w 4(a6,d0.l),d3 ; must equal previous multiplr bne ni cmp.w 4(a6,a2.l),d3 bne ni move.w 2(a6,a4.l),d1 ; current max. subscript cmp.w 2(a6,d0.l),d1 ; must be equal bne bp cmp.w 2(a6,a2.l),d1 bne bp addq #1,d1 ; (allow for subscript 0) mulu d1,d3 ; multiply into product subq #4,a4 ; update pointers subq #4,d0 subq #4,a2 dbra d4,addlp1 ; next subscript cmp.b #6,d5 ; floating-point operation? beq addflt addintlp move.w 0(a6,a0.l),d3 ; first addend ('2') move.w 0(a6,a3.l),d2 ; second addend ('3') cmp.b #ri_add,d7 ; do we add? beq.s add7 neg.w d3 ; no, subtract bvs ov ; oops add7 add.w d3,d2 ; now add bvs ov ; oops move.w d2,0(a6,a5.l) ; write result into '1' addq #2,a0 ; update pointers addq #2,a3 addq #2,a5 subq.l #1,d6 ; no dbra for long integer tst.l d6 bne.s addintlp ; next element bra add6 loct cmp.b #3,0(a6,a3.l) ; is it an array? bne bp ; if not, an error moveq #$f,d5 ; mask out separators and.b 1(a6,a3.l),d5 ; to obtain type 1,2,3 tst.b d5 beq ni ; nix on string array slice move.b d5,d3 ; needed in matstart asl.w #2,d5 ; convert to ... sub.w #$e,d5 ; ... 10,6,2 neg.w d5 move.l bv_vvbas(a6),a5 ; offset from vv base ... move.l 4(a6,a3.l),a4 ; ... yields ... add.l a5,a4 ; ... descriptor base ... add.l 0(a6,a4.l),a5 ; ... and array base move.w 4(a6,a4.l),d4 ; number of dimensions move.w 8(a6,a4.l),d6 ; start computing # of elements move.w 6(a6,a4.l),d0 ; max. first subscript cmp.b #1,d3 ; is it a string array? beq.s loct0 move.w d4,d1 ; no. of dimensions becomes ... subq #2,d1 ; adjusted loop variable blt.s loct1 ; single dim. always OK move.w d1,d2 ; compute pointer asl.w #2,d2 add.l d2,a4 move.w d5,-(a7) ; save element length moveq #1,d5 ; initialise multiplier cmp.w #1,$c(a6,a4.l) ; is last multiplier 1? bne.s ni2 loctlp move.w $a(a6,a4.l),d2 ; current max. subscript addq #1,d2 ; allow for subscript 0 mulu d2,d5 ; update multiplier cmp.w 8(a6,a4.l),d5 ; equal to next lower one? bne.s ni2 subq #4,a4 ; update pointer dbra d1,loctlp ; next lower subscript addq #4,a4 ; restore descriptor base move.w (a7)+,d5 bra.s loct1 loct0 move.l #0,d2 move.w d4,d2 ; copy no. of dimensions subq #2,d4 ; blt bp ; must be at least 2 move.l #0,d2 move.w d4,d2 ; compute pointer asl.l #2,d2 add.l d2,a4 move.w $a(a6,a4.l),d1 ; max. final subscript sub.l d2,a4 ; restore descriptor base move.w d1,6(a6,a4.l) ; new max. first subscript move.w #1,4(a6,a4.l) ; just one dimension move.w #1,8(a6,a4.l) ; single multiplier addq #2,d1 ; + word for length btst #0,d1 ; is it even? beq.s loct2 ; yes: OK addq #1,d1 ; no: add 1 loct2 move.w d1,d5 ; corrected element length divu d5,d6 ; corrected global multiplier loct1 addq #1,d0 ; ... adjusted for subscript 0 mulu d0,d6 ; may need long word moveq #0,d0 ; no error rts ni2 addq #2,a7 ni moveq #err_ni,d0 rts bp2 addq #2,a7 bp moveq #err_bp,d0 rts chrix moveq #$12,d1 ; reserve 18 bytes move.w bv_chrix,a2 jsr (a2) move.l bv_rip(a6),a1 ; restore from stack pointer moveq #0,d0 ; d0 was undefined rts onepara sub.l a3,a5 ; test for single # param. cmp.w #8,a5 bne.s bp ; <> 1 parameters moveq #0,d0 ; otherwise no error rts retnflt1 addq #6,a1 retnflt moveq #2,d4 ; floating point move.l a1,bv_rip(a6) ; restore stack pointer rts addflt bsr chrix ; make room on RI stack sub.l #$c,a1 ; push two addends addfltlp move.w 0(a6,a0.l),0(a6,a1.l) ; '2' move.l 2(a6,a0.l),2(a6,a1.l) move.w 0(a6,a3.l),6(a6,a1.l) ; '3' move.l 2(a6,a3.l),8(a6,a1.l) move.w ri_exec,a2 ; prepare add or sub ... clr.l d0 move.b d7,d0 ; ... and do it jsr (a2) bne.s addrts ; oops move.w 0(a6,a1.l),0(a6,a5.l) ; write result into '1' move.l 2(a6,a1.l),2(a6,a5.l) subq #6,a1 ; clean up RI stack addq #6,a0 ; update pointers addq #6,a3 addq #6,a5 subq.l #1,d6 ; no dbra for long integer tst.l d6 bne.s addfltlp ; next element add6 moveq #0,d0 ; no error addrts rts ndim bsr onepara ; must be 1 parameter bne.s ndimrts moveq #0,d4 ; default 0 bsr chrix ; reserve space on RI stack cmp.b #3,0(a6,a3.l) ; is it an array? bne.s rtnint ; no: return zero move.l bv_vvbas(a6),a4 ; variable values base add.l 4(a6,a3.l),a4 ; array descriptor base subq #2,a1 ; one integer required move.w 4(a6,a4.l),0(a6,a1.l) ; put no. of dims on rtnint moveq #3,d4 ; code for integer move.l a1,bv_rip(a6) ; restore RI stack pointer moveq #0,d0 ndimrts rts matidn subq #8,a5 ; must be two parameters cmp.l a3,a5 bne bp ; or else! bsr loct ; establish array parameters cmp.b #6,d5 ; is it numeric? bgt bp ; no, shame on you! move.w 4(a6,a4.l),d2 ; how many dimensions? cmp.w #2,d2 bne.s or ; what, not two? move.w 6(a6,a4.l),d2 cmp.w 10(a6,a4.l),d2 bne.s or ; they must be equal move.w d2,d6 ; copy dim. for no. of 1s idnlp1 move.w #1,0(a6,a5.l) ; write '1' into array cmp.b #2,d5 ; if integer, that's it ... beq.s idnint1 move.b #8,0(a6,a5.l) ; else use float coding move.l #$40000000,2(a6,a5.l) idnint1 add.l d5,a5 ; move to next element move.w d2,d3 ; copy dim. for no. of zeroes idnlp0 move.w #0,0(a6,a5.l) ; write zero into array cmp.b #2,d5 beq.s idnint0 move.l #0,2(a6,a5.l) ; there's more if float array idnint0 add.l d5,a5 ; move to next element dbra d3,idnlp0 ; and loop to next zero, ... dbra d6,idnlp1 ; ... then to next 1 moveq #0,d0 ; no error rts or moveq #err_or,d0 rts om moveq #err_om,d0 rts gregtab dc.w $0000 ; month code, days in month dc.w $051f dc.w $011c dc.w $011f dc.w $041e dc.w $061f dc.w $021e dc.w $041f dc.w $001f dc.w $031e dc.w $051f dc.w $011e dc.w $031f gregrts rts gregnul moveq #0,d5 ; zero for invalid dates bra greg9 gregor move.w ca_gtint,a2 ; get integers jsr (a2) bne.s gregrts cmp.w #3,d3 bne bp ; must be three move.w 0(a6,a1.l),d1 ; day move.w 2(a6,a1.l),d2 ; month clr.l d3 ; needed for division move.w 4(a6,a1.l),d3 ; year cmp.w #$62e,d3 ; no earlier than 1582 ... blt.s gregnul bgt.s gregok cmp.w #$a,d2 ; ... October ... blt.s gregnul bgt.s gregok cmp.w #$f,d1 ; ... fifteenth blt.s gregnul gregok cmp.w #1,d2 ; positive month ... blt.s gregnul cmp.w #$c,d2 ; ... not exceeding 12 bgt.s gregnul cmp.w #1,d1 ; positive day ... blt.s gregnul cmp.w #31,d1 ; ... not exceeding 31 for now bgt.s gregnul divu #$190,d3 ; reduce year modulo 400 clr.w d3 swap d3 beq.s gregleap ; leap year if remainder 0 moveq #0,d4 ; assume no leap year clr.l d6 move.w d3,d6 ; save year and.w #3,d6 ; reduce modulo 4 bne.s gregnoleap ; can't be leap unless zero move.w d3,d6 ; save year again divu #$64,d6 ; reduce modulo 100 clr.w d6 swap d6 beq.s gregnoleap ; no leap if divisible gregleap moveq #1,d4 ; leap/noleap now in d4 gregnoleap lea gregtab,a3 ; load table address add.l d2,a3 ; pointer to month add.l d2,a3 ; (distance is word) move.w (a3),d5 ; high: code, low: maximum cmp.b #2,d2 bne.s greg8 add.w d4,d5 ; adjust max. for February greg8 cmp.b d5,d1 ; does day exceed maximum? bgt gregnul asr.w #8,d5 ; start with month code cmp.b #2,d2 ; beyond February ... ble.s gregearly add.w d4,d5 ; ... add 1 if leap year gregearly add.w d1,d5 ; add day add.w d3,d5 ; and year since cycle start asr.w #2,d3 ; add # of leap years since ... add.w d3,d5 ; start of 400-year period divu #$19,d3 ; subtract # of non-leap ... sub.w d3,d5 ; ... centuries divu #7,d5 ; reduce modulo 7 clr.w d5 swap d5 addq #1,d5 ; add 1 to make code 1 to 7 greg9 addq #4,a1 ; clean up RI stack move.w d5,0(a6,a1.l) ; put on result retnint moveq #3,d4 move.l a1,bv_rip(a6) rts easterrts rts easter bsr chrix ; reserve space for RI stack move.w ca_gtint,a2 ; get an integer jsr (a2) bne.s easterrts cmp.w #1,d3 bne bp ; just one move.w 0(a6,a1.l),d1 ; y = year cmp.w #$62f,d1 ; not earlier than 1583 blt bp move.w d1,d2 divu #$13,d2 ; golden number g = ... clr.w d2 ; ... int(y mod 19) +1 swap d2 addq #1,d2 move.w d1,d4 divu #$64,d4 ; century c = ... addq #1,d4 ; ... int(y/100) +1 move.w d4,d5 mulu #3,d5 ; x = int(3*c/4)-12 asr #2,d5 sub.w #$c,d5 and.l #$ffff,d4 asl #3,d4 ; z = int(8c+5)/25)-5 addq #5,d4 divu #$19,d4 sub.w #5,d4 move.w d1,d6 mulu #5,d6 ; d = int(5y/4)-x-10 asr #2,d6 sub.w d5,d6 sub.w #$a,d6 move.w d2,d1 ; epact e = ... mulu #$b,d1 ; ... (11g+20+z-x) mod 30 add.w #$14,d1 add.w d4,d1 sub.w d5,d1 divu #$1e,d1 clr.w d1 swap d1 cmp.w #$18,d1 ; if e = 24 or ... beq.s eastincr cmp.w #$19,d1 ; ... e = 25 and g > 11 ... bne.s east9 cmp.w #$b,d2 ble.s east9 eastincr addq #1,d1 ; ... then add 1 to e east9 move.w #$2c,d2 ; n = 44-e sub.w d1,d2 cmp.w #$15,d2 ; if n < 21, increase n by 30 bge.s east8 add.w #$1e,d2 east8 move.w d2,d5 ; n = n+7-((d+n) mod 7) add.w d6,d5 divu #7,d5 clr.w d5 swap d5 sub.w d5,d2 add.w #7,d2 cmp.w #$1f,d2 ; x > 31? bgt.s eastapril mulu #$a,d2 ; if March then 10*(x.3) addq #3,d2 bra.s easter9 eastapril sub.w #$1f,d2 ; if April then 10*((x-31).4) mulu #$a,d2 addq #4,d2 easter9 move.w d2,0(a6,a1.l) ; put on stack move.w ri_exec,a2 ; float moveq #ri_float,d0 jsr (a2) subq #6,a1 ; push 10 move.w #$0804,0(a6,a1.l) move.l #$50000000,2(a6,a1.l) moveq #ri_div,d0 ; divide jsr (a2) bra retnflt eastend rts gcd move.w ca_gtlin,a2 ; get long integers jsr (a2) bne.s eastend ; oops subq #2,d3 blt bp ; must be at least two move.l 0(a6,a1.l),d2 ; first argument ble or ; must be positive move.w d3,d7 ; d7 untouched by subroutine gcdlp1 addq #4,a1 move.l 0(a6,a1.l),d1 ; next argument ble or ; must also be positive gcdlp2 bsr gcdentry ; arg1 mod arg2 tst.l d1 ; done if zero beq.s gcd9 exg d1,d2 ; else exchange arguments ... bra.s gcdlp2 ; and try again gcd9 dbra d7,gcdlp1 ; now for a new argument move.l d2,d7 ; required by normal subroutine subq #2,a1 ; clean up RI stack bsr normal ; float result bra retnflt ; and return it lcm bsr chrix ; reserve extra space on RI stk move.w ca_gtfp,a2 ; get floating-point numbers jsr (a2) bne.s eastend ; oops subq #2,d3 blt bp ; must be at least two move.w ri_exec,a2 ; prepare arithmetic operations move.w d3,d7 ; d7 untouched by subroutine lcmlp1 moveq #ri_dup,d0 ; duplicate first argument jsr (a2) moveq #ri_nlint,d0 ; ... in long-integer form jsr (a2) bne bp ; oops subq #6,a1 ; duplicate second argument move.w $10(a6,a1.l),0(a6,a1.l) move.l $12(a6,a1.l),2(a6,a1.l) moveq #ri_nlint,d0 ; ... in long-integer form jsr (a2) bne bp ; oops move.l 0(a6,a1.l),d1 ; prepare for subroutine move.l 4(a6,a1.l),d2 lcmlp2 bsr gcdentry ; arg1 mod arg2 tst.l d1 ; done if zero beq.s lcm9 exg d1,d2 ; else exchange arguments ... bra.s lcmlp2 ; ... and try again lcm9 addq #2,a1 ; 2 long integers - 1 float move.w #$81f,0(a6,a1.l); neutral exponent lcmlp3 btst.l #30,d2 ; mantissa normalised yet? bne.s lcm8 asl.l #1,d2 ; no; double mantissa ... subq.w #1,0(a6,a1.l) ; ... and reduce exponent bra.s lcmlp3 ; next try lcm8 move.l d2,2(a6,a1.l) ; put mantissa on stack moveq #ri_div,d0 ; divide out one gcd jsr (a2) moveq #ri_mult,d0 ; multiply by second argument jsr (a2) ; this is current lcm bne ov ; could be too large dbra d7,lcmlp1 ; current lcm -> new 1st arg. bra retnflt ; return as float atn move.w ca_gtfp,a2 ; get argument jsr (a2) bne.s atnend ; oops subq #1,d3 bne bp ; must be just one move.w ri_exec,a2 ; prepare RI operations moveq #ri_atan,d0 ; compute arctangent jsr (a2) bra retnflt atnend rts sqr move.w ca_gtfp,a2 ; get argument jsr (a2) bne.s sqrend ; oops subq #1,d3 bne bp ; just one move.w ri_exec,a2 moveq #ri_sqrt,d0 ; extract square root jsr (a2) bne.s sqrend ; negative argument? bra retnflt sqrend rts sgn move.w ca_gtfp,a2 ; get argument jsr (a2) bne.s sgn_rts ; oops subq.w #1,d3 bne bp ; just one tst.l 2(a6,a1.l) ; is it zero? beq retnflt ; return it move.w #0,4(a6,a1.l) ; there'll be no decimals btst #7,2(a6,a1.l) ; sign of mantissa? beq.s sgnpos move.l #$08008000,0(a6,a1.l) ; -1 bra retnflt sgnpos move.l #$08014000,0(a6,a1.l) ; +1 bra retnflt sgn_rts rts inf bsr chrix ; reserve space on RI stack subq #6,a1 move.w #$0fff,0(a6,a1.l) ; put on value ... move.l #$7fffffff,2(a6,a1.l) bra retnflt ; and return it eps move.w ca_gtfp,a2 ; get argument jsr (a2) bne.s epsend ; oops tst.w d3 beq.s epszero0 ; should be either none ... subq #1,d3 bne bp ; ... or one sub.w #$1e,0(a6,a1.l) ; reduce exponent by 30 ble.s epszero ; if not pos., return eps(0) bra.s epsuni ; only mantissa missing now epszero0 bsr chrix ; reserve space on RI stack subq #6,a1 epszero move.w #$0,0(a6,a1.l) ; this is eps(0) epsuni move.l #$40000000,2(a6,a1.l) ; a power of 2 bra retnflt ; return epsend rts intmax bsr chrix ; reserve space on RI stack subq #6,a1 move.w #$081e,0(a6,a1.l) ; put on value move.l #$7fffffff,2(a6,a1.l) bra retnflt ; and return it ceil move.w ca_gtfp,a2 ; get argument jsr (a2) bne.s ceil_rts ; oops subq.w #1,d3 bne.l bp ; just one move.w ri_exec,a2 ; prepare RI operations moveq #ri_neg,d0 ; negate jsr (a2) moveq #ri_int,d0 ; compute integer jsr (a2) bne or ; outside -32768...32767 moveq #ri_float,d0 ; re-float jsr (a2) moveq #ri_neg,d0 ; negate again jsr (a2) bra retnflt ; return ceil_rts rts min moveq #1,d7 ; code for minimum bra.s min9 max moveq #0,d7 ; code for maximum min9 move.w ca_gtfp,a2 ; get float numbers jsr (a2) bne.s maxrts ; oops tst.w d3 beq.l bp ; what, no parameters? subq.w #2,d3 ; adjust loop variable blt retnflt ; only one param.: return it move.w ri_exec,a2 ; prepare for subtraction maxlp move.w 0(a6,a1.l),d6 ; copy first parameter ... move.l 2(a6,a1.l),d5 move.w 6(a6,a1.l),d4 ; ... and second move.l 8(a6,a1.l),d2 moveq #ri_sub,d0 jsr (a2) ; subtract moveq #0,d0 ; no error tst.b d7 ; max or min? bne.s min8 ; max is treated below tas.b 2(a6,a1.l) ; check sign blt.s bmax ; 1st parameter larger bra.s max7 ; 2nd parameter larger/equal min8 tas.b 2(a6,a1.l) ; for min ... bgt.s bmax ; ... the other way round max7 move.w d4,0(a6,a1.l) ; return second parameter ... move.l d2,2(a6,a1.l) bra.s maxx bmax move.w d6,0(a6,a1.l) ; or first, as the case may be move.l d5,2(a6,a1.l) maxx dbra d3,maxlp ; compare old max/min, next # bra retnflt ; when done, return result maxrts rts atn2 move.w ca_gtfp,a2 ; get floating-point arguments jsr (a2) bne.l atnrts cmp.b #2,d3 ; must be two (x,y) bne bp move.w ri_exec,a2 ; prepare for RI operations move.w #$0802,d1 move.l #$6487ed51,d2 ; pi moveq #0,d7 ; required by early ROMs for RI move.l 8(a6,a1.l),d4 ; mantissa of y ... move.l 2(a6,a1.l),d3 ; ... and of x for sign tests bne.s atnreg ; sign of x? tst.l 8(a6,a1.l) ; x = 0; sign of y? beq ov ; both zero; value undefined addq #6,a1 ; prepare RI stack for output subq #1,d1 ; compute pi/2 move.w d1,0(a6,a1.l) ; put it on stack move.l d2,2(a6,a1.l) btst.l #31,d4 ; x = 0; y <> 0 but which? beq retnflt ; x = 0; y > 0; return pi/2 moveq #ri_neg,d0 jsr (a2) bra retnflt ; x = 0; y < 0: return -pi/2 atnreg moveq #ri_div,d0 ; x <> 0; compute atan(y/x) jsr (a2) bne.s atnrts ; oops moveq #ri_atan,d0 jsr (a2) btst.l #31,d3 beq retnflt ; x > 0; return atan(y/x) subq #6,a1 ; push pi onto stack move.w d1,0(a6,a1.l) move.l d2,2(a6,a1.l) btst.l #31,d4 ; sign of y? bne.s atnneg moveq #ri_add,d0 ; y > 0, add pi bra.s atn9 atnneg moveq #ri_sub,d0 ; y < 0, subtract pi atn9 jsr (a2) bra retnflt atnrts rts swap sub.l a3,a5 cmp.l #$10,a5 bne bp ; must be two arguments clr.l d5 move.w 0(a6,a3.l),d5 ; compare supertypes and types and.w #$ff0f,d5 ; with separators masked out move.w 8(a6,a3.l),d6 and.w #$ff0f,d6 cmp.w d5,d6 bne bp ; no difference tolerated asr.w #8,d6 ; supertype cmp.b #3,d6 ; array? beq.s swaparr cmp.b #2,d6 bne bp ; what, not an array either? move.w 2(a6,a3.l),d1 ; exchange name pointers move.w 10(a6,a3.l),2(a6,a3.l) move.w d1,10(a6,a3.l) moveq #0,d0 ; no error rts swaparr bsr.s twoarr ; establish array parameters bne.s swaprts ; oops asr.l #1,d5 mulu d5,d6 ; number of words to move swaplp3 move.w 0(a6,a5.l),d1 ; exchange by words move.w 0(a6,a2.l),0(a6,a5.l) move.w d1,0(a6,a2.l) addq #2,a5 ; adjust pointers addq #2,a2 subq.l #1,d6 ; no dbra for long integers bne.s swaplp3 ; loop to next word moveq #0,d0 ; no error swaprts rts twoarr cmp.b #3,0(a6,a3.l) bne bp ; first argument not an array and.b #$f,1(a6,a3.l) move.b 1(a6,a3.l),d5 ; type and.w #3,d5 beq ni ; first arg is array substring cmp.b #3,8(a6,a3.l) ; now same for second argument bne bp and.b #$f,9(a6,a3.l) beq ni move.b d5,d3 ; d3 = 1 | 2 | 3 asl.w #2,d5 ; convert type to 10 | 6 | 2 sub.w #$e,d5 neg.w d5 move.l bv_vvbas(a6),a5 move.l a5,a2 move.l 4(a6,a3.l),a4 add.l a5,a4 ; a4 = descriptor base 1 move.l $c(a6,a3.l),a0 add.l a5,a0 ; a0 = descriptor base 2 add.l 0(a6,a4.l),a5 ; a5 = array base 1 add.l 0(a6,a0.l),a2 ; a2 = array base 2 move.w 4(a6,a4.l),d4 ; number of dimensions ... cmp.w 4(a6,a0.l),d4 bne bp ; ... must be equal move.w 8(a6,a4.l),d6 ; start computing # of elems. cmp.w 8(a6,a0.l),d6 bne bp move.w 6(a6,a4.l),d0 ; max. first subscript cmp.w 6(a6,a0.l),d0 bne bp cmp.b #1,d3 ; is it a string array? beq.s twoarr0 move.w d4,d1 ; no. of elems. becomes ... subq #2,d1 ; ... adjusted loop variable blt twoarr1 ; single dim. always OK move.w d1,d2 ; compute pointer asl.l #2,d2 add.l d2,a4 move.w d5,-(a7) ; save element length moveq #1,d5 cmp.w #1,$c(a6,a4.l) ; is last multiplier 1? bne ni2 cmp.w #1,$c(a6,a0.l) bne ni2 twoarrlp move.w $a(a6,a4.l),d2 ; current max. subscript cmp.w $a(a6,a0.l),d2 bne bp2 addq #1,d2 ; allow for subscript 0 mulu d2,d5 ; update multiplier cmp.w 8(a6,a4.l),d5 ; equal to next lower one? bne ni2 cmp.w 8(a6,a0.l),d5 bne ni2 subq #4,a4 ; update pointers subq #4,a0 dbra d1,twoarrlp ; next lower subscript addq #4,a4 ; restore descriptor bases addq #4,a0 move.w (a7)+,d5 bra.s twoarr1 twoarr0 subq #2,d4 ; adjust loop variable blt bp ; must have at least 2 dims. move.l #0,d2 move.w d4,d2 ; compute pointer asl.l #2,d2 add.l d2,a4 move.w $a(a6,a4.l),d1 ; max. final subscript sub.l d2,a4 ; restore descriptor base move.w d1,6(a6,a4.l) ; new max. first subscript move.w d1,6(a6,a0.l) move.w #1,4(a6,a4.l) ; just one dimension move.w #1,4(a6,a0.l) move.w #1,8(a6,a4.l) ; single multiplier move.w #1,8(a6,a0.l) addq #2,d1 ; + word for length btst #0,d1 beq.s twoarr2 addq #1,d1 ; make even twoarr2 move.w d1,d5 divu d5,d6 ; new no. of elements when ... twoarr1 addq #1,d0 ; ... multiplied by ... mulu d0,d6 ; 1st max. subscript + 1 moveq #0,d0 ; no error rts matequ sub.l a3,a5 cmp.l #$10,a5 bne bp ; must have two arguments move.b 0(a6,a3.l),d1 cmp.b #3,d1 bne bp ; first must be an array move.b 1(a6,a3.l),d5 ; get type of first argument and.b #$f,d5 ; mask out separator move.b 8(a6,a3.l),d1 ; what is second element? cmp.b #2,d1 ; a variable (not unset)? beq.s equscal cmp.b #6,d1 ; a REPeat variable? beq.s equscal cmp.b #7,d1 ; a FOR variable? beq.s equscal cmp.b #3,d1 ; an array? bne bp ; nothing else permitted move.b 9(a6,a3.l),d1 ; second array ... and.b #$f,d1 ; (separator masked out) cmp.b d5,d1 ; ... and first ... bne bp ; ... must be of same type bsr twoarr ; establish array parameters bne.s equrts ; oops asr.l #1,d5 mulu d5,d6 ; number of words to move equlp2 move.w 0(a6,a2.l),0(a6,a5.l) ; write one word addq #2,a5 ; update pointers addq #2,a2 subq.l #1,d6 ; no dbra for long integer bne.s equlp2 ; next element moveq #0,d0 ; no error equrts rts equscal addq #8,a3 move.l a3,a5 addq #8,a5 ; look at second argument move.w d5,d3 asl.w #1,d3 neg.w d3 add.w #$118,d3 ; obtain ca_xxx for type move.w d3,a2 move.w (a2),a2 jsr (a2) ; fetch one parameter bne.s equrts ; oops subq #8,a3 ; restore pointer for array move.l bv_vvbas(a6),a5 ; get variable values base move.l 4(a6,a3.l),a4 ; get descriptor pointer add.l a5,a4 ; a4 = descriptor base add.l 0(a6,a4.l),a5 ; a5 = array base cmp.b #1,d5 ; special treatment for strings beq.s equstring asl.w #1,d5 sub.w #6,d5 neg.w d5 ; d5 = type: 0 int, 2 flt move.w 6(a6,a4.l),d6 ; highest first index addq #1,d6 ; allow for index 0 mulu 8(a6,a4.l),d6 ; number of elements move.l d5,d3 ; must copy bra.s equlp3 cutstring move.w d3,d2 ; copy and un-adjust subq #2,d2 ; check whether array has ... cmp.w 0(a6,a1.l),d2 ; ... shorter string length ... bge.s cutstringrts ; ... than expression move.w d2,0(a6,a1.l) ; if so, cut latter cutstringrts rts equstring move.l #0,d1 move.w 4(a6,a4.l),d1 ; number of dimensions cmp.w #1,d1 ; special treatment for ... beq.s equstr ; single-string array asl.l #2,d1 ; offset for adjusted ... add.l d1,a4 ; ... string length move.w 0(a6,a4.l),d3 ; this now in d3 sub.l d1,a4 ; restore pointer bsr.s cutstring ; max. length is of array move.w 8(a6,a4.l),d6 ; top multiplier divu d3,d6 ; divide by adj. string length move.w 6(a6,a4.l),d4 ; highest first subscript addq #1,d4 ; allow for subscript 0 mulu d4,d6 ; number of strings equ7 asr.l #1,d3 ; bytes -> words subq #1,d3 ; adjust loop variable equlp3 move.l d3,d5 ; copy for decrementing move.l a1,a2 ; copy for moving equlp4 move.w 0(a6,a2.l),0(a6,a5.l) ; write one word addq #2,a2 ; update pointers addq #2,a5 dbra d5,equlp4 ; next word subq #1,d6 ; no dbra for long integer bne.s equlp3 ; next string moveq #0,d0 ; no error rts equstr bsr.s minstrgarr bsr.s cutstring ; max. length is of array bra.s equ7 minstrgarr move.l #0,d5 move.w 6(a6,a4.l),d5 ; highest subscript btst #0,d5 ; is it even? beq.s minstrgarr9 ; yes addq #1,d5 ; no, make it even minstrgarr9 addq #2,d5 ; add word for length in n$(0) asr.w #1,d5 ; bytes -> words subq #1,d5 ; adjust loop variable moveq.l #1,d6 ; just one string rts log2 bsr chrix ; make room on RI stack move.w ca_gtfp,a2 ; obtain argument jsr (a2) bne.s logrts ; oops subq #1,d3 bne bp ; must be one parameter move.w ri_exec,a2 moveq #ri_ln,d0 jsr (a2) ; compute natural log bne logrts ; argument not positive? subq #6,a1 ; prepare division ... move.w #$800,0(a6,a1.l); ... by ln(2) move.l #$58b90bfc,2(a6,a1.l) moveq #ri_div,d0 jsr (a2) ; do it bne logrts ; oops bra retnflt logrts rts fact bsr chrix ; reserve space for RI stack move.w ca_gtint,a2 ; get argument jsr (a2) bne.s factrts ; oops subq #1,d3 bne bp ; must be just one move.w ri_exec,a2 ; prepare RI operations moveq #ri_float,d0 ; ... and convert to float jsr (a2) tst.b 2(a6,a1.l) blt ov ; undefined for neg. argument move.l 0(a6,a1.l),d2 cmp.l #$08094b00,d2 bgt ov ; no use trying if arg > 300 cmp.l #0,2(a6,a1.l) beq.s factone ; if arg is zero, return 1 moveq #ri_dup,d0 jsr (a2) ; push previous top of stack .. subq #6,a1 clr.w 4(a6,a1.l) factlp move.l #$08014000,0(a6,a1.l) moveq #ri_sub,d0 ; ... minus 1 onto stack jsr (a2) tst.l 2(a6,a1.l) ; arrived at zero yet? beq retnflt1 ; clean stack and return move.w 0(a6,a1.l),d5 ; copy top of stack move.l 2(a6,a1.l),d6 moveq #ri_mult,d0 ; multiply TOS by NOS jsr (a2) subq #6,a1 ; prepare for next lower int move.w d5,0(a6,a1.l) ; restore last int to TOS move.l d6,2(a6,a1.l) subq #6,a1 ; prepare for minuend 1 bra.s factlp ; and loop factrts rts factone move.l #$08014000,0(a6,a1.l) ; return 1 bra retnflt binom move.w ca_gtlin,a2 ; get long integers jsr (a2) bne.s factrts ; oops subq #2,d3 ; must be two bne bp bsr chrix ; need extra space on RI stack addq #2,a1 ; 2 long integers -> 1 float move.l -2(a6,a1.l),d4 ; top blt.s binomzero move.l 2(a6,a1.l),d5 ; bottom, neither negative blt.s binomzero ; or return zero cmp.l d5,d4 ; bottom must not exceed top blt.s binomzero ; or return zero move.l d4,d6 ; if bottom > top/2 ... asr.l #1,d6 cmp.l d6,d5 ble.s binom0 sub.l d4,d5 ; let bottom = top - bottom neg.l d5 binom0 tst.l d5 beq.s binomone ; if bottom = 0, return 1 cmp.l #1,d5 ; if bottom = 1, return top beq.s binomtop move.w ri_exec,a2 ; prepare for RI operations move.l d4,d7 bsr normal ; float top subq #2,d5 ; adjust loop variable moveq #1,d6 ; count bottom up from 1 binomlp subq #6,a1 ; next operand ... subq #1,d4 ; ... is decremented top move.l d4,d7 bsr normal ; float it moveq #ri_mult,d0 jsr (a2) ; multiply bne.s factrts ; overflow? subq #6,a1 ; next operand ... addq #1,d6 ; ... is incremented bottom move.l d6,d7 bsr normal ; float it moveq #ri_div,d0 jsr (a2) ; divide bne.s factrts dbra d5,binomlp ; next multiply/divide bra retnflt binomone move.w #$801,0(a6,a1.l) move.l #$40000000,2(a6,a1.l) ; put on 1 bra retnflt ; and return binomzero move.w #0,0(a6,a1.l) move.l #0,2(a6,a1.l) ; put on zero bra retnflt ; and return binomtop move.l d4,d7 ; select top bsr normal ; float it bra retnflt ; and return div bsr.s divmod ; perform long integer division bne.s divrts ; oops move.l d3,d7 ; use quotient addq #2,a1 ; clean up RI stack bsr normal ; put on RI stack in float form btst.l #1,d4 div9 beq retnflt ; return if no sign correction move.w ri_exec,a2 ; prepare for RI operation moveq #ri_neg,d0 ; negate jsr (a2) bra retnflt mod bsr.s divmod ; perform long integer division bne.s divrts ; oops move.l d1,d7 ; use remainder addq #2,a1 ; clean up RI stack bsr normal ; put on RI stack in float form btst.l #0,d4 bra.s div9 bra retnflt ; and return it divrts rts divmod move.w ca_gtlin,a2 ; get two integers jsr (a2) bne.s divrts ; oops subq #2,d3 ; just two bne bp move.l 0(a6,a1.l),d1 ; dividend move.l 4(a6,a1.l),d2 ; divisor tst.l d2 beq ov ; error if divisor 0 gcdentry move.b #0,d4 ; prepare for sign bits btst.l #31,d2 beq.s divmod9 moveq #1,d4 ; set bit 0 of d4 if d2 was < 0 neg.l d2 ; absolute value of divisor divmod9 move.b #0,d3 ; for scratch btst.l #31,d1 beq.s divmod8 moveq #1,d3 ; set d3 if d1 was < 0 neg.l d1 ; absolute value of dividend divmod8 cmp.b d3,d4 beq.s divmod7 addq #2,d4 ; set bit 1 of d4 on diff. sign divmod7 move.l #0,d3 ; for buildup of quotient moveq #0,d6 ; dividend shift counter divmodlp1 btst.l #30,d1 bne.s divmod0 btst.l #30,d2 bne.s divmod0 ; exit if operand is leftmost asl.l #1,d1 asl.l #1,d2 ; double both operands addq.l #1,d6 ; increment dividend shift ctr bra.s divmodlp1 ; try again divmod0 moveq #0,d5 ; displacement counter divmodlp2 cmp.l d2,d1 ; exit if remainder < divisor blt.s divmod6 btst #30,d2 bne.s divmodlp3 ; unless divisor is leftmost, asl.l #1,d2 ; shift divisor left addq #1,d5 ; increment counter bra.s divmodlp2 ; try again divmodlp3 cmp.l d2,d1 ; skip if not subtractable blt.s divmod6 sub.l d2,d1 ; subtract from dividend addq #1,d3 ; increment quotient divmod6 tst.l d5 ; last time through loop? bne.s divmod5 btst.l #1,d4 ; originally different signs? beq.s divmod5 sub.l d2,d1 ; subtract one more time ... neg.l d1 ; change sign of remainder addq #1,d3 ; ... and increment quotient divmod5 asr.l #1,d2 ; shift divisor right ... asl.l #1,d3 ; ... and quotient left dbra d5,divmodlp3 ; loop asr.l #1,d3 ; cancel last left shift divmodlp4 tst.l d6 beq.s divmod4 ; one pass less for remainder asr.l #1,d1 cmp.l #1,d6 ; two passes less for divisor beq.s divmod4 asr.l #1,d2 ; (needed for gcd/lcm only) divmod4 dbra d6,divmodlp4 ; cancel original left shift moveq #0,d0 ; no error divmodrts rts