head     56.3;
access   paws bayes jws quist brad dew jwh;
symbols  ;
locks    ; strict;
comment  @# @;


56.3
date     93.01.27.13.18.52;  author jwh;  state Exp;
branches ;
next     56.2;

56.2
date     93.01.27.11.59.50;  author jwh;  state Exp;
branches ;
next     56.1;

56.1
date     91.11.05.09.56.12;  author jwh;  state Exp;
branches ;
next     55.1;

55.1
date     91.08.25.10.31.39;  author jwh;  state Exp;
branches ;
next     54.3;

54.3
date     91.08.21.10.39.13;  author jwh;  state Exp;
branches ;
next     54.2;

54.2
date     91.08.21.09.42.47;  author jwh;  state Exp;
branches ;
next     54.1;

54.1
date     91.03.18.15.32.57;  author jwh;  state Exp;
branches ;
next     53.1;

53.1
date     91.03.11.19.32.51;  author jwh;  state Exp;
branches ;
next     52.1;

52.1
date     91.02.19.09.18.15;  author jwh;  state Exp;
branches ;
next     51.1;

51.1
date     91.01.30.16.17.25;  author jwh;  state Exp;
branches ;
next     50.1;

50.1
date     90.10.29.16.31.29;  author jwh;  state Exp;
branches ;
next     49.1;

49.1
date     90.08.14.14.15.14;  author jwh;  state Exp;
branches ;
next     48.1;

48.1
date     90.07.26.11.21.42;  author jwh;  state Exp;
branches ;
next     47.1;

47.1
date     90.05.14.11.06.41;  author dew;  state Exp;
branches ;
next     46.1;

46.1
date     90.05.07.08.53.37;  author jwh;  state Exp;
branches ;
next     45.1;

45.1
date     90.04.19.16.01.37;  author jwh;  state Exp;
branches ;
next     44.1;

44.1
date     90.04.01.22.18.47;  author jwh;  state Exp;
branches ;
next     43.1;

43.1
date     90.03.20.14.11.29;  author jwh;  state Exp;
branches ;
next     42.1;

42.1
date     90.01.23.17.55.42;  author jwh;  state Exp;
branches ;
next     41.1;

41.1
date     89.12.22.11.37.51;  author jwh;  state Exp;
branches ;
next     40.1;

40.1
date     89.09.29.11.58.55;  author jwh;  state Exp;
branches ;
next     39.1;

39.1
date     89.09.26.16.43.44;  author dew;  state Exp;
branches ;
next     38.1;

38.1
date     89.08.29.11.35.44;  author jwh;  state Exp;
branches ;
next     37.1;

37.1
date     89.05.12.11.49.31;  author dew;  state Exp;
branches ;
next     36.1;

36.1
date     89.02.06.10.27.08;  author dew;  state Exp;
branches ;
next     35.1;

35.1
date     89.02.02.13.42.47;  author dew;  state Exp;
branches ;
next     34.1;

34.1
date     89.01.23.16.17.58;  author jwh;  state Exp;
branches ;
next     33.1;

33.1
date     89.01.16.11.49.21;  author dew;  state Exp;
branches ;
next     32.1;

32.1
date     89.01.10.11.58.46;  author bayes;  state Exp;
branches ;
next     31.1;

31.1
date     88.12.14.18.19.32;  author bayes;  state Exp;
branches ;
next     30.1;

30.1
date     88.12.09.13.56.37;  author dew;  state Exp;
branches ;
next     29.1;

29.1
date     88.10.31.15.41.11;  author bayes;  state Exp;
branches ;
next     28.1;

28.1
date     88.10.06.11.07.23;  author dew;  state Exp;
branches ;
next     27.1;

27.1
date     88.09.29.11.50.13;  author bayes;  state Exp;
branches ;
next     26.1;

26.1
date     88.09.28.13.39.15;  author bayes;  state Exp;
branches ;
next     25.1;

25.1
date     88.03.02.09.45.02;  author bayes;  state Exp;
branches ;
next     24.1;

24.1
date     87.08.31.10.16.12;  author jws;  state Exp;
branches ;
next     23.1;

23.1
date     87.08.26.11.02.31;  author bayes;  state Exp;
branches ;
next     22.1;

22.1
date     87.08.17.11.41.33;  author bayes;  state Exp;
branches ;
next     21.1;

21.1
date     87.08.12.14.25.32;  author bayes;  state Exp;
branches ;
next     20.1;

20.1
date     87.07.30.11.37.18;  author bayes;  state Exp;
branches ;
next     19.1;

19.1
date     87.06.01.08.51.19;  author jws;  state Exp;
branches ;
next     18.1;

18.1
date     87.05.20.15.56.35;  author bayes;  state Exp;
branches ;
next     17.1;

17.1
date     87.04.30.11.00.35;  author jws;  state Exp;
branches ;
next     16.1;

16.1
date     87.04.26.16.10.42;  author jws;  state Exp;
branches ;
next     15.1;

15.1
date     87.04.13.09.51.30;  author jws;  state Exp;
branches ;
next     14.1;

14.1
date     87.04.01.16.01.40;  author jws;  state Exp;
branches ;
next     13.1;

13.1
date     87.02.28.18.53.58;  author jws;  state Exp;
branches ;
next     12.1;

12.1
date     87.02.02.13.47.40;  author jws;  state Exp;
branches ;
next     11.1;

11.1
date     87.01.19.10.13.53;  author jws;  state Exp;
branches ;
next     10.1;

10.1
date     86.12.24.11.29.02;  author jws;  state Exp;
branches ;
next     9.1;

9.1
date     86.12.12.15.12.46;  author bayes;  state Exp;
branches ;
next     8.1;

8.1
date     86.11.27.12.22.09;  author jws;  state Exp;
branches ;
next     7.1;

7.1
date     86.11.20.14.34.40;  author hal;  state Exp;
branches ;
next     6.1;

6.1
date     86.11.04.18.27.29;  author paws;  state Exp;
branches ;
next     5.1;

