![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to spitv43.min CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / spitbol / 4.3|
Return to spitv43.min CVS log | Up to [Research Unix] / researchv10no / cmd / spitbol / 4.3 |
1.1 ! root 1: * CHANGES [SGD] ! 2: * ------------- ! 3: * 1. COMMENTED OUT DEFAULT .DEF, .UNDEF AS THESE MACHINE- ! 4: * DEPENDENT. I SUGGEST AGAIN THAT THESE DO NOT BELONG ! 5: * IN MINIMAL SOURCE, UNLESS SOMETHING OF THE FORM .*DEF ! 6: * IS TO BE INCORPORTATED INTO MINIMAL LANGUAGE DEFN. ! 7: * ! 8: * 2. NOTED THAT DESCRIPTION OF BEV, BOD MISSING FROM ! 9: * SBL42.CMT MINIMAL DESCRIPTION, AND DISCUSSION OF ! 10: * "ODD"/"EVEN" AND REQUIREMENTS PERTAINING THERETO ! 11: * SEEMS INSUFFICIENT. ! 12: * ! 13: * 3. PERMIT CODE KEYWORD TO CONTAIN ANY INTEGER VALUE. ! 14: * THIS CONSISTS OF REMOVING THE ENFORCED RESTRICTION ! 15: * IN ASIGN (SEE ASG24), SINCE CODE CONTAINS NO RELOC. ! 16: * USE OF KEYWORD VALUE (AS IT SHOULDNT). SBL DOC. ! 17: * MUST BE UPDATED. ADDRESS OF CODE VALUE NOW PASSED TO ! 18: * OSINT (KVCOD), INSTEAD OF VALUE ITSELF. HENCE OSINT ! 19: * DOCUMENTATION MUST LIKEWISE BE REVISED. CHANGES ! 20: * MADE IN KEYWORD DEFINITION TABLES, PROCEDURES ACESS ! 21: * AND ASIGN SINCE CODE NOW SPECIAL KEYWORD. ! 22: * ! 23: * EROSI RETURNS NOW CONTAIN NEW CODE KEYWORD VALUE IN ! 24: * IA. OSINT DOCUMENTATION MUST BE REVISED. ! 25: * ! 26: * INTERESTINGLY, THIS SHOULD PERMIT THE SPITBOL PROGRAM ! 27: * TO INTERROGATE THE CODE KEYWORD AT THE START OF ! 28: * EXECUTION TO DETERMINE IF COMPILATION ERRORS ! 29: * OCCURRED. ! 30: * ! 31: * 4. ADD -COPY "FILETAG" CONTROL CARD. -COPY PERMITTED IN ! 32: * CODE STRINGS. NESTING IS PERMITTED TO ANY LEVEL, ! 33: * THOUGH OSINT IS FREE TO RESTRICT THE MAXIMUM LEVEL. ! 34: * NOTE REQUIREMENT FOR FILETAG SPECIFIED AS ! 35: * STRING CONSTANT SINCE FILETAGS MAY CONTAIN SEMICOLONS. ! 36: * I HAVE TRIED TO MAKE THIS ENHANCEMENT WITH MINIMUM ! 37: * (MINIMAL?) AMOUNT OF NEW CODE, SO THE FEATURE IS ! 38: * NOT CONDITIONALIZED. THE SOLUTION ! 39: * REQUIRED THE ADDITION OF A NEW BLOCK TYPE (COBLK) TO ! 40: * BUILD THE INPUT CONTEXT SAVE STACK AS A CHAIN OF ! 41: * COBLKS. A RECUSIVE SOLUTION ON CMPIL/READR/NEXTS ! 42: * WOULD HAVE REQUIRED EXTENSIVE MODIFICATIONS AND ! 43: * SUBSTANTIAL NEW CODE. NOTE THAT FORMS SUCH AS ! 44: * CODE('-COPY "FILE.SBL"') ARE ACCEPTABLE, WHICH IS ! 45: * VIEWED AS SIGNIFICANT ENHANCEMENT IN ADDITION TO ! 46: * COMPILE-TIME INCLUDE. ! 47: * ! 48: * TO SUPPORT THIS FEATURE, TWO NEW OSINT ROUTINES ARE ! 49: * DEFINED, SYSSC (START COPY) AND SYSEC (END COPY) WITH ! 50: * LOGICS DESCRIBED IN THE .CMT FILE. ! 51: * ! 52: * BECAUSE OF ANNOYANCE FACTOR, SOURCE LISTING OF ! 53: * CODE() INFO VIA -LIST, INCLUDING -COPY INPUT, IS ! 54: * NO LONGER POSSIBLE. IF THIS IS PERMITTED, THEN ! 55: * ONE FINDS -COPY INPUT BEING PRINTED ON STD. ! 56: * OUTPUT CHANNEL (DEPENDING ON STATE OF -LIST), ! 57: * UNLESS EXPLICIT -NOLIST IS GIVEN. ! 58: * ! 59: * 5. THE DOCUMENTATION FOR SYSIO IS INCONSISTENT. IT ! 60: * SHOWS 0,1,2,3 BEING POSSIBLE INPUTS DEPENDING ON ! 61: * INPUT/OUTPUT, STD/NONSTD. HOWEVER, IT ALSO APPEARS ! 62: * (AND IS STATED) THAT SYSIO IS NOT CALLED FOR STD ! 63: * INPUT/OUTPUT. ! 64: * ! 65: * 6. SINCE -PRINT,-NOPRINT REMOVED IN V4, I HAVE ! 66: * REINSTATED THE CIRCUIT IN NEXTS TO AVOID LISTING ! 67: * CONTROL CARDS (-COPY FORCES LIST IN CNCRD THOUGH). ! 68: * ! 69: * 7. WA NOW CONTAINS THE INITIAL VALUE OF &CODE ON ENTRY ! 70: * TO SPITBOL. ! 71: * ! 72: * 8. ADDED DDC (DEFINE DISPLAY CONSTANT). IS IDENTICAL ! 73: * TO DTC EXCEPT THAT ON SYSTEMS SUPPORTING LOWER CASE, ! 74: * THE DISPLAY TEXT CAN BE TRANSLATED WITH A ! 75: * CASE MIX. FOR EXAMPLE, CAPITALIZE ONLY THE FIRST ! 76: * LETTER, OR THE FIRST LETTER OF EVERY WORD, OR NO ! 77: * UPPER CASE (FOR EUNICHS), ETC. ! 78: * ! 79: * 9. FIX MINOR OVERSIGHT IN FAILING TO CLEAR R$PMB AT ! 80: * END OF PATTERN MATCH, THUS LEAVING PTR TO BCBLK ! 81: * THAT CANNOT BE COLLECTED. ! 82: * ! 83: * 10. AFTER CONSULTATION WITH DAVE SHIELDS, IT WAS AGREED ! 84: * TO REINSTATE ARG,FIELD,ITEM AND LOCAL FUNCTIONS. ! 85: * COMMENTS WERE RECEIVED THAT REMOVING THEM BREAKS ! 86: * EXISTING CODE IN DIFFICULT-TO-FIX WAYS, INCLUDING ! 87: * A NUMBER OF THE UTILITY ROUTINES IN GIMPELS BOOK. ! 88: * IN ANY EVENT, THESE ARE SNOBOL4 COMPATIBILITY ! 89: * FUNCTIONS THAT TAKE LITTLE CODE SPACE. AS A ! 90: * RESULT OF THIS, AND -COPY, ERROR NUMBERS HAVE ! 91: * BEEN PUSHED BACK OVER THE 255 THRESHOLD, WHICH ! 92: * SEEMS UNAVOIDABLE UNLESS MAJOR SURGERY IS DONE. ! 93: * ! 94: * 11. VERSION ID CHANGED TO V4.3 DUE TO SUBSTANTIAL ! 95: * CHANGES. ! 96: * ! 97: * 12. PERMIT DOLLAR SIGN IN VARIABLE NAMES. MINOR ! 98: * CHANGE TO OPERATOR TABLE AND SCANE. ! 99: * ! 100: * 13. PERMIT BUFFER TYPE FOR LOAD SPECIFICATION. AS ! 101: * A SIDE-EFFECT, THE CODE FOR BUFFER CONVERSION HAS ! 102: * BEEN CENTRALIZED IN GTBUF. ALSO FIXED PADDING ! 103: * BUG IN INSBF RELATED TO ZERO PADDING. ! 104: * ! 105: * 14. DOCUMENT THAT SYSIL MUST NEVER REQUEST ZERO BYTES. ! 106: * DOING SO CAUSES ACESS TO POTENTIALLY CREATE ! 107: * INVALID MEMORY CAUSING LATER GARBAGE COLLECTOR ! 108: * PROBLEMS OR MISADJUSTMENTS OF DNAMP, ETC. ! 109: * ! 110: * 15. VDIFFER FUNCTION ADDED. VDIFFER(X,Y) RETURNS X ! 111: * IF DIFFERENT FROM Y. IN MOST CASES IT IS EXPECTED ! 112: * THAT Y WOULD BE NULL. ! 113: * ! 114: SEC FORMAL START OF PROCEDURES SECTION ! 115: EJC ! 116: * ! 117: * SPITBOL CONDITIONAL ASSEMBLY SYMBOLS ! 118: * ------------------------------------ ! 119: * ! 120: * IN THE SPITBOL TRANSLATOR, THE FOLLOWING CONDITIONAL ! 121: * ASSEMBLY SYMBOLS ARE REFERRED TO. ! 122: * A PARTICULAR SET OF DEFAULT SETTINGS IS GIVEN IN THIS ! 123: * SOURCE BY USE OF .DEF AND .UNDEF PSEUDO OPS. ! 124: * A DIFFERENT SELECTION MAY BE MADE BY VARYING THE ! 125: * DEFINITIONS. AS AN ALTERNATIVE, THIS SECTION MAY BE ! 126: * COMMENTED OUT AND THE MINIMAL TRANSLATOR PRELOADED WITH ! 127: * THE SELECTED DEFINITIONS, THUS ALLOWING A MORE DYNAMIC ! 128: * CHOICE TO BE MADE. ! 129: * SOME OF THE CONDITIONAL FEATURES CHOOSE AMONGST A VARIETY ! 130: * OF OPTIONS. OTHERS ARE DEFINED PRINCIPALLY TO ALLOW ! 131: * OMISSION OF A FEATURE WHICH IS NOT WANTED IN ORDER TO ! 132: * SAVE MEMORY OR BECAUSE IT CANNOT BE SUPPORTED. ! 133: * NOTE THAT IF .CPLC OPTION IS CHOSEN, TRANSLATION OF DTC, ! 134: * ERR, ERB ARGUMENTS SHOULD BE TO LOWER CASE. ! 135: * ! 136: *.DEF .CAHT DEFINE TO INCLUDE HORIZONTAL TAB ! 137: *.DEF .CASL DEFINE TO INCLUDE 26 SHIFTED LETTRS ! 138: *.DEF .CAVT DEFINE TO INCLUDE VERTICAL TAB ! 139: *.UNDEF .CEPP DEFINE FOR ODD PARITY ENTRY POINTS ! 140: *.UNDEF .CNBF DEFINE TO OMIT BUFFER EXTENSION ! 141: *.UNDEF .CNBT DEFINE TO OMIT BATCH INITIALISATION ! 142: *.UNDEF .CNEX DEFINE TO OMIT EXIT() CODE ! 143: *.UNDEF .CNFN DEFINE TO OMIT FENCE() CODE ! 144: *.UNDEF .CNLD DEFINE TO OMIT LOAD() CODE ! 145: *.UNDEF .CNPF DEFINE TO OMIT PROFILE CODE ! 146: *.UNDEF .CNRA DEFINE TO OMIT ALL REAL ARITHMETIC ! 147: *.UNDEF .CNSR DEFINE TO OMIT SORT, RSORT CODE ! 148: *.DEF .CPLC DEFINE IF HOST PREFERS LOWER CASE ! 149: *.UNDEF .CRPP DEFINE FOR ODD PARITY RETURN POINTS ! 150: *.UNDEF .CS16 DEFINE TO INITIALIZE STLIM TO 32767 ! 151: *.UNDEF .CSAX DEFINE IF SYSAX IS TO BE CALLED ! 152: *.UNDEF .CSCI DEFINE TO ENABLE SYSCI ROUTINE ! 153: *.UNDEF .CSCV DEFINE FOR CLU, CUL CASE CONVERSION ! 154: *.DEF .CSIG DEFINE TO IGNORE CASE OF LETTERS ! 155: *.UNDEF .CSN6 DEFINE TO PAD STMT NOS TO 6 CHARS ! 156: *.DEF .CSN8 DEFINE TO PAD STMT NOS TO 8 CHARS ! 157: *.UNDEF .CTMD DEFINE IF SYSTM UNIT IS DECISECOND ! 158: .IF .CASL ! 159: .ELSE ! 160: .UNDEF .CSIG .CSIG USELESS WITHOUT LC LETTERS ! 161: .UNDEF .CPLC .CPLC ERRONEOUS WITHOUT LC LETTERS ! 162: .FI ! 163: EJC ! 164: * ! 165: * ACTUAL PROCESSABLE EXP PROCEDURE DEFINITIONS ! 166: * ! 167: .IF .CSAX ! 168: SYSAX EXP E,0 ! 169: .ELSE ! 170: .FI ! 171: SYSBX EXP E,0 ! 172: .IF .CSCI ! 173: SYSCI EXP E,0 ! 174: .FI ! 175: SYSDT EXP E,0 ! 176: SYSEC EXP E,2 ! 177: SYSEF EXP E,2 ! 178: SYSEJ EXP E,0 ! 179: SYSEM EXP E,0 ! 180: SYSEN EXP E,2 ! 181: SYSEP EXP E,2 ! 182: .IF .CNLD ! 183: .ELSE ! 184: SYSEX EXP E,1 ! 185: .FI ! 186: SYSHS EXP E,2 ! 187: SYSID EXP E,0 ! 188: SYSIL EXP E,0 ! 189: SYSIN EXP E,2 ! 190: SYSIO EXP E,2 ! 191: .IF .CNLD ! 192: .ELSE ! 193: SYSLD EXP E,2 ! 194: .FI ! 195: SYSMM EXP E,0 ! 196: SYSMX EXP E,0 ! 197: SYSOU EXP E,2 ! 198: SYSPI EXP E,2 ! 199: SYSPP EXP E,0 ! 200: SYSPR EXP E,2 ! 201: SYSRD EXP E,2 ! 202: SYSRI EXP E,2 ! 203: SYSSC EXP E,2 ! 204: .IF .CUST ! 205: SYSST EXP E,2 ! 206: .FI ! 207: SYSTM EXP E,0 ! 208: SYSTT EXP E,0 ! 209: .IF .CNLD ! 210: .ELSE ! 211: SYSUL EXP E,0 ! 212: .FI ! 213: .IF .CNEX ! 214: .ELSE ! 215: SYSXI EXP E,2 ! 216: .FI ! 217: EJC ! 218: * NAME GLOBAL LABELS, INTERNAL PROCEDURES AND ROUTINES. ! 219: * ! 220: CMPCE GLB ! 221: CMPEL GLB ! 222: CMPLE GLB ! 223: CMPSE GLB ! 224: EVLXF GLB ! 225: EVLXN GLB ! 226: EVLXV GLB ! 227: LCNXE GLB ! 228: TRXQR GLB ! 229: ACESS INP R,1 ! 230: ACOMP INP N,5 ! 231: ALLOC INP E,0 ! 232: .IF .CNBF ! 233: .ELSE ! 234: ALOBF INP E,0 ! 235: .FI ! 236: ALOCS INP E,0 ! 237: ALOST INP E,0 ! 238: .IF .CNRA ! 239: ARITH INP N,2 ! 240: .ELSE ! 241: ARITH INP N,3 ! 242: .FI ! 243: ASIGN INP R,1 ! 244: ASINP INP R,1 ! 245: BLKLN INP E,0 ! 246: CBLCK INP N,1 ! 247: CDGCG INP E,0 ! 248: CDGEX INP R,0 ! 249: CDGNM INP R,0 ! 250: CDGVL INP R,0 ! 251: CDWRD INP E,0 ! 252: CMGEN INP R,0 ! 253: CMPIL INP E,0 ! 254: CNCRD INP E,0 ! 255: COPND INP E,0 ! 256: DFFNC INP E,0 ! 257: DTYPE INP E,0 ! 258: DUMPR INP E,0 ! 259: ERMSG INP E,0 ! 260: ERTEX INP E,0 ! 261: EVALI INP R,3 ! 262: EVALP INP R,1 ! 263: EVALS INP R,2 ! 264: EVALX INP R,1 ! 265: EXBLD INP E,0 ! 266: EXPAN INP E,0 ! 267: EXPAP INP E,1 ! 268: EXPDM INP N,0 ! 269: EXPOP INP N,0 ! 270: GBCOL INP E,0 ! 271: GBCPF INP E,0 ! 272: GTARR INP E,1 ! 273: .IF .CNBF ! 274: .ELSE ! 275: GTBUF INP E,1 ! 276: .FI ! 277: EJC ! 278: GTCOD INP E,1 ! 279: GTEXP INP E,1 ! 280: GTINT INP E,1 ! 281: GTNUM INP E,1 ! 282: GTNVR INP E,1 ! 283: GTPAT INP E,1 ! 284: .IF .CNRA ! 285: .ELSE ! 286: GTREA INP E,1 ! 287: .FI ! 288: GTSMI INP N,2 ! 289: GTSTG INP N,1 ! 290: GTVAR INP E,1 ! 291: HASHS INP E,0 ! 292: ICBLD INP E,0 ! 293: IDENT INP E,1 ! 294: INOUT INP E,0 ! 295: .IF .CNBF ! 296: .ELSE ! 297: INSBF INP E,2 ! 298: .FI ! 299: IOFTG INP N,1 ! 300: IOPUT INP N,4 ! 301: KTREX INP R,0 ! 302: KWNAM INP N,0 ! 303: LCOMP INP N,5 ! 304: LISTR INP E,0 ! 305: LISTT INP E,0 ! 306: NEXTS INP E,0 ! 307: PATIN INP N,2 ! 308: PATST INP N,1 ! 309: PBILD INP E,0 ! 310: PCONC INP E,0 ! 311: PCOPY INP N,0 ! 312: .IF .CNPF ! 313: .ELSE ! 314: PRFLR INP E,0 ! 315: PRFLU INP E,0 ! 316: .FI ! 317: PRPAR INP E,0 ! 318: PRTCF INP E,0 ! 319: PRTCH INP E,0 ! 320: PRTFB INP E,0 ! 321: PRTFH INP R,0 ! 322: PRTIN INP E,0 ! 323: PRTMI INP E,0 ! 324: PRTNM INP R,0 ! 325: PRTNV INP E,0 ! 326: PRTPG INP E,0 ! 327: PRTPS INP E,0 ! 328: PRTSF INP E,0 ! 329: PRTSN INP E,0 ! 330: PRTST INP R,0 ! 331: EJC ! 332: PRTVF INP E,0 ! 333: PRTVL INP R,0 ! 334: PRTVN INP E,0 ! 335: PTTFH INP E,0 ! 336: PTTST INP E,0 ! 337: .IF .CNRA ! 338: .ELSE ! 339: RCBLD INP E,0 ! 340: .FI ! 341: READR INP E,0 ! 342: .IF .CASL ! 343: SBSCC INP E,0 ! 344: SBSTG INP E,0 ! 345: .FI ! 346: SBSTR INP E,0 ! 347: SCANE INP E,0 ! 348: SCNGF INP E,0 ! 349: SETVR INP E,0 ! 350: .IF .CNSR ! 351: .ELSE ! 352: SORTA INP N,1 ! 353: SORTC INP E,1 ! 354: SORTF INP E,0 ! 355: SORTH INP N,0 ! 356: .FI ! 357: TFIND INP E,1 ! 358: TRACE INP N,3 ! 359: TRBLD INP E,0 ! 360: TRCHN INP E,1 ! 361: TRIMR INP E,0 ! 362: TRXEQ INP R,0 ! 363: XSCAN INP E,0 ! 364: XSCNI INP N,2 ! 365: ARREF INR ! 366: CFUNC INR ! 367: EROSI INR ! 368: ERROR INR ! 369: EXFAL INR ! 370: EXINT INR ! 371: EXITS INR ! 372: EXIXR INR ! 373: EXNAM INR ! 374: EXNUL INR ! 375: .IF .CNRA ! 376: .ELSE ! 377: EXREA INR ! 378: .FI ! 379: EXSID INR ! 380: EXVNM INR ! 381: FAILP INR ! 382: FLPOP INR ! 383: INDIR INR ! 384: INITL INR ! 385: MATCH INR ! 386: RETRN INR ! 387: STAKV INR ! 388: STCOV INR ! 389: STMGO INR ! 390: STOPR INR ! 391: SUCCP INR ! 392: TTL S P I T B O L -- DEFINITIONS AND DATA STRUCTURES ! 393: * THIS SECTION CONTAINS ALL SYMBOL DEFINITIONS AND ALSO ! 394: * PICTURES OF ALL DATA STRUCTURES USED IN THE SYSTEM. ! 395: * ! 396: SEC START OF DEFINITIONS SECTION ! 397: * ! 398: * DEFINITIONS OF MACHINE PARAMETERS ! 399: * ! 400: * THE MINIMAL TRANSLATOR SHOULD SUPPLY APPROPRIATE VALUES ! 401: * FOR THE PARTICULAR TARGET MACHINE FOR ALL THE ! 402: * EQU * ! 403: * DEFINITIONS GIVEN AT THE START OF THIS SECTION. ! 404: * NOTE THAT EVEN IF CONDITIONAL ASSEMBLY IS USED TO OMIT ! 405: * SOME FEATURE (E.G. REAL ARITHMETIC) A FULL SET OF CFP$- ! 406: * VALUES MUST BE SUPPLIED. USE DUMMY VALUES IF GENUINE ! 407: * ONES ARE NOT NEEDED. ! 408: * ! 409: CFP$A EQU * NUMBER OF CHARACTERS IN ALPHABET ! 410: * ! 411: CFP$B EQU * BAUS/WORD ADDRESSING FACTOR ! 412: * ! 413: CFP$C EQU * NUMBER OF CHARACTERS PER WORD ! 414: * ! 415: CFP$F EQU * OFFSET IN BAUS TO CHARS IN ! 416: * SCBLK. SEE SCBLK FORMAT. ! 417: * ! 418: CFP$I EQU * NUMBER OF WORDS IN INTEGER CONSTANT ! 419: * ! 420: CFP$M EQU * MAX POSITIVE INTEGER IN ONE WORD ! 421: * ! 422: CFP$N EQU * NUMBER OF BITS IN ONE WORD ! 423: * ! 424: CFP$R EQU * NUMBER OF WORDS IN REAL CONSTANT ! 425: * ! 426: CFP$S EQU * NUMBER OF SIG DIGS FOR REAL OUTPUT ! 427: * ! 428: * THE FOLLOWING DEFINITION FOR CFP$U SUPPLIES A REALISTIC ! 429: * UPPER BOUND ON THE SIZE OF THE ALPHABET. CFP$U IS USED ! 430: * TO SAVE SPACE IN THE SCANE BSW-IFF-ESW TABLE AND TO EASE ! 431: * TRANSLATION STORAGE REQUIREMENTS. ! 432: * ! 433: CFP$U EQU * REALISTIC UPPER BOUND ON ALPHABET ! 434: * ! 435: CFP$X EQU * MAX DIGITS IN REAL EXPONENT ! 436: * ! 437: MXDGS EQU CFP$S+CFP$X MAX DIGITS IN REAL NUMBER ! 438: * ! 439: NSTMX EQU MXDGS+5 MAX SPACE FOR REAL (FOR +0.E+) ! 440: EJC ! 441: * ! 442: * ENVIRONMENT PARAMETERS ! 443: * ! 444: * THE SPITBOL PROGRAM IS ESSENTIALLY INDEPENDENT OF ! 445: * THE DEFINITIONS OF THESE PARAMETERS. HOWEVER, THE ! 446: * EFFICIENCY OF THE SYSTEM MAY BE AFFECTED. CONSEQUENTLY, ! 447: * THESE PARAMETERS MAY REQUIRE TUNING FOR A GIVEN VERSION ! 448: * THE VALUES GIVEN IN COMMENTS HAVE BEEN SUCCESSFULLY USED. ! 449: * ! 450: * E$SRS IS THE NUMBER OF WORDS TO RESERVE AT THE END OF ! 451: * STORAGE FOR END OF RUN PROCESSING. IT SHOULD BE ! 452: * SET AS SMALL AS POSSIBLE WITHOUT CAUSING MEMORY OVERFLOW ! 453: * IN CRITICAL SITUATIONS (E.G. MEMORY OVERFLOW TERMINATION) ! 454: * AND SHOULD THUS RESERVE SUFFICIENT SPACE AT LEAST FOR ! 455: * AN SCBLK CONTAINING SAY 30 CHARACTERS. ! 456: * ! 457: E$SRS EQU * 30 WORDS ! 458: * ! 459: * E$STS IS THE NUMBER OF WORDS GRABBED IN A CHUNK WHEN ! 460: * STORAGE IS ALLOCATED IN THE STATIC REGION. THE MINIMUM ! 461: * PERMITTED VALUE IS 256/CFP$B. LARGER VALUES WILL LEAD ! 462: * TO INCREASED EFFICIENCY AT THE COST OF WASTING MEMORY. ! 463: * ! 464: E$STS EQU * 500 WORDS ! 465: * ! 466: * E$CBS IS THE SIZE OF CODE BLOCK ALLOCATED INITIALLY AND ! 467: * THE EXPANSION INCREMENT IF OVERFLOW OCCURS. IF THIS VALUE ! 468: * IS TOO SMALL OR TOO LARGE, EXCESSIVE GARBAGE COLLECTIONS ! 469: * WILL OCCUR DURING COMPILATION AND MEMORY MAY BE LOST ! 470: * IN THE CASE OF A TOO LARGE VALUE. ! 471: * ! 472: E$CBS EQU * 500 WORDS ! 473: * ! 474: * E$HNB IS THE NUMBER OF BUCKET HEADERS IN THE VARIABLE ! 475: * HASH TABLE. IT SHOULD ALWAYS BE ODD. LARGER VALUES WILL ! 476: * SPEED UP COMPILATION AND INDIRECT REFERENCES AT THE ! 477: * EXPENSE OF ADDITIONAL STORAGE FOR THE HASH TABLE ITSELF. ! 478: * ! 479: E$HNB EQU * 127 BUCKET HEADERS ! 480: * ! 481: * E$HNW IS THE MAXIMUM NUMBER OF WORDS OF A STRING ! 482: * NAME WHICH PARTICIPATE IN THE STRING HASH ALGORITHM. ! 483: * LARGER VALUES GIVE A BETTER HASH AT THE EXPENSE OF TAKING ! 484: * LONGER TO COMPUTE THE HASH. THERE IS SOME OPTIMAL VALUE. ! 485: * ! 486: E$HNW EQU * 6 WORDS ! 487: * ! 488: * E$FSP . IF THE AMOUNT OF FREE SPACE LEFT AFTER A GARBAGE ! 489: * COLLECTION IS SMALL COMPARED TO THE TOTAL AMOUNT OF SPACE ! 490: * IN USE GARBAGE COLLECTOR THRASHING IS LIKELY TO OCCUR AS ! 491: * THIS SPACE IS USED UP. E$FSP IS A MEASURE OF THE ! 492: * MINIMUM PERCENTAGE OF DYNAMIC MEMORY LEFT AS FREE SPACE ! 493: * BEFORE THE SYSTEM ROUTINE SYSMM IS CALLED TO TRY TO ! 494: * OBTAIN MORE MEMORY. ! 495: * ! 496: E$FSP EQU * 15 PERCENT ! 497: EJC ! 498: * ! 499: * DEFINITIONS OF CODES FOR LETTERS ! 500: * ! 501: CH$LA EQU * LETTER A ! 502: CH$LB EQU * LETTER B ! 503: CH$LC EQU * LETTER C ! 504: CH$LD EQU * LETTER D ! 505: CH$LE EQU * LETTER E ! 506: CH$LF EQU * LETTER F ! 507: CH$LG EQU * LETTER G ! 508: CH$LH EQU * LETTER H ! 509: CH$LI EQU * LETTER I ! 510: CH$LJ EQU * LETTER J ! 511: CH$LK EQU * LETTER K ! 512: CH$LL EQU * LETTER L ! 513: CH$LM EQU * LETTER M ! 514: CH$LN EQU * LETTER N ! 515: CH$LO EQU * LETTER O ! 516: CH$LP EQU * LETTER P ! 517: CH$LQ EQU * LETTER Q ! 518: CH$LR EQU * LETTER R ! 519: CH$LS EQU * LETTER S ! 520: CH$LT EQU * LETTER T ! 521: CH$LU EQU * LETTER U ! 522: CH$LV EQU * LETTER V ! 523: CH$LW EQU * LETTER W ! 524: CH$LX EQU * LETTER X ! 525: CH$LY EQU * LETTER Y ! 526: CH$L$ EQU * LETTER Z ! 527: * ! 528: * DEFINITIONS OF CODES FOR DIGITS ! 529: * ! 530: CH$D0 EQU * DIGIT 0 ! 531: CH$D1 EQU * DIGIT 1 ! 532: CH$D2 EQU * DIGIT 2 ! 533: CH$D3 EQU * DIGIT 3 ! 534: CH$D4 EQU * DIGIT 4 ! 535: CH$D5 EQU * DIGIT 5 ! 536: CH$D6 EQU * DIGIT 6 ! 537: CH$D7 EQU * DIGIT 7 ! 538: CH$D8 EQU * DIGIT 8 ! 539: CH$D9 EQU * DIGIT 9 ! 540: EJC ! 541: * ! 542: * DEFINITIONS OF CODES FOR SPECIAL CHARACTERS ! 543: * ! 544: * THE NAMES OF THESE CHARACTERS ARE RELATED TO THEIR ! 545: * ORIGINAL REPRESENTATION IN THE EBCDIC SET CORRESPONDING ! 546: * TO THE DESCRIPTION IN STANDARD SNOBOL4 MANUALS AND TEXTS. ! 547: * ! 548: CH$AM EQU * KEYWORD OPERATOR (AMPERSAND) ! 549: CH$AS EQU * MULTIPLICATION SYMBOL (ASTERISK) ! 550: CH$AT EQU * CURSOR POSITION OPERATOR (AT) ! 551: CH$BB EQU * LEFT ARRAY BRACKET (LESS THAN) ! 552: CH$BL EQU * BLANK ! 553: CH$BR EQU * ALTERNATION OPERATOR (VERTICAL BAR) ! 554: CH$CL EQU * GOTO SYMBOL (COLON) ! 555: CH$CM EQU * COMMA ! 556: CH$DL EQU * INDIRECTION OPERATOR (DOLLAR) ! 557: CH$DT EQU * NAME OPERATOR (DOT) ! 558: CH$DQ EQU * DOUBLE QUOTE ! 559: CH$EQ EQU * EQUAL SIGN ! 560: CH$EX EQU * EXPONENTIATION OPERATOR (EXCLM) ! 561: CH$MN EQU * MINUS SIGN ! 562: CH$NM EQU * NUMBER SIGN ! 563: CH$NT EQU * NEGATION OPERATOR (NOT) ! 564: CH$PC EQU * PERCENT ! 565: CH$PL EQU * PLUS SIGN ! 566: CH$PP EQU * LEFT PARENTHESIS ! 567: CH$RB EQU * RIGHT ARRAY BRACKET (GRTR THAN) ! 568: CH$RP EQU * RIGHT PARENTHESIS ! 569: CH$QU EQU * INTERROGATION OPERATOR (QUESTION) ! 570: CH$SL EQU * SLASH ! 571: CH$SM EQU * SEMICOLON ! 572: CH$SQ EQU * SINGLE QUOTE ! 573: CH$UN EQU * SPECIAL IDENTIFIER CHAR (UNDERLINE) ! 574: CH$OB EQU * OPENING BRACKET ! 575: CH$CB EQU * CLOSING BRACKET ! 576: EJC ! 577: * ! 578: * REMAINING CHARS ARE OPTIONAL ADDITIONS TO THE STANDARDS. ! 579: * THEY ARE ALL UNDER CONDITIONAL ASSEMBLY. ! 580: .IF .CAHT ! 581: * ! 582: * TAB CHARACTERS - SYNTACTICALLY EQUIVALENT TO BLANK ! 583: * ! 584: CH$HT EQU * HORIZONTAL TAB ! 585: .FI ! 586: .IF .CAVT ! 587: CH$VT EQU * VERTICAL TAB ! 588: .FI ! 589: .IF .CASL ! 590: * ! 591: * LOWER CASE OR SHIFTED CASE ALPHABETIC CHARS ! 592: * ! 593: CH$$A EQU * SHIFTED A ! 594: CH$$B EQU * SHIFTED B ! 595: CH$$C EQU * SHIFTED C ! 596: CH$$D EQU * SHIFTED D ! 597: CH$$E EQU * SHIFTED E ! 598: CH$$F EQU * SHIFTED F ! 599: CH$$G EQU * SHIFTED G ! 600: CH$$H EQU * SHIFTED H ! 601: CH$$I EQU * SHIFTED I ! 602: CH$$J EQU * SHIFTED J ! 603: CH$$K EQU * SHIFTED K ! 604: CH$$L EQU * SHIFTED L ! 605: CH$$M EQU * SHIFTED M ! 606: CH$$N EQU * SHIFTED N ! 607: CH$$O EQU * SHIFTED O ! 608: CH$$P EQU * SHIFTED P ! 609: CH$$Q EQU * SHIFTED Q ! 610: CH$$R EQU * SHIFTED R ! 611: CH$$S EQU * SHIFTED S ! 612: CH$$T EQU * SHIFTED T ! 613: CH$$U EQU * SHIFTED U ! 614: CH$$V EQU * SHIFTED V ! 615: CH$$W EQU * SHIFTED W ! 616: CH$$X EQU * SHIFTED X ! 617: CH$$Y EQU * SHIFTED Y ! 618: CH$$$ EQU * SHIFTED Z ! 619: .IF .CASL ! 620: DFA$A EQU CH$$A-CH$LA DIFF BETWEEN LC AND UC LETTERS ! 621: .FI ! 622: .FI ! 623: EJC ! 624: * ! 625: * DATA BLOCK FORMATS AND DEFINITIONS ! 626: * ! 627: * THE FOLLOWING SECTIONS DESCRIBE THE DETAILED FORMAT OF ! 628: * ALL POSSIBLE DATA BLOCKS IN STATIC AND DYNAMIC MEMORY. ! 629: * ! 630: * EVERY BLOCK HAS A NAME OF THE FORM XXBLK WHERE XX IS A ! 631: * UNIQUE TWO CHARACTER IDENTIFIER. THE FIRST WORD OF EVERY ! 632: * BLOCK MUST CONTAIN A POINTER TO A PROGRAM LOCATION IN THE ! 633: * INTERPRETOR WHICH IS IMMEDIATELY PRECEDED BY AN ADDRESS ! 634: * CONSTANT CONTAINING THE VALUE BL$XX WHERE XX IS THE BLOCK ! 635: * IDENTIFIER. THIS PROVIDES A UNIFORM MECHANISM FOR ! 636: * DISTINGUISHING BETWEEN THE VARIOUS BLOCK TYPES. ! 637: * ! 638: * IN SOME CASES, THE CONTENTS OF THE FIRST WORD IS CONSTANT ! 639: * FOR A GIVEN BLOCK TYPE AND MERELY SERVES AS A POINTER ! 640: * TO THE IDENTIFYING ADDRESS CONSTANT. HOWEVER, IN OTHER ! 641: * CASES THERE ARE SEVERAL POSSIBILITIES FOR THE FIRST ! 642: * WORD IN WHICH CASE EACH OF THE SEVERAL PROGRAM ENTRY ! 643: * POINTS MUST BE PRECEDED BY THE APPROPRIATE CONSTANT. ! 644: * ! 645: * IN EACH BLOCK, SOME OF THE FIELDS ARE RELOCATABLE. THIS ! 646: * MEANS THAT THEY MAY CONTAIN A POINTER TO ANOTHER BLOCK ! 647: * IN THE DYNAMIC AREA. (TO BE MORE PRECISE, IF THEY CONTAIN ! 648: * A POINTER WITHIN THE DYNAMIC AREA, THEN IT IS A POINTER ! 649: * TO A BLOCK). SUCH FIELDS MUST BE MODIFIED BY THE GARBAGE ! 650: * COLLECTOR (PROCEDURE GBCOL) WHENEVER BLOCKS ARE COMPACTED ! 651: * IN THE DYNAMIC REGION. THE GARBAGE COLLECTOR (ACTUALLY ! 652: * PROCEDURE GBCPF) REQUIRES THAT ALL SUCH RELOCATABLE ! 653: * FIELDS IN A BLOCK MUST BE CONTIGUOUS. ! 654: EJC ! 655: * ! 656: * THE DESCRIPTION FORMAT USES THE FOLLOWING SCHEME. ! 657: * ! 658: * 1) BLOCK TITLE AND TWO CHARACTER IDENTIFIER ! 659: * ! 660: * 2) DESCRIPTION OF BASIC USE OF BLOCK AND INDICATION ! 661: * OF CIRCUMSTANCES UNDER WHICH IT IS CONSTRUCTED. ! 662: * ! 663: * 3) PICTURE OF THE BLOCK FORMAT. IN THESE PICTURES LOW ! 664: * MEMORY ADDRESSES ARE AT THE TOP OF THE PAGE. FIXED ! 665: * LENGTH FIELDS ARE SURROUNDED BY I (LETTER I). FIELDS ! 666: * WHICH ARE FIXED LENGTH BUT WHOSE LENGTH IS DEPENDENT ! 667: * ON A CONFIGURATION PARAMETER ARE SURROUNDED BY * ! 668: * (ASTERISK). VARIABLE LENGTH FIELDS ARE SURROUNDED ! 669: * BY / (SLASH). ! 670: * ! 671: * 4) DEFINITION OF SYMBOLIC OFFSETS TO FIELDS IN ! 672: * BLOCK AND OF THE SIZE OF THE BLOCK IF FIXED LENGTH ! 673: * OR OF THE SIZE OF THE FIXED LENGTH FIELDS IF THE ! 674: * BLOCK IS VARIABLE LENGTH. ! 675: * NOTE THAT SOME ROUTINES SUCH AS GBCPF ASSUME ! 676: * CERTAIN OFFSETS ARE EQUAL. THE DEFINITIONS ! 677: * GIVEN HERE ENFORCE THIS. MAKE CHANGES TO ! 678: * THEM ONLY WITH DUE CARE. ! 679: * ! 680: * DEFINITIONS OF COMMON OFFSETS ! 681: * ! 682: OFFS1 EQU 1 ! 683: OFFS2 EQU 2 ! 684: OFFS3 EQU 3 ! 685: * ! 686: * 5) DETAILED COMMENTS ON THE SIGNIFICANCE AND FORMATS ! 687: * OF THE VARIOUS FIELDS. ! 688: * ! 689: * THE ORDER IS ALPHABETICAL BY IDENTIFICATION CODE. ! 690: EJC ! 691: * ! 692: * DEFINITIONS OF BLOCK CODES ! 693: * ! 694: * THIS TABLE PROVIDES A UNIQUE IDENTIFICATION CODE FOR ! 695: * EACH SEPARATE BLOCK TYPE. THE FIRST WORD OF A BLOCK IN ! 696: * THE DYNAMIC AREA ALWAYS CONTAINS THE ADDRESS OF A PROGRAM ! 697: * ENTRY POINT. THE BLOCK CODE IS USED AS THE ENTRY POINT ID ! 698: * THE ORDER OF THESE CODES DICTATES THE ORDER OF THE TABLE ! 699: * USED BY THE DATATYPE FUNCTION (SCNMT IN THE CONSTANT SEC) ! 700: * ! 701: * BLOCK CODES FOR ACCESSIBLE DATATYPES ! 702: * ! 703: BL$AR EQU 0 ARBLK ARRAY ! 704: .IF .CNBF ! 705: BL$CD EQU BL$AR+1 CDBLK CODE ! 706: .ELSE ! 707: BL$BC EQU BL$AR+1 BCBLK BUFFER ! 708: BL$CD EQU BL$BC+1 CDBLK CODE ! 709: .FI ! 710: BL$EX EQU BL$CD+1 EXBLK EXPRESSION ! 711: BL$IC EQU BL$EX+1 ICBLK INTEGER ! 712: BL$NM EQU BL$IC+1 NMBLK NAME ! 713: BL$P0 EQU BL$NM+1 P0BLK PATTERN ! 714: BL$P1 EQU BL$P0+1 P1BLK PATTERN ! 715: BL$P2 EQU BL$P1+1 P2BLK PATTERN ! 716: .IF .CNRA ! 717: BL$SC EQU BL$P2+1 SCBLK STRING ! 718: .ELSE ! 719: BL$RC EQU BL$P2+1 RCBLK REAL ! 720: BL$SC EQU BL$RC+1 SCBLK STRING ! 721: .FI ! 722: BL$SE EQU BL$SC+1 SEBLK EXPRESSION ! 723: BL$TB EQU BL$SE+1 TBBLK TABLE ! 724: BL$VC EQU BL$TB+1 VCBLK ARRAY ! 725: BL$XN EQU BL$VC+1 XNBLK EXTERNAL ! 726: BL$XR EQU BL$XN+1 XRBLK EXTERNAL ! 727: BL$PD EQU BL$XR+1 PDBLK PROGRAM DEFINED DATATYPE ! 728: * ! 729: BL$$D EQU BL$PD+1 NUMBER OF BLOCK CODES FOR DATA ! 730: * ! 731: * OTHER BLOCK CODES ! 732: * ! 733: BL$TR EQU BL$PD+1 TRBLK ! 734: .IF .CNBF ! 735: BL$CC EQU BL$TR+1 CCBLK ! 736: .ELSE ! 737: BL$BF EQU BL$TR+1 BFBLK ! 738: BL$CC EQU BL$BF+1 CCBLK ! 739: .FI ! 740: BL$CM EQU BL$CC+1 CMBLK ! 741: BL$CO EQU BL$CM+1 COBLK ! 742: BL$CT EQU BL$CO+1 CTBLK ! 743: BL$DF EQU BL$CT+1 DFBLK ! 744: BL$EF EQU BL$DF+1 EFBLK ! 745: BL$EV EQU BL$EF+1 EVBLK ! 746: BL$FF EQU BL$EV+1 FFBLK ! 747: BL$KV EQU BL$FF+1 KVBLK ! 748: BL$PF EQU BL$KV+1 PFBLK ! 749: BL$TE EQU BL$PF+1 TEBLK ! 750: * ! 751: BL$$I EQU 0 DEFAULT IDENTIFICATION CODE ! 752: BL$$T EQU BL$TR+1 CODE FOR DATA OR TRACE BLOCK ! 753: BL$$$ EQU BL$TE+1 NUMBER OF BLOCK CODES ! 754: EJC ! 755: * ! 756: * FIELD REFERENCES ! 757: * ! 758: * REFERENCES TO THE FIELDS OF DATA BLOCKS ARE SYMBOLIC ! 759: * (I.E. USE THE SYMBOLIC OFFSETS) WITH THE FOLLOWING ! 760: * EXCEPTIONS. ! 761: * ! 762: * 1) REFERENCES TO THE FIRST WORD ARE USUALLY NOT ! 763: * SYMBOLIC SINCE THEY USE THE (X) OPERAND FORMAT. ! 764: * ! 765: * 2) THE CODE WHICH CONSTRUCTS A BLOCK IS OFTEN NOT ! 766: * SYMBOLIC AND SHOULD BE CHANGED IF THE CORRESPONDING ! 767: * BLOCK FORMAT IS MODIFIED. ! 768: * ! 769: * 3) THE PLC AND PSC INSTRUCTIONS IMPLY AN OFFSET ! 770: * CORRESPONDING TO THE DEFINITION OF CFP$F. ! 771: * ! 772: * 4) THERE ARE NON-SYMBOLIC REFERENCES (EASILY CHANGED) ! 773: * IN THE GARBAGE COLLECTOR (PROCEDURES GBCPF, BLKLN). ! 774: * ! 775: * 5) THE FIELDS IDVAL, FARGS APPEAR IN SEVERAL BLOCKS ! 776: * AND ANY CHANGES MUST BE MADE IN PARALLEL TO ALL ! 777: * BLOCKS CONTAINING THE FIELDS. THE ACTUAL REFERENCES ! 778: * TO THESE FIELDS ARE SYMBOLIC WITH THE ABOVE ! 779: * LISTED EXCEPTIONS. ! 780: * ! 781: * 6) SEVERAL SPOTS IN THE CODE ASSUME THAT THE ! 782: * DEFINITIONS OF THE FIELDS VRVAL, TEVAL, TRNXT ARE ! 783: * THE SAME (THESE ARE SECTIONS OF CODE WHICH SEARCH ! 784: * OUT ALONG A TRBLK CHAIN FROM A VARIABLE). ! 785: * ! 786: * 7) REFERENCES TO THE FIELDS OF AN ARRAY BLOCK IN THE ! 787: * ARRAY REFERENCE ROUTINE ARREF ARE NON-SYMBOLIC. ! 788: * ! 789: * APART FROM THE EXCEPTIONS LISTED, REFERENCES ARE SYMBOLIC ! 790: * AS FAR AS POSSIBLE AND MODIFYING THE ORDER OR NUMBER ! 791: * OF FIELDS WILL NOT REQUIRE CHANGES. ! 792: EJC ! 793: * ! 794: * COMMON FIELDS FOR FUNCTION BLOCKS ! 795: * ! 796: * BLOCKS WHICH REPRESENT CALLABLE FUNCTIONS HAVE TWO ! 797: * COMMON FIELDS AT THE START OF THE BLOCK AS FOLLOWS. ! 798: * ! 799: * +------------------------------------+ ! 800: * I FCODE I ! 801: * +------------------------------------+ ! 802: * I FARGS I ! 803: * +------------------------------------+ ! 804: * / / ! 805: * / REST OF FUNCTION BLOCK / ! 806: * / / ! 807: * +------------------------------------+ ! 808: * ! 809: FCODE EQU 0 POINTER TO CODE FOR FUNCTION ! 810: FARGS EQU 1 NUMBER OF ARGUMENTS ! 811: * ! 812: * FCODE IS A POINTER TO THE LOCATION IN THE INTERPRETOR ! 813: * PROGRAM WHICH PROCESSES THIS TYPE OF FUNCTION CALL. ! 814: * ! 815: * FARGS IS THE EXPECTED NUMBER OF ARGUMENTS. THE ACTUAL ! 816: * NUMBER OF ARGUMENTS IS ADJUSTED TO THIS AMOUNT BY ! 817: * DELETING EXTRA ARGUMENTS OR SUPPLYING TRAILING NULLS ! 818: * FOR MISSING ONES BEFORE TRANSFERRING THOUGH FCODE. ! 819: * A VALUE OF 999 MAY BE USED IN THIS FIELD TO INDICATE A ! 820: * VARIABLE NUMBER OF ARGUMENTS (SEE SVBLK FIELD SVNAR). ! 821: * ! 822: * THE BLOCK TYPES WHICH FOLLOW THIS SCHEME ARE. ! 823: * ! 824: * FFBLK FIELD FUNCTION ! 825: * DFBLK DATATYPE FUNCTION ! 826: * PFBLK PROGRAM DEFINED FUNCTION ! 827: * EFBLK EXTERNAL LOADED FUNCTION ! 828: EJC ! 829: * ! 830: * IDENTIFICATION FIELD ! 831: * ! 832: * ! 833: * ID FIELD ! 834: * ! 835: * CERTAIN PROGRAM ACCESSIBLE OBJECTS (THOSE WHICH CONTAIN ! 836: * OTHER DATA VALUES AND CAN BE COPIED) ARE GIVEN A UNIQUE ! 837: * IDENTIFICATION NUMBER (SEE EXSID). THIS ID VALUE IS AN ! 838: * ADDRESS INTEGER VALUE WHICH IS ALWAYS STORED IN WORD TWO. ! 839: * ! 840: IDVAL EQU 1 ID VALUE FIELD ! 841: * ! 842: * THE BLOCKS CONTAINING AN IDVAL FIELD ARE. ! 843: * ! 844: * ARBLK ARRAY ! 845: * PDBLK PROGRAM DEFINED DATATYPE ! 846: * TBBLK TABLE ! 847: * VCBLK VECTOR BLOCK (ARRAY) ! 848: * ! 849: * NOTE THAT A ZERO IDVAL MEANS THAT THE BLOCK IS ONLY ! 850: * HALF BUILT AND SHOULD NOT BE DUMPED (SEE DUMPR). ! 851: EJC ! 852: * ! 853: * ARRAY BLOCK (ARBLK) ! 854: * ! 855: * AN ARRAY BLOCK REPRESENTS AN ARRAY VALUE OTHER THAN ONE ! 856: * WITH ONE DIMENSION WHOSE LOWER BOUND IS ONE (SEE VCBLK). ! 857: * AN ARBLK IS BUILT WITH A CALL TO THE FUNCTIONS CONVERT ! 858: * (S$CNV) OR ARRAY (S$ARR). ! 859: * ! 860: * +------------------------------------+ ! 861: * I ARTYP I ! 862: * +------------------------------------+ ! 863: * I IDVAL I ! 864: * +------------------------------------+ ! 865: * I ARLEN I ! 866: * +------------------------------------+ ! 867: * I AROFS I ! 868: * +------------------------------------+ ! 869: * I ARNDM I ! 870: * +------------------------------------+ ! 871: * * ARLBD * ! 872: * +------------------------------------+ ! 873: * * ARDIM * ! 874: * +------------------------------------+ ! 875: * * * ! 876: * * ABOVE 2 FLDS REPEATED FOR EACH DIM * ! 877: * * * ! 878: * +------------------------------------+ ! 879: * I ARPRO I ! 880: * +------------------------------------+ ! 881: * / / ! 882: * / ARVLS / ! 883: * / / ! 884: * +------------------------------------+ ! 885: EJC ! 886: * ! 887: * ARRAY BLOCK (CONTINUED) ! 888: * ! 889: ARTYP EQU 0 POINTER TO DUMMY ROUTINE B$ART ! 890: ARLEN EQU IDVAL+1 LENGTH OF ARBLK IN BAUS ! 891: AROFS EQU ARLEN+1 OFFSET IN ARBLK TO ARPRO FIELD ! 892: ARNDM EQU AROFS+1 NUMBER OF DIMENSIONS ! 893: ARLBD EQU ARNDM+1 LOW BOUND (FIRST SUBSCRIPT) ! 894: ARDIM EQU ARLBD+CFP$I DIMENSION (FIRST SUBSCRIPT) ! 895: ARLB2 EQU ARDIM+CFP$I LOW BOUND (SECOND SUBSCRIPT) ! 896: ARDM2 EQU ARLB2+CFP$I DIMENSION (SECOND SUBSCRIPT) ! 897: ARPRO EQU ARDIM+CFP$I ARRAY PROTOTYPE (ONE DIMENSION) ! 898: ARVLS EQU ARPRO+1 START OF VALUES (ONE DIMENSION) ! 899: ARPR2 EQU ARDM2+CFP$I ARRAY PROTOTYPE (TWO DIMENSIONS) ! 900: ARVL2 EQU ARPR2+1 START OF VALUES (TWO DIMENSIONS) ! 901: ARSI$ EQU ARLBD NUMBER OF STANDARD FIELDS IN BLOCK ! 902: ARDMS EQU ARLB2-ARLBD SIZE OF INFO FOR ONE SET OF BOUNDS ! 903: * ! 904: * THE BOUNDS AND DIMENSION FIELDS ARE SIGNED INTEGER ! 905: * VALUES AND EACH OCCUPY CFP$I WORDS IN THE ARBLK. ! 906: * ! 907: * THE LENGTH OF AN ARBLK IN BAUS MAY NOT EXCEED MXLEN. ! 908: * THIS IS REQUIRED TO KEEP NAME OFFSETS GARBAGE COLLECTABLE ! 909: * ! 910: * THE ACTUAL VALUES ARE ARRANGED IN ROW-WISE ORDER AND ! 911: * CAN CONTAIN A DATA POINTER OR A POINTER TO A TRBLK. ! 912: .IF .CNBF ! 913: .ELSE ! 914: EJC ! 915: * BUFFER CONTROL BLOCK (BCBLK) ! 916: * ! 917: * A BCBLK IS BUILT FOR EVERY BFBLK. ! 918: * ! 919: * +------------------------------------+ ! 920: * I BCTYP I ! 921: * +------------------------------------+ ! 922: * I IDVAL I ! 923: * +------------------------------------+ ! 924: * I BCLEN I ! 925: * +------------------------------------+ ! 926: * I BCBUF I ! 927: * +------------------------------------+ ! 928: * ! 929: BCTYP EQU 0 PTR TO DUMMY ROUTINE B$BCT ! 930: BCLEN EQU IDVAL+1 DEFINED BUFFER LENGTH ! 931: BCBUF EQU BCLEN+1 PTR TO BFBLK ! 932: BCSI$ EQU BCBUF+1 SIZE OF BCBLK ! 933: * ! 934: * A BCBLK IS AN INDIRECT CONTROL HEADER FOR BFBLK. ! 935: * THE REASON FOR NOT STORING THIS DATA DIRECTLY ! 936: * IN THE RELATED BFBLK IS SO THAT THE BFBLK CAN ! 937: * MAINTAIN THE SAME SKELETAL STRUCTURE AS AN SCBLK ! 938: * THUS FACILITATING TRANSPARENT STRING OPERATIONS ! 939: * (FOR THE MOST PART). SPECIFICALLY, CFP$F IS THE ! 940: * SAME FOR A BFBLK AS FOR AN SCBLK. BY CONVENTION, ! 941: * WHEREEVER A BUFFER VALUE IS EMPLOYED, THE BCBLK ! 942: * IS POINTED TO. ! 943: * ! 944: * THE CORRESPONDING BFBLK IS POINTED TO BY THE ! 945: * BCBUF POINTER IN THE BCBLK. ! 946: * ! 947: * BCLEN IS THE CURRENT DEFINED SIZE OF THE CHARACTER ! 948: * ARRAY IN THE BFBLK. CHARACTERS FOLLOWING THE OFFSET ! 949: * OF BCLEN ARE UNDEFINED. ! 950: * ! 951: EJC ! 952: * ! 953: * STRING BUFFER BLOCK (BFBLK) ! 954: * ! 955: * A BFBLK IS BUILT BY A CALL TO BUFFER(...) ! 956: * ! 957: * +------------------------------------+ ! 958: * I BFTYP I ! 959: * +------------------------------------+ ! 960: * I BFALC I ! 961: * +------------------------------------+ ! 962: * / / ! 963: * / BFCHR / ! 964: * / / ! 965: * +------------------------------------+ ! 966: * ! 967: BFTYP EQU 0 PTR TO DUMMY ROUTINE B$BFT ! 968: BFALC EQU BFTYP+1 ALLOCATED SIZE OF BUFFER ! 969: BFCHR EQU BFALC+1 CHARACTERS OF STRING ! 970: BFSI$ EQU BFCHR SIZE OF STANDARD FIELDS IN BFBLK ! 971: * ! 972: * THE CHARACTERS IN THE BUFFER ARE STORED LEFT JUSTIFIED. ! 973: * THE FINAL WORD OF DEFINED CHARACTERS IS ALWAYS ZERO ! 974: * (CHARACTER) PADDED. ANY TRAILING ALLOCATION PAST THE ! 975: * WORD CONTAINING THE LAST CHARACTER CONTAINS ! 976: * UNPREDICTABLE CONTENTS AND IS NEVER REFERENCED. ! 977: * ! 978: * NOTE THAT THE OFFSET TO THE CHARACTERS OF THE STRING ! 979: * IS GIVEN BY CFP$F, AS WITH AN SCBLK. HOWEVER, THE ! 980: * OFFSET WHICH IS OCCUPIED BY THE LENGTH FOR AN SCBLK ! 981: * IS THE TOTAL CHAR SPACE FOR BFBLKS, AND ROUTINES WHICH ! 982: * DEAL WITH BOTH MUST ACCOUNT FOR THIS DIFFERENCE. ! 983: * ! 984: * THE VALUE OF BFALC MAY NOT EXCEED MXLEN. THE VALUE OF ! 985: * BCLEN IS ALWAYS LESS THAN OR EQUAL TO BFALC. ! 986: * ! 987: .FI ! 988: EJC ! 989: * ! 990: * CODE CONSTRUCTION BLOCK (CCBLK) ! 991: * ! 992: * AT ANY ONE MOMENT THERE IS AT MOST ONE CCBLK INTO ! 993: * WHICH THE COMPILER IS CURRENTLY STORING CODE (CDWRD). ! 994: * ! 995: * +------------------------------------+ ! 996: * I CCTYP I ! 997: * +------------------------------------+ ! 998: * I CCLEN I ! 999: * +------------------------------------+ ! 1000: * I CCUSE I ! 1001: * +------------------------------------+ ! 1002: * / / ! 1003: * / CCCOD / ! 1004: * / / ! 1005: * +------------------------------------+ ! 1006: * ! 1007: CCTYP EQU 0 POINTER TO DUMMY ROUTINE B$CCT ! 1008: CCLEN EQU CCTYP+1 LENGTH OF CCBLK IN BAUS ! 1009: CCUSE EQU CCLEN+1 OFFSET PAST LAST USED WORD (BAUS) ! 1010: CCCOD EQU CCUSE+1 START OF GENERATED CODE IN BLOCK ! 1011: * ! 1012: * THE REASON THAT THE CCBLK IS A SEPARATE BLOCK TYPE FROM ! 1013: * THE USUAL CDBLK IS THAT THE GARBAGE COLLECTOR MUST ! 1014: * ONLY PROCESS THOSE FIELDS WHICH HAVE BEEN SET (SEE GBCPF) ! 1015: EJC ! 1016: * ! 1017: * CODE BLOCK (CDBLK) ! 1018: * ! 1019: * A CODE BLOCK IS BUILT FOR EACH STATEMENT COMPILED DURING ! 1020: * THE INITIAL COMPILATION OR BY SUBSEQUENT CALLS TO CODE. ! 1021: * ! 1022: * +------------------------------------+ ! 1023: * I CDJMP I ! 1024: * +------------------------------------+ ! 1025: * I CDSTM I ! 1026: * +------------------------------------+ ! 1027: * I CDLEN I ! 1028: * +------------------------------------+ ! 1029: * I CDFAL I ! 1030: * +------------------------------------+ ! 1031: * / / ! 1032: * / CDCOD / ! 1033: * / / ! 1034: * +------------------------------------+ ! 1035: * ! 1036: CDJMP EQU 0 PTR TO ROUTINE TO EXECUTE STATEMENT ! 1037: CDSTM EQU CDJMP+1 STATEMENT NUMBER ! 1038: CDLEN EQU OFFS2 LENGTH OF CDBLK IN BAUS ! 1039: CDFAL EQU OFFS3 FAILURE EXIT (SEE BELOW) ! 1040: CDCOD EQU CDFAL+1 EXECUTABLE PSEUDO-CODE ! 1041: CDSI$ EQU CDCOD NUMBER OF STANDARD FIELDS IN CDBLK ! 1042: * ! 1043: * CDSTM IS THE STATEMENT NUMBER OF THE CURRENT STATEMENT. ! 1044: * ! 1045: * CDJMP, CDFAL ARE SET AS FOLLOWS. ! 1046: * ! 1047: * 1) IF THE FAILURE EXIT IS THE NEXT STATEMENT ! 1048: * ! 1049: * CDJMP = B$CDS ! 1050: * CDFAL = PTR TO CDBLK FOR NEXT STATEMENT ! 1051: * ! 1052: * 2) IF THE FAILURE EXIT IS A SIMPLE LABEL NAME ! 1053: * ! 1054: * CDJMP = B$CDS ! 1055: * CDFAL IS A PTR TO THE VRTRA FIELD OF THE VRBLK ! 1056: * ! 1057: * 3) IF THERE IS NO FAILURE EXIT (-NOFAIL MODE) ! 1058: * ! 1059: * CDJMP = B$CDS ! 1060: * CDFAL = O$UNF ! 1061: * ! 1062: * 4) IF THE FAILURE EXIT IS COMPLEX OR DIRECT ! 1063: * ! 1064: * CDJMP = B$CDC ! 1065: * CDFAL IS THE OFFSET TO THE O$GOF WORD ! 1066: EJC ! 1067: * ! 1068: * CODE BLOCK (CONTINUED) ! 1069: * ! 1070: * CDCOD IS THE START OF THE ACTUAL CODE. FIRST WE DESCRIBE ! 1071: * THE CODE GENERATED FOR AN EXPRESSION. IN AN EXPRESSION, ! 1072: * ELEMENTS ARE FETCHED BY NAME OR BY VALUE. FOR EXAMPLE, ! 1073: * THE BINARY EQUAL OPERATOR FETCHES ITS LEFT ARGUMENT ! 1074: * BY NAME AND ITS RIGHT ARGUMENT BY VALUE. THESE TWO ! 1075: * CASES GENERATE QUITE DIFFERENT CODE AND ARE DESCRIBED ! 1076: * SEPARATELY. FIRST WE CONSIDER THE CODE BY VALUE CASE. ! 1077: * ! 1078: * GENERATION OF CODE BY VALUE FOR EXPRESSIONS ELEMENTS. ! 1079: * ! 1080: * EXPRESSION POINTER TO EXBLK OR SEBLK ! 1081: * ! 1082: * INTEGER CONSTANT POINTER TO ICBLK ! 1083: * ! 1084: * NULL CONSTANT POINTER TO NULLS ! 1085: * ! 1086: * PATTERN (RESULTING FROM PREEVALUATION) ! 1087: * =O$LPT ! 1088: * POINTER TO P0BLK,P1BLK OR P2BLK ! 1089: * ! 1090: * REAL CONSTANT POINTER TO RCBLK ! 1091: * ! 1092: * STRING CONSTANT POINTER TO SCBLK ! 1093: * ! 1094: * VARIABLE POINTER TO VRGET FIELD OF VRBLK ! 1095: * ! 1096: * ADDITION VALUE CODE FOR LEFT OPERAND ! 1097: * VALUE CODE FOR RIGHT OPERAND ! 1098: * =O$ADD ! 1099: * ! 1100: * AFFIRMATION VALUE CODE FOR OPERAND ! 1101: * =O$AFF ! 1102: * ! 1103: * ALTERNATION VALUE CODE FOR LEFT OPERAND ! 1104: * VALUE CODE FOR RIGHT OPERAND ! 1105: * =O$ALT ! 1106: * ! 1107: * ARRAY REFERENCE (CASE OF ONE SUBSCRIPT) ! 1108: * VALUE CODE FOR ARRAY OPERAND ! 1109: * VALUE CODE FOR SUBSCRIPT OPERAND ! 1110: * =O$AOV ! 1111: * ! 1112: * (CASE OF MORE THAN ONE SUBSCRIPT) ! 1113: * VALUE CODE FOR ARRAY OPERAND ! 1114: * VALUE CODE FOR FIRST SUBSCRIPT ! 1115: * VALUE CODE FOR SECOND SUBSCRIPT ! 1116: * ... ! 1117: * VALUE CODE FOR LAST SUBSCRIPT ! 1118: * =O$AMV ! 1119: * NUMBER OF SUBSCRIPTS ! 1120: EJC ! 1121: * ! 1122: * CODE BLOCK (CONTINUED) ! 1123: * ! 1124: * ASSIGNMENT (TO NATURAL VARIABLE) ! 1125: * VALUE CODE FOR RIGHT OPERAND ! 1126: * POINTER TO VRSTO FIELD OF VRBLK ! 1127: * ! 1128: * (TO ANY OTHER VARIABLE) ! 1129: * NAME CODE FOR LEFT OPERAND ! 1130: * VALUE CODE FOR RIGHT OPERAND ! 1131: * =O$ASS ! 1132: * ! 1133: * COMPILE ERROR =O$CER ! 1134: * ! 1135: * ! 1136: * COMPLEMENTATION VALUE CODE FOR OPERAND ! 1137: * =O$COM ! 1138: * ! 1139: * CONCATENATION (CASE OF PRED FUNC LEFT OPERAND) ! 1140: * VALUE CODE FOR LEFT OPERAND ! 1141: * =O$POP ! 1142: * VALUE CODE FOR RIGHT OPERAND ! 1143: * ! 1144: * (ALL OTHER CASES) ! 1145: * VALUE CODE FOR LEFT OPERAND ! 1146: * VALUE CODE FOR RIGHT OPERAND ! 1147: * =O$CNC ! 1148: * ! 1149: * CURSOR ASSIGNMENT NAME CODE FOR OPERAND ! 1150: * =O$CAS ! 1151: * ! 1152: * DIVISION VALUE CODE FOR LEFT OPERAND ! 1153: * VALUE CODE FOR RIGHT OPERAND ! 1154: * =O$DVD ! 1155: * ! 1156: * EXPONENTIATION VALUE CODE FOR LEFT OPERAND ! 1157: * VALUE CODE FOR RIGHT OPERAND ! 1158: * =O$EXP ! 1159: * ! 1160: * FUNCTION CALL (CASE OF CALL TO SYSTEM FUNCTION) ! 1161: * VALUE CODE FOR FIRST ARGUMENT ! 1162: * VALUE CODE FOR SECOND ARGUMENT ! 1163: * ... ! 1164: * VALUE CODE FOR LAST ARGUMENT ! 1165: * POINTER TO SVFNC FIELD OF SVBLK ! 1166: * ! 1167: EJC ! 1168: * ! 1169: * CODE BLOCK (CONTINUED) ! 1170: * ! 1171: * FUNCTION CALL (CASE OF NON-SYSTEM FUNCTION 1 ARG) ! 1172: * VALUE CODE FOR ARGUMENT ! 1173: * =O$FNS ! 1174: * POINTER TO VRBLK FOR FUNCTION ! 1175: * ! 1176: * (NON-SYSTEM FUNCTION, GT 1 ARG) ! 1177: * VALUE CODE FOR FIRST ARGUMENT ! 1178: * VALUE CODE FOR SECOND ARGUMENT ! 1179: * ... ! 1180: * VALUE CODE FOR LAST ARGUMENT ! 1181: * =O$FNC ! 1182: * NUMBER OF ARGUMENTS ! 1183: * POINTER TO VRBLK FOR FUNCTION ! 1184: * ! 1185: * IMMEDIATE ASSIGNMENT VALUE CODE FOR LEFT OPERAND ! 1186: * NAME CODE FOR RIGHT OPERAND ! 1187: * =O$IMA ! 1188: * ! 1189: * INDIRECTION VALUE CODE FOR OPERAND ! 1190: * =O$INV ! 1191: * ! 1192: * INTERROGATION VALUE CODE FOR OPERAND ! 1193: * =O$INT ! 1194: * ! 1195: * KEYWORD REFERENCE NAME CODE FOR OPERAND ! 1196: * =O$KWV ! 1197: * ! 1198: * MULTIPLICATION VALUE CODE FOR LEFT OPERAND ! 1199: * VALUE CODE FOR RIGHT OPERAND ! 1200: * =O$MLT ! 1201: * ! 1202: * NAME REFERENCE (NATURAL VARIABLE CASE) ! 1203: * POINTER TO NMBLK FOR NAME ! 1204: * ! 1205: * (ALL OTHER CASES) ! 1206: * NAME CODE FOR OPERAND ! 1207: * =O$NAM ! 1208: * ! 1209: * NEGATION =O$NTA ! 1210: * CDBLK OFFSET OF O$NTC WORD ! 1211: * VALUE CODE FOR OPERAND ! 1212: * =O$NTB ! 1213: * =O$NTC ! 1214: EJC ! 1215: * ! 1216: * CODE BLOCK (CONTINUED) ! 1217: * ! 1218: * PATTERN ASSIGNMENT VALUE CODE FOR LEFT OPERAND ! 1219: * NAME CODE FOR RIGHT OPERAND ! 1220: * =O$PAS ! 1221: * ! 1222: * PATTERN MATCH VALUE CODE FOR LEFT OPERAND ! 1223: * VALUE CODE FOR RIGHT OPERAND ! 1224: * =O$PMV ! 1225: * ! 1226: * PATTERN REPLACEMENT NAME CODE FOR SUBJECT ! 1227: * VALUE CODE FOR PATTERN ! 1228: * =O$PMN ! 1229: * VALUE CODE FOR REPLACEMENT ! 1230: * =O$RPL ! 1231: * ! 1232: * SELECTION (FOR FIRST ALTERNATIVE) ! 1233: * =O$SLA ! 1234: * CDBLK OFFSET TO NEXT O$SLC WORD ! 1235: * VALUE CODE FOR FIRST ALTERNATIVE ! 1236: * =O$SLB ! 1237: * CDBLK OFFSET PAST ALTERNATIVES ! 1238: * ! 1239: * (FOR SUBSEQUENT ALTERNATIVES) ! 1240: * =O$SLC ! 1241: * CDBLK OFFSET TO NEXT O$SLC,O$SLD ! 1242: * VALUE CODE FOR ALTERNATIVE ! 1243: * =O$SLB ! 1244: * OFFSET IN CDBLK PAST ALTERNATIVES ! 1245: * ! 1246: * (FOR LAST ALTERNATIVE) ! 1247: * =O$SLD ! 1248: * VALUE CODE FOR LAST ALTERNATIVE ! 1249: * ! 1250: * SUBTRACTION VALUE CODE FOR LEFT OPERAND ! 1251: * VALUE CODE FOR RIGHT OPERAND ! 1252: * =O$SUB ! 1253: EJC ! 1254: * ! 1255: * CODE BLOCK (CONTINUED) ! 1256: * ! 1257: * GENERATION OF CODE BY NAME FOR EXPRESSION ELEMENTS. ! 1258: * ! 1259: * VARIABLE =O$LVN ! 1260: * POINTER TO VRBLK ! 1261: * ! 1262: * EXPRESSION (CASE OF *NATURAL VARIABLE) ! 1263: * =O$LVN ! 1264: * POINTER TO VRBLK ! 1265: * ! 1266: * (ALL OTHER CASES) ! 1267: * =O$LEX ! 1268: * POINTER TO EXBLK ! 1269: * ! 1270: * ! 1271: * ARRAY REFERENCE (CASE OF ONE SUBSCRIPT) ! 1272: * VALUE CODE FOR ARRAY OPERAND ! 1273: * VALUE CODE FOR SUBSCRIPT OPERAND ! 1274: * =O$AON ! 1275: * ! 1276: * (CASE OF MORE THAN ONE SUBSCRIPT) ! 1277: * VALUE CODE FOR ARRAY OPERAND ! 1278: * VALUE CODE FOR FIRST SUBSCRIPT ! 1279: * VALUE CODE FOR SECOND SUBSCRIPT ! 1280: * ... ! 1281: * VALUE CODE FOR LAST SUBSCRIPT ! 1282: * =O$AMN ! 1283: * NUMBER OF SUBSCRIPTS ! 1284: * ! 1285: * COMPILE ERROR =O$CER ! 1286: * ! 1287: * FUNCTION CALL (SAME CODE AS FOR VALUE CALL) ! 1288: * =O$FNE ! 1289: * ! 1290: * INDIRECTION VALUE CODE FOR OPERAND ! 1291: * =O$INN ! 1292: * ! 1293: * KEYWORD REFERENCE NAME CODE FOR OPERAND ! 1294: * =O$KWN ! 1295: * ! 1296: * ANY OTHER OPERAND IS AN ERROR IN A NAME POSITION ! 1297: * ! 1298: * NOTE THAT IN THIS DESCRIPTION, =O$XXX REFERS TO THE ! 1299: * GENERATION OF A WORD CONTAINING THE ADDRESS OF ANOTHER ! 1300: * WORD WHICH CONTAINS THE ENTRY POINT ADDRESS O$XXX. ! 1301: EJC ! 1302: * ! 1303: * CODE BLOCK (CONTINUED) ! 1304: * ! 1305: * NOW WE CONSIDER THE OVERALL STRUCTURE OF THE CODE BLOCK ! 1306: * FOR A STATEMENT WITH POSSIBLE GOTO FIELDS. ! 1307: * ! 1308: * FIRST COMES THE CODE FOR THE STATEMENT BODY. ! 1309: * THE STATEMENT BODY IS AN EXPRESSION TO BE EVALUATED ! 1310: * BY VALUE ALTHOUGH THE VALUE IS NOT ACTUALLY REQUIRED. ! 1311: * NORMAL VALUE CODE IS GENERATED FOR THE BODY OF THE ! 1312: * STATEMENT EXCEPT IN THE CASE OF A PATTERN MATCH BY ! 1313: * VALUE, IN WHICH CASE THE FOLLOWING IS GENERATED. ! 1314: * ! 1315: * VALUE CODE FOR LEFT OPERAND ! 1316: * VALUE CODE FOR RIGHT OPERAND ! 1317: * =O$PMS ! 1318: * ! 1319: * NEXT WE HAVE THE CODE FOR THE SUCCESS GOTO. THERE ARE ! 1320: * SEVERAL CASES AS FOLLOWS. ! 1321: * ! 1322: * 1) NO SUCCESS GOTO PTR TO CDBLK FOR NEXT STATEMENT ! 1323: * ! 1324: * 2) SIMPLE LABEL PTR TO VRTRA FIELD OF VRBLK ! 1325: * ! 1326: * 3) COMPLEX GOTO (CODE BY NAME FOR GOTO OPERAND) ! 1327: * =O$GOC ! 1328: * ! 1329: * 4) DIRECT GOTO (CODE BY VALUE FOR GOTO OPERAND) ! 1330: * =O$GOD ! 1331: * ! 1332: * FOLLOWING THIS WE GENERATE CODE FOR THE FAILURE GOTO IF ! 1333: * IT IS DIRECT OR IF IT IS COMPLEX, SIMPLE FAILURE GOTOS ! 1334: * HAVING BEEN HANDLED BY AN APPROPRIATE SETTING OF THE ! 1335: * CDFAL FIELD OF THE CDBLK. THE GENERATED CODE IS ONE ! 1336: * OF THE FOLLOWING. ! 1337: * ! 1338: * 1) COMPLEX FGOTO =O$FIF ! 1339: * =O$GOF ! 1340: * NAME CODE FOR GOTO OPERAND ! 1341: * =O$GOC ! 1342: * ! 1343: * 2) DIRECT FGOTO =O$FIF ! 1344: * =O$GOF ! 1345: * VALUE CODE FOR GOTO OPERAND ! 1346: * =O$GOD ! 1347: * ! 1348: * AN OPTIMIZATION OCCURS IF THE SUCCESS AND FAILURE GOTOS ! 1349: * ARE IDENTICAL AND EITHER COMPLEX OR DIRECT. IN THIS CASE, ! 1350: * NO CODE IS GENERATED FOR THE SUCCESS GOTO AND CONTROL ! 1351: * IS ALLOWED TO FALL INTO THE FAILURE GOTO ON SUCCESS. ! 1352: EJC ! 1353: * ! 1354: * COMPILER BLOCK (CMBLK) ! 1355: * ! 1356: * A COMPILER BLOCK (CMBLK) IS BUILT BY EXPAN TO REPRESENT ! 1357: * ONE NODE OF A TREE STRUCTURED EXPRESSION REPRESENTATION. ! 1358: * ! 1359: * +------------------------------------+ ! 1360: * I CMIDN I ! 1361: * +------------------------------------+ ! 1362: * I CMLEN I ! 1363: * +------------------------------------+ ! 1364: * I CMTYP I ! 1365: * +------------------------------------+ ! 1366: * I CMOPN I ! 1367: * +------------------------------------+ ! 1368: * / CMVLS OR CMROP / ! 1369: * / / ! 1370: * / CMLOP / ! 1371: * / / ! 1372: * +------------------------------------+ ! 1373: * ! 1374: CMIDN EQU 0 POINTER TO DUMMY ROUTINE B$CMT ! 1375: CMLEN EQU CMIDN+1 LENGTH OF CMBLK IN BAUS ! 1376: CMTYP EQU CMLEN+1 TYPE (C$XXX, SEE LIST BELOW) ! 1377: CMOPN EQU CMTYP+1 OPERAND POINTER (SEE BELOW) ! 1378: CMVLS EQU CMOPN+1 OPERAND VALUE POINTERS (SEE BELOW) ! 1379: CMROP EQU CMVLS RIGHT (ONLY) OPERATOR OPERAND ! 1380: CMLOP EQU CMVLS+1 LEFT OPERATOR OPERAND ! 1381: CMSI$ EQU CMVLS NUMBER OF STANDARD FIELDS IN CMBLK ! 1382: CMUS$ EQU CMSI$+1 SIZE OF UNARY OPERATOR CMBLK ! 1383: CMBS$ EQU CMSI$+2 SIZE OF BINARY OPERATOR CMBLK ! 1384: CMAR1 EQU CMVLS+1 ARRAY SUBSCRIPT POINTERS ! 1385: * ! 1386: * THE CMOPN AND CMVLS FIELDS ARE SET AS FOLLOWS ! 1387: * ! 1388: * ARRAY REFERENCE CMOPN = PTR TO ARRAY OPERAND ! 1389: * CMVLS = PTRS TO SUBSCRIPT OPERANDS ! 1390: * ! 1391: * FUNCTION CALL CMOPN = PTR TO VRBLK FOR FUNCTION ! 1392: * CMVLS = PTRS TO ARGUMENT OPERANDS ! 1393: * ! 1394: * SELECTION CMOPN = ZERO ! 1395: * CMVLS = PTRS TO ALTERNATE OPERANDS ! 1396: * ! 1397: * UNARY OPERATOR CMOPN = PTR TO OPERATOR DVBLK ! 1398: * CMROP = PTR TO OPERAND ! 1399: * ! 1400: * BINARY OPERATOR CMOPN = PTR TO OPERATOR DVBLK ! 1401: * CMROP = PTR TO RIGHT OPERAND ! 1402: * CMLOP = PTR TO LEFT OPERAND ! 1403: EJC ! 1404: * ! 1405: * CMTYP IS SET TO INDICATE THE TYPE OF EXPRESSION ELEMENT ! 1406: * AS SHOWN BY THE FOLLOWING TABLE OF DEFINITIONS. ! 1407: * ! 1408: C$ARR EQU 0 ARRAY REFERENCE ! 1409: C$FNC EQU C$ARR+1 FUNCTION CALL ! 1410: C$DEF EQU C$FNC+1 DEFERRED EXPRESSION (UNARY *) ! 1411: C$IND EQU C$DEF+1 INDIRECTION (UNARY $) ! 1412: C$KEY EQU C$IND+1 KEYWORD REFERENCE (UNARY AMPERSAND) ! 1413: C$UBO EQU C$KEY+1 UNDEFINED BINARY OPERATOR ! 1414: C$UUO EQU C$UBO+1 UNDEFINED UNARY OPERATOR ! 1415: C$UO$ EQU C$UUO+1 TEST VALUE (=C$UUO+1=C$UBO+2) ! 1416: C$$NM EQU C$UUO+1 NUMBER OF CODES FOR NAME OPERANDS ! 1417: * ! 1418: * THE REMAINING TYPES INDICATE EXPRESSION ELEMENTS WHICH ! 1419: * CAN ONLY BE EVALUATED BY VALUE (NOT BY NAME). ! 1420: * ! 1421: C$BVL EQU C$UUO+1 BINARY OP WITH VALUE OPERANDS ! 1422: C$UVL EQU C$BVL+1 UNARY OPERATOR WITH VALUE OPERAND ! 1423: C$ALT EQU C$UVL+1 ALTERNATION (BINARY BAR) ! 1424: C$CNC EQU C$ALT+1 CONCATENATION ! 1425: C$CNP EQU C$CNC+1 CONCATENATION, NOT PATTERN MATCH ! 1426: C$UNM EQU C$CNP+1 UNARY OP WITH NAME OPERAND ! 1427: C$BVN EQU C$UNM+1 BINARY OP (OPERANDS BY VALUE, NAME) ! 1428: C$ASS EQU C$BVN+1 ASSIGNMENT ! 1429: C$INT EQU C$ASS+1 INTERROGATION ! 1430: C$NEG EQU C$INT+1 NEGATION (UNARY NOT) ! 1431: C$SEL EQU C$NEG+1 SELECTION ! 1432: C$PMT EQU C$SEL+1 PATTERN MATCH ! 1433: * ! 1434: C$PR$ EQU C$BVN LAST PREEVALUABLE CODE ! 1435: C$$NV EQU C$PMT+1 NUMBER OF DIFFERENT CMBLK TYPES ! 1436: EJC ! 1437: * ! 1438: * COPY FILE BLOCK (COBLK) ! 1439: * ! 1440: * A CHAIN STACK OF COPY BLOCKS IS BUILT FOR EVERY NESTED ! 1441: * -COPY CONTROL CARD. THE CONTROL BLOCK IS USED TO PRESERVE ! 1442: * THE INPUT CONTEXT OF THE FILE CONTAINING THE -COPY. ! 1443: * AS -COPYS ARE ENDED, THESE BLOCKS ARE POPPED OFF THE CHAIN ! 1444: * AND THE STATE RESTORED. SEE ROUTINES CNCRD, COPND. ! 1445: * ! 1446: * +------------------------------------+ ! 1447: * I COTYP I ! 1448: * +------------------------------------+ ! 1449: * I CONXT I ! 1450: * +------------------------------------+ ! 1451: * I COIOT I ! 1452: * +------------------------------------+ ! 1453: * I COTTI I ! 1454: * +------------------------------------+ ! 1455: * I COCIM I ! 1456: * +------------------------------------+ ! 1457: * I COSPT I ! 1458: * +------------------------------------+ ! 1459: * I COSLS I ! 1460: * +------------------------------------+ ! 1461: * I COSIN I ! 1462: * +------------------------------------+ ! 1463: * I COSTL I ! 1464: * +------------------------------------+ ! 1465: * ! 1466: COTYP EQU 0 POINTER TO DUMMY ROUTINE B$COP ! 1467: CONXT EQU COTYP+1 POINT TO NEXT (OUTER -COPY) COBLK ! 1468: COIOT EQU CONXT+1 RECORD IOTAG FOR OSINT ! 1469: COTTI EQU COIOT+1 RECORD TTINS FLAG ! 1470: COCIM EQU COTTI+1 RECORD R$CIM COMPILER IMAGE ! 1471: COSPT EQU COCIM+1 RECORD SCNPT SCAN POINTER ! 1472: COSLS EQU COSPT+1 RECORD CSWLS LISTING FLAG ! 1473: COSIN EQU COSLS+1 RECORD CSWIN -INXXX VALUE ! 1474: COSTL EQU COSIN+1 RECORD R$STL -STITL STRING PTR ! 1475: COSI$ EQU COSTL+1 SIZE OF COBLK ! 1476: EJC ! 1477: * ! 1478: * CHARACTER TABLE BLOCK (CTBLK) ! 1479: * ! 1480: * A CHARACTER TABLE BLOCK IS USED TO HOLD LOGICAL CHARACTER ! 1481: * TABLES FOR USE WITH ANY,NOTANY,SPAN,BREAK,BREAKX ! 1482: * PATTERNS. EACH CHARACTER TABLE CAN BE USED TO STORE ! 1483: * CFP$N DISTINCT TABLES AS BIT COLUMNS. A BIT COLUMN ! 1484: * ALLOCATED FOR EACH ARGUMENT OF MORE THAN ONE CHARACTER ! 1485: * IN LENGTH TO ONE OF THE ABOVE LISTED PATTERN PRIMITIVES. ! 1486: * ! 1487: * +------------------------------------+ ! 1488: * I CTTYP I ! 1489: * +------------------------------------+ ! 1490: * * * ! 1491: * * * ! 1492: * * CTCHS * ! 1493: * * * ! 1494: * * * ! 1495: * +------------------------------------+ ! 1496: * ! 1497: CTTYP EQU 0 POINTER TO DUMMY ROUTINE B$CTT ! 1498: CTCHS EQU CTTYP+1 START OF CHARACTER TABLE WORDS ! 1499: CTSI$ EQU CTCHS+CFP$A NUMBER OF WORDS IN CTBLK ! 1500: * ! 1501: * CTCHS IS CFP$A WORDS LONG AND CONSISTS OF A ONE WORD ! 1502: * BIT STRING VALUE FOR EACH POSSIBLE CHARACTER IN THE ! 1503: * INTERNAL ALPHABET. EACH OF THE CFP$N POSSIBLE BITS IN ! 1504: * A BITSTRING IS USED TO FORM A COLUMN OF BIT INDICATORS. ! 1505: * A BIT IS SET ON IF THE CHARACTER IS IN THE TABLE AND OFF ! 1506: * IF THE CHARACTER IS NOT PRESENT. ! 1507: EJC ! 1508: * ! 1509: * DATATYPE FUNCTION BLOCK (DFBLK) ! 1510: * ! 1511: * A DATATYPE FUNCTION IS USED TO CONTROL THE CONSTRUCTION ! 1512: * OF A PROGRAM DEFINED DATATYPE OBJECT. A CALL TO THE ! 1513: * SYSTEM FUNCTION DATA BUILDS A DFBLK FOR THE DATATYPE NAME ! 1514: * ! 1515: * NOTE THAT THESE BLOCKS ARE BUILT IN STATIC BECAUSE PDBLK ! 1516: * LENGTH IS GOT FROM DFLEN FIELD. IF DFBLK WAS IN DYNAMIC ! 1517: * STORE THIS WOULD CAUSE TROUBLE DURING PASS TWO OF GARBAGE ! 1518: * COLLECTION. SCBLK REFERRED TO BY DFNAM FIELD IS ALSO PUT ! 1519: * IN STATIC SO THAT THERE ARE NO RELOC. FIELDS. THIS CUTS ! 1520: * GARBAGE COLLECTION TASK APPRECIABLY FOR PDBLKS WHICH ARE ! 1521: * LIKELY TO BE PRESENT IN LARGE NUMBERS. ! 1522: * ! 1523: * +------------------------------------+ ! 1524: * I FCODE I ! 1525: * +------------------------------------+ ! 1526: * I FARGS I ! 1527: * +------------------------------------+ ! 1528: * I DFLEN I ! 1529: * +------------------------------------+ ! 1530: * I DFPDL I ! 1531: * +------------------------------------+ ! 1532: * I DFNAM I ! 1533: * +------------------------------------+ ! 1534: * / / ! 1535: * / DFFLD / ! 1536: * / / ! 1537: * +------------------------------------+ ! 1538: * ! 1539: DFLEN EQU FARGS+1 LENGTH OF DFBLK IN BAUS ! 1540: DFPDL EQU DFLEN+1 LENGTH OF CORRESPONDING PDBLK ! 1541: DFNAM EQU DFPDL+1 POINTER TO SCBLK FOR DATATYPE NAME ! 1542: DFFLD EQU DFNAM+1 START OF VRBLK PTRS FOR FIELD NAMES ! 1543: DFFLB EQU DFFLD-1 OFFSET BEHIND DFFLD FOR FIELD FUNC ! 1544: DFSI$ EQU DFFLD NUMBER OF STANDARD FIELDS IN DFBLK ! 1545: * ! 1546: * THE FCODE FIELD POINTS TO THE ROUTINE B$DFC ! 1547: * ! 1548: * FARGS (THE NUMBER OF ARGUMENTS) IS THE NUMBER OF FIELDS. ! 1549: EJC ! 1550: * ! 1551: * DOPE VECTOR BLOCK (DVBLK) ! 1552: * ! 1553: * A DOPE VECTOR IS ASSEMBLED FOR EACH POSSIBLE OPERATOR IN ! 1554: * THE SNOBOL4 LANGUAGE AS PART OF THE CONSTANT SECTION. ! 1555: * ! 1556: * +------------------------------------+ ! 1557: * I DVOPN I ! 1558: * +------------------------------------+ ! 1559: * I DVTYP I ! 1560: * +------------------------------------+ ! 1561: * I DVLPR I ! 1562: * +------------------------------------+ ! 1563: * I DVRPR I ! 1564: * +------------------------------------+ ! 1565: * ! 1566: DVOPN EQU 0 ENTRY ADDRESS (PTR TO O$XXX) ! 1567: DVTYP EQU DVOPN+1 TYPE CODE (C$XXX, SEE CMBLK) ! 1568: DVLPR EQU DVTYP+1 LEFT PRECEDENCE (LLXXX, SEE BELOW) ! 1569: DVRPR EQU DVLPR+1 RIGHT PRECEDENCE (RRXXX, SEE BELOW) ! 1570: DVUS$ EQU DVLPR+1 SIZE OF UNARY OPERATOR DV ! 1571: DVBS$ EQU DVRPR+1 SIZE OF BINARY OPERATOR DV ! 1572: DVUBS EQU DVUS$+DVBS$ SIZE OF UNOP + BINOP (SEE SCANE) ! 1573: * ! 1574: * THE CONTENTS OF THE DVTYP FIELD IS COPIED INTO THE CMTYP ! 1575: * FIELD OF THE CMBLK FOR THE OPERATOR IF IT IS USED. ! 1576: * ! 1577: * THE CMOPN FIELD OF AN OPERATOR CMBLK POINTS TO THE DVBLK ! 1578: * ITSELF, PROVIDING THE REQUIRED ENTRY ADDRESS POINTER PTR. ! 1579: * ! 1580: * FOR NORMALLY UNDEFINED OPERATORS, THE DVOPN (AND CMOPN) ! 1581: * FIELDS CONTAIN A WORD OFFSET FROM R$UBA OF THE FUNCTION ! 1582: * BLOCK POINTER FOR THE OPERATOR (INSTEAD OF O$XXX PTR). ! 1583: * FOR CERTAIN SPECIAL OPERATORS, THE DVOPN FIELD IS NOT ! 1584: * REQUIRED AT ALL AND IS ASSEMBLED AS ZERO. ! 1585: * ! 1586: * THE LEFT PRECEDENCE IS USED IN COMPARING AN OPERATOR TO ! 1587: * THE LEFT OF SOME OTHER OPERATOR. IT THEREFORE GOVERNS THE ! 1588: * PRECEDENCE OF THE OPERATOR TOWARDS ITS RIGHT OPERAND. ! 1589: * ! 1590: * THE RIGHT PRECEDENCE IS USED IN COMPARING AN OPERATOR TO ! 1591: * THE RIGHT OF SOME OTHER OPERATOR. IT THEREFORE GOVERNS ! 1592: * THE PRECEDENCE OF THE OPERATOR TOWARDS ITS LEFT OPERAND. ! 1593: * ! 1594: * HIGHER PRECEDENCE VALUES CORRESPOND TO A TIGHTER BINDING ! 1595: * CAPABILITY. THUS WE HAVE THE LEFT PRECEDENCE LOWER ! 1596: * (HIGHER) THAN THE RIGHT PRECEDENCE FOR RIGHT (LEFT) ! 1597: * ASSOCIATIVE BINARY OPERATORS. ! 1598: * ! 1599: * THE LEFT PRECEDENCE OF UNARY OPERATORS IS SET TO AN ! 1600: * ARBITRARY HIGH VALUE. THE RIGHT VALUE IS NOT REQUIRED AND ! 1601: * CONSEQUENTLY THE DVRPR FIELD IS OMITTED FOR UNARY OPS. ! 1602: EJC ! 1603: * ! 1604: * TABLE OF OPERATOR PRECEDENCE VALUES ! 1605: * ! 1606: RRASS EQU 10 RIGHT EQUAL ! 1607: LLASS EQU 00 LEFT EQUAL ! 1608: RRPMT EQU 20 RIGHT QUESTION MARK ! 1609: LLPMT EQU 30 LEFT QUESTION MARK ! 1610: RRAMP EQU 40 RIGHT AMPERSAND ! 1611: LLAMP EQU 50 LEFT AMPERSAND ! 1612: RRALT EQU 70 RIGHT VERTICAL BAR ! 1613: LLALT EQU 60 LEFT VERTICAL BAR ! 1614: RRCNC EQU 90 RIGHT BLANK ! 1615: LLCNC EQU 80 LEFT BLANK ! 1616: RRATS EQU 110 RIGHT AT ! 1617: LLATS EQU 100 LEFT AT ! 1618: RRPLM EQU 120 RIGHT PLUS, MINUS ! 1619: LLPLM EQU 130 LEFT PLUS, MINUS ! 1620: RRNUM EQU 140 RIGHT NUMBER ! 1621: LLNUM EQU 150 LEFT NUMBER ! 1622: RRDVD EQU 160 RIGHT SLASH ! 1623: LLDVD EQU 170 LEFT SLASH ! 1624: RRMLT EQU 180 RIGHT ASTERISK ! 1625: LLMLT EQU 190 LEFT ASTERISK ! 1626: RRPCT EQU 200 RIGHT PERCENT ! 1627: LLPCT EQU 210 LEFT PERCENT ! 1628: RREXP EQU 230 RIGHT EXCLAMATION ! 1629: LLEXP EQU 220 LEFT EXCLAMATION ! 1630: RRDLD EQU 240 RIGHT DOLLAR, DOT ! 1631: LLDLD EQU 250 LEFT DOLLAR, DOT ! 1632: RRNOT EQU 270 RIGHT NOT ! 1633: LLNOT EQU 260 LEFT NOT ! 1634: LLUNO EQU 999 LEFT ALL UNARY OPERATORS ! 1635: * ! 1636: * PRECEDENCES ARE THE SAME AS IN BTL SNOBOL4 WITH THE ! 1637: * FOLLOWING EXCEPTIONS. ! 1638: * ! 1639: * 1) BINARY QUESTION MARK IS LOWERED AND MADE LEFT ASSOC- ! 1640: * IATIVE TO REFLECT ITS NEW USE FOR PATTERN MATCHING. ! 1641: * ! 1642: * 2) ALTERNATION AND CONCATENATION ARE MADE RIGHT ! 1643: * ASSOCIATIVE FOR GREATER EFFICIENCY IN PATTERN ! 1644: * CONSTRUCTION AND MATCHING RESPECTIVELY. THIS CHANGE ! 1645: * IS TRANSPARENT TO THE SNOBOL4 PROGRAMMER. ! 1646: * ! 1647: * 3) THE EQUAL SIGN HAS BEEN ADDED AS A LOW PRECEDENCE ! 1648: * OPERATOR WHICH IS RIGHT ASSOCIATIVE TO REFLECT ITS ! 1649: * MORE GENERAL USAGE IN THIS VERSION OF SNOBOL4. ! 1650: .IF .CNLD ! 1651: .ELSE ! 1652: EJC ! 1653: * ! 1654: * EXTERNAL FUNCTION BLOCK (EFBLK) ! 1655: * ! 1656: * AN EXTERNAL FUNCTION BLOCK IS USED TO CONTROL THE CALLING ! 1657: * OF AN EXTERNAL FUNCTION. IT IS BUILT BY A CALL TO LOAD. ! 1658: * ! 1659: * +------------------------------------+ ! 1660: * I FCODE I ! 1661: * +------------------------------------+ ! 1662: * I FARGS I ! 1663: * +------------------------------------+ ! 1664: * I EFLEN I ! 1665: * +------------------------------------+ ! 1666: * I EFUSE I ! 1667: * +------------------------------------+ ! 1668: * I EFCOD I ! 1669: * +------------------------------------+ ! 1670: * I EFVAR I ! 1671: * +------------------------------------+ ! 1672: * I EFRSL I ! 1673: * +------------------------------------+ ! 1674: * / / ! 1675: * / EFTAR / ! 1676: * / / ! 1677: * +------------------------------------+ ! 1678: * ! 1679: EFLEN EQU FARGS+1 LENGTH OF EFBLK IN BAUS ! 1680: EFUSE EQU EFLEN+1 USE COUNT (FOR OPSYN) ! 1681: EFCOD EQU EFUSE+1 PTR TO CODE (FROM SYSLD) ! 1682: EFVAR EQU EFCOD+1 PTR TO ASSOCIATED VRBLK ! 1683: EFRSL EQU EFVAR+1 RESULT TYPE (SEE BELOW) ! 1684: EFTAR EQU EFRSL+1 ARGUMENT TYPES (SEE BELOW) ! 1685: EFSI$ EQU EFTAR NUMBER OF STANDARD FIELDS IN EFBLK ! 1686: * ! 1687: * THE FCODE FIELD POINTS TO THE ROUTINE B$EFC. ! 1688: * ! 1689: * EFUSE IS USED TO KEEP TRACK OF MULTIPLE USE WHEN OPSYN ! 1690: * IS EMPLOYED. THE FUNCTION IS AUTOMATICALLY UNLOADED ! 1691: * WHEN THERE ARE NO MORE REFERENCES TO THE FUNCTION. ! 1692: * ! 1693: * EFRSL AND EFTAR ARE TYPE CODES AS FOLLOWS. ! 1694: * ! 1695: * 0 TYPE IS UNCONVERTED ! 1696: * 1 TYPE IS STRING ! 1697: * 2 TYPE IS INTEGER ! 1698: * 3 TYPE IS REAL ! 1699: * 4 TYPE IS BUFFER ! 1700: .FI ! 1701: EJC ! 1702: * ! 1703: * EXPRESSION VARIABLE BLOCK (EVBLK) ! 1704: * ! 1705: * IN THIS VERSION OF SPITBOL, AN EXPRESSION CAN BE USED IN ! 1706: * ANY POSITION WHICH WOULD NORMALLY EXPECT A NAME (FOR ! 1707: * EXAMPLE ON THE LEFT SIDE OF EQUALS OR AS THE RIGHT ! 1708: * ARGUMENT OF BINARY DOT). THIS CORRESPONDS TO THE CREATION ! 1709: * OF A PSEUDO-VARIABLE WHICH IS REPRESENTED BY A POINTER TO ! 1710: * AN EXPRESSION VARIABLE BLOCK AS FOLLOWS. ! 1711: * ! 1712: * +------------------------------------+ ! 1713: * I EVTYP I ! 1714: * +------------------------------------+ ! 1715: * I EVEXP I ! 1716: * +------------------------------------+ ! 1717: * I EVVAR I ! 1718: * +------------------------------------+ ! 1719: * ! 1720: EVTYP EQU 0 POINTER TO DUMMY ROUTINE B$EVT ! 1721: EVEXP EQU EVTYP+1 POINTER TO EXBLK FOR EXPRESSION ! 1722: EVVAR EQU EVEXP+1 POINTER TO TRBEV DUMMY TRBLK ! 1723: EVSI$ EQU EVVAR+1 SIZE OF EVBLK ! 1724: * ! 1725: * THE NAME OF AN EXPRESSION VARIABLE IS REPRESENTED BY A ! 1726: * BASE POINTER TO THE EVBLK AND AN OFFSET OF EVVAR. THIS ! 1727: * VALUE APPEARS TO BE TRAPPED BY THE DUMMY TRBEV BLOCK. ! 1728: * ! 1729: * NOTE THAT THERE IS NO NEED TO ALLOW FOR THE CASE OF AN ! 1730: * EXPRESSION VARIABLE WHICH REFERENCES AN SEBLK SINCE A ! 1731: * VARIABLE WHICH IS OF THE FORM *VAR IS EQUIVALENT TO VAR. ! 1732: EJC ! 1733: * ! 1734: * EXPRESSION BLOCK (EXBLK) ! 1735: * ! 1736: * AN EXPRESSION BLOCK IS BUILT FOR EACH EXPRESSION ! 1737: * REFERENCED IN A PROGRAM OR CREATED BY EVAL OR CONVERT ! 1738: * DURING EXECUTION OF A PROGRAM. ! 1739: * ! 1740: * +------------------------------------+ ! 1741: * I EXTYP I ! 1742: * +------------------------------------+ ! 1743: * I EXSTM I ! 1744: * +------------------------------------+ ! 1745: * I EXLEN I ! 1746: * +------------------------------------+ ! 1747: * I EXFLC I ! 1748: * +------------------------------------+ ! 1749: * / / ! 1750: * / EXCOD / ! 1751: * / / ! 1752: * +------------------------------------+ ! 1753: * ! 1754: EXTYP EQU 0 PTR TO ROUTINE B$EXL TO LOAD EXPR ! 1755: EXSTM EQU CDSTM STORES STMNT NO. DURING EVALUATION ! 1756: EXLEN EQU EXSTM+1 LENGTH OF EXBLK IN BAUS ! 1757: EXFLC EQU EXLEN+1 FAILURE CODE (=O$FEX) ! 1758: EXCOD EQU EXFLC+1 PSEUDO-CODE FOR EXPRESSION ! 1759: EXSI$ EQU EXCOD NUMBER OF STANDARD FIELDS IN EXBLK ! 1760: * ! 1761: * THERE ARE TWO CASES FOR EXCOD DEPENDING ON WHETHER THE ! 1762: * EXPRESSION CAN BE EVALUATED BY NAME (SEE DESCRIPTION ! 1763: * OF CDBLK FOR DETAILS OF CODE FOR EXPRESSIONS). ! 1764: * ! 1765: * IF THE EXPRESSION CAN BE EVALUATED BY NAME WE HAVE. ! 1766: * ! 1767: * (CODE FOR EXPR BY NAME) ! 1768: * =O$RNM ! 1769: * ! 1770: * IF THE EXPRESSION CAN ONLY BE EVALUATED BY VALUE. ! 1771: * ! 1772: * (CODE FOR EXPR BY VALUE) ! 1773: * =O$RVL ! 1774: EJC ! 1775: * ! 1776: * FIELD FUNCTION BLOCK (FFBLK) ! 1777: * ! 1778: * A FIELD FUNCTION BLOCK IS USED TO CONTROL THE SELECTION ! 1779: * OF A FIELD FROM A PROGRAM DEFINED DATATYPE BLOCK. ! 1780: * A CALL TO DATA CREATES AN FFBLK FOR EACH FIELD. ! 1781: * ! 1782: * +------------------------------------+ ! 1783: * I FCODE I ! 1784: * +------------------------------------+ ! 1785: * I FARGS I ! 1786: * +------------------------------------+ ! 1787: * I FFDFP I ! 1788: * +------------------------------------+ ! 1789: * I FFNXT I ! 1790: * +------------------------------------+ ! 1791: * I FFOFS I ! 1792: * +------------------------------------+ ! 1793: * ! 1794: FFDFP EQU FARGS+1 POINTER TO ASSOCIATED DFBLK ! 1795: FFNXT EQU FFDFP+1 PTR TO NEXT FFBLK ON CHAIN OR ZERO ! 1796: FFOFS EQU FFNXT+1 OFFSET (BAUS) TO FIELD IN PDBLK ! 1797: FFSI$ EQU FFOFS+1 SIZE OF FFBLK IN WORDS ! 1798: * ! 1799: * THE FCODE FIELD POINTS TO THE ROUTINE B$FFC. ! 1800: * ! 1801: * FARGS ALWAYS CONTAINS ONE. ! 1802: * ! 1803: * FFDFP IS USED TO VERIFY THAT THE CORRECT PROGRAM DEFINED ! 1804: * DATATYPE IS BEING ACCESSED BY THIS CALL. ! 1805: * FFDFP IS NON-RELOC. BECAUSE DFBLK IS IN STATIC ! 1806: * ! 1807: * FFOFS IS USED TO SELECT THE APPROPRIATE FIELD. NOTE THAT ! 1808: * IT IS AN ACTUAL OFFSET (NOT A FIELD NUMBER) ! 1809: * ! 1810: * FFNXT IS USED TO POINT TO THE NEXT FFBLK OF THE SAME NAME ! 1811: * IN THE CASE WHERE THERE ARE SEVERAL FIELDS OF THE SAME ! 1812: * NAME FOR DIFFERENT DATATYPES. ZERO MARKS THE END OF CHAIN ! 1813: EJC ! 1814: * ! 1815: * INTEGER CONSTANT BLOCK (ICBLK) ! 1816: * ! 1817: * AN ICBLK IS CREATED FOR EVERY INTEGER REFERENCED OR ! 1818: * CREATED BY A PROGRAM. NOTE HOWEVER THAT CERTAIN INTERNAL ! 1819: * INTEGER VALUES ARE STORED AS ADDRESSES (E.G. THE LENGTH ! 1820: * FIELD IN A STRING CONSTANT BLOCK) ! 1821: * ! 1822: * +------------------------------------+ ! 1823: * I ICGET I ! 1824: * +------------------------------------+ ! 1825: * * ICVAL * ! 1826: * +------------------------------------+ ! 1827: * ! 1828: ICGET EQU 0 PTR TO ROUTINE B$ICL TO LOAD INT ! 1829: ICVAL EQU ICGET+1 INTEGER VALUE ! 1830: ICSI$ EQU ICVAL+CFP$I SIZE OF ICBLK ! 1831: * ! 1832: * THE LENGTH OF THE ICVAL FIELD IS CFP$I. ! 1833: EJC ! 1834: * ! 1835: * KEYWORD VARIABLE BLOCK (KVBLK) ! 1836: * ! 1837: * A KVBLK IS USED TO REPRESENT A KEYWORD PSEUDO-VARIABLE. ! 1838: * A KVBLK IS BUILT FOR EACH KEYWORD REFERENCE (KWNAM). ! 1839: * ! 1840: * +------------------------------------+ ! 1841: * I KVTYP I ! 1842: * +------------------------------------+ ! 1843: * I KVVAR I ! 1844: * +------------------------------------+ ! 1845: * I KVNUM I ! 1846: * +------------------------------------+ ! 1847: * ! 1848: KVTYP EQU 0 POINTER TO DUMMY ROUTINE B$KVT ! 1849: KVVAR EQU KVTYP+1 POINTER TO DUMMY BLOCK TRBKV ! 1850: KVNUM EQU KVVAR+1 KEYWORD NUMBER ! 1851: KVSI$ EQU KVNUM+1 SIZE OF KVBLK ! 1852: * ! 1853: * THE NAME OF A KEYWORD VARIABLE IS REPRESENTED BY A ! 1854: * BASE POINTER TO THE KVBLK AND AN OFFSET OF KVVAR. THE ! 1855: * VALUE APPEARS TO BE TRAPPED BY THE POINTER TO TRBKV. ! 1856: EJC ! 1857: * ! 1858: * NAME BLOCK (NMBLK) ! 1859: * ! 1860: * A NAME BLOCK IS USED WHEREVER A NAME MUST BE STORED AS ! 1861: * A VALUE FOLLOWING USE OF THE UNARY DOT OPERATOR. ! 1862: * ! 1863: * +------------------------------------+ ! 1864: * I NMTYP I ! 1865: * +------------------------------------+ ! 1866: * I NMBAS I ! 1867: * +------------------------------------+ ! 1868: * I NMOFS I ! 1869: * +------------------------------------+ ! 1870: * ! 1871: NMTYP EQU 0 PTR TO ROUTINE B$NML TO LOAD NAME ! 1872: NMBAS EQU NMTYP+1 BASE POINTER FOR VARIABLE ! 1873: NMOFS EQU NMBAS+1 OFFSET FOR VARIABLE ! 1874: NMSI$ EQU NMOFS+1 SIZE OF NMBLK ! 1875: * ! 1876: * THE ACTUAL FIELD REPRESENTING THE CONTENTS OF THE NAME ! 1877: * IS FOUND NMOFS BAUS PAST THE ADDRESS IN NMBAS. ! 1878: * ! 1879: * THE NAME IS SPLIT INTO BASE AND OFFSET FORM TO AVOID ! 1880: * CREATION OF A POINTER INTO THE MIDDLE OF A BLOCK WHICH ! 1881: * COULD NOT BE HANDLED PROPERLY BY THE GARBAGE COLLECTOR. ! 1882: * ! 1883: * A NAME MAY BE BUILT FOR ANY VARIABLE (SEE SECTION ON ! 1884: * REPRESENTATIONS OF VARIABLES) THIS INCLUDES THE ! 1885: * CASES OF PSEUDO-VARIABLES. ! 1886: EJC ! 1887: * ! 1888: * PATTERN BLOCK, NO PARAMETERS (P0BLK) ! 1889: * ! 1890: * A P0BLK IS USED TO REPRESENT PATTERN NODES WHICH DO ! 1891: * NOT REQUIRE THE USE OF ANY PARAMETER VALUES. ! 1892: * ! 1893: * +------------------------------------+ ! 1894: * I PCODE I ! 1895: * +------------------------------------+ ! 1896: * I PTHEN I ! 1897: * +------------------------------------+ ! 1898: * ! 1899: PCODE EQU 0 PTR TO MATCH ROUTINE (P$XXX) ! 1900: PTHEN EQU PCODE+1 POINTER TO SUBSEQUENT NODE ! 1901: PASI$ EQU PTHEN+1 SIZE OF P0BLK ! 1902: * ! 1903: * PTHEN POINTS TO THE PATTERN BLOCK FOR THE SUBSEQUENT ! 1904: * NODE TO BE MATCHED. THIS IS A POINTER TO THE PATTERN ! 1905: * BLOCK NDNTH IF THERE IS NO SUBSEQUENT (END OF PATTERN) ! 1906: * ! 1907: * PCODE IS A POINTER TO THE MATCH ROUTINE FOR THE NODE. ! 1908: EJC ! 1909: * ! 1910: * PATTERN BLOCK (ONE PARAMETER) ! 1911: * ! 1912: * A P1BLK IS USED TO REPRESENT PATTERN NODES WHICH ! 1913: * REQUIRE ONE PARAMETER VALUE. ! 1914: * ! 1915: * +------------------------------------+ ! 1916: * I PCODE I ! 1917: * +------------------------------------+ ! 1918: * I PTHEN I ! 1919: * +------------------------------------+ ! 1920: * I PARM1 I ! 1921: * +------------------------------------+ ! 1922: * ! 1923: PARM1 EQU PTHEN+1 FIRST PARAMETER VALUE ! 1924: PBSI$ EQU PARM1+1 SIZE OF P1BLK IN WORDS ! 1925: * ! 1926: * SEE P0BLK FOR DEFINITIONS OF PCODE, PTHEN ! 1927: * ! 1928: * PARM1 CONTAINS A PARAMETER VALUE USED IN MATCHING THE ! 1929: * NODE. FOR EXAMPLE, IN A LEN PATTERN, IT IS THE INTEGER ! 1930: * ARGUMENT TO LEN. THE DETAILS OF THE USE OF THE PARAMETER ! 1931: * FIELD ARE INCLUDED IN THE DESCRIPTION OF THE INDIVIDUAL ! 1932: * MATCH ROUTINES. PARM1 IS ALWAYS AN ADDRESS POINTER WHICH ! 1933: * IS PROCESSED BY THE GARBAGE COLLECTOR. ! 1934: EJC ! 1935: * ! 1936: * PATTERN BLOCK (TWO PARAMETERS) ! 1937: * ! 1938: * A P2BLK IS USED TO REPRESENT PATTERN NODES WHICH ! 1939: * REQUIRE TWO PARAMETER VALUES. ! 1940: * ! 1941: * +------------------------------------+ ! 1942: * I PCODE I ! 1943: * +------------------------------------+ ! 1944: * I PTHEN I ! 1945: * +------------------------------------+ ! 1946: * I PARM1 I ! 1947: * +------------------------------------+ ! 1948: * I PARM2 I ! 1949: * +------------------------------------+ ! 1950: * ! 1951: PARM2 EQU PARM1+1 SECOND PARAMETER VALUE ! 1952: PCSI$ EQU PARM2+1 SIZE OF P2BLK IN WORDS ! 1953: * ! 1954: * SEE P1BLK FOR DEFINITIONS OF PCODE, PTHEN, PARM1 ! 1955: * ! 1956: * PARM2 IS A PARAMETER WHICH PERFORMS THE SAME SORT OF ! 1957: * FUNCTION AS PARM1 (SEE DESCRIPTION OF P1BLK). ! 1958: * ! 1959: * PARM2 IS A NON-RELOCATABLE FIELD AND IS NOT ! 1960: * PROCESSED BY THE GARBAGE COLLECTOR. ACCORDINGLY, IT MAY ! 1961: * NOT CONTAIN A POINTER TO A BLOCK IN DYNAMIC MEMORY. ! 1962: EJC ! 1963: * ! 1964: * PROGRAM-DEFINED DATATYPE BLOCK ! 1965: * ! 1966: * A PDBLK REPRESENTS THE DATA ITEM FORMED BY A CALL TO A ! 1967: * DATATYPE FUNCTION AS DEFINED BY THE SYSTEM FUNCTION DATA. ! 1968: * ! 1969: * +------------------------------------+ ! 1970: * I PDTYP I ! 1971: * +------------------------------------+ ! 1972: * I IDVAL I ! 1973: * +------------------------------------+ ! 1974: * I PDDFP I ! 1975: * +------------------------------------+ ! 1976: * / / ! 1977: * / PDFLD / ! 1978: * / / ! 1979: * +------------------------------------+ ! 1980: * ! 1981: PDTYP EQU 0 PTR TO DUMMY ROUTINE B$PDT ! 1982: PDDFP EQU IDVAL+1 PTR TO ASSOCIATED DFBLK ! 1983: PDFLD EQU PDDFP+1 START OF FIELD VALUE POINTERS ! 1984: PDFOF EQU DFFLD-PDFLD DIFFERENCE IN OFFSET TO FIELD PTRS ! 1985: PDSI$ EQU PDFLD SIZE OF STANDARD FIELDS IN PDBLK ! 1986: PDDFS EQU DFSI$-PDSI$ DIFFERENCE IN DFBLK, PDBLK SIZES ! 1987: * ! 1988: * THE PDDFP POINTER MAY BE USED TO DETERMINE THE DATATYPE ! 1989: * AND THE NAMES OF THE FIELDS IF REQUIRED. THE DFBLK ALSO ! 1990: * CONTAINS THE LENGTH OF THE PDBLK IN BAUS (FIELD DFPDL). ! 1991: * PDDFP IS NON-RELOC. BECAUSE DFBLK IS IN STATIC ! 1992: * ! 1993: * PDFLD VALUES ARE STORED IN ORDER FROM LEFT TO RIGHT. ! 1994: * THEY CONTAIN VALUES OR POINTERS TO TRBLK CHAINS. ! 1995: EJC ! 1996: * ! 1997: * PROGRAM DEFINED FUNCTION BLOCK (PFBLK) ! 1998: * ! 1999: * A PFBLK IS CREATED FOR EACH CALL TO THE DEFINE FUNCTION ! 2000: * AND A POINTER TO THE PFBLK PLACED IN THE PROPER VRBLK. ! 2001: * ! 2002: * +------------------------------------+ ! 2003: * I FCODE I ! 2004: * +------------------------------------+ ! 2005: * I FARGS I ! 2006: * +------------------------------------+ ! 2007: * I PFLEN I ! 2008: * +------------------------------------+ ! 2009: * I PFVBL I ! 2010: * +------------------------------------+ ! 2011: * I PFNLO I ! 2012: * +------------------------------------+ ! 2013: * I PFCOD I ! 2014: * +------------------------------------+ ! 2015: * I PFCTR I ! 2016: * +------------------------------------+ ! 2017: * I PFRTR I ! 2018: * +------------------------------------+ ! 2019: * / / ! 2020: * / PFARG / ! 2021: * / / ! 2022: * +------------------------------------+ ! 2023: * ! 2024: PFLEN EQU FARGS+1 LENGTH OF PFBLK IN BAUS ! 2025: PFVBL EQU PFLEN+1 POINTER TO VRBLK FOR FUNCTION NAME ! 2026: PFNLO EQU PFVBL+1 NUMBER OF LOCALS ! 2027: PFCOD EQU PFNLO+1 PTR TO CDBLK FOR FIRST STATEMENT ! 2028: PFCTR EQU PFCOD+1 TRBLK PTR IF CALL TRACED ELSE 0 ! 2029: PFRTR EQU PFCTR+1 TRBLK PTR IF RETURN TRACED ELSE 0 ! 2030: PFARG EQU PFRTR+1 VRBLK PTRS FOR ARGUMENTS AND LOCALS ! 2031: PFAGB EQU PFARG-1 OFFSET BEHIND PFARG FOR ARG,LOCAL ! 2032: PFSI$ EQU PFARG NUMBER OF STANDARD FIELDS IN PFBLK ! 2033: * ! 2034: * THE FCODE FIELD POINTS TO THE ROUTINE B$PFC. ! 2035: * ! 2036: * PFARG IS STORED IN THE FOLLOWING ORDER. ! 2037: * ! 2038: * ARGUMENTS (LEFT TO RIGHT) ! 2039: * LOCALS (LEFT TO RIGHT) ! 2040: .IF .CNRA ! 2041: .ELSE ! 2042: EJC ! 2043: * ! 2044: * REAL CONSTANT BLOCK (RCBLK) ! 2045: * ! 2046: * AN RCBLK IS CREATED FOR EVERY REAL REFERENCED OR ! 2047: * CREATED BY A PROGRAM. ! 2048: * ! 2049: * +------------------------------------+ ! 2050: * I RCGET I ! 2051: * +------------------------------------+ ! 2052: * * RCVAL * ! 2053: * +------------------------------------+ ! 2054: * ! 2055: RCGET EQU 0 PTR TO ROUTINE B$RCL TO LOAD REAL ! 2056: RCVAL EQU RCGET+1 REAL VALUE ! 2057: RCSI$ EQU RCVAL+CFP$R SIZE OF RCBLK ! 2058: * ! 2059: * THE LENGTH OF THE RCVAL FIELD IS CFP$R. ! 2060: .FI ! 2061: EJC ! 2062: * ! 2063: * STRING CONSTANT BLOCK (SCBLK) ! 2064: * ! 2065: * AN SCBLK IS BUILT FOR EVERY STRING REFERENCED OR CREATED ! 2066: * BY A PROGRAM. ! 2067: * ! 2068: * +------------------------------------+ ! 2069: * I SCGET I ! 2070: * +------------------------------------+ ! 2071: * I SCLEN I ! 2072: * +------------------------------------+ ! 2073: * / / ! 2074: * / SCHAR / ! 2075: * / / ! 2076: * +------------------------------------+ ! 2077: * ! 2078: SCGET EQU 0 PTR TO ROUTINE B$SCL TO LOAD STRING ! 2079: SCLEN EQU SCGET+1 LENGTH OF STRING IN CHARACTERS ! 2080: SCHAR EQU SCLEN+1 CHARACTERS OF STRING ! 2081: SCSI$ EQU SCHAR SIZE OF STANDARD FIELDS IN SCBLK ! 2082: * ! 2083: * THE CHARACTERS OF THE STRING ARE STORED LEFT JUSTIFIED. ! 2084: * THE FINAL WORD IS PADDED ON THE RIGHT WITH ZEROS. ! 2085: * (I.E. THE CHARACTER WHOSE INTERNAL CODE IS ZERO). ! 2086: * ! 2087: * THE VALUE OF SCLEN MAY NOT EXCEED MXLEN. THIS ENSURES ! 2088: * THAT CHARACTER OFFSETS (E.G. THE PATTERN MATCH CURSOR) ! 2089: * CAN BE CORRECTLY PROCESSED BY THE GARBAGE COLLECTOR. ! 2090: * ! 2091: * NOTE THAT THE OFFSET TO THE CHARACTERS OF THE STRING ! 2092: * IS GIVEN IN BAUS BY CFP$F AND THAT THIS VALUE IS ! 2093: * AUTOMATICALLY ALLOWED FOR IN PLC, PSC. ! 2094: * NOTE THAT FOR A SPITBOL SCBLK, THE VALUE OF CFP$F ! 2095: * IS GIVEN BY CFP$B*SCHAR. ! 2096: EJC ! 2097: * ! 2098: * SIMPLE EXPRESSION BLOCK (SEBLK) ! 2099: * ! 2100: * AN SEBLK IS USED TO REPRESENT AN EXPRESSION OF THE FORM ! 2101: * *(NATURAL VARIABLE). ALL OTHER EXPRESSIONS ARE EXBLKS. ! 2102: * ! 2103: * +------------------------------------+ ! 2104: * I SETYP I ! 2105: * +------------------------------------+ ! 2106: * I SEVAR I ! 2107: * +------------------------------------+ ! 2108: * ! 2109: SETYP EQU 0 PTR TO ROUTINE B$SEL TO LOAD EXPR ! 2110: SEVAR EQU SETYP+1 PTR TO VRBLK FOR VARIABLE ! 2111: SESI$ EQU SEVAR+1 LENGTH OF SEBLK IN WORDS ! 2112: EJC ! 2113: * ! 2114: * STANDARD VARIABLE BLOCK (SVBLK) ! 2115: * ! 2116: * AN SVBLK IS ASSEMBLED IN THE CONSTANT SECTION FOR EACH ! 2117: * VARIABLE WHICH SATISFIES ONE OF THE FOLLOWING CONDITIONS. ! 2118: * ! 2119: * 1) IT IS THE NAME OF A SYSTEM FUNCTION ! 2120: * 2) IT HAS AN INITIAL VALUE ! 2121: * 3) IT HAS A KEYWORD ASSOCIATION ! 2122: * 4) IT HAS A STANDARD I/O ASSOCIATION ! 2123: * 6) IT HAS A STANDARD LABEL ASSOCIATION ! 2124: * ! 2125: * IF VRBLKS ARE CONSTRUCTED FOR ANY OF THESE VARIABLES, ! 2126: * THEN THE VRSVP FIELD POINTS TO THE SVBLK (SEE VRBLK) ! 2127: * ! 2128: * +------------------------------------+ ! 2129: * I SVBIT I ! 2130: * +------------------------------------+ ! 2131: * I SVLEN I ! 2132: * +------------------------------------+ ! 2133: * / SVCHS / ! 2134: * +------------------------------------+ ! 2135: * I SVKNM I ! 2136: * +------------------------------------+ ! 2137: * I SVFNC I ! 2138: * +------------------------------------+ ! 2139: * I SVNAR I ! 2140: * +------------------------------------+ ! 2141: * I SVLBL I ! 2142: * +------------------------------------+ ! 2143: * I SVVAL I ! 2144: * +------------------------------------+ ! 2145: EJC ! 2146: * ! 2147: * STANDARD VARIABLE BLOCK (CONTINUED) ! 2148: * ! 2149: SVBIT EQU 0 BIT STRING INDICATING ATTRIBUTES ! 2150: SVLEN EQU 1 (=SCLEN) LENGTH OF NAME IN CHARS ! 2151: SVCHS EQU 2 (=SCHAR) CHARACTERS OF NAME ! 2152: SVSI$ EQU 2 NUMBER OF STANDARD FIELDS IN SVBLK ! 2153: SVPRE EQU 1 SET IF PREEVALUATION PERMITTED ! 2154: SVFFC EQU SVPRE+SVPRE SET ON IF FAST CALL PERMITTED ! 2155: SVCKW EQU SVFFC+SVFFC SET ON IF KEYWORD VALUE CONSTANT ! 2156: SVPRD EQU SVCKW+SVCKW SET ON IF PREDICATE FUNCTION ! 2157: SVNBT EQU 4 NUMBER OF BITS TO RIGHT OF SVKNM ! 2158: SVKNM EQU SVPRD+SVPRD SET ON IF KEYWORD ASSOCIATION ! 2159: SVFNC EQU SVKNM+SVKNM SET ON IF SYSTEM FUNCTION ! 2160: SVNAR EQU SVFNC+SVFNC SET ON IF SYSTEM FUNCTION ! 2161: SVLBL EQU SVNAR+SVNAR SET ON IF SYSTEM LABEL ! 2162: SVVAL EQU SVLBL+SVLBL SET ON IF PREDEFINED VALUE ! 2163: * ! 2164: * NOTE THAT THE LAST FIVE BITS CORRESPOND IN ORDER ! 2165: * TO THE FIELDS WHICH ARE PRESENT (SEE PROCEDURE GTNVR). ! 2166: * ! 2167: * THE FOLLOWING DEFINITIONS ARE USED IN THE SVBLK TABLE ! 2168: * ! 2169: SVFNF EQU SVFNC+SVNAR FUNCTION WITH NO FAST CALL ! 2170: SVFNN EQU SVFNF+SVFFC FUNCTION WITH FAST CALL, NO PREEVAL ! 2171: SVFNP EQU SVFNN+SVPRE FUNCTION ALLOWING PREEVALUATION ! 2172: SVFPR EQU SVFNN+SVPRD PREDICATE FUNCTION ! 2173: SVFNK EQU SVFNN+SVKNM NO PREEVAL FUNC + KEYWORD ! 2174: SVKWV EQU SVKNM+SVVAL KEYWORD + VALUE ! 2175: SVKWC EQU SVCKW+SVKNM KEYWORD WITH CONSTANT VALUE ! 2176: SVKVC EQU SVKWV+SVCKW CONSTANT KEYWORD + VALUE ! 2177: SVKVL EQU SVKVC+SVLBL CONSTANT KEYWORD + VALUE + LABEL ! 2178: .IF .CNFN ! 2179: .ELSE ! 2180: SVFPK EQU SVFNP+SVKVC PREEVAL FUNC + CONST KEYWD+VAL ! 2181: .FI ! 2182: * ! 2183: * THE SVPRE BIT ALLOWS THE COMPILER TO PREEVALUATE A CALL ! 2184: * TO THE ASSOCIATED SYSTEM FUNCTION IF ALL THE ARGUMENTS ! 2185: * ARE THEMSELVES CONSTANTS. FUNCTIONS IN THIS CATEGORY ! 2186: * MUST HAVE NO SIDE EFFECTS AND MUST NEVER CAUSE FAILURE. ! 2187: * THE CALL MAY GENERATE AN ERROR CONDITION. ! 2188: * ! 2189: * THE SVFFC BIT ALLOWS THE COMPILER TO GENERATE THE SPECIAL ! 2190: * FAST CALL AFTER ADJUSTING THE NUMBER OF ARGUMENTS. ONLY ! 2191: * THE APPLY FUNCTION FALLS OUTSIDE THIS CATEGORY. ! 2192: * ! 2193: * THE SVCKW BIT IS SET IF THE ASSOCIATED KEYWORD VALUE IS ! 2194: * A CONSTANT, THUS ALLOWING PREEVALUATION FOR A VALUE CALL. ! 2195: * ! 2196: * THE SVPRD BIT IS SET ON FOR ALL PREDICATE FUNCTIONS TO ! 2197: * ENABLE THE SPECIAL CONCATENATION CODE OPTIMIZATION. ! 2198: EJC ! 2199: * ! 2200: * SVBLK (CONTINUED) ! 2201: * ! 2202: * SVKNM KEYWORD NUMBER ! 2203: * ! 2204: * SVKNM IS PRESENT ONLY FOR A STANDARD KEYWORD ASSOC. ! 2205: * IT CONTAINS A KEYWORD NUMBER AS DEFINED BY THE ! 2206: * KEYWORD NUMBER TABLE GIVEN LATER ON. ! 2207: * ! 2208: * SVFNC SYSTEM FUNCTION POINTER ! 2209: * ! 2210: * SVFNC IS PRESENT ONLY FOR A SYSTEM FUNCTION ASSOC. ! 2211: * IT IS A POINTER TO THE ACTUAL CODE FOR THE SYSTEM ! 2212: * FUNCTION. THE GENERATED CODE FOR A FAST CALL IS A ! 2213: * POINTER TO THE SVFNC FIELD OF THE SVBLK FOR THE ! 2214: * FUNCTION. THE VRFNC FIELD OF THE VRBLK POINTS TO ! 2215: * THIS SAME FIELD, IN WHICH CASE, IT SERVES AS THE ! 2216: * FCODE FIELD FOR THE FUNCTION CALL. ! 2217: * ! 2218: * SVNAR NUMBER OF FUNCTION ARGUMENTS ! 2219: * ! 2220: * SVNAR IS PRESENT ONLY FOR A SYSTEM FUNCTION ASSOC. ! 2221: * IT IS THE NUMBER OF ARGUMENTS REQUIRED FOR A CALL ! 2222: * TO THE SYSTEM FUNCTION. THE COMPILER USES THIS ! 2223: * VALUE TO ADJUST THE NUMBER OF ARGUMENTS IN A FAST ! 2224: * CALL AND IN THE CASE OF A FUNCTION CALLED THROUGH ! 2225: * THE VRFNC FIELD OF THE VRBLK, THE SVNAR FIELD ! 2226: * SERVES AS THE FARGS FIELD FOR O$FNC. A SPECIAL ! 2227: * CASE OCCURS IF THIS VALUE IS SET TO 999. THIS IS ! 2228: * USED TO INDICATE THAT THE FUNCTION HAS A VARIABLE ! 2229: * NUMBER OF ARGUMENTS AND CAUSES O$FNC TO PASS CONTROL ! 2230: * WITHOUT ADJUSTING THE ARGUMENT COUNT. THE ONLY ! 2231: * PREDEFINED FUNCTION USING THIS IS APPLY. ! 2232: * ! 2233: * SVLBL SYSTEM LABEL POINTER ! 2234: * ! 2235: * SVLBL IS PRESENT ONLY FOR A STANDARD LABEL ASSOC. ! 2236: * IT IS A POINTER TO A SYSTEM LABEL ROUTINE (L$XXX). ! 2237: * THE VRLBL FIELD OF THE CORRESPONDING VRBLK POINTS TO ! 2238: * THE SVLBL FIELD OF THE SVBLK. ! 2239: * ! 2240: * SVVAL SYSTEM VALUE POINTER ! 2241: * ! 2242: * SVVAL IS PRESENT ONLY FOR A STANDARD VALUE. ! 2243: * IT IS A POINTER TO THE PATTERN NODE (NDXXX) WHICH ! 2244: * IS THE STANDARD INITIAL VALUE OF THE VARIABLE. ! 2245: * THIS VALUE IS COPIED TO THE VRVAL FIELD OF THE VRBLK ! 2246: EJC ! 2247: * ! 2248: * SVBLK (CONTINUED) ! 2249: * ! 2250: * KEYWORD NUMBER TABLE ! 2251: * ! 2252: * THE FOLLOWING TABLE GIVES SYMBOLIC NAMES FOR KEYWORD ! 2253: * NUMBERS. THESE VALUES ARE STORED IN THE SVKNM FIELD OF ! 2254: * SVBLKS AND IN THE KVNUM FIELD OF KVBLKS. SEE ALSO ! 2255: * PROCEDURES ASIGN, ACESS AND KWNAM. ! 2256: * ! 2257: * UNPROTECTED KEYWORDS WITH ONE WORD INTEGER VALUES ! 2258: * ! 2259: K$ANC EQU 0 ANCHOR ! 2260: K$DMP EQU K$ANC+CFP$B DUMP ! 2261: K$ERL EQU K$DMP+CFP$B ERRLIMIT ! 2262: K$ERT EQU K$ERL+CFP$B ERRTYPE ! 2263: K$FTR EQU K$ERT+CFP$B FTRACE ! 2264: K$INP EQU K$FTR+CFP$B INPUT ! 2265: K$MXL EQU K$INP+CFP$B MAXLENGTH ! 2266: K$OUP EQU K$MXL+CFP$B OUTPUT ! 2267: .IF .CNPF ! 2268: K$TRA EQU K$OUP+CFP$B TRACE ! 2269: .ELSE ! 2270: K$PFL EQU K$OUP+CFP$B PROFILE ! 2271: K$TRA EQU K$PFL+CFP$B TRACE ! 2272: .FI ! 2273: K$TRM EQU K$TRA+CFP$B TRIM ! 2274: * ! 2275: * PROTECTED KEYWORDS WITH ONE WORD INTEGER VALUES ! 2276: * ! 2277: K$FNC EQU K$TRM+CFP$B FNCLEVEL ! 2278: K$LST EQU K$FNC+CFP$B LASTNO ! 2279: K$STN EQU K$LST+CFP$B STNO ! 2280: * ! 2281: * KEYWORDS WITH CONSTANT PATTERN VALUES ! 2282: * ! 2283: K$ABO EQU K$STN+CFP$B ABORT ! 2284: K$ARB EQU K$ABO+PASI$ ARB ! 2285: K$BAL EQU K$ARB+PASI$ BAL ! 2286: K$FAL EQU K$BAL+PASI$ FAIL ! 2287: K$FEN EQU K$FAL+PASI$ FENCE ! 2288: K$REM EQU K$FEN+PASI$ REM ! 2289: K$SUC EQU K$REM+PASI$ SUCCEED ! 2290: EJC ! 2291: * ! 2292: * KEYWORD NUMBER TABLE (CONTINUED) ! 2293: * ! 2294: * SPECIAL KEYWORDS ! 2295: * ! 2296: K$ALP EQU K$SUC+1 ALPHABET ! 2297: K$RTN EQU K$ALP+1 RTNTYPE ! 2298: K$COD EQU K$RTN+1 CODE ! 2299: K$STC EQU K$COD+1 STCOUNT ! 2300: K$ETX EQU K$STC+1 ERRTEXT ! 2301: K$STL EQU K$ETX+1 STLIMIT ! 2302: * ! 2303: * RELATIVE OFFSETS OF SPECIAL KEYWORDS ! 2304: * ! 2305: K$$AL EQU K$ALP-K$ALP ALPHABET ! 2306: K$$RT EQU K$RTN-K$ALP RTNTYPE ! 2307: K$$CD EQU K$COD-K$ALP CODE ! 2308: K$$SC EQU K$STC-K$ALP STCOUNT ! 2309: K$$ET EQU K$ETX-K$ALP ERRTEXT ! 2310: K$$SL EQU K$STL-K$ALP STLIMIT ! 2311: * ! 2312: * SYMBOLS USED IN ASIGN AND ACESS PROCEDURES ! 2313: * ! 2314: K$P$$ EQU K$FNC FIRST PROTECTED KEYWORD ! 2315: K$V$$ EQU K$ABO FIRST KEYWORD WITH CONSTANT VALUE ! 2316: K$S$$ EQU K$ALP FIRST KEYWORD WITH SPECIAL ACESS ! 2317: EJC ! 2318: * ! 2319: * FORMAT OF A TABLE BLOCK (TBBLK) ! 2320: * ! 2321: * A TABLE BLOCK IS USED TO REPRESENT A TABLE VALUE. ! 2322: * IT IS BUILT BY A CALL TO THE TABLE OR CONVERT FUNCTIONS. ! 2323: * ! 2324: * +------------------------------------+ ! 2325: * I TBTYP I ! 2326: * +------------------------------------+ ! 2327: * I IDVAL I ! 2328: * +------------------------------------+ ! 2329: * I TBLEN I ! 2330: * +------------------------------------+ ! 2331: * I TBINV I ! 2332: * +------------------------------------+ ! 2333: * / / ! 2334: * / TBBUK / ! 2335: * / / ! 2336: * +------------------------------------+ ! 2337: * ! 2338: TBTYP EQU 0 POINTER TO DUMMY ROUTINE B$TBT ! 2339: TBLEN EQU OFFS2 LENGTH OF TBBLK IN BAUS ! 2340: TBINV EQU OFFS3 DEFAULT INITIAL LOOKUP VALUE ! 2341: TBBUK EQU TBINV+1 START OF HASH BUCKET POINTERS ! 2342: TBSI$ EQU TBBUK SIZE OF STANDARD FIELDS IN TBBLK ! 2343: TBNBK EQU 11 DEFAULT NO. OF BUCKETS ! 2344: * ! 2345: * THE TABLE BLOCK IS A HASH TABLE WHICH POINTS TO CHAINS ! 2346: * OF TABLE ELEMENT BLOCKS REPRESENTING THE ELEMENTS ! 2347: * IN THE TABLE WHICH HASH INTO THE SAME BUCKET. ! 2348: * ! 2349: * TBBUK ENTRIES EITHER POINT TO THE FIRST TEBLK ON THE ! 2350: * CHAIN OR THEY POINT TO THE TBBLK ITSELF TO INDICATE THE ! 2351: * END OF THE CHAIN. ! 2352: EJC ! 2353: * ! 2354: * TABLE ELEMENT BLOCK (TEBLK) ! 2355: * ! 2356: * A TABLE ELEMENT IS USED TO REPRESENT A SINGLE ENTRY IN ! 2357: * A TABLE (SEE DESCRIPTION OF TBBLK FORMAT FOR HASH TABLE) ! 2358: * ! 2359: * +------------------------------------+ ! 2360: * I TETYP I ! 2361: * +------------------------------------+ ! 2362: * I TESUB I ! 2363: * +------------------------------------+ ! 2364: * I TEVAL I ! 2365: * +------------------------------------+ ! 2366: * I TENXT I ! 2367: * +------------------------------------+ ! 2368: * ! 2369: TETYP EQU 0 POINTER TO DUMMY ROUTINE B$TET ! 2370: TESUB EQU TETYP+1 SUBSCRIPT VALUE ! 2371: TEVAL EQU TESUB+1 (=VRVAL) TABLE ELEMENT VALUE ! 2372: TENXT EQU TEVAL+1 LINK TO NEXT TEBLK ! 2373: * SEE S$CNV WHERE RELATION IS ASSUMED WITH TENXT AND TBBUK ! 2374: TESI$ EQU TENXT+1 SIZE OF TEBLK IN WORDS ! 2375: * ! 2376: * TENXT POINTS TO THE NEXT TEBLK ON THE HASH CHAIN FROM THE ! 2377: * TBBUK CHAIN FOR THIS HASH INDEX. AT THE END OF THE CHAIN, ! 2378: * TENXT POINTS BACK TO THE START OF THE TBBLK. ! 2379: * ! 2380: * TEVAL CONTAINS A DATA POINTER OR A TRBLK POINTER. ! 2381: * ! 2382: * TESUB CONTAINS A DATA POINTER. ! 2383: EJC ! 2384: * ! 2385: * TRAP BLOCK (TRBLK) ! 2386: * ! 2387: * A TRAP BLOCK IS USED TO REPRESENT A TRACE OR INPUT OR ! 2388: * OUTPUT ASSOCIATION IN RESPONSE TO A CALL TO THE TRACE ! 2389: * INPUT OR OUTPUT SYSTEM FUNCTIONS. SEE BELOW FOR DETAILS ! 2390: * ! 2391: * +------------------------------------+ ! 2392: * I TRIDN I ! 2393: * +------------------------------------+ ! 2394: * I TRTYP I ! 2395: * +------------------------------------+ ! 2396: * I TRVAL OR TRLBL OR TRNXT OR TRKVR I ! 2397: * +------------------------------------+ ! 2398: * I TRTAG OR TRTER I ! 2399: * +------------------------------------+ ! 2400: * I TRFNC OR TRTRI I ! 2401: * +------------------------------------+ ! 2402: * ! 2403: TRIDN EQU 0 POINTER TO DUMMY ROUTINE B$TRT ! 2404: TRTYP EQU TRIDN+1 TRAP TYPE CODE ! 2405: TRVAL EQU TRTYP+1 VALUE OF TRAPPED VARIABLE (=VRVAL) ! 2406: TRNXT EQU TRVAL PTR TO NEXT TRBLK ON TRBLK CHAIN ! 2407: TRLBL EQU TRVAL PTR TO ACTUAL LABEL (TRACED LABEL) ! 2408: TRKVR EQU TRVAL VRBLK POINTER FOR KEYWORD TRACE ! 2409: TRTAG EQU TRVAL+1 TRACE TAG OR IOTAG ! 2410: TRTER EQU TRTAG PTR TO TERMINAL VRBLK OR NULL ! 2411: TRFNC EQU TRTAG+1 TRACE FUNCTION VRBLK (ZERO IF NONE) ! 2412: TRTRI EQU TRFNC PTR TO TRACE BLOCK HOLDING IOTAG ! 2413: TRSI$ EQU TRFNC+1 NUMBER OF WORDS IN TRBLK ! 2414: * ! 2415: TRTIN EQU 0 TRACE TYPE FOR INPUT ASSOCIATION ! 2416: TRTAC EQU TRTIN+1 TRACE TYPE FOR ACCESS TRACE ! 2417: TRTVL EQU TRTAC+1 TRACE TYPE FOR VALUE TRACE ! 2418: TRTIO EQU TRTVL+1 TRACE TYPE FOR IOTAG TRACE BLOCK ! 2419: TRTOU EQU TRTIO+1 TRACE TYPE FOR OUTPUT ASSOCIATION ! 2420: EJC ! 2421: * ! 2422: * TRAP BLOCK (CONTINUED) ! 2423: * ! 2424: * VARIABLE INPUT ASSOCIATION ! 2425: * ! 2426: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK ! 2427: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE ! 2428: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS ! 2429: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK. ! 2430: * ! 2431: * TRTYP IS SET TO TRTIN ! 2432: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL ! 2433: * TRTER IS A POINTER TO SVBLK IF ASSOCIATION IS ! 2434: * FOR INPUT, TERMINAL, ELSE IT IS NULL. ! 2435: * TRTRI IS A PTR TO IOTAG TRBLK FROM SYSIO OR ZERO. ! 2436: * ! 2437: * VARIABLE ACCESS TRACE ASSOCIATION ! 2438: * ! 2439: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK ! 2440: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE ! 2441: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS ! 2442: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK. ! 2443: * ! 2444: * TRTYP IS SET TO TRTAC ! 2445: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL ! 2446: * TRTAG IS THE TRACE TAG (0 IF NONE) ! 2447: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 2448: * ! 2449: * VARIABLE VALUE TRACE ASSOCIATION ! 2450: * ! 2451: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK ! 2452: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE ! 2453: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS ! 2454: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK. ! 2455: * ! 2456: * TRTYP IS SET TO TRTVL ! 2457: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL ! 2458: * TRTAG IS THE TRACE TAG (0 IF NONE) ! 2459: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 2460: EJC ! 2461: * TRAP BLOCK (CONTINUED) ! 2462: * ! 2463: * VARIABLE OUTPUT ASSOCIATION ! 2464: * ! 2465: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK ! 2466: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE ! 2467: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS ! 2468: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK. ! 2469: * ! 2470: * TRTYP IS SET TO TRTOU ! 2471: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL ! 2472: * TRTER IS A POINTER TO SVBLK IF ASSOCIATION IS ! 2473: * FOR OUTPUT, TERMINAL, ELSE IT IS NULL. ! 2474: * TRTRI IS A PTR TO IOTAG TRBLK FROM SYSIO OR ZERO. ! 2475: * ! 2476: * FUNCTION CALL TRACE ! 2477: * ! 2478: * THE PFCTR FIELD OF THE CORRESPONDING PFBLK IS SET ! 2479: * TO POINT TO A TRBLK. ! 2480: * ! 2481: * TRTYP IS SET TO TRTIN ! 2482: * TRNXT IS ZERO ! 2483: * TRTAG IS THE TRACE TAG (0 IF NONE) ! 2484: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 2485: * ! 2486: * FUNCTION RETURN TRACE ! 2487: * ! 2488: * THE PFRTR FIELD OF THE CORRESPONDING PFBLK IS SET ! 2489: * TO POINT TO A TRBLK ! 2490: * ! 2491: * TRTYP IS SET TO TRTIN ! 2492: * TRNXT IS ZERO ! 2493: * TRTAG IS THE TRACE TAG (0 IF NONE) ! 2494: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 2495: * ! 2496: * LABEL TRACE ! 2497: * ! 2498: * THE VRLBL OF THE VRBLK FOR THE LABEL IS ! 2499: * CHANGED TO POINT TO A TRBLK AND THE VRTRA FIELD IS ! 2500: * SET TO B$VRT TO ACTIVATE THE CHECK. ! 2501: * ! 2502: * TRTYP IS SET TO TRTIN ! 2503: * TRLBL POINTS TO THE ACTUAL LABEL (CDBLK) VALUE ! 2504: * TRTAG IS THE TRACE TAG (0 IF NONE) ! 2505: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 2506: EJC ! 2507: * ! 2508: * TRAP BLOCK (CONTINUED) ! 2509: * ! 2510: * KEYWORD TRACE ! 2511: * ! 2512: * KEYWORDS WHICH CAN BE TRACED POSSESS A UNIQUE ! 2513: * LOCATION WHICH IS ZERO IF THERE IS NO TRACE AND ! 2514: * POINTS TO A TRBLK IF THERE IS A TRACE. THE LOCATIONS ! 2515: * ARE AS FOLLOWS. ! 2516: * ! 2517: * R$ERT ERRTYPE ! 2518: * R$FNC FNCLEVEL ! 2519: * R$STC STCOUNT ! 2520: * ! 2521: * THE FORMAT OF THE TRBLK IS AS FOLLOWS. ! 2522: * ! 2523: * TRTYP IS SET TO TRTIN ! 2524: * TRKVR IS A POINTER TO THE VRBLK FOR THE KEYWORD ! 2525: * TRTAG IS THE TRACE TAG (0 IF NONE) ! 2526: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 2527: * ! 2528: * INPUT/OUTPUT FILETAG TRAP BLOCK (TRTIO) ! 2529: * ! 2530: * THE VALUE FIELD OF THE FILETAG VBL POINTS TO A TRBLK ! 2531: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE OF ! 2532: * A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS ! 2533: * CONTAIN =B$VRA AND =B$VRV. THIS TRAP BLOCK IS USED ! 2534: * TO HOLD THE IOTAG RETURNED BY A SYSIO CALL ! 2535: * ! 2536: * TRTYP IS SET TO TRTIO ! 2537: * TRNXT POINTS TO NEXT TRBLK OR TRVAL IS VARIABLE VAL ! 2538: * TRTAG HOLDS THE IOTAG. ! 2539: * ! 2540: * NOTE THAT WHEN MULTIPLE TRAPS ARE SET ON A VARIABLE ! 2541: * THE ORDER IS IN ASCENDING VALUE OF TRTYP FIELD. ! 2542: * ! 2543: * INPUT ASSOCIATION (IF PRESENT) ! 2544: * ACCESS TRACE (IF PRESENT) ! 2545: * VALUE TRACE (IF PRESENT) ! 2546: * FILETAG ASSOCIATION (IF PRESENT) ! 2547: * OUTPUT ASSOCIATION (IF PRESENT) ! 2548: * ! 2549: * THE ACTUAL VALUE OF THE VARIABLE IS STORED IN THE TRVAL ! 2550: * FIELD OF THE LAST TRBLK ON THE CHAIN. ! 2551: * ! 2552: * THIS IMPLEMENTATION DOES NOT PERMIT TRACE OR I/O ! 2553: * ASSOCIATIONS TO ANY OF THE PSEUDO-VARIABLES. ! 2554: EJC ! 2555: * ! 2556: * VECTOR BLOCK (VCBLK) ! 2557: * ! 2558: * A VCBLK IS USED TO REPRESENT AN ARRAY VALUE WHICH HAS ! 2559: * ONE DIMENSION WHOSE LOWER BOUND IS ONE. ALL OTHER ARRAYS ! 2560: * ARE REPRESENTED BY ARBLKS. A VCBLK IS CREATED BY THE ! 2561: * SYSTEM FUNCTION ARRAY (S$ARR) WHEN PASSED AN INTEGER ARG. ! 2562: * ! 2563: * +------------------------------------+ ! 2564: * I VCTYP I ! 2565: * +------------------------------------+ ! 2566: * I IDVAL I ! 2567: * +------------------------------------+ ! 2568: * I VCLEN I ! 2569: * +------------------------------------+ ! 2570: * I VCVLS I ! 2571: * +------------------------------------+ ! 2572: * ! 2573: VCTYP EQU 0 POINTER TO DUMMY ROUTINE B$VCT ! 2574: VCLEN EQU OFFS2 LENGTH OF VCBLK IN BAUS ! 2575: VCVLS EQU OFFS3 START OF VECTOR VALUES ! 2576: VCSI$ EQU VCVLS SIZE OF STANDARD FIELDS IN VCBLK ! 2577: VCVLB EQU VCVLS-1 OFFSET ONE WORD BEHIND VCVLS ! 2578: VCTBD EQU TBSI$-VCSI$ DIFFERENCE IN SIZES - SEE PRTVL ! 2579: * ! 2580: * VCVLS ARE EITHER DATA POINTERS OR TRBLK POINTERS ! 2581: * ! 2582: * THE DIMENSION CAN BE DEDUCED FROM VCLEN. ! 2583: EJC ! 2584: * ! 2585: * VARIABLE BLOCK (VRBLK) ! 2586: * ! 2587: * A VARIABLE BLOCK IS BUILT IN THE STATIC MEMORY AREA ! 2588: * FOR EVERY VARIABLE REFERENCED OR CREATED BY A PROGRAM. ! 2589: * ! 2590: * NOTE THAT SINCE THESE BLOCKS ONLY OCCUR IN THE STATIC ! 2591: * REGION, IT IS PERMISSIBLE TO POINT TO ANY WORD IN ! 2592: * THE BLOCK AND THIS IS USED TO PROVIDE THREE DISTINCT ! 2593: * ACCESS POINTS FROM THE GENERATED CODE AS FOLLOWS. ! 2594: * ! 2595: * 1) POINT TO VRGET (FIRST WORD OF VRBLK) TO LOAD THE ! 2596: * VALUE OF THE VARIABLE ONTO THE MAIN STACK. ! 2597: * ! 2598: * 2) POINT TO VRSTO (SECOND WORD OF VRBLK) TO STORE THE ! 2599: * TOP STACK ELEMENT AS THE VALUE OF THE VARIABLE. ! 2600: * ! 2601: * 3) POINT TO VRTRA (FOURTH WORD OF VRBLK) TO JUMP TO ! 2602: * THE LABEL ASSOCIATED WITH THE VARIABLE NAME. ! 2603: * ! 2604: * +------------------------------------+ ! 2605: * I VRGET I ! 2606: * +------------------------------------+ ! 2607: * I VRSTO I ! 2608: * +------------------------------------+ ! 2609: * I VRVAL I ! 2610: * +------------------------------------+ ! 2611: * I VRTRA I ! 2612: * +------------------------------------+ ! 2613: * I VRLBL I ! 2614: * +------------------------------------+ ! 2615: * I VRFNC I ! 2616: * +------------------------------------+ ! 2617: * I VRNXT I ! 2618: * +------------------------------------+ ! 2619: * I VRLEN I ! 2620: * +------------------------------------+ ! 2621: * / / ! 2622: * / VRCHS = VRSVP / ! 2623: * / / ! 2624: * +------------------------------------+ ! 2625: EJC ! 2626: * ! 2627: * VARIABLE BLOCK (CONTINUED) ! 2628: * ! 2629: VRGET EQU 0 POINTER TO ROUTINE TO LOAD VALUE ! 2630: VRSTO EQU VRGET+1 POINTER TO ROUTINE TO STORE VALUE ! 2631: VRVAL EQU VRSTO+1 VARIABLE VALUE ! 2632: VRVLO EQU VRVAL-VRSTO OFFSET TO VALUE FROM STORE FIELD ! 2633: VRTRA EQU VRVAL+1 POINTER TO ROUTINE TO JUMP TO LABEL ! 2634: VRLBL EQU VRTRA+1 POINTER TO CODE FOR LABEL ! 2635: VRLBO EQU VRLBL-VRTRA OFFSET TO LABEL FROM TRANSFER FIELD ! 2636: VRFNC EQU VRLBL+1 POINTER TO FUNCTION BLOCK ! 2637: VRNXT EQU VRFNC+1 POINTER TO NEXT VRBLK ON HASH CHAIN ! 2638: VRLEN EQU VRNXT+1 LENGTH OF NAME (OR ZERO) ! 2639: VRCHS EQU VRLEN+1 CHARACTERS OF NAME (VRLEN GT 0) ! 2640: VRSVP EQU VRLEN+1 PTR TO SVBLK (VRLEN EQ 0) ! 2641: VRSI$ EQU VRCHS+1 NUMBER OF STANDARD FIELDS IN VRBLK ! 2642: VRSOF EQU VRLEN-SCLEN OFFSET TO DUMMY SCBLK FOR NAME ! 2643: VRSVO EQU VRSVP-VRSOF PSEUDO-OFFSET TO VRSVP FIELD ! 2644: * ! 2645: * VRGET = B$VRL IF NOT INPUT ASSOCIATED OR ACCESS TRACED ! 2646: * VRGET = B$VRA IF INPUT ASSOCIATED OR ACCESS TRACED ! 2647: * ! 2648: * VRSTO = B$VRS IF NOT OUTPUT ASSOCIATED OR VALUE TRACED ! 2649: * VRSTO = B$VRV IF OUTPUT ASSOCIATED OR VALUE TRACED ! 2650: * VRSTO = B$VRE IF VALUE IS PROTECTED PATTERN VALUE ! 2651: * ! 2652: * VRVAL POINTS TO THE APPROPRIATE VALUE UNLESS THE ! 2653: * VARIABLE IS I/O/TRACE ASSOCIATED IN WHICH CASE, VRVAL ! 2654: * POINTS TO AN APPROPRIATE TRBLK (TRAP BLOCK) CHAIN. ! 2655: * ! 2656: * VRTRA = B$VRG IF THE LABEL IS NOT TRACED ! 2657: * VRTRA = B$VRT IF THE LABEL IS TRACED ! 2658: * ! 2659: * VRLBL POINTS TO A CDBLK IF THERE IS A LABEL ! 2660: * VRLBL POINTS TO THE SVBLK SVLBL FIELD FOR A SYSTEM LABEL ! 2661: * VRLBL POINTS TO STNDL FOR AN UNDEFINED LABEL ! 2662: * VRLBL POINTS TO A TRBLK IF THE LABEL IS TRACED ! 2663: * ! 2664: * VRFNC POINTS TO A FFBLK FOR A FIELD FUNCTION ! 2665: * VRFNC POINTS TO A DFBLK FOR A DATATYPE FUNCTION ! 2666: * VRFNC POINTS TO A PFBLK FOR A PROGRAM DEFINED FUNCTION ! 2667: * VRFNC POINTS TO A EFBLK FOR AN EXTERNAL LOADED FUNCTION ! 2668: * VRFNC POINTS TO SVFNC (SVBLK) FOR A SYSTEM FUNCTION ! 2669: * VRFNC POINTS TO STNDF IF THE FUNCTION IS UNDEFINED ! 2670: * ! 2671: * VRNXT POINTS TO THE NEXT VRBLK ON THIS CHAIN UNLESS ! 2672: * THIS IS THE END OF THE CHAIN IN WHICH CASE IT IS ZERO. ! 2673: * ! 2674: * VRLEN IS THE NAME LENGTH FOR A NON-SYSTEM VARIABLE. ! 2675: * VRLEN IS ZERO FOR A SYSTEM VARIABLE. ! 2676: * ! 2677: * VRCHS IS THE NAME IF VRLEN IS NON-ZERO. ! 2678: * VRSVP IS A PTR TO THE SVBLK IF VRLEN IS ZERO. ! 2679: EJC ! 2680: * ! 2681: * FORMAT OF A NON-RELOCATABLE EXTERNAL BLOCK (XNBLK) ! 2682: * ! 2683: * AN XNBLK IS A BLOCK REPRESENTING AN UNKNOWN (EXTERNAL) ! 2684: * DATA VALUE. THE BLOCK CONTAINS NO POINTERS TO OTHER ! 2685: * RELOCATABLE BLOCKS. AN XNBLK IS USED BY EXTERNAL FUNCTION ! 2686: * PROCESSING OR POSSIBLY FOR SYSTEM I/O ROUTINES ETC. ! 2687: * THE MACRO-SYSTEM ITSELF DOES NOT USE XNBLKS. ! 2688: * ! 2689: * +------------------------------------+ ! 2690: * I XNTYP I ! 2691: * +------------------------------------+ ! 2692: * I XNLEN I ! 2693: * +------------------------------------+ ! 2694: * / / ! 2695: * / XNDTA / ! 2696: * / / ! 2697: * +------------------------------------+ ! 2698: * ! 2699: XNTYP EQU 0 POINTER TO DUMMY ROUTINE B$XNT ! 2700: XNLEN EQU XNTYP+1 LENGTH OF XNBLK IN BAUS ! 2701: XNDTA EQU XNLEN+1 DATA WORDS ! 2702: XNSI$ EQU XNDTA SIZE OF STANDARD FIELDS IN XNBLK ! 2703: * ! 2704: * NOTE THAT THE TERM NON-RELOCATABLE REFERS TO THE CONTENTS ! 2705: * AND NOT THE BLOCK ITSELF. AN XNBLK CAN BE MOVED AROUND IF ! 2706: * IT IS BUILT IN THE DYNAMIC MEMORY AREA. ! 2707: EJC ! 2708: * ! 2709: * RELOCATABLE EXTERNAL BLOCK (XRBLK) ! 2710: * ! 2711: * AN XRBLK IS A BLOCK REPRESENTING AN UNKNOWN (EXTERNAL) ! 2712: * DATA VALUE. THE DATA AREA IN THIS BLOCK CONSISTS ONLY ! 2713: * OF ADDRESS VALUES AND ANY ADDRESSES POINTING INTO THE ! 2714: * DYNAMIC MEMORY AREA MUST POINT TO THE START OF OTHER ! 2715: * DATA BLOCKS. SEE ALSO DESCRIPTION OF XNBLK. ! 2716: * ! 2717: * +------------------------------------+ ! 2718: * I XRTYP I ! 2719: * +------------------------------------+ ! 2720: * I XRLEN I ! 2721: * +------------------------------------+ ! 2722: * / / ! 2723: * / XRPTR / ! 2724: * / / ! 2725: * +------------------------------------+ ! 2726: * ! 2727: XRTYP EQU 0 POINTER TO DUMMY ROUTINE B$XRT ! 2728: XRLEN EQU XRTYP+1 LENGTH OF XRBLK IN BAUS ! 2729: XRPTR EQU XRLEN+1 START OF ADDRESS POINTERS ! 2730: XRSI$ EQU XRPTR SIZE OF STANDARD FIELDS IN XRBLK ! 2731: EJC ! 2732: * ! 2733: * S$CNV (CONVERT) FUNCTION SWITCH CONSTANTS. THE VALUES ! 2734: * ARE TIED TO THE ORDER OF THE ENTRIES IN THE SVCTB TABLE ! 2735: * AND HENCE TO THE BRANCH TABLE IN S$CNV. ! 2736: * ! 2737: CNVST EQU 8 MAX STANDARD TYPE CODE FOR CONVERT ! 2738: .IF .CNRA ! 2739: CNVRT EQU CNVST NO REALS - SAME AS STANDARD TYPES ! 2740: .ELSE ! 2741: CNVRT EQU CNVST+1 CONVERT CODE FOR REALS ! 2742: .FI ! 2743: .IF .CNBF ! 2744: CNVBT EQU CNVRT NO BUFFERS - SAME AS REAL CODE ! 2745: .ELSE ! 2746: CNVBT EQU CNVRT+1 CONVERT CODE FOR BUFFER ! 2747: .FI ! 2748: CNVTT EQU CNVBT+1 BSW CODE FOR CONVERT ! 2749: * ! 2750: * INPUT IMAGE LENGTH ! 2751: * ! 2752: INILN EQU 160 DEFAULT IMAGE LENGTH FOR COMPILER ! 2753: * ! 2754: * IN GENERAL, MEANINGFUL MNEMONICS SHOULD BE USED FOR ! 2755: * OFFSETS. HOWEVER FOR SMALL INTEGERS USED OFTEN IN ! 2756: * LITERALS THE FOLLOWING GENERAL DEFINITIONS ARE PROVIDED. ! 2757: * ! 2758: NUM01 EQU 1 ! 2759: NUM02 EQU 2 ! 2760: NUM03 EQU 3 ! 2761: NUM04 EQU 4 ! 2762: NUM05 EQU 5 ! 2763: NUM06 EQU 6 ! 2764: NUM07 EQU 7 ! 2765: NUM08 EQU 8 ! 2766: NUM09 EQU 9 ! 2767: NUM10 EQU 10 ! 2768: NINI9 EQU 999 ! 2769: THSND EQU 1000 ! 2770: * ! 2771: * NUMBERS OF UNDEFINED SPITBOL OPERATORS ! 2772: * ! 2773: OPBUN EQU 5 NO. OF BINARY UNDEFINED OPS ! 2774: OPUUN EQU 6 NO OF UNARY UNDEFINED OPS ! 2775: * ! 2776: * OFFSETS USED IN PRTSN, PRTMI AND ACESS ! 2777: * ! 2778: PRSNF EQU 13 OFFSET USED IN PRTSN ! 2779: PRTMF EQU 15 OFFSET TO COL 15 (PRTMI) ! 2780: RILEN EQU 160 BUFFER LENGTH FOR SYSRI ! 2781: * ! 2782: * CODES FOR STAGES OF PROCESSING ! 2783: * ! 2784: STGIC EQU 0 INITIAL COMPILE ! 2785: STGXC EQU STGIC+1 EXECUTION COMPILE (CODE) ! 2786: STGEV EQU STGXC+1 EXPRESSION EVAL DURING EXECUTION ! 2787: STGXT EQU STGEV+1 EXECUTION TIME ! 2788: STGCE EQU STGXT+1 INITIAL COMPILE AFTER END LINE ! 2789: STGXE EQU STGCE+1 EXEC. COMPILE AFTER END LINE ! 2790: STGND EQU STGCE-STGIC DIFFERENCE IN STAGE AFTER END ! 2791: STGEE EQU STGXE+1 EVAL EVALUATING EXPRESSION ! 2792: STGNO EQU STGEE+1 NUMBER OF CODES ! 2793: EJC ! 2794: * ! 2795: * ! 2796: * STATEMENT NUMBER PAD COUNT FOR LISTR ! 2797: * ! 2798: .DEF .CSN5 ! 2799: .IF .CSN6 ! 2800: STNPD EQU 6 STATEMENT NO. PAD COUNT ! 2801: .UNDEF .CSN5 ! 2802: .FI ! 2803: .IF .CSN8 ! 2804: STNPD EQU 8 STATEMENT NO. PAD COUNT ! 2805: .UNDEF .CSN5 ! 2806: .FI ! 2807: .IF .CSN5 ! 2808: STNPD EQU 5 STATEMENT NO. PAD COUNT ! 2809: .FI ! 2810: * ! 2811: * SYNTAX TYPE CODES ! 2812: * ! 2813: * THESE CODES ARE RETURNED FROM THE SCANE PROCEDURE. ! 2814: * ! 2815: * THEY ARE SPACED 3 APART FOR THE BENEFIT OF EXPAN. ! 2816: * ! 2817: T$UOP EQU 0 UNARY OPERATOR ! 2818: T$LPR EQU T$UOP+3 LEFT PAREN ! 2819: T$LBR EQU T$LPR+3 LEFT BRACKET ! 2820: T$CMA EQU T$LBR+3 COMMA ! 2821: T$FNC EQU T$CMA+3 FUNCTION CALL ! 2822: T$VAR EQU T$FNC+3 VARIABLE ! 2823: T$CON EQU T$VAR+3 CONSTANT ! 2824: T$BOP EQU T$CON+3 BINARY OPERATOR ! 2825: T$RPR EQU T$BOP+3 RIGHT PAREN ! 2826: T$RBR EQU T$RPR+3 RIGHT BRACKET ! 2827: T$COL EQU T$RBR+3 COLON ! 2828: T$SMC EQU T$COL+3 SEMI-COLON ! 2829: * ! 2830: * THE FOLLOWING DEFINITIONS ARE USED ONLY IN THE GOTO FIELD ! 2831: * ! 2832: T$FGO EQU T$SMC+1 FAILURE GOTO ! 2833: T$SGO EQU T$FGO+1 SUCCESS GOTO ! 2834: * ! 2835: * THE ABOVE CODES ARE GROUPED SO THAT CODES FOR ELEMENTS ! 2836: * WHICH CAN LEGITIMATELY IMMEDIATELY PRECEDE A UNARY ! 2837: * OPERATOR COME FIRST TO FACILITATE OPERATOR SYNTAX CHECK. ! 2838: * ! 2839: T$UOK EQU T$FNC LAST CODE OK BEFORE UNARY OPERATOR ! 2840: EJC ! 2841: * ! 2842: * DEFINITIONS OF VALUES FOR EXPAN JUMP TABLE ! 2843: * ! 2844: T$UO0 EQU T$UOP+0 UNARY OPERATOR, STATE ZERO ! 2845: T$UO1 EQU T$UOP+1 UNARY OPERATOR, STATE ONE ! 2846: T$UO2 EQU T$UOP+2 UNARY OPERATOR, STATE TWO ! 2847: T$LP0 EQU T$LPR+0 LEFT PAREN, STATE ZERO ! 2848: T$LP1 EQU T$LPR+1 LEFT PAREN, STATE ONE ! 2849: T$LP2 EQU T$LPR+2 LEFT PAREN, STATE TWO ! 2850: T$LB0 EQU T$LBR+0 LEFT BRACKET, STATE ZERO ! 2851: T$LB1 EQU T$LBR+1 LEFT BRACKET, STATE ONE ! 2852: T$LB2 EQU T$LBR+2 LEFT BRACKET, STATE TWO ! 2853: T$CM0 EQU T$CMA+0 COMMA, STATE ZERO ! 2854: T$CM1 EQU T$CMA+1 COMMA, STATE ONE ! 2855: T$CM2 EQU T$CMA+2 COMMA, STATE TWO ! 2856: T$FN0 EQU T$FNC+0 FUNCTION CALL, STATE ZERO ! 2857: T$FN1 EQU T$FNC+1 FUNCTION CALL, STATE ONE ! 2858: T$FN2 EQU T$FNC+2 FUNCTION CALL, STATE TWO ! 2859: T$VA0 EQU T$VAR+0 VARIABLE, STATE ZERO ! 2860: T$VA1 EQU T$VAR+1 VARIABLE, STATE ONE ! 2861: T$VA2 EQU T$VAR+2 VARIABLE, STATE TWO ! 2862: T$CO0 EQU T$CON+0 CONSTANT, STATE ZERO ! 2863: T$CO1 EQU T$CON+1 CONSTANT, STATE ONE ! 2864: T$CO2 EQU T$CON+2 CONSTANT, STATE TWO ! 2865: T$BO0 EQU T$BOP+0 BINARY OPERATOR, STATE ZERO ! 2866: T$BO1 EQU T$BOP+1 BINARY OPERATOR, STATE ONE ! 2867: T$BO2 EQU T$BOP+2 BINARY OPERATOR, STATE TWO ! 2868: T$RP0 EQU T$RPR+0 RIGHT PAREN, STATE ZERO ! 2869: T$RP1 EQU T$RPR+1 RIGHT PAREN, STATE ONE ! 2870: T$RP2 EQU T$RPR+2 RIGHT PAREN, STATE TWO ! 2871: T$RB0 EQU T$RBR+0 RIGHT BRACKET, STATE ZERO ! 2872: T$RB1 EQU T$RBR+1 RIGHT BRACKET, STATE ONE ! 2873: T$RB2 EQU T$RBR+2 RIGHT BRACKET, STATE TWO ! 2874: T$CL0 EQU T$COL+0 COLON, STATE ZERO ! 2875: T$CL1 EQU T$COL+1 COLON, STATE ONE ! 2876: T$CL2 EQU T$COL+2 COLON, STATE TWO ! 2877: T$SM0 EQU T$SMC+0 SEMICOLON, STATE ZERO ! 2878: T$SM1 EQU T$SMC+1 SEMICOLON, STATE ONE ! 2879: T$SM2 EQU T$SMC+2 SEMICOLON, STATE TWO ! 2880: * ! 2881: T$NES EQU T$SM2+1 NUMBER OF ENTRIES IN BRANCH TABLE ! 2882: EJC ! 2883: * ! 2884: * DEFINITION OF OFFSETS USED IN CONTROL CARD PROCESSING ! 2885: * ! 2886: .IF .CASL ! 2887: CC$CI EQU 0 -CASEIG ! 2888: CC$CO EQU CC$CI+1 -COPY ! 2889: .ELSE ! 2890: CC$CO EQU 0 -COPY ! 2891: .FI ! 2892: CC$EJ EQU CC$CO+1 -EJECT ! 2893: CC$FA EQU CC$EJ+1 -FAIL ! 2894: CC$LI EQU CC$FA+1 -LIST ! 2895: .IF .CASL ! 2896: CC$NC EQU CC$LI+1 -NOCASEIG ! 2897: CC$NF EQU CC$NC+1 -NOFAIL ! 2898: .ELSE ! 2899: CC$NF EQU CC$LI+1 -NOFAIL ! 2900: .FI ! 2901: CC$NL EQU CC$NF+1 -NOLIST ! 2902: CC$ST EQU CC$NL+1 -STITL ! 2903: CC$TI EQU CC$ST+1 -TITLE ! 2904: CC$TR EQU CC$TI+1 -TRACE ! 2905: CC$CT EQU CC$TR+1 NUMBER OF CONTROL CARDS ! 2906: CCNOC EQU 4 NO. OF CHARS INCLUDED IN MATCH ! 2907: CCOFS EQU 7 OFFSET TO START OF TITLE/SUBTITLE ! 2908: * ! 2909: * DEFINITIONS OF STACK OFFSETS USED IN CMPIL PROCEDURE ! 2910: * ! 2911: * SEE DESCRIPTION AT START OF CMPIL PROCEDURE FOR DETAILS ! 2912: * OF USE OF THESE LOCATIONS ON THE STACK. ! 2913: * ! 2914: CMSTM EQU 0 TREE FOR STATEMENT BODY ! 2915: CMSGO EQU CMSTM+1 TREE FOR SUCCESS GOTO ! 2916: CMFGO EQU CMSGO+1 TREE FOR FAIL GOTO ! 2917: CMCGO EQU CMFGO+1 CONDITIONAL GOTO FLAG ! 2918: CMPCD EQU CMCGO+1 PREVIOUS CDBLK POINTER ! 2919: CMFFP EQU CMPCD+1 FAILURE FILL IN FLAG FOR PREVIOUS ! 2920: CMFFC EQU CMFFP+1 FAILURE FILL IN FLAG FOR CURRENT ! 2921: CMSOP EQU CMFFC+1 SUCCESS FILL IN OFFSET FOR PREVIOUS ! 2922: CMSOC EQU CMSOP+1 SUCCESS FILL IN OFFSET FOR CURRENT ! 2923: CMLBL EQU CMSOC+1 PTR TO VRBLK FOR CURRENT LABEL ! 2924: CMTRA EQU CMLBL+1 PTR TO ENTRY CDBLK ! 2925: * ! 2926: CMNEN EQU CMTRA+1 COUNT OF STACK ENTRIES FOR CMPIL ! 2927: .IF .CNPF ! 2928: .ELSE ! 2929: * ! 2930: * A FEW CONSTANTS USED BY THE PROFILER ! 2931: PFPD1 EQU 8 PAD POSITIONS ... ! 2932: PFPD2 EQU 20 ... FOR PROFILE ... ! 2933: PFPD3 EQU 32 ... PRINTOUT ! 2934: PF$I2 EQU CFP$I+CFP$I SIZE OF TABLE ENTRY (2 INTS) ! 2935: .FI ! 2936: TTL S P I T B O L -- CONSTANT SECTION ! 2937: * ! 2938: * THIS SECTION CONSISTS ENTIRELY OF ASSEMBLED CONSTANTS. ! 2939: * ! 2940: * ALL LABEL NAMES ARE FIVE LETTERS. THE ORDER IS ! 2941: * APPROXIMATELY ALPHABETICAL, BUT IN SOME CASES (ALWAYS ! 2942: * DOCUMENTED), CONSTANTS MUST BE PLACED IN SOME SPECIAL ! 2943: * ORDER WHICH MUST NOT BE DISTURBED. ! 2944: * ! 2945: * IT MUST ALSO BE REMEMBERED THAT THERE IS A REQUIREMENT ! 2946: * FOR NO FORWARD REFERENCES WHICH ALSO DISTURBS THE ! 2947: * ALPHABETICAL ORDER IN SOME CASES. ! 2948: * ! 2949: SEC START OF CONSTANT SECTION ! 2950: * ! 2951: * FREE STORE PERCENTAGE (USED BY ALLOC) ! 2952: * ! 2953: ALFSP DAC E$FSP FREE STORE PERCENTAGE ! 2954: * ! 2955: * BIT CONSTANTS FOR GENERAL USE ! 2956: * ! 2957: BITS0 DBC 0 ALL ZERO BITS ! 2958: BITS1 DBC 1 ONE BIT IN LOW ORDER POSITION ! 2959: BITS2 DBC 2 BIT IN POSITION 2 ! 2960: BITS3 DBC 4 BIT IN POSITION 3 ! 2961: BITS4 DBC 8 BIT IN POSITION 4 ! 2962: BITS5 DBC 16 BIT IN POSITION 5 ! 2963: BITS6 DBC 32 BIT IN POSITION 6 ! 2964: BITS7 DBC 64 BIT IN POSITION 7 ! 2965: BITS8 DBC 128 BIT IN POSITION 8 ! 2966: BITS9 DBC 256 BIT IN POSITION 9 ! 2967: BIT10 DBC 512 BIT IN POSITION 10 ! 2968: BITSM DBC CFP$M MASK FOR MAX INTEGER ! 2969: * ! 2970: * BIT CONSTANTS FOR SVBLK (SVBIT FIELD) TESTS ! 2971: * ! 2972: BTFNC DBC SVFNC BIT TO TEST FOR FUNCTION ! 2973: BTKNM DBC SVKNM BIT TO TEST FOR KEYWORD NUMBER ! 2974: BTLBL DBC SVLBL BIT TO TEST FOR LABEL ! 2975: BTFFC DBC SVFFC BIT TO TEST FOR FAST CALL ! 2976: BTCKW DBC SVCKW BIT TO TEST FOR CONSTANT KEYWORD ! 2977: BTPRD DBC SVPRD BIT TO TEST FOR PREDICATE FUNCTION ! 2978: BTPRE DBC SVPRE BIT TO TEST FOR PREEVALUATION ! 2979: BTVAL DBC SVVAL BIT TO TEST FOR VALUE ! 2980: EJC ! 2981: * ! 2982: * LIST OF NAMES USED FOR CONTROL CARD PROCESSING ! 2983: * ! 2984: .IF .CASL ! 2985: CCNMS DTC /CASE/ ! 2986: DTC /COPY/ ! 2987: .ELSE ! 2988: CCNMS DTC /COPY/ ! 2989: .FI ! 2990: DTC /EJEC/ ! 2991: DTC /FAIL/ ! 2992: DTC /LIST/ ! 2993: .IF .CASL ! 2994: DTC /NOCA/ ! 2995: .FI ! 2996: DTC /NOFA/ ! 2997: DTC /NOLI/ ! 2998: DTC /STIT/ ! 2999: DTC /TITL/ ! 3000: DTC /TRAC/ ! 3001: * ! 3002: * HEADER MESSAGES FOR DUMPR PROCEDURE (SCBLK FORMAT) ! 3003: * ! 3004: DMHDK DAC B$SCL ! 3005: DAC 22 ! 3006: DDC /DUMP OF KEYWORD VALUES/ ! 3007: * ! 3008: DMHDV DAC B$SCL ! 3009: DAC 25 ! 3010: DDC /DUMP OF NATURAL VARIABLES/ ! 3011: * ! 3012: * MESSAGE TEXT FOR COMPILATION STATISTICS ! 3013: * ! 3014: ENCM1 DAC B$SCL ! 3015: DAC 10 ! 3016: DDC /STORE USED/ ! 3017: * ! 3018: ENCM2 DAC B$SCL ! 3019: DAC 10 ! 3020: DDC /STORE LEFT/ ! 3021: * ! 3022: ENCM3 DAC B$SCL ! 3023: DAC 11 ! 3024: DDC /COMP ERRORS/ ! 3025: * ! 3026: ENCM4 DAC B$SCL ! 3027: DAC 14 ! 3028: .IF .CTMD ! 3029: DDC /COMP TIME-DSEC/ ! 3030: .ELSE ! 3031: DDC /COMP TIME-MSEC/ ! 3032: .FI ! 3033: * ! 3034: ENCM5 DAC B$SCL ! 3035: DAC 20 ! 3036: DDC /EXECUTION SUPPRESSED/ ! 3037: EJC ! 3038: * ! 3039: * FOR TERMINATION IN COMPILATION ! 3040: * ! 3041: ENDIC DAC B$SCL ! 3042: DAC 14 ! 3043: DDC /IN COMPILATION/ ! 3044: * ! 3045: * MEMORY OVERFLOW DURING INITIALISATION ! 3046: * ! 3047: ENDMO DAC B$SCL ! 3048: ENDML DAC 15 ! 3049: DDC /MEMORY OVERFLOW/ ! 3050: * ! 3051: * STRING CONSTANT FOR MESSAGE ISSUED BY L$END ! 3052: * ! 3053: ENDMS DAC B$SCL ! 3054: DAC 10 ! 3055: DDC /NORMAL END/ ! 3056: * ! 3057: * FAIL MESSAGE FOR STACK FAIL SECTION ! 3058: * ! 3059: ENDSO DAC B$SCL ! 3060: DAC 36 ! 3061: DDC /STACK OVERFLOW IN GARBAGE COLLECTION/ ! 3062: EJC ! 3063: * ! 3064: * STRING CONSTANT FOR ERROR MESSAGE (ERROR SECTION) ! 3065: * ! 3066: ERMMS DAC B$SCL ! 3067: DAC 5 ! 3068: DDC /ERROR/ ! 3069: * ! 3070: ERMNS DAC B$SCL ! 3071: DAC 4 ! 3072: DTC / -- / ! 3073: * ! 3074: * ! 3075: ERRTF DAC 251 FATAL ERROR CODE - SEE LABEL ERRAF ! 3076: * ! 3077: * STRING CONSTANT FOR PAGE NUMBERING ! 3078: * ! 3079: LSTMS DAC B$SCL ! 3080: DAC 5 ! 3081: DDC /PAGE / ! 3082: * ! 3083: * LISTING HEADER MESSAGE ! 3084: * ! 3085: HEADR DAC B$SCL ! 3086: DAC 25 ! 3087: DDC /MACRO SPITBOL VERSION 4.3/ ! 3088: * ! 3089: HEADV DAC B$SCL FOR EXIT() VERSION NO. CHECK ! 3090: DAC 3 ! 3091: DTC /4.3/ ! 3092: * ! 3093: * INTEGER CONSTANTS FOR GENERAL USE ! 3094: * ICBLD OPTIMISATION USES THE FIRST THREE. ! 3095: * ! 3096: INT$R DAC B$ICL ! 3097: INTV0 DIC +0 0 ! 3098: INTON DAC B$ICL ! 3099: INTV1 DIC +1 1 ! 3100: INTTW DAC B$ICL ! 3101: INTV2 DIC +2 2 ! 3102: INTVT DIC +10 10 ! 3103: INTVH DIC +100 100 ! 3104: INTTH DIC +1000 1000 ! 3105: * ! 3106: * TABLE USED IN ICBLD OPTIMISATION ! 3107: * ! 3108: INTAB DAC INT$R POINTER TO 0 ! 3109: DAC INTON POINTER TO 1 ! 3110: DAC INTTW POINTER TO 2 ! 3111: EJC ! 3112: * ! 3113: * SPECIAL PATTERN NODES. THE FOLLOWING PATTERN NODES ! 3114: * CONSIST SIMPLY OF A PCODE POINTER, SEE MATCH ROUTINES ! 3115: * (P$XXX) FOR FULL DETAILS OF THEIR USE AND FORMAT). ! 3116: * ! 3117: NDABB DAC P$ABB ARBNO ! 3118: NDABD DAC P$ABD ARBNO ! 3119: NDARC DAC P$ARC ARB ! 3120: NDEXB DAC P$EXB EXPRESSION ! 3121: NDEXC DAC P$EXC EXPRESSION ! 3122: .IF .CNFN ! 3123: .ELSE ! 3124: NDFNB DAC P$FNB FENCE() ! 3125: NDFND DAC P$FND FENCE() ! 3126: .FI ! 3127: NDIMB DAC P$IMB IMMEDIATE ASSIGNMENT ! 3128: NDIMD DAC P$IMD IMMEDIATE ASSIGNMENT ! 3129: NDNTH DAC P$NTH PATTERN END (NULL PATTERN) ! 3130: NDPAB DAC P$PAB PATTERN ASSIGNMENT ! 3131: NDPAD DAC P$PAD PATTERN ASSIGNMENT ! 3132: NDUNA DAC P$UNA ANCHOR POINT MOVEMENT ! 3133: * ! 3134: * KEYWORD CONSTANT PATTERN NODES. THE FOLLOWING NODES ARE ! 3135: * USED AS THE VALUES OF PATTERN KEYWORDS AND THE INITIAL ! 3136: * VALUES OF THE CORRESPONDING NATURAL VARIABLES. ALL ! 3137: * NODES ARE IN P0BLK FORMAT AND THE ORDER IS TIED TO THE ! 3138: * DEFINITIONS OF CORRESPONDING K$XXX SYMBOLS. ! 3139: * ! 3140: NDABO DAC P$ABO ABORT ! 3141: DAC NDNTH ! 3142: NDARB DAC P$ARB ARB ! 3143: DAC NDNTH ! 3144: NDBAL DAC P$BAL BAL ! 3145: DAC NDNTH ! 3146: NDFAL DAC P$FAL FAIL ! 3147: DAC NDNTH ! 3148: NDFEN DAC P$FEN FENCE ! 3149: DAC NDNTH ! 3150: NDREM DAC P$REM REM ! 3151: DAC NDNTH ! 3152: NDSUC DAC P$SUC SUCCEED ! 3153: DAC NDNTH ! 3154: * ! 3155: * NULL STRING. ALL NULL VALUES POINT TO THIS STRING. THE ! 3156: * SVCHS FIELD CONTAINS A BLANK TO PROVIDE FOR EASY DEFAULT ! 3157: * PROCESSING IN TRACE, STOPTR, LPAD AND RPAD. ! 3158: * NULLW CONTAINS 10 BLANKS WHICH ENSURES AN ALL BLANK WORD ! 3159: * BUT FOR VERY EXCEPTIONAL MACHINES. ! 3160: * ! 3161: NULLS DAC B$SCL NULL STRING VALUE ! 3162: DAC 0 SCLEN = 0 ! 3163: NULLW DTC / / ! 3164: EJC ! 3165: * ! 3166: * OPERATOR DOPE VECTORS (SEE DVBLK FORMAT) ! 3167: * ! 3168: OPDVC DAC O$CNC CONCATENATION ! 3169: DAC C$CNC ! 3170: DAC LLCNC ! 3171: DAC RRCNC ! 3172: * ! 3173: * OPDVP IS USED WHEN SCANNING BELOW TOP LEVEL TO ENSURE ! 3174: * THE CONCATENATION WILL NOT LATER BE MISTAKEN FOR ! 3175: * PATTERN MATCHING ! 3176: * ! 3177: OPDVP DAC O$CNC PROVEN CONCATENATION ! 3178: DAC C$CNP ! 3179: DAC LLCNC ! 3180: DAC RRCNC ! 3181: * ! 3182: * NOTE THAT THE ORDER OF THE REMAINING ENTRIES IS TIED TO ! 3183: * THE ORDER OF THE CODING IN THE SCANE PROCEDURE. ! 3184: * ! 3185: OPDVS DAC O$ASS ASSIGNMENT ! 3186: DAC C$ASS ! 3187: DAC LLASS ! 3188: DAC RRASS ! 3189: * ! 3190: DAC 6 UNARY EQUAL ! 3191: DAC C$UUO ! 3192: DAC LLUNO ! 3193: * ! 3194: DAC O$PMV PATTERN MATCH ! 3195: DAC C$PMT ! 3196: DAC LLPMT ! 3197: DAC RRPMT ! 3198: * ! 3199: DAC O$INT INTERROGATION ! 3200: DAC C$UVL ! 3201: DAC LLUNO ! 3202: * ! 3203: DAC 1 BINARY AMPERSAND ! 3204: DAC C$UBO ! 3205: DAC LLAMP ! 3206: DAC RRAMP ! 3207: * ! 3208: DAC O$KWV KEYWORD REFERENCE ! 3209: DAC C$KEY ! 3210: DAC LLUNO ! 3211: * ! 3212: DAC O$ALT ALTERNATION ! 3213: DAC C$ALT ! 3214: DAC LLALT ! 3215: DAC RRALT ! 3216: EJC ! 3217: * ! 3218: * OPERATOR DOPE VECTORS (CONTINUED) ! 3219: * ! 3220: DAC 5 UNARY VERTICAL BAR ! 3221: DAC C$UUO ! 3222: DAC LLUNO ! 3223: * ! 3224: DAC 0 BINARY AT ! 3225: DAC C$UBO ! 3226: DAC LLATS ! 3227: DAC RRATS ! 3228: * ! 3229: DAC O$CAS CURSOR ASSIGNMENT ! 3230: DAC C$UNM ! 3231: DAC LLUNO ! 3232: * ! 3233: DAC 2 BINARY NUMBER SIGN ! 3234: DAC C$UBO ! 3235: DAC LLNUM ! 3236: DAC RRNUM ! 3237: * ! 3238: DAC 7 UNARY NUMBER SIGN ! 3239: DAC C$UUO ! 3240: DAC LLUNO ! 3241: * ! 3242: DAC O$DVD DIVISION ! 3243: DAC C$BVL ! 3244: DAC LLDVD ! 3245: DAC RRDVD ! 3246: * ! 3247: DAC 9 UNARY SLASH ! 3248: DAC C$UUO ! 3249: DAC LLUNO ! 3250: * ! 3251: DAC O$MLT MULTIPLICATION ! 3252: DAC C$BVL ! 3253: DAC LLMLT ! 3254: DAC RRMLT ! 3255: EJC ! 3256: * ! 3257: * OPERATOR DOPE VECTORS (CONTINUED) ! 3258: * ! 3259: DAC 0 DEFERRED EXPRESSION ! 3260: DAC C$DEF ! 3261: DAC LLUNO ! 3262: * ! 3263: DAC 3 BINARY PERCENT ! 3264: DAC C$UBO ! 3265: DAC LLPCT ! 3266: DAC RRPCT ! 3267: * ! 3268: DAC 8 UNARY PERCENT ! 3269: DAC C$UUO ! 3270: DAC LLUNO ! 3271: * ! 3272: DAC O$EXP EXPONENTIATION ! 3273: DAC C$BVL ! 3274: DAC LLEXP ! 3275: DAC RREXP ! 3276: * ! 3277: DAC 10 UNARY EXCLAMATION ! 3278: DAC C$UUO ! 3279: DAC LLUNO ! 3280: * ! 3281: DAC 4 BINARY NOT ! 3282: DAC C$UBO ! 3283: DAC LLNOT ! 3284: DAC RRNOT ! 3285: * ! 3286: DAC 0 NEGATION ! 3287: DAC C$NEG ! 3288: DAC LLUNO ! 3289: EJC ! 3290: * ! 3291: * OPERATOR DOPE VECTORS (CONTINUED) ! 3292: * ! 3293: DAC O$SUB SUBTRACTION ! 3294: DAC C$BVL ! 3295: DAC LLPLM ! 3296: DAC RRPLM ! 3297: * ! 3298: DAC O$COM COMPLEMENTATION ! 3299: DAC C$UVL ! 3300: DAC LLUNO ! 3301: * ! 3302: DAC O$ADD ADDITION ! 3303: DAC C$BVL ! 3304: DAC LLPLM ! 3305: DAC RRPLM ! 3306: * ! 3307: DAC O$AFF AFFIRMATION ! 3308: DAC C$UVL ! 3309: DAC LLUNO ! 3310: * ! 3311: DAC O$IMA IMMEDIATE ASSIGNMENT ! 3312: DAC C$BVN ! 3313: DAC LLDLD ! 3314: DAC RRDLD ! 3315: * ! 3316: DAC O$INV INDIRECTION ! 3317: DAC C$IND ! 3318: DAC LLUNO ! 3319: * ! 3320: DAC O$PAS PATTERN ASSIGNMENT ! 3321: DAC C$BVN ! 3322: DAC LLDLD ! 3323: DAC RRDLD ! 3324: * ! 3325: DAC O$NAM NAME REFERENCE ! 3326: DAC C$UNM ! 3327: DAC LLUNO ! 3328: * ! 3329: * SPECIAL DVS FOR GOTO OPERATORS (SEE PROCEDURE SCNGF) ! 3330: * ! 3331: OPDVD DAC O$GOD DIRECT GOTO ! 3332: DAC C$UVL ! 3333: DAC LLUNO ! 3334: * ! 3335: OPDVN DAC O$GOC COMPLEX NORMAL GOTO ! 3336: DAC C$UNM ! 3337: DAC LLUNO ! 3338: EJC ! 3339: * ! 3340: * OPERATOR ENTRY ADDRESS POINTERS, USED IN CODE ! 3341: * ! 3342: OAMN$ DAC O$AMN ARRAY REF (MULTI-SUBS BY VALUE) ! 3343: OAMV$ DAC O$AMV ARRAY REF (MULTI-SUBS BY VALUE) ! 3344: OAON$ DAC O$AON ARRAY REF (ONE SUB BY NAME) ! 3345: OAOV$ DAC O$AOV ARRAY REF (ONE SUB BY VALUE) ! 3346: OCER$ DAC O$CER COMPILATION ERROR ! 3347: OFEX$ DAC O$FEX FAILURE IN EXPRESSION EVALUATION ! 3348: OFIF$ DAC O$FIF FAILURE DURING GOTO EVALUATION ! 3349: OFNC$ DAC O$FNC FUNCTION CALL (MORE THAN ONE ARG) ! 3350: OFNE$ DAC O$FNE FUNCTION NAME ERROR ! 3351: OFNS$ DAC O$FNS FUNCTION CALL (SINGLE ARGUMENT) ! 3352: OGOF$ DAC O$GOF SET GOTO FAILURE TRAP ! 3353: OINN$ DAC O$INN INDIRECTION BY NAME ! 3354: OKWN$ DAC O$KWN KEYWORD REFERENCE BY NAME ! 3355: OLEX$ DAC O$LEX LOAD EXPRESSION BY NAME ! 3356: OLPT$ DAC O$LPT LOAD PATTERN ! 3357: OLVN$ DAC O$LVN LOAD VARIABLE NAME ! 3358: ONTA$ DAC O$NTA NEGATION, FIRST ENTRY ! 3359: ONTB$ DAC O$NTB NEGATION, SECOND ENTRY ! 3360: ONTC$ DAC O$NTC NEGATION, THIRD ENTRY ! 3361: OPMN$ DAC O$PMN PATTERN MATCH BY NAME ! 3362: OPMS$ DAC O$PMS PATTERN MATCH (STATEMENT) ! 3363: OPOP$ DAC O$POP POP TOP STACK ITEM ! 3364: ORNM$ DAC O$RNM RETURN NAME FROM EXPRESSION ! 3365: ORPL$ DAC O$RPL PATTERN REPLACEMENT ! 3366: ORVL$ DAC O$RVL RETURN VALUE FROM EXPRESSION ! 3367: OSLA$ DAC O$SLA SELECTION, FIRST ENTRY ! 3368: OSLB$ DAC O$SLB SELECTION, SECOND ENTRY ! 3369: OSLC$ DAC O$SLC SELECTION, THIRD ENTRY ! 3370: OSLD$ DAC O$SLD SELECTION, FOURTH ENTRY ! 3371: OSTP$ DAC O$STP STOP EXECUTION ! 3372: OUNF$ DAC O$UNF UNEXPECTED FAILURE ! 3373: EJC ! 3374: * ! 3375: * TABLE OF NAMES OF UNDEFINED BINARY OPERATORS FOR OPSYN ! 3376: * ! 3377: OPSNB DAC CH$AT AT ! 3378: DAC CH$AM AMPERSAND ! 3379: DAC CH$NM NUMBER ! 3380: DAC CH$PC PERCENT ! 3381: DAC CH$NT NOT ! 3382: * ! 3383: * TABLE OF NAMES OF UNDEFINED UNARY OPERATORS FOR OPSYN ! 3384: * ! 3385: OPNSU DAC CH$BR VERTICAL BAR ! 3386: DAC CH$EQ EQUAL ! 3387: DAC CH$NM NUMBER ! 3388: DAC CH$PC PERCENT ! 3389: DAC CH$SL SLASH ! 3390: DAC CH$EX EXCLAMATION ! 3391: .IF .CNPF ! 3392: .ELSE ! 3393: * ! 3394: * ADDRESS CONST CONTAINING PROFILE TABLE ENTRY SIZE ! 3395: * ! 3396: PFI2A DAC PF$I2 ! 3397: * ! 3398: * PROFILER MESSAGE STRINGS ! 3399: * ! 3400: PFMS1 DAC B$SCL ! 3401: DAC 15 ! 3402: DDC /PROGRAM PROFILE/ ! 3403: PFMS2 DAC B$SCL ! 3404: DAC 42 ! 3405: DDC /STMT NUMBER OF -- EXECUTION TIME --/ ! 3406: PFMS3 DAC B$SCL ! 3407: DAC 47 ! 3408: DDC /NUMBER EXECUTIONS TOTAL(MSEC) PER EXCN(MCSEC)/ ! 3409: .FI ! 3410: .IF .CNRA ! 3411: .ELSE ! 3412: * ! 3413: * REAL CONSTANTS FOR GENERAL USE. NOTE THAT THE CONSTANTS ! 3414: * STARTING AT REAV1 FORM A POWERS OF TEN TABLE (GTSTG) ! 3415: * ! 3416: REAV0 DRC +0.0 0.0 ! 3417: REAP1 DRC +0.1 0.1 ! 3418: REAP5 DRC +0.5 0.5 ! 3419: REAV1 DRC +1.0 10**0 ! 3420: REAVT DRC +1.0E+1 10**1 ! 3421: DRC +1.0E+2 10**2 ! 3422: DRC +1.0E+3 10**3 ! 3423: DRC +1.0E+4 10**4 ! 3424: DRC +1.0E+5 10**5 ! 3425: DRC +1.0E+6 10**6 ! 3426: DRC +1.0E+7 10**7 ! 3427: DRC +1.0E+8 10**8 ! 3428: DRC +1.0E+9 10**9 ! 3429: REATT DRC +1.0E+10 10**10 ! 3430: .FI ! 3431: EJC ! 3432: * ! 3433: * STRING CONSTANTS (SCBLK FORMAT) FOR DTYPE PROCEDURE ! 3434: * ! 3435: SCARR DAC B$SCL ARRAY ! 3436: DAC 5 ! 3437: DTC /ARRAY/ ! 3438: .IF .CNBF ! 3439: .ELSE ! 3440: * ! 3441: SCBUF DAC B$SCL ! 3442: DAC 6 ! 3443: DTC /BUFFER/ ! 3444: .FI ! 3445: * ! 3446: SCCOD DAC B$SCL CODE ! 3447: DAC 4 ! 3448: DTC /CODE/ ! 3449: * ! 3450: SCEXP DAC B$SCL EXPRESSION ! 3451: DAC 10 ! 3452: DTC /EXPRESSION/ ! 3453: * ! 3454: SCEXT DAC B$SCL EXTERNAL ! 3455: DAC 8 ! 3456: DTC /EXTERNAL/ ! 3457: * ! 3458: SCINT DAC B$SCL INTEGER ! 3459: DAC 7 ! 3460: DTC /INTEGER/ ! 3461: * ! 3462: SCNAM DAC B$SCL NAME ! 3463: DAC 4 ! 3464: DTC /NAME/ ! 3465: * ! 3466: SCNUM DAC B$SCL NUMERIC ! 3467: DAC 7 ! 3468: DTC /NUMERIC/ ! 3469: * ! 3470: SCPAT DAC B$SCL PATTERN ! 3471: DAC 7 ! 3472: DTC /PATTERN/ ! 3473: .IF .CNRA ! 3474: .ELSE ! 3475: * ! 3476: SCREA DAC B$SCL REAL ! 3477: DAC 4 ! 3478: DTC /REAL/ ! 3479: .FI ! 3480: * ! 3481: SCSTR DAC B$SCL STRING ! 3482: DAC 6 ! 3483: DTC /STRING/ ! 3484: * ! 3485: SCTAB DAC B$SCL TABLE ! 3486: DAC 5 ! 3487: DTC /TABLE/ ! 3488: EJC ! 3489: * ! 3490: * STRING CONSTANTS (SCBLK FORMAT) FOR KVRTN (SEE RETRN) ! 3491: * ! 3492: SCFRT DAC B$SCL FRETURN ! 3493: DAC 7 ! 3494: DTC /FRETURN/ ! 3495: * ! 3496: SCNRT DAC B$SCL NRETURN ! 3497: DAC 7 ! 3498: DTC /NRETURN/ ! 3499: * ! 3500: SCRTN DAC B$SCL RETURN ! 3501: DAC 6 ! 3502: DTC /RETURN/ ! 3503: * ! 3504: * DATATYPE NAME TABLE FOR DTYPE PROCEDURE. THE ORDER OF ! 3505: * THESE ENTRIES IS TIED TO THE B$XXX DEFINITIONS FOR BLOCKS ! 3506: * ! 3507: SCNMT DAC SCARR ARBLK ARRAY ! 3508: .IF .CNBF ! 3509: .ELSE ! 3510: DAC SCBUF BFBLK BUFFER ! 3511: .FI ! 3512: DAC SCCOD CDBLK CODE ! 3513: DAC SCEXP EXBLK EXPRESSION ! 3514: DAC SCINT ICBLK INTEGER ! 3515: DAC SCNAM NMBLK NAME ! 3516: DAC SCPAT P0BLK PATTERN ! 3517: DAC SCPAT P1BLK PATTERN ! 3518: DAC SCPAT P2BLK PATTERN ! 3519: .IF .CNRA ! 3520: .ELSE ! 3521: DAC SCREA RCBLK REAL ! 3522: .FI ! 3523: DAC SCSTR SCBLK STRING ! 3524: DAC SCEXP SEBLK EXPRESSION ! 3525: DAC SCTAB TBBLK TABLE ! 3526: DAC SCARR VCBLK ARRAY ! 3527: DAC SCEXT XNBLK EXTERNAL ! 3528: DAC SCEXT XRBLK EXTERNAL ! 3529: * ! 3530: .IF .CNRA ! 3531: .ELSE ! 3532: * STRING CONSTANT FOR REAL ZERO ! 3533: * ! 3534: SCRE0 DAC B$SCL ! 3535: DAC 2 ! 3536: DTC /0./ ! 3537: .FI ! 3538: EJC ! 3539: * ! 3540: * USED TO RE-INITIALISE KVSTL ! 3541: * ! 3542: .IF .CS16 ! 3543: STLIM DIC +32767 DEFAULT STATEMENT LIMIT ! 3544: .ELSE ! 3545: STLIM DIC +50000 DEFAULT STATEMENT LIMIT ! 3546: .FI ! 3547: * ! 3548: * DUMMY FUNCTION BLOCK USED FOR UNDEFINED FUNCTIONS ! 3549: * ! 3550: STNDF DAC O$FUN PTR TO UNDEFINED FUNCTION ERR CALL ! 3551: DAC 0 DUMMY FARGS COUNT FOR CALL CIRCUIT ! 3552: * ! 3553: * DUMMY CODE BLOCK USED FOR UNDEFINED LABELS ! 3554: * ! 3555: STNDL DAC L$UND CODE PTR POINTS TO UNDEFINED LBL ! 3556: * ! 3557: * DUMMY OPERATOR BLOCK USED FOR UNDEFINED OPERATORS ! 3558: * ! 3559: STNDO DAC O$OUN PTR TO UNDEFINED OPERATOR ERR CALL ! 3560: DAC 0 DUMMY FARGS COUNT FOR CALL CIRCUIT ! 3561: * ! 3562: * STANDARD VARIABLE BLOCK. THIS BLOCK IS USED TO INITIALIZE ! 3563: * THE FIRST SEVEN FIELDS OF A NEWLY CONSTRUCTED VRBLK. ! 3564: * ITS FORMAT IS TIED TO THE VRBLK DEFINITIONS (SEE GTNVR). ! 3565: * ! 3566: STNVR DAC B$VRL VRGET ! 3567: DAC B$VRS VRSTO ! 3568: DAC NULLS VRVAL ! 3569: DAC B$VRG VRTRA ! 3570: DAC STNDL VRLBL ! 3571: DAC STNDF VRFNC ! 3572: DAC 0 VRNXT ! 3573: EJC ! 3574: * ! 3575: * MESSAGES USED IN END OF RUN PROCESSING (STOPR) ! 3576: * ! 3577: STPM1 DAC B$SCL ! 3578: DAC 12 ! 3579: DDC /IN STATEMENT/ ! 3580: * ! 3581: STPM2 DAC B$SCL ! 3582: DAC 14 ! 3583: DDC /STMTS EXECUTED/ ! 3584: * ! 3585: STPM3 DAC B$SCL ! 3586: DAC 13 ! 3587: .IF .CTMD ! 3588: DDC /RUN TIME-DSEC/ ! 3589: .ELSE ! 3590: DDC /RUN TIME-MSEC/ ! 3591: .FI ! 3592: * ! 3593: STPM4 DAC B$SCL ! 3594: DAC 12 ! 3595: DDC $MCSEC / STMT$ ! 3596: * ! 3597: STPM5 DAC B$SCL ! 3598: DAC 13 ! 3599: DDC /REGENERATIONS/ ! 3600: * ! 3601: * TABLE USED BY CONVERT FUNCTION TO CHECK DATATYPE NAME ! 3602: * THE ENTRIES ARE ORDERED TO CORRESPOND TO BRANCH TABLE ! 3603: * IN S$CNV ! 3604: * ! 3605: SVCTB DAC SCSTR STRING ! 3606: DAC SCINT INTEGER ! 3607: DAC SCNAM NAME ! 3608: DAC SCPAT PATTERN ! 3609: DAC SCARR ARRAY ! 3610: DAC SCTAB TABLE ! 3611: DAC SCEXP EXPRESSION ! 3612: DAC SCCOD CODE ! 3613: DAC SCNUM NUMERIC ! 3614: .IF .CNRA ! 3615: .ELSE ! 3616: DAC SCREA REAL ! 3617: .FI ! 3618: .IF .CNBF ! 3619: .ELSE ! 3620: DAC SCBUF BUFFER ! 3621: .FI ! 3622: DAC 0 ZERO MARKS END OF LIST ! 3623: EJC ! 3624: * ! 3625: * MESSAGES (SCBLK FORMAT) USED BY TRACE PROCEDURES ! 3626: * ! 3627: * ! 3628: TMASB DAC B$SCL ! 3629: DAC 13 ! 3630: DTC /************ / ! 3631: * ! 3632: TMBEB DAC B$SCL ! 3633: DAC 3 ! 3634: DTC / = / ! 3635: * ! 3636: * DUMMY TRBLK FOR EXPRESSION VARIABLE ! 3637: * ! 3638: TRBEV DAC B$TRT DUMMY TRBLK ! 3639: * ! 3640: * DUMMY TRBLK FOR KEYWORD VARIABLE ! 3641: * ! 3642: TRBKV DAC B$TRT DUMMY TRBLK ! 3643: * ! 3644: * DUMMY CODE BLOCK TO RETURN CONTROL TO TRXEQ PROCEDURE ! 3645: * ! 3646: TRXDR DAC O$TXR BLOCK POINTS TO RETURN ROUTINE ! 3647: TRXDC DAC TRXDR POINTER TO BLOCK ! 3648: EJC ! 3649: * ! 3650: * STANDARD VARIABLE BLOCKS ! 3651: * ! 3652: * SEE SVBLK FORMAT FOR FULL DETAILS OF THE FORMAT. THE ! 3653: * VRBLKS ARE ORDERED BY LENGTH AND WITHIN EACH LENGTH THE ! 3654: * ORDER IS ALPHABETICAL BY NAME OF THE VARIABLE. ! 3655: * ! 3656: V$EQF DBC SVFPR EQ ! 3657: DAC 2 ! 3658: DTC /EQ/ ! 3659: DAC S$EQF ! 3660: DAC 2 ! 3661: * ! 3662: V$GEF DBC SVFPR GE ! 3663: DAC 2 ! 3664: DTC /GE/ ! 3665: DAC S$GEF ! 3666: DAC 2 ! 3667: * ! 3668: V$GTF DBC SVFPR GT ! 3669: DAC 2 ! 3670: DTC /GT/ ! 3671: DAC S$GTF ! 3672: DAC 2 ! 3673: * ! 3674: V$LEF DBC SVFPR LE ! 3675: DAC 2 ! 3676: DTC /LE/ ! 3677: DAC S$LEF ! 3678: DAC 2 ! 3679: * ! 3680: V$LTF DBC SVFPR LT ! 3681: DAC 2 ! 3682: DTC /LT/ ! 3683: DAC S$LTF ! 3684: DAC 2 ! 3685: * ! 3686: V$NEF DBC SVFPR NE ! 3687: DAC 2 ! 3688: DTC /NE/ ! 3689: DAC S$NEF ! 3690: DAC 2 ! 3691: * ! 3692: V$ANY DBC SVFNP ANY ! 3693: DAC 3 ! 3694: DTC /ANY/ ! 3695: DAC S$ANY ! 3696: DAC 1 ! 3697: * ! 3698: V$ARB DBC SVKVC ARB ! 3699: DAC 3 ! 3700: DTC /ARB/ ! 3701: DAC K$ARB ! 3702: DAC NDARB ! 3703: EJC ! 3704: * ! 3705: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 3706: * ! 3707: V$ARG DBC SVFNN ARG ! 3708: DAC 3 ! 3709: DTC /ARG/ ! 3710: DAC S$ARG ! 3711: DAC 2 ! 3712: * ! 3713: V$BAL DBC SVKVC BAL ! 3714: DAC 3 ! 3715: DTC /BAL/ ! 3716: DAC K$BAL ! 3717: DAC NDBAL ! 3718: * ! 3719: V$CTI DBC SVFNP CTI ! 3720: DAC 3 ! 3721: DTC /CTI/ ! 3722: DAC S$CTI ! 3723: DAC 1 ! 3724: * ! 3725: V$END DBC SVLBL END ! 3726: DAC 3 ! 3727: DTC /END/ ! 3728: DAC L$END ! 3729: * ! 3730: V$ITC DBC SVFNN ITC ! 3731: DAC 3 ! 3732: DTC /ITC/ ! 3733: DAC S$ITC ! 3734: DAC 1 ! 3735: * ! 3736: V$LEN DBC SVFNP LEN ! 3737: DAC 3 ! 3738: DTC /LEN/ ! 3739: DAC S$LEN ! 3740: DAC 1 ! 3741: * ! 3742: V$LEQ DBC SVFPR LEQ ! 3743: DAC 3 ! 3744: DTC /LEQ/ ! 3745: DAC S$LEQ ! 3746: DAC 2 ! 3747: * ! 3748: V$LGE DBC SVFPR LGE ! 3749: DAC 3 ! 3750: DTC /LGE/ ! 3751: DAC S$LGE ! 3752: DAC 2 ! 3753: * ! 3754: V$LGT DBC SVFPR LGT ! 3755: DAC 3 ! 3756: DTC /LGT/ ! 3757: DAC S$LGT ! 3758: DAC 2 ! 3759: * ! 3760: V$LLE DBC SVFPR LLE ! 3761: DAC 3 ! 3762: DTC /LLE/ ! 3763: DAC S$LLE ! 3764: DAC 2 ! 3765: EJC ! 3766: * ! 3767: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 3768: * ! 3769: V$LLT DBC SVFPR LLT ! 3770: DAC 3 ! 3771: DTC /LLT/ ! 3772: DAC S$LLT ! 3773: DAC 2 ! 3774: * ! 3775: V$LNE DBC SVFPR LNE ! 3776: DAC 3 ! 3777: DTC /LNE/ ! 3778: DAC S$LNE ! 3779: DAC 2 ! 3780: * ! 3781: V$POS DBC SVFNP POS ! 3782: DAC 3 ! 3783: DTC /POS/ ! 3784: DAC S$POS ! 3785: DAC 1 ! 3786: * ! 3787: V$REM DBC SVKVC REM ! 3788: DAC 3 ! 3789: DTC /REM/ ! 3790: DAC K$REM ! 3791: DAC NDREM ! 3792: .IF .CUST ! 3793: * ! 3794: V$SET DBC SVFNN SET ! 3795: DAC 3 ! 3796: DTC /SET/ ! 3797: DAC S$SET ! 3798: DAC 3 ! 3799: .FI ! 3800: * ! 3801: V$TAB DBC SVFNP TAB ! 3802: DAC 3 ! 3803: DTC /TAB/ ! 3804: DAC S$TAB ! 3805: DAC 1 ! 3806: * ! 3807: V$COD DBC SVFNK CODE ! 3808: DAC 4 ! 3809: DTC /CODE/ ! 3810: DAC K$COD ! 3811: DAC S$COD ! 3812: DAC 1 ! 3813: * ! 3814: V$COP DBC SVFNN COPY ! 3815: DAC 4 ! 3816: DTC /COPY/ ! 3817: DAC S$COP ! 3818: DAC 1 ! 3819: EJC ! 3820: * ! 3821: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 3822: * ! 3823: V$DAT DBC SVFNN DATA ! 3824: DAC 4 ! 3825: DTC /DATA/ ! 3826: DAC S$DAT ! 3827: DAC 1 ! 3828: * ! 3829: V$DTE DBC SVFNN DATE ! 3830: DAC 4 ! 3831: DTC /DATE/ ! 3832: DAC S$DTE ! 3833: DAC 0 ! 3834: * ! 3835: V$DMP DBC SVFNK DUMP ! 3836: DAC 4 ! 3837: DTC /DUMP/ ! 3838: DAC K$DMP ! 3839: DAC S$DMP ! 3840: DAC 1 ! 3841: * ! 3842: V$DUP DBC SVFNN DUPL ! 3843: DAC 4 ! 3844: DTC /DUPL/ ! 3845: DAC S$DUP ! 3846: DAC 2 ! 3847: * ! 3848: V$EVL DBC SVFNN EVAL ! 3849: DAC 4 ! 3850: DTC /EVAL/ ! 3851: DAC S$EVL ! 3852: DAC 1 ! 3853: .IF .CNEX ! 3854: .ELSE ! 3855: * ! 3856: V$EXT DBC SVFNN EXIT ! 3857: DAC 4 ! 3858: DTC /EXIT/ ! 3859: DAC S$EXT ! 3860: DAC 1 ! 3861: .FI ! 3862: * ! 3863: V$FAL DBC SVKVC FAIL ! 3864: DAC 4 ! 3865: DTC /FAIL/ ! 3866: DAC K$FAL ! 3867: DAC NDFAL ! 3868: * ! 3869: V$HST DBC SVFNN HOST ! 3870: DAC 4 ! 3871: DTC /HOST/ ! 3872: DAC S$HST ! 3873: DAC 3 ! 3874: EJC ! 3875: * ! 3876: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 3877: * ! 3878: V$ITM DBC SVFNF ITEM ! 3879: DAC 4 ! 3880: DTC /ITEM/ ! 3881: DAC S$ITM ! 3882: DAC 999 ! 3883: .IF .CNLD ! 3884: .ELSE ! 3885: * ! 3886: V$LOD DBC SVFNN LOAD ! 3887: DAC 4 ! 3888: DTC /LOAD/ ! 3889: DAC S$LOD ! 3890: DAC 2 ! 3891: .FI ! 3892: * ! 3893: V$LPD DBC SVFNP LPAD ! 3894: DAC 4 ! 3895: DTC /LPAD/ ! 3896: DAC S$LPD ! 3897: DAC 3 ! 3898: * ! 3899: V$RPD DBC SVFNP RPAD ! 3900: DAC 4 ! 3901: DTC /RPAD/ ! 3902: DAC S$RPD ! 3903: DAC 3 ! 3904: EJC ! 3905: * ! 3906: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 3907: * ! 3908: * ! 3909: V$RPS DBC SVFNP RPOS ! 3910: DAC 4 ! 3911: DTC /RPOS/ ! 3912: DAC S$RPS ! 3913: DAC 1 ! 3914: * ! 3915: V$RTB DBC SVFNP RTAB ! 3916: DAC 4 ! 3917: DTC /RTAB/ ! 3918: DAC S$RTB ! 3919: DAC 1 ! 3920: * ! 3921: V$SI$ DBC SVFNP SIZE ! 3922: DAC 4 ! 3923: DTC /SIZE/ ! 3924: DAC S$SI$ ! 3925: DAC 1 ! 3926: * ! 3927: .IF .CNSR ! 3928: .ELSE ! 3929: * ! 3930: V$SRT DBC SVFNN SORT ! 3931: DAC 4 ! 3932: DTC /SORT/ ! 3933: DAC S$SRT ! 3934: DAC 2 ! 3935: .FI ! 3936: V$SPN DBC SVFNP SPAN ! 3937: DAC 4 ! 3938: DTC /SPAN/ ! 3939: DAC S$SPN ! 3940: DAC 1 ! 3941: EJC ! 3942: * ! 3943: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 3944: * ! 3945: V$STN DBC SVKNM STNO ! 3946: DAC 4 ! 3947: DTC /STNO/ ! 3948: DAC K$STN ! 3949: * ! 3950: V$TIM DBC SVFNN TIME ! 3951: DAC 4 ! 3952: DTC /TIME/ ! 3953: DAC S$TIM ! 3954: DAC 0 ! 3955: * ! 3956: V$TRM DBC SVFNK TRIM ! 3957: DAC 4 ! 3958: DTC /TRIM/ ! 3959: DAC K$TRM ! 3960: DAC S$TRM ! 3961: DAC 1 ! 3962: * ! 3963: V$ABO DBC SVKVL ABORT ! 3964: DAC 5 ! 3965: DTC /ABORT/ ! 3966: DAC K$ABO ! 3967: DAC L$ABO ! 3968: DAC NDABO ! 3969: * ! 3970: V$APP DBC SVFNF APPLY ! 3971: DAC 5 ! 3972: DTC /APPLY/ ! 3973: DAC S$APP ! 3974: DAC 999 ! 3975: * ! 3976: V$ABN DBC SVFNP ARBNO ! 3977: DAC 5 ! 3978: DTC /ARBNO/ ! 3979: DAC S$ABN ! 3980: DAC 1 ! 3981: * ! 3982: V$ARR DBC SVFNN ARRAY ! 3983: DAC 5 ! 3984: DTC /ARRAY/ ! 3985: DAC S$ARR ! 3986: DAC 2 ! 3987: EJC ! 3988: * ! 3989: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 3990: * ! 3991: V$BRK DBC SVFNP BREAK ! 3992: DAC 5 ! 3993: DTC /BREAK/ ! 3994: DAC S$BRK ! 3995: DAC 1 ! 3996: * ! 3997: V$CLR DBC SVFNN CLEAR ! 3998: DAC 5 ! 3999: DTC /CLEAR/ ! 4000: DAC S$CLR ! 4001: DAC 1 ! 4002: * ! 4003: V$EJC DBC SVFNN EJECT ! 4004: DAC 5 ! 4005: DTC /EJECT/ ! 4006: DAC S$EJC ! 4007: DAC 1 ! 4008: * ! 4009: .IF .CNFN ! 4010: V$FEN DBC SVKVC FENCE ! 4011: .ELSE ! 4012: V$FEN DBC SVFPK FENCE ! 4013: .FI ! 4014: DAC 5 ! 4015: DTC /FENCE/ ! 4016: DAC K$FEN ! 4017: .IF .CNFN ! 4018: .ELSE ! 4019: DAC S$FNC ! 4020: DAC 1 ! 4021: .FI ! 4022: DAC NDFEN ! 4023: * ! 4024: V$FLD DBC SVFNN FIELD ! 4025: DAC 5 ! 4026: DTC /FIELD/ ! 4027: DAC S$FLD ! 4028: DAC 2 ! 4029: * ! 4030: V$IDN DBC SVFPR IDENT ! 4031: DAC 5 ! 4032: DTC /IDENT/ ! 4033: DAC S$IDN ! 4034: DAC 2 ! 4035: * ! 4036: V$INP DBC SVFNK INPUT ! 4037: DAC 5 ! 4038: DTC /INPUT/ ! 4039: DAC K$INP ! 4040: DAC S$INP ! 4041: DAC 3 ! 4042: * ! 4043: V$LOC DBC SVFNN LOCAL ! 4044: DAC 5 ! 4045: DTC /LOCAL/ ! 4046: DAC S$LOC ! 4047: DAC 2 ! 4048: EJC ! 4049: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 4050: * ! 4051: V$OPS DBC SVFNN OPSYN ! 4052: DAC 5 ! 4053: DTC /OPSYN/ ! 4054: DAC S$OPS ! 4055: DAC 3 ! 4056: * ! 4057: V$RMD DBC SVFNP REMDR ! 4058: DAC 5 ! 4059: DTC /REMDR/ ! 4060: DAC S$RMD ! 4061: DAC 2 ! 4062: .IF .CNSR ! 4063: .ELSE ! 4064: * ! 4065: V$RSR DBC SVFNN RSORT ! 4066: DAC 5 ! 4067: DTC /RSORT/ ! 4068: DAC S$RSR ! 4069: DAC 2 ! 4070: .FI ! 4071: * ! 4072: V$TBL DBC SVFNN TABLE ! 4073: DAC 5 ! 4074: DTC /TABLE/ ! 4075: DAC S$TBL ! 4076: DAC 3 ! 4077: * ! 4078: V$TRA DBC SVFNK TRACE ! 4079: DAC 5 ! 4080: DTC /TRACE/ ! 4081: DAC K$TRA ! 4082: DAC S$TRA ! 4083: DAC 4 ! 4084: * ! 4085: V$ANC DBC SVKNM ANCHOR ! 4086: DAC 6 ! 4087: DTC /ANCHOR/ ! 4088: DAC K$ANC ! 4089: EJC ! 4090: * ! 4091: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 4092: * ! 4093: .IF .CNBF ! 4094: .ELSE ! 4095: V$APN DBC SVFNN APPEND ! 4096: DAC 6 ! 4097: DTC /APPEND/ ! 4098: DAC S$APN ! 4099: DAC 2 ! 4100: .FI ! 4101: * ! 4102: V$BKX DBC SVFNP BREAKX ! 4103: DAC 6 ! 4104: DTC /BREAKX/ ! 4105: DAC S$BKX ! 4106: DAC 1 ! 4107: .IF .CNBF ! 4108: .ELSE ! 4109: V$BUF DBC SVFNN BUFFER ! 4110: DAC 6 ! 4111: DTC /BUFFER/ ! 4112: DAC S$BUF ! 4113: DAC 2 ! 4114: .FI ! 4115: * ! 4116: V$DEF DBC SVFNN DEFINE ! 4117: DAC 6 ! 4118: DTC /DEFINE/ ! 4119: DAC S$DFN ! 4120: DAC 2 ! 4121: * ! 4122: V$DET DBC SVFNN DETACH ! 4123: DAC 6 ! 4124: DTC /DETACH/ ! 4125: DAC S$DET ! 4126: DAC 1 ! 4127: * ! 4128: V$DIF DBC SVFPR DIFFER ! 4129: DAC 6 ! 4130: DTC /DIFFER/ ! 4131: DAC S$DIF ! 4132: DAC 2 ! 4133: * ! 4134: V$FTR DBC SVKNM FTRACE ! 4135: DAC 6 ! 4136: DTC /FTRACE/ ! 4137: DAC K$FTR ! 4138: EJC ! 4139: .IF .CNBF ! 4140: .ELSE ! 4141: * ! 4142: V$INS DBC SVFNN INSERT ! 4143: DAC 6 ! 4144: DTC /INSERT/ ! 4145: DAC S$INS ! 4146: DAC 4 ! 4147: .FI ! 4148: * ! 4149: V$LST DBC SVKNM LASTNO ! 4150: DAC 6 ! 4151: DTC /LASTNO/ ! 4152: DAC K$LST ! 4153: * ! 4154: V$NAY DBC SVFNP NOTANY ! 4155: DAC 6 ! 4156: DTC /NOTANY/ ! 4157: DAC S$NAY ! 4158: DAC 1 ! 4159: * ! 4160: V$OUP DBC SVFNK OUTPUT ! 4161: DAC 6 ! 4162: DTC /OUTPUT/ ! 4163: DAC K$OUP ! 4164: DAC S$OUP ! 4165: DAC 3 ! 4166: * ! 4167: V$RET DBC SVLBL RETURN ! 4168: DAC 6 ! 4169: DTC /RETURN/ ! 4170: DAC L$RTN ! 4171: * ! 4172: V$STT DBC SVFNN STOPTR ! 4173: DAC 6 ! 4174: DTC /STOPTR/ ! 4175: DAC S$STT ! 4176: DAC 2 ! 4177: EJC ! 4178: * ! 4179: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 4180: * ! 4181: V$SUB DBC SVFNN SUBSTR ! 4182: DAC 6 ! 4183: DTC /SUBSTR/ ! 4184: DAC S$SUB ! 4185: DAC 3 ! 4186: * ! 4187: V$UNL DBC SVFNN UNLOAD ! 4188: DAC 6 ! 4189: DTC /UNLOAD/ ! 4190: DAC S$UNL ! 4191: DAC 1 ! 4192: * ! 4193: V$COL DBC SVFNN COLLECT ! 4194: DAC 7 ! 4195: DTC /COLLECT/ ! 4196: DAC S$COL ! 4197: DAC 1 ! 4198: * ! 4199: V$CNV DBC SVFNN CONVERT ! 4200: DAC 7 ! 4201: DTC /CONVERT/ ! 4202: DAC S$CVT ! 4203: DAC 2 ! 4204: * ! 4205: V$ENF DBC SVFNN ENDFILE ! 4206: DAC 7 ! 4207: DTC /ENDFILE/ ! 4208: DAC S$ENF ! 4209: DAC 2 ! 4210: * ! 4211: V$ETX DBC SVKNM ERRTEXT ! 4212: DAC 7 ! 4213: DTC /ERRTEXT/ ! 4214: DAC K$ETX ! 4215: * ! 4216: V$ERT DBC SVKNM ERRTYPE ! 4217: DAC 7 ! 4218: DTC /ERRTYPE/ ! 4219: DAC K$ERT ! 4220: * ! 4221: V$FRT DBC SVLBL FRETURN ! 4222: DAC 7 ! 4223: DTC /FRETURN/ ! 4224: DAC L$FRT ! 4225: * ! 4226: V$INT DBC SVFPR INTEGER ! 4227: DAC 7 ! 4228: DTC /INTEGER/ ! 4229: DAC S$INT ! 4230: DAC 1 ! 4231: * ! 4232: V$NRT DBC SVLBL NRETURN ! 4233: DAC 7 ! 4234: DTC /NRETURN/ ! 4235: DAC L$NRT ! 4236: EJC ! 4237: * ! 4238: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 4239: .IF .CNPF ! 4240: .ELSE ! 4241: * ! 4242: V$PFL DBC SVKNM PROFILE ! 4243: DAC 7 ! 4244: DTC /PROFILE/ ! 4245: DAC K$PFL ! 4246: .FI ! 4247: * ! 4248: * ! 4249: V$RPL DBC SVFNP REPLACE ! 4250: DAC 7 ! 4251: DTC /REPLACE/ ! 4252: DAC S$RPL ! 4253: DAC 3 ! 4254: * ! 4255: V$RVS DBC SVFNP REVERSE ! 4256: DAC 7 ! 4257: DTC /REVERSE/ ! 4258: DAC S$RVS ! 4259: DAC 1 ! 4260: * ! 4261: V$RTN DBC SVKNM RTNTYPE ! 4262: DAC 7 ! 4263: DTC /RTNTYPE/ ! 4264: DAC K$RTN ! 4265: * ! 4266: V$STX DBC SVFNN SETEXIT ! 4267: DAC 7 ! 4268: DTC /SETEXIT/ ! 4269: DAC S$STX ! 4270: DAC 1 ! 4271: * ! 4272: V$STC DBC SVKNM STCOUNT ! 4273: DAC 7 ! 4274: DTC /STCOUNT/ ! 4275: DAC K$STC ! 4276: * ! 4277: V$STL DBC SVKNM STLIMIT ! 4278: DAC 7 ! 4279: DTC /STLIMIT/ ! 4280: DAC K$STL ! 4281: * ! 4282: V$SUC DBC SVKVC SUCCEED ! 4283: DAC 7 ! 4284: DTC /SUCCEED/ ! 4285: DAC K$SUC ! 4286: DAC NDSUC ! 4287: * ! 4288: V$VDF DBC SVFPR VDIFFER ! 4289: DAC 7 ! 4290: DTC /VDIFFER/ ! 4291: DAC S$VDF ! 4292: DAC 2 ! 4293: * ! 4294: V$ALP DBC SVKWC ALPHABET ! 4295: DAC 8 ! 4296: DTC /ALPHABET/ ! 4297: DAC K$ALP ! 4298: EJC ! 4299: * ! 4300: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 4301: * ! 4302: V$CNT DBC SVLBL CONTINUE ! 4303: DAC 8 ! 4304: DTC /CONTINUE/ ! 4305: DAC L$CNT ! 4306: * ! 4307: V$DTP DBC SVFNP DATATYPE ! 4308: DAC 8 ! 4309: DTC /DATATYPE/ ! 4310: DAC S$DTP ! 4311: DAC 1 ! 4312: * ! 4313: V$ERL DBC SVKNM ERRLIMIT ! 4314: DAC 8 ! 4315: DTC /ERRLIMIT/ ! 4316: DAC K$ERL ! 4317: * ! 4318: V$FNC DBC SVKNM FNCLEVEL ! 4319: DAC 8 ! 4320: DTC /FNCLEVEL/ ! 4321: DAC K$FNC ! 4322: * ! 4323: V$MXL DBC SVKNM MAXLNGTH ! 4324: DAC 8 ! 4325: DTC /MAXLNGTH/ ! 4326: DAC K$MXL ! 4327: * ! 4328: V$TER DBC 0 TERMINAL ! 4329: DAC 8 ! 4330: DTC /TERMINAL/ ! 4331: DAC 0 ! 4332: * ! 4333: V$PRO DBC SVFNN PROTOTYPE ! 4334: DAC 9 ! 4335: DTC /PROTOTYPE/ ! 4336: DAC S$PRO ! 4337: DAC 1 ! 4338: * ! 4339: DBC 0 DUMMY ENTRY TO END LIST ! 4340: DAC 10 LENGTH GT 9 (PROTOTYPE) ! 4341: EJC ! 4342: * ! 4343: * LIST OF SVBLK POINTERS FOR KEYWORDS TO BE DUMPED. THE ! 4344: * LIST IS IN THE ORDER WHICH APPEARS ON THE DUMP OUTPUT. ! 4345: * ! 4346: VDMKW DAC V$ANC ANCHOR ! 4347: DAC V$COD CODE ! 4348: DAC V$DMP DUMP ! 4349: DAC V$ERL ERRLIMIT ! 4350: DAC V$ETX ERRTEXT ! 4351: DAC V$ERT ERRTYPE ! 4352: DAC V$FNC FNCLEVEL ! 4353: DAC V$FTR FTRACE ! 4354: DAC V$INP INPUT ! 4355: DAC V$LST LASTNO ! 4356: DAC V$MXL MAXLENGTH ! 4357: DAC V$OUP OUTPUT ! 4358: .IF .CNPF ! 4359: .ELSE ! 4360: DAC V$PFL PROFILE ! 4361: .FI ! 4362: DAC V$RTN RTNTYPE ! 4363: DAC V$STC STCOUNT ! 4364: DAC V$STL STLIMIT ! 4365: DAC V$STN STNO ! 4366: DAC V$TRA TRACE ! 4367: DAC V$TRM TRIM ! 4368: DAC 0 END OF LIST ! 4369: * ! 4370: * TABLE USED BY GTNVR TO SEARCH SVBLK LISTS ! 4371: * ! 4372: VSRCH DAC 0 DUMMY ENTRY TO GET PROPER INDEXING ! 4373: DAC V$EQF START OF 1 CHAR VARIABLES (NONE) ! 4374: DAC V$EQF START OF 2 CHAR VARIABLES ! 4375: DAC V$ANY START OF 3 CHAR VARIABLES ! 4376: DAC V$COD START OF 4 CHAR VARIABLES ! 4377: DAC V$ABO START OF 5 CHAR VARIABLES ! 4378: DAC V$ANC START OF 6 CHAR VARIABLES ! 4379: DAC V$COL START OF 7 CHAR VARIABLES ! 4380: DAC V$ALP START OF 8 CHAR VARIABLES ! 4381: DAC V$PRO START OF 9 CHAR VARIABLES ! 4382: TTL S P I T B O L -- WORKING STORAGE SECTION ! 4383: * ! 4384: * THE WORKING STORAGE SECTION CONTAINS AREAS WHICH ARE ! 4385: * CHANGED DURING EXECUTION OF THE PROGRAM. THE VALUE ! 4386: * ASSEMBLED IS THE INITIAL VALUE BEFORE EXECUTION STARTS. ! 4387: * ! 4388: * ALL THESE AREAS ARE FIXED LENGTH AREAS. VARIABLE LENGTH ! 4389: * DATA IS STORED IN THE STATIC OR DYNAMIC REGIONS OF THE ! 4390: * ALLOCATED DATA AREAS. ! 4391: * ! 4392: * THE VALUES IN THIS AREA ARE DESCRIBED EITHER AS WORK ! 4393: * AREAS OR AS GLOBAL VALUES. A WORK AREA IS USED IN AN ! 4394: * EPHEMERAL MANNER AND THE VALUE IS NOT SAVED FROM ONE ! 4395: * ENTRY INTO A ROUTINE TO ANOTHER. A GLOBAL VALUE IS A ! 4396: * LESS TEMPORARY LOCATION WHOSE VALUE IS SAVED FROM ONE ! 4397: * CALL TO ANOTHER. ! 4398: * ! 4399: * A GENERAL PART OF THE APPROACH IN THIS PROGRAM IS NOT ! 4400: * TO OVERLAP WORK AREAS BETWEEN PROCEDURES EVEN THOUGH A ! 4401: * SMALL AMOUNT OF SPACE COULD BE SAVED. SUCH OVERLAP IS ! 4402: * CONSIDERED A SOURCE OF PROGRAM ERRORS AND DECREASES THE ! 4403: * INFORMATION LEFT BEHIND AFTER A SYSTEM CRASH OF ANY KIND. ! 4404: * ! 4405: * THE NAMES OF THESE LOCATIONS ARE LABELS WITH FIVE LETTER ! 4406: * (A-Y,$) NAMES. AS FAR AS POSSIBLE THE ORDER IS KEPT ! 4407: * ALPHABETICAL BY THESE NAMES BUT IN SOME CASES THERE ! 4408: * ARE SLIGHT DEPARTURES CAUSED BY OTHER ORDER REQUIREMENTS. ! 4409: * ! 4410: * UNLESS OTHERWISE DOCUMENTED, THE ORDER OF WORK AREAS ! 4411: * DOES NOT AFFECT THE EXECUTION OF THE SPITBOL PROGRAM. ! 4412: * ! 4413: SEC START OF WORKING STORAGE SECTION ! 4414: EJC ! 4415: * ! 4416: * THIS AREA IS NOT CLEARED BY INITIAL CODE ! 4417: * ! 4418: CMLAB DAC B$SCL STRING USED TO CHECK LABEL LEGALITY ! 4419: DAC 2 ! 4420: DTC / / ! 4421: * ! 4422: * LABEL TO MARK START OF WORK AREA WHICH IS CLEARED ! 4423: * ! 4424: AAAAA DAC 0 ! 4425: * ! 4426: * WORK AREAS FOR ALLOC PROCEDURE ! 4427: * ! 4428: ALDYN DAC 0 AMOUNT OF DYNAMIC STORE ! 4429: ALFSF DIC +0 FACTOR IN FREE STORE PCNTAGE CHECK ! 4430: ALLIA DIC +0 DUMP IA ! 4431: ALLSV DAC 0 SAVE WB IN ALLOC ! 4432: * ! 4433: * WORK AREAS FOR ALOST PROCEDURE ! 4434: * ! 4435: ALSTA DAC 0 SAVE WA IN ALOST ! 4436: * ! 4437: * SAVE AREAS FOR ARRAY FUNCTION (S$ARR) ! 4438: * ! 4439: ARCDM DAC 0 COUNT DIMENSIONS ! 4440: ARNEL DIC +0 COUNT ELEMENTS ! 4441: ARPTR DAC 0 OFFSET PTR INTO ARBLK ! 4442: ARSVL DIC +0 SAVE INTEGER LOW BOUND ! 4443: EJC ! 4444: * WORK AREAS FOR ARREF ROUTINE ! 4445: * ! 4446: ARFSI DIC +0 SAVE CURRENT EVOLVING SUBSCRIPT ! 4447: ARFXS DAC 0 SAVE BASE STACK POINTER ! 4448: * ! 4449: * WORK AREAS FOR B$EFC BLOCK ROUTINE ! 4450: * ! 4451: BEFOF DAC 0 SAVE OFFSET PTR INTO EFBLK ! 4452: * ! 4453: * WORK AREAS FOR B$PFC BLOCK ROUTINE ! 4454: * ! 4455: BPFPF DAC 0 SAVE PFBLK POINTER ! 4456: BPFSV DAC 0 SAVE OLD FUNCTION VALUE ! 4457: BPFXT DAC 0 POINTER TO STACKED ARGUMENTS ! 4458: * ! 4459: * SAVE AREAS FOR COLLECT FUNCTION (S$COL) ! 4460: * ! 4461: CLSVI DIC +0 SAVE INTEGER ARGUMENT ! 4462: * ! 4463: * GLOBAL VALUES FOR CMPIL PROCEDURE ! 4464: * ! 4465: CMERC DAC 0 COUNT OF INITIAL COMPILE ERRORS ! 4466: CMPXS DAC 0 SAVE STACK PTR IN CASE OF ERRORS ! 4467: CMPSN DAC 1 NUMBER OF NEXT STATEMENT TO COMPILE ! 4468: CMPSS DAC 0 SAVE SUBROUTINE STACK PTR ! 4469: * ! 4470: * WORK AREA FOR CNCRD ! 4471: * ! 4472: CNSCC DAC 0 POINTER TO CONTROL CARD STRING ! 4473: CNSWC DAC 0 WORD COUNT ! 4474: CNR$T DAC 0 POINTER TO R$TTL OR R$STL ! 4475: CNTTL DAC 0 FLAG FOR -TITLE, -STITL ! 4476: * ! 4477: * WORK AREAS FOR CONVERT FUNCTION (S$CNV) ! 4478: * ! 4479: CNVTP DAC 0 SAVE PTR INTO SCVTB ! 4480: * ! 4481: * FLAG FOR SUPPRESSION OF COMPILATION STATISTICS. ! 4482: * ! 4483: CPSTS DAC 0 SUPPRESS COMP. STATS IF NON ZERO ! 4484: * ! 4485: * GLOBAL VALUES FOR CONTROL CARD SWITCHES ! 4486: * ! 4487: .IF .CASL ! 4488: CSWCI DAC 0 0/1 FOR -NOCASEIG/CASEIG ! 4489: .FI ! 4490: CSWFL DAC 1 0/1 FOR -NOFAIL/-FAIL ! 4491: CSWIN DAC INILN XXX FOR -INXXX ! 4492: CSWLS DAC 1 0/1 FOR -NOLIST/-LIST ! 4493: EJC ! 4494: * ! 4495: * GLOBAL LOCATION USED BY PATST PROCEDURE ! 4496: * ! 4497: CTMSK DBC 0 LAST BIT POSITION USED IN R$CTP ! 4498: CURID DAC 0 CURRENT ID VALUE ! 4499: * ! 4500: * GLOBAL VALUE FOR CDWRD PROCEDURE ! 4501: * ! 4502: CWCOF DAC 0 NEXT WORD OFFSET IN CURRENT CCBLK ! 4503: * ! 4504: * WORK AREAS FOR DATA FUNCTION (S$DAT) ! 4505: * ! 4506: DATDV DAC 0 SAVE VRBLK PTR FOR DATATYPE NAME ! 4507: DATXS DAC 0 SAVE INITIAL STACK POINTER ! 4508: * ! 4509: * WORK AREAS FOR DEFINE FUNCTION (S$DEF) ! 4510: * ! 4511: DEFLB DAC 0 SAVE VRBLK PTR FOR LABEL ! 4512: DEFNA DAC 0 COUNT FUNCTION ARGUMENTS ! 4513: DEFVR DAC 0 SAVE VRBLK PTR FOR FUNCTION NAME ! 4514: DEFXS DAC 0 SAVE INITIAL STACK POINTER ! 4515: * ! 4516: * WORK AREAS FOR DUMPR PROCEDURE ! 4517: * ! 4518: DMARG DAC 0 DUMP ARGUMENT ! 4519: DMPKB DAC B$KVT DUMMY KVBLK FOR USE IN DUMPR ! 4520: DMPKT DAC TRBKV KVVAR TRBLK POINTER ! 4521: DMPKN DAC 0 KEYWORD NUMBER (MUST FOLLOW DMPKB) ! 4522: DMPSA DAC 0 PRESERVE WA OVER PRTVL CALL ! 4523: DMPSV DAC 0 GENERAL SCRATCH SAVE ! 4524: DMVCH DAC 0 CHAIN POINTER FOR VARIABLE BLOCKS ! 4525: DMPCH DAC 0 SAVE SORTED VRBLK CHAIN POINTER ! 4526: * ! 4527: * GLOBAL LOCATIONS FOR DYNAMIC STORAGE POINTERS ! 4528: * ! 4529: DNAMB DAC 0 START OF DYNAMIC AREA ! 4530: DNAMP DAC 0 NEXT AVAILABLE LOC IN DYNAMIC AREA ! 4531: DNAME DAC 0 END OF AVAILABLE DYNAMIC AREA ! 4532: * ! 4533: * WORK AREAS FOR DUPL FUNCTION (S$DUP) ! 4534: * ! 4535: DUPSI DIC +0 STORE INTEGER STRING LENGTH ! 4536: * ! 4537: * WORK AREA FOR ENDFILE (S$ENF) ! 4538: * ! 4539: ENFCH DAC 0 FOR IOCHN CHAIN HEAD ! 4540: * ! 4541: * WORK AREA FOR ERROR PROCESSING. ! 4542: * ! 4543: EROSN DAC 0 FLAG FOR SPECIAL EROSI RETURN ! 4544: ERRFT DAC 0 FATAL ERROR FLAG ! 4545: ERRSP DAC 0 ERROR SUPPRESSION FLAG ! 4546: EJC ! 4547: * ! 4548: * DUMP AREA FOR ERTEX ! 4549: * ! 4550: ERTWA DAC 0 SAVE WA ! 4551: ERTWB DAC 0 SAVE WB ! 4552: * ! 4553: * GLOBAL VALUES FOR EVALI ! 4554: * ! 4555: EVLIN DAC P$LEN DUMMY PATTERN BLOCK PCODE ! 4556: EVLIS DAC 0 POINTER TO SUBSEQUENT NODE ! 4557: EVLIV DAC 0 VALUE OF PARAMETER ! 4558: * ! 4559: * WORK AREA FOR EXPAN ! 4560: * ! 4561: EXPSV DAC 0 SAVE OP DOPE VECTOR POINTER ! 4562: * ! 4563: * FLAG FOR SUPPRESSION OF EXECUTION STATS ! 4564: * ! 4565: EXSTS DAC 0 SUPPRESS EXEC STATS IF SET ! 4566: * ! 4567: * GLOBAL VALUES FOR EXFAL AND RETURN ! 4568: * ! 4569: FLPRT DAC 0 LOCATION OF FAIL OFFSET FOR RETURN ! 4570: FLPTR DAC 0 LOCATION OF FAILURE OFFSET ON STACK ! 4571: * ! 4572: * WORK AREAS FOR GBCOL PROCEDURE ! 4573: * ! 4574: GBCFL DAC 0 GARBAGE COLLECTOR ACTIVE FLAG ! 4575: GBCLM DAC 0 POINTER TO LAST MOVE BLOCK (PASS 3) ! 4576: GBCNM DAC 0 DUMMY FIRST MOVE BLOCK ! 4577: GBCNS DAC 0 REST OF DUMMY BLOCK (FOLLOWS GBCNM) ! 4578: GBSVA DAC 0 SAVE WA ! 4579: GBSVB DAC 0 SAVE WB ! 4580: GBSVC DAC 0 SAVE WC ! 4581: * ! 4582: * GLOBAL LOCATION TO COUNT GARBAGE COLLECTIONS (GBCOL) ! 4583: * ! 4584: GBCNT DAC 0 COUNT OF GARBAGE COLLECTIONS ! 4585: * ! 4586: * WORK AREAS FOR GTNVR PROCEDURE ! 4587: * ! 4588: GNVHE DAC 0 PTR TO END OF HASH CHAIN ! 4589: GNVNW DAC 0 NUMBER OF WORDS IN STRING NAME ! 4590: GNVSA DAC 0 SAVE WA ! 4591: GNVSB DAC 0 SAVE WB ! 4592: GNVSP DAC 0 POINTER INTO VSRCH TABLE ! 4593: GNVST DAC 0 POINTER TO CHARS OF STRING ! 4594: * ! 4595: * GLOBAL VALUE FOR GTCOD AND GTEXP ! 4596: * ! 4597: GTCEF DAC 0 SAVE FAIL PTR IN CASE OF ERROR ! 4598: * ! 4599: * WORK AREAS FOR GTINT ! 4600: * ! 4601: GTINA DAC 0 SAVE WA ! 4602: GTINB DAC 0 SAVE WB ! 4603: EJC ! 4604: * ! 4605: * WORK AREAS FOR GTNUM PROCEDURE ! 4606: * ! 4607: GTNNF DAC 0 ZERO/NONZERO FOR RESULT +/- ! 4608: GTNSI DIC +0 GENERAL INTEGER SAVE ! 4609: .IF .CNRA ! 4610: .ELSE ! 4611: GTNDF DAC 0 0/1 FOR DEC POINT SO FAR NO/YES ! 4612: GTNES DAC 0 ZERO/NONZERO EXPONENT +/- ! 4613: GTNEX DIC +0 REAL EXPONENT ! 4614: GTNSC DAC 0 SCALE (PLACES AFTER POINT) ! 4615: GTNSR DRC +0.0 GENERAL REAL SAVE ! 4616: GTNSV DIC +0 SAVE IA ! 4617: GTNRD DAC 0 FLAG FOR OK REAL NUMBER ! 4618: .FI ! 4619: * ! 4620: * WORK AREAS FOR GTPAT PROCEDURE ! 4621: * ! 4622: GTPSB DAC 0 SAVE WB ! 4623: * ! 4624: * WORK AREAS FOR GTSTG PROCEDURE ! 4625: * ! 4626: GTSSF DAC 0 0/1 FOR RESULT +/- ! 4627: GTSVC DAC 0 SAVE WC ! 4628: GTSVB DAC 0 SAVE WB ! 4629: GTSWK DAC 0 PTR TO WORK AREA FOR GTSTG ! 4630: .IF .CNRA ! 4631: .ELSE ! 4632: GTSES DAC 0 CHAR + OR - FOR EXPONENT +/- ! 4633: GTSRS DRC +0.0 GENERAL REAL SAVE ! 4634: * ! 4635: * GLOBAL LOCATIONS (CONSTANTS) FOR GTSTG PROCEDURE ! 4636: * ! 4637: GTSRN DRC +0.0 ROUNDING FACTOR 0.5*10**-CFP$S ! 4638: GTSSC DRC +0.0 SCALING VALUE 10**CFP$S ! 4639: .FI ! 4640: EJC ! 4641: * ! 4642: * WORK AREAS FOR GTVAR PROCEDURE ! 4643: * ! 4644: GTVRC DAC 0 SAVE WC ! 4645: * ! 4646: * FLAGS FOR HEADER PRINTING ! 4647: * ! 4648: HEADN DAC 0 NON-ZERO IF HDRS NOT TO BE PRINTED ! 4649: HEADP DAC 0 HEADER PRINTED FLAG ! 4650: * ! 4651: * GLOBAL VALUES FOR VARIABLE HASH TABLE ! 4652: * ! 4653: HSHNB DIC +0 NUMBER OF HASH BUCKETS ! 4654: HSHTB DAC 0 POINTER TO START OF VRBLK HASH TABL ! 4655: HSHTE DAC 0 POINTER PAST END OF VRBLK HASH TABL ! 4656: * ! 4657: * WORK AREA FOR INIT ! 4658: * ! 4659: INICD DIC +0 CODE KWD VAL (NEEDED FOR BATCH) ! 4660: INISS DAC 0 SAVE SUBROUTINE STACK PTR ! 4661: INITR DAC 0 SAVE TERMINAL FLAG ! 4662: .IF .CNBF ! 4663: .ELSE ! 4664: * ! 4665: * SAVE AREA FOR INSBF ! 4666: * ! 4667: INSAB DAC 0 ENTRY WA PLUS ENTRY WB ! 4668: INSBB DAC 0 BFBLK POINTER ! 4669: INSBC DAC 0 BCBLK POINTER ! 4670: INSSA DAC 0 SAVE ENTRY WA ! 4671: INSSB DAC 0 SAVE ENTRY WB ! 4672: .FI ! 4673: * ! 4674: * WORK AREAS FOR IOPUT ! 4675: * ! 4676: IOPNF DAC 0 NAME OFFSET ! 4677: IOPVR DAC 0 FILETAG VRBLK ! 4678: IOPWA DAC 0 KEEP WA ! 4679: IOPWB DAC 0 KEEP WB ! 4680: IOPWC DAC 0 KEEP WC ! 4681: EJC ! 4682: * ! 4683: * GLOBAL VALUES FOR KEYWORD VALUES WHICH ARE STORED AS ONE ! 4684: * WORD INTEGERS. THESE VALUES MUST BE ASSEMBLED IN THE ! 4685: * FOLLOWING ORDER (AS DICTATED BY K$XXX DEFINITION VALUES). ! 4686: * ! 4687: KVANC DAC 0 ANCHOR ! 4688: KVDMP DAC 0 DUMP ! 4689: KVERL DAC 0 ERRLIMIT ! 4690: KVERT DAC 0 ERRTYPE ! 4691: KVFTR DAC 0 FTRACE ! 4692: KVINP DAC 1 INPUT ! 4693: KVMXL DAC 5000 MAXLENGTH ! 4694: KVOUP DAC 1 OUTPUT ! 4695: .IF .CNPF ! 4696: .ELSE ! 4697: KVPFL DAC 0 PROFILE ! 4698: .FI ! 4699: KVTRA DAC 0 TRACE ! 4700: KVTRM DAC 0 TRIM ! 4701: KVFNC DAC 0 FNCLEVEL ! 4702: KVLST DAC 0 LASTNO ! 4703: KVSTN DAC 0 STNO ! 4704: * ! 4705: * GLOBAL VALUES FOR OTHER KEYWORDS ! 4706: * ! 4707: KVALP DAC 0 ALPHABET ! 4708: KVRTN DAC NULLS RTNTYPE (SCBLK POINTER) ! 4709: KVCOD DIC 0 CODE ! 4710: .IF .CS16 ! 4711: KVSTL DIC +32767 STLIMIT ! 4712: KVSTC DIC +32767 STCOUNT (COUNTS DOWN FROM STLIMIT) ! 4713: .ELSE ! 4714: KVSTL DIC +50000 STLIMIT ! 4715: KVSTC DIC +50000 STCOUNT (COUNTS DOWN FROM STLIMIT) ! 4716: .FI ! 4717: .IF .CNLD ! 4718: .ELSE ! 4719: * ! 4720: * WORK AREAS FOR LOAD FUNCTION ! 4721: * ! 4722: LODFN DAC 0 POINTER TO VRBLK FOR FUNC NAME ! 4723: LODNA DAC 0 COUNT NUMBER OF ARGUMENTS ! 4724: .FI ! 4725: EJC ! 4726: * ! 4727: * GLOBAL VALUES FOR LISTR PROCEDURE ! 4728: * ! 4729: LSTLC DAC 0 COUNT LINES ON SOURCE LIST PAGE ! 4730: LSTNP DAC 0 MAX NUMBER OF LINES ON PAGE ! 4731: LSTPF DAC 1 SET NONZERO IF CURRENT IMAGE LISTED ! 4732: LSTPG DAC 0 CURRENT SOURCE LIST PAGE NUMBER ! 4733: LSTPO DAC 0 OFFSET TO PAGE NNN MESSAGE ! 4734: LSTSN DAC 0 REMEMBER LAST STMNUM LISTED ! 4735: * ! 4736: * MAXIMUM SIZE OF SPITBOL OBJECTS ! 4737: * ! 4738: MXLEN DAC 0 INITIALISED BY SYSMX CALL ! 4739: * ! 4740: * EXECUTION CONTROL VARIABLE ! 4741: * ! 4742: NOXEQ DAC 0 SET NON-ZERO TO INHIBIT EXECUTION ! 4743: .IF .CNPF ! 4744: .ELSE ! 4745: * ! 4746: * PROFILER GLOBAL VALUES AND WORK LOCATIONS ! 4747: * ! 4748: PFDMP DAC 0 SET NON-0 IF PROFILE SET NON-0 ! 4749: PFFNC DAC 0 SET NON-0 IF FUNCT JUST ENTERED ! 4750: PFSTM DIC +0 TO STORE STARTING TIME OF STMT ! 4751: PFETM DIC +0 TO STORE ENDING TIME OF STMT ! 4752: PFSVW DAC 0 TO SAVE A W-REG ! 4753: PFTBL DAC 0 GETS ADRS OF (IMAG) TABLE BASE ! 4754: PFNTE DAC 0 NR OF TABLE ENTRIES ! 4755: PFSTE DIC +0 TABLE ENTRY SIZE IN BAUS ! 4756: .FI ! 4757: EJC ! 4758: * ! 4759: * GLOBAL VALUES USED IN PATTERN MATCH ROUTINES ! 4760: * ! 4761: PMDFL DAC 0 PATTERN ASSIGNMENT FLAG ! 4762: PMHBS DAC 0 HISTORY STACK BASE POINTER ! 4763: PMSSL DAC 0 LENGTH OF SUBJECT STRING IN CHARS ! 4764: * ! 4765: * GLOBAL VALUE FOR PRTNM PROCEDURE ! 4766: * ! 4767: PRNMV DAC 0 VRBLK PTR FROM LAST NAME SEARCH ! 4768: * ! 4769: * WORK AREAS FOR PRTNM PROCEDURE ! 4770: * ! 4771: PRNSI DIC +0 SCRATCH INTEGER LOC ! 4772: * ! 4773: * WORK AREAS FOR PRTSN PROCEDURE ! 4774: * ! 4775: PRSNA DAC 0 SAVE WA ! 4776: * ! 4777: * GLOBAL VALUES FOR PRINT PROCEDURES ! 4778: * ! 4779: PRAVL DAC 0 SET IF PRINT FILE AVAILABLE ! 4780: PRBLK DAC 0 ADDRESS OF BUFFER BLANKING STRING ! 4781: PRBUF DAC 0 PTR TO PRINT BFR IN STATIC ! 4782: PRCHS DAC 0 ADDRESS OF CHARS IN PRINT BUFFER ! 4783: PRCMV DAC 0 NO. OF BAUS TO MOVE IN BFR CLEARING ! 4784: PRECL DAC 0 EXTENDED/COMPACT LISTING FLAG ! 4785: PRLEN DAC 0 LENGTH OF PRINT BUFFER IN CHARS ! 4786: PROFS DAC 0 OFFSET TO NEXT LOCATION IN PRBUF ! 4787: PRPUT DAC 0 SET IF CHARS TO BE PUT IN BFR ! 4788: PRSTD DAC 0 TESTED BY PRTPG ! 4789: PRSTO DAC 0 STANDARD LISTING OPTION FLAG ! 4790: PRTEF DAC 0 ENDFILE FLAG ! 4791: * ! 4792: * WORK AREAS FOR PRTST, PTTST PROCEDURES ! 4793: * ! 4794: PRSVA DAC 0 SAVE WA ! 4795: PRSVB DAC 0 SAVE WB ! 4796: PRTVA DAC 0 SAVE WA ! 4797: PRTVB DAC 0 SAVE WB ! 4798: * ! 4799: * WORK AREA FOR PRTVL ! 4800: * ! 4801: PRVSI DAC 0 SAVE IDVAL ! 4802: * ! 4803: * WORK AREAS FOR PATTERN MATCH ROUTINES ! 4804: * ! 4805: PSAVE DAC 0 TEMPORARY SAVE FOR CURRENT NODE PTR ! 4806: PSAVC DAC 0 SAVE CURSOR IN P$SPN, P$STR ! 4807: EJC ! 4808: * ! 4809: * FLAG TO TELL ERROR THAT WE ARE READING SOURCE LINE ! 4810: * ! 4811: RDRER DAC 0 READ-SOURCE-LINE IN PROGRESS FLAG ! 4812: * ! 4813: * AMOUNT OF MEMORY RESERVED FOR END OF EXECUTION ! 4814: * ! 4815: RSMEM DAC 0 RESERVE MEMORY ! 4816: * ! 4817: * WORK AREAS FOR RETRN ROUTINE ! 4818: * ! 4819: RTNBP DAC 0 TO SAVE A BLOCK POINTER ! 4820: RTNFV DAC 0 NEW FUNCTION VALUE (RESULT) ! 4821: RTNSV DAC 0 OLD FUNCTION VALUE (SAVED VALUE) ! 4822: * ! 4823: * RELOCATABLE GLOBAL VALUES ! 4824: * ! 4825: * ALL THE POINTERS IN THIS SECTION CAN POINT TO BLOCKS IN ! 4826: * THE DYNAMIC STORAGE AREA AND MUST BE RELOCATED BY THE ! 4827: * GARBAGE COLLECTOR. THEY ARE IDENTIFIED BY R$XXX NAMES. ! 4828: * ! 4829: R$AAA DAC 0 START OF RELOCATABLE VALUES ! 4830: R$ARF DAC 0 ARRAY BLOCK POINTER FOR ARREF ! 4831: R$CCB DAC 0 PTR TO CCBLK BEING BUILT (CDWRD) ! 4832: R$CIM DAC 0 PTR TO CURRENT COMPILER INPUT STR ! 4833: R$CMP DAC 0 COPY OF R$CIM USED IN CMPIL ! 4834: R$CNI DAC 0 PTR TO NEXT COMPILER INPUT STRING ! 4835: R$CNT DAC 0 CDBLK POINTER FOR SETEXIT CONTINUE ! 4836: R$COD DAC 0 POINTER TO CURRENT CDBLK OR EXBLK ! 4837: R$COP DAC 0 PTR TO -COPY CHAIN STACK ! 4838: R$CTP DAC 0 PTR TO CURRENT CTBLK FOR PATST ! 4839: R$ERT DAC 0 TRBLK POINTER FOR ERRTYPE TRACE ! 4840: R$ETX DAC NULLS POINTER TO ERRTEXT STRING ! 4841: R$EXS DAC 0 = SAVE XL IN EXPDM ! 4842: R$FNC DAC 0 TRBLK POINTER FOR FNCLEVEL TRACE ! 4843: R$GTC DAC 0 KEEP CODE PTR FOR GTCOD,GTEXP ! 4844: R$IO1 DAC 0 FIRST ARGUMENT ! 4845: R$IOL DAC 0 SECOND ARGUMENT (FILETAG) SCBLK PTR ! 4846: R$IOR DAC 0 FILEPROPS SCBLK PTR ! 4847: R$IOT DAC 0 TRTIO TRACE BLK PTR ! 4848: .IF .CNBF ! 4849: .ELSE ! 4850: R$PMB DAC 0 BUFFER PTR IN PATTERN MATCH ! 4851: .FI ! 4852: R$PMS DAC 0 SUBJECT STRING PTR IN PATTERN MATCH ! 4853: R$RA2 DAC 0 REPLACE SECOND ARGUMENT LAST TIME ! 4854: R$RA3 DAC 0 REPLACE THIRD ARGUMENT LAST TIME ! 4855: R$RPT DAC 0 PTR TO CTBLK REPLACE TABLE LAST USD ! 4856: R$SCP DAC 0 SAVE POINTER FROM LAST SCANE CALL ! 4857: R$SXL DAC 0 PRESERVE XL IN SORTC ! 4858: R$SXR DAC 0 PRESERVE XR IN SORTA/SORTC ! 4859: R$STC DAC 0 TRBLK POINTER FOR STCOUNT TRACE ! 4860: R$STL DAC 0 SOURCE LISTING SUB-TITLE ! 4861: R$SXC DAC 0 CODE (CDBLK) PTR FOR SETEXIT TRAP ! 4862: R$TTL DAC NULLS SOURCE LISTING TITLE ! 4863: R$XSC DAC 0 STRING POINTER FOR XSCAN ! 4864: EJC ! 4865: * ! 4866: * THE REMAINING POINTERS IN THIS LIST ARE USED TO POINT ! 4867: * TO FUNCTION BLOCKS FOR NORMALLY UNDEFINED OPERATORS. ! 4868: * ! 4869: R$UBA DAC STNDO BINARY AT ! 4870: R$UBM DAC STNDO BINARY AMPERSAND ! 4871: R$UBN DAC STNDO BINARY NUMBER SIGN ! 4872: R$UBP DAC STNDO BINARY PERCENT ! 4873: R$UBT DAC STNDO BINARY NOT ! 4874: R$UUB DAC STNDO UNARY VERTICAL BAR ! 4875: R$UUE DAC STNDO UNARY EQUAL ! 4876: R$UUN DAC STNDO UNARY NUMBER SIGN ! 4877: R$UUP DAC STNDO UNARY PERCENT ! 4878: R$UUS DAC STNDO UNARY SLASH ! 4879: R$UUX DAC STNDO UNARY EXCLAMATION ! 4880: R$YYY DAC 0 LAST RELOCATABLE LOCATION ! 4881: * ! 4882: * WORK AREAS FOR SUBSTR FUNCTION (S$SUB) ! 4883: * ! 4884: SBSSV DAC 0 SAVE THIRD ARGUMENT ! 4885: * ! 4886: * GLOBAL LOCATIONS USED IN SCAN PROCEDURE ! 4887: * ! 4888: SCNBL DAC 0 SET NON-ZERO IF SCANNED PAST BLANKS ! 4889: SCNCC DAC 0 NON-ZERO TO SCAN CONTROL CARD NAME ! 4890: SCNGO DAC 0 SET NON-ZERO TO SCAN GOTO FIELD ! 4891: SCNIL DAC 0 LENGTH OF CURRENT INPUT IMAGE ! 4892: SCNPT DAC 0 POINTER TO NEXT LOCATION IN R$CIM ! 4893: SCNRS DAC 0 SET NON-ZERO TO SIGNAL RESCAN ! 4894: SCNTP DAC 0 SAVE SYNTAX TYPE FROM LAST CALL ! 4895: * ! 4896: * WORK AREAS FOR SCAN PROCEDURE ! 4897: * ! 4898: SCNSA DAC 0 SAVE WA ! 4899: SCNSB DAC 0 SAVE WB ! 4900: SCNSC DAC 0 SAVE WC ! 4901: SCNSE DAC 0 START OF CURRENT ELEMENT ! 4902: SCNOF DAC 0 SAVE OFFSET ! 4903: * ! 4904: * WORK AREA FOR DETACH PROCEDURE ! 4905: * ! 4906: SDETF DAC 0 TRACE BLOCK FLAG ! 4907: * ! 4908: * WORK AREA FOR ENDFILE PROCEDURE ! 4909: * ! 4910: SENFR DAC 0 SAVE XR ! 4911: .IF .CNSR ! 4912: .ELSE ! 4913: EJC ! 4914: * ! 4915: * WORK AREA USED BY SORTA, SORTC, SORTF, SORTH ! 4916: * ! 4917: SRTDF DAC 0 DATATYPE FIELD NAME ! 4918: SRTFD DAC 0 FOUND DFBLK ADDRESS ! 4919: SRTFF DAC 0 FOUND FIELD NAME ! 4920: SRTFO DAC 0 OFFSET TO FIELD NAME ! 4921: SRTNR DAC 0 NUMBER OF ROWS ! 4922: SRTOF DAC 0 OFFSET WITHIN ROW TO SORT KEY ! 4923: SRTRT DAC 0 ROOT OFFSET ! 4924: SRTS1 DAC 0 SAVE OFFSET 1 ! 4925: SRTS2 DAC 0 SAVE OFFSET 2 ! 4926: SRTSC DAC 0 SAVE WC ! 4927: SRTSF DAC 0 SORT ARRAY FIRST ROW OFFSET ! 4928: SRTSN DAC 0 SAVE N ! 4929: SRTSO DAC 0 OFFSET TO A(0) ! 4930: SRTSR DAC 0 0 , NON-ZERO FOR SORT, RSORT ! 4931: SRTST DAC 0 STRIDE FROM ONE ROW TO NEXT ! 4932: SRTWC DAC 0 DUMP WC ! 4933: .FI ! 4934: * ! 4935: * VALUES FOR INDICATING COMPILATION/EXECUTION STAGE ! 4936: * ! 4937: STAGE DAC 0 INITIAL VALUE = INITIAL COMPILE ! 4938: STAGX DAC 0 NON-ZERO IF EXECUTING ! 4939: * ! 4940: * GLOBAL VALUES DEFINING EXTENT OF STATIC AREA (ALOST) ! 4941: * ! 4942: STATB DAC 0 START OF STATIC AREA ! 4943: STATE DAC 0 END OF STATIC AREA ! 4944: EJC ! 4945: * ! 4946: * GLOBAL STACK POINTER ! 4947: * ! 4948: STBAS DAC 0 POINTER PAST STACK BASE ! 4949: * ! 4950: * WORK AREAS FOR STOPR ROUTINE ! 4951: * ! 4952: STPSI DIC +0 SAVE VALUE OF STCOUNT ! 4953: STPTI DIC +0 SAVE TIME ELAPSED ! 4954: STPXR DAC 0 SAVE XR ! 4955: * ! 4956: * GLOBAL VALUES FOR SETEXIT FUNCTION (S$STX) ! 4957: * ! 4958: STXOF DAC 0 FAILURE OFFSET ! 4959: STXVR DAC NULLS VRBLK POINTER OR NULL ! 4960: * ! 4961: * WORK AREAS FOR TFIND PROCEDURE ! 4962: * ! 4963: TFNSI DIC +0 NUMBER OF HEADERS ! 4964: * ! 4965: * GLOBAL VALUE FOR TIME KEEPING ! 4966: * ! 4967: TIMSX DIC +0 TIME AT START OF EXECUTION ! 4968: * ! 4969: * TERMINAL BUFFER ADDRESSES, FLAGS ETC ! 4970: * ! 4971: TTBLK DAC 0 BLANKING STRING ADRS ! 4972: TTBUF DAC 0 BUFFER ADRS ! 4973: TTCHS DAC 0 START OF BUFFER CHARACTERS ! 4974: TTCMV DAC 0 COUNT OF BLANKING CHARS TO MOVE ! 4975: TTERL DAC 0 ERROR FLAG ! 4976: TTINS DAC 0 NON-ZERO IF STD INPUT FROM TERML ! 4977: TTLEN DAC 0 LENGTH OF TERMINAL BUFFER ! 4978: TTLST DAC 0 COPY STD O/P TO TERML IF SET ! 4979: TTOFS DAC 0 OFFSET TO POSITION IN TERML BFR ! 4980: TTOUS DAC 0 SET IF STD OUTPUT TO TERMINAL ! 4981: * ! 4982: * WORK AREAS FOR XSCAN PROCEDURE ! 4983: * ! 4984: XSCBL DAC 0 COUNT OF TRAILING BLANKS ! 4985: XSCNB DAC 0 NON-ZERO IF NON-BLANKS SEEN ! 4986: XSCRT DAC 0 SAVE RETURN CODE ! 4987: XSCWB DAC 0 SAVE REGISTER WB ! 4988: * ! 4989: * GLOBAL VALUES FOR XSCAN AND XSCNI PROCEDURES ! 4990: * ! 4991: XSOFS DAC 0 OFFSET TO CURRENT LOCATION IN R$XSC ! 4992: * ! 4993: * LABEL TO MARK END OF WORK AREA ! 4994: * ! 4995: YYYYY DAC 0 ! 4996: TTL S P I T B O L -- INITIALIZATION ! 4997: * ! 4998: * INITIALISATION ! 4999: * THE FOLLOWING SECTION RECEIVES CONTROL FROM THE SYSTEM ! 5000: * AT THE START OF A RUN WITH THE REGISTERS SET AS FOLLOWS. ! 5001: * ! 5002: * (XS) POINTS PAST STACK BASE ! 5003: * (XR) POINTS TO FIRST WORD OF DATA AREA ! 5004: * (XL) POINTS TO LAST WORD OF DATA AREA ! 5005: * (WA) INITIAL &CODE VALUE ! 5006: * ! 5007: SEC START OF PROGRAM SECTION ! 5008: * ! 5009: INITL RTN INITIALISATION CODE ! 5010: MOV WA,INICD SAVE INITIAL CODE KYWD VALUE ! 5011: .IF .CNBT ! 5012: MOV XR,STATB START ADDRESS OF STATIC ! 5013: .ELSE ! 5014: * ! 5015: * INITIALISE WORK AREA (ESSENTIAL FOR BATCHED RUNS) ! 5016: * ! 5017: MOV XR,WB PRESERVE XR ! 5018: MOV =YYYYY,WA POINT TO END OF WORK AREA ! 5019: SUB =AAAAA,WA GET LENGTH OF WORK AREA ! 5020: BTW WA CONVERT TO WORDS ! 5021: LCT WA,WA COUNT FOR LOOP ! 5022: MOV =AAAAA,XR SET UP INDEX REGISTER ! 5023: * ! 5024: * CLEAR WORK SPACE ! 5025: * ! 5026: INI01 ZER (XR)+ CLEAR A WORD ! 5027: BCT WA,INI01 LOOP TILL DONE ! 5028: MOV =STNDO,WA UNDEFINED OPERATORS POINTER ! 5029: MOV =R$YYY,WC POINT TO TABLE END ! 5030: SUB =R$UBA,WC LENGTH OF UNDEF. OPERATORS TABLE ! 5031: BTW WC CONVERT TO WORDS ! 5032: LCT WC,WC LOOP COUNTER ! 5033: MOV =R$UBA,XR SET UP XR ! 5034: * ! 5035: * SET CORRECT VALUE INTO UNDEFINED OPERATORS TABLE ! 5036: * ! 5037: INI02 MOV WA,(XR)+ STORE VALUE ! 5038: BCT WC,INI02 LOOP TILL ALL DONE ! 5039: MOV =NUM01,WA GET A 1 ! 5040: MOV WA,CMPSN STATEMENT NO ! 5041: MOV WA,CSWFL NOFAIL ! 5042: MOV WA,CSWLS LIST ! 5043: MOV WA,KVINP INPUT ! 5044: MOV WA,KVOUP OUTPUT ! 5045: MOV WA,LSTPF NOTHING FOR LISTR YET ! 5046: MOV =INILN,WA INPUT IMAGE LENGTH ! 5047: MOV WA,CSWIN STORE FOR LATER USE ! 5048: MOV =B$KVT,DMPKB DUMP ! 5049: MOV =TRBKV,DMPKT DUMP ! 5050: MOV =P$LEN,EVLIN EVAL ! 5051: EJC ! 5052: MOV =NULLS,WA GET NULLSTRING POINTER ! 5053: MOV WA,KVRTN RETURN ! 5054: MOV WA,R$ETX ERRTEXT ! 5055: MOV WA,R$TTL TITLE FOR LISTING ! 5056: MOV WA,STXVR SETEXIT ! 5057: LDI STLIM GET DEFAULT STLIMIT ! 5058: STI KVSTL STATEMENT LIMIT ! 5059: STI KVSTC STATEMENT COUNT ! 5060: MOV WB,STATB STORE START ADRS OF STATIC ! 5061: .FI ! 5062: .IF .CSIG ! 5063: MNZ CSWCI -CASEIG ! 5064: .FI ! 5065: JSR SYSTM INITIALISE TIMER ! 5066: STI TIMSX STORE TIME ! 5067: LDI INICD LOAD INITIAL CODE KWD VALUE ! 5068: STI KVCOD STORE ! 5069: MOV *E$SRS,RSMEM RESERVE MEMORY ! 5070: MOV XS,STBAS STORE STACK BASE ! 5071: SSS INISS SAVE S-R STACK PTR ! 5072: * ! 5073: * NOW CONVERT FREE STORE PERCENTAGE TO A SUITABLE FACTOR ! 5074: * FOR EASY TESTING IN ALLOC ROUTINE. ! 5075: * ! 5076: LDI INTVH GET 100 ! 5077: DVI ALFSP FORM 100 / ALFSP ! 5078: STI ALFSF STORE THE FACTOR ! 5079: .IF .CNRA ! 5080: .ELSE ! 5081: * ! 5082: * INITIALIZE VALUES FOR REAL CONVERSION ROUTINE ! 5083: * ! 5084: LCT WB,=CFP$S LOAD COUNTER FOR SIGNIFICANT DIGITS ! 5085: LDR REAV1 LOAD 1.0 ! 5086: * ! 5087: * LOOP TO COMPUTE 10**(MAX NUMBER SIGNIFICANT DIGITS) ! 5088: * ! 5089: INI03 MLR REAVT * 10.0 ! 5090: BCT WB,INI03 LOOP TILL DONE ! 5091: STR GTSSC STORE 10**(MAX SIG DIGITS) ! 5092: LDR REAP5 LOAD 0.5 ! 5093: DVR GTSSC COMPUTE 0.5*10**(MAX SIG DIGITS) ! 5094: STR GTSRN STORE AS ROUNDING BIAS ! 5095: .FI ! 5096: ZER WC SET TO READ PARAMETERS ! 5097: JSR PRPAR READ THEM ! 5098: EJC ! 5099: * ! 5100: * NOW COMPUTE STARTING ADDRESS FOR DYNAMIC STORE AND IF ! 5101: * NECESSARY REQUEST MORE MEMORY. ! 5102: * ! 5103: SUB *E$SRS,XL ALLOW FOR RESERVE MEMORY ! 5104: MOV PRLEN,WA GET PRINT BUFFER LENGTH ! 5105: ADD TTLEN,WA ADD TERMINAL BUFFER LENGTH ! 5106: ADD WA,WA ALLOW FOR EQUALLY BIG BLANK STRINGS ! 5107: ADD =CFP$A,WA ADD NO. OF CHARS IN ALPHABET ! 5108: ADD =NSTMX,WA ADD CHARS FOR GTSTG BFR ! 5109: CTB WA,8 CONVERT TO BAUS, ALLOWING A MARGIN ! 5110: MOV STATB,XR POINT TO STATIC BASE ! 5111: ADD WA,XR INCREMENT FOR ABOVE BUFFERS ! 5112: ADD *E$HNB,XR INCREMENT FOR HASH TABLE ! 5113: ADD *E$STS,XR BUMP FOR INITIAL STATIC BLOCK ! 5114: JSR SYSMX GET MXLEN ! 5115: MOV WA,KVMXL PROVISIONALLY STORE AS MAXLNGTH ! 5116: MOV WA,MXLEN AND AS MXLEN ! 5117: BGT XR,WA,INI05 SKIP IF STATIC HI EXCEEDS MXLEN ! 5118: MOV WA,XR USE MXLEN INSTEAD ! 5119: ICA XR MAKE BIGGER THAN MXLEN ! 5120: * ! 5121: * HERE TO STORE VALUES WHICH MARK INITIAL DIVISION ! 5122: * OF DATA AREA INTO STATIC AND DYNAMIC ! 5123: * ! 5124: INI05 MOV XR,DNAMB DYNAMIC BASE ADRS ! 5125: MOV XR,DNAMP DYNAMIC PTR ! 5126: BNZ WA,INI06 SKIP IF NON-ZERO MXLEN ! 5127: DCA XR POINT A WORD IN FRONT ! 5128: MOV XR,KVMXL USE AS MAXLNGTH ! 5129: MOV XR,MXLEN AND AS MXLEN ! 5130: * ! 5131: * LOOP HERE IF NECESSARY TILL ENOUGH MEMORY OBTAINED ! 5132: * SO THAT DNAME IS ABOVE DNAMB ! 5133: * ! 5134: INI06 MOV XL,DNAME STORE DYNAMIC END ADDRESS ! 5135: BLT DNAMB,XL,INI08 SKIP IF HIGH ENOUGH ! 5136: JSR SYSMM REQUEST MORE MEMORY ! 5137: WTB XR CONVERT TO BAUS ! 5138: ADD XR,XL BUMP BY AMOUNT OBTAINED ! 5139: BNZ XR,INI06 TRY AGAIN ! 5140: MOV =ENDMO,XR POINT TO FAILURE MESSAGE ! 5141: MOV ENDML,WC MESSAGE LENGTH ! 5142: JSR SYSPR PRINT IT (PRTST NOT YET USABLE) ! 5143: PPM INI07 ! 5144: PPM INI07 ! 5145: * ! 5146: * EMERGENCY SHUTDOWN ! 5147: * ! 5148: INI07 MOV =KVCOD,WA CODE KEYWORD ! 5149: JSR SYSEJ PACK UP (STOPR NOT YET USABLE) ! 5150: EJC ! 5151: * ! 5152: * INITIALISE PRINT BUFFER WITH BLANK WORDS ! 5153: * ! 5154: INI08 MOV PRLEN,WA NO. OF CHARS IN PRINT BFR ! 5155: MOV STATB,XR POINT TO STATIC AGAIN ! 5156: MOV XR,PRBUF PRINT BFR IS PUT AT STATIC START ! 5157: MOV =B$SCL,(XR)+ STORE STRING TYPE CODE ! 5158: MOV WA,(XR)+ AND STRING LENGTH ! 5159: MOV XR,PRCHS KEEP ADRS OF BUFFER PROPER ! 5160: MOV XR,XL COPY IT ! 5161: CTB WA,0 WORDS NEEDED EXPRESSED IN BAUS ! 5162: MOV WA,PRCMV KEEP FOR CLEARING BUFFER ! 5163: MOV XR,PRBLK CONSTRUCT ADRS OF BLANKING STRING ! 5164: ADD WA,PRBLK ADD OFFSET TO BLANKING STRING ! 5165: ADD WA,WA CLEAR BOTH BFR AND BLANKING STRING ! 5166: MOV NULLW,(XR)+ CLEAR FIRST WORD ! 5167: BZE WA,INI09 SKIP IF NO PRINT BUFFER ! 5168: DCA WA ADJUST FOR FIRST WORD ! 5169: MVW PERFORM BLANKING ! 5170: * ! 5171: * SET UP TERMINAL BUFFER ! 5172: * ! 5173: INI09 MOV TTLEN,WA LENGTH OF TERMINAL BUFFER ! 5174: MOV XR,TTBUF ADRS OF TERMINAL STRING BUFFER ! 5175: MOV =B$SCL,(XR)+ STRING TYPE CODE ! 5176: MOV WA,(XR)+ STRING LENGTH ! 5177: MOV XR,TTCHS KEEP ADRS OF BUFFER PROPER ! 5178: MOV XR,XL COPY IT ! 5179: CTB WA,0 WORDS NEEDED EXPRESSED IN BAUS ! 5180: MOV WA,TTCMV KEEP FOR CLEARING BUFFER ! 5181: MOV XR,TTBLK CONSTRUCT ADRS OF BLANKING STRING ! 5182: ADD WA,TTBLK ADD OFFSET TO BLANKING STRING ! 5183: ADD WA,WA CLEAR BOTH BFR AND BLANKING STRING ! 5184: MOV NULLW,(XR)+ CLEAR FIRST WORD ! 5185: BZE WA,INI10 SKIP IF NO PRINT BUFFER ! 5186: DCA WA ADJUST FOR FIRST WORD ! 5187: MVW PERFORM BLANKING ! 5188: * ! 5189: * INITIALIZE NUMBER OF HASH HEADERS ! 5190: * ! 5191: INI10 MOV =E$HNB,WA GET NUMBER OF HASH HEADERS ! 5192: MTI WA CONVERT TO INTEGER ! 5193: STI HSHNB STORE FOR USE BY GTNVR PROCEDURE ! 5194: LCT WA,WA COUNTER FOR CLEARING HASH TABLE ! 5195: MOV XR,HSHTB POINTER TO HASH TABLE ! 5196: * ! 5197: * LOOP TO CLEAR HASH TABLE ! 5198: * ! 5199: INI11 ZER (XR)+ BLANK A WORD ! 5200: BCT WA,INI11 LOOP ! 5201: MOV XR,HSHTE END OF HASH TABLE ADRS IS KEPT ! 5202: * ! 5203: * ALLOCATE WORK AREA FOR GTSTG CONVERSION PROCEDURE ! 5204: * ! 5205: MOV =NSTMX,WA GET MAX NUM CHARS IN OUTPUT NUMBER ! 5206: CTB WA,SCSI$ NO OF BAUS NEEDED ! 5207: MOV XR,GTSWK STORE BFR ADRS ! 5208: ADD WA,XR BUMP FOR WORK BFR ! 5209: EJC ! 5210: * ! 5211: * BUILD ALPHABET STRING FOR ALPHABET KEYWORD AND REPLACE ! 5212: * ! 5213: MOV XR,KVALP SAVE ALPHABET POINTER ! 5214: MOV =B$SCL,(XR) STRING BLK TYPE ! 5215: MOV =CFP$A,WC NO OF CHARS IN ALPHABET ! 5216: MOV WC,SCLEN(XR) STORE AS STRING LENGTH ! 5217: MOV WC,WB COPY CHAR COUNT ! 5218: CTB WB,SCSI$ NO. OF BAUS NEEDED ! 5219: ADD XR,WB CURRENT END ADDRESS FOR STATIC ! 5220: MOV WB,STATE STORE STATIC END ADRS ! 5221: LCT WC,WC LOOP COUNTER ! 5222: PSC XR POINT TO CHARS OF STRING ! 5223: ZER WB SET INITIAL CHARACTER VALUE ! 5224: * ! 5225: * LOOP TO ENTER CHARACTER CODES IN ORDER ! 5226: * ! 5227: INI12 SCH WB,(XR)+ STORE NEXT CODE ! 5228: ICV WB BUMP CODE VALUE ! 5229: BCT WC,INI12 LOOP TILL ALL STORED ! 5230: CSC XR COMPLETE STORE CHARACTERS ! 5231: * ! 5232: * INITIALIZE VARIABLE BLOCKS FOR INPUT OUTPUT TERMINAL ! 5233: * ! 5234: MOV =V$INP,XL POINT TO STRING /INPUT/ ! 5235: MOV =TRTIN,WB TRBLK TYPE FOR INPUT ! 5236: JSR INOUT PERFORM INPUT ASSOCIATION ! 5237: MOV =V$OUP,XL POINT TO STRING /OUTPUT/ ! 5238: MOV =TRTOU,WB TRBLK TYPE FOR OUTPUT ! 5239: JSR INOUT PERFORM OUTPUT ASSOCIATION ! 5240: BZE TTLEN,INI13 SKIP IF NO TERMINAL I/O ! 5241: MOV =V$TER,XL POINT TO STRING /TERMINAL/ ! 5242: MOV =TRTOU,WB TRTYP FOR OUTPUT ! 5243: JSR INOUT PERFORM ASSOCIATION ! 5244: MOV =V$TER,XL ! 5245: MOV =TRTIN,WB TRTYP FOR INPUT ! 5246: JSR INOUT PERFORM ASSOCIATION ! 5247: EJC ! 5248: * ! 5249: * ! 5250: * PREPARE FOR COMPILATION ! 5251: * ! 5252: INI13 MOV XS,FLPTR IN CASE STACK OVERFLOWS IN COMPILER ! 5253: * ! 5254: * NOW COMPILE SOURCE INPUT CODE ! 5255: * ! 5256: JSR CMPIL CALL COMPILER ! 5257: MOV XR,R$COD SET PTR TO FIRST CODE BLOCK ! 5258: MOV =NULLS,R$TTL FORGET TITLE ! 5259: MOV =NULLS,R$STL FORGET SUB-TITLE ! 5260: ZER R$CIM FORGET COMPILER INPUT IMAGE ! 5261: ZER XL CLEAR DUD VALUE ! 5262: ZER WB DONT SHIFT DYNAMIC STORE UP ! 5263: JSR GBCOL CLEAR GARBAGE LEFT FROM COMPILE ! 5264: BNZ CPSTS,INIX1 SKIP IF NO LISTING OF COMP STATS ! 5265: JSR PRTPG EJECT PAGE ! 5266: * ! 5267: * PRINT COMPILE STATISTICS ! 5268: * ! 5269: MOV DNAMP,WA NEXT AVAILABLE LOC ! 5270: SUB STATB,WA MINUS START ! 5271: BTW WA CONVERT TO WORDS ! 5272: MTI WA CONVERT TO INTEGER ! 5273: MOV =ENCM1,XR POINT TO /MEMORY USED (WORDS)/ ! 5274: JSR PRTMI PRINT MESSAGE ! 5275: MOV DNAME,WA END OF MEMORY ! 5276: SUB DNAMP,WA MINUS NEXT AVAILABLE LOC ! 5277: BTW WA CONVERT TO WORDS ! 5278: MTI WA CONVERT TO INTEGER ! 5279: MOV =ENCM2,XR POINT TO /MEMORY AVAILABLE (WORDS)/ ! 5280: JSR PRTMI PRINT LINE ! 5281: MTI CMERC GET COUNT OF ERRORS AS INTEGER ! 5282: MOV =ENCM3,XR POINT TO /COMPILE ERRORS/ ! 5283: JSR PRTMI PRINT IT ! 5284: MTI GBCNT GARBAGE COLLECTION COUNT ! 5285: SBI INTV1 ADJUST FOR UNAVOIDABLE COLLECT ! 5286: MOV =STPM5,XR POINT TO /STORAGE REGENERATIONS/ ! 5287: JSR PRTMI PRINT GBCOL COUNT ! 5288: JSR SYSTM GET TIME ! 5289: SBI TIMSX GET COMPILATION TIME ! 5290: MOV =ENCM4,XR POINT TO COMPILATION TIME (MSEC)/ ! 5291: JSR PRTMI PRINT MESSAGE ! 5292: ADD =NUM05,LSTLC BUMP LINE COUNT ! 5293: EJC ! 5294: * ! 5295: * PREPARE NOW TO START EXECUTION ! 5296: * ! 5297: * ! 5298: * CHECK FOR NOEXECUTE ! 5299: * ! 5300: INIX1 BNZ NOXEQ,INIX3 JUMP IF EXECUTION SUPPRESSED ! 5301: ZER GBCNT INITIALISE COLLECT COUNT ! 5302: BZE HEADP,INIX2 SKIP IF NO PRTPG CALLS IN COMPILN ! 5303: JSR PRTPG EJECT STANDARD PRINTER FILE ! 5304: * ! 5305: * INFORM OSINT OF STAGE ! 5306: * ! 5307: INIX2 JSR SYSBX CALL BEFORE STARTING EXECUTION ! 5308: ZER -(XS) SET FAILURE LOCATION ON STACK ! 5309: MOV XS,FLPTR SAVE PTR TO FAILURE OFFSET WORD ! 5310: MOV R$COD,XR LOAD PTR TO ENTRY CODE BLOCK ! 5311: MOV =STGXT,STAGE SET STAGE FOR EXECUTE TIME ! 5312: JSR SYSTM GET TIME ! 5313: STI TIMSX STORE FOR END RUN PROCESSING ! 5314: .IF .CNPF ! 5315: .ELSE ! 5316: STI PFSTM STORE TIME FOR PROFILER ! 5317: MOV CMPSN,PFNTE COPY STATEMENTS COMPILED COUNT ! 5318: .FI ! 5319: BRI (XR) START XEQ WITH FIRST STATEMENT ! 5320: * ! 5321: * HERE IF EXECUTION IS SUPPRESSED ! 5322: * ! 5323: INIX3 JSR PRTFH PRINT A BLANK LINE ! 5324: MOV =ENCM5,XR POINT TO /EXECUTION SUPPRESSED/ ! 5325: MOV TTERL,TTLST TO FORCE MSG TO TERMINAL ! 5326: JSR PRTSF PRINT NOEXECUTE MESSAGE ! 5327: MOV =KVCOD,WA ENDING CODE ! 5328: JSR SYSEJ END OF JOB, EXIT TO SYSTEM ! 5329: TTL S P I T B O L -- SNOBOL4 OPERATOR ROUTINES ! 5330: * ! 5331: * THIS SECTION INCLUDES ALL ROUTINES WHICH CAN BE ACCESSED ! 5332: * DIRECTLY FROM THE GENERATED CODE EXCEPT SYSTEM FUNCTIONS. ! 5333: * ! 5334: * ALL ROUTINES IN THIS SECTION START WITH A LABEL OF THE ! 5335: * FORM O$XXX WHERE XXX IS THREE LETTERS. THE GENERATED CODE ! 5336: * CONTAINS A POINTER TO THE APPROPRIATE ENTRY LABEL. ! 5337: * ! 5338: * SINCE THE GENERAL FORM OF THE GENERATED CODE CONSISTS OF ! 5339: * POINTERS TO BLOCKS WHOSE FIRST WORD IS THE ADDRESS OF THE ! 5340: * ACTUAL ENTRY POINT LABEL (O$XXX). ! 5341: * ! 5342: * THESE ROUTINES ARE IN ALPHABETICAL ORDER BY THEIR ! 5343: * ENTRY LABEL NAMES (I.E. BY THE XXX OF THE O$XXX NAME) ! 5344: * ! 5345: * THESE ROUTINES RECEIVE CONTROL AS FOLLOWS ! 5346: * ! 5347: * (CP) POINTER TO NEXT CODE WORD ! 5348: * (XS) CURRENT STACK POINTER ! 5349: EJC ! 5350: * ! 5351: * BINARY PLUS (ADDITION) ! 5352: * ! 5353: O$ADD ENT ENTRY POINT ! 5354: JSR ARITH FETCH ARITHMETIC OPERANDS ! 5355: ERR 001,ADDITION LEFT OPERAND IS NOT NUMERIC ! 5356: ERR 002,ADDITION RIGHT OPERAND IS NOT NUMERIC ! 5357: .IF .CNRA ! 5358: .ELSE ! 5359: PPM OADD1 JUMP IF REAL OPERANDS ! 5360: .FI ! 5361: * ! 5362: * HERE TO ADD TWO INTEGERS ! 5363: * ! 5364: ADI ICVAL(XL) ADD RIGHT OPERAND TO LEFT ! 5365: INO EXINT RETURN INTEGER IF NO OVERFLOW ! 5366: ERB 003,ADDITION CAUSED INTEGER OVERFLOW ! 5367: .IF .CNRA ! 5368: .ELSE ! 5369: * ! 5370: * HERE TO ADD TWO REALS ! 5371: * ! 5372: OADD1 ADR RCVAL(XL) ADD RIGHT OPERAND TO LEFT ! 5373: RNO EXREA RETURN REAL IF NO OVERFLOW ! 5374: ERB 004,ADDITION CAUSED REAL OVERFLOW ! 5375: .FI ! 5376: EJC ! 5377: * ! 5378: * UNARY PLUS (AFFIRMATION) ! 5379: * ! 5380: O$AFF ENT ENTRY POINT ! 5381: MOV (XS)+,XR LOAD OPERAND ! 5382: JSR GTNUM CONVERT TO NUMERIC ! 5383: ERR 005,AFFIRMATION OPERAND IS NOT NUMERIC ! 5384: BRN EXIXR RETURN IF CONVERTED TO NUMERIC ! 5385: EJC ! 5386: * ! 5387: * BINARY BAR (ALTERNATION) ! 5388: * ! 5389: O$ALT ENT ENTRY POINT ! 5390: MOV (XS)+,XR LOAD RIGHT OPERAND ! 5391: JSR GTPAT CONVERT TO PATTERN ! 5392: ERR 006,ALTERNATION RIGHT OPERAND IS NOT PATTERN ! 5393: * ! 5394: * MERGE HERE FROM SPECIAL (LEFT ALTERNATION) CASE ! 5395: * ! 5396: OALT1 MOV =P$ALT,WB SET PCODE FOR ALTERNATIVE NODE ! 5397: JSR PBILD BUILD ALTERNATIVE NODE ! 5398: MOV XR,XL SAVE ADDRESS OF ALTERNATIVE NODE ! 5399: MOV (XS)+,XR LOAD LEFT OPERAND ! 5400: JSR GTPAT CONVERT TO PATTERN ! 5401: ERR 007,ALTERNATION LEFT OPERAND IS NOT PATTERN ! 5402: BEQ XR,=P$ALT,OALT2 JUMP IF LEFT ARG IS ALTERNATION ! 5403: MOV XR,PTHEN(XL) SET LEFT OPERAND AS SUCCESSOR ! 5404: MOV XL,XR MOVE RESULT TO PROPER REGISTER ! 5405: BRN EXIXR JUMP FOR NEXT CODE WORD ! 5406: * ! 5407: * COME HERE IF LEFT ARGUMENT IS ITSELF AN ALTERNATION ! 5408: * ! 5409: * THE RESULT IS MORE EFFICIENT IF WE MAKE THE REPLACEMENT ! 5410: * ! 5411: * (A / B) / C = A / (B / C) ! 5412: * ! 5413: OALT2 MOV PARM1(XR),PTHEN(XL) BUILD THE (B / C) NODE ! 5414: MOV PTHEN(XR),-(XS) SET A AS NEW LEFT ARG ! 5415: MOV XL,XR SET (B / C) AS NEW RIGHT ARG ! 5416: BRN OALT1 MERGE BACK TO BUILD A / (B / C) ! 5417: EJC ! 5418: * ! 5419: * ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY NAME) ! 5420: * ! 5421: O$AMN ENT ENTRY POINT ! 5422: LCW XR LOAD NUMBER OF SUBSCRIPTS ! 5423: MOV XR,WB SET FLAG FOR BY NAME ! 5424: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE ! 5425: * ! 5426: * ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY VALUE) ! 5427: * ! 5428: O$AMV ENT ENTRY POINT ! 5429: LCW XR LOAD NUMBER OF SUBSCRIPTS ! 5430: ZER WB SET FLAG FOR BY VALUE ! 5431: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE ! 5432: * ! 5433: * ARRAY REFERENCE (ONE SUBSCRIPT, BY NAME) ! 5434: * ! 5435: O$AON ENT ENTRY POINT ! 5436: MOV (XS),XR LOAD SUBSCRIPT VALUE ! 5437: MOV 1(XS),XL LOAD ARRAY VALUE ! 5438: MOV (XL),WA LOAD FIRST WORD OF ARRAY OPERAND ! 5439: BEQ WA,=B$VCT,OAON2 JUMP IF VECTOR REFERENCE ! 5440: BEQ WA,=B$TBT,OAON3 JUMP IF TABLE REFERENCE ! 5441: * ! 5442: * HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE ! 5443: * ! 5444: OAON1 MOV =NUM01,XR SET NUMBER OF SUBSCRIPTS TO ONE ! 5445: MOV XR,WB SET FLAG FOR BY NAME ! 5446: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE ! 5447: * ! 5448: * HERE IF WE HAVE A VECTOR REFERENCE ! 5449: * ! 5450: OAON2 BNE (XR),=B$ICL,OAON1 USE LONG ROUTINE IF NOT INTEGER ! 5451: LDI ICVAL(XR) LOAD INTEGER SUBSCRIPT VALUE ! 5452: MFI WA,EXFAL COPY AS ADDRESS INT, FAIL IF OVFLO ! 5453: BZE WA,EXFAL FAIL IF ZERO ! 5454: ADD =VCVLB,WA COMPUTE OFFSET IN WORDS ! 5455: WTB WA CONVERT TO BAUS ! 5456: MOV WA,(XS) COMPLETE NAME ON STACK ! 5457: BLT WA,VCLEN(XL),EXITS EXIT IF SUBSCRIPT NOT TOO LARGE ! 5458: BRN EXFAL ELSE FAIL ! 5459: * ! 5460: * HERE FOR TABLE REFERENCE ! 5461: * ! 5462: OAON3 MNZ WB SET FLAG FOR NAME REFERENCE ! 5463: JSR TFIND LOCATE/CREATE TABLE ELEMENT ! 5464: PPM EXFAL FAIL IF ACCESS FAILS ! 5465: MOV XL,1(XS) STORE NAME BASE ON STACK ! 5466: MOV WA,(XS) STORE NAME OFFSET ON STACK ! 5467: BRN EXITS EXIT WITH RESULT ON STACK ! 5468: EJC ! 5469: * ! 5470: * ARRAY REFERENCE (ONE SUBSCRIPT, BY VALUE) ! 5471: * ! 5472: O$AOV ENT ENTRY POINT ! 5473: MOV (XS)+,XR LOAD SUBSCRIPT VALUE ! 5474: MOV (XS)+,XL LOAD ARRAY VALUE ! 5475: MOV (XL),WA LOAD FIRST WORD OF ARRAY OPERAND ! 5476: BEQ WA,=B$VCT,OAOV2 JUMP IF VECTOR REFERENCE ! 5477: BEQ WA,=B$TBT,OAOV3 JUMP IF TABLE REFERENCE ! 5478: * ! 5479: * HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE ! 5480: * ! 5481: OAOV1 MOV XL,-(XS) RESTACK ARRAY VALUE ! 5482: MOV XR,-(XS) RESTACK SUBSCRIPT ! 5483: MOV =NUM01,XR SET NUMBER OF SUBSCRIPTS TO ONE ! 5484: ZER WB SET FLAG FOR VALUE CALL ! 5485: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE ! 5486: * ! 5487: * HERE IF WE HAVE A VECTOR REFERENCE ! 5488: * ! 5489: OAOV2 BNE (XR),=B$ICL,OAOV1 USE LONG ROUTINE IF NOT INTEGER ! 5490: LDI ICVAL(XR) LOAD INTEGER SUBSCRIPT VALUE ! 5491: MFI WA,EXFAL MOVE AS ONE WORD INT, FAIL IF OVFLO ! 5492: BZE WA,EXFAL FAIL IF ZERO ! 5493: ADD =VCVLB,WA COMPUTE OFFSET IN WORDS ! 5494: WTB WA CONVERT TO BAUS ! 5495: BGE WA,VCLEN(XL),EXFAL FAIL IF SUBSCRIPT TOO LARGE ! 5496: JSR ACESS ACCESS VALUE ! 5497: PPM EXFAL FAIL IF ACCESS FAILS ! 5498: BRN EXIXR ELSE RETURN VALUE TO CALLER ! 5499: * ! 5500: * HERE FOR TABLE REFERENCE BY VALUE ! 5501: * ! 5502: OAOV3 ZER WB SET FLAG FOR VALUE REFERENCE ! 5503: JSR TFIND CALL TABLE SEARCH ROUTINE ! 5504: PPM EXFAL FAIL IF ACCESS FAILS ! 5505: BRN EXIXR EXIT WITH RESULT IN XR ! 5506: EJC ! 5507: * ! 5508: * ASSIGNMENT (O$RPL MERGES) ! 5509: * ! 5510: O$ASS ENT ENTRY POINT ! 5511: MOV (XS)+,WB LOAD VALUE TO BE ASSIGNED ! 5512: MOV (XS)+,WA LOAD NAME OFFSET ! 5513: MOV (XS),XL LOAD NAME BASE ! 5514: MOV WB,(XS) STORE ASSIGNED VALUE AS RESULT ! 5515: JSR ASIGN PERFORM ASSIGNMENT ! 5516: PPM EXFAL FAIL IF ASSIGNMENT FAILS ! 5517: BRN EXITS EXIT WITH RESULT ON STACK ! 5518: * ! 5519: * COMPILATION ERROR ! 5520: * ! 5521: O$CER ENT ENTRY POINT ! 5522: ERB 008,COMPILATION ERROR ENCOUNTERED DURING EXECUTION ! 5523: * ! 5524: * UNARY AT (CURSOR ASSIGNMENT) ! 5525: * ! 5526: O$CAS ENT ENTRY POINT ! 5527: MOV (XS)+,WC LOAD NAME OFFSET (PARM2) ! 5528: MOV (XS)+,XR LOAD NAME BASE (PARM1) ! 5529: MOV =P$CAS,WB SET PCODE FOR CURSOR ASSIGNMENT ! 5530: JSR PBILD BUILD NODE ! 5531: BRN EXIXR JUMP FOR NEXT CODE WORD ! 5532: EJC ! 5533: * ! 5534: * CONCATENATION ! 5535: * ! 5536: O$CNC ENT ENTRY POINT ! 5537: MOV (XS),XR LOAD RIGHT ARGUMENT ! 5538: BEQ XR,=NULLS,OCNC3 JUMP IF RIGHT ARG IS NULL ! 5539: MOV 1(XS),XL LOAD LEFT ARGUMENT ! 5540: BEQ XL,=NULLS,OCNC4 JUMP IF LEFT ARGUMENT IS NULL ! 5541: MOV =B$SCL,WA GET CONSTANT TO TEST FOR STRING ! 5542: BNE WA,(XL),OCNC2 JUMP IF LEFT ARG NOT A STRING ! 5543: BNE WA,(XR),OCNC2 JUMP IF RIGHT ARG NOT A STRING ! 5544: * ! 5545: * MERGE HERE TO CONCATENATE TWO STRINGS ! 5546: * ! 5547: OCNC1 MOV SCLEN(XL),WA LOAD LEFT ARGUMENT LENGTH ! 5548: ADD SCLEN(XR),WA COMPUTE RESULT LENGTH ! 5549: JSR ALOCS ALLOCATE SCBLK FOR RESULT ! 5550: MOV XR,1(XS) STORE RESULT PTR OVER LEFT ARGUMENT ! 5551: PSC XR PREPARE TO STORE CHARS OF RESULT ! 5552: MOV SCLEN(XL),WA GET NUMBER OF CHARS IN LEFT ARG ! 5553: PLC XL PREPARE TO LOAD LEFT ARG CHARS ! 5554: MVC MOVE CHARACTERS OF LEFT ARGUMENT ! 5555: MOV (XS)+,XL LOAD RIGHT ARG POINTER, POP STACK ! 5556: MOV SCLEN(XL),WA LOAD NUMBER OF CHARS IN RIGHT ARG ! 5557: PLC XL PREPARE TO LOAD RIGHT ARG CHARS ! 5558: MVC MOVE CHARACTERS OF RIGHT ARGUMENT ! 5559: BRN EXITS EXIT WITH RESULT ON STACK ! 5560: * ! 5561: * COME HERE IF ARGUMENTS ARE NOT BOTH STRINGS ! 5562: * ! 5563: OCNC2 JSR GTSTG CONVERT RIGHT ARG TO STRING ! 5564: PPM OCNC5 JUMP IF RIGHT ARG IS NOT STRING ! 5565: MOV XR,XL SAVE RIGHT ARG PTR ! 5566: JSR GTSTG CONVERT LEFT ARG TO STRING ! 5567: PPM OCNC6 JUMP IF LEFT ARG IS NOT A STRING ! 5568: MOV XR,-(XS) STACK LEFT ARGUMENT ! 5569: MOV XL,-(XS) STACK RIGHT ARGUMENT ! 5570: MOV XR,XL MOVE LEFT ARG TO PROPER REG ! 5571: MOV (XS),XR MOVE RIGHT ARG TO PROPER REG ! 5572: BRN OCNC1 MERGE BACK TO CONCATENATE STRINGS ! 5573: EJC ! 5574: * ! 5575: * CONCATENATION (CONTINUED) ! 5576: * ! 5577: * COME HERE FOR NULL RIGHT ARGUMENT ! 5578: * ! 5579: OCNC3 ICA XS REMOVE RIGHT ARG FROM STACK ! 5580: BRN EXITS RETURN WITH LEFT ARGUMENT ON STACK ! 5581: * ! 5582: * HERE FOR NULL LEFT ARGUMENT ! 5583: * ! 5584: OCNC4 ICA XS UNSTACK ONE ARGUMENT ! 5585: MOV XR,(XS) STORE RIGHT ARGUMENT ! 5586: BRN EXITS EXIT WITH RESULT ON STACK ! 5587: * ! 5588: * HERE IF RIGHT ARGUMENT IS NOT A STRING ! 5589: * ! 5590: OCNC5 MOV XR,XL MOVE RIGHT ARGUMENT PTR ! 5591: MOV (XS)+,XR LOAD LEFT ARG POINTER ! 5592: * ! 5593: * MERGE HERE WHEN LEFT ARGUMENT IS NOT A STRING ! 5594: * ! 5595: OCNC6 JSR GTPAT CONVERT LEFT ARG TO PATTERN ! 5596: ERR 009,CONCATENATION LEFT OPND IS NOT STRING OR PATTERN ! 5597: MOV XR,-(XS) SAVE RESULT ON STACK ! 5598: MOV XL,XR POINT TO RIGHT OPERAND ! 5599: JSR GTPAT CONVERT TO PATTERN ! 5600: ERR 010,CONCATENATION RIGHT OPD IS NOT STRING OR PATTERN ! 5601: MOV XR,XL MOVE FOR PCONC ! 5602: MOV (XS)+,XR RELOAD LEFT OPERAND PTR ! 5603: JSR PCONC CONCATENATE PATTERNS ! 5604: BRN EXIXR EXIT WITH RESULT IN XR ! 5605: EJC ! 5606: * ! 5607: * COMPLEMENTATION ! 5608: * ! 5609: O$COM ENT ENTRY POINT ! 5610: MOV (XS)+,XR LOAD OPERAND ! 5611: MOV (XR),WA LOAD TYPE WORD ! 5612: * ! 5613: * MERGE BACK HERE AFTER CONVERSION ! 5614: * ! 5615: OCOM1 BEQ WA,=B$ICL,OCOM2 JUMP IF INTEGER ! 5616: .IF .CNRA ! 5617: .ELSE ! 5618: BEQ WA,=B$RCL,OCOM3 JUMP IF REAL ! 5619: .FI ! 5620: JSR GTNUM ELSE CONVERT TO NUMERIC ! 5621: ERR 011,COMPLEMENTATION OPERAND IS NOT NUMERIC ! 5622: BRN OCOM1 BACK TO CHECK CASES ! 5623: * ! 5624: * HERE TO COMPLEMENT INTEGER ! 5625: * ! 5626: OCOM2 LDI ICVAL(XR) LOAD INTEGER VALUE ! 5627: NGI NEGATE ! 5628: INO EXINT RETURN INTEGER IF NO OVERFLOW ! 5629: ERB 012,COMPLEMENTATION CAUSED INTEGER OVERFLOW ! 5630: .IF .CNRA ! 5631: .ELSE ! 5632: * ! 5633: * HERE TO COMPLEMENT REAL ! 5634: * ! 5635: OCOM3 LDR RCVAL(XR) LOAD REAL VALUE ! 5636: NGR NEGATE ! 5637: BRN EXREA RETURN REAL RESULT ! 5638: .FI ! 5639: EJC ! 5640: * ! 5641: * BINARY SLASH (DIVISION) ! 5642: * ! 5643: O$DVD ENT ENTRY POINT ! 5644: JSR ARITH FETCH ARITHMETIC OPERANDS ! 5645: ERR 013,DIVISION LEFT OPERAND IS NOT NUMERIC ! 5646: ERR 014,DIVISION RIGHT OPERAND IS NOT NUMERIC ! 5647: .IF .CNRA ! 5648: .ELSE ! 5649: PPM ODVD2 JUMP IF REAL OPERANDS ! 5650: .FI ! 5651: * ! 5652: * HERE TO DIVIDE TWO INTEGERS ! 5653: * ! 5654: DVI ICVAL(XL) DIVIDE LEFT OPERAND BY RIGHT ! 5655: INO EXINT RESULT OK IF NO OVERFLOW ! 5656: ERB 015,DIVISION CAUSED INTEGER OVERFLOW ! 5657: .IF .CNRA ! 5658: .ELSE ! 5659: * ! 5660: * HERE TO DIVIDE TWO REALS ! 5661: * ! 5662: ODVD2 DVR RCVAL(XL) DIVIDE LEFT OPERAND BY RIGHT ! 5663: RNO EXREA RETURN REAL IF NO OVERFLOW ! 5664: ERB 016,DIVISION CAUSED REAL OVERFLOW ! 5665: .FI ! 5666: EJC ! 5667: * ! 5668: * EXPONENTIATION ! 5669: * ! 5670: O$EXP ENT ENTRY POINT ! 5671: MOV (XS)+,XR LOAD EXPONENT ! 5672: JSR GTNUM CONVERT TO NUMBER ! 5673: ERR 017,EXPONENTIATION RIGHT OPERAND IS NOT NUMERIC ! 5674: .IF .CNRA ! 5675: .ELSE ! 5676: BNE WA,=B$ICL,OEXP7 JUMP IF REAL ! 5677: .FI ! 5678: MOV XR,XL MOVE EXPONENT ! 5679: MOV (XS)+,XR LOAD BASE ! 5680: JSR GTNUM CONVERT TO NUMERIC ! 5681: ERR 018,EXPONENTIATION LEFT OPERAND IS NOT NUMERIC ! 5682: LDI ICVAL(XL) LOAD EXPONENT ! 5683: ILT OEXP8 ERROR IF NEGATIVE EXPONENT ! 5684: .IF .CNRA ! 5685: .ELSE ! 5686: BEQ WA,=B$RCL,OEXP3 JUMP IF BASE IS REAL ! 5687: .FI ! 5688: * ! 5689: * HERE TO EXPONENTIATE AN INTEGER ! 5690: * ! 5691: MFI WA,OEXP2 CONVERT EXPONENT TO 1 WORD INTEGER ! 5692: LCT WA,WA SET LOOP COUNTER ! 5693: LDI INTV1 LOAD INITIAL VALUE OF 1 ! 5694: BNZ WA,OEXP1 JUMP IF NON-ZERO EXPONENT ! 5695: INE EXINT GIVE ZERO AS RESULT FOR NONZERO**0 ! 5696: BRN OEXP4 ELSE ERROR OF 0**0 ! 5697: * ! 5698: * LOOP TO PERFORM EXPONENTIATION ! 5699: * ! 5700: OEXP1 MLI ICVAL(XR) MULTIPLY BY BASE ! 5701: IOV OEXP2 JUMP IF OVERFLOW ! 5702: BCT WA,OEXP1 LOOP BACK TILL COMPUTATION COMPLETE ! 5703: BRN EXINT THEN RETURN INTEGER RESULT ! 5704: * ! 5705: * HERE IF INTEGER OVERFLOW ! 5706: * ! 5707: OEXP2 ERB 019,EXPONENTIATION CAUSED INTEGER OVERFLOW ! 5708: EJC ! 5709: * ! 5710: * EXPONENTIATION (CONTINUED) ! 5711: .IF .CNRA ! 5712: .ELSE ! 5713: * ! 5714: * HERE TO EXPONENTIATE A REAL ! 5715: * ! 5716: OEXP3 MFI WA,OEXP6 CONVERT EXPONENT TO ONE WORD ! 5717: LCT WA,WA SET LOOP COUNTER ! 5718: LDR REAV1 LOAD 1.0 AS INITIAL VALUE ! 5719: BNZ WA,OEXP5 JUMP IF NON-ZERO EXPONENT ! 5720: RNE EXREA RETURN 1.0 IF NONZERO**ZERO ! 5721: .FI ! 5722: * ! 5723: * HERE FOR ERROR OF 0**0 OR 0.0**0 ! 5724: * ! 5725: OEXP4 ERB 020,EXPONENTIATION RESULT IS UNDEFINED ! 5726: .IF .CNRA ! 5727: .ELSE ! 5728: * ! 5729: * LOOP TO PERFORM EXPONENTIATION ! 5730: * ! 5731: OEXP5 MLR RCVAL(XR) MULTIPLY BY BASE ! 5732: ROV OEXP6 JUMP IF OVERFLOW ! 5733: BCT WA,OEXP5 LOOP TILL COMPUTATION COMPLETE ! 5734: BRN EXREA THEN RETURN REAL RESULT ! 5735: * ! 5736: * HERE IF REAL OVERFLOW ! 5737: * ! 5738: OEXP6 ERB 021,EXPONENTIATION CAUSED REAL OVERFLOW ! 5739: * ! 5740: * HERE IF REAL EXPONENT ! 5741: * ! 5742: OEXP7 ERB 022,EXPONENTIATION RIGHT OPERAND IS REAL NOT INTEGER ! 5743: .FI ! 5744: * ! 5745: * HERE FOR NEGATIVE EXPONENT ! 5746: * ! 5747: OEXP8 ERB 023,EXPONENTIATION RIGHT OPERAND IS NEGATIVE ! 5748: EJC ! 5749: * ! 5750: * FAILURE IN EXPRESSION EVALUATION ! 5751: * ! 5752: * THIS ENTRY POINT IS USED IF THE EVALUATION OF AN ! 5753: * EXPRESSION, INITIATED BY THE EVALX PROCEDURE, FAILS. ! 5754: * CONTROL IS RETURNED TO AN APPROPRIATE POINT IN EVALX. ! 5755: * ! 5756: O$FEX ENT ENTRY POINT ! 5757: JMG EVLXF JUMP TO FAILURE LOC IN EVALX ! 5758: * ! 5759: * FAILURE DURING EVALUATION OF A COMPLEX OR DIRECT GOTO ! 5760: * ! 5761: O$FIF ENT ENTRY POINT ! 5762: ERB 024,GOTO EVALUATION FAILURE ! 5763: * ! 5764: * FUNCTION CALL (MORE THAN ONE ARGUMENT) ! 5765: * ! 5766: O$FNC ENT ENTRY POINT ! 5767: LCW WA LOAD NUMBER OF ARGUMENTS ! 5768: LCW XR LOAD FUNCTION VRBLK POINTER ! 5769: MOV VRFNC(XR),XL LOAD FUNCTION POINTER ! 5770: BNE WA,FARGS(XL),CFUNC USE CENTRAL ROUTINE IF WRONG NUM ! 5771: BRI (XL) JUMP TO FUNCTION IF ARG COUNT OK ! 5772: * ! 5773: * FUNCTION NAME ERROR ! 5774: * ! 5775: O$FNE ENT ENTRY POINT ! 5776: LCW WA GET NEXT CODE WORD ! 5777: BNE WA,=ORNM$,OFNE1 FAIL IF NOT EVALUATING EXPRESSION ! 5778: BNZ 2(XS),OFNE1 FAIL UNLESS EXPRN WANTED BY VALUE ! 5779: JMG EVLXV JOIN EXPRESSION BY VALUE CODE ! 5780: * ! 5781: * HERE FOR ERROR ! 5782: * ! 5783: OFNE1 ERB 025,FUNCTION CALLED BY NAME RETURNED A VALUE ! 5784: * ! 5785: * FUNCTION CALL (SINGLE ARGUMENT) ! 5786: * ! 5787: O$FNS ENT ENTRY POINT ! 5788: LCW XR LOAD FUNCTION VRBLK POINTER ! 5789: MOV =NUM01,WA SET NUMBER OF ARGUMENTS TO ONE ! 5790: MOV VRFNC(XR),XL LOAD FUNCTION POINTER ! 5791: BNE WA,FARGS(XL),CFUNC USE CENTRAL ROUTINE IF WRONG NUM ! 5792: BRI (XL) JUMP TO FUNCTION IF ARG COUNT OK ! 5793: EJC ! 5794: * CALL TO UNDEFINED FUNCTION ! 5795: * ! 5796: O$FUN ENT ENTRY POINT ! 5797: ERB 026,UNDEFINED FUNCTION CALLED ! 5798: * ! 5799: * EXECUTE COMPLEX GOTO ! 5800: * ! 5801: O$GOC ENT ENTRY POINT ! 5802: MOV 1(XS),XR LOAD NAME BASE POINTER ! 5803: BHI XR,STATE,OGOC1 JUMP IF NOT NATURAL VARIABLE ! 5804: ADD *VRTRA,XR ELSE POINT TO VRTRA FIELD ! 5805: BRI (XR) AND JUMP THROUGH IT ! 5806: * ! 5807: * HERE IF GOTO OPERAND IS NOT NATURAL VARIABLE ! 5808: * ! 5809: OGOC1 ERB 027,GOTO OPERAND IS NOT A NATURAL VARIABLE ! 5810: * ! 5811: * EXECUTE DIRECT GOTO ! 5812: * ! 5813: O$GOD ENT ENTRY POINT ! 5814: MOV (XS),XR LOAD OPERAND ! 5815: MOV (XR),WA LOAD FIRST WORD ! 5816: BEQ WA,=B$CDC,OGOD1 JUMP IF CODE BLOCK ! 5817: BEQ WA,=B$CDS,OGOD2 JUMP IF CODE BLOCK ! 5818: ERB 028,GOTO OPERAND IN DIRECT GOTO IS NOT CODE ! 5819: * ! 5820: * CASE OF COMPLEX FAILURE CODE ! 5821: * ! 5822: OGOD1 MOV FLPTR,XS POP GARBAGE OFF STACK ! 5823: MOV CDFAL(XR),(XS) SET NEW FAILURE OFFSET ! 5824: BRN STMGO JUMP TO EXECUTE CODE ! 5825: * ! 5826: * CASE OF SIMPLE FAILURE CODE ! 5827: * ! 5828: OGOD2 MOV FLPTR,XS POP GARBAGE OFF STACK ! 5829: MOV *CDFAL,(XS) SET NEW FAILURE OFFSET ! 5830: BRN STMGO JUMP TO EXECUTE CODE ! 5831: * ! 5832: * SET GOTO FAILURE TRAP ! 5833: * ! 5834: * THIS ROUTINE IS EXECUTED AT THE START OF A COMPLEX OR ! 5835: * DIRECT FAILURE GOTO TO TRAP A SUBSEQUENT FAIL (SEE EXFAL) ! 5836: * ! 5837: O$GOF ENT ENTRY POINT ! 5838: MOV FLPTR,XR POINT TO FAIL OFFSET ON STACK ! 5839: ICA (XR) POINT FAILURE TO O$FIF WORD ! 5840: ICP POINT TO NEXT CODE WORD ! 5841: BRN EXITS EXIT TO CONTINUE ! 5842: EJC ! 5843: * ! 5844: * BINARY DOLLAR (IMMEDIATE ASSIGNMENT) ! 5845: * ! 5846: * THE PATTERN BUILT BY BINARY DOLLAR IS A COMPOUND PATTERN. ! 5847: * SEE DESCRIPTION AT START OF PATTERN MATCH SECTION FOR ! 5848: * DETAILS OF THE STRUCTURE WHICH IS CONSTRUCTED. ! 5849: * ! 5850: O$IMA ENT ENTRY POINT ! 5851: MOV =P$IMC,WB SET PCODE FOR LAST NODE ! 5852: MOV (XS)+,WC POP NAME OFFSET (PARM2) ! 5853: MOV (XS)+,XR POP NAME BASE (PARM1) ! 5854: JSR PBILD BUILD P$IMC NODE ! 5855: MOV XR,XL SAVE PTR TO NODE ! 5856: MOV (XS),XR LOAD LEFT ARGUMENT ! 5857: JSR GTPAT CONVERT TO PATTERN ! 5858: ERR 029,IMMEDIATE ASSIGNMENT LEFT OPERAND IS NOT PATTERN ! 5859: MOV XR,(XS) SAVE PTR TO LEFT OPERAND PATTERN ! 5860: MOV =P$IMA,WB SET PCODE FOR FIRST NODE ! 5861: JSR PBILD BUILD P$IMA NODE ! 5862: MOV (XS)+,PTHEN(XR) SET LEFT OPERAND AS P$IMA SUCCESSOR ! 5863: JSR PCONC CONCATENATE TO FORM FINAL PATTERN ! 5864: BRN EXIXR ALL DONE ! 5865: * ! 5866: * INDIRECTION (BY NAME) ! 5867: * ! 5868: O$INN ENT ENTRY POINT ! 5869: MNZ WB SET FLAG FOR RESULT BY NAME ! 5870: BRN INDIR JUMP TO COMMON ROUTINE ! 5871: * ! 5872: * INTERROGATION ! 5873: * ! 5874: O$INT ENT ENTRY POINT ! 5875: MOV =NULLS,(XS) REPLACE OPERAND WITH NULL ! 5876: BRN EXITS EXIT FOR NEXT CODE WORD ! 5877: * ! 5878: * INDIRECTION (BY VALUE) ! 5879: * ! 5880: O$INV ENT ENTRY POINT ! 5881: ZER WB SET FLAG FOR BY VALUE ! 5882: BRN INDIR JUMP TO COMMON ROUTINE ! 5883: EJC ! 5884: * ! 5885: * KEYWORD REFERENCE (BY NAME) ! 5886: * ! 5887: O$KWN ENT ENTRY POINT ! 5888: JSR KWNAM GET KEYWORD NAME ! 5889: BRN EXNAM EXIT WITH RESULT NAME ! 5890: * ! 5891: * KEYWORD REFERENCE (BY VALUE) ! 5892: * ! 5893: O$KWV ENT ENTRY POINT ! 5894: JSR KWNAM GET KEYWORD NAME ! 5895: MOV XR,DNAMP DELETE KVBLK ! 5896: JSR ACESS ACCESS VALUE ! 5897: PPM EXNUL DUMMY (UNUSED) FAILURE RETURN ! 5898: BRN EXIXR JUMP WITH VALUE IN XR ! 5899: * ! 5900: * LOAD EXPRESSION BY NAME ! 5901: * ! 5902: O$LEX ENT ENTRY POINT ! 5903: MOV *EVSI$,WA SET SIZE OF EVBLK ! 5904: JSR ALLOC ALLOCATE SPACE FOR EVBLK ! 5905: MOV =B$EVT,(XR) SET TYPE WORD ! 5906: MOV =TRBEV,EVVAR(XR) SET DUMMY TRBLK POINTER ! 5907: LCW WA LOAD EXBLK POINTER ! 5908: MOV WA,EVEXP(XR) SET EXBLK POINTER ! 5909: MOV XR,XL MOVE NAME BASE TO PROPER REG ! 5910: MOV *EVVAR,WA SET NAME OFFSET = ZERO ! 5911: BRN EXNAM EXIT WITH NAME IN (XL,WA) ! 5912: * ! 5913: * LOAD PATTERN VALUE ! 5914: * ! 5915: O$LPT ENT ENTRY POINT ! 5916: LCW XR LOAD PATTERN POINTER ! 5917: BRN EXIXR STACK PTR AND OBEY NEXT CODE WORD ! 5918: EJC ! 5919: * ! 5920: * LOAD VARIABLE NAME ! 5921: * ! 5922: O$LVN ENT ENTRY POINT ! 5923: LCW WA LOAD VRBLK POINTER ! 5924: MOV WA,-(XS) STACK VRBLK PTR (NAME BASE) ! 5925: MOV *VRVAL,-(XS) STACK NAME OFFSET ! 5926: BRN EXITS EXIT WITH RESULT ON STACK ! 5927: * ! 5928: * BINARY ASTERISK (MULTIPLICATION) ! 5929: * ! 5930: O$MLT ENT ENTRY POINT ! 5931: JSR ARITH FETCH ARITHMETIC OPERANDS ! 5932: ERR 030,MULTIPLICATION LEFT OPERAND IS NOT NUMERIC ! 5933: ERR 031,MULTIPLICATION RIGHT OPERAND IS NOT NUMERIC ! 5934: .IF .CNRA ! 5935: .ELSE ! 5936: PPM OMLT1 JUMP IF REAL OPERANDS ! 5937: .FI ! 5938: * ! 5939: * HERE TO MULTIPLY TWO INTEGERS ! 5940: * ! 5941: MLI ICVAL(XL) MULTIPLY LEFT OPERAND BY RIGHT ! 5942: INO EXINT RETURN INTEGER IF NO OVERFLOW ! 5943: ERB 032,MULTIPLICATION CAUSED INTEGER OVERFLOW ! 5944: .IF .CNRA ! 5945: .ELSE ! 5946: * ! 5947: * HERE TO MULTIPLY TWO REALS ! 5948: * ! 5949: OMLT1 MLR RCVAL(XL) MULTIPLY LEFT OPERAND BY RIGHT ! 5950: RNO EXREA RETURN REAL IF NO OVERFLOW ! 5951: ERB 033,MULTIPLICATION CAUSED REAL OVERFLOW ! 5952: .FI ! 5953: * ! 5954: * NAME REFERENCE ! 5955: * ! 5956: O$NAM ENT ENTRY POINT ! 5957: MOV *NMSI$,WA SET LENGTH OF NMBLK ! 5958: JSR ALLOC ALLOCATE NMBLK ! 5959: MOV =B$NML,(XR) SET NAME BLOCK CODE ! 5960: MOV (XS)+,NMOFS(XR) SET NAME OFFSET FROM OPERAND ! 5961: MOV (XS)+,NMBAS(XR) SET NAME BASE FROM OPERAND ! 5962: BRN EXIXR EXIT WITH RESULT IN XR ! 5963: EJC ! 5964: * ! 5965: * NEGATION ! 5966: * ! 5967: * INITIAL ENTRY ! 5968: * ! 5969: O$NTA ENT ENTRY POINT ! 5970: LCW WA LOAD NEW FAILURE OFFSET ! 5971: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER ! 5972: MOV WA,-(XS) STACK NEW FAILURE OFFSET ! 5973: MOV XS,FLPTR SET NEW FAILURE POINTER ! 5974: BRN EXITS JUMP TO CONTINUE EXECUTION ! 5975: * ! 5976: * ENTRY AFTER SUCCESSFUL EVALUATION OF OPERAND ! 5977: * ! 5978: O$NTB ENT ENTRY POINT ! 5979: MOV 2(XS),FLPTR RESTORE OLD FAILURE POINTER ! 5980: BRN EXFAL AND FAIL ! 5981: * ! 5982: * ENTRY FOR FAILURE DURING OPERAND EVALUATION ! 5983: * ! 5984: O$NTC ENT ENTRY POINT ! 5985: ICA XS POP FAILURE OFFSET ! 5986: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER ! 5987: BRN EXNUL EXIT GIVING NULL RESULT ! 5988: * ! 5989: * USE OF UNDEFINED OPERATOR ! 5990: * ! 5991: O$OUN ENT ENTRY POINT ! 5992: ERB 034,UNDEFINED OPERATOR REFERENCED ! 5993: * ! 5994: * BINARY DOT (PATTERN ASSIGNMENT) ! 5995: * ! 5996: * THE PATTERN BUILT BY BINARY DOT IS A COMPOUND PATTERN. ! 5997: * SEE DESCRIPTION AT START OF PATTERN MATCH SECTION FOR ! 5998: * DETAILS OF THE STRUCTURE WHICH IS CONSTRUCTED. ! 5999: * ! 6000: O$PAS ENT ENTRY POINT ! 6001: MOV =P$PAC,WB LOAD PCODE FOR P$PAC NODE ! 6002: MOV (XS)+,WC LOAD NAME OFFSET (PARM2) ! 6003: MOV (XS)+,XR LOAD NAME BASE (PARM1) ! 6004: JSR PBILD BUILD P$PAC NODE ! 6005: MOV XR,XL SAVE PTR TO NODE ! 6006: MOV (XS),XR LOAD LEFT OPERAND ! 6007: JSR GTPAT CONVERT TO PATTERN ! 6008: ERR 035,PATTERN ASSIGNMENT LEFT OPERAND IS NOT PATTERN ! 6009: MOV XR,(XS) SAVE PTR TO LEFT OPERAND PATTERN ! 6010: MOV =P$PAA,WB SET PCODE FOR P$PAA NODE ! 6011: JSR PBILD BUILD P$PAA NODE ! 6012: MOV (XS)+,PTHEN(XR) SET LEFT OPERAND AS P$PAA SUCCESSOR ! 6013: JSR PCONC CONCATENATE TO FORM FINAL PATTERN ! 6014: BRN EXIXR JUMP FOR NEXT CODE WORD ! 6015: EJC ! 6016: * ! 6017: * PATTERN MATCH (BY NAME, FOR REPLACEMENT) ! 6018: * ! 6019: O$PMN ENT ENTRY POINT ! 6020: ZER WB SET TYPE CODE FOR MATCH BY NAME ! 6021: BRN MATCH JUMP TO ROUTINE TO START MATCH ! 6022: * ! 6023: * PATTERN MATCH (STATEMENT) ! 6024: * ! 6025: * O$PMS IS USED IN PLACE OF O$PMV WHEN THE PATTERN MATCH ! 6026: * OCCURS AT THE OUTER (STATEMENT) LEVEL SINCE IN THIS ! 6027: * CASE THE SUBSTRING VALUE NEED NOT BE CONSTRUCTED. ! 6028: * ! 6029: O$PMS ENT ENTRY POINT ! 6030: MOV =NUM02,WB SET FLAG FOR STATEMENT TO MATCH ! 6031: BRN MATCH JUMP TO ROUTINE TO START MATCH ! 6032: * ! 6033: * PATTERN MATCH (BY VALUE) ! 6034: * ! 6035: O$PMV ENT ENTRY POINT ! 6036: MOV =NUM01,WB SET TYPE CODE FOR VALUE MATCH ! 6037: BRN MATCH JUMP TO ROUTINE TO START MATCH ! 6038: * ! 6039: * POP TOP ITEM ON STACK ! 6040: * ! 6041: O$POP ENT ENTRY POINT ! 6042: ICA XS POP TOP STACK ENTRY ! 6043: BRN EXITS OBEY NEXT CODE WORD ! 6044: * ! 6045: * TERMINATE EXECUTION (CODE COMPILED FOR END STATEMENT) ! 6046: * ! 6047: O$STP ENT ENTRY POINT ! 6048: MOV =ENDMS,XR ENDING MESSAGE ! 6049: ZER WA NO ERROR CODE ! 6050: BRN STOPR STOP THE RUN ! 6051: * ! 6052: * RETURN NAME FROM EXPRESSION ! 6053: * THIS ENTRY POINTS IS USED IF THE EVALUATION OF AN ! 6054: * EXPRESSION, INITIATED BY THE EVALX PROCEDURE, RETURNS ! 6055: * A NAME. CONTROL IS RETURNED TO THE PROPER POINT IN EVALX. ! 6056: * ! 6057: O$RNM ENT ENTRY POINT ! 6058: JMG EVLXN RETURN TO EVALX PROCEDURE ! 6059: EJC ! 6060: * ! 6061: * PATTERN REPLACEMENT ! 6062: * ! 6063: * WHEN THIS ROUTINE GETS CONTROL, THE FOLLOWING STACK ! 6064: * ENTRIES HAVE BEEN MADE (SEE END OF MATCH ROUTINE P$NTH) ! 6065: * ! 6066: * SUBJECT NAME BASE ! 6067: * SUBJECT NAME OFFSET ! 6068: * INITIAL CURSOR VALUE ! 6069: * FINAL CURSOR VALUE ! 6070: * SUBJECT STRING POINTER ! 6071: * (XS) ---------------- REPLACEMENT VALUE ! 6072: * ! 6073: O$RPL ENT ENTRY POINT ! 6074: JSR GTSTG CONVERT REPLACEMENT VAL TO STRING ! 6075: ERR 036,PATTERN REPLACEMENT RIGHT OPERAND IS NOT STRING ! 6076: * ! 6077: * GET RESULT LENGTH AND ALLOCATE RESULT SCBLK ! 6078: * ! 6079: MOV (XS),XL LOAD SUBJECT STRING POINTER ! 6080: .IF .CNBF ! 6081: .ELSE ! 6082: BEQ (XL),=B$BCT,ORPL5 BRANCH IF BUFFER ASSIGNMENT ! 6083: .FI ! 6084: ADD SCLEN(XL),WA ADD SUBJECT STRING LENGTH ! 6085: ADD 2(XS),WA ADD STARTING CURSOR ! 6086: SUB 1(XS),WA MINUS FINAL CURSOR = TOTAL LENGTH ! 6087: BZE WA,ORPL3 JUMP IF RESULT IS NULL ! 6088: MOV XR,-(XS) RESTACK REPLACEMENT STRING ! 6089: JSR ALOCS ALLOCATE SCBLK FOR RESULT ! 6090: MOV 3(XS),WA GET INITIAL CURSOR (PART 1 LEN) ! 6091: MOV XR,3(XS) STACK RESULT POINTER ! 6092: PSC XR POINT TO CHARACTERS OF RESULT ! 6093: * ! 6094: * MOVE PART 1 (START OF SUBJECT) TO RESULT ! 6095: * ! 6096: BZE WA,ORPL1 JUMP IF FIRST PART IS NULL ! 6097: MOV 1(XS),XL ELSE POINT TO SUBJECT STRING ! 6098: PLC XL POINT TO SUBJECT STRING CHARS ! 6099: MVC MOVE FIRST PART TO RESULT ! 6100: EJC ! 6101: * PATTERN REPLACEMENT (CONTINUED) ! 6102: * ! 6103: * NOW MOVE IN REPLACEMENT VALUE ! 6104: * ! 6105: ORPL1 MOV (XS)+,XL LOAD REPLACEMENT STRING, POP ! 6106: MOV SCLEN(XL),WA LOAD LENGTH ! 6107: BZE WA,ORPL2 JUMP IF NULL REPLACEMENT ! 6108: PLC XL ELSE POINT TO CHARS OF REPLACEMENT ! 6109: MVC MOVE IN CHARS (PART 2) ! 6110: * ! 6111: * NOW MOVE IN REMAINDER OF STRING (PART 3) ! 6112: * ! 6113: ORPL2 MOV (XS)+,XL LOAD SUBJECT STRING POINTER, POP ! 6114: MOV (XS)+,WC LOAD FINAL CURSOR, POP ! 6115: MOV SCLEN(XL),WA LOAD SUBJECT STRING LENGTH ! 6116: SUB WC,WA MINUS FINAL CURSOR = PART 3 LENGTH ! 6117: BZE WA,ORPL4 JUMP TO ASSIGN IF PART 3 IS NULL ! 6118: PLC XL,WC ELSE POINT TO LAST PART OF STRING ! 6119: MVC MOVE PART 3 TO RESULT ! 6120: BRN ORPL4 JUMP TO PERFORM ASSIGNMENT ! 6121: * ! 6122: * HERE IF RESULT IS NULL ! 6123: * ! 6124: ORPL3 ADD *NUM02,XS POP SUBJECT STR PTR, FINAL CURSOR ! 6125: MOV =NULLS,(XS) SET NULL RESULT ! 6126: * ! 6127: * MERGE WITH ASSIGNMENT ROUTINE ! 6128: * ! 6129: ORPL4 MOV =O$ASS,XL CONTINUATION ROUTINE ! 6130: BRI XL ENTER ROUTINE ! 6131: .IF .CNBF ! 6132: .ELSE ! 6133: * ! 6134: * HERE FOR BUFFER SUBSTRING ASSIGNMENT ! 6135: * ! 6136: ORPL5 MOV XR,XL COPY SCBLK REPLACEMENT PTR ! 6137: MOV (XS)+,XR UNSTACK BCBLK PTR ! 6138: MOV (XS)+,WB GET FINAL CURSOR VALUE ! 6139: MOV (XS)+,WA GET INITIAL CURSOR ! 6140: SUB WA,WB GET LENGTH IN WB ! 6141: ADD *NUM02,XS GET RID OF NAME BASE/OFFSET ! 6142: JSR INSBF INSERT SUBSTRING ! 6143: PPM CONVERT FAIL IMPOSSIBLE ! 6144: PPM EXFAL FAIL IF INSERT FAILS ! 6145: BRN EXNUL ELSE NULL RESULT ! 6146: .FI ! 6147: EJC ! 6148: * ! 6149: * RETURN VALUE FROM EXPRESSION ! 6150: * ! 6151: * THIS ENTRY POINTS IS USED IF THE EVALUATION OF AN ! 6152: * EXPRESSION, INITIATED BY THE EVALX PROCEDURE, RETURNS ! 6153: * A VALUE. CONTROL IS RETURNED TO THE PROPER POINT IN EVALX ! 6154: * ! 6155: O$RVL ENT ENTRY POINT ! 6156: BRN EVLXV RETURN TO EVALX PROCEDURE ! 6157: EJC ! 6158: * ! 6159: * SELECTION ! 6160: * ! 6161: * INITIAL ENTRY ! 6162: * ! 6163: O$SLA ENT ENTRY POINT ! 6164: LCW WA LOAD NEW FAILURE OFFSET ! 6165: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER ! 6166: MOV WA,-(XS) STACK NEW FAILURE OFFSET ! 6167: MOV XS,FLPTR SET NEW FAILURE POINTER ! 6168: BRN EXITS JUMP TO EXECUTE FIRST ALTERNATIVE ! 6169: * ! 6170: * ENTRY AFTER SUCCESSFUL EVALUATION OF ALTERNATIVE ! 6171: * ! 6172: O$SLB ENT ENTRY POINT ! 6173: MOV (XS)+,XR LOAD RESULT ! 6174: ICA XS POP FAIL OFFSET ! 6175: MOV (XS),FLPTR RESTORE OLD FAILURE POINTER ! 6176: MOV XR,(XS) RESTACK RESULT ! 6177: LCW WA LOAD NEW CODE OFFSET ! 6178: ADD R$COD,WA POINT TO ABSOLUTE CODE LOCATION ! 6179: LCP WA SET NEW CODE POINTER ! 6180: BRN EXITS JUMP TO CONTINUE PAST SELECTION ! 6181: * ! 6182: * ENTRY AT START OF SUBSEQUENT ALTERNATIVES ! 6183: * ! 6184: O$SLC ENT ENTRY POINT ! 6185: LCW WA LOAD NEW FAIL OFFSET ! 6186: MOV WA,(XS) STORE NEW FAIL OFFSET ! 6187: BRN EXITS JUMP TO EXECUTE NEXT ALTERNATIVE ! 6188: * ! 6189: * ENTRY AT START OF LAST ALTERNATIVE ! 6190: * ! 6191: O$SLD ENT ENTRY POINT ! 6192: ICA XS POP FAILURE OFFSET ! 6193: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER ! 6194: BRN EXITS JUMP TO EXECUTE LAST ALTERNATIVE ! 6195: EJC ! 6196: * ! 6197: * BINARY MINUS (SUBTRACTION) ! 6198: * ! 6199: O$SUB ENT ENTRY POINT ! 6200: JSR ARITH FETCH ARITHMETIC OPERANDS ! 6201: ERR 037,SUBTRACTION LEFT OPERAND IS NOT NUMERIC ! 6202: ERR 038,SUBTRACTION RIGHT OPERAND IS NOT NUMERIC ! 6203: .IF .CNRA ! 6204: .ELSE ! 6205: PPM OSUB1 JUMP IF REAL OPERANDS ! 6206: .FI ! 6207: * ! 6208: * HERE TO SUBTRACT TWO INTEGERS ! 6209: * ! 6210: SBI ICVAL(XL) SUBTRACT RIGHT OPERAND FROM LEFT ! 6211: INO EXINT RETURN INTEGER IF NO OVERFLOW ! 6212: ERB 039,SUBTRACTION CAUSED INTEGER OVERFLOW ! 6213: .IF .CNRA ! 6214: .ELSE ! 6215: * ! 6216: * HERE TO SUBTRACT TWO REALS ! 6217: * ! 6218: OSUB1 SBR RCVAL(XL) SUBTRACT RIGHT OPERAND FROM LEFT ! 6219: RNO EXREA RETURN REAL IF NO OVERFLOW ! 6220: ERB 040,SUBTRACTION CAUSED REAL OVERFLOW ! 6221: .FI ! 6222: * ! 6223: * DUMMY OPERATOR TO RETURN CONTROL TO TRXEQ PROCEDURE ! 6224: * ! 6225: O$TXR ENT ENTRY POINT ! 6226: JMG TRXQR JUMP INTO TRXEQ PROCEDURE ! 6227: * ! 6228: * UNEXPECTED FAILURE ! 6229: * ! 6230: * NOTE THAT IF A SETEXIT TRAP IS OPERATING THEN ! 6231: * TRANSFER TO SYSTEM LABEL CONTINUE ! 6232: * WILL RESULT IN LOOPING HERE. DIFFICULT TO AVOID EXCEPT ! 6233: * WITH A CONSIDERABLE OVERHEAD WHICH IS NOT WORTHWHILE OR ! 6234: * ELSE BY A TECHNIQUE SUCH AS SETTING KVERL TO ZERO. ! 6235: * ! 6236: O$UNF ENT ENTRY POINT ! 6237: ERB 041,UNEXPECTED FAILURE IN -NOFAIL MODE ! 6238: TTL S P I T B O L -- SNOBOL4 BUILTIN LABEL ROUTINES ! 6239: * ! 6240: * THE FOLLOWING SECTION CONTAINS THE ROUTINES FOR LABELS ! 6241: * WHICH HAVE A PREDEFINED MEANING IN SNOBOL4. ! 6242: * ! 6243: * CONTROL IS PASSED DIRECTLY TO THE LABEL NAME ENTRY POINT. ! 6244: * ! 6245: * ENTRY NAMES ARE OF THE FORM L$XXX WHERE XXX IS THE THREE ! 6246: * LETTER VARIABLE NAME IDENTIFIER. ! 6247: * ! 6248: * ENTRIES ARE IN ALPHABETICAL ORDER ! 6249: * ! 6250: * ABORT ! 6251: * ! 6252: L$ABO ENT ENTRY POINT ! 6253: MOV KVERT,WA LOAD ERROR CODE ! 6254: ZER XR INDICATE NO ENDING MESSAGE ! 6255: BNZ WA,STOPR STOP RUN ! 6256: * ! 6257: * ! 6258: * FAIL IF NO ERROR HAD OCCURED ! 6259: * ! 6260: ERB 042,GOTO ABORT WITH NO PRECEDING ERROR ! 6261: * ! 6262: * CONTINUE ! 6263: * ! 6264: L$CNT ENT ENTRY POINT ! 6265: * ! 6266: * MERGE HERE AFTER EXECUTION ERROR ! 6267: * ! 6268: LCNXE MOV R$CNT,XR LOAD CONTINUATION CODE BLOCK PTR ! 6269: BZE XR,LCNT1 JUMP IF NO PREVIOUS ERROR ! 6270: ZER R$CNT CLEAR FLAG ! 6271: MOV XR,R$COD ELSE STORE AS NEW CODE BLOCK PTR ! 6272: ADD STXOF,XR ADD FAILURE OFFSET ! 6273: LCP XR LOAD CODE POINTER ! 6274: MOV FLPTR,XS RESET STACK POINTER ! 6275: BRN EXITS JUMP TO TAKE INDICATED FAILURE ! 6276: * ! 6277: * HERE IF NO PREVIOUS ERROR ! 6278: * ! 6279: LCNT1 ERB 043,GOTO CONTINUE WITH NO PRECEDING ERROR ! 6280: EJC ! 6281: * ! 6282: * END ! 6283: * ! 6284: L$END ENT ENTRY POINT ! 6285: MOV =ENDMS,XR POINT TO MESSAGE /NORMAL TERM../ ! 6286: ZER WA NO ERROR CODE ! 6287: BRN STOPR JUMP TO ROUTINE TO STOP RUN ! 6288: * ! 6289: * FRETURN ! 6290: * ! 6291: L$FRT ENT ENTRY POINT ! 6292: MOV =SCFRT,WA POINT TO STRING /FRETURN/ ! 6293: BRN RETRN JUMP TO COMMON RETURN ROUTINE ! 6294: * ! 6295: * NRETURN ! 6296: * ! 6297: L$NRT ENT ENTRY POINT ! 6298: MOV =SCNRT,WA POINT TO STRING /NRETURN/ ! 6299: BRN RETRN JUMP TO COMMON RETURN ROUTINE ! 6300: * ! 6301: * RETURN ! 6302: * ! 6303: L$RTN ENT ENTRY POINT ! 6304: MOV =SCRTN,WA POINT TO STRING /RETURN/ ! 6305: BRN RETRN JUMP TO COMMON RETURN ROUTINE ! 6306: * ! 6307: * UNDEFINED LABEL ! 6308: * ! 6309: L$UND ENT ENTRY POINT ! 6310: ERB 044,GOTO UNDEFINED LABEL ! 6311: TTL S P I T B O L -- BLOCK ACTION ROUTINES ! 6312: * ! 6313: * THE FIRST WORD OF EVERY BLOCK IN DYNAMIC STORAGE AND THE ! 6314: * VRGET, VRSTO AND VRTRA FIELDS OF A VRBLK CONTAIN A ! 6315: * POINTER TO AN ENTRY POINT IN THE PROGRAM. ALL SUCH ENTRY ! 6316: * POINTS ARE IN THE FOLLOWING SECTION EXCEPT THOSE FOR ! 6317: * PATTERN BLOCKS WHICH ARE IN THE PATTERN MATCHING SEGMENT ! 6318: * LATER ON (LABELS OF THE FORM P$XXX), AND DOPE VECTORS ! 6319: * (D$XXX) WHICH ARE IN THE DOPE VECTOR SECTION FOLLOWING ! 6320: * THE PATTERN ROUTINES (DOPE VECTORS ARE USED FOR CMBLKS). ! 6321: * ! 6322: * THE ENTRY POINTS IN THIS SECTION HAVE LABELS OF THE ! 6323: * FORM B$XXY WHERE XX IS THE TWO CHARACTER BLOCK TYPE FOR ! 6324: * THE CORRESPONDING BLOCK AND Y IS ANY LETTER. ! 6325: * ! 6326: * IN SOME CASES, THE POINTERS SERVE NO OTHER PURPOSE THAN ! 6327: * TO IDENTIFY THE BLOCK TYPE. IN THIS CASE THE ROUTINE ! 6328: * IS NEVER EXECUTED AND THUS NO CODE IS ASSEMBLED. ! 6329: * ! 6330: * FOR EACH OF THESE ENTRY POINTS CORRESPONDING TO A BLOCK ! 6331: * AN ENTRY POINT IDENTIFICATION IS ASSEMBLED (BL$XX). ! 6332: * ! 6333: * THE EXACT ENTRY CONDITIONS DEPEND ON THE MANNER IN ! 6334: * WHICH THE ROUTINE IS ACCESSED AND ARE DOCUMENTED WITH ! 6335: * THE INDIVIDUAL ROUTINES AS REQUIRED. ! 6336: * ! 6337: * THE ORDER OF THESE ROUTINES IS ALPHABETICAL WITH THE ! 6338: * FOLLOWING EXCEPTIONS. ! 6339: * ! 6340: * THE ROUTINES FOR SEBLK AND EXBLK ENTRIES OCCUR FIRST SO ! 6341: * THAT EXPRESSIONS CAN BE QUICKLY IDENTIFIED FROM THE FACT ! 6342: * THAT THEIR ROUTINES LIE BEFORE THE SYMBOL B$E$$. ! 6343: * ! 6344: * THESE ARE IMMEDIATELY FOLLOWED BY THE ROUTINE FOR A TRBLK ! 6345: * SO THAT THE TEST AGAINST THE SYMBOL B$T$$ CHECKS FOR ! 6346: * TRAPPED VALUES OR EXPRESSION VALUES (SEE PROCEDURE EVALP) ! 6347: * ! 6348: * THE PATTERN ROUTINES LIE AFTER THIS SECTION SO THAT ! 6349: * PATTERNS ARE IDENTIFIED WITH ROUTINES STARTING AT OR ! 6350: * AFTER THE INITIAL INSTRUCTION IN THESE ROUTINES (P$AAA). ! 6351: * ! 6352: * THE SYMBOL B$AAA DEFINES THE FIRST LOCATION FOR BLOCK ! 6353: * ROUTINES AND THE SYMBOL P$YYY (AT THE END OF THE PATTERN ! 6354: * MATCH ROUTINES SECTION) DEFINES THE LAST SUCH ENTRY POINT ! 6355: * ! 6356: B$AAA ENT BL$$I ENTRY POINT OF FIRST BLOCK ROUTINE ! 6357: EJC ! 6358: * ! 6359: * EXBLK ! 6360: * ! 6361: * THE ROUTINE FOR AN EXBLK LOADS THE EXPRESSION ONTO ! 6362: * THE STACK AS A VALUE. ! 6363: * ! 6364: * (XR) POINTER TO EXBLK ! 6365: * ! 6366: B$EXL ENT BL$EX ENTRY POINT (EXBLK) ! 6367: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD ! 6368: * ! 6369: * SEBLK ! 6370: * ! 6371: * THE ROUTINE FOR SEBLK IS ACCESSED FROM THE GENERATED ! 6372: * CODE TO LOAD THE EXPRESSION VALUE ONTO THE STACK. ! 6373: * ! 6374: B$SEL ENT BL$SE ENTRY POINT (SEBLK) ! 6375: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD ! 6376: * ! 6377: * DEFINE SYMBOL WHICH MARKS END OF ENTRIES FOR EXPRESSIONS ! 6378: * ! 6379: B$E$$ ENT BL$$I ENTRY POINT ! 6380: * ! 6381: * TRBLK ! 6382: * ! 6383: * THE ROUTINE FOR A TRBLK IS NEVER EXECUTED ! 6384: * ! 6385: B$TRT ENT BL$TR ENTRY POINT (TRBLK) ! 6386: * ! 6387: * DEFINE SYMBOL MARKING END OF TRAP AND EXPRESSION BLOCKS ! 6388: * ! 6389: B$T$$ ENT BL$$I END OF TRBLK,SEBLK,EXBLK ENTRIES ! 6390: * ! 6391: * ARBLK ! 6392: * ! 6393: * THE ROUTINE FOR ARBLK IS NEVER EXECUTED ! 6394: * ! 6395: B$ART ENT BL$AR ENTRY POINT (ARBLK) ! 6396: EJC ! 6397: .IF .CNBF ! 6398: .ELSE ! 6399: * ! 6400: * BCBLK ! 6401: * ! 6402: * THE ROUTINE FOR A BCBLK IS NEVER EXECUTED ! 6403: * ! 6404: * (XR) POINTER TO BCBLK ! 6405: * ! 6406: B$BCT ENT BL$BC ENTRY POINT (BCBLK) ! 6407: * ! 6408: * BFBLK ! 6409: * ! 6410: * THE ROUTINE FOR A BFBLK IS NEVER EXECUTED ! 6411: * ! 6412: * (XR) POINTER TO BFBLK ! 6413: * ! 6414: B$BFT ENT BL$BF ENTRY POINT (BFBLK) ! 6415: EJC ! 6416: .FI ! 6417: * ! 6418: * CCBLK ! 6419: * ! 6420: * THE ROUTINE FOR CCBLK IS NEVER ENTERED ! 6421: * ! 6422: B$CCT ENT BL$CC ENTRY POINT (CCBLK) ! 6423: * ! 6424: * CDBLK ! 6425: * ! 6426: * THE CDBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE. ! 6427: * THERE ARE TWO CASES DEPENDING ON THE FORM OF CDFAL. ! 6428: * ! 6429: * ENTRY FOR COMPLEX FAILURE CODE AT CDFAL ! 6430: * ! 6431: * (XR) POINTER TO CDBLK ! 6432: * ! 6433: B$CDC ENT BL$CD ENTRY POINT (CDBLK) ! 6434: MOV FLPTR,XS POP GARBAGE OFF STACK ! 6435: MOV CDFAL(XR),(XS) SET FAILURE OFFSET ! 6436: BRN STMGO ENTER STMT ! 6437: * ! 6438: * ENTRY FOR SIMPLE FAILURE CODE AT CDFAL ! 6439: * ! 6440: * (XR) POINTER TO CDBLK ! 6441: * ! 6442: B$CDS ENT BL$CD ENTRY POINT (CDBLK) ! 6443: MOV FLPTR,XS POP GARBAGE OFF STACK ! 6444: MOV *CDFAL,(XS) SET FAILURE OFFSET ! 6445: BRN STMGO ENTER STMT ! 6446: * ! 6447: * CMBLK ! 6448: * ! 6449: * THE ROUTINE FOR A CMBLK IS NEVER EXECUTED ! 6450: * ! 6451: B$CMT ENT BL$CM ENTRY POINT (CMBLK) ! 6452: * ! 6453: * COBLK ! 6454: * ! 6455: * THE ROUTINE FOR A COBLK IS NEVER EXECUTED ! 6456: * ! 6457: B$COP ENT BL$CO ENTRY POINT (COBLK) ! 6458: * ! 6459: * CTBLK ! 6460: * ! 6461: * THE ROUTINE FOR A CTBLK IS NEVER EXECUTED ! 6462: * ! 6463: B$CTT ENT BL$CT ENTRY POINT (CTBLK) ! 6464: EJC ! 6465: * ! 6466: * DFBLK ! 6467: * ! 6468: * THE ROUTINE FOR A DFBLK IS ACCESSED FROM THE O$FNC ENTRY ! 6469: * TO CALL A DATATYPE FUNCTION AND BUILD A PDBLK. ! 6470: * ! 6471: * (XL) POINTER TO DFBLK ! 6472: * ! 6473: B$DFC ENT BL$DF ENTRY POINT ! 6474: MOV DFPDL(XL),WA LOAD LENGTH OF PDBLK ! 6475: JSR ALLOC ALLOCATE PDBLK ! 6476: MOV =B$PDT,(XR) STORE TYPE WORD ! 6477: MOV XL,PDDFP(XR) STORE DFBLK POINTER ! 6478: MOV XR,WC SAVE POINTER TO PDBLK ! 6479: ADD WA,XR POINT PAST PDBLK ! 6480: LCT WA,FARGS(XL) SET TO COUNT FIELDS ! 6481: * ! 6482: * LOOP TO ACQUIRE FIELD VALUES FROM STACK ! 6483: * ! 6484: BDFC1 MOV (XS)+,-(XR) MOVE A FIELD VALUE ! 6485: BCT WA,BDFC1 LOOP TILL ALL MOVED ! 6486: MOV WC,XR RECALL POINTER TO PDBLK ! 6487: BRN EXSID EXIT SETTING ID FIELD ! 6488: .IF .CNLD ! 6489: .ELSE ! 6490: EJC ! 6491: * ! 6492: * EFBLK ! 6493: * ! 6494: * THE ROUTINE FOR AN EFBLK IS PASSED CONTROL FORM THE O$FNC ! 6495: * ENTRY TO CALL AN EXTERNAL FUNCTION. ! 6496: * ! 6497: * (XL) POINTER TO EFBLK ! 6498: * ! 6499: B$EFC ENT BL$EF ENTRY POINT (EFBLK) ! 6500: MOV FARGS(XL),WC LOAD NUMBER OF ARGUMENTS ! 6501: WTB WC CONVERT TO OFFSET ! 6502: MOV XL,-(XS) SAVE POINTER TO EFBLK ! 6503: MOV XS,XT COPY POINTER TO ARGUMENTS ! 6504: * ! 6505: * LOOP TO CONVERT ARGUMENTS ! 6506: * ! 6507: BEFC1 ICA XT POINT TO NEXT ENTRY ! 6508: MOV (XS),XR LOAD POINTER TO EFBLK ! 6509: DCA WC DECREMENT EFTAR OFFSET ! 6510: ADD WC,XR POINT TO NEXT EFTAR ENTRY ! 6511: MOV EFTAR(XR),XR LOAD EFTAR ENTRY ! 6512: BSW XR,5,BEFC7 SWITCH ON EFTAR TYPE ! 6513: IFF 1,BEFC2 STRING ! 6514: IFF 2,BEFC3 INTEGER ! 6515: .IF .CNRA ! 6516: .ELSE ! 6517: IFF 3,BEFC4 REAL ! 6518: .FI ! 6519: .IF .CNBF ! 6520: .ELSE ! 6521: IFF 4,BEFCA BUFFER ! 6522: .FI ! 6523: ESW END OF SWITCH ON TYPE ! 6524: * ! 6525: * HERE TO CONVERT TO STRING ! 6526: * ! 6527: BEFC2 MOV (XT),-(XS) STACK ARG PTR ! 6528: JSR GTSTG CONVERT ARGUMENT TO STRING ! 6529: ERR 045,EXTERNAL FUNCTION ARGUMENT IS NOT STRING ! 6530: BRN BEFC6 JUMP TO MERGE ! 6531: EJC ! 6532: * ! 6533: * EFBLK (CONTINUED) ! 6534: * ! 6535: * HERE TO CONVERT AN INTEGER ! 6536: * ! 6537: BEFC3 MOV (XT),XR LOAD NEXT ARGUMENT ! 6538: MOV WC,BEFOF SAVE OFFSET ! 6539: JSR GTINT CONVERT TO INTEGER ! 6540: ERR 046,EXTERNAL FUNCTION ARGUMENT IS NOT INTEGER ! 6541: .IF .CNRA ! 6542: .ELSE ! 6543: BRN BEFC5 MERGE WITH REAL CASE ! 6544: * ! 6545: * HERE TO CONVERT A REAL ! 6546: * ! 6547: BEFC4 MOV (XT),XR LOAD NEXT ARGUMENT ! 6548: MOV WC,BEFOF SAVE OFFSET ! 6549: JSR GTREA CONVERT TO REAL ! 6550: ERR 047,EXTERNAL FUNCTION ARGUMENT IS NOT REAL ! 6551: * ! 6552: * INTEGER CASE MERGES HERE ! 6553: * ! 6554: .FI ! 6555: .IF .CNBF ! 6556: .ELSE ! 6557: BRN BEFC5 MERGE ! 6558: * ! 6559: * HERE TO CONVERT BUFFER ! 6560: * ! 6561: BEFCA MOV (XT),XR LOAD ARGUMENT ! 6562: MOV WC,BEFOF SAVE OFFSET ! 6563: MOV XL,-(XS) SAVE EFBLK PTR ! 6564: JSR GTBUF GET A BUFFER ! 6565: ERR 259,EXTERNAL FUNCTION ARGUMENT IS NOT BUFFER ! 6566: MOV (XS)+,XL RESTORE EFBLK PTR ! 6567: * ! 6568: * INTEGER AND REAL CASE MERGES HERE ! 6569: * ! 6570: .FI ! 6571: BEFC5 MOV BEFOF,WC RESTORE OFFSET ! 6572: * ! 6573: * STRING MERGES HERE ! 6574: * ! 6575: BEFC6 MOV XR,(XT) STORE CONVERTED RESULT ! 6576: * ! 6577: * NO CONVERSION MERGES HERE ! 6578: * ! 6579: BEFC7 BNZ WC,BEFC1 LOOP BACK IF MORE TO GO ! 6580: * ! 6581: * HERE AFTER CONVERTING ALL THE ARGUMENTS ! 6582: * ! 6583: MOV (XS)+,XL RESTORE EFBLK POINTER ! 6584: MOV FARGS(XL),WA GET NUMBER OF ARGS ! 6585: JSR SYSEX CALL ROUTINE TO CALL EXTERNAL FNC ! 6586: PPM EXFAL FAIL IF FAILURE ! 6587: EJC ! 6588: * ! 6589: * EFBLK (CONTINUED) ! 6590: * ! 6591: * RETURN HERE WITH RESULT IN XR ! 6592: * ! 6593: * FIRST DEFEND AGAINST NON-STANDARD NULL STRING RETURNED ! 6594: * ! 6595: MOV EFRSL(XL),WB GET RESULT TYPE ! 6596: BNZ WB,BEFA8 BRANCH IF NOT UNCONVERTED ! 6597: BNE (XR),=B$SCL,BEFC8 JUMP IF NOT A STRING ! 6598: BZE SCLEN(XR),EXNUL RETURN NULL IF NULL ! 6599: * ! 6600: * HERE IF CONVERTED RESULT TO CHECK FOR NULL STRING ! 6601: * ! 6602: BEFA8 BNE WB,=NUM01,BEFC8 JUMP IF NOT A STRING ! 6603: BZE SCLEN(XR),EXNUL RETURN NULL IF NULL ! 6604: * ! 6605: * RETURN IF RESULT IS IN DYNAMIC STORAGE ! 6606: * ! 6607: BEFC8 BLT XR,DNAMB,BEFC9 JUMP IF NOT IN DYNAMIC STORAGE ! 6608: BLE XR,DNAMP,EXIXR RETURN RESULT IF ALREADY DYNAMIC ! 6609: * ! 6610: * HERE WE COPY A RESULT INTO THE DYNAMIC REGION ! 6611: * ! 6612: BEFC9 MOV (XR),WA GET POSSIBLE TYPE WORD ! 6613: BZE WB,BEF11 JUMP IF UNCONVERTED RESULT ! 6614: MOV =B$SCL,WA STRING ! 6615: BEQ WB,=NUM01,BEF10 YES JUMP ! 6616: MOV =B$ICL,WA INTEGER ! 6617: BEQ WB,=NUM02,BEF10 YES JUMP ! 6618: .IF .CNRA ! 6619: .ELSE ! 6620: MOV =B$RCL,WA REAL ! 6621: BEQ WB,=NUM03,BEF10 YES JUMP ! 6622: .FI ! 6623: .IF .CNBF ! 6624: .ELSE ! 6625: MOV =B$BCT,WA BUFFER ! 6626: BEQ WB,=NUM04,BEF10 YES JUMP ! 6627: .FI ! 6628: * ! 6629: * STORE TYPE WORD IN RESULT ! 6630: * ! 6631: BEF10 MOV WA,(XR) STORED BEFORE COPYING TO DYNAMIC ! 6632: * ! 6633: * MERGE FOR UNCONVERTED RESULT ! 6634: * ! 6635: BEF11 JSR BLKLN GET LENGTH OF BLOCK ! 6636: MOV XR,XL COPY ADDRESS OF OLD BLOCK ! 6637: JSR ALLOC ALLOCATE DYNAMIC BLOCK SAME SIZE ! 6638: MOV XR,-(XS) SET POINTER TO NEW BLOCK AS RESULT ! 6639: MVW COPY OLD BLOCK TO DYNAMIC BLOCK ! 6640: BRN EXITS EXIT WITH RESULT ON STACK ! 6641: .FI ! 6642: * ! 6643: * EVBLK ! 6644: * ! 6645: * THE ROUTINE FOR AN EVBLK IS NEVER EXECUTED ! 6646: * ! 6647: B$EVT ENT BL$EV ENTRY POINT (EVBLK) ! 6648: EJC ! 6649: * ! 6650: * FFBLK ! 6651: * ! 6652: * THE ROUTINE FOR AN FFBLK IS EXECUTED FROM THE O$FNC ENTRY ! 6653: * TO CALL A FIELD FUNCTION AND EXTRACT A FIELD VALUE/NAME. ! 6654: * ! 6655: * (XL) POINTER TO FFBLK ! 6656: * ! 6657: B$FFC ENT BL$FF ENTRY POINT (FFBLK) ! 6658: MOV XL,XR COPY FFBLK POINTER ! 6659: LCW WC LOAD NEXT CODE WORD ! 6660: MOV (XS),XL LOAD PDBLK POINTER ! 6661: BNE (XL),=B$PDT,BFFC2 JUMP IF NOT PDBLK AT ALL ! 6662: MOV PDDFP(XL),WA LOAD DFBLK POINTER FROM PDBLK ! 6663: * ! 6664: * LOOP TO FIND CORRECT FFBLK FOR THIS PDBLK ! 6665: * ! 6666: BFFC1 BEQ WA,FFDFP(XR),BFFC3 JUMP IF THIS IS THE CORRECT FFBLK ! 6667: MOV FFNXT(XR),XR ELSE LINK TO NEXT FFBLK ON CHAIN ! 6668: BNZ XR,BFFC1 LOOP BACK IF ANOTHER ENTRY TO CHECK ! 6669: * ! 6670: * HERE FOR BAD ARGUMENT ! 6671: * ! 6672: BFFC2 ERB 048,FIELD FUNCTION ARGUMENT IS WRONG DATATYPE ! 6673: * ! 6674: * HERE AFTER LOCATING CORRECT FFBLK ! 6675: * ! 6676: BFFC3 MOV FFOFS(XR),WA LOAD FIELD OFFSET ! 6677: BEQ WC,=OFNE$,BFFC5 JUMP IF CALLED BY NAME ! 6678: ADD WA,XL ELSE POINT TO VALUE FIELD ! 6679: MOV (XL),XR LOAD VALUE ! 6680: BNE (XR),=B$TRT,BFFC4 JUMP IF NOT TRAPPED ! 6681: SUB WA,XL ELSE RESTORE NAME BASE,OFFSET ! 6682: MOV WC,(XS) SAVE NEXT CODE WORD OVER PDBLK PTR ! 6683: JSR ACESS ACCESS VALUE ! 6684: PPM EXFAL FAIL IF ACCESS FAILS ! 6685: MOV (XS),WC RESTORE NEXT CODE WORD ! 6686: * ! 6687: * HERE AFTER GETTING VALUE IN (XR) ! 6688: * ! 6689: BFFC4 MOV XR,(XS) STORE VALUE ON STACK (OVER PDBLK) ! 6690: MOV WC,XR COPY NEXT CODE WORD ! 6691: MOV (XR),XL LOAD ENTRY ADDRESS ! 6692: BRI XL JUMP TO ROUTINE FOR NEXT CODE WORD ! 6693: * ! 6694: * HERE IF CALLED BY NAME ! 6695: * ! 6696: BFFC5 MOV WA,-(XS) STORE NAME OFFSET (BASE IS SET) ! 6697: BRN EXITS EXIT WITH NAME ON STACK ! 6698: EJC ! 6699: * ! 6700: * ICBLK ! 6701: * ! 6702: * THE ROUTINE FOR ICBLK IS EXECUTED FROM THE GENERATED ! 6703: * CODE TO LOAD AN INTEGER VALUE ONTO THE STACK. ! 6704: * ! 6705: * (XR) POINTER TO ICBLK ! 6706: * ! 6707: B$ICL ENT BL$IC ENTRY POINT (ICBLK) ! 6708: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD ! 6709: * ! 6710: * KVBLK ! 6711: * ! 6712: * THE ROUTINE FOR A KVBLK IS NEVER EXECUTED. ! 6713: * ! 6714: B$KVT ENT BL$KV ENTRY POINT (KVBLK) ! 6715: * ! 6716: * NMBLK ! 6717: * ! 6718: * THE ROUTINE FOR A NMBLK IS EXECUTED FROM THE GENERATED ! 6719: * CODE FOR THE CASE OF LOADING A NAME ONTO THE STACK ! 6720: * WHERE THE NAME IS THAT OF A NATURAL VARIABLE WHICH CAN ! 6721: * BE PREEVALUATED AT COMPILE TIME. ! 6722: * ! 6723: * (XR) POINTER TO NMBLK ! 6724: * ! 6725: B$NML ENT BL$NM ENTRY POINT (NMBLK) ! 6726: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD ! 6727: * ! 6728: * PDBLK ! 6729: * ! 6730: * THE ROUTINE FOR A PDBLK IS NEVER EXECUTED ! 6731: * ! 6732: B$PDT ENT BL$PD ENTRY POINT (PDBLK) ! 6733: EJC ! 6734: * ! 6735: * PFBLK ! 6736: * ! 6737: * THE ROUTINE FOR A PFBLK IS EXECUTED FROM THE ENTRY O$FNC ! 6738: * TO CALL A PROGRAM DEFINED FUNCTION. ! 6739: * ! 6740: * (XL) POINTER TO PFBLK ! 6741: * ! 6742: * THE FOLLOWING STACK ENTRIES ARE MADE BEFORE PASSING ! 6743: * CONTROL TO THE PROGRAM DEFINED FUNCTION. ! 6744: * ! 6745: * SAVED VALUE OF FIRST ARGUMENT ! 6746: * . ! 6747: * SAVED VALUE OF LAST ARGUMENT ! 6748: * SAVED VALUE OF FIRST LOCAL ! 6749: * . ! 6750: * SAVED VALUE OF LAST LOCAL ! 6751: * SAVED VALUE OF FUNCTION NAME ! 6752: * SAVED CODE BLOCK PTR (R$COD) ! 6753: * SAVED CODE POINTER (-R$COD) ! 6754: * SAVED VALUE OF FLPRT ! 6755: * SAVED VALUE OF FLPTR ! 6756: * POINTER TO PFBLK ! 6757: * FLPTR --------------- ZERO (TO BE OVERWRITTEN WITH OFFS) ! 6758: * ! 6759: B$PFC ENT BL$PF ENTRY POINT (PFBLK) ! 6760: MOV XL,BPFPF SAVE PFBLK PTR (NEED NOT BE RELOC) ! 6761: MOV XL,XR COPY FOR THE MOMENT ! 6762: MOV PFVBL(XR),XL POINT TO VRBLK FOR FUNCTION ! 6763: * ! 6764: * LOOP TO FIND OLD VALUE OF FUNCTION ! 6765: * ! 6766: BPF01 MOV XL,WB SAVE POINTER ! 6767: MOV VRVAL(XL),XL LOAD VALUE ! 6768: BEQ (XL),=B$TRT,BPF01 LOOP IF TRBLK ! 6769: * ! 6770: * SET VALUE TO NULL AND SAVE OLD FUNCTION VALUE ! 6771: * ! 6772: MOV XL,BPFSV SAVE OLD VALUE ! 6773: MOV WB,XL POINT BACK TO BLOCK WITH VALUE ! 6774: MOV =NULLS,VRVAL(XL) SET VALUE TO NULL ! 6775: MOV FARGS(XR),WA LOAD NUMBER OF ARGUMENTS ! 6776: ADD *PFARG,XR POINT TO PFARG ENTRIES ! 6777: BZE WA,BPF04 JUMP IF NO ARGUMENTS ! 6778: MOV XS,XT PTR TO LAST ARG ! 6779: WTB WA CONVERT NO. OF ARGS TO BAUS OFFSET ! 6780: ADD WA,XT POINT BEFORE FIRST ARG ! 6781: MOV XT,BPFXT REMEMBER ARG POINTER ! 6782: EJC ! 6783: * ! 6784: * PFBLK (CONTINUED) ! 6785: * ! 6786: * LOOP TO SAVE OLD ARGUMENT VALUES AND SET NEW ONES ! 6787: * ! 6788: BPF02 MOV (XR)+,XL LOAD VRBLK PTR FOR NEXT ARGUMENT ! 6789: * ! 6790: * LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE ! 6791: * ! 6792: BPF03 MOV XL,WC SAVE POINTER ! 6793: MOV VRVAL(XL),XL LOAD NEXT VALUE ! 6794: BEQ (XL),=B$TRT,BPF03 LOOP BACK IF TRBLK ! 6795: * ! 6796: * SAVE OLD VALUE AND GET NEW VALUE ! 6797: * ! 6798: MOV XL,WA KEEP OLD VALUE ! 6799: MOV BPFXT,XT POINT BEFORE NEXT STACKED ARG ! 6800: MOV -(XT),WB LOAD ARGUMENT (NEW VALUE) ! 6801: MOV WA,(XT) SAVE OLD VALUE ! 6802: MOV XT,BPFXT KEEP ARG PTR FOR NEXT TIME ! 6803: MOV WC,XL POINT BACK TO BLOCK WITH VALUE ! 6804: MOV WB,VRVAL(XL) SET NEW VALUE ! 6805: BNE XS,BPFXT,BPF02 LOOP IF NOT ALL DONE ! 6806: * ! 6807: * NOW PROCESS LOCALS ! 6808: * ! 6809: BPF04 MOV BPFPF,XL RESTORE PFBLK POINTER ! 6810: MOV PFNLO(XL),WA LOAD NUMBER OF LOCALS ! 6811: BZE WA,BPF07 JUMP IF NO LOCALS ! 6812: MOV =NULLS,WB GET NULL CONSTANT ! 6813: LCT WA,WA SET LOCAL COUNTER ! 6814: * ! 6815: * LOOP TO PROCESS LOCALS ! 6816: * ! 6817: BPF05 MOV (XR)+,XL LOAD VRBLK PTR FOR NEXT LOCAL ! 6818: * ! 6819: * LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE ! 6820: * ! 6821: BPF06 MOV XL,WC SAVE POINTER ! 6822: MOV VRVAL(XL),XL LOAD NEXT VALUE ! 6823: BEQ (XL),=B$TRT,BPF06 LOOP BACK IF TRBLK ! 6824: * ! 6825: * SAVE OLD VALUE AND SET NULL AS NEW VALUE ! 6826: * ! 6827: MOV XL,-(XS) STACK OLD VALUE ! 6828: MOV WC,XL POINT BACK TO BLOCK WITH VALUE ! 6829: MOV WB,VRVAL(XL) SET NULL AS NEW VALUE ! 6830: BCT WA,BPF05 LOOP TILL ALL LOCALS PROCESSED ! 6831: EJC ! 6832: * ! 6833: * PFBLK (CONTINUED) ! 6834: * ! 6835: * HERE AFTER PROCESSING ARGUMENTS AND LOCALS ! 6836: * ! 6837: .IF .CNPF ! 6838: BPF07 MOV R$COD,WA LOAD OLD CODE BLOCK POINTER ! 6839: .ELSE ! 6840: BPF07 ZER XR ZERO REG XR IN CASE ! 6841: BZE KVPFL,BPF7C SKIP IF PROFILING IS OFF ! 6842: BEQ KVPFL,=NUM02,BPF7A BRANCH ON TYPE OF PROFILE ! 6843: * ! 6844: * HERE IF PROFILE = 1 ! 6845: * ! 6846: JSR SYSTM GET CURRENT TIME ! 6847: STI PFETM SAVE FOR A SEC ! 6848: SBI PFSTM FIND TIME USED BY CALLER ! 6849: JSR ICBLD BUILD INTO AN ICBLK ! 6850: LDI PFETM RELOAD CURRENT TIME ! 6851: BRN BPF7B MERGE ! 6852: * ! 6853: * HERE IF PROFILE = 2 ! 6854: * ! 6855: BPF7A LDI PFSTM GET START TIME OF CALLING STMT ! 6856: JSR ICBLD ASSEMBLE AN ICBLK ROUND IT ! 6857: JSR SYSTM GET NOW TIME ! 6858: * ! 6859: * BOTH TYPES OF PROFILE MERGE HERE ! 6860: * ! 6861: BPF7B STI PFSTM SET START TIME OF 1ST FUNC STMT ! 6862: MNZ PFFNC FLAG FUNCTION ENTRY ! 6863: EJC ! 6864: * ! 6865: * PFBLK (CONTINUED) ! 6866: * ! 6867: * NO PROFILING MERGES HERE ! 6868: * ! 6869: BPF7C MOV XR,-(XS) STACK ICBLK PTR (OR ZERO) ! 6870: MOV R$COD,WA LOAD OLD CODE BLOCK POINTER ! 6871: .FI ! 6872: SCP WB GET CODE POINTER ! 6873: SUB WA,WB MAKE CODE POINTER INTO OFFSET ! 6874: MOV BPFPF,XL RECALL PFBLK POINTER ! 6875: MOV BPFSV,-(XS) STACK OLD VALUE OF FUNCTION NAME ! 6876: MOV WA,-(XS) STACK CODE BLOCK POINTER ! 6877: MOV WB,-(XS) STACK CODE OFFSET ! 6878: MOV FLPRT,-(XS) STACK OLD FLPRT ! 6879: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER ! 6880: MOV XL,-(XS) STACK POINTER TO PFBLK ! 6881: ZER -(XS) DUMMY ZERO ENTRY FOR FAIL RETURN ! 6882: CHK CHECK FOR STACK OVERFLOW ! 6883: MOV XS,FLPTR SET NEW FAIL RETURN VALUE ! 6884: MOV XS,FLPRT SET NEW FLPRT ! 6885: MOV KVTRA,WA LOAD TRACE VALUE ! 6886: ADD KVFTR,WA ADD FTRACE VALUE ! 6887: BNZ WA,BPF09 JUMP IF TRACING POSSIBLE ! 6888: ICV KVFNC ELSE BUMP FNCLEVEL ! 6889: * ! 6890: * HERE TO ACTUALLY JUMP TO FUNCTION ! 6891: * ! 6892: BPF08 MOV PFCOD(XL),XR POINT TO CODE ! 6893: BRI (XR) OFF TO EXECUTE FUNCTION ! 6894: * ! 6895: * HERE IF TRACING IS POSSIBLE ! 6896: * ! 6897: BPF09 MOV PFCTR(XL),XR LOAD POSSIBLE CALL TRACE TRBLK ! 6898: MOV PFVBL(XL),XL LOAD VRBLK POINTER FOR FUNCTION ! 6899: MOV *VRVAL,WA SET NAME OFFSET FOR VARIABLE ! 6900: BZE KVTRA,BPF10 JUMP IF TRACE MODE IS OFF ! 6901: BZE XR,BPF10 OR IF THERE IS NO CALL TRACE ! 6902: * ! 6903: * HERE IF CALL TRACED ! 6904: * ! 6905: DCV KVTRA DECREMENT TRACE COUNT ! 6906: BZE TRFNC(XR),BPF11 JUMP IF PRINT TRACE ! 6907: JSR TRXEQ EXECUTE FUNCTION TYPE TRACE ! 6908: EJC ! 6909: * ! 6910: * PFBLK (CONTINUED) ! 6911: * ! 6912: * HERE TO TEST FOR FTRACE TRACE ! 6913: * ! 6914: BPF10 BZE KVFTR,BPF16 JUMP IF FTRACE IS OFF ! 6915: DCV KVFTR ELSE DECREMENT FTRACE ! 6916: * ! 6917: * HERE FOR PRINT TRACE ! 6918: * ! 6919: BPF11 JSR PRTSN PRINT STATEMENT NUMBER ! 6920: JSR PRTNM PRINT FUNCTION NAME ! 6921: MOV =CH$PP,WA LOAD LEFT PAREN ! 6922: JSR PRTCH PRINT LEFT PAREN ! 6923: MOV 1(XS),XL RECOVER PFBLK POINTER ! 6924: BZE FARGS(XL),BPF15 SKIP IF NO ARGUMENTS ! 6925: ZER WB ELSE SET ARGUMENT COUNTER ! 6926: BRN BPF13 JUMP INTO LOOP ! 6927: * ! 6928: * LOOP TO PRINT ARGUMENT VALUES ! 6929: * ! 6930: BPF12 MOV =CH$CM,WA LOAD COMMA ! 6931: JSR PRTCH PRINT TO SEPARATE FROM LAST ARG ! 6932: * ! 6933: * MERGE HERE FIRST TIME (NO COMMA REQUIRED) ! 6934: * ! 6935: BPF13 MOV WB,(XS) SAVE ARG CTR (OVER FAILOFFS IS OK) ! 6936: WTB WB CONVERT TO BAU OFFSET ! 6937: ADD WB,XL POINT TO NEXT ARGUMENT POINTER ! 6938: MOV PFARG(XL),XR LOAD NEXT ARGUMENT VRBLK PTR ! 6939: SUB WB,XL RESTORE PFBLK POINTER ! 6940: MOV VRVAL(XR),XR LOAD NEXT VALUE ! 6941: JSR PRTVL PRINT ARGUMENT VALUE ! 6942: EJC ! 6943: * ! 6944: * HERE AFTER DEALING WITH ONE ARGUMENT ! 6945: * ! 6946: MOV (XS),WB RESTORE ARGUMENT COUNTER ! 6947: ICV WB INCREMENT ARGUMENT COUNTER ! 6948: BLT WB,FARGS(XL),BPF12 LOOP IF MORE TO PRINT ! 6949: * ! 6950: * MERGE HERE IN NO ARGS CASE TO PRINT PAREN ! 6951: * ! 6952: BPF15 MOV =CH$RP,WA LOAD RIGHT PAREN ! 6953: JSR PRTCF PRINT TO TERMINATE OUTPUT ! 6954: * ! 6955: * MERGE HERE TO EXIT WITH TEST FOR FNCLEVEL TRACE ! 6956: * ! 6957: BPF16 ICV KVFNC INCREMENT FNCLEVEL ! 6958: MOV R$FNC,XL LOAD PTR TO POSSIBLE TRBLK ! 6959: JSR KTREX CALL KEYWORD TRACE ROUTINE ! 6960: * ! 6961: * CALL FUNCTION AFTER TRACE TESTS COMPLETE ! 6962: * ! 6963: MOV 1(XS),XL RESTORE PFBLK POINTER ! 6964: BRN BPF08 JUMP BACK TO EXECUTE FUNCTION ! 6965: .IF .CNRA ! 6966: .ELSE ! 6967: EJC ! 6968: * ! 6969: * RCBLK ! 6970: * ! 6971: * THE ROUTINE FOR AN RCBLK IS EXECUTED FROM THE GENERATED ! 6972: * CODE TO LOAD A REAL VALUE ONTO THE STACK. ! 6973: * ! 6974: * (XR) POINTER TO RCBLK ! 6975: * ! 6976: B$RCL ENT BL$RC ENTRY POINT (RCBLK) ! 6977: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD ! 6978: .FI ! 6979: * ! 6980: * SCBLK ! 6981: * ! 6982: * THE ROUTINE FOR AN SCBLK IS EXECUTED FROM THE GENERATED ! 6983: * CODE TO LOAD A STRING VALUE ONTO THE STACK. ! 6984: * ! 6985: * (XR) POINTER TO SCBLK ! 6986: * ! 6987: B$SCL ENT BL$SC ENTRY POINT (SCBLK) ! 6988: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD ! 6989: * ! 6990: * TBBLK ! 6991: * ! 6992: * THE ROUTINE FOR A TBBLK IS NEVER EXECUTED ! 6993: * ! 6994: B$TBT ENT BL$TB ENTRY POINT (TBBLK) ! 6995: * ! 6996: * TEBLK ! 6997: * ! 6998: * THE ROUTINE FOR A TEBLK IS NEVER EXECUTED ! 6999: * ! 7000: B$TET ENT BL$TE ENTRY POINT (TEBLK) ! 7001: * ! 7002: * VCBLK ! 7003: * ! 7004: * THE ROUTINE FOR A VCBLK IS NEVER EXECUTED ! 7005: * ! 7006: B$VCT ENT BL$VC ENTRY POINT (VCBLK) ! 7007: EJC ! 7008: * ! 7009: * VRBLK ! 7010: * ! 7011: * THE VRBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE. ! 7012: * THERE ARE SIX ENTRIES FOR VRBLK COVERING VARIOUS CASES ! 7013: * ! 7014: B$VR$ ENT BL$$I MARK START OF VRBLK ENTRY POINTS ! 7015: * ! 7016: * ENTRY FOR VRGET (TRAPPED CASE). THIS ROUTINE IS CALLED ! 7017: * FROM THE GENERATED CODE TO LOAD THE VALUE OF A VARIABLE. ! 7018: * THIS ENTRY POINT IS USED IF AN ACCESS TRACE OR INPUT ! 7019: * ASSOCIATION IS CURRENTLY ACTIVE. ! 7020: * ! 7021: * (XR) POINTER TO VRGET FIELD OF VRBLK ! 7022: * ! 7023: B$VRA ENT BL$$I ENTRY POINT ! 7024: MOV XR,XL COPY NAME BASE (VRGET = 0) ! 7025: MOV *VRVAL,WA SET NAME OFFSET ! 7026: JSR ACESS ACCESS VALUE ! 7027: PPM EXFAL FAIL IF ACCESS FAILS ! 7028: BRN EXIXR ELSE EXIT WITH RESULT IN XR ! 7029: * ! 7030: * ENTRY FOR VRSTO (ERROR CASE. THIS ROUTINE IS CALLED FROM ! 7031: * THE EXECUTED CODE FOR AN ATTEMPT TO MODIFY THE VALUE ! 7032: * OF A PROTECTED (PATTERN VALUED) NATURAL VARIABLE. ! 7033: * ! 7034: B$VRE ENT ENTRY POINT ! 7035: ERB 049,ATTEMPT TO CHANGE VALUE OF PROTECTED VARIABLE ! 7036: * ! 7037: * ENTRY FOR VRTRA (UNTRAPPED CASE). THIS ROUTINE IS CALLED ! 7038: * FROM THE EXECUTED CODE TO TRANSFER TO A LABEL. ! 7039: * ! 7040: * (XR) POINTER TO VRTRA FIELD OF VRBLK ! 7041: * ! 7042: B$VRG ENT ENTRY POINT ! 7043: MOV VRLBO(XR),XR LOAD CODE POINTER ! 7044: MOV (XR),XL LOAD ENTRY ADDRESS ! 7045: BRI XL JUMP TO ROUTINE FOR NEXT CODE WORD ! 7046: * ! 7047: * ENTRY FOR VRGET (UNTRAPPED CASE). THIS ROUTINE IS CALLED ! 7048: * FROM THE GENERATED CODE TO LOAD THE VALUE OF A VARIABLE. ! 7049: * ! 7050: * (XR) POINTS TO VRGET FIELD OF VRBLK ! 7051: * ! 7052: B$VRL ENT ENTRY POINT ! 7053: MOV VRVAL(XR),-(XS) LOAD VALUE ONTO STACK (VRGET = 0) ! 7054: BRN EXITS OBEY NEXT CODE WORD ! 7055: EJC ! 7056: * ! 7057: * VRBLK (CONTINUED) ! 7058: * ! 7059: * ENTRY FOR VRSTO (UNTRAPPED CASE). THIS ROUTINE IS CALLED ! 7060: * FROM THE GENERATED CODE TO STORE THE VALUE OF A VARIABLE. ! 7061: * ! 7062: * (XR) POINTER TO VRSTO FIELD OF VRBLK ! 7063: * ! 7064: B$VRS ENT ENTRY POINT ! 7065: MOV (XS),VRVLO(XR) STORE VALUE, LEAVE ON STACK ! 7066: BRN EXITS OBEY NEXT CODE WORD ! 7067: * ! 7068: * VRTRA (TRAPPED CASE). THIS ROUTINE IS CALLED FROM THE ! 7069: * GENERATED CODE TO TRANSFER TO A LABEL WHEN A LABEL ! 7070: * TRACE IS CURRENTLY ACTIVE. ! 7071: * ! 7072: B$VRT ENT ENTRY POINT ! 7073: SUB *VRTRA,XR POINT BACK TO START OF VRBLK ! 7074: MOV XR,XL COPY VRBLK POINTER ! 7075: MOV *VRVAL,WA SET NAME OFFSET ! 7076: MOV VRLBL(XL),XR LOAD POINTER TO TRBLK ! 7077: BZE KVTRA,BVRT2 JUMP IF TRACE IS OFF ! 7078: DCV KVTRA ELSE DECREMENT TRACE COUNT ! 7079: BZE TRFNC(XR),BVRT1 JUMP IF PRINT TRACE CASE ! 7080: JSR TRXEQ ELSE EXECUTE FULL TRACE ! 7081: BRN BVRT2 MERGE TO JUMP TO LABEL ! 7082: * ! 7083: * HERE FOR PRINT TRACE -- PRINT COLON ( LABEL NAME ) ! 7084: * ! 7085: BVRT1 JSR PRTSN PRINT STATEMENT NUMBER ! 7086: MOV XL,XR COPY VRBLK POINTER ! 7087: MOV =CH$CL,WA COLON ! 7088: JSR PRTCH PRINT IT ! 7089: MOV =CH$PP,WA LEFT PAREN ! 7090: JSR PRTCH PRINT IT ! 7091: JSR PRTVN PRINT LABEL NAME ! 7092: MOV =CH$RP,WA RIGHT PAREN ! 7093: JSR PRTCF PRINT IT ! 7094: MOV VRLBL(XL),XR POINT BACK TO TRBLK ! 7095: * ! 7096: * MERGE HERE TO JUMP TO LABEL ! 7097: * ! 7098: BVRT2 MOV TRLBL(XR),XR LOAD POINTER TO ACTUAL CODE ! 7099: BRI (XR) EXECUTE STATEMENT AT LABEL ! 7100: EJC ! 7101: * ! 7102: * VRBLK (CONTINUED) ! 7103: * ! 7104: * ENTRY FOR VRSTO (TRAPPED CASE). THIS ROUTINE IS CALLED ! 7105: * FROM THE GENERATED CODE TO STORE THE VALUE OF A VARIABLE. ! 7106: * THIS ENTRY IS USED WHEN A VALUE TRACE OR OUTPUT ! 7107: * ASSOCIATION IS CURRENTLY ACTIVE. ! 7108: * ! 7109: * (XR) POINTER TO VRSTO FIELD OF VRBLK ! 7110: * ! 7111: B$VRV ENT ENTRY POINT ! 7112: MOV (XS),WB LOAD VALUE (LEAVE COPY ON STACK) ! 7113: SUB *VRSTO,XR POINT TO VRBLK ! 7114: MOV XR,XL COPY VRBLK POINTER ! 7115: MOV *VRVAL,WA SET OFFSET ! 7116: JSR ASIGN CALL ASSIGNMENT ROUTINE ! 7117: PPM EXFAL FAIL IF ASSIGNMENT FAILS ! 7118: BRN EXITS ELSE RETURN WITH RESULT ON STACK ! 7119: EJC ! 7120: * ! 7121: * XNBLK ! 7122: * ! 7123: * THE ROUTINE FOR AN XNBLK IS NEVER EXECUTED ! 7124: * ! 7125: B$XNT ENT BL$XN ENTRY POINT (XNBLK) ! 7126: * ! 7127: * XRBLK ! 7128: * ! 7129: * THE ROUTINE FOR AN XRBLK IS NEVER EXECUTED ! 7130: * ! 7131: B$XRT ENT BL$XR ENTRY POINT (XRBLK) ! 7132: * ! 7133: * MARK ENTRY ADDRESS PAST LAST BLOCK ACTION ROUTINE ! 7134: * ! 7135: B$YYY ENT BL$$I LAST BLOCK ROUTINE ENTRY POINT ! 7136: TTL S P I T B O L -- PATTERN MATCHING ROUTINES ! 7137: * ! 7138: * THE FOLLOWING SECTION CONSISTS OF THE PATTERN MATCHING ! 7139: * ROUTINES. ALL PATTERN NODES CONTAIN A POINTER (PCODE) ! 7140: * TO ONE OF THE ROUTINES IN THIS SECTION (P$XXX). ! 7141: * ! 7142: * NOTE THAT THIS SECTION FOLLOWS THE B$XXX ROUTINES TO ! 7143: * ENABLE A FAST TEST FOR THE PATTERN DATATYPE. ! 7144: * ! 7145: P$AAA ENT BL$$I ENTRY TO MARK FIRST PATTERN ! 7146: * ! 7147: * ! 7148: * THE ENTRY CONDITIONS TO THE MATCH ROUTINE ARE AS FOLLOWS ! 7149: * (SEE O$PMN, O$PMV, O$PMS AND PROCEDURE MATCH). ! 7150: * ! 7151: * STACK CONTENTS. ! 7152: * ! 7153: * NAME BASE (O$PMN ONLY) ! 7154: * NAME OFFSET (O$PMN ONLY) ! 7155: * TYPE (0-O$PMN, 1-O$PMV, 2-O$PMS) ! 7156: * PMHBS --------------- INITIAL CURSOR (ZERO) ! 7157: * INITIAL NODE POINTER ! 7158: * XS ------------------ =NDABO (ANCHORED), =NDUNA (UNANCH) ! 7159: * ! 7160: * REGISTER VALUES. ! 7161: * ! 7162: * (XS) SET AS SHOWN IN STACK DIAGRAM ! 7163: * (XR) POINTER TO INITIAL PATTERN NODE ! 7164: * (WB) INITIAL CURSOR (ZERO) ! 7165: * ! 7166: * GLOBAL PATTERN VALUES ! 7167: * ! 7168: * R$PMS POINTER TO SUBJECT STRING SCBLK ! 7169: * PMSSL LENGTH OF SUBJECT STRING IN CHARS ! 7170: * PMDFL DOT FLAG, INITIALLY ZERO ! 7171: * PMHBS SET AS SHOWN IN STACK DIAGRAM ! 7172: * ! 7173: * CONTROL IS PASSED BY BRANCHING THROUGH THE PCODE ! 7174: * FIELD OF THE INITIAL PATTERN NODE (BRI (XR)). ! 7175: EJC ! 7176: * ! 7177: * DESCRIPTION OF ALGORITHM ! 7178: * ! 7179: * A PATTERN STRUCTURE IS REPRESENTED AS A LINKED GRAPH ! 7180: * OF NODES WITH THE FOLLOWING STRUCTURE. ! 7181: * ! 7182: * +------------------------------------+ ! 7183: * I PCODE I ! 7184: * +------------------------------------+ ! 7185: * I PTHEN I ! 7186: * +------------------------------------+ ! 7187: * I PARM1 I ! 7188: * +------------------------------------+ ! 7189: * I PARM2 I ! 7190: * +------------------------------------+ ! 7191: * ! 7192: * PCODE IS A POINTER TO THE ROUTINE WHICH WILL PERFORM ! 7193: * THE MATCH OF THIS PARTICULAR NODE TYPE. ! 7194: * ! 7195: * PTHEN IS A POINTER TO THE SUCCESSOR NODE. I.E. THE NODE ! 7196: * TO BE MATCHED IF THE ATTEMPT TO MATCH THIS NODE SUCCEEDS. ! 7197: * IF THIS IS THE LAST NODE OF THE PATTERN PTHEN POINTS ! 7198: * TO THE DUMMY NODE NDNTH WHICH INITIATES PATTERN EXIT. ! 7199: * ! 7200: * PARM1, PARM2 ARE PARAMETERS WHOSE USE VARIES WITH THE ! 7201: * PARTICULAR NODE. THEY ARE ONLY PRESENT IF REQUIRED. ! 7202: * ! 7203: * ALTERNATIVES ARE HANDLED WITH THE SPECIAL ALTERNATIVE ! 7204: * NODE WHOSE PARAMETER POINTS TO THE NODE TO BE MATCHED ! 7205: * IF THERE IS A FAILURE ON THE SUCCESSOR PATH. ! 7206: * ! 7207: * THE FOLLOWING EXAMPLE ILLUSTRATES THE MANNER IN WHICH ! 7208: * THE STRUCTURE IS BUILT UP. THE PATTERN IS ! 7209: * ! 7210: * (A / B / C) (D / E) WHERE / IS ALTERNATION ! 7211: * ! 7212: * IN THE DIAGRAM, THE NODE MARKED + REPRESENTS AN ! 7213: * ALTERNATIVE NODE AND THE DOTTED LINE FROM A + NODE ! 7214: * REPRESENTS THE PARAMETER POINTER TO THE ALTERNATIVE. ! 7215: * ! 7216: * +---+ +---+ +---+ +---+ ! 7217: * I + I-----I A I-----I + I-----I D I----- ! 7218: * +---+ +---+ I +---+ +---+ ! 7219: * . I . ! 7220: * . I . ! 7221: * +---+ +---+ I +---+ ! 7222: * I + I-----I B I--I I E I----- ! 7223: * +---+ +---+ I +---+ ! 7224: * . I ! 7225: * . I ! 7226: * +---+ I ! 7227: * I C I------------I ! 7228: * +---+ ! 7229: EJC ! 7230: * ! 7231: * DURING THE MATCH, THE REGISTERS ARE USED AS FOLLOWS. ! 7232: * ! 7233: * (XR) POINTS TO THE CURRENT NODE ! 7234: * (XL) SCRATCH ! 7235: * (XS) MAIN STACK POINTER ! 7236: * (WB) CURSOR (NUMBER OF CHARS MATCHED) ! 7237: * (WA,WC) SCRATCH ! 7238: * ! 7239: * TO KEEP TRACK OF ALTERNATIVES, THE MAIN STACK IS USED AS ! 7240: * A HISTORY STACK AND CONTAINS TWO WORD ENTRIES. ! 7241: * ! 7242: * WORD 1 SAVED CURSOR VALUE ! 7243: * WORD 2 NODE TO MATCH ON FAILURE ! 7244: * ! 7245: * WHEN A FAILURE OCCURS, THE MOST RECENT ENTRY ON THIS ! 7246: * STACK IS POPPED OFF TO RESTORE THE CURSOR AND POINT ! 7247: * TO THE NODE TO BE MATCHED AS AN ALTERNATIVE. THE ENTRY ! 7248: * AT THE BOTTOM OF THE STACK POINTS TO THE FOLLOWING ! 7249: * SPECIAL NODES DEPENDING ON THE SCAN MODE. ! 7250: * ! 7251: * ANCHORED MODE THE BOTTOM ENTRY POINTS TO THE ! 7252: * SPECIAL NODE NDABO WHICH CAUSES AN ! 7253: * ABORT. THE CURSOR VALUE STORED ! 7254: * WITH THIS ENTRY IS ALWAYS ZERO. ! 7255: * ! 7256: * UNANCHORED MODE THE BOTTOM ENTRY POINTS TO THE ! 7257: * SPECIAL NODE NDUNA WHICH MOVES THE ! 7258: * ANCHOR POINT AND RESTARTS THE MATCH ! 7259: * THE CURSOR SAVED WITH THIS ENTRY ! 7260: * IS THE NUMBER OF CHARACTERS WHICH ! 7261: * LIE BEFORE THE INITIAL ANCHOR POINT ! 7262: * (I.E. THE NUMBER OF ANCHOR MOVES). ! 7263: * THIS ENTRY IS THREE WORDS LONG AND ! 7264: * ALSO CONTAINS THE INITIAL PATTERN. ! 7265: * ! 7266: * ENTRIES ARE MADE ON THIS HISTORY STACK BY ALTERNATIVE ! 7267: * NODES AND BY SOME SPECIAL COMPOUD PATTERNS AS DESCRIBED ! 7268: * LATER ON. THE FOLLOWING GLOBAL LOCATIONS ARE USED DURING ! 7269: * PATTERN MATCHING. ! 7270: * ! 7271: * R$PMS POINTER TO SUBJECT STRING ! 7272: * PMSSL LENGTH OF SUBJECT STRING ! 7273: * PMDFL FLAG SET NON-ZERO FOR DOT PATTERNS ! 7274: * PMHBS BASE PTR FOR CURRENT HISTORY STACK ! 7275: * ! 7276: * THE FOLLOWING EXIT POINTS ARE AVAILABLE TO MATCH ROUTINES ! 7277: * ! 7278: * SUCCP SUCCESS IN MATCHING CURRENT NODE ! 7279: * FAILP FAILURE IN MATCHING CURRENT NODE ! 7280: EJC ! 7281: * ! 7282: * COMPOUND PATTERNS ! 7283: * ! 7284: * SOME PATTERNS HAVE IMPLICIT ALTERNATIVES AND THEIR ! 7285: * REPRESENTATION IN THE PATTERN STRUCTURE CONSISTS OF A ! 7286: * LINKED SET OF NODES AS INDICATED BY THESE DIAGRAMS. ! 7287: * ! 7288: * AS BEFORE, THE + REPRESENTS AN ALTERNATIVE NODE AND ! 7289: * THE DOTTED LINE FROM A + NODE IS THE PARAMETER POINTER ! 7290: * TO THE ALTERNATIVE PATTERN. ! 7291: * ! 7292: * ARB ! 7293: * --- ! 7294: * ! 7295: * +---+ THIS NODE (P$ARB) MATCHES NULL ! 7296: * I B I----- AND STACKS CURSOR, SUCCESSOR PTR, ! 7297: * +---+ CURSOR (COPY) AND A PTR TO NDARC. ! 7298: * ! 7299: * ! 7300: * ! 7301: * ! 7302: * BAL ! 7303: * --- ! 7304: * ! 7305: * +---+ THE P$BAL NODE SCANS A BALANCED ! 7306: * I B I----- STRING AND THEN STACKS A POINTER ! 7307: * +---+ TO ITSELF ON THE HISTORY STACK. ! 7308: EJC ! 7309: * ! 7310: * COMPOUND PATTERN STRUCTURES (CONTINUED) ! 7311: * ! 7312: * ! 7313: * ARBNO ! 7314: * ----- ! 7315: * ! 7316: * +---+ THIS ALTERNATIVE NODE MATCHES NULL ! 7317: * +----I + I----- THE FIRST TIME AND STACKS A POINTER ! 7318: * I +---+ TO THE ARGUMENT PATTERN X. ! 7319: * I . ! 7320: * I . ! 7321: * I +---+ NODE (P$ABA) TO STACK CURSOR ! 7322: * I I A I AND HISTORY STACK BASE PTR. ! 7323: * I +---+ ! 7324: * I I ! 7325: * I I ! 7326: * I +---+ THIS IS THE ARGUMENT PATTERN. AS ! 7327: * I I X I INDICATED, THE SUCCESSOR OF THE ! 7328: * I +---+ PATTERN IS THE P$ABC NODE ! 7329: * I I ! 7330: * I I ! 7331: * I +---+ THIS NODE (P$ABC) POPS PMHBS, ! 7332: * +----I C I STACKS OLD PMHBS AND PTR TO NDABD ! 7333: * +---+ (UNLESS OPTIMISATION HAS OCCURRED) ! 7334: * ! 7335: * STRUCTURE AND EXECUTION OF THIS PATTERN RESEMBLE THOSE OF ! 7336: * RECURSIVE PATTERN MATCHING AND IMMEDIATE ASSIGNMENT. ! 7337: * THE ALTERNATIVE NODE AT THE HEAD OF THE STRUCTURE MATCHES ! 7338: * NULL INITIALLY BUT ON SUBSEQUENT FAILURE ENSURES ATTEMPT ! 7339: * TO MATCH THE ARGUMENT. BEFORE THE ARGUMENT IS MATCHED ! 7340: * P$ABA STACKS THE CURSOR,PMHBS AND A PTR TO P$ABB. IF ! 7341: * THE ARGUMENT CANT BE MATCHED , P$ABB REMOVES THIS SPECIAL ! 7342: * STACK ENTRY AND FAILS. ! 7343: * IF ARGUMENT IS MATCHED , P$ABC RESTORES THE OUTER PMHBS ! 7344: * VALUE (SAVED BY P$ABA) . THEN IF THE ARGUMENT HAS LEFT ! 7345: * ALTERNATIVES ON STACK IT STACKS THE INNER VALUE OF PMHBS ! 7346: * AND A PTR TO NDABD. IF ARGUMENT LEFT NOTHING ON THE STACK ! 7347: * IT OPTIMISES BY REMOVING ITEMS STACKED BY P$ABA. FINALLY ! 7348: * A CHECK IS MADE THAT ARGUMENT MATCHED MORE THAN THE NULL ! 7349: * STRING (CHECK IS INTENDED TO PREVENT USELESS LOOPING). ! 7350: * IF SO THE SUCCESSOR IS AGAIN THE ALTERNATIVE NODE AT THE ! 7351: * HEAD OF THE STRUCTURE , ENSURING A POSSIBLE EXTRA ATTEMPT ! 7352: * TO MATCH THE ARG IF NECESSARY. IF NOT , THE SUCCESSOR TO ! 7353: * ALTERNATIVE IS TAKEN SO AS TO TERMINATE THE LOOP. P$ABD ! 7354: * RESTORES INNER PMHBS PTR AND FAILS , THUS TRYING TO MATCH ! 7355: * ALTERNATIVES LEFT BY THE ARBNO ARGUMENT. ! 7356: EJC ! 7357: * ! 7358: * COMPOUND PATTERN STRUCTURES (CONTINUED) ! 7359: * ! 7360: * BREAKX ! 7361: * ------ ! 7362: * ! 7363: * +---+ THIS NODE IS A BREAK NODE FOR ! 7364: * +----I B I THE ARGUMENT TO BREAKX, IDENTICAL ! 7365: * I +---+ TO AN ORDINARY BREAK NODE. ! 7366: * I I ! 7367: * I I ! 7368: * I +---+ THIS ALTERNATIVE NODE STACKS A ! 7369: * I I + I----- POINTER TO THE BREAKX NODE TO ! 7370: * I +---+ ALLOW FOR SUBSEQUENT FAILURE ! 7371: * I . ! 7372: * I . ! 7373: * I +---+ THIS IS THE BREAKX NODE ITSELF. IT ! 7374: * +----I X I MATCHES ONE CHARACTER AND THEN ! 7375: * +---+ PROCEEDS BACK TO THE BREAK NODE. ! 7376: * ! 7377: * ! 7378: * ! 7379: * ! 7380: * FENCE ! 7381: * ----- ! 7382: * ! 7383: * +---+ THE FENCE NODE MATCHES NULL AND ! 7384: * I F I----- STACKS A POINTER TO NODE NDABO TO ! 7385: * +---+ ABORT ON A SUBSEQUENT REMATCH ! 7386: * ! 7387: * ! 7388: * ! 7389: * ! 7390: * SUCCEED ! 7391: * ------- ! 7392: * ! 7393: * +---+ THE NODE FOR SUCCEED MATCHES NULL ! 7394: * I S I----- AND STACKS A POINTER TO ITSELF ! 7395: * +---+ TO REPEAT THE MATCH ON A FAILURE. ! 7396: EJC ! 7397: * ! 7398: * COMPOUND PATTERNS (CONTINUED) ! 7399: * ! 7400: * BINARY DOT (PATTERN ASSIGNMENT) ! 7401: * ------------------------------- ! 7402: * ! 7403: * +---+ THIS NODE (P$PAA) SAVES THE CURRENT ! 7404: * I A I CURSOR AND A POINTER TO THE ! 7405: * +---+ SPECIAL NODE NDPAB ON THE STACK. ! 7406: * I ! 7407: * I ! 7408: * +---+ THIS IS THE STRUCTURE FOR THE ! 7409: * I X I PATTERN LEFT ARGUMENT OF THE ! 7410: * +---+ PATTERN ASSIGNMENT CALL. ! 7411: * I ! 7412: * I ! 7413: * +---+ THIS NODE (P$PAC) SAVES THE CURSOR, ! 7414: * I C I----- A PTR TO ITSELF, THE CURSOR (COPY) ! 7415: * +---+ AND A PTR TO NDPAD ON THE STACK. ! 7416: * ! 7417: * ! 7418: * THE FUNCTION OF THE MATCH ROUTINE FOR NDPAB (P$PAB) ! 7419: * IS SIMPLY TO UNSTACK ITSELF AND FAIL BACK ONTO THE STACK. ! 7420: * ! 7421: * THE MATCH ROUTINE FOR P$PAC ALSO SETS THE GLOBAL PATTERN ! 7422: * FLAG PMDFL NON-ZERO TO INDICATE THAT PATTERN ASSIGNMENTS ! 7423: * MAY HAVE OCCURED IN THE PATTERN MATCH ! 7424: * ! 7425: * IF PMDFL IS SET AT THE END OF THE MATCH (SEE P$NTH), THE ! 7426: * HISTORY STACK IS SCANNED FOR MATCHING NDPAB-NDPAD PAIRS ! 7427: * AND THE CORRESPONDING PATTERN ASSIGNMENTS ARE EXECUTED. ! 7428: * ! 7429: * THE FUNCTION OF THE MATCH ROUTINE FOR NDPAD (P$PAD) ! 7430: * IS SIMPLY TO REMOVE ITS ENTRY FROM THE STACK AND FAIL. ! 7431: * THIS INCLUDES REMOVING THE SPECIAL NODE POINTER STORED ! 7432: * IN ADDITION TO THE STANDARD TWO ENTRIES ON THE STACK. ! 7433: .IF .CNFN ! 7434: .ELSE ! 7435: EJC ! 7436: * ! 7437: * FENCE (FUNCTION) ! 7438: * ---------------- ! 7439: * ! 7440: * +---+ THIS NODE (P$FNA) SAVES THE ! 7441: * I A I CURRENT HISTORY STACK AND A ! 7442: * +---+ POINTER TO NDFNB ON THE STACK. ! 7443: * I ! 7444: * I ! 7445: * +---+ THIS IS THE PATTERN STRUCTURE ! 7446: * I X I GIVEN AS THE ARGUMENT TO THE ! 7447: * +---+ FENCE FUNCTION. ! 7448: * I ! 7449: * I ! 7450: * +---+ THIS NODE P$FNC RESTORES THE OUTER ! 7451: * I C I HISTORY STACK PTR SAVED IN P$FNA, ! 7452: * +---+ AND STACKS THE INNER STACK BASE ! 7453: * PTR AND A POINTER TO NDFND ON THE ! 7454: * STACK. ! 7455: * ! 7456: * NDFNB (F$FNB) SIMPLY IS THE FAILURE EXIT FOR PATTERN ! 7457: * ARGUMENT FAILURE, AND IT POPS ITSELF AND FAILS ONTO THE ! 7458: * STACK. ! 7459: * ! 7460: * THE MATCH ROUTINE P$FNC ALLOWS FOR AN OPTIMIZATION WHEN ! 7461: * THE FENCE PATTERN LEAVES NO ALTERNATIVES. IN THIS CASE, ! 7462: * THE NDFNB ENTRY IS POPPED, AND THE MATCH CONTINUES. ! 7463: * ! 7464: * NDFND (P$FND) IS ENTERED WHEN THE PATTERN FAILS AFTER ! 7465: * GOING THROUGH A NON-OPTIMIZED P$FNC, AND IT POPS THE ! 7466: * STACK BACK PAST THE INNER STACK BASE CREATED BY P$FNA ! 7467: .FI ! 7468: EJC ! 7469: * ! 7470: * COMPOUND PATTERNS (CONTINUED) ! 7471: * ! 7472: * EXPRESSION PATTERNS (RECURSIVE PATTERN MATCHES) ! 7473: * ----------------------------------------------- ! 7474: * ! 7475: * INITIAL ENTRY FOR A PATTERN NODE IS TO THE ROUTINE P$EXA. ! 7476: * IF THE EVALUATED RESULT OF THE EXPRESSION IS ITSELF A ! 7477: * PATTERN, THEN THE FOLLOWING STEPS ARE TAKEN TO ARRANGE ! 7478: * FOR PROPER RECURSIVE PROCESSING. ! 7479: * ! 7480: * 1) A POINTER TO THE CURRENT NODE (THE P$EXA NODE) IS ! 7481: * STORED ON THE HISTORY STACK WITH A DUMMY CURSOR. ! 7482: * ! 7483: * 2) A SPECIAL HISTORY STACK ENTRY IS MADE IN WHICH THE ! 7484: * NODE POINTER POINTS TO NDEXB, AND THE CURSOR VALUE ! 7485: * IS THE SAVED VALUE OF PMHBS ON ENTRY TO THIS NODE. ! 7486: * THE MATCH ROUTINE FOR NDEXB (P$EXB) RESTORES PMHBS ! 7487: * FROM THIS CURSOR ENTRY, POPS OFF THE P$EXA NODE ! 7488: * POINTER AND FAILS. ! 7489: * ! 7490: * 3) THE RESULTING HISTORY STACK POINTER IS SAVED IN ! 7491: * PMHBS TO ESTABLISH A NEW LEVEL OF HISTORY STACK. ! 7492: * ! 7493: * AFTER MATCHING A PATTERN, THE END OF MATCH ROUTINE GETS ! 7494: * CONTROL (P$NTH). THIS ROUTINE PROCEEDS AS FOLLOWS. ! 7495: * ! 7496: * 1) LOAD THE CURRENT VALUE OF PMHBS AND RECOGNIZE THE ! 7497: * OUTER LEVEL CASE BY THE FACT THAT THE ASSOCIATED ! 7498: * CURSOR IN THIS CASE IS THE PATTERN MATCH TYPE CODE ! 7499: * WHICH IS LESS THAN 3. TERMINATE THE MATCH IN THIS ! 7500: * CASE AND CONTINUE EXECUTION OF THE PROGRAM. ! 7501: * ! 7502: * 2) OTHERWISE MAKE A SPECIAL HISTORY STACK ENTRY IN ! 7503: * WHICH THE NODE POINTER POINTS TO THE SPECIAL NODE ! 7504: * NDEXC AND THE CURSOR IS THE CURRENT VALUE OF PMHBS. ! 7505: * THE MATCH ROUTINE FOR NDEXC (P$EXC) RESETS PMHBS TO ! 7506: * THIS (INNER) VALUE AND AND THEN FAILS. ! 7507: * ! 7508: * 3) USING THE HISTORY STACK ENTRY MADE ON STARTING THE ! 7509: * EXPRESSION (ACCESSIBLE WITH THE CURRENT VALUE OF ! 7510: * PMHBS), RESTORE THE P$EXA NODE POINTER AND THE OLD ! 7511: * PMHBS SETTING. TAKE THE SUCCESSOR AND CONTINUE. ! 7512: * ! 7513: * AN OPTIMIZATION IS POSSIBLE IF THE EXPRESSION PATTERN ! 7514: * MAKES NO ENTRIES ON THE HISTORY STACK. IN THIS CASE, ! 7515: * INSTEAD OF BUILDING THE P$EXC NODE IN STEP 2, IT IS MORE ! 7516: * EFFICIENT TO SIMPLY POP OFF THE P$EXB ENTRY AND ITS ! 7517: * ASSOCIATED NODE POINTER. THE EFFECT IS THE SAME. ! 7518: EJC ! 7519: * ! 7520: * COMPOUND PATTERNS (CONTINUED) ! 7521: * ! 7522: * BINARY DOLLAR (IMMEDIATE ASSIGNMENT) ! 7523: * ------------------------------------ ! 7524: * ! 7525: * +---+ THIS NODE (P$IMA) STACKS THE CURSOR ! 7526: * I A I PMHBS AND A PTR TO NDIMB AND RESETS ! 7527: * +---+ THE STACK PTR PMHBS. ! 7528: * I ! 7529: * I ! 7530: * +---+ THIS IS THE LEFT STRUCTURE FOR THE ! 7531: * I X I PATTERN LEFT ARGUMENT OF THE ! 7532: * +---+ IMMEDIATE ASSIGNMENT CALL. ! 7533: * I ! 7534: * I ! 7535: * +---+ THIS NODE (P$IMC) PERFORMS THE ! 7536: * I C I----- ASSIGNMENT, POPS PMHBS AND STACKS ! 7537: * +---+ THE OLD PMHBS AND A PTR TO NDIMD. ! 7538: * ! 7539: * ! 7540: * THE STRUCTURE AND EXECUTION OF THIS PATTERN ARE SIMILAR ! 7541: * TO THOSE OF THE RECURSIVE EXPRESSION PATTERN MATCHING. ! 7542: * ! 7543: * THE MATCH ROUTINE FOR NDIMB (P$IMB) RESTORES THE OUTER ! 7544: * LEVEL VALUE OF PMHBS, UNSTACKS THE SAVED CURSOR AND FAILS ! 7545: * ! 7546: * THE MATCH ROUTINE P$IMC USES THE CURRENT VALUE OF PMHBS ! 7547: * TO LOCATE THE P$IMB ENTRY. THIS ENTRY IS USED TO MAKE ! 7548: * THE ASSIGNMENT AND RESTORE THE OUTER LEVEL VALUE OF ! 7549: * PMHBS. FINALLY, THE INNER LEVEL VALUE OF PMHBS AND A ! 7550: * POINTER TO THE SPECIAL NODE NDIMD ARE STACKED. ! 7551: * ! 7552: * THE MATCH ROUTINE FOR NDIMD (P$IMD) RESTORES THE INNER ! 7553: * LEVEL VALUE OF PMHBS AND FAILS BACK INTO THE STACK. ! 7554: * ! 7555: * AN OPTIMIZATION OCCURS IF THE INNER PATTERN MAKES NO ! 7556: * ENTRIES ON THE HISTORY STACK. IN THIS CASE, P$IMC POPS ! 7557: * THE P$IMB ENTRY INSTEAD OF MAKING A P$IMD ENTRY. ! 7558: EJC ! 7559: * ! 7560: * ARBNO ! 7561: * ! 7562: * SEE COMPOUND PATTERNS SECTION FOR STUCTURE AND ! 7563: * ALGORITHM FOR MATCHING THIS NODE TYPE. ! 7564: * ! 7565: * NO PARAMETERS ! 7566: * ! 7567: P$ABA ENT BL$P0 P0BLK ! 7568: MOV WB,-(XS) STACK CURSOR ! 7569: MOV XR,-(XS) STACK DUMMY NODE PTR ! 7570: MOV PMHBS,-(XS) STACK OLD STACK BASE PTR ! 7571: MOV =NDABB,-(XS) STACK PTR TO NODE NDABB ! 7572: MOV XS,PMHBS STORE NEW STACK BASE PTR ! 7573: BRN SUCCP SUCCEED ! 7574: * ! 7575: * ARBNO (REMOVE P$ABA SPECIAL STACK ENTRY) ! 7576: * ! 7577: * NO PARAMETERS (DUMMY PATTERN) ! 7578: * ! 7579: P$ABB ENT ENTRY POINT ! 7580: MOV WB,PMHBS RESTORE HISTORY STACK BASE PTR ! 7581: BRN FLPOP FAIL AND POP DUMMY NODE PTR ! 7582: * ! 7583: * ARBNO (CHECK IF ARG MATCHED NULL STRING) ! 7584: * ! 7585: * NO PARAMETERS (DUMMY PATTERN) ! 7586: * ! 7587: P$ABC ENT BL$P0 P0BLK ! 7588: MOV PMHBS,XT KEEP P$ABB STACK BASE ! 7589: MOV 3(XT),WA LOAD INITIAL CURSOR ! 7590: MOV 1(XT),PMHBS RESTORE OUTER STACK BASE PTR ! 7591: BEQ XT,XS,PABC1 JUMP IF NO HISTORY STACK ENTRIES ! 7592: MOV XT,-(XS) ELSE SAVE INNER PMHBS ENTRY ! 7593: MOV =NDABD,-(XS) STACK PTR TO SPECIAL NODE NDABD ! 7594: BRN PABC2 MERGE ! 7595: * ! 7596: * OPTIMISE CASE OF NO EXTRA ENTRIES ON STACK FROM ARBNO ARG ! 7597: * ! 7598: PABC1 ADD *NUM04,XS REMOVE NDABB ENTRY AND CURSOR ! 7599: * ! 7600: * MERGE TO CHECK FOR MATCHING OF NULL STRING ! 7601: * ! 7602: PABC2 BNE WA,WB,SUCCP ALLOW FURTHER ATTEMPT IF NON-NULL ! 7603: MOV PTHEN(XR),XR BYPASS ALTERNATIVE NODE SO AS TO .. ! 7604: BRN SUCCP ... REFUSE FURTHER MATCH ATTEMPTS ! 7605: * ! 7606: * ARBNO (TRY FOR ALTERNATIVES IN ARBNO ARGUMENT) ! 7607: * ! 7608: * NO PARAMETERS (DUMMY PATTERN) ! 7609: * ! 7610: P$ABD ENT ENTRY POINT ! 7611: MOV WB,PMHBS RESTORE INNER STACK BASE PTR ! 7612: BRN FAILP AND FAIL ! 7613: EJC ! 7614: * ! 7615: * ABORT ! 7616: * ! 7617: * NO PARAMETERS ! 7618: * ! 7619: P$ABO ENT BL$P0 P0BLK ! 7620: BRN EXFAL SIGNAL STATEMENT FAILURE ! 7621: * ! 7622: * ALTERNATION ! 7623: * ! 7624: * PARM1 ALTERNATIVE NODE ! 7625: * ! 7626: P$ALT ENT BL$P1 P1BLK ! 7627: MOV WB,-(XS) STACK CURSOR ! 7628: MOV PARM1(XR),-(XS) STACK POINTER TO ALTERNATIVE ! 7629: CHK CHECK FOR STACK OVERFLOW ! 7630: BRN SUCCP IF ALL OK, THEN SUCCEED ! 7631: EJC ! 7632: * ! 7633: * ANY (ONE CHARACTER ARGUMENT) (1-CHAR STRING ALSO) ! 7634: * ! 7635: * PARM1 CHARACTER ARGUMENT ! 7636: * ! 7637: P$ANS ENT BL$P1 P1BLK ! 7638: BEQ WB,PMSSL,FAILP FAIL IF NO CHARS LEFT ! 7639: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING ! 7640: PLC XL,WB POINT TO CURRENT CHARACTER ! 7641: LCH WA,(XL) LOAD CURRENT CHARACTER ! 7642: BNE WA,PARM1(XR),FAILP FAIL IF NO MATCH ! 7643: ICV WB ELSE BUMP CURSOR ! 7644: BRN SUCCP AND SUCCEED ! 7645: * ! 7646: * ANY (MULTI-CHARACTER ARGUMENT CASE) ! 7647: * EXPRESSION ARGUMENT CASE MERGES ! 7648: * ! 7649: * PARM1 POINTER TO CTBLK ! 7650: * PARM2 BIT MASK TO SELECT BIT IN CTBLK ! 7651: * ! 7652: P$ANY ENT BL$P2 P2BLK ! 7653: BEQ WB,PMSSL,FAILP FAIL IF NO CHARACTERS LEFT ! 7654: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING ! 7655: PLC XL,WB GET CHAR PTR TO CURRENT CHARACTER ! 7656: LCH WA,(XL) LOAD CURRENT CHARACTER ! 7657: MOV PARM1(XR),XL POINT TO CTBLK ! 7658: WTB WA CHANGE TO BAU OFFSET ! 7659: ADD WA,XL POINT TO ENTRY IN CTBLK ! 7660: MOV CTCHS(XL),WA LOAD WORD FROM CTBLK ! 7661: ANB PARM2(XR),WA AND WITH SELECTED BIT ! 7662: ZRB WA,FAILP FAIL IF NO MATCH ! 7663: ICV WB ELSE BUMP CURSOR ! 7664: BRN SUCCP AND SUCCEED ! 7665: * ! 7666: * ANY (EXPRESSION ARGUMENT) ! 7667: * ! 7668: * PARM1 EXPRESSION POINTER ! 7669: * ! 7670: P$AYD ENT BL$P1 P1BLK ! 7671: MOV =P$ANY,WA PCODE FOR NEW NODE ! 7672: JSR EVALS EVALUATE STRING ARGUMENT ! 7673: ERR 050,ANY EVALUATED ARGUMENT IS NOT STRING ! 7674: PPM FAILP FAIL IF EVALUATION FAILURE ! 7675: BRI XL MERGE MULTI-CHAR CASE IF OK ! 7676: EJC ! 7677: * ! 7678: * P$ARB INITIAL ARB MATCH ! 7679: * ! 7680: * NO PARAMETERS ! 7681: * ! 7682: * THE P$ARB NODE IS PART OF A COMPOUND PATTERN STRUCTURE ! 7683: * FOR AN ARB PATTERN (SEE DESCRIPTION OF COMPOUND PATTERNS) ! 7684: * ! 7685: P$ARB ENT BL$P0 P0BLK ! 7686: MOV PTHEN(XR),XR LOAD SUCCESSOR POINTER ! 7687: MOV WB,-(XS) STACK DUMMY CURSOR ! 7688: MOV XR,-(XS) STACK SUCCESSOR POINTER ! 7689: MOV WB,-(XS) STACK CURSOR ! 7690: MOV =NDARC,-(XS) STACK PTR TO SPECIAL NODE NDARC ! 7691: BRI (XR) EXECUTE NEXT NODE MATCHING NULL ! 7692: * ! 7693: * P$ARC EXTEND ARB MATCH ! 7694: * ! 7695: * NO PARAMETERS (DUMMY PATTERN) ! 7696: * ! 7697: P$ARC ENT ENTRY POINT ! 7698: BEQ WB,PMSSL,FLPOP FAIL AND POP STACK TO SUCCESSOR ! 7699: ICV WB ELSE BUMP CURSOR ! 7700: MOV WB,-(XS) STACK UPDATED CURSOR ! 7701: MOV XR,-(XS) RESTACK POINTER TO NDARC NODE ! 7702: MOV 2(XS),XR LOAD SUCCESSOR POINTER ! 7703: BRI (XR) OFF TO REEXECUTE SUCCESSOR NODE ! 7704: EJC ! 7705: * ! 7706: * BAL ! 7707: * ! 7708: * NO PARAMETERS ! 7709: * ! 7710: * THE P$BAL NODE IS PART OF THE COMPOUND STRUCTURE BUILT ! 7711: * FOR BAL (SEE SECTION ON COMPOUND PATTERNS). ! 7712: * ! 7713: P$BAL ENT BL$P0 P0BLK ! 7714: ZER WC ZERO PARENTHESES LEVEL COUNTER ! 7715: MOV R$PMS,XL POINT TO SUBJECT STRING ! 7716: PLC XL,WB POINT TO CURRENT CHARACTER ! 7717: BRN PBAL2 JUMP INTO SCAN LOOP ! 7718: * ! 7719: * LOOP TO SCAN OUT CHARACTERS ! 7720: * ! 7721: PBAL1 LCH WA,(XL)+ LOAD NEXT CHARACTER, BUMP POINTER ! 7722: ICV WB PUSH CURSOR FOR CHARACTER ! 7723: BEQ WA,=CH$PP,PBAL3 JUMP IF LEFT PAREN ! 7724: BEQ WA,=CH$RP,PBAL4 JUMP IF RIGHT PAREN ! 7725: BZE WC,PBAL5 ELSE SUCCEED IF AT OUTER LEVEL ! 7726: * ! 7727: * HERE AFTER PROCESSING ONE CHARACTER ! 7728: * ! 7729: PBAL2 BNE WB,PMSSL,PBAL1 LOOP BACK UNLESS END OF STRING ! 7730: BRN FAILP IN WHICH CASE, FAIL ! 7731: * ! 7732: * HERE ON LEFT PAREN ! 7733: * ! 7734: PBAL3 ICV WC BUMP PAREN LEVEL ! 7735: BRN PBAL2 LOOP BACK TO CHECK END OF STRING ! 7736: * ! 7737: * HERE FOR RIGHT PAREN ! 7738: * ! 7739: PBAL4 BZE WC,FAILP FAIL IF NO MATCHING LEFT PAREN ! 7740: DCV WC ELSE DECREMENT LEVEL COUNTER ! 7741: BNZ WC,PBAL2 LOOP BACK IF NOT AT OUTER LEVEL ! 7742: * ! 7743: * HERE AFTER SUCCESSFULLY SCANNING A BALANCED STRING ! 7744: * ! 7745: PBAL5 MOV WB,-(XS) STACK CURSOR ! 7746: MOV XR,-(XS) STACK PTR TO BAL NODE FOR EXTEND ! 7747: BRN SUCCP AND SUCCEED ! 7748: EJC ! 7749: * ! 7750: * BREAK (EXPRESSION ARGUMENT) ! 7751: * ! 7752: * PARM1 EXPRESSION POINTER ! 7753: * ! 7754: P$BKD ENT BL$P1 P1BLK ! 7755: MOV =P$BRK,WA PCODE FOR NEW NODE ! 7756: JSR EVALS EVALUATE STRING EXPRESSION ! 7757: ERR 051,BREAK EVALUATED ARGUMENT IS NOT STRING ! 7758: PPM FAILP FAIL IF EVALUATION FAILS ! 7759: BRI XL MERGE WITH MULTI-CHAR CASE IF OK ! 7760: * ! 7761: * BREAK (ONE CHARACTER ARGUMENT) ! 7762: * ! 7763: * PARM1 CHARACTER ARGUMENT ! 7764: * ! 7765: P$BKS ENT BL$P1 P1BLK ! 7766: MOV PMSSL,WC GET SUBJECT STRING LENGTH ! 7767: SUB WB,WC GET NUMBER OF CHARACTERS LEFT ! 7768: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT ! 7769: LCT WC,WC SET COUNTER FOR CHARS LEFT ! 7770: MOV R$PMS,XL POINT TO SUBJECT STRING ! 7771: PLC XL,WB POINT TO CURRENT CHARACTER ! 7772: * ! 7773: * LOOP TO SCAN TILL BREAK CHARACTER FOUND ! 7774: * ! 7775: PBKS1 LCH WA,(XL)+ LOAD NEXT CHAR, BUMP POINTER ! 7776: BEQ WA,PARM1(XR),SUCCP SUCCEED IF BREAK CHARACTER FOUND ! 7777: ICV WB ELSE PUSH CURSOR ! 7778: BCT WC,PBKS1 LOOP BACK IF MORE TO GO ! 7779: BRN FAILP FAIL IF END OF STRING, NO BREAK CHR ! 7780: EJC ! 7781: * ! 7782: * BREAK (MULTI-CHARACTER ARGUMENT) ! 7783: * EXPRESSION ARGUMENT CASE MERGES ! 7784: * ! 7785: * PARM1 POINTER TO CTBLK ! 7786: * PARM2 BIT MASK TO SELECT BIT COLUMN ! 7787: * ! 7788: P$BRK ENT BL$P2 P2BLK ! 7789: MOV PMSSL,WC LOAD SUBJECT STRING LENGTH ! 7790: SUB WB,WC GET NUMBER OF CHARACTERS LEFT ! 7791: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT ! 7792: LCT WC,WC SET COUNTER FOR CHARACTERS LEFT ! 7793: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING ! 7794: PLC XL,WB POINT TO CURRENT CHARACTER ! 7795: MOV XR,PSAVE SAVE NODE POINTER ! 7796: * ! 7797: * LOOP TO SEARCH FOR BREAK CHARACTER ! 7798: * ! 7799: PBRK2 LCH WA,(XL)+ LOAD NEXT CHAR, BUMP POINTER ! 7800: MOV PARM1(XR),XR LOAD POINTER TO CTBLK ! 7801: WTB WA CONVERT TO BAU OFFSET ! 7802: ADD WA,XR POINT TO CTBLK ENTRY ! 7803: MOV CTCHS(XR),WA LOAD CTBLK WORD ! 7804: MOV PSAVE,XR RESTORE NODE POINTER ! 7805: ANB PARM2(XR),WA AND WITH SELECTED BIT ! 7806: NZB WA,SUCCP SUCCEED IF BREAK CHARACTER FOUND ! 7807: ICV WB ELSE PUSH CURSOR ! 7808: BCT WC,PBRK2 LOOP BACK UNLESS END OF STRING ! 7809: BRN FAILP FAIL IF END OF STRING, NO BREAK CHR ! 7810: EJC ! 7811: * ! 7812: * BREAKX (EXTENSION) ! 7813: * ! 7814: * THIS IS THE ENTRY WHICH CAUSES AN EXTENSION OF A BREAKX ! 7815: * MATCH WHEN FAILURE OCCURS. SEE SECTION ON COMPOUND ! 7816: * PATTERNS FOR FULL DETAILS OF BREAKX MATCHING. ! 7817: * ! 7818: * NO PARAMETERS ! 7819: * ! 7820: P$BKX ENT BL$P0 P0BLK ! 7821: ICV WB STEP CURSOR PAST PREVIOUS BREAK CHR ! 7822: BRN SUCCP SUCCEED TO REMATCH BREAK ! 7823: * ! 7824: * BREAKX (EXPRESSION ARGUMENT) ! 7825: * ! 7826: * SEE SECTION ON COMPOUND PATTERNS FOR FULL STRUCTURE OF ! 7827: * BREAKX PATTERN. THE ACTUAL CHARACTER MATCHING USES A ! 7828: * BREAK NODE. HOWEVER, THE ENTRY FOR THE EXPRESSION ! 7829: * ARGUMENT CASE IS SEPARATED TO GET PROPER ERROR MESSAGES. ! 7830: * ! 7831: * PARM1 EXPRESSION POINTER ! 7832: * ! 7833: P$BXD ENT BL$P1 P1BLK ! 7834: MOV =P$BRK,WA PCODE FOR NEW NODE ! 7835: JSR EVALS EVALUATE STRING ARGUMENT ! 7836: ERR 052,BREAKX EVALUATED ARGUMENT IS NOT STRING ! 7837: PPM FAILP FAIL IF EVALUATION FAILS ! 7838: BRI XL MERGE WITH BREAK IF ALL OK ! 7839: * ! 7840: * CURSOR ASSIGNMENT ! 7841: * ! 7842: * PARM1 NAME BASE ! 7843: * PARM2 NAME OFFSET ! 7844: * ! 7845: P$CAS ENT BL$P2 P2BLK ! 7846: MOV XR,-(XS) SAVE NODE POINTER ! 7847: MOV WB,-(XS) SAVE CURSOR ! 7848: MOV PARM1(XR),XL LOAD NAME BASE ! 7849: MTI WB LOAD CURSOR AS INTEGER ! 7850: MOV PARM2(XR),WB LOAD NAME OFFSET ! 7851: JSR ICBLD GET ICBLK FOR CURSOR VALUE ! 7852: MOV WB,WA MOVE NAME OFFSET ! 7853: MOV XR,WB MOVE VALUE TO ASSIGN ! 7854: JSR ASINP PERFORM ASSIGNMENT ! 7855: PPM FLPOP FAIL ON ASSIGNMENT FAILURE ! 7856: MOV (XS)+,WB ELSE RESTORE CURSOR ! 7857: MOV (XS)+,XR RESTORE NODE POINTER ! 7858: BRN SUCCP AND SUCCEED MATCHING NULL ! 7859: EJC ! 7860: * ! 7861: * EXPRESSION NODE (P$EXA, INITIAL ENTRY) ! 7862: * ! 7863: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 7864: * ALGORITHMS FOR HANDLING EXPRESSION NODES. ! 7865: * ! 7866: * PARM1 EXPRESSION POINTER ! 7867: * ! 7868: P$EXA ENT BL$P1 P1BLK ! 7869: JSR EVALP EVALUATE EXPRESSION ! 7870: PPM FAILP FAIL IF EVALUATION FAILS ! 7871: BLO WA,=P$AAA,PEXA1 JUMP IF RESULT IS NOT A PATTERN ! 7872: * ! 7873: * HERE IF RESULT OF EXPRESSION IS A PATTERN ! 7874: * ! 7875: MOV WB,-(XS) STACK DUMMY CURSOR ! 7876: MOV XR,-(XS) STACK PTR TO P$EXA NODE ! 7877: MOV PMHBS,-(XS) STACK HISTORY STACK BASE PTR ! 7878: MOV =NDEXB,-(XS) STACK PTR TO SPECIAL NODE NDEXB ! 7879: MOV XS,PMHBS STORE NEW STACK BASE POINTER ! 7880: MOV XL,XR COPY NODE POINTER ! 7881: BRI (XR) MATCH FIRST NODE IN EXPRESSION PAT ! 7882: * ! 7883: * HERE IF RESULT OF EXPRESSION IS NOT A PATTERN ! 7884: * ! 7885: PEXA1 BEQ WA,=B$SCL,PEXA2 JUMP IF IT IS ALREADY A STRING ! 7886: MOV XL,-(XS) ELSE STACK RESULT ! 7887: MOV XR,XL SAVE NODE POINTER ! 7888: JSR GTSTG CONVERT RESULT TO STRING ! 7889: ERR 053,EXPRESSION DOES NOT EVALUATE TO PATTERN ! 7890: MOV XR,WC COPY STRING POINTER ! 7891: MOV XL,XR RESTORE NODE POINTER ! 7892: MOV WC,XL COPY STRING POINTER AGAIN ! 7893: * ! 7894: * MERGE HERE WITH STRING POINTER IN XL ! 7895: * ! 7896: PEXA2 BZE SCLEN(XL),SUCCP JUST SUCCEED IF NULL STRING ! 7897: MOV XR,PSAVE SAVE NODE PTR ! 7898: MOV R$PMS,XR LOAD SUBJECT STRING PTR ! 7899: PLC XR,WB POINT TO CURRENT CHAR ! 7900: ADD SCLEN(XL),WB COMPUTE NEW CURSOR POSITION ! 7901: BGT WB,PMSSL,FAILP FAIL IF PAST END OF STRING ! 7902: MOV WB,PSAVC SAVE UPDATED CURSOR ! 7903: MOV SCLEN(XL),WA NUMBER OF CHARS TO COMPARE ! 7904: PLC XL POINT TO TEST STRING CHARS ! 7905: CMC FAILP,FAILP COMPARE, FAIL IF UNEQUAL ! 7906: MOV PSAVE,XR IF ALL MATCHED, RESTORE NODE PTR ! 7907: MOV PSAVC,WB RESTORE UPDATED CURSOR ! 7908: BRN SUCCP AND SUCCEED ! 7909: EJC ! 7910: * ! 7911: * EXPRESSION NODE (P$EXB, REMOVE NDEXB ENTRY) ! 7912: * ! 7913: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 7914: * ALGORITHMS FOR HANDLING EXPRESSION NODES. ! 7915: * ! 7916: * NO PARAMETERS (DUMMY PATTERN) ! 7917: * ! 7918: P$EXB ENT ENTRY POINT ! 7919: MOV WB,PMHBS RESTORE OUTER LEVEL STACK POINTER ! 7920: BRN FLPOP FAIL AND POP P$EXA NODE PTR ! 7921: EJC ! 7922: * ! 7923: * EXPRESSION NODE (P$EXC, REMOVE NDEXC ENTRY) ! 7924: * ! 7925: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 7926: * ALGORITHMS FOR HANDLING EXPRESSION NODES. ! 7927: * ! 7928: * NO PARAMETERS (DUMMY PATTERN) ! 7929: * ! 7930: P$EXC ENT ENTRY POINT ! 7931: MOV WB,PMHBS RESTORE INNER STACK BASE POINTER ! 7932: BRN FAILP AND FAIL INTO EXPR PATTERN ALTERNVS ! 7933: * ! 7934: * FAIL ! 7935: * ! 7936: * NO PARAMETERS ! 7937: * ! 7938: P$FAL ENT BL$P0 P0BLK ! 7939: BRN FAILP JUST SIGNAL FAILURE ! 7940: EJC ! 7941: * FENCE ! 7942: * ! 7943: * SEE COMPOUND PATTERNS SECTION FOR THE STRUCTURE AND ! 7944: * ALGORITHM FOR MATCHING THIS NODE TYPE. ! 7945: * ! 7946: * NO PARAMETERS ! 7947: * ! 7948: P$FEN ENT BL$P0 P0BLK ! 7949: MOV WB,-(XS) STACK DUMMY CURSOR ! 7950: MOV =NDABO,-(XS) STACK PTR TO ABORT NODE ! 7951: BRN SUCCP AND SUCCEED MATCHING NULL ! 7952: .IF .CNFN ! 7953: .ELSE ! 7954: * ! 7955: * FENCE (FUNCTION) ! 7956: * ! 7957: * SEE COMPOUND PATTERNS COMMENTS AT START OF THIS SECTION ! 7958: * FOR DETAILS OF SCHEME ! 7959: * ! 7960: * NO PARAMETERS ! 7961: * ! 7962: P$FNA ENT BL$P0 P0BLK ! 7963: MOV PMHBS,-(XS) STACK CURRENT HISTORY STACK BASE ! 7964: MOV =NDFNB,-(XS) STACK INDIR PTR TO P$FNB (FAILURE) ! 7965: MOV XS,PMHBS BEGIN NEW HISTORY STACK ! 7966: BRN SUCCP SUCCEED ! 7967: * ! 7968: * FENCE (FUNCTION) (RESET HISTORY STACK AND FAIL) ! 7969: * ! 7970: * NO PARAMETERS (DUMMY PATTERN) ! 7971: * ! 7972: P$FNB ENT BL$P0 P0BLK ! 7973: MOV WB,PMHBS RESTORE OUTER PMHBS STACK BASE ! 7974: BRN FAILP ...AND FAIL ! 7975: * ! 7976: * FENCE (FUNCTION) (MAKE FENCE TRAP ENTRY ON STACK) ! 7977: * ! 7978: * NO PARAMETERS (DUMMY PATTERN) ! 7979: * ! 7980: P$FNC ENT BL$P0 P0BLK ! 7981: MOV PMHBS,XT GET INNER STACK BASE PTR ! 7982: MOV NUM01(XT),PMHBS RESTORE OUTER STACK BASE ! 7983: BEQ XT,XS,PFNC1 OPTIMIZE IF NO ALTERNATIVES ! 7984: MOV XT,-(XS) ELSE STACK INNER STACK BASE ! 7985: MOV =NDFND,-(XS) STACK PTR TO NDFND ! 7986: BRN SUCCP SUCCEED ! 7987: * ! 7988: * HERE WHEN FENCE FUNCTION LEFT NOTHING ON THE STACK ! 7989: * ! 7990: PFNC1 ADD *NUM02,XS POP OFF P$FNB ENTRY ! 7991: BRN SUCCP SUCCEED ! 7992: * ! 7993: * FENCE (FUNCTION) (SKIP PAST ALTERNATIVES ON FAILURE) ! 7994: * ! 7995: * NO PARAMETERS (DUMMY PATTERN) ! 7996: * ! 7997: P$FND ENT BL$P0 P0BLK ! 7998: MOV WB,XS POP STACK TO FENCE() HISTORY BASE ! 7999: BRN FLPOP POP BASE ENTRY AND FAIL ! 8000: .FI ! 8001: EJC ! 8002: * ! 8003: * IMMEDIATE ASSIGNMENT (INITIAL ENTRY, SAVE CURRENT CURSOR) ! 8004: * ! 8005: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE ! 8006: * STRUCTURE AND ALGORITHM FOR MATCHING THIS NODE TYPE. ! 8007: * ! 8008: * NO PARAMETERS ! 8009: * ! 8010: P$IMA ENT BL$P0 P0BLK ! 8011: MOV WB,-(XS) STACK CURSOR ! 8012: MOV XR,-(XS) STACK DUMMY NODE POINTER ! 8013: MOV PMHBS,-(XS) STACK OLD STACK BASE POINTER ! 8014: MOV =NDIMB,-(XS) STACK PTR TO SPECIAL NODE NDIMB ! 8015: MOV XS,PMHBS STORE NEW STACK BASE POINTER ! 8016: BRN SUCCP AND SUCCEED ! 8017: * ! 8018: * IMMEDIATE ASSIGNMENT (REMOVE CURSOR MARK ENTRY) ! 8019: * ! 8020: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE ! 8021: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 8022: * ! 8023: * NO PARAMETERS (DUMMY PATTERN) ! 8024: * ! 8025: P$IMB ENT ENTRY POINT ! 8026: MOV WB,PMHBS RESTORE HISTORY STACK BASE PTR ! 8027: BRN FLPOP FAIL AND POP DUMMY NODE PTR ! 8028: EJC ! 8029: * ! 8030: * IMMEDIATE ASSIGNMENT (PERFORM ACTUAL ASSIGNMENT) ! 8031: * ! 8032: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE ! 8033: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 8034: * ! 8035: * PARM1 NAME BASE OF VARIABLE ! 8036: * PARM2 NAME OFFSET OF VARIABLE ! 8037: * ! 8038: P$IMC ENT BL$P2 P2BLK ! 8039: MOV PMHBS,XT LOAD POINTER TO P$IMB ENTRY ! 8040: MOV WB,WA COPY FINAL CURSOR ! 8041: MOV 3(XT),WB LOAD INITIAL CURSOR ! 8042: MOV 1(XT),PMHBS RESTORE OUTER STACK BASE POINTER ! 8043: BEQ XT,XS,PIMC1 JUMP IF NO HISTORY STACK ENTRIES ! 8044: MOV XT,-(XS) ELSE SAVE INNER PMHBS POINTER ! 8045: MOV =NDIMD,-(XS) AND A PTR TO SPECIAL NODE NDIMD ! 8046: BRN PIMC2 MERGE ! 8047: * ! 8048: * HERE IF NO ENTRIES MADE ON HISTORY STACK ! 8049: * ! 8050: PIMC1 ADD *NUM04,XS REMOVE NDIMB ENTRY AND CURSOR ! 8051: * ! 8052: * MERGE HERE TO PERFORM ASSIGNMENT ! 8053: * ! 8054: PIMC2 MOV WA,-(XS) SAVE CURRENT (FINAL) CURSOR ! 8055: MOV XR,-(XS) SAVE CURRENT NODE POINTER ! 8056: MOV R$PMS,XL POINT TO SUBJECT STRING ! 8057: SUB WB,WA COMPUTE SUBSTRING LENGTH ! 8058: JSR SBSTR BUILD SUBSTRING ! 8059: MOV XR,WB MOVE RESULT ! 8060: MOV (XS),XR RELOAD NODE POINTER ! 8061: MOV PARM1(XR),XL LOAD NAME BASE ! 8062: MOV PARM2(XR),WA LOAD NAME OFFSET ! 8063: JSR ASINP PERFORM ASSIGNMENT ! 8064: PPM FLPOP FAIL IF ASSIGNMENT FAILS ! 8065: MOV (XS)+,XR ELSE RESTORE NODE POINTER ! 8066: MOV (XS)+,WB RESTORE CURSOR ! 8067: BRN SUCCP AND SUCCEED ! 8068: * ! 8069: * IMMEDIATE ASSIGNMENT (REMOVE NDIMD ENTRY ON FAILURE) ! 8070: * ! 8071: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE ! 8072: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 8073: * ! 8074: * NO PARAMETERS (DUMMY PATTERN) ! 8075: * ! 8076: P$IMD ENT ENTRY POINT ! 8077: MOV WB,PMHBS RESTORE INNER STACK BASE POINTER ! 8078: BRN FAILP AND FAIL ! 8079: EJC ! 8080: * ! 8081: * LEN (INTEGER ARGUMENT) ! 8082: * ! 8083: * PARM1 INTEGER ARGUMENT ! 8084: * ! 8085: P$LEN ENT BL$P1 P1BLK ! 8086: ADD PARM1(XR),WB PUSH CURSOR INDICATED AMOUNT ! 8087: BLE WB,PMSSL,SUCCP SUCCEED IF NOT OFF END ! 8088: BRN FAILP ELSE FAIL ! 8089: * ! 8090: * LEN (EXPRESSION ARGUMENT) ! 8091: * ! 8092: * PARM1 EXPRESSION POINTER ! 8093: * ! 8094: P$LND ENT BL$P1 P1BLK ! 8095: JSR EVALI EVALUATE INTEGER ARGUMENT ! 8096: ERR 054,LEN EVALUATED ARGUMENT IS NOT INTEGER ! 8097: ERR 055,LEN EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE ! 8098: PPM FAILP FAIL IF EVALUATION FAILS ! 8099: ADD PARM1(XR),WB PUSH CURSOR INDICATED AMOUNT ! 8100: BLE WB,PMSSL,SUCCP SUCCEED IF NOT OFF END ! 8101: BRN FAILP ELSE FAIL ! 8102: EJC ! 8103: * ! 8104: * NOTANY (EXPRESSION ARGUMENT) ! 8105: * ! 8106: * PARM1 EXPRESSION POINTER ! 8107: * ! 8108: P$NAD ENT BL$P1 P1BLK ! 8109: MOV =P$NAY,WA PCODE FOR NEW NODE ! 8110: JSR EVALS EVALUATE STRING ARGUMENT ! 8111: ERR 056,NOTANY EVALUATED ARGUMENT IS NOT STRING ! 8112: PPM FAILP FAIL IF EVALUATION FAILS ! 8113: BRI XL MERGE WITH MULTI-CHAR CASE IF OK ! 8114: EJC ! 8115: * ! 8116: * NOTANY (ONE CHARACTER ARGUMENT) ! 8117: * ! 8118: * PARM1 CHARACTER ARGUMENT ! 8119: * ! 8120: P$NAS ENT BL$P1 ENTRY POINT ! 8121: BEQ WB,PMSSL,FAILP FAIL IF NO CHARS LEFT ! 8122: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING ! 8123: PLC XL,WB POINT TO CURRENT CHARACTER IN STRIN ! 8124: LCH WA,(XL) LOAD CURRENT CHARACTER ! 8125: BEQ WA,PARM1(XR),FAILP FAIL IF MATCH ! 8126: ICV WB ELSE BUMP CURSOR ! 8127: BRN SUCCP AND SUCCEED ! 8128: EJC ! 8129: * ! 8130: * NOTANY (MULTI-CHARACTER STRING ARGUMENT) ! 8131: * EXPRESSION ARGUMENT CASE MERGES ! 8132: * ! 8133: * PARM1 POINTER TO CTBLK ! 8134: * PARM2 BIT MASK TO SELECT BIT COLUMN ! 8135: * ! 8136: P$NAY ENT BL$P2 P2BLK ! 8137: BEQ WB,PMSSL,FAILP FAIL IF NO CHARACTERS LEFT ! 8138: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING ! 8139: PLC XL,WB POINT TO CURRENT CHARACTER ! 8140: LCH WA,(XL) LOAD CURRENT CHARACTER ! 8141: WTB WA CONVERT TO BAU OFFSET ! 8142: MOV PARM1(XR),XL LOAD POINTER TO CTBLK ! 8143: ADD WA,XL POINT TO ENTRY IN CTBLK ! 8144: MOV CTCHS(XL),WA LOAD ENTRY FROM CTBLK ! 8145: ANB PARM2(XR),WA AND WITH SELECTED BIT ! 8146: NZB WA,FAILP FAIL IF CHARACTER IS MATCHED ! 8147: ICV WB ELSE BUMP CURSOR ! 8148: BRN SUCCP AND SUCCEED ! 8149: EJC ! 8150: * ! 8151: * END OF PATTERN MATCH ! 8152: * ! 8153: * THIS ROUTINE IS ENTERED ON SUCCESSFUL COMPLETION. ! 8154: * SEE DESCRIPTION OF EXPRESSION PATTERNS IN COMPOUND ! 8155: * PATTERN SECTION FOR HANDLING OF RECURSION IN MATCHING. ! 8156: * ! 8157: * NO PARAMETERS (DUMMY PATTERN) ! 8158: * ! 8159: P$NTH ENT ENTRY POINT ! 8160: MOV PMHBS,XT LOAD POINTER TO BASE OF STACK ! 8161: MOV 1(XT),WA LOAD SAVED PMHBS (OR PATTERN TYPE) ! 8162: BLE WA,=NUM02,PNTH2 JUMP IF OUTER LEVEL (PATTERN TYPE) ! 8163: * ! 8164: * HERE WE ARE AT THE END OF MATCHING AN EXPRESSION PATTERN ! 8165: * ! 8166: MOV WA,PMHBS RESTORE OUTER STACK BASE POINTER ! 8167: MOV 2(XT),XR RESTORE POINTER TO P$EXA NODE ! 8168: BEQ XT,XS,PNTH1 JUMP IF NO HISTORY STACK ENTRIES ! 8169: MOV XT,-(XS) ELSE STACK INNER STACK BASE PTR ! 8170: MOV =NDEXC,-(XS) STACK PTR TO SPECIAL NODE NDEXC ! 8171: BRN SUCCP AND SUCCEED ! 8172: * ! 8173: * HERE IF NO HISTORY STACK ENTRIES DURING PATTERN ! 8174: * ! 8175: PNTH1 ADD *NUM04,XS REMOVE P$EXB ENTRY AND NODE PTR ! 8176: BRN SUCCP AND SUCCEED ! 8177: * ! 8178: * HERE IF END OF MATCH AT OUTER LEVEL ! 8179: * ! 8180: PNTH2 MOV WB,PMSSL SAVE FINAL CURSOR IN SAFE PLACE ! 8181: BZE PMDFL,PNTH6 JUMP IF NO PATTERN ASSIGNMENTS ! 8182: EJC ! 8183: * ! 8184: * END OF PATTERN MATCH (CONTINUED) ! 8185: * ! 8186: * NOW WE MUST PERFORM PATTERN ASSIGNMENTS. THIS IS DONE BY ! 8187: * SCANNING THE HISTORY STACK FOR MATCHING NDPAB-NDPAD PAIRS ! 8188: * ! 8189: PNTH3 DCA XT POINT PAST CURSOR ENTRY ! 8190: MOV -(XT),WA LOAD NODE POINTER ! 8191: BEQ WA,=NDPAD,PNTH4 JUMP IF NDPAD ENTRY ! 8192: BNE WA,=NDPAB,PNTH5 JUMP IF NOT NDPAB ENTRY ! 8193: * ! 8194: * HERE FOR NDPAB ENTRY, STACK INITIAL CURSOR ! 8195: * NOTE THAT THERE MUST BE MORE ENTRIES ON THE STACK. ! 8196: * ! 8197: MOV 1(XT),-(XS) STACK INITIAL CURSOR ! 8198: CHK CHECK FOR STACK OVERFLOW ! 8199: BRN PNTH3 LOOP BACK IF OK ! 8200: * ! 8201: * HERE FOR NDPAD ENTRY. THE STARTING CURSOR FROM THE ! 8202: * MATCHING NDPAD ENTRY IS NOW THE TOP STACK ENTRY. ! 8203: * ! 8204: PNTH4 MOV 1(XT),WA LOAD FINAL CURSOR ! 8205: MOV (XS),WB LOAD INITIAL CURSOR FROM STACK ! 8206: MOV XT,(XS) SAVE HISTORY STACK SCAN PTR ! 8207: SUB WB,WA COMPUTE LENGTH OF STRING ! 8208: * ! 8209: * BUILD SUBSTRING AND PERFORM ASSIGNMENT ! 8210: * ! 8211: MOV R$PMS,XL POINT TO SUBJECT STRING ! 8212: JSR SBSTR CONSTRUCT SUBSTRING ! 8213: MOV XR,WB COPY SUBSTRING POINTER ! 8214: MOV (XS),XT RELOAD HISTORY STACK SCAN PTR ! 8215: MOV 2(XT),XL LOAD POINTER TO P$PAC NODE WITH NAM ! 8216: MOV PARM2(XL),WA LOAD NAME OFFSET ! 8217: MOV PARM1(XL),XL LOAD NAME BASE ! 8218: JSR ASINP PERFORM ASSIGNMENT ! 8219: PPM EXFAL MATCH FAILS IF NAME EVAL FAILS ! 8220: MOV (XS)+,XT ELSE RESTORE HISTORY STACK PTR ! 8221: EJC ! 8222: * ! 8223: * END OF PATTERN MATCH (CONTINUED) ! 8224: * ! 8225: * HERE CHECK FOR END OF ENTRIES ! 8226: * ! 8227: PNTH5 BNE XT,XS,PNTH3 LOOP IF MORE ENTRIES TO SCAN ! 8228: * ! 8229: * HERE AFTER DEALING WITH PATTERN ASSIGNMENTS ! 8230: * ! 8231: PNTH6 MOV PMHBS,XS WIPE OUT HISTORY STACK ! 8232: MOV (XS)+,WB LOAD INITIAL CURSOR ! 8233: MOV (XS)+,WC LOAD MATCH TYPE CODE ! 8234: MOV PMSSL,WA LOAD FINAL CURSOR VALUE ! 8235: MOV R$PMS,XL POINT TO SUBJECT STRING ! 8236: ZER R$PMS CLEAR SUBJECT STRING PTR FOR GBCOL ! 8237: BZE WC,PNTH7 JUMP IF CALL BY NAME ! 8238: ZER R$PMB CLEAR POSSIBLE BCBLK PTR FOR GBCOL ! 8239: BEQ WC,=NUM02,EXITS EXIT IF STATEMENT LEVEL CALL ! 8240: * ! 8241: * HERE WE HAVE A CALL BY VALUE, BUILD SUBSTRING ! 8242: * ! 8243: SUB WB,WA COMPUTE LENGTH OF STRING ! 8244: JSR SBSTR BUILD SUBSTRING ! 8245: BRN EXIXR AND EXIT WITH SUBSTRING VALUE ! 8246: * ! 8247: * HERE FOR CALL BY NAME, MAKE STACK ENTRIES FOR O$RPL ! 8248: * ! 8249: PNTH7 MOV WB,-(XS) STACK INITIAL CURSOR ! 8250: MOV WA,-(XS) STACK FINAL CURSOR ! 8251: .IF .CNBF ! 8252: MOV XL,-(XS) STACK SUBJECT STRING POINTER ! 8253: .ELSE ! 8254: BZE R$PMB,PNTH8 SKIP IF SUBJECT NOT BUFFER ! 8255: MOV R$PMB,XL ELSE GET PTR TO BCBLK INSTEAD ! 8256: ZER R$PMB CLEAR BCBLK PTR FOR GBCOL ! 8257: * ! 8258: * HERE WITH XL POINTING TO SCBLK OR BCBLK ! 8259: * ! 8260: PNTH8 MOV XL,-(XS) STACK SUBJECT POINTER ! 8261: .FI ! 8262: BRN EXITS EXIT WITH SPECIAL ENTRY ON STACK ! 8263: EJC ! 8264: * ! 8265: * POS (INTEGER ARGUMENT) ! 8266: * ! 8267: * PARM1 INTEGER ARGUMENT ! 8268: * ! 8269: P$POS ENT BL$P1 P1BLK ! 8270: BEQ WB,PARM1(XR),SUCCP SUCCEED IF AT RIGHT LOCATION ! 8271: BRN FAILP ELSE FAIL ! 8272: * ! 8273: * POS (EXPRESSION ARGUMENT) ! 8274: * ! 8275: * PARM1 EXPRESSION POINTER ! 8276: * ! 8277: P$PSD ENT BL$P1 P1BLK ! 8278: JSR EVALI EVALUATE INTEGER ARGUMENT ! 8279: ERR 057,POS EVALUATED ARGUMENT IS NOT INTEGER ! 8280: ERR 058,POS EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE ! 8281: PPM FAILP FAIL IF EVALUATION FAILS ! 8282: BEQ WB,PARM1(XR),SUCCP SUCCEED IF AT RIGHT LOCATION ! 8283: BRN FAILP ELSE FAIL ! 8284: EJC ! 8285: * ! 8286: * PATTERN ASSIGNMENT (INITIAL ENTRY, SAVE CURSOR) ! 8287: * ! 8288: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 8289: * ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 8290: * ! 8291: * NO PARAMETERS ! 8292: * ! 8293: P$PAA ENT BL$P0 P0BLK ! 8294: MOV WB,-(XS) STACK INITIAL CURSOR ! 8295: MOV =NDPAB,-(XS) STACK PTR TO NDPAB SPECIAL NODE ! 8296: BRN SUCCP AND SUCCEED MATCHING NULL ! 8297: * ! 8298: * PATTERN ASSIGNMENT (REMOVE SAVED CURSOR) ! 8299: * ! 8300: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 8301: * ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 8302: * ! 8303: * NO PARAMETERS (DUMMY PATTERN) ! 8304: * ! 8305: P$PAB ENT ENTRY POINT ! 8306: BRN FAILP JUST FAIL (ENTRY IS ALREADY POPPED) ! 8307: * ! 8308: * PATTERN ASSIGNMENT (END OF MATCH, MAKE ASSIGN ENTRY) ! 8309: * ! 8310: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 8311: * ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 8312: * ! 8313: * PARM1 NAME BASE OF VARIABLE ! 8314: * PARM2 NAME OFFSET OF VARIABLE ! 8315: * ! 8316: P$PAC ENT BL$P2 P2BLK ! 8317: MOV WB,-(XS) STACK DUMMY CURSOR VALUE ! 8318: MOV XR,-(XS) STACK POINTER TO P$PAC NODE ! 8319: MOV WB,-(XS) STACK FINAL CURSOR ! 8320: MOV =NDPAD,-(XS) STACK PTR TO SPECIAL NDPAD NODE ! 8321: MNZ PMDFL SET DOT FLAG NON-ZERO ! 8322: BRN SUCCP AND SUCCEED ! 8323: * ! 8324: * PATTERN ASSIGNMENT (REMOVE ASSIGN ENTRY) ! 8325: * ! 8326: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 8327: * ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 8328: * ! 8329: * NO PARAMETERS (DUMMY NODE) ! 8330: * ! 8331: P$PAD ENT ENTRY POINT ! 8332: BRN FLPOP FAIL AND REMOVE P$PAC NODE ! 8333: EJC ! 8334: * ! 8335: * REM ! 8336: * ! 8337: * NO PARAMETERS ! 8338: * ! 8339: P$REM ENT BL$P0 P0BLK ! 8340: MOV PMSSL,WB POINT CURSOR TO END OF STRING ! 8341: BRN SUCCP AND SUCCEED ! 8342: * ! 8343: * RPOS (EXPRESSION ARGUMENT) ! 8344: * ! 8345: * PARM1 EXPRESSION POINTER ! 8346: * ! 8347: P$RPD ENT BL$P1 P1BLK ! 8348: JSR EVALI EVALUATE INTEGER ARGUMENT ! 8349: ERR 059,RPOS EVALUATED ARGUMENT IS NOT INTEGER ! 8350: ERR 060,RPOS EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE ! 8351: PPM FAILP FAIL IF EVALUATION FAILS ! 8352: MOV =P$RPS,XL CONTINUATION ROUTINE ! 8353: BRI XL ENTER ROUTINE ! 8354: * ! 8355: * RPOS (INTEGER ARGUMENT) ! 8356: * EXPRESSION ARGUMENT CASE MERGES ! 8357: * ! 8358: * PARM1 INTEGER ARGUMENT ! 8359: * ! 8360: P$RPS ENT BL$P1 P1BLK ! 8361: MOV PMSSL,WC GET LENGTH OF STRING ! 8362: SUB WB,WC GET NUMBER OF CHARACTERS REMAINING ! 8363: BEQ WC,PARM1(XR),SUCCP SUCCEED IF AT RIGHT LOCATION ! 8364: BRN FAILP ELSE FAIL ! 8365: EJC ! 8366: * ! 8367: * RTAB (INTEGER ARGUMENT) ! 8368: * EXPRESSION ARGUMENT CASE MERGES ! 8369: * ! 8370: * PARM1 INTEGER ARGUMENT ! 8371: * ! 8372: P$RTB ENT BL$P1 P1BLK ! 8373: MOV WB,WC SAVE INITIAL CURSOR ! 8374: MOV PMSSL,WB POINT TO END OF STRING ! 8375: BLT WB,PARM1(XR),FAILP FAIL IF STRING NOT LONG ENOUGH ! 8376: SUB PARM1(XR),WB ELSE SET NEW CURSOR ! 8377: BGE WB,WC,SUCCP AND SUCCEED IF NOT TOO FAR ALREADY ! 8378: BRN FAILP IN WHICH CASE, FAIL ! 8379: * ! 8380: * RTAB (EXPRESSION ARGUMENT) ! 8381: * ! 8382: * PARM1 EXPRESSION POINTER ! 8383: * ! 8384: P$RTD ENT BL$P1 P1BLK ! 8385: JSR EVALI EVALUATE INTEGER ARGUMENT ! 8386: ERR 061,RTAB EVALUATED ARGUMENT IS NOT INTEGER ! 8387: ERR 062,RTAB EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE ! 8388: PPM FAILP FAIL IF EVALUATION FAILS ! 8389: MOV =P$RTB,XL CONTINUATION ROUTINE ! 8390: BRI XL ENTER ROUTINE ! 8391: EJC ! 8392: * ! 8393: * SPAN (EXPRESSION ARGUMENT) ! 8394: * ! 8395: * PARM1 EXPRESSION POINTER ! 8396: * ! 8397: P$SPD ENT BL$P1 P1BLK ! 8398: MOV =P$SPN,WA PCODE FOR NEW NODE ! 8399: JSR EVALS EVALUATE STRING ARGUMENT ! 8400: ERR 063,SPAN EVALUATED ARGUMENT IS NOT STRING ! 8401: PPM FAILP FAIL IF EVALUATION FAILS ! 8402: BRI XL MERGE WITH MULTI-CHAR CASE IF OK ! 8403: * ! 8404: * SPAN (MULTI-CHARACTER ARGUMENT CASE) ! 8405: * EXPRESSION ARGUMENT CASE MERGES ! 8406: * ! 8407: * PARM1 POINTER TO CTBLK ! 8408: * PARM2 BIT MASK TO SELECT BIT COLUMN ! 8409: * ! 8410: P$SPN ENT BL$P2 P2BLK ! 8411: MOV PMSSL,WC COPY SUBJECT STRING LENGTH ! 8412: SUB WB,WC CALCULATE NUMBER OF CHARACTERS LEFT ! 8413: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT ! 8414: MOV R$PMS,XL POINT TO SUBJECT STRING ! 8415: PLC XL,WB POINT TO CURRENT CHARACTER ! 8416: MOV WB,PSAVC SAVE INITIAL CURSOR ! 8417: MOV XR,PSAVE SAVE NODE POINTER ! 8418: LCT WC,WC SET COUNTER FOR CHARS LEFT ! 8419: * ! 8420: * LOOP TO SCAN MATCHING CHARACTERS ! 8421: * ! 8422: PSPN2 LCH WA,(XL)+ LOAD NEXT CHARACTER, BUMP POINTER ! 8423: WTB WA CONVERT TO BAU OFFSET ! 8424: MOV PARM1(XR),XR POINT TO CTBLK ! 8425: ADD WA,XR POINT TO CTBLK ENTRY ! 8426: MOV CTCHS(XR),WA LOAD CTBLK ENTRY ! 8427: MOV PSAVE,XR RESTORE NODE POINTER ! 8428: ANB PARM2(XR),WA AND WITH SELECTED BIT ! 8429: ZRB WA,PSPN3 JUMP IF NO MATCH ! 8430: ICV WB ELSE PUSH CURSOR ! 8431: BCT WC,PSPN2 LOOP BACK UNLESS END OF STRING ! 8432: * ! 8433: * HERE AFTER SCANNING MATCHING CHARACTERS ! 8434: * ! 8435: PSPN3 BNE WB,PSAVC,SUCCP SUCCEED IF CHARS MATCHED ! 8436: BRN FAILP ELSE FAIL IF NULL STRING MATCHED ! 8437: EJC ! 8438: * ! 8439: * SPAN (ONE CHARACTER ARGUMENT) ! 8440: * ! 8441: * PARM1 CHARACTER ARGUMENT ! 8442: * ! 8443: P$SPS ENT BL$P1 P1BLK ! 8444: MOV PMSSL,WC GET SUBJECT STRING LENGTH ! 8445: SUB WB,WC CALCULATE NUMBER OF CHARACTERS LEFT ! 8446: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT ! 8447: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING ! 8448: PLC XL,WB POINT TO CURRENT CHARACTER ! 8449: MOV WB,PSAVC SAVE INITIAL CURSOR ! 8450: LCT WC,WC SET COUNTER FOR CHARACTERS LEFT ! 8451: * ! 8452: * LOOP TO SCAN MATCHING CHARACTERS ! 8453: * ! 8454: PSPS1 LCH WA,(XL)+ LOAD NEXT CHARACTER, BUMP POINTER ! 8455: BNE WA,PARM1(XR),PSPS2 JUMP IF NO MATCH ! 8456: ICV WB ELSE PUSH CURSOR ! 8457: BCT WC,PSPS1 AND LOOP UNLESS END OF STRING ! 8458: * ! 8459: * HERE AFTER SCANNING MATCHING CHARACTERS ! 8460: * ! 8461: PSPS2 BNE WB,PSAVC,SUCCP SUCCEED IF CHARS MATCHED ! 8462: BRN FAILP FAIL IF NULL STRING MATCHED ! 8463: * ! 8464: * MULTI-CHARACTER STRING (MERGE FROM P$EXA) ! 8465: * ! 8466: * NOTE THAT ONE CHARACTER STRINGS USE THE CIRCUIT FOR ! 8467: * ONE CHARACTER ANY ARGUMENTS (P$AN1). ! 8468: * ! 8469: * PARM1 POINTER TO SCBLK FOR STRING ARG ! 8470: * ! 8471: P$STR ENT BL$P1 P1BLK ! 8472: MOV PARM1(XR),XL GET POINTER TO STRING ! 8473: MOV XR,PSAVE SAVE NODE POINTER ! 8474: MOV R$PMS,XR LOAD SUBJECT STRING POINTER ! 8475: PLC XR,WB POINT TO CURRENT CHARACTER ! 8476: ADD SCLEN(XL),WB COMPUTE NEW CURSOR POSITION ! 8477: BGT WB,PMSSL,FAILP FAIL IF PAST END OF STRING ! 8478: MOV WB,PSAVC SAVE UPDATED CURSOR ! 8479: MOV SCLEN(XL),WA GET NUMBER OF CHARS TO COMPARE ! 8480: PLC XL POINT TO CHARS OF TEST STRING ! 8481: CMC FAILP,FAILP COMPARE, FAIL IF NOT EQUAL ! 8482: MOV PSAVE,XR IF ALL MATCHED, RESTORE NODE PTR ! 8483: MOV PSAVC,WB RESTORE UPDATED CURSOR ! 8484: BRN SUCCP AND SUCCEED ! 8485: EJC ! 8486: * ! 8487: * SUCCEED ! 8488: * ! 8489: * SEE SECTION ON COMPOUND PATTERNS FOR DETAILS OF THE ! 8490: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE ! 8491: * ! 8492: * NO PARAMETERS ! 8493: * ! 8494: P$SUC ENT BL$P0 P0BLK ! 8495: MOV WB,-(XS) STACK CURSOR ! 8496: MOV XR,-(XS) STACK POINTER TO THIS NODE ! 8497: BRN SUCCP SUCCEED MATCHING NULL ! 8498: EJC ! 8499: * ! 8500: * TAB (INTEGER ARGUMENT) ! 8501: * EXPRESSION CASE MERGES ! 8502: * ! 8503: * PARM1 INTEGER ARGUMENT ! 8504: * ! 8505: P$TAB ENT BL$P1 P1BLK ! 8506: BGT WB,PARM1(XR),FAILP FAIL IF TOO FAR ALREADY ! 8507: MOV PARM1(XR),WB ELSE SET NEW CURSOR POSITION ! 8508: BLE WB,PMSSL,SUCCP SUCCEED IF NOT OFF END ! 8509: BRN FAILP ELSE FAIL ! 8510: * ! 8511: * TAB (EXPRESSION ARGUMENT) ! 8512: * ! 8513: * PARM1 EXPRESSION POINTER ! 8514: * ! 8515: P$TBD ENT BL$P1 P1BLK ! 8516: JSR EVALI EVALUATE INTEGER ARGUMENT ! 8517: ERR 064,TAB EVALUATED ARGUMENT IS NOT INTEGER ! 8518: ERR 065,TAB EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE ! 8519: PPM FAILP FAIL IF EVALUATION FAILS ! 8520: MOV =P$TAB,XL CONTINUATION ROUTINE ! 8521: BRI XL ENTER ROUTINE ! 8522: * ! 8523: * ANCHOR MOVEMENT ! 8524: * ! 8525: * NO PARAMETERS (DUMMY NODE) ! 8526: * ! 8527: P$UNA ENT ENTRY POINT ! 8528: MOV WB,XR COPY INITIAL PATTERN NODE POINTER ! 8529: MOV (XS),WB GET INITIAL CURSOR ! 8530: BEQ WB,PMSSL,EXFAL MATCH FAILS IF AT END OF STRING ! 8531: ICV WB ELSE INCREMENT CURSOR ! 8532: MOV WB,(XS) STORE INCREMENTED CURSOR ! 8533: MOV XR,-(XS) RESTACK INITIAL NODE PTR ! 8534: MOV =NDUNA,-(XS) RESTACK UNANCHORED NODE ! 8535: BRI (XR) REMATCH FIRST NODE ! 8536: * ! 8537: * END OF PATTERN MATCH ROUTINES ! 8538: * ! 8539: * THE FOLLOWING ENTRY POINT MARKS THE END OF THE PATTERN ! 8540: * MATCHING ROUTINES AND ALSO THE END OF THE ENTRY POINTS ! 8541: * REFERENCED FROM THE FIRST WORD OF BLOCKS IN DYNAMIC STORE ! 8542: * ! 8543: P$YYY ENT BL$$I MARK LAST ENTRY IN PATTERN SECTION ! 8544: TTL S P I T B O L -- PREDEFINED SNOBOL4 FUNCTIONS ! 8545: * ! 8546: * THE FOLLOWING SECTION CONTAINS CODING FOR FUNCTIONS ! 8547: * WHICH ARE PREDEFINED AND AVAILABLE AT THE SNOBOL LEVEL. ! 8548: * ! 8549: * THESE ROUTINES RECEIVE CONTROL DIRECTLY FROM THE CODE OR ! 8550: * INDIRECTLY THROUGH THE O$FNC, O$FNS OR CFUNC ROUTINES. ! 8551: * IN BOTH CASES THE CONDITIONS ON ENTRY ARE AS FOLLOWS ! 8552: * ! 8553: * THE ARGUMENTS ARE ON THE STACK. THE NUMBER OF ARGUMENTS ! 8554: * HAS BEEN ADJUSTED TO CORRESPOND TO THE SVBLK SVNAR FIELD. ! 8555: * ! 8556: * IN CERTAIN FUNCTIONS THE DIRECT CALL IS NOT PERMITTED ! 8557: * AND IN THESE INSTANCES WE ALSO HAVE. ! 8558: * ! 8559: * (WA) ACTUAL NUMBER OF ARGUMENTS IN CALL ! 8560: * ! 8561: * CONTROL RETURNS BY PLACING THE FUNCTION RESULT VALUE ON ! 8562: * ON THE STACK AND CONTINUING EXECUTION WITH THE NEXT ! 8563: * WORD FROM THE GENERATED CODE. ! 8564: * ! 8565: * THE NAMES OF THE ENTRY POINTS OF THESE FUNCTIONS ARE OF ! 8566: * THE FORM S$XXX WHERE XXX IS THE THREE LETTER CODE FOR ! 8567: * THE SYSTEM VARIABLE NAME. THE FUNCTIONS ARE IN ORDER ! 8568: * ALPHABETICALLY BY THEIR ENTRY NAMES. ! 8569: EJC ! 8570: * ! 8571: * ANY ! 8572: * ! 8573: S$ANY ENT ENTRY POINT ! 8574: MOV =P$ANS,WB SET PCODE FOR SINGLE CHAR CASE ! 8575: MOV =P$ANY,XL PCODE FOR MULTI-CHAR CASE ! 8576: MOV =P$AYD,WC PCODE FOR EXPRESSION CASE ! 8577: JSR PATST CALL COMMON ROUTINE TO BUILD NODE ! 8578: ERR 066,ANY ARGUMENT IS NOT STRING OR EXPRESSION ! 8579: BRN EXIXR JUMP FOR NEXT CODE WORD ! 8580: .IF .CNBF ! 8581: .ELSE ! 8582: EJC ! 8583: * ! 8584: * APPEND ! 8585: * ! 8586: S$APN ENT ENTRY POINT ! 8587: MOV (XS)+,XL GET APPEND ARGUMENT ! 8588: MOV (XS)+,XR GET BCBLK ! 8589: BEQ (XR),=B$BCT,SAPN1 OK IF FIRST ARG IS BCBLK ! 8590: ERB 067,APPEND FIRST ARGUMENT IS NOT BUFFER ! 8591: * ! 8592: * HERE TO DO THE APPEND ! 8593: * ! 8594: SAPN1 MOV BCLEN(XR),WA OFFSET TO BUFFER END ! 8595: ZER WB NO CHARS TO BE REPLACED ! 8596: JSR INSBF DO THE APPEND ! 8597: ERR 068,APPEND SECOND ARGUMENT IS NOT STRING ! 8598: PPM EXFAL NO ROOM - FAIL ! 8599: BRN EXNUL EXIT WITH NULL RESULT ! 8600: .FI ! 8601: EJC ! 8602: * ! 8603: * APPLY ! 8604: * ! 8605: * APPLY DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT ! 8606: * WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED. ! 8607: * ! 8608: S$APP ENT ENTRY POINT ! 8609: BZE WA,SAPP3 JUMP IF NO ARGUMENTS ! 8610: DCV WA ELSE GET APPLIED FUNC ARG COUNT ! 8611: MOV WA,WB COPY ! 8612: WTB WB CONVERT TO BAUS ! 8613: MOV XS,XT COPY STACK POINTER ! 8614: ADD WB,XT POINT TO FUNCTION ARGUMENT ON STACK ! 8615: MOV (XT),XR LOAD FUNCTION PTR (APPLY 1ST ARG) ! 8616: BZE WA,SAPP2 JUMP IF NO ARGS FOR APPLIED FUNC ! 8617: LCT WB,WA ELSE SET COUNTER FOR LOOP ! 8618: * ! 8619: * LOOP TO MOVE ARGUMENTS UP ON STACK ! 8620: * ! 8621: SAPP1 DCA XT POINT TO NEXT ARGUMENT ! 8622: MOV (XT),1(XT) MOVE ARGUMENT UP ! 8623: BCT WB,SAPP1 LOOP TILL ALL MOVED ! 8624: * ! 8625: * MERGE HERE TO CALL FUNCTION (WA = NUMBER OF ARGUMENTS) ! 8626: * ! 8627: SAPP2 ICA XS ADJUST STACK PTR FOR APPLY 1ST ARG ! 8628: JSR GTNVR GET VARIABLE BLOCK ADDR FOR FUNC ! 8629: PPM SAPP3 JUMP IF NOT NATURAL VARIABLE ! 8630: MOV VRFNC(XR),XL ELSE POINT TO FUNCTION BLOCK ! 8631: BRN CFUNC GO CALL APPLIED FUNCTION ! 8632: * ! 8633: * HERE FOR INVALID FIRST ARGUMENT ! 8634: * ! 8635: SAPP3 ERB 069,APPLY FIRST ARG IS NOT NATURAL VARIABLE NAME ! 8636: EJC ! 8637: * ! 8638: * ARBNO ! 8639: * ! 8640: * ARBNO BUILDS A COMPOUND PATTERN. SEE DESCRIPTION AT ! 8641: * START OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED. ! 8642: * ! 8643: S$ABN ENT ENTRY POINT ! 8644: ZER XR SET PARM1 = 0 FOR THE MOMENT ! 8645: MOV =P$ALT,WB SET PCODE FOR ALTERNATIVE NODE ! 8646: JSR PBILD BUILD ALTERNATIVE NODE ! 8647: MOV XR,XL SAVE PTR TO ALTERNATIVE PATTERN ! 8648: MOV =P$ABC,WB PCODE FOR P$ABC ! 8649: ZER XR P0BLK ! 8650: JSR PBILD BUILD P$ABC NODE ! 8651: MOV XL,PTHEN(XR) PUT ALTERNATIVE NODE AS SUCCESSOR ! 8652: MOV XL,WA REMEMBER ALTERNATIVE NODE POINTER ! 8653: MOV XR,XL COPY P$ABC NODE PTR ! 8654: MOV (XS),XR LOAD ARBNO ARGUMENT ! 8655: MOV WA,(XS) STACK ALTERNATIVE NODE POINTER ! 8656: JSR GTPAT GET ARBNO ARGUMENT AS PATTERN ! 8657: ERR 070,ARBNO ARGUMENT IS NOT PATTERN ! 8658: JSR PCONC CONCAT ARG WITH P$ABC NODE ! 8659: MOV XR,XL REMEMBER PTR TO CONCD PATTERNS ! 8660: MOV =P$ABA,WB PCODE FOR P$ABA ! 8661: ZER XR P0BLK ! 8662: JSR PBILD BUILD P$ABA NODE ! 8663: MOV XL,PTHEN(XR) CONCATENATE NODES ! 8664: MOV (XS),XL RECALL PTR TO ALTERNATIVE NODE ! 8665: MOV XR,PARM1(XL) POINT ALTERNATIVE BACK TO ARGUMENT ! 8666: BRN EXITS JUMP FOR NEXT CODE WORD ! 8667: EJC ! 8668: * ! 8669: * ARG ! 8670: * ! 8671: S$ARG ENT ENTRY POINT ! 8672: JSR GTSMI GET SECOND ARG AS SMALL INTEGER ! 8673: ERR 253,ARG SECOND ARGUMENT IS NOT INTEGER ! 8674: PPM EXFAL FAIL IF OUT OF RANGE OR NEGATIVE ! 8675: MOV XR,WA SAVE ARGUMENT NUMBER ! 8676: MOV (XS)+,XR LOAD FIRST ARGUMENT ! 8677: JSR GTNVR LOCATE VRBLK ! 8678: PPM SARG1 JUMP IF NOT NATURAL VARIABLE ! 8679: MOV VRFNC(XR),XR ELSE LOAD FUNCTION BLOCK POINTER ! 8680: BNE (XR),=B$PFC,SARG1 JUMP IF NOT PROGRAM DEFINED ! 8681: BZE WA,EXFAL FAIL IF ARG NUMBER IS ZERO ! 8682: BGT WA,FARGS(XR),EXFAL FAIL IF ARG NUMBER IS TOO LARGE ! 8683: WTB WA ELSE CONVERT TO BYTE OFFSET ! 8684: ADD WA,XR POINT TO ARGUMENT SELECTED ! 8685: MOV PFAGB(XR),XR LOAD ARGUMENT VRBLK POINTER ! 8686: BRN EXVNM EXIT TO BUILD NMBLK ! 8687: * ! 8688: * HERE IF 1ST ARGUMENT IS BAD ! 8689: * ! 8690: SARG1 ERB 252,ARG FIRST ARGUMENT IS NOT PROGRAM FUNCTION NAME ! 8691: EJC ! 8692: * ! 8693: * ARRAY ! 8694: * ! 8695: S$ARR ENT ENTRY POINT ! 8696: MOV (XS)+,XL LOAD INITIAL ELEMENT VALUE ! 8697: MOV (XS)+,XR LOAD FIRST ARGUMENT ! 8698: JSR GTINT CONVERT FIRST ARG TO INTEGER ! 8699: PPM SAR02 JUMP IF NOT INTEGER ! 8700: * ! 8701: * HERE FOR INTEGER FIRST ARGUMENT, BUILD VCBLK ! 8702: * ! 8703: LDI ICVAL(XR) LOAD INTEGER VALUE ! 8704: ILE SAR10 JUMP IF ZERO OR NEG (BAD DIMENSION) ! 8705: MFI WA,SAR11 ELSE CONVERT TO ONE WORD, TEST OVFL ! 8706: LCT WB,WA COPY ELEMENTS FOR LOOP LATER ON ! 8707: ADD =VCSI$,WA ADD SPACE FOR STANDARD FIELDS ! 8708: WTB WA CONVERT LENGTH TO BAUS ! 8709: BGE WA,MXLEN,SAR11 FAIL IF TOO LARGE ! 8710: JSR ALLOC ALLOCATE SPACE FOR VCBLK ! 8711: MOV =B$VCT,(XR) STORE TYPE WORD ! 8712: MOV WA,VCLEN(XR) SET LENGTH ! 8713: MOV XL,WC COPY DEFAULT VALUE ! 8714: MOV XR,XL COPY VCBLK POINTER ! 8715: ADD *VCVLS,XL POINT TO FIRST ELEMENT VALUE ! 8716: * ! 8717: * LOOP TO SET VECTOR ELEMENTS TO DEFAULT VALUE ! 8718: * ! 8719: SAR01 MOV WC,(XL)+ STORE ONE VALUE ! 8720: BCT WB,SAR01 LOOP TILL ALL STORED ! 8721: BRN EXSID EXIT SETTING IDVAL ! 8722: EJC ! 8723: * ! 8724: * ARRAY (CONTINUED) ! 8725: * ! 8726: * HERE IF FIRST ARGUMENT IS NOT AN INTEGER ! 8727: * ! 8728: SAR02 MOV XR,-(XS) REPLACE ARGUMENT ON STACK ! 8729: JSR XSCNI INITIALIZE SCAN OF FIRST ARGUMENT ! 8730: ERR 071,ARRAY FIRST ARGUMENT IS NOT INTEGER OR STRING ! 8731: PPM EXNUL DUMMY (UNUSED) NULL STRING EXIT ! 8732: MOV R$XSC,-(XS) SAVE PROTOTYPE POINTER ! 8733: MOV XL,-(XS) SAVE DEFAULT VALUE ! 8734: ZER ARCDM ZERO COUNT OF DIMENSIONS ! 8735: ZER ARPTR ZERO OFFSET TO INDICATE PASS ONE ! 8736: LDI INTV1 LOAD INTEGER ONE ! 8737: STI ARNEL INITIALIZE ELEMENT COUNT ! 8738: * ! 8739: * THE FOLLOWING CODE IS EXECUTED TWICE. THE FIRST TIME ! 8740: * (ARPTR EQ 0), IT IS USED TO COUNT THE NUMBER OF ELEMENTS ! 8741: * AND NUMBER OF DIMENSIONS. THE SECOND TIME (ARPTR GT 0) IS ! 8742: * USED TO ACTUALLY FILL IN THE DIM,LBD FIELDS OF THE ARBLK. ! 8743: * ! 8744: SAR03 LDI INTV1 LOAD ONE AS DEFAULT LOW BOUND ! 8745: STI ARSVL SAVE AS LOW BOUND ! 8746: MOV =CH$CL,WC SET DELIMITER ONE = COLON ! 8747: MOV =CH$CM,XL SET DELIMITER TWO = COMMA ! 8748: JSR XSCAN SCAN NEXT BOUND ! 8749: BNE WA,=NUM01,SAR04 JUMP IF NOT COLON ! 8750: * ! 8751: * HERE WE HAVE A COLON ENDING A LOW BOUND ! 8752: * ! 8753: JSR GTINT CONVERT LOW BOUND ! 8754: ERR 072,ARRAY FIRST ARGUMENT LOWER BOUND IS NOT INTEGER ! 8755: LDI ICVAL(XR) LOAD VALUE OF LOW BOUND ! 8756: STI ARSVL STORE LOW BOUND VALUE ! 8757: MOV =CH$CM,WC SET DELIMITER ONE = COMMA ! 8758: MOV WC,XL AND DELIMITER TWO = COMMA ! 8759: JSR XSCAN SCAN HIGH BOUND ! 8760: EJC ! 8761: * ! 8762: * ARRAY (CONTINUED) ! 8763: * ! 8764: * MERGE HERE TO PROCESS UPPER BOUND ! 8765: * ! 8766: SAR04 BNZ WA,SAR4A SKIP IF DELIMITER 1 OR 2 ! 8767: BNZ XSCNB,SAR10 JUMP IF ILLEGALLY PLACED BLANK ! 8768: * ! 8769: * CHECK FOR INTEGER BOUND ! 8770: * ! 8771: SAR4A JSR GTINT CONVERT HIGH BOUND TO INTEGER ! 8772: ERR 073,ARRAY FIRST ARGUMENT UPPER BOUND IS NOT INTEGER ! 8773: LDI ICVAL(XR) GET HIGH BOUND ! 8774: SBI ARSVL SUBTRACT LOWER BOUND ! 8775: IOV SAR10 BAD DIMENSION IF OVERFLOW ! 8776: ILT SAR10 BAD DIMENSION IF NEGATIVE ! 8777: ADI INTV1 ADD 1 TO GET DIMENSION ! 8778: IOV SAR10 BAD DIMENSION IF OVERFLOW ! 8779: MOV ARPTR,XL LOAD OFFSET (ALSO PASS INDICATOR) ! 8780: BZE XL,SAR05 JUMP IF FIRST PASS ! 8781: * ! 8782: * HERE IN SECOND PASS TO STORE LBD AND DIM IN ARBLK ! 8783: * ! 8784: ADD (XS),XL POINT TO CURRENT LOCATION IN ARBLK ! 8785: STI CFP$I(XL) STORE DIMENSION ! 8786: LDI ARSVL LOAD LOW BOUND ! 8787: STI (XL) STORE LOW BOUND ! 8788: ADD *ARDMS,ARPTR BUMP OFFSET TO NEXT BOUNDS ! 8789: BRN SAR06 JUMP TO CHECK FOR END OF BOUNDS ! 8790: * ! 8791: * HERE IN PASS 1 ! 8792: * ! 8793: SAR05 ICV ARCDM BUMP DIMENSION COUNT ! 8794: MLI ARNEL MULTIPLY DIMENSION BY COUNT SO FAR ! 8795: IOV SAR11 TOO LARGE IF OVERFLOW ! 8796: STI ARNEL ELSE STORE UPDATED ELEMENT COUNT ! 8797: * ! 8798: * MERGE HERE AFTER PROCESSING ONE SET OF BOUNDS ! 8799: * ! 8800: SAR06 BNZ WA,SAR03 LOOP BACK UNLESS END OF BOUNDS ! 8801: BNZ ARPTR,SAR09 JUMP IF END OF PASS 2 ! 8802: EJC ! 8803: * ! 8804: * ARRAY (CONTINUED) ! 8805: * ! 8806: * HERE AT END OF PASS ONE, BUILD ARBLK ! 8807: * ! 8808: LDI ARNEL GET NUMBER OF ELEMENTS ! 8809: MFI WB,SAR11 GET AS ADDR INTEGER, TEST OVFLO ! 8810: WTB WB ELSE CONVERT TO LENGTH IN BAUS ! 8811: MOV *ARSI$,WA SET SIZE OF STANDARD FIELDS ! 8812: LCT WC,ARCDM SET DIMENSION COUNT TO CONTROL LOOP ! 8813: * ! 8814: * LOOP TO ALLOW SPACE FOR DIMENSIONS ! 8815: * ! 8816: SAR07 ADD *ARDMS,WA ALLOW SPACE FOR ONE SET OF BOUNDS ! 8817: BCT WC,SAR07 LOOP BACK TILL ALL ACCOUNTED FOR ! 8818: MOV WA,XL SAVE SIZE (=AROFS) ! 8819: * ! 8820: * NOW ALLOCATE SPACE FOR ARBLK ! 8821: * ! 8822: ADD WB,WA ADD SPACE FOR ELEMENTS ! 8823: ICA WA ALLOW FOR ARPRO PROTOTYPE FIELD ! 8824: BGE WA,MXLEN,SAR11 FAIL IF TOO LARGE ! 8825: JSR ALLOC ELSE ALLOCATE ARBLK ! 8826: MOV (XS),WB LOAD DEFAULT VALUE ! 8827: MOV XR,(XS) SAVE ARBLK POINTER ! 8828: MOV WA,WC SAVE LENGTH IN BAUS ! 8829: BTW WA CONVERT LENGTH BACK TO WORDS ! 8830: LCT WA,WA SET COUNTER TO CONTROL LOOP ! 8831: * ! 8832: * LOOP TO CLEAR ENTIRE ARBLK TO DEFAULT VALUE ! 8833: * ! 8834: SAR08 MOV WB,(XR)+ SET ONE WORD ! 8835: BCT WA,SAR08 LOOP TILL ALL SET ! 8836: EJC ! 8837: * ! 8838: * ARRAY (CONTINUED) ! 8839: * ! 8840: * NOW SET INITIAL FIELDS OF ARBLK ! 8841: * ! 8842: MOV (XS)+,XR RELOAD ARBLK POINTER ! 8843: MOV (XS),WB LOAD PROTOTYPE ! 8844: MOV =B$ART,(XR) SET TYPE WORD ! 8845: MOV WC,ARLEN(XR) STORE LENGTH IN BAUS ! 8846: ZER IDVAL(XR) ZERO ID TILL WE GET IT BUILT ! 8847: MOV XL,AROFS(XR) SET PROTOTYPE FIELD PTR ! 8848: MOV ARCDM,ARNDM(XR) SET NUMBER OF DIMENSIONS ! 8849: MOV XR,WC SAVE ARBLK POINTER ! 8850: ADD XL,XR POINT TO PROTOTYPE FIELD ! 8851: MOV WB,(XR) STORE PROTOTYPE PTR IN ARBLK ! 8852: MOV *ARLBD,ARPTR SET OFFSET FOR PASS 2 BOUNDS SCAN ! 8853: MOV WB,R$XSC RESET STRING POINTER FOR XSCAN ! 8854: MOV WC,(XS) STORE ARBLK POINTER ON STACK ! 8855: ZER XSOFS RESET OFFSET PTR TO START OF STRING ! 8856: BRN SAR03 JUMP BACK TO RESCAN BOUNDS ! 8857: * ! 8858: * HERE AFTER FILLING IN BOUNDS INFORMATION (END PASS TWO) ! 8859: * ! 8860: SAR09 MOV (XS)+,XR RELOAD POINTER TO ARBLK ! 8861: BRN EXSID EXIT SETTING IDVAL ! 8862: * ! 8863: * HERE FOR BAD DIMENSION ! 8864: * ! 8865: SAR10 ERB 074,BAD DIMENSION, ZERO, NEGATIVE OR OUT OF RANGE ! 8866: * ! 8867: * HERE IF ARRAY IS TOO LARGE ! 8868: * ! 8869: SAR11 ERB 075,ARRAY SIZE EXCEEDS MAXIMUM PERMITTED ! 8870: EJC ! 8871: * ! 8872: * BREAK ! 8873: * ! 8874: S$BRK ENT ENTRY POINT ! 8875: MOV =P$BKS,WB SET PCODE FOR SINGLE CHAR CASE ! 8876: MOV =P$BRK,XL PCODE FOR MULTI-CHAR CASE ! 8877: MOV =P$BKD,WC PCODE FOR EXPRESSION CASE ! 8878: JSR PATST CALL COMMON ROUTINE TO BUILD NODE ! 8879: ERR 076,BREAK ARGUMENT IS NOT STRING OR EXPRESSION ! 8880: BRN EXIXR JUMP FOR NEXT CODE WORD ! 8881: EJC ! 8882: * ! 8883: * BREAKX ! 8884: * ! 8885: * BREAKX IS A COMPOUND PATTERN. SEE DESCRIPTION AT START ! 8886: * OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED. ! 8887: * ! 8888: S$BKX ENT ENTRY POINT ! 8889: MOV =P$BKS,WB PCODE FOR SINGLE CHAR ARGUMENT ! 8890: MOV =P$BRK,XL PCODE FOR MULTI-CHAR ARGUMENT ! 8891: MOV =P$BXD,WC PCODE FOR EXPRESSION CASE ! 8892: JSR PATST CALL COMMON ROUTINE TO BUILD NODE ! 8893: ERR 077,BREAKX ARGUMENT IS NOT STRING OR EXPRESSION ! 8894: * ! 8895: * NOW HOOK BREAKX NODE ON AT FRONT END ! 8896: * ! 8897: MOV XR,-(XS) SAVE PTR TO BREAK NODE ! 8898: MOV =P$BKX,WB SET PCODE FOR BREAKX NODE ! 8899: JSR PBILD BUILD IT ! 8900: MOV (XS),PTHEN(XR) SET BREAK NODE AS SUCCESSOR ! 8901: MOV =P$ALT,WB SET PCODE FOR ALTERNATION NODE ! 8902: JSR PBILD BUILD (PARM1=ALT=BREAKX NODE) ! 8903: MOV XR,WA SAVE PTR TO ALTERNATION NODE ! 8904: MOV (XS),XR POINT TO BREAK NODE ! 8905: MOV WA,PTHEN(XR) SET ALTERNATE NODE AS SUCCESSOR ! 8906: BRN EXITS EXIT WITH RESULT ON STACK ! 8907: .IF .CNBF ! 8908: .ELSE ! 8909: EJC ! 8910: * ! 8911: * BUFFER ! 8912: * ! 8913: S$BUF ENT ENTRY POINT ! 8914: MOV (XS)+,XL GET INITIAL STRING ! 8915: JSR GTSMI CONVERT MEMORY REQUEST TO INTEGER ! 8916: ERR 078,BUFFER FIRST ARGUMENT IS NOT INTEGER ! 8917: PPM SBF01 FAIL IF OUT OF RANGE ! 8918: MOV WC,WA MOVE LENGTH TO CORRECT REGISTER ! 8919: JSR ALOBF ALLOCATE THE BUFFER ! 8920: JSR INSBF COPY INITIAL ARG IN ! 8921: ERR 079,BUFFER SECOND ARGUMENT IS NOT STRING OR BUFFER ! 8922: ERR 080,BUFFER INITIAL VALUE TOO BIG FOR ALLOCATION ! 8923: BRN EXSID EXIT SETTING IDVAL ! 8924: * ! 8925: * HERE FOR INVALID ALLOCATION SIZE ! 8926: * ! 8927: SBF01 ERB 081,BUFFER FIRST ARGUMENT IS OUT OF RANGE ! 8928: .FI ! 8929: EJC ! 8930: * ! 8931: * CLEAR ! 8932: * ! 8933: S$CLR ENT ENTRY POINT ! 8934: JSR XSCNI INITIALIZE TO SCAN ARGUMENT ! 8935: ERR 082,CLEAR ARGUMENT IS NOT STRING ! 8936: PPM SCLR2 JUMP IF NULL ! 8937: * ! 8938: * LOOP TO SCAN OUT NAMES IN FIRST ARGUMENT. VARIABLES IN ! 8939: * THE LIST ARE FLAGGED BY SETTING VRGET OF VRBLK TO ZERO. ! 8940: * ! 8941: SCLR1 MOV =CH$CM,WC SET DELIMITER ONE = COMMA ! 8942: MOV WC,XL DELIMITER TWO = COMMA ! 8943: JSR XSCAN SCAN NEXT VARIABLE NAME ! 8944: JSR GTNVR LOCATE VRBLK ! 8945: PPM SCLR7 ERRONEOUS NAME ! 8946: ZER VRGET(XR) ELSE FLAG BY ZEROING VRGET FIELD ! 8947: BNZ WA,SCLR1 LOOP BACK IF STOPPED BY COMMA ! 8948: BNZ XSCNB,SCLR7 BADLY PLACED BLANK ! 8949: * ! 8950: * HERE AFTER FLAGGING VARIABLES IN ARGUMENT LIST ! 8951: * ! 8952: SCLR2 MOV HSHTB,WB POINT TO START OF HASH TABLE ! 8953: * ! 8954: * LOOP THROUGH SLOTS IN HASH TABLE ! 8955: * ! 8956: SCLR3 BEQ WB,HSHTE,EXNUL EXIT RETURNING NULL IF NONE LEFT ! 8957: MOV WB,XR ELSE COPY SLOT POINTER ! 8958: ICA WB BUMP SLOT POINTER ! 8959: SUB *VRNXT,XR SET OFFSET TO MERGE INTO LOOP ! 8960: * ! 8961: * LOOP THROUGH VRBLKS ON ONE HASH CHAIN ! 8962: * ! 8963: SCLR4 MOV VRNXT(XR),XR POINT TO NEXT VRBLK ON CHAIN ! 8964: BZE XR,SCLR3 JUMP FOR NEXT BUCKET IF CHAIN END ! 8965: BNZ VRGET(XR),SCLR5 JUMP IF NOT FLAGGED ! 8966: EJC ! 8967: * ! 8968: * CLEAR (CONTINUED) ! 8969: * ! 8970: * HERE FOR FLAGGED VARIABLE, DO NOT SET VALUE TO NULL ! 8971: * ! 8972: JSR SETVR FOR FLAGGED VAR, RESTORE VRGET ! 8973: BRN SCLR4 AND LOOP BACK FOR NEXT VRBLK ! 8974: * ! 8975: * HERE TO SET VALUE OF A VARIABLE TO NULL ! 8976: * PROTECTED VARIABLES (ARB ETC) ARE EXEMPT ! 8977: * ! 8978: SCLR5 BEQ VRSTO(XR),=B$VRE,SCLR4 CHECK FOR PROTECTED VARIABLE ! 8979: MOV XR,XL COPY VRBLK POINTER ! 8980: * ! 8981: * LOOP TO LOCATE VALUE AT END OF POSSIBLE TRBLK CHAIN ! 8982: * ! 8983: SCLR6 MOV XL,WA SAVE BLOCK POINTER ! 8984: MOV VRVAL(XL),XL LOAD NEXT VALUE FIELD ! 8985: BEQ (XL),=B$TRT,SCLR6 LOOP BACK IF TRAPPED ! 8986: * ! 8987: * NOW STORE THE NULL VALUE ! 8988: * ! 8989: MOV WA,XL RESTORE BLOCK POINTER ! 8990: MOV =NULLS,VRVAL(XL) STORE NULL CONSTANT VALUE ! 8991: BRN SCLR4 LOOP BACK FOR NEXT VRBLK ! 8992: * ! 8993: * ERROR POINT ! 8994: * ! 8995: SCLR7 ERB 083,NULL VARIABLE NAME OR ILLEGAL BLANK IN CLEAR ARG ! 8996: EJC ! 8997: * ! 8998: * CODE ! 8999: * ! 9000: S$COD ENT ENTRY POINT ! 9001: MOV (XS)+,XR LOAD ARGUMENT ! 9002: JSR GTCOD CONVERT TO CODE ! 9003: PPM EXFAL FAIL IF CONVERSION IS IMPOSSIBLE ! 9004: BRN EXIXR ELSE RETURN CODE AS RESULT ! 9005: EJC ! 9006: * ! 9007: * COLLECT ! 9008: * ! 9009: S$COL ENT ENTRY POINT ! 9010: MOV (XS)+,XR LOAD ARGUMENT ! 9011: JSR GTINT CONVERT TO INTEGER ! 9012: ERR 084,COLLECT ARGUMENT IS NOT INTEGER ! 9013: LDI ICVAL(XR) LOAD COLLECT ARGUMENT ! 9014: STI CLSVI SAVE COLLECT ARGUMENT ! 9015: ZER WB SET NO MOVE UP ! 9016: JSR GBCOL PERFORM GARBAGE COLLECTION ! 9017: MOV DNAME,WA POINT TO END OF MEMORY ! 9018: SUB DNAMP,WA SUBTRACT NEXT LOCATION ! 9019: BTW WA CONVERT BAUS TO WORDS ! 9020: MTI WA CONVERT WORDS AVAILABLE AS INTEGER ! 9021: SBI CLSVI SUBTRACT ARGUMENT ! 9022: IOV EXFAL FAIL IF OVERFLOW ! 9023: ILT EXFAL FAIL IF NOT ENOUGH ! 9024: ADI CLSVI ELSE RECOMPUTE AVAILABLE ! 9025: BRN EXINT AND EXIT WITH INTEGER RESULT ! 9026: EJC ! 9027: * ! 9028: * CONVERT ! 9029: * ! 9030: S$CVT ENT ENTRY POINT ! 9031: JSR GTSTG CONVERT SECOND ARGUMENT TO STRING ! 9032: ERR 085,CONVERT SECOND ARGUMENT IS NOT STRING ! 9033: .IF .CASL ! 9034: MOV XR,XL COPY STRING PTR TO XL ! 9035: ZER WB ZERO OFFSET ! 9036: JSR SBSTG CONVERT CASE OF ARG IF NECESSARY ! 9037: .FI ! 9038: MOV (XS),XL LOAD FIRST ARGUMENT ! 9039: BNE (XL),=B$PDT,SCV01 JUMP IF NOT PROGRAM DEFINED ! 9040: * ! 9041: * HERE FOR PROGRAM DEFINED DATATYPE ! 9042: * ! 9043: MOV PDDFP(XL),XL POINT TO DFBLK ! 9044: MOV DFNAM(XL),XL LOAD DATATYPE NAME ! 9045: JSR IDENT COMPARE WITH SECOND ARG ! 9046: PPM EXITS EXIT IF IDENT WITH ARG AS RESULT ! 9047: BRN EXFAL ELSE FAIL ! 9048: * ! 9049: * HERE IF NOT PROGRAM DEFINED DATATYPE ! 9050: * ! 9051: SCV01 MOV XR,-(XS) SAVE STRING ARGUMENT ! 9052: MOV =SVCTB,XL POINT TO TABLE OF NAMES TO COMPARE ! 9053: ZER WB INITIALIZE COUNTER ! 9054: MOV SCLEN(XR),WC SAVE LENGTH OF ARGUMENT STRING ! 9055: * ! 9056: * LOOP THROUGH TABLE ENTRIES ! 9057: * ! 9058: SCV02 MOV (XL)+,XR LOAD NEXT TABLE ENTRY, BUMP POINTER ! 9059: BZE XR,EXFAL FAIL IF ZERO MARKING END OF LIST ! 9060: BNE WC,SCLEN(XR),SCV05 JUMP IF WRONG LENGTH ! 9061: MOV XL,CNVTP ELSE STORE TABLE POINTER ! 9062: PLC XR POINT TO CHARS OF TABLE ENTRY ! 9063: MOV (XS),XL LOAD POINTER TO STRING ARGUMENT ! 9064: PLC XL POINT TO CHARS OF STRING ARG ! 9065: MOV WC,WA SET NUMBER OF CHARS TO COMPARE ! 9066: CMC SCV04,SCV04 COMPARE, JUMP IF NO MATCH ! 9067: EJC ! 9068: * ! 9069: * CONVERT (CONTINUED) ! 9070: * ! 9071: * HERE WE HAVE A MATCH ! 9072: * ! 9073: SCV03 MOV WB,XL COPY ENTRY NUMBER ! 9074: ICA XS POP STRING ARG OFF STACK ! 9075: MOV (XS)+,XR LOAD FIRST ARGUMENT ! 9076: BSW XL,CNVTT JUMP TO APPROPRIATE ROUTINE ! 9077: IFF 0,SCV06 STRING ! 9078: IFF 1,SCV07 INTEGER ! 9079: IFF 2,SCV09 NAME ! 9080: IFF 3,SCV10 PATTERN ! 9081: IFF 4,SCV11 ARRAY ! 9082: IFF 5,SCV19 TABLE ! 9083: IFF 6,SCV25 EXPRESSION ! 9084: IFF 7,SCV26 CODE ! 9085: IFF 8,SCV27 NUMERIC ! 9086: .IF .CNRA ! 9087: .ELSE ! 9088: IFF 9,SCV08 REAL ! 9089: .FI ! 9090: .IF .CNBF ! 9091: .ELSE ! 9092: IFF CNVBT,SCV28 BUFFER ! 9093: .FI ! 9094: ESW END OF SWITCH TABLE ! 9095: * ! 9096: * HERE IF NO MATCH WITH TABLE ENTRY ! 9097: * ! 9098: SCV04 MOV CNVTP,XL RESTORE TABLE POINTER, MERGE ! 9099: * ! 9100: * MERGE HERE IF LENGTHS DID NOT MATCH ! 9101: * ! 9102: SCV05 ICV WB BUMP ENTRY NUMBER ! 9103: BRN SCV02 LOOP BACK TO CHECK NEXT ENTRY ! 9104: * ! 9105: * HERE TO CONVERT TO STRING ! 9106: * ! 9107: SCV06 MOV XR,-(XS) REPLACE STRING ARGUMENT ON STACK ! 9108: JSR GTSTG CONVERT TO STRING ! 9109: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE ! 9110: BRN EXIXR ELSE RETURN STRING ! 9111: EJC ! 9112: * ! 9113: * CONVERT (CONTINUED) ! 9114: * ! 9115: * HERE TO CONVERT TO INTEGER ! 9116: * ! 9117: SCV07 JSR GTINT CONVERT TO INTEGER ! 9118: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE ! 9119: BRN EXIXR ELSE RETURN INTEGER ! 9120: .IF .CNRA ! 9121: .ELSE ! 9122: * ! 9123: * HERE TO CONVERT TO REAL ! 9124: * ! 9125: SCV08 JSR GTREA CONVERT TO REAL ! 9126: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE ! 9127: BRN EXIXR ELSE RETURN REAL ! 9128: .FI ! 9129: * ! 9130: * HERE TO CONVERT TO NAME ! 9131: * ! 9132: SCV09 BEQ (XR),=B$NML,EXIXR RETURN IF ALREADY A NAME ! 9133: JSR GTNVR ELSE TRY STRING TO NAME CONVERT ! 9134: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE ! 9135: BRN EXVNM ELSE EXIT BUILDING NMBLK FOR VRBLK ! 9136: * ! 9137: * HERE TO CONVERT TO PATTERN ! 9138: * ! 9139: SCV10 JSR GTPAT CONVERT TO PATTERN ! 9140: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE ! 9141: BRN EXIXR ELSE RETURN PATTERN ! 9142: * ! 9143: * CONVERT TO ARRAY ! 9144: * ! 9145: SCV11 JSR GTARR GET AN ARRAY ! 9146: PPM EXFAL FAIL IF NOT CONVERTIBLE ! 9147: BRN EXSID EXIT SETTING ID FIELD ! 9148: * ! 9149: * CONVERT TO TABLE ! 9150: * ! 9151: SCV19 MOV (XR),WA LOAD FIRST WORD OF BLOCK ! 9152: MOV XR,-(XS) REPLACE ARBLK POINTER ON STACK ! 9153: BEQ WA,=B$TBT,EXITS RETURN ARG IF ALREADY A TABLE ! 9154: BNE WA,=B$ART,EXFAL ELSE FAIL IF NOT AN ARRAY ! 9155: EJC ! 9156: * ! 9157: * CONVERT (CONTINUED) ! 9158: * ! 9159: * HERE TO CONVERT AN ARRAY TO TABLE ! 9160: * ! 9161: BNE ARNDM(XR),=NUM02,EXFAL FAIL IF NOT 2-DIM ARRAY ! 9162: LDI ARDM2(XR) LOAD DIM 2 ! 9163: SBI INTV2 SUBTRACT 2 TO COMPARE ! 9164: INE EXFAL FAIL IF DIM2 NOT 2 ! 9165: * ! 9166: * HERE WE HAVE AN ARBLK OF THE RIGHT SHAPE ! 9167: * ! 9168: LDI ARDIM(XR) LOAD DIM 1 (NUMBER OF ELEMENTS) ! 9169: MFI WA GET AS ONE WORD INTEGER ! 9170: LCT WB,WA COPY TO CONTROL LOOP ! 9171: ADD =TBSI$,WA ADD SPACE FOR STANDARD FIELDS ! 9172: WTB WA CONVERT LENGTH TO BAUS ! 9173: JSR ALLOC ALLOCATE SPACE FOR TBBLK ! 9174: MOV XR,WC COPY TBBLK POINTER ! 9175: MOV XR,-(XS) SAVE TBBLK POINTER ! 9176: MOV =B$TBT,(XR)+ STORE TYPE WORD ! 9177: ZER (XR)+ STORE ZERO FOR IDVAL FOR NOW ! 9178: MOV WA,(XR)+ STORE LENGTH ! 9179: MOV =NULLS,(XR)+ NULL INITIAL LOOKUP VALUE ! 9180: * ! 9181: * LOOP TO INITIALIZE BUCKET PTRS TO POINT TO TABLE ! 9182: * ! 9183: SCV20 MOV WC,(XR)+ SET BUCKET PTR TO POINT TO TBBLK ! 9184: BCT WB,SCV20 LOOP TILL ALL INITIALIZED ! 9185: MOV *ARVL2,WB SET OFFSET TO FIRST ARBLK ELEMENT ! 9186: * ! 9187: * LOOP TO COPY ELEMENTS FROM ARRAY TO TABLE ! 9188: * ! 9189: SCV21 MOV 1(XS),XL POINT TO ARBLK ! 9190: BEQ WB,ARLEN(XL),SCV24 JUMP IF ALL MOVED ! 9191: ADD WB,XL ELSE POINT TO CURRENT LOCATION ! 9192: ADD *NUM02,WB BUMP OFFSET ! 9193: MOV (XL),XR LOAD SUBSCRIPT NAME ! 9194: DCA XL ADJUST PTR TO MERGE (TRVAL=1+1) ! 9195: EJC ! 9196: * ! 9197: * CONVERT (CONTINUED) ! 9198: * ! 9199: * LOOP TO CHASE DOWN TRBLK CHAIN FOR VALUE ! 9200: * ! 9201: SCV22 MOV TRVAL(XL),XL POINT TO NEXT VALUE ! 9202: BEQ (XL),=B$TRT,SCV22 LOOP BACK IF TRAPPED ! 9203: * ! 9204: * HERE WITH NAME IN XR, VALUE IN XL ! 9205: * ! 9206: SCV23 MOV XL,-(XS) STACK VALUE ! 9207: MOV 1(XS),XL LOAD TBBLK POINTER ! 9208: JSR TFIND BUILD TEBLK (NOTE WB GT 0 BY NAME) ! 9209: PPM EXFAL FAIL IF ACESS FAILS ! 9210: MOV (XS)+,TEVAL(XL) STORE VALUE IN TEBLK ! 9211: BRN SCV21 LOOP BACK FOR NEXT ELEMENT ! 9212: * ! 9213: * HERE AFTER MOVING ALL ELEMENTS TO TBBLK ! 9214: * ! 9215: SCV24 MOV (XS)+,XR LOAD TBBLK POINTER ! 9216: ICA XS POP ARBLK POINTER ! 9217: BRN EXSID EXIT SETTING IDVAL ! 9218: * ! 9219: * CONVERT TO EXPRESSION ! 9220: * ! 9221: SCV25 JSR GTEXP CONVERT TO EXPRESSION ! 9222: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE ! 9223: BRN EXIXR ELSE RETURN EXPRESSION ! 9224: * ! 9225: * CONVERT TO CODE ! 9226: * ! 9227: SCV26 JSR GTCOD CONVERT TO CODE ! 9228: PPM EXFAL FAIL IF CONVERSION IS NOT POSSIBLE ! 9229: BRN EXIXR ELSE RETURN CODE ! 9230: * ! 9231: * CONVERT TO NUMERIC ! 9232: * ! 9233: SCV27 JSR GTNUM CONVERT TO NUMERIC ! 9234: PPM EXFAL FAIL IF UNCONVERTIBLE ! 9235: BRN EXIXR RETURN NUMBER ! 9236: EJC ! 9237: .IF .CNBF ! 9238: .ELSE ! 9239: * ! 9240: * CONVERT TO BUFFER ! 9241: * ! 9242: SCV28 JSR GTBUF CONVERT TO BUFFER ! 9243: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE ! 9244: BRN EXSID EXIT SETTING IDVAL FIELD ! 9245: .FI ! 9246: EJC ! 9247: * ! 9248: * COPY ! 9249: * ! 9250: S$COP ENT ENTRY POINT ! 9251: JSR CBLCK COPY THE BLOCK ! 9252: PPM EXITS RETURN IF NO IDVAL FIELD ! 9253: BRN EXSID EXIT SETTING ID VALUE ! 9254: * ! 9255: * CTI ! 9256: * ! 9257: S$CTI ENT ! 9258: LDI INTV0 ZERO IN CASE NULL STRING ! 9259: JSR GTSTG GET ARG AS A STRING ! 9260: ERR 086,CTI ARGUMENT IS NOT A STRING ! 9261: BZE WA,SCT01 SKIP IF NULL ! 9262: PLC XR PREPARE TO READ THE CHARACTER ! 9263: LCH WB,(XR) GET THE CHARACTER ! 9264: MTI WB CONVERT TO INTEGER ! 9265: ZER XR CLEAR GARBAGE ! 9266: * ! 9267: * MAKE ICBLK AND RETURN ! 9268: * ! 9269: SCT01 JSR ICBLD BUILD ICBLK ! 9270: BRN EXIXR RETURN INTEGER RESULT ! 9271: EJC ! 9272: * ! 9273: * DATA ! 9274: * ! 9275: S$DAT ENT ENTRY POINT ! 9276: JSR XSCNI PREPARE TO SCAN ARGUMENT ! 9277: ERR 087,DATA ARGUMENT IS NOT STRING ! 9278: ERR 088,DATA ARGUMENT IS NULL ! 9279: * ! 9280: * SCAN OUT DATATYPE NAME ! 9281: * ! 9282: MOV =CH$PP,WC DELIMITER ONE = LEFT PAREN ! 9283: MOV WC,XL DELIMITER TWO = LEFT PAREN ! 9284: JSR XSCAN SCAN DATATYPE NAME ! 9285: BNZ WA,SDAT1 SKIP IF LEFT PAREN FOUND ! 9286: ERB 089,DATA ARGUMENT IS MISSING A LEFT PAREN ! 9287: * ! 9288: * HERE AFTER SCANNING DATATYPE NAME ! 9289: * ! 9290: SDAT1 MOV XR,XL SAVE NAME PTR ! 9291: MOV SCLEN(XR),WA GET LENGTH ! 9292: CTB WA,SCSI$ COMPUTE SPACE NEEDED ! 9293: JSR ALOST REQUEST STATIC STORE FOR NAME ! 9294: MOV XR,-(XS) SAVE DATATYPE NAME ! 9295: MVW COPY NAME TO STATIC ! 9296: MOV (XS),XR GET NAME PTR ! 9297: ZER XL SCRUB DUD REGISTER ! 9298: JSR GTNVR LOCATE VRBLK FOR DATATYPE NAME ! 9299: ERR 090,DATA ARGUMENT HAS NULL DATATYPE NAME ! 9300: MOV XR,DATDV SAVE VRBLK POINTER FOR DATATYPE ! 9301: MOV XS,DATXS STORE STARTING STACK VALUE ! 9302: ZER WB ZERO COUNT OF FIELD NAMES ! 9303: * ! 9304: * LOOP TO SCAN FIELD NAMES AND STACK VRBLK POINTERS ! 9305: * ! 9306: SDAT2 MOV =CH$RP,WC DELIMITER ONE = RIGHT PAREN ! 9307: MOV =CH$CM,XL DELIMITER TWO = COMMA ! 9308: JSR XSCAN SCAN NEXT FIELD NAME ! 9309: BNZ WA,SDAT3 JUMP IF DELIMITER FOUND ! 9310: ERB 091,BAD BLANK OR MISSING RIGHT PAREN IN DATA ARG ! 9311: * ! 9312: * HERE AFTER SCANNING OUT ONE FIELD NAME ! 9313: * ! 9314: SDAT3 JSR GTNVR LOCATE VRBLK FOR FIELD NAME ! 9315: ERR 092,DATA ARGUMENT HAS NULL FIELD NAME ! 9316: MOV XR,-(XS) STACK VRBLK POINTER ! 9317: ICV WB INCREMENT COUNTER ! 9318: BEQ WA,=NUM02,SDAT2 LOOP BACK IF STOPPED BY COMMA ! 9319: EJC ! 9320: * ! 9321: * DATA (CONTINUED) ! 9322: * ! 9323: * NOW BUILD THE DFBLK ! 9324: * ! 9325: MOV =DFSI$,WA SET SIZE OF DFBLK STANDARD FIELDS ! 9326: ADD WB,WA ADD NUMBER OF FIELDS ! 9327: WTB WA CONVERT LENGTH TO BAUS ! 9328: MOV WB,WC PRESERVE NO. OF FIELDS ! 9329: JSR ALOST ALLOCATE SPACE FOR DFBLK ! 9330: MOV WC,WB GET NO OF FIELDS ! 9331: MOV DATXS,XT POINT TO START OF STACK ! 9332: MOV (XT),WC LOAD DATATYPE NAME ! 9333: MOV XR,(XT) SAVE DFBLK POINTER ON STACK ! 9334: MOV =B$DFC,(XR)+ STORE TYPE WORD ! 9335: MOV WB,(XR)+ STORE NUMBER OF FIELDS (FARGS) ! 9336: MOV WA,(XR)+ STORE LENGTH (DFLEN) ! 9337: SUB *PDDFS,WA COMPUTE PDBLK LENGTH (FOR DFPDL) ! 9338: MOV WA,(XR)+ STORE PDBLK LENGTH (DFPDL) ! 9339: MOV WC,(XR)+ STORE DATATYPE NAME (DFNAM) ! 9340: LCT WC,WB COPY NUMBER OF FIELDS ! 9341: * ! 9342: * LOOP TO MOVE FIELD NAME VRBLK POINTERS TO DFBLK ! 9343: * ! 9344: SDAT4 MOV -(XT),(XR)+ MOVE ONE FIELD NAME VRBLK POINTER ! 9345: BCT WC,SDAT4 LOOP TILL ALL MOVED ! 9346: * ! 9347: * NOW DEFINE THE DATATYPE FUNCTION ! 9348: * ! 9349: MOV WA,WC COPY LENGTH OF PDBLK FOR LATER LOOP ! 9350: MOV DATDV,XR POINT TO VRBLK ! 9351: MOV DATXS,XT POINT BACK ON STACK ! 9352: MOV (XT),XL LOAD DFBLK POINTER ! 9353: JSR DFFNC DEFINE FUNCTION ! 9354: EJC ! 9355: * ! 9356: * DATA (CONTINUED) ! 9357: * ! 9358: * LOOP TO BUILD FFBLKS ! 9359: * ! 9360: * ! 9361: * NOTICE THAT THE FFBLKS ARE CONSTRUCTED IN REVERSE ORDER ! 9362: * SO THAT THE REQUIRED OFFSETS CAN BE OBTAINED FROM ! 9363: * SUCCESSIVE DECREMENTATION OF THE PDBLK LENGTH (IN WC). ! 9364: * ! 9365: SDAT5 MOV *FFSI$,WA SET LENGTH OF FFBLK ! 9366: JSR ALLOC ALLOCATE SPACE FOR FFBLK ! 9367: MOV =B$FFC,(XR) SET TYPE WORD ! 9368: MOV =NUM01,FARGS(XR) STORE FARGS (ALWAYS ONE) ! 9369: MOV DATXS,XT POINT BACK ON STACK ! 9370: MOV (XT),FFDFP(XR) COPY DFBLK PTR TO FFBLK ! 9371: DCA WC DECREMENT OLD DFPDL TO GET NEXT OFS ! 9372: MOV WC,FFOFS(XR) SET OFFSET TO THIS FIELD ! 9373: ZER FFNXT(XR) TENTATIVELY SET ZERO FORWARD PTR ! 9374: MOV XR,XL COPY FFBLK POINTER FOR DFFNC ! 9375: MOV (XS),XR LOAD VRBLK POINTER FOR FIELD ! 9376: MOV VRFNC(XR),XR LOAD CURRENT FUNCTION POINTER ! 9377: BNE (XR),=B$FFC,SDAT6 SKIP IF NOT CURRENTLY A FIELD FUNC ! 9378: * ! 9379: * HERE WE MUST CHAIN AN OLD FFBLK PTR TO PRESERVE IT IN THE ! 9380: * CASE OF MULTIPLE FIELD FUNCTIONS WITH THE SAME NAME ! 9381: * ! 9382: MOV XR,FFNXT(XL) LINK NEW FFBLK TO PREVIOUS CHAIN ! 9383: * ! 9384: * MERGE HERE TO DEFINE FIELD FUNCTION ! 9385: * ! 9386: SDAT6 MOV (XS)+,XR LOAD VRBLK POINTER ! 9387: JSR DFFNC DEFINE FIELD FUNCTION ! 9388: BNE XS,DATXS,SDAT5 LOOP BACK TILL ALL DONE ! 9389: ICA XS POP DFBLK POINTER ! 9390: BRN EXNUL RETURN WITH NULL RESULT ! 9391: EJC ! 9392: * ! 9393: * DATATYPE ! 9394: * ! 9395: S$DTP ENT ENTRY POINT ! 9396: MOV (XS)+,XR LOAD ARGUMENT ! 9397: JSR DTYPE GET DATATYPE ! 9398: BRN EXIXR AND RETURN IT AS RESULT ! 9399: EJC ! 9400: * ! 9401: * DATE ! 9402: * ! 9403: S$DTE ENT ENTRY POINT ! 9404: JSR SYSDT CALL SYSTEM DATE ROUTINE ! 9405: MOV 1(XL),WA LOAD LENGTH FOR SBSTR ! 9406: BZE WA,EXNUL RETURN NULL IF LENGTH IS ZERO ! 9407: ZER WB SET ZERO OFFSET ! 9408: JSR SBSTR USE SBSTR TO BUILD SCBLK ! 9409: BRN EXIXR RETURN DATE STRING ! 9410: EJC ! 9411: * ! 9412: * DEFINE ! 9413: * ! 9414: S$DFN ENT ENTRY POINT ! 9415: MOV (XS)+,XR LOAD SECOND ARGUMENT ! 9416: ZER DEFLB ZERO LABEL POINTER IN CASE NULL ! 9417: BEQ XR,=NULLS,SDF01 JUMP IF NULL SECOND ARGUMENT ! 9418: JSR GTNVR ELSE FIND VRBLK FOR LABEL ! 9419: PPM SDF13 JUMP IF NOT A VARIABLE NAME ! 9420: MOV XR,DEFLB ELSE SET SPECIFIED ENTRY ! 9421: * ! 9422: * SCAN FUNCTION NAME ! 9423: * ! 9424: SDF01 JSR XSCNI PREPARE TO SCAN FIRST ARGUMENT ! 9425: ERR 093,DEFINE FIRST ARGUMENT IS NOT STRING ! 9426: ERR 094,DEFINE FIRST ARGUMENT IS NULL ! 9427: MOV =CH$PP,WC DELIMITER ONE = LEFT PAREN ! 9428: MOV WC,XL DELIMITER TWO = LEFT PAREN ! 9429: JSR XSCAN SCAN OUT FUNCTION NAME ! 9430: BNZ WA,SDF02 JUMP IF LEFT PAREN FOUND ! 9431: ERB 095,DEFINE FIRST ARGUMENT IS MISSING A LEFT PAREN ! 9432: * ! 9433: * HERE AFTER SCANNING OUT FUNCTION NAME ! 9434: * ! 9435: SDF02 JSR GTNVR GET VARIABLE NAME ! 9436: ERR 096,DEFINE FIRST ARGUMENT HAS NULL FUNCTION NAME ! 9437: MOV XR,DEFVR SAVE VRBLK POINTER FOR FUNCTION NAM ! 9438: ZER WB ZERO COUNT OF ARGUMENTS ! 9439: MOV XS,DEFXS SAVE INITIAL STACK POINTER ! 9440: BNZ DEFLB,SDF03 JUMP IF SECOND ARGUMENT GIVEN ! 9441: MOV XR,DEFLB ELSE DEFAULT IS FUNCTION NAME ! 9442: * ! 9443: * LOOP TO SCAN ARGUMENT NAMES AND STACK VRBLK POINTERS ! 9444: * ! 9445: SDF03 MOV =CH$RP,WC DELIMITER ONE = RIGHT PAREN ! 9446: MOV =CH$CM,XL DELIMITER TWO = COMMA ! 9447: JSR XSCAN SCAN OUT NEXT ARGUMENT NAME ! 9448: BZE WA,SDF14 FAIL IF RUNOUT ! 9449: JSR GTNVR GET VRBLK POINTER ! 9450: PPM SDF04 IGNORE NULL NAME ! 9451: MOV XR,-(XS) STACK ARGUMENT VRBLK POINTER ! 9452: ICV WB INCREMENT COUNTER ! 9453: BEQ WA,=NUM02,SDF03 LOOP BACK IF STOPPED BY A COMMA ! 9454: BRN SDF05 JUMP FOR RIGHT PAREN ! 9455: EJC ! 9456: * ! 9457: * DEFINE (CONTINUED) ! 9458: * ! 9459: * NULL ARG FOUND. CONTINUE IF STOPPED BY COMMA ! 9460: * ! 9461: SDF04 BEQ WA,=NUM02,SDF03 LOOP IF COMMA ! 9462: * ! 9463: * HERE AFTER SCANNING OUT FUNCTION ARGUMENT NAMES ! 9464: * ! 9465: SDF05 MOV WB,DEFNA SAVE NUMBER OF ARGUMENTS ! 9466: ZER WB ZERO COUNT OF LOCALS ! 9467: * ! 9468: * LOOP TO SCAN LOCAL NAMES AND STACK VRBLK POINTERS ! 9469: * ! 9470: SDF06 MOV =CH$CM,WC SET DELIMITER ONE = COMMA ! 9471: MOV WC,XL SET DELIMITER TWO = COMMA ! 9472: JSR XSCAN SCAN OUT NEXT LOCAL NAME ! 9473: BNZ WA,SDF07 SKIP IF COMMA FOUND ! 9474: BNZ XSCNB,SDF14 FAIL IF BAD BLANK, OK IF LAST LOC ! 9475: * ! 9476: * HERE AFTER SCANNING OUT A LOCAL NAME ! 9477: * ! 9478: SDF07 JSR GTNVR GET VRBLK POINTER ! 9479: PPM SDF08 IGNORE NULL NAME ! 9480: ICV WB IF OK, INCREMENT COUNT ! 9481: MOV XR,-(XS) STACK VRBLK POINTER ! 9482: BNZ WA,SDF06 LOOP BACK IF STOPPED BY A COMMA ! 9483: BRN SDF09 JUMP FOR END OF STRING ! 9484: * ! 9485: * NULL LOCAL ! 9486: * ! 9487: SDF08 BNZ WA,SDF06 LOOP IF COMMA AFTER NULL LOCAL ! 9488: EJC ! 9489: * ! 9490: * DEFINE (CONTINUED) ! 9491: * ! 9492: * HERE AFTER SCANNING LOCALS, BUILD PFBLK ! 9493: * ! 9494: SDF09 MOV WB,WA COPY COUNT OF LOCALS ! 9495: ADD DEFNA,WA ADD NUMBER OF ARGUMENTS ! 9496: MOV WA,WC SET SUM ARGS+LOCALS AS LOOP COUNT ! 9497: ADD =PFSI$,WA ADD SPACE FOR STANDARD FIELDS ! 9498: WTB WA CONVERT LENGTH TO BAUS ! 9499: JSR ALLOC ALLOCATE SPACE FOR PFBLK ! 9500: MOV XR,XL SAVE POINTER TO PFBLK ! 9501: MOV =B$PFC,(XR)+ STORE FIRST WORD ! 9502: MOV DEFNA,(XR)+ STORE NUMBER OF ARGUMENTS ! 9503: MOV WA,(XR)+ STORE LENGTH (PFLEN) ! 9504: MOV DEFVR,(XR)+ STORE VRBLK PTR FOR FUNCTION NAME ! 9505: MOV WB,(XR)+ STORE NUMBER OF LOCALS ! 9506: ZER (XR)+ DEAL WITH LABEL LATER ! 9507: ZER (XR)+ ZERO PFCTR ! 9508: ZER (XR)+ ZERO PFRTR ! 9509: BZE WC,SDF11 SKIP IF NO ARGS OR LOCALS ! 9510: MOV XL,WA KEEP PFBLK POINTER ! 9511: MOV DEFXS,XT POINT BEFORE ARGUMENTS ! 9512: LCT WC,WC GET COUNT OF ARGS+LOCALS FOR LOOP ! 9513: * ! 9514: * LOOP TO MOVE LOCALS AND ARGS TO PFBLK ! 9515: * ! 9516: SDF10 MOV -(XT),(XR)+ STORE ONE ENTRY AND BUMP POINTERS ! 9517: BCT WC,SDF10 LOOP TILL ALL STORED ! 9518: MOV WA,XL RECOVER PFBLK POINTER ! 9519: EJC ! 9520: * ! 9521: * DEFINE (CONTINUED) ! 9522: * ! 9523: * NOW DEAL WITH LABEL ! 9524: * ! 9525: SDF11 MOV DEFXS,XS POP STACK ! 9526: MOV DEFLB,XR POINT TO VRBLK FOR LABEL ! 9527: MOV VRLBL(XR),XR LOAD LABEL POINTER ! 9528: BNE (XR),=B$TRT,SDF12 SKIP IF NOT TRAPPED ! 9529: MOV TRLBL(XR),XR ELSE POINT TO REAL LABEL ! 9530: * ! 9531: * HERE AFTER LOCATING REAL LABEL POINTER ! 9532: * ! 9533: SDF12 BEQ XR,=STNDL,SDF13 JUMP IF LABEL IS NOT DEFINED ! 9534: MOV XR,PFCOD(XL) ELSE STORE LABEL POINTER ! 9535: MOV DEFVR,XR POINT BACK TO VRBLK FOR FUNCTION ! 9536: JSR DFFNC DEFINE FUNCTION ! 9537: BRN EXNUL AND EXIT RETURNING NULL ! 9538: * ! 9539: * HERE FOR ERRONEOUS LABEL ! 9540: * ! 9541: SDF13 ERB 097,DEFINE FUNCTION ENTRY POINT IS NOT DEFINED LABEL ! 9542: * ! 9543: * ERRONEOUS ARG OR LOCAL ! 9544: * ! 9545: SDF14 ERB 098,BAD BLANK OR MISSING RIGHT PAREN IN DEFINE ARG ! 9546: EJC ! 9547: * ! 9548: * DETACH ! 9549: * ! 9550: S$DET ENT ENTRY POINT ! 9551: MOV (XS)+,XR LOAD ARGUMENT ! 9552: JSR GTVAR LOCATE VARIABLE ! 9553: ERR 099,DETACH ARGUMENT IS NOT APPROPRIATE NAME ! 9554: MOV WA,-(XS) KEEP OFFSET ! 9555: ZER SDETF CLEAR FAIL FLAG ! 9556: MOV =TRTIN,WB TRACE TYPE ! 9557: ZER XR REMOVE TRBLK ! 9558: JSR TRCHN REMOVE ANY INPUT ASSOCIATION ! 9559: PPM SDET1 SKIP IF NO INPUT TRBLK ! 9560: MNZ SDETF NOTE TRBLK REMOVED ! 9561: * ! 9562: * REPEAT FOR OUTPUT TRBLK ! 9563: * ! 9564: SDET1 MOV (XS)+,WA RECOVER OFFSET ! 9565: MOV =TRTOU,WB TRTYP ! 9566: JSR TRCHN REMOVE ANY OUTPUT ASSOCIATION ! 9567: PPM SDET2 SKIP IF NO TRBLK ! 9568: BRN EXNUL SUCCEED ! 9569: * ! 9570: * CHECK AT LEAST ONE TRBLK REMOVED ! 9571: * ! 9572: SDET2 BNZ SDETF,EXNUL SUCCEED IF SO ! 9573: BRN EXFAL ELSE FAIL ! 9574: EJC ! 9575: * ! 9576: * DIFFER ! 9577: * ! 9578: S$DIF ENT ENTRY POINT ! 9579: MOV (XS)+,XR LOAD SECOND ARGUMENT ! 9580: MOV (XS)+,XL LOAD FIRST ARGUMENT ! 9581: JSR IDENT CALL IDENT COMPARISON ROUTINE ! 9582: PPM EXFAL FAIL IF IDENT ! 9583: BRN EXNUL RETURN NULL IF DIFFER ! 9584: EJC ! 9585: * ! 9586: * DUMP ! 9587: * ! 9588: S$DMP ENT ENTRY POINT ! 9589: JSR GTSMI LOAD DUMP ARG AS SMALL INTEGER ! 9590: ERR 100,DUMP ARGUMENT IS NOT INTEGER ! 9591: ERR 101,DUMP ARGUMENT IS NEGATIVE OR TOO LARGE ! 9592: JSR DUMPR ELSE CALL DUMP ROUTINE ! 9593: BRN EXNUL AND RETURN NULL AS RESULT ! 9594: EJC ! 9595: * ! 9596: * DUPL ! 9597: * ! 9598: S$DUP ENT ENTRY POINT ! 9599: JSR GTSMI GET SECOND ARGUMENT AS SMALL INTEGE ! 9600: ERR 102,DUPL SECOND ARGUMENT IS NOT INTEGER ! 9601: PPM SDUP7 JUMP IF NEGATIVE OT TOO BIG ! 9602: MOV XR,WB SAVE DUPLICATION FACTOR ! 9603: JSR GTSTG GET FIRST ARG AS STRING ! 9604: PPM SDUP4 JUMP IF NOT A STRING ! 9605: * ! 9606: * HERE FOR CASE OF DUPLICATION OF A STRING ! 9607: * ! 9608: MTI WA ACQUIRE LENGTH AS INTEGER ! 9609: STI DUPSI SAVE FOR THE MOMENT ! 9610: MTI WB GET DUPLICATION FACTOR AS INTEGER ! 9611: MLI DUPSI FORM PRODUCT ! 9612: IOV SDUP3 JUMP IF OVERFLOW ! 9613: IEQ EXNUL RETURN NULL IF RESULT LENGTH = 0 ! 9614: MFI WA,SDUP3 GET AS ADDR INTEGER, CHECK OVFLO ! 9615: * ! 9616: * MERGE HERE WITH RESULT LENGTH IN WA ! 9617: * ! 9618: SDUP1 MOV XR,XL SAVE STRING POINTER ! 9619: JSR ALOCS ALLOCATE SPACE FOR STRING ! 9620: MOV XR,-(XS) SAVE AS RESULT POINTER ! 9621: MOV XL,WC SAVE POINTER TO ARGUMENT STRING ! 9622: PSC XR PREPARE TO STORE CHARS OF RESULT ! 9623: LCT WB,WB SET COUNTER TO CONTROL LOOP ! 9624: * ! 9625: * LOOP THROUGH DUPLICATIONS ! 9626: * ! 9627: SDUP2 MOV WC,XL POINT BACK TO ARGUMENT STRING ! 9628: MOV SCLEN(XL),WA GET NUMBER OF CHARACTERS ! 9629: PLC XL POINT TO CHARS IN ARGUMENT STRING ! 9630: MVC MOVE CHARACTERS TO RESULT STRING ! 9631: BCT WB,SDUP2 LOOP TILL ALL DUPLICATIONS DONE ! 9632: BRN EXITS THEN EXIT FOR NEXT CODE WORD ! 9633: EJC ! 9634: * ! 9635: * DUPL (CONTINUED) ! 9636: * ! 9637: * HERE IF TOO LARGE, SET MAX LENGTH AND LET ALOCS CATCH IT ! 9638: * ! 9639: SDUP3 MOV DNAME,WA SET IMPOSSIBLE LENGTH FOR ALOCS ! 9640: BRN SDUP1 MERGE BACK ! 9641: * ! 9642: * HERE IF NOT A STRING ! 9643: * ! 9644: SDUP4 JSR GTPAT CONVERT ARGUMENT TO PATTERN ! 9645: ERR 103,DUPL FIRST ARGUMENT IS NOT STRING OR PATTERN ! 9646: * ! 9647: * HERE TO DUPLICATE A PATTERN ARGUMENT ! 9648: * ! 9649: MOV XR,-(XS) STORE PATTERN ON STACK ! 9650: MOV =NDNTH,XR START OFF WITH NULL PATTERN ! 9651: BZE WB,SDUP6 NULL PATTERN IS RESULT IF DUPFAC=0 ! 9652: MOV WB,-(XS) PRESERVE LOOP COUNT ! 9653: * ! 9654: * LOOP TO DUPLICATE BY SUCCESSIVE CONCATENATION ! 9655: * ! 9656: SDUP5 MOV XR,XL COPY CURRENT VALUE AS RIGHT ARGUMNT ! 9657: MOV 1(XS),XR GET A NEW COPY OF LEFT ! 9658: JSR PCONC CONCATENATE ! 9659: DCV (XS) COUNT DOWN ! 9660: BNZ (XS),SDUP5 LOOP ! 9661: ICA XS POP LOOP COUNT ! 9662: * ! 9663: * HERE TO EXIT AFTER CONSTRUCTING PATTERN ! 9664: * ! 9665: SDUP6 MOV XR,(XS) STORE RESULT ON STACK ! 9666: BRN EXITS EXIT WITH RESULT ON STACK ! 9667: * ! 9668: * FAIL IF SECOND ARG IS OUT OF RANGE ! 9669: * ! 9670: SDUP7 ICA XS POP FIRST ARGUMENT ! 9671: BRN EXFAL FAIL ! 9672: EJC ! 9673: * ! 9674: * EJECT ! 9675: * ! 9676: S$EJC ENT ENTRY POINT ! 9677: MOV (XS)+,WB GET ARGUMENT ! 9678: MOV WB,-(XS) RESTACK IT ! 9679: JSR GTSTG CONVERT TO STRING ! 9680: PPM SEJC2 FAIL IF CANT ! 9681: BZE WA,SEJC1 SKIP IF NULL STRING ! 9682: MOV WB,-(XS) RESTACK ORIGINAL ARG ! 9683: JSR IOFTG CALL FILETAG ROUTINE ! 9684: PPM SEJC2 FAIL ! 9685: BZE WA,EXFAL FAIL IF NOT ASSOCIATED ! 9686: JSR SYSEF CALL EJECT FILE FUNCTION ! 9687: PPM EXFAL FAIL RETURN ! 9688: PPM EROSI ERROR RETURN ! 9689: BRN EXNUL RETURN NULL AS RESULT ! 9690: * ! 9691: * HERE TO EJECT STANDARD OUTPUT FILE ! 9692: * ! 9693: SEJC1 JSR SYSEP CALL ROUTINE TO EJECT PRINTER ! 9694: PPM EXFAL FAIL RETURN ! 9695: PPM EROSI ERROR RETURN ! 9696: BRN EXNUL EXIT WITH NULL RESULT ! 9697: * ! 9698: * ERROR POINT ! 9699: * ! 9700: SEJC2 ERB 104,EJECT ARGUMENT IS NOT A SUITABLE FILETAG ! 9701: EJC ! 9702: * ! 9703: * ENDFILE ! 9704: * ! 9705: S$ENF ENT ENTRY POINT ! 9706: JSR GTSTG CONVERT SECOND ARG TO STRING ! 9707: ERR 105,ENDFILE SECOND ARGUMENT IS NOT A STRING ! 9708: BNZ WA,SENF1 SKIP IF NON NULL SECOND ARG ! 9709: ZER XR 0 IF NULL ! 9710: * ! 9711: * NOW PROCESS FILETAG ! 9712: * ! 9713: SENF1 MOV XR,SENFR KEEP SECOND ARG ! 9714: JSR IOFTG CALL FILETAG PROC (WB = VRBLK PTR) ! 9715: ERR 106,ENDFILE FIRST ARGUMENT IS NOT A SUITABLE FILETAG ! 9716: BZE WA,EXFAL FAIL IF NO IOTAG ! 9717: MOV SENFR,XR RECOVER SECOND ARG ! 9718: JSR SYSEN CALL ENDFILE ROUTINE ! 9719: PPM EXFAL FAIL RETURN ! 9720: PPM EROSI ERROR RETURN ! 9721: BNZ WA,EXNUL RETURN NULL IF NO FILE CLOSURE ! 9722: MOV WB,XL POINT TO FILETAG VRBLK ! 9723: MOV *VRVAL,WA OFFSET TO VALUE FIELD ! 9724: ZER XR FOR TRBLK REMOVAL ! 9725: MOV =TRTIO,WB TRTYP ! 9726: JSR TRCHN REMOVE TRBLK ! 9727: PPM EXFAL (CANT FAIL HERE) ! 9728: BRN EXNUL RETURN NULL ! 9729: EJC ! 9730: * ! 9731: * EQ ! 9732: * ! 9733: S$EQF ENT ENTRY POINT ! 9734: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE ! 9735: ERR 107,EQ FIRST ARGUMENT IS NOT NUMERIC ! 9736: ERR 108,EQ SECOND ARGUMENT IS NOT NUMERIC ! 9737: PPM EXFAL FAIL IF LT ! 9738: PPM EXNUL RETURN NULL IF EQ ! 9739: PPM EXFAL FAIL IF GT ! 9740: EJC ! 9741: * ! 9742: * EVAL ! 9743: * ! 9744: S$EVL ENT ENTRY POINT ! 9745: MOV (XS)+,XR LOAD ARGUMENT ! 9746: JSR GTEXP CONVERT TO EXPRESSION ! 9747: ERR 109,EVAL ARGUMENT IS NOT EXPRESSION ! 9748: LCW WC LOAD NEXT CODE WORD ! 9749: BNE WC,=OFNE$,SEVL1 JUMP IF CALLED BY VALUE ! 9750: SCP XL COPY CODE POINTER ! 9751: MOV (XL),WA GET NEXT CODE WORD ! 9752: BNE WA,=ORNM$,SEVL2 BY NAME UNLESS EXPRESSION ! 9753: BNZ 1(XS),SEVL2 JUMP IF BY NAME ! 9754: * ! 9755: * HERE IF CALLED BY VALUE ! 9756: * ! 9757: SEVL1 ZER WB SET FLAG FOR BY VALUE ! 9758: MOV WC,-(XS) SAVE CODE WORD ! 9759: JSR EVALX EVALUATE EXPRESSION BY VALUE ! 9760: PPM EXFAL FAIL IF EVALUATION FAILS ! 9761: MOV XR,XL COPY RESULT ! 9762: MOV (XS),XR RELOAD NEXT CODE WORD ! 9763: MOV XL,(XS) STACK RESULT ! 9764: BRI (XR) JUMP TO EXECUTE NEXT CODE WORD ! 9765: * ! 9766: * HERE IF CALLED BY NAME ! 9767: * ! 9768: SEVL2 MOV =NUM01,WB SET FLAG FOR BY NAME ! 9769: JSR EVALX EVALUATE EXPRESSION BY NAME ! 9770: PPM EXFAL FAIL IF EVALUATION FAILS ! 9771: BRN EXNAM EXIT WITH NAME ! 9772: .IF .CNEX ! 9773: .ELSE ! 9774: EJC ! 9775: * ! 9776: * EXIT ! 9777: * ! 9778: S$EXT ENT ENTRY POINT ! 9779: ZER WB CLEAR AMOUNT OF STATIC SHIFT ! 9780: JSR GBCOL COMPACT MEMORY BY COLLECTING ! 9781: JSR GTSTG CONVERT ARG TO STRING ! 9782: ERR 110,EXIT ARGUMENT IS NOT SUITABLE INTEGER OR STRING ! 9783: MOV XR,XL COPY STRING PTR ! 9784: JSR GTINT CHECK IT IS INTEGER ! 9785: PPM SEXT1 SKIP IF UNCONVERTIBLE ! 9786: ZER XL NOTE IT IS INTEGER ! 9787: LDI ICVAL(XR) GET INTEGER ARG ! 9788: * ! 9789: * MERGE TO CALL OSINT EXIT ROUTINE ! 9790: * ! 9791: SEXT1 MOV =HEADV,XR POINT TO V.V STRING ! 9792: MOV =KVCOD,WA VALUE OF CODE KEYWORD ! 9793: JSR SYSXI CALL EXTERNAL ROUTINE ! 9794: PPM EXFAL FAIL RETURN ! 9795: PPM EROSI ERROR RETURN ! 9796: IEQ EXNUL RETURN IF ARGUMENT 0 ! 9797: ZER GBCNT RESUMING EXECUTION SO. ! 9798: IGT SEXT2 SKIP IF POSITIVE ! 9799: NGI MAKE POSITIVE ! 9800: * ! 9801: * CHECK FOR OPTION RESPECIFICATION ! 9802: * ! 9803: SEXT2 MFI WC GET VALUE IN WORK REGISTER ! 9804: BEQ WC,=NUM03,SEXT3 SKIP IF WAS 3 ! 9805: MOV WC,-(XS) SAVE VALUE ! 9806: ZER WC SET TO READ OPTIONS ! 9807: JSR PRPAR READ SYSPP OPTIONS ! 9808: MOV (XS)+,WA RESTORE VALUE ! 9809: * ! 9810: * DEAL WITH HEADER OPTIONS (FIDDLED BY PRPAR) ! 9811: * ! 9812: SEXT3 MNZ HEADP ASSUME NO HEADERS ! 9813: BNE WC,=NUM01,SEXT4 SKIP IF NOT 1 ! 9814: ZER HEADP REQUEST HEADER PRINTING ! 9815: * ! 9816: * ALMOST READY TO RESUME RUNNING ! 9817: * ! 9818: SEXT4 JSR SYSTM GET RECOMMENCEMENT TIME ! 9819: STI TIMSX SAVE AS INITIAL TIME ! 9820: LDI KVSTC RESET TO ENSURE ... ! 9821: STI KVSTL ... CORRECT EXECUTION STATS ! 9822: BRN EXNUL RESUME EXECUTION ! 9823: .FI ! 9824: .IF .CNFN ! 9825: .ELSE ! 9826: EJC ! 9827: * ! 9828: * FENCE ! 9829: * ! 9830: S$FNC ENT ENTRY POINT ! 9831: MOV =P$FNC,WB SET PCODE FOR P$FNC ! 9832: ZER XR P0BLK ! 9833: JSR PBILD BUILD P$FNC NODE ! 9834: MOV XR,XL SAVE POINTER TO IT ! 9835: MOV (XS)+,XR GET ARGUMENT ! 9836: JSR GTPAT CONVERT TO PATTERN ! 9837: ERR 180,FENCE ARGUMENT IS NOT PATTERN ! 9838: JSR PCONC CONCATENATE TO P$FNC NODE ! 9839: MOV XR,XL SAVE PTR TO CONCATENATED PATTERN ! 9840: MOV =P$FNA,WB SET FOR P$FNA PCODE ! 9841: ZER XR P0BLK ! 9842: JSR PBILD CONSTRUCT P$FNA NODE ! 9843: MOV XL,PTHEN(XR) SET PATTERN AS PTHEN ! 9844: MOV XR,-(XS) SET AS RESULT ! 9845: BRN EXITS DO NEXT CODE WORD ! 9846: EJC ! 9847: .FI ! 9848: * ! 9849: * FIELD ! 9850: * ! 9851: S$FLD ENT ENTRY POINT ! 9852: JSR GTSMI GET SECOND ARGUMENT (FIELD NUMBER) ! 9853: ERR 255,FIELD SECOND ARGUMENT IS NOT INTEGER ! 9854: PPM EXFAL FAIL IF OUT OF RANGE ! 9855: MOV XR,WB ELSE SAVE INTEGER VALUE ! 9856: MOV (XS)+,XR LOAD FIRST ARGUMENT ! 9857: JSR GTNVR POINT TO VRBLK ! 9858: PPM SFLD1 JUMP (ERROR) IF NOT VARIABLE NAME ! 9859: MOV VRFNC(XR),XR ELSE POINT TO FUNCTION BLOCK ! 9860: BNE (XR),=B$DFC,SFLD1 ERROR IF NOT DATATYPE FUNCTION ! 9861: * ! 9862: * HERE IF FIRST ARGUMENT IS A DATATYPE FUNCTION NAME ! 9863: * ! 9864: BZE WB,EXFAL FAIL IF ARGUMENT NUMBER IS ZERO ! 9865: BGT WB,FARGS(XR),EXFAL FAIL IF TOO LARGE ! 9866: WTB WB ELSE CONVERT TO BYTE OFFSET ! 9867: ADD WB,XR POINT TO FIELD NAME ! 9868: MOV DFFLB(XR),XR LOAD VRBLK POINTER ! 9869: BRN EXVNM EXIT TO BUILD NMBLK ! 9870: * ! 9871: * HERE FOR BAD FIRST ARGUMENT ! 9872: * ! 9873: SFLD1 ERB 254,FIELD FIRST ARGUMENT IS NOT DATATYPE NAME ! 9874: EJC ! 9875: * ! 9876: * GE ! 9877: * ! 9878: S$GEF ENT ENTRY POINT ! 9879: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE ! 9880: ERR 111,GE FIRST ARGUMENT IS NOT NUMERIC ! 9881: ERR 112,GE SECOND ARGUMENT IS NOT NUMERIC ! 9882: PPM EXFAL FAIL IF LT ! 9883: PPM EXNUL RETURN NULL IF EQ ! 9884: PPM EXNUL RETURN NULL IF GT ! 9885: * ! 9886: * GT ! 9887: * ! 9888: S$GTF ENT ENTRY POINT ! 9889: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE ! 9890: ERR 113,GT FIRST ARGUMENT IS NOT NUMERIC ! 9891: ERR 114,GT SECOND ARGUMENT IS NOT NUMERIC ! 9892: PPM EXFAL FAIL IF LT ! 9893: PPM EXFAL FAIL IF EQ ! 9894: PPM EXNUL RETURN NULL IF GT ! 9895: EJC ! 9896: * ! 9897: * HOST ! 9898: * ! 9899: S$HST ENT ENTRY POINT ! 9900: JSR GTSTG CONVERT ARG TO STRING ! 9901: ERR 115,ERRONEOUS THIRD ARGUMENT FOR HOST ! 9902: MOV WA,WB KEEP LENGTH ! 9903: MOV XR,WC KEEP THIRD ARG ! 9904: JSR GTSTG CONVERT ARG TO STRING ! 9905: ERR 116,ERRONEOUS SECOND ARGUMENT FOR HOST ! 9906: ORB WA,WB NON ZERO UNLESS TWO ARGS NULL ! 9907: MOV XR,XL KEEP SECOND ARG ! 9908: JSR GTSTG CONVERT ARG TO STRING ! 9909: ERR 117,ERRONEOUS FIRST ARGUMENT FOR HOST ! 9910: ORB WA,WB NON ZERO UNLESS ALL ARGS NULL ! 9911: MOV XR,WA KEEP FIRST ARG ! 9912: MOV WC,XR GET THIRD ARG ! 9913: JSR SYSHS CALL SYSHS ROUTINE ! 9914: PPM EXFAL FAIL RETURN ! 9915: PPM EROSI ERROR RETURN ! 9916: MOV SCLEN(XL),WA LENGTH OF RETURNED STRING ! 9917: ZER WB ZERO OFFSET ! 9918: JSR SBSTR BUILD COPY OF STRING ! 9919: MOV XR,-(XS) STACK THE RESULT ! 9920: BRN EXITS RETURN RESULT ON STACK ! 9921: EJC ! 9922: * ! 9923: * IDENT ! 9924: * ! 9925: S$IDN ENT ENTRY POINT ! 9926: MOV (XS)+,XR LOAD SECOND ARGUMENT ! 9927: MOV (XS)+,XL LOAD FIRST ARGUMENT ! 9928: JSR IDENT CALL IDENT COMPARISON ROUTINE ! 9929: PPM EXNUL RETURN NULL IF IDENT ! 9930: BRN EXFAL FAIL IF DIFFER ! 9931: EJC ! 9932: * ! 9933: * INPUT ! 9934: * ! 9935: S$INP ENT ENTRY POINT ! 9936: ZER WB INPUT FLAG ! 9937: JSR IOPUT CALL INPUT/OUTPUT ASSOC. ROUTINE ! 9938: ERR 118,INPUT THIRD ARGUMENT (FILEPROPS) IS NOT A STRING ! 9939: ERR 119,INAPPROPRIATE SECOND ARGUMENT (FILETAG) FOR INPUT ! 9940: ERR 120,INAPPROPRIATE FIRST ARGUMENT FOR INPUT ! 9941: PPM EXFAL FAIL RETURN ! 9942: BRN EXNUL RETURN NULL STRING ! 9943: .IF .CNBF ! 9944: .ELSE ! 9945: EJC ! 9946: * ! 9947: * INSERT ! 9948: * ! 9949: S$INS ENT ENTRY POINT ! 9950: MOV (XS)+,XL GET STRING ARG ! 9951: JSR GTSMI GET REPLACE LENGTH ! 9952: ERR 121,INSERT THIRD ARGUMENT NOT INTEGER ! 9953: PPM EXFAL FAIL IF OUT OF RANGE ! 9954: MOV WC,WB COPY TO PROPER REG ! 9955: JSR GTSMI GET REPLACE POSITION ! 9956: ERR 122,INSERT SECOND ARGUMENT NOT INTEGER ! 9957: PPM EXFAL FAIL IF OUT OF RANGE ! 9958: BZE WC,EXFAL FAIL IF ZERO ! 9959: DCV WC DECREMENT TO GET OFFSET ! 9960: MOV WC,WA PUT IN PROPER REGISTER ! 9961: MOV (XS)+,XR GET BUFFER ! 9962: BEQ (XR),=B$BCT,SINS1 PRESS ON IF TYPE OK ! 9963: ERB 123,INSERT FIRST ARGUMENT NOT BUFFER ! 9964: * ! 9965: * HERE WHEN EVERYTHING LOADED UP ! 9966: * ! 9967: SINS1 JSR INSBF CALL TO INSERT ! 9968: ERR 124,INSERT FOURTH ARGUMENT NOT A STRING ! 9969: PPM EXFAL FAIL IF OUT OF RANGE ! 9970: BRN EXNUL ELSE OK - EXIT WITH NULL ! 9971: .FI ! 9972: EJC ! 9973: * ! 9974: * INTEGER ! 9975: * ! 9976: S$INT ENT ENTRY POINT ! 9977: MOV (XS)+,XR LOAD ARGUMENT ! 9978: JSR GTNUM CONVERT TO NUMERIC ! 9979: PPM EXFAL FAIL IF NON-NUMERIC ! 9980: BEQ WA,=B$ICL,EXNUL RETURN NULL IF INTEGER ! 9981: BRN EXFAL FAIL IF REAL ! 9982: EJC ! 9983: * ! 9984: * ITC ! 9985: * ! 9986: S$ITC ENT ! 9987: JSR GTSMI OBTAIN ARG AS AN INTEGER ! 9988: ERR 125,ITC ARGUMENT IS NOT A SMALL INTEGER ! 9989: PPM EXFAL FAIL IF OUT OF RANGE ! 9990: BGE WC,=CFP$A,EXFAL FURTHER RANGE CHECK ! 9991: MOV WC,WB PRESERVE WC ! 9992: MOV =NUM01,WA FOR SCBLK REQUEST ! 9993: JSR ALOCS BUILD STRING BLOCK ! 9994: MOV XR,XL COPY STRING PTR ! 9995: PSC XL READY TO STORE CHAR ! 9996: SCH WB,(XL) STORE IT ! 9997: ZER XL CLEAR GARBAGE ! 9998: BRN EXIXR RETURN STRING RESULT ! 9999: EJC ! 10000: * ! 10001: * ITEM ! 10002: * ! 10003: * ITEM DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT ! 10004: * WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED. ! 10005: * ! 10006: S$ITM ENT ENTRY POINT ! 10007: * ! 10008: * DEAL WITH CASE OF NO ARGS ! 10009: * ! 10010: BNZ WA,SITM1 JUMP IF AT LEAST ONE ARG ! 10011: MOV =NULLS,-(XS) ELSE SUPPLY GARBAGE NULL ARG ! 10012: MOV =NUM01,WA AND FIX ARGUMENT COUNT ! 10013: * ! 10014: * CHECK FOR NAME/VALUE CASES ! 10015: * ! 10016: SITM1 SCP XR GET CURRENT CODE POINTER ! 10017: MOV (XR),XL LOAD NEXT CODE WORD ! 10018: DCV WA GET NUMBER OF SUBSCRIPTS ! 10019: MOV WA,XR COPY FOR ARREF ! 10020: BEQ XL,=OFNE$,SITM2 JUMP IF CALLED BY NAME ! 10021: * ! 10022: * HERE IF CALLED BY VALUE ! 10023: * ! 10024: ZER WB SET CODE FOR CALL BY VALUE ! 10025: BRN ARREF OFF TO ARRAY REFERENCE ROUTINE ! 10026: * ! 10027: * HERE FOR CALL BY NAME ! 10028: * ! 10029: SITM2 MNZ WB SET CODE FOR CALL BY NAME ! 10030: LCW WA LOAD AND IGNORE OFNE$ CALL ! 10031: BRN ARREF OFF TO ARRAY REFERENCE ROUTINE ! 10032: EJC ! 10033: * ! 10034: * LE ! 10035: * ! 10036: S$LEF ENT ENTRY POINT ! 10037: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE ! 10038: ERR 126,LE FIRST ARGUMENT IS NOT NUMERIC ! 10039: ERR 127,LE SECOND ARGUMENT IS NOT NUMERIC ! 10040: PPM EXNUL RETURN NULL IF LT ! 10041: PPM EXNUL RETURN NULL IF EQ ! 10042: PPM EXFAL FAIL IF GT ! 10043: EJC ! 10044: * ! 10045: * LEN ! 10046: * ! 10047: S$LEN ENT ENTRY POINT ! 10048: MOV =P$LEN,WB SET PCODE FOR INTEGER ARG CASE ! 10049: MOV =P$LND,WA SET PCODE FOR EXPR ARG CASE ! 10050: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE ! 10051: ERR 128,LEN ARGUMENT IS NOT INTEGER OR EXPRESSION ! 10052: ERR 129,LEN ARGUMENT IS NEGATIVE OR TOO LARGE ! 10053: BRN EXIXR RETURN PATTERN NODE ! 10054: EJC ! 10055: * ! 10056: * LEQ ! 10057: * ! 10058: S$LEQ ENT ENTRY POINT ! 10059: JSR LCOMP CALL STRING COMPARISON ROUTINE ! 10060: ERR 130,LEQ FIRST ARGUMENT IS NOT STRING ! 10061: ERR 131,LEQ SECOND ARGUMENT IS NOT STRING ! 10062: PPM EXFAL FAIL IF LLT ! 10063: PPM EXNUL RETURN NULL IF LEQ ! 10064: PPM EXFAL FAIL IF LGT ! 10065: EJC ! 10066: * ! 10067: * LGE ! 10068: * ! 10069: S$LGE ENT ENTRY POINT ! 10070: JSR LCOMP CALL STRING COMPARISON ROUTINE ! 10071: ERR 132,LGE FIRST ARGUMENT IS NOT STRING ! 10072: ERR 133,LGE SECOND ARGUMENT IS NOT STRING ! 10073: PPM EXFAL FAIL IF LLT ! 10074: PPM EXNUL RETURN NULL IF LEQ ! 10075: PPM EXNUL RETURN NULL IF LGT ! 10076: EJC ! 10077: * ! 10078: * LGT ! 10079: * ! 10080: S$LGT ENT ENTRY POINT ! 10081: JSR LCOMP CALL STRING COMPARISON ROUTINE ! 10082: ERR 134,LGT FIRST ARGUMENT IS NOT STRING ! 10083: ERR 135,LGT SECOND ARGUMENT IS NOT STRING ! 10084: PPM EXFAL FAIL IF LLT ! 10085: PPM EXFAL FAIL IF LEQ ! 10086: PPM EXNUL RETURN NULL IF LGT ! 10087: EJC ! 10088: * ! 10089: * LLE ! 10090: * ! 10091: S$LLE ENT ENTRY POINT ! 10092: JSR LCOMP CALL STRING COMPARISON ROUTINE ! 10093: ERR 136,LLE FIRST ARGUMENT IS NOT STRING ! 10094: ERR 137,LLE SECOND ARGUMENT IS NOT STRING ! 10095: PPM EXNUL RETURN NULL IF LLT ! 10096: PPM EXNUL RETURN NULL IF LEQ ! 10097: PPM EXFAL FAIL IF LGT ! 10098: EJC ! 10099: * ! 10100: * LLT ! 10101: * ! 10102: S$LLT ENT ENTRY POINT ! 10103: JSR LCOMP CALL STRING COMPARISON ROUTINE ! 10104: ERR 138,LLT FIRST ARGUMENT IS NOT STRING ! 10105: ERR 139,LLT SECOND ARGUMENT IS NOT STRING ! 10106: PPM EXNUL RETURN NULL IF LLT ! 10107: PPM EXFAL FAIL IF LEQ ! 10108: PPM EXFAL FAIL IF LGT ! 10109: EJC ! 10110: * ! 10111: * LNE ! 10112: * ! 10113: S$LNE ENT ENTRY POINT ! 10114: JSR LCOMP CALL STRING COMPARISON ROUTINE ! 10115: ERR 140,LNE FIRST ARGUMENT IS NOT STRING ! 10116: ERR 141,LNE SECOND ARGUMENT IS NOT STRING ! 10117: PPM EXNUL RETURN NULL IF LLT ! 10118: PPM EXFAL FAIL IF LEQ ! 10119: PPM EXNUL RETURN NULL IF LGT ! 10120: .IF .CNLD ! 10121: .ELSE ! 10122: EJC ! 10123: * ! 10124: * LOAD ! 10125: * ! 10126: S$LOD ENT ENTRY POINT ! 10127: JSR GTSTG LOAD LIBRARY NAME ! 10128: ERR 142,LOAD SECOND ARGUMENT IS NOT STRING ! 10129: MOV XR,XL SAVE LIBRARY NAME ! 10130: JSR XSCNI PREPARE TO SCAN FIRST ARGUMENT ! 10131: ERR 143,LOAD FIRST ARGUMENT IS NOT STRING ! 10132: ERR 144,LOAD FIRST ARGUMENT IS NULL ! 10133: MOV XL,-(XS) STACK LIBRARY NAME ! 10134: MOV =CH$PP,WC SET DELIMITER ONE = LEFT PAREN ! 10135: MOV WC,XL SET DELIMITER TWO = LEFT PAREN ! 10136: JSR XSCAN SCAN FUNCTION NAME ! 10137: MOV XR,-(XS) SAVE PTR TO FUNCTION NAME ! 10138: BNZ WA,SLOD1 JUMP IF LEFT PAREN FOUND ! 10139: ERB 145,LOAD FIRST ARGUMENT IS MISSING A LEFT PAREN ! 10140: * ! 10141: * HERE AFTER SUCCESSFULLY SCANNING FUNCTION NAME ! 10142: * ! 10143: SLOD1 JSR GTNVR LOCATE VRBLK ! 10144: ERR 146,LOAD FIRST ARGUMENT HAS NULL FUNCTION NAME ! 10145: MOV XR,LODFN SAVE VRBLK POINTER ! 10146: ZER LODNA ZERO COUNT OF ARGUMENTS ! 10147: * ! 10148: * LOOP TO SCAN ARGUMENT DATATYPE NAMES ! 10149: * ! 10150: SLOD2 MOV =CH$RP,WC DELIMITER ONE IS RIGHT PAREN ! 10151: MOV =CH$CM,XL DELIMITER TWO IS COMMA ! 10152: JSR XSCAN SCAN NEXT ARGUMENT NAME ! 10153: ICV LODNA BUMP ARGUMENT COUNT ! 10154: BNZ WA,SLOD3 JUMP IF OK DELIMITER WAS FOUND ! 10155: ERB 147,BAD BLANK OR MISSING RIGHT PAREN IN LOAD ARG ! 10156: EJC ! 10157: * ! 10158: * LOAD (CONTINUED) ! 10159: * ! 10160: * COME HERE TO ANALYZE THE DATATYPE POINTER IN (XR). THIS ! 10161: * CODE IS USED BOTH FOR ARGUMENTS (WA=1,2) AND FOR THE ! 10162: * RESULT DATATYPE (WITH WA SET TO ZERO). ! 10163: * ! 10164: SLOD3 MOV XR,-(XS) STACK DATATYPE NAME POINTER ! 10165: MOV =NUM01,WB SET STRING CODE IN CASE (1) ! 10166: MOV =SCSTR,XL POINT TO /STRING/ ! 10167: JSR IDENT CHECK FOR MATCH ! 10168: PPM SLOD4 JUMP IF MATCH ! 10169: MOV (XS),XR ELSE RELOAD NAME ! 10170: ADD WB,WB SET CODE FOR INTEGER (2) ! 10171: MOV =SCINT,XL POINT TO /INTEGER/ ! 10172: JSR IDENT CHECK FOR MATCH ! 10173: PPM SLOD4 JUMP IF MATCH ! 10174: ICV WB ELSE SET CODE FOR REAL (3) ! 10175: .IF .CNRA ! 10176: .ELSE ! 10177: MOV (XS),XR RELOAD STRING POINTER ! 10178: MOV =SCREA,XL POINT TO /REAL/ ! 10179: JSR IDENT CHECK FOR MATCH ! 10180: PPM SLOD4 JUMP IF MATCH ! 10181: .FI ! 10182: ICV WB SET CODE FOR BUFFER (4) ! 10183: .IF .CNBF ! 10184: .ELSE ! 10185: MOV (XS),XR RELOAD STRING POINTER ! 10186: MOV =SCBUF,XL POINT TO /BUFFER/ ! 10187: JSR IDENT CHECK FOR MATCH ! 10188: PPM SLOD4 JUMP IF MATCH ! 10189: .FI ! 10190: ZER WB ELSE GET CODE FOR NO CONVERT ! 10191: * ! 10192: * MERGE HERE WITH PROPER DATATYPE CODE IN WB ! 10193: * ! 10194: SLOD4 MOV WB,(XS) STORE CODE ON STACK ! 10195: BEQ WA,=NUM02,SLOD2 LOOP BACK IF ARG STOPPED BY COMMA ! 10196: BZE WA,SLOD5 JUMP IF THAT WAS THE RESULT TYPE ! 10197: * ! 10198: * HERE WE SCAN OUT THE RESULT TYPE (ARG STOPPED BY ) ) ! 10199: * ! 10200: MOV MXLEN,WC SET DUMMY (IMPOSSIBLE) DELIMITER 1 ! 10201: MOV WC,XL AND DELIMITER TWO ! 10202: JSR XSCAN SCAN RESULT NAME ! 10203: ZER WA SET CODE FOR PROCESSING RESULT ! 10204: BRN SLOD3 JUMP BACK TO PROCESS RESULT NAME ! 10205: EJC ! 10206: * ! 10207: * LOAD (CONTINUED) ! 10208: * ! 10209: * HERE AFTER PROCESSING ALL ARGS AND RESULT ! 10210: * ! 10211: SLOD5 MOV LODNA,WA GET NUMBER OF ARGUMENTS ! 10212: MOV WA,WC COPY FOR LATER ! 10213: WTB WA CONVERT LENGTH TO BAUS ! 10214: ADD *EFSI$,WA ADD SPACE FOR STANDARD FIELDS ! 10215: JSR ALLOC ALLOCATE EFBLK ! 10216: MOV =B$EFC,(XR) SET TYPE WORD ! 10217: MOV WC,FARGS(XR) SET NUMBER OF ARGUMENTS ! 10218: ZER EFUSE(XR) SET USE COUNT (DFFNC WILL SET TO 1) ! 10219: ZER EFCOD(XR) ZERO CODE POINTER FOR NOW ! 10220: MOV (XS)+,EFRSL(XR) STORE RESULT TYPE CODE ! 10221: MOV LODFN,EFVAR(XR) STORE FUNCTION VRBLK POINTER ! 10222: MOV WA,EFLEN(XR) STORE EFBLK LENGTH ! 10223: MOV XR,WB SAVE EFBLK POINTER ! 10224: ADD WA,XR POINT PAST END OF EFBLK ! 10225: LCT WC,WC SET NUMBER OF ARGUMENTS FOR LOOP ! 10226: * ! 10227: * LOOP TO SET ARGUMENT TYPE CODES FROM STACK ! 10228: * ! 10229: SLOD6 MOV (XS)+,-(XR) STORE ONE TYPE CODE FROM STACK ! 10230: BCT WC,SLOD6 LOOP TILL ALL STORED ! 10231: * ! 10232: * NOW LOAD THE EXTERNAL FUNCTION AND PERFORM DEFINITION ! 10233: * ! 10234: MOV (XS)+,XR LOAD FUNCTION STRING NAME ! 10235: MOV (XS),XL LOAD LIBRARY NAME ! 10236: MOV WB,(XS) STORE EFBLK POINTER ! 10237: JSR SYSLD CALL FUNCTION TO LOAD EXTERNAL FUNC ! 10238: PPM EXFAL FAIL RETURN ! 10239: PPM EROSI ERROR RETURN ! 10240: MOV (XS)+,XL RECALL EFBLK POINTER ! 10241: MOV XR,EFCOD(XL) STORE CODE POINTER ! 10242: MOV LODFN,XR POINT TO VRBLK FOR FUNCTION ! 10243: JSR DFFNC PERFORM FUNCTION DEFINITION ! 10244: BRN EXNUL RETURN NULL RESULT ! 10245: .FI ! 10246: EJC ! 10247: * ! 10248: * LOCAL ! 10249: * ! 10250: S$LOC ENT ENTRY POINT ! 10251: JSR GTSMI GET SECOND ARGUMENT (LOCAL NUMBER) ! 10252: ERR 256,LOCAL SECOND ARGUMENT IS NOT INTEGER ! 10253: PPM EXFAL FAIL IF OUT OF RANGE ! 10254: MOV XR,WB SAVE LOCAL NUMBER ! 10255: MOV (XS)+,XR LOAD FIRST ARGUMENT ! 10256: JSR GTNVR POINT TO VRBLK ! 10257: PPM SLOC1 JUMP IF NOT VARIABLE NAME ! 10258: MOV VRFNC(XR),XR ELSE LOAD FUNCTION POINTER ! 10259: BNE (XR),=B$PFC,SLOC1 JUMP IF NOT PROGRAM DEFINED ! 10260: * ! 10261: * HERE IF WE HAVE A PROGRAM DEFINED FUNCTION NAME ! 10262: * ! 10263: BZE WB,EXFAL FAIL IF SECOND ARG IS ZERO ! 10264: BGT WB,PFNLO(XR),EXFAL OR TOO LARGE ! 10265: ADD FARGS(XR),WB ELSE ADJUST OFFSET TO INCLUDE ARGS ! 10266: WTB WB CONVERT TO BYTES ! 10267: ADD WB,XR POINT TO LOCAL POINTER ! 10268: MOV PFAGB(XR),XR LOAD VRBLK POINTER ! 10269: BRN EXVNM EXIT BUILDING NMBLK ! 10270: * ! 10271: * HERE IF FIRST ARGUMENT IS NO GOOD ! 10272: * ! 10273: SLOC1 ERB 257,LOCAL FIRST ARG IS NOT A PROGRAM FUNCTION NAME ! 10274: EJC ! 10275: * ! 10276: * LPAD ! 10277: * ! 10278: S$LPD ENT ENTRY POINT ! 10279: JSR GTSTG GET PAD CHARACTER ! 10280: ERR 148,LPAD THIRD ARGUMENT NOT A STRING ! 10281: PLC XR POINT TO CHARACTER (NULL IS BLANK) ! 10282: LCH WB,(XR) LOAD PAD CHARACTER ! 10283: JSR GTSMI GET PAD LENGTH ! 10284: ERR 149,LPAD SECOND ARGUMENT IS NOT INTEGER ! 10285: PPM SLPD3 SKIP IF NEGATIVE OR LARGE ! 10286: * ! 10287: * MERGE TO CHECK FIRST ARG ! 10288: * ! 10289: SLPD1 JSR GTSTG GET FIRST ARGUMENT (STRING TO PAD) ! 10290: ERR 150,LPAD FIRST ARGUMENT IS NOT STRING ! 10291: BGE WA,WC,EXIXR RETURN 1ST ARG IF TOO LONG TO PAD ! 10292: MOV XR,XL ELSE MOVE PTR TO STRING TO PAD ! 10293: * ! 10294: * NOW WE ARE READY FOR THE PAD ! 10295: * ! 10296: * (XL) POINTER TO STRING TO PAD ! 10297: * (WB) PAD CHARACTER ! 10298: * (WC) LENGTH TO PAD STRING TO ! 10299: * ! 10300: MOV WC,WA COPY LENGTH ! 10301: JSR ALOCS ALLOCATE SCBLK FOR NEW STRING ! 10302: MOV XR,-(XS) SAVE AS RESULT ! 10303: MOV SCLEN(XL),WA LOAD LENGTH OF ARGUMENT ! 10304: SUB WA,WC CALCULATE NUMBER OF PAD CHARACTERS ! 10305: PSC XR POINT TO CHARS IN RESULT STRING ! 10306: LCT WC,WC SET COUNTER FOR PAD LOOP ! 10307: * ! 10308: * LOOP TO PERFORM PAD ! 10309: * ! 10310: SLPD2 SCH WB,(XR)+ STORE PAD CHARACTER, BUMP PTR ! 10311: BCT WC,SLPD2 LOOP TILL ALL PAD CHARS STORED ! 10312: CSC XR COMPLETE STORE CHARACTERS ! 10313: * ! 10314: * NOW COPY STRING ! 10315: * ! 10316: BZE WA,EXITS EXIT IF NULL STRING ! 10317: PLC XL ELSE POINT TO CHARS IN ARGUMENT ! 10318: MVC MOVE CHARACTERS TO RESULT STRING ! 10319: BRN EXITS JUMP FOR NEXT CODE WORD ! 10320: * ! 10321: * HERE IF 2ND ARG IS NEGATIVE OR LARGE ! 10322: * ! 10323: SLPD3 ZER WC ZERO PAD COUNT ! 10324: BRN SLPD1 MERGE ! 10325: EJC ! 10326: * ! 10327: * LT ! 10328: * ! 10329: S$LTF ENT ENTRY POINT ! 10330: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE ! 10331: ERR 151,LT FIRST ARGUMENT IS NOT NUMERIC ! 10332: ERR 152,LT SECOND ARGUMENT IS NOT NUMERIC ! 10333: PPM EXNUL RETURN NULL IF LT ! 10334: PPM EXFAL FAIL IF EQ ! 10335: PPM EXFAL FAIL IF GT ! 10336: EJC ! 10337: * ! 10338: * NE ! 10339: * ! 10340: S$NEF ENT ENTRY POINT ! 10341: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE ! 10342: ERR 153,NE FIRST ARGUMENT IS NOT NUMERIC ! 10343: ERR 154,NE SECOND ARGUMENT IS NOT NUMERIC ! 10344: PPM EXNUL RETURN NULL IF LT ! 10345: PPM EXFAL FAIL IF EQ ! 10346: PPM EXNUL RETURN NULL IF GT ! 10347: EJC ! 10348: * ! 10349: * NOTANY ! 10350: * ! 10351: S$NAY ENT ENTRY POINT ! 10352: MOV =P$NAS,WB SET PCODE FOR SINGLE CHAR ARG ! 10353: MOV =P$NAY,XL PCODE FOR MULTI-CHAR ARG ! 10354: MOV =P$NAD,WC SET PCODE FOR EXPR ARG ! 10355: JSR PATST CALL COMMON ROUTINE TO BUILD NODE ! 10356: ERR 155,NOTANY ARGUMENT IS NOT STRING OR EXPRESSION ! 10357: BRN EXIXR JUMP FOR NEXT CODE WORD ! 10358: EJC ! 10359: * ! 10360: * OPSYN ! 10361: * ! 10362: S$OPS ENT ENTRY POINT ! 10363: JSR GTSMI LOAD THIRD ARGUMENT ! 10364: ERR 156,OPSYN THIRD ARGUMENT IS NOT INTEGER ! 10365: ERR 157,OPSYN THIRD ARGUMENT IS NEGATIVE OR TOO LARGE ! 10366: MOV WC,WB IF OK, SAVE THIRD ARGUMNET ! 10367: MOV (XS)+,XR LOAD SECOND ARGUMENT ! 10368: JSR GTNVR LOCATE VARIABLE BLOCK ! 10369: ERR 158,OPSYN SECOND ARG IS NOT NATURAL VARIABLE NAME ! 10370: MOV VRFNC(XR),XL IF OK, LOAD FUNCTION BLOCK POINTER ! 10371: BNZ WB,SOPS2 JUMP IF OPERATOR OPSYN CASE ! 10372: * ! 10373: * HERE FOR FUNCTION OPSYN (THIRD ARG ZERO) ! 10374: * ! 10375: MOV (XS)+,XR LOAD FIRST ARGUMENT ! 10376: JSR GTNVR GET VRBLK POINTER ! 10377: ERR 159,OPSYN FIRST ARG IS NOT NATURAL VARIABLE NAME ! 10378: * ! 10379: * MERGE HERE TO PERFORM FUNCTION DEFINITION ! 10380: * ! 10381: SOPS1 JSR DFFNC CALL FUNCTION DEFINER ! 10382: BRN EXNUL EXIT WITH NULL RESULT ! 10383: * ! 10384: * HERE FOR OPERATOR OPSYN (THIRD ARG NON-ZERO) ! 10385: * ! 10386: SOPS2 JSR GTSTG GET OPERATOR NAME ! 10387: PPM SOPS5 JUMP IF NOT STRING ! 10388: BNE WA,=NUM01,SOPS5 ERROR IF NOT ONE CHAR LONG ! 10389: PLC XR ELSE POINT TO CHARACTER ! 10390: LCH WC,(XR) LOAD CHARACTER NAME ! 10391: EJC ! 10392: * ! 10393: * OPSYN (CONTINUED) ! 10394: * ! 10395: * NOW SET TO SEARCH FOR MATCHING UNARY OR BINARY OPERATOR ! 10396: * NAME AS APPROPRIATE. NOTE THAT THERE ARE =OPBUN UNDEFINED ! 10397: * BINARY OPERATORS AND =OPUUN UNDEFINED UNARY OPERATORS. ! 10398: * ! 10399: MOV =R$UUB,WA POINT TO UNOP POINTERS IN CASE ! 10400: MOV =OPNSU,XR POINT TO NAMES OF UNARY OPERATORS ! 10401: ADD =OPBUN,WB ADD NO. OF UNDEFINED BINARY OPS ! 10402: BEQ WB,=OPUUN,SOPS3 JUMP IF UNOP (THIRD ARG WAS 1) ! 10403: MOV =R$UBA,WA ELSE POINT TO BINARY OPERATOR PTRS ! 10404: MOV =OPSNB,XR POINT TO NAMES OF BINARY OPERATORS ! 10405: MOV =OPBUN,WB SET NUMBER OF UNDEFINED BINOPS ! 10406: * ! 10407: * MERGE HERE TO CHECK LIST (WB = NUMBER TO CHECK) ! 10408: * ! 10409: SOPS3 LCT WB,WB SET COUNTER TO CONTROL LOOP ! 10410: * ! 10411: * LOOP TO SEARCH FOR NAME MATCH ! 10412: * ! 10413: SOPS4 BEQ WC,(XR),SOPS6 JUMP IF NAMES MATCH ! 10414: ICA WA ELSE PUSH POINTER TO FUNCTION PTR ! 10415: ICA XR BUMP POINTER ! 10416: BCT WB,SOPS4 LOOP BACK TILL ALL CHECKED ! 10417: * ! 10418: * HERE IF BAD OPERATOR NAME ! 10419: * ! 10420: SOPS5 ERB 160,OPSYN FIRST ARG IS NOT CORRECT OPERATOR NAME ! 10421: * ! 10422: * COME HERE ON FINDING A MATCH IN THE OPERATOR NAME TABLE ! 10423: * ! 10424: SOPS6 MOV WA,XR COPY POINTER TO FUNCTION BLOCK PTR ! 10425: SUB *VRFNC,XR MAKE IT LOOK LIKE DUMMY VRBLK ! 10426: BRN SOPS1 MERGE BACK TO DEFINE OPERATOR ! 10427: EJC ! 10428: * ! 10429: * OUTPUT ! 10430: * ! 10431: S$OUP ENT ENTRY POINT ! 10432: MOV =NUM02,WB OUTPUT FLAG ! 10433: JSR IOPUT CALL INPUT/OUTPUT ASSOC. ROUTINE ! 10434: ERR 161,OUTPUT THIRD ARGUMENT (FILEPROPS) IS NOT A STRING ! 10435: ERR 162,INAPPROPRIATE SECOND ARGUMENT (FILETAG) FOR OUTPUT ! 10436: ERR 163,INAPPROPRIATE FIRST ARGUMENT FOR OUTPUT ! 10437: PPM EXFAL FAIL RETURN ! 10438: BRN EXNUL RETURN NULL STRING ! 10439: EJC ! 10440: * ! 10441: * POS ! 10442: * ! 10443: S$POS ENT ENTRY POINT ! 10444: MOV =P$POS,WB SET PCODE FOR INTEGER ARG CASE ! 10445: MOV =P$PSD,WA SET PCODE FOR EXPRESSION ARG CASE ! 10446: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE ! 10447: ERR 164,POS ARGUMENT IS NOT INTEGER OR EXPRESSION ! 10448: ERR 165,POS ARGUMENT IS NEGATIVE OR TOO LARGE ! 10449: BRN EXIXR RETURN PATTERN NODE ! 10450: EJC ! 10451: * ! 10452: * PROTOTYPE ! 10453: * ! 10454: S$PRO ENT ENTRY POINT ! 10455: MOV (XS)+,XR LOAD ARGUMENT ! 10456: MOV TBLEN(XR),WB LENGTH IF TABLE, VECTOR (=VCLEN) ! 10457: BTW WB CONVERT TO WORDS ! 10458: MOV (XR),WA LOAD TYPE WORD OF ARGUMENT BLOCK ! 10459: BEQ WA,=B$ART,SPRO4 JUMP IF ARRAY ! 10460: BEQ WA,=B$TBT,SPRO1 JUMP IF TABLE ! 10461: BEQ WA,=B$VCT,SPRO3 JUMP IF VECTOR ! 10462: .IF .CNBF ! 10463: .ELSE ! 10464: BEQ WA,=B$BCT,SPR05 JUMP IF BUFFER ! 10465: .FI ! 10466: ERB 166,PROTOTYPE ARGUMENT IS NOT TABLE OR ARRAY ! 10467: * ! 10468: * HERE FOR TABLE ! 10469: * ! 10470: SPRO1 SUB =TBSI$,WB SUBTRACT STANDARD FIELDS ! 10471: * ! 10472: * MERGE FOR VECTOR ! 10473: * ! 10474: SPRO2 MTI WB CONVERT TO INTEGER ! 10475: BRN EXINT EXIT WITH INTEGER RESULT ! 10476: * ! 10477: * HERE FOR VECTOR ! 10478: * ! 10479: SPRO3 SUB =VCSI$,WB SUBTRACT STANDARD FIELDS ! 10480: BRN SPRO2 MERGE ! 10481: * ! 10482: * HERE FOR ARRAY ! 10483: * ! 10484: SPRO4 ADD AROFS(XR),XR POINT TO PROTOTYPE FIELD ! 10485: MOV (XR),XR LOAD PROTOTYPE ! 10486: BRN EXIXR RETURN PROTOTYPE AS RESULT ! 10487: .IF .CNBF ! 10488: .ELSE ! 10489: * ! 10490: * HERE FOR BUFFER ! 10491: * ! 10492: SPR05 MOV BCBUF(XR),XR POINT TO BFBLK ! 10493: MTI BFALC(XR) LOAD ALLOCATED LENGTH ! 10494: BRN EXINT EXIT WITH INTEGER ALLOCATION ! 10495: .FI ! 10496: EJC ! 10497: * ! 10498: * REMDR ! 10499: * ! 10500: S$RMD ENT ENTRY POINT ! 10501: ZER WB SET POSITIVE FLAG ! 10502: MOV (XS),XR LOAD SECOND ARGUMENT ! 10503: JSR GTINT CONVERT TO INTEGER ! 10504: ERR 167,REMDR SECOND ARGUMENT IS NOT INTEGER ! 10505: JSR ARITH CONVERT ARGS ! 10506: PPM SRM01 FIRST ARG NOT INTEGER ! 10507: PPM SECOND ARG CHECKED ABOVE ! 10508: .IF .CNRA ! 10509: .ELSE ! 10510: PPM SRM01 FIRST ARG REAL ! 10511: .FI ! 10512: LDI ICVAL(XR) LOAD LEFT ARGUMENT VALUE ! 10513: RMI ICVAL(XL) GET REMAINDER ! 10514: INO EXINT JUMP IF NO OVERFLOW ! 10515: ERB 168,REMDR CAUSED INTEGER OVERFLOW ! 10516: * ! 10517: * FAIL FIRST ARGUMENT ! 10518: * ! 10519: SRM01 ERB 169,REMDR FIRST ARGUMENT IS NOT INTEGER ! 10520: EJC ! 10521: * ! 10522: * REPLACE ! 10523: * ! 10524: * THE ACTUAL REPLACE OPERATION USES AN SCBLK WHOSE CFP$A ! 10525: * CHARS CONTAIN THE TRANSLATED VERSIONS OF ALL THE CHARS. ! 10526: * THE TABLE POINTER IS REMEMBERED FROM CALL TO CALL AND ! 10527: * THE TABLE IS ONLY BUILT WHEN THE ARGUMENTS CHANGE. ! 10528: * ! 10529: S$RPL ENT ENTRY POINT ! 10530: JSR GTSTG LOAD THIRD ARGUMENT AS STRING ! 10531: ERR 170,REPLACE THIRD ARGUMENT IS NOT STRING ! 10532: MOV XR,XL SAVE THIRD ARG PTR ! 10533: JSR GTSTG GET SECOND ARGUMENT ! 10534: ERR 171,REPLACE SECOND ARGUMENT IS NOT STRING ! 10535: * ! 10536: * CHECK TO SEE IF THIS IS THE SAME TABLE AS LAST TIME ! 10537: * ! 10538: BNE XR,R$RA2,SRPL1 JUMP IF 2ND ARGUMENT DIFFERENT ! 10539: BEQ XL,R$RA3,SRPL4 JUMP IF ARGS SAME AS LAST TIME ! 10540: * ! 10541: * HERE WE BUILD A NEW REPLACE TABLE (NOTE WA = 2ND ARG LEN) ! 10542: * ! 10543: SRPL1 MOV SCLEN(XL),WB LOAD 3RD ARGUMENT LENGTH ! 10544: BNE WA,WB,SRPL5 JUMP IF ARGUMENTS NOT SAME LENGTH ! 10545: BZE WB,SRPL5 JUMP IF NULL 2ND ARGUMENT ! 10546: MOV XL,R$RA3 SAVE THIRD ARG FOR NEXT TIME IN ! 10547: MOV XR,R$RA2 SAVE SECOND ARG FOR NEXT TIME IN ! 10548: MOV KVALP,XL POINT TO ALPHABET STRING ! 10549: MOV SCLEN(XL),WA LOAD ALPHABET SCBLK LENGTH ! 10550: MOV R$RPT,XR POINT TO CURRENT TABLE (IF ANY) ! 10551: BNZ XR,SRPL2 JUMP IF WE ALREADY HAVE A TABLE ! 10552: * ! 10553: * HERE WE ALLOCATE A NEW TABLE ! 10554: * ! 10555: JSR ALOCS ALLOCATE NEW TABLE ! 10556: MOV WC,WA KEEP SCBLK LENGTH ! 10557: MOV XR,R$RPT SAVE TABLE POINTER FOR NEXT TIME ! 10558: * ! 10559: * MERGE HERE WITH POINTER TO NEW TABLE BLOCK IN (XR) ! 10560: * ! 10561: SRPL2 CTB WA,SCSI$ COMPUTE LENGTH OF SCBLK ! 10562: MVW COPY TO GET INITIAL TABLE VALUES ! 10563: EJC ! 10564: * ! 10565: * REPLACE (CONTINUED) ! 10566: * ! 10567: * NOW WE MUST PLUG SELECTED ENTRIES AS REQUIRED. NOTE THAT ! 10568: * WE ARE SHORT OF INDEX REGISTERS FOR THE FOLLOWING LOOP. ! 10569: * HENCE THE NEED TO REPEATEDLY RE-INITIALISE CHAR PTR XL ! 10570: * ! 10571: MOV R$RA2,XL POINT TO SECOND ARGUMENT ! 10572: LCT WB,WB NUMBER OF CHARS TO PLUG ! 10573: ZER WC ZERO CHAR OFFSET ! 10574: MOV R$RA3,XR POINT TO 3RD ARG ! 10575: PLC XR GET CHAR PTR FOR 3RD ARG ! 10576: * ! 10577: * LOOP TO PLUG CHARS ! 10578: * ! 10579: SRPL3 MOV R$RA2,XL POINT TO 2ND ARG ! 10580: PLC XL,WC POINT TO NEXT CHAR ! 10581: ICV WC INCREMENT OFFSET ! 10582: LCH WA,(XL) GET NEXT CHAR ! 10583: MOV R$RPT,XL POINT TO TRANSLATE TABLE ! 10584: PSC XL,WA CONVERT CHAR TO OFFSET INTO TABLE ! 10585: LCH WA,(XR)+ GET TRANSLATED CHAR ! 10586: SCH WA,(XL) STORE IN TABLE ! 10587: CSC XL COMPLETE STORE CHARACTERS ! 10588: BCT WB,SRPL3 LOOP TILL DONE ! 10589: EJC ! 10590: * ! 10591: * REPLACE (CONTINUED) ! 10592: * ! 10593: * HERE TO PERFORM TRANSLATE ! 10594: * ! 10595: SRPL4 JSR GTSTG GET FIRST ARGUMENT ! 10596: ERR 172,REPLACE FIRST ARGUMENT IS NOT STRING ! 10597: BZE WA,EXNUL RETURN NULL IF NULL ARGUMENT ! 10598: MOV XR,XL COPY POINTER ! 10599: MOV WA,WC SAVE LENGTH ! 10600: CTB WA,SCHAR GET SCBLK LENGTH ! 10601: JSR ALLOC ALLOCATE SPACE FOR COPY ! 10602: MOV XR,WB SAVE ADDRESS OF COPY ! 10603: MVW MOVE SCBLK CONTENTS TO COPY ! 10604: MOV R$RPT,XR POINT TO REPLACE TABLE ! 10605: PLC XR POINT TO CHARS OF TABLE ! 10606: MOV WB,XL POINT TO STRING TO TRANSLATE ! 10607: PLC XL POINT TO CHARS OF STRING ! 10608: MOV WC,WA SET NUMBER OF CHARS TO TRANSLATE ! 10609: TRC PERFORM TRANSLATION ! 10610: MOV WB,-(XS) STACK NEW STRING AS RESULT ! 10611: BRN EXITS RETURN WITH RESULT ON STACK ! 10612: * ! 10613: * ERROR POINT ! 10614: * ! 10615: SRPL5 ERB 173,NULL OR UNEQUALLY LONG 2ND, 3RD ARGS TO REPLACE ! 10616: EJC ! 10617: * ! 10618: * REVERSE ! 10619: * ! 10620: S$RVS ENT ENTRY POINT ! 10621: JSR GTSTG LOAD STRING ARGUMENT ! 10622: ERR 174,REVERSE ARGUMENT IS NOT STRING ! 10623: BZE WA,EXIXR RETURN ARGUMENT IF NULL ! 10624: MOV XR,XL ELSE SAVE POINTER TO STRING ARG ! 10625: JSR ALOCS ALLOCATE SPACE FOR NEW SCBLK ! 10626: MOV XR,-(XS) STORE SCBLK PTR ON STACK AS RESULT ! 10627: PSC XR PREPARE TO STORE IN NEW SCBLK ! 10628: PLC XL,WC POINT PAST LAST CHAR IN ARGUMENT ! 10629: LCT WC,WC SET LOOP COUNTER ! 10630: * ! 10631: * LOOP TO MOVE CHARS IN REVERSE ORDER ! 10632: * ! 10633: SRVS1 LCH WB,-(XL) LOAD NEXT CHAR FROM ARGUMENT ! 10634: SCH WB,(XR)+ STORE IN RESULT ! 10635: BCT WC,SRVS1 LOOP TILL ALL MOVED ! 10636: CSC XR COMPLETE STORE CHARACTERS ! 10637: BRN EXITS AND THEN JUMP FOR NEXT CODE WORD ! 10638: EJC ! 10639: * ! 10640: * RPAD ! 10641: * ! 10642: S$RPD ENT ENTRY POINT ! 10643: JSR GTSTG GET PAD CHARACTER ! 10644: ERR 175,RPAD THIRD ARGUMENT IS NOT STRING ! 10645: PLC XR POINT TO CHARACTER (NULL IS BLANK) ! 10646: LCH WB,(XR) LOAD PAD CHARACTER ! 10647: JSR GTSMI GET PAD LENGTH ! 10648: ERR 176,RPAD SECOND ARGUMENT IS NOT INTEGER ! 10649: PPM SRPD3 SKIP IF NEGATIVE OR LARGE ! 10650: * ! 10651: * MERGE TO CHECK FIRST ARG. ! 10652: * ! 10653: SRPD1 JSR GTSTG GET FIRST ARGUMENT (STRING TO PAD) ! 10654: ERR 177,RPAD FIRST ARGUMENT IS NOT STRING ! 10655: BGE WA,WC,EXIXR RETURN 1ST ARG IF TOO LONG TO PAD ! 10656: MOV XR,XL ELSE MOVE PTR TO STRING TO PAD ! 10657: * ! 10658: * NOW WE ARE READY FOR THE PAD ! 10659: * ! 10660: * (XL) POINTER TO STRING TO PAD ! 10661: * (WB) PAD CHARACTER ! 10662: * (WC) LENGTH TO PAD STRING TO ! 10663: * ! 10664: MOV WC,WA COPY LENGTH ! 10665: JSR ALOCS ALLOCATE SCBLK FOR NEW STRING ! 10666: MOV XR,-(XS) SAVE AS RESULT ! 10667: MOV SCLEN(XL),WA LOAD LENGTH OF ARGUMENT ! 10668: SUB WA,WC CALCULATE NUMBER OF PAD CHARACTERS ! 10669: PSC XR POINT TO CHARS IN RESULT STRING ! 10670: LCT WC,WC SET COUNTER FOR PAD LOOP ! 10671: * ! 10672: * COPY ARGUMENT STRING ! 10673: * ! 10674: BZE WA,SRPD2 JUMP IF ARGUMENT IS NULL ! 10675: PLC XL ELSE POINT TO ARGUMENT CHARS ! 10676: MVC MOVE CHARACTERS TO RESULT STRING ! 10677: * ! 10678: * LOOP TO SUPPLY PAD CHARACTERS ! 10679: * ! 10680: SRPD2 SCH WB,(XR)+ STORE PAD CHARACTER, BUMP PTR ! 10681: BCT WC,SRPD2 LOOP TILL ALL PAD CHARS STORED ! 10682: CSC XR COMPLETE CHARACTER STORING ! 10683: BRN EXITS AND EXIT FOR NEXT WORD ! 10684: * ! 10685: * HERE IF 2ND ARG IS NEGATIVE OR LARGE ! 10686: * ! 10687: SRPD3 ZER WC ZERO PAD COUNT ! 10688: BRN SRPD1 MERGE ! 10689: EJC ! 10690: * ! 10691: * RTAB ! 10692: * ! 10693: S$RTB ENT ENTRY POINT ! 10694: MOV =P$RTB,WB SET PCODE FOR INTEGER ARG CASE ! 10695: MOV =P$RTD,WA SET PCODE FOR EXPRESSION ARG CASE ! 10696: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE ! 10697: ERR 178,RTAB ARGUMENT IS NOT INTEGER OR EXPRESSION ! 10698: ERR 179,RTAB ARGUMENT IS NEGATIVE OR TOO LARGE ! 10699: BRN EXIXR RETURN PATTERN NODE ! 10700: EJC ! 10701: .IF .CUST ! 10702: * ! 10703: * SET ! 10704: * ! 10705: S$SET ENT ENTRY POINT ! 10706: MOV (XS)+,R$IOL SAVE THIRD ARG ! 10707: MOV (XS)+,R$IO1 SAVE SECOND ARG ! 10708: JSR IOFTG CALL IOTAG ROUTINE ! 10709: ERR 180,SET FIRST ARGUMENT IS NOT A SUITABLE NAME ! 10710: BZE WA,EXFAL FAIL IF NO IOTAG ! 10711: MOV R$IO1,WB LOAD SECOND ARG ! 10712: MOV R$IOL,WC LOAD THIRD ARG ! 10713: JSR SYSST CALL SYSTEM SET ROUTINE ! 10714: PPM EXFAL FAILURE RETURN ! 10715: PPM EROSI ERROR RETURN ! 10716: BRN EXNUL OTHERWISE RETURN NULL ! 10717: EJC ! 10718: .FI ! 10719: * ! 10720: * RPOS ! 10721: * ! 10722: S$RPS ENT ENTRY POINT ! 10723: MOV =P$RPS,WB SET PCODE FOR INTEGER ARG CASE ! 10724: MOV =P$RPD,WA SET PCODE FOR EXPRESSION ARG CASE ! 10725: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE ! 10726: ERR 181,RPOS ARGUMENT IS NOT INTEGER OR EXPRESSION ! 10727: ERR 182,RPOS ARGUMENT IS NEGATIVE OR TOO LARGE ! 10728: BRN EXIXR RETURN PATTERN NODE ! 10729: .IF .CNSR ! 10730: .ELSE ! 10731: EJC ! 10732: * ! 10733: * RSORT ! 10734: * ! 10735: S$RSR ENT ENTRY POINT ! 10736: MNZ WA MARK AS RSORT ! 10737: JSR SORTA CALL SORT ROUTINE ! 10738: PPM EXFAL FAIL EMPTY TABLE ! 10739: BRN EXSID RETURN, SETTING IDVAL ! 10740: .FI ! 10741: EJC ! 10742: * ! 10743: * SETEXIT ! 10744: * ! 10745: S$STX ENT ENTRY POINT ! 10746: MOV (XS)+,XR LOAD ARGUMENT ! 10747: MOV STXVR,WA LOAD OLD VRBLK POINTER ! 10748: ZER XL LOAD ZERO IN CASE NULL ARG ! 10749: BEQ XR,=NULLS,SSTX1 JUMP IF NULL ARGUMENT (RESET CALL) ! 10750: JSR GTNVR ELSE GET SPECIFIED VRBLK ! 10751: PPM SSTX2 JUMP IF NOT NATURAL VARIABLE ! 10752: MOV VRLBL(XR),XL ELSE LOAD LABEL ! 10753: BEQ XL,=STNDL,SSTX2 JUMP IF LABEL IS NOT DEFINED ! 10754: BNE (XL),=B$TRT,SSTX1 JUMP IF NOT TRAPPED ! 10755: MOV TRLBL(XL),XL ELSE LOAD PTR TO REAL LABEL CODE ! 10756: * ! 10757: * HERE TO SET/RESET SETEXIT TRAP ! 10758: * ! 10759: SSTX1 MOV XR,STXVR STORE NEW VRBLK POINTER (OR NULL) ! 10760: MOV XL,R$SXC STORE NEW CODE PTR (OR ZERO) ! 10761: BEQ WA,=NULLS,EXNUL RETURN NULL IF NULL RESULT ! 10762: MOV WA,XR ELSE COPY VRBLK POINTER ! 10763: BRN EXVNM AND RETURN BUILDING NMBLK ! 10764: * ! 10765: * HERE IF BAD ARGUMENT ! 10766: * ! 10767: SSTX2 ERB 183,SETEXIT ARGUMENT IS NOT LABEL NAME OR NULL ! 10768: .IF .CNSR ! 10769: .ELSE ! 10770: EJC ! 10771: * ! 10772: * SORT ! 10773: * ! 10774: S$SRT ENT ENTRY POINT ! 10775: ZER WA MARK AS SORT ! 10776: JSR SORTA CALL SORT ROUTINE ! 10777: PPM EXFAL FAIL EMPTY TABLE ! 10778: BRN EXSID RETURN, SETTING IDVAL ! 10779: .FI ! 10780: EJC ! 10781: * ! 10782: * SPAN ! 10783: * ! 10784: S$SPN ENT ENTRY POINT ! 10785: MOV =P$SPS,WB SET PCODE FOR SINGLE CHAR ARG ! 10786: MOV =P$SPN,XL SET PCODE FOR MULTI-CHAR ARG ! 10787: MOV =P$SPD,WC SET PCODE FOR EXPRESSION ARG ! 10788: JSR PATST CALL COMMON ROUTINE TO BUILD NODE ! 10789: ERR 184,SPAN ARGUMENT IS NOT STRING OR EXPRESSION ! 10790: BRN EXIXR JUMP FOR NEXT CODE WORD ! 10791: EJC ! 10792: * ! 10793: * SIZE ! 10794: * ! 10795: S$SI$ ENT ENTRY POINT ! 10796: .IF .CNBF ! 10797: JSR GTSTG LOAD STRING ARGUMENT ! 10798: .ELSE ! 10799: MOV (XS),XR LOAD ARGUMENT ! 10800: BNE (XR),=B$BCT,SSI$1 BRANCH IF NOT BUFFER ! 10801: ICA XS ELSE POP ARGUMENT ! 10802: MTI BCLEN(XR) LOAD DEFINED LENGTH ! 10803: BRN EXINT EXIT WITH INTEGER ! 10804: * ! 10805: * HERE IF NOT BUFFER ! 10806: * ! 10807: SSI$1 JSR GTSTG LOAD STRING ARGUMENT ! 10808: .FI ! 10809: ERR 185,SIZE ARGUMENT IS NOT STRING ! 10810: MTI WA LOAD LENGTH AS INTEGER ! 10811: BRN EXINT EXIT WITH INTEGER RESULT ! 10812: EJC ! 10813: * ! 10814: * STOPTR ! 10815: * ! 10816: S$STT ENT ENTRY POINT ! 10817: ZER XL INDICATE STOPTR CASE ! 10818: JSR TRACE CALL TRACE PROCEDURE ! 10819: ERR 186,STOPTR FIRST ARGUMENT IS NOT APPROPRIATE NAME ! 10820: ERR 187,STOPTR SECOND ARGUMENT IS NOT TRACE TYPE ! 10821: PPM EXFAL FAIL RETURN ! 10822: BRN EXNUL RETURN NULL ! 10823: EJC ! 10824: * ! 10825: * SUBSTR ! 10826: * ! 10827: S$SUB ENT ENTRY POINT ! 10828: JSR GTSMI LOAD THIRD ARGUMENT ! 10829: ERR 188,SUBSTR THIRD ARGUMENT IS NOT INTEGER ! 10830: PPM EXFAL JUMP IF NEGATIVE OR TOO LARGE ! 10831: MOV XR,SBSSV SAVE THIRD ARGUMENT ! 10832: JSR GTSMI LOAD SECOND ARGUMENT ! 10833: ERR 189,SUBSTR SECOND ARGUMENT IS NOT INTEGER ! 10834: PPM EXFAL JUMP IF OUT OF RANGE ! 10835: MOV XR,WB SAVE SECOND ARGUMENT ! 10836: BZE WB,EXFAL JUMP IF SECOND ARGUMENT ZERO ! 10837: DCV WB ELSE DECREMENT FOR ONES ORIGIN ! 10838: .IF .CNBF ! 10839: JSR GTSTG LOAD FIRST ARGUMENT ! 10840: .ELSE ! 10841: MOV (XS),XL GET FIRST ARG PTR ! 10842: BNE (XL),=B$BCT,SSUBA BRANCH IF NOT BUFFER ! 10843: MOV BCBUF(XL),XR GET BFBLK PTR ! 10844: MOV BCLEN(XL),WA GET LENGTH ! 10845: BRN SSUBB MERGE ! 10846: * ! 10847: * HERE IF NOT BUFFER TO GET STRING ! 10848: * ! 10849: SSUBA JSR GTSTG LOAD FIRST ARGUMENT ! 10850: .FI ! 10851: ERR 190,SUBSTR FIRST ARGUMENT IS NOT STRING ! 10852: MOV XR,XL COPY POINTER TO FIRST ARG ! 10853: .IF .CNBF ! 10854: MOV SBSSV,WC RELOAD THIRD ARGUMENT ! 10855: .ELSE ! 10856: * ! 10857: * MERGE WITH BFBLK OR SCBLK IN XR, LENGTH IN WA ! 10858: * ! 10859: SSUBB MOV SBSSV,WC RELOAD THIRD ARGUMENT ! 10860: .FI ! 10861: BNZ WC,SSUB1 SKIP IF THIRD ARG GIVEN ! 10862: MOV SCLEN(XL),WC ELSE GET STRING LENGTH ! 10863: BGT WB,WC,EXFAL FAIL IF IMPROPER ! 10864: SUB WB,WC REDUCE BY OFFSET TO START ! 10865: * ! 10866: * MERGE ! 10867: * ! 10868: SSUB1 MOV WC,WA SET LENGTH OF SUBSTRING ! 10869: ADD WB,WC ADD 2ND ARG TO 3RD ARG ! 10870: BGT WC,SCLEN(XL),EXFAL JUMP IF IMPROPER SUBSTRING ! 10871: JSR SBSTR BUILD SUBSTRING ! 10872: BRN EXIXR AND JUMP FOR NEXT CODE WORD ! 10873: EJC ! 10874: * ! 10875: * TAB ! 10876: * ! 10877: S$TAB ENT ENTRY POINT ! 10878: MOV =P$TAB,WB SET PCODE FOR INTEGER ARG CASE ! 10879: MOV =P$TBD,WA SET PCODE FOR EXPRESSION ARG CASE ! 10880: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE ! 10881: ERR 191,TAB ARGUMENT IS NOT INTEGER OR EXPRESSION ! 10882: ERR 192,TAB ARGUMENT IS NEGATIVE OR TOO LARGE ! 10883: BRN EXIXR RETURN PATTERN NODE ! 10884: EJC ! 10885: * ! 10886: * TABLE ! 10887: * ! 10888: S$TBL ENT ENTRY POINT ! 10889: MOV (XS)+,XL GET INITIAL LOOKUP VALUE ! 10890: ICA XS POP SECOND ARGUMENT ! 10891: JSR GTSMI LOAD ARGUMENT ! 10892: ERR 193,TABLE ARGUMENT IS NOT INTEGER ! 10893: ERR 194,TABLE ARGUMENT IS OUT OF RANGE ! 10894: BNZ WC,STBL1 JUMP IF NON-ZERO ! 10895: MOV =TBNBK,WC ELSE SUPPLY DEFAULT VALUE ! 10896: * ! 10897: * MERGE HERE WITH NUMBER OF HEADERS IN WA ! 10898: * ! 10899: STBL1 MOV WC,WA COPY NUMBER OF HEADERS ! 10900: ADD =TBSI$,WA ADJUST FOR STANDARD FIELDS ! 10901: WTB WA CONVERT LENGTH TO BAUS ! 10902: JSR ALLOC ALLOCATE SPACE FOR TBBLK ! 10903: MOV XR,WB COPY POINTER TO TBBLK ! 10904: MOV =B$TBT,(XR)+ STORE TYPE WORD ! 10905: ZER (XR)+ ZERO ID FOR THE MOMENT ! 10906: MOV WA,(XR)+ STORE LENGTH (TBLEN) ! 10907: MOV XL,(XR)+ STORE INITIAL LOOKUP VALUE ! 10908: LCT WC,WC SET LOOP COUNTER (NUM HEADERS) ! 10909: * ! 10910: * LOOP TO INITIALIZE ALL BUCKET POINTERS ! 10911: * ! 10912: STBL2 MOV WB,(XR)+ STORE TBBLK PTR IN BUCKET HEADER ! 10913: BCT WC,STBL2 LOOP TILL ALL STORED ! 10914: MOV WB,XR RECALL POINTER TO TBBLK ! 10915: BRN EXSID EXIT SETTING IDVAL ! 10916: EJC ! 10917: * ! 10918: * TIME ! 10919: * ! 10920: S$TIM ENT ENTRY POINT ! 10921: JSR SYSTM GET TIMER VALUE ! 10922: SBI TIMSX SUBTRACT STARTING TIME ! 10923: BRN EXINT EXIT WITH INTEGER VALUE ! 10924: EJC ! 10925: * ! 10926: * TRACE ! 10927: * ! 10928: S$TRA ENT ENTRY POINT ! 10929: BEQ 3(XS),=NULLS,STR03 JUMP IF FIRST ARGUMENT IS NULL ! 10930: MOV (XS)+,XR LOAD FOURTH ARGUMENT ! 10931: ZER XL TENTATIVELY SET ZERO POINTER ! 10932: BEQ XR,=NULLS,STR02 JUMP IF 4TH ARGUMENT IS NULL ! 10933: JSR GTNVR ELSE POINT TO VRBLK ! 10934: PPM STR01 JUMP IF NOT VARIABLE NAME ! 10935: MOV VRFNC(XR),XL ELSE LOAD FUNCTION POINTER ! 10936: BNE XL,=STNDF,STR02 JUMP IF FUNCTION IS DEFINED ! 10937: * ! 10938: * HERE FOR BAD FOURTH ARGUMENT ! 10939: * ! 10940: STR01 ERB 195,TRACE FOURTH ARG IS NOT FUNCTION NAME OR NULL ! 10941: * ! 10942: * HERE WITH FUNCTION POINTER IN XL ! 10943: * ! 10944: STR02 MOV (XS)+,XR LOAD THIRD ARGUMENT (TAG) ! 10945: ZER WB SET ZERO AS TRTYP VALUE FOR NOW ! 10946: JSR TRBLD BUILD TRBLK FOR TRACE CALL ! 10947: MOV XR,XL MOVE TRBLK POINTER FOR TRACE ! 10948: JSR TRACE CALL TRACE PROCEDURE ! 10949: ERR 196,TRACE FIRST ARGUMENT IS NOT APPROPRIATE NAME ! 10950: ERR 197,TRACE SECOND ARGUMENT IS NOT TRACE TYPE ! 10951: PPM UNUSED RETURN ! 10952: BRN EXNUL RETURN NULL ! 10953: * ! 10954: * HERE TO CALL SYSTEM TRACE TOGGLE ROUTINE ! 10955: * ! 10956: STR03 JSR SYSTT CALL IT ! 10957: ADD *NUM04,XS POP TRACE ARGUMENTS ! 10958: BRN EXNUL RETURN ! 10959: EJC ! 10960: * ! 10961: * TRIM ! 10962: * ! 10963: S$TRM ENT ENTRY POINT ! 10964: JSR GTSTG LOAD ARGUMENT AS STRING ! 10965: ERR 198,TRIM ARGUMENT IS NOT STRING ! 10966: BZE WA,EXNUL RETURN NULL IF ARGUMENT IS NULL ! 10967: MOV XR,XL COPY STRING POINTER ! 10968: CTB WA,SCHAR GET BLOCK LENGTH ! 10969: JSR ALLOC ALLOCATE COPY SAME SIZE ! 10970: MOV XR,WB SAVE POINTER TO COPY ! 10971: MVW COPY OLD STRING BLOCK TO NEW ! 10972: MOV WB,XR RESTORE PTR TO NEW BLOCK ! 10973: JSR TRIMR TRIM BLANKS (WB IS NON-ZERO) ! 10974: BRN EXIXR EXIT WITH RESULT IN XR ! 10975: EJC ! 10976: * ! 10977: * UNLOAD ! 10978: * ! 10979: S$UNL ENT ENTRY POINT ! 10980: MOV (XS)+,XR LOAD ARGUMENT ! 10981: JSR GTNVR POINT TO VRBLK ! 10982: ERR 199,UNLOAD ARGUMENT IS NOT NATURAL VARIABLE NAME ! 10983: MOV =STNDF,XL GET PTR TO UNDEFINED FUNCTION ! 10984: JSR DFFNC UNDEFINE NAMED FUNCTION ! 10985: BRN EXNUL RETURN NULL AS RESULT ! 10986: EJC ! 10987: * ! 10988: * VDIFFER ! 10989: * ! 10990: S$VDF ENT ENTRY POINT ! 10991: MOV (XS)+,XR LOAD SECOND ARGUMENT ! 10992: MOV (XS),XL LOAD FIRST ARGUMENT ! 10993: JSR IDENT CALL IDENT COMPARISON ROUTINE ! 10994: PPM EXFAL FAIL IF IDENT ! 10995: BRN EXITS RETURN FIRST ARG IF DIFFER ! 10996: TTL S P I T B O L -- UTILITY PROCEDURES ! 10997: * ! 10998: * THE FOLLOWING SECTION CONTAINS PROCEDURES WHICH ARE ! 10999: * USED FOR VARIOUS PURPOSES THROUGHOUT THE SYSTEM. ! 11000: * ! 11001: * EACH PROCEDURE IS PRECEDED BY A DESCRIPTION OF THE ! 11002: * CALLING SEQUENCE. USUALLY THE ARGUMENTS ARE IN REGISTERS ! 11003: * BUT ARGUMENTS CAN ALSO OCCUR ON THE STACK AND AS ! 11004: * PARAMETERS ASSEMBLED AFTER THE JSR INSTRUCTION. ! 11005: * ! 11006: * THE FOLLOWING CONSIDERATIONS APPLY TO THESE DESCRIPTIONS. ! 11007: * ! 11008: * 1) THE STACK POINTER (XS) IS NOT CHANGED UNLESS THE ! 11009: * CHANGE IS EXPLICITLY DOCUMENTED IN THE CALL. ! 11010: * ! 11011: * 2) REGISTERS WHOSE ENTRY VALUES ARE NOT MENTIONED ! 11012: * MAY CONTAIN ANY VALUE EXCEPT THAT XL,XR MAY ONLY ! 11013: * CONTAIN PROPER (COLLECTABLE) POINTER VALUES. ! 11014: * THIS CONDITION ON XR MEANS THAT THE CALLED ROUTINE ! 11015: * MAY IF IT CHOOSES PRESERVE XR BY STACKING. ! 11016: * ! 11017: * 3) REGISTERS NOT MENTIONED ON EXIT CONTAIN THE SAME ! 11018: * VALUES AS THEY DID ON ENTRY EXCEPT THAT VALUES IN ! 11019: * XR,XL MAY HAVE BEEN RELOCATED BY THE COLLECTOR. ! 11020: * ! 11021: * 4) REGISTERS WHICH ARE DESTROYED ON EXIT MAY CONTAIN ! 11022: * ANY VALUE EXCEPT THAT VALUES IN XL,XR ARE PROPER ! 11023: * (COLLECTABLE) POINTERS. ! 11024: * ! 11025: * 5) THE CODE POINTER REGISTER POINTS TO THE CURRENT ! 11026: * CODE LOCATION ON ENTRY AND IS UNCHANGED ON EXIT. ! 11027: * ! 11028: * IN THE ABOVE DESCRIPTION, A COLLECTABLE POINTER IS ONE ! 11029: * WHICH EITHER POINTS OUTSIDE THE DYNAMIC REGION OR ! 11030: * POINTS TO THE START OF A BLOCK IN THE DYNAMIC REGION. ! 11031: * ! 11032: * IN THOSE CASES WHERE THE CALLING SEQUENCE CONTAINS ! 11033: * PARAMETERS WHICH ARE USED AS ALTERNATE RETURN POINTS, ! 11034: * THESE PARAMETERS MAY BE REPLACED BY ERROR CODES ! 11035: * ASSEMBLED WITH THE ERR INSTRUCTION. THIS WILL RESULT ! 11036: * IN THE POSTING OF THE ERROR IF THE RETURN IS TAKEN. ! 11037: * ! 11038: * THE PROCEDURES ALL HAVE NAMES CONSISTING OF FIVE LETTERS ! 11039: * AND ARE IN ALPHABETICAL ORDER BY THEIR NAMES. ! 11040: EJC ! 11041: * ! 11042: * ACESS - ACCESS VARIABLE VALUE WITH TRACE/INPUT CHECKS ! 11043: * ! 11044: * ACESS LOADS THE VALUE OF A VARIABLE. TRACE AND INPUT ! 11045: * ASSOCIATIONS ARE TESTED FOR AND EXECUTED AS REQUIRED. ! 11046: * ACESS ALSO HANDLES THE SPECIAL CASES OF PSEUDO-VARIABLES. ! 11047: * ! 11048: * (XL) VARIABLE NAME BASE ! 11049: * (WA) VARIABLE NAME OFFSET ! 11050: * JSR ACESS CALL TO ACCESS VALUE ! 11051: * PPM LOC TRANSFER LOC IF ACCESS FAILURE ! 11052: * (XR) VARIABLE VALUE ! 11053: * (WA,WB,WC) DESTROYED ! 11054: * (XL,RA) DESTROYED ! 11055: * ! 11056: * FAILURE CAN OCCUR IF AN INPUT ASSOCIATION CAUSES AN END ! 11057: * OF FILE CONDITION OR IF THE EVALUATION OF AN EXPRESSION ! 11058: * ASSOCIATED WITH AN EXPRESSION VARIABLE FAILS. ! 11059: * ! 11060: ACESS PRC R,1 ENTRY POINT (RECURSIVE) ! 11061: MOV XL,XR COPY NAME BASE ! 11062: ADD WA,XR POINT TO VARIABLE LOCATION ! 11063: MOV (XR),XR LOAD VARIABLE VALUE ! 11064: * ! 11065: * LOOP HERE TO CHECK FOR SUCCESSIVE TRBLKS ! 11066: * ! 11067: ACS02 BNE (XR),=B$TRT,ACS18 JUMP IF NOT TRAPPED ! 11068: * ! 11069: * HERE IF TRAPPED ! 11070: * ! 11071: BEQ XR,=TRBKV,ACS12 JUMP IF KEYWORD VARIABLE ! 11072: BNE XR,=TRBEV,ACS05 JUMP IF NOT EXPRESSION VARIABLE ! 11073: * ! 11074: * HERE FOR EXPRESSION VARIABLE, EVALUATE VARIABLE ! 11075: * ! 11076: MOV EVEXP(XL),XR LOAD EXPRESSION POINTER ! 11077: ZER WB EVALUATE BY VALUE ! 11078: JSR EVALX EVALUATE EXPRESSION ! 11079: PPM ACS04 JUMP IF EVALUATION FAILURE ! 11080: BRN ACS02 CHECK VALUE FOR MORE TRBLKS ! 11081: EJC ! 11082: * ! 11083: * ACESS (CONTINUED) ! 11084: * ! 11085: * HERE ON READING END OF FILE ! 11086: * ! 11087: ACS03 ADD *NUM03,XS POP TRBLK PTR, NAME BASE AND OFFSET ! 11088: MOV XR,DNAMP POP UNUSED SCBLK ! 11089: * ! 11090: * MERGE HERE WHEN EVALUATION OF EXPRESSION FAILS ! 11091: * ! 11092: ACS04 EXI 1 TAKE ALTERNATE (FAILURE) RETURN ! 11093: * ! 11094: * HERE IF NOT KEYWORD OR EXPRESSION VARIABLE ! 11095: * ! 11096: ACS05 MOV TRTYP(XR),WB LOAD TRAP TYPE CODE ! 11097: BNZ WB,ACS10 JUMP IF NOT INPUT ASSOCIATION ! 11098: BZE KVINP,ACS09 IGNORE INPUT ASSOC IF INPUT IS OFF ! 11099: * ! 11100: * HERE FOR INPUT ASSOCIATION ! 11101: * ! 11102: MOV XL,-(XS) STACK NAME BASE ! 11103: MOV WA,-(XS) STACK NAME OFFSET ! 11104: MOV XR,-(XS) STACK TRBLK POINTER ! 11105: MOV TRTRI(XR),XL GET TRTIO BLOCK PTR OR 0 ! 11106: BNZ XL,ACS06 JUMP IF NOT STANDARD INPUT FILE ! 11107: BEQ TRTER(XR),=V$TER,ACS21 JUMP IF TERMINAL ! 11108: * ! 11109: * HERE TO READ FROM STANDARD INPUT FILE ! 11110: * ! 11111: MOV CSWIN,WA LENGTH FOR READ BUFFER ! 11112: JSR ALOCS BUILD STRING OF APPROPRIATE LENGTH ! 11113: BZE TTINS,ACSA5 SKIP IF NOT TERML STD INPUT ! 11114: JSR SYSRI READ FROM TERMINAL ! 11115: PPM ACS03 END FILE ! 11116: PPM EROSI ERROR ! 11117: BRN ACS07 MERGE ! 11118: * ! 11119: * GENUINE STD INPUT FILE ! 11120: * ! 11121: ACSA5 JSR SYSRD READ NEXT STANDARD INPUT IMAGE ! 11122: PPM ACS03 JUMP TO FAIL EXIT IF END OF FILE ! 11123: PPM EROSI ERROR RETURN ! 11124: BRN ACS07 ELSE MERGE WITH OTHER FILE CASE ! 11125: * ! 11126: * HERE FOR INPUT FROM OTHER THAN STANDARD INPUT FILE ! 11127: * ! 11128: ACS06 MOV TRTAG(XL),WA OBTAIN IOTAG ! 11129: BZE WA,ACS03 FAIL IF ENDFILE DONE ! 11130: JSR SYSIL GET INPUT RECORD MAX LENGTH (TO WA) ! 11131: JSR ALOCS ALLOCATE STRING OF CORRECT SIZE ! 11132: MOV TRTAG(XL),WA GET IOTAG ! 11133: JSR SYSIN CALL SYSTEM INPUT ROUTINE ! 11134: PPM ACS03 JUMP TO FAIL EXIT IF END OF FILE ! 11135: PPM ACS22 ERROR RETURN ! 11136: EJC ! 11137: * ! 11138: * ACESS (CONTINUED) ! 11139: * ! 11140: * MERGE HERE AFTER OBTAINING INPUT RECORD ! 11141: * ! 11142: ACS07 MOV KVTRM,WB LOAD TRIM INDICATOR ! 11143: JSR TRIMR TRIM RECORD AS REQUIRED ! 11144: MOV XR,WB COPY RESULT POINTER ! 11145: MOV (XS),XR RELOAD POINTER TO TRBLK ! 11146: * ! 11147: * LOOP TO CHASE TO END OF TRBLK CHAIN AND STORE VALUE ! 11148: * ! 11149: ACS08 MOV XR,XL SAVE POINTER TO THIS TRBLK ! 11150: MOV TRNXT(XR),XR LOAD FORWARD POINTER ! 11151: BEQ (XR),=B$TRT,ACS08 LOOP IF THIS IS ANOTHER TRBLK ! 11152: MOV WB,TRNXT(XL) ELSE STORE RESULT AT END OF CHAIN ! 11153: MOV (XS)+,XR RESTORE INITIAL TRBLK POINTER ! 11154: MOV (XS)+,WA RESTORE NAME OFFSET ! 11155: MOV (XS)+,XL RESTORE NAME BASE POINTER ! 11156: * ! 11157: * COME HERE TO MOVE TO NEXT TRBLK ! 11158: * ! 11159: ACS09 MOV TRNXT(XR),XR LOAD FORWARD PTR TO NEXT VALUE ! 11160: BRN ACS02 BACK TO CHECK IF TRAPPED ! 11161: * ! 11162: * HERE TO CHECK FOR ACCESS TRACE TRBLK ! 11163: * ! 11164: ACS10 BNE WB,=TRTAC,ACS09 LOOP BACK IF NOT ACCESS TRACE ! 11165: BZE KVTRA,ACS09 IGNORE ACCESS TRACE IF TRACE OFF ! 11166: DCV KVTRA ELSE DECREMENT TRACE COUNT ! 11167: BZE TRFNC(XR),ACS11 JUMP IF PRINT TRACE ! 11168: EJC ! 11169: * ! 11170: * ACESS (CONTINUED) ! 11171: * ! 11172: * HERE FOR FULL FUNCTION TRACE ! 11173: * ! 11174: JSR TRXEQ CALL ROUTINE TO EXECUTE TRACE ! 11175: BRN ACS09 JUMP FOR NEXT TRBLK ! 11176: * ! 11177: * HERE FOR CASE OF PRINT TRACE ! 11178: * ! 11179: ACS11 JSR PRTSN PRINT STATEMENT NUMBER ! 11180: JSR PRTNV PRINT NAME = VALUE ! 11181: BRN ACS09 JUMP BACK FOR NEXT TRBLK ! 11182: * ! 11183: * HERE FOR KEYWORD VARIABLE ! 11184: * ! 11185: ACS12 MOV KVNUM(XL),XR LOAD KEYWORD NUMBER ! 11186: BGE XR,=K$V$$,ACS14 JUMP IF NOT ONE WORD VALUE ! 11187: MTI KVANC(XR) ELSE LOAD VALUE AS INTEGER ! 11188: * ! 11189: * COMMON EXIT WITH KEYWORD VALUE AS INTEGER IN (IA) ! 11190: * ! 11191: ACS13 JSR ICBLD BUILD ICBLK ! 11192: BRN ACS18 JUMP TO EXIT ! 11193: * ! 11194: * HERE IF NOT ONE WORD KEYWORD VALUE ! 11195: * ! 11196: ACS14 BGE XR,=K$S$$,ACS15 JUMP IF SPECIAL CASE ! 11197: SUB =K$V$$,XR ELSE GET OFFSET ! 11198: WTB XR CONVERT TO OFFSET IN BAUS ! 11199: ADD =NDABO,XR POINT TO PATTERN VALUE ! 11200: BRN ACS18 JUMP TO EXIT ! 11201: * ! 11202: * HERE IF SPECIAL KEYWORD CASE ! 11203: * ! 11204: ACS15 MOV KVRTN,XL LOAD RTNTYPE IN CASE ! 11205: LDI KVSTL LOAD STLIMIT IN CASE ! 11206: SUB =K$S$$,XR GET CASE NUMBER ! 11207: BSW XR,6 SWITCH ON KEYWORD NUMBER ! 11208: IFF K$$AL,ACS16 JUMP IF ALPHABET ! 11209: IFF K$$RT,ACS17 RTNTYPE ! 11210: IFF K$$CD,ACS23 CODE ! 11211: IFF K$$SC,ACS19 STCOUNT ! 11212: IFF K$$SL,ACS13 STLIMIT ! 11213: IFF K$$ET,ACS20 ERRTEXT ! 11214: ESW END SWITCH ON KEYWORD NUMBER ! 11215: EJC ! 11216: * ! 11217: * ACESS (CONTINUED) ! 11218: * ! 11219: * ALPHABET ! 11220: * ! 11221: ACS16 MOV KVALP,XL LOAD POINTER TO ALPHABET STRING ! 11222: * ! 11223: * RTNTYPE MERGES HERE ! 11224: * ! 11225: ACS17 MOV XL,XR COPY STRING PTR TO PROPER REG ! 11226: * ! 11227: * COMMON RETURN POINT ! 11228: * ! 11229: ACS18 EXI RETURN TO ACESS CALLER ! 11230: * ! 11231: * HERE FOR STCOUNT (IA HAS STLIMIT) ! 11232: * ! 11233: ACS19 SBI KVSTC STCOUNT = LIMIT - LEFT ! 11234: BRN ACS13 MERGE BACK WITH INTEGER RESULT ! 11235: * ! 11236: * ERRTEXT ! 11237: * ! 11238: ACS20 MOV R$ETX,XR GET ERRTEXT STRING ! 11239: BRN ACS18 MERGE WITH RESULT ! 11240: * ! 11241: * HERE TO READ A RECORD FROM TERMINAL ! 11242: * ! 11243: ACS21 MOV =RILEN,WA BUFFER LENGTH ! 11244: JSR ALOCS ALLOCATE BUFFER ! 11245: JSR SYSRI READ RECORD ! 11246: PPM ACS03 ENDFILE ! 11247: PPM EROSI ERROR RETURN ! 11248: BRN ACS07 MERGE WITH RECORD READ ! 11249: * ! 11250: * ERROR RETURN ! 11251: * ! 11252: ACS22 MOV XR,DNAMP POP UNUSED SCBLK ! 11253: BRN EROSI GENERATE ERROR MESSAGE ! 11254: * ! 11255: * ACCESS CODE KEYWORD ! 11256: * ! 11257: ACS23 LDI KVCOD GET CODE VALUE ! 11258: BRN ACS13 EXIT ! 11259: ENP END PROCEDURE ACESS ! 11260: EJC ! 11261: * ! 11262: * ACOMP -- COMPARE TWO ARITHMETIC VALUES ! 11263: * ! 11264: * 1(XS) FIRST ARGUMENT ! 11265: * 0(XS) SECOND ARGUMENT ! 11266: * JSR ACOMP CALL TO COMPARE VALUES ! 11267: * PPM LOC TRANSFER LOC IF ARG1 IS NON-NUMERIC ! 11268: * PPM LOC TRANSFER LOC IF ARG2 IS NON-NUMERIC ! 11269: * PPM LOC TRANSFER LOC FOR ARG1 LT ARG2 ! 11270: * PPM LOC TRANSFER LOC FOR ARG1 EQ ARG2 ! 11271: * PPM LOC TRANSFER LOC FOR ARG1 GT ARG2 ! 11272: * (NORMAL RETURN IS NEVER GIVEN) ! 11273: * (WA,WB,WC,IA,RA) DESTROYED ! 11274: * (XL,XR) DESTROYED ! 11275: * ! 11276: ACOMP PRC N,5 ENTRY POINT ! 11277: JSR ARITH LOAD ARITHMETIC OPERANDS ! 11278: PPM ACMP7 JUMP IF FIRST ARG NON-NUMERIC ! 11279: PPM ACMP8 JUMP IF SECOND ARG NON-NUMERIC ! 11280: .IF .CNRA ! 11281: .ELSE ! 11282: PPM ACMP4 JUMP IF REAL ARGUMENTS ! 11283: .FI ! 11284: * ! 11285: * HERE FOR INTEGER ARGUMENTS ! 11286: * ! 11287: SBI ICVAL(XL) SUBTRACT TO COMPARE ! 11288: IOV ACMP3 JUMP IF OVERFLOW ! 11289: ILT ACMP5 ELSE JUMP IF ARG1 LT ARG2 ! 11290: IEQ ACMP2 JUMP IF ARG1 EQ ARG2 ! 11291: * ! 11292: * HERE IF ARG1 GT ARG2 ! 11293: * ! 11294: ACMP1 EXI 5 TAKE GT EXIT ! 11295: * ! 11296: * HERE IF ARG1 EQ ARG2 ! 11297: * ! 11298: ACMP2 EXI 4 TAKE EQ EXIT ! 11299: EJC ! 11300: * ! 11301: * ACOMP (CONTINUED) ! 11302: * ! 11303: * HERE FOR INTEGER OVERFLOW ON SUBTRACT ! 11304: * ! 11305: ACMP3 LDI ICVAL(XL) LOAD SECOND ARGUMENT ! 11306: ILT ACMP1 GT IF NEGATIVE ! 11307: BRN ACMP5 ELSE LT ! 11308: .IF .CNRA ! 11309: .ELSE ! 11310: * ! 11311: * HERE FOR REAL OPERANDS ! 11312: * ! 11313: ACMP4 SBR RCVAL(XL) SUBTRACT TO COMPARE ! 11314: ROV ACMP6 JUMP IF OVERFLOW ! 11315: RGT ACMP1 ELSE JUMP IF ARG1 GT ! 11316: REQ ACMP2 JUMP IF ARG1 EQ ARG2 ! 11317: .FI ! 11318: * ! 11319: * HERE IF ARG1 LT ARG2 ! 11320: * ! 11321: ACMP5 EXI 3 TAKE LT EXIT ! 11322: .IF .CNRA ! 11323: .ELSE ! 11324: * ! 11325: * HERE IF OVERFLOW ON REAL SUBTRACTION ! 11326: * ! 11327: ACMP6 LDR RCVAL(XL) RELOAD ARG2 ! 11328: RLT ACMP1 GT IF NEGATIVE ! 11329: BRN ACMP5 ELSE LT ! 11330: .FI ! 11331: * ! 11332: * HERE IF ARG1 NON-NUMERIC ! 11333: * ! 11334: ACMP7 EXI 1 TAKE ERROR EXIT ! 11335: * ! 11336: * HERE IF ARG2 NON-NUMERIC ! 11337: * ! 11338: ACMP8 EXI 2 TAKE ERROR EXIT ! 11339: ENP END PROCEDURE ACOMP ! 11340: EJC ! 11341: * ! 11342: * ALLOC ALLOCATE BLOCK OF DYNAMIC STORAGE ! 11343: * ! 11344: * (WA) LENGTH REQUIRED IN BAUS ! 11345: * JSR ALLOC CALL TO ALLOCATE BLOCK ! 11346: * (XR) POINTER TO ALLOCATED BLOCK ! 11347: * ! 11348: * A POSSIBLE ALTERNATIVE TO AOV .. AND FOLLOWING STMT IS - ! 11349: * MOV DNAME,XR . SUB WA,XR . BLO XR,DNAMP,ALOC2 . ! 11350: * MOV DNAMP,XR . ADD WA,XR ! 11351: * ! 11352: ALLOC PRC E,0 ENTRY POINT ! 11353: * ! 11354: * COMMON EXIT POINT ! 11355: * ! 11356: ALOC1 MOV DNAMP,XR POINT TO NEXT AVAILABLE LOC ! 11357: AOV WA,XR,ALOC2 POINT PAST ALLOCATED BLOCK ! 11358: BGT XR,DNAME,ALOC2 JUMP IF NOT ENOUGH ROOM ! 11359: MOV XR,DNAMP STORE NEW POINTER ! 11360: SUB WA,XR POINT BACK TO START OF ALLOCATED BK ! 11361: EXI RETURN TO CALLER ! 11362: * ! 11363: * HERE IF INSUFFICIENT ROOM, TRY A GARBAGE COLLECTION ! 11364: * ! 11365: ALOC2 MOV WB,ALLSV SAVE WB ! 11366: ZER WB SET NO UPWARD MOVE FOR GBCOL ! 11367: JSR GBCOL GARBAGE COLLECT ! 11368: * ! 11369: * SEE IF ROOM AFTER GBCOL OR SYSMM CALL ! 11370: * ! 11371: ALOC3 MOV DNAMP,XR POINT TO FIRST AVAILABLE LOC ! 11372: AOV WA,XR,ALC3A POINT PAST NEW BLOCK ! 11373: BLO XR,DNAME,ALOC4 JUMP IF THERE IS ROOM NOW ! 11374: * ! 11375: * FAILED AGAIN, SEE IF WE CAN GET MORE CORE ! 11376: * ! 11377: ALC3A JSR SYSMM TRY TO GET MORE MEMORY ! 11378: WTB XR CONVERT TO BAUS ! 11379: ADD XR,DNAME BUMP PTR BY AMOUNT OBTAINED ! 11380: BNZ XR,ALOC3 JUMP IF GOT MORE CORE ! 11381: ADD RSMEM,DNAME GET THE RESERVE MEMORY ! 11382: ZER RSMEM ONLY PERMISSIBLE ONCE ! 11383: ICV ERRFT FATAL ERROR ! 11384: ERB 200,MEMORY OVERFLOW ! 11385: EJC ! 11386: * ! 11387: * HERE AFTER SUCCESSFUL GARBAGE COLLECTION ! 11388: * ! 11389: ALOC4 STI ALLIA SAVE IA ! 11390: MOV DNAME,WB GET DYNAMIC END ADRS ! 11391: SUB DNAMP,WB COMPUTE FREE STORE ! 11392: BTW WB CONVERT BAUS TO WORDS ! 11393: MTI WB PUT FREE STORE IN IA ! 11394: MLI ALFSF MULTIPLY BY FREE STORE FACTOR ! 11395: IOV ALOC5 JUMP IF OVERFLOWED ! 11396: MOV DNAME,WB DYNAMIC END ADRS ! 11397: SUB DNAMB,WB COMPUTE TOTAL AMOUNT OF DYNAMIC ! 11398: BTW WB CONVERT TO WORDS ! 11399: MOV WB,ALDYN STORE IT ! 11400: SBI ALDYN SUBTRACT FROM SCALED UP FREE STORE ! 11401: IGT ALOC5 JUMP IF SUFFICIENT FREE STORE ! 11402: JSR SYSMM TRY TO GET MORE STORE ! 11403: WTB XR CONVERT TO BAUS ! 11404: ADD XR,DNAME ADJUST DYNAMIC END ADRS ! 11405: * ! 11406: * MERGE TO RESTORE IA AND WB ! 11407: * ! 11408: ALOC5 LDI ALLIA RECOVER IA ! 11409: MOV ALLSV,WB RESTORE WB ! 11410: BRN ALOC1 JUMP BACK TO EXIT ! 11411: ENP END PROCEDURE ALLOC ! 11412: EJC ! 11413: .IF .CNBF ! 11414: .ELSE ! 11415: * ! 11416: * ALOBF -- ALLOCATE BUFFER ! 11417: * ! 11418: * THIS ROUTINES ALLOCATES A NEW BUFFER. AS THE BFBLK ! 11419: * AND BCBLK COME IN PAIRS, BOTH ARE ALLOCATED HERE, ! 11420: * AND XR POINTS TO THE BCBLK ON RETURN. THE BFBLK ! 11421: * AND BCBLK ARE SET TO THE NULL BUFFER, AND THE IDVAL ! 11422: * IS ZERO ON RETURN. ! 11423: * ! 11424: * (WA) BUFFER SIZE IN CHARACTERS ! 11425: * JSR ALOBF CALL TO CREATE BUFFER ! 11426: * (WA) 0 (INITIAL OFFSET TO BFBLK CHARS) ! 11427: * (WB) 0 (INITIAL BCLEN) ! 11428: * (XR) BCBLK PTR ! 11429: * ! 11430: ALOBF PRC E,0 ENTRY POINT ! 11431: MOV WA,WB HANG ONTO ALLOCATION SIZE ! 11432: CTB WA,BFSI$ GET TOTAL BLOCK SIZE ! 11433: BGE WA,MXLEN,ALB01 CHECK FOR MAXLEN EXCEEDED ! 11434: ADD *BCSI$,WA ADD IN ALLOCATION FOR BCBLK ! 11435: JSR ALLOC ALLOCATE FRAME ! 11436: MOV =B$BCT,(XR) SET TYPE ! 11437: ZER IDVAL(XR) NO ID YET ! 11438: ZER BCLEN(XR) NO DEFINED LENGTH ! 11439: MOV XL,WA SAVE XL ! 11440: MOV XR,XL COPY BCBLK PTR ! 11441: ADD *BCSI$,XL BIAS PAST PARTIALLY BUILT BCBLK ! 11442: MOV =B$BFT,(XL) SET BFBLK TYPE WORD ! 11443: MOV WB,BFALC(XL) SET ALLOCATED SIZE ! 11444: MOV XL,BCBUF(XR) SET POINTER IN BCBLK ! 11445: ZER WB CLEAR FOR RETURN ! 11446: MOV WB,BFCHR(XL) CLEAR FIRST WORD (NULL PAD) ! 11447: MOV WA,XL RESTORE ENTRY XL ! 11448: ZER WA CLEAR FOR RETURN ! 11449: EXI RETURN TO CALLER ! 11450: * ! 11451: * HERE FOR MXLEN EXCEEDED ! 11452: * ! 11453: ALB01 ERB 201,REQUESTED BUFFER ALLOCATION EXCEEDS MAXLNGTH ! 11454: ENP END PROCEDURE ALOBF ! 11455: EJC ! 11456: .FI ! 11457: * ! 11458: * ALOCS -- ALLOCATE STRING BLOCK ! 11459: * ! 11460: * ALOCS IS USED TO BUILD A FRAME FOR A STRING BLOCK INTO ! 11461: * WHICH THE ACTUAL CHARACTERS ARE PLACED BY THE CALLER. ! 11462: * ALL STRINGS ARE CREATED WITH A CALL TO ALOCS (THE ! 11463: * EXCEPTIONS OCCUR IN TRIMR AND S$RPL PROCEDURES). ! 11464: * ! 11465: * (WA) LENGTH OF STRING TO BE ALLOCATED ! 11466: * JSR ALOCS CALL TO ALLOCATE SCBLK ! 11467: * (XR) POINTER TO RESULTING SCBLK ! 11468: * (WA) DESTROYED ! 11469: * (WC) CHARACTER COUNT (ENTRY VALUE OF WA) ! 11470: * ! 11471: * THE RESULTING SCBLK HAS THE TYPE WORD AND THE LENGTH ! 11472: * FILLED IN AND THE LAST WORD IS CLEARED TO ZERO CHARACTERS ! 11473: * TO ENSURE CORRECT RIGHT PADDING OF THE FINAL WORD. ! 11474: * ! 11475: ALOCS PRC E,0 ENTRY POINT ! 11476: BGT WA,KVMXL,ALCS2 JUMP IF LENGTH EXCEEEDS MAXLENGTH ! 11477: MOV WA,WC ELSE COPY LENGTH ! 11478: CTB WA,SCSI$ COMPUTE LENGTH OF SCBLK IN BAUS ! 11479: MOV DNAMP,XR POINT TO NEXT AVAILABLE LOCATION ! 11480: AOV WA,XR,ALCS0 POINT PAST BLOCK ! 11481: BLO XR,DNAME,ALCS1 JUMP IF THERE IS ROOM ! 11482: * ! 11483: * INSUFFICIENT MEMORY ! 11484: * ! 11485: ALCS0 ZER XR ELSE CLEAR GARBAGE XR VALUE ! 11486: JSR ALLOC AND USE STANDARD ALLOCATOR ! 11487: ADD WA,XR POINT PAST END OF BLOCK TO MERGE ! 11488: * ! 11489: * MERGE HERE WITH XR POINTING BEYOND NEW BLOCK ! 11490: * ! 11491: ALCS1 MOV XR,DNAMP SET UPDATED STORAGE POINTER ! 11492: ZER -(XR) STORE ZERO CHARS IN LAST WORD ! 11493: DCA WA DECREMENT LENGTH ! 11494: SUB WA,XR POINT BACK TO START OF BLOCK ! 11495: MOV =B$SCL,(XR) SET TYPE WORD ! 11496: MOV WC,SCLEN(XR) STORE LENGTH IN CHARS ! 11497: EXI RETURN TO ALOCS CALLER ! 11498: * ! 11499: * COME HERE IF STRING IS TOO LONG ! 11500: * ! 11501: ALCS2 ERB 202,STRING LENGTH EXCEEDS VALUE OF MAXLNGTH KEYWORD ! 11502: ENP END PROCEDURE ALOCS ! 11503: EJC ! 11504: * ! 11505: * ALOST -- ALLOCATE SPACE IN STATIC REGION ! 11506: * ! 11507: * (WA) LENGTH REQUIRED IN BAUS ! 11508: * JSR ALOST CALL TO ALLOCATE SPACE ! 11509: * (XR) POINTER TO ALLOCATED BLOCK ! 11510: * (WB) DESTROYED ! 11511: * ! 11512: * NOTE THAT THE CODING ENSURES THAT THE RESULTING VALUE ! 11513: * OF STATE IS ALWAYS LESS THAN DNAMB. THIS FACT IS USED ! 11514: * IN TESTING A VARIABLE NAME FOR BEING IN THE STATIC REGION ! 11515: * ! 11516: ALOST PRC E,0 ENTRY POINT ! 11517: * ! 11518: * MERGE BACK HERE AFTER ALLOCATING NEW CHUNK ! 11519: * ! 11520: ALST1 MOV STATE,XR POINT TO CURRENT END OF AREA ! 11521: AOV WA,XR,ALST2 POINT BEYOND PROPOSED BLOCK ! 11522: BGE XR,DNAMB,ALST2 JUMP IF OVERLAP WITH DYNAMIC AREA ! 11523: MOV XR,STATE ELSE STORE NEW POINTER ! 11524: SUB WA,XR POINT BACK TO START OF BLOCK ! 11525: EXI RETURN TO ALOST CALLER ! 11526: * ! 11527: * HERE IF NO ROOM, PREPARE TO MOVE DYNAMIC STORAGE UP ! 11528: * ! 11529: ALST2 MOV WA,ALSTA SAVE WA ! 11530: BGE WA,*E$STS,ALST3 SKIP IF REQUESTED CHUNK IS LARGE ! 11531: MOV *E$STS,WA ELSE SET TO GET LARGE ENOUGH CHUNK ! 11532: * ! 11533: * HERE WITH AMOUNT TO MOVE UP IN WA ! 11534: * ! 11535: ALST3 JSR ALLOC ALLOCATE BLOCK TO ENSURE ROOM ! 11536: MOV XR,DNAMP AND DELETE IT ! 11537: MOV WA,WB COPY MOVE UP AMOUNT ! 11538: JSR GBCOL CALL GBCOL TO MOVE DYNAMIC AREA UP ! 11539: MOV ALSTA,WA RESTORE WA ! 11540: BRN ALST1 LOOP BACK TO TRY AGAIN ! 11541: ENP END PROCEDURE ALOST ! 11542: EJC ! 11543: * ! 11544: * ARITH -- FETCH ARITHMETIC OPERANDS ! 11545: * ! 11546: * ARITH IS USED BY FUNCTIONS AND OPERATORS WHICH EXPECT ! 11547: * TWO NUMERIC ARGUMENTS (OPERANDS) WHICH MUST BOTH BE ! 11548: * INTEGER OR BOTH BE REAL. ARITH FETCHES TWO ARGUMENTS FROM ! 11549: * THE STACK AND PERFORMS ANY NECESSARY CONVERSIONS. ! 11550: * ! 11551: * 1(XS) FIRST ARGUMENT (LEFT OPERAND) ! 11552: * 0(XS) SECOND ARGUMENT (RIGHT OPERAND) ! 11553: * JSR ARITH CALL TO FETCH NUMERIC ARGUMENTS ! 11554: * PPM LOC TRANSFER LOC FOR OPND 1 NON-NUMERIC ! 11555: * PPM LOC TRANSFER LOC FOR OPND 2 NON-NUMERIC ! 11556: .IF .CNRA ! 11557: .ELSE ! 11558: * PPM LOC TRANSFER LOC FOR REAL OPERANDS ! 11559: .FI ! 11560: * ! 11561: * FOR INTEGER ARGS, CONTROL RETURNS PAST THE PARAMETERS ! 11562: * ! 11563: * (IA) LEFT OPERAND VALUE ! 11564: * (XR) PTR TO ICBLK FOR LEFT OPERAND ! 11565: * (XL) PTR TO ICBLK FOR RIGHT OPERAND ! 11566: * (XS) POPPED TWICE ! 11567: * (WA,WB,RA) DESTROYED ! 11568: .IF .CNRA ! 11569: .ELSE ! 11570: * ! 11571: * FOR REAL ARGUMENTS, CONTROL RETURNS TO THE LOCATION ! 11572: * SPECIFIED BY THE THIRD PARAMETER. ! 11573: * ! 11574: * (RA) LEFT OPERAND VALUE ! 11575: * (XR) PTR TO RCBLK FOR LEFT OPERAND ! 11576: * (XL) PTR TO RCBLK FOR RIGHT OPERAND ! 11577: * (WA,WB,WC) DESTROYED ! 11578: * (XS) POPPED TWICE ! 11579: .FI ! 11580: EJC ! 11581: * ! 11582: * ARITH (CONTINUED) ! 11583: * ! 11584: * ENTRY POINT ! 11585: * ! 11586: .IF .CNRA ! 11587: ARITH PRC N,2 ENTRY POINT ! 11588: .ELSE ! 11589: ARITH PRC N,3 ENTRY POINT ! 11590: .FI ! 11591: MOV (XS)+,XL LOAD RIGHT OPERAND ! 11592: MOV (XS)+,XR LOAD LEFT OPERAND ! 11593: MOV (XL),WA GET RIGHT OPERAND TYPE WORD ! 11594: BEQ WA,=B$ICL,ARTH1 JUMP IF INTEGER ! 11595: .IF .CNRA ! 11596: .ELSE ! 11597: BEQ WA,=B$RCL,ARTH4 JUMP IF REAL ! 11598: .FI ! 11599: MOV XR,-(XS) ELSE REPLACE LEFT ARG ON STACK ! 11600: MOV XL,XR COPY LEFT ARG POINTER ! 11601: JSR GTNUM CONVERT TO NUMERIC ! 11602: PPM ARTH6 JUMP IF UNCONVERTIBLE ! 11603: MOV XR,XL ELSE COPY CONVERTED RESULT ! 11604: MOV (XL),WA GET RIGHT OPERAND TYPE WORD ! 11605: MOV (XS)+,XR RELOAD LEFT ARGUMENT ! 11606: .IF .CNRA ! 11607: .ELSE ! 11608: BEQ WA,=B$RCL,ARTH4 JUMP IF RIGHT ARG IS REAL ! 11609: .FI ! 11610: * ! 11611: * HERE IF RIGHT ARG IS AN INTEGER ! 11612: * ! 11613: ARTH1 BNE (XR),=B$ICL,ARTH3 JUMP IF LEFT ARG NOT INTEGER ! 11614: * ! 11615: * EXIT FOR INTEGER CASE ! 11616: * ! 11617: ARTH2 LDI ICVAL(XR) LOAD LEFT OPERAND VALUE ! 11618: EXI RETURN TO ARITH CALLER ! 11619: * ! 11620: * HERE FOR RIGHT OPERAND INTEGER, LEFT OPERAND NOT ! 11621: * ! 11622: ARTH3 JSR GTNUM CONVERT LEFT ARG TO NUMERIC ! 11623: PPM ARTH7 JUMP IF NOT CONVERTIBLE ! 11624: BEQ WA,=B$ICL,ARTH2 JUMP BACK IF INTEGER-INTEGER ! 11625: .IF .CNRA ! 11626: .ELSE ! 11627: * ! 11628: * HERE WE MUST CONVERT REAL-INTEGER TO REAL-REAL ! 11629: * ! 11630: MOV XR,-(XS) PUT LEFT ARG BACK ON STACK ! 11631: LDI ICVAL(XL) LOAD RIGHT ARGUMENT VALUE ! 11632: ITR CONVERT TO REAL ! 11633: JSR RCBLD GET REAL BLOCK FOR RIGHT ARG, MERGE ! 11634: MOV XR,XL COPY RIGHT ARG PTR ! 11635: MOV (XS)+,XR LOAD LEFT ARGUMENT ! 11636: BRN ARTH5 MERGE FOR REAL-REAL CASE ! 11637: EJC ! 11638: * ! 11639: * ARITH (CONTINUED) ! 11640: * ! 11641: * HERE IF RIGHT ARGUMENT IS REAL ! 11642: * ! 11643: ARTH4 BEQ (XR),=B$RCL,ARTH5 JUMP IF LEFT ARG REAL ! 11644: JSR GTREA ELSE CONVERT TO REAL ! 11645: PPM ARTH7 ERROR IF UNCONVERTIBLE ! 11646: * ! 11647: * HERE FOR REAL-REAL ! 11648: * ! 11649: ARTH5 LDR RCVAL(XR) LOAD LEFT OPERAND VALUE ! 11650: EXI 3 TAKE REAL-REAL EXIT ! 11651: .FI ! 11652: * ! 11653: * HERE FOR ERROR CONVERTING RIGHT ARGUMENT ! 11654: * ! 11655: ARTH6 ICA XS POP UNWANTED LEFT ARG ! 11656: EXI 2 TAKE APPROPRIATE ERROR EXIT ! 11657: * ! 11658: * HERE FOR ERROR CONVERTING LEFT OPERAND ! 11659: * ! 11660: ARTH7 EXI 1 TAKE APPROPRIATE ERROR RETURN ! 11661: ENP END PROCEDURE ARITH ! 11662: EJC ! 11663: * ! 11664: * ASIGN -- PERFORM ASSIGNMENT ! 11665: * ! 11666: * ASIGN PERFORMS THE ASSIGNMENT OF A VALUE TO A VARIABLE ! 11667: * WITH APPROPRIATE CHECKS FOR OUTPUT ASSOCIATIONS AND ! 11668: * VALUE TRACE ASSOCIATIONS WHICH ARE EXECUTED AS REQUIRED. ! 11669: * ASIGN ALSO HANDLES THE SPECIAL CASES OF ASSIGNMENT TO ! 11670: * PATTERN AND EXPRESSION VARIABLES. ! 11671: * ! 11672: * (WB) VALUE TO BE ASSIGNED ! 11673: * (XL) BASE POINTER FOR VARIABLE ! 11674: * (WA) OFFSET FOR VARIABLE ! 11675: * JSR ASIGN CALL TO ASSIGN VALUE TO VARIABLE ! 11676: * PPM LOC TRANSFER LOC FOR FAILURE ! 11677: * (XR,XL,WA,WB,WC) DESTROYED ! 11678: * (RA) DESTROYED ! 11679: * ! 11680: * FAILURE OCCURS IF THE EVALUATION OF AN EXPRESSION ! 11681: * ASSOCIATED WITH AN EXPRESSION VARIABLE FAILS. ! 11682: * ! 11683: ASIGN PRC R,1 ENTRY POINT (RECURSIVE) ! 11684: * ! 11685: * MERGE BACK HERE TO ASSIGN RESULT TO EXPRESSION VARIABLE. ! 11686: * ! 11687: ASG01 ADD WA,XL POINT TO VARIABLE VALUE ! 11688: MOV (XL),XR LOAD VARIABLE VALUE ! 11689: BEQ (XR),=B$TRT,ASG02 JUMP IF TRAPPED ! 11690: MOV WB,(XL) ELSE PERFORM ASSIGNMENT ! 11691: ZER XL CLEAR GARBAGE VALUE IN XL ! 11692: EXI AND RETURN TO ASIGN CALLER ! 11693: * ! 11694: * HERE IF VALUE IS TRAPPED ! 11695: * ! 11696: ASG02 SUB WA,XL RESTORE NAME BASE ! 11697: BEQ XR,=TRBKV,ASG14 JUMP IF KEYWORD VARIABLE ! 11698: BNE XR,=TRBEV,ASG04 JUMP IF NOT EXPRESSION VARIABLE ! 11699: * ! 11700: * HERE FOR ASSIGNMENT TO EXPRESSION VARIABLE ! 11701: * ! 11702: MOV EVEXP(XL),XR POINT TO EXPRESSION ! 11703: MOV WB,-(XS) STORE VALUE TO ASSIGN ON STACK ! 11704: MOV =NUM01,WB SET FOR EVALUATION BY NAME ! 11705: JSR EVALX EVALUATE EXPRESSION BY NAME ! 11706: PPM ASG03 JUMP IF EVALUATION FAILS ! 11707: MOV (XS)+,WB ELSE RELOAD VALUE TO ASSIGN ! 11708: BRN ASG01 LOOP BACK TO PERFORM ASSIGNMENT ! 11709: EJC ! 11710: * ! 11711: * ASIGN (CONTINUED) ! 11712: * ! 11713: * HERE FOR FAILURE RETURNS ! 11714: * ! 11715: ASG03 ICA XS REMOVE STACKED VALUE ENTRY ! 11716: * ! 11717: ASG3A EXI 1 TAKE FAILURE EXIT ! 11718: * ! 11719: * HERE IF NOT KEYWORD OR EXPRESSION VARIABLE ! 11720: * ! 11721: ASG04 MOV XR,-(XS) SAVE PTR TO FIRST TRBLK ! 11722: * ! 11723: * LOOP TO CHASE DOWN TRBLK CHAIN AND ASSIGN VALUE AT END ! 11724: * ! 11725: ASG05 MOV XR,WC SAVE PTR TO THIS TRBLK ! 11726: MOV TRNXT(XR),XR POINT TO NEXT TRBLK ! 11727: BEQ (XR),=B$TRT,ASG05 LOOP BACK IF ANOTHER TRBLK ! 11728: MOV WC,XR ELSE POINT BACK TO LAST TRBLK ! 11729: MOV WB,TRVAL(XR) STORE VALUE AT END OF CHAIN ! 11730: MOV (XS)+,XR RESTORE PTR TO FIRST TRBLK ! 11731: * ! 11732: * LOOP TO PROCESS TRBLK ENTRIES ON CHAIN ! 11733: * ! 11734: ASG06 MOV TRTYP(XR),WB LOAD TYPE CODE OF TRBLK ! 11735: BEQ WB,=TRTVL,ASG08 JUMP IF VALUE TRACE ! 11736: BEQ WB,=TRTOU,ASG10 JUMP IF OUTPUT ASSOCIATION ! 11737: * ! 11738: * HERE TO MOVE TO NEXT TRBLK ON CHAIN ! 11739: * ! 11740: ASG07 MOV TRNXT(XR),XR POINT TO NEXT TRBLK ON CHAIN ! 11741: BEQ (XR),=B$TRT,ASG06 LOOP BACK IF ANOTHER TRBLK ! 11742: EXI ELSE END OF CHAIN, RETURN TO CALLER ! 11743: * ! 11744: * HERE TO PROCESS VALUE TRACE ! 11745: * ! 11746: ASG08 BZE KVTRA,ASG07 IGNORE VALUE TRACE IF TRACE OFF ! 11747: DCV KVTRA ELSE DECREMENT TRACE COUNT ! 11748: BZE TRFNC(XR),ASG09 JUMP IF PRINT TRACE ! 11749: JSR TRXEQ ELSE EXECUTE FUNCTION TRACE ! 11750: BRN ASG07 AND LOOP BACK ! 11751: EJC ! 11752: * ! 11753: * ASIGN (CONTINUED) ! 11754: * ! 11755: * HERE FOR PRINT TRACE ! 11756: * ! 11757: ASG09 JSR PRTSN PRINT STATEMENT NUMBER ! 11758: JSR PRTNV PRINT NAME = VALUE ! 11759: BRN ASG07 LOOP BACK FOR NEXT TRBLK ! 11760: * ! 11761: * HERE FOR OUTPUT ASSOCIATION ! 11762: * ! 11763: ASG10 BZE KVOUP,ASG07 IGNORE OUTPUT ASSOC IF OUTPUT OFF ! 11764: MOV XR,XL ELSE COPY TRBLK POINTER ! 11765: MOV TRVAL(XR),-(XS) STACK VALUE TO OUTPUT ! 11766: JSR GTSTG CONVERT TO STRING ! 11767: PPM ASG12 GET DATATYPE NAME IF UNCONVERTIBLE ! 11768: * ! 11769: * MERGE WITH STRING FOR OUTPUT ! 11770: * ! 11771: ASG11 MOV TRTRI(XL),WA TRTIO BLK PTR ! 11772: BZE WA,ASG13 JUMP IF STANDARD OUTPUT FILE ! 11773: * ! 11774: * HERE FOR OUTPUT TO NON-STANDARD OUTPUT FILE ! 11775: * ! 11776: MOV WA,XL COPY TRTIO BLOCK PTR TO XL ! 11777: MOV TRTAG(XL),WA GET IOTAG ! 11778: BZE WA,ASG3A FAIL IF ENDFILE DONE ! 11779: MOV SCLEN(XR),WC STRING LENGTH ! 11780: JSR SYSOU CALL SYSTEM OUTPUT ROUTINE ! 11781: PPM ASG3A FAIL RETURN ! 11782: PPM EROSI ERROR RETURN ! 11783: EXI ELSE ALL DONE, RETURN TO CALLER ! 11784: * ! 11785: * IF NOT PRINTABLE, GET DATATYPE NAME INSTEAD ! 11786: * ! 11787: ASG12 JSR DTYPE CALL DATATYPE ROUTINE ! 11788: BRN ASG11 MERGE ! 11789: * ! 11790: * HERE TO PRINT A STRING ! 11791: * ! 11792: ASG13 BEQ TRTER(XL),=V$TER,ASG20 JUMP IF TERMINAL OUTPUT ! 11793: JSR PRTSF PRINT STRING AND FLUSH BUFFER ! 11794: EXI RETURN TO CALLER ! 11795: EJC ! 11796: * ! 11797: * ASIGN (CONTINUED) ! 11798: * ! 11799: * HERE FOR KEYWORD ASSIGNMENT ! 11800: * ! 11801: ASG14 MOV KVNUM(XL),XL LOAD KEYWORD NUMBER ! 11802: BEQ XL,=K$ETX,ASG19 JUMP IF ERRTEXT ! 11803: MOV WB,XR COPY VALUE TO BE ASSIGNED ! 11804: JSR GTINT CONVERT TO INTEGER ! 11805: ERR 203,KEYWORD VALUE ASSIGNED IS NOT INTEGER ! 11806: LDI ICVAL(XR) ELSE LOAD VALUE ! 11807: BEQ XL,=K$STL,ASG16 JUMP IF SPECIAL CASE OF STLIMIT ! 11808: BEQ XL,=K$COD,ASG24 JUMP IF SPECIAL CASE OF CODE ! 11809: MFI WA,ASG18 ELSE GET ADDR INTEGER, TEST OVFLOW ! 11810: BGE WA,MXLEN,ASG18 FAIL IF TOO LARGE ! 11811: BEQ XL,=K$ERT,ASG17 JUMP IF SPECIAL CASE OF ERRTYPE ! 11812: .IF .CNPF ! 11813: .ELSE ! 11814: BEQ XL,=K$PFL,ASG21 JUMP IF SPECIAL CASE OF PROFILE ! 11815: .FI ! 11816: BLT XL,=K$P$$,ASG15 JUMP UNLESS PROTECTED ! 11817: ERB 204,KEYWORD IN ASSIGNMENT IS PROTECTED ! 11818: * ! 11819: * HERE TO DO ASSIGNMENT IF NOT PROTECTED ! 11820: * ! 11821: ASG15 MOV WA,KVANC(XL) STORE NEW VALUE ! 11822: EXI RETURN TO ASIGN CALLER ! 11823: * ! 11824: * HERE FOR SPECIAL CASE OF STLIMIT ! 11825: * ! 11826: * SINCE STCOUNT IS MAINTAINED AS (STLIMIT-STCOUNT) ! 11827: * IT IS ALSO NECESSARY TO MODIFY STCOUNT APPROPRIATELY. ! 11828: * ! 11829: ASG16 SBI KVSTL SUBTRACT OLD LIMIT ! 11830: ADI KVSTC ADD OLD COUNTER ! 11831: STI KVSTC STORE NEW COUNTER VALUE ! 11832: LDI ICVAL(XR) RELOAD NEW LIMIT VALUE ! 11833: STI KVSTL STORE NEW LIMIT VALUE ! 11834: EXI RETURN TO ASIGN CALLER ! 11835: EJC ! 11836: * ! 11837: * ASIGN (CONTINUED) ! 11838: * ! 11839: * HERE FOR SPECIAL CASE OF ERRTYPE ! 11840: * ! 11841: ASG17 BLE WA,=NINI9,ERROR OK TO SIGNAL IF IN RANGE ! 11842: * ! 11843: * HERE IF VALUE ASSIGNED IS OUT OF RANGE ! 11844: * ! 11845: ASG18 ERB 205,KEYWORD VALUE ASSIGNED IS NEGATIVE OR TOO LARGE ! 11846: * ! 11847: * HERE FOR SPECIAL CASE OF ERRTEXT ! 11848: * ! 11849: ASG19 MOV WB,-(XS) STACK VALUE ! 11850: JSR GTSTG CONVERT TO STRING ! 11851: ERR 206,VALUE ASSIGNED TO KEYWORD ERRTEXT NOT A STRING ! 11852: MOV XR,R$ETX MAKE ASSIGNMENT ! 11853: EXI RETURN TO CALLER ! 11854: * ! 11855: * PRINT STRING TO TERMINAL ! 11856: * ! 11857: ASG20 JSR PTTST PRINT STRING TO TERMINAL ! 11858: JSR PTTFH FLUSH TERMINAL BUFFER ! 11859: EXI RETURN ! 11860: .IF .CNPF ! 11861: .ELSE ! 11862: * HERE FOR KEYWORD PROFILE ! 11863: * ! 11864: ASG21 BGT WA,=NUM02,ASG18 MOAN IF NOT 0,1, OR 2 ! 11865: BZE WA,ASG15 JUST ASSIGN IF ZERO ! 11866: BZE PFDMP,ASG22 BRANCH IF FIRST ASSIGNMENT ! 11867: BEQ WA,PFDMP,ASG23 ALSO IF SAME VALUE AS BEFORE ! 11868: ERB 207,INCONSISTENT VALUE ASSIGNED TO KEYWORD PROFILE ! 11869: * ! 11870: ASG22 MOV WA,PFDMP NOTE VALUE ON FIRST ASSIGNMENT ! 11871: ASG23 JSR SYSTM GET THE TIME ! 11872: STI PFSTM FUDGE SOME KIND OF START TIME ! 11873: BRN ASG15 AND GO ASSIGN ! 11874: .FI ! 11875: * ! 11876: * HERE FOR KEYWORD ASSIGNMENT TO CODE ! 11877: * ! 11878: ASG24 STI KVCOD STORE VALUE ! 11879: EXI RETURN TO CALLER ! 11880: ENP END PROCEDURE ASIGN ! 11881: EJC ! 11882: * ! 11883: * ASINP -- ASSIGN DURING PATTERN MATCH ! 11884: * ! 11885: * ASINP IS LIKE ASIGN AND HAS A SIMILAR CALLING SEQUENCE ! 11886: * AND EFFECT. THE DIFFERENCE IS THAT THE GLOBAL PATTERN ! 11887: * VARIABLES ARE SAVED AND RESTORED IF REQUIRED. ! 11888: * ! 11889: * (XL) BASE POINTER FOR VARIABLE ! 11890: * (WA) OFFSET FOR VARIABLE ! 11891: * (WB) VALUE TO BE ASSIGNED ! 11892: * JSR ASINP CALL TO ASSIGN VALUE TO VARIABLE ! 11893: * PPM LOC TRANSFER LOC IF FAILURE ! 11894: * (XR,XL) DESTROYED ! 11895: * (WA,WB,WC,RA) DESTROYED ! 11896: * ! 11897: ASINP PRC R,1 ENTRY POINT, RECURSIVE ! 11898: ADD WA,XL POINT TO VARIABLE ! 11899: MOV (XL),XR LOAD CURRENT CONTENTS ! 11900: BEQ (XR),=B$TRT,ASNP1 JUMP IF TRAPPED ! 11901: MOV WB,(XL) ELSE PERFORM ASSIGNMENT ! 11902: ZER XL CLEAR GARBAGE VALUE IN XL ! 11903: EXI RETURN TO ASINP CALLER ! 11904: * ! 11905: * HERE IF VARIABLE IS TRAPPED ! 11906: * ! 11907: ASNP1 SUB WA,XL RESTORE BASE POINTER ! 11908: MOV PMSSL,-(XS) STACK SUBJECT STRING LENGTH ! 11909: MOV PMHBS,-(XS) STACK HISTORY STACK BASE PTR ! 11910: MOV R$PMS,-(XS) STACK SUBJECT STRING POINTER ! 11911: MOV PMDFL,-(XS) STACK DOT FLAG ! 11912: JSR ASIGN CALL FULL-BLOWN ASSIGNMENT ROUTINE ! 11913: PPM ASNP2 JUMP IF FAILURE ! 11914: MOV (XS)+,PMDFL RESTORE DOT FLAG ! 11915: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER ! 11916: MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER ! 11917: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH ! 11918: EXI RETURN TO ASINP CALLER ! 11919: * ! 11920: * HERE IF FAILURE IN ASIGN CALL ! 11921: * ! 11922: ASNP2 MOV (XS)+,PMDFL RESTORE DOT FLAG ! 11923: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER ! 11924: MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER ! 11925: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH ! 11926: EXI 1 TAKE FAILURE EXIT ! 11927: ENP END PROCEDURE ASINP ! 11928: EJC ! 11929: * ! 11930: * BLKLN -- DETERMINE LENGTH OF BLOCK ! 11931: * ! 11932: * BLKLN DETERMINES THE LENGTH OF A BLOCK IN DYNAMIC STORE. ! 11933: * ! 11934: * (WA) FIRST WORD OF BLOCK ! 11935: * (XR) POINTER TO BLOCK ! 11936: * JSR BLKLN CALL TO GET BLOCK LENGTH ! 11937: * (WA) LENGTH OF BLOCK IN BAUS ! 11938: * (XL) DESTROYED ! 11939: * ! 11940: * BLKLN IS USED BY THE GARBAGE COLLECTOR AND IS NOT ! 11941: * PERMITTED TO CALL GBCOL DIRECTLY OR INDIRECTLY. ! 11942: * ! 11943: * THE FIRST WORD STORED IN THE BLOCK (I.E. AT XR) MAY ! 11944: * BE ANYTHING, BUT THE CONTENTS OF WA MUST BE CORRECT. ! 11945: * ! 11946: BLKLN PRC E,0 ENTRY POINT ! 11947: MOV WA,XL COPY FIRST WORD ! 11948: LEI XL GET ENTRY ID (BL$XX) ! 11949: BSW XL,BL$$$,BLN00 SWITCH ON BLOCK TYPE ! 11950: IFF BL$AR,BLN01 ARBLK ! 11951: IFF BL$CD,BLN01 CDBLK ! 11952: IFF BL$CO,BLN12 COBLK ! 11953: IFF BL$DF,BLN01 DFBLK ! 11954: IFF BL$EF,BLN01 EFBLK ! 11955: IFF BL$EX,BLN01 EXBLK ! 11956: IFF BL$PF,BLN01 PFBLK ! 11957: IFF BL$TB,BLN01 TBBLK ! 11958: IFF BL$VC,BLN01 VCBLK ! 11959: IFF BL$EV,BLN03 EVBLK ! 11960: IFF BL$KV,BLN03 KVBLK ! 11961: IFF BL$P0,BLN02 P0BLK ! 11962: IFF BL$SE,BLN02 SEBLK ! 11963: IFF BL$NM,BLN03 NMBLK ! 11964: IFF BL$P1,BLN03 P1BLK ! 11965: IFF BL$P2,BLN04 P2BLK ! 11966: IFF BL$TE,BLN04 TEBLK ! 11967: IFF BL$FF,BLN05 FFBLK ! 11968: IFF BL$TR,BLN05 TRBLK ! 11969: IFF BL$CT,BLN06 CTBLK ! 11970: IFF BL$IC,BLN07 ICBLK ! 11971: IFF BL$PD,BLN08 PDBLK ! 11972: .IF .CNBF ! 11973: .ELSE ! 11974: IFF BL$BC,BLN04 BCBLK ! 11975: IFF BL$BF,BLN11 BFBLK ! 11976: .FI ! 11977: .IF .CNRA ! 11978: .ELSE ! 11979: IFF BL$RC,BLN09 RCBLK ! 11980: .FI ! 11981: IFF BL$SC,BLN10 SCBLK ! 11982: ESW END OF JUMP TABLE ON BLOCK TYPE ! 11983: EJC ! 11984: * ! 11985: * BLKLN (CONTINUED) ! 11986: * ! 11987: * HERE FOR BLOCKS WITH LENGTH IN SECOND WORD ! 11988: * ! 11989: BLN00 MOV 1(XR),WA LOAD LENGTH ! 11990: EXI RETURN TO BLKLN CALLER ! 11991: * ! 11992: * HERE FOR LENGTH IN THIRD WORD (AR,CD,DF,EF,EX,PF,TB,VC) ! 11993: * ! 11994: BLN01 MOV 2(XR),WA LOAD LENGTH FROM THIRD WORD ! 11995: EXI RETURN TO BLKLN CALLER ! 11996: * ! 11997: * HERE FOR TWO WORD BLOCKS (P0,SE) ! 11998: * ! 11999: BLN02 MOV *NUM02,WA LOAD LENGTH (TWO WORDS) ! 12000: EXI RETURN TO BLKLN CALLER ! 12001: * ! 12002: * HERE FOR THREE WORD BLOCKS (NM,P1,EV,KV) ! 12003: * ! 12004: BLN03 MOV *NUM03,WA LOAD LENGTH (THREE WORDS) ! 12005: EXI RETURN TO BLKLN CALLER ! 12006: * ! 12007: * HERE FOR FOUR WORD BLOCKS (P2,TE) ! 12008: * ! 12009: BLN04 MOV *NUM04,WA LOAD LENGTH (FOUR WORDS) ! 12010: EXI RETURN TO BLKLN CALLER ! 12011: * ! 12012: * HERE FOR FIVE WORD BLOCKS (FF,TR) ! 12013: * ! 12014: BLN05 MOV *NUM05,WA LOAD LENGTH ! 12015: EXI RETURN TO BLKLN CALLER ! 12016: EJC ! 12017: * ! 12018: * BLKLN (CONTINUED) ! 12019: * ! 12020: * HERE FOR CTBLK ! 12021: * ! 12022: BLN06 MOV *CTSI$,WA SET SIZE OF CTBLK ! 12023: EXI RETURN TO BLKLN CALLER ! 12024: * ! 12025: * HERE FOR ICBLK ! 12026: * ! 12027: BLN07 MOV *ICSI$,WA SET SIZE OF ICBLK ! 12028: EXI RETURN TO BLKLN CALLER ! 12029: * ! 12030: * HERE FOR PDBLK ! 12031: * ! 12032: BLN08 MOV PDDFP(XR),XL POINT TO DFBLK ! 12033: MOV DFPDL(XL),WA LOAD PDBLK LENGTH FROM DFBLK ! 12034: EXI RETURN TO BLKLN CALLER ! 12035: .IF .CNRA ! 12036: .ELSE ! 12037: * ! 12038: * HERE FOR RCBLK ! 12039: * ! 12040: BLN09 MOV *RCSI$,WA SET SIZE OF RCBLK ! 12041: EXI RETURN TO BLKLN CALLER ! 12042: .FI ! 12043: * ! 12044: * HERE FOR SCBLK ! 12045: * ! 12046: BLN10 MOV SCLEN(XR),WA LOAD LENGTH IN CHARACTERS ! 12047: CTB WA,SCSI$ CALCULATE LENGTH IN BAUS ! 12048: EXI RETURN TO BLKLN CALLER ! 12049: .IF .CNBF ! 12050: .ELSE ! 12051: * ! 12052: * HERE FOR BFBLK ! 12053: * ! 12054: BLN11 MOV BFALC(XR),WA GET ALLOCATION IN BAUS ! 12055: CTB WA,BFSI$ CALCULATE LENGTH IN BAUS ! 12056: EXI RETURN TO BLKLN CALLER ! 12057: .FI ! 12058: * ! 12059: * HERE FOR COBLK ! 12060: * ! 12061: BLN12 MOV *COSI$,WA GET SIZE IN BAUS ! 12062: EXI RETURN TO BLKLN CALLER ! 12063: ENP END PROCEDURE BLKLN ! 12064: EJC ! 12065: * ! 12066: * CBLCK -- COPY A BLOCK ! 12067: * ! 12068: * (XS) BLOCK TO BE COPIED ! 12069: * JSR CBLCK CALL TO COPY BLOCK ! 12070: * PPM LOC RETURN IF BLOCK HAS NO IDVAL FIELD ! 12071: * NORMAL RETURN IF IDVAL FIELD ! 12072: * (XR) COPY OF BLOCK ! 12073: * (XS) POPPED ! 12074: * (XL,WA,WB,WC) DESTROYED ! 12075: * ! 12076: CBLCK PRC N,1 ENTRY POINT ! 12077: MOV (XS),XR LOAD ARGUMENT ! 12078: BEQ XR,=NULLS,CBL10 RETURN ARGUMENT IF IT IS NULL ! 12079: MOV (XR),WA ELSE LOAD TYPE WORD ! 12080: MOV WA,WB COPY TYPE WORD ! 12081: JSR BLKLN GET LENGTH OF ARGUMENT BLOCK ! 12082: MOV XR,XL COPY POINTER ! 12083: JSR ALLOC ALLOCATE BLOCK OF SAME SIZE ! 12084: MOV XR,(XS) STORE POINTER TO COPY ! 12085: MVW COPY CONTENTS OF OLD BLOCK TO NEW ! 12086: MOV (XS),XR RELOAD POINTER TO START OF COPY ! 12087: BEQ WB,=B$TBT,CBL05 JUMP IF TABLE ! 12088: BEQ WB,=B$VCT,CBL01 JUMP IF VECTOR ! 12089: BEQ WB,=B$PDT,CBL01 JUMP IF PROGRAM DEFINED ! 12090: .IF .CNBF ! 12091: .ELSE ! 12092: BEQ WB,=B$BCT,CBL11 JUMP IF BUFFER ! 12093: .FI ! 12094: BNE WB,=B$ART,CBL10 RETURN COPY IF NOT ARRAY ! 12095: * ! 12096: * HERE FOR ARRAY (ARBLK) ! 12097: * ! 12098: ADD AROFS(XR),XR POINT TO PROTOTYPE FIELD ! 12099: BRN CBL02 JUMP TO MERGE ! 12100: * ! 12101: * HERE FOR VECTOR, PROGRAM DEFINED ! 12102: * ! 12103: CBL01 ADD *PDFLD,XR POINT TO PDFLD = VCVLS ! 12104: * ! 12105: * MERGE HERE FOR ARBLK, VCBLK, PDBLK TO DELETE TRAP ! 12106: * BLOCKS FROM ALL VALUE FIELDS (THE COPY IS UNTRAPPED) ! 12107: * ! 12108: CBL02 MOV (XR),XL LOAD NEXT POINTER ! 12109: * ! 12110: * LOOP TO GET VALUE AT END OF TRBLK CHAIN ! 12111: * ! 12112: CBL03 BNE (XL),=B$TRT,CBL04 JUMP IF NOT TRAPPED ! 12113: MOV TRVAL(XL),XL ELSE POINT TO NEXT VALUE ! 12114: BRN CBL03 AND LOOP BACK ! 12115: EJC ! 12116: * ! 12117: * CBLCK (CONTINUED) ! 12118: * ! 12119: * HERE WITH UNTRAPPED VALUE IN XL ! 12120: * ! 12121: CBL04 MOV XL,(XR)+ STORE REAL VALUE, BUMP POINTER ! 12122: BNE XR,DNAMP,CBL02 LOOP BACK IF MORE TO GO ! 12123: BRN CBL09 ELSE JUMP TO EXIT ! 12124: * ! 12125: * HERE TO COPY A TABLE ! 12126: * ! 12127: CBL05 ZER IDVAL(XR) ZERO ID TO STOP DUMP BLOWING UP ! 12128: MOV *TESI$,WA SET SIZE OF TEBLK ! 12129: MOV *TBBUK,WC SET INITIAL OFFSET ! 12130: * ! 12131: * LOOP THROUGH BUCKETS IN TABLE ! 12132: * ! 12133: CBL06 MOV (XS),XR LOAD TABLE POINTER ! 12134: BEQ WC,TBLEN(XR),CBL09 JUMP TO EXIT IF ALL DONE ! 12135: ADD WC,XR ELSE POINT TO NEXT BUCKET HEADER ! 12136: ICA WC BUMP OFFSET ! 12137: SUB *TENXT,XR SUBTRACT LINK OFFSET TO MERGE ! 12138: * ! 12139: * LOOP THROUGH TEBLKS ON ONE CHAIN ! 12140: * ! 12141: CBL07 MOV TENXT(XR),XL LOAD POINTER TO NEXT TEBLK ! 12142: MOV (XS),TENXT(XR) SET END OF CHAIN POINTER IN CASE ! 12143: BEQ (XL),=B$TBT,CBL06 BACK FOR NEXT BUCKET IF CHAIN END ! 12144: MOV XR,-(XS) ELSE STACK PTR TO PREVIOUS BLOCK ! 12145: MOV *TESI$,WA SET SIZE OF TEBLK ! 12146: JSR ALLOC ALLOCATE NEW TEBLK ! 12147: MOV XR,WB SAVE PTR TO NEW TEBLK ! 12148: MVW COPY OLD TEBLK TO NEW TEBLK ! 12149: MOV WB,XR RESTORE POINTER TO NEW TEBLK ! 12150: MOV (XS)+,XL RESTORE POINTER TO PREVIOUS BLOCK ! 12151: MOV XR,TENXT(XL) LINK NEW BLOCK TO PREVIOUS ! 12152: MOV XR,XL COPY POINTER TO NEW BLOCK ! 12153: * ! 12154: * LOOP TO SET REAL VALUE AFTER REMOVING TRAP CHAIN ! 12155: * ! 12156: CBL08 MOV TEVAL(XL),XL LOAD VALUE ! 12157: BEQ (XL),=B$TRT,CBL08 LOOP BACK IF TRAPPED ! 12158: MOV XL,TEVAL(XR) STORE UNTRAPPED VALUE IN TEBLK ! 12159: BRN CBL07 BACK FOR NEXT TEBLK ! 12160: * ! 12161: * COMMON EXIT POINT ! 12162: * ! 12163: CBL09 MOV (XS)+,XR LOAD POINTER TO BLOCK ! 12164: EXI RETURN ! 12165: * ! 12166: * ALTERNATIVE RETURN ! 12167: * ! 12168: CBL10 EXI 1 RETURN ! 12169: .IF .CNBF ! 12170: .ELSE ! 12171: EJC ! 12172: * ! 12173: * HERE TO COPY BUFFER ! 12174: * ! 12175: CBL11 MOV BCBUF(XR),XL GET BFBLK PTR ! 12176: MOV BFALC(XL),WA GET ALLOCATION ! 12177: CTB WA,BFSI$ SET TOTAL SIZE ! 12178: MOV XR,XL SAVE BCBLK PTR ! 12179: JSR ALLOC ALLOCATE BFBLK ! 12180: MOV BCBUF(XL),WB GET OLD BFBLK ! 12181: MOV XR,BCBUF(XL) SET POINTER TO NEW BFBLK ! 12182: MOV WB,XL POINT TO OLD BFBLK ! 12183: MVW COPY BFBLK TOO ! 12184: ZER XL CLEAR RUBBISH PTR ! 12185: BRN CBL09 BRANCH TO EXIT ! 12186: .FI ! 12187: ENP END PROCEDURE CBLCK ! 12188: EJC ! 12189: * ! 12190: * CDGCG -- GENERATE CODE FOR COMPLEX GOTO ! 12191: * ! 12192: * USED BY CMPIL TO PROCESS COMPLEX GOTO TREE ! 12193: * ! 12194: * (WB) MUST BE COLLECTABLE ! 12195: * (XR) EXPRESSION POINTER ! 12196: * JSR CDGCG CALL TO GENERATE COMPLEX GOTO ! 12197: * (XL,XR,WA) DESTROYED ! 12198: * ! 12199: CDGCG PRC E,0 ENTRY POINT ! 12200: MOV CMOPN(XR),XL GET UNARY GOTO OPERATOR ! 12201: MOV CMROP(XR),XR POINT TO GOTO OPERAND ! 12202: BEQ XL,=OPDVD,CDGC2 JUMP IF DIRECT GOTO ! 12203: JSR CDGNM GENERATE OPND BY NAME IF NOT DIRECT ! 12204: * ! 12205: * RETURN POINT ! 12206: * ! 12207: CDGC1 MOV XL,WA GOTO OPERATOR ! 12208: JSR CDWRD GENERATE IT ! 12209: EXI RETURN TO CALLER ! 12210: * ! 12211: * DIRECT GOTO ! 12212: * ! 12213: CDGC2 JSR CDGVL GENERATE OPERAND BY VALUE ! 12214: BRN CDGC1 MERGE TO RETURN ! 12215: ENP END PROCEDURE CDGCG ! 12216: EJC ! 12217: * ! 12218: * CDGEX -- BUILD EXPRESSION BLOCK ! 12219: * ! 12220: * CDGEX IS PASSED A POINTER TO AN EXPRESSION TREE (SEE ! 12221: * EXPAN) AND RETURNS AN EXPRESSION (SEBLK OR EXBLK). ! 12222: * ! 12223: * (WC) SOME COLLECTABLE VALUE ! 12224: * (WB) INTEGER IN RANGE 0 LE X LE MXLEN ! 12225: * (XL) PTR TO EXPRESSION TREE ! 12226: * JSR CDGEX CALL TO BUILD EXPRESSION ! 12227: * (XR) PTR TO SEBLK OR EXBLK ! 12228: * (XL,WA,WB) DESTROYED ! 12229: * ! 12230: CDGEX PRC R,0 ENTRY POINT, RECURSIVE ! 12231: BLO (XL),=B$VR$,CDGX1 JUMP IF NOT VARIABLE ! 12232: * ! 12233: * HERE FOR NATURAL VARIABLE, BUILD SEBLK ! 12234: * ! 12235: MOV *SESI$,WA SET SIZE OF SEBLK ! 12236: JSR ALLOC ALLOCATE SPACE FOR SEBLK ! 12237: MOV =B$SEL,(XR) SET TYPE WORD ! 12238: MOV XL,SEVAR(XR) STORE VRBLK POINTER ! 12239: EXI RETURN TO CDGEX CALLER ! 12240: * ! 12241: * HERE IF NOT VARIABLE, BUILD EXBLK ! 12242: * ! 12243: CDGX1 MOV XL,XR COPY TREE POINTER ! 12244: MOV WC,-(XS) SAVE WC ! 12245: MOV CWCOF,XL SAVE CURRENT OFFSET ! 12246: MOV (XR),WA GET TYPE WORD ! 12247: BNE WA,=B$CMT,CDGX2 CALL BY VALUE IF NOT CMBLK ! 12248: BGE CMTYP(XR),=C$$NM,CDGX2 JUMP IF CMBLK ONLY BY VALUE ! 12249: EJC ! 12250: * ! 12251: * CDGEX (CONTINUED) ! 12252: * ! 12253: * HERE IF EXPRESSION CAN BE EVALUATED BY NAME ! 12254: * ! 12255: JSR CDGNM GENERATE CODE BY NAME ! 12256: MOV =ORNM$,WA LOAD RETURN BY NAME WORD ! 12257: BRN CDGX3 MERGE WITH VALUE CASE ! 12258: * ! 12259: * HERE IF EXPRESSION CAN ONLY BE EVALUATED BY VALUE ! 12260: * ! 12261: CDGX2 JSR CDGVL GENERATE CODE BY VALUE ! 12262: MOV =ORVL$,WA LOAD RETURN BY VALUE WORD ! 12263: * ! 12264: * MERGE HERE TO CONSTRUCT EXBLK ! 12265: * ! 12266: CDGX3 JSR CDWRD GENERATE RETURN WORD ! 12267: JSR EXBLD BUILD EXBLK ! 12268: MOV (XS)+,WC RESTORE WC ! 12269: EXI RETURN TO CDGEX CALLER ! 12270: ENP END PROCEDURE CDGEX ! 12271: EJC ! 12272: * ! 12273: * CDGNM -- GENERATE CODE BY NAME ! 12274: * ! 12275: * CDGNM IS CALLED DURING THE COMPILATION PROCESS TO ! 12276: * GENERATE CODE BY NAME FOR AN EXPRESSION. SEE CDBLK ! 12277: * DESCRIPTION FOR DETAILS OF CODE GENERATED. THE INPUT ! 12278: * TO CDGNM IS AN EXPRESSION TREE AS GENERATED BY EXPAN. ! 12279: * ! 12280: * CDGNM IS A RECURSIVE PROCEDURE WHICH PROCEEDS BY MAKING ! 12281: * RECURSIVE CALLS TO GENERATE CODE FOR OPERANDS. ! 12282: * ! 12283: * (WB) INTEGER IN RANGE 0 LE N LE DNAMB ! 12284: * (XR) PTR TO TREE GENERATED BY EXPAN ! 12285: * (WC) CONSTANT FLAG (SEE BELOW) ! 12286: * JSR CDGNM CALL TO GENERATE CODE BY NAME ! 12287: * (XR,WA) DESTROYED ! 12288: * (WC) SET NON-ZERO IF NON-CONSTANT ! 12289: * ! 12290: * WC IS SET TO A NON-ZERO (COLLECTABLE) VALUE IF THE ! 12291: * EXPRESSION FOR WHICH CODE IS GENERATED CANNOT BE ! 12292: * EVALUATED AT COMPILE TIME, OTHERWISE WC IS UNCHANGED. ! 12293: * ! 12294: * THE CODE IS GENERATED IN THE CURRENT CCBLK (SEE CDWRD). ! 12295: * ! 12296: CDGNM PRC R,0 ENTRY POINT, RECURSIVE ! 12297: MOV XL,-(XS) SAVE ENTRY XL ! 12298: MOV WB,-(XS) SAVE ENTRY WB ! 12299: CHK CHECK FOR STACK OVERFLOW ! 12300: MOV (XR),WA LOAD TYPE WORD ! 12301: BEQ WA,=B$CMT,CGN04 JUMP IF CMBLK ! 12302: BHI WA,=B$VR$,CGN02 JUMP IF SIMPLE VARIABLE ! 12303: * ! 12304: * MERGE HERE FOR OPERAND YIELDING VALUE (E.G. CONSTANT) ! 12305: * ! 12306: CGN01 ERB 208,SYNTAX ERROR. VALUE USED WHERE NAME IS REQUIRED ! 12307: * ! 12308: * HERE FOR NATURAL VARIABLE REFERENCE ! 12309: * ! 12310: CGN02 MOV =OLVN$,WA LOAD VARIABLE LOAD CALL ! 12311: JSR CDWRD GENERATE IT ! 12312: MOV XR,WA COPY VRBLK POINTER ! 12313: JSR CDWRD GENERATE VRBLK POINTER ! 12314: EJC ! 12315: * ! 12316: * CDGNM (CONTINUED) ! 12317: * ! 12318: * HERE TO EXIT WITH WC SET CORRECTLY ! 12319: * ! 12320: CGN03 MOV (XS)+,WB RESTORE ENTRY WB ! 12321: MOV (XS)+,XL RESTORE ENTRY XL ! 12322: EXI RETURN TO CDGNM CALLER ! 12323: * ! 12324: * HERE FOR CMBLK ! 12325: * ! 12326: CGN04 MOV XR,XL COPY CMBLK POINTER ! 12327: MOV CMTYP(XR),XR LOAD CMBLK TYPE ! 12328: BGE XR,=C$$NM,CGN01 ERROR IF NOT NAME OPERAND ! 12329: BSW XR,C$$NM ELSE SWITCH ON TYPE ! 12330: IFF C$ARR,CGN05 ARRAY REFERENCE ! 12331: IFF C$FNC,CGN08 FUNCTION CALL ! 12332: IFF C$DEF,CGN09 DEFERRED EXPRESSION ! 12333: IFF C$IND,CGN10 INDIRECT REFERENCE ! 12334: IFF C$KEY,CGN11 KEYWORD REFERENCE ! 12335: IFF C$UBO,CGN08 UNDEFINED BINARY OP ! 12336: IFF C$UUO,CGN08 UNDEFINED UNARY OP ! 12337: ESW END SWITCH ON CMBLK TYPE ! 12338: * ! 12339: * HERE TO GENERATE CODE FOR ARRAY REFERENCE ! 12340: * ! 12341: CGN05 MOV *CMOPN,WB POINT TO ARRAY OPERAND ! 12342: * ! 12343: * LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS ! 12344: * ! 12345: CGN06 JSR CMGEN GENERATE CODE FOR NEXT OPERAND ! 12346: MOV CMLEN(XL),WC LOAD LENGTH OF CMBLK ! 12347: BLT WB,WC,CGN06 LOOP TILL ALL GENERATED ! 12348: * ! 12349: * GENERATE APPROPRIATE ARRAY CALL ! 12350: * ! 12351: MOV =OAON$,WA LOAD ONE-SUBSCRIPT CASE CALL ! 12352: BEQ WC,*CMAR1,CGN07 JUMP TO EXIT IF ONE SUBSCRIPT CASE ! 12353: MOV =OAMN$,WA ELSE LOAD MULTI-SUBSCRIPT CASE CALL ! 12354: JSR CDWRD GENERATE CALL ! 12355: MOV WC,WA COPY CMBLK LENGTH ! 12356: BTW WA CONVERT TO WORDS ! 12357: SUB =CMVLS,WA CALCULATE NUMBER OF SUBSCRIPTS ! 12358: EJC ! 12359: * ! 12360: * CDGNM (CONTINUED) ! 12361: * ! 12362: * HERE TO EXIT GENERATING WORD (NON-CONSTANT) ! 12363: * ! 12364: CGN07 MNZ WC SET RESULT NON-CONSTANT ! 12365: JSR CDWRD GENERATE WORD ! 12366: BRN CGN03 BACK TO EXIT ! 12367: * ! 12368: * HERE TO GENERATE CODE FOR FUNCTIONS AND UNDEFINED OPRS ! 12369: * ! 12370: CGN08 MOV XL,XR COPY CMBLK POINTER ! 12371: JSR CDGVL GEN CODE BY VALUE FOR CALL ! 12372: MOV =OFNE$,WA GET EXTRA CALL FOR BY NAME ! 12373: BRN CGN07 BACK TO GENERATE AND EXIT ! 12374: * ! 12375: * HERE TO GENERATE CODE FOR DEFERED EXPRESSION ! 12376: * ! 12377: CGN09 MOV CMROP(XL),XR CHECK IF VARIABLE ! 12378: BHI (XR),=B$VR$,CGN02 TREAT *VARIABLE AS SIMPLE VAR ! 12379: MOV XR,XL COPY PTR TO EXPRESSION TREE ! 12380: JSR CDGEX ELSE BUILD EXBLK ! 12381: MOV =OLEX$,WA SET CALL TO LOAD EXPR BY NAME ! 12382: JSR CDWRD GENERATE IT ! 12383: MOV XR,WA COPY EXBLK POINTER ! 12384: JSR CDWRD GENERATE EXBLK POINTER ! 12385: BRN CGN03 BACK TO EXIT ! 12386: * ! 12387: * HERE TO GENERATE CODE FOR INDIRECT REFERENCE ! 12388: * ! 12389: CGN10 MOV CMROP(XL),XR GET OPERAND ! 12390: JSR CDGVL GENERATE CODE BY VALUE FOR IT ! 12391: MOV =OINN$,WA LOAD CALL FOR INDIRECT BY NAME ! 12392: BRN CGN12 MERGE ! 12393: * ! 12394: * HERE TO GENERATE CODE FOR KEYWORD REFERENCE ! 12395: * ! 12396: CGN11 MOV CMROP(XL),XR GET OPERAND ! 12397: JSR CDGNM GENERATE CODE BY NAME FOR IT ! 12398: MOV =OKWN$,WA LOAD CALL FOR KEYWORD BY NAME ! 12399: * ! 12400: * KEYWORD, INDIRECT MERGE HERE ! 12401: * ! 12402: CGN12 JSR CDWRD GENERATE CODE FOR OPERATOR ! 12403: BRN CGN03 EXIT ! 12404: ENP END PROCEDURE CDGNM ! 12405: EJC ! 12406: * ! 12407: * CDGVL -- GENERATE CODE BY VALUE ! 12408: * ! 12409: * CDGVL IS CALLED DURING THE COMPILATION PROCESS TO ! 12410: * GENERATE CODE BY VALUE FOR AN EXPRESSION. SEE CDBLK ! 12411: * DESCRIPTION FOR DETAILS OF THE CODE GENERATED. THE INPUT ! 12412: * TO CDGVL IS AN EXPRESSION TREE AS GENERATED BY EXPAN. ! 12413: * ! 12414: * CDGVL IS A RECURSIVE PROCEDURE WHICH PROCEEDS BY MAKING ! 12415: * RECURSIVE CALLS TO GENERATE CODE FOR OPERANDS. ! 12416: * ! 12417: * (WB) INTEGER IN RANGE 0 LE N LE DNAMB ! 12418: * (XR) PTR TO TREE GENERATED BY EXPAN ! 12419: * (WC) CONSTANT FLAG (SEE BELOW) ! 12420: * JSR CDGVL CALL TO GENERATE CODE BY VALUE ! 12421: * (XR,WA) DESTROYED ! 12422: * (WC) SET NON-ZERO IF NON-CONSTANT ! 12423: * ! 12424: * WC IS SET TO A NON-ZERO (COLLECTABLE) VALUE IF THE ! 12425: * EXPRESSION FOR WHICH CODE IS GENERATED CANNOT BE ! 12426: * EVALUATED AT COMPILE TIME, OTHERWISE WC IS UNCHANGED. ! 12427: * ! 12428: * IF WC IS NON-ZERO ON ENTRY, THEN PREEVALUATION IS NOT ! 12429: * ALLOWED REGARDLESS OF THE NATURE OF THE OPERAND. ! 12430: * ! 12431: * THE CODE IS GENERATED IN THE CURRENT CCBLK (SEE CDWRD). ! 12432: * ! 12433: CDGVL PRC R,0 ENTRY POINT, RECURSIVE ! 12434: MOV (XR),WA LOAD TYPE WORD ! 12435: BEQ WA,=B$CMT,CGV01 JUMP IF CMBLK ! 12436: BLT WA,=B$VRA,CGV00 JUMP IF ICBLK, RCBLK, SCBLK ! 12437: * ! 12438: * HERE FOR VARIABLE VALUE REFERENCE ! 12439: * ! 12440: CGVL0 MNZ WC INDICATE NON-CONSTANT VALUE ! 12441: * ! 12442: * MERGE HERE FOR SIMPLE CONSTANT (ICBLK,RCBLK,SCBLK) ! 12443: * AND FOR VARIABLES CORRESPONDING TO CONSTANT KEYWORDS. ! 12444: * ! 12445: CGV00 MOV XR,WA COPY PTR TO VAR OR CONSTANT ! 12446: JSR CDWRD GENERATE AS CODE WORD ! 12447: EXI RETURN TO CALLER ! 12448: EJC ! 12449: * ! 12450: * CDGVL (CONTINUED) ! 12451: * ! 12452: * HERE FOR TREE NODE (CMBLK) ! 12453: * ! 12454: CGV01 MOV WB,-(XS) SAVE ENTRY WB ! 12455: MOV XL,-(XS) SAVE ENTRY XL ! 12456: MOV WC,-(XS) SAVE ENTRY CONSTANT FLAG ! 12457: MOV CWCOF,-(XS) SAVE INITIAL CODE OFFSET ! 12458: CHK CHECK FOR STACK OVERFLOW ! 12459: * ! 12460: * PREPARE TO GENERATE CODE FOR CMBLK. WC IS CLEARED TO ! 12461: * START WITH AND IS RESET NON-ZERO FOR ANY NON-CONSTANT ! 12462: * CODE GENERATED. IF IT IS STILL ZERO AFTER GENERATING ALL ! 12463: * THE CMBLK CODE, THEN ITS VALUE IS COMPUTED AS THE RESULT. ! 12464: * ! 12465: MOV XR,XL COPY CMBLK POINTER ! 12466: MOV CMTYP(XR),XR LOAD CMBLK TYPE ! 12467: ZER WC CLEAR OPTIMISE FLAG ! 12468: BLE XR,=C$PR$,CGV02 JUMP IF NOT PREDICATE VALUE ! 12469: MNZ WC ELSE FORCE NON-CONSTANT CASE ! 12470: * ! 12471: * HERE WITH WC SET APPROPRIATELY ! 12472: * ! 12473: CGV02 BSW XR,C$$NV SWITCH TO APPROPRIATE GENERATOR ! 12474: IFF C$ARR,CGV03 ARRAY REFERENCE ! 12475: IFF C$FNC,CGV05 FUNCTION CALL ! 12476: IFF C$DEF,CGV14 DEFERRED EXPRESSION ! 12477: IFF C$SEL,CGV15 SELECTION ! 12478: IFF C$IND,CGV31 INDIRECT REFERENCE ! 12479: IFF C$KEY,CGV27 KEYWORD REFERENCE ! 12480: IFF C$UBO,CGV29 UNDEFINED BINOP ! 12481: IFF C$UUO,CGV30 UNDEFINED UNOP ! 12482: IFF C$BVL,CGV18 BINOPS WITH VAL OPDS ! 12483: IFF C$ALT,CGV18 ALTERNATION ! 12484: IFF C$UVL,CGV19 UNOPS WITH VALU OPND ! 12485: IFF C$ASS,CGV21 ASSIGNMENT ! 12486: IFF C$CNC,CGV24 CONCATENATION ! 12487: IFF C$UNM,CGV27 UNOPS WITH NAME OPND ! 12488: IFF C$CNP,CGV24 CONCAT. NOT PATTERN ! 12489: IFF C$BVN,CGV26 BINARY $ AND . ! 12490: IFF C$INT,CGV31 INTERROGATION ! 12491: IFF C$NEG,CGV28 NEGATION ! 12492: IFF C$PMT,CGV18 PATTERN MATCH ! 12493: ESW END SWITCH ON CMBLK TYPE ! 12494: EJC ! 12495: * ! 12496: * CDGVL (CONTINUED) ! 12497: * ! 12498: * HERE TO GENERATE CODE FOR ARRAY REFERENCE ! 12499: * ! 12500: CGV03 MOV *CMOPN,WB SET OFFSET TO ARRAY OPERAND ! 12501: * ! 12502: * LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS ! 12503: * ! 12504: CGV04 JSR CMGEN GEN VALUE CODE FOR NEXT OPERAND ! 12505: MOV CMLEN(XL),WC LOAD CMBLK LENGTH ! 12506: BLT WB,WC,CGV04 LOOP BACK IF MORE TO GO ! 12507: * ! 12508: * GENERATE CALL TO APPROPRIATE ARRAY REFERENCE ROUTINE ! 12509: * ! 12510: MOV =OAOV$,WA SET ONE SUBSCRIPT CALL IN CASE ! 12511: BEQ WC,*CMAR1,CGV32 JUMP TO EXIT IF 1-SUB CASE ! 12512: MOV =OAMV$,WA ELSE SET CALL FOR MULTI-SUBSCRIPTS ! 12513: JSR CDWRD GENERATE CALL ! 12514: MOV WC,WA COPY LENGTH OF CMBLK ! 12515: SUB *CMVLS,WA SUBTRACT STANDARD LENGTH ! 12516: BTW WA GET NUMBER OF WORDS ! 12517: BRN CGV32 JUMP TO GENERATE SUBSCRIPT COUNT ! 12518: * ! 12519: * HERE TO GENERATE CODE FOR FUNCTION CALL ! 12520: * ! 12521: CGV05 MOV *CMVLS,WB SET OFFSET TO FIRST ARGUMENT ! 12522: * ! 12523: * LOOP TO GENERATE CODE FOR ARGUMENTS ! 12524: * ! 12525: CGV06 BEQ WB,CMLEN(XL),CGV07 JUMP IF ALL GENERATED ! 12526: JSR CMGEN ELSE GEN VALUE CODE FOR NEXT ARG ! 12527: BRN CGV06 BACK TO GENERATE NEXT ARGUMENT ! 12528: * ! 12529: * HERE TO GENERATE ACTUAL FUNCTION CALL ! 12530: * ! 12531: CGV07 SUB *CMVLS,WB GET NUMBER OF ARG PTRS (BAUS) ! 12532: BTW WB CONVERT BAUS TO WORDS ! 12533: MOV CMOPN(XL),XR LOAD FUNCTION VRBLK POINTER ! 12534: BNZ VRLEN(XR),CGV12 JUMP IF NOT SYSTEM FUNCTION ! 12535: MOV VRSVP(XR),XL LOAD SVBLK PTR IF SYSTEM VAR ! 12536: MOV SVBIT(XL),WA LOAD BIT MASK ! 12537: ANB BTFFC,WA TEST FOR FAST FUNCTION CALL ALLOWED ! 12538: ZRB WA,CGV12 JUMP IF NOT ! 12539: EJC ! 12540: * ! 12541: * CDGVL (CONTINUED) ! 12542: * ! 12543: * HERE IF FAST FUNCTION CALL IS ALLOWED ! 12544: * ! 12545: MOV SVBIT(XL),WA RELOAD BIT INDICATORS ! 12546: ANB BTPRE,WA TEST FOR PREEVALUATION OK ! 12547: NZB WA,CGV08 JUMP IF PREEVALUATION PERMITTED ! 12548: MNZ WC ELSE SET RESULT NON-CONSTANT ! 12549: * ! 12550: * TEST FOR CORRECT NUMBER OF ARGS FOR FAST CALL ! 12551: * ! 12552: CGV08 MOV VRFNC(XR),XL LOAD PTR TO SVFNC FIELD ! 12553: MOV FARGS(XL),WA LOAD SVNAR FIELD VALUE ! 12554: BEQ WA,WB,CGV11 JUMP IF ARGUMENT COUNT IS CORRECT ! 12555: BHI WA,WB,CGV09 JUMP IF TOO FEW ARGUMENTS GIVEN ! 12556: * ! 12557: * HERE IF TOO MANY ARGUMENTS, PREPARE TO GENERATE O$POPS ! 12558: * ! 12559: SUB WA,WB GET NUMBER OF EXTRA ARGS ! 12560: LCT WB,WB SET AS COUNT TO CONTROL LOOP ! 12561: MOV =OPOP$,WA SET POP CALL ! 12562: BRN CGV10 JUMP TO COMMON LOOP ! 12563: * ! 12564: * HERE IF TOO FEW ARGUMENTS, PREPARE TO GENERATE NULLS ! 12565: * ! 12566: CGV09 SUB WB,WA GET NUMBER OF MISSING ARGUMENTS ! 12567: LCT WB,WA LOAD AS COUNT TO CONTROL LOOP ! 12568: MOV =NULLS,WA LOAD PTR TO NULL CONSTANT ! 12569: * ! 12570: * LOOP TO GENERATE CALLS TO FIX ARGUMENT COUNT ! 12571: * ! 12572: CGV10 JSR CDWRD GENERATE ONE CALL ! 12573: BCT WB,CGV10 LOOP TILL ALL GENERATED ! 12574: * ! 12575: * HERE AFTER ADJUSTING ARG COUNT AS REQUIRED ! 12576: * ! 12577: CGV11 MOV XL,WA COPY POINTER TO SVFNC FIELD ! 12578: BRN CGV36 JUMP TO GENERATE CALL ! 12579: EJC ! 12580: * ! 12581: * CDGVL (CONTINUED) ! 12582: * ! 12583: * COME HERE IF FAST CALL IS NOT PERMITTED ! 12584: * ! 12585: CGV12 MOV =OFNS$,WA SET ONE ARG CALL IN CASE ! 12586: BEQ WB,=NUM01,CGV13 JUMP IF ONE ARG CASE ! 12587: MOV =OFNC$,WA ELSE LOAD CALL FOR MORE THAN 1 ARG ! 12588: JSR CDWRD GENERATE IT ! 12589: MOV WB,WA COPY ARGUMENT COUNT ! 12590: * ! 12591: * ONE ARG CASE MERGES HERE ! 12592: * ! 12593: CGV13 JSR CDWRD GENERATE =O$FNS OR ARG COUNT ! 12594: MOV XR,WA COPY VRBLK POINTER ! 12595: BRN CGV32 JUMP TO GENERATE VRBLK PTR ! 12596: * ! 12597: * HERE FOR DEFERRED EXPRESSION ! 12598: * ! 12599: CGV14 MOV CMROP(XL),XL POINT TO EXPRESSION TREE ! 12600: JSR CDGEX BUILD EXBLK OR SEBLK ! 12601: MOV XR,WA COPY BLOCK PTR ! 12602: JSR CDWRD GENERATE PTR TO EXBLK OR SEBLK ! 12603: BRN CGV34 JUMP TO EXIT, CONSTANT TEST ! 12604: * ! 12605: * HERE TO GENERATE CODE FOR SELECTION ! 12606: * ! 12607: CGV15 ZER -(XS) ZERO PTR TO CHAIN OF FORWARD JUMPS ! 12608: ZER -(XS) ZERO PTR TO PREV O$SLC FORWARD PTR ! 12609: MOV *CMVLS,WB POINT TO FIRST ALTERNATIVE ! 12610: MOV =OSLA$,WA SET INITIAL CODE WORD ! 12611: * ! 12612: * 0(XS) IS THE OFFSET TO THE PREVIOUS WORD ! 12613: * WHICH REQUIRES FILLING IN WITH AN ! 12614: * OFFSET TO THE FOLLOWING O$SLC,O$SLD ! 12615: * ! 12616: * 1(XS) IS THE HEAD OF A CHAIN OF OFFSET ! 12617: * POINTERS INDICATING THOSE LOCATIONS ! 12618: * TO BE FILLED WITH OFFSETS PAST ! 12619: * THE END OF ALL THE ALTERNATIVES ! 12620: * ! 12621: CGV16 JSR CDWRD GENERATE O$SLC (O$SLA FIRST TIME) ! 12622: MOV CWCOF,(XS) SET CURRENT LOC AS PTR TO FILL IN ! 12623: JSR CDWRD GENERATE GARBAGE WORD THERE FOR NOW ! 12624: JSR CMGEN GEN VALUE CODE FOR ALTERNATIVE ! 12625: MOV =OSLB$,WA LOAD O$SLB POINTER ! 12626: JSR CDWRD GENERATE O$SLB CALL ! 12627: MOV 1(XS),WA LOAD OLD CHAIN PTR ! 12628: MOV CWCOF,1(XS) SET CURRENT LOC AS NEW CHAIN HEAD ! 12629: JSR CDWRD GENERATE FORWARD CHAIN LINK ! 12630: EJC ! 12631: * ! 12632: * CDGVL (CONTINUED) ! 12633: * ! 12634: * NOW TO FILL IN THE SKIP OFFSET TO O$SLC,O$SLD ! 12635: * ! 12636: MOV (XS),XR LOAD OFFSET TO WORD TO PLUG ! 12637: ADD R$CCB,XR POINT TO ACTUAL LOCATION TO PLUG ! 12638: MOV CWCOF,(XR) PLUG PROPER OFFSET IN ! 12639: MOV =OSLC$,WA LOAD O$SLC PTR FOR NEXT ALTERNATIVE ! 12640: MOV WB,XR COPY OFFSET (DESTROY GARBAGE XR) ! 12641: ICA XR BUMP EXTRA TIME FOR TEST ! 12642: BLT XR,CMLEN(XL),CGV16 LOOP BACK IF NOT LAST ALTERNATIVE ! 12643: * ! 12644: * HERE TO GENERATE CODE FOR LAST ALTERNATIVE ! 12645: * ! 12646: MOV =OSLD$,WA GET HEADER CALL ! 12647: JSR CDWRD GENERATE O$SLD CALL ! 12648: JSR CMGEN GENERATE CODE FOR LAST ALTERNATIVE ! 12649: ICA XS POP OFFSET PTR ! 12650: MOV (XS)+,XR LOAD CHAIN PTR ! 12651: * ! 12652: * LOOP TO PLUG OFFSETS PAST STRUCTURE ! 12653: * ! 12654: CGV17 ADD R$CCB,XR MAKE NEXT PTR ABSOLUTE ! 12655: MOV (XR),WA LOAD FORWARD PTR ! 12656: MOV CWCOF,(XR) PLUG REQUIRED OFFSET ! 12657: MOV WA,XR COPY FORWARD PTR ! 12658: BNZ WA,CGV17 LOOP BACK IF MORE TO GO ! 12659: BRN CGV33 ELSE JUMP TO EXIT (NOT CONSTANT) ! 12660: * ! 12661: * HERE FOR BINARY OPS WITH VALUE OPERANDS ! 12662: * ! 12663: CGV18 MOV CMLOP(XL),XR LOAD LEFT OPERAND POINTER ! 12664: JSR CDGVL GEN VALUE CODE FOR LEFT OPERAND ! 12665: * ! 12666: * HERE FOR UNARY OPS WITH VALUE OPERAND (BINOPS MERGE) ! 12667: * ! 12668: CGV19 MOV CMROP(XL),XR LOAD RIGHT (ONLY) OPERAND PTR ! 12669: JSR CDGVL GEN CODE BY VALUE ! 12670: EJC ! 12671: * ! 12672: * CDGVL (CONTINUED) ! 12673: * ! 12674: * MERGE HERE TO GENERATE OPERATOR CALL FROM CMOPN FIELD ! 12675: * ! 12676: CGV20 MOV CMOPN(XL),WA LOAD OPERATOR CALL POINTER ! 12677: BRN CGV36 JUMP TO GENERATE IT WITH CONS TEST ! 12678: * ! 12679: * HERE FOR ASSIGNMENT ! 12680: * ! 12681: CGV21 MOV CMLOP(XL),XR LOAD LEFT OPERAND POINTER ! 12682: BLO (XR),=B$VR$,CGV22 JUMP IF NOT VARIABLE ! 12683: * ! 12684: * HERE FOR ASSIGNMENT TO SIMPLE VARIABLE ! 12685: * ! 12686: MOV CMROP(XL),XR LOAD RIGHT OPERAND PTR ! 12687: JSR CDGVL GENERATE CODE BY VALUE ! 12688: MOV CMLOP(XL),WA RELOAD LEFT OPERAND VRBLK PTR ! 12689: ADD *VRSTO,WA POINT TO VRSTO FIELD ! 12690: BRN CGV32 JUMP TO GENERATE STORE PTR ! 12691: * ! 12692: * HERE IF NOT SIMPLE VARIABLE ASSIGNMENT ! 12693: * ! 12694: CGV22 JSR EXPAP TEST FOR PATTERN MATCH ON LEFT SIDE ! 12695: PPM CGV23 JUMP IF NOT PATTERN MATCH ! 12696: * ! 12697: * HERE FOR PATTERN REPLACEMENT ! 12698: * ! 12699: MOV CMROP(XR),CMLOP(XL) SAVE PATTERN PTR IN SAFE PLACE ! 12700: MOV CMLOP(XR),XR LOAD SUBJECT PTR ! 12701: JSR CDGNM GEN CODE BY NAME FOR SUBJECT ! 12702: MOV CMLOP(XL),XR LOAD PATTERN PTR ! 12703: JSR CDGVL GEN CODE BY VALUE FOR PATTERN ! 12704: MOV =OPMN$,WA LOAD MATCH BY NAME CALL ! 12705: JSR CDWRD GENERATE IT ! 12706: MOV CMROP(XL),XR LOAD REPLACEMENT VALUE PTR ! 12707: JSR CDGVL GEN CODE BY VALUE ! 12708: MOV =ORPL$,WA LOAD REPLACE CALL ! 12709: BRN CGV32 JUMP TO GEN AND EXIT (NOT CONSTANT) ! 12710: * ! 12711: * HERE FOR ASSIGNMENT TO COMPLEX VARIABLE ! 12712: * ! 12713: CGV23 MNZ WC INHIBIT PRE-EVALUATION ! 12714: JSR CDGNM GEN CODE BY NAME FOR LEFT SIDE ! 12715: BRN CGV31 MERGE WITH UNOP CIRCUIT ! 12716: EJC ! 12717: * ! 12718: * CDGVL (CONTINUED) ! 12719: * ! 12720: * HERE FOR CONCATENATION ! 12721: * ! 12722: CGV24 MOV CMLOP(XL),XR LOAD LEFT OPERAND PTR ! 12723: BNE (XR),=B$CMT,CGV18 ORDINARY BINOP IF NOT CMBLK ! 12724: MOV CMTYP(XR),WB LOAD CMBLK TYPE CODE ! 12725: BEQ WB,=C$INT,CGV25 SPECIAL CASE IF INTERROGATION ! 12726: BEQ WB,=C$NEG,CGV25 OR NEGATION ! 12727: BNE WB,=C$FNC,CGV18 ELSE ORDINARY BINOP IF NOT FUNCTION ! 12728: MOV CMOPN(XR),XR ELSE LOAD FUNCTION VRBLK PTR ! 12729: BNZ VRLEN(XR),CGV18 ORDINARY BINOP IF NOT SYSTEM VAR ! 12730: MOV VRSVP(XR),XR ELSE POINT TO SVBLK ! 12731: MOV SVBIT(XR),WA LOAD BIT INDICATORS ! 12732: ANB BTPRD,WA TEST FOR PREDICATE FUNCTION ! 12733: ZRB WA,CGV18 ORDINARY BINOP IF NOT ! 12734: * ! 12735: * HERE IF LEFT ARG OF CONCATENATION IS PREDICATE FUNCTION ! 12736: * ! 12737: CGV25 MOV CMLOP(XL),XR RELOAD LEFT ARG ! 12738: JSR CDGVL GEN CODE BY VALUE ! 12739: MOV =OPOP$,WA LOAD POP CALL ! 12740: JSR CDWRD GENERATE IT ! 12741: MOV CMROP(XL),XR LOAD RIGHT OPERAND ! 12742: JSR CDGVL GEN CODE BY VALUE AS RESULT CODE ! 12743: BRN CGV33 EXIT (NOT CONSTANT) ! 12744: * ! 12745: * HERE TO GENERATE CODE FOR PATTERN, IMMEDIATE ASSIGNMENT ! 12746: * ! 12747: CGV26 MOV CMLOP(XL),XR LOAD LEFT OPERAND ! 12748: JSR CDGVL GEN CODE BY VALUE, MERGE ! 12749: * ! 12750: * HERE FOR UNOPS WITH ARG BY NAME (BINARY $ . MERGE) ! 12751: * ! 12752: CGV27 MOV CMROP(XL),XR LOAD RIGHT OPERAND PTR ! 12753: JSR CDGNM GEN CODE BY NAME FOR RIGHT ARG ! 12754: MOV CMOPN(XL),XR GET OPERATOR CODE WORD ! 12755: BNE (XR),=O$KWV,CGV20 GEN CALL UNLESS KEYWORD VALUE ! 12756: EJC ! 12757: * ! 12758: * CDGVL (CONTINUED) ! 12759: * ! 12760: * HERE FOR KEYWORD BY VALUE. THIS IS CONSTANT ONLY IF ! 12761: * THE OPERAND IS ONE OF THE SPECIAL SYSTEM VARIABLES WITH ! 12762: * THE SVCKW BIT SET TO INDICATE A CONSTANT KEYWORD VALUE. ! 12763: * NOTE THAT THE ONLY CONSTANT OPERAND BY NAME IS A VARIABLE ! 12764: * ! 12765: BNZ WC,CGV20 GEN CALL IF NON-CONSTANT (NOT VAR) ! 12766: MNZ WC ELSE SET NON-CONSTANT IN CASE ! 12767: MOV CMROP(XL),XR LOAD PTR TO OPERAND VRBLK ! 12768: BNZ VRLEN(XR),CGV20 GEN (NON-CONSTANT) IF NOT SYS VAR ! 12769: MOV VRSVP(XR),XR ELSE LOAD PTR TO SVBLK ! 12770: MOV SVBIT(XR),WA LOAD BIT MASK ! 12771: ANB BTCKW,WA TEST FOR CONSTANT KEYWORD ! 12772: ZRB WA,CGV20 GO GEN IF NOT CONSTANT ! 12773: ZER WC ELSE SET RESULT CONSTANT ! 12774: BRN CGV20 AND JUMP BACK TO GENERATE CALL ! 12775: * ! 12776: * HERE TO GENERATE CODE FOR NEGATION ! 12777: * ! 12778: CGV28 MOV =ONTA$,WA GET INITIAL WORD ! 12779: JSR CDWRD GENERATE IT ! 12780: MOV CWCOF,WB SAVE NEXT OFFSET ! 12781: JSR CDWRD GENERATE GUNK WORD FOR NOW ! 12782: MOV CMROP(XL),XR LOAD RIGHT OPERAND PTR ! 12783: JSR CDGVL GEN CODE BY VALUE ! 12784: MOV =ONTB$,WA LOAD END OF EVALUATION CALL ! 12785: JSR CDWRD GENERATE IT ! 12786: MOV WB,XR COPY OFFSET TO WORD TO PLUG ! 12787: ADD R$CCB,XR POINT TO ACTUAL WORD TO PLUG ! 12788: MOV CWCOF,(XR) PLUG WORD WITH CURRENT OFFSET ! 12789: MOV =ONTC$,WA LOAD FINAL CALL ! 12790: BRN CGV32 JUMP TO GENERATE IT (NOT CONSTANT) ! 12791: * ! 12792: * HERE TO GENERATE CODE FOR UNDEFINED BINARY OPERATOR ! 12793: * ! 12794: CGV29 MOV CMLOP(XL),XR LOAD LEFT OPERAND PTR ! 12795: JSR CDGVL GENERATE CODE BY VALUE ! 12796: EJC ! 12797: * ! 12798: * CDGVL (CONTINUED) ! 12799: * ! 12800: * HERE TO GENERATE CODE FOR UNDEFINED UNARY OPERATOR ! 12801: * ! 12802: CGV30 MOV =C$UO$,WB SET UNOP CODE + 1 ! 12803: SUB CMTYP(XL),WB SET NUMBER OF ARGS (1 OR 2) ! 12804: * ! 12805: * MERGE HERE FOR UNDEFINED OPERATORS ! 12806: * ! 12807: MOV CMROP(XL),XR LOAD RIGHT (ONLY) OPERAND POINTER ! 12808: JSR CDGVL GEN VALUE CODE FOR RIGHT OPERAND ! 12809: MOV CMOPN(XL),XR LOAD POINTER TO OPERATOR DV ! 12810: MOV DVOPN(XR),XR LOAD POINTER OFFSET ! 12811: WTB XR CONVERT WORD OFFSET TO BAUS ! 12812: ADD =R$UBA,XR POINT TO PROPER FUNCTION PTR ! 12813: SUB *VRFNC,XR SET STANDARD FUNCTION OFFSET ! 12814: BRN CGV12 MERGE WITH FUNCTION CALL CIRCUIT ! 12815: * ! 12816: * HERE TO GENERATE CODE FOR INTERROGATION, INDIRECTION ! 12817: * ! 12818: CGV31 MNZ WC SET NON CONSTANT ! 12819: BRN CGV19 MERGE ! 12820: * ! 12821: * HERE TO EXIT GENERATING A WORD, RESULT NOT CONSTANT ! 12822: * ! 12823: CGV32 JSR CDWRD GENERATE WORD, MERGE ! 12824: * ! 12825: * HERE TO EXIT WITH NO WORD GENERATED, NOT CONSTANT ! 12826: * ! 12827: CGV33 MNZ WC INDICATE RESULT IS NOT CONSTANT ! 12828: * ! 12829: * COMMON EXIT POINT ! 12830: * ! 12831: CGV34 ICA XS POP INITIAL CODE OFFSET ! 12832: MOV (XS)+,WA RESTORE OLD CONSTANT FLAG ! 12833: MOV (XS)+,XL RESTORE ENTRY XL ! 12834: MOV (XS)+,WB RESTORE ENTRY WB ! 12835: BNZ WC,CGV35 JUMP IF NOT CONSTANT ! 12836: MOV WA,WC ELSE RESTORE ENTRY CONSTANT FLAG ! 12837: * ! 12838: * HERE TO RETURN AFTER DEALING WITH WC SETTING ! 12839: * ! 12840: CGV35 EXI RETURN TO CDGVL CALLER ! 12841: * ! 12842: * EXIT HERE TO GENERATE WORD AND TEST FOR CONSTANT ! 12843: * ! 12844: CGV36 JSR CDWRD GENERATE WORD ! 12845: BNZ WC,CGV34 JUMP TO EXIT IF NOT CONSTANT ! 12846: EJC ! 12847: * ! 12848: * CDGVL (CONTINUED) ! 12849: * ! 12850: * HERE TO PREEVALUATE CONSTANT SUB-EXPRESSION ! 12851: * ! 12852: MOV =ORVL$,WA LOAD CALL TO RETURN VALUE ! 12853: JSR CDWRD GENERATE IT ! 12854: MOV (XS),XL LOAD INITIAL CODE OFFSET ! 12855: JSR EXBLD BUILD EXBLK FOR EXPRESSION ! 12856: ZER WB SET TO EVALUATE BY VALUE ! 12857: JSR EVALX EVALUATE EXPRESSION ! 12858: PPM SHOULD NOT FAIL ! 12859: MOV (XR),WA LOAD TYPE WORD OF RESULT ! 12860: BLO WA,=P$AAA,CGV37 JUMP IF NOT PATTERN ! 12861: MOV =OLPT$,WA ELSE LOAD SPECIAL PATTERN LOAD CALL ! 12862: JSR CDWRD GENERATE IT ! 12863: * ! 12864: * MERGE HERE TO GENERATE POINTER TO RESULTING CONSTANT ! 12865: * ! 12866: CGV37 MOV XR,WA COPY CONSTANT POINTER ! 12867: JSR CDWRD GENERATE PTR ! 12868: ZER WC SET RESULT CONSTANT ! 12869: BRN CGV34 JUMP BACK TO EXIT ! 12870: ENP END PROCEDURE CDGVL ! 12871: EJC ! 12872: * ! 12873: * CDWRD -- GENERATE ONE WORD OF CODE ! 12874: * ! 12875: * CDWRD WRITES ONE WORD INTO THE CURRENT CODE BLOCK UNDER ! 12876: * CONSTRUCTION. A NEW, LARGER, BLOCK IS ALLOCATED IF THERE ! 12877: * IS INSUFFICIENT ROOM IN THE CURRENT BLOCK. CDWRD ENSURES ! 12878: * THAT THERE ARE AT LEAST THREE WORDS LEFT IN THE BLOCK ! 12879: * AFTER ENTERING THE NEW WORD. THIS GUARANTEES THAT ANY ! 12880: * EXTRA SPACE AT THE END CAN BE SPLIT OFF AS A CCBLK. ! 12881: * ! 12882: * (WA) WORD TO BE GENERATED ! 12883: * JSR CDWRD CALL TO GENERATE WORD ! 12884: * ! 12885: CDWRD PRC E,0 ENTRY POINT ! 12886: MOV XR,-(XS) SAVE ENTRY XR ! 12887: MOV WA,-(XS) SAVE CODE WORD TO BE GENERATED ! 12888: * ! 12889: * MERGE BACK HERE AFTER ALLOCATING LARGER BLOCK ! 12890: * ! 12891: CDWD1 MOV R$CCB,XR LOAD PTR TO CCBLK BEING BUILT ! 12892: BNZ XR,CDWD2 JUMP IF BLOCK ALLOCATED ! 12893: * ! 12894: * HERE WE ALLOCATE AN ENTIRELY FRESH BLOCK ! 12895: * ! 12896: MOV *E$CBS,WA LOAD INITIAL LENGTH ! 12897: JSR ALLOC ALLOCATE CCBLK ! 12898: MOV =B$CCT,(XR) STORE TYPE WORD ! 12899: MOV *CCCOD,CWCOF SET INITIAL OFFSET ! 12900: MOV WA,CCLEN(XR) STORE BLOCK LENGTH ! 12901: MOV XR,R$CCB STORE PTR TO NEW BLOCK ! 12902: * ! 12903: * HERE WE HAVE A BLOCK WE CAN USE ! 12904: * ! 12905: CDWD2 MOV CWCOF,WA LOAD CURRENT OFFSET ! 12906: ADD *NUM04,WA ADJUST FOR TEST (FOUR WORDS) ! 12907: BLO WA,CCLEN(XR),CDWD4 JUMP IF ROOM IN THIS BLOCK ! 12908: * ! 12909: * HERE IF NO ROOM IN CURRENT BLOCK ! 12910: * ! 12911: BGE WA,MXLEN,CDWD5 JUMP IF ALREADY AT MAX SIZE ! 12912: ADD *E$CBS,WA ELSE GET NEW SIZE ! 12913: MOV XL,-(XS) SAVE ENTRY XL ! 12914: MOV XR,XL COPY POINTER ! 12915: BLT WA,MXLEN,CDWD3 JUMP IF NOT TOO LARGE ! 12916: MOV MXLEN,WA ELSE RESET TO MAX ALLOWED SIZE ! 12917: EJC ! 12918: * ! 12919: * CDWRD (CONTINUED) ! 12920: * ! 12921: * HERE WITH NEW BLOCK SIZE IN WA ! 12922: * ! 12923: CDWD3 JSR ALLOC ALLOCATE NEW BLOCK ! 12924: MOV XR,R$CCB STORE POINTER TO NEW BLOCK ! 12925: MOV =B$CCT,(XR)+ STORE TYPE WORD IN NEW BLOCK ! 12926: MOV WA,(XR)+ STORE BLOCK LENGTH ! 12927: ADD *CCUSE,XL POINT TO CCUSE,CCCOD FIELDS IN OLD ! 12928: MOV (XL),WA LOAD CCUSE VALUE ! 12929: MVW COPY USEFUL WORDS FROM OLD BLOCK ! 12930: MOV (XS)+,XL RESTORE XL ! 12931: BRN CDWD1 MERGE BACK TO TRY AGAIN ! 12932: * ! 12933: * HERE WITH ROOM IN CURRENT BLOCK ! 12934: * ! 12935: CDWD4 MOV CWCOF,WA LOAD CURRENT OFFSET ! 12936: ICA WA GET NEW OFFSET ! 12937: MOV WA,CWCOF STORE NEW OFFSET ! 12938: MOV WA,CCUSE(XR) STORE IN CCBLK FOR GBCOL ! 12939: DCA WA RESTORE PTR TO THIS WORD ! 12940: ADD WA,XR POINT TO CURRENT ENTRY ! 12941: MOV (XS)+,WA RELOAD WORD TO GENERATE ! 12942: MOV WA,(XR) STORE WORD IN BLOCK ! 12943: MOV (XS)+,XR RESTORE ENTRY XR ! 12944: EXI RETURN TO CALLER ! 12945: * ! 12946: * HERE IF COMPILED CODE IS TOO LONG FOR CDBLK ! 12947: * ! 12948: CDWD5 ERB 209,SYNTAX ERROR. STATEMENT IS TOO COMPLICATED. ! 12949: ENP END PROCEDURE CDWRD ! 12950: EJC ! 12951: * ! 12952: * CMGEN -- GENERATE CODE FOR CMBLK PTR ! 12953: * ! 12954: * CMGEN IS A SUBSIDIARY PROCEDURE USED TO GENERATE VALUE ! 12955: * CODE FOR A CMBLK PTR FROM THE MAIN CODE GENERATORS. ! 12956: * ! 12957: * (XL) CMBLK POINTER ! 12958: * (WB) OFFSET TO POINTER IN CMBLK ! 12959: * JSR CMGEN CALL TO GENERATE CODE ! 12960: * (XR,WA) DESTROYED ! 12961: * (WB) BUMPED BY ONE WORD ! 12962: * ! 12963: CMGEN PRC R,0 ENTRY POINT, RECURSIVE ! 12964: MOV XL,XR COPY CMBLK POINTER ! 12965: ADD WB,XR POINT TO CMBLK POINTER ! 12966: MOV (XR),XR LOAD CMBLK POINTER ! 12967: JSR CDGVL GENERATE CODE BY VALUE ! 12968: ICA WB BUMP OFFSET ! 12969: EXI RETURN TO CALLER ! 12970: ENP END PROCEDURE CMGEN ! 12971: EJC ! 12972: * ! 12973: * CMPIL (COMPILE SOURCE CODE) ! 12974: * ! 12975: * CMPIL IS USED TO CONVERT SNOBOL4 SOURCE CODE TO INTERNAL ! 12976: * FORM (SEE CDBLK FORMAT). IT IS USED BOTH FOR THE INITIAL ! 12977: * COMPILE AND AT RUN TIME BY THE CODE AND CONVERT FUNCTIONS ! 12978: * THIS PROCEDURE HAS CONTROL FOR THE ENTIRE DURATION OF ! 12979: * INITIAL COMPILATION. AN ERROR IN ANY PROCEDURE CALLED ! 12980: * DURING COMPILATION WILL LEAD FIRST TO THE ERROR SECTION ! 12981: * AND ULTIMATELY BACK HERE FOR RESUMED COMPILATION. THE ! 12982: * RE-ENTRY POINTS AFTER AN ERROR ARE SPECIALLY LABELLED - ! 12983: * ! 12984: * CMPCE RESUME AFTER CONTROL CARD ERROR ! 12985: * CMPLE RESUME AFTER LABEL ERROR ! 12986: * CMPSE RESUME AFTER STATEMENT ERROR ! 12987: * ! 12988: * JSR CMPIL CALL TO COMPILE CODE ! 12989: * (XR) PTR TO CDBLK FOR ENTRY STATEMENT ! 12990: * (XL,WA,WB,WC,RA) DESTROYED ! 12991: * ! 12992: * THE FOLLOWING GLOBAL VARIABLES ARE REFERENCED ! 12993: * ! 12994: * CMPSN NUMBER OF NEXT STATEMENT ! 12995: * TO BE COMPILED. ! 12996: * ! 12997: * CSWXX CONTROL CARD SWITCH VALUES ARE ! 12998: * CHANGED WHEN RELEVANT CONTROL ! 12999: * CARDS ARE MET. ! 13000: * ! 13001: * CWCOF OFFSET TO NEXT WORD IN CODE BLOCK ! 13002: * BEING BUILT (SEE CDWRD). ! 13003: * ! 13004: * LSTSN NUMBER OF STATEMENT MOST RECENTLY ! 13005: * COMPILED (INITIALLY SET TO ZERO). ! 13006: * ! 13007: * R$CIM CURRENT (INITIAL) COMPILER IMAGE ! 13008: * (ZERO FOR INITIAL COMPILE CALL) ! 13009: * ! 13010: * R$CNI USED TO POINT TO FOLLOWING IMAGE. ! 13011: * (SEE READR PROCEDURE). ! 13012: * ! 13013: * SCNGO GOTO SWITCH FOR SCANE PROCEDURE ! 13014: * ! 13015: * SCNIL LENGTH OF CURRENT IMAGE EXCLUDING ! 13016: * CHARACTERS REMOVED BY -INPUT. ! 13017: * ! 13018: * SCNPT CURRENT SCAN OFFSET, SEE SCANE. ! 13019: * ! 13020: * SCNRS RESCAN SWITCH FOR SCANE PROCEDURE. ! 13021: * ! 13022: * SCNSE OFFSET (IN R$CIM) OF MOST RECENTLY ! 13023: * SCANNED ELEMENT. SET ZERO IF NOT ! 13024: * CURRENTLY SCANNING ITEMS ! 13025: EJC ! 13026: * ! 13027: * CMPIL (CONTINUED) ! 13028: * ! 13029: * STAGE STGIC INITIAL COMPILE IN PROGRESS ! 13030: * STGXC CODE/CONVERT COMPILE ! 13031: * STGEV BUILDING EXBLK FOR EVAL ! 13032: * STGXT EXECUTE TIME (OUTSIDE COMPILE) ! 13033: * STGCE INITIAL COMPILE AFTER END LINE ! 13034: * STGXE EXECUTE COMPILE AFTER END LINE ! 13035: * ! 13036: * CMPIL ALSO USES A FIXED NUMBER OF LOCATIONS ON THE ! 13037: * MAIN STACK AS FOLLOWS. (THE DEFINITIONS OF THE ACTUAL ! 13038: * OFFSETS ARE IN THE DEFINITIONS SECTION). ! 13039: * ! 13040: * CMSTM(XS) POINTER TO EXPAN TREE FOR BODY OF ! 13041: * STATEMENT (SEE EXPAN PROCEDURE). ! 13042: * ! 13043: * CMSGO(XS) POINTER TO TREE REPRESENTATION OF ! 13044: * SUCCESS GOTO (SEE PROCEDURE SCNGO)9 ! 13045: * ZERO IF NO SUCCESS GOTO IS GIVEN ! 13046: * ! 13047: * CMFGO(XS) LIKE CMSGO FOR FAILURE GOTO. ! 13048: * ! 13049: * CMCGO(XS) SET NON-ZERO ONLY IF THERE IS A ! 13050: * CONDITIONAL GOTO. USED FOR -FAIL, ! 13051: * -NOFAIL CODE GENERATION. ! 13052: * ! 13053: * CMPCD(XS) POINTER TO CDBLK FOR PREVIOUS ! 13054: * STATEMENT. ZERO FOR 1ST STATEMENT. ! 13055: * ! 13056: * CMFFP(XS) SET NON-ZERO IF CDFAL IN PREVIOUS ! 13057: * CDBLK NEEDS FILLING WITH FORWARD ! 13058: * POINTER, ELSE SET TO ZERO. ! 13059: * ! 13060: * CMFFC(XS) SAME AS CMFFP FOR CURRENT CDBLK ! 13061: * ! 13062: * CMSOP(XS) OFFSET TO WORD IN PREVIOUS CDBLK ! 13063: * TO BE FILLED IN WITH FORWARD PTR ! 13064: * TO NEXT CDBLK FOR SUCCESS GOTO. ! 13065: * ZERO IF NO FILL IN IS REQUIRED. ! 13066: * ! 13067: * CMSOC(XS) SAME AS CMSOP FOR CURRENT CDBLK. ! 13068: * ! 13069: * CMLBL(XS) POINTER TO VRBLK FOR LABEL OF ! 13070: * CURRENT STATEMENT. ZERO IF NO LABEL ! 13071: * ! 13072: * CMTRA(XS) POINTER TO CDBLK FOR ENTRY STMNT. ! 13073: EJC ! 13074: * ! 13075: * CMPIL (CONTINUED) ! 13076: * ! 13077: * ENTRY POINT ! 13078: * ! 13079: CMPIL PRC E,0 ENTRY POINT ! 13080: LCT WB,=CMNEN SET NUMBER OF STACK WORK LOCATIONS ! 13081: * ! 13082: * LOOP TO INITIALIZE STACK WORKING LOCATIONS ! 13083: * ! 13084: CMP00 ZER -(XS) STORE A ZERO, MAKE ONE ENTRY ! 13085: BCT WB,CMP00 LOOP BACK UNTIL ALL SET ! 13086: MOV XS,CMPXS SAVE STACK POINTER FOR ERROR SEC ! 13087: SSS CMPSS SAVE S-R STACK POINTER IF ANY ! 13088: * ! 13089: * LOOP THROUGH STATEMENTS ! 13090: * ! 13091: CMP01 MOV SCNPT,WB SET SCAN POINTER OFFSET ! 13092: MOV WB,SCNSE SET START OF ELEMENT LOCATION ! 13093: MOV =OCER$,WA POINT TO COMPILE ERROR CALL ! 13094: JSR CDWRD GENERATE AS TEMPORARY CDFAL ! 13095: BLT WB,SCNIL,CMP04 JUMP IF CHARS LEFT ON THIS IMAGE ! 13096: * ! 13097: * LOOP HERE AFTER COMMENT OR CONTROL CARD ! 13098: * ALSO SPECIAL ENTRY AFTER CONTROL CARD ERROR ! 13099: * ! 13100: CMPCE ZER XR CLEAR POSSIBLE GARBAGE XR VALUE ! 13101: BEQ STAGE,=STGIC,CMPC1 READ IF INITIAL COMPILE ! 13102: BZE R$COP,CMP02 ELSE SKIP IF NO -COPY IN FORCE ! 13103: * ! 13104: * HERE TO ATTEMPT READ (STGIC OR -COPY) ! 13105: * ! 13106: CMPC1 JSR READR READ NEXT INPUT IMAGE ! 13107: BZE XR,CMPC2 JUMP IF NO INPUT AVAILABLE ! 13108: JSR NEXTS ACQUIRE NEXT SOURCE IMAGE ! 13109: MOV CMPSN,LSTSN STORE STMT NO FOR USE BY LISTR ! 13110: ZER SCNPT RESET SCAN POINTER ! 13111: BRN CMP04 GO PROCESS IMAGE ! 13112: * ! 13113: * HERE IF READR HAD NOTHING TO RETURN. IF NOT DURING ! 13114: * INITIAL COMPILE, THEN MUST BE AT OUTER LEVEL OF -COPY ! 13115: * IN CODE(). R$CIM HAS BEEN RESTORED TO CODE STRING ! 13116: * BY COPND SO WE CONTINUE FROM THE -COPY STMT. ! 13117: * ! 13118: CMPC2 BEQ STAGE,=STGIC,CMP09 JUMP IF INITIAL COMPILE ! 13119: * ! 13120: * FOR EXECUTE TIME COMPILE, PERMIT EMBEDDED CONTROL CARDS ! 13121: * AND COMMENTS (BY SKIPPING TO NEXT SEMI-COLON) ! 13122: * ! 13123: CMP02 MOV R$CIM,XR GET CURRENT IMAGE ! 13124: MOV SCNPT,WB GET CURRENT OFFSET ! 13125: PLC XR,WB PREPARE TO GET CHARS ! 13126: * ! 13127: * SKIP TO SEMI-COLON ! 13128: * ! 13129: CMP03 LCH WC,(XR)+ GET CHAR ! 13130: ICV SCNPT ADVANCE OFFSET ! 13131: BEQ WC,=CH$SM,CMP04 SKIP IF SEMI-COLON FOUND ! 13132: BLT SCNPT,SCNIL,CMP03 LOOP IF MORE CHARS ! 13133: ZER XR CLEAR GARBAGE XR VALUE ! 13134: BRN CMP09 END OF IMAGE ! 13135: EJC ! 13136: * ! 13137: * CMPIL (CONTINUED) ! 13138: * ! 13139: * HERE WITH IMAGE AVAILABLE TO SCAN. NOTE THAT IF THE INPUT ! 13140: * STRING IS NULL, THEN EVERYTHING IS OK SINCE NULL IS ! 13141: * ACTUALLY ASSEMBLED AS A WORD OF BLANKS. ! 13142: * ! 13143: CMP04 MOV R$CIM,XR POINT TO CURRENT IMAGE ! 13144: MOV SCNPT,WB LOAD CURRENT OFFSET ! 13145: MOV WB,WA COPY FOR LABEL SCAN ! 13146: PLC XR,WB POINT TO FIRST CHARACTER ! 13147: LCH WC,(XR)+ LOAD FIRST CHARACTER ! 13148: BEQ WC,=CH$SM,CMP12 NO LABEL IF SEMICOLON ! 13149: BEQ WC,=CH$AS,CMPCE LOOP BACK IF COMMENT CARD ! 13150: BEQ WC,=CH$MN,CMP33 JUMP IF CONTROL CARD ! 13151: MOV R$CIM,R$CMP ABOUT TO DESTROY R$CIM ! 13152: MOV =CMLAB,XL POINT TO LABEL WORK STRING ! 13153: MOV XL,R$CIM SCANE IS TO SCAN WORK STRING ! 13154: PSC XL POINT TO FIRST CHARACTER POSITION ! 13155: SCH WC,(XL)+ STORE CHAR JUST LOADED ! 13156: MOV =CH$SM,WC GET A SEMICOLON ! 13157: SCH WC,(XL) STORE AFTER FIRST CHAR ! 13158: CSC XL FINISHED CHARACTER STORING ! 13159: ZER XL CLEAR POINTER ! 13160: ZER SCNPT START AT FIRST CHARACTER ! 13161: MOV SCNIL,-(XS) PRESERVE IMAGE LENGTH ! 13162: MOV =NUM02,SCNIL READ 2 CHARS AT MOST ! 13163: JSR SCANE SCAN FIRST CHAR FOR TYPE ! 13164: MOV (XS)+,SCNIL RESTORE IMAGE LENGTH ! 13165: MOV XL,WC NOTE RETURN CODE ! 13166: MOV R$CMP,XL GET OLD R$CIM ! 13167: MOV XL,R$CIM PUT IT BACK ! 13168: MOV WB,SCNPT REINSTATE OFFSET ! 13169: BNZ SCNBL,CMP12 BLANK SEEN - CANT BE LABEL ! 13170: MOV XL,XR POINT TO CURRENT IMAGE ! 13171: PLC XR,WB POINT TO FIRST CHAR AGAIN ! 13172: BEQ WC,=T$VAR,CMP06 OK IF LETTER ! 13173: BEQ WC,=T$CON,CMP06 OK IF DIGIT ! 13174: * ! 13175: * DROP IN OR JUMP FROM ERROR SECTION IF SCANE FAILED ! 13176: * ! 13177: CMPLE MOV R$CMP,R$CIM POINT TO BAD LINE ! 13178: ERB 210,BAD LABEL OR MISPLACED CONTINUATION LINE ! 13179: * ! 13180: * LOOP TO SCAN LABEL ! 13181: * ! 13182: CMP05 BEQ WC,=CH$SM,CMP07 SKIP IF SEMICOLON ! 13183: ICV WA BUMP OFFSET ! 13184: BEQ WA,SCNIL,CMP07 JUMP IF END OF IMAGE (LABEL END) ! 13185: EJC ! 13186: * ! 13187: * CMPIL (CONTINUED) ! 13188: * ! 13189: * ENTER LOOP AT THIS POINT ! 13190: * ! 13191: CMP06 LCH WC,(XR)+ ELSE LOAD NEXT CHARACTER ! 13192: .IF .CAHT ! 13193: BEQ WC,=CH$HT,CMP07 JUMP IF HORIZONTAL TAB ! 13194: .FI ! 13195: .IF .CAVT ! 13196: BEQ WC,=CH$VT,CMP07 JUMP IF VERTICAL TAB ! 13197: .FI ! 13198: BNE WC,=CH$BL,CMP05 LOOP BACK IF NON-BLANK ! 13199: * ! 13200: * HERE AFTER SCANNING OUT LABEL ! 13201: * ! 13202: CMP07 MOV WA,SCNPT SAVE UPDATED SCAN OFFSET ! 13203: SUB WB,WA GET LENGTH OF LABEL ! 13204: BZE WA,CMP12 SKIP IF LABEL LENGTH ZERO ! 13205: ZER XR CLEAR GARBAGE XR VALUE ! 13206: JSR SBSTR BUILD SCBLK FOR LABEL NAME ! 13207: JSR GTNVR LOCATE/CONTRUCT VRBLK ! 13208: PPM DUMMY (IMPOSSIBLE) ERROR RETURN ! 13209: MOV XR,CMLBL(XS) STORE LABEL POINTER ! 13210: BNZ VRLEN(XR),CMP11 JUMP IF NOT SYSTEM LABEL ! 13211: BNE VRSVP(XR),=V$END,CMP11 JUMP IF NOT END LABEL ! 13212: * ! 13213: * HERE FOR END LABEL SCANNED OUT ! 13214: * ! 13215: ADD =STGND,STAGE ADJUST STAGE APPROPRIATELY ! 13216: JSR SCANE SCAN OUT NEXT ELEMENT ! 13217: BEQ XL,=T$SMC,CMPEE JUMP IF END OF IMAGE ! 13218: BNE XL,=T$VAR,CMP08 ELSE ERROR IF NOT VARIABLE ! 13219: * ! 13220: * HERE CHECK FOR VALID INITIAL TRANSFER ! 13221: * ! 13222: BEQ VRLBL(XR),=STNDL,CMP08 JUMP IF NOT DEFINED (ERROR) ! 13223: MOV VRLBL(XR),CMTRA(XS) ELSE SET INITIAL ENTRY POINTER ! 13224: JSR SCANE SCAN NEXT ELEMENT ! 13225: BEQ XL,=T$SMC,CMPEE JUMP IF OK (END OF IMAGE) ! 13226: * ! 13227: * HERE FOR BAD TRANSFER LABEL ! 13228: * ! 13229: CMP08 ERB 211,SYNTAX ERROR. UNDEFINED OR ERRONEOUS ENTRY LABEL ! 13230: * ! 13231: * HERE FOR END OF INPUT (NO END LABEL DETECTED) ! 13232: * ! 13233: CMP09 ADD =STGND,STAGE ADJUST STAGE APPROPRIATELY ! 13234: BEQ STAGE,=STGXE,CMPEE JUMP IF CODE CALL (OK) ! 13235: ERB 212,SYNTAX ERROR. MISSING END LINE ! 13236: * ! 13237: * HERE AFTER PROCESSING END LINE (MERGE HERE ON END ERROR) ! 13238: * ! 13239: CMPEE MOV =OSTP$,WA SET STOP CALL POINTER ! 13240: JSR CDWRD GENERATE AS STATEMENT CALL ! 13241: BRN CMPSE JUMP TO GENERATE AS FAILURE ! 13242: EJC ! 13243: * ! 13244: * CMPIL (CONTINUED) ! 13245: * ! 13246: * HERE AFTER PROCESSING LABEL OTHER THAN END ! 13247: * ! 13248: CMP11 BNE STAGE,=STGIC,CMP12 JUMP IF CODE CALL - REDEF. OK ! 13249: BEQ VRLBL(XR),=STNDL,CMP12 ELSE CHECK FOR REDEFINITION ! 13250: ZER CMLBL(XS) LEAVE FIRST LABEL DECLN UNDISTURBED ! 13251: ERB 213,SYNTAX ERROR. DUPLICATE LABEL ! 13252: * ! 13253: * HERE AFTER DEALING WITH LABEL ! 13254: * ! 13255: CMP12 ZER WB SET FLAG FOR STATEMENT BODY ! 13256: JSR EXPAN GET TREE FOR STATEMENT BODY ! 13257: MOV XR,CMSTM(XS) STORE FOR LATER USE ! 13258: ZER CMSGO(XS) CLEAR SUCCESS GOTO POINTER ! 13259: ZER CMFGO(XS) CLEAR FAILURE GOTO POINTER ! 13260: ZER CMCGO(XS) CLEAR CONDITIONAL GOTO FLAG ! 13261: JSR SCANE SCAN NEXT ELEMENT ! 13262: BNE XL,=T$COL,CMP18 JUMP IT NOT COLON (NO GOTO) ! 13263: * ! 13264: * LOOP TO PROCESS GOTO FIELDS ! 13265: * ! 13266: CMP13 MNZ SCNGO SET GOTO FLAG ! 13267: JSR SCANE SCAN NEXT ELEMENT ! 13268: BEQ XL,=T$SMC,CMP32 JUMP IF NO FIELDS LEFT ! 13269: BEQ XL,=T$SGO,CMP14 JUMP IF S FOR SUCCESS GOTO ! 13270: BEQ XL,=T$FGO,CMP16 JUMP IF F FOR FAILURE GOTO ! 13271: * ! 13272: * HERE FOR UNCONDITIONAL GOTO (I.E. NOT F OR S) ! 13273: * ! 13274: MNZ SCNRS SET TO RESCAN ELEMENT NOT F,S ! 13275: JSR SCNGF SCAN OUT GOTO FIELD ! 13276: BNZ CMFGO(XS),CMP17 ERROR IF FGOTO ALREADY ! 13277: MOV XR,CMFGO(XS) ELSE SET AS FGOTO ! 13278: BRN CMP15 MERGE WITH SGOTO CIRCUIT ! 13279: * ! 13280: * HERE FOR SUCCESS GOTO ! 13281: * ! 13282: CMP14 JSR SCNGF SCAN SUCCESS GOTO FIELD ! 13283: MOV =NUM01,CMCGO(XS) SET CONDITIONAL GOTO FLAG ! 13284: * ! 13285: * UNCONTIONAL GOTO MERGES HERE ! 13286: * ! 13287: CMP15 BNZ CMSGO(XS),CMP17 ERROR IF SGOTO ALREADY GIVEN ! 13288: MOV XR,CMSGO(XS) ELSE SET SGOTO ! 13289: BRN CMP13 LOOP BACK FOR NEXT GOTO FIELD ! 13290: * ! 13291: * HERE FOR FAILURE GOTO ! 13292: * ! 13293: CMP16 JSR SCNGF SCAN GOTO FIELD ! 13294: MOV =NUM01,CMCGO(XS) SET CONDITONAL GOTO FLAG ! 13295: BNZ CMFGO(XS),CMP17 ERROR IF FGOTO ALREADY GIVEN ! 13296: MOV XR,CMFGO(XS) ELSE STORE FGOTO POINTER ! 13297: BRN CMP13 LOOP BACK FOR NEXT FIELD ! 13298: EJC ! 13299: * ! 13300: * CMPIL (CONTINUED) ! 13301: * ! 13302: * HERE FOR DUPLICATED GOTO FIELD ! 13303: * ! 13304: CMP17 ERB 214,SYNTAX ERROR. DUPLICATED GOTO FIELD ! 13305: * ! 13306: * HERE TO GENERATE CODE ! 13307: * ! 13308: CMP18 ZER SCNSE STOP POSITIONAL ERROR FLAGS ! 13309: MOV CMSTM(XS),XR LOAD TREE PTR FOR STATEMENT BODY ! 13310: ZER WB COLLECTABLE VALUE FOR WB FOR CDGVL ! 13311: ZER WC RESET CONSTANT FLAG FOR CDGVL ! 13312: JSR EXPAP TEST FOR PATTERN MATCH ! 13313: PPM CMP19 JUMP IF NOT PATTERN MATCH ! 13314: MOV =OPMS$,CMOPN(XR) ELSE SET PATTERN MATCH POINTER ! 13315: MOV =C$PMT,CMTYP(XR) ! 13316: * ! 13317: * HERE AFTER DEALING WITH SPECIAL PATTERN MATCH CASE ! 13318: * ! 13319: CMP19 JSR CDGVL GENERATE CODE FOR BODY OF STATEMENT ! 13320: MOV CMSGO(XS),XR LOAD SGOTO POINTER ! 13321: MOV XR,WA COPY IT ! 13322: BZE XR,CMP21 JUMP IF NO SUCCESS GOTO ! 13323: ZER CMSOC(XS) CLEAR SUCCESS OFFSET FILLIN PTR ! 13324: BHI XR,STATE,CMP20 JUMP IF COMPLEX GOTO ! 13325: * ! 13326: * HERE FOR SIMPLE SUCCESS GOTO (LABEL) ! 13327: * ! 13328: ADD *VRTRA,WA POINT TO VRTRA FIELD AS REQUIRED ! 13329: JSR CDWRD GENERATE SUCCESS GOTO ! 13330: BRN CMP22 JUMP TO DEAL WITH FGOTO ! 13331: * ! 13332: * HERE FOR COMPLEX SUCCESS GOTO ! 13333: * ! 13334: CMP20 BEQ XR,CMFGO(XS),CMP22 NO CODE IF SAME AS FGOTO ! 13335: ZER WB ELSE SET OK VALUE FOR CDGVL IN WB ! 13336: JSR CDGCG GENERATE CODE FOR SUCCESS GOTO ! 13337: BRN CMP22 JUMP TO DEAL WITH FGOTO ! 13338: * ! 13339: * HERE FOR NO SUCCESS GOTO ! 13340: * ! 13341: CMP21 MOV CWCOF,CMSOC(XS) SET SUCCESS FILL IN OFFSET ! 13342: MOV =OCER$,WA POINT TO COMPILE ERROR CALL ! 13343: JSR CDWRD GENERATE AS TEMPORARY VALUE ! 13344: EJC ! 13345: * ! 13346: * CMPIL (CONTINUED) ! 13347: * ! 13348: * HERE TO DEAL WITH FAILURE GOTO ! 13349: * ! 13350: CMP22 MOV CMFGO(XS),XR LOAD FAILURE GOTO POINTER ! 13351: MOV XR,WA COPY IT ! 13352: ZER CMFFC(XS) SET NO FILL IN REQUIRED YET ! 13353: BZE XR,CMP23 JUMP IF NO FAILURE GOTO GIVEN ! 13354: ADD *VRTRA,WA POINT TO VRTRA FIELD IN CASE ! 13355: BLO XR,STATE,CMPSE JUMP TO GEN IF SIMPLE FGOTO ! 13356: * ! 13357: * HERE FOR COMPLEX FAILURE GOTO ! 13358: * ! 13359: MOV CWCOF,WB SAVE OFFSET TO O$GOF CALL ! 13360: MOV =OGOF$,WA POINT TO FAILURE GOTO CALL ! 13361: JSR CDWRD GENERATE ! 13362: MOV =OFIF$,WA POINT TO FAIL IN FAIL WORD ! 13363: JSR CDWRD GENERATE ! 13364: JSR CDGCG GENERATE CODE FOR FAILURE GOTO ! 13365: MOV WB,WA COPY OFFSET TO O$GOF FOR CDFAL ! 13366: MOV =B$CDC,WB SET COMPLEX CASE CDTYP ! 13367: BRN CMP25 JUMP TO BUILD CDBLK ! 13368: * ! 13369: * HERE IF NO FAILURE GOTO GIVEN ! 13370: * ! 13371: CMP23 MOV =OUNF$,WA LOAD UNEXPECTED FAILURE CALL IN CAS ! 13372: MOV CSWFL,WC GET -NOFAIL FLAG ! 13373: ORB CMCGO(XS),WC CHECK IF CONDITIONAL GOTO ! 13374: ZRB WC,CMPSE JUMP IF -NOFAIL AND NO COND. GOTO ! 13375: MNZ CMFFC(XS) ELSE SET FILL IN FLAG ! 13376: MOV =OCER$,WA AND SET COMPILE ERROR FOR TEMPORARY ! 13377: * ! 13378: * MERGE HERE WITH CDFAL VALUE IN WA, SIMPLE CDBLK ! 13379: * ALSO SPECIAL ENTRY AFTER STATEMENT ERROR ! 13380: * ! 13381: CMPSE MOV =B$CDS,WB SET CDTYP FOR SIMPLE CASE ! 13382: EJC ! 13383: * ! 13384: * CMPIL (CONTINUED) ! 13385: * ! 13386: * MERGE HERE TO BUILD CDBLK ! 13387: * ! 13388: * (WA) CDFAL VALUE TO BE GENERATED ! 13389: * (WB) CDTYP VALUE TO BE GENERATED ! 13390: * ! 13391: * AT THIS STAGE, WE CHOP OFF AN APPROPRIATE CHUNK OF THE ! 13392: * CURRENT CCBLK AND CONVERT IT INTO A CDBLK. THE REMAINDER ! 13393: * OF THE CCBLK IS REFORMATTED TO BE THE NEW CCBLK. ! 13394: * ! 13395: CMP25 MOV R$CCB,XR POINT TO CCBLK ! 13396: MOV CMLBL(XS),XL GET POSSIBLE LABEL POINTER ! 13397: BZE XL,CMP26 SKIP IF NO LABEL ! 13398: ZER CMLBL(XS) CLEAR FLAG FOR NEXT STATEMENT ! 13399: MOV XR,VRLBL(XL) PUT CDBLK PTR IN VRBLK LABEL FIELD ! 13400: * ! 13401: * MERGE AFTER DOING LABEL ! 13402: * ! 13403: CMP26 MOV WB,(XR) SET TYPE WORD FOR NEW CDBLK ! 13404: MOV WA,CDFAL(XR) SET FAILURE WORD ! 13405: MOV XR,XL COPY POINTER TO CCBLK ! 13406: MOV CCUSE(XR),WB LOAD LENGTH GEN (= NEW CDLEN) ! 13407: MOV CCLEN(XR),WC LOAD TOTAL CCBLK LENGTH ! 13408: ADD WB,XL POINT PAST CDBLK ! 13409: SUB WB,WC GET LENGTH LEFT FOR CHOP OFF ! 13410: MOV =B$CCT,(XL) SET TYPE CODE FOR NEW CCBLK AT END ! 13411: MOV *CCCOD,CCUSE(XL) SET INITIAL CODE OFFSET ! 13412: MOV *CCCOD,CWCOF REINITIALISE CWCOF ! 13413: MOV WC,CCLEN(XL) SET NEW LENGTH ! 13414: MOV XL,R$CCB SET NEW CCBLK POINTER ! 13415: MOV CMPSN,CDSTM(XR) SET STATEMENT NUMBER ! 13416: ICV CMPSN BUMP STATEMENT NUMBER ! 13417: * ! 13418: * SET POINTERS IN PREVIOUS CODE BLOCK AS REQUIRED ! 13419: * ! 13420: MOV CMPCD(XS),XL LOAD PTR TO PREVIOUS CDBLK ! 13421: BZE CMFFP(XS),CMP27 JUMP IF NO FAILURE FILL IN REQUIRED ! 13422: MOV XR,CDFAL(XL) ELSE SET FAILURE PTR IN PREVIOUS ! 13423: * ! 13424: * HERE TO DEAL WITH SUCCESS FORWARD POINTER ! 13425: * ! 13426: CMP27 MOV CMSOP(XS),WA LOAD SUCCESS OFFSET ! 13427: BZE WA,CMP28 JUMP IF NO FILL IN REQUIRED ! 13428: ADD WA,XL ELSE POINT TO FILL IN LOCATION ! 13429: MOV XR,(XL) STORE FORWARD POINTER ! 13430: ZER XL CLEAR GARBAGE XL VALUE ! 13431: EJC ! 13432: * ! 13433: * CMPIL (CONTINUED) ! 13434: * ! 13435: * NOW SET FILL IN POINTERS FOR THIS STATEMENT ! 13436: * ! 13437: CMP28 MOV CMFFC(XS),CMFFP(XS) COPY FAILURE FILL IN FLAG ! 13438: MOV CMSOC(XS),CMSOP(XS) COPY SUCCESS FILL IN OFFSET ! 13439: MOV XR,CMPCD(XS) SAVE PTR TO THIS CDBLK ! 13440: BNZ CMTRA(XS),CMP29 JUMP IF INITIAL ENTRY ALREADY SET ! 13441: MOV XR,CMTRA(XS) ELSE SET PTR HERE AS DEFAULT ! 13442: * ! 13443: * HERE AFTER COMPILING ONE STATEMENT ! 13444: * ! 13445: CMP29 BLT STAGE,=STGCE,CMP01 JUMP IF NOT END LINE JUST DONE ! 13446: BZE CSWLS,CMP30 SKIP IF -NOLIST ! 13447: JSR LISTR LIST LAST LINE ! 13448: * ! 13449: * RETURN ! 13450: * ! 13451: CMP30 MOV CMTRA(XS),XR LOAD INITIAL ENTRY CDBLK POINTER ! 13452: ADD *CMNEN,XS POP WORK LOCATIONS OFF STACK ! 13453: * ! 13454: * LOOP TO UNNEST ANY OUTSTANDING -COPY LEVELS ! 13455: * ! 13456: CMP31 JSR COPND CALL TO UNNEST -COPY ! 13457: BNZ R$COP,CMP31 LOOP IF NOT ALL -COPYS CLOSED ! 13458: EXI RETURN TO CMPIL CALLER ! 13459: * ! 13460: * HERE AT END OF GOTO FIELD ! 13461: * ! 13462: CMP32 MOV CMFGO(XS),WB GET FAIL GOTO ! 13463: ORB CMSGO(XS),WB OR IN SUCCESS GOTO ! 13464: BNZ WB,CMP18 OK IF NON-NULL FIELD ! 13465: ERB 215,SYNTAX ERROR. EMPTY GOTO FIELD ! 13466: * ! 13467: * CONTROL CARD FOUND ! 13468: * ! 13469: CMP33 ICV WB POINT PAST CH$MN ! 13470: JSR CNCRD PROCESS CONTROL CARD ! 13471: ZER SCNSE CLEAR START OF ELEMENT LOC. ! 13472: BRN CMPCE LOOP FOR NEXT STATEMENT ! 13473: ENP END PROCEDURE CMPIL ! 13474: EJC ! 13475: * ! 13476: * CNCRD -- CONTROL CARD PROCESSOR ! 13477: * ! 13478: * CALLED TO DEAL WITH CONTROL CARDS ! 13479: * ! 13480: * R$CIM POINTS TO CURRENT IMAGE ! 13481: * (WB) OFFSET TO 1ST CHAR OF CONTROL CARD ! 13482: * JSR CNCRD CALL TO PROCESS CONTROL CARDS ! 13483: * (XL,XR,WA,WB,WC,IA) DESTROYED ! 13484: * ! 13485: CNCRD PRC E,0 ENTRY POINT ! 13486: MOV WB,SCNPT OFFSET FOR CONTROL CARD SCAN ! 13487: MOV =CCNOC,WA NUMBER OF CHARS FOR COMPARISON ! 13488: CTW WA,0 CONVERT TO WORD COUNT ! 13489: MOV WA,CNSWC SAVE WORD COUNT ! 13490: * ! 13491: * LOOP HERE IF MORE THAN ONE CONTROL CARD ! 13492: * ! 13493: CNC01 BGE SCNPT,SCNIL,CNC10 RETURN IF END OF IMAGE ! 13494: MOV R$CIM,XR POINT TO IMAGE ! 13495: PLC XR,SCNPT CHAR PTR FOR FIRST CHAR ! 13496: LCH WA,(XR)+ GET FIRST CHAR ! 13497: BEQ WA,=CH$LI,CNC07 SPECIAL CASE OF -INXXX ! 13498: .IF .CASL ! 13499: BEQ WA,=CH$$I,CNC07 DITTO (LC) ! 13500: .FI ! 13501: MNZ SCNCC SET FLAG FOR SCANE ! 13502: JSR SCANE SCAN CARD NAME ! 13503: ZER SCNCC CLEAR SCANE FLAG ! 13504: BNZ XL,CNC06 FAIL UNLESS CONTROL CARD NAME ! 13505: MOV =CCNOC,WA NO. OF CHARS TO BE COMPARED ! 13506: BLT SCLEN(XR),WA,CNC06 FAIL IF TOO FEW CHARS ! 13507: MOV XR,XL POINT TO CONTROL CARD NAME ! 13508: ZER WB ZERO OFFSET FOR SUBSTRING ! 13509: .IF .CASL ! 13510: JSR SBSCC CONVERT CASE BEFORE COMPARISON ! 13511: .ELSE ! 13512: JSR SBSTR EXTRACT SUBSTRING FOR COMPARISON ! 13513: .FI ! 13514: MOV XR,CNSCC KEEP CONTROL CARD SUBSTRING PTR ! 13515: MOV =CCNMS,XR POINT TO LIST OF STANDARD NAMES ! 13516: ZER WB INITIALISE NAME OFFSET ! 13517: LCT WC,=CC$CT NUMBER OF STANDARD NAMES ! 13518: * ! 13519: * TRY TO MATCH NAME ! 13520: * ! 13521: CNC02 MOV CNSCC,XL POINT TO NAME ! 13522: LCT WA,CNSWC COUNTER FOR INNER LOOP ! 13523: BRN CNC04 JUMP INTO LOOP ! 13524: * ! 13525: * INNER LOOP TO MATCH CARD NAME CHARS ! 13526: * ! 13527: CNC03 ICA XR BUMP STANDARD NAMES PTR ! 13528: ICA XL BUMP NAME POINTER ! 13529: * ! 13530: * HERE TO INITIATE THE LOOP ! 13531: * ! 13532: CNC04 CNE SCHAR(XL),(XR),CNC05 COMP. UP TO CFP$C CHARS AT ONCE ! 13533: BCT WA,CNC03 LOOP IF MORE WORDS TO COMPARE ! 13534: EJC ! 13535: * ! 13536: * CNCRD (CONTINUED) ! 13537: * ! 13538: * MATCHED - BRANCH ON CARD OFFSET ! 13539: * ! 13540: MOV WB,XL GET NAME OFFSET ! 13541: BSW XL,CC$CT SWITCH ! 13542: .IF .CASL ! 13543: IFF CC$CI,CNC11 -CASEIG ! 13544: .FI ! 13545: IFF CC$CO,CNC23 -COPY ! 13546: IFF CC$EJ,CNC12 -EJECT ! 13547: IFF CC$FA,CNC13 -FAIL ! 13548: IFF CC$LI,CNC14 -LIST ! 13549: .IF .CASL ! 13550: IFF CC$NC,CNC15 -NOCASEIG ! 13551: .FI ! 13552: IFF CC$NF,CNC16 -NOFAIL ! 13553: IFF CC$NL,CNC17 -NOLIST ! 13554: IFF CC$ST,CNC18 -STITLE ! 13555: IFF CC$TI,CNC19 -TITLE ! 13556: IFF CC$TR,CNC22 -TRACE ! 13557: ESW END SWITCH ! 13558: * ! 13559: * NOT MATCHED YET. ALIGN STD NAMES PTR AND TRY AGAIN ! 13560: * ! 13561: CNC05 ICA XR BUMP STANDARD NAMES PTR ! 13562: BCT WA,CNC05 LOOP ! 13563: ICV WB BUMP NAMES OFFSET ! 13564: BCT WC,CNC02 CONTINUE IF MORE NAMES ! 13565: * ! 13566: * INVALID CONTROL CARD NAME ! 13567: * ! 13568: CNC06 ERB 216,INVALID CONTROL CARD ! 13569: * ! 13570: * SPECIAL PROCESSING FOR -INXXX ! 13571: * ! 13572: CNC07 LCH WA,(XR) GET NEXT CHAR ! 13573: .IF .CASL ! 13574: BEQ WA,=CH$$N,CNC08 SKIP IF LC N ! 13575: .FI ! 13576: BNE WA,=CH$LN,CNC06 FAIL IF NOT LETTER N ! 13577: .IF .CASL ! 13578: CNC08 ADD =NUM02,SCNPT BUMP OFFSET PAST -IN ! 13579: .ELSE ! 13580: ADD =NUM02,SCNPT BUMP OFFSET PAST -IN ! 13581: .FI ! 13582: JSR SCANE SCAN INTEGER AFTER -IN ! 13583: MOV XR,-(XS) STACK SCANNED ITEM ! 13584: JSR GTSMI CHECK IF INTEGER ! 13585: PPM CNC06 FAIL IF NOT INTEGER ! 13586: PPM CNC06 FAIL IF NEGATIVE OR LARGE ! 13587: MOV XR,CSWIN KEEP INTEGER ! 13588: EJC ! 13589: * ! 13590: * CNCRD (CONTINUED) ! 13591: * ! 13592: * CHECK FOR MORE CONTROL CARDS BEFORE RETURNING ! 13593: * ! 13594: CNC09 MOV SCNPT,WA PRESERVE IN CASE XEQ TIME COMPILE ! 13595: JSR SCANE LOOK FOR COMMA ! 13596: BEQ XL,=T$CMA,CNC01 LOOP IF COMMA FOUND ! 13597: MOV WA,SCNPT RESTORE SCNPT IN CASE XEQ TIME ! 13598: * ! 13599: * RETURN POINT ! 13600: * ! 13601: CNC10 EXI RETURN ! 13602: .IF .CASL ! 13603: * ! 13604: * -CASEIG ! 13605: * ! 13606: CNC11 MNZ CSWCI SET SWITCH ! 13607: BRN CNC09 MERGE ! 13608: .FI ! 13609: * ! 13610: * -EJECT ! 13611: * ! 13612: CNC12 BZE CSWLS,CNC10 RETURN IF -NOLIST ! 13613: JSR PRTPS EJECT ! 13614: JSR LISTT LIST TITLE ! 13615: BRN CNC10 FINISHED ! 13616: * ! 13617: * -FAIL ! 13618: * ! 13619: CNC13 MNZ CSWFL SET SWITCH ! 13620: BRN CNC09 MERGE ! 13621: * ! 13622: * -LIST ! 13623: * ! 13624: CNC14 MNZ CSWLS SET SWITCH ! 13625: BRN CNC09 MERGE ! 13626: .IF .CASL ! 13627: * ! 13628: * -NOCASEIG ! 13629: * ! 13630: CNC15 ZER CSWCI CLEAR SWITCH ! 13631: BRN CNC09 MERGE ! 13632: .FI ! 13633: * ! 13634: * -NOFAIL ! 13635: * ! 13636: CNC16 ZER CSWFL CLEAR SWITCH ! 13637: BRN CNC09 MERGE ! 13638: EJC ! 13639: * ! 13640: * CNCRD (CONTINUED) ! 13641: * ! 13642: * -NOLIST ! 13643: * ! 13644: CNC17 ZER CSWLS CLEAR SWITCH ! 13645: BRN CNC09 MERGE ! 13646: * ! 13647: * -STITL ! 13648: * ! 13649: CNC18 MOV =R$STL,CNR$T PTR TO R$STL ! 13650: BRN CNC20 MERGE ! 13651: * ! 13652: * -TITLE ! 13653: * ! 13654: CNC19 MOV =NULLS,R$STL CLEAR SUBTITLE ! 13655: MOV =R$TTL,CNR$T PTR TO R$TTL ! 13656: * ! 13657: * COMMON PROCESSING FOR -TITLE, -STITL ! 13658: * ! 13659: CNC20 MOV =NULLS,XR NULL IN CASE NEEDED ! 13660: MNZ CNTTL SET FLAG FOR NEXT LISTR CALL ! 13661: MOV =CCOFS,WB OFFSET TO TITLE/SUBTITLE ! 13662: MOV SCNIL,WA INPUT IMAGE LENGTH ! 13663: BLO WA,WB,CNC21 JUMP IF NO CHARS LEFT ! 13664: SUB WB,WA NO OF CHARS TO EXTRACT ! 13665: MOV R$CIM,XL POINT TO IMAGE ! 13666: JSR SBSTR GET TITLE/SUBTITLE ! 13667: * ! 13668: * STORE TITLE/SUBTITLE ! 13669: * ! 13670: CNC21 MOV CNR$T,XL POINT TO STORAGE LOCATION ! 13671: MOV XR,(XL) STORE TITLE/SUBTITLE ! 13672: BRN CNC10 RETURN ! 13673: * ! 13674: * -TRACE ! 13675: * ! 13676: * PROVIDED FOR SYSTEM DEBUGGING. TOGGLES THE SYSTEM LABEL ! 13677: * TRACE SWITCH AT COMPILE TIME ! 13678: * ! 13679: CNC22 JSR SYSTT TOGGLE SWITCH ! 13680: BRN CNC09 MERGE ! 13681: * ! 13682: * -COPY ! 13683: * ! 13684: * GET FILETAG AND NOTIFY OSINT THAT WE ARE NESTING ! 13685: * ! 13686: CNC23 JSR SCANE GET FILETAG ! 13687: BNE =T$CON,XL,CNC06 ERR IF NOT CONSTANT ! 13688: BNE =B$SCL,(XR),CNC06 ERR IF NOT SCBLK ! 13689: JSR SYSSC CALL TO START COPY ! 13690: ERR 258,COPY FILE DOES NOT EXIST ! 13691: PPM EROSI ERROR RETURN (ALWAYS) ! 13692: MOV WA,WB SAVE IOTAG FROM OSINT ! 13693: MOV *COSI$,WA GET SIZE OF COPY BLOCK ! 13694: JSR ALLOC ALLOCATE ! 13695: MOV =B$COP,COTYP(XR) SET TYPE ! 13696: MOV R$COP,CONXT(XR) PLACE AT FRONT OF STACK CHN ! 13697: MOV XR,R$COP SPLICE IT IN ! 13698: MOV WB,COIOT(XR) SAVE OSINT IOTAG ! 13699: MOV TTINS,COTTI(XR) SAVE TTINS ! 13700: ZER TTINS INPUT NOT FROM TERMINAL NOW ! 13701: MOV R$CIM,COCIM(XR) SAVE R$CIM IN CASE EXEC TIME ! 13702: MOV SCNPT,COSPT(XR) SAVE SCNPT IN CASE EXEC TIME ! 13703: MOV CSWLS,COSLS(XR) SAVE LIST FLAG ! 13704: MOV CSWIN,COSIN(XR) SAVE -INXXX VALUE ! 13705: MOV R$STL,COSTL(XR) SAVE SUBTITLE ! 13706: BZE CSWLS,CNC10 NO LIST -COPY IF -NOLIST ! 13707: JSR LISTR LIST -COPY CARD ! 13708: BRN CNC10 EXIT ! 13709: ENP END PROCEDURE CNCRD ! 13710: EJC ! 13711: * ! 13712: * COPND -- END -COPY NESTING ! 13713: * ! 13714: * COPND IS CALLED FROM CMPIL AND READR IN ORDER TO ! 13715: * UNNEST ONE LEVEL OF -COPY AND RESTORE THE PREVIOUS ! 13716: * INPUT COMPILE STRING. THE COPY BLOCK IS REMOVED ! 13717: * FROM THE CHAIN AND THE STATE RESTORED FROM IT. ! 13718: * ! 13719: * JSR COPND CALL TO END -COPY AT CUR. LEVEL ! 13720: * (XL,WA,WB,WC) DESTROYED ! 13721: * ! 13722: COPND PRC E,0 ENTRY POINT ! 13723: MOV R$COP,XL GET POINTER TO CURRENT COBLK ! 13724: BZE XL,COP02 EXIT IF NONE ! 13725: MOV CONXT(XL),R$COP TAKE OFF CHAIN ! 13726: MOV COIOT(XL),WA GET IOTAG FOR OSINT ! 13727: JSR SYSEC CALL TO END COPY ! 13728: PPM DO NOT USE ! 13729: PPM EROSI ERROR EXIT ! 13730: BZE CSWLS,COP01 SKIP LISTING IF -NOLIST ! 13731: JSR LISTR LIST CURRENT IMAGE ! 13732: * ! 13733: * MERGE AFTER POSSIBLE LISTING OF CURRENT IMAGE ! 13734: * ! 13735: COP01 MOV COTTI(XL),TTINS RESTORE TERMINAL INPUT FLAG ! 13736: MOV COSLS(XL),CSWLS RESTORE LISTING STATE ! 13737: MOV COSPT(XL),SCNPT GET OLD SCAN POINTER ! 13738: MOV COSIN(XL),CSWIN OLD INPUT IMAGE LENGTH ! 13739: MOV COSTL(XL),R$STL RESTORE SUBTITLE STRING ! 13740: MNZ LSTPF THIS IMAGE LISTED IN CNCRD ! 13741: MOV COCIM(XL),XL GET OLD COMPILER IMAGE SCBLK ! 13742: MOV XL,R$CIM RESTORE IT ! 13743: MOV SCLEN(XL),SCNIL SET INPUT IMAGE LENGTH TOO ! 13744: * ! 13745: * MERGE TO EXIT ! 13746: * ! 13747: COP02 EXI RETURN TO CALLER ! 13748: ENP END PROCEDURE COPND ! 13749: EJC ! 13750: * ! 13751: * DFFNC -- DEFINE FUNCTION ! 13752: * ! 13753: * DFFNC IS CALLED WHENEVER A NEW FUNCTION IS ASSIGNED TO ! 13754: * A VARIABLE. IT DEALS WITH EXTERNAL FUNCTION USE COUNTS. ! 13755: * ! 13756: * (XR) POINTER TO VRBLK ! 13757: * (XL) POINTER TO NEW FUNCTION BLOCK ! 13758: * JSR DFFNC CALL TO DEFINE FUNCTION ! 13759: * (WA,WB) DESTROYED ! 13760: * ! 13761: DFFNC PRC E,0 ENTRY POINT ! 13762: .IF .CNLD ! 13763: .ELSE ! 13764: BNE (XL),=B$EFC,DFFN1 SKIP IF NEW FUNCTION NOT EXTERNAL ! 13765: ICV EFUSE(XL) ELSE INCREMENT ITS USE COUNT ! 13766: * ! 13767: * HERE AFTER DEALING WITH NEW FUNCTION USE COUNT ! 13768: * ! 13769: DFFN1 MOV XR,WA SAVE VRBLK POINTER ! 13770: MOV VRFNC(XR),XR LOAD OLD FUNCTION POINTER ! 13771: BNE (XR),=B$EFC,DFFN2 JUMP IF OLD FUNCTION NOT EXTERNAL ! 13772: MOV EFUSE(XR),WB ELSE GET USE COUNT ! 13773: DCV WB DECREMENT ! 13774: MOV WB,EFUSE(XR) STORE DECREMENTED VALUE ! 13775: BNZ WB,DFFN2 JUMP IF USE COUNT STILL NON-ZERO ! 13776: JSR SYSUL ELSE CALL SYSTEM UNLOAD FUNCTION ! 13777: * ! 13778: * HERE AFTER DEALING WITH OLD FUNCTION USE COUNT ! 13779: * ! 13780: DFFN2 MOV WA,XR RESTORE VRBLK POINTER ! 13781: .FI ! 13782: MOV XL,WA COPY FUNCTION BLOCK PTR ! 13783: BLT XR,=R$YYY,DFFN3 SKIP CHECKS IF OPSYN OP DEFINITION ! 13784: BNZ VRLEN(XR),DFFN3 JUMP IF NOT SYSTEM VARIABLE ! 13785: * ! 13786: * FOR SYSTEM VARIABLE, CHECK FOR ILLEGAL REDEFINITION ! 13787: * ! 13788: MOV VRSVP(XR),XL POINT TO SVBLK ! 13789: MOV SVBIT(XL),WB LOAD BIT INDICATORS ! 13790: ANB BTFNC,WB IS IT A SYSTEM FUNCTION ! 13791: ZRB WB,DFFN3 REDEF OK IF NOT ! 13792: ERB 217,ATTEMPTED REDEFINITION OF SYSTEM FUNCTION ! 13793: * ! 13794: * HERE IF REDEFINITION IS PERMITTED ! 13795: * ! 13796: DFFN3 MOV WA,VRFNC(XR) STORE NEW FUNCTION POINTER ! 13797: MOV WA,XL RESTORE FUNCTION BLOCK POINTER ! 13798: EXI RETURN TO DFFNC CALLER ! 13799: ENP END PROCEDURE DFFNC ! 13800: EJC ! 13801: * ! 13802: * DTYPE -- GET DATATYPE NAME ! 13803: * ! 13804: * (XR) OBJECT WHOSE DATATYPE IS REQUIRED ! 13805: * JSR DTYPE CALL TO GET DATATYPE ! 13806: * (XR) RESULT DATATYPE ! 13807: * ! 13808: DTYPE PRC E,0 ENTRY POINT ! 13809: BEQ (XR),=B$PDT,DTYP1 JUMP IF PROG.DEFINED ! 13810: MOV (XR),XR LOAD TYPE WORD ! 13811: LEI XR GET ENTRY POINT ID (BLOCK CODE) ! 13812: WTB XR CONVERT TO BAU OFFSET ! 13813: MOV SCNMT(XR),XR LOAD TABLE ENTRY ! 13814: EXI EXIT TO DTYPE CALLER ! 13815: * ! 13816: * HERE IF PROGRAM DEFINED ! 13817: * ! 13818: DTYP1 MOV PDDFP(XR),XR POINT TO DFBLK ! 13819: MOV DFNAM(XR),XR GET DATATYPE NAME FROM DFBLK ! 13820: EXI RETURN TO DTYPE CALLER ! 13821: ENP END PROCEDURE DTYPE ! 13822: EJC ! 13823: * ! 13824: * DUMPR -- PRINT DUMP OF STORAGE ! 13825: * ! 13826: * (XR) DUMP ARGUMENT (SEE BELOW) ! 13827: * JSR DUMPR CALL TO PRINT DUMP ! 13828: * (XR,XL) DESTROYED ! 13829: * (WA,WB,WC,RA) DESTROYED ! 13830: * ! 13831: * THE DUMP ARGUMENT HAS THE FOLLOWING SIGNIFICANCE ! 13832: * ! 13833: * DMARG = 0 NO DUMP PRINTED ! 13834: * DMARG = 1 PARTIAL DUMP (NAT VARS, KEYWORDS) ! 13835: * DMARG GE 2 FULL DUMP (INCL ARRAYS ETC.) ! 13836: * ! 13837: * SINCE DUMPR SCRAMBLES STORE, IT IS NOT PERMISSIBLE TO ! 13838: * COLLECT IN MID-DUMP. HENCE A COLLECT IS DONE INITIALLY ! 13839: * AND THEN IF STORE RUNS OUT AN ERROR MESSAGE IS PRODUCED. ! 13840: * ! 13841: DUMPR PRC E,0 ENTRY POINT ! 13842: BZE XR,DMP28 SKIP DUMP IF ARGUMENT IS ZERO ! 13843: ZER XL CLEAR XL ! 13844: ZER WB ZERO MOVE OFFSET ! 13845: MOV XR,DMARG SAVE DUMP ARGUMENT ! 13846: JSR GBCOL COLLECT GARBAGE ! 13847: JSR PRTPG EJECT PRINTER ! 13848: MOV =DMHDV,XR POINT TO HEADING FOR VARIABLES ! 13849: JSR PRTFB PRINT IT ! 13850: * ! 13851: * FIRST ALL NATURAL VARIABLE BLOCKS (VRBLK) WHOSE VALUES ! 13852: * ARE NON-NULL ARE LINKED IN LEXICAL ORDER USING DMVCH AS ! 13853: * THE CHAIN HEAD AND CHAINING THROUGH THE VRGET FIELDS. ! 13854: * NOTE THAT THIS SCRAMBLES STORE IF THE PROCESS IS ! 13855: * INTERRUPTED BEFORE COMPLETION E.G. BY EXCEEDING TIME OR ! 13856: * PRINT LIMITS. SINCE THE SUBSEQUENT CORE DUMPS AND ! 13857: * FAILURES IF EXECUTION IS RESUMED ARE VERY CONFUSING, THE ! 13858: * EXECUTION TIME ERROR ROUTINE CHECKS FOR THIS EVENT AND ! 13859: * ATTEMPTS AN UNSCRAMBLE. SIMILAR PRECAUTIONS SHOULD BE ! 13860: * OBSERVED IF TRANSLATE TIME DUMPING IS IMPLEMENTED. ! 13861: * ! 13862: ZER DMVCH SET NULL CHAIN TO START ! 13863: MOV HSHTB,WA POINT TO HASH TABLE ! 13864: * ! 13865: * LOOP THROUGH HEADERS IN HASH TABLE ! 13866: * ! 13867: DMP00 MOV WA,XR COPY HASH BUCKET POINTER ! 13868: ICA WA BUMP POINTER ! 13869: SUB *VRNXT,XR SET OFFSET TO MERGE ! 13870: * ! 13871: * LOOP THROUGH VRBLKS ON ONE CHAIN ! 13872: * ! 13873: DMP01 MOV VRNXT(XR),XR POINT TO NEXT VRBLK ON CHAIN ! 13874: BZE XR,DMP09 JUMP IF END OF THIS HASH CHAIN ! 13875: MOV XR,XL ELSE COPY VRBLK POINTER ! 13876: EJC ! 13877: * ! 13878: * DUMPR (CONTINUED) ! 13879: * ! 13880: * LOOP TO FIND VALUE AND SKIP IF NULL ! 13881: * ! 13882: DMP02 MOV VRVAL(XL),XL LOAD VALUE ! 13883: BEQ XL,=NULLS,DMP01 LOOP FOR NEXT VRBLK IF NULL VALUE ! 13884: BEQ (XL),=B$TRT,DMP02 LOOP BACK IF VALUE IS TRAPPED ! 13885: * ! 13886: * NON-NULL VALUE, PREPARE TO SEARCH CHAIN ! 13887: * ! 13888: MOV XR,WC SAVE VRBLK POINTER ! 13889: ADD *VRSOF,XR ADJUST PTR TO BE LIKE SCBLK PTR ! 13890: BNZ SCLEN(XR),DMP03 JUMP IF NON-SYSTEM VARIABLE ! 13891: MOV VRSVO(XR),XR ELSE LOAD PTR TO NAME IN SVBLK ! 13892: * ! 13893: * HERE WITH NAME POINTER FOR NEW BLOCK IN XR ! 13894: * ! 13895: DMP03 MOV XR,WB SAVE POINTER TO CHARS ! 13896: MOV WA,DMPSV SAVE HASH BUCKET POINTER ! 13897: MOV =DMVCH,WA POINT TO CHAIN HEAD ! 13898: * ! 13899: * LOOP TO SEARCH CHAIN FOR CORRECT INSERTION POINT ! 13900: * ! 13901: DMP04 MOV WA,DMPCH SAVE CHAIN POINTER ! 13902: MOV WA,XL COPY IT ! 13903: MOV (XL),XR LOAD POINTER TO NEXT ENTRY ! 13904: BZE XR,DMP08 JUMP IF END OF CHAIN TO INSERT ! 13905: ADD *VRSOF,XR ELSE GET NAME PTR FOR CHAINED VRBLK ! 13906: BNZ SCLEN(XR),DMP05 JUMP IF NOT SYSTEM VARIABLE ! 13907: MOV VRSVO(XR),XR ELSE POINT TO NAME IN SVBLK ! 13908: * ! 13909: * HERE PREPARE TO COMPARE THE NAMES ! 13910: * ! 13911: * (WA) SCRATCH ! 13912: * (WB) POINTER TO STRING OF ENTERING VRBLK ! 13913: * (WC) POINTER TO ENTERING VRBLK ! 13914: * (XR) POINTER TO STRING OF CURRENT BLOCK ! 13915: * (XL) SCRATCH ! 13916: * ! 13917: DMP05 MOV WB,XL POINT TO ENTERING VRBLK STRING ! 13918: MOV SCLEN(XL),WA LOAD ITS LENGTH ! 13919: PLC XL POINT TO CHARS OF ENTERING STRING ! 13920: BHI WA,SCLEN(XR),DMP06 JUMP IF ENTERING LENGTH HIGH ! 13921: PLC XR ELSE POINT TO CHARS OF OLD STRING ! 13922: CMC DMP08,DMP07 COMPARE, INSERT IF NEW IS LLT OLD ! 13923: BRN DMP08 OR IF LEQ (WE HAD SHORTER LENGTH) ! 13924: * ! 13925: * HERE WHEN NEW LENGTH IS LONGER THAN OLD LENGTH ! 13926: * ! 13927: DMP06 MOV SCLEN(XR),WA LOAD SHORTER LENGTH ! 13928: PLC XR POINT TO CHARS OF OLD STRING ! 13929: CMC DMP08,DMP07 COMPARE, INSERT IF NEW ONE LOW ! 13930: EJC ! 13931: * ! 13932: * DUMPR (CONTINUED) ! 13933: * ! 13934: * HERE WE MOVE OUT ON THE CHAIN ! 13935: * ! 13936: DMP07 MOV DMPCH,XL COPY CHAIN POINTER ! 13937: MOV (XL),WA MOVE TO NEXT ENTRY ON CHAIN ! 13938: BRN DMP04 LOOP BACK ! 13939: * ! 13940: * HERE AFTER LOCATING THE PROPER INSERTION POINT ! 13941: * ! 13942: DMP08 MOV DMPCH,XL COPY CHAIN POINTER ! 13943: MOV DMPSV,WA RESTORE HASH BUCKET POINTER ! 13944: MOV WC,XR RESTORE VRBLK POINTER ! 13945: MOV (XL),VRGET(XR) LINK VRBLK TO REST OF CHAIN ! 13946: MOV XR,(XL) LINK VRBLK INTO CURRENT CHAIN LOC ! 13947: BRN DMP01 LOOP BACK FOR NEXT VRBLK ! 13948: * ! 13949: * HERE AFTER PROCESSING ALL VRBLKS ON ONE CHAIN ! 13950: * ! 13951: DMP09 BNE WA,HSHTE,DMP00 LOOP BACK IF MORE BUCKETS TO GO ! 13952: * ! 13953: * LOOP TO GENERATE DUMP OF NATURAL VARIABLE VALUES ! 13954: * ! 13955: DMP10 MOV DMVCH,XR LOAD POINTER TO NEXT ENTRY ON CHAIN ! 13956: BZE XR,DMP11 JUMP IF END OF CHAIN ! 13957: MOV (XR),DMVCH ELSE UPDATE CHAIN PTR TO NEXT ENTRY ! 13958: JSR SETVR RESTORE VRGET FIELD ! 13959: MOV XR,XL COPY VRBLK POINTER (NAME BASE) ! 13960: MOV *VRVAL,WA SET OFFSET FOR VRBLK NAME ! 13961: JSR PRTNV PRINT NAME = VALUE ! 13962: BRN DMP10 LOOP BACK TILL ALL PRINTED ! 13963: * ! 13964: * PREPARE TO PRINT KEYWORDS ! 13965: * ! 13966: DMP11 JSR PRTFH PRINT BLANK LINE ! 13967: JSR PRTFH AND ANOTHER ! 13968: MOV =DMHDK,XR POINT TO KEYWORD HEADING ! 13969: JSR PRTFB PRINT HEADING ! 13970: MOV =VDMKW,XL POINT TO LIST OF KEYWORD SVBLK PTRS ! 13971: EJC ! 13972: * ! 13973: * DUMPR (CONTINUED) ! 13974: * ! 13975: * LOOP TO DUMP KEYWORD VALUES ! 13976: * ! 13977: DMP12 MOV (XL)+,XR LOAD NEXT SVBLK PTR FROM TABLE ! 13978: BZE XR,DMP13 JUMP IF END OF LIST ! 13979: MOV =CH$AM,WA LOAD AMPERSAND ! 13980: JSR PRTCH PRINT AMPERSAND ! 13981: JSR PRTST PRINT KEYWORD NAME ! 13982: MOV SVLEN(XR),WA LOAD NAME LENGTH FROM SVBLK ! 13983: CTB WA,SVCHS GET LENGTH OF NAME ! 13984: ADD WA,XR POINT TO SVKNM FIELD ! 13985: MOV (XR),DMPKN STORE IN DUMMY KVBLK ! 13986: MOV =TMBEB,XR POINT TO BLANK-EQUAL-BLANK ! 13987: JSR PRTST PRINT IT ! 13988: MOV XL,DMPSV SAVE TABLE POINTER ! 13989: MOV =DMPKB,XL POINT TO DUMMY KVBLK ! 13990: MOV *KVVAR,WA SET ZERO OFFSET ! 13991: JSR ACESS GET KEYWORD VALUE ! 13992: PPM FAILURE IS IMPOSSIBLE ! 13993: JSR PRTVF PRINT KEYWORD VALUE ! 13994: MOV DMPSV,XL RESTORE TABLE POINTER ! 13995: BRN DMP12 LOOP BACK TILL ALL PRINTED ! 13996: * ! 13997: * HERE AFTER COMPLETING PARTIAL DUMP ! 13998: * ! 13999: DMP13 BEQ DMARG,=NUM01,DMP27 EXIT IF PARTIAL DUMP COMPLETE ! 14000: MOV DNAMB,XR ELSE POINT TO FIRST DYNAMIC BLOCK ! 14001: * ! 14002: * LOOP THROUGH BLOCKS IN DYNAMIC STORAGE ! 14003: * ! 14004: DMP14 BEQ XR,DNAMP,DMP27 JUMP IF END OF USED REGION ! 14005: MOV (XR),WA ELSE LOAD FIRST WORD OF BLOCK ! 14006: BEQ WA,=B$VCT,DMP16 JUMP IF VECTOR ! 14007: BEQ WA,=B$ART,DMP17 JUMP IF ARRAY ! 14008: BEQ WA,=B$PDT,DMP18 JUMP IF PROGRAM DEFINED ! 14009: BEQ WA,=B$TBT,DMP19 JUMP IF TABLE ! 14010: .IF .CNBF ! 14011: .ELSE ! 14012: BEQ WA,=B$BCT,DMP29 JUMP IF BUFFER ! 14013: .FI ! 14014: * ! 14015: * MERGE HERE TO MOVE TO NEXT BLOCK ! 14016: * ! 14017: DMP15 JSR BLKLN GET LENGTH OF BLOCK ! 14018: ADD WA,XR POINT PAST THIS BLOCK ! 14019: BRN DMP14 LOOP BACK FOR NEXT BLOCK ! 14020: EJC ! 14021: * ! 14022: * DUMPR (CONTINUED) ! 14023: * ! 14024: * HERE FOR VECTOR ! 14025: * ! 14026: DMP16 MOV *VCVLS,WB SET OFFSET TO FIRST VALUE ! 14027: BRN DMP19 JUMP TO MERGE ! 14028: * ! 14029: * HERE FOR ARRAY ! 14030: * ! 14031: DMP17 MOV AROFS(XR),WB SET OFFSET TO ARPRO FIELD ! 14032: ICA WB BUMP TO GET OFFSET TO VALUES ! 14033: BRN DMP19 JUMP TO MERGE ! 14034: * ! 14035: * HERE FOR PROGRAM DEFINED ! 14036: * ! 14037: DMP18 MOV *PDFLD,WB POINT TO VALUES, MERGE ! 14038: * ! 14039: * HERE FOR TABLE (OTHERS MERGE) ! 14040: * ! 14041: DMP19 BZE IDVAL(XR),DMP15 IGNORE BLOCK IF ZERO ID VALUE ! 14042: JSR BLKLN ELSE GET BLOCK LENGTH ! 14043: MOV XR,XL COPY BLOCK POINTER ! 14044: MOV WA,DMPSV SAVE LENGTH ! 14045: MOV WB,WA COPY OFFSET TO FIRST VALUE ! 14046: JSR PRTFH PRINT BLANK LINE ! 14047: MOV WA,DMPSA PRESERVE OFFSET ! 14048: JSR PRTVF PRINT BLOCK VALUE (FOR TITLE) ! 14049: MOV DMPSA,WA RECOVER OFFSET ! 14050: BEQ (XR),=B$TBT,DMP22 JUMP IF TABLE ! 14051: DCA WA POINT BEFORE FIRST WORD ! 14052: * ! 14053: * LOOP TO PRINT CONTENTS OF ARRAY, VECTOR, OR PROGRAM DEF ! 14054: * ! 14055: DMP20 MOV XL,XR COPY BLOCK POINTER ! 14056: ICA WA BUMP OFFSET ! 14057: ADD WA,XR POINT TO NEXT VALUE ! 14058: BEQ WA,DMPSV,DMP14 EXIT IF END (XR PAST BLOCK) ! 14059: SUB *VRVAL,XR SUBTRACT OFFSET TO MERGE INTO LOOP ! 14060: * ! 14061: * LOOP TO FIND VALUE AND IGNORE NULLS ! 14062: * ! 14063: DMP21 MOV VRVAL(XR),XR LOAD NEXT VALUE ! 14064: BEQ XR,=NULLS,DMP20 LOOP BACK IF NULL VALUE ! 14065: BEQ (XR),=B$TRT,DMP21 LOOP BACK IF TRAPPED ! 14066: JSR PRTNV ELSE PRINT NAME = VALUE ! 14067: BRN DMP20 LOOP BACK FOR NEXT FIELD ! 14068: EJC ! 14069: * ! 14070: * DUMPR (CONTINUED) ! 14071: * ! 14072: * HERE TO DUMP A TABLE ! 14073: * ! 14074: DMP22 MOV *TBBUK,WC SET OFFSET TO FIRST BUCKET ! 14075: MOV *TEVAL,WA SET NAME OFFSET FOR ALL TEBLKS ! 14076: * ! 14077: * LOOP THROUGH TABLE BUCKETS ! 14078: * ! 14079: DMP23 MOV XL,-(XS) SAVE TBBLK POINTER ! 14080: ADD WC,XL POINT TO NEXT BUCKET HEADER ! 14081: ICA WC BUMP BUCKET OFFSET ! 14082: SUB *TENXT,XL SUBTRACT OFFSET TO MERGE INTO LOOP ! 14083: * ! 14084: * LOOP TO PROCESS TEBLKS ON ONE CHAIN ! 14085: * ! 14086: DMP24 MOV TENXT(XL),XL POINT TO NEXT TEBLK ! 14087: BEQ XL,(XS),DMP26 JUMP IF END OF CHAIN ! 14088: MOV XL,XR ELSE COPY TEBLK POINTER ! 14089: * ! 14090: * LOOP TO FIND VALUE AND IGNORE IF NULL ! 14091: * ! 14092: DMP25 MOV TEVAL(XR),XR LOAD NEXT VALUE ! 14093: BEQ XR,=NULLS,DMP24 IGNORE IF NULL VALUE ! 14094: BEQ (XR),=B$TRT,DMP25 LOOP BACK IF TRAPPED ! 14095: MOV WC,DMPSV ELSE SAVE OFFSET POINTER ! 14096: JSR PRTNV PRINT NAME = VALUE ! 14097: MOV DMPSV,WC RELOAD OFFSET ! 14098: BRN DMP24 LOOP BACK FOR NEXT TEBLK ! 14099: * ! 14100: * HERE TO MOVE TO NEXT HASH CHAIN ! 14101: * ! 14102: DMP26 MOV (XS)+,XL RESTORE TBBLK POINTER ! 14103: BNE WC,TBLEN(XL),DMP23 LOOP BACK IF MORE BUCKETS TO GO ! 14104: MOV XL,XR ELSE COPY TABLE POINTER ! 14105: ADD WC,XR POINT TO FOLLOWING BLOCK ! 14106: BRN DMP14 LOOP BACK TO PROCESS NEXT BLOCK ! 14107: * ! 14108: * HERE AFTER COMPLETING DUMP ! 14109: * ! 14110: DMP27 JSR PRTPG EJECT PRINTER ! 14111: * ! 14112: * MERGE HERE IF NO DUMP GIVEN (DMARG=0) ! 14113: * ! 14114: DMP28 EXI RETURN TO DUMP CALLER ! 14115: .IF .CNBF ! 14116: .ELSE ! 14117: EJC ! 14118: * ! 14119: * DUMPR (CONTINUED) ! 14120: * ! 14121: * HERE TO DUMP BUFFER BLOCK ! 14122: * ! 14123: DMP29 JSR PRTFH PRINT BLANK LINE ! 14124: JSR PRTVF PRINT VALUE ID FOR TITLE ! 14125: MOV =CH$DQ,WA LOAD DOUBLE QUOTE ! 14126: JSR PRTCH PRINT IT ! 14127: MOV BCLEN(XR),WC LOAD DEFINED LENGTH ! 14128: BZE WC,DMP32 SKIP CHARACTERS IF NONE ! 14129: LCT WC,WC LOAD COUNT FOR LOOP ! 14130: MOV XR,WB SAVE BCBLK PTR ! 14131: MOV BCBUF(XR),XR POINT TO BFBLK ! 14132: PLC XR GET SET TO LOAD CHARACTERS ! 14133: * ! 14134: * LOOP HERE STUFFING CHARACTERS IN OUTPUT STREAM ! 14135: * ! 14136: DMP31 LCH WA,(XR)+ GET NEXT CHARACTER ! 14137: JSR PRTCH STUFF IT ! 14138: BCT WC,DMP31 BRANCH FOR NEXT ONE ! 14139: MOV WB,XR RESTORE BCBLK POINTER ! 14140: * ! 14141: * MERGE TO STUFF CLOSING QUOTE MARK ! 14142: * ! 14143: DMP32 MOV =CH$DQ,WA STUFF QUOTE ! 14144: JSR PRTCF PRINT IT ! 14145: MOV (XR),WA GET FIRST WD FOR BLKLN ! 14146: BRN DMP15 MERGE TO GET NEXT BLOCK ! 14147: .FI ! 14148: ENP END PROCEDURE DUMPR ! 14149: EJC ! 14150: * ! 14151: * ERMSG -- PRINT ERROR CODE AND ERROR MESSAGE ! 14152: * ! 14153: * KVERT ERROR CODE ! 14154: * JSR ERMSG CALL TO PRINT MESSAGE ! 14155: * (XR,XL,WA,WB,WC,IA) DESTROYED ! 14156: * ! 14157: ERMSG PRC E,0 ENTRY POINT ! 14158: JSR PRTFH PRINT ERROR PTR OR BLANK LINE ! 14159: MOV KVERT,WA LOAD ERROR CODE ! 14160: MOV =ERMMS,XR POINT TO ERROR MESSAGE /ERROR/ ! 14161: JSR PRTST PRINT IT ! 14162: JSR ERTEX GET ERROR MESSAGE TEXT ! 14163: ADD =THSND,WA BUMP ERROR CODE FOR PRINT ! 14164: MTI WA FAIL CODE IN INT ACC ! 14165: JSR PRTIN PRINT CODE (NOW HAVE ERROR1XXX) ! 14166: MOV PRBUF,XL POINT TO PRINT BUFFER ! 14167: PSC XL,=NUM05 POINT TO THE 1 ! 14168: MOV =CH$BL,WA LOAD A BLANK ! 14169: SCH WA,(XL) STORE BLANK OVER 1 (ERROR XXX) ! 14170: CSC XL COMPLETE STORE CHARACTERS ! 14171: ZER XL CLEAR GARBAGE POINTER IN XL ! 14172: MOV XR,WA KEEP ERROR TEXT ! 14173: MOV =ERMNS,XR POINT TO / -- / ! 14174: JSR PRTST PRINT IT ! 14175: MOV WA,XR GET ERROR TEXT AGAIN ! 14176: JSR PRTFB PRINT ERROR MESSAGE TEXT ! 14177: EXI RETURN TO ERMSG CALLER ! 14178: ENP END PROCEDURE ERMSG ! 14179: EJC ! 14180: * ! 14181: * ERTEX -- GET ERROR MESSAGE TEXT ! 14182: * ! 14183: * (WA) ERROR CODE ! 14184: * JSR ERTEX CALL TO GET ERROR TEXT ! 14185: * (XR) PTR TO ERROR TEXT IN DYNAMIC ! 14186: * (R$ETX) COPY OF PTR TO ERROR TEXT ! 14187: * (XL,WC,IA) DESTROYED ! 14188: * ! 14189: ERTEX PRC E,0 ENTRY POINT ! 14190: MOV WA,ERTWA SAVE WA ! 14191: MOV WB,ERTWB SAVE WB ! 14192: BNZ EROSN,ERT03 SKIP IF SPECIAL EROSI RETURN ! 14193: JSR SYSEM GET FAILURE MESSAGE TEXT ! 14194: MOV XR,XL COPY POINTER TO IT ! 14195: MOV SCLEN(XR),WA GET LENGTH OF STRING ! 14196: BZE WA,ERT02 JUMP IF NULL ! 14197: ZER WB OFFSET OF ZERO ! 14198: JSR SBSTR COPY INTO DYNAMIC STORE ! 14199: MOV XR,R$ETX STORE FOR RELOCATION ! 14200: * ! 14201: * RETURN ! 14202: * ! 14203: ERT01 MOV ERTWB,WB RESTORE WB ! 14204: MOV ERTWA,WA RESTORE WA ! 14205: EXI RETURN TO CALLER ! 14206: * ! 14207: * RETURN ERRTEXT CONTENTS INSTEAD OF NULL ! 14208: * ! 14209: ERT02 MOV R$ETX,XR GET ERRTEXT ! 14210: BRN ERT01 RETURN ! 14211: * ! 14212: * SPECIAL CASE SET UP BY EROSI RETURN TO AVOID SYSEM CALL ! 14213: * ! 14214: ERT03 ZER EROSN CLEAR FLAG ! 14215: MOV R$ETX,XR GET ERROR MESSAGE TEXT ! 14216: BRN ERT01 RETURN WITHOUT MAKING SYSEM CALL ! 14217: ENP ! 14218: EJC ! 14219: * ! 14220: * EVALI -- EVALUATE INTEGER ARGUMENT ! 14221: * ! 14222: * EVALI IS USED BY PATTERN PRIMITIVES LEN,TAB,RTAB,POS,RPOS ! 14223: * WHEN THEIR ARGUMENT IS AN EXPRESSION VALUE. ! 14224: * ! 14225: * (XR) NODE POINTER ! 14226: * (WB) CURSOR ! 14227: * JSR EVALI CALL TO EVALUATE INTEGER ! 14228: * PPM LOC TRANSFER LOC FOR NON-INTEGER ARG ! 14229: * PPM LOC TRANSFER LOC FOR OUT OF RANGE ARG ! 14230: * PPM LOC TRANSFER LOC FOR EVALUATION FAILURE ! 14231: * (XR) PTR TO NODE WITH INTEGER ARGUMENT ! 14232: * (WC,XL,RA) DESTROYED ! 14233: * ! 14234: * ON RETURN, THE NODE POINTED TO HAS THE INTEGER ARGUMENT ! 14235: * IN PARM1 AND THE PROPER SUCCESSOR POINTER IN PTHEN. ! 14236: * THIS ALLOWS MERGING WITH THE NORMAL (INTEGER ARG) CASE. ! 14237: * ! 14238: EVALI PRC R,3 ENTRY POINT (RECURSIVE) ! 14239: JSR EVALP EVALUATE EXPRESSION ! 14240: PPM EVLI1 JUMP ON FAILURE ! 14241: MOV XL,-(XS) STACK RESULT FOR GTSMI ! 14242: MOV PTHEN(XR),XL LOAD SUCCESSOR POINTER ! 14243: JSR GTSMI CONVERT ARG TO SMALL INTEGER ! 14244: PPM EVLI2 JUMP IF NOT INTEGER ! 14245: PPM EVLI3 JUMP IF OUT OF RANGE ! 14246: MOV XR,EVLIV STORE RESULT IN SPECIAL DUMMY NODE ! 14247: MOV XL,EVLIS STORE SUCCESSOR POINTER ! 14248: MOV =EVLIN,XR POINT TO DUMMY NODE WITH RESULT ! 14249: EXI SUCCESSFUL RETURN ! 14250: * ! 14251: * HERE IF EVALUATION FAILS ! 14252: * ! 14253: EVLI1 EXI 3 TAKE FAILURE RETURN ! 14254: * ! 14255: * HERE IF ARGUMENT IS NOT INTEGER ! 14256: * ! 14257: EVLI2 EXI 1 TAKE NON-INTEGER ERROR EXIT ! 14258: * ! 14259: * HERE IF ARGUMENT IS OUT OF RANGE ! 14260: * ! 14261: EVLI3 EXI 2 TAKE OUT-OF-RANGE ERROR EXIT ! 14262: ENP END PROCEDURE EVALI ! 14263: EJC ! 14264: * ! 14265: * EVALP -- EVALUATE EXPRESSION DURING PATTERN MATCH ! 14266: * ! 14267: * EVALP IS USED TO EVALUATE AN EXPRESSION (BY VALUE) DURING ! 14268: * A PATTERN MATCH. THE EFFECT IS LIKE EVALX, BUT PATTERN ! 14269: * VARIABLES ARE STACKED AND RESTORED IF NECESSARY. ! 14270: * ! 14271: * EVALP ALSO DIFFERS FROM EVALX IN THAT IF THE RESULT IS ! 14272: * AN EXPRESSION IT IS REEVALUATED. THIS OCCURS REPEATEDLY. ! 14273: * ! 14274: * (XR) NODE POINTER ! 14275: * (WB) PATTERN MATCH CURSOR ! 14276: * JSR EVALP CALL TO EVALUATE EXPRESSION ! 14277: * PPM LOC TRANSFER LOC IF EVALUATION FAILS ! 14278: * (XL) RESULT ! 14279: * (WA) FIRST WORD OF RESULT BLOCK ! 14280: * (XR,WB) DESTROYED (FAILURE CASE ONLY) ! 14281: * (WC,RA) DESTROYED ! 14282: * ! 14283: * THE EXPRESSION POINTER IS STORED IN PARM1 OF THE NODE ! 14284: * ! 14285: * CONTROL RETURNS TO FAILP ON FAILURE OF EVALUATION ! 14286: * ! 14287: EVALP PRC R,1 ENTRY POINT (RECURSIVE) ! 14288: MOV PARM1(XR),XL LOAD EXPRESSION POINTER ! 14289: BEQ (XL),=B$EXL,EVLP1 JUMP IF EXBLK CASE ! 14290: * ! 14291: * HERE FOR CASE OF SEBLK ! 14292: * ! 14293: * WE CAN GIVE A FAST RETURN IF THE VALUE OF THE VRBLK IS ! 14294: * NOT AN EXPRESSION AND IS NOT TRAPPED. ! 14295: * ! 14296: MOV SEVAR(XL),XL LOAD VRBLK POINTER ! 14297: MOV VRVAL(XL),XL LOAD VALUE OF VRBLK ! 14298: MOV (XL),WA LOAD FIRST WORD OF VALUE ! 14299: BHI WA,=B$T$$,EVLP3 JUMP IF NOT SEBLK, TRBLK OR EXBLK ! 14300: * ! 14301: * HERE FOR EXBLK OR SEBLK WITH EXPR VALUE OR TRAPPED VALUE ! 14302: * ! 14303: EVLP1 MOV XR,-(XS) STACK NODE POINTER ! 14304: MOV WB,-(XS) STACK CURSOR ! 14305: MOV R$PMS,-(XS) STACK SUBJECT STRING POINTER ! 14306: MOV PMSSL,-(XS) STACK SUBJECT STRING LENGTH ! 14307: MOV PMDFL,-(XS) STACK DOT FLAG ! 14308: MOV PMHBS,-(XS) STACK HISTORY STACK BASE POINTER ! 14309: MOV PARM1(XR),XR LOAD EXPRESSION POINTER ! 14310: EJC ! 14311: * ! 14312: * EVALP (CONTINUED) ! 14313: * ! 14314: * LOOP BACK HERE TO REEVALUATE EXPRESSION RESULT ! 14315: * ! 14316: EVLP2 ZER WB SET FLAG FOR BY VALUE ! 14317: JSR EVALX EVALUATE EXPRESSION ! 14318: PPM EVLP4 JUMP ON FAILURE ! 14319: MOV (XR),WA ELSE LOAD FIRST WORD OF VALUE ! 14320: BLO WA,=B$E$$,EVLP2 LOOP BACK TO REEVALUATE EXPRESSION ! 14321: * ! 14322: * HERE TO RESTORE PATTERN VALUES AFTER SUCCESSFUL EVAL ! 14323: * ! 14324: MOV XR,XL COPY RESULT POINTER ! 14325: MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER ! 14326: MOV (XS)+,PMDFL RESTORE DOT FLAG ! 14327: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH ! 14328: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER ! 14329: MOV (XS)+,WB RESTORE CURSOR ! 14330: MOV (XS)+,XR RESTORE NODE POINTER ! 14331: * ! 14332: * COMMON EXIT POINT ! 14333: * ! 14334: EVLP3 EXI RETURN TO EVALP CALLER ! 14335: * ! 14336: * HERE FOR FAILURE DURING EVALUATION ! 14337: * ! 14338: EVLP4 MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER ! 14339: MOV (XS)+,PMDFL RESTORE DOT FLAG ! 14340: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH ! 14341: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER ! 14342: ADD *NUM02,XS REMOVE NODE PTR, CURSOR ! 14343: EXI 1 TAKE FAILURE EXIT ! 14344: ENP END PROCEDURE EVALP ! 14345: EJC ! 14346: * ! 14347: * EVALS -- EVALUATE STRING ARGUMENT ! 14348: * ! 14349: * EVALS IS USED BY SPAN, ANY, NOTANY, BREAK, BREAKX WHEN ! 14350: * THEY ARE PASSED AN EXPRESSION ARGUMENT. ! 14351: * ! 14352: * (XR) NODE POINTER ! 14353: * (WA) APPROPRIATE MULTI CHARACTER PCODE ! 14354: * (WB) CURSOR ! 14355: * JSR EVALS CALL TO EVALUATE STRING ! 14356: * PPM LOC TRANSFER LOC FOR NON-STRING ARG ! 14357: * PPM LOC TRANSFER LOC FOR EVALUATION FAILURE ! 14358: * (XL) PCODE OF NEW NODE (ENTRY WA) ! 14359: * (XR) PTR TO NODE WITH PARMS SET ! 14360: * (WA,WC,RA) DESTROYED ! 14361: * ! 14362: * ON RETURN, THE NODE POINTED TO HAS A CHARACTER TABLE ! 14363: * POINTER IN PARM1 AND A BIT MASK IN PARM2. THE PROPER ! 14364: * SUCCESSOR IS STORED IN PTHEN OF THIS NODE. THUS IT IS ! 14365: * OK FOR MERGING WITH THE NORMAL (MULTI-CHAR STRING) CASE. ! 14366: * THIS IS DONE BY THE USUAL INDIRECT BRANCH THROUGH THE ! 14367: * PCODE PASSED IN WA. ! 14368: * ! 14369: EVALS PRC R,2 ENTRY POINT (RECURSIVE) ! 14370: MOV WA,-(XS) KEEP PCODE ! 14371: JSR EVALP EVALUATE EXPRESSION ! 14372: PPM EVLS1 JUMP IF EVALUATION FAILS ! 14373: MOV (XS)+,WA RECOVER PCODE ! 14374: MOV PTHEN(XR),-(XS) SAVE SUCCESSOR POINTER ! 14375: MOV WB,-(XS) SAVE CURSOR ! 14376: MOV XL,-(XS) STACK RESULT PTR FOR PATST ! 14377: ZER WB DUMMY PCODE FOR ONE CHAR STRING ! 14378: ZER WC DUMMY PCODE FOR EXPRESSION ARG ! 14379: MOV WA,XL APPROPRIATE PCODE FOR OUR USE ! 14380: JSR PATST CALL ROUTINE TO BUILD NODE ! 14381: PPM EVLS2 JUMP IF NOT STRING ! 14382: MOV (XS)+,WB RESTORE CURSOR ! 14383: MOV (XS)+,PTHEN(XR) STORE SUCCESSOR POINTER ! 14384: MOV (XR),XL GET PCODE ! 14385: EXI TAKE SUCCESS RETURN ! 14386: * ! 14387: * HERE IF EVALUATION FAILS ! 14388: * ! 14389: EVLS1 MOV (XS)+,WA POP STACK ! 14390: EXI 2 TAKE FAILURE RETURN ! 14391: * ! 14392: * HERE IF ARGUMENT IS NOT STRING ! 14393: * ! 14394: EVLS2 ADD *NUM02,XS POP SUCCESSOR AND CURSOR ! 14395: EXI 1 TAKE NON-STRING ERROR EXIT ! 14396: ENP END PROCEDURE EVALS ! 14397: EJC ! 14398: * ! 14399: * EVALX -- EVALUATE EXPRESSION ! 14400: * ! 14401: * EVALX IS CALLED TO EVALUATE AN EXPRESSION ! 14402: * ! 14403: * (XR) POINTER TO EXBLK OR SEBLK ! 14404: * (WB) 0 IF BY VALUE, 1 IF BY NAME ! 14405: * JSR EVALX CALL TO EVALUATE EXPRESSION ! 14406: * PPM LOC TRANSFER LOC IF EVALUATION FAILS ! 14407: * (XR) RESULT IF CALLED BY VALUE ! 14408: * (XL,WA) RESULT NAME BASE,OFFSET IF BY NAME ! 14409: * (XR) DESTROYED (NAME CASE ONLY) ! 14410: * (XL,WA) DESTROYED (VALUE CASE ONLY) ! 14411: * (WB,WC,RA) DESTROYED ! 14412: * ! 14413: EVALX PRC R,1 ENTRY POINT, RECURSIVE ! 14414: BEQ (XR),=B$EXL,EVLX2 JUMP IF EXBLK CASE ! 14415: * ! 14416: * HERE FOR SEBLK ! 14417: * ! 14418: MOV SEVAR(XR),XL LOAD VRBLK POINTER (NAME BASE) ! 14419: MOV *VRVAL,WA SET NAME OFFSET ! 14420: BNZ WB,EVLX1 JUMP IF CALLED BY NAME ! 14421: JSR ACESS CALL ROUTINE TO ACCESS VALUE ! 14422: PPM EVLX9 JUMP IF FAILURE ON ACCESS ! 14423: * ! 14424: * MERGE HERE TO EXIT FOR SEBLK CASE ! 14425: * ! 14426: EVLX1 EXI RETURN TO EVALX CALLER ! 14427: EJC ! 14428: * ! 14429: * EVALX (CONTINUED) ! 14430: * ! 14431: * HERE FOR FULL EXPRESSION (EXBLK) CASE ! 14432: * ! 14433: * IF AN ERROR OCCURS IN THE EXPRESSION CODE AT EXECUTION ! 14434: * TIME, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL ! 14435: * WITHOUT RETURNING TO THIS ROUTINE. ! 14436: * THE FOLLOWING ENTRIES ARE MADE ON THE STACK BEFORE ! 14437: * GIVING CONTROL TO THE EXPRESSION CODE ! 14438: * ! 14439: * EVALX RETURN POINT ! 14440: * SAVED VALUE OF R$COD ! 14441: * CODE POINTER (-R$COD) ! 14442: * SAVED VALUE OF FLPTR ! 14443: * 0 IF BY VALUE, 1 IF BY NAME ! 14444: * FLPTR --------------- *EXFLC, FAIL OFFSET IN EXBLK ! 14445: * ! 14446: EVLX2 SCP WC GET CODE POINTER ! 14447: MOV R$COD,WA LOAD CODE BLOCK POINTER ! 14448: SUB WA,WC GET CODE POINTER AS OFFSET ! 14449: MOV WA,-(XS) STACK OLD CODE BLOCK POINTER ! 14450: MOV WC,-(XS) STACK RELATIVE CODE OFFSET ! 14451: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER ! 14452: MOV WB,-(XS) STACK NAME/VALUE INDICATOR ! 14453: MOV *EXFLC,-(XS) STACK NEW FAIL OFFSET ! 14454: MOV FLPTR,GTCEF KEEP IN CASE OF ERROR ! 14455: MOV R$COD,R$GTC KEEP CODE BLOCK POINTER SIMILARLY ! 14456: MOV XS,FLPTR SET NEW FAILURE POINTER ! 14457: MOV XR,R$COD SET NEW CODE BLOCK POINTER ! 14458: MOV KVSTN,EXSTM(XR) REMEMBER STMNT NUMBER ! 14459: ADD *EXCOD,XR POINT TO FIRST CODE WORD ! 14460: LCP XR SET CODE POINTER ! 14461: BNE STAGE,=STGXT,EXITS JUMP IF NOT EXECUTION TIME ! 14462: MOV =STGEE,STAGE EVALUATING EXPRESSION ! 14463: BRN EXITS JUMP TO EXECUTE FIRST CODE WORD ! 14464: EJC ! 14465: * ! 14466: * EVALX (CONTINUED) ! 14467: * ! 14468: * COME HERE IF SUCCESSFUL RETURN BY VALUE (SEE O$RVL) ! 14469: * ! 14470: EVLXV MOV (XS)+,XR LOAD VALUE ! 14471: BZE 1(XS),EVLX5 JUMP IF CALLED BY VALUE ! 14472: ERB 218,EXPRESSION EVALUATED BY NAME RETURNED VALUE ! 14473: * ! 14474: * HERE FOR EXPRESSION RETURNING BY NAME (SEE O$RNM) ! 14475: * ! 14476: EVLXN MOV (XS)+,WA LOAD NAME OFFSET ! 14477: MOV (XS)+,XL LOAD NAME BASE ! 14478: BNZ 1(XS),EVLX5 JUMP IF CALLED BY NAME ! 14479: JSR ACESS ELSE ACCESS VALUE FIRST ! 14480: PPM EVLXF JUMP IF FAILURE DURING ACCESS ! 14481: * ! 14482: * HERE AFTER LOADING CORRECT RESULT INTO XR OR XL,WA ! 14483: * ! 14484: EVLX5 ZER WB NOTE SUCCESSFUL ! 14485: BRN EVLX7 MERGE ! 14486: * ! 14487: * HERE FOR FAILURE IN EXPRESSION EVALUATION (SEE O$FEX) ! 14488: * ! 14489: EVLXF MNZ WB NOTE UNSUCCESSFUL ! 14490: * ! 14491: * RESTORE ENVIRONMENT ! 14492: * ! 14493: EVLX7 BNE STAGE,=STGEE,EVLX8 SKIP IF WAS NOT PREVIOUSLY XT ! 14494: MOV =STGXT,STAGE EXECUTE TIME ! 14495: * ! 14496: * MERGE WITH STAGE SET UP ! 14497: * ! 14498: EVLX8 ADD *NUM02,XS POP NAME/VALUE INDICATOR, *EXFAL ! 14499: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER ! 14500: MOV (XS)+,WC LOAD CODE OFFSET ! 14501: ADD (XS),WC MAKE CODE POINTER ABSOLUTE ! 14502: MOV (XS)+,R$COD RESTORE OLD CODE BLOCK POINTER ! 14503: LCP WC RESTORE OLD CODE POINTER ! 14504: BZE WB,EVLX1 JUMP FOR SUCCESSFUL RETURN ! 14505: * ! 14506: * MERGE HERE FOR FAILURE IN SEBLK CASE ! 14507: * ! 14508: EVLX9 EXI 1 TAKE FAILURE EXIT ! 14509: ENP END OF PROCEDURE EVALX ! 14510: EJC ! 14511: * ! 14512: * EXBLD -- BUILD EXBLK ! 14513: * ! 14514: * EXBLD IS USED TO BUILD AN EXPRESSION BLOCK FROM THE ! 14515: * CODE COMPILED MOST RECENTLY IN THE CURRENT CCBLK. ! 14516: * ! 14517: * (XL) OFFSET IN CCBLK TO START OF CODE ! 14518: * (WB) INTEGER IN RANGE 0 LE N LE MXLEN ! 14519: * JSR EXBLD CALL TO BUILD EXBLK ! 14520: * (XR) PTR TO CONSTRUCTED EXBLK ! 14521: * (WA,WB,XL) DESTROYED ! 14522: * ! 14523: EXBLD PRC E,0 ENTRY POINT ! 14524: MOV XL,WA COPY OFFSET TO START OF CODE ! 14525: SUB *EXCOD,WA CALC REDUCTION IN OFFSET IN EXBLK ! 14526: MOV WA,-(XS) STACK FOR LATER ! 14527: MOV CWCOF,WA LOAD FINAL OFFSET ! 14528: SUB XL,WA COMPUTE LENGTH OF CODE ! 14529: ADD *EXSI$,WA ADD SPACE FOR STANDARD FIELDS ! 14530: JSR ALLOC ALLOCATE SPACE FOR EXBLK ! 14531: MOV XR,-(XS) SAVE POINTER TO EXBLK ! 14532: MOV =B$EXL,EXTYP(XR) STORE TYPE WORD ! 14533: ZER EXSTM(XR) ZEROISE STMNT NUMBER FIELD ! 14534: MOV WA,EXLEN(XR) STORE LENGTH ! 14535: MOV =OFEX$,EXFLC(XR) STORE FAILURE WORD ! 14536: ADD *EXSI$,XR SET XR FOR SYSMW ! 14537: MOV XL,CWCOF RESET OFFSET TO START OF CODE ! 14538: ADD R$CCB,XL POINT TO START OF CODE ! 14539: SUB *EXSI$,WA LENGTH OF CODE TO MOVE ! 14540: MOV WA,-(XS) STACK LENGTH OF CODE ! 14541: MVW MOVE CODE TO EXBLK ! 14542: MOV (XS)+,WA GET LENGTH OF CODE ! 14543: BTW WA CONVERT BAU COUNT TO WORD COUNT ! 14544: LCT WA,WA PREPARE COUNTER FOR LOOP ! 14545: MOV (XS),XL COPY EXBLK PTR, DONT UNSTACK ! 14546: ADD *EXCOD,XL POINT TO CODE ITSELF ! 14547: MOV 1(XS),WB GET REDUCTION IN OFFSET ! 14548: * ! 14549: * THIS LOOP SEARCHES FOR NEGATION AND SELECTION CODE SO ! 14550: * THAT THE OFFSETS COMPUTED WHILST CODE WAS IN CODE BLOCK ! 14551: * CAN BE TRANSFORMED TO REDUCED VALUES APPLICABLE IN AN ! 14552: * EXBLK. ! 14553: * ! 14554: EXBL1 MOV (XL)+,XR GET NEXT CODE WORD ! 14555: BEQ XR,=OSLA$,EXBL3 JUMP IF SELECTION FOUND ! 14556: BEQ XR,=ONTA$,EXBL3 JUMP IF NEGATION FOUND ! 14557: BCT WA,EXBL1 LOOP TO END OF CODE ! 14558: * ! 14559: * NO SELECTION FOUND OR MERGE TO EXIT ON TERMINATION ! 14560: * ! 14561: EXBL2 MOV (XS)+,XR POP EXBLK PTR INTO XR ! 14562: MOV (XS)+,XL POP REDUCTION CONSTANT ! 14563: EXI RETURN TO CALLER ! 14564: EJC ! 14565: * ! 14566: * EXBLD (CONTINUED) ! 14567: * ! 14568: * SELECTION OR NEGATION FOUND ! 14569: * REDUCE THE OFFSETS AS NEEDED. OFFSETS OCCUR IN WORDS ! 14570: * FOLLOWING CODE WORDS - ! 14571: * =ONTA$, =OSLA$, =OSLB$, =OSLC$ ! 14572: * ! 14573: EXBL3 SUB WB,(XL)+ ADJUST OFFSET ! 14574: BCT WA,EXBL4 DECREMENT COUNT ! 14575: * ! 14576: EXBL4 BCT WA,EXBL5 DECREMENT COUNT ! 14577: * ! 14578: * CONTINUE SEARCH FOR MORE OFFSETS ! 14579: * ! 14580: EXBL5 MOV (XL)+,XR GET NEXT CODE WORD ! 14581: BEQ XR,=OSLA$,EXBL3 JUMP IF OFFSET FOUND ! 14582: BEQ XR,=OSLB$,EXBL3 JUMP IF OFFSET FOUND ! 14583: BEQ XR,=OSLC$,EXBL3 JUMP IF OFFSET FOUND ! 14584: BEQ XR,=ONTA$,EXBL3 JUMP IF OFFSET FOUND ! 14585: BCT WA,EXBL5 LOOP ! 14586: BRN EXBL2 MERGE TO RETURN ! 14587: ENP END PROCEDURE EXBLD ! 14588: EJC ! 14589: * ! 14590: * EXPAN -- ANALYZE EXPRESSION ! 14591: * ! 14592: * THE EXPRESSION ANALYZER (EXPAN) PROCEDURE IS USED TO SCAN ! 14593: * AN EXPRESSION AND CONVERT IT INTO A TREE REPRESENTATION. ! 14594: * SEE DESCRIPTIONS OF CMBLK, CUBLK, CBBLK IN THE STRUCTURES ! 14595: * SECTION FOR DETAILED FORMAT OF TREE BLOCKS. ! 14596: * ! 14597: * THE ANALYZER USES A SIMPLE PRECEDENCE SCHEME IN WHICH ! 14598: * OPERANDS AND OPERATORS ARE PLACED ON A SINGLE STACK ! 14599: * AND CONDENSATIONS ARE MADE WHEN LOW PRECEDENCE OPERATORS ! 14600: * ARE STACKED AFTER A HIGHER PRECEDENCE OPERATOR. A GLOBAL ! 14601: * VARIABLE (IN WB) KEEPS TRACK OF THE LEVEL AS FOLLOWS. ! 14602: * ! 14603: * 0 SCANNING OUTER LEVEL OF STATEMENT OR EXPRESSION ! 14604: * 1 SCANNING OUTER LEVEL OF NORMAL GOTO ! 14605: * 2 SCANNING OUTER LEVEL OF DIRECT GOTO ! 14606: * 3 SCANNING INSIDE ARRAY BRACKETS ! 14607: * 4 SCANNING INSIDE GROUPING PARENTHESES ! 14608: * 5 SCANNING INSIDE FUNCTION PARENTHESES ! 14609: * ! 14610: * THIS VARIABLE IS SAVED ON THE STACK ON ENCOUNTERING A ! 14611: * GROUPING AND RESTORED AT THE END OF THE GROUPING. ! 14612: * ! 14613: * ANOTHER GLOBAL VARIABLE (IN WC) COUNTS THE NUMBER OF ! 14614: * ITEMS AT ONE GROUPING LEVEL AND IS INCREMENTED FOR EACH ! 14615: * COMMA ENCOUNTERED. IT IS STACKED WITH THE LEVEL INDICATOR ! 14616: * ! 14617: * THE SCAN IS CONTROLLED BY A THREE STATE FINITE MACHINE. ! 14618: * A GLOBAL VARIABLE STORED IN WA IS THE CURRENT STATE. ! 14619: * ! 14620: * WA=0 NOTHING SCANNED AT THIS LEVEL ! 14621: * WA=1 OPERAND EXPECTED ! 14622: * WA=2 OPERATOR EXPECTED ! 14623: * ! 14624: * (WB) CALL TYPE (SEE BELOW) ! 14625: * JSR EXPAN CALL TO ANALYZE EXPRESSION ! 14626: * (XR) POINTER TO RESULTING TREE ! 14627: * (XL,WA,WB,WC,RA) DESTROYED ! 14628: * ! 14629: * THE ENTRY VALUE OF WB INDICATES THE CALL TYPE AS FOLLOWS. ! 14630: * ! 14631: * 0 SCANNING EITHER THE MAIN BODY OF A STATEMENT OR THE ! 14632: * TEXT OF AN EXPRESSION (FROM EVAL CALL). VALID ! 14633: * TERMINATORS ARE COLON, SEMICOLON. THE RESCAN FLAG IS ! 14634: * SET TO RETURN THE TERMINATOR ON THE NEXT SCANE CALL. ! 14635: * ! 14636: * 1 SCANNING A NORMAL GOTO. THE ONLY VALID ! 14637: * TERMINATOR IS A RIGHT PAREN. ! 14638: * ! 14639: * 2 SCANNING A DIRECT GOTO. THE ONLY VALID ! 14640: * TERMINATOR IS A RIGHT BRACKET. ! 14641: EJC ! 14642: * ! 14643: * EXPAN (CONTINUED) ! 14644: * ! 14645: * ENTRY POINT ! 14646: * ! 14647: EXPAN PRC E,0 ENTRY POINT ! 14648: ZER -(XS) SET TOP OF STACK INDICATOR ! 14649: ZER WA SET INITIAL STATE TO ZERO ! 14650: ZER WC ZERO COUNTER VALUE ! 14651: * ! 14652: * LOOP HERE FOR SUCCESSIVE ENTRIES ! 14653: * ! 14654: EXP01 JSR SCANE SCAN NEXT ELEMENT ! 14655: ADD WA,XL ADD STATE TO SYNTAX CODE ! 14656: BSW XL,T$NES SWITCH ON ELEMENT TYPE/STATE ! 14657: IFF T$VA0,EXP03 VARIABLE, S=0 ! 14658: IFF T$VA1,EXP03 VARIABLE, STATE ONE ! 14659: IFF T$VA2,EXP04 VARIABLE, S=2 ! 14660: IFF T$CO0,EXP03 CONSTANT, S=0 ! 14661: IFF T$CO1,EXP03 CONSTANT, S=1 ! 14662: IFF T$CO2,EXP04 CONSTANT, S=2 ! 14663: IFF T$LP0,EXP06 LEFT PAREN, S=0 ! 14664: IFF T$LP1,EXP06 LEFT PAREN, S=1 ! 14665: IFF T$LP2,EXP04 LEFT PAREN, S=2 ! 14666: IFF T$FN0,EXP10 FUNCTION, S=0 ! 14667: IFF T$FN1,EXP10 FUNCTION, S=1 ! 14668: IFF T$FN2,EXP04 FUNCTION, S=2 ! 14669: IFF T$RP0,EXP02 RIGHT PAREN, S=0 ! 14670: IFF T$RP1,EXP05 RIGHT PAREN, S=1 ! 14671: IFF T$RP2,EXP12 RIGHT PAREN, S=2 ! 14672: IFF T$LB0,EXP08 LEFT BRKT, S=0 ! 14673: IFF T$LB1,EXP08 LEFT BRKT, S=1 ! 14674: IFF T$LB2,EXP09 LEFT BRKT, S=2 ! 14675: IFF T$RB0,EXP02 RIGHT BRKT, S=0 ! 14676: IFF T$RB1,EXP05 RIGHT BRKT, S=1 ! 14677: IFF T$RB2,EXP18 RIGHT BRKT, S=2 ! 14678: IFF T$UO0,EXP27 UNOP, S=0 ! 14679: IFF T$UO1,EXP27 UNOP, S=1 ! 14680: IFF T$UO2,EXP04 UNOP, S=2 ! 14681: IFF T$BO0,EXP05 BINOP, S=0 ! 14682: IFF T$BO1,EXP05 BINOP, S=1 ! 14683: IFF T$BO2,EXP26 BINOP, S=2 ! 14684: IFF T$CM0,EXP02 COMMA, S=0 ! 14685: IFF T$CM1,EXP05 COMMA, S=1 ! 14686: IFF T$CM2,EXP11 COMMA, S=2 ! 14687: IFF T$CL0,EXP02 COLON, S=0 ! 14688: IFF T$CL1,EXP05 COLON, S=1 ! 14689: IFF T$CL2,EXP19 COLON, S=2 ! 14690: IFF T$SM0,EXP02 SEMICOLON, S=0 ! 14691: IFF T$SM1,EXP05 SEMICOLON, S=1 ! 14692: IFF T$SM2,EXP19 SEMICOLON, S=2 ! 14693: ESW END SWITCH ON ELEMENT TYPE/STATE ! 14694: EJC ! 14695: * ! 14696: * EXPAN (CONTINUED) ! 14697: * ! 14698: * HERE FOR RBR,RPR,COL,SMC,CMA IN STATE 0 ! 14699: * ! 14700: * SET TO RESCAN THE TERMINATOR ENCOUNTERED AND CREATE ! 14701: * A NULL CONSTANT (CASE OF OMITTED NULL) ! 14702: * ! 14703: EXP02 MNZ SCNRS SET TO RESCAN ELEMENT ! 14704: MOV =NULLS,XR POINT TO NULL, MERGE ! 14705: * ! 14706: * HERE FOR VAR OR CON IN STATES 0,1 ! 14707: * ! 14708: * STACK THE VARIABLE/CONSTANT AND SET STATE=2 ! 14709: * ! 14710: EXP03 MOV XR,-(XS) STACK POINTER TO OPERAND ! 14711: MOV =NUM02,WA SET STATE 2 ! 14712: BRN EXP01 JUMP FOR NEXT ELEMENT ! 14713: * ! 14714: * HERE FOR VAR,CON,LPR,FNC,UOP IN STATE 2 ! 14715: * ! 14716: * WE RESCAN THE ELEMENT AND CREATE A CONCATENATION OPERATOR ! 14717: * THIS IS THE CASE OF THE BLANK CONCATENATION OPERATOR. ! 14718: * ! 14719: EXP04 MNZ SCNRS SET TO RESCAN ELEMENT ! 14720: MOV =OPDVC,XR POINT TO CONCAT OPERATOR DV ! 14721: BZE WB,EXP4A OK IF AT TOP LEVEL ! 14722: MOV =OPDVP,XR ELSE POINT TO UNMISTAKEABLE CONCAT ! 14723: * ! 14724: * MERGE WITH CORRECT CONCATENATION DVBLK IN XR ! 14725: * ! 14726: EXP4A BNZ SCNBL,EXP26 MERGE BOP IF BLANKS, ELSE ERROR ! 14727: DCV SCNSE ADJUST START OF ELEMENT LOCATION ! 14728: ERB 219,SYNTAX ERROR. MISSING OPERATOR ! 14729: * ! 14730: * HERE FOR CMA,RPR,RBR,COL,SMC,BOP(S=1) BOP(S=0) ! 14731: * ! 14732: * THIS IS AN ERRONOUS CONTRUCTION ! 14733: * ! 14734: EXP05 DCV SCNSE ADJUST START OF ELEMENT LOCATION ! 14735: ERB 220,SYNTAX ERROR. MISSING OPERAND ! 14736: * ! 14737: * HERE FOR LPR (S=0,1) ! 14738: * ! 14739: EXP06 MOV =NUM04,XL SET NEW LEVEL INDICATOR ! 14740: ZER XR SET ZERO VALUE FOR CMOPN ! 14741: EJC ! 14742: * ! 14743: * EXPAN (CONTINUED) ! 14744: * ! 14745: * MERGE HERE TO STORE OLD LEVEL ON STACK AND START NEW ONE ! 14746: * ! 14747: EXP07 MOV XR,-(XS) STACK CMOPN VALUE ! 14748: MOV WC,-(XS) STACK OLD COUNTER ! 14749: MOV WB,-(XS) STACK OLD LEVEL INDICATOR ! 14750: CHK CHECK FOR STACK OVERFLOW ! 14751: ZER WA SET NEW STATE TO ZERO ! 14752: MOV XL,WB SET NEW LEVEL INDICATOR ! 14753: MOV =NUM01,WC INITIALIZE NEW COUNTER ! 14754: BRN EXP01 JUMP TO SCAN NEXT ELEMENT ! 14755: * ! 14756: * HERE FOR LBR (S=0,1) ! 14757: * ! 14758: * THIS IS AN ILLEGAL USE OF LEFT BRACKET ! 14759: * ! 14760: EXP08 ERB 221,SYNTAX ERROR. INVALID USE OF LEFT BRACKET ! 14761: * ! 14762: * HERE FOR LBR (S=2) ! 14763: * ! 14764: * SET NEW LEVEL AND START TO SCAN SUBSCRIPTS ! 14765: * ! 14766: EXP09 MOV (XS)+,XR LOAD ARRAY PTR FOR CMOPN ! 14767: MOV =NUM03,XL SET NEW LEVEL INDICATOR ! 14768: BRN EXP07 JUMP TO STACK OLD AND START NEW ! 14769: * ! 14770: * HERE FOR FNC (S=0,1) ! 14771: * ! 14772: * STACK OLD LEVEL AND START TO SCAN ARGUMENTS ! 14773: * ! 14774: EXP10 MOV =NUM05,XL SET NEW LEV INDIC (XR=VRBLK=CMOPN) ! 14775: BRN EXP07 JUMP TO STACK OLD AND START NEW ! 14776: * ! 14777: * HERE FOR CMA (S=2) ! 14778: * ! 14779: * INCREMENT ARGUMENT COUNT AND CONTINUE ! 14780: * ! 14781: EXP11 ICV WC INCREMENT COUNTER ! 14782: JSR EXPDM DUMP OPERATORS AT THIS LEVEL ! 14783: ZER -(XS) SET NEW LEVEL FOR PARAMETER ! 14784: ZER WA SET NEW STATE ! 14785: BGT WB,=NUM02,EXP01 LOOP BACK UNLESS OUTER LEVEL ! 14786: ERB 222,SYNTAX ERROR. INVALID USE OF COMMA ! 14787: EJC ! 14788: * ! 14789: * EXPAN (CONTINUED) ! 14790: * ! 14791: * HERE FOR RPR (S=2) ! 14792: * ! 14793: * AT OUTER LEVEL IN A NORMAL GOTO THIS IS A TERMINATOR ! 14794: * OTHERWISE IT MUST TERMINATE A FUNCTION OR GROUPING ! 14795: * ! 14796: EXP12 BEQ WB,=NUM01,EXP20 END OF NORMAL GOTO ! 14797: BEQ WB,=NUM05,EXP13 END OF FUNCTION ARGUMENTS ! 14798: BEQ WB,=NUM04,EXP14 END OF GROUPING / SELECTION ! 14799: ERB 223,SYNTAX ERROR. UNBALANCED RIGHT PARENTHESIS ! 14800: * ! 14801: * HERE AT END OF FUNCTION ARGUMENTS ! 14802: * ! 14803: EXP13 MOV =C$FNC,XL SET CMTYP VALUE FOR FUNCTION ! 14804: BRN EXP15 JUMP TO BUILD CMBLK ! 14805: * ! 14806: * HERE FOR END OF GROUPING ! 14807: * ! 14808: EXP14 BEQ WC,=NUM01,EXP17 JUMP IF END OF GROUPING ! 14809: MOV =C$SEL,XL ELSE SET CMTYP FOR SELECTION ! 14810: * ! 14811: * MERGE HERE TO BUILD CMBLK FOR LEVEL JUST SCANNED AND ! 14812: * TO POP UP TO THE PREVIOUS SCAN LEVEL BEFORE CONTINUING. ! 14813: * ! 14814: EXP15 JSR EXPDM DUMP OPERATORS AT THIS LEVEL ! 14815: MOV WC,WA COPY COUNT ! 14816: ADD =CMVLS,WA ADD FOR STANDARD FIELDS AT START ! 14817: WTB WA CONVERT LENGTH TO BAUS ! 14818: JSR ALLOC ALLOCATE SPACE FOR CMBLK ! 14819: MOV =B$CMT,(XR) STORE TYPE CODE FOR CMBLK ! 14820: MOV XL,CMTYP(XR) STORE CMBLK NODE TYPE INDICATOR ! 14821: MOV WA,CMLEN(XR) STORE LENGTH ! 14822: ADD WA,XR POINT PAST END OF BLOCK ! 14823: LCT WC,WC SET LOOP COUNTER ! 14824: * ! 14825: * LOOP TO MOVE REMAINING WORDS TO CMBLK ! 14826: * ! 14827: EXP16 MOV (XS)+,-(XR) MOVE ONE OPERAND PTR FROM STACK ! 14828: MOV (XS)+,WB POP TO OLD LEVEL INDICATOR ! 14829: BCT WC,EXP16 LOOP TILL ALL MOVED ! 14830: EJC ! 14831: * ! 14832: * EXPAN (CONTINUED) ! 14833: * ! 14834: * COMPLETE CMBLK AND STACK POINTER TO IT ON STACK ! 14835: * ! 14836: SUB *CMVLS,XR POINT BACK TO START OF BLOCK ! 14837: MOV (XS)+,WC RESTORE OLD COUNTER ! 14838: MOV (XS),CMOPN(XR) STORE OPERAND PTR IN CMBLK ! 14839: MOV XR,(XS) STACK CMBLK POINTER ! 14840: MOV =NUM02,WA SET NEW STATE ! 14841: BRN EXP01 BACK FOR NEXT ELEMENT ! 14842: * ! 14843: * HERE AT END OF A PARENTHESIZED EXPRESSION ! 14844: * ! 14845: EXP17 JSR EXPDM DUMP OPERATORS AT THIS LEVEL ! 14846: MOV (XS)+,XR RESTORE XR ! 14847: MOV (XS)+,WB RESTORE OUTER LEVEL ! 14848: MOV (XS)+,WC RESTORE OUTER COUNT ! 14849: MOV XR,(XS) STORE OPND OVER UNUSED CMOPN VAL ! 14850: MOV =NUM02,WA SET NEW STATE ! 14851: BRN EXP01 BACK FOR NEXT ELE8ENT ! 14852: * ! 14853: * HERE FOR RBR (S=2) ! 14854: * ! 14855: * AT OUTER LEVEL IN A DIRECT GOTO, THIS IS A TERMINATOR. ! 14856: * OTHERWISE IT MUST TERMINATE A SUBSCRIPT LIST. ! 14857: * ! 14858: EXP18 MOV =C$ARR,XL SET CMTYP FOR ARRAY REFERENCE ! 14859: BEQ WB,=NUM03,EXP15 JUMP TO BUILD CMBLK IF END ARRAYREF ! 14860: BEQ WB,=NUM02,EXP20 JUMP IF END OF DIRECT GOTO ! 14861: ERB 224,SYNTAX ERROR. UNBALANCED RIGHT BRACKET ! 14862: EJC ! 14863: * ! 14864: * EXPAN (CONTINUED) ! 14865: * ! 14866: * HERE FOR COL,SMC (S=2) ! 14867: * ! 14868: * ERROR UNLESS TERMINATING STATEMENT BODY AT OUTER LEVEL ! 14869: * ! 14870: EXP19 MNZ SCNRS RESCAN TERMINATOR ! 14871: MOV WB,XL COPY LEVEL INDICATOR ! 14872: BSW XL,6 SWITCH ON LEVEL INDICATOR ! 14873: IFF 0,EXP20 NORMAL OUTER LEVEL ! 14874: IFF 1,EXP22 FAIL IF NORMAL GOTO ! 14875: IFF 2,EXP23 FAIL IF DIRECT GOTO ! 14876: IFF 3,EXP24 FAIL ARRAY BRACKETS ! 14877: IFF 4,EXP21 FAIL IF IN GROUPING ! 14878: IFF 5,EXP21 FAIL FUNCTION ARGS ! 14879: ESW END SWITCH ON LEVEL ! 14880: * ! 14881: * HERE AT NORMAL END OF EXPRESSION ! 14882: * ! 14883: EXP20 JSR EXPDM DUMP REMAINING OPERATORS ! 14884: MOV (XS)+,XR LOAD TREE POINTER ! 14885: ICA XS POP OFF BOTTOM OF STACK MARKER ! 14886: EXI RETURN TO EXPAN CALLER ! 14887: * ! 14888: * MISSING RIGHT PAREN ! 14889: * ! 14890: EXP21 ERB 225,SYNTAX ERROR. MISSING RIGHT PAREN ! 14891: * ! 14892: * MISSING RIGHT PAREN IN GOTO FIELD ! 14893: * ! 14894: EXP22 ERB 226,SYNTAX ERROR. RIGHT PAREN MISSING FROM GOTO ! 14895: * ! 14896: * MISSING BRACKET IN GOTO ! 14897: * ! 14898: EXP23 ERB 227,SYNTAX ERROR. RIGHT BRACKET MISSING FROM GOTO ! 14899: * ! 14900: * MISSING ARRAY BRACKET ! 14901: * ! 14902: EXP24 ERB 228,SYNTAX ERROR. MISSING RIGHT ARRAY BRACKET ! 14903: EJC ! 14904: * ! 14905: * EXPAN (CONTINUED) ! 14906: * ! 14907: * LOOP HERE WHEN AN OPERATOR CAUSES AN OPERATOR DUMP ! 14908: * ! 14909: EXP25 MOV XR,EXPSV ! 14910: JSR EXPOP POP ONE OPERATOR ! 14911: MOV EXPSV,XR RESTORE OP DV POINTER AND MERGE ! 14912: * ! 14913: * HERE FOR BOP (S=2) ! 14914: * ! 14915: * REMOVE OPERATORS (CONDENSE) FROM STACK UNTIL NO MORE ! 14916: * LEFT AT THIS LEVEL OR TOP ONE HAS LOWER PRECEDENCE. ! 14917: * LOOP HERE TILL THIS CONDITION IS MET. ! 14918: * ! 14919: EXP26 MOV 1(XS),XL LOAD OPERATOR DVPTR FROM STACK ! 14920: BLE XL,=NUM05,EXP27 JUMP IF BOTTOM OF STACK LEVEL ! 14921: BLT DVRPR(XR),DVLPR(XL),EXP25 ELSE POP IF NEW PREC IS LO ! 14922: * ! 14923: * HERE FOR UOP (S=0,1) ! 14924: * ! 14925: * BINARY OPERATOR MERGES AFTER PRECEDENCE CHECK ! 14926: * ! 14927: * THE OPERATOR DV IS STORED ON THE STACK AND THE SCAN ! 14928: * CONTINUES AFTER SETTING THE SCAN STATE TO ONE. ! 14929: * ! 14930: EXP27 MOV XR,-(XS) STACK OPERATOR DVPTR ON STACK ! 14931: CHK CHECK FOR STACK OVERFLOW ! 14932: MOV =NUM01,WA SET NEW STATE ! 14933: BNE XR,=OPDVS,EXP01 BACK FOR NEXT ELEMENT UNLESS = ! 14934: * ! 14935: * HERE FOR SPECIAL CASE OF BINARY =. THE SYNTAX ALLOWS A ! 14936: * NULL RIGHT ARGUMENT FOR THIS OPERATOR TO BE LEFT ! 14937: * OUT. ACCORDINGLY WE RESET TO STATE ZERO TO GET PROPER ! 14938: * ACTION ON A TERMINATOR (SUPPLY A NULL CONSTANT). ! 14939: * ! 14940: ZER WA SET STATE ZERO ! 14941: BRN EXP01 JUMP FOR NEXT ELEMENT ! 14942: ENP END PROCEDURE EXPAN ! 14943: EJC ! 14944: * ! 14945: * EXPAP -- TEST FOR PATTERN MATCH TREE ! 14946: * ! 14947: * EXPAP IS PASSED AN EXPRESSION TREE TO DETERMINE IF IT ! 14948: * IS A PATTERN MATCH. THE FOLLOWING ARE RECOGIZED AS ! 14949: * MATCHES IN THE CONTEXT OF THIS CALL. ! 14950: * ! 14951: * 1) AN EXPLICIT USE OF BINARY QUESTION MARK ! 14952: * 2) A CONCATENATION ! 14953: * 3) AN ALTERNATION WHOSE LEFT OPERAND IS A CONCATENATION ! 14954: * ! 14955: * (XR) PTR TO EXPAN TREE ! 14956: * JSR EXPAP CALL TO TEST FOR PATTERN MATCH ! 14957: * PPM LOC TRANSFER LOC IF NOT A PATTERN MATCH ! 14958: * (WA) DESTROYED ! 14959: * (XR) UNCHANGED (IF NOT MATCH) ! 14960: * (XR) PTR TO BINARY OPERATOR BLK IF MATCH ! 14961: * ! 14962: EXPAP PRC E,1 ENTRY POINT ! 14963: MOV XL,-(XS) SAVE XL ! 14964: BNE (XR),=B$CMT,EXPP2 NO MATCH IF NOT COMPLEX ! 14965: MOV CMTYP(XR),WA ELSE LOAD TYPE CODE ! 14966: BEQ WA,=C$CNC,EXPP1 CONCATENATION IS A MATCH ! 14967: BEQ WA,=C$PMT,EXPP1 BINARY QUESTION MARK IS A MATCH ! 14968: BNE WA,=C$ALT,EXPP2 ELSE NOT MATCH UNLESS ALTERNATION ! 14969: * ! 14970: * HERE FOR ALTERNATION. CHANGE (A B) / C TO A QM (B / C) ! 14971: * ! 14972: MOV CMLOP(XR),XL LOAD LEFT OPERAND POINTER ! 14973: BNE (XL),=B$CMT,EXPP2 NOT MATCH IF LEFT OPND NOT COMPLEX ! 14974: BNE CMTYP(XL),=C$CNC,EXPP2 NOT MATCH IF LEFT OP NOT CONC ! 14975: MOV CMROP(XL),CMLOP(XR) XR POINTS TO (B / C) ! 14976: MOV XR,CMROP(XL) SET XL OPNDS TO A, (B / C) ! 14977: MOV XL,XR POINT TO THIS ALTERED NODE ! 14978: * ! 14979: * EXIT HERE FOR PATTERN MATCH ! 14980: * ! 14981: EXPP1 MOV (XS)+,XL RESTORE ENTRY XL ! 14982: EXI GIVE PATTERN MATCH RETURN ! 14983: * ! 14984: * EXIT HERE IF NOT PATTERN MATCH ! 14985: * ! 14986: EXPP2 MOV (XS)+,XL RESTORE ENTRY XL ! 14987: EXI 1 GIVE NON-MATCH RETURN ! 14988: ENP END PROCEDURE EXPAP ! 14989: EJC ! 14990: * ! 14991: * EXPDM -- DUMP OPERATORS AT CURRENT LEVEL (FOR EXPAN) ! 14992: * ! 14993: * EXPDM USES EXPOP TO CONDENSE ALL OPERATORS AT THIS SYNTAX ! 14994: * LEVEL. THE STACK BOTTOM IS RECOGNIZED FROM THE LEVEL ! 14995: * VALUE WHICH IS SAVED ON THE TOP OF THE STACK. ! 14996: * ! 14997: * JSR EXPDM CALL TO DUMP OPERATORS ! 14998: * (XS) POPPED AS REQUIRED ! 14999: * (XR,WA) DESTROYED ! 15000: * ! 15001: EXPDM PRC N,0 ENTRY POINT ! 15002: MOV XL,R$EXS SAVE XL VALUE ! 15003: * ! 15004: * LOOP TO DUMP OPERATORS ! 15005: * ! 15006: EXDM1 BLE 1(XS),=NUM05,EXDM2 JUMP IF STACK BOTTOM (SAVED LEVEL) ! 15007: JSR EXPOP ELSE POP ONE OPERATOR ! 15008: BRN EXDM1 AND LOOP BACK ! 15009: * ! 15010: * HERE AFTER POPPING ALL OPERATORS ! 15011: * ! 15012: EXDM2 MOV R$EXS,XL RESTORE XL ! 15013: ZER R$EXS RELEASE SAVE LOCATION ! 15014: EXI RETURN TO EXPDM CALLER ! 15015: ENP END PROCEDURE EXPDM ! 15016: EJC ! 15017: * ! 15018: * EXPOP-- POP OPERATOR (FOR EXPAN) ! 15019: * ! 15020: * EXPOP IS USED BY THE EXPAN ROUTINE TO CONDENSE ONE ! 15021: * OPERATOR FROM THE TOP OF THE SYNTAX STACK. AN APPROPRIATE ! 15022: * CMBLK IS BUILT FOR THE OPERATOR (UNARY OR BINARY) AND A ! 15023: * POINTER TO THIS CMBLK IS STACKED. ! 15024: * ! 15025: * EXPOP IS ALSO USED BY SCNGF (GOTO FIELD SCAN) PROCEDURE ! 15026: * ! 15027: * JSR EXPOP CALL TO POP OPERATOR ! 15028: * (XS) POPPED APPROPRIATELY ! 15029: * (XR,XL,WA) DESTROYED ! 15030: * ! 15031: EXPOP PRC N,0 ENTRY POINT ! 15032: MOV 1(XS),XR LOAD OPERATOR DV POINTER ! 15033: BEQ DVLPR(XR),=LLUNO,EXPO2 JUMP IF UNARY ! 15034: * ! 15035: * HERE FOR BINARY OPERATOR ! 15036: * ! 15037: MOV *CMBS$,WA SET SIZE OF BINARY OPERATOR CMBLK ! 15038: JSR ALLOC ALLOCATE SPACE FOR CMBLK ! 15039: MOV (XS)+,CMROP(XR) POP AND STORE RIGHT OPERAND PTR ! 15040: MOV (XS)+,XL POP AND LOAD OPERATOR DV PTR ! 15041: MOV (XS),CMLOP(XR) STORE LEFT OPERAND POINTER ! 15042: * ! 15043: * COMMON EXIT POINT ! 15044: * ! 15045: EXPO1 MOV =B$CMT,(XR) STORE TYPE CODE FOR CMBLK ! 15046: MOV DVTYP(XL),CMTYP(XR) STORE CMBLK NODE TYPE CODE ! 15047: MOV XL,CMOPN(XR) STORE DVPTR (=PTR TO DAC O$XXX) ! 15048: MOV WA,CMLEN(XR) STORE CMBLK LENGTH ! 15049: MOV XR,(XS) STORE RESULTING NODE PTR ON STACK ! 15050: EXI RETURN TO EXPOP CALLER ! 15051: * ! 15052: * HERE FOR UNARY OPERATOR ! 15053: * ! 15054: EXPO2 MOV *CMUS$,WA SET SIZE OF UNARY OPERATOR CMBLK ! 15055: JSR ALLOC ALLOCATE SPACE FOR CMBLK ! 15056: MOV (XS)+,CMROP(XR) POP AND STORE OPERAND POINTER ! 15057: MOV (XS),XL LOAD OPERATOR DV POINTER ! 15058: BRN EXPO1 MERGE BACK TO EXIT ! 15059: ENP END PROCEDURE EXPOP ! 15060: EJC ! 15061: * ! 15062: * GBCOL -- PERFORM GARBAGE COLLECTION ! 15063: * ! 15064: * GBCOL PERFORMS A GARBAGE COLLECTION ON THE DYNAMIC REGION ! 15065: * ALL BLOCKS WHICH ARE NO LONGER IN USE ARE ELIMINATED ! 15066: * BY MOVING BLOCKS WHICH ARE IN USE DOWN AND RESETTING ! 15067: * DNAMP, THE POINTER TO THE NEXT AVAILABLE LOCATION. ! 15068: * ! 15069: * (WB) MOVE OFFSET (SEE BELOW) ! 15070: * JSR GBCOL CALL TO COLLECT GARBAGE ! 15071: * (XR) DESTROYED ! 15072: * ! 15073: * THE FOLLOWING CONDITIONS MUST BE MET AT THE TIME WHEN ! 15074: * GBCOL IS CALLED. ! 15075: * ! 15076: * 1) ALL POINTERS TO BLOCKS IN THE DYNAMIC AREA MUST BE ! 15077: * ACCESSIBLE TO THE GARBAGE COLLECTOR. THIS MEANS ! 15078: * THAT THEY MUST OCCUR IN ONE OF THE FOLLOWING. ! 15079: * ! 15080: * A) MAIN STACK, WITH CURRENT TOP ! 15081: * ELEMENT BEING INDICATED BY XS ! 15082: * ! 15083: * B) IN RELOCATABLE FIELDS OF VRBLKS. ! 15084: * ! 15085: * C) IN REGISTER XL AT THE TIME OF CALL ! 15086: * ! 15087: * E) IN THE SPECIAL REGION OF WORKING ! 15088: * STORAGE WHERE NAMES BEGIN WITH R$. ! 15089: * ! 15090: * 2) ALL POINTERS MUST POINT TO THE START OF BLOCKS WITH ! 15091: * THE SOLE EXCEPTION OF THE CONTENTS OF THE CODE ! 15092: * POINTER REGISTER WHICH POINTS INTO THE R$COD BLOCK. ! 15093: * ! 15094: * 3) NO LOCATION WHICH APPEARS TO CONTAIN A POINTER ! 15095: * INTO THE DYNAMIC REGION MAY OCCUR UNLESS IT IS IN ! 15096: * FACT A POINTER TO THE START OF THE BLOCK. HOWEVER ! 15097: * POINTERS OUTSIDE THIS AREA MAY OCCUR AND WILL ! 15098: * NOT BE CHANGED BY THE GARBAGE COLLECTOR. ! 15099: * IT IS ESPECIALLY IMPORTANT TO MAKE SURE THAT XL ! 15100: * DOES NOT CONTAIN A GARBAGE VALUE FROM SOME PROCESS ! 15101: * CARRIED OUT BEFORE THE CALL TO THE COLLECTOR. ! 15102: * ! 15103: * GBCOL HAS THE CAPABILITY OF MOVING THE FINAL COMPACTED ! 15104: * RESULT UP IN MEMORY (WITH ADDRESSES ADJUSTED ACCORDINGLY) ! 15105: * THIS IS USED TO ADD SPACE TO THE STATIC REGION. THE ! 15106: * ENTRY VALUE OF WB IS THE NUMBER OF BAUS TO MOVE UP. ! 15107: * THE CALLER MUST GUARANTEE THAT THERE IS ENOUGH ROOM. ! 15108: * FURTHERMORE THE VALUE IN WB IF IT IS NON-ZERO, MUST BE AT ! 15109: * LEAST 256 SO THAT THE MWB INSTRUCTION CONDITIONS ARE MET. ! 15110: EJC ! 15111: * ! 15112: * GBCOL (CONTINUED) ! 15113: * ! 15114: * THE ALGORITHM, WHICH IS A MODIFICATION OF THE LISP-2 ! 15115: * GARBAGE COLLECTOR DEVISED BY R.DEWAR AND K.BELCHER ! 15116: * TAKES THREE PASSES AS FOLLOWS. ! 15117: * ! 15118: * 1) ALL POINTERS IN MEMORY ARE SCANNED AND BLOCKS IN USE ! 15119: * DETERMINED FROM THIS SCAN. NOTE THAT THIS PROCEDURE ! 15120: * IS RECURSIVE AND USES THE MAIN STACK FOR LINKAGE. ! 15121: * THE MARKING PROCESS IS THUS SIMILAR TO THAT USED IN ! 15122: * A STANDARD LISP COLLECTOR. HOWEVER THE METHOD OF ! 15123: * ACTUALLY MARKING THE BLOCKS IS DIFFERENT. ! 15124: * ! 15125: * THE FIRST FIELD OF A BLOCK NORMALLY CONTAINS A ! 15126: * CODE ENTRY POINT POINTER. SUCH AN ENTRY POINTER ! 15127: * CAN BE DISTINGUISHED FROM THE ADDRESS OF ANY POINTER ! 15128: * TO BE PROCESSED BY THE COLLECTOR. DURING GARBAGE ! 15129: * COLLECTION, THIS WORD IS USED TO BUILD A BACK CHAIN ! 15130: * OF POINTERS THROUGH FIELDS WHICH POINT TO THE BLOCK. ! 15131: * THE END OF THE CHAIN IS MARKED BY THE OCCURENCE ! 15132: * OF THE WORD WHICH USED TO BE IN THE FIRST WORD OF ! 15133: * THE BLOCK. THIS BACKCHAIN SERVES BOTH AS A MARK ! 15134: * INDICATING THAT THE BLOCK IS IN USE AND AS A LIST OF ! 15135: * REFERENCES FOR THE RELOCATION PHASE. ! 15136: * ! 15137: * 2) STORAGE IS SCANNED SEQUENTIALLY TO DISCOVER WHICH ! 15138: * BLOCKS ARE CURRENTLY IN USE AS INDICATED BY THE ! 15139: * PRESENCE OF A BACKCHAIN. TWO POINTERS ARE MAINTAINED ! 15140: * ONE SCANS THROUGH LOOKING AT EACH BLOCK. THE OTHER ! 15141: * IS INCREMENTED ONLY FOR BLOCKS FOUND TO BE IN USE. ! 15142: * IN THIS WAY, THE EVENTUAL LOCATION OF EACH BLOCK CAN ! 15143: * BE DETERMINED WITHOUT ACTUALLY MOVING ANY BLOCKS. ! 15144: * AS EACH BLOCK WHICH IS IN USE IS PROCESSED, THE BACK ! 15145: * CHAIN IS USED TO RESET ALL POINTERS WHICH POINT TO ! 15146: * THIS BLOCK TO CONTAIN ITS NEW ADDRESS, I.E. THE ! 15147: * ADDRESS IT WILL OCCUPY AFTER THE BLOCKS ARE MOVED. ! 15148: * THE FIRST WORD OF THE BLOCK, TAKEN FROM THE END OF ! 15149: * THE CHAIN IS RESTORED AT THIS POINT. ! 15150: * ! 15151: * DURING PASS 2, THE COLLECTOR BUILDS BLOCKS WHICH ! 15152: * DESCRIBE THE REGIONS OF STORAGE WHICH ARE TO BE ! 15153: * MOVED IN THE THIRD PASS. THERE IS ONE DESCRIPTOR FOR ! 15154: * EACH CONTIGUOUS SET OF GOOD BLOCKS. THE DESCRIPTOR ! 15155: * IS BUILT JUST BEHIND THE BLOCK TO BE MOVED AND ! 15156: * CONTAINS A POINTER TO THE NEXT BLOCK AND THE NUMBER ! 15157: * OF WORDS TO BE MOVED. ! 15158: * ! 15159: * 3) IN THE THIRD AND FINAL PASS, THE MOVE DESCRIPTOR ! 15160: * BLOCKS BUILT IN PASS TWO ARE USED TO ACTUALLY MOVE ! 15161: * THE BLOCKS DOWN TO THE BOTTOM OF THE DYNAMIC REGION. ! 15162: * THE COLLECTION IS THEN COMPLETE AND THE NEXT ! 15163: * AVAILABLE LOCATION POINTER IS RESET. ! 15164: EJC ! 15165: * ! 15166: * GBCOL (CONTINUED) ! 15167: * ! 15168: GBCOL PRC E,0 ENTRY POINT ! 15169: BNZ DMVCH,GBC14 FAIL IF IN MID-DUMP ! 15170: MNZ GBCFL NOTE GBCOL ENTERED ! 15171: MOV WA,GBSVA SAVE ENTRY WA ! 15172: MOV WB,GBSVB SAVE ENTRY WB ! 15173: MOV WC,GBSVC SAVE ENTRY WC ! 15174: MOV XL,-(XS) SAVE ENTRY XL ! 15175: SCP WA GET CODE POINTER VALUE ! 15176: SUB R$COD,WA MAKE RELATIVE ! 15177: LCP WA AND RESTORE ! 15178: * ! 15179: * PROCESS STACK ENTRIES ! 15180: * ! 15181: MOV XS,XR POINT TO STACK FRONT ! 15182: MOV STBAS,XL POINT PAST END OF STACK ! 15183: BGE XL,XR,GBC00 OK IF D-STACK ! 15184: MOV XL,XR REVERSE IF ... ! 15185: MOV XS,XL ... U-STACK ! 15186: * ! 15187: * PROCESS THE STACK ! 15188: * ! 15189: GBC00 JSR GBCPF PROCESS POINTERS ON STACK ! 15190: * ! 15191: * PROCESS SPECIAL WORK LOCATIONS ! 15192: * ! 15193: MOV =R$AAA,XR POINT TO START OF RELOCATABLE LOCS ! 15194: MOV =R$YYY,XL POINT PAST END OF RELOCATABLE LOCS ! 15195: JSR GBCPF PROCESS WORK FIELDS ! 15196: * ! 15197: * PREPARE TO PROCESS VARIABLE BLOCKS ! 15198: * ! 15199: MOV HSHTB,WA POINT TO FIRST HASH SLOT POINTER ! 15200: * ! 15201: * LOOP THROUGH HASH SLOTS ! 15202: * ! 15203: GBC01 MOV WA,XL POINT TO NEXT SLOT ! 15204: ICA WA BUMP BUCKET POINTER ! 15205: MOV WA,GBCNM SAVE BUCKET POINTER ! 15206: EJC ! 15207: * ! 15208: * GBCOL (CONTINUED) ! 15209: * ! 15210: * LOOP THROUGH VARIABLES ON ONE HASH CHAIN ! 15211: * ! 15212: GBC02 MOV (XL),XR LOAD PTR TO NEXT VRBLK ! 15213: BZE XR,GBC03 JUMP IF END OF CHAIN ! 15214: MOV XR,XL ELSE COPY VRBLK POINTER ! 15215: ADD *VRVAL,XR POINT TO FIRST RELOC FLD ! 15216: ADD *VRNXT,XL POINT PAST LAST (AND TO LINK PTR) ! 15217: JSR GBCPF PROCESS RELOC FIELDS IN VRBLK ! 15218: BRN GBC02 LOOP BACK FOR NEXT BLOCK ! 15219: * ! 15220: * HERE AT END OF ONE HASH CHAIN ! 15221: * ! 15222: GBC03 MOV GBCNM,WA RESTORE BUCKET POINTER ! 15223: BNE WA,HSHTE,GBC01 LOOP BACK IF MORE BUCKETS TO GO ! 15224: EJC ! 15225: * ! 15226: * GBCOL (CONTINUED) ! 15227: * ! 15228: * NOW WE ARE READY TO START PASS TWO. REGISTERS ARE USED ! 15229: * AS FOLLOWS IN PASS TWO. ! 15230: * ! 15231: * (XR) SCANS THROUGH ALL BLOCKS ! 15232: * (WC) POINTER TO EVENTUAL LOCATION ! 15233: * ! 15234: * THE MOVE DESCRIPTION BLOCKS BUILT IN THIS PASS HAVE ! 15235: * THE FOLLOWING FORMAT. ! 15236: * ! 15237: * WORD 1 POINTER TO NEXT MOVE BLOCK, ! 15238: * ZERO IF END OF CHAIN OF BLOCKS ! 15239: * ! 15240: * WORD 2 LENGTH OF BLOCKS TO BE MOVED IN ! 15241: * BAUS. SET TO THE ADDRESS OF THE ! 15242: * FIRST BAU WHILE ACTUALLY SCANNING ! 15243: * THE BLOCKS. ! 15244: * ! 15245: * THE FIRST ENTRY ON THIS CHAIN IS A SPECIAL ENTRY ! 15246: * CONSISTING OF THE TWO WORDS GBCNM AND GBCNS. AFTER ! 15247: * BUILDING THE CHAIN OF MOVE DESCRIPTORS, GBCNM POINTS TO ! 15248: * THE FIRST REAL MOVE BLOCK, AND GBCNS IS THE LENGTH OF ! 15249: * BLOCKS IN USE AT THE START OF STORAGE WHICH NEED NOT ! 15250: * BE MOVED SINCE THEY ARE IN THE CORRECT POSITION. ! 15251: * ! 15252: GBC04 MOV DNAMB,XR POINT TO FIRST BLOCK ! 15253: MOV XR,WC SET AS FIRST EVENTUAL LOCATION ! 15254: ADD GBSVB,WC ADD OFFSET FOR EVENTUAL MOVE UP ! 15255: ZER GBCNM CLEAR INITIAL FORWARD POINTER ! 15256: MOV =GBCNM,GBCLM INITIALIZE PTR TO LAST MOVE BLOCK ! 15257: MOV XR,GBCNS INITIALIZE FIRST ADDRESS ! 15258: * ! 15259: * LOOP THROUGH A SERIES OF BLOCKS IN USE ! 15260: * ! 15261: GBC05 BEQ XR,DNAMP,GBC07 JUMP IF END OF USED REGION ! 15262: MOV (XR),WA ELSE GET FIRST WORD ! 15263: .IF .CEPP ! 15264: BOD WA,GBC07 JUMP IF ENTRY POINTER (UNUSED) ! 15265: .ELSE ! 15266: BHI WA,=P$YYY,GBC06 SKIP IF NOT ENTRY PTR (IN USE) ! 15267: BHI WA,=B$AAA,GBC07 JUMP IF ENTRY POINTER (UNUSED) ! 15268: .FI ! 15269: * ! 15270: * HERE FOR BLOCK IN USE, LOOP TO RELOCATE REFERENCES ! 15271: * ! 15272: GBC06 MOV WA,XL COPY POINTER ! 15273: MOV (XL),WA LOAD FORWARD POINTER ! 15274: MOV WC,(XL) RELOCATE REFERENCE ! 15275: .IF .CEPP ! 15276: BEV WA,GBC06 LOOP BACK IF NOT END OF CHAIN ! 15277: .ELSE ! 15278: BHI WA,=P$YYY,GBC06 LOOP BACK IF NOT END OF CHAIN ! 15279: BLO WA,=B$AAA,GBC06 LOOP BACK IF NOT END OF CHAIN ! 15280: .FI ! 15281: EJC ! 15282: * ! 15283: * GBCOL (CONTINUED) ! 15284: * ! 15285: * AT END OF CHAIN, RESTORE FIRST WORD AND BUMP PAST ! 15286: * ! 15287: MOV WA,(XR) RESTORE FIRST WORD ! 15288: JSR BLKLN GET LENGTH OF THIS BLOCK ! 15289: ADD WA,XR BUMP ACTUAL POINTER ! 15290: ADD WA,WC BUMP EVENTUAL POINTER ! 15291: BRN GBC05 LOOP BACK FOR NEXT BLOCK ! 15292: * ! 15293: * HERE AT END OF A SERIES OF BLOCKS IN USE ! 15294: * ! 15295: GBC07 MOV XR,WA COPY POINTER PAST LAST BLOCK ! 15296: MOV GBCLM,XL POINT TO PREVIOUS MOVE BLOCK ! 15297: SUB 1(XL),WA SUBTRACT STARTING ADDRESS ! 15298: MOV WA,1(XL) STORE LENGTH OF BLOCK TO BE MOVED ! 15299: * ! 15300: * LOOP THROUGH A SERIES OF BLOCKS NOT IN USE ! 15301: * ! 15302: GBC08 BEQ XR,DNAMP,GBC10 JUMP IF END OF USED REGION ! 15303: MOV (XR),WA ELSE LOAD FIRST WORD OF NEXT BLOCK ! 15304: .IF .CEPP ! 15305: BEV WA,GBC09 JUMP IF IN USE ! 15306: .ELSE ! 15307: BHI WA,=P$YYY,GBC09 JUMP IF IN USE ! 15308: BLO WA,=B$AAA,GBC09 JUMP IF IN USE ! 15309: .FI ! 15310: JSR BLKLN ELSE GET LENGTH OF NEXT BLOCK ! 15311: ADD WA,XR PUSH POINTER ! 15312: BRN GBC08 AND LOOP BACK ! 15313: * ! 15314: * HERE FOR A BLOCK IN USE AFTER PROCESSING A SERIES OF ! 15315: * BLOCKS WHICH WERE NOT IN USE, BUILD NEW MOVE BLOCK. ! 15316: * ! 15317: GBC09 SUB *NUM02,XR POINT 2 WORDS BEHIND FOR MOVE BLOCK ! 15318: MOV GBCLM,XL POINT TO PREVIOUS MOVE BLOCK ! 15319: MOV XR,(XL) SET FORWARD PTR IN PREVIOUS BLOCK ! 15320: ZER (XR) ZERO FORWARD PTR OF NEW BLOCK ! 15321: MOV XR,GBCLM REMEMBER ADDRESS OF THIS BLOCK ! 15322: MOV XR,XL COPY PTR TO MOVE BLOCK ! 15323: ADD *NUM02,XR POINT BACK TO BLOCK IN USE ! 15324: MOV XR,1(XL) STORE STARTING ADDRESS ! 15325: BRN GBC06 JUMP TO PROCESS BLOCK IN USE ! 15326: EJC ! 15327: * ! 15328: * GBCOL (CONTINUED) ! 15329: * ! 15330: * HERE FOR PASS THREE -- ACTUALLY MOVE THE BLOCKS DOWN ! 15331: * ! 15332: * (XL) POINTER TO OLD LOCATION ! 15333: * (XR) POINTER TO NEW LOCATION ! 15334: * ! 15335: GBC10 MOV DNAMB,XR POINT TO START OF STORAGE ! 15336: ADD GBCNS,XR BUMP PAST UNMOVED BLOCKS AT START ! 15337: * ! 15338: * LOOP THROUGH MOVE DESCRIPTORS ! 15339: * ! 15340: GBC11 MOV GBCNM,XL POINT TO NEXT MOVE BLOCK ! 15341: BZE XL,GBC12 JUMP IF END OF CHAIN ! 15342: MOV (XL)+,GBCNM MOVE POINTER DOWN CHAIN ! 15343: MOV (XL)+,WA GET LENGTH TO MOVE ! 15344: MVW PERFORM MOVE ! 15345: BRN GBC11 LOOP BACK ! 15346: * ! 15347: * NOW TEST FOR MOVE UP ! 15348: * ! 15349: GBC12 MOV XR,DNAMP SET NEXT AVAILABLE LOC PTR ! 15350: MOV GBSVB,WB RELOAD MOVE OFFSET ! 15351: BZE WB,GBC13 JUMP IF NO MOVE REQUIRED ! 15352: MOV XR,XL ELSE COPY OLD TOP OF CORE ! 15353: ADD WB,XR POINT TO NEW TOP OF CORE ! 15354: MOV XR,DNAMP SAVE NEW TOP OF CORE POINTER ! 15355: MOV XL,WA COPY OLD TOP ! 15356: SUB DNAMB,WA MINUS OLD BOTTOM = LENGTH ! 15357: ADD WB,DNAMB BUMP BOTTOM TO GET NEW VALUE ! 15358: MWB PERFORM MOVE (BACKWARDS) ! 15359: * ! 15360: * MERGE HERE TO EXIT ! 15361: * ! 15362: GBC13 MOV GBSVA,WA RESTORE WA ! 15363: SCP WC GET CODE POINTER ! 15364: ADD R$COD,WC MAKE ABSOLUTE AGAIN ! 15365: LCP WC AND REPLACE ABSOLUTE VALUE ! 15366: MOV GBSVC,WC RESTORE WC ! 15367: MOV (XS)+,XL RESTORE ENTRY XL ! 15368: ICV GBCNT INCREMENT COUNT OF COLLECTIONS ! 15369: ZER XR CLEAR GARBAGE VALUE IN XR ! 15370: ZER GBCFL NOTE EXIT FROM GBCOL ! 15371: EXI EXIT TO GBCOL CALLER ! 15372: * ! 15373: * GARBAGE COLLECTION NOT ALLOWED WHILST DUMPING ! 15374: * ! 15375: GBC14 ICV ERRFT FATAL ERROR ! 15376: ERB 229,INSUFFICIENT MEMORY TO COMPLETE DUMP ! 15377: ENP END PROCEDURE GBCOL ! 15378: EJC ! 15379: * ! 15380: * GBCPF -- PROCESS FIELDS FOR GARBAGE COLLECTOR ! 15381: * ! 15382: * THIS PROCEDURE IS USED BY THE GARBAGE COLLECTOR TO ! 15383: * PROCESS FIELDS IN PASS ONE. SEE GBCOL FOR FULL DETAILS. ! 15384: * ! 15385: * (XR) PTR TO FIRST LOCATION TO PROCESS ! 15386: * (XL) PTR PAST LAST LOCATION TO PROCESS ! 15387: * JSR GBCPF CALL TO PROCESS FIELDS ! 15388: * (XR,WA,WB,WC,IA) DESTROYED ! 15389: * ! 15390: * NOTE THAT ALTHOUGH THIS PROCEDURE USES A RECURSIVE ! 15391: * APPROACH, IT CONTROLS ITS OWN STACK AND IS NOT RECURSIVE. ! 15392: * ! 15393: GBCPF PRC E,0 ENTRY POINT ! 15394: ZER -(XS) SET ZERO TO MARK BOTTOM OF STACK ! 15395: MOV XL,-(XS) SAVE END POINTER ! 15396: * ! 15397: * MERGE HERE TO GO DOWN A LEVEL AND START A NEW LOOP ! 15398: * ! 15399: * 1(XS) NEXT LVL FIELD PTR (0 AT OUTER LVL) ! 15400: * 0(XS) PTR PAST LAST FIELD TO PROCESS ! 15401: * (XR) PTR TO FIRST FIELD TO PROCESS ! 15402: * ! 15403: * LOOP TO PROCESS SUCCESSIVE FIELDS ! 15404: * ! 15405: GPF01 MOV (XR),XL LOAD FIELD CONTENTS ! 15406: MOV XR,WC SAVE FIELD POINTER ! 15407: .IF .CRPP ! 15408: BOD XL,GPF02 JUMP IF NOT PTR INTO DYNAMIC AREA ! 15409: .ELSE ! 15410: .FI ! 15411: BLT XL,DNAMB,GPF02 JUMP IF NOT PTR INTO DYNAMIC AREA ! 15412: BGE XL,DNAMP,GPF02 JUMP IF NOT PTR INTO DYNAMIC AREA ! 15413: * ! 15414: * HERE WE HAVE A PTR TO A BLOCK IN THE DYNAMIC AREA. ! 15415: * LINK THIS FIELD ONTO THE REFERENCE BACKCHAIN. ! 15416: * ! 15417: MOV (XL),WA LOAD PTR TO CHAIN (OR ENTRY PTR) ! 15418: MOV XR,(XL) SET THIS FIELD AS NEW HEAD OF CHAIN ! 15419: MOV WA,(XR) SET FORWARD POINTER ! 15420: * ! 15421: * NOW SEE IF THIS BLOCK HAS BEEN PROCESSED BEFORE ! 15422: * ! 15423: .IF .CEPP ! 15424: BOD WA,GPF03 JUMP IF NOT ALREADY PROCESSED ! 15425: .ELSE ! 15426: BHI WA,=P$YYY,GPF02 JUMP IF ALREADY PROCESSED ! 15427: BHI WA,=B$AAA,GPF03 JUMP IF NOT ALREADY PROCESSED ! 15428: .FI ! 15429: * ! 15430: * HERE TO MOVE TO NEXT FIELD ! 15431: * ! 15432: GPF02 MOV WC,XR RESTORE FIELD POINTER ! 15433: ICA XR BUMP TO NEXT FIELD ! 15434: BNE XR,(XS),GPF01 LOOP BACK IF MORE TO GO ! 15435: EJC ! 15436: * ! 15437: * GBCPF (CONTINUED) ! 15438: * ! 15439: * HERE WE POP UP A LEVEL AFTER FINISHING A BLOCK ! 15440: * ! 15441: MOV (XS)+,XL RESTORE POINTER PAST END ! 15442: MOV (XS)+,WC RESTORE BLOCK POINTER ! 15443: BNZ WC,GPF02 CONTINUE LOOP UNLESS OUTER LEVL ! 15444: EXI RETURN TO CALLER IF OUTER LEVEL ! 15445: * ! 15446: * HERE TO PROCESS AN ACTIVE BLOCK WHICH HAS NOT BEEN DONE ! 15447: * ! 15448: GPF03 MOV XL,XR COPY BLOCK POINTER ! 15449: MOV WA,XL COPY FIRST WORD OF BLOCK ! 15450: LEI XL LOAD ENTRY POINT ID (BL$XX) ! 15451: * ! 15452: * BLOCK TYPE SWITCH. NOTE THAT BLOCKS WITH NO RELOCATABLE ! 15453: * FIELDS JUST RETURN TO GPF02 HERE TO CONTINE TO NEXT FLD. ! 15454: * ! 15455: BSW XL,BL$$$ SWITCH ON BLOCK TYPE ! 15456: IFF BL$AR,GPF06 ARBLK ! 15457: .IF .CNBF ! 15458: .ELSE ! 15459: IFF BL$BC,GPF18 BCBLK ! 15460: IFF BL$BF,GPF02 BFBLK ! 15461: .FI ! 15462: IFF BL$CC,GPF07 CCBLK ! 15463: IFF BL$CD,GPF08 CDBLK ! 15464: IFF BL$CM,GPF04 CMBLK ! 15465: IFF BL$CO,GPF19 COBLK ! 15466: IFF BL$DF,GPF02 DFBLK ! 15467: IFF BL$EV,GPF10 EVBLK ! 15468: IFF BL$EX,GPF17 EXBLK ! 15469: IFF BL$FF,GPF11 FFBLK ! 15470: IFF BL$NM,GPF10 NMBLK ! 15471: IFF BL$P0,GPF10 P0BLK ! 15472: IFF BL$P1,GPF12 P1BLK ! 15473: IFF BL$P2,GPF12 P2BLK ! 15474: IFF BL$PD,GPF13 PDBLK ! 15475: IFF BL$PF,GPF14 PFBLK ! 15476: IFF BL$TB,GPF08 TBBLK ! 15477: IFF BL$TE,GPF15 TEBLK ! 15478: IFF BL$TR,GPF16 TRBLK ! 15479: IFF BL$VC,GPF08 VCBLK ! 15480: IFF BL$XR,GPF09 XRBLK ! 15481: IFF BL$CT,GPF02 CTBLK ! 15482: IFF BL$EF,GPF02 EFBLK ! 15483: IFF BL$IC,GPF02 ICBLK ! 15484: IFF BL$KV,GPF02 KVBLK ! 15485: .IF .CNRA ! 15486: .ELSE ! 15487: IFF BL$RC,GPF02 RCBLK ! 15488: .FI ! 15489: IFF BL$SC,GPF02 SCBLK ! 15490: IFF BL$SE,GPF02 SEBLK ! 15491: IFF BL$XN,GPF02 XNBLK ! 15492: ESW END OF JUMP TABLE ! 15493: EJC ! 15494: * ! 15495: * GBCPF (CONTINUED) ! 15496: * ! 15497: * CMBLK ! 15498: * ! 15499: GPF04 MOV CMLEN(XR),WA LOAD LENGTH ! 15500: MOV *CMTYP,WB SET OFFSET ! 15501: * ! 15502: * HERE TO PUSH DOWN TO NEW LEVEL ! 15503: * ! 15504: * (WC) FIELD PTR AT PREVIOUS LEVEL ! 15505: * (XR) PTR TO NEW BLOCK ! 15506: * (WA) LENGTH (RELOC FLDS + FLDS AT START) ! 15507: * (WB) OFFSET TO FIRST RELOC FIELD ! 15508: * ! 15509: GPF05 ADD XR,WA POINT PAST LAST RELOC FIELD ! 15510: ADD WB,XR POINT TO FIRST RELOC FIELD ! 15511: MOV WC,-(XS) STACK OLD FIELD POINTER ! 15512: MOV WA,-(XS) STACK NEW LIMIT POINTER ! 15513: CHK CHECK FOR STACK OVERFLOW ! 15514: BRN GPF01 IF OK, BACK TO PROCESS ! 15515: * ! 15516: * ARBLK ! 15517: * ! 15518: GPF06 MOV ARLEN(XR),WA LOAD LENGTH ! 15519: MOV AROFS(XR),WB SET OFFSET TO 1ST RELOC FLD (ARPRO) ! 15520: BRN GPF05 ALL SET ! 15521: * ! 15522: * CCBLK ! 15523: * ! 15524: GPF07 MOV CCUSE(XR),WA SET LENGTH IN USE ! 15525: MOV *CCUSE,WB 1ST WORD (MAKE SURE AT LEAST ONE) ! 15526: BRN GPF05 ALL SET ! 15527: EJC ! 15528: * ! 15529: * GBCPF (CONTINUED) ! 15530: * ! 15531: * CDBLK, TBBLK, VCBLK ! 15532: * ! 15533: GPF08 MOV OFFS2(XR),WA LOAD LENGTH ! 15534: MOV *OFFS3,WB SET OFFSET ! 15535: BRN GPF05 JUMP BACK ! 15536: * ! 15537: * XRBLK ! 15538: * ! 15539: GPF09 MOV XRLEN(XR),WA LOAD LENGTH ! 15540: MOV *XRPTR,WB SET OFFSET ! 15541: BRN GPF05 JUMP BACK ! 15542: * ! 15543: * EVBLK, NMBLK, P0BLK ! 15544: * ! 15545: GPF10 MOV *OFFS2,WA POINT PAST SECOND FIELD ! 15546: MOV *OFFS1,WB OFFSET IS ONE (ONLY RELOC FLD IS 2) ! 15547: BRN GPF05 ALL SET ! 15548: * ! 15549: * FFBLK ! 15550: * ! 15551: GPF11 MOV *FFOFS,WA SET LENGTH ! 15552: MOV *FFNXT,WB SET OFFSET ! 15553: BRN GPF05 ALL SET ! 15554: * ! 15555: * P1BLK, P2BLK ! 15556: * ! 15557: GPF12 MOV *PARM2,WA LENGTH (PARM2 IS NON-RELOCATABLE) ! 15558: MOV *PTHEN,WB SET OFFSET ! 15559: BRN GPF05 ALL SET ! 15560: EJC ! 15561: * ! 15562: * GBCPF (CONTINUED) ! 15563: * ! 15564: * PDBLK ! 15565: * ! 15566: GPF13 MOV PDDFP(XR),XL LOAD PTR TO DFBLK ! 15567: MOV DFPDL(XL),WA GET PDBLK LENGTH ! 15568: MOV *PDFLD,WB SET OFFSET ! 15569: BRN GPF05 ALL SET ! 15570: * ! 15571: * PFBLK ! 15572: * ! 15573: GPF14 MOV *PFARG,WA LENGTH PAST LAST RELOC ! 15574: MOV *PFCOD,WB OFFSET TO FIRST RELOC ! 15575: BRN GPF05 ALL SET ! 15576: * ! 15577: * TEBLK ! 15578: * ! 15579: GPF15 MOV *TESI$,WA SET LENGTH ! 15580: MOV *TESUB,WB AND OFFSET ! 15581: BRN GPF05 ALL SET ! 15582: * ! 15583: * TRBLK ! 15584: * ! 15585: GPF16 MOV *TRSI$,WA SET LENGTH ! 15586: MOV *TRVAL,WB AND OFFSET ! 15587: BRN GPF05 ALL SET ! 15588: * ! 15589: * EXBLK ! 15590: * ! 15591: GPF17 MOV EXLEN(XR),WA LOAD LENGTH ! 15592: MOV *EXFLC,WB SET OFFSET ! 15593: BRN GPF05 JUMP BACK ! 15594: .IF .CNBF ! 15595: .ELSE ! 15596: * ! 15597: * BCBLK ! 15598: * ! 15599: GPF18 MOV *BCSI$,WA SET LENGTH ! 15600: MOV *BCBUF,WB AND OFFSET ! 15601: BRN GPF05 ALL SET ! 15602: .FI ! 15603: * ! 15604: * COBLK ! 15605: * ! 15606: GPF19 MOV *COSI$,WA SET LENGTH ! 15607: MOV *CONXT,WB AND OFFSET ! 15608: BRN GPF05 ALL SET ! 15609: ENP END PROCEDURE GBCPF ! 15610: .IF .CNBF ! 15611: .ELSE ! 15612: EJC ! 15613: * ! 15614: * GTBUF -- GET BUFFER ! 15615: * ! 15616: * GTBUF IS PASSED AN OBJECT AND RETURNS A BUFFER IF ! 15617: * POSSIBLE. UNLESS THE OBJECT IS ALREADY A BUFFER, ! 15618: * THIS INVOLVES A CONVERSION TO STRING AND THEN ! 15619: * STRING TO BUFFER. ! 15620: * ! 15621: * (XR) OBJECT TO BE CONVERTED ! 15622: * JSR GTBUF CALL TO GET BUFFER ! 15623: * PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE ! 15624: * (XR) RESULTING BUFFER ! 15625: * (XL,WA,WB,WC) DESTROYED ! 15626: * ! 15627: GTBUF PRC E,1 ENTRY POINT ! 15628: BEQ (XR),=B$BCT,GTB01 EXIT IF ALREADY BUFFER ! 15629: MOV XR,-(XS) STACK TO CONVERT TO STRING ! 15630: JSR GTSTG CONVERT TO STRING ! 15631: PPM GTB02 CONVERSION ERROR ! 15632: MOV XR,XL SAVE STRING POINTER ! 15633: JSR ALOBF ALLOCATE BUFFER OF SAME SIZE ! 15634: JSR INSBF COPY IN THE STRING ! 15635: PPM ALREADY STRING - CANT FAIL TO CNV ! 15636: PPM MUST BE ENOUGH ROOM ! 15637: * ! 15638: * MERGE TO EXIT WITH BUFFER CONTROL BLK IN (XR) ! 15639: * ! 15640: GTB01 EXI RETURN TO CALLER ! 15641: * ! 15642: * HERE ON CONVERSION FAILURE ! 15643: * ! 15644: GTB02 EXI 1 TAKE FAILURE EXIT ! 15645: ENP ! 15646: .FI ! 15647: EJC ! 15648: * ! 15649: * GTARR -- GET ARRAY ! 15650: * ! 15651: * GTARR IS PASSED AN OBJECT AND RETURNS AN ARRAY IF POSSIBLE ! 15652: * ! 15653: * (XR) VALUE TO BE CONVERTED ! 15654: * JSR GTARR CALL TO GET ARRAY ! 15655: * PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE ! 15656: * (XR) RESULTING ARRAY ! 15657: * (XL,WA,WB,WC) DESTROYED ! 15658: * ! 15659: GTARR PRC E,1 ENTRY POINT ! 15660: MOV (XR),WA LOAD TYPE WORD ! 15661: BEQ WA,=B$ART,GTAR8 EXIT IF ALREADY AN ARRAY ! 15662: BEQ WA,=B$VCT,GTAR8 EXIT IF ALREADY AN ARRAY ! 15663: MOV XR,-(XS) PLACE POSSIBLE TBBLK PTR ON STACK ! 15664: BNE WA,=B$TBT,GTAR9 ELSE FAIL IF NOT A TABLE ! 15665: * ! 15666: * HERE WE CONVERT A TABLE TO AN ARRAY ! 15667: * ! 15668: ZER XR SIGNAL FIRST PASS ! 15669: ZER WB ZERO NON-NULL ELEMENT COUNT ! 15670: * ! 15671: * THE FOLLOWING CODE IS EXECUTED TWICE. ON THE FIRST PASS, ! 15672: * SIGNALLED BY XR=0, THE NUMBER OF NON-NULL ELEMENTS IN ! 15673: * THE TABLE IS COUNTED IN WB. IN THE SECOND PASS, WHERE ! 15674: * XR IS A POINTER INTO THE ARBLK, THE NAME AND VALUE ARE ! 15675: * ENTERED INTO THE CURRENT ARBLK LOCATION. ! 15676: * ! 15677: GTAR1 MOV (XS),XL POINT TO TABLE ! 15678: ADD TBLEN(XL),XL POINT PAST LAST BUCKET ! 15679: SUB *TBBUK,XL SET FIRST BUCKET OFFSET ! 15680: MOV XL,WA COPY ADJUSTED POINTER ! 15681: * ! 15682: * LOOP THROUGH BUCKETS IN TABLE BLOCK ! 15683: * NEXT THREE LINES OF CODE RELY ON TENXT HAVING A VALUE ! 15684: * 1 LESS THAN TBBUK. ! 15685: * ! 15686: GTAR2 MOV WA,XL COPY BUCKET POINTER ! 15687: DCA WA DECREMENT BUCKET POINTER ! 15688: * ! 15689: * LOOP THROUGH TEBLKS ON ONE BUCKET CHAIN ! 15690: * ! 15691: GTAR3 MOV TENXT(XL),XL POINT TO NEXT TEBLK ! 15692: BEQ XL,(XS),GTAR6 JUMP IF CHAIN END (TBBLK PTR) ! 15693: MOV XL,CNVTP ELSE SAVE TEBLK POINTER ! 15694: * ! 15695: * LOOP TO FIND VALUE DOWN TRBLK CHAIN ! 15696: * ! 15697: GTAR4 MOV TEVAL(XL),XL LOAD VALUE ! 15698: BEQ (XL),=B$TRT,GTAR4 LOOP TILL VALUE FOUND ! 15699: MOV XL,WC COPY VALUE ! 15700: MOV CNVTP,XL RESTORE TEBLK POINTER ! 15701: EJC ! 15702: * ! 15703: * GTARR (CONTINUED) ! 15704: * ! 15705: * NOW CHECK FOR NULL AND TEST CASES ! 15706: * ! 15707: BEQ WC,=NULLS,GTAR3 LOOP BACK TO IGNORE NULL VALUE ! 15708: BNZ XR,GTAR5 JUMP IF SECOND PASS ! 15709: ICV WB FOR THE FIRST PASS, BUMP COUNT ! 15710: BRN GTAR3 AND LOOP BACK FOR NEXT TEBLK ! 15711: * ! 15712: * HERE IN SECOND PASS ! 15713: * ! 15714: GTAR5 MOV TESUB(XL),(XR)+ STORE SUBSCRIPT NAME ! 15715: MOV WC,(XR)+ STORE VALUE IN ARBLK ! 15716: BRN GTAR3 LOOP BACK FOR NEXT TEBLK ! 15717: * ! 15718: * HERE AFTER SCANNING TEBLKS ON ONE CHAIN ! 15719: * ! 15720: GTAR6 BNE WA,(XS),GTAR2 LOOP BACK IF MORE BUCKETS TO GO ! 15721: BNZ XR,GTAR7 ELSE JUMP IF SECOND PASS ! 15722: * ! 15723: * HERE AFTER COUNTING NON-NULL ELEMENTS ! 15724: * ! 15725: BZE WB,GTAR9 FAIL IF NO NON-NULL ELEMENTS ! 15726: MOV WB,WA ELSE COPY COUNT ! 15727: ADD WB,WA DOUBLE (TWO WORDS/ELEMENT) ! 15728: ADD =ARVL2,WA ADD SPACE FOR STANDARD FIELDS ! 15729: WTB WA CONVERT LENGTH TO BAUS ! 15730: BGE WA,MXLEN,GTAR9 FAIL IF TOO LONG FOR ARRAY ! 15731: JSR ALLOC ELSE ALLOCATE SPACE FOR ARBLK ! 15732: MOV =B$ART,(XR) STORE TYPE WORD ! 15733: ZER IDVAL(XR) ZERO ID FOR THE MOMENT ! 15734: MOV WA,ARLEN(XR) STORE LENGTH ! 15735: MOV =NUM02,ARNDM(XR) SET DIMENSIONS = 2 ! 15736: LDI INTV1 GET INTEGER ONE ! 15737: STI ARLBD(XR) STORE AS LBD 1 ! 15738: STI ARLB2(XR) STORE AS LBD 2 ! 15739: LDI INTV2 LOAD INTEGER TWO ! 15740: STI ARDM2(XR) STORE AS DIM 2 ! 15741: MTI WB GET ELEMENT COUNT AS INTEGER ! 15742: STI ARDIM(XR) STORE AS DIM 1 ! 15743: ZER ARPR2(XR) ZERO PROTOTYPE FIELD FOR NOW ! 15744: MOV *ARPR2,AROFS(XR) SET OFFSET FIELD (SIGNAL PASS 2) ! 15745: MOV XR,WB SAVE ARBLK POINTER ! 15746: ADD *ARVL2,XR POINT TO FIRST ELEMENT LOCATION ! 15747: BRN GTAR1 JUMP BACK TO FILL IN ELEMENTS ! 15748: EJC ! 15749: * ! 15750: * GTARR (CONTINUED) ! 15751: * ! 15752: * HERE AFTER FILLING IN ELEMENT VALUES ! 15753: * ! 15754: GTAR7 MOV WB,XR RESTORE ARBLK POINTER ! 15755: MOV WB,(XS) STORE AS RESULT ! 15756: * ! 15757: * NOW WE NEED THE ARRAY PROTOTYPE WHICH IS OF THE FORM NN,2 ! 15758: * THIS IS OBTAINED BY BUILDING THE STRING FOR NN02 AND ! 15759: * CHANGING THE ZERO TO A COMMA BEFORE STORING IT. ! 15760: * ! 15761: LDI ARDIM(XR) GET NUMBER OF ELEMENTS (NN) ! 15762: MLI INTVH MULTIPLY BY 100 ! 15763: ADI INTV2 ADD 2 (NN02) ! 15764: JSR ICBLD BUILD INTEGER ! 15765: MOV XR,-(XS) STORE PTR FOR GTSTG ! 15766: JSR GTSTG CONVERT TO STRING ! 15767: PPM CONVERT FAIL IS IMPOSSIBLE ! 15768: MOV XR,XL COPY STRING POINTER ! 15769: MOV (XS)+,XR RELOAD ARBLK POINTER ! 15770: MOV XL,ARPR2(XR) STORE PROTOTYPE PTR (NN02) ! 15771: SUB =NUM02,WA ADJUST LENGTH TO POINT TO ZERO ! 15772: PSC XL,WA POINT TO ZERO ! 15773: MOV =CH$CM,WB LOAD A COMMA ! 15774: SCH WB,(XL) STORE A COMMA OVER THE ZERO ! 15775: CSC XL COMPLETE STORE CHARACTERS ! 15776: * ! 15777: * NORMAL RETURN ! 15778: * ! 15779: GTAR8 EXI RETURN TO CALLER ! 15780: * ! 15781: * NON-CONVERSION RETURN ! 15782: * ! 15783: GTAR9 MOV (XS)+,XR CLEAR UP STACK ! 15784: EXI 1 RETURN ! 15785: ENP PROCEDURE GTARR ! 15786: EJC ! 15787: * ! 15788: * GTCOD -- CONVERT TO CODE ! 15789: * ! 15790: * (XR) OBJECT TO BE CONVERTED ! 15791: * JSR GTCOD CALL TO CONVERT TO CODE ! 15792: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 15793: * (XR) POINTER TO RESULTING CDBLK ! 15794: * (XL,WA,WB,WC,RA) DESTROYED ! 15795: * ! 15796: * IF A SPITBOL ERROR OCCURS DURING COMPILATION OR PRE- ! 15797: * EVALUATION, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL ! 15798: * WITHOUT RETURNING TO THIS ROUTINE. ! 15799: * ! 15800: GTCOD PRC E,1 ENTRY POINT ! 15801: BEQ (XR),=B$CDS,GTCD1 JUMP IF ALREADY CODE ! 15802: BEQ (XR),=B$CDC,GTCD1 JUMP IF ALREADY CODE ! 15803: * ! 15804: * HERE WE MUST GENERATE A CDBLK BY COMPILATION ! 15805: * ! 15806: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG ! 15807: JSR GTSTG CONVERT ARGUMENT TO STRING ! 15808: PPM GTCD2 JUMP IF NON-CONVERTIBLE ! 15809: MOV FLPTR,GTCEF SAVE FAIL PTR IN CASE OF ERROR ! 15810: MOV R$COD,R$GTC ALSO SAVE CODE PTR ! 15811: MOV XR,R$CIM ELSE SET IMAGE POINTER ! 15812: MOV WA,SCNIL SET IMAGE LENGTH ! 15813: ZER SCNPT SET SCAN POINTER ! 15814: MOV =STGXC,STAGE SET STAGE FOR EXECUTE COMPILE ! 15815: MOV CMPSN,LSTSN IN CASE LISTR CALLED ! 15816: JSR CMPIL COMPILE STRING ! 15817: MOV =STGXT,STAGE RESET STAGE FOR EXECUTE TIME ! 15818: ZER R$CIM CLEAR IMAGE ! 15819: * ! 15820: * MERGE HERE IF NO CONVERT REQUIRED ! 15821: * ! 15822: GTCD1 EXI GIVE NORMAL GTCOD RETURN ! 15823: * ! 15824: * HERE IF UNCONVERTIBLE ! 15825: * ! 15826: GTCD2 EXI 1 GIVE ERROR RETURN ! 15827: ENP END PROCEDURE GTCOD ! 15828: EJC ! 15829: * ! 15830: * GTEXP -- CONVERT TO EXPRESSION ! 15831: * ! 15832: * (XR) INPUT VALUE TO BE CONVERTED ! 15833: * JSR GTEXP CALL TO CONVERT TO EXPRESSION ! 15834: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 15835: * (XR) POINTER TO RESULT EXBLK OR SEBLK ! 15836: * (XL,WA,WB,WC,RA) DESTROYED ! 15837: * ! 15838: * IF A SPITBOL ERROR OCCURS DURING COMPILATION OR PRE- ! 15839: * EVALUATION, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL ! 15840: * WITHOUT RETURNING TO THIS ROUTINE. ! 15841: * ! 15842: GTEXP PRC E,1 ENTRY POINT ! 15843: BLO (XR),=B$E$$,GTEX1 JUMP IF ALREADY AN EXPRESSION ! 15844: MOV XR,-(XS) STORE ARGUMENT FOR GTSTG ! 15845: JSR GTSTG CONVERT ARGUMENT TO STRING ! 15846: PPM GTEX2 JUMP IF UNCONVERTIBLE ! 15847: * ! 15848: * CHECK THE LAST CHAR OF STRING FOR COLON OR ! 15849: * SEMICOLON. THEY CAN LEGITIMATELY END AN EXPRESSION ! 15850: * IN OPEN CODE, SO EXPAN WILL NOT FAIL THEM BUT THEY ARE ! 15851: * INVALID AS TERMINATORS FOR A STRING WHICH IS TO BE ! 15852: * CONVERTED TO EXPRESSION FORM. ! 15853: * ! 15854: MOV XR,XL COPY ARGUMENT STRING ! 15855: PLC XL,WA POINT PAST STRING END ! 15856: LCH XL,-(XL) GET LAST CHAR ! 15857: BEQ XL,=CH$CL,GTEX2 FAIL IF COLON ! 15858: BEQ XL,=CH$SM,GTEX2 FAIL IF SEMICOLON ! 15859: * ! 15860: * HERE WE CONVERT A STRING BY COMPILATION ! 15861: * ! 15862: MOV XR,R$CIM SET INPUT IMAGE POINTER ! 15863: ZER SCNPT SET SCAN POINTER ! 15864: MOV WA,SCNIL SET INPUT IMAGE LENGTH ! 15865: ZER WB SET CODE FOR NORMAL SCAN ! 15866: MOV FLPTR,GTCEF SAVE FAIL PTR IN CASE OF ERROR ! 15867: MOV R$COD,R$GTC ALSO SAVE CODE PTR ! 15868: MOV =STGEV,STAGE ADJUST STAGE FOR COMPILE ! 15869: MOV =T$UOK,SCNTP INDICATE UNARY OPERATOR ACCEPTABLE ! 15870: JSR EXPAN BUILD TREE FOR EXPRESSION ! 15871: ZER SCNRS RESET RESCAN FLAG ! 15872: BNE SCNPT,SCNIL,GTEX2 ERROR IF NOT END OF IMAGE ! 15873: ZER WB SET OK VALUE FOR CDGEX CALL ! 15874: MOV XR,XL COPY TREE POINTER ! 15875: JSR CDGEX BUILD EXPRESSION BLOCK ! 15876: ZER R$CIM CLEAR POINTER ! 15877: MOV =STGXT,STAGE RESTORE STAGE FOR EXECUTE TIME ! 15878: * ! 15879: * MERGE HERE IF NO CONVERSION REQUIRED ! 15880: * ! 15881: GTEX1 EXI RETURN TO GTEXP CALLER ! 15882: * ! 15883: * HERE IF UNCONVERTIBLE ! 15884: * ! 15885: GTEX2 EXI 1 TAKE ERROR EXIT ! 15886: ENP END PROCEDURE GTEXP ! 15887: EJC ! 15888: * ! 15889: * GTINT -- GET INTEGER VALUE ! 15890: * ! 15891: * GTINT IS PASSED AN OBJECT AND RETURNS AN INTEGER AFTER ! 15892: * PERFORMING ANY NECESSARY CONVERSIONS. ! 15893: * ! 15894: * (XR) VALUE TO BE CONVERTED ! 15895: * JSR GTINT CALL TO CONVERT TO INTEGER ! 15896: * PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE ! 15897: * (XR) RESULTING INTEGER ! 15898: * (WC,RA) DESTROYED ! 15899: * (WA,WB) DESTROYED (ONLY ON CONVERSION ERR) ! 15900: * (XR) UNCHANGED (ON CONVERT ERROR) ! 15901: * ! 15902: GTINT PRC E,1 ENTRY POINT ! 15903: BEQ (XR),=B$ICL,GTIN2 JUMP IF ALREADY AN INTEGER ! 15904: MOV WA,GTINA ELSE SAVE WA ! 15905: MOV WB,GTINB SAVE WB ! 15906: JSR GTNUM CONVERT TO NUMERIC ! 15907: PPM GTIN3 JUMP IF UNCONVERTIBLE ! 15908: .IF .CNRA ! 15909: .ELSE ! 15910: BEQ WA,=B$ICL,GTIN1 JUMP IF INTEGER ! 15911: * ! 15912: * HERE WE CONVERT A REAL TO INTEGER ! 15913: * ! 15914: LDR RCVAL(XR) LOAD REAL VALUE ! 15915: RTI GTIN3 CONVERT TO INTEGER (ERR IF OVFLOW) ! 15916: JSR ICBLD IF OK BUILD ICBLK ! 15917: .FI ! 15918: * ! 15919: * HERE AFTER SUCCESSFUL CONVERSION TO INTEGER ! 15920: * ! 15921: GTIN1 MOV GTINA,WA RESTORE WA ! 15922: MOV GTINB,WB RESTORE WB ! 15923: * ! 15924: * COMMON EXIT POINT ! 15925: * ! 15926: GTIN2 EXI RETURN TO GTINT CALLER ! 15927: * ! 15928: * HERE ON CONVERSION ERROR ! 15929: * ! 15930: GTIN3 EXI 1 TAKE CONVERT ERROR EXIT ! 15931: ENP END PROCEDURE GTINT ! 15932: EJC ! 15933: * ! 15934: * GTNUM -- GET NUMERIC VALUE ! 15935: * ! 15936: * GTNUM IS GIVEN AN OBJECT AND RETURNS EITHER AN INTEGER ! 15937: * OR A REAL, PERFORMING ANY NECESSARY CONVERSIONS. ! 15938: * ! 15939: * (XR) OBJECT TO BE CONVERTED ! 15940: * JSR GTNUM CALL TO CONVERT TO NUMERIC ! 15941: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 15942: * (XR) POINTER TO RESULT (INT OR REAL) ! 15943: * (WA) FIRST WORD OF RESULT BLOCK ! 15944: * (WB,WC,RA) DESTROYED ! 15945: * (XR) UNCHANGED (ON CONVERT ERROR) ! 15946: * ! 15947: GTNUM PRC E,1 ENTRY POINT ! 15948: MOV (XR),WA LOAD FIRST WORD OF BLOCK ! 15949: BEQ WA,=B$ICL,GTN3A JUMP IF INTEGER (NO CONVERSION) ! 15950: .IF .CNRA ! 15951: .ELSE ! 15952: BEQ WA,=B$RCL,GTN3A JUMP IF REAL (NO CONVERSION) ! 15953: .FI ! 15954: * ! 15955: * AT THIS POINT THE ONLY POSSIBILITY IS TO CONVERT A STRING ! 15956: * TO AN INTEGER OR REAL AS APPROPRIATE. ! 15957: * ! 15958: STI GTNSV SAVE IA ! 15959: MOV XR,-(XS) STACK ARGUMENT IN CASE CONVERT ERR ! 15960: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG ! 15961: JSR GTSTG CONVERT ARGUMENT TO STRING ! 15962: PPM GTN36 JUMP IF UNCONVERTIBLE ! 15963: * ! 15964: * INITIALIZE NUMERIC CONVERSION ! 15965: * ! 15966: LDI INTV0 INITIALIZE INTEGER RESULT TO ZERO ! 15967: BZE WA,GTN32 JUMP TO EXIT WITH ZERO IF NULL ! 15968: LCT WA,WA SET BCT COUNTER FOR FOLLOWING LOOPS ! 15969: ZER GTNNF TENTATIVELY INDICATE RESULT + ! 15970: .IF .CNRA ! 15971: .ELSE ! 15972: STI GTNEX INITIALISE EXPONENT TO ZERO ! 15973: ZER GTNSC ZERO SCALE IN CASE REAL ! 15974: ZER GTNDF RESET FLAG FOR DEC POINT FOUND ! 15975: ZER GTNRD RESET FLAG FOR DIGITS FOUND ! 15976: LDR REAV0 ZERO REAL ACCUM IN CASE REAL ! 15977: .FI ! 15978: PLC XR POINT TO ARGUMENT CHARACTERS ! 15979: * ! 15980: * MERGE BACK HERE AFTER IGNORING LEADING BLANK ! 15981: * ! 15982: GTN01 LCH WB,(XR)+ LOAD FIRST CHARACTER ! 15983: BLT WB,=CH$D0,GTN02 JUMP IF NOT DIGIT ! 15984: BLE WB,=CH$D9,GTN06 JUMP IF FIRST CHAR IS A DIGIT ! 15985: EJC ! 15986: * ! 15987: * GTNUM (CONTINUED) ! 15988: * ! 15989: * HERE IF FIRST DIGIT IS NON-DIGIT ! 15990: * ! 15991: GTN02 BNE WB,=CH$BL,GTN03 JUMP IF NON-BLANK ! 15992: GTNA2 BCT WA,GTN01 ELSE DECR COUNT AND LOOP BACK ! 15993: BRN GTN07 JUMP TO RETURN ZERO IF ALL BLANKS ! 15994: * ! 15995: * HERE FOR FIRST CHARACTER NON-BLANK, NON-DIGIT ! 15996: * ! 15997: GTN03 BEQ WB,=CH$PL,GTN04 JUMP IF PLUS SIGN ! 15998: .IF .CAHT ! 15999: BEQ WB,=CH$HT,GTNA2 HORIZONTAL TAB EQUIV TO BLANK ! 16000: .FI ! 16001: .IF .CAVT ! 16002: BEQ WB,=CH$VT,GTNA2 VERTICAL TAB EQUIV TO BLANK ! 16003: .FI ! 16004: .IF .CNRA ! 16005: BNE WB,=CH$MN,GTN36 ELSE FAIL ! 16006: .ELSE ! 16007: BNE WB,=CH$MN,GTN12 JUMP IF NOT MINUS (MAY BE REAL) ! 16008: .FI ! 16009: MNZ GTNNF IF MINUS SIGN, SET NEGATIVE FLAG ! 16010: * ! 16011: * MERGE HERE AFTER PROCESSING SIGN ! 16012: * ! 16013: GTN04 BCT WA,GTN05 JUMP IF CHARS LEFT ! 16014: BRN GTN36 ELSE ERROR ! 16015: * ! 16016: * LOOP TO FETCH CHARACTERS OF AN INTEGER ! 16017: * ! 16018: GTN05 LCH WB,(XR)+ LOAD NEXT CHARACTER ! 16019: BLT WB,=CH$D0,GTN08 JUMP IF NOT A DIGIT ! 16020: BGT WB,=CH$D9,GTN08 JUMP IF NOT A DIGIT ! 16021: * ! 16022: * MERGE HERE FOR FIRST DIGIT ! 16023: * ! 16024: GTN06 STI GTNSI SAVE CURRENT VALUE ! 16025: .IF .CNRA ! 16026: CVM GTN36 CURRENT*10-(NEW DIG) JUMP IF OVFLOW ! 16027: .ELSE ! 16028: CVM GTN35 CURRENT*10-(NEW DIG) JUMP IF OVFLOW ! 16029: MNZ GTNRD SET DIGIT READ FLAG ! 16030: .FI ! 16031: BCT WA,GTN05 ELSE LOOP BACK IF MORE CHARS ! 16032: * ! 16033: * HERE TO EXIT WITH CONVERTED INTEGER VALUE ! 16034: * ! 16035: GTN07 BNZ GTNNF,GTN32 JUMP IF NEGATIVE (ALL SET) ! 16036: NGI ELSE NEGATE ! 16037: INO GTN32 JUMP IF NO OVERFLOW ! 16038: BRN GTN36 ELSE SIGNAL ERROR ! 16039: EJC ! 16040: * ! 16041: * GTNUM (CONTINUED) ! 16042: * ! 16043: * HERE FOR A NON-DIGIT CHARACTER WHILE ATTEMPTING TO ! 16044: * CONVERT AN INTEGER, CHECK FOR TRAILING BLANKS OR REAL. ! 16045: * ! 16046: GTN08 BEQ WB,=CH$BL,GTNA9 JUMP IF A BLANK ! 16047: .IF .CAHT ! 16048: BEQ WB,=CH$HT,GTNA9 JUMP IF HORIZONTAL TAB ! 16049: .FI ! 16050: .IF .CAVT ! 16051: BEQ WB,=CH$VT,GTNA9 JUMP IF VERTICAL TAB ! 16052: .FI ! 16053: .IF .CNRA ! 16054: BRN GTN36 ERROR ! 16055: .ELSE ! 16056: ITR ELSE CONVERT INTEGER TO REAL ! 16057: NGR NEGATE TO GET POSITIVE VALUE ! 16058: BRN GTN12 JUMP TO TRY FOR REAL ! 16059: .FI ! 16060: * ! 16061: * HERE WE SCAN OUT BLANKS TO END OF STRING ! 16062: * ! 16063: GTN09 LCH WB,(XR)+ GET NEXT CHAR ! 16064: .IF .CAHT ! 16065: BEQ WB,=CH$HT,GTNA9 JUMP IF HORIZONTAL TAB ! 16066: .FI ! 16067: .IF .CAVT ! 16068: BEQ WB,=CH$VT,GTNA9 JUMP IF VERTICAL TAB ! 16069: .FI ! 16070: BNE WB,=CH$BL,GTN36 ERROR IF NON-BLANK ! 16071: GTNA9 BCT WA,GTN09 LOOP BACK IF MORE CHARS TO CHECK ! 16072: BRN GTN07 RETURN INTEGER IF ALL BLANKS ! 16073: .IF .CNRA ! 16074: .ELSE ! 16075: * ! 16076: * LOOP TO COLLECT MANTISSA OF REAL ! 16077: * ! 16078: GTN10 LCH WB,(XR)+ LOAD NEXT CHARACTER ! 16079: BLT WB,=CH$D0,GTN12 JUMP IF NON-NUMERIC ! 16080: BGT WB,=CH$D9,GTN12 JUMP IF NON-NUMERIC ! 16081: * ! 16082: * MERGE HERE TO COLLECT FIRST REAL DIGIT ! 16083: * ! 16084: GTN11 SUB =CH$D0,WB CONVERT DIGIT TO NUMBER ! 16085: MLR REAVT MULTIPLY REAL BY 10.0 ! 16086: ROV GTN36 CONVERT ERROR IF OVERFLOW ! 16087: STR GTNSR SAVE RESULT ! 16088: MTI WB GET NEW DIGIT AS INTEGER ! 16089: ITR CONVERT NEW DIGIT TO REAL ! 16090: ADR GTNSR ADD TO GET NEW TOTAL ! 16091: ADD GTNDF,GTNSC INCREMENT SCALE IF AFTER DEC POINT ! 16092: MNZ GTNRD SET DIGIT FOUND FLAG ! 16093: BCT WA,GTN10 LOOP BACK IF MORE CHARS ! 16094: BRN GTN22 ELSE JUMP TO SCALE ! 16095: EJC ! 16096: * ! 16097: * GTNUM (CONTINUED) ! 16098: * ! 16099: * HERE IF NON-DIGIT FOUND WHILE COLLECTING A REAL ! 16100: * ! 16101: GTN12 BNE WB,=CH$DT,GTN13 JUMP IF NOT DEC POINT ! 16102: BNZ GTNDF,GTN36 IF DEC POINT, ERROR IF ONE ALREADY ! 16103: MOV =NUM01,GTNDF ELSE SET FLAG FOR DEC POINT ! 16104: BCT WA,GTN10 LOOP BACK IF MORE CHARS ! 16105: BRN GTN22 ELSE JUMP TO SCALE ! 16106: * ! 16107: * HERE IF NOT DECIMAL POINT ! 16108: * ! 16109: GTN13 BEQ WB,=CH$LE,GTN15 JUMP IF E FOR EXPONENT ! 16110: BEQ WB,=CH$LD,GTN15 JUMP IF D FOR EXPONENT ! 16111: .IF .CASL ! 16112: BEQ WB,=CH$$E,GTN15 JUMP FOR EXPT ! 16113: BEQ WB,=CH$$D,GTN15 JUMP FOR EXPT ! 16114: .FI ! 16115: * ! 16116: * HERE CHECK FOR TRAILING BLANKS ! 16117: * ! 16118: GTN14 BEQ WB,=CH$BL,GTNB4 JUMP IF BLANK ! 16119: .IF .CAHT ! 16120: BEQ WB,=CH$HT,GTNB4 JUMP IF HORIZONTAL TAB ! 16121: .FI ! 16122: .IF .CAVT ! 16123: BEQ WB,=CH$VT,GTNB4 JUMP IF VERTICAL TAB ! 16124: .FI ! 16125: BRN GTN36 ERROR IF NON-BLANK ! 16126: * ! 16127: GTNB4 LCH WB,(XR)+ GET NEXT CHARACTER ! 16128: BCT WA,GTN14 LOOP BACK TO CHECK IF MORE ! 16129: BRN GTN22 ELSE JUMP TO SCALE ! 16130: * ! 16131: * HERE TO READ AND PROCESS AN EXPONENT ! 16132: * ! 16133: GTN15 ZER GTNES SET EXPONENT SIGN POSITIVE ! 16134: LDI INTV0 INITIALIZE EXPONENT TO ZERO ! 16135: MNZ GTNDF RESET NO DEC POINT INDICATION ! 16136: BCT WA,GTN16 JUMP SKIPPING PAST E OR D ! 16137: BRN GTN36 ERROR IF NULL EXPONENT ! 16138: * ! 16139: * CHECK FOR EXPONENT SIGN ! 16140: * ! 16141: GTN16 LCH WB,(XR)+ LOAD FIRST EXPONENT CHARACTER ! 16142: BEQ WB,=CH$PL,GTN17 JUMP IF PLUS SIGN ! 16143: BNE WB,=CH$MN,GTN19 ELSE JUMP IF NOT MINUS SIGN ! 16144: MNZ GTNES SET SIGN NEGATIVE IF MINUS SIGN ! 16145: * ! 16146: * MERGE HERE AFTER PROCESSING EXPONENT SIGN ! 16147: * ! 16148: GTN17 BCT WA,GTN18 JUMP IF CHARS LEFT ! 16149: BRN GTN36 ELSE ERROR ! 16150: * ! 16151: * LOOP TO CONVERT EXPONENT DIGITS ! 16152: * ! 16153: GTN18 LCH WB,(XR)+ LOAD NEXT CHARACTER ! 16154: EJC ! 16155: * ! 16156: * GTNUM (CONTINUED) ! 16157: * ! 16158: * MERGE HERE FOR FIRST EXPONENT DIGIT ! 16159: * ! 16160: GTN19 BLT WB,=CH$D0,GTN20 JUMP IF NOT DIGIT ! 16161: BGT WB,=CH$D9,GTN20 JUMP IF NOT DIGIT ! 16162: CVM GTN36 ELSE CURRENT*10, SUBTRACT NEW DIGIT ! 16163: BCT WA,GTN18 LOOP BACK IF MORE CHARS ! 16164: BRN GTN21 JUMP IF EXPONENT FIELD IS EXHAUSTED ! 16165: * ! 16166: * HERE TO CHECK FOR TRAILING BLANKS AFTER EXPONENT ! 16167: * ! 16168: GTN20 BEQ WB,=CH$BL,GTNC0 JUMP IF BLANK ! 16169: .IF .CAHT ! 16170: BEQ WB,=CH$HT,GTNC0 JUMP IF HORIZONTAL TAB ! 16171: .FI ! 16172: .IF .CAVT ! 16173: BEQ WC,=CH$VT,GTNC0 JUMP IF VERTICAL TAB ! 16174: .FI ! 16175: BRN GTN36 ERROR IF NON-BLANK ! 16176: * ! 16177: GTNC0 LCH WB,(XR)+ GET NEXT CHARACTER ! 16178: BCT WA,GTN20 LOOP BACK TILL ALL BLANKS SCANNED ! 16179: * ! 16180: * MERGE HERE AFTER COLLECTING EXPONENT ! 16181: * ! 16182: GTN21 STI GTNEX SAVE COLLECTED EXPONENT ! 16183: BNZ GTNES,GTN22 JUMP IF IT WAS NEGATIVE ! 16184: NGI ELSE COMPLEMENT ! 16185: IOV GTN36 ERROR IF OVERFLOW ! 16186: STI GTNEX AND STORE POSITIVE EXPONENT ! 16187: * ! 16188: * MERGE HERE WITH EXPONENT (0 IF NONE GIVEN) ! 16189: * ! 16190: GTN22 BZE GTNRD,GTN36 ERROR IF NOT DIGITS COLLECTED ! 16191: BZE GTNDF,GTN36 ERROR IF NO EXPONENT OR DEC POINT ! 16192: MTI GTNSC ELSE LOAD SCALE AS INTEGER ! 16193: SBI GTNEX SUBTRACT EXPONENT ! 16194: IOV GTN36 ERROR IF OVERFLOW ! 16195: ILT GTN26 JUMP IF WE MUST SCALE UP ! 16196: * ! 16197: * HERE WE HAVE A NEGATIVE EXPONENT, SO SCALE DOWN ! 16198: * ! 16199: MFI WA,GTN36 LOAD SCALE FACTOR, ERR IF OVFLOW ! 16200: * ! 16201: * LOOP TO SCALE DOWN IN STEPS OF 10**10 ! 16202: * ! 16203: GTN23 BLE WA,=NUM10,GTN24 JUMP IF 10 OR LESS TO GO ! 16204: DVR REATT ELSE DIVIDE BY 10**10 ! 16205: SUB =NUM10,WA DECREMENT SCALE ! 16206: BRN GTN23 AND LOOP BACK ! 16207: EJC ! 16208: * ! 16209: * GTNUM (CONTINUED) ! 16210: * ! 16211: * HERE SCALE REST OF WAY FROM POWERS OF TEN TABLE ! 16212: * ! 16213: GTN24 BZE WA,GTN30 JUMP IF SCALED ! 16214: LCT WB,=CFP$R ELSE GET INDEXING FACTOR ! 16215: MOV =REAV1,XR POINT TO POWERS OF TEN TABLE ! 16216: WTB WA CONVERT REMAINING SCALE TO BAU OFS ! 16217: * ! 16218: * LOOP TO POINT TO POWERS OF TEN TABLE ENTRY ! 16219: * ! 16220: GTN25 ADD WA,XR BUMP POINTER ! 16221: BCT WB,GTN25 ONCE FOR EACH VALUE WORD ! 16222: DVR (XR) SCALE DOWN AS REQUIRED ! 16223: BRN GTN30 AND JUMP ! 16224: * ! 16225: * COME HERE TO SCALE RESULT UP (POSITIVE EXPONENT) ! 16226: * ! 16227: GTN26 NGI GET ABSOLUTE VALUE OF EXPONENT ! 16228: IOV GTN36 ERROR IF OVERFLOW ! 16229: MFI WA,GTN36 ACQUIRE SCALE, ERROR IF OVFLOW ! 16230: * ! 16231: * LOOP TO SCALE UP IN STEPS OF 10**10 ! 16232: * ! 16233: GTN27 BLE WA,=NUM10,GTN28 JUMP IF 10 OR LESS TO GO ! 16234: MLR REATT ELSE MULTIPLY BY 10**10 ! 16235: ROV GTN36 ERROR IF OVERFLOW ! 16236: SUB =NUM10,WA ELSE DECREMENT SCALE ! 16237: BRN GTN27 AND LOOP BACK ! 16238: * ! 16239: * HERE TO SCALE UP REST OF WAY WITH TABLE ! 16240: * ! 16241: GTN28 BZE WA,GTN30 JUMP IF SCALED ! 16242: LCT WB,=CFP$R ELSE GET INDEXING FACTOR ! 16243: MOV =REAV1,XR POINT TO POWERS OF TEN TABLE ! 16244: WTB WA CONVERT REMAINING SCALE TO BAU OFS ! 16245: * ! 16246: * LOOP TO POINT TO PROPER ENTRY IN POWERS OF TEN TABLE ! 16247: * ! 16248: GTN29 ADD WA,XR BUMP POINTER ! 16249: BCT WB,GTN29 ONCE FOR EACH WORD IN VALUE ! 16250: MLR (XR) SCALE UP ! 16251: ROV GTN36 ERROR IF OVERFLOW ! 16252: EJC ! 16253: * ! 16254: * GTNUM (CONTINUED) ! 16255: * ! 16256: * HERE WITH REAL VALUE SCALED AND READY EXCEPT FOR SIGN ! 16257: * ! 16258: GTN30 BZE GTNNF,GTN31 JUMP IF POSITIVE ! 16259: NGR ELSE NEGATE ! 16260: * ! 16261: * HERE WITH PROPERLY SIGNED REAL VALUE IN (RA) ! 16262: * ! 16263: GTN31 JSR RCBLD BUILD REAL BLOCK ! 16264: BRN GTN33 MERGE TO EXIT ! 16265: .FI ! 16266: * ! 16267: * HERE WITH PROPERLY SIGNED INTEGER VALUE IN (IA) ! 16268: * ! 16269: GTN32 JSR ICBLD BUILD ICBLK ! 16270: * ! 16271: * REAL MERGES HERE ! 16272: * ! 16273: GTN33 MOV (XR),WA LOAD FIRST WORD OF RESULT BLOCK ! 16274: ICA XS POP ARGUMENT OFF STACK ! 16275: * ! 16276: * COMMON EXIT POINT ! 16277: * ! 16278: GTN34 LDI GTNSV RECOVER IA ! 16279: GTN3A EXI RETURN TO GTNUM CALLER ! 16280: .IF .CNRA ! 16281: .ELSE ! 16282: * ! 16283: * COME HERE IF OVERFLOW OCCURS DURING COLLECTION OF INTEGER ! 16284: * ! 16285: GTN35 LDI GTNSI RELOAD INTEGER SO FAR ! 16286: ITR CONVERT TO REAL ! 16287: NGR MAKE VALUE POSITIVE ! 16288: BRN GTN11 MERGE WITH REAL CIRCUIT ! 16289: .FI ! 16290: * ! 16291: * HERE FOR UNCONVERTIBLE TO STRING OR CONVERSION ERROR ! 16292: * ! 16293: GTN36 MOV (XS)+,XR RELOAD ORIGINAL ARGUMENT ! 16294: LDI GTNSV RECOVER IA ! 16295: EXI 1 TAKE CONVERT-ERROR EXIT ! 16296: ENP END PROCEDURE GTNUM ! 16297: EJC ! 16298: * ! 16299: * GTNVR -- CONVERT TO NATURAL VARIABLE ! 16300: * ! 16301: * GTNVR LOCATES A VARIABLE BLOCK (VRBLK) GIVEN EITHER AN ! 16302: * APPROPRIATE NAME (NMBLK) OR A NON-NULL STRING (SCBLK). ! 16303: * ! 16304: * (XR) ARGUMENT ! 16305: * JSR GTNVR CALL TO CONVERT TO NATURAL VARIABLE ! 16306: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 16307: * (XR) POINTER TO VRBLK ! 16308: * (WC) DESTROYED ! 16309: * ! 16310: GTNVR PRC E,1 ENTRY POINT ! 16311: BNE (XR),=B$NML,GNV02 JUMP IF NOT NAME ! 16312: MOV NMBAS(XR),XR ELSE LOAD NAME BASE IF NAME ! 16313: BLO XR,STATE,GNV07 SKIP IF VRBLK (IN STATIC REGION) ! 16314: BRN GNV01 FAIL ! 16315: * ! 16316: * RESTORE REGS AND FAIL ! 16317: * ! 16318: GNV00 MOV GNVSA,WA RESTORE REGS ! 16319: MOV GNVSB,WB ! 16320: * ! 16321: * COMMON ERROR EXIT ! 16322: * ! 16323: GNV01 EXI 1 TAKE CONVERT-ERROR EXIT ! 16324: * ! 16325: * HERE IF NOT NAME ! 16326: * ! 16327: GNV02 MOV WA,GNVSA SAVE WA ! 16328: MOV WB,GNVSB SAVE WB ! 16329: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG ! 16330: JSR GTSTG CONVERT ARGUMENT TO STRING ! 16331: PPM GNV00 JUMP IF CONVERSION ERROR ! 16332: BZE WA,GNV00 NULL STRING IS AN ERROR ! 16333: MOV XL,-(XS) SAVE XL ! 16334: .IF .CASL ! 16335: MOV XR,XL COPY STRING POINTER ! 16336: ZER WB ZERO OFFSET ! 16337: JSR SBSTG CONVERT TO PREFERRED CASE ! 16338: MOV SCLEN(XR),WA RECOVER STRING LENGTH ! 16339: .FI ! 16340: MOV XR,-(XS) STACK STRING PTR FOR LATER ! 16341: MOV XR,WB COPY STRING POINTER ! 16342: ADD *SCHAR,WB POINT TO CHARACTERS OF STRING ! 16343: MOV WB,GNVST SAVE POINTER TO CHARACTERS ! 16344: MOV WA,WB COPY LENGTH ! 16345: CTW WB,0 GET NUMBER OF WORDS IN NAME ! 16346: MOV WB,GNVNW SAVE FOR LATER ! 16347: JSR HASHS COMPUTE HASH INDEX FOR STRING ! 16348: RMI HSHNB COMPUTE HASH OFFSET BY TAKING MOD ! 16349: MFI WC GET AS OFFSET ! 16350: WTB WC CONVERT OFFSET TO BAUS ! 16351: ADD HSHTB,WC POINT TO PROPER HASH CHAIN ! 16352: SUB *VRNXT,WC SUBTRACT OFFSET TO MERGE INTO LOOP ! 16353: EJC ! 16354: * ! 16355: * GTNVR (CONTINUED) ! 16356: * ! 16357: * LOOP TO SEARCH HASH CHAIN ! 16358: * ! 16359: GNV03 MOV WC,XL COPY HASH CHAIN POINTER ! 16360: MOV VRNXT(XL),XL POINT TO NEXT VRBLK ON CHAIN ! 16361: BZE XL,GNV08 JUMP IF END OF CHAIN ! 16362: MOV XL,WC SAVE POINTER TO THIS VRBLK ! 16363: BNZ VRLEN(XL),GNV04 JUMP IF NOT SYSTEM VARIABLE ! 16364: MOV VRSVP(XL),XL ELSE POINT TO SVBLK ! 16365: SUB *VRSOF,XL ADJUST OFFSET FOR MERGE ! 16366: * ! 16367: * MERGE HERE WITH STRING PTR (LIKE VRBLK) IN XL ! 16368: * ! 16369: GNV04 BNE WA,VRLEN(XL),GNV03 BACK FOR NEXT VRBLK IF LENGTHS NE ! 16370: ADD *VRCHS,XL ELSE POINT TO CHARS OF CHAIN ENTRY ! 16371: LCT WB,GNVNW GET WORD COUNTER TO CONTROL LOOP ! 16372: MOV GNVST,XR POINT TO CHARS OF NEW NAME ! 16373: * ! 16374: * LOOP TO COMPARE CHARACTERS OF THE TWO NAMES ! 16375: * ! 16376: GNV05 CNE (XR),(XL),GNV03 JUMP IF NO MATCH FOR NEXT VRBLK ! 16377: ICA XR BUMP NEW NAME POINTER ! 16378: ICA XL BUMP VRBLK IN CHAIN NAME POINTER ! 16379: BCT WB,GNV05 ELSE LOOP TILL ALL COMPARED ! 16380: MOV WC,XR WE HAVE FOUND A MATCH, GET VRBLK ! 16381: * ! 16382: * EXIT POINT AFTER FINDING VRBLK OR BUILDING NEW ONE ! 16383: * ! 16384: GNV06 MOV GNVSA,WA RESTORE WA ! 16385: MOV GNVSB,WB RESTORE WB ! 16386: ICA XS POP STRING POINTER ! 16387: MOV (XS)+,XL RESTORE XL ! 16388: * ! 16389: * COMMON EXIT POINT ! 16390: * ! 16391: GNV07 EXI RETURN TO GTNVR CALLER ! 16392: * ! 16393: * NOT FOUND, PREPARE TO SEARCH SYSTEM VARIABLE TABLE ! 16394: * ! 16395: GNV08 ZER XR CLEAR GARBAGE XR POINTER ! 16396: MOV WC,GNVHE SAVE PTR TO END OF HASH CHAIN ! 16397: BGT WA,=NUM09,GNV14 CANNOT BE SYSTEM VAR IF LENGTH GT 9 ! 16398: MOV WA,XL ELSE COPY LENGTH ! 16399: WTB XL CONVERT TO BAU OFFSET ! 16400: MOV VSRCH(XL),XL POINT TO FIRST SVBLK OF THIS LENGTH ! 16401: EJC ! 16402: * ! 16403: * GTNVR (CONTINUED) ! 16404: * ! 16405: * LOOP TO SEARCH ENTRIES IN STANDARD VARIABLE TABLE ! 16406: * ! 16407: GNV09 MOV XL,GNVSP SAVE TABLE POINTER ! 16408: MOV (XL)+,WC LOAD SVBIT BIT STRING ! 16409: MOV (XL)+,WB LOAD LENGTH FROM TABLE ENTRY ! 16410: BNE WA,WB,GNV14 JUMP IF END OF RIGHT LENGTH ENTIRES ! 16411: LCT WB,GNVNW GET WORD COUNTER TO CONTROL LOOP ! 16412: MOV GNVST,XR POINT TO CHARS OF NEW NAME ! 16413: * ! 16414: * LOOP TO CHECK FOR MATCHING NAMES ! 16415: * ! 16416: GNV10 CNE (XR),(XL),GNV11 JUMP IF NAME MISMATCH ! 16417: ICA XR ELSE BUMP NEW NAME POINTER ! 16418: ICA XL BUMP SVBLK POINTER ! 16419: BCT WB,GNV10 ELSE LOOP UNTIL ALL CHECKED ! 16420: * ! 16421: * HERE WE HAVE A MATCH IN THE STANDARD VARIABLE TABLE ! 16422: * ! 16423: ZER WC SET VRLEN VALUE ZERO ! 16424: MOV *VRSI$,WA SET STANDARD SIZE ! 16425: BRN GNV15 JUMP TO BUILD VRBLK ! 16426: * ! 16427: * HERE IF NO MATCH WITH TABLE ENTRY IN SVBLKS TABLE ! 16428: * ! 16429: GNV11 ICA XL BUMP PAST WORD OF CHARS ! 16430: BCT WB,GNV11 LOOP BACK IF MORE TO GO ! 16431: RSH WC,SVNBT REMOVE UNINTERESTING BITS ! 16432: * ! 16433: * LOOP TO BUMP TABLE PTR FOR EACH FLAGGED WORD ! 16434: * ! 16435: GNV12 MOV BITS1,WB LOAD BIT TO TEST ! 16436: ANB WC,WB TEST FOR WORD PRESENT ! 16437: ZRB WB,GNV13 JUMP IF NOT PRESENT ! 16438: ICA XL ELSE BUMP TABLE POINTER ! 16439: * ! 16440: * HERE AFTER DEALING WITH ONE WORD (ONE BIT) ! 16441: * ! 16442: GNV13 RSH WC,1 REMOVE BIT ALREADY PROCESSED ! 16443: NZB WC,GNV12 LOOP BACK IF MORE BITS TO TEST ! 16444: BRN GNV09 ELSE LOOP BACK FOR NEXT SVBLK ! 16445: * ! 16446: * HERE IF NOT SYSTEM VARIABLE ! 16447: * ! 16448: GNV14 MOV WA,WC COPY VRLEN VALUE ! 16449: MOV =VRCHS,WA LOAD STANDARD SIZE -CHARS ! 16450: ADD GNVNW,WA ADJUST FOR CHARS OF NAME ! 16451: WTB WA CONVERT LENGTH TO BAUS ! 16452: EJC ! 16453: * ! 16454: * GTNVR (CONTINUED) ! 16455: * ! 16456: * MERGE HERE TO BUILD VRBLK ! 16457: * ! 16458: GNV15 JSR ALOST ALLOCATE SPACE FOR VRBLK (STATIC) ! 16459: MOV XR,WB SAVE VRBLK POINTER ! 16460: MOV =STNVR,XL POINT TO MODEL VARIABLE BLOCK ! 16461: MOV *VRLEN,WA SET LENGTH OF STANDARD FIELDS ! 16462: MVW SET INITIAL FIELDS OF NEW BLOCK ! 16463: MOV GNVHE,XL LOAD POINTER TO END OF HASH CHAIN ! 16464: MOV WB,VRNXT(XL) ADD NEW BLOCK TO END OF CHAIN ! 16465: MOV WC,(XR)+ SET VRLEN FIELD, BUMP PTR ! 16466: MOV GNVNW,WA GET LENGTH IN WORDS ! 16467: WTB WA CONVERT TO LENGTH IN BAUS ! 16468: BZE WC,GNV16 JUMP IF SYSTEM VARIABLE ! 16469: * ! 16470: * HERE FOR NON-SYSTEM VARIABLE -- SET CHARS OF NAME ! 16471: * ! 16472: MOV (XS),XL POINT BACK TO STRING NAME ! 16473: ADD *SCHAR,XL POINT TO CHARS OF NAME ! 16474: MVW MOVE CHARACTERS INTO PLACE ! 16475: MOV WB,XR RESTORE VRBLK POINTER ! 16476: BRN GNV06 JUMP BACK TO EXIT ! 16477: * ! 16478: * HERE FOR SYSTEM VARIABLE CASE TO FILL IN FIELDS WHERE ! 16479: * NECESSARY FROM THE FIELDS PRESENT IN THE SVBLK. ! 16480: * ! 16481: GNV16 MOV GNVSP,XL LOAD POINTER TO SVBLK ! 16482: MOV XL,(XR) SET SVBLK PTR IN VRBLK ! 16483: MOV WB,XR RESTORE VRBLK POINTER ! 16484: MOV SVBIT(XL),WB LOAD BIT INDICATORS ! 16485: ADD *SVCHS,XL POINT TO CHARACTERS OF NAME ! 16486: ADD WA,XL POINT PAST CHARACTERS ! 16487: * ! 16488: * SKIP PAST KEYWORD NUMBER (SVKNM) IF PRESENT ! 16489: * ! 16490: MOV BTKNM,WC LOAD TEST BIT ! 16491: ANB WB,WC AND TO TEST ! 16492: ZRB WC,GNV17 JUMP IF NO KEYWORD NUMBER ! 16493: ICA XL ELSE BUMP POINTER ! 16494: EJC ! 16495: * ! 16496: * GTNVR (CONTINUED) ! 16497: * ! 16498: * HERE TEST FOR FUNCTION (SVFNC AND SVNAR) ! 16499: * ! 16500: GNV17 MOV BTFNC,WC GET TEST BIT ! 16501: ANB WB,WC AND TO TEST ! 16502: ZRB WC,GNV18 SKIP IF NO SYSTEM FUNCTION ! 16503: MOV XL,VRFNC(XR) ELSE POINT VRFNC TO SVFNC FIELD ! 16504: ADD *NUM02,XL AND BUMP PAST SVFNC, SVNAR FIELDS ! 16505: * ! 16506: * NOW TEST FOR LABEL (SVLBL) ! 16507: * ! 16508: GNV18 MOV BTLBL,WC GET TEST BIT ! 16509: ANB WB,WC AND TO TEST ! 16510: ZRB WC,GNV19 JUMP IF BIT IS OFF (NO SYSTEM LABL) ! 16511: MOV XL,VRLBL(XR) ELSE POINT VRLBL TO SVLBL FIELD ! 16512: ICA XL BUMP PAST SVLBL FIELD ! 16513: * ! 16514: * NOW TEST FOR VALUE (SVVAL) ! 16515: * ! 16516: GNV19 MOV BTVAL,WC LOAD TEST BIT ! 16517: ANB WB,WC AND TO TEST ! 16518: ZRB WC,GNV06 ALL DONE IF NO VALUE ! 16519: MOV (XL),VRVAL(XR) ELSE SET INITIAL VALUE ! 16520: MOV =B$VRE,VRSTO(XR) SET ERROR STORE ACCESS ! 16521: BRN GNV06 MERGE BACK TO EXIT TO CALLER ! 16522: ENP END PROCEDURE GTNVR ! 16523: EJC ! 16524: * ! 16525: * GTPAT -- GET PATTERN ! 16526: * ! 16527: * GTPAT IS PASSED AN OBJECT IN (XR) AND RETURNS A ! 16528: * PATTERN AFTER PERFORMING ANY NECESSARY CONVERSIONS ! 16529: * ! 16530: * (XR) INPUT ARGUMENT ! 16531: * JSR GTPAT CALL TO CONVERT TO PATTERN ! 16532: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 16533: * (XR) RESULTING PATTERN ! 16534: * (WA) DESTROYED ! 16535: * (WB) DESTROYED (ONLY ON CONVERT ERROR) ! 16536: * (XR) UNCHANGED (ONLY ON CONVERT ERROR) ! 16537: * ! 16538: GTPAT PRC E,1 ENTRY POINT ! 16539: BHI (XR),=P$AAA,GTPT5 JUMP IF PATTERN ALREADY ! 16540: * ! 16541: * HERE IF NOT PATTERN, TRY FOR STRING ! 16542: * ! 16543: MOV WB,GTPSB SAVE WB ! 16544: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG ! 16545: JSR GTSTG CONVERT ARGUMENT TO STRING ! 16546: PPM GTPT2 JUMP IF IMPOSSIBLE ! 16547: * ! 16548: * HERE WE HAVE A STRING ! 16549: * ! 16550: BNZ WA,GTPT1 JUMP IF NON-NULL ! 16551: * ! 16552: * HERE FOR NULL STRING. GENERATE POINTER TO NULL PATTERN. ! 16553: * ! 16554: MOV =NDNTH,XR POINT TO NOTHEN NODE ! 16555: BRN GTPT4 JUMP TO EXIT ! 16556: EJC ! 16557: * ! 16558: * GTPAT (CONTINUED) ! 16559: * ! 16560: * HERE FOR NON-NULL STRING ! 16561: * ! 16562: GTPT1 MOV =P$STR,WB LOAD PCODE FOR MULTI-CHAR STRING ! 16563: BNE WA,=NUM01,GTPT3 JUMP IF MULTI-CHAR STRING ! 16564: * ! 16565: * HERE FOR ONE CHARACTER STRING, SHARE ONE CHARACTER ANY ! 16566: * ! 16567: PLC XR POINT TO CHARACTER ! 16568: LCH WA,(XR) LOAD CHARACTER ! 16569: MOV WA,XR SET AS PARM1 ! 16570: MOV =P$ANS,WB POINT TO PCODE FOR 1-CHAR ANY ! 16571: BRN GTPT3 JUMP TO BUILD NODE ! 16572: * ! 16573: * HERE IF ARGUMENT IS NOT CONVERTIBLE TO STRING ! 16574: * ! 16575: GTPT2 MOV =P$EXA,WB SET PCODE FOR EXPRESSION IN CASE ! 16576: BLO (XR),=B$E$$,GTPT3 JUMP TO BUILD NODE IF EXPRESSION ! 16577: * ! 16578: * HERE WE HAVE AN ERROR (CONVERSION IMPOSSIBLE) ! 16579: * ! 16580: EXI 1 TAKE CONVERT ERROR EXIT ! 16581: * ! 16582: * MERGE HERE TO BUILD NODE FOR STRING OR EXPRESSION ! 16583: * ! 16584: GTPT3 JSR PBILD CALL ROUTINE TO BUILD PATTERN NODE ! 16585: * ! 16586: * COMMON EXIT AFTER SUCCESSFUL CONVERSION ! 16587: * ! 16588: GTPT4 MOV GTPSB,WB RESTORE WB ! 16589: * ! 16590: * MERGE HERE TO EXIT IF NO CONVERSION REQUIRED ! 16591: * ! 16592: GTPT5 EXI RETURN TO GTPAT CALLER ! 16593: ENP END PROCEDURE GTPAT ! 16594: .IF .CNRA ! 16595: .ELSE ! 16596: EJC ! 16597: * ! 16598: * GTREA -- GET REAL VALUE ! 16599: * ! 16600: * GTREA IS PASSED AN OBJECT AND RETURNS A REAL VALUE ! 16601: * PERFORMING ANY NECESSARY CONVERSIONS. ! 16602: * ! 16603: * (XR) OBJECT TO BE CONVERTED ! 16604: * JSR GTREA CALL TO CONVERT OBJECT TO REAL ! 16605: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 16606: * (XR) POINTER TO RESULTING REAL ! 16607: * (WA,WB,WC,RA) DESTROYED ! 16608: * (XR) UNCHANGED (CONVERT ERROR ONLY) ! 16609: * ! 16610: GTREA PRC E,1 ENTRY POINT ! 16611: MOV (XR),WA GET FIRST WORD OF BLOCK ! 16612: BEQ WA,=B$RCL,GTRE2 JUMP IF REAL ! 16613: JSR GTNUM ELSE CONVERT ARGUMENT TO NUMERIC ! 16614: PPM GTRE3 JUMP IF UNCONVERTIBLE ! 16615: BEQ WA,=B$RCL,GTRE2 JUMP IF REAL WAS RETURNED ! 16616: * ! 16617: * HERE FOR CASE OF AN INTEGER TO CONVERT TO REAL ! 16618: * ! 16619: GTRE1 LDI ICVAL(XR) LOAD INTEGER ! 16620: ITR CONVERT TO REAL ! 16621: JSR RCBLD BUILD RCBLK ! 16622: * ! 16623: * EXIT WITH REAL ! 16624: * ! 16625: GTRE2 EXI RETURN TO GTREA CALLER ! 16626: * ! 16627: * HERE ON CONVERSION ERROR ! 16628: * ! 16629: GTRE3 EXI 1 TAKE CONVERT ERROR EXIT ! 16630: ENP END PROCEDURE GTREA ! 16631: .FI ! 16632: EJC ! 16633: * ! 16634: * GTSMI -- GET SMALL INTEGER ! 16635: * ! 16636: * GTSMI IS PASSED A SNOBOL OBJECT AND RETURNS AN ADDRESS ! 16637: * INTEGER IN THE RANGE (0 LE N LE DNAMB). SUCH A VALUE CAN ! 16638: * ONLY BE DERIVED FROM AN INTEGER IN THE APPROPRIATE RANGE. ! 16639: * SMALL INTEGERS NEVER APPEAR AS SNOBOL VALUES. HOWEVER, ! 16640: * THEY ARE USED INTERNALLY FOR A VARIETY OF PURPOSES. ! 16641: * ! 16642: * -(XS) ARGUMENT TO CONVERT (ON STACK) ! 16643: * JSR GTSMI CALL TO CONVERT TO SMALL INTEGER ! 16644: * PPM LOC TRANSFER LOC FOR NOT INTEGER ! 16645: * PPM LOC TRANSFER LOC FOR LT 0, GT DNAMB ! 16646: * (XR,WC) RESULTING SMALL INT (TWO COPIES) ! 16647: * (XS) POPPED ! 16648: * (RA) DESTROYED ! 16649: * (WA,WB) DESTROYED (ON CONVERT ERROR ONLY) ! 16650: * (XR) INPUT ARG (CONVERT ERROR ONLY) ! 16651: * ! 16652: GTSMI PRC N,2 ENTRY POINT ! 16653: MOV (XS)+,XR LOAD ARGUMENT ! 16654: BEQ (XR),=B$ICL,GTSM1 SKIP IF ALREADY AN INTEGER ! 16655: * ! 16656: * HERE IF NOT AN INTEGER ! 16657: * ! 16658: JSR GTINT CONVERT ARGUMENT TO INTEGER ! 16659: PPM GTSM2 JUMP IF CONVERT IS IMPOSSIBLE ! 16660: * ! 16661: * MERGE HERE WITH INTEGER ! 16662: * ! 16663: GTSM1 LDI ICVAL(XR) LOAD INTEGER VALUE ! 16664: MFI WC,GTSM3 MOVE AS ONE WORD, JUMP IF OVFLOW ! 16665: BGT WC,MXLEN,GTSM3 OR IF TOO LARGE ! 16666: MOV WC,XR COPY RESULT TO XR ! 16667: EXI RETURN TO GTSMI CALLER ! 16668: * ! 16669: * HERE IF UNCONVERTIBLE TO INTEGER ! 16670: * ! 16671: GTSM2 EXI 1 TAKE NON-INTEGER ERROR EXIT ! 16672: * ! 16673: * HERE IF OUT OF RANGE ! 16674: * ! 16675: GTSM3 EXI 2 TAKE OUT-OF-RANGE ERROR EXIT ! 16676: ENP END PROCEDURE GTSMI ! 16677: EJC ! 16678: * ! 16679: * GTSTG -- GET STRING ! 16680: * ! 16681: * GTSTG IS PASSED AN OBJECT AND RETURNS A STRING WITH ! 16682: * ANY NECESSARY CONVERSIONS PERFORMED. ! 16683: * ! 16684: * -(XS) INPUT ARGUMENT (ON STACK) ! 16685: * JSR GTSTG CALL TO CONVERT TO STRING ! 16686: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 16687: * (XR) POINTER TO RESULTING STRING ! 16688: * (WA) LENGTH OF STRING IN CHARACTERS ! 16689: * (XS) POPPED ! 16690: * (RA) DESTROYED ! 16691: * (XR) INPUT ARG (CONVERT ERROR ONLY) ! 16692: * ! 16693: GTSTG PRC N,1 ENTRY POINT ! 16694: MOV (XS)+,XR LOAD ARGUMENT, POP STACK ! 16695: BEQ (XR),=B$SCL,GTS30 JUMP IF ALREADY A STRING ! 16696: * ! 16697: * HERE IF NOT A STRING ALREADY ! 16698: * ! 16699: GTS01 MOV XR,-(XS) RESTACK ARGUMENT IN CASE ERROR ! 16700: MOV XL,-(XS) SAVE XL ! 16701: MOV WB,GTSVB SAVE WB ! 16702: MOV WC,GTSVC SAVE WC ! 16703: MOV (XR),WA LOAD FIRST WORD OF BLOCK ! 16704: BEQ WA,=B$ICL,GTS05 JUMP TO CONVERT INTEGER ! 16705: .IF .CNRA ! 16706: .ELSE ! 16707: BEQ WA,=B$RCL,GTS10 JUMP TO CONVERT REAL ! 16708: .FI ! 16709: BEQ WA,=B$NML,GTS03 JUMP TO CONVERT NAME ! 16710: .IF .CNBF ! 16711: .ELSE ! 16712: BEQ WA,=B$BCT,GTS32 JUMP TO CONVERT BUFFER ! 16713: .FI ! 16714: * ! 16715: * HERE ON CONVERSION ERROR ! 16716: * ! 16717: GTS02 MOV (XS)+,XL RESTORE XL ! 16718: MOV (XS)+,XR RELOAD INPUT ARGUMENT ! 16719: EXI 1 TAKE CONVERT ERROR EXIT ! 16720: EJC ! 16721: * ! 16722: * GTSTG (CONTINUED) ! 16723: * ! 16724: * HERE TO CONVERT A NAME (ONLY POSSIBLE IF NATURAL VAR) ! 16725: * ! 16726: GTS03 MOV NMBAS(XR),XL LOAD NAME BASE ! 16727: BHI XL,STATE,GTS02 ERROR IF NOT NATURAL VAR (STATIC) ! 16728: ADD *VRSOF,XL ELSE POINT TO POSSIBLE STRING NAME ! 16729: MOV SCLEN(XL),WA LOAD LENGTH ! 16730: BNZ WA,GTS04 JUMP IF NOT SYSTEM VARIABLE ! 16731: MOV VRSVO(XL),XL ELSE POINT TO SVBLK ! 16732: MOV SVLEN(XL),WA AND LOAD NAME LENGTH ! 16733: * ! 16734: * MERGE HERE WITH STRING IN XR, LENGTH IN WA ! 16735: * ! 16736: GTS04 ZER WB SET OFFSET TO ZERO ! 16737: JSR SBSTR USE SBSTR TO COPY STRING ! 16738: BRN GTS29 JUMP TO EXIT ! 16739: * ! 16740: * COME HERE TO CONVERT AN INTEGER ! 16741: * ! 16742: GTS05 LDI ICVAL(XR) LOAD INTEGER VALUE ! 16743: .IF .CSCI ! 16744: JSR SYSCI CONVERT INTEGER ! 16745: MOV SCLEN(XL),WA GET LENGTH ! 16746: ZER WB ZERO OFFSET FOR SBSTR ! 16747: JSR SBSTR COPY IN RESULT FROM SYSCI ! 16748: BRN GTS29 EXIT ! 16749: .ELSE ! 16750: MOV =NUM01,GTSSF SET SIGN FLAG NEGATIVE ! 16751: ILT GTS06 SKIP IF INTEGER IS NEGATIVE ! 16752: NGI ELSE NEGATE INTEGER ! 16753: ZER GTSSF AND RESET NEGATIVE FLAG ! 16754: EJC ! 16755: * ! 16756: * GTSTG (CONTINUED) ! 16757: * ! 16758: * HERE WITH SIGN FLAG SET AND SIGN FORCED NEGATIVE AS ! 16759: * REQUIRED BY THE CVD INSTRUCTION. ! 16760: * ! 16761: GTS06 MOV GTSWK,XR POINT TO RESULT WORK AREA ! 16762: MOV =NSTMX,WB INITIALIZE COUNTER TO MAX LENGTH ! 16763: PSC XR,WB PREPARE TO STORE (RIGHT-LEFT) ! 16764: * ! 16765: * LOOP TO CONVERT DIGITS INTO WORK AREA ! 16766: * ! 16767: GTS07 CVD CONVERT ONE DIGIT INTO WA ! 16768: SCH WA,-(XR) STORE IN WORK AREA ! 16769: DCV WB DECREMENT COUNTER ! 16770: INE GTS07 LOOP IF MORE DIGITS TO GO ! 16771: CSC XR COMPLETE STORE CHARACTERS ! 16772: * ! 16773: * MERGE HERE AFTER CONVERTING INTEGER OR REAL INTO WORK ! 16774: * AREA. WB IS SET TO NSTMX - (NUMBER OF CHARS IN RESULT). ! 16775: * ! 16776: GTS08 MOV =NSTMX,WA GET MAX NUMBER OF CHARACTERS ! 16777: SUB WB,WA COMPUTE LENGTH OF RESULT ! 16778: MOV WA,XL REMEMBER LENGTH FOR MOVE LATER ON ! 16779: ADD GTSSF,WA ADD ONE FOR NEGATIVE SIGN IF NEEDED ! 16780: JSR ALOCS ALLOCATE STRING FOR RESULT ! 16781: MOV XR,WC SAVE RESULT POINTER FOR THE MOMENT ! 16782: PSC XR POINT TO CHARS OF RESULT BLOCK ! 16783: BZE GTSSF,GTS09 SKIP IF POSITIVE ! 16784: MOV =CH$MN,WA ELSE LOAD NEGATIVE SIGN ! 16785: SCH WA,(XR)+ AND STORE IT ! 16786: CSC XR COMPLETE STORE CHARACTERS ! 16787: .FI ! 16788: * ! 16789: * HERE AFTER DEALING WITH SIGN ! 16790: * ! 16791: GTS09 MOV XL,WA RECALL LENGTH TO MOVE ! 16792: MOV GTSWK,XL POINT TO RESULT WORK AREA ! 16793: PLC XL,WB POINT TO FIRST RESULT CHARACTER ! 16794: MVC MOVE CHARS TO RESULT STRING ! 16795: MOV WC,XR RESTORE RESULT POINTER ! 16796: .IF .CNRA ! 16797: .ELSE ! 16798: BRN GTS29 JUMP TO EXIT ! 16799: EJC ! 16800: * ! 16801: * GTSTG (CONTINUED) ! 16802: * ! 16803: * HERE TO CONVERT A REAL ! 16804: * ! 16805: GTS10 LDR RCVAL(XR) LOAD REAL ! 16806: ZER GTSSF RESET NEGATIVE FLAG ! 16807: REQ GTS31 SKIP IF ZERO ! 16808: RGE GTS11 JUMP IF REAL IS POSITIVE ! 16809: MOV =NUM01,GTSSF ELSE SET NEGATIVE FLAG ! 16810: NGR AND GET ABSOLUTE VALUE OF REAL ! 16811: * ! 16812: * NOW SCALE THE REAL TO THE RANGE (0.1 LE X LT 1.0) ! 16813: * ! 16814: GTS11 LDI INTV0 INITIALIZE EXPONENT TO ZERO ! 16815: * ! 16816: * LOOP TO SCALE UP IN STEPS OF 10**10 ! 16817: * ! 16818: GTS12 STR GTSRS SAVE REAL VALUE ! 16819: SBR REAP1 SUBTRACT 0.1 TO COMPARE ! 16820: RGE GTS13 JUMP IF SCALE UP NOT REQUIRED ! 16821: LDR GTSRS ELSE RELOAD VALUE ! 16822: MLR REATT MULTIPLY BY 10**10 ! 16823: SBI INTVT DECREMENT EXPONENT BY 10 ! 16824: BRN GTS12 LOOP BACK TO TEST AGAIN ! 16825: * ! 16826: * TEST FOR SCALE DOWN REQUIRED ! 16827: * ! 16828: GTS13 LDR GTSRS RELOAD VALUE ! 16829: SBR REAV1 SUBTRACT 1.0 ! 16830: RLT GTS17 JUMP IF NO SCALE DOWN REQUIRED ! 16831: LDR GTSRS ELSE RELOAD VALUE ! 16832: * ! 16833: * LOOP TO SCALE DOWN IN STEPS OF 10**10 ! 16834: * ! 16835: GTS14 SBR REATT SUBTRACT 10**10 TO COMPARE ! 16836: RLT GTS15 JUMP IF LARGE STEP NOT REQUIRED ! 16837: LDR GTSRS ELSE RESTORE VALUE ! 16838: DVR REATT DIVIDE BY 10**10 ! 16839: STR GTSRS STORE NEW VALUE ! 16840: ADI INTVT INCREMENT EXPONENT BY 10 ! 16841: BRN GTS14 LOOP BACK ! 16842: EJC ! 16843: * ! 16844: * GTSTG (CONTINUED) ! 16845: * ! 16846: * AT THIS POINT WE HAVE (1.0 LE X LT 10**10) ! 16847: * COMPLETE SCALING WITH POWERS OF TEN TABLE ! 16848: * ! 16849: GTS15 MOV =REAV1,XR POINT TO POWERS OF TEN TABLE ! 16850: * ! 16851: * LOOP TO LOCATE CORRECT ENTRY IN TABLE ! 16852: * ! 16853: GTS16 LDR GTSRS RELOAD VALUE ! 16854: ADI INTV1 INCREMENT EXPONENT ! 16855: ADD *CFP$R,XR POINT TO NEXT ENTRY IN TABLE ! 16856: SBR (XR) SUBTRACT IT TO COMPARE ! 16857: RGE GTS16 LOOP TILL WE FIND A LARGER ENTRY ! 16858: LDR GTSRS THEN RELOAD THE VALUE ! 16859: DVR (XR) AND COMPLETE SCALING ! 16860: STR GTSRS STORE VALUE ! 16861: * ! 16862: * WE ARE NOW SCALED, SO ROUND BY ADDING 0.5 * 10**(-CFP$S) ! 16863: * ! 16864: GTS17 LDR GTSRS GET VALUE AGAIN ! 16865: ADR GTSRN ADD ROUNDING FACTOR ! 16866: STR GTSRS STORE RESULT ! 16867: * ! 16868: * THE ROUNDING OPERATION MAY HAVE PUSHED US UP PAST ! 16869: * 1.0 AGAIN, SO CHECK ONE MORE TIME. ! 16870: * ! 16871: SBR REAV1 SUBTRACT 1.0 TO COMPARE ! 16872: RLT GTS18 SKIP IF OK ! 16873: ADI INTV1 ELSE INCREMENT EXPONENT ! 16874: LDR GTSRS RELOAD VALUE ! 16875: DVR REAVT DIVIDE BY 10.0 TO RESCALE ! 16876: BRN GTS19 JUMP TO MERGE ! 16877: * ! 16878: * HERE IF ROUNDING DID NOT MUCK UP SCALING ! 16879: * ! 16880: GTS18 LDR GTSRS RELOAD ROUNDED VALUE ! 16881: EJC ! 16882: * ! 16883: * GTSTG (CONTINUED) ! 16884: * ! 16885: * NOW WE HAVE COMPLETED THE SCALING AS FOLLOWS ! 16886: * ! 16887: * (IA) SIGNED EXPONENT ! 16888: * (RA) SCALED REAL (ABSOLUTE VALUE) ! 16889: * ! 16890: * IF THE EXPONENT IS NEGATIVE OR GREATER THAN CFP$S, THEN ! 16891: * WE CONVERT THE NUMBER IN THE FORM. ! 16892: * ! 16893: * (NEG SIGN) 0 . (CPF$S DIGITS) E (EXP SIGN) (EXP DIGITS) ! 16894: * ! 16895: * IF THE EXPONENT IS POSITIVE AND LESS THAN OR EQUAL TO ! 16896: * CFP$S, THE NUMBER IS CONVERTED IN THE FORM. ! 16897: * ! 16898: * (NEG SIGN) (EXPONENT DIGITS) . (CFP$S-EXPONENT DIGITS) ! 16899: * ! 16900: * IN BOTH CASES, THE FORMATS OBTAINED FROM THE ABOVE ! 16901: * RULES ARE MODIFIED BY DELETING TRAILING ZEROS AFTER THE ! 16902: * DECIMAL POINT. THERE ARE NO LEADING ZEROS IN THE EXPONENT ! 16903: * AND THE EXPONENT SIGN IS ALWAYS PRESENT. ! 16904: * ! 16905: GTS19 MOV =CFP$S,XL SET NUM DEC DIGITS = CFP$S ! 16906: MOV =CH$MN,GTSES SET EXPONENT SIGN NEGATIVE ! 16907: ILT GTS21 ALL SET IF EXPONENT IS NEGATIVE ! 16908: MFI WA ELSE FETCH EXPONENT ! 16909: BLE WA,=CFP$S,GTS20 SKIP IF WE CAN USE SPECIAL FORMAT ! 16910: MTI WA ELSE RESTORE EXPONENT ! 16911: NGI SET NEGATIVE FOR CVD ! 16912: MOV =CH$PL,GTSES SET PLUS SIGN FOR EXPONENT SIGN ! 16913: BRN GTS21 JUMP TO GENERATE EXPONENT ! 16914: * ! 16915: * HERE IF WE CAN USE THE FORMAT WITHOUT AN EXPONENT ! 16916: * ! 16917: GTS20 SUB WA,XL COMPUTE DIGITS AFTER DECIMAL POINT ! 16918: LDI INTV0 RESET EXPONENT TO ZERO ! 16919: EJC ! 16920: * ! 16921: * GTSTG (CONTINUED) ! 16922: * ! 16923: * MERGE HERE AS FOLLOWS ! 16924: * ! 16925: * (IA) EXPONENT ABSOLUTE VALUE ! 16926: * GTSES CHARACTER FOR EXPONENT SIGN ! 16927: * (RA) POSITIVE FRACTION ! 16928: * (XL) NUMBER OF DIGITS AFTER DEC POINT ! 16929: * ! 16930: GTS21 MOV GTSWK,XR POINT TO WORK AREA ! 16931: MOV =NSTMX,WB SET CHARACTER CTR TO MAX LENGTH ! 16932: PSC XR,WB PREPARE TO STORE (RIGHT TO LEFT) ! 16933: IEQ GTS23 SKIP EXPONENT IF IT IS ZERO ! 16934: * ! 16935: * LOOP TO GENERATE DIGITS OF EXPONENT ! 16936: * ! 16937: GTS22 CVD CONVERT A DIGIT INTO WA ! 16938: SCH WA,-(XR) STORE IN WORK AREA ! 16939: DCV WB DECREMENT COUNTER ! 16940: INE GTS22 LOOP BACK IF MORE DIGITS TO GO ! 16941: * ! 16942: * HERE GENERATE EXPONENT SIGN AND E ! 16943: * ! 16944: MOV GTSES,WA LOAD EXPONENT SIGN ! 16945: SCH WA,-(XR) STORE IN WORK AREA ! 16946: .IF .CPLC ! 16947: MOV =CH$$E,WA GET CHAR LETTER E ! 16948: .ELSE ! 16949: MOV =CH$LE,WA GET CHARACTER LETTER E ! 16950: .FI ! 16951: SCH WA,-(XR) STORE IN WORK AREA ! 16952: SUB =NUM02,WB DECREMENT COUNTER FOR SIGN AND E ! 16953: * ! 16954: * HERE TO GENERATE THE FRACTION ! 16955: * ! 16956: GTS23 MLR GTSSC CONVERT REAL TO INTEGER (10**CFP$S) ! 16957: RTI GET INTEGER (OVERFLOW IMPOSSIBLE) ! 16958: NGI NEGATE AS REQUIRED BY CVD ! 16959: * ! 16960: * LOOP TO SUPPRESS TRAILING ZEROS ! 16961: * ! 16962: GTS24 BZE XL,GTS27 JUMP IF NO DIGITS LEFT TO DO ! 16963: CVD ELSE CONVERT ONE DIGIT ! 16964: BNE WA,=CH$D0,GTS26 JUMP IF NOT A ZERO ! 16965: DCV XL DECREMENT COUNTER ! 16966: BRN GTS24 LOOP BACK FOR NEXT DIGIT ! 16967: EJC ! 16968: * ! 16969: * GTSTG (CONTINUED) ! 16970: * ! 16971: * LOOP TO GENERATE DIGITS AFTER DECIMAL POINT ! 16972: * ! 16973: GTS25 CVD CONVERT A DIGIT INTO WA ! 16974: * ! 16975: * MERGE HERE FIRST TIME ! 16976: * ! 16977: GTS26 SCH WA,-(XR) STORE DIGIT ! 16978: DCV WB DECREMENT COUNTER ! 16979: DCV XL DECREMENT COUNTER ! 16980: BNZ XL,GTS25 LOOP BACK IF MORE TO GO ! 16981: * ! 16982: * HERE GENERATE THE DECIMAL POINT ! 16983: * ! 16984: GTS27 MOV =CH$DT,WA LOAD DECIMAL POINT ! 16985: SCH WA,-(XR) STORE IN WORK AREA ! 16986: DCV WB DECREMENT COUNTER ! 16987: * ! 16988: * HERE GENERATE THE DIGITS BEFORE THE DECIMAL POINT ! 16989: * ! 16990: GTS28 CVD CONVERT A DIGIT INTO WA ! 16991: SCH WA,-(XR) STORE IN WORK AREA ! 16992: DCV WB DECREMENT COUNTER ! 16993: INE GTS28 LOOP BACK IF MORE TO GO ! 16994: CSC XR COMPLETE STORE CHARACTERS ! 16995: BRN GTS08 ELSE JUMP BACK TO EXIT ! 16996: .FI ! 16997: * ! 16998: * EXIT POINT AFTER SUCCESSFUL CONVERSION ! 16999: * ! 17000: GTS29 MOV (XS)+,XL RESTORE XL ! 17001: ICA XS POP ARGUMENT ! 17002: MOV GTSVB,WB RESTORE WB ! 17003: MOV GTSVC,WC RESTORE WC ! 17004: * ! 17005: * MERGE HERE IF NO CONVERSION REQUIRED ! 17006: * ! 17007: GTS30 MOV SCLEN(XR),WA LOAD STRING LENGTH ! 17008: EXI RETURN TO CALLER ! 17009: .IF .CNRA ! 17010: .ELSE ! 17011: * ! 17012: * HERE TO RETURN STRING FOR REAL ZERO ! 17013: * ! 17014: GTS31 MOV =SCRE0,XL POINT TO STRING ! 17015: MOV =NUM02,WA 2 CHARS ! 17016: ZER WB ZERO OFFSET ! 17017: JSR SBSTR COPY STRING ! 17018: BRN GTS29 RETURN ! 17019: .FI ! 17020: .IF .CNBF ! 17021: .ELSE ! 17022: EJC ! 17023: * ! 17024: * HERE TO CONVERT A BUFFER BLOCK ! 17025: * ! 17026: GTS32 MOV XR,XL COPY ARG PTR ! 17027: MOV BCLEN(XL),WA GET SIZE TO ALLOCATE ! 17028: BZE WA,GTS33 IF NULL THEN RETURN NULL ! 17029: JSR ALOCS ALLOCATE STRING FRAME ! 17030: MOV XR,WB SAVE STRING PTR ! 17031: MOV SCLEN(XR),WA GET LENGTH TO MOVE ! 17032: CTB WA,0 GET AS MULTIPLE OF WORD SIZE ! 17033: MOV BCBUF(XL),XL POINT TOBFBLK ! 17034: ADD *SCSI$,XR POINT TO START OF CHARACTER AREA ! 17035: ADD *BFSI$,XL POINT TO START OF BUFFER CHARS ! 17036: MVW COPY WORDS ! 17037: MOV WB,XR RESTORE SCBLK PTR ! 17038: BRN GTS29 EXIT WITH SCBLK ! 17039: * ! 17040: * HERE WHEN NULL BUFFER IS BEING CONVERTED ! 17041: * ! 17042: GTS33 MOV =NULLS,XR POINT TO NULL ! 17043: BRN GTS29 EXIT WITH NULL ! 17044: .FI ! 17045: ENP END PROCEDURE GTSTG ! 17046: EJC ! 17047: * ! 17048: * GTVAR -- GET VARIABLE FOR I/O/TRACE ASSOCIATION ! 17049: * ! 17050: * GTVAR IS USED TO POINT TO AN ACTUAL VARIABLE LOCATION ! 17051: * FOR THE DETACH,INPUT,OUTPUT,TRACE,STOPTR SYSTEM FUNCTIONS ! 17052: * ! 17053: * (XR) ARGUMENT TO FUNCTION ! 17054: * JSR GTVAR CALL TO LOCATE VARIABLE POINTER ! 17055: * PPM LOC TRANSFER LOC IF NOT OK VARIABLE ! 17056: * (XL,WA) NAME BASE,OFFSET OF VARIABLE ! 17057: * (XR,RA) DESTROYED ! 17058: * (WB,WC) DESTROYED (CONVERT ERROR ONLY) ! 17059: * (XR) INPUT ARG (CONVERT ERROR ONLY) ! 17060: * ! 17061: GTVAR PRC E,1 ENTRY POINT ! 17062: BNE (XR),=B$NML,GTVR2 JUMP IF NOT A NAME ! 17063: MOV NMOFS(XR),WA ELSE LOAD NAME OFFSET ! 17064: MOV NMBAS(XR),XL LOAD NAME BASE ! 17065: BEQ (XL),=B$EVT,GTVR1 ERROR IF EXPRESSION VARIABLE ! 17066: BNE (XL),=B$KVT,GTVR3 ALL OK IF NOT KEYWORD VARIABLE ! 17067: * ! 17068: * HERE ON CONVERSION ERROR ! 17069: * ! 17070: GTVR1 EXI 1 TAKE CONVERT ERROR EXIT ! 17071: * ! 17072: * HERE IF NOT A NAME, TRY CONVERT TO NATURAL VARIABLE ! 17073: * ! 17074: GTVR2 MOV WC,GTVRC SAVE WC ! 17075: JSR GTNVR LOCATE VRBLK IF POSSIBLE ! 17076: PPM GTVR1 JUMP IF CONVERT ERROR ! 17077: MOV XR,XL ELSE COPY VRBLK NAME BASE ! 17078: MOV *VRVAL,WA AND SET OFFSET ! 17079: MOV GTVRC,WC RESTORE WC ! 17080: * ! 17081: * HERE FOR NAME OBTAINED ! 17082: * ! 17083: GTVR3 BHI XL,STATE,GTVR4 ALL OK IF NOT NATURAL VARIABLE ! 17084: BEQ VRSTO(XL),=B$VRE,GTVR1 ERROR IF PROTECTED VARIABLE ! 17085: * ! 17086: * COMMON EXIT POINT ! 17087: * ! 17088: GTVR4 EXI RETURN TO CALLER ! 17089: ENP END PROCEDURE GTVAR ! 17090: EJC ! 17091: * ! 17092: * HASHS -- COMPUTE HASH INDEX FOR STRING ! 17093: * ! 17094: * HASHS REPRODUCIBLY MAPS A STRING TO AN INTEGER ! 17095: * VALUE. THE RESULTING HASH VALUE IS A POSITIVE INTEGER ! 17096: * IN THE RANGE 0 TO CFP$M ! 17097: * ! 17098: * (XR) STRING TO BE HASHED ! 17099: * JSR HASHS CALL TO HASH STRING ! 17100: * (IA) HASH VALUE ! 17101: * (XR,WB,WC) DESTROYED ! 17102: * ! 17103: * THE HASH FUNCTION USED IS AS FOLLOWS. ! 17104: * ! 17105: * START WITH THE LENGTH OF THE STRING ! 17106: * ! 17107: * TAKE THE FIRST E$HNW WORDS OF THE CHARACTERS FROM ! 17108: * THE STRING OR ALL THE WORDS IF FEWER THAN E$HNW. ! 17109: * ! 17110: * COMPUTE THE EXCLUSIVE OR OF ALL THESE WORDS TREATING ! 17111: * THEM AS ONE WORD BIT STRING VALUES. ! 17112: * ! 17113: * MOVE THE RESULT AS AN INTEGER WITH THE MTI INSTRUCTION. ! 17114: * ! 17115: HASHS PRC E,0 ENTRY POINT ! 17116: MOV SCLEN(XR),WC LOAD STRING LENGTH IN CHARACTERS ! 17117: MOV WC,WB INITIALIZE WITH LENGTH ! 17118: BZE WC,HSHS3 JUMP IF NULL STRING ! 17119: CTW WC,0 ELSE GET NUMBER OF WORDS OF CHARS ! 17120: ADD *SCHAR,XR POINT TO CHARACTERS OF STRING ! 17121: BLO WC,=E$HNW,HSHS1 USE WHOLE STRING IF SHORT ! 17122: MOV =E$HNW,WC ELSE SET TO INVOLVE FIRST E$HNW WDS ! 17123: * ! 17124: * HERE WITH COUNT OF WORDS TO CHECK IN WC ! 17125: * ! 17126: HSHS1 LCT WC,WC SET COUNTER TO CONTROL LOOP ! 17127: * ! 17128: * LOOP TO COMPUTE EXCLUSIVE OR ! 17129: * ! 17130: HSHS2 XOB (XR)+,WB EXCLUSIVE OR NEXT WORD OF CHARS ! 17131: BCT WC,HSHS2 LOOP TILL ALL PROCESSED ! 17132: * ! 17133: * MERGE HERE WITH EXCLUSIVE OR IN WB ! 17134: * ! 17135: HSHS3 ZGB WB ZEROISE UNDEFINED BITS ! 17136: ANB BITSM,WB ENSURE IN RANGE 0 TO CFP$M ! 17137: MTI WB MOVE RESULT AS INTEGER ! 17138: ZER XR CLEAR GARBAGE VALUE IN XR ! 17139: EXI RETURN TO HASHS CALLER ! 17140: ENP END PROCEDURE HASHS ! 17141: EJC ! 17142: * ! 17143: * ICBLD -- BUILD INTEGER BLOCK ! 17144: * ! 17145: * (IA) INTEGER VALUE FOR ICBLK ! 17146: * JSR ICBLD CALL TO BUILD INTEGER BLOCK ! 17147: * (XR) POINTER TO RESULT ICBLK ! 17148: * (WA) DESTROYED ! 17149: * ! 17150: ICBLD PRC E,0 ENTRY POINT ! 17151: ILT ICBL1 SKIP IF NEGATIVE ! 17152: SBI INTV2 REDUCE BY TWO ! 17153: ILE ICBL3 JUMP IF 0 , 1 OR 2 ! 17154: ADI INTV2 RESTORE VALUE ! 17155: * ! 17156: * CONSTRUCT ICBLK ! 17157: * ! 17158: ICBL1 MOV DNAMP,XR LOAD POINTER TO NEXT AVAILABLE LOC ! 17159: ADD *ICSI$,XR POINT PAST NEW ICBLK ! 17160: BLO XR,DNAME,ICBL2 JUMP IF THERE IS ROOM ! 17161: MOV *ICSI$,WA ELSE LOAD LENGTH OF ICBLK ! 17162: JSR ALLOC USE STANDARD ALLOCATOR TO GET BLOCK ! 17163: ADD WA,XR POINT PAST BLOCK TO MERGE ! 17164: * ! 17165: * MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED ! 17166: * ! 17167: ICBL2 MOV XR,DNAMP SET NEW POINTER ! 17168: SUB *ICSI$,XR POINT BACK TO START OF BLOCK ! 17169: MOV =B$ICL,(XR) STORE TYPE WORD ! 17170: STI ICVAL(XR) STORE INTEGER VALUE IN ICBLK ! 17171: EXI RETURN TO ICBLD CALLER ! 17172: * ! 17173: * OPTIMISE BY NOT BUILDING ICBLKS FOR SMALL INTEGERS ! 17174: * ! 17175: ICBL3 ADI INTV2 RESTORE VALUE ! 17176: MFI XR CONVERT TO SHORT INTEGER ! 17177: WTB XR CONVERT INTEGER TO OFFSET ! 17178: MOV INTAB(XR),XR POINT TO PRE-BUILT ICBLK ! 17179: EXI RETURN ! 17180: ENP END PROCEDURE ICBLD ! 17181: EJC ! 17182: * ! 17183: * IDENT -- COMPARE TWO VALUES ! 17184: * ! 17185: * IDENT COMPARES TWO VALUES IN THE SENSE OF THE IDENT ! 17186: * DIFFER FUNCTIONS AVAILABLE AT THE SNOBOL LEVEL. ! 17187: * ! 17188: * (XR) FIRST ARGUMENT ! 17189: * (XL) SECOND ARGUMENT ! 17190: * JSR IDENT CALL TO COMPARE ARGUMENTS ! 17191: * PPM LOC TRANSFER LOC IF IDENT ! 17192: * (NORMAL RETURN IF DIFFER) ! 17193: * (XR,XL,WC,RA) DESTROYED ! 17194: * ! 17195: IDENT PRC E,1 ENTRY POINT ! 17196: BEQ XR,XL,IDEN7 JUMP IF SAME POINTER (IDENT) ! 17197: MOV (XR),WC ELSE LOAD ARG 1 TYPE WORD ! 17198: BNE WC,(XL),IDEN1 DIFFER IF ARG 2 TYPE WORD DIFFER ! 17199: BEQ WC,=B$SCL,IDEN2 JUMP IF STRINGS ! 17200: BEQ WC,=B$ICL,IDEN4 JUMP IF INTEGERS ! 17201: .IF .CNRA ! 17202: .ELSE ! 17203: BEQ WC,=B$RCL,IDEN5 JUMP IF REALS ! 17204: .FI ! 17205: BEQ WC,=B$NML,IDEN6 JUMP IF NAMES ! 17206: * ! 17207: * FOR ALL OTHER DATATYPES, MUST BE DIFFER IF XR NE XL ! 17208: * ! 17209: * MERGE HERE FOR DIFFER ! 17210: * ! 17211: IDEN1 EXI TAKE DIFFER EXIT ! 17212: * ! 17213: * HERE FOR STRINGS, IDENT ONLY IF LENGTHS AND CHARS SAME ! 17214: * ! 17215: IDEN2 MOV SCLEN(XR),WC LOAD ARG 1 LENGTH ! 17216: BNE WC,SCLEN(XL),IDEN1 DIFFER IF LENGTHS DIFFER ! 17217: CTW WC,0 GET NUMBER OF WORDS IN STRINGS ! 17218: ADD *SCHAR,XR POINT TO CHARS OF ARG 1 ! 17219: ADD *SCHAR,XL POINT TO CHARS OF ARG 2 ! 17220: LCT WC,WC SET LOOP COUNTER ! 17221: * ! 17222: * LOOP TO COMPARE CHARACTERS. NOTE THAT WA CANNOT BE ZERO ! 17223: * SINCE ALL NULL STRINGS POINT TO NULLS AND GIVE XL=XR. ! 17224: * ! 17225: IDEN3 CNE (XR),(XL),IDEN8 DIFFER IF CHARS DO NOT MATCH ! 17226: ICA XR ELSE BUMP ARG ONE POINTER ! 17227: ICA XL BUMP ARG TWO POINTER ! 17228: BCT WC,IDEN3 LOOP BACK TILL ALL CHECKED ! 17229: EJC ! 17230: * ! 17231: * IDENT (CONTINUED) ! 17232: * ! 17233: * HERE TO EXIT FOR CASE OF TWO IDENT STRINGS ! 17234: * ! 17235: ZER XL CLEAR GARBAGE VALUE IN XL ! 17236: ZER XR CLEAR GARBAGE VALUE IN XR ! 17237: EXI 1 TAKE IDENT EXIT ! 17238: * ! 17239: * HERE FOR INTEGERS, IDENT IF SAME VALUES ! 17240: * ! 17241: IDEN4 LDI ICVAL(XR) LOAD ARG 1 ! 17242: SBI ICVAL(XL) SUBTRACT ARG 2 TO COMPARE ! 17243: IOV IDEN1 DIFFER IF OVERFLOW ! 17244: INE IDEN1 DIFFER IF RESULT IS NOT ZERO ! 17245: EXI 1 TAKE IDENT EXIT ! 17246: .IF .CNRA ! 17247: .ELSE ! 17248: * ! 17249: * HERE FOR REALS, IDENT IF SAME VALUES ! 17250: * ! 17251: IDEN5 LDR RCVAL(XR) LOAD ARG 1 ! 17252: SBR RCVAL(XL) SUBTRACT ARG 2 TO COMPARE ! 17253: ROV IDEN1 DIFFER IF OVERFLOW ! 17254: RNE IDEN1 DIFFER IF RESULT IS NOT ZERO ! 17255: EXI 1 TAKE IDENT EXIT ! 17256: .FI ! 17257: * ! 17258: * HERE FOR NAMES, IDENT IF BASES AND OFFSETS SAME ! 17259: * ! 17260: IDEN6 BNE NMOFS(XR),NMOFS(XL),IDEN1 DIFFER IF DIFFERENT OFFSET ! 17261: BNE NMBAS(XR),NMBAS(XL),IDEN1 DIFFER IF DIFFERENT BASE ! 17262: * ! 17263: * MERGE HERE TO SIGNAL IDENT FOR IDENTICAL POINTERS ! 17264: * ! 17265: IDEN7 EXI 1 TAKE IDENT EXIT ! 17266: * ! 17267: * HERE FOR DIFFER STRINGS ! 17268: * ! 17269: IDEN8 ZER XR CLEAR GARBAGE PTR IN XR ! 17270: ZER XL CLEAR GARBAGE PTR IN XL ! 17271: EXI RETURN TO CALLER (DIFFER) ! 17272: ENP END PROCEDURE IDENT ! 17273: EJC ! 17274: * ! 17275: * INOUT - USED TO INITIALISE .INPUT .OUTPUT .TERMINAL ! 17276: * ! 17277: * (XL) POINTER TO VBL NAME STRING ! 17278: * (WB) TRBLK TYPE (TRTYP FIELD) ! 17279: * JSR INOUT CALL TO PERFORM INITIALISATION ! 17280: * (WA,WC) DESTROYED ! 17281: * ! 17282: * NOTE THAT TRTER (= TRTRF) FIELD OF STANDARD I/O VARIABLES ! 17283: * POINTS TO CORRESPONDING SVBLK NOT TO A TRBLK AS IS THE ! 17284: * CASE FOR ORDINARY VARIABLES. ! 17285: * ! 17286: INOUT PRC E,0 ENTRY POINT ! 17287: MOV WB,-(XS) STACK TRBLK TYPE ! 17288: MOV SCLEN(XL),WA GET NAME LENGTH ! 17289: ZER WB POINT TO START OF NAME ! 17290: JSR SBSTR BUILD A PROPER SCBLK ! 17291: JSR GTNVR FIND OR BUILD VRBLK ! 17292: PPM NO ERROR RETURN ! 17293: MOV XR,WC SAVE VRBLK POINTER ! 17294: MOV (XS)+,WB GET TRTYP FIELD ! 17295: ZER XL ZERO TRTRI ! 17296: MOV VRSVP(XR),XR GET SVBLK POINTER ! 17297: JSR TRBLD BUILD TRBLK ! 17298: MOV WC,XL RECALL VRBLK POINTER ! 17299: MOV *VRVAL,WA OFFSET TO VALUE FIELD ! 17300: JSR TRCHN PUT TRBLK IN TRACE CHAIN ! 17301: PPM CANT FAIL ! 17302: EXI RETURN TO CALLER ! 17303: ENP END PROCEDURE INOUT ! 17304: EJC ! 17305: .IF .CNBF ! 17306: .ELSE ! 17307: * ! 17308: * INSBF -- INSERT STRING IN BUFFER ! 17309: * ! 17310: * THIS ROUTINE WILL REPLACE A SECTION OF A BUFFER WITH THE ! 17311: * CONTENTS OF A GIVEN STRING. IF THE LENGTH OF THE ! 17312: * SECTION TO BE REPLACED DIFFERS FROM THAT OF THE ! 17313: * GIVEN STRING, AND THE REPLACEMENT IS NOT AN APPEND, ! 17314: * THEN THE UPPER SECTION OF THE BUFFER IS SHIFTED UP OR ! 17315: * DOWN TO CREATE THE PROPER SPACE FOR THE INSERT. ! 17316: * ! 17317: * (XR) POINTER TO BCBLK ! 17318: * (XL) OBJECT WHICH IS STRING CONVERTIBLE ! 17319: * (WA) OFFSET OF START OF INSERT IN (XR) ! 17320: * (WB) LENGTH OF SECTION IN (XR) REPLACED ! 17321: * JSR INSBF CALL TO INSERT CHARACTERS IN BUFFER ! 17322: * PPM LOC ERROR IF (XR) NOT CONVERTIBLE ! 17323: * PPM LOC FAIL IF INSERT NOT POSSIBLE ! 17324: * (XL,WA,WB,WC) DESTROYED ! 17325: * ! 17326: * THE SECOND ALTERNATE EXIT IS TAKEN IF THE INSERT WOULD ! 17327: * OVERFLOW THE BUFFER, OR IF THE INSERT IS OUT PAST THE ! 17328: * DEFINED END OF THE BUFFER AS GIVEN. ! 17329: * ! 17330: INSBF PRC E,2 ENTRY POINT ! 17331: MOV WA,INSSA SAVE ENTRY WA ! 17332: MOV WB,INSSB SAVE ENTRY WB ! 17333: ADD WB,WA ADD TO GET OFFSET PAST REPLACE PART ! 17334: MOV WA,INSAB SAVE WA+WB ! 17335: MOV BCLEN(XR),WC GET CURRENT DEFINED LENGTH ! 17336: BGT INSSA,WC,INS07 FAIL IF START OFFSET TOO BIG ! 17337: BGT WA,WC,INS07 FAIL IF FINAL OFFSET TOO BIG ! 17338: MOV XR,-(XS) SAVE BCBLK PTR ! 17339: MOV XL,-(XS) STACK STRING POINTER FOR GTSTG ! 17340: JSR GTSTG CALL TO CONVERT TO STRING ! 17341: PPM INS06 TAKE STRING CONVERT ERR EXIT ! 17342: MOV XR,XL SAVE STRING PTR ! 17343: MOV (XS)+,XR RESTORE BCBLK PTR ! 17344: MOV XR,INSBC BCBLK PTR - NO DANGER OF GARB COLLN ! 17345: MOV BCBUF(XR),XR POINT TO BFBLK ! 17346: MOV XR,INSBB BFBLK PTR - NO DANGER OF GARB COLLN ! 17347: ADD WC,WA ADD BUFFER LEN TO STRING LEN ! 17348: SUB INSSB,WA BIAS OUT COMPONENT BEING REPLACED ! 17349: BGT WA,BFALC(XR),INS07 FAIL IF RESULT EXCEEDS ALLOCATION ! 17350: MOV INSBC,XR RESTORE BCBLK PTR ! 17351: MOV WC,WA GET BUFFER LENGTH ! 17352: SUB INSAB,WA SUBTRACT TO GET SHIFT LENGTH ! 17353: ADD SCLEN(XL),WC ADD LENGTH OF NEW ! 17354: SUB INSSB,WC SUBTRACT OLD TO GET TOTAL NEW LEN ! 17355: MOV BCLEN(XR),WB GET OLD BCLEN ! 17356: MOV WC,BCLEN(XR) STUFF NEW LENGTH ! 17357: MOV INSBB,XR POINT TO BFBLK ! 17358: MOV XL,-(XS) SAVE SCBLK PTR ! 17359: BZE WA,INS02 SKIP SHIFT IF NOTHING TO DO ! 17360: BEQ INSSB,SCLEN(XL),INS02 SKIP SHIFT IF LENGTHS MATCH ! 17361: BLO INSSB,SCLEN(XL),INS01 BRN IF SHIFT IS FOR MORE ROOM ! 17362: EJC ! 17363: * ! 17364: * INSBF (CONTINUED) ! 17365: * ! 17366: * WE ARE SHIFTING THE UPPER SEGMENT DOWN TO COMPACT ! 17367: * THE BUFFER. (THE STRING LENGTH IS SMALLER THAN THE ! 17368: * SEGMENT BEING REPLACED). REGISTERS ARE SET AS - ! 17369: * ! 17370: * (WA) MOVE (SHIFT DOWN) LENGTH ! 17371: * (WB) OLD BCLEN ! 17372: * (WC) NEW BCLEN ! 17373: * (XR) BFBLK PTR ! 17374: * (XL),(XS) SCBLK PTR ! 17375: * ! 17376: MOV INSSA,WB GET OFFSET TO INSERT ! 17377: ADD SCLEN(XL),WB ADD INSERT LENGTH TO GET DEST OFF ! 17378: MOV XR,XL MAKE COPY ! 17379: PLC XL,INSAB PREPARE SOURCE FOR MOVE ! 17380: PSC XR,WB PREPARE DESTINATION REG FOR MOVE ! 17381: MVC MOVE EM OUT ! 17382: BRN INS02 BRANCH TO PAD ! 17383: * ! 17384: * WE ARE SHIFTING THE UPPER SEGMENT UP TO EXPAND ! 17385: * THE BUFFER. (THE STRING LENGTH IS LARGER THAN THE ! 17386: * SEGMENT BEING REPLACED.) ! 17387: * ! 17388: INS01 MOV XR,XL COPY BFBLK PTR ! 17389: PLC XL,WB SET SOURCE REG FOR MOVE BACKWARDS ! 17390: PSC XR,WC SET DESTINATION PTR FOR MOVE ! 17391: MCB MOVE BACKWARDS (POSSIBLE OVERLAP) ! 17392: * ! 17393: * MERGE HERE AFTER POSSIBLE MOVE TO ADJUST ZERO FILL AT END ! 17394: * ! 17395: INS02 MOV (XS)+,XL RESTORE SCBLK PTR ! 17396: MOV WC,WA COPY NEW BUFFER END ! 17397: CTB WA,0 ROUND OUT ! 17398: BTC WA CONVERT TO CHAR COUNT ! 17399: SUB WC,WA SUBTRACT TO GET REMAINDER ! 17400: BZE WA,INS04 NO PAD IF ALREADY EVEN BOUNDARY ! 17401: MOV INSBB,XR POINT TO BFBLK ! 17402: PSC XR,WC PREPARE TO PAD ! 17403: ZER WB CLEAR WB ! 17404: LCT WA,WA LOAD LOOP COUNT ! 17405: EJC ! 17406: * ! 17407: * INSBF (CONTINUED) ! 17408: * ! 17409: * LOOP HERE TO STUFF PAD CHARACTERS ! 17410: * ! 17411: INS03 SCH WB,(XR)+ STUFF ZERO PAD ! 17412: BCT WA,INS03 BRANCH FOR MORE ! 17413: * ! 17414: * MERGE HERE WHEN PADDING OK. NOW COPY IN THE INSERT ! 17415: * STRING TO THE HOLE. ! 17416: * ! 17417: INS04 MOV INSBB,XR POINT TO BFBLK ! 17418: MOV SCLEN(XL),WA GET MOVE LENGTH ! 17419: BZE WA,INS05 SKIP IF NO CHARS TO INSERT ! 17420: PLC XL PREPARE TO COPY FROM FIRST CHAR ! 17421: PSC XR,INSSA PREPARE TO STORE IN HOLE ! 17422: MVC COPY THE CHARACTERS ! 17423: * ! 17424: * SUCCESSFUL RETURN ! 17425: * ! 17426: INS05 MOV INSBC,XR RESTORE ENTRY XR ! 17427: ZER XL CLEAR GARBAGE CHAR POINTER ! 17428: EXI RETURN TO CALLER ! 17429: * ! 17430: * HERE TO TAKE STRING CONVERT ERROR EXIT ! 17431: * ! 17432: INS06 ICA XS DISCARD UNWANTED STACK TOP ! 17433: EXI 1 ALTERNATE EXIT ! 17434: * ! 17435: * HERE FOR INVALID OFFSET OR LENGTH ! 17436: * ! 17437: INS07 EXI 2 ALTERNATE EXIT ! 17438: ENP END PROCEDURE INSBF ! 17439: EJC ! 17440: .FI ! 17441: * IOFTG -- GET IOTAG ! 17442: * ! 17443: * USED TO FIND THE IOTAG (IF ANY) CORRESPONDING TO THE ! 17444: * FILETAG ARGUMENT. ! 17445: * ! 17446: * -(XS) FILETAG ARGUMENT ! 17447: * JSR IOFTG CALL TO FIND IOTAG ! 17448: * PPM LOC ARG IS AN UNSUITABLE FILETAG ! 17449: * (XS) POPPED ! 17450: * (XL) PTR TO FILETAG SCBLK ! 17451: * (XR) PTR TO TRTIO TRACE BLK OR ZERO ! 17452: * (WA) IOTAG OR ZERO ! 17453: * (WB) PTR TO FILETAG VRBLK ! 17454: * (WC) VALUE/0 FOR INTEGER/STRING FILETAG ! 17455: * ! 17456: IOFTG PRC N,1 ENTRY POINT ! 17457: JSR GTSTG GET ARG AS STRING ! 17458: PPM IOFT4 FAIL ! 17459: MOV XR,XL COPY STRING PTR ! 17460: MOV XR,-(XS) STACK STRING ! 17461: JSR GTSMI TRY CONVERSION TO INTEGER ! 17462: PPM IOFT5 SKIP IF CANT ! 17463: PPM IOFT5 SKIP IF CANT ! 17464: * ! 17465: * MERGE WITH WC SET UP ! 17466: * ! 17467: IOFT1 MOV WC,WB KEEP INTEGER OR ZERO ! 17468: MOV XL,XR FILETAG STRING TO XR FOR GTNVR CALL ! 17469: JSR GTNVR FIND VRBLK ! 17470: PPM IOFT4 SKIP IF NULL STRING ! 17471: MOV XL,-(XS) KEEP SCBLK PTR ! 17472: ZER XL IN CASE NO TRTIO BLK FOUND ! 17473: MOV WB,WC KEEP INTEGER OR ZERO ! 17474: MOV XR,WB COPY VRBLK PTR FOR RETURN ! 17475: ZER WA IN CASE NO TRBLK FOUND ! 17476: * ! 17477: * LOOP TO FIND FILE ARG1 TRBLK ! 17478: * ! 17479: IOFT2 MOV VRVAL(XR),XR GET POSSIBLE TRBLK PTR ! 17480: BNE (XR),=B$TRT,IOFT3 SKIP IF END OF CHAIN ! 17481: BNE TRTYP(XR),=TRTIO,IOFT2 LOOP IF NOT FILETAG TRBLK ! 17482: MOV TRTAG(XR),WA GET IOTAG OR 0 ! 17483: MOV XR,XL TRTIO BLK PTR ! 17484: * ! 17485: * RETURN POINT ! 17486: * ! 17487: IOFT3 MOV XL,XR TRTIO BLK PTR OR 0 ! 17488: MOV (XS)+,XL RECOVER SCBLK PTR ! 17489: EXI SUCCESSFUL RETURN ! 17490: * ! 17491: * FAIL RETURN ! 17492: * ! 17493: IOFT4 EXI 1 FAIL ! 17494: EJC ! 17495: * ! 17496: * NON NUMERIC FILETAG ! 17497: * ! 17498: IOFT5 ZER WC NOTE NON NUMERIC ! 17499: BRN IOFT1 MERGE ! 17500: ENP END PROCEDURE IOFTG ! 17501: EJC ! 17502: * ! 17503: * IOPUT -- PROCESS INPUT AND OUTPUT ARGUMENTS ! 17504: * ! 17505: * IOPUT CHECKS THE ARGUMENTS OF INPUT AND OUTPUT CALLS, ! 17506: * SETS UP THE REQUIRED ASSOCIATIONS AND CALLS SYSIO TO ! 17507: * OPEN THE REQUESTED FILES. ! 17508: * ! 17509: * -(XS) 1ST ARG (VBL TO BE ASSOCIATED) ! 17510: * -(XS) 2ND ARG (FILETAG) ! 17511: * -(XS) 3RD ARG (FILEPROPS) ! 17512: * (WB) 0 FOR INPUT, 2 FOR OUTPUT ASSOC. ! 17513: * JSR IOPUT CALL FOR INPUT/OUTPUT ASSOCIATION ! 17514: * PPM LOC 3RD ARG NOT A STRING ! 17515: * PPM LOC 2ND ARG NOT A SUITABLE FILETAG ! 17516: * PPM LOC 1ST ARG NOT A SUITABLE NAME ! 17517: * PPM LOC FAIL RETURN ! 17518: * (XS) POPPED ! 17519: * (XL,XR,WA,WB,WC) DESTROYED ! 17520: * ! 17521: EJC ! 17522: * FIRST ARG NAME ! 17523: * I I ! 17524: * +------+ ! 17525: * I I-----+ ! 17526: * +------+ V ! 17527: * I I +----------------+ ! 17528: * I =B$TRT I ! 17529: * +----------------+ ! 17530: * I =TRTIN/=TRTOU I ! 17531: * +----------------+ ! 17532: * I VALUE OR TRCHN + ! 17533: * +----------------+ ! 17534: * TRTER I I-----+ ! 17535: * +----------------+ V ! 17536: * TRTRI I 0 I +------+ ! 17537: * +----------------+ I I SVBLK ! 17538: * I/O TRACE BLOCK +------+ ! 17539: * ! 17540: * 1. ASSOCIATION TO STANDARD FILES. ! 17541: * ! 17542: * FIRST ARG NAME FILETAG VRBLK ! 17543: * I I I I ! 17544: * +------+ LK1 +------+ LK2 ! 17545: * I I---+ +---+ I I---+ ! 17546: * +------+ V I V +------+ V ! 17547: * I I +----------------+ I +----------------+ ! 17548: * I =B$TRT I I I =B$TRT I ! 17549: * +----------------+ I +----------------+ ! 17550: * I =TRTIN/=TRTOU I I I =TRTIO I ! 17551: * +----------------+ I +----------------+ ! 17552: * I VALUE OR TRCHN I I I VALUE OR TRCHN I ! 17553: * +----------------+ I +----------------+ ! 17554: * TRTER I 0 I I I 0 OR IOTAG I TRTAG ! 17555: * +----------------+ I +----------------+ ! 17556: * TRTRI I I--+ I 0 I TRTRI ! 17557: * +----------------+ +----------------+ ! 17558: * I/O TRACE BLOCK TRTIO BLOCK ! 17559: * ! 17560: * 2. REGULAR CASE. ! 17561: * ! 17562: * THE STRUCTURES BUILT FOR I/O ASSOCIATIONS ARE AS SHOWN ! 17563: * ABOVE. A TRACE BLOCK CHAIN (TRCHN) MAY HOLD ANY OR ALL ! 17564: * OF THE TYPES, =TRTIN, =TRTOU, =TRTIO, BUT NOT MORE THAN ! 17565: * ONE BLOCK OF ANY GIVEN TYPE. CASES ARE - ! 17566: * 1. NO FILETAG OR IOTAG IS USED FOR ASSOCIATING STANDARD ! 17567: * FILES (SYSRD, SYSPR, TERMINAL). THE I/O TRACE BLOCK ! 17568: * IS DISTINGUISHED BY A NON-NULL TRTER FIELD POINTING ! 17569: * TO THE RELEVANT SVBLK (V$INP, V$OUP, V$TER) AND A ! 17570: * ZERO TRTRI FIELD. FOR TERMINAL, TRBLKS OF BOTH ! 17571: * INPUT AND OUTPUT TYPE ARE CHAINED FROM THE FIRST ARG ! 17572: * VIA THE TRCHN FIELD. ! 17573: * 2. THE I/O TRACE BLOCK FOR THE REGULAR CASE HAS A ZERO ! 17574: * TRTER FIELD AND A POINTER TO A TRTIO BLOCK IS IN ! 17575: * THE TRTRI FIELD. THE FILETAG MUST BE A NATURAL ! 17576: * VARIABLE AND THE TRTIO TRACE BLOCK ATTACHED TO IT ! 17577: * HOLDS THE IOTAG. ! 17578: * THE EFFECT OF ENDFILE() IS TO CLEAR IOTAG AND BREAK LK2. ! 17579: * THE EFFECT OF DETACH() IS TO BREAK LK1. ! 17580: EJC ! 17581: IOPUT PRC N,4 ENTRY POINT ! 17582: MOV WB,IOPWB KEEP ASSOCIATION TYPE FLAG ! 17583: JSR GTSTG CONVERT THIRD ARG TO STRING ! 17584: PPM IOP12 FAIL THIRD ARG ! 17585: BNZ WA,IOP01 SKIP IF NON NULL ! 17586: ZER XR NOTE NULL ARG ! 17587: * ! 17588: * PROCESS SECOND ARG ! 17589: * ! 17590: IOP01 MOV XR,R$IOR KEEP FILEPROPS STRING PTR ! 17591: JSR IOFTG CHECK SECOND ARG ! 17592: PPM IOP07 FAIL SECOND ARG ! 17593: MOV XL,R$IOL KEEP SCBLK FOR FILETAG ! 17594: MOV XR,R$IOT KEEP TRTIO BLK PTR ! 17595: MOV WA,IOPWA KEEP IOTAG ! 17596: MOV WB,IOPVR KEEP FILETAG VRBLK PTR ! 17597: MOV WC,IOPWC KEEP FILETAG VALUE ! 17598: MOV (XS)+,XR GET FIRST ARG OFF STACK ! 17599: JSR GTVAR CONVERT TO NAME ! 17600: PPM IOP13 FAIL FIRST ARG ! 17601: MOV XL,R$IO1 SAVE FIRST ARG NAME BASE ADRS ! 17602: MOV WA,IOPNF SAVE FIRST ARG NAME OFFSET ! 17603: MOV WB,XR FILETAG VRBLK PTR ! 17604: BNZ VRLEN(XR),IOP02 NOT SPECIAL CASE IF NOT SYS NAME ! 17605: MOV VRSVP(XR),WC GET SVBLK PTR ! 17606: MOV =TRTIN,WB IN CASE .INPUT ! 17607: BEQ WC,=V$INP,IOP06 JUMP IF .INPUT ! 17608: MOV =TRTOU,WB IN CASE .OUTPUT OR .TERMINAL ! 17609: BEQ WC,=V$OUP,IOP08 JUMP IF .OUTPUT ! 17610: BEQ WC,=V$TER,IOP09 JUMP IF .TERMINAL ! 17611: EJC ! 17612: * ! 17613: * NORMAL CASE ! 17614: * ! 17615: IOP02 BNZ R$IOT,IOP03 SKIP IF TRTIO BLK EXISTS ALREADY ! 17616: MOV =TRTIO,WB TRACE BLOCK TYPE WORD ! 17617: ZER XR ZERO IOTAG WORD ! 17618: ZER XL ZERO TRTRI FIELD ! 17619: JSR TRBLD BUILD TRTIO TRBLK ! 17620: MOV XR,R$IOT SAVE TRTIO BLK PTR ! 17621: MOV IOPVR,XL GET FILETAG VRBLK ! 17622: MOV *VRVAL,WA OFFSET TO VALUE FIELD ! 17623: JSR TRCHN PLACE IN TRBLK CHAIN FOR FILETAG ! 17624: PPM UNUSED RETURN ! 17625: * ! 17626: * MERGE TO BUILD TRBLK FOR FIRST ARG ! 17627: * ! 17628: IOP03 MOV =TRTIN,WB IN CASE INPUT ! 17629: BZE IOPWB,IOP04 SKIP IF SO ! 17630: MOV =TRTOU,WB IN CASE OUTPUT ! 17631: * ! 17632: * BUILD TRACE BLOCK ! 17633: * ! 17634: IOP04 ICV IOPWB NOTE NOT STANDARD I/O FILE ! 17635: MOV R$IOT,XL TRTIO BLK PTR TO TRTRI FIELD ! 17636: ZER XR ZERO TRTER FIELD ! 17637: JSR TRBLD BUILD I/O TRACE BLOCK ! 17638: MOV R$IO1,XL ASSOCIATED VBL NAME BASE ! 17639: MOV IOPNF,WA NAME OFFSET ! 17640: JSR TRCHN UPDATE TRACE CHAIN FOR FIRST ARG ! 17641: PPM UNUSED RETURN ! 17642: * ! 17643: * PREPARE FOR AND MAKE SYSIO CALL ! 17644: * ! 17645: IOP05 MOV R$IOL,XL FILETAG SCBLK PTR ! 17646: MOV R$IOR,XR FILEPROPS SCBLK PTR ! 17647: MOV IOPWA,WA IOTAG OR ZERO ! 17648: MOV IOPWB,WB ASSOCIATION TYPE NUMBER ! 17649: MOV IOPWC,WC POSSIBLE FILETAG VALUE ! 17650: JSR SYSIO CALL SYSTEM ROUTINE TO OPEN FILE ! 17651: PPM IOP14 FAIL RETURN ! 17652: PPM EROSI ERROR RETURN ! 17653: MOV R$IOT,XL TRTIO POINTER ! 17654: BZE XL,IOP11 DONE IF ZERO ! 17655: MOV WA,TRTAG(XL) STORE RETURNED IOTAG ! 17656: BRN IOP11 SUCCEED ! 17657: EJC ! 17658: * ! 17659: * SPECIAL CASE OF .INPUT ! 17660: * ! 17661: IOP06 BZE IOPWB,IOP09 FAIL OUTPUT(.X,.INPUT) ! 17662: * ! 17663: * BAD FILETAG ! 17664: * ! 17665: IOP07 EXI 2 ERRONEOUS SECOND ARG ! 17666: * ! 17667: * SPECIAL CASE OF .OUTPUT ! 17668: * ! 17669: IOP08 BZE IOPWB,IOP07 FAIL INPUT(.X,.OUTPUT) ! 17670: * ! 17671: * SPECIAL CASE OF .TERMINAL AND MERGE FOR OTHERS ! 17672: * ! 17673: IOP09 ZER R$IOT NOTE NO TRTIO BLOCK ! 17674: MOV WC,XR SVBLK PTR FOR TRTER FIELD ! 17675: ZER XL ZERO TRTRI FIELD ! 17676: JSR TRBLD BUILD TRBLK ! 17677: MOV R$IO1,XL ASSOCIATED VBL NAME BASE ! 17678: MOV IOPNF,WA NAME OFFSET ! 17679: JSR TRCHN UPDATE TRACE CHAIN FOR ARG 1 ! 17680: PPM UNUSED RETURN ! 17681: BNE TRTER(XR),=V$TER,IOP10 DONE UNLESS TERMINAL ! 17682: BNE TRTYP(XR),=TRTOU,IOP10 DONE IF TERM. 2ND TIME ROUND ! 17683: MOV =V$TER,WC TRTER FIELD ! 17684: MOV =TRTIN,WB TRTYP FIELD ! 17685: BRN IOP09 REPEAT LOOP FOR TERMINAL ! 17686: * ! 17687: * CHECK SPECIAL CASES FOR NON-NULL THIRD ARGS ! 17688: * ! 17689: IOP10 ZER IOPWA NO IOTAG ! 17690: BNZ R$IOR,IOP05 MERGE ONLY IF FILEPROPS NON-NULL ! 17691: * ! 17692: * SUCCESS RETURN ! 17693: * ! 17694: IOP11 ZER R$IO1 CLEAR GARBAGE ! 17695: ZER R$IOL ! 17696: ZER R$IOR ! 17697: ZER R$IOT ! 17698: EXI RETURN TO CALLER ! 17699: * ! 17700: * ERROR RETURNS ! 17701: * ! 17702: IOP12 EXI 1 ERRONEOUS THIRD ARG ! 17703: * ! 17704: IOP13 EXI 3 ERRONEOUS FIRST ARG ! 17705: * ! 17706: IOP14 EXI 4 FAIL RETURN FROM SYSIO ! 17707: ENP END PROCEDURE IOPUT ! 17708: EJC ! 17709: * ! 17710: * KTREX -- EXECUTE KEYWORD TRACE ! 17711: * ! 17712: * KTREX IS USED TO EXECUTE A POSSIBLE KEYWORD TRACE. IT ! 17713: * INCLUDES THE TEST ON TRACE AND TESTS FOR TRACE ACTIVE. ! 17714: * ! 17715: * (XL) PTR TO TRBLK (OR 0 IF UNTRACED) ! 17716: * JSR KTREX CALL TO EXECUTE KEYWORD TRACE ! 17717: * (XL,WA,WB,WC) DESTROYED ! 17718: * (RA) DESTROYED ! 17719: * ! 17720: KTREX PRC R,0 ENTRY POINT (RECURSIVE) ! 17721: BZE XL,KTRX3 IMMEDIATE EXIT IF KEYWORD UNTRACED ! 17722: BZE KVTRA,KTRX3 IMMEDIATE EXIT IF TRACE = 0 ! 17723: DCV KVTRA ELSE DECREMENT TRACE ! 17724: MOV XR,-(XS) SAVE XR ! 17725: MOV XL,XR COPY TRBLK POINTER ! 17726: MOV TRKVR(XR),XL LOAD VRBLK POINTER (NMBAS) ! 17727: MOV *VRVAL,WA SET NAME OFFSET ! 17728: BZE TRFNC(XR),KTRX1 JUMP IF PRINT TRACE ! 17729: JSR TRXEQ ELSE EXECUTE FULL TRACE ! 17730: BRN KTRX2 AND JUMP TO EXIT ! 17731: * ! 17732: * HERE FOR PRINT TRACE ! 17733: * ! 17734: KTRX1 MOV XL,-(XS) STACK VRBLK PTR FOR KWNAM ! 17735: MOV WA,-(XS) STACK OFFSET FOR KWNAM ! 17736: JSR PRTSN PRINT STATEMENT NUMBER ! 17737: MOV =CH$AM,WA LOAD AMPERSAND ! 17738: JSR PRTCH PRINT AMPERSAND ! 17739: JSR PRTNM PRINT KEYWORD NAME ! 17740: MOV =TMBEB,XR POINT TO BLANK-EQUAL-BLANK ! 17741: JSR PRTST PRINT BLANK-EQUAL-BLANK ! 17742: JSR KWNAM GET KEYWORD PSEUDO-VARIABLE NAME ! 17743: MOV XR,DNAMP RESET PTR TO DELETE KVBLK ! 17744: JSR ACESS GET KEYWORD VALUE ! 17745: PPM FAILURE IS IMPOSSIBLE ! 17746: JSR PRTVF PRINT KEYWORD VALUE ! 17747: * ! 17748: * HERE TO EXIT AFTER COMPLETING TRACE ! 17749: * ! 17750: KTRX2 MOV (XS)+,XR RESTORE ENTRY XR ! 17751: * ! 17752: * MERGE HERE TO EXIT IF NO TRACE REQUIRED ! 17753: * ! 17754: KTRX3 EXI RETURN TO KTREX CALLER ! 17755: ENP END PROCEDURE KTREX ! 17756: EJC ! 17757: * ! 17758: * KWNAM -- GET PSEUDO-VARIABLE NAME FOR KEYWORD ! 17759: * ! 17760: * 1(XS) NAME BASE FOR VRBLK ! 17761: * 0(XS) OFFSET (SHOULD BE *VRVAL) ! 17762: * JSR KWNAM CALL TO GET PSEUDO-VARIABLE NAME ! 17763: * (XS) POPPED TWICE ! 17764: * (XL,WA) RESULTING PSEUDO-VARIABLE NAME ! 17765: * (XR,WA,WB) DESTROYED ! 17766: * ! 17767: KWNAM PRC N,0 ENTRY POINT ! 17768: ICA XS IGNORE NAME OFFSET ! 17769: MOV (XS)+,XR LOAD NAME BASE ! 17770: BGE XR,STATE,KWNM1 JUMP IF NOT NATURAL VARIABLE NAME ! 17771: BNZ VRLEN(XR),KWNM1 ERROR IF NOT SYSTEM VARIABLE ! 17772: MOV VRSVP(XR),XR ELSE POINT TO SVBLK ! 17773: MOV SVBIT(XR),WA LOAD BIT MASK ! 17774: ANB BTKNM,WA AND WITH KEYWORD BIT ! 17775: ZRB WA,KWNM1 ERROR IF NO KEYWORD ASSOCIATION ! 17776: MOV SVLEN(XR),WA ELSE LOAD NAME LENGTH IN CHARACTERS ! 17777: CTB WA,SVCHS COMPUTE OFFSET TO FIELD WE WANT ! 17778: ADD WA,XR POINT TO SVKNM FIELD ! 17779: MOV (XR),WB LOAD SVKNM VALUE ! 17780: MOV *KVSI$,WA SET SIZE OF KVBLK ! 17781: JSR ALLOC ALLOCATE KVBLK ! 17782: MOV =B$KVT,(XR) STORE TYPE WORD ! 17783: MOV WB,KVNUM(XR) STORE KEYWORD NUMBER ! 17784: MOV =TRBKV,KVVAR(XR) SET DUMMY TRBLK POINTER ! 17785: MOV XR,XL COPY KVBLK POINTER ! 17786: MOV *KVVAR,WA SET PROPER OFFSET ! 17787: EXI RETURN TO KVNAM CALLER ! 17788: * ! 17789: * HERE IF NOT KEYWORD NAME ! 17790: * ! 17791: KWNM1 ERB 230,KEYWORD OPERAND IS NOT NAME OF DEFINED KEYWORD ! 17792: ENP END PROCEDURE KWNAM ! 17793: EJC ! 17794: * ! 17795: * LCOMP-- COMPARE TWO STRINGS LEXICALLY ! 17796: * ! 17797: * 1(XS) FIRST ARGUMENT ! 17798: * 0(XS) SECOND ARGUMENT ! 17799: * JSR LCOMP CALL TO COMPARE ARUMENTS ! 17800: * PPM LOC TRANSFER LOC FOR ARG1 NOT STRING ! 17801: * PPM LOC TRANSFER LOC FOR ARG2 NOT STRING ! 17802: * PPM LOC TRANSFER LOC IF ARG1 LLT ARG2 ! 17803: * PPM LOC TRANSFER LOC IF ARG1 LEQ ARG2 ! 17804: * PPM LOC TRANSFER LOC IF ARG1 LGT ARG2 ! 17805: * (THE NORMAL RETURN IS NEVER TAKEN) ! 17806: * (XS) POPPED TWICE ! 17807: * (XR,XL) DESTROYED ! 17808: * (WA,WB,WC,RA) DESTROYED ! 17809: * ! 17810: LCOMP PRC N,5 ENTRY POINT ! 17811: JSR GTSTG CONVERT SECOND ARG TO STRING ! 17812: PPM LCMP6 JUMP IF SECOND ARG NOT STRING ! 17813: MOV XR,XL ELSE SAVE POINTER ! 17814: MOV WA,WB AND LENGTH ! 17815: JSR GTSTG CONVERT FIRST ARGUMENT TO STRING ! 17816: PPM LCMP5 JUMP IF NOT STRING ! 17817: MOV WA,WC SAVE ARG 1 LENGTH ! 17818: PLC XR POINT TO CHARS OF ARG 1 ! 17819: PLC XL POINT TO CHARS OF ARG 2 ! 17820: BLO WA,WB,LCMP0 JUMP IF ARG 1 LENGTH IS SMALLER ! 17821: MOV WB,WA ELSE SET ARG 2 LENGTH AS SMALLER ! 17822: * ! 17823: * HERE WITH SMALLER LENGTH IN (WA) ! 17824: * ! 17825: LCMP0 BZE WA,LCMP1 SKIP IF A NULL ARG ! 17826: CMC LCMP4,LCMP3 COMPARE STRINGS, JUMP IF UNEQUAL ! 17827: * ! 17828: * EQUAL STRINGS OR AT LEAST ONE NULL ARG ! 17829: * ! 17830: LCMP1 BNE WB,WC,LCMP2 IF EQUAL, JUMP IF LENGTHS UNEQUAL ! 17831: EXI 4 ELSE IDENTICAL STRINGS, LEQ EXIT ! 17832: EJC ! 17833: * ! 17834: * LCOMP (CONTINUED) ! 17835: * ! 17836: * HERE IF INITIAL STRINGS IDENTICAL, BUT LENGTHS UNEQUAL ! 17837: * ! 17838: LCMP2 BHI WC,WB,LCMP4 JUMP IF ARG 1 LENGTH GT ARG 2 LENG ! 17839: * ! 17840: * HERE IF FIRST ARG LLT SECOND ARG ! 17841: * ! 17842: LCMP3 EXI 3 TAKE LLT EXIT ! 17843: * ! 17844: * HERE IF FIRST ARG LGT SECOND ARG ! 17845: * ! 17846: LCMP4 EXI 5 TAKE LGT EXIT ! 17847: * ! 17848: * HERE IF FIRST ARG IS NOT A STRING ! 17849: * ! 17850: LCMP5 EXI 1 TAKE BAD FIRST ARG EXIT ! 17851: * ! 17852: * HERE FOR SECOND ARG NOT A STRING ! 17853: * ! 17854: LCMP6 EXI 2 TAKE BAD SECOND ARG ERROR EXIT ! 17855: ENP END PROCEDURE LCOMP ! 17856: EJC ! 17857: * ! 17858: * LISTR -- LIST SOURCE LINE ! 17859: * ! 17860: * LISTR IS USED TO LIST A SOURCE LINE DURING THE INITIAL ! 17861: * COMPILATION. IT IS CALLED FROM SCANE AND SCANL. ! 17862: * ! 17863: * JSR LISTR CALL TO LIST LINE ! 17864: * (XR,XL,WA,WB,WC) DESTROYED ! 17865: * ! 17866: * GLOBAL LOCATIONS USED BY LISTR ! 17867: * ! 17868: * ERLST IF LISTING ON ACCOUNT OF AN ERROR ! 17869: * ! 17870: * LSTLC COUNT LINES ON CURRENT PAGE ! 17871: * ! 17872: * LSTNP MAX NUMBER OF LINES/PAGE ! 17873: * ! 17874: * LSTPF SET NON-ZERO IF THE CURRENT SOURCE ! 17875: * LINE HAS BEEN LISTED, ELSE ZERO. ! 17876: * ! 17877: * LSTPG COMPILER LISTING PAGE NUMBER ! 17878: * ! 17879: * LSTSN SET IF STMNT NUM TO BE LISTED ! 17880: * ! 17881: * R$CIM POINTER TO CURRENT INPUT LINE. ! 17882: * ! 17883: * R$TTL TITLE FOR SOURCE LISTING ! 17884: * ! 17885: * R$STL PTR TO SUB-TITLE STRING ! 17886: * ! 17887: * ENTRY POINT ! 17888: * ! 17889: LISTR PRC E,0 ENTRY POINT ! 17890: MOV STAGE,WA GET COMPILER STAGE ! 17891: BEQ WA,=STGIC,LIST0 LIST OK IF INITIAL COMPILE ! 17892: BEQ WA,=STGCE,LIST0 LIST OK IF END LINE ! 17893: BRN LIST4 ELSE NO LISTING OF SOURCE ! 17894: * ! 17895: * HERE WHEN STAGE IS OK TO LIST ! 17896: * ! 17897: LIST0 BNZ CNTTL,LIST5 JUMP IF -TITLE OR -STITL ! 17898: BNZ LSTPF,LIST4 IMMEDIATE EXIT IF ALREADY LISTED ! 17899: BGE LSTLC,LSTNP,LIST6 JUMP IF NO ROOM ! 17900: * ! 17901: * HERE AFTER PRINTING TITLE (IF NEEDED) ! 17902: * ! 17903: LIST1 MOV R$CIM,XR LOAD POINTER TO CURRENT IMAGE ! 17904: PLC XR POINT TO CHARACTERS ! 17905: LCH WA,(XR) LOAD FIRST CHARACTER ! 17906: MOV LSTSN,XR LOAD STATEMENT NUMBER ! 17907: BZE XR,LIST2 JUMP IF NO STATEMENT NUMBER ! 17908: MTI XR ELSE GET STMNT NUMBER AS INTEGER ! 17909: BEQ WA,=CH$AS,LIST2 NO STMNT NUMBER LIST IF COMMENT ! 17910: BEQ WA,=CH$MN,LIST2 NO STMNT NO. IF CONTROL CARD ! 17911: JSR PRTIN ELSE PRINT STATEMENT NUMBER ! 17912: ZER LSTSN AND CLEAR FOR NEXT TIME IN ! 17913: EJC ! 17914: * ! 17915: * LISTR (CONTINUED) ! 17916: * ! 17917: * MERGE HERE AFTER PRINTING STATEMENT NUMBER (IF REQUIRED) ! 17918: * ! 17919: LIST2 MOV =STNPD,PROFS POINT PAST STATEMENT NUMBER ! 17920: MOV R$CIM,XR LOAD POINTER TO CURRENT IMAGE ! 17921: JSR PRTSF PRINT IT ! 17922: ICV LSTLC BUMP LINE COUNTER ! 17923: MNZ LSTPF SET FLAG FOR LINE PRINTED ! 17924: * ! 17925: * MERGE HERE TO EXIT ! 17926: * ! 17927: LIST4 EXI RETURN TO LISTR CALLER ! 17928: * ! 17929: * PRINT TITLE AFTER -TITLE OR -STITL CARD ! 17930: * ! 17931: LIST5 ZER CNTTL CLEAR FLAG ! 17932: * ! 17933: * EJECT TO NEW PAGE AND LIST TITLE ! 17934: * ! 17935: LIST6 JSR PRTPS EJECT ! 17936: BNZ PRLEN,LIST7 SKIP IF LISTING TO REGULAR PRINTER ! 17937: BEQ R$TTL,=NULLS,LIST1 TERMINAL LISTING OMITS NULL TITLE ! 17938: * ! 17939: * LIST TITLE ! 17940: * ! 17941: LIST7 JSR LISTT LIST TITLE ! 17942: BRN LIST1 MERGE ! 17943: ENP END PROCEDURE LISTR ! 17944: EJC ! 17945: * ! 17946: * LISTT -- LIST TITLE AND SUBTITLE ! 17947: * ! 17948: * USED DURING COMPILATION TO PRINT PAGE HEADING ! 17949: * ! 17950: * JSR LISTT CALL TO LIST TITLE ! 17951: * (XR,WA) DESTROYED ! 17952: * ! 17953: LISTT PRC E,0 ENTRY POINT ! 17954: MOV R$TTL,XR POINT TO SOURCE LISTING TITLE ! 17955: JSR PRTST PRINT TITLE ! 17956: MOV LSTPO,PROFS SET OFFSET ! 17957: MOV =LSTMS,XR SET PAGE MESSAGE ! 17958: JSR PRTST PRINT PAGE MESSAGE ! 17959: ICV LSTPG BUMP PAGE NUMBER ! 17960: MTI LSTPG LOAD PAGE NUMBER AS INTEGER ! 17961: JSR PRTIN PRINT PAGE NUMBER ! 17962: JSR PRTFH TERMINATE TITLE LINE ! 17963: ADD =NUM02,LSTLC COUNT TITLE LINE AND BLANK LINE ! 17964: * ! 17965: * PRINT SUB-TITLE (IF ANY) ! 17966: * ! 17967: MOV R$STL,XR LOAD POINTER TO SUB-TITLE ! 17968: BZE XR,LSTT1 JUMP IF NO SUB-TITLE ! 17969: JSR PRTSF ELSE PRINT SUB-TITLE ! 17970: ICV LSTLC BUMP LINE COUNT ! 17971: * ! 17972: * RETURN POINT ! 17973: * ! 17974: LSTT1 JSR PRTFH PRINT A BLANK LINE ! 17975: EXI RETURN TO CALLER ! 17976: ENP END PROCEDURE LISTT ! 17977: EJC ! 17978: * ! 17979: * NEXTS -- ACQUIRE NEXT SOURCE IMAGE ! 17980: * ! 17981: * NEXTS IS USED TO ACQUIRE THE NEXT SOURCE IMAGE AT COMPILE ! 17982: * TIME. IT ASSUMES THAT A PRIOR CALL TO READR HAS INPUT ! 17983: * A LINE IMAGE (SEE PROCEDURE READR). BEFORE THE CURRENT ! 17984: * IMAGE IS FINALLY LOST IT MAY BE LISTED HERE. ! 17985: * ! 17986: * JSR NEXTS CALL TO ACQUIRE NEXT INPUT LINE ! 17987: * (XR,XL,WA,WB,WC) DESTROYED ! 17988: * ! 17989: * GLOBAL VALUES AFFECTED ! 17990: * ! 17991: * R$CNI ON INPUT, NEXT IMAGE. ON ! 17992: * EXIT RESET TO ZERO ! 17993: * ! 17994: * R$CIM ON EXIT, SET TO POINT TO IMAGE ! 17995: * ! 17996: * SCNIL INPUT IMAGE LENGTH ON EXIT ! 17997: * ! 17998: * SCNSE RESET TO ZERO ON EXIT ! 17999: * ! 18000: * LSTPF SET ON EXIT IF LINE IS LISTED ! 18001: * ! 18002: NEXTS PRC E,0 ENTRY POINT ! 18003: BZE CSWLS,NXTS1 JUMP IF -NOLIST ! 18004: MOV R$CIM,XR POINT TO IMAGE ! 18005: BZE XR,NXTS1 JUMP IF NO IMAGE ! 18006: PLC XR GET CHAR PTR ! 18007: LCH WA,(XR) GET FIRST CHAR ! 18008: BEQ WA,=CH$MN,NXTS1 SKIP LISTING IF CONTROL CARD ! 18009: JSR LISTR LIST LINE ! 18010: * ! 18011: * HERE AFTER POSSIBLE LISTING ! 18012: * ! 18013: NXTS1 MOV R$CNI,XR POINT TO NEXT IMAGE ! 18014: MOV XR,R$CIM SET AS NEXT IMAGE ! 18015: ZER R$CNI CLEAR NEXT IMAGE POINTER ! 18016: MOV SCLEN(XR),WA GET INPUT IMAGE LENGTH ! 18017: MOV CSWIN,WB GET MAX ALLOWABLE LENGTH ! 18018: BLO WA,WB,NXTS2 SKIP IF NOT TOO LONG ! 18019: MOV WB,WA ELSE TRUNCATE ! 18020: * ! 18021: * HERE WITH LENGTH IN (WA) ! 18022: * ! 18023: NXTS2 MOV WA,SCNIL USE AS RECORD LENGTH ! 18024: ZER SCNSE RESET SCNSE ! 18025: ZER LSTPF SET LINE NOT LISTED YET ! 18026: EXI RETURN TO NEXTS CALLER ! 18027: ENP END PROCEDURE NEXTS ! 18028: EJC ! 18029: * ! 18030: * PATIN -- PATTERN CONSTRUCTION FOR LEN,POS,RPOS,TAB,RTAB ! 18031: * ! 18032: * THESE PATTERN TYPES ALL GENERATE A SIMILAR NODE TYPE. SO ! 18033: * THE CONSTRUCTION CODE IS SHARED. SEE FUNCTIONS SECTION ! 18034: * FOR ACTUAL ENTRY POINTS FOR THESE FIVE FUNCTIONS. ! 18035: * ! 18036: * (WA) PCODE FOR EXPRESSION ARG CASE ! 18037: * (WB) PCODE FOR INTEGER ARG CASE ! 18038: * JSR PATIN CALL TO BUILD PATTERN NODE ! 18039: * PPM LOC TRANSFER LOC FOR NOT INTEGER OR EXP ! 18040: * PPM LOC TRANSFER LOC FOR INT OUT OF RANGE ! 18041: * (XR) POINTER TO CONSTRUCTED NODE ! 18042: * (XL,WA,WB,WC,IA) DESTROYED ! 18043: * ! 18044: PATIN PRC N,2 ENTRY POINT ! 18045: MOV WA,XL PRESERVE EXPRESSION ARG PCODE ! 18046: JSR GTSMI TRY TO CONVERT ARG AS SMALL INTEGER ! 18047: PPM PTIN2 JUMP IF NOT INTEGER ! 18048: PPM PTIN3 JUMP IF OUT OF RANGE ! 18049: * ! 18050: * COMMON SUCCESSFUL EXIT POINT ! 18051: * ! 18052: PTIN1 JSR PBILD BUILD PATTERN NODE ! 18053: EXI RETURN TO CALLER ! 18054: * ! 18055: * HERE IF ARGUMENT IS NOT AN INTEGER ! 18056: * ! 18057: PTIN2 MOV XL,WB COPY EXPR ARG CASE PCODE ! 18058: BLO (XR),=B$E$$,PTIN1 ALL OK IF EXPRESSION ARG ! 18059: EXI 1 ELSE TAKE ERROR EXIT FOR WRONG TYPE ! 18060: * ! 18061: * HERE FOR ERROR OF OUT OF RANGE INTEGER ARGUMENT ! 18062: * ! 18063: PTIN3 EXI 2 TAKE OUT-OF-RANGE ERROR EXIT ! 18064: ENP END PROCEDURE PATIN ! 18065: EJC ! 18066: * ! 18067: * PATST -- PATTERN CONSTRUCTION FOR ANY,NOTANY, ! 18068: * BREAK,SPAN AND BREAKX PATTERN FUNCTIONS. ! 18069: * ! 18070: * THESE PATTERN FUNCTIONS BUILD SIMILAR TYPES OF NODES AND ! 18071: * THE CONSTRUCTION CODE IS SHARED. SEE FUNCTIONS SECTION ! 18072: * FOR ACTUAL ENTRY POINTS FOR THESE FIVE PATTERN FUNCTIONS. ! 18073: * ! 18074: * 0(XS) STRING ARGUMENT ! 18075: * (WB) PCODE FOR ONE CHAR ARGUMENT ! 18076: * (XL) PCODE FOR MULTI-CHAR ARGUMENT ! 18077: * (WC) PCODE FOR EXPRESSION ARGUMENT ! 18078: * JSR PATST CALL TO BUILD NODE ! 18079: * PPM LOC TRANSFER LOC IF NOT STRING OR EXPR ! 18080: * (XS) POPPED PAST STRING ARGUMENT ! 18081: * (XR) POINTER TO CONSTRUCTED NODE ! 18082: * (XL) DESTROYED ! 18083: * (WA,WB,WC,RA) DESTROYED ! 18084: * ! 18085: * NOTE THAT THERE IS A SPECIAL CALL TO PATST IN THE EVALS ! 18086: * PROCEDURE WITH A SLIGHTLY DIFFERENT FORM. SEE EVALS ! 18087: * FOR DETAILS OF THE FORM OF THIS CALL. ! 18088: * ! 18089: PATST PRC N,1 ENTRY POINT ! 18090: JSR GTSTG CONVERT ARGUMENT AS STRING ! 18091: PPM PATS7 JUMP IF NOT STRING ! 18092: BNE WA,=NUM01,PATS2 JUMP IF NOT ONE CHAR STRING ! 18093: * ! 18094: * HERE FOR ONE CHAR STRING CASE ! 18095: * ! 18096: BZE WB,PATS2 TREAT AS MULTI-CHAR IF EVALS CALL ! 18097: PLC XR POINT TO CHARACTER ! 18098: LCH XR,(XR) LOAD CHARACTER ! 18099: * ! 18100: * COMMON EXIT POINT AFTER SUCCESSFUL CONSTRUCTION ! 18101: * ! 18102: PATS1 JSR PBILD CALL ROUTINE TO BUILD NODE ! 18103: EXI RETURN TO PATST CALLER ! 18104: EJC ! 18105: * ! 18106: * PATST (CONTINUED) ! 18107: * ! 18108: * HERE FOR MULTI-CHARACTER STRING CASE ! 18109: * ! 18110: PATS2 MOV XL,-(XS) SAVE MULTI-CHAR PCODE ! 18111: MOV XR,-(XS) SAVE STRING POINTER ! 18112: MOV CTMSK,WC LOAD CURRENT MASK BIT ! 18113: LSH WC,1 SHIFT TO NEXT POSITION ! 18114: NZB WC,PATS4 SKIP IF POSITION LEFT IN THIS TBL ! 18115: * ! 18116: * HERE WE MUST ALLOCATE A NEW CHARACTER TABLE ! 18117: * ! 18118: MOV *CTSI$,WA SET SIZE OF CTBLK ! 18119: JSR ALLOC ALLOCATE CTBLK ! 18120: MOV XR,R$CTP STORE PTR TO NEW CTBLK ! 18121: MOV =B$CTT,(XR)+ STORE TYPE CODE, BUMP PTR ! 18122: LCT WB,=CFP$A SET NUMBER OF WORDS TO CLEAR ! 18123: MOV BITS0,WC LOAD ALL ZERO BITS ! 18124: * ! 18125: * LOOP TO CLEAR ALL BITS IN TABLE TO ZEROS ! 18126: * ! 18127: PATS3 MOV WC,(XR)+ MOVE WORD OF ZERO BITS ! 18128: BCT WB,PATS3 LOOP TILL ALL CLEARED ! 18129: MOV BITS1,WC SET INITIAL BIT POSITION ! 18130: * ! 18131: * MERGE HERE WITH BIT POSITION AVAILABLE ! 18132: * ! 18133: PATS4 MOV WC,CTMSK SAVE PARM2 (NEW BIT POSITION) ! 18134: MOV (XS)+,XL RESTORE POINTER TO ARGUMENT STRING ! 18135: MOV SCLEN(XL),WB LOAD STRING LENGTH ! 18136: BZE WB,PATS6 JUMP IF NULL STRING CASE ! 18137: LCT WB,WB ELSE SET LOOP COUNTER ! 18138: PLC XL POINT TO CHARACTERS IN ARGUMENT ! 18139: EJC ! 18140: * ! 18141: * PATST (CONTINUED) ! 18142: * ! 18143: * LOOP TO SET BITS IN COLUMN OF TABLE ! 18144: * ! 18145: PATS5 LCH WA,(XL)+ LOAD NEXT CHARACTER ! 18146: WTB WA CONVERT TO BAU OFFSET ! 18147: MOV R$CTP,XR POINT TO CTBLK ! 18148: ADD WA,XR POINT TO CTBLK ENTRY ! 18149: MOV WC,WA COPY BIT MASK ! 18150: ORB CTCHS(XR),WA OR IN BITS ALREADY SET ! 18151: MOV WA,CTCHS(XR) STORE RESULTING BIT STRING ! 18152: BCT WB,PATS5 LOOP TILL ALL BITS SET ! 18153: * ! 18154: * COMPLETE PROCESSING FOR MUTI-CHAR STRING CASE ! 18155: * ! 18156: PATS6 MOV R$CTP,XR LOAD CTBLK PTR AS PARM1 FOR PBILD ! 18157: ZER XL CLEAR GARBAGE PTR IN XL ! 18158: MOV (XS)+,WB LOAD PCODE FOR MULTI-CHAR STR CASE ! 18159: BRN PATS1 BACK TO EXIT (WC=BITSTRING=PARM2) ! 18160: * ! 18161: * HERE IF ARGUMENT IS NOT A STRING ! 18162: * ! 18163: * NOTE THAT THE CALL FROM EVALS CANNOT PASS AN EXPRESSION ! 18164: * SINCE EVALP ALWAYS REEVALUATES EXPRESSIONS. ! 18165: * ! 18166: PATS7 MOV WC,WB SET PCODE FOR EXPRESSION ARGUMENT ! 18167: BLO (XR),=B$E$$,PATS1 JUMP TO EXIT IF EXPRESSION ARG ! 18168: EXI 1 ELSE TAKE WRONG TYPE ERROR EXIT ! 18169: ENP END PROCEDURE PATST ! 18170: EJC ! 18171: * ! 18172: * PBILD -- BUILD PATTERN NODE ! 18173: * ! 18174: * (XR) PARM1 (ONLY IF REQUIRED) ! 18175: * (WB) PCODE FOR NODE ! 18176: * (WC) PARM2 (ONLY IF REQUIRED) ! 18177: * JSR PBILD CALL TO BUILD NODE ! 18178: * (XR) POINTER TO CONSTRUCTED NODE ! 18179: * (WA) DESTROYED ! 18180: * ! 18181: PBILD PRC E,0 ENTRY POINT ! 18182: MOV XR,-(XS) STACK POSSIBLE PARM1 ! 18183: MOV WB,XR COPY PCODE ! 18184: LEI XR LOAD ENTRY POINT ID (BL$PX) ! 18185: BEQ XR,=BL$P1,PBLD1 JUMP IF ONE PARAMETER ! 18186: BEQ XR,=BL$P0,PBLD3 JUMP IF NO PARAMETERS ! 18187: * ! 18188: * HERE FOR TWO PARAMETER CASE ! 18189: * ! 18190: MOV *PCSI$,WA SET SIZE OF P2BLK ! 18191: JSR ALLOC ALLOCATE BLOCK ! 18192: MOV WC,PARM2(XR) STORE SECOND PARAMETER ! 18193: BRN PBLD2 MERGE WITH ONE PARM CASE ! 18194: * ! 18195: * HERE FOR ONE PARAMETER CASE ! 18196: * ! 18197: PBLD1 MOV *PBSI$,WA SET SIZE OF P1BLK ! 18198: JSR ALLOC ALLOCATE NODE ! 18199: * ! 18200: * MERGE HERE FROM TWO PARM CASE ! 18201: * ! 18202: PBLD2 MOV (XS),PARM1(XR) STORE FIRST PARAMETER ! 18203: BRN PBLD4 MERGE WITH NO PARAMETER CASE ! 18204: * ! 18205: * HERE FOR CASE OF NO PARAMETERS ! 18206: * ! 18207: PBLD3 MOV *PASI$,WA SET SIZE OF P0BLK ! 18208: JSR ALLOC ALLOCATE NODE ! 18209: * ! 18210: * MERGE HERE FROM OTHER CASES ! 18211: * ! 18212: PBLD4 MOV WB,(XR) STORE PCODE ! 18213: ICA XS POP FIRST PARAMETER ! 18214: MOV =NDNTH,PTHEN(XR) SET NOTHEN SUCCESSOR POINTER ! 18215: EXI RETURN TO PBILD CALLER ! 18216: ENP END PROCEDURE PBILD ! 18217: EJC ! 18218: * ! 18219: * PCONC -- CONCATENATE TWO PATTERNS ! 18220: * ! 18221: * (XL) PTR TO RIGHT PATTERN ! 18222: * (XR) PTR TO LEFT PATTERN ! 18223: * JSR PCONC CALL TO CONCATENATE PATTERNS ! 18224: * (XR) PTR TO CONCATENATED PATTERN ! 18225: * (XL,WA,WB,WC) DESTROYED ! 18226: * ! 18227: * ! 18228: * TO CONCATENATE TWO PATTERNS, ALL SUCCESSORS IN THE LEFT ! 18229: * PATTERN WHICH POINT TO THE NOTHEN NODE MUST BE CHANGED TO ! 18230: * POINT TO THE RIGHT PATTERN. HOWEVER, THIS MODIFICATION ! 18231: * MUST BE PERFORMED ON A COPY OF THE LEFT ARGUMENT RATHER ! 18232: * THAN THE LEFT ARGUMENT ITSELF, SINCE THE LEFT ARGUMENT ! 18233: * MAY BE POINTED TO BY SOME OTHER VARIABLE VALUE. ! 18234: * ! 18235: * ACCORDINGLY, IT IS NECESSARY TO COPY THE LEFT ARGUMENT. ! 18236: * THIS IS NOT A TRIVIAL PROCESS SINCE WE MUST AVOID COPYING ! 18237: * NODES MORE THAN ONCE AND THE PATTERN IS A GRAPH STRUCTURE ! 18238: * THE FOLLOWING ALGORITHM IS EMPLOYED. ! 18239: * ! 18240: * THE STACK IS USED TO STORE A LIST OF NODES WHICH ! 18241: * HAVE ALREADY BEEN COPIED. THE FORMAT OF THE ENTRIES ON ! 18242: * THIS LIST CONSISTS OF A TWO WORD BLOCK. THE FIRST WORD ! 18243: * IS THE OLD ADDRESS AND THE SECOND WORD IS THE ADDRESS ! 18244: * OF THE COPY. THIS LIST IS SEARCHED BY THE PCOPY ! 18245: * ROUTINE TO AVOID MAKING DUPLICATE COPIES. A TRICK IS ! 18246: * USED TO ACCOMPLISH THE CONCATENATION AT THE SAME TIME. ! 18247: * A SPECIAL ENTRY IS MADE TO START WITH ON THE STACK. THIS ! 18248: * ENTRY RECORDS THAT THE NOTHEN NODE HAS BEEN COPIED ! 18249: * ALREADY AND THE ADDRESS OF ITS COPY IS THE RIGHT PATTERN. ! 18250: * THIS AUTOMATICALLY PERFORMS THE CORRECT REPLACEMENTS. ! 18251: * ! 18252: PCONC PRC E,0 ENTRY POINT ! 18253: ZER -(XS) MAKE ROOM FOR ONE ENTRY AT BOTTOM ! 18254: MOV XS,WC STORE POINTER TO START OF LIST ! 18255: MOV =NDNTH,-(XS) STACK NOTHEN NODE AS OLD NODE ! 18256: MOV XL,-(XS) STORE RIGHT ARG AS COPY OF NOTHEN ! 18257: MOV XS,XT INITIALIZE POINTER TO STACK ENTRIES ! 18258: JSR PCOPY COPY FIRST NODE OF LEFT ARG ! 18259: MOV WA,2(XT) STORE AS RESULT UNDER LIST ! 18260: EJC ! 18261: * ! 18262: * PCONC (CONTINUED) ! 18263: * ! 18264: * THE FOLLOWING LOOP SCANS ENTRIES IN THE LIST AND MAKES ! 18265: * SURE THAT THEIR SUCCESSORS HAVE BEEN COPIED. ! 18266: * ! 18267: PCNC1 BEQ XT,XS,PCNC2 JUMP IF ALL ENTRIES PROCESSED ! 18268: MOV -(XT),XR ELSE LOAD NEXT OLD ADDRESS ! 18269: MOV PTHEN(XR),XR LOAD POINTER TO SUCCESSOR ! 18270: JSR PCOPY COPY SUCCESSOR NODE ! 18271: MOV -(XT),XR LOAD POINTER TO NEW NODE (COPY) ! 18272: MOV WA,PTHEN(XR) STORE PTR TO NEW SUCCESSOR ! 18273: * ! 18274: * NOW CHECK FOR SPECIAL CASE OF ALTERNATION NODE WHERE ! 18275: * PARM1 POINTS TO A NODE AND MUST BE COPIED LIKE PTHEN. ! 18276: * ! 18277: BNE (XR),=P$ALT,PCNC1 LOOP BACK IF NOT ! 18278: MOV PARM1(XR),XR ELSE LOAD POINTER TO ALTERNATIVE ! 18279: JSR PCOPY COPY IT ! 18280: MOV (XT),XR RESTORE PTR TO NEW NODE ! 18281: MOV WA,PARM1(XR) STORE PTR TO COPIED ALTERNATIVE ! 18282: BRN PCNC1 LOOP BACK FOR NEXT ENTRY ! 18283: * ! 18284: * HERE AT END OF COPY PROCESS ! 18285: * ! 18286: PCNC2 MOV WC,XS RESTORE STACK POINTER ! 18287: MOV (XS)+,XR LOAD POINTER TO COPY ! 18288: EXI RETURN TO PCONC CALLER ! 18289: ENP END PROCEDURE PCONC ! 18290: EJC ! 18291: * ! 18292: * PCOPY -- COPY A PATTERN NODE ! 18293: * ! 18294: * PCOPY IS CALLED FROM THE PCONC PROCEDURE TO COPY A SINGLE ! 18295: * PATTERN NODE. THE COPY IS ONLY CARRIED OUT IF THE NODE ! 18296: * HAS NOT BEEN COPIED ALREADY. ! 18297: * ! 18298: * (XR) POINTER TO NODE TO BE COPIED ! 18299: * (XT) PTR TO CURRENT LOC IN COPY LIST ! 18300: * (WC) POINTER TO LIST OF COPIED NODES ! 18301: * JSR PCOPY CALL TO COPY A NODE ! 18302: * (WA) POINTER TO COPY ! 18303: * (WB,XR) DESTROYED ! 18304: * ! 18305: PCOPY PRC N,0 ENTRY POINT ! 18306: MOV XT,WB SAVE XT ! 18307: MOV WC,XT POINT TO START OF LIST ! 18308: * ! 18309: * LOOP TO SEARCH LIST OF NODES COPIED ALREADY ! 18310: * ! 18311: PCOP1 DCA XT POINT TO NEXT ENTRY ON LIST ! 18312: BEQ XR,(XT),PCOP2 JUMP IF MATCH ! 18313: DCA XT ELSE SKIP OVER COPIED ADDRESS ! 18314: BNE XT,XS,PCOP1 LOOP BACK IF MORE TO TEST ! 18315: * ! 18316: * HERE IF NOT IN LIST, PERFORM COPY ! 18317: * ! 18318: MOV (XR),WA LOAD FIRST WORD OF BLOCK ! 18319: JSR BLKLN GET LENGTH OF BLOCK ! 18320: MOV XR,XL SAVE POINTER TO OLD NODE ! 18321: JSR ALLOC ALLOCATE SPACE FOR COPY ! 18322: MOV XL,-(XS) STORE OLD ADDRESS ON LIST ! 18323: MOV XR,-(XS) STORE NEW ADDRESS ON LIST ! 18324: CHK CHECK FOR STACK OVERFLOW ! 18325: MVW MOVE WORDS FROM OLD BLOCK TO COPY ! 18326: MOV (XS),WA LOAD POINTER TO COPY ! 18327: BRN PCOP3 JUMP TO EXIT ! 18328: * ! 18329: * HERE IF WE FIND ENTRY IN LIST ! 18330: * ! 18331: PCOP2 MOV -(XT),WA LOAD ADDRESS OF COPY FROM LIST ! 18332: * ! 18333: * COMMON EXIT POINT ! 18334: * ! 18335: PCOP3 MOV WB,XT RESTORE XT ! 18336: EXI RETURN TO PCOPY CALLER ! 18337: ENP END PROCEDURE PCOPY ! 18338: .IF .CNPF ! 18339: .ELSE ! 18340: EJC ! 18341: * ! 18342: * PRFLR -- PRINT PROFILE ! 18343: * PRFLR IS CALLED TO PRINT THE CONTENTS OF THE PROFILE ! 18344: * TABLE IN A FAIRLY READABLE TABULAR FORMAT. ! 18345: * ! 18346: * JSR PRFLR CALL TO PRINT PROFILE ! 18347: * (WA,IA) DESTROYED ! 18348: * ! 18349: PRFLR PRC E,0 ! 18350: BZE PFDMP,PRFL4 NO PRINTING IF NO PROFILING DONE ! 18351: MOV XR,-(XS) PRESERVE ENTRY XR ! 18352: MOV WB,PFSVW AND ALSO WB ! 18353: JSR PRTPG EJECT ! 18354: MOV =PFMS1,XR LOAD MSG /PROGRAM PROFILE/ ! 18355: JSR PRTFB AND PRINT IT ! 18356: MOV =PFMS2,XR POINT TO FIRST HDR ! 18357: JSR PRTSF PRINT IT ! 18358: MOV =PFMS3,XR SECOND HDR ! 18359: JSR PRTFB ! 18360: ZER WB INITIAL STMT COUNT ! 18361: MOV PFTBL,XR POINT TO TABLE ORIGIN ! 18362: ADD *NUM02,XR BIASS PAST XNBLK HEADER ! 18363: EJC ! 18364: * ! 18365: * PRFLR (CONTINUED) ! 18366: * ! 18367: * LOOP FOR PRINTING TABLE ENTRIES ! 18368: * ! 18369: PRFL1 ICV WB BUMP STMT NR ! 18370: LDI (XR) LOAD NR OF EXECUTIONS ! 18371: IEQ PRFL3 NO PRINTING IF ZERO ! 18372: MOV =PFPD1,PROFS POINT WHERE TO PRINT ! 18373: JSR PRTIN AND PRINT IT ! 18374: ZER PROFS BACK TO START OF LINE ! 18375: MTI WB LOAD STMT NR ! 18376: JSR PRTIN PRINT IT THERE ! 18377: MOV =PFPD2,PROFS AND PAD PAST COUNT ! 18378: LDI CFP$I(XR) LOAD TOTAL EXEC TIME ! 18379: JSR PRTIN PRINT THAT TOO ! 18380: LDI CFP$I(XR) RELOAD TIME ! 18381: MLI INTTH CONVERT TO MICROSEC ! 18382: IOV PRFL2 OMIT NEXT BIT IF OVERFLOW ! 18383: DVI (XR) DIVIDE BY EXECUTIONS ! 18384: MOV =PFPD3,PROFS PAD LAST PRINT ! 18385: JSR PRTIN AND PRINT MCSEC/EXECN ! 18386: * ! 18387: * PRINT A BLANK ! 18388: * ! 18389: PRFL2 JSR PRTFH THATS ANOTHER LINE ! 18390: * ! 18391: * TEST TO SEE IF LOOP FINISHED ! 18392: * ! 18393: PRFL3 ADD *PF$I2,XR BUMP INDEX POINTER ! 18394: BLT WB,PFNTE,PRFL1 LOOP IF MORE STMTS ! 18395: MOV (XS)+,XR RESTORE CALLERS XR ! 18396: MOV PFSVW,WB AND WB TOO ! 18397: * ! 18398: * RETURN POINT ! 18399: * ! 18400: PRFL4 EXI RETURN ! 18401: ENP END OF PRFLR ! 18402: EJC ! 18403: * ! 18404: * PRFLU -- UPDATE AN ENTRY IN THE PROFILE TABLE ! 18405: * ! 18406: * ON ENTRY, KVSTN CONTAINS NR OF STMT TO PROFILE ! 18407: * ! 18408: * JSR PRFLU CALL TO UPDATE ENTRY ! 18409: * (IA) DESTROYED ! 18410: * ! 18411: PRFLU PRC E,0 ! 18412: BNZ PFFNC,PFLU4 SKIP IF JUST ENTERED FUNCTION ! 18413: MOV XR,-(XS) PRESERVE ENTRY XR ! 18414: MOV WA,PFSVW SAVE WA ! 18415: BNZ PFTBL,PFLU2 BRANCH IF TABLE ALLOCATED ! 18416: * ! 18417: * HERE IF SPACE FOR PROFILE TABLE NOT YET ALLOCATED. ! 18418: * CALCULATE SIZE NEEDED, ALLOCATE A STATIC XNBLK, AND ! 18419: * INITIALIZE IT ALL TO ZERO. ! 18420: * THE TIME TAKEN FOR THIS WILL BE ATTRIBUTED TO THE CURRENT ! 18421: * STATEMENT (ASSIGNMENT TO KEYWD PROFILE), BUT SINCE THE ! 18422: * TIMING FOR THIS STATEMENT IS UP THE POLE ANYWAY, THIS ! 18423: * DOESNT REALLY MATTER... ! 18424: * ! 18425: SUB =NUM01,PFNTE ADJUST FOR EXTRA COUNT ! 18426: MTI PFI2A CONVRT ENTRY SIZE TO INT ! 18427: STI PFSTE AND STORE SAFELY FOR LATER ! 18428: MTI PFNTE LOAD TABLE LENGTH AS INTEGER ! 18429: MLI PFSTE MULTIPLY BY ENTRY SIZE ! 18430: MFI WA GET BACK ADDRESS-STYLE ! 18431: ADD =NUM02,WA ADD ON 2 WORD OVERHEAD ! 18432: WTB WA CONVERT THE WHOLE LOT TO BYTES ! 18433: JSR ALOST GIMME THE SPACE ! 18434: MOV XR,PFTBL SAVE BLOCK POINTER ! 18435: MOV =B$XNT,(XR)+ PUT BLOCK TYPE AND ... ! 18436: MOV WA,(XR)+ ... LENGTH INTO HEADER ! 18437: MFI WA GET BACK NR OF WDS IN DATA AREA ! 18438: LCT WA,WA LOAD THE COUNTER ! 18439: * ! 18440: * LOOP HERE TO ZERO THE BLOCK DATA ! 18441: * ! 18442: PFLU1 ZER (XR)+ BLANK A WORD ! 18443: BCT WA,PFLU1 AND ALL THE REST ! 18444: EJC ! 18445: * ! 18446: * PRFLU (CONTINUED) ! 18447: * ! 18448: * END OF ALLOCATION. MERGE BACK INTO ROUTINE ! 18449: * ! 18450: PFLU2 MTI KVSTN LOAD NR OF STMT JUST ENDED ! 18451: SBI INTV1 MAKE INTO INDEX OFFSET ! 18452: MLI PFSTE MAKE OFFSET OF TABLE ENTRY ! 18453: MFI WA CONVERT TO ADDRESS ! 18454: WTB WA GET AS BAUS ! 18455: ADD *NUM02,WA OFFSET INCLUDES TABLE HEADER ! 18456: MOV PFTBL,XR GET TABLE START ! 18457: BGE WA,NUM01(XR),PFLU3 IF OUT OF TABLE, SKIP IT ! 18458: ADD WA,XR ELSE POINT TO ENTRY ! 18459: LDI (XR) GET NR OF EXECUTIONS SO FAR ! 18460: ADI INTV1 NUDGE UP ONE ! 18461: STI (XR) AND PUT BACK ! 18462: JSR SYSTM GET TIME NOW ! 18463: STI PFETM STASH ENDING TIME ! 18464: SBI PFSTM SUBTRACT START TIME ! 18465: ADI CFP$I(XR) ADD CUMULATIVE TIME SO FAR ! 18466: STI CFP$I(XR) AND PUT BACK NEW TOTAL ! 18467: LDI PFETM LOAD END TIME OF THIS STMT ... ! 18468: STI PFSTM ... WHICH IS START TIME OF NEXT ! 18469: * ! 18470: * RETURN POINT ! 18471: * ! 18472: PFLU3 MOV (XS)+,XR RESTORE CALLERS XR ! 18473: MOV PFSVW,WA RESTORE WA ! 18474: EXI AND RETURN ! 18475: * ! 18476: * HERE IF PROFILE IS SUPPRESSED BECAUSE A PROGRAM DEFINED ! 18477: * FUNCTION IS ABOUT TO BE ENTERED, AND SO THE CURRENT STMT ! 18478: * HAS NOT YET FINISHED ! 18479: * ! 18480: PFLU4 ZER PFFNC RESET THE CONDITION FLAG ! 18481: EXI AND IMMEDIATE RETURN ! 18482: ENP END OF PROCEDURE PRFLU ! 18483: .FI ! 18484: EJC ! 18485: * ! 18486: * PRPAR -- PROCESS PRINT PARAMETERS ! 18487: * ! 18488: * JSR PRPAR CALL TO PROCESS PRINT PARAMETERS ! 18489: * (XR,WA,WB,WC) DESTROYED ! 18490: * ! 18491: PRPAR PRC E,0 ENTRY POINT ! 18492: MOV XL,-(XS) SAVE XL ! 18493: JSR SYSPP GET PRINT PARAMETERS ! 18494: BNZ WB,PRPA1 JUMP IF LINES/PAGE SPECIFIED ! 18495: MOV =CFP$M,WB ELSE USE A LARGE VALUE ! 18496: RSH WB,1 BUT NOT TOO LARGE ! 18497: * ! 18498: * STORE LINE COUNT/PAGE ! 18499: * ! 18500: PRPA1 MOV WB,LSTNP STORE NUMBER OF LINES/PAGE ! 18501: MOV WB,LSTLC PRETEND PAGE IS FULL INITIALLY ! 18502: ZER LSTPG CLEAR PAGE NUMBER ! 18503: BZE PRLEN,PRPA2 SKIP IF NOT SYSXI RESUMPTION ! 18504: BHI WA,PRLEN,PRPA3 SKIP IF BIGGER THAN PRIOR BFRS ! 18505: * ! 18506: * STORE PRINT BUFFER LENGTH ! 18507: * ! 18508: PRPA2 MOV WA,PRLEN STORE VALUE ! 18509: * ! 18510: * CHECK TERMINAL BUFFER SIZE ! 18511: * ! 18512: PRPA3 BZE TTLEN,PRPA4 SKIP IF NOT SYSXI RESUMPTION ! 18513: BHI XL,TTLEN,PRPA5 SKIP IF TOO BIG ! 18514: * ! 18515: * STORE TERMINAL BUFFER LENGTH ! 18516: * ! 18517: PRPA4 MOV XL,TTLEN BFR LENGTH ! 18518: * ! 18519: * PROCESS BITS OPTIONS ! 18520: * ! 18521: PRPA5 MOV BITS1,WB BIT 1 MASK ! 18522: ANB WC,WB GET BIT ! 18523: MOV WB,TTINS INPUT FROM TERMINAL FLAG ! 18524: MOV BITS2,WB BIT 2 MASK ! 18525: ANB WC,WB GET BIT ! 18526: MOV WB,TTOUS STD OUTPUT TO TERMINAL FLAG ! 18527: MOV TTLEN,TTERL ERRORS TO TERML IF AVAILABLE ! 18528: MOV PRLEN,PRAVL NOTE IF A PRINT FILE IS AVAILABLE ! 18529: ZRB WB,PRPA6 IF FLAG SET, CLEAR TTERL SINCE ... ! 18530: ZER TTERL ... TERML GETS ALL OUTPUT ALREADY ! 18531: MOV TTLEN,TTOUS REGULAR O/P TO TERML IF AVAILABLE ! 18532: MOV TTLEN,PRLEN REVISED PRINT BUFFER LENGTH ! 18533: ZER TTLEN DONT NEED SEPARATE TERML BUFFER ! 18534: EJC ! 18535: * ! 18536: * PRPAR (CONTINUED) ! 18537: * ! 18538: * GET OFFSET TO /PAGE NN/ PART OF HEADER ! 18539: * ! 18540: PRPA6 MOV PRLEN,WA STD BFR LENGTH ! 18541: BNZ WA,PRPA7 USE IF NON-ZERO ! 18542: MOV TTLEN,WA ELSE TRY TERMINAL ! 18543: BZE WA,PRPA8 GIVE UP IF ZERO ALSO ! 18544: * ! 18545: * GET OFFSET ! 18546: * ! 18547: PRPA7 MOV WA,PRLEN STORE AS BUFFER LENGTH ! 18548: SUB =NUM08,WA JUST BEFORE END OF LINE ! 18549: MOV WA,LSTPO KEEP IT ! 18550: MOV TTOUS,WB CONSTRUCT VALUE FOR ... ! 18551: ORB PRAVL,WB ... USE IN DECIDING WHETHER TO ... ! 18552: MOV WB,PRPUT ... PUT STRINGS IN OUTPUT BUFFER ! 18553: * ! 18554: * MORE BITS ! 18555: * ! 18556: PRPA8 MOV BITS3,WB BIT 3 MASK ! 18557: ANB WC,WB GET -NOLIST BIT ! 18558: ZRB WB,PRPA9 SKIP IF CLEAR ! 18559: ZER CSWLS SET -NOLIST ! 18560: * ! 18561: * MORE BITS ! 18562: * ! 18563: PRPA9 MOV BITS4,WB BIT 4 MASK ! 18564: ANB WC,WB GET BIT ! 18565: MOV WB,CPSTS FLAG FOR COMPILE STATS SUPPRESSN. ! 18566: MOV BITS5,WB BIT 5 MASK ! 18567: ANB WC,WB GET BIT ! 18568: MOV WB,EXSTS FLAG FOR EXEC STATS SUPPRESSION ! 18569: MOV BITS6,WB BIT 6 MASK ! 18570: ANB WC,WB GET BIT ! 18571: MOV WB,NOXEQ SET NOEXECUTE IF NON-ZERO ! 18572: MOV BITS7,WB BIT 7 MASK ! 18573: ANB WC,WB GET BIT ! 18574: ZRB WB,PRP10 SKIP IF NOT SET ! 18575: ZER TTERL CLEAR ERRORS TO TERML IF SET ! 18576: * ! 18577: * MORE BITS ! 18578: * ! 18579: PRP10 MOV BITS8,WB BIT 8 MASK ! 18580: ANB WC,WB GET BIT ! 18581: MOV WB,HEADN SYSID HEADERS INCLUDE/OMIT FLAG ! 18582: MOV BITS9,WB BIT 9 MASK ! 18583: ANB WC,WB GET BIT ! 18584: MOV WB,PRSTO STANDARD LISTING FLAG ! 18585: MOV BIT10,WB BIT 10 MASK ! 18586: ANB WC,WB GET BIT ! 18587: MOV WB,PRECL EXTENDED LISTING OPTION ! 18588: MOV (XS)+,XL RESTORE XL ! 18589: EXI RETURN ! 18590: ENP END PROCEDURE PRPAR ! 18591: EJC ! 18592: * ! 18593: * PRTCF -- PRINT CHAR TO STD PRINTER AND FLUSH BFR ! 18594: * ! 18595: * (WA) CHAR TO PRINT ! 18596: * JSR PRTCF CALL TO PRINT AND FLUSH ! 18597: * ! 18598: PRTCF PRC E,0 ENTRY POINT ! 18599: JSR PRTCH PRINT CHARACTER ! 18600: JSR PRTFH FLUSH BUFFER ! 18601: EXI RETURN TO CALLER ! 18602: ENP END PROCEDURE PRTCF ! 18603: * ! 18604: * PRTCH -- PRINT A CHARACTER ON STANDARD PRINTER ! 18605: * ! 18606: * PRTCH IS USED TO PRINT A SINGLE CHARACTER ! 18607: * ! 18608: * (WA) CHARACTER TO BE PRINTED ! 18609: * JSR PRTCH CALL TO PRINT CHARACTER ! 18610: * ! 18611: PRTCH PRC E,0 ENTRY POINT ! 18612: BZE PRLEN,PTCH2 SKIP IF NO PRINT FILE ! 18613: MOV XR,-(XS) SAVE XR ! 18614: BNE PROFS,PRLEN,PTCH1 JUMP IF ROOM IN BUFFER ! 18615: JSR PRTFH ELSE PRINT THIS LINE ! 18616: * ! 18617: * HERE AFTER MAKING SURE WE HAVE ROOM ! 18618: * ! 18619: PTCH1 MOV PRBUF,XR POINT TO PRINT BUFFER ! 18620: PSC XR,PROFS POINT TO NEXT CHARACTER LOCATION ! 18621: SCH WA,(XR) STORE NEW CHARACTER ! 18622: CSC XR COMPLETE STORE CHARACTERS ! 18623: ICV PROFS BUMP POINTER ! 18624: MOV (XS)+,XR RESTORE ENTRY XR ! 18625: * ! 18626: * RETURN POINT ! 18627: * ! 18628: PTCH2 EXI RETURN TO PRTCH CALLER ! 18629: ENP END PROCEDURE PRTCH ! 18630: * ! 18631: * PRTFB -- PRINT STRING, FLUSH BFR AND PRINT BLANK LINE ! 18632: * ! 18633: * (XR) STRING TO PRINT ! 18634: * JSR PRTFB CALL FOR PRINT FLUSH AND BLANK ! 18635: * ! 18636: PRTFB PRC E,0 ENTRY POINT ! 18637: JSR PRTSF PRINT AND FLUSH ! 18638: JSR PRTFH PRINT BLANK ! 18639: EXI RETURN TO CALLER ! 18640: ENP END PROCEDURE PRTFB ! 18641: EJC ! 18642: * ! 18643: * PRTFH -- FLUSH STANDARD PRINT BUFFER ! 18644: * ! 18645: * PRTFH PRINTS THE CONTENTS OF THE PRINT BUFFER, RESETS ! 18646: * THE BUFFER TO ALL BLANKS AND RESETS THE PRINT POINTER. ! 18647: * ON ITS FIRST CALL IT MAY PRINT LISTING HEADERS. ! 18648: * IF TTLST IS NON-ZERO, IT COPIES PRINT BUFFER TO ! 18649: * TERMINAL AND FLUSHES THIS ALSO. ! 18650: * ! 18651: * JSR PRTFH CALL TO FLUSH BUFFER ! 18652: * ! 18653: PRTFH PRC R,0 ENTRY POINT ! 18654: BNZ HEADP,PTFH1 WERE HEADERS PRINTED ! 18655: JSR PRTPS NO - PRINT THEM ! 18656: * ! 18657: * HEADERS DONE ! 18658: * ! 18659: PTFH1 BZE PRLEN,PTFH4 SKIP IF NO OUTPUT POSSIBLE ! 18660: MOV XL,-(XS) SAVE XL ! 18661: MOV XR,-(XS) SAVE XR ! 18662: MOV WA,-(XS) SAVE WA ! 18663: MOV WC,-(XS) SAVE WC ! 18664: MOV PRBUF,XR LOAD POINTER TO BUFFER ! 18665: MOV PROFS,WC LOAD NUMBER OF CHARS IN BUFFER ! 18666: BNZ PRAVL,PTFH5 SKIP IF PRINT FILE AVAILABLE ! 18667: BNZ TTOUS,PTFH2 SKIP IF STD OUTPUT TO TERML ! 18668: BZE TTLST,PTFH3 LAST POSSIBILITY IS ERROR TO TERML ! 18669: * ! 18670: * SEND TO TERMINAL ! 18671: * ! 18672: PTFH2 JSR SYSPI PRINT TO TERMINAL ! 18673: PPM PTFH6 FAIL ! 18674: PPM EROSI ERROR ! 18675: EJC ! 18676: * PRTFH (CONTINUED) ! 18677: * ! 18678: * BLANK BUFFER ! 18679: * ! 18680: PTFH3 MOV PRBLK,XL POINT TO BLANKING STRING ! 18681: MOV PRCHS,XR POINT TO BUFFER ! 18682: MOV PRCMV,WA COUNT OF BAUS TO MOVE ! 18683: MVW MOVE BLANKS INTO BUFFER ! 18684: ZER PROFS RESET OFFSET ! 18685: MOV (XS)+,WC RESTORE WC ! 18686: MOV (XS)+,WA RECOVER WA ! 18687: MOV (XS)+,XR RESTORE XR ! 18688: MOV (XS)+,XL RESTORE XL ! 18689: * ! 18690: * RETURN POINT ! 18691: * ! 18692: PTFH4 EXI RETURN TO CALLER ! 18693: * ! 18694: * HERE FOR REGULAR PRINT FILE ! 18695: * ! 18696: PTFH5 JSR SYSPR CALL SYSTEM PRINT ROUTINE ! 18697: PPM PTFH6 JUMP IF FAILED ! 18698: PPM EROSI STOP IF ERROR ! 18699: BZE TTLST,PTFH3 SKIP IF NO COPY TO TERMINAL ! 18700: MOV PROFS,SCLEN(XR) SET STRING LENGTH FOR PTTST ! 18701: JSR PTTST COPY STD BUFFER TO TERML BFR ! 18702: JSR PTTFH FLUSH IT ! 18703: MOV PRLEN,SCLEN(XR) RESTORE BUFFER LENGTH ! 18704: BRN PTFH3 MERGE ! 18705: * ! 18706: * A FAILURE SUCH AS FILE OVERFILLED OCCURRED ! 18707: * ! 18708: PTFH6 BZE STAGX,PTFH3 IGNORE IF COMPILE TIME ! 18709: BRN EXFAL ELSE CAUSE STMT FAILURE ! 18710: ENP END PROCEDURE PRTFH ! 18711: EJC ! 18712: * ! 18713: * PRTIN -- PRINT AN INTEGER ! 18714: * ! 18715: * PRTIN PRINTS THE INTEGER VALUE WHICH IS IN THE INTEGER ! 18716: * ACCUMULATOR. BLOCKS BUILT IN DYNAMIC STORAGE ! 18717: * DURING THIS PROCESS ARE IMMEDIATELY DELETED. ! 18718: * ! 18719: * (IA) INTEGER VALUE TO BE PRINTED ! 18720: * JSR PRTIN CALL TO PRINT INTEGER ! 18721: * (IA,RA) DESTROYED ! 18722: * ! 18723: PRTIN PRC E,0 ENTRY POINT ! 18724: MOV XR,-(XS) SAVE XR ! 18725: JSR ICBLD BUILD INTEGER BLOCK ! 18726: BLO XR,DNAMB,PRTI1 JUMP IF ICBLK BELOW DYNAMIC ! 18727: BHI XR,DNAMP,PRTI1 JUMP IF ABOVE DYNAMIC ! 18728: MOV XR,DNAMP IMMEDIATELY DELETE IT ! 18729: * ! 18730: * DELETE ICBLK FROM DYNAMIC STORE ! 18731: * ! 18732: PRTI1 MOV XR,-(XS) STACK PTR FOR GTSTG ! 18733: JSR GTSTG CONVERT TO STRING ! 18734: PPM CONVERT ERROR IS IMPOSSIBLE ! 18735: MOV XR,DNAMP RESET POINTER TO DELETE SCBLK ! 18736: JSR PRTST PRINT INTEGER STRING ! 18737: MOV (XS)+,XR RESTORE ENTRY XR ! 18738: EXI RETURN TO PRTIN CALLER ! 18739: ENP END PROCEDURE PRTIN ! 18740: * ! 18741: * PRTMI -- PRINT MESSAGE AND INTEGER ! 18742: * ! 18743: * PRTMI IS USED TO PRINT MESSAGES TOGETHER WITH AN INTEGER ! 18744: * VALUE STARTING IN COLUMN 15 (USED BY THE ROUTINES AT ! 18745: * THE END OF COMPILATION). ! 18746: * ! 18747: * JSR PRTMI CALL TO PRINT MESSAGE AND INTEGER ! 18748: * ! 18749: PRTMI PRC E,0 ENTRY POINT ! 18750: JSR PRTST PRINT STRING MESSAGE ! 18751: MOV =PRTMF,PROFS SET OFFSET TO COL 15 ! 18752: JSR PRTIN PRINT INTEGER ! 18753: JSR PRTFH PRINT LINE ! 18754: EXI RETURN TO PRTMI CALLER ! 18755: ENP END PROCEDURE PRTMI ! 18756: EJC ! 18757: * ! 18758: * PRTNM -- PRINT VARIABLE NAME ! 18759: * ! 18760: * PRTNM IS USED TO PRINT A CHARACTER REPRESENTATION OF THE ! 18761: * NAME OF A VARIABLE (NOT A VALUE OF DATATYPE NAME) ! 18762: * NAMES OF PSEUDO-VARIABLES MAY NOT BE PASSED TO PRTNM. ! 18763: * ! 18764: * (XL) NAME BASE ! 18765: * (WA) NAME OFFSET ! 18766: * JSR PRTNM CALL TO PRINT NAME ! 18767: * (WB,WC,RA) DESTROYED ! 18768: * ! 18769: PRTNM PRC R,0 ENTRY POINT (RECURSIVE, SEE PRTVL) ! 18770: MOV WA,-(XS) SAVE WA (OFFSET IS COLLECTABLE) ! 18771: MOV XR,-(XS) SAVE ENTRY XR ! 18772: MOV XL,-(XS) SAVE NAME BASE ! 18773: BHI XL,STATE,PRN02 JUMP IF NOT NATURAL VARIABLE ! 18774: * ! 18775: * HERE FOR NATURAL VARIABLE NAME, RECOGNIZED BY THE FACT ! 18776: * THAT THE NAME BASE POINTS INTO THE STATIC AREA. ! 18777: * ! 18778: MOV XL,XR POINT TO VRBLK ! 18779: JSR PRTVN PRINT NAME OF VARIABLE ! 18780: * ! 18781: * COMMON EXIT POINT ! 18782: * ! 18783: PRN01 MOV (XS)+,XL RESTORE NAME BASE ! 18784: MOV (XS)+,XR RESTORE ENTRY VALUE OF XR ! 18785: MOV (XS)+,WA RESTORE WA ! 18786: EXI RETURN TO PRTNM CALLER ! 18787: * ! 18788: * HERE FOR CASE OF NON-NATURAL VARIABLE ! 18789: * ! 18790: PRN02 MOV WA,WB COPY NAME OFFSET ! 18791: BNE (XL),=B$PDT,PRN03 JUMP IF ARRAY OR TABLE ! 18792: * ! 18793: * FOR PROGRAM DEFINED DATATYPE, PRT FLD NAME, LEFT PAREN ! 18794: * ! 18795: MOV PDDFP(XL),XR LOAD POINTER TO DFBLK ! 18796: ADD WA,XR ADD NAME OFFSET ! 18797: MOV PDFOF(XR),XR LOAD VRBLK POINTER FOR FIELD ! 18798: JSR PRTVN PRINT FIELD NAME ! 18799: MOV =CH$PP,WA LOAD LEFT PAREN ! 18800: JSR PRTCH PRINT CHARACTER ! 18801: EJC ! 18802: * ! 18803: * PRTNM (CONTINUED) ! 18804: * ! 18805: * NOW WE PRINT AN IDENTIFYING NAME FOR THE OBJECT IF ONE ! 18806: * CAN BE FOUND. THE FOLLOWING CODE SEARCHES FOR A NATURAL ! 18807: * VARIABLE WHICH CONTAINS THIS OBJECT AS VALUE. IF SUCH A ! 18808: * VARIABLE IS FOUND, ITS NAME IS PRINTED, ELSE THE VALUE ! 18809: * OF THE OBJECT (AS PRINTED BY PRTVL) IS USED INSTEAD. ! 18810: * ! 18811: * FIRST WE POINT TO THE PARENT TBBLK IF THIS IS THE CASE OF ! 18812: * A TABLE ELEMENT. TO DO THIS, CHASE DOWN THE TRNXT CHAIN. ! 18813: * ! 18814: PRN03 BNE (XL),=B$TET,PRN04 JUMP IF WE GOT THERE (OR NOT TE) ! 18815: MOV TENXT(XL),XL ELSE MOVE OUT ON CHAIN ! 18816: BRN PRN03 AND LOOP BACK ! 18817: * ! 18818: * NOW WE ARE READY FOR THE SEARCH. TO SPEED THINGS UP IN ! 18819: * THE CASE OF CALLS FROM DUMP WHERE THE SAME NAME BASE ! 18820: * WILL OCCUR REPEATEDLY WHILE DUMPING AN ARRAY OR TABLE, ! 18821: * WE REMEMBER THE LAST VRBLK POINTER FOUND IN PRNMV. SO ! 18822: * FIRST CHECK TO SEE IF WE HAVE THIS ONE AGAIN. ! 18823: * ! 18824: PRN04 MOV PRNMV,XR POINT TO VRBLK WE FOUND LAST TIME ! 18825: MOV HSHTB,WA POINT TO HASH TABLE IN CASE NOT ! 18826: BRN PRN07 JUMP INTO SEARCH FOR SPECIAL CHECK ! 18827: * ! 18828: * LOOP THROUGH HASH SLOTS ! 18829: * ! 18830: PRN05 MOV WA,XR COPY SLOT POINTER ! 18831: ICA WA BUMP SLOT POINTER ! 18832: SUB *VRNXT,XR INTRODUCE STANDARD VRBLK OFFSET ! 18833: * ! 18834: * LOOP THROUGH VRBLKS ON ONE HASH CHAIN ! 18835: * ! 18836: PRN06 MOV VRNXT(XR),XR POINT TO NEXT VRBLK ON HASH CHAIN ! 18837: * ! 18838: * MERGE HERE FIRST TIME TO CHECK BLOCK WE FOUND LAST TIME ! 18839: * ! 18840: PRN07 MOV XR,WC COPY VRBLK POINTER ! 18841: BZE WC,PRN09 JUMP IF CHAIN END (OR PRNMV ZERO) ! 18842: EJC ! 18843: * ! 18844: * PRTNM (CONTINUED) ! 18845: * ! 18846: * LOOP TO FIND VALUE (CHASE DOWN POSSIBLE TRBLK CHAIN) ! 18847: * ! 18848: PRN08 MOV VRVAL(XR),XR LOAD VALUE ! 18849: BEQ (XR),=B$TRT,PRN08 LOOP IF THAT WAS A TRBLK ! 18850: * ! 18851: * NOW WE HAVE THE VALUE, IS THIS THE BLOCK WE WANT ! 18852: * ! 18853: BEQ XR,XL,PRN10 JUMP IF THIS MATCHES THE NAME BASE ! 18854: MOV WC,XR ELSE POINT BACK TO THAT VRBLK ! 18855: BRN PRN06 AND LOOP BACK ! 18856: * ! 18857: * HERE TO MOVE TO NEXT HASH SLOT ! 18858: * ! 18859: PRN09 BLT WA,HSHTE,PRN05 LOOP BACK IF MORE TO GO ! 18860: MOV XL,XR ELSE NOT FOUND, COPY VALUE POINTER ! 18861: JSR PRTVL PRINT VALUE ! 18862: BRN PRN11 AND MERGE AHEAD ! 18863: * ! 18864: * HERE WHEN WE FIND A MATCHING ENTRY ! 18865: * ! 18866: PRN10 MOV WC,XR COPY VRBLK POINTER ! 18867: MOV XR,PRNMV SAVE FOR NEXT TIME IN ! 18868: JSR PRTVN PRINT VARIABLE NAME ! 18869: * ! 18870: * MERGE HERE IF NO ENTRY FOUND ! 18871: * ! 18872: PRN11 MOV (XL),WC LOAD FIRST WORD OF NAME BASE ! 18873: BNE WC,=B$PDT,PRN13 JUMP IF NOT PROGRAM DEFINED ! 18874: * ! 18875: * FOR PROGRAM DEFINED DATATYPE, ADD RIGHT PAREN AND EXIT ! 18876: * ! 18877: MOV =CH$RP,WA LOAD RIGHT PAREN, MERGE ! 18878: * ! 18879: * MERGE HERE TO PRINT FINAL RIGHT PAREN OR BRACKET ! 18880: * ! 18881: PRN12 JSR PRTCH PRINT FINAL CHARACTER ! 18882: MOV WB,WA RESTORE NAME OFFSET ! 18883: BRN PRN01 MERGE BACK TO EXIT ! 18884: EJC ! 18885: * ! 18886: * PRTNM (CONTINUED) ! 18887: * ! 18888: * HERE FOR ARRAY OR TABLE ! 18889: * ! 18890: PRN13 MOV =CH$BB,WA LOAD LEFT BRACKET ! 18891: JSR PRTCH AND PRINT IT ! 18892: MOV (XS),XL RESTORE BLOCK POINTER ! 18893: MOV (XL),WC LOAD TYPE WORD AGAIN ! 18894: BNE WC,=B$TET,PRN15 JUMP IF NOT TABLE ! 18895: * ! 18896: * HERE FOR TABLE, PRINT SUBSCRIPT VALUE ! 18897: * ! 18898: MOV TESUB(XL),XR LOAD SUBSCRIPT VALUE ! 18899: MOV WB,XL SAVE NAME OFFSET ! 18900: JSR PRTVL PRINT SUBSCRIPT VALUE ! 18901: MOV XL,WB RESTORE NAME OFFSET ! 18902: * ! 18903: * MERGE HERE FROM ARRAY CASE TO PRINT RIGHT BRACKET ! 18904: * ! 18905: PRN14 MOV =CH$RB,WA LOAD RIGHT BRACKET ! 18906: BRN PRN12 MERGE BACK TO PRINT IT ! 18907: * ! 18908: * HERE FOR ARRAY OR VECTOR, TO PRINT SUBSCRIPT(S) ! 18909: * ! 18910: PRN15 MOV WB,WA COPY NAME OFFSET ! 18911: BTW WA CONVERT TO WORDS ! 18912: BEQ WC,=B$ART,PRN16 JUMP IF ARBLK ! 18913: * ! 18914: * HERE FOR VECTOR ! 18915: * ! 18916: SUB =VCVLB,WA ADJUST FOR STANDARD FIELDS ! 18917: MTI WA MOVE TO INTEGER ACCUM ! 18918: JSR PRTIN PRINT LINEAR SUBSCRIPT ! 18919: BRN PRN14 MERGE BACK FOR RIGHT BRACKET ! 18920: EJC ! 18921: * ! 18922: * PRTNM (CONTINUED) ! 18923: * ! 18924: * HERE FOR ARRAY. FIRST CALCULATE ABSOLUTE SUBSCRIPT ! 18925: * OFFSETS BY SUCCESSIVE DIVISIONS BY THE DIMENSION VALUES. ! 18926: * THIS MUST BE DONE RIGHT TO LEFT SINCE THE ELEMENTS ARE ! 18927: * STORED ROW-WISE. THE SUBSCRIPTS ARE STACKED AS INTEGERS. ! 18928: * ! 18929: PRN16 MOV AROFS(XL),WC LOAD LENGTH OF BOUNDS INFO ! 18930: ICA WC ADJUST FOR ARPRO FIELD ! 18931: BTW WC CONVERT TO WORDS ! 18932: SUB WC,WA GET LINEAR ZERO-ORIGIN SUBSCRIPT ! 18933: MTI WA GET INTEGER VALUE ! 18934: LCT WA,ARNDM(XL) SET NUM OF DIMENSIONS AS LOOP COUNT ! 18935: ADD AROFS(XL),XL POINT PAST BOUNDS INFORMATION ! 18936: SUB *ARLBD,XL SET OK OFFSET FOR PROPER PTR LATER ! 18937: * ! 18938: * LOOP TO STACK SUBSCRIPT OFFSETS ! 18939: * ! 18940: PRN17 SUB *ARDMS,XL POINT TO NEXT SET OF BOUNDS ! 18941: STI PRNSI SAVE CURRENT OFFSET ! 18942: RMI ARDIM(XL) GET REMAINDER ON DIVIDING BY DIMENS ! 18943: MFI -(XS) STORE ON STACK (ONE WORD) ! 18944: LDI PRNSI RELOAD ARGUMENT ! 18945: DVI ARDIM(XL) DIVIDE TO GET QUOTIENT ! 18946: BCT WA,PRN17 LOOP TILL ALL STACKED ! 18947: ZER XR SET OFFSET TO FIRST SET OF BOUNDS ! 18948: LCT WB,ARNDM(XL) LOAD COUNT OF DIMS TO CONTROL LOOP ! 18949: BRN PRN19 JUMP INTO PRINT LOOP ! 18950: * ! 18951: * LOOP TO PRINT SUBSCRIPTS FROM STACK ADJUSTING BY ADDING ! 18952: * THE APPROPRIATE LOW BOUND VALUE FROM THE ARBLK ! 18953: * ! 18954: PRN18 MOV =CH$CM,WA LOAD A COMMA ! 18955: JSR PRTCH PRINT IT ! 18956: * ! 18957: * MERGE HERE FIRST TIME IN (NO COMMA REQUIRED) ! 18958: * ! 18959: PRN19 MTI (XS)+ LOAD SUBSCRIPT OFFSET AS INTEGER ! 18960: ADD XR,XL POINT TO CURRENT LBD ! 18961: ADI ARLBD(XL) ADD LBD TO GET SIGNED SUBSCRIPT ! 18962: SUB XR,XL POINT BACK TO START OF ARBLK ! 18963: JSR PRTIN PRINT SUBSCRIPT ! 18964: ADD *ARDMS,XR BUMP OFFSET TO NEXT BOUNDS ! 18965: BCT WB,PRN18 LOOP BACK TILL ALL PRINTED ! 18966: BRN PRN14 MERGE BACK TO PRINT RIGHT BRACKET ! 18967: ENP END PROCEDURE PRTNM ! 18968: EJC ! 18969: * ! 18970: * PRTNV -- PRINT NAME VALUE ! 18971: * ! 18972: * PRTNV IS USED BY THE TRACE AND DUMP ROUTINES TO PRINT ! 18973: * A LINE OF THE FORM ! 18974: * ! 18975: * NAME = VALUE ! 18976: * ! 18977: * NOTE THAT THE NAME INVOLVED CAN NEVER BE A PSEUDO-VAR ! 18978: * ! 18979: * (XL) NAME BASE ! 18980: * (WA) NAME OFFSET ! 18981: * JSR PRTNV CALL TO PRINT NAME = VALUE ! 18982: * (WB,WC,RA) DESTROYED ! 18983: * ! 18984: PRTNV PRC E,0 ENTRY POINT ! 18985: JSR PRTNM PRINT ARGUMENT NAME ! 18986: MOV XR,-(XS) SAVE ENTRY XR ! 18987: MOV WA,-(XS) SAVE NAME OFFSET (COLLECTABLE) ! 18988: MOV =TMBEB,XR POINT TO BLANK EQUAL BLANK ! 18989: JSR PRTST PRINT IT ! 18990: MOV XL,XR COPY NAME BASE ! 18991: ADD WA,XR POINT TO VALUE ! 18992: MOV (XR),XR LOAD VALUE POINTER ! 18993: JSR PRTVF PRINT VALUE ! 18994: MOV (XS)+,WA RESTORE NAME OFFSET ! 18995: MOV (XS)+,XR RESTORE ENTRY XR ! 18996: EXI RETURN TO CALLER ! 18997: ENP END PROCEDURE PRTNV ! 18998: EJC ! 18999: * ! 19000: * PRTPG -- PRINT A PAGE THROW ! 19001: * ! 19002: * PRINTS A PAGE THROW OR A FEW BLANK LINES ON THE STANDARD ! 19003: * LISTING FILE DEPENDING ON THE LISTING OPTIONS CHOSEN. ! 19004: * ! 19005: * JSR PRTPG CALL FOR PAGE EJECT ! 19006: * ! 19007: PRTPG PRC E,0 ENTRY POINT ! 19008: BNZ STAGX,PTPG1 SKIP IF EXECUTION TIME ! 19009: BZE LSTLC,PTPG6 RETURN IF TOP OF PAGE ALREADY ! 19010: ZER LSTLC CLEAR LINE COUNT ! 19011: * ! 19012: * CHECK TYPE OF LISTING ! 19013: * ! 19014: PTPG1 MOV XR,-(XS) PRESERVE XR ! 19015: BNZ PRECL,PTPG2 EJECT IF EXTENDED LISTING ! 19016: BZE PRSTD,PTPG3 SKIP IF COMPACT LISTING ! 19017: BNZ TTOUS,PTPG3 SKIP IF LISTING TO TERMINAL ! 19018: * ! 19019: * PERFORM AN EJECT ! 19020: * ! 19021: PTPG2 JSR SYSEP EJECT ! 19022: PPM PTPG4 IGNORE FAILURE ! 19023: PPM EROSI ERROR ! 19024: BRN PTPG4 MERGE ! 19025: * ! 19026: * COMPACT LISTING. ! 19027: * ! 19028: PTPG3 BNZ HEADN,PTPG4 SKIP IF HEADERS OMITTED ! 19029: MOV HEADP,XR REMEMBER HEADP ! 19030: MNZ HEADP SET TO AVOID RECURSIVE PRTPG CALLS ! 19031: JSR PRTFH PRINT BLANK LINE ! 19032: JSR PRTFH PRINT BLANK LINE ! 19033: JSR PRTFH PRINT BLANK LINE ! 19034: MOV =NUM03,LSTLC COUNT BLANK LINES ! 19035: MOV XR,HEADP RESTORE HEADER FLAG ! 19036: EJC ! 19037: * ! 19038: * PRPTG (CONTINUED) ! 19039: * ! 19040: * PRINT THE HEADING ! 19041: * ! 19042: PTPG4 BNZ HEADP,PTPG5 JUMP IF HEADER LISTED ! 19043: MNZ HEADP MARK HEADERS PRINTED ! 19044: BNZ HEADN,PTPG5 SKIP IF HEADERS OMITTED ! 19045: MOV XL,-(XS) KEEP XL ! 19046: MOV =HEADR,XR POINT TO LISTING HEADER ! 19047: JSR PRTST PLACE IT ! 19048: JSR SYSID GET SYSTEM IDENTIFICATION ! 19049: JSR PRTSF APPEND EXTRA CHARS AND PRINT ! 19050: MOV XL,XR EXTRA HEADER LINE ! 19051: JSR PRTFB PLACE IT AND A BLANK ! 19052: JSR PRTFH AND ANOTHER ! 19053: ADD =NUM04,LSTLC FOUR HEADER LINES PRINTED ! 19054: MOV (XS)+,XL RESTORE XL ! 19055: * ! 19056: * MERGE IF HEADER NOT PRINTED ! 19057: * ! 19058: PTPG5 MOV (XS)+,XR RESTORE XR ! 19059: * ! 19060: * RETURN ! 19061: * ! 19062: PTPG6 EXI RETURN ! 19063: ENP END PROCEDURE PRTPG ! 19064: EJC ! 19065: * ! 19066: * PRTPS -- PRINT PAGE WITH TEST FOR STANDARD LISTING OPTION ! 19067: * ! 19068: * IF THE STANDARD LISTING OPTION IS SELECTED, INSIST THAT ! 19069: * AN EJECT BE DONE ! 19070: * ! 19071: * JSR PRTPS CALL FOR EJECT ! 19072: * ! 19073: PRTPS PRC E,0 ENTRY POINT ! 19074: MOV PRSTO,PRSTD COPY OPTION FLAG ! 19075: JSR PRTPG PRINT PAGE ! 19076: ZER PRSTD CLEAR FLAG ! 19077: EXI RETURN ! 19078: ENP END PROCEDURE PRTPS ! 19079: * ! 19080: * PRTSF -- PRINT STRING TO STD PRINTER AND FLUSH BFR ! 19081: * ! 19082: * (XR) STRING TO PRINT ! 19083: * JSR PRTSF CALL TO PRINT AND FLUSH ! 19084: * ! 19085: PRTSF PRC E,0 ENTRY POINT ! 19086: JSR PRTST PRINT STRING ! 19087: JSR PRTFH FLUSH BUFFER ! 19088: EXI RETURN TO CALLER ! 19089: ENP END PROCEDURE PRTSF ! 19090: EJC ! 19091: * ! 19092: * PRTSN -- PRINT STATEMENT NUMBER ! 19093: * ! 19094: * PRTSN IS USED TO INITIATE A PRINT TRACE LINE BY PRINTING ! 19095: * ASTERISKS AND THE CURRENT STATEMENT NUMBER. THE ACTUAL ! 19096: * FORMAT OF THE OUTPUT GENERATED IS. ! 19097: * ! 19098: * ***NNNNN**** III.....IIII ! 19099: * ! 19100: * NNNNN IS THE STATEMENT NUMBER WITH LEADING ZEROS REPLACED ! 19101: * BY ASTERISKS (E.G. *******9****) ! 19102: * ! 19103: * III...III REPRESENTS A VARIABLE LENGTH OUTPUT CONSISTING ! 19104: * OF A NUMBER OF LETTER I CHARACTERS EQUAL TO FNCLEVEL. ! 19105: * ! 19106: * JSR PRTSN CALL TO PRINT STATEMENT NUMBER ! 19107: * (WC) DESTROYED ! 19108: * ! 19109: PRTSN PRC E,0 ENTRY POINT ! 19110: MOV XR,-(XS) SAVE ENTRY XR ! 19111: MOV WA,PRSNA SAVE ENTRY WA ! 19112: MOV =TMASB,XR POINT TO ASTERISKS ! 19113: JSR PRTST PRINT ASTERISKS ! 19114: MOV =NUM04,PROFS POINT INTO MIDDLE OF ASTERISKS ! 19115: MTI KVSTN LOAD STATEMENT NUMBER AS INTEGER ! 19116: JSR PRTIN PRINT INTEGER STATEMENT NUMBER ! 19117: MOV =PRSNF,PROFS POINT PAST ASTERISKS PLUS BLANK ! 19118: MOV KVFNC,XR GET FNCLEVEL ! 19119: MOV =CH$LI,WA SET LETTER I ! 19120: * ! 19121: * LOOP TO GENERATE LETTER I FNCLEVEL TIMES ! 19122: * ! 19123: PRSN1 BZE XR,PRSN2 JUMP IF ALL SET ! 19124: JSR PRTCH ELSE PRINT AN I ! 19125: DCV XR DECREMENT COUNTER ! 19126: BRN PRSN1 LOOP BACK ! 19127: * ! 19128: * MERRE WITH ALL LETTER I CHARACTERS GENERATED ! 19129: * ! 19130: PRSN2 MOV =CH$BL,WA GET BLANK ! 19131: JSR PRTCH PRINT BLANK ! 19132: MOV PRSNA,WA RESTORE ENTRY WA ! 19133: MOV (XS)+,XR RESTORE ENTRY XR ! 19134: EXI RETURN TO PRTSN CALLER ! 19135: ENP END PROCEDURE PRTSN ! 19136: EJC ! 19137: * ! 19138: * PRTST -- PRINT STRING TO STANDARD FILE ! 19139: * ! 19140: * PLACE A STRING OF CHARACTERS IN THE STANDARD PRINT BUFFER ! 19141: * ! 19142: * NOTE THAT THE FIRST WORD OF THE BLOCK (NORMALLY B$SCL) ! 19143: * IS NOT USED AND NEED NOT BE SET CORRECTLY (SEE PRTVN) ! 19144: * IF GLOBAL TTOUS IS NON-ZERO, STRING IS SENT TO TERMINAL ! 19145: * INSTEAD OF STANDARD OUTPUT FILE. ! 19146: * IF GLOBAL TTLST IS NON-ZERO, STRING IS SENT TO ! 19147: * TERMINAL AS WELL AS STANDARD OUTPUT FILE ! 19148: * ! 19149: * (XR) STRING TO BE PRINTED ! 19150: * JSR PRTST CALL TO PRINT STRING ! 19151: * (PROFS) UPDATED PAST CHARS PLACED ! 19152: * ! 19153: PRTST PRC R,0 ENTRY POINT ! 19154: BNZ HEADP,PTST1 WERE HEADERS PRINTED ! 19155: JSR PRTPS NO - PRINT THEM ! 19156: * ! 19157: * HEADERS DEALT WITH ! 19158: * ! 19159: PTST1 BZE PRLEN,PTST7 SKIP IF NO O/P POSSIBLE ! 19160: BNZ PRPUT,PTST2 SKIP IF PUTTING IS OK ! 19161: BZE TTLST,PTST7 SKIP OUT IF NOT ERROR TO TERML ! 19162: * ! 19163: * KEEP REGISTERS ! 19164: * ! 19165: PTST2 MOV WA,PRSVA SAVE WA ! 19166: MOV WB,PRSVB SAVE WB ! 19167: ZER WB SET CHARS PRINTED COUNT TO ZERO ! 19168: * ! 19169: * LOOP TO PRINT SUCCESSIVE LINES FOR LONG STRING ! 19170: * ! 19171: PTST3 MOV SCLEN(XR),WA LOAD STRING LENGTH ! 19172: SUB WB,WA SUBTRACT COUNT OF CHARS ALREADY OUT ! 19173: BZE WA,PTST6 JUMP TO EXIT IF NONE LEFT ! 19174: MOV XL,-(XS) ELSE STACK ENTRY XL ! 19175: MOV XR,-(XS) SAVE ARGUMENT ! 19176: MOV XR,XL COPY FOR EVENTUAL MOVE ! 19177: MOV PRLEN,XR LOAD PRINT BUFFER LENGTH ! 19178: SUB PROFS,XR GET CHARS LEFT IN PRINT BUFFER ! 19179: BNZ XR,PTST4 SKIP IF ROOM LEFT ON THIS LINE ! 19180: JSR PRTFH PRINT THIS LINE ! 19181: MOV PRLEN,XR AND SET FULL WIDTH AVAILABLE ! 19182: EJC ! 19183: * ! 19184: * PRTST (CONTINUED) ! 19185: * ! 19186: * HERE WITH CHARS TO PRINT AND SOME ROOM IN BUFFER ! 19187: * ! 19188: PTST4 BLO WA,XR,PTST5 JUMP IF ROOM FOR REST OF STRING ! 19189: MOV XR,WA ELSE SET TO FILL LINE ! 19190: * ! 19191: * MERGE HERE WITH CHARACTER COUNT IN WA ! 19192: * ! 19193: PTST5 MOV PRBUF,XR POINT TO PRINT BUFFER ! 19194: PLC XL,WB POINT TO LOCATION IN STRING ! 19195: PSC XR,PROFS POINT TO LOCATION IN BUFFER ! 19196: ADD WA,WB BUMP STRING CHARS COUNT ! 19197: ADD WA,PROFS BUMP BUFFER POINTER ! 19198: MVC MOVE CHARACTERS TO BUFFER ! 19199: MOV (XS)+,XR RESTORE ARGUMENT POINTER ! 19200: MOV (XS)+,XL RESTORE ENTRY XL ! 19201: BRN PTST3 LOOP BACK TO TEST FOR MORE ! 19202: * ! 19203: * HERE TO EXIT AFTER PRINTING STRING ! 19204: * ! 19205: PTST6 MOV PRSVB,WB RESTORE ENTRY WB ! 19206: MOV PRSVA,WA RESTORE ENTRY WA ! 19207: * ! 19208: * RETURN POINT ! 19209: * ! 19210: PTST7 EXI RETURN TO PRTST CALLER ! 19211: ENP END PROCEDURE PRTST ! 19212: * ! 19213: * PRTVF -- PLACE A VALUE AND FLUSH STANDARD BUFFER ! 19214: * ! 19215: * (XR) VALUE TO PRINT ! 19216: * JSR PRTVF CALL TO PRINT AND FLUSH ! 19217: * ! 19218: PRTVF PRC E,0 ENTRY POINT ! 19219: JSR PRTVL PLACE VALUE ! 19220: JSR PRTFH FLUSH BUFFER ! 19221: EXI RETURN TO CALLER ! 19222: ENP END PROCEDURE PRTVF ! 19223: EJC ! 19224: * ! 19225: * PRTVL -- PRINT A VALUE ! 19226: * ! 19227: * PRTVL PLACES AN APPROPRIATE CHARACTER REPRESENTATION OF ! 19228: * A DATA VALUE IN THE PRINT BUFFER FOR DUMP/TRACE USE. ! 19229: * ! 19230: * (XR) VALUE TO BE PRINTED ! 19231: * JSR PRTVL CALL TO PRINT VALUE ! 19232: * (WA,WB,WC,RA) DESTROYED ! 19233: * ! 19234: PRTVL PRC R,0 ENTRY POINT, RECURSIVE ! 19235: MOV XL,-(XS) SAVE ENTRY XL ! 19236: MOV XR,-(XS) SAVE ARGUMENT ! 19237: CHK CHECK FOR STACK OVERFLOW ! 19238: * ! 19239: * LOOP BACK HERE AFTER FINDING A TRAP BLOCK (TRBLK) ! 19240: * ! 19241: PRV01 MOV IDVAL(XR),PRVSI COPY IDVAL (IF ANY) ! 19242: MOV (XR),XL LOAD FIRST WORD OF BLOCK ! 19243: LEI XL LOAD ENTRY POINT ID ! 19244: BSW XL,BL$$T,PRV02 SWITCH ON BLOCK TYPE ! 19245: IFF BL$TR,PRV04 TRBLK ! 19246: IFF BL$AR,PRV05 ARBLK ! 19247: IFF BL$IC,PRV08 ICBLK ! 19248: IFF BL$NM,PRV09 NMBLK ! 19249: IFF BL$PD,PRV10 PDBLK ! 19250: .IF .CNRA ! 19251: .ELSE ! 19252: IFF BL$RC,PRV08 RCBLK ! 19253: .FI ! 19254: IFF BL$SC,PRV11 SCBLK ! 19255: IFF BL$SE,PRV12 SEBLK ! 19256: IFF BL$TB,PRV13 TBBLK ! 19257: IFF BL$VC,PRV13 VCBLK ! 19258: .IF .CNBF ! 19259: .ELSE ! 19260: IFF BL$BC,PRV15 BCBLK ! 19261: .FI ! 19262: ESW END OF SWITCH ON BLOCK TYPE ! 19263: * ! 19264: * HERE FOR BLOCKS FOR WHICH WE JUST PRINT DATATYPE NAME ! 19265: * ! 19266: PRV02 JSR DTYPE GET DATATYPE NAME ! 19267: JSR PRTST PRINT DATATYPE NAME ! 19268: * ! 19269: * COMMON EXIT POINT ! 19270: * ! 19271: PRV03 MOV (XS)+,XR RELOAD ARGUMENT ! 19272: MOV (XS)+,XL RESTORE XL ! 19273: EXI RETURN TO PRTVL CALLER ! 19274: * ! 19275: * HERE FOR TRBLK ! 19276: * ! 19277: PRV04 MOV TRVAL(XR),XR LOAD REAL VALUE ! 19278: BRN PRV01 AND LOOP BACK ! 19279: EJC ! 19280: * ! 19281: * PRTVL (CONTINUED) ! 19282: * ! 19283: * HERE FOR ARRAY (ARBLK) ! 19284: * ! 19285: * PRINT ARRAY ( PROTOTYPE ) BLANK NUMBER IDVAL ! 19286: * ! 19287: PRV05 MOV XR,XL PRESERVE ARGUMENT ! 19288: MOV =SCARR,XR POINT TO DATATYPE NAME (ARRAY) ! 19289: JSR PRTST PRINT IT ! 19290: MOV =CH$PP,WA LOAD LEFT PAREN ! 19291: JSR PRTCH PRINT LEFT PAREN ! 19292: ADD AROFS(XL),XL POINT TO PROTOTYPE ! 19293: MOV (XL),XR LOAD PROTOTYPE ! 19294: JSR PRTST PRINT PROTOTYPE ! 19295: * ! 19296: * VCBLK, TBBLK MERGE HERE FOR ) BLANK NUMBER IDVAL ! 19297: * ! 19298: PRV06 MOV =CH$RP,WA LOAD RIGHT PAREN ! 19299: JSR PRTCH PRINT RIGHT PAREN ! 19300: * ! 19301: * PDBLK MERGES HERE TO PRINT BLANK NUMBER IDVAL ! 19302: * ! 19303: PRV07 MOV =CH$BL,WA LOAD BLANK ! 19304: JSR PRTCH PRINT IT ! 19305: MOV =CH$NM,WA LOAD NUMBER SIGN ! 19306: JSR PRTCH PRINT IT ! 19307: MTI PRVSI GET IDVAL ! 19308: JSR PRTIN PRINT ID NUMBER ! 19309: BRN PRV03 BACK TO EXIT ! 19310: * ! 19311: * HERE FOR INTEGER (ICBLK), REAL (RCBLK) ! 19312: * ! 19313: * PRINT CHARACTER REPRESENTATION OF VALUE ! 19314: * ! 19315: PRV08 MOV XR,-(XS) STACK ARGUMENT FOR GTSTG ! 19316: JSR GTSTG CONVERT TO STRING ! 19317: PPM ERROR RETURN IS IMPOSSIBLE ! 19318: JSR PRTST PRINT THE STRING ! 19319: MOV XR,DNAMP DELETE GARBAGE STRING FROM STORAGE ! 19320: BRN PRV03 BACK TO EXIT ! 19321: EJC ! 19322: * ! 19323: * PRTVL (CONTINUED) ! 19324: * ! 19325: * NAME (NMBLK) ! 19326: * ! 19327: * FOR PSEUDO-VARIABLE, JUST PRINT DATATYPE NAME (NAME) ! 19328: * FOR ALL OTHER NAMES, PRINT DOT FOLLOWED BY NAME REP ! 19329: * ! 19330: PRV09 MOV NMBAS(XR),XL LOAD NAME BASE ! 19331: MOV (XL),WA LOAD FIRST WORD OF BLOCK ! 19332: BEQ WA,=B$KVT,PRV02 JUST PRINT NAME IF KEYWORD ! 19333: BEQ WA,=B$EVT,PRV02 JUST PRINT NAME IF EXPRESSION VAR ! 19334: MOV =CH$DT,WA ELSE GET DOT ! 19335: JSR PRTCH AND PRINT IT ! 19336: MOV NMOFS(XR),WA LOAD NAME OFFSET ! 19337: JSR PRTNM PRINT NAME ! 19338: BRN PRV03 BACK TO EXIT ! 19339: * ! 19340: * PROGRAM DATATYPE (PDBLK) ! 19341: * ! 19342: * PRINT DATATYPE NAME CH$BL CH$NM IDVAL ! 19343: * ! 19344: PRV10 JSR DTYPE GET DATATYPE NAME ! 19345: JSR PRTST PRINT DATATYPE NAME ! 19346: BRN PRV07 MERGE BACK TO PRINT ID ! 19347: * ! 19348: * HERE FOR STRING (SCBLK) ! 19349: * ! 19350: * PRINT QUOTE STRING-CHARACTERS QUOTE ! 19351: * ! 19352: PRV11 MOV =CH$SQ,WA LOAD SINGLE QUOTE ! 19353: JSR PRTCH PRINT QUOTE ! 19354: JSR PRTST PRINT STRING VALUE ! 19355: JSR PRTCH PRINT ANOTHER QUOTE ! 19356: BRN PRV03 BACK TO EXIT ! 19357: EJC ! 19358: * ! 19359: * PRTVL (CONTINUED) ! 19360: * ! 19361: * HERE FOR SIMPLE EXPRESSION (SEBLK) ! 19362: * ! 19363: * PRINT ASTERISK VARIABLE-NAME ! 19364: * ! 19365: PRV12 MOV =CH$AS,WA LOAD ASTERISK ! 19366: JSR PRTCH PRINT ASTERISK ! 19367: MOV SEVAR(XR),XR LOAD VARIABLE POINTER ! 19368: JSR PRTVN PRINT VARIABLE NAME ! 19369: BRN PRV03 JUMP BACK TO EXIT ! 19370: * ! 19371: * HERE FOR TABLE (TBBLK) AND ARRAY (VCBLK) ! 19372: * ! 19373: * PRINT DATATYPE ( PROTOTYPE ) BLANK NUMBER IDVAL ! 19374: * ! 19375: PRV13 MOV XR,XL PRESERVE ARGUMENT ! 19376: JSR DTYPE GET DATATYPE NAME ! 19377: JSR PRTST PRINT DATATYPE NAME ! 19378: MOV =CH$PP,WA LOAD LEFT PAREN ! 19379: JSR PRTCH PRINT LEFT PAREN ! 19380: MOV TBLEN(XL),WA LOAD LENGTH OF BLOCK (=VCLEN) ! 19381: BTW WA CONVERT TO WORD COUNT ! 19382: SUB =TBSI$,WA ALLOW FOR STANDARD FIELDS ! 19383: BEQ (XL),=B$TBT,PRV14 JUMP IF TABLE ! 19384: ADD =VCTBD,WA FOR VCBLK, ADJUST SIZE ! 19385: * ! 19386: * PRINT PROTOTYPE ! 19387: * ! 19388: PRV14 MTI WA MOVE AS INTEGER ! 19389: JSR PRTIN PRINT INTEGER PROTOTYPE ! 19390: BRN PRV06 MERGE BACK FOR REST ! 19391: .IF .CNBF ! 19392: .ELSE ! 19393: EJC ! 19394: * ! 19395: * PRTVL (CONTINUED) ! 19396: * ! 19397: * HERE FOR BUFFER (BCBLK) ! 19398: * ! 19399: PRV15 MOV XR,XL PRESERVE ARGUMENT ! 19400: MOV =SCBUF,XR POINT TO DATATYPE NAME (BUFFER) ! 19401: JSR PRTST PRINT IT ! 19402: MOV =CH$PP,WA LOAD LEFT PAREN ! 19403: JSR PRTCH PRINT LEFT PAREN ! 19404: MOV BCBUF(XL),XR POINT TO BFBLK ! 19405: MTI BFALC(XR) LOAD ALLOCATION SIZE ! 19406: JSR PRTIN PRINT IT ! 19407: MOV =CH$CM,WA LOAD COMMA ! 19408: JSR PRTCH PRINT IT ! 19409: MTI BCLEN(XL) LOAD DEFINED LENGTH ! 19410: JSR PRTIN PRINT IT ! 19411: BRN PRV06 MERGE TO FINISH UP ! 19412: .FI ! 19413: ENP END PROCEDURE PRTVL ! 19414: EJC ! 19415: * ! 19416: * PRTVN -- PRINT NATURAL VARIABLE NAME ! 19417: * ! 19418: * PRTVN PRINTS THE NAME OF A NATURAL VARIABLE ! 19419: * ! 19420: * (XR) POINTER TO VRBLK ! 19421: * JSR PRTVN CALL TO PRINT VARIABLE NAME ! 19422: * ! 19423: PRTVN PRC E,0 ENTRY POINT ! 19424: MOV XR,-(XS) STACK VRBLK POINTER ! 19425: ADD *VRSOF,XR POINT TO POSSIBLE STRING NAME ! 19426: BNZ SCLEN(XR),PRVN1 JUMP IF NOT SYSTEM VARIABLE ! 19427: MOV VRSVO(XR),XR POINT TO SVBLK WITH NAME ! 19428: * ! 19429: * MERGE HERE WITH DUMMY SCBLK POINTER IN XR ! 19430: * ! 19431: PRVN1 JSR PRTST PRINT STRING NAME OF VARIABLE ! 19432: MOV (XS)+,XR RESTORE VRBLK POINTER ! 19433: EXI RETURN TO PRTVN CALLER ! 19434: ENP END PROCEDURE PRTVN ! 19435: EJC ! 19436: * ! 19437: * PTTFH -- FLUSH TERMINAL BUFFER ! 19438: * ! 19439: * PRINTS THE CONTENTS OF THE TTY BUFFER, RESETS ! 19440: * THE BUFFER TO ALL BLANKS AND RESETS THE POINTER. ! 19441: * ! 19442: * JSR PTTFH CALL TO FLUSH BUFFER ! 19443: * ! 19444: PTTFH PRC E,0 ENTRY POINT ! 19445: BZE TTLEN,PTTF2 SKIP IF NO TERMINAL ! 19446: MOV XL,-(XS) SAVE XL ! 19447: MOV XR,-(XS) SAVE XR ! 19448: MOV WA,-(XS) SAVE WA ! 19449: MOV WC,-(XS) SAVE WC ! 19450: MOV TTBUF,XR LOAD POINTER TO BUFFER ! 19451: MOV TTOFS,WC LOAD NUMBER OF CHARS IN BUFFER ! 19452: JSR SYSPI CALL SYSTEM PRINT ROUTINE ! 19453: PPM PTTF3 JUMP IF FAILED ! 19454: PPM EROSI STOP IF ERROR ! 19455: * ! 19456: * BLANK BUFFER ! 19457: * ! 19458: PTTF1 MOV TTBLK,XL POINT TO BLANKING STRING ! 19459: MOV TTCHS,XR POINT TO BUFFER ! 19460: MOV TTCMV,WA COUNT OF BAUS TO MOVE ! 19461: MVW MOVE BLANKS INTO BUFFER ! 19462: ZER TTOFS RESET OFFSET ! 19463: MOV (XS)+,WC RESTORE WC ! 19464: MOV (XS)+,WA RECOVER WA ! 19465: MOV (XS)+,XR RESTORE XR ! 19466: MOV (XS)+,XL RESTORE XL ! 19467: * ! 19468: * RETURN POINT ! 19469: * ! 19470: PTTF2 EXI RETURN TO CALLER ! 19471: * ! 19472: * A FAILURE SUCH AS FILE OVERFILLED OCCURRED ! 19473: * ! 19474: PTTF3 BZE STAGX,PTTF1 IGNORE IF COMPILE TIME ! 19475: BRN EXFAL ELSE CAUSE STMT FAILURE ! 19476: ENP END PROCEDURE ! 19477: EJC ! 19478: * ! 19479: * PTTST -- PRINT STRING TO TERMINAL ! 19480: * ! 19481: * PLACE A STRING OF CHARACTERS IN THE TERMINAL BUFFER ! 19482: * ! 19483: * NOTE THAT THE FIRST WORD OF THE BLOCK (NORMALLY B$SCL) ! 19484: * IS NOT USED AND NEED NOT BE SET CORRECTLY (SEE PRTVN) ! 19485: * ! 19486: * (XR) STRING TO BE PRINTED ! 19487: * JSR PTTST CALL TO PRINT STRING ! 19488: * (TTOFS) UPDATED PAST CHARS PLACED ! 19489: * ! 19490: PTTST PRC E,0 ENTRY POINT ! 19491: BZE TTLEN,PTTS5 SKIP IF NO TERMINAL ! 19492: MOV WA,PRTVA SAVE WA ! 19493: MOV WB,PRTVB SAVE WB ! 19494: ZER WB SET CHARS PRINTED COUNT TO ZERO ! 19495: * ! 19496: * LOOP TO PRINT SUCCESSIVE LINES FOR LONG STRING ! 19497: * ! 19498: PTTS1 MOV SCLEN(XR),WA LOAD STRING LENGTH ! 19499: SUB WB,WA SUBTRACT COUNT OF CHARS ALREADY OUT ! 19500: BZE WA,PTTS4 JUMP TO EXIT IF NONE LEFT ! 19501: MOV XL,-(XS) ELSE STACK ENTRY XL ! 19502: MOV XR,-(XS) SAVE ARGUMENT ! 19503: MOV XR,XL COPY FOR EVENTUAL MOVE ! 19504: MOV TTLEN,XR LOAD BUFFER LENGTH ! 19505: SUB TTOFS,XR GET CHARS LEFT IN BUFFER ! 19506: BNZ XR,PTTS2 SKIP IF ROOM LEFT ON THIS LINE ! 19507: JSR PTTFH ELSE PRINT THIS LINE ! 19508: MOV TTLEN,XR AND SET FULL WIDTH AVAILABLE ! 19509: * ! 19510: * HERE WITH CHARS TO PRINT AND SOME ROOM IN BUFFER ! 19511: * ! 19512: PTTS2 BLO WA,XR,PTTS3 JUMP IF ROOM FOR REST OF STRING ! 19513: MOV XR,WA ELSE SET TO FILL LINE ! 19514: * ! 19515: * MERGE HERE WITH CHARACTER COUNT IN WA ! 19516: * ! 19517: PTTS3 MOV TTBUF,XR POINT TO PRINT BUFFER ! 19518: PLC XL,WB POINT TO LOCATION IN STRING ! 19519: PSC XR,TTOFS POINT TO LOCATION IN BUFFER ! 19520: ADD WA,WB BUMP STRING CHARS COUNT ! 19521: ADD WA,TTOFS BUMP BUFFER POINTER ! 19522: MVC MOVE CHARACTERS TO BUFFER ! 19523: MOV (XS)+,XR RESTORE ARGUMENT POINTER ! 19524: MOV (XS)+,XL RESTORE ENTRY XL ! 19525: BRN PTTS1 LOOP BACK TO TEST FOR MORE ! 19526: EJC ! 19527: * ! 19528: * HERE TO EXIT AFTER PRINTING STRING ! 19529: * ! 19530: PTTS4 MOV PRTVB,WB RESTORE ENTRY WB ! 19531: MOV PRTVA,WA RESTORE ENTRY WA ! 19532: * ! 19533: * RETURN POINT ! 19534: * ! 19535: PTTS5 EXI RETURN TO PTTST CALLER ! 19536: ENP END PROCEDURE PTTST ! 19537: .IF .CNRA ! 19538: .ELSE ! 19539: EJC ! 19540: * ! 19541: * RCBLD -- BUILD A REAL BLOCK ! 19542: * ! 19543: * (RA) REAL VALUE FOR RCBLK ! 19544: * JSR RCBLD CALL TO BUILD REAL BLOCK ! 19545: * (XR) POINTER TO RESULT RCBLK ! 19546: * (WA) DESTROYED ! 19547: * ! 19548: RCBLD PRC E,0 ENTRY POINT ! 19549: MOV DNAMP,XR LOAD POINTER TO NEXT AVAILABLE LOC ! 19550: ADD *RCSI$,XR POINT PAST NEW RCBLK ! 19551: BLO XR,DNAME,RCBL1 JUMP IF THERE IS ROOM ! 19552: MOV *RCSI$,WA ELSE LOAD RCBLK LENGTH ! 19553: JSR ALLOC USE STANDARD ALLOCATOR TO GET BLOCK ! 19554: ADD WA,XR POINT PAST BLOCK TO MERGE ! 19555: * ! 19556: * MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED ! 19557: * ! 19558: RCBL1 MOV XR,DNAMP SET NEW POINTER ! 19559: SUB *RCSI$,XR POINT BACK TO START OF BLOCK ! 19560: MOV =B$RCL,(XR) STORE TYPE WORD ! 19561: STR RCVAL(XR) STORE REAL VALUE IN RCBLK ! 19562: EXI RETURN TO RCBLD CALLER ! 19563: ENP END PROCEDURE RCBLD ! 19564: .FI ! 19565: EJC ! 19566: * ! 19567: * READR -- READ NEXT SOURCE IMAGE AT COMPILE TIME ! 19568: * ! 19569: * READR IS USED TO READ THE NEXT SOURCE IMAGE. TO PROCESS ! 19570: * CONTINUATION CARDS PROPERLY, THE COMPILER MUST READ ONE ! 19571: * LINE AHEAD. THUS READR DOES NOT DESTROY THE CURRENT IMAGE ! 19572: * SEE ALSO THE NEXTS ROUTINE WHICH ACTUALLY GETS THE IMAGE. ! 19573: * ! 19574: * THE GLOBAL FLAG RDRER IS SET JUST BEFORE THE READ, AND ! 19575: * CLEARED AFTER IT. THIS IS SO THAT IN THE EVENT SYSRD ! 19576: * OR SYSRI TAKE AN EROSI EXIT, THE ERROR APPENDAGE CAN ! 19577: * RECOGNIZE THE SITUATION AND TAKE APPROPRIATE ACTION. ! 19578: * ! 19579: * JSR READR CALL TO READ NEXT IMAGE ! 19580: * (XR) PTR TO NEXT IMAGE (0 IF NONE) ! 19581: * (R$CNI) COPY OF POINTER ! 19582: * (WA,WB,WC,XL) DESTROYED ! 19583: * ! 19584: READR PRC E,0 ENTRY POINT ! 19585: MOV R$CNI,XR GET PTR TO NEXT IMAGE ! 19586: BNZ XR,READ5 EXIT IF ALREADY READ ! 19587: * ! 19588: * MERGE FROM -COPY EOF TO TRY READ ! 19589: * ! 19590: READ0 BEQ STAGE,=STGIC,READ1 READ IF INITIAL COMPILE ! 19591: BZE R$COP,READ6 ELSE EXIT IF NO -COPY IN FORCE ! 19592: * ! 19593: * ATTEMPT READ ! 19594: * ! 19595: READ1 MOV CSWIN,WA MAX READ LENGTH ! 19596: MNZ RDRER NOTE IN-READR IN CASE EROSI ! 19597: JSR ALOCS ALLOCATE BUFFER ! 19598: BZE TTINS,READ2 SKIP IF STANDARD INPUT FILE ! 19599: JSR SYSRI READ FROM TERMINAL ! 19600: PPM READ7 FAIL ! 19601: PPM EROSI ERROR ! 19602: BRN READ3 MERGE ! 19603: * ! 19604: * READ FROM STANDARD FILE ! 19605: * ! 19606: READ2 JSR SYSRD READ INPUT IMAGE ! 19607: PPM READ7 JUMP IF END OF FILE ! 19608: PPM EROSI ERROR RETURN ! 19609: * ! 19610: * MERGE ! 19611: * ! 19612: READ3 ZER RDRER NOTE NOT-IN-READR FOR ERROR RTN ! 19613: MNZ WB SET TRIMR TO PERFORM TRIM ! 19614: BLE SCLEN(XR),CSWIN,READ4 USE SMALLER OF STRING LNTH.. ! 19615: MOV CSWIN,SCLEN(XR) ... AND XXX OF -INXXX ! 19616: * ! 19617: * PERFORM THE TRIM ! 19618: * ! 19619: READ4 JSR TRIMR TRIM TRAILING BLANKS ! 19620: * ! 19621: * MERGE HERE AFTER READ ! 19622: * ! 19623: READ5 MOV XR,R$CNI STORE COPY OF POINTER ! 19624: * ! 19625: * MERGE HERE IF NO READ ATTEMPTED ! 19626: * ! 19627: READ6 EXI RETURN TO READR CALLER ! 19628: * ! 19629: * HERE ON END OF FILE ! 19630: * ! 19631: READ7 ZER RDRER NOTE NOT-IN-READR FOR ERR ! 19632: MOV XR,DNAMP POP UNUSED SCBLK ! 19633: ZER XR ZERO PTR AS RESULT ! 19634: BZE R$COP,READ5 SKIP IF NO -COPY IN FORCE ! 19635: JSR COPND CALL TO END THIS -COPY (EOF) ! 19636: BRN READ0 TRY AGAIN ! 19637: ENP END PROCEDURE READR ! 19638: .IF .CASL ! 19639: EJC ! 19640: * ! 19641: * SBSCC -- BUILD SUBSTRING WITH CASE CONVERSION ! 19642: * ! 19643: * (XL) PTR TO SCBLK CONTAINING CHARS ! 19644: * (WA) CHAR COUNT ! 19645: * (WB) OFFSET TO FIRST CHAR IN SCBLK ! 19646: * JSR SBSCC CALL TO BUILD SUBSTRING ! 19647: * (XR) PTR TO NEW SCBLK WITH SUBSTRING ! 19648: * (WA,WB,WC,XL,IA) DESTROYED ! 19649: * ! 19650: * IF OPTION .CPLC IS SELECTED (PREFER LOWER CASE), TARGET ! 19651: * CASE IS LOWER CASE, OTHERWISE IT IS UPPER CASE. ! 19652: * ! 19653: SBSCC PRC E,0 ENTRY POINT ! 19654: BZE WA,SBSC4 JUMP IF NULL SUBSTRING ! 19655: JSR ALOCS ELSE ALLOCATE SCBLK ! 19656: MOV WC,WA MOVE NUMBER OF CHARACTERS ! 19657: MOV XR,WC SAVE PTR TO NEW SCBLK ! 19658: PLC XL,WB PREPARE TO LOAD CHARS FROM OLD BLK ! 19659: PSC XR PREPARE TO STORE CHARS IN NEW BLK ! 19660: LCT WA,WA TO COUNT ROUND LOOP ! 19661: * ! 19662: * LOOP TO COPY AND TRANSLATE CHARS ! 19663: * ! 19664: SBSC1 LCH WB,(XL)+ GET CHAR ! 19665: .IF .CPLC ! 19666: BGT WB,=CH$L$,SBSC2 SKIP IF NOT UC LETTER ! 19667: BLT WB,=CH$LA,SBSC2 SKIP IF NOT UC LETTER ! 19668: .IF .CSCV ! 19669: CUL WB CONVERT FROM UC TO LC ! 19670: .ELSE ! 19671: ADD =DFA$A,WB CONVERT FROM UC TO LC ! 19672: .FI ! 19673: .ELSE ! 19674: BGT WB,=CH$$$,SBSC2 SKIP IF NOT A LC LETTER ! 19675: BLT WB,=CH$$A,SBSC2 SKIP IF NOT A LC LETTER ! 19676: .IF .CSCV ! 19677: CLU WB CONVERT FROM LC TO UC ! 19678: .ELSE ! 19679: SUB =DFA$A,WB CONVERT FROM LC TO UC ! 19680: .FI ! 19681: .FI ! 19682: * ! 19683: * STORE CHAR IN NEW SUBSTRING ! 19684: * ! 19685: SBSC2 SCH WB,(XR)+ STORE CHAR ! 19686: BCT WA,SBSC1 LOOP ! 19687: MOV WC,XR RESTORE SCBLK POINTER ! 19688: * ! 19689: * RETURN POINT ! 19690: * ! 19691: SBSC3 ZER XL CLEAR GARBAGE POINTER IN XL ! 19692: EXI RETURN TO SBSCC CALLER ! 19693: * ! 19694: * HERE FOR NULL SUBSTRING ! 19695: * ! 19696: SBSC4 MOV =NULLS,XR SET NULL STRING AS RESULT ! 19697: BRN SBSC3 RETURN ! 19698: ENP END PROCEDURE SBSCC ! 19699: EJC ! 19700: * ! 19701: * SBSTG -- BUILD SUBSTRING POSSIBLY CONVERTING CASE ! 19702: * ! 19703: * (XL) PTR TO SCBLK CONTAINING CHARS ! 19704: * (WA) CHAR COUNT ! 19705: * (WB) OFFSET TO FIRST CHAR IN SCBLK ! 19706: * JSR SBSTG CALL TO BUILD SUBSTRING ! 19707: * (XR) PTR TO NEW SCBLK WITH SUBSTRING ! 19708: * (WA,WB,WC,XL,IA) DESTROYED ! 19709: * ! 19710: * IF CASE IS TO BE IGNORED (-CASEIG OR .CSIG), SUBSTRING ! 19711: * IS CONVERTED TO PREFERRED CASE (DEFAULT UPPER), ! 19712: * OTHERWISE CASE IS LEFT ALONE. ! 19713: * ! 19714: SBSTG PRC E,0 ENTRY POINT ! 19715: BZE CSWCI,SBSG1 SKIP IF CASE NOT IGNORED ! 19716: JSR SBSCC CONVERT TO IGNORE CASE ! 19717: EXI RETURN TO CALLER ! 19718: * ! 19719: SBSG1 JSR SBSTR READ SUBSTRING IN MIXED CASE ! 19720: EXI RETURN TO CALLER ! 19721: ENP END PROCEDURE SBSTG ! 19722: .FI ! 19723: EJC ! 19724: * ! 19725: * SBSTR -- BUILD A SUBSTRING ! 19726: * ! 19727: * (XL) PTR TO SCBLK CONTAINING CHARS ! 19728: * (WA) NUMBER OF CHARS IN SUBSTRING ! 19729: * (WB) OFFSET TO FIRST CHAR IN SCBLK ! 19730: * JSR SBSTR CALL TO BUILD SUBSTRING ! 19731: * (XR) PTR TO NEW SCBLK WITH SUBSTRING ! 19732: * (WA,WB,WC,XL,IA) DESTROYED ! 19733: * ! 19734: * NOTE THAT SBSTR IS CALLED WITH A DUMMY STRING POINTER ! 19735: * (POINTING INTO A VRBLK OR SVBLK) TO COPY THE NAME OF A ! 19736: * VARIABLE AS A STANDARD STRING VALUE. ! 19737: * ! 19738: SBSTR PRC E,0 ENTRY POINT ! 19739: BZE WA,SBST2 JUMP IF NULL SUBSTRING ! 19740: JSR ALOCS ELSE ALLOCATE SCBLK ! 19741: MOV WC,WA MOVE NUMBER OF CHARACTERS ! 19742: MOV XR,WC SAVE PTR TO NEW SCBLK ! 19743: PLC XL,WB PREPARE TO LOAD CHARS FROM OLD BLK ! 19744: PSC XR PREPARE TO STORE CHARS IN NEW BLK ! 19745: MVC MOVE CHARACTERS TO NEW STRING ! 19746: MOV WC,XR THEN RESTORE SCBLK POINTER ! 19747: * ! 19748: * RETURN POINT ! 19749: * ! 19750: SBST1 ZER XL CLEAR GARBAGE POINTER IN XL ! 19751: EXI RETURN TO SBSTR CALLER ! 19752: * ! 19753: * HERE FOR NULL SUBSTRING ! 19754: * ! 19755: SBST2 MOV =NULLS,XR SET NULL STRING AS RESULT ! 19756: BRN SBST1 RETURN ! 19757: ENP END PROCEDURE SBSTR ! 19758: EJC ! 19759: * ! 19760: * SCANE -- SCAN AN ELEMENT ! 19761: * ! 19762: * SCANE IS CALLED AT COMPILE TIME (BY EXPAN ,CMPIL,CNCRD) ! 19763: * TO SCAN ONE ELEMENT FROM THE INPUT IMAGE. ! 19764: * ! 19765: * (SCNCC) NON-ZERO IF CALLED FROM CNCRD ! 19766: * JSR SCANE CALL TO SCAN ELEMENT ! 19767: * (XR) RESULT POINTER (SEE BELOW) ! 19768: * (XL) SYNTAX TYPE CODE (T$XXX) ! 19769: * ! 19770: * THE FOLLOWING GLOBAL LOCATIONS ARE USED. ! 19771: * ! 19772: * R$CIM POINTER TO STRING BLOCK (SCBLK) ! 19773: * FOR CURRENT INPUT IMAGE. ! 19774: * ! 19775: * R$CNI POINTER TO NEXT INPUT IMAGE STRING ! 19776: * POINTER (ZERO IF NONE). ! 19777: * ! 19778: * R$SCP SAVE POINTER (EXIT XR) FROM LAST ! 19779: * CALL IN CASE RESCAN IS SET. ! 19780: * ! 19781: * SCNBL THIS LOCATION IS SET NON-ZERO ON ! 19782: * EXIT IF SCANE SCANNED PAST BLANKS ! 19783: * BEFORE LOCATING THE CURRENT ELEMENT ! 19784: * THE END OF A LINE COUNTS AS BLANKS. ! 19785: * ! 19786: * SCNCC CNCRD SETS THIS NON-ZERO TO SCAN ! 19787: * CONTROL CARD NAMES AND CLEARS IT ! 19788: * ON RETURN ! 19789: * ! 19790: * SCNIL LENGTH OF CURRENT INPUT IMAGE ! 19791: * ! 19792: * SCNGO IF SET NON-ZERO ON ENTRY, F AND S ! 19793: * ARE RETURNED AS SEPARATE SYNTAX ! 19794: * TYPES (NOT LETTERS) (GOTO PRO- ! 19795: * CESSING). SCNGO IS RESET ON EXIT. ! 19796: * ! 19797: * SCNPT OFFSET TO CURRENT LOC IN R$CIM ! 19798: * ! 19799: * SCNRS IF SET NON-ZERO ON ENTRY, SCANE ! 19800: * RETURNS THE SAME RESULT AS ON THE ! 19801: * LAST CALL (RESCAN). SCNRS IS RESET ! 19802: * ON EXIT FROM ANY CALL TO SCANE. ! 19803: * ! 19804: * SCNTP SAVE SYNTAX TYPE FROM LAST ! 19805: * CALL (IN CASE RESCAN IS SET). ! 19806: EJC ! 19807: * ! 19808: * SCANE (CONTINUED) ! 19809: * ! 19810: * ! 19811: * ! 19812: * ELEMENT SCANNED XL XR ! 19813: * --------------- -- -- ! 19814: * ! 19815: * CONTROL CARD NAME 0 POINTER TO SCBLK FOR NAME ! 19816: * ! 19817: * UNARY OPERATOR T$UOP PTR TO OPERATOR DVBLK ! 19818: * ! 19819: * LEFT PAREN T$LPR T$LPR ! 19820: * ! 19821: * LEFT BRACKET T$LBR T$LBR ! 19822: * ! 19823: * COMMA T$CMA T$CMA ! 19824: * ! 19825: * FUNCTION CALL T$FNC PTR TO FUNCTION VRBLK ! 19826: * ! 19827: * VARIABLE T$VAR PTR TO VRBLK ! 19828: * ! 19829: * STRING CONSTANT T$CON PTR TO SCBLK ! 19830: * ! 19831: * INTEGER CONSTANT T$CON PTR TO ICBLK ! 19832: * ! 19833: .IF .CNRA ! 19834: .ELSE ! 19835: * REAL CONSTANT T$CON PTR TO RCBLK ! 19836: * ! 19837: .FI ! 19838: * BINARY OPERATOR T$BOP PTR TO OPERATOR DVBLK ! 19839: * ! 19840: * RIGHT PAREN T$RPR T$RPR ! 19841: * ! 19842: * RIGHT BRACKET T$RBR T$RBR ! 19843: * ! 19844: * COLON T$COL T$COL ! 19845: * ! 19846: * SEMI-COLON T$SMC T$SMC ! 19847: * ! 19848: * F (SCNGO NE 0) T$FGO T$FGO ! 19849: * ! 19850: * S (SCNGO NE 0) T$SGO T$SGO ! 19851: EJC ! 19852: * ! 19853: * SCANE (CONTINUED) ! 19854: * ! 19855: * ENTRY POINT ! 19856: * ! 19857: SCANE PRC E,0 ENTRY POINT ! 19858: ZER SCNBL RESET BLANKS FLAG ! 19859: MOV WA,SCNSA SAVE WA ! 19860: MOV WB,SCNSB SAVE WB ! 19861: MOV WC,SCNSC SAVE WC ! 19862: BZE SCNRS,SCN03 JUMP IF NO RESCAN ! 19863: * ! 19864: * HERE FOR RESCAN REQUEST ! 19865: * ! 19866: MOV SCNTP,XL SET PREVIOUS RETURNED SCAN TYPE ! 19867: MOV R$SCP,XR SET PREVIOUS RETURNED POINTER ! 19868: ZER SCNRS RESET RESCAN SWITCH ! 19869: BRN SCN13 JUMP TO EXIT ! 19870: * ! 19871: * COME HERE TO READ NEW IMAGE TO TEST FOR CONTINUATION ! 19872: * ! 19873: SCN01 JSR READR READ NEXT IMAGE ! 19874: MOV *DVUBS,WB SET WB FOR NOT READING NAME ! 19875: BZE XR,SCN30 TREAT AS SEMI-COLON IF NONE ! 19876: PLC XR ELSE POINT TO FIRST CHARACTER ! 19877: LCH WC,(XR) LOAD FIRST CHARACTER ! 19878: BEQ WC,=CH$DT,SCN02 JUMP IF DOT FOR CONTINUATION ! 19879: BNE WC,=CH$PL,SCN30 ELSE TREAT AS SEMICOLON UNLESS PLUS ! 19880: * ! 19881: * HERE FOR CONTINUATION LINE ! 19882: * ! 19883: SCN02 JSR NEXTS ACQUIRE NEXT SOURCE IMAGE ! 19884: MOV =NUM01,SCNPT SET SCAN POINTER PAST CONTINUATION ! 19885: MNZ SCNBL SET BLANKS FLAG ! 19886: EJC ! 19887: * ! 19888: * SCANE (CONTINUED) ! 19889: * ! 19890: * MERGE HERE TO SCAN NEXT ELEMENT ON CURRENT LINE ! 19891: * ! 19892: SCN03 MOV SCNPT,WA LOAD CURRENT OFFSET ! 19893: BEQ WA,SCNIL,SCN01 CHECK CONTINUATION IF END ! 19894: MOV R$CIM,XL POINT TO CURRENT LINE ! 19895: PLC XL,WA POINT TO CURRENT CHARACTER ! 19896: MOV WA,SCNSE SET START OF ELEMENT LOCATION ! 19897: MOV =OPDVS,WC POINT TO OPERATOR DV LIST ! 19898: MOV *DVUBS,WB SET CONSTANT FOR OPERATOR CIRCUIT ! 19899: BRN SCN06 START SCANNING ! 19900: * ! 19901: * LOOP HERE TO IGNORE LEADING BLANKS AND TABS ! 19902: * ! 19903: SCN05 BZE WB,SCN10 JUMP IF TRAILING ! 19904: ICV SCNSE INCREMENT START OF ELEMENT ! 19905: BEQ WA,SCNIL,SCN01 JUMP IF END OF IMAGE ! 19906: MNZ SCNBL NOTE BLANKS SEEN ! 19907: * ! 19908: * THE FOLLOWING JUMP IS USED REPEATEDLY FOR SCANNING OUT ! 19909: * THE CHARACTERS OF A NUMERIC CONSTANT OR VARIABLE NAME. ! 19910: * THE REGISTERS ARE USED AS FOLLOWS. ! 19911: * ! 19912: * (XR) SCRATCH ! 19913: * (XL) PTR TO NEXT CHARACTER ! 19914: * (WA) CURRENT SCAN OFFSET ! 19915: * (WB) *DVUBS (0 IF SCANNING NAME,CONST) ! 19916: * (WC) =OPDVS (0 IF SCANNING CONSTANT) ! 19917: * ! 19918: SCN06 LCH XR,(XL)+ GET NEXT CHARACTER ! 19919: ICV WA BUMP SCAN OFFSET ! 19920: MOV WA,SCNPT STORE OFFSET PAST CHAR SCANNED ! 19921: BGE XR,=CFP$U,SCN07 QUICK CHECK FOR OTHER CHAR ! 19922: BSW XR,CFP$U,SCN07 SWITCH ON SCANNED CHARACTER ! 19923: * ! 19924: * SWITCH TABLE FOR SWITCH ON CHARACTER ! 19925: * ! 19926: IFF CH$BL,SCN05 BLANK ! 19927: .IF .CAHT ! 19928: IFF CH$HT,SCN05 HORIZONTAL TAB ! 19929: .FI ! 19930: .IF .CAVT ! 19931: IFF CH$VT,SCN05 VERTICAL TAB ! 19932: .FI ! 19933: IFF CH$D0,SCN08 DIGIT 0 ! 19934: IFF CH$D1,SCN08 DIGIT 1 ! 19935: IFF CH$D2,SCN08 DIGIT 2 ! 19936: IFF CH$D3,SCN08 DIGIT 3 ! 19937: IFF CH$D4,SCN08 DIGIT 4 ! 19938: IFF CH$D5,SCN08 DIGIT 5 ! 19939: IFF CH$D6,SCN08 DIGIT 6 ! 19940: IFF CH$D7,SCN08 DIGIT 7 ! 19941: IFF CH$D8,SCN08 DIGIT 8 ! 19942: IFF CH$D9,SCN08 DIGIT 9 ! 19943: EJC ! 19944: * ! 19945: * SCANE (CONTINUED) ! 19946: * ! 19947: IFF CH$LA,SCN09 LETTER A ! 19948: IFF CH$LB,SCN09 LETTER B ! 19949: IFF CH$LC,SCN09 LETTER C ! 19950: IFF CH$LD,SCN09 LETTER D ! 19951: IFF CH$LE,SCN09 LETTER E ! 19952: IFF CH$LG,SCN09 LETTER G ! 19953: IFF CH$LH,SCN09 LETTER H ! 19954: IFF CH$LI,SCN09 LETTER I ! 19955: IFF CH$LJ,SCN09 LETTER J ! 19956: IFF CH$LK,SCN09 LETTER K ! 19957: IFF CH$LL,SCN09 LETTER L ! 19958: IFF CH$LM,SCN09 LETTER M ! 19959: IFF CH$LN,SCN09 LETTER N ! 19960: IFF CH$LO,SCN09 LETTER O ! 19961: IFF CH$LP,SCN09 LETTER P ! 19962: IFF CH$LQ,SCN09 LETTER Q ! 19963: IFF CH$LR,SCN09 LETTER R ! 19964: IFF CH$LT,SCN09 LETTER T ! 19965: IFF CH$LU,SCN09 LETTER U ! 19966: IFF CH$LV,SCN09 LETTER V ! 19967: IFF CH$LW,SCN09 LETTER W ! 19968: IFF CH$LX,SCN09 LETTER X ! 19969: IFF CH$LY,SCN09 LETTER Y ! 19970: IFF CH$L$,SCN09 LETTER Z ! 19971: .IF .CASL ! 19972: IFF CH$$A,SCN09 SHIFTED A ! 19973: IFF CH$$B,SCN09 SHIFTED B ! 19974: IFF CH$$C,SCN09 SHIFTED C ! 19975: IFF CH$$D,SCN09 SHIFTED D ! 19976: IFF CH$$E,SCN09 SHIFTED E ! 19977: IFF CH$$F,SCN20 SHIFTED F ! 19978: IFF CH$$G,SCN09 SHIFTED G ! 19979: IFF CH$$H,SCN09 SHIFTED H ! 19980: IFF CH$$I,SCN09 SHIFTED I ! 19981: IFF CH$$J,SCN09 SHIFTED J ! 19982: IFF CH$$K,SCN09 SHIFTED K ! 19983: IFF CH$$L,SCN09 SHIFTED L ! 19984: IFF CH$$M,SCN09 SHIFTED M ! 19985: IFF CH$$N,SCN09 SHIFTED N ! 19986: IFF CH$$O,SCN09 SHIFTED O ! 19987: IFF CH$$P,SCN09 SHIFTED P ! 19988: IFF CH$$Q,SCN09 SHIFTED Q ! 19989: IFF CH$$R,SCN09 SHIFTED R ! 19990: IFF CH$$S,SCN21 SHIFTED S ! 19991: IFF CH$$T,SCN09 SHIFTED T ! 19992: IFF CH$$U,SCN09 SHIFTED U ! 19993: IFF CH$$V,SCN09 SHIFTED V ! 19994: IFF CH$$W,SCN09 SHIFTED W ! 19995: IFF CH$$X,SCN09 SHIFTED X ! 19996: IFF CH$$Y,SCN09 SHIFTED Y ! 19997: IFF CH$$$,SCN09 SHIFTED Z ! 19998: .FI ! 19999: EJC ! 20000: * ! 20001: * SCANE (CONTINUED) ! 20002: * ! 20003: IFF CH$SQ,SCN16 SINGLE QUOTE ! 20004: IFF CH$DQ,SCN17 DOUBLE QUOTE ! 20005: IFF CH$LF,SCN20 LETTER F ! 20006: IFF CH$LS,SCN21 LETTER S ! 20007: IFF CH$UN,SCN24 UNDERLINE ! 20008: IFF CH$PP,SCN25 LEFT PAREN ! 20009: IFF CH$RP,SCN26 RIGHT PAREN ! 20010: IFF CH$RB,SCN27 RIGHT BRACKET ! 20011: IFF CH$BB,SCN28 LEFT BRACKET ! 20012: IFF CH$CB,SCN27 RIGHT BRACKET ! 20013: IFF CH$OB,SCN28 LEFT BRACKET ! 20014: IFF CH$CL,SCN29 COLON ! 20015: IFF CH$SM,SCN30 SEMI-COLON ! 20016: IFF CH$CM,SCN31 COMMA ! 20017: IFF CH$DT,SCN32 DOT ! 20018: IFF CH$PL,SCN34 PLUS ! 20019: IFF CH$MN,SCN35 MINUS ! 20020: IFF CH$NT,SCN36 NOT ! 20021: IFF CH$DL,SCN33 DOLLAR ! 20022: IFF CH$EX,SCN37 EXCLAMATION MARK ! 20023: IFF CH$PC,SCN38 PERCENT ! 20024: IFF CH$SL,SCN40 SLASH ! 20025: IFF CH$NM,SCN41 NUMBER SIGN ! 20026: IFF CH$AT,SCN42 AT ! 20027: IFF CH$BR,SCN43 VERTICAL BAR ! 20028: IFF CH$AM,SCN44 AMPERSAND ! 20029: IFF CH$QU,SCN45 QUESTION MARK ! 20030: IFF CH$EQ,SCN46 EQUAL ! 20031: IFF CH$AS,SCN49 ASTERISK ! 20032: ESW END SWITCH ON CHARACTER ! 20033: * ! 20034: * HERE FOR ILLEGAL CHARACTER (UNDERLINE MERGES) ! 20035: * ! 20036: SCN07 BZE WB,SCN10 JUMP IF SCANNING NAME OR CONSTANT ! 20037: ERB 232,SYNTAX ERROR. ILLEGAL CHARACTER ! 20038: EJC ! 20039: * ! 20040: * SCANE (CONTINUED) ! 20041: * ! 20042: * HERE FOR DIGITS 0-9 ! 20043: * ! 20044: SCN08 BZE WB,SCN09 KEEP SCANNING IF NAME/CONSTANT ! 20045: ZER WC ELSE SET FLAG FOR SCANNING CONSTANT ! 20046: * ! 20047: * HERE FOR LETTER. LOOP HERE WHEN SCANNING NAME/CONSTANT ! 20048: * ! 20049: SCN09 BEQ WA,SCNIL,SCN11 JUMP IF END OF IMAGE ! 20050: ZER WB SET FLAG FOR SCANNING NAME/CONST ! 20051: BRN SCN06 MERGE BACK TO CONTINUE SCAN ! 20052: * ! 20053: * COME HERE FOR DELIMITER ENDING NAME OR CONSTANT ! 20054: * ! 20055: SCN10 DCV WA RESET OFFSET TO POINT TO DELIMITER ! 20056: * ! 20057: * COME HERE AFTER FINISHING SCAN OF NAME OR CONSTANT ! 20058: * ! 20059: SCN11 MOV WA,SCNPT STORE UPDATED SCAN OFFSET ! 20060: MOV SCNSE,WB POINT TO START OF ELEMENT ! 20061: SUB WB,WA GET NUMBER OF CHARACTERS ! 20062: MOV R$CIM,XL POINT TO LINE IMAGE ! 20063: BNZ WC,SCN15 JUMP IF NAME ! 20064: * ! 20065: * HERE AFTER SCANNING OUT NUMERIC CONSTANT ! 20066: * ! 20067: JSR SBSTR GET STRING FOR CONSTANT ! 20068: MOV XR,DNAMP DELETE FROM STORAGE (NOT NEEDED) ! 20069: JSR GTNUM CONVERT TO NUMERIC ! 20070: PPM SCN14 JUMP IF CONVERSION FAILURE ! 20071: * ! 20072: * MERGE HERE TO EXIT WITH CONSTANT ! 20073: * ! 20074: SCN12 MOV =T$CON,XL SET RESULT TYPE OF CONSTANT ! 20075: EJC ! 20076: * ! 20077: * SCANE (CONTINUED) ! 20078: * ! 20079: * COMMON EXIT POINT (XR,XL) SET ! 20080: * ! 20081: SCN13 MOV SCNSA,WA RESTORE WA ! 20082: MOV SCNSB,WB RESTORE WB ! 20083: MOV SCNSC,WC RESTORE WC ! 20084: MOV XR,R$SCP SAVE XR IN CASE RESCAN ! 20085: MOV XL,SCNTP SAVE XL IN CASE RESCAN ! 20086: ZER SCNGO RESET POSSIBLE GOTO FLAG ! 20087: EXI RETURN TO SCANE CALLER ! 20088: * ! 20089: * HERE IF CONVERSION ERROR ON NUMERIC ITEM ! 20090: * ! 20091: SCN14 ERB 233,SYNTAX ERROR. INVALID NUMERIC ITEM ! 20092: * ! 20093: * HERE AFTER SCANNING OUT VARIABLE NAME ! 20094: * ! 20095: .IF .CASL ! 20096: SCN15 JSR SBSTG BUILD STRING NAME OF VARIABLE ! 20097: .ELSE ! 20098: SCN15 JSR SBSTR BUILD STRING NAME OF VARIABLE ! 20099: .FI ! 20100: BNZ SCNCC,SCN13 RETURN IF CNCRD CALL ! 20101: JSR GTNVR LOCATE/BUILD VRBLK ! 20102: PPM DUMMY (UNUSED) ERROR RETURN ! 20103: MOV =T$VAR,XL SET TYPE AS VARIABLE ! 20104: BRN SCN13 BACK TO EXIT ! 20105: * ! 20106: * HERE FOR SINGLE QUOTE (START OF STRING CONSTANT) ! 20107: * ! 20108: SCN16 BZE WB,SCN10 TERMINATOR IF SCANNING NAME OR CNST ! 20109: MOV =CH$SQ,WB SET TERMINATOR AS SINGLE QUOTE ! 20110: BRN SCN18 MERGE ! 20111: * ! 20112: * HERE FOR DOUBLE QUOTE (START OF STRING CONSTANT) ! 20113: * ! 20114: SCN17 BZE WB,SCN10 TERMINATOR IF SCANNING NAME OR CNST ! 20115: MOV =CH$DQ,WB SET DOUBLE QUOTE TERMINATOR, MERGE ! 20116: * ! 20117: * LOOP TO SCAN OUT STRING CONSTANT ! 20118: * ! 20119: SCN18 BEQ WA,SCNIL,SCN19 ERROR IF END OF IMAGE ! 20120: LCH WC,(XL)+ ELSE LOAD NEXT CHARACTER ! 20121: ICV WA BUMP OFFSET ! 20122: BNE WC,WB,SCN18 LOOP BACK IF NOT TERMINATOR ! 20123: EJC ! 20124: * ! 20125: * SCANE (CONTINUED) ! 20126: * ! 20127: * HERE AFTER SCANNING OUT STRING CONSTANT ! 20128: * ! 20129: MOV SCNPT,WB POINT TO FIRST CHARACTER ! 20130: MOV WA,SCNPT SAVE OFFSET PAST FINAL QUOTE ! 20131: DCV WA POINT BACK PAST LAST CHARACTER ! 20132: SUB WB,WA GET NUMBER OF CHARACTERS ! 20133: MOV R$CIM,XL POINT TO INPUT IMAGE ! 20134: JSR SBSTR BUILD SUBSTRING VALUE ! 20135: BRN SCN12 BACK TO EXIT WITH CONSTANT RESULT ! 20136: * ! 20137: * HERE IF NO MATCHING QUOTE FOUND ! 20138: * ! 20139: SCN19 MOV WA,SCNPT SET UPDATED SCAN POINTER ! 20140: ERB 234,SYNTAX ERROR. UNMATCHED STRING QUOTE ! 20141: * ! 20142: * HERE FOR F (POSSIBLE FAILURE GOTO) ! 20143: * ! 20144: SCN20 MOV =T$FGO,XR SET RETURN CODE FOR FAIL GOTO ! 20145: BRN SCN22 JUMP TO MERGE ! 20146: * ! 20147: * HERE FOR S (POSSIBLE SUCCESS GOTO) ! 20148: * ! 20149: SCN21 MOV =T$SGO,XR SET SUCCESS GOTO AS RETURN CODE ! 20150: * ! 20151: * SPECIAL GOTO CASES MERGE HERE ! 20152: * ! 20153: SCN22 BZE SCNGO,SCN09 TREAT AS NORMAL LETTER IF NOT GOTO ! 20154: * ! 20155: * MERGE HERE FOR SPECIAL CHARACTER EXIT ! 20156: * ! 20157: SCN23 BZE WB,SCN10 JUMP IF END OF NAME/CONSTANT ! 20158: MOV XR,XL ELSE COPY CODE ! 20159: BRN SCN13 AND JUMP TO EXIT ! 20160: * ! 20161: * HERE FOR UNDERLINE ! 20162: * ! 20163: SCN24 BZE WB,SCN09 PART OF NAME IF SCANNING NAME ! 20164: BRN SCN07 ELSE ILLEGAL ! 20165: EJC ! 20166: * ! 20167: * SCANE (CONTINUED) ! 20168: * ! 20169: * HERE FOR LEFT PAREN ! 20170: * ! 20171: SCN25 MOV =T$LPR,XR SET LEFT PAREN RETURN CODE ! 20172: BNZ WB,SCN23 RETURN LEFT PAREN UNLESS NAME ! 20173: BZE WC,SCN10 DELIMITER IF SCANNING CONSTANT ! 20174: * ! 20175: * HERE FOR LEFT PAREN AFTER NAME (FUNCTION CALL) ! 20176: * ! 20177: MOV SCNSE,WB POINT TO START OF NAME ! 20178: MOV WA,SCNPT SET POINTER PAST LEFT PAREN ! 20179: DCV WA POINT BACK PAST LAST CHAR OF NAME ! 20180: SUB WB,WA GET NAME LENGTH ! 20181: MOV R$CIM,XL POINT TO INPUT IMAGE ! 20182: JSR SBSTR GET STRING NAME FOR FUNCTION ! 20183: JSR GTNVR LOCATE/BUILD VRBLK ! 20184: PPM DUMMY (UNUSED) ERROR RETURN ! 20185: MOV =T$FNC,XL SET CODE FOR FUNCTION CALL ! 20186: BRN SCN13 BACK TO EXIT ! 20187: * ! 20188: * PROCESSING FOR SPECIAL CHARACTERS ! 20189: * ! 20190: SCN26 MOV =T$RPR,XR RIGHT PAREN, SET CODE ! 20191: BRN SCN23 TAKE SPECIAL CHARACTER EXIT ! 20192: * ! 20193: SCN27 MOV =T$RBR,XR RIGHT BRACKET, SET CODE ! 20194: BRN SCN23 TAKE SPECIAL CHARACTER EXIT ! 20195: * ! 20196: SCN28 MOV =T$LBR,XR LEFT BRACKET, SET CODE ! 20197: BRN SCN23 TAKE SPECIAL CHARACTER EXIT ! 20198: * ! 20199: SCN29 MOV =T$COL,XR COLON, SET CODE ! 20200: BRN SCN23 TAKE SPECIAL CHARACTER EXIT ! 20201: * ! 20202: SCN30 MOV =T$SMC,XR SEMI-COLON, SET CODE ! 20203: BRN SCN23 TAKE SPECIAL CHARACTER EXIT ! 20204: * ! 20205: SCN31 MOV =T$CMA,XR COMMA, SET CODE ! 20206: BRN SCN23 TAKE SPECIAL CHARACTER EXIT ! 20207: EJC ! 20208: * ! 20209: * SCANE (CONTINUED) ! 20210: * ! 20211: * HERE FOR OPERATORS. ON ENTRY, WC POINTS TO THE TABLE OF ! 20212: * OPERATOR DOPE VECTORS AND WB IS THE INCREMENT TO STEP ! 20213: * TO THE NEXT PAIR (BINARY/UNARY) OF DOPE VECTORS IN THE ! 20214: * LIST. ON REACHING SCN46, THE POINTER HAS BEEN ADJUSTED TO ! 20215: * POINT TO THE APPROPRIATE PAIR OF DOPE VECTORS. ! 20216: * THE FIRST FOUR ENTRIES ARE SPECIAL SINCE THEY CAN OCCUR ! 20217: * AS PART OF A VARIABLE NAME (.$) OR CONSTANT (.+-). ! 20218: * ! 20219: SCN32 BZE WB,SCN09 DOT CAN BE PART OF NAME OR CONSTANT ! 20220: ADD WB,WC ELSE BUMP POINTER ! 20221: * ! 20222: SCN33 BZE WB,SCN09 DOLLAR CAN BE PART OF NAME ! 20223: ADD WB,WC ELSE BUMP POINTER ! 20224: * ! 20225: SCN34 BZE WC,SCN09 PLUS CAN BE PART OF CONSTANT ! 20226: BZE WB,SCN48 PLUS CANNOT BE PART OF NAME ! 20227: ADD WB,WC ELSE BUMP POINTER ! 20228: * ! 20229: SCN35 BZE WC,SCN09 MINUS CAN BE PART OF CONSTANT ! 20230: BZE WB,SCN48 MINUS CANNOT BE PART OF NAME ! 20231: ADD WB,WC ELSE BUMP POINTER ! 20232: LCH XR,(XL) GET NEXT CHARACTER ! 20233: BLT XR,=CH$D0,SCN36 SKIP IF NOT DIGIT ! 20234: BLE XR,=CH$D9,SCN08 JUMP IF DIGIT ! 20235: * ! 20236: SCN36 ADD WB,WC NOT ! 20237: SCN37 ADD WB,WC EXCLAMATION ! 20238: SCN38 ADD WB,WC PERCENT ! 20239: SCN39 ADD WB,WC ASTERISK ! 20240: SCN40 ADD WB,WC SLASH ! 20241: SCN41 ADD WB,WC NUMBER SIGN ! 20242: SCN42 ADD WB,WC AT SIGN ! 20243: SCN43 ADD WB,WC VERTICAL BAR ! 20244: SCN44 ADD WB,WC AMPERSAND ! 20245: SCN45 ADD WB,WC QUESTION MARK ! 20246: EJC ! 20247: * ! 20248: * SCANE (CONTINUED) ! 20249: * ! 20250: * ALL OPERATORS COME HERE (EQUAL MERGES DIRECTLY) ! 20251: * (WC) POINTS TO THE BINARY/UNARY PAIR OF OPERATOR DVBLKS. ! 20252: * ! 20253: SCN46 BZE WB,SCN10 OPERATOR TERMINATES NAME/CONSTANT ! 20254: MOV WC,XR ELSE COPY DV POINTER ! 20255: LCH WC,(XL) LOAD NEXT CHARACTER ! 20256: MOV =T$BOP,XL SET BINARY OP IN CASE ! 20257: BEQ WA,SCNIL,SCN47 SHOULD BE BINARY IF IMAGE END ! 20258: BEQ WC,=CH$BL,SCN47 SHOULD BE BINARY IF FOLLOWED BY BLK ! 20259: .IF .CAHT ! 20260: BEQ WC,=CH$HT,SCN47 JUMP IF HORIZONTAL TAB ! 20261: .FI ! 20262: .IF .CAVT ! 20263: BEQ WC,=CH$VT,SCN47 JUMP IF VERTICAL TAB ! 20264: .FI ! 20265: BEQ WC,=CH$SM,SCN47 SEMICOLON CAN IMMEDIATELY FOLLOW = ! 20266: * ! 20267: * HERE FOR UNARY OPERATOR ! 20268: * ! 20269: ADD *DVBS$,XR POINT TO DV FOR UNARY OP ! 20270: MOV =T$UOP,XL SET TYPE FOR UNARY OPERATOR ! 20271: BLE SCNTP,=T$UOK,SCN13 OK UNARY IF OK PRECEDING ELEMENT ! 20272: EJC ! 20273: * ! 20274: * SCANE (CONTINUED) ! 20275: * ! 20276: * MERGE HERE TO REQUIRE PRECEDING BLANKS ! 20277: * ! 20278: SCN47 BNZ SCNBL,SCN13 ALL OK IF PRECEDING BLANKS, EXIT ! 20279: * ! 20280: * FAIL OPERATOR IN THIS POSITION ! 20281: * ! 20282: SCN48 ERB 235,SYNTAX ERROR. INVALID USE OF OPERATOR ! 20283: * ! 20284: * HERE FOR ASTERISK, COULD BE ** SUBSTITUTE FOR EXCLAMATION ! 20285: * ! 20286: SCN49 BZE WB,SCN10 END OF NAME IF SCANNING NAME ! 20287: BEQ WA,SCNIL,SCN39 NOT ** IF * AT IMAGE END ! 20288: MOV WA,XR ELSE SAVE OFFSET PAST FIRST * ! 20289: MOV WA,SCNOF SAVE ANOTHER COPY ! 20290: LCH WA,(XL)+ LOAD NEXT CHARACTER ! 20291: BNE WA,=CH$AS,SCN50 NOT ** IF NEXT CHAR NOT * ! 20292: ICV XR ELSE STEP OFFSET PAST SECOND * ! 20293: BEQ XR,SCNIL,SCN51 OK EXCLAM IF END OF IMAGE ! 20294: LCH WA,(XL) ELSE LOAD NEXT CHARACTER ! 20295: BEQ WA,=CH$BL,SCN51 EXCLAMATION IF BLANK ! 20296: .IF .CAHT ! 20297: BEQ WA,=CH$HT,SCN51 EXCLAMATION IF HORIZONTAL TAB ! 20298: .FI ! 20299: .IF .CAVT ! 20300: BEQ WA,=CH$VT,SCN51 EXCLAMATION IF VERTICAL TAB ! 20301: .FI ! 20302: * ! 20303: * UNARY * ! 20304: * ! 20305: SCN50 MOV SCNOF,WA RECOVER STORED OFFSET ! 20306: MOV R$CIM,XL POINT TO LINE AGAIN ! 20307: PLC XL,WA POINT TO CURRENT CHAR ! 20308: BRN SCN39 MERGE WITH UNARY * ! 20309: * ! 20310: * HERE FOR ** AS SUBSTITUTE FOR EXCLAMATION ! 20311: * ! 20312: SCN51 MOV XR,SCNPT SAVE SCAN POINTER PAST 2ND * ! 20313: MOV XR,WA COPY SCAN POINTER ! 20314: BRN SCN37 MERGE WITH EXCLAMATION ! 20315: ENP END PROCEDURE SCANE ! 20316: EJC ! 20317: * ! 20318: * SCNGF -- SCAN GOTO FIELD ! 20319: * ! 20320: * SCNGF IS CALLED FROM CMPIL TO SCAN AND ANALYZE A GOTO ! 20321: * FIELD INCLUDING THE SURROUNDING BRACKETS OR PARENTHESES. ! 20322: * FOR A NORMAL GOTO, THE RESULT RETURNED IS EITHER A VRBLK ! 20323: * POINTER FOR A SIMPLE LABEL OPERAND, OR A POINTER TO AN ! 20324: * EXPRESSION TREE WITH A SPECIAL OUTER UNARY OPERATOR ! 20325: * (O$GOC). FOR A DIRECT GOTO, THE RESULT RETURNED IS A ! 20326: * POINTER TO AN EXPRESSION TREE WITH THE SPECIAL OUTER ! 20327: * UNARY OPERATOR O$GOD. ! 20328: * ! 20329: * JSR SCNGF CALL TO SCAN GOTO FIELD ! 20330: * (XR) RESULT (SEE ABOVE) ! 20331: * (XL,WA,WB,WC) DESTROYED ! 20332: * ! 20333: SCNGF PRC E,0 ENTRY POINT ! 20334: JSR SCANE SCAN INITIAL ELEMENT ! 20335: BEQ XL,=T$LPR,SCNG1 SKIP IF LEFT PAREN (NORMAL GOTO) ! 20336: BEQ XL,=T$LBR,SCNG2 SKIP IF LEFT BRACKET (DIRECT GOTO) ! 20337: ERB 236,SYNTAX ERROR. GOTO FIELD INCORRECT ! 20338: * ! 20339: * HERE FOR LEFT PAREN (NORMAL GOTO) ! 20340: * ! 20341: SCNG1 MOV =NUM01,WB SET EXPAN FLAG FOR NORMAL GOTO ! 20342: JSR EXPAN ANALYZE GOTO FIELD ! 20343: MOV =OPDVN,WA ELSE POINT TO OPDV FOR COMPLEX GOTO ! 20344: BLE XR,STATB,SCNG3 JUMP IF NOT IN STATIC ! 20345: BLO XR,STATE,SCNG4 JUMP TO EXIT IF SIMPLE LABEL NAME ! 20346: BRN SCNG3 AND MERGE ! 20347: * ! 20348: * HERE FOR LEFT BRACKET (DIRECT GOTO) ! 20349: * ! 20350: SCNG2 MOV =NUM02,WB SET EXPAN FLAG FOR DIRECT GOTO ! 20351: JSR EXPAN SCAN GOTO FIELD ! 20352: MOV =OPDVD,WA SET OPDV POINTER FOR DIRECT GOTO ! 20353: EJC ! 20354: * ! 20355: * SCNGF (CONTINUED) ! 20356: * ! 20357: * MERGE HERE TO BUILD OUTER UNARY OPERATOR BLOCK ! 20358: * ! 20359: SCNG3 MOV WA,-(XS) STACK OPERATOR DV POINTER ! 20360: MOV XR,-(XS) STACK POINTER TO EXPRESSION TREE ! 20361: JSR EXPOP POP OPERATOR OFF ! 20362: MOV (XS)+,XR RELOAD NEW EXPRESSION TREE POINTER ! 20363: * ! 20364: * COMMON EXIT POINT ! 20365: * ! 20366: SCNG4 EXI RETURN TO CALLER ! 20367: ENP END PROCEDURE SCNGF ! 20368: EJC ! 20369: * ! 20370: * SETVR -- SET VRGET,VRSTO FIELDS OF VRBLK ! 20371: * ! 20372: * SETVR SETS THE PROPER VALUES IN THE VRGET AND VRSTO ! 20373: * FIELDS OF A VRBLK. IT IS CALLED WHENEVER TRBLKS ARE ! 20374: * ADDED OR SUBTRACTED (TRACE,STOPTR,INPUT,OUTPUT,DETACH) ! 20375: * ! 20376: * (XR) POINTER TO VRBLK ! 20377: * JSR SETVR CALL TO SET FIELDS ! 20378: * (XL,WA) DESTROYED ! 20379: * ! 20380: * NOTE THAT SETVR IGNORES THE CALL IF XR DOES NOT POINT ! 20381: * INTO THE STATIC REGION (I.E. IS SOME OTHER NAME BASE) ! 20382: * ! 20383: SETVR PRC E,0 ENTRY POINT ! 20384: BHI XR,STATE,SETV1 EXIT IF NOT NATURAL VARIABLE ! 20385: * ! 20386: * HERE IF WE HAVE A VRBLK ! 20387: * ! 20388: MOV XR,XL COPY VRBLK POINTER ! 20389: MOV =B$VRL,VRGET(XR) STORE NORMAL GET VALUE ! 20390: BEQ VRSTO(XR),=B$VRE,SETV1 SKIP IF PROTECTED VARIABLE ! 20391: MOV =B$VRS,VRSTO(XR) STORE NORMAL STORE VALUE ! 20392: MOV VRVAL(XL),XL POINT TO NEXT ENTRY ON CHAIN ! 20393: BNE (XL),=B$TRT,SETV1 JUMP IF END OF TRBLK CHAIN ! 20394: MOV =B$VRA,VRGET(XR) STORE TRAPPED ROUTINE ADDRESS ! 20395: MOV =B$VRV,VRSTO(XR) SET TRAPPED ROUTINE ADDRESS ! 20396: * ! 20397: * MERGE HERE TO EXIT TO CALLER ! 20398: * ! 20399: SETV1 EXI RETURN TO SETVR CALLER ! 20400: ENP END PROCEDURE SETVR ! 20401: .IF .CNSR ! 20402: .ELSE ! 20403: EJC ! 20404: * ! 20405: * SORTA -- SORT ARRAY ! 20406: * ! 20407: * ROUTINE TO SORT AN ARRAY OR TABLE ON SAME BASIS AS IN ! 20408: * SITBOL. A TABLE IS CONVERTED TO AN ARRAY, LEAVING TWO ! 20409: * DIMENSIONAL ARRAYS AND VECTORS AS CASES TO BE CONSIDERED. ! 20410: * WHOLE ROWS OF ARRAYS ARE PERMUTED ACCORDING TO THE ! 20411: * ORDERING OF THE KEYS THEY CONTAIN, AND THE STRIDE ! 20412: * REFERRED TO, IS THE THE LENGTH OF A ROW. IT IS ONE ! 20413: * FOR A VECTOR. ! 20414: * THE SORT USED IS HEAPSORT, FUNDAMENTALS OF DATA STRUCTURES, ! 20415: * HOROWITZ AND SAHNI, PITMAN 1977, PAGE 347. ! 20416: * IT IS AN ORDER N*LOG(N) ALGORITHM. IN ORDER ! 20417: * TO MAKE IT STABLE, COMPARANDS MAY NOT COMPARE EQUAL. THIS ! 20418: * IS ACHIEVED BY SORTING A COPY ARRAY (REFERRED TO AS THE ! 20419: * SORT ARRAY) CONTAINING AT ITS HIGH ADDRESS END, BAU ! 20420: * OFFSETS TO THE ROWS TO BE SORTED HELD IN THE ORIGINAL ! 20421: * ARRAY (REFERRED TO AS THE KEY ARRAY). SORTC, THE ! 20422: * COMPARISON ROUTINE, ACCESSES THE KEYS THROUGH THESE ! 20423: * OFFSETS AND IN THE CASE OF EQUALITY, RESOLVES IT BY ! 20424: * COMPARING THE OFFSETS THEMSELVES. THE SORT PERMUTES THE ! 20425: * OFFSETS WHICH ARE THEN USED IN A FINAL OPERATION TO COPY ! 20426: * THE ACTUAL ITEMS INTO THE NEW ARRAY IN SORTED ORDER. ! 20427: * REFERENCES TO ZEROTH ITEM ARE TO NOTIONAL ITEM ! 20428: * PRECEDING FIRST ACTUAL ITEM. ! 20429: * REVERSE SORTING FOR RSORT IS DONE BY HAVING THE LESS THAN ! 20430: * TEST FOR KEYS EFFECTIVELY BE REPLACED BY A ! 20431: * GREATER THAN TEST. ! 20432: * GIVES ERROR MESSAGES FOR INCORRECT ARGS, RETURNS EXI 1 ! 20433: * FOR EMPTY TABLE. ! 20434: * ! 20435: * 1(XS) FIRST ARG - ARRAY OR TABLE ! 20436: * 0(XS) 2ND ARG - INDEX OR PDTYPE NAME ! 20437: * (WA) 0 , NON-ZERO FOR SORT , RSORT ! 20438: * JSR SORTA CALL TO SORT ARRAY ! 20439: * PPM LOC FAIL RETURN FOR EMPTY TABLE ! 20440: * (XR) SORTED ARRAY ! 20441: * (XL,WA,WB,WC) DESTROYED ! 20442: EJC ! 20443: * ! 20444: * SORTA (CONTINUED) ! 20445: * ! 20446: SORTA PRC N,1 ENTRY POINT ! 20447: MOV WA,SRTSR SORT/RSORT INDICATOR ! 20448: MOV *NUM01,SRTST DEFAULT STRIDE OF 1 ! 20449: ZER SRTOF DEFAULT ZERO OFFSET TO SORT KEY ! 20450: MOV =NULLS,SRTDF CLEAR DATATYPE FIELD NAME ! 20451: MOV (XS)+,R$SXR UNSTACK ARGUMENT 2 ! 20452: MOV (XS)+,XR GET FIRST ARGUMENT ! 20453: MOV (XR),WA GET ARG TYPE ! 20454: BEQ WA,=B$ART,SRT00 SKIP IF ARRAY ! 20455: BNE WA,=B$TBT,SRT16 ERROR IF NOT TABLE ! 20456: JSR GTARR CONVERT TO ARRAY ! 20457: PPM SRT18 FAIL ! 20458: * ! 20459: * MAKE COPY OF ARRAY ! 20460: * ! 20461: SRT00 MOV XR,-(XS) STACK PTR TO RESULTING KEY ARRAY ! 20462: MOV XR,-(XS) ANOTHER COPY FOR CBLCK ! 20463: JSR CBLCK GET COPY ARRAY FOR SORTING INTO ! 20464: PPM CANT FAIL ! 20465: MOV XR,-(XS) STACK POINTER TO SORT ARRAY ! 20466: MOV R$SXR,XR GET SECOND ARG ! 20467: MOV 1(XS),XL GET PTR TO KEY ARRAY ! 20468: BNE (XL),=B$VCT,SRT02 JUMP IF ARBLK ! 20469: BEQ XR,=NULLS,SRT01 JUMP IF NULL SECOND ARG ! 20470: JSR GTNVR GET VRBLK PTR FOR IT ! 20471: ERR 237,ERRONEOUS 2ND ARG IN SORT/RSORT OF VECTOR ! 20472: MOV XR,SRTDF STORE DATATYPE FIELD NAME VRBLK ! 20473: * ! 20474: * COMPUTE N AND OFFSET TO ITEM A(0) IN VECTOR CASE ! 20475: * ! 20476: SRT01 MOV *VCLEN,WC OFFSET TO A(0) ! 20477: MOV *VCVLS,WB OFFSET TO FIRST ITEM ! 20478: MOV VCLEN(XL),WA GET BLOCK LENGTH ! 20479: SUB *VCSI$,WA GET NO. OF ENTRIES, N (IN BAUS) ! 20480: BRN SRT04 MERGE ! 20481: * ! 20482: * HERE FOR ARRAY ! 20483: * ! 20484: SRT02 LDI ARDIM(XL) GET POSSIBLE DIMENSION ! 20485: MFI WA CONVERT TO SHORT INTEGER ! 20486: WTB WA FURTHER CONVERT TO BAUS ! 20487: MOV *ARVLS,WB OFFSET TO FIRST VALUE IF ONE DIM. ! 20488: MOV *ARPRO,WC OFFSET BEFORE VALUES IF ONE DIM. ! 20489: BEQ ARNDM(XL),=NUM01,SRT04 JUMP IF IN FACT ONE DIMENSION ! 20490: BNE ARNDM(XL),=NUM02,SRT16 FAIL UNLESS TWO DIMENSIONAL ! 20491: LDI ARLB2(XL) GET LOWER BOUND 2 AS DEFAULT COLUMN ! 20492: BEQ XR,=NULLS,SRT03 JUMP IF DEFAULT SECOND ARG ! 20493: JSR GTINT CONVERT TO INTEGER ! 20494: PPM SRT17 FAIL ! 20495: LDI ICVAL(XR) GET ACTUAL INTEGER VALUE ! 20496: EJC ! 20497: * ! 20498: * SORTA (CONTINUED) ! 20499: * ! 20500: * HERE WITH SORT COLUMN INDEX IN IA IN ARRAY CASE ! 20501: * ! 20502: SRT03 SBI ARLB2(XL) SUBTRACT LOW BOUND ! 20503: IOV SRT17 FAIL IF OVERFLOW ! 20504: ILT SRT17 FAIL IF BELOW LOW BOUND ! 20505: SBI ARDM2(XL) CHECK AGAINST DIMENSION ! 20506: IGE SRT17 FAIL IF TOO LARGE ! 20507: ADI ARDM2(XL) RESTORE VALUE ! 20508: MFI WA GET AS SMALL INTEGER ! 20509: WTB WA OFFSET WITHIN ROW TO KEY ! 20510: MOV WA,SRTOF KEEP OFFSET ! 20511: LDI ARDM2(XL) SECOND DIMENSION IS ROW LENGTH ! 20512: MFI WA CONVERT TO SHORT INTEGER ! 20513: MOV WA,XR COPY ROW LENGTH ! 20514: WTB WA CONVERT TO BAUS ! 20515: MOV WA,SRTST STORE AS STRIDE ! 20516: LDI ARDIM(XL) GET NUMBER OF ROWS ! 20517: MFI WA AS A SHORT INTEGER ! 20518: WTB WA CONVERT N TO BAUS ! 20519: MOV ARLEN(XL),WC OFFSET PAST ARRAY END ! 20520: SUB WA,WC ADJUST, GIVING SPACE FOR N OFFSETS ! 20521: DCA WC POINT TO A(0) ! 20522: MOV AROFS(XL),WB OFFSET TO WORD BEFORE FIRST ITEM ! 20523: ICA WB OFFSET TO FIRST ITEM ! 20524: * ! 20525: * SEPARATE PRE-PROCESSING FOR ARRAYS AND VECTORS DONE. ! 20526: * TO SIMPLIFY LATER KEY COMPARISONS, REMOVAL OF ANY TRBLK ! 20527: * TRAP BLOCKS FROM ENTRIES IN KEY ARRAY IS EFFECTED. ! 20528: * ! 20529: * (XL) = 1(XS) = POINTER TO KEY ARRAY ! 20530: * (XS) = POINTER TO SORT ARRAY ! 20531: * WA = NUMBER OF ITEMS, N (CONVERTED TO BAUS). ! 20532: * WB = OFFSET TO FIRST ITEM OF ARRAYS. ! 20533: * WC = OFFSET TO A(0) ! 20534: * ! 20535: SRT04 BLE WA,*NUM01,SRT15 RETURN IF ONLY A SINGLE ITEM ! 20536: MOV WA,SRTSN STORE NUMBER OF ITEMS (IN BAUS) ! 20537: MOV WC,SRTSO STORE OFFSET TO A(0) ! 20538: MOV ARLEN(XL),WC LENGTH OF ARRAY OR VEC (=VCLEN) ! 20539: ADD XL,WC POINT PAST END OF ARRAY OR VECTOR ! 20540: MOV WB,SRTSF STORE OFFSET TO FIRST ROW ! 20541: ADD WB,XL POINT TO FIRST ITEM IN KEY ARRAY ! 20542: * ! 20543: * LOOP THROUGH ARRAY ! 20544: * ! 20545: SRT05 MOV (XL),XR GET AN ENTRY ! 20546: * ! 20547: * HUNT ALONG TRBLK CHAIN ! 20548: * ! 20549: SRT06 BNE (XR),=B$TRT,SRT07 JUMP OUT IF NOT TRBLK ! 20550: MOV TRVAL(XR),XR GET VALUE FIELD ! 20551: BRN SRT06 LOOP ! 20552: EJC ! 20553: * ! 20554: * SORTA (CONTINUED) ! 20555: * ! 20556: * XR IS VALUE FROM END OF CHAIN ! 20557: * ! 20558: SRT07 MOV XR,(XL)+ STORE AS ARRAY ENTRY ! 20559: BLT XL,WC,SRT05 LOOP IF NOT DONE ! 20560: MOV (XS),XL GET ADRS OF SORT ARRAY ! 20561: MOV SRTSF,XR INITIAL OFFSET TO FIRST KEY ! 20562: MOV SRTST,WB GET STRIDE ! 20563: ADD SRTSO,XL OFFSET TO A(0) ! 20564: ICA XL POINT TO A(1) ! 20565: MOV SRTSN,WC GET N ! 20566: BTW WC CONVERT FROM BAUS ! 20567: MOV WC,SRTNR STORE AS ROW COUNT ! 20568: LCT WC,WC LOOP COUNTER ! 20569: * ! 20570: * STORE KEY OFFSETS AT TOP OF SORT ARRAY ! 20571: * ! 20572: SRT08 MOV XR,(XL)+ STORE AN OFFSET ! 20573: ADD WB,XR BUMP OFFSET BY STRIDE ! 20574: BCT WC,SRT08 LOOP THROUGH ROWS ! 20575: * ! 20576: * PERFORM THE SORT ON OFFSETS IN SORT ARRAY. ! 20577: * ! 20578: * (SRTSN) NUMBER OF ITEMS TO SORT, N (BAUS) ! 20579: * (SRTSO) OFFSET TO A(0) ! 20580: * ! 20581: SRT09 MOV SRTSN,WA GET N ! 20582: MOV SRTNR,WC GET NUMBER OF ROWS ! 20583: RSH WC,1 I = N / 2 (WC=I, INDEX INTO ARRAY) ! 20584: WTB WC CONVERT BACK TO BAUS ! 20585: * ! 20586: * LOOP TO FORM INITIAL HEAP ! 20587: * ! 20588: SRT10 JSR SORTH SORTH(I,N) ! 20589: DCA WC I = I - 1 ! 20590: BNZ WC,SRT10 LOOP IF I GT 0 ! 20591: MOV WA,WC I = N ! 20592: * ! 20593: * SORTING LOOP. AT THIS POINT, A(1) IS THE LARGEST ! 20594: * ITEM, SINCE ALGORITHM INITIALISES IT AS, AND THEN MAINTAINS ! 20595: * IT AS, ROOT OF TREE. ! 20596: * ! 20597: SRT11 DCA WC I = I - 1 (N - 1 INITIALLY) ! 20598: BZE WC,SRT12 JUMP IF DONE ! 20599: MOV (XS),XR GET SORT ARRAY ADDRESS ! 20600: ADD SRTSO,XR POINT TO A(0) ! 20601: MOV XR,XL A(0) ADDRESS ! 20602: ADD WC,XL A(I) ADDRESS ! 20603: MOV 1(XL),WB COPY A(I+1) ! 20604: MOV 1(XR),1(XL) MOVE A(1) TO A(I+1) ! 20605: MOV WB,1(XR) COMPLETE EXCHANGE OF A(1), A(I+1) ! 20606: MOV WC,WA N = I FOR SORTH ! 20607: MOV *NUM01,WC I = 1 FOR SORTH ! 20608: JSR SORTH SORTH(1,N) ! 20609: MOV WA,WC RESTORE WC ! 20610: BRN SRT11 LOOP ! 20611: EJC ! 20612: * ! 20613: * SORTA (CONTINUED) ! 20614: * ! 20615: * OFFSETS HAVE BEEN PERMUTED INTO REQUIRED ORDER BY SORT. ! 20616: * COPY ARRAY ELEMENTS OVER THEM. ! 20617: * ! 20618: SRT12 MOV (XS),XL BASE ADRS OF KEY ARRAY ! 20619: MOV XL,WC COPY IT ! 20620: ADD SRTSO,WC OFFSET OF A(0) ! 20621: ADD SRTSF,XL ADRS OF FIRST ROW OF SORT ARRAY ! 20622: MOV SRTST,WB GET STRIDE ! 20623: BTW WB CONVERT TO WORDS ! 20624: * ! 20625: * COPYING LOOP FOR SUCCESSIVE ITEMS. SORTED OFFSETS ARE ! 20626: * HELD AT END OF SORT ARRAY. ! 20627: * ! 20628: SRT13 ICA WC ADRS OF NEXT OF SORTED OFFSETS ! 20629: MOV WC,XR COPY IT FOR ACCESS ! 20630: MOV (XR),XR GET OFFSET ! 20631: ADD 1(XS),XR ADD KEY ARRAY BASE ADRS ! 20632: LCT WA,WB GET COUNT OF WORDS IN ROW ! 20633: * ! 20634: * COPY A COMPLETE ROW ! 20635: * ! 20636: SRT14 MOV (XR)+,(XL)+ MOVE A WORD ! 20637: BCT WA,SRT14 LOOP ! 20638: DCV SRTNR DECREMENT ROW COUNT ! 20639: BNZ SRTNR,SRT13 REPEAT TILL ALL ROWS DONE ! 20640: * ! 20641: * RETURN POINT ! 20642: * ! 20643: SRT15 MOV (XS)+,XR POP RESULT ARRAY PTR ! 20644: ICA XS POP KEY ARRAY PTR ! 20645: ZER R$SXL CLEAR JUNK ! 20646: ZER R$SXR CLEAR JUNK ! 20647: EXI RETURN ! 20648: * ! 20649: * ERROR POINT ! 20650: * ! 20651: SRT16 ERB 238,SORT/RSORT 1ST ARG NOT SUITABLE ARRAY OR TABLE ! 20652: SRT17 ERB 239,SORT/RSORT 2ND ARG OUT OF RANGE OR NON-INTEGER ! 20653: * ! 20654: * SOFT FAIL RETURN ! 20655: * ! 20656: SRT18 EXI 1 RETURN ! 20657: ENP END PROCUDURE SORTA ! 20658: EJC ! 20659: * ! 20660: * SORTC -- COMPARE SORT KEYS ! 20661: * ! 20662: * COMPARE TWO SORT KEYS GIVEN THEIR OFFSETS. IF ! 20663: * EQUAL, COMPARE KEY OFFSETS TO GIVE STABLE SORT. ! 20664: * NOTE THAT IF SRTSR IS NON-ZERO (REQUEST FOR REVERSE ! 20665: * SORT), THE QUOTED RETURNS ARE INVERTED. ! 20666: * FOR OBJECTS OF DIFFERING DATATYPES, THE ENTRY POINT ! 20667: * IDENTIFICATIONS ARE COMPARED. ! 20668: * ! 20669: * (XL) BASE ADRS FOR KEYS ! 20670: * (WA) OFFSET TO KEY 1 ITEM ! 20671: * (WB) OFFSET TO KEY 2 ITEM ! 20672: * (SRTSR) ZERO/NON-ZERO FOR SORT/RSORT ! 20673: * (SRTOF) OFFSET WITHIN ROW TO COMPARANDS ! 20674: * JSR SORTC CALL TO COMPARE KEYS ! 20675: * PPM LOC KEY1 LESS THAN KEY2 ! 20676: * NORMAL RETURN, KEY1 GT THAN KEY2 ! 20677: * (XL,XR,WA,WB) DESTROYED ! 20678: * ! 20679: SORTC PRC E,1 ENTRY POINT ! 20680: MOV WA,SRTS1 SAVE OFFSET 1 ! 20681: MOV WB,SRTS2 SAVE OFFSET 2 ! 20682: MOV WC,SRTSC SAVE WC ! 20683: ADD SRTOF,XL ADD OFFSET TO COMPARAND FIELD ! 20684: MOV XL,XR COPY BASE + OFFSET ! 20685: ADD WA,XL ADD KEY1 OFFSET ! 20686: ADD WB,XR ADD KEY2 OFFSET ! 20687: MOV (XL),XL GET KEY1 ! 20688: MOV (XR),XR GET KEY2 ! 20689: BNE SRTDF,=NULLS,SRC11 JUMP IF DATATYPE FIELD NAME USED ! 20690: EJC ! 20691: * ! 20692: * SORTC (CONTINUED) ! 20693: * ! 20694: * MERGE AFTER DEALING WITH FIELD NAME. TRY FOR STRINGS. ! 20695: * ! 20696: SRC01 MOV (XL),WC GET TYPE CODE ! 20697: BNE WC,(XR),SRC02 SKIP IF NOT SAME DATATYPE ! 20698: BEQ WC,=B$SCL,SRC09 JUMP IF BOTH STRINGS ! 20699: * ! 20700: * NOW TRY FOR NUMERIC ! 20701: * ! 20702: SRC02 MOV XL,R$SXL KEEP ARG1 ! 20703: MOV XR,R$SXR KEEP ARG2 ! 20704: MOV XL,-(XS) STACK ! 20705: MOV XR,-(XS) ARGS ! 20706: JSR ACOMP COMPARE OBJECTS ! 20707: PPM SRC10 NOT NUMERIC ! 20708: PPM SRC10 NOT NUMERIC ! 20709: PPM SRC03 KEY1 LESS ! 20710: PPM SRC08 KEYS EQUAL ! 20711: PPM SRC05 KEY1 GREATER ! 20712: * ! 20713: * RETURN IF KEY1 SMALLER (SORT), GREATER (RSORT) ! 20714: * ! 20715: SRC03 BNZ SRTSR,SRC06 JUMP IF RSORT ! 20716: * ! 20717: SRC04 MOV SRTSC,WC RESTORE WC ! 20718: EXI 1 RETURN ! 20719: * ! 20720: * RETURN IF KEY1 GREATER (SORT), SMALLER (RSORT) ! 20721: * ! 20722: SRC05 BNZ SRTSR,SRC04 JUMP IF RSORT ! 20723: * ! 20724: SRC06 MOV SRTSC,WC RESTORE WC ! 20725: EXI RETURN ! 20726: * ! 20727: * KEYS ARE OF SAME DATATYPE ! 20728: * ! 20729: SRC07 BLT XL,XR,SRC03 ITEM FIRST CREATED IS LESS ! 20730: BGT XL,XR,SRC05 ADDRESSES RISE IN ORDER OF CREATION ! 20731: * ! 20732: * DROP THROUGH OR MERGE FOR IDENTICAL OR EQUAL OBJECTS ! 20733: * ! 20734: SRC08 BLT SRTS1,SRTS2,SRC04 TEST OFFSETS OR KEY ADDRSS INSTEAD ! 20735: BRN SRC06 OFFSET 1 GREATER ! 20736: EJC ! 20737: * ! 20738: * SORTC (CONTINUED) ! 20739: * ! 20740: * STRINGS ! 20741: * ! 20742: SRC09 MOV XL,-(XS) STACK ! 20743: MOV XR,-(XS) ARGS ! 20744: JSR LCOMP COMPARE OBJECTS ! 20745: PPM CANT ! 20746: PPM FAIL ! 20747: PPM SRC03 KEY1 LESS ! 20748: PPM SRC08 KEYS EQUAL ! 20749: PPM SRC05 KEY1 GREATER ! 20750: * ! 20751: * ARITHMETIC COMPARISON FAILED - RECOVER ARGS ! 20752: * ! 20753: SRC10 MOV R$SXL,XL GET ARG1 ! 20754: MOV R$SXR,XR GET ARG2 ! 20755: MOV (XL),WC GET TYPE OF KEY1 ! 20756: BEQ WC,(XR),SRC07 JUMP IF KEYS OF SAME TYPE ! 20757: MOV WC,XL GET BLOCK TYPE WORD ! 20758: MOV (XR),XR GET BLOCK TYPE WORD ! 20759: LEI XL ENTRY POINT ID FOR KEY1 ! 20760: LEI XR ENTRY POINT ID FOR KEY2 ! 20761: BGT XL,XR,SRC05 JUMP IF KEY1 GT KEY2 ! 20762: BRN SRC03 KEY1 LT KEY2 ! 20763: * ! 20764: * DATATYPE FIELD NAME USED ! 20765: * ! 20766: SRC11 JSR SORTF CALL ROUTINE TO FIND FIELD 1 ! 20767: MOV XL,-(XS) STACK ITEM POINTER ! 20768: MOV XR,XL GET KEY2 ! 20769: JSR SORTF FIND FIELD 2 ! 20770: MOV XL,XR PLACE AS KEY2 ! 20771: MOV (XS)+,XL RECOVER KEY1 ! 20772: BRN SRC01 MERGE ! 20773: ENP PROCEDURE SORTC ! 20774: EJC ! 20775: * ! 20776: * SORTF -- FIND FIELD FOR SORTC ! 20777: * ! 20778: * ROUTINE USED BY SORTC TO OBTAIN ITEM CORRESPONDING ! 20779: * TO A GIVEN FIELD NAME, IF THIS EXISTS, IN A PROGRAMMER ! 20780: * DEFINED OBJECT PASSED AS ARGUMENT. ! 20781: * IF SUCH A MATCH OCCURS, RECORD IS KEPT OF DATATYPE ! 20782: * NAME, FIELD NAME AND OFFSET TO FIELD IN ORDER TO ! 20783: * SHORT-CIRCUIT LATER SEARCHES ON SAME TYPE. NOTE THAT ! 20784: * DFBLKS ARE STORED IN STATIC AND HENCE CANNOT BE MOVED. ! 20785: * ! 20786: * (SRTDF) VRBLK POINTER OF FIELD NAME ! 20787: * (XL) POSSIBLE PDBLK POINTER ! 20788: * JSR SORTF CALL TO SEARCH FOR FIELD NAME ! 20789: * (XL) ITEM FOUND OR ORIGINAL PDBLK PTR ! 20790: * (WC) DESTROYED ! 20791: * ! 20792: SORTF PRC E,0 ENTRY POINT ! 20793: BNE (XL),=B$PDT,SRTF3 RETURN IF NOT PDBLK ! 20794: MOV XR,-(XS) KEEP XR ! 20795: MOV SRTFD,XR GET POSSIBLE FORMER DFBLK PTR ! 20796: BZE XR,SRTF4 JUMP IF NOT ! 20797: BNE XR,PDDFP(XL),SRTF4 JUMP IF NOT RIGHT DATATYPE ! 20798: BNE SRTDF,SRTFF,SRTF4 JUMP IF NOT RIGHT FIELD NAME ! 20799: ADD SRTFO,XL ADD OFFSET TO REQUIRED FIELD ! 20800: * ! 20801: * HERE WITH XL POINTING TO FOUND FIELD ! 20802: * ! 20803: SRTF1 MOV (XL),XL GET ITEM FROM FIELD ! 20804: * ! 20805: * RETURN POINT ! 20806: * ! 20807: SRTF2 MOV (XS)+,XR RESTORE XR ! 20808: * ! 20809: SRTF3 EXI RETURN ! 20810: EJC ! 20811: * ! 20812: * SORTF (CONTINUED) ! 20813: * ! 20814: * CONDUCT A SEARCH ! 20815: * ! 20816: SRTF4 MOV XL,XR COPY ORIGINAL POINTER ! 20817: MOV PDDFP(XR),XR POINT TO DFBLK ! 20818: MOV XR,SRTFD KEEP A COPY ! 20819: MOV FARGS(XR),WC GET NUMBER OF FIELDS ! 20820: WTB WC CONVERT TO BAUS ! 20821: ADD DFLEN(XR),XR POINT PAST LAST FIELD ! 20822: * ! 20823: * LOOP TO FIND NAME IN PDFBLK ! 20824: * ! 20825: SRTF5 DCA WC COUNT DOWN ! 20826: DCA XR POINT IN FRONT ! 20827: BEQ (XR),SRTDF,SRTF6 SKIP OUT IF FOUND ! 20828: BNZ WC,SRTF5 LOOP ! 20829: BRN SRTF2 RETURN - NOT FOUND ! 20830: * ! 20831: * FOUND ! 20832: * ! 20833: SRTF6 MOV (XR),SRTFF KEEP FIELD NAME PTR ! 20834: ADD *PDFLD,WC ADD OFFSET TO FIRST FIELD ! 20835: MOV WC,SRTFO STORE AS FIELD OFFSET ! 20836: ADD WC,XL POINT TO FIELD ! 20837: BRN SRTF1 RETURN ! 20838: ENP PROCEDURE SORTF ! 20839: EJC ! 20840: * ! 20841: * SORTH -- HEAP ROUTINE FOR SORTA ! 20842: * ! 20843: * THIS ROUTINE CONSTRUCTS A HEAP FROM ELEMENTS OF ARRAY, A. ! 20844: * IN THIS APPLICATION, THE ELEMENTS ARE OFFSETS TO KEYS IN ! 20845: * A KEY ARRAY. ! 20846: * ! 20847: * (XS) POINTER TO SORT ARRAY BASE ! 20848: * 1(XS) POINTER TO KEY ARRAY BASE ! 20849: * (WA) MAX ARRAY INDEX, N (IN BAUS) ! 20850: * (WC) OFFSET J IN A TO ROOT (IN *1 TO *N) ! 20851: * JSR SORTH CALL SORTH(J,N) TO MAKE HEAP ! 20852: * (XL,XR,WB) DESTROYED ! 20853: * ! 20854: SORTH PRC N,0 ENTRY POINT ! 20855: MOV WA,SRTSN SAVE N ! 20856: MOV WC,SRTWC KEEP WC ! 20857: MOV (XS),XL SORT ARRAY BASE ADRS ! 20858: ADD SRTSO,XL ADD OFFSET TO A(0) ! 20859: ADD WC,XL POINT TO A(J) ! 20860: MOV (XL),SRTRT GET OFFSET TO ROOT ! 20861: ADD WC,WC DOUBLE J - CANT EXCEED N ! 20862: * ! 20863: * LOOP TO MOVE DOWN TREE USING DOUBLED INDEX J ! 20864: * ! 20865: SRH01 BGT WC,SRTSN,SRH03 DONE IF J GT N ! 20866: BEQ WC,SRTSN,SRH02 SKIP IF J EQUALS N ! 20867: MOV (XS),XR SORT ARRAY BASE ADRS ! 20868: MOV 1(XS),XL KEY ARRAY BASE ADRS ! 20869: ADD SRTSO,XR POINT TO A(0) ! 20870: ADD WC,XR ADRS OF A(J) ! 20871: MOV 1(XR),WA GET A(J+1) ! 20872: MOV (XR),WB GET A(J) ! 20873: * ! 20874: * COMPARE SONS. (WA) RIGHT SON, (WB) LEFT SON ! 20875: * ! 20876: JSR SORTC COMPARE KEYS - LT(A(J+1),A(J)) ! 20877: PPM SRH02 A(J+1) LT A(J) ! 20878: ICA WC POINT TO GREATER SON, A(J+1) ! 20879: EJC ! 20880: * ! 20881: * SORTH (CONTINUED) ! 20882: * ! 20883: * COMPARE ROOT WITH GREATER SON ! 20884: * ! 20885: SRH02 MOV 1(XS),XL KEY ARRAY BASE ADRS ! 20886: MOV (XS),XR GET SORT ARRAY ADDRESS ! 20887: ADD SRTSO,XR ADRS OF A(0) ! 20888: MOV XR,WB COPY THIS ADRS ! 20889: ADD WC,XR ADRS OF GREATER SON, A(J) ! 20890: MOV (XR),WA GET A(J) ! 20891: MOV WB,XR POINT BACK TO A(0) ! 20892: MOV SRTRT,WB GET ROOT ! 20893: JSR SORTC COMPARE THEM - LT(A(J),ROOT) ! 20894: PPM SRH03 FATHER EXCEEDS SONS - DONE ! 20895: MOV (XS),XR GET SORT ARRAY ADRS ! 20896: ADD SRTSO,XR POINT TO A(0) ! 20897: MOV XR,XL COPY IT ! 20898: MOV WC,WA COPY J ! 20899: BTW WC CONVERT TO WORDS ! 20900: RSH WC,1 GET J/2 ! 20901: WTB WC CONVERT BACK TO BAUS ! 20902: ADD WA,XL POINT TO A(J) ! 20903: ADD WC,XR ADRS OF A(J/2) ! 20904: MOV (XL),(XR) A(J/2) = A(J) ! 20905: MOV WA,WC RECOVER J ! 20906: AOV WC,WC,SRH03 J = J*2. DONE IF TOO BIG ! 20907: BRN SRH01 LOOP ! 20908: * ! 20909: * FINISH BY COPYING ROOT OFFSET BACK INTO ARRAY ! 20910: * ! 20911: SRH03 BTW WC CONVERT TO WORDS ! 20912: RSH WC,1 J = J/2 ! 20913: WTB WC CONVERT BACK TO BAUS ! 20914: MOV (XS),XR SORT ARRAY ADRS ! 20915: ADD SRTSO,XR ADRS OF A(0) ! 20916: ADD WC,XR ADRS OF A(J/2) ! 20917: MOV SRTRT,(XR) A(J/2) = ROOT ! 20918: MOV SRTSN,WA RESTORE WA ! 20919: MOV SRTWC,WC RESTORE WC ! 20920: EXI RETURN ! 20921: ENP END PROCEDURE SORTH ! 20922: EJC ! 20923: .FI ! 20924: EJC ! 20925: * ! 20926: * TFIND -- LOCATE TABLE ELEMENT ! 20927: * ! 20928: * (XR) SUBSCRIPT VALUE FOR ELEMENT ! 20929: * (XL) POINTER TO TABLE ! 20930: * (WB) ZERO BY VALUE, NON-ZERO BY NAME ! 20931: * JSR TFIND CALL TO LOCATE ELEMENT ! 20932: * PPM LOC TRANSFER LOCATION IF ACCESS FAILS ! 20933: * (XR) ELEMENT VALUE (IF BY VALUE) ! 20934: * (XR) DESTROYED (IF BY NAME) ! 20935: * (XL,WA) TEBLK NAME (IF BY NAME) ! 20936: * (XL,WA) DESTROYED (IF BY VALUE) ! 20937: * (WC,RA) DESTROYED ! 20938: * ! 20939: * NOTE THAT IF A CALL BY VALUE SPECIFIES A NON-EXISTENT ! 20940: * SUBSCRIPT, NULL IS RETURNED WITHOUT BUILDING A NEW TEBLK. ! 20941: * ! 20942: TFIND PRC E,1 ENTRY POINT ! 20943: MOV WB,-(XS) SAVE NAME/VALUE INDICATOR ! 20944: MOV XR,-(XS) SAVE SUBSCRIPT VALUE ! 20945: MOV XL,-(XS) SAVE TABLE POINTER ! 20946: MOV TBLEN(XL),WA LOAD LENGTH OF TBBLK ! 20947: BTW WA CONVERT TO WORD COUNT ! 20948: SUB =TBBUK,WA GET NUMBER OF BUCKETS ! 20949: MTI WA CONVERT TO INTEGER VALUE ! 20950: STI TFNSI SAVE FOR LATER ! 20951: MOV (XR),XL LOAD FIRST WORD OF SUBSCRIPT ! 20952: LEI XL LOAD BLOCK ENTRY ID (BL$XX) ! 20953: BSW XL,BL$$D,TFN00 SWITCH ON BLOCK TYPE ! 20954: IFF BL$IC,TFN02 JUMP IF INTEGER ! 20955: .IF .CNRA ! 20956: .ELSE ! 20957: IFF BL$RC,TFN02 REAL ! 20958: .FI ! 20959: IFF BL$P0,TFN03 JUMP IF PATTERN ! 20960: IFF BL$P1,TFN03 JUMP IF PATTERN ! 20961: IFF BL$P2,TFN03 JUMP IF PATTERN ! 20962: IFF BL$NM,TFN04 JUMP IF NAME ! 20963: IFF BL$SC,TFN05 JUMP IF STRING ! 20964: ESW END SWITCH ON BLOCK TYPE ! 20965: * ! 20966: * HERE FOR BLOCKS FOR WHICH WE USE THE SECOND WORD OF THE ! 20967: * BLOCK AS THE HASH SOURCE (SEE BLOCK FORMATS FOR DETAILS). ! 20968: * ! 20969: TFN00 MOV 1(XR),WA LOAD SECOND WORD ! 20970: * ! 20971: * MERGE HERE WITH ONE WORD HASH SOURCE IN WA ! 20972: * ! 20973: TFN01 MTI WA CONVERT TO INTEGER ! 20974: BRN TFN06 JUMP TO MERGE ! 20975: EJC ! 20976: * ! 20977: * TFIND (CONTINUED) ! 20978: * ! 20979: * HERE FOR INTEGER OR REAL ! 20980: * POSSIBILITY OF OVERFLOW EXIST ON TWOS COMPLEMENT ! 20981: * MACHINE IF HASH SOURCE IS MOST NEGATIVE INTEGER OR IS ! 20982: * A REAL HAVING THE SAME BIT PATTERN. ! 20983: * ! 20984: TFN02 LDI 1(XR) LOAD VALUE AS HASH SOURCE ! 20985: IGE TFN06 OK IF POSITIVE OR ZERO ! 20986: NGI MAKE POSITIVE ! 20987: IOV TFN06 CLEAR POSSIBLE OVERFLOW ! 20988: BRN TFN06 MERGE ! 20989: * ! 20990: * FOR PATTERN, USE FIRST WORD (PCODE) AS SOURCE ! 20991: * ! 20992: TFN03 MOV (XR),WA LOAD FIRST WORD AS HASH SOURCE ! 20993: BRN TFN01 MERGE BACK ! 20994: * ! 20995: * FOR NAME, USE OFFSET AS HASH SOURCE ! 20996: * ! 20997: TFN04 MOV NMOFS(XR),WA LOAD OFFSET AS HASH SOURCE ! 20998: BRN TFN01 MERGE BACK ! 20999: * ! 21000: * HERE FOR STRING ! 21001: * ! 21002: TFN05 JSR HASHS CALL ROUTINE TO COMPUTE HASH ! 21003: * ! 21004: * MERGE HERE WITH HASH SOURCE IN (IA) ! 21005: * ! 21006: TFN06 RMI TFNSI COMPUTE HASH INDEX BY REMAINDERING ! 21007: MFI WC GET AS ONE WORD INTEGER ! 21008: WTB WC CONVERT TO BAU OFFSET ! 21009: MOV (XS),XL GET TABLE PTR AGAIN ! 21010: ADD WC,XL POINT TO PROPER BUCKET ! 21011: MOV TBBUK(XL),XR LOAD FIRST TEBLK POINTER ! 21012: BEQ XR,(XS),TFN10 JUMP IF NO TEBLKS ON CHAIN ! 21013: * ! 21014: * LOOP THROUGH TEBLKS ON HASH CHAIN ! 21015: * ! 21016: TFN07 MOV XR,WB SAVE TEBLK POINTER ! 21017: MOV TESUB(XR),XR LOAD SUBSCRIPT VALUE ! 21018: MOV 1(XS),XL LOAD INPUT ARGUMENT SUBSCRIPT VAL ! 21019: JSR IDENT COMPARE THEM ! 21020: PPM TFN08 JUMP IF EQUAL (IDENT) ! 21021: * ! 21022: * HERE IF NO MATCH WITH THAT TEBLK ! 21023: * ! 21024: MOV WB,XL RESTORE TEBLK POINTER ! 21025: MOV TENXT(XL),XR POINT TO NEXT TEBLK ON CHAIN ! 21026: BNE XR,(XS),TFN07 JUMP IF THERE IS ONE ! 21027: * ! 21028: * HERE IF NO MATCH WITH ANY TEBLK ON CHAIN ! 21029: * ! 21030: MOV *TENXT,WC SET OFFSET TO LINK FIELD (XL BASE) ! 21031: BRN TFN11 JUMP TO MERGE ! 21032: EJC ! 21033: * ! 21034: * TFIND (CONTINUED) ! 21035: * ! 21036: * HERE WE HAVE FOUND A MATCHING ELEMENT ! 21037: * ! 21038: TFN08 MOV WB,XL RESTORE TEBLK POINTER ! 21039: MOV *TEVAL,WA SET TEBLK NAME OFFSET ! 21040: MOV 2(XS),WB RESTORE NAME/VALUE INDICATOR ! 21041: BNZ WB,TFN09 JUMP IF CALLED BY NAME ! 21042: JSR ACESS ELSE GET VALUE ! 21043: PPM TFN12 JUMP IF REFERENCE FAILS ! 21044: ZER WB RESTORE NAME/VALUE INDICATOR ! 21045: * ! 21046: * COMMON EXIT FOR ENTRY FOUND ! 21047: * ! 21048: TFN09 ADD *NUM03,XS POP STACK ENTRIES ! 21049: EXI RETURN TO TFIND CALLER ! 21050: * ! 21051: * HERE IF NO TEBLKS ON THE HASH CHAIN ! 21052: * ! 21053: TFN10 ADD *TBBUK,WC GET OFFSET TO BUCKET PTR ! 21054: MOV (XS),XL SET TBBLK PTR AS BASE ! 21055: * ! 21056: * MERGE HERE WITH (XL,WC) BASE,OFFSET OF FINAL LINK ! 21057: * ! 21058: TFN11 MOV (XS),XR TBBLK POINTER ! 21059: MOV TBINV(XR),XR LOAD DEFAULT VALUE IN CASE ! 21060: MOV 2(XS),WB LOAD NAME/VALUE INDICATOR ! 21061: BZE WB,TFN09 EXIT WITH DEFAULT IF VALUE CALL ! 21062: MOV XR,WB COPY DEFAULT VALUE ! 21063: * ! 21064: * HERE WE MUST BUILD A NEW TEBLK ! 21065: * ! 21066: MOV *TESI$,WA SET SIZE OF TEBLK ! 21067: JSR ALLOC ALLOCATE TEBLK ! 21068: ADD WC,XL POINT TO HASH LINK ! 21069: MOV XR,(XL) LINK NEW TEBLK AT END OF CHAIN ! 21070: MOV =B$TET,(XR) STORE TYPE WORD ! 21071: MOV WB,TEVAL(XR) SET DEFAULT AS INITIAL VALUE ! 21072: MOV (XS)+,TENXT(XR) SET TBBLK PTR TO MARK END OF CHAIN ! 21073: MOV (XS)+,TESUB(XR) STORE SUBSCRIPT VALUE ! 21074: MOV (XS)+,WB RESTORE NAME/VALUE INDICATOR ! 21075: MOV XR,XL COPY TEBLK POINTER (NAME BASE) ! 21076: MOV *TEVAL,WA SET OFFSET ! 21077: EXI RETURN TO CALLER WITH NEW TEBLK ! 21078: * ! 21079: * ACESS FAIL RETURN ! 21080: * ! 21081: TFN12 EXI 1 ALTERNATIVE RETURN ! 21082: ENP END PROCEDURE TFIND ! 21083: EJC ! 21084: * ! 21085: * TRACE -- SET/RESET A TRACE ASSOCIATION ! 21086: * ! 21087: * THIS PROCEDURE IS SHARED BY TRACE AND STOPTR TO ! 21088: * EITHER INITIATE OR STOP A TRACE RESPECTIVELY. ! 21089: * ! 21090: * (XL) TRBLK PTR (TRACE) OR ZERO (STOPTR) ! 21091: * 1(XS) FIRST ARGUMENT (NAME) ! 21092: * 0(XS) SECOND ARGUMENT (TRACE TYPE) ! 21093: * JSR TRACE CALL TO SET/RESET TRACE ! 21094: * PPM LOC TRANSFER LOC IF 1ST ARG IS BAD NAME ! 21095: * PPM LOC TRANSFER LOC IF 2ND ARG IS BAD TYPE ! 21096: * PPM LOC FAIL STOPTR IF NON-EXISTENT TRACE ! 21097: * (XS) POPPED ! 21098: * (XL,XR,WA,WB,WC,IA) DESTROYED ! 21099: * ! 21100: TRACE PRC N,3 ENTRY POINT ! 21101: JSR GTSTG GET TRACE TYPE STRING ! 21102: PPM TRC15 JUMP IF NOT STRING ! 21103: PLC XR ELSE POINT TO STRING ! 21104: LCH WA,(XR) LOAD FIRST CHARACTER ! 21105: .IF .CASL ! 21106: BLT WA,=CH$$A,TRC00 SKIP IF NOT LOWER CASE ! 21107: SUB =DFA$A,WA CONVERT LOWER TO UPPER CASE ! 21108: * ! 21109: * HERE WITH UPPER CASE TRACE TYPE CODE ! 21110: * ! 21111: TRC00 MOV (XS),XR LOAD NAME ARGUMENT ! 21112: .ELSE ! 21113: MOV (XS),XR LOAD NAME ARGUMENT ! 21114: .FI ! 21115: MOV XL,(XS) STACK TRBLK PTR OR ZERO ! 21116: MOV =TRTAC,WC SET TRTYP FOR ACCESS TRACE ! 21117: BEQ WA,=CH$LA,TRC10 JUMP IF A (ACCESS) ! 21118: MOV =TRTVL,WC SET TRTYP FOR VALUE TRACE ! 21119: BEQ WA,=CH$LV,TRC10 JUMP IF V (VALUE) ! 21120: BEQ WA,=CH$BL,TRC10 JUMP IF BLANK (VALUE) ! 21121: * ! 21122: * HERE FOR L,K,F,C,R ! 21123: * ! 21124: BEQ WA,=CH$LF,TRC01 JUMP IF F (FUNCTION) ! 21125: BEQ WA,=CH$LR,TRC01 JUMP IF R (RETURN) ! 21126: BEQ WA,=CH$LL,TRC03 JUMP IF L (LABEL) ! 21127: BEQ WA,=CH$LK,TRC06 JUMP IF K (KEYWORD) ! 21128: BNE WA,=CH$LC,TRC15 ELSE ERROR IF NOT C (CALL) ! 21129: * ! 21130: * HERE FOR F,C,R ! 21131: * ! 21132: TRC01 JSR GTNVR POINT TO VRBLK FOR NAME ! 21133: PPM TRC16 JUMP IF BAD NAME ! 21134: ICA XS POP STACK ! 21135: MOV VRFNC(XR),XR POINT TO FUNCTION BLOCK ! 21136: BNE (XR),=B$PFC,TRC17 ERROR IF NOT PROGRAM FUNCTION ! 21137: MOV XL,WB COPY TRBLK PTR OR 0 ! 21138: BEQ WA,=CH$LR,TRC02 JUMP IF R (RETURN) ! 21139: EJC ! 21140: * ! 21141: * TRACE (CONTINUED) ! 21142: * ! 21143: * HERE FOR F,C TO SET/RESET CALL TRACE ! 21144: * ! 21145: ORB PFCTR(XR),WB STOPTR FAIL CHECK ! 21146: MOV XL,PFCTR(XR) SET/RESET CALL TRACE ! 21147: BEQ WA,=CH$LC,TRC11 RETURN IF LETTER C ! 21148: * ! 21149: * HERE FOR F,R TO SET/RESET RETURN TRACE ! 21150: * ! 21151: TRC02 ORB PFRTR(XR),WB STOPTR FAIL CHECK ! 21152: MOV XL,PFRTR(XR) SET/RESET RETURN TRACE ! 21153: BRN TRC11 RETURN ! 21154: * ! 21155: * HERE FOR L TO SET/RESET LABEL TRACE ! 21156: * ! 21157: TRC03 JSR GTNVR POINT TO VRBLK ! 21158: PPM TRC16 JUMP IF BAD NAME ! 21159: MOV (XS)+,WB GET TRBLK OR ZERO ! 21160: MOV VRLBL(XR),XL LOAD LABEL POINTER ! 21161: BNE (XL),=B$TRT,TRC04 JUMP IF NO OLD TRACE ! 21162: MOV TRLBL(XL),XL ELSE DELETE OLD TRACE ASSOCIATION ! 21163: BRN TRCA4 MERGE ! 21164: * ! 21165: * HERE WITH OLD LABEL TRACE ASSOCIATION DELETED ! 21166: * ! 21167: TRC04 BZE WB,TRC12 FAIL IF STOPTR OF UNTRACED LABEL ! 21168: * ! 21169: * TEST FOR UNDEFINED LABEL ! 21170: * ! 21171: TRCA4 BEQ XL,=STNDL,TRC17 ERROR IF UNDEFINED LABEL ! 21172: BZE WB,TRC05 JUMP IF STOPTR CASE ! 21173: MOV WB,VRLBL(XR) ELSE SET NEW TRBLK POINTER ! 21174: MOV =B$VRT,VRTRA(XR) SET LABEL TRACE ROUTINE ADDRESS ! 21175: MOV WB,XR COPY TRBLK POINTER ! 21176: MOV XL,TRLBL(XR) STORE REAL LABEL IN TRBLK ! 21177: EXI RETURN ! 21178: * ! 21179: * HERE FOR STOPTR CASE FOR LABEL ! 21180: * ! 21181: TRC05 MOV XL,VRLBL(XR) STORE LABEL PTR BACK IN VRBLK ! 21182: MOV =B$VRG,VRTRA(XR) STORE NORMAL TRANSFER ADDRESS ! 21183: EXI RETURN ! 21184: EJC ! 21185: * ! 21186: * TRACE (CONTINUED) ! 21187: * ! 21188: * HERE FOR K (KEYWORD) ! 21189: * ! 21190: TRC06 JSR GTNVR POINT TO VRBLK ! 21191: PPM TRC16 ERROR IF NOT NATURAL VAR ! 21192: BNZ VRLEN(XR),TRC16 ERROR IF NOT SYSTEM VAR ! 21193: ICA XS POP STACK ! 21194: BZE XL,TRC07 JUMP IF STOPTR CASE ! 21195: MOV XR,TRKVR(XL) STORE VRBLK PTR IN TRBLK FOR KTREX ! 21196: * ! 21197: * MERGE HERE WITH TRBLK SET UP IN XL (OR ZERO) ! 21198: * ! 21199: TRC07 MOV VRSVP(XR),XR POINT TO SVBLK ! 21200: MOV XL,WB COPY TRBLK PR OR 0 ! 21201: BEQ XR,=V$ERT,TRC08 JUMP IF ERRTYPE ! 21202: BEQ XR,=V$STC,TRC09 JUMP IF STCOUNT ! 21203: BNE XR,=V$FNC,TRC17 ELSE ERROR IF NOT FNCLEVEL ! 21204: * ! 21205: * FNCLEVEL ! 21206: * ! 21207: ORB R$FNC,WB STOPTR FAIL CHECK ! 21208: MOV XL,R$FNC SET/RESET FNCLEVEL TRACE ! 21209: BRN TRC11 RETURN ! 21210: * ! 21211: * ERRTYPE ! 21212: * ! 21213: TRC08 ORB R$ERT,WB STOPTR FAIL CHECK ! 21214: MOV XL,R$ERT SET/RESET ERRTYPE TRACE ! 21215: BRN TRC11 RETURN ! 21216: * ! 21217: * STCOUNT ! 21218: * ! 21219: TRC09 ORB R$STC,WB STOPTR FAIL CHECK ! 21220: MOV XL,R$STC SET/RESET STCOUNT TRACE ! 21221: BRN TRC11 RETURN ! 21222: EJC ! 21223: * ! 21224: * TRACE (CONTINUED) ! 21225: * ! 21226: * A,V MERGE HERE WITH TRTYP VALUE IN WC ! 21227: * ! 21228: TRC10 JSR GTVAR LOCATE VARIABLE ! 21229: PPM TRC16 ERROR IF NOT APPROPRIATE NAME ! 21230: MOV (XS)+,XR GET NEW TRBLK PTR AGAIN ! 21231: MOV WC,WB COPY TRACE TYPE ! 21232: JSR TRCHN UPDATE TRACE CHAIN ! 21233: PPM TRC12 FAIL ! 21234: EXI RETURN ! 21235: * ! 21236: * RETURN AFTER CHECKING STOPTR FAIL CONDITION (WB = 0) ! 21237: * ! 21238: TRC11 ZRB WB,TRC12 FAIL IF NECESSARY ! 21239: EXI ELSE RETURN ! 21240: * ! 21241: * FAIL STOPTR ! 21242: * ! 21243: TRC12 EXI 3 FAIL RETURN ! 21244: * ! 21245: * HERE FOR BAD TRACE TYPE ! 21246: * ! 21247: TRC15 EXI 2 TAKE BAD TRACE TYPE ERROR EXIT ! 21248: * ! 21249: * POP STACK BEFORE FAILING ! 21250: * ! 21251: TRC16 ICA XS POP STACK ! 21252: * ! 21253: * HERE FOR BAD NAME ARGUMENT ! 21254: * ! 21255: TRC17 EXI 1 TAKE BAD NAME ERROR EXIT ! 21256: ENP END PROCEDURE TRACE ! 21257: EJC ! 21258: * ! 21259: * TRBLD -- BUILD TRBLK ! 21260: * ! 21261: * TRBLK IS USED BY THE INPUT, OUTPUT AND TRACE FUNCTIONS ! 21262: * TO CONSTRUCT A TRBLK (TRAP BLOCK) ! 21263: * ! 21264: * (XR) TRTAG OR TRTER ! 21265: * (XL) TRFNC OR TRTRI ! 21266: * (WB) TRTYP ! 21267: * JSR TRBLD CALL TO BUILD TRBLK ! 21268: * (XR) POINTER TO TRBLK ! 21269: * (WA) DESTROYED ! 21270: * ! 21271: TRBLD PRC E,0 ENTRY POINT ! 21272: MOV XR,-(XS) STACK TRTAG (OR TRFNM) ! 21273: MOV *TRSI$,WA SET SIZE OF TRBLK ! 21274: JSR ALLOC ALLOCATE TRBLK ! 21275: MOV =B$TRT,(XR) STORE FIRST WORD ! 21276: MOV XL,TRFNC(XR) STORE TRFNC (OR TRTRI) ! 21277: MOV (XS)+,TRTAG(XR) STORE TRTAG (OR TRTER) ! 21278: MOV WB,TRTYP(XR) STORE TYPE ! 21279: MOV =NULLS,TRVAL(XR) FOR NOW, A NULL VALUE ! 21280: EXI RETURN TO CALLER ! 21281: ENP END PROCEDURE TRBLD ! 21282: EJC ! 21283: * ! 21284: * TRCHN -- UPDATE TRACE BLOCK CHAIN ! 21285: * ! 21286: * CALLED WHEN A TRACE BLOCK CHAIN IS TO BE UPDATED BY ! 21287: * ADDITION OR REMOVAL OF A TRBLK. ! 21288: * IF A TRBLK OF THE SAME TYPE AS AN ADDITION IS ALREADY ! 21289: * PRESENT IT IS DELETED. THE TRTAG FIELD OF ANY DELETED ! 21290: * TRBLK IS CLEARED AS REQUIRED BY S$ENF. ! 21291: * ! 21292: * (XL,WA) POINTER, OFFSET TO TRACED VARIABLE ! 21293: * (XR) PTR TO NEW TRBLK OR 0 FOR REMOVAL ! 21294: * (WB) TRACE TYPE (TRTYP) ! 21295: * JSR TRCHN CALL TO UPDATE TRACE CHAIN ! 21296: * PPM LOC NO TRACE BLK OF REQD DELETION TYPE ! 21297: * (WA,WC) DESTROYED ! 21298: * ! 21299: TRCHN PRC E,1 ENTRY POINT ! 21300: ADD XL,WA KEEP POINTER TO TRACED LOCATION ! 21301: MOV WA,XL COPY POINTER ! 21302: SUB *TRNXT,XL ADJUST OFFSET BEFORE ENTERING LOOP ! 21303: MOV XR,WC COPY TRBLK PTR ! 21304: * ! 21305: * LOOP TO FIND TRACE BLOCK ! 21306: * ! 21307: TRCH1 MOV XL,XR COPY SO XR POINTS TO PREDECESSOR ! 21308: MOV TRNXT(XL),XL POINT TO POSSIBLE TRACE BLOCK ! 21309: BNE (XL),=B$TRT,TRCH2 SKIP OUT AT CHAIN END ! 21310: BLT WB,TRTYP(XL),TRCH2 SKIP IF TOO FAR OUT ON CHAIN ! 21311: BNE WB,TRTYP(XL),TRCH1 LOOP UNLESS TYPE MATCHES ! 21312: MOV TRNXT(XL),TRNXT(XR) REMOVE LINK TO OLD TRBLK ! 21313: ZER TRTAG(XL) CLEAR IOTAG FIELD OF DELETED BLOCK ! 21314: BZE WC,TRCH3 DONE IF NO NEW TRBLK ! 21315: * ! 21316: * OLD TRBLK REMOVED AND/OR END OF CHAIN REACHED ! 21317: * ! 21318: TRCH2 BZE WC,TRCH4 FAIL IF REQD BLOCK TYPE NOT FOUND ! 21319: MOV WC,XL POINT TO NEW TRBLK ! 21320: MOV TRNXT(XR),TRNXT(XL) ATTACH TAIL OF CHAIN TO IT ! 21321: MOV WC,TRNXT(XR) LINK NEW BLOCK IN ! 21322: MOV WB,TRTYP(XL) ENSURE TRTYP FIELD SET UP ! 21323: * ! 21324: * UPDATE ACCESS FIELDS OF NAME IF IT IS A VRBLK ! 21325: * ! 21326: TRCH3 MOV WA,XR POINT TO VBL ! 21327: SUB *VRVAL,XR ADJUST TO POSSIBLE VRBLK NAME BASE ! 21328: JSR SETVR UPDATE ACCESS FIELDS ! 21329: MOV WA,XL RECOVER XL ! 21330: MOV WC,XR RECOVER XR ! 21331: EXI RETURN TO CALLER ! 21332: * ! 21333: * FAIL RETURN ! 21334: * ! 21335: TRCH4 MOV WA,XL RECOVER XL ! 21336: MOV WC,XR RECOVER XR ! 21337: EXI 1 FAIL ! 21338: ENP END PROCEDURE TRCHN ! 21339: EJC ! 21340: * ! 21341: * TRIMR -- TRIM TRAILING BLANKS ! 21342: * ! 21343: * TRIMR IS PASSED A POINTER TO AN SCBLK WHICH MUST BE THE ! 21344: * LAST BLOCK IN DYNAMIC STORAGE. TRAILING BLANKS ARE ! 21345: * TRIMMED OFF AND THE DYNAMIC STORAGE POINTER RESET TO ! 21346: * THE END OF THE (POSSIBLY) SHORTENED BLOCK. ! 21347: * ! 21348: * (WB) NON-ZERO TO TRIM TRAILING BLANKS ! 21349: * (XR) POINTER TO STRING TO TRIM ! 21350: * JSR TRIMR CALL TO TRIM STRING ! 21351: * (XR) POINTER TO TRIMMED STRING ! 21352: * (XL,WA,WB,WC) DESTROYED ! 21353: * ! 21354: * THE CALL WITH WB ZERO STILL PERFORMS THE END ZERO PAD ! 21355: * AND DNAMP READJUSTMENT. IT IS USED FROM ACESS IF KVTRM=0. ! 21356: * ! 21357: TRIMR PRC E,0 ENTRY POINT ! 21358: MOV XR,XL COPY STRING POINTER ! 21359: MOV SCLEN(XR),WA LOAD STRING LENGTH ! 21360: BZE WA,TRIM2 JUMP IF NULL INPUT ! 21361: PLC XL,WA ELSE POINT PAST LAST CHARACTER ! 21362: BZE WB,TRIM3 JUMP IF NO TRIM ! 21363: MOV =CH$BL,WC LOAD BLANK CHARACTER ! 21364: * ! 21365: * LOOP THROUGH CHARACTERS FROM RIGHT TO LEFT ! 21366: * ! 21367: TRIM0 LCH WB,-(XL) LOAD NEXT CHARACTER ! 21368: .IF .CAHT ! 21369: BEQ WB,=CH$HT,TRIM1 JUMP IF HORIZONTAL TAB ! 21370: .FI ! 21371: BNE WB,WC,TRIM3 JUMP IF NON-BLANK FOUND ! 21372: TRIM1 DCV WA ELSE DECREMENT CHARACTER COUNT ! 21373: BNZ WA,TRIM0 LOOP BACK IF MORE TO CHECK ! 21374: * ! 21375: * HERE IF RESULT IS NULL (NULL OR ALL-BLANK INPUT) ! 21376: * ! 21377: TRIM2 MOV XR,DNAMP WIPE OUT INPUT STRING BLOCK ! 21378: MOV =NULLS,XR LOAD NULL RESULT ! 21379: BRN TRIM5 MERGE TO EXIT ! 21380: EJC ! 21381: * ! 21382: * TRIMR (CONTINUED) ! 21383: * ! 21384: * HERE WITH NON-BLANK FOUND (MERGE FOR NO TRIM) ! 21385: * ! 21386: TRIM3 MOV WA,SCLEN(XR) SET NEW LENGTH ! 21387: MOV XR,XL COPY STRING POINTER ! 21388: PSC XL,WA READY FOR STORING ZEROES ! 21389: CTB WA,SCHAR GET LENGTH OF BLOCK IN BAUS ! 21390: ADD XR,WA POINT PAST NEW BLOCK ! 21391: MOV WA,DNAMP SET NEW TOP OF STORAGE POINTER ! 21392: LCT WA,=CFP$C GET COUNT OF CHARS IN WORD ! 21393: ZER WC SET ZERO CHAR ! 21394: * ! 21395: * LOOP TO ZERO PAD LAST WORD OF CHARACTERS ! 21396: * ! 21397: TRIM4 SCH WC,(XL)+ STORE ZERO CHARACTER ! 21398: BCT WA,TRIM4 LOOP BACK TILL ALL STORED ! 21399: CSC XL COMPLETE STORE CHARACTERS ! 21400: * ! 21401: * COMMON EXIT POINT ! 21402: * ! 21403: TRIM5 ZER XL CLEAR GARBAGE XL POINTER ! 21404: EXI RETURN TO CALLER ! 21405: ENP END PROCEDURE TRIMR ! 21406: EJC ! 21407: * ! 21408: * TRXEQ -- EXECUTE FUNCTION TYPE TRACE ! 21409: * ! 21410: * TRXEQ IS USED TO EXECUTE A TRACE WHEN A FOURTH ARGUMENT ! 21411: * HAS BEEN SUPPLIED. TRACE HAS ALREADY BEEN DECREMENTED. ! 21412: * ! 21413: * (XR) POINTER TO TRBLK ! 21414: * (XL,WA) NAME BASE,OFFSET FOR VARIABLE ! 21415: * JSR TRXEQ CALL TO EXECUTE TRACE ! 21416: * (WB,WC,RA) DESTROYED ! 21417: * ! 21418: * THE FOLLOWING STACK ENTRIES ARE MADE BEFORE PASSING ! 21419: * CONTROL TO THE TRACE FUNCTION USING THE CFUNC ROUTINE. ! 21420: * ! 21421: * TRXEQ RETURN POINT WORD(S) ! 21422: * SAVED VALUE OF TRACE KEYWORD ! 21423: * TRBLK POINTER ! 21424: * NAME BASE ! 21425: * NAME OFFSET ! 21426: * SAVED VALUE OF R$COD ! 21427: * SAVED CODE PTR (-R$COD) ! 21428: * SAVED VALUE OF FLPTR ! 21429: * FLPTR --------------- ZERO (DUMMY FAIL OFFSET) ! 21430: * NMBLK FOR VARIABLE NAME ! 21431: * XS ------------------ TRACE TAG ! 21432: * ! 21433: * R$COD AND THE CODE PTR ARE SET TO DUMMY VALUES WHICH ! 21434: * CAUSE CONTROL TO RETURN TO THE TRXEQ PROCEDURE ON SUCCESS ! 21435: * OR FAILURE (TRXEQ IGNORES A FAILURE CONDITION). ! 21436: * ! 21437: TRXEQ PRC R,0 ENTRY POINT (RECURSIVE) ! 21438: MOV R$COD,WC LOAD CODE BLOCK POINTER ! 21439: SCP WB GET CURRENT CODE POINTER ! 21440: SUB WC,WB MAKE CODE POINTER INTO OFFSET ! 21441: MOV KVTRA,-(XS) STACK TRACE KEYWORD VALUE ! 21442: MOV XR,-(XS) STACK TRBLK POINTER ! 21443: MOV XL,-(XS) STACK NAME BASE ! 21444: MOV WA,-(XS) STACK NAME OFFSET ! 21445: MOV WC,-(XS) STACK CODE BLOCK POINTER ! 21446: MOV WB,-(XS) STACK CODE POINTER OFFSET ! 21447: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER ! 21448: ZER -(XS) SET DUMMY FAIL OFFSET ! 21449: MOV XS,FLPTR SET NEW FAILURE POINTER ! 21450: ZER KVTRA RESET TRACE KEYWORD TO ZERO ! 21451: MOV =TRXDC,WC LOAD NEW (DUMMY) CODE BLK POINTER ! 21452: MOV WC,R$COD SET AS CODE BLOCK POINTER ! 21453: LCP WC AND NEW CODE POINTER ! 21454: EJC ! 21455: * ! 21456: * TRXEQ (CONTINUED) ! 21457: * ! 21458: * NOW PREPARE ARGUMENTS FOR FUNCTION ! 21459: * ! 21460: MOV WA,WB SAVE NAME OFFSET ! 21461: MOV *NMSI$,WA LOAD NMBLK SIZE ! 21462: JSR ALLOC ALLOCATE SPACE FOR NMBLK ! 21463: MOV =B$NML,(XR) SET TYPE WORD ! 21464: MOV XL,NMBAS(XR) STORE NAME BASE ! 21465: MOV WB,NMOFS(XR) STORE NAME OFFSET ! 21466: MOV 6(XS),XL RELOAD POINTER TO TRBLK ! 21467: MOV XR,-(XS) STACK NMBLK POINTER (1ST ARGUMENT) ! 21468: MOV TRTAG(XL),-(XS) STACK TRACE TAG (2ND ARGUMENT) ! 21469: MOV TRFNC(XL),XL LOAD TRACE FUNCTION POINTER ! 21470: MOV =NUM02,WA SET NUMBER OF ARGUMENTS TO TWO ! 21471: BRN CFUNC JUMP TO CALL FUNCTION ! 21472: * ! 21473: * SEE O$TXR FOR DETAILS OF RETURN TO THIS POINT ! 21474: * ! 21475: TRXQR MOV FLPTR,XS POINT BACK TO OUR STACK ENTRIES ! 21476: ICA XS POP OFF GARBAGE FAIL OFFSET ! 21477: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER ! 21478: MOV (XS)+,WB RELOAD CODE OFFSET ! 21479: MOV (XS)+,WC LOAD OLD CODE BASE POINTER ! 21480: MOV WC,XR COPY CDBLK POINTER ! 21481: MOV CDSTM(XR),KVSTN RESTORE STMNT NO ! 21482: MOV (XS)+,WA RELOAD NAME OFFSET ! 21483: MOV (XS)+,XL RELOAD NAME BASE ! 21484: MOV (XS)+,XR RELOAD TRBLK POINTER ! 21485: MOV (XS)+,KVTRA RESTORE TRACE KEYWORD VALUE ! 21486: ADD WC,WB RECOMPUTE ABSOLUTE CODE POINTER ! 21487: LCP WB RESTORE CODE POINTER ! 21488: MOV WC,R$COD AND CODE BLOCK POINTER ! 21489: EXI RETURN TO TRXEQ CALLER ! 21490: ENP END PROCEDURE TRXEQ ! 21491: EJC ! 21492: * ! 21493: * XSCAN -- EXECUTION FUNCTION ARGUMENT SCAN ! 21494: * ! 21495: * XSCAN SCANS OUT ONE TOKEN IN A PROTOTYPE ARGUMENT IN ! 21496: * ARRAY,CLEAR,DATA,DEFINE,LOAD FUNCTION CALLS. XSCAN ! 21497: * CALLS MUST BE PRECEDED BY A CALL TO THE INITIALIZATION ! 21498: * PROCEDURE XSCNI. THE FOLLOWING VARIABLES ARE USED. ! 21499: * ! 21500: * R$XSC POINTER TO SCBLK FOR FUNCTION ARG ! 21501: * XSOFS OFFSET (NUM CHARS SCANNED SO FAR) ! 21502: * ! 21503: * (WC) DELIMITER ONE (CH$XX) ! 21504: * (XL) DELIMITER TWO (CH$XX) ! 21505: * JSR XSCAN CALL TO SCAN NEXT ITEM ! 21506: * (XR) POINTER TO SCBLK FOR TOKEN SCANNED ! 21507: * (WA) COMPLETION CODE (SEE BELOW) ! 21508: * (WC,XL) DESTROYED ! 21509: * (XSCNB) ERROR INDICATOR - SEE 4) BELOW ! 21510: * ! 21511: * LEADING BLANKS AND TRAILING BLANKS POSITIONED BEFORE A ! 21512: * DELIMITER OR AT THE END OF THE ARGUMENT STRING ARE ! 21513: * IGNORED. OTHER BLANKS ARE ILLEGAL. ! 21514: * THE SCAN STARTS FROM THE CURRENT POSITION AND CONTINUES ! 21515: * UNTIL ONE OF THE FOLLOWING CONDITIONS OCCURS. ! 21516: * ! 21517: * 1) DELIMITER ONE IS ENCOUNTERED (WA SET TO 1) ! 21518: * ! 21519: * 2) DELIMITER TWO ENCOUNTERED (WA SET TO 2) ! 21520: * ! 21521: * 3) END OF STRING ENCOUNTERED (WA AND XSCNB SET TO 0) ! 21522: * ! 21523: * 4) ILLEGAL BLANK (WA 0, XSCNB NON-ZERO) ! 21524: * ! 21525: * THE RESULT IS A STRING CONTAINING ALL CHARACTERS SCANNED ! 21526: * UP TO BUT NOT INCLUDING ANY DELIMITER CHARACTER. ! 21527: * THE POINTER IS LEFT POINTING PAST THE DELIMITER. ! 21528: * ! 21529: * IF ONLY ONE DELIMITER IS TO BE DETECTED, DELIMITER ONE ! 21530: * AND DELIMITER TWO SHOULD BE SET TO THE SAME VALUE. ! 21531: * ! 21532: * IN THE CASE WHERE THE END OF STRING IS ENCOUNTERED, THE ! 21533: * STRING INCLUDES ALL THE CHARACTERS TO THE END OF THE ! 21534: * STRING. NO FURTHER CALLS CAN BE MADE TO XSCAN UNTIL ! 21535: * XSCNI IS CALLED TO INITIALIZE A NEW ARGUMENT SCAN ! 21536: EJC ! 21537: * ! 21538: * XSCAN (CONTINUED) ! 21539: * ! 21540: XSCAN PRC E,0 ENTRY POINT ! 21541: MOV WB,XSCWB PRESERVE WB ! 21542: ZER XSCBL CLEAR COUNT OF TRAILING BLANKS ! 21543: ZER XSCNB CLEAR NON-BLANK SEEN FLAG ! 21544: MOV R$XSC,XR POINT TO ARGUMENT STRING ! 21545: MOV SCLEN(XR),WA LOAD STRING LENGTH ! 21546: MOV XSOFS,WB LOAD CURRENT OFFSET ! 21547: SUB WB,WA GET NUMBER OF REMAINING CHARACTERS ! 21548: BZE WA,XSCN2 JUMP IF NO CHARACTERS LEFT ! 21549: PLC XR,WB POINT TO CURRENT CHARACTER ! 21550: * ! 21551: * LOOP TO SEARCH FOR DELIMITER ! 21552: * ! 21553: XSCN0 LCH WB,(XR)+ LOAD NEXT CHARACTER ! 21554: BEQ WB,WC,XSCN3 JUMP IF DELIMITER ONE FOUND ! 21555: BEQ WB,XL,XSCN4 JUMP IF DELIMITER TWO FOUND ! 21556: BEQ WB,=CH$BL,XSCN7 SKIP IF IT IS A BLANK ! 21557: .IF .CAHT ! 21558: BEQ WB,=CH$HT,XSCN7 SKIP IF IT IS A TAB ! 21559: .FI ! 21560: BNZ XSCBL,XSCN2 FAIL CHAR AFTER TRAILING BLANK ! 21561: MNZ XSCNB NOTE A NON-BLANK SEEN ! 21562: * ! 21563: * COUNT CHARS DONE ! 21564: * ! 21565: XSCN1 DCV WA DECREMENT COUNT OF CHARS LEFT ! 21566: BNZ WA,XSCN0 LOOP BACK IF MORE CHARS TO GO ! 21567: ZER XSCNB CLEAR ERRONEOUS BLANKS FLAG ! 21568: * ! 21569: * HERE FOR RUNOUT ! 21570: * ! 21571: XSCN2 MOV R$XSC,XL POINT TO STRING BLOCK ! 21572: MOV SCLEN(XL),WA GET STRING LENGTH ! 21573: MOV XSOFS,WB LOAD OFFSET ! 21574: SUB WB,WA GET SUBSTRING LENGTH ! 21575: SUB XSCBL,WA ADJUST FOR TRAILING BLANKS ! 21576: ZER R$XSC CLEAR STRING PTR FOR COLLECTOR ! 21577: ZER XSCRT SET ZERO (RUNOUT) RETURN CODE ! 21578: BRN XSCN6 JUMP TO EXIT ! 21579: EJC ! 21580: * ! 21581: * XSCAN (CONTINUED) ! 21582: * ! 21583: * HERE IF DELIMITER ONE FOUND ! 21584: * ! 21585: XSCN3 MOV =NUM01,XSCRT SET RETURN CODE ! 21586: BRN XSCN5 JUMP TO MERGE ! 21587: * ! 21588: * HERE IF DELIMITER TWO FOUND ! 21589: * ! 21590: XSCN4 MOV =NUM02,XSCRT SET RETURN CODE ! 21591: * ! 21592: * MERGE HERE AFTER DETECTING A DELIMITER ! 21593: * ! 21594: XSCN5 MOV R$XSC,XL RELOAD POINTER TO STRING ! 21595: MOV SCLEN(XL),WC GET ORIGINAL LENGTH OF STRING ! 21596: SUB WA,WC MINUS CHARS LEFT = CHARS SCANNED ! 21597: MOV WC,WA MOVE TO REG FOR SBSTR ! 21598: SUB XSCBL,WA ADJUST FOR TRAILING BLANKS ! 21599: MOV XSOFS,WB SET OFFSET ! 21600: SUB WB,WA COMPUTE LENGTH FOR SBSTR ! 21601: ICV WC ADJUST NEW CURSOR PAST DELIMITER ! 21602: MOV WC,XSOFS STORE NEW OFFSET ! 21603: * ! 21604: * COMMON EXIT POINT ! 21605: * ! 21606: XSCN6 ZER XR CLEAR GARBAGE CHARACTER PTR IN XR ! 21607: .IF .CASL ! 21608: JSR SBSTG BUILD SUBSTRING ! 21609: .ELSE ! 21610: JSR SBSTR BUILD SUB-STRING ! 21611: .FI ! 21612: MOV XSCRT,WA LOAD RETURN CODE ! 21613: MOV XSCWB,WB RESTORE WB ! 21614: EXI RETURN TO XSCAN CALLER ! 21615: * ! 21616: * DEAL WITH BLANK ! 21617: * ! 21618: XSCN7 BZE XSCNB,XSCN8 SKIP IF LEADING BLANK ! 21619: ICV XSCBL ELSE COUNT TRAILING BLANK ! 21620: BRN XSCN1 LOOP ! 21621: * ! 21622: * LEADING BLANK ! 21623: * ! 21624: XSCN8 ICV XSOFS PUSH OFFSET PAST BLANK ! 21625: BRN XSCN1 LOOP ! 21626: ENP END PROCEDURE XSCAN ! 21627: EJC ! 21628: * ! 21629: * XSCNI -- EXECUTION FUNCTION ARGUMENT SCAN ! 21630: * ! 21631: * XSCNI INITIALIZES THE SCAN USED FOR PROTOTYPE ARGUMENTS ! 21632: * IN THE CLEAR, DEFINE, LOAD, DATA, ARRAY FUNCTIONS. SEE ! 21633: * XSCAN FOR THE PROCEDURE WHICH IS USED AFTER THIS CALL. ! 21634: * ! 21635: * -(XS) ARGUMENT TO BE SCANNED (ON STACK) ! 21636: * JSR XSCNI CALL TO SCAN ARGUMENT ! 21637: * PPM LOC TRANSFER LOC IF ARG IS NOT STRING ! 21638: * PPM LOC TRANSFER LOC IF ARGUMENT IS NULL ! 21639: * (XS) POPPED ! 21640: * (XR,R$XSC) ARGUMENT (SCBLK PTR) ! 21641: * (WA) ARGUMENT LENGTH ! 21642: * (IA,RA) DESTROYED ! 21643: * ! 21644: XSCNI PRC N,2 ENTRY POINT ! 21645: JSR GTSTG FETCH ARGUMENT AS STRING ! 21646: PPM XSCI1 JUMP IF NOT CONVERTIBLE ! 21647: MOV XR,R$XSC ELSE STORE SCBLK PTR FOR XSCAN ! 21648: ZER XSOFS SET OFFSET TO ZERO ! 21649: BZE WA,XSCI2 JUMP IF NULL STRING ! 21650: EXI RETURN TO XSCNI CALLER ! 21651: * ! 21652: * HERE IF ARGUMENT IS NOT A STRING ! 21653: * ! 21654: XSCI1 EXI 1 TAKE NOT-STRING ERROR EXIT ! 21655: * ! 21656: * HERE FOR NULL STRING ! 21657: * ! 21658: XSCI2 EXI 2 TAKE NULL-STRING ERROR EXIT ! 21659: ENP END PROCEDURE XSCNI ! 21660: TTL S P I T B O L -- UTILITY ROUTINES ! 21661: * ! 21662: * THE FOLLOWING SECTION CONTAINS UTILITY ROUTINES USED FOR ! 21663: * VARIOUS PURPOSES THROUGHOUT THE SYSTEM. THESE DIFFER ! 21664: * FROM THE PROCEDURES IN THE UTILITY PROCEDURES SECTION IN ! 21665: * THEY ARE NOT IN PROCEDURE FORM AND THEY DO NOT RETURN ! 21666: * TO THEIR CALLERS. THEY ARE ACCESSED WITH A BRANCH TYPE ! 21667: * INSTRUCTION AFTER SETTING THE REGISTERS TO APPROPRIATE ! 21668: * PARAMETER VALUES. ! 21669: * ! 21670: * THE REGISTER VALUES REQUIRED FOR EACH ROUTINE ARE ! 21671: * DOCUMENTED AT THE START OF EACH ROUTINE. REGISTERS NOT ! 21672: * MENTIONED MAY CONTAIN ANY VALUES EXCEPT THAT XR,XL ! 21673: * CAN ONLY CONTAIN PROPER COLLECTABLE POINTERS. ! 21674: * ! 21675: * SOME OF THESE ROUTINES WILL TOLERATE GARBAGE POINTERS ! 21676: * IN XL,XR ON ENTRY. THIS IS ALWAYS DOCUMENTED AND IN ! 21677: * EACH CASE, THE ROUTINE CLEARS THESE GARBAGE VALUES BEFORE ! 21678: * EXITING AFTER COMPLETING ITS TASK. ! 21679: * ! 21680: * THE ROUTINES HAVE NAMES CONSISTING OF FIVE LETTERS ! 21681: * AND ARE ASSEMBLED IN ALPHABETICAL ORDER. ! 21682: EJC ! 21683: * ARREF -- ARRAY REFERENCE ! 21684: * ! 21685: * (XL) MAY BE NON-COLLECTABLE ! 21686: * (XR) NUMBER OF SUBSCRIPTS ! 21687: * (WB) SET ZERO/NONZERO FOR VALUE/NAME ! 21688: * THE VALUE IN WB MUST BE COLLECTABLE ! 21689: * STACK SUBSCRIPTS AND ARRAY OPERAND ! 21690: * BRN ARREF JUMP TO CALL FUNCTION ! 21691: * ! 21692: * ARREF CONTINUES BY EXECUTING THE NEXT CODE WORD WITH ! 21693: * THE RESULT NAME OR VALUE PLACED ON TOP OF THE STACK. ! 21694: * TO DEAL WITH THE PROBLEM OF ACCESSING SUBSCRIPTS IN THE ! 21695: * ORDER OF STACKING, XL IS USED AS A SUBSCRIPT POINTER ! 21696: * WORKING BELOW THE STACK POINTER. ! 21697: * ! 21698: ARREF RTN ! 21699: MOV XR,WA COPY NUMBER OF SUBSCRIPTS ! 21700: MOV XS,XT POINT TO STACK FRONT ! 21701: WTB XR CONVERT TO BAU OFFSET ! 21702: ADD XR,XT POINT TO ARRAY OPERAND ON STACK ! 21703: ICA XT FINAL VALUE FOR STACK POPPING ! 21704: MOV XT,ARFXS KEEP FOR LATER ! 21705: MOV -(XT),XR LOAD ARRAY OPERAND POINTER ! 21706: MOV XR,R$ARF KEEP ARRAY POINTER ! 21707: MOV XT,XR SAVE POINTER TO SUBSCRIPTS ! 21708: MOV R$ARF,XL POINT XL TO POSSIBLE VCBLK OR TBBLK ! 21709: MOV (XL),WC LOAD FIRST WORD ! 21710: BEQ WC,=B$ART,ARF01 JUMP IF ARBLK ! 21711: BEQ WC,=B$VCT,ARF07 JUMP IF VCBLK ! 21712: BEQ WC,=B$TBT,ARF10 JUMP IF TBBLK ! 21713: ERB 240,SUBSCRIPTED OPERAND IS NOT TABLE OR ARRAY ! 21714: * ! 21715: * HERE FOR ARRAY (ARBLK) ! 21716: * ! 21717: ARF01 BNE WA,ARNDM(XL),ARF09 JUMP IF WRONG NUMBER OF DIMS ! 21718: LDI INTV0 GET INITIAL SUBSCRIPT OF ZERO ! 21719: MOV XR,XT POINT BEFORE SUBSCRIPTS ! 21720: ZER WA INITIAL OFFSET TO BOUNDS ! 21721: BRN ARF03 JUMP INTO LOOP ! 21722: * ! 21723: * LOOP TO COMPUTE SUBSCRIPTS BY MULTIPLICATIONS ! 21724: * ! 21725: ARF02 MLI ARDM2(XR) MULTIPLY TOTAL BY NEXT DIMENSION ! 21726: * ! 21727: * MERGE HERE FIRST TIME ! 21728: * ! 21729: ARF03 MOV -(XT),XR LOAD NEXT SUBSCRIPT ! 21730: STI ARFSI SAVE CURRENT SUBSCRIPT ! 21731: LDI ICVAL(XR) LOAD INTEGER VALUE IN CASE ! 21732: BEQ (XR),=B$ICL,ARF04 JUMP IF IT WAS AN INTEGER ! 21733: EJC ! 21734: * ! 21735: * ARREF (CONTINUED) ! 21736: * ! 21737: * ! 21738: JSR GTINT CONVERT TO INTEGER ! 21739: PPM ARF12 JUMP IF NOT INTEGER ! 21740: LDI ICVAL(XR) IF OK, LOAD INTEGER VALUE ! 21741: * ! 21742: * HERE WITH INTEGER SUBSCRIPT IN (IA) ! 21743: * ! 21744: ARF04 MOV R$ARF,XR POINT TO ARRAY ! 21745: ADD WA,XR OFFSET TO NEXT BOUNDS ! 21746: SBI ARLBD(XR) SUBTRACT LOW BOUND TO COMPARE ! 21747: IOV ARF13 OUT OF RANGE FAIL IF OVERFLOW ! 21748: ILT ARF13 OUT OF RANGE FAIL IF TOO SMALL ! 21749: SBI ARDIM(XR) SUBTRACT DIMENSION ! 21750: IGE ARF13 OUT OF RANGE FAIL IF TOO LARGE ! 21751: ADI ARDIM(XR) ELSE RESTORE SUBSCRIPT OFFSET ! 21752: ADI ARFSI ADD TO CURRENT TOTAL ! 21753: ADD *ARDMS,WA POINT TO NEXT BOUNDS ! 21754: BNE XT,XS,ARF02 LOOP BACK IF MORE TO GO ! 21755: * ! 21756: * HERE WITH INTEGER SUBSCRIPT COMPUTED ! 21757: * ! 21758: MFI WA GET AS ONE WORD INTEGER ! 21759: WTB WA CONVERT TO OFFSET ! 21760: MOV R$ARF,XL POINT TO ARBLK ! 21761: ADD AROFS(XL),WA ADD OFFSET PAST BOUNDS ! 21762: ICA WA ADJUST FOR ARPRO FIELD ! 21763: BNZ WB,ARF08 EXIT WITH NAME IF NAME CALL ! 21764: * ! 21765: * MERGE HERE TO GET VALUE FOR VALUE CALL ! 21766: * ! 21767: ARF05 JSR ACESS GET VALUE ! 21768: PPM ARF13 FAIL IF ACESS FAILS ! 21769: * ! 21770: * RETURN VALUE ! 21771: * ! 21772: ARF06 MOV ARFXS,XS POP STACK ENTRIES ! 21773: ZER R$ARF FINISHED WITH ARRAY POINTER ! 21774: BRN EXIXR EXIT WITH VALUE IN XR ! 21775: EJC ! 21776: * ! 21777: * ARREF (CONTINUED) ! 21778: * ! 21779: * HERE FOR VECTOR ! 21780: * ! 21781: ARF07 BNE WA,=NUM01,ARF09 ERROR IF MORE THAN 1 SUBSCRIPT ! 21782: MOV (XS),XR ELSE LOAD SUBSCRIPT ! 21783: JSR GTINT CONVERT TO INTEGER ! 21784: PPM ARF12 ERROR IF NOT INTEGER ! 21785: LDI ICVAL(XR) ELSE LOAD INTEGER VALUE ! 21786: SBI INTV1 SUBTRACT FOR ONES OFFSET ! 21787: MFI WA,ARF13 GET SUBSCRIPT AS ONE WORD ! 21788: ADD =VCVLS,WA ADD OFFSET FOR STANDARD FIELDS ! 21789: WTB WA CONVERT OFFSET TO BAUS ! 21790: BGE WA,VCLEN(XL),ARF13 FAIL IF OUT OF RANGE SUBSCRIPT ! 21791: BZE WB,ARF05 BACK TO GET VALUE IF VALUE CALL ! 21792: * ! 21793: * RETURN NAME ! 21794: * ! 21795: ARF08 MOV ARFXS,XS POP STACK ENTRIES ! 21796: ZER R$ARF FINISHED WITH ARRAY POINTER ! 21797: BRN EXNAM ELSE EXIT WITH NAME ! 21798: * ! 21799: * HERE IF SUBSCRIPT COUNT IS WRONG ! 21800: * ! 21801: ARF09 ERB 241,ARRAY REFERENCED WITH WRONG NUMBER OF SUBSCRIPTS ! 21802: * ! 21803: * TABLE ! 21804: * ! 21805: ARF10 BNE WA,=NUM01,ARF11 ERROR IF MORE THAN 1 SUBSCRIPT ! 21806: MOV (XS),XR ELSE LOAD SUBSCRIPT ! 21807: JSR TFIND CALL TABLE SEARCH ROUTINE ! 21808: PPM ARF13 FAIL IF FAILED ! 21809: BNZ WB,ARF08 EXIT WITH NAME IF NAME CALL ! 21810: BRN ARF06 ELSE EXIT WITH VALUE ! 21811: * ! 21812: * HERE FOR BAD TABLE REFERENCE ! 21813: * ! 21814: ARF11 ERB 242,TABLE REFERENCED WITH MORE THAN ONE SUBSCRIPT ! 21815: * ! 21816: * HERE FOR BAD SUBSCRIPT ! 21817: * ! 21818: ARF12 ERB 243,ARRAY SUBSCRIPT IS NOT INTEGER ! 21819: * ! 21820: * HERE TO SIGNAL FAILURE ! 21821: * ! 21822: ARF13 ZER R$ARF FINISHED WITH ARRAY POINTER ! 21823: BRN EXFAL FAIL ! 21824: EJC ! 21825: * ! 21826: * CFUNC -- CALL A FUNCTION ! 21827: * ! 21828: * CFUNC IS USED TO CALL A SNOBOL LEVEL FUNCTION. IT IS ! 21829: * USED BY THE APPLY FUNCTION (S$APP), THE FUNCTION ! 21830: * TRACE ROUTINE (TRXEQ) AND THE MAIN FUNCTION CALL ENTRY ! 21831: * (O$FNC, O$FNS). IN THE LATTER CASES, CFUNC IS USED ONLY ! 21832: * IF THE NUMBER OF ARGUMENTS IS INCORRECT. ! 21833: * ! 21834: * (XL) POINTER TO FUNCTION BLOCK ! 21835: * (WA) ACTUAL NUMBER OF ARGUMENTS ! 21836: * (XS) POINTS TO STACKED ARGUMENTS ! 21837: * BRN CFUNC JUMP TO CALL FUNCTION ! 21838: * ! 21839: * CFUNC CONTINUES BY EXECUTING THE FUNCTION ! 21840: * ! 21841: CFUNC RTN ! 21842: BLT WA,FARGS(XL),CFNC1 JUMP IF TOO FEW ARGUMENTS ! 21843: BEQ WA,FARGS(XL),CFNC3 JUMP IF CORRECT NUMBER OF ARGS ! 21844: * ! 21845: * HERE IF TOO MANY ARGUMENTS SUPPLIED, POP THEM OFF ! 21846: * ! 21847: MOV WA,WB COPY ACTUAL NUMBER ! 21848: SUB FARGS(XL),WB GET NUMBER OF EXTRA ARGS ! 21849: WTB WB CONVERT TO BAUS ! 21850: ADD WB,XS POP OFF UNWANTED ARGUMENTS ! 21851: BRN CFNC3 JUMP TO GO OFF TO FUNCTION ! 21852: * ! 21853: * HERE IF TOO FEW ARGUMENTS ! 21854: * ! 21855: CFNC1 MOV FARGS(XL),WB LOAD REQUIRED NUMBER OF ARGUMENTS ! 21856: BEQ WB,=NINI9,CFNC3 JUMP IF CASE OF VAR NUM OF ARGS ! 21857: SUB WA,WB CALCULATE NUMBER MISSING ! 21858: LCT WB,WB SET COUNTER TO CONTROL LOOP ! 21859: * ! 21860: * LOOP TO SUPPLY EXTRA NULL ARGUMENTS ! 21861: * ! 21862: CFNC2 MOV =NULLS,-(XS) STACK A NULL ARGUMENT ! 21863: BCT WB,CFNC2 LOOP TILL PROPER NUMBER STACKED ! 21864: * ! 21865: * MERGE HERE TO JUMP TO FUNCTION ! 21866: * ! 21867: CFNC3 BRI (XL) JUMP THROUGH FCODE FIELD ! 21868: EJC ! 21869: * ! 21870: * EROSI -- PROCESS ERROR RETURN FROM OSINT ! 21871: * ! 21872: * (WA) 0 OR ERROR CODE IN 256 TO 998 ! 21873: * (XL) 0 OR PSEUDO SCBLK FOR ERROR MESSAGE ! 21874: * (IA) NEW VALUE FOR CODE KEYWORD ! 21875: * BRN EROSI JUMP TO PROCESS ERROR ! 21876: * ! 21877: EROSI RTN ! 21878: STI KVCOD STORE NEW CODE KEYWORD VALUE ! 21879: MOV WA,KVERT STORE ERROR CODE ! 21880: BZE XL,ERROR FAIL AT ONCE IF NO ERROR MSG TEXT ! 21881: MOV SCLEN(XL),WA STRING LENGTH ! 21882: ZER WB ZERO OFFSET ! 21883: JSR SBSTR COPY ERROR MESSAGE STRING ! 21884: MOV XR,R$ETX AND STORE IT ! 21885: MNZ EROSN NOTE NO CALL OF SYSEM ! 21886: MOV KVERT,WA RECALL ERROR CODE ! 21887: BRN ERROR ENTER ERROR SECTION ! 21888: * ! 21889: * EXFAL -- EXIT SIGNALLING SNOBOL FAILURE ! 21890: * ! 21891: * (XL,XR) MAY BE NON-COLLECTABLE ! 21892: * BRN EXFAL JUMP TO FAIL ! 21893: * ! 21894: * EXFAL CONTINUES BY EXECUTING THE APPROPRIATE FAIL GOTO ! 21895: * ! 21896: EXFAL RTN ! 21897: MOV FLPTR,XS POP STACK ! 21898: MOV (XS),XR LOAD FAILURE OFFSET ! 21899: ADD R$COD,XR POINT TO FAILURE CODE LOCATION ! 21900: LCP XR SET CODE POINTER ! 21901: BRN EXITS DO NEXT CODE WORD ! 21902: * ! 21903: * EXINT -- EXIT WITH INTEGER RESULT ! 21904: * ! 21905: * (XL,XR) MAY BE NONCOLLECTABLE ! 21906: * (IA) INTEGER VALUE ! 21907: * BRN EXINT JUMP TO EXIT WITH INTEGER ! 21908: * ! 21909: * EXINT CONTINUES BY EXECUTING THE NEXT CODE WORD ! 21910: * WHICH IT DOES BY FALLING THROUGH TO EXIXR ! 21911: * ! 21912: EXINT RTN ! 21913: JSR ICBLD BUILD ICBLK ! 21914: EJC ! 21915: * EXIXR -- EXIT WITH RESULT IN (XR) ! 21916: * ! 21917: * (XR) RESULT ! 21918: * (XL) MAY BE NON-COLLECTABLE ! 21919: * BRN EXIXR JUMP TO EXIT WITH RESULT IN (XR) ! 21920: * ! 21921: * EXIXR CONTINUES BY EXECUTING THE NEXT CODE WORD ! 21922: * WHICH IT DOES BY FALLING THROUGH TO EXITS. ! 21923: EXIXR RTN ! 21924: * ! 21925: MOV XR,-(XS) STACK RESULT ! 21926: * ! 21927: * ! 21928: * EXITS -- EXIT WITH RESULT IF ANY STACKED ! 21929: * ! 21930: * (XR,XL) MAY BE NON-COLLECTABLE ! 21931: * ! 21932: * BRN EXITS ENTER EXITS ROUTINE ! 21933: * ! 21934: EXITS RTN ! 21935: LCW XR LOAD NEXT CODE WORD ! 21936: MOV (XR),XL LOAD ENTRY ADDRESS ! 21937: BRI XL JUMP TO EXECUTE NEXT CODE WORD ! 21938: * ! 21939: * EXNAM -- EXIT WITH NAME IN (XL,WA) ! 21940: * ! 21941: * (XL) NAME BASE ! 21942: * (WA) NAME OFFSET ! 21943: * (XR) MAY BE NON-COLLECTABLE ! 21944: * BRN EXNAM JUMP TO EXIT WITH NAME IN (XL,WA) ! 21945: * ! 21946: * EXNAM CONTINUES BY EXECUTING THE NEXT CODE WORD ! 21947: * ! 21948: EXNAM RTN ! 21949: MOV XL,-(XS) STACK NAME BASE ! 21950: MOV WA,-(XS) STACK NAME OFFSET ! 21951: BRN EXITS DO NEXT CODE WORD ! 21952: EJC ! 21953: * ! 21954: * EXNUL -- EXIT WITH NULL RESULT ! 21955: * ! 21956: * (XL,XR) MAY BE NON-COLLECTABLE ! 21957: * BRN EXNUL JUMP TO EXIT WITH NULL VALUE ! 21958: * ! 21959: * EXNUL CONTINUES BY EXECUTING THE NEXT CODE WORD ! 21960: * ! 21961: EXNUL RTN ! 21962: MOV =NULLS,-(XS) STACK NULL VALUE ! 21963: BRN EXITS DO NEXT CODE WORD ! 21964: .IF .CNRA ! 21965: .ELSE ! 21966: * ! 21967: * EXREA -- EXIT WITH REAL RESULT ! 21968: * ! 21969: * (XL,XR) MAY BE NON-COLLECTABLE ! 21970: * (RA) REAL VALUE ! 21971: * BRN EXREA JUMP TO EXIT WITH REAL VALUE ! 21972: * ! 21973: * EXREA CONTINUES BY EXECUTING THE NEXT CODE WORD ! 21974: * ! 21975: EXREA RTN ! 21976: JSR RCBLD BUILD RCBLK ! 21977: BRN EXIXR JUMP TO EXIT WITH RESULT IN XR ! 21978: .FI ! 21979: * ! 21980: * EXSID -- EXIT SETTING ID FIELD ! 21981: * ! 21982: * EXSID IS USED TO EXIT AFTER BUILDING ANY OF THE FOLLOWING ! 21983: * BLOCKS (ARBLK, TBBLK, PDBLK, VCBLK). IT SETS THE IDVAL. ! 21984: * ! 21985: * (XR) PTR TO BLOCK WITH IDVAL FIELD ! 21986: * (XL) MAY BE NON-COLLECTABLE ! 21987: * BRN EXSID JUMP TO EXIT AFTER SETTING ID FIELD ! 21988: * ! 21989: * EXSID CONTINUES BY EXECUTING THE NEXT CODE WORD ! 21990: * ! 21991: EXSID RTN ! 21992: MOV CURID,WA LOAD CURRENT ID VALUE ! 21993: BNE WA,=CFP$M,EXSI1 JUMP IF NO OVERFLOW ! 21994: ZER WA ELSE RESET FOR WRAPAROUND ! 21995: * ! 21996: * HERE WITH OLD IDVAL IN WA ! 21997: * ! 21998: EXSI1 ICV WA BUMP ID VALUE ! 21999: MOV WA,CURID STORE FOR NEXT TIME ! 22000: MOV WA,IDVAL(XR) STORE ID VALUE ! 22001: BRN EXIXR EXIT WITH RESULT IN (XR) ! 22002: EJC ! 22003: * ! 22004: * EXVNM -- EXIT WITH NAME OF VARIABLE ! 22005: * ! 22006: * EXVNM EXITS AFTER STACKING A VALUE WHICH IS A NMBLK ! 22007: * REFERENCING THE NAME OF A GIVEN NATURAL VARIABLE. ! 22008: * ! 22009: * (XR) VRBLK POINTER ! 22010: * (XL) MAY BE NON-COLLECTABLE ! 22011: * BRN EXVNM EXIT WITH VRBLK POINTER IN XR ! 22012: * ! 22013: EXVNM RTN ! 22014: MOV XR,XL COPY NAME BASE POINTER ! 22015: MOV *NMSI$,WA SET SIZE OF NMBLK ! 22016: JSR ALLOC ALLOCATE NMBLK ! 22017: MOV =B$NML,(XR) STORE TYPE WORD ! 22018: MOV XL,NMBAS(XR) STORE NAME BASE ! 22019: MOV *VRVAL,NMOFS(XR) STORE NAME OFFSET ! 22020: BRN EXIXR EXIT WITH RESULT IN XR ! 22021: * ! 22022: * FLPOP -- FAIL AND POP IN PATTERN MATCHING ! 22023: * ! 22024: * FLPOP POPS THE NODE AND CURSOR ON THE STACK AND THEN ! 22025: * DROPS THROUGH INTO FAILP TO CAUSE PATTERN FAILURE ! 22026: * ! 22027: * (XL,XR) MAY BE NON-COLLECTABLE ! 22028: * BRN FLPOP JUMP TO FAIL AND POP STACK ! 22029: * ! 22030: FLPOP RTN ! 22031: ADD *NUM02,XS POP TWO ENTRIES OFF STACK ! 22032: * ! 22033: * FAILP -- FAILURE IN MATCHING PATTERN NODE ! 22034: * ! 22035: * FAILP IS USED AFTER FAILING TO MATCH A PATTERN NODE. ! 22036: * SEE PATTERN MATCH ROUTINES FOR DETAILS OF USE. ! 22037: * ! 22038: * (XL,XR) MAY BE NON-COLLECTABLE ! 22039: * BRN FAILP SIGNAL FAILURE TO MATCH ! 22040: * ! 22041: * FAILP CONTINUES BY MATCHING AN ALTERNATIVE FROM THE STACK ! 22042: * ! 22043: FAILP RTN ! 22044: MOV (XS)+,XR LOAD ALTERNATIVE NODE POINTER ! 22045: MOV (XS)+,WB RESTORE OLD CURSOR ! 22046: MOV (XR),XL LOAD PCODE ENTRY POINTER ! 22047: BRI XL JUMP TO EXECUTE CODE FOR NODE ! 22048: EJC ! 22049: * ! 22050: * INDIR -- COMPUTE INDIRECT REFERENCE ! 22051: * ! 22052: * (WB) NONZERO/ZERO FOR BY NAME/VALUE ! 22053: * BRN INDIR JUMP TO GET INDIRECT REF ON STACK ! 22054: * ! 22055: * INDIR CONTINUES BY EXECUTING THE NEXT CODE WORD ! 22056: * ! 22057: INDIR RTN ! 22058: MOV (XS)+,XR LOAD ARGUMENT ! 22059: BEQ (XR),=B$NML,INDR2 JUMP IF A NAME ! 22060: JSR GTNVR ELSE CONVERT TO VARIABLE ! 22061: ERR 244,INDIRECTION OPERAND IS NOT NAME ! 22062: BZE WB,INDR1 SKIP IF BY VALUE ! 22063: MOV XR,-(XS) ELSE STACK VRBLK PTR ! 22064: MOV *VRVAL,-(XS) STACK NAME OFFSET ! 22065: BRN EXITS EXIT WITH RESULT ON STACK ! 22066: * ! 22067: * HERE TO GET VALUE OF NATURAL VARIABLE ! 22068: * ! 22069: INDR1 BRI (XR) JUMP THROUGH VRGET FIELD OF VRBLK ! 22070: * ! 22071: * HERE IF OPERAND IS A NAME ! 22072: * ! 22073: INDR2 MOV NMBAS(XR),XL LOAD NAME BASE ! 22074: MOV NMOFS(XR),WA LOAD NAME OFFSET ! 22075: BNZ WB,EXNAM EXIT IF CALLED BY NAME ! 22076: JSR ACESS ELSE GET VALUE FIRST ! 22077: PPM EXFAL FAIL IF ACCESS FAILS ! 22078: BRN EXIXR ELSE RETURN WITH VALUE IN XR ! 22079: EJC ! 22080: * ! 22081: * MATCH -- INITIATE PATTERN MATCH ! 22082: * ! 22083: * (WB) MATCH TYPE CODE ! 22084: * BRN MATCH JUMP TO INITIATE PATTERN MATCH ! 22085: * ! 22086: * MATCH CONTINUES BY EXECUTING THE PATTERN MATCH. SEE ! 22087: * PATTERN MATCH ROUTINES (P$XXX) FOR FULL DETAILS. ! 22088: * ! 22089: MATCH RTN ! 22090: MOV (XS)+,XR LOAD PATTERN OPERAND ! 22091: JSR GTPAT CONVERT TO PATTERN ! 22092: ERR 245,PATTERN MATCH RIGHT OPERAND IS NOT PATTERN ! 22093: MOV XR,XL IF OK, SAVE PATTERN POINTER ! 22094: BNZ WB,MTCH1 JUMP IF NOT MATCH BY NAME ! 22095: MOV (XS),WA ELSE LOAD NAME OFFSET ! 22096: MOV XL,-(XS) SAVE PATTERN POINTER ! 22097: MOV 2(XS),XL LOAD NAME BASE ! 22098: JSR ACESS ACCESS SUBJECT VALUE ! 22099: PPM EXFAL FAIL IF ACCESS FAILS ! 22100: MOV (XS),XL RESTORE PATTERN POINTER ! 22101: MOV XR,(XS) STACK SUBJECT STRING VAL FOR MERGE ! 22102: ZER WB RESTORE TYPE CODE ! 22103: * ! 22104: * MERGE HERE WITH SUBJECT VALUE ON STACK ! 22105: * ! 22106: .IF .CNBF ! 22107: MTCH1 JSR GTSTG CONVERT SUBJECT TO STRING ! 22108: .ELSE ! 22109: MTCH1 MOV (XS),XR LOAD SUBJECT VALUE ! 22110: ZER R$PMB ASSUME NOT A BUFFER ! 22111: BNE (XR),=B$BCT,MTCHA BRANCH IF NOT ! 22112: ICA XS ELSE POP VALUE ! 22113: MOV XR,R$PMB SAVE POINTER ! 22114: MOV BCLEN(XR),WA GET DEFINED LENGTH ! 22115: MOV BCBUF(XR),XR POINT TO BFBLK ! 22116: BRN MTCHB ! 22117: * ! 22118: * HERE IF NOT BUFFER TO CONVERT TO STRING ! 22119: * ! 22120: MTCHA JSR GTSTG NOT BUFFER - CONVERT TO STRING ! 22121: .FI ! 22122: ERR 246,PATTERN MATCH LEFT OPERAND IS NOT STRING ! 22123: .IF .CNBF ! 22124: MOV XR,R$PMS IF OK, STORE SUBJECT STRING POINTER ! 22125: .ELSE ! 22126: * ! 22127: * MERGE WITH NULL STRING OR BUFFER ! 22128: * ! 22129: MTCHB MOV XR,R$PMS IF OK, STORE SUBJECT STRING POINTER ! 22130: .FI ! 22131: MOV WA,PMSSL AND LENGTH ! 22132: MOV WB,-(XS) STACK MATCH TYPE CODE ! 22133: ZER -(XS) STACK INITIAL CURSOR (ZERO) ! 22134: ZER WB SET INITIAL CURSOR ! 22135: MOV XS,PMHBS SET HISTORY STACK BASE PTR ! 22136: ZER PMDFL RESET PATTERN ASSIGNMENT FLAG ! 22137: MOV XL,XR SET INITIAL NODE POINTER ! 22138: BNZ KVANC,MTCH2 JUMP IF ANCHORED ! 22139: EJC ! 22140: * ! 22141: * MATCH (CONTINUED) ! 22142: * ! 22143: * HERE FOR UNANCHORED ! 22144: * ! 22145: MOV XR,-(XS) STACK INITIAL NODE POINTER ! 22146: MOV =NDUNA,-(XS) STACK POINTER TO ANCHOR MOVE NODE ! 22147: BRI (XR) START MATCH OF FIRST NODE ! 22148: * ! 22149: * HERE IN ANCHORED MODE ! 22150: * ! 22151: MTCH2 ZER -(XS) DUMMY CURSOR VALUE ! 22152: MOV =NDABO,-(XS) STACK POINTER TO ABORT NODE ! 22153: BRI (XR) START MATCH OF FIRST NODE ! 22154: EJC ! 22155: * ! 22156: * RETRN -- RETURN FROM FUNCTION ! 22157: * ! 22158: * (WA) STRING POINTER FOR RETURN TYPE ! 22159: * BRN RETRN JUMP TO RETURN FROM (SNOBOL) FUNC ! 22160: * ! 22161: * RETRN CONTINUES BY EXECUTING THE CODE AT THE RETURN POINT ! 22162: * THE STACK IS CLEANED OF ANY GARBAGE LEFT BY OTHER ! 22163: * ROUTINES WHICH MAY HAVE ALTERED FLPTR SINCE FUNCTION ! 22164: * ENTRY BY USING FLPRT, RESERVED FOR USE ONLY BY ! 22165: * FUNCTION CALL AND RETURN. ! 22166: * ! 22167: RETRN RTN ! 22168: BNZ KVFNC,RTN01 JUMP IF NOT LEVEL ZERO ! 22169: ERB 247,FUNCTION RETURN FROM LEVEL ZERO ! 22170: * ! 22171: * HERE IF NOT LEVEL ZERO RETURN ! 22172: * ! 22173: RTN01 MOV FLPRT,XS POP STACK ! 22174: ICA XS REMOVE FAILURE OFFSET ! 22175: MOV (XS)+,XR POP PFBLK POINTER ! 22176: MOV (XS)+,FLPTR POP FAILURE POINTER ! 22177: MOV (XS)+,FLPRT POP OLD FLPRT ! 22178: MOV (XS)+,WB POP CODE POINTER OFFSET ! 22179: MOV (XS)+,WC POP OLD CODE BLOCK POINTER ! 22180: ADD WC,WB MAKE OLD CODE POINTER ABSOLUTE ! 22181: LCP WB RESTORE OLD CODE POINTER ! 22182: MOV WC,R$COD RESTORE OLD CODE BLOCK POINTER ! 22183: DCV KVFNC DECREMENT FUNCTION LEVEL ! 22184: MOV KVTRA,WB LOAD TRACE ! 22185: ADD KVFTR,WB ADD FTRACE ! 22186: BZE WB,RTN06 JUMP IF NO TRACING POSSIBLE ! 22187: * ! 22188: * HERE IF THERE MAY BE A TRACE ! 22189: * ! 22190: MOV WA,-(XS) SAVE FUNCTION RETURN TYPE ! 22191: MOV XR,-(XS) SAVE PFBLK POINTER ! 22192: MOV WA,KVRTN SET RTNTYPE FOR TRACE FUNCTION ! 22193: MOV R$FNC,XL LOAD FNCLEVEL TRBLK PTR (IF ANY) ! 22194: JSR KTREX EXECUTE POSSIBLE FNCLEVEL TRACE ! 22195: MOV PFVBL(XR),XL LOAD VRBLK POINTER ! 22196: BZE KVTRA,RTN02 JUMP IF TRACE IS OFF ! 22197: MOV PFRTR(XR),XR ELSE LOAD RETURN TRACE TRBLK PTR ! 22198: BZE XR,RTN02 JUMP IF NOT RETURN TRACED ! 22199: DCV KVTRA ELSE DECREMENT TRACE COUNT ! 22200: BZE TRFNC(XR),RTN03 JUMP IF PRINT TRACE ! 22201: MOV *VRVAL,WA ELSE SET NAME OFFSET ! 22202: MOV 1(XS),KVRTN MAKE SURE RTNTYPE IS SET RIGHT ! 22203: JSR TRXEQ EXECUTE FULL TRACE ! 22204: EJC ! 22205: * ! 22206: * RETRN (CONTINUED) ! 22207: * ! 22208: * HERE TO TEST FOR FTRACE ! 22209: * ! 22210: RTN02 BZE KVFTR,RTN05 JUMP IF FTRACE IS OFF ! 22211: DCV KVFTR ELSE DECREMENT FTRACE ! 22212: * ! 22213: * HERE FOR PRINT TRACE OF FUNCTION RETURN ! 22214: * ! 22215: RTN03 JSR PRTSN PRINT STATEMENT NUMBER ! 22216: MOV 1(XS),XR LOAD RETURN TYPE ! 22217: JSR PRTST PRINT IT ! 22218: MOV =CH$BL,WA LOAD BLANK ! 22219: JSR PRTCH PRINT IT ! 22220: MOV 0(XS),XL LOAD PFBLK PTR ! 22221: MOV PFVBL(XL),XL LOAD FUNCTION VRBLK PTR ! 22222: MOV *VRVAL,WA SET VRBLK NAME OFFSET ! 22223: BNE XR,=SCFRT,RTN04 JUMP IF NOT FRETURN CASE ! 22224: * ! 22225: * FOR FRETURN, JUST PRINT FUNCTION NAME ! 22226: * ! 22227: JSR PRTNM PRINT NAME ! 22228: JSR PRTFH TERMINATE PRINT LINE ! 22229: BRN RTN05 MERGE ! 22230: * ! 22231: * HERE FOR RETURN OR NRETURN, PRINT FUNCTION NAME = VALUE ! 22232: * ! 22233: RTN04 JSR PRTNV PRINT NAME = VALUE ! 22234: * ! 22235: * HERE AFTER COMPLETING TRACE ! 22236: * ! 22237: RTN05 MOV (XS)+,XR POP PFBLK POINTER ! 22238: MOV (XS)+,WA POP RETURN TYPE STRING ! 22239: * ! 22240: * MERGE HERE IF NO TRACE REQUIRED ! 22241: * ! 22242: RTN06 MOV WA,KVRTN SET RTNTYPE KEYWORD ! 22243: MOV PFVBL(XR),XL LOAD POINTER TO FN VRBLK ! 22244: EJC ! 22245: * RETRN (CONTINUED) ! 22246: * ! 22247: * GET VALUE OF FUNCTION ! 22248: * ! 22249: RTN07 MOV XL,RTNBP SAVE BLOCK POINTER ! 22250: MOV VRVAL(XL),XL LOAD VALUE ! 22251: BEQ (XL),=B$TRT,RTN07 LOOP BACK IF TRAPPED ! 22252: MOV XL,RTNFV ELSE SAVE FUNCTION RESULT VALUE ! 22253: MOV (XS)+,RTNSV SAVE ORIGINAL FUNCTION VALUE ! 22254: .IF .CNPF ! 22255: MOV FARGS(XR),WB GET NUMBER OF ARGUMENTS ! 22256: .ELSE ! 22257: MOV (XS)+,XL POP SAVED POINTER ! 22258: BZE XL,RTN7C NO ACTION IF NONE ! 22259: BZE KVPFL,RTN7C JUMP IF NO PROFILING ! 22260: JSR PRFLU ELSE PROFILE LAST FUNC STMT ! 22261: BEQ KVPFL,=NUM02,RTN7A BRANCH ON VALUE OF PROFILE KEYWD ! 22262: * ! 22263: * HERE IF PROFILE = 1. START TIME MUST BE FRIGGED TO ! 22264: * APPEAR EARLIER THAN IT ACTUALLY IS, BY AMOUNT USED BEFORE ! 22265: * THE CALL. ! 22266: * ! 22267: LDI PFSTM LOAD CURRENT TIME ! 22268: SBI ICVAL(XL) FRIG BY SUBTRACTING SAVED AMOUNT ! 22269: BRN RTN7B AND MERGE ! 22270: * ! 22271: * HERE IF PROFILE = 2 ! 22272: * ! 22273: RTN7A LDI ICVAL(XL) LOAD SAVED TIME ! 22274: * ! 22275: * BOTH PROFILE TYPES MERGE HERE ! 22276: * ! 22277: RTN7B STI PFSTM STORE BACK CORRECT START TIME ! 22278: * ! 22279: * MERGE HERE IF NO PROFILING ! 22280: * ! 22281: RTN7C MOV FARGS(XR),WB GET NUMBER OF ARGS ! 22282: .FI ! 22283: ADD PFNLO(XR),WB ADD NUMBER OF LOCALS ! 22284: BZE WB,RTN10 JUMP IF NO ARGS/LOCALS ! 22285: LCT WB,WB ELSE SET LOOP COUNTER ! 22286: ADD PFLEN(XR),XR AND POINT TO END OF PFBLK ! 22287: * ! 22288: * LOOP TO RESTORE FUNCTIONS AND LOCALS ! 22289: * ! 22290: RTN08 MOV -(XR),XL LOAD NEXT VRBLK POINTER ! 22291: * ! 22292: * LOOP TO FIND VALUE BLOCK ! 22293: * ! 22294: RTN09 MOV XL,WA SAVE BLOCK POINTER ! 22295: MOV VRVAL(XL),XL LOAD POINTER TO NEXT VALUE ! 22296: BEQ (XL),=B$TRT,RTN09 LOOP BACK IF TRAPPED ! 22297: MOV WA,XL ELSE RESTORE LAST BLOCK POINTER ! 22298: MOV (XS)+,VRVAL(XL) RESTORE OLD VARIABLE VALUE ! 22299: BCT WB,RTN08 LOOP TILL ALL PROCESSED ! 22300: EJC ! 22301: * ! 22302: * RETRN (CONTINUED) ! 22303: * ! 22304: * NOW RESTORE FUNCTION VALUE AND EXIT ! 22305: * ! 22306: RTN10 MOV RTNBP,XL RESTORE PTR TO LAST FUNCTION BLOCK ! 22307: MOV RTNSV,VRVAL(XL) RESTORE OLD FUNCTION VALUE ! 22308: MOV RTNFV,XR RELOAD FUNCTION RESULT ! 22309: MOV R$COD,XL POINT TO NEW CODE BLOCK ! 22310: MOV KVSTN,KVLST SET LASTNO FROM STNO ! 22311: MOV CDSTM(XL),KVSTN RESET PROPER STNO VALUE ! 22312: MOV KVRTN,WA LOAD RETURN TYPE ! 22313: BEQ WA,=SCRTN,EXIXR EXIT WITH RESULT IN XR IF RETURN ! 22314: BEQ WA,=SCFRT,EXFAL FAIL IF FRETURN ! 22315: * ! 22316: * HERE FOR NRETURN ! 22317: * ! 22318: BEQ (XR),=B$NML,RTN11 JUMP IF IS A NAME ! 22319: JSR GTNVR ELSE TRY CONVERT TO VARIABLE NAME ! 22320: ERR 248,FUNCTION RESULT IN NRETURN IS NOT NAME ! 22321: MOV XR,XL IF OK, COPY VRBLK (NAME BASE) PTR ! 22322: MOV *VRVAL,WA SET NAME OFFSET ! 22323: BRN RTN12 AND MERGE ! 22324: * ! 22325: * HERE IF RETURNED RESULT IS A NAME ! 22326: * ! 22327: RTN11 MOV NMBAS(XR),XL LOAD NAME BASE ! 22328: MOV NMOFS(XR),WA LOAD NAME OFFSET ! 22329: * ! 22330: * MERGE HERE WITH RETURNED NAME IN (XL,WA) ! 22331: * ! 22332: RTN12 MOV XL,XR PRESERVE XL ! 22333: LCW WB LOAD NEXT WORD ! 22334: MOV XR,XL RESTORE XL ! 22335: BEQ WB,=OFNE$,EXNAM EXIT IF CALLED BY NAME ! 22336: MOV WB,-(XS) ELSE SAVE CODE WORD ! 22337: JSR ACESS GET VALUE ! 22338: PPM EXFAL FAIL IF ACCESS FAILS ! 22339: MOV XR,XL IF OK, COPY RESULT ! 22340: MOV (XS),XR RELOAD NEXT CODE WORD ! 22341: MOV XL,(XS) STORE RESULT ON STACK ! 22342: MOV (XR),XL LOAD ROUTINE ADDRESS ! 22343: BRI XL JUMP TO EXECUTE NEXT CODE WORD ! 22344: EJC ! 22345: * ! 22346: * STCOV -- SIGNAL STATEMENT COUNTER OVERFLOW ! 22347: * ! 22348: * BRN STCOV JUMP TO SIGNAL STATEMENT COUNT OFLO ! 22349: * ! 22350: * PERMIT UP TO 10 MORE STATEMENTS TO BE OBEYED SO THAT ! 22351: * SETEXIT TRAP CAN REGAIN CONTROL. ! 22352: * STCOV CONTINUES BY ISSUING THE ERROR MESSAGE ! 22353: * ! 22354: STCOV RTN ! 22355: ICV ERRFT FATAL ERROR ! 22356: LDI INTVT GET 10 ! 22357: ADI KVSTL ADD TO FORMER LIMIT ! 22358: STI KVSTL STORE AS NEW STLIMIT ! 22359: LDI INTVT GET 10 ! 22360: STI KVSTC SET AS NEW COUNT ! 22361: ERB 249,STATEMENT COUNT EXCEEDS VALUE OF STLIMIT KEYWORD ! 22362: EJC ! 22363: * ! 22364: * STMGO -- START EXECUTION OF NEW STATEMENT ! 22365: * ! 22366: * (XR) POINTER TO CDBLK FOR NEW STATEMENT ! 22367: * BRN STMGO JUMP TO EXECUTE NEW STATEMENT ! 22368: * ! 22369: * STMGO CONTINUES BY EXECUTING THE NEXT STATEMENT ! 22370: * ! 22371: STMGO RTN ! 22372: MOV XR,R$COD SET NEW CODE BLOCK POINTER ! 22373: .IF .CNPF ! 22374: MOV KVSTN,KVLST SET LASTNO ! 22375: .ELSE ! 22376: BZE KVPFL,STGO1 SKIP IF NO PROFILING ! 22377: JSR PRFLU ELSE PROFILE THE STATEMENT ! 22378: * ! 22379: * MERGE PROFILE, NO-PROFILE CASES ! 22380: * ! 22381: STGO1 MOV KVSTN,KVLST SET LASTNO ! 22382: .FI ! 22383: MOV CDSTM(XR),KVSTN SET STNO ! 22384: ADD *CDCOD,XR POINT TO FIRST CODE WORD ! 22385: LCP XR SET CODE POINTER ! 22386: LDI KVSTC GET STMT COUNT ! 22387: ILT EXITS OMIT COUNTING IF NEGATIVE ! 22388: IEQ STCOV FAIL IF STLIMIT REACHED ! 22389: SBI INTV1 DECREMENT ! 22390: STI KVSTC REPLACE IT ! 22391: BZE R$STC,EXITS EXIT IF NO STCOUNT TRACE ! 22392: * ! 22393: * HERE FOR STCOUNT TRACE ! 22394: * ! 22395: ZER XR CLEAR GARBAGE VALUE IN XR ! 22396: MOV R$STC,XL LOAD POINTER TO STCOUNT TRBLK ! 22397: JSR KTREX EXECUTE KEYWORD TRACE ! 22398: BRN EXITS AND THEN EXIT FOR NEXT CODE WORD ! 22399: EJC ! 22400: * ! 22401: * STOPR -- TERMINATE RUN ! 22402: * ! 22403: * (WA) 0 OR ERROR MESSAGE CODE ! 22404: * (XR) 0 OR ENDING MESSAGE POINTER ! 22405: * BRN STOPR JUMP TO TERMINATE RUN ! 22406: * ! 22407: * TERMINATE RUN AND PRINT STATISTICS. ON ENTRY XR POINTS ! 22408: * TO ENDING MESSAGE OR IS ZERO IF MESSAGE PRINTED ALREADY. ! 22409: * (WA) AND (XR) ARE BOTH NON-ZERO ONLY IN THE CASE OF FATAL ! 22410: * ERRORS DURING INITIAL COMPILE. ! 22411: * ! 22412: STOPR RTN ! 22413: .IF .CSAX ! 22414: JSR SYSAX CALL AFTER EXECUTION PROC ! 22415: .ELSE ! 22416: .FI ! 22417: ADD RSMEM,DNAME USE THE RESERVE MEMORY ! 22418: BZE WA,STPR1 SKIP IF NO ERROR MESSAGE ! 22419: MOV XR,STPXR KEEP 0 OR ENDING MESSAGE ! 22420: MOV TTERL,TTLST SEND ERROR AND STATS TO TERML ! 22421: JSR PRTPG PAGE THROW ! 22422: JSR ERMSG PRINT ERROR MESSAGE ! 22423: MOV STPXR,XR RECOVER 0 OR ENDING MESSAGE ! 22424: ZER EXSTS TO FORCE ENDING STATS OUT FOR ERROR ! 22425: * ! 22426: * PROCESS ENDING STATISTICS ! 22427: * ! 22428: STPR1 MTI KVSTN GET STATEMENT NUMBER ! 22429: IEQ STPR6 SKIP IF COMPILE TIME ! 22430: BNZ EXSTS,STPR4 SKIP IF NO STATS TO BE PRINTED ! 22431: JSR PRTPG EJECT PRINTER ! 22432: BZE XR,STPR2 SKIP IF NO MESSAGE ! 22433: JSR PRTFB PRINT MESSAGE ! 22434: * ! 22435: * MERGE HERE IF NO MESSAGE TO PRINT ! 22436: * ! 22437: STPR2 JSR PRTFH PRINT BLANK LINE ! 22438: MOV =STPM1,XR POINT TO MESSAGE /IN STATEMENT XXX/ ! 22439: JSR PRTMI PRINT IT ! 22440: JSR SYSTM GET CURRENT TIME ! 22441: SBI TIMSX MINUS START TIME = ELAPSED EXEC TIM ! 22442: STI STPTI SAVE FOR LATER ! 22443: MOV =STPM3,XR POINT TO MSG /EXECUTION TIME MSEC / ! 22444: JSR PRTMI PRINT IT ! 22445: LDI KVSTL GET STATEMENT LIMIT ! 22446: ILT STPR3 SKIP IF NEGATIVE ! 22447: SBI KVSTC MINUS COUNTER = COUNT ! 22448: STI STPSI SAVE ! 22449: MOV =STPM2,XR POINT TO MESSAGE /STMTS EXECUTED/ ! 22450: JSR PRTMI PRINT IT ! 22451: .IF .CTMD ! 22452: .ELSE ! 22453: LDI STPTI RELOAD ELAPSED TIME ! 22454: MLI INTTH *1000 (MICROSECS) ! 22455: IOV STPR3 JUMP IF WE CANNOT COMPUTE ! 22456: DVI STPSI DIVIDE BY STATEMENT COUNT ! 22457: IOV STPR3 JUMP IF OVERFLOW ! 22458: MOV =STPM4,XR POINT TO MSG (MCSEC PER STATEMENT / ! 22459: JSR PRTMI PRINT IT ! 22460: .FI ! 22461: EJC ! 22462: * ! 22463: * STOPR (CONTINUED) ! 22464: * ! 22465: * MERGE TO SKIP MESSAGE (OVERFLOW OR NEGATIVE STLIMIT) ! 22466: * ! 22467: STPR3 MTI GBCNT LOAD COUNT OF COLLECTIONS ! 22468: MOV =STPM5,XR POINT TO MESSAGE /REGENERATIONS / ! 22469: JSR PRTMI PRINT IT ! 22470: JSR PRTFH ONE MORE BLANK FOR LUCK ! 22471: * ! 22472: * CHECK IF DUMP REQUESTED ! 22473: * ! 22474: .IF .CNPF ! 22475: STPR4 MOV KVDMP,XR LOAD DUMP KEYWORD ! 22476: .ELSE ! 22477: STPR4 JSR PRFLR PRINT PROFILE IF WANTED ! 22478: MOV KVDMP,XR LOAD DUMP KEYWORD ! 22479: .FI ! 22480: JSR DUMPR EXECUTE DUMP IF REQUESTED ! 22481: * ! 22482: * MERGE TO END RUN FOR SEVERE COMPILATION ERRORS ! 22483: * ! 22484: STPR5 MOV =KVCOD,WA LOAD CODE VALUE ! 22485: JSR SYSEJ EXIT TO SYSTEM ! 22486: * ! 22487: * TERMINATION DURING COMPILE ! 22488: * ! 22489: STPR6 BZE XR,STPR7 SKIP IF NO MESSAGE ! 22490: JSR PRTSF ELSE PRINT IT ! 22491: * ! 22492: * NOTIFICATION THAT IT IS COMPILE TIME ! 22493: * ! 22494: STPR7 MOV =ENDIC,XR NOTIFY USER ! 22495: JSR PRTSF SEND IT ! 22496: BRN STPR5 END ! 22497: EJC ! 22498: * ! 22499: * SUCCP -- SIGNAL SUCCESSFUL MATCH OF A PATTERN NODE ! 22500: * ! 22501: * SEE PATTERN MATCH ROUTINES FOR DETAILS ! 22502: * ! 22503: * (XR) CURRENT NODE ! 22504: * (WB) CURRENT CURSOR ! 22505: * (XL) MAY BE NON-COLLECTABLE ! 22506: * BRN SUCCP SIGNAL SUCCESSFUL PATTERN MATCH ! 22507: * ! 22508: * SUCCP CONTINUES BY MATCHING THE SUCCESSOR NODE ! 22509: * ! 22510: SUCCP RTN ! 22511: MOV PTHEN(XR),XR LOAD SUCCESSOR NODE ! 22512: MOV (XR),XL LOAD NODE CODE ENTRY ADDRESS ! 22513: BRI XL JUMP TO MATCH SUCCESSOR NODE ! 22514: TTL S P I T B O L -- STACK OVERFLOW SECTION ! 22515: * ! 22516: * CONTROL COMES HERE IF THE MAIN STACK OVERFLOWS ! 22517: * ! 22518: SEC START OF STACK OVERFLOW SECTION ! 22519: * ! 22520: STAKV RTN ENTRY POINT FOR STACK OVERFLOW ! 22521: ICV ERRFT FATAL ERROR ! 22522: MOV FLPTR,XS POP STACK TO AVOID MORE FAILS ! 22523: BNZ GBCFL,STAK1 JUMP IF GARBAGE COLLECTING ! 22524: ERB 250,STACK OVERFLOW ! 22525: * ! 22526: * NO CHANCE OF RECOVERY IN MID GARBAGE COLLECTION ! 22527: * ! 22528: STAK1 MOV =ENDSO,XR POINT TO MESSAGE ! 22529: ZER KVDMP MEMORY IS UNDUMPABLE ! 22530: ZER WA NO ERROR MESSAGE ! 22531: MOV TTERL,TTLST SEND MESSAGE TO TERML IF POSSIBLE ! 22532: BRN STOPR GIVE UP ! 22533: TTL S P I T B O L -- ERROR SECTION ! 22534: * ! 22535: * THIS SECTION OF CODE IS ENTERED WHENEVER A PROCEDURE ! 22536: * RETURN VIA AN ERR PARAMETER OR AN ERB OPCODE IS OBEYED. ! 22537: * ! 22538: * (WA) IS THE ERROR CODE ! 22539: * ! 22540: * THE GLOBAL VARIABLE STAGE INDICATES THE POINT AT WHICH ! 22541: * THE ERROR OCCURED AS FOLLOWS. ! 22542: * ! 22543: * STAGE=STGIC ERROR DURING INITIAL COMPILE ! 22544: * ! 22545: * STAGE=STGXC ERROR DURING COMPILE AT EXECUTE ! 22546: * TIME (CODE, CONVERT FUNCTION CALLS) ! 22547: * ! 22548: * STAGE=STGEV ERROR DURING COMPILATION OF ! 22549: * EXPRESSION AT EXECUTION TIME ! 22550: * (EVAL, CONVERT FUNCTION CALL). ! 22551: * ! 22552: * STAGE=STGXT ERROR AT EXECUTE TIME. COMPILER ! 22553: * NOT ACTIVE. ! 22554: * ! 22555: * STAGE=STGCE ERROR DURING INITIAL COMPILE AFTER ! 22556: * SCANNING OUT THE END LINE. ! 22557: * ! 22558: * STAGE=STGXE ERROR DURING COMPILE AT EXECUTE ! 22559: * TIME AFTER SCANNING END LINE. ! 22560: * ! 22561: * STAGE=STGEE ERROR DURING EXPRESSION EVALUATION ! 22562: * ! 22563: SEC START OF ERROR SECTION ! 22564: * ! 22565: ERROR RTN ERROR CODE ENTRY POINT ! 22566: BGE ERRFT,=NUM03,ERR16 SKIP IF TOO MANY FATALS ! 22567: BEQ R$CIM,=CMLAB,ERRG1 JUMP IF ERROR IN LABEL SCAN ! 22568: MOV WA,KVERT SAVE ERROR CODE ! 22569: ZER SCNRS RESET RESCAN SWITCH FOR SCANE ! 22570: ZER SCNGO RESET GOTO SWITCH FOR SCANE ! 22571: MOV STAGE,XR LOAD CURRENT STAGE ! 22572: BSW XR,STGNO JUMP TO APPROPRIATE ERROR CIRCUIT ! 22573: IFF STGIC,ERR01 INITIAL COMPILE ! 22574: IFF STGXC,ERR08 EXECUTE TIME COMPILE ! 22575: IFF STGEV,ERR08 EVAL COMPILING EXPR. ! 22576: IFF STGEE,ERR08 EVAL EVALUATING EXPR ! 22577: IFF STGXT,ERR12 EXECUTE TIME ! 22578: IFF STGCE,ERR01 COMPILE - AFTER END ! 22579: IFF STGXE,ERR08 XEQ COMPILE-PAST END ! 22580: ESW END SWITCH ON ERROR TYPE ! 22581: * ! 22582: * ERROR DURING INITIAL COMPILE ! 22583: * THE ERROR MESSAGE IS PRINTED AS PART OF THE COMPILER ! 22584: * OUTPUT. THIS PRINTOUT INCLUDES THE OFFENDING LINE (IF NOT ! 22585: * PRINTED ALREADY) AND AN ERROR FLAG UNDER THE APPROPRIATE ! 22586: * COLUMN AS INDICATED BY SCNSE UNLESS SCNSE IS SET TO ZERO. ! 22587: * AFTER PRINTING THE MESSAGE, THE GENERATED CODE IS ! 22588: * MODIFIED TO AN ERROR CALL AND CONTROL IS RETURNED TO ! 22589: * THE CMPIL PROCEDURE AFTER RESETTING THE STACK POINTER. ! 22590: * IF THE ERROR OCCURS AFTER THE END LINE, CONTROL RETURNS ! 22591: * IN A SLIGHTLY DIFFERENT MANNER TO ENSURE PROPER CLEANUP. ! 22592: EJC ! 22593: * ! 22594: ERR01 MOV CMPXS,XS RESET STACK POINTER ! 22595: SSL CMPSS RESTORE S-R STACK PTR FOR CMPIL ! 22596: BNZ ERRSP,ERR06 JUMP IF ERROR SUPPRESS FLAG SET ! 22597: JSR PRTFH PRINT A BLANK ! 22598: MOV TTERL,TTLST SET FLAG FOR LISTR ! 22599: ADD =NUM03,LSTLC CAUSE EJECT IF BELOW 4 LINES LEFT ! 22600: MOV LSTLC,-(XS) KEEP LINE COUNT ! 22601: JSR LISTR LIST LINE ! 22602: JSR PRTFH TERMINATE LISTING ! 22603: MOV (XS)+,WA RECOVER LINE COUNT ! 22604: BGT LSTLC,WA,ERR02 SKIP IF NOT NEW PAGE ! 22605: ADD =NUM04,LSTLC BUMP FOR LINES PRINTED ! 22606: * ! 22607: * PRINT FLAG UNDER BAD ELEMENT ! 22608: * ! 22609: ERR02 MOV SCNSE,WA LOAD SCAN ELEMENT OFFSET ! 22610: .IF .CAHT ! 22611: MOV WA,WB COPY OFFSET ! 22612: ICV WA INCREASE FOR CH$EX ! 22613: JSR ALOCS STRING BLOCK FOR ERROR FLAG ! 22614: MOV XR,WA REMEMBER STRING PTR ! 22615: PSC XR READY FOR CHARACTER STORING ! 22616: BZE WB,ERR05 SKIP IF NO BLANKS BEFORE ERROR FLAG ! 22617: MOV R$CIM,XL POINT TO BAD STATEMENT ! 22618: PLC XL READY TO GET CHARS ! 22619: LCT WB,WB LOOP COUNTER ! 22620: * ! 22621: * LOOP TO REPLACE ALL CHARS BUT TABS BY BLANKS ! 22622: * ! 22623: ERR03 LCH WC,(XL)+ GET NEXT CHAR ! 22624: BEQ WC,=CH$HT,ERR04 SKIP IF TAB ! 22625: MOV =CH$BL,WC GET A BLANK ! 22626: EJC ! 22627: * ! 22628: * MERGE TO STORE BLANK OR TAB IN ERROR LINE ! 22629: * ! 22630: ERR04 SCH WC,(XR)+ STORE CHAR ! 22631: BCT WB,ERR03 LOOP ! 22632: EJC ! 22633: * ! 22634: * MERGE IN CASE OF NO PRECEDING BLANKS ! 22635: * ! 22636: ERR05 MOV =CH$EX,XL EXCLAMATION MARK ! 22637: SCH XL,(XR) STORE AT END OF ERROR LINE ! 22638: CSC XR END OF SCH LOOP ! 22639: MOV =STNPD,PROFS ALLOW FOR STATEMENT NUMBER ! 22640: MOV WA,XR POINT TO ERROR LINE ! 22641: JSR PRTST PRINT ERROR LINE ! 22642: .ELSE ! 22643: MTI PRLEN GET PRINT BUFFER LENGTH ! 22644: STI GTNSI STORE AS SIGNED INTEGER ! 22645: ADD =STNPD,WA ADJUST FOR STATEMENT NUMBER ! 22646: MTI WA COPY TO INTEGER ACCUMULATOR ! 22647: RMI GTNSI REMAINDER MODULO PRINT BFR LENGTH ! 22648: MFI PROFS USE AS CHARACTER OFFSET ! 22649: MOV =CH$EX,WA GET EXCLAMATION MARK ! 22650: JSR PRTCH GENERATE UNDER BAD COLUMN ! 22651: .FI ! 22652: * ! 22653: * HERE AFTER PLACING ERROR FLAG AS REQUIRED ! 22654: * ! 22655: JSR ERMSG GENERATE FLAG AND ERROR MESSAGE ! 22656: ZER TTLST REVERT TO REGULAR LISTING ! 22657: ZER XR IN CASE OF FATAL ERROR ! 22658: ICV CMERC BUMP ERROR COUNT ! 22659: BNE STAGE,=STGIC,ERRG2 SPECIAL RETURN IF AFTER END LINE ! 22660: * ! 22661: * IF ERROR IN READR THEN EITHER CLOSE OUT ! 22662: * CURRENT -COPY LEVEL, OR IF AT TOP THEN ABORT ! 22663: * ! 22664: BZE RDRER,ERR06 SKIP IF NOT ERROR WHILE READING ! 22665: BZE R$COP,ERR16 ABORT IF AT TOP LEVEL INPUT FILE ! 22666: ZER RDRER ELSE CLEAR READR ERROR FLAG ! 22667: JSR COPND AND CLOSE OUT THIS COPY LEVEL ! 22668: * ! 22669: * LOOP TO SCAN TO END OF STATEMENT ! 22670: * ! 22671: ERR06 MOV R$CIM,XR POINT TO START OF IMAGE ! 22672: BZE XR,ERR07 SKIP IF NO INPUT IMAGE ! 22673: PLC XR POINT TO FIRST CHAR ! 22674: LCH XR,(XR) GET FIRST CHAR ! 22675: BEQ XR,=CH$MN,ERRG3 JUMP IF ERROR IN CONTROL CARD ! 22676: ZER SCNRS CLEAR RESCAN FLAG ! 22677: MNZ ERRSP SET ERROR SUPPRESS FLAG ! 22678: JSR SCANE SCAN NEXT ELEMENT ! 22679: BNE XL,=T$SMC,ERR06 LOOP BACK IF NOT STATEMENT END ! 22680: ZER ERRSP CLEAR ERROR SUPPRESS FLAG ! 22681: EJC ! 22682: * ! 22683: * GENERATE ERROR CALL IN CODE AND RETURN TO CMPIL ! 22684: * ! 22685: ERR07 MOV *CDCOD,CWCOF RESET OFFSET IN CCBLK ! 22686: MOV =OCER$,WA LOAD COMPILE ERROR CALL ! 22687: JSR CDWRD GENERATE IT ! 22688: MOV CWCOF,CMSOC(XS) SET SUCCESS FILL IN OFFSET ! 22689: MNZ CMFFC(XS) SET FAILURE FILL IN FLAG ! 22690: JSR CDWRD GENERATE SUCC. FILL IN WORD ! 22691: JMG CMPSE MERGE TO GENERATE ERROR AS CDFAL ! 22692: EJC ! 22693: * ! 22694: * ERROR DURING EXECUTE TIME COMPILE OR EXPRESSION EVALUATION. ! 22695: * ! 22696: * EXECUTE TIME COMPILATION IS INITIATED THROUGH GTCOD OR ! 22697: * GTEXP WHICH ARE CALLED BY COMPILE, CODE OR EVAL. ! 22698: * BEFORE CAUSING STATEMENT FAILURE THROUGH EXFAL IT IS ! 22699: * HELPFUL TO SET KEYWORD ERRTEXT AND FOR GENERALITY ! 22700: * THESE ERRORS MAY BE HANDLED BY THE SETEXIT MECHANISM. ! 22701: * ! 22702: ERR08 JSR COPND CALL TO CLOSE OFF THIS LEVEL ! 22703: BNZ R$COP,ERR08 LOOP IF NOT ALL -COPYS CLOSED ! 22704: ZER R$CCB FORGET GARBAGE CODE BLOCK ! 22705: SSL INISS RESTORE MAIN PROG S-R STACK PTR ! 22706: JSR ERTEX GET FAIL MESSAGE TEXT ! 22707: DCA XS ENSURE STACK OK ON LOOP START ! 22708: * ! 22709: * POP STACK UNTIL FIND FLPTR FOR MOST DEEPLY NESTED PROG. ! 22710: * DEFINED FUNCTION CALL OR CALL OF EVAL / CODE. ! 22711: * ! 22712: ERR09 ICA XS POP STACK ! 22713: BEQ XS,FLPRT,ERR11 JUMP IF PROG DEFINED FN CALL FOUND ! 22714: BNE XS,GTCEF,ERR09 LOOP IF NOT EVAL OR CODE CALL YET ! 22715: MOV =STGXT,STAGE RE-SET STAGE FOR EXECUTE ! 22716: MOV R$GTC,R$COD RECOVER CODE PTR ! 22717: MOV XS,FLPTR RESTORE FAIL POINTER ! 22718: ZER R$CIM FORGET POSSIBLE IMAGE ! 22719: * ! 22720: * TEST ERRLIMIT ! 22721: * ! 22722: ERR10 BNZ KVERL,ERR14 JUMP IF ERRLIMIT NON-ZERO ! 22723: BRN EXFAL FAIL ! 22724: * ! 22725: * RETURN FROM PROG. DEFINED FUNCTION IS OUTSTANDING ! 22726: * ! 22727: ERR11 MOV FLPTR,XS RESTORE STACK FROM FLPTR ! 22728: BRN ERR10 MERGE ! 22729: * ! 22730: * ERROR AT EXECUTE TIME. ! 22731: * ! 22732: * THE ACTION TAKEN ON AN ERROR IS AS FOLLOWS. ! 22733: * ! 22734: * IF ERRLIMIT KEYWORD IS ZERO, THE RUN IS ABORTED. ! 22735: * OTHERWISE, ERRLIMIT IS DECREMENTED AND AN ERRTYPE TRACE ! 22736: * GENERATED IF REQUIRED. CONTROL RETURNS EITHER VIA A JUMP ! 22737: * TO CONTINUE (TO TAKE THE FAILURE EXIT) OR A SPECIFIED ! 22738: * SETEXIT TRAP IS EXECUTED AND CONTROL PASSES TO THE TRAP. ! 22739: * IF 3 OR MORE FATAL ERRORS OCCUR AN ABORT OCCURS ! 22740: * REGARDLESS OF ERRLIMIT AND SETEXIT - LOOPING IS ALL TOO ! 22741: * PROBABLE OTHERWISE. FATAL ERRORS INCLUDE STACK OVERFLOW ! 22742: * AND EXCEEDING STLIMIT. ! 22743: EJC ! 22744: * ! 22745: ERR12 SSL INISS RESTORE MAIN PROG S-R STACK PTR ! 22746: BNZ DMVCH,ERR15 JUMP IF IN MID-DUMP ! 22747: * ! 22748: * MERGE HERE AFTER DUMP TIDY UP ! 22749: * ! 22750: ERR13 ZER XR CLEAR XR FLAG ! 22751: BZE KVERL,STOPR ABORT IF ERRLIMIT IS ZERO ! 22752: JSR ERTEX GET FAIL MESSAGE TEXT ! 22753: * ! 22754: * MERGE AFTER ERRLIMIT TEST ! 22755: * ! 22756: ERR14 DCV KVERL DECREMENT ERRLIMIT ! 22757: MOV R$ERT,XL LOAD ERRTYPE TRACE POINTER ! 22758: JSR KTREX GENERATE ERRTYPE TRACE IF REQUIRED ! 22759: MOV R$COD,R$CNT SET CDBLK PTR FOR CONTINUATION ! 22760: MOV FLPTR,XR SET PTR TO FAILURE OFFSET ! 22761: MOV (XR),STXOF SAVE FAILURE OFFSET FOR CONTINUE ! 22762: MOV R$SXC,XR LOAD SETEXIT CDBLK POINTER ! 22763: BZE XR,ERRG4 CONTINUE IF NO SETEXIT TRAP ! 22764: ZER R$SXC ELSE RESET TRAP ! 22765: MOV =NULLS,STXVR RESET SETEXIT ARG TO NULL ! 22766: MOV (XR),XL LOAD PTR TO CODE BLOCK ROUTINE ! 22767: BRI XL EXECUTE FIRST TRAP STATEMENT ! 22768: * ! 22769: * INTERRUPTED PARTLY THROUGH A DUMP WHILST STORE IS IN A ! 22770: * MESS SO DO A TIDY UP OPERATION. SEE DUMPR FOR DETAILS. ! 22771: * ! 22772: ERR15 MOV DMVCH,XR CHAIN HEAD FOR AFFECTED VRBLKS ! 22773: BZE XR,ERR13 DONE IF ZERO ! 22774: MOV (XR),DMVCH SET NEXT LINK AS CHAIN HEAD ! 22775: JSR SETVR RESTORE VRGET FIELD ! 22776: BRN ERR15 LOOP THROUGH CHAIN ! 22777: * ! 22778: * TAKE DRACONIAN STEPS FOR REPEATED FATAL ERRORS ! 22779: * ! 22780: ERR16 MOV ERRTF,WA ERROR CODE ! 22781: MOV WA,KVERT PLACE ERROR CODE FOR ERMSG ! 22782: MNZ XR IN CASE COMPILE TIME ! 22783: BEQ STAGE,=STGIC,STOPR JUMP IF SO ! 22784: BEQ STAGE,=STGCE,STOPR ALSO COMPILE TIME ! 22785: ZER XR INDICATE EXECUTION ! 22786: BRN STOPR TERMINATE RUN ! 22787: * ! 22788: ERRAF ERB 251,TOO MANY FATAL ERRORS ! 22789: * ! 22790: * HERE FOR GLOBAL ERROR JUMPS ! 22791: * ! 22792: ERRG1 JMG CMPLE ! 22793: ERRG2 JMG CMPEE ! 22794: ERRG3 JMG CMPCE ! 22795: ERRG4 JMG LCNXE ! 22796: TTL S P I T B O L -- HERE ENDETH THE CODE ! 22797: * ! 22798: * END OF ASSEMBLY ! 22799: * ! 22800: END END MACRO-SPITBOL ASSEMBLY
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.