Programmer 7500/MAX_PROGRAMMERS.iso/INFO/MISC/REC.ZIP/ATH87.ASM

Assembly Source File | 1986-02-13 | 15.5 KB | 716 lines

;    ===============================================================
;
;    REC module for the arithmetic operators.  These comprise:
;
;        + :    sum/logical or
;        - :    difference/exclusive or
;        * :    product/logical and
;        / :    remainder, quotient
;        ^ :    increment
;        d :    decrement, false on zero
;        N :    comparison, false if top greater
;        % :    convert to next smaller type
;        \ :    convert to next larger type
;
;    ---------------------------------------------------------------
;
;            ATH87 - Copyright (c) 1986
;            Universidad Autonoma de Puebla
;             All Rights Reserved
;
;            [Gerardo Cisneros, 25 April 1984]
;            [G. Cisneros, 6 February 1986]
;
;    ==================================================================
;    15 Aug 1984 - Entry point for ^^ - GCS
;    29 Jul 1985 - Fix for % and sumd0 - GCS
;    6 Feb 1986 - 8087 support - GCS
;    ===============================================================

;    (+) Add top two arguments on PDL: <a, b, +> leaves (a+b).
;    If arguments are of different length, the smaller one gets
;    promoted to the type of the larger one.  A null string is
;    treated as a zero.
;        arg size          result
;          0            null string
;          1             a <or> b
;          2              (a+b)mod(65536)
;          4              (a+b)mod(2**32)
;         5,8              (a+b)

sum:    call    twchk        ;fetch top into arg1, pointers of next
    jcxz    sum0
sum00:    test    al,al
    jnz    sum1
    ret            ;top arg null, PDL has result
sum0:    jmp    rtop        ;lower arg null, give arg1 as result

sum1:    cmp    al,cl        ;compare with size of lower arg
    jz    sum2
    call    cnv        ;promote smaller if different
sum2:    cmp    al,2        ;is size 1?
    jae    suma
    mov    al,[si]        ;yes, do logical or
    or    [bx],al
    ret

suma:    ja    suml
    mov    ax,[si]        ;no, add word integers
    add    [bx],ax
    ret

suml:    cmp    al,5
    jae    sumf        ;keep going if F.P.
    mov    ax,[si]
    add    [bx],ax
    mov    ax,2[si]
    adc    2[bx],ax
    ret

sumf:    ja    sumd
    inc    si
    inc    bx
;    fld    dword ptr [si]    ;load top
    esc    08H,[si]
    wait
;    fadd    dword ptr [bx]    ;add lower
    esc    00H,[bx]
    wait
;    fstp    dword ptr [bx]    ;store on PDL, pop 87 stack
    esc    0BH,[bx]
    wait
    ret

sumd:
;    fld    qword ptr [si]    ;load top
    esc    28H,[si]
    wait
;    fadd    qword ptr [bx]    ;add lower
    esc    20H,[bx]
    wait
;    fstp    qword ptr [bx]    ;store on PDL, pop 87 stack
    esc    2BH,[bx]
    wait
    ret

;    (-) Subtract top from next: <a, b, -> leaves (a-b).
;    Reverse subtraction can be accomplished by exchanging
;    arguments: write <a, b, &, -> to get (b-a).
;    If arguments are of different length, the smaller one gets
;    promoted to the type of the larger one.  A null string is
;    treated as a zero.
;        arg size          result
;          0            null string
;          1             a <xor> b
;          2              (a-b)mod(65536)
;          4              (a-b)mod(2**32)
;         5,8               (a-b)

dif:    call    twchk    ;get pointers
    jcxz    difa    ;is lower arg null?
    test    al,al    ;no, is top null?
    jnz    difa0
    ret        ;yes, leave lower

difa:    call    rtop    ;lower null: leave top arg as result,
    cmp    al,1
    jbe    dif0
    jmp    comp    ;but in negated form if size 2 bytes or longer
dif0:    ret

difa0:    cmp    al,cl        ;no, compare its size with the lower one's
    jz    difa1
    call    cnv        ;and make them of equal type if needed
difa1:    cmp    al,2        ;is size 1?
    jae    difb
    mov    al,[si]        ;yes, do logical xor
    xor    [bx],al
    ret

difb:    ja    difl
    mov    ax,[si]        ;no, subtract word integers
    sub    [bx],ax
    ret

difl:    cmp    al,5
    jae    diff        ;keep going if F.P.