5.1
date     86.10.28.17.16.58;  author hal;  state Exp;
branches ;
next     4.1;

4.1
date     86.09.30.20.10.53;  author hal;  state Exp;
branches ;
next     3.1;

3.1
date     86.09.01.12.22.23;  author hal;  state Exp;
branches ;
next     2.1;

2.1
date     86.07.30.15.10.35;  author hal;  state Exp;
branches ;
next     1.1;

1.1
date     86.06.30.16.48.19;  author danm;  state tmp;
branches ;
next     ;


desc
@Base file for PWS 3.2 release.

@


56.3
log
@
pws2rcs automatic delta on Wed Jan 27 13:14:25 MST 1993
@
text
@
*
*     STRING AND SET SUPPORT ROUTINES
*        -- SET SUPPPORT ADDED 3/18/85
*
	def fs_fwritestrint
	refa sysglobals,M68KTYPE                (rdq)

ioresult        equ sysglobals-22
istrovfl        equ 28

sign            equ d0
digits          equ d1

int             equ d2
high            equ d3
extend          equ d4
ten             equ d5
zero            equ d6
fieldwidth      equ d7

maxstrlen       equ d0

intlen          equ d2
strlen          equ d3
temp            equ d4
newindex        equ d5
index           equ d6

return          equ a0
straddr         equ a1
dindex          equ a2
sindex          equ a3
aindex          equ a4

l0      divu    ten,int
	swap    int
	add.w   zero,int
	move.b  int,-(dindex)
	addq    #1,digits
	clr.w   int
	swap    int
get_digits      equ *
	cmp.l   ten,int
	bcc.s   l0
	add.w   zero,int
	move.b  int,-(dindex)
	addq    #1,digits
	rts

fs_fwritestrint  equ *
	movea.l (sp)+,return
	move    (sp)+,fieldwidth        integer is to be right justified
	move.l  (sp)+,int               integer to be converted
	movea.l (sp)+,aindex            address of index into string
	movea.l (sp)+,straddr           address of string
	moveq   #0,maxstrlen
	move.b  (sp)+,maxstrlen         dimensioned size of string

	link    a6,#-12                 allocate space for local string
	move.b  maxstrlen,(sp)          save maxstrlen in local string
	lea     (a6),dindex             index to tail of local string
	moveq   #0,digits
	moveq   #10,ten
	moveq   #'0',zero

	tst.l   int
	slt     sign            remember whether negative
	bge.s   positive
	neg.l   int
positive moveq  #0,high
	cmp.l  #100000,int
	bcs.s   small           unsigned integer is less than 100000

* divide integer by 100000, save high part, keep low part in integer:

	lsr.l   #1,int          divide by 2
	TST.B   M68KTYPE
	BNE.S   DIV0
	move    sr,extend       remainder in extend bit
	BRA.S   DIV1
DIV0    DC.W    $42C4           MOVE    CCR,EXTEND  ??????      (rdq)
DIV1    divu    #50000,int      divide by 50000
	move.w  int,high        quotient is high part
	clr.w   int             zap quotient
	swap    int             get remainder
	move    extend,ccr      reconstruct full remainder
	roxl.l  #1,int          integer is now mod 100000

small   bsr.s   get_digits      extract low order digits

	tst.w   high            check for any high order digits
	beq.s   finish
l1      cmp     #5,digits       there should be at least 5 digits
	beq.s   l2
	move.b  zero,-(dindex)
	addq    #1,digits
	bra.s   l1
l2      move    high,int
	bsr.s   get_digits      get high order digits

finish  equ *

	move.l  (aindex),index
	ble.s   error                   error if index < 1

	moveq   #0,strlen
	move.b  (straddr),strlen        current length of string

	move.l  strlen,temp
	addq.l  #1,temp
	cmp.l   temp,index
	bgt.s   error           error if index > strlen(s)+1

	move    digits,intlen   compute minimum size of new integer
	tst.b   sign
	beq.s   nosign
	addq    #1,intlen       add 1 for minus sign
nosign  equ *

	tst     fieldwidth      field width is 12 if passed negative
	bge.s   nodefault
	moveq   #12,fieldwidth
nodefault equ *

	cmp   intlen,fieldwidth       fieldwidth is at least size of integer
	bge.s   bigger
	move    intlen,fieldwidth
bigger  equ *

	move.l  index,newindex          compute new index
	add     fieldwidth,newindex

	move    newindex,temp           string length is maximum of
	subq    #1,temp                         old length, newindex-1
	cmp     temp,strlen
	bge.s   longer
	move    temp,strlen
longer  equ     *

	clr     temp
	move.b  (sp),temp               retrieve strmax
	cmp     temp,strlen
	bgt.s   error                   error if new length > strmax(s)

	move.b  strlen,(straddr)        set new string length
	move.l  newindex,(aindex)                set new index

	lea     0(straddr,index),sindex

	sub     intlen,fieldwidth
	beq.s   nospaces
space   move.b  #' ',(sindex)+
	subq    #1,fieldwidth
	bgt.s   space
nospaces equ *

	tst.b  sign
	beq.s   nosgn
	move.b  #'-',(sindex)+
nosgn   equ *

digit   move.b  (dindex)+,(sindex)+
	subq    #1,digits
	bgt.s   digit

	clr.l   ioresult(a5)
strok   unlk    a6
	jmp     (return)

error   moveq   #istrovfl,d0
	move.l  d0,ioresult(a5)
	bra.s   strok

*------------------------------------------
	    DEF asm_Xin
*
* History:
*       01/29/85, bct, original (take-off of original "asm_in")
*------------------------------------------

asm_Xin         EQU     *               extended capacity set "in" operator

		movea.l (sp)+,a0        return address
		movea.l (sp)+,a1        set address
		move.l  (sp)+,d0        selector value
		blt     lfalse          selector < 0 ?
		move.l  d0,d1
		lsr.l   #3,d0           byte offset
		andi.l  #7,d1           bit offset
		cmp.w   (a1),d0         selector > setsize ?
		bge     lfalse
		move.b  2(a1,d0),d0     get selected byte
		lsl.b   d1,d0           construct boolean result
		lsr.b   #7,d0
		move.b  d0,-(sp)
		jmp     (a0)            return true
