sumex/arith.mbd079

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