subc:    mov    ax,[si]        ;subtract dword at [si] from [bx]
    sub    [bx],ax
    mov    ax,2[si]
    sbb    2[bx],ax
    ret

diff:    ja    difd
    inc    si
    inc    bx
;    fld    dword ptr [bx]    ;load lower
    esc    08H,[bx]
    wait
;    fsub    dword ptr [si]    ;subtract top
    esc    04H,[si]
    wait
;    fstp    dword ptr [bx]    ;store on PDL, pop 87 stack
    esc    0BH,[bx]
    wait
    ret

difd:
;    fld    qword ptr [bx]    ;load lower
    esc    28H,[bx]
    wait
;    fsub    qword ptr [si]    ;subtract top
    esc    24H,[si]
    wait
;    fstp    qword ptr [bx]    ;store on PDL, pop 87 stack
    esc    2BH,[bx]
    wait
    ret

;    (*) Multiply top two arguments on PDL: <a, b, *> leaves (a*b).
;    If arguments are of different lengths, the smaller one gets
;    promoted to the type of the larger one. A null string is treated
;    as a 0.
;            arg size          result
;            0            null string
;            1             a <and> b
;            2              (a*b)mod(2**16)
;            4              (a*b)mod(2**32)
;            5,8               (a*b)

mpy:    call    twchk    ;get top and pointers to next
    jcxz    mpy0
    test    al,al
    jnz    mpy1
    jmp    zres1    ;return a 0 if top is the null string

mpy0:    jmp    zres    ;return a 0 if lower is the null string

mpy1:    cmp    al,cl
    jz    mpy2
    call    cnv    ;promote smaller if not same size
mpy2:    cmp    al,2
    jae    mpya
    mov    al,[si]    ;do logical op if size is 1
    and    [bx],al
    ret

mpya:    ja    mpyb
    mov    ax,[si]    ;2-byte integer prod here
    mul    word ptr [bx]
    mov    [bx],ax
    ret

mpyb:    cmp    al,5
    jae    mpyc
    mov    di,(offset ARG2)    ;move factor to lower 4 of arg2
    mov    cx,4
    call    xf1        ;4-byte integers done here
    call    zarg1        ;factor in arg2, zero in arg1
    mov    dx,20H        ;32 shifts needed
pr3:    mov    cx,2        ;number of words
    call    twi0    ;shift arg1 left
    mov    cx,2
    mov    bx,PX
    call    twi1    ;shift lower factor left
    jnc    pr3a
    mov    cx,2
    call    adda        ;add top factor to arg1 if bit shifted out
pr3a:    dec    dx
    jnz    pr3
    mov    si,(offset ARG1M)    ;back on the PDL
    mov    cx,4
    mov    di,py
    mov    py,di
    call    mduc
    ret


mpyc:    ja    mpyd
    inc    bx
    inc    si
;    fld    dword ptr [si]    ;load top
    esc    08H,[si]
    wait
;    fmul    dword ptr [bx]    ;multiply lower
    esc    01H,[bx]
    wait
;    fstp    dword ptr [bx]    ;store on PDL, pop 87 stack
    esc    0BH,[bx]
    wait
    ret

mpyd:
;    fld    qword ptr [si]    ;load top
    esc    28H,[si]
    wait
;    fmul    qword ptr [bx]    ;multiply lower
    esc    21H,[bx]
    wait
;    fstp    qword ptr [bx]    ;store on PDL, pop 87 stack
    esc    2BH,[bx]
    wait
    ret

;    (/)  Divide top: <a,b,/> leaves rem(a/b), int(a/b).
;    Reverse division is possible by exchanging arguments;
;    thus <b,a,&,/> leaves rem(b/a), int(b/a).  If just
;    the remainder is required, write <a,b,/,L>, while if
;    only the quotient is desired, write <a,b,/,&,L>, and
;    finally, if the order of the remainder and quotient is
;    not satisfactory, they can be exchanged.  The division
;    is unsigned integer division.  It can also be used to
;    split a two-byte word into two parts through division
;    by the corresponding power of two.
;    Floating point divisions leave only the quotient.

dvd:    call    twchk        ;check top two args
    test    cl,cl
    jnz    dvd0        ;leave two zeros if lower is null
    call    zres
    mov    cx,PY
    sub    cx,PX
    cmp    cl,5        ;only one zero if dividend is F.P.
    jc    dvd0a
    ret
dvd0a:    call    narg
    jmp    zres1