lfalse          clr.b   -(sp)
		jmp     (a0)            return false
		page


*------------------------------------------
	    DEF asm_XSETASSIGN
*
* History:
*       01/29/85, bct, original (take-off of original "asm_SETASSIGN")
*------------------------------------------
asm_XSETASSIGN   EQU *
* obtain sets from stack
	    movea.l    4(sp),a3          address of source
	    movea.l    8(sp),a4          address of dest
* place size in d7
	    move.w     (a3)+,d7          size of source
	    move.w     d7,(a4)           store size in dest
	    beq.s      done2             check for zero length set
	    move.l     12(sp),d0         dest min
	    beq.s      testhigh
	    moveq      #0,d2             zero count
	    move.w     d7,d3
	    movea.l    a3,a2
loop1       tst.b      (a2)+             find nonzero byte
	    bne.s      NZbyte
	    addq.w     #1,d2
	    subq.w     #1,d3
	    bgt.s      loop1

	    clr.w      (a4)
	    bra.s      done2

NZbyte      lsl.l      #3,d2             byte count * 8
	    cmp.l      d2,d0
	    ble.s      testhigh

	    move.b     -1(a2),d3         get first nonzero byte
loop2       lsl.b      #1,d3
	    bcs.s      NZbit             nonzero bit found
	    addq.l     #1,d2
	    bra.s      loop2

NZbit       cmp.l      d2,d0
	    ble.s      testhigh
	    trap       #7                error

testhigh    move.l     16(sp),d1         dest max
lastword    move.w     -2(a3,d7.w),d3    get last word of set
	    bne.s      NZword
	    subq.w     #2,d7
	    bgt.s      lastword
	    clr.w      (a4)              set was empty
	    bra.s      done2

NZword      move.w     d7,d2
	    ext.l      d2
	    lsl.l      #3,d2             byte count * 8
loop3       subq.l     #1,d2
	    lsr.w      #1,d3
	    bcc.s      loop3

	    cmp.l      d2,d1             last nonzero bit found
	    bge.s      ok
	    trap       #7                error
* perform assignment
ok          move.w     d7,(a4)+           store size in dest
	    asr.w      #2,d7              determine size in long words
	    bcc.s        evenn              even number of long words
	    move.w     (a3)+,(a4)+        move "odd" word
	    tst.w      d7                 min size single word?
	    beq.s        done2
EVENN       move.l     (a3)+,(a4)+        move long words
	    subq.w     #1,d7
	    bgt.s        evenn
DONE2       movea.l    (sp)+,a0            eliminate extra bytes in stack
	    adda.l     #16,sp
	    jmp        (a0)
	    page
*------------------------------------------
	   DEF asm_XaDELEMENT
	   DEF asm_XXaDELEMENT
	   DEF asm_XADDSETRANGE
	   DEF asm_XXADDSETRANGE
*
* History:
*       01/29/85, bct, original (take-off of originals
*                 "asm_ADDSETRANGE" and  "asm_aDELEMENT")
*------------------------------------------

asm_XXADDSETRANGE EQU   *
		move.w  #1,d0
		bra.s   hit_it
asm_XADDSETRANGE  EQU   *
		clr.w   d0
hit_it          movea.l (sp)+,a0        return address
		move.l  (sp)+,d3        hivalue
		move.l  (sp)+,d4        lowvalue
		cmp.l   d3,d4
		ble.s   addchk
*                                       Bug fix to Rev. 3.1 Pascal, now
*                                         copy src to dest (if not same)
*       ****    move.l  (sp),4(sp)        instead of changing addresses
		movea.l (sp),a1         src addr
		movea.l 4(sp),a2        dest addr
		cmpa.l   a1,a2          src = dest?
		beq     stopping
		move.w  (a1),d7         size of src
		addq.w  #2,d7           include size field on copy
cploop          move.w  (a1)+,(a2)+
		subq.w  #2,d7
		bgt.s   cploop
stopping        adda.l  #4,sp
		jmp     (a0)            return

addchk          cmpi.w  #0,d0
		bgt     large
		cmpi.l  #8175,d3
		ble.s   adding
		trap    #7
large           cmpi.l  #261999,d3
		ble.s   adding
		trap    #7
adding          movea.l (sp),a1        source address
		movea.l 4(sp),a2       destination address
cont_adding     move.l  d4,d0          ordinal value being added
		jsr     adelement_entry
		addq.l  #1,d4
		cmp.l   d3,d4
		bgt.s   stopping
		suba.l  #2,a2           restore to point at size field
		movea.l a2,a1           avoids src re-copy
		bra.s   cont_adding

asm_XXaDELEMENT EQU     *
	movea.l         (sp)+,a0        return address
	move.l          (sp)+,d0        element number to add to set
	movea.l         (sp)+,a1        source address
	movea.l         (sp),a2         destination address
	cmpi.l          #261999,d0      under max set ordinal value ?
	ble.s           strt
	    trap    #7
asm_XaDELEMENT EQU      *
	movea.l         (sp)+,a0        return address
	move.l          (sp)+,d0        element number to add to set
	movea.l         (sp)+,a1        source address
	movea.l         (sp),a2         destination address
	cmpi.l          #8175,d0        under default max set ordinal value ?
	ble.s           strt
	    trap    #7
strt    jsr             adelement_entry
	jmp             (a0)            return

adelement_entry  EQU  *
	move.w          (a1)+,d7        get set size of source
	move.w          d7,(a2)+        store size value
	cmpa.l          a2,a1           see if source and destination are equal
	beq.s           insert
* copy source set to the destination set
setcopy movea.l         a2,a3           save destination address
	move.w          d7,d6           save size for destination
	ble.s           insert          check for size of zero
rept    move.w          (a1)+,(a3)+     sets are always an even number of bytes
	subq.w          #2,d6
	bgt.s           rept
