MUDDLE/arith.58

   1 TITLE ARITHMETIC PRIMITIVES FOR MUDDLE
   2
   3 ;BKD
   4
   5 ;DEFINES MUDDLE PRIMITIVES:   FIX,FLOAT,ATAN,IEXP,LOG,
   6 ;       G?,L?,0?,1?,+,-,*,/,MAX,MIN,ABS,SIN,COS,SQRT,RANDOM,
   7 ;       TIME,SORT.
   8
   9 RELOCATABLE
  10
  11 .INSRT MUDDLE >
  12
  13 O=0
  14
  15
  16 DEFINE  TYP1
  17         (AB) TERMIN
  18 DEFINE VAL1
  19         (AB)+1 TERMIN
  20
  21 DEFINE  TYP2
  22         (AB)+2 TERMIN
  23 DEFINE  VAL2
  24         (AB)+3 TERMIN
  25
  26 DEFINE  TYP3
  27         (AB)+4 TERMIN
  28 DEFINE  VAL3
  29         (AB)+5 TERMIN
  30
  31 DEFINE  TYPN
  32         (D) TERMIN
  33 DEFINE  VALN
  34         (D)+1 TERMIN
  35
  36
  37 YES:    MOVSI   A,TATOM ;RETURN PATH FOR 'TRUE'
  38         MOVE    B,MQUOTE T
  39         JRST FINIS
  40
  41 NO:     MOVSI   A,TFALSE        ;RETURN PATH FOR 'FALSE'
  42         MOVEI   B,NIL
  43         JRST FINIS
  44
  45 \f;ERROR RETURNS AND OTHER UTILITY ROUTINES
  46
  47 OVRFLW==10
  48 OVRFLD: PUSH    TP,$TATOM
  49         PUSH    TP,MQUOTE OVERFLOW
  50         JRST    CALER1
  51
  52 ARGCHK:                 ;CHECK FOR SINGLE FIXED OR FLOATING
  53                         ;ARGUMENT IF FIXED CONVERT TO FLOATING
  54                         ;RETURN FLOATING ARGRUMENT IN B ALWAYS
  55         ENTRY   1
  56         HLRZ    C,TYP1
  57         MOVE    B,VAL1
  58         CAIN    C,TFLOAT        ;FLOATING?
  59         POPJ P, ;YES, RETURN
  60         CAIE    C,TFIX  ;FIXED?
  61         JRST    WTYP    ;NO, ERROR
  62         JSP A,BFLOAT    ;YES, CONVERT TO FLOATING AND RETURN
  63         POPJ P,
  64
  65 OUTRNG: PUSH    TP,$TATOM
  66         PUSH    TP,MQUOTE ARGUMENT-OUT-OF-RANGE
  67         JRST    CALER1
  68
  69 NSQRT:  PUSH TP,$TATOM
  70         PUSH TP,MQUOTE NEGATIVE-ARGUMENT
  71         JRST CALER1"
  72
  73 WTYP:   PUSH TP,$TATOM
  74         PUSH TP,MQUOTE WRONG-TYPE
  75         JRST CALER1
  76
  77 DEFINE MFLOAT AC
  78         IDIVI AC, 400000
  79         FSC     AC+1,233
  80         FSC     AC,254
  81         FADR AC,AC+1
  82         TERMIN
  83
  84 BFLOAT: MFLOAT  B
  85         JRST    (A)
  86
  87 OFLOAT: MFLOAT  O
  88         JRST    (C)
  89
  90 BFIX:   MULI    B,400
  91         TSC     B,B
  92         ASH     C,(B)-243
  93         MOVE    B,C
  94         JRST    (A)
  95
  96 \f;DISPATCH TABLES USED TO CONTROL THE FLOW OF THE VARIOUS PRIMITIVES
  97
  98 TABLE2: NO      ;TABLE2 (0)
  99 TABLE3: YES     ;TABLE2 (1)  &  TABLE3 (0)
 100         NO      ;TABLE2 (2)
 101
 102
 103 FUNC:           JSP     A,BFIX
 104         JSP     A,BFLOAT
 105         SUB     B,VALN
 106         IDIV    B,VALN
 107         ADD     B,VALN
 108         IMUL    B,VALN
 109         JSP     C,SWITCH
 110         JSP     C,SWITCH
 111
 112 FLFUNC==.-2
 113         FSBR    B,O
 114         FDVR    B,O
 115         FADR    B,O
 116         FMPR    B,O
 117         JSP     C,FLSWCH
 118         JSP     C,FLSWCH
 119 \f;PRIMITIVES FLOAT AND FIX
 120
 121 MFUNCTION       FIX,SUBR
 122         MOVEI   E,0
 123         JRST    TRANS
 124
 125 MFUNCTION       FLOAT,SUBR
 126         MOVEI   E,1
 127
 128 TRANS:  ENTRY   1
 129         MOVE    A,TYP1
 130         MOVE    B,VAL1
 131         CAMN    A,TYPS(E)+1     ;SAME TYPE ARGUMENT?
 132         JRST    FINIS
 133         CAME    A,TYPS(E)       ;correct type argument ?
 134         JRST    WTYP
 135         XCT     FUNC(E) ;perform appropriate operation
 136         MOVE    A,TYPS(E)+1     ;save this new type
 137 JRST FINIS
 138
 139 TYPS:           TFLOAT,,0
 140         TFIX,,0
 141         TFLOAT,,0
 142
 143 MFUNCTION       ABS,SUBR
 144         ENTRY   1
 145         MOVE    A,TYP1
 146         CAME    A,$TFIX
 147         CAMN    A,$TFLOAT
 148         JRST    MOVIT
 149         JRST    WTYP
 150 MOVIT:  MOVM    B,VAL1  ;GET ABSOLUTE VALUE OF ARGUMENT
 151         JRST    FINIS
 152
 153 MFUNCTION       MOD,SUBR
 154         ENTRY   2
 155         MOVSI   A,TFIX
 156         CAME    A,TYP1  ;FIRST ARG FIXED ?
 157         JRST    WTYP
 158         CAME    A,TYP2  ;SECOND ARG FIXED ?
 159         JRST    WTYP
 160         MOVE    B,VAL1
 161         IDIV    B,VAL2  ;FORM QUOTIENT & REMAINDER
 162         JUMPGE  C,.+2   ;Only return positive remainders
 163         ADD     C,VAL2
 164         MOVE    B,C     ;RETURN REMAINDER
 165         JRST    FINIS
 166 \f;PRIMITIVES PLUS, DIFFERENCE, TIMES, DIVIDE, MIN, AND MAX
 167
 168 MFUNCTION       MIN,SUBR
 169         MOVEI   E,6
 170         JRST    GOPT
 171
 172         MFUNCTION       MAX,SUBR
 173         MOVEI   E,7
 174 GOPT:   ENTRY
 175         MOVE    D,AB    ;ARGUMENT POINTER
 176         JUMPL   D,MINMAX        ;ANY ARGUMENTS AT ALL ?
 177         MOVSI   A,TFLOAT        ;DEFAULT TYPE
 178         MOVE    B,INFIN(E)      ;DEFAULT VALUE + OR - "LARGE NUMBER"
 179         JRST    FINIS
 180 INFIN==.-6
 181         377777,,-1
 182         400000,,1
 183
 184 MFUNCTION       DIVIDE,SUBR,[/]
 185         MOVEI   E,3
 186         JRST    ARITH0
 187
 188 MFUNCTION       DIFFERENCE,SUBR,[-]
 189         MOVEI   E,2
 190         JRST    ARITH0
 191
 192 MFUNCTION       TIMES,SUBR,[*]
 193         MOVEI   E,5
 194         JRST    ARITH0
 195
 196 MFUNCTION       PLUS,SUBR,[+]
 197         MOVEI   E,4
 198
 199 ARITH0: ENTRY
 200         MOVE    D,AB    ;argument pointer
 201         CAMGE   D,[-2,,0]       ;LESS THAN TWO ARGUMENTS ?
 202         JRST    MINMAX
 203         MOVSI   A,TFIX  ;initial type of result
 204         MOVE    B,E     ;initial accumulator contents for zero & one argument
 205         TRZ     B,-2
 206         JRST    MINMAX+3
 207 MINMAX: MOVE    A,TYP1
 208         MOVE    B,VAL1  ;initial value of accumulator for more than one argument is first value
 209         ADD     D,[2,,2]        ;UPDATE ARGUMENT POINTER
 210         JUMPGE  D,FINIS ;ANY MORE ARGUMENTS ?
 211         JFCL    OVRFLW,.+1
 212         CAME    A,$TFIX ;WAS THE FIRST ARGUMENT FIXED ?
 213         JRST    ARITH3
 214 ARITH1: CAME    A,TYPN  ;next argument fixed ?
 215         JRST    ARITH2
 216         XCT     FUNC(E) ;PERFORM APPROPRIATE OPERATION
 217         ADD     D,[2,,2]        ;UPDATE ARGUMENT POINTER
 218         JUMPL   D,ARITH1        ;repeat for next argument if any
 219         JFCL    OVRFLW,OVRFLD
 220         JRST    FINIS
 221 \f;CONTINUATION OF PLUS,TIMES, ETC.
 222
 223 ARITH3: CAME    A,$TFLOAT       ;was the first argument floating ?
 224         JRST    WTYP
 225         SKIPA
 226
 227 ARITH2: JSP     A,BFLOAT        ;float accumulator contents
 228         MOVE    C,TYPN  ;get next argument's type
 229         MOVE    O,VALN  ;get next argument's value
 230         CAMN    C,$TFLOAT       ;floating ?
 231         JRST    OPERATE
 232         CAME    C,$TFIX ;fixed ?
 233         JRST    WTYP
 234         JSP     C,OFLOAT        ;go float this fixed argument
 235 OPERATE:        XCT     FLFUNC(E)       ;perform appropriate operation
 236         ADD     D,[2,,2]        ;UPDATE ARGUMENT POINTER
 237         JUMPL   D,ARITH2+1      ;repeat for next argument if any
 238         JFCL    OVRFLW,OVRFLD
 239         MOVSI   A,TFLOAT
 240         JRST FINIS
 241
 242 SWITCH: XCT     COMPAR(E)       ;FOR MAX & MIN TESTING
 243         MOVE    B,VALN
 244         JRST    (C)
 245 COMPAR==.-6
 246         CAMLE   B,VALN
 247         CAMGE   B,VALN
 248
 249 FLSWCH: XCT     FLCMPR(E)
 250         MOVE    B,O
 251         JRST    (C)
 252 FLCMPR==.-6
 253         CAMLE   B,O
 254         CAMGE   B,O
 255 \f;PRIMITIVES ONEP AND ZEROP
 256
 257 MFUNCTION       ONEP,SUBR,[1?]
 258         MOVEI   E,1
 259         JRST    JOIN
 260
 261 MFUNCTION       ZEROP,SUBR,[0?]
 262         MOVEI   E,
 263
 264 JOIN:   ENTRY 1
 265         MOVE    A,TYP1
 266         CAMN    A,$TFIX ;fixed ?
 267         JRST    TESTFX
 268         CAME    A,$TFLOAT       ;floating ?
 269         JRST    WTYP
 270         MOVE    B,VAL1
 271         CAMN    B,NUMBR(E)      ;equal to correct value ?
 272         JRST    YES
 273         JRST    NO
 274
 275 TESTFX: CAMN    E,VAL1  ;equal to correct value ?
 276         JRST    YES
 277         JRST    NO
 278
 279 NUMBR:  0       ;FLOATING PT  ZERO
 280         201400,,0       ;FLOATING PT ONE
 281 \f;PRIMITIVES LESSP AND GREATERP
 282
 283
 284 MFUNCTION       LESSP,SUBR,[L?]
 285         MOVEI   E,1
 286         JRST    ARGS
 287
 288 MFUNCTION       GREATERP,SUBR,[G?]
 289         MOVEI   E,0
 290
 291 ARGS:   ENTRY 2
 292         MOVE    O,VAL1
 293         MOVE    A,TYP1
 294         MOVE    B,VAL2
 295         SETO    D,      ;used for flow of control in this routine
 296         CAMN    A,$TFLOAT
 297         AOJA    D,CONT
 298         CAME    A,$TFIX
 299         JUMPL   D,WTYP
 300 CONT:   MOVE    A,TYP2
 301         CAMN    A,$TFIX
 302         AOJE    D,FIXFIX        ;are both arguments fixed
 303         CAME    A,$TFLOAT
 304         JRST    FLTFIX
 305         JUMPE   D,FLTFLT        ;are both arguments floating ?
 306         JSP     C,OFLOAT        ;go float the first argument
 307 FLTFLT: FSBR    O,B     ;both arguments are floating here
 308 TEST:   JUMPL   O,@TABLE2(E)
 309         JUMPG   O,@TABLE3(E)
 310         JRST    NO
 311
 312 FLTFIX: JUMPLE  D,WTYP
 313         JSP     A,BFLOAT        ;go float the second argument
 314         JRST    FLTFLT
 315
 316 FIXFIX: SUB     O,B     ;both arguments are fixed here
 317         JRST    TEST
 318
 319 MFUNCTION RANDOM,SUBR
 320         ENTRY
 321         HLRE    A,AB
 322         CAMGE   A,[-4]  ;At most two arguments to random to set seeds
 323         JRST    WNA
 324         JRST    RANDGO(A)
 325         MOVE    B,VAL2  ;Set second seed
 326         MOVEM   B,RLOW
 327         MOVE    A,VAL1  ;Set first seed
 328         MOVEM   A,RHI
 329 RANDGO: MOVE B,RLOW     ;FREDKIN'S RANDOM NUMBER GENERATOR.
 330         MOVE A,RHI
 331         MOVEM A,RLOW
 332         LSHC A,-43
 333         XORB B,RHI
 334         MOVSI A,TFIX
 335         JRST FINIS
 336 RHI:    267762113337
 337 RLOW:   155256071112
 338 \fMFUNCTION SQRT,SUBR
 339         ENTRY 1
 340         MOVE B,1(AB)
 341         HLRZ A,(AB)
 342         CAIN A,TFLOAT
 343         JRST SQ1
 344         CAIE A,TFIX
 345         JRST WTYP
 346         JSP A,BFLOAT
 347 SQ1:    JUMPL B,NSQRT
 348
 349         MOVE A,B
 350         ASH B,-1
 351         FSC B,100
 352 SQ2:    MOVE C,B        ;NEWTON'S METHOD, SPECINER'S HACK.
 353         FDVRM A,B
 354         FADRM C,B
 355         FSC B,-1
 356         CAME C,B
 357         JRST SQ2
 358         MOVSI A,TFLOAT
 359         JRST FINIS
 360
 361
 362 MFUNCTION COS,SUBR
 363         ENTRY 1
 364         MOVE B,1(AB)
 365         HLRZ A,(AB)
 366         CAIN A,TFLOAT
 367         JRST COS1
 368         CAIE A,TFIX
 369         JRST WTYP
 370         JSP A,BFLOAT
 371 COS1:   FADR B,[1.570796326]    ;COS(X)=SIN (X+PI/2)
 372         PUSHJ P,.SIN
 373         MOVSI A,TFLOAT
 374         JRST FINIS
 375
 376 MFUNCTION SIN,SUBR
 377         ENTRY 1
 378         MOVE B,1(AB)
 379         HLRZ A,(AB)
 380         CAIN A,TFLOAT
 381         JRST SIN1
 382         CAIE A,TFIX
 383         JRST WTYP
 384         JSP A,BFLOAT
 385 SIN1:   PUSHJ P,.SIN
 386         MOVSI A,TFLOAT
 387         JRST FINIS
 388
 389 .SIN:   MOVM A,B
 390         CAMG A,[.0001]
 391         POPJ P,         ;GOSPER'S RECURSIVE SIN.
 392         FDVR B,[-3.0]   ;SIN(X)=4*SIN(X/-3)**3-3*SIN(X/-3)
 393         PUSHJ P,.SIN
 394         FSC A,1
 395         FMPR A,A
 396         FADR A,[-3.0]
 397         FMPRB A,B
 398         POPJ P,
 399 MFUNCTION       LOG,SUBR
 400         PUSHJ P,ARGCHK  ;LEAVES ARGUMENT IN B
 401         JUMPLE  B,OUTRNG
 402         LDB     D,[331100,,B]   ;GRAB EXPONENT
 403         SUBI    D,201   ;REMOVE BIAS
 404         TLZ     B,777000        ;SET EXPONENT
 405         TLO     B,201000        ; TO 1
 406         MOVE    A,B
 407         FSBR    A,RT2
 408         FADR    B,RT2
 409         FDVB    A,B
 410         FMPR    B,B
 411         MOVE    C,[0.434259751]
 412         FMPR    C,B
 413         FADR    C,[0.576584342]
 414         FMPR    C,B
 415         FADR    C,[0.961800762]
 416         FMPR    C,B
 417         FADR    C,[2.88539007]
 418         FMPR    C,A
 419         FADR    C,[0.5]
 420
 421         MOVE    B,D
 422         FSC     B,233
 423         FADR    B,C
 424         FMPR    B,[0.693147180] ;LOG E OF 2
 425         MOVSI   A,TFLOAT
 426         JRST    FINIS
 427 RT2:    1.41421356
 428 \fMFUNCTION      ATAN,SUBR
 429         PUSHJ P,ARGCHK
 430         MOVM    D,B
 431         CAMG    D,[0.4^-8]      ;SMALL ENOUGH SO ATAN(X)=X?
 432         JRST    ATAN3   ;YES
 433         CAML    D,[7.0^7]       ;LARGE ENOUGH SO THAT ATAN(X)=PI/2?
 434         JRST    ATAN1   ;YES
 435         MOVN    C,[1.0]
 436         CAMLE   D,[1.0] ;IS ABS(X)<1.0?
 437         FDVM    C,D     ;NO,SCALE IT DOWN
 438         MOVE    B,D
 439         FMPR    B,B
 440         MOVE    C,[1.44863154]
 441         FADR    C,B
 442         MOVE    A,[-0.264768620]
 443         FDVM    A,C
 444         FADR    C,B
 445         FADR    C,[3.31633543]
 446         MOVE    A,[-7.10676005]
 447         FDVM    A,C
 448         FADR    C,B
 449         FADR    C,[6.76213924]
 450         MOVE    B,[3.70925626]
 451         FDVR    B,C
 452         FADR    B,[0.174655439]
 453         FMPR    B,D     ;
 454         JUMPG   D,ATAN2 ;WAS ARG SCALED?
 455         FADR    B,PI2   ;YES,  ATAN(X)=PI/2-ATAN(1/X)
 456         JRST    ATAN2
 457 ATAN1:  MOVE    B,PI2
 458 ATAN2:  SKIPGE  1(AB)   ;WAS INPUT NEGATIVE?
 459         MOVNS   B               ;YES,COMPLEMENT
 460 ATAN3:  MOVSI   A,TFLOAT
 461         JRST    FINIS
 462 PI2:    1.57079632
 463 \fMFUNCTION      IEXP,SUBR,[EXP]
 464         PUSHJ P,ARGCHK  ;LEAVE FLOATING POINT ARG IN B
 465         MOVM    A,B
 466         SETZM   B
 467         FMPR    A,[0.434294481] ;LOG BASE 10 OF E
 468         MOVE    D,[1.0]
 469         CAMG    A,D
 470         JRST    RATEX
 471         MULI    A,400
 472         ASHC    B,-243(A)
 473         CAILE   B,43
 474         JRST    OUTRNG
 475         CAILE   B,7
 476         JRST    EXPR2
 477 EXPR1:  FMPR    D,FLOAP1(B)
 478         LDB     A,[103300,,C]
 479         SKIPE   A
 480         TLO     A,177000
 481         FADR    A,A
 482 RATEX:  MOVEI   B,7
 483         SETZM   C
 484 RATEY:  FADR    C,COEF2-1(B)
 485         FMPR    C,A
 486         SOJN    B,RATEY
 487         FADR    C,[1.0]
 488         FMPR    C,C
 489         FMPR    D,C
 490         MOVE    B,[1.0]
 491         SKIPL   1(AB)   ;SKIP IF INPUT NEGATIVE
 492         SKIPN   B,D
 493         FDVR    B,D
 494         MOVSI   A,TFLOAT
 495         JRST    FINIS
 496 EXPR2:  LDB     E,[030300,,B]
 497         ANDI    B,7
 498         MOVE    D,FLOAP1(E)
 499         FMPR    D,D     ;TO THE 8TH POWER
 500         FMPR    D,D
 501         FMPR    D,D
 502         JRST    EXPR1
 503
 504 COEF2:  1.15129278
 505         0.662730884
 506         0.254393575
 507         0.0729517367
 508         0.0174211199
 509         2.55491796^-3
 510         9.3264267^-4
 511
 512 FLOAP1: 1.0
 513         10.0
 514         100.0
 515         1000.0
 516         10000.0
 517         100000.0
 518         1000000.0
 519         10000000.0
 520 \f;routine to sort lists or vectors of either fixed point or floating numbers
 521 ;the components are interchanged repeatedly to acheive the sort
 522 ;first arg:     the structure to be sorted
 523 ;if no second arg sort in descending order
 524 ;second arg:    if false then sort in ascending order
 525 ;               else sort in descending order
 526
 527 MFUNCTION       SORT,SUBR
 528         ENTRY
 529         HLRZ    A,AB
 530         CAIGE   A,-4    ;Only two arguments allowed
 531         JRST    WNA
 532         MOVE    O,DESCEND       ;Set up "O" to test for descending order as default condition
 533         CAIE    A,-4    ;Optional second argument?
 534         JRST    .+4
 535         HLRZ    B,TYP2  ;See if it is other than false
 536         CAIN    B,TFALSE
 537         MOVE    O,ASCEND        ;Set up "O" to test for ascending order
 538         HLRZ    A,TYP1  ;CHECK TYPE OF FIRST ARGUMENT
 539         CAIN    A,TLIST
 540         JRST    LSORT
 541         CAIN    A,TVEC
 542         JRST    VSORT
 543         JRST    WTYP
 544
 545
 546
 547
 548 GOBACK: MOVE    A,TYP1  ;RETURN THE SORTED ARGUMENT AS VALUE
 549         MOVE    B,VAL1
 550         JRST    FINIS
 551
 552 DESCEND:        CAMG    C,(A)+1
 553 ASCEND:         CAML    C,(A)+1
 554 \f;ROUTINE TO SORT LISTS IN NUMERICAL ORDER
 555
 556 LSORT:  MOVE    A,VAL1
 557         JUMPE   A,GOBACK        ;EMPTY LIST?
 558         HLRZ    B,(A)   ;TYPE OF FIRST COMPONENT
 559         CAIE    B,TFIX
 560         CAIN    B,TFLOAT
 561         SKIPA
 562         JRST    WTYP
 563         MOVEI   E,0     ;FOR COUNT OF LENGTH OF LIST
 564 LCOUNT: JUMPE   A,LLSORT        ;REACHED END OF LIST?
 565         MOVE    A,(A)   ;NEXT COMPONENT
 566         TLZ     A,(B)   ;SAME TYPE AS FIRST COMPONENT?
 567         TLNE    A,-1
 568         JRST    WTYP
 569         AOJA    E,LCOUNT        ;INCREMENT COUNT AND CONTINUE
 570
 571 LLSORT: SOJE    E,GOBACK        ;FINISHED WITH SORTING?
 572         HRRZ    A,VAL1  ;START THIS LOOP OF SORTING AT THE BEGINNING
 573         MOVEM   E,(P)+1 ;Save the iteration depth
 574 CLSORT: HRRZ    B,(A)   ;NEXT COMPONENT
 575         MOVE    C,(B)+1 ;ITS VALUE
 576         XCT     O       ;ARE THESE TWO COMPONENTS IN ORDER?
 577         JRST    .+4
 578         MOVE    D,(A)+1 ;INTERCHANGE THEM
 579         MOVEM   D,(B)+1
 580         MOVEM   C,(A)+1
 581         MOVE    A,B     ;MAKE THE COMPONENT IN "B" THE CURRENT ONE
 582         SOJG    E,CLSORT
 583         MOVE    E,(P)+1 ;Restore the iteration depth
 584         JRST    LLSORT
 585 \f;ROUTINE TO SORT VECTORS IN NUMERICAL ORDER
 586
 587 VSORT:  HLRE    D,VAL1  ;GET COUNT FIELD OF VECTOR
 588         IDIV    D,[-2]  ;LENGTH
 589         JUMPE   D,GOBACK        ;EMPTY VECTOR?
 590         MOVE    E,D     ;SAVE LENGTH IN "E"
 591         HRRZ    A,VAL1  ;POINTER TO VECTOR
 592         MOVE    B,(A)   ;TYPE OF FIRST COMPONENT
 593         CAME    B,$TFIX
 594         CAMN    B,$TFLOAT
 595         SKIPA
 596         JRST    WTYP
 597         SOJLE   D,GOBACK        ;IF ONLY ONE COMPONENT THEN FINISHED
 598 VCOUNT: ADDI    A,2     ;CHECK NEXT COMPONENT
 599         CAME    B,(A)   ;SAME TYPE AS FIRST COMPONENT?
 600         JRST    WTYP
 601         SOJG    D,VCOUNT        ;CONTINUE WITH NEXT COMPONENT
 602
 603 VVSORT: SOJE    E,GOBACK        ;FINISHED SORTING?
 604         HRRZ    A,VAL1  ;START THIS LOOP OF SORTING AT THE BEGINNING
 605         MOVEM   E,(P)+1 ;Save the iteration depth
 606 CVSORT: MOVE    C,(A)+3 ;VALUE OF NEXT COMPONENT
 607         XCT     O       ;ARE THESE TWO COMPONENTS IN ORDER?
 608         JRST    .+4
 609         MOVE    D,(A)+1 ;INTERCHANGE THEM
 610         MOVEM   D,(A)+3
 611         MOVEM   C,(A)+1
 612         ADDI    A,2     ;UPDATE THE CURRENT COMPONENT
 613         SOJG    E,CVSORT
 614         MOVE    E,(P)+1 ;Restore the iteration depth
 615         JRST    VVSORT
 616
 617
 618 MFUNCTION TIME,SUBR
 619         ENTRY 0
 620         .RDTIME B,      ;Get time since SYSTEM up
 621         MOVSI   A,TFIX
 622         JRST    FINIS
 623
 624
 625 END
 626 \f\f\ 3\f