dvd0:    cmp    al,cl
    jz    dvd1
    call    cnv        ;else make sure both are same length
dvd1:    cmp    al,1
    jnz    dvda
    mov    1[si],ah    ;make upper bytes of both arguments zero
    mov    1[bx],ah
    inc    PY        ;update py and run into word-divide
dvda:    cmp    al,4
    jnc    dvdb
    cmp    word ptr [si],0000    ;divisor
    jz    der
    mov    ax,[bx]
    mov    dx,0000        ;32-byte dividend
    div    word ptr [si]
    mov    [bx],dx        ;remainder
    mov    bp,ax
    mov    cx,0002
    call    narg        ;close argument, open new
    mov    [bx],bp        ;quotient
    add    bx,cx
    mov    PY,bx
    ret
der:    call    RER

dvdb:    cmp    al,5
    jb    dvdc
    ja    divd
    inc    si
    inc    bx
;    fld    dword ptr [bx]    ;load lower
    esc    08H,[bx]
    wait
;    fdiv    dword ptr [si]    ;divide by top
    esc    06H,[si]
    wait
;    fstp    dword ptr [bx]    ;store on PDL, pop 87 stack
    esc    0BH,[bx]
    wait
    ret

divd:
;    fld    qword ptr [bx]    ;load lower
    esc    28H,[bx]
    wait
;    fdiv    qword ptr [si]    ;dividy by top
    esc    26H,[si]
    wait
;    fstp    qword ptr [bx]    ;store on PDL, pop 87 stack
    esc    2BH,[bx]
    wait
    ret

dvdc:    mov    al,[si]        ;save sign of divisor
    mov    DXSG,al
    test    al,al        ;and complement if negative
    jns    dvdb0
    mov    bx,si
    mov    cx,4
    call    ngn1
dvdb0:    mov    di,(offset arg2m)
    mov    cx,4
    call    xf1
    call    zarg1    ;clear arg1
    mov    bx,(offset arg2)
    mov    [bx],ax    ;clear high arg2
    mov    2[bx],ax
    mov    si,(offset arg2m)
    call    subc    ;subtract divisor from 0 (high end)
    mov    bx,PY
    mov    al,-1[bx]        ;save sign of dividend
    mov    byte ptr DCXPT,al    ;separately to give sign of remainder
    xor    DXSG,al        ;and combined with sign of divisor
    mov    si,bx        ;prepare pointer for transfer
    test    al,al
    jns    dvdb1
    mov    bx,PX
    mov    cx,4
    call    ngn1    ;and complement dividend if negative
dvdb1:    mov    di,(offset arg1m)    ;point to middle of arg1
    mov    cx,4    ;set counter for mduc
    call    mduc    ;and copy numerator to lower half of arg1
    mov    dh,20H    ;32 shifts at most
qn4:    call    twice    ;shift arg1 left
    mov    bx,(offset arg1m)
    mov    cx,2
    call    addb    ;add arg2 to arg1 (high 4)
    jnc    qn5    ;undo if denominator didn't fit
    inc    (byte ptr ARG1)        ;else add one at LSbit of quotient
    jmp    short qn6
qn5:    mov    bx,(offset arg1m)
    mov    bp,(offset arg2m)    ;positive copy of divisor
    mov    cx,2
    call    addc    ;undo previous subtraction
qn6:    dec    dh    ;shift count
    jnz    qn4
    mov    di,PY    ;arg1 will be split into 2 4-byte values
    mov    si,(offset arghh)
    mov    cx,4
    call    mduc    ;move remainder to the PDL
    mov    al,byte ptr DCXPT    ;get sign of numerator
    test    al,al
    jns    dvdb2
    call    comp    ;and complement remainder if numerator was <0
dvdb2:    call    rarg    ;redo pointers
    mov    cx,4
    add    bx,cx    ;add 4 to HL, which contains px
    mov    PY,bx
    mov    di,bx
    mov    si,(offset ARG1M)    ;point to middle of arg1
    call    mduc    ;put quotient on the PDL
    mov    al,DXSG    ;get sign of quotient
    test    al,al
    jns    dvdb3
    call    comp    ;and complement if necessary
dvdb3:    ret


;    (N) Numerical comparison of top two elements on PDL. <a,b,N>
;    is true if a .LE. b; both arguments are erased irrespective
;    of the result.  Assuming numerical arguments means they are
;    two byte integers in the machine representation of addresses.
;    In the case of single byte arguments, their logical AND is
;    calculated, but they are both popped from the pushdown list.
;    N is FALSE if the AND is zero, meaning that if the bit tested
;    in one argument by using the other as a mask was zero, then
;    N failed.