* insert an element in a set, adjusting the size of the destination if needed
insert  move.l          d0,d5
	lsr.l           #4,d0           word offset
	asl.l           #1,d0           word offset in bytes
	andi.l          #15,d5          bit offset from left end of word
	sub.l           #15,d5
	neg.l           d5              bit offset from right end
	move.w          d0,d1           compute final size into d1
	addq.w          #2,d1           put zeros in the two bytes containing
	move.w          d1,d2           the new bit if it is beyond current size
	sub.w           -2(a2),d1
	ble.s           exxiit
	move.w          d2,-2(a2)       store appropriate size for set
	lea             0(a2,d2),a3
zerout  clr.w           -(a3)
	subq.w          #2,d1
	bgt.s           zerout
exxiit  bclr            #3,d5           { received upgrade 9/9 }
	beq.s           skiipp
	bset            d5,0(a2,d0)
	rts
skiipp  bset            d5,1(a2,d0)
	rts
*------------------------------------------



	nosyms
	end
@


56.2
log
@
pws2rcs automatic delta on Wed Jan 27 11:57:27 MST 1993
@
text
@d1 391
@


56.1
log
@Automatic bump of revision number for PWS version 3.25
@
text
@a0 391

*
*     STRING AND SET SUPPORT ROUTINES
*        -- SET SUPPPORT ADDED 3/18/85
*
	def fs_fwritestrint
	refa sysglobals,M68KTYPE                (rdq)

ioresult        equ sysglobals-22
istrovfl        equ 28

sign            equ d0
digits          equ d1

int             equ d2
high            equ d3
extend          equ d4
ten             equ d5
zero            equ d6
fieldwidth      equ d7

maxstrlen       equ d0

intlen          equ d2
strlen          equ d3
temp            equ d4
newindex        equ d5
index           equ d6

return          equ a0
straddr         equ a1
dindex          equ a2
sindex          equ a3
aindex          equ a4

l0      divu    ten,int
	swap    int
	add.w   zero,int
	move.b  int,-(dindex)
	addq    #1,digits
	clr.w   int
	swap    int
get_digits      equ *
	cmp.l   ten,int
	bcc.s   l0
	add.w   zero,int
	move.b  int,-(dindex)
	addq    #1,digits
	rts

fs_fwritestrint  equ *
	movea.l (sp)+,return
	move    (sp)+,fieldwidth        integer is to be right justified
	move.l  (sp)+,int               integer to be converted
	movea.l (sp)+,aindex            address of index into string
	movea.l (sp)+,straddr           address of string
	moveq   #0,maxstrlen
	move.b  (sp)+,maxstrlen         dimensioned size of string

	link    a6,#-12                 allocate space for local string
	move.b  maxstrlen,(sp)          save maxstrlen in local string
	lea     (a6),dindex             index to tail of local string
	moveq   #0,digits
	moveq   #10,ten
	moveq   #'0',zero

	tst.l   int
	slt     sign            remember whether negative
	bge.s   positive
	neg.l   int
positive moveq  #0,high
	cmp.l  #100000,int
	bcs.s   small           unsigned integer is less than 100000

* divide integer by 100000, save high part, keep low part in integer:

	lsr.l   #1,int          divide by 2
	TST.B   M68KTYPE
	BNE.S   DIV0
	move    sr,extend       remainder in extend bit
	BRA.S   DIV1
DIV0    DC.W    $42C4           MOVE    CCR,EXTEND  ??????      (rdq)
DIV1    divu    #50000,int      divide by 50000
	move.w  int,high        quotient is high part
	clr.w   int             zap quotient
	swap    int             get remainder
	move    extend,ccr      reconstruct full remainder
	roxl.l  #1,int          integer is now mod 100000

small   bsr.s   get_digits      extract low order digits

	tst.w   high            check for any high order digits
	beq.s   finish
l1      cmp     #5,digits       there should be at least 5 digits
	beq.s   l2
	move.b  zero,-(dindex)
	addq    #1,digits
	bra.s   l1
l2      move    high,int
	bsr.s   get_digits      get high order digits

finish  equ *

	move.l  (aindex),index
	ble.s   error                   error if index < 1

	moveq   #0,strlen
	move.b  (straddr),strlen        current length of string

	move.l  strlen,temp
	addq.l  #1,temp
	cmp.l   temp,index
	bgt.s   error           error if index > strlen(s)+1

	move    digits,intlen   compute minimum size of new integer
	tst.b   sign
	beq.s   nosign
	addq    #1,intlen       add 1 for minus sign
nosign  equ *

	tst     fieldwidth      field width is 12 if passed negative
	bge.s   nodefault
	moveq   #12,fieldwidth
nodefault equ *

	cmp   intlen,fieldwidth       fieldwidth is at least size of integer
	bge.s   bigger
	move    intlen,fieldwidth
bigger  equ *

	move.l  index,newindex          compute new index
	add     fieldwidth,newindex

	move    newindex,temp           string length is maximum of
	subq    #1,temp                         old length, newindex-1
	cmp     temp,strlen
	bge.s   longer
	move    temp,strlen
longer  equ     *

	clr     temp
	move.b  (sp),temp               retrieve strmax
	cmp     temp,strlen
	bgt.s   error                   error if new length > strmax(s)

	move.b  strlen,(straddr)        set new string length
	move.l  newindex,(aindex)                set new index

	lea     0(straddr,index),sindex

	sub     intlen,fieldwidth
	beq.s   nospaces
space   move.b  #' ',(sindex)+
	subq    #1,fieldwidth
	bgt.s   space
nospaces equ *

	tst.b  sign
	beq.s   nosgn
	move.b  #'-',(sindex)+
nosgn   equ *

digit   move.b  (dindex)+,(sindex)+
	subq    #1,digits
	bgt.s   digit

	clr.l   ioresult(a5)
strok   unlk    a6
	jmp     (return)

error   moveq   #istrovfl,d0
	move.l  d0,ioresult(a5)
	bra.s   strok

*------------------------------------------
	    DEF asm_Xin
*
* History:
*       01/29/85, bct, original (take-off of original "asm_in")
*------------------------------------------

asm_Xin         EQU     *               extended capacity set "in" operator

		movea.l (sp)+,a0        return address
		movea.l (sp)+,a1        set address
		move.l  (sp)+,d0        selector value
		blt     lfalse          selector < 0 ?
		move.l  d0,d1
		lsr.l   #3,d0           byte offset
		andi.l  #7,d1           bit offset
		cmp.w   (a1),d0         selector > setsize ?
		bge     lfalse
		move.b  2(a1,d0),d0     get selected byte
		lsl.b   d1,d0           construct boolean result
		lsr.b   #7,d0
		move.b  d0,-(sp)
		jmp     (a0)            return true
lfalse          clr.b   -(sp)
		jmp     (a0)            return false
		page


*------------------------------------------
	    DEF asm_XSETASSIGN
*
* History:
*       01/29/85, bct, original (take-off of original "asm_SETASSIGN")
*------------------------------------------
asm_XSETASSIGN   EQU *
* obtain sets from stack
	    movea.l    4(sp),a3          address of source
	    movea.l    8(sp),a4          address of dest
* place size in d7
	    move.w     (a3)+,d7          size of source
	    move.w     d7,(a4)           store size in dest
	    beq.s      done2             check for zero length set
	    move.l     12(sp),d0         dest min
	    beq.s      testhigh
	    moveq      #0,d2             zero count
	    move.w     d7,d3
	    movea.l    a3,a2
loop1       tst.b      (a2)+             find nonzero byte
	    bne.s      NZbyte
	    addq.w     #1,d2
	    subq.w     #1,d3
	    bgt.s      loop1

	    clr.w      (a4)
	    bra.s      done2

NZbyte      lsl.l      #3,d2             byte count * 8
	    cmp.l      d2,d0
	    ble.s      testhigh

	    move.b     -1(a2),d3         get first nonzero byte
loop2       lsl.b      #1,d3
	    bcs.s      NZbit             nonzero bit found
	    addq.l     #1,d2
	    bra.s      loop2

NZbit       cmp.l      d2,d0
	    ble.s      testhigh
	    trap       #7                error

testhigh    move.l     16(sp),d1         dest max
lastword    move.w     -2(a3,d7.w),d3    get last word of set
	    bne.s      NZword
	    subq.w     #2,d7
	    bgt.s      lastword
	    clr.w      (a4)              set was empty
	    bra.s      done2

NZword      move.w     d7,d2
	    ext.l      d2
	    lsl.l      #3,d2             byte count * 8
loop3       subq.l     #1,d2
	    lsr.w      #1,d3
	    bcc.s      loop3

	    cmp.l      d2,d1             last nonzero bit found
	    bge.s      ok
	    trap       #7                error
* perform assignment
ok          move.w     d7,(a4)+           store size in dest
	    asr.w      #2,d7              determine size in long words
	    bcc.s        evenn              even number of long words
	    move.w     (a3)+,(a4)+        move "odd" word
	    tst.w      d7                 min size single word?
	    beq.s        done2
EVENN       move.l     (a3)+,(a4)+        move long words
	    subq.w     #1,d7
	    bgt.s        evenn
DONE2       movea.l    (sp)+,a0            eliminate extra bytes in stack
	    adda.l     #16,sp
	    jmp        (a0)
	    page
*------------------------------------------
	   DEF asm_XaDELEMENT
	   DEF asm_XXaDELEMENT
	   DEF asm_XADDSETRANGE
	   DEF asm_XXADDSETRANGE
*
* History:
*       01/29/85, bct, original (take-off of originals
*                 "asm_ADDSETRANGE" and  "asm_aDELEMENT")
*------------------------------------------

asm_XXADDSETRANGE EQU   *
		move.w  #1,d0
		bra.s   hit_it
asm_XADDSETRANGE  EQU   *
		clr.w   d0
hit_it          movea.l (sp)+,a0        return address
		move.l  (sp)+,d3        hivalue
		move.l  (sp)+,d4        lowvalue
		cmp.l   d3,d4
		ble.s   addchk
*                                       Bug fix to Rev. 3.1 Pascal, now
*                                         copy src to dest (if not same)
*       ****    move.l  (sp),4(sp)        instead of changing addresses
		movea.l (sp),a1         src addr
		movea.l 4(sp),a2        dest addr
		cmpa.l   a1,a2          src = dest?
		beq     stopping
		move.w  (a1),d7         size of src
		addq.w  #2,d7           include size field on copy
cploop          move.w  (a1)+,(a2)+
		subq.w  #2,d7
		bgt.s   cploop
stopping        adda.l  #4,sp
		jmp     (a0)            return

addchk          cmpi.w  #0,d0
		bgt     large
		cmpi.l  #8175,d3
		ble.s   adding
		trap    #7
large           cmpi.l  #261999,d3
		ble.s   adding
		trap    #7
adding          movea.l (sp),a1        source address
		movea.l 4(sp),a2       destination address
cont_adding     move.l  d4,d0          ordinal value being added
		jsr     adelement_entry
		addq.l  #1,d4
		cmp.l   d3,d4
		bgt.s   stopping
		suba.l  #2,a2           restore to point at size field
		movea.l a2,a1           avoids src re-copy
		bra.s   cont_adding

asm_XXaDELEMENT EQU     *
	movea.l         (sp)+,a0        return address
	move.l          (sp)+,d0        element number to add to set
	movea.l         (sp)+,a1        source address
	movea.l         (sp),a2         destination address
	cmpi.l          #261999,d0      under max set ordinal value ?
	ble.s           strt
	    trap    #7
asm_XaDELEMENT EQU      *
	movea.l         (sp)+,a0        return address
	move.l          (sp)+,d0        element number to add to set
	movea.l         (sp)+,a1        source address
	movea.l         (sp),a2         destination address
	cmpi.l          #8175,d0        under default max set ordinal value ?
	ble.s           strt
	    trap    #7
strt    jsr             adelement_entry
	jmp             (a0)            return

adelement_entry  EQU  *
	move.w          (a1)+,d7        get set size of source
	move.w          d7,(a2)+        store size value
	cmpa.l          a2,a1           see if source and destination are equal
	beq.s           insert
* copy source set to the destination set
setcopy movea.l         a2,a3           save destination address
	move.w          d7,d6           save size for destination
	ble.s           insert          check for size of zero
rept    move.w          (a1)+,(a3)+     sets are always an even number of bytes
	subq.w          #2,d6
	bgt.s           rept
* insert an element in a set, adjusting the size of the destination if needed
insert  move.l          d0,d5
	lsr.l           #4,d0           word offset
	asl.l           #1,d0           word offset in bytes
	andi.l          #15,d5          bit offset from left end of word
	sub.l           #15,d5
	neg.l           d5              bit offset from right end
	move.w          d0,d1           compute final size into d1
	addq.w          #2,d1           put zeros in the two bytes containing
	move.w          d1,d2           the new bit if it is beyond current size
	sub.w           -2(a2),d1
	ble.s           exxiit
	move.w          d2,-2(a2)       store appropriate size for set
	lea             0(a2,d2),a3
zerout  clr.w           -(a3)
	subq.w          #2,d1
	bgt.s           zerout
exxiit  bclr            #3,d5           { received upgrade 9/9 }
	beq.s           skiipp
	bset            d5,0(a2,d0)
	rts
skiipp  bset            d5,1(a2,d0)
	rts
*------------------------------------------



	nosyms
	end
@


55.1
log
@Automatic bump of revision number for PWS version 3.25A
@
text
@@


54.3
log
@
pws2rcs automatic delta on Wed Aug 21 10:27:27 MDT 1991
@
text
@@


54.2
log
@
pws2rcs automatic delta on Wed Aug 21 09:35:48 MDT 1991
@
text
@d1 391
@


54.1
log
@Automatic bump of revision number for PWS version 3.24
@
text
@a0 391

*
*     STRING AND SET SUPPORT ROUTINES
*        -- SET SUPPPORT ADDED 3/18/85
*
	def fs_fwritestrint
	refa sysglobals,M68KTYPE                (rdq)

ioresult        equ sysglobals-22
istrovfl        equ 28

sign            equ d0
digits          equ d1

int             equ d2
high            equ d3
extend          equ d4
ten             equ d5
zero            equ d6
fieldwidth      equ d7

maxstrlen       equ d0

intlen          equ d2
strlen          equ d3
temp            equ d4
newindex        equ d5
index           equ d6

return          equ a0
straddr         equ a1
dindex          equ a2
sindex          equ a3
aindex          equ a4

l0      divu    ten,int
	swap    int
	add.w   zero,int
	move.b  int,-(dindex)
	addq    #1,digits
	clr.w   int
	swap    int
get_digits      equ *
	cmp.l   ten,int
	bcc.s   l0
	add.w   zero,int
	move.b  int,-(dindex)
	addq    #1,digits
	rts

fs_fwritestrint  equ *
	movea.l (sp)+,return
	move    (sp)+,fieldwidth        integer is to be right justified
	move.l  (sp)+,int               integer to be converted
	movea.l (sp)+,aindex            address of index into string
	movea.l (sp)+,straddr           address of string
	moveq   #0,maxstrlen
	move.b  (sp)+,maxstrlen         dimensioned size of string

	link    a6,#-12                 allocate space for local string
	move.b  maxstrlen,(sp)          save maxstrlen in local string
	lea     (a6),dindex             index to tail of local string
	moveq   #0,digits
	moveq   #10,ten
	moveq   #'0',zero

	tst.l   int
	slt     sign            remember whether negative
	bge.s   positive
	neg.l   int
positive moveq  #0,high
	cmp.l  #100000,int
	bcs.s   small           unsigned integer is less than 100000

* divide integer by 100000, save high part, keep low part in integer:

	lsr.l   #1,int          divide by 2
	TST.B   M68KTYPE
	BNE.S   DIV0
	move    sr,extend       remainder in extend bit
	BRA.S   DIV1
DIV0    DC.W    $42C4           MOVE    CCR,EXTEND  ??????      (rdq)
DIV1    divu    #50000,int      divide by 50000
	move.w  int,high        quotient is high part
	clr.w   int             zap quotient
	swap    int             get remainder
	move    extend,ccr      reconstruct full remainder
	roxl.l  #1,int          integer is now mod 100000

small   bsr.s   get_digits      extract low order digits

	tst.w   high            check for any high order digits
	beq.s   finish
l1      cmp     #5,digits       there should be at least 5 digits
	beq.s   l2
	move.b  zero,-(dindex)
	addq    #1,digits
	bra.s   l1
l2      move    high,int
	bsr.s   get_digits      get high order digits

finish  equ *

	move.l  (aindex),index
	ble.s   error                   error if index < 1

	moveq   #0,strlen
	move.b  (straddr),strlen        current length of string

	move.l  strlen,temp
	addq.l  #1,temp
	cmp.l   temp,index
	bgt.s   error           error if index > strlen(s)+1

	move    digits,intlen   compute minimum size of new integer
	tst.b   sign
	beq.s   nosign
	addq    #1,intlen       add 1 for minus sign
nosign  equ *

	tst     fieldwidth      field width is 12 if passed negative
	bge.s   nodefault
	moveq   #12,fieldwidth
nodefault equ *

	cmp   intlen,fieldwidth       fieldwidth is at least size of integer
	bge.s   bigger
	move    intlen,fieldwidth
bigger  equ *

	move.l  index,newindex          compute new index
	add     fieldwidth,newindex

	move    newindex,temp           string length is maximum of
	subq    #1,temp                         old length, newindex-1
	cmp     temp,strlen
	bge.s   longer
	move    temp,strlen
longer  equ     *

	clr     temp
	move.b  (sp),temp               retrieve strmax
	cmp     temp,strlen
	bgt.s   error                   error if new length > strmax(s)

	move.b  strlen,(straddr)        set new string length
	move.l  newindex,(aindex)                set new index

	lea     0(straddr,index),sindex

	sub     intlen,fieldwidth
	beq.s   nospaces
space   move.b  #' ',(sindex)+
	subq    #1,fieldwidth
	bgt.s   space
nospaces equ *

	tst.b  sign
	beq.s   nosgn
	move.b  #'-',(sindex)+
nosgn   equ *

digit   move.b  (dindex)+,(sindex)+
	subq    #1,digits
	bgt.s   digit

	clr.l   ioresult(a5)
strok   unlk    a6
	jmp     (return)

error   moveq   #istrovfl,d0
	move.l  d0,ioresult(a5)
	bra.s   strok

*------------------------------------------
	    DEF asm_Xin
*
* History:
*       01/29/85, bct, original (take-off of original "asm_in")
*------------------------------------------

asm_Xin         EQU     *               extended capacity set "in" operator

		movea.l (sp)+,a0        return address
		movea.l (sp)+,a1        set address
		move.l  (sp)+,d0        selector value
		blt     lfalse          selector < 0 ?
		move.l  d0,d1
		lsr.l   #3,d0           byte offset
		andi.l  #7,d1           bit offset
		cmp.w   (a1),d0         selector > setsize ?
		bge     lfalse
		move.b  2(a1,d0),d0     get selected byte
		lsl.b   d1,d0           construct boolean result
		lsr.b   #7,d0
		move.b  d0,-(sp)
		jmp     (a0)            return true
lfalse          clr.b   -(sp)
		jmp     (a0)            return false
		page


*------------------------------------------
	    DEF asm_XSETASSIGN
*
* History:
*       01/29/85, bct, original (take-off of original "asm_SETASSIGN")
*------------------------------------------
asm_XSETASSIGN   EQU *
* obtain sets from stack
	    movea.l    4(sp),a3          address of source
	    movea.l    8(sp),a4          address of dest
* place size in d7
	    move.w     (a3)+,d7          size of source
	    move.w     d7,(a4)           store size in dest
	    beq.s      done2             check for zero length set
	    move.l     12(sp),d0         dest min
	    beq.s      testhigh
	    moveq      #0,d2             zero count
	    move.w     d7,d3
	    movea.l    a3,a2
loop1       tst.b      (a2)+             find nonzero byte
	    bne.s      NZbyte
	    addq.w     #1,d2
	    subq.w     #1,d3
	    bgt.s      loop1

	    clr.w      (a4)
	    bra.s      done2

NZbyte      lsl.l      #3,d2             byte count * 8
	    cmp.l      d2,d0
	    ble.s      testhigh

	    move.b     -1(a2),d3         get first nonzero byte
loop2       lsl.b      #1,d3
	    bcs.s      NZbit             nonzero bit found
	    addq.l     #1,d2
	    bra.s      loop2

NZbit       cmp.l      d2,d0
	    ble.s      testhigh
	    trap       #7                error

testhigh    move.l     16(sp),d1         dest max
lastword    move.w     -2(a3,d7.w),d3    get last word of set
	    bne.s      NZword
	    subq.w     #2,d7
	    bgt.s      lastword
	    clr.w      (a4)              set was empty
	    bra.s      done2

NZword      move.w     d7,d2
	    ext.l      d2
	    lsl.l      #3,d2             byte count * 8
loop3       subq.l     #1,d2
	    lsr.w      #1,d3
	    bcc.s      loop3

	    cmp.l      d2,d1             last nonzero bit found
	    bge.s      ok
	    trap       #7                error
* perform assignment
ok          move.w     d7,(a4)+           store size in dest
	    asr.w      #2,d7              determine size in long words
	    bcc.s        evenn              even number of long words
	    move.w     (a3)+,(a4)+        move "odd" word
	    tst.w      d7                 min size single word?
	    beq.s        done2
EVENN       move.l     (a3)+,(a4)+        move long words
	    subq.w     #1,d7
	    bgt.s        evenn
DONE2       movea.l    (sp)+,a0            eliminate extra bytes in stack
	    adda.l     #16,sp
	    jmp        (a0)
	    page
*------------------------------------------
	   DEF asm_XaDELEMENT
	   DEF asm_XXaDELEMENT
	   DEF asm_XADDSETRANGE
	   DEF asm_XXADDSETRANGE
*
* History:
*       01/29/85, bct, original (take-off of originals
*                 "asm_ADDSETRANGE" and  "asm_aDELEMENT")
*------------------------------------------

asm_XXADDSETRANGE EQU   *
		move.w  #1,d0
		bra.s   hit_it
asm_XADDSETRANGE  EQU   *
		clr.w   d0
hit_it          movea.l (sp)+,a0        return address
		move.l  (sp)+,d3        hivalue
		move.l  (sp)+,d4        lowvalue
		cmp.l   d3,d4
		ble.s   addchk
*                                       Bug fix to Rev. 3.1 Pascal, now
*                                         copy src to dest (if not same)
*       ****    move.l  (sp),4(sp)        instead of changing addresses
		movea.l (sp),a1         src addr
		movea.l 4(sp),a2        dest addr
		cmpa.l   a1,a2          src = dest?
		beq     stopping
		move.w  (a1),d7         size of src
		addq.w  #2,d7           include size field on copy
cploop          move.w  (a1)+,(a2)+
		subq.w  #2,d7
		bgt.s   cploop
stopping        adda.l  #4,sp
		jmp     (a0)            return

addchk          cmpi.w  #0,d0
		bgt     large
		cmpi.l  #8175,d3
		ble.s   adding
		trap    #7
large           cmpi.l  #261999,d3
		ble.s   adding
		trap    #7
adding          movea.l (sp),a1        source address
		movea.l 4(sp),a2       destination address
cont_adding     move.l  d4,d0          ordinal value being added
		jsr     adelement_entry
		addq.l  #1,d4
		cmp.l   d3,d4
		bgt.s   stopping
		suba.l  #2,a2           restore to point at size field
		movea.l a2,a1           avoids src re-copy
		bra.s   cont_adding

asm_XXaDELEMENT EQU     *
	movea.l         (sp)+,a0        return address
	move.l          (sp)+,d0        element number to add to set
	movea.l         (sp)+,a1        source address
	movea.l         (sp),a2         destination address
	cmpi.l          #261999,d0      under max set ordinal value ?
	ble.s           strt
	    trap    #7
asm_XaDELEMENT EQU      *
	movea.l         (sp)+,a0        return address
	move.l          (sp)+,d0        element number to add to set
	movea.l         (sp)+,a1        source address
	movea.l         (sp),a2         destination address
	cmpi.l          #8175,d0        under default max set ordinal value ?
	ble.s           strt
	    trap    #7
strt    jsr             adelement_entry
	jmp             (a0)            return

adelement_entry  EQU  *
	move.w          (a1)+,d7        get set size of source
	move.w          d7,(a2)+        store size value
	cmpa.l          a2,a1           see if source and destination are equal
	beq.s           insert
* copy source set to the destination set
setcopy movea.l         a2,a3           save destination address
	move.w          d7,d6           save size for destination
	ble.s           insert          check for size of zero
rept    move.w          (a1)+,(a3)+     sets are always an even number of bytes
	subq.w          #2,d6
	bgt.s           rept
* insert an element in a set, adjusting the size of the destination if needed
insert  move.l          d0,d5
	lsr.l           #4,d0           word offset
	asl.l           #1,d0           word offset in bytes
	andi.l          #15,d5          bit offset from left end of word
	sub.l           #15,d5
	neg.l           d5              bit offset from right end
	move.w          d0,d1           compute final size into d1
	addq.w          #2,d1           put zeros in the two bytes containing
	move.w          d1,d2           the new bit if it is beyond current size
	sub.w           -2(a2),d1
	ble.s           exxiit
	move.w          d2,-2(a2)       store appropriate size for set
	lea             0(a2,d2),a3
zerout  clr.w           -(a3)
	subq.w          #2,d1
	bgt.s           zerout
exxiit  bclr            #3,d5           { received upgrade 9/9 }
	beq.s           skiipp
	bset            d5,0(a2,d0)
	rts
skiipp  bset            d5,1(a2,d0)
	rts
*------------------------------------------



	nosyms
	end
@


53.1
log
@Automatic bump of revision number for PWS version 3.24B
@
text
@@


52.1
log
@Automatic bump of revision number for PWS version 3.24A
@
text
@@


51.1
log
@Automatic bump of revision number for PWS version 3.24d
@
text
@@


50.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


49.1
log
@Automatic bump of revision number for PWS version 3.24b
@
text
@@


48.1
log
@Automatic bump of revision number for PWS version 3.24a
@
text
@@


47.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


46.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


45.1
log
@Automatic bump of revision number for PWS version 3.23C
@
text
@@


44.1
log
@Automatic bump of revision number for PWS version 3.23B
@
text
@@


43.1
log
@Automatic bump of revision number for PWS version 3.23aA
@
text
@@


42.1
log
@Automatic bump of revision number for PWS version 3.23e
@
text
@@


41.1
log
@Automatic bump of revision number for PWS version 3.23d
@
text
@@


40.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


39.1
log
@Automatic bump of revision number for PWS version 3.23b
@
text
@@


38.1
log
@Automatic bump of revision number for PWS version 3.23a
@
text
@@


37.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


36.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


35.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


34.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


33.1
log
@Automatic bump of revision number for PWS version 3.22D
@
text
@@


32.1
log
@Automatic bump of revision number for PWS version 3.22C
@
text
@@


31.1
log
@Automatic bump of revision number for PWS version 3.22B
@
text
@@


30.1
log
@Automatic bump of revision number for PWS version 3.22A
@
text
@@


29.1
log
@Automatic bump of revision number for PWS version 3.22b
@
text
@@


28.1
log
@Automatic bump of revision number for PWS version 3.3b
@
text
@@


27.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


26.1
log
@Automatic bump of revision number for PWS version 3.3 Synch
@
text
@@


25.1
log
@Automatic bump of revision number for PWS version 3.2Y
@
text
@@


24.1
log
@Automatic bump of revision number for PWS version 3.2
@
text
@@


23.1
log
@Automatic bump of revision number for PWS version 3.2P
@
text
@@


22.1
log
@Automatic bump of revision number for PWS version 3.2N
@
text
@@


21.1
log
@Automatic bump of revision number for PWS version 3.2M
@
text
@@


20.1
log
@Automatic bump of revision number for PWS version 3.2L
@
text
@@


19.1
log
@Automatic bump of revision number for PWS version 3.2K
@
text
@@


18.1
log
@Automatic bump of revision number for PWS version 3.2J
@
text
@@


17.1
log
@Automatic bump of revision number for PWS version 3.2I+
@
text
@@


16.1
log
@Automatic bump of revision number for PWS version 3.2I
@
text
@@


15.1
log
@Automatic bump of revision number for PWS version 3.2H
@
text
@@


14.1
log
@Automatic bump of revision number for PWS version 3.2G
@
text
@@


13.1
log
@Automatic bump of revision number for PWS version 3.2F
@
text
@@


12.1
log
@Automatic bump of revision number for PWS version 3.2E
@
text
@@


11.1
log
@Automatic bump of revision number for PWS version 3.2D
@
text
@@


10.1
log
@Automatic bump of revision number for PWS version 3.2C
@
text
@@


9.1
log
@Automatic bump of revision number for PWS version 3.2B
@
text
@@


8.1
log
@Automatic bump of revision number for PWS version 3.2A
@
text
@@


7.1
log
@Automatic bump of revision number for PWS version 3.2l
@
text
@@


6.1
log
@Automatic bump of revision number for PWS version 3.2k
@
text
@@


5.1
log
@Automatic bump of revision number for PWS version 3.2j
@
text
@@


4.1
log
@Automatic bump of revision number for PWS version 3.2i
@
text
@@


3.1
log
@Automatic bump of revision number for PWS version 3.2h
@
text
@@


2.1
log
@Auto bump rev number to 2.1 for sys 3.2e.
@
text
@@


1.1
log
@Initial revision
@
text
@@
