<mdl.int>/arith.mid.94

   1 TITLE ARITHMETIC PRIMITIVES FOR MUDDLE
   2
   3 .GLOBAL HI,RLOW,CPLUS,CMINUS,CTIMES,CDIVID,CFIX,CFLOAT
   4 .GLOBAL CLQ,CGQ,CLEQ,CGEQ,C1Q,C0Q,CMAX,CMIN,CABS,CMOD,CCOS,CSIN,CATAN,CLOG
   5 .GLOBAL CEXP,CSQRT,CTIME,CORB,CXORB,CANDB,CEQVB,CRAND,CLSH,CROT,
   6 .GLOBAL SAT,BFLOAT,FLGSET
   7
   8 ;BKD
   9
  10 ;DEFINES MUDDLE PRIMITIVES:   FIX,FLOAT,ATAN,IEXP,LOG,
  11 ;       G?,L?,0?,1?,+,-,*,/,MAX,MIN,ABS,SIN,COS,SQRT,RANDOM,
  12 ;       TIME,SORT.
  13
  14 RELOCATABLE
  15
  16 .INSRT MUDDLE >
  17
  18 O=0
  19
  20
  21 DEFINE  TYP1
  22         (AB) TERMIN
  23 DEFINE VAL1
  24         (AB)+1 TERMIN
  25
  26 DEFINE  TYP2
  27         (AB)+2 TERMIN
  28 DEFINE  VAL2
  29         (AB)+3 TERMIN
  30
  31 DEFINE  TYP3
  32         (AB)+4 TERMIN
  33 DEFINE  VAL3
  34         (AB)+5 TERMIN
  35
  36 DEFINE  TYPN
  37         (D) TERMIN
  38 DEFINE  VALN
  39         (D)+1 TERMIN
  40
  41
  42 YES:    MOVSI   A,TATOM         ;RETURN PATH FOR 'TRUE'
  43         MOVE    B,IMQUOTE T
  44         AOS     (P)
  45         POPJ    P,
  46
  47 NO:     MOVSI   A,TFALSE        ;RETURN PATH FOR 'FALSE'
  48         MOVEI   B,NIL
  49         POPJ    P,
  50
  51 \f;ERROR RETURNS AND OTHER UTILITY ROUTINES
  52
  53 OVRFLW==10
  54 OVRFLD: ERRUUO  EQUOTE OVERFLOW
  55
  56 CARGCH: GETYP   0,A             ; GET TYPE
  57         CAIN    0,TFLOAT
  58         POPJ    P,
  59         JSP     A,BFLOAT
  60         POPJ    P,
  61
  62 ARGCHK:                 ;CHECK FOR SINGLE FIXED OR FLOATING
  63                         ;ARGUMENT IF FIXED CONVERT TO FLOATING
  64                         ;RETURN FLOATING ARGRUMENT IN B ALWAYS
  65         ENTRY   1
  66         GETYP   C,TYP1
  67         MOVE    B,VAL1
  68         CAIN    C,TFLOAT        ;FLOATING?
  69         POPJ    P,              ;YES, RETURN
  70         CAIE    C,TFIX          ;FIXED?
  71         JRST    WTYP1           ;NO, ERROR
  72         JSP     A,BFLOAT        ;YES, CONVERT TO FLOATING AND RETURN
  73         POPJ    P,
  74
  75 OUTRNG: ERRUUO  EQUOTE ARGUMENT-OUT-OF-RANGE
  76
  77 NSQRT:  ERRUUO  EQUOTE NEGATIVE-ARGUMENT
  78
  79 DEFINE MFLOAT AC
  80         IDIVI   AC,400000
  81         FSC     AC+1,233
  82         FSC     AC,254
  83         FADR    AC,AC+1
  84         TERMIN
  85
  86 BFLOAT: MFLOAT  B
  87         JRST    (A)
  88
  89 OFLOAT: MFLOAT  O
  90         JRST    (C)
  91
  92 BFIX:   MULI    B,400
  93         TSC     B,B
  94         ASH     C,(B)-243
  95         MOVE    B,C
  96         JRST    (A)
  97
  98 \f;DISPATCH TABLES USED TO CONTROL THE FLOW OF THE VARIOUS PRIMITIVES
  99
 100 TABLE2: SETZ    NO              ;TABLE2 (0)
 101 TABLE3: SETZ    YES             ;TABLE2 (1)  &  TABLE3 (0)
 102         SETZ    NO              ;TABLE2 (2)
 103         SETZ    YES
 104         SETZ    NO
 105
 106 TABLE4: SETZ    NO
 107         SETZ    NO
 108         SETZ    YES
 109         SETZ    YES
 110
 111
 112
 113 FUNC:   JSP     A,BFIX
 114         JSP     A,BFLOAT
 115         SUB     B,VALN
 116         IDIV    B,VALN
 117         ADD     B,VALN
 118         IMUL    B,VALN
 119         JSP     C,SWITCH
 120         JSP     C,SWITCH
 121
 122
 123
 124 FLFUNC==.-2
 125         FSBR    B,O
 126         FDVR    B,O
 127         FADR    B,O
 128         FMPR    B,O
 129         JSP     C,FLSWCH
 130         JSP     C,FLSWCH
 131
 132 DEFVAL==.-2
 133         0
 134         1
 135         0
 136         1
 137         377777,,-1
 138         400000,,1
 139
 140 DEFTYP==.-2
 141         TFIX,,
 142         TFIX,,
 143         TFIX,,
 144         TFIX,,
 145         TFLOAT,,
 146         TFLOAT,,
 147 \f;PRIMITIVES FLOAT AND FIX
 148
 149 IMFUNCTION      FIX,SUBR
 150
 151         ENTRY   1
 152
 153         JSP     C,FXFL
 154         MOVE    B,1(AB)
 155         CAIE    A,TFIX
 156         JSP     A,BFIX
 157         MOVSI   A,TFIX
 158         JRST    FINIS
 159
 160 IMFUNCTION      FLOAT,SUBR
 161
 162         ENTRY   1
 163
 164         JSP     C,FXFL
 165         MOVE    B,1(AB)
 166         CAIE    A,TFLOAT
 167         JSP     A,BFLOAT
 168         MOVSI   A,TFLOAT
 169         JRST    FINIS
 170
 171 CFIX:   GETYP   0,A
 172         CAIN    0,TFIX
 173         POPJ    P,
 174         JSP     A,BFIX
 175         MOVSI   A,TFIX
 176         POPJ    P,
 177
 178 CFLOAT: GETYP   0,A
 179         CAIN    0,TFLOAT
 180         POPJ    P,
 181         JSP     A,BFLOAT
 182         MOVSI   A,TFLOAT
 183         POPJ    P,
 184
 185 FXFL:   GETYP   A,(AB)
 186         CAIE    A,TFIX
 187         CAIN    A,TFLOAT
 188         JRST    (C)
 189         JRST    WTYP1
 190
 191
 192 MFUNCTION       ABS,SUBR
 193         ENTRY   1
 194         GETYP   A,TYP1
 195         CAIE    A,TFIX
 196         CAIN    A,TFLOAT
 197         JRST    MOVIT
 198         JRST    WTYP1
 199 MOVIT:  MOVM    B,VAL1          ;GET ABSOLUTE VALUE OF ARGUMENT
 200 AFINIS: HRLZS   A               ;MOVE TYPE CODE INTO LEFT HALF
 201         JRST    FINIS
 202
 203
 204
 205 MFUNCTION       MOD,SUBR
 206         ENTRY   2
 207         GETYP   A,TYP1
 208         CAIE    A,TFIX          ;FIRST ARG FIXED ?
 209         JRST    WTYP1
 210         GETYP   A,TYP2
 211         CAIE    A,TFIX          ;SECOND ARG FIXED ?
 212         JRST    WTYP2
 213         MOVE    A,VAL1
 214         IDIV    A,VAL2          ;FORM QUOTIENT & REMAINDER
 215         JUMPGE  B,.+2           ;Only return positive remainders
 216         ADD     B,VAL2
 217         MOVSI   A,TFIX
 218         JRST    FINIS
 219 \f;PRIMITIVES PLUS, DIFFERENCE, TIMES, DIVIDE, MIN, AND MAX
 220
 221 MFUNCTION       MIN,SUBR
 222
 223         ENTRY
 224
 225         MOVEI   E,6
 226         JRST    GOPT
 227
 228 IMFUNCTION      MAX,SUBR
 229
 230         ENTRY
 231
 232         MOVEI   E,7
 233         JRST    GOPT
 234
 235 MFUNCTION       DIVIDE,SUBR,[/]
 236
 237         ENTRY
 238
 239         MOVEI   E,3
 240         JRST    GOPT
 241
 242 MFUNCTION       DIFFERENCE,SUBR,[-]
 243
 244         ENTRY
 245
 246         MOVEI   E,2
 247         JRST    GOPT
 248
 249 IMFUNCTION      TIMES,SUBR,[*]
 250
 251         ENTRY
 252
 253         MOVEI   E,5
 254         JRST    GOPT
 255
 256 MFUNCTION       PLUS,SUBR,[+]
 257
 258         ENTRY
 259
 260         MOVEI   E,4
 261
 262 GOPT:   MOVE    D,AB            ;ARGUMENT POINTER
 263         HLRE    A,AB
 264         MOVMS   A
 265         ASH     A,-1
 266         PUSHJ   P,CARITH
 267         JRST    FINIS
 268
 269 ; BUILD COMPILER ENTRIES TO THESE ROUTINES
 270
 271 IRP NAME,,[CMINUS,CDIVID,CPLUS,CTIMES,CMIN,CMAX]CODE,,[2,3,4,5,6,7]
 272
 273 NAME:   MOVEI   E,CODE
 274         JRST    CARIT1
 275 TERMIN
 276 \f
 277 CARIT1: MOVEI   D,(A)
 278         ASH     D,1             ; TIMES 2
 279         HRLI    D,(D)
 280         SUBM    TP,D            ; POINT TO ARGS
 281         PUSH    TP,$TTP
 282         AOBJN   D,.+1
 283         PUSH    TP,D
 284         PUSHJ   P,CARITH
 285         MOVE    TP,(TP)
 286         SUB     TP,[1,,1]
 287         POPJ    P,
 288
 289 CARITH: MOVE    B,DEFVAL(E)     ; GET VAL
 290         JFCL    OVRFLW,.+1
 291         MOVEI   0,TFIX          ; FIX UNTIL CHANGE
 292         JUMPN   A,ARITH0        ; AT LEAST ONE ARG
 293         MOVE    A,DEFTYP(E)
 294         POPJ    P,
 295
 296 ARITH0: SOJE    A,ARITH1        ; FALL IN WITH ONE ARG
 297         MOVE    B,1(D)
 298         GETYP   C,(D)           ; TYPE OF 1ST ARG
 299         ADD     D,[2,,2]        ; GO TO NEXT
 300         CAIN    C,TFLOAT
 301         JRST    ARITH3
 302         CAIN    C,TFIX
 303         JRST    ARITH1
 304         JRST    WRONGT
 305
 306 ARITH1: GETYP   C,0(D)          ; GET NEXT TYPE
 307         CAIE    C,TFIX
 308         JRST    ARITH2          ; TO FLOAT LOOP
 309         XCT     FUNC(E)         ; DO IT
 310         ADD     D,[2,,2]
 311         SOJG    A,ARITH1        ; KEEP ADDING OR WHATEVER
 312         SKIPE   OVFLG
 313         JFCL    OVRFLW,OVRFLD
 314         MOVSI   A,TFIX
 315         POPJ    P,
 316
 317 ARITH3: GETYP   C,0(D)
 318         MOVE    0,1(D)          ; GET ARG
 319         CAIE    C,TFIX
 320         JRST    ARITH4
 321         PUSH    P,A
 322         JSP     C,OFLOAT        ; FLOAT IT
 323         POP     P,A
 324         JRST    ARITH5
 325 ARITH4: CAIE    C,TFLOAT
 326         JRST    WRONGT
 327         JRST    ARITH5
 328
 329 ARITH2: CAIE    C,TFLOAT        ; FLOATER?
 330         JRST    WRONGT
 331         PUSH    P,A
 332         JSP     A,BFLOAT
 333         POP     P,A
 334         MOVE    0,1(D)
 335
 336 ARITH5: XCT     FLFUNC(E)
 337         ADD     D,[2,,2]
 338         SOJG    A,ARITH3
 339
 340         SKIPE   OVFLG
 341         JFCL    OVRFLW,OVRFLD
 342         MOVSI   A,TFLOAT
 343         POPJ    P,
 344
 345 SWITCH: XCT     COMPAR(E)       ;FOR MAX & MIN TESTING
 346         MOVE    B,VALN
 347         JRST    (C)
 348 COMPAR==.-6
 349         CAMLE   B,VALN
 350         CAMGE   B,VALN
 351
 352
 353
 354 FLSWCH: XCT     FLCMPR(E)
 355         MOVE    B,O
 356         JRST    (C)
 357 FLCMPR==.-6
 358         CAMLE   B,O
 359         CAMGE   B,O
 360 \f;PRIMITIVES ONEP AND ZEROP
 361
 362 MFUNCTION       ONEP,SUBR,[1?]
 363         MOVEI   E,1
 364         JRST    JOIN
 365
 366 MFUNCTION       ZEROP,SUBR,[0?]
 367         MOVEI   E,
 368
 369 JOIN:   ENTRY 1
 370         GETYP   A,TYP1
 371         CAIN    A,TFIX  ;fixed ?
 372         JRST    TESTFX
 373         CAIE    A,TFLOAT        ;floating ?
 374         JRST    WTYP1
 375         MOVE    B,VAL1
 376         CAMN    B,NUMBR(E)      ;equal to correct value ?
 377         JRST    YES1
 378         JRST    NO1
 379
 380 TESTFX: CAMN    E,VAL1  ;equal to correct value ?
 381         JRST    YES1
 382
 383 NO1:    MOVSI   A,TFALSE
 384         MOVEI   B,0
 385         JRST    FINIS
 386
 387 YES1:   MOVSI   A,TATOM
 388         MOVE    B,IMQUOTE T
 389         JRST    FINIS
 390
 391 NUMBR:  0       ;FLOATING PT  ZERO
 392         201400,,0       ;FLOATING PT ONE
 393 \f;PRIMITIVES LESSP AND GREATERP
 394
 395 MFUNCTION       LEQP,SUBR,[L=?]
 396         MOVEI   E,3
 397         JRST    ARGS
 398
 399 MFUNCTION       GEQP,SUBR,[G=?]
 400         MOVEI   E,2
 401         JRST    ARGS
 402
 403
 404 MFUNCTION       LESSP,SUBR,[L?]
 405         MOVEI   E,1
 406         JRST    ARGS
 407
 408 MFUNCTION       GREATERP,SUBR,[G?]
 409         MOVEI   E,0
 410
 411 ARGS:   ENTRY 2
 412         MOVE    B,VAL1
 413         MOVE    A,TYP1
 414         GETYP   0,A
 415         PUSHJ   P,CMPTYP
 416         JRST    WTYP1
 417         MOVE    D,VAL2
 418         MOVE    C,TYP2
 419         GETYP   0,C
 420         PUSHJ   P,CMPTYP
 421         JRST    WTYP2
 422         PUSHJ   P,ACOMPS
 423         JFCL
 424         JRST    FINIS
 425
 426 ; COMPILERS ENTRIES TO THESE GUYS
 427
 428 IRP NAME,,[CGQ,CLQ,CGEQ,CLEQ]COD,,[0,1,2,3]
 429
 430 NAME:   MOVEI   E,COD
 431         JRST    ACOMPS
 432 TERMIN
 433
 434 ACOMPS: GETYP   A,A
 435         GETYP   0,C
 436         CAIE    0,(A)
 437         JRST    COMPD           ; COMPARING FIX AND FLOAT
 438 TEST:   CAMN    B,D
 439         JRST    @TABLE4(E)
 440         CAMG    B,D
 441         JRST    @TABLE2(E)
 442         JRST    @TABLE3(E)
 443
 444 CMPTYP: CAIE    0,TFIX
 445         CAIN    0,TFLOAT
 446         AOS     (P)
 447         POPJ    P,
 448 COMPD:  EXCH    B,D
 449         CAIN    A,TFLOAT
 450         JSP     A,BFLOAT
 451         EXCH    B,D
 452         CAIN    0,TFLOAT
 453         JSP     A,BFLOAT
 454 COMPF:  JRST    TEST
 455
 456 MFUNCTION RANDOM,SUBR
 457         ENTRY
 458         HLRE    A,AB
 459         CAMGE   A,[-4]          ;At most two arguments to random to set seeds
 460         JRST    TMA
 461         JRST    RANDGO(A)
 462         MOVE    B,VAL2          ;Set second seed
 463         MOVEM   B,RLOW
 464         MOVE    A,VAL1          ;Set first seed
 465         MOVEM   A,RHI
 466 RANDGO: PUSHJ   P,CRAND
 467         JRST    FINIS
 468
 469 CRAND:  MOVE    A,RHI
 470         MOVE    B,RLOW
 471         MOVEM   A,RLOW          ;Update Low seed
 472         LSHC    A,-1            ;Shift both right one bit
 473         XORB    B,RHI           ;Generate output and update High seed
 474         MOVSI   A,TFIX
 475         POPJ    P,
 476
 477
 478 \fMFUNCTION SQRT,SUBR
 479         PUSHJ   P,ARGCHK
 480         JUMPL   B,NSQRT
 481         PUSHJ   P,ISQRT
 482         JRST    FINIS
 483
 484 ISQRT:  MOVE    A,B
 485         ASH     B,-1
 486         FSC     B,100
 487 SQ2:    MOVE    C,B     ;NEWTON'S METHOD, SPECINER'S HACK.
 488         FDVRM   A,B
 489         FADRM   C,B
 490         FSC     B,-1
 491         CAME    C,B
 492         JRST    SQ2
 493         MOVSI   A,TFLOAT
 494         POPJ    P,
 495
 496 MFUNCTION COS,SUBR
 497         PUSHJ   P,ARGCHK
 498         FADR    B,[1.570796326]         ;COS(X)=SIN (X+PI/2)
 499         PUSHJ   P,.SIN
 500         MOVSI   A,TFLOAT
 501         JRST    FINIS
 502
 503 MFUNCTION SIN,SUBR
 504         PUSHJ   P,ARGCHK
 505         PUSHJ   P,.SIN
 506         MOVSI   A,TFLOAT
 507         JRST    FINIS
 508
 509 .SIN:   MOVM    A,B
 510         CAMG    A,[.0001]
 511         POPJ    P,              ;GOSPER'S RECURSIVE SIN.
 512         FDVR    B,[-3.0]        ;SIN(X)=4*SIN(X/-3)**3-3*SIN(X/-3)
 513         PUSHJ   P,.SIN
 514         FSC     A,1
 515         FMPR    A,A
 516         FADR    A,[-3.0]
 517         FMPRB   A,B
 518         POPJ    P,
 519
 520 CSQRT:  PUSHJ   P,CARGCH
 521         JUMPL   B,NSQRT
 522         JRST    ISQRT
 523
 524 CSIN:   PUSHJ   P,CARGCH
 525 CSIN1:  PUSHJ   P,.SIN
 526         MOVSI   A,TFLOAT
 527         POPJ    P,
 528
 529 CCOS:   PUSHJ   P,CARGCH
 530         FADR    B,[1.570796326]
 531         JRST    CSIN1
 532 \fMFUNCTION      LOG,SUBR
 533         PUSHJ   P,ARGCHK        ;LEAVES ARGUMENT IN B
 534         PUSHJ   P,ILOG
 535         JRST    FINIS
 536
 537 CLOG:   PUSHJ   P,CARGCH
 538
 539 ILOG:   JUMPLE  B,OUTRNG
 540         LDB     D,[331100,,B]   ;GRAB EXPONENT
 541         SUBI    D,201           ;REMOVE BIAS
 542         TLZ     B,777000        ;SET EXPONENT
 543         TLO     B,201000        ; TO 1
 544         MOVE    A,B
 545         FSBR    A,RT2
 546         FADR    B,RT2
 547         FDVB    A,B
 548         FMPR    B,B
 549         MOVE    C,[0.434259751]
 550         FMPR    C,B
 551         FADR    C,[0.576584342]
 552         FMPR    C,B
 553         FADR    C,[0.961800762]
 554         FMPR    C,B
 555         FADR    C,[2.88539007]
 556         FMPR    C,A
 557         FADR    C,[0.5]
 558         MOVE    B,D
 559         FSC     B,233
 560         FADR    B,C
 561         FMPR    B,[0.693147180] ;LOG E OF 2
 562         MOVSI   A,TFLOAT
 563         POPJ    P,
 564
 565 RT2:    1.41421356
 566 \fMFUNCTION      ATAN,SUBR
 567         PUSHJ   P,ARGCHK
 568         PUSHJ   P,IATAN
 569         JRST    FINIS
 570
 571 CATAN:  PUSHJ   P,CARGCH
 572
 573 IATAN:  PUSH    P,B
 574         MOVM    D,B
 575         CAMG    D,[0.4^-8]      ;SMALL ENOUGH SO ATAN(X)=X?
 576         JRST    ATAN3           ;YES
 577         CAML    D,[7.0^7]       ;LARGE ENOUGH SO THAT ATAN(X)=PI/2?
 578         JRST    ATAN1           ;YES
 579         MOVN    C,[1.0]
 580         CAMLE   D,[1.0]         ;IS ABS(X)<1.0?
 581         FDVM    C,D             ;NO,SCALE IT DOWN
 582         MOVE    B,D
 583         FMPR    B,B
 584         MOVE    C,[1.44863154]
 585         FADR    C,B
 586         MOVE    A,[-0.264768620]
 587         FDVM    A,C
 588         FADR    C,B
 589         FADR    C,[3.31633543]
 590         MOVE    A,[-7.10676005]
 591         FDVM    A,C
 592         FADR    C,B
 593         FADR    C,[6.76213924]
 594         MOVE    B,[3.70925626]
 595         FDVR    B,C
 596         FADR    B,[0.174655439]
 597         FMPR    B,D
 598         JUMPG   D,ATAN2         ;WAS ARG SCALED?
 599         FADR    B,PI2           ;YES,  ATAN(X)=PI/2-ATAN(1/X)
 600         JRST    ATAN2
 601 ATAN1:  MOVE    B,PI2
 602 ATAN2:  SKIPGE  (P)             ;WAS INPUT NEGATIVE?
 603         MOVNS   B               ;YES,COMPLEMENT
 604 ATAN3:  MOVSI   A,TFLOAT
 605         SUB     P,[1,,1]
 606         POPJ    P,
 607
 608 PI2:    1.57079632
 609 \fMFUNCTION      IEXP,SUBR,[EXP]
 610         PUSHJ   P,ARGCHK        ;LEAVE FLOATING POINT ARG IN B
 611         PUSHJ   P,IIEXP
 612         JRST    FINIS
 613
 614 CEXP:   PUSHJ   P,CARGCH
 615
 616 IIEXP:  PUSH    P,B
 617         MOVM    A,B
 618         SETZM   B
 619         FMPR    A,[0.434294481] ;LOG BASE 10 OF E
 620         MOVE    D,[1.0]
 621         CAMG    A,D
 622         JRST    RATEX
 623         MULI    A,400
 624         ASHC    B,-243(A)
 625         CAILE   B,43
 626         JRST    OUTRNG
 627         CAILE   B,7
 628         JRST    EXPR2
 629 EXPR1:  FMPR    D,FLOAP1(B)
 630         LDB     A,[103300,,C]
 631         SKIPE   A
 632         TLO     A,177000
 633         FADR    A,A
 634 RATEX:  MOVEI   B,7
 635         SETZM   C
 636 RATEY:  FADR    C,COEF2-1(B)
 637         FMPR    C,A
 638         SOJN    B,RATEY
 639         FADR    C,[1.0]
 640         FMPR    C,C
 641         FMPR    D,C
 642         MOVE    B,[1.0]
 643         SKIPL   (P)             ;SKIP IF INPUT NEGATIVE
 644         SKIPN   B,D
 645         FDVR    B,D
 646         MOVSI   A,TFLOAT
 647         SUB     P,[1,,1]
 648         POPJ    P,
 649
 650 EXPR2:  LDB     E,[030300,,B]
 651         ANDI    B,7
 652         MOVE    D,FLOAP1(E)
 653         FMPR    D,D             ;TO THE 8TH POWER
 654         FMPR    D,D
 655         FMPR    D,D
 656         JRST    EXPR1
 657
 658 COEF2:  1.15129278
 659         0.662730884
 660         0.254393575
 661         0.0729517367
 662         0.0174211199
 663         2.55491796^-3
 664         9.3264267^-4
 665
 666 FLOAP1: 1.0
 667         10.0
 668         100.0
 669         1000.0
 670         10000.0
 671         100000.0
 672         1000000.0
 673         10000000.0
 674 \f
 675 ;LSH AND ROT (ERB WOULD BE PLEASED) PDL 2/22/79
 676
 677 MFUNCTION %LSH,SUBR,LSH
 678         ENTRY   2
 679         MOVE    C,[LSH B,(A)]
 680         JRST    LSHROT
 681
 682 MFUNCTION %ROT,SUBR,ROT
 683         ENTRY   2
 684         MOVE    C,[ROT B,(A)]
 685 LSHROT: GETYP   A,(AB)
 686         PUSHJ   P,SAT
 687         CAIE    A,S1WORD
 688          JRST   WRONGT
 689         GETYP   A,2(AB)
 690         CAIE    A,TFIX
 691          JRST   WTYP2
 692         MOVE    A,3(AB)
 693         MOVE    B,1(AB)
 694         XCT     C
 695         MOVE    A,$TWORD
 696         JRST    FINIS
 697
 698 ;BITWISE BOOLEAN FUNCTIONS
 699
 700 MFUNCTION %ANDB,SUBR,ANDB
 701         ENTRY
 702         HRREI   B,-1            ;START ANDING WITH ALL ONES
 703         MOVE    D,[AND B,A]     ;LOGICAL INSTRUCTION
 704         JRST    LOGFUN          ;DO THE OPERATION
 705
 706 MFUNCTION %ORB,SUBR,ORB
 707         ENTRY
 708         MOVEI   B,0
 709         MOVE    D,[IOR B,A]
 710         JRST    LOGFUN
 711
 712 MFUNCTION %XORB,SUBR,XORB
 713         ENTRY
 714         MOVEI   B,0
 715         MOVE    D,[XOR B,A]
 716         JRST    LOGFUN
 717
 718 MFUNCTION %EQVB,SUBR,EQVB
 719         ENTRY
 720         HRREI   B,-1
 721         MOVE    D,[EQV B,A]
 722
 723 LOGFUN: JUMPGE  AB,ZROARG
 724 LOGTYP: GETYP   A,(AB)          ;GRAB THE TYPE
 725         PUSHJ   P,SAT           ;STORAGE ALLOCATION TYPE
 726         CAIE    A,S1WORD
 727         JRST    WRONGT          ;WRONG TYPE...LOSE
 728         MOVE    A,1(AB)         ;LOAD ARG INTO A
 729         XCT     D               ;DO THE LOGICAL OPERATION
 730         AOBJP   AB,.+2          ;ADD ONE TO BOTH HALVES
 731         AOBJN   AB,LOGTYP       ;ADD AGAIN AND LOOP IF NEEDED
 732
 733 ZROARG: MOVE    A,$TWORD
 734         JRST    FINIS
 735 \fREPEAT 0,[
 736 ;routine to sort lists or vectors of either fixed point or floating numbers
 737 ;the components are interchanged repeatedly to acheive the sort
 738 ;first arg:     the structure to be sorted
 739 ;if no second arg sort in descending order
 740 ;second arg:    if false then sort in ascending order
 741 ;               else sort in descending order
 742
 743 MFUNCTION       SORT,SUBR
 744         ENTRY
 745         HLRZ    A,AB
 746         CAIGE   A,-4            ;Only two arguments allowed
 747         JRST    TMA
 748         MOVE    O,DESCEND       ;Set up "O" to test for descending order as default condition
 749         CAIE    A,-4            ;Optional second argument?
 750         JRST    .+4
 751         GETYP   B,TYP2          ;See if it is other than false
 752         CAIN    B,TFALSE
 753         MOVE    O,ASCEND        ;Set up "O" to test for ascending order
 754         GETYP   A,TYP1          ;CHECK TYPE OF FIRST ARGUMENT
 755         CAIN    A,TLIST
 756         JRST    LSORT
 757         CAIN    A,TVEC
 758         JRST    VSORT
 759         JRST    WTYP1
 760
 761
 762
 763
 764 GOBACK: MOVE    A,TYP1          ;RETURN THE SORTED ARGUMENT AS VALUE
 765         MOVE    B,VAL1
 766         JRST    FINIS
 767
 768 DESCEND:        CAMG    C,(A)+1
 769 ASCEND:         CAML    C,(A)+1
 770 \f;ROUTINE TO SORT LISTS IN NUMERICAL ORDER
 771
 772 LSORT:  MOVE    A,VAL1
 773         JUMPE   A,GOBACK        ;EMPTY LIST?
 774         HLRZ    B,(A)           ;TYPE OF FIRST COMPONENT
 775         CAIE    B,TFIX
 776         CAIN    B,TFLOAT
 777         SKIPA
 778         JRST    WRONGT
 779         MOVEI   E,0             ;FOR COUNT OF LENGTH OF LIST
 780 LCOUNT: JUMPE   A,LLSORT        ;REACHED END OF LIST?
 781         MOVE    A,(A)           ;NEXT COMPONENT
 782         TLZ     A,(B)           ;SAME TYPE AS FIRST COMPONENT?
 783         TLNE    A,-1
 784         JRST    WRONGT
 785         AOJA    E,LCOUNT        ;INCREMENT COUNT AND CONTINUE
 786
 787 LLSORT: SOJE    E,GOBACK        ;FINISHED WITH SORTING?
 788         HRRZ    A,VAL1          ;START THIS LOOP OF SORTING AT THE BEGINNING
 789         MOVEM   E,(P)+1         ;Save the iteration depth
 790 CLSORT: HRRZ    B,(A)           ;NEXT COMPONENT
 791         MOVE    C,(B)+1         ;ITS VALUE
 792         XCT     O               ;ARE THESE TWO COMPONENTS IN ORDER?
 793         JRST    .+4
 794         MOVE    D,(A)+1         ;INTERCHANGE THEM
 795         MOVEM   D,(B)+1
 796         MOVEM   C,(A)+1
 797         MOVE    A,B             ;MAKE THE COMPONENT IN "B" THE CURRENT ONE
 798         SOJG    E,CLSORT
 799         MOVE    E,(P)+1         ;Restore the iteration depth
 800         JRST    LLSORT
 801 \f;ROUTINE TO SORT VECTORS IN NUMERICAL ORDER
 802
 803 VSORT:  HLRE    D,VAL1          ;GET COUNT FIELD OF VECTOR
 804         IDIV    D,[-2]          ;LENGTH
 805         JUMPE   D,GOBACK        ;EMPTY VECTOR?
 806         MOVE    E,D             ;SAVE LENGTH IN "E"
 807         HRRZ    A,VAL1          ;POINTER TO VECTOR
 808         MOVE    B,(A)           ;TYPE OF FIRST COMPONENT
 809         CAME    B,$TFIX
 810         CAMN    B,$TFLOAT
 811         SKIPA
 812         JRST    WRONGT
 813         SOJLE   D,GOBACK        ;IF ONLY ONE COMPONENT THEN FINISHED
 814 VCOUNT: ADDI    A,2             ;CHECK NEXT COMPONENT
 815         CAME    B,(A)           ;SAME TYPE AS FIRST COMPONENT?
 816         JRST    WRONGT
 817         SOJG    D,VCOUNT        ;CONTINUE WITH NEXT COMPONENT
 818
 819 VVSORT: SOJE    E,GOBACK        ;FINISHED SORTING?
 820         HRRZ    A,VAL1          ;START THIS LOOP OF SORTING AT THE BEGINNING
 821         MOVEM   E,(P)+1         ;Save the iteration depth
 822 CVSORT: MOVE    C,(A)+3         ;VALUE OF NEXT COMPONENT
 823         XCT     O               ;ARE THESE TWO COMPONENTS IN ORDER?
 824         JRST    .+4
 825         MOVE    D,(A)+1         ;INTERCHANGE THEM
 826         MOVEM   D,(A)+3
 827         MOVEM   C,(A)+1
 828         ADDI    A,2             ;UPDATE THE CURRENT COMPONENT
 829         SOJG    E,CVSORT
 830         MOVE    E,(P)+1         ;Restore the iteration depth
 831         JRST    VVSORT
 832 ]
 833
 834 MFUNCTION OVERFLOW,SUBR
 835
 836         ENTRY
 837
 838         MOVEI   E,OVFLG
 839         JRST    FLGSET
 840
 841
 842 MFUNCTION TIME,SUBR
 843         ENTRY
 844         PUSHJ   P,CTIME
 845         JRST    FINIS
 846
 847 IMPURE
 848
 849 RHI:    267762113337
 850 RLOW:   155256071112
 851 OVFLG:  -1
 852 PURE
 853
 854
 855 END
 856 \f\f