ucn:    call    twchk    ;verify size of args
    cmp    al,cl
    jz    ucn0
    call    cnv    ;make sizes equal
ucn0:    test    al,al
    jnz    ucn1
    jmp    skp    ;TRUE if both null
ucn1:    cmp    al,2    ;TEST one-byte arguments
    jae    un2
un1:    mov    al,[si]    ;TEST
    and    al,[bx]
    jnz    un0
    jmp    ucl        ;false
un0:    jmp    cucl        ;true

un2:    ja    un3
    mov    ax,[si]
    cmp    ax,[bx]
    jnc    un2a
    jmp    ucl        ;false, lower.gt.top
un2a:    jmp    cucl        ;true, lower.le.top

un3:    call    difl
    mov    bx,PY
    dec    bx
    dec    bx
    mov    ax,[bx]        ;test hi bytes
    test    ax,ax
    js    un4
    dec    bx
    dec    bx
    or    ax,[bx]        ;get next two lower bytes
    jz    un4
    jmp    ucl        ;lift and FALSE if strictly positive
un4:    jmp    cucl        ;lift and TRUE if minus or zero

;    (^) Increment the top of the PDL. A null string causes a
;    noop.  Other arguments cause a '+' operation to be performed
;    with a 1 of the proper size

intw:    call    incr        ;Entry point for ^^

incr:    call    numchk
    cmp    cl,1
    jae    incr0
    ret        ;leave null strings alone

incr0:    ja    incr2
    or    byte ptr [bx],1
    ret

incr2:    cmp    cl,4
    jae    incr3
    inc    word ptr [bx]
    ret

incr3:    ja    incr4
    mov    cl,1
    add    [bx],cx
    mov    cl,0
    adc    2[bx],cx
    ret

incr4:
;    fld1
    db    0D9H,0E8H
    cmp    cl,5
    wait
    ja    incr5
    inc    bx
;    fadd    dword ptr [bx]
    esc    00H,[bx]
    wait
;    fstp    dword ptr [bx]
    esc    0BH,[bx]
    wait
    ret

incr5:
;    fadd    qword ptr [bx]
    esc    20H,[bx]
    wait
;    fstp    qword ptr [bx]
    esc    2BH,[bx]
    wait
    ret

;    (d) False and lift if zero, otherwise decrement and exit true.
;    Always false on null strings; a one of the proper type is
;    subtracted in all other cases

decr:    call    numchk
    test    cl,cl
    jnz    dec0
    jmp    ucl    ;Lift and exit FALSE if null
dec0:    mov    dl,cl    ;save size of operand
    xor    al,al
    mov    ch,al
    mov    si,bx
    cmp    cl,5
    jnz    dec1
    inc    si
    inc    bx
    dec    cx
dec1:    or    al,byte ptr[si]    ;jam operand bytes into A
    inc    si
    loop    dec1
    or    al,al
    jnz    dec2
    jmp    ucl    ;Lift and exit false if zero

dec2:    mov    cl,dl    ;else restore size
    cmp    cl,2
    jae    decr2
    xor    byte ptr [bx],1
    jmp    skp

decr2:    ja    decr3
    dec    word ptr [bx]
    jmp    skp

decr3:    cmp    cl,5
    jae    decr4
    mov    cl,1
    sub    [bx],cx
    mov    cl,0
    sbb    2[bx],cx
    jmp    skp

decr4:
;    fld1
    db    0D9H,0E8H
    wait
    ja    decr5
;    fsubr    dword ptr [bx]
    esc    05H,[bx]
    wait
;    fstp    dword ptr [bx]
    esc    0BH,[bx]
    wait
    jmp    skp

decr5:
;    fsubr    qword ptr [bx]
    esc    25H,[bx]
    wait
;    fstp    qword ptr [bx]
    esc    2BH,[bx]
    wait
    jmp    skp

;    (%) Convert numeric argument to next smaller type. DP=>SP may
;    produce overflow or underflow. SP=>4-byte integer is done by
;    dropping the fraction, truncating the integer part modulo (2**32)
;    and negating if the original was less than 0.  4-byte=>2-byte and
;    2-byte=>1-byte are done by truncating mod(2**16) and mod(2**8)
;    respectively.  The null string produces a noop.

pe:    call    numchk    ;verify that argument is indeed numeric
    jz    peflt    ;distinguish FP argument
    test    cl,cl
    jnz    pe0a
    ret        ;leave null strings in peace
pe0a:    shr    cl,1    ;else an integer, leave half of original
    add    bx,cx    ;add to px
    mov    py,bx    ;store as new limit of argument
    ret

peflt:    cmp    cl,5
    ja    pe0
    dec    PY
    mov    si,offset ARG1
;    fstcw    [si]    ;copy current control word
    esc    0FH,[si]
    wait
;    fld    dword ptr 1[bx]
    esc    08H,1[bx]
    or    word ptr [si],0C00H
    wait
;    fldcw    [si]    ;set chopping
    esc    0DH,[si]
    wait
;    fistp    dword ptr [bx]
    esc    1BH,[bx]
    and    word ptr [si],0F3FFH
    wait
;    fldcw    [si]    ;set rounding to nearest
    esc    0DH,[si]
    wait
    ret

pe0:
;    fld    qword ptr [bx]
    esc    28H,[bx]
    wait
    inc    bx
;    fstp    dword ptr [bx]
    esc    0BH,[bx]
    mov    cl,4
    add    bx,cx
    mov    py,bx
    wait
    ret

;    (\) Convert a numeric argument to the next higher type

ip:    call    numchk    ;ensure arg has size of a numeric type
    jz    ipflt    ;go to ipflt if arg is FP
    cmp    cl,4
    jz    iplf    ;int to FP conv reqd for long integers
    add    cl,cl    ;determine new size for 1 or 2-byte args
    jnz    ip0
    mov    (byte ptr[bx]),cl    ;clear a byte if arg was null string
    inc    cl
ip0:    call    OARG    ;check that space is available
    mov    dx,bx    ;new py to DE
    mov    bx,PY    ;old py to HL
    clc
    rcr    cl,1    ;bytes to clear
    jc    ip2    ;done if new arg has size 1
ip1:    mov    (byte ptr[bx]),0
    inc    bx
    loop    ip1
ip2:    mov    PY,dx    ;and save
    ret

iplf:
;    fild    dword ptr [bx]
    esc    18H,[bx]
    wait
    inc    bx
;    fstp    dword ptr [bx]
    esc    0BH,[bx]
    inc    py    ;make size 5
    wait
    ret

ipflt:    cmp    cl,8
    jnz    ipfl0
    ret        ;leave DP arg in peace
ipfl0:
;    fld    dword ptr 1[bx]
    esc    08H,1[bx]
    wait
;    fstp    qword ptr [bx]
    esc    2BH,[bx]
    mov    cl,8
    add    bx,cx
    mov    py,bx
    wait
    ret

;    ---------------------------------------------------------------
;    Service routines for the preceding operators
;    ---------------------------------------------------------------

;    Get top arg into arg1 and poinuers to lower arg into registers
;    Check also that both args are numeric
;    If succesful, numchk returns px in HL, py in DE, py-px in
;    BC and in A and zero flag on if arg is FP

twchk:    pop    bp    ;remove return address from stack
    call    numchk    ;check top arg
    mov    ax,cx    ;save its size
    mov    si,bx    ;PX as source pointer
    call    ucl    ;lift it from the PDL
    call    numchk    ;check top arg
    jmp    bp

;    Return old top

rtop:    mov    PX,si    ;rebuild pointers
    add    si,ax
    mov    PY,si
    jmp    XLFT

;    Return a zero of the proper size

zres1:    mov    al,cl
zres:    mov    cl,al
    mov    di,px
    mov    ch,0    ;clear upper byte of count
    jcxz    znul    ;done if nothing to move
    call    zar1
znul:    mov    py,di    ;keep py updated
    ret

;    Convert to type of longer argument

cnv:    mov    cx,ax    ;size of old top
    lahf
    push    ax    ;save size and result of comparison
    mov    px,si    ;top px
    add    si,cx
    mov    py,si    ;top py
    pop    ax
    sahf
    pushf        ;retrieve but save again comparison flag
    jc    cnv0
    call    exch    ;exchange if lower smaller than upper
cnv0:    call    ip    ;convert top to next bigger type
    popf
    jc    cnv1
    call    exch    ;exchange back if necessary
cnv1:    call    twchk    ;see if same size
    cmp    al,cl
    jnz    cnv    ;repeat if not same size yet
    ret

;    end