![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to spitv35.ppmin CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / spitbol|
Return to spitv35.ppmin CVS log | Up to [Research Unix] / researchv10no / cmd / spitbol |
1.1 ! root 1: TTL S P I T B O L - REVISION HISTORY ! 2: EJC ! 3: * R E V I S I O N H I S T O R Y ! 4: * ------------------------------- ! 5: * ! 6: * ! 7: * VERSION 3.5B (FEB 81... - SGD PATCHES) ! 8: * ----------------------------------- ! 9: * ! 10: * SGD03 - ADDITION OF .CNCI AND SYSCI (INT->STRING ! 11: * SYSTEM ROUTINE OPTION) ! 12: * SGD04 - (06-MAY-1981) MODIFIED INILN TO 132 ! 13: * SGD05 - (13-MAY-1981) INSERTED MISSING WTB AFTER SYSMM ! 14: * CALLS ! 15: * SGD06 - (25-MAY-1981) MERGED IN PROFILER PATCHES ! 16: * (NOT MARKED) ! 17: * SGD07 - (25-MAY-1981) MUCHO PATCHES TO PROFILER (MARKED, ! 18: * BUT BEST JUST TO EXTRACT ENMASSE) ! 19: * SGD08 - (25-MAY-1981) USE STRING LENGTH IN HASHS ! 20: * SGD09 - (25-MAY-1981) FIXED SERIOUS PARSER PROBLEM ! 21: * RELATING TO (X Y) ON LINE BEING VIEWED AS PATTERN ! 22: * MATCH. FIXED BY ADDITION OF NEW CMTYP VALUE ! 23: * C$CNP (CONCATENATION - NOT PATTERN MATCH) ! 24: * SGD10 - (01-AUG-1981) FIXED EXIT(N) RESPECIFICATION CODE ! 25: * TO PROPERLY OBSERVE HEADER SEMANTICS ON RETURN. ! 26: * SGD11 - (07-AUG-1981) BYPASS PRTPG CALL AT INITIALIZATION ! 27: * FOLLOWING COMPILATION IF NO OUTPUT GENERATED. ! 28: * THIS PREVENTS OUTPUT FILES CONSISTING OF THE ! 29: * HEADERS AND A FEW BLANK LINES WHEN THERE IS NO ! 30: * SOURCE LISTING AND NO COMPILATION STATS. ! 31: * ALSO FIX TIMSX INITIALIZATION IN SAME CODE. ! 32: * SGD12 - (17-AUG-1981) B$EFC CODE DID NOT CHECK FOR ! 33: * UNCONVERTED RESULT RETURNING NULL STRING. FIXED. ! 34: * SGDBF - ( NOV-1981) ADDED BUFFER TYPE AND SYMBOL CNBF ! 35: * SGD13 - (03-MAR-1982) LOAD PFVBL FIELD IN RETRN FOR ! 36: * RETURN TRACING. THIS WAS CAUSING BUG ON RETURN ! 37: * TRACES THAT TRIED TO ACCESS THE VARIABLE NAME ! 38: * SGD14 - ADDED CHAR FUNCTION. CHAR(N) RETURNS NTH ! 39: * CHARACTER OF HOST MACHINE CHARACTER SET. ! 40: * NOT CONDITIONALIZED OR MARKED. ! 41: * SGD15 - FIXED PROBLEM RELATING TO COMPILATION OF GOTO ! 42: * FIELDS CONTAINING SMALL INTEGERS (IN CONST SEC). ! 43: * ! 44: * REG01 - (XX-AUG-82) ! 45: * ADDED CFP$U TO EASE TRANSLATION ON SMALLER ! 46: * SYSTEMS - CONDITIONAL .CUCF ! 47: * ADDED LOWER CASE SUPPORT - CONDITIONAL .CULC ! 48: * ADDED SET I/O FUNCTION - CONDITIONAL .CUST ! 49: * ! 50: * REG02 - (XX-SEP-82) ! 51: * CHANGED INILN AND AND INILS TO 258 ! 52: * ! 53: * REG03 - (XX-OCT-82) ! 54: * CONDITIONALIZED THE PAGE EJECT AFTER CALL TO SYSBX ! 55: * AND ADDED ANOTHER BEFORE CALL TO SYSBX, SO THAT, ! 56: * IF DESIRED BY THE IMPLEMENTOR, STANDARD OUTPUT ! 57: * WILL REFLECT ASSIGNMENTS MADE BY EXECUTING PROGRAM ! 58: * ONLY. CONDITIONAL .CUEJ CONTROLS - IF DEFINED ! 59: * EJECT IS BEFORE CALL TO SYSBX. ! 60: * ! 61: * REG04 - (XX-NOV-82) ! 62: * FIXED DIFFICULTIES WITH LISTINGS DURING EXECUTION ! 63: * WHEN NO LISTING GENERATED DURING COMPILATION. ! 64: * ! 65: * -LIST TO CODE() CAUSED BOMB. FIX IS TO RESET ! 66: * R$TTL AND R$STL TO NULLS NOT 0 AFTER COMPILATION. ! 67: * (LISTR AND LISTT EXPECT NULLS) ! 68: * ! 69: * WHEN LISTING AND STATISTICS ROUTED TO DIFFERENT ! 70: * FILE THAN EXECUTION OUTPUT, ERROR MESSAGE IS SENT ! 71: * TO EXECUTION OUTPUT (AND GETS SEPARATED FROM ! 72: * ... IN STATEMENT ... MSG). LABO1 CALLS SYSAX AND ! 73: * STOPR DOES NOT CALL SYSAX IF ENTERED FROM LABO1. ! 74: * ! 75: * REG05 - (XX-NOV-82) ! 76: * PREVENT CLEAR() FROM CLOBBERING PROTECTED VARIABLES ! 77: * AT LABEL SCLR5. ! 78: * ! 79: * REG06 - (XX-NOV-82) ! 80: * FIXED GTEXP FROM ACCEPTING TRAILING SEMICOLON OR ! 81: * COLON. NOT LEGAL WAY TO END AN EXPRESSION. ! 82: * ! 83: * VERSION 3.5A (OCT 79 - SGD PATCHES) ! 84: * ----------------------------------- ! 85: * ! 86: * SGD01 - PATCH IN ASIGN TO FIX MULTIPLE TRAP BLOCK PROBLEM ! 87: * (ASG10+2) ! 88: * SGD02 - PATCH IN GTARR TO FIX NULL CONVERT (GTAR9+0) ! 89: * ! 90: TTL S P I T B O L -- BASIC INFORMATION ! 91: EJC ! 92: * ! 93: * GENERAL STRUCTURE ! 94: * ----------------- ! 95: * ! 96: * THIS PROGRAM IS A TRANSLATOR FOR A VERSION OF THE SNOBOL4 ! 97: * PROGRAMMING LANGUAGE. LANGUAGE DETAILS ARE CONTAINED IN ! 98: * THE MANUAL MACRO SPITBOL BY DEWAR AND MCCANN, TECHNICAL ! 99: * REPORT 90, UNIVERSITY OF LEEDS 1976. THE LANGUAGE ! 100: * IS IDENTICAL TO THAT IMPLEMENTED BY THE BTL TRANSLATOR ! 101: * (R. E. GRISWOLD ET AL.) WITH THE FOLLOWING EXCEPTIONS. ! 102: * ! 103: * 1) REDEFINITION OF STANDARD SYSTEM FUNCTIONS AND ! 104: * OPERATORS IS NOT PERMITTED. ! 105: * ! 106: * 2) THE VALUE FUNCTION IS NOT PROVIDED. ! 107: * ! 108: * 3) ACCESS TRACING IS PROVIDED IN ADDITION TO THE ! 109: * OTHER STANDARD TRACE MODES. ! 110: * ! 111: * 4) THE KEYWORD STFCOUNT IS NOT PROVIDED. ! 112: * ! 113: * 5) THE KEYWORD FULLSCAN IS NOT PROVIDED AND ALL PATTERN ! 114: * MATCHING TAKES PLACE IN FULLSCAN MODE (I.E. WITH NO ! 115: * HEURISTICS APPLIED). ! 116: * ! 117: * 6) A SERIES OF EXPRESSIONS SEPARATED BY COMMAS MAY ! 118: * BE GROUPED WITHIN PARENTHESES TO PROVIDE A SELECTION ! 119: * CAPABILITY. THE SEMANTICS ARE THAT THE SELECTION ! 120: * ASSUMES THE VALUE OF THE FIRST EXPRESSION WITHIN IT ! 121: * WHICH SUCCEEDS AS THEY ARE EVALUATED FROM THE LEFT. ! 122: * IF NO EXPRESSION SUCCEEDS THE ENTIRE STATEMENT FAILS ! 123: * ! 124: * 7) AN EXPLICIT PATTERN MATCHING OPERATOR IS PROVIDED. ! 125: * THIS IS THE BINARY QUERY (SEE GIMPEL SIGPLAN OCT 74) ! 126: * ! 127: * 8) THE ASSIGNMENT OPERATOR IS INTRODUCED AS IN THE ! 128: * GIMPEL REFERENCE. ! 129: * ! 130: * 9) THE EXIT FUNCTION IS PROVIDED FOR GENERATING LOAD ! 131: * MODULES - CF. GIMPELS SITBOL. ! 132: * ! 133: * ! 134: * THE METHOD USED IN THIS PROGRAM IS TO TRANSLATE THE ! 135: * SOURCE CODE INTO AN INTERNAL PSEUDO-CODE (SEE FOLLOWING ! 136: * SECTION). AN INTERPRETOR IS THEN USED TO EXECUTE THIS ! 137: * GENERATED PSEUDO-CODE. THE NATURE OF THE SNOBOL4 LANGUAGE ! 138: * IS SUCH THAT THE LATTER TASK IS MUCH MORE COMPLEX THAN ! 139: * THE ACTUAL TRANSLATION PHASE. ACCORDINGLY, NEARLY ALL THE ! 140: * CODE IN THE PROGRAM SECTION IS CONCERNED WITH THE ACTUAL ! 141: * EXECUTION OF THE SNOBOL4 PROGRAM. ! 142: EJC ! 143: * ! 144: * INTERPRETIVE CODE FORMAT ! 145: * ------------------------ ! 146: * ! 147: * THE INTERPRETIVE PSEUDO-CODE CONSISTS OF A SERIES OF ! 148: * ADDRESS POINTERS. THE EXACT FORMAT OF THE CODE IS ! 149: * DESCRIBED IN CONNECTION WITH THE CDBLK FORMAT. THE ! 150: * PURPOSE OF THIS SECTION IS TO GIVE GENERAL INSIGHT INTO ! 151: * THE INTERPRETIVE APPROACH INVOLVED. ! 152: * ! 153: * THE BASIC FORM OF THE CODE IS RELATED TO REVERSE POLISH. ! 154: * IN OTHER WORDS, THE OPERANDS PRECEDE THE OPERATORS WHICH ! 155: * ARE ZERO ADDRESS OPERATORS. THERE ARE SOME EXCEPTIONS TO ! 156: * THESE RULES, NOTABLY THE UNARY NOT OPERATOR AND THE ! 157: * SELECTION CONSTRUCTION WHICH CLEARLY REQUIRE ADVANCE ! 158: * KNOWLEDGE OF THE OPERATOR INVOLVED. ! 159: * ! 160: * THE OPERANDS ARE MOVED TO THE TOP OF THE MAIN STACK AND ! 161: * THE OPERATORS ARE APPLIED TO THE TOP STACK ENTRIES. LIKE ! 162: * OTHER VERSIONS OF SPITBOL, THIS PROCESSOR DEPENDS ON ! 163: * KNOWING WHETHER OPERANDS ARE REQUIRED BY NAME OR BY VALUE ! 164: * AND MOVES THE APPROPRIATE OBJECT TO THE STACK. THUS NO ! 165: * NAME/VALUE CHECKS ARE INCLUDED IN THE OPERATOR CIRCUITS. ! 166: * ! 167: * THE ACTUAL POINTERS IN THE CODE POINT TO A BLOCK WHOSE ! 168: * FIRST WORD IS THE ADDRESS OF THE INTERPRETOR ROUTINE ! 169: * TO BE EXECUTED FOR THE CODE WORD. ! 170: * ! 171: * IN THE CASE OF OPERATORS, THE POINTER IS TO A WORD WHICH ! 172: * CONTAINS THE ADDRESS OF THE OPERATOR TO BE EXECUTED. IN ! 173: * THE CASE OF OPERANDS SUCH AS CONSTANTS, THE POINTER IS TO ! 174: * THE OPERAND ITSELF. ACCORDINGLY, ALL OPERANDS CONTAIN ! 175: * A FIELD WHICH POINTS TO THE ROUTINE TO LOAD THE VALUE OF ! 176: * THE OPERAND ONTO THE STACK. IN THE CASE OF A VARIABLE, ! 177: * THERE ARE THREE SUCH POINTERS. ONE TO LOAD THE VALUE, ! 178: * ONE TO STORE THE VALUE AND A THIRD TO JUMP TO THE LABEL. ! 179: * ! 180: * THE HANDLING OF FAILURE RETURNS DESERVES SPECIAL COMMENT. ! 181: * THE LOCATION FLPTR CONTAINS THE POINTER TO THE LOCATION ! 182: * ON THE MAIN STACK WHICH CONTAINS THE FAILURE RETURN ! 183: * WHICH IS IN THE FORM OF A BYTE OFFSET IN THE CURRENT ! 184: * CODE BLOCK (CDBLK OR EXBLK). WHEN A FAILURE OCCURS, THE ! 185: * STACK IS POPPED AS INDICATED BY THE SETTING OF FLPTR AND ! 186: * CONTROL IS PASSED TO THE APPROPRIATE LOCATION IN THE ! 187: * CURRENT CODE BLOCK WITH THE STACK POINTER POINTING TO THE ! 188: * FAILURE OFFSET ON THE STACK AND FLPTR UNCHANGED. ! 189: EJC ! 190: * ! 191: * INTERNAL DATA REPRESENTATIONS ! 192: * ----------------------------- ! 193: * ! 194: * REPRESENTATION OF VALUES ! 195: * ! 196: * A VALUE IS REPRESENTED BY A POINTER TO A BLOCK WHICH ! 197: * DESCRIBES THE TYPE AND PARTICULARS OF THE DATA VALUE. ! 198: * IN GENERAL, A VARIABLE IS A LOCATION CONTAINING SUCH A ! 199: * POINTER (ALTHOUGH IN THE CASE OF TRACE ASSOCIATIONS THIS ! 200: * IS MODIFIED, SEE DESCRIPTION OF TRBLK). ! 201: * ! 202: * THE FOLLOWING IS A LIST OF POSSIBLE DATATYPES SHOWING THE ! 203: * TYPE OF BLOCK USED TO HOLD THE VALUE. THE DETAILS OF ! 204: * EACH BLOCK FORMAT ARE GIVEN LATER. ! 205: * ! 206: * DATATYPE BLOCK TYPE ! 207: * -------- ---------- ! 208: * ! 209: * ! 210: * ARRAY ARBLK OR VCBLK ! 211: * ! 212: * CODE CDBLK ! 213: * ! 214: * EXPRESSION EXBLK OR SEBLK ! 215: * ! 216: * INTEGER ICBLK ! 217: * ! 218: * NAME NMBLK ! 219: * ! 220: * PATTERN P0BLK OR P1BLK OR P2BLK ! 221: * ! 222: * REAL RCBLK ! 223: * ! 224: * STRING SCBLK ! 225: * ! 226: * TABLE TBBLK ! 227: * ! 228: * PROGRAM DATATYPE PDBLK ! 229: EJC ! 230: * ! 231: * REPRESENTATION OF VARIABLES ! 232: * --------------------------- ! 233: * ! 234: * DURING THE COURSE OF EVALUATING EXPRESSIONS, IT IS ! 235: * NECESSARY TO GENERATE NAMES OF VARIABLES (FOR EXAMPLE ! 236: * ON THE LEFT SIDE OF A BINARY EQUALS OPERATOR). THESE ARE ! 237: * NOT TO BE CONFUSED WITH OBJECTS OF DATATYPE NAME WHICH ! 238: * ARE IN FACT VALUES. ! 239: * ! 240: * FROM A LOGICAL POINT OF VIEW, SUCH NAMES COULD BE SIMPLY ! 241: * REPRESENTED BY A POINTER TO THE APPROPRIATE VALUE CELL. ! 242: * HOWEVER IN THE CASE OF ARRAYS AND PROGRAM DEFINED ! 243: * DATATYPES, THIS WOULD VIOLATE THE RULE THAT THERE MUST BE ! 244: * NO POINTERS INTO THE MIDDLE OF A BLOCK IN DYNAMIC STORE. ! 245: * ACCORDINGLY, A NAME IS ALWAYS REPRESENTED BY A BASE AND ! 246: * OFFSET. THE BASE POINTS TO THE START OF THE BLOCK ! 247: * CONTAINING THE VARIABLE VALUE AND THE OFFSET IS THE ! 248: * OFFSET WITHIN THIS BLOCK IN BYTES. THUS THE ADDRESS ! 249: * OF THE ACTUAL VARIABLE IS DETERMINED BY ADDING THE BASE ! 250: * AND OFFSET VALUES. ! 251: * ! 252: * THE FOLLOWING ARE THE INSTANCES OF VARIABLES REPRESENTED ! 253: * IN THIS MANNER. ! 254: * ! 255: * 1) NATURAL VARIABLE BASE IS PTR TO VRBLK ! 256: * OFFSET IS *VRVAL ! 257: * ! 258: * 2) TABLE ELEMENT BASE IS PTR TO TEBLK ! 259: * OFFSET IS *TEVAL ! 260: * ! 261: * 3) ARRAY ELEMENT BASE IS PTR TO ARBLK ! 262: * OFFSET IS OFFSET TO ELEMENT ! 263: * ! 264: * 4) VECTOR ELEMENT BASE IS PTR TO VCBLK ! 265: * OFFSET IS OFFSET TO ELEMENT ! 266: * ! 267: * 5) PROG DEF DTP BASE IS PTR TO PDBLK ! 268: * OFFSET IS OFFSET TO FIELD VALUE ! 269: * ! 270: * IN ADDITION THERE ARE TWO CASES OF OBJECTS WHICH ARE ! 271: * LIKE VARIABLES BUT CANNOT BE HANDLED IN THIS MANNER. ! 272: * THESE ARE CALLED PSEUDO-VARIABLES AND ARE REPRESENTED ! 273: * WITH A SPECIAL BASE POINTER AS FOLLOWS= ! 274: * ! 275: * EXPRESSION VARIABLE PTR TO EVBLK (SEE EVBLK) ! 276: * ! 277: * KEYWORD VARIABLE PTR TO KVBLK (SEE KVBLK) ! 278: * ! 279: * PSEUDO-VARIABLES ARE HANDLED AS SPECIAL CASES BY THE ! 280: * ACCESS PROCEDURE (ACESS) AND THE ASSIGNMENT PROCEDURE ! 281: * (ASIGN). SEE THESE TWO PROCEDURES FOR DETAILS. ! 282: EJC ! 283: * ! 284: * ORGANIZATION OF DATA AREA ! 285: * ------------------------- ! 286: * ! 287: * ! 288: * THE DATA AREA IS DIVIDED INTO TWO REGIONS. ! 289: * ! 290: * STATIC AREA ! 291: * ! 292: * THE STATIC AREA BUILDS UP FROM THE BOTTOM AND CONTAINS ! 293: * DATA AREAS WHICH ARE ALLOCATED DYNAMICALLY BUT ARE NEVER ! 294: * DELETED OR MOVED AROUND. THE MACRO-PROGRAM ITSELF ! 295: * USES THE STATIC AREA FOR THE FOLLOWING. ! 296: * ! 297: * 1) ALL VARIABLE BLOCKS (VRBLK). ! 298: * ! 299: * 2) THE HASH TABLE FOR VARIABLE BLOCKS. ! 300: * ! 301: * 3) MISCELLANEOUS BUFFERS AND WORK AREAS (SEE PROGRAM ! 302: * INITIALIZATION SECTION). ! 303: * ! 304: * IN ADDITION, THE SYSTEM PROCEDURES MAY USE THIS AREA FOR ! 305: * INPUT/OUTPUT BUFFERS, EXTERNAL FUNCTIONS ETC. SPACE IN ! 306: * THE STATIC REGION IS ALLOCATED BY CALLING PROCEDURE ALOST ! 307: * ! 308: * THE FOLLOWING GLOBAL VARIABLES DEFINE THE CURRENT ! 309: * LOCATION AND SIZE OF THE STATIC AREA. ! 310: * ! 311: * STATB ADDRESS OF START OF STATIC AREA ! 312: * STATE ADDRESS+1 OF LAST WORD IN AREA. ! 313: * ! 314: * THE MINIMUM SIZE OF STATIC IS GIVEN APPROXIMATELY BY ! 315: * 12 + *E$HNB + *E$STS + SPACE FOR ALPHABET STRING ! 316: * AND STANDARD PRINT BUFFER. ! 317: EJC ! 318: * ! 319: * DYNAMIC AREA ! 320: * ! 321: * THE DYNAMIC AREA IS BUILT UPWARDS IN MEMORY AFTER THE ! 322: * STATIC REGION. DATA IN THIS AREA MUST ALL BE IN STANDARD ! 323: * BLOCK FORMATS SO THAT IT CAN BE PROCESSED BY THE GARBAGE ! 324: * COLLECTOR (PROCEDURE GBCOL). GBCOL COMPACTS BLOCKS DOWN ! 325: * IN THIS REGION AS REQUIRED BY SPACE EXHAUSTION AND CAN ! 326: * ALSO MOVE ALL BLOCKS UP TO ALLOW FOR EXPANSION OF THE ! 327: * STATIC REGION. ! 328: * WITH THE EXCEPTION OF TABLES AND ARRAYS, NO SPITBOL ! 329: * OBJECT ONCE BUILT IN DYNAMIC MEMORY IS EVER SUBSEQUENTLY ! 330: * MODIFIED. OBSERVING THIS RULE NECESSITATES A COPYING ! 331: * ACTION DURING STRING AND PATTERN CONCATENATION. ! 332: * ! 333: * GARBAGE COLLECTION IS FUNDAMENTAL TO THE ALLOCATION OF ! 334: * SPACE FOR VALUES. SPITBOL USES A VERY EFFICIENT GARBAGE ! 335: * COLLECTOR WHICH INSISTS THAT POINTERS INTO DYNAMIC STORE ! 336: * SHOULD BE IDENTIFIABLE WITHOUT USE OF BIT TABLES, ! 337: * MARKER BITS ETC. TO SATISFY THIS REQUIREMENT, DYNAMIC ! 338: * MEMORY MUST NOT START AT TOO LOW AN ADDRESS AND LENGTHS ! 339: * OF ARRAYS, TABLES, STRINGS, CODE AND EXPRESSION BLOCKS ! 340: * MAY NOT EXCEED THE NUMERICAL VALUE OF THE LOWEST DYNAMIC ! 341: * ADDRESS. TO AVOID EITHER PENALIZING USERS WITH MODEST ! 342: * REQUIREMENTS OR RESTRICTING THOSE WITH GREATER NEEDS ON ! 343: * HOST SYSTEMS WHERE DYNAMIC MEMORY IS ALLOCATED IN LOW ! 344: * ADDRESSES, THE MINIMUM DYNAMIC ADDRESS MAY BE SPECIFIED ! 345: * SUFFICIENTLY HIGH TO PERMIT ARBITRARILY LARGE SPITBOL ! 346: * OBJECTS TO BE CREATED ( WITH THE POSSIBILITY IN EXTREME ! 347: * CASES OF WASTING LARGE AMOUNTS OF MEMORY BELOW THE ! 348: * START ADDRESS). THIS MINIMUM VALUE IS MADE AVAILABLE ! 349: * IN VARIABLE MXLEN BY A SYSTEM ROUTINE, SYSMX. ! 350: * ALTERNATIVELY SYSMX MAY INDICATE THAT A ! 351: * DEFAULT MAY BE USED IN WHICH DYNAMIC IS PLACED ! 352: * AT THE LOWEST POSSIBLE ADDRESS FOLLOWING STATIC. ! 353: * ! 354: * THE FOLLOWING GLOBAL WORK CELLS DEFINE THE LOCATION AND ! 355: * LENGTH OF THE DYNAMIC AREA. ! 356: * ! 357: * DNAMB START OF DYNAMIC AREA ! 358: * DNAMP NEXT AVAILABLE LOCATION ! 359: * DNAME LAST AVAILABLE LOCATION + 1 ! 360: * ! 361: * DNAMB IS ALWAYS HIGHER THAN STATE SINCE THE ALOST ! 362: * PROCEDURE MAINTAINS SOME EXPANSION SPACE ABOVE STATE. ! 363: * *** DNAMB MUST NEVER BE PERMITTED TO HAVE A VALUE LESS ! 364: * THAN THAT IN MXLEN *** ! 365: * ! 366: * SPACE IN THE DYNAMIC REGION IS ALLOCATED BY THE ALLOC ! 367: * PROCEDURE. THE DYNAMIC REGION MAY BE USED BY SYSTEM ! 368: * PROCEDURES PROVIDED THAT ALL THE RULES ARE OBEYED. ! 369: EJC ! 370: * ! 371: * REGISTER USAGE ! 372: * -------------- ! 373: * ! 374: * (CP) CODE POINTER REGISTER. USED TO ! 375: * HOLD A POINTER TO THE CURRENT ! 376: * LOCATION IN THE INTERPRETIVE PSEUDO ! 377: * CODE (I.E. PTR INTO A CDBLK). ! 378: * ! 379: * (XL,XR) GENERAL INDEX REGISTERS. USUALLY ! 380: * USED TO HOLD POINTERS TO BLOCKS IN ! 381: * DYNAMIC STORAGE. AN IMPORTANT ! 382: * RESTRICTION IS THAT THE VALUE IN ! 383: * XL MUST BE COLLECTABLE FOR ! 384: * A GARBAGE COLLECT CALL. A VALUE ! 385: * IS COLLECTABLE IF IT EITHER POINTS ! 386: * OUTSIDE THE DYNAMIC AREA, OR IF IT ! 387: * POINTS TO THE START OF A BLOCK IN ! 388: * THE DYNAMIC AREA. ! 389: * ! 390: * (XS) STACK POINTER. USED TO POINT TO ! 391: * THE STACK FRONT. THE STACK MAY ! 392: * BUILD UP OR DOWN AND IS USED ! 393: * TO STACK SUBROUTINE RETURN POINTS ! 394: * AND OTHER RECURSIVELY SAVED DATA. ! 395: * ! 396: * (XT) AN ALTERNATIVE NAME FOR XL DURING ! 397: * ITS USE IN ACCESSING STACKED ITEMS. ! 398: * ! 399: * (WA,WB,WC) GENERAL WORK REGISTERS. CANNOT BE ! 400: * USED FOR INDEXING, BUT MAY HOLD ! 401: * VARIOUS TYPES OF DATA. ! 402: * ! 403: * (IA) USED FOR ALL SIGNED INTEGER ! 404: * ARITHMETIC, BOTH THAT USED BY THE ! 405: * TRANSLATOR AND THAT ARISING FROM ! 406: * USE OF SNOBOL4 ARITHMETIC OPERATORS ! 407: * ! 408: * (RA) REAL ACCUMULATOR. USED FOR ALL ! 409: * FLOATING POINT ARITHMETIC. ! 410: EJC ! 411: * ! 412: * SPITBOL CONDITIONAL ASSEMBLY SYMBOLS ! 413: * ------------------------------------ ! 414: * ! 415: * IN THE SPITBOL TRANSLATOR, THE FOLLOWING CONDITIONAL ! 416: * ASSEMBLY SYMBOLS ARE REFERRED TO. TO INCORPORATE THE ! 417: * FEATURES REFERRED TO, THE MINIMAL SOURCE SHOULD BE ! 418: * PREFACED BY SUITABLE CONDITIONAL ASSEMBLY SYMBOL ! 419: * DEFINITIONS. ! 420: * IN ALL CASES IT IS PERMISSIBLE TO DEFAULT THE DEFINITIONS ! 421: * IN WHICH CASE THE ADDITIONAL FEATURES WILL BE OMITTED ! 422: * FROM THE TARGET CODE. ! 423: * ! 424: * .CASL DEFINE TO INCLUDE 26 SHIFTED LETTRS ! 425: * .CAHT DEFINE TO INCLUDE HORIZONTAL TAB ! 426: * .CAVT DEFINE TO INCLUDE VERTICAL TAB ! 427: * .CIOD IF DEFINED, DEFAULT DELIMITER IS ! 428: * NOT USED IN PROCESSING 3RD ARG OF ! 429: * INPUT() AND OUTPUT() ! 430: * .CNBT DEFINE TO OMIT BATCH INITIALISATION ! 431: * .CNCI DEFINE TO ENABLE SYSCI ROUTINE ! 432: * .CNEX DEFINE TO OMIT EXIT() CODE. ! 433: * .CNLD DEFINE TO OMIT LOAD() CODE. ! 434: * .CNPF DEFINE TO OMIT PROFILE STUFF ! 435: * .CNRA DEFINE TO OMIT ALL REAL ARITHMETIC ! 436: * .CNSR DEFINE TO OMIT SORT, RSORT ! 437: * .CSAX DEFINE IF SYSAX IS TO BE CALLED ! 438: * .CSN6 DEFINE TO PAD STMT NOS TO 6 CHARS ! 439: * .CSN8 DEFINE TO PAD STMT NOS TO 8 CHARS ! 440: * .CUCF DEFINE TO INCLUDE CFP$U ! 441: * .CULC DEFINE TO INCLUDE &CASE (LC NAMES) ! 442: * .CUST DEFINE TO INCLUDE SET() CODE ! 443: TTL S P I T B O L -- PROCEDURES SECTION ! 444: * ! 445: * THIS SECTION STARTS WITH DESCRIPTIONS OF THE OPERATING ! 446: * SYSTEM DEPENDENT PROCEDURES WHICH ARE USED BY THE SPITBOL ! 447: * TRANSLATOR. ALL SUCH PROCEDURES HAVE FIVE LETTER NAMES ! 448: * BEGINNING WITH SYS. THEY ARE LISTED IN ALPHABETICAL ! 449: * ORDER. ! 450: * ALL PROCEDURES HAVE A SPECIFICATION CONSISTING OF A ! 451: * MODEL CALL, PRECEDED BY A POSSIBLY EMPTY LIST OF REGISTER ! 452: * CONTENTS GIVING PARAMETERS AVAILABLE TO THE PROCEDURE AND ! 453: * FOLLOWED BY A POSSIBLY EMPTY LIST OF REGISTER CONTENTS ! 454: * REQUIRED ON RETURN FROM THE CALL OR WHICH MAY HAVE HAD ! 455: * THEIR CONTENTS DESTROYED. ONLY THOSE REGISTERS EXPLICITLY ! 456: * MENTIONED IN THE LIST AFTER THE CALL MAY HAVE THEIR ! 457: * VALUES CHANGED. ! 458: * THE SEGMENT OF CODE PROVIDING THE EXTERNAL PROCEDURES IS ! 459: * CONVENIENTLY REFERRED TO AS OSINT (OPERATING SYSTEM ! 460: * INTERFACE). THE SYSXX PROCEDURES IT CONTAINS PROVIDE ! 461: * FACILITIES NOT USUALLY AVAILABLE AS PRIMITIVES IN ! 462: * ASSEMBLY LANGUAGES. FOR PARTICULAR TARGET MACHINES, ! 463: * IMPLEMENTORS MAY CHOOSE FOR SOME MINIMAL OPCODES WHICH ! 464: * DO NOT HAVE REASONABLY DIRECT TRANSLATIONS, TO USE CALLS ! 465: * OF ADDITIONAL PROCEDURES WHICH THEY PROVIDE IN OSINT. ! 466: * E.G. MWB OR TRC MIGHT BE TRANSLATED AS JSR SYSMB, ! 467: * JSR SYSTC IN SOME IMPLEMENTATIONS. ! 468: * ! 469: * IN THE DESCRIPTIONS, REFERENCE IS MADE TO --BLK ! 470: * FORMATS (-- = A PAIR OF LETTERS). SEE THE SPITBOL ! 471: * DEFINITIONS SECTION FOR DETAILED DESCRIPTIONS OF ALL ! 472: * SUCH BLOCK FORMATS EXCEPT FCBLK FOR WHICH SYSFC SHOULD ! 473: * BE CONSULTED. ! 474: * ! 475: * SECTION 0 CONTAINS INP,INR SPECIFICATIONS OF INTERNAL ! 476: * PROCEDURES,ROUTINES. THIS GIVES A SINGLE PASS TRANSLATOR ! 477: * INFORMATION MAKING IT EASY TO GENERATE ALTERNATIVE CALLS ! 478: * IN THE TRANSLATION OF JSR-S FOR PROCEDURES OF DIFFERENT ! 479: * TYPES IF THIS PROVES NECESSARY. ! 480: * ! 481: SEC START OF PROCEDURES SECTION ! 482: EJC ! 483: * ! 484: * SYSAX -- AFTER EXECUTION ! 485: * ! 486: SYSAX EXP DEFINE EXTERNAL ENTRY POINT ! 487: * ! 488: * IF THE CONDITIONAL ASSEMBLY SYMBOL .CSAX IS DEFINED, ! 489: * THIS ROUTINE IS CALLED IMMEDIATELY AFTER EXECUTION AND ! 490: * BEFORE PRINTING OF EXECUTION STATISTICS OR DUMP OUTPUT. ! 491: * PURPOSE OF CALL IS FOR IMPLEMENTOR TO DETERMINE AND ! 492: * IF THE CALL IS NOT REQUIRED IT WILL BE OMITTED IF .CSAX ! 493: * IS UNDEFINED. IN THIS CASE SYSAX NEED NOT BE CODED. ! 494: * ! 495: * JSR SYSAX CALL AFTER EXECUTION ! 496: EJC ! 497: * ! 498: * SYSBX -- BEFORE EXECUTION ! 499: * ! 500: SYSBX EXP DEFINE EXTERNAL ENTRY POINT ! 501: * ! 502: * CALLED AFTER INITIAL SPITBOL COMPILATION AND BEFORE ! 503: * COMMENCING EXECUTION IN CASE OSINT NEEDS ! 504: * TO ASSIGN FILES OR PERFORM OTHER NECESSARY SERVICES. ! 505: * OSINT MAY ALSO CHOOSE TO SEND A MESSAGE TO ONLINE ! 506: * TERMINAL (IF ANY) INDICATING THAT EXECUTION IS STARTING. ! 507: * ! 508: * JSR SYSBX CALL BEFORE EXECUTION STARTS ! 509: EJC ! 510: * ! 511: * SYSDC -- DATE CHECK ! 512: * ! 513: SYSDC EXP DEFINE EXTERNAL ENTRY POINT ! 514: * ! 515: * SYSDC IS CALLED TO CHECK THAT THE EXPIRY DATE FOR A TRIAL ! 516: * VERSION OF SPITBOL IS UNEXPIRED. ! 517: * ! 518: * JSR SYSDC CALL TO CHECK DATE ! 519: * RETURN ONLY IF DATE IS OK ! 520: EJC ! 521: * ! 522: * SYSDM -- DUMP CORE ! 523: * ! 524: SYSDM EXP DEFINE EXTERNAL ENTRY POINT ! 525: * ! 526: * SYSDM IS CALLED BY A SPITBOL PROGRAM CALL OF DUMP(N) WITH ! 527: * N GE 3. ITS PURPOSE IS TO PROVIDE A CORE DUMP. ! 528: * N COULD HOLD AN ENCODING OF THE START ADRS FOR DUMP AND ! 529: * AMOUNT TO BE DUMPED E.G. N = 256*A + S , S = START ADRS ! 530: * IN KILOWORDS, A = KILOWORDS TO DUMP ! 531: * ! 532: * (XR) PARAMETER N OF CALL DUMP(N) ! 533: * JSR SYSDM CALL TO ENTER ROUTINE ! 534: EJC ! 535: * ! 536: * SYSDT -- GET CURRENT DATE ! 537: * ! 538: SYSDT EXP DEFINE EXTERNAL ENTRY POINT ! 539: * ! 540: * SYSDT IS USED TO OBTAIN THE CURRENT DATE. THE DATE IS ! 541: * RETURNED AS A CHARACTER STRING IN ANY FORMAT APPROPRIATE ! 542: * TO THE OPERATING SYSTEM IN USE. IT MAY ALSO CONTAIN THE ! 543: * CURRENT TIME OF DAY. SYSDT IS USED TO IMPLEMENT THE ! 544: * SNOBOL4 FUNCTION DATE. ! 545: * ! 546: * JSR SYSDT CALL TO GET DATE ! 547: * (XL) POINTER TO BLOCK CONTAINING DATE ! 548: * ! 549: * THE FORMAT OF THE BLOCK IS LIKE AN SCBLK EXCEPT THAT ! 550: * THE FIRST WORD NEED NOT BE SET. THE RESULT IS COPIED ! 551: * INTO SPITBOL DYNAMIC MEMORY ON RETURN. ! 552: EJC ! 553: * ! 554: * SYSEF -- EJECT FILE ! 555: * ! 556: SYSEF EXP DEFINE EXTERNAL ENTRY POINT ! 557: * ! 558: * SYSEF IS USED TO WRITE A PAGE EJECT TO A NAMED FILE. IT ! 559: * MAY ONLY BE USED FOR FILES WHERE THIS CONCEPT MAKES ! 560: * SENSE. NOTE THAT SYSEF IS NOT NORMALLY USED FOR THE ! 561: * STANDARD OUTPUT FILE (SEE SYSEP). ! 562: * ! 563: * (WA) PTR TO FCBLK OR ZERO ! 564: * (XR) EJECT ARGUMENT (SCBLK PTR) ! 565: * JSR SYSEF CALL TO EJECT FILE ! 566: * PPM LOC RETURN HERE IF FILE DOES NOT EXIST ! 567: * PPM LOC RETURN HERE IF INAPPROPRIATE FILE ! 568: * PPM LOC RETURN HERE IF I/O ERROR ! 569: EJC ! 570: * ! 571: * SYSEJ -- END OF JOB ! 572: * ! 573: SYSEJ EXP DEFINE EXTERNAL ENTRY POINT ! 574: * ! 575: * SYSEJ IS CALLED ONCE AT THE END OF EXECUTION TO ! 576: * TERMINATE THE RUN. THE SIGNIFICANCE OF THE ABEND AND ! 577: * CODE VALUES IS SYSTEM DEPENDENT. IN GENERAL, THE CODE ! 578: * VALUE SHOULD BE MADE AVAILABLE FOR TESTING, AND THE ! 579: * ABEND VALUE SHOULD CAUSE SOME POST-MORTEM ACTION SUCH AS ! 580: * A DUMP. NOTE THAT SYSEJ DOES NOT RETURN TO ITS CALLER. ! 581: * SEE SYSXI FOR DETAILS OF FCBLK CHAIN ! 582: * ! 583: * (WA) VALUE OF ABEND KEYWORD ! 584: * (WB) VALUE OF CODE KEYWORD ! 585: * (XL) O OR PTR TO HEAD OF FCBLK CHAIN ! 586: * JSR SYSEJ CALL TO END JOB ! 587: * ! 588: * THE FOLLOWING SPECIAL VALUES ARE USED AS CODES IN (WB) ! 589: * 999 EXECUTION SUPPRESSED ! 590: * 998 STANDARD OUTPUT FILE FULL OR UNAVAILABLE IN A SYSXI ! 591: * LOAD MODULE. IN THESE CASES (WA) CONTAINS THE NUMBER ! 592: * OF THE STATEMENT CAUSING PREMATURE TERMINATION. ! 593: EJC ! 594: * ! 595: * SYSEM -- GET ERROR MESSAGE TEXT ! 596: * ! 597: SYSEM EXP DEFINE EXTERNAL ENTRY POINT ! 598: * ! 599: * SYSEM IS USED TO OBTAIN THE TEXT OF ERR, ERB CALLS IN THE ! 600: * SOURCE PROGRAM GIVEN THE ERROR CODE NUMBER. IT IS ALLOWED ! 601: * TO RETURN A NULL STRING IF THIS FACILITY IS UNAVAILABLE. ! 602: * ! 603: * (WA) ERROR CODE NUMBER ! 604: * JSR SYSEM CALL TO GET TEXT ! 605: * (XR) TEXT OF MESSAGE ! 606: * ! 607: * THE RETURNED VALUE IS A POINTER TO A BLOCK IN SCBLK ! 608: * FORMAT EXCEPT THAT THE FIRST WORD NEED NOT BE SET. THE ! 609: * STRING IS COPIED INTO DYNAMIC MEMORY ON RETURN. ! 610: * IF THE NULL STRING IS RETURNED EITHER BECAUSE SYSEM DOES ! 611: * NOT PROVIDE ERROR MESSAGE TEXTS OR BECAUSE WA IS OUT OF ! 612: * RANGE, SPITBOL WILL PRINT THE STRING STORED IN ERRTEXT ! 613: * KEYWORD. ! 614: EJC ! 615: * ! 616: * SYSEN -- ENDFILE ! 617: * ! 618: SYSEN EXP DEFINE EXTERNAL ENTRY POINT ! 619: * ! 620: * SYSEN IS USED TO IMPLEMENT THE SNOBOL4 FUNCTION ENDFILE. ! 621: * THE MEANING IS SYSTEM DEPENDENT. IN GENERAL, ENDFILE ! 622: * IMPLIES THAT NO FURTHER I/O OPERATIONS WILL BE PERFORMED, ! 623: * BUT DOES NOT GUARANTEE THIS TO BE THE CASE. THE FILE ! 624: * SHOULD BE CLOSED AFTER THE CALL, A SUBSEQUENT READ ! 625: * OR WRITE MAY REOPEN THE FILE AT THE START OR IT MAY BE ! 626: * NECESSARY TO REOPEN THE FILE VIA SYSIO. ! 627: * ! 628: * (WA) PTR TO FCBLK OR ZERO ! 629: * (XR) ENDFILE ARGUMENT (SCBLK PTR) ! 630: * JSR SYSEN CALL TO ENDFILE ! 631: * PPM LOC RETURN HERE IF FILE DOES NOT EXIST ! 632: * PPM LOC RETURN HERE IF ENDFILE NOT ALLOWED ! 633: * PPM LOC RETURN HERE IF I/O ERROR ! 634: * (WA,WB) DESTROYED ! 635: * ! 636: * THE SECOND ERROR RETURN IS USED FOR FILES FOR WHICH ! 637: * ENDFILE IS NOT PERMITTED. FOR EXAMPLE, IT MAY BE EXPECTED ! 638: * THAT THE STANDARD INPUT AND OUTPUT FILES ARE IN THIS ! 639: * CATEGORY. ! 640: EJC ! 641: * ! 642: * SYSEP -- EJECT PRINTER PAGE ! 643: * ! 644: SYSEP EXP DEFINE EXTERNAL ENTRY POINT ! 645: * ! 646: * SYSEP IS CALLED TO PERFORM A PAGE EJECT ON THE STANDARD ! 647: * PRINTER OUTPUT FILE (CORRESPONDING TO SYSPR OUTPUT). ! 648: * ! 649: * JSR SYSEP CALL TO EJECT PRINTER OUTPUT ! 650: EJC ! 651: * ! 652: * SYSEX -- CALL EXTERNAL FUNCTION ! 653: * ! 654: SYSEX EXP DEFINE EXTERNAL ENTRY POINT ! 655: * ! 656: * SYSEX IS CALLED TO PASS CONTROL TO AN EXTERNAL FUNCTION ! 657: * PREVIOUSLY LOADED WITH A CALL TO SYSLD. ! 658: * ! 659: * (XS) POINTER TO ARGUMENTS ON STACK ! 660: * (XL) POINTER TO CONTROL BLOCK (EFBLK) ! 661: * (WA) NUMBER OF ARGUMENTS ON STACK ! 662: * JSR SYSEX CALL TO PASS CONTROL TO FUNCTION ! 663: * PPM LOC RETURN HERE IF FUNCTION CALL FAILS ! 664: * (XS) POPPED PAST ARGUMENTS ! 665: * (XR) RESULT RETURNED ! 666: * ! 667: * THE ARGUMENTS ARE STORED ON THE STACK WITH ! 668: * THE LAST ARGUMENT AT 0(XS). ON RETURN, XS ! 669: * IS POPPED PAST THE ARGUMENTS. ! 670: * ! 671: * THE FORM OF THE ARGUMENTS AS PASSED IS THAT USED IN THE ! 672: * SPITBOL TRANSLATOR (SEE DEFINITIONS AND DATA STRUCTURES ! 673: * SECTION). THE CONTROL BLOCK FORMAT IS ALSO DESCRIBED ! 674: * (UNDER EFBLK) IN THIS SECTION. ! 675: * ! 676: * THERE ARE TWO WAYS OF RETURNING A RESULT. ! 677: * ! 678: * 1) RETURN A POINTER TO A BLOCK IN DYNAMIC STORAGE. THIS ! 679: * BLOCK MUST BE IN EXACTLY CORRECT FORMAT, INCLUDING ! 680: * THE FIRST WORD. ONLY FUNCTIONS WRITTEN WITH INTIMATE ! 681: * KNOWLEDGE OF THE SYSTEM WILL RETURN IN THIS WAY. ! 682: * ! 683: * 2) STRING, INTEGER AND REAL RESULTS MAY BE RETURNED BY ! 684: * POINTING TO A PSEUDO-BLOCK OUTSIDE DYNAMIC MEMORY. ! 685: * THIS BLOCK IS IN ICBLK, RCBLK OR SCBLK FORMAT EXCEPT ! 686: * THAT THE FIRST WORD WILL BE OVERWRITTEN ! 687: * BY A TYPE WORD ON RETURN AND SO NEED NOT ! 688: * BE CORRECTLY SET. SUCH A RESULT IS ! 689: * COPIED INTO MAIN STORAGE BEFORE PROCEEDING. ! 690: * UNCONVERTED RESULTS MAY SIMILARLY BE RETURNED IN A ! 691: * PSEUDO-BLOCK WHICH IS IN CORRECT FORMAT INCLUDING ! 692: * TYPE WORD RECOGNISABLE BY GARBAGE COLLECTOR SINCE ! 693: * BLOCK IS COPIED INTO DYNAMIC MEMORY. ! 694: EJC ! 695: * ! 696: * SYSFC -- FILE CONTROL BLOCK ROUTINE ! 697: * ! 698: SYSFC EXP DEFINE EXTERNAL ENTRY POINT ! 699: * ! 700: * SEE ALSO SYSIO ! 701: * INPUT AND OUTPUT HAVE 3 ARGUMENTS REFERRED TO AS SHOWN ! 702: * INPUT(VARIABLE NAME,FILE ARG1,FILE ARG2) ! 703: * OUTPUT(VARIABLE NAME,FILE ARG1,FILE ARG2) ! 704: * FILE ARG1 MAY BE AN INTEGER OR STRING USED TO IDENTIFY ! 705: * AN I/O CHANNEL. IT IS CONVERTED TO A STRING FOR CHECKING. ! 706: * THE EXACT SIGNIFICANCE OF FILE ARG2 ! 707: * IS NOT RIGOROUSLY PRESCRIBED BUT TO IMPROVE PORTABILITY, ! 708: * THE SCHEME DESCRIBED IN THE SPITBOL USER MANUAL ! 709: * SHOULD BE ADOPTED WHEN POSSIBLE. THE PREFERRED FORM IS ! 710: * A STRING $F$,R$R$,C$C$,I$I$,...,Z$Z$ WHERE ! 711: * $F$ IS AN OPTIONAL FILE NAME WHICH IS PLACED FIRST. ! 712: * REMAINING ITEMS MAY BE OMITTED OR INCLUDED IN ANY ORDER. ! 713: * $R$ IS MAXIMUM RECORD LENGTH ! 714: * $C$ IS A CARRIAGE CONTROL CHARACTER OR CHARACTER STRING ! 715: * $I$ IS SOME FORM OF CHANNEL IDENTIFICATION USED IN THE ! 716: * ABSENCE OF $F$ TO ASSOCIATE THE VARIABLE ! 717: * WITH A FILE ALLOCATED DYNAMICALLY BY JCL COMMANDS AT ! 718: * SPITBOL LOAD TIME. ! 719: * ,...,Z$Z$ ARE ADDITIONAL FIELDS. ! 720: * IF , (COMMA) CANNOT BE USED AS A DELIMITER, .CIOD ! 721: * SHOULD BE DEFINED TO INTRODUCE BY CONDITIONAL ASSEMBLY ! 722: * ANOTHER DELIMITER (SEE ! 723: * IODEL EQU * ! 724: * EARLY IN DEFINITIONS SECTION). ! 725: * SYSFC IS CALLED WHEN A VARIABLE IS INPUT OR OUTPUT ! 726: * ASSOCIATED TO CHECK FILE ARG1 AND FILE ARG2 AND ! 727: * TO REPORT WHETHER AN FCBLK (FILE CONTROL ! 728: * BLOCK) IS NECESSARY AND IF SO WHAT SIZE IT SHOULD BE. ! 729: * THIS MAKES IT POSSIBLE FOR SPITBOL RATHER THAN OSINT TO ! 730: * ALLOCATE SUCH A BLOCK IN DYNAMIC MEMORY IF REQUIRED ! 731: * OR ALTERNATIVELY IN STATIC MEMORY. ! 732: * THE SIGNIFICANCE OF AN FCBLK , IF ONE IS REQUESTED, IS ! 733: * ENTIRELY UP TO THE SYSTEM INTERFACE. THE ONLY RESTRICTION ! 734: * IS THAT IF THE FCBLK SHOULD APPEAR TO LIE IN DYNAMIC ! 735: * MEMORY , POINTERS TO IT SHOULD BE PROPER POINTERS TO ! 736: * THE START OF A RECOGNISABLE AND GARBAGE COLLECTABLE ! 737: * BLOCK (THIS CONDITION WILL BE MET IF SYSFC REQUESTS ! 738: * SPITBOL TO PROVIDE AN FCBLK). ! 739: * AN OPTION IS PROVIDED FOR OSINT TO RETURN A POINTER IN ! 740: * XL TO AN FCBLK WHICH IT PRIVATELY ALLOCATED. THIS PTR ! 741: * WILL BE MADE AVAILABLE WHEN I/O OCCURS LATER. ! 742: * PRIVATE FCBLKS MAY HAVE ARBITRARY CONTENTS AND SPITBOL ! 743: * STORES NOTHING IN THEM. ! 744: EJC ! 745: * THE REQUESTED SIZE FOR AN FCBLK IN DYNAMIC MEMORY ! 746: * SHOULD ALLOW A 2 WORD OVERHEAD FOR BLOCK TYPE AND ! 747: * LENGTH FIELDS. INFORMATION SUBSEQUENTLY STORED IN THE ! 748: * REMAINING WORDS MAY BE ARBITRARY IF AN XNBLK (EXTERNAL ! 749: * NON-RELOCATABLE BLOCK) IS REQUESTED. IF THE REQUEST IS ! 750: * FOR AN XRBLK (EXTERNAL RELOCATABLE BLOCK) THE ! 751: * CONTENTS OF WORDS SHOULD BE COLLECTABLE (I.E. ANY ! 752: * APPARENT POINTERS INTO DYNAMIC SHOULD BE GENUINE BLOCK ! 753: * POINTERS). THESE RESTRICTIONS DO NOT APPLY IF AN FCBLK ! 754: * IS ALLOCATED OUTSIDE DYNAMIC OR IS NOT ALLOCATED AT ALL. ! 755: * IF AN FCBLK IS REQUESTED, ITS FIELDS WILL BE INITIALISED ! 756: * TO ZERO BEFORE ENTRY TO SYSIO WITH THE EXCEPTION OF ! 757: * WORDS 0 AND 1 IN WHICH THE BLOCK TYPE AND LENGTH ! 758: * FIELDS ARE PLACED FOR FCBLKS IN DYNAMIC MEMORY ONLY. ! 759: * FOR THE POSSIBLE USE OF SYSEJ AND SYSXI, IF FCBLKS ! 760: * ARE USED, A CHAIN IS BUILT SO THAT THEY MAY ALL BE ! 761: * FOUND - SEE SYSXI FOR DETAILS. ! 762: * IF BOTH FILE ARG1 AND FILE ARG2 ARE NULL, CALLS OF SYSFC ! 763: * AND SYSIO ARE OMITTED. ! 764: * IF FILE ARG1 IS NULL (STANDARD INPUT/OUTPUT FILE), SYSFC ! 765: * IS CALLED TO CHECK NON-NULL FILE ARG2 BUT ANY REQUEST ! 766: * FOR AN FCBLK WILL BE IGNORED, SINCE SPITBOL HANDLES THE ! 767: * STANDARD FILES SPECIALLY AND CANNOT READILY KEEP FCBLK ! 768: * POINTERS FOR THEM. ! 769: * FILEARG1 IS TYPE CHECKED BY SPITBOL SO FURTHER CHECKING ! 770: * MAY BE UNNECCESSARY IN MANY IMPLEMENTATIONS. ! 771: * FILE ARG2 IS PASSED SO THAT SYSFC MAY ANALYSE AND ! 772: * CHECK IT. HOWEVER TO ASSIST IN THIS, SPITBOL ALSO PASSES ! 773: * ON THE STACK THE COMPONENTS OF THIS ARGUMENT WITH ! 774: * FILE NAME, $F$ (OTHERWISE NULL) EXTRACTED AND STACKED ! 775: * FIRST. ! 776: * THE OTHER FIELDS, IF ANY, ARE EXTRACTED AS SUBSTRINGS, ! 777: * POINTERS TO THEM ARE STACKED AND A COUNT OF ALL ITEMS ! 778: * STACKED IS PLACED IN WC. IF AN FCBLK WAS EARLIER ! 779: * ALLOCATED AND POINTED TO VIA FILE ARG1, SYSFC IS ALSO ! 780: * PASSED A POINTER TO THIS FCBLK. ! 781: * ! 782: * (XL) FILE ARG1 SCBLK PTR (2ND ARG) ! 783: * (XR) FILEARG2 (3RD ARG) OR NULL ! 784: * -(XS)...-(XS) SCBLKS FOR $F$,$R$,$C$,... ! 785: * (WC) NO. OF STACKED SCBLKS ABOVE ! 786: * (WA) EXISTING FILE ARG1 FCBLK PTR OR 0 ! 787: * (WB) 0/3 FOR INPUT/OUTPUT ASSOCN ! 788: * JSR SYSFC CALL TO CHECK NEED FOR FCBLK ! 789: * PPM LOC INVALID FILE ARGUMENT ! 790: * (XS) POPPED (WC) TIMES ! 791: * (WA NON ZERO) BYTE SIZE OF REQUESTED FCBLK ! 792: * (WA=0,XL NON ZERO) PRIVATE FCBLK PTR IN XL ! 793: * (WA=XL=0) NO FCBLK WANTED, NO PRIVATE FCBLK ! 794: * (WC) 0/1/2 REQUEST ALLOC OF XRBLK/XNBLK ! 795: * /STATIC BLOCK FOR USE AS FCBLK ! 796: * (WB) DESTROYED ! 797: EJC ! 798: * ! 799: * SYSHS -- GIVE ACCESS TO HOST COMPUTER FEATURES ! 800: * ! 801: SYSHS EXP DEFINE EXTERNAL ENTRY POINT ! 802: * ! 803: * PROVIDES MEANS FOR IMPLEMENTING SPECIAL FEATURES ! 804: * ON DIFFERENT HOST COMPUTERS. THE ONLY DEFINED ENTRY IS ! 805: * THAT WHERE ALL ARGUMENTS ARE NULL IN WHICH CASE SYSHS ! 806: * RETURNS AN SCBLK CONTAINING NAME OF COMPUTER, ! 807: * NAME OF OPERATING SYSTEM AND NAME OF SITE SEPARATED BY ! 808: * COLONS. THE SCBLK NEED NOT HAVE A CORRECT FIRST FIELD ! 809: * AS THIS IS SUPPLIED ON COPYING STRING TO DYNAMIC MEMORY. ! 810: * SPITBOL DOES NO ARGUMENT CHECKING BUT DOES PROVIDE A ! 811: * SINGLE ERROR RETURN FOR ARGUMENTS CHECKED AS ERRONEOUS ! 812: * BY OSINT. IT ALSO PROVIDES A SINGLE EXECUTION ERROR ! 813: * RETURN. IF THESE ARE INADEQUATE, USE MAY BE MADE OF THE ! 814: * MINIMAL ERROR SECTION DIRECT AS DESCRIBED IN MINIMAL ! 815: * DOCUMENTATION, SECTION 10. ! 816: * SEVERAL NON-ERROR RETURNS ARE PROVIDED. THE FIRST ! 817: * CORRESPONDS TO THE DEFINED ENTRY OR, FOR IMPLEMENTATION ! 818: * DEFINED ENTRIES, ANY STRING MAY BE RETURNED. THE OTHERS ! 819: * PERMIT RESPECTIVELY, RETURN A NULL RESULT, RETURN WITH A ! 820: * RESULT TO BE STACKED WHICH IS POINTED AT BY XR, AND A ! 821: * RETURN CAUSING SPITBOL STATEMENT FAILURE. IF A RETURNED ! 822: * RESULT IS IN DYNAMIC MEMORY IT MUST OBEY GARBAGE ! 823: * COLLECTOR RULES. THE ONLY RESULTS COPIED ON RETURN ! 824: * ARE STRINGS RETURNED VIA PPM LOC3 RETURN. ! 825: * ! 826: * (WA) ARGUMENT 1 ! 827: * (XL) ARGUMENT 2 ! 828: * (XR) ARGUMENT 3 ! 829: * JSR SYSHS CALL TO GET HOST INFORMATION ! 830: * PPM LOC1 ERRONEOUS ARG ! 831: * PPM LOC2 EXECUTION ERROR ! 832: * PPM LOC3 SCBLK PTR IN XL OR 0 IF UNAVAILABLE ! 833: * PPM LOC4 RETURN A NULL RESULT ! 834: * PPM LOC5 RETURN RESULT IN XR ! 835: * PPM LOC6 CAUSE STATEMENT FAILURE ! 836: EJC ! 837: * ! 838: * SYSID -- RETURN SYSTEM IDENTIFICATION ! 839: * ! 840: SYSID EXP DEFINE EXTERNAL ENTRY POINT ! 841: * ! 842: * THIS ROUTINE SHOULD RETURN STRINGS TO HEAD THE STANDARD ! 843: * PRINTER OUTPUT. THE FIRST STRING WILL BE APPENDED TO ! 844: * A HEADING LINE OF THE FORM ! 845: * MACRO SPITBOL VERSION V.V ! 846: * SUPPLIED BY SPITBOL ITSELF. V.V ARE DIGITS GIVING THE ! 847: * MAJOR VERSION NUMBER AND GENERALLY AT LEAST A MINOR ! 848: * VERSION NUMBER RELATING TO OSINT SHOULD BE SUPPLIED TO ! 849: * GIVE SAY ! 850: * MACRO SPITBOL VERSION V.V(M.M) ! 851: * THE SECOND STRING SHOULD IDENTIFY AT LEAST THE MACHINE ! 852: * AND OPERATING SYSTEM. PREFERABLY IT SHOULD INCLUDE ! 853: * THE DATE AND TIME OF THE RUN. ! 854: * OPTIONALLY THE STRINGS MAY INCLUDE SITE NAME OF THE ! 855: * THE IMPLEMENTOR AND/OR MACHINE ON WHICH RUN TAKES PLACE, ! 856: * UNIQUE SITE OR COPY NUMBER AND OTHER INFORMATION AS ! 857: * APPROPRIATE WITHOUT MAKING IT SO LONG AS TO BE A ! 858: * NUISANCE TO USERS. ! 859: * THE FIRST WORDS OF THE SCBLKS POINTED AT NEED NOT BE ! 860: * CORRECTLY SET. ! 861: * ! 862: * JSR SYSID CALL FOR SYSTEM IDENTIFICATION ! 863: * (XR) SCBLK PTR FOR ADDITION TO HEADER ! 864: * (XL) PTR TO SECOND HEADER SCBLK ! 865: EJC ! 866: * ! 867: * SYSIL -- GET INPUT RECORD LENGTH ! 868: * ! 869: SYSIL EXP DEFINE EXTERNAL ENTRY POINT ! 870: * ! 871: * SYSIL IS USED TO GET THE LENGTH OF THE NEXT INPUT RECORD ! 872: * FROM A FILE PREVIOUSLY INPUT ASSOCIATED WITH A SYSIO ! 873: * CALL. THE LENGTH RETURNED IS USED TO ESTABLISH A BUFFER ! 874: * FOR A SUBSEQUENT SYSIN CALL. ! 875: * ! 876: * (WA) PTR TO FCBLK OR ZERO ! 877: * JSR SYSIL CALL TO GET RECORD LENGTH ! 878: * (WA) LENGTH OR ZERO IF FILE CLOSED ! 879: * ! 880: * NO HARM IS DONE IF THE VALUE RETURNED IS TOO LONG SINCE ! 881: * UNUSED SPACE WILL BE RECLAIMED AFTER THE SYSIN CALL. ! 882: * ! 883: * NOTE THAT IT IS THE SYSIL CALL (NOT THE SYSIO CALL) WHICH ! 884: * CAUSES THE FILE TO BE OPENED AS REQUIRED FOR THE FIRST ! 885: * RECORD INPUT FROM THE FILE. ! 886: EJC ! 887: * ! 888: * SYSIN -- READ INPUT RECORD ! 889: * ! 890: SYSIN EXP DEFINE EXTERNAL ENTRY POINT ! 891: * ! 892: * SYSIN IS USED TO READ A RECORD FROM THE FILE WHICH WAS ! 893: * REFERENCED IN A PRIOR CALL TO SYSIL (I.E. THESE CALLS ! 894: * ALWAYS OCCUR IN PAIRS). THE BUFFER PROVIDED IS AN ! 895: * SCBLK FOR A STRING OF LENGTH SET FROM THE SYSIL CALL. ! 896: * IF THE ACTUAL LENGTH READ IS LESS THAN THIS, THE LENGTH ! 897: * FIELD OF THE SCBLK MUST BE MODIFIED BEFORE RETURNING ! 898: * UNLESS BUFFER IS RIGHT PADDED WITH ZEROES. ! 899: * IT IS ALSO PERMISSIBLE TO TAKE ANY OF THE ALTERNATIVE ! 900: * RETURNS AFTER SCBLK LENGTH HAS BEEN MODIFIED. ! 901: * ! 902: * (WA) PTR TO FCBLK OR ZERO ! 903: * (XR) POINTER TO BUFFER (SCBLK PTR) ! 904: * JSR SYSIN CALL TO READ RECORD ! 905: * PPM LOC ENDFILE OR NO I/P FILE AFTER SYSXI ! 906: * PPM LOC RETURN HERE IF I/O ERROR ! 907: * PPM LOC RETURN HERE IF RECORD FORMAT ERROR ! 908: * (WA,WB,WC) DESTROYED ! 909: EJC ! 910: * ! 911: * SYSIO -- INPUT/OUTPUT FILE ASSOCIATION ! 912: * ! 913: SYSIO EXP DEFINE EXTERNAL ENTRY POINT ! 914: * ! 915: * SEE ALSO SYSFC. ! 916: * SYSIO IS CALLED IN RESPONSE TO A SNOBOL4 INPUT OR OUTPUT ! 917: * FUNCTION CALL EXCEPT WHEN FILE ARG1 AND FILE ARG2 ! 918: * ARE BOTH NULL. ! 919: * ITS CALL ALWAYS FOLLOWS IMMEDIATELY AFTER A CALL ! 920: * OF SYSFC. IF SYSFC REQUESTED ALLOCATION ! 921: * OF AN FCBLK, ITS ADDRESS WILL BE IN WA. ! 922: * FOR INPUT FILES, NON-ZERO VALUES OF $R$ SHOULD BE ! 923: * COPIED TO WC FOR USE IN ALLOCATING INPUT BUFFERS. IF $R$ ! 924: * IS DEFAULTED OR NOT IMPLEMENTED, WC SHOULD BE ZEROISED. ! 925: * ONCE A FILE HAS BEEN OPENED, SUBSEQUENT INPUT(),OUTPUT() ! 926: * CALLS IN WHICH THE SECOND ARGUMENT IS IDENTICAL WITH THAT ! 927: * IN A PREVIOUS CALL, MERELY ASSOCIATE THE ADDITIONAL ! 928: * VARIABLE NAME (FIRST ARGUMENT) TO THE FILE AND DO NOT ! 929: * RESULT IN RE-OPENING THE FILE. ! 930: * IN SUBSEQUENT ASSOCIATED ACCESSES TO THE FILE A POINTER ! 931: * TO ANY FCBLK ALLOCATED WILL BE MADE AVAILABLE. ! 932: * ! 933: * (XL) FILE ARG1 SCBLK PTR (2ND ARG) ! 934: * (XR) FILE ARG2 SCBLK PTR (3RD ARG) ! 935: * (WA) FCBLK PTR (0 IF NONE) ! 936: * (WB) 0 FOR INPUT, 3 FOR OUTPUT ! 937: * JSR SYSIO CALL TO ASSOCIATE FILE ! 938: * PPM LOC RETURN HERE IF FILE DOES NOT EXIST ! 939: * PPM LOC RETURN IF INPUT/OUTPUT NOT ALLOWED ! 940: * (XL) FCBLK POINTER (0 IF NONE) ! 941: * (WC) 0 (FOR DEFAULT) OR MAX RECORD LNGTH ! 942: * (WA,WB) DESTROYED ! 943: * ! 944: * THE SECOND ERROR RETURN IS USED IF THE FILE NAMED EXISTS ! 945: * BUT INPUT/OUTPUT FROM THE FILE IS NOT ALLOWED. FOR ! 946: * EXAMPLE, THE STANDARD OUTPUT FILE MAY BE IN THIS CATEGORY ! 947: * AS REGARDS INPUT ASSOCIATION. ! 948: EJC ! 949: * ! 950: * SYSLD -- LOAD EXTERNAL FUNCTION ! 951: * ! 952: SYSLD EXP DEFINE EXTERNAL ENTRY POINT ! 953: * ! 954: * SYSLD IS CALLED IN RESPONSE TO THE USE OF THE SNOBOL4 ! 955: * LOAD FUNCTION. THE NAMED FUNCTION IS LOADED (WHATEVER ! 956: * THIS MEANS), AND A POINTER IS RETURNED. THE POINTER WILL ! 957: * BE USED ON SUBSEQUENT CALLS TO THE FUNCTION (SEE SYSEX). ! 958: * ! 959: * (XR) POINTER TO FUNCTION NAME (SCBLK) ! 960: * (XL) POINTER TO LIBRARY NAME (SCBLK) ! 961: * JSR SYSLD CALL TO LOAD FUNCTION ! 962: * PPM LOC RETURN HERE IF FUNC DOES NOT EXIST ! 963: * PPM LOC RETURN HERE IF I/O ERROR ! 964: * (XR) POINTER TO LOADED CODE ! 965: * ! 966: * THE SIGNIFICANCE OF THE POINTER RETURNED IS UP TO THE ! 967: * SYSTEM INTERFACE ROUTINE. THE ONLY RESTRICTION IS THAT ! 968: * IF THE POINTER IS WITHIN DYNAMIC STORAGE, IT MUST BE ! 969: * A PROPER BLOCK POINTER. ! 970: EJC ! 971: * ! 972: * SYSMM -- GET MORE MEMORY ! 973: * ! 974: SYSMM EXP DEFINE EXTERNAL ENTRY POINT ! 975: * ! 976: * SYSMM IS CALLED IN AN ATTEMPT TO ALLOCATE MORE DYNAMIC ! 977: * MEMORY. THIS MEMORY MUST BE ALLOCATED CONTIGUOUSLY WITH ! 978: * THE CURRENT DYNAMIC DATA AREA. ! 979: * ! 980: * THE AMOUNT ALLOCATED IS UP TO THE SYSTEM TO DECIDE. ANY ! 981: * VALUE IS ACCEPTABLE INCLUDING ZERO IF ALLOCATION IS ! 982: * IMPOSSIBLE. ! 983: * ! 984: * JSR SYSMM CALL TO GET MORE MEMORY ! 985: * (XR) NUMBER OF ADDITIONAL WORDS OBTAINED ! 986: EJC ! 987: * ! 988: * SYSMX -- SUPPLY MXLEN ! 989: * ! 990: SYSMX EXP DEFINE EXTERNAL ENTRY POINT ! 991: * ! 992: * BECAUSE OF THE METHOD OF GARBAGE COLLECTION, NO SPITBOL ! 993: * OBJECT IS ALLOWED TO OCCUPY MORE BYTES OF MEMORY THAN ! 994: * THE INTEGER GIVING THE LOWEST ADDRESS OF DYNAMIC ! 995: * (GARBAGE COLLECTABLE) MEMORY. MXLEN IS THE NAME USED TO ! 996: * REFER TO THIS MAXIMUM LENGTH OF AN OBJECT AND FOR MOST ! 997: * USERS OF MOST IMPLEMENTATIONS, PROVIDED DYNAMIC MEMORY ! 998: * STARTS AT AN ADDRESS OF AT LEAST A FEW THOUSAND WORDS, ! 999: * THERE IS NO PROBLEM. ! 1000: * IF THE DEFAULT STARTING ADDRESS IS LESS THAN SAY 10000 OR ! 1001: * 20000, THEN A LOAD TIME OPTION SHOULD BE PROVIDED WHERE A ! 1002: * USER CAN REQUEST THAT HE BE ABLE TO CREATE LARGER ! 1003: * OBJECTS. THIS ROUTINE INFORMS SPITBOL OF THIS REQUEST IF ! 1004: * ANY. THE VALUE RETURNED IS EITHER AN INTEGER ! 1005: * REPRESENTING THE DESIRED VALUE OF MXLEN (AND HENCE THE ! 1006: * MINIMUM DYNAMIC STORE ADDRESS WHICH MAY RESULT IN ! 1007: * NON-USE OF SOME STORE) OR ZERO IF A DEFAULT IS ACCEPTABLE ! 1008: * IN WHICH MXLEN IS SET TO THE LOWEST ADDRESS ALLOCATED ! 1009: * TO DYNAMIC STORE BEFORE COMPILATION STARTS. ! 1010: * IF A NON-ZERO VALUE IS RETURNED, THIS IS USED FOR KEYWORD ! 1011: * MAXLNGTH. OTHERWISE THE INITIAL LOW ADDRESS OF DYNAMIC ! 1012: * MEMORY IS USED FOR THIS KEYWORD. ! 1013: * ! 1014: * JSR SYSMX CALL TO GET MXLEN ! 1015: * (WA) EITHER MXLEN OR 0 FOR DEFAULT ! 1016: EJC ! 1017: * ! 1018: * SYSOU -- OUTPUT RECORD ! 1019: * ! 1020: SYSOU EXP DEFINE EXTERNAL ENTRY POINT ! 1021: * ! 1022: * SYSOU IS USED TO WRITE A RECORD TO A FILE PREVIOUSLY ! 1023: * ASSOCIATED WITH A SYSIO CALL. ! 1024: * ! 1025: * (WA) PTR TO FCBLK OR ZERO ! 1026: * (XR) RECORD TO BE WRITTEN (SCBLK) ! 1027: * JSR SYSOU CALL TO OUTPUT RECORD ! 1028: * PPM LOC FILE FULL OR NO FILE AFTER SYSXI ! 1029: * PPM LOC RETURN HERE IF I/O ERROR ! 1030: * (WA,WB,WC) DESTROYED ! 1031: * ! 1032: * NOTE THAT IT IS THE SYSOU CALL (NOT THE SYSIO CALL) WHICH ! 1033: * CAUSES THE FILE TO BE OPENED AS REQUIRED FOR THE FIRST ! 1034: * RECORD OUTPUT TO THE FILE. ! 1035: EJC ! 1036: * ! 1037: * SYSPI -- PRINT ON INTERACTIVE CHANNEL ! 1038: * ! 1039: SYSPI EXP DEFINE EXTERNAL ENTRY POINT ! 1040: * ! 1041: * IF SPITBOL IS RUN FROM AN ONLINE TERMINAL, OSINT CAN ! 1042: * REQUEST THAT MESSAGES SUCH AS COPIES OF COMPILATION ! 1043: * ERRORS BE SENT TO THE TERMINAL (SEE SYSPP). IF RELEVANT ! 1044: * REPLY WAS MADE BY SYSPP THEN SYSPI IS CALLED TO SEND SUCH ! 1045: * MESSAGES TO THE INTERACTIVE CHANNEL. ! 1046: * SYSPI IS ALSO USED FOR SENDING OUTPUT TO THE TERMINAL ! 1047: * THROUGH THE SPECIAL VARIABLE NAME, TERMINAL. ! 1048: * ! 1049: * (XR) PTR TO LINE BUFFER (SCBLK) ! 1050: * (WA) LINE LENGTH ! 1051: * JSR SYSPI CALL TO PRINT LINE ! 1052: * PPM LOC FAILURE RETURN ! 1053: * (WA,WB) DESTROYED ! 1054: EJC ! 1055: * ! 1056: * SYSPP -- OBTAIN PRINT PARAMETERS ! 1057: * ! 1058: SYSPP EXP DEFINE EXTERNAL ENTRY POINT ! 1059: * ! 1060: * SYSPP IS CALLED ONCE DURING COMPILATION TO OBTAIN ! 1061: * PARAMETERS REQUIRED FOR CORRECT PRINTED OUTPUT FORMAT ! 1062: * AND TO SELECT OTHER OPTIONS. IT MAY ALSO BE CALLED AGAIN ! 1063: * AFTER SYSXI WHEN A LOAD MODULE IS RESUMED. IN THIS ! 1064: * CASE THE VALUE RETURNED IN WA MAY BE LESS THAN OR EQUAL ! 1065: * TO THAT RETURNED IN INITIAL CALL BUT MAY NOT BE ! 1066: * GREATER. ! 1067: * THE INFORMATION RETURNED IS - ! 1068: * 1. LINE LENGTH IN CHARS FOR STANDARD PRINT FILE ! 1069: * 2. NO OF LINES/PAGE. 0 IS PREFERABLE FOR A NON-PAGED ! 1070: * DEVICE (E.G. ONLINE TERMINAL) IN WHICH CASE LISTING ! 1071: * PAGE THROWS ARE SUPPRESSED AND PAGE HEADERS ! 1072: * RESULTING FROM -TITLE,-STITL LINES ARE KEPT SHORT. ! 1073: * 3. AN INITIAL -NOLIST OPTION TO SUPPRESS LISTING UNLESS ! 1074: * THE PROGRAM CONTAINS AN EXPLICIT -LIST. ! 1075: * 4. OPTIONS TO SUPPRESS LISTING OF COMPILATION AND/OR ! 1076: * EXECUTION STATS (USEFUL FOR ESTABLISHED PROGRAMS) - ! 1077: * COMBINED WITH 3. GIVES POSSIBILITY OF LISTING ! 1078: * FILE NEVER BEING OPENED. ! 1079: * 5. OPTION TO HAVE COPIES OF ERRORS SENT TO AN ! 1080: * INTERACTIVE CHANNEL IN ADDITION TO STANDARD PRINTER. ! 1081: * 6. OPTION TO KEEP PAGE HEADERS SHORT (E.G. IF LISTING ! 1082: * TO AN ONLINE TERMINAL). ! 1083: * 7. AN OPTION TO CHOOSE EXTENDED OR COMPACT LISTING ! 1084: * FORMAT. IN THE FORMER A PAGE EJECT AND IN THE LATTER ! 1085: * A FEW LINE FEEDS PRECEDE THE PRINTING OF EACH ! 1086: * OF-- LISTING, COMPILATION STATISTICS, EXECUTION ! 1087: * OUTPUT AND EXECUTION STATISTICS. ! 1088: * 8. AN OPTION TO SUPPRESS EXECUTION AS THOUGH A ! 1089: * -NOEXECUTE CARD WERE SUPPLIED. ! 1090: * 9. AN OPTION TO REQUEST THAT NAME /TERMINAL/ BE PRE- ! 1091: * ASSOCIATED TO AN ONLINE TERMINAL VIA SYSPI AND SYSRI ! 1092: * 10. AN INTERMEDIATE (STANDARD) LISTING OPTION REQUIRING ! 1093: * THAT PAGE EJECTS OCCUR IN SOURCE LISTINGS. REDUNDANT ! 1094: * IF EXTENDED OPTION CHOSEN BUT PARTIALLY EXTENDS ! 1095: * COMPACT OPTION. ! 1096: * 11. OPTION TO SUPPRESS SYSID IDENTIFICATION. ! 1097: * ! 1098: * JSR SYSPP CALL TO GET PRINT PARAMETERS ! 1099: * (WA) PRINT LINE LENGTH IN CHARS ! 1100: * (WB) NUMBER OF LINES/PAGE ! 1101: * (WC) BITS VALUE ...JIHGFEDCBA WHERE ! 1102: * A = 1 TO SEND ERROR COPY TO INT.CH. ! 1103: * B = 1 MEANS STD PRINTER IS INT. CH. ! 1104: * C = 1 FOR -NOLIST OPTION ! 1105: * D = 1 TO SUPPRESS COMPILN. STATS ! 1106: * E = 1 TO SUPPRESS EXECN. STATS ! 1107: * F = 1/0 FOR EXTNDED/COMPACT LISTING ! 1108: * G = 1 FOR -NOEXECUTE ! 1109: * H = 1 PRE-ASSOCIATE /TERMINAL/ ! 1110: * I = 1 FOR STANDARD LISTING OPTION. ! 1111: * J = 1 SUPPRESSES LISTING HEADER ! 1112: EJC ! 1113: * ! 1114: * SYSPR -- PRINT LINE ON STANDARD OUTPUT FILE ! 1115: * ! 1116: SYSPR EXP DEFINE EXTERNAL ENTRY POINT ! 1117: * ! 1118: * SYSPR IS USED TO PRINT A SINGLE LINE ON THE STANDARD ! 1119: * OUTPUT FILE. ! 1120: * ! 1121: * (XR) POINTER TO LINE BUFFER (SCBLK) ! 1122: * (WA) LINE LENGTH ! 1123: * JSR SYSPR CALL TO PRINT LINE ! 1124: * PPM LOC TOO MUCH O/P OR NO FILE AFTER SYSXI ! 1125: * (WA,WB) DESTROYED ! 1126: * ! 1127: * THE BUFFER POINTED TO IS THE LENGTH OBTAINED FROM THE ! 1128: * SYSPP CALL AND IS FILLED OUT WITH TRAILING BLANKS. THE ! 1129: * VALUE IN WA IS THE ACTUAL LINE LENGTH WHICH MAY BE LESS ! 1130: * THAN THE MAXIMUM LINE LENGTH POSSIBLE. THERE IS NO SPACE ! 1131: * CONTROL ASSOCIATED WITH THE LINE, ALL LINES ARE PRINTED ! 1132: * SINGLE SPACED. NOTE THAT NULL LINES (WA=0) ARE POSSIBLE ! 1133: * IN WHICH CASE A BLANK LINE IS TO BE PRINTED. ! 1134: * ! 1135: * THE ERROR EXIT IS USED FOR SYSTEMS WHICH LIMIT THE AMOUNT ! 1136: * OF PRINTED OUTPUT. IF POSSIBLE, PRINTING SHOULD BE ! 1137: * PERMITTED AFTER THIS CONDITION HAS BEEN SIGNALLED ONCE TO ! 1138: * ALLOW FOR DUMP AND OTHER DIAGNOSTIC INFORMATION. ! 1139: * ASSUMING THIS TO BE POSSIBLE, SPITBOL MAY MAKE MORE SYSPR ! 1140: * CALLS. IF THE ERROR RETURN OCCURS ANOTHER TIME, EXECUTION ! 1141: * IS TERMINATED BY A CALL OF SYSEJ WITH ENDING CODE 998. ! 1142: EJC ! 1143: * ! 1144: * SYSRD -- READ RECORD FROM STANDARD INPUT FILE ! 1145: * ! 1146: SYSRD EXP DEFINE EXTERNAL ENTRY POINT ! 1147: * ! 1148: * SYSRD IS USED TO READ A RECORD FROM THE STANDARD INPUT ! 1149: * FILE. THE BUFFER PROVIDED IS AN SCBLK FOR A STRING THE ! 1150: * LENGTH OF WHICH IN CHARACTERS IS GIVEN IN WC, THIS ! 1151: * CORRESPONDING TO THE MAXIMUM LENGTH OF STRING WHICH ! 1152: * SPITBOL IS PREPARED TO RECEIVE. AT COMPILE TIME IT ! 1153: * CORRESPONDS TO XXX IN THE MOST RECENT -INXXX CARD ! 1154: * (DEFAULT 72) AND AT EXECUTION TIME TO THE MOST RECENT ! 1155: * ,R$R$ (RECORD LENGTH) IN THE THIRD ARG OF AN INPUT() ! 1156: * STATEMENT FOR THE STANDARD INPUT FILE (DEFAULT 80). ! 1157: * IF FEWER THAN (WC) CHARACTERS ARE READ, THE LENGTH ! 1158: * FIELD OF THE SCBLK MUST BE ADJUSTED BEFORE RETURNING ! 1159: * UNLESS THE BUFFER IS RIGHT PADDED WITH ZEROES. ! 1160: * IT IS ALSO PERMISSIBLE TO TAKE THE ALTERNATIVE RETURN ! 1161: * AFTER SUCH AN ADJUSTMENT HAS BEEN MADE. ! 1162: * SPITBOL MAY CONTINUE TO MAKE CALLS AFTER AN ENDFILE ! 1163: * RETURN SO THIS ROUTINE SHOULD BE PREPARED TO MAKE ! 1164: * REPEATED ENDFILE RETURNS. ! 1165: * ! 1166: * (XR) POINTER TO BUFFER (SCBLK PTR) ! 1167: * (WC) LENGTH OF BUFFER IN CHARACTERS ! 1168: * JSR SYSRD CALL TO READ LINE ! 1169: * PPM LOC ENDFILE OR NO I/P FILE AFTER SYSXI ! 1170: * (WA,WB,WC) DESTROYED ! 1171: EJC ! 1172: * ! 1173: * SYSRI -- READ RECORD FROM INTERACTIVE CHANNEL ! 1174: * ! 1175: SYSRI EXP DEFINE EXTERNAL ENTRY POINT ! 1176: * ! 1177: * READS A RECORD FROM ONLINE TERMINAL FOR SPITBOL VARIABLE, ! 1178: * TERMINAL. IF ONLINE TERMINAL IS UNAVAILABLE THEN CODE THE ! 1179: * ENDFILE RETURN ONLY. ! 1180: * THE BUFFER PROVIDED IS OF LENGTH 120 CHARACTERS. SYSRI ! 1181: * SHOULD REPLACE THE COUNT IN THE SECOND WORD OF THE SCBLK ! 1182: * BY THE ACTUAL CHARACTER COUNT UNLESS BUFFER IS RIGHT ! 1183: * PADDED WITH ZEROES. ! 1184: * IT IS ALSO PERMISSIBLE TO TAKE THE ALTERNATIVE ! 1185: * RETURN AFTER ADJUSTING THE COUNT. ! 1186: * THE END OF FILE RETURN MAY BE USED IF THIS MAKES ! 1187: * SENSE ON THE TARGET MACHINE (E.G. IF THERE IS AN ! 1188: * EOF CHARACTER.) ! 1189: * ! 1190: * (XR) PTR TO 120 CHAR BUFFER (SCBLK PTR) ! 1191: * JSR SYSRI CALL TO READ LINE FROM TERMINAL ! 1192: * PPM LOC END OF FILE RETURN ! 1193: * (WA,WB,WC) MAY BE DESTROYED ! 1194: EJC ! 1195: * ! 1196: * SYSRW -- REWIND FILE ! 1197: * ! 1198: SYSRW EXP DEFINE EXTERNAL ENTRY POINT ! 1199: * ! 1200: * SYSRW IS USED TO REWIND A FILE I.E. REPOSITION THE FILE ! 1201: * AT THE START BEFORE THE FIRST RECORD. THE FILE SHOULD BE ! 1202: * CLOSED AND THE NEXT READ OR WRITE CALL WILL OPEN THE ! 1203: * FILE AT THE START. ! 1204: * ! 1205: * (WA) PTR TO FCBLK OR ZERO ! 1206: * (XR) REWIND ARG (SCBLK PTR) ! 1207: * JSR SYSRW CALL TO REWIND FILE ! 1208: * PPM LOC RETURN HERE IF FILE DOES NOT EXIST ! 1209: * PPM LOC RETURN HERE IF REWIND NOT ALLOWED ! 1210: * PPM LOC RETURN HERE IF I/O ERROR ! 1211: EJC ! 1212: * ! 1213: * SYSST -- SET FILE POINTER ! 1214: * ! 1215: SYSST EXP DEFINE EXTERNAL ENTRY POINT ! 1216: * ! 1217: * SYSST IS CALLED TO CHANGE THE POSITION OF A FILE ! 1218: * POINTER. THIS IS ACCOMPLISHED IN A SYSTEM DEPENDENT ! 1219: * MANNER, AND THUS THE 2ND AND 3RD ARGUMENTS ARE PASSED ! 1220: * UNCONVERTED. ! 1221: * ! 1222: * (WA) FCBLK POINTER ! 1223: * (WB) 2ND ARGUMENT ! 1224: * (WC) 3RD ARGUMENT ! 1225: * JSR SYSST CALL TO SET FILE POINTER ! 1226: * PPM LOC RETURN HERE IF INVALID 2ND ARG ! 1227: * PPM LOC RETURN HERE IF INVALID 3RD ARG ! 1228: * PPM LOC RETURN HERE IF FILE DOES NOT EXIST ! 1229: * PPM LOC RETURN HERE IF SET NOT ALLOWED ! 1230: * PPM LOC RETURN HERE IF I/O ERROR ! 1231: * ! 1232: EJC ! 1233: * ! 1234: * SYSTM -- GET EXECUTION TIME SO FAR ! 1235: * ! 1236: SYSTM EXP DEFINE EXTERNAL ENTRY POINT ! 1237: * ! 1238: * SYSTM IS USED TO OBTAIN THE AMOUNT OF EXECUTION TIME ! 1239: * USED SO FAR SINCE SPITBOL WAS GIVEN CONTROL. THE UNITS ! 1240: * ARE DESCRIBED AS MILLISECONDS IN THE SPITBOL OUTPUT, BUT ! 1241: * THE EXACT MEANING IS SYSTEM DEPENDENT. WHERE APPROPRIATE, ! 1242: * THIS VALUE SHOULD RELATE TO PROCESSOR RATHER THAN CLOCK ! 1243: * TIMING VALUES. ! 1244: * ! 1245: * JSR SYSTM CALL TO GET TIMER VALUE ! 1246: * (IA) TIME SO FAR IN MILLISECONDS ! 1247: EJC ! 1248: * ! 1249: * SYSTT -- TRACE TOGGLE ! 1250: * ! 1251: SYSTT EXP DEFINE EXTERNAL ENTRY POINT ! 1252: * ! 1253: * CALLED BY SPITBOL FUNCTION TRACE() WITH NO ARGS TO ! 1254: * TOGGLE THE SYSTEM TRACE SWITCH. THIS PERMITS TRACING OF ! 1255: * LABELS IN SPITBOL CODE TO BE TURNED ON OR OFF. ! 1256: * ! 1257: * JSR SYSTT CALL TO TOGGLE TRACE SWITCH ! 1258: EJC ! 1259: * ! 1260: * SYSUL -- UNLOAD EXTERNAL FUNCTION ! 1261: * ! 1262: SYSUL EXP DEFINE EXTERNAL ENTRY POINT ! 1263: * ! 1264: * SYSUL IS USED TO UNLOAD A FUNCTION PREVIOUSLY ! 1265: * LOADED WITH A CALL TO SYSLD. ! 1266: * ! 1267: * (XR) PTR TO CONTROL BLOCK (EFBLK) ! 1268: * JSR SYSUL CALL TO UNLOAD FUNCTION ! 1269: * ! 1270: * THE FUNCTION CANNOT BE CALLED FOLLOWING A SYSUL CALL ! 1271: * UNTIL ANOTHER SYSLD CALL IS MADE FOR THE SAME FUNCTION. ! 1272: * ! 1273: * THE EFBLK CONTAINS THE FUNCTION CODE POINTER AND ALSO A ! 1274: * POINTER TO THE VRBLK CONTAINING THE FUNCTION NAME (SEE ! 1275: * DEFINITIONS AND DATA STRUCTURES SECTION). ! 1276: EJC ! 1277: * ! 1278: * SYSXI -- EXIT TO PRODUCE LOAD MODULE ! 1279: * ! 1280: SYSXI EXP DEFINE EXTERNAL ENTRY POINT ! 1281: * ! 1282: * WHEN SYSXI IS CALLED, XL CONTAINS EITHER A STRING POINTER ! 1283: * OR ZERO. IN THE FORMER CASE, THE STRING GIVES THE ! 1284: * CHARACTER NAME OF A PROGRAM. THE INTENTION IS THAT ! 1285: * SPITBOL EXECUTION SHOULD BE TERMINATED FORTHWITH AND ! 1286: * THE NAMED PROGRAM LOADED AND EXECUTED. THIS TYPE OF CHAIN ! 1287: * EXECUTION IS VERY SYSTEM DEPENDENT AND IMPLEMENTORS MAY ! 1288: * CHOOSE TO OMIT IT OR FIND IT IMPOSSIBLE TO PROVIDE. ! 1289: * IF (XL) IS ZERO,IA CONTAINS ONE OF THE FOLLOWING INTEGERS ! 1290: * ! 1291: * -1, -2, -3 ! 1292: * CREATE IF POSSIBLE A LOAD MODULE CONTAINING ONLY THE ! 1293: * IMPURE AREA OF MEMORY WHICH NEEDS TO BE LOADED WITH ! 1294: * A COMPATIBLE PURE SEGMENT FOR SUBSEQUENT EXECUTIONS. ! 1295: * VERSION NUMBERS TO CHECK COMPATIBILITY SHOULD BE ! 1296: * KEPT IN BOTH SEGMENTS AND CHECKED ON LOADING. ! 1297: * TO ASSIST WITH THIS CHECK, (XR) ON ENTRY IS A ! 1298: * POINTER TO AN SCBLK CONTAINING THE SPITBOL MAJOR ! 1299: * VERSION NUMBER V.V (SEE SYSID). ! 1300: * ! 1301: * 0 IF POSSIBLE, RETURN CONTROL TO JOB CONTROL ! 1302: * COMMAND LEVEL. THE EFFECT IF AVAILABLE WILL BE ! 1303: * SYSTEM DEPENDENT. ! 1304: * ! 1305: * +1, +2, +3 ! 1306: * CREATE IF POSSIBLE A LOAD MODULE FROM ALL OF ! 1307: * MEMORY. IT SHOULD BE POSSIBLE TO LOAD AND EXECUTE ! 1308: * THIS MODULE DIRECTLY. ! 1309: * ! 1310: * IN THE CASE OF SAVED LOAD MODULES, THE STATUS OF OPEN ! 1311: * FILES IS NOT PRESERVED AND IMPLEMENTORS MAY CHOOSE TO ! 1312: * OFFER MEANS OF ATTACHING FILES BEFORE EXECUTION OF LOAD ! 1313: * MODULES STARTS OR LEAVE IT TO THE USER TO INCLUDE ! 1314: * SUITABLE INPUT(), OUTPUT() CALLS IN HIS PROGRAM. ! 1315: * SYSXI SHOULD MAKE A NOTE THAT NO I/O CHANNELS, ! 1316: * INCLUDING STANDARD FILES, HAVE FILES ATTACHED SO THAT ! 1317: * CALLS OF SYSIN, SYSOU, SYSPR, SYSRD SHOULD FAIL UNLESS ! 1318: * NEW ASSOCIATIONS ARE MADE FOR THE LOAD MODULE. ! 1319: * AT LEAST IN THE CASE OF THE STANDARD OUTPUT FILE, IT IS ! 1320: * RECOMMENDED THAT EITHER THE USER BE REQUIRED TO ATTACH ! 1321: * A FILE OR THAT A DEFAULT FILE IS ATTACHED, SINCE THE ! 1322: * PROBLEM OF ERROR MESSAGES GENERATED BY THE LOAD MODULE ! 1323: * IS OTHERWISE SEVERE. AS A LAST RESORT, IF SPITBOL ! 1324: * ATTEMPTS TO WRITE TO THE STANDARD OUTPUT FILE AND GETS A ! 1325: * REPLY INDICATING THAT SUCH OUPUT IS UNACCEPTABLE IT STOPS ! 1326: * BY USING AN ENTRY TO SYSEJ WITH ENDING CODE 998. ! 1327: * AS DESCRIBED BELOW, PASSING OF SOME ARGUMENTS MAKES IT ! 1328: * CLEAR THAT LOAD MODULE WILL USE A STANDARD OUTPUT FILE. ! 1329: * ! 1330: * IF USE IS MADE OF FCBLKS FOR I/O ASSOCIATION, SPITBOL ! 1331: * BUILDS A CHAIN SO THAT THOSE IN USE MAY BE FOUND IN SYSXI ! 1332: * AND SYSEJ. THE NODES ARE 4 WORDS LONG. THIRD WORD ! 1333: * CONTAINS LINK TO NEXT NODE OR 0, FOURTH WORD CONTAINS ! 1334: * FCBLK POINTER. ! 1335: EJC ! 1336: * ! 1337: * SYSXI (CONTINUED) ! 1338: * ! 1339: * (XL) ZERO OR SCBLK PTR ! 1340: * (XR) PTR TO V.V SCBLK ! 1341: * (IA) SIGNED INTEGER ARGUMENT ! 1342: * (WB) 0 OR PTR TO HEAD OF FCBLK CHAIN ! 1343: * JSR SYSXI CALL TO EXIT ! 1344: * PPM LOC REQUESTED ACTION NOT POSSIBLE ! 1345: * PPM LOC ACTION CAUSED IRRECOVERABLE ERROR ! 1346: * (REGISTERS) SHOULD BE PRESERVED OVER CALL ! 1347: * ! 1348: * LOADING AND RUNNING THE LOAD MODULE OR RETURNING FROM ! 1349: * JCL COMMAND LEVEL CAUSES EXECUTION TO RESUME AT THE POINT ! 1350: * AFTER THE ERROR RETURNS WHICH FOLLOW THE CALL OF SYSXI. ! 1351: * THE VALUE PASSED AS EXIT ARGUMENT IS USED TO INDICATE ! 1352: * OPTIONS REQUIRED ON RESUMPTION OF LOAD MODULE. ! 1353: * +1 OR -1 REQUIRE THAT ON RESUMPTION, SYSID AND SYSPP BE ! 1354: * CALLED AND A HEADING PRINTED ON THE STANDARD OUTPUT FILE. ! 1355: * +2 OR -2 INDICATE THAT SYSPP WILL BE CALLED BUT NOT SYSID ! 1356: * AND NO HEADING WILL BE PUT ON STANDARD OUTPUT FILE. ! 1357: * ABOVE OPTIONS HAVE THE OBVIOUS IMPLICATION THAT A ! 1358: * STANDARD O/P FILE MUST BE PROVIDED FOR THE LOAD MODULE. ! 1359: * +3 OR -3 INDICATE CALLS OF NEITHER SYSID NOR SYSPP ! 1360: * AND NO HEADING WILL BE PLACED ON STANDARD OUTPUT FILE. ! 1361: * NO RETURN FROM SYSXI IS POSSIBLE IF ANOTHER PROGRAM ! 1362: * IS LOADED AND ENTERED. ! 1363: EJC ! 1364: * ! 1365: * INTRODUCE THE INTERNAL PROCEDURES. ! 1366: * ! 1367: ACESS INP R,1 ! 1368: ACOMP INP N,5 ! 1369: ALLOC INP E,0 ! 1370: ALOBF INP E,0 ! 1371: ALOCS INP E,0 ! 1372: ALOST INP E,0 ! 1373: APNDB INP E,2 ! 1374: ARITH INP N,3 ! 1375: ASIGN INP R,1 ! 1376: ASINP INP R,1 ! 1377: BLKLN INP E,0 ! 1378: CDGCG INP E,0 ! 1379: CDGEX INP R,0 ! 1380: CDGNM INP R,0 ! 1381: CDGVL INP R,0 ! 1382: CDWRD INP E,0 ! 1383: CMGEN INP R,0 ! 1384: CMPIL INP E,0 ! 1385: CNCRD INP E,0 ! 1386: COPYB INP N,1 ! 1387: DFFNC INP E,0 ! 1388: DTACH INP E,0 ! 1389: DTYPE INP E,0 ! 1390: DUMPR INP E,0 ! 1391: ERMSG INP E,0 ! 1392: ERTEX INP E,0 ! 1393: EVALI INP R,4 ! 1394: EVALP INP R,1 ! 1395: EVALS INP R,3 ! 1396: EVALX INP R,1 ! 1397: EXBLD INP E,0 ! 1398: EXPAN INP E,0 ! 1399: EXPAP INP E,1 ! 1400: EXPDM INP N,0 ! 1401: EXPOP INP N,0 ! 1402: FLSTG INP R,0 ! 1403: GBCOL INP E,0 ! 1404: GBCPF INP E,0 ! 1405: GTARR INP E,1 ! 1406: EJC ! 1407: GTCOD INP E,1 ! 1408: GTEXP INP E,1 ! 1409: GTINT INP E,1 ! 1410: GTNUM INP E,1 ! 1411: GTNVR INP E,1 ! 1412: GTPAT INP E,1 ! 1413: GTREA INP E,1 ! 1414: GTSMI INP N,2 ! 1415: GTSTG INP N,1 ! 1416: GTVAR INP E,1 ! 1417: HASHS INP E,0 ! 1418: ICBLD INP E,0 ! 1419: IDENT INP E,1 ! 1420: INOUT INP E,0 ! 1421: INSBF INP E,2 ! 1422: IOFCB INP N,2 ! 1423: IOPPF INP N,0 ! 1424: IOPUT INP N,6 ! 1425: KTREX INP R,0 ! 1426: KWNAM INP N,0 ! 1427: LCOMP INP N,5 ! 1428: LISTR INP E,0 ! 1429: LISTT INP E,0 ! 1430: NEXTS INP E,0 ! 1431: PATIN INP N,2 ! 1432: PATST INP N,1 ! 1433: PBILD INP E,0 ! 1434: PCONC INP E,0 ! 1435: PCOPY INP N,0 ! 1436: PRFLR INP E,0 ! 1437: PRFLU INP E,0 ! 1438: PRPAR INP E,0 ! 1439: PRTCH INP E,0 ! 1440: PRTIC INP E,0 ! 1441: PRTIS INP E,0 ! 1442: PRTIN INP E,0 ! 1443: PRTMI INP E,0 ! 1444: PRTMX INP E,0 ! 1445: PRTNL INP R,0 ! 1446: PRTNM INP R,0 ! 1447: PRTNV INP E,0 ! 1448: PRTPG INP E,0 ! 1449: PRTPS INP E,0 ! 1450: PRTSN INP E,0 ! 1451: PRTST INP R,0 ! 1452: EJC ! 1453: PRTTR INP E,0 ! 1454: PRTVL INP R,0 ! 1455: PRTVN INP E,0 ! 1456: RCBLD INP E,0 ! 1457: READR INP E,0 ! 1458: SBSTR INP E,0 ! 1459: SCANE INP E,0 ! 1460: SCNGF INP E,0 ! 1461: SETVR INP E,0 ! 1462: SORTA INP N,0 ! 1463: SORTC INP E,1 ! 1464: SORTF INP E,0 ! 1465: SORTH INP E,0 ! 1466: TFIND INP E,1 ! 1467: TRACE INP N,2 ! 1468: TRBLD INP E,0 ! 1469: TRIMR INP E,0 ! 1470: TRXEQ INP R,0 ! 1471: XSCAN INP E,0 ! 1472: XSCNI INP N,2 ! 1473: * ! 1474: * INTRODUCE THE INTERNAL ROUTINES ! 1475: * ! 1476: ARREF INR ! 1477: CFUNC INR ! 1478: EXFAL INR ! 1479: EXINT INR ! 1480: EXITS INR ! 1481: EXIXR INR ! 1482: EXNAM INR ! 1483: EXNUL INR ! 1484: EXREA INR ! 1485: EXSID INR ! 1486: EXVNM INR ! 1487: FAILP INR ! 1488: FLPOP INR ! 1489: INDIR INR ! 1490: MATCH INR ! 1491: RETRN INR ! 1492: STCOV INR ! 1493: STMGO INR ! 1494: STOPR INR ! 1495: SUCCP INR ! 1496: SYSAB INR ! 1497: SYSTU INR ! 1498: TTL S P I T B O L -- DEFINITIONS AND DATA STRUCTURES ! 1499: SEC START OF DEFINITIONS SECTION ! 1500: * ! 1501: * DEFINITIONS OF MACHINE PARAMETERS ! 1502: * ! 1503: * THE MINIMAL TRANSLATOR SHOULD SUPPLY APPROPRIATE VALUES ! 1504: * FOR THE PARTICULAR TARGET MACHINE FOR ALL THE ! 1505: * EQU * ! 1506: * DEFINITIONS GIVEN AT THE START OF THIS SECTION. ! 1507: * ! 1508: CFP$A EQU * NUMBER OF CHARACTERS IN ALPHABET ! 1509: * ! 1510: CFP$B EQU * BYTES/WORD ADDRESSING FACTOR ! 1511: * ! 1512: CFP$C EQU * NUMBER OF CHARACTERS PER WORD ! 1513: * ! 1514: CFP$F EQU * OFFSET IN BYTES TO CHARS IN ! 1515: * SCBLK. SEE SCBLK FORMAT. ! 1516: * ! 1517: CFP$I EQU * NUMBER OF WORDS IN INTEGER CONSTANT ! 1518: * ! 1519: CFP$M EQU * MAX POSITIVE INTEGER IN ONE WORD ! 1520: * ! 1521: CFP$N EQU * NUMBER OF BITS IN ONE WORD ! 1522: * ! 1523: * THE FOLLOWING DEFINITIONS REQUIRE THE SUPPLY OF EITHER ! 1524: * A SINGLE PARAMETER IF REAL ARITHMETIC IS OMITTED OR ! 1525: * THREE PARAMETERS IF REAL ARITHMETIC IS INCLUDED. ! 1526: * ! 1527: * ! 1528: CFP$R EQU * NUMBER OF WORDS IN REAL CONSTANT ! 1529: * ! 1530: CFP$S EQU * NUMBER OF SIG DIGS FOR REAL OUTPUT ! 1531: * ! 1532: CFP$X EQU * MAX DIGITS IN REAL EXPONENT ! 1533: * ! 1534: MXDGS EQU CFP$S+CFP$X MAX DIGITS IN REAL NUMBER ! 1535: * ! 1536: NSTMX EQU MXDGS+5 MAX SPACE FOR REAL (FOR +0.E+) ! 1537: * ! 1538: * THE FOLLOWING DEFINITION FOR CFP$U SUPPLIES A REALISTIC ! 1539: * UPPER BOUND ON THE SIZE OF THE ALPHABET. CFP$U IS USED ! 1540: * TO SAVE SPACE IN THE SCANE BSW-IFF-ESW TABLE AND TO EASE ! 1541: * TRANSLATION STORAGE REQUIREMENTS. ! 1542: * ! 1543: CFP$U EQU * REALISTIC UPPER BOUND ON ALPHABET ! 1544: EJC ! 1545: * ! 1546: * ENVIRONMENT PARAMETERS ! 1547: * ! 1548: * THE SPITBOL PROGRAM IS ESSENTIALLY INDEPENDENT OF ! 1549: * THE DEFINITIONS OF THESE PARAMETERS. HOWEVER, THE ! 1550: * EFFICIENCY OF THE SYSTEM MAY BE AFFECTED. CONSEQUENTLY, ! 1551: * THESE PARAMETERS MAY REQUIRE TUNING FOR A GIVEN VERSION ! 1552: * THE VALUES GIVEN IN COMMENTS HAVE BEEN SUCCESSFULLY USED. ! 1553: * ! 1554: * E$SRS IS THE NUMBER OF WORDS TO RESERVE AT THE END OF ! 1555: * STORAGE FOR END OF RUN PROCESSING. IT SHOULD BE ! 1556: * SET AS SMALL AS POSSIBLE WITHOUT CAUSING MEMORY OVERFLOW ! 1557: * IN CRITICAL SITUATIONS (E.G. MEMORY OVERFLOW TERMINATION) ! 1558: * AND SHOULD THUS RESERVE SUFFICIENT SPACE AT LEAST FOR ! 1559: * AN SCBLK CONTAINING SAY 30 CHARACTERS. ! 1560: * ! 1561: E$SRS EQU * 30 WORDS ! 1562: * ! 1563: * E$STS IS THE NUMBER OF WORDS GRABBED IN A CHUNK WHEN ! 1564: * STORAGE IS ALLOCATED IN THE STATIC REGION. THE MINIMUM ! 1565: * PERMITTED VALUE IS 256/CFP$B. LARGER VALUES WILL LEAD ! 1566: * TO INCREASED EFFICIENCY AT THE COST OF WASTING MEMORY. ! 1567: * ! 1568: E$STS EQU * 500 WORDS ! 1569: * ! 1570: * E$CBS IS THE SIZE OF CODE BLOCK ALLOCATED INITIALLY AND ! 1571: * THE EXPANSION INCREMENT IF OVERFLOW OCCURS. IF THIS VALUE ! 1572: * IS TOO SMALL OR TOO LARGE, EXCESSIVE GARBAGE COLLECTIONS ! 1573: * WILL OCCUR DURING COMPILATION AND MEMORY MAY BE LOST ! 1574: * IN THE CASE OF A TOO LARGE VALUE. ! 1575: * ! 1576: E$CBS EQU * 500 WORDS ! 1577: * ! 1578: * E$HNB IS THE NUMBER OF BUCKET HEADERS IN THE VARIABLE ! 1579: * HASH TABLE. IT SHOULD ALWAYS BE ODD. LARGER VALUES WILL ! 1580: * SPEED UP COMPILATION AND INDIRECT REFERENCES AT THE ! 1581: * EXPENSE OF ADDITIONAL STORAGE FOR THE HASH TABLE ITSELF. ! 1582: * ! 1583: E$HNB EQU * 127 BUCKET HEADERS ! 1584: * ! 1585: * E$HNW IS THE MAXIMUM NUMBER OF WORDS OF A STRING ! 1586: * NAME WHICH PARTICIPATE IN THE STRING HASH ALGORITHM. ! 1587: * LARGER VALUES GIVE A BETTER HASH AT THE EXPENSE OF TAKING ! 1588: * LONGER TO COMPUTE THE HASH. THERE IS SOME OPTIMAL VALUE. ! 1589: * ! 1590: E$HNW EQU * 6 WORDS ! 1591: * ! 1592: * E$FSP . IF THE AMOUNT OF FREE SPACE LEFT AFTER A GARBAGE ! 1593: * COLLECTION IS SMALL COMPARED TO THE TOTAL AMOUNT OF SPACE ! 1594: * IN USE GARBAGE COLLECTOR THRASHING IS LIKELY TO OCCUR AS ! 1595: * THIS SPACE IS USED UP. E$FSP IS A MEASURE OF THE ! 1596: * MINIMUM PERCENTAGE OF DYNAMIC MEMORY LEFT AS FREE SPACE ! 1597: * BEFORE THE SYSTEM ROUTINE SYSMM IS CALLED TO TRY TO ! 1598: * OBTAIN MORE MEMORY. ! 1599: * ! 1600: E$FSP EQU * 15 PERCENT ! 1601: EJC ! 1602: * ! 1603: * DEFINITIONS OF CODES FOR LETTERS ! 1604: * ! 1605: CH$LA EQU * LETTER A ! 1606: CH$LB EQU * LETTER B ! 1607: CH$LC EQU * LETTER C ! 1608: CH$LD EQU * LETTER D ! 1609: CH$LE EQU * LETTER E ! 1610: CH$LF EQU * LETTER F ! 1611: CH$LG EQU * LETTER G ! 1612: CH$LH EQU * LETTER H ! 1613: CH$LI EQU * LETTER I ! 1614: CH$LJ EQU * LETTER J ! 1615: CH$LK EQU * LETTER K ! 1616: CH$LL EQU * LETTER L ! 1617: CH$LM EQU * LETTER M ! 1618: CH$LN EQU * LETTER N ! 1619: CH$LO EQU * LETTER O ! 1620: CH$LP EQU * LETTER P ! 1621: CH$LQ EQU * LETTER Q ! 1622: CH$LR EQU * LETTER R ! 1623: CH$LS EQU * LETTER S ! 1624: CH$LT EQU * LETTER T ! 1625: CH$LU EQU * LETTER U ! 1626: CH$LV EQU * LETTER V ! 1627: CH$LW EQU * LETTER W ! 1628: CH$LX EQU * LETTER X ! 1629: CH$LY EQU * LETTER Y ! 1630: CH$L$ EQU * LETTER Z ! 1631: * ! 1632: * DEFINITIONS OF CODES FOR DIGITS ! 1633: * ! 1634: CH$D0 EQU * DIGIT 0 ! 1635: CH$D1 EQU * DIGIT 1 ! 1636: CH$D2 EQU * DIGIT 2 ! 1637: CH$D3 EQU * DIGIT 3 ! 1638: CH$D4 EQU * DIGIT 4 ! 1639: CH$D5 EQU * DIGIT 5 ! 1640: CH$D6 EQU * DIGIT 6 ! 1641: CH$D7 EQU * DIGIT 7 ! 1642: CH$D8 EQU * DIGIT 8 ! 1643: CH$D9 EQU * DIGIT 9 ! 1644: EJC ! 1645: * ! 1646: * DEFINITIONS OF CODES FOR SPECIAL CHARACTERS ! 1647: * ! 1648: * THE NAMES OF THESE CHARACTERS ARE RELATED TO THEIR ! 1649: * ORIGINAL REPRESENTATION IN THE EBCDIC SET CORRESPONDING ! 1650: * TO THE DESCRIPTION IN STANDARD SNOBOL4 MANUALS AND TEXTS. ! 1651: * ! 1652: CH$AM EQU * KEYWORD OPERATOR (AMPERSAND) ! 1653: CH$AS EQU * MULTIPLICATION SYMBOL (ASTERISK) ! 1654: CH$AT EQU * CURSOR POSITION OPERATOR (AT) ! 1655: CH$BB EQU * LEFT ARRAY BRACKET (LESS THAN) ! 1656: CH$BL EQU * BLANK ! 1657: CH$BR EQU * ALTERNATION OPERATOR (VERTICAL BAR) ! 1658: CH$CL EQU * GOTO SYMBOL (COLON) ! 1659: CH$CM EQU * COMMA ! 1660: CH$DL EQU * INDIRECTION OPERATOR (DOLLAR) ! 1661: CH$DT EQU * NAME OPERATOR (DOT) ! 1662: CH$DQ EQU * DOUBLE QUOTE ! 1663: CH$EQ EQU * EQUAL SIGN ! 1664: CH$EX EQU * EXPONENTIATION OPERATOR (EXCLM) ! 1665: CH$MN EQU * MINUS SIGN ! 1666: CH$NM EQU * NUMBER SIGN ! 1667: CH$NT EQU * NEGATION OPERATOR (NOT) ! 1668: CH$PC EQU * PERCENT ! 1669: CH$PL EQU * PLUS SIGN ! 1670: CH$PP EQU * LEFT PARENTHESIS ! 1671: CH$RB EQU * RIGHT ARRAY BRACKET (GRTR THAN) ! 1672: CH$RP EQU * RIGHT PARENTHESIS ! 1673: CH$QU EQU * INTERROGATION OPERATOR (QUESTION) ! 1674: CH$SL EQU * SLASH ! 1675: CH$SM EQU * SEMICOLON ! 1676: CH$SQ EQU * SINGLE QUOTE ! 1677: CH$UN EQU * SPECIAL IDENTIFIER CHAR (UNDERLINE) ! 1678: CH$OB EQU * OPENING BRACKET ! 1679: CH$CB EQU * CLOSING BRACKET ! 1680: EJC ! 1681: * ! 1682: * REMAINING CHARS ARE OPTIONAL ADDITIONS TO THE STANDARDS. ! 1683: * ! 1684: * TAB CHARACTERS - SYNTACTICALLY EQUIVALENT TO BLANK ! 1685: * ! 1686: CH$HT EQU * HORIZONTAL TAB ! 1687: * ! 1688: * LOWER CASE OR SHIFTED CASE ALPHABETIC CHARS ! 1689: * ! 1690: CH$$A EQU * SHIFTED A ! 1691: CH$$B EQU * SHIFTED B ! 1692: CH$$C EQU * SHIFTED C ! 1693: CH$$D EQU * SHIFTED D ! 1694: CH$$E EQU * SHIFTED E ! 1695: CH$$F EQU * SHIFTED F ! 1696: CH$$G EQU * SHIFTED G ! 1697: CH$$H EQU * SHIFTED H ! 1698: CH$$I EQU * SHIFTED I ! 1699: CH$$J EQU * SHIFTED J ! 1700: CH$$K EQU * SHIFTED K ! 1701: CH$$L EQU * SHIFTED L ! 1702: CH$$M EQU * SHIFTED M ! 1703: CH$$N EQU * SHIFTED N ! 1704: CH$$O EQU * SHIFTED O ! 1705: CH$$P EQU * SHIFTED P ! 1706: CH$$Q EQU * SHIFTED Q ! 1707: CH$$R EQU * SHIFTED R ! 1708: CH$$S EQU * SHIFTED S ! 1709: CH$$T EQU * SHIFTED T ! 1710: CH$$U EQU * SHIFTED U ! 1711: CH$$V EQU * SHIFTED V ! 1712: CH$$W EQU * SHIFTED W ! 1713: CH$$X EQU * SHIFTED X ! 1714: CH$$Y EQU * SHIFTED Y ! 1715: CH$$$ EQU * SHIFTED Z ! 1716: * IF A DELIMITER OTHER THAN CH$CM MUST BE USED IN ! 1717: * THE THIRD ARGUMENT OF INPUT(),OUTPUT() THEN .CIOD SHOULD ! 1718: * BE DEFINED AND A PARAMETER SUPPLIED FOR IODEL. ! 1719: * ! 1720: IODEL EQU * ! 1721: EJC ! 1722: * ! 1723: * DATA BLOCK FORMATS AND DEFINITIONS ! 1724: * ! 1725: * THE FOLLOWING SECTIONS DESCRIBE THE DETAILED FORMAT OF ! 1726: * ALL POSSIBLE DATA BLOCKS IN STATIC AND DYNAMIC MEMORY. ! 1727: * ! 1728: * EVERY BLOCK HAS A NAME OF THE FORM XXBLK WHERE XX IS A ! 1729: * UNIQUE TWO CHARACTER IDENTIFIER. THE FIRST WORD OF EVERY ! 1730: * BLOCK MUST CONTAIN A POINTER TO A PROGRAM LOCATION IN THE ! 1731: * INTERPRETOR WHICH IS IMMEDIATELY PRECEDED BY AN ADDRESS ! 1732: * CONSTANT CONTAINING THE VALUE BL$XX WHERE XX IS THE BLOCK ! 1733: * IDENTIFIER. THIS PROVIDES A UNIFORM MECHANISM FOR ! 1734: * DISTINGUISHING BETWEEN THE VARIOUS BLOCK TYPES. ! 1735: * ! 1736: * IN SOME CASES, THE CONTENTS OF THE FIRST WORD IS CONSTANT ! 1737: * FOR A GIVEN BLOCK TYPE AND MERELY SERVES AS A POINTER ! 1738: * TO THE IDENTIFYING ADDRESS CONSTANT. HOWEVER, IN OTHER ! 1739: * CASES THERE ARE SEVERAL POSSIBILITIES FOR THE FIRST ! 1740: * WORD IN WHICH CASE EACH OF THE SEVERAL PROGRAM ENTRY ! 1741: * POINTS MUST BE PRECEDED BY THE APPROPRIATE CONSTANT. ! 1742: * ! 1743: * IN EACH BLOCK, SOME OF THE FIELDS ARE RELOCATABLE. THIS ! 1744: * MEANS THAT THEY MAY CONTAIN A POINTER TO ANOTHER BLOCK ! 1745: * IN THE DYNAMIC AREA. (TO BE MORE PRECISE, IF THEY CONTAIN ! 1746: * A POINTER WITHIN THE DYNAMIC AREA, THEN IT IS A POINTER ! 1747: * TO A BLOCK). SUCH FIELDS MUST BE MODIFIED BY THE GARBAGE ! 1748: * COLLECTOR (PROCEDURE GBCOL) WHENEVER BLOCKS ARE COMPACTED ! 1749: * IN THE DYNAMIC REGION. THE GARBAGE COLLECTOR (ACTUALLY ! 1750: * PROCEDURE GBCPF) REQUIRES THAT ALL SUCH RELOCATABLE ! 1751: * FIELDS IN A BLOCK MUST BE CONTIGUOUS. ! 1752: EJC ! 1753: * ! 1754: * THE DESCRIPTION FORMAT USES THE FOLLOWING SCHEME. ! 1755: * ! 1756: * 1) BLOCK TITLE AND TWO CHARACTER IDENTIFIER ! 1757: * ! 1758: * 2) DESCRIPTION OF BASIC USE OF BLOCK AND INDICATION ! 1759: * OF CIRCUMSTANCES UNDER WHICH IT IS CONSTRUCTED. ! 1760: * ! 1761: * 3) PICTURE OF THE BLOCK FORMAT. IN THESE PICTURES LOW ! 1762: * MEMORY ADDRESSES ARE AT THE TOP OF THE PAGE. FIXED ! 1763: * LENGTH FIELDS ARE SURROUNDED BY I (LETTER I). FIELDS ! 1764: * WHICH ARE FIXED LENGTH BUT WHOSE LENGTH IS DEPENDENT ! 1765: * ON A CONFIGURATION PARAMETER ARE SURROUNDED BY * ! 1766: * (ASTERISK). VARIABLE LENGTH FIELDS ARE SURROUNDED ! 1767: * BY / (SLASH). ! 1768: * ! 1769: * 4) DEFINITION OF SYMBOLIC OFFSETS TO FIELDS IN ! 1770: * BLOCK AND OF THE SIZE OF THE BLOCK IF FIXED LENGTH ! 1771: * OR OF THE SIZE OF THE FIXED LENGTH FIELDS IF THE ! 1772: * BLOCK IS VARIABLE LENGTH. ! 1773: * NOTE THAT SOME ROUTINES SUCH AS GBCPF ASSUME ! 1774: * CERTAIN OFFSETS ARE EQUAL. THE DEFINITIONS ! 1775: * GIVEN HERE ENFORCE THIS. MAKE CHANGES TO ! 1776: * THEM ONLY WITH DUE CARE. ! 1777: * ! 1778: * DEFINITIONS OF COMMON OFFSETS ! 1779: * ! 1780: OFFS1 EQU 1 ! 1781: OFFS2 EQU 2 ! 1782: OFFS3 EQU 3 ! 1783: * ! 1784: * 5) DETAILED COMMENTS ON THE SIGNIFICANCE AND FORMATS ! 1785: * OF THE VARIOUS FIELDS. ! 1786: * ! 1787: * THE ORDER IS ALPHABETICAL BY IDENTIFICATION CODE. ! 1788: EJC ! 1789: * ! 1790: * DEFINITIONS OF BLOCK CODES ! 1791: * ! 1792: * THIS TABLE PROVIDES A UNIQUE IDENTIFICATION CODE FOR ! 1793: * EACH SEPARATE BLOCK TYPE. THE FIRST WORD OF A BLOCK IN ! 1794: * THE DYNAMIC AREA ALWAYS CONTAINS THE ADDRESS OF A PROGRAM ! 1795: * ENTRY POINT. THE BLOCK CODE IS USED AS THE ENTRY POINT ID ! 1796: * THE ORDER OF THESE CODES DICTATES THE ORDER OF THE TABLE ! 1797: * USED BY THE DATATYPE FUNCTION (SCNMT IN THE CONSTANT SEC) ! 1798: * ! 1799: * BLOCK CODES FOR ACCESSIBLE DATATYPES ! 1800: * ! 1801: BL$AR EQU 0 ARBLK ARRAY ! 1802: BL$BC EQU BL$AR+1 BCBLK BUFFER ! 1803: BL$CD EQU BL$BC+1 CDBLK CODE ! 1804: BL$EX EQU BL$CD+1 EXBLK EXPRESSION ! 1805: BL$IC EQU BL$EX+1 ICBLK INTEGER ! 1806: BL$NM EQU BL$IC+1 NMBLK NAME ! 1807: BL$P0 EQU BL$NM+1 P0BLK PATTERN ! 1808: BL$P1 EQU BL$P0+1 P1BLK PATTERN ! 1809: BL$P2 EQU BL$P1+1 P2BLK PATTERN ! 1810: BL$RC EQU BL$P2+1 RCBLK REAL ! 1811: BL$SC EQU BL$RC+1 SCBLK STRING ! 1812: BL$SE EQU BL$SC+1 SEBLK EXPRESSION ! 1813: BL$TB EQU BL$SE+1 TBBLK TABLE ! 1814: BL$VC EQU BL$TB+1 VCBLK ARRAY ! 1815: BL$XN EQU BL$VC+1 XNBLK EXTERNAL ! 1816: BL$XR EQU BL$XN+1 XRBLK EXTERNAL ! 1817: BL$PD EQU BL$XR+1 PDBLK PROGRAM DEFINED DATATYPE ! 1818: * ! 1819: BL$$D EQU BL$PD+1 NUMBER OF BLOCK CODES FOR DATA ! 1820: * ! 1821: * OTHER BLOCK CODES ! 1822: * ! 1823: BL$TR EQU BL$PD+1 TRBLK ! 1824: BL$BF EQU BL$TR+1 BFBLK ! 1825: BL$CC EQU BL$BF+1 CCBLK ! 1826: BL$CM EQU BL$CC+1 CMBLK ! 1827: BL$CT EQU BL$CM+1 CTBLK ! 1828: BL$DF EQU BL$CT+1 DFBLK ! 1829: BL$EF EQU BL$DF+1 EFBLK ! 1830: BL$EV EQU BL$EF+1 EVBLK ! 1831: BL$FF EQU BL$EV+1 FFBLK ! 1832: BL$KV EQU BL$FF+1 KVBLK ! 1833: BL$PF EQU BL$KV+1 PFBLK ! 1834: BL$TE EQU BL$PF+1 TEBLK ! 1835: * ! 1836: BL$$I EQU 0 DEFAULT IDENTIFICATION CODE ! 1837: BL$$T EQU BL$TR+1 CODE FOR DATA OR TRACE BLOCK ! 1838: BL$$$ EQU BL$TE+1 NUMBER OF BLOCK CODES ! 1839: EJC ! 1840: * ! 1841: * FIELD REFERENCES ! 1842: * ! 1843: * REFERENCES TO THE FIELDS OF DATA BLOCKS ARE SYMBOLIC ! 1844: * (I.E. USE THE SYMBOLIC OFFSETS) WITH THE FOLLOWING ! 1845: * EXCEPTIONS. ! 1846: * ! 1847: * 1) REFERENCES TO THE FIRST WORD ARE USUALLY NOT ! 1848: * SYMBOLIC SINCE THEY USE THE (X) OPERAND FORMAT. ! 1849: * ! 1850: * 2) THE CODE WHICH CONSTRUCTS A BLOCK IS OFTEN NOT ! 1851: * SYMBOLIC AND SHOULD BE CHANGED IF THE CORRESPONDING ! 1852: * BLOCK FORMAT IS MODIFIED. ! 1853: * ! 1854: * 3) THE PLC AND PSC INSTRUCTIONS IMPLY AN OFFSET ! 1855: * CORRESPONDING TO THE DEFINITION OF CFP$F. ! 1856: * ! 1857: * 4) THERE ARE NON-SYMBOLIC REFERENCES (EASILY CHANGED) ! 1858: * IN THE GARBAGE COLLECTOR (PROCEDURES GBCPF, BLKLN). ! 1859: * ! 1860: * 5) THE FIELDS IDVAL, FARGS APPEAR IN SEVERAL BLOCKS ! 1861: * AND ANY CHANGES MUST BE MADE IN PARALLEL TO ALL ! 1862: * BLOCKS CONTAINING THE FIELDS. THE ACTUAL REFERENCES ! 1863: * TO THESE FIELDS ARE SYMBOLIC WITH THE ABOVE ! 1864: * LISTED EXCEPTIONS. ! 1865: * ! 1866: * 6) SEVERAL SPOTS IN THE CODE ASSUME THAT THE ! 1867: * DEFINITIONS OF THE FIELDS VRVAL, TEVAL, TRNXT ARE ! 1868: * THE SAME (THESE ARE SECTIONS OF CODE WHICH SEARCH ! 1869: * OUT ALONG A TRBLK CHAIN FROM A VARIABLE). ! 1870: * ! 1871: * 7) REFERENCES TO THE FIELDS OF AN ARRAY BLOCK IN THE ! 1872: * ARRAY REFERENCE ROUTINE ARREF ARE NON-SYMBOLIC. ! 1873: * ! 1874: * APART FROM THE EXCEPTIONS LISTED, REFERENCES ARE SYMBOLIC ! 1875: * AS FAR AS POSSIBLE AND MODIFYING THE ORDER OR NUMBER ! 1876: * OF FIELDS WILL NOT REQUIRE CHANGES. ! 1877: EJC ! 1878: * ! 1879: * COMMON FIELDS FOR FUNCTION BLOCKS ! 1880: * ! 1881: * BLOCKS WHICH REPRESENT CALLABLE FUNCTIONS HAVE TWO ! 1882: * COMMON FIELDS AT THE START OF THE BLOCK AS FOLLOWS. ! 1883: * ! 1884: * +------------------------------------+ ! 1885: * I FCODE I ! 1886: * +------------------------------------+ ! 1887: * I FARGS I ! 1888: * +------------------------------------+ ! 1889: * / / ! 1890: * / REST OF FUNCTION BLOCK / ! 1891: * / / ! 1892: * +------------------------------------+ ! 1893: * ! 1894: FCODE EQU 0 POINTER TO CODE FOR FUNCTION ! 1895: FARGS EQU 1 NUMBER OF ARGUMENTS ! 1896: * ! 1897: * FCODE IS A POINTER TO THE LOCATION IN THE INTERPRETOR ! 1898: * PROGRAM WHICH PROCESSES THIS TYPE OF FUNCTION CALL. ! 1899: * ! 1900: * FARGS IS THE EXPECTED NUMBER OF ARGUMENTS. THE ACTUAL ! 1901: * NUMBER OF ARGUMENTS IS ADJUSTED TO THIS AMOUNT BY ! 1902: * DELETING EXTRA ARGUMENTS OR SUPPLYING TRAILING NULLS ! 1903: * FOR MISSING ONES BEFORE TRANSFERRING THOUGH FCODE. ! 1904: * A VALUE OF 999 MAY BE USED IN THIS FIELD TO INDICATE A ! 1905: * VARIABLE NUMBER OF ARGUMENTS (SEE SVBLK FIELD SVNAR). ! 1906: * ! 1907: * THE BLOCK TYPES WHICH FOLLOW THIS SCHEME ARE. ! 1908: * ! 1909: * FFBLK FIELD FUNCTION ! 1910: * DFBLK DATATYPE FUNCTION ! 1911: * PFBLK PROGRAM DEFINED FUNCTION ! 1912: * EFBLK EXTERNAL LOADED FUNCTION ! 1913: EJC ! 1914: * ! 1915: * IDENTIFICATION FIELD ! 1916: * ! 1917: * ! 1918: * ID FIELD ! 1919: * ! 1920: * CERTAIN PROGRAM ACCESSIBLE OBJECTS (THOSE WHICH CONTAIN ! 1921: * OTHER DATA VALUES AND CAN BE COPIED) ARE GIVEN A UNIQUE ! 1922: * IDENTIFICATION NUMBER (SEE EXSID). THIS ID VALUE IS AN ! 1923: * ADDRESS INTEGER VALUE WHICH IS ALWAYS STORED IN WORD TWO. ! 1924: * ! 1925: IDVAL EQU 1 ID VALUE FIELD ! 1926: * ! 1927: * THE BLOCKS CONTAINING AN IDVAL FIELD ARE. ! 1928: * ! 1929: * ARBLK ARRAY ! 1930: * BCBLK BUFFER CONTROL BLOCK ! 1931: * PDBLK PROGRAM DEFINED DATATYPE ! 1932: * TBBLK TABLE ! 1933: * VCBLK VECTOR BLOCK (ARRAY) ! 1934: * ! 1935: * NOTE THAT A ZERO IDVAL MEANS THAT THE BLOCK IS ONLY ! 1936: * HALF BUILT AND SHOULD NOT BE DUMPED (SEE DUMPR). ! 1937: EJC ! 1938: * ! 1939: * ARRAY BLOCK (ARBLK) ! 1940: * ! 1941: * AN ARRAY BLOCK REPRESENTS AN ARRAY VALUE OTHER THAN ONE ! 1942: * WITH ONE DIMENSION WHOSE LOWER BOUND IS ONE (SEE VCBLK). ! 1943: * AN ARBLK IS BUILT WITH A CALL TO THE FUNCTIONS CONVERT ! 1944: * (S$CNV) OR ARRAY (S$ARR). ! 1945: * ! 1946: * +------------------------------------+ ! 1947: * I ARTYP I ! 1948: * +------------------------------------+ ! 1949: * I IDVAL I ! 1950: * +------------------------------------+ ! 1951: * I ARLEN I ! 1952: * +------------------------------------+ ! 1953: * I AROFS I ! 1954: * +------------------------------------+ ! 1955: * I ARNDM I ! 1956: * +------------------------------------+ ! 1957: * * ARLBD * ! 1958: * +------------------------------------+ ! 1959: * * ARDIM * ! 1960: * +------------------------------------+ ! 1961: * * * ! 1962: * * ABOVE 2 FLDS REPEATED FOR EACH DIM * ! 1963: * * * ! 1964: * +------------------------------------+ ! 1965: * I ARPRO I ! 1966: * +------------------------------------+ ! 1967: * / / ! 1968: * / ARVLS / ! 1969: * / / ! 1970: * +------------------------------------+ ! 1971: EJC ! 1972: * ! 1973: * ARRAY BLOCK (CONTINUED) ! 1974: * ! 1975: ARTYP EQU 0 POINTER TO DUMMY ROUTINE B$ART ! 1976: ARLEN EQU IDVAL+1 LENGTH OF ARBLK IN BYTES ! 1977: AROFS EQU ARLEN+1 OFFSET IN ARBLK TO ARPRO FIELD ! 1978: ARNDM EQU AROFS+1 NUMBER OF DIMENSIONS ! 1979: ARLBD EQU ARNDM+1 LOW BOUND (FIRST SUBSCRIPT) ! 1980: ARDIM EQU ARLBD+CFP$I DIMENSION (FIRST SUBSCRIPT) ! 1981: ARLB2 EQU ARDIM+CFP$I LOW BOUND (SECOND SUBSCRIPT) ! 1982: ARDM2 EQU ARLB2+CFP$I DIMENSION (SECOND SUBSCRIPT) ! 1983: ARPRO EQU ARDIM+CFP$I ARRAY PROTOTYPE (ONE DIMENSION) ! 1984: ARVLS EQU ARPRO+1 START OF VALUES (ONE DIMENSION) ! 1985: ARPR2 EQU ARDM2+CFP$I ARRAY PROTOTYPE (TWO DIMENSIONS) ! 1986: ARVL2 EQU ARPR2+1 START OF VALUES (TWO DIMENSIONS) ! 1987: ARSI$ EQU ARLBD NUMBER OF STANDARD FIELDS IN BLOCK ! 1988: ARDMS EQU ARLB2-ARLBD SIZE OF INFO FOR ONE SET OF BOUNDS ! 1989: * ! 1990: * THE BOUNDS AND DIMENSION FIELDS ARE SIGNED INTEGER ! 1991: * VALUES AND EACH OCCUPY CFP$I WORDS IN THE ARBLK. ! 1992: * ! 1993: * THE LENGTH OF AN ARBLK IN BYTES MAY NOT EXCEED MXLEN. ! 1994: * THIS IS REQUIRED TO KEEP NAME OFFSETS GARBAGE COLLECTABLE ! 1995: * ! 1996: * THE ACTUAL VALUES ARE ARRANGED IN ROW-WISE ORDER AND ! 1997: * CAN CONTAIN A DATA POINTER OR A POINTER TO A TRBLK. ! 1998: * ! 1999: * BUFFER CONTROL BLOCK (BCBLK) ! 2000: * ! 2001: * A BCBLK IS BUILT FOR EVERY BFBLK. ! 2002: * ! 2003: * +------------------------------------+ ! 2004: * I BCTYP I ! 2005: * +------------------------------------+ ! 2006: * I IDVAL I ! 2007: * +------------------------------------+ ! 2008: * I BCLEN I ! 2009: * +------------------------------------+ ! 2010: * I BCBUF I ! 2011: * +------------------------------------+ ! 2012: * ! 2013: BCTYP EQU 0 PTR TO DUMMY ROUTINE B$BCT ! 2014: BCLEN EQU IDVAL+1 DEFINED BUFFER LENGTH ! 2015: BCBUF EQU BCLEN+1 PTR TO BFBLK ! 2016: BCSI$ EQU BCBUF+1 SIZE OF BCBLK ! 2017: * ! 2018: * A BCBLK IS AN INDIRECT CONTROL HEADER FOR BFBLK. ! 2019: * THE REASON FOR NOT STORING THIS DATA DIRECTLY ! 2020: * IN THE RELATED BFBLK IS SO THAT THE BFBLK CAN ! 2021: * MAINTAIN THE SAME SKELETAL STRUCTURE AS AN SCBLK ! 2022: * THUS FACILITATING TRANSPARENT STRING OPERATIONS ! 2023: * (FOR THE MOST PART). SPECIFICALLY, CFP$F IS THE ! 2024: * SAME FOR A BFBLK AS FOR AN SCBLK. BY CONVENTION, ! 2025: * WHEREEVER A BUFFER VALUE IS EMPLOYED, THE BCBLK ! 2026: * IS POINTED TO. ! 2027: * ! 2028: * THE CORRESPONDING BFBLK IS POINTED TO BY THE ! 2029: * BCBUF POINTER IN THE BCBLK. ! 2030: * ! 2031: * BCLEN IS THE CURRENT DEFINED SIZE OF THE CHARACTER ! 2032: * ARRAY IN THE BFBLK. CHARACTERS FOLLOWING THE OFFSET ! 2033: * OF BCLEN ARE UNDEFINED. ! 2034: * ! 2035: EJC ! 2036: * ! 2037: * STRING BUFFER BLOCK (BFBLK) ! 2038: * ! 2039: * A BFBLK IS BUILT BY A CALL TO BUFFER(...) ! 2040: * ! 2041: * +------------------------------------+ ! 2042: * I BFTYP I ! 2043: * +------------------------------------+ ! 2044: * I BFALC I ! 2045: * +------------------------------------+ ! 2046: * / / ! 2047: * / BFCHR / ! 2048: * / / ! 2049: * +------------------------------------+ ! 2050: * ! 2051: BFTYP EQU 0 PTR TO DUMMY ROUTINE B$BFT ! 2052: BFALC EQU BFTYP+1 ALLOCATED SIZE OF BUFFER ! 2053: BFCHR EQU BFALC+1 CHARACTERS OF STRING ! 2054: BFSI$ EQU BFCHR SIZE OF STANDARD FIELDS IN BFBLK ! 2055: * ! 2056: * THE CHARACTERS IN THE BUFFER ARE STORED LEFT JUSTIFIED. ! 2057: * THE FINAL WORD OF DEFINED CHARACTERS IS ALWAYS ZERO ! 2058: * (CHARACTER) PADDED. ANY TRAILING ALLOCATION PAST THE ! 2059: * WORD CONTAINING THE LAST CHARACTER CONTAINS ! 2060: * UNPREDICTABLE CONTENTS AND IS NEVER REFERENCED. ! 2061: * ! 2062: * NOTE THAT THE OFFSET TO THE CHARACTERS OF THE STRING ! 2063: * IS GIVEN BY CFP$F, AS WITH AN SCBLK. HOWEVER, THE ! 2064: * OFFSET WHICH IS OCCUPIED BY THE LENGTH FOR AN SCBLK ! 2065: * IS THE TOTAL CHAR SPACE FOR BFBLKS, AND ROUTINES WHICH ! 2066: * DEAL WITH BOTH MUST ACCOUNT FOR THIS DIFFERENCE. ! 2067: * ! 2068: * THE VALUE OF BFALC MAY NOT EXCEED MXLEN. THE VALUE OF ! 2069: * BCLEN IS ALWAYS LESS THAN OR EQUAL TO BFALC. ! 2070: * ! 2071: EJC ! 2072: * ! 2073: * CODE CONSTRUCTION BLOCK (CCBLK) ! 2074: * ! 2075: * AT ANY ONE MOMENT THERE IS AT MOST ONE CCBLK INTO ! 2076: * WHICH THE COMPILER IS CURRENTLY STORING CODE (CDWRD). ! 2077: * ! 2078: * +------------------------------------+ ! 2079: * I CCTYP I ! 2080: * +------------------------------------+ ! 2081: * I CCLEN I ! 2082: * +------------------------------------+ ! 2083: * I CCUSE I ! 2084: * +------------------------------------+ ! 2085: * / / ! 2086: * / CCCOD / ! 2087: * / / ! 2088: * +------------------------------------+ ! 2089: * ! 2090: CCTYP EQU 0 POINTER TO DUMMY ROUTINE B$CCT ! 2091: CCLEN EQU CCTYP+1 LENGTH OF CCBLK IN BYTES ! 2092: CCUSE EQU CCLEN+1 OFFSET PAST LAST USED WORD (BYTES) ! 2093: CCCOD EQU CCUSE+1 START OF GENERATED CODE IN BLOCK ! 2094: * ! 2095: * THE REASON THAT THE CCBLK IS A SEPARATE BLOCK TYPE FROM ! 2096: * THE USUAL CDBLK IS THAT THE GARBAGE COLLECTOR MUST ! 2097: * ONLY PROCESS THOSE FIELDS WHICH HAVE BEEN SET (SEE GBCPF) ! 2098: EJC ! 2099: * ! 2100: * CODE BLOCK (CDBLK) ! 2101: * ! 2102: * A CODE BLOCK IS BUILT FOR EACH STATEMENT COMPILED DURING ! 2103: * THE INITIAL COMPILATION OR BY SUBSEQUENT CALLS TO CODE. ! 2104: * ! 2105: * +------------------------------------+ ! 2106: * I CDJMP I ! 2107: * +------------------------------------+ ! 2108: * I CDSTM I ! 2109: * +------------------------------------+ ! 2110: * I CDLEN I ! 2111: * +------------------------------------+ ! 2112: * I CDFAL I ! 2113: * +------------------------------------+ ! 2114: * / / ! 2115: * / CDCOD / ! 2116: * / / ! 2117: * +------------------------------------+ ! 2118: * ! 2119: CDJMP EQU 0 PTR TO ROUTINE TO EXECUTE STATEMENT ! 2120: CDSTM EQU CDJMP+1 STATEMENT NUMBER ! 2121: CDLEN EQU OFFS2 LENGTH OF CDBLK IN BYTES ! 2122: CDFAL EQU OFFS3 FAILURE EXIT (SEE BELOW) ! 2123: CDCOD EQU CDFAL+1 EXECUTABLE PSEUDO-CODE ! 2124: CDSI$ EQU CDCOD NUMBER OF STANDARD FIELDS IN CDBLK ! 2125: * ! 2126: * CDSTM IS THE STATEMENT NUMBER OF THE CURRENT STATEMENT. ! 2127: * ! 2128: * CDJMP, CDFAL ARE SET AS FOLLOWS. ! 2129: * ! 2130: * 1) IF THE FAILURE EXIT IS THE NEXT STATEMENT ! 2131: * ! 2132: * CDJMP = B$CDS ! 2133: * CDFAL = PTR TO CDBLK FOR NEXT STATEMENT ! 2134: * ! 2135: * 2) IF THE FAILURE EXIT IS A SIMPLE LABEL NAME ! 2136: * ! 2137: * CDJMP = B$CDS ! 2138: * CDFAL IS A PTR TO THE VRTRA FIELD OF THE VRBLK ! 2139: * ! 2140: * 3) IF THERE IS NO FAILURE EXIT (-NOFAIL MODE) ! 2141: * ! 2142: * CDJMP = B$CDS ! 2143: * CDFAL = O$UNF ! 2144: * ! 2145: * 4) IF THE FAILURE EXIT IS COMPLEX OR DIRECT ! 2146: * ! 2147: * CDJMP = B$CDC ! 2148: * CDFAL IS THE OFFSET TO THE O$GOF WORD ! 2149: EJC ! 2150: * ! 2151: * CODE BLOCK (CONTINUED) ! 2152: * ! 2153: * CDCOD IS THE START OF THE ACTUAL CODE. FIRST WE DESCRIBE ! 2154: * THE CODE GENERATED FOR AN EXPRESSION. IN AN EXPRESSION, ! 2155: * ELEMENTS ARE FETCHED BY NAME OR BY VALUE. FOR EXAMPLE, ! 2156: * THE BINARY EQUAL OPERATOR FETCHES ITS LEFT ARGUMENT ! 2157: * BY NAME AND ITS RIGHT ARGUMENT BY VALUE. THESE TWO ! 2158: * CASES GENERATE QUITE DIFFERENT CODE AND ARE DESCRIBED ! 2159: * SEPARATELY. FIRST WE CONSIDER THE CODE BY VALUE CASE. ! 2160: * ! 2161: * GENERATION OF CODE BY VALUE FOR EXPRESSIONS ELEMENTS. ! 2162: * ! 2163: * EXPRESSION POINTER TO EXBLK OR SEBLK ! 2164: * ! 2165: * INTEGER CONSTANT POINTER TO ICBLK ! 2166: * ! 2167: * NULL CONSTANT POINTER TO NULLS ! 2168: * ! 2169: * PATTERN (RESULTING FROM PREEVALUATION) ! 2170: * =O$LPT ! 2171: * POINTER TO P0BLK,P1BLK OR P2BLK ! 2172: * ! 2173: * REAL CONSTANT POINTER TO RCBLK ! 2174: * ! 2175: * STRING CONSTANT POINTER TO SCBLK ! 2176: * ! 2177: * VARIABLE POINTER TO VRGET FIELD OF VRBLK ! 2178: * ! 2179: * ADDITION VALUE CODE FOR LEFT OPERAND ! 2180: * VALUE CODE FOR RIGHT OPERAND ! 2181: * =O$ADD ! 2182: * ! 2183: * AFFIRMATION VALUE CODE FOR OPERAND ! 2184: * =O$AFF ! 2185: * ! 2186: * ALTERNATION VALUE CODE FOR LEFT OPERAND ! 2187: * VALUE CODE FOR RIGHT OPERAND ! 2188: * =O$ALT ! 2189: * ! 2190: * ARRAY REFERENCE (CASE OF ONE SUBSCRIPT) ! 2191: * VALUE CODE FOR ARRAY OPERAND ! 2192: * VALUE CODE FOR SUBSCRIPT OPERAND ! 2193: * =O$AOV ! 2194: * ! 2195: * (CASE OF MORE THAN ONE SUBSCRIPT) ! 2196: * VALUE CODE FOR ARRAY OPERAND ! 2197: * VALUE CODE FOR FIRST SUBSCRIPT ! 2198: * VALUE CODE FOR SECOND SUBSCRIPT ! 2199: * ... ! 2200: * VALUE CODE FOR LAST SUBSCRIPT ! 2201: * =O$AMV ! 2202: * NUMBER OF SUBSCRIPTS ! 2203: EJC ! 2204: * ! 2205: * CODE BLOCK (CONTINUED) ! 2206: * ! 2207: * ASSIGNMENT (TO NATURAL VARIABLE) ! 2208: * VALUE CODE FOR RIGHT OPERAND ! 2209: * POINTER TO VRSTO FIELD OF VRBLK ! 2210: * ! 2211: * (TO ANY OTHER VARIABLE) ! 2212: * NAME CODE FOR LEFT OPERAND ! 2213: * VALUE CODE FOR RIGHT OPERAND ! 2214: * =O$ASS ! 2215: * ! 2216: * COMPILE ERROR =O$CER ! 2217: * ! 2218: * ! 2219: * COMPLEMENTATION VALUE CODE FOR OPERAND ! 2220: * =O$COM ! 2221: * ! 2222: * CONCATENATION (CASE OF PRED FUNC LEFT OPERAND) ! 2223: * VALUE CODE FOR LEFT OPERAND ! 2224: * =O$POP ! 2225: * VALUE CODE FOR RIGHT OPERAND ! 2226: * ! 2227: * (ALL OTHER CASES) ! 2228: * VALUE CODE FOR LEFT OPERAND ! 2229: * VALUE CODE FOR RIGHT OPERAND ! 2230: * =O$CNC ! 2231: * ! 2232: * CURSOR ASSIGNMENT NAME CODE FOR OPERAND ! 2233: * =O$CAS ! 2234: * ! 2235: * DIVISION VALUE CODE FOR LEFT OPERAND ! 2236: * VALUE CODE FOR RIGHT OPERAND ! 2237: * =O$DVD ! 2238: * ! 2239: * EXPONENTIATION VALUE CODE FOR LEFT OPERAND ! 2240: * VALUE CODE FOR RIGHT OPERAND ! 2241: * =O$EXP ! 2242: * ! 2243: * FUNCTION CALL (CASE OF CALL TO SYSTEM FUNCTION) ! 2244: * VALUE CODE FOR FIRST ARGUMENT ! 2245: * VALUE CODE FOR SECOND ARGUMENT ! 2246: * ... ! 2247: * VALUE CODE FOR LAST ARGUMENT ! 2248: * POINTER TO SVFNC FIELD OF SVBLK ! 2249: * ! 2250: EJC ! 2251: * ! 2252: * CODE BLOCK (CONTINUED) ! 2253: * ! 2254: * FUNCTION CALL (CASE OF NON-SYSTEM FUNCTION 1 ARG) ! 2255: * VALUE CODE FOR ARGUMENT ! 2256: * =O$FNS ! 2257: * POINTER TO VRBLK FOR FUNCTION ! 2258: * ! 2259: * (NON-SYSTEM FUNCTION, GT 1 ARG) ! 2260: * VALUE CODE FOR FIRST ARGUMENT ! 2261: * VALUE CODE FOR SECOND ARGUMENT ! 2262: * ... ! 2263: * VALUE CODE FOR LAST ARGUMENT ! 2264: * =O$FNC ! 2265: * NUMBER OF ARGUMENTS ! 2266: * POINTER TO VRBLK FOR FUNCTION ! 2267: * ! 2268: * IMMEDIATE ASSIGNMENT VALUE CODE FOR LEFT OPERAND ! 2269: * NAME CODE FOR RIGHT OPERAND ! 2270: * =O$IMA ! 2271: * ! 2272: * INDIRECTION VALUE CODE FOR OPERAND ! 2273: * =O$INV ! 2274: * ! 2275: * INTERROGATION VALUE CODE FOR OPERAND ! 2276: * =O$INT ! 2277: * ! 2278: * KEYWORD REFERENCE NAME CODE FOR OPERAND ! 2279: * =O$KWV ! 2280: * ! 2281: * MULTIPLICATION VALUE CODE FOR LEFT OPERAND ! 2282: * VALUE CODE FOR RIGHT OPERAND ! 2283: * =O$MLT ! 2284: * ! 2285: * NAME REFERENCE (NATURAL VARIABLE CASE) ! 2286: * POINTER TO NMBLK FOR NAME ! 2287: * ! 2288: * (ALL OTHER CASES) ! 2289: * NAME CODE FOR OPERAND ! 2290: * =O$NAM ! 2291: * ! 2292: * NEGATION =O$NTA ! 2293: * CDBLK OFFSET OF O$NTC WORD ! 2294: * VALUE CODE FOR OPERAND ! 2295: * =O$NTB ! 2296: * =O$NTC ! 2297: EJC ! 2298: * ! 2299: * CODE BLOCK (CONTINUED) ! 2300: * ! 2301: * PATTERN ASSIGNMENT VALUE CODE FOR LEFT OPERAND ! 2302: * NAME CODE FOR RIGHT OPERAND ! 2303: * =O$PAS ! 2304: * ! 2305: * PATTERN MATCH VALUE CODE FOR LEFT OPERAND ! 2306: * VALUE CODE FOR RIGHT OPERAND ! 2307: * =O$PMV ! 2308: * ! 2309: * PATTERN REPLACEMENT NAME CODE FOR SUBJECT ! 2310: * VALUE CODE FOR PATTERN ! 2311: * =O$PMN ! 2312: * VALUE CODE FOR REPLACEMENT ! 2313: * =O$RPL ! 2314: * ! 2315: * SELECTION (FOR FIRST ALTERNATIVE) ! 2316: * =O$SLA ! 2317: * CDBLK OFFSET TO NEXT O$SLC WORD ! 2318: * VALUE CODE FOR FIRST ALTERNATIVE ! 2319: * =O$SLB ! 2320: * CDBLK OFFSET PAST ALTERNATIVES ! 2321: * ! 2322: * (FOR SUBSEQUENT ALTERNATIVES) ! 2323: * =O$SLC ! 2324: * CDBLK OFFSET TO NEXT O$SLC,O$SLD ! 2325: * VALUE CODE FOR ALTERNATIVE ! 2326: * =O$SLB ! 2327: * OFFSET IN CDBLK PAST ALTERNATIVES ! 2328: * ! 2329: * (FOR LAST ALTERNATIVE) ! 2330: * =O$SLD ! 2331: * VALUE CODE FOR LAST ALTERNATIVE ! 2332: * ! 2333: * SUBTRACTION VALUE CODE FOR LEFT OPERAND ! 2334: * VALUE CODE FOR RIGHT OPERAND ! 2335: * =O$SUB ! 2336: EJC ! 2337: * ! 2338: * CODE BLOCK (CONTINUED) ! 2339: * ! 2340: * GENERATION OF CODE BY NAME FOR EXPRESSION ELEMENTS. ! 2341: * ! 2342: * VARIABLE =O$LVN ! 2343: * POINTER TO VRBLK ! 2344: * ! 2345: * EXPRESSION (CASE OF *NATURAL VARIABLE) ! 2346: * =O$LVN ! 2347: * POINTER TO VRBLK ! 2348: * ! 2349: * (ALL OTHER CASES) ! 2350: * =O$LEX ! 2351: * POINTER TO EXBLK ! 2352: * ! 2353: * ! 2354: * ARRAY REFERENCE (CASE OF ONE SUBSCRIPT) ! 2355: * VALUE CODE FOR ARRAY OPERAND ! 2356: * VALUE CODE FOR SUBSCRIPT OPERAND ! 2357: * =O$AON ! 2358: * ! 2359: * (CASE OF MORE THAN ONE SUBSCRIPT) ! 2360: * VALUE CODE FOR ARRAY OPERAND ! 2361: * VALUE CODE FOR FIRST SUBSCRIPT ! 2362: * VALUE CODE FOR SECOND SUBSCRIPT ! 2363: * ... ! 2364: * VALUE CODE FOR LAST SUBSCRIPT ! 2365: * =O$AMN ! 2366: * NUMBER OF SUBSCRIPTS ! 2367: * ! 2368: * COMPILE ERROR =O$CER ! 2369: * ! 2370: * FUNCTION CALL (SAME CODE AS FOR VALUE CALL) ! 2371: * =O$FNE ! 2372: * ! 2373: * INDIRECTION VALUE CODE FOR OPERAND ! 2374: * =O$INN ! 2375: * ! 2376: * KEYWORD REFERENCE NAME CODE FOR OPERAND ! 2377: * =O$KWN ! 2378: * ! 2379: * ANY OTHER OPERAND IS AN ERROR IN A NAME POSITION ! 2380: * ! 2381: * NOTE THAT IN THIS DESCRIPTION, =O$XXX REFERS TO THE ! 2382: * GENERATION OF A WORD CONTAINING THE ADDRESS OF ANOTHER ! 2383: * WORD WHICH CONTAINS THE ENTRY POINT ADDRESS O$XXX. ! 2384: EJC ! 2385: * ! 2386: * CODE BLOCK (CONTINUED) ! 2387: * ! 2388: * NOW WE CONSIDER THE OVERALL STRUCTURE OF THE CODE BLOCK ! 2389: * FOR A STATEMENT WITH POSSIBLE GOTO FIELDS. ! 2390: * ! 2391: * FIRST COMES THE CODE FOR THE STATEMENT BODY. ! 2392: * THE STATEMENT BODY IS AN EXPRESSION TO BE EVALUATED ! 2393: * BY VALUE ALTHOUGH THE VALUE IS NOT ACTUALLY REQUIRED. ! 2394: * NORMAL VALUE CODE IS GENERATED FOR THE BODY OF THE ! 2395: * STATEMENT EXCEPT IN THE CASE OF A PATTERN MATCH BY ! 2396: * VALUE, IN WHICH CASE THE FOLLOWING IS GENERATED. ! 2397: * ! 2398: * VALUE CODE FOR LEFT OPERAND ! 2399: * VALUE CODE FOR RIGHT OPERAND ! 2400: * =O$PMS ! 2401: * ! 2402: * NEXT WE HAVE THE CODE FOR THE SUCCESS GOTO. THERE ARE ! 2403: * SEVERAL CASES AS FOLLOWS. ! 2404: * ! 2405: * 1) NO SUCCESS GOTO PTR TO CDBLK FOR NEXT STATEMENT ! 2406: * ! 2407: * 2) SIMPLE LABEL PTR TO VRTRA FIELD OF VRBLK ! 2408: * ! 2409: * 3) COMPLEX GOTO (CODE BY NAME FOR GOTO OPERAND) ! 2410: * =O$GOC ! 2411: * ! 2412: * 4) DIRECT GOTO (CODE BY VALUE FOR GOTO OPERAND) ! 2413: * =O$GOD ! 2414: * ! 2415: * FOLLOWING THIS WE GENERATE CODE FOR THE FAILURE GOTO IF ! 2416: * IT IS DIRECT OR IF IT IS COMPLEX, SIMPLE FAILURE GOTOS ! 2417: * HAVING BEEN HANDLED BY AN APPROPRIATE SETTING OF THE ! 2418: * CDFAL FIELD OF THE CDBLK. THE GENERATED CODE IS ONE ! 2419: * OF THE FOLLOWING. ! 2420: * ! 2421: * 1) COMPLEX FGOTO =O$FIF ! 2422: * =O$GOF ! 2423: * NAME CODE FOR GOTO OPERAND ! 2424: * =O$GOC ! 2425: * ! 2426: * 2) DIRECT FGOTO =O$FIF ! 2427: * =O$GOF ! 2428: * VALUE CODE FOR GOTO OPERAND ! 2429: * =O$GOD ! 2430: * ! 2431: * AN OPTIMIZATION OCCURS IF THE SUCCESS AND FAILURE GOTOS ! 2432: * ARE IDENTICAL AND EITHER COMPLEX OR DIRECT. IN THIS CASE, ! 2433: * NO CODE IS GENERATED FOR THE SUCCESS GOTO AND CONTROL ! 2434: * IS ALLOWED TO FALL INTO THE FAILURE GOTO ON SUCCESS. ! 2435: EJC ! 2436: * ! 2437: * COMPILER BLOCK (CMBLK) ! 2438: * ! 2439: * A COMPILER BLOCK (CMBLK) IS BUILT BY EXPAN TO REPRESENT ! 2440: * ONE NODE OF A TREE STRUCTURED EXPRESSION REPRESENTATION. ! 2441: * ! 2442: * +------------------------------------+ ! 2443: * I CMIDN I ! 2444: * +------------------------------------+ ! 2445: * I CMLEN I ! 2446: * +------------------------------------+ ! 2447: * I CMTYP I ! 2448: * +------------------------------------+ ! 2449: * I CMOPN I ! 2450: * +------------------------------------+ ! 2451: * / CMVLS OR CMROP / ! 2452: * / / ! 2453: * / CMLOP / ! 2454: * / / ! 2455: * +------------------------------------+ ! 2456: * ! 2457: CMIDN EQU 0 POINTER TO DUMMY ROUTINE B$CMT ! 2458: CMLEN EQU CMIDN+1 LENGTH OF CMBLK IN BYTES ! 2459: CMTYP EQU CMLEN+1 TYPE (C$XXX, SEE LIST BELOW) ! 2460: CMOPN EQU CMTYP+1 OPERAND POINTER (SEE BELOW) ! 2461: CMVLS EQU CMOPN+1 OPERAND VALUE POINTERS (SEE BELOW) ! 2462: CMROP EQU CMVLS RIGHT (ONLY) OPERATOR OPERAND ! 2463: CMLOP EQU CMVLS+1 LEFT OPERATOR OPERAND ! 2464: CMSI$ EQU CMVLS NUMBER OF STANDARD FIELDS IN CMBLK ! 2465: CMUS$ EQU CMSI$+1 SIZE OF UNARY OPERATOR CMBLK ! 2466: CMBS$ EQU CMSI$+2 SIZE OF BINARY OPERATOR CMBLK ! 2467: CMAR1 EQU CMVLS+1 ARRAY SUBSCRIPT POINTERS ! 2468: * ! 2469: * THE CMOPN AND CMVLS FIELDS ARE SET AS FOLLOWS ! 2470: * ! 2471: * ARRAY REFERENCE CMOPN = PTR TO ARRAY OPERAND ! 2472: * CMVLS = PTRS TO SUBSCRIPT OPERANDS ! 2473: * ! 2474: * FUNCTION CALL CMOPN = PTR TO VRBLK FOR FUNCTION ! 2475: * CMVLS = PTRS TO ARGUMENT OPERANDS ! 2476: * ! 2477: * SELECTION CMOPN = ZERO ! 2478: * CMVLS = PTRS TO ALTERNATE OPERANDS ! 2479: * ! 2480: * UNARY OPERATOR CMOPN = PTR TO OPERATOR DVBLK ! 2481: * CMROP = PTR TO OPERAND ! 2482: * ! 2483: * BINARY OPERATOR CMOPN = PTR TO OPERATOR DVBLK ! 2484: * CMROP = PTR TO RIGHT OPERAND ! 2485: * CMLOP = PTR TO LEFT OPERAND ! 2486: EJC ! 2487: * ! 2488: * CMTYP IS SET TO INDICATE THE TYPE OF EXPRESSION ELEMENT ! 2489: * AS SHOWN BY THE FOLLOWING TABLE OF DEFINITIONS. ! 2490: * ! 2491: C$ARR EQU 0 ARRAY REFERENCE ! 2492: C$FNC EQU C$ARR+1 FUNCTION CALL ! 2493: C$DEF EQU C$FNC+1 DEFERRED EXPRESSION (UNARY *) ! 2494: C$IND EQU C$DEF+1 INDIRECTION (UNARY $) ! 2495: C$KEY EQU C$IND+1 KEYWORD REFERENCE (UNARY AMPERSAND) ! 2496: C$UBO EQU C$KEY+1 UNDEFINED BINARY OPERATOR ! 2497: C$UUO EQU C$UBO+1 UNDEFINED UNARY OPERATOR ! 2498: C$UO$ EQU C$UUO+1 TEST VALUE (=C$UUO+1=C$UBO+2) ! 2499: C$$NM EQU C$UUO+1 NUMBER OF CODES FOR NAME OPERANDS ! 2500: * ! 2501: * THE REMAINING TYPES INDICATE EXPRESSION ELEMENTS WHICH ! 2502: * CAN ONLY BE EVALUATED BY VALUE (NOT BY NAME). ! 2503: * ! 2504: C$BVL EQU C$UUO+1 BINARY OP WITH VALUE OPERANDS ! 2505: C$UVL EQU C$BVL+1 UNARY OPERATOR WITH VALUE OPERAND ! 2506: C$ALT EQU C$UVL+1 ALTERNATION (BINARY BAR) ! 2507: C$CNC EQU C$ALT+1 CONCATENATION ! 2508: C$CNP EQU C$CNC+1 CONCATENATION, NOT PATTERN MATCH ! 2509: C$UNM EQU C$CNP+1 UNARY OP WITH NAME OPERAND ! 2510: C$BVN EQU C$UNM+1 BINARY OP (OPERANDS BY VALUE, NAME) ! 2511: C$ASS EQU C$BVN+1 ASSIGNMENT ! 2512: C$INT EQU C$ASS+1 INTERROGATION ! 2513: C$NEG EQU C$INT+1 NEGATION (UNARY NOT) ! 2514: C$SEL EQU C$NEG+1 SELECTION ! 2515: C$PMT EQU C$SEL+1 PATTERN MATCH ! 2516: * ! 2517: C$PR$ EQU C$BVN LAST PREEVALUABLE CODE ! 2518: C$$NV EQU C$PMT+1 NUMBER OF DIFFERENT CMBLK TYPES ! 2519: EJC ! 2520: * ! 2521: * CHARACTER TABLE BLOCK (CTBLK) ! 2522: * ! 2523: * A CHARACTER TABLE BLOCK IS USED TO HOLD LOGICAL CHARACTER ! 2524: * TABLES FOR USE WITH ANY,NOTANY,SPAN,BREAK,BREAKX ! 2525: * PATTERNS. EACH CHARACTER TABLE CAN BE USED TO STORE ! 2526: * CFP$N DISTINCT TABLES AS BIT COLUMNS. A BIT COLUMN ! 2527: * ALLOCATED FOR EACH ARGUMENT OF MORE THAN ONE CHARACTER ! 2528: * IN LENGTH TO ONE OF THE ABOVE LISTED PATTERN PRIMITIVES. ! 2529: * ! 2530: * +------------------------------------+ ! 2531: * I CTTYP I ! 2532: * +------------------------------------+ ! 2533: * * * ! 2534: * * * ! 2535: * * CTCHS * ! 2536: * * * ! 2537: * * * ! 2538: * +------------------------------------+ ! 2539: * ! 2540: CTTYP EQU 0 POINTER TO DUMMY ROUTINE B$CTT ! 2541: CTCHS EQU CTTYP+1 START OF CHARACTER TABLE WORDS ! 2542: CTSI$ EQU CTCHS+CFP$A NUMBER OF WORDS IN CTBLK ! 2543: * ! 2544: * CTCHS IS CFP$A WORDS LONG AND CONSISTS OF A ONE WORD ! 2545: * BIT STRING VALUE FOR EACH POSSIBLE CHARACTER IN THE ! 2546: * INTERNAL ALPHABET. EACH OF THE CFP$N POSSIBLE BITS IN ! 2547: * A BITSTRING IS USED TO FORM A COLUMN OF BIT INDICATORS. ! 2548: * A BIT IS SET ON IF THE CHARACTER IS IN THE TABLE AND OFF ! 2549: * IF THE CHARACTER IS NOT PRESENT. ! 2550: EJC ! 2551: * ! 2552: * DATATYPE FUNCTION BLOCK (DFBLK) ! 2553: * ! 2554: * A DATATYPE FUNCTION IS USED TO CONTROL THE CONSTRUCTION ! 2555: * OF A PROGRAM DEFINED DATATYPE OBJECT. A CALL TO THE ! 2556: * SYSTEM FUNCTION DATA BUILDS A DFBLK FOR THE DATATYPE NAME ! 2557: * ! 2558: * NOTE THAT THESE BLOCKS ARE BUILT IN STATIC BECAUSE PDBLK ! 2559: * LENGTH IS GOT FROM DFLEN FIELD. IF DFBLK WAS IN DYNAMIC ! 2560: * STORE THIS WOULD CAUSE TROUBLE DURING PASS TWO OF GARBAGE ! 2561: * COLLECTION. SCBLK REFERRED TO BY DFNAM FIELD IS ALSO PUT ! 2562: * IN STATIC SO THAT THERE ARE NO RELOC. FIELDS. THIS CUTS ! 2563: * GARBAGE COLLECTION TASK APPRECIABLY FOR PDBLKS WHICH ARE ! 2564: * LIKELY TO BE PRESENT IN LARGE NUMBERS. ! 2565: * ! 2566: * +------------------------------------+ ! 2567: * I FCODE I ! 2568: * +------------------------------------+ ! 2569: * I FARGS I ! 2570: * +------------------------------------+ ! 2571: * I DFLEN I ! 2572: * +------------------------------------+ ! 2573: * I DFPDL I ! 2574: * +------------------------------------+ ! 2575: * I DFNAM I ! 2576: * +------------------------------------+ ! 2577: * / / ! 2578: * / DFFLD / ! 2579: * / / ! 2580: * +------------------------------------+ ! 2581: * ! 2582: DFLEN EQU FARGS+1 LENGTH OF DFBLK IN BYTES ! 2583: DFPDL EQU DFLEN+1 LENGTH OF CORRESPONDING PDBLK ! 2584: DFNAM EQU DFPDL+1 POINTER TO SCBLK FOR DATATYPE NAME ! 2585: DFFLD EQU DFNAM+1 START OF VRBLK PTRS FOR FIELD NAMES ! 2586: DFFLB EQU DFFLD-1 OFFSET BEHIND DFFLD FOR FIELD FUNC ! 2587: DFSI$ EQU DFFLD NUMBER OF STANDARD FIELDS IN DFBLK ! 2588: * ! 2589: * THE FCODE FIELD POINTS TO THE ROUTINE B$DFC ! 2590: * ! 2591: * FARGS (THE NUMBER OF ARGUMENTS) IS THE NUMBER OF FIELDS. ! 2592: EJC ! 2593: * ! 2594: * DOPE VECTOR BLOCK (DVBLK) ! 2595: * ! 2596: * A DOPE VECTOR IS ASSEMBLED FOR EACH POSSIBLE OPERATOR IN ! 2597: * THE SNOBOL4 LANGUAGE AS PART OF THE CONSTANT SECTION. ! 2598: * ! 2599: * +------------------------------------+ ! 2600: * I DVOPN I ! 2601: * +------------------------------------+ ! 2602: * I DVTYP I ! 2603: * +------------------------------------+ ! 2604: * I DVLPR I ! 2605: * +------------------------------------+ ! 2606: * I DVRPR I ! 2607: * +------------------------------------+ ! 2608: * ! 2609: DVOPN EQU 0 ENTRY ADDRESS (PTR TO O$XXX) ! 2610: DVTYP EQU DVOPN+1 TYPE CODE (C$XXX, SEE CMBLK) ! 2611: DVLPR EQU DVTYP+1 LEFT PRECEDENCE (LLXXX, SEE BELOW) ! 2612: DVRPR EQU DVLPR+1 RIGHT PRECEDENCE (RRXXX, SEE BELOW) ! 2613: DVUS$ EQU DVLPR+1 SIZE OF UNARY OPERATOR DV ! 2614: DVBS$ EQU DVRPR+1 SIZE OF BINARY OPERATOR DV ! 2615: DVUBS EQU DVUS$+DVBS$ SIZE OF UNOP + BINOP (SEE SCANE) ! 2616: * ! 2617: * THE CONTENTS OF THE DVTYP FIELD IS COPIED INTO THE CMTYP ! 2618: * FIELD OF THE CMBLK FOR THE OPERATOR IF IT IS USED. ! 2619: * ! 2620: * THE CMOPN FIELD OF AN OPERATOR CMBLK POINTS TO THE DVBLK ! 2621: * ITSELF, PROVIDING THE REQUIRED ENTRY ADDRESS POINTER PTR. ! 2622: * ! 2623: * FOR NORMALLY UNDEFINED OPERATORS, THE DVOPN (AND CMOPN) ! 2624: * FIELDS CONTAIN A WORD OFFSET FROM R$UBA OF THE FUNCTION ! 2625: * BLOCK POINTER FOR THE OPERATOR (INSTEAD OF O$XXX PTR). ! 2626: * FOR CERTAIN SPECIAL OPERATORS, THE DVOPN FIELD IS NOT ! 2627: * REQUIRED AT ALL AND IS ASSEMBLED AS ZERO. ! 2628: * ! 2629: * THE LEFT PRECEDENCE IS USED IN COMPARING AN OPERATOR TO ! 2630: * THE LEFT OF SOME OTHER OPERATOR. IT THEREFORE GOVERNS THE ! 2631: * PRECEDENCE OF THE OPERATOR TOWARDS ITS RIGHT OPERAND. ! 2632: * ! 2633: * THE RIGHT PRECEDENCE IS USED IN COMPARING AN OPERATOR TO ! 2634: * THE RIGHT OF SOME OTHER OPERATOR. IT THEREFORE GOVERNS ! 2635: * THE PRECEDENCE OF THE OPERATOR TOWARDS ITS LEFT OPERAND. ! 2636: * ! 2637: * HIGHER PRECEDENCE VALUES CORRESPOND TO A TIGHTER BINDING ! 2638: * CAPABILITY. THUS WE HAVE THE LEFT PRECEDENCE LOWER ! 2639: * (HIGHER) THAN THE RIGHT PRECEDENCE FOR RIGHT (LEFT) ! 2640: * ASSOCIATIVE BINARY OPERATORS. ! 2641: * ! 2642: * THE LEFT PRECEDENCE OF UNARY OPERATORS IS SET TO AN ! 2643: * ARBITRARY HIGH VALUE. THE RIGHT VALUE IS NOT REQUIRED AND ! 2644: * CONSEQUENTLY THE DVRPR FIELD IS OMITTED FOR UNARY OPS. ! 2645: EJC ! 2646: * ! 2647: * TABLE OF OPERATOR PRECEDENCE VALUES ! 2648: * ! 2649: RRASS EQU 10 RIGHT EQUAL ! 2650: LLASS EQU 00 LEFT EQUAL ! 2651: RRPMT EQU 20 RIGHT QUESTION MARK ! 2652: LLPMT EQU 30 LEFT QUESTION MARK ! 2653: RRAMP EQU 40 RIGHT AMPERSAND ! 2654: LLAMP EQU 50 LEFT AMPERSAND ! 2655: RRALT EQU 70 RIGHT VERTICAL BAR ! 2656: LLALT EQU 60 LEFT VERTICAL BAR ! 2657: RRCNC EQU 90 RIGHT BLANK ! 2658: LLCNC EQU 80 LEFT BLANK ! 2659: RRATS EQU 110 RIGHT AT ! 2660: LLATS EQU 100 LEFT AT ! 2661: RRPLM EQU 120 RIGHT PLUS, MINUS ! 2662: LLPLM EQU 130 LEFT PLUS, MINUS ! 2663: RRNUM EQU 140 RIGHT NUMBER ! 2664: LLNUM EQU 150 LEFT NUMBER ! 2665: RRDVD EQU 160 RIGHT SLASH ! 2666: LLDVD EQU 170 LEFT SLASH ! 2667: RRMLT EQU 180 RIGHT ASTERISK ! 2668: LLMLT EQU 190 LEFT ASTERISK ! 2669: RRPCT EQU 200 RIGHT PERCENT ! 2670: LLPCT EQU 210 LEFT PERCENT ! 2671: RREXP EQU 230 RIGHT EXCLAMATION ! 2672: LLEXP EQU 220 LEFT EXCLAMATION ! 2673: RRDLD EQU 240 RIGHT DOLLAR, DOT ! 2674: LLDLD EQU 250 LEFT DOLLAR, DOT ! 2675: RRNOT EQU 270 RIGHT NOT ! 2676: LLNOT EQU 260 LEFT NOT ! 2677: LLUNO EQU 999 LEFT ALL UNARY OPERATORS ! 2678: * ! 2679: * PRECEDENCES ARE THE SAME AS IN BTL SNOBOL4 WITH THE ! 2680: * FOLLOWING EXCEPTIONS. ! 2681: * ! 2682: * 1) BINARY QUESTION MARK IS LOWERED AND MADE LEFT ASSOC- ! 2683: * IATIVE TO REFLECT ITS NEW USE FOR PATTERN MATCHING. ! 2684: * ! 2685: * 2) ALTERNATION AND CONCATENATION ARE MADE RIGHT ! 2686: * ASSOCIATIVE FOR GREATER EFFICIENCY IN PATTERN ! 2687: * CONSTRUCTION AND MATCHING RESPECTIVELY. THIS CHANGE ! 2688: * IS TRANSPARENT TO THE SNOBOL4 PROGRAMMER. ! 2689: * ! 2690: * 3) THE EQUAL SIGN HAS BEEN ADDED AS A LOW PRECEDENCE ! 2691: * OPERATOR WHICH IS RIGHT ASSOCIATIVE TO REFLECT ITS ! 2692: * MORE GENERAL USAGE IN THIS VERSION OF SNOBOL4. ! 2693: EJC ! 2694: * ! 2695: * EXTERNAL FUNCTION BLOCK (EFBLK) ! 2696: * ! 2697: * AN EXTERNAL FUNCTION BLOCK IS USED TO CONTROL THE CALLING ! 2698: * OF AN EXTERNAL FUNCTION. IT IS BUILT BY A CALL TO LOAD. ! 2699: * ! 2700: * +------------------------------------+ ! 2701: * I FCODE I ! 2702: * +------------------------------------+ ! 2703: * I FARGS I ! 2704: * +------------------------------------+ ! 2705: * I EFLEN I ! 2706: * +------------------------------------+ ! 2707: * I EFUSE I ! 2708: * +------------------------------------+ ! 2709: * I EFCOD I ! 2710: * +------------------------------------+ ! 2711: * I EFVAR I ! 2712: * +------------------------------------+ ! 2713: * I EFRSL I ! 2714: * +------------------------------------+ ! 2715: * / / ! 2716: * / EFTAR / ! 2717: * / / ! 2718: * +------------------------------------+ ! 2719: * ! 2720: EFLEN EQU FARGS+1 LENGTH OF EFBLK IN BYTES ! 2721: EFUSE EQU EFLEN+1 USE COUNT (FOR OPSYN) ! 2722: EFCOD EQU EFUSE+1 PTR TO CODE (FROM SYSLD) ! 2723: EFVAR EQU EFCOD+1 PTR TO ASSOCIATED VRBLK ! 2724: EFRSL EQU EFVAR+1 RESULT TYPE (SEE BELOW) ! 2725: EFTAR EQU EFRSL+1 ARGUMENT TYPES (SEE BELOW) ! 2726: EFSI$ EQU EFTAR NUMBER OF STANDARD FIELDS IN EFBLK ! 2727: * ! 2728: * THE FCODE FIELD POINTS TO THE ROUTINE B$EFC. ! 2729: * ! 2730: * EFUSE IS USED TO KEEP TRACK OF MULTIPLE USE WHEN OPSYN ! 2731: * IS EMPLOYED. THE FUNCTION IS AUTOMATICALLY UNLOADED ! 2732: * WHEN THERE ARE NO MORE REFERENCES TO THE FUNCTION. ! 2733: * ! 2734: * EFRSL AND EFTAR ARE TYPE CODES AS FOLLOWS. ! 2735: * ! 2736: * 0 TYPE IS UNCONVERTED ! 2737: * 1 TYPE IS STRING ! 2738: * 2 TYPE IS INTEGER ! 2739: * 3 TYPE IS REAL ! 2740: EJC ! 2741: * ! 2742: * EXPRESSION VARIABLE BLOCK (EVBLK) ! 2743: * ! 2744: * IN THIS VERSION OF SPITBOL, AN EXPRESSION CAN BE USED IN ! 2745: * ANY POSITION WHICH WOULD NORMALLY EXPECT A NAME (FOR ! 2746: * EXAMPLE ON THE LEFT SIDE OF EQUALS OR AS THE RIGHT ! 2747: * ARGUMENT OF BINARY DOT). THIS CORRESPONDS TO THE CREATION ! 2748: * OF A PSEUDO-VARIABLE WHICH IS REPRESENTED BY A POINTER TO ! 2749: * AN EXPRESSION VARIABLE BLOCK AS FOLLOWS. ! 2750: * ! 2751: * +------------------------------------+ ! 2752: * I EVTYP I ! 2753: * +------------------------------------+ ! 2754: * I EVEXP I ! 2755: * +------------------------------------+ ! 2756: * I EVVAR I ! 2757: * +------------------------------------+ ! 2758: * ! 2759: EVTYP EQU 0 POINTER TO DUMMY ROUTINE B$EVT ! 2760: EVEXP EQU EVTYP+1 POINTER TO EXBLK FOR EXPRESSION ! 2761: EVVAR EQU EVEXP+1 POINTER TO TRBEV DUMMY TRBLK ! 2762: EVSI$ EQU EVVAR+1 SIZE OF EVBLK ! 2763: * ! 2764: * THE NAME OF AN EXPRESSION VARIABLE IS REPRESENTED BY A ! 2765: * BASE POINTER TO THE EVBLK AND AN OFFSET OF EVVAR. THIS ! 2766: * VALUE APPEARS TO BE TRAPPED BY THE DUMMY TRBEV BLOCK. ! 2767: * ! 2768: * NOTE THAT THERE IS NO NEED TO ALLOW FOR THE CASE OF AN ! 2769: * EXPRESSION VARIABLE WHICH REFERENCES AN SEBLK SINCE A ! 2770: * VARIABLE WHICH IS OF THE FORM *VAR IS EQUIVALENT TO VAR. ! 2771: EJC ! 2772: * ! 2773: * EXPRESSION BLOCK (EXBLK) ! 2774: * ! 2775: * AN EXPRESSION BLOCK IS BUILT FOR EACH EXPRESSION ! 2776: * REFERENCED IN A PROGRAM OR CREATED BY EVAL OR CONVERT ! 2777: * DURING EXECUTION OF A PROGRAM. ! 2778: * ! 2779: * +------------------------------------+ ! 2780: * I EXTYP I ! 2781: * +------------------------------------+ ! 2782: * I EXSTM I ! 2783: * +------------------------------------+ ! 2784: * I EXLEN I ! 2785: * +------------------------------------+ ! 2786: * I EXFLC I ! 2787: * +------------------------------------+ ! 2788: * / / ! 2789: * / EXCOD / ! 2790: * / / ! 2791: * +------------------------------------+ ! 2792: * ! 2793: EXTYP EQU 0 PTR TO ROUTINE B$EXL TO LOAD EXPR ! 2794: EXSTM EQU CDSTM STORES STMNT NO. DURING EVALUATION ! 2795: EXLEN EQU EXSTM+1 LENGTH OF EXBLK IN BYTES ! 2796: EXFLC EQU EXLEN+1 FAILURE CODE (=O$FEX) ! 2797: EXCOD EQU EXFLC+1 PSEUDO-CODE FOR EXPRESSION ! 2798: EXSI$ EQU EXCOD NUMBER OF STANDARD FIELDS IN EXBLK ! 2799: * ! 2800: * THERE ARE TWO CASES FOR EXCOD DEPENDING ON WHETHER THE ! 2801: * EXPRESSION CAN BE EVALUATED BY NAME (SEE DESCRIPTION ! 2802: * OF CDBLK FOR DETAILS OF CODE FOR EXPRESSIONS). ! 2803: * ! 2804: * IF THE EXPRESSION CAN BE EVALUATED BY NAME WE HAVE. ! 2805: * ! 2806: * (CODE FOR EXPR BY NAME) ! 2807: * =O$RNM ! 2808: * ! 2809: * IF THE EXPRESSION CAN ONLY BE EVALUATED BY VALUE. ! 2810: * ! 2811: * (CODE FOR EXPR BY VALUE) ! 2812: * =O$RVL ! 2813: EJC ! 2814: * ! 2815: * FIELD FUNCTION BLOCK (FFBLK) ! 2816: * ! 2817: * A FIELD FUNCTION BLOCK IS USED TO CONTROL THE SELECTION ! 2818: * OF A FIELD FROM A PROGRAM DEFINED DATATYPE BLOCK. ! 2819: * A CALL TO DATA CREATES AN FFBLK FOR EACH FIELD. ! 2820: * ! 2821: * +------------------------------------+ ! 2822: * I FCODE I ! 2823: * +------------------------------------+ ! 2824: * I FARGS I ! 2825: * +------------------------------------+ ! 2826: * I FFDFP I ! 2827: * +------------------------------------+ ! 2828: * I FFNXT I ! 2829: * +------------------------------------+ ! 2830: * I FFOFS I ! 2831: * +------------------------------------+ ! 2832: * ! 2833: FFDFP EQU FARGS+1 POINTER TO ASSOCIATED DFBLK ! 2834: FFNXT EQU FFDFP+1 PTR TO NEXT FFBLK ON CHAIN OR ZERO ! 2835: FFOFS EQU FFNXT+1 OFFSET (BYTES) TO FIELD IN PDBLK ! 2836: FFSI$ EQU FFOFS+1 SIZE OF FFBLK IN WORDS ! 2837: * ! 2838: * THE FCODE FIELD POINTS TO THE ROUTINE B$FFC. ! 2839: * ! 2840: * FARGS ALWAYS CONTAINS ONE. ! 2841: * ! 2842: * FFDFP IS USED TO VERIFY THAT THE CORRECT PROGRAM DEFINED ! 2843: * DATATYPE IS BEING ACCESSED BY THIS CALL. ! 2844: * FFDFP IS NON-RELOC. BECAUSE DFBLK IS IN STATIC ! 2845: * ! 2846: * FFOFS IS USED TO SELECT THE APPROPRIATE FIELD. NOTE THAT ! 2847: * IT IS AN ACTUAL OFFSET (NOT A FIELD NUMBER) ! 2848: * ! 2849: * FFNXT IS USED TO POINT TO THE NEXT FFBLK OF THE SAME NAME ! 2850: * IN THE CASE WHERE THERE ARE SEVERAL FIELDS OF THE SAME ! 2851: * NAME FOR DIFFERENT DATATYPES. ZERO MARKS THE END OF CHAIN ! 2852: EJC ! 2853: * ! 2854: * INTEGER CONSTANT BLOCK (ICBLK) ! 2855: * ! 2856: * AN ICBLK IS CREATED FOR EVERY INTEGER REFERENCED OR ! 2857: * CREATED BY A PROGRAM. NOTE HOWEVER THAT CERTAIN INTERNAL ! 2858: * INTEGER VALUES ARE STORED AS ADDRESSES (E.G. THE LENGTH ! 2859: * FIELD IN A STRING CONSTANT BLOCK) ! 2860: * ! 2861: * +------------------------------------+ ! 2862: * I ICGET I ! 2863: * +------------------------------------+ ! 2864: * * ICVAL * ! 2865: * +------------------------------------+ ! 2866: * ! 2867: ICGET EQU 0 PTR TO ROUTINE B$ICL TO LOAD INT ! 2868: ICVAL EQU ICGET+1 INTEGER VALUE ! 2869: ICSI$ EQU ICVAL+CFP$I SIZE OF ICBLK ! 2870: * ! 2871: * THE LENGTH OF THE ICVAL FIELD IS CFP$I. ! 2872: EJC ! 2873: * ! 2874: * KEYWORD VARIABLE BLOCK (KVBLK) ! 2875: * ! 2876: * A KVBLK IS USED TO REPRESENT A KEYWORD PSEUDO-VARIABLE. ! 2877: * A KVBLK IS BUILT FOR EACH KEYWORD REFERENCE (KWNAM). ! 2878: * ! 2879: * +------------------------------------+ ! 2880: * I KVTYP I ! 2881: * +------------------------------------+ ! 2882: * I KVVAR I ! 2883: * +------------------------------------+ ! 2884: * I KVNUM I ! 2885: * +------------------------------------+ ! 2886: * ! 2887: KVTYP EQU 0 POINTER TO DUMMY ROUTINE B$KVT ! 2888: KVVAR EQU KVTYP+1 POINTER TO DUMMY BLOCK TRBKV ! 2889: KVNUM EQU KVVAR+1 KEYWORD NUMBER ! 2890: KVSI$ EQU KVNUM+1 SIZE OF KVBLK ! 2891: * ! 2892: * THE NAME OF A KEYWORD VARIABLE IS REPRESENTED BY A ! 2893: * BASE POINTER TO THE KVBLK AND AN OFFSET OF KVVAR. THE ! 2894: * VALUE APPEARS TO BE TRAPPED BY THE POINTER TO TRBKV. ! 2895: EJC ! 2896: * ! 2897: * NAME BLOCK (NMBLK) ! 2898: * ! 2899: * A NAME BLOCK IS USED WHEREVER A NAME MUST BE STORED AS ! 2900: * A VALUE FOLLOWING USE OF THE UNARY DOT OPERATOR. ! 2901: * ! 2902: * +------------------------------------+ ! 2903: * I NMTYP I ! 2904: * +------------------------------------+ ! 2905: * I NMBAS I ! 2906: * +------------------------------------+ ! 2907: * I NMOFS I ! 2908: * +------------------------------------+ ! 2909: * ! 2910: NMTYP EQU 0 PTR TO ROUTINE B$NML TO LOAD NAME ! 2911: NMBAS EQU NMTYP+1 BASE POINTER FOR VARIABLE ! 2912: NMOFS EQU NMBAS+1 OFFSET FOR VARIABLE ! 2913: NMSI$ EQU NMOFS+1 SIZE OF NMBLK ! 2914: * ! 2915: * THE ACTUAL FIELD REPRESENTING THE CONTENTS OF THE NAME ! 2916: * IS FOUND NMOFS BYTES PAST THE ADDRESS IN NMBAS. ! 2917: * ! 2918: * THE NAME IS SPLIT INTO BASE AND OFFSET FORM TO AVOID ! 2919: * CREATION OF A POINTER INTO THE MIDDLE OF A BLOCK WHICH ! 2920: * COULD NOT BE HANDLED PROPERLY BY THE GARBAGE COLLECTOR. ! 2921: * ! 2922: * A NAME MAY BE BUILT FOR ANY VARIABLE (SEE SECTION ON ! 2923: * REPRESENTATIONS OF VARIABLES) THIS INCLUDES THE ! 2924: * CASES OF PSEUDO-VARIABLES. ! 2925: EJC ! 2926: * ! 2927: * PATTERN BLOCK, NO PARAMETERS (P0BLK) ! 2928: * ! 2929: * A P0BLK IS USED TO REPRESENT PATTERN NODES WHICH DO ! 2930: * NOT REQUIRE THE USE OF ANY PARAMETER VALUES. ! 2931: * ! 2932: * +------------------------------------+ ! 2933: * I PCODE I ! 2934: * +------------------------------------+ ! 2935: * I PTHEN I ! 2936: * +------------------------------------+ ! 2937: * ! 2938: PCODE EQU 0 PTR TO MATCH ROUTINE (P$XXX) ! 2939: PTHEN EQU PCODE+1 POINTER TO SUBSEQUENT NODE ! 2940: PASI$ EQU PTHEN+1 SIZE OF P0BLK ! 2941: * ! 2942: * PTHEN POINTS TO THE PATTERN BLOCK FOR THE SUBSEQUENT ! 2943: * NODE TO BE MATCHED. THIS IS A POINTER TO THE PATTERN ! 2944: * BLOCK NDNTH IF THERE IS NO SUBSEQUENT (END OF PATTERN) ! 2945: * ! 2946: * PCODE IS A POINTER TO THE MATCH ROUTINE FOR THE NODE. ! 2947: EJC ! 2948: * ! 2949: * PATTERN BLOCK (ONE PARAMETER) ! 2950: * ! 2951: * A P1BLK IS USED TO REPRESENT PATTERN NODES WHICH ! 2952: * REQUIRE ONE PARAMETER VALUE. ! 2953: * ! 2954: * +------------------------------------+ ! 2955: * I PCODE I ! 2956: * +------------------------------------+ ! 2957: * I PTHEN I ! 2958: * +------------------------------------+ ! 2959: * I PARM1 I ! 2960: * +------------------------------------+ ! 2961: * ! 2962: PARM1 EQU PTHEN+1 FIRST PARAMETER VALUE ! 2963: PBSI$ EQU PARM1+1 SIZE OF P1BLK IN WORDS ! 2964: * ! 2965: * SEE P0BLK FOR DEFINITIONS OF PCODE, PTHEN ! 2966: * ! 2967: * PARM1 CONTAINS A PARAMETER VALUE USED IN MATCHING THE ! 2968: * NODE. FOR EXAMPLE, IN A LEN PATTERN, IT IS THE INTEGER ! 2969: * ARGUMENT TO LEN. THE DETAILS OF THE USE OF THE PARAMETER ! 2970: * FIELD ARE INCLUDED IN THE DESCRIPTION OF THE INDIVIDUAL ! 2971: * MATCH ROUTINES. PARM1 IS ALWAYS AN ADDRESS POINTER WHICH ! 2972: * IS PROCESSED BY THE GARBAGE COLLECTOR. ! 2973: EJC ! 2974: * ! 2975: * PATTERN BLOCK (TWO PARAMETERS) ! 2976: * ! 2977: * A P2BLK IS USED TO REPRESENT PATTERN NODES WHICH ! 2978: * REQUIRE TWO PARAMETER VALUES. ! 2979: * ! 2980: * +------------------------------------+ ! 2981: * I PCODE I ! 2982: * +------------------------------------+ ! 2983: * I PTHEN I ! 2984: * +------------------------------------+ ! 2985: * I PARM1 I ! 2986: * +------------------------------------+ ! 2987: * I PARM2 I ! 2988: * +------------------------------------+ ! 2989: * ! 2990: PARM2 EQU PARM1+1 SECOND PARAMETER VALUE ! 2991: PCSI$ EQU PARM2+1 SIZE OF P2BLK IN WORDS ! 2992: * ! 2993: * SEE P1BLK FOR DEFINITIONS OF PCODE, PTHEN, PARM1 ! 2994: * ! 2995: * PARM2 IS A PARAMETER WHICH PERFORMS THE SAME SORT OF ! 2996: * FUNCTION AS PARM1 (SEE DESCRIPTION OF P1BLK). ! 2997: * ! 2998: * PARM2 IS A NON-RELOCATABLE FIELD AND IS NOT ! 2999: * PROCESSED BY THE GARBAGE COLLECTOR. ACCORDINGLY, IT MAY ! 3000: * NOT CONTAIN A POINTER TO A BLOCK IN DYNAMIC MEMORY. ! 3001: EJC ! 3002: * ! 3003: * PROGRAM-DEFINED DATATYPE BLOCK ! 3004: * ! 3005: * A PDBLK REPRESENTS THE DATA ITEM FORMED BY A CALL TO A ! 3006: * DATATYPE FUNCTION AS DEFINED BY THE SYSTEM FUNCTION DATA. ! 3007: * ! 3008: * +------------------------------------+ ! 3009: * I PDTYP I ! 3010: * +------------------------------------+ ! 3011: * I IDVAL I ! 3012: * +------------------------------------+ ! 3013: * I PDDFP I ! 3014: * +------------------------------------+ ! 3015: * / / ! 3016: * / PDFLD / ! 3017: * / / ! 3018: * +------------------------------------+ ! 3019: * ! 3020: PDTYP EQU 0 PTR TO DUMMY ROUTINE B$PDT ! 3021: PDDFP EQU IDVAL+1 PTR TO ASSOCIATED DFBLK ! 3022: PDFLD EQU PDDFP+1 START OF FIELD VALUE POINTERS ! 3023: PDFOF EQU DFFLD-PDFLD DIFFERENCE IN OFFSET TO FIELD PTRS ! 3024: PDSI$ EQU PDFLD SIZE OF STANDARD FIELDS IN PDBLK ! 3025: PDDFS EQU DFSI$-PDSI$ DIFFERENCE IN DFBLK, PDBLK SIZES ! 3026: * ! 3027: * THE PDDFP POINTER MAY BE USED TO DETERMINE THE DATATYPE ! 3028: * AND THE NAMES OF THE FIELDS IF REQUIRED. THE DFBLK ALSO ! 3029: * CONTAINS THE LENGTH OF THE PDBLK IN BYTES (FIELD DFPDL). ! 3030: * PDDFP IS NON-RELOC. BECAUSE DFBLK IS IN STATIC ! 3031: * ! 3032: * PDFLD VALUES ARE STORED IN ORDER FROM LEFT TO RIGHT. ! 3033: * THEY CONTAIN VALUES OR POINTERS TO TRBLK CHAINS. ! 3034: EJC ! 3035: * ! 3036: * PROGRAM DEFINED FUNCTION BLOCK (PFBLK) ! 3037: * ! 3038: * A PFBLK IS CREATED FOR EACH CALL TO THE DEFINE FUNCTION ! 3039: * AND A POINTER TO THE PFBLK PLACED IN THE PROPER VRBLK. ! 3040: * ! 3041: * +------------------------------------+ ! 3042: * I FCODE I ! 3043: * +------------------------------------+ ! 3044: * I FARGS I ! 3045: * +------------------------------------+ ! 3046: * I PFLEN I ! 3047: * +------------------------------------+ ! 3048: * I PFVBL I ! 3049: * +------------------------------------+ ! 3050: * I PFNLO I ! 3051: * +------------------------------------+ ! 3052: * I PFCOD I ! 3053: * +------------------------------------+ ! 3054: * I PFCTR I ! 3055: * +------------------------------------+ ! 3056: * I PFRTR I ! 3057: * +------------------------------------+ ! 3058: * / / ! 3059: * / PFARG / ! 3060: * / / ! 3061: * +------------------------------------+ ! 3062: * ! 3063: PFLEN EQU FARGS+1 LENGTH OF PFBLK IN BYTES ! 3064: PFVBL EQU PFLEN+1 POINTER TO VRBLK FOR FUNCTION NAME ! 3065: PFNLO EQU PFVBL+1 NUMBER OF LOCALS ! 3066: PFCOD EQU PFNLO+1 PTR TO CDBLK FOR FIRST STATEMENT ! 3067: PFCTR EQU PFCOD+1 TRBLK PTR IF CALL TRACED ELSE 0 ! 3068: PFRTR EQU PFCTR+1 TRBLK PTR IF RETURN TRACED ELSE 0 ! 3069: PFARG EQU PFRTR+1 VRBLK PTRS FOR ARGUMENTS AND LOCALS ! 3070: PFAGB EQU PFARG-1 OFFSET BEHIND PFARG FOR ARG, LOCAL ! 3071: PFSI$ EQU PFARG NUMBER OF STANDARD FIELDS IN PFBLK ! 3072: * ! 3073: * THE FCODE FIELD POINTS TO THE ROUTINE B$PFC. ! 3074: * ! 3075: * PFARG IS STORED IN THE FOLLOWING ORDER. ! 3076: * ! 3077: * ARGUMENTS (LEFT TO RIGHT) ! 3078: * LOCALS (LEFT TO RIGHT) ! 3079: EJC ! 3080: * ! 3081: * REAL CONSTANT BLOCK (RCBLK) ! 3082: * ! 3083: * AN RCBLK IS CREATED FOR EVERY REAL REFERENCED OR ! 3084: * CREATED BY A PROGRAM. ! 3085: * ! 3086: * +------------------------------------+ ! 3087: * I RCGET I ! 3088: * +------------------------------------+ ! 3089: * * RCVAL * ! 3090: * +------------------------------------+ ! 3091: * ! 3092: RCGET EQU 0 PTR TO ROUTINE B$RCL TO LOAD REAL ! 3093: RCVAL EQU RCGET+1 REAL VALUE ! 3094: RCSI$ EQU RCVAL+CFP$R SIZE OF RCBLK ! 3095: * ! 3096: * THE LENGTH OF THE RCVAL FIELD IS CFP$R. ! 3097: EJC ! 3098: * ! 3099: * STRING CONSTANT BLOCK (SCBLK) ! 3100: * ! 3101: * AN SCBLK IS BUILT FOR EVERY STRING REFERENCED OR CREATED ! 3102: * BY A PROGRAM. ! 3103: * ! 3104: * +------------------------------------+ ! 3105: * I SCGET I ! 3106: * +------------------------------------+ ! 3107: * I SCLEN I ! 3108: * +------------------------------------+ ! 3109: * / / ! 3110: * / SCHAR / ! 3111: * / / ! 3112: * +------------------------------------+ ! 3113: * ! 3114: SCGET EQU 0 PTR TO ROUTINE B$SCL TO LOAD STRING ! 3115: SCLEN EQU SCGET+1 LENGTH OF STRING IN CHARACTERS ! 3116: SCHAR EQU SCLEN+1 CHARACTERS OF STRING ! 3117: SCSI$ EQU SCHAR SIZE OF STANDARD FIELDS IN SCBLK ! 3118: * ! 3119: * THE CHARACTERS OF THE STRING ARE STORED LEFT JUSTIFIED. ! 3120: * THE FINAL WORD IS PADDED ON THE RIGHT WITH ZEROS. ! 3121: * (I.E. THE CHARACTER WHOSE INTERNAL CODE IS ZERO). ! 3122: * ! 3123: * THE VALUE OF SCLEN MAY NOT EXCEED MXLEN. THIS ENSURES ! 3124: * THAT CHARACTER OFFSETS (E.G. THE PATTERN MATCH CURSOR) ! 3125: * CAN BE CORRECTLY PROCESSED BY THE GARBAGE COLLECTOR. ! 3126: * ! 3127: * NOTE THAT THE OFFSET TO THE CHARACTERS OF THE STRING ! 3128: * IS GIVEN IN BYTES BY CFP$F AND THAT THIS VALUE IS ! 3129: * AUTOMATICALLY ALLOWED FOR IN PLC, PSC. ! 3130: * NOTE THAT FOR A SPITBOL SCBLK, THE VALUE OF CFP$F ! 3131: * IS GIVEN BY CFP$B*SCHAR. ! 3132: EJC ! 3133: * ! 3134: * SIMPLE EXPRESSION BLOCK (SEBLK) ! 3135: * ! 3136: * AN SEBLK IS USED TO REPRESENT AN EXPRESSION OF THE FORM ! 3137: * *(NATURAL VARIABLE). ALL OTHER EXPRESSIONS ARE EXBLKS. ! 3138: * ! 3139: * +------------------------------------+ ! 3140: * I SETYP I ! 3141: * +------------------------------------+ ! 3142: * I SEVAR I ! 3143: * +------------------------------------+ ! 3144: * ! 3145: SETYP EQU 0 PTR TO ROUTINE B$SEL TO LOAD EXPR ! 3146: SEVAR EQU SETYP+1 PTR TO VRBLK FOR VARIABLE ! 3147: SESI$ EQU SEVAR+1 LENGTH OF SEBLK IN WORDS ! 3148: EJC ! 3149: * ! 3150: * STANDARD VARIABLE BLOCK (SVBLK) ! 3151: * ! 3152: * AN SVBLK IS ASSEMBLED IN THE CONSTANT SECTION FOR EACH ! 3153: * VARIABLE WHICH SATISFIES ONE OF THE FOLLOWING CONDITIONS. ! 3154: * ! 3155: * 1) IT IS THE NAME OF A SYSTEM FUNCTION ! 3156: * 2) IT HAS AN INITIAL VALUE ! 3157: * 3) IT HAS A KEYWORD ASSOCIATION ! 3158: * 4) IT HAS A STANDARD I/O ASSOCIATION ! 3159: * 6) IT HAS A STANDARD LABEL ASSOCIATION ! 3160: * ! 3161: * IF VRBLKS ARE CONSTRUCTED FOR ANY OF THESE VARIABLES, ! 3162: * THEN THE VRSVP FIELD POINTS TO THE SVBLK (SEE VRBLK) ! 3163: * ! 3164: * +------------------------------------+ ! 3165: * I SVBIT I ! 3166: * +------------------------------------+ ! 3167: * I SVLEN I ! 3168: * +------------------------------------+ ! 3169: * I SVCHS I ! 3170: * +------------------------------------+ ! 3171: * I SVKNM I ! 3172: * +------------------------------------+ ! 3173: * I SVFNC I ! 3174: * +------------------------------------+ ! 3175: * I SVNAR I ! 3176: * +------------------------------------+ ! 3177: * I SVLBL I ! 3178: * +------------------------------------+ ! 3179: * I SVVAL I ! 3180: * +------------------------------------+ ! 3181: EJC ! 3182: * ! 3183: * STANDARD VARIABLE BLOCK (CONTINUED) ! 3184: * ! 3185: SVBIT EQU 0 BIT STRING INDICATING ATTRIBUTES ! 3186: SVLEN EQU 1 (=SCLEN) LENGTH OF NAME IN CHARS ! 3187: SVCHS EQU 2 (=SCHAR) CHARACTERS OF NAME ! 3188: SVSI$ EQU 2 NUMBER OF STANDARD FIELDS IN SVBLK ! 3189: SVPRE EQU 1 SET IF PREEVALUATION PERMITTED ! 3190: SVFFC EQU SVPRE+SVPRE SET ON IF FAST CALL PERMITTED ! 3191: SVCKW EQU SVFFC+SVFFC SET ON IF KEYWORD VALUE CONSTANT ! 3192: SVPRD EQU SVCKW+SVCKW SET ON IF PREDICATE FUNCTION ! 3193: SVNBT EQU 4 NUMBER OF BITS TO RIGHT OF SVKNM ! 3194: SVKNM EQU SVPRD+SVPRD SET ON IF KEYWORD ASSOCIATION ! 3195: SVFNC EQU SVKNM+SVKNM SET ON IF SYSTEM FUNCTION ! 3196: SVNAR EQU SVFNC+SVFNC SET ON IF SYSTEM FUNCTION ! 3197: SVLBL EQU SVNAR+SVNAR SET ON IF SYSTEM LABEL ! 3198: SVVAL EQU SVLBL+SVLBL SET ON IF PREDEFINED VALUE ! 3199: * ! 3200: * NOTE THAT THE LAST FIVE BITS CORRESPOND IN ORDER ! 3201: * TO THE FIELDS WHICH ARE PRESENT (SEE PROCEDURE GTNVR). ! 3202: * ! 3203: * THE FOLLOWING DEFINITIONS ARE USED IN THE SVBLK TABLE ! 3204: * ! 3205: SVFNF EQU SVFNC+SVNAR FUNCTION WITH NO FAST CALL ! 3206: SVFNN EQU SVFNF+SVFFC FUNCTION WITH FAST CALL, NO PREEVAL ! 3207: SVFNP EQU SVFNN+SVPRE FUNCTION ALLOWING PREEVALUATION ! 3208: SVFPR EQU SVFNN+SVPRD PREDICATE FUNCTION ! 3209: SVFNK EQU SVFNN+SVKNM NO PREEVAL FUNC + KEYWORD ! 3210: SVKWV EQU SVKNM+SVVAL KEYWORD + VALUE ! 3211: SVKWC EQU SVCKW+SVKNM KEYWORD WITH CONSTANT VALUE ! 3212: SVKVC EQU SVKWV+SVCKW CONSTANT KEYWORD + VALUE ! 3213: SVKVL EQU SVKVC+SVLBL CONSTANT KEYWORD + VALUE + LABEL ! 3214: SVFPK EQU SVFNP+SVKVC PREEVAL FCN + CONST KEYWD + VAL ! 3215: * ! 3216: * THE SVPRE BIT ALLOWS THE COMPILER TO PREEVALUATE A CALL ! 3217: * TO THE ASSOCIATED SYSTEM FUNCTION IF ALL THE ARGUMENTS ! 3218: * ARE THEMSELVES CONSTANTS. FUNCTIONS IN THIS CATEGORY ! 3219: * MUST HAVE NO SIDE EFFECTS AND MUST NEVER CAUSE FAILURE. ! 3220: * THE CALL MAY GENERATE AN ERROR CONDITION. ! 3221: * ! 3222: * THE SVFFC BIT ALLOWS THE COMPILER TO GENERATE THE SPECIAL ! 3223: * FAST CALL AFTER ADJUSTING THE NUMBER OF ARGUMENTS. ONLY ! 3224: * THE ITEM AND APPLY FUNCTIONS FALL OUTSIDE THIS CATEGORY. ! 3225: * ! 3226: * THE SVCKW BIT IS SET IF THE ASSOCIATED KEYWORD VALUE IS ! 3227: * A CONSTANT, THUS ALLOWING PREEVALUATION FOR A VALUE CALL. ! 3228: * ! 3229: * THE SVPRD BIT IS SET ON FOR ALL PREDICATE FUNCTIONS TO ! 3230: * ENABLE THE SPECIAL CONCATENATION CODE OPTIMIZATION. ! 3231: EJC ! 3232: * ! 3233: * SVBLK (CONTINUED) ! 3234: * ! 3235: * SVKNM KEYWORD NUMBER ! 3236: * ! 3237: * SVKNM IS PRESENT ONLY FOR A STANDARD KEYWORD ASSOC. ! 3238: * IT CONTAINS A KEYWORD NUMBER AS DEFINED BY THE ! 3239: * KEYWORD NUMBER TABLE GIVEN LATER ON. ! 3240: * ! 3241: * SVFNC SYSTEM FUNCTION POINTER ! 3242: * ! 3243: * SVFNC IS PRESENT ONLY FOR A SYSTEM FUNCTION ASSOC. ! 3244: * IT IS A POINTER TO THE ACTUAL CODE FOR THE SYSTEM ! 3245: * FUNCTION. THE GENERATED CODE FOR A FAST CALL IS A ! 3246: * POINTER TO THE SVFNC FIELD OF THE SVBLK FOR THE ! 3247: * FUNCTION. THE VRFNC FIELD OF THE VRBLK POINTS TO ! 3248: * THIS SAME FIELD, IN WHICH CASE, IT SERVES AS THE ! 3249: * FCODE FIELD FOR THE FUNCTION CALL. ! 3250: * ! 3251: * SVNAR NUMBER OF FUNCTION ARGUMENTS ! 3252: * ! 3253: * SVNAR IS PRESENT ONLY FOR A SYSTEM FUNCTION ASSOC. ! 3254: * IT IS THE NUMBER OF ARGUMENTS REQUIRED FOR A CALL ! 3255: * TO THE SYSTEM FUNCTION. THE COMPILER USES THIS ! 3256: * VALUE TO ADJUST THE NUMBER OF ARGUMENTS IN A FAST ! 3257: * CALL AND IN THE CASE OF A FUNCTION CALLED THROUGH ! 3258: * THE VRFNC FIELD OF THE VRBLK, THE SVNAR FIELD ! 3259: * SERVES AS THE FARGS FIELD FOR O$FNC. A SPECIAL ! 3260: * CASE OCCURS IF THIS VALUE IS SET TO 999. THIS IS ! 3261: * USED TO INDICATE THAT THE FUNCTION HAS A VARIABLE ! 3262: * NUMBER OF ARGUMENTS AND CAUSES O$FNC TO PASS CONTROL ! 3263: * WITHOUT ADJUSTING THE ARGUMENT COUNT. THE ONLY ! 3264: * PREDEFINED FUNCTIONS USING THIS ARE APPLY AND ITEM. ! 3265: * ! 3266: * SVLBL SYSTEM LABEL POINTER ! 3267: * ! 3268: * SVLBL IS PRESENT ONLY FOR A STANDARD LABEL ASSOC. ! 3269: * IT IS A POINTER TO A SYSTEM LABEL ROUTINE (L$XXX). ! 3270: * THE VRLBL FIELD OF THE CORRESPONDING VRBLK POINTS TO ! 3271: * THE SVLBL FIELD OF THE SVBLK. ! 3272: * ! 3273: * SVVAL SYSTEM VALUE POINTER ! 3274: * ! 3275: * SVVAL IS PRESENT ONLY FOR A STANDARD VALUE. ! 3276: * IT IS A POINTER TO THE PATTERN NODE (NDXXX) WHICH ! 3277: * IS THE STANDARD INITIAL VALUE OF THE VARIABLE. ! 3278: * THIS VALUE IS COPIED TO THE VRVAL FIELD OF THE VRBLK ! 3279: EJC ! 3280: * ! 3281: * SVBLK (CONTINUED) ! 3282: * ! 3283: * KEYWORD NUMBER TABLE ! 3284: * ! 3285: * THE FOLLOWING TABLE GIVES SYMBOLIC NAMES FOR KEYWORD ! 3286: * NUMBERS. THESE VALUES ARE STORED IN THE SVKNM FIELD OF ! 3287: * SVBLKS AND IN THE KVNUM FIELD OF KVBLKS. SEE ALSO ! 3288: * PROCEDURES ASIGN, ACESS AND KWNAM. ! 3289: * ! 3290: * UNPROTECTED KEYWORDS WITH ONE WORD INTEGER VALUES ! 3291: * ! 3292: K$ABE EQU 0 ABEND ! 3293: K$ANC EQU K$ABE+CFP$B ANCHOR ! 3294: K$CAS EQU K$ANC+CFP$B CASE ! 3295: K$COD EQU K$CAS+CFP$B CODE ! 3296: K$DMP EQU K$COD+CFP$B DUMP ! 3297: K$ERL EQU K$DMP+CFP$B ERRLIMIT ! 3298: K$ERT EQU K$ERL+CFP$B ERRTYPE ! 3299: K$FTR EQU K$ERT+CFP$B FTRACE ! 3300: K$INP EQU K$FTR+CFP$B INPUT ! 3301: K$MXL EQU K$INP+CFP$B MAXLENGTH ! 3302: K$OUP EQU K$MXL+CFP$B OUTPUT ! 3303: K$PFL EQU K$OUP+CFP$B PROFILE ! 3304: K$TRA EQU K$PFL+CFP$B TRACE ! 3305: K$TRM EQU K$TRA+CFP$B TRIM ! 3306: * ! 3307: * PROTECTED KEYWORDS WITH ONE WORD INTEGER VALUES ! 3308: * ! 3309: K$FNC EQU K$TRM+CFP$B FNCLEVEL ! 3310: K$LST EQU K$FNC+CFP$B LASTNO ! 3311: K$STN EQU K$LST+CFP$B STNO ! 3312: * ! 3313: * KEYWORDS WITH CONSTANT PATTERN VALUES ! 3314: * ! 3315: K$ABO EQU K$STN+CFP$B ABORT ! 3316: K$ARB EQU K$ABO+PASI$ ARB ! 3317: K$BAL EQU K$ARB+PASI$ BAL ! 3318: K$FAL EQU K$BAL+PASI$ FAIL ! 3319: K$FEN EQU K$FAL+PASI$ FENCE ! 3320: K$REM EQU K$FEN+PASI$ REM ! 3321: K$SUC EQU K$REM+PASI$ SUCCEED ! 3322: EJC ! 3323: * ! 3324: * KEYWORD NUMBER TABLE (CONTINUED) ! 3325: * ! 3326: * SPECIAL KEYWORDS ! 3327: * ! 3328: K$ALP EQU K$SUC+1 ALPHABET ! 3329: K$RTN EQU K$ALP+1 RTNTYPE ! 3330: K$STC EQU K$RTN+1 STCOUNT ! 3331: K$ETX EQU K$STC+1 ERRTEXT ! 3332: K$STL EQU K$ETX+1 STLIMIT ! 3333: * ! 3334: * RELATIVE OFFSETS OF SPECIAL KEYWORDS ! 3335: * ! 3336: K$$AL EQU K$ALP-K$ALP ALPHABET ! 3337: K$$RT EQU K$RTN-K$ALP RTNTYPE ! 3338: K$$SC EQU K$STC-K$ALP STCOUNT ! 3339: K$$ET EQU K$ETX-K$ALP ERRTEXT ! 3340: K$$SL EQU K$STL-K$ALP STLIMIT ! 3341: * ! 3342: * SYMBOLS USED IN ASIGN AND ACESS PROCEDURES ! 3343: * ! 3344: K$P$$ EQU K$FNC FIRST PROTECTED KEYWORD ! 3345: K$V$$ EQU K$ABO FIRST KEYWORD WITH CONSTANT VALUE ! 3346: K$S$$ EQU K$ALP FIRST KEYWORD WITH SPECIAL ACESS ! 3347: EJC ! 3348: * ! 3349: * FORMAT OF A TABLE BLOCK (TBBLK) ! 3350: * ! 3351: * A TABLE BLOCK IS USED TO REPRESENT A TABLE VALUE. ! 3352: * IT IS BUILT BY A CALL TO THE TABLE OR CONVERT FUNCTIONS. ! 3353: * ! 3354: * +------------------------------------+ ! 3355: * I TBTYP I ! 3356: * +------------------------------------+ ! 3357: * I IDVAL I ! 3358: * +------------------------------------+ ! 3359: * I TBLEN I ! 3360: * +------------------------------------+ ! 3361: * +------------------------------------+ ! 3362: * I TBINV I ! 3363: * +------------------------------------+ ! 3364: * / / ! 3365: * / TBBUK / ! 3366: * / / ! 3367: * +------------------------------------+ ! 3368: * ! 3369: TBTYP EQU 0 POINTER TO DUMMY ROUTINE B$TBT ! 3370: TBLEN EQU OFFS2 LENGTH OF TBBLK IN BYTES ! 3371: TBINV EQU OFFS3 DEFAULT INITIAL LOOKUP VALUE ! 3372: TBBUK EQU TBINV+1 START OF HASH BUCKET POINTERS ! 3373: TBSI$ EQU TBBUK SIZE OF STANDARD FIELDS IN TBBLK ! 3374: TBNBK EQU 11 DEFAULT NO. OF BUCKETS ! 3375: * ! 3376: * THE TABLE BLOCK IS A HASH TABLE WHICH POINTS TO CHAINS ! 3377: * OF TABLE ELEMENT BLOCKS REPRESENTING THE ELEMENTS ! 3378: * IN THE TABLE WHICH HASH INTO THE SAME BUCKET. ! 3379: * ! 3380: * TBBUK ENTRIES EITHER POINT TO THE FIRST TEBLK ON THE ! 3381: * CHAIN OR THEY POINT TO THE TBBLK ITSELF TO INDICATE THE ! 3382: * END OF THE CHAIN. ! 3383: EJC ! 3384: * ! 3385: * TABLE ELEMENT BLOCK (TEBLK) ! 3386: * ! 3387: * A TABLE ELEMENT IS USED TO REPRESENT A SINGLE ENTRY IN ! 3388: * A TABLE (SEE DESCRIPTION OF TBBLK FORMAT FOR HASH TABLE) ! 3389: * ! 3390: * +------------------------------------+ ! 3391: * I TETYP I ! 3392: * +------------------------------------+ ! 3393: * I TESUB I ! 3394: * +------------------------------------+ ! 3395: * I TEVAL I ! 3396: * +------------------------------------+ ! 3397: * I TENXT I ! 3398: * +------------------------------------+ ! 3399: * ! 3400: TETYP EQU 0 POINTER TO DUMMY ROUTINE B$TET ! 3401: TESUB EQU TETYP+1 SUBSCRIPT VALUE ! 3402: TEVAL EQU TESUB+1 (=VRVAL) TABLE ELEMENT VALUE ! 3403: TENXT EQU TEVAL+1 LINK TO NEXT TEBLK ! 3404: * SEE S$CNV WHERE RELATION IS ASSUMED WITH TENXT AND TBBUK ! 3405: TESI$ EQU TENXT+1 SIZE OF TEBLK IN WORDS ! 3406: * ! 3407: * TENXT POINTS TO THE NEXT TEBLK ON THE HASH CHAIN FROM THE ! 3408: * TBBUK CHAIN FOR THIS HASH INDEX. AT THE END OF THE CHAIN, ! 3409: * TENXT POINTS BACK TO THE START OF THE TBBLK. ! 3410: * ! 3411: * TEVAL CONTAINS A DATA POINTER OR A TRBLK POINTER. ! 3412: * ! 3413: * TESUB CONTAINS A DATA POINTER. ! 3414: EJC ! 3415: * ! 3416: * TRAP BLOCK (TRBLK) ! 3417: * ! 3418: * A TRAP BLOCK IS USED TO REPRESENT A TRACE OR INPUT OR ! 3419: * OUTPUT ASSOCIATION IN RESPONSE TO A CALL TO THE TRACE ! 3420: * INPUT OR OUTPUT SYSTEM FUNCTIONS. SEE BELOW FOR DETAILS ! 3421: * ! 3422: * +------------------------------------+ ! 3423: * I TRIDN I ! 3424: * +------------------------------------+ ! 3425: * I TRTYP I ! 3426: * +------------------------------------+ ! 3427: * I TRVAL OR TRLBL OR TRNXT OR TRKVR I ! 3428: * +------------------------------------+ ! 3429: * I TRTAG OR TRTER OR TRTRF I ! 3430: * +------------------------------------+ ! 3431: * I TRFNC OR TRFPT I ! 3432: * +------------------------------------+ ! 3433: * ! 3434: TRIDN EQU 0 POINTER TO DUMMY ROUTINE B$TRT ! 3435: TRTYP EQU TRIDN+1 TRAP TYPE CODE ! 3436: TRVAL EQU TRTYP+1 VALUE OF TRAPPED VARIABLE (=VRVAL) ! 3437: TRNXT EQU TRVAL PTR TO NEXT TRBLK ON TRBLK CHAIN ! 3438: TRLBL EQU TRVAL PTR TO ACTUAL LABEL (TRACED LABEL) ! 3439: TRKVR EQU TRVAL VRBLK POINTER FOR KEYWORD TRACE ! 3440: TRTAG EQU TRVAL+1 TRACE TAG ! 3441: TRTER EQU TRTAG PTR TO TERMINAL VRBLK OR NULL ! 3442: TRTRF EQU TRTAG PTR TO TRBLK HOLDING FCBLK PTR ! 3443: TRFNC EQU TRTAG+1 TRACE FUNCTION VRBLK (ZERO IF NONE) ! 3444: TRFPT EQU TRFNC FCBLK PTR FOR SYSIO ! 3445: TRSI$ EQU TRFNC+1 NUMBER OF WORDS IN TRBLK ! 3446: * ! 3447: TRTIN EQU 0 TRACE TYPE FOR INPUT ASSOCIATION ! 3448: TRTAC EQU TRTIN+1 TRACE TYPE FOR ACCESS TRACE ! 3449: TRTVL EQU TRTAC+1 TRACE TYPE FOR VALUE TRACE ! 3450: TRTOU EQU TRTVL+1 TRACE TYPE FOR OUTPUT ASSOCIATION ! 3451: TRTFC EQU TRTOU+1 TRACE TYPE FOR FCBLK IDENTIFICATION ! 3452: EJC ! 3453: * ! 3454: * TRAP BLOCK (CONTINUED) ! 3455: * ! 3456: * VARIABLE INPUT ASSOCIATION ! 3457: * ! 3458: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK ! 3459: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE ! 3460: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS ! 3461: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK. ! 3462: * ! 3463: * TRTYP IS SET TO TRTIN ! 3464: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL ! 3465: * TRTER IS A POINTER TO SVBLK IF ASSOCIATION IS ! 3466: * FOR INPUT, TERMINAL, ELSE IT IS NULL. ! 3467: * TRTRF POINTS TO THE TRAP BLOCK WHICH IN TURN POINTS ! 3468: * TO AN FCBLK USED FOR I/O ASSOCIATION. ! 3469: * TRFPT IS THE FCBLK PTR RETURNED BY SYSIO. ! 3470: * ! 3471: * VARIABLE ACCESS TRACE ASSOCIATION ! 3472: * ! 3473: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK ! 3474: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE ! 3475: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS ! 3476: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK. ! 3477: * ! 3478: * TRTYP IS SET TO TRTAC ! 3479: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL ! 3480: * TRTAG IS THE TRACE TAG (0 IF NONE) ! 3481: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 3482: * ! 3483: * VARIABLE VALUE TRACE ASSOCIATION ! 3484: * ! 3485: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK ! 3486: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE ! 3487: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS ! 3488: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK. ! 3489: * ! 3490: * TRTYP IS SET TO TRTVL ! 3491: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL ! 3492: * TRTAG IS THE TRACE TAG (0 IF NONE) ! 3493: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 3494: EJC ! 3495: * TRAP BLOCK (CONTINUED) ! 3496: * ! 3497: * VARIABLE OUTPUT ASSOCIATION ! 3498: * ! 3499: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK ! 3500: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE ! 3501: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS ! 3502: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK. ! 3503: * ! 3504: * TRTYP IS SET TO TRTOU ! 3505: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL ! 3506: * TRTER IS A POINTER TO SVBLK IF ASSOCIATION IS ! 3507: * FOR OUTPUT, TERMINAL, ELSE IT IS NULL. ! 3508: * TRTRF POINTS TO THE TRAP BLOCK WHICH IN TURN POINTS ! 3509: * TO AN FCBLK USED FOR I/O ASSOCIATION. ! 3510: * TRFPT IS THE FCBLK PTR RETURNED BY SYSIO. ! 3511: * ! 3512: * FUNCTION CALL TRACE ! 3513: * ! 3514: * THE PFCTR FIELD OF THE CORRESPONDING PFBLK IS SET ! 3515: * TO POINT TO A TRBLK. ! 3516: * ! 3517: * TRTYP IS SET TO TRTIN ! 3518: * TRNXT IS ZERO ! 3519: * TRTAG IS THE TRACE TAG (0 IF NONE) ! 3520: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 3521: * ! 3522: * FUNCTION RETURN TRACE ! 3523: * ! 3524: * THE PFRTR FIELD OF THE CORRESPONDING PFBLK IS SET ! 3525: * TO POINT TO A TRBLK ! 3526: * ! 3527: * TRTYP IS SET TO TRTIN ! 3528: * TRNXT IS ZERO ! 3529: * TRTAG IS THE TRACE TAG (0 IF NONE) ! 3530: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 3531: * ! 3532: * LABEL TRACE ! 3533: * ! 3534: * THE VRLBL OF THE VRBLK FOR THE LABEL IS ! 3535: * CHANGED TO POINT TO A TRBLK AND THE VRTRA FIELD IS ! 3536: * SET TO B$VRT TO ACTIVATE THE CHECK. ! 3537: * ! 3538: * TRTYP IS SET TO TRTIN ! 3539: * TRLBL POINTS TO THE ACTUAL LABEL (CDBLK) VALUE ! 3540: * TRTAG IS THE TRACE TAG (0 IF NONE) ! 3541: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 3542: EJC ! 3543: * ! 3544: * TRAP BLOCK (CONTINUED) ! 3545: * ! 3546: * KEYWORD TRACE ! 3547: * ! 3548: * KEYWORDS WHICH CAN BE TRACED POSSESS A UNIQUE ! 3549: * LOCATION WHICH IS ZERO IF THERE IS NO TRACE AND ! 3550: * POINTS TO A TRBLK IF THERE IS A TRACE. THE LOCATIONS ! 3551: * ARE AS FOLLOWS. ! 3552: * ! 3553: * R$ERT ERRTYPE ! 3554: * R$FNC FNCLEVEL ! 3555: * R$STC STCOUNT ! 3556: * ! 3557: * THE FORMAT OF THE TRBLK IS AS FOLLOWS. ! 3558: * ! 3559: * TRTYP IS SET TO TRTIN ! 3560: * TRKVR IS A POINTER TO THE VRBLK FOR THE KEYWORD ! 3561: * TRTAG IS THE TRACE TAG (0 IF NONE) ! 3562: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 3563: * ! 3564: * INPUT/OUTPUT FILE ARG1 TRAP BLOCK ! 3565: * ! 3566: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK ! 3567: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE OF ! 3568: * A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS ! 3569: * CONTAIN =B$VRA AND =B$VRV. THIS TRAP BLOCK IS USED ! 3570: * TO HOLD A POINTER TO THE FCBLK WHICH AN ! 3571: * IMPLEMENTATION MAY REQUEST TO HOLD INFORMATION ! 3572: * ABOUT A FILE. ! 3573: * ! 3574: * TRTYP IS SET TO TRTFC ! 3575: * TRNEXT POINTS TO NEXT TRBLK OR TRVAL IS VARIABLE VAL ! 3576: * TRFNM IS 0 ! 3577: * TRFPT IS THE FCBLK POINTER. ! 3578: * ! 3579: * NOTE THAT WHEN MULTIPLE TRAPS ARE SET ON A VARIABLE ! 3580: * THE ORDER IS IN ASCENDING VALUE OF TRTYP FIELD. ! 3581: * ! 3582: * INPUT ASSOCIATION (IF PRESENT) ! 3583: * ACCESS TRACE (IF PRESENT) ! 3584: * VALUE TRACE (IF PRESENT) ! 3585: * OUTPUT ASSOCIATION (IF PRESENT) ! 3586: * ! 3587: * THE ACTUAL VALUE OF THE VARIABLE IS STORED IN THE TRVAL ! 3588: * FIELD OF THE LAST TRBLK ON THE CHAIN. ! 3589: * ! 3590: * THIS IMPLEMENTATION DOES NOT PERMIT TRACE OR I/O ! 3591: * ASSOCIATIONS TO ANY OF THE PSEUDO-VARIABLES. ! 3592: EJC ! 3593: * ! 3594: * VECTOR BLOCK (VCBLK) ! 3595: * ! 3596: * A VCBLK IS USED TO REPRESENT AN ARRAY VALUE WHICH HAS ! 3597: * ONE DIMENSION WHOSE LOWER BOUND IS ONE. ALL OTHER ARRAYS ! 3598: * ARE REPRESENTED BY ARBLKS. A VCBLK IS CREATED BY THE ! 3599: * SYSTEM FUNCTION ARRAY (S$ARR) WHEN PASSED AN INTEGER ARG. ! 3600: * ! 3601: * +------------------------------------+ ! 3602: * I VCTYP I ! 3603: * +------------------------------------+ ! 3604: * I IDVAL I ! 3605: * +------------------------------------+ ! 3606: * I VCLEN I ! 3607: * +------------------------------------+ ! 3608: * I VCVLS I ! 3609: * +------------------------------------+ ! 3610: * ! 3611: VCTYP EQU 0 POINTER TO DUMMY ROUTINE B$VCT ! 3612: VCLEN EQU OFFS2 LENGTH OF VCBLK IN BYTES ! 3613: VCVLS EQU OFFS3 START OF VECTOR VALUES ! 3614: VCSI$ EQU VCVLS SIZE OF STANDARD FIELDS IN VCBLK ! 3615: VCVLB EQU VCVLS-1 OFFSET ONE WORD BEHIND VCVLS ! 3616: VCTBD EQU TBSI$-VCSI$ DIFFERENCE IN SIZES - SEE PRTVL ! 3617: * ! 3618: * VCVLS ARE EITHER DATA POINTERS OR TRBLK POINTERS ! 3619: * ! 3620: * THE DIMENSION CAN BE DEDUCED FROM VCLEN. ! 3621: EJC ! 3622: * ! 3623: * VARIABLE BLOCK (VRBLK) ! 3624: * ! 3625: * A VARIABLE BLOCK IS BUILT IN THE STATIC MEMORY AREA ! 3626: * FOR EVERY VARIABLE REFERENCED OR CREATED BY A PROGRAM. ! 3627: * ! 3628: * NOTE THAT SINCE THESE BLOCKS ONLY OCCUR IN THE STATIC ! 3629: * REGION, IT IS PERMISSIBLE TO POINT TO ANY WORD IN ! 3630: * THE BLOCK AND THIS IS USED TO PROVIDE THREE DISTINCT ! 3631: * ACCESS POINTS FROM THE GENERATED CODE AS FOLLOWS. ! 3632: * ! 3633: * 1) POINT TO VRGET (FIRST WORD OF VRBLK) TO LOAD THE ! 3634: * VALUE OF THE VARIABLE ONTO THE MAIN STACK. ! 3635: * ! 3636: * 2) POINT TO VRSTO (SECOND WORD OF VRBLK) TO STORE THE ! 3637: * TOP STACK ELEMENT AS THE VALUE OF THE VARIABLE. ! 3638: * ! 3639: * 3) POINT TO VRTRA (FOURTH WORD OF VRBLK) TO JUMP TO ! 3640: * THE LABEL ASSOCIATED WITH THE VARIABLE NAME. ! 3641: * ! 3642: * +------------------------------------+ ! 3643: * I VRGET I ! 3644: * +------------------------------------+ ! 3645: * I VRSTO I ! 3646: * +------------------------------------+ ! 3647: * I VRVAL I ! 3648: * +------------------------------------+ ! 3649: * I VRTRA I ! 3650: * +------------------------------------+ ! 3651: * I VRLBL I ! 3652: * +------------------------------------+ ! 3653: * I VRFNC I ! 3654: * +------------------------------------+ ! 3655: * I VRNXT I ! 3656: * +------------------------------------+ ! 3657: * I VRLEN I ! 3658: * +------------------------------------+ ! 3659: * / / ! 3660: * / VRCHS = VRSVP / ! 3661: * / / ! 3662: * +------------------------------------+ ! 3663: EJC ! 3664: * ! 3665: * VARIABLE BLOCK (CONTINUED) ! 3666: * ! 3667: VRGET EQU 0 POINTER TO ROUTINE TO LOAD VALUE ! 3668: VRSTO EQU VRGET+1 POINTER TO ROUTINE TO STORE VALUE ! 3669: VRVAL EQU VRSTO+1 VARIABLE VALUE ! 3670: VRVLO EQU VRVAL-VRSTO OFFSET TO VALUE FROM STORE FIELD ! 3671: VRTRA EQU VRVAL+1 POINTER TO ROUTINE TO JUMP TO LABEL ! 3672: VRLBL EQU VRTRA+1 POINTER TO CODE FOR LABEL ! 3673: VRLBO EQU VRLBL-VRTRA OFFSET TO LABEL FROM TRANSFER FIELD ! 3674: VRFNC EQU VRLBL+1 POINTER TO FUNCTION BLOCK ! 3675: VRNXT EQU VRFNC+1 POINTER TO NEXT VRBLK ON HASH CHAIN ! 3676: VRLEN EQU VRNXT+1 LENGTH OF NAME (OR ZERO) ! 3677: VRCHS EQU VRLEN+1 CHARACTERS OF NAME (VRLEN GT 0) ! 3678: VRSVP EQU VRLEN+1 PTR TO SVBLK (VRLEN EQ 0) ! 3679: VRSI$ EQU VRCHS+1 NUMBER OF STANDARD FIELDS IN VRBLK ! 3680: VRSOF EQU VRLEN-SCLEN OFFSET TO DUMMY SCBLK FOR NAME ! 3681: VRSVO EQU VRSVP-VRSOF PSEUDO-OFFSET TO VRSVP FIELD ! 3682: * ! 3683: * VRGET = B$VRL IF NOT INPUT ASSOCIATED OR ACCESS TRACED ! 3684: * VRGET = B$VRA IF INPUT ASSOCIATED OR ACCESS TRACED ! 3685: * ! 3686: * VRSTO = B$VRS IF NOT OUTPUT ASSOCIATED OR VALUE TRACED ! 3687: * VRSTO = B$VRV IF OUTPUT ASSOCIATED OR VALUE TRACED ! 3688: * VRSTO = B$VRE IF VALUE IS PROTECTED PATTERN VALUE ! 3689: * ! 3690: * VRVAL POINTS TO THE APPROPRIATE VALUE UNLESS THE ! 3691: * VARIABLE IS I/O/TRACE ASSOCIATED IN WHICH CASE, VRVAL ! 3692: * POINTS TO AN APPROPRIATE TRBLK (TRAP BLOCK) CHAIN. ! 3693: * ! 3694: * VRTRA = B$VRG IF THE LABEL IS NOT TRACED ! 3695: * VRTRA = B$VRT IF THE LABEL IS TRACED ! 3696: * ! 3697: * VRLBL POINTS TO A CDBLK IF THERE IS A LABEL ! 3698: * VRLBL POINTS TO THE SVBLK SVLBL FIELD FOR A SYSTEM LABEL ! 3699: * VRLBL POINTS TO STNDL FOR AN UNDEFINED LABEL ! 3700: * VRLBL POINTS TO A TRBLK IF THE LABEL IS TRACED ! 3701: * ! 3702: * VRFNC POINTS TO A FFBLK FOR A FIELD FUNCTION ! 3703: * VRFNC POINTS TO A DFBLK FOR A DATATYPE FUNCTION ! 3704: * VRFNC POINTS TO A PFBLK FOR A PROGRAM DEFINED FUNCTION ! 3705: * VRFNC POINTS TO A EFBLK FOR AN EXTERNAL LOADED FUNCTION ! 3706: * VRFNC POINTS TO SVFNC (SVBLK) FOR A SYSTEM FUNCTION ! 3707: * VRFNC POINTS TO STNDF IF THE FUNCTION IS UNDEFINED ! 3708: * ! 3709: * VRNXT POINTS TO THE NEXT VRBLK ON THIS CHAIN UNLESS ! 3710: * THIS IS THE END OF THE CHAIN IN WHICH CASE IT IS ZERO. ! 3711: * ! 3712: * VRLEN IS THE NAME LENGTH FOR A NON-SYSTEM VARIABLE. ! 3713: * VRLEN IS ZERO FOR A SYSTEM VARIABLE. ! 3714: * ! 3715: * VRCHS IS THE NAME (LJRZ) IF VRLEN IS NON-ZERO. ! 3716: * VRSVP IS A PTR TO THE SVBLK IF VRLEN IS ZERO. ! 3717: EJC ! 3718: * ! 3719: * FORMAT OF A NON-RELOCATABLE EXTERNAL BLOCK (XNBLK) ! 3720: * ! 3721: * AN XNBLK IS A BLOCK REPRESENTING AN UNKNOWN (EXTERNAL) ! 3722: * DATA VALUE. THE BLOCK CONTAINS NO POINTERS TO OTHER ! 3723: * RELOCATABLE BLOCKS. AN XNBLK IS USED BY EXTERNAL FUNCTION ! 3724: * PROCESSING OR POSSIBLY FOR SYSTEM I/O ROUTINES ETC. ! 3725: * THE MACRO-SYSTEM ITSELF DOES NOT USE XNBLKS. ! 3726: * THIS TYPE OF BLOCK MAY BE USED AS A FILE CONTROL BLOCK. ! 3727: * SEE SYSFC,SYSIN,SYSOU,S$INP,S$OUP FOR DETAILS. ! 3728: * ! 3729: * +------------------------------------+ ! 3730: * I XNTYP I ! 3731: * +------------------------------------+ ! 3732: * I XNLEN I ! 3733: * +------------------------------------+ ! 3734: * / / ! 3735: * / XNDTA / ! 3736: * / / ! 3737: * +------------------------------------+ ! 3738: * ! 3739: XNTYP EQU 0 POINTER TO DUMMY ROUTINE B$XNT ! 3740: XNLEN EQU XNTYP+1 LENGTH OF XNBLK IN BYTES ! 3741: XNDTA EQU XNLEN+1 DATA WORDS ! 3742: XNSI$ EQU XNDTA SIZE OF STANDARD FIELDS IN XNBLK ! 3743: * ! 3744: * NOTE THAT THE TERM NON-RELOCATABLE REFERS TO THE CONTENTS ! 3745: * AND NOT THE BLOCK ITSELF. AN XNBLK CAN BE MOVED AROUND IF ! 3746: * IT IS BUILT IN THE DYNAMIC MEMORY AREA. ! 3747: EJC ! 3748: * ! 3749: * RELOCATABLE EXTERNAL BLOCK (XRBLK) ! 3750: * ! 3751: * AN XRBLK IS A BLOCK REPRESENTING AN UNKNOWN (EXTERNAL) ! 3752: * DATA VALUE. THE DATA AREA IN THIS BLOCK CONSISTS ONLY ! 3753: * OF ADDRESS VALUES AND ANY ADDRESSES POINTING INTO THE ! 3754: * DYNAMIC MEMORY AREA MUST POINT TO THE START OF OTHER ! 3755: * DATA BLOCKS. SEE ALSO DESCRIPTION OF XNBLK. ! 3756: * THIS TYPE OF BLOCK MAY BE USED AS A FILE CONTROL BLOCK. ! 3757: * SEE SYSFC,SYSIN,SYSOU,S$INP,S$OUP FOR DETAILS. ! 3758: * ! 3759: * +------------------------------------+ ! 3760: * I XRTYP I ! 3761: * +------------------------------------+ ! 3762: * I XRLEN I ! 3763: * +------------------------------------+ ! 3764: * / / ! 3765: * / XRPTR / ! 3766: * / / ! 3767: * +------------------------------------+ ! 3768: * ! 3769: XRTYP EQU 0 POINTER TO DUMMY ROUTINE B$XRT ! 3770: XRLEN EQU XRTYP+1 LENGTH OF XRBLK IN BYTES ! 3771: XRPTR EQU XRLEN+1 START OF ADDRESS POINTERS ! 3772: XRSI$ EQU XRPTR SIZE OF STANDARD FIELDS IN XRBLK ! 3773: EJC ! 3774: * ! 3775: * S$CNV (CONVERT) FUNCTION SWITCH CONSTANTS. THE VALUES ! 3776: * ARE TIED TO THE ORDER OF THE ENTRIES IN THE SVCTB TABLE ! 3777: * AND HENCE TO THE BRANCH TABLE IN S$CNV. ! 3778: * ! 3779: CNVST EQU 8 MAX STANDARD TYPE CODE FOR CONVERT ! 3780: CNVRT EQU CNVST+1 CONVERT CODE FOR REALS ! 3781: CNVBT EQU CNVRT+1 CONVERT CODE FOR BUFFER ! 3782: CNVTT EQU CNVBT+1 BSW CODE FOR CONVERT ! 3783: * ! 3784: * INPUT IMAGE LENGTH ! 3785: * ! 3786: INILN EQU 132 DEFAULT IMAGE LENGTH FOR COMPILER ! 3787: INILS EQU 80 IMAGE LENGTH IF -SEQU IN EFFECT ! 3788: * ! 3789: IONMB EQU 2 NAME BASE USED FOR IOCHN IN SYSIO ! 3790: IONMO EQU 4 NAME OFFSET USED FOR IOCHN IN SYSIO ! 3791: * ! 3792: * IN GENERAL, MEANINGFUL MNEMONICS SHOULD BE USED FOR ! 3793: * OFFSETS. HOWEVER FOR SMALL INTEGERS USED OFTEN IN ! 3794: * LITERALS THE FOLLOWING GENERAL DEFINITIONS ARE PROVIDED. ! 3795: * ! 3796: NUM01 EQU 1 ! 3797: NUM02 EQU 2 ! 3798: NUM03 EQU 3 ! 3799: NUM04 EQU 4 ! 3800: NUM05 EQU 5 ! 3801: NUM06 EQU 6 ! 3802: NUM07 EQU 7 ! 3803: NUM08 EQU 8 ! 3804: NUM09 EQU 9 ! 3805: NUM10 EQU 10 ! 3806: NINI8 EQU 998 ! 3807: NINI9 EQU 999 ! 3808: THSND EQU 1000 ! 3809: EJC ! 3810: * ! 3811: * NUMBERS OF UNDEFINED SPITBOL OPERATORS ! 3812: * ! 3813: OPBUN EQU 5 NO. OF BINARY UNDEFINED OPS ! 3814: OPUUN EQU 6 NO OF UNARY UNDEFINED OPS ! 3815: * ! 3816: * OFFSETS USED IN PRTSN, PRTMI AND ACESS ! 3817: * ! 3818: PRSNF EQU 13 OFFSET USED IN PRTSN ! 3819: PRTMF EQU 15 OFFSET TO COL 15 (PRTMI) ! 3820: RILEN EQU 120 BUFFER LENGTH FOR SYSRI ! 3821: * ! 3822: * CODES FOR STAGES OF PROCESSING ! 3823: * ! 3824: STGIC EQU 0 INITIAL COMPILE ! 3825: STGXC EQU STGIC+1 EXECUTION COMPILE (CODE) ! 3826: STGEV EQU STGXC+1 EXPRESSION EVAL DURING EXECUTION ! 3827: STGXT EQU STGEV+1 EXECUTION TIME ! 3828: STGCE EQU STGXT+1 INITIAL COMPILE AFTER END LINE ! 3829: STGXE EQU STGCE+1 EXEC. COMPILE AFTER END LINE ! 3830: STGND EQU STGCE-STGIC DIFFERENCE IN STAGE AFTER END ! 3831: STGEE EQU STGXE+1 EVAL EVALUATING EXPRESSION ! 3832: STGNO EQU STGEE+1 NUMBER OF CODES ! 3833: EJC ! 3834: * ! 3835: * ! 3836: * STATEMENT NUMBER PAD COUNT FOR LISTR ! 3837: * ! 3838: STNPD EQU 8 STATEMENT NO. PAD COUNT ! 3839: * ! 3840: * SYNTAX TYPE CODES ! 3841: * ! 3842: * THESE CODES ARE RETURNED FROM THE SCANE PROCEDURE. ! 3843: * ! 3844: * THEY ARE SPACED 3 APART FOR THE BENEFIT OF EXPAN. ! 3845: * ! 3846: T$UOP EQU 0 UNARY OPERATOR ! 3847: T$LPR EQU T$UOP+3 LEFT PAREN ! 3848: T$LBR EQU T$LPR+3 LEFT BRACKET ! 3849: T$CMA EQU T$LBR+3 COMMA ! 3850: T$FNC EQU T$CMA+3 FUNCTION CALL ! 3851: T$VAR EQU T$FNC+3 VARIABLE ! 3852: T$CON EQU T$VAR+3 CONSTANT ! 3853: T$BOP EQU T$CON+3 BINARY OPERATOR ! 3854: T$RPR EQU T$BOP+3 RIGHT PAREN ! 3855: T$RBR EQU T$RPR+3 RIGHT BRACKET ! 3856: T$COL EQU T$RBR+3 COLON ! 3857: T$SMC EQU T$COL+3 SEMI-COLON ! 3858: * ! 3859: * THE FOLLOWING DEFINITIONS ARE USED ONLY IN THE GOTO FIELD ! 3860: * ! 3861: T$FGO EQU T$SMC+1 FAILURE GOTO ! 3862: T$SGO EQU T$FGO+1 SUCCESS GOTO ! 3863: * ! 3864: * THE ABOVE CODES ARE GROUPED SO THAT CODES FOR ELEMENTS ! 3865: * WHICH CAN LEGITIMATELY IMMEDIATELY PRECEDE A UNARY ! 3866: * OPERATOR COME FIRST TO FACILITATE OPERATOR SYNTAX CHECK. ! 3867: * ! 3868: T$UOK EQU T$FNC LAST CODE OK BEFORE UNARY OPERATOR ! 3869: EJC ! 3870: * ! 3871: * DEFINITIONS OF VALUES FOR EXPAN JUMP TABLE ! 3872: * ! 3873: T$UO0 EQU T$UOP+0 UNARY OPERATOR, STATE ZERO ! 3874: T$UO1 EQU T$UOP+1 UNARY OPERATOR, STATE ONE ! 3875: T$UO2 EQU T$UOP+2 UNARY OPERATOR, STATE TWO ! 3876: T$LP0 EQU T$LPR+0 LEFT PAREN, STATE ZERO ! 3877: T$LP1 EQU T$LPR+1 LEFT PAREN, STATE ONE ! 3878: T$LP2 EQU T$LPR+2 LEFT PAREN, STATE TWO ! 3879: T$LB0 EQU T$LBR+0 LEFT BRACKET, STATE ZERO ! 3880: T$LB1 EQU T$LBR+1 LEFT BRACKET, STATE ONE ! 3881: T$LB2 EQU T$LBR+2 LEFT BRACKET, STATE TWO ! 3882: T$CM0 EQU T$CMA+0 COMMA, STATE ZERO ! 3883: T$CM1 EQU T$CMA+1 COMMA, STATE ONE ! 3884: T$CM2 EQU T$CMA+2 COMMA, STATE TWO ! 3885: T$FN0 EQU T$FNC+0 FUNCTION CALL, STATE ZERO ! 3886: T$FN1 EQU T$FNC+1 FUNCTION CALL, STATE ONE ! 3887: T$FN2 EQU T$FNC+2 FUNCTION CALL, STATE TWO ! 3888: T$VA0 EQU T$VAR+0 VARIABLE, STATE ZERO ! 3889: T$VA1 EQU T$VAR+1 VARIABLE, STATE ONE ! 3890: T$VA2 EQU T$VAR+2 VARIABLE, STATE TWO ! 3891: T$CO0 EQU T$CON+0 CONSTANT, STATE ZERO ! 3892: T$CO1 EQU T$CON+1 CONSTANT, STATE ONE ! 3893: T$CO2 EQU T$CON+2 CONSTANT, STATE TWO ! 3894: T$BO0 EQU T$BOP+0 BINARY OPERATOR, STATE ZERO ! 3895: T$BO1 EQU T$BOP+1 BINARY OPERATOR, STATE ONE ! 3896: T$BO2 EQU T$BOP+2 BINARY OPERATOR, STATE TWO ! 3897: T$RP0 EQU T$RPR+0 RIGHT PAREN, STATE ZERO ! 3898: T$RP1 EQU T$RPR+1 RIGHT PAREN, STATE ONE ! 3899: T$RP2 EQU T$RPR+2 RIGHT PAREN, STATE TWO ! 3900: T$RB0 EQU T$RBR+0 RIGHT BRACKET, STATE ZERO ! 3901: T$RB1 EQU T$RBR+1 RIGHT BRACKET, STATE ONE ! 3902: T$RB2 EQU T$RBR+2 RIGHT BRACKET, STATE TWO ! 3903: T$CL0 EQU T$COL+0 COLON, STATE ZERO ! 3904: T$CL1 EQU T$COL+1 COLON, STATE ONE ! 3905: T$CL2 EQU T$COL+2 COLON, STATE TWO ! 3906: T$SM0 EQU T$SMC+0 SEMICOLON, STATE ZERO ! 3907: T$SM1 EQU T$SMC+1 SEMICOLON, STATE ONE ! 3908: T$SM2 EQU T$SMC+2 SEMICOLON, STATE TWO ! 3909: * ! 3910: T$NES EQU T$SM2+1 NUMBER OF ENTRIES IN BRANCH TABLE ! 3911: EJC ! 3912: * ! 3913: * DEFINITION OF OFFSETS USED IN CONTROL CARD PROCESSING ! 3914: * ! 3915: CC$CA EQU 0 -CASE ! 3916: CC$DO EQU CC$CA+1 -DOUBLE ! 3917: CC$DU EQU CC$DO+1 -DUMP ! 3918: CC$EJ EQU CC$DU+1 -EJECT ! 3919: CC$ER EQU CC$EJ+1 -ERRORS ! 3920: CC$EX EQU CC$ER+1 -EXECUTE ! 3921: CC$FA EQU CC$EX+1 -FAIL ! 3922: CC$LI EQU CC$FA+1 -LIST ! 3923: CC$NR EQU CC$LI+1 -NOERRORS ! 3924: CC$NX EQU CC$NR+1 -NOEXECUTE ! 3925: CC$NF EQU CC$NX+1 -NOFAIL ! 3926: CC$NL EQU CC$NF+1 -NOLIST ! 3927: CC$NO EQU CC$NL+1 -NOOPT ! 3928: CC$NP EQU CC$NO+1 -NOPRINT ! 3929: CC$OP EQU CC$NP+1 -OPTIMISE ! 3930: CC$PR EQU CC$OP+1 -PRINT ! 3931: CC$SI EQU CC$PR+1 -SINGLE ! 3932: CC$SP EQU CC$SI+1 -SPACE ! 3933: CC$ST EQU CC$SP+1 -STITL ! 3934: CC$TI EQU CC$ST+1 -TITLE ! 3935: CC$TR EQU CC$TI+1 -TRACE ! 3936: CC$NC EQU CC$TR+1 NUMBER OF CONTROL CARDS ! 3937: CCNOC EQU 4 NO. OF CHARS INCLUDED IN MATCH ! 3938: CCOFS EQU 7 OFFSET TO START OF TITLE/SUBTITLE ! 3939: EJC ! 3940: * ! 3941: * DEFINITIONS OF STACK OFFSETS USED IN CMPIL PROCEDURE ! 3942: * ! 3943: * SEE DESCRIPTION AT START OF CMPIL PROCEDURE FOR DETAILS ! 3944: * OF USE OF THESE LOCATIONS ON THE STACK. ! 3945: * ! 3946: CMSTM EQU 0 TREE FOR STATEMENT BODY ! 3947: CMSGO EQU CMSTM+1 TREE FOR SUCCESS GOTO ! 3948: CMFGO EQU CMSGO+1 TREE FOR FAIL GOTO ! 3949: CMCGO EQU CMFGO+1 CONDITIONAL GOTO FLAG ! 3950: CMPCD EQU CMCGO+1 PREVIOUS CDBLK POINTER ! 3951: CMFFP EQU CMPCD+1 FAILURE FILL IN FLAG FOR PREVIOUS ! 3952: CMFFC EQU CMFFP+1 FAILURE FILL IN FLAG FOR CURRENT ! 3953: CMSOP EQU CMFFC+1 SUCCESS FILL IN OFFSET FOR PREVIOUS ! 3954: CMSOC EQU CMSOP+1 SUCCESS FILL IN OFFSET FOR CURRENT ! 3955: CMLBL EQU CMSOC+1 PTR TO VRBLK FOR CURRENT LABEL ! 3956: CMTRA EQU CMLBL+1 PTR TO ENTRY CDBLK ! 3957: * ! 3958: CMNEN EQU CMTRA+1 COUNT OF STACK ENTRIES FOR CMPIL ! 3959: * ! 3960: * A FEW CONSTANTS USED BY THE PROFILER ! 3961: PFPD1 EQU 8 PAD POSITIONS ... ! 3962: PFPD2 EQU 20 ... FOR PROFILE ... ! 3963: PFPD3 EQU 32 ... PRINTOUT ! 3964: PF$I2 EQU CFP$I+CFP$I SIZE OF TABLE ENTRY (2 INTS) ! 3965: * ! 3966: TTL S P I T B O L -- CONSTANT SECTION ! 3967: * ! 3968: * THIS SECTION CONSISTS ENTIRELY OF ASSEMBLED CONSTANTS. ! 3969: * ! 3970: * ALL LABEL NAMES ARE FIVE LETTERS. THE ORDER IS ! 3971: * APPROXIMATELY ALPHABETICAL, BUT IN SOME CASES (ALWAYS ! 3972: * DOCUMENTED), CONSTANTS MUST BE PLACED IN SOME SPECIAL ! 3973: * ORDER WHICH MUST NOT BE DISTURBED. ! 3974: * ! 3975: * IT MUST ALSO BE REMEMBERED THAT THERE IS A REQUIREMENT ! 3976: * FOR NO FORWARD REFERENCES WHICH ALSO DISTURBS THE ! 3977: * ALPHABETICAL ORDER IN SOME CASES. ! 3978: * ! 3979: SEC START OF CONSTANT SECTION ! 3980: * ! 3981: * FREE STORE PERCENTAGE (USED BY ALLOC) ! 3982: * ! 3983: ALFSP DAC E$FSP FREE STORE PERCENTAGE ! 3984: * ! 3985: * BIT CONSTANTS FOR GENERAL USE ! 3986: * ! 3987: BITS0 DBC 0 ALL ZERO BITS ! 3988: BITS1 DBC 1 ONE BIT IN LOW ORDER POSITION ! 3989: BITS2 DBC 2 BIT IN POSITION 2 ! 3990: BITS3 DBC 4 BIT IN POSITION 3 ! 3991: BITS4 DBC 8 BIT IN POSITION 4 ! 3992: BITS5 DBC 16 BIT IN POSITION 5 ! 3993: BITS6 DBC 32 BIT IN POSITION 6 ! 3994: BITS7 DBC 64 BIT IN POSITION 7 ! 3995: BITS8 DBC 128 BIT IN POSITION 8 ! 3996: BITS9 DBC 256 BIT IN POSITION 9 ! 3997: BIT10 DBC 512 BIT IN POSITION 10 ! 3998: BITSM DBC CFP$M MASK FOR MAX INTEGER ! 3999: * ! 4000: * BIT CONSTANTS FOR SVBLK (SVBIT FIELD) TESTS ! 4001: * ! 4002: BTFNC DBC SVFNC BIT TO TEST FOR FUNCTION ! 4003: BTKNM DBC SVKNM BIT TO TEST FOR KEYWORD NUMBER ! 4004: BTLBL DBC SVLBL BIT TO TEST FOR LABEL ! 4005: BTFFC DBC SVFFC BIT TO TEST FOR FAST CALL ! 4006: BTCKW DBC SVCKW BIT TO TEST FOR CONSTANT KEYWORD ! 4007: BTPRD DBC SVPRD BIT TO TEST FOR PREDICATE FUNCTION ! 4008: BTPRE DBC SVPRE BIT TO TEST FOR PREEVALUATION ! 4009: BTVAL DBC SVVAL BIT TO TEST FOR VALUE ! 4010: EJC ! 4011: * ! 4012: * LIST OF NAMES USED FOR CONTROL CARD PROCESSING ! 4013: * ! 4014: CCNMS DTC /CASE/ ! 4015: DTC /DOUB/ ! 4016: DTC /DUMP/ ! 4017: DTC /EJEC/ ! 4018: DTC /ERRO/ ! 4019: DTC /EXEC/ ! 4020: DTC /FAIL/ ! 4021: DTC /LIST/ ! 4022: DTC /NOER/ ! 4023: DTC /NOEX/ ! 4024: DTC /NOFA/ ! 4025: DTC /NOLI/ ! 4026: DTC /NOOP/ ! 4027: DTC /NOPR/ ! 4028: DTC /OPTI/ ! 4029: DTC /PRIN/ ! 4030: DTC /SING/ ! 4031: DTC /SPAC/ ! 4032: DTC /STIT/ ! 4033: DTC /TITL/ ! 4034: DTC /TRAC/ ! 4035: * ! 4036: * HEADER MESSAGES FOR DUMPR PROCEDURE (SCBLK FORMAT) ! 4037: * ! 4038: DMHDK DAC B$SCL DUMP OF KEYWORD VALUES ! 4039: DAC 22 ! 4040: DTC /DUMP OF KEYWORD VALUES/ ! 4041: * ! 4042: DMHDV DAC B$SCL DUMP OF NATURAL VARIABLES ! 4043: DAC 25 ! 4044: DTC /DUMP OF NATURAL VARIABLES/ ! 4045: EJC ! 4046: * ! 4047: * MESSAGE TEXT FOR COMPILATION STATISTICS ! 4048: * ! 4049: ENCM1 DAC B$SCL ! 4050: DAC 10 ! 4051: DTC /STORE USED/ ! 4052: * ! 4053: ENCM2 DAC B$SCL ! 4054: DAC 10 ! 4055: DTC /STORE LEFT/ ! 4056: * ! 4057: ENCM3 DAC B$SCL ! 4058: DAC 11 ! 4059: DTC /COMP ERRORS/ ! 4060: * ! 4061: ENCM4 DAC B$SCL ! 4062: DAC 14 ! 4063: DTC /COMP TIME-MSEC/ ! 4064: * ! 4065: ENCM5 DAC B$SCL EXECUTION SUPPRESSED ! 4066: DAC 20 ! 4067: DTC /EXECUTION SUPPRESSED/ ! 4068: * ! 4069: * STRING CONSTANT FOR ABNORMAL END ! 4070: * ! 4071: ENDAB DAC B$SCL ! 4072: DAC 12 ! 4073: DTC /ABNORMAL END/ ! 4074: EJC ! 4075: * ! 4076: * MEMORY OVERFLOW DURING INITIALISATION ! 4077: * ! 4078: ENDMO DAC B$SCL ! 4079: ENDML DAC 15 ! 4080: DTC /MEMORY OVERFLOW/ ! 4081: * ! 4082: * STRING CONSTANT FOR MESSAGE ISSUED BY L$END ! 4083: * ! 4084: ENDMS DAC B$SCL ! 4085: DAC 10 ! 4086: DTC /NORMAL END/ ! 4087: * ! 4088: * FAIL MESSAGE FOR STACK FAIL SECTION ! 4089: * ! 4090: ENDSO DAC B$SCL STACK OVERFLOW IN GARBAGE COLLECTOR ! 4091: DAC 36 ! 4092: DTC /STACK OVERFLOW IN GARBAGE COLLECTION/ ! 4093: * ! 4094: * STRING CONSTANT FOR TIME UP ! 4095: * ! 4096: ENDTU DAC B$SCL ! 4097: DAC 15 ! 4098: DTC /ERROR - TIME UP/ ! 4099: EJC ! 4100: * ! 4101: * STRING CONSTANT FOR ERROR MESSAGE (ERROR SECTION) ! 4102: * ! 4103: ERMMS DAC B$SCL ERROR ! 4104: DAC 5 ! 4105: DTC /ERROR/ ! 4106: * ! 4107: ERMNS DAC B$SCL STRING / -- / ! 4108: DAC 4 ! 4109: DTC / -- / ! 4110: * ! 4111: * STRING CONSTANT FOR PAGE NUMBERING ! 4112: * ! 4113: LSTMS DAC B$SCL PAGE ! 4114: DAC 5 ! 4115: DTC /PAGE / ! 4116: * ! 4117: * LISTING HEADER MESSAGE ! 4118: * ! 4119: HEADR DAC B$SCL ! 4120: DAC 25 ! 4121: DTC /MACRO SPITBOL VERSION 3.5/ ! 4122: * ! 4123: HEADV DAC B$SCL FOR EXIT() VERSION NO. CHECK ! 4124: DAC 3 ! 4125: DTC /3.5/ ! 4126: * ! 4127: * INTEGER CONSTANTS FOR GENERAL USE ! 4128: * ICBLD OPTIMISATION USES THE FIRST THREE. ! 4129: * ! 4130: INT$R DAC B$ICL ! 4131: INTV0 DIC +0 0 ! 4132: INTON DAC B$ICL ! 4133: INTV1 DIC +1 1 ! 4134: INTTW DAC B$ICL ! 4135: INTV2 DIC +2 2 ! 4136: INTVT DIC +10 10 ! 4137: INTVH DIC +100 100 ! 4138: INTTH DIC +1000 1000 ! 4139: * ! 4140: * TABLE USED IN ICBLD OPTIMISATION ! 4141: * ! 4142: INTAB DAC INT$R POINTER TO 0 ! 4143: DAC INTON POINTER TO 1 ! 4144: DAC INTTW POINTER TO 2 ! 4145: EJC ! 4146: * ! 4147: * SPECIAL PATTERN NODES. THE FOLLOWING PATTERN NODES ! 4148: * CONSIST SIMPLY OF A PCODE POINTER, SEE MATCH ROUTINES ! 4149: * (P$XXX) FOR FULL DETAILS OF THEIR USE AND FORMAT). ! 4150: * ! 4151: NDABB DAC P$ABB ARBNO ! 4152: NDABD DAC P$ABD ARBNO ! 4153: NDARC DAC P$ARC ARB ! 4154: NDEXB DAC P$EXB EXPRESSION ! 4155: NDFNB DAC P$FNB FENCE() ! 4156: NDFND DAC P$FND FENCE() ! 4157: NDEXC DAC P$EXC EXPRESSION ! 4158: NDIMB DAC P$IMB IMMEDIATE ASSIGNMENT ! 4159: NDIMD DAC P$IMD IMMEDIATE ASSIGNMENT ! 4160: NDNTH DAC P$NTH PATTERN END (NULL PATTERN) ! 4161: NDPAB DAC P$PAB PATTERN ASSIGNMENT ! 4162: NDPAD DAC P$PAD PATTERN ASSIGNMENT ! 4163: NDUNA DAC P$UNA ANCHOR POINT MOVEMENT ! 4164: * ! 4165: * KEYWORD CONSTANT PATTERN NODES. THE FOLLOWING NODES ARE ! 4166: * USED AS THE VALUES OF PATTERN KEYWORDS AND THE INITIAL ! 4167: * VALUES OF THE CORRESPONDING NATURAL VARIABLES. ALL ! 4168: * NODES ARE IN P0BLK FORMAT AND THE ORDER IS TIED TO THE ! 4169: * DEFINITIONS OF CORRESPONDING K$XXX SYMBOLS. ! 4170: * ! 4171: NDABO DAC P$ABO ABORT ! 4172: DAC NDNTH ! 4173: NDARB DAC P$ARB ARB ! 4174: DAC NDNTH ! 4175: NDBAL DAC P$BAL BAL ! 4176: DAC NDNTH ! 4177: NDFAL DAC P$FAL FAIL ! 4178: DAC NDNTH ! 4179: NDFEN DAC P$FEN FENCE ! 4180: DAC NDNTH ! 4181: NDREM DAC P$REM REM ! 4182: DAC NDNTH ! 4183: NDSUC DAC P$SUC SUCCEED ! 4184: DAC NDNTH ! 4185: * ! 4186: * NULL STRING. ALL NULL VALUES POINT TO THIS STRING. THE ! 4187: * SVCHS FIELD CONTAINS A BLANK TO PROVIDE FOR EASY DEFAULT ! 4188: * PROCESSING IN TRACE, STOPTR, LPAD AND RPAD. ! 4189: * NULLW CONTAINS 10 BLANKS WHICH ENSURES AN ALL BLANK WORD ! 4190: * BUT FOR VERY EXCEPTIONAL MACHINES. ! 4191: * ! 4192: NULLS DAC B$SCL NULL STRING VALUE ! 4193: DAC 0 SCLEN = 0 ! 4194: NULLW DTC / / ! 4195: EJC ! 4196: * ! 4197: * OPERATOR DOPE VECTORS (SEE DVBLK FORMAT) ! 4198: * ! 4199: OPDVC DAC O$CNC CONCATENATION ! 4200: DAC C$CNC ! 4201: DAC LLCNC ! 4202: DAC RRCNC ! 4203: * ! 4204: * OPDVS IS USED WHEN SCANNING BELOW THE TOP LEVEL TO ! 4205: * INSURE THAT THE CONCATENATION WILL NOT BE LATER ! 4206: * MISTAKEN FOR PATTERN MATCHING ! 4207: * ! 4208: OPDVP DAC O$CNC CONCATENATION - NOT PATTERN MATCH ! 4209: DAC C$CNP ! 4210: DAC LLCNC ! 4211: DAC RRCNC ! 4212: * ! 4213: * NOTE THAT THE ORDER OF THE REMAINING ENTRIES IS TIED TO ! 4214: * THE ORDER OF THE CODING IN THE SCANE PROCEDURE. ! 4215: * ! 4216: OPDVS DAC O$ASS ASSIGNMENT ! 4217: DAC C$ASS ! 4218: DAC LLASS ! 4219: DAC RRASS ! 4220: * ! 4221: DAC 6 UNARY EQUAL ! 4222: DAC C$UUO ! 4223: DAC LLUNO ! 4224: * ! 4225: DAC O$PMV PATTERN MATCH ! 4226: DAC C$PMT ! 4227: DAC LLPMT ! 4228: DAC RRPMT ! 4229: * ! 4230: DAC O$INT INTERROGATION ! 4231: DAC C$UVL ! 4232: DAC LLUNO ! 4233: * ! 4234: DAC 1 BINARY AMPERSAND ! 4235: DAC C$UBO ! 4236: DAC LLAMP ! 4237: DAC RRAMP ! 4238: * ! 4239: DAC O$KWV KEYWORD REFERENCE ! 4240: DAC C$KEY ! 4241: DAC LLUNO ! 4242: * ! 4243: DAC O$ALT ALTERNATION ! 4244: DAC C$ALT ! 4245: DAC LLALT ! 4246: DAC RRALT ! 4247: EJC ! 4248: * ! 4249: * OPERATOR DOPE VECTORS (CONTINUED) ! 4250: * ! 4251: DAC 5 UNARY VERTICAL BAR ! 4252: DAC C$UUO ! 4253: DAC LLUNO ! 4254: * ! 4255: DAC 0 BINARY AT ! 4256: DAC C$UBO ! 4257: DAC LLATS ! 4258: DAC RRATS ! 4259: * ! 4260: DAC O$CAS CURSOR ASSIGNMENT ! 4261: DAC C$UNM ! 4262: DAC LLUNO ! 4263: * ! 4264: DAC 2 BINARY NUMBER SIGN ! 4265: DAC C$UBO ! 4266: DAC LLNUM ! 4267: DAC RRNUM ! 4268: * ! 4269: DAC 7 UNARY NUMBER SIGN ! 4270: DAC C$UUO ! 4271: DAC LLUNO ! 4272: * ! 4273: DAC O$DVD DIVISION ! 4274: DAC C$BVL ! 4275: DAC LLDVD ! 4276: DAC RRDVD ! 4277: * ! 4278: DAC 9 UNARY SLASH ! 4279: DAC C$UUO ! 4280: DAC LLUNO ! 4281: * ! 4282: DAC O$MLT MULTIPLICATION ! 4283: DAC C$BVL ! 4284: DAC LLMLT ! 4285: DAC RRMLT ! 4286: EJC ! 4287: * ! 4288: * OPERATOR DOPE VECTORS (CONTINUED) ! 4289: * ! 4290: DAC 0 DEFERRED EXPRESSION ! 4291: DAC C$DEF ! 4292: DAC LLUNO ! 4293: * ! 4294: DAC 3 BINARY PERCENT ! 4295: DAC C$UBO ! 4296: DAC LLPCT ! 4297: DAC RRPCT ! 4298: * ! 4299: DAC 8 UNARY PERCENT ! 4300: DAC C$UUO ! 4301: DAC LLUNO ! 4302: * ! 4303: DAC O$EXP EXPONENTIATION ! 4304: DAC C$BVL ! 4305: DAC LLEXP ! 4306: DAC RREXP ! 4307: * ! 4308: DAC 10 UNARY EXCLAMATION ! 4309: DAC C$UUO ! 4310: DAC LLUNO ! 4311: * ! 4312: DAC O$IMA IMMEDIATE ASSIGNMENT ! 4313: DAC C$BVN ! 4314: DAC LLDLD ! 4315: DAC RRDLD ! 4316: * ! 4317: DAC O$INV INDIRECTION ! 4318: DAC C$IND ! 4319: DAC LLUNO ! 4320: * ! 4321: DAC 4 BINARY NOT ! 4322: DAC C$UBO ! 4323: DAC LLNOT ! 4324: DAC RRNOT ! 4325: * ! 4326: DAC 0 NEGATION ! 4327: DAC C$NEG ! 4328: DAC LLUNO ! 4329: EJC ! 4330: * ! 4331: * OPERATOR DOPE VECTORS (CONTINUED) ! 4332: * ! 4333: DAC O$SUB SUBTRACTION ! 4334: DAC C$BVL ! 4335: DAC LLPLM ! 4336: DAC RRPLM ! 4337: * ! 4338: DAC O$COM COMPLEMENTATION ! 4339: DAC C$UVL ! 4340: DAC LLUNO ! 4341: * ! 4342: DAC O$ADD ADDITION ! 4343: DAC C$BVL ! 4344: DAC LLPLM ! 4345: DAC RRPLM ! 4346: * ! 4347: DAC O$AFF AFFIRMATION ! 4348: DAC C$UVL ! 4349: DAC LLUNO ! 4350: * ! 4351: DAC O$PAS PATTERN ASSIGNMENT ! 4352: DAC C$BVN ! 4353: DAC LLDLD ! 4354: DAC RRDLD ! 4355: * ! 4356: DAC O$NAM NAME REFERENCE ! 4357: DAC C$UNM ! 4358: DAC LLUNO ! 4359: * ! 4360: * SPECIAL DVS FOR GOTO OPERATORS (SEE PROCEDURE SCNGF) ! 4361: * ! 4362: OPDVD DAC O$GOD DIRECT GOTO ! 4363: DAC C$UVL ! 4364: DAC LLUNO ! 4365: * ! 4366: OPDVN DAC O$GOC COMPLEX NORMAL GOTO ! 4367: DAC C$UNM ! 4368: DAC LLUNO ! 4369: EJC ! 4370: * ! 4371: * OPERATOR ENTRY ADDRESS POINTERS, USED IN CODE ! 4372: * ! 4373: OAMN$ DAC O$AMN ARRAY REF (MULTI-SUBS BY VALUE) ! 4374: OAMV$ DAC O$AMV ARRAY REF (MULTI-SUBS BY VALUE) ! 4375: OAON$ DAC O$AON ARRAY REF (ONE SUB BY NAME) ! 4376: OAOV$ DAC O$AOV ARRAY REF (ONE SUB BY VALUE) ! 4377: OCER$ DAC O$CER COMPILATION ERROR ! 4378: OFEX$ DAC O$FEX FAILURE IN EXPRESSION EVALUATION ! 4379: OFIF$ DAC O$FIF FAILURE DURING GOTO EVALUATION ! 4380: OFNC$ DAC O$FNC FUNCTION CALL (MORE THAN ONE ARG) ! 4381: OFNE$ DAC O$FNE FUNCTION NAME ERROR ! 4382: OFNS$ DAC O$FNS FUNCTION CALL (SINGLE ARGUMENT) ! 4383: OGOF$ DAC O$GOF SET GOTO FAILURE TRAP ! 4384: OINN$ DAC O$INN INDIRECTION BY NAME ! 4385: OKWN$ DAC O$KWN KEYWORD REFERENCE BY NAME ! 4386: OLEX$ DAC O$LEX LOAD EXPRESSION BY NAME ! 4387: OLPT$ DAC O$LPT LOAD PATTERN ! 4388: OLVN$ DAC O$LVN LOAD VARIABLE NAME ! 4389: ONTA$ DAC O$NTA NEGATION, FIRST ENTRY ! 4390: ONTB$ DAC O$NTB NEGATION, SECOND ENTRY ! 4391: ONTC$ DAC O$NTC NEGATION, THIRD ENTRY ! 4392: OPMN$ DAC O$PMN PATTERN MATCH BY NAME ! 4393: OPMS$ DAC O$PMS PATTERN MATCH (STATEMENT) ! 4394: OPOP$ DAC O$POP POP TOP STACK ITEM ! 4395: ORNM$ DAC O$RNM RETURN NAME FROM EXPRESSION ! 4396: ORPL$ DAC O$RPL PATTERN REPLACEMENT ! 4397: ORVL$ DAC O$RVL RETURN VALUE FROM EXPRESSION ! 4398: OSLA$ DAC O$SLA SELECTION, FIRST ENTRY ! 4399: OSLB$ DAC O$SLB SELECTION, SECOND ENTRY ! 4400: OSLC$ DAC O$SLC SELECTION, THIRD ENTRY ! 4401: OSLD$ DAC O$SLD SELECTION, FOURTH ENTRY ! 4402: OSTP$ DAC O$STP STOP EXECUTION ! 4403: OUNF$ DAC O$UNF UNEXPECTED FAILURE ! 4404: EJC ! 4405: * ! 4406: * TABLE OF NAMES OF UNDEFINED BINARY OPERATORS FOR OPSYN ! 4407: * ! 4408: OPSNB DAC CH$AT AT ! 4409: DAC CH$AM AMPERSAND ! 4410: DAC CH$NM NUMBER ! 4411: DAC CH$PC PERCENT ! 4412: DAC CH$NT NOT ! 4413: * ! 4414: * TABLE OF NAMES OF UNDEFINED UNARY OPERATORS FOR OPSYN ! 4415: * ! 4416: OPNSU DAC CH$BR VERTICAL BAR ! 4417: DAC CH$EQ EQUAL ! 4418: DAC CH$NM NUMBER ! 4419: DAC CH$PC PERCENT ! 4420: DAC CH$SL SLASH ! 4421: DAC CH$EX EXCLAMATION ! 4422: * ! 4423: * ADDRESS CONST CONTAINING PROFILE TABLE ENTRY SIZE ! 4424: * ! 4425: PFI2A DAC PF$I2 ! 4426: * ! 4427: * PROFILER MESSAGE STRINGS ! 4428: * ! 4429: PFMS1 DAC B$SCL ! 4430: DAC 15 ! 4431: DTC /PROGRAM PROFILE/ ! 4432: PFMS2 DAC B$SCL ! 4433: DAC 42 ! 4434: DTC /STMT NUMBER OF -- EXECUTION TIME --/ ! 4435: PFMS3 DAC B$SCL ! 4436: DAC 47 ! 4437: DTC /NUMBER EXECUTIONS TOTAL(MSEC) PER EXCN(MCSEC)/ ! 4438: * ! 4439: * ! 4440: * REAL CONSTANTS FOR GENERAL USE. NOTE THAT THE CONSTANTS ! 4441: * STARTING AT REAV1 FORM A POWERS OF TEN TABLE (GTSTG) ! 4442: * ! 4443: REAV0 DRC +0.0 0.0 ! 4444: REAP1 DRC +0.1 0.1 ! 4445: REAP5 DRC +0.5 0.5 ! 4446: REAV1 DRC +1.0 10**0 ! 4447: REAVT DRC +1.0E+1 10**1 ! 4448: DRC +1.0E+2 10**2 ! 4449: DRC +1.0E+3 10**3 ! 4450: DRC +1.0E+4 10**4 ! 4451: DRC +1.0E+5 10**5 ! 4452: DRC +1.0E+6 10**6 ! 4453: DRC +1.0E+7 10**7 ! 4454: DRC +1.0E+8 10**8 ! 4455: DRC +1.0E+9 10**9 ! 4456: REATT DRC +1.0E+10 10**10 ! 4457: EJC ! 4458: * ! 4459: * STRING CONSTANTS (SCBLK FORMAT) FOR DTYPE PROCEDURE ! 4460: * ! 4461: SCARR DAC B$SCL ARRAY ! 4462: DAC 5 ! 4463: DTC /ARRAY/ ! 4464: * ! 4465: SCBUF DAC B$SCL BUFFER ! 4466: DAC 6 ! 4467: DTC /BUFFER/ ! 4468: * ! 4469: SCCOD DAC B$SCL CODE ! 4470: DAC 4 ! 4471: DTC /CODE/ ! 4472: * ! 4473: SCEXP DAC B$SCL EXPRESSION ! 4474: DAC 10 ! 4475: DTC /EXPRESSION/ ! 4476: * ! 4477: SCEXT DAC B$SCL EXTERNAL ! 4478: DAC 8 ! 4479: DTC /EXTERNAL/ ! 4480: * ! 4481: SCINT DAC B$SCL INTEGER ! 4482: DAC 7 ! 4483: DTC /INTEGER/ ! 4484: * ! 4485: SCNAM DAC B$SCL NAME ! 4486: DAC 4 ! 4487: DTC /NAME/ ! 4488: * ! 4489: SCNUM DAC B$SCL NUMERIC ! 4490: DAC 7 ! 4491: DTC /NUMERIC/ ! 4492: * ! 4493: SCPAT DAC B$SCL PATTERN ! 4494: DAC 7 ! 4495: DTC /PATTERN/ ! 4496: * ! 4497: SCREA DAC B$SCL REAL ! 4498: DAC 4 ! 4499: DTC /REAL/ ! 4500: * ! 4501: SCSTR DAC B$SCL STRING ! 4502: DAC 6 ! 4503: DTC /STRING/ ! 4504: * ! 4505: SCTAB DAC B$SCL TABLE ! 4506: DAC 5 ! 4507: DTC /TABLE/ ! 4508: EJC ! 4509: * ! 4510: * STRING CONSTANTS (SCBLK FORMAT) FOR KVRTN (SEE RETRN) ! 4511: * ! 4512: SCFRT DAC B$SCL FRETURN ! 4513: DAC 7 ! 4514: DTC /FRETURN/ ! 4515: * ! 4516: SCNRT DAC B$SCL NRETURN ! 4517: DAC 7 ! 4518: DTC /NRETURN/ ! 4519: * ! 4520: SCRTN DAC B$SCL RETURN ! 4521: DAC 6 ! 4522: DTC /RETURN/ ! 4523: * ! 4524: * DATATYPE NAME TABLE FOR DTYPE PROCEDURE. THE ORDER OF ! 4525: * THESE ENTRIES IS TIED TO THE B$XXX DEFINITIONS FOR BLOCKS ! 4526: * ! 4527: SCNMT DAC SCARR ARBLK ARRAY ! 4528: DAC SCBUF BFBLK BUFFER ! 4529: DAC SCCOD CDBLK CODE ! 4530: DAC SCEXP EXBLK EXPRESSION ! 4531: DAC SCINT ICBLK INTEGER ! 4532: DAC SCNAM NMBLK NAME ! 4533: DAC SCPAT P0BLK PATTERN ! 4534: DAC SCPAT P1BLK PATTERN ! 4535: DAC SCPAT P2BLK PATTERN ! 4536: DAC SCREA RCBLK REAL ! 4537: DAC SCSTR SCBLK STRING ! 4538: DAC SCEXP SEBLK EXPRESSION ! 4539: DAC SCTAB TBBLK TABLE ! 4540: DAC SCARR VCBLK ARRAY ! 4541: DAC SCEXT XNBLK EXTERNAL ! 4542: DAC SCEXT XRBLK EXTERNAL ! 4543: * ! 4544: * STRING CONSTANT FOR REAL ZERO ! 4545: * ! 4546: SCRE0 DAC B$SCL ! 4547: DAC 2 ! 4548: DTC /0./ ! 4549: EJC ! 4550: * ! 4551: * USED TO RE-INITIALISE KVSTL ! 4552: * ! 4553: STLIM DIC +50000 DEFAULT STATEMENT LIMIT ! 4554: * ! 4555: * DUMMY FUNCTION BLOCK USED FOR UNDEFINED FUNCTIONS ! 4556: * ! 4557: STNDF DAC O$FUN PTR TO UNDEFINED FUNCTION ERR CALL ! 4558: DAC 0 DUMMY FARGS COUNT FOR CALL CIRCUIT ! 4559: * ! 4560: * DUMMY CODE BLOCK USED FOR UNDEFINED LABELS ! 4561: * ! 4562: STNDL DAC L$UND CODE PTR POINTS TO UNDEFINED LBL ! 4563: * ! 4564: * DUMMY OPERATOR BLOCK USED FOR UNDEFINED OPERATORS ! 4565: * ! 4566: STNDO DAC O$OUN PTR TO UNDEFINED OPERATOR ERR CALL ! 4567: DAC 0 DUMMY FARGS COUNT FOR CALL CIRCUIT ! 4568: * ! 4569: * STANDARD VARIABLE BLOCK. THIS BLOCK IS USED TO INITIALIZE ! 4570: * THE FIRST SEVEN FIELDS OF A NEWLY CONSTRUCTED VRBLK. ! 4571: * ITS FORMAT IS TIED TO THE VRBLK DEFINITIONS (SEE GTNVR). ! 4572: * ! 4573: STNVR DAC B$VRL VRGET ! 4574: DAC B$VRS VRSTO ! 4575: DAC NULLS VRVAL ! 4576: DAC B$VRG VRTRA ! 4577: DAC STNDL VRLBL ! 4578: DAC STNDF VRFNC ! 4579: DAC 0 VRNXT ! 4580: EJC ! 4581: * ! 4582: * MESSAGES USED IN END OF RUN PROCESSING (STOPR) ! 4583: * ! 4584: STPM1 DAC B$SCL IN STATEMENT ! 4585: DAC 12 ! 4586: DTC /IN STATEMENT/ ! 4587: * ! 4588: STPM2 DAC B$SCL ! 4589: DAC 14 ! 4590: DTC /STMTS EXECUTED/ ! 4591: * ! 4592: STPM3 DAC B$SCL ! 4593: DAC 13 ! 4594: DTC /RUN TIME-MSEC/ ! 4595: * ! 4596: STPM4 DAC B$SCL ! 4597: DAC 12 ! 4598: DTC $MCSEC / STMT$ ! 4599: * ! 4600: STPM5 DAC B$SCL ! 4601: DAC 13 ! 4602: DTC /REGENERATIONS/ ! 4603: * ! 4604: * CHARS FOR /TU/ ENDING CODE ! 4605: * ! 4606: STRTU DTC /TU/ ! 4607: * ! 4608: * TABLE USED BY CONVERT FUNCTION TO CHECK DATATYPE NAME ! 4609: * THE ENTRIES ARE ORDERED TO CORRESPOND TO BRANCH TABLE ! 4610: * IN S$CNV ! 4611: * ! 4612: SVCTB DAC SCSTR STRING ! 4613: DAC SCINT INTEGER ! 4614: DAC SCNAM NAME ! 4615: DAC SCPAT PATTERN ! 4616: DAC SCARR ARRAY ! 4617: DAC SCTAB TABLE ! 4618: DAC SCEXP EXPRESSION ! 4619: DAC SCCOD CODE ! 4620: DAC SCNUM NUMERIC ! 4621: DAC SCREA REAL ! 4622: DAC SCBUF BUFFER ! 4623: DAC 0 ZERO MARKS END OF LIST ! 4624: EJC ! 4625: * ! 4626: * MESSAGES (SCBLK FORMAT) USED BY TRACE PROCEDURES ! 4627: * ! 4628: * ! 4629: TMASB DAC B$SCL ASTERISKS FOR TRACE STATEMENT NO ! 4630: DAC 13 ! 4631: DTC /************ / ! 4632: ! 4633: * ! 4634: TMBEB DAC B$SCL BLANK-EQUAL-BLANK ! 4635: DAC 3 ! 4636: DTC / = / ! 4637: * ! 4638: * DUMMY TRBLK FOR EXPRESSION VARIABLE ! 4639: * ! 4640: TRBEV DAC B$TRT DUMMY TRBLK ! 4641: * ! 4642: * DUMMY TRBLK FOR KEYWORD VARIABLE ! 4643: * ! 4644: TRBKV DAC B$TRT DUMMY TRBLK ! 4645: * ! 4646: * DUMMY CODE BLOCK TO RETURN CONTROL TO TRXEQ PROCEDURE ! 4647: * ! 4648: TRXDR DAC O$TXR BLOCK POINTS TO RETURN ROUTINE ! 4649: TRXDC DAC TRXDR POINTER TO BLOCK ! 4650: EJC ! 4651: * ! 4652: * STANDARD VARIABLE BLOCKS ! 4653: * ! 4654: * SEE SVBLK FORMAT FOR FULL DETAILS OF THE FORMAT. THE ! 4655: * VRBLKS ARE ORDERED BY LENGTH AND WITHIN EACH LENGTH THE ! 4656: * ORDER IS ALPHABETICAL BY NAME OF THE VARIABLE. ! 4657: * ! 4658: V$EQF DBC SVFPR EQ ! 4659: DAC 2 ! 4660: DTC /EQ/ ! 4661: DAC S$EQF ! 4662: DAC 2 ! 4663: * ! 4664: V$GEF DBC SVFPR GE ! 4665: DAC 2 ! 4666: DTC /GE/ ! 4667: DAC S$GEF ! 4668: DAC 2 ! 4669: * ! 4670: V$GTF DBC SVFPR GT ! 4671: DAC 2 ! 4672: DTC /GT/ ! 4673: DAC S$GTF ! 4674: DAC 2 ! 4675: * ! 4676: V$LEF DBC SVFPR LE ! 4677: DAC 2 ! 4678: DTC /LE/ ! 4679: DAC S$LEF ! 4680: DAC 2 ! 4681: * ! 4682: V$LTF DBC SVFPR LT ! 4683: DAC 2 ! 4684: DTC /LT/ ! 4685: DAC S$LTF ! 4686: DAC 2 ! 4687: * ! 4688: V$NEF DBC SVFPR NE ! 4689: DAC 2 ! 4690: DTC /NE/ ! 4691: DAC S$NEF ! 4692: DAC 2 ! 4693: * ! 4694: V$ANY DBC SVFNP ANY ! 4695: DAC 3 ! 4696: DTC /ANY/ ! 4697: DAC S$ANY ! 4698: DAC 1 ! 4699: * ! 4700: V$ARB DBC SVKVC ARB ! 4701: DAC 3 ! 4702: DTC /ARB/ ! 4703: DAC K$ARB ! 4704: DAC NDARB ! 4705: EJC ! 4706: * ! 4707: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 4708: * ! 4709: V$ARG DBC SVFNN ARG ! 4710: DAC 3 ! 4711: DTC /ARG/ ! 4712: DAC S$ARG ! 4713: DAC 2 ! 4714: * ! 4715: V$BAL DBC SVKVC BAL ! 4716: DAC 3 ! 4717: DTC /BAL/ ! 4718: DAC K$BAL ! 4719: DAC NDBAL ! 4720: * ! 4721: V$END DBC SVLBL END ! 4722: DAC 3 ! 4723: DTC /END/ ! 4724: DAC L$END ! 4725: * ! 4726: V$LEN DBC SVFNP LEN ! 4727: DAC 3 ! 4728: DTC /LEN/ ! 4729: DAC S$LEN ! 4730: DAC 1 ! 4731: * ! 4732: V$LEQ DBC SVFPR LEQ ! 4733: DAC 3 ! 4734: DTC /LEQ/ ! 4735: DAC S$LEQ ! 4736: DAC 2 ! 4737: * ! 4738: V$LGE DBC SVFPR LGE ! 4739: DAC 3 ! 4740: DTC /LGE/ ! 4741: DAC S$LGE ! 4742: DAC 2 ! 4743: * ! 4744: V$LGT DBC SVFPR LGT ! 4745: DAC 3 ! 4746: DTC /LGT/ ! 4747: DAC S$LGT ! 4748: DAC 2 ! 4749: * ! 4750: V$LLE DBC SVFPR LLE ! 4751: DAC 3 ! 4752: DTC /LLE/ ! 4753: DAC S$LLE ! 4754: DAC 2 ! 4755: EJC ! 4756: * ! 4757: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 4758: * ! 4759: V$LLT DBC SVFPR LLT ! 4760: DAC 3 ! 4761: DTC /LLT/ ! 4762: DAC S$LLT ! 4763: DAC 2 ! 4764: * ! 4765: V$LNE DBC SVFPR LNE ! 4766: DAC 3 ! 4767: DTC /LNE/ ! 4768: DAC S$LNE ! 4769: DAC 2 ! 4770: * ! 4771: V$POS DBC SVFNP POS ! 4772: DAC 3 ! 4773: DTC /POS/ ! 4774: DAC S$POS ! 4775: DAC 1 ! 4776: * ! 4777: V$REM DBC SVKVC REM ! 4778: DAC 3 ! 4779: DTC /REM/ ! 4780: DAC K$REM ! 4781: DAC NDREM ! 4782: * ! 4783: V$SET DBC SVFNN SET ! 4784: DAC 3 ! 4785: DTC /SET/ ! 4786: DAC S$SET ! 4787: DAC 3 ! 4788: * ! 4789: V$TAB DBC SVFNP TAB ! 4790: DAC 3 ! 4791: DTC /TAB/ ! 4792: DAC S$TAB ! 4793: DAC 1 ! 4794: * ! 4795: V$CAS DBC SVKNM CASE ! 4796: DAC 4 ! 4797: DTC /CASE/ ! 4798: DAC K$CAS ! 4799: * ! 4800: V$CHR DBC SVFNP CHAR ! 4801: DAC 4 ! 4802: DTC /CHAR/ ! 4803: DAC S$CHR ! 4804: DAC 1 ! 4805: * ! 4806: V$COD DBC SVFNK CODE ! 4807: DAC 4 ! 4808: DTC /CODE/ ! 4809: DAC K$COD ! 4810: DAC S$COD ! 4811: DAC 1 ! 4812: * ! 4813: V$COP DBC SVFNN COPY ! 4814: DAC 4 ! 4815: DTC /COPY/ ! 4816: DAC S$COP ! 4817: DAC 1 ! 4818: EJC ! 4819: * ! 4820: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 4821: * ! 4822: V$DAT DBC SVFNN DATA ! 4823: DAC 4 ! 4824: DTC /DATA/ ! 4825: DAC S$DAT ! 4826: DAC 1 ! 4827: * ! 4828: V$DTE DBC SVFNN DATE ! 4829: DAC 4 ! 4830: DTC /DATE/ ! 4831: DAC S$DTE ! 4832: DAC 0 ! 4833: * ! 4834: V$DMP DBC SVFNK DUMP ! 4835: DAC 4 ! 4836: DTC /DUMP/ ! 4837: DAC K$DMP ! 4838: DAC S$DMP ! 4839: DAC 1 ! 4840: * ! 4841: V$DUP DBC SVFNN DUPL ! 4842: DAC 4 ! 4843: DTC /DUPL/ ! 4844: DAC S$DUP ! 4845: DAC 2 ! 4846: * ! 4847: V$EVL DBC SVFNN EVAL ! 4848: DAC 4 ! 4849: DTC /EVAL/ ! 4850: DAC S$EVL ! 4851: DAC 1 ! 4852: * ! 4853: V$EXT DBC SVFNN EXIT ! 4854: DAC 4 ! 4855: DTC /EXIT/ ! 4856: DAC S$EXT ! 4857: DAC 1 ! 4858: * ! 4859: V$FAL DBC SVKVC FAIL ! 4860: DAC 4 ! 4861: DTC /FAIL/ ! 4862: DAC K$FAL ! 4863: DAC NDFAL ! 4864: * ! 4865: V$HST DBC SVFNN HOST ! 4866: DAC 4 ! 4867: DTC /HOST/ ! 4868: DAC S$HST ! 4869: DAC 3 ! 4870: EJC ! 4871: * ! 4872: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 4873: * ! 4874: V$ITM DBC SVFNF ITEM ! 4875: DAC 4 ! 4876: DTC /ITEM/ ! 4877: DAC S$ITM ! 4878: DAC 999 ! 4879: * ! 4880: V$LOD DBC SVFNN LOAD ! 4881: DAC 4 ! 4882: DTC /LOAD/ ! 4883: DAC S$LOD ! 4884: DAC 2 ! 4885: * ! 4886: V$LPD DBC SVFNP LPAD ! 4887: DAC 4 ! 4888: DTC /LPAD/ ! 4889: DAC S$LPD ! 4890: DAC 3 ! 4891: * ! 4892: V$RPD DBC SVFNP RPAD ! 4893: DAC 4 ! 4894: DTC /RPAD/ ! 4895: DAC S$RPD ! 4896: DAC 3 ! 4897: * ! 4898: V$RPS DBC SVFNP RPOS ! 4899: DAC 4 ! 4900: DTC /RPOS/ ! 4901: DAC S$RPS ! 4902: DAC 1 ! 4903: * ! 4904: V$RTB DBC SVFNP RTAB ! 4905: DAC 4 ! 4906: DTC /RTAB/ ! 4907: DAC S$RTB ! 4908: DAC 1 ! 4909: * ! 4910: V$SI$ DBC SVFNP SIZE ! 4911: DAC 4 ! 4912: DTC /SIZE/ ! 4913: DAC S$SI$ ! 4914: DAC 1 ! 4915: * ! 4916: * ! 4917: V$SRT DBC SVFNN SORT ! 4918: DAC 4 ! 4919: DTC /SORT/ ! 4920: DAC S$SRT ! 4921: DAC 2 ! 4922: V$SPN DBC SVFNP SPAN ! 4923: DAC 4 ! 4924: DTC /SPAN/ ! 4925: DAC S$SPN ! 4926: DAC 1 ! 4927: EJC ! 4928: * ! 4929: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 4930: * ! 4931: V$STN DBC SVKNM STNO ! 4932: DAC 4 ! 4933: DTC /STNO/ ! 4934: DAC K$STN ! 4935: * ! 4936: V$TIM DBC SVFNN TIME ! 4937: DAC 4 ! 4938: DTC /TIME/ ! 4939: DAC S$TIM ! 4940: DAC 0 ! 4941: * ! 4942: V$TRM DBC SVFNK TRIM ! 4943: DAC 4 ! 4944: DTC /TRIM/ ! 4945: DAC K$TRM ! 4946: DAC S$TRM ! 4947: DAC 1 ! 4948: * ! 4949: V$ABE DBC SVKNM ABEND ! 4950: DAC 5 ! 4951: DTC /ABEND/ ! 4952: DAC K$ABE ! 4953: * ! 4954: V$ABO DBC SVKVL ABORT ! 4955: DAC 5 ! 4956: DTC /ABORT/ ! 4957: DAC K$ABO ! 4958: DAC L$ABO ! 4959: DAC NDABO ! 4960: * ! 4961: V$APP DBC SVFNF APPLY ! 4962: DAC 5 ! 4963: DTC /APPLY/ ! 4964: DAC S$APP ! 4965: DAC 999 ! 4966: * ! 4967: V$ABN DBC SVFNP ARBNO ! 4968: DAC 5 ! 4969: DTC /ARBNO/ ! 4970: DAC S$ABN ! 4971: DAC 1 ! 4972: * ! 4973: V$ARR DBC SVFNN ARRAY ! 4974: DAC 5 ! 4975: DTC /ARRAY/ ! 4976: DAC S$ARR ! 4977: DAC 2 ! 4978: EJC ! 4979: * ! 4980: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 4981: * ! 4982: V$BRK DBC SVFNP BREAK ! 4983: DAC 5 ! 4984: DTC /BREAK/ ! 4985: DAC S$BRK ! 4986: DAC 1 ! 4987: * ! 4988: V$CLR DBC SVFNN CLEAR ! 4989: DAC 5 ! 4990: DTC /CLEAR/ ! 4991: DAC S$CLR ! 4992: DAC 1 ! 4993: * ! 4994: V$EJC DBC SVFNN EJECT ! 4995: DAC 5 ! 4996: DTC /EJECT/ ! 4997: DAC S$EJC ! 4998: DAC 1 ! 4999: * ! 5000: V$FEN DBC SVFPK FENCE ! 5001: DAC 5 ! 5002: DTC /FENCE/ ! 5003: DAC K$FEN ! 5004: DAC S$FNC ! 5005: DAC 1 ! 5006: DAC NDFEN ! 5007: * ! 5008: V$FLD DBC SVFNN FIELD ! 5009: DAC 5 ! 5010: DTC /FIELD/ ! 5011: DAC S$FLD ! 5012: DAC 2 ! 5013: * ! 5014: V$IDN DBC SVFPR IDENT ! 5015: DAC 5 ! 5016: DTC /IDENT/ ! 5017: DAC S$IDN ! 5018: DAC 2 ! 5019: * ! 5020: V$INP DBC SVFNK INPUT ! 5021: DAC 5 ! 5022: DTC /INPUT/ ! 5023: DAC K$INP ! 5024: DAC S$INP ! 5025: DAC 3 ! 5026: * ! 5027: V$LOC DBC SVFNN LOCAL ! 5028: DAC 5 ! 5029: DTC /LOCAL/ ! 5030: DAC S$LOC ! 5031: DAC 2 ! 5032: EJC ! 5033: * ! 5034: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 5035: * ! 5036: V$OPS DBC SVFNN OPSYN ! 5037: DAC 5 ! 5038: DTC /OPSYN/ ! 5039: DAC S$OPS ! 5040: DAC 3 ! 5041: * ! 5042: V$RMD DBC SVFNP REMDR ! 5043: DAC 5 ! 5044: DTC /REMDR/ ! 5045: DAC S$RMD ! 5046: DAC 2 ! 5047: * ! 5048: V$RSR DBC SVFNN RSORT ! 5049: DAC 5 ! 5050: DTC /RSORT/ ! 5051: DAC S$RSR ! 5052: DAC 2 ! 5053: * ! 5054: V$TBL DBC SVFNN TABLE ! 5055: DAC 5 ! 5056: DTC /TABLE/ ! 5057: DAC S$TBL ! 5058: DAC 3 ! 5059: * ! 5060: V$TRA DBC SVFNK TRACE ! 5061: DAC 5 ! 5062: DTC /TRACE/ ! 5063: DAC K$TRA ! 5064: DAC S$TRA ! 5065: DAC 4 ! 5066: * ! 5067: V$ANC DBC SVKNM ANCHOR ! 5068: DAC 6 ! 5069: DTC /ANCHOR/ ! 5070: DAC K$ANC ! 5071: * ! 5072: V$APN DBC SVFNN ! 5073: DAC 6 ! 5074: DTC /APPEND/ ! 5075: DAC S$APN ! 5076: DAC 2 ! 5077: * ! 5078: V$BKX DBC SVFNP BREAKX ! 5079: DAC 6 ! 5080: DTC /BREAKX/ ! 5081: DAC S$BKX ! 5082: DAC 1 ! 5083: * ! 5084: V$BUF DBC SVFNN BUFFER ! 5085: DAC 6 ! 5086: DTC /BUFFER/ ! 5087: DAC S$BUF ! 5088: DAC 2 ! 5089: * ! 5090: V$DEF DBC SVFNN DEFINE ! 5091: DAC 6 ! 5092: DTC /DEFINE/ ! 5093: DAC S$DEF ! 5094: DAC 2 ! 5095: * ! 5096: V$DET DBC SVFNN DETACH ! 5097: DAC 6 ! 5098: DTC /DETACH/ ! 5099: DAC S$DET ! 5100: DAC 1 ! 5101: EJC ! 5102: * ! 5103: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 5104: * ! 5105: V$DIF DBC SVFPR DIFFER ! 5106: DAC 6 ! 5107: DTC /DIFFER/ ! 5108: DAC S$DIF ! 5109: DAC 2 ! 5110: * ! 5111: V$FTR DBC SVKNM FTRACE ! 5112: DAC 6 ! 5113: DTC /FTRACE/ ! 5114: DAC K$FTR ! 5115: * ! 5116: V$INS DBC SVFNN INSERT ! 5117: DAC 6 ! 5118: DTC /INSERT/ ! 5119: DAC S$INS ! 5120: DAC 4 ! 5121: * ! 5122: V$LST DBC SVKNM LASTNO ! 5123: DAC 6 ! 5124: DTC /LASTNO/ ! 5125: DAC K$LST ! 5126: * ! 5127: V$NAY DBC SVFNP NOTANY ! 5128: DAC 6 ! 5129: DTC /NOTANY/ ! 5130: DAC S$NAY ! 5131: DAC 1 ! 5132: * ! 5133: V$OUP DBC SVFNK OUTPUT ! 5134: DAC 6 ! 5135: DTC /OUTPUT/ ! 5136: DAC K$OUP ! 5137: DAC S$OUP ! 5138: DAC 3 ! 5139: * ! 5140: V$RET DBC SVLBL RETURN ! 5141: DAC 6 ! 5142: DTC /RETURN/ ! 5143: DAC L$RTN ! 5144: * ! 5145: V$REW DBC SVFNN REWIND ! 5146: DAC 6 ! 5147: DTC /REWIND/ ! 5148: DAC S$REW ! 5149: DAC 1 ! 5150: * ! 5151: V$STT DBC SVFNN STOPTR ! 5152: DAC 6 ! 5153: DTC /STOPTR/ ! 5154: DAC S$STT ! 5155: DAC 2 ! 5156: EJC ! 5157: * ! 5158: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 5159: * ! 5160: V$SUB DBC SVFNN SUBSTR ! 5161: DAC 6 ! 5162: DTC /SUBSTR/ ! 5163: DAC S$SUB ! 5164: DAC 3 ! 5165: * ! 5166: V$UNL DBC SVFNN UNLOAD ! 5167: DAC 6 ! 5168: DTC /UNLOAD/ ! 5169: DAC S$UNL ! 5170: DAC 1 ! 5171: * ! 5172: V$COL DBC SVFNN COLLECT ! 5173: DAC 7 ! 5174: DTC /COLLECT/ ! 5175: DAC S$COL ! 5176: DAC 1 ! 5177: * ! 5178: V$CNV DBC SVFNN CONVERT ! 5179: DAC 7 ! 5180: DTC /CONVERT/ ! 5181: DAC S$CNV ! 5182: DAC 2 ! 5183: * ! 5184: V$ENF DBC SVFNN ENDFILE ! 5185: DAC 7 ! 5186: DTC /ENDFILE/ ! 5187: DAC S$ENF ! 5188: DAC 1 ! 5189: * ! 5190: V$ETX DBC SVKNM ERRTEXT ! 5191: DAC 7 ! 5192: DTC /ERRTEXT/ ! 5193: DAC K$ETX ! 5194: * ! 5195: V$ERT DBC SVKNM ERRTYPE ! 5196: DAC 7 ! 5197: DTC /ERRTYPE/ ! 5198: DAC K$ERT ! 5199: * ! 5200: V$FRT DBC SVLBL FRETURN ! 5201: DAC 7 ! 5202: DTC /FRETURN/ ! 5203: DAC L$FRT ! 5204: * ! 5205: V$INT DBC SVFPR INTEGER ! 5206: DAC 7 ! 5207: DTC /INTEGER/ ! 5208: DAC S$INT ! 5209: DAC 1 ! 5210: * ! 5211: V$NRT DBC SVLBL NRETURN ! 5212: DAC 7 ! 5213: DTC /NRETURN/ ! 5214: DAC L$NRT ! 5215: EJC ! 5216: * ! 5217: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 5218: * ! 5219: * ! 5220: V$PFL DBC SVKNM PROFILE ! 5221: DAC 7 ! 5222: DTC /PROFILE/ ! 5223: DAC K$PFL ! 5224: * ! 5225: V$RPL DBC SVFNP REPLACE ! 5226: DAC 7 ! 5227: DTC /REPLACE/ ! 5228: DAC S$RPL ! 5229: DAC 3 ! 5230: * ! 5231: V$RVS DBC SVFNP REVERSE ! 5232: DAC 7 ! 5233: DTC /REVERSE/ ! 5234: DAC S$RVS ! 5235: DAC 1 ! 5236: * ! 5237: V$RTN DBC SVKNM RTNTYPE ! 5238: DAC 7 ! 5239: DTC /RTNTYPE/ ! 5240: DAC K$RTN ! 5241: * ! 5242: V$STX DBC SVFNN SETEXIT ! 5243: DAC 7 ! 5244: DTC /SETEXIT/ ! 5245: DAC S$STX ! 5246: DAC 1 ! 5247: * ! 5248: V$STC DBC SVKNM STCOUNT ! 5249: DAC 7 ! 5250: DTC /STCOUNT/ ! 5251: DAC K$STC ! 5252: * ! 5253: V$STL DBC SVKNM STLIMIT ! 5254: DAC 7 ! 5255: DTC /STLIMIT/ ! 5256: DAC K$STL ! 5257: * ! 5258: V$SUC DBC SVKVC SUCCEED ! 5259: DAC 7 ! 5260: DTC /SUCCEED/ ! 5261: DAC K$SUC ! 5262: DAC NDSUC ! 5263: * ! 5264: V$ALP DBC SVKWC ALPHABET ! 5265: DAC 8 ! 5266: DTC /ALPHABET/ ! 5267: DAC K$ALP ! 5268: * ! 5269: V$CNT DBC SVLBL CONTINUE ! 5270: DAC 8 ! 5271: DTC /CONTINUE/ ! 5272: DAC L$CNT ! 5273: EJC ! 5274: * ! 5275: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 5276: * ! 5277: V$DTP DBC SVFNP DATATYPE ! 5278: DAC 8 ! 5279: DTC /DATATYPE/ ! 5280: DAC S$DTP ! 5281: DAC 1 ! 5282: * ! 5283: V$ERL DBC SVKNM ERRLIMIT ! 5284: DAC 8 ! 5285: DTC /ERRLIMIT/ ! 5286: DAC K$ERL ! 5287: * ! 5288: V$FNC DBC SVKNM FNCLEVEL ! 5289: DAC 8 ! 5290: DTC /FNCLEVEL/ ! 5291: DAC K$FNC ! 5292: * ! 5293: V$MXL DBC SVKNM MAXLNGTH ! 5294: DAC 8 ! 5295: DTC /MAXLNGTH/ ! 5296: DAC K$MXL ! 5297: * ! 5298: V$TER DBC 0 TERMINAL ! 5299: DAC 8 ! 5300: DTC /TERMINAL/ ! 5301: DAC 0 ! 5302: * ! 5303: V$PRO DBC SVFNN PROTOTYPE ! 5304: DAC 9 ! 5305: DTC /PROTOTYPE/ ! 5306: DAC S$PRO ! 5307: DAC 1 ! 5308: * ! 5309: DBC 0 DUMMY ENTRY TO END LIST ! 5310: DAC 10 LENGTH GT 9 (PROTOTYPE) ! 5311: EJC ! 5312: * ! 5313: * LIST OF SVBLK POINTERS FOR KEYWORDS TO BE DUMPED. THE ! 5314: * LIST IS IN THE ORDER WHICH APPEARS ON THE DUMP OUTPUT. ! 5315: * ! 5316: VDMKW DAC V$ANC ANCHOR ! 5317: DAC V$CAS CCASE ! 5318: DAC V$COD CODE ! 5319: DAC V$DMP DUMP ! 5320: DAC V$ERL ERRLIMIT ! 5321: DAC V$ETX ERRTEXT ! 5322: DAC V$ERT ERRTYPE ! 5323: DAC V$FNC FNCLEVEL ! 5324: DAC V$FTR FTRACE ! 5325: DAC V$INP INPUT ! 5326: DAC V$LST LASTNO ! 5327: DAC V$MXL MAXLENGTH ! 5328: DAC V$OUP OUTPUT ! 5329: DAC V$PFL PROFILE ! 5330: DAC V$RTN RTNTYPE ! 5331: DAC V$STC STCOUNT ! 5332: DAC V$STL STLIMIT ! 5333: DAC V$STN STNO ! 5334: DAC V$TRA TRACE ! 5335: DAC V$TRM TRIM ! 5336: DAC 0 END OF LIST ! 5337: * ! 5338: * TABLE USED BY GTNVR TO SEARCH SVBLK LISTS ! 5339: * ! 5340: VSRCH DAC 0 DUMMY ENTRY TO GET PROPER INDEXING ! 5341: DAC V$EQF START OF 1 CHAR VARIABLES (NONE) ! 5342: DAC V$EQF START OF 2 CHAR VARIABLES ! 5343: DAC V$ANY START OF 3 CHAR VARIABLES ! 5344: DAC V$CAS START OF 4 CHAR VARIABLES ! 5345: DAC V$ABE START OF 5 CHAR VARIABLES ! 5346: DAC V$ANC START OF 6 CHAR VARIABLES ! 5347: DAC V$COL START OF 7 CHAR VARIABLES ! 5348: DAC V$ALP START OF 8 CHAR VARIABLES ! 5349: DAC V$PRO START OF 9 CHAR VARIABLES ! 5350: TTL S P I T B O L -- WORKING STORAGE SECTION ! 5351: * ! 5352: * THE WORKING STORAGE SECTION CONTAINS AREAS WHICH ARE ! 5353: * CHANGED DURING EXECUTION OF THE PROGRAM. THE VALUE ! 5354: * ASSEMBLED IS THE INITIAL VALUE BEFORE EXECUTION STARTS. ! 5355: * ! 5356: * ALL THESE AREAS ARE FIXED LENGTH AREAS. VARIABLE LENGTH ! 5357: * DATA IS STORED IN THE STATIC OR DYNAMIC REGIONS OF THE ! 5358: * ALLOCATED DATA AREAS. ! 5359: * ! 5360: * THE VALUES IN THIS AREA ARE DESCRIBED EITHER AS WORK ! 5361: * AREAS OR AS GLOBAL VALUES. A WORK AREA IS USED IN AN ! 5362: * EPHEMERAL MANNER AND THE VALUE IS NOT SAVED FROM ONE ! 5363: * ENTRY INTO A ROUTINE TO ANOTHER. A GLOBAL VALUE IS A ! 5364: * LESS TEMPORARY LOCATION WHOSE VALUE IS SAVED FROM ONE ! 5365: * CALL TO ANOTHER. ! 5366: * ! 5367: * A GENERAL PART OF THE APPROACH IN THIS PROGRAM IS NOT ! 5368: * TO OVERLAP WORK AREAS BETWEEN PROCEDURES EVEN THOUGH A ! 5369: * SMALL AMOUNT OF SPACE COULD BE SAVED. SUCH OVERLAP IS ! 5370: * CONSIDERED A SOURCE OF PROGRAM ERRORS AND DECREASES THE ! 5371: * INFORMATION LEFT BEHIND AFTER A SYSTEM CRASH OF ANY KIND. ! 5372: * ! 5373: * THE NAMES OF THESE LOCATIONS ARE LABELS WITH FIVE LETTER ! 5374: * (A-Y,$) NAMES. AS FAR AS POSSIBLE THE ORDER IS KEPT ! 5375: * ALPHABETICAL BY THESE NAMES BUT IN SOME CASES THERE ! 5376: * ARE SLIGHT DEPARTURES CAUSED BY OTHER ORDER REQUIREMENTS. ! 5377: * ! 5378: * UNLESS OTHERWISE DOCUMENTED, THE ORDER OF WORK AREAS ! 5379: * DOES NOT AFFECT THE EXECUTION OF THE SPITBOL PROGRAM. ! 5380: * ! 5381: SEC START OF WORKING STORAGE SECTION ! 5382: EJC ! 5383: * ! 5384: * THIS AREA IS NOT CLEARED BY INITIAL CODE ! 5385: * ! 5386: CMLAB DAC B$SCL STRING USED TO CHECK LABEL LEGALITY ! 5387: DAC 2 ! 5388: DTC / / ! 5389: * ! 5390: * LABEL TO MARK START OF WORK AREA ! 5391: * ! 5392: AAAAA DAC 0 ! 5393: * ! 5394: * WORK AREAS FOR ALLOC PROCEDURE ! 5395: * ! 5396: ALDYN DAC 0 AMOUNT OF DYNAMIC STORE ! 5397: ALFSF DIC +0 FACTOR IN FREE STORE PCNTAGE CHECK ! 5398: ALLIA DIC +0 DUMP IA ! 5399: ALLSV DAC 0 SAVE WB IN ALLOC ! 5400: * ! 5401: * WORK AREAS FOR ALOST PROCEDURE ! 5402: * ! 5403: ALSTA DAC 0 SAVE WA IN ALOST ! 5404: * ! 5405: * SAVE AREAS FOR ARRAY FUNCTION (S$ARR) ! 5406: * ! 5407: ARCDM DAC 0 COUNT DIMENSIONS ! 5408: ARNEL DIC +0 COUNT ELEMENTS ! 5409: ARPTR DAC 0 OFFSET PTR INTO ARBLK ! 5410: ARSVL DIC +0 SAVE INTEGER LOW BOUND ! 5411: EJC ! 5412: * WORK AREAS FOR ARREF ROUTINE ! 5413: * ! 5414: ARFSI DIC +0 SAVE CURRENT EVOLVING SUBSCRIPT ! 5415: ARFXS DAC 0 SAVE BASE STACK POINTER ! 5416: * ! 5417: * WORK AREAS FOR B$EFC BLOCK ROUTINE ! 5418: * ! 5419: BEFOF DAC 0 SAVE OFFSET PTR INTO EFBLK ! 5420: * ! 5421: * WORK AREAS FOR B$PFC BLOCK ROUTINE ! 5422: * ! 5423: BPFPF DAC 0 SAVE PFBLK POINTER ! 5424: BPFSV DAC 0 SAVE OLD FUNCTION VALUE ! 5425: BPFXT DAC 0 POINTER TO STACKED ARGUMENTS ! 5426: * ! 5427: * SAVE AREAS FOR COLLECT FUNCTION (S$COL) ! 5428: * ! 5429: CLSVI DIC +0 SAVE INTEGER ARGUMENT ! 5430: * ! 5431: * GLOBAL VALUES FOR CMPIL PROCEDURE ! 5432: * ! 5433: CMERC DAC 0 COUNT OF INITIAL COMPILE ERRORS ! 5434: CMPXS DAC 0 SAVE STACK PTR IN CASE OF ERRORS ! 5435: CMPSN DAC 1 NUMBER OF NEXT STATEMENT TO COMPILE ! 5436: CMPSS DAC 0 SAVE SUBROUTINE STACK PTR ! 5437: * ! 5438: * WORK AREA FOR CNCRD ! 5439: * ! 5440: CNSCC DAC 0 POINTER TO CONTROL CARD STRING ! 5441: CNSWC DAC 0 WORD COUNT ! 5442: CNR$T DAC 0 POINTER TO R$TTL OR R$STL ! 5443: CNTTL DAC 0 FLAG FOR -TITLE, -STITL ! 5444: * ! 5445: * WORK AREAS FOR CONVERT FUNCTION (S$CNV) ! 5446: * ! 5447: CNVTP DAC 0 SAVE PTR INTO SCVTB ! 5448: * ! 5449: * FLAG FOR SUPPRESSION OF COMPILATION STATISTICS. ! 5450: * ! 5451: CPSTS DAC 0 SUPPRESS COMP. STATS IF NON ZERO ! 5452: * ! 5453: * GLOBAL VALUES FOR CONTROL CARD SWITCHES ! 5454: * ! 5455: CSWDB DAC 0 0/1 FOR -SINGLE/-DOUBLE ! 5456: CSWER DAC 0 0/1 FOR -ERRORS/-NOERRORS ! 5457: CSWEX DAC 0 0/1 FOR -EXECUTE/-NOEXECUTE ! 5458: CSWFL DAC 1 0/1 FOR -NOFAIL/-FAIL ! 5459: CSWIN DAC INILN XXX FOR -INXXX ! 5460: CSWLS DAC 1 0/1 FOR -NOLIST/-LIST ! 5461: CSWNO DAC 0 0/1 FOR -OPTIMISE/-NOOPT ! 5462: CSWPR DAC 0 0/1 FOR -NOPRINT/-PRINT ! 5463: * ! 5464: * GLOBAL LOCATION USED BY PATST PROCEDURE ! 5465: * ! 5466: CTMSK DBC 0 LAST BIT POSITION USED IN R$CTP ! 5467: CURID DAC 0 CURRENT ID VALUE ! 5468: EJC ! 5469: * ! 5470: * GLOBAL VALUE FOR CDWRD PROCEDURE ! 5471: * ! 5472: CWCOF DAC 0 NEXT WORD OFFSET IN CURRENT CCBLK ! 5473: * ! 5474: * WORK AREAS FOR DATA FUNCTION (S$DAT) ! 5475: * ! 5476: DATDV DAC 0 SAVE VRBLK PTR FOR DATATYPE NAME ! 5477: DATXS DAC 0 SAVE INITIAL STACK POINTER ! 5478: * ! 5479: * WORK AREAS FOR DEFINE FUNCTION (S$DEF) ! 5480: * ! 5481: DEFLB DAC 0 SAVE VRBLK PTR FOR LABEL ! 5482: DEFNA DAC 0 COUNT FUNCTION ARGUMENTS ! 5483: DEFVR DAC 0 SAVE VRBLK PTR FOR FUNCTION NAME ! 5484: DEFXS DAC 0 SAVE INITIAL STACK POINTER ! 5485: * ! 5486: * WORK AREAS FOR DUMPR PROCEDURE ! 5487: * ! 5488: DMARG DAC 0 DUMP ARGUMENT ! 5489: DMPKB DAC B$KVT DUMMY KVBLK FOR USE IN DUMPR ! 5490: DMPKT DAC TRBKV KVVAR TRBLK POINTER ! 5491: DMPKN DAC 0 KEYWORD NUMBER (MUST FOLLOW DMPKB) ! 5492: DMPSA DAC 0 PRESERVE WA OVER PRTVL CALL ! 5493: DMPSV DAC 0 GENERAL SCRATCH SAVE ! 5494: DMVCH DAC 0 CHAIN POINTER FOR VARIABLE BLOCKS ! 5495: DMPCH DAC 0 SAVE SORTED VRBLK CHAIN POINTER ! 5496: * ! 5497: * GLOBAL LOCATIONS FOR DYNAMIC STORAGE POINTERS ! 5498: * ! 5499: DNAMB DAC 0 START OF DYNAMIC AREA ! 5500: DNAMP DAC 0 NEXT AVAILABLE LOC IN DYNAMIC AREA ! 5501: DNAME DAC 0 END OF AVAILABLE DYNAMIC AREA ! 5502: * ! 5503: * WORK AREA FOR DTACH ! 5504: * ! 5505: DTCNB DAC 0 NAME BASE ! 5506: DTCNM DAC 0 NAME PTR ! 5507: * ! 5508: * WORK AREAS FOR DUPL FUNCTION (S$DUP) ! 5509: * ! 5510: DUPSI DIC +0 STORE INTEGER STRING LENGTH ! 5511: * ! 5512: * WORK AREA FOR ENDFILE (S$ENF) ! 5513: * ! 5514: ENFCH DAC 0 FOR IOCHN CHAIN HEAD ! 5515: * ! 5516: * WORK AREA FOR ERROR PROCESSING. ! 5517: * ! 5518: ERICH DAC 0 COPY ERROR REPORTS TO INT.CHAN IF 1 ! 5519: ERLST DAC 0 FOR LISTR WHEN ERRORS GO TO INT.CH. ! 5520: ERRFT DAC 0 FATAL ERROR FLAG ! 5521: ERRSP DAC 0 ERROR SUPPRESSION FLAG ! 5522: EJC ! 5523: * ! 5524: * DUMP AREA FOR ERTEX ! 5525: * ! 5526: ERTWA DAC 0 SAVE WA ! 5527: ERTWB DAC 0 SAVE WB ! 5528: * ! 5529: * GLOBAL VALUES FOR EVALI ! 5530: * ! 5531: EVLIN DAC P$LEN DUMMY PATTERN BLOCK PCODE ! 5532: EVLIS DAC 0 POINTER TO SUBSEQUENT NODE ! 5533: EVLIV DAC 0 VALUE OF PARAMETER ! 5534: * WORK AREA FOR EXPAN ! 5535: * ! 5536: EXPSV DAC 0 SAVE OP DOPE VECTOR POINTER ! 5537: * ! 5538: * FLAG FOR SUPPRESSION OF EXECUTION STATS ! 5539: * ! 5540: EXSTS DAC 0 SUPPRESS EXEC STATS IF SET ! 5541: * ! 5542: * GLOBAL VALUES FOR EXFAL AND RETURN ! 5543: * ! 5544: FLPRT DAC 0 LOCATION OF FAIL OFFSET FOR RETURN ! 5545: FLPTR DAC 0 LOCATION OF FAILURE OFFSET ON STACK ! 5546: * ! 5547: * WORK AREAS FOR GBCOL PROCEDURE ! 5548: * ! 5549: GBCFL DAC 0 GARBAGE COLLECTOR ACTIVE FLAG ! 5550: GBCLM DAC 0 POINTER TO LAST MOVE BLOCK (PASS 3) ! 5551: GBCNM DAC 0 DUMMY FIRST MOVE BLOCK ! 5552: GBCNS DAC 0 REST OF DUMMY BLOCK (FOLLOWS GBCNM) ! 5553: GBSVA DAC 0 SAVE WA ! 5554: GBSVB DAC 0 SAVE WB ! 5555: GBSVC DAC 0 SAVE WC ! 5556: * ! 5557: * GLOBAL LOCATION TO COUNT GARBAGE COLLECTIONS (GBCOL) ! 5558: * ! 5559: GBCNT DAC 0 COUNT OF GARBAGE COLLECTIONS ! 5560: * ! 5561: * WORK AREAS FOR GTNVR PROCEDURE ! 5562: * ! 5563: GNVHE DAC 0 PTR TO END OF HASH CHAIN ! 5564: GNVNW DAC 0 NUMBER OF WORDS IN STRING NAME ! 5565: GNVSA DAC 0 SAVE WA ! 5566: GNVSB DAC 0 SAVE WB ! 5567: GNVSP DAC 0 POINTER INTO VSRCH TABLE ! 5568: GNVST DAC 0 POINTER TO CHARS OF STRING ! 5569: * ! 5570: * GLOBAL VALUE FOR GTCOD AND GTEXP ! 5571: * ! 5572: GTCEF DAC 0 SAVE FAIL PTR IN CASE OF ERROR ! 5573: * ! 5574: * WORK AREAS FOR GTINT ! 5575: * ! 5576: GTINA DAC 0 SAVE WA ! 5577: GTINB DAC 0 SAVE WB ! 5578: EJC ! 5579: * ! 5580: * WORK AREAS FOR GTNUM PROCEDURE ! 5581: * ! 5582: GTNNF DAC 0 ZERO/NONZERO FOR RESULT +/- ! 5583: GTNSI DIC +0 GENERAL INTEGER SAVE ! 5584: GTNDF DAC 0 0/1 FOR DEC POINT SO FAR NO/YES ! 5585: GTNES DAC 0 ZERO/NONZERO EXPONENT +/- ! 5586: GTNEX DIC +0 REAL EXPONENT ! 5587: GTNSC DAC 0 SCALE (PLACES AFTER POINT) ! 5588: GTNSR DRC +0.0 GENERAL REAL SAVE ! 5589: GTNRD DAC 0 FLAG FOR OK REAL NUMBER ! 5590: * ! 5591: * WORK AREAS FOR GTPAT PROCEDURE ! 5592: * ! 5593: GTPSB DAC 0 SAVE WB ! 5594: * ! 5595: * WORK AREAS FOR GTSTG PROCEDURE ! 5596: * ! 5597: GTSSF DAC 0 0/1 FOR RESULT +/- ! 5598: GTSVC DAC 0 SAVE WC ! 5599: GTSVB DAC 0 SAVE WB ! 5600: GTSWK DAC 0 PTR TO WORK AREA FOR GTSTG ! 5601: GTSES DAC 0 CHAR + OR - FOR EXPONENT +/- ! 5602: GTSRS DRC +0.0 GENERAL REAL SAVE ! 5603: * ! 5604: * GLOBAL LOCATIONS (CONSTANTS) FOR GTSTG PROCEDURE ! 5605: * ! 5606: GTSRN DRC +0.0 ROUNDING FACTOR 0.5*10**-CFP$S ! 5607: GTSSC DRC +0.0 SCALING VALUE 10**CFP$S ! 5608: * ! 5609: * WORK AREAS FOR GTVAR PROCEDURE ! 5610: * ! 5611: GTVRC DAC 0 SAVE WC ! 5612: * ! 5613: * FLAG FOR HEADER PRINTING ! 5614: * ! 5615: HEADP DAC 0 HEADER PRINTED FLAG ! 5616: * ! 5617: * GLOBAL VALUES FOR VARIABLE HASH TABLE ! 5618: * ! 5619: HSHNB DIC +0 NUMBER OF HASH BUCKETS ! 5620: HSHTB DAC 0 POINTER TO START OF VRBLK HASH TABL ! 5621: HSHTE DAC 0 POINTER PAST END OF VRBLK HASH TABL ! 5622: * ! 5623: * WORK AREA FOR INIT ! 5624: * ! 5625: INISS DAC 0 SAVE SUBROUTINE STACK PTR ! 5626: INITR DAC 0 SAVE TERMINAL FLAG ! 5627: * ! 5628: * SAVE AREA FOR INSBF ! 5629: * ! 5630: INSAB DAC 0 ENTRY WA + ENTRY WB ! 5631: INSSA DAC 0 SAVE ENTRY WA ! 5632: INSSB DAC 0 SAVE ENTRY WB ! 5633: INSSC DAC 0 SAVE ENTRY WC ! 5634: * ! 5635: * WORK AREAS FOR IOPUT ! 5636: * ! 5637: IOPTT DAC 0 TYPE OF ASSOCIATION ! 5638: EJC ! 5639: * ! 5640: * GLOBAL VALUES FOR KEYWORD VALUES WHICH ARE STORED AS ONE ! 5641: * WORD INTEGERS. THESE VALUES MUST BE ASSEMBLED IN THE ! 5642: * FOLLOWING ORDER (AS DICTATED BY K$XXX DEFINITION VALUES). ! 5643: * ! 5644: KVABE DAC 0 ABEND ! 5645: KVANC DAC 0 ANCHOR ! 5646: KVCAS DAC 0 CASE ! 5647: KVCOD DAC 0 CODE ! 5648: KVDMP DAC 0 DUMP ! 5649: KVERL DAC 0 ERRLIMIT ! 5650: KVERT DAC 0 ERRTYPE ! 5651: KVFTR DAC 0 FTRACE ! 5652: KVINP DAC 1 INPUT ! 5653: KVMXL DAC 5000 MAXLENGTH ! 5654: KVOUP DAC 1 OUTPUT ! 5655: KVPFL DAC 0 PROFILE ! 5656: KVTRA DAC 0 TRACE ! 5657: KVTRM DAC 0 TRIM ! 5658: KVFNC DAC 0 FNCLEVEL ! 5659: KVLST DAC 0 LASTNO ! 5660: KVSTN DAC 0 STNO ! 5661: * ! 5662: * GLOBAL VALUES FOR OTHER KEYWORDS ! 5663: * ! 5664: KVALP DAC 0 ALPHABET ! 5665: KVRTN DAC NULLS RTNTYPE (SCBLK POINTER) ! 5666: KVSTL DIC +50000 STLIMIT ! 5667: KVSTC DIC +50000 STCOUNT (COUNTS DOWN FROM STLIMIT) ! 5668: * ! 5669: * WORK AREAS FOR LOAD FUNCTION ! 5670: * ! 5671: LODFN DAC 0 POINTER TO VRBLK FOR FUNC NAME ! 5672: LODNA DAC 0 COUNT NUMBER OF ARGUMENTS ! 5673: * ! 5674: * GLOBAL VALUES FOR LISTR PROCEDURE ! 5675: * ! 5676: LSTLC DAC 0 COUNT LINES ON SOURCE LIST PAGE ! 5677: LSTNP DAC 0 MAX NUMBER OF LINES ON PAGE ! 5678: LSTPF DAC 1 SET NONZERO IF CURRENT IMAGE LISTED ! 5679: LSTPG DAC 0 CURRENT SOURCE LIST PAGE NUMBER ! 5680: LSTPO DAC 0 OFFSET TO PAGE NNN MESSAGE ! 5681: LSTSN DAC 0 REMEMBER LAST STMNUM LISTED ! 5682: * ! 5683: * MAXIMUM SIZE OF SPITBOL OBJECTS ! 5684: * ! 5685: MXLEN DAC 0 INITIALISED BY SYSMX CALL ! 5686: * ! 5687: * EXECUTION CONTROL VARIABLE ! 5688: * ! 5689: NOXEQ DAC 0 SET NON-ZERO TO INHIBIT EXECUTION ! 5690: * ! 5691: * PROFILER GLOBAL VALUES AND WORK LOCATIONS ! 5692: * ! 5693: PFDMP DAC 0 SET NON-0 IF &PROFILE SET NON-0 ! 5694: PFFNC DAC 0 SET NON-0 IF FUNCT JUST ENTERED ! 5695: PFSTM DIC +0 TO STORE STARTING TIME OF STMT ! 5696: PFETM DIC +0 TO STORE ENDING TIME OF STMT ! 5697: PFSVW DAC 0 TO SAVE A W-REG ! 5698: PFTBL DAC 0 GETS ADRS OF (IMAG) TABLE BASE ! 5699: PFNTE DAC 0 NR OF TABLE ENTRIES ! 5700: PFSTE DIC +0 GETS INT REP OF TABLE ENTRY SIZE ! 5701: * ! 5702: EJC ! 5703: * ! 5704: * GLOBAL VALUES USED IN PATTERN MATCH ROUTINES ! 5705: * ! 5706: PMDFL DAC 0 PATTERN ASSIGNMENT FLAG ! 5707: PMHBS DAC 0 HISTORY STACK BASE POINTER ! 5708: PMSSL DAC 0 LENGTH OF SUBJECT STRING IN CHARS ! 5709: * ! 5710: * FLAGS USED FOR STANDARD FILE LISTING OPTIONS ! 5711: * ! 5712: PRICH DAC 0 PRINTER ON INTERACTIVE CHANNEL ! 5713: PRSTD DAC 0 TESTED BY PRTPG ! 5714: PRSTO DAC 0 STANDARD LISTING OPTION FLAG ! 5715: * ! 5716: * GLOBAL VALUE FOR PRTNM PROCEDURE ! 5717: * ! 5718: PRNMV DAC 0 VRBLK PTR FROM LAST NAME SEARCH ! 5719: * ! 5720: * WORK AREAS FOR PRTNM PROCEDURE ! 5721: * ! 5722: PRNSI DIC +0 SCRATCH INTEGER LOC ! 5723: * ! 5724: * WORK AREAS FOR PRTSN PROCEDURE ! 5725: * ! 5726: PRSNA DAC 0 SAVE WA ! 5727: * ! 5728: * GLOBAL VALUES FOR PRINT PROCEDURES ! 5729: * ! 5730: PRBUF DAC 0 PTR TO PRINT BFR IN STATIC ! 5731: PRECL DAC 0 EXTENDED/COMPACT LISTING FLAG ! 5732: PRLEN DAC 0 LENGTH OF PRINT BUFFER IN CHARS ! 5733: PRLNW DAC 0 LENGTH OF PRINT BUFFER IN WORDS ! 5734: PROFS DAC 0 OFFSET TO NEXT LOCATION IN PRBUF ! 5735: PRTEF DAC 0 ENDFILE FLAG ! 5736: * ! 5737: * WORK AREAS FOR PRTST PROCEDURE ! 5738: * ! 5739: PRSVA DAC 0 SAVE WA ! 5740: PRSVB DAC 0 SAVE WB ! 5741: PRSVC DAC 0 SAVE CHAR COUNTER ! 5742: * ! 5743: * WORK AREA FOR PRTNL ! 5744: * ! 5745: PRTSA DAC 0 SAVE WA ! 5746: PRTSB DAC 0 SAVE WB ! 5747: * ! 5748: * WORK AREA FOR PRTVL ! 5749: * ! 5750: PRVSI DAC 0 SAVE IDVAL ! 5751: * ! 5752: * WORK AREAS FOR PATTERN MATCH ROUTINES ! 5753: * ! 5754: PSAVE DAC 0 TEMPORARY SAVE FOR CURRENT NODE PTR ! 5755: PSAVC DAC 0 SAVE CURSOR IN P$SPN, P$STR ! 5756: EJC ! 5757: * ! 5758: * AMOUNT OF MEMORY RESERVED FOR END OF EXECUTION ! 5759: * ! 5760: RSMEM DAC 0 RESERVE MEMORY ! 5761: * ! 5762: * WORK AREAS FOR RETRN ROUTINE ! 5763: * ! 5764: RTNBP DAC 0 TO SAVE A BLOCK POINTER ! 5765: RTNFV DAC 0 NEW FUNCTION VALUE (RESULT) ! 5766: RTNSV DAC 0 OLD FUNCTION VALUE (SAVED VALUE) ! 5767: * ! 5768: * RELOCATABLE GLOBAL VALUES ! 5769: * ! 5770: * ALL THE POINTERS IN THIS SECTION CAN POINT TO BLOCKS IN ! 5771: * THE DYNAMIC STORAGE AREA AND MUST BE RELOCATED BY THE ! 5772: * GARBAGE COLLECTOR. THEY ARE IDENTIFIED BY R$XXX NAMES. ! 5773: * ! 5774: R$AAA DAC 0 START OF RELOCATABLE VALUES ! 5775: R$ARF DAC 0 ARRAY BLOCK POINTER FOR ARREF ! 5776: R$CCB DAC 0 PTR TO CCBLK BEING BUILT (CDWRD) ! 5777: R$CIM DAC 0 PTR TO CURRENT COMPILER INPUT STR ! 5778: R$CMP DAC 0 COPY OF R$CIM USED IN CMPIL ! 5779: R$CNI DAC 0 PTR TO NEXT COMPILER INPUT STRING ! 5780: R$CNT DAC 0 CDBLK POINTER FOR SETEXIT CONTINUE ! 5781: R$COD DAC 0 POINTER TO CURRENT CDBLK OR EXBLK ! 5782: R$CTP DAC 0 PTR TO CURRENT CTBLK FOR PATST ! 5783: R$ERT DAC 0 TRBLK POINTER FOR ERRTYPE TRACE ! 5784: R$ETX DAC NULLS POINTER TO ERRTEXT STRING ! 5785: R$EXS DAC 0 = SAVE XL IN EXPDM ! 5786: R$FCB DAC 0 FCBLK CHAIN HEAD ! 5787: R$FNC DAC 0 TRBLK POINTER FOR FNCLEVEL TRACE ! 5788: R$GTC DAC 0 KEEP CODE PTR FOR GTCOD,GTEXP ! 5789: R$IO1 DAC 0 FILE ARG1 FOR IOPUT ! 5790: R$IO2 DAC 0 FILE ARG2 FOR IOPUT ! 5791: R$IOF DAC 0 FCBLK PTR OR 0 ! 5792: R$ION DAC 0 NAME BASE PTR ! 5793: R$IOP DAC 0 PREDECESSOR BLOCK PTR FOR IOPUT ! 5794: R$IOT DAC 0 TRBLK PTR FOR IOPUT ! 5795: R$PMB DAC 0 BUFFER PTR IN PATTERN MATCH ! 5796: R$PMS DAC 0 SUBJECT STRING PTR IN PATTERN MATCH ! 5797: R$RA2 DAC 0 REPLACE SECOND ARGUMENT LAST TIME ! 5798: R$RA3 DAC 0 REPLACE THIRD ARGUMENT LAST TIME ! 5799: R$RPT DAC 0 PTR TO CTBLK REPLACE TABLE LAST USD ! 5800: R$SCP DAC 0 SAVE POINTER FROM LAST SCANE CALL ! 5801: R$SXL DAC 0 PRESERVE XL IN SORTC ! 5802: R$SXR DAC 0 PRESERVE XR IN SORTA/SORTC ! 5803: R$STC DAC 0 TRBLK POINTER FOR STCOUNT TRACE ! 5804: R$STL DAC 0 SOURCE LISTING SUB-TITLE ! 5805: R$SXC DAC 0 CODE (CDBLK) PTR FOR SETEXIT TRAP ! 5806: R$TTL DAC NULLS SOURCE LISTING TITLE ! 5807: R$XSC DAC 0 STRING POINTER FOR XSCAN ! 5808: EJC ! 5809: * ! 5810: * THE REMAINING POINTERS IN THIS LIST ARE USED TO POINT ! 5811: * TO FUNCTION BLOCKS FOR NORMALLY UNDEFINED OPERATORS. ! 5812: * ! 5813: R$UBA DAC STNDO BINARY AT ! 5814: R$UBM DAC STNDO BINARY AMPERSAND ! 5815: R$UBN DAC STNDO BINARY NUMBER SIGN ! 5816: R$UBP DAC STNDO BINARY PERCENT ! 5817: R$UBT DAC STNDO BINARY NOT ! 5818: R$UUB DAC STNDO UNARY VERTICAL BAR ! 5819: R$UUE DAC STNDO UNARY EQUAL ! 5820: R$UUN DAC STNDO UNARY NUMBER SIGN ! 5821: R$UUP DAC STNDO UNARY PERCENT ! 5822: R$UUS DAC STNDO UNARY SLASH ! 5823: R$UUX DAC STNDO UNARY EXCLAMATION ! 5824: R$YYY DAC 0 LAST RELOCATABLE LOCATION ! 5825: * ! 5826: * WORK AREAS FOR SUBSTR FUNCTION (S$SUB) ! 5827: * ! 5828: SBSSV DAC 0 SAVE THIRD ARGUMENT ! 5829: * ! 5830: * GLOBAL LOCATIONS USED IN SCAN PROCEDURE ! 5831: * ! 5832: SCNBL DAC 0 SET NON-ZERO IF SCANNED PAST BLANKS ! 5833: SCNCC DAC 0 NON-ZERO TO SCAN CONTROL CARD NAME ! 5834: SCNGO DAC 0 SET NON-ZERO TO SCAN GOTO FIELD ! 5835: SCNIL DAC 0 LENGTH OF CURRENT INPUT IMAGE ! 5836: SCNPT DAC 0 POINTER TO NEXT LOCATION IN R$CIM ! 5837: SCNRS DAC 0 SET NON-ZERO TO SIGNAL RESCAN ! 5838: SCNTP DAC 0 SAVE SYNTAX TYPE FROM LAST CALL ! 5839: * ! 5840: * WORK AREAS FOR SCAN PROCEDURE ! 5841: * ! 5842: SCNSA DAC 0 SAVE WA ! 5843: SCNSB DAC 0 SAVE WB ! 5844: SCNSC DAC 0 SAVE WC ! 5845: SCNSE DAC 0 START OF CURRENT ELEMENT ! 5846: SCNOF DAC 0 SAVE OFFSET ! 5847: EJC ! 5848: * ! 5849: * WORK AREA USED BY SORTA, SORTC, SORTF, SORTH ! 5850: * ! 5851: SRTDF DAC 0 DATATYPE FIELD NAME ! 5852: SRTFD DAC 0 FOUND DFBLK ADDRESS ! 5853: SRTFF DAC 0 FOUND FIELD NAME ! 5854: SRTFO DAC 0 OFFSET TO FIELD NAME ! 5855: SRTNR DAC 0 NUMBER OF ROWS ! 5856: SRTOF DAC 0 OFFSET WITHIN ROW TO SORT KEY ! 5857: SRTRT DAC 0 ROOT OFFSET ! 5858: SRTS1 DAC 0 SAVE OFFSET 1 ! 5859: SRTS2 DAC 0 SAVE OFFSET 2 ! 5860: SRTSC DAC 0 SAVE WC ! 5861: SRTSF DAC 0 SORT ARRAY FIRST ROW OFFSET ! 5862: SRTSN DAC 0 SAVE N ! 5863: SRTSO DAC 0 OFFSET TO A(0) ! 5864: SRTSR DAC 0 0 , NON-ZERO FOR SORT, RSORT ! 5865: SRTST DAC 0 STRIDE FROM ONE ROW TO NEXT ! 5866: SRTWC DAC 0 DUMP WC ! 5867: * ! 5868: * GLOBAL VALUE FOR INDICATING STAGE (SEE ERROR SECTION) ! 5869: * ! 5870: STAGE DAC 0 INITIAL VALUE = INITIAL COMPILE ! 5871: * ! 5872: * GLOBAL VALUES DEFINING EXTENT OF STATIC AREA (ALOST) ! 5873: * ! 5874: STATB DAC 0 START OF STATIC AREA ! 5875: STATE DAC 0 END OF STATIC AREA ! 5876: EJC ! 5877: * ! 5878: * GLOBAL STACK POINTER ! 5879: * ! 5880: STBAS DAC 0 POINTER PAST STACK BASE ! 5881: * ! 5882: * WORK AREAS FOR STOPR ROUTINE ! 5883: * ! 5884: STPSI DIC +0 SAVE VALUE OF STCOUNT ! 5885: STPTI DIC +0 SAVE TIME ELAPSED ! 5886: * ! 5887: * GLOBAL VALUES FOR SETEXIT FUNCTION (S$STX) ! 5888: * ! 5889: STXOF DAC 0 FAILURE OFFSET ! 5890: STXVR DAC NULLS VRBLK POINTER OR NULL ! 5891: * ! 5892: * WORK AREAS FOR TFIND PROCEDURE ! 5893: * ! 5894: TFNSI DIC +0 NUMBER OF HEADERS ! 5895: * ! 5896: * GLOBAL VALUE FOR TIME KEEPING ! 5897: * ! 5898: TIMSX DIC +0 TIME AT START OF EXECUTION ! 5899: TIMUP DAC 0 SET WHEN TIME UP OCCURS ! 5900: * ! 5901: * WORK AREAS FOR XSCAN PROCEDURE ! 5902: * ! 5903: XSCRT DAC 0 SAVE RETURN CODE ! 5904: XSCWB DAC 0 SAVE REGISTER WB ! 5905: * ! 5906: * GLOBAL VALUES FOR XSCAN AND XSCNI PROCEDURES ! 5907: * ! 5908: XSOFS DAC 0 OFFSET TO CURRENT LOCATION IN R$XSC ! 5909: * ! 5910: * LABEL TO MARK END OF WORK AREA ! 5911: * ! 5912: YYYYY DAC 0 ! 5913: TTL S P I T B O L -- INITIALIZATION ! 5914: * ! 5915: * INITIALISATION ! 5916: * THE FOLLOWING SECTION RECEIVES CONTROL FROM THE SYSTEM ! 5917: * AT THE START OF A RUN WITH THE REGISTERS SET AS FOLLOWS. ! 5918: * ! 5919: * (XS) POINTS PAST STACK BASE ! 5920: * (XR) POINTS TO FIRST WORD OF DATA AREA ! 5921: * (XL) POINTS TO LAST WORD OF DATA AREA ! 5922: * ! 5923: SEC START OF PROGRAM SECTION ! 5924: JSR SYSTM INITIALISE TIMER ! 5925: * ! 5926: * INITIALISE WORK AREA (ESSENTIAL FOR BATCHED RUNS) ! 5927: * ! 5928: MOV XR,WB PRESERVE XR ! 5929: MOV =YYYYY,WA POINT TO END OF WORK AREA ! 5930: SUB =AAAAA,WA GET LENGTH OF WORK AREA ! 5931: BTW WA CONVERT TO WORDS ! 5932: LCT WA,WA COUNT FOR LOOP ! 5933: MOV =AAAAA,XR SET UP INDEX REGISTER ! 5934: * ! 5935: * CLEAR WORK SPACE ! 5936: * ! 5937: INI01 ZER (XR)+ CLEAR A WORD ! 5938: BCT WA,INI01 LOOP TILL DONE ! 5939: MOV =STNDO,WA UNDEFINED OPERATORS POINTER ! 5940: MOV =R$YYY,WC POINT TO TABLE END ! 5941: SUB =R$UBA,WC LENGTH OF UNDEF. OPERATORS TABLE ! 5942: BTW WC CONVERT TO WORDS ! 5943: LCT WC,WC LOOP COUNTER ! 5944: MOV =R$UBA,XR SET UP XR ! 5945: * ! 5946: * SET CORRECT VALUE INTO UNDEFINED OPERATORS TABLE ! 5947: * ! 5948: INI02 MOV WA,(XR)+ STORE VALUE ! 5949: BCT WC,INI02 LOOP TILL ALL DONE ! 5950: MOV =NUM01,WA GET A 1 ! 5951: MOV WA,CMPSN STATEMENT NO ! 5952: MOV WA,CSWFL NOFAIL ! 5953: MOV WA,CSWLS LIST ! 5954: MOV WA,KVINP INPUT ! 5955: MOV WA,KVOUP OUTPUT ! 5956: MOV WA,LSTPF NOTHING FOR LISTR YET ! 5957: MOV =INILN,WA INPUT IMAGE LENGTH ! 5958: MOV WA,CSWIN -IN72 ! 5959: MOV =B$KVT,DMPKB DUMP ! 5960: MOV =TRBKV,DMPKT DUMP ! 5961: MOV =P$LEN,EVLIN EVAL ! 5962: EJC ! 5963: MOV =NULLS,WA GET NULLSTRING POINTER ! 5964: MOV WA,KVRTN RETURN ! 5965: MOV WA,R$ETX ERRTEXT ! 5966: MOV WA,R$TTL TITLE FOR LISTING ! 5967: MOV WA,STXVR SETEXIT ! 5968: STI TIMSX STORE TIME IN CORRECT PLACE ! 5969: LDI STLIM GET DEFAULT STLIMIT ! 5970: STI KVSTL STATEMENT LIMIT ! 5971: STI KVSTC STATEMENT COUNT ! 5972: MOV WB,STATB STORE START ADRS OF STATIC ! 5973: MOV *E$SRS,RSMEM RESERVE MEMORY ! 5974: MOV XS,STBAS STORE STACK BASE ! 5975: SSS INISS SAVE S-R STACK PTR ! 5976: * ! 5977: * NOW CONVERT FREE STORE PERCENTAGE TO A SUITABLE FACTOR ! 5978: * FOR EASY TESTING IN ALLOC ROUTINE. ! 5979: * ! 5980: LDI INTVH GET 100 ! 5981: DVI ALFSP FORM 100 / ALFSP ! 5982: STI ALFSF STORE THE FACTOR ! 5983: * ! 5984: * INITIALIZE VALUES FOR REAL CONVERSION ROUTINE ! 5985: * ! 5986: LCT WB,=CFP$S LOAD COUNTER FOR SIGNIFICANT DIGITS ! 5987: LDR REAV1 LOAD 1.0 ! 5988: * ! 5989: * LOOP TO COMPUTE 10**(MAX NUMBER SIGNIFICANT DIGITS) ! 5990: * ! 5991: INI03 MLR REAVT * 10.0 ! 5992: BCT WB,INI03 LOOP TILL DONE ! 5993: STR GTSSC STORE 10**(MAX SIG DIGITS) ! 5994: LDR REAP5 LOAD 0.5 ! 5995: DVR GTSSC COMPUTE 0.5*10**(MAX SIG DIGITS) ! 5996: STR GTSRN STORE AS ROUNDING BIAS ! 5997: ZER WC SET TO READ PARAMETERS ! 5998: JSR PRPAR READ THEM ! 5999: EJC ! 6000: * ! 6001: * NOW COMPUTE STARTING ADDRESS FOR DYNAMIC STORE AND IF ! 6002: * NECESSARY REQUEST MORE MEMORY. ! 6003: * ! 6004: SUB *E$SRS,XL ALLOW FOR RESERVE MEMORY ! 6005: MOV PRLEN,WA GET PRINT BUFFER LENGTH ! 6006: ADD =CFP$A,WA ADD NO. OF CHARS IN ALPHABET ! 6007: ADD =NSTMX,WA ADD CHARS FOR GTSTG BFR ! 6008: CTB WA,8 CONVERT TO BYTES, ALLOWING A MARGIN ! 6009: MOV STATB,XR POINT TO STATIC BASE ! 6010: ADD WA,XR INCREMENT FOR ABOVE BUFFERS ! 6011: ADD *E$HNB,XR INCREMENT FOR HASH TABLE ! 6012: ADD *E$STS,XR BUMP FOR INITIAL STATIC BLOCK ! 6013: JSR SYSMX GET MXLEN ! 6014: MOV WA,KVMXL PROVISIONALLY STORE AS MAXLNGTH ! 6015: MOV WA,MXLEN AND AS MXLEN ! 6016: BGT XR,WA,INI06 SKIP IF STATIC HI EXCEEDS MXLEN ! 6017: MOV WA,XR USE MXLEN INSTEAD ! 6018: ICA XR MAKE BIGGER THAN MXLEN ! 6019: * ! 6020: * HERE TO STORE VALUES WHICH MARK INITIAL DIVISION ! 6021: * OF DATA AREA INTO STATIC AND DYNAMIC ! 6022: * ! 6023: INI06 MOV XR,DNAMB DYNAMIC BASE ADRS ! 6024: MOV XR,DNAMP DYNAMIC PTR ! 6025: BNZ WA,INI07 SKIP IF NON-ZERO MXLEN ! 6026: DCA XR POINT A WORD IN FRONT ! 6027: MOV XR,KVMXL USE AS MAXLNGTH ! 6028: MOV XR,MXLEN AND AS MXLEN ! 6029: EJC ! 6030: * ! 6031: * LOOP HERE IF NECESSARY TILL ENOUGH MEMORY OBTAINED ! 6032: * SO THAT DNAME IS ABOVE DNAMB ! 6033: * ! 6034: INI07 MOV XL,DNAME STORE DYNAMIC END ADDRESS ! 6035: BLT DNAMB,XL,INI09 SKIP IF HIGH ENOUGH ! 6036: JSR SYSMM REQUEST MORE MEMORY ! 6037: WTB XR GET AS BAUS (SGD05) ! 6038: ADD XR,XL BUMP BY AMOUNT OBTAINED ! 6039: BNZ XR,INI07 TRY AGAIN ! 6040: MOV =ENDMO,XR POINT TO FAILURE MESSAGE ! 6041: MOV ENDML,WA MESSAGE LENGTH ! 6042: JSR SYSPR PRINT IT (PRTST NOT YET USABLE) ! 6043: PPM SHOULD NOT FAIL ! 6044: JSR SYSEJ PACK UP (STOPR NOT YET USABLE) ! 6045: * ! 6046: * INITIALISE PRINT BUFFER WITH BLANK WORDS ! 6047: * ! 6048: INI09 MOV PRLEN,WC NO. OF CHARS IN PRINT BFR ! 6049: MOV STATB,XR POINT TO STATIC AGAIN ! 6050: MOV XR,PRBUF PRINT BFR IS PUT AT STATIC START ! 6051: MOV =B$SCL,(XR)+ STORE STRING TYPE CODE ! 6052: MOV WC,(XR)+ AND STRING LENGTH ! 6053: CTW WC,0 GET NUMBER OF WORDS IN BUFFER ! 6054: MOV WC,PRLNW STORE FOR BUFFER CLEAR ! 6055: LCT WC,WC WORDS TO CLEAR ! 6056: * ! 6057: * LOOP TO CLEAR BUFFER ! 6058: * ! 6059: INI10 MOV NULLW,(XR)+ STORE BLANK ! 6060: BCT WC,INI10 LOOP ! 6061: * ! 6062: * INITIALIZE NUMBER OF HASH HEADERS ! 6063: * ! 6064: MOV =E$HNB,WA GET NUMBER OF HASH HEADERS ! 6065: MTI WA CONVERT TO INTEGER ! 6066: STI HSHNB STORE FOR USE BY GTNVR PROCEDURE ! 6067: LCT WA,WA COUNTER FOR CLEARING HASH TABLE ! 6068: MOV XR,HSHTB POINTER TO HASH TABLE ! 6069: * ! 6070: * LOOP TO CLEAR HASH TABLE ! 6071: * ! 6072: INI11 ZER (XR)+ BLANK A WORD ! 6073: BCT WA,INI11 LOOP ! 6074: MOV XR,HSHTE END OF HASH TABLE ADRS IS KEPT ! 6075: * ! 6076: * ALLOCATE WORK AREA FOR GTSTG CONVERSION PROCEDURE ! 6077: * ! 6078: MOV =NSTMX,WA GET MAX NUM CHARS IN OUTPUT NUMBER ! 6079: CTB WA,SCSI$ NO OF BYTES NEEDED ! 6080: MOV XR,GTSWK STORE BFR ADRS ! 6081: ADD WA,XR BUMP FOR WORK BFR ! 6082: EJC ! 6083: * ! 6084: * BUILD ALPHABET STRING FOR ALPHABET KEYWORD AND REPLACE ! 6085: * ! 6086: MOV XR,KVALP SAVE ALPHABET POINTER ! 6087: MOV =B$SCL,(XR) STRING BLK TYPE ! 6088: MOV =CFP$A,WC NO OF CHARS IN ALPHABET ! 6089: MOV WC,SCLEN(XR) STORE AS STRING LENGTH ! 6090: MOV WC,WB COPY CHAR COUNT ! 6091: CTB WB,SCSI$ NO. OF BYTES NEEDED ! 6092: ADD XR,WB CURRENT END ADDRESS FOR STATIC ! 6093: MOV WB,STATE STORE STATIC END ADRS ! 6094: LCT WC,WC LOOP COUNTER ! 6095: PSC XR POINT TO CHARS OF STRING ! 6096: ZER WB SET INITIAL CHARACTER VALUE ! 6097: * ! 6098: * LOOP TO ENTER CHARACTER CODES IN ORDER ! 6099: * ! 6100: INI12 SCH WB,(XR)+ STORE NEXT CODE ! 6101: ICV WB BUMP CODE VALUE ! 6102: BCT WC,INI12 LOOP TILL ALL STORED ! 6103: CSC XR COMPLETE STORE CHARACTERS ! 6104: * ! 6105: * INITIALIZE VARIABLE BLOCKS FOR INPUT AND OUTPUT ! 6106: * ! 6107: MOV =V$INP,XL POINT TO STRING /INPUT/ ! 6108: MOV =TRTIN,WB TRBLK TYPE FOR INPUT ! 6109: JSR INOUT PERFORM INPUT ASSOCIATION ! 6110: MOV =V$OUP,XL POINT TO STRING /OUTPUT/ ! 6111: MOV =TRTOU,WB TRBLK TYPE FOR OUTPUT ! 6112: JSR INOUT PERFORM OUTPUT ASSOCIATION ! 6113: MOV INITR,WC TERMINAL FLAG ! 6114: BZE WC,INI13 SKIP IF NO TERMINAL ! 6115: JSR PRPAR ASSOCIATE TERMINAL ! 6116: EJC ! 6117: * ! 6118: * CHECK FOR EXPIRY DATE ! 6119: * ! 6120: INI13 JSR SYSDC CALL DATE CHECK ! 6121: MOV XS,FLPTR IN CASE STACK OVERFLOWS IN COMPILER ! 6122: * ! 6123: * NOW COMPILE SOURCE INPUT CODE ! 6124: * ! 6125: JSR CMPIL CALL COMPILER ! 6126: MOV XR,R$COD SET PTR TO FIRST CODE BLOCK ! 6127: MOV =NULLS,R$TTL FORGET TITLE (REG04) ! 6128: MOV =NULLS,R$STL FORGET SUB-TITLE (REG04) ! 6129: ZER R$CIM FORGET COMPILER INPUT IMAGE ! 6130: ZER XL CLEAR DUD VALUE ! 6131: ZER WB DONT SHIFT DYNAMIC STORE UP ! 6132: JSR GBCOL CLEAR GARBAGE LEFT FROM COMPILE ! 6133: BNZ CPSTS,INIX0 SKIP IF NO LISTING OF COMP STATS ! 6134: JSR PRTPG EJECT PAGE ! 6135: * ! 6136: * PRINT COMPILE STATISTICS ! 6137: * ! 6138: MOV DNAMP,WA NEXT AVAILABLE LOC ! 6139: SUB STATB,WA MINUS START ! 6140: BTW WA CONVERT TO WORDS ! 6141: MTI WA CONVERT TO INTEGER ! 6142: MOV =ENCM1,XR POINT TO /MEMORY USED (WORDS)/ ! 6143: JSR PRTMI PRINT MESSAGE ! 6144: MOV DNAME,WA END OF MEMORY ! 6145: SUB DNAMP,WA MINUS NEXT AVAILABLE LOC ! 6146: BTW WA CONVERT TO WORDS ! 6147: MTI WA CONVERT TO INTEGER ! 6148: MOV =ENCM2,XR POINT TO /MEMORY AVAILABLE (WORDS)/ ! 6149: JSR PRTMI PRINT LINE ! 6150: MTI CMERC GET COUNT OF ERRORS AS INTEGER ! 6151: MOV =ENCM3,XR POINT TO /COMPILE ERRORS/ ! 6152: JSR PRTMI PRINT IT ! 6153: MTI GBCNT GARBAGE COLLECTION COUNT ! 6154: SBI INTV1 ADJUST FOR UNAVOIDABLE COLLECT ! 6155: MOV =STPM5,XR POINT TO /STORAGE REGENERATIONS/ ! 6156: JSR PRTMI PRINT GBCOL COUNT ! 6157: JSR SYSTM GET TIME ! 6158: SBI TIMSX GET COMPILATION TIME ! 6159: MOV =ENCM4,XR POINT TO COMPILATION TIME (MSEC)/ ! 6160: JSR PRTMI PRINT MESSAGE ! 6161: ADD =NUM05,LSTLC BUMP LINE COUNT ! 6162: BZE HEADP,INIX0 NO EJECT IF NOTHING PRINTED (SDG11) ! 6163: JSR PRTPG EJECT PRINTER ! 6164: EJC ! 6165: * ! 6166: * PREPARE NOW TO START EXECUTION ! 6167: * ! 6168: * SET DEFAULT INPUT RECORD LENGTH ! 6169: * ! 6170: INIX0 BGT CSWIN,=INILN,INIX1 SKIP IF NOT DEFAULT -IN72 USED ! 6171: MOV =INILS,CSWIN ELSE USE DEFAULT RECORD LENGTH ! 6172: * ! 6173: * RESET TIMER ! 6174: * ! 6175: INIX1 JSR SYSTM GET TIME AGAIN ! 6176: STI TIMSX STORE FOR END RUN PROCESSING ! 6177: ADD CSWEX,NOXEQ ADD -NOEXECUTE FLAG ! 6178: BNZ NOXEQ,INIX2 JUMP IF EXECUTION SUPPRESSED ! 6179: ZER GBCNT INITIALISE COLLECT COUNT ! 6180: JSR SYSBX CALL BEFORE STARTING EXECUTION ! 6181: * ! 6182: * MERGE WHEN LISTING FILE SET FOR EXECUTION ! 6183: * ! 6184: INIY0 MNZ HEADP MARK HEADERS OUT REGARDLESS ! 6185: ZER -(XS) SET FAILURE LOCATION ON STACK ! 6186: MOV XS,FLPTR SAVE PTR TO FAILURE OFFSET WORD ! 6187: MOV R$COD,XR LOAD PTR TO ENTRY CODE BLOCK ! 6188: MOV =STGXT,STAGE SET STAGE FOR EXECUTE TIME ! 6189: MOV CMPSN,PFNTE COPY STMTS COMPILED COUNT IN CASE ! 6190: JSR SYSTM TIME YET AGAIN ! 6191: STI PFSTM ! 6192: BRI (XR) START XEQ WITH FIRST STATEMENT ! 6193: * ! 6194: * HERE IF EXECUTION IS SUPPRESSED ! 6195: * ! 6196: INIX2 JSR PRTNL PRINT A BLANK LINE ! 6197: MOV =ENCM5,XR POINT TO /EXECUTION SUPPRESSED/ ! 6198: JSR PRTST PRINT STRING ! 6199: JSR PRTNL OUTPUT LINE ! 6200: ZER WA SET ABEND VALUE TO ZERO ! 6201: MOV =NINI9,WB SET SPECIAL CODE VALUE ! 6202: JSR SYSEJ END OF JOB, EXIT TO SYSTEM ! 6203: TTL S P I T B O L -- SNOBOL4 OPERATOR ROUTINES ! 6204: * ! 6205: * THIS SECTION INCLUDES ALL ROUTINES WHICH CAN BE ACCESSED ! 6206: * DIRECTLY FROM THE GENERATED CODE EXCEPT SYSTEM FUNCTIONS. ! 6207: * ! 6208: * ALL ROUTINES IN THIS SECTION START WITH A LABEL OF THE ! 6209: * FORM O$XXX WHERE XXX IS THREE LETTERS. THE GENERATED CODE ! 6210: * CONTAINS A POINTER TO THE APPROPRIATE ENTRY LABEL. ! 6211: * ! 6212: * SINCE THE GENERAL FORM OF THE GENERATED CODE CONSISTS OF ! 6213: * POINTERS TO BLOCKS WHOSE FIRST WORD IS THE ADDRESS OF THE ! 6214: * ACTUAL ENTRY POINT LABEL (O$XXX). ! 6215: * ! 6216: * THESE ROUTINES ARE IN ALPHABETICAL ORDER BY THEIR ! 6217: * ENTRY LABEL NAMES (I.E. BY THE XXX OF THE O$XXX NAME) ! 6218: * ! 6219: * THESE ROUTINES RECEIVE CONTROL AS FOLLOWS ! 6220: * ! 6221: * (CP) POINTER TO NEXT CODE WORD ! 6222: * (XS) CURRENT STACK POINTER ! 6223: EJC ! 6224: * ! 6225: * BINARY PLUS (ADDITION) ! 6226: * ! 6227: O$ADD ENT ENTRY POINT ! 6228: JSR ARITH FETCH ARITHMETIC OPERANDS ! 6229: ERR 001,ADDITION LEFT OPERAND IS NOT NUMERIC ! 6230: ERR 002,ADDITION RIGHT OPERAND IS NOT NUMERIC ! 6231: PPM OADD1 JUMP IF REAL OPERANDS ! 6232: * ! 6233: * HERE TO ADD TWO INTEGERS ! 6234: * ! 6235: ADI ICVAL(XL) ADD RIGHT OPERAND TO LEFT ! 6236: INO EXINT RETURN INTEGER IF NO OVERFLOW ! 6237: ERB 003,ADDITION CAUSED INTEGER OVERFLOW ! 6238: * ! 6239: * HERE TO ADD TWO REALS ! 6240: * ! 6241: OADD1 ADR RCVAL(XL) ADD RIGHT OPERAND TO LEFT ! 6242: RNO EXREA RETURN REAL IF NO OVERFLOW ! 6243: ERB 261,ADDITION CAUSED REAL OVERFLOW ! 6244: EJC ! 6245: * ! 6246: * UNARY PLUS (AFFIRMATION) ! 6247: * ! 6248: O$AFF ENT ENTRY POINT ! 6249: MOV (XS)+,XR LOAD OPERAND ! 6250: JSR GTNUM CONVERT TO NUMERIC ! 6251: ERR 004,AFFIRMATION OPERAND IS NOT NUMERIC ! 6252: BRN EXIXR RETURN IF CONVERTED TO NUMERIC ! 6253: EJC ! 6254: * ! 6255: * BINARY BAR (ALTERNATION) ! 6256: * ! 6257: O$ALT ENT ENTRY POINT ! 6258: MOV (XS)+,XR LOAD RIGHT OPERAND ! 6259: JSR GTPAT CONVERT TO PATTERN ! 6260: ERR 005,ALTERNATION RIGHT OPERAND IS NOT PATTERN ! 6261: * ! 6262: * MERGE HERE FROM SPECIAL (LEFT ALTERNATION) CASE ! 6263: * ! 6264: OALT1 MOV =P$ALT,WB SET PCODE FOR ALTERNATIVE NODE ! 6265: JSR PBILD BUILD ALTERNATIVE NODE ! 6266: MOV XR,XL SAVE ADDRESS OF ALTERNATIVE NODE ! 6267: MOV (XS)+,XR LOAD LEFT OPERAND ! 6268: JSR GTPAT CONVERT TO PATTERN ! 6269: ERR 006,ALTERNATION LEFT OPERAND IS NOT PATTERN ! 6270: BEQ XR,=P$ALT,OALT2 JUMP IF LEFT ARG IS ALTERNATION ! 6271: MOV XR,PTHEN(XL) SET LEFT OPERAND AS SUCCESSOR ! 6272: MOV XL,XR MOVE RESULT TO PROPER REGISTER ! 6273: BRN EXIXR JUMP FOR NEXT CODE WORD ! 6274: * ! 6275: * COME HERE IF LEFT ARGUMENT IS ITSELF AN ALTERNATION ! 6276: * ! 6277: * THE RESULT IS MORE EFFICIENT IF WE MAKE THE REPLACEMENT ! 6278: * ! 6279: * (A / B) / C = A / (B / C) ! 6280: * ! 6281: OALT2 MOV PARM1(XR),PTHEN(XL) BUILD THE (B / C) NODE ! 6282: MOV PTHEN(XR),-(XS) SET A AS NEW LEFT ARG ! 6283: MOV XL,XR SET (B / C) AS NEW RIGHT ARG ! 6284: BRN OALT1 MERGE BACK TO BUILD A / (B / C) ! 6285: EJC ! 6286: * ! 6287: * ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY NAME) ! 6288: * ! 6289: O$AMN ENT ENTRY POINT ! 6290: LCW XR LOAD NUMBER OF SUBSCRIPTS ! 6291: MOV XR,WB SET FLAG FOR BY NAME ! 6292: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE ! 6293: EJC ! 6294: * ! 6295: * ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY VALUE) ! 6296: * ! 6297: O$AMV ENT ENTRY POINT ! 6298: LCW XR LOAD NUMBER OF SUBSCRIPTS ! 6299: ZER WB SET FLAG FOR BY VALUE ! 6300: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE ! 6301: EJC ! 6302: * ! 6303: * ARRAY REFERENCE (ONE SUBSCRIPT, BY NAME) ! 6304: * ! 6305: O$AON ENT ENTRY POINT ! 6306: MOV (XS),XR LOAD SUBSCRIPT VALUE ! 6307: MOV 1(XS),XL LOAD ARRAY VALUE ! 6308: MOV (XL),WA LOAD FIRST WORD OF ARRAY OPERAND ! 6309: BEQ WA,=B$VCT,OAON2 JUMP IF VECTOR REFERENCE ! 6310: BEQ WA,=B$TBT,OAON3 JUMP IF TABLE REFERENCE ! 6311: * ! 6312: * HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE ! 6313: * ! 6314: OAON1 MOV =NUM01,XR SET NUMBER OF SUBSCRIPTS TO ONE ! 6315: MOV XR,WB SET FLAG FOR BY NAME ! 6316: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE ! 6317: * ! 6318: * HERE IF WE HAVE A VECTOR REFERENCE ! 6319: * ! 6320: OAON2 BNE (XR),=B$ICL,OAON1 USE LONG ROUTINE IF NOT INTEGER ! 6321: LDI ICVAL(XR) LOAD INTEGER SUBSCRIPT VALUE ! 6322: MFI WA,EXFAL COPY AS ADDRESS INT, FAIL IF OVFLO ! 6323: BZE WA,EXFAL FAIL IF ZERO ! 6324: ADD =VCVLB,WA COMPUTE OFFSET IN WORDS ! 6325: WTB WA CONVERT TO BYTES ! 6326: MOV WA,(XS) COMPLETE NAME ON STACK ! 6327: BLT WA,VCLEN(XL),EXITS EXIT IF SUBSCRIPT NOT TOO LARGE ! 6328: BRN EXFAL ELSE FAIL ! 6329: * ! 6330: * HERE FOR TABLE REFERENCE ! 6331: * ! 6332: OAON3 MNZ WB SET FLAG FOR NAME REFERENCE ! 6333: JSR TFIND LOCATE/CREATE TABLE ELEMENT ! 6334: PPM EXFAL FAIL IF ACCESS FAILS ! 6335: MOV XL,1(XS) STORE NAME BASE ON STACK ! 6336: MOV WA,(XS) STORE NAME OFFSET ON STACK ! 6337: BRN EXITS EXIT WITH RESULT ON STACK ! 6338: EJC ! 6339: * ! 6340: * ARRAY REFERENCE (ONE SUBSCRIPT, BY VALUE) ! 6341: * ! 6342: O$AOV ENT ENTRY POINT ! 6343: MOV (XS)+,XR LOAD SUBSCRIPT VALUE ! 6344: MOV (XS)+,XL LOAD ARRAY VALUE ! 6345: MOV (XL),WA LOAD FIRST WORD OF ARRAY OPERAND ! 6346: BEQ WA,=B$VCT,OAOV2 JUMP IF VECTOR REFERENCE ! 6347: BEQ WA,=B$TBT,OAOV3 JUMP IF TABLE REFERENCE ! 6348: * ! 6349: * HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE ! 6350: * ! 6351: OAOV1 MOV XL,-(XS) RESTACK ARRAY VALUE ! 6352: MOV XR,-(XS) RESTACK SUBSCRIPT ! 6353: MOV =NUM01,XR SET NUMBER OF SUBSCRIPTS TO ONE ! 6354: ZER WB SET FLAG FOR VALUE CALL ! 6355: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE ! 6356: * ! 6357: * HERE IF WE HAVE A VECTOR REFERENCE ! 6358: * ! 6359: OAOV2 BNE (XR),=B$ICL,OAOV1 USE LONG ROUTINE IF NOT INTEGER ! 6360: LDI ICVAL(XR) LOAD INTEGER SUBSCRIPT VALUE ! 6361: MFI WA,EXFAL MOVE AS ONE WORD INT, FAIL IF OVFLO ! 6362: BZE WA,EXFAL FAIL IF ZERO ! 6363: ADD =VCVLB,WA COMPUTE OFFSET IN WORDS ! 6364: WTB WA CONVERT TO BYTES ! 6365: BGE WA,VCLEN(XL),EXFAL FAIL IF SUBSCRIPT TOO LARGE ! 6366: JSR ACESS ACCESS VALUE ! 6367: PPM EXFAL FAIL IF ACCESS FAILS ! 6368: BRN EXIXR ELSE RETURN VALUE TO CALLER ! 6369: * ! 6370: * HERE FOR TABLE REFERENCE BY VALUE ! 6371: * ! 6372: OAOV3 ZER WB SET FLAG FOR VALUE REFERENCE ! 6373: JSR TFIND CALL TABLE SEARCH ROUTINE ! 6374: PPM EXFAL FAIL IF ACCESS FAILS ! 6375: BRN EXIXR EXIT WITH RESULT IN XR ! 6376: EJC ! 6377: * ! 6378: * ASSIGNMENT ! 6379: * ! 6380: O$ASS ENT ENTRY POINT ! 6381: * ! 6382: * O$RPL (PATTERN REPLACEMENT) MERGES HERE ! 6383: * ! 6384: OASS0 MOV (XS)+,WB LOAD VALUE TO BE ASSIGNED ! 6385: MOV (XS)+,WA LOAD NAME OFFSET ! 6386: MOV (XS),XL LOAD NAME BASE ! 6387: MOV WB,(XS) STORE ASSIGNED VALUE AS RESULT ! 6388: JSR ASIGN PERFORM ASSIGNMENT ! 6389: PPM EXFAL FAIL IF ASSIGNMENT FAILS ! 6390: BRN EXITS EXIT WITH RESULT ON STACK ! 6391: EJC ! 6392: * ! 6393: * COMPILATION ERROR ! 6394: * ! 6395: O$CER ENT ENTRY POINT ! 6396: ERB 007,COMPILATION ERROR ENCOUNTERED DURING EXECUTION ! 6397: EJC ! 6398: * ! 6399: * UNARY AT (CURSOR ASSIGNMENT) ! 6400: * ! 6401: O$CAS ENT ENTRY POINT ! 6402: MOV (XS)+,WC LOAD NAME OFFSET (PARM2) ! 6403: MOV (XS)+,XR LOAD NAME BASE (PARM1) ! 6404: MOV =P$CAS,WB SET PCODE FOR CURSOR ASSIGNMENT ! 6405: JSR PBILD BUILD NODE ! 6406: BRN EXIXR JUMP FOR NEXT CODE WORD ! 6407: EJC ! 6408: * ! 6409: * CONCATENATION ! 6410: * ! 6411: O$CNC ENT ENTRY POINT ! 6412: MOV (XS),XR LOAD RIGHT ARGUMENT ! 6413: BEQ XR,=NULLS,OCNC3 JUMP IF RIGHT ARG IS NULL ! 6414: MOV 1(XS),XL LOAD LEFT ARGUMENT ! 6415: BEQ XL,=NULLS,OCNC4 JUMP IF LEFT ARGUMENT IS NULL ! 6416: MOV =B$SCL,WA GET CONSTANT TO TEST FOR STRING ! 6417: BNE WA,(XL),OCNC2 JUMP IF LEFT ARG NOT A STRING ! 6418: BNE WA,(XR),OCNC2 JUMP IF RIGHT ARG NOT A STRING ! 6419: * ! 6420: * MERGE HERE TO CONCATENATE TWO STRINGS ! 6421: * ! 6422: OCNC1 MOV SCLEN(XL),WA LOAD LEFT ARGUMENT LENGTH ! 6423: ADD SCLEN(XR),WA COMPUTE RESULT LENGTH ! 6424: JSR ALOCS ALLOCATE SCBLK FOR RESULT ! 6425: MOV XR,1(XS) STORE RESULT PTR OVER LEFT ARGUMENT ! 6426: PSC XR PREPARE TO STORE CHARS OF RESULT ! 6427: MOV SCLEN(XL),WA GET NUMBER OF CHARS IN LEFT ARG ! 6428: PLC XL PREPARE TO LOAD LEFT ARG CHARS ! 6429: MVC MOVE CHARACTERS OF LEFT ARGUMENT ! 6430: MOV (XS)+,XL LOAD RIGHT ARG POINTER, POP STACK ! 6431: MOV SCLEN(XL),WA LOAD NUMBER OF CHARS IN RIGHT ARG ! 6432: PLC XL PREPARE TO LOAD RIGHT ARG CHARS ! 6433: MVC MOVE CHARACTERS OF RIGHT ARGUMENT ! 6434: BRN EXITS EXIT WITH RESULT ON STACK ! 6435: * ! 6436: * COME HERE IF ARGUMENTS ARE NOT BOTH STRINGS ! 6437: * ! 6438: OCNC2 JSR GTSTG CONVERT RIGHT ARG TO STRING ! 6439: PPM OCNC5 JUMP IF RIGHT ARG IS NOT STRING ! 6440: MOV XR,XL SAVE RIGHT ARG PTR ! 6441: JSR GTSTG CONVERT LEFT ARG TO STRING ! 6442: PPM OCNC6 JUMP IF LEFT ARG IS NOT A STRING ! 6443: MOV XR,-(XS) STACK LEFT ARGUMENT ! 6444: MOV XL,-(XS) STACK RIGHT ARGUMENT ! 6445: MOV XR,XL MOVE LEFT ARG TO PROPER REG ! 6446: MOV (XS),XR MOVE RIGHT ARG TO PROPER REG ! 6447: BRN OCNC1 MERGE BACK TO CONCATENATE STRINGS ! 6448: EJC ! 6449: * ! 6450: * CONCATENATION (CONTINUED) ! 6451: * ! 6452: * COME HERE FOR NULL RIGHT ARGUMENT ! 6453: * ! 6454: OCNC3 ICA XS REMOVE RIGHT ARG FROM STACK ! 6455: BRN EXITS RETURN WITH LEFT ARGUMENT ON STACK ! 6456: * ! 6457: * HERE FOR NULL LEFT ARGUMENT ! 6458: * ! 6459: OCNC4 ICA XS UNSTACK ONE ARGUMENT ! 6460: MOV XR,(XS) STORE RIGHT ARGUMENT ! 6461: BRN EXITS EXIT WITH RESULT ON STACK ! 6462: * ! 6463: * HERE IF RIGHT ARGUMENT IS NOT A STRING ! 6464: * ! 6465: OCNC5 MOV XR,XL MOVE RIGHT ARGUMENT PTR ! 6466: MOV (XS)+,XR LOAD LEFT ARG POINTER ! 6467: * ! 6468: * MERGE HERE WHEN LEFT ARGUMENT IS NOT A STRING ! 6469: * ! 6470: OCNC6 JSR GTPAT CONVERT LEFT ARG TO PATTERN ! 6471: ERR 008,CONCATENATION LEFT OPND IS NOT STRING OR PATTERN ! 6472: MOV XR,-(XS) SAVE RESULT ON STACK ! 6473: MOV XL,XR POINT TO RIGHT OPERAND ! 6474: JSR GTPAT CONVERT TO PATTERN ! 6475: ERR 009,CONCATENATION RIGHT OPD IS NOT STRING OR PATTERN ! 6476: MOV XR,XL MOVE FOR PCONC ! 6477: MOV (XS)+,XR RELOAD LEFT OPERAND PTR ! 6478: JSR PCONC CONCATENATE PATTERNS ! 6479: BRN EXIXR EXIT WITH RESULT IN XR ! 6480: EJC ! 6481: * ! 6482: * COMPLEMENTATION ! 6483: * ! 6484: O$COM ENT ENTRY POINT ! 6485: MOV (XS)+,XR LOAD OPERAND ! 6486: MOV (XR),WA LOAD TYPE WORD ! 6487: * ! 6488: * MERGE BACK HERE AFTER CONVERSION ! 6489: * ! 6490: OCOM1 BEQ WA,=B$ICL,OCOM2 JUMP IF INTEGER ! 6491: BEQ WA,=B$RCL,OCOM3 JUMP IF REAL ! 6492: JSR GTNUM ELSE CONVERT TO NUMERIC ! 6493: ERR 010,COMPLEMENTATION OPERAND IS NOT NUMERIC ! 6494: BRN OCOM1 BACK TO CHECK CASES ! 6495: * ! 6496: * HERE TO COMPLEMENT INTEGER ! 6497: * ! 6498: OCOM2 LDI ICVAL(XR) LOAD INTEGER VALUE ! 6499: NGI NEGATE ! 6500: INO EXINT RETURN INTEGER IF NO OVERFLOW ! 6501: ERB 011,COMPLEMENTATION CAUSED INTEGER OVERFLOW ! 6502: * ! 6503: * HERE TO COMPLEMENT REAL ! 6504: * ! 6505: OCOM3 LDR RCVAL(XR) LOAD REAL VALUE ! 6506: NGR NEGATE ! 6507: BRN EXREA RETURN REAL RESULT ! 6508: EJC ! 6509: * ! 6510: * BINARY SLASH (DIVISION) ! 6511: * ! 6512: O$DVD ENT ENTRY POINT ! 6513: JSR ARITH FETCH ARITHMETIC OPERANDS ! 6514: ERR 012,DIVISION LEFT OPERAND IS NOT NUMERIC ! 6515: ERR 013,DIVISION RIGHT OPERAND IS NOT NUMERIC ! 6516: PPM ODVD2 JUMP IF REAL OPERANDS ! 6517: * ! 6518: * HERE TO DIVIDE TWO INTEGERS ! 6519: * ! 6520: DVI ICVAL(XL) DIVIDE LEFT OPERAND BY RIGHT ! 6521: INO EXINT RESULT OK IF NO OVERFLOW ! 6522: ERB 014,DIVISION CAUSED INTEGER OVERFLOW ! 6523: * ! 6524: * HERE TO DIVIDE TWO REALS ! 6525: * ! 6526: ODVD2 DVR RCVAL(XL) DIVIDE LEFT OPERAND BY RIGHT ! 6527: RNO EXREA RETURN REAL IF NO OVERFLOW ! 6528: ERB 262,DIVISION CAUSED REAL OVERFLOW ! 6529: EJC ! 6530: * ! 6531: * EXPONENTIATION ! 6532: * ! 6533: O$EXP ENT ENTRY POINT ! 6534: MOV (XS)+,XR LOAD EXPONENT ! 6535: JSR GTNUM CONVERT TO NUMBER ! 6536: ERR 015,EXPONENTIATION RIGHT OPERAND IS NOT NUMERIC ! 6537: BNE WA,=B$ICL,OEXP7 JUMP IF REAL ! 6538: MOV XR,XL MOVE EXPONENT ! 6539: MOV (XS)+,XR LOAD BASE ! 6540: JSR GTNUM CONVERT TO NUMERIC ! 6541: ERR 016,EXPONENTIATION LEFT OPERAND IS NOT NUMERIC ! 6542: LDI ICVAL(XL) LOAD EXPONENT ! 6543: ILT OEXP8 ERROR IF NEGATIVE EXPONENT ! 6544: BEQ WA,=B$RCL,OEXP3 JUMP IF BASE IS REAL ! 6545: * ! 6546: * HERE TO EXPONENTIATE AN INTEGER ! 6547: * ! 6548: MFI WA,OEXP2 CONVERT EXPONENT TO 1 WORD INTEGER ! 6549: LCT WA,WA SET LOOP COUNTER ! 6550: LDI INTV1 LOAD INITIAL VALUE OF 1 ! 6551: BNZ WA,OEXP1 JUMP IF NON-ZERO EXPONENT ! 6552: INE EXINT GIVE ZERO AS RESULT FOR NONZERO**0 ! 6553: BRN OEXP4 ELSE ERROR OF 0**0 ! 6554: * ! 6555: * LOOP TO PERFORM EXPONENTIATION ! 6556: * ! 6557: OEXP1 MLI ICVAL(XR) MULTIPLY BY BASE ! 6558: IOV OEXP2 JUMP IF OVERFLOW ! 6559: BCT WA,OEXP1 LOOP BACK TILL COMPUTATION COMPLETE ! 6560: BRN EXINT THEN RETURN INTEGER RESULT ! 6561: * ! 6562: * HERE IF INTEGER OVERFLOW ! 6563: * ! 6564: OEXP2 ERB 017,EXPONENTIATION CAUSED INTEGER OVERFLOW ! 6565: EJC ! 6566: * ! 6567: * EXPONENTIATION (CONTINUED) ! 6568: * ! 6569: * HERE TO EXPONENTIATE A REAL ! 6570: * ! 6571: OEXP3 MFI WA,OEXP6 CONVERT EXPONENT TO ONE WORD ! 6572: LCT WA,WA SET LOOP COUNTER ! 6573: LDR REAV1 LOAD 1.0 AS INITIAL VALUE ! 6574: BNZ WA,OEXP5 JUMP IF NON-ZERO EXPONENT ! 6575: RNE EXREA RETURN 1.0 IF NONZERO**ZERO ! 6576: * ! 6577: * HERE FOR ERROR OF 0**0 OR 0.0**0 ! 6578: * ! 6579: OEXP4 ERB 018,EXPONENTIATION RESULT IS UNDEFINED ! 6580: * ! 6581: * LOOP TO PERFORM EXPONENTIATION ! 6582: * ! 6583: OEXP5 MLR RCVAL(XR) MULTIPLY BY BASE ! 6584: ROV OEXP6 JUMP IF OVERFLOW ! 6585: BCT WA,OEXP5 LOOP TILL COMPUTATION COMPLETE ! 6586: BRN EXREA THEN RETURN REAL RESULT ! 6587: * ! 6588: * HERE IF REAL OVERFLOW ! 6589: * ! 6590: OEXP6 ERB 266,EXPONENTIATION CAUSED REAL OVERFLOW ! 6591: * ! 6592: * HERE IF REAL EXPONENT ! 6593: * ! 6594: OEXP7 ERB 267,EXPONENTIATION RIGHT OPERAND IS REAL NOT INTEGER ! 6595: * ! 6596: * HERE FOR NEGATIVE EXPONENT ! 6597: * ! 6598: OEXP8 ERB 019,EXPONENTIATION RIGHT OPERAND IS NEGATIVE ! 6599: EJC ! 6600: * ! 6601: * FAILURE IN EXPRESSION EVALUATION ! 6602: * ! 6603: * THIS ENTRY POINT IS USED IF THE EVALUATION OF AN ! 6604: * EXPRESSION, INITIATED BY THE EVALX PROCEDURE, FAILS. ! 6605: * CONTROL IS RETURNED TO AN APPROPRIATE POINT IN EVALX. ! 6606: * ! 6607: O$FEX ENT ENTRY POINT ! 6608: BRN EVLX6 JUMP TO FAILURE LOC IN EVALX ! 6609: EJC ! 6610: * ! 6611: * FAILURE DURING EVALUATION OF A COMPLEX OR DIRECT GOTO ! 6612: * ! 6613: O$FIF ENT ENTRY POINT ! 6614: ERB 020,GOTO EVALUATION FAILURE ! 6615: EJC ! 6616: * ! 6617: * FUNCTION CALL (MORE THAN ONE ARGUMENT) ! 6618: * ! 6619: O$FNC ENT ENTRY POINT ! 6620: LCW WA LOAD NUMBER OF ARGUMENTS ! 6621: LCW XR LOAD FUNCTION VRBLK POINTER ! 6622: MOV VRFNC(XR),XL LOAD FUNCTION POINTER ! 6623: BNE WA,FARGS(XL),CFUNC USE CENTRAL ROUTINE IF WRONG NUM ! 6624: BRI (XL) JUMP TO FUNCTION IF ARG COUNT OK ! 6625: EJC ! 6626: * ! 6627: * FUNCTION NAME ERROR ! 6628: * ! 6629: O$FNE ENT ENTRY POINT ! 6630: LCW WA GET NEXT CODE WORD ! 6631: BNE WA,=ORNM$,OFNE1 FAIL IF NOT EVALUATING EXPRESSION ! 6632: BZE 2(XS),EVLX3 OK IF EXPR. WAS WANTED BY VALUE ! 6633: * ! 6634: * HERE FOR ERROR ! 6635: * ! 6636: OFNE1 ERB 021,FUNCTION CALLED BY NAME RETURNED A VALUE ! 6637: EJC ! 6638: * ! 6639: * FUNCTION CALL (SINGLE ARGUMENT) ! 6640: * ! 6641: O$FNS ENT ENTRY POINT ! 6642: LCW XR LOAD FUNCTION VRBLK POINTER ! 6643: MOV =NUM01,WA SET NUMBER OF ARGUMENTS TO ONE ! 6644: MOV VRFNC(XR),XL LOAD FUNCTION POINTER ! 6645: BNE WA,FARGS(XL),CFUNC USE CENTRAL ROUTINE IF WRONG NUM ! 6646: BRI (XL) JUMP TO FUNCTION IF ARG COUNT OK ! 6647: EJC ! 6648: * CALL TO UNDEFINED FUNCTION ! 6649: * ! 6650: O$FUN ENT ENTRY POINT ! 6651: ERB 022,UNDEFINED FUNCTION CALLED ! 6652: EJC ! 6653: * ! 6654: * EXECUTE COMPLEX GOTO ! 6655: * ! 6656: O$GOC ENT ENTRY POINT ! 6657: MOV 1(XS),XR LOAD NAME BASE POINTER ! 6658: BHI XR,STATE,OGOC1 JUMP IF NOT NATURAL VARIABLE ! 6659: ADD *VRTRA,XR ELSE POINT TO VRTRA FIELD ! 6660: BRI (XR) AND JUMP THROUGH IT ! 6661: * ! 6662: * HERE IF GOTO OPERAND IS NOT NATURAL VARIABLE ! 6663: * ! 6664: OGOC1 ERB 023,GOTO OPERAND IS NOT A NATURAL VARIABLE ! 6665: EJC ! 6666: * ! 6667: * EXECUTE DIRECT GOTO ! 6668: * ! 6669: O$GOD ENT ENTRY POINT ! 6670: MOV (XS),XR LOAD OPERAND ! 6671: MOV (XR),WA LOAD FIRST WORD ! 6672: BEQ WA,=B$CDS,BCDS0 JUMP IF CODE BLOCK TO CODE ROUTINE ! 6673: BEQ WA,=B$CDC,BCDC0 JUMP IF CODE BLOCK TO CODE ROUTINE ! 6674: ERB 024,GOTO OPERAND IN DIRECT GOTO IS NOT CODE ! 6675: EJC ! 6676: * ! 6677: * SET GOTO FAILURE TRAP ! 6678: * ! 6679: * THIS ROUTINE IS EXECUTED AT THE START OF A COMPLEX OR ! 6680: * DIRECT FAILURE GOTO TO TRAP A SUBSEQUENT FAIL (SEE EXFAL) ! 6681: * ! 6682: O$GOF ENT ENTRY POINT ! 6683: MOV FLPTR,XR POINT TO FAIL OFFSET ON STACK ! 6684: ICA (XR) POINT FAILURE TO O$FIF WORD ! 6685: ICP POINT TO NEXT CODE WORD ! 6686: BRN EXITS EXIT TO CONTINUE ! 6687: EJC ! 6688: * ! 6689: * BINARY DOLLAR (IMMEDIATE ASSIGNMENT) ! 6690: * ! 6691: * THE PATTERN BUILT BY BINARY DOLLAR IS A COMPOUND PATTERN. ! 6692: * SEE DESCRIPTION AT START OF PATTERN MATCH SECTION FOR ! 6693: * DETAILS OF THE STRUCTURE WHICH IS CONSTRUCTED. ! 6694: * ! 6695: O$IMA ENT ENTRY POINT ! 6696: MOV =P$IMC,WB SET PCODE FOR LAST NODE ! 6697: MOV (XS)+,WC POP NAME OFFSET (PARM2) ! 6698: MOV (XS)+,XR POP NAME BASE (PARM1) ! 6699: JSR PBILD BUILD P$IMC NODE ! 6700: MOV XR,XL SAVE PTR TO NODE ! 6701: MOV (XS),XR LOAD LEFT ARGUMENT ! 6702: JSR GTPAT CONVERT TO PATTERN ! 6703: ERR 025,IMMEDIATE ASSIGNMENT LEFT OPERAND IS NOT PATTERN ! 6704: MOV XR,(XS) SAVE PTR TO LEFT OPERAND PATTERN ! 6705: MOV =P$IMA,WB SET PCODE FOR FIRST NODE ! 6706: JSR PBILD BUILD P$IMA NODE ! 6707: MOV (XS)+,PTHEN(XR) SET LEFT OPERAND AS P$IMA SUCCESSOR ! 6708: JSR PCONC CONCATENATE TO FORM FINAL PATTERN ! 6709: BRN EXIXR ALL DONE ! 6710: EJC ! 6711: * ! 6712: * INDIRECTION (BY NAME) ! 6713: * ! 6714: O$INN ENT ENTRY POINT ! 6715: MNZ WB SET FLAG FOR RESULT BY NAME ! 6716: BRN INDIR JUMP TO COMMON ROUTINE ! 6717: EJC ! 6718: * ! 6719: * INTERROGATION ! 6720: * ! 6721: O$INT ENT ENTRY POINT ! 6722: MOV =NULLS,(XS) REPLACE OPERAND WITH NULL ! 6723: BRN EXITS EXIT FOR NEXT CODE WORD ! 6724: EJC ! 6725: * ! 6726: * INDIRECTION (BY VALUE) ! 6727: * ! 6728: O$INV ENT ENTRY POINT ! 6729: ZER WB SET FLAG FOR BY VALUE ! 6730: BRN INDIR JUMP TO COMMON ROUTINE ! 6731: EJC ! 6732: * ! 6733: * KEYWORD REFERENCE (BY NAME) ! 6734: * ! 6735: O$KWN ENT ENTRY POINT ! 6736: JSR KWNAM GET KEYWORD NAME ! 6737: BRN EXNAM EXIT WITH RESULT NAME ! 6738: EJC ! 6739: * ! 6740: * KEYWORD REFERENCE (BY VALUE) ! 6741: * ! 6742: O$KWV ENT ENTRY POINT ! 6743: JSR KWNAM GET KEYWORD NAME ! 6744: MOV XR,DNAMP DELETE KVBLK ! 6745: JSR ACESS ACCESS VALUE ! 6746: PPM EXNUL DUMMY (UNUSED) FAILURE RETURN ! 6747: BRN EXIXR JUMP WITH VALUE IN XR ! 6748: EJC ! 6749: * ! 6750: * LOAD EXPRESSION BY NAME ! 6751: * ! 6752: O$LEX ENT ENTRY POINT ! 6753: MOV *EVSI$,WA SET SIZE OF EVBLK ! 6754: JSR ALLOC ALLOCATE SPACE FOR EVBLK ! 6755: MOV =B$EVT,(XR) SET TYPE WORD ! 6756: MOV =TRBEV,EVVAR(XR) SET DUMMY TRBLK POINTER ! 6757: LCW WA LOAD EXBLK POINTER ! 6758: MOV WA,EVEXP(XR) SET EXBLK POINTER ! 6759: MOV XR,XL MOVE NAME BASE TO PROPER REG ! 6760: MOV *EVVAR,WA SET NAME OFFSET = ZERO ! 6761: BRN EXNAM EXIT WITH NAME IN (XL,WA) ! 6762: EJC ! 6763: * ! 6764: * LOAD PATTERN VALUE ! 6765: * ! 6766: O$LPT ENT ENTRY POINT ! 6767: LCW XR LOAD PATTERN POINTER ! 6768: BRN EXIXR STACK PTR AND OBEY NEXT CODE WORD ! 6769: EJC ! 6770: * ! 6771: * LOAD VARIABLE NAME ! 6772: * ! 6773: O$LVN ENT ENTRY POINT ! 6774: LCW WA LOAD VRBLK POINTER ! 6775: MOV WA,-(XS) STACK VRBLK PTR (NAME BASE) ! 6776: MOV *VRVAL,-(XS) STACK NAME OFFSET ! 6777: BRN EXITS EXIT WITH RESULT ON STACK ! 6778: EJC ! 6779: * ! 6780: * BINARY ASTERISK (MULTIPLICATION) ! 6781: * ! 6782: O$MLT ENT ENTRY POINT ! 6783: JSR ARITH FETCH ARITHMETIC OPERANDS ! 6784: ERR 026,MULTIPLICATION LEFT OPERAND IS NOT NUMERIC ! 6785: ERR 027,MULTIPLICATION RIGHT OPERAND IS NOT NUMERIC ! 6786: PPM OMLT1 JUMP IF REAL OPERANDS ! 6787: * ! 6788: * HERE TO MULTIPLY TWO INTEGERS ! 6789: * ! 6790: MLI ICVAL(XL) MULTIPLY LEFT OPERAND BY RIGHT ! 6791: INO EXINT RETURN INTEGER IF NO OVERFLOW ! 6792: ERB 028,MULTIPLICATION CAUSED INTEGER OVERFLOW ! 6793: * ! 6794: * HERE TO MULTIPLY TWO REALS ! 6795: * ! 6796: OMLT1 MLR RCVAL(XL) MULTIPLY LEFT OPERAND BY RIGHT ! 6797: RNO EXREA RETURN REAL IF NO OVERFLOW ! 6798: ERB 263,MULTIPLICATION CAUSED REAL OVERFLOW ! 6799: EJC ! 6800: * ! 6801: * NAME REFERENCE ! 6802: * ! 6803: O$NAM ENT ENTRY POINT ! 6804: MOV *NMSI$,WA SET LENGTH OF NMBLK ! 6805: JSR ALLOC ALLOCATE NMBLK ! 6806: MOV =B$NML,(XR) SET NAME BLOCK CODE ! 6807: MOV (XS)+,NMOFS(XR) SET NAME OFFSET FROM OPERAND ! 6808: MOV (XS)+,NMBAS(XR) SET NAME BASE FROM OPERAND ! 6809: BRN EXIXR EXIT WITH RESULT IN XR ! 6810: EJC ! 6811: * ! 6812: * NEGATION ! 6813: * ! 6814: * INITIAL ENTRY ! 6815: * ! 6816: O$NTA ENT ENTRY POINT ! 6817: LCW WA LOAD NEW FAILURE OFFSET ! 6818: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER ! 6819: MOV WA,-(XS) STACK NEW FAILURE OFFSET ! 6820: MOV XS,FLPTR SET NEW FAILURE POINTER ! 6821: BRN EXITS JUMP TO CONTINUE EXECUTION ! 6822: * ! 6823: * ENTRY AFTER SUCCESSFUL EVALUATION OF OPERAND ! 6824: * ! 6825: O$NTB ENT ENTRY POINT ! 6826: MOV 2(XS),FLPTR RESTORE OLD FAILURE POINTER ! 6827: BRN EXFAL AND FAIL ! 6828: * ! 6829: * ENTRY FOR FAILURE DURING OPERAND EVALUATION ! 6830: * ! 6831: O$NTC ENT ENTRY POINT ! 6832: ICA XS POP FAILURE OFFSET ! 6833: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER ! 6834: BRN EXNUL EXIT GIVING NULL RESULT ! 6835: EJC ! 6836: * ! 6837: * USE OF UNDEFINED OPERATOR ! 6838: * ! 6839: O$OUN ENT ENTRY POINT ! 6840: ERB 029,UNDEFINED OPERATOR REFERENCED ! 6841: EJC ! 6842: * ! 6843: * BINARY DOT (PATTERN ASSIGNMENT) ! 6844: * ! 6845: * THE PATTERN BUILT BY BINARY DOT IS A COMPOUND PATTERN. ! 6846: * SEE DESCRIPTION AT START OF PATTERN MATCH SECTION FOR ! 6847: * DETAILS OF THE STRUCTURE WHICH IS CONSTRUCTED. ! 6848: * ! 6849: O$PAS ENT ENTRY POINT ! 6850: MOV =P$PAC,WB LOAD PCODE FOR P$PAC NODE ! 6851: MOV (XS)+,WC LOAD NAME OFFSET (PARM2) ! 6852: MOV (XS)+,XR LOAD NAME BASE (PARM1) ! 6853: JSR PBILD BUILD P$PAC NODE ! 6854: MOV XR,XL SAVE PTR TO NODE ! 6855: MOV (XS),XR LOAD LEFT OPERAND ! 6856: JSR GTPAT CONVERT TO PATTERN ! 6857: ERR 030,PATTERN ASSIGNMENT LEFT OPERAND IS NOT PATTERN ! 6858: MOV XR,(XS) SAVE PTR TO LEFT OPERAND PATTERN ! 6859: MOV =P$PAA,WB SET PCODE FOR P$PAA NODE ! 6860: JSR PBILD BUILD P$PAA NODE ! 6861: MOV (XS)+,PTHEN(XR) SET LEFT OPERAND AS P$PAA SUCCESSOR ! 6862: JSR PCONC CONCATENATE TO FORM FINAL PATTERN ! 6863: BRN EXIXR JUMP FOR NEXT CODE WORD ! 6864: EJC ! 6865: * ! 6866: * PATTERN MATCH (BY NAME, FOR REPLACEMENT) ! 6867: * ! 6868: O$PMN ENT ENTRY POINT ! 6869: ZER WB SET TYPE CODE FOR MATCH BY NAME ! 6870: BRN MATCH JUMP TO ROUTINE TO START MATCH ! 6871: EJC ! 6872: * ! 6873: * PATTERN MATCH (STATEMENT) ! 6874: * ! 6875: * O$PMS IS USED IN PLACE OF O$PMV WHEN THE PATTERN MATCH ! 6876: * OCCURS AT THE OUTER (STATEMENT) LEVEL SINCE IN THIS ! 6877: * CASE THE SUBSTRING VALUE NEED NOT BE CONSTRUCTED. ! 6878: * ! 6879: O$PMS ENT ENTRY POINT ! 6880: MOV =NUM02,WB SET FLAG FOR STATEMENT TO MATCH ! 6881: BRN MATCH JUMP TO ROUTINE TO START MATCH ! 6882: EJC ! 6883: * ! 6884: * PATTERN MATCH (BY VALUE) ! 6885: * ! 6886: O$PMV ENT ENTRY POINT ! 6887: MOV =NUM01,WB SET TYPE CODE FOR VALUE MATCH ! 6888: BRN MATCH JUMP TO ROUTINE TO START MATCH ! 6889: EJC ! 6890: * ! 6891: * POP TOP ITEM ON STACK ! 6892: * ! 6893: O$POP ENT ENTRY POINT ! 6894: ICA XS POP TOP STACK ENTRY ! 6895: BRN EXITS OBEY NEXT CODE WORD ! 6896: EJC ! 6897: * ! 6898: * TERMINATE EXECUTION (CODE COMPILED FOR END STATEMENT) ! 6899: * ! 6900: O$STP ENT ENTRY POINT ! 6901: BRN LEND0 JUMP TO END CIRCUIT ! 6902: EJC ! 6903: * ! 6904: * RETURN NAME FROM EXPRESSION ! 6905: * THIS ENTRY POINTS IS USED IF THE EVALUATION OF AN ! 6906: * EXPRESSION, INITIATED BY THE EVALX PROCEDURE, RETURNS ! 6907: * A NAME. CONTROL IS RETURNED TO THE PROPER POINT IN EVALX. ! 6908: * ! 6909: O$RNM ENT ENTRY POINT ! 6910: BRN EVLX4 RETURN TO EVALX PROCEDURE ! 6911: EJC ! 6912: * ! 6913: * PATTERN REPLACEMENT ! 6914: * ! 6915: * WHEN THIS ROUTINE GETS CONTROL, THE FOLLOWING STACK ! 6916: * ENTRIES HAVE BEEN MADE (SEE END OF MATCH ROUTINE P$NTH) ! 6917: * ! 6918: * SUBJECT NAME BASE ! 6919: * SUBJECT NAME OFFSET ! 6920: * INITIAL CURSOR VALUE ! 6921: * FINAL CURSOR VALUE ! 6922: * SUBJECT POINTER ! 6923: * (XS) ---------------- REPLACEMENT VALUE ! 6924: * ! 6925: O$RPL ENT ENTRY POINT ! 6926: JSR GTSTG CONVERT REPLACEMENT VAL TO STRING ! 6927: ERR 031,PATTERN REPLACEMENT RIGHT OPERAND IS NOT STRING ! 6928: * ! 6929: * GET RESULT LENGTH AND ALLOCATE RESULT SCBLK ! 6930: * ! 6931: MOV (XS),XL LOAD SUBJECT STRING POINTER ! 6932: BEQ (XL),=B$BCT,ORPL4 BRANCH IF BUFFER ASSIGNMENT ! 6933: ADD SCLEN(XL),WA ADD SUBJECT STRING LENGTH ! 6934: ADD 2(XS),WA ADD STARTING CURSOR ! 6935: SUB 1(XS),WA MINUS FINAL CURSOR = TOTAL LENGTH ! 6936: BZE WA,ORPL3 JUMP IF RESULT IS NULL ! 6937: MOV XR,-(XS) RESTACK REPLACEMENT STRING ! 6938: JSR ALOCS ALLOCATE SCBLK FOR RESULT ! 6939: MOV 3(XS),WA GET INITIAL CURSOR (PART 1 LEN) ! 6940: MOV XR,3(XS) STACK RESULT POINTER ! 6941: PSC XR POINT TO CHARACTERS OF RESULT ! 6942: * ! 6943: * MOVE PART 1 (START OF SUBJECT) TO RESULT ! 6944: * ! 6945: BZE WA,ORPL1 JUMP IF FIRST PART IS NULL ! 6946: MOV 1(XS),XL ELSE POINT TO SUBJECT STRING ! 6947: PLC XL POINT TO SUBJECT STRING CHARS ! 6948: MVC MOVE FIRST PART TO RESULT ! 6949: EJC ! 6950: * PATTERN REPLACEMENT (CONTINUED) ! 6951: * ! 6952: * NOW MOVE IN REPLACEMENT VALUE ! 6953: * ! 6954: ORPL1 MOV (XS)+,XL LOAD REPLACEMENT STRING, POP ! 6955: MOV SCLEN(XL),WA LOAD LENGTH ! 6956: BZE WA,ORPL2 JUMP IF NULL REPLACEMENT ! 6957: PLC XL ELSE POINT TO CHARS OF REPLACEMENT ! 6958: MVC MOVE IN CHARS (PART 2) ! 6959: * ! 6960: * NOW MOVE IN REMAINDER OF STRING (PART 3) ! 6961: * ! 6962: ORPL2 MOV (XS)+,XL LOAD SUBJECT STRING POINTER, POP ! 6963: MOV (XS)+,WC LOAD FINAL CURSOR, POP ! 6964: MOV SCLEN(XL),WA LOAD SUBJECT STRING LENGTH ! 6965: SUB WC,WA MINUS FINAL CURSOR = PART 3 LENGTH ! 6966: BZE WA,OASS0 JUMP TO ASSIGN IF PART 3 IS NULL ! 6967: PLC XL,WC ELSE POINT TO LAST PART OF STRING ! 6968: MVC MOVE PART 3 TO RESULT ! 6969: BRN OASS0 JUMP TO PERFORM ASSIGNMENT ! 6970: * ! 6971: * HERE IF RESULT IS NULL ! 6972: * ! 6973: ORPL3 ADD *NUM02,XS POP SUBJECT STR PTR, FINAL CURSOR ! 6974: MOV =NULLS,(XS) SET NULL RESULT ! 6975: BRN OASS0 JUMP TO ASSIGN NULL VALUE ! 6976: * ! 6977: * HERE FOR BUFFER SUBSTRING ASSIGNMENT ! 6978: * ! 6979: ORPL4 MOV XR,XL COPY SCBLK REPLACEMENT PTR ! 6980: MOV (XS)+,XR UNSTACK BCBLK PTR ! 6981: MOV (XS)+,WB GET FINAL CURSOR VALUE ! 6982: MOV (XS)+,WA GET INITIAL CURSOR ! 6983: SUB WA,WB GET LENGTH IN WB ! 6984: ADD *NUM02,XS GET RID OF NAME BASE/OFFSET ! 6985: JSR INSBF INSERT SUBSTRING ! 6986: PPM CONVERT FAIL IMPOSSIBLE ! 6987: PPM EXFAL FAIL IF INSERT FAILS ! 6988: BRN EXNUL ELSE NULL RESULT ! 6989: EJC ! 6990: * ! 6991: * RETURN VALUE FROM EXPRESSION ! 6992: * ! 6993: * THIS ENTRY POINTS IS USED IF THE EVALUATION OF AN ! 6994: * EXPRESSION, INITIATED BY THE EVALX PROCEDURE, RETURNS ! 6995: * A VALUE. CONTROL IS RETURNED TO THE PROPER POINT IN EVALX ! 6996: * ! 6997: O$RVL ENT ENTRY POINT ! 6998: BRN EVLX3 RETURN TO EVALX PROCEDURE ! 6999: EJC ! 7000: * ! 7001: * SELECTION ! 7002: * ! 7003: * INITIAL ENTRY ! 7004: * ! 7005: O$SLA ENT ENTRY POINT ! 7006: LCW WA LOAD NEW FAILURE OFFSET ! 7007: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER ! 7008: MOV WA,-(XS) STACK NEW FAILURE OFFSET ! 7009: MOV XS,FLPTR SET NEW FAILURE POINTER ! 7010: BRN EXITS JUMP TO EXECUTE FIRST ALTERNATIVE ! 7011: * ! 7012: * ENTRY AFTER SUCCESSFUL EVALUATION OF ALTERNATIVE ! 7013: * ! 7014: O$SLB ENT ENTRY POINT ! 7015: MOV (XS)+,XR LOAD RESULT ! 7016: ICA XS POP FAIL OFFSET ! 7017: MOV (XS),FLPTR RESTORE OLD FAILURE POINTER ! 7018: MOV XR,(XS) RESTACK RESULT ! 7019: LCW WA LOAD NEW CODE OFFSET ! 7020: ADD R$COD,WA POINT TO ABSOLUTE CODE LOCATION ! 7021: LCP WA SET NEW CODE POINTER ! 7022: BRN EXITS JUMP TO CONTINUE PAST SELECTION ! 7023: * ! 7024: * ENTRY AT START OF SUBSEQUENT ALTERNATIVES ! 7025: * ! 7026: O$SLC ENT ENTRY POINT ! 7027: LCW WA LOAD NEW FAIL OFFSET ! 7028: MOV WA,(XS) STORE NEW FAIL OFFSET ! 7029: BRN EXITS JUMP TO EXECUTE NEXT ALTERNATIVE ! 7030: * ! 7031: * ENTRY AT START OF LAST ALTERNATIVE ! 7032: * ! 7033: O$SLD ENT ENTRY POINT ! 7034: ICA XS POP FAILURE OFFSET ! 7035: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER ! 7036: BRN EXITS JUMP TO EXECUTE LAST ALTERNATIVE ! 7037: EJC ! 7038: * ! 7039: * BINARY MINUS (SUBTRACTION) ! 7040: * ! 7041: O$SUB ENT ENTRY POINT ! 7042: JSR ARITH FETCH ARITHMETIC OPERANDS ! 7043: ERR 032,SUBTRACTION LEFT OPERAND IS NOT NUMERIC ! 7044: ERR 033,SUBTRACTION RIGHT OPERAND IS NOT NUMERIC ! 7045: PPM OSUB1 JUMP IF REAL OPERANDS ! 7046: * ! 7047: * HERE TO SUBTRACT TWO INTEGERS ! 7048: * ! 7049: SBI ICVAL(XL) SUBTRACT RIGHT OPERAND FROM LEFT ! 7050: INO EXINT RETURN INTEGER IF NO OVERFLOW ! 7051: ERB 034,SUBTRACTION CAUSED INTEGER OVERFLOW ! 7052: * ! 7053: * HERE TO SUBTRACT TWO REALS ! 7054: * ! 7055: OSUB1 SBR RCVAL(XL) SUBTRACT RIGHT OPERAND FROM LEFT ! 7056: RNO EXREA RETURN REAL IF NO OVERFLOW ! 7057: ERB 264,SUBTRACTION CAUSED REAL OVERFLOW ! 7058: EJC ! 7059: * ! 7060: * DUMMY OPERATOR TO RETURN CONTROL TO TRXEQ PROCEDURE ! 7061: * ! 7062: O$TXR ENT ENTRY POINT ! 7063: BRN TRXQ1 JUMP INTO TRXEQ PROCEDURE ! 7064: EJC ! 7065: * ! 7066: * UNEXPECTED FAILURE ! 7067: * ! 7068: * NOTE THAT IF A SETEXIT TRAP IS OPERATING THEN ! 7069: * TRANSFER TO SYSTEM LABEL CONTINUE ! 7070: * WILL RESULT IN LOOPING HERE. DIFFICULT TO AVOID EXCEPT ! 7071: * WITH A CONSIDERABLE OVERHEAD WHICH IS NOT WORTHWHILE OR ! 7072: * ELSE BY A TECHNIQUE SUCH AS SETTING KVERL TO ZERO. ! 7073: * ! 7074: O$UNF ENT ENTRY POINT ! 7075: ERB 035,UNEXPECTED FAILURE IN -NOFAIL MODE ! 7076: TTL S P I T B O L -- SNOBOL4 BUILTIN LABEL ROUTINES ! 7077: * ! 7078: * THE FOLLOWING SECTION CONTAINS THE ROUTINES FOR LABELS ! 7079: * WHICH HAVE A PREDEFINED MEANING IN SNOBOL4. ! 7080: * ! 7081: * CONTROL IS PASSED DIRECTLY TO THE LABEL NAME ENTRY POINT. ! 7082: * ! 7083: * ENTRY NAMES ARE OF THE FORM L$XXX WHERE XXX IS THE THREE ! 7084: * LETTER VARIABLE NAME IDENTIFIER. ! 7085: * ! 7086: * ENTRIES ARE IN ALPHABETICAL ORDER ! 7087: EJC ! 7088: * ! 7089: * ABORT ! 7090: * ! 7091: L$ABO ENT ENTRY POINT ! 7092: * ! 7093: * MERGE HERE IF EXECUTION TERMINATES IN ERROR ! 7094: * ! 7095: LABO1 MOV KVERT,WA LOAD ERROR CODE ! 7096: BZE WA,LABO2 JUMP IF NO ERROR HAS OCCURED ! 7097: JSR SYSAX CALL AFTER EXECUTION PROC (REG04) ! 7098: JSR PRTPG ELSE EJECT PRINTER ! 7099: JSR ERMSG PRINT ERROR MESSAGE ! 7100: ZER XR INDICATE NO MESSAGE TO PRINT ! 7101: BRN STOPR JUMP TO ROUTINE TO STOP RUN ! 7102: * ! 7103: * HERE IF NO ERROR HAD OCCURED ! 7104: * ! 7105: LABO2 ERB 036,GOTO ABORT WITH NO PRECEDING ERROR ! 7106: EJC ! 7107: * ! 7108: * CONTINUE ! 7109: * ! 7110: L$CNT ENT ENTRY POINT ! 7111: * ! 7112: * MERGE HERE AFTER EXECUTION ERROR ! 7113: * ! 7114: LCNT1 MOV R$CNT,XR LOAD CONTINUATION CODE BLOCK PTR ! 7115: BZE XR,LCNT2 JUMP IF NO PREVIOUS ERROR ! 7116: ZER R$CNT CLEAR FLAG ! 7117: MOV XR,R$COD ELSE STORE AS NEW CODE BLOCK PTR ! 7118: ADD STXOF,XR ADD FAILURE OFFSET ! 7119: LCP XR LOAD CODE POINTER ! 7120: MOV FLPTR,XS RESET STACK POINTER ! 7121: BRN EXITS JUMP TO TAKE INDICATED FAILURE ! 7122: * ! 7123: * HERE IF NO PREVIOUS ERROR ! 7124: * ! 7125: LCNT2 ERB 037,GOTO CONTINUE WITH NO PRECEDING ERROR ! 7126: EJC ! 7127: * ! 7128: * END ! 7129: * ! 7130: L$END ENT ENTRY POINT ! 7131: * ! 7132: * MERGE HERE FROM END CODE CIRCUIT ! 7133: * ! 7134: LEND0 MOV =ENDMS,XR POINT TO MESSAGE /NORMAL TERM../ ! 7135: BRN STOPR JUMP TO ROUTINE TO STOP RUN ! 7136: EJC ! 7137: * ! 7138: * FRETURN ! 7139: * ! 7140: L$FRT ENT ENTRY POINT ! 7141: MOV =SCFRT,WA POINT TO STRING /FRETURN/ ! 7142: BRN RETRN JUMP TO COMMON RETURN ROUTINE ! 7143: EJC ! 7144: * ! 7145: * NRETURN ! 7146: * ! 7147: L$NRT ENT ENTRY POINT ! 7148: MOV =SCNRT,WA POINT TO STRING /NRETURN/ ! 7149: BRN RETRN JUMP TO COMMON RETURN ROUTINE ! 7150: EJC ! 7151: * ! 7152: * RETURN ! 7153: * ! 7154: L$RTN ENT ENTRY POINT ! 7155: MOV =SCRTN,WA POINT TO STRING /RETURN/ ! 7156: BRN RETRN JUMP TO COMMON RETURN ROUTINE ! 7157: EJC ! 7158: * ! 7159: * UNDEFINED LABEL ! 7160: * ! 7161: L$UND ENT ENTRY POINT ! 7162: ERB 038,GOTO UNDEFINED LABEL ! 7163: TTL S P I T B O L -- BLOCK ACTION ROUTINES ! 7164: * ! 7165: * THE FIRST WORD OF EVERY BLOCK IN DYNAMIC STORAGE AND THE ! 7166: * VRGET, VRSTO AND VRTRA FIELDS OF A VRBLK CONTAIN A ! 7167: * POINTER TO AN ENTRY POINT IN THE PROGRAM. ALL SUCH ENTRY ! 7168: * POINTS ARE IN THE FOLLOWING SECTION EXCEPT THOSE FOR ! 7169: * PATTERN BLOCKS WHICH ARE IN THE PATTERN MATCHING SEGMENT ! 7170: * LATER ON (LABELS OF THE FORM P$XXX), AND DOPE VECTORS ! 7171: * (D$XXX) WHICH ARE IN THE DOPE VECTOR SECTION FOLLOWING ! 7172: * THE PATTERN ROUTINES (DOPE VECTORS ARE USED FOR CMBLKS). ! 7173: * ! 7174: * THE ENTRY POINTS IN THIS SECTION HAVE LABELS OF THE ! 7175: * FORM B$XXY WHERE XX IS THE TWO CHARACTER BLOCK TYPE FOR ! 7176: * THE CORRESPONDING BLOCK AND Y IS ANY LETTER. ! 7177: * ! 7178: * IN SOME CASES, THE POINTERS SERVE NO OTHER PURPOSE THAN ! 7179: * TO IDENTIFY THE BLOCK TYPE. IN THIS CASE THE ROUTINE ! 7180: * IS NEVER EXECUTED AND THUS NO CODE IS ASSEMBLED. ! 7181: * ! 7182: * FOR EACH OF THESE ENTRY POINTS CORRESPONDING TO A BLOCK ! 7183: * AN ENTRY POINT IDENTIFICATION IS ASSEMBLED (BL$XX). ! 7184: * ! 7185: * THE EXACT ENTRY CONDITIONS DEPEND ON THE MANNER IN ! 7186: * WHICH THE ROUTINE IS ACCESSED AND ARE DOCUMENTED WITH ! 7187: * THE INDIVIDUAL ROUTINES AS REQUIRED. ! 7188: * ! 7189: * THE ORDER OF THESE ROUTINES IS ALPHABETICAL WITH THE ! 7190: * FOLLOWING EXCEPTIONS. ! 7191: * ! 7192: * THE ROUTINES FOR SEBLK AND EXBLK ENTRIES OCCUR FIRST SO ! 7193: * THAT EXPRESSIONS CAN BE QUICKLY IDENTIFIED FROM THE FACT ! 7194: * THAT THEIR ROUTINES LIE BEFORE THE SYMBOL B$E$$. ! 7195: * ! 7196: * THESE ARE IMMEDIATELY FOLLOWED BY THE ROUTINE FOR A TRBLK ! 7197: * SO THAT THE TEST AGAINST THE SYMBOL B$T$$ CHECKS FOR ! 7198: * TRAPPED VALUES OR EXPRESSION VALUES (SEE PROCEDURE EVALP) ! 7199: * ! 7200: * THE PATTERN ROUTINES LIE AFTER THIS SECTION SO THAT ! 7201: * PATTERNS ARE IDENTIFIED WITH ROUTINES STARTING AT OR ! 7202: * AFTER THE INITIAL INSTRUCTION IN THESE ROUTINES (P$AAA). ! 7203: * ! 7204: * THE SYMBOL B$AAA DEFINES THE FIRST LOCATION FOR BLOCK ! 7205: * ROUTINES AND THE SYMBOL P$YYY (AT THE END OF THE PATTERN ! 7206: * MATCH ROUTINES SECTION) DEFINES THE LAST SUCH ENTRY POINT ! 7207: * ! 7208: B$AAA ENT BL$$I ENTRY POINT OF FIRST BLOCK ROUTINE ! 7209: EJC ! 7210: * ! 7211: * EXBLK ! 7212: * ! 7213: * THE ROUTINE FOR AN EXBLK LOADS THE EXPRESSION ONTO ! 7214: * THE STACK AS A VALUE. ! 7215: * ! 7216: * (XR) POINTER TO EXBLK ! 7217: * ! 7218: B$EXL ENT BL$EX ENTRY POINT (EXBLK) ! 7219: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD ! 7220: EJC ! 7221: * ! 7222: * SEBLK ! 7223: * ! 7224: * THE ROUTINE FOR SEBLK IS ACCESSED FROM THE GENERATED ! 7225: * CODE TO LOAD THE EXPRESSION VALUE ONTO THE STACK. ! 7226: * ! 7227: B$SEL ENT BL$SE ENTRY POINT (SEBLK) ! 7228: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD ! 7229: * ! 7230: * DEFINE SYMBOL WHICH MARKS END OF ENTRIES FOR EXPRESSIONS ! 7231: * ! 7232: B$E$$ ENT BL$$I ENTRY POINT ! 7233: EJC ! 7234: * ! 7235: * TRBLK ! 7236: * ! 7237: * THE ROUTINE FOR A TRBLK IS NEVER EXECUTED ! 7238: * ! 7239: B$TRT ENT BL$TR ENTRY POINT (TRBLK) ! 7240: * ! 7241: * DEFINE SYMBOL MARKING END OF TRAP AND EXPRESSION BLOCKS ! 7242: * ! 7243: B$T$$ ENT BL$$I END OF TRBLK,SEBLK,EXBLK ENTRIES ! 7244: EJC ! 7245: * ! 7246: * ARBLK ! 7247: * ! 7248: * THE ROUTINE FOR ARBLK IS NEVER EXECUTED ! 7249: * ! 7250: B$ART ENT BL$AR ENTRY POINT (ARBLK) ! 7251: EJC ! 7252: * ! 7253: * BCBLK ! 7254: * ! 7255: * THE ROUTINE FOR A BCBLK IS NEVER EXECUTED ! 7256: * ! 7257: * (XR) POINTER TO BCBLK ! 7258: * ! 7259: B$BCT ENT BL$BC ENTRY POINT (BCBLK) ! 7260: EJC ! 7261: * ! 7262: * BFBLK ! 7263: * ! 7264: * THE ROUTINE FOR A BFBLK IS NEVER EXECUTED ! 7265: * ! 7266: * (XR) POINTER TO BFBLK ! 7267: * ! 7268: B$BFT ENT BL$BF ENTRY POINT (BFBLK) ! 7269: EJC ! 7270: * ! 7271: * CCBLK ! 7272: * ! 7273: * THE ROUTINE FOR CCBLK IS NEVER ENTERED ! 7274: * ! 7275: B$CCT ENT BL$CC ENTRY POINT (CCBLK) ! 7276: EJC ! 7277: * ! 7278: * CDBLK ! 7279: * ! 7280: * THE CDBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE. ! 7281: * THERE ARE TWO CASES DEPENDING ON THE FORM OF CDFAL. ! 7282: * ! 7283: * ENTRY FOR COMPLEX FAILURE CODE AT CDFAL ! 7284: * ! 7285: * (XR) POINTER TO CDBLK ! 7286: * ! 7287: B$CDC ENT BL$CD ENTRY POINT (CDBLK) ! 7288: BCDC0 MOV FLPTR,XS POP GARBAGE OFF STACK ! 7289: MOV CDFAL(XR),(XS) SET FAILURE OFFSET ! 7290: BRN STMGO ENTER STMT ! 7291: EJC ! 7292: * ! 7293: * CDBLK (CONTINUED) ! 7294: * ! 7295: * ENTRY FOR SIMPLE FAILURE CODE AT CDFAL ! 7296: * ! 7297: * (XR) POINTER TO CDBLK ! 7298: * ! 7299: B$CDS ENT BL$CD ENTRY POINT (CDBLK) ! 7300: BCDS0 MOV FLPTR,XS POP GARBAGE OFF STACK ! 7301: MOV *CDFAL,(XS) SET FAILURE OFFSET ! 7302: BRN STMGO ENTER STMT ! 7303: EJC ! 7304: * ! 7305: * CMBLK ! 7306: * ! 7307: * THE ROUTINE FOR A CMBLK IS NEVER EXECUTED ! 7308: * ! 7309: B$CMT ENT BL$CM ENTRY POINT (CMBLK) ! 7310: EJC ! 7311: * ! 7312: * CTBLK ! 7313: * ! 7314: * THE ROUTINE FOR A CTBLK IS NEVER EXECUTED ! 7315: * ! 7316: B$CTT ENT BL$CT ENTRY POINT (CTBLK) ! 7317: EJC ! 7318: * ! 7319: * DFBLK ! 7320: * ! 7321: * THE ROUTINE FOR A DFBLK IS ACCESSED FROM THE O$FNC ENTRY ! 7322: * TO CALL A DATATYPE FUNCTION AND BUILD A PDBLK. ! 7323: * ! 7324: * (XL) POINTER TO DFBLK ! 7325: * ! 7326: B$DFC ENT BL$DF ENTRY POINT ! 7327: MOV DFPDL(XL),WA LOAD LENGTH OF PDBLK ! 7328: JSR ALLOC ALLOCATE PDBLK ! 7329: MOV =B$PDT,(XR) STORE TYPE WORD ! 7330: MOV XL,PDDFP(XR) STORE DFBLK POINTER ! 7331: MOV XR,WC SAVE POINTER TO PDBLK ! 7332: ADD WA,XR POINT PAST PDBLK ! 7333: LCT WA,FARGS(XL) SET TO COUNT FIELDS ! 7334: * ! 7335: * LOOP TO ACQUIRE FIELD VALUES FROM STACK ! 7336: * ! 7337: BDFC1 MOV (XS)+,-(XR) MOVE A FIELD VALUE ! 7338: BCT WA,BDFC1 LOOP TILL ALL MOVED ! 7339: MOV WC,XR RECALL POINTER TO PDBLK ! 7340: BRN EXSID EXIT SETTING ID FIELD ! 7341: EJC ! 7342: * ! 7343: * EFBLK ! 7344: * ! 7345: * THE ROUTINE FOR AN EFBLK IS PASSED CONTROL FORM THE O$FNC ! 7346: * ENTRY TO CALL AN EXTERNAL FUNCTION. ! 7347: * ! 7348: * (XL) POINTER TO EFBLK ! 7349: * ! 7350: B$EFC ENT BL$EF ENTRY POINT (EFBLK) ! 7351: MOV FARGS(XL),WC LOAD NUMBER OF ARGUMENTS ! 7352: WTB WC CONVERT TO OFFSET ! 7353: MOV XL,-(XS) SAVE POINTER TO EFBLK ! 7354: MOV XS,XT COPY POINTER TO ARGUMENTS ! 7355: * ! 7356: * LOOP TO CONVERT ARGUMENTS ! 7357: * ! 7358: BEFC1 ICA XT POINT TO NEXT ENTRY ! 7359: MOV (XS),XR LOAD POINTER TO EFBLK ! 7360: DCA WC DECREMENT EFTAR OFFSET ! 7361: ADD WC,XR POINT TO NEXT EFTAR ENTRY ! 7362: MOV EFTAR(XR),XR LOAD EFTAR ENTRY ! 7363: BSW XR,4 SWITCH ON TYPE ! 7364: IFF 0,BEFC7 NO CONVERSION NEEDED ! 7365: IFF 1,BEFC2 STRING ! 7366: IFF 2,BEFC3 INTEGER ! 7367: IFF 3,BEFC4 REAL ! 7368: ESW END OF SWITCH ON TYPE ! 7369: * ! 7370: * HERE TO CONVERT TO STRING ! 7371: * ! 7372: BEFC2 MOV (XT),-(XS) STACK ARG PTR ! 7373: JSR GTSTG CONVERT ARGUMENT TO STRING ! 7374: ERR 039,EXTERNAL FUNCTION ARGUMENT IS NOT STRING ! 7375: BRN BEFC6 JUMP TO MERGE ! 7376: EJC ! 7377: * ! 7378: * EFBLK (CONTINUED) ! 7379: * ! 7380: * HERE TO CONVERT AN INTEGER ! 7381: * ! 7382: BEFC3 MOV (XT),XR LOAD NEXT ARGUMENT ! 7383: MOV WC,BEFOF SAVE OFFSET ! 7384: JSR GTINT CONVERT TO INTEGER ! 7385: ERR 040,EXTERNAL FUNCTION ARGUMENT IS NOT INTEGER ! 7386: BRN BEFC5 MERGE WITH REAL CASE ! 7387: * ! 7388: * HERE TO CONVERT A REAL ! 7389: * ! 7390: BEFC4 MOV (XT),XR LOAD NEXT ARGUMENT ! 7391: MOV WC,BEFOF SAVE OFFSET ! 7392: JSR GTREA CONVERT TO REAL ! 7393: ERR 265,EXTERNAL FUNCTION ARGUMENT IS NOT REAL ! 7394: * ! 7395: * INTEGER CASE MERGES HERE ! 7396: * ! 7397: BEFC5 MOV BEFOF,WC RESTORE OFFSET ! 7398: * ! 7399: * STRING MERGES HERE ! 7400: * ! 7401: BEFC6 MOV XR,(XT) STORE CONVERTED RESULT ! 7402: * ! 7403: * NO CONVERSION MERGES HERE ! 7404: * ! 7405: BEFC7 BNZ WC,BEFC1 LOOP BACK IF MORE TO GO ! 7406: * ! 7407: * HERE AFTER CONVERTING ALL THE ARGUMENTS ! 7408: * ! 7409: MOV (XS)+,XL RESTORE EFBLK POINTER ! 7410: MOV FARGS(XL),WA GET NUMBER OF ARGS ! 7411: JSR SYSEX CALL ROUTINE TO CALL EXTERNAL FNC ! 7412: PPM EXFAL FAIL IF FAILURE ! 7413: EJC ! 7414: * ! 7415: * EFBLK (CONTINUED) ! 7416: * ! 7417: * RETURN HERE WITH RESULT IN XR ! 7418: * ! 7419: * FIRST DEFEND AGAINST NON-STANDARD NULL STRING RETURNED ! 7420: * ! 7421: MOV EFRSL(XL),WB GET RESULT TYPE ID ! 7422: BNZ WB,BEFA8 BRANCH IF NOT UNCONVERTED ! 7423: BNE (XR),=B$SCL,BEFC8 JUMP IF NOT A STRING ! 7424: BZE SCLEN(XR),EXNUL RETURN NULL IF NULL ! 7425: * ! 7426: * HERE IF CONVERTED RESULT TO CHECK FOR NULL STRING ! 7427: * ! 7428: BEFA8 BNE WB,=NUM01,BEFC8 JUMP IF NOT A STRING ! 7429: BZE SCLEN(XR),EXNUL RETURN NULL IF NULL ! 7430: * ! 7431: * RETURN IF RESULT IS IN DYNAMIC STORAGE ! 7432: * ! 7433: BEFC8 BLT XR,DNAMB,BEFC9 JUMP IF NOT IN DYNAMIC STORAGE ! 7434: BLE XR,DNAMP,EXIXR RETURN RESULT IF ALREADY DYNAMIC ! 7435: * ! 7436: * HERE WE COPY A RESULT INTO THE DYNAMIC REGION ! 7437: * ! 7438: BEFC9 MOV (XR),WA GET POSSIBLE TYPE WORD ! 7439: BZE WB,BEF11 JUMP IF UNCONVERTED RESULT ! 7440: MOV =B$SCL,WA STRING ! 7441: BEQ WB,=NUM01,BEF10 YES JUMP ! 7442: MOV =B$ICL,WA INTEGER ! 7443: BEQ WB,=NUM02,BEF10 YES JUMP ! 7444: MOV =B$RCL,WA REAL ! 7445: * ! 7446: * STORE TYPE WORD IN RESULT ! 7447: * ! 7448: BEF10 MOV WA,(XR) STORED BEFORE COPYING TO DYNAMIC ! 7449: * ! 7450: * MERGE FOR UNCONVERTED RESULT ! 7451: * ! 7452: BEF11 JSR BLKLN GET LENGTH OF BLOCK ! 7453: MOV XR,XL COPY ADDRESS OF OLD BLOCK ! 7454: JSR ALLOC ALLOCATE DYNAMIC BLOCK SAME SIZE ! 7455: MOV XR,-(XS) SET POINTER TO NEW BLOCK AS RESULT ! 7456: MVW COPY OLD BLOCK TO DYNAMIC BLOCK ! 7457: BRN EXITS EXIT WITH RESULT ON STACK ! 7458: EJC ! 7459: * ! 7460: * EVBLK ! 7461: * ! 7462: * THE ROUTINE FOR AN EVBLK IS NEVER EXECUTED ! 7463: * ! 7464: B$EVT ENT BL$EV ENTRY POINT (EVBLK) ! 7465: EJC ! 7466: * ! 7467: * FFBLK ! 7468: * ! 7469: * THE ROUTINE FOR AN FFBLK IS EXECUTED FROM THE O$FNC ENTRY ! 7470: * TO CALL A FIELD FUNCTION AND EXTRACT A FIELD VALUE/NAME. ! 7471: * ! 7472: * (XL) POINTER TO FFBLK ! 7473: * ! 7474: B$FFC ENT BL$FF ENTRY POINT (FFBLK) ! 7475: MOV XL,XR COPY FFBLK POINTER ! 7476: LCW WC LOAD NEXT CODE WORD ! 7477: MOV (XS),XL LOAD PDBLK POINTER ! 7478: BNE (XL),=B$PDT,BFFC2 JUMP IF NOT PDBLK AT ALL ! 7479: MOV PDDFP(XL),WA LOAD DFBLK POINTER FROM PDBLK ! 7480: * ! 7481: * LOOP TO FIND CORRECT FFBLK FOR THIS PDBLK ! 7482: * ! 7483: BFFC1 BEQ WA,FFDFP(XR),BFFC3 JUMP IF THIS IS THE CORRECT FFBLK ! 7484: MOV FFNXT(XR),XR ELSE LINK TO NEXT FFBLK ON CHAIN ! 7485: BNZ XR,BFFC1 LOOP BACK IF ANOTHER ENTRY TO CHECK ! 7486: * ! 7487: * HERE FOR BAD ARGUMENT ! 7488: * ! 7489: BFFC2 ERB 041,FIELD FUNCTION ARGUMENT IS WRONG DATATYPE ! 7490: EJC ! 7491: * ! 7492: * FFBLK (CONTINUED) ! 7493: * ! 7494: * HERE AFTER LOCATING CORRECT FFBLK ! 7495: * ! 7496: BFFC3 MOV FFOFS(XR),WA LOAD FIELD OFFSET ! 7497: BEQ WC,=OFNE$,BFFC5 JUMP IF CALLED BY NAME ! 7498: ADD WA,XL ELSE POINT TO VALUE FIELD ! 7499: MOV (XL),XR LOAD VALUE ! 7500: BNE (XR),=B$TRT,BFFC4 JUMP IF NOT TRAPPED ! 7501: SUB WA,XL ELSE RESTORE NAME BASE,OFFSET ! 7502: MOV WC,(XS) SAVE NEXT CODE WORD OVER PDBLK PTR ! 7503: JSR ACESS ACCESS VALUE ! 7504: PPM EXFAL FAIL IF ACCESS FAILS ! 7505: MOV (XS),WC RESTORE NEXT CODE WORD ! 7506: * ! 7507: * HERE AFTER GETTING VALUE IN (XR) ! 7508: * ! 7509: BFFC4 MOV XR,(XS) STORE VALUE ON STACK (OVER PDBLK) ! 7510: MOV WC,XR COPY NEXT CODE WORD ! 7511: MOV (XR),XL LOAD ENTRY ADDRESS ! 7512: BRI XL JUMP TO ROUTINE FOR NEXT CODE WORD ! 7513: * ! 7514: * HERE IF CALLED BY NAME ! 7515: * ! 7516: BFFC5 MOV WA,-(XS) STORE NAME OFFSET (BASE IS SET) ! 7517: BRN EXITS EXIT WITH NAME ON STACK ! 7518: EJC ! 7519: * ! 7520: * ICBLK ! 7521: * ! 7522: * THE ROUTINE FOR ICBLK IS EXECUTED FROM THE GENERATED ! 7523: * CODE TO LOAD AN INTEGER VALUE ONTO THE STACK. ! 7524: * ! 7525: * (XR) POINTER TO ICBLK ! 7526: * ! 7527: B$ICL ENT BL$IC ENTRY POINT (ICBLK) ! 7528: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD ! 7529: EJC ! 7530: * ! 7531: * KVBLK ! 7532: * ! 7533: * THE ROUTINE FOR A KVBLK IS NEVER EXECUTED. ! 7534: * ! 7535: B$KVT ENT BL$KV ENTRY POINT (KVBLK) ! 7536: EJC ! 7537: * ! 7538: * NMBLK ! 7539: * ! 7540: * THE ROUTINE FOR A NMBLK IS EXECUTED FROM THE GENERATED ! 7541: * CODE FOR THE CASE OF LOADING A NAME ONTO THE STACK ! 7542: * WHERE THE NAME IS THAT OF A NATURAL VARIABLE WHICH CAN ! 7543: * BE PREEVALUATED AT COMPILE TIME. ! 7544: * ! 7545: * (XR) POINTER TO NMBLK ! 7546: * ! 7547: B$NML ENT BL$NM ENTRY POINT (NMBLK) ! 7548: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD ! 7549: EJC ! 7550: * ! 7551: * PDBLK ! 7552: * ! 7553: * THE ROUTINE FOR A PDBLK IS NEVER EXECUTED ! 7554: * ! 7555: B$PDT ENT BL$PD ENTRY POINT (PDBLK) ! 7556: EJC ! 7557: * ! 7558: * PFBLK ! 7559: * ! 7560: * THE ROUTINE FOR A PFBLK IS EXECUTED FROM THE ENTRY O$FNC ! 7561: * TO CALL A PROGRAM DEFINED FUNCTION. ! 7562: * ! 7563: * (XL) POINTER TO PFBLK ! 7564: * ! 7565: * THE FOLLOWING STACK ENTRIES ARE MADE BEFORE PASSING ! 7566: * CONTROL TO THE PROGRAM DEFINED FUNCTION. ! 7567: * ! 7568: * SAVED VALUE OF FIRST ARGUMENT ! 7569: * . ! 7570: * SAVED VALUE OF LAST ARGUMENT ! 7571: * SAVED VALUE OF FIRST LOCAL ! 7572: * . ! 7573: * SAVED VALUE OF LAST LOCAL ! 7574: * SAVED VALUE OF FUNCTION NAME ! 7575: * SAVED CODE BLOCK PTR (R$COD) ! 7576: * SAVED CODE POINTER (-R$COD) ! 7577: * SAVED VALUE OF FLPRT ! 7578: * SAVED VALUE OF FLPTR ! 7579: * POINTER TO PFBLK ! 7580: * FLPTR --------------- ZERO (TO BE OVERWRITTEN WITH OFFS) ! 7581: * ! 7582: B$PFC ENT BL$PF ENTRY POINT (PFBLK) ! 7583: MOV XL,BPFPF SAVE PFBLK PTR (NEED NOT BE RELOC) ! 7584: MOV XL,XR COPY FOR THE MOMENT ! 7585: MOV PFVBL(XR),XL POINT TO VRBLK FOR FUNCTION ! 7586: * ! 7587: * LOOP TO FIND OLD VALUE OF FUNCTION ! 7588: * ! 7589: BPF01 MOV XL,WB SAVE POINTER ! 7590: MOV VRVAL(XL),XL LOAD VALUE ! 7591: BEQ (XL),=B$TRT,BPF01 LOOP IF TRBLK ! 7592: * ! 7593: * SET VALUE TO NULL AND SAVE OLD FUNCTION VALUE ! 7594: * ! 7595: MOV XL,BPFSV SAVE OLD VALUE ! 7596: MOV WB,XL POINT BACK TO BLOCK WITH VALUE ! 7597: MOV =NULLS,VRVAL(XL) SET VALUE TO NULL ! 7598: MOV FARGS(XR),WA LOAD NUMBER OF ARGUMENTS ! 7599: ADD *PFARG,XR POINT TO PFARG ENTRIES ! 7600: BZE WA,BPF04 JUMP IF NO ARGUMENTS ! 7601: MOV XS,XT PTR TO LAST ARG ! 7602: WTB WA CONVERT NO. OF ARGS TO BYTES OFFSET ! 7603: ADD WA,XT POINT BEFORE FIRST ARG ! 7604: MOV XT,BPFXT REMEMBER ARG POINTER ! 7605: EJC ! 7606: * ! 7607: * PFBLK (CONTINUED) ! 7608: * ! 7609: * LOOP TO SAVE OLD ARGUMENT VALUES AND SET NEW ONES ! 7610: * ! 7611: BPF02 MOV (XR)+,XL LOAD VRBLK PTR FOR NEXT ARGUMENT ! 7612: * ! 7613: * LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE ! 7614: * ! 7615: BPF03 MOV XL,WC SAVE POINTER ! 7616: MOV VRVAL(XL),XL LOAD NEXT VALUE ! 7617: BEQ (XL),=B$TRT,BPF03 LOOP BACK IF TRBLK ! 7618: * ! 7619: * SAVE OLD VALUE AND GET NEW VALUE ! 7620: * ! 7621: MOV XL,WA KEEP OLD VALUE ! 7622: MOV BPFXT,XT POINT BEFORE NEXT STACKED ARG ! 7623: MOV -(XT),WB LOAD ARGUMENT (NEW VALUE) ! 7624: MOV WA,(XT) SAVE OLD VALUE ! 7625: MOV XT,BPFXT KEEP ARG PTR FOR NEXT TIME ! 7626: MOV WC,XL POINT BACK TO BLOCK WITH VALUE ! 7627: MOV WB,VRVAL(XL) SET NEW VALUE ! 7628: BNE XS,BPFXT,BPF02 LOOP IF NOT ALL DONE ! 7629: * ! 7630: * NOW PROCESS LOCALS ! 7631: * ! 7632: BPF04 MOV BPFPF,XL RESTORE PFBLK POINTER ! 7633: MOV PFNLO(XL),WA LOAD NUMBER OF LOCALS ! 7634: BZE WA,BPF07 JUMP IF NO LOCALS ! 7635: MOV =NULLS,WB GET NULL CONSTANT ! 7636: LCT WA,WA SET LOCAL COUNTER ! 7637: * ! 7638: * LOOP TO PROCESS LOCALS ! 7639: * ! 7640: BPF05 MOV (XR)+,XL LOAD VRBLK PTR FOR NEXT LOCAL ! 7641: * ! 7642: * LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE ! 7643: * ! 7644: BPF06 MOV XL,WC SAVE POINTER ! 7645: MOV VRVAL(XL),XL LOAD NEXT VALUE ! 7646: BEQ (XL),=B$TRT,BPF06 LOOP BACK IF TRBLK ! 7647: * ! 7648: * SAVE OLD VALUE AND SET NULL AS NEW VALUE ! 7649: * ! 7650: MOV XL,-(XS) STACK OLD VALUE ! 7651: MOV WC,XL POINT BACK TO BLOCK WITH VALUE ! 7652: MOV WB,VRVAL(XL) SET NULL AS NEW VALUE ! 7653: BCT WA,BPF05 LOOP TILL ALL LOCALS PROCESSED ! 7654: EJC ! 7655: * ! 7656: * PFBLK (CONTINUED) ! 7657: * ! 7658: * HERE AFTER PROCESSING ARGUMENTS AND LOCALS ! 7659: * ! 7660: BPF07 ZER XR ZERO REG XR IN CASE ! 7661: BZE KVPFL,BPF7C SKIP IF PROFILING IS OFF ! 7662: BEQ KVPFL,=NUM02,BPF7A BRANCH ON TYPE OF PROFILE ! 7663: * ! 7664: * HERE IF &PROFILE = 1 ! 7665: * ! 7666: JSR SYSTM GET CURRENT TIME ! 7667: STI PFETM SAVE FOR A SEC ! 7668: SBI PFSTM FIND TIME USED BY CALLER ! 7669: JSR ICBLD BUILD INTO AN ICBLK ! 7670: LDI PFETM RELOAD CURRENT TIME ! 7671: BRN BPF7B MERGE ! 7672: * ! 7673: * HERE IF &PROFILE = 2 ! 7674: * ! 7675: BPF7A LDI PFSTM GET START TIME OF CALLING STMT ! 7676: JSR ICBLD ASSEMBLE AN ICBLK ROUND IT ! 7677: JSR SYSTM GET NOW TIME ! 7678: * ! 7679: * BOTH TYPES OF PROFILE MERGE HERE ! 7680: * ! 7681: BPF7B STI PFSTM SET START TIME OF 1ST FUNC STMT ! 7682: MNZ PFFNC FLAG FUNCTION ENTRY ! 7683: * ! 7684: * NO PROFILING MERGES HERE ! 7685: * ! 7686: BPF7C MOV XR,-(XS) STACK ICBLK PTR (OR ZERO) ! 7687: MOV R$COD,WA LOAD OLD CODE BLOCK POINTER ! 7688: SCP WB GET CODE POINTER ! 7689: SUB WA,WB MAKE CODE POINTER INTO OFFSET ! 7690: MOV BPFPF,XL RECALL PFBLK POINTER ! 7691: MOV BPFSV,-(XS) STACK OLD VALUE OF FUNCTION NAME ! 7692: MOV WA,-(XS) STACK CODE BLOCK POINTER ! 7693: MOV WB,-(XS) STACK CODE OFFSET ! 7694: MOV FLPRT,-(XS) STACK OLD FLPRT ! 7695: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER ! 7696: MOV XL,-(XS) STACK POINTER TO PFBLK ! 7697: ZER -(XS) DUMMY ZERO ENTRY FOR FAIL RETURN ! 7698: CHK CHECK FOR STACK OVERFLOW ! 7699: MOV XS,FLPTR SET NEW FAIL RETURN VALUE ! 7700: MOV XS,FLPRT SET NEW FLPRT ! 7701: MOV KVTRA,WA LOAD TRACE VALUE ! 7702: ADD KVFTR,WA ADD FTRACE VALUE ! 7703: BNZ WA,BPF09 JUMP IF TRACING POSSIBLE ! 7704: ICV KVFNC ELSE BUMP FNCLEVEL ! 7705: * ! 7706: * HERE TO ACTUALLY JUMP TO FUNCTION ! 7707: * ! 7708: BPF08 MOV PFCOD(XL),XR POINT TO CODE ! 7709: BRI (XR) OFF TO EXECUTE FUNCTION ! 7710: * ! 7711: * HERE IF TRACING IS POSSIBLE ! 7712: * ! 7713: BPF09 MOV PFCTR(XL),XR LOAD POSSIBLE CALL TRACE TRBLK ! 7714: MOV PFVBL(XL),XL LOAD VRBLK POINTER FOR FUNCTION ! 7715: MOV *VRVAL,WA SET NAME OFFSET FOR VARIABLE ! 7716: BZE KVTRA,BPF10 JUMP IF TRACE MODE IS OFF ! 7717: BZE XR,BPF10 OR IF THERE IS NO CALL TRACE ! 7718: * ! 7719: * HERE IF CALL TRACED ! 7720: * ! 7721: DCV KVTRA DECREMENT TRACE COUNT ! 7722: BZE TRFNC(XR),BPF11 JUMP IF PRINT TRACE ! 7723: JSR TRXEQ EXECUTE FUNCTION TYPE TRACE ! 7724: EJC ! 7725: * ! 7726: * PFBLK (CONTINUED) ! 7727: * ! 7728: * HERE TO TEST FOR FTRACE TRACE ! 7729: * ! 7730: BPF10 BZE KVFTR,BPF16 JUMP IF FTRACE IS OFF ! 7731: DCV KVFTR ELSE DECREMENT FTRACE ! 7732: * ! 7733: * HERE FOR PRINT TRACE ! 7734: * ! 7735: BPF11 JSR PRTSN PRINT STATEMENT NUMBER ! 7736: JSR PRTNM PRINT FUNCTION NAME ! 7737: MOV =CH$PP,WA LOAD LEFT PAREN ! 7738: JSR PRTCH PRINT LEFT PAREN ! 7739: MOV 1(XS),XL RECOVER PFBLK POINTER ! 7740: BZE FARGS(XL),BPF15 SKIP IF NO ARGUMENTS ! 7741: ZER WB ELSE SET ARGUMENT COUNTER ! 7742: BRN BPF13 JUMP INTO LOOP ! 7743: * ! 7744: * LOOP TO PRINT ARGUMENT VALUES ! 7745: * ! 7746: BPF12 MOV =CH$CM,WA LOAD COMMA ! 7747: JSR PRTCH PRINT TO SEPARATE FROM LAST ARG ! 7748: * ! 7749: * MERGE HERE FIRST TIME (NO COMMA REQUIRED) ! 7750: * ! 7751: BPF13 MOV WB,(XS) SAVE ARG CTR (OVER FAILOFFS IS OK) ! 7752: WTB WB CONVERT TO BYTE OFFSET ! 7753: ADD WB,XL POINT TO NEXT ARGUMENT POINTER ! 7754: MOV PFARG(XL),XR LOAD NEXT ARGUMENT VRBLK PTR ! 7755: SUB WB,XL RESTORE PFBLK POINTER ! 7756: MOV VRVAL(XR),XR LOAD NEXT VALUE ! 7757: JSR PRTVL PRINT ARGUMENT VALUE ! 7758: EJC ! 7759: * ! 7760: * HERE AFTER DEALING WITH ONE ARGUMENT ! 7761: * ! 7762: MOV (XS),WB RESTORE ARGUMENT COUNTER ! 7763: ICV WB INCREMENT ARGUMENT COUNTER ! 7764: BLT WB,FARGS(XL),BPF12 LOOP IF MORE TO PRINT ! 7765: * ! 7766: * MERGE HERE IN NO ARGS CASE TO PRINT PAREN ! 7767: * ! 7768: BPF15 MOV =CH$RP,WA LOAD RIGHT PAREN ! 7769: JSR PRTCH PRINT TO TERMINATE OUTPUT ! 7770: JSR PRTNL TERMINATE PRINT LINE ! 7771: * ! 7772: * MERGE HERE TO EXIT WITH TEST FOR FNCLEVEL TRACE ! 7773: * ! 7774: BPF16 ICV KVFNC INCREMENT FNCLEVEL ! 7775: MOV R$FNC,XL LOAD PTR TO POSSIBLE TRBLK ! 7776: JSR KTREX CALL KEYWORD TRACE ROUTINE ! 7777: * ! 7778: * CALL FUNCTION AFTER TRACE TESTS COMPLETE ! 7779: * ! 7780: MOV 1(XS),XL RESTORE PFBLK POINTER ! 7781: BRN BPF08 JUMP BACK TO EXECUTE FUNCTION ! 7782: EJC ! 7783: * ! 7784: * RCBLK ! 7785: * ! 7786: * THE ROUTINE FOR AN RCBLK IS EXECUTED FROM THE GENERATED ! 7787: * CODE TO LOAD A REAL VALUE ONTO THE STACK. ! 7788: * ! 7789: * (XR) POINTER TO RCBLK ! 7790: * ! 7791: B$RCL ENT BL$RC ENTRY POINT (RCBLK) ! 7792: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD ! 7793: EJC ! 7794: * ! 7795: * SCBLK ! 7796: * ! 7797: * THE ROUTINE FOR AN SCBLK IS EXECUTED FROM THE GENERATED ! 7798: * CODE TO LOAD A STRING VALUE ONTO THE STACK. ! 7799: * ! 7800: * (XR) POINTER TO SCBLK ! 7801: * ! 7802: B$SCL ENT BL$SC ENTRY POINT (SCBLK) ! 7803: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD ! 7804: EJC ! 7805: * ! 7806: * TBBLK ! 7807: * ! 7808: * THE ROUTINE FOR A TBBLK IS NEVER EXECUTED ! 7809: * ! 7810: B$TBT ENT BL$TB ENTRY POINT (TBBLK) ! 7811: EJC ! 7812: * ! 7813: * TEBLK ! 7814: * ! 7815: * THE ROUTINE FOR A TEBLK IS NEVER EXECUTED ! 7816: * ! 7817: B$TET ENT BL$TE ENTRY POINT (TEBLK) ! 7818: EJC ! 7819: * ! 7820: * VCBLK ! 7821: * ! 7822: * THE ROUTINE FOR A VCBLK IS NEVER EXECUTED ! 7823: * ! 7824: B$VCT ENT BL$VC ENTRY POINT (VCBLK) ! 7825: EJC ! 7826: * ! 7827: * VRBLK ! 7828: * ! 7829: * THE VRBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE. ! 7830: * THERE ARE SIX ENTRIES FOR VRBLK COVERING VARIOUS CASES ! 7831: * ! 7832: B$VR$ ENT BL$$I MARK START OF VRBLK ENTRY POINTS ! 7833: * ! 7834: * ENTRY FOR VRGET (TRAPPED CASE). THIS ROUTINE IS CALLED ! 7835: * FROM THE GENERATED CODE TO LOAD THE VALUE OF A VARIABLE. ! 7836: * THIS ENTRY POINT IS USED IF AN ACCESS TRACE OR INPUT ! 7837: * ASSOCIATION IS CURRENTLY ACTIVE. ! 7838: * ! 7839: * (XR) POINTER TO VRGET FIELD OF VRBLK ! 7840: * ! 7841: B$VRA ENT BL$$I ENTRY POINT ! 7842: MOV XR,XL COPY NAME BASE (VRGET = 0) ! 7843: MOV *VRVAL,WA SET NAME OFFSET ! 7844: JSR ACESS ACCESS VALUE ! 7845: PPM EXFAL FAIL IF ACCESS FAILS ! 7846: BRN EXIXR ELSE EXIT WITH RESULT IN XR ! 7847: EJC ! 7848: * ! 7849: * VRBLK (CONTINUED) ! 7850: * ! 7851: * ENTRY FOR VRSTO (ERROR CASE. THIS ROUTINE IS CALLED FROM ! 7852: * THE EXECUTED CODE FOR AN ATTEMPT TO MODIFY THE VALUE ! 7853: * OF A PROTECTED (PATTERN VALUED) NATURAL VARIABLE. ! 7854: * ! 7855: B$VRE ENT ENTRY POINT ! 7856: ERB 042,ATTEMPT TO CHANGE VALUE OF PROTECTED VARIABLE ! 7857: EJC ! 7858: * ! 7859: * VRBLK (CONTINUED) ! 7860: * ! 7861: * ENTRY FOR VRTRA (UNTRAPPED CASE). THIS ROUTINE IS CALLED ! 7862: * FROM THE EXECUTED CODE TO TRANSFER TO A LABEL. ! 7863: * ! 7864: * (XR) POINTER TO VRTRA FIELD OF VRBLK ! 7865: * ! 7866: B$VRG ENT ENTRY POINT ! 7867: MOV VRLBO(XR),XR LOAD CODE POINTER ! 7868: MOV (XR),XL LOAD ENTRY ADDRESS ! 7869: BRI XL JUMP TO ROUTINE FOR NEXT CODE WORD ! 7870: EJC ! 7871: * ! 7872: * VRBLK (CONTINUED) ! 7873: * ! 7874: * ENTRY FOR VRGET (UNTRAPPED CASE). THIS ROUTINE IS CALLED ! 7875: * FROM THE GENERATED CODE TO LOAD THE VALUE OF A VARIABLE. ! 7876: * ! 7877: * (XR) POINTS TO VRGET FIELD OF VRBLK ! 7878: * ! 7879: B$VRL ENT ENTRY POINT ! 7880: MOV VRVAL(XR),-(XS) LOAD VALUE ONTO STACK (VRGET = 0) ! 7881: BRN EXITS OBEY NEXT CODE WORD ! 7882: EJC ! 7883: * ! 7884: * VRBLK (CONTINUED) ! 7885: * ! 7886: * ENTRY FOR VRSTO (UNTRAPPED CASE). THIS ROUTINE IS CALLED ! 7887: * FROM THE GENERATED CODE TO STORE THE VALUE OF A VARIABLE. ! 7888: * ! 7889: * (XR) POINTER TO VRSTO FIELD OF VRBLK ! 7890: * ! 7891: B$VRS ENT ENTRY POINT ! 7892: MOV (XS),VRVLO(XR) STORE VALUE, LEAVE ON STACK ! 7893: BRN EXITS OBEY NEXT CODE WORD ! 7894: EJC ! 7895: * ! 7896: * VRBLK (CONTINUED) ! 7897: * ! 7898: * VRTRA (TRAPPED CASE). THIS ROUTINE IS CALLED FROM THE ! 7899: * GENERATED CODE TO TRANSFER TO A LABEL WHEN A LABEL ! 7900: * TRACE IS CURRENTLY ACTIVE. ! 7901: * ! 7902: B$VRT ENT ENTRY POINT ! 7903: SUB *VRTRA,XR POINT BACK TO START OF VRBLK ! 7904: MOV XR,XL COPY VRBLK POINTER ! 7905: MOV *VRVAL,WA SET NAME OFFSET ! 7906: MOV VRLBL(XL),XR LOAD POINTER TO TRBLK ! 7907: BZE KVTRA,BVRT2 JUMP IF TRACE IS OFF ! 7908: DCV KVTRA ELSE DECREMENT TRACE COUNT ! 7909: BZE TRFNC(XR),BVRT1 JUMP IF PRINT TRACE CASE ! 7910: JSR TRXEQ ELSE EXECUTE FULL TRACE ! 7911: BRN BVRT2 MERGE TO JUMP TO LABEL ! 7912: * ! 7913: * HERE FOR PRINT TRACE -- PRINT COLON ( LABEL NAME ) ! 7914: * ! 7915: BVRT1 JSR PRTSN PRINT STATEMENT NUMBER ! 7916: MOV XL,XR COPY VRBLK POINTER ! 7917: MOV =CH$CL,WA COLON ! 7918: JSR PRTCH PRINT IT ! 7919: MOV =CH$PP,WA LEFT PAREN ! 7920: JSR PRTCH PRINT IT ! 7921: JSR PRTVN PRINT LABEL NAME ! 7922: MOV =CH$RP,WA RIGHT PAREN ! 7923: JSR PRTCH PRINT IT ! 7924: JSR PRTNL TERMINATE LINE ! 7925: MOV VRLBL(XL),XR POINT BACK TO TRBLK ! 7926: * ! 7927: * MERGE HERE TO JUMP TO LABEL ! 7928: * ! 7929: BVRT2 MOV TRLBL(XR),XR LOAD POINTER TO ACTUAL CODE ! 7930: BRI (XR) EXECUTE STATEMENT AT LABEL ! 7931: EJC ! 7932: * ! 7933: * VRBLK (CONTINUED) ! 7934: * ! 7935: * ENTRY FOR VRSTO (TRAPPED CASE). THIS ROUTINE IS CALLED ! 7936: * FROM THE GENERATED CODE TO STORE THE VALUE OF A VARIABLE. ! 7937: * THIS ENTRY IS USED WHEN A VALUE TRACE OR OUTPUT ! 7938: * ASSOCIATION IS CURRENTLY ACTIVE. ! 7939: * ! 7940: * (XR) POINTER TO VRSTO FIELD OF VRBLK ! 7941: * ! 7942: B$VRV ENT ENTRY POINT ! 7943: MOV (XS),WB LOAD VALUE (LEAVE COPY ON STACK) ! 7944: SUB *VRSTO,XR POINT TO VRBLK ! 7945: MOV XR,XL COPY VRBLK POINTER ! 7946: MOV *VRVAL,WA SET OFFSET ! 7947: JSR ASIGN CALL ASSIGNMENT ROUTINE ! 7948: PPM EXFAL FAIL IF ASSIGNMENT FAILS ! 7949: BRN EXITS ELSE RETURN WITH RESULT ON STACK ! 7950: EJC ! 7951: * ! 7952: * XNBLK ! 7953: * ! 7954: * THE ROUTINE FOR AN XNBLK IS NEVER EXECUTED ! 7955: * ! 7956: B$XNT ENT BL$XN ENTRY POINT (XNBLK) ! 7957: EJC ! 7958: * ! 7959: * XRBLK ! 7960: * ! 7961: * THE ROUTINE FOR AN XRBLK IS NEVER EXECUTED ! 7962: * ! 7963: B$XRT ENT BL$XR ENTRY POINT (XRBLK) ! 7964: * ! 7965: * MARK ENTRY ADDRESS PAST LAST BLOCK ACTION ROUTINE ! 7966: * ! 7967: B$YYY ENT BL$$I LAST BLOCK ROUTINE ENTRY POINT ! 7968: TTL S P I T B O L -- PATTERN MATCHING ROUTINES ! 7969: * ! 7970: * THE FOLLOWING SECTION CONSISTS OF THE PATTERN MATCHING ! 7971: * ROUTINES. ALL PATTERN NODES CONTAIN A POINTER (PCODE) ! 7972: * TO ONE OF THE ROUTINES IN THIS SECTION (P$XXX). ! 7973: * ! 7974: * NOTE THAT THIS SECTION FOLLOWS THE B$XXX ROUTINES TO ! 7975: * ENABLE A FAST TEST FOR THE PATTERN DATATYPE. ! 7976: * ! 7977: P$AAA ENT BL$$I ENTRY TO MARK FIRST PATTERN ! 7978: * ! 7979: * ! 7980: * THE ENTRY CONDITIONS TO THE MATCH ROUTINE ARE AS FOLLOWS ! 7981: * (SEE O$PMN, O$PMV, O$PMS AND PROCEDURE MATCH). ! 7982: * ! 7983: * STACK CONTENTS. ! 7984: * ! 7985: * NAME BASE (O$PMN ONLY) ! 7986: * NAME OFFSET (O$PMN ONLY) ! 7987: * TYPE (0-O$PMN, 1-O$PMV, 2-O$PMS) ! 7988: * PMHBS --------------- INITIAL CURSOR (ZERO) ! 7989: * INITIAL NODE POINTER ! 7990: * XS ------------------ =NDABO (ANCHORED), =NDUNA (UNANCH) ! 7991: * ! 7992: * REGISTER VALUES. ! 7993: * ! 7994: * (XS) SET AS SHOWN IN STACK DIAGRAM ! 7995: * (XR) POINTER TO INITIAL PATTERN NODE ! 7996: * (WB) INITIAL CURSOR (ZERO) ! 7997: * ! 7998: * GLOBAL PATTERN VALUES ! 7999: * ! 8000: * R$PMS POINTER TO SUBJECT STRING SCBLK ! 8001: * PMSSL LENGTH OF SUBJECT STRING IN CHARS ! 8002: * PMDFL DOT FLAG, INITIALLY ZERO ! 8003: * PMHBS SET AS SHOWN IN STACK DIAGRAM ! 8004: * ! 8005: * CONTROL IS PASSED BY BRANCHING THROUGH THE PCODE ! 8006: * FIELD OF THE INITIAL PATTERN NODE (BRI (XR)). ! 8007: EJC ! 8008: * ! 8009: * DESCRIPTION OF ALGORITHM ! 8010: * ! 8011: * A PATTERN STRUCTURE IS REPRESENTED AS A LINKED GRAPH ! 8012: * OF NODES WITH THE FOLLOWING STRUCTURE. ! 8013: * ! 8014: * +------------------------------------+ ! 8015: * I PCODE I ! 8016: * +------------------------------------+ ! 8017: * I PTHEN I ! 8018: * +------------------------------------+ ! 8019: * I PARM1 I ! 8020: * +------------------------------------+ ! 8021: * I PARM2 I ! 8022: * +------------------------------------+ ! 8023: * ! 8024: * PCODE IS A POINTER TO THE ROUTINE WHICH WILL PERFORM ! 8025: * THE MATCH OF THIS PARTICULAR NODE TYPE. ! 8026: * ! 8027: * PTHEN IS A POINTER TO THE SUCCESSOR NODE. I.E. THE NODE ! 8028: * TO BE MATCHED IF THE ATTEMPT TO MATCH THIS NODE SUCCEEDS. ! 8029: * IF THIS IS THE LAST NODE OF THE PATTERN PTHEN POINTS ! 8030: * TO THE DUMMY NODE NDNTH WHICH INITIATES PATTERN EXIT. ! 8031: * ! 8032: * PARM1, PARM2 ARE PARAMETERS WHOSE USE VARIES WITH THE ! 8033: * PARTICULAR NODE. THEY ARE ONLY PRESENT IF REQUIRED. ! 8034: * ! 8035: * ALTERNATIVES ARE HANDLED WITH THE SPECIAL ALTERNATIVE ! 8036: * NODE WHOSE PARAMETER POINTS TO THE NODE TO BE MATCHED ! 8037: * IF THERE IS A FAILURE ON THE SUCCESSOR PATH. ! 8038: * ! 8039: * THE FOLLOWING EXAMPLE ILLUSTRATES THE MANNER IN WHICH ! 8040: * THE STRUCTURE IS BUILT UP. THE PATTERN IS ! 8041: * ! 8042: * (A / B / C) (D / E) WHERE / IS ALTERNATION ! 8043: * ! 8044: * IN THE DIAGRAM, THE NODE MARKED + REPRESENTS AN ! 8045: * ALTERNATIVE NODE AND THE DOTTED LINE FROM A + NODE ! 8046: * REPRESENTS THE PARAMETER POINTER TO THE ALTERNATIVE. ! 8047: * ! 8048: * +---+ +---+ +---+ +---+ ! 8049: * I + I-----I A I-----I + I-----I D I----- ! 8050: * +---+ +---+ I +---+ +---+ ! 8051: * . I . ! 8052: * . I . ! 8053: * +---+ +---+ I +---+ ! 8054: * I + I-----I B I--I I E I----- ! 8055: * +---+ +---+ I +---+ ! 8056: * . I ! 8057: * . I ! 8058: * +---+ I ! 8059: * I C I------------I ! 8060: * +---+ ! 8061: EJC ! 8062: * ! 8063: * DURING THE MATCH, THE REGISTERS ARE USED AS FOLLOWS. ! 8064: * ! 8065: * (XR) POINTS TO THE CURRENT NODE ! 8066: * (XL) SCRATCH ! 8067: * (XS) MAIN STACK POINTER ! 8068: * (WB) CURSOR (NUMBER OF CHARS MATCHED) ! 8069: * (WA,WC) SCRATCH ! 8070: * ! 8071: * TO KEEP TRACK OF ALTERNATIVES, THE MAIN STACK IS USED AS ! 8072: * A HISTORY STACK AND CONTAINS TWO WORD ENTRIES. ! 8073: * ! 8074: * WORD 1 SAVED CURSOR VALUE ! 8075: * WORD 2 NODE TO MATCH ON FAILURE ! 8076: * ! 8077: * WHEN A FAILURE OCCURS, THE MOST RECENT ENTRY ON THIS ! 8078: * STACK IS POPPED OFF TO RESTORE THE CURSOR AND POINT ! 8079: * TO THE NODE TO BE MATCHED AS AN ALTERNATIVE. THE ENTRY ! 8080: * AT THE BOTTOM OF THE STACK POINTS TO THE FOLLOWING ! 8081: * SPECIAL NODES DEPENDING ON THE SCAN MODE. ! 8082: * ! 8083: * ANCHORED MODE THE BOTTOM ENTRY POINTS TO THE ! 8084: * SPECIAL NODE NDABO WHICH CAUSES AN ! 8085: * ABORT. THE CURSOR VALUE STORED ! 8086: * WITH THIS ENTRY IS ALWAYS ZERO. ! 8087: * ! 8088: * UNANCHORED MODE THE BOTTOM ENTRY POINTS TO THE ! 8089: * SPECIAL NODE NDUNA WHICH MOVES THE ! 8090: * ANCHOR POINT AND RESTARTS THE MATCH ! 8091: * THE CURSOR SAVED WITH THIS ENTRY ! 8092: * IS THE NUMBER OF CHARACTERS WHICH ! 8093: * LIE BEFORE THE INITIAL ANCHOR POINT ! 8094: * (I.E. THE NUMBER OF ANCHOR MOVES). ! 8095: * THIS ENTRY IS THREE WORDS LONG AND ! 8096: * ALSO CONTAINS THE INITIAL PATTERN. ! 8097: * ! 8098: * ENTRIES ARE MADE ON THIS HISTORY STACK BY ALTERNATIVE ! 8099: * NODES AND BY SOME SPECIAL COMPOUD PATTERNS AS DESCRIBED ! 8100: * LATER ON. THE FOLLOWING GLOBAL LOCATIONS ARE USED DURING ! 8101: * PATTERN MATCHING. ! 8102: * ! 8103: * R$PMS POINTER TO SUBJECT STRING ! 8104: * PMSSL LENGTH OF SUBJECT STRING ! 8105: * PMDFL FLAG SET NON-ZERO FOR DOT PATTERNS ! 8106: * PMHBS BASE PTR FOR CURRENT HISTORY STACK ! 8107: * ! 8108: * THE FOLLOWING EXIT POINTS ARE AVAILABLE TO MATCH ROUTINES ! 8109: * ! 8110: * SUCCP SUCCESS IN MATCHING CURRENT NODE ! 8111: * FAILP FAILURE IN MATCHING CURRENT NODE ! 8112: EJC ! 8113: * ! 8114: * COMPOUND PATTERNS ! 8115: * ! 8116: * SOME PATTERNS HAVE IMPLICIT ALTERNATIVES AND THEIR ! 8117: * REPRESENTATION IN THE PATTERN STRUCTURE CONSISTS OF A ! 8118: * LINKED SET OF NODES AS INDICATED BY THESE DIAGRAMS. ! 8119: * ! 8120: * AS BEFORE, THE + REPRESENTS AN ALTERNATIVE NODE AND ! 8121: * THE DOTTED LINE FROM A + NODE IS THE PARAMETER POINTER ! 8122: * TO THE ALTERNATIVE PATTERN. ! 8123: * ! 8124: * ARB ! 8125: * --- ! 8126: * ! 8127: * +---+ THIS NODE (P$ARB) MATCHES NULL ! 8128: * I B I----- AND STACKS CURSOR, SUCCESSOR PTR, ! 8129: * +---+ CURSOR (COPY) AND A PTR TO NDARC. ! 8130: * ! 8131: * ! 8132: * ! 8133: * ! 8134: * BAL ! 8135: * --- ! 8136: * ! 8137: * +---+ THE P$BAL NODE SCANS A BALANCED ! 8138: * I B I----- STRING AND THEN STACKS A POINTER ! 8139: * +---+ TO ITSELF ON THE HISTORY STACK. ! 8140: EJC ! 8141: * ! 8142: * COMPOUND PATTERN STRUCTURES (CONTINUED) ! 8143: * ! 8144: * ! 8145: * ARBNO ! 8146: * ----- ! 8147: * ! 8148: * +---+ THIS ALTERNATIVE NODE MATCHES NULL ! 8149: * +----I + I----- THE FIRST TIME AND STACKS A POINTER ! 8150: * I +---+ TO THE ARGUMENT PATTERN X. ! 8151: * I . ! 8152: * I . ! 8153: * I +---+ NODE (P$ABA) TO STACK CURSOR ! 8154: * I I A I AND HISTORY STACK BASE PTR. ! 8155: * I +---+ ! 8156: * I I ! 8157: * I I ! 8158: * I +---+ THIS IS THE ARGUMENT PATTERN. AS ! 8159: * I I X I INDICATED, THE SUCCESSOR OF THE ! 8160: * I +---+ PATTERN IS THE P$ABC NODE ! 8161: * I I ! 8162: * I I ! 8163: * I +---+ THIS NODE (P$ABC) POPS PMHBS, ! 8164: * +----I C I STACKS OLD PMHBS AND PTR TO NDABD ! 8165: * +---+ (UNLESS OPTIMISATION HAS OCCURRED) ! 8166: * ! 8167: * STRUCTURE AND EXECUTION OF THIS PATTERN RESEMBLE THOSE OF ! 8168: * RECURSIVE PATTERN MATCHING AND IMMEDIATE ASSIGNMENT. ! 8169: * THE ALTERNATIVE NODE AT THE HEAD OF THE STRUCTURE MATCHES ! 8170: * NULL INITIALLY BUT ON SUBSEQUENT FAILURE ENSURES ATTEMPT ! 8171: * TO MATCH THE ARGUMENT. BEFORE THE ARGUMENT IS MATCHED ! 8172: * P$ABA STACKS THE CURSOR,PMHBS AND A PTR TO P$ABB. IF ! 8173: * THE ARGUMENT CANT BE MATCHED , P$ABB REMOVES THIS SPECIAL ! 8174: * STACK ENTRY AND FAILS. ! 8175: * IF ARGUMENT IS MATCHED , P$ABC RESTORES THE OUTER PMHBS ! 8176: * VALUE (SAVED BY P$ABA) . THEN IF THE ARGUMENT HAS LEFT ! 8177: * ALTERNATIVES ON STACK IT STACKS THE INNER VALUE OF PMHBS ! 8178: * AND A PTR TO NDABD. IF ARGUMENT LEFT NOTHING ON THE STACK ! 8179: * IT OPTIMISES BY REMOVING ITEMS STACKED BY P$ABA. FINALLY ! 8180: * A CHECK IS MADE THAT ARGUMENT MATCHED MORE THAN THE NULL ! 8181: * STRING (CHECK IS INTENDED TO PREVENT USELESS LOOPING). ! 8182: * IF SO THE SUCCESSOR IS AGAIN THE ALTERNATIVE NODE AT THE ! 8183: * HEAD OF THE STRUCTURE , ENSURING A POSSIBLE EXTRA ATTEMPT ! 8184: * TO MATCH THE ARG IF NECESSARY. IF NOT , THE SUCCESSOR TO ! 8185: * ALTERNATIVE IS TAKEN SO AS TO TERMINATE THE LOOP. P$ABD ! 8186: * RESTORES INNER PMHBS PTR AND FAILS , THUS TRYING TO MATCH ! 8187: * ALTERNATIVES LEFT BY THE ARBNO ARGUMENT. ! 8188: EJC ! 8189: * ! 8190: * COMPOUND PATTERN STRUCTURES (CONTINUED) ! 8191: * ! 8192: * BREAKX ! 8193: * ------ ! 8194: * ! 8195: * +---+ THIS NODE IS A BREAK NODE FOR ! 8196: * +----I B I THE ARGUMENT TO BREAKX, IDENTICAL ! 8197: * I +---+ TO AN ORDINARY BREAK NODE. ! 8198: * I I ! 8199: * I I ! 8200: * I +---+ THIS ALTERNATIVE NODE STACKS A ! 8201: * I I + I----- POINTER TO THE BREAKX NODE TO ! 8202: * I +---+ ALLOW FOR SUBSEQUENT FAILURE ! 8203: * I . ! 8204: * I . ! 8205: * I +---+ THIS IS THE BREAKX NODE ITSELF. IT ! 8206: * +----I X I MATCHES ONE CHARACTER AND THEN ! 8207: * +---+ PROCEEDS BACK TO THE BREAK NODE. ! 8208: * ! 8209: * ! 8210: * ! 8211: * ! 8212: * FENCE ! 8213: * ----- ! 8214: * ! 8215: * +---+ THE FENCE NODE MATCHES NULL AND ! 8216: * I F I----- STACKS A POINTER TO NODE NDABO TO ! 8217: * +---+ ABORT ON A SUBSEQUENT REMATCH ! 8218: * ! 8219: * ! 8220: * ! 8221: * ! 8222: * SUCCEED ! 8223: * ------- ! 8224: * ! 8225: * +---+ THE NODE FOR SUCCEED MATCHES NULL ! 8226: * I S I----- AND STACKS A POINTER TO ITSELF ! 8227: * +---+ TO REPEAT THE MATCH ON A FAILURE. ! 8228: EJC ! 8229: * ! 8230: * COMPOUND PATTERNS (CONTINUED) ! 8231: * ! 8232: * BINARY DOT (PATTERN ASSIGNMENT) ! 8233: * ------------------------------- ! 8234: * ! 8235: * +---+ THIS NODE (P$PAA) SAVES THE CURRENT ! 8236: * I A I CURSOR AND A POINTER TO THE ! 8237: * +---+ SPECIAL NODE NDPAB ON THE STACK. ! 8238: * I ! 8239: * I ! 8240: * +---+ THIS IS THE STRUCTURE FOR THE ! 8241: * I X I PATTERN LEFT ARGUMENT OF THE ! 8242: * +---+ PATTERN ASSIGNMENT CALL. ! 8243: * I ! 8244: * I ! 8245: * +---+ THIS NODE (P$PAC) SAVES THE CURSOR, ! 8246: * I C I----- A PTR TO ITSELF, THE CURSOR (COPY) ! 8247: * +---+ AND A PTR TO NDPAD ON THE STACK. ! 8248: * ! 8249: * ! 8250: * THE FUNCTION OF THE MATCH ROUTINE FOR NDPAB (P$PAB) ! 8251: * IS SIMPLY TO UNSTACK ITSELF AND FAIL BACK ONTO THE STACK. ! 8252: * ! 8253: * THE MATCH ROUTINE FOR P$PAC ALSO SETS THE GLOBAL PATTERN ! 8254: * FLAG PMDFL NON-ZERO TO INDICATE THAT PATTERN ASSIGNMENTS ! 8255: * MAY HAVE OCCURED IN THE PATTERN MATCH ! 8256: * ! 8257: * IF PMDFL IS SET AT THE END OF THE MATCH (SEE P$NTH), THE ! 8258: * HISTORY STACK IS SCANNED FOR MATCHING NDPAB-NDPAD PAIRS ! 8259: * AND THE CORRESPONDING PATTERN ASSIGNMENTS ARE EXECUTED. ! 8260: * ! 8261: * THE FUNCTION OF THE MATCH ROUTINE FOR NDPAD (P$PAD) ! 8262: * IS SIMPLY TO REMOVE ITS ENTRY FROM THE STACK AND FAIL. ! 8263: * THIS INCLUDES REMOVING THE SPECIAL NODE POINTER STORED ! 8264: * IN ADDITION TO THE STANDARD TWO ENTRIES ON THE STACK. ! 8265: EJC ! 8266: * ! 8267: * COMPOUNT PATTERN STRUCTURES (CONTINUED) ! 8268: * ! 8269: * FENCE (FUNCTION) ! 8270: * ---------------- ! 8271: * ! 8272: * +---+ THIS NODE (P$FNA) SAVES THE ! 8273: * I A I CURRENT HISTORY STACK AND A ! 8274: * +---+ POINTER TO NDFNB ON THE STACK. ! 8275: * I ! 8276: * I ! 8277: * +---+ THIS IS THE PATTERN STRUCTURE ! 8278: * I X I GIVEN AS THE ARGUMENT TO THE ! 8279: * +---+ FENCE FUNCTION. ! 8280: * I ! 8281: * I ! 8282: * +---+ THIS NODE P$FNC RESTORES THE OUTER ! 8283: * I C I HISTORY STACK PTR SAVED IN P$FNA, ! 8284: * +---+ AND STACKS THE INNER STACK BASE ! 8285: * PTR AND A POINTER TO NDFND ON THE ! 8286: * STACK. ! 8287: * ! 8288: * NDFNB (F$FNB) SIMPLY IS THE FAILURE EXIT FOR PATTERN ! 8289: * ARGUMENT FAILURE, AND IT POPS ITSELF AND FAILS ONTO THE ! 8290: * STACK. ! 8291: * ! 8292: * THE MATCH ROUTINE P$FNC ALLOWS FOR AN OPTIMIZATION WHEN ! 8293: * THE FENCE PATTERN LEAVES NO ALTERNATIVES. IN THIS CASE, ! 8294: * THE NDFNB ENTRY IS POPPED, AND THE MATCH CONTINUES. ! 8295: * ! 8296: * NDFND (P$FND) IS ENTERED WHEN THE PATTERN FAILS AFTER ! 8297: * GOING THROUGH A NON-OPTIMIZED P$FNC, AND IT POPS THE ! 8298: * STACK BACK PAST THE INNTER STACK BASE CREATED BY P$FNA ! 8299: EJC ! 8300: * ! 8301: * COMPOUND PATTERNS (CONTINUED) ! 8302: * ! 8303: * EXPRESSION PATTERNS (RECURSIVE PATTERN MATCHES) ! 8304: * ----------------------------------------------- ! 8305: * ! 8306: * INITIAL ENTRY FOR A PATTERN NODE IS TO THE ROUTINE P$EXA. ! 8307: * IF THE EVALUATED RESULT OF THE EXPRESSION IS ITSELF A ! 8308: * PATTERN, THEN THE FOLLOWING STEPS ARE TAKEN TO ARRANGE ! 8309: * FOR PROPER RECURSIVE PROCESSING. ! 8310: * ! 8311: * 1) A POINTER TO THE CURRENT NODE (THE P$EXA NODE) IS ! 8312: * STORED ON THE HISTORY STACK WITH A DUMMY CURSOR. ! 8313: * ! 8314: * 2) A SPECIAL HISTORY STACK ENTRY IS MADE IN WHICH THE ! 8315: * NODE POINTER POINTS TO NDEXB, AND THE CURSOR VALUE ! 8316: * IS THE SAVED VALUE OF PMHBS ON ENTRY TO THIS NODE. ! 8317: * THE MATCH ROUTINE FOR NDEXB (P$EXB) RESTORES PMHBS ! 8318: * FROM THIS CURSOR ENTRY, POPS OFF THE P$EXA NODE ! 8319: * POINTER AND FAILS. ! 8320: * ! 8321: * 3) THE RESULTING HISTORY STACK POINTER IS SAVED IN ! 8322: * PMHBS TO ESTABLISH A NEW LEVEL OF HISTORY STACK. ! 8323: * ! 8324: * AFTER MATCHING A PATTERN, THE END OF MATCH ROUTINE GETS ! 8325: * CONTROL (P$NTH). THIS ROUTINE PROCEEDS AS FOLLOWS. ! 8326: * ! 8327: * 1) LOAD THE CURRENT VALUE OF PMHBS AND RECOGNIZE THE ! 8328: * OUTER LEVEL CASE BY THE FACT THAT THE ASSOCIATED ! 8329: * CURSOR IN THIS CASE IS THE PATTERN MATCH TYPE CODE ! 8330: * WHICH IS LESS THAN 3. TERMINATE THE MATCH IN THIS ! 8331: * CASE AND CONTINUE EXECUTION OF THE PROGRAM. ! 8332: * ! 8333: * 2) OTHERWISE MAKE A SPECIAL HISTORY STACK ENTRY IN ! 8334: * WHICH THE NODE POINTER POINTS TO THE SPECIAL NODE ! 8335: * NDEXC AND THE CURSOR IS THE CURRENT VALUE OF PMHBS. ! 8336: * THE MATCH ROUTINE FOR NDEXC (P$EXC) RESETS PMHBS TO ! 8337: * THIS (INNER) VALUE AND AND THEN FAILS. ! 8338: * ! 8339: * 3) USING THE HISTORY STACK ENTRY MADE ON STARTING THE ! 8340: * EXPRESSION (ACCESSIBLE WITH THE CURRENT VALUE OF ! 8341: * PMHBS), RESTORE THE P$EXA NODE POINTER AND THE OLD ! 8342: * PMHBS SETTING. TAKE THE SUCCESSOR AND CONTINUE. ! 8343: * ! 8344: * AN OPTIMIZATION IS POSSIBLE IF THE EXPRESSION PATTERN ! 8345: * MAKES NO ENTRIES ON THE HISTORY STACK. IN THIS CASE, ! 8346: * INSTEAD OF BUILDING THE P$EXC NODE IN STEP 2, IT IS MORE ! 8347: * EFFICIENT TO SIMPLY POP OFF THE P$EXB ENTRY AND ITS ! 8348: * ASSOCIATED NODE POINTER. THE EFFECT IS THE SAME. ! 8349: EJC ! 8350: * ! 8351: * COMPOUND PATTERNS (CONTINUED) ! 8352: * ! 8353: * BINARY DOLLAR (IMMEDIATE ASSIGNMENT) ! 8354: * ------------------------------------ ! 8355: * ! 8356: * +---+ THIS NODE (P$IMA) STACKS THE CURSOR ! 8357: * I A I PMHBS AND A PTR TO NDIMB AND RESETS ! 8358: * +---+ THE STACK PTR PMHBS. ! 8359: * I ! 8360: * I ! 8361: * +---+ THIS IS THE LEFT STRUCTURE FOR THE ! 8362: * I X I PATTERN LEFT ARGUMENT OF THE ! 8363: * +---+ IMMEDIATE ASSIGNMENT CALL. ! 8364: * I ! 8365: * I ! 8366: * +---+ THIS NODE (P$IMC) PERFORMS THE ! 8367: * I C I----- ASSIGNMENT, POPS PMHBS AND STACKS ! 8368: * +---+ THE OLD PMHBS AND A PTR TO NDIMD. ! 8369: * ! 8370: * ! 8371: * THE STRUCTURE AND EXECUTION OF THIS PATTERN ARE SIMILAR ! 8372: * TO THOSE OF THE RECURSIVE EXPRESSION PATTERN MATCHING. ! 8373: * ! 8374: * THE MATCH ROUTINE FOR NDIMB (P$IMB) RESTORES THE OUTER ! 8375: * LEVEL VALUE OF PMHBS, UNSTACKS THE SAVED CURSOR AND FAILS ! 8376: * ! 8377: * THE MATCH ROUTINE P$IMC USES THE CURRENT VALUE OF PMHBS ! 8378: * TO LOCATE THE P$IMB ENTRY. THIS ENTRY IS USED TO MAKE ! 8379: * THE ASSIGNMENT AND RESTORE THE OUTER LEVEL VALUE OF ! 8380: * PMHBS. FINALLY, THE INNER LEVEL VALUE OF PMHBS AND A ! 8381: * POINTER TO THE SPECIAL NODE NDIMD ARE STACKED. ! 8382: * ! 8383: * THE MATCH ROUTINE FOR NDIMD (P$IMD) RESTORES THE INNER ! 8384: * LEVEL VALUE OF PMHBS AND FAILS BACK INTO THE STACK. ! 8385: * ! 8386: * AN OPTIMIZATION OCCURS IF THE INNER PATTERN MAKES NO ! 8387: * ENTRIES ON THE HISTORY STACK. IN THIS CASE, P$IMC POPS ! 8388: * THE P$IMB ENTRY INSTEAD OF MAKING A P$IMD ENTRY. ! 8389: EJC ! 8390: * ! 8391: * ARBNO ! 8392: * ! 8393: * SEE COMPOUND PATTERNS SECTION FOR STUCTURE AND ! 8394: * ALGORITHM FOR MATCHING THIS NODE TYPE. ! 8395: * ! 8396: * NO PARAMETERS ! 8397: * ! 8398: P$ABA ENT BL$P0 P0BLK ! 8399: MOV WB,-(XS) STACK CURSOR ! 8400: MOV XR,-(XS) STACK DUMMY NODE PTR ! 8401: MOV PMHBS,-(XS) STACK OLD STACK BASE PTR ! 8402: MOV =NDABB,-(XS) STACK PTR TO NODE NDABB ! 8403: MOV XS,PMHBS STORE NEW STACK BASE PTR ! 8404: BRN SUCCP SUCCEED ! 8405: EJC ! 8406: * ! 8407: * ARBNO (REMOVE P$ABA SPECIAL STACK ENTRY) ! 8408: * ! 8409: * NO PARAMETERS (DUMMY PATTERN) ! 8410: * ! 8411: P$ABB ENT ENTRY POINT ! 8412: MOV WB,PMHBS RESTORE HISTORY STACK BASE PTR ! 8413: BRN FLPOP FAIL AND POP DUMMY NODE PTR ! 8414: EJC ! 8415: * ! 8416: * ARBNO (CHECK IF ARG MATCHED NULL STRING) ! 8417: * ! 8418: * NO PARAMETERS (DUMMY PATTERN) ! 8419: * ! 8420: P$ABC ENT BL$P0 P0BLK ! 8421: MOV PMHBS,XT KEEP P$ABB STACK BASE ! 8422: MOV 3(XT),WA LOAD INITIAL CURSOR ! 8423: MOV 1(XT),PMHBS RESTORE OUTER STACK BASE PTR ! 8424: BEQ XT,XS,PABC1 JUMP IF NO HISTORY STACK ENTRIES ! 8425: MOV XT,-(XS) ELSE SAVE INNER PMHBS ENTRY ! 8426: MOV =NDABD,-(XS) STACK PTR TO SPECIAL NODE NDABD ! 8427: BRN PABC2 MERGE ! 8428: * ! 8429: * OPTIMISE CASE OF NO EXTRA ENTRIES ON STACK FROM ARBNO ARG ! 8430: * ! 8431: PABC1 ADD *NUM04,XS REMOVE NDABB ENTRY AND CURSOR ! 8432: * ! 8433: * MERGE TO CHECK FOR MATCHING OF NULL STRING ! 8434: * ! 8435: PABC2 BNE WA,WB,SUCCP ALLOW FURTHER ATTEMPT IF NON-NULL ! 8436: MOV PTHEN(XR),XR BYPASS ALTERNATIVE NODE SO AS TO .. ! 8437: BRN SUCCP ... REFUSE FURTHER MATCH ATTEMPTS ! 8438: EJC ! 8439: * ! 8440: * ARBNO (TRY FOR ALTERNATIVES IN ARBNO ARGUMENT) ! 8441: * ! 8442: * NO PARAMETERS (DUMMY PATTERN) ! 8443: * ! 8444: P$ABD ENT ENTRY POINT ! 8445: MOV WB,PMHBS RESTORE INNER STACK BASE PTR ! 8446: BRN FAILP AND FAIL ! 8447: EJC ! 8448: * ! 8449: * ABORT ! 8450: * ! 8451: * NO PARAMETERS ! 8452: * ! 8453: P$ABO ENT BL$P0 P0BLK ! 8454: BRN EXFAL SIGNAL STATEMENT FAILURE ! 8455: EJC ! 8456: * ! 8457: * ALTERNATION ! 8458: * ! 8459: * PARM1 ALTERNATIVE NODE ! 8460: * ! 8461: P$ALT ENT BL$P1 P1BLK ! 8462: MOV WB,-(XS) STACK CURSOR ! 8463: MOV PARM1(XR),-(XS) STACK POINTER TO ALTERNATIVE ! 8464: CHK CHECK FOR STACK OVERFLOW ! 8465: BRN SUCCP IF ALL OK, THEN SUCCEED ! 8466: EJC ! 8467: * ! 8468: * ANY (ONE CHARACTER ARGUMENT) (1-CHAR STRING ALSO) ! 8469: * ! 8470: * PARM1 CHARACTER ARGUMENT ! 8471: * ! 8472: P$ANS ENT BL$P1 P1BLK ! 8473: BEQ WB,PMSSL,FAILP FAIL IF NO CHARS LEFT ! 8474: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING ! 8475: PLC XL,WB POINT TO CURRENT CHARACTER ! 8476: LCH WA,(XL) LOAD CURRENT CHARACTER ! 8477: BNE WA,PARM1(XR),FAILP FAIL IF NO MATCH ! 8478: ICV WB ELSE BUMP CURSOR ! 8479: BRN SUCCP AND SUCCEED ! 8480: EJC ! 8481: * ! 8482: * ANY (MULTI-CHARACTER ARGUMENT CASE) ! 8483: * ! 8484: * PARM1 POINTER TO CTBLK ! 8485: * PARM2 BIT MASK TO SELECT BIT IN CTBLK ! 8486: * ! 8487: P$ANY ENT BL$P2 P2BLK ! 8488: * ! 8489: * EXPRESSION ARGUMENT CASE MERGES HERE ! 8490: * ! 8491: PANY1 BEQ WB,PMSSL,FAILP FAIL IF NO CHARACTERS LEFT ! 8492: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING ! 8493: PLC XL,WB GET CHAR PTR TO CURRENT CHARACTER ! 8494: LCH WA,(XL) LOAD CURRENT CHARACTER ! 8495: MOV PARM1(XR),XL POINT TO CTBLK ! 8496: WTB WA CHANGE TO BYTE OFFSET ! 8497: ADD WA,XL POINT TO ENTRY IN CTBLK ! 8498: MOV CTCHS(XL),WA LOAD WORD FROM CTBLK ! 8499: ANB PARM2(XR),WA AND WITH SELECTED BIT ! 8500: ZRB WA,FAILP FAIL IF NO MATCH ! 8501: ICV WB ELSE BUMP CURSOR ! 8502: BRN SUCCP AND SUCCEED ! 8503: EJC ! 8504: * ! 8505: * ANY (EXPRESSION ARGUMENT) ! 8506: * ! 8507: * PARM1 EXPRESSION POINTER ! 8508: * ! 8509: P$AYD ENT BL$P1 P1BLK ! 8510: JSR EVALS EVALUATE STRING ARGUMENT ! 8511: ERR 043,ANY EVALUATED ARGUMENT IS NOT STRING ! 8512: PPM FAILP FAIL IF EVALUATION FAILURE ! 8513: PPM PANY1 MERGE MULTI-CHAR CASE IF OK ! 8514: EJC ! 8515: * ! 8516: * P$ARB INITIAL ARB MATCH ! 8517: * ! 8518: * NO PARAMETERS ! 8519: * ! 8520: * THE P$ARB NODE IS PART OF A COMPOUND PATTERN STRUCTURE ! 8521: * FOR AN ARB PATTERN (SEE DESCRIPTION OF COMPOUND PATTERNS) ! 8522: * ! 8523: P$ARB ENT BL$P0 P0BLK ! 8524: MOV PTHEN(XR),XR LOAD SUCCESSOR POINTER ! 8525: MOV WB,-(XS) STACK DUMMY CURSOR ! 8526: MOV XR,-(XS) STACK SUCCESSOR POINTER ! 8527: MOV WB,-(XS) STACK CURSOR ! 8528: MOV =NDARC,-(XS) STACK PTR TO SPECIAL NODE NDARC ! 8529: BRI (XR) EXECUTE NEXT NODE MATCHING NULL ! 8530: EJC ! 8531: * ! 8532: * P$ARC EXTEND ARB MATCH ! 8533: * ! 8534: * NO PARAMETERS (DUMMY PATTERN) ! 8535: * ! 8536: P$ARC ENT ENTRY POINT ! 8537: BEQ WB,PMSSL,FLPOP FAIL AND POP STACK TO SUCCESSOR ! 8538: ICV WB ELSE BUMP CURSOR ! 8539: MOV WB,-(XS) STACK UPDATED CURSOR ! 8540: MOV XR,-(XS) RESTACK POINTER TO NDARC NODE ! 8541: MOV 2(XS),XR LOAD SUCCESSOR POINTER ! 8542: BRI (XR) OFF TO REEXECUTE SUCCESSOR NODE ! 8543: EJC ! 8544: * ! 8545: * BAL ! 8546: * ! 8547: * NO PARAMETERS ! 8548: * ! 8549: * THE P$BAL NODE IS PART OF THE COMPOUND STRUCTURE BUILT ! 8550: * FOR BAL (SEE SECTION ON COMPOUND PATTERNS). ! 8551: * ! 8552: P$BAL ENT BL$P0 P0BLK ! 8553: ZER WC ZERO PARENTHESES LEVEL COUNTER ! 8554: MOV R$PMS,XL POINT TO SUBJECT STRING ! 8555: PLC XL,WB POINT TO CURRENT CHARACTER ! 8556: BRN PBAL2 JUMP INTO SCAN LOOP ! 8557: * ! 8558: * LOOP TO SCAN OUT CHARACTERS ! 8559: * ! 8560: PBAL1 LCH WA,(XL)+ LOAD NEXT CHARACTER, BUMP POINTER ! 8561: ICV WB PUSH CURSOR FOR CHARACTER ! 8562: BEQ WA,=CH$PP,PBAL3 JUMP IF LEFT PAREN ! 8563: BEQ WA,=CH$RP,PBAL4 JUMP IF RIGHT PAREN ! 8564: BZE WC,PBAL5 ELSE SUCCEED IF AT OUTER LEVEL ! 8565: * ! 8566: * HERE AFTER PROCESSING ONE CHARACTER ! 8567: * ! 8568: PBAL2 BNE WB,PMSSL,PBAL1 LOOP BACK UNLESS END OF STRING ! 8569: BRN FAILP IN WHICH CASE, FAIL ! 8570: * ! 8571: * HERE ON LEFT PAREN ! 8572: * ! 8573: PBAL3 ICV WC BUMP PAREN LEVEL ! 8574: BRN PBAL2 LOOP BACK TO CHECK END OF STRING ! 8575: * ! 8576: * HERE FOR RIGHT PAREN ! 8577: * ! 8578: PBAL4 BZE WC,FAILP FAIL IF NO MATCHING LEFT PAREN ! 8579: DCV WC ELSE DECREMENT LEVEL COUNTER ! 8580: BNZ WC,PBAL2 LOOP BACK IF NOT AT OUTER LEVEL ! 8581: * ! 8582: * HERE AFTER SUCCESSFULLY SCANNING A BALANCED STRING ! 8583: * ! 8584: PBAL5 MOV WB,-(XS) STACK CURSOR ! 8585: MOV XR,-(XS) STACK PTR TO BAL NODE FOR EXTEND ! 8586: BRN SUCCP AND SUCCEED ! 8587: EJC ! 8588: * ! 8589: * BREAK (EXPRESSION ARGUMENT) ! 8590: * ! 8591: * PARM1 EXPRESSION POINTER ! 8592: * ! 8593: P$BKD ENT BL$P1 P1BLK ! 8594: JSR EVALS EVALUATE STRING EXPRESSION ! 8595: ERR 044,BREAK EVALUATED ARGUMENT IS NOT STRING ! 8596: PPM FAILP FAIL IF EVALUATION FAILS ! 8597: PPM PBRK1 MERGE WITH MULTI-CHAR CASE IF OK ! 8598: EJC ! 8599: * ! 8600: * BREAK (ONE CHARACTER ARGUMENT) ! 8601: * ! 8602: * PARM1 CHARACTER ARGUMENT ! 8603: * ! 8604: P$BKS ENT BL$P1 P1BLK ! 8605: MOV PMSSL,WC GET SUBJECT STRING LENGTH ! 8606: SUB WB,WC GET NUMBER OF CHARACTERS LEFT ! 8607: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT ! 8608: LCT WC,WC SET COUNTER FOR CHARS LEFT ! 8609: MOV R$PMS,XL POINT TO SUBJECT STRING ! 8610: PLC XL,WB POINT TO CURRENT CHARACTER ! 8611: * ! 8612: * LOOP TO SCAN TILL BREAK CHARACTER FOUND ! 8613: * ! 8614: PBKS1 LCH WA,(XL)+ LOAD NEXT CHAR, BUMP POINTER ! 8615: BEQ WA,PARM1(XR),SUCCP SUCCEED IF BREAK CHARACTER FOUND ! 8616: ICV WB ELSE PUSH CURSOR ! 8617: BCT WC,PBKS1 LOOP BACK IF MORE TO GO ! 8618: BRN FAILP FAIL IF END OF STRING, NO BREAK CHR ! 8619: EJC ! 8620: * ! 8621: * BREAK (MULTI-CHARACTER ARGUMENT) ! 8622: * ! 8623: * PARM1 POINTER TO CTBLK ! 8624: * PARM2 BIT MASK TO SELECT BIT COLUMN ! 8625: * ! 8626: P$BRK ENT BL$P2 P2BLK ! 8627: * ! 8628: * EXPRESSION ARGUMENT MERGES HERE ! 8629: * ! 8630: PBRK1 MOV PMSSL,WC LOAD SUBJECT STRING LENGTH ! 8631: SUB WB,WC GET NUMBER OF CHARACTERS LEFT ! 8632: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT ! 8633: LCT WC,WC SET COUNTER FOR CHARACTERS LEFT ! 8634: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING ! 8635: PLC XL,WB POINT TO CURRENT CHARACTER ! 8636: MOV XR,PSAVE SAVE NODE POINTER ! 8637: * ! 8638: * LOOP TO SEARCH FOR BREAK CHARACTER ! 8639: * ! 8640: PBRK2 LCH WA,(XL)+ LOAD NEXT CHAR, BUMP POINTER ! 8641: MOV PARM1(XR),XR LOAD POINTER TO CTBLK ! 8642: WTB WA CONVERT TO BYTE OFFSET ! 8643: ADD WA,XR POINT TO CTBLK ENTRY ! 8644: MOV CTCHS(XR),WA LOAD CTBLK WORD ! 8645: MOV PSAVE,XR RESTORE NODE POINTER ! 8646: ANB PARM2(XR),WA AND WITH SELECTED BIT ! 8647: NZB WA,SUCCP SUCCEED IF BREAK CHARACTER FOUND ! 8648: ICV WB ELSE PUSH CURSOR ! 8649: BCT WC,PBRK2 LOOP BACK UNLESS END OF STRING ! 8650: BRN FAILP FAIL IF END OF STRING, NO BREAK CHR ! 8651: EJC ! 8652: * ! 8653: * BREAKX (EXTENSION) ! 8654: * ! 8655: * THIS IS THE ENTRY WHICH CAUSES AN EXTENSION OF A BREAKX ! 8656: * MATCH WHEN FAILURE OCCURS. SEE SECTION ON COMPOUND ! 8657: * PATTERNS FOR FULL DETAILS OF BREAKX MATCHING. ! 8658: * ! 8659: * NO PARAMETERS ! 8660: * ! 8661: P$BKX ENT BL$P0 P0BLK ! 8662: ICV WB STEP CURSOR PAST PREVIOUS BREAK CHR ! 8663: BRN SUCCP SUCCEED TO REMATCH BREAK ! 8664: EJC ! 8665: * ! 8666: * BREAKX (EXPRESSION ARGUMENT) ! 8667: * ! 8668: * SEE SECTION ON COMPOUND PATTERNS FOR FULL STRUCTURE OF ! 8669: * BREAKX PATTERN. THE ACTUAL CHARACTER MATCHING USES A ! 8670: * BREAK NODE. HOWEVER, THE ENTRY FOR THE EXPRESSION ! 8671: * ARGUMENT CASE IS SEPARATED TO GET PROPER ERROR MESSAGES. ! 8672: * ! 8673: * PARM1 EXPRESSION POINTER ! 8674: * ! 8675: P$BXD ENT BL$P1 P1BLK ! 8676: JSR EVALS EVALUATE STRING ARGUMENT ! 8677: ERR 045,BREAKX EVALUATED ARGUMENT IS NOT STRING ! 8678: PPM FAILP FAIL IF EVALUATION FAILS ! 8679: PPM PBRK1 MERGE WITH BREAK IF ALL OK ! 8680: EJC ! 8681: * ! 8682: * CURSOR ASSIGNMENT ! 8683: * ! 8684: * PARM1 NAME BASE ! 8685: * PARM2 NAME OFFSET ! 8686: * ! 8687: P$CAS ENT BL$P2 P2BLK ! 8688: MOV XR,-(XS) SAVE NODE POINTER ! 8689: MOV WB,-(XS) SAVE CURSOR ! 8690: MOV PARM1(XR),XL LOAD NAME BASE ! 8691: MTI WB LOAD CURSOR AS INTEGER ! 8692: MOV PARM2(XR),WB LOAD NAME OFFSET ! 8693: JSR ICBLD GET ICBLK FOR CURSOR VALUE ! 8694: MOV WB,WA MOVE NAME OFFSET ! 8695: MOV XR,WB MOVE VALUE TO ASSIGN ! 8696: JSR ASINP PERFORM ASSIGNMENT ! 8697: PPM FLPOP FAIL ON ASSIGNMENT FAILURE ! 8698: MOV (XS)+,WB ELSE RESTORE CURSOR ! 8699: MOV (XS)+,XR RESTORE NODE POINTER ! 8700: BRN SUCCP AND SUCCEED MATCHING NULL ! 8701: EJC ! 8702: * ! 8703: * EXPRESSION NODE (P$EXA, INITIAL ENTRY) ! 8704: * ! 8705: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 8706: * ALGORITHMS FOR HANDLING EXPRESSION NODES. ! 8707: * ! 8708: * PARM1 EXPRESSION POINTER ! 8709: * ! 8710: P$EXA ENT BL$P1 P1BLK ! 8711: JSR EVALP EVALUATE EXPRESSION ! 8712: PPM FAILP FAIL IF EVALUATION FAILS ! 8713: BLO WA,=P$AAA,PEXA1 JUMP IF RESULT IS NOT A PATTERN ! 8714: * ! 8715: * HERE IF RESULT OF EXPRESSION IS A PATTERN ! 8716: * ! 8717: MOV WB,-(XS) STACK DUMMY CURSOR ! 8718: MOV XR,-(XS) STACK PTR TO P$EXA NODE ! 8719: MOV PMHBS,-(XS) STACK HISTORY STACK BASE PTR ! 8720: MOV =NDEXB,-(XS) STACK PTR TO SPECIAL NODE NDEXB ! 8721: MOV XS,PMHBS STORE NEW STACK BASE POINTER ! 8722: MOV XL,XR COPY NODE POINTER ! 8723: BRI (XR) MATCH FIRST NODE IN EXPRESSION PAT ! 8724: * ! 8725: * HERE IF RESULT OF EXPRESSION IS NOT A PATTERN ! 8726: * ! 8727: PEXA1 BEQ WA,=B$SCL,PEXA2 JUMP IF IT IS ALREADY A STRING ! 8728: MOV XL,-(XS) ELSE STACK RESULT ! 8729: MOV XR,XL SAVE NODE POINTER ! 8730: JSR GTSTG CONVERT RESULT TO STRING ! 8731: ERR 046,EXPRESSION DOES NOT EVALUATE TO PATTERN ! 8732: MOV XR,WC COPY STRING POINTER ! 8733: MOV XL,XR RESTORE NODE POINTER ! 8734: MOV WC,XL COPY STRING POINTER AGAIN ! 8735: * ! 8736: * MERGE HERE WITH STRING POINTER IN XL ! 8737: * ! 8738: PEXA2 BZE SCLEN(XL),SUCCP JUST SUCCEED IF NULL STRING ! 8739: BRN PSTR1 ELSE MERGE WITH STRING CIRCUIT ! 8740: EJC ! 8741: * ! 8742: * EXPRESSION NODE (P$EXB, REMOVE NDEXB ENTRY) ! 8743: * ! 8744: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 8745: * ALGORITHMS FOR HANDLING EXPRESSION NODES. ! 8746: * ! 8747: * NO PARAMETERS (DUMMY PATTERN) ! 8748: * ! 8749: P$EXB ENT ENTRY POINT ! 8750: MOV WB,PMHBS RESTORE OUTER LEVEL STACK POINTER ! 8751: BRN FLPOP FAIL AND POP P$EXA NODE PTR ! 8752: EJC ! 8753: * ! 8754: * EXPRESSION NODE (P$EXC, REMOVE NDEXC ENTRY) ! 8755: * ! 8756: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 8757: * ALGORITHMS FOR HANDLING EXPRESSION NODES. ! 8758: * ! 8759: * NO PARAMETERS (DUMMY PATTERN) ! 8760: * ! 8761: P$EXC ENT ENTRY POINT ! 8762: MOV WB,PMHBS RESTORE INNER STACK BASE POINTER ! 8763: BRN FAILP AND FAIL INTO EXPR PATTERN ALTERNVS ! 8764: EJC ! 8765: * ! 8766: * FAIL ! 8767: * ! 8768: * NO PARAMETERS ! 8769: * ! 8770: P$FAL ENT BL$P0 P0BLK ! 8771: BRN FAILP JUST SIGNAL FAILURE ! 8772: EJC ! 8773: * ! 8774: * FENCE ! 8775: * ! 8776: * SEE COMPOUND PATTERNS SECTION FOR THE STRUCTURE AND ! 8777: * ALGORITHM FOR MATCHING THIS NODE TYPE. ! 8778: * ! 8779: * NO PARAMETERS ! 8780: * ! 8781: P$FEN ENT BL$P0 P0BLK ! 8782: MOV WB,-(XS) STACK DUMMY CURSOR ! 8783: MOV =NDABO,-(XS) STACK PTR TO ABORT NODE ! 8784: BRN SUCCP AND SUCCEED MATCHING NULL ! 8785: EJC ! 8786: * ! 8787: * FENCE (FUNCTION) ! 8788: * ! 8789: * SEE COMPOUND PATTERNS COMMENTS AT START OF THIS SECTION ! 8790: * FOR DETAILS OF SCHEME ! 8791: * ! 8792: * NO PARAMETERS ! 8793: * ! 8794: P$FNA ENT BL$P0 P0BLK ! 8795: MOV PMHBS,-(XS) STACK CURRENT HISTORY STACK BASE ! 8796: MOV =NDFNB,-(XS) STACK INDIR PTR TO P$FNB (FAILURE) ! 8797: MOV XS,PMHBS BEGIN NEW HISTORY STACK ! 8798: BRN SUCCP SUCCEED ! 8799: EJC ! 8800: * ! 8801: * FENCE (FUNCTION) (RESET HISTORY STACK AND FAIL) ! 8802: * ! 8803: * NO PARAMETERS (DUMMY PATTERN) ! 8804: * ! 8805: P$FNB ENT BL$P0 P0BLK ! 8806: MOV WB,PMHBS RESTORE OUTER PMHBS STACK BASE ! 8807: BRN FAILP ...AND FAIL ! 8808: EJC ! 8809: * ! 8810: * FENCE (FUNCTION) (MAKE FENCE TRAP ENTRY ON STACK) ! 8811: * ! 8812: * NO PARAMETERS (DUMMY PATTERN) ! 8813: * ! 8814: P$FNC ENT BL$P0 P0BLK ! 8815: MOV PMHBS,XT GET INNER STACK BASE PTR ! 8816: MOV NUM01(XT),PMHBS RESTORE OUTER STACK BASE ! 8817: BEQ XT,XS,PFNC1 OPTIMIZE IF NO ALTERNATIVES ! 8818: MOV XT,-(XS) ELSE STACK INNER STACK BASE ! 8819: MOV =NDFND,-(XS) STACK PTR TO NDFND ! 8820: BRN SUCCP SUCCEED ! 8821: * ! 8822: * HERE WHEN FENCE FUNCTION LEFT NOTHING ON THE STACK ! 8823: * ! 8824: PFNC1 ADD *NUM02,XS POP OFF P$FNB ENTRY ! 8825: BRN SUCCP SUCCEED ! 8826: EJC ! 8827: * ! 8828: * FENCE (FUNCTION) (SKIP PAST ALTERNATIVES ON FAILURE) ! 8829: * ! 8830: * NO PARAMETERS (DUMMY PATTERN) ! 8831: * ! 8832: P$FND ENT BL$P0 P0BLK ! 8833: MOV WB,XS POP STACK TO FENCE() HISTORY BASE ! 8834: BRN FLPOP POP BASE ENTRY AND FAIL ! 8835: EJC ! 8836: * ! 8837: * IMMEDIATE ASSIGNMENT (INITIAL ENTRY, SAVE CURRENT CURSOR) ! 8838: * ! 8839: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE ! 8840: * STRUCTURE AND ALGORITHM FOR MATCHING THIS NODE TYPE. ! 8841: * ! 8842: * NO PARAMETERS ! 8843: * ! 8844: P$IMA ENT BL$P0 P0BLK ! 8845: MOV WB,-(XS) STACK CURSOR ! 8846: MOV XR,-(XS) STACK DUMMY NODE POINTER ! 8847: MOV PMHBS,-(XS) STACK OLD STACK BASE POINTER ! 8848: MOV =NDIMB,-(XS) STACK PTR TO SPECIAL NODE NDIMB ! 8849: MOV XS,PMHBS STORE NEW STACK BASE POINTER ! 8850: BRN SUCCP AND SUCCEED ! 8851: EJC ! 8852: * ! 8853: * IMMEDIATE ASSIGNMENT (REMOVE CURSOR MARK ENTRY) ! 8854: * ! 8855: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE ! 8856: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 8857: * ! 8858: * NO PARAMETERS (DUMMY PATTERN) ! 8859: * ! 8860: P$IMB ENT ENTRY POINT ! 8861: MOV WB,PMHBS RESTORE HISTORY STACK BASE PTR ! 8862: BRN FLPOP FAIL AND POP DUMMY NODE PTR ! 8863: EJC ! 8864: * ! 8865: * IMMEDIATE ASSIGNMENT (PERFORM ACTUAL ASSIGNMENT) ! 8866: * ! 8867: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE ! 8868: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 8869: * ! 8870: * PARM1 NAME BASE OF VARIABLE ! 8871: * PARM2 NAME OFFSET OF VARIABLE ! 8872: * ! 8873: P$IMC ENT BL$P2 P2BLK ! 8874: MOV PMHBS,XT LOAD POINTER TO P$IMB ENTRY ! 8875: MOV WB,WA COPY FINAL CURSOR ! 8876: MOV 3(XT),WB LOAD INITIAL CURSOR ! 8877: MOV 1(XT),PMHBS RESTORE OUTER STACK BASE POINTER ! 8878: BEQ XT,XS,PIMC1 JUMP IF NO HISTORY STACK ENTRIES ! 8879: MOV XT,-(XS) ELSE SAVE INNER PMHBS POINTER ! 8880: MOV =NDIMD,-(XS) AND A PTR TO SPECIAL NODE NDIMD ! 8881: BRN PIMC2 MERGE ! 8882: * ! 8883: * HERE IF NO ENTRIES MADE ON HISTORY STACK ! 8884: * ! 8885: PIMC1 ADD *NUM04,XS REMOVE NDIMB ENTRY AND CURSOR ! 8886: * ! 8887: * MERGE HERE TO PERFORM ASSIGNMENT ! 8888: * ! 8889: PIMC2 MOV WA,-(XS) SAVE CURRENT (FINAL) CURSOR ! 8890: MOV XR,-(XS) SAVE CURRENT NODE POINTER ! 8891: MOV R$PMS,XL POINT TO SUBJECT STRING ! 8892: SUB WB,WA COMPUTE SUBSTRING LENGTH ! 8893: JSR SBSTR BUILD SUBSTRING ! 8894: MOV XR,WB MOVE RESULT ! 8895: MOV (XS),XR RELOAD NODE POINTER ! 8896: MOV PARM1(XR),XL LOAD NAME BASE ! 8897: MOV PARM2(XR),WA LOAD NAME OFFSET ! 8898: JSR ASINP PERFORM ASSIGNMENT ! 8899: PPM FLPOP FAIL IF ASSIGNMENT FAILS ! 8900: MOV (XS)+,XR ELSE RESTORE NODE POINTER ! 8901: MOV (XS)+,WB RESTORE CURSOR ! 8902: BRN SUCCP AND SUCCEED ! 8903: EJC ! 8904: * ! 8905: * IMMEDIATE ASSIGNMENT (REMOVE NDIMD ENTRY ON FAILURE) ! 8906: * ! 8907: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE ! 8908: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 8909: * ! 8910: * NO PARAMETERS (DUMMY PATTERN) ! 8911: * ! 8912: P$IMD ENT ENTRY POINT ! 8913: MOV WB,PMHBS RESTORE INNER STACK BASE POINTER ! 8914: BRN FAILP AND FAIL ! 8915: EJC ! 8916: * ! 8917: * LEN (INTEGER ARGUMENT) ! 8918: * ! 8919: * PARM1 INTEGER ARGUMENT ! 8920: * ! 8921: P$LEN ENT BL$P1 P1BLK ! 8922: * ! 8923: * EXPRESSION ARGUMENT CASE MERGES HERE ! 8924: * ! 8925: PLEN1 ADD PARM1(XR),WB PUSH CURSOR INDICATED AMOUNT ! 8926: BLE WB,PMSSL,SUCCP SUCCEED IF NOT OFF END ! 8927: BRN FAILP ELSE FAIL ! 8928: EJC ! 8929: * ! 8930: * LEN (EXPRESSION ARGUMENT) ! 8931: * ! 8932: * PARM1 EXPRESSION POINTER ! 8933: * ! 8934: P$LND ENT BL$P1 P1BLK ! 8935: JSR EVALI EVALUATE INTEGER ARGUMENT ! 8936: ERR 047,LEN EVALUATED ARGUMENT IS NOT INTEGER ! 8937: ERR 048,LEN EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE ! 8938: PPM FAILP FAIL IF EVALUATION FAILS ! 8939: PPM PLEN1 MERGE WITH NORMAL CIRCUIT IF OK ! 8940: EJC ! 8941: * ! 8942: * NOTANY (EXPRESSION ARGUMENT) ! 8943: * ! 8944: * PARM1 EXPRESSION POINTER ! 8945: * ! 8946: P$NAD ENT BL$P1 P1BLK ! 8947: JSR EVALS EVALUATE STRING ARGUMENT ! 8948: ERR 049,NOTANY EVALUATED ARGUMENT IS NOT STRING ! 8949: PPM FAILP FAIL IF EVALUATION FAILS ! 8950: PPM PNAY1 MERGE WITH MULTI-CHAR CASE IF OK ! 8951: EJC ! 8952: * ! 8953: * NOTANY (ONE CHARACTER ARGUMENT) ! 8954: * ! 8955: * PARM1 CHARACTER ARGUMENT ! 8956: * ! 8957: P$NAS ENT BL$P1 ENTRY POINT ! 8958: BEQ WB,PMSSL,FAILP FAIL IF NO CHARS LEFT ! 8959: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING ! 8960: PLC XL,WB POINT TO CURRENT CHARACTER IN STRIN ! 8961: LCH WA,(XL) LOAD CURRENT CHARACTER ! 8962: BEQ WA,PARM1(XR),FAILP FAIL IF MATCH ! 8963: ICV WB ELSE BUMP CURSOR ! 8964: BRN SUCCP AND SUCCEED ! 8965: EJC ! 8966: * ! 8967: * NOTANY (MULTI-CHARACTER STRING ARGUMENT) ! 8968: * ! 8969: * PARM1 POINTER TO CTBLK ! 8970: * PARM2 BIT MASK TO SELECT BIT COLUMN ! 8971: * ! 8972: P$NAY ENT BL$P2 P2BLK ! 8973: * ! 8974: * EXPRESSION ARGUMENT CASE MERGES HERE ! 8975: * ! 8976: PNAY1 BEQ WB,PMSSL,FAILP FAIL IF NO CHARACTERS LEFT ! 8977: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING ! 8978: PLC XL,WB POINT TO CURRENT CHARACTER ! 8979: LCH WA,(XL) LOAD CURRENT CHARACTER ! 8980: WTB WA CONVERT TO BYTE OFFSET ! 8981: MOV PARM1(XR),XL LOAD POINTER TO CTBLK ! 8982: ADD WA,XL POINT TO ENTRY IN CTBLK ! 8983: MOV CTCHS(XL),WA LOAD ENTRY FROM CTBLK ! 8984: ANB PARM2(XR),WA AND WITH SELECTED BIT ! 8985: NZB WA,FAILP FAIL IF CHARACTER IS MATCHED ! 8986: ICV WB ELSE BUMP CURSOR ! 8987: BRN SUCCP AND SUCCEED ! 8988: EJC ! 8989: * ! 8990: * END OF PATTERN MATCH ! 8991: * ! 8992: * THIS ROUTINE IS ENTERED ON SUCCESSFUL COMPLETION. ! 8993: * SEE DESCRIPTION OF EXPRESSION PATTERNS IN COMPOUND ! 8994: * PATTERN SECTION FOR HANDLING OF RECURSION IN MATCHING. ! 8995: * ! 8996: * NO PARAMETERS (DUMMY PATTERN) ! 8997: * ! 8998: P$NTH ENT ENTRY POINT ! 8999: MOV PMHBS,XT LOAD POINTER TO BASE OF STACK ! 9000: MOV 1(XT),WA LOAD SAVED PMHBS (OR PATTERN TYPE) ! 9001: BLE WA,=NUM02,PNTH2 JUMP IF OUTER LEVEL (PATTERN TYPE) ! 9002: * ! 9003: * HERE WE ARE AT THE END OF MATCHING AN EXPRESSION PATTERN ! 9004: * ! 9005: MOV WA,PMHBS RESTORE OUTER STACK BASE POINTER ! 9006: MOV 2(XT),XR RESTORE POINTER TO P$EXA NODE ! 9007: BEQ XT,XS,PNTH1 JUMP IF NO HISTORY STACK ENTRIES ! 9008: MOV XT,-(XS) ELSE STACK INNER STACK BASE PTR ! 9009: MOV =NDEXC,-(XS) STACK PTR TO SPECIAL NODE NDEXC ! 9010: BRN SUCCP AND SUCCEED ! 9011: * ! 9012: * HERE IF NO HISTORY STACK ENTRIES DURING PATTERN ! 9013: * ! 9014: PNTH1 ADD *NUM04,XS REMOVE P$EXB ENTRY AND NODE PTR ! 9015: BRN SUCCP AND SUCCEED ! 9016: * ! 9017: * HERE IF END OF MATCH AT OUTER LEVEL ! 9018: * ! 9019: PNTH2 MOV WB,PMSSL SAVE FINAL CURSOR IN SAFE PLACE ! 9020: BZE PMDFL,PNTH6 JUMP IF NO PATTERN ASSIGNMENTS ! 9021: EJC ! 9022: * ! 9023: * END OF PATTERN MATCH (CONTINUED) ! 9024: * ! 9025: * NOW WE MUST PERFORM PATTERN ASSIGNMENTS. THIS IS DONE BY ! 9026: * SCANNING THE HISTORY STACK FOR MATCHING NDPAB-NDPAD PAIRS ! 9027: * ! 9028: PNTH3 DCA XT POINT PAST CURSOR ENTRY ! 9029: MOV -(XT),WA LOAD NODE POINTER ! 9030: BEQ WA,=NDPAD,PNTH4 JUMP IF NDPAD ENTRY ! 9031: BNE WA,=NDPAB,PNTH5 JUMP IF NOT NDPAB ENTRY ! 9032: * ! 9033: * HERE FOR NDPAB ENTRY, STACK INITIAL CURSOR ! 9034: * NOTE THAT THERE MUST BE MORE ENTRIES ON THE STACK. ! 9035: * ! 9036: MOV 1(XT),-(XS) STACK INITIAL CURSOR ! 9037: CHK CHECK FOR STACK OVERFLOW ! 9038: BRN PNTH3 LOOP BACK IF OK ! 9039: * ! 9040: * HERE FOR NDPAD ENTRY. THE STARTING CURSOR FROM THE ! 9041: * MATCHING NDPAD ENTRY IS NOW THE TOP STACK ENTRY. ! 9042: * ! 9043: PNTH4 MOV 1(XT),WA LOAD FINAL CURSOR ! 9044: MOV (XS),WB LOAD INITIAL CURSOR FROM STACK ! 9045: MOV XT,(XS) SAVE HISTORY STACK SCAN PTR ! 9046: SUB WB,WA COMPUTE LENGTH OF STRING ! 9047: * ! 9048: * BUILD SUBSTRING AND PERFORM ASSIGNMENT ! 9049: * ! 9050: MOV R$PMS,XL POINT TO SUBJECT STRING ! 9051: JSR SBSTR CONSTRUCT SUBSTRING ! 9052: MOV XR,WB COPY SUBSTRING POINTER ! 9053: MOV (XS),XT RELOAD HISTORY STACK SCAN PTR ! 9054: MOV 2(XT),XL LOAD POINTER TO P$PAC NODE WITH NAM ! 9055: MOV PARM2(XL),WA LOAD NAME OFFSET ! 9056: MOV PARM1(XL),XL LOAD NAME BASE ! 9057: JSR ASINP PERFORM ASSIGNMENT ! 9058: PPM EXFAL MATCH FAILS IF NAME EVAL FAILS ! 9059: MOV (XS)+,XT ELSE RESTORE HISTORY STACK PTR ! 9060: EJC ! 9061: * ! 9062: * END OF PATTERN MATCH (CONTINUED) ! 9063: * ! 9064: * HERE CHECK FOR END OF ENTRIES ! 9065: * ! 9066: PNTH5 BNE XT,XS,PNTH3 LOOP IF MORE ENTRIES TO SCAN ! 9067: * ! 9068: * HERE AFTER DEALING WITH PATTERN ASSIGNMENTS ! 9069: * ! 9070: PNTH6 MOV PMHBS,XS WIPE OUT HISTORY STACK ! 9071: MOV (XS)+,WB LOAD INITIAL CURSOR ! 9072: MOV (XS)+,WC LOAD MATCH TYPE CODE ! 9073: MOV PMSSL,WA LOAD FINAL CURSOR VALUE ! 9074: MOV R$PMS,XL POINT TO SUBJECT STRING ! 9075: ZER R$PMS CLEAR SUBJECT STRING PTR FOR GBCOL ! 9076: BZE WC,PNTH7 JUMP IF CALL BY NAME ! 9077: BEQ WC,=NUM02,EXITS EXIT IF STATEMENT LEVEL CALL ! 9078: * ! 9079: * HERE WE HAVE A CALL BY VALUE, BUILD SUBSTRING ! 9080: * ! 9081: SUB WB,WA COMPUTE LENGTH OF STRING ! 9082: JSR SBSTR BUILD SUBSTRING ! 9083: BRN EXIXR AND EXIT WITH SUBSTRING VALUE ! 9084: * ! 9085: * HERE FOR CALL BY NAME, MAKE STACK ENTRIES FOR O$RPL ! 9086: * ! 9087: PNTH7 MOV WB,-(XS) STACK INITIAL CURSOR ! 9088: MOV WA,-(XS) STACK FINAL CURSOR ! 9089: BZE R$PMB,PNTH8 SKIP IF SUBJECT NOT BUFFER ! 9090: MOV R$PMB,XL ELSE GET PTR TO BCBLK INSTEAD ! 9091: * ! 9092: * HERE WITH XL POINTING TO SCBLK OR BCBLK ! 9093: * ! 9094: PNTH8 MOV XL,-(XS) STACK SUBJECT POINTER ! 9095: BRN EXITS EXIT WITH SPECIAL ENTRY ON STACK ! 9096: EJC ! 9097: * ! 9098: * POS (INTEGER ARGUMENT) ! 9099: * ! 9100: * PARM1 INTEGER ARGUMENT ! 9101: * ! 9102: P$POS ENT BL$P1 P1BLK ! 9103: * ! 9104: * EXPRESSION ARGUMENT CASE MERGES HERE ! 9105: * ! 9106: PPOS1 BEQ WB,PARM1(XR),SUCCP SUCCEED IF AT RIGHT LOCATION ! 9107: BRN FAILP ELSE FAIL ! 9108: EJC ! 9109: * ! 9110: * POS (EXPRESSION ARGUMENT) ! 9111: * ! 9112: * PARM1 EXPRESSION POINTER ! 9113: * ! 9114: P$PSD ENT BL$P1 P1BLK ! 9115: JSR EVALI EVALUATE INTEGER ARGUMENT ! 9116: ERR 050,POS EVALUATED ARGUMENT IS NOT INTEGER ! 9117: ERR 051,POS EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE ! 9118: PPM FAILP FAIL IF EVALUATION FAILS ! 9119: PPM PPOS1 MERGE WITH NORMAL CASE IF OK ! 9120: EJC ! 9121: * ! 9122: * PATTERN ASSIGNMENT (INITIAL ENTRY, SAVE CURSOR) ! 9123: * ! 9124: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9125: * ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9126: * ! 9127: * NO PARAMETERS ! 9128: * ! 9129: P$PAA ENT BL$P0 P0BLK ! 9130: MOV WB,-(XS) STACK INITIAL CURSOR ! 9131: MOV =NDPAB,-(XS) STACK PTR TO NDPAB SPECIAL NODE ! 9132: BRN SUCCP AND SUCCEED MATCHING NULL ! 9133: EJC ! 9134: * ! 9135: * PATTERN ASSIGNMENT (REMOVE SAVED CURSOR) ! 9136: * ! 9137: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9138: * ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9139: * ! 9140: * NO PARAMETERS (DUMMY PATTERN) ! 9141: * ! 9142: P$PAB ENT ENTRY POINT ! 9143: BRN FAILP JUST FAIL (ENTRY IS ALREADY POPPED) ! 9144: EJC ! 9145: * ! 9146: * PATTERN ASSIGNMENT (END OF MATCH, MAKE ASSIGN ENTRY) ! 9147: * ! 9148: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9149: * ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9150: * ! 9151: * PARM1 NAME BASE OF VARIABLE ! 9152: * PARM2 NAME OFFSET OF VARIABLE ! 9153: * ! 9154: P$PAC ENT BL$P2 P2BLK ! 9155: MOV WB,-(XS) STACK DUMMY CURSOR VALUE ! 9156: MOV XR,-(XS) STACK POINTER TO P$PAC NODE ! 9157: MOV WB,-(XS) STACK FINAL CURSOR ! 9158: MOV =NDPAD,-(XS) STACK PTR TO SPECIAL NDPAD NODE ! 9159: MNZ PMDFL SET DOT FLAG NON-ZERO ! 9160: BRN SUCCP AND SUCCEED ! 9161: EJC ! 9162: * ! 9163: * PATTERN ASSIGNMENT (REMOVE ASSIGN ENTRY) ! 9164: * ! 9165: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9166: * ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9167: * ! 9168: * NO PARAMETERS (DUMMY NODE) ! 9169: * ! 9170: P$PAD ENT ENTRY POINT ! 9171: BRN FLPOP FAIL AND REMOVE P$PAC NODE ! 9172: EJC ! 9173: * ! 9174: * REM ! 9175: * ! 9176: * NO PARAMETERS ! 9177: * ! 9178: P$REM ENT BL$P0 P0BLK ! 9179: MOV PMSSL,WB POINT CURSOR TO END OF STRING ! 9180: BRN SUCCP AND SUCCEED ! 9181: EJC ! 9182: * ! 9183: * RPOS (EXPRESSION ARGUMENT) ! 9184: * ! 9185: * PARM1 EXPRESSION POINTER ! 9186: * ! 9187: P$RPD ENT BL$P1 P1BLK ! 9188: JSR EVALI EVALUATE INTEGER ARGUMENT ! 9189: ERR 052,RPOS EVALUATED ARGUMENT IS NOT INTEGER ! 9190: ERR 053,RPOS EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE ! 9191: PPM FAILP FAIL IF EVALUATION FAILS ! 9192: PPM PRPS1 MERGE WITH NORMAL CASE IF OK ! 9193: EJC ! 9194: * ! 9195: * RPOS (INTEGER ARGUMENT) ! 9196: * ! 9197: * PARM1 INTEGER ARGUMENT ! 9198: * ! 9199: P$RPS ENT BL$P1 P1BLK ! 9200: * ! 9201: * EXPRESSION ARGUMENT CASE MERGES HERE ! 9202: * ! 9203: PRPS1 MOV PMSSL,WC GET LENGTH OF STRING ! 9204: SUB WB,WC GET NUMBER OF CHARACTERS REMAINING ! 9205: BEQ WC,PARM1(XR),SUCCP SUCCEED IF AT RIGHT LOCATION ! 9206: BRN FAILP ELSE FAIL ! 9207: EJC ! 9208: * ! 9209: * RTAB (INTEGER ARGUMENT) ! 9210: * ! 9211: * PARM1 INTEGER ARGUMENT ! 9212: * ! 9213: P$RTB ENT BL$P1 P1BLK ! 9214: * ! 9215: * EXPRESSION ARGUMENT CASE MERGES HERE ! 9216: * ! 9217: PRTB1 MOV WB,WC SAVE INITIAL CURSOR ! 9218: MOV PMSSL,WB POINT TO END OF STRING ! 9219: BLT WB,PARM1(XR),FAILP FAIL IF STRING NOT LONG ENOUGH ! 9220: SUB PARM1(XR),WB ELSE SET NEW CURSOR ! 9221: BGE WB,WC,SUCCP AND SUCCEED IF NOT TOO FAR ALREADY ! 9222: BRN FAILP IN WHICH CASE, FAIL ! 9223: EJC ! 9224: * ! 9225: * RTAB (EXPRESSION ARGUMENT) ! 9226: * ! 9227: * PARM1 EXPRESSION POINTER ! 9228: * ! 9229: P$RTD ENT BL$P1 P1BLK ! 9230: JSR EVALI EVALUATE INTEGER ARGUMENT ! 9231: ERR 054,RTAB EVALUATED ARGUMENT IS NOT INTEGER ! 9232: ERR 055,RTAB EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE ! 9233: PPM FAILP FAIL IF EVALUATION FAILS ! 9234: PPM PRTB1 MERGE WITH NORMAL CASE IF SUCCESS ! 9235: EJC ! 9236: * ! 9237: * SPAN (EXPRESSION ARGUMENT) ! 9238: * ! 9239: * PARM1 EXPRESSION POINTER ! 9240: * ! 9241: P$SPD ENT BL$P1 P1BLK ! 9242: JSR EVALS EVALUATE STRING ARGUMENT ! 9243: ERR 056,SPAN EVALUATED ARGUMENT IS NOT STRING ! 9244: PPM FAILP FAIL IF EVALUATION FAILS ! 9245: PPM PSPN1 MERGE WITH MULTI-CHAR CASE IF OK ! 9246: EJC ! 9247: * ! 9248: * SPAN (MULTI-CHARACTER ARGUMENT CASE) ! 9249: * ! 9250: * PARM1 POINTER TO CTBLK ! 9251: * PARM2 BIT MASK TO SELECT BIT COLUMN ! 9252: * ! 9253: P$SPN ENT BL$P2 P2BLK ! 9254: * ! 9255: * EXPRESSION ARGUMENT CASE MERGES HERE ! 9256: * ! 9257: PSPN1 MOV PMSSL,WC COPY SUBJECT STRING LENGTH ! 9258: SUB WB,WC CALCULATE NUMBER OF CHARACTERS LEFT ! 9259: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT ! 9260: MOV R$PMS,XL POINT TO SUBJECT STRING ! 9261: PLC XL,WB POINT TO CURRENT CHARACTER ! 9262: MOV WB,PSAVC SAVE INITIAL CURSOR ! 9263: MOV XR,PSAVE SAVE NODE POINTER ! 9264: LCT WC,WC SET COUNTER FOR CHARS LEFT ! 9265: * ! 9266: * LOOP TO SCAN MATCHING CHARACTERS ! 9267: * ! 9268: PSPN2 LCH WA,(XL)+ LOAD NEXT CHARACTER, BUMP POINTER ! 9269: WTB WA CONVERT TO BYTE OFFSET ! 9270: MOV PARM1(XR),XR POINT TO CTBLK ! 9271: ADD WA,XR POINT TO CTBLK ENTRY ! 9272: MOV CTCHS(XR),WA LOAD CTBLK ENTRY ! 9273: MOV PSAVE,XR RESTORE NODE POINTER ! 9274: ANB PARM2(XR),WA AND WITH SELECTED BIT ! 9275: ZRB WA,PSPN3 JUMP IF NO MATCH ! 9276: ICV WB ELSE PUSH CURSOR ! 9277: BCT WC,PSPN2 LOOP BACK UNLESS END OF STRING ! 9278: * ! 9279: * HERE AFTER SCANNING MATCHING CHARACTERS ! 9280: * ! 9281: PSPN3 BNE WB,PSAVC,SUCCP SUCCEED IF CHARS MATCHED ! 9282: BRN FAILP ELSE FAIL IF NULL STRING MATCHED ! 9283: EJC ! 9284: * ! 9285: * SPAN (ONE CHARACTER ARGUMENT) ! 9286: * ! 9287: * PARM1 CHARACTER ARGUMENT ! 9288: * ! 9289: P$SPS ENT BL$P1 P1BLK ! 9290: MOV PMSSL,WC GET SUBJECT STRING LENGTH ! 9291: SUB WB,WC CALCULATE NUMBER OF CHARACTERS LEFT ! 9292: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT ! 9293: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING ! 9294: PLC XL,WB POINT TO CURRENT CHARACTER ! 9295: MOV WB,PSAVC SAVE INITIAL CURSOR ! 9296: LCT WC,WC SET COUNTER FOR CHARACTERS LEFT ! 9297: * ! 9298: * LOOP TO SCAN MATCHING CHARACTERS ! 9299: * ! 9300: PSPS1 LCH WA,(XL)+ LOAD NEXT CHARACTER, BUMP POINTER ! 9301: BNE WA,PARM1(XR),PSPS2 JUMP IF NO MATCH ! 9302: ICV WB ELSE PUSH CURSOR ! 9303: BCT WC,PSPS1 AND LOOP UNLESS END OF STRING ! 9304: * ! 9305: * HERE AFTER SCANNING MATCHING CHARACTERS ! 9306: * ! 9307: PSPS2 BNE WB,PSAVC,SUCCP SUCCEED IF CHARS MATCHED ! 9308: BRN FAILP FAIL IF NULL STRING MATCHED ! 9309: EJC ! 9310: * ! 9311: * MULTI-CHARACTER STRING ! 9312: * ! 9313: * NOTE THAT ONE CHARACTER STRINGS USE THE CIRCUIT FOR ! 9314: * ONE CHARACTER ANY ARGUMENTS (P$AN1). ! 9315: * ! 9316: * PARM1 POINTER TO SCBLK FOR STRING ARG ! 9317: * ! 9318: P$STR ENT BL$P1 P1BLK ! 9319: MOV PARM1(XR),XL GET POINTER TO STRING ! 9320: * ! 9321: * MERGE HERE AFTER EVALUATING EXPRESSION WITH STRING VALUE ! 9322: * ! 9323: PSTR1 MOV XR,PSAVE SAVE NODE POINTER ! 9324: MOV R$PMS,XR LOAD SUBJECT STRING POINTER ! 9325: PLC XR,WB POINT TO CURRENT CHARACTER ! 9326: ADD SCLEN(XL),WB COMPUTE NEW CURSOR POSITION ! 9327: BGT WB,PMSSL,FAILP FAIL IF PAST END OF STRING ! 9328: MOV WB,PSAVC SAVE UPDATED CURSOR ! 9329: MOV SCLEN(XL),WA GET NUMBER OF CHARS TO COMPARE ! 9330: PLC XL POINT TO CHARS OF TEST STRING ! 9331: CMC FAILP,FAILP COMPARE, FAIL IF NOT EQUAL ! 9332: MOV PSAVE,XR IF ALL MATCHED, RESTORE NODE PTR ! 9333: MOV PSAVC,WB RESTORE UPDATED CURSOR ! 9334: BRN SUCCP AND SUCCEED ! 9335: EJC ! 9336: * ! 9337: * SUCCEED ! 9338: * ! 9339: * SEE SECTION ON COMPOUND PATTERNS FOR DETAILS OF THE ! 9340: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE ! 9341: * ! 9342: * NO PARAMETERS ! 9343: * ! 9344: P$SUC ENT BL$P0 P0BLK ! 9345: MOV WB,-(XS) STACK CURSOR ! 9346: MOV XR,-(XS) STACK POINTER TO THIS NODE ! 9347: BRN SUCCP SUCCEED MATCHING NULL ! 9348: EJC ! 9349: * ! 9350: * TAB (INTEGER ARGUMENT) ! 9351: * ! 9352: * PARM1 INTEGER ARGUMENT ! 9353: * ! 9354: P$TAB ENT BL$P1 P1BLK ! 9355: * ! 9356: * EXPRESSION ARGUMENT CASE MERGES HERE ! 9357: * ! 9358: PTAB1 BGT WB,PARM1(XR),FAILP FAIL IF TOO FAR ALREADY ! 9359: MOV PARM1(XR),WB ELSE SET NEW CURSOR POSITION ! 9360: BLE WB,PMSSL,SUCCP SUCCEED IF NOT OFF END ! 9361: BRN FAILP ELSE FAIL ! 9362: EJC ! 9363: * ! 9364: * TAB (EXPRESSION ARGUMENT) ! 9365: * ! 9366: * PARM1 EXPRESSION POINTER ! 9367: * ! 9368: P$TBD ENT BL$P1 P1BLK ! 9369: JSR EVALI EVALUATE INTEGER ARGUMENT ! 9370: ERR 057,TAB EVALUATED ARGUMENT IS NOT INTEGER ! 9371: ERR 058,TAB EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE ! 9372: PPM FAILP FAIL IF EVALUATION FAILS ! 9373: PPM PTAB1 MERGE WITH NORMAL CASE IF OK ! 9374: EJC ! 9375: * ! 9376: * ANCHOR MOVEMENT ! 9377: * ! 9378: * NO PARAMETERS (DUMMY NODE) ! 9379: * ! 9380: P$UNA ENT ENTRY POINT ! 9381: MOV WB,XR COPY INITIAL PATTERN NODE POINTER ! 9382: MOV (XS),WB GET INITIAL CURSOR ! 9383: BEQ WB,PMSSL,EXFAL MATCH FAILS IF AT END OF STRING ! 9384: ICV WB ELSE INCREMENT CURSOR ! 9385: MOV WB,(XS) STORE INCREMENTED CURSOR ! 9386: MOV XR,-(XS) RESTACK INITIAL NODE PTR ! 9387: MOV =NDUNA,-(XS) RESTACK UNANCHORED NODE ! 9388: BRI (XR) REMATCH FIRST NODE ! 9389: EJC ! 9390: * ! 9391: * END OF PATTERN MATCH ROUTINES ! 9392: * ! 9393: * THE FOLLOWING ENTRY POINT MARKS THE END OF THE PATTERN ! 9394: * MATCHING ROUTINES AND ALSO THE END OF THE ENTRY POINTS ! 9395: * REFERENCED FROM THE FIRST WORD OF BLOCKS IN DYNAMIC STORE ! 9396: * ! 9397: P$YYY ENT BL$$I MARK LAST ENTRY IN PATTERN SECTION ! 9398: TTL S P I T B O L -- PREDEFINED SNOBOL4 FUNCTIONS ! 9399: * ! 9400: * THE FOLLOWING SECTION CONTAINS CODING FOR FUNCTIONS ! 9401: * WHICH ARE PREDEFINED AND AVAILABLE AT THE SNOBOL LEVEL. ! 9402: * ! 9403: * THESE ROUTINES RECEIVE CONTROL DIRECTLY FROM THE CODE OR ! 9404: * INDIRECTLY THROUGH THE O$FNC, O$FNS OR CFUNC ROUTINES. ! 9405: * IN BOTH CASES THE CONDITIONS ON ENTRY ARE AS FOLLOWS ! 9406: * ! 9407: * THE ARGUMENTS ARE ON THE STACK. THE NUMBER OF ARGUMENTS ! 9408: * HAS BEEN ADJUSTED TO CORRESPOND TO THE SVBLK SVNAR FIELD. ! 9409: * ! 9410: * IN CERTAIN FUNCTIONS THE DIRECT CALL IS NOT PERMITTED ! 9411: * AND IN THESE INSTANCES WE ALSO HAVE. ! 9412: * ! 9413: * (WA) ACTUAL NUMBER OF ARGUMENTS IN CALL ! 9414: * ! 9415: * CONTROL RETURNS BY PLACING THE FUNCTION RESULT VALUE ON ! 9416: * ON THE STACK AND CONTINUING EXECUTION WITH THE NEXT ! 9417: * WORD FROM THE GENERATED CODE. ! 9418: * ! 9419: * THE NAMES OF THE ENTRY POINTS OF THESE FUNCTIONS ARE OF ! 9420: * THE FORM S$XXX WHERE XXX IS THE THREE LETTER CODE FOR ! 9421: * THE SYSTEM VARIABLE NAME. THE FUNCTIONS ARE IN ORDER ! 9422: * ALPHABETICALLY BY THEIR ENTRY NAMES. ! 9423: EJC ! 9424: * ! 9425: * ANY ! 9426: * ! 9427: S$ANY ENT ENTRY POINT ! 9428: MOV =P$ANS,WB SET PCODE FOR SINGLE CHAR CASE ! 9429: MOV =P$ANY,XL PCODE FOR MULTI-CHAR CASE ! 9430: MOV =P$AYD,WC PCODE FOR EXPRESSION CASE ! 9431: JSR PATST CALL COMMON ROUTINE TO BUILD NODE ! 9432: ERR 059,ANY ARGUMENT IS NOT STRING OR EXPRESSION ! 9433: BRN EXIXR JUMP FOR NEXT CODE WORD ! 9434: EJC ! 9435: * ! 9436: * APPEND ! 9437: * ! 9438: S$APN ENT ENTRY POINT ! 9439: MOV (XS)+,XL GET APPEND ARGUMENT ! 9440: MOV (XS)+,XR GET BCBLK ! 9441: BEQ (XR),=B$BCT,SAPN1 OK IF FIRST ARG IS BCBLK ! 9442: ERB 275,APPEND FIRST ARGUMENT IS NOT BUFFER ! 9443: * ! 9444: * HERE TO DO THE APPEND ! 9445: * ! 9446: SAPN1 JSR APNDB DO THE APPEND ! 9447: ERR 276,APPEND SECOND ARGUMENT IS NOT STRING ! 9448: PPM EXFAL NO ROOM - FAIL ! 9449: BRN EXNUL EXIT WITH NULL RESULT ! 9450: EJC ! 9451: * ! 9452: * APPLY ! 9453: * ! 9454: * APPLY DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT ! 9455: * WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED. ! 9456: * ! 9457: S$APP ENT ENTRY POINT ! 9458: BZE WA,SAPP3 JUMP IF NO ARGUMENTS ! 9459: DCV WA ELSE GET APPLIED FUNC ARG COUNT ! 9460: MOV WA,WB COPY ! 9461: WTB WB CONVERT TO BYTES ! 9462: MOV XS,XT COPY STACK POINTER ! 9463: ADD WB,XT POINT TO FUNCTION ARGUMENT ON STACK ! 9464: MOV (XT),XR LOAD FUNCTION PTR (APPLY 1ST ARG) ! 9465: BZE WA,SAPP2 JUMP IF NO ARGS FOR APPLIED FUNC ! 9466: LCT WB,WA ELSE SET COUNTER FOR LOOP ! 9467: * ! 9468: * LOOP TO MOVE ARGUMENTS UP ON STACK ! 9469: * ! 9470: SAPP1 DCA XT POINT TO NEXT ARGUMENT ! 9471: MOV (XT),1(XT) MOVE ARGUMENT UP ! 9472: BCT WB,SAPP1 LOOP TILL ALL MOVED ! 9473: * ! 9474: * MERGE HERE TO CALL FUNCTION (WA = NUMBER OF ARGUMENTS) ! 9475: * ! 9476: SAPP2 ICA XS ADJUST STACK PTR FOR APPLY 1ST ARG ! 9477: JSR GTNVR GET VARIABLE BLOCK ADDR FOR FUNC ! 9478: PPM SAPP3 JUMP IF NOT NATURAL VARIABLE ! 9479: MOV VRFNC(XR),XL ELSE POINT TO FUNCTION BLOCK ! 9480: BRN CFUNC GO CALL APPLIED FUNCTION ! 9481: * ! 9482: * HERE FOR INVALID FIRST ARGUMENT ! 9483: * ! 9484: SAPP3 ERB 060,APPLY FIRST ARG IS NOT NATURAL VARIABLE NAME ! 9485: EJC ! 9486: * ! 9487: * ARBNO ! 9488: * ! 9489: * ARBNO BUILDS A COMPOUND PATTERN. SEE DESCRIPTION AT ! 9490: * START OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED. ! 9491: * ! 9492: S$ABN ENT ENTRY POINT ! 9493: ZER XR SET PARM1 = 0 FOR THE MOMENT ! 9494: MOV =P$ALT,WB SET PCODE FOR ALTERNATIVE NODE ! 9495: JSR PBILD BUILD ALTERNATIVE NODE ! 9496: MOV XR,XL SAVE PTR TO ALTERNATIVE PATTERN ! 9497: MOV =P$ABC,WB PCODE FOR P$ABC ! 9498: ZER XR P0BLK ! 9499: JSR PBILD BUILD P$ABC NODE ! 9500: MOV XL,PTHEN(XR) PUT ALTERNATIVE NODE AS SUCCESSOR ! 9501: MOV XL,WA REMEMBER ALTERNATIVE NODE POINTER ! 9502: MOV XR,XL COPY P$ABC NODE PTR ! 9503: MOV (XS),XR LOAD ARBNO ARGUMENT ! 9504: MOV WA,(XS) STACK ALTERNATIVE NODE POINTER ! 9505: JSR GTPAT GET ARBNO ARGUMENT AS PATTERN ! 9506: ERR 061,ARBNO ARGUMENT IS NOT PATTERN ! 9507: JSR PCONC CONCAT ARG WITH P$ABC NODE ! 9508: MOV XR,XL REMEMBER PTR TO CONCD PATTERNS ! 9509: MOV =P$ABA,WB PCODE FOR P$ABA ! 9510: ZER XR P0BLK ! 9511: JSR PBILD BUILD P$ABA NODE ! 9512: MOV XL,PTHEN(XR) CONCATENATE NODES ! 9513: MOV (XS),XL RECALL PTR TO ALTERNATIVE NODE ! 9514: MOV XR,PARM1(XL) POINT ALTERNATIVE BACK TO ARGUMENT ! 9515: BRN EXITS JUMP FOR NEXT CODE WORD ! 9516: EJC ! 9517: * ! 9518: * ARG ! 9519: * ! 9520: S$ARG ENT ENTRY POINT ! 9521: JSR GTSMI GET SECOND ARG AS SMALL INTEGER ! 9522: ERR 062,ARG SECOND ARGUMENT IS NOT INTEGER ! 9523: PPM EXFAL FAIL IF OUT OF RANGE OR NEGATIVE ! 9524: MOV XR,WA SAVE ARGUMENT NUMBER ! 9525: MOV (XS)+,XR LOAD FIRST ARGUMENT ! 9526: JSR GTNVR LOCATE VRBLK ! 9527: PPM SARG1 JUMP IF NOT NATURAL VARIABLE ! 9528: MOV VRFNC(XR),XR ELSE LOAD FUNCTION BLOCK POINTER ! 9529: BNE (XR),=B$PFC,SARG1 JUMP IF NOT PROGRAM DEFINED ! 9530: BZE WA,EXFAL FAIL IF ARG NUMBER IS ZERO ! 9531: BGT WA,FARGS(XR),EXFAL FAIL IF ARG NUMBER IS TOO LARGE ! 9532: WTB WA ELSE CONVERT TO BYTE OFFSET ! 9533: ADD WA,XR POINT TO ARGUMENT SELECTED ! 9534: MOV PFAGB(XR),XR LOAD ARGUMENT VRBLK POINTER ! 9535: BRN EXVNM EXIT TO BUILD NMBLK ! 9536: * ! 9537: * HERE IF 1ST ARGUMENT IS BAD ! 9538: * ! 9539: SARG1 ERB 063,ARG FIRST ARGUMENT IS NOT PROGRAM FUNCTION NAME ! 9540: EJC ! 9541: * ! 9542: * ARRAY ! 9543: * ! 9544: S$ARR ENT ENTRY POINT ! 9545: MOV (XS)+,XL LOAD INITIAL ELEMENT VALUE ! 9546: MOV (XS)+,XR LOAD FIRST ARGUMENT ! 9547: JSR GTINT CONVERT FIRST ARG TO INTEGER ! 9548: PPM SAR02 JUMP IF NOT INTEGER ! 9549: * ! 9550: * HERE FOR INTEGER FIRST ARGUMENT, BUILD VCBLK ! 9551: * ! 9552: LDI ICVAL(XR) LOAD INTEGER VALUE ! 9553: ILE SAR10 JUMP IF ZERO OR NEG (BAD DIMENSION) ! 9554: MFI WA,SAR11 ELSE CONVERT TO ONE WORD, TEST OVFL ! 9555: LCT WB,WA COPY ELEMENTS FOR LOOP LATER ON ! 9556: ADD =VCSI$,WA ADD SPACE FOR STANDARD FIELDS ! 9557: WTB WA CONVERT LENGTH TO BYTES ! 9558: BGE WA,MXLEN,SAR11 FAIL IF TOO LARGE ! 9559: JSR ALLOC ALLOCATE SPACE FOR VCBLK ! 9560: MOV =B$VCT,(XR) STORE TYPE WORD ! 9561: MOV WA,VCLEN(XR) SET LENGTH ! 9562: MOV XL,WC COPY DEFAULT VALUE ! 9563: MOV XR,XL COPY VCBLK POINTER ! 9564: ADD *VCVLS,XL POINT TO FIRST ELEMENT VALUE ! 9565: * ! 9566: * LOOP TO SET VECTOR ELEMENTS TO DEFAULT VALUE ! 9567: * ! 9568: SAR01 MOV WC,(XL)+ STORE ONE VALUE ! 9569: BCT WB,SAR01 LOOP TILL ALL STORED ! 9570: BRN EXSID EXIT SETTING IDVAL ! 9571: EJC ! 9572: * ! 9573: * ARRAY (CONTINUED) ! 9574: * ! 9575: * HERE IF FIRST ARGUMENT IS NOT AN INTEGER ! 9576: * ! 9577: SAR02 MOV XR,-(XS) REPLACE ARGUMENT ON STACK ! 9578: JSR XSCNI INITIALIZE SCAN OF FIRST ARGUMENT ! 9579: ERR 064,ARRAY FIRST ARGUMENT IS NOT INTEGER OR STRING ! 9580: PPM EXNUL DUMMY (UNUSED) NULL STRING EXIT ! 9581: MOV R$XSC,-(XS) SAVE PROTOTYPE POINTER ! 9582: MOV XL,-(XS) SAVE DEFAULT VALUE ! 9583: ZER ARCDM ZERO COUNT OF DIMENSIONS ! 9584: ZER ARPTR ZERO OFFSET TO INDICATE PASS ONE ! 9585: LDI INTV1 LOAD INTEGER ONE ! 9586: STI ARNEL INITIALIZE ELEMENT COUNT ! 9587: * ! 9588: * THE FOLLOWING CODE IS EXECUTED TWICE. THE FIRST TIME ! 9589: * (ARPTR EQ 0), IT IS USED TO COUNT THE NUMBER OF ELEMENTS ! 9590: * AND NUMBER OF DIMENSIONS. THE SECOND TIME (ARPTR GT 0) IS ! 9591: * USED TO ACTUALLY FILL IN THE DIM,LBD FIELDS OF THE ARBLK. ! 9592: * ! 9593: SAR03 LDI INTV1 LOAD ONE AS DEFAULT LOW BOUND ! 9594: STI ARSVL SAVE AS LOW BOUND ! 9595: MOV =CH$CL,WC SET DELIMITER ONE = COLON ! 9596: MOV =CH$CM,XL SET DELIMITER TWO = COMMA ! 9597: JSR XSCAN SCAN NEXT BOUND ! 9598: BNE WA,=NUM01,SAR04 JUMP IF NOT COLON ! 9599: * ! 9600: * HERE WE HAVE A COLON ENDING A LOW BOUND ! 9601: * ! 9602: JSR GTINT CONVERT LOW BOUND ! 9603: ERR 065,ARRAY FIRST ARGUMENT LOWER BOUND IS NOT INTEGER ! 9604: LDI ICVAL(XR) LOAD VALUE OF LOW BOUND ! 9605: STI ARSVL STORE LOW BOUND VALUE ! 9606: MOV =CH$CM,WC SET DELIMITER ONE = COMMA ! 9607: MOV WC,XL AND DELIMITER TWO = COMMA ! 9608: JSR XSCAN SCAN HIGH BOUND ! 9609: EJC ! 9610: * ! 9611: * ARRAY (CONTINUED) ! 9612: * ! 9613: * MERGE HERE TO PROCESS UPPER BOUND ! 9614: * ! 9615: SAR04 JSR GTINT CONVERT HIGH BOUND TO INTEGER ! 9616: ERR 066,ARRAY FIRST ARGUMENT UPPER BOUND IS NOT INTEGER ! 9617: LDI ICVAL(XR) GET HIGH BOUND ! 9618: SBI ARSVL SUBTRACT LOWER BOUND ! 9619: IOV SAR10 BAD DIMENSION IF OVERFLOW ! 9620: ILT SAR10 BAD DIMENSION IF NEGATIVE ! 9621: ADI INTV1 ADD 1 TO GET DIMENSION ! 9622: IOV SAR10 BAD DIMENSION IF OVERFLOW ! 9623: MOV ARPTR,XL LOAD OFFSET (ALSO PASS INDICATOR) ! 9624: BZE XL,SAR05 JUMP IF FIRST PASS ! 9625: * ! 9626: * HERE IN SECOND PASS TO STORE LBD AND DIM IN ARBLK ! 9627: * ! 9628: ADD (XS),XL POINT TO CURRENT LOCATION IN ARBLK ! 9629: STI CFP$I(XL) STORE DIMENSION ! 9630: LDI ARSVL LOAD LOW BOUND ! 9631: STI (XL) STORE LOW BOUND ! 9632: ADD *ARDMS,ARPTR BUMP OFFSET TO NEXT BOUNDS ! 9633: BRN SAR06 JUMP TO CHECK FOR END OF BOUNDS ! 9634: * ! 9635: * HERE IN PASS 1 ! 9636: * ! 9637: SAR05 ICV ARCDM BUMP DIMENSION COUNT ! 9638: MLI ARNEL MULTIPLY DIMENSION BY COUNT SO FAR ! 9639: IOV SAR11 TOO LARGE IF OVERFLOW ! 9640: STI ARNEL ELSE STORE UPDATED ELEMENT COUNT ! 9641: * ! 9642: * MERGE HERE AFTER PROCESSING ONE SET OF BOUNDS ! 9643: * ! 9644: SAR06 BNZ WA,SAR03 LOOP BACK UNLESS END OF BOUNDS ! 9645: BNZ ARPTR,SAR09 JUMP IF END OF PASS 2 ! 9646: EJC ! 9647: * ! 9648: * ARRAY (CONTINUED) ! 9649: * ! 9650: * HERE AT END OF PASS ONE, BUILD ARBLK ! 9651: * ! 9652: LDI ARNEL GET NUMBER OF ELEMENTS ! 9653: MFI WB,SAR11 GET AS ADDR INTEGER, TEST OVFLO ! 9654: WTB WB ELSE CONVERT TO LENGTH IN BYTES ! 9655: MOV *ARSI$,WA SET SIZE OF STANDARD FIELDS ! 9656: LCT WC,ARCDM SET DIMENSION COUNT TO CONTROL LOOP ! 9657: * ! 9658: * LOOP TO ALLOW SPACE FOR DIMENSIONS ! 9659: * ! 9660: SAR07 ADD *ARDMS,WA ALLOW SPACE FOR ONE SET OF BOUNDS ! 9661: BCT WC,SAR07 LOOP BACK TILL ALL ACCOUNTED FOR ! 9662: MOV WA,XL SAVE SIZE (=AROFS) ! 9663: * ! 9664: * NOW ALLOCATE SPACE FOR ARBLK ! 9665: * ! 9666: ADD WB,WA ADD SPACE FOR ELEMENTS ! 9667: ICA WA ALLOW FOR ARPRO PROTOTYPE FIELD ! 9668: BGE WA,MXLEN,SAR11 FAIL IF TOO LARGE ! 9669: JSR ALLOC ELSE ALLOCATE ARBLK ! 9670: MOV (XS),WB LOAD DEFAULT VALUE ! 9671: MOV XR,(XS) SAVE ARBLK POINTER ! 9672: MOV WA,WC SAVE LENGTH IN BYTES ! 9673: BTW WA CONVERT LENGTH BACK TO WORDS ! 9674: LCT WA,WA SET COUNTER TO CONTROL LOOP ! 9675: * ! 9676: * LOOP TO CLEAR ENTIRE ARBLK TO DEFAULT VALUE ! 9677: * ! 9678: SAR08 MOV WB,(XR)+ SET ONE WORD ! 9679: BCT WA,SAR08 LOOP TILL ALL SET ! 9680: EJC ! 9681: * ! 9682: * ARRAY (CONTINUED) ! 9683: * ! 9684: * NOW SET INITIAL FIELDS OF ARBLK ! 9685: * ! 9686: MOV (XS)+,XR RELOAD ARBLK POINTER ! 9687: MOV (XS),WB LOAD PROTOTYPE ! 9688: MOV =B$ART,(XR) SET TYPE WORD ! 9689: MOV WC,ARLEN(XR) STORE LENGTH IN BYTES ! 9690: ZER IDVAL(XR) ZERO ID TILL WE GET IT BUILT ! 9691: MOV XL,AROFS(XR) SET PROTOTYPE FIELD PTR ! 9692: MOV ARCDM,ARNDM(XR) SET NUMBER OF DIMENSIONS ! 9693: MOV XR,WC SAVE ARBLK POINTER ! 9694: ADD XL,XR POINT TO PROTOTYPE FIELD ! 9695: MOV WB,(XR) STORE PROTOTYPE PTR IN ARBLK ! 9696: MOV *ARLBD,ARPTR SET OFFSET FOR PASS 2 BOUNDS SCAN ! 9697: MOV WB,R$XSC RESET STRING POINTER FOR XSCAN ! 9698: MOV WC,(XS) STORE ARBLK POINTER ON STACK ! 9699: ZER XSOFS RESET OFFSET PTR TO START OF STRING ! 9700: BRN SAR03 JUMP BACK TO RESCAN BOUNDS ! 9701: * ! 9702: * HERE AFTER FILLING IN BOUNDS INFORMATION (END PASS TWO) ! 9703: * ! 9704: SAR09 MOV (XS)+,XR RELOAD POINTER TO ARBLK ! 9705: BRN EXSID EXIT SETTING IDVAL ! 9706: * ! 9707: * HERE FOR BAD DIMENSION ! 9708: * ! 9709: SAR10 ERB 067,ARRAY DIMENSION IS ZERO,NEGATIVE OR OUT OF RANGE ! 9710: * ! 9711: * HERE IF ARRAY IS TOO LARGE ! 9712: * ! 9713: SAR11 ERB 068,ARRAY SIZE EXCEEDS MAXIMUM PERMITTED ! 9714: EJC ! 9715: * ! 9716: * BUFFER ! 9717: * ! 9718: S$BUF ENT ENTRY POINT ! 9719: MOV (XS)+,XL GET INITIAL VALUE ! 9720: MOV (XS)+,XR GET REQUESTED ALLOCATION ! 9721: JSR GTINT CONVERT TO INTEGER ! 9722: ERR 269,BUFFER FIRST ARGUMENT IS NOT INTEGER ! 9723: LDI ICVAL(XR) GET VALUE ! 9724: ILE SBF01 BRANCH IF NEGATIVE OR ZERO ! 9725: MFI WA,SBF02 MOVE WITH OVERFLOW CHECK ! 9726: JSR ALOBF ALLOCATE THE BUFFER ! 9727: JSR APNDB COPY IT IN ! 9728: ERR 270,BUFFER SECOND ARGUMENT IS NOT STRING OR BUFFER ! 9729: ERR 271,BUFFER INITIAL VALUE TOO BIG FOR ALLOCATION ! 9730: BRN EXSID EXIT SETTING IDVAL ! 9731: * ! 9732: * HERE FOR INVALID ALLOCATION SIZE ! 9733: * ! 9734: SBF01 ERB 272,BUFFER FIRST ARGUMENT IS NOT POSITIVE ! 9735: * ! 9736: * HERE FOR ALLOCATION SIZE INTEGER OVERFLOW ! 9737: * ! 9738: SBF02 ERB 273,BUFFER SIZE IS TOO BIG ! 9739: EJC ! 9740: * ! 9741: * BREAK ! 9742: * ! 9743: S$BRK ENT ENTRY POINT ! 9744: MOV =P$BKS,WB SET PCODE FOR SINGLE CHAR CASE ! 9745: MOV =P$BRK,XL PCODE FOR MULTI-CHAR CASE ! 9746: MOV =P$BKD,WC PCODE FOR EXPRESSION CASE ! 9747: JSR PATST CALL COMMON ROUTINE TO BUILD NODE ! 9748: ERR 069,BREAK ARGUMENT IS NOT STRING OR EXPRESSION ! 9749: BRN EXIXR JUMP FOR NEXT CODE WORD ! 9750: EJC ! 9751: * ! 9752: * BREAKX ! 9753: * ! 9754: * BREAKX IS A COMPOUND PATTERN. SEE DESCRIPTION AT START ! 9755: * OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED. ! 9756: * ! 9757: S$BKX ENT ENTRY POINT ! 9758: MOV =P$BKS,WB PCODE FOR SINGLE CHAR ARGUMENT ! 9759: MOV =P$BRK,XL PCODE FOR MULTI-CHAR ARGUMENT ! 9760: MOV =P$BXD,WC PCODE FOR EXPRESSION CASE ! 9761: JSR PATST CALL COMMON ROUTINE TO BUILD NODE ! 9762: ERR 070,BREAKX ARGUMENT IS NOT STRING OR EXPRESSION ! 9763: * ! 9764: * NOW HOOK BREAKX NODE ON AT FRONT END ! 9765: * ! 9766: MOV XR,-(XS) SAVE PTR TO BREAK NODE ! 9767: MOV =P$BKX,WB SET PCODE FOR BREAKX NODE ! 9768: JSR PBILD BUILD IT ! 9769: MOV (XS),PTHEN(XR) SET BREAK NODE AS SUCCESSOR ! 9770: MOV =P$ALT,WB SET PCODE FOR ALTERNATION NODE ! 9771: JSR PBILD BUILD (PARM1=ALT=BREAKX NODE) ! 9772: MOV XR,WA SAVE PTR TO ALTERNATION NODE ! 9773: MOV (XS),XR POINT TO BREAK NODE ! 9774: MOV WA,PTHEN(XR) SET ALTERNATE NODE AS SUCCESSOR ! 9775: BRN EXITS EXIT WITH RESULT ON STACK ! 9776: EJC ! 9777: * ! 9778: * CHAR ! 9779: * ! 9780: S$CHR ENT ENTRY POINT ! 9781: JSR GTSMI CONVERT ARG TO INTEGER ! 9782: ERR 281,CHAR ARGUMENT NOT INTEGER ! 9783: PPM SCHR1 TOO BIG ERROR EXIT ! 9784: BGE WC,=CFP$A,SCHR1 SEE IF OUT OF RANGE OF HOST SET ! 9785: MOV =NUM01,WA IF NOT SET SCBLK ALLOCATION ! 9786: MOV WC,WB SAVE CHAR CODE ! 9787: JSR ALOCS ALLOCATE 1 BAU SCBLK ! 9788: MOV XR,XL COPY SCBLK POINTER ! 9789: PSC XL GET SET TO STUFF CHAR ! 9790: SCH WB,(XL)+ STUFF IT ! 9791: ZER XL CLEAR SLOP IN XL ! 9792: BRN EXIXR EXIT WITH SCBLK POINTER ! 9793: * ! 9794: * HERE IF CHAR ARGUMENT IS OUT OF RANGE ! 9795: * ! 9796: SCHR1 ERB 282,CHAR ARGUMENT NOT IN RANGE ! 9797: EJC ! 9798: * ! 9799: * CLEAR ! 9800: * ! 9801: S$CLR ENT ENTRY POINT ! 9802: JSR XSCNI INITIALIZE TO SCAN ARGUMENT ! 9803: ERR 071,CLEAR ARGUMENT IS NOT STRING ! 9804: PPM SCLR2 JUMP IF NULL ! 9805: * ! 9806: * LOOP TO SCAN OUT NAMES IN FIRST ARGUMENT. VARIABLES IN ! 9807: * THE LIST ARE FALGGED BY SETTING VRGET OF VRBLK TO ZERO. ! 9808: * ! 9809: SCLR1 MOV =CH$CM,WC SET DELIMITER ONE = COMMA ! 9810: MOV WC,XL DELIMITER TWO = COMMA ! 9811: JSR XSCAN SCAN NEXT VARIABLE NAME ! 9812: JSR GTNVR LOCATE VRBLK ! 9813: ERR 072,CLEAR ARGUMENT HAS NULL VARIABLE NAME ! 9814: ZER VRGET(XR) ELSE FLAG BY ZEROING VRGET FIELD ! 9815: BNZ WA,SCLR1 LOOP BACK IF STOPPED BY COMMA ! 9816: * ! 9817: * HERE AFTER FLAGGING VARIABLES IN ARGUMENT LIST ! 9818: * ! 9819: SCLR2 MOV HSHTB,WB POINT TO START OF HASH TABLE ! 9820: * ! 9821: * LOOP THROUGH SLOTS IN HASH TABLE ! 9822: * ! 9823: SCLR3 BEQ WB,HSHTE,EXNUL EXIT RETURNING NULL IF NONE LEFT ! 9824: MOV WB,XR ELSE COPY SLOT POINTER ! 9825: ICA WB BUMP SLOT POINTER ! 9826: SUB *VRNXT,XR SET OFFSET TO MERGE INTO LOOP ! 9827: * ! 9828: * LOOP THROUGH VRBLKS ON ONE HASH CHAIN ! 9829: * ! 9830: SCLR4 MOV VRNXT(XR),XR POINT TO NEXT VRBLK ON CHAIN ! 9831: BZE XR,SCLR3 JUMP FOR NEXT BUCKET IF CHAIN END ! 9832: BNZ VRGET(XR),SCLR5 JUMP IF NOT FLAGGED ! 9833: EJC ! 9834: * ! 9835: * CLEAR (CONTINUED) ! 9836: * ! 9837: * HERE FOR FLAGGED VARIABLE, DO NOT SET VALUE TO NULL ! 9838: * ! 9839: JSR SETVR FOR FLAGGED VAR, RESTORE VRGET ! 9840: BRN SCLR4 AND LOOP BACK FOR NEXT VRBLK ! 9841: * ! 9842: * HERE TO SET VALUE OF A VARIABLE TO NULL ! 9843: * PRROTECTED VARIABLES (ARB, ETC) ARE EXEMPT ! 9844: * ! 9845: SCLR5 BEQ VRSTO(XR),=B$VRE,SCLR4 CHECK FOR PROTECTED VARIABLE (REG05) ! 9846: MOV XR,XL COPY VRBLK POINTER (REG05) ! 9847: * ! 9848: * LOOP TO LOCATE VALUE AT END OF POSSIBLE TRBLK CHAIN ! 9849: * ! 9850: SCLR6 MOV XL,WA SAVE BLOCK POINTER ! 9851: MOV VRVAL(XL),XL LOAD NEXT VALUE FIELD ! 9852: BEQ (XL),=B$TRT,SCLR6 LOOP BACK IF TRAPPED ! 9853: * ! 9854: * NOW STORE THE NULL VALUE ! 9855: * ! 9856: MOV WA,XL RESTORE BLOCK POINTER ! 9857: MOV =NULLS,VRVAL(XL) STORE NULL CONSTANT VALUE ! 9858: BRN SCLR4 LOOP BACK FOR NEXT VRBLK ! 9859: EJC ! 9860: * ! 9861: * CODE ! 9862: * ! 9863: S$COD ENT ENTRY POINT ! 9864: MOV (XS)+,XR LOAD ARGUMENT ! 9865: JSR GTCOD CONVERT TO CODE ! 9866: PPM EXFAL FAIL IF CONVERSION IS IMPOSSIBLE ! 9867: BRN EXIXR ELSE RETURN CODE AS RESULT ! 9868: EJC ! 9869: * ! 9870: * COLLECT ! 9871: * ! 9872: S$COL ENT ENTRY POINT ! 9873: MOV (XS)+,XR LOAD ARGUMENT ! 9874: JSR GTINT CONVERT TO INTEGER ! 9875: ERR 073,COLLECT ARGUMENT IS NOT INTEGER ! 9876: LDI ICVAL(XR) LOAD COLLECT ARGUMENT ! 9877: STI CLSVI SAVE COLLECT ARGUMENT ! 9878: ZER WB SET NO MOVE UP ! 9879: JSR GBCOL PERFORM GARBAGE COLLECTION ! 9880: MOV DNAME,WA POINT TO END OF MEMORY ! 9881: SUB DNAMP,WA SUBTRACT NEXT LOCATION ! 9882: BTW WA CONVERT BYTES TO WORDS ! 9883: MTI WA CONVERT WORDS AVAILABLE AS INTEGER ! 9884: SBI CLSVI SUBTRACT ARGUMENT ! 9885: IOV EXFAL FAIL IF OVERFLOW ! 9886: ILT EXFAL FAIL IF NOT ENOUGH ! 9887: ADI CLSVI ELSE RECOMPUTE AVAILABLE ! 9888: BRN EXINT AND EXIT WITH INTEGER RESULT ! 9889: EJC ! 9890: * ! 9891: * CONVERT ! 9892: * ! 9893: S$CNV ENT ENTRY POINT ! 9894: JSR GTSTG CONVERT SECOND ARGUMENT TO STRING ! 9895: ERR 074,CONVERT SECOND ARGUMENT IS NOT STRING ! 9896: JSR FLSTG FOLD LOWER CASE TO UPPER CASE ! 9897: MOV (XS),XL LOAD FIRST ARGUMENT ! 9898: BNE (XL),=B$PDT,SCV01 JUMP IF NOT PROGRAM DEFINED ! 9899: * ! 9900: * HERE FOR PROGRAM DEFINED DATATYPE ! 9901: * ! 9902: MOV PDDFP(XL),XL POINT TO DFBLK ! 9903: MOV DFNAM(XL),XL LOAD DATATYPE NAME ! 9904: JSR IDENT COMPARE WITH SECOND ARG ! 9905: PPM EXITS EXIT IF IDENT WITH ARG AS RESULT ! 9906: BRN EXFAL ELSE FAIL ! 9907: * ! 9908: * HERE IF NOT PROGRAM DEFINED DATATYPE ! 9909: * ! 9910: SCV01 MOV XR,-(XS) SAVE STRING ARGUMENT ! 9911: MOV =SVCTB,XL POINT TO TABLE OF NAMES TO COMPARE ! 9912: ZER WB INITIALIZE COUNTER ! 9913: MOV WA,WC SAVE LENGTH OF ARGUMENT STRING ! 9914: * ! 9915: * LOOP THROUGH TABLE ENTRIES ! 9916: * ! 9917: SCV02 MOV (XL)+,XR LOAD NEXT TABLE ENTRY, BUMP POINTER ! 9918: BZE XR,EXFAL FAIL IF ZERO MARKING END OF LIST ! 9919: BNE WC,SCLEN(XR),SCV05 JUMP IF WRONG LENGTH ! 9920: MOV XL,CNVTP ELSE STORE TABLE POINTER ! 9921: PLC XR POINT TO CHARS OF TABLE ENTRY ! 9922: MOV (XS),XL LOAD POINTER TO STRING ARGUMENT ! 9923: PLC XL POINT TO CHARS OF STRING ARG ! 9924: MOV WC,WA SET NUMBER OF CHARS TO COMPARE ! 9925: CMC SCV04,SCV04 COMPARE, JUMP IF NO MATCH ! 9926: EJC ! 9927: * ! 9928: * CONVERT (CONTINUED) ! 9929: * ! 9930: * HERE WE HAVE A MATCH ! 9931: * ! 9932: SCV03 MOV WB,XL COPY ENTRY NUMBER ! 9933: ICA XS POP STRING ARG OFF STACK ! 9934: MOV (XS)+,XR LOAD FIRST ARGUMENT ! 9935: BSW XL,CNVTT JUMP TO APPROPRIATE ROUTINE ! 9936: IFF 0,SCV06 STRING ! 9937: IFF 1,SCV07 INTEGER ! 9938: IFF 2,SCV09 NAME ! 9939: IFF 3,SCV10 PATTERN ! 9940: IFF 4,SCV11 ARRAY ! 9941: IFF 5,SCV19 TABLE ! 9942: IFF 6,SCV25 EXPRESSION ! 9943: IFF 7,SCV26 CODE ! 9944: IFF 8,SCV27 NUMERIC ! 9945: IFF CNVRT,SCV08 REAL ! 9946: IFF CNVBT,SCV28 BUFFER ! 9947: ESW END OF SWITCH TABLE ! 9948: * ! 9949: * HERE IF NO MATCH WITH TABLE ENTRY ! 9950: * ! 9951: SCV04 MOV CNVTP,XL RESTORE TABLE POINTER, MERGE ! 9952: * ! 9953: * MERGE HERE IF LENGTHS DID NOT MATCH ! 9954: * ! 9955: SCV05 ICV WB BUMP ENTRY NUMBER ! 9956: BRN SCV02 LOOP BACK TO CHECK NEXT ENTRY ! 9957: * ! 9958: * HERE TO CONVERT TO STRING ! 9959: * ! 9960: SCV06 MOV XR,-(XS) REPLACE STRING ARGUMENT ON STACK ! 9961: JSR GTSTG CONVERT TO STRING ! 9962: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE ! 9963: BRN EXIXR ELSE RETURN STRING ! 9964: EJC ! 9965: * ! 9966: * CONVERT (CONTINUED) ! 9967: * ! 9968: * HERE TO CONVERT TO INTEGER ! 9969: * ! 9970: SCV07 JSR GTINT CONVERT TO INTEGER ! 9971: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE ! 9972: BRN EXIXR ELSE RETURN INTEGER ! 9973: * ! 9974: * HERE TO CONVERT TO REAL ! 9975: * ! 9976: SCV08 JSR GTREA CONVERT TO REAL ! 9977: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE ! 9978: BRN EXIXR ELSE RETURN REAL ! 9979: * ! 9980: * HERE TO CONVERT TO NAME ! 9981: * ! 9982: SCV09 BEQ (XR),=B$NML,EXIXR RETURN IF ALREADY A NAME ! 9983: JSR GTNVR ELSE TRY STRING TO NAME CONVERT ! 9984: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE ! 9985: BRN EXVNM ELSE EXIT BUILDING NMBLK FOR VRBLK ! 9986: * ! 9987: * HERE TO CONVERT TO PATTERN ! 9988: * ! 9989: SCV10 JSR GTPAT CONVERT TO PATTERN ! 9990: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE ! 9991: BRN EXIXR ELSE RETURN PATTERN ! 9992: * ! 9993: * CONVERT TO ARRAY ! 9994: * ! 9995: SCV11 JSR GTARR GET AN ARRAY ! 9996: PPM EXFAL FAIL IF NOT CONVERTIBLE ! 9997: BRN EXSID EXIT SETTING ID FIELD ! 9998: * ! 9999: * CONVERT TO TABLE ! 10000: * ! 10001: SCV19 MOV (XR),WA LOAD FIRST WORD OF BLOCK ! 10002: MOV XR,-(XS) REPLACE ARBLK POINTER ON STACK ! 10003: BEQ WA,=B$TBT,EXITS RETURN ARG IF ALREADY A TABLE ! 10004: BNE WA,=B$ART,EXFAL ELSE FAIL IF NOT AN ARRAY ! 10005: EJC ! 10006: * ! 10007: * CONVERT (CONTINUED) ! 10008: * ! 10009: * HERE TO CONVERT AN ARRAY TO TABLE ! 10010: * ! 10011: BNE ARNDM(XR),=NUM02,EXFAL FAIL IF NOT 2-DIM ARRAY ! 10012: LDI ARDM2(XR) LOAD DIM 2 ! 10013: SBI INTV2 SUBTRACT 2 TO COMPARE ! 10014: INE EXFAL FAIL IF DIM2 NOT 2 ! 10015: * ! 10016: * HERE WE HAVE AN ARBLK OF THE RIGHT SHAPE ! 10017: * ! 10018: LDI ARDIM(XR) LOAD DIM 1 (NUMBER OF ELEMENTS) ! 10019: MFI WA GET AS ONE WORD INTEGER ! 10020: LCT WB,WA COPY TO CONTROL LOOP ! 10021: ADD =TBSI$,WA ADD SPACE FOR STANDARD FIELDS ! 10022: WTB WA CONVERT LENGTH TO BYTES ! 10023: JSR ALLOC ALLOCATE SPACE FOR TBBLK ! 10024: MOV XR,WC COPY TBBLK POINTER ! 10025: MOV XR,-(XS) SAVE TBBLK POINTER ! 10026: MOV =B$TBT,(XR)+ STORE TYPE WORD ! 10027: ZER (XR)+ STORE ZERO FOR IDVAL FOR NOW ! 10028: MOV WA,(XR)+ STORE LENGTH ! 10029: MOV =NULLS,(XR)+ NULL INITIAL LOOKUP VALUE ! 10030: * ! 10031: * LOOP TO INITIALIZE BUCKET PTRS TO POINT TO TABLE ! 10032: * ! 10033: SCV20 MOV WC,(XR)+ SET BUCKET PTR TO POINT TO TBBLK ! 10034: BCT WB,SCV20 LOOP TILL ALL INITIALIZED ! 10035: MOV *ARVL2,WB SET OFFSET TO FIRST ARBLK ELEMENT ! 10036: * ! 10037: * LOOP TO COPY ELEMENTS FROM ARRAY TO TABLE ! 10038: * ! 10039: SCV21 MOV 1(XS),XL POINT TO ARBLK ! 10040: BEQ WB,ARLEN(XL),SCV24 JUMP IF ALL MOVED ! 10041: ADD WB,XL ELSE POINT TO CURRENT LOCATION ! 10042: ADD *NUM02,WB BUMP OFFSET ! 10043: MOV (XL),XR LOAD SUBSCRIPT NAME ! 10044: DCA XL ADJUST PTR TO MERGE (TRVAL=1+1) ! 10045: EJC ! 10046: * ! 10047: * CONVERT (CONTINUED) ! 10048: * ! 10049: * LOOP TO CHASE DOWN TRBLK CHAIN FOR VALUE ! 10050: * ! 10051: SCV22 MOV TRVAL(XL),XL POINT TO NEXT VALUE ! 10052: BEQ (XL),=B$TRT,SCV22 LOOP BACK IF TRAPPED ! 10053: * ! 10054: * HERE WITH NAME IN XR, VALUE IN XL ! 10055: * ! 10056: SCV23 MOV XL,-(XS) STACK VALUE ! 10057: MOV 1(XS),XL LOAD TBBLK POINTER ! 10058: JSR TFIND BUILD TEBLK (NOTE WB GT 0 BY NAME) ! 10059: PPM EXFAL FAIL IF ACESS FAILS ! 10060: MOV (XS)+,TEVAL(XL) STORE VALUE IN TEBLK ! 10061: BRN SCV21 LOOP BACK FOR NEXT ELEMENT ! 10062: * ! 10063: * HERE AFTER MOVING ALL ELEMENTS TO TBBLK ! 10064: * ! 10065: SCV24 MOV (XS)+,XR LOAD TBBLK POINTER ! 10066: ICA XS POP ARBLK POINTER ! 10067: BRN EXSID EXIT SETTING IDVAL ! 10068: * ! 10069: * CONVERT TO EXPRESSION ! 10070: * ! 10071: SCV25 JSR GTEXP CONVERT TO EXPRESSION ! 10072: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE ! 10073: BRN EXIXR ELSE RETURN EXPRESSION ! 10074: * ! 10075: * CONVERT TO CODE ! 10076: * ! 10077: SCV26 JSR GTCOD CONVERT TO CODE ! 10078: PPM EXFAL FAIL IF CONVERSION IS NOT POSSIBLE ! 10079: BRN EXIXR ELSE RETURN CODE ! 10080: * ! 10081: * CONVERT TO NUMERIC ! 10082: * ! 10083: SCV27 JSR GTNUM CONVERT TO NUMERIC ! 10084: PPM EXFAL FAIL IF UNCONVERTIBLE ! 10085: BRN EXIXR RETURN NUMBER ! 10086: EJC ! 10087: * ! 10088: * CONVERT TO BUFFER ! 10089: * ! 10090: SCV28 MOV XR,-(XS) STACK STRING FOR PROCEDURE ! 10091: JSR GTSTG CONVERT TO STRING ! 10092: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE ! 10093: MOV XR,XL SAVE STRING POINTER ! 10094: JSR ALOBF ALLOCATE BUFFER OF SAME SIZE ! 10095: JSR APNDB COPY IN THE STRING ! 10096: PPM ALREADY STRING - CANT FAIL TO CNV ! 10097: PPM MUST BE ENOUGH ROOM ! 10098: BRN EXSID EXIT SETTING IDVAL FIELD ! 10099: EJC ! 10100: * ! 10101: * COPY ! 10102: * ! 10103: S$COP ENT ENTRY POINT ! 10104: JSR COPYB COPY THE BLOCK ! 10105: PPM EXITS RETURN IF NO IDVAL FIELD ! 10106: BRN EXSID EXIT SETTING ID VALUE ! 10107: EJC ! 10108: * ! 10109: * DATA ! 10110: * ! 10111: S$DAT ENT ENTRY POINT ! 10112: JSR XSCNI PREPARE TO SCAN ARGUMENT ! 10113: ERR 075,DATA ARGUMENT IS NOT STRING ! 10114: ERR 076,DATA ARGUMENT IS NULL ! 10115: * ! 10116: * SCAN OUT DATATYPE NAME ! 10117: * ! 10118: MOV =CH$PP,WC DELIMITER ONE = LEFT PAREN ! 10119: MOV WC,XL DELIMITER TWO = LEFT PAREN ! 10120: JSR XSCAN SCAN DATATYPE NAME ! 10121: BNZ WA,SDAT1 SKIP IF LEFT PAREN FOUND ! 10122: ERB 077,DATA ARGUMENT IS MISSING A LEFT PAREN ! 10123: * ! 10124: * HERE AFTER SCANNING DATATYPE NAME ! 10125: * ! 10126: SDAT1 MOV SCLEN(XR),WA GET LENGTH ! 10127: JSR FLSTG FOLD LOWER CASE TO UPPER CASE ! 10128: MOV XR,XL SAVE NAME PTR ! 10129: MOV SCLEN(XR),WA GET LENGTH ! 10130: CTB WA,SCSI$ COMPUTE SPACE NEEDED ! 10131: JSR ALOST REQUEST STATIC STORE FOR NAME ! 10132: MOV XR,-(XS) SAVE DATATYPE NAME ! 10133: MVW COPY NAME TO STATIC ! 10134: MOV (XS),XR GET NAME PTR ! 10135: ZER XL SCRUB DUD REGISTER ! 10136: JSR GTNVR LOCATE VRBLK FOR DATATYPE NAME ! 10137: ERR 078,DATA ARGUMENT HAS NULL DATATYPE NAME ! 10138: MOV XR,DATDV SAVE VRBLK POINTER FOR DATATYPE ! 10139: MOV XS,DATXS STORE STARTING STACK VALUE ! 10140: ZER WB ZERO COUNT OF FIELD NAMES ! 10141: * ! 10142: * LOOP TO SCAN FIELD NAMES AND STACK VRBLK POINTERS ! 10143: * ! 10144: SDAT2 MOV =CH$RP,WC DELIMITER ONE = RIGHT PAREN ! 10145: MOV =CH$CM,XL DELIMITER TWO = COMMA ! 10146: JSR XSCAN SCAN NEXT FIELD NAME ! 10147: BNZ WA,SDAT3 JUMP IF DELIMITER FOUND ! 10148: ERB 079,DATA ARGUMENT IS MISSING A RIGHT PAREN ! 10149: * ! 10150: * HERE AFTER SCANNING OUT ONE FIELD NAME ! 10151: * ! 10152: SDAT3 JSR GTNVR LOCATE VRBLK FOR FIELD NAME ! 10153: ERR 080,DATA ARGUMENT HAS NULL FIELD NAME ! 10154: MOV XR,-(XS) STACK VRBLK POINTER ! 10155: ICV WB INCREMENT COUNTER ! 10156: BEQ WA,=NUM02,SDAT2 LOOP BACK IF STOPPED BY COMMA ! 10157: EJC ! 10158: * ! 10159: * DATA (CONTINUED) ! 10160: * ! 10161: * NOW BUILD THE DFBLK ! 10162: * ! 10163: MOV =DFSI$,WA SET SIZE OF DFBLK STANDARD FIELDS ! 10164: ADD WB,WA ADD NUMBER OF FIELDS ! 10165: WTB WA CONVERT LENGTH TO BYTES ! 10166: MOV WB,WC PRESERVE NO. OF FIELDS ! 10167: JSR ALOST ALLOCATE SPACE FOR DFBLK ! 10168: MOV WC,WB GET NO OF FIELDS ! 10169: MOV DATXS,XT POINT TO START OF STACK ! 10170: MOV (XT),WC LOAD DATATYPE NAME ! 10171: MOV XR,(XT) SAVE DFBLK POINTER ON STACK ! 10172: MOV =B$DFC,(XR)+ STORE TYPE WORD ! 10173: MOV WB,(XR)+ STORE NUMBER OF FIELDS (FARGS) ! 10174: MOV WA,(XR)+ STORE LENGTH (DFLEN) ! 10175: SUB *PDDFS,WA COMPUTE PDBLK LENGTH (FOR DFPDL) ! 10176: MOV WA,(XR)+ STORE PDBLK LENGTH (DFPDL) ! 10177: MOV WC,(XR)+ STORE DATATYPE NAME (DFNAM) ! 10178: LCT WC,WB COPY NUMBER OF FIELDS ! 10179: * ! 10180: * LOOP TO MOVE FIELD NAME VRBLK POINTERS TO DFBLK ! 10181: * ! 10182: SDAT4 MOV -(XT),(XR)+ MOVE ONE FIELD NAME VRBLK POINTER ! 10183: BCT WC,SDAT4 LOOP TILL ALL MOVED ! 10184: * ! 10185: * NOW DEFINE THE DATATYPE FUNCTION ! 10186: * ! 10187: MOV WA,WC COPY LENGTH OF PDBLK FOR LATER LOOP ! 10188: MOV DATDV,XR POINT TO VRBLK ! 10189: MOV DATXS,XT POINT BACK ON STACK ! 10190: MOV (XT),XL LOAD DFBLK POINTER ! 10191: JSR DFFNC DEFINE FUNCTION ! 10192: EJC ! 10193: * ! 10194: * DATA (CONTINUED) ! 10195: * ! 10196: * LOOP TO BUILD FFBLKS ! 10197: * ! 10198: * ! 10199: * NOTICE THAT THE FFBLKS ARE CONSTRUCTED IN REVERSE ORDER ! 10200: * SO THAT THE REQUIRED OFFSETS CAN BE OBTAINED FROM ! 10201: * SUCCESSIVE DECREMENTATION OF THE PDBLK LENGTH (IN WC). ! 10202: * ! 10203: SDAT5 MOV *FFSI$,WA SET LENGTH OF FFBLK ! 10204: JSR ALLOC ALLOCATE SPACE FOR FFBLK ! 10205: MOV =B$FFC,(XR) SET TYPE WORD ! 10206: MOV =NUM01,FARGS(XR) STORE FARGS (ALWAYS ONE) ! 10207: MOV DATXS,XT POINT BACK ON STACK ! 10208: MOV (XT),FFDFP(XR) COPY DFBLK PTR TO FFBLK ! 10209: DCA WC DECREMENT OLD DFPDL TO GET NEXT OFS ! 10210: MOV WC,FFOFS(XR) SET OFFSET TO THIS FIELD ! 10211: ZER FFNXT(XR) TENTATIVELY SET ZERO FORWARD PTR ! 10212: MOV XR,XL COPY FFBLK POINTER FOR DFFNC ! 10213: MOV (XS),XR LOAD VRBLK POINTER FOR FIELD ! 10214: MOV VRFNC(XR),XR LOAD CURRENT FUNCTION POINTER ! 10215: BNE (XR),=B$FFC,SDAT6 SKIP IF NOT CURRENTLY A FIELD FUNC ! 10216: * ! 10217: * HERE WE MUST CHAIN AN OLD FFBLK PTR TO PRESERVE IT IN THE ! 10218: * CASE OF MULTIPLE FIELD FUNCTIONS WITH THE SAME NAME ! 10219: * ! 10220: MOV XR,FFNXT(XL) LINK NEW FFBLK TO PREVIOUS CHAIN ! 10221: * ! 10222: * MERGE HERE TO DEFINE FIELD FUNCTION ! 10223: * ! 10224: SDAT6 MOV (XS)+,XR LOAD VRBLK POINTER ! 10225: JSR DFFNC DEFINE FIELD FUNCTION ! 10226: BNE XS,DATXS,SDAT5 LOOP BACK TILL ALL DONE ! 10227: ICA XS POP DFBLK POINTER ! 10228: BRN EXNUL RETURN WITH NULL RESULT ! 10229: EJC ! 10230: * ! 10231: * DATATYPE ! 10232: * ! 10233: S$DTP ENT ENTRY POINT ! 10234: MOV (XS)+,XR LOAD ARGUMENT ! 10235: JSR DTYPE GET DATATYPE ! 10236: BRN EXIXR AND RETURN IT AS RESULT ! 10237: EJC ! 10238: * ! 10239: * DATE ! 10240: * ! 10241: S$DTE ENT ENTRY POINT ! 10242: JSR SYSDT CALL SYSTEM DATE ROUTINE ! 10243: MOV 1(XL),WA LOAD LENGTH FOR SBSTR ! 10244: BZE WA,EXNUL RETURN NULL IF LENGTH IS ZERO ! 10245: ZER WB SET ZERO OFFSET ! 10246: JSR SBSTR USE SBSTR TO BUILD SCBLK ! 10247: BRN EXIXR RETURN DATE STRING ! 10248: EJC ! 10249: * ! 10250: * DEFINE ! 10251: * ! 10252: S$DEF ENT ENTRY POINT ! 10253: MOV (XS)+,XR LOAD SECOND ARGUMENT ! 10254: ZER DEFLB ZERO LABEL POINTER IN CASE NULL ! 10255: BEQ XR,=NULLS,SDF01 JUMP IF NULL SECOND ARGUMENT ! 10256: JSR GTNVR ELSE FIND VRBLK FOR LABEL ! 10257: PPM SDF13 JUMP IF NOT A VARIABLE NAME ! 10258: MOV XR,DEFLB ELSE SET SPECIFIED ENTRY ! 10259: * ! 10260: * SCAN FUNCTION NAME ! 10261: * ! 10262: SDF01 JSR XSCNI PREPARE TO SCAN FIRST ARGUMENT ! 10263: ERR 081,DEFINE FIRST ARGUMENT IS NOT STRING ! 10264: ERR 082,DEFINE FIRST ARGUMENT IS NULL ! 10265: MOV =CH$PP,WC DELIMITER ONE = LEFT PAREN ! 10266: MOV WC,XL DELIMITER TWO = LEFT PAREN ! 10267: JSR XSCAN SCAN OUT FUNCTION NAME ! 10268: BNZ WA,SDF02 JUMP IF LEFT PAREN FOUND ! 10269: ERB 083,DEFINE FIRST ARGUMENT IS MISSING A LEFT PAREN ! 10270: * ! 10271: * HERE AFTER SCANNING OUT FUNCTION NAME ! 10272: * ! 10273: SDF02 JSR GTNVR GET VARIABLE NAME ! 10274: ERR 084,DEFINE FIRST ARGUMENT HAS NULL FUNCTION NAME ! 10275: MOV XR,DEFVR SAVE VRBLK POINTER FOR FUNCTION NAM ! 10276: ZER WB ZERO COUNT OF ARGUMENTS ! 10277: MOV XS,DEFXS SAVE INITIAL STACK POINTER ! 10278: BNZ DEFLB,SDF03 JUMP IF SECOND ARGUMENT GIVEN ! 10279: MOV XR,DEFLB ELSE DEFAULT IS FUNCTION NAME ! 10280: * ! 10281: * LOOP TO SCAN ARGUMENT NAMES AND STACK VRBLK POINTERS ! 10282: * ! 10283: SDF03 MOV =CH$RP,WC DELIMITER ONE = RIGHT PAREN ! 10284: MOV =CH$CM,XL DELIMITER TWO = COMMA ! 10285: JSR XSCAN SCAN OUT NEXT ARGUMENT NAME ! 10286: BNZ WA,SDF04 SKIP IF DELIMITER FOUND ! 10287: ERB 085,NULL ARG NAME OR MISSING ) IN DEFINE FIRST ARG. ! 10288: EJC ! 10289: * ! 10290: * DEFINE (CONTINUED) ! 10291: * ! 10292: * HERE AFTER SCANNING AN ARGUMENT NAME ! 10293: * ! 10294: SDF04 BNE XR,=NULLS,SDF05 SKIP IF NON-NULL ! 10295: BZE WB,SDF06 IGNORE NULL IF CASE OF NO ARGUMENTS ! 10296: * ! 10297: * HERE AFTER DEALING WITH THE CASE OF NO ARGUMENTS ! 10298: * ! 10299: SDF05 JSR GTNVR GET VRBLK POINTER ! 10300: PPM SDF03 LOOP BACK TO IGNORE NULL NAME ! 10301: MOV XR,-(XS) STACK ARGUMENT VRBLK POINTER ! 10302: ICV WB INCREMENT COUNTER ! 10303: BEQ WA,=NUM02,SDF03 LOOP BACK IF STOPPED BY A COMMA ! 10304: * ! 10305: * HERE AFTER SCANNING OUT FUNCTION ARGUMENT NAMES ! 10306: * ! 10307: SDF06 MOV WB,DEFNA SAVE NUMBER OF ARGUMENTS ! 10308: ZER WB ZERO COUNT OF LOCALS ! 10309: * ! 10310: * LOOP TO SCAN LOCAL NAMES AND STACK VRBLK POINTERS ! 10311: * ! 10312: SDF07 MOV =CH$CM,WC SET DELIMITER ONE = COMMA ! 10313: MOV WC,XL SET DELIMITER TWO = COMMA ! 10314: JSR XSCAN SCAN OUT NEXT LOCAL NAME ! 10315: BNE XR,=NULLS,SDF08 SKIP IF NON-NULL ! 10316: BZE WB,SDF09 IGNORE NULL IF CASE OF NO LOCALS ! 10317: * ! 10318: * HERE AFTER SCANNING OUT A LOCAL NAME ! 10319: * ! 10320: SDF08 JSR GTNVR GET VRBLK POINTER ! 10321: PPM SDF07 LOOP BACK TO IGNORE NULL NAME ! 10322: ICV WB IF OK, INCREMENT COUNT ! 10323: MOV XR,-(XS) STACK VRBLK POINTER ! 10324: BNZ WA,SDF07 LOOP BACK IF STOPPED BY A COMMA ! 10325: EJC ! 10326: * ! 10327: * DEFINE (CONTINUED) ! 10328: * ! 10329: * HERE AFTER SCANNING LOCALS, BUILD PFBLK ! 10330: * ! 10331: SDF09 MOV WB,WA COPY COUNT OF LOCALS ! 10332: ADD DEFNA,WA ADD NUMBER OF ARGUMENTS ! 10333: MOV WA,WC SET SUM ARGS+LOCALS AS LOOP COUNT ! 10334: ADD =PFSI$,WA ADD SPACE FOR STANDARD FIELDS ! 10335: WTB WA CONVERT LENGTH TO BYTES ! 10336: JSR ALLOC ALLOCATE SPACE FOR PFBLK ! 10337: MOV XR,XL SAVE POINTER TO PFBLK ! 10338: MOV =B$PFC,(XR)+ STORE FIRST WORD ! 10339: MOV DEFNA,(XR)+ STORE NUMBER OF ARGUMENTS ! 10340: MOV WA,(XR)+ STORE LENGTH (PFLEN) ! 10341: MOV DEFVR,(XR)+ STORE VRBLK PTR FOR FUNCTION NAME ! 10342: MOV WB,(XR)+ STORE NUMBER OF LOCALS ! 10343: ZER (XR)+ DEAL WITH LABEL LATER ! 10344: ZER (XR)+ ZERO PFCTR ! 10345: ZER (XR)+ ZERO PFRTR ! 10346: BZE WC,SDF11 SKIP IF NO ARGS OR LOCALS ! 10347: MOV XL,WA KEEP PFBLK POINTER ! 10348: MOV DEFXS,XT POINT BEFORE ARGUMENTS ! 10349: LCT WC,WC GET COUNT OF ARGS+LOCALS FOR LOOP ! 10350: * ! 10351: * LOOP TO MOVE LOCALS AND ARGS TO PFBLK ! 10352: * ! 10353: SDF10 MOV -(XT),(XR)+ STORE ONE ENTRY AND BUMP POINTERS ! 10354: BCT WC,SDF10 LOOP TILL ALL STORED ! 10355: MOV WA,XL RECOVER PFBLK POINTER ! 10356: EJC ! 10357: * ! 10358: * DEFINE (CONTINUED) ! 10359: * ! 10360: * NOW DEAL WITH LABEL ! 10361: * ! 10362: SDF11 MOV DEFXS,XS POP STACK ! 10363: MOV DEFLB,XR POINT TO VRBLK FOR LABEL ! 10364: MOV VRLBL(XR),XR LOAD LABEL POINTER ! 10365: BNE (XR),=B$TRT,SDF12 SKIP IF NOT TRAPPED ! 10366: MOV TRLBL(XR),XR ELSE POINT TO REAL LABEL ! 10367: * ! 10368: * HERE AFTER LOCATING REAL LABEL POINTER ! 10369: * ! 10370: SDF12 BEQ XR,=STNDL,SDF13 JUMP IF LABEL IS NOT DEFINED ! 10371: MOV XR,PFCOD(XL) ELSE STORE LABEL POINTER ! 10372: MOV DEFVR,XR POINT BACK TO VRBLK FOR FUNCTION ! 10373: JSR DFFNC DEFINE FUNCTION ! 10374: BRN EXNUL AND EXIT RETURNING NULL ! 10375: * ! 10376: * HERE FOR ERRONEOUS LABEL ! 10377: * ! 10378: SDF13 ERB 086,DEFINE FUNCTION ENTRY POINT IS NOT DEFINED LABEL ! 10379: EJC ! 10380: * ! 10381: * DETACH ! 10382: * ! 10383: S$DET ENT ENTRY POINT ! 10384: MOV (XS)+,XR LOAD ARGUMENT ! 10385: JSR GTVAR LOCATE VARIABLE ! 10386: ERR 087,DETACH ARGUMENT IS NOT APPROPRIATE NAME ! 10387: JSR DTACH DETACH I/O ASSOCIATION FROM NAME ! 10388: BRN EXNUL RETURN NULL RESULT ! 10389: EJC ! 10390: * ! 10391: * DIFFER ! 10392: * ! 10393: S$DIF ENT ENTRY POINT ! 10394: MOV (XS)+,XR LOAD SECOND ARGUMENT ! 10395: MOV (XS)+,XL LOAD FIRST ARGUMENT ! 10396: JSR IDENT CALL IDENT COMPARISON ROUTINE ! 10397: PPM EXFAL FAIL IF IDENT ! 10398: BRN EXNUL RETURN NULL IF DIFFER ! 10399: EJC ! 10400: * ! 10401: * DUMP ! 10402: * ! 10403: S$DMP ENT ENTRY POINT ! 10404: JSR GTSMI LOAD DUMP ARG AS SMALL INTEGER ! 10405: ERR 088,DUMP ARGUMENT IS NOT INTEGER ! 10406: ERR 089,DUMP ARGUMENT IS NEGATIVE OR TOO LARGE ! 10407: JSR DUMPR ELSE CALL DUMP ROUTINE ! 10408: BRN EXNUL AND RETURN NULL AS RESULT ! 10409: EJC ! 10410: * ! 10411: * DUPL ! 10412: * ! 10413: S$DUP ENT ENTRY POINT ! 10414: JSR GTSMI GET SECOND ARGUMENT AS SMALL INTEGE ! 10415: ERR 090,DUPL SECOND ARGUMENT IS NOT INTEGER ! 10416: PPM SDUP7 JUMP IF NEGATIVE OT TOO BIG ! 10417: MOV XR,WB SAVE DUPLICATION FACTOR ! 10418: JSR GTSTG GET FIRST ARG AS STRING ! 10419: PPM SDUP4 JUMP IF NOT A STRING ! 10420: * ! 10421: * HERE FOR CASE OF DUPLICATION OF A STRING ! 10422: * ! 10423: MTI WA ACQUIRE LENGTH AS INTEGER ! 10424: STI DUPSI SAVE FOR THE MOMENT ! 10425: MTI WB GET DUPLICATION FACTOR AS INTEGER ! 10426: MLI DUPSI FORM PRODUCT ! 10427: IOV SDUP3 JUMP IF OVERFLOW ! 10428: IEQ EXNUL RETURN NULL IF RESULT LENGTH = 0 ! 10429: MFI WA,SDUP3 GET AS ADDR INTEGER, CHECK OVFLO ! 10430: * ! 10431: * MERGE HERE WITH RESULT LENGTH IN WA ! 10432: * ! 10433: SDUP1 MOV XR,XL SAVE STRING POINTER ! 10434: JSR ALOCS ALLOCATE SPACE FOR STRING ! 10435: MOV XR,-(XS) SAVE AS RESULT POINTER ! 10436: MOV XL,WC SAVE POINTER TO ARGUMENT STRING ! 10437: PSC XR PREPARE TO STORE CHARS OF RESULT ! 10438: LCT WB,WB SET COUNTER TO CONTROL LOOP ! 10439: * ! 10440: * LOOP THROUGH DUPLICATIONS ! 10441: * ! 10442: SDUP2 MOV WC,XL POINT BACK TO ARGUMENT STRING ! 10443: MOV SCLEN(XL),WA GET NUMBER OF CHARACTERS ! 10444: PLC XL POINT TO CHARS IN ARGUMENT STRING ! 10445: MVC MOVE CHARACTERS TO RESULT STRING ! 10446: BCT WB,SDUP2 LOOP TILL ALL DUPLICATIONS DONE ! 10447: BRN EXITS THEN EXIT FOR NEXT CODE WORD ! 10448: EJC ! 10449: * ! 10450: * DUPL (CONTINUED) ! 10451: * ! 10452: * HERE IF TOO LARGE, SET MAX LENGTH AND LET ALOCS CATCH IT ! 10453: * ! 10454: SDUP3 MOV DNAME,WA SET IMPOSSIBLE LENGTH FOR ALOCS ! 10455: BRN SDUP1 MERGE BACK ! 10456: * ! 10457: * HERE IF NOT A STRING ! 10458: * ! 10459: SDUP4 JSR GTPAT CONVERT ARGUMENT TO PATTERN ! 10460: ERR 091,DUPL FIRST ARGUMENT IS NOT STRING OR PATTERN ! 10461: * ! 10462: * HERE TO DUPLICATE A PATTERN ARGUMENT ! 10463: * ! 10464: MOV XR,-(XS) STORE PATTERN ON STACK ! 10465: MOV =NDNTH,XR START OFF WITH NULL PATTERN ! 10466: BZE WB,SDUP6 NULL PATTERN IS RESULT IF DUPFAC=0 ! 10467: MOV WB,-(XS) PRESERVE LOOP COUNT ! 10468: * ! 10469: * LOOP TO DUPLICATE BY SUCCESSIVE CONCATENATION ! 10470: * ! 10471: SDUP5 MOV XR,XL COPY CURRENT VALUE AS RIGHT ARGUMNT ! 10472: MOV 1(XS),XR GET A NEW COPY OF LEFT ! 10473: JSR PCONC CONCATENATE ! 10474: DCV (XS) COUNT DOWN ! 10475: BNZ (XS),SDUP5 LOOP ! 10476: ICA XS POP LOOP COUNT ! 10477: * ! 10478: * HERE TO EXIT AFTER CONSTRUCTING PATTERN ! 10479: * ! 10480: SDUP6 MOV XR,(XS) STORE RESULT ON STACK ! 10481: BRN EXITS EXIT WITH RESULT ON STACK ! 10482: * ! 10483: * FAIL IF SECOND ARG IS OUT OF RANGE ! 10484: * ! 10485: SDUP7 ICA XS POP FIRST ARGUMENT ! 10486: BRN EXFAL FAIL ! 10487: EJC ! 10488: * ! 10489: * EJECT ! 10490: * ! 10491: S$EJC ENT ENTRY POINT ! 10492: JSR IOFCB CALL FCBLK ROUTINE ! 10493: ERR 092,EJECT ARGUMENT IS NOT A SUITABLE NAME ! 10494: PPM SEJC1 NULL ARGUMENT ! 10495: JSR SYSEF CALL EJECT FILE FUNCTION ! 10496: ERR 093,EJECT FILE DOES NOT EXIST ! 10497: ERR 094,EJECT FILE DOES NOT PERMIT PAGE EJECT ! 10498: ERR 095,EJECT CAUSED NON-RECOVERABLE OUTPUT ERROR ! 10499: BRN EXNUL RETURN NULL AS RESULT ! 10500: * ! 10501: * HERE TO EJECT STANDARD OUTPUT FILE ! 10502: * ! 10503: SEJC1 JSR SYSEP CALL ROUTINE TO EJECT PRINTER ! 10504: BRN EXNUL EXIT WITH NULL RESULT ! 10505: EJC ! 10506: * ! 10507: * ENDFILE ! 10508: * ! 10509: S$ENF ENT ENTRY POINT ! 10510: JSR IOFCB CALL FCBLK ROUTINE ! 10511: ERR 096,ENDFILE ARGUMENT IS NOT A SUITABLE NAME ! 10512: ERR 097,ENDFILE ARGUMENT IS NULL ! 10513: JSR SYSEN CALL ENDFILE ROUTINE ! 10514: ERR 098,ENDFILE FILE DOES NOT EXIST ! 10515: ERR 099,ENDFILE FILE DOES NOT PERMIT ENDFILE ! 10516: ERR 100,ENDFILE CAUSED NON-RECOVERABLE OUTPUT ERROR ! 10517: MOV XL,WB REMEMBER VRBLK PTR FROM IOFCB CALL ! 10518: * ! 10519: * LOOP TO FIND TRTRF BLOCK ! 10520: * ! 10521: SENF1 MOV XL,XR COPY POINTER ! 10522: MOV TRVAL(XR),XR CHAIN ALONG ! 10523: BNE (XR),=B$TRT,EXNUL SKIP OUT IF CHAIN END ! 10524: BNE TRTYP(XR),=TRTFC,SENF1 LOOP IF NOT FOUND ! 10525: MOV TRVAL(XR),TRVAL(XL) REMOVE TRTRF ! 10526: MOV TRTRF(XR),ENFCH POINT TO HEAD OF IOCHN ! 10527: MOV TRFPT(XR),WC POINT TO FCBLK ! 10528: MOV WB,XR FILEARG1 VRBLK FROM IOFCB ! 10529: JSR SETVR RESET IT ! 10530: MOV =R$FCB,XL PTR TO HEAD OF FCBLK CHAIN ! 10531: SUB *NUM02,XL ADJUST READY TO ENTER LOOP ! 10532: * ! 10533: * FIND FCBLK ! 10534: * ! 10535: SENF2 MOV XL,XR COPY PTR ! 10536: MOV 2(XL),XL GET NEXT LINK ! 10537: BZE XL,SENF4 STOP IF CHAIN END ! 10538: BEQ 3(XL),WC,SENF3 JUMP IF FCBLK FOUND ! 10539: BRN SENF2 LOOP ! 10540: * ! 10541: * REMOVE FCBLK ! 10542: * ! 10543: SENF3 MOV 2(XL),2(XR) DELETE FCBLK FROM CHAIN ! 10544: * ! 10545: * LOOP WHICH DETACHES ALL VBLS ON IOCHN CHAIN ! 10546: * ! 10547: SENF4 MOV ENFCH,XL GET CHAIN HEAD ! 10548: BZE XL,EXNUL FINISHED IF CHAIN END ! 10549: MOV TRTRF(XL),ENFCH CHAIN ALONG ! 10550: MOV IONMO(XL),WA NAME OFFSET ! 10551: MOV IONMB(XL),XL NAME BASE ! 10552: JSR DTACH DETACH NAME ! 10553: BRN SENF4 LOOP TILL DONE ! 10554: EJC ! 10555: * ! 10556: * EQ ! 10557: * ! 10558: S$EQF ENT ENTRY POINT ! 10559: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE ! 10560: ERR 101,EQ FIRST ARGUMENT IS NOT NUMERIC ! 10561: ERR 102,EQ SECOND ARGUMENT IS NOT NUMERIC ! 10562: PPM EXFAL FAIL IF LT ! 10563: PPM EXNUL RETURN NULL IF EQ ! 10564: PPM EXFAL FAIL IF GT ! 10565: EJC ! 10566: * ! 10567: * EVAL ! 10568: * ! 10569: S$EVL ENT ENTRY POINT ! 10570: MOV (XS)+,XR LOAD ARGUMENT ! 10571: JSR GTEXP CONVERT TO EXPRESSION ! 10572: ERR 103,EVAL ARGUMENT IS NOT EXPRESSION ! 10573: LCW WC LOAD NEXT CODE WORD ! 10574: BNE WC,=OFNE$,SEVL1 JUMP IF CALLED BY VALUE ! 10575: SCP XL COPY CODE POINTER ! 10576: MOV (XL),WA GET NEXT CODE WORD ! 10577: BNE WA,=ORNM$,SEVL2 BY NAME UNLESS EXPRESSION ! 10578: BNZ 1(XS),SEVL2 JUMP IF BY NAME ! 10579: * ! 10580: * HERE IF CALLED BY VALUE ! 10581: * ! 10582: SEVL1 ZER WB SET FLAG FOR BY VALUE ! 10583: MOV WC,-(XS) SAVE CODE WORD ! 10584: JSR EVALX EVALUATE EXPRESSION BY VALUE ! 10585: PPM EXFAL FAIL IF EVALUATION FAILS ! 10586: MOV XR,XL COPY RESULT ! 10587: MOV (XS),XR RELOAD NEXT CODE WORD ! 10588: MOV XL,(XS) STACK RESULT ! 10589: BRI (XR) JUMP TO EXECUTE NEXT CODE WORD ! 10590: * ! 10591: * HERE IF CALLED BY NAME ! 10592: * ! 10593: SEVL2 MOV =NUM01,WB SET FLAG FOR BY NAME ! 10594: JSR EVALX EVALUATE EXPRESSION BY NAME ! 10595: PPM EXFAL FAIL IF EVALUATION FAILS ! 10596: BRN EXNAM EXIT WITH NAME ! 10597: EJC ! 10598: * ! 10599: * EXIT ! 10600: * ! 10601: S$EXT ENT ENTRY POINT ! 10602: ZER WB CLEAR AMOUNT OF STATIC SHIFT ! 10603: JSR GBCOL COMPACT MEMORY BY COLLECTING ! 10604: JSR GTSTG CONVERT ARG TO STRING ! 10605: ERR 104,EXIT ARGUMENT IS NOT SUITABLE INTEGER OR STRING ! 10606: MOV XR,XL COPY STRING PTR ! 10607: JSR GTINT CHECK IT IS INTEGER ! 10608: PPM SEXT1 SKIP IF UNCONVERTIBLE ! 10609: ZER XL NOTE IT IS INTEGER ! 10610: LDI ICVAL(XR) GET INTEGER ARG ! 10611: MOV R$FCB,WB GET FCBLK CHAIN HEADER ! 10612: * ! 10613: * MERGE TO CALL OSINT EXIT ROUTINE ! 10614: * ! 10615: SEXT1 MOV =HEADV,XR POINT TO V.V STRING ! 10616: JSR SYSXI CALL EXTERNAL ROUTINE ! 10617: ERR 105,EXIT ACTION NOT AVAILABLE IN THIS IMPLEMENTATION ! 10618: ERR 106,EXIT ACTION CAUSED IRRECOVERABLE ERROR ! 10619: IEQ EXNUL RETURN IF ARGUMENT 0 ! 10620: ZER GBCNT RESUMING EXECUTION SO RESET ! 10621: IGT SEXT2 SKIP IF POSITIVE ! 10622: NGI MAKE POSITIVE ! 10623: * ! 10624: * CHECK FOR OPTION RESPECIFICATION ! 10625: * ! 10626: SEXT2 MFI WC GET VALUE IN WORK REG ! 10627: BEQ WC,=NUM03,SEXT3 SKIP IF WAS 3 ! 10628: MOV WC,-(XS) SAVE VALUE ! 10629: ZER WC SET TO READ OPTIONS ! 10630: JSR PRPAR READ SYSPP OPTIONS ! 10631: MOV (XS)+,WC RESTORE VALUE ! 10632: * ! 10633: * DEAL WITH HEADER OPTION (FIDDLED BY PRPAR) ! 10634: * ! 10635: SEXT3 MNZ HEADP ASSUME NO HEADERS ! 10636: BNE WC,=NUM01,SEXT4 SKIP IF NOT 1 ! 10637: ZER HEADP REQUEST HEADER PRINTING ! 10638: * ! 10639: * ALMOST READY TO RESUME RUNNING ! 10640: * ! 10641: SEXT4 JSR SYSTM GET EXECUTION TIME START (SGD11) ! 10642: STI TIMSX SAVE AS INITIAL TIME ! 10643: LDI KVSTC RESET TO ENSURE ... ! 10644: STI KVSTL ... CORRECT EXECUTION STATS ! 10645: BRN EXNUL RESUME EXECUTION ! 10646: EJC ! 10647: * ! 10648: * FIELD ! 10649: * ! 10650: S$FLD ENT ENTRY POINT ! 10651: JSR GTSMI GET SECOND ARGUMENT (FIELD NUMBER) ! 10652: ERR 107,FIELD SECOND ARGUMENT IS NOT INTEGER ! 10653: PPM EXFAL FAIL IF OUT OF RANGE ! 10654: MOV XR,WB ELSE SAVE INTEGER VALUE ! 10655: MOV (XS)+,XR LOAD FIRST ARGUMENT ! 10656: JSR GTNVR POINT TO VRBLK ! 10657: PPM SFLD1 JUMP (ERROR) IF NOT VARIABLE NAME ! 10658: MOV VRFNC(XR),XR ELSE POINT TO FUNCTION BLOCK ! 10659: BNE (XR),=B$DFC,SFLD1 ERROR IF NOT DATATYPE FUNCTION ! 10660: * ! 10661: * HERE IF FIRST ARGUMENT IS A DATATYPE FUNCTION NAME ! 10662: * ! 10663: BZE WB,EXFAL FAIL IF ARGUMENT NUMBER IS ZERO ! 10664: BGT WB,FARGS(XR),EXFAL FAIL IF TOO LARGE ! 10665: WTB WB ELSE CONVERT TO BYTE OFFSET ! 10666: ADD WB,XR POINT TO FIELD NAME ! 10667: MOV DFFLB(XR),XR LOAD VRBLK POINTER ! 10668: BRN EXVNM EXIT TO BUILD NMBLK ! 10669: * ! 10670: * HERE FOR BAD FIRST ARGUMENT ! 10671: * ! 10672: SFLD1 ERB 108,FIELD FIRST ARGUMENT IS NOT DATATYPE NAME ! 10673: EJC ! 10674: * ! 10675: * FENCE ! 10676: * ! 10677: S$FNC ENT ENTRY POINT ! 10678: MOV =P$FNC,WB SET PCODE FOR P$FNC ! 10679: ZER XR P0BLK ! 10680: JSR PBILD BUILD P$FNC NODE ! 10681: MOV XR,XL SAVE POINTER TO IT ! 10682: MOV (XS)+,XR GET ARGUMENT ! 10683: JSR GTPAT CONVERT TO PATTERN ! 10684: ERR 259,FENCE ARGUMENT IS NOT PATTERN ! 10685: JSR PCONC CONCATENATE TO P$FNC NODE ! 10686: MOV XR,XL SAVE PTR TO CONCATENATED PATTERN ! 10687: MOV =P$FNA,WB SET FOR P$FNA PCODE ! 10688: ZER XR P0BLK ! 10689: JSR PBILD CONSTRUCT P$FNA NODE ! 10690: MOV XL,PTHEN(XR) SET PATTERN AS PTHEN ! 10691: MOV XR,-(XS) SET AS RESULT ! 10692: BRN EXITS DO NEXT CODE WORD ! 10693: EJC ! 10694: * ! 10695: * GE ! 10696: * ! 10697: S$GEF ENT ENTRY POINT ! 10698: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE ! 10699: ERR 109,GE FIRST ARGUMENT IS NOT NUMERIC ! 10700: ERR 110,GE SECOND ARGUMENT IS NOT NUMERIC ! 10701: PPM EXFAL FAIL IF LT ! 10702: PPM EXNUL RETURN NULL IF EQ ! 10703: PPM EXNUL RETURN NULL IF GT ! 10704: EJC ! 10705: * ! 10706: * GT ! 10707: * ! 10708: S$GTF ENT ENTRY POINT ! 10709: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE ! 10710: ERR 111,GT FIRST ARGUMENT IS NOT NUMERIC ! 10711: ERR 112,GT SECOND ARGUMENT IS NOT NUMERIC ! 10712: PPM EXFAL FAIL IF LT ! 10713: PPM EXFAL FAIL IF EQ ! 10714: PPM EXNUL RETURN NULL IF GT ! 10715: EJC ! 10716: * ! 10717: * HOST ! 10718: * ! 10719: S$HST ENT ENTRY POINT ! 10720: MOV (XS)+,XR GET THIRD ARG ! 10721: MOV (XS)+,XL GET SECOND ARG ! 10722: MOV (XS)+,WA GET FIRST ARG ! 10723: JSR SYSHS ENTER SYSHS ROUTINE ! 10724: ERR 254,ERRONEOUS ARGUMENT FOR HOST ! 10725: ERR 255,ERROR DURING EXECUTION OF HOST ! 10726: PPM SHST1 STORE HOST STRING ! 10727: PPM EXNUL RETURN NULL RESULT ! 10728: PPM EXIXR RETURN XR ! 10729: PPM EXFAL FAIL RETURN ! 10730: * ! 10731: * RETURN HOST STRING ! 10732: * ! 10733: SHST1 BZE XL,EXNUL NULL STRING IF SYSHS UNCOOPERATIVE ! 10734: MOV SCLEN(XL),WA LENGTH ! 10735: ZER WB ZERO OFFSET ! 10736: JSR SBSTR BUILD COPY OF STRING ! 10737: MOV XR,-(XS) STACK THE RESULT ! 10738: BRN EXITS RETURN RESULT ON STACK ! 10739: EJC ! 10740: * ! 10741: * IDENT ! 10742: * ! 10743: S$IDN ENT ENTRY POINT ! 10744: MOV (XS)+,XR LOAD SECOND ARGUMENT ! 10745: MOV (XS)+,XL LOAD FIRST ARGUMENT ! 10746: JSR IDENT CALL IDENT COMPARISON ROUTINE ! 10747: PPM EXNUL RETURN NULL IF IDENT ! 10748: BRN EXFAL FAIL IF DIFFER ! 10749: EJC ! 10750: * ! 10751: * INPUT ! 10752: * ! 10753: S$INP ENT ENTRY POINT ! 10754: ZER WB INPUT FLAG ! 10755: JSR IOPUT CALL INPUT/OUTPUT ASSOC. ROUTINE ! 10756: ERR 113,INPUT THIRD ARGUMENT IS NOT A STRING ! 10757: ERR 114,INAPPROPRIATE SECOND ARGUMENT FOR INPUT ! 10758: ERR 115,INAPPROPRIATE FIRST ARGUMENT FOR INPUT ! 10759: ERR 116,INAPPROPRIATE FILE SPECIFICATION FOR INPUT ! 10760: PPM EXFAL FAIL IF FILE DOES NOT EXIST ! 10761: ERR 117,INPUT FILE CANNOT BE READ ! 10762: BRN EXNUL RETURN NULL STRING ! 10763: EJC ! 10764: * ! 10765: * INSERT ! 10766: * ! 10767: S$INS ENT ENTRY POINT ! 10768: MOV (XS)+,XL GET STRING ARG ! 10769: JSR GTSMI GET REPLACE LENGTH ! 10770: ERR 277,INSERT THIRD ARGUMENT NOT INTEGER ! 10771: PPM EXFAL FAIL IF OUT OF RANGE ! 10772: MOV WC,WB COPY TO PROPER REG ! 10773: JSR GTSMI GET REPLACE POSITION ! 10774: ERR 278,INSERT SECOND ARGUMENT NOT INTEGER ! 10775: PPM EXFAL FAIL IF OUT OF RANGE ! 10776: BZE WC,EXFAL FAIL IF ZERO ! 10777: DCV WC DECREMENT TO GET OFFSET ! 10778: MOV WC,WA PUT IN PROPER REGISTER ! 10779: MOV (XS)+,XR GET BUFFER ! 10780: BEQ (XR),=B$BCT,SINS1 PRESS ON IF TYPE OK ! 10781: ERB 279,INSERT FIRST ARGUMENT NOT BUFFER ! 10782: * ! 10783: * HERE WHEN EVERYTHING LOADED UP ! 10784: * ! 10785: SINS1 JSR INSBF CALL TO INSERT ! 10786: ERR 280,INSERT FOURTH ARGUMENT NOT A STRING ! 10787: PPM EXFAL FAIL IF OUT OF RANGE ! 10788: BRN EXNUL ELSE OK - EXIT WITH NULL ! 10789: EJC ! 10790: * ! 10791: * INTEGER ! 10792: * ! 10793: S$INT ENT ENTRY POINT ! 10794: MOV (XS)+,XR LOAD ARGUMENT ! 10795: JSR GTNUM CONVERT TO NUMERIC ! 10796: PPM EXFAL FAIL IF NON-NUMERIC ! 10797: BEQ WA,=B$ICL,EXNUL RETURN NULL IF INTEGER ! 10798: BRN EXFAL FAIL IF REAL ! 10799: EJC ! 10800: * ! 10801: * ITEM ! 10802: * ! 10803: * ITEM DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT ! 10804: * WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED. ! 10805: * ! 10806: S$ITM ENT ENTRY POINT ! 10807: * ! 10808: * DEAL WITH CASE OF NO ARGS ! 10809: * ! 10810: BNZ WA,SITM1 JUMP IF AT LEAST ONE ARG ! 10811: MOV =NULLS,-(XS) ELSE SUPPLY GARBAGE NULL ARG ! 10812: MOV =NUM01,WA AND FIX ARGUMENT COUNT ! 10813: * ! 10814: * CHECK FOR NAME/VALUE CASES ! 10815: * ! 10816: SITM1 SCP XR GET CURRENT CODE POINTER ! 10817: MOV (XR),XL LOAD NEXT CODE WORD ! 10818: DCV WA GET NUMBER OF SUBSCRIPTS ! 10819: MOV WA,XR COPY FOR ARREF ! 10820: BEQ XL,=OFNE$,SITM2 JUMP IF CALLED BY NAME ! 10821: * ! 10822: * HERE IF CALLED BY VALUE ! 10823: * ! 10824: ZER WB SET CODE FOR CALL BY VALUE ! 10825: BRN ARREF OFF TO ARRAY REFERENCE ROUTINE ! 10826: * ! 10827: * HERE FOR CALL BY NAME ! 10828: * ! 10829: SITM2 MNZ WB SET CODE FOR CALL BY NAME ! 10830: LCW WA LOAD AND IGNORE OFNE$ CALL ! 10831: BRN ARREF OFF TO ARRAY REFERENCE ROUTINE ! 10832: EJC ! 10833: * ! 10834: * LE ! 10835: * ! 10836: S$LEF ENT ENTRY POINT ! 10837: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE ! 10838: ERR 118,LE FIRST ARGUMENT IS NOT NUMERIC ! 10839: ERR 119,LE SECOND ARGUMENT IS NOT NUMERIC ! 10840: PPM EXNUL RETURN NULL IF LT ! 10841: PPM EXNUL RETURN NULL IF EQ ! 10842: PPM EXFAL FAIL IF GT ! 10843: EJC ! 10844: * ! 10845: * LEN ! 10846: * ! 10847: S$LEN ENT ENTRY POINT ! 10848: MOV =P$LEN,WB SET PCODE FOR INTEGER ARG CASE ! 10849: MOV =P$LND,WA SET PCODE FOR EXPR ARG CASE ! 10850: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE ! 10851: ERR 120,LEN ARGUMENT IS NOT INTEGER OR EXPRESSION ! 10852: ERR 121,LEN ARGUMENT IS NEGATIVE OR TOO LARGE ! 10853: BRN EXIXR RETURN PATTERN NODE ! 10854: EJC ! 10855: * ! 10856: * LEQ ! 10857: * ! 10858: S$LEQ ENT ENTRY POINT ! 10859: JSR LCOMP CALL STRING COMPARISON ROUTINE ! 10860: ERR 122,LEQ FIRST ARGUMENT IS NOT STRING ! 10861: ERR 123,LEQ SECOND ARGUMENT IS NOT STRING ! 10862: PPM EXFAL FAIL IF LLT ! 10863: PPM EXNUL RETURN NULL IF LEQ ! 10864: PPM EXFAL FAIL IF LGT ! 10865: EJC ! 10866: * ! 10867: * LGE ! 10868: * ! 10869: S$LGE ENT ENTRY POINT ! 10870: JSR LCOMP CALL STRING COMPARISON ROUTINE ! 10871: ERR 124,LGE FIRST ARGUMENT IS NOT STRING ! 10872: ERR 125,LGE SECOND ARGUMENT IS NOT STRING ! 10873: PPM EXFAL FAIL IF LLT ! 10874: PPM EXNUL RETURN NULL IF LEQ ! 10875: PPM EXNUL RETURN NULL IF LGT ! 10876: EJC ! 10877: * ! 10878: * LGT ! 10879: * ! 10880: S$LGT ENT ENTRY POINT ! 10881: JSR LCOMP CALL STRING COMPARISON ROUTINE ! 10882: ERR 126,LGT FIRST ARGUMENT IS NOT STRING ! 10883: ERR 127,LGT SECOND ARGUMENT IS NOT STRING ! 10884: PPM EXFAL FAIL IF LLT ! 10885: PPM EXFAL FAIL IF LEQ ! 10886: PPM EXNUL RETURN NULL IF LGT ! 10887: EJC ! 10888: * ! 10889: * LLE ! 10890: * ! 10891: S$LLE ENT ENTRY POINT ! 10892: JSR LCOMP CALL STRING COMPARISON ROUTINE ! 10893: ERR 128,LLE FIRST ARGUMENT IS NOT STRING ! 10894: ERR 129,LLE SECOND ARGUMENT IS NOT STRING ! 10895: PPM EXNUL RETURN NULL IF LLT ! 10896: PPM EXNUL RETURN NULL IF LEQ ! 10897: PPM EXFAL FAIL IF LGT ! 10898: EJC ! 10899: * ! 10900: * LLT ! 10901: * ! 10902: S$LLT ENT ENTRY POINT ! 10903: JSR LCOMP CALL STRING COMPARISON ROUTINE ! 10904: ERR 130,LLT FIRST ARGUMENT IS NOT STRING ! 10905: ERR 131,LLT SECOND ARGUMENT IS NOT STRING ! 10906: PPM EXNUL RETURN NULL IF LLT ! 10907: PPM EXFAL FAIL IF LEQ ! 10908: PPM EXFAL FAIL IF LGT ! 10909: EJC ! 10910: * ! 10911: * LNE ! 10912: * ! 10913: S$LNE ENT ENTRY POINT ! 10914: JSR LCOMP CALL STRING COMPARISON ROUTINE ! 10915: ERR 132,LNE FIRST ARGUMENT IS NOT STRING ! 10916: ERR 133,LNE SECOND ARGUMENT IS NOT STRING ! 10917: PPM EXNUL RETURN NULL IF LLT ! 10918: PPM EXFAL FAIL IF LEQ ! 10919: PPM EXNUL RETURN NULL IF LGT ! 10920: EJC ! 10921: * ! 10922: * LOCAL ! 10923: * ! 10924: S$LOC ENT ENTRY POINT ! 10925: JSR GTSMI GET SECOND ARGUMENT (LOCAL NUMBER) ! 10926: ERR 134,LOCAL SECOND ARGUMENT IS NOT INTEGER ! 10927: PPM EXFAL FAIL IF OUT OF RANGE ! 10928: MOV XR,WB SAVE LOCAL NUMBER ! 10929: MOV (XS)+,XR LOAD FIRST ARGUMENT ! 10930: JSR GTNVR POINT TO VRBLK ! 10931: PPM SLOC1 JUMP IF NOT VARIABLE NAME ! 10932: MOV VRFNC(XR),XR ELSE LOAD FUNCTION POINTER ! 10933: BNE (XR),=B$PFC,SLOC1 JUMP IF NOT PROGRAM DEFINED ! 10934: * ! 10935: * HERE IF WE HAVE A PROGRAM DEFINED FUNCTION NAME ! 10936: * ! 10937: BZE WB,EXFAL FAIL IF SECOND ARG IS ZERO ! 10938: BGT WB,PFNLO(XR),EXFAL OR TOO LARGE ! 10939: ADD FARGS(XR),WB ELSE ADJUST OFFSET TO INCLUDE ARGS ! 10940: WTB WB CONVERT TO BYTES ! 10941: ADD WB,XR POINT TO LOCAL POINTER ! 10942: MOV PFAGB(XR),XR LOAD VRBLK POINTER ! 10943: BRN EXVNM EXIT BUILDING NMBLK ! 10944: * ! 10945: * HERE IF FIRST ARGUMENT IS NO GOOD ! 10946: * ! 10947: SLOC1 ERB 135,LOCAL FIRST ARG IS NOT A PROGRAM FUNCTION NAME ! 10948: EJC ! 10949: * ! 10950: * LOAD ! 10951: * ! 10952: S$LOD ENT ENTRY POINT ! 10953: JSR GTSTG LOAD LIBRARY NAME ! 10954: ERR 136,LOAD SECOND ARGUMENT IS NOT STRING ! 10955: MOV XR,XL SAVE LIBRARY NAME ! 10956: JSR XSCNI PREPARE TO SCAN FIRST ARGUMENT ! 10957: ERR 137,LOAD FIRST ARGUMENT IS NOT STRING ! 10958: ERR 138,LOAD FIRST ARGUMENT IS NULL ! 10959: MOV XL,-(XS) STACK LIBRARY NAME ! 10960: MOV =CH$PP,WC SET DELIMITER ONE = LEFT PAREN ! 10961: MOV WC,XL SET DELIMITER TWO = LEFT PAREN ! 10962: JSR XSCAN SCAN FUNCTION NAME ! 10963: MOV XR,-(XS) SAVE PTR TO FUNCTION NAME ! 10964: BNZ WA,SLOD1 JUMP IF LEFT PAREN FOUND ! 10965: ERB 139,LOAD FIRST ARGUMENT IS MISSING A LEFT PAREN ! 10966: * ! 10967: * HERE AFTER SUCCESSFULLY SCANNING FUNCTION NAME ! 10968: * ! 10969: SLOD1 JSR GTNVR LOCATE VRBLK ! 10970: ERR 140,LOAD FIRST ARGUMENT HAS NULL FUNCTION NAME ! 10971: MOV XR,LODFN SAVE VRBLK POINTER ! 10972: ZER LODNA ZERO COUNT OF ARGUMENTS ! 10973: * ! 10974: * LOOP TO SCAN ARGUMENT DATATYPE NAMES ! 10975: * ! 10976: SLOD2 MOV =CH$RP,WC DELIMITER ONE IS RIGHT PAREN ! 10977: MOV =CH$CM,XL DELIMITER TWO IS COMMA ! 10978: JSR XSCAN SCAN NEXT ARGUMENT NAME ! 10979: ICV LODNA BUMP ARGUMENT COUNT ! 10980: BNZ WA,SLOD3 JUMP IF OK DELIMITER WAS FOUND ! 10981: ERB 141,LOAD FIRST ARGUMENT IS MISSING A RIGHT PAREN ! 10982: EJC ! 10983: * ! 10984: * LOAD (CONTINUED) ! 10985: * ! 10986: * COME HERE TO ANALYZE THE DATATYPE POINTER IN (XR). THIS ! 10987: * CODE IS USED BOTH FOR ARGUMENTS (WA=1,2) AND FOR THE ! 10988: * RESULT DATATYPE (WITH WA SET TO ZERO). ! 10989: * ! 10990: SLOD3 MOV XR,-(XS) STACK DATATYPE NAME POINTER ! 10991: MOV =NUM01,WB SET STRING CODE IN CASE ! 10992: MOV =SCSTR,XL POINT TO /STRING/ ! 10993: JSR IDENT CHECK FOR MATCH ! 10994: PPM SLOD4 JUMP IF MATCH ! 10995: MOV (XS),XR ELSE RELOAD NAME ! 10996: ADD WB,WB SET CODE FOR INTEGER (2) ! 10997: MOV =SCINT,XL POINT TO /INTEGER/ ! 10998: JSR IDENT CHECK FOR MATCH ! 10999: PPM SLOD4 JUMP IF MATCH ! 11000: MOV (XS),XR ELSE RELOAD STRING POINTER ! 11001: ICV WB SET CODE FOR REAL (3) ! 11002: MOV =SCREA,XL POINT TO /REAL/ ! 11003: JSR IDENT CHECK FOR MATCH ! 11004: PPM SLOD4 JUMP IF MATCH ! 11005: ZER WB ELSE GET CODE FOR NO CONVERT ! 11006: * ! 11007: * MERGE HERE WITH PROPER DATATYPE CODE IN WB ! 11008: * ! 11009: SLOD4 MOV WB,(XS) STORE CODE ON STACK ! 11010: BEQ WA,=NUM02,SLOD2 LOOP BACK IF ARG STOPPED BY COMMA ! 11011: BZE WA,SLOD5 JUMP IF THAT WAS THE RESULT TYPE ! 11012: * ! 11013: * HERE WE SCAN OUT THE RESULT TYPE (ARG STOPPED BY ) ) ! 11014: * ! 11015: MOV MXLEN,WC SET DUMMY (IMPOSSIBLE) DELIMITER 1 ! 11016: MOV WC,XL AND DELIMITER TWO ! 11017: JSR XSCAN SCAN RESULT NAME ! 11018: ZER WA SET CODE FOR PROCESSING RESULT ! 11019: BRN SLOD3 JUMP BACK TO PROCESS RESULT NAME ! 11020: EJC ! 11021: * ! 11022: * LOAD (CONTINUED) ! 11023: * ! 11024: * HERE AFTER PROCESSING ALL ARGS AND RESULT ! 11025: * ! 11026: SLOD5 MOV LODNA,WA GET NUMBER OF ARGUMENTS ! 11027: MOV WA,WC COPY FOR LATER ! 11028: WTB WA CONVERT LENGTH TO BYTES ! 11029: ADD *EFSI$,WA ADD SPACE FOR STANDARD FIELDS ! 11030: JSR ALLOC ALLOCATE EFBLK ! 11031: MOV =B$EFC,(XR) SET TYPE WORD ! 11032: MOV WC,FARGS(XR) SET NUMBER OF ARGUMENTS ! 11033: ZER EFUSE(XR) SET USE COUNT (DFFNC WILL SET TO 1) ! 11034: ZER EFCOD(XR) ZERO CODE POINTER FOR NOW ! 11035: MOV (XS)+,EFRSL(XR) STORE RESULT TYPE CODE ! 11036: MOV LODFN,EFVAR(XR) STORE FUNCTION VRBLK POINTER ! 11037: MOV WA,EFLEN(XR) STORE EFBLK LENGTH ! 11038: MOV XR,WB SAVE EFBLK POINTER ! 11039: ADD WA,XR POINT PAST END OF EFBLK ! 11040: LCT WC,WC SET NUMBER OF ARGUMENTS FOR LOOP ! 11041: * ! 11042: * LOOP TO SET ARGUMENT TYPE CODES FROM STACK ! 11043: * ! 11044: SLOD6 MOV (XS)+,-(XR) STORE ONE TYPE CODE FROM STACK ! 11045: BCT WC,SLOD6 LOOP TILL ALL STORED ! 11046: * ! 11047: * NOW LOAD THE EXTERNAL FUNCTION AND PERFORM DEFINITION ! 11048: * ! 11049: MOV (XS)+,XR LOAD FUNCTION STRING NAME ! 11050: MOV (XS),XL LOAD LIBRARY NAME ! 11051: MOV WB,(XS) STORE EFBLK POINTER ! 11052: JSR SYSLD CALL FUNCTION TO LOAD EXTERNAL FUNC ! 11053: ERR 142,LOAD FUNCTION DOES NOT EXIST ! 11054: ERR 143,LOAD FUNCTION CAUSED INPUT ERROR DURING LOAD ! 11055: MOV (XS)+,XL RECALL EFBLK POINTER ! 11056: MOV XR,EFCOD(XL) STORE CODE POINTER ! 11057: MOV LODFN,XR POINT TO VRBLK FOR FUNCTION ! 11058: JSR DFFNC PERFORM FUNCTION DEFINITION ! 11059: BRN EXNUL RETURN NULL RESULT ! 11060: EJC ! 11061: * ! 11062: * LPAD ! 11063: * ! 11064: S$LPD ENT ENTRY POINT ! 11065: JSR GTSTG GET PAD CHARACTER ! 11066: ERR 144,LPAD THIRD ARGUMENT NOT A STRING ! 11067: PLC XR POINT TO CHARACTER (NULL IS BLANK) ! 11068: LCH WB,(XR) LOAD PAD CHARACTER ! 11069: JSR GTSMI GET PAD LENGTH ! 11070: ERR 145,LPAD SECOND ARGUMENT IS NOT INTEGER ! 11071: PPM SLPD3 SKIP IF NEGATIVE OR LARGE ! 11072: * ! 11073: * MERGE TO CHECK FIRST ARG ! 11074: * ! 11075: SLPD1 JSR GTSTG GET FIRST ARGUMENT (STRING TO PAD) ! 11076: ERR 146,LPAD FIRST ARGUMENT IS NOT STRING ! 11077: BGE WA,WC,EXIXR RETURN 1ST ARG IF TOO LONG TO PAD ! 11078: MOV XR,XL ELSE MOVE PTR TO STRING TO PAD ! 11079: * ! 11080: * NOW WE ARE READY FOR THE PAD ! 11081: * ! 11082: * (XL) POINTER TO STRING TO PAD ! 11083: * (WB) PAD CHARACTER ! 11084: * (WC) LENGTH TO PAD STRING TO ! 11085: * ! 11086: MOV WC,WA COPY LENGTH ! 11087: JSR ALOCS ALLOCATE SCBLK FOR NEW STRING ! 11088: MOV XR,-(XS) SAVE AS RESULT ! 11089: MOV SCLEN(XL),WA LOAD LENGTH OF ARGUMENT ! 11090: SUB WA,WC CALCULATE NUMBER OF PAD CHARACTERS ! 11091: PSC XR POINT TO CHARS IN RESULT STRING ! 11092: LCT WC,WC SET COUNTER FOR PAD LOOP ! 11093: * ! 11094: * LOOP TO PERFORM PAD ! 11095: * ! 11096: SLPD2 SCH WB,(XR)+ STORE PAD CHARACTER, BUMP PTR ! 11097: BCT WC,SLPD2 LOOP TILL ALL PAD CHARS STORED ! 11098: CSC XR COMPLETE STORE CHARACTERS ! 11099: * ! 11100: * NOW COPY STRING ! 11101: * ! 11102: BZE WA,EXITS EXIT IF NULL STRING ! 11103: PLC XL ELSE POINT TO CHARS IN ARGUMENT ! 11104: MVC MOVE CHARACTERS TO RESULT STRING ! 11105: BRN EXITS JUMP FOR NEXT CODE WORD ! 11106: * ! 11107: * HERE IF 2ND ARG IS NEGATIVE OR LARGE ! 11108: * ! 11109: SLPD3 ZER WC ZERO PAD COUNT ! 11110: BRN SLPD1 MERGE ! 11111: EJC ! 11112: * ! 11113: * LT ! 11114: * ! 11115: S$LTF ENT ENTRY POINT ! 11116: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE ! 11117: ERR 147,LT FIRST ARGUMENT IS NOT NUMERIC ! 11118: ERR 148,LT SECOND ARGUMENT IS NOT NUMERIC ! 11119: PPM EXNUL RETURN NULL IF LT ! 11120: PPM EXFAL FAIL IF EQ ! 11121: PPM EXFAL FAIL IF GT ! 11122: EJC ! 11123: * ! 11124: * NE ! 11125: * ! 11126: S$NEF ENT ENTRY POINT ! 11127: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE ! 11128: ERR 149,NE FIRST ARGUMENT IS NOT NUMERIC ! 11129: ERR 150,NE SECOND ARGUMENT IS NOT NUMERIC ! 11130: PPM EXNUL RETURN NULL IF LT ! 11131: PPM EXFAL FAIL IF EQ ! 11132: PPM EXNUL RETURN NULL IF GT ! 11133: EJC ! 11134: * ! 11135: * NOTANY ! 11136: * ! 11137: S$NAY ENT ENTRY POINT ! 11138: MOV =P$NAS,WB SET PCODE FOR SINGLE CHAR ARG ! 11139: MOV =P$NAY,XL PCODE FOR MULTI-CHAR ARG ! 11140: MOV =P$NAD,WC SET PCODE FOR EXPR ARG ! 11141: JSR PATST CALL COMMON ROUTINE TO BUILD NODE ! 11142: ERR 151,NOTANY ARGUMENT IS NOT STRING OR EXPRESSION ! 11143: BRN EXIXR JUMP FOR NEXT CODE WORD ! 11144: EJC ! 11145: * ! 11146: * OPSYN ! 11147: * ! 11148: S$OPS ENT ENTRY POINT ! 11149: JSR GTSMI LOAD THIRD ARGUMENT ! 11150: ERR 152,OPSYN THIRD ARGUMENT IS NOT INTEGER ! 11151: ERR 153,OPSYN THIRD ARGUMENT IS NEGATIVE OR TOO LARGE ! 11152: MOV WC,WB IF OK, SAVE THIRD ARGUMNET ! 11153: MOV (XS)+,XR LOAD SECOND ARGUMENT ! 11154: JSR GTNVR LOCATE VARIABLE BLOCK ! 11155: ERR 154,OPSYN SECOND ARG IS NOT NATURAL VARIABLE NAME ! 11156: MOV VRFNC(XR),XL IF OK, LOAD FUNCTION BLOCK POINTER ! 11157: BNZ WB,SOPS2 JUMP IF OPERATOR OPSYN CASE ! 11158: * ! 11159: * HERE FOR FUNCTION OPSYN (THIRD ARG ZERO) ! 11160: * ! 11161: MOV (XS)+,XR LOAD FIRST ARGUMENT ! 11162: JSR GTNVR GET VRBLK POINTER ! 11163: ERR 155,OPSYN FIRST ARG IS NOT NATURAL VARIABLE NAME ! 11164: * ! 11165: * MERGE HERE TO PERFORM FUNCTION DEFINITION ! 11166: * ! 11167: SOPS1 JSR DFFNC CALL FUNCTION DEFINER ! 11168: BRN EXNUL EXIT WITH NULL RESULT ! 11169: * ! 11170: * HERE FOR OPERATOR OPSYN (THIRD ARG NON-ZERO) ! 11171: * ! 11172: SOPS2 JSR GTSTG GET OPERATOR NAME ! 11173: PPM SOPS5 JUMP IF NOT STRING ! 11174: BNE WA,=NUM01,SOPS5 ERROR IF NOT ONE CHAR LONG ! 11175: PLC XR ELSE POINT TO CHARACTER ! 11176: LCH WC,(XR) LOAD CHARACTER NAME ! 11177: EJC ! 11178: * ! 11179: * OPSYN (CONTINUED) ! 11180: * ! 11181: * NOW SET TO SEARCH FOR MATCHING UNARY OR BINARY OPERATOR ! 11182: * NAME AS APPROPRIATE. NOTE THAT THERE ARE =OPBUN UNDEFINED ! 11183: * BINARY OPERATORS AND =OPUUN UNDEFINED UNARY OPERATORS. ! 11184: * ! 11185: MOV =R$UUB,WA POINT TO UNOP POINTERS IN CASE ! 11186: MOV =OPNSU,XR POINT TO NAMES OF UNARY OPERATORS ! 11187: ADD =OPBUN,WB ADD NO. OF UNDEFINED BINARY OPS ! 11188: BEQ WB,=OPUUN,SOPS3 JUMP IF UNOP (THIRD ARG WAS 1) ! 11189: MOV =R$UBA,WA ELSE POINT TO BINARY OPERATOR PTRS ! 11190: MOV =OPSNB,XR POINT TO NAMES OF BINARY OPERATORS ! 11191: MOV =OPBUN,WB SET NUMBER OF UNDEFINED BINOPS ! 11192: * ! 11193: * MERGE HERE TO CHECK LIST (WB = NUMBER TO CHECK) ! 11194: * ! 11195: SOPS3 LCT WB,WB SET COUNTER TO CONTROL LOOP ! 11196: * ! 11197: * LOOP TO SEARCH FOR NAME MATCH ! 11198: * ! 11199: SOPS4 BEQ WC,(XR),SOPS6 JUMP IF NAMES MATCH ! 11200: ICA WA ELSE PUSH POINTER TO FUNCTION PTR ! 11201: ICA XR BUMP POINTER ! 11202: BCT WB,SOPS4 LOOP BACK TILL ALL CHECKED ! 11203: * ! 11204: * HERE IF BAD OPERATOR NAME ! 11205: * ! 11206: SOPS5 ERB 156,OPSYN FIRST ARG IS NOT CORRECT OPERATOR NAME ! 11207: * ! 11208: * COME HERE ON FINDING A MATCH IN THE OPERATOR NAME TABLE ! 11209: * ! 11210: SOPS6 MOV WA,XR COPY POINTER TO FUNCTION BLOCK PTR ! 11211: SUB *VRFNC,XR MAKE IT LOOK LIKE DUMMY VRBLK ! 11212: BRN SOPS1 MERGE BACK TO DEFINE OPERATOR ! 11213: EJC ! 11214: * ! 11215: * OUTPUT ! 11216: * ! 11217: S$OUP ENT ENTRY POINT ! 11218: MOV =NUM03,WB OUTPUT FLAG ! 11219: JSR IOPUT CALL INPUT/OUTPUT ASSOC. ROUTINE ! 11220: ERR 157,OUTPUT THIRD ARGUMENT IS NOT A STRING ! 11221: ERR 158,INAPPROPRIATE SECOND ARGUMENT FOR OUTPUT ! 11222: ERR 159,INAPPROPRIATE FIRST ARGUMENT FOR OUTPUT ! 11223: ERR 160,INAPPROPRIATE FILE SPECIFICATION FOR OUTPUT ! 11224: PPM EXFAL FAIL IF FILE DOES NOT EXIST ! 11225: ERR 161,OUTPUT FILE CANNOT BE WRITTEN TO ! 11226: BRN EXNUL RETURN NULL STRING ! 11227: EJC ! 11228: * ! 11229: * POS ! 11230: * ! 11231: S$POS ENT ENTRY POINT ! 11232: MOV =P$POS,WB SET PCODE FOR INTEGER ARG CASE ! 11233: MOV =P$PSD,WA SET PCODE FOR EXPRESSION ARG CASE ! 11234: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE ! 11235: ERR 162,POS ARGUMENT IS NOT INTEGER OR EXPRESSION ! 11236: ERR 163,POS ARGUMENT IS NEGATIVE OR TOO LARGE ! 11237: BRN EXIXR RETURN PATTERN NODE ! 11238: EJC ! 11239: * ! 11240: * PROTOTYPE ! 11241: * ! 11242: S$PRO ENT ENTRY POINT ! 11243: MOV (XS)+,XR LOAD ARGUMENT ! 11244: MOV TBLEN(XR),WB LENGTH IF TABLE, VECTOR (=VCLEN) ! 11245: BTW WB CONVERT TO WORDS ! 11246: MOV (XR),WA LOAD TYPE WORD OF ARGUMENT BLOCK ! 11247: BEQ WA,=B$ART,SPRO4 JUMP IF ARRAY ! 11248: BEQ WA,=B$TBT,SPRO1 JUMP IF TABLE ! 11249: BEQ WA,=B$VCT,SPRO3 JUMP IF VECTOR ! 11250: BEQ WA,=B$BCT,SPR05 JUMP IF BUFFER ! 11251: ERB 164,PROTOTYPE ARGUMENT IS NOT VALID OBJECT ! 11252: * ! 11253: * HERE FOR TABLE ! 11254: * ! 11255: SPRO1 SUB =TBSI$,WB SUBTRACT STANDARD FIELDS ! 11256: * ! 11257: * MERGE FOR VECTOR ! 11258: * ! 11259: SPRO2 MTI WB CONVERT TO INTEGER ! 11260: BRN EXINT EXIT WITH INTEGER RESULT ! 11261: * ! 11262: * HERE FOR VECTOR ! 11263: * ! 11264: SPRO3 SUB =VCSI$,WB SUBTRACT STANDARD FIELDS ! 11265: BRN SPRO2 MERGE ! 11266: * ! 11267: * HERE FOR ARRAY ! 11268: * ! 11269: SPRO4 ADD AROFS(XR),XR POINT TO PROTOTYPE FIELD ! 11270: MOV (XR),XR LOAD PROTOTYPE ! 11271: BRN EXIXR RETURN PROTOTYPE AS RESULT ! 11272: * ! 11273: * HERE FOR BUFFER ! 11274: * ! 11275: SPR05 MOV BCBUF(XR),XR POINT TO BFBLK ! 11276: MTI BFALC(XR) LOAD ALLOCATED LENGTH ! 11277: BRN EXINT EXIT WITH INTEGER ALLOCATION ! 11278: EJC ! 11279: * ! 11280: * REMDR ! 11281: * ! 11282: S$RMD ENT ENTRY POINT ! 11283: ZER WB SET POSITIVE FLAG ! 11284: MOV (XS),XR LOAD SECOND ARGUMENT ! 11285: JSR GTINT CONVERT TO INTEGER ! 11286: ERR 165,REMDR SECOND ARGUMENT IS NOT INTEGER ! 11287: JSR ARITH CONVERT ARGS ! 11288: PPM SRM01 FIRST ARG NOT INTEGER ! 11289: PPM SECOND ARG CHECKED ABOVE ! 11290: PPM SRM01 FIRST ARG REAL ! 11291: LDI ICVAL(XR) LOAD LEFT ARGUMENT VALUE ! 11292: RMI ICVAL(XL) GET REMAINDER ! 11293: INO EXINT JUMP IF NO OVERFLOW ! 11294: ERB 167,REMDR CAUSED INTEGER OVERFLOW ! 11295: * ! 11296: * FAIL FIRST ARGUMENT ! 11297: * ! 11298: SRM01 ERB 166,REMDR FIRST ARGUMENT IS NOT INTEGER ! 11299: EJC ! 11300: * ! 11301: * REPLACE ! 11302: * ! 11303: * THE ACTUAL REPLACE OPERATION USES AN SCBLK WHOSE CFP$A ! 11304: * CHARS CONTAIN THE TRANSLATED VERSIONS OF ALL THE CHARS. ! 11305: * THE TABLE POINTER IS REMEMBERED FROM CALL TO CALL AND ! 11306: * THE TABLE IS ONLY BUILT WHEN THE ARGUMENTS CHANGE. ! 11307: * ! 11308: S$RPL ENT ENTRY POINT ! 11309: JSR GTSTG LOAD THIRD ARGUMENT AS STRING ! 11310: ERR 168,REPLACE THIRD ARGUMENT IS NOT STRING ! 11311: MOV XR,XL SAVE THIRD ARG PTR ! 11312: JSR GTSTG GET SECOND ARGUMENT ! 11313: ERR 169,REPLACE SECOND ARGUMENT IS NOT STRING ! 11314: * ! 11315: * CHECK TO SEE IF THIS IS THE SAME TABLE AS LAST TIME ! 11316: * ! 11317: BNE XR,R$RA2,SRPL1 JUMP IF 2ND ARGUMENT DIFFERENT ! 11318: BEQ XL,R$RA3,SRPL4 JUMP IF ARGS SAME AS LAST TIME ! 11319: * ! 11320: * HERE WE BUILD A NEW REPLACE TABLE (NOTE WA = 2ND ARG LEN) ! 11321: * ! 11322: SRPL1 MOV SCLEN(XL),WB LOAD 3RD ARGUMENT LENGTH ! 11323: BNE WA,WB,SRPL5 JUMP IF ARGUMENTS NOT SAME LENGTH ! 11324: BZE WB,SRPL5 JUMP IF NULL 2ND ARGUMENT ! 11325: MOV XL,R$RA3 SAVE THIRD ARG FOR NEXT TIME IN ! 11326: MOV XR,R$RA2 SAVE SECOND ARG FOR NEXT TIME IN ! 11327: MOV KVALP,XL POINT TO ALPHABET STRING ! 11328: MOV SCLEN(XL),WA LOAD ALPHABET SCBLK LENGTH ! 11329: MOV R$RPT,XR POINT TO CURRENT TABLE (IF ANY) ! 11330: BNZ XR,SRPL2 JUMP IF WE ALREADY HAVE A TABLE ! 11331: * ! 11332: * HERE WE ALLOCATE A NEW TABLE ! 11333: * ! 11334: JSR ALOCS ALLOCATE NEW TABLE ! 11335: MOV WC,WA KEEP SCBLK LENGTH ! 11336: MOV XR,R$RPT SAVE TABLE POINTER FOR NEXT TIME ! 11337: * ! 11338: * MERGE HERE WITH POINTER TO NEW TABLE BLOCK IN (XR) ! 11339: * ! 11340: SRPL2 CTB WA,SCSI$ COMPUTE LENGTH OF SCBLK ! 11341: MVW COPY TO GET INITIAL TABLE VALUES ! 11342: EJC ! 11343: * ! 11344: * REPLACE (CONTINUED) ! 11345: * ! 11346: * NOW WE MUST PLUG SELECTED ENTRIES AS REQUIRED. NOTE THAT ! 11347: * WE ARE SHORT OF INDEX REGISTERS FOR THE FOLLOWING LOOP. ! 11348: * HENCE THE NEED TO REPEATEDLY RE-INITIALISE CHAR PTR XL ! 11349: * ! 11350: MOV R$RA2,XL POINT TO SECOND ARGUMENT ! 11351: LCT WB,WB NUMBER OF CHARS TO PLUG ! 11352: ZER WC ZERO CHAR OFFSET ! 11353: MOV R$RA3,XR POINT TO 3RD ARG ! 11354: PLC XR GET CHAR PTR FOR 3RD ARG ! 11355: * ! 11356: * LOOP TO PLUG CHARS ! 11357: * ! 11358: SRPL3 MOV R$RA2,XL POINT TO 2ND ARG ! 11359: PLC XL,WC POINT TO NEXT CHAR ! 11360: ICV WC INCREMENT OFFSET ! 11361: LCH WA,(XL) GET NEXT CHAR ! 11362: MOV R$RPT,XL POINT TO TRANSLATE TABLE ! 11363: PSC XL,WA CONVERT CHAR TO OFFSET INTO TABLE ! 11364: LCH WA,(XR)+ GET TRANSLATED CHAR ! 11365: SCH WA,(XL) STORE IN TABLE ! 11366: CSC XL COMPLETE STORE CHARACTERS ! 11367: BCT WB,SRPL3 LOOP TILL DONE ! 11368: EJC ! 11369: * ! 11370: * REPLACE (CONTINUED) ! 11371: * ! 11372: * HERE TO PERFORM TRANSLATE ! 11373: * ! 11374: SRPL4 JSR GTSTG GET FIRST ARGUMENT ! 11375: ERR 170,REPLACE FIRST ARGUMENT IS NOT STRING ! 11376: BZE WA,EXNUL RETURN NULL IF NULL ARGUMENT ! 11377: MOV XR,XL COPY POINTER ! 11378: MOV WA,WC SAVE LENGTH ! 11379: CTB WA,SCHAR GET SCBLK LENGTH ! 11380: JSR ALLOC ALLOCATE SPACE FOR COPY ! 11381: MOV XR,WB SAVE ADDRESS OF COPY ! 11382: MVW MOVE SCBLK CONTENTS TO COPY ! 11383: MOV R$RPT,XR POINT TO REPLACE TABLE ! 11384: PLC XR POINT TO CHARS OF TABLE ! 11385: MOV WB,XL POINT TO STRING TO TRANSLATE ! 11386: PLC XL POINT TO CHARS OF STRING ! 11387: MOV WC,WA SET NUMBER OF CHARS TO TRANSLATE ! 11388: TRC PERFORM TRANSLATION ! 11389: MOV WB,-(XS) STACK NEW STRING AS RESULT ! 11390: BRN EXITS RETURN WITH RESULT ON STACK ! 11391: * ! 11392: * ERROR POINT ! 11393: * ! 11394: SRPL5 ERB 171,NULL OR UNEQUALLY LONG 2ND, 3RD ARGS TO REPLACE ! 11395: EJC ! 11396: * ! 11397: * REWIND ! 11398: * ! 11399: S$REW ENT ENTRY POINT ! 11400: JSR IOFCB CALL FCBLK ROUTINE ! 11401: ERR 172,REWIND ARGUMENT IS NOT A SUITABLE NAME ! 11402: ERR 173,REWIND ARGUMENT IS NULL ! 11403: JSR SYSRW CALL SYSTEM REWIND FUNCTION ! 11404: ERR 174,REWIND FILE DOES NOT EXIST ! 11405: ERR 175,REWIND FILE DOES NOT PERMIT REWIND ! 11406: ERR 176,REWIND CAUSED NON-RECOVERABLE ERROR ! 11407: BRN EXNUL EXIT WITH NULL RESULT IF NO ERROR ! 11408: EJC ! 11409: * ! 11410: * REVERSE ! 11411: * ! 11412: S$RVS ENT ENTRY POINT ! 11413: JSR GTSTG LOAD STRING ARGUMENT ! 11414: ERR 177,REVERSE ARGUMENT IS NOT STRING ! 11415: BZE WA,EXIXR RETURN ARGUMENT IF NULL ! 11416: MOV XR,XL ELSE SAVE POINTER TO STRING ARG ! 11417: JSR ALOCS ALLOCATE SPACE FOR NEW SCBLK ! 11418: MOV XR,-(XS) STORE SCBLK PTR ON STACK AS RESULT ! 11419: PSC XR PREPARE TO STORE IN NEW SCBLK ! 11420: PLC XL,WC POINT PAST LAST CHAR IN ARGUMENT ! 11421: LCT WC,WC SET LOOP COUNTER ! 11422: * ! 11423: * LOOP TO MOVE CHARS IN REVERSE ORDER ! 11424: * ! 11425: SRVS1 LCH WB,-(XL) LOAD NEXT CHAR FROM ARGUMENT ! 11426: SCH WB,(XR)+ STORE IN RESULT ! 11427: BCT WC,SRVS1 LOOP TILL ALL MOVED ! 11428: CSC XR COMPLETE STORE CHARACTERS ! 11429: BRN EXITS AND THEN JUMP FOR NEXT CODE WORD ! 11430: EJC ! 11431: * ! 11432: * RPAD ! 11433: * ! 11434: S$RPD ENT ENTRY POINT ! 11435: JSR GTSTG GET PAD CHARACTER ! 11436: ERR 178,RPAD THIRD ARGUMENT IS NOT STRING ! 11437: PLC XR POINT TO CHARACTER (NULL IS BLANK) ! 11438: LCH WB,(XR) LOAD PAD CHARACTER ! 11439: JSR GTSMI GET PAD LENGTH ! 11440: ERR 179,RPAD SECOND ARGUMENT IS NOT INTEGER ! 11441: PPM SRPD3 SKIP IF NEGATIVE OR LARGE ! 11442: * ! 11443: * MERGE TO CHECK FIRST ARG. ! 11444: * ! 11445: SRPD1 JSR GTSTG GET FIRST ARGUMENT (STRING TO PAD) ! 11446: ERR 180,RPAD FIRST ARGUMENT IS NOT STRING ! 11447: BGE WA,WC,EXIXR RETURN 1ST ARG IF TOO LONG TO PAD ! 11448: MOV XR,XL ELSE MOVE PTR TO STRING TO PAD ! 11449: * ! 11450: * NOW WE ARE READY FOR THE PAD ! 11451: * ! 11452: * (XL) POINTER TO STRING TO PAD ! 11453: * (WB) PAD CHARACTER ! 11454: * (WC) LENGTH TO PAD STRING TO ! 11455: * ! 11456: MOV WC,WA COPY LENGTH ! 11457: JSR ALOCS ALLOCATE SCBLK FOR NEW STRING ! 11458: MOV XR,-(XS) SAVE AS RESULT ! 11459: MOV SCLEN(XL),WA LOAD LENGTH OF ARGUMENT ! 11460: SUB WA,WC CALCULATE NUMBER OF PAD CHARACTERS ! 11461: PSC XR POINT TO CHARS IN RESULT STRING ! 11462: LCT WC,WC SET COUNTER FOR PAD LOOP ! 11463: * ! 11464: * COPY ARGUMENT STRING ! 11465: * ! 11466: BZE WA,SRPD2 JUMP IF ARGUMENT IS NULL ! 11467: PLC XL ELSE POINT TO ARGUMENT CHARS ! 11468: MVC MOVE CHARACTERS TO RESULT STRING ! 11469: * ! 11470: * LOOP TO SUPPLY PAD CHARACTERS ! 11471: * ! 11472: SRPD2 SCH WB,(XR)+ STORE PAD CHARACTER, BUMP PTR ! 11473: BCT WC,SRPD2 LOOP TILL ALL PAD CHARS STORED ! 11474: CSC XR COMPLETE CHARACTER STORING ! 11475: BRN EXITS AND EXIT FOR NEXT WORD ! 11476: * ! 11477: * HERE IF 2ND ARG IS NEGATIVE OR LARGE ! 11478: * ! 11479: SRPD3 ZER WC ZERO PAD COUNT ! 11480: BRN SRPD1 MERGE ! 11481: EJC ! 11482: * ! 11483: * RTAB ! 11484: * ! 11485: S$RTB ENT ENTRY POINT ! 11486: MOV =P$RTB,WB SET PCODE FOR INTEGER ARG CASE ! 11487: MOV =P$RTD,WA SET PCODE FOR EXPRESSION ARG CASE ! 11488: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE ! 11489: ERR 181,RTAB ARGUMENT IS NOT INTEGER OR EXPRESSION ! 11490: ERR 182,RTAB ARGUMENT IS NEGATIVE OR TOO LARGE ! 11491: BRN EXIXR RETURN PATTERN NODE ! 11492: EJC ! 11493: * ! 11494: * SET ! 11495: * ! 11496: S$SET ENT ENTRY POINT ! 11497: MOV (XS)+,R$IO2 SAVE THIRD ARG ! 11498: MOV (XS)+,R$IO1 SAVE SECOND ARG ! 11499: JSR IOFCB CALL FCBLK ROUTINE ! 11500: ERR 291,SET FIRST ARGUMENT IS NOT A SUITABLE NAME ! 11501: ERR 292,SET FIRST ARGUMENT IS NULL ! 11502: MOV R$IO1,WB LOAD SECOND ARG ! 11503: MOV R$IO2,WC LOAD THIRD ARG ! 11504: JSR SYSST CALL SYSTEM SET ROUTINE ! 11505: ERR 293,INAPPROPRIATE SECOND ARGUMENT TO SET ! 11506: ERR 294,INAPPROPRIATE THIRD ARGUMENT TO SET ! 11507: ERR 295,SET FILE DOES NOT EXIST ! 11508: ERR 296,SET FILE DOES NOT PERMIT SETTING FILE POINTER ! 11509: ERR 297,SET CAUSED NON-RECOVERABLE I/O ERROR ! 11510: BRN EXNUL OTHERWISEW RETURN NULL ! 11511: EJC ! 11512: * ! 11513: * TAB ! 11514: * ! 11515: S$TAB ENT ENTRY POINT ! 11516: MOV =P$TAB,WB SET PCODE FOR INTEGER ARG CASE ! 11517: MOV =P$TBD,WA SET PCODE FOR EXPRESSION ARG CASE ! 11518: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE ! 11519: ERR 183,TAB ARGUMENT IS NOT INTEGER OR EXPRESSION ! 11520: ERR 184,TAB ARGUMENT IS NEGATIVE OR TOO LARGE ! 11521: BRN EXIXR RETURN PATTERN NODE ! 11522: EJC ! 11523: * ! 11524: * RPOS ! 11525: * ! 11526: S$RPS ENT ENTRY POINT ! 11527: MOV =P$RPS,WB SET PCODE FOR INTEGER ARG CASE ! 11528: MOV =P$RPD,WA SET PCODE FOR EXPRESSION ARG CASE ! 11529: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE ! 11530: ERR 185,RPOS ARGUMENT IS NOT INTEGER OR EXPRESSION ! 11531: ERR 186,RPOS ARGUMENT IS NEGATIVE OR TOO LARGE ! 11532: BRN EXIXR RETURN PATTERN NODE ! 11533: EJC ! 11534: * ! 11535: * RSORT ! 11536: * ! 11537: S$RSR ENT ENTRY POINT ! 11538: MNZ WA MARK AS RSORT ! 11539: JSR SORTA CALL SORT ROUTINE ! 11540: BRN EXSID RETURN, SETTING IDVAL ! 11541: EJC ! 11542: * ! 11543: * SETEXIT ! 11544: * ! 11545: S$STX ENT ENTRY POINT ! 11546: MOV (XS)+,XR LOAD ARGUMENT ! 11547: MOV STXVR,WA LOAD OLD VRBLK POINTER ! 11548: ZER XL LOAD ZERO IN CASE NULL ARG ! 11549: BEQ XR,=NULLS,SSTX1 JUMP IF NULL ARGUMENT (RESET CALL) ! 11550: JSR GTNVR ELSE GET SPECIFIED VRBLK ! 11551: PPM SSTX2 JUMP IF NOT NATURAL VARIABLE ! 11552: MOV VRLBL(XR),XL ELSE LOAD LABEL ! 11553: BEQ XL,=STNDL,SSTX2 JUMP IF LABEL IS NOT DEFINED ! 11554: BNE (XL),=B$TRT,SSTX1 JUMP IF NOT TRAPPED ! 11555: MOV TRLBL(XL),XL ELSE LOAD PTR TO REAL LABEL CODE ! 11556: * ! 11557: * HERE TO SET/RESET SETEXIT TRAP ! 11558: * ! 11559: SSTX1 MOV XR,STXVR STORE NEW VRBLK POINTER (OR NULL) ! 11560: MOV XL,R$SXC STORE NEW CODE PTR (OR ZERO) ! 11561: BEQ WA,=NULLS,EXNUL RETURN NULL IF NULL RESULT ! 11562: MOV WA,XR ELSE COPY VRBLK POINTER ! 11563: BRN EXVNM AND RETURN BUILDING NMBLK ! 11564: * ! 11565: * HERE IF BAD ARGUMENT ! 11566: * ! 11567: SSTX2 ERB 187,SETEXIT ARGUMENT IS NOT LABEL NAME OR NULL ! 11568: EJC ! 11569: * ! 11570: * SORT ! 11571: * ! 11572: S$SRT ENT ENTRY POINT ! 11573: ZER WA MARK AS SORT ! 11574: JSR SORTA CALL SORT ROUTINE ! 11575: BRN EXSID RETURN, SETTING IDVAL ! 11576: EJC ! 11577: * ! 11578: * SPAN ! 11579: * ! 11580: S$SPN ENT ENTRY POINT ! 11581: MOV =P$SPS,WB SET PCODE FOR SINGLE CHAR ARG ! 11582: MOV =P$SPN,XL SET PCODE FOR MULTI-CHAR ARG ! 11583: MOV =P$SPD,WC SET PCODE FOR EXPRESSION ARG ! 11584: JSR PATST CALL COMMON ROUTINE TO BUILD NODE ! 11585: ERR 188,SPAN ARGUMENT IS NOT STRING OR EXPRESSION ! 11586: BRN EXIXR JUMP FOR NEXT CODE WORD ! 11587: EJC ! 11588: * ! 11589: * SIZE ! 11590: * ! 11591: S$SI$ ENT ENTRY POINT ! 11592: MOV (XS),XR LOAD ARGUMENT ! 11593: BNE (XR),=B$BCT,SSI$1 BRANCH IF NOT BUFFER ! 11594: ICA XS ELSE POP ARGUMENT ! 11595: MTI BCLEN(XR) LOAD DEFINED LENGTH ! 11596: BRN EXINT EXIT WITH INTEGER ! 11597: * ! 11598: * HERE IF NOT BUFFER ! 11599: * ! 11600: SSI$1 JSR GTSTG LOAD STRING ARGUMENT ! 11601: ERR 189,SIZE ARGUMENT IS NOT STRING ! 11602: MTI WA LOAD LENGTH AS INTEGER ! 11603: BRN EXINT EXIT WITH INTEGER RESULT ! 11604: EJC ! 11605: * ! 11606: * STOPTR ! 11607: * ! 11608: S$STT ENT ENTRY POINT ! 11609: ZER XL INDICATE STOPTR CASE ! 11610: JSR TRACE CALL TRACE PROCEDURE ! 11611: ERR 190,STOPTR FIRST ARGUMENT IS NOT APPROPRIATE NAME ! 11612: ERR 191,STOPTR SECOND ARGUMENT IS NOT TRACE TYPE ! 11613: BRN EXNUL RETURN NULL ! 11614: EJC ! 11615: * ! 11616: * SUBSTR ! 11617: * ! 11618: S$SUB ENT ENTRY POINT ! 11619: JSR GTSMI LOAD THIRD ARGUMENT ! 11620: ERR 192,SUBSTR THIRD ARGUMENT IS NOT INTEGER ! 11621: PPM EXFAL JUMP IF NEGATIVE OR TOO LARGE ! 11622: MOV XR,SBSSV SAVE THIRD ARGUMENT ! 11623: JSR GTSMI LOAD SECOND ARGUMENT ! 11624: ERR 193,SUBSTR SECOND ARGUMENT IS NOT INTEGER ! 11625: PPM EXFAL JUMP IF OUT OF RANGE ! 11626: MOV XR,WB SAVE SECOND ARGUMENT ! 11627: BZE WB,EXFAL JUMP IF SECOND ARGUMENT ZERO ! 11628: DCV WB ELSE DECREMENT FOR ONES ORIGIN ! 11629: MOV (XS),XL GET FIRST ARG PTR ! 11630: BNE (XL),=B$BCT,SSUBA BRANCH IF NOT BUFFER ! 11631: MOV BCBUF(XL),XR GET BFBLK PTR ! 11632: MOV BCLEN(XL),WA GET LENGTH ! 11633: BRN SSUBB MERGE ! 11634: * ! 11635: * HERE IF NOT BUFFER TO GET STRING ! 11636: * ! 11637: SSUBA JSR GTSTG LOAD FIRST ARGUMENT ! 11638: ERR 194,SUBSTR FIRST ARGUMENT IS NOT STRING ! 11639: * ! 11640: * MERGE WITH BFBLK OR SCBLK PTR IN XR. WA HAS LENGTH ! 11641: * ! 11642: SSUBB MOV SBSSV,WC RELOAD THIRD ARGUMENT ! 11643: BNZ WC,SSUB1 SKIP IF THIRD ARG GIVEN ! 11644: MOV WA,WC ELSE GET STRING LENGTH ! 11645: BGT WB,WC,EXFAL FAIL IF IMPROPER ! 11646: SUB WB,WC REDUCE BY OFFSET TO START ! 11647: * ! 11648: * MERGE ! 11649: * ! 11650: SSUB1 MOV WA,XL SAVE STRING LENGTH ! 11651: MOV WC,WA SET LENGTH OF SUBSTRING ! 11652: ADD WB,WC ADD 2ND ARG TO 3RD ARG ! 11653: BGT WC,XL,EXFAL JUMP IF IMPROPER SUBSTRING ! 11654: MOV XR,XL COPY POINTER TO FIRST ARG ! 11655: JSR SBSTR BUILD SUBSTRING ! 11656: BRN EXIXR AND JUMP FOR NEXT CODE WORD ! 11657: EJC ! 11658: * ! 11659: * TABLE ! 11660: * ! 11661: S$TBL ENT ENTRY POINT ! 11662: MOV (XS)+,XL GET INITIAL LOOKUP VALUE ! 11663: ICA XS POP SECOND ARGUMENT ! 11664: JSR GTSMI LOAD ARGUMENT ! 11665: ERR 195,TABLE ARGUMENT IS NOT INTEGER ! 11666: ERR 196,TABLE ARGUMENT IS OUT OF RANGE ! 11667: BNZ WC,STBL1 JUMP IF NON-ZERO ! 11668: MOV =TBNBK,WC ELSE SUPPLY DEFAULT VALUE ! 11669: * ! 11670: * MERGE HERE WITH NUMBER OF HEADERS IN WA ! 11671: * ! 11672: STBL1 MOV WC,WA COPY NUMBER OF HEADERS ! 11673: ADD =TBSI$,WA ADJUST FOR STANDARD FIELDS ! 11674: WTB WA CONVERT LENGTH TO BYTES ! 11675: JSR ALLOC ALLOCATE SPACE FOR TBBLK ! 11676: MOV XR,WB COPY POINTER TO TBBLK ! 11677: MOV =B$TBT,(XR)+ STORE TYPE WORD ! 11678: ZER (XR)+ ZERO ID FOR THE MOMENT ! 11679: MOV WA,(XR)+ STORE LENGTH (TBLEN) ! 11680: MOV XL,(XR)+ STORE INITIAL LOOKUP VALUE ! 11681: LCT WC,WC SET LOOP COUNTER (NUM HEADERS) ! 11682: * ! 11683: * LOOP TO INITIALIZE ALL BUCKET POINTERS ! 11684: * ! 11685: STBL2 MOV WB,(XR)+ STORE TBBLK PTR IN BUCKET HEADER ! 11686: BCT WC,STBL2 LOOP TILL ALL STORED ! 11687: MOV WB,XR RECALL POINTER TO TBBLK ! 11688: BRN EXSID EXIT SETTING IDVAL ! 11689: EJC ! 11690: * ! 11691: * TIME ! 11692: * ! 11693: S$TIM ENT ENTRY POINT ! 11694: JSR SYSTM GET TIMER VALUE ! 11695: SBI TIMSX SUBTRACT STARTING TIME ! 11696: BRN EXINT EXIT WITH INTEGER VALUE ! 11697: EJC ! 11698: * ! 11699: * TRACE ! 11700: * ! 11701: S$TRA ENT ENTRY POINT ! 11702: BEQ 3(XS),=NULLS,STR03 JUMP IF FIRST ARGUMENT IS NULL ! 11703: MOV (XS)+,XR LOAD FOURTH ARGUMENT ! 11704: ZER XL TENTATIVELY SET ZERO POINTER ! 11705: BEQ XR,=NULLS,STR02 JUMP IF 4TH ARGUMENT IS NULL ! 11706: JSR GTNVR ELSE POINT TO VRBLK ! 11707: PPM STR01 JUMP IF NOT VARIABLE NAME ! 11708: MOV VRFNC(XR),XL ELSE LOAD FUNCTION POINTER ! 11709: BNE XL,=STNDF,STR02 JUMP IF FUNCTION IS DEFINED ! 11710: * ! 11711: * HERE FOR BAD FOURTH ARGUMENT ! 11712: * ! 11713: STR01 ERB 197,TRACE FOURTH ARG IS NOT FUNCTION NAME OR NULL ! 11714: * ! 11715: * HERE WITH FUNCTION POINTER IN XL ! 11716: * ! 11717: STR02 MOV (XS)+,XR LOAD THIRD ARGUMENT (TAG) ! 11718: ZER WB SET ZERO AS TRTYP VALUE FOR NOW ! 11719: JSR TRBLD BUILD TRBLK FOR TRACE CALL ! 11720: MOV XR,XL MOVE TRBLK POINTER FOR TRACE ! 11721: JSR TRACE CALL TRACE PROCEDURE ! 11722: ERR 198,TRACE FIRST ARGUMENT IS NOT APPROPRIATE NAME ! 11723: ERR 199,TRACE SECOND ARGUMENT IS NOT TRACE TYPE ! 11724: BRN EXNUL RETURN NULL ! 11725: * ! 11726: * HERE TO CALL SYSTEM TRACE TOGGLE ROUTINE ! 11727: * ! 11728: STR03 JSR SYSTT CALL IT ! 11729: ADD *NUM04,XS POP TRACE ARGUMENTS ! 11730: BRN EXNUL RETURN ! 11731: EJC ! 11732: * ! 11733: * TRIM ! 11734: * ! 11735: S$TRM ENT ENTRY POINT ! 11736: JSR GTSTG LOAD ARGUMENT AS STRING ! 11737: ERR 200,TRIM ARGUMENT IS NOT STRING ! 11738: BZE WA,EXNUL RETURN NULL IF ARGUMENT IS NULL ! 11739: MOV XR,XL COPY STRING POINTER ! 11740: CTB WA,SCHAR GET BLOCK LENGTH ! 11741: JSR ALLOC ALLOCATE COPY SAME SIZE ! 11742: MOV XR,WB SAVE POINTER TO COPY ! 11743: MVW COPY OLD STRING BLOCK TO NEW ! 11744: MOV WB,XR RESTORE PTR TO NEW BLOCK ! 11745: JSR TRIMR TRIM BLANKS (WB IS NON-ZERO) ! 11746: BRN EXIXR EXIT WITH RESULT IN XR ! 11747: EJC ! 11748: * ! 11749: * UNLOAD ! 11750: * ! 11751: S$UNL ENT ENTRY POINT ! 11752: MOV (XS)+,XR LOAD ARGUMENT ! 11753: JSR GTNVR POINT TO VRBLK ! 11754: ERR 201,UNLOAD ARGUMENT IS NOT NATURAL VARIABLE NAME ! 11755: MOV =STNDF,XL GET PTR TO UNDEFINED FUNCTION ! 11756: JSR DFFNC UNDEFINE NAMED FUNCTION ! 11757: BRN EXNUL RETURN NULL AS RESULT ! 11758: TTL S P I T B O L -- UTILITY PROCEDURES ! 11759: * ! 11760: * THE FOLLOWING SECTION CONTAINS PROCEDURES WHICH ARE ! 11761: * USED FOR VARIOUS PURPOSES THROUGHOUT THE SYSTEM. ! 11762: * ! 11763: * EACH PROCEDURE IS PRECEDED BY A DESCRIPTION OF THE ! 11764: * CALLING SEQUENCE. USUALLY THE ARGUMENTS ARE IN REGISTERS ! 11765: * BUT ARGUMENTS CAN ALSO OCCUR ON THE STACK AND AS ! 11766: * PARAMETERS ASSEMBLED AFTER THE JSR INSTRUCTION. ! 11767: * ! 11768: * THE FOLLOWING CONSIDERATIONS APPLY TO THESE DESCRIPTIONS. ! 11769: * ! 11770: * 1) THE STACK POINTER (XS) IS NOT CHANGED UNLESS THE ! 11771: * CHANGE IS EXPLICITLY DOCUMENTED IN THE CALL. ! 11772: * ! 11773: * 2) REGISTERS WHOSE ENTRY VALUES ARE NOT MENTIONED ! 11774: * MAY CONTAIN ANY VALUE EXCEPT THAT XL,XR MAY ONLY ! 11775: * CONTAIN PROPER (COLLECTABLE) POINTER VALUES. ! 11776: * THIS CONDITION ON XR MEANS THAT THE CALLED ROUTINE ! 11777: * MAY IF IT CHOOSES PRESERVE XR BY STACKING. ! 11778: * ! 11779: * 3) REGISTERS NOT MENTIONED ON EXIT CONTAIN THE SAME ! 11780: * VALUES AS THEY DID ON ENTRY EXCEPT THAT VALUES IN ! 11781: * XR,XL MAY HAVE BEEN RELOCATED BY THE COLLECTOR. ! 11782: * ! 11783: * 4) REGISTERS WHICH ARE DESTROYED ON EXIT MAY CONTAIN ! 11784: * ANY VALUE EXCEPT THAT VALUES IN XL,XR ARE PROPER ! 11785: * (COLLECTABLE) POINTERS. ! 11786: * ! 11787: * 5) THE CODE POINTER REGISTER POINTS TO THE CURRENT ! 11788: * CODE LOCATION ON ENTRY AND IS UNCHANGED ON EXIT. ! 11789: * ! 11790: * IN THE ABOVE DESCRIPTION, A COLLECTABLE POINTER IS ONE ! 11791: * WHICH EITHER POINTS OUTSIDE THE DYNAMIC REGION OR ! 11792: * POINTS TO THE START OF A BLOCK IN THE DYNAMIC REGION. ! 11793: * ! 11794: * IN THOSE CASES WHERE THE CALLING SEQUENCE CONTAINS ! 11795: * PARAMETERS WHICH ARE USED AS ALTERNATE RETURN POINTS, ! 11796: * THESE PARAMETERS MAY BE REPLACED BY ERROR CODES ! 11797: * ASSEMBLED WITH THE ERR INSTRUCTION. THIS WILL RESULT ! 11798: * IN THE POSTING OF THE ERROR IF THE RETURN IS TAKEN. ! 11799: * ! 11800: * THE PROCEDURES ALL HAVE NAMES CONSISTING OF FIVE LETTERS ! 11801: * AND ARE IN ALPHABETICAL ORDER BY THEIR NAMES. ! 11802: EJC ! 11803: * ! 11804: * ACESS - ACCESS VARIABLE VALUE WITH TRACE/INPUT CHECKS ! 11805: * ! 11806: * ACESS LOADS THE VALUE OF A VARIABLE. TRACE AND INPUT ! 11807: * ASSOCIATIONS ARE TESTED FOR AND EXECUTED AS REQUIRED. ! 11808: * ACESS ALSO HANDLES THE SPECIAL CASES OF PSEUDO-VARIABLES. ! 11809: * ! 11810: * (XL) VARIABLE NAME BASE ! 11811: * (WA) VARIABLE NAME OFFSET ! 11812: * JSR ACESS CALL TO ACCESS VALUE ! 11813: * PPM LOC TRANSFER LOC IF ACCESS FAILURE ! 11814: * (XR) VARIABLE VALUE ! 11815: * (WA,WB,WC) DESTROYED ! 11816: * (XL,RA) DESTROYED ! 11817: * ! 11818: * FAILURE CAN OCCUR IF AN INPUT ASSOCIATION CAUSES AN END ! 11819: * OF FILE CONDITION OR IF THE EVALUATION OF AN EXPRESSION ! 11820: * ASSOCIATED WITH AN EXPRESSION VARIABLE FAILS. ! 11821: * ! 11822: ACESS PRC R,1 ENTRY POINT (RECURSIVE) ! 11823: MOV XL,XR COPY NAME BASE ! 11824: ADD WA,XR POINT TO VARIABLE LOCATION ! 11825: MOV (XR),XR LOAD VARIABLE VALUE ! 11826: * ! 11827: * LOOP HERE TO CHECK FOR SUCCESSIVE TRBLKS ! 11828: * ! 11829: ACS02 BNE (XR),=B$TRT,ACS18 JUMP IF NOT TRAPPED ! 11830: * ! 11831: * HERE IF TRAPPED ! 11832: * ! 11833: BEQ XR,=TRBKV,ACS12 JUMP IF KEYWORD VARIABLE ! 11834: BNE XR,=TRBEV,ACS05 JUMP IF NOT EXPRESSION VARIABLE ! 11835: * ! 11836: * HERE FOR EXPRESSION VARIABLE, EVALUATE VARIABLE ! 11837: * ! 11838: MOV EVEXP(XL),XR LOAD EXPRESSION POINTER ! 11839: ZER WB EVALUATE BY VALUE ! 11840: JSR EVALX EVALUATE EXPRESSION ! 11841: PPM ACS04 JUMP IF EVALUATION FAILURE ! 11842: BRN ACS02 CHECK VALUE FOR MORE TRBLKS ! 11843: EJC ! 11844: * ! 11845: * ACESS (CONTINUED) ! 11846: * ! 11847: * HERE ON READING END OF FILE ! 11848: * ! 11849: ACS03 ADD *NUM03,XS POP TRBLK PTR, NAME BASE AND OFFSET ! 11850: MOV XR,DNAMP POP UNUSED SCBLK ! 11851: * ! 11852: * MERGE HERE WHEN EVALUATION OF EXPRESSION FAILS ! 11853: * ! 11854: ACS04 EXI 1 TAKE ALTERNATE (FAILURE) RETURN ! 11855: * ! 11856: * HERE IF NOT KEYWORD OR EXPRESSION VARIABLE ! 11857: * ! 11858: ACS05 MOV TRTYP(XR),WB LOAD TRAP TYPE CODE ! 11859: BNZ WB,ACS10 JUMP IF NOT INPUT ASSOCIATION ! 11860: BZE KVINP,ACS09 IGNORE INPUT ASSOC IF INPUT IS OFF ! 11861: * ! 11862: * HERE FOR INPUT ASSOCIATION ! 11863: * ! 11864: MOV XL,-(XS) STACK NAME BASE ! 11865: MOV WA,-(XS) STACK NAME OFFSET ! 11866: MOV XR,-(XS) STACK TRBLK POINTER ! 11867: MOV TRFPT(XR),XL GET FILE CTRL BLK PTR OR ZERO ! 11868: BNZ XL,ACS06 JUMP IF NOT STANDARD INPUT FILE ! 11869: BEQ TRTER(XR),=V$TER,ACS21 JUMP IF TERMINAL ! 11870: * ! 11871: * HERE TO READ FROM STANDARD INPUT FILE ! 11872: * ! 11873: MOV CSWIN,WA LENGTH FOR READ BUFFER ! 11874: JSR ALOCS BUILD STRING OF APPROPRIATE LENGTH ! 11875: JSR SYSRD READ NEXT STANDARD INPUT IMAGE ! 11876: PPM ACS03 JUMP TO FAIL EXIT IF END OF FILE ! 11877: BRN ACS07 ELSE MERGE WITH OTHER FILE CASE ! 11878: * ! 11879: * HERE FOR INPUT FROM OTHER THAN STANDARD INPUT FILE ! 11880: * ! 11881: ACS06 MOV XL,WA FCBLK PTR ! 11882: JSR SYSIL GET INPUT RECORD MAX LENGTH (TO WA) ! 11883: JSR ALOCS ALLOCATE STRING OF CORRECT SIZE ! 11884: MOV XL,WA FCBLK PTR ! 11885: JSR SYSIN CALL SYSTEM INPUT ROUTINE ! 11886: PPM ACS03 JUMP TO FAIL EXIT IF END OF FILE ! 11887: PPM ACS22 ERROR ! 11888: PPM ACS23 ERROR ! 11889: EJC ! 11890: * ! 11891: * ACESS (CONTINUED) ! 11892: * ! 11893: * MERGE HERE AFTER OBTAINING INPUT RECORD ! 11894: * ! 11895: ACS07 MOV KVTRM,WB LOAD TRIM INDICATOR ! 11896: JSR TRIMR TRIM RECORD AS REQUIRED ! 11897: MOV XR,WB COPY RESULT POINTER ! 11898: MOV (XS),XR RELOAD POINTER TO TRBLK ! 11899: * ! 11900: * LOOP TO CHASE TO END OF TRBLK CHAIN AND STORE VALUE ! 11901: * ! 11902: ACS08 MOV XR,XL SAVE POINTER TO THIS TRBLK ! 11903: MOV TRNXT(XR),XR LOAD FORWARD POINTER ! 11904: BEQ (XR),=B$TRT,ACS08 LOOP IF THIS IS ANOTHER TRBLK ! 11905: MOV WB,TRNXT(XL) ELSE STORE RESULT AT END OF CHAIN ! 11906: MOV (XS)+,XR RESTORE INITIAL TRBLK POINTER ! 11907: MOV (XS)+,WA RESTORE NAME OFFSET ! 11908: MOV (XS)+,XL RESTORE NAME BASE POINTER ! 11909: * ! 11910: * COME HERE TO MOVE TO NEXT TRBLK ! 11911: * ! 11912: ACS09 MOV TRNXT(XR),XR LOAD FORWARD PTR TO NEXT VALUE ! 11913: BRN ACS02 BACK TO CHECK IF TRAPPED ! 11914: * ! 11915: * HERE TO CHECK FOR ACCESS TRACE TRBLK ! 11916: * ! 11917: ACS10 BNE WB,=TRTAC,ACS09 LOOP BACK IF NOT ACCESS TRACE ! 11918: BZE KVTRA,ACS09 IGNORE ACCESS TRACE IF TRACE OFF ! 11919: DCV KVTRA ELSE DECREMENT TRACE COUNT ! 11920: BZE TRFNC(XR),ACS11 JUMP IF PRINT TRACE ! 11921: EJC ! 11922: * ! 11923: * ACESS (CONTINUED) ! 11924: * ! 11925: * HERE FOR FULL FUNCTION TRACE ! 11926: * ! 11927: JSR TRXEQ CALL ROUTINE TO EXECUTE TRACE ! 11928: BRN ACS09 JUMP FOR NEXT TRBLK ! 11929: * ! 11930: * HERE FOR CASE OF PRINT TRACE ! 11931: * ! 11932: ACS11 JSR PRTSN PRINT STATEMENT NUMBER ! 11933: JSR PRTNV PRINT NAME = VALUE ! 11934: BRN ACS09 JUMP BACK FOR NEXT TRBLK ! 11935: * ! 11936: * HERE FOR KEYWORD VARIABLE ! 11937: * ! 11938: ACS12 MOV KVNUM(XL),XR LOAD KEYWORD NUMBER ! 11939: BGE XR,=K$V$$,ACS14 JUMP IF NOT ONE WORD VALUE ! 11940: MTI KVABE(XR) ELSE LOAD VALUE AS INTEGER ! 11941: * ! 11942: * COMMON EXIT WITH KEYWORD VALUE AS INTEGER IN (IA) ! 11943: * ! 11944: ACS13 JSR ICBLD BUILD ICBLK ! 11945: BRN ACS18 JUMP TO EXIT ! 11946: * ! 11947: * HERE IF NOT ONE WORD KEYWORD VALUE ! 11948: * ! 11949: ACS14 BGE XR,=K$S$$,ACS15 JUMP IF SPECIAL CASE ! 11950: SUB =K$V$$,XR ELSE GET OFFSET ! 11951: ADD =NDABO,XR POINT TO PATTERN VALUE ! 11952: BRN ACS18 JUMP TO EXIT ! 11953: * ! 11954: * HERE IF SPECIAL KEYWORD CASE ! 11955: * ! 11956: ACS15 MOV KVRTN,XL LOAD RTNTYPE IN CASE ! 11957: LDI KVSTL LOAD STLIMIT IN CASE ! 11958: SUB =K$S$$,XR GET CASE NUMBER ! 11959: BSW XR,5 SWITCH ON KEYWORD NUMBER ! 11960: IFF K$$AL,ACS16 JUMP IF ALPHABET ! 11961: IFF K$$RT,ACS17 RTNTYPE ! 11962: IFF K$$SC,ACS19 STCOUNT ! 11963: IFF K$$SL,ACS13 STLIMIT ! 11964: IFF K$$ET,ACS20 ERRTEXT ! 11965: ESW END SWITCH ON KEYWORD NUMBER ! 11966: EJC ! 11967: * ! 11968: * ACESS (CONTINUED) ! 11969: * ! 11970: * ALPHABET ! 11971: * ! 11972: ACS16 MOV KVALP,XL LOAD POINTER TO ALPHABET STRING ! 11973: * ! 11974: * RTNTYPE MERGES HERE ! 11975: * ! 11976: ACS17 MOV XL,XR COPY STRING PTR TO PROPER REG ! 11977: * ! 11978: * COMMON RETURN POINT ! 11979: * ! 11980: ACS18 EXI RETURN TO ACESS CALLER ! 11981: * ! 11982: * HERE FOR STCOUNT (IA HAS STLIMIT) ! 11983: * ! 11984: ACS19 SBI KVSTC STCOUNT = LIMIT - LEFT ! 11985: BRN ACS13 MERGE BACK WITH INTEGER RESULT ! 11986: * ! 11987: * ERRTEXT ! 11988: * ! 11989: ACS20 MOV R$ETX,XR GET ERRTEXT STRING ! 11990: BRN ACS18 MERGE WITH RESULT ! 11991: * ! 11992: * HERE TO READ A RECORD FROM TERMINAL ! 11993: * ! 11994: ACS21 MOV =RILEN,WA BUFFER LENGTH ! 11995: JSR ALOCS ALLOCATE BUFFER ! 11996: JSR SYSRI READ RECORD ! 11997: PPM ACS03 ENDFILE ! 11998: BRN ACS07 MERGE WITH RECORD READ ! 11999: * ! 12000: * ERROR RETURNS ! 12001: * ! 12002: ACS22 MOV XR,DNAMP POP UNUSED SCBLK ! 12003: ERB 202,INPUT FROM FILE CAUSED NON-RECOVERABLE ERROR ! 12004: * ! 12005: ACS23 MOV XR,DNAMP POP UNUSED SCBLK ! 12006: ERB 203,INPUT FILE RECORD HAS INCORRECT FORMAT ! 12007: ENP END PROCEDURE ACESS ! 12008: EJC ! 12009: * ! 12010: * ACOMP -- COMPARE TWO ARITHMETIC VALUES ! 12011: * ! 12012: * 1(XS) FIRST ARGUMENT ! 12013: * 0(XS) SECOND ARGUMENT ! 12014: * JSR ACOMP CALL TO COMPARE VALUES ! 12015: * PPM LOC TRANSFER LOC IF ARG1 IS NON-NUMERIC ! 12016: * PPM LOC TRANSFER LOC IF ARG2 IS NON-NUMERIC ! 12017: * PPM LOC TRANSFER LOC FOR ARG1 LT ARG2 ! 12018: * PPM LOC TRANSFER LOC FOR ARG1 EQ ARG2 ! 12019: * PPM LOC TRANSFER LOC FOR ARG1 GT ARG2 ! 12020: * (NORMAL RETURN IS NEVER GIVEN) ! 12021: * (WA,WB,WC,IA,RA) DESTROYED ! 12022: * (XL,XR) DESTROYED ! 12023: * ! 12024: ACOMP PRC N,5 ENTRY POINT ! 12025: JSR ARITH LOAD ARITHMETIC OPERANDS ! 12026: PPM ACMP7 JUMP IF FIRST ARG NON-NUMERIC ! 12027: PPM ACMP8 JUMP IF SECOND ARG NON-NUMERIC ! 12028: PPM ACMP4 JUMP IF REAL ARGUMENTS ! 12029: * ! 12030: * HERE FOR INTEGER ARGUMENTS ! 12031: * ! 12032: SBI ICVAL(XL) SUBTRACT TO COMPARE ! 12033: IOV ACMP3 JUMP IF OVERFLOW ! 12034: ILT ACMP5 ELSE JUMP IF ARG1 LT ARG2 ! 12035: IEQ ACMP2 JUMP IF ARG1 EQ ARG2 ! 12036: * ! 12037: * HERE IF ARG1 GT ARG2 ! 12038: * ! 12039: ACMP1 EXI 5 TAKE GT EXIT ! 12040: * ! 12041: * HERE IF ARG1 EQ ARG2 ! 12042: * ! 12043: ACMP2 EXI 4 TAKE EQ EXIT ! 12044: EJC ! 12045: * ! 12046: * ACOMP (CONTINUED) ! 12047: * ! 12048: * HERE FOR INTEGER OVERFLOW ON SUBTRACT ! 12049: * ! 12050: ACMP3 LDI ICVAL(XL) LOAD SECOND ARGUMENT ! 12051: ILT ACMP1 GT IF NEGATIVE ! 12052: BRN ACMP5 ELSE LT ! 12053: * ! 12054: * HERE FOR REAL OPERANDS ! 12055: * ! 12056: ACMP4 SBR RCVAL(XL) SUBTRACT TO COMPARE ! 12057: ROV ACMP6 JUMP IF OVERFLOW ! 12058: RGT ACMP1 ELSE JUMP IF ARG1 GT ! 12059: REQ ACMP2 JUMP IF ARG1 EQ ARG2 ! 12060: * ! 12061: * HERE IF ARG1 LT ARG2 ! 12062: * ! 12063: ACMP5 EXI 3 TAKE LT EXIT ! 12064: * ! 12065: * HERE IF OVERFLOW ON REAL SUBTRACTION ! 12066: * ! 12067: ACMP6 LDR RCVAL(XL) RELOAD ARG2 ! 12068: RLT ACMP1 GT IF NEGATIVE ! 12069: BRN ACMP5 ELSE LT ! 12070: * ! 12071: * HERE IF ARG1 NON-NUMERIC ! 12072: * ! 12073: ACMP7 EXI 1 TAKE ERROR EXIT ! 12074: * ! 12075: * HERE IF ARG2 NON-NUMERIC ! 12076: * ! 12077: ACMP8 EXI 2 TAKE ERROR EXIT ! 12078: ENP END PROCEDURE ACOMP ! 12079: EJC ! 12080: * ! 12081: * ALLOC ALLOCATE BLOCK OF DYNAMIC STORAGE ! 12082: * ! 12083: * (WA) LENGTH REQUIRED IN BYTES ! 12084: * JSR ALLOC CALL TO ALLOCATE BLOCK ! 12085: * (XR) POINTER TO ALLOCATED BLOCK ! 12086: * ! 12087: * A POSSIBLE ALTERNATIVE TO AOV .. AND FOLLOWING STMT IS - ! 12088: * MOV DNAME,XR . SUB WA,XR . BLO XR,DNAMP,ALOC2 . ! 12089: * MOV DNAMP,XR . ADD WA,XR ! 12090: * ! 12091: ALLOC PRC E,0 ENTRY POINT ! 12092: * ! 12093: * COMMON EXIT POINT ! 12094: * ! 12095: ALOC1 MOV DNAMP,XR POINT TO NEXT AVAILABLE LOC ! 12096: AOV WA,XR,ALOC2 POINT PAST ALLOCATED BLOCK ! 12097: BGT XR,DNAME,ALOC2 JUMP IF NOT ENOUGH ROOM ! 12098: MOV XR,DNAMP STORE NEW POINTER ! 12099: SUB WA,XR POINT BACK TO START OF ALLOCATED BK ! 12100: EXI RETURN TO CALLER ! 12101: * ! 12102: * HERE IF INSUFFICIENT ROOM, TRY A GARBAGE COLLECTION ! 12103: * ! 12104: ALOC2 MOV WB,ALLSV SAVE WB ! 12105: ZER WB SET NO UPWARD MOVE FOR GBCOL ! 12106: JSR GBCOL GARBAGE COLLECT ! 12107: * ! 12108: * SEE IF ROOM AFTER GBCOL OR SYSMM CALL ! 12109: * ! 12110: ALOC3 MOV DNAMP,XR POINT TO FIRST AVAILABLE LOC ! 12111: AOV WA,XR,ALC3A POINT PAST NEW BLOCK ! 12112: BLO XR,DNAME,ALOC4 JUMP IF THERE IS ROOM NOW ! 12113: * ! 12114: * FAILED AGAIN, SEE IF WE CAN GET MORE CORE ! 12115: * ! 12116: ALC3A JSR SYSMM TRY TO GET MORE MEMORY ! 12117: WTB XR CONVERT TO BAUS (SGD05) ! 12118: ADD XR,DNAME BUMP PTR BY AMOUNT OBTAINED ! 12119: BNZ XR,ALOC3 JUMP IF GOT MORE CORE ! 12120: ADD RSMEM,DNAME GET THE RESERVE MEMORY ! 12121: ZER RSMEM ONLY PERMISSIBLE ONCE ! 12122: ICV ERRFT FATAL ERROR ! 12123: ERB 204,MEMORY OVERFLOW ! 12124: EJC ! 12125: * ! 12126: * HERE AFTER SUCCESSFUL GARBAGE COLLECTION ! 12127: * ! 12128: ALOC4 STI ALLIA SAVE IA ! 12129: MOV DNAME,WB GET DYNAMIC END ADRS ! 12130: SUB DNAMP,WB COMPUTE FREE STORE ! 12131: BTW WB CONVERT BYTES TO WORDS ! 12132: MTI WB PUT FREE STORE IN IA ! 12133: MLI ALFSF MULTIPLY BY FREE STORE FACTOR ! 12134: IOV ALOC5 JUMP IF OVERFLOWED ! 12135: MOV DNAME,WB DYNAMIC END ADRS ! 12136: SUB DNAMB,WB COMPUTE TOTAL AMOUNT OF DYNAMIC ! 12137: BTW WB CONVERT TO WORDS ! 12138: MOV WB,ALDYN STORE IT ! 12139: SBI ALDYN SUBTRACT FROM SCALED UP FREE STORE ! 12140: IGT ALOC5 JUMP IF SUFFICIENT FREE STORE ! 12141: JSR SYSMM TRY TO GET MORE STORE ! 12142: WTB XR CONVERT TO BAUS (SGD05) ! 12143: ADD XR,DNAME ADJUST DYNAMIC END ADRS ! 12144: * ! 12145: * MERGE TO RESTORE IA AND WB ! 12146: * ! 12147: ALOC5 LDI ALLIA RECOVER IA ! 12148: MOV ALLSV,WB RESTORE WB ! 12149: BRN ALOC1 JUMP BACK TO EXIT ! 12150: ENP END PROCEDURE ALLOC ! 12151: EJC ! 12152: * ! 12153: * ALOBF -- ALLOCATE BUFFER ! 12154: * ! 12155: * THIS ROUTINES ALLOCATES A NEW BUFFER. AS THE BFBLK ! 12156: * AND BCBLK COME IN PAIRS, BOTH ARE ALLOCATED HERE, ! 12157: * AND XR POINTS TO THE BCBLK ON RETURN. THE BFBLK ! 12158: * AND BCBLK ARE SET TO THE NULL BUFFER, AND THE IDVAL ! 12159: * IS ZERO ON RETURN. ! 12160: * ! 12161: * (WA) BUFFER SIZE IN CHARACTERS ! 12162: * JSR ALOBF CALL TO CREATE BUFFER ! 12163: * (XR) BCBLK PTR ! 12164: * (WA,WB) DESTROYED ! 12165: * ! 12166: ALOBF PRC E,0 ENTRY POINT ! 12167: MOV WA,WB HANG ONTO ALLOCATION SIZE ! 12168: CTB WA,BFSI$ GET TOTAL BLOCK SIZE ! 12169: BGE WA,MXLEN,ALB01 CHECK FOR MAXLEN EXCEEDED ! 12170: ADD *BCSI$,WA ADD IN ALLOCATION FOR BCBLK ! 12171: JSR ALLOC ALLOCATE FRAME ! 12172: MOV =B$BCT,(XR) SET TYPE ! 12173: ZER IDVAL(XR) NO ID YET ! 12174: ZER BCLEN(XR) NO DEFINED LENGTH ! 12175: MOV XL,WA SAVE XL ! 12176: MOV XR,XL COPY BCBLK PTR ! 12177: ADD *BCSI$,XL BIAS PAST PARTIALLY BUILT BCBLK ! 12178: MOV =B$BFT,(XL) SET BFBLK TYPE WORD ! 12179: MOV WB,BFALC(XL) SET ALLOCATED SIZE ! 12180: MOV XL,BCBUF(XR) SET POINTER IN BCBLK ! 12181: ZER BFCHR(XL) CLEAR FIRST WORD (NULL PAD) ! 12182: MOV WA,XL RESTORE ENTRY XL ! 12183: EXI RETURN TO CALLER ! 12184: * ! 12185: * HERE FOR MXLEN EXCEEDED ! 12186: * ! 12187: ALB01 ERB 274,REQUESTED BUFFER ALLOCATION EXCEEDS MXLEN ! 12188: ENP END PROCEDURE ALOBF ! 12189: EJC ! 12190: * ! 12191: * ALOCS -- ALLOCATE STRING BLOCK ! 12192: * ! 12193: * ALOCS IS USED TO BUILD A FRAME FOR A STRING BLOCK INTO ! 12194: * WHICH THE ACTUAL CHARACTERS ARE PLACED BY THE CALLER. ! 12195: * ALL STRINGS ARE CREATED WITH A CALL TO ALOCS (THE ! 12196: * EXCEPTIONS OCCUR IN TRIMR AND S$RPL PROCEDURES). ! 12197: * ! 12198: * (WA) LENGTH OF STRING TO BE ALLOCATED ! 12199: * JSR ALOCS CALL TO ALLOCATE SCBLK ! 12200: * (XR) POINTER TO RESULTING SCBLK ! 12201: * (WA) DESTROYED ! 12202: * (WC) CHARACTER COUNT (ENTRY VALUE OF WA) ! 12203: * ! 12204: * THE RESULTING SCBLK HAS THE TYPE WORD AND THE LENGTH ! 12205: * FILLED IN AND THE LAST WORD IS CLEARED TO ZERO CHARACTERS ! 12206: * TO ENSURE CORRECT RIGHT PADDING OF THE FINAL WORD. ! 12207: * ! 12208: ALOCS PRC E,0 ENTRY POINT ! 12209: BGT WA,KVMXL,ALCS2 JUMP IF LENGTH EXCEEEDS MAXLENGTH ! 12210: MOV WA,WC ELSE COPY LENGTH ! 12211: CTB WA,SCSI$ COMPUTE LENGTH OF SCBLK IN BYTES ! 12212: MOV DNAMP,XR POINT TO NEXT AVAILABLE LOCATION ! 12213: AOV WA,XR,ALCS0 POINT PAST BLOCK ! 12214: BLO XR,DNAME,ALCS1 JUMP IF THERE IS ROOM ! 12215: * ! 12216: * INSUFFICIENT MEMORY ! 12217: * ! 12218: ALCS0 ZER XR ELSE CLEAR GARBAGE XR VALUE ! 12219: JSR ALLOC AND USE STANDARD ALLOCATOR ! 12220: ADD WA,XR POINT PAST END OF BLOCK TO MERGE ! 12221: * ! 12222: * MERGE HERE WITH XR POINTING BEYOND NEW BLOCK ! 12223: * ! 12224: ALCS1 MOV XR,DNAMP SET UPDATED STORAGE POINTER ! 12225: ZER -(XR) STORE ZERO CHARS IN LAST WORD ! 12226: DCA WA DECREMENT LENGTH ! 12227: SUB WA,XR POINT BACK TO START OF BLOCK ! 12228: MOV =B$SCL,(XR) SET TYPE WORD ! 12229: MOV WC,SCLEN(XR) STORE LENGTH IN CHARS ! 12230: EXI RETURN TO ALOCS CALLER ! 12231: * ! 12232: * COME HERE IF STRING IS TOO LONG ! 12233: * ! 12234: ALCS2 ERB 205,STRING LENGTH EXCEEDS VALUE OF MAXLNGTH KEYWORD ! 12235: ENP END PROCEDURE ALOCS ! 12236: EJC ! 12237: * ! 12238: * ALOST -- ALLOCATE SPACE IN STATIC REGION ! 12239: * ! 12240: * (WA) LENGTH REQUIRED IN BYTES ! 12241: * JSR ALOST CALL TO ALLOCATE SPACE ! 12242: * (XR) POINTER TO ALLOCATED BLOCK ! 12243: * (WB) DESTROYED ! 12244: * ! 12245: * NOTE THAT THE CODING ENSURES THAT THE RESULTING VALUE ! 12246: * OF STATE IS ALWAYS LESS THAN DNAMB. THIS FACT IS USED ! 12247: * IN TESTING A VARIABLE NAME FOR BEING IN THE STATIC REGION ! 12248: * ! 12249: ALOST PRC E,0 ENTRY POINT ! 12250: * ! 12251: * MERGE BACK HERE AFTER ALLOCATING NEW CHUNK ! 12252: * ! 12253: ALST1 MOV STATE,XR POINT TO CURRENT END OF AREA ! 12254: AOV WA,XR,ALST2 POINT BEYOND PROPOSED BLOCK ! 12255: BGE XR,DNAMB,ALST2 JUMP IF OVERLAP WITH DYNAMIC AREA ! 12256: MOV XR,STATE ELSE STORE NEW POINTER ! 12257: SUB WA,XR POINT BACK TO START OF BLOCK ! 12258: EXI RETURN TO ALOST CALLER ! 12259: * ! 12260: * HERE IF NO ROOM, PREPARE TO MOVE DYNAMIC STORAGE UP ! 12261: * ! 12262: ALST2 MOV WA,ALSTA SAVE WA ! 12263: BGE WA,*E$STS,ALST3 SKIP IF REQUESTED CHUNK IS LARGE ! 12264: MOV *E$STS,WA ELSE SET TO GET LARGE ENOUGH CHUNK ! 12265: * ! 12266: * HERE WITH AMOUNT TO MOVE UP IN WA ! 12267: * ! 12268: ALST3 JSR ALLOC ALLOCATE BLOCK TO ENSURE ROOM ! 12269: MOV XR,DNAMP AND DELETE IT ! 12270: MOV WA,WB COPY MOVE UP AMOUNT ! 12271: JSR GBCOL CALL GBCOL TO MOVE DYNAMIC AREA UP ! 12272: MOV ALSTA,WA RESTORE WA ! 12273: BRN ALST1 LOOP BACK TO TRY AGAIN ! 12274: ENP END PROCEDURE ALOST ! 12275: EJC ! 12276: * ! 12277: * APNDB -- APPEND STRING TO BUFFER ! 12278: * ! 12279: * THIS ROUTINE IS USED BY BUFFER HANDLING ROUTINES TO ! 12280: * APPEND DATA TO AN EXISTING BFBLK. ! 12281: * ! 12282: * (XR) EXISTING BCBLK TO BE APPENDED ! 12283: * (XL) CONVERTABLE TO STRING ! 12284: * JSR APNDB CALL TO APPEND TO BUFFER ! 12285: * PPM LOC THREAD IF (XL) CANT BE CONVERTED ! 12286: * PPM LOC IF NOT ENOUGH ROOM ! 12287: * (WA,WB) DESTROYED ! 12288: * ! 12289: * IF MORE CHARACTERS ARE SPECIFIED THAN CAN BE INSERTED, ! 12290: * THEN NO ACTION IS TAKEN AND THE SECOND RETURN IS TAKEN. ! 12291: * ! 12292: APNDB PRC E,2 ENTRY POINT ! 12293: MOV BCLEN(XR),WA LOAD OFFSET TO INSERT ! 12294: ZER WB REPLACE SECTION IS NULL ! 12295: JSR INSBF CALL TO INSERT AT END ! 12296: PPM APN01 CONVERT ERROR ! 12297: PPM APN02 NO ROOM ! 12298: EXI RETURN TO CALLER ! 12299: * ! 12300: * HERE TO TAKE CONVERT FAILURE EXIT ! 12301: * ! 12302: APN01 EXI 1 RETURN TO CALLER ALTERNATE ! 12303: * ! 12304: * HERE FOR NO FIT EXIT ! 12305: * ! 12306: APN02 EXI 2 ALTERNATE EXIT TO CALLER ! 12307: ENP END PROCEDURE APNDB ! 12308: EJC ! 12309: * ! 12310: * ARITH -- FETCH ARITHMETIC OPERANDS ! 12311: * ! 12312: * ARITH IS USED BY FUNCTIONS AND OPERATORS WHICH EXPECT ! 12313: * TWO NUMERIC ARGUMENTS (OPERANDS) WHICH MUST BOTH BE ! 12314: * INTEGER OR BOTH BE REAL. ARITH FETCHES TWO ARGUMENTS FROM ! 12315: * THE STACK AND PERFORMS ANY NECESSARY CONVERSIONS. ! 12316: * ! 12317: * 1(XS) FIRST ARGUMENT (LEFT OPERAND) ! 12318: * 0(XS) SECOND ARGUMENT (RIGHT OPERAND) ! 12319: * JSR ARITH CALL TO FETCH NUMERIC ARGUMENTS ! 12320: * PPM LOC TRANSFER LOC FOR OPND 1 NON-NUMERIC ! 12321: * PPM LOC TRANSFER LOC FOR OPND 2 NON-NUMERIC ! 12322: * PPM LOC TRANSFER LOC FOR REAL OPERANDS ! 12323: * ! 12324: * FOR INTEGER ARGS, CONTROL RETURNS PAST THE PARAMETERS ! 12325: * ! 12326: * (IA) LEFT OPERAND VALUE ! 12327: * (XR) PTR TO ICBLK FOR LEFT OPERAND ! 12328: * (XL) PTR TO ICBLK FOR RIGHT OPERAND ! 12329: * (XS) POPPED TWICE ! 12330: * (WA,WB,RA) DESTROYED ! 12331: * ! 12332: * FOR REAL ARGUMENTS, CONTROL RETURNS TO THE LOCATION ! 12333: * SPECIFIED BY THE THIRD PARAMETER. ! 12334: * ! 12335: * (RA) LEFT OPERAND VALUE ! 12336: * (XR) PTR TO RCBLK FOR LEFT OPERAND ! 12337: * (XL) PTR TO RCBLK FOR RIGHT OPERAND ! 12338: * (WA,WB,WC) DESTROYED ! 12339: * (XS) POPPED TWICE ! 12340: EJC ! 12341: * ! 12342: * ARITH (CONTINUED) ! 12343: * ! 12344: * ENTRY POINT ! 12345: * ! 12346: ARITH PRC N,3 ENTRY POINT ! 12347: MOV (XS)+,XL LOAD RIGHT OPERAND ! 12348: MOV (XS)+,XR LOAD LEFT OPERAND ! 12349: MOV (XL),WA GET RIGHT OPERAND TYPE WORD ! 12350: BEQ WA,=B$ICL,ARTH1 JUMP IF INTEGER ! 12351: BEQ WA,=B$RCL,ARTH4 JUMP IF REAL ! 12352: MOV XR,-(XS) ELSE REPLACE LEFT ARG ON STACK ! 12353: MOV XL,XR COPY LEFT ARG POINTER ! 12354: JSR GTNUM CONVERT TO NUMERIC ! 12355: PPM ARTH6 JUMP IF UNCONVERTIBLE ! 12356: MOV XR,XL ELSE COPY CONVERTED RESULT ! 12357: MOV (XL),WA GET RIGHT OPERAND TYPE WORD ! 12358: MOV (XS)+,XR RELOAD LEFT ARGUMENT ! 12359: BEQ WA,=B$RCL,ARTH4 JUMP IF RIGHT ARG IS REAL ! 12360: * ! 12361: * HERE IF RIGHT ARG IS AN INTEGER ! 12362: * ! 12363: ARTH1 BNE (XR),=B$ICL,ARTH3 JUMP IF LEFT ARG NOT INTEGER ! 12364: * ! 12365: * EXIT FOR INTEGER CASE ! 12366: * ! 12367: ARTH2 LDI ICVAL(XR) LOAD LEFT OPERAND VALUE ! 12368: EXI RETURN TO ARITH CALLER ! 12369: * ! 12370: * HERE FOR RIGHT OPERAND INTEGER, LEFT OPERAND NOT ! 12371: * ! 12372: ARTH3 JSR GTNUM CONVERT LEFT ARG TO NUMERIC ! 12373: PPM ARTH7 JUMP IF NOT CONVERTIBLE ! 12374: BEQ WA,=B$ICL,ARTH2 JUMP BACK IF INTEGER-INTEGER ! 12375: * ! 12376: * HERE WE MUST CONVERT REAL-INTEGER TO REAL-REAL ! 12377: * ! 12378: MOV XR,-(XS) PUT LEFT ARG BACK ON STACK ! 12379: LDI ICVAL(XL) LOAD RIGHT ARGUMENT VALUE ! 12380: ITR CONVERT TO REAL ! 12381: JSR RCBLD GET REAL BLOCK FOR RIGHT ARG, MERGE ! 12382: MOV XR,XL COPY RIGHT ARG PTR ! 12383: MOV (XS)+,XR LOAD LEFT ARGUMENT ! 12384: BRN ARTH5 MERGE FOR REAL-REAL CASE ! 12385: EJC ! 12386: * ! 12387: * ARITH (CONTINUED) ! 12388: * ! 12389: * HERE IF RIGHT ARGUMENT IS REAL ! 12390: * ! 12391: ARTH4 BEQ (XR),=B$RCL,ARTH5 JUMP IF LEFT ARG REAL ! 12392: JSR GTREA ELSE CONVERT TO REAL ! 12393: PPM ARTH7 ERROR IF UNCONVERTIBLE ! 12394: * ! 12395: * HERE FOR REAL-REAL ! 12396: * ! 12397: ARTH5 LDR RCVAL(XR) LOAD LEFT OPERAND VALUE ! 12398: EXI 3 TAKE REAL-REAL EXIT ! 12399: * ! 12400: * HERE FOR ERROR CONVERTING RIGHT ARGUMENT ! 12401: * ! 12402: ARTH6 ICA XS POP UNWANTED LEFT ARG ! 12403: EXI 2 TAKE APPROPRIATE ERROR EXIT ! 12404: * ! 12405: * HERE FOR ERROR CONVERTING LEFT OPERAND ! 12406: * ! 12407: ARTH7 EXI 1 TAKE APPROPRIATE ERROR RETURN ! 12408: ENP END PROCEDURE ARITH ! 12409: EJC ! 12410: * ! 12411: * ASIGN -- PERFORM ASSIGNMENT ! 12412: * ! 12413: * ASIGN PERFORMS THE ASSIGNMENT OF A VALUE TO A VARIABLE ! 12414: * WITH APPROPRIATE CHECKS FOR OUTPUT ASSOCIATIONS AND ! 12415: * VALUE TRACE ASSOCIATIONS WHICH ARE EXECUTED AS REQUIRED. ! 12416: * ASIGN ALSO HANDLES THE SPECIAL CASES OF ASSIGNMENT TO ! 12417: * PATTERN AND EXPRESSION VARIABLES. ! 12418: * ! 12419: * (WB) VALUE TO BE ASSIGNED ! 12420: * (XL) BASE POINTER FOR VARIABLE ! 12421: * (WA) OFFSET FOR VARIABLE ! 12422: * JSR ASIGN CALL TO ASSIGN VALUE TO VARIABLE ! 12423: * PPM LOC TRANSFER LOC FOR FAILURE ! 12424: * (XR,XL,WA,WB,WC) DESTROYED ! 12425: * (RA) DESTROYED ! 12426: * ! 12427: * FAILURE OCCURS IF THE EVALUATION OF AN EXPRESSION ! 12428: * ASSOCIATED WITH AN EXPRESSION VARIABLE FAILS. ! 12429: * ! 12430: ASIGN PRC R,1 ENTRY POINT (RECURSIVE) ! 12431: * ! 12432: * MERGE BACK HERE TO ASSIGN RESULT TO EXPRESSION VARIABLE. ! 12433: * ! 12434: ASG01 ADD WA,XL POINT TO VARIABLE VALUE ! 12435: MOV (XL),XR LOAD VARIABLE VALUE ! 12436: BEQ (XR),=B$TRT,ASG02 JUMP IF TRAPPED ! 12437: MOV WB,(XL) ELSE PERFORM ASSIGNMENT ! 12438: ZER XL CLEAR GARBAGE VALUE IN XL ! 12439: EXI AND RETURN TO ASIGN CALLER ! 12440: * ! 12441: * HERE IF VALUE IS TRAPPED ! 12442: * ! 12443: ASG02 SUB WA,XL RESTORE NAME BASE ! 12444: BEQ XR,=TRBKV,ASG14 JUMP IF KEYWORD VARIABLE ! 12445: BNE XR,=TRBEV,ASG04 JUMP IF NOT EXPRESSION VARIABLE ! 12446: * ! 12447: * HERE FOR ASSIGNMENT TO EXPRESSION VARIABLE ! 12448: * ! 12449: MOV EVEXP(XL),XR POINT TO EXPRESSION ! 12450: MOV WB,-(XS) STORE VALUE TO ASSIGN ON STACK ! 12451: MOV =NUM01,WB SET FOR EVALUATION BY NAME ! 12452: JSR EVALX EVALUATE EXPRESSION BY NAME ! 12453: PPM ASG03 JUMP IF EVALUATION FAILS ! 12454: MOV (XS)+,WB ELSE RELOAD VALUE TO ASSIGN ! 12455: BRN ASG01 LOOP BACK TO PERFORM ASSIGNMENT ! 12456: EJC ! 12457: * ! 12458: * ASIGN (CONTINUED) ! 12459: * ! 12460: * HERE FOR FAILURE DURING EXPRESSION EVALUATION ! 12461: * ! 12462: ASG03 ICA XS REMOVE STACKED VALUE ENTRY ! 12463: EXI 1 TAKE FAILURE EXIT ! 12464: * ! 12465: * HERE IF NOT KEYWORD OR EXPRESSION VARIABLE ! 12466: * ! 12467: ASG04 MOV XR,-(XS) SAVE PTR TO FIRST TRBLK ! 12468: * ! 12469: * LOOP TO CHASE DOWN TRBLK CHAIN AND ASSIGN VALUE AT END ! 12470: * ! 12471: ASG05 MOV XR,WC SAVE PTR TO THIS TRBLK ! 12472: MOV TRNXT(XR),XR POINT TO NEXT TRBLK ! 12473: BEQ (XR),=B$TRT,ASG05 LOOP BACK IF ANOTHER TRBLK ! 12474: MOV WC,XR ELSE POINT BACK TO LAST TRBLK ! 12475: MOV WB,TRVAL(XR) STORE VALUE AT END OF CHAIN ! 12476: MOV (XS)+,XR RESTORE PTR TO FIRST TRBLK ! 12477: * ! 12478: * LOOP TO PROCESS TRBLK ENTRIES ON CHAIN ! 12479: * ! 12480: ASG06 MOV TRTYP(XR),WB LOAD TYPE CODE OF TRBLK ! 12481: BEQ WB,=TRTVL,ASG08 JUMP IF VALUE TRACE ! 12482: BEQ WB,=TRTOU,ASG10 JUMP IF OUTPUT ASSOCIATION ! 12483: * ! 12484: * HERE TO MOVE TO NEXT TRBLK ON CHAIN ! 12485: * ! 12486: ASG07 MOV TRNXT(XR),XR POINT TO NEXT TRBLK ON CHAIN ! 12487: BEQ (XR),=B$TRT,ASG06 LOOP BACK IF ANOTHER TRBLK ! 12488: EXI ELSE END OF CHAIN, RETURN TO CALLER ! 12489: * ! 12490: * HERE TO PROCESS VALUE TRACE ! 12491: * ! 12492: ASG08 BZE KVTRA,ASG07 IGNORE VALUE TRACE IF TRACE OFF ! 12493: DCV KVTRA ELSE DECREMENT TRACE COUNT ! 12494: BZE TRFNC(XR),ASG09 JUMP IF PRINT TRACE ! 12495: JSR TRXEQ ELSE EXECUTE FUNCTION TRACE ! 12496: BRN ASG07 AND LOOP BACK ! 12497: EJC ! 12498: * ! 12499: * ASIGN (CONTINUED) ! 12500: * ! 12501: * HERE FOR PRINT TRACE ! 12502: * ! 12503: ASG09 JSR PRTSN PRINT STATEMENT NUMBER ! 12504: JSR PRTNV PRINT NAME = VALUE ! 12505: BRN ASG07 LOOP BACK FOR NEXT TRBLK ! 12506: * ! 12507: * HERE FOR OUTPUT ASSOCIATION ! 12508: * ! 12509: ASG10 BZE KVOUP,ASG07 IGNORE OUTPUT ASSOC IF OUTPUT OFF ! 12510: MOV XR,XL ELSE COPY TRBLK POINTER ! 12511: MOV TRVAL(WC),-(XS) STACK VALUE TO OUTPUT (SGD01) ! 12512: JSR GTSTG CONVERT TO STRING ! 12513: PPM ASG12 GET DATATYPE NAME IF UNCONVERTIBLE ! 12514: * ! 12515: * MERGE WITH STRING FOR OUTPUT ! 12516: * ! 12517: ASG11 MOV TRFPT(XL),WA FCBLK PTR ! 12518: BZE WA,ASG13 JUMP IF STANDARD OUTPUT FILE ! 12519: * ! 12520: * HERE FOR OUTPUT TO NON-STANDARD OUTPUT FILE ! 12521: * ! 12522: JSR SYSOU CALL SYSTEM OUTPUT ROUTINE ! 12523: ERR 206,OUTPUT CAUSED FILE OVERFLOW ! 12524: ERR 207,OUTPUT CAUSED NON-RECOVERABLE ERROR ! 12525: EXI ELSE ALL DONE, RETURN TO CALLER ! 12526: * ! 12527: * IF NOT PRINTABLE, GET DATATYPE NAME INSTEAD ! 12528: * ! 12529: ASG12 JSR DTYPE CALL DATATYPE ROUTINE ! 12530: BRN ASG11 MERGE ! 12531: * ! 12532: * HERE TO PRINT A STRING ON THE PRINTER ! 12533: * ! 12534: ASG13 JSR PRTST PRINT STRING VALUE ! 12535: BEQ TRTER(XL),=V$TER,ASG20 JUMP IF TERMINAL OUTPUT ! 12536: JSR PRTNL END OF LINE ! 12537: EXI RETURN TO CALLER ! 12538: EJC ! 12539: * ! 12540: * ASIGN (CONTINUED) ! 12541: * ! 12542: * HERE FOR KEYWORD ASSIGNMENT ! 12543: * ! 12544: ASG14 MOV KVNUM(XL),XL LOAD KEYWORD NUMBER ! 12545: BEQ XL,=K$ETX,ASG19 JUMP IF ERRTEXT ! 12546: MOV WB,XR COPY VALUE TO BE ASSIGNED ! 12547: JSR GTINT CONVERT TO INTEGER ! 12548: ERR 208,KEYWORD VALUE ASSIGNED IS NOT INTEGER ! 12549: LDI ICVAL(XR) ELSE LOAD VALUE ! 12550: BEQ XL,=K$STL,ASG16 JUMP IF SPECIAL CASE OF STLIMIT ! 12551: MFI WA,ASG18 ELSE GET ADDR INTEGER, TEST OVFLOW ! 12552: BGE WA,MXLEN,ASG18 FAIL IF TOO LARGE ! 12553: BEQ XL,=K$ERT,ASG17 JUMP IF SPECIAL CASE OF ERRTYPE ! 12554: BEQ XL,=K$PFL,ASG21 JUMP IF SPECIAL CASE OF PROFILE ! 12555: BLT XL,=K$P$$,ASG15 JUMP UNLESS PROTECTED ! 12556: ERB 209,KEYWORD IN ASSIGNMENT IS PROTECTED ! 12557: * ! 12558: * HERE TO DO ASSIGNMENT IF NOT PROTECTED ! 12559: * ! 12560: ASG15 MOV WA,KVABE(XL) STORE NEW VALUE ! 12561: EXI RETURN TO ASIGN CALLER ! 12562: * ! 12563: * HERE FOR SPECIAL CASE OF STLIMIT ! 12564: * ! 12565: * SINCE STCOUNT IS MAINTAINED AS (STLIMIT-STCOUNT) ! 12566: * IT IS ALSO NECESSARY TO MODIFY STCOUNT APPROPRIATELY. ! 12567: * ! 12568: ASG16 SBI KVSTL SUBTRACT OLD LIMIT ! 12569: ADI KVSTC ADD OLD COUNTER ! 12570: STI KVSTC STORE NEW COUNTER VALUE ! 12571: LDI ICVAL(XR) RELOAD NEW LIMIT VALUE ! 12572: STI KVSTL STORE NEW LIMIT VALUE ! 12573: EXI RETURN TO ASIGN CALLER ! 12574: * ! 12575: * HERE FOR SPECIAL CASE OF ERRTYPE ! 12576: * ! 12577: ASG17 BLE WA,=NINI9,ERROR OK TO SIGNAL IF IN RANGE ! 12578: * ! 12579: * HERE IF VALUE ASSIGNED IS OUT OF RANGE ! 12580: * ! 12581: ASG18 ERB 210,KEYWORD VALUE ASSIGNED IS NEGATIVE OR TOO LARGE ! 12582: * ! 12583: * HERE FOR SPECIAL CASE OF ERRTEXT ! 12584: * ! 12585: ASG19 MOV WB,-(XS) STACK VALUE ! 12586: JSR GTSTG CONVERT TO STRING ! 12587: ERR 211,VALUE ASSIGNED TO KEYWORD ERRTEXT NOT A STRING ! 12588: MOV XR,R$ETX MAKE ASSIGNMENT ! 12589: EXI RETURN TO CALLER ! 12590: * ! 12591: * PRINT STRING TO TERMINAL ! 12592: * ! 12593: ASG20 JSR PRTTR PRINT ! 12594: EXI RETURN ! 12595: * ! 12596: * HERE FOR KEYWORD PROFILE ! 12597: * ! 12598: ASG21 BGT WA,=NUM02,ASG18 MOAN IF NOT 0,1, OR 2 ! 12599: BZE WA,ASG15 JUST ASSIGN IF ZERO ! 12600: BZE PFDMP,ASG22 BRANCH IF FIRST ASSIGNMENT ! 12601: BEQ WA,PFDMP,ASG23 ALSO IF SAME VALUE AS BEFORE ! 12602: ERB 268,INCONSISTENT VALUE ASSIGNED TO KEYWORD PROFILE ! 12603: * ! 12604: ASG22 MOV WA,PFDMP NOTE VALUE ON FIRST ASSIGNMENT ! 12605: ASG23 JSR SYSTM GET THE TIME ! 12606: STI PFSTM FUDGE SOME KIND OF START TIME ! 12607: BRN ASG15 AND GO ASSIGN ! 12608: ENP END PROCEDURE ASIGN ! 12609: EJC ! 12610: * ! 12611: * ASINP -- ASSIGN DURING PATTERN MATCH ! 12612: * ! 12613: * ASINP IS LIKE ASIGN AND HAS A SIMILAR CALLING SEQUENCE ! 12614: * AND EFFECT. THE DIFFERENCE IS THAT THE GLOBAL PATTERN ! 12615: * VARIABLES ARE SAVED AND RESTORED IF REQUIRED. ! 12616: * ! 12617: * (XL) BASE POINTER FOR VARIABLE ! 12618: * (WA) OFFSET FOR VARIABLE ! 12619: * (WB) VALUE TO BE ASSIGNED ! 12620: * JSR ASINP CALL TO ASSIGN VALUE TO VARIABLE ! 12621: * PPM LOC TRANSFER LOC IF FAILURE ! 12622: * (XR,XL) DESTROYED ! 12623: * (WA,WB,WC,RA) DESTROYED ! 12624: * ! 12625: ASINP PRC R,1 ENTRY POINT, RECURSIVE ! 12626: ADD WA,XL POINT TO VARIABLE ! 12627: MOV (XL),XR LOAD CURRENT CONTENTS ! 12628: BEQ (XR),=B$TRT,ASNP1 JUMP IF TRAPPED ! 12629: MOV WB,(XL) ELSE PERFORM ASSIGNMENT ! 12630: ZER XL CLEAR GARBAGE VALUE IN XL ! 12631: EXI RETURN TO ASINP CALLER ! 12632: * ! 12633: * HERE IF VARIABLE IS TRAPPED ! 12634: * ! 12635: ASNP1 SUB WA,XL RESTORE BASE POINTER ! 12636: MOV PMSSL,-(XS) STACK SUBJECT STRING LENGTH ! 12637: MOV PMHBS,-(XS) STACK HISTORY STACK BASE PTR ! 12638: MOV R$PMS,-(XS) STACK SUBJECT STRING POINTER ! 12639: MOV PMDFL,-(XS) STACK DOT FLAG ! 12640: JSR ASIGN CALL FULL-BLOWN ASSIGNMENT ROUTINE ! 12641: PPM ASNP2 JUMP IF FAILURE ! 12642: MOV (XS)+,PMDFL RESTORE DOT FLAG ! 12643: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER ! 12644: MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER ! 12645: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH ! 12646: EXI RETURN TO ASINP CALLER ! 12647: * ! 12648: * HERE IF FAILURE IN ASIGN CALL ! 12649: * ! 12650: ASNP2 MOV (XS)+,PMDFL RESTORE DOT FLAG ! 12651: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER ! 12652: MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER ! 12653: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH ! 12654: EXI 1 TAKE FAILURE EXIT ! 12655: ENP END PROCEDURE ASINP ! 12656: EJC ! 12657: * ! 12658: * BLKLN -- DETERMINE LENGTH OF BLOCK ! 12659: * ! 12660: * BLKLN DETERMINES THE LENGTH OF A BLOCK IN DYNAMIC STORE. ! 12661: * ! 12662: * (WA) FIRST WORD OF BLOCK ! 12663: * (XR) POINTER TO BLOCK ! 12664: * JSR BLKLN CALL TO GET BLOCK LENGTH ! 12665: * (WA) LENGTH OF BLOCK IN BYTES ! 12666: * (XL) DESTROYED ! 12667: * ! 12668: * BLKLN IS USED BY THE GARBAGE COLLECTOR AND IS NOT ! 12669: * PERMITTED TO CALL GBCOL DIRECTLY OR INDIRECTLY. ! 12670: * ! 12671: * THE FIRST WORD STORED IN THE BLOCK (I.E. AT XR) MAY ! 12672: * BE ANYTHING, BUT THE CONTENTS OF WA MUST BE CORRECT. ! 12673: * ! 12674: BLKLN PRC E,0 ENTRY POINT ! 12675: MOV WA,XL COPY FIRST WORD ! 12676: LEI XL GET ENTRY ID (BL$XX) ! 12677: BSW XL,BL$$$,BLN00 SWITCH ON BLOCK TYPE ! 12678: IFF BL$AR,BLN01 ARBLK ! 12679: IFF BL$BC,BLN04 BCBLK ! 12680: IFF BL$BF,BLN11 BFBLK ! 12681: IFF BL$CD,BLN01 CDBLK ! 12682: IFF BL$DF,BLN01 DFBLK ! 12683: IFF BL$EF,BLN01 EFBLK ! 12684: IFF BL$EX,BLN01 EXBLK ! 12685: IFF BL$PF,BLN01 PFBLK ! 12686: IFF BL$TB,BLN01 TBBLK ! 12687: IFF BL$VC,BLN01 VCBLK ! 12688: IFF BL$EV,BLN03 EVBLK ! 12689: IFF BL$KV,BLN03 KVBLK ! 12690: IFF BL$P0,BLN02 P0BLK ! 12691: IFF BL$SE,BLN02 SEBLK ! 12692: IFF BL$NM,BLN03 NMBLK ! 12693: IFF BL$P1,BLN03 P1BLK ! 12694: IFF BL$P2,BLN04 P2BLK ! 12695: IFF BL$TE,BLN04 TEBLK ! 12696: IFF BL$FF,BLN05 FFBLK ! 12697: IFF BL$TR,BLN05 TRBLK ! 12698: IFF BL$CT,BLN06 CTBLK ! 12699: IFF BL$IC,BLN07 ICBLK ! 12700: IFF BL$PD,BLN08 PDBLK ! 12701: IFF BL$RC,BLN09 RCBLK ! 12702: IFF BL$SC,BLN10 SCBLK ! 12703: ESW END OF JUMP TABLE ON BLOCK TYPE ! 12704: EJC ! 12705: * ! 12706: * BLKLN (CONTINUED) ! 12707: * ! 12708: * HERE FOR BLOCKS WITH LENGTH IN SECOND WORD ! 12709: * ! 12710: BLN00 MOV 1(XR),WA LOAD LENGTH ! 12711: EXI RETURN TO BLKLN CALLER ! 12712: * ! 12713: * HERE FOR LENGTH IN THIRD WORD (AR,CD,DF,EF,EX,PF,TB,VC) ! 12714: * ! 12715: BLN01 MOV 2(XR),WA LOAD LENGTH FROM THIRD WORD ! 12716: EXI RETURN TO BLKLN CALLER ! 12717: * ! 12718: * HERE FOR TWO WORD BLOCKS (P0,SE) ! 12719: * ! 12720: BLN02 MOV *NUM02,WA LOAD LENGTH (TWO WORDS) ! 12721: EXI RETURN TO BLKLN CALLER ! 12722: * ! 12723: * HERE FOR THREE WORD BLOCKS (NM,P1,EV,KV) ! 12724: * ! 12725: BLN03 MOV *NUM03,WA LOAD LENGTH (THREE WORDS) ! 12726: EXI RETURN TO BLKLN CALLER ! 12727: * ! 12728: * HERE FOR FOUR WORD BLOCKS (P2,TE,BC) ! 12729: * ! 12730: BLN04 MOV *NUM04,WA LOAD LENGTH (FOUR WORDS) ! 12731: EXI RETURN TO BLKLN CALLER ! 12732: * ! 12733: * HERE FOR FIVE WORD BLOCKS (FF,TR) ! 12734: * ! 12735: BLN05 MOV *NUM05,WA LOAD LENGTH ! 12736: EXI RETURN TO BLKLN CALLER ! 12737: EJC ! 12738: * ! 12739: * BLKLN (CONTINUED) ! 12740: * ! 12741: * HERE FOR CTBLK ! 12742: * ! 12743: BLN06 MOV *CTSI$,WA SET SIZE OF CTBLK ! 12744: EXI RETURN TO BLKLN CALLER ! 12745: * ! 12746: * HERE FOR ICBLK ! 12747: * ! 12748: BLN07 MOV *ICSI$,WA SET SIZE OF ICBLK ! 12749: EXI RETURN TO BLKLN CALLER ! 12750: * ! 12751: * HERE FOR PDBLK ! 12752: * ! 12753: BLN08 MOV PDDFP(XR),XL POINT TO DFBLK ! 12754: MOV DFPDL(XL),WA LOAD PDBLK LENGTH FROM DFBLK ! 12755: EXI RETURN TO BLKLN CALLER ! 12756: * ! 12757: * HERE FOR RCBLK ! 12758: * ! 12759: BLN09 MOV *RCSI$,WA SET SIZE OF RCBLK ! 12760: EXI RETURN TO BLKLN CALLER ! 12761: * ! 12762: * HERE FOR SCBLK ! 12763: * ! 12764: BLN10 MOV SCLEN(XR),WA LOAD LENGTH IN CHARACTERS ! 12765: CTB WA,SCSI$ CALCULATE LENGTH IN BYTES ! 12766: EXI RETURN TO BLKLN CALLER ! 12767: * ! 12768: * HERE FOR BFBLK ! 12769: * ! 12770: BLN11 MOV BFALC(XR),WA GET ALLOCATION IN BYTES ! 12771: CTB WA,BFSI$ CALCULATE LENGTH IN BYTES ! 12772: EXI RETURN TO BLKLN CALLER ! 12773: ENP END PROCEDURE BLKLN ! 12774: EJC ! 12775: * ! 12776: * COPYB -- COPY A BLOCK ! 12777: * ! 12778: * (XS) BLOCK TO BE COPIED ! 12779: * JSR COPYB CALL TO COPY BLOCK ! 12780: * PPM LOC RETURN IF BLOCK HAS NO IDVAL FIELD ! 12781: * NORMAL RETURN IF IDVAL FIELD ! 12782: * (XR) COPY OF BLOCK ! 12783: * (XS) POPPED ! 12784: * (XL,WA,WB,WC) DESTROYED ! 12785: * ! 12786: COPYB PRC N,1 ENTRY POINT ! 12787: MOV (XS),XR LOAD ARGUMENT ! 12788: BEQ XR,=NULLS,COP10 RETURN ARGUMENT IF IT IS NULL ! 12789: MOV (XR),WA ELSE LOAD TYPE WORD ! 12790: MOV WA,WB COPY TYPE WORD ! 12791: JSR BLKLN GET LENGTH OF ARGUMENT BLOCK ! 12792: MOV XR,XL COPY POINTER ! 12793: JSR ALLOC ALLOCATE BLOCK OF SAME SIZE ! 12794: MOV XR,(XS) STORE POINTER TO COPY ! 12795: MVW COPY CONTENTS OF OLD BLOCK TO NEW ! 12796: MOV (XS),XR RELOAD POINTER TO START OF COPY ! 12797: BEQ WB,=B$TBT,COP05 JUMP IF TABLE ! 12798: BEQ WB,=B$VCT,COP01 JUMP IF VECTOR ! 12799: BEQ WB,=B$PDT,COP01 JUMP IF PROGRAM DEFINED ! 12800: BEQ WB,=B$BCT,COP11 JUMP IF BUFFER ! 12801: BNE WB,=B$ART,COP10 RETURN COPY IF NOT ARRAY ! 12802: * ! 12803: * HERE FOR ARRAY (ARBLK) ! 12804: * ! 12805: ADD AROFS(XR),XR POINT TO PROTOTYPE FIELD ! 12806: BRN COP02 JUMP TO MERGE ! 12807: * ! 12808: * HERE FOR VECTOR, PROGRAM DEFINED ! 12809: * ! 12810: COP01 ADD *PDFLD,XR POINT TO PDFLD = VCVLS ! 12811: * ! 12812: * MERGE HERE FOR ARBLK, VCBLK, PDBLK TO DELETE TRAP ! 12813: * BLOCKS FROM ALL VALUE FIELDS (THE COPY IS UNTRAPPED) ! 12814: * ! 12815: COP02 MOV (XR),XL LOAD NEXT POINTER ! 12816: * ! 12817: * LOOP TO GET VALUE AT END OF TRBLK CHAIN ! 12818: * ! 12819: COP03 BNE (XL),=B$TRT,COP04 JUMP IF NOT TRAPPED ! 12820: MOV TRVAL(XL),XL ELSE POINT TO NEXT VALUE ! 12821: BRN COP03 AND LOOP BACK ! 12822: EJC ! 12823: * ! 12824: * COPYB (CONTINUED) ! 12825: * ! 12826: * HERE WITH UNTRAPPED VALUE IN XL ! 12827: * ! 12828: COP04 MOV XL,(XR)+ STORE REAL VALUE, BUMP POINTER ! 12829: BNE XR,DNAMP,COP02 LOOP BACK IF MORE TO GO ! 12830: BRN COP09 ELSE JUMP TO EXIT ! 12831: * ! 12832: * HERE TO COPY A TABLE ! 12833: * ! 12834: COP05 ZER IDVAL(XR) ZERO ID TO STOP DUMP BLOWING UP ! 12835: MOV *TESI$,WA SET SIZE OF TEBLK ! 12836: MOV *TBBUK,WC SET INITIAL OFFSET ! 12837: * ! 12838: * LOOP THROUGH BUCKETS IN TABLE ! 12839: * ! 12840: COP06 MOV (XS),XR LOAD TABLE POINTER ! 12841: BEQ WC,TBLEN(XR),COP09 JUMP TO EXIT IF ALL DONE ! 12842: ADD WC,XR ELSE POINT TO NEXT BUCKET HEADER ! 12843: ICA WC BUMP OFFSET ! 12844: SUB *TENXT,XR SUBTRACT LINK OFFSET TO MERGE ! 12845: * ! 12846: * LOOP THROUGH TEBLKS ON ONE CHAIN ! 12847: * ! 12848: COP07 MOV TENXT(XR),XL LOAD POINTER TO NEXT TEBLK ! 12849: MOV (XS),TENXT(XR) SET END OF CHAIN POINTER IN CASE ! 12850: BEQ (XL),=B$TBT,COP06 BACK FOR NEXT BUCKET IF CHAIN END ! 12851: MOV XR,-(XS) ELSE STACK PTR TO PREVIOUS BLOCK ! 12852: MOV *TESI$,WA SET SIZE OF TEBLK ! 12853: JSR ALLOC ALLOCATE NEW TEBLK ! 12854: MOV XR,WB SAVE PTR TO NEW TEBLK ! 12855: MVW COPY OLD TEBLK TO NEW TEBLK ! 12856: MOV WB,XR RESTORE POINTER TO NEW TEBLK ! 12857: MOV (XS)+,XL RESTORE POINTER TO PREVIOUS BLOCK ! 12858: MOV XR,TENXT(XL) LINK NEW BLOCK TO PREVIOUS ! 12859: MOV XR,XL COPY POINTER TO NEW BLOCK ! 12860: * ! 12861: * LOOP TO SET REAL VALUE AFTER REMOVING TRAP CHAIN ! 12862: * ! 12863: COP08 MOV TEVAL(XL),XL LOAD VALUE ! 12864: BEQ (XL),=B$TRT,COP08 LOOP BACK IF TRAPPED ! 12865: MOV XL,TEVAL(XR) STORE UNTRAPPED VALUE IN TEBLK ! 12866: BRN COP07 BACK FOR NEXT TEBLK ! 12867: * ! 12868: * COMMON EXIT POINT ! 12869: * ! 12870: COP09 MOV (XS)+,XR LOAD POINTER TO BLOCK ! 12871: EXI RETURN ! 12872: * ! 12873: * ALTERNATIVE RETURN ! 12874: * ! 12875: COP10 EXI 1 RETURN ! 12876: EJC ! 12877: * ! 12878: * HERE TO COPY BUFFER ! 12879: * ! 12880: COP11 MOV BCBUF(XR),XL GET BFBLK PTR ! 12881: MOV BFALC(XL),WA GET ALLOCATION ! 12882: CTB WA,BFSI$ SET TOTAL SIZE ! 12883: MOV XR,XL SAVE BCBLK PTR ! 12884: JSR ALLOC ALLOCATE BFBLK ! 12885: MOV BCBUF(XL),WB GET OLD BFBLK ! 12886: MOV XR,BCBUF(XL) SET POINTER TO NEW BFBLK ! 12887: MOV WB,XL POINT TO OLD BFBLK ! 12888: MVW COPY BFBLK TOO ! 12889: ZER XL CLEAR RUBBISH PTR ! 12890: BRN COP09 BRANCH TO EXIT ! 12891: ENP END PROCEDURE COPYB ! 12892: * ! 12893: * CDGCG -- GENERATE CODE FOR COMPLEX GOTO ! 12894: * ! 12895: * USED BY CMPIL TO PROCESS COMPLEX GOTO TREE ! 12896: * ! 12897: * (WB) MUST BE COLLECTABLE ! 12898: * (XR) EXPRESSION POINTER ! 12899: * JSR CDGCG CALL TO GENERATE COMPLEX GOTO ! 12900: * (XL,XR,WA) DESTROYED ! 12901: * ! 12902: CDGCG PRC E,0 ENTRY POINT ! 12903: MOV CMOPN(XR),XL GET UNARY GOTO OPERATOR ! 12904: MOV CMROP(XR),XR POINT TO GOTO OPERAND ! 12905: BEQ XL,=OPDVD,CDGC2 JUMP IF DIRECT GOTO ! 12906: JSR CDGNM GENERATE OPND BY NAME IF NOT DIRECT ! 12907: * ! 12908: * RETURN POINT ! 12909: * ! 12910: CDGC1 MOV XL,WA GOTO OPERATOR ! 12911: JSR CDWRD GENERATE IT ! 12912: EXI RETURN TO CALLER ! 12913: * ! 12914: * DIRECT GOTO ! 12915: * ! 12916: CDGC2 JSR CDGVL GENERATE OPERAND BY VALUE ! 12917: BRN CDGC1 MERGE TO RETURN ! 12918: ENP END PROCEDURE CDGCG ! 12919: EJC ! 12920: * ! 12921: * CDGEX -- BUILD EXPRESSION BLOCK ! 12922: * ! 12923: * CDGEX IS PASSED A POINTER TO AN EXPRESSION TREE (SEE ! 12924: * EXPAN) AND RETURNS AN EXPRESSION (SEBLK OR EXBLK). ! 12925: * ! 12926: * (WC) SOME COLLECTABLE VALUE ! 12927: * (WB) INTEGER IN RANGE 0 LE X LE MXLEN ! 12928: * (XL) PTR TO EXPRESSION TREE ! 12929: * JSR CDGEX CALL TO BUILD EXPRESSION ! 12930: * (XR) PTR TO SEBLK OR EXBLK ! 12931: * (XL,WA,WB) DESTROYED ! 12932: * ! 12933: CDGEX PRC R,0 ENTRY POINT, RECURSIVE ! 12934: BLO (XL),=B$VR$,CDGX1 JUMP IF NOT VARIABLE ! 12935: * ! 12936: * HERE FOR NATURAL VARIABLE, BUILD SEBLK ! 12937: * ! 12938: MOV *SESI$,WA SET SIZE OF SEBLK ! 12939: JSR ALLOC ALLOCATE SPACE FOR SEBLK ! 12940: MOV =B$SEL,(XR) SET TYPE WORD ! 12941: MOV XL,SEVAR(XR) STORE VRBLK POINTER ! 12942: EXI RETURN TO CDGEX CALLER ! 12943: * ! 12944: * HERE IF NOT VARIABLE, BUILD EXBLK ! 12945: * ! 12946: CDGX1 MOV XL,XR COPY TREE POINTER ! 12947: MOV WC,-(XS) SAVE WC ! 12948: MOV CWCOF,XL SAVE CURRENT OFFSET ! 12949: MOV (XR),WA GET TYPE WORD ! 12950: BNE WA,=B$CMT,CDGX2 CALL BY VALUE IF NOT CMBLK ! 12951: BGE CMTYP(XR),=C$$NM,CDGX2 JUMP IF CMBLK ONLY BY VALUE ! 12952: EJC ! 12953: * ! 12954: * CDGEX (CONTINUED) ! 12955: * ! 12956: * HERE IF EXPRESSION CAN BE EVALUATED BY NAME ! 12957: * ! 12958: JSR CDGNM GENERATE CODE BY NAME ! 12959: MOV =ORNM$,WA LOAD RETURN BY NAME WORD ! 12960: BRN CDGX3 MERGE WITH VALUE CASE ! 12961: * ! 12962: * HERE IF EXPRESSION CAN ONLY BE EVALUATED BY VALUE ! 12963: * ! 12964: CDGX2 JSR CDGVL GENERATE CODE BY VALUE ! 12965: MOV =ORVL$,WA LOAD RETURN BY VALUE WORD ! 12966: * ! 12967: * MERGE HERE TO CONSTRUCT EXBLK ! 12968: * ! 12969: CDGX3 JSR CDWRD GENERATE RETURN WORD ! 12970: JSR EXBLD BUILD EXBLK ! 12971: MOV (XS)+,WC RESTORE WC ! 12972: EXI RETURN TO CDGEX CALLER ! 12973: ENP END PROCEDURE CDGEX ! 12974: EJC ! 12975: * ! 12976: * CDGNM -- GENERATE CODE BY NAME ! 12977: * ! 12978: * CDGNM IS CALLED DURING THE COMPILATION PROCESS TO ! 12979: * GENERATE CODE BY NAME FOR AN EXPRESSION. SEE CDBLK ! 12980: * DESCRIPTION FOR DETAILS OF CODE GENERATED. THE INPUT ! 12981: * TO CDGNM IS AN EXPRESSION TREE AS GENERATED BY EXPAN. ! 12982: * ! 12983: * CDGNM IS A RECURSIVE PROCEDURE WHICH PROCEEDS BY MAKING ! 12984: * RECURSIVE CALLS TO GENERATE CODE FOR OPERANDS. ! 12985: * ! 12986: * (WB) INTEGER IN RANGE 0 LE N LE DNAMB ! 12987: * (XR) PTR TO TREE GENERATED BY EXPAN ! 12988: * (WC) CONSTANT FLAG (SEE BELOW) ! 12989: * JSR CDGNM CALL TO GENERATE CODE BY NAME ! 12990: * (XR,WA) DESTROYED ! 12991: * (WC) SET NON-ZERO IF NON-CONSTANT ! 12992: * ! 12993: * WC IS SET TO A NON-ZERO (COLLECTABLE) VALUE IF THE ! 12994: * EXPRESSION FOR WHICH CODE IS GENERATED CANNOT BE ! 12995: * EVALUATED AT COMPILE TIME, OTHERWISE WC IS UNCHANGED. ! 12996: * ! 12997: * THE CODE IS GENERATED IN THE CURRENT CCBLK (SEE CDWRD). ! 12998: * ! 12999: CDGNM PRC R,0 ENTRY POINT, RECURSIVE ! 13000: MOV XL,-(XS) SAVE ENTRY XL ! 13001: MOV WB,-(XS) SAVE ENTRY WB ! 13002: CHK CHECK FOR STACK OVERFLOW ! 13003: MOV (XR),WA LOAD TYPE WORD ! 13004: BEQ WA,=B$CMT,CGN04 JUMP IF CMBLK ! 13005: BHI WA,=B$VR$,CGN02 JUMP IF SIMPLE VARIABLE ! 13006: * ! 13007: * MERGE HERE FOR OPERAND YIELDING VALUE (E.G. CONSTANT) ! 13008: * ! 13009: CGN01 ERB 212,SYNTAX ERROR. VALUE USED WHERE NAME IS REQUIRED ! 13010: * ! 13011: * HERE FOR NATURAL VARIABLE REFERENCE ! 13012: * ! 13013: CGN02 MOV =OLVN$,WA LOAD VARIABLE LOAD CALL ! 13014: JSR CDWRD GENERATE IT ! 13015: MOV XR,WA COPY VRBLK POINTER ! 13016: JSR CDWRD GENERATE VRBLK POINTER ! 13017: EJC ! 13018: * ! 13019: * CDGNM (CONTINUED) ! 13020: * ! 13021: * HERE TO EXIT WITH WC SET CORRECTLY ! 13022: * ! 13023: CGN03 MOV (XS)+,WB RESTORE ENTRY WB ! 13024: MOV (XS)+,XL RESTORE ENTRY XL ! 13025: EXI RETURN TO CDGNM CALLER ! 13026: * ! 13027: * HERE FOR CMBLK ! 13028: * ! 13029: CGN04 MOV XR,XL COPY CMBLK POINTER ! 13030: MOV CMTYP(XR),XR LOAD CMBLK TYPE ! 13031: BGE XR,=C$$NM,CGN01 ERROR IF NOT NAME OPERAND ! 13032: BSW XR,C$$NM ELSE SWITCH ON TYPE ! 13033: IFF C$ARR,CGN05 ARRAY REFERENCE ! 13034: IFF C$FNC,CGN08 FUNCTION CALL ! 13035: IFF C$DEF,CGN09 DEFERRED EXPRESSION ! 13036: IFF C$IND,CGN10 INDIRECT REFERENCE ! 13037: IFF C$KEY,CGN11 KEYWORD REFERENCE ! 13038: IFF C$UBO,CGN08 UNDEFINED BINARY OP ! 13039: IFF C$UUO,CGN08 UNDEFINED UNARY OP ! 13040: ESW END SWITCH ON CMBLK TYPE ! 13041: * ! 13042: * HERE TO GENERATE CODE FOR ARRAY REFERENCE ! 13043: * ! 13044: CGN05 MOV *CMOPN,WB POINT TO ARRAY OPERAND ! 13045: * ! 13046: * LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS ! 13047: * ! 13048: CGN06 JSR CMGEN GENERATE CODE FOR NEXT OPERAND ! 13049: MOV CMLEN(XL),WC LOAD LENGTH OF CMBLK ! 13050: BLT WB,WC,CGN06 LOOP TILL ALL GENERATED ! 13051: * ! 13052: * GENERATE APPROPRIATE ARRAY CALL ! 13053: * ! 13054: MOV =OAON$,WA LOAD ONE-SUBSCRIPT CASE CALL ! 13055: BEQ WC,*CMAR1,CGN07 JUMP TO EXIT IF ONE SUBSCRIPT CASE ! 13056: MOV =OAMN$,WA ELSE LOAD MULTI-SUBSCRIPT CASE CALL ! 13057: JSR CDWRD GENERATE CALL ! 13058: MOV WC,WA COPY CMBLK LENGTH ! 13059: BTW WA CONVERT TO WORDS ! 13060: SUB =CMVLS,WA CALCULATE NUMBER OF SUBSCRIPTS ! 13061: EJC ! 13062: * ! 13063: * CDGNM (CONTINUED) ! 13064: * ! 13065: * HERE TO EXIT GENERATING WORD (NON-CONSTANT) ! 13066: * ! 13067: CGN07 MNZ WC SET RESULT NON-CONSTANT ! 13068: JSR CDWRD GENERATE WORD ! 13069: BRN CGN03 BACK TO EXIT ! 13070: * ! 13071: * HERE TO GENERATE CODE FOR FUNCTIONS AND UNDEFINED OPRS ! 13072: * ! 13073: CGN08 MOV XL,XR COPY CMBLK POINTER ! 13074: JSR CDGVL GEN CODE BY VALUE FOR CALL ! 13075: MOV =OFNE$,WA GET EXTRA CALL FOR BY NAME ! 13076: BRN CGN07 BACK TO GENERATE AND EXIT ! 13077: * ! 13078: * HERE TO GENERATE CODE FOR DEFERED EXPRESSION ! 13079: * ! 13080: CGN09 MOV CMROP(XL),XR CHECK IF VARIABLE ! 13081: BHI (XR),=B$VR$,CGN02 TREAT *VARIABLE AS SIMPLE VAR ! 13082: MOV XR,XL COPY PTR TO EXPRESSION TREE ! 13083: JSR CDGEX ELSE BUILD EXBLK ! 13084: MOV =OLEX$,WA SET CALL TO LOAD EXPR BY NAME ! 13085: JSR CDWRD GENERATE IT ! 13086: MOV XR,WA COPY EXBLK POINTER ! 13087: JSR CDWRD GENERATE EXBLK POINTER ! 13088: BRN CGN03 BACK TO EXIT ! 13089: * ! 13090: * HERE TO GENERATE CODE FOR INDIRECT REFERENCE ! 13091: * ! 13092: CGN10 MOV CMROP(XL),XR GET OPERAND ! 13093: JSR CDGVL GENERATE CODE BY VALUE FOR IT ! 13094: MOV =OINN$,WA LOAD CALL FOR INDIRECT BY NAME ! 13095: BRN CGN12 MERGE ! 13096: * ! 13097: * HERE TO GENERATE CODE FOR KEYWORD REFERENCE ! 13098: * ! 13099: CGN11 MOV CMROP(XL),XR GET OPERAND ! 13100: JSR CDGNM GENERATE CODE BY NAME FOR IT ! 13101: MOV =OKWN$,WA LOAD CALL FOR KEYWORD BY NAME ! 13102: * ! 13103: * KEYWORD, INDIRECT MERGE HERE ! 13104: * ! 13105: CGN12 JSR CDWRD GENERATE CODE FOR OPERATOR ! 13106: BRN CGN03 EXIT ! 13107: ENP END PROCEDURE CDGNM ! 13108: EJC ! 13109: * ! 13110: * CDGVL -- GENERATE CODE BY VALUE ! 13111: * ! 13112: * CDGVL IS CALLED DURING THE COMPILATION PROCESS TO ! 13113: * GENERATE CODE BY VALUE FOR AN EXPRESSION. SEE CDBLK ! 13114: * DESCRIPTION FOR DETAILS OF THE CODE GENERATED. THE INPUT ! 13115: * TO CDGVL IS AN EXPRESSION TREE AS GENERATED BY EXPAN. ! 13116: * ! 13117: * CDGVL IS A RECURSIVE PROCEDURE WHICH PROCEEDS BY MAKING ! 13118: * RECURSIVE CALLS TO GENERATE CODE FOR OPERANDS. ! 13119: * ! 13120: * (WB) INTEGER IN RANGE 0 LE N LE DNAMB ! 13121: * (XR) PTR TO TREE GENERATED BY EXPAN ! 13122: * (WC) CONSTANT FLAG (SEE BELOW) ! 13123: * JSR CDGVL CALL TO GENERATE CODE BY VALUE ! 13124: * (XR,WA) DESTROYED ! 13125: * (WC) SET NON-ZERO IF NON-CONSTANT ! 13126: * ! 13127: * WC IS SET TO A NON-ZERO (COLLECTABLE) VALUE IF THE ! 13128: * EXPRESSION FOR WHICH CODE IS GENERATED CANNOT BE ! 13129: * EVALUATED AT COMPILE TIME, OTHERWISE WC IS UNCHANGED. ! 13130: * ! 13131: * IF WC IS NON-ZERO ON ENTRY, THEN PREEVALUATION IS NOT ! 13132: * ALLOWED REGARDLESS OF THE NATURE OF THE OPERAND. ! 13133: * ! 13134: * THE CODE IS GENERATED IN THE CURRENT CCBLK (SEE CDWRD). ! 13135: * ! 13136: CDGVL PRC R,0 ENTRY POINT, RECURSIVE ! 13137: MOV (XR),WA LOAD TYPE WORD ! 13138: BEQ WA,=B$CMT,CGV01 JUMP IF CMBLK ! 13139: BLT WA,=B$VRA,CGV00 JUMP IF ICBLK, RCBLK, SCBLK ! 13140: BNZ VRLEN(XR),CGVL0 JUMP IF NOT SYSTEM VARIABLE ! 13141: MOV XR,-(XS) STACK XR ! 13142: MOV VRSVP(XR),XR POINT TO SVBLK ! 13143: MOV SVBIT(XR),WA GET SVBLK PROPERTY BITS ! 13144: MOV (XS)+,XR RECOVER XR ! 13145: ANB BTCKW,WA CHECK IF CONSTANT KEYWORD ! 13146: NZB WA,CGV00 JUMP IF CONSTANT KEYWORD ! 13147: * ! 13148: * HERE FOR VARIABLE VALUE REFERENCE ! 13149: * ! 13150: CGVL0 MNZ WC INDICATE NON-CONSTANT VALUE ! 13151: * ! 13152: * MERGE HERE FOR SIMPLE CONSTANT (ICBLK,RCBLK,SCBLK) ! 13153: * AND FOR VARIABLES CORRESPONDING TO CONSTANT KEYWORDS. ! 13154: * ! 13155: CGV00 MOV XR,WA COPY PTR TO VAR OR CONSTANT ! 13156: JSR CDWRD GENERATE AS CODE WORD ! 13157: EXI RETURN TO CALLER ! 13158: EJC ! 13159: * ! 13160: * CDGVL (CONTINUED) ! 13161: * ! 13162: * HERE FOR TREE NODE (CMBLK) ! 13163: * ! 13164: CGV01 MOV WB,-(XS) SAVE ENTRY WB ! 13165: MOV XL,-(XS) SAVE ENTRY XL ! 13166: MOV WC,-(XS) SAVE ENTRY CONSTANT FLAG ! 13167: MOV CWCOF,-(XS) SAVE INITIAL CODE OFFSET ! 13168: CHK CHECK FOR STACK OVERFLOW ! 13169: * ! 13170: * PREPARE TO GENERATE CODE FOR CMBLK. WC IS SET TO THE ! 13171: * VALUE OF CSWNO (ZERO IF -OPTIMISE, 1 IF -NOOPT) TO ! 13172: * START WITH AND IS RESET NON-ZERO FOR ANY NON-CONSTANT ! 13173: * CODE GENERATED. IF IT IS STILL ZERO AFTER GENERATING ALL ! 13174: * THE CMBLK CODE, THEN ITS VALUE IS COMPUTED AS THE RESULT. ! 13175: * ! 13176: MOV XR,XL COPY CMBLK POINTER ! 13177: MOV CMTYP(XR),XR LOAD CMBLK TYPE ! 13178: MOV CSWNO,WC RESET CONSTANT FLAG ! 13179: BLE XR,=C$PR$,CGV02 JUMP IF NOT PREDICATE VALUE ! 13180: MNZ WC ELSE FORCE NON-CONSTANT CASE ! 13181: * ! 13182: * HERE WITH WC SET APPROPRIATELY ! 13183: * ! 13184: CGV02 BSW XR,C$$NV SWITCH TO APPROPRIATE GENERATOR ! 13185: IFF C$ARR,CGV03 ARRAY REFERENCE ! 13186: IFF C$FNC,CGV05 FUNCTION CALL ! 13187: IFF C$DEF,CGV14 DEFERRED EXPRESSION ! 13188: IFF C$SEL,CGV15 SELECTION ! 13189: IFF C$IND,CGV31 INDIRECT REFERENCE ! 13190: IFF C$KEY,CGV27 KEYWORD REFERENCE ! 13191: IFF C$UBO,CGV29 UNDEFINED BINOP ! 13192: IFF C$UUO,CGV30 UNDEFINED UNOP ! 13193: IFF C$BVL,CGV18 BINOPS WITH VAL OPDS ! 13194: IFF C$ALT,CGV18 ALTERNATION ! 13195: IFF C$UVL,CGV19 UNOPS WITH VALU OPND ! 13196: IFF C$ASS,CGV21 ASSIGNMENT ! 13197: IFF C$CNC,CGV24 CONCATENATION ! 13198: IFF C$CNP,CGV24 CONCATENATION (NOT PATTERN MATCH) ! 13199: IFF C$UNM,CGV27 UNOPS WITH NAME OPND ! 13200: IFF C$BVN,CGV26 BINARY $ AND . ! 13201: IFF C$INT,CGV31 INTERROGATION ! 13202: IFF C$NEG,CGV28 NEGATION ! 13203: IFF C$PMT,CGV18 PATTERN MATCH ! 13204: ESW END SWITCH ON CMBLK TYPE ! 13205: EJC ! 13206: * ! 13207: * CDGVL (CONTINUED) ! 13208: * ! 13209: * HERE TO GENERATE CODE FOR ARRAY REFERENCE ! 13210: * ! 13211: CGV03 MOV *CMOPN,WB SET OFFSET TO ARRAY OPERAND ! 13212: * ! 13213: * LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS ! 13214: * ! 13215: CGV04 JSR CMGEN GEN VALUE CODE FOR NEXT OPERAND ! 13216: MOV CMLEN(XL),WC LOAD CMBLK LENGTH ! 13217: BLT WB,WC,CGV04 LOOP BACK IF MORE TO GO ! 13218: * ! 13219: * GENERATE CALL TO APPROPRIATE ARRAY REFERENCE ROUTINE ! 13220: * ! 13221: MOV =OAOV$,WA SET ONE SUBSCRIPT CALL IN CASE ! 13222: BEQ WC,*CMAR1,CGV32 JUMP TO EXIT IF 1-SUB CASE ! 13223: MOV =OAMV$,WA ELSE SET CALL FOR MULTI-SUBSCRIPTS ! 13224: JSR CDWRD GENERATE CALL ! 13225: MOV WC,WA COPY LENGTH OF CMBLK ! 13226: SUB *CMVLS,WA SUBTRACT STANDARD LENGTH ! 13227: BTW WA GET NUMBER OF WORDS ! 13228: BRN CGV32 JUMP TO GENERATE SUBSCRIPT COUNT ! 13229: * ! 13230: * HERE TO GENERATE CODE FOR FUNCTION CALL ! 13231: * ! 13232: CGV05 MOV *CMVLS,WB SET OFFSET TO FIRST ARGUMENT ! 13233: * ! 13234: * LOOP TO GENERATE CODE FOR ARGUMENTS ! 13235: * ! 13236: CGV06 BEQ WB,CMLEN(XL),CGV07 JUMP IF ALL GENERATED ! 13237: JSR CMGEN ELSE GEN VALUE CODE FOR NEXT ARG ! 13238: BRN CGV06 BACK TO GENERATE NEXT ARGUMENT ! 13239: * ! 13240: * HERE TO GENERATE ACTUAL FUNCTION CALL ! 13241: * ! 13242: CGV07 SUB *CMVLS,WB GET NUMBER OF ARG PTRS (BYTES) ! 13243: BTW WB CONVERT BYTES TO WORDS ! 13244: MOV CMOPN(XL),XR LOAD FUNCTION VRBLK POINTER ! 13245: BNZ VRLEN(XR),CGV12 JUMP IF NOT SYSTEM FUNCTION ! 13246: MOV VRSVP(XR),XL LOAD SVBLK PTR IF SYSTEM VAR ! 13247: MOV SVBIT(XL),WA LOAD BIT MASK ! 13248: ANB BTFFC,WA TEST FOR FAST FUNCTION CALL ALLOWED ! 13249: ZRB WA,CGV12 JUMP IF NOT ! 13250: EJC ! 13251: * ! 13252: * CDGVL (CONTINUED) ! 13253: * ! 13254: * HERE IF FAST FUNCTION CALL IS ALLOWED ! 13255: * ! 13256: MOV SVBIT(XL),WA RELOAD BIT INDICATORS ! 13257: ANB BTPRE,WA TEST FOR PREEVALUATION OK ! 13258: NZB WA,CGV08 JUMP IF PREEVALUATION PERMITTED ! 13259: MNZ WC ELSE SET RESULT NON-CONSTANT ! 13260: * ! 13261: * TEST FOR CORRECT NUMBER OF ARGS FOR FAST CALL ! 13262: * ! 13263: CGV08 MOV VRFNC(XR),XL LOAD PTR TO SVFNC FIELD ! 13264: MOV FARGS(XL),WA LOAD SVNAR FIELD VALUE ! 13265: BEQ WA,WB,CGV11 JUMP IF ARGUMENT COUNT IS CORRECT ! 13266: BHI WA,WB,CGV09 JUMP IF TOO FEW ARGUMENTS GIVEN ! 13267: * ! 13268: * HERE IF TOO MANY ARGUMENTS, PREPARE TO GENERATE O$POPS ! 13269: * ! 13270: SUB WA,WB GET NUMBER OF EXTRA ARGS ! 13271: LCT WB,WB SET AS COUNT TO CONTROL LOOP ! 13272: MOV =OPOP$,WA SET POP CALL ! 13273: BRN CGV10 JUMP TO COMMON LOOP ! 13274: * ! 13275: * HERE IF TOO FEW ARGUMENTS, PREPARE TO GENERATE NULLS ! 13276: * ! 13277: CGV09 SUB WB,WA GET NUMBER OF MISSING ARGUMENTS ! 13278: LCT WB,WA LOAD AS COUNT TO CONTROL LOOP ! 13279: MOV =NULLS,WA LOAD PTR TO NULL CONSTANT ! 13280: * ! 13281: * LOOP TO GENERATE CALLS TO FIX ARGUMENT COUNT ! 13282: * ! 13283: CGV10 JSR CDWRD GENERATE ONE CALL ! 13284: BCT WB,CGV10 LOOP TILL ALL GENERATED ! 13285: * ! 13286: * HERE AFTER ADJUSTING ARG COUNT AS REQUIRED ! 13287: * ! 13288: CGV11 MOV XL,WA COPY POINTER TO SVFNC FIELD ! 13289: BRN CGV36 JUMP TO GENERATE CALL ! 13290: EJC ! 13291: * ! 13292: * CDGVL (CONTINUED) ! 13293: * ! 13294: * COME HERE IF FAST CALL IS NOT PERMITTED ! 13295: * ! 13296: CGV12 MOV =OFNS$,WA SET ONE ARG CALL IN CASE ! 13297: BEQ WB,=NUM01,CGV13 JUMP IF ONE ARG CASE ! 13298: MOV =OFNC$,WA ELSE LOAD CALL FOR MORE THAN 1 ARG ! 13299: JSR CDWRD GENERATE IT ! 13300: MOV WB,WA COPY ARGUMENT COUNT ! 13301: * ! 13302: * ONE ARG CASE MERGES HERE ! 13303: * ! 13304: CGV13 JSR CDWRD GENERATE =O$FNS OR ARG COUNT ! 13305: MOV XR,WA COPY VRBLK POINTER ! 13306: BRN CGV32 JUMP TO GENERATE VRBLK PTR ! 13307: * ! 13308: * HERE FOR DEFERRED EXPRESSION ! 13309: * ! 13310: CGV14 MOV CMROP(XL),XL POINT TO EXPRESSION TREE ! 13311: JSR CDGEX BUILD EXBLK OR SEBLK ! 13312: MOV XR,WA COPY BLOCK PTR ! 13313: JSR CDWRD GENERATE PTR TO EXBLK OR SEBLK ! 13314: BRN CGV34 JUMP TO EXIT, CONSTANT TEST ! 13315: * ! 13316: * HERE TO GENERATE CODE FOR SELECTION ! 13317: * ! 13318: CGV15 ZER -(XS) ZERO PTR TO CHAIN OF FORWARD JUMPS ! 13319: ZER -(XS) ZERO PTR TO PREV O$SLC FORWARD PTR ! 13320: MOV *CMVLS,WB POINT TO FIRST ALTERNATIVE ! 13321: MOV =OSLA$,WA SET INITIAL CODE WORD ! 13322: * ! 13323: * 0(XS) IS THE OFFSET TO THE PREVIOUS WORD ! 13324: * WHICH REQUIRES FILLING IN WITH AN ! 13325: * OFFSET TO THE FOLLOWING O$SLC,O$SLD ! 13326: * ! 13327: * 1(XS) IS THE HEAD OF A CHAIN OF OFFSET ! 13328: * POINTERS INDICATING THOSE LOCATIONS ! 13329: * TO BE FILLED WITH OFFSETS PAST ! 13330: * THE END OF ALL THE ALTERNATIVES ! 13331: * ! 13332: CGV16 JSR CDWRD GENERATE O$SLC (O$SLA FIRST TIME) ! 13333: MOV CWCOF,(XS) SET CURRENT LOC AS PTR TO FILL IN ! 13334: JSR CDWRD GENERATE GARBAGE WORD THERE FOR NOW ! 13335: JSR CMGEN GEN VALUE CODE FOR ALTERNATIVE ! 13336: MOV =OSLB$,WA LOAD O$SLB POINTER ! 13337: JSR CDWRD GENERATE O$SLB CALL ! 13338: MOV 1(XS),WA LOAD OLD CHAIN PTR ! 13339: MOV CWCOF,1(XS) SET CURRENT LOC AS NEW CHAIN HEAD ! 13340: JSR CDWRD GENERATE FORWARD CHAIN LINK ! 13341: EJC ! 13342: * ! 13343: * CDGVL (CONTINUED) ! 13344: * ! 13345: * NOW TO FILL IN THE SKIP OFFSET TO O$SLC,O$SLD ! 13346: * ! 13347: MOV (XS),XR LOAD OFFSET TO WORD TO PLUG ! 13348: ADD R$CCB,XR POINT TO ACTUAL LOCATION TO PLUG ! 13349: MOV CWCOF,(XR) PLUG PROPER OFFSET IN ! 13350: MOV =OSLC$,WA LOAD O$SLC PTR FOR NEXT ALTERNATIVE ! 13351: MOV WB,XR COPY OFFSET (DESTROY GARBAGE XR) ! 13352: ICA XR BUMP EXTRA TIME FOR TEST ! 13353: BLT XR,CMLEN(XL),CGV16 LOOP BACK IF NOT LAST ALTERNATIVE ! 13354: * ! 13355: * HERE TO GENERATE CODE FOR LAST ALTERNATIVE ! 13356: * ! 13357: MOV =OSLD$,WA GET HEADER CALL ! 13358: JSR CDWRD GENERATE O$SLD CALL ! 13359: JSR CMGEN GENERATE CODE FOR LAST ALTERNATIVE ! 13360: ICA XS POP OFFSET PTR ! 13361: MOV (XS)+,XR LOAD CHAIN PTR ! 13362: * ! 13363: * LOOP TO PLUG OFFSETS PAST STRUCTURE ! 13364: * ! 13365: CGV17 ADD R$CCB,XR MAKE NEXT PTR ABSOLUTE ! 13366: MOV (XR),WA LOAD FORWARD PTR ! 13367: MOV CWCOF,(XR) PLUG REQUIRED OFFSET ! 13368: MOV WA,XR COPY FORWARD PTR ! 13369: BNZ WA,CGV17 LOOP BACK IF MORE TO GO ! 13370: BRN CGV33 ELSE JUMP TO EXIT (NOT CONSTANT) ! 13371: * ! 13372: * HERE FOR BINARY OPS WITH VALUE OPERANDS ! 13373: * ! 13374: CGV18 MOV CMLOP(XL),XR LOAD LEFT OPERAND POINTER ! 13375: JSR CDGVL GEN VALUE CODE FOR LEFT OPERAND ! 13376: * ! 13377: * HERE FOR UNARY OPS WITH VALUE OPERAND (BINOPS MERGE) ! 13378: * ! 13379: CGV19 MOV CMROP(XL),XR LOAD RIGHT (ONLY) OPERAND PTR ! 13380: JSR CDGVL GEN CODE BY VALUE ! 13381: EJC ! 13382: * ! 13383: * CDGVL (CONTINUED) ! 13384: * ! 13385: * MERGE HERE TO GENERATE OPERATOR CALL FROM CMOPN FIELD ! 13386: * ! 13387: CGV20 MOV CMOPN(XL),WA LOAD OPERATOR CALL POINTER ! 13388: BRN CGV36 JUMP TO GENERATE IT WITH CONS TEST ! 13389: * ! 13390: * HERE FOR ASSIGNMENT ! 13391: * ! 13392: CGV21 MOV CMLOP(XL),XR LOAD LEFT OPERAND POINTER ! 13393: BLO (XR),=B$VR$,CGV22 JUMP IF NOT VARIABLE ! 13394: * ! 13395: * HERE FOR ASSIGNMENT TO SIMPLE VARIABLE ! 13396: * ! 13397: MOV CMROP(XL),XR LOAD RIGHT OPERAND PTR ! 13398: JSR CDGVL GENERATE CODE BY VALUE ! 13399: MOV CMLOP(XL),WA RELOAD LEFT OPERAND VRBLK PTR ! 13400: ADD *VRSTO,WA POINT TO VRSTO FIELD ! 13401: BRN CGV32 JUMP TO GENERATE STORE PTR ! 13402: * ! 13403: * HERE IF NOT SIMPLE VARIABLE ASSIGNMENT ! 13404: * ! 13405: CGV22 JSR EXPAP TEST FOR PATTERN MATCH ON LEFT SIDE ! 13406: PPM CGV23 JUMP IF NOT PATTERN MATCH ! 13407: * ! 13408: * HERE FOR PATTERN REPLACEMENT ! 13409: * ! 13410: MOV CMROP(XR),CMLOP(XL) SAVE PATTERN PTR IN SAFE PLACE ! 13411: MOV CMLOP(XR),XR LOAD SUBJECT PTR ! 13412: JSR CDGNM GEN CODE BY NAME FOR SUBJECT ! 13413: MOV CMLOP(XL),XR LOAD PATTERN PTR ! 13414: JSR CDGVL GEN CODE BY VALUE FOR PATTERN ! 13415: MOV =OPMN$,WA LOAD MATCH BY NAME CALL ! 13416: JSR CDWRD GENERATE IT ! 13417: MOV CMROP(XL),XR LOAD REPLACEMENT VALUE PTR ! 13418: JSR CDGVL GEN CODE BY VALUE ! 13419: MOV =ORPL$,WA LOAD REPLACE CALL ! 13420: BRN CGV32 JUMP TO GEN AND EXIT (NOT CONSTANT) ! 13421: * ! 13422: * HERE FOR ASSIGNMENT TO COMPLEX VARIABLE ! 13423: * ! 13424: CGV23 MNZ WC INHIBIT PRE-EVALUATION ! 13425: JSR CDGNM GEN CODE BY NAME FOR LEFT SIDE ! 13426: BRN CGV31 MERGE WITH UNOP CIRCUIT ! 13427: EJC ! 13428: * ! 13429: * CDGVL (CONTINUED) ! 13430: * ! 13431: * HERE FOR CONCATENATION ! 13432: * ! 13433: CGV24 MOV CMLOP(XL),XR LOAD LEFT OPERAND PTR ! 13434: BNE (XR),=B$CMT,CGV18 ORDINARY BINOP IF NOT CMBLK ! 13435: MOV CMTYP(XR),WB LOAD CMBLK TYPE CODE ! 13436: BEQ WB,=C$INT,CGV25 SPECIAL CASE IF INTERROGATION ! 13437: BEQ WB,=C$NEG,CGV25 OR NEGATION ! 13438: BNE WB,=C$FNC,CGV18 ELSE ORDINARY BINOP IF NOT FUNCTION ! 13439: MOV CMOPN(XR),XR ELSE LOAD FUNCTION VRBLK PTR ! 13440: BNZ VRLEN(XR),CGV18 ORDINARY BINOP IF NOT SYSTEM VAR ! 13441: MOV VRSVP(XR),XR ELSE POINT TO SVBLK ! 13442: MOV SVBIT(XR),WA LOAD BIT INDICATORS ! 13443: ANB BTPRD,WA TEST FOR PREDICATE FUNCTION ! 13444: ZRB WA,CGV18 ORDINARY BINOP IF NOT ! 13445: * ! 13446: * HERE IF LEFT ARG OF CONCATENATION IS PREDICATE FUNCTION ! 13447: * ! 13448: CGV25 MOV CMLOP(XL),XR RELOAD LEFT ARG ! 13449: JSR CDGVL GEN CODE BY VALUE ! 13450: MOV =OPOP$,WA LOAD POP CALL ! 13451: JSR CDWRD GENERATE IT ! 13452: MOV CMROP(XL),XR LOAD RIGHT OPERAND ! 13453: JSR CDGVL GEN CODE BY VALUE AS RESULT CODE ! 13454: BRN CGV33 EXIT (NOT CONSTANT) ! 13455: * ! 13456: * HERE TO GENERATE CODE FOR PATTERN, IMMEDIATE ASSIGNMENT ! 13457: * ! 13458: CGV26 MOV CMLOP(XL),XR LOAD LEFT OPERAND ! 13459: JSR CDGVL GEN CODE BY VALUE, MERGE ! 13460: * ! 13461: * HERE FOR UNOPS WITH ARG BY NAME (BINARY $ . MERGE) ! 13462: * ! 13463: CGV27 MOV CMROP(XL),XR LOAD RIGHT OPERAND PTR ! 13464: JSR CDGNM GEN CODE BY NAME FOR RIGHT ARG ! 13465: MOV CMOPN(XL),XR GET OPERATOR CODE WORD ! 13466: BNE (XR),=O$KWV,CGV20 GEN CALL UNLESS KEYWORD VALUE ! 13467: EJC ! 13468: * ! 13469: * CDGVL (CONTINUED) ! 13470: * ! 13471: * HERE FOR KEYWORD BY VALUE. THIS IS CONSTANT ONLY IF ! 13472: * THE OPERAND IS ONE OF THE SPECIAL SYSTEM VARIABLES WITH ! 13473: * THE SVCKW BIT SET TO INDICATE A CONSTANT KEYWORD VALUE. ! 13474: * NOTE THAT THE ONLY CONSTANT OPERAND BY NAME IS A VARIABLE ! 13475: * ! 13476: BNZ WC,CGV20 GEN CALL IF NON-CONSTANT (NOT VAR) ! 13477: MNZ WC ELSE SET NON-CONSTANT IN CASE ! 13478: MOV CMROP(XL),XR LOAD PTR TO OPERAND VRBLK ! 13479: BNZ VRLEN(XR),CGV20 GEN (NON-CONSTANT) IF NOT SYS VAR ! 13480: MOV VRSVP(XR),XR ELSE LOAD PTR TO SVBLK ! 13481: MOV SVBIT(XR),WA LOAD BIT MASK ! 13482: ANB BTCKW,WA TEST FOR CONSTANT KEYWORD ! 13483: ZRB WA,CGV20 GO GEN IF NOT CONSTANT ! 13484: ZER WC ELSE SET RESULT CONSTANT ! 13485: BRN CGV20 AND JUMP BACK TO GENERATE CALL ! 13486: * ! 13487: * HERE TO GENERATE CODE FOR NEGATION ! 13488: * ! 13489: CGV28 MOV =ONTA$,WA GET INITIAL WORD ! 13490: JSR CDWRD GENERATE IT ! 13491: MOV CWCOF,WB SAVE NEXT OFFSET ! 13492: JSR CDWRD GENERATE GUNK WORD FOR NOW ! 13493: MOV CMROP(XL),XR LOAD RIGHT OPERAND PTR ! 13494: JSR CDGVL GEN CODE BY VALUE ! 13495: MOV =ONTB$,WA LOAD END OF EVALUATION CALL ! 13496: JSR CDWRD GENERATE IT ! 13497: MOV WB,XR COPY OFFSET TO WORD TO PLUG ! 13498: ADD R$CCB,XR POINT TO ACTUAL WORD TO PLUG ! 13499: MOV CWCOF,(XR) PLUG WORD WITH CURRENT OFFSET ! 13500: MOV =ONTC$,WA LOAD FINAL CALL ! 13501: BRN CGV32 JUMP TO GENERATE IT (NOT CONSTANT) ! 13502: * ! 13503: * HERE TO GENERATE CODE FOR UNDEFINED BINARY OPERATOR ! 13504: * ! 13505: CGV29 MOV CMLOP(XL),XR LOAD LEFT OPERAND PTR ! 13506: JSR CDGVL GENERATE CODE BY VALUE ! 13507: EJC ! 13508: * ! 13509: * CDGVL (CONTINUED) ! 13510: * ! 13511: * HERE TO GENERATE CODE FOR UNDEFINED UNARY OPERATOR ! 13512: * ! 13513: CGV30 MOV =C$UO$,WB SET UNOP CODE + 1 ! 13514: SUB CMTYP(XL),WB SET NUMBER OF ARGS (1 OR 2) ! 13515: * ! 13516: * MERGE HERE FOR UNDEFINED OPERATORS ! 13517: * ! 13518: MOV CMROP(XL),XR LOAD RIGHT (ONLY) OPERAND POINTER ! 13519: JSR CDGVL GEN VALUE CODE FOR RIGHT OPERAND ! 13520: MOV CMOPN(XL),XR LOAD POINTER TO OPERATOR DV ! 13521: MOV DVOPN(XR),XR LOAD POINTER OFFSET ! 13522: WTB XR CONVERT WORD OFFSET TO BYTES ! 13523: ADD =R$UBA,XR POINT TO PROPER FUNCTION PTR ! 13524: SUB *VRFNC,XR SET STANDARD FUNCTION OFFSET ! 13525: BRN CGV12 MERGE WITH FUNCTION CALL CIRCUIT ! 13526: * ! 13527: * HERE TO GENERATE CODE FOR INTERROGATION, INDIRECTION ! 13528: * ! 13529: CGV31 MNZ WC SET NON CONSTANT ! 13530: BRN CGV19 MERGE ! 13531: * ! 13532: * HERE TO EXIT GENERATING A WORD, RESULT NOT CONSTANT ! 13533: * ! 13534: CGV32 JSR CDWRD GENERATE WORD, MERGE ! 13535: * ! 13536: * HERE TO EXIT WITH NO WORD GENERATED, NOT CONSTANT ! 13537: * ! 13538: CGV33 MNZ WC INDICATE RESULT IS NOT CONSTANT ! 13539: * ! 13540: * COMMON EXIT POINT ! 13541: * ! 13542: CGV34 ICA XS POP INITIAL CODE OFFSET ! 13543: MOV (XS)+,WA RESTORE OLD CONSTANT FLAG ! 13544: MOV (XS)+,XL RESTORE ENTRY XL ! 13545: MOV (XS)+,WB RESTORE ENTRY WB ! 13546: BNZ WC,CGV35 JUMP IF NOT CONSTANT ! 13547: MOV WA,WC ELSE RESTORE ENTRY CONSTANT FLAG ! 13548: * ! 13549: * HERE TO RETURN AFTER DEALING WITH WC SETTING ! 13550: * ! 13551: CGV35 EXI RETURN TO CDGVL CALLER ! 13552: * ! 13553: * EXIT HERE TO GENERATE WORD AND TEST FOR CONSTANT ! 13554: * ! 13555: CGV36 JSR CDWRD GENERATE WORD ! 13556: BNZ WC,CGV34 JUMP TO EXIT IF NOT CONSTANT ! 13557: EJC ! 13558: * ! 13559: * CDGVL (CONTINUED) ! 13560: * ! 13561: * HERE TO PREEVALUATE CONSTANT SUB-EXPRESSION ! 13562: * ! 13563: MOV =ORVL$,WA LOAD CALL TO RETURN VALUE ! 13564: JSR CDWRD GENERATE IT ! 13565: MOV (XS),XL LOAD INITIAL CODE OFFSET ! 13566: JSR EXBLD BUILD EXBLK FOR EXPRESSION ! 13567: ZER WB SET TO EVALUATE BY VALUE ! 13568: JSR EVALX EVALUATE EXPRESSION ! 13569: PPM SHOULD NOT FAIL ! 13570: MOV (XR),WA LOAD TYPE WORD OF RESULT ! 13571: BLO WA,=P$AAA,CGV37 JUMP IF NOT PATTERN ! 13572: MOV =OLPT$,WA ELSE LOAD SPECIAL PATTERN LOAD CALL ! 13573: JSR CDWRD GENERATE IT ! 13574: * ! 13575: * MERGE HERE TO GENERATE POINTER TO RESULTING CONSTANT ! 13576: * ! 13577: CGV37 MOV XR,WA COPY CONSTANT POINTER ! 13578: JSR CDWRD GENERATE PTR ! 13579: ZER WC SET RESULT CONSTANT ! 13580: BRN CGV34 JUMP BACK TO EXIT ! 13581: ENP END PROCEDURE CDGVL ! 13582: EJC ! 13583: * ! 13584: * CDWRD -- GENERATE ONE WORD OF CODE ! 13585: * ! 13586: * CDWRD WRITES ONE WORD INTO THE CURRENT CODE BLOCK UNDER ! 13587: * CONSTRUCTION. A NEW, LARGER, BLOCK IS ALLOCATED IF THERE ! 13588: * IS INSUFFICIENT ROOM IN THE CURRENT BLOCK. CDWRD ENSURES ! 13589: * THAT THERE ARE AT LEAST THREE WORDS LEFT IN THE BLOCK ! 13590: * AFTER ENTERING THE NEW WORD. THIS GUARANTEES THAT ANY ! 13591: * EXTRA SPACE AT THE END CAN BE SPLIT OFF AS A CCBLK. ! 13592: * ! 13593: * (WA) WORD TO BE GENERATED ! 13594: * JSR CDWRD CALL TO GENERATE WORD ! 13595: * ! 13596: CDWRD PRC E,0 ENTRY POINT ! 13597: MOV XR,-(XS) SAVE ENTRY XR ! 13598: MOV WA,-(XS) SAVE CODE WORD TO BE GENERATED ! 13599: * ! 13600: * MERGE BACK HERE AFTER ALLOCATING LARGER BLOCK ! 13601: * ! 13602: CDWD1 MOV R$CCB,XR LOAD PTR TO CCBLK BEING BUILT ! 13603: BNZ XR,CDWD2 JUMP IF BLOCK ALLOCATED ! 13604: * ! 13605: * HERE WE ALLOCATE AN ENTIRELY FRESH BLOCK ! 13606: * ! 13607: MOV *E$CBS,WA LOAD INITIAL LENGTH ! 13608: JSR ALLOC ALLOCATE CCBLK ! 13609: MOV =B$CCT,(XR) STORE TYPE WORD ! 13610: MOV *CCCOD,CWCOF SET INITIAL OFFSET ! 13611: MOV WA,CCLEN(XR) STORE BLOCK LENGTH ! 13612: MOV XR,R$CCB STORE PTR TO NEW BLOCK ! 13613: * ! 13614: * HERE WE HAVE A BLOCK WE CAN USE ! 13615: * ! 13616: CDWD2 MOV CWCOF,WA LOAD CURRENT OFFSET ! 13617: ADD *NUM04,WA ADJUST FOR TEST (FOUR WORDS) ! 13618: BLO WA,CCLEN(XR),CDWD4 JUMP IF ROOM IN THIS BLOCK ! 13619: * ! 13620: * HERE IF NO ROOM IN CURRENT BLOCK ! 13621: * ! 13622: BGE WA,MXLEN,CDWD5 JUMP IF ALREADY AT MAX SIZE ! 13623: ADD *E$CBS,WA ELSE GET NEW SIZE ! 13624: MOV XL,-(XS) SAVE ENTRY XL ! 13625: MOV XR,XL COPY POINTER ! 13626: BLT WA,MXLEN,CDWD3 JUMP IF NOT TOO LARGE ! 13627: MOV MXLEN,WA ELSE RESET TO MAX ALLOWED SIZE ! 13628: EJC ! 13629: * ! 13630: * CDWRD (CONTINUED) ! 13631: * ! 13632: * HERE WITH NEW BLOCK SIZE IN WA ! 13633: * ! 13634: CDWD3 JSR ALLOC ALLOCATE NEW BLOCK ! 13635: MOV XR,R$CCB STORE POINTER TO NEW BLOCK ! 13636: MOV =B$CCT,(XR)+ STORE TYPE WORD IN NEW BLOCK ! 13637: MOV WA,(XR)+ STORE BLOCK LENGTH ! 13638: ADD *CCUSE,XL POINT TO CCUSE,CCCOD FIELDS IN OLD ! 13639: MOV (XL),WA LOAD CCUSE VALUE ! 13640: MVW COPY USEFUL WORDS FROM OLD BLOCK ! 13641: MOV (XS)+,XL RESTORE XL ! 13642: BRN CDWD1 MERGE BACK TO TRY AGAIN ! 13643: * ! 13644: * HERE WITH ROOM IN CURRENT BLOCK ! 13645: * ! 13646: CDWD4 MOV CWCOF,WA LOAD CURRENT OFFSET ! 13647: ICA WA GET NEW OFFSET ! 13648: MOV WA,CWCOF STORE NEW OFFSET ! 13649: MOV WA,CCUSE(XR) STORE IN CCBLK FOR GBCOL ! 13650: DCA WA RESTORE PTR TO THIS WORD ! 13651: ADD WA,XR POINT TO CURRENT ENTRY ! 13652: MOV (XS)+,WA RELOAD WORD TO GENERATE ! 13653: MOV WA,(XR) STORE WORD IN BLOCK ! 13654: MOV (XS)+,XR RESTORE ENTRY XR ! 13655: EXI RETURN TO CALLER ! 13656: * ! 13657: * HERE IF COMPILED CODE IS TOO LONG FOR CDBLK ! 13658: * ! 13659: CDWD5 ERB 213,SYNTAX ERROR. STATEMENT IS TOO COMPLICATED. ! 13660: ENP END PROCEDURE CDWRD ! 13661: EJC ! 13662: * ! 13663: * CMGEN -- GENERATE CODE FOR CMBLK PTR ! 13664: * ! 13665: * CMGEN IS A SUBSIDIARY PROCEDURE USED TO GENERATE VALUE ! 13666: * CODE FOR A CMBLK PTR FROM THE MAIN CODE GENERATORS. ! 13667: * ! 13668: * (XL) CMBLK POINTER ! 13669: * (WB) OFFSET TO POINTER IN CMBLK ! 13670: * JSR CMGEN CALL TO GENERATE CODE ! 13671: * (XR,WA) DESTROYED ! 13672: * (WB) BUMPED BY ONE WORD ! 13673: * ! 13674: CMGEN PRC R,0 ENTRY POINT, RECURSIVE ! 13675: MOV XL,XR COPY CMBLK POINTER ! 13676: ADD WB,XR POINT TO CMBLK POINTER ! 13677: MOV (XR),XR LOAD CMBLK POINTER ! 13678: JSR CDGVL GENERATE CODE BY VALUE ! 13679: ICA WB BUMP OFFSET ! 13680: EXI RETURN TO CALLER ! 13681: ENP END PROCEDURE CMGEN ! 13682: EJC ! 13683: * ! 13684: * CMPIL (COMPILE SOURCE CODE) ! 13685: * ! 13686: * CMPIL IS USED TO CONVERT SNOBOL4 SOURCE CODE TO INTERNAL ! 13687: * FORM (SEE CDBLK FORMAT). IT IS USED BOTH FOR THE INITIAL ! 13688: * COMPILE AND AT RUN TIME BY THE CODE AND CONVERT FUNCTIONS ! 13689: * THIS PROCEDURE HAS CONTROL FOR THE ENTIRE DURATION OF ! 13690: * INITIAL COMPILATION. AN ERROR IN ANY PROCEDURE CALLED ! 13691: * DURING COMPILATION WILL LEAD FIRST TO THE ERROR SECTION ! 13692: * AND ULTIMATELY BACK HERE FOR RESUMED COMPILATION. THE ! 13693: * RE-ENTRY POINTS AFTER AN ERROR ARE SPECIALLY LABELLED - ! 13694: * ! 13695: * CMPCE RESUME AFTER CONTROL CARD ERROR ! 13696: * CMPLE RESUME AFTER LABEL ERROR ! 13697: * CMPSE RESUME AFTER STATEMENT ERROR ! 13698: * ! 13699: * JSR CMPIL CALL TO COMPILE CODE ! 13700: * (XR) PTR TO CDBLK FOR ENTRY STATEMENT ! 13701: * (XL,WA,WB,WC,RA) DESTROYED ! 13702: * ! 13703: * THE FOLLOWING GLOBAL VARIABLES ARE REFERENCED ! 13704: * ! 13705: * CMPSN NUMBER OF NEXT STATEMENT ! 13706: * TO BE COMPILED. ! 13707: * ! 13708: * CSWXX CONTROL CARD SWITCH VALUES ARE ! 13709: * CHANGED WHEN RELEVANT CONTROL ! 13710: * CARDS ARE MET. ! 13711: * ! 13712: * CWCOF OFFSET TO NEXT WORD IN CODE BLOCK ! 13713: * BEING BUILT (SEE CDWRD). ! 13714: * ! 13715: * LSTSN NUMBER OF STATEMENT MOST RECENTLY ! 13716: * COMPILED (INITIALLY SET TO ZERO). ! 13717: * ! 13718: * R$CIM CURRENT (INITIAL) COMPILER IMAGE ! 13719: * (ZERO FOR INITIAL COMPILE CALL) ! 13720: * ! 13721: * R$CNI USED TO POINT TO FOLLOWING IMAGE. ! 13722: * (SEE READR PROCEDURE). ! 13723: * ! 13724: * SCNGO GOTO SWITCH FOR SCANE PROCEDURE ! 13725: * ! 13726: * SCNIL LENGTH OF CURRENT IMAGE EXCLUDING ! 13727: * CHARACTERS REMOVED BY -INPUT. ! 13728: * ! 13729: * SCNPT CURRENT SCAN OFFSET, SEE SCANE. ! 13730: * ! 13731: * SCNRS RESCAN SWITCH FOR SCANE PROCEDURE. ! 13732: * ! 13733: * SCNSE OFFSET (IN R$CIM) OF MOST RECENTLY ! 13734: * SCANNED ELEMENT. SET ZERO IF NOT ! 13735: * CURRENTLY SCANNING ITEMS ! 13736: EJC ! 13737: * ! 13738: * CMPIL (CONTINUED) ! 13739: * ! 13740: * STAGE STGIC INITIAL COMPILE IN PROGRESS ! 13741: * STGXC CODE/CONVERT COMPILE ! 13742: * STGEV BUILDING EXBLK FOR EVAL ! 13743: * STGXT EXECUTE TIME (OUTSIDE COMPILE) ! 13744: * STGCE INITIAL COMPILE AFTER END LINE ! 13745: * STGXE EXECUTE COMPILE AFTER END LINE ! 13746: * ! 13747: * CMPIL ALSO USES A FIXED NUMBER OF LOCATIONS ON THE ! 13748: * MAIN STACK AS FOLLOWS. (THE DEFINITIONS OF THE ACTUAL ! 13749: * OFFSETS ARE IN THE DEFINITIONS SECTION). ! 13750: * ! 13751: * CMSTM(XS) POINTER TO EXPAN TREE FOR BODY OF ! 13752: * STATEMENT (SEE EXPAN PROCEDURE). ! 13753: * ! 13754: * CMSGO(XS) POINTER TO TREE REPRESENTATION OF ! 13755: * SUCCESS GOTO (SEE PROCEDURE SCNGO)9 ! 13756: * ZERO IF NO SUCCESS GOTO IS GIVEN ! 13757: * ! 13758: * CMFGO(XS) LIKE CMSGO FOR FAILURE GOTO. ! 13759: * ! 13760: * CMCGO(XS) SET NON-ZERO ONLY IF THERE IS A ! 13761: * CONDITIONAL GOTO. USED FOR -FAIL, ! 13762: * -NOFAIL CODE GENERATION. ! 13763: * ! 13764: * CMPCD(XS) POINTER TO CDBLK FOR PREVIOUS ! 13765: * STATEMENT. ZERO FOR 1ST STATEMENT. ! 13766: * ! 13767: * CMFFP(XS) SET NON-ZERO IF CDFAL IN PREVIOUS ! 13768: * CDBLK NEEDS FILLING WITH FORWARD ! 13769: * POINTER, ELSE SET TO ZERO. ! 13770: * ! 13771: * CMFFC(XS) SAME AS CMFFP FOR CURRENT CDBLK ! 13772: * ! 13773: * CMSOP(XS) OFFSET TO WORD IN PREVIOUS CDBLK ! 13774: * TO BE FILLED IN WITH FORWARD PTR ! 13775: * TO NEXT CDBLK FOR SUCCESS GOTO. ! 13776: * ZERO IF NO FILL IN IS REQUIRED. ! 13777: * ! 13778: * CMSOC(XS) SAME AS CMSOP FOR CURRENT CDBLK. ! 13779: * ! 13780: * CMLBL(XS) POINTER TO VRBLK FOR LABEL OF ! 13781: * CURRENT STATEMENT. ZERO IF NO LABEL ! 13782: * ! 13783: * CMTRA(XS) POINTER TO CDBLK FOR ENTRY STMNT. ! 13784: EJC ! 13785: * ! 13786: * CMPIL (CONTINUED) ! 13787: * ! 13788: * ENTRY POINT ! 13789: * ! 13790: CMPIL PRC E,0 ENTRY POINT ! 13791: LCT WB,=CMNEN SET NUMBER OF STACK WORK LOCATIONS ! 13792: * ! 13793: * LOOP TO INITIALIZE STACK WORKING LOCATIONS ! 13794: * ! 13795: CMP00 ZER -(XS) STORE A ZERO, MAKE ONE ENTRY ! 13796: BCT WB,CMP00 LOOP BACK UNTIL ALL SET ! 13797: MOV XS,CMPXS SAVE STACK POINTER FOR ERROR SEC ! 13798: SSS CMPSS SAVE S-R STACK POINTER IF ANY ! 13799: * ! 13800: * LOOP THROUGH STATEMENTS ! 13801: * ! 13802: CMP01 MOV SCNPT,WB SET SCAN POINTER OFFSET ! 13803: MOV WB,SCNSE SET START OF ELEMENT LOCATION ! 13804: MOV =OCER$,WA POINT TO COMPILE ERROR CALL ! 13805: JSR CDWRD GENERATE AS TEMPORARY CDFAL ! 13806: BLT WB,SCNIL,CMP04 JUMP IF CHARS LEFT ON THIS IMAGE ! 13807: * ! 13808: * LOOP HERE AFTER COMMENT OR CONTROL CARD ! 13809: * ALSO SPECIAL ENTRY AFTER CONTROL CARD ERROR ! 13810: * ! 13811: CMPCE ZER XR CLEAR POSSIBLE GARBAGE XR VALUE ! 13812: BNE STAGE,=STGIC,CMP02 SKIP UNLESS INITIAL COMPILE ! 13813: JSR READR READ NEXT INPUT IMAGE ! 13814: BZE XR,CMP09 JUMP IF NO INPUT AVAILABLE ! 13815: JSR NEXTS ACQUIRE NEXT SOURCE IMAGE ! 13816: MOV CMPSN,LSTSN STORE STMT NO FOR USE BY LISTR ! 13817: ZER SCNPT RESET SCAN POINTER ! 13818: BRN CMP04 GO PROCESS IMAGE ! 13819: * ! 13820: * FOR EXECUTE TIME COMPILE, PERMIT EMBEDDED CONTROL CARDS ! 13821: * AND COMMENTS (BY SKIPPING TO NEXT SEMI-COLON) ! 13822: * ! 13823: CMP02 MOV R$CIM,XR GET CURRENT IMAGE ! 13824: MOV SCNPT,WB GET CURRENT OFFSET ! 13825: PLC XR,WB PREPARE TO GET CHARS ! 13826: * ! 13827: * SKIP TO SEMI-COLON ! 13828: * ! 13829: CMP03 LCH WC,(XR)+ GET CHAR ! 13830: ICV SCNPT ADVANCE OFFSET ! 13831: BEQ WC,=CH$SM,CMP04 SKIP IF SEMI-COLON FOUND ! 13832: BLT SCNPT,SCNIL,CMP03 LOOP IF MORE CHARS ! 13833: ZER XR CLEAR GARBAGE XR VALUE ! 13834: BRN CMP09 END OF IMAGE ! 13835: EJC ! 13836: * ! 13837: * CMPIL (CONTINUED) ! 13838: * ! 13839: * HERE WITH IMAGE AVAILABLE TO SCAN. NOTE THAT IF THE INPUT ! 13840: * STRING IS NULL, THEN EVERYTHING IS OK SINCE NULL IS ! 13841: * ACTUALLY ASSEMBLED AS A WORD OF BLANKS. ! 13842: * ! 13843: CMP04 MOV R$CIM,XR POINT TO CURRENT IMAGE ! 13844: MOV SCNPT,WB LOAD CURRENT OFFSET ! 13845: MOV WB,WA COPY FOR LABEL SCAN ! 13846: PLC XR,WB POINT TO FIRST CHARACTER ! 13847: LCH WC,(XR)+ LOAD FIRST CHARACTER ! 13848: BEQ WC,=CH$SM,CMP12 NO LABEL IF SEMICOLON ! 13849: BEQ WC,=CH$AS,CMPCE LOOP BACK IF COMMENT CARD ! 13850: BEQ WC,=CH$MN,CMP32 JUMP IF CONTROL CARD ! 13851: MOV R$CIM,R$CMP ABOUT TO DESTROY R$CIM ! 13852: MOV =CMLAB,XL POINT TO LABEL WORK STRING ! 13853: MOV XL,R$CIM SCANE IS TO SCAN WORK STRING ! 13854: PSC XL POINT TO FIRST CHARACTER POSITION ! 13855: SCH WC,(XL)+ STORE CHAR JUST LOADED ! 13856: MOV =CH$SM,WC GET A SEMICOLON ! 13857: SCH WC,(XL) STORE AFTER FIRST CHAR ! 13858: CSC XL FINISHED CHARACTER STORING ! 13859: ZER XL CLEAR POINTER ! 13860: ZER SCNPT START AT FIRST CHARACTER ! 13861: MOV SCNIL,-(XS) PRESERVE IMAGE LENGTH ! 13862: MOV =NUM02,SCNIL READ 2 CHARS AT MOST ! 13863: JSR SCANE SCAN FIRST CHAR FOR TYPE ! 13864: MOV (XS)+,SCNIL RESTORE IMAGE LENGTH ! 13865: MOV XL,WC NOTE RETURN CODE ! 13866: MOV R$CMP,XL GET OLD R$CIM ! 13867: MOV XL,R$CIM PUT IT BACK ! 13868: MOV WB,SCNPT REINSTATE OFFSET ! 13869: BNZ SCNBL,CMP12 BLANK SEEN - CANT BE LABEL ! 13870: MOV XL,XR POINT TO CURRENT IMAGE ! 13871: PLC XR,WB POINT TO FIRST CHAR AGAIN ! 13872: BEQ WC,=T$VAR,CMP06 OK IF LETTER ! 13873: BEQ WC,=T$CON,CMP06 OK IF DIGIT ! 13874: * ! 13875: * DROP IN OR JUMP FROM ERROR SECTION IF SCANE FAILED ! 13876: * ! 13877: CMPLE MOV R$CMP,R$CIM POINT TO BAD LINE ! 13878: ERB 214,BAD LABEL OR MISPLACED CONTINUATION LINE ! 13879: * ! 13880: * LOOP TO SCAN LABEL ! 13881: * ! 13882: CMP05 BEQ WC,=CH$SM,CMP07 SKIP IF SEMICOLON ! 13883: ICV WA BUMP OFFSET ! 13884: BEQ WA,SCNIL,CMP07 JUMP IF END OF IMAGE (LABEL END) ! 13885: EJC ! 13886: * ! 13887: * CMPIL (CONTINUED) ! 13888: * ! 13889: * ENTER LOOP AT THIS POINT ! 13890: * ! 13891: CMP06 LCH WC,(XR)+ ELSE LOAD NEXT CHARACTER ! 13892: BEQ WC,=CH$HT,CMP07 JUMP IF HORIZONTAL TAB ! 13893: BNE WC,=CH$BL,CMP05 LOOP BACK IF NON-BLANK ! 13894: * ! 13895: * HERE AFTER SCANNING OUT LABEL ! 13896: * ! 13897: CMP07 MOV WA,SCNPT SAVE UPDATED SCAN OFFSET ! 13898: SUB WB,WA GET LENGTH OF LABEL ! 13899: BZE WA,CMP12 SKIP IF LABEL LENGTH ZERO ! 13900: ZER XR CLEAR GARBAGE XR VALUE ! 13901: JSR SBSTR BUILD SCBLK FOR LABEL NAME ! 13902: JSR GTNVR LOCATE/CONTRUCT VRBLK ! 13903: PPM DUMMY (IMPOSSIBLE) ERROR RETURN ! 13904: MOV XR,CMLBL(XS) STORE LABEL POINTER ! 13905: BNZ VRLEN(XR),CMP11 JUMP IF NOT SYSTEM LABEL ! 13906: BNE VRSVP(XR),=V$END,CMP11 JUMP IF NOT END LABEL ! 13907: * ! 13908: * HERE FOR END LABEL SCANNED OUT ! 13909: * ! 13910: ADD =STGND,STAGE ADJUST STAGE APPROPRIATELY ! 13911: JSR SCANE SCAN OUT NEXT ELEMENT ! 13912: BEQ XL,=T$SMC,CMP10 JUMP IF END OF IMAGE ! 13913: BNE XL,=T$VAR,CMP08 ELSE ERROR IF NOT VARIABLE ! 13914: * ! 13915: * HERE CHECK FOR VALID INITIAL TRANSFER ! 13916: * ! 13917: BEQ VRLBL(XR),=STNDL,CMP08 JUMP IF NOT DEFINED (ERROR) ! 13918: MOV VRLBL(XR),CMTRA(XS) ELSE SET INITIAL ENTRY POINTER ! 13919: JSR SCANE SCAN NEXT ELEMENT ! 13920: BEQ XL,=T$SMC,CMP10 JUMP IF OK (END OF IMAGE) ! 13921: * ! 13922: * HERE FOR BAD TRANSFER LABEL ! 13923: * ! 13924: CMP08 ERB 215,SYNTAX ERROR. UNDEFINED OR ERRONEOUS ENTRY LABEL ! 13925: * ! 13926: * HERE FOR END OF INPUT (NO END LABEL DETECTED) ! 13927: * ! 13928: CMP09 ADD =STGND,STAGE ADJUST STAGE APPROPRIATELY ! 13929: BEQ STAGE,=STGXE,CMP10 JUMP IF CODE CALL (OK) ! 13930: ERB 216,SYNTAX ERROR. MISSING END LINE ! 13931: * ! 13932: * HERE AFTER PROCESSING END LINE (MERGE HERE ON END ERROR) ! 13933: * ! 13934: CMP10 MOV =OSTP$,WA SET STOP CALL POINTER ! 13935: JSR CDWRD GENERATE AS STATEMENT CALL ! 13936: BRN CMPSE JUMP TO GENERATE AS FAILURE ! 13937: EJC ! 13938: * ! 13939: * CMPIL (CONTINUED) ! 13940: * ! 13941: * HERE AFTER PROCESSING LABEL OTHER THAN END ! 13942: * ! 13943: CMP11 BNE STAGE,=STGIC,CMP12 JUMP IF CODE CALL - REDEF. OK ! 13944: BEQ VRLBL(XR),=STNDL,CMP12 ELSE CHECK FOR REDEFINITION ! 13945: ZER CMLBL(XS) LEAVE FIRST LABEL DECLN UNDISTURBED ! 13946: ERB 217,SYNTAX ERROR. DUPLICATE LABEL ! 13947: * ! 13948: * HERE AFTER DEALING WITH LABEL ! 13949: * ! 13950: CMP12 ZER WB SET FLAG FOR STATEMENT BODY ! 13951: JSR EXPAN GET TREE FOR STATEMENT BODY ! 13952: MOV XR,CMSTM(XS) STORE FOR LATER USE ! 13953: ZER CMSGO(XS) CLEAR SUCCESS GOTO POINTER ! 13954: ZER CMFGO(XS) CLEAR FAILURE GOTO POINTER ! 13955: ZER CMCGO(XS) CLEAR CONDITIONAL GOTO FLAG ! 13956: JSR SCANE SCAN NEXT ELEMENT ! 13957: BNE XL,=T$COL,CMP18 JUMP IT NOT COLON (NO GOTO) ! 13958: * ! 13959: * LOOP TO PROCESS GOTO FIELDS ! 13960: * ! 13961: CMP13 MNZ SCNGO SET GOTO FLAG ! 13962: JSR SCANE SCAN NEXT ELEMENT ! 13963: BEQ XL,=T$SMC,CMP31 JUMP IF NO FIELDS LEFT ! 13964: BEQ XL,=T$SGO,CMP14 JUMP IF S FOR SUCCESS GOTO ! 13965: BEQ XL,=T$FGO,CMP16 JUMP IF F FOR FAILURE GOTO ! 13966: * ! 13967: * HERE FOR UNCONDITIONAL GOTO (I.E. NOT F OR S) ! 13968: * ! 13969: MNZ SCNRS SET TO RESCAN ELEMENT NOT F,S ! 13970: JSR SCNGF SCAN OUT GOTO FIELD ! 13971: BNZ CMFGO(XS),CMP17 ERROR IF FGOTO ALREADY ! 13972: MOV XR,CMFGO(XS) ELSE SET AS FGOTO ! 13973: BRN CMP15 MERGE WITH SGOTO CIRCUIT ! 13974: * ! 13975: * HERE FOR SUCCESS GOTO ! 13976: * ! 13977: CMP14 JSR SCNGF SCAN SUCCESS GOTO FIELD ! 13978: MOV =NUM01,CMCGO(XS) SET CONDITIONAL GOTO FLAG ! 13979: * ! 13980: * UNCONTIONAL GOTO MERGES HERE ! 13981: * ! 13982: CMP15 BNZ CMSGO(XS),CMP17 ERROR IF SGOTO ALREADY GIVEN ! 13983: MOV XR,CMSGO(XS) ELSE SET SGOTO ! 13984: BRN CMP13 LOOP BACK FOR NEXT GOTO FIELD ! 13985: * ! 13986: * HERE FOR FAILURE GOTO ! 13987: * ! 13988: CMP16 JSR SCNGF SCAN GOTO FIELD ! 13989: MOV =NUM01,CMCGO(XS) SET CONDITONAL GOTO FLAG ! 13990: BNZ CMFGO(XS),CMP17 ERROR IF FGOTO ALREADY GIVEN ! 13991: MOV XR,CMFGO(XS) ELSE STORE FGOTO POINTER ! 13992: BRN CMP13 LOOP BACK FOR NEXT FIELD ! 13993: EJC ! 13994: * ! 13995: * CMPIL (CONTINUED) ! 13996: * ! 13997: * HERE FOR DUPLICATED GOTO FIELD ! 13998: * ! 13999: CMP17 ERB 218,SYNTAX ERROR. DUPLICATED GOTO FIELD ! 14000: * ! 14001: * HERE TO GENERATE CODE ! 14002: * ! 14003: CMP18 ZER SCNSE STOP POSITIONAL ERROR FLAGS ! 14004: MOV CMSTM(XS),XR LOAD TREE PTR FOR STATEMENT BODY ! 14005: ZER WB COLLECTABLE VALUE FOR WB FOR CDGVL ! 14006: ZER WC RESET CONSTANT FLAG FOR CDGVL ! 14007: JSR EXPAP TEST FOR PATTERN MATCH ! 14008: PPM CMP19 JUMP IF NOT PATTERN MATCH ! 14009: MOV =OPMS$,CMOPN(XR) ELSE SET PATTERN MATCH POINTER ! 14010: MOV =C$PMT,CMTYP(XR) ! 14011: * ! 14012: * HERE AFTER DEALING WITH SPECIAL PATTERN MATCH CASE ! 14013: * ! 14014: CMP19 JSR CDGVL GENERATE CODE FOR BODY OF STATEMENT ! 14015: MOV CMSGO(XS),XR LOAD SGOTO POINTER ! 14016: MOV XR,WA COPY IT ! 14017: BZE XR,CMP21 JUMP IF NO SUCCESS GOTO ! 14018: ZER CMSOC(XS) CLEAR SUCCESS OFFSET FILLIN PTR ! 14019: BHI XR,STATE,CMP20 JUMP IF COMPLEX GOTO ! 14020: * ! 14021: * HERE FOR SIMPLE SUCCESS GOTO (LABEL) ! 14022: * ! 14023: ADD *VRTRA,WA POINT TO VRTRA FIELD AS REQUIRED ! 14024: JSR CDWRD GENERATE SUCCESS GOTO ! 14025: BRN CMP22 JUMP TO DEAL WITH FGOTO ! 14026: * ! 14027: * HERE FOR COMPLEX SUCCESS GOTO ! 14028: * ! 14029: CMP20 BEQ XR,CMFGO(XS),CMP22 NO CODE IF SAME AS FGOTO ! 14030: ZER WB ELSE SET OK VALUE FOR CDGVL IN WB ! 14031: JSR CDGCG GENERATE CODE FOR SUCCESS GOTO ! 14032: BRN CMP22 JUMP TO DEAL WITH FGOTO ! 14033: * ! 14034: * HERE FOR NO SUCCESS GOTO ! 14035: * ! 14036: CMP21 MOV CWCOF,CMSOC(XS) SET SUCCESS FILL IN OFFSET ! 14037: MOV =OCER$,WA POINT TO COMPILE ERROR CALL ! 14038: JSR CDWRD GENERATE AS TEMPORARY VALUE ! 14039: EJC ! 14040: * ! 14041: * CMPIL (CONTINUED) ! 14042: * ! 14043: * HERE TO DEAL WITH FAILURE GOTO ! 14044: * ! 14045: CMP22 MOV CMFGO(XS),XR LOAD FAILURE GOTO POINTER ! 14046: MOV XR,WA COPY IT ! 14047: ZER CMFFC(XS) SET NO FILL IN REQUIRED YET ! 14048: BZE XR,CMP23 JUMP IF NO FAILURE GOTO GIVEN ! 14049: ADD *VRTRA,WA POINT TO VRTRA FIELD IN CASE ! 14050: BLO XR,STATE,CMPSE JUMP TO GEN IF SIMPLE FGOTO ! 14051: * ! 14052: * HERE FOR COMPLEX FAILURE GOTO ! 14053: * ! 14054: MOV CWCOF,WB SAVE OFFSET TO O$GOF CALL ! 14055: MOV =OGOF$,WA POINT TO FAILURE GOTO CALL ! 14056: JSR CDWRD GENERATE ! 14057: MOV =OFIF$,WA POINT TO FAIL IN FAIL WORD ! 14058: JSR CDWRD GENERATE ! 14059: JSR CDGCG GENERATE CODE FOR FAILURE GOTO ! 14060: MOV WB,WA COPY OFFSET TO O$GOF FOR CDFAL ! 14061: MOV =B$CDC,WB SET COMPLEX CASE CDTYP ! 14062: BRN CMP25 JUMP TO BUILD CDBLK ! 14063: * ! 14064: * HERE IF NO FAILURE GOTO GIVEN ! 14065: * ! 14066: CMP23 MOV =OUNF$,WA LOAD UNEXPECTED FAILURE CALL IN CAS ! 14067: MOV CSWFL,WC GET -NOFAIL FLAG ! 14068: ORB CMCGO(XS),WC CHECK IF CONDITIONAL GOTO ! 14069: ZRB WC,CMPSE JUMP IF -NOFAIL AND NO COND. GOTO ! 14070: MNZ CMFFC(XS) ELSE SET FILL IN FLAG ! 14071: MOV =OCER$,WA AND SET COMPILE ERROR FOR TEMPORARY ! 14072: * ! 14073: * MERGE HERE WITH CDFAL VALUE IN WA, SIMPLE CDBLK ! 14074: * ALSO SPECIAL ENTRY AFTER STATEMENT ERROR ! 14075: * ! 14076: CMPSE MOV =B$CDS,WB SET CDTYP FOR SIMPLE CASE ! 14077: EJC ! 14078: * ! 14079: * CMPIL (CONTINUED) ! 14080: * ! 14081: * MERGE HERE TO BUILD CDBLK ! 14082: * ! 14083: * (WA) CDFAL VALUE TO BE GENERATED ! 14084: * (WB) CDTYP VALUE TO BE GENERATED ! 14085: * ! 14086: * AT THIS STAGE, WE CHOP OFF AN APPROPRIATE CHUNK OF THE ! 14087: * CURRENT CCBLK AND CONVERT IT INTO A CDBLK. THE REMAINDER ! 14088: * OF THE CCBLK IS REFORMATTED TO BE THE NEW CCBLK. ! 14089: * ! 14090: CMP25 MOV R$CCB,XR POINT TO CCBLK ! 14091: MOV CMLBL(XS),XL GET POSSIBLE LABEL POINTER ! 14092: BZE XL,CMP26 SKIP IF NO LABEL ! 14093: ZER CMLBL(XS) CLEAR FLAG FOR NEXT STATEMENT ! 14094: MOV XR,VRLBL(XL) PUT CDBLK PTR IN VRBLK LABEL FIELD ! 14095: * ! 14096: * MERGE AFTER DOING LABEL ! 14097: * ! 14098: CMP26 MOV WB,(XR) SET TYPE WORD FOR NEW CDBLK ! 14099: MOV WA,CDFAL(XR) SET FAILURE WORD ! 14100: MOV XR,XL COPY POINTER TO CCBLK ! 14101: MOV CCUSE(XR),WB LOAD LENGTH GEN (= NEW CDLEN) ! 14102: MOV CCLEN(XR),WC LOAD TOTAL CCBLK LENGTH ! 14103: ADD WB,XL POINT PAST CDBLK ! 14104: SUB WB,WC GET LENGTH LEFT FOR CHOP OFF ! 14105: MOV =B$CCT,(XL) SET TYPE CODE FOR NEW CCBLK AT END ! 14106: MOV *CCCOD,CCUSE(XL) SET INITIAL CODE OFFSET ! 14107: MOV *CCCOD,CWCOF REINITIALISE CWCOF ! 14108: MOV WC,CCLEN(XL) SET NEW LENGTH ! 14109: MOV XL,R$CCB SET NEW CCBLK POINTER ! 14110: MOV CMPSN,CDSTM(XR) SET STATEMENT NUMBER ! 14111: ICV CMPSN BUMP STATEMENT NUMBER ! 14112: * ! 14113: * SET POINTERS IN PREVIOUS CODE BLOCK AS REQUIRED ! 14114: * ! 14115: MOV CMPCD(XS),XL LOAD PTR TO PREVIOUS CDBLK ! 14116: BZE CMFFP(XS),CMP27 JUMP IF NO FAILURE FILL IN REQUIRED ! 14117: MOV XR,CDFAL(XL) ELSE SET FAILURE PTR IN PREVIOUS ! 14118: * ! 14119: * HERE TO DEAL WITH SUCCESS FORWARD POINTER ! 14120: * ! 14121: CMP27 MOV CMSOP(XS),WA LOAD SUCCESS OFFSET ! 14122: BZE WA,CMP28 JUMP IF NO FILL IN REQUIRED ! 14123: ADD WA,XL ELSE POINT TO FILL IN LOCATION ! 14124: MOV XR,(XL) STORE FORWARD POINTER ! 14125: ZER XL CLEAR GARBAGE XL VALUE ! 14126: EJC ! 14127: * ! 14128: * CMPIL (CONTINUED) ! 14129: * ! 14130: * NOW SET FILL IN POINTERS FOR THIS STATEMENT ! 14131: * ! 14132: CMP28 MOV CMFFC(XS),CMFFP(XS) COPY FAILURE FILL IN FLAG ! 14133: MOV CMSOC(XS),CMSOP(XS) COPY SUCCESS FILL IN OFFSET ! 14134: MOV XR,CMPCD(XS) SAVE PTR TO THIS CDBLK ! 14135: BNZ CMTRA(XS),CMP29 JUMP IF INITIAL ENTRY ALREADY SET ! 14136: MOV XR,CMTRA(XS) ELSE SET PTR HERE AS DEFAULT ! 14137: * ! 14138: * HERE AFTER COMPILING ONE STATEMENT ! 14139: * ! 14140: CMP29 BLT STAGE,=STGCE,CMP01 JUMP IF NOT END LINE JUST DONE ! 14141: BZE CSWLS,CMP30 SKIP IF -NOLIST ! 14142: JSR LISTR LIST LAST LINE ! 14143: * ! 14144: * RETURN ! 14145: * ! 14146: CMP30 MOV CMTRA(XS),XR LOAD INITIAL ENTRY CDBLK POINTER ! 14147: ADD *CMNEN,XS POP WORK LOCATIONS OFF STACK ! 14148: EXI AND RETURN TO CMPIL CALLER ! 14149: * ! 14150: * HERE AT END OF GOTO FIELD ! 14151: * ! 14152: CMP31 MOV CMFGO(XS),WB GET FAIL GOTO ! 14153: ORB CMSGO(XS),WB OR IN SUCCESS GOTO ! 14154: BNZ WB,CMP18 OK IF NON-NULL FIELD ! 14155: ERB 219,SYNTAX ERROR. EMPTY GOTO FIELD ! 14156: * ! 14157: * CONTROL CARD FOUND ! 14158: * ! 14159: CMP32 ICV WB POINT PAST CH$MN ! 14160: JSR CNCRD PROCESS CONTROL CARD ! 14161: ZER SCNSE CLEAR START OF ELEMENT LOC. ! 14162: BRN CMPCE LOOP FOR NEXT STATEMENT ! 14163: ENP END PROCEDURE CMPIL ! 14164: EJC ! 14165: * ! 14166: * CNCRD -- CONTROL CARD PROCESSOR ! 14167: * ! 14168: * CALLED TO DEAL WITH CONTROL CARDS ! 14169: * ! 14170: * R$CIM POINTS TO CURRENT IMAGE ! 14171: * (WB) OFFSET TO 1ST CHAR OF CONTROL CARD ! 14172: * JSR CNCRD CALL TO PROCESS CONTROL CARDS ! 14173: * (XL,XR,WA,WB,WC,IA) DESTROYED ! 14174: * ! 14175: CNCRD PRC E,0 ENTRY POINT ! 14176: MOV WB,SCNPT OFFSET FOR CONTROL CARD SCAN ! 14177: MOV =CCNOC,WA NUMBER OF CHARS FOR COMPARISON ! 14178: CTW WA,0 CONVERT TO WORD COUNT ! 14179: MOV WA,CNSWC SAVE WORD COUNT ! 14180: * ! 14181: * LOOP HERE IF MORE THAN ONE CONTROL CARD ! 14182: * ! 14183: CNC01 BGE SCNPT,SCNIL,CNC09 RETURN IF END OF IMAGE ! 14184: MOV R$CIM,XR POINT TO IMAGE ! 14185: PLC XR,SCNPT CHAR PTR FOR FIRST CHAR ! 14186: LCH WA,(XR)+ GET FIRST CHAR ! 14187: FLC WA FOLD TO UPPER CASE ! 14188: BEQ WA,=CH$LI,CNC07 SPECIAL CASE OF -INXXX ! 14189: MNZ SCNCC SET FLAG FOR SCANE ! 14190: JSR SCANE SCAN CARD NAME ! 14191: ZER SCNCC CLEAR SCANE FLAG ! 14192: BNZ XL,CNC06 FAIL UNLESS CONTROL CARD NAME ! 14193: MOV =CCNOC,WA NO. OF CHARS TO BE COMPARED ! 14194: BLT SCLEN(XR),WA,CNC06 FAIL IF TOO FEW CHARS ! 14195: MOV XR,XL POINT TO CONTROL CARD NAME ! 14196: ZER WB ZERO OFFSET FOR SUBSTRING ! 14197: JSR SBSTR EXTRACT SUBSTRING FOR COMPARISON ! 14198: MOV SCLEN(XR),WA RELOAD LENGTH ! 14199: JSR FLSTG FOLD TO UPPER CASE ! 14200: MOV XR,CNSCC KEEP CONTROL CARD SUBSTRING PTR ! 14201: MOV =CCNMS,XR POINT TO LIST OF STANDARD NAMES ! 14202: ZER WB INITIALISE NAME OFFSET ! 14203: LCT WC,=CC$NC NUMBER OF STANDARD NAMES ! 14204: * ! 14205: * TRY TO MATCH NAME ! 14206: * ! 14207: CNC02 MOV CNSCC,XL POINT TO NAME ! 14208: LCT WA,CNSWC COUNTER FOR INNER LOOP ! 14209: BRN CNC04 JUMP INTO LOOP ! 14210: * ! 14211: * INNER LOOP TO MATCH CARD NAME CHARS ! 14212: * ! 14213: CNC03 ICA XR BUMP STANDARD NAMES PTR ! 14214: ICA XL BUMP NAME POINTER ! 14215: * ! 14216: * HERE TO INITIATE THE LOOP ! 14217: * ! 14218: CNC04 CNE SCHAR(XL),(XR),CNC05 COMP. UP TO CFP$C CHARS AT ONCE ! 14219: BCT WA,CNC03 LOOP IF MORE WORDS TO COMPARE ! 14220: EJC ! 14221: * ! 14222: * CNCRD (CONTINUED) ! 14223: * ! 14224: * MATCHED - BRANCH ON CARD OFFSET ! 14225: * ! 14226: MOV WB,XL GET NAME OFFSET ! 14227: BSW XL,CC$NC SWITCH ! 14228: IFF CC$CA,CNC37 -CASE ! 14229: IFF CC$DO,CNC10 -DOUBLE ! 14230: IFF CC$DU,CNC11 -DUMP ! 14231: IFF CC$EJ,CNC12 -EJECT ! 14232: IFF CC$ER,CNC13 -ERRORS ! 14233: IFF CC$EX,CNC14 -EXECUTE ! 14234: IFF CC$FA,CNC15 -FAIL ! 14235: IFF CC$LI,CNC16 -LIST ! 14236: IFF CC$NR,CNC17 -NOERRORS ! 14237: IFF CC$NX,CNC18 -NOEXECUTE ! 14238: IFF CC$NF,CNC19 -NOFAIL ! 14239: IFF CC$NL,CNC20 -NOLIST ! 14240: IFF CC$NO,CNC21 -NOOPT ! 14241: IFF CC$NP,CNC22 -NOPRINT ! 14242: IFF CC$OP,CNC24 -OPTIMISE ! 14243: IFF CC$PR,CNC25 -PRINT ! 14244: IFF CC$SI,CNC27 -SINGLE ! 14245: IFF CC$SP,CNC28 -SPACE ! 14246: IFF CC$ST,CNC31 -STITLE ! 14247: IFF CC$TI,CNC32 -TITLE ! 14248: IFF CC$TR,CNC36 -TRACE ! 14249: ESW END SWITCH ! 14250: * ! 14251: * NOT MATCHED YET. ALIGN STD NAMES PTR AND TRY AGAIN ! 14252: * ! 14253: CNC05 ICA XR BUMP STANDARD NAMES PTR ! 14254: BCT WA,CNC05 LOOP ! 14255: ICV WB BUMP NAMES OFFSET ! 14256: BCT WC,CNC02 CONTINUE IF MORE NAMES ! 14257: * ! 14258: * INVALID CONTROL CARD NAME ! 14259: * ! 14260: CNC06 ERB 247,INVALID CONTROL CARD ! 14261: * ! 14262: * SPECIAL PROCESSING FOR -INXXX ! 14263: * ! 14264: CNC07 LCH WA,(XR) GET NEXT CHAR ! 14265: FLC WA FOLD TO UPPER CASE ! 14266: BNE WA,=CH$LN,CNC06 FAIL IF NOT LETTER N ! 14267: ADD =NUM02,SCNPT BUMP OFFSET PAST -IN ! 14268: JSR SCANE SCAN INTEGER AFTER -IN ! 14269: MOV XR,-(XS) STACK SCANNED ITEM ! 14270: JSR GTSMI CHECK IF INTEGER ! 14271: PPM CNC06 FAIL IF NOT INTEGER ! 14272: PPM CNC06 FAIL IF NEGATIVE OR LARGE ! 14273: MOV XR,CSWIN KEEP INTEGER ! 14274: EJC ! 14275: * ! 14276: * CNCRD (CONTINUED) ! 14277: * ! 14278: * CHECK FOR MORE CONTROL CARDS BEFORE RETURNING ! 14279: * ! 14280: CNC08 MOV SCNPT,WA PRESERVE IN CASE XEQ TIME COMPILE ! 14281: JSR SCANE LOOK FOR COMMA ! 14282: BEQ XL,=T$CMA,CNC01 LOOP IF COMMA FOUND ! 14283: MOV WA,SCNPT RESTORE SCNPT IN CASE XEQ TIME ! 14284: * ! 14285: * RETURN POINT ! 14286: * ! 14287: CNC09 EXI RETURN ! 14288: * ! 14289: * -DOUBLE ! 14290: * ! 14291: CNC10 MNZ CSWDB SET SWITCH ! 14292: BRN CNC08 MERGE ! 14293: * ! 14294: * -DUMP ! 14295: * THIS IS USED FOR SYSTEM DEBUGGING . IT HAS THE EFFECT OF ! 14296: * PRODUCING A CORE DUMP AT COMPILATION TIME ! 14297: * ! 14298: CNC11 JSR SYSDM CALL DUMPER ! 14299: BRN CNC09 FINISHED ! 14300: * ! 14301: * -EJECT ! 14302: * ! 14303: CNC12 BZE CSWLS,CNC09 RETURN IF -NOLIST ! 14304: JSR PRTPS EJECT ! 14305: JSR LISTT LIST TITLE ! 14306: BRN CNC09 FINISHED ! 14307: * ! 14308: * -ERRORS ! 14309: * ! 14310: CNC13 ZER CSWER CLEAR SWITCH ! 14311: BRN CNC08 MERGE ! 14312: * ! 14313: * -EXECUTE ! 14314: * ! 14315: CNC14 ZER CSWEX CLEAR SWITCH ! 14316: BRN CNC08 MERGE ! 14317: * ! 14318: * -FAIL ! 14319: * ! 14320: CNC15 MNZ CSWFL SET SWITCH ! 14321: BRN CNC08 MERGE ! 14322: * ! 14323: * -LIST ! 14324: * ! 14325: CNC16 MNZ CSWLS SET SWITCH ! 14326: BEQ STAGE,=STGIC,CNC08 DONE IF COMPILE TIME ! 14327: * ! 14328: * LIST CODE LINE IF EXECUTE TIME COMPILE ! 14329: * ! 14330: ZER LSTPF PERMIT LISTING ! 14331: JSR LISTR LIST LINE ! 14332: BRN CNC08 MERGE ! 14333: EJC ! 14334: * ! 14335: * CNCRD (CONTINUED) ! 14336: * ! 14337: * -NOERRORS ! 14338: * ! 14339: CNC17 MNZ CSWER SET SWITCH ! 14340: BRN CNC08 MERGE ! 14341: * ! 14342: * -NOEXECUTE ! 14343: * ! 14344: CNC18 MNZ CSWEX SET SWITCH ! 14345: BRN CNC08 MERGE ! 14346: * ! 14347: * -NOFAIL ! 14348: * ! 14349: CNC19 ZER CSWFL CLEAR SWITCH ! 14350: BRN CNC08 MERGE ! 14351: * ! 14352: * -NOLIST ! 14353: * ! 14354: CNC20 ZER CSWLS CLEAR SWITCH ! 14355: BRN CNC08 MERGE ! 14356: * ! 14357: * -NOOPTIMISE ! 14358: * ! 14359: CNC21 MNZ CSWNO SET SWITCH ! 14360: BRN CNC08 MERGE ! 14361: * ! 14362: * -NOPRINT ! 14363: * ! 14364: CNC22 ZER CSWPR CLEAR SWITCH ! 14365: BRN CNC08 MERGE ! 14366: * ! 14367: * -OPTIMISE ! 14368: * ! 14369: CNC24 ZER CSWNO CLEAR SWITCH ! 14370: BRN CNC08 MERGE ! 14371: * ! 14372: * -PRINT ! 14373: * ! 14374: CNC25 MNZ CSWPR SET SWITCH ! 14375: BRN CNC08 MERGE ! 14376: EJC ! 14377: * ! 14378: * CNCRD (CONTINUED) ! 14379: * ! 14380: * -SINGLE ! 14381: * ! 14382: CNC27 ZER CSWDB CLEAR SWITCH ! 14383: BRN CNC08 MERGE ! 14384: * ! 14385: * -SPACE ! 14386: * ! 14387: CNC28 BZE CSWLS,CNC09 RETURN IF -NOLIST ! 14388: JSR SCANE SCAN INTEGER AFTER -SPACE ! 14389: MOV =NUM01,WC 1 SPACE IN CASE ! 14390: BEQ XR,=T$SMC,CNC29 JUMP IF NO INTEGER ! 14391: MOV XR,-(XS) STACK IT ! 14392: JSR GTSMI CHECK INTEGER ! 14393: PPM CNC06 FAIL IF NOT INTEGER ! 14394: PPM CNC06 FAIL IF NEGATIVE OR LARGE ! 14395: BNZ WC,CNC29 JUMP IF NON ZERO ! 14396: MOV =NUM01,WC ELSE 1 SPACE ! 14397: * ! 14398: * MERGE WITH COUNT OF LINES TO SKIP ! 14399: * ! 14400: CNC29 ADD WC,LSTLC BUMP LINE COUNT ! 14401: LCT WC,WC CONVERT TO LOOP COUNTER ! 14402: BLT LSTLC,LSTNP,CNC30 JUMP IF FITS ON PAGE ! 14403: JSR PRTPS EJECT ! 14404: JSR LISTT LIST TITLE ! 14405: BRN CNC09 MERGE ! 14406: * ! 14407: * SKIP LINES ! 14408: * ! 14409: CNC30 JSR PRTNL PRINT A BLANK ! 14410: BCT WC,CNC30 LOOP ! 14411: BRN CNC09 MERGE ! 14412: EJC ! 14413: * ! 14414: * CNCRD (CONTINUED) ! 14415: * ! 14416: * -STITL ! 14417: * ! 14418: CNC31 MOV =R$STL,CNR$T PTR TO R$STL ! 14419: BRN CNC33 MERGE ! 14420: * ! 14421: * -TITLE ! 14422: * ! 14423: CNC32 MOV =NULLS,R$STL CLEAR SUBTITLE ! 14424: MOV =R$TTL,CNR$T PTR TO R$TTL ! 14425: * ! 14426: * COMMON PROCESSING FOR -TITLE, -STITL ! 14427: * ! 14428: CNC33 MOV =NULLS,XR NULL IN CASE NEEDED ! 14429: MNZ CNTTL SET FLAG FOR NEXT LISTR CALL ! 14430: MOV =CCOFS,WB OFFSET TO TITLE/SUBTITLE ! 14431: MOV SCNIL,WA INPUT IMAGE LENGTH ! 14432: BLO WA,WB,CNC34 JUMP IF NO CHARS LEFT ! 14433: SUB WB,WA NO OF CHARS TO EXTRACT ! 14434: MOV R$CIM,XL POINT TO IMAGE ! 14435: JSR SBSTR GET TITLE/SUBTITLE ! 14436: * ! 14437: * STORE TITLE/SUBTITLE ! 14438: * ! 14439: CNC34 MOV CNR$T,XL POINT TO STORAGE LOCATION ! 14440: MOV XR,(XL) STORE TITLE/SUBTITLE ! 14441: BEQ XL,=R$STL,CNC09 RETURN IF STITL ! 14442: BNZ PRECL,CNC09 RETURN IF EXTENDED LISTING ! 14443: BZE PRICH,CNC09 RETURN IF REGULAR PRINTER ! 14444: MOV SCLEN(XR),XL GET LENGTH OF TITLE ! 14445: MOV XL,WA COPY IT ! 14446: BZE XL,CNC35 JUMP IF NULL ! 14447: ADD =NUM10,XL INCREMENT ! 14448: BHI XL,PRLEN,CNC09 USE DEFAULT LSTP0 VAL IF TOO LONG ! 14449: ADD =NUM04,WA POINT JUST PAST TITLE ! 14450: * ! 14451: * STORE OFFSET TO PAGE NN MESSAGE FOR SHORT TITLE ! 14452: * ! 14453: CNC35 MOV WA,LSTPO STORE OFFSET ! 14454: BRN CNC09 RETURN ! 14455: * ! 14456: * -TRACE ! 14457: * PROVIDED FOR SYSTEM DEBUGGING. TOGGLES THE SYSTEM LABEL ! 14458: * TRACE SWITCH AT COMPILE TIME ! 14459: * ! 14460: CNC36 JSR SYSTT TOGGLE SWITCH ! 14461: BRN CNC08 MERGE ! 14462: * ! 14463: * -CASE ! 14464: * SETS VALUE OF KVCAS SO THAT NAMES ARE FOLDED OR NOT ! 14465: * DURING COMPILATION. ! 14466: * ! 14467: CNC37 JSR SCANE SCAN INTEGER AFTER -CASE ! 14468: ZER WC GET 0 IN CASE NONE THERE ! 14469: BEQ XL,=T$SMC,CNC38 SKIP IF NO INTEGER ! 14470: MOV XR,-(XS) STACK IT ! 14471: JSR GTSMI CHECK INTEGER ! 14472: PPM CNC06 FAIL IF NOT INTEGER ! 14473: PPM CNC06 FAIL IF NEGATIVE OR TOO LARGE ! 14474: CNC38 MOV WC,KVCAS STORE NEW CASE VALUE ! 14475: BRN CNC09 MERGE ! 14476: ENP END PROCEDURE CNCRD ! 14477: EJC ! 14478: * ! 14479: * DFFNC -- DEFINE FUNCTION ! 14480: * ! 14481: * DFFNC IS CALLED WHENEVER A NEW FUNCTION IS ASSIGNED TO ! 14482: * A VARIABLE. IT DEALS WITH EXTERNAL FUNCTION USE COUNTS. ! 14483: * ! 14484: * (XR) POINTER TO VRBLK ! 14485: * (XL) POINTER TO NEW FUNCTION BLOCK ! 14486: * JSR DFFNC CALL TO DEFINE FUNCTION ! 14487: * (WA,WB) DESTROYED ! 14488: * ! 14489: DFFNC PRC E,0 ENTRY POINT ! 14490: BNE (XL),=B$EFC,DFFN1 SKIP IF NEW FUNCTION NOT EXTERNAL ! 14491: ICV EFUSE(XL) ELSE INCREMENT ITS USE COUNT ! 14492: * ! 14493: * HERE AFTER DEALING WITH NEW FUNCTION USE COUNT ! 14494: * ! 14495: DFFN1 MOV XR,WA SAVE VRBLK POINTER ! 14496: MOV VRFNC(XR),XR LOAD OLD FUNCTION POINTER ! 14497: BNE (XR),=B$EFC,DFFN2 JUMP IF OLD FUNCTION NOT EXTERNAL ! 14498: MOV EFUSE(XR),WB ELSE GET USE COUNT ! 14499: DCV WB DECREMENT ! 14500: MOV WB,EFUSE(XR) STORE DECREMENTED VALUE ! 14501: BNZ WB,DFFN2 JUMP IF USE COUNT STILL NON-ZERO ! 14502: JSR SYSUL ELSE CALL SYSTEM UNLOAD FUNCTION ! 14503: * ! 14504: * HERE AFTER DEALING WITH OLD FUNCTION USE COUNT ! 14505: * ! 14506: DFFN2 MOV WA,XR RESTORE VRBLK POINTER ! 14507: MOV XL,WA COPY FUNCTION BLOCK PTR ! 14508: BLT XR,=R$YYY,DFFN3 SKIP CHECKS IF OPSYN OP DEFINITION ! 14509: BNZ VRLEN(XR),DFFN3 JUMP IF NOT SYSTEM VARIABLE ! 14510: * ! 14511: * FOR SYSTEM VARIABLE, CHECK FOR ILLEGAL REDEFINITION ! 14512: * ! 14513: MOV VRSVP(XR),XL POINT TO SVBLK ! 14514: MOV SVBIT(XL),WB LOAD BIT INDICATORS ! 14515: ANB BTFNC,WB IS IT A SYSTEM FUNCTION ! 14516: ZRB WB,DFFN3 REDEF OK IF NOT ! 14517: ERB 248,ATTEMPTED REDEFINITION OF SYSTEM FUNCTION ! 14518: * ! 14519: * HERE IF REDEFINITION IS PERMITTED ! 14520: * ! 14521: DFFN3 MOV WA,VRFNC(XR) STORE NEW FUNCTION POINTER ! 14522: MOV WA,XL RESTORE FUNCTION BLOCK POINTER ! 14523: EXI RETURN TO DFFNC CALLER ! 14524: ENP END PROCEDURE DFFNC ! 14525: EJC ! 14526: * ! 14527: * DTACH -- DETACH I/O ASSOCIATED NAMES ! 14528: * ! 14529: * DETACHES TRBLKS FROM I/O ASSOCIATED VARIABLES, REMOVES ! 14530: * ENTRY FROM IOCHN CHAIN ATTACHED TO FILEARG1 VRBLK AND MAY ! 14531: * REMOVE VRBLK ACCESS AND STORE TRAPS. ! 14532: * INPUT, OUTPUT, TERMINAL ARE HANDLED SPECIALLY. ! 14533: * ! 14534: * (XL) I/O ASSOC. VBL NAME BASE PTR ! 14535: * (WA) OFFSET TO NAME ! 14536: * JSR DTACH CALL FOR DETACH OPERATION ! 14537: * (XL,XR,WA,WB,WC) DESTROYED ! 14538: * ! 14539: DTACH PRC E,0 ENTRY POINT ! 14540: MOV XL,DTCNB STORE NAME BASE (GBCOL NOT CALLED) ! 14541: ADD WA,XL POINT TO NAME LOCATION ! 14542: MOV XL,DTCNM STORE IT ! 14543: * ! 14544: * LOOP TO SEARCH FOR I/O TRBLK ! 14545: * ! 14546: DTCH1 MOV XL,XR COPY NAME POINTER ! 14547: * ! 14548: * CONTINUE AFTER BLOCK DELETION ! 14549: * ! 14550: DTCH2 MOV (XL),XL POINT TO NEXT VALUE ! 14551: BNE (XL),=B$TRT,DTCH6 JUMP AT CHAIN END ! 14552: MOV TRTYP(XL),WA GET TRAP BLOCK TYPE ! 14553: BEQ WA,=TRTIN,DTCH3 JUMP IF INPUT ! 14554: BEQ WA,=TRTOU,DTCH3 JUMP IF OUTPUT ! 14555: ADD *TRNXT,XL POINT TO NEXT LINK ! 14556: BRN DTCH1 LOOP ! 14557: * ! 14558: * DELETE AN OLD ASSOCIATION ! 14559: * ! 14560: DTCH3 MOV TRVAL(XL),(XR) DELETE TRBLK ! 14561: MOV XL,WA DUMP XL ... ! 14562: MOV XR,WB ... AND XR ! 14563: MOV TRTRF(XL),XL POINT TO TRTRF TRAP BLOCK ! 14564: BZE XL,DTCH5 JUMP IF NO IOCHN ! 14565: BNE (XL),=B$TRT,DTCH5 JUMP IF INPUT, OUTPUT, TERMINAL ! 14566: * ! 14567: * LOOP TO SEARCH IOCHN CHAIN FOR NAME PTR ! 14568: * ! 14569: DTCH4 MOV XL,XR REMEMBER LINK PTR ! 14570: MOV TRTRF(XL),XL POINT TO NEXT LINK ! 14571: BZE XL,DTCH5 JUMP IF END OF CHAIN ! 14572: MOV IONMB(XL),WC GET NAME BASE ! 14573: ADD IONMO(XL),WC ADD OFFSET ! 14574: BNE WC,DTCNM,DTCH4 LOOP IF NO MATCH ! 14575: MOV TRTRF(XL),TRTRF(XR) REMOVE NAME FROM CHAIN ! 14576: EJC ! 14577: * ! 14578: * DTACH (CONTINUED) ! 14579: * ! 14580: * PREPARE TO RESUME I/O TRBLK SCAN ! 14581: * ! 14582: DTCH5 MOV WA,XL RECOVER XL ... ! 14583: MOV WB,XR ... AND XR ! 14584: ADD *TRVAL,XL POINT TO VALUE FIELD ! 14585: BRN DTCH2 CONTINUE ! 14586: * ! 14587: * EXIT POINT ! 14588: * ! 14589: DTCH6 MOV DTCNB,XR POSSIBLE VRBLK PTR ! 14590: JSR SETVR RESET VRBLK IF NECESSARY ! 14591: EXI RETURN ! 14592: ENP END PROCEDURE DTACH ! 14593: EJC ! 14594: * ! 14595: * DTYPE -- GET DATATYPE NAME ! 14596: * ! 14597: * (XR) OBJECT WHOSE DATATYPE IS REQUIRED ! 14598: * JSR DTYPE CALL TO GET DATATYPE ! 14599: * (XR) RESULT DATATYPE ! 14600: * ! 14601: DTYPE PRC E,0 ENTRY POINT ! 14602: BEQ (XR),=B$PDT,DTYP1 JUMP IF PROG.DEFINED ! 14603: MOV (XR),XR LOAD TYPE WORD ! 14604: LEI XR GET ENTRY POINT ID (BLOCK CODE) ! 14605: WTB XR CONVERT TO BYTE OFFSET ! 14606: MOV SCNMT(XR),XR LOAD TABLE ENTRY ! 14607: EXI EXIT TO DTYPE CALLER ! 14608: * ! 14609: * HERE IF PROGRAM DEFINED ! 14610: * ! 14611: DTYP1 MOV PDDFP(XR),XR POINT TO DFBLK ! 14612: MOV DFNAM(XR),XR GET DATATYPE NAME FROM DFBLK ! 14613: EXI RETURN TO DTYPE CALLER ! 14614: ENP END PROCEDURE DTYPE ! 14615: EJC ! 14616: * ! 14617: * DUMPR -- PRINT DUMP OF STORAGE ! 14618: * ! 14619: * (XR) DUMP ARGUMENT (SEE BELOW) ! 14620: * JSR DUMPR CALL TO PRINT DUMP ! 14621: * (XR,XL) DESTROYED ! 14622: * (WA,WB,WC,RA) DESTROYED ! 14623: * ! 14624: * THE DUMP ARGUMENT HAS THE FOLLOWING SIGNIFICANCE ! 14625: * ! 14626: * DMARG = 0 NO DUMP PRINTED ! 14627: * DMARG = 1 PARTIAL DUMP (NAT VARS, KEYWORDS) ! 14628: * DMARG EQ 2 FULL DUMP (INCL ARRAYS ETC.) ! 14629: * DMARG GE 3 CORE DUMP ! 14630: * ! 14631: * SINCE DUMPR SCRAMBLES STORE, IT IS NOT PERMISSIBLE TO ! 14632: * COLLECT IN MID-DUMP. HENCE A COLLECT IS DONE INITIALLY ! 14633: * AND THEN IF STORE RUNS OUT AN ERROR MESSAGE IS PRODUCED. ! 14634: * ! 14635: DUMPR PRC E,0 ENTRY POINT ! 14636: BZE XR,DMP28 SKIP DUMP IF ARGUMENT IS ZERO ! 14637: BGT XR,=NUM02,DMP29 JUMP IF CORE DUMP REQUIRED ! 14638: ZER XL CLEAR XL ! 14639: ZER WB ZERO MOVE OFFSET ! 14640: MOV XR,DMARG SAVE DUMP ARGUMENT ! 14641: JSR GBCOL COLLECT GARBAGE ! 14642: JSR PRTPG EJECT PRINTER ! 14643: MOV =DMHDV,XR POINT TO HEADING FOR VARIABLES ! 14644: JSR PRTST PRINT IT ! 14645: JSR PRTNL TERMINATE PRINT LINE ! 14646: JSR PRTNL AND PRINT A BLANK LINE ! 14647: * ! 14648: * FIRST ALL NATURAL VARIABLE BLOCKS (VRBLK) WHOSE VALUES ! 14649: * ARE NON-NULL ARE LINKED IN LEXICAL ORDER USING DMVCH AS ! 14650: * THE CHAIN HEAD AND CHAINING THROUGH THE VRGET FIELDS. ! 14651: * NOTE THAT THIS SCRAMBLES STORE IF THE PROCESS IS ! 14652: * INTERRUPTED BEFORE COMPLETION E.G. BY EXCEEDING TIME OR ! 14653: * PRINT LIMITS. SINCE THE SUBSEQUENT CORE DUMPS AND ! 14654: * FAILURES IF EXECUTION IS RESUMED ARE VERY CONFUSING, THE ! 14655: * EXECUTION TIME ERROR ROUTINE CHECKS FOR THIS EVENT AND ! 14656: * ATTEMPTS AN UNSCRAMBLE. SIMILAR PRECAUTIONS SHOULD BE ! 14657: * OBSERVED IF TRANSLATE TIME DUMPING IS IMPLEMENTED. ! 14658: * ! 14659: ZER DMVCH SET NULL CHAIN TO START ! 14660: MOV HSHTB,WA POINT TO HASH TABLE ! 14661: * ! 14662: * LOOP THROUGH HEADERS IN HASH TABLE ! 14663: * ! 14664: DMP00 MOV WA,XR COPY HASH BUCKET POINTER ! 14665: ICA WA BUMP POINTER ! 14666: SUB *VRNXT,XR SET OFFSET TO MERGE ! 14667: * ! 14668: * LOOP THROUGH VRBLKS ON ONE CHAIN ! 14669: * ! 14670: DMP01 MOV VRNXT(XR),XR POINT TO NEXT VRBLK ON CHAIN ! 14671: BZE XR,DMP09 JUMP IF END OF THIS HASH CHAIN ! 14672: MOV XR,XL ELSE COPY VRBLK POINTER ! 14673: EJC ! 14674: * ! 14675: * DUMPR (CONTINUED) ! 14676: * ! 14677: * LOOP TO FIND VALUE AND SKIP IF NULL ! 14678: * ! 14679: DMP02 MOV VRVAL(XL),XL LOAD VALUE ! 14680: BEQ XL,=NULLS,DMP01 LOOP FOR NEXT VRBLK IF NULL VALUE ! 14681: BEQ (XL),=B$TRT,DMP02 LOOP BACK IF VALUE IS TRAPPED ! 14682: * ! 14683: * NON-NULL VALUE, PREPARE TO SEARCH CHAIN ! 14684: * ! 14685: MOV XR,WC SAVE VRBLK POINTER ! 14686: ADD *VRSOF,XR ADJUST PTR TO BE LIKE SCBLK PTR ! 14687: BNZ SCLEN(XR),DMP03 JUMP IF NON-SYSTEM VARIABLE ! 14688: MOV VRSVO(XR),XR ELSE LOAD PTR TO NAME IN SVBLK ! 14689: * ! 14690: * HERE WITH NAME POINTER FOR NEW BLOCK IN XR ! 14691: * ! 14692: DMP03 MOV XR,WB SAVE POINTER TO CHARS ! 14693: MOV WA,DMPSV SAVE HASH BUCKET POINTER ! 14694: MOV =DMVCH,WA POINT TO CHAIN HEAD ! 14695: * ! 14696: * LOOP TO SEARCH CHAIN FOR CORRECT INSERTION POINT ! 14697: * ! 14698: DMP04 MOV WA,DMPCH SAVE CHAIN POINTER ! 14699: MOV WA,XL COPY IT ! 14700: MOV (XL),XR LOAD POINTER TO NEXT ENTRY ! 14701: BZE XR,DMP08 JUMP IF END OF CHAIN TO INSERT ! 14702: ADD *VRSOF,XR ELSE GET NAME PTR FOR CHAINED VRBLK ! 14703: BNZ SCLEN(XR),DMP05 JUMP IF NOT SYSTEM VARIABLE ! 14704: MOV VRSVO(XR),XR ELSE POINT TO NAME IN SVBLK ! 14705: * ! 14706: * HERE PREPARE TO COMPARE THE NAMES ! 14707: * ! 14708: * (WA) SCRATCH ! 14709: * (WB) POINTER TO STRING OF ENTERING VRBLK ! 14710: * (WC) POINTER TO ENTERING VRBLK ! 14711: * (XR) POINTER TO STRING OF CURRENT BLOCK ! 14712: * (XL) SCRATCH ! 14713: * ! 14714: DMP05 MOV WB,XL POINT TO ENTERING VRBLK STRING ! 14715: MOV SCLEN(XL),WA LOAD ITS LENGTH ! 14716: PLC XL POINT TO CHARS OF ENTERING STRING ! 14717: BHI WA,SCLEN(XR),DMP06 JUMP IF ENTERING LENGTH HIGH ! 14718: PLC XR ELSE POINT TO CHARS OF OLD STRING ! 14719: CMC DMP08,DMP07 COMPARE, INSERT IF NEW IS LLT OLD ! 14720: BRN DMP08 OR IF LEQ (WE HAD SHORTER LENGTH) ! 14721: * ! 14722: * HERE WHEN NEW LENGTH IS LONGER THAN OLD LENGTH ! 14723: * ! 14724: DMP06 MOV SCLEN(XR),WA LOAD SHORTER LENGTH ! 14725: PLC XR POINT TO CHARS OF OLD STRING ! 14726: CMC DMP08,DMP07 COMPARE, INSERT IF NEW ONE LOW ! 14727: EJC ! 14728: * ! 14729: * DUMPR (CONTINUED) ! 14730: * ! 14731: * HERE WE MOVE OUT ON THE CHAIN ! 14732: * ! 14733: DMP07 MOV DMPCH,XL COPY CHAIN POINTER ! 14734: MOV (XL),WA MOVE TO NEXT ENTRY ON CHAIN ! 14735: BRN DMP04 LOOP BACK ! 14736: * ! 14737: * HERE AFTER LOCATING THE PROPER INSERTION POINT ! 14738: * ! 14739: DMP08 MOV DMPCH,XL COPY CHAIN POINTER ! 14740: MOV DMPSV,WA RESTORE HASH BUCKET POINTER ! 14741: MOV WC,XR RESTORE VRBLK POINTER ! 14742: MOV (XL),VRGET(XR) LINK VRBLK TO REST OF CHAIN ! 14743: MOV XR,(XL) LINK VRBLK INTO CURRENT CHAIN LOC ! 14744: BRN DMP01 LOOP BACK FOR NEXT VRBLK ! 14745: * ! 14746: * HERE AFTER PROCESSING ALL VRBLKS ON ONE CHAIN ! 14747: * ! 14748: DMP09 BNE WA,HSHTE,DMP00 LOOP BACK IF MORE BUCKETS TO GO ! 14749: * ! 14750: * LOOP TO GENERATE DUMP OF NATURAL VARIABLE VALUES ! 14751: * ! 14752: DMP10 MOV DMVCH,XR LOAD POINTER TO NEXT ENTRY ON CHAIN ! 14753: BZE XR,DMP11 JUMP IF END OF CHAIN ! 14754: MOV (XR),DMVCH ELSE UPDATE CHAIN PTR TO NEXT ENTRY ! 14755: JSR SETVR RESTORE VRGET FIELD ! 14756: MOV XR,XL COPY VRBLK POINTER (NAME BASE) ! 14757: MOV *VRVAL,WA SET OFFSET FOR VRBLK NAME ! 14758: JSR PRTNV PRINT NAME = VALUE ! 14759: BRN DMP10 LOOP BACK TILL ALL PRINTED ! 14760: * ! 14761: * PREPARE TO PRINT KEYWORDS ! 14762: * ! 14763: DMP11 JSR PRTNL PRINT BLANK LINE ! 14764: JSR PRTNL AND ANOTHER ! 14765: MOV =DMHDK,XR POINT TO KEYWORD HEADING ! 14766: JSR PRTST PRINT HEADING ! 14767: JSR PRTNL END LINE ! 14768: JSR PRTNL PRINT ONE BLANK LINE ! 14769: MOV =VDMKW,XL POINT TO LIST OF KEYWORD SVBLK PTRS ! 14770: EJC ! 14771: * ! 14772: * DUMPR (CONTINUED) ! 14773: * ! 14774: * LOOP TO DUMP KEYWORD VALUES ! 14775: * ! 14776: DMP12 MOV (XL)+,XR LOAD NEXT SVBLK PTR FROM TABLE ! 14777: BZE XR,DMP13 JUMP IF END OF LIST ! 14778: MOV =CH$AM,WA LOAD AMPERSAND ! 14779: JSR PRTCH PRINT AMPERSAND ! 14780: JSR PRTST PRINT KEYWORD NAME ! 14781: MOV SVLEN(XR),WA LOAD NAME LENGTH FROM SVBLK ! 14782: CTB WA,SVCHS GET LENGTH OF NAME ! 14783: ADD WA,XR POINT TO SVKNM FIELD ! 14784: MOV (XR),DMPKN STORE IN DUMMY KVBLK ! 14785: MOV =TMBEB,XR POINT TO BLANK-EQUAL-BLANK ! 14786: JSR PRTST PRINT IT ! 14787: MOV XL,DMPSV SAVE TABLE POINTER ! 14788: MOV =DMPKB,XL POINT TO DUMMY KVBLK ! 14789: MOV *KVVAR,WA SET ZERO OFFSET ! 14790: JSR ACESS GET KEYWORD VALUE ! 14791: PPM FAILURE IS IMPOSSIBLE ! 14792: JSR PRTVL PRINT KEYWORD VALUE ! 14793: JSR PRTNL TERMINATE PRINT LINE ! 14794: MOV DMPSV,XL RESTORE TABLE POINTER ! 14795: BRN DMP12 LOOP BACK TILL ALL PRINTED ! 14796: * ! 14797: * HERE AFTER COMPLETING PARTIAL DUMP ! 14798: * ! 14799: DMP13 BEQ DMARG,=NUM01,DMP27 EXIT IF PARTIAL DUMP COMPLETE ! 14800: MOV DNAMB,XR ELSE POINT TO FIRST DYNAMIC BLOCK ! 14801: * ! 14802: * LOOP THROUGH BLOCKS IN DYNAMIC STORAGE ! 14803: * ! 14804: DMP14 BEQ XR,DNAMP,DMP27 JUMP IF END OF USED REGION ! 14805: MOV (XR),WA ELSE LOAD FIRST WORD OF BLOCK ! 14806: BEQ WA,=B$VCT,DMP16 JUMP IF VECTOR ! 14807: BEQ WA,=B$ART,DMP17 JUMP IF ARRAY ! 14808: BEQ WA,=B$PDT,DMP18 JUMP IF PROGRAM DEFINED ! 14809: BEQ WA,=B$TBT,DMP19 JUMP IF TABLE ! 14810: BEQ WA,=B$BCT,DMP30 JUMP IF BUFFER ! 14811: * ! 14812: * MERGE HERE TO MOVE TO NEXT BLOCK ! 14813: * ! 14814: DMP15 JSR BLKLN GET LENGTH OF BLOCK ! 14815: ADD WA,XR POINT PAST THIS BLOCK ! 14816: BRN DMP14 LOOP BACK FOR NEXT BLOCK ! 14817: EJC ! 14818: * ! 14819: * DUMPR (CONTINUED) ! 14820: * ! 14821: * HERE FOR VECTOR ! 14822: * ! 14823: DMP16 MOV *VCVLS,WB SET OFFSET TO FIRST VALUE ! 14824: BRN DMP19 JUMP TO MERGE ! 14825: * ! 14826: * HERE FOR ARRAY ! 14827: * ! 14828: DMP17 MOV AROFS(XR),WB SET OFFSET TO ARPRO FIELD ! 14829: ICA WB BUMP TO GET OFFSET TO VALUES ! 14830: BRN DMP19 JUMP TO MERGE ! 14831: * ! 14832: * HERE FOR PROGRAM DEFINED ! 14833: * ! 14834: DMP18 MOV *PDFLD,WB POINT TO VALUES, MERGE ! 14835: * ! 14836: * HERE FOR TABLE (OTHERS MERGE) ! 14837: * ! 14838: DMP19 BZE IDVAL(XR),DMP15 IGNORE BLOCK IF ZERO ID VALUE ! 14839: JSR BLKLN ELSE GET BLOCK LENGTH ! 14840: MOV XR,XL COPY BLOCK POINTER ! 14841: MOV WA,DMPSV SAVE LENGTH ! 14842: MOV WB,WA COPY OFFSET TO FIRST VALUE ! 14843: JSR PRTNL PRINT BLANK LINE ! 14844: MOV WA,DMPSA PRESERVE OFFSET ! 14845: JSR PRTVL PRINT BLOCK VALUE (FOR TITLE) ! 14846: MOV DMPSA,WA RECOVER OFFSET ! 14847: JSR PRTNL END PRINT LINE ! 14848: BEQ (XR),=B$TBT,DMP22 JUMP IF TABLE ! 14849: DCA WA POINT BEFORE FIRST WORD ! 14850: * ! 14851: * LOOP TO PRINT CONTENTS OF ARRAY, VECTOR, OR PROGRAM DEF ! 14852: * ! 14853: DMP20 MOV XL,XR COPY BLOCK POINTER ! 14854: ICA WA BUMP OFFSET ! 14855: ADD WA,XR POINT TO NEXT VALUE ! 14856: BEQ WA,DMPSV,DMP14 EXIT IF END (XR PAST BLOCK) ! 14857: SUB *VRVAL,XR SUBTRACT OFFSET TO MERGE INTO LOOP ! 14858: * ! 14859: * LOOP TO FIND VALUE AND IGNORE NULLS ! 14860: * ! 14861: DMP21 MOV VRVAL(XR),XR LOAD NEXT VALUE ! 14862: BEQ XR,=NULLS,DMP20 LOOP BACK IF NULL VALUE ! 14863: BEQ (XR),=B$TRT,DMP21 LOOP BACK IF TRAPPED ! 14864: JSR PRTNV ELSE PRINT NAME = VALUE ! 14865: BRN DMP20 LOOP BACK FOR NEXT FIELD ! 14866: EJC ! 14867: * ! 14868: * DUMPR (CONTINUED) ! 14869: * ! 14870: * HERE TO DUMP A TABLE ! 14871: * ! 14872: DMP22 MOV *TBBUK,WC SET OFFSET TO FIRST BUCKET ! 14873: MOV *TEVAL,WA SET NAME OFFSET FOR ALL TEBLKS ! 14874: * ! 14875: * LOOP THROUGH TABLE BUCKETS ! 14876: * ! 14877: DMP23 MOV XL,-(XS) SAVE TBBLK POINTER ! 14878: ADD WC,XL POINT TO NEXT BUCKET HEADER ! 14879: ICA WC BUMP BUCKET OFFSET ! 14880: SUB *TENXT,XL SUBTRACT OFFSET TO MERGE INTO LOOP ! 14881: * ! 14882: * LOOP TO PROCESS TEBLKS ON ONE CHAIN ! 14883: * ! 14884: DMP24 MOV TENXT(XL),XL POINT TO NEXT TEBLK ! 14885: BEQ XL,(XS),DMP26 JUMP IF END OF CHAIN ! 14886: MOV XL,XR ELSE COPY TEBLK POINTER ! 14887: * ! 14888: * LOOP TO FIND VALUE AND IGNORE IF NULL ! 14889: * ! 14890: DMP25 MOV TEVAL(XR),XR LOAD NEXT VALUE ! 14891: BEQ XR,=NULLS,DMP24 IGNORE IF NULL VALUE ! 14892: BEQ (XR),=B$TRT,DMP25 LOOP BACK IF TRAPPED ! 14893: MOV WC,DMPSV ELSE SAVE OFFSET POINTER ! 14894: JSR PRTNV PRINT NAME = VALUE ! 14895: MOV DMPSV,WC RELOAD OFFSET ! 14896: BRN DMP24 LOOP BACK FOR NEXT TEBLK ! 14897: * ! 14898: * HERE TO MOVE TO NEXT HASH CHAIN ! 14899: * ! 14900: DMP26 MOV (XS)+,XL RESTORE TBBLK POINTER ! 14901: BNE WC,TBLEN(XL),DMP23 LOOP BACK IF MORE BUCKETS TO GO ! 14902: MOV XL,XR ELSE COPY TABLE POINTER ! 14903: ADD WC,XR POINT TO FOLLOWING BLOCK ! 14904: BRN DMP14 LOOP BACK TO PROCESS NEXT BLOCK ! 14905: * ! 14906: * HERE AFTER COMPLETING DUMP ! 14907: * ! 14908: DMP27 JSR PRTPG EJECT PRINTER ! 14909: * ! 14910: * MERGE HERE IF NO DUMP GIVEN (DMARG=0) ! 14911: * ! 14912: DMP28 EXI RETURN TO DUMP CALLER ! 14913: * ! 14914: * CALL SYSTEM CORE DUMP ROUTINE ! 14915: * ! 14916: DMP29 JSR SYSDM CALL IT ! 14917: BRN DMP28 RETURN ! 14918: EJC ! 14919: * ! 14920: * DUMPR (CONTINUED) ! 14921: * ! 14922: * HERE TO DUMP BUFFER BLOCK ! 14923: * ! 14924: DMP30 JSR PRTNL PRINT BLANK LINE ! 14925: JSR PRTVL PRINT VALUE ID FOR TITLE ! 14926: JSR PRTNL FORCE NEW LINE ! 14927: MOV =CH$DQ,WA LOAD DOUBLE QUOTE ! 14928: JSR PRTCH PRINT IT ! 14929: MOV BCLEN(XR),WC LOAD DEFINED LENGTH ! 14930: BZE WC,DMP32 SKIP CHARACTERS IF NONE ! 14931: LCT WC,WC LOAD COUNT FOR LOOP ! 14932: MOV XR,WB SAVE BCBLK PTR ! 14933: MOV BCBUF(XR),XR POINT TO BFBLK ! 14934: PLC XR GET SET TO LOAD CHARACTERS ! 14935: * ! 14936: * LOOP HERE STUFFING CHARACTERS IN OUTPUT STREAM ! 14937: * ! 14938: DMP31 LCH WA,(XR)+ GET NEXT CHARACTER ! 14939: JSR PRTCH STUFF IT ! 14940: BCT WC,DMP31 BRANCH FOR NEXT ONE ! 14941: MOV WB,XR RESTORE BCBLK POINTER ! 14942: * ! 14943: * MERGE TO STUFF CLOSING QUOTE MARK ! 14944: * ! 14945: DMP32 MOV =CH$DQ,WA STUFF QUOTE ! 14946: JSR PRTCH PRINT IT ! 14947: JSR PRTNL PRINT NEW LINE ! 14948: MOV (XR),WA GET FIRST WD FOR BLKLN ! 14949: BRN DMP15 MERGE TO GET NEXT BLOCK ! 14950: ENP END PROCEDURE DUMPR ! 14951: EJC ! 14952: * ! 14953: * ERMSG -- PRINT ERROR CODE AND ERROR MESSAGE ! 14954: * ! 14955: * KVERT ERROR CODE ! 14956: * JSR ERMSG CALL TO PRINT MESSAGE ! 14957: * (XR,XL,WA,WB,WC,IA) DESTROYED ! 14958: * ! 14959: ERMSG PRC E,0 ENTRY POINT ! 14960: JSR PRTIS PRINT ERROR PTR OR BLANK LINE ! 14961: MOV KVERT,WA LOAD ERROR CODE ! 14962: MOV =ERMMS,XR POINT TO ERROR MESSAGE /ERROR/ ! 14963: JSR PRTST PRINT IT ! 14964: JSR ERTEX GET ERROR MESSAGE TEXT ! 14965: ADD =THSND,WA BUMP ERROR CODE FOR PRINT ! 14966: MTI WA FAIL CODE IN INT ACC ! 14967: JSR PRTIN PRINT CODE (NOW HAVE ERROR1XXX) ! 14968: MOV PRBUF,XL POINT TO PRINT BUFFER ! 14969: PSC XL,=NUM05 POINT TO THE 1 ! 14970: MOV =CH$BL,WA LOAD A BLANK ! 14971: SCH WA,(XL) STORE BLANK OVER 1 (ERROR XXX) ! 14972: CSC XL COMPLETE STORE CHARACTERS ! 14973: ZER XL CLEAR GARBAGE POINTER IN XL ! 14974: MOV XR,WA KEEP ERROR TEXT ! 14975: MOV =ERMNS,XR POINT TO / -- / ! 14976: JSR PRTST PRINT IT ! 14977: MOV WA,XR GET ERROR TEXT AGAIN ! 14978: JSR PRTST PRINT ERROR MESSAGE TEXT ! 14979: JSR PRTIS PRINT LINE ! 14980: JSR PRTIS PRINT BLANK LINE ! 14981: EXI RETURN TO ERMSG CALLER ! 14982: ENP END PROCEDURE ERMSG ! 14983: EJC ! 14984: * ! 14985: * ERTEX -- GET ERROR MESSAGE TEXT ! 14986: * ! 14987: * (WA) ERROR CODE ! 14988: * JSR ERTEX CALL TO GET ERROR TEXT ! 14989: * (XR) PTR TO ERROR TEXT IN DYNAMIC ! 14990: * (R$ETX) COPY OF PTR TO ERROR TEXT ! 14991: * (XL,WC,IA) DESTROYED ! 14992: * ! 14993: ERTEX PRC E,0 ENTRY POINT ! 14994: MOV WA,ERTWA SAVE WA ! 14995: MOV WB,ERTWB SAVE WB ! 14996: JSR SYSEM GET FAILURE MESSAGE TEXT ! 14997: MOV XR,XL COPY POINTER TO IT ! 14998: MOV SCLEN(XR),WA GET LENGTH OF STRING ! 14999: BZE WA,ERT02 JUMP IF NULL ! 15000: ZER WB OFFSET OF ZERO ! 15001: JSR SBSTR COPY INTO DYNAMIC STORE ! 15002: MOV XR,R$ETX STORE FOR RELOCATION ! 15003: * ! 15004: * RETURN ! 15005: * ! 15006: ERT01 MOV ERTWB,WB RESTORE WB ! 15007: MOV ERTWA,WA RESTORE WA ! 15008: EXI RETURN TO CALLER ! 15009: * ! 15010: * RETURN ERRTEXT CONTENTS INSTEAD OF NULL ! 15011: * ! 15012: ERT02 MOV R$ETX,XR GET ERRTEXT ! 15013: BRN ERT01 RETURN ! 15014: ENP ! 15015: EJC ! 15016: * ! 15017: * EVALI -- EVALUATE INTEGER ARGUMENT ! 15018: * ! 15019: * EVALI IS USED BY PATTERN PRIMITIVES LEN,TAB,RTAB,POS,RPOS ! 15020: * WHEN THEIR ARGUMENT IS AN EXPRESSION VALUE. ! 15021: * ! 15022: * (XR) NODE POINTER ! 15023: * (WB) CURSOR ! 15024: * JSR EVALI CALL TO EVALUATE INTEGER ! 15025: * PPM LOC TRANSFER LOC FOR NON-INTEGER ARG ! 15026: * PPM LOC TRANSFER LOC FOR OUT OF RANGE ARG ! 15027: * PPM LOC TRANSFER LOC FOR EVALUATION FAILURE ! 15028: * PPM LOC TRANSFER LOC FOR SUCCESSFUL EVAL ! 15029: * (THE NORMAL RETURN IS NEVER TAKEN) ! 15030: * (XR) PTR TO NODE WITH INTEGER ARGUMENT ! 15031: * (WC,XL,RA) DESTROYED ! 15032: * ! 15033: * ON RETURN, THE NODE POINTED TO HAS THE INTEGER ARGUMENT ! 15034: * IN PARM1 AND THE PROPER SUCCESSOR POINTER IN PTHEN. ! 15035: * THIS ALLOWS MERGING WITH THE NORMAL (INTEGER ARG) CASE. ! 15036: * ! 15037: EVALI PRC R,4 ENTRY POINT (RECURSIVE) ! 15038: JSR EVALP EVALUATE EXPRESSION ! 15039: PPM EVLI1 JUMP ON FAILURE ! 15040: MOV XL,-(XS) STACK RESULT FOR GTSMI ! 15041: MOV PTHEN(XR),XL LOAD SUCCESSOR POINTER ! 15042: JSR GTSMI CONVERT ARG TO SMALL INTEGER ! 15043: PPM EVLI2 JUMP IF NOT INTEGER ! 15044: PPM EVLI3 JUMP IF OUT OF RANGE ! 15045: MOV XR,EVLIV STORE RESULT IN SPECIAL DUMMY NODE ! 15046: MOV XL,EVLIS STORE SUCCESSOR POINTER ! 15047: MOV =EVLIN,XR POINT TO DUMMY NODE WITH RESULT ! 15048: EXI 4 TAKE SUCCESSFUL EXIT ! 15049: * ! 15050: * HERE IF EVALUATION FAILS ! 15051: * ! 15052: EVLI1 EXI 3 TAKE FAILURE RETURN ! 15053: * ! 15054: * HERE IF ARGUMENT IS NOT INTEGER ! 15055: * ! 15056: EVLI2 EXI 1 TAKE NON-INTEGER ERROR EXIT ! 15057: * ! 15058: * HERE IF ARGUMENT IS OUT OF RANGE ! 15059: * ! 15060: EVLI3 EXI 2 TAKE OUT-OF-RANGE ERROR EXIT ! 15061: ENP END PROCEDURE EVALI ! 15062: EJC ! 15063: * ! 15064: * EVALP -- EVALUATE EXPRESSION DURING PATTERN MATCH ! 15065: * ! 15066: * EVALP IS USED TO EVALUATE AN EXPRESSION (BY VALUE) DURING ! 15067: * A PATTERN MATCH. THE EFFECT IS LIKE EVALX, BUT PATTERN ! 15068: * VARIABLES ARE STACKED AND RESTORED IF NECESSARY. ! 15069: * ! 15070: * EVALP ALSO DIFFERS FROM EVALX IN THAT IF THE RESULT IS ! 15071: * AN EXPRESSION IT IS REEVALUATED. THIS OCCURS REPEATEDLY. ! 15072: * ! 15073: * (XR) NODE POINTER ! 15074: * (WB) PATTERN MATCH CURSOR ! 15075: * JSR EVALP CALL TO EVALUATE EXPRESSION ! 15076: * PPM LOC TRANSFER LOC IF EVALUATION FAILS ! 15077: * (XL) RESULT ! 15078: * (WA) FIRST WORD OF RESULT BLOCK ! 15079: * (XR,WB) DESTROYED (FAILURE CASE ONLY) ! 15080: * (WC,RA) DESTROYED ! 15081: * ! 15082: * THE EXPRESSION POINTER IS STORED IN PARM1 OF THE NODE ! 15083: * ! 15084: * CONTROL RETURNS TO FAILP ON FAILURE OF EVALUATION ! 15085: * ! 15086: EVALP PRC R,1 ENTRY POINT (RECURSIVE) ! 15087: MOV PARM1(XR),XL LOAD EXPRESSION POINTER ! 15088: BEQ (XL),=B$EXL,EVLP1 JUMP IF EXBLK CASE ! 15089: * ! 15090: * HERE FOR CASE OF SEBLK ! 15091: * ! 15092: * WE CAN GIVE A FAST RETURN IF THE VALUE OF THE VRBLK IS ! 15093: * NOT AN EXPRESSION AND IS NOT TRAPPED. ! 15094: * ! 15095: MOV SEVAR(XL),XL LOAD VRBLK POINTER ! 15096: MOV VRVAL(XL),XL LOAD VALUE OF VRBLK ! 15097: MOV (XL),WA LOAD FIRST WORD OF VALUE ! 15098: BHI WA,=B$T$$,EVLP3 JUMP IF NOT SEBLK, TRBLK OR EXBLK ! 15099: * ! 15100: * HERE FOR EXBLK OR SEBLK WITH EXPR VALUE OR TRAPPED VALUE ! 15101: * ! 15102: EVLP1 MOV XR,-(XS) STACK NODE POINTER ! 15103: MOV WB,-(XS) STACK CURSOR ! 15104: MOV R$PMS,-(XS) STACK SUBJECT STRING POINTER ! 15105: MOV PMSSL,-(XS) STACK SUBJECT STRING LENGTH ! 15106: MOV PMDFL,-(XS) STACK DOT FLAG ! 15107: MOV PMHBS,-(XS) STACK HISTORY STACK BASE POINTER ! 15108: MOV PARM1(XR),XR LOAD EXPRESSION POINTER ! 15109: EJC ! 15110: * ! 15111: * EVALP (CONTINUED) ! 15112: * ! 15113: * LOOP BACK HERE TO REEVALUATE EXPRESSION RESULT ! 15114: * ! 15115: EVLP2 ZER WB SET FLAG FOR BY VALUE ! 15116: JSR EVALX EVALUATE EXPRESSION ! 15117: PPM EVLP4 JUMP ON FAILURE ! 15118: MOV (XR),WA ELSE LOAD FIRST WORD OF VALUE ! 15119: BLO WA,=B$E$$,EVLP2 LOOP BACK TO REEVALUATE EXPRESSION ! 15120: * ! 15121: * HERE TO RESTORE PATTERN VALUES AFTER SUCCESSFUL EVAL ! 15122: * ! 15123: MOV XR,XL COPY RESULT POINTER ! 15124: MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER ! 15125: MOV (XS)+,PMDFL RESTORE DOT FLAG ! 15126: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH ! 15127: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER ! 15128: MOV (XS)+,WB RESTORE CURSOR ! 15129: MOV (XS)+,XR RESTORE NODE POINTER ! 15130: * ! 15131: * COMMON EXIT POINT ! 15132: * ! 15133: EVLP3 EXI RETURN TO EVALP CALLER ! 15134: * ! 15135: * HERE FOR FAILURE DURING EVALUATION ! 15136: * ! 15137: EVLP4 MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER ! 15138: MOV (XS)+,PMDFL RESTORE DOT FLAG ! 15139: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH ! 15140: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER ! 15141: ADD *NUM02,XS REMOVE NODE PTR, CURSOR ! 15142: EXI 1 TAKE FAILURE EXIT ! 15143: ENP END PROCEDURE EVALP ! 15144: EJC ! 15145: * ! 15146: * EVALS -- EVALUATE STRING ARGUMENT ! 15147: * ! 15148: * EVALS IS USED BY SPAN, ANY, NOTANY, BREAK, BREAKX WHEN ! 15149: * THEY ARE PASSED AN EXPRESSION ARGUMENT. ! 15150: * ! 15151: * (XR) NODE POINTER ! 15152: * (WB) CURSOR ! 15153: * JSR EVALS CALL TO EVALUATE STRING ! 15154: * PPM LOC TRANSFER LOC FOR NON-STRING ARG ! 15155: * PPM LOC TRANSFER LOC FOR EVALUATION FAILURE ! 15156: * PPM LOC TRANSFER LOC FOR SUCCESSFUL EVAL ! 15157: * (THE NORMAL RETURN IS NEVER TAKEN) ! 15158: * (XR) PTR TO NODE WITH PARMS SET ! 15159: * (XL,WC,RA) DESTROYED ! 15160: * ! 15161: * ON RETURN, THE NODE POINTED TO HAS A CHARACTER TABLE ! 15162: * POINTER IN PARM1 AND A BIT MASK IN PARM2. THE PROPER ! 15163: * SUCCESSOR IS STORED IN PTHEN OF THIS NODE. THUS IT IS ! 15164: * OK FOR MERGING WITH THE NORMAL (MULTI-CHAR STRING) CASE. ! 15165: * ! 15166: EVALS PRC R,3 ENTRY POINT (RECURSIVE) ! 15167: JSR EVALP EVALUATE EXPRESSION ! 15168: PPM EVLS1 JUMP IF EVALUATION FAILS ! 15169: MOV PTHEN(XR),-(XS) SAVE SUCCESSOR POINTER ! 15170: MOV WB,-(XS) SAVE CURSOR ! 15171: MOV XL,-(XS) STACK RESULT PTR FOR PATST ! 15172: ZER WB DUMMY PCODE FOR ONE CHAR STRING ! 15173: ZER WC DUMMY PCODE FOR EXPRESSION ARG ! 15174: MOV =P$BRK,XL APPROPRIATE PCODE FOR OUR USE ! 15175: JSR PATST CALL ROUTINE TO BUILD NODE ! 15176: PPM EVLS2 JUMP IF NOT STRING ! 15177: MOV (XS)+,WB RESTORE CURSOR ! 15178: MOV (XS)+,PTHEN(XR) STORE SUCCESSOR POINTER ! 15179: EXI 3 TAKE SUCCESS RETURN ! 15180: * ! 15181: * HERE IF EVALUATION FAILS ! 15182: * ! 15183: EVLS1 EXI 2 TAKE FAILURE RETURN ! 15184: * ! 15185: * HERE IF ARGUMENT IS NOT STRING ! 15186: * ! 15187: EVLS2 ADD *NUM02,XS POP SUCCESSOR AND CURSOR ! 15188: EXI 1 TAKE NON-STRING ERROR EXIT ! 15189: ENP END PROCEDURE EVALS ! 15190: EJC ! 15191: * ! 15192: * EVALX -- EVALUATE EXPRESSION ! 15193: * ! 15194: * EVALX IS CALLED TO EVALUATE AN EXPRESSION ! 15195: * ! 15196: * (XR) POINTER TO EXBLK OR SEBLK ! 15197: * (WB) 0 IF BY VALUE, 1 IF BY NAME ! 15198: * JSR EVALX CALL TO EVALUATE EXPRESSION ! 15199: * PPM LOC TRANSFER LOC IF EVALUATION FAILS ! 15200: * (XR) RESULT IF CALLED BY VALUE ! 15201: * (XL,WA) RESULT NAME BASE,OFFSET IF BY NAME ! 15202: * (XR) DESTROYED (NAME CASE ONLY) ! 15203: * (XL,WA) DESTROYED (VALUE CASE ONLY) ! 15204: * (WB,WC,RA) DESTROYED ! 15205: * ! 15206: EVALX PRC R,1 ENTRY POINT, RECURSIVE ! 15207: BEQ (XR),=B$EXL,EVLX2 JUMP IF EXBLK CASE ! 15208: * ! 15209: * HERE FOR SEBLK ! 15210: * ! 15211: MOV SEVAR(XR),XL LOAD VRBLK POINTER (NAME BASE) ! 15212: MOV *VRVAL,WA SET NAME OFFSET ! 15213: BNZ WB,EVLX1 JUMP IF CALLED BY NAME ! 15214: JSR ACESS CALL ROUTINE TO ACCESS VALUE ! 15215: PPM EVLX9 JUMP IF FAILURE ON ACCESS ! 15216: * ! 15217: * MERGE HERE TO EXIT FOR SEBLK CASE ! 15218: * ! 15219: EVLX1 EXI RETURN TO EVALX CALLER ! 15220: EJC ! 15221: * ! 15222: * EVALX (CONTINUED) ! 15223: * ! 15224: * HERE FOR FULL EXPRESSION (EXBLK) CASE ! 15225: * ! 15226: * IF AN ERROR OCCURS IN THE EXPRESSION CODE AT EXECUTION ! 15227: * TIME, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL ! 15228: * WITHOUT RETURNING TO THIS ROUTINE. ! 15229: * THE FOLLOWING ENTRIES ARE MADE ON THE STACK BEFORE ! 15230: * GIVING CONTROL TO THE EXPRESSION CODE ! 15231: * ! 15232: * EVALX RETURN POINT ! 15233: * SAVED VALUE OF R$COD ! 15234: * CODE POINTER (-R$COD) ! 15235: * SAVED VALUE OF FLPTR ! 15236: * 0 IF BY VALUE, 1 IF BY NAME ! 15237: * FLPTR --------------- *EXFLC, FAIL OFFSET IN EXBLK ! 15238: * ! 15239: EVLX2 SCP WC GET CODE POINTER ! 15240: MOV R$COD,WA LOAD CODE BLOCK POINTER ! 15241: SUB WA,WC GET CODE POINTER AS OFFSET ! 15242: MOV WA,-(XS) STACK OLD CODE BLOCK POINTER ! 15243: MOV WC,-(XS) STACK RELATIVE CODE OFFSET ! 15244: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER ! 15245: MOV WB,-(XS) STACK NAME/VALUE INDICATOR ! 15246: MOV *EXFLC,-(XS) STACK NEW FAIL OFFSET ! 15247: MOV FLPTR,GTCEF KEEP IN CASE OF ERROR ! 15248: MOV R$COD,R$GTC KEEP CODE BLOCK POINTER SIMILARLY ! 15249: MOV XS,FLPTR SET NEW FAILURE POINTER ! 15250: MOV XR,R$COD SET NEW CODE BLOCK POINTER ! 15251: MOV KVSTN,EXSTM(XR) REMEMBER STMNT NUMBER ! 15252: ADD *EXCOD,XR POINT TO FIRST CODE WORD ! 15253: LCP XR SET CODE POINTER ! 15254: BNE STAGE,=STGXT,EXITS JUMP IF NOT EXECUTION TIME ! 15255: MOV =STGEE,STAGE EVALUATING EXPRESSION ! 15256: BRN EXITS JUMP TO EXECUTE FIRST CODE WORD ! 15257: EJC ! 15258: * ! 15259: * EVALX (CONTINUED) ! 15260: * ! 15261: * COME HERE IF SUCCESSFUL RETURN BY VALUE (SEE O$RVL) ! 15262: * ! 15263: EVLX3 MOV (XS)+,XR LOAD VALUE ! 15264: BZE 1(XS),EVLX5 JUMP IF CALLED BY VALUE ! 15265: ERB 249,EXPRESSION EVALUATED BY NAME RETURNED VALUE ! 15266: * ! 15267: * HERE FOR EXPRESSION RETURNING BY NAME (SEE O$RNM) ! 15268: * ! 15269: EVLX4 MOV (XS)+,WA LOAD NAME OFFSET ! 15270: MOV (XS)+,XL LOAD NAME BASE ! 15271: BNZ 1(XS),EVLX5 JUMP IF CALLED BY NAME ! 15272: JSR ACESS ELSE ACCESS VALUE FIRST ! 15273: PPM EVLX6 JUMP IF FAILURE DURING ACCESS ! 15274: * ! 15275: * HERE AFTER LOADING CORRECT RESULT INTO XR OR XL,WA ! 15276: * ! 15277: EVLX5 ZER WB NOTE SUCCESSFUL ! 15278: BRN EVLX7 MERGE ! 15279: * ! 15280: * HERE FOR FAILURE IN EXPRESSION EVALUATION (SEE O$FEX) ! 15281: * ! 15282: EVLX6 MNZ WB NOTE UNSUCCESSFUL ! 15283: * ! 15284: * RESTORE ENVIRONMENT ! 15285: * ! 15286: EVLX7 BNE STAGE,=STGEE,EVLX8 SKIP IF WAS NOT PREVIOUSLY XT ! 15287: MOV =STGXT,STAGE EXECUTE TIME ! 15288: * ! 15289: * MERGE WITH STAGE SET UP ! 15290: * ! 15291: EVLX8 ADD *NUM02,XS POP NAME/VALUE INDICATOR, *EXFAL ! 15292: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER ! 15293: MOV (XS)+,WC LOAD CODE OFFSET ! 15294: ADD (XS),WC MAKE CODE POINTER ABSOLUTE ! 15295: MOV (XS)+,R$COD RESTORE OLD CODE BLOCK POINTER ! 15296: LCP WC RESTORE OLD CODE POINTER ! 15297: BZE WB,EVLX1 JUMP FOR SUCCESSFUL RETURN ! 15298: * ! 15299: * MERGE HERE FOR FAILURE IN SEBLK CASE ! 15300: * ! 15301: EVLX9 EXI 1 TAKE FAILURE EXIT ! 15302: ENP END OF PROCEDURE EVALX ! 15303: EJC ! 15304: * ! 15305: * EXBLD -- BUILD EXBLK ! 15306: * ! 15307: * EXBLD IS USED TO BUILD AN EXPRESSION BLOCK FROM THE ! 15308: * CODE COMPILED MOST RECENTLY IN THE CURRENT CCBLK. ! 15309: * ! 15310: * (XL) OFFSET IN CCBLK TO START OF CODE ! 15311: * (WB) INTEGER IN RANGE 0 LE N LE MXLEN ! 15312: * JSR EXBLD CALL TO BUILD EXBLK ! 15313: * (XR) PTR TO CONSTRUCTED EXBLK ! 15314: * (WA,WB,XL) DESTROYED ! 15315: * ! 15316: EXBLD PRC E,0 ENTRY POINT ! 15317: MOV XL,WA COPY OFFSET TO START OF CODE ! 15318: SUB *EXCOD,WA CALC REDUCTION IN OFFSET IN EXBLK ! 15319: MOV WA,-(XS) STACK FOR LATER ! 15320: MOV CWCOF,WA LOAD FINAL OFFSET ! 15321: SUB XL,WA COMPUTE LENGTH OF CODE ! 15322: ADD *EXSI$,WA ADD SPACE FOR STANDARD FIELDS ! 15323: JSR ALLOC ALLOCATE SPACE FOR EXBLK ! 15324: MOV XR,-(XS) SAVE POINTER TO EXBLK ! 15325: MOV =B$EXL,EXTYP(XR) STORE TYPE WORD ! 15326: ZER EXSTM(XR) ZEROISE STMNT NUMBER FIELD ! 15327: MOV WA,EXLEN(XR) STORE LENGTH ! 15328: MOV =OFEX$,EXFLC(XR) STORE FAILURE WORD ! 15329: ADD *EXSI$,XR SET XR FOR SYSMW ! 15330: MOV XL,CWCOF RESET OFFSET TO START OF CODE ! 15331: ADD R$CCB,XL POINT TO START OF CODE ! 15332: SUB *EXSI$,WA LENGTH OF CODE TO MOVE ! 15333: MOV WA,-(XS) STACK LENGTH OF CODE ! 15334: MVW MOVE CODE TO EXBLK ! 15335: MOV (XS)+,WA GET LENGTH OF CODE ! 15336: BTW WA CONVERT BYTE COUNT TO WORD COUNT ! 15337: LCT WA,WA PREPARE COUNTER FOR LOOP ! 15338: MOV (XS),XL COPY EXBLK PTR, DONT UNSTACK ! 15339: ADD *EXCOD,XL POINT TO CODE ITSELF ! 15340: MOV 1(XS),WB GET REDUCTION IN OFFSET ! 15341: * ! 15342: * THIS LOOP SEARCHES FOR NEGATION AND SELECTION CODE SO ! 15343: * THAT THE OFFSETS COMPUTED WHILST CODE WAS IN CODE BLOCK ! 15344: * CAN BE TRANSFORMED TO REDUCED VALUES APPLICABLE IN AN ! 15345: * EXBLK. ! 15346: * ! 15347: EXBL1 MOV (XL)+,XR GET NEXT CODE WORD ! 15348: BEQ XR,=OSLA$,EXBL3 JUMP IF SELECTION FOUND ! 15349: BEQ XR,=ONTA$,EXBL3 JUMP IF NEGATION FOUND ! 15350: BCT WA,EXBL1 LOOP TO END OF CODE ! 15351: * ! 15352: * NO SELECTION FOUND OR MERGE TO EXIT ON TERMINATION ! 15353: * ! 15354: EXBL2 MOV (XS)+,XR POP EXBLK PTR INTO XR ! 15355: MOV (XS)+,XL POP REDUCTION CONSTANT ! 15356: EXI RETURN TO CALLER ! 15357: EJC ! 15358: * ! 15359: * EXBLD (CONTINUED) ! 15360: * ! 15361: * SELECTION OR NEGATION FOUND ! 15362: * REDUCE THE OFFSETS AS NEEDED. OFFSETS OCCUR IN WORDS ! 15363: * FOLLOWING CODE WORDS - ! 15364: * =ONTA$, =OSLA$, =OSLB$, =OSLC$ ! 15365: * ! 15366: EXBL3 SUB WB,(XL)+ ADJUST OFFSET ! 15367: BCT WA,EXBL4 DECREMENT COUNT ! 15368: * ! 15369: EXBL4 BCT WA,EXBL5 DECREMENT COUNT ! 15370: * ! 15371: * CONTINUE SEARCH FOR MORE OFFSETS ! 15372: * ! 15373: EXBL5 MOV (XL)+,XR GET NEXT CODE WORD ! 15374: BEQ XR,=OSLA$,EXBL3 JUMP IF OFFSET FOUND ! 15375: BEQ XR,=OSLB$,EXBL3 JUMP IF OFFSET FOUND ! 15376: BEQ XR,=OSLC$,EXBL3 JUMP IF OFFSET FOUND ! 15377: BEQ XR,=ONTA$,EXBL3 JUMP IF OFFSET FOUND ! 15378: BCT WA,EXBL5 LOOP ! 15379: BRN EXBL2 MERGE TO RETURN ! 15380: ENP END PROCEDURE EXBLD ! 15381: EJC ! 15382: * ! 15383: * EXPAN -- ANALYZE EXPRESSION ! 15384: * ! 15385: * THE EXPRESSION ANALYZER (EXPAN) PROCEDURE IS USED TO SCAN ! 15386: * AN EXPRESSION AND CONVERT IT INTO A TREE REPRESENTATION. ! 15387: * SEE DESCRIPTIONS OF CMBLK, CUBLK, CBBLK IN THE STRUCTURES ! 15388: * SECTION FOR DETAILED FORMAT OF TREE BLOCKS. ! 15389: * ! 15390: * THE ANALYZER USES A SIMPLE PRECEDENCE SCHEME IN WHICH ! 15391: * OPERANDS AND OPERATORS ARE PLACED ON A SINGLE STACK ! 15392: * AND CONDENSATIONS ARE MADE WHEN LOW PRECEDENCE OPERATORS ! 15393: * ARE STACKED AFTER A HIGHER PRECEDENCE OPERATOR. A GLOBAL ! 15394: * VARIABLE (IN WB) KEEPS TRACK OF THE LEVEL AS FOLLOWS. ! 15395: * ! 15396: * 0 SCANNING OUTER LEVEL OF STATEMENT OR EXPRESSION ! 15397: * 1 SCANNING OUTER LEVEL OF NORMAL GOTO ! 15398: * 2 SCANNING OUTER LEVEL OF DIRECT GOTO ! 15399: * 3 SCANNING INSIDE ARRAY BRACKETS ! 15400: * 4 SCANNING INSIDE GROUPING PARENTHESES ! 15401: * 5 SCANNING INSIDE FUNCTION PARENTHESES ! 15402: * ! 15403: * THIS VARIABLE IS SAVED ON THE STACK ON ENCOUNTERING A ! 15404: * GROUPING AND RESTORED AT THE END OF THE GROUPING. ! 15405: * ! 15406: * ANOTHER GLOBAL VARIABLE (IN WC) COUNTS THE NUMBER OF ! 15407: * ITEMS AT ONE GROUPING LEVEL AND IS INCREMENTED FOR EACH ! 15408: * COMMA ENCOUNTERED. IT IS STACKED WITH THE LEVEL INDICATOR ! 15409: * ! 15410: * THE SCAN IS CONTROLLED BY A THREE STATE FINITE MACHINE. ! 15411: * A GLOBAL VARIABLE STORED IN WA IS THE CURRENT STATE. ! 15412: * ! 15413: * WA=0 NOTHING SCANNED AT THIS LEVEL ! 15414: * WA=1 OPERAND EXPECTED ! 15415: * WA=2 OPERATOR EXPECTED ! 15416: * ! 15417: * (WB) CALL TYPE (SEE BELOW) ! 15418: * JSR EXPAN CALL TO ANALYZE EXPRESSION ! 15419: * (XR) POINTER TO RESULTING TREE ! 15420: * (XL,WA,WB,WC,RA) DESTROYED ! 15421: * ! 15422: * THE ENTRY VALUE OF WB INDICATES THE CALL TYPE AS FOLLOWS. ! 15423: * ! 15424: * 0 SCANNING EITHER THE MAIN BODY OF A STATEMENT OR THE ! 15425: * TEXT OF AN EXPRESSION (FROM EVAL CALL). VALID ! 15426: * TERMINATORS ARE COLON, SEMICOLON. THE RESCAN FLAG IS ! 15427: * SET TO RETURN THE TERMINATOR ON THE NEXT SCANE CALL. ! 15428: * ! 15429: * 1 SCANNING A NORMAL GOTO. THE ONLY VALID ! 15430: * TERMINATOR IS A RIGHT PAREN. ! 15431: * ! 15432: * 2 SCANNING A DIRECT GOTO. THE ONLY VALID ! 15433: * TERMINATOR IS A RIGHT BRACKET. ! 15434: EJC ! 15435: * ! 15436: * EXPAN (CONTINUED) ! 15437: * ! 15438: * ENTRY POINT ! 15439: * ! 15440: EXPAN PRC E,0 ENTRY POINT ! 15441: ZER -(XS) SET TOP OF STACK INDICATOR ! 15442: ZER WA SET INITIAL STATE TO ZERO ! 15443: ZER WC ZERO COUNTER VALUE ! 15444: * ! 15445: * LOOP HERE FOR SUCCESSIVE ENTRIES ! 15446: * ! 15447: EXP01 JSR SCANE SCAN NEXT ELEMENT ! 15448: ADD WA,XL ADD STATE TO SYNTAX CODE ! 15449: BSW XL,T$NES SWITCH ON ELEMENT TYPE/STATE ! 15450: IFF T$VA0,EXP03 VARIABLE, S=0 ! 15451: IFF T$VA1,EXP03 VARIABLE, STATE ONE ! 15452: IFF T$VA2,EXP04 VARIABLE, S=2 ! 15453: IFF T$CO0,EXP03 CONSTANT, S=0 ! 15454: IFF T$CO1,EXP03 CONSTANT, S=1 ! 15455: IFF T$CO2,EXP04 CONSTANT, S=2 ! 15456: IFF T$LP0,EXP06 LEFT PAREN, S=0 ! 15457: IFF T$LP1,EXP06 LEFT PAREN, S=1 ! 15458: IFF T$LP2,EXP04 LEFT PAREN, S=2 ! 15459: IFF T$FN0,EXP10 FUNCTION, S=0 ! 15460: IFF T$FN1,EXP10 FUNCTION, S=1 ! 15461: IFF T$FN2,EXP04 FUNCTION, S=2 ! 15462: IFF T$RP0,EXP02 RIGHT PAREN, S=0 ! 15463: IFF T$RP1,EXP05 RIGHT PAREN, S=1 ! 15464: IFF T$RP2,EXP12 RIGHT PAREN, S=2 ! 15465: IFF T$LB0,EXP08 LEFT BRKT, S=0 ! 15466: IFF T$LB1,EXP08 LEFT BRKT, S=1 ! 15467: IFF T$LB2,EXP09 LEFT BRKT, S=2 ! 15468: IFF T$RB0,EXP02 RIGHT BRKT, S=0 ! 15469: IFF T$RB1,EXP05 RIGHT BRKT, S=1 ! 15470: IFF T$RB2,EXP18 RIGHT BRKT, S=2 ! 15471: IFF T$UO0,EXP27 UNOP, S=0 ! 15472: IFF T$UO1,EXP27 UNOP, S=1 ! 15473: IFF T$UO2,EXP04 UNOP, S=2 ! 15474: IFF T$BO0,EXP05 BINOP, S=0 ! 15475: IFF T$BO1,EXP05 BINOP, S=1 ! 15476: IFF T$BO2,EXP26 BINOP, S=2 ! 15477: IFF T$CM0,EXP02 COMMA, S=0 ! 15478: IFF T$CM1,EXP05 COMMA, S=1 ! 15479: IFF T$CM2,EXP11 COMMA, S=2 ! 15480: IFF T$CL0,EXP02 COLON, S=0 ! 15481: IFF T$CL1,EXP05 COLON, S=1 ! 15482: IFF T$CL2,EXP19 COLON, S=2 ! 15483: IFF T$SM0,EXP02 SEMICOLON, S=0 ! 15484: IFF T$SM1,EXP05 SEMICOLON, S=1 ! 15485: IFF T$SM2,EXP19 SEMICOLON, S=2 ! 15486: ESW END SWITCH ON ELEMENT TYPE/STATE ! 15487: EJC ! 15488: * ! 15489: * EXPAN (CONTINUED) ! 15490: * ! 15491: * HERE FOR RBR,RPR,COL,SMC,CMA IN STATE 0 ! 15492: * ! 15493: * SET TO RESCAN THE TERMINATOR ENCOUNTERED AND CREATE ! 15494: * A NULL CONSTANT (CASE OF OMITTED NULL) ! 15495: * ! 15496: EXP02 MNZ SCNRS SET TO RESCAN ELEMENT ! 15497: MOV =NULLS,XR POINT TO NULL, MERGE ! 15498: * ! 15499: * HERE FOR VAR OR CON IN STATES 0,1 ! 15500: * ! 15501: * STACK THE VARIABLE/CONSTANT AND SET STATE=2 ! 15502: * ! 15503: EXP03 MOV XR,-(XS) STACK POINTER TO OPERAND ! 15504: MOV =NUM02,WA SET STATE 2 ! 15505: BRN EXP01 JUMP FOR NEXT ELEMENT ! 15506: * ! 15507: * HERE FOR VAR,CON,LPR,FNC,UOP IN STATE 2 ! 15508: * ! 15509: * WE RESCAN THE ELEMENT AND CREATE A CONCATENATION OPERATOR ! 15510: * THIS IS THE CASE OF THE BLANK CONCATENATION OPERATOR. ! 15511: * ! 15512: EXP04 MNZ SCNRS SET TO RESCAN ELEMENT ! 15513: MOV =OPDVC,XR POINT TO CONCAT OPERATOR DV ! 15514: BZE WB,EXP4A OK IF AT TOP LEVEL ! 15515: MOV =OPDVP,XR ELSE POINT TO UNMISTAKABLE CONCAT. ! 15516: * ! 15517: * MERGE HERE WHEN XR SET UP WITH PROPER CONCATENATION DVBLK ! 15518: * ! 15519: EXP4A BNZ SCNBL,EXP26 MERGE BOP IF BLANKS, ELSE ERROR ! 15520: DCV SCNSE ADJUST START OF ELEMENT LOCATION ! 15521: ERB 220,SYNTAX ERROR. MISSING OPERATOR ! 15522: * ! 15523: * HERE FOR CMA,RPR,RBR,COL,SMC,BOP(S=1) BOP(S=0) ! 15524: * ! 15525: * THIS IS AN ERRONOUS CONTRUCTION ! 15526: * ! 15527: EXP05 DCV SCNSE ADJUST START OF ELEMENT LOCATION ! 15528: ERB 221,SYNTAX ERROR. MISSING OPERAND ! 15529: * ! 15530: * HERE FOR LPR (S=0,1) ! 15531: * ! 15532: EXP06 MOV =NUM04,XL SET NEW LEVEL INDICATOR ! 15533: ZER XR SET ZERO VALUE FOR CMOPN ! 15534: EJC ! 15535: * ! 15536: * EXPAN (CONTINUED) ! 15537: * ! 15538: * MERGE HERE TO STORE OLD LEVEL ON STACK AND START NEW ONE ! 15539: * ! 15540: EXP07 MOV XR,-(XS) STACK CMOPN VALUE ! 15541: MOV WC,-(XS) STACK OLD COUNTER ! 15542: MOV WB,-(XS) STACK OLD LEVEL INDICATOR ! 15543: CHK CHECK FOR STACK OVERFLOW ! 15544: ZER WA SET NEW STATE TO ZERO ! 15545: MOV XL,WB SET NEW LEVEL INDICATOR ! 15546: MOV =NUM01,WC INITIALIZE NEW COUNTER ! 15547: BRN EXP01 JUMP TO SCAN NEXT ELEMENT ! 15548: * ! 15549: * HERE FOR LBR (S=0,1) ! 15550: * ! 15551: * THIS IS AN ILLEGAL USE OF LEFT BRACKET ! 15552: * ! 15553: EXP08 ERB 222,SYNTAX ERROR. INVALID USE OF LEFT BRACKET ! 15554: * ! 15555: * HERE FOR LBR (S=2) ! 15556: * ! 15557: * SET NEW LEVEL AND START TO SCAN SUBSCRIPTS ! 15558: * ! 15559: EXP09 MOV (XS)+,XR LOAD ARRAY PTR FOR CMOPN ! 15560: MOV =NUM03,XL SET NEW LEVEL INDICATOR ! 15561: BRN EXP07 JUMP TO STACK OLD AND START NEW ! 15562: * ! 15563: * HERE FOR FNC (S=0,1) ! 15564: * ! 15565: * STACK OLD LEVEL AND START TO SCAN ARGUMENTS ! 15566: * ! 15567: EXP10 MOV =NUM05,XL SET NEW LEV INDIC (XR=VRBLK=CMOPN) ! 15568: BRN EXP07 JUMP TO STACK OLD AND START NEW ! 15569: * ! 15570: * HERE FOR CMA (S=2) ! 15571: * ! 15572: * INCREMENT ARGUMENT COUNT AND CONTINUE ! 15573: * ! 15574: EXP11 ICV WC INCREMENT COUNTER ! 15575: JSR EXPDM DUMP OPERATORS AT THIS LEVEL ! 15576: ZER -(XS) SET NEW LEVEL FOR PARAMETER ! 15577: ZER WA SET NEW STATE ! 15578: BGT WB,=NUM02,EXP01 LOOP BACK UNLESS OUTER LEVEL ! 15579: ERB 223,SYNTAX ERROR. INVALID USE OF COMMA ! 15580: EJC ! 15581: * ! 15582: * EXPAN (CONTINUED) ! 15583: * ! 15584: * HERE FOR RPR (S=2) ! 15585: * ! 15586: * AT OUTER LEVEL IN A NORMAL GOTO THIS IS A TERMINATOR ! 15587: * OTHERWISE IT MUST TERMINATE A FUNCTION OR GROUPING ! 15588: * ! 15589: EXP12 BEQ WB,=NUM01,EXP20 END OF NORMAL GOTO ! 15590: BEQ WB,=NUM05,EXP13 END OF FUNCTION ARGUMENTS ! 15591: BEQ WB,=NUM04,EXP14 END OF GROUPING / SELECTION ! 15592: ERB 224,SYNTAX ERROR. UNBALANCED RIGHT PARENTHESIS ! 15593: * ! 15594: * HERE AT END OF FUNCTION ARGUMENTS ! 15595: * ! 15596: EXP13 MOV =C$FNC,XL SET CMTYP VALUE FOR FUNCTION ! 15597: BRN EXP15 JUMP TO BUILD CMBLK ! 15598: * ! 15599: * HERE FOR END OF GROUPING ! 15600: * ! 15601: EXP14 BEQ WC,=NUM01,EXP17 JUMP IF END OF GROUPING ! 15602: MOV =C$SEL,XL ELSE SET CMTYP FOR SELECTION ! 15603: * ! 15604: * MERGE HERE TO BUILD CMBLK FOR LEVEL JUST SCANNED AND ! 15605: * TO POP UP TO THE PREVIOUS SCAN LEVEL BEFORE CONTINUING. ! 15606: * ! 15607: EXP15 JSR EXPDM DUMP OPERATORS AT THIS LEVEL ! 15608: MOV WC,WA COPY COUNT ! 15609: ADD =CMVLS,WA ADD FOR STANDARD FIELDS AT START ! 15610: WTB WA CONVERT LENGTH TO BYTES ! 15611: JSR ALLOC ALLOCATE SPACE FOR CMBLK ! 15612: MOV =B$CMT,(XR) STORE TYPE CODE FOR CMBLK ! 15613: MOV XL,CMTYP(XR) STORE CMBLK NODE TYPE INDICATOR ! 15614: MOV WA,CMLEN(XR) STORE LENGTH ! 15615: ADD WA,XR POINT PAST END OF BLOCK ! 15616: LCT WC,WC SET LOOP COUNTER ! 15617: * ! 15618: * LOOP TO MOVE REMAINING WORDS TO CMBLK ! 15619: * ! 15620: EXP16 MOV (XS)+,-(XR) MOVE ONE OPERAND PTR FROM STACK ! 15621: MOV (XS)+,WB POP TO OLD LEVEL INDICATOR ! 15622: BCT WC,EXP16 LOOP TILL ALL MOVED ! 15623: EJC ! 15624: * ! 15625: * EXPAN (CONTINUED) ! 15626: * ! 15627: * COMPLETE CMBLK AND STACK POINTER TO IT ON STACK ! 15628: * ! 15629: SUB *CMVLS,XR POINT BACK TO START OF BLOCK ! 15630: MOV (XS)+,WC RESTORE OLD COUNTER ! 15631: MOV (XS),CMOPN(XR) STORE OPERAND PTR IN CMBLK ! 15632: MOV XR,(XS) STACK CMBLK POINTER ! 15633: MOV =NUM02,WA SET NEW STATE ! 15634: BRN EXP01 BACK FOR NEXT ELEMENT ! 15635: * ! 15636: * HERE AT END OF A PARENTHESIZED EXPRESSION ! 15637: * ! 15638: EXP17 JSR EXPDM DUMP OPERATORS AT THIS LEVEL ! 15639: MOV (XS)+,XR RESTORE XR ! 15640: MOV (XS)+,WB RESTORE OUTER LEVEL ! 15641: MOV (XS)+,WC RESTORE OUTER COUNT ! 15642: MOV XR,(XS) STORE OPND OVER UNUSED CMOPN VAL ! 15643: MOV =NUM02,WA SET NEW STATE ! 15644: BRN EXP01 BACK FOR NEXT ELE8ENT ! 15645: * ! 15646: * HERE FOR RBR (S=2) ! 15647: * ! 15648: * AT OUTER LEVEL IN A DIRECT GOTO, THIS IS A TERMINATOR. ! 15649: * OTHERWISE IT MUST TERMINATE A SUBSCRIPT LIST. ! 15650: * ! 15651: EXP18 MOV =C$ARR,XL SET CMTYP FOR ARRAY REFERENCE ! 15652: BEQ WB,=NUM03,EXP15 JUMP TO BUILD CMBLK IF END ARRAYREF ! 15653: BEQ WB,=NUM02,EXP20 JUMP IF END OF DIRECT GOTO ! 15654: ERB 225,SYNTAX ERROR. UNBALANCED RIGHT BRACKET ! 15655: EJC ! 15656: * ! 15657: * EXPAN (CONTINUED) ! 15658: * ! 15659: * HERE FOR COL,SMC (S=2) ! 15660: * ! 15661: * ERROR UNLESS TERMINATING STATEMENT BODY AT OUTER LEVEL ! 15662: * ! 15663: EXP19 MNZ SCNRS RESCAN TERMINATOR ! 15664: MOV WB,XL COPY LEVEL INDICATOR ! 15665: BSW XL,6 SWITCH ON LEVEL INDICATOR ! 15666: IFF 0,EXP20 NORMAL OUTER LEVEL ! 15667: IFF 1,EXP22 FAIL IF NORMAL GOTO ! 15668: IFF 2,EXP23 FAIL IF DIRECT GOTO ! 15669: IFF 3,EXP24 FAIL ARRAY BRACKETS ! 15670: IFF 4,EXP21 FAIL IF IN GROUPING ! 15671: IFF 5,EXP21 FAIL FUNCTION ARGS ! 15672: ESW END SWITCH ON LEVEL ! 15673: * ! 15674: * HERE AT NORMAL END OF EXPRESSION ! 15675: * ! 15676: EXP20 JSR EXPDM DUMP REMAINING OPERATORS ! 15677: MOV (XS)+,XR LOAD TREE POINTER ! 15678: ICA XS POP OFF BOTTOM OF STACK MARKER ! 15679: EXI RETURN TO EXPAN CALLER ! 15680: * ! 15681: * MISSING RIGHT PAREN ! 15682: * ! 15683: EXP21 ERB 226,SYNTAX ERROR. MISSING RIGHT PAREN ! 15684: * ! 15685: * MISSING RIGHT PAREN IN GOTO FIELD ! 15686: * ! 15687: EXP22 ERB 227,SYNTAX ERROR. RIGHT PAREN MISSING FROM GOTO ! 15688: * ! 15689: * MISSING BRACKET IN GOTO ! 15690: * ! 15691: EXP23 ERB 228,SYNTAX ERROR. RIGHT BRACKET MISSING FROM GOTO ! 15692: * ! 15693: * MISSING ARRAY BRACKET ! 15694: * ! 15695: EXP24 ERB 229,SYNTAX ERROR. MISSING RIGHT ARRAY BRACKET ! 15696: EJC ! 15697: * ! 15698: * EXPAN (CONTINUED) ! 15699: * ! 15700: * LOOP HERE WHEN AN OPERATOR CAUSES AN OPERATOR DUMP ! 15701: * ! 15702: EXP25 MOV XR,EXPSV ! 15703: JSR EXPOP POP ONE OPERATOR ! 15704: MOV EXPSV,XR RESTORE OP DV POINTER AND MERGE ! 15705: * ! 15706: * HERE FOR BOP (S=2) ! 15707: * ! 15708: * REMOVE OPERATORS (CONDENSE) FROM STACK UNTIL NO MORE ! 15709: * LEFT AT THIS LEVEL OR TOP ONE HAS LOWER PRECEDENCE. ! 15710: * LOOP HERE TILL THIS CONDITION IS MET. ! 15711: * ! 15712: EXP26 MOV 1(XS),XL LOAD OPERATOR DVPTR FROM STACK ! 15713: BLE XL,=NUM05,EXP27 JUMP IF BOTTOM OF STACK LEVEL ! 15714: BLT DVRPR(XR),DVLPR(XL),EXP25 ELSE POP IF NEW PREC IS LO ! 15715: * ! 15716: * HERE FOR UOP (S=0,1) ! 15717: * ! 15718: * BINARY OPERATOR MERGES AFTER PRECEDENCE CHECK ! 15719: * ! 15720: * THE OPERATOR DV IS STORED ON THE STACK AND THE SCAN ! 15721: * CONTINUES AFTER SETTING THE SCAN STATE TO ONE. ! 15722: * ! 15723: EXP27 MOV XR,-(XS) STACK OPERATOR DVPTR ON STACK ! 15724: CHK CHECK FOR STACK OVERFLOW ! 15725: MOV =NUM01,WA SET NEW STATE ! 15726: BNE XR,=OPDVS,EXP01 BACK FOR NEXT ELEMENT UNLESS = ! 15727: * ! 15728: * HERE FOR SPECIAL CASE OF BINARY =. THE SYNTAX ALLOWS A ! 15729: * NULL RIGHT ARGUMENT FOR THIS OPERATOR TO BE LEFT ! 15730: * OUT. ACCORDINGLY WE RESET TO STATE ZERO TO GET PROPER ! 15731: * ACTION ON A TERMINATOR (SUPPLY A NULL CONSTANT). ! 15732: * ! 15733: ZER WA SET STATE ZERO ! 15734: BRN EXP01 JUMP FOR NEXT ELEMENT ! 15735: ENP END PROCEDURE EXPAN ! 15736: EJC ! 15737: * ! 15738: * EXPAP -- TEST FOR PATTERN MATCH TREE ! 15739: * ! 15740: * EXPAP IS PASSED AN EXPRESSION TREE TO DETERMINE IF IT ! 15741: * IS A PATTERN MATCH. THE FOLLOWING ARE RECOGIZED AS ! 15742: * MATCHES IN THE CONTEXT OF THIS CALL. ! 15743: * ! 15744: * 1) AN EXPLICIT USE OF BINARY QUESTION MARK ! 15745: * 2) A CONCATENATION ! 15746: * 3) AN ALTERNATION WHOSE LEFT OPERAND IS A CONCATENATION ! 15747: * ! 15748: * (XR) PTR TO EXPAN TREE ! 15749: * JSR EXPAP CALL TO TEST FOR PATTERN MATCH ! 15750: * PPM LOC TRANSFER LOC IF NOT A PATTERN MATCH ! 15751: * (WA) DESTROYED ! 15752: * (XR) UNCHANGED (IF NOT MATCH) ! 15753: * (XR) PTR TO BINARY OPERATOR BLK IF MATCH ! 15754: * ! 15755: EXPAP PRC E,1 ENTRY POINT ! 15756: MOV XL,-(XS) SAVE XL ! 15757: BNE (XR),=B$CMT,EXPP2 NO MATCH IF NOT COMPLEX ! 15758: MOV CMTYP(XR),WA ELSE LOAD TYPE CODE ! 15759: BEQ WA,=C$CNC,EXPP1 CONCATENATION IS A MATCH ! 15760: BEQ WA,=C$PMT,EXPP1 BINARY QUESTION MARK IS A MATCH ! 15761: BNE WA,=C$ALT,EXPP2 ELSE NOT MATCH UNLESS ALTERNATION ! 15762: * ! 15763: * HERE FOR ALTERNATION. CHANGE (A B) / C TO A QM (B / C) ! 15764: * ! 15765: MOV CMLOP(XR),XL LOAD LEFT OPERAND POINTER ! 15766: BNE (XL),=B$CMT,EXPP2 NOT MATCH IF LEFT OPND NOT COMPLEX ! 15767: BNE CMTYP(XL),=C$CNC,EXPP2 NOT MATCH IF LEFT OP NOT CONC ! 15768: MOV CMROP(XL),CMLOP(XR) XR POINTS TO (B / C) ! 15769: MOV XR,CMROP(XL) SET XL OPNDS TO A, (B / C) ! 15770: MOV XL,XR POINT TO THIS ALTERED NODE ! 15771: * ! 15772: * EXIT HERE FOR PATTERN MATCH ! 15773: * ! 15774: EXPP1 MOV (XS)+,XL RESTORE ENTRY XL ! 15775: EXI GIVE PATTERN MATCH RETURN ! 15776: * ! 15777: * EXIT HERE IF NOT PATTERN MATCH ! 15778: * ! 15779: EXPP2 MOV (XS)+,XL RESTORE ENTRY XL ! 15780: EXI 1 GIVE NON-MATCH RETURN ! 15781: ENP END PROCEDURE EXPAP ! 15782: EJC ! 15783: * ! 15784: * EXPDM -- DUMP OPERATORS AT CURRENT LEVEL (FOR EXPAN) ! 15785: * ! 15786: * EXPDM USES EXPOP TO CONDENSE ALL OPERATORS AT THIS SYNTAX ! 15787: * LEVEL. THE STACK BOTTOM IS RECOGNIZED FROM THE LEVEL ! 15788: * VALUE WHICH IS SAVED ON THE TOP OF THE STACK. ! 15789: * ! 15790: * JSR EXPDM CALL TO DUMP OPERATORS ! 15791: * (XS) POPPED AS REQUIRED ! 15792: * (XR,WA) DESTROYED ! 15793: * ! 15794: EXPDM PRC N,0 ENTRY POINT ! 15795: MOV XL,R$EXS SAVE XL VALUE ! 15796: * ! 15797: * LOOP TO DUMP OPERATORS ! 15798: * ! 15799: EXDM1 BLE 1(XS),=NUM05,EXDM2 JUMP IF STACK BOTTOM (SAVED LEVEL ! 15800: JSR EXPOP ELSE POP ONE OPERATOR ! 15801: BRN EXDM1 AND LOOP BACK ! 15802: * ! 15803: * HERE AFTER POPPING ALL OPERATORS ! 15804: * ! 15805: EXDM2 MOV R$EXS,XL RESTORE XL ! 15806: ZER R$EXS RELEASE SAVE LOCATION ! 15807: EXI RETURN TO EXPDM CALLER ! 15808: ENP END PROCEDURE EXPDM ! 15809: EJC ! 15810: * ! 15811: * EXPOP-- POP OPERATOR (FOR EXPAN) ! 15812: * ! 15813: * EXPOP IS USED BY THE EXPAN ROUTINE TO CONDENSE ONE ! 15814: * OPERATOR FROM THE TOP OF THE SYNTAX STACK. AN APPROPRIATE ! 15815: * CMBLK IS BUILT FOR THE OPERATOR (UNARY OR BINARY) AND A ! 15816: * POINTER TO THIS CMBLK IS STACKED. ! 15817: * ! 15818: * EXPOP IS ALSO USED BY SCNGF (GOTO FIELD SCAN) PROCEDURE ! 15819: * ! 15820: * JSR EXPOP CALL TO POP OPERATOR ! 15821: * (XS) POPPED APPROPRIATELY ! 15822: * (XR,XL,WA) DESTROYED ! 15823: * ! 15824: EXPOP PRC N,0 ENTRY POINT ! 15825: MOV 1(XS),XR LOAD OPERATOR DV POINTER ! 15826: BEQ DVLPR(XR),=LLUNO,EXPO2 JUMP IF UNARY ! 15827: * ! 15828: * HERE FOR BINARY OPERATOR ! 15829: * ! 15830: MOV *CMBS$,WA SET SIZE OF BINARY OPERATOR CMBLK ! 15831: JSR ALLOC ALLOCATE SPACE FOR CMBLK ! 15832: MOV (XS)+,CMROP(XR) POP AND STORE RIGHT OPERAND PTR ! 15833: MOV (XS)+,XL POP AND LOAD OPERATOR DV PTR ! 15834: MOV (XS),CMLOP(XR) STORE LEFT OPERAND POINTER ! 15835: * ! 15836: * COMMON EXIT POINT ! 15837: * ! 15838: EXPO1 MOV =B$CMT,(XR) STORE TYPE CODE FOR CMBLK ! 15839: MOV DVTYP(XL),CMTYP(XR) STORE CMBLK NODE TYPE CODE ! 15840: MOV XL,CMOPN(XR) STORE DVPTR (=PTR TO DAC O$XXX) ! 15841: MOV WA,CMLEN(XR) STORE CMBLK LENGTH ! 15842: MOV XR,(XS) STORE RESULTING NODE PTR ON STACK ! 15843: EXI RETURN TO EXPOP CALLER ! 15844: * ! 15845: * HERE FOR UNARY OPERATOR ! 15846: * ! 15847: EXPO2 MOV *CMUS$,WA SET SIZE OF UNARY OPERATOR CMBLK ! 15848: JSR ALLOC ALLOCATE SPACE FOR CMBLK ! 15849: MOV (XS)+,CMROP(XR) POP AND STORE OPERAND POINTER ! 15850: MOV (XS),XL LOAD OPERATOR DV POINTER ! 15851: BRN EXPO1 MERGE BACK TO EXIT ! 15852: ENP END PROCEDURE EXPOP ! 15853: EJC ! 15854: * ! 15855: * FLSTG -- FOLD STRING TO UPPER CASE ! 15856: * ! 15857: * FLSTG FOLDS A CHARACTER STRING CONTAINING LOWER CASE ! 15858: * CHARACCTERS TO ONE CONTAINING UPPER CASE CHARACTERS. ! 15859: * FOLDING IS ONLY DONE IF &CASE (KVCAS) IS NOT ZERO. ! 15860: * ! 15861: * (XR) STRING ARGUMENT ! 15862: * (WA) LENGTH OF STRING ! 15863: * JSR FLSTG CALL TO FOLD STRING ! 15864: * (XR) RESULT STRING (POSSIBLY ORIGINAL) ! 15865: * (WC) DESTROYED ! 15866: * ! 15867: FLSTG PRC R,0 ENTRY POINT ! 15868: BZE KVCAS,FST99 SKIP IF &CASE IS 0 ! 15869: MOV XL,-(XS) SAVE XL ACROSS CALL ! 15870: MOV XR,-(XS) SAVE ORIGINAL SCBLK PTR ! 15871: JSR ALOCS ALLOCATE NEW STRING BLOCK ! 15872: MOV (XS),XL POINT TO ORIGINAL SCBLK ! 15873: MOV XR,-(XS) SAVE POINTER TO NEW SCBLK ! 15874: PLC XL POINT TO ORIGINAL CHARS ! 15875: PLC XR POINT TO NEW CHARS ! 15876: ZER -(XS) INIT DID FOLD FLAG ! 15877: LCT WC,WC LOAD LOOP COUNTER ! 15878: FST01 LCH WA,(XL)+ LOAD CHARACTER ! 15879: BGT =CH$$A,WA,FST02 SKIP IF LESS THAN LC A ! 15880: BGT WA,=CH$$$,FST02 SKIP IF GREATER THAN LC Z ! 15881: FLC WA FOLD CHARACTER TO UPPER CASE ! 15882: MNZ (XS) SET DID FOLD CHARACTER FLAG ! 15883: FST02 SCH WA,(XR)+ STORE (POSSIBLY FOLDED) CHARACTER ! 15884: BCT WC,FST01 LOOP THRU ENTIRE STRING ! 15885: CSC XR COMPLETE STORE CHARACTERS ! 15886: BNZ (XS)+,FST10 SKIP IF FOLDING DONE ! 15887: MOV (XS)+,DNAMP DO NOT NEED NEW SCBLK ! 15888: MOV (XS)+,XR RETURN ORIGINAL SCBLK ! 15889: BRN FST20 MERGE BELOW ! 15890: FST10 MOV (XS)+,XR RETURN NEW SCBLK ! 15891: ICA XS THROW AWAY ORIGINAL SCBLK POINTER ! 15892: FST20 MOV SCLEN(XR),WA RELOAD STRING LENGTH ! 15893: MOV (XS)+,XL RESTORE XL ! 15894: FST99 EXI RETURN ! 15895: ENP ! 15896: EJC ! 15897: * ! 15898: * GBCOL -- PERFORM GARBAGE COLLECTION ! 15899: * ! 15900: * GBCOL PERFORMS A GARBAGE COLLECTION ON THE DYNAMIC REGION ! 15901: * ALL BLOCKS WHICH ARE NO LONGER IN USE ARE ELIMINATED ! 15902: * BY MOVING BLOCKS WHICH ARE IN USE DOWN AND RESETTING ! 15903: * DNAMP, THE POINTER TO THE NEXT AVAILABLE LOCATION. ! 15904: * ! 15905: * (WB) MOVE OFFSET (SEE BELOW) ! 15906: * JSR GBCOL CALL TO COLLECT GARBAGE ! 15907: * (XR) DESTROYED ! 15908: * ! 15909: * THE FOLLOWING CONDITIONS MUST BE MET AT THE TIME WHEN ! 15910: * GBCOL IS CALLED. ! 15911: * ! 15912: * 1) ALL POINTERS TO BLOCKS IN THE DYNAMIC AREA MUST BE ! 15913: * ACCESSIBLE TO THE GARBAGE COLLECTOR. THIS MEANS ! 15914: * THAT THEY MUST OCCUR IN ONE OF THE FOLLOWING. ! 15915: * ! 15916: * A) MAIN STACK, WITH CURRENT TOP ! 15917: * ELEMENT BEING INDICATED BY XS ! 15918: * ! 15919: * B) IN RELOCATABLE FIELDS OF VRBLKS. ! 15920: * ! 15921: * C) IN REGISTER XL AT THE TIME OF CALL ! 15922: * ! 15923: * E) IN THE SPECIAL REGION OF WORKING ! 15924: * STORAGE WHERE NAMES BEGIN WITH R$. ! 15925: * ! 15926: * 2) ALL POINTERS MUST POINT TO THE START OF BLOCKS WITH ! 15927: * THE SOLE EXCEPTION OF THE CONTENTS OF THE CODE ! 15928: * POINTER REGISTER WHICH POINTS INTO THE R$COD BLOCK. ! 15929: * ! 15930: * 3) NO LOCATION WHICH APPEARS TO CONTAIN A POINTER ! 15931: * INTO THE DYNAMIC REGION MAY OCCUR UNLESS IT IS IN ! 15932: * FACT A POINTER TO THE START OF THE BLOCK. HOWEVER ! 15933: * POINTERS OUTSIDE THIS AREA MAY OCCUR AND WILL ! 15934: * NOT BE CHANGED BY THE GARBAGE COLLECTOR. ! 15935: * IT IS ESPECIALLY IMPORTANT TO MAKE SURE THAT XL ! 15936: * DOES NOT CONTAIN A GARBAGE VALUE FROM SOME PROCESS ! 15937: * CARRIED OUT BEFORE THE CALL TO THE COLLECTOR. ! 15938: * ! 15939: * GBCOL HAS THE CAPABILITY OF MOVING THE FINAL COMPACTED ! 15940: * RESULT UP IN MEMORY (WITH ADDRESSES ADJUSTED ACCORDINGLY) ! 15941: * THIS IS USED TO ADD SPACE TO THE STATIC REGION. THE ! 15942: * ENTRY VALUE OF WB IS THE NUMBER OF BYTES TO MOVE UP. ! 15943: * THE CALLER MUST GUARANTEE THAT THERE IS ENOUGH ROOM. ! 15944: * FURTHERMORE THE VALUE IN WB IF IT IS NON-ZERO, MUST BE AT ! 15945: * LEAST 256 SO THAT THE MWB INSTRUCTION CONDITIONS ARE MET. ! 15946: EJC ! 15947: * ! 15948: * GBCOL (CONTINUED) ! 15949: * ! 15950: * THE ALGORITHM, WHICH IS A MODIFICATION OF THE LISP-2 ! 15951: * GARBAGE COLLECTOR DEVISED BY R.DEWAR AND K.BELCHER ! 15952: * TAKES THREE PASSES AS FOLLOWS. ! 15953: * ! 15954: * 1) ALL POINTERS IN MEMORY ARE SCANNED AND BLOCKS IN USE ! 15955: * DETERMINED FROM THIS SCAN. NOTE THAT THIS PROCEDURE ! 15956: * IS RECURSIVE AND USES THE MAIN STACK FOR LINKAGE. ! 15957: * THE MARKING PROCESS IS THUS SIMILAR TO THAT USED IN ! 15958: * A STANDARD LISP COLLECTOR. HOWEVER THE METHOD OF ! 15959: * ACTUALLY MARKING THE BLOCKS IS DIFFERENT. ! 15960: * ! 15961: * THE FIRST FIELD OF A BLOCK NORMALLY CONTAINS A ! 15962: * CODE ENTRY POINT POINTER. SUCH AN ENTRY POINTER ! 15963: * CAN BE DISTINGUISHED FROM THE ADDRESS OF ANY POINTER ! 15964: * TO BE PROCESSED BY THE COLLECTOR. DURING GARBAGE ! 15965: * COLLECTION, THIS WORD IS USED TO BUILD A BACK CHAIN ! 15966: * OF POINTERS THROUGH FIELDS WHICH POINT TO THE BLOCK. ! 15967: * THE END OF THE CHAIN IS MARKED BY THE OCCURENCE ! 15968: * OF THE WORD WHICH USED TO BE IN THE FIRST WORD OF ! 15969: * THE BLOCK. THIS BACKCHAIN SERVES BOTH AS A MARK ! 15970: * INDICATING THAT THE BLOCK IS IN USE AND AS A LIST OF ! 15971: * REFERENCES FOR THE RELOCATION PHASE. ! 15972: * ! 15973: * 2) STORAGE IS SCANNED SEQUENTIALLY TO DISCOVER WHICH ! 15974: * BLOCKS ARE CURRENTLY IN USE AS INDICATED BY THE ! 15975: * PRESENCE OF A BACKCHAIN. TWO POINTERS ARE MAINTAINED ! 15976: * ONE SCANS THROUGH LOOKING AT EACH BLOCK. THE OTHER ! 15977: * IS INCREMENTED ONLY FOR BLOCKS FOUND TO BE IN USE. ! 15978: * IN THIS WAY, THE EVENTUAL LOCATION OF EACH BLOCK CAN ! 15979: * BE DETERMINED WITHOUT ACTUALLY MOVING ANY BLOCKS. ! 15980: * AS EACH BLOCK WHICH IS IN USE IS PROCESSED, THE BACK ! 15981: * CHAIN IS USED TO RESET ALL POINTERS WHICH POINT TO ! 15982: * THIS BLOCK TO CONTAIN ITS NEW ADDRESS, I.E. THE ! 15983: * ADDRESS IT WILL OCCUPY AFTER THE BLOCKS ARE MOVED. ! 15984: * THE FIRST WORD OF THE BLOCK, TAKEN FROM THE END OF ! 15985: * THE CHAIN IS RESTORED AT THIS POINT. ! 15986: * ! 15987: * DURING PASS 2, THE COLLECTOR BUILDS BLOCKS WHICH ! 15988: * DESCRIBE THE REGIONS OF STORAGE WHICH ARE TO BE ! 15989: * MOVED IN THE THIRD PASS. THERE IS ONE DESCRIPTOR FOR ! 15990: * EACH CONTIGUOUS SET OF GOOD BLOCKS. THE DESCRIPTOR ! 15991: * IS BUILT JUST BEHIND THE BLOCK TO BE MOVED AND ! 15992: * CONTAINS A POINTER TO THE NEXT BLOCK AND THE NUMBER ! 15993: * OF WORDS TO BE MOVED. ! 15994: * ! 15995: * 3) IN THE THIRD AND FINAL PASS, THE MOVE DESCRIPTOR ! 15996: * BLOCKS BUILT IN PASS TWO ARE USED TO ACTUALLY MOVE ! 15997: * THE BLOCKS DOWN TO THE BOTTOM OF THE DYNAMIC REGION. ! 15998: * THE COLLECTION IS THEN COMPLETE AND THE NEXT ! 15999: * AVAILABLE LOCATION POINTER IS RESET. ! 16000: EJC ! 16001: * ! 16002: * GBCOL (CONTINUED) ! 16003: * ! 16004: GBCOL PRC E,0 ENTRY POINT ! 16005: BNZ DMVCH,GBC14 FAIL IF IN MID-DUMP ! 16006: MNZ GBCFL NOTE GBCOL ENTERED ! 16007: MOV WA,GBSVA SAVE ENTRY WA ! 16008: MOV WB,GBSVB SAVE ENTRY WB ! 16009: MOV WC,GBSVC SAVE ENTRY WC ! 16010: MOV XL,-(XS) SAVE ENTRY XL ! 16011: SCP WA GET CODE POINTER VALUE ! 16012: SUB R$COD,WA MAKE RELATIVE ! 16013: LCP WA AND RESTORE ! 16014: * ! 16015: * PROCESS STACK ENTRIES ! 16016: * ! 16017: MOV XS,XR POINT TO STACK FRONT ! 16018: MOV STBAS,XL POINT PAST END OF STACK ! 16019: BGE XL,XR,GBC00 OK IF D-STACK ! 16020: MOV XL,XR REVERSE IF ... ! 16021: MOV XS,XL ... U-STACK ! 16022: * ! 16023: * PROCESS THE STACK ! 16024: * ! 16025: GBC00 JSR GBCPF PROCESS POINTERS ON STACK ! 16026: * ! 16027: * PROCESS SPECIAL WORK LOCATIONS ! 16028: * ! 16029: MOV =R$AAA,XR POINT TO START OF RELOCATABLE LOCS ! 16030: MOV =R$YYY,XL POINT PAST END OF RELOCATABLE LOCS ! 16031: JSR GBCPF PROCESS WORK FIELDS ! 16032: * ! 16033: * PREPARE TO PROCESS VARIABLE BLOCKS ! 16034: * ! 16035: MOV HSHTB,WA POINT TO FIRST HASH SLOT POINTER ! 16036: * ! 16037: * LOOP THROUGH HASH SLOTS ! 16038: * ! 16039: GBC01 MOV WA,XL POINT TO NEXT SLOT ! 16040: ICA WA BUMP BUCKET POINTER ! 16041: MOV WA,GBCNM SAVE BUCKET POINTER ! 16042: EJC ! 16043: * ! 16044: * GBCOL (CONTINUED) ! 16045: * ! 16046: * LOOP THROUGH VARIABLES ON ONE HASH CHAIN ! 16047: * ! 16048: GBC02 MOV (XL),XR LOAD PTR TO NEXT VRBLK ! 16049: BZE XR,GBC03 JUMP IF END OF CHAIN ! 16050: MOV XR,XL ELSE COPY VRBLK POINTER ! 16051: ADD *VRVAL,XR POINT TO FIRST RELOC FLD ! 16052: ADD *VRNXT,XL POINT PAST LAST (AND TO LINK PTR) ! 16053: JSR GBCPF PROCESS RELOC FIELDS IN VRBLK ! 16054: BRN GBC02 LOOP BACK FOR NEXT BLOCK ! 16055: * ! 16056: * HERE AT END OF ONE HASH CHAIN ! 16057: * ! 16058: GBC03 MOV GBCNM,WA RESTORE BUCKET POINTER ! 16059: BNE WA,HSHTE,GBC01 LOOP BACK IF MORE BUCKETS TO GO ! 16060: EJC ! 16061: * ! 16062: * GBCOL (CONTINUED) ! 16063: * ! 16064: * NOW WE ARE READY TO START PASS TWO. REGISTERS ARE USED ! 16065: * AS FOLLOWS IN PASS TWO. ! 16066: * ! 16067: * (XR) SCANS THROUGH ALL BLOCKS ! 16068: * (WC) POINTER TO EVENTUAL LOCATION ! 16069: * ! 16070: * THE MOVE DESCRIPTION BLOCKS BUILT IN THIS PASS HAVE ! 16071: * THE FOLLOWING FORMAT. ! 16072: * ! 16073: * WORD 1 POINTER TO NEXT MOVE BLOCK, ! 16074: * ZERO IF END OF CHAIN OF BLOCKS ! 16075: * ! 16076: * WORD 2 LENGTH OF BLOCKS TO BE MOVED IN ! 16077: * BYTES. SET TO THE ADDRESS OF THE ! 16078: * FIRST BYTE WHILE ACTUALLY SCANNING ! 16079: * THE BLOCKS. ! 16080: * ! 16081: * THE FIRST ENTRY ON THIS CHAIN IS A SPECIAL ENTRY ! 16082: * CONSISTING OF THE TWO WORDS GBCNM AND GBCNS. AFTER ! 16083: * BUILDING THE CHAIN OF MOVE DESCRIPTORS, GBCNM POINTS TO ! 16084: * THE FIRST REAL MOVE BLOCK, AND GBCNS IS THE LENGTH OF ! 16085: * BLOCKS IN USE AT THE START OF STORAGE WHICH NEED NOT ! 16086: * BE MOVED SINCE THEY ARE IN THE CORRECT POSITION. ! 16087: * ! 16088: GBC04 MOV DNAMB,XR POINT TO FIRST BLOCK ! 16089: MOV XR,WC SET AS FIRST EVENTUAL LOCATION ! 16090: ADD GBSVB,WC ADD OFFSET FOR EVENTUAL MOVE UP ! 16091: ZER GBCNM CLEAR INITIAL FORWARD POINTER ! 16092: MOV =GBCNM,GBCLM INITIALIZE PTR TO LAST MOVE BLOCK ! 16093: MOV XR,GBCNS INITIALIZE FIRST ADDRESS ! 16094: * ! 16095: * LOOP THROUGH A SERIES OF BLOCKS IN USE ! 16096: * ! 16097: GBC05 BEQ XR,DNAMP,GBC07 JUMP IF END OF USED REGION ! 16098: MOV (XR),WA ELSE GET FIRST WORD ! 16099: BHI WA,=P$YYY,GBC06 SKIP IF NOT ENTRY PTR (IN USE) ! 16100: BHI WA,=B$AAA,GBC07 JUMP IF ENTRY POINTER (UNUSED) ! 16101: * ! 16102: * HERE FOR BLOCK IN USE, LOOP TO RELOCATE REFERENCES ! 16103: * ! 16104: GBC06 MOV WA,XL COPY POINTER ! 16105: MOV (XL),WA LOAD FORWARD POINTER ! 16106: MOV WC,(XL) RELOCATE REFERENCE ! 16107: BHI WA,=P$YYY,GBC06 LOOP BACK IF NOT END OF CHAIN ! 16108: BLO WA,=B$AAA,GBC06 LOOP BACK IF NOT END OF CHAIN ! 16109: EJC ! 16110: * ! 16111: * GBCOL (CONTINUED) ! 16112: * ! 16113: * AT END OF CHAIN, RESTORE FIRST WORD AND BUMP PAST ! 16114: * ! 16115: MOV WA,(XR) RESTORE FIRST WORD ! 16116: JSR BLKLN GET LENGTH OF THIS BLOCK ! 16117: ADD WA,XR BUMP ACTUAL POINTER ! 16118: ADD WA,WC BUMP EVENTUAL POINTER ! 16119: BRN GBC05 LOOP BACK FOR NEXT BLOCK ! 16120: * ! 16121: * HERE AT END OF A SERIES OF BLOCKS IN USE ! 16122: * ! 16123: GBC07 MOV XR,WA COPY POINTER PAST LAST BLOCK ! 16124: MOV GBCLM,XL POINT TO PREVIOUS MOVE BLOCK ! 16125: SUB 1(XL),WA SUBTRACT STARTING ADDRESS ! 16126: MOV WA,1(XL) STORE LENGTH OF BLOCK TO BE MOVED ! 16127: * ! 16128: * LOOP THROUGH A SERIES OF BLOCKS NOT IN USE ! 16129: * ! 16130: GBC08 BEQ XR,DNAMP,GBC10 JUMP IF END OF USED REGION ! 16131: MOV (XR),WA ELSE LOAD FIRST WORD OF NEXT BLOCK ! 16132: BHI WA,=P$YYY,GBC09 JUMP IF IN USE ! 16133: BLO WA,=B$AAA,GBC09 JUMP IF IN USE ! 16134: JSR BLKLN ELSE GET LENGTH OF NEXT BLOCK ! 16135: ADD WA,XR PUSH POINTER ! 16136: BRN GBC08 AND LOOP BACK ! 16137: * ! 16138: * HERE FOR A BLOCK IN USE AFTER PROCESSING A SERIES OF ! 16139: * BLOCKS WHICH WERE NOT IN USE, BUILD NEW MOVE BLOCK. ! 16140: * ! 16141: GBC09 SUB *NUM02,XR POINT 2 WORDS BEHIND FOR MOVE BLOCK ! 16142: MOV GBCLM,XL POINT TO PREVIOUS MOVE BLOCK ! 16143: MOV XR,(XL) SET FORWARD PTR IN PREVIOUS BLOCK ! 16144: ZER (XR) ZERO FORWARD PTR OF NEW BLOCK ! 16145: MOV XR,GBCLM REMEMBER ADDRESS OF THIS BLOCK ! 16146: MOV XR,XL COPY PTR TO MOVE BLOCK ! 16147: ADD *NUM02,XR POINT BACK TO BLOCK IN USE ! 16148: MOV XR,1(XL) STORE STARTING ADDRESS ! 16149: BRN GBC06 JUMP TO PROCESS BLOCK IN USE ! 16150: EJC ! 16151: * ! 16152: * GBCOL (CONTINUED) ! 16153: * ! 16154: * HERE FOR PASS THREE -- ACTUALLY MOVE THE BLOCKS DOWN ! 16155: * ! 16156: * (XL) POINTER TO OLD LOCATION ! 16157: * (XR) POINTER TO NEW LOCATION ! 16158: * ! 16159: GBC10 MOV DNAMB,XR POINT TO START OF STORAGE ! 16160: ADD GBCNS,XR BUMP PAST UNMOVED BLOCKS AT START ! 16161: * ! 16162: * LOOP THROUGH MOVE DESCRIPTORS ! 16163: * ! 16164: GBC11 MOV GBCNM,XL POINT TO NEXT MOVE BLOCK ! 16165: BZE XL,GBC12 JUMP IF END OF CHAIN ! 16166: MOV (XL)+,GBCNM MOVE POINTER DOWN CHAIN ! 16167: MOV (XL)+,WA GET LENGTH TO MOVE ! 16168: MVW PERFORM MOVE ! 16169: BRN GBC11 LOOP BACK ! 16170: * ! 16171: * NOW TEST FOR MOVE UP ! 16172: * ! 16173: GBC12 MOV XR,DNAMP SET NEXT AVAILABLE LOC PTR ! 16174: MOV GBSVB,WB RELOAD MOVE OFFSET ! 16175: BZE WB,GBC13 JUMP IF NO MOVE REQUIRED ! 16176: MOV XR,XL ELSE COPY OLD TOP OF CORE ! 16177: ADD WB,XR POINT TO NEW TOP OF CORE ! 16178: MOV XR,DNAMP SAVE NEW TOP OF CORE POINTER ! 16179: MOV XL,WA COPY OLD TOP ! 16180: SUB DNAMB,WA MINUS OLD BOTTOM = LENGTH ! 16181: ADD WB,DNAMB BUMP BOTTOM TO GET NEW VALUE ! 16182: MWB PERFORM MOVE (BACKWARDS) ! 16183: * ! 16184: * MERGE HERE TO EXIT ! 16185: * ! 16186: GBC13 MOV GBSVA,WA RESTORE WA ! 16187: SCP WC GET CODE POINTER ! 16188: ADD R$COD,WC MAKE ABSOLUTE AGAIN ! 16189: LCP WC AND REPLACE ABSOLUTE VALUE ! 16190: MOV GBSVC,WC RESTORE WC ! 16191: MOV (XS)+,XL RESTORE ENTRY XL ! 16192: ICV GBCNT INCREMENT COUNT OF COLLECTIONS ! 16193: ZER XR CLEAR GARBAGE VALUE IN XR ! 16194: ZER GBCFL NOTE EXIT FROM GBCOL ! 16195: EXI EXIT TO GBCOL CALLER ! 16196: * ! 16197: * GARBAGE COLLECTION NOT ALLOWED WHILST DUMPING ! 16198: * ! 16199: GBC14 ICV ERRFT FATAL ERROR ! 16200: ERB 250,INSUFFICIENT MEMORY TO COMPLETE DUMP ! 16201: ENP END PROCEDURE GBCOL ! 16202: EJC ! 16203: * ! 16204: * GBCPF -- PROCESS FIELDS FOR GARBAGE COLLECTOR ! 16205: * ! 16206: * THIS PROCEDURE IS USED BY THE GARBAGE COLLECTOR TO ! 16207: * PROCESS FIELDS IN PASS ONE. SEE GBCOL FOR FULL DETAILS. ! 16208: * ! 16209: * (XR) PTR TO FIRST LOCATION TO PROCESS ! 16210: * (XL) PTR PAST LAST LOCATION TO PROCESS ! 16211: * JSR GBCPF CALL TO PROCESS FIELDS ! 16212: * (XR,WA,WB,WC,IA) DESTROYED ! 16213: * ! 16214: * NOTE THAT ALTHOUGH THIS PROCEDURE USES A RECURSIVE ! 16215: * APPROACH, IT CONTROLS ITS OWN STACK AND IS NOT RECURSIVE. ! 16216: * ! 16217: GBCPF PRC E,0 ENTRY POINT ! 16218: ZER -(XS) SET ZERO TO MARK BOTTOM OF STACK ! 16219: MOV XL,-(XS) SAVE END POINTER ! 16220: * ! 16221: * MERGE HERE TO GO DOWN A LEVEL AND START A NEW LOOP ! 16222: * ! 16223: * 1(XS) NEXT LVL FIELD PTR (0 AT OUTER LVL) ! 16224: * 0(XS) PTR PAST LAST FIELD TO PROCESS ! 16225: * (XR) PTR TO FIRST FIELD TO PROCESS ! 16226: * ! 16227: * LOOP TO PROCESS SUCCESSIVE FIELDS ! 16228: * ! 16229: GPF01 MOV (XR),XL LOAD FIELD CONTENTS ! 16230: MOV XR,WC SAVE FIELD POINTER ! 16231: BLT XL,DNAMB,GPF02 JUMP IF NOT PTR INTO DYNAMIC AREA ! 16232: BGE XL,DNAMP,GPF02 JUMP IF NOT PTR INTO DYNAMIC AREA ! 16233: * ! 16234: * HERE WE HAVE A PTR TO A BLOCK IN THE DYNAMIC AREA. ! 16235: * LINK THIS FIELD ONTO THE REFERENCE BACKCHAIN. ! 16236: * ! 16237: MOV (XL),WA LOAD PTR TO CHAIN (OR ENTRY PTR) ! 16238: MOV XR,(XL) SET THIS FIELD AS NEW HEAD OF CHAIN ! 16239: MOV WA,(XR) SET FORWARD POINTER ! 16240: * ! 16241: * NOW SEE IF THIS BLOCK HAS BEEN PROCESSED BEFORE ! 16242: * ! 16243: BHI WA,=P$YYY,GPF02 JUMP IF ALREADY PROCESSED ! 16244: BHI WA,=B$AAA,GPF03 JUMP IF NOT ALREADY PROCESSED ! 16245: * ! 16246: * HERE TO MOVE TO NEXT FIELD ! 16247: * ! 16248: GPF02 MOV WC,XR RESTORE FIELD POINTER ! 16249: ICA XR BUMP TO NEXT FIELD ! 16250: BNE XR,(XS),GPF01 LOOP BACK IF MORE TO GO ! 16251: EJC ! 16252: * ! 16253: * GBCPF (CONTINUED) ! 16254: * ! 16255: * HERE WE POP UP A LEVEL AFTER FINISHING A BLOCK ! 16256: * ! 16257: MOV (XS)+,XL RESTORE POINTER PAST END ! 16258: MOV (XS)+,WC RESTORE BLOCK POINTER ! 16259: BNZ WC,GPF02 CONTINUE LOOP UNLESS OUTER LEVL ! 16260: EXI RETURN TO CALLER IF OUTER LEVEL ! 16261: * ! 16262: * HERE TO PROCESS AN ACTIVE BLOCK WHICH HAS NOT BEEN DONE ! 16263: * ! 16264: GPF03 MOV XL,XR COPY BLOCK POINTER ! 16265: MOV WA,XL COPY FIRST WORD OF BLOCK ! 16266: LEI XL LOAD ENTRY POINT ID (BL$XX) ! 16267: * ! 16268: * BLOCK TYPE SWITCH. NOTE THAT BLOCKS WITH NO RELOCATABLE ! 16269: * FIELDS JUST RETURN TO GPF02 HERE TO CONTINE TO NEXT FLD. ! 16270: * ! 16271: BSW XL,BL$$$ SWITCH ON BLOCK TYPE ! 16272: IFF BL$AR,GPF06 ARBLK ! 16273: IFF BL$BC,GPF18 BCBLK ! 16274: IFF BL$BF,GPF02 BFBLK ! 16275: IFF BL$CC,GPF07 CCBLK ! 16276: IFF BL$CD,GPF08 CDBLK ! 16277: IFF BL$CM,GPF04 CMBLK ! 16278: IFF BL$DF,GPF02 DFBLK ! 16279: IFF BL$EV,GPF10 EVBLK ! 16280: IFF BL$EX,GPF17 EXBLK ! 16281: IFF BL$FF,GPF11 FFBLK ! 16282: IFF BL$NM,GPF10 NMBLK ! 16283: IFF BL$P0,GPF10 P0BLK ! 16284: IFF BL$P1,GPF12 P1BLK ! 16285: IFF BL$P2,GPF12 P2BLK ! 16286: IFF BL$PD,GPF13 PDBLK ! 16287: IFF BL$PF,GPF14 PFBLK ! 16288: IFF BL$TB,GPF08 TBBLK ! 16289: IFF BL$TE,GPF15 TEBLK ! 16290: IFF BL$TR,GPF16 TRBLK ! 16291: IFF BL$VC,GPF08 VCBLK ! 16292: IFF BL$XR,GPF09 XRBLK ! 16293: IFF BL$CT,GPF02 CTBLK ! 16294: IFF BL$EF,GPF02 EFBLK ! 16295: IFF BL$IC,GPF02 ICBLK ! 16296: IFF BL$KV,GPF02 KVBLK ! 16297: IFF BL$RC,GPF02 RCBLK ! 16298: IFF BL$SC,GPF02 SCBLK ! 16299: IFF BL$SE,GPF02 SEBLK ! 16300: IFF BL$XN,GPF02 XNBLK ! 16301: ESW END OF JUMP TABLE ! 16302: EJC ! 16303: * ! 16304: * GBCPF (CONTINUED) ! 16305: * ! 16306: * CMBLK ! 16307: * ! 16308: GPF04 MOV CMLEN(XR),WA LOAD LENGTH ! 16309: MOV *CMTYP,WB SET OFFSET ! 16310: * ! 16311: * HERE TO PUSH DOWN TO NEW LEVEL ! 16312: * ! 16313: * (WC) FIELD PTR AT PREVIOUS LEVEL ! 16314: * (XR) PTR TO NEW BLOCK ! 16315: * (WA) LENGTH (RELOC FLDS + FLDS AT START) ! 16316: * (WB) OFFSET TO FIRST RELOC FIELD ! 16317: * ! 16318: GPF05 ADD XR,WA POINT PAST LAST RELOC FIELD ! 16319: ADD WB,XR POINT TO FIRST RELOC FIELD ! 16320: MOV WC,-(XS) STACK OLD FIELD POINTER ! 16321: MOV WA,-(XS) STACK NEW LIMIT POINTER ! 16322: CHK CHECK FOR STACK OVERFLOW ! 16323: BRN GPF01 IF OK, BACK TO PROCESS ! 16324: * ! 16325: * ARBLK ! 16326: * ! 16327: GPF06 MOV ARLEN(XR),WA LOAD LENGTH ! 16328: MOV AROFS(XR),WB SET OFFSET TO 1ST RELOC FLD (ARPRO) ! 16329: BRN GPF05 ALL SET ! 16330: * ! 16331: * CCBLK ! 16332: * ! 16333: GPF07 MOV CCUSE(XR),WA SET LENGTH IN USE ! 16334: MOV *CCUSE,WB 1ST WORD (MAKE SURE AT LEAST ONE) ! 16335: BRN GPF05 ALL SET ! 16336: EJC ! 16337: * ! 16338: * GBCPF (CONTINUED) ! 16339: * ! 16340: * CDBLK, TBBLK, VCBLK ! 16341: * ! 16342: GPF08 MOV OFFS2(XR),WA LOAD LENGTH ! 16343: MOV *OFFS3,WB SET OFFSET ! 16344: BRN GPF05 JUMP BACK ! 16345: * ! 16346: * XRBLK ! 16347: * ! 16348: GPF09 MOV XRLEN(XR),WA LOAD LENGTH ! 16349: MOV *XRPTR,WB SET OFFSET ! 16350: BRN GPF05 JUMP BACK ! 16351: * ! 16352: * EVBLK, NMBLK, P0BLK ! 16353: * ! 16354: GPF10 MOV *OFFS2,WA POINT PAST SECOND FIELD ! 16355: MOV *OFFS1,WB OFFSET IS ONE (ONLY RELOC FLD IS 2) ! 16356: BRN GPF05 ALL SET ! 16357: * ! 16358: * FFBLK ! 16359: * ! 16360: GPF11 MOV *FFOFS,WA SET LENGTH ! 16361: MOV *FFNXT,WB SET OFFSET ! 16362: BRN GPF05 ALL SET ! 16363: * ! 16364: * P1BLK, P2BLK ! 16365: * ! 16366: GPF12 MOV *PARM2,WA LENGTH (PARM2 IS NON-RELOCATABLE) ! 16367: MOV *PTHEN,WB SET OFFSET ! 16368: BRN GPF05 ALL SET ! 16369: EJC ! 16370: * ! 16371: * GBCPF (CONTINUED) ! 16372: * ! 16373: * PDBLK ! 16374: * ! 16375: GPF13 MOV PDDFP(XR),XL LOAD PTR TO DFBLK ! 16376: MOV DFPDL(XL),WA GET PDBLK LENGTH ! 16377: MOV *PDFLD,WB SET OFFSET ! 16378: BRN GPF05 ALL SET ! 16379: * ! 16380: * PFBLK ! 16381: * ! 16382: GPF14 MOV *PFARG,WA LENGTH PAST LAST RELOC ! 16383: MOV *PFCOD,WB OFFSET TO FIRST RELOC ! 16384: BRN GPF05 ALL SET ! 16385: * ! 16386: * TEBLK ! 16387: * ! 16388: GPF15 MOV *TESI$,WA SET LENGTH ! 16389: MOV *TESUB,WB AND OFFSET ! 16390: BRN GPF05 ALL SET ! 16391: * ! 16392: * TRBLK ! 16393: * ! 16394: GPF16 MOV *TRSI$,WA SET LENGTH ! 16395: MOV *TRVAL,WB AND OFFSET ! 16396: BRN GPF05 ALL SET ! 16397: * ! 16398: * EXBLK ! 16399: * ! 16400: GPF17 MOV EXLEN(XR),WA LOAD LENGTH ! 16401: MOV *EXFLC,WB SET OFFSET ! 16402: BRN GPF05 JUMP BACK ! 16403: * ! 16404: * BCBLK ! 16405: * ! 16406: GPF18 MOV *BCSI$,WA SET LENGTH ! 16407: MOV *BCBUF,WB AND OFFSET ! 16408: BRN GPF05 ALL SET ! 16409: ENP END PROCEDURE GBCPF ! 16410: EJC ! 16411: * ! 16412: * GTARR -- GET ARRAY ! 16413: * ! 16414: * GTARR IS PASSED AN OBJECT AND RETURNS AN ARRAY IF POSSIBL ! 16415: * ! 16416: * (XR) VALUE TO BE CONVERTED ! 16417: * JSR GTARR CALL TO GET ARRAY ! 16418: * PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE ! 16419: * (XR) RESULTING ARRAY ! 16420: * (XL,WA,WB,WC) DESTROYED ! 16421: * ! 16422: GTARR PRC E,1 ENTRY POINT ! 16423: MOV (XR),WA LOAD TYPE WORD ! 16424: BEQ WA,=B$ART,GTAR8 EXIT IF ALREADY AN ARRAY ! 16425: BEQ WA,=B$VCT,GTAR8 EXIT IF ALREADY AN ARRAY ! 16426: BNE WA,=B$TBT,GTA9A ELSE FAIL IF NOT A TABLE (SGD02) ! 16427: * ! 16428: * HERE WE CONVERT A TABLE TO AN ARRAY ! 16429: * ! 16430: MOV XR,-(XS) REPLACE TBBLK POINTER ON STACK ! 16431: ZER XR SIGNAL FIRST PASS ! 16432: ZER WB ZERO NON-NULL ELEMENT COUNT ! 16433: * ! 16434: * THE FOLLOWING CODE IS EXECUTED TWICE. ON THE FIRST PASS, ! 16435: * SIGNALLED BY XR=0, THE NUMBER OF NON-NULL ELEMENTS IN ! 16436: * THE TABLE IS COUNTED IN WB. IN THE SECOND PASS, WHERE ! 16437: * XR IS A POINTER INTO THE ARBLK, THE NAME AND VALUE ARE ! 16438: * ENTERED INTO THE CURRENT ARBLK LOCATION. ! 16439: * ! 16440: GTAR1 MOV (XS),XL POINT TO TABLE ! 16441: ADD TBLEN(XL),XL POINT PAST LAST BUCKET ! 16442: SUB *TBBUK,XL SET FIRST BUCKET OFFSET ! 16443: MOV XL,WA COPY ADJUSTED POINTER ! 16444: * ! 16445: * LOOP THROUGH BUCKETS IN TABLE BLOCK ! 16446: * NEXT THREE LINES OF CODE RELY ON TENXT HAVING A VALUE ! 16447: * 1 LESS THAN TBBUK. ! 16448: * ! 16449: GTAR2 MOV WA,XL COPY BUCKET POINTER ! 16450: DCA WA DECREMENT BUCKET POINTER ! 16451: * ! 16452: * LOOP THROUGH TEBLKS ON ONE BUCKET CHAIN ! 16453: * ! 16454: GTAR3 MOV TENXT(XL),XL POINT TO NEXT TEBLK ! 16455: BEQ XL,(XS),GTAR6 JUMP IF CHAIN END (TBBLK PTR) ! 16456: MOV XL,CNVTP ELSE SAVE TEBLK POINTER ! 16457: * ! 16458: * LOOP TO FIND VALUE DOWN TRBLK CHAIN ! 16459: * ! 16460: GTAR4 MOV TEVAL(XL),XL LOAD VALUE ! 16461: BEQ (XL),=B$TRT,GTAR4 LOOP TILL VALUE FOUND ! 16462: MOV XL,WC COPY VALUE ! 16463: MOV CNVTP,XL RESTORE TEBLK POINTER ! 16464: EJC ! 16465: * ! 16466: * GTARR (CONTINUED) ! 16467: * ! 16468: * NOW CHECK FOR NULL AND TEST CASES ! 16469: * ! 16470: BEQ WC,=NULLS,GTAR3 LOOP BACK TO IGNORE NULL VALUE ! 16471: BNZ XR,GTAR5 JUMP IF SECOND PASS ! 16472: ICV WB FOR THE FIRST PASS, BUMP COUNT ! 16473: BRN GTAR3 AND LOOP BACK FOR NEXT TEBLK ! 16474: * ! 16475: * HERE IN SECOND PASS ! 16476: * ! 16477: GTAR5 MOV TESUB(XL),(XR)+ STORE SUBSCRIPT NAME ! 16478: MOV WC,(XR)+ STORE VALUE IN ARBLK ! 16479: BRN GTAR3 LOOP BACK FOR NEXT TEBLK ! 16480: * ! 16481: * HERE AFTER SCANNING TEBLKS ON ONE CHAIN ! 16482: * ! 16483: GTAR6 BNE WA,(XS),GTAR2 LOOP BACK IF MORE BUCKETS TO GO ! 16484: BNZ XR,GTAR7 ELSE JUMP IF SECOND PASS ! 16485: * ! 16486: * HERE AFTER COUNTING NON-NULL ELEMENTS ! 16487: * ! 16488: BZE WB,GTAR9 FAIL IF NO NON-NULL ELEMENTS ! 16489: MOV WB,WA ELSE COPY COUNT ! 16490: ADD WB,WA DOUBLE (TWO WORDS/ELEMENT) ! 16491: ADD =ARVL2,WA ADD SPACE FOR STANDARD FIELDS ! 16492: WTB WA CONVERT LENGTH TO BYTES ! 16493: BGE WA,MXLEN,GTAR9 FAIL IF TOO LONG FOR ARRAY ! 16494: JSR ALLOC ELSE ALLOCATE SPACE FOR ARBLK ! 16495: MOV =B$ART,(XR) STORE TYPE WORD ! 16496: ZER IDVAL(XR) ZERO ID FOR THE MOMENT ! 16497: MOV WA,ARLEN(XR) STORE LENGTH ! 16498: MOV =NUM02,ARNDM(XR) SET DIMENSIONS = 2 ! 16499: LDI INTV1 GET INTEGER ONE ! 16500: STI ARLBD(XR) STORE AS LBD 1 ! 16501: STI ARLB2(XR) STORE AS LBD 2 ! 16502: LDI INTV2 LOAD INTEGER TWO ! 16503: STI ARDM2(XR) STORE AS DIM 2 ! 16504: MTI WB GET ELEMENT COUNT AS INTEGER ! 16505: STI ARDIM(XR) STORE AS DIM 1 ! 16506: ZER ARPR2(XR) ZERO PROTOTYPE FIELD FOR NOW ! 16507: MOV *ARPR2,AROFS(XR) SET OFFSET FIELD (SIGNAL PASS 2) ! 16508: MOV XR,WB SAVE ARBLK POINTER ! 16509: ADD *ARVL2,XR POINT TO FIRST ELEMENT LOCATION ! 16510: BRN GTAR1 JUMP BACK TO FILL IN ELEMENTS ! 16511: EJC ! 16512: * ! 16513: * GTARR (CONTINUED) ! 16514: * ! 16515: * HERE AFTER FILLING IN ELEMENT VALUES ! 16516: * ! 16517: GTAR7 MOV WB,XR RESTORE ARBLK POINTER ! 16518: MOV WB,(XS) STORE AS RESULT ! 16519: * ! 16520: * NOW WE NEED THE ARRAY PROTOTYPE WHICH IS OF THE FORM NN,2 ! 16521: * THIS IS OBTAINED BY BUILDING THE STRING FOR NN02 AND ! 16522: * CHANGING THE ZERO TO A COMMA BEFORE STORING IT. ! 16523: * ! 16524: LDI ARDIM(XR) GET NUMBER OF ELEMENTS (NN) ! 16525: MLI INTVH MULTIPLY BY 100 ! 16526: ADI INTV2 ADD 2 (NN02) ! 16527: JSR ICBLD BUILD INTEGER ! 16528: MOV XR,-(XS) STORE PTR FOR GTSTG ! 16529: JSR GTSTG CONVERT TO STRING ! 16530: PPM CONVERT FAIL IS IMPOSSIBLE ! 16531: MOV XR,XL COPY STRING POINTER ! 16532: MOV (XS)+,XR RELOAD ARBLK POINTER ! 16533: MOV XL,ARPR2(XR) STORE PROTOTYPE PTR (NN02) ! 16534: SUB =NUM02,WA ADJUST LENGTH TO POINT TO ZERO ! 16535: PSC XL,WA POINT TO ZERO ! 16536: MOV =CH$CM,WB LOAD A COMMA ! 16537: SCH WB,(XL) STORE A COMMA OVER THE ZERO ! 16538: CSC XL COMPLETE STORE CHARACTERS ! 16539: * ! 16540: * NORMAL RETURN ! 16541: * ! 16542: GTAR8 EXI RETURN TO CALLER ! 16543: * ! 16544: * NON-CONVERSION RETURN ! 16545: * ! 16546: GTAR9 MOV (XS)+,XR RESTORE STACK FOR CONV ERR (SGD02) ! 16547: * ! 16548: * MERGE TO TAKE CONVERT ERROR WHEN STACK ADJUSTED OK ! 16549: * ! 16550: GTA9A EXI 1 RETURN ! 16551: ENP PROCEDURE GTARR ! 16552: EJC ! 16553: * ! 16554: * GTCOD -- CONVERT TO CODE ! 16555: * ! 16556: * (XR) OBJECT TO BE CONVERTED ! 16557: * JSR GTCOD CALL TO CONVERT TO CODE ! 16558: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 16559: * (XR) POINTER TO RESULTING CDBLK ! 16560: * (XL,WA,WB,WC,RA) DESTROYED ! 16561: * ! 16562: * IF A SPITBOL ERROR OCCURS DURING COMPILATION OR PRE- ! 16563: * EVALUATION, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL ! 16564: * WITHOUT RETURNING TO THIS ROUTINE. ! 16565: * ! 16566: GTCOD PRC E,1 ENTRY POINT ! 16567: BEQ (XR),=B$CDS,GTCD1 JUMP IF ALREADY CODE ! 16568: BEQ (XR),=B$CDC,GTCD1 JUMP IF ALREADY CODE ! 16569: * ! 16570: * HERE WE MUST GENERATE A CDBLK BY COMPILATION ! 16571: * ! 16572: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG ! 16573: JSR GTSTG CONVERT ARGUMENT TO STRING ! 16574: PPM GTCD2 JUMP IF NON-CONVERTIBLE ! 16575: MOV FLPTR,GTCEF SAVE FAIL PTR IN CASE OF ERROR ! 16576: MOV R$COD,R$GTC ALSO SAVE CODE PTR ! 16577: MOV XR,R$CIM ELSE SET IMAGE POINTER ! 16578: MOV WA,SCNIL SET IMAGE LENGTH ! 16579: ZER SCNPT SET SCAN POINTER ! 16580: MOV =STGXC,STAGE SET STAGE FOR EXECUTE COMPILE ! 16581: MOV CMPSN,LSTSN IN CASE LISTR CALLED ! 16582: JSR CMPIL COMPILE STRING ! 16583: MOV =STGXT,STAGE RESET STAGE FOR EXECUTE TIME ! 16584: ZER R$CIM CLEAR IMAGE ! 16585: * ! 16586: * MERGE HERE IF NO CONVERT REQUIRED ! 16587: * ! 16588: GTCD1 EXI GIVE NORMAL GTCOD RETURN ! 16589: * ! 16590: * HERE IF UNCONVERTIBLE ! 16591: * ! 16592: GTCD2 EXI 1 GIVE ERROR RETURN ! 16593: ENP END PROCEDURE GTCOD ! 16594: EJC ! 16595: * ! 16596: * GTEXP -- CONVERT TO EXPRESSION ! 16597: * ! 16598: * (XR) INPUT VALUE TO BE CONVERTED ! 16599: * JSR GTEXP CALL TO CONVERT TO EXPRESSION ! 16600: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 16601: * (XR) POINTER TO RESULT EXBLK OR SEBLK ! 16602: * (XL,WA,WB,WC,RA) DESTROYED ! 16603: * ! 16604: * IF A SPITBOL ERROR OCCURS DURING COMPILATION OR PRE- ! 16605: * EVALUATION, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL ! 16606: * WITHOUT RETURNING TO THIS ROUTINE. ! 16607: * ! 16608: GTEXP PRC E,1 ENTRY POINT ! 16609: BLO (XR),=B$E$$,GTEX1 JUMP IF ALREADY AN EXPRESSION ! 16610: MOV XR,-(XS) STORE ARGUMENT FOR GTSTG ! 16611: JSR GTSTG CONVERT ARGUMENT TO STRING ! 16612: PPM GTEX2 JUMP IF UNCONVERTIBLE ! 16613: * ! 16614: * CHECK THE LAST CHARACTER OF THE STRING FOR COLON OR ! 16615: * SEMICOLON. THESE CHARACTERS CAN LEGITIMATELY END AN ! 16616: * EXPRESSION IN OPEN CODE, SO EXPAN WILL NOT DETECT THEM ! 16617: * AS ERRORS, BUT THEY ARE INVALID AS TERMINATORS FOR A ! 16618: * STRING THAT IS BEING CONVERTED TO EXPRESSION FORM. ! 16619: * ! 16620: MOV XR,XL COPY INPUT STRING POINTER (REG06) ! 16621: PLC XL,WA POINT ONE PAST THE STRING END (REG06) ! 16622: LCH XL,-(XL) FETCH THE LAST CHARACTER (REG06) ! 16623: BEQ XL,=CH$CL,GTEX2 ERROR IF IT IS A SEMICOLON (REG06) ! 16624: BEQ XL,=CH$SM,GTEX2 OR IF IT IS A COLON (REG06) ! 16625: * ! 16626: * HERE WE CONVERT A STRING BY COMPILATION ! 16627: * ! 16628: MOV XR,R$CIM SET INPUT IMAGE POINTER ! 16629: ZER SCNPT SET SCAN POINTER ! 16630: MOV WA,SCNIL SET INPUT IMAGE LENGTH ! 16631: ZER WB SET CODE FOR NORMAL SCAN ! 16632: MOV FLPTR,GTCEF SAVE FAIL PTR IN CASE OF ERROR ! 16633: MOV R$COD,R$GTC ALSO SAVE CODE PTR ! 16634: MOV =STGEV,STAGE ADJUST STAGE FOR COMPILE ! 16635: MOV =T$UOK,SCNTP INDICATE UNARY OPERATOR ACCEPTABLE ! 16636: JSR EXPAN BUILD TREE FOR EXPRESSION ! 16637: ZER SCNRS RESET RESCAN FLAG ! 16638: BNE SCNPT,SCNIL,GTEX2 ERROR IF NOT END OF IMAGE ! 16639: ZER WB SET OK VALUE FOR CDGEX CALL ! 16640: MOV XR,XL COPY TREE POINTER ! 16641: JSR CDGEX BUILD EXPRESSION BLOCK ! 16642: ZER R$CIM CLEAR POINTER ! 16643: MOV =STGXT,STAGE RESTORE STAGE FOR EXECUTE TIME ! 16644: * ! 16645: * MERGE HERE IF NO CONVERSION REQUIRED ! 16646: * ! 16647: GTEX1 EXI RETURN TO GTEXP CALLER ! 16648: * ! 16649: * HERE IF UNCONVERTIBLE ! 16650: * ! 16651: GTEX2 EXI 1 TAKE ERROR EXIT ! 16652: ENP END PROCEDURE GTEXP ! 16653: EJC ! 16654: * ! 16655: * GTINT -- GET INTEGER VALUE ! 16656: * ! 16657: * GTINT IS PASSED AN OBJECT AND RETURNS AN INTEGER AFTER ! 16658: * PERFORMING ANY NECESSARY CONVERSIONS. ! 16659: * ! 16660: * (XR) VALUE TO BE CONVERTED ! 16661: * JSR GTINT CALL TO CONVERT TO INTEGER ! 16662: * PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE ! 16663: * (XR) RESULTING INTEGER ! 16664: * (WC,RA) DESTROYED ! 16665: * (WA,WB) DESTROYED (ONLY ON CONVERSION ERR) ! 16666: * (XR) UNCHANGED (ON CONVERT ERROR) ! 16667: * ! 16668: GTINT PRC E,1 ENTRY POINT ! 16669: BEQ (XR),=B$ICL,GTIN2 JUMP IF ALREADY AN INTEGER ! 16670: MOV WA,GTINA ELSE SAVE WA ! 16671: MOV WB,GTINB SAVE WB ! 16672: JSR GTNUM CONVERT TO NUMERIC ! 16673: PPM GTIN3 JUMP IF UNCONVERTIBLE ! 16674: BEQ WA,=B$ICL,GTIN1 JUMP IF INTEGER ! 16675: * ! 16676: * HERE WE CONVERT A REAL TO INTEGER ! 16677: * ! 16678: LDR RCVAL(XR) LOAD REAL VALUE ! 16679: RTI GTIN3 CONVERT TO INTEGER (ERR IF OVFLOW) ! 16680: JSR ICBLD IF OK BUILD ICBLK ! 16681: * ! 16682: * HERE AFTER SUCCESSFUL CONVERSION TO INTEGER ! 16683: * ! 16684: GTIN1 MOV GTINA,WA RESTORE WA ! 16685: MOV GTINB,WB RESTORE WB ! 16686: * ! 16687: * COMMON EXIT POINT ! 16688: * ! 16689: GTIN2 EXI RETURN TO GTINT CALLER ! 16690: * ! 16691: * HERE ON CONVERSION ERROR ! 16692: * ! 16693: GTIN3 EXI 1 TAKE CONVERT ERROR EXIT ! 16694: ENP END PROCEDURE GTINT ! 16695: EJC ! 16696: * ! 16697: * GTNUM -- GET NUMERIC VALUE ! 16698: * ! 16699: * GTNUM IS GIVEN AN OBJECT AND RETURNS EITHER AN INTEGER ! 16700: * OR A REAL, PERFORMING ANY NECESSARY CONVERSIONS. ! 16701: * ! 16702: * (XR) OBJECT TO BE CONVERTED ! 16703: * JSR GTNUM CALL TO CONVERT TO NUMERIC ! 16704: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 16705: * (XR) POINTER TO RESULT (INT OR REAL) ! 16706: * (WA) FIRST WORD OF RESULT BLOCK ! 16707: * (WB,WC,RA) DESTROYED ! 16708: * (XR) UNCHANGED (ON CONVERT ERROR) ! 16709: * ! 16710: GTNUM PRC E,1 ENTRY POINT ! 16711: MOV (XR),WA LOAD FIRST WORD OF BLOCK ! 16712: BEQ WA,=B$ICL,GTN34 JUMP IF INTEGER (NO CONVERSION) ! 16713: BEQ WA,=B$RCL,GTN34 JUMP IF REAL (NO CONVERSION) ! 16714: * ! 16715: * AT THIS POINT THE ONLY POSSIBILITY IS TO CONVERT A STRING ! 16716: * TO AN INTEGER OR REAL AS APPROPRIATE. ! 16717: * ! 16718: MOV XR,-(XS) STACK ARGUMENT IN CASE CONVERT ERR ! 16719: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG ! 16720: JSR GTSTG CONVERT ARGUMENT TO STRING ! 16721: PPM GTN36 JUMP IF UNCONVERTIBLE ! 16722: * ! 16723: * INITIALIZE NUMERIC CONVERSION ! 16724: * ! 16725: LDI INTV0 INITIALIZE INTEGER RESULT TO ZERO ! 16726: BZE WA,GTN32 JUMP TO EXIT WITH ZERO IF NULL ! 16727: LCT WA,WA SET BCT COUNTER FOR FOLLOWING LOOPS ! 16728: ZER GTNNF TENTATIVELY INDICATE RESULT + ! 16729: STI GTNEX INITIALISE EXPONENT TO ZERO ! 16730: ZER GTNSC ZERO SCALE IN CASE REAL ! 16731: ZER GTNDF RESET FLAG FOR DEC POINT FOUND ! 16732: ZER GTNRD RESET FLAG FOR DIGITS FOUND ! 16733: LDR REAV0 ZERO REAL ACCUM IN CASE REAL ! 16734: PLC XR POINT TO ARGUMENT CHARACTERS ! 16735: * ! 16736: * MERGE BACK HERE AFTER IGNORING LEADING BLANK ! 16737: * ! 16738: GTN01 LCH WB,(XR)+ LOAD FIRST CHARACTER ! 16739: BLT WB,=CH$D0,GTN02 JUMP IF NOT DIGIT ! 16740: BLE WB,=CH$D9,GTN06 JUMP IF FIRST CHAR IS A DIGIT ! 16741: EJC ! 16742: * ! 16743: * GTNUM (CONTINUED) ! 16744: * ! 16745: * HERE IF FIRST DIGIT IS NON-DIGIT ! 16746: * ! 16747: GTN02 BNE WB,=CH$BL,GTN03 JUMP IF NON-BLANK ! 16748: GTNA2 BCT WA,GTN01 ELSE DECR COUNT AND LOOP BACK ! 16749: BRN GTN07 JUMP TO RETURN ZERO IF ALL BLANKS ! 16750: * ! 16751: * HERE FOR FIRST CHARACTER NON-BLANK, NON-DIGIT ! 16752: * ! 16753: GTN03 BEQ WB,=CH$PL,GTN04 JUMP IF PLUS SIGN ! 16754: BEQ WB,=CH$HT,GTNA2 HORIZONTAL TAB EQUIV TO BLANK ! 16755: BNE WB,=CH$MN,GTN12 JUMP IF NOT MINUS (MAY BE REAL) ! 16756: MNZ GTNNF IF MINUS SIGN, SET NEGATIVE FLAG ! 16757: * ! 16758: * MERGE HERE AFTER PROCESSING SIGN ! 16759: * ! 16760: GTN04 BCT WA,GTN05 JUMP IF CHARS LEFT ! 16761: BRN GTN36 ELSE ERROR ! 16762: * ! 16763: * LOOP TO FETCH CHARACTERS OF AN INTEGER ! 16764: * ! 16765: GTN05 LCH WB,(XR)+ LOAD NEXT CHARACTER ! 16766: BLT WB,=CH$D0,GTN08 JUMP IF NOT A DIGIT ! 16767: BGT WB,=CH$D9,GTN08 JUMP IF NOT A DIGIT ! 16768: * ! 16769: * MERGE HERE FOR FIRST DIGIT ! 16770: * ! 16771: GTN06 STI GTNSI SAVE CURRENT VALUE ! 16772: CVM GTN35 CURRENT*10-(NEW DIG) JUMP IF OVFLOW ! 16773: MNZ GTNRD SET DIGIT READ FLAG ! 16774: BCT WA,GTN05 ELSE LOOP BACK IF MORE CHARS ! 16775: * ! 16776: * HERE TO EXIT WITH CONVERTED INTEGER VALUE ! 16777: * ! 16778: GTN07 BNZ GTNNF,GTN32 JUMP IF NEGATIVE (ALL SET) ! 16779: NGI ELSE NEGATE ! 16780: INO GTN32 JUMP IF NO OVERFLOW ! 16781: BRN GTN36 ELSE SIGNAL ERROR ! 16782: EJC ! 16783: * ! 16784: * GTNUM (CONTINUED) ! 16785: * ! 16786: * HERE FOR A NON-DIGIT CHARACTER WHILE ATTEMPTING TO ! 16787: * CONVERT AN INTEGER, CHECK FOR TRAILING BLANKS OR REAL. ! 16788: * ! 16789: GTN08 BEQ WB,=CH$BL,GTNA9 JUMP IF A BLANK ! 16790: BEQ WB,=CH$HT,GTNA9 JUMP IF HORIZONTAL TAB ! 16791: ITR ELSE CONVERT INTEGER TO REAL ! 16792: NGR NEGATE TO GET POSITIVE VALUE ! 16793: BRN GTN12 JUMP TO TRY FOR REAL ! 16794: * ! 16795: * HERE WE SCAN OUT BLANKS TO END OF STRING ! 16796: * ! 16797: GTN09 LCH WB,(XR)+ GET NEXT CHAR ! 16798: BEQ WB,=CH$HT,GTNA9 JUMP IF HORIZONTAL TAB ! 16799: BNE WB,=CH$BL,GTN36 ERROR IF NON-BLANK ! 16800: GTNA9 BCT WA,GTN09 LOOP BACK IF MORE CHARS TO CHECK ! 16801: BRN GTN07 RETURN INTEGER IF ALL BLANKS ! 16802: * ! 16803: * LOOP TO COLLECT MANTISSA OF REAL ! 16804: * ! 16805: GTN10 LCH WB,(XR)+ LOAD NEXT CHARACTER ! 16806: BLT WB,=CH$D0,GTN12 JUMP IF NON-NUMERIC ! 16807: BGT WB,=CH$D9,GTN12 JUMP IF NON-NUMERIC ! 16808: * ! 16809: * MERGE HERE TO COLLECT FIRST REAL DIGIT ! 16810: * ! 16811: GTN11 SUB =CH$D0,WB CONVERT DIGIT TO NUMBER ! 16812: MLR REAVT MULTIPLY REAL BY 10.0 ! 16813: ROV GTN36 CONVERT ERROR IF OVERFLOW ! 16814: STR GTNSR SAVE RESULT ! 16815: MTI WB GET NEW DIGIT AS INTEGER ! 16816: ITR CONVERT NEW DIGIT TO REAL ! 16817: ADR GTNSR ADD TO GET NEW TOTAL ! 16818: ADD GTNDF,GTNSC INCREMENT SCALE IF AFTER DEC POINT ! 16819: MNZ GTNRD SET DIGIT FOUND FLAG ! 16820: BCT WA,GTN10 LOOP BACK IF MORE CHARS ! 16821: BRN GTN22 ELSE JUMP TO SCALE ! 16822: EJC ! 16823: * ! 16824: * GTNUM (CONTINUED) ! 16825: * ! 16826: * HERE IF NON-DIGIT FOUND WHILE COLLECTING A REAL ! 16827: * ! 16828: GTN12 BNE WB,=CH$DT,GTN13 JUMP IF NOT DEC POINT ! 16829: BNZ GTNDF,GTN36 IF DEC POINT, ERROR IF ONE ALREADY ! 16830: MOV =NUM01,GTNDF ELSE SET FLAG FOR DEC POINT ! 16831: BCT WA,GTN10 LOOP BACK IF MORE CHARS ! 16832: BRN GTN22 ELSE JUMP TO SCALE ! 16833: * ! 16834: * HERE IF NOT DECIMAL POINT ! 16835: * ! 16836: GTN13 BEQ WB,=CH$LE,GTN15 JUMP IF E FOR EXPONENT ! 16837: BEQ WB,=CH$LD,GTN15 JUMP IF D FOR EXPONENT ! 16838: BEQ WB,=CH$$E,GTN15 JUMP IF E FOR EXPONENT ! 16839: BEQ WB,=CH$$D,GTN15 JUMP IF D FOR EXPONENT ! 16840: * ! 16841: * HERE CHECK FOR TRAILING BLANKS ! 16842: * ! 16843: GTN14 BEQ WB,=CH$BL,GTNB4 JUMP IF BLANK ! 16844: BEQ WB,=CH$HT,GTNB4 JUMP IF HORIZONTAL TAB ! 16845: BRN GTN36 ERROR IF NON-BLANK ! 16846: * ! 16847: GTNB4 LCH WB,(XR)+ GET NEXT CHARACTER ! 16848: BCT WA,GTN14 LOOP BACK TO CHECK IF MORE ! 16849: BRN GTN22 ELSE JUMP TO SCALE ! 16850: * ! 16851: * HERE TO READ AND PROCESS AN EXPONENT ! 16852: * ! 16853: GTN15 ZER GTNES SET EXPONENT SIGN POSITIVE ! 16854: LDI INTV0 INITIALIZE EXPONENT TO ZERO ! 16855: MNZ GTNDF RESET NO DEC POINT INDICATION ! 16856: BCT WA,GTN16 JUMP SKIPPING PAST E OR D ! 16857: BRN GTN36 ERROR IF NULL EXPONENT ! 16858: * ! 16859: * CHECK FOR EXPONENT SIGN ! 16860: * ! 16861: GTN16 LCH WB,(XR)+ LOAD FIRST EXPONENT CHARACTER ! 16862: BEQ WB,=CH$PL,GTN17 JUMP IF PLUS SIGN ! 16863: BNE WB,=CH$MN,GTN19 ELSE JUMP IF NOT MINUS SIGN ! 16864: MNZ GTNES SET SIGN NEGATIVE IF MINUS SIGN ! 16865: * ! 16866: * MERGE HERE AFTER PROCESSING EXPONENT SIGN ! 16867: * ! 16868: GTN17 BCT WA,GTN18 JUMP IF CHARS LEFT ! 16869: BRN GTN36 ELSE ERROR ! 16870: * ! 16871: * LOOP TO CONVERT EXPONENT DIGITS ! 16872: * ! 16873: GTN18 LCH WB,(XR)+ LOAD NEXT CHARACTER ! 16874: EJC ! 16875: * ! 16876: * GTNUM (CONTINUED) ! 16877: * ! 16878: * MERGE HERE FOR FIRST EXPONENT DIGIT ! 16879: * ! 16880: GTN19 BLT WB,=CH$D0,GTN20 JUMP IF NOT DIGIT ! 16881: BGT WB,=CH$D9,GTN20 JUMP IF NOT DIGIT ! 16882: CVM GTN36 ELSE CURRENT*10, SUBTRACT NEW DIGIT ! 16883: BCT WA,GTN18 LOOP BACK IF MORE CHARS ! 16884: BRN GTN21 JUMP IF EXPONENT FIELD IS EXHAUSTED ! 16885: * ! 16886: * HERE TO CHECK FOR TRAILING BLANKS AFTER EXPONENT ! 16887: * ! 16888: GTN20 BEQ WB,=CH$BL,GTNC0 JUMP IF BLANK ! 16889: BEQ WB,=CH$HT,GTNC0 JUMP IF HORIZONTAL TAB ! 16890: BRN GTN36 ERROR IF NON-BLANK ! 16891: * ! 16892: GTNC0 LCH WB,(XR)+ GET NEXT CHARACTER ! 16893: BCT WA,GTN20 LOOP BACK TILL ALL BLANKS SCANNED ! 16894: * ! 16895: * MERGE HERE AFTER COLLECTING EXPONENT ! 16896: * ! 16897: GTN21 STI GTNEX SAVE COLLECTED EXPONENT ! 16898: BNZ GTNES,GTN22 JUMP IF IT WAS NEGATIVE ! 16899: NGI ELSE COMPLEMENT ! 16900: IOV GTN36 ERROR IF OVERFLOW ! 16901: STI GTNEX AND STORE POSITIVE EXPONENT ! 16902: * ! 16903: * MERGE HERE WITH EXPONENT (0 IF NONE GIVEN) ! 16904: * ! 16905: GTN22 BZE GTNRD,GTN36 ERROR IF NOT DIGITS COLLECTED ! 16906: BZE GTNDF,GTN36 ERROR IF NO EXPONENT OR DEC POINT ! 16907: MTI GTNSC ELSE LOAD SCALE AS INTEGER ! 16908: SBI GTNEX SUBTRACT EXPONENT ! 16909: IOV GTN36 ERROR IF OVERFLOW ! 16910: ILT GTN26 JUMP IF WE MUST SCALE UP ! 16911: * ! 16912: * HERE WE HAVE A NEGATIVE EXPONENT, SO SCALE DOWN ! 16913: * ! 16914: MFI WA,GTN36 LOAD SCALE FACTOR, ERR IF OVFLOW ! 16915: * ! 16916: * LOOP TO SCALE DOWN IN STEPS OF 10**10 ! 16917: * ! 16918: GTN23 BLE WA,=NUM10,GTN24 JUMP IF 10 OR LESS TO GO ! 16919: DVR REATT ELSE DIVIDE BY 10**10 ! 16920: SUB =NUM10,WA DECREMENT SCALE ! 16921: BRN GTN23 AND LOOP BACK ! 16922: EJC ! 16923: * ! 16924: * GTNUM (CONTINUED) ! 16925: * ! 16926: * HERE SCALE REST OF WAY FROM POWERS OF TEN TABLE ! 16927: * ! 16928: GTN24 BZE WA,GTN30 JUMP IF SCALED ! 16929: LCT WB,=CFP$R ELSE GET INDEXING FACTOR ! 16930: MOV =REAV1,XR POINT TO POWERS OF TEN TABLE ! 16931: WTB WA CONVERT REMAINING SCALE TO BYTE OFS ! 16932: * ! 16933: * LOOP TO POINT TO POWERS OF TEN TABLE ENTRY ! 16934: * ! 16935: GTN25 ADD WA,XR BUMP POINTER ! 16936: BCT WB,GTN25 ONCE FOR EACH VALUE WORD ! 16937: DVR (XR) SCALE DOWN AS REQUIRED ! 16938: BRN GTN30 AND JUMP ! 16939: * ! 16940: * COME HERE TO SCALE RESULT UP (POSITIVE EXPONENT) ! 16941: * ! 16942: GTN26 NGI GET ABSOLUTE VALUE OF EXPONENT ! 16943: IOV GTN36 ERROR IF OVERFLOW ! 16944: MFI WA,GTN36 ACQUIRE SCALE, ERROR IF OVFLOW ! 16945: * ! 16946: * LOOP TO SCALE UP IN STEPS OF 10**10 ! 16947: * ! 16948: GTN27 BLE WA,=NUM10,GTN28 JUMP IF 10 OR LESS TO GO ! 16949: MLR REATT ELSE MULTIPLY BY 10**10 ! 16950: ROV GTN36 ERROR IF OVERFLOW ! 16951: SUB =NUM10,WA ELSE DECREMENT SCALE ! 16952: BRN GTN27 AND LOOP BACK ! 16953: * ! 16954: * HERE TO SCALE UP REST OF WAY WITH TABLE ! 16955: * ! 16956: GTN28 BZE WA,GTN30 JUMP IF SCALED ! 16957: LCT WB,=CFP$R ELSE GET INDEXING FACTOR ! 16958: MOV =REAV1,XR POINT TO POWERS OF TEN TABLE ! 16959: WTB WA CONVERT REMAINING SCALE TO BYTE OFS ! 16960: * ! 16961: * LOOP TO POINT TO PROPER ENTRY IN POWERS OF TEN TABLE ! 16962: * ! 16963: GTN29 ADD WA,XR BUMP POINTER ! 16964: BCT WB,GTN29 ONCE FOR EACH WORD IN VALUE ! 16965: MLR (XR) SCALE UP ! 16966: ROV GTN36 ERROR IF OVERFLOW ! 16967: EJC ! 16968: * ! 16969: * GTNUM (CONTINUED) ! 16970: * ! 16971: * HERE WITH REAL VALUE SCALED AND READY EXCEPT FOR SIGN ! 16972: * ! 16973: GTN30 BZE GTNNF,GTN31 JUMP IF POSITIVE ! 16974: NGR ELSE NEGATE ! 16975: * ! 16976: * HERE WITH PROPERLY SIGNED REAL VALUE IN (RA) ! 16977: * ! 16978: GTN31 JSR RCBLD BUILD REAL BLOCK ! 16979: BRN GTN33 MERGE TO EXIT ! 16980: * ! 16981: * HERE WITH PROPERLY SIGNED INTEGER VALUE IN (IA) ! 16982: * ! 16983: GTN32 JSR ICBLD BUILD ICBLK ! 16984: * ! 16985: * REAL MERGES HERE ! 16986: * ! 16987: GTN33 MOV (XR),WA LOAD FIRST WORD OF RESULT BLOCK ! 16988: ICA XS POP ARGUMENT OFF STACK ! 16989: * ! 16990: * COMMON EXIT POINT ! 16991: * ! 16992: GTN34 EXI RETURN TO GTNUM CALLER ! 16993: * ! 16994: * COME HERE IF OVERFLOW OCCURS DURING COLLECTION OF INTEGER ! 16995: * ! 16996: GTN35 LDI GTNSI RELOAD INTEGER SO FAR ! 16997: ITR CONVERT TO REAL ! 16998: NGR MAKE VALUE POSITIVE ! 16999: BRN GTN11 MERGE WITH REAL CIRCUIT ! 17000: * ! 17001: * HERE FOR UNCONVERTIBLE TO STRING OR CONVERSION ERROR ! 17002: * ! 17003: GTN36 MOV (XS)+,XR RELOAD ORIGINAL ARGUMENT ! 17004: EXI 1 TAKE CONVERT-ERROR EXIT ! 17005: ENP END PROCEDURE GTNUM ! 17006: EJC ! 17007: * ! 17008: * GTNVR -- CONVERT TO NATURAL VARIABLE ! 17009: * ! 17010: * GTNVR LOCATES A VARIABLE BLOCK (VRBLK) GIVEN EITHER AN ! 17011: * APPROPRIATE NAME (NMBLK) OR A NON-NULL STRING (SCBLK). ! 17012: * ! 17013: * (XR) ARGUMENT ! 17014: * JSR GTNVR CALL TO CONVERT TO NATURAL VARIABLE ! 17015: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 17016: * (XR) POINTER TO VRBLK ! 17017: * (WA,WB) DESTROYED (CONVERSION ERROR ONLY) ! 17018: * (WC) DESTROYED ! 17019: * ! 17020: GTNVR PRC E,1 ENTRY POINT ! 17021: BNE (XR),=B$NML,GNV02 JUMP IF NOT NAME ! 17022: MOV NMBAS(XR),XR ELSE LOAD NAME BASE IF NAME ! 17023: BLO XR,STATE,GNV07 SKIP IF VRBLK (IN STATIC REGION) ! 17024: * ! 17025: * COMMON ERROR EXIT ! 17026: * ! 17027: GNV01 EXI 1 TAKE CONVERT-ERROR EXIT ! 17028: * ! 17029: * HERE IF NOT NAME ! 17030: * ! 17031: GNV02 MOV WA,GNVSA SAVE WA ! 17032: MOV WB,GNVSB SAVE WB ! 17033: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG ! 17034: JSR GTSTG CONVERT ARGUMENT TO STRING ! 17035: PPM GNV01 JUMP IF CONVERSION ERROR ! 17036: BZE WA,GNV01 NULL STRING IS AN ERROR ! 17037: JSR FLSTG FOLD LOWER CASE TO UPPER CASE ! 17038: MOV XL,-(XS) SAVE XL ! 17039: MOV XR,-(XS) STACK STRING PTR FOR LATER ! 17040: MOV XR,WB COPY STRING POINTER ! 17041: ADD *SCHAR,WB POINT TO CHARACTERS OF STRING ! 17042: MOV WB,GNVST SAVE POINTER TO CHARACTERS ! 17043: MOV WA,WB COPY LENGTH ! 17044: CTW WB,0 GET NUMBER OF WORDS IN NAME ! 17045: MOV WB,GNVNW SAVE FOR LATER ! 17046: JSR HASHS COMPUTE HASH INDEX FOR STRING ! 17047: RMI HSHNB COMPUTE HASH OFFSET BY TAKING MOD ! 17048: MFI WC GET AS OFFSET ! 17049: WTB WC CONVERT OFFSET TO BYTES ! 17050: ADD HSHTB,WC POINT TO PROPER HASH CHAIN ! 17051: SUB *VRNXT,WC SUBTRACT OFFSET TO MERGE INTO LOOP ! 17052: EJC ! 17053: * ! 17054: * GTNVR (CONTINUED) ! 17055: * ! 17056: * LOOP TO SEARCH HASH CHAIN ! 17057: * ! 17058: GNV03 MOV WC,XL COPY HASH CHAIN POINTER ! 17059: MOV VRNXT(XL),XL POINT TO NEXT VRBLK ON CHAIN ! 17060: BZE XL,GNV08 JUMP IF END OF CHAIN ! 17061: MOV XL,WC SAVE POINTER TO THIS VRBLK ! 17062: BNZ VRLEN(XL),GNV04 JUMP IF NOT SYSTEM VARIABLE ! 17063: MOV VRSVP(XL),XL ELSE POINT TO SVBLK ! 17064: SUB *VRSOF,XL ADJUST OFFSET FOR MERGE ! 17065: * ! 17066: * MERGE HERE WITH STRING PTR (LIKE VRBLK) IN XL ! 17067: * ! 17068: GNV04 BNE WA,VRLEN(XL),GNV03 BACK FOR NEXT VRBLK IF LENGTHS NE ! 17069: ADD *VRCHS,XL ELSE POINT TO CHARS OF CHAIN ENTRY ! 17070: LCT WB,GNVNW GET WORD COUNTER TO CONTROL LOOP ! 17071: MOV GNVST,XR POINT TO CHARS OF NEW NAME ! 17072: * ! 17073: * LOOP TO COMPARE CHARACTERS OF THE TWO NAMES ! 17074: * ! 17075: GNV05 CNE (XR),(XL),GNV03 JUMP IF NO MATCH FOR NEXT VRBLK ! 17076: ICA XR BUMP NEW NAME POINTER ! 17077: ICA XL BUMP VRBLK IN CHAIN NAME POINTER ! 17078: BCT WB,GNV05 ELSE LOOP TILL ALL COMPARED ! 17079: MOV WC,XR WE HAVE FOUND A MATCH, GET VRBLK ! 17080: * ! 17081: * EXIT POINT AFTER FINDING VRBLK OR BUILDING NEW ONE ! 17082: * ! 17083: GNV06 MOV GNVSA,WA RESTORE WA ! 17084: MOV GNVSB,WB RESTORE WB ! 17085: ICA XS POP STRING POINTER ! 17086: MOV (XS)+,XL RESTORE XL ! 17087: * ! 17088: * COMMON EXIT POINT ! 17089: * ! 17090: GNV07 EXI RETURN TO GTNVR CALLER ! 17091: * ! 17092: * NOT FOUND, PREPARE TO SEARCH SYSTEM VARIABLE TABLE ! 17093: * ! 17094: GNV08 ZER XR CLEAR GARBAGE XR POINTER ! 17095: MOV WC,GNVHE SAVE PTR TO END OF HASH CHAIN ! 17096: BGT WA,=NUM09,GNV14 CANNOT BE SYSTEM VAR IF LENGTH GT 9 ! 17097: MOV WA,XL ELSE COPY LENGTH ! 17098: WTB XL CONVERT TO BYTE OFFSET ! 17099: MOV VSRCH(XL),XL POINT TO FIRST SVBLK OF THIS LENGTH ! 17100: EJC ! 17101: * ! 17102: * GTNVR (CONTINUED) ! 17103: * ! 17104: * LOOP TO SEARCH ENTRIES IN STANDARD VARIABLE TABLE ! 17105: * ! 17106: GNV09 MOV XL,GNVSP SAVE TABLE POINTER ! 17107: MOV (XL)+,WC LOAD SVBIT BIT STRING ! 17108: MOV (XL)+,WB LOAD LENGTH FROM TABLE ENTRY ! 17109: BNE WA,WB,GNV14 JUMP IF END OF RIGHT LENGTH ENTIRES ! 17110: LCT WB,GNVNW GET WORD COUNTER TO CONTROL LOOP ! 17111: MOV GNVST,XR POINT TO CHARS OF NEW NAME ! 17112: * ! 17113: * LOOP TO CHECK FOR MATCHING NAMES ! 17114: * ! 17115: GNV10 CNE (XR),(XL),GNV11 JUMP IF NAME MISMATCH ! 17116: ICA XR ELSE BUMP NEW NAME POINTER ! 17117: ICA XL BUMP SVBLK POINTER ! 17118: BCT WB,GNV10 ELSE LOOP UNTIL ALL CHECKED ! 17119: * ! 17120: * HERE WE HAVE A MATCH IN THE STANDARD VARIABLE TABLE ! 17121: * ! 17122: ZER WC SET VRLEN VALUE ZERO ! 17123: MOV *VRSI$,WA SET STANDARD SIZE ! 17124: BRN GNV15 JUMP TO BUILD VRBLK ! 17125: * ! 17126: * HERE IF NO MATCH WITH TABLE ENTRY IN SVBLKS TABLE ! 17127: * ! 17128: GNV11 ICA XL BUMP PAST WORD OF CHARS ! 17129: BCT WB,GNV11 LOOP BACK IF MORE TO GO ! 17130: RSH WC,SVNBT REMOVE UNINTERESTING BITS ! 17131: * ! 17132: * LOOP TO BUMP TABLE PTR FOR EACH FLAGGED WORD ! 17133: * ! 17134: GNV12 MOV BITS1,WB LOAD BIT TO TEST ! 17135: ANB WC,WB TEST FOR WORD PRESENT ! 17136: ZRB WB,GNV13 JUMP IF NOT PRESENT ! 17137: ICA XL ELSE BUMP TABLE POINTER ! 17138: * ! 17139: * HERE AFTER DEALING WITH ONE WORD (ONE BIT) ! 17140: * ! 17141: GNV13 RSH WC,1 REMOVE BIT ALREADY PROCESSED ! 17142: NZB WC,GNV12 LOOP BACK IF MORE BITS TO TEST ! 17143: BRN GNV09 ELSE LOOP BACK FOR NEXT SVBLK ! 17144: * ! 17145: * HERE IF NOT SYSTEM VARIABLE ! 17146: * ! 17147: GNV14 MOV WA,WC COPY VRLEN VALUE ! 17148: MOV =VRCHS,WA LOAD STANDARD SIZE -CHARS ! 17149: ADD GNVNW,WA ADJUST FOR CHARS OF NAME ! 17150: WTB WA CONVERT LENGTH TO BYTES ! 17151: EJC ! 17152: * ! 17153: * GTNVR (CONTINUED) ! 17154: * ! 17155: * MERGE HERE TO BUILD VRBLK ! 17156: * ! 17157: GNV15 JSR ALOST ALLOCATE SPACE FOR VRBLK (STATIC) ! 17158: MOV XR,WB SAVE VRBLK POINTER ! 17159: MOV =STNVR,XL POINT TO MODEL VARIABLE BLOCK ! 17160: MOV *VRLEN,WA SET LENGTH OF STANDARD FIELDS ! 17161: MVW SET INITIAL FIELDS OF NEW BLOCK ! 17162: MOV GNVHE,XL LOAD POINTER TO END OF HASH CHAIN ! 17163: MOV WB,VRNXT(XL) ADD NEW BLOCK TO END OF CHAIN ! 17164: MOV WC,(XR)+ SET VRLEN FIELD, BUMP PTR ! 17165: MOV GNVNW,WA GET LENGTH IN WORDS ! 17166: WTB WA CONVERT TO LENGTH IN BYTES ! 17167: BZE WC,GNV16 JUMP IF SYSTEM VARIABLE ! 17168: * ! 17169: * HERE FOR NON-SYSTEM VARIABLE -- SET CHARS OF NAME ! 17170: * ! 17171: MOV (XS),XL POINT BACK TO STRING NAME ! 17172: ADD *SCHAR,XL POINT TO CHARS OF NAME ! 17173: MVW MOVE CHARACTERS INTO PLACE ! 17174: MOV WB,XR RESTORE VRBLK POINTER ! 17175: BRN GNV06 JUMP BACK TO EXIT ! 17176: * ! 17177: * HERE FOR SYSTEM VARIABLE CASE TO FILL IN FIELDS WHERE ! 17178: * NECESSARY FROM THE FIELDS PRESENT IN THE SVBLK. ! 17179: * ! 17180: GNV16 MOV GNVSP,XL LOAD POINTER TO SVBLK ! 17181: MOV XL,(XR) SET SVBLK PTR IN VRBLK ! 17182: MOV WB,XR RESTORE VRBLK POINTER ! 17183: MOV SVBIT(XL),WB LOAD BIT INDICATORS ! 17184: ADD *SVCHS,XL POINT TO CHARACTERS OF NAME ! 17185: ADD WA,XL POINT PAST CHARACTERS ! 17186: * ! 17187: * SKIP PAST KEYWORD NUMBER (SVKNM) IF PRESENT ! 17188: * ! 17189: MOV BTKNM,WC LOAD TEST BIT ! 17190: ANB WB,WC AND TO TEST ! 17191: ZRB WC,GNV17 JUMP IF NO KEYWORD NUMBER ! 17192: ICA XL ELSE BUMP POINTER ! 17193: EJC ! 17194: * ! 17195: * GTNVR (CONTINUED) ! 17196: * ! 17197: * HERE TEST FOR FUNCTION (SVFNC AND SVNAR) ! 17198: * ! 17199: GNV17 MOV BTFNC,WC GET TEST BIT ! 17200: ANB WB,WC AND TO TEST ! 17201: ZRB WC,GNV18 SKIP IF NO SYSTEM FUNCTION ! 17202: MOV XL,VRFNC(XR) ELSE POINT VRFNC TO SVFNC FIELD ! 17203: ADD *NUM02,XL AND BUMP PAST SVFNC, SVNAR FIELDS ! 17204: * ! 17205: * NOW TEST FOR LABEL (SVLBL) ! 17206: * ! 17207: GNV18 MOV BTLBL,WC GET TEST BIT ! 17208: ANB WB,WC AND TO TEST ! 17209: ZRB WC,GNV19 JUMP IF BIT IS OFF (NO SYSTEM LABL) ! 17210: MOV XL,VRLBL(XR) ELSE POINT VRLBL TO SVLBL FIELD ! 17211: ICA XL BUMP PAST SVLBL FIELD ! 17212: * ! 17213: * NOW TEST FOR VALUE (SVVAL) ! 17214: * ! 17215: GNV19 MOV BTVAL,WC LOAD TEST BIT ! 17216: ANB WB,WC AND TO TEST ! 17217: ZRB WC,GNV06 ALL DONE IF NO VALUE ! 17218: MOV (XL),VRVAL(XR) ELSE SET INITIAL VALUE ! 17219: MOV =B$VRE,VRSTO(XR) SET ERROR STORE ACCESS ! 17220: BRN GNV06 MERGE BACK TO EXIT TO CALLER ! 17221: ENP END PROCEDURE GTNVR ! 17222: EJC ! 17223: * ! 17224: * GTPAT -- GET PATTERN ! 17225: * ! 17226: * GTPAT IS PASSED AN OBJECT IN (XR) AND RETURNS A ! 17227: * PATTERN AFTER PERFORMING ANY NECESSARY CONVERSIONS ! 17228: * ! 17229: * (XR) INPUT ARGUMENT ! 17230: * JSR GTPAT CALL TO CONVERT TO PATTERN ! 17231: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 17232: * (XR) RESULTING PATTERN ! 17233: * (WA) DESTROYED ! 17234: * (WB) DESTROYED (ONLY ON CONVERT ERROR) ! 17235: * (XR) UNCHANGED (ONLY ON CONVERT ERROR) ! 17236: * ! 17237: GTPAT PRC E,1 ENTRY POINT ! 17238: BHI (XR),=P$AAA,GTPT5 JUMP IF PATTERN ALREADY ! 17239: * ! 17240: * HERE IF NOT PATTERN, TRY FOR STRING ! 17241: * ! 17242: MOV WB,GTPSB SAVE WB ! 17243: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG ! 17244: JSR GTSTG CONVERT ARGUMENT TO STRING ! 17245: PPM GTPT2 JUMP IF IMPOSSIBLE ! 17246: * ! 17247: * HERE WE HAVE A STRING ! 17248: * ! 17249: BNZ WA,GTPT1 JUMP IF NON-NULL ! 17250: * ! 17251: * HERE FOR NULL STRING. GENERATE POINTER TO NULL PATTERN. ! 17252: * ! 17253: MOV =NDNTH,XR POINT TO NOTHEN NODE ! 17254: BRN GTPT4 JUMP TO EXIT ! 17255: EJC ! 17256: * ! 17257: * GTPAT (CONTINUED) ! 17258: * ! 17259: * HERE FOR NON-NULL STRING ! 17260: * ! 17261: GTPT1 MOV =P$STR,WB LOAD PCODE FOR MULTI-CHAR STRING ! 17262: BNE WA,=NUM01,GTPT3 JUMP IF MULTI-CHAR STRING ! 17263: * ! 17264: * HERE FOR ONE CHARACTER STRING, SHARE ONE CHARACTER ANY ! 17265: * ! 17266: PLC XR POINT TO CHARACTER ! 17267: LCH WA,(XR) LOAD CHARACTER ! 17268: MOV WA,XR SET AS PARM1 ! 17269: MOV =P$ANS,WB POINT TO PCODE FOR 1-CHAR ANY ! 17270: BRN GTPT3 JUMP TO BUILD NODE ! 17271: * ! 17272: * HERE IF ARGUMENT IS NOT CONVERTIBLE TO STRING ! 17273: * ! 17274: GTPT2 MOV =P$EXA,WB SET PCODE FOR EXPRESSION IN CASE ! 17275: BLO (XR),=B$E$$,GTPT3 JUMP TO BUILD NODE IF EXPRESSION ! 17276: * ! 17277: * HERE WE HAVE AN ERROR (CONVERSION IMPOSSIBLE) ! 17278: * ! 17279: EXI 1 TAKE CONVERT ERROR EXIT ! 17280: * ! 17281: * MERGE HERE TO BUILD NODE FOR STRING OR EXPRESSION ! 17282: * ! 17283: GTPT3 JSR PBILD CALL ROUTINE TO BUILD PATTERN NODE ! 17284: * ! 17285: * COMMON EXIT AFTER SUCCESSFUL CONVERSION ! 17286: * ! 17287: GTPT4 MOV GTPSB,WB RESTORE WB ! 17288: * ! 17289: * MERGE HERE TO EXIT OF NO CONVERSION REQUIRED ! 17290: * ! 17291: GTPT5 EXI RETURN TO GTPAT CALLER ! 17292: ENP END PROCEDURE GTPAT ! 17293: EJC ! 17294: * ! 17295: * GTREA -- GET REAL VALUE ! 17296: * ! 17297: * GTREA IS PASSED AN OBJECT AND RETURNS A REAL VALUE ! 17298: * PERFORMING ANY NECESSARY CONVERSIONS. ! 17299: * ! 17300: * (XR) OBJECT TO BE CONVERTED ! 17301: * JSR GTREA CALL TO CONVERT OBJECT TO REAL ! 17302: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 17303: * (XR) POINTER TO RESULTING REAL ! 17304: * (WA,WB,WC,RA) DESTROYED ! 17305: * (XR) UNCHANGED (CONVERT ERROR ONLY) ! 17306: * ! 17307: GTREA PRC E,1 ENTRY POINT ! 17308: MOV (XR),WA GET FIRST WORD OF BLOCK ! 17309: BEQ WA,=B$RCL,GTRE2 JUMP IF REAL ! 17310: JSR GTNUM ELSE CONVERT ARGUMENT TO NUMERIC ! 17311: PPM GTRE3 JUMP IF UNCONVERTIBLE ! 17312: BEQ WA,=B$RCL,GTRE2 JUMP IF REAL WAS RETURNED ! 17313: * ! 17314: * HERE FOR CASE OF AN INTEGER TO CONVERT TO REAL ! 17315: * ! 17316: GTRE1 LDI ICVAL(XR) LOAD INTEGER ! 17317: ITR CONVERT TO REAL ! 17318: JSR RCBLD BUILD RCBLK ! 17319: * ! 17320: * EXIT WITH REAL ! 17321: * ! 17322: GTRE2 EXI RETURN TO GTREA CALLER ! 17323: * ! 17324: * HERE ON CONVERSION ERROR ! 17325: * ! 17326: GTRE3 EXI 1 TAKE CONVERT ERROR EXIT ! 17327: ENP END PROCEDURE GTREA ! 17328: EJC ! 17329: * ! 17330: * GTSMI -- GET SMALL INTEGER ! 17331: * ! 17332: * GTSMI IS PASSED A SNOBOL OBJECT AND RETURNS AN ADDRESS ! 17333: * INTEGER IN THE RANGE (0 LE N LE DNAMB). SUCH A VALUE CAN ! 17334: * ONLY BE DERIVED FROM AN INTEGER IN THE APPROPRIATE RANGE. ! 17335: * SMALL INTEGERS NEVER APPEAR AS SNOBOL VALUES. HOWEVER, ! 17336: * THEY ARE USED INTERNALLY FOR A VARIETY OF PURPOSES. ! 17337: * ! 17338: * -(XS) ARGUMENT TO CONVERT (ON STACK) ! 17339: * JSR GTSMI CALL TO CONVERT TO SMALL INTEGER ! 17340: * PPM LOC TRANSFER LOC FOR NOT INTEGER ! 17341: * PPM LOC TRANSFER LOC FOR LT 0, GT DNAMB ! 17342: * (XR,WC) RESULTING SMALL INT (TWO COPIES) ! 17343: * (XS) POPPED ! 17344: * (RA) DESTROYED ! 17345: * (WA,WB) DESTROYED (ON CONVERT ERROR ONLY) ! 17346: * (XR) INPUT ARG (CONVERT ERROR ONLY) ! 17347: * ! 17348: GTSMI PRC N,2 ENTRY POINT ! 17349: MOV (XS)+,XR LOAD ARGUMENT ! 17350: BEQ (XR),=B$ICL,GTSM1 SKIP IF ALREADY AN INTEGER ! 17351: * ! 17352: * HERE IF NOT AN INTEGER ! 17353: * ! 17354: JSR GTINT CONVERT ARGUMENT TO INTEGER ! 17355: PPM GTSM2 JUMP IF CONVERT IS IMPOSSIBLE ! 17356: * ! 17357: * MERGE HERE WITH INTEGER ! 17358: * ! 17359: GTSM1 LDI ICVAL(XR) LOAD INTEGER VALUE ! 17360: MFI WC,GTSM3 MOVE AS ONE WORD, JUMP IF OVFLOW ! 17361: BGT WC,MXLEN,GTSM3 OR IF TOO SMALL ! 17362: MOV WC,XR COPY RESULT TO XR ! 17363: EXI RETURN TO GTSMI CALLER ! 17364: * ! 17365: * HERE IF UNCONVERTIBLE TO INTEGER ! 17366: * ! 17367: GTSM2 EXI 1 TAKE NON-INTEGER ERROR EXIT ! 17368: * ! 17369: * HERE IF OUT OF RANGE ! 17370: * ! 17371: GTSM3 EXI 2 TAKE OUT-OF-RANGE ERROR EXIT ! 17372: ENP END PROCEDURE GTSMI ! 17373: EJC ! 17374: * ! 17375: * GTSTG -- GET STRING ! 17376: * ! 17377: * GTSTG IS PASSED AN OBJECT AND RETURNS A STRING WITH ! 17378: * ANY NECESSARY CONVERSIONS PERFORMED. ! 17379: * ! 17380: * -(XS) INPUT ARGUMENT (ON STACK) ! 17381: * JSR GTSTG CALL TO CONVERT TO STRING ! 17382: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 17383: * (XR) POINTER TO RESULTING STRING ! 17384: * (WA) LENGTH OF STRING IN CHARACTERS ! 17385: * (XS) POPPED ! 17386: * (RA) DESTROYED ! 17387: * (XR) INPUT ARG (CONVERT ERROR ONLY) ! 17388: * ! 17389: GTSTG PRC N,1 ENTRY POINT ! 17390: MOV (XS)+,XR LOAD ARGUMENT, POP STACK ! 17391: BEQ (XR),=B$SCL,GTS30 JUMP IF ALREADY A STRING ! 17392: * ! 17393: * HERE IF NOT A STRING ALREADY ! 17394: * ! 17395: GTS01 MOV XR,-(XS) RESTACK ARGUMENT IN CASE ERROR ! 17396: MOV XL,-(XS) SAVE XL ! 17397: MOV WB,GTSVB SAVE WB ! 17398: MOV WC,GTSVC SAVE WC ! 17399: MOV (XR),WA LOAD FIRST WORD OF BLOCK ! 17400: BEQ WA,=B$ICL,GTS05 JUMP TO CONVERT INTEGER ! 17401: BEQ WA,=B$RCL,GTS10 JUMP TO CONVERT REAL ! 17402: BEQ WA,=B$NML,GTS03 JUMP TO CONVERT NAME ! 17403: BEQ WA,=B$BCT,GTS32 JUMP TO CONVERT BUFFER ! 17404: * ! 17405: * HERE ON CONVERSION ERROR ! 17406: * ! 17407: GTS02 MOV (XS)+,XL RESTORE XL ! 17408: MOV (XS)+,XR RELOAD INPUT ARGUMENT ! 17409: EXI 1 TAKE CONVERT ERROR EXIT ! 17410: EJC ! 17411: * ! 17412: * GTSTG (CONTINUED) ! 17413: * ! 17414: * HERE TO CONVERT A NAME (ONLY POSSIBLE IF NATURAL VAR) ! 17415: * ! 17416: GTS03 MOV NMBAS(XR),XL LOAD NAME BASE ! 17417: BHI XL,STATE,GTS02 ERROR IF NOT NATURAL VAR (STATIC) ! 17418: ADD *VRSOF,XL ELSE POINT TO POSSIBLE STRING NAME ! 17419: MOV SCLEN(XL),WA LOAD LENGTH ! 17420: BNZ WA,GTS04 JUMP IF NOT SYSTEM VARIABLE ! 17421: MOV VRSVO(XL),XL ELSE POINT TO SVBLK ! 17422: MOV SVLEN(XL),WA AND LOAD NAME LENGTH ! 17423: * ! 17424: * MERGE HERE WITH STRING IN XR, LENGTH IN WA ! 17425: * ! 17426: GTS04 ZER WB SET OFFSET TO ZERO ! 17427: JSR SBSTR USE SBSTR TO COPY STRING ! 17428: BRN GTS29 JUMP TO EXIT ! 17429: * ! 17430: * COME HERE TO CONVERT AN INTEGER ! 17431: * ! 17432: GTS05 LDI ICVAL(XR) LOAD INTEGER VALUE ! 17433: MOV =NUM01,GTSSF SET SIGN FLAG NEGATIVE ! 17434: ILT GTS06 SKIP IF INTEGER IS NEGATIVE ! 17435: NGI ELSE NEGATE INTEGER ! 17436: ZER GTSSF AND RESET NEGATIVE FLAG ! 17437: EJC ! 17438: * ! 17439: * GTSTG (CONTINUED) ! 17440: * ! 17441: * HERE WITH SIGN FLAG SET AND SIGN FORCED NEGATIVE AS ! 17442: * REQUIRED BY THE CVD INSTRUCTION. ! 17443: * ! 17444: GTS06 MOV GTSWK,XR POINT TO RESULT WORK AREA ! 17445: MOV =NSTMX,WB INITIALIZE COUNTER TO MAX LENGTH ! 17446: PSC XR,WB PREPARE TO STORE (RIGHT-LEFT) ! 17447: * ! 17448: * LOOP TO CONVERT DIGITS INTO WORK AREA ! 17449: * ! 17450: GTS07 CVD CONVERT ONE DIGIT INTO WA ! 17451: SCH WA,-(XR) STORE IN WORK AREA ! 17452: DCV WB DECREMENT COUNTER ! 17453: INE GTS07 LOOP IF MORE DIGITS TO GO ! 17454: CSC XR COMPLETE STORE CHARACTERS ! 17455: * ! 17456: * MERGE HERE AFTER CONVERTING INTEGER OR REAL INTO WORK ! 17457: * AREA. WB IS SET TO NSTMX - (NUMBER OF CHARS IN RESULT). ! 17458: * ! 17459: GTS08 MOV =NSTMX,WA GET MAX NUMBER OF CHARACTERS ! 17460: SUB WB,WA COMPUTE LENGTH OF RESULT ! 17461: MOV WA,XL REMEMBER LENGTH FOR MOVE LATER ON ! 17462: ADD GTSSF,WA ADD ONE FOR NEGATIVE SIGN IF NEEDED ! 17463: JSR ALOCS ALLOCATE STRING FOR RESULT ! 17464: MOV XR,WC SAVE RESULT POINTER FOR THE MOMENT ! 17465: PSC XR POINT TO CHARS OF RESULT BLOCK ! 17466: BZE GTSSF,GTS09 SKIP IF POSITIVE ! 17467: MOV =CH$MN,WA ELSE LOAD NEGATIVE SIGN ! 17468: SCH WA,(XR)+ AND STORE IT ! 17469: CSC XR COMPLETE STORE CHARACTERS ! 17470: * ! 17471: * HERE AFTER DEALING WITH SIGN ! 17472: * ! 17473: GTS09 MOV XL,WA RECALL LENGTH TO MOVE ! 17474: MOV GTSWK,XL POINT TO RESULT WORK AREA ! 17475: PLC XL,WB POINT TO FIRST RESULT CHARACTER ! 17476: MVC MOVE CHARS TO RESULT STRING ! 17477: MOV WC,XR RESTORE RESULT POINTER ! 17478: BRN GTS29 JUMP TO EXIT ! 17479: EJC ! 17480: * ! 17481: * GTSTG (CONTINUED) ! 17482: * ! 17483: * HERE TO CONVERT A REAL ! 17484: * ! 17485: GTS10 LDR RCVAL(XR) LOAD REAL ! 17486: ZER GTSSF RESET NEGATIVE FLAG ! 17487: REQ GTS31 SKIP IF ZERO ! 17488: RGE GTS11 JUMP IF REAL IS POSITIVE ! 17489: MOV =NUM01,GTSSF ELSE SET NEGATIVE FLAG ! 17490: NGR AND GET ABSOLUTE VALUE OF REAL ! 17491: * ! 17492: * NOW SCALE THE REAL TO THE RANGE (0.1 LE X LT 1.0) ! 17493: * ! 17494: GTS11 LDI INTV0 INITIALIZE EXPONENT TO ZERO ! 17495: * ! 17496: * LOOP TO SCALE UP IN STEPS OF 10**10 ! 17497: * ! 17498: GTS12 STR GTSRS SAVE REAL VALUE ! 17499: SBR REAP1 SUBTRACT 0.1 TO COMPARE ! 17500: RGE GTS13 JUMP IF SCALE UP NOT REQUIRED ! 17501: LDR GTSRS ELSE RELOAD VALUE ! 17502: MLR REATT MULTIPLY BY 10**10 ! 17503: SBI INTVT DECREMENT EXPONENT BY 10 ! 17504: BRN GTS12 LOOP BACK TO TEST AGAIN ! 17505: * ! 17506: * TEST FOR SCALE DOWN REQUIRED ! 17507: * ! 17508: GTS13 LDR GTSRS RELOAD VALUE ! 17509: SBR REAV1 SUBTRACT 1.0 ! 17510: RLT GTS17 JUMP IF NO SCALE DOWN REQUIRED ! 17511: LDR GTSRS ELSE RELOAD VALUE ! 17512: * ! 17513: * LOOP TO SCALE DOWN IN STEPS OF 10**10 ! 17514: * ! 17515: GTS14 SBR REATT SUBTRACT 10**10 TO COMPARE ! 17516: RLT GTS15 JUMP IF LARGE STEP NOT REQUIRED ! 17517: LDR GTSRS ELSE RESTORE VALUE ! 17518: DVR REATT DIVIDE BY 10**10 ! 17519: STR GTSRS STORE NEW VALUE ! 17520: ADI INTVT INCREMENT EXPONENT BY 10 ! 17521: BRN GTS14 LOOP BACK ! 17522: EJC ! 17523: * ! 17524: * GTSTG (CONTINUED) ! 17525: * ! 17526: * AT THIS POINT WE HAVE (1.0 LE X LT 10**10) ! 17527: * COMPLETE SCALING WITH POWERS OF TEN TABLE ! 17528: * ! 17529: GTS15 MOV =REAV1,XR POINT TO POWERS OF TEN TABLE ! 17530: * ! 17531: * LOOP TO LOCATE CORRECT ENTRY IN TABLE ! 17532: * ! 17533: GTS16 LDR GTSRS RELOAD VALUE ! 17534: ADI INTV1 INCREMENT EXPONENT ! 17535: ADD *CFP$R,XR POINT TO NEXT ENTRY IN TABLE ! 17536: SBR (XR) SUBTRACT IT TO COMPARE ! 17537: RGE GTS16 LOOP TILL WE FIND A LARGER ENTRY ! 17538: LDR GTSRS THEN RELOAD THE VALUE ! 17539: DVR (XR) AND COMPLETE SCALING ! 17540: STR GTSRS STORE VALUE ! 17541: * ! 17542: * WE ARE NOW SCALED, SO ROUND BY ADDING 0.5 * 10**(-CFP$S) ! 17543: * ! 17544: GTS17 LDR GTSRS GET VALUE AGAIN ! 17545: ADR GTSRN ADD ROUNDING FACTOR ! 17546: STR GTSRS STORE RESULT ! 17547: * ! 17548: * THE ROUNDING OPERATION MAY HAVE PUSHED US UP PAST ! 17549: * 1.0 AGAIN, SO CHECK ONE MORE TIME. ! 17550: * ! 17551: SBR REAV1 SUBTRACT 1.0 TO COMPARE ! 17552: RLT GTS18 SKIP IF OK ! 17553: ADI INTV1 ELSE INCREMENT EXPONENT ! 17554: LDR GTSRS RELOAD VALUE ! 17555: DVR REAVT DIVIDE BY 10.0 TO RESCALE ! 17556: BRN GTS19 JUMP TO MERGE ! 17557: * ! 17558: * HERE IF ROUNDING DID NOT MUCK UP SCALING ! 17559: * ! 17560: GTS18 LDR GTSRS RELOAD ROUNDED VALUE ! 17561: EJC ! 17562: * ! 17563: * GTSTG (CONTINUED) ! 17564: * ! 17565: * NOW WE HAVE COMPLETED THE SCALING AS FOLLOWS ! 17566: * ! 17567: * (IA) SIGNED EXPONENT ! 17568: * (RA) SCALED REAL (ABSOLUTE VALUE) ! 17569: * ! 17570: * IF THE EXPONENT IS NEGATIVE OR GREATER THAN CFP$S, THEN ! 17571: * WE CONVERT THE NUMBER IN THE FORM. ! 17572: * ! 17573: * (NEG SIGN) 0 . (CPF$S DIGITS) E (EXP SIGN) (EXP DIGITS) ! 17574: * ! 17575: * IF THE EXPONENT IS POSITIVE AND LESS THAN OR EQUAL TO ! 17576: * CFP$S, THE NUMBER IS CONVERTED IN THE FORM. ! 17577: * ! 17578: * (NEG SIGN) (EXPONENT DIGITS) . (CFP$S-EXPONENT DIGITS) ! 17579: * ! 17580: * IN BOTH CASES, THE FORMATS OBTAINED FROM THE ABOVE ! 17581: * RULES ARE MODIFIED BY DELETING TRAILING ZEROS AFTER THE ! 17582: * DECIMAL POINT. THERE ARE NO LEADING ZEROS IN THE EXPONENT ! 17583: * AND THE EXPONENT SIGN IS ALWAYS PRESENT. ! 17584: * ! 17585: GTS19 MOV =CFP$S,XL SET NUM DEC DIGITS = CFP$S ! 17586: MOV =CH$MN,GTSES SET EXPONENT SIGN NEGATIVE ! 17587: ILT GTS21 ALL SET IF EXPONENT IS NEGATIVE ! 17588: MFI WA ELSE FETCH EXPONENT ! 17589: BLE WA,=CFP$S,GTS20 SKIP IF WE CAN USE SPECIAL FORMAT ! 17590: MTI WA ELSE RESTORE EXPONENT ! 17591: NGI SET NEGATIVE FOR CVD ! 17592: MOV =CH$PL,GTSES SET PLUS SIGN FOR EXPONENT SIGN ! 17593: BRN GTS21 JUMP TO GENERATE EXPONENT ! 17594: * ! 17595: * HERE IF WE CAN USE THE FORMAT WITHOUT AN EXPONENT ! 17596: * ! 17597: GTS20 SUB WA,XL COMPUTE DIGITS AFTER DECIMAL POINT ! 17598: LDI INTV0 RESET EXPONENT TO ZERO ! 17599: EJC ! 17600: * ! 17601: * GTSTG (CONTINUED) ! 17602: * ! 17603: * MERGE HERE AS FOLLOWS ! 17604: * ! 17605: * (IA) EXPONENT ABSOLUTE VALUE ! 17606: * GTSES CHARACTER FOR EXPONENT SIGN ! 17607: * (RA) POSITIVE FRACTION ! 17608: * (XL) NUMBER OF DIGITS AFTER DEC POINT ! 17609: * ! 17610: GTS21 MOV GTSWK,XR POINT TO WORK AREA ! 17611: MOV =NSTMX,WB SET CHARACTER CTR TO MAX LENGTH ! 17612: PSC XR,WB PREPARE TO STORE (RIGHT TO LEFT) ! 17613: IEQ GTS23 SKIP EXPONENT IF IT IS ZERO ! 17614: * ! 17615: * LOOP TO GENERATE DIGITS OF EXPONENT ! 17616: * ! 17617: GTS22 CVD CONVERT A DIGIT INTO WA ! 17618: SCH WA,-(XR) STORE IN WORK AREA ! 17619: DCV WB DECREMENT COUNTER ! 17620: INE GTS22 LOOP BACK IF MORE DIGITS TO GO ! 17621: * ! 17622: * HERE GENERATE EXPONENT SIGN AND E ! 17623: * ! 17624: MOV GTSES,WA LOAD EXPONENT SIGN ! 17625: SCH WA,-(XR) STORE IN WORK AREA ! 17626: MOV =CH$LE,WA GET CHARACTER LETTER E ! 17627: SCH WA,-(XR) STORE IN WORK AREA ! 17628: SUB =NUM02,WB DECREMENT COUNTER FOR SIGN AND E ! 17629: * ! 17630: * HERE TO GENERATE THE FRACTION ! 17631: * ! 17632: GTS23 MLR GTSSC CONVERT REAL TO INTEGER (10**CFP$S) ! 17633: RTI GET INTEGER (OVERFLOW IMPOSSIBLE) ! 17634: NGI NEGATE AS REQUIRED BY CVD ! 17635: * ! 17636: * LOOP TO SUPPRESS TRAILING ZEROS ! 17637: * ! 17638: GTS24 BZE XL,GTS27 JUMP IF NO DIGITS LEFT TO DO ! 17639: CVD ELSE CONVERT ONE DIGIT ! 17640: BNE WA,=CH$D0,GTS26 JUMP IF NOT A ZERO ! 17641: DCV XL DECREMENT COUNTER ! 17642: BRN GTS24 LOOP BACK FOR NEXT DIGIT ! 17643: EJC ! 17644: * ! 17645: * GTSTG (CONTINUED) ! 17646: * ! 17647: * LOOP TO GENERATE DIGITS AFTER DECIMAL POINT ! 17648: * ! 17649: GTS25 CVD CONVERT A DIGIT INTO WA ! 17650: * ! 17651: * MERGE HERE FIRST TIME ! 17652: * ! 17653: GTS26 SCH WA,-(XR) STORE DIGIT ! 17654: DCV WB DECREMENT COUNTER ! 17655: DCV XL DECREMENT COUNTER ! 17656: BNZ XL,GTS25 LOOP BACK IF MORE TO GO ! 17657: * ! 17658: * HERE GENERATE THE DECIMAL POINT ! 17659: * ! 17660: GTS27 MOV =CH$DT,WA LOAD DECIMAL POINT ! 17661: SCH WA,-(XR) STORE IN WORK AREA ! 17662: DCV WB DECREMENT COUNTER ! 17663: * ! 17664: * HERE GENERATE THE DIGITS BEFORE THE DECIMAL POINT ! 17665: * ! 17666: GTS28 CVD CONVERT A DIGIT INTO WA ! 17667: SCH WA,-(XR) STORE IN WORK AREA ! 17668: DCV WB DECREMENT COUNTER ! 17669: INE GTS28 LOOP BACK IF MORE TO GO ! 17670: CSC XR COMPLETE STORE CHARACTERS ! 17671: BRN GTS08 ELSE JUMP BACK TO EXIT ! 17672: * ! 17673: * EXIT POINT AFTER SUCCESSFUL CONVERSION ! 17674: * ! 17675: GTS29 MOV (XS)+,XL RESTORE XL ! 17676: ICA XS POP ARGUMENT ! 17677: MOV GTSVB,WB RESTORE WB ! 17678: MOV GTSVC,WC RESTORE WC ! 17679: * ! 17680: * MERGE HERE IF NO CONVERSION REQUIRED ! 17681: * ! 17682: GTS30 MOV SCLEN(XR),WA LOAD STRING LENGTH ! 17683: EXI RETURN TO CALLER ! 17684: * ! 17685: * HERE TO RETURN STRING FOR REAL ZERO ! 17686: * ! 17687: GTS31 MOV =SCRE0,XL POINT TO STRING ! 17688: MOV =NUM02,WA 2 CHARS ! 17689: ZER WB ZERO OFFSET ! 17690: JSR SBSTR COPY STRING ! 17691: BRN GTS29 RETURN ! 17692: EJC ! 17693: * ! 17694: * HERE TO CONVERT A BUFFER BLOCK ! 17695: * ! 17696: GTS32 MOV XR,XL COPY ARG PTR ! 17697: MOV BCLEN(XL),WA GET SIZE TO ALLOCATE ! 17698: BZE WA,GTS33 IF NULL THEN RETURN NULL ! 17699: JSR ALOCS ALLOCATE STRING FRAME ! 17700: MOV XR,WB SAVE STRING PTR ! 17701: MOV SCLEN(XR),WA GET LENGTH TO MOVE ! 17702: CTB WA,0 GET AS MULTIPLE OF WORD SIZE ! 17703: MOV BCBUF(XL),XL POINT TO BFBLK ! 17704: ADD *SCSI$,XR POINT TO START OF CHARACTER AREA ! 17705: ADD *BFSI$,XL POINT TO START OF BUFFER CHARS ! 17706: MVW COPY WORDS ! 17707: MOV WB,XR RESTORE SCBLK PTR ! 17708: BRN GTS29 EXIT WITH SCBLK ! 17709: * ! 17710: * HERE WHEN NULL BUFFER IS BEING CONVERTED ! 17711: * ! 17712: GTS33 MOV =NULLS,XR POINT TO NULL ! 17713: BRN GTS29 EXIT WITH NULL ! 17714: ENP END PROCEDURE GTSTG ! 17715: EJC ! 17716: * ! 17717: * GTVAR -- GET VARIABLE FOR I/O/TRACE ASSOCIATION ! 17718: * ! 17719: * GTVAR IS USED TO POINT TO AN ACTUAL VARIABLE LOCATION ! 17720: * FOR THE DETACH,INPUT,OUTPUT,TRACE,STOPTR SYSTEM FUNCTIONS ! 17721: * ! 17722: * (XR) ARGUMENT TO FUNCTION ! 17723: * JSR GTVAR CALL TO LOCATE VARIABLE POINTER ! 17724: * PPM LOC TRANSFER LOC IF NOT OK VARIABLE ! 17725: * (XL,WA) NAME BASE,OFFSET OF VARIABLE ! 17726: * (XR,RA) DESTROYED ! 17727: * (WB,WC) DESTROYED (CONVERT ERROR ONLY) ! 17728: * (XR) INPUT ARG (CONVERT ERROR ONLY) ! 17729: * ! 17730: GTVAR PRC E,1 ENTRY POINT ! 17731: BNE (XR),=B$NML,GTVR2 JUMP IF NOT A NAME ! 17732: MOV NMOFS(XR),WA ELSE LOAD NAME OFFSET ! 17733: MOV NMBAS(XR),XL LOAD NAME BASE ! 17734: BEQ (XL),=B$EVT,GTVR1 ERROR IF EXPRESSION VARIABLE ! 17735: BNE (XL),=B$KVT,GTVR3 ALL OK IF NOT KEYWORD VARIABLE ! 17736: * ! 17737: * HERE ON CONVERSION ERROR ! 17738: * ! 17739: GTVR1 EXI 1 TAKE CONVERT ERROR EXIT ! 17740: * ! 17741: * HERE IF NOT A NAME, TRY CONVERT TO NATURAL VARIABLE ! 17742: * ! 17743: GTVR2 MOV WC,GTVRC SAVE WC ! 17744: JSR GTNVR LOCATE VRBLK IF POSSIBLE ! 17745: PPM GTVR1 JUMP IF CONVERT ERROR ! 17746: MOV XR,XL ELSE COPY VRBLK NAME BASE ! 17747: MOV *VRVAL,WA AND SET OFFSET ! 17748: MOV GTVRC,WC RESTORE WC ! 17749: * ! 17750: * HERE FOR NAME OBTAINED ! 17751: * ! 17752: GTVR3 BHI XL,STATE,GTVR4 ALL OK IF NOT NATURAL VARIABLE ! 17753: BEQ VRSTO(XL),=B$VRE,GTVR1 ERROR IF PROTECTED VARIABLE ! 17754: * ! 17755: * COMMON EXIT POINT ! 17756: * ! 17757: GTVR4 EXI RETURN TO CALLER ! 17758: ENP END PROCEDURE GTVAR ! 17759: EJC ! 17760: * ! 17761: * HASHS -- COMPUTE HASH INDEX FOR STRING ! 17762: * ! 17763: * HASHS IS USED TO CONVERT A STRING TO A UNIQUE INTEGER ! 17764: * VALUE. THE RESULTING HASH VALUE IS A POSITIVE INTEGER ! 17765: * IN THE RANGE 0 TO CFP$M ! 17766: * ! 17767: * (XR) STRING TO BE HASHED ! 17768: * JSR HASHS CALL TO HASH STRING ! 17769: * (IA) HASH VALUE ! 17770: * (XR,WB,WC) DESTROYED ! 17771: * ! 17772: * THE HASH FUNCTION USED IS AS FOLLOWS. ! 17773: * ! 17774: * START WITH THE LENGTH OF THE STRING (SGD07) ! 17775: * ! 17776: * TAKE THE FIRST E$HNW WORDS OF THE CHARACTERS FROM ! 17777: * THE STRING OR ALL THE WORDS IF FEWER THAN E$HNW. ! 17778: * ! 17779: * COMPUTE THE EXCLUSIVE OR OF ALL THESE WORDS TREATING ! 17780: * THEM AS ONE WORD BIT STRING VALUES. ! 17781: * ! 17782: * MOVE THE RESULT AS AN INTEGER WITH THE MTI INSTRUCTION. ! 17783: * ! 17784: HASHS PRC E,0 ENTRY POINT ! 17785: MOV SCLEN(XR),WC LOAD STRING LENGTH IN CHARACTERS ! 17786: MOV WC,WB INITIALIZE WITH LENGTH ! 17787: BZE WC,HSHS3 JUMP IF NULL STRING ! 17788: CTW WC,0 ELSE GET NUMBER OF WORDS OF CHARS ! 17789: ADD *SCHAR,XR POINT TO CHARACTERS OF STRING ! 17790: BLO WC,=E$HNW,HSHS1 USE WHOLE STRING IF SHORT ! 17791: MOV =E$HNW,WC ELSE SET TO INVOLVE FIRST E$HNW WDS ! 17792: * ! 17793: * HERE WITH COUNT OF WORDS TO CHECK IN WC ! 17794: * ! 17795: HSHS1 LCT WC,WC SET COUNTER TO CONTROL LOOP ! 17796: * ! 17797: * LOOP TO COMPUTE EXCLUSIVE OR ! 17798: * ! 17799: HSHS2 XOB (XR)+,WB EXCLUSIVE OR NEXT WORD OF CHARS ! 17800: BCT WC,HSHS2 LOOP TILL ALL PROCESSED ! 17801: * ! 17802: * MERGE HERE WITH EXCLUSIVE OR IN WB ! 17803: * ! 17804: HSHS3 ZGB WB ZEROISE UNDEFINED BITS ! 17805: ANB BITSM,WB ENSURE IN RANGE 0 TO CFP$M ! 17806: MTI WB MOVE RESULT AS INTEGER ! 17807: ZER XR CLEAR GARBAGE VALUE IN XR ! 17808: EXI RETURN TO HASHS CALLER ! 17809: ENP END PROCEDURE HASHS ! 17810: EJC ! 17811: * ! 17812: * ICBLD -- BUILD INTEGER BLOCK ! 17813: * ! 17814: * (IA) INTEGER VALUE FOR ICBLK ! 17815: * JSR ICBLD CALL TO BUILD INTEGER BLOCK ! 17816: * (XR) POINTER TO RESULT ICBLK ! 17817: * (WA) DESTROYED ! 17818: * ! 17819: ICBLD PRC E,0 ENTRY POINT ! 17820: MFI XR,ICBL1 COPY SMALL INTEGERS ! 17821: BLE XR,=NUM02,ICBL3 JUMP IF 0,1 OR 2 ! 17822: * ! 17823: * CONSTRUCT ICBLK ! 17824: * ! 17825: ICBL1 MOV DNAMP,XR LOAD POINTER TO NEXT AVAILABLE LOC ! 17826: ADD *ICSI$,XR POINT PAST NEW ICBLK ! 17827: BLO XR,DNAME,ICBL2 JUMP IF THERE IS ROOM ! 17828: MOV *ICSI$,WA ELSE LOAD LENGTH OF ICBLK ! 17829: JSR ALLOC USE STANDARD ALLOCATOR TO GET BLOCK ! 17830: ADD WA,XR POINT PAST BLOCK TO MERGE ! 17831: * ! 17832: * MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED ! 17833: * ! 17834: ICBL2 MOV XR,DNAMP SET NEW POINTER ! 17835: SUB *ICSI$,XR POINT BACK TO START OF BLOCK ! 17836: MOV =B$ICL,(XR) STORE TYPE WORD ! 17837: STI ICVAL(XR) STORE INTEGER VALUE IN ICBLK ! 17838: EXI RETURN TO ICBLD CALLER ! 17839: * ! 17840: * OPTIMISE BY NOT BUILDING ICBLKS FOR SMALL INTEGERS ! 17841: * ! 17842: ICBL3 WTB XR CONVERT INTEGER TO OFFSET ! 17843: MOV INTAB(XR),XR POINT TO PRE-BUILT ICBLK ! 17844: EXI RETURN ! 17845: ENP END PROCEDURE ICBLD ! 17846: EJC ! 17847: * ! 17848: * IDENT -- COMPARE TWO VALUES ! 17849: * ! 17850: * IDENT COMPARES TWO VALUES IN THE SENSE OF THE IDENT ! 17851: * DIFFER FUNCTIONS AVAILABLE AT THE SNOBOL LEVEL. ! 17852: * ! 17853: * (XR) FIRST ARGUMENT ! 17854: * (XL) SECOND ARGUMENT ! 17855: * JSR IDENT CALL TO COMPARE ARGUMENTS ! 17856: * PPM LOC TRANSFER LOC IF IDENT ! 17857: * (NORMAL RETURN IF DIFFER) ! 17858: * (XR,XL,WC,RA) DESTROYED ! 17859: * ! 17860: IDENT PRC E,1 ENTRY POINT ! 17861: BEQ XR,XL,IDEN7 JUMP IF SAME POINTER (IDENT) ! 17862: MOV (XR),WC ELSE LOAD ARG 1 TYPE WORD ! 17863: BNE WC,(XL),IDEN1 DIFFER IF ARG 2 TYPE WORD DIFFER ! 17864: BEQ WC,=B$SCL,IDEN2 JUMP IF STRINGS ! 17865: BEQ WC,=B$ICL,IDEN4 JUMP IF INTEGERS ! 17866: BEQ WC,=B$RCL,IDEN5 JUMP IF REALS ! 17867: BEQ WC,=B$NML,IDEN6 JUMP IF NAMES ! 17868: * ! 17869: * FOR ALL OTHER DATATYPES, MUST BE DIFFER IF XR NE XL ! 17870: * ! 17871: * MERGE HERE FOR DIFFER ! 17872: * ! 17873: IDEN1 EXI TAKE DIFFER EXIT ! 17874: * ! 17875: * HERE FOR STRINGS, IDENT ONLY IF LENGTHS AND CHARS SAME ! 17876: * ! 17877: IDEN2 MOV SCLEN(XR),WC LOAD ARG 1 LENGTH ! 17878: BNE WC,SCLEN(XL),IDEN1 DIFFER IF LENGTHS DIFFER ! 17879: CTW WC,0 GET NUMBER OF WORDS IN STRINGS ! 17880: ADD *SCHAR,XR POINT TO CHARS OF ARG 1 ! 17881: ADD *SCHAR,XL POINT TO CHARS OF ARG 2 ! 17882: LCT WC,WC SET LOOP COUNTER ! 17883: * ! 17884: * LOOP TO COMPARE CHARACTERS. NOTE THAT WA CANNOT BE ZERO ! 17885: * SINCE ALL NULL STRINGS POINT TO NULLS AND GIVE XL=XR. ! 17886: * ! 17887: IDEN3 CNE (XR),(XL),IDEN8 DIFFER IF CHARS DO NOT MATCH ! 17888: ICA XR ELSE BUMP ARG ONE POINTER ! 17889: ICA XL BUMP ARG TWO POINTER ! 17890: BCT WC,IDEN3 LOOP BACK TILL ALL CHECKED ! 17891: EJC ! 17892: * ! 17893: * IDENT (CONTINUED) ! 17894: * ! 17895: * HERE TO EXIT FOR CASE OF TWO IDENT STRINGS ! 17896: * ! 17897: ZER XL CLEAR GARBAGE VALUE IN XL ! 17898: ZER XR CLEAR GARBAGE VALUE IN XR ! 17899: EXI 1 TAKE IDENT EXIT ! 17900: * ! 17901: * HERE FOR INTEGERS, IDENT IF SAME VALUES ! 17902: * ! 17903: IDEN4 LDI ICVAL(XR) LOAD ARG 1 ! 17904: SBI ICVAL(XL) SUBTRACT ARG 2 TO COMPARE ! 17905: IOV IDEN1 DIFFER IF OVERFLOW ! 17906: INE IDEN1 DIFFER IF RESULT IS NOT ZERO ! 17907: EXI 1 TAKE IDENT EXIT ! 17908: * ! 17909: * HERE FOR REALS, IDENT IF SAME VALUES ! 17910: * ! 17911: IDEN5 LDR RCVAL(XR) LOAD ARG 1 ! 17912: SBR RCVAL(XL) SUBTRACT ARG 2 TO COMPARE ! 17913: ROV IDEN1 DIFFER IF OVERFLOW ! 17914: RNE IDEN1 DIFFER IF RESULT IS NOT ZERO ! 17915: EXI 1 TAKE IDENT EXIT ! 17916: * ! 17917: * HERE FOR NAMES, IDENT IF BASES AND OFFSETS SAME ! 17918: * ! 17919: IDEN6 BNE NMOFS(XR),NMOFS(XL),IDEN1 DIFFER IF DIFFERENT OFFSET ! 17920: BNE NMBAS(XR),NMBAS(XL),IDEN1 DIFFER IF DIFFERENT BASE ! 17921: * ! 17922: * MERGE HERE TO SIGNAL IDENT FOR IDENTICAL POINTERS ! 17923: * ! 17924: IDEN7 EXI 1 TAKE IDENT EXIT ! 17925: * ! 17926: * HERE FOR DIFFER STRINGS ! 17927: * ! 17928: IDEN8 ZER XR CLEAR GARBAGE PTR IN XR ! 17929: ZER XL CLEAR GARBAGE PTR IN XL ! 17930: EXI RETURN TO CALLER (DIFFER) ! 17931: ENP END PROCEDURE IDENT ! 17932: EJC ! 17933: * ! 17934: * INOUT - USED TO INITIALISE INPUT AND OUTPUT VARIABLES ! 17935: * ! 17936: * (XL) POINTER TO VBL NAME STRING ! 17937: * (WB) TRBLK TYPE ! 17938: * JSR INOUT CALL TO PERFORM INITIALISATION ! 17939: * (XL) VRBLK PTR ! 17940: * (XR) TRBLK PTR ! 17941: * (WA,WC) DESTROYED ! 17942: * ! 17943: * NOTE THAT TRTER (= TRTRF) FIELD OF STANDARD I/O VARIABLES ! 17944: * POINTS TO CORRESPONDING SVBLK NOT TO A TRBLK AS IS THE ! 17945: * CASE FOR ORDINARY VARIABLES. ! 17946: * ! 17947: INOUT PRC E,0 ENTRY POINT ! 17948: MOV WB,-(XS) STACK TRBLK TYPE ! 17949: MOV SCLEN(XL),WA GET NAME LENGTH ! 17950: ZER WB POINT TO START OF NAME ! 17951: JSR SBSTR BUILD A PROPER SCBLK ! 17952: JSR GTNVR BUILD VRBLK ! 17953: PPM NO ERROR RETURN ! 17954: MOV XR,WC SAVE VRBLK POINTER ! 17955: MOV (XS)+,WB GET TRTER FIELD ! 17956: ZER XL ZERO TRFPT ! 17957: JSR TRBLD BUILD TRBLK ! 17958: MOV WC,XL RECALL VRBLK POINTER ! 17959: MOV VRSVP(XL),TRTER(XR) STORE SVBLK POINTER ! 17960: MOV XR,VRVAL(XL) STORE TRBLK PTR IN VRBLK ! 17961: MOV =B$VRA,VRGET(XL) SET TRAPPED ACCESS ! 17962: MOV =B$VRV,VRSTO(XL) SET TRAPPED STORE ! 17963: EXI RETURN TO CALLER ! 17964: ENP END PROCEDURE INOUT ! 17965: EJC ! 17966: * ! 17967: * INSBF -- INSERT STRING IN BUFFER ! 17968: * ! 17969: * THIS ROUTINE WILL REPLACE A SECTION OF A BUFFER WITH THE ! 17970: * CONTENTS OF A GIVEN STRING. IF THE LENGTH OF THE ! 17971: * SECTION TO BE REPLACED IS DIFFERENT THAN THE LENGTH OF ! 17972: * THE GIVEN STRING, AND THE REPLACEMENT IS NOT AN APPEND, ! 17973: * THEN THE UPPER SECTION OF THE BUFFER IS SHIFTED UP OR ! 17974: * DOWN TO CREATE THE PROPER SPACE FOR THE INSERT. ! 17975: * ! 17976: * (XR) POINTER TO BFBLK ! 17977: * (XL) OBJECT WHICH IS STRING CONVERTABLE ! 17978: * (WA) OFFSET OF START OF INSERT IN (XR) ! 17979: * (WB) LENGTH OF SECTION IN (XR) REPLACED ! 17980: * JSR INSBF CALL TO INSERT CHARACTERS IN BUFFER ! 17981: * PPM LOC THREAD IF (XR) NOT CONVERTABLE ! 17982: * PPM LOC THREAD IF INSERT NOT POSSIBLE ! 17983: * ! 17984: * THE SECOND ALTERNATE EXIT IS TAKEN IF THE INSERT WOULD ! 17985: * OVERFLOW THE BUFFER, OR IF THE INSERT IS OUT PAST THE ! 17986: * DEFINED END OF THE BUFFER AS GIVEN. ! 17987: * ! 17988: INSBF PRC E,2 ENTRY POINT ! 17989: MOV WA,INSSA SAVE ENTRY WA ! 17990: MOV WB,INSSB SAVE ENTRY WB ! 17991: MOV WC,INSSC SAVE ENTRY WC ! 17992: ADD WB,WA ADD TO GET OFFSET PAST REPLACE PART ! 17993: MOV WA,INSAB SAVE WA+WB ! 17994: MOV BCLEN(XR),WC GET CURRENT DEFINED LENGTH ! 17995: BGT INSSA,WC,INS07 FAIL IF START OFFSET TOO BIG ! 17996: BGT WA,WC,INS07 FAIL IF FINAL OFFSET TOO BIG ! 17997: MOV XL,-(XS) SAVE ENTRY XL ! 17998: MOV XR,-(XS) SAVE BCBLK PTR ! 17999: MOV XL,-(XS) STACK AGAIN FOR GTSTG ! 18000: JSR GTSTG CALL TO CONVERT TO STRING ! 18001: PPM INS05 TAKE STRING CONVERT ERR EXIT ! 18002: MOV XR,XL SAVE STRING PTR ! 18003: MOV (XS),XR RESTORE BCBLK PTR ! 18004: ADD WC,WA ADD BUFFER LEN TO STRING LEN ! 18005: SUB INSSB,WA BIAS OUT COMPONENT BEING REPLACED ! 18006: MOV BCBUF(XR),XR POINT TO BFBLK ! 18007: BGT WA,BFALC(XR),INS06 FAIL IF RESULT EXCEEDS ALLOCATION ! 18008: MOV (XS),XR RESTORE BCBLK PTR ! 18009: MOV WC,WA GET BUFFER LENGTH ! 18010: SUB INSAB,WA SUBTRACT TO GET SHIFT LENGTH ! 18011: ADD SCLEN(XL),WC ADD LENGTH OF NEW ! 18012: SUB INSSB,WC SUBTRACT OLD TO GET TOTAL NEW LEN ! 18013: MOV BCLEN(XR),WB GET OLD BCLEN ! 18014: MOV WC,BCLEN(XR) STUFF NEW LENGTH ! 18015: BZE WA,INS04 SKIP SHIFT IF NOTHING TO DO ! 18016: BEQ INSSB,SCLEN(XL),INS04 SKIP SHIFT IF LENGTHS MATCH ! 18017: MOV BCBUF(XR),XR POINT TO BFBLK ! 18018: MOV XL,-(XS) SAVE SCBLK PTR ! 18019: BLO INSSB,SCLEN(XL),INS01 BRN IF SHFT IS FOR MORE ROOM ! 18020: EJC ! 18021: * ! 18022: * INSBF (CONTINUED) ! 18023: * ! 18024: * WE ARE SHIFTING THE UPPER SEGMENT DOWN TO COMPACT ! 18025: * THE BUFFER. (THE STRING LENGTH IS SMALLER THAN THE ! 18026: * SEGMENT BEING REPLACED.) REGISTERS ARE SET AS: ! 18027: * ! 18028: * (WA) MOVE (SHIFT DOWN) LENGTH ! 18029: * (WB) OLD BCLEN ! 18030: * (WC) NEW BCLEN ! 18031: * (XR) BFBLK PTR ! 18032: * (XL),(XS) SCBLK PTR ! 18033: * ! 18034: MOV INSSA,WB GET OFFSET TO INSERT ! 18035: ADD SCLEN(XL),WB ADD INSERT LENGTH TO GET DEST OFF ! 18036: MOV XR,XL MAKE COPY ! 18037: PLC XL,INSAB PREPARE SOURCE FOR MOVE ! 18038: PSC XR,WB PREPARE DESTINATION REG FOR MOVE ! 18039: MVC MOVE EM OUT ! 18040: BRN INS02 BRANCH TO PAD ! 18041: * ! 18042: * WE ARE SHIFTING THE UPPER SEGMENT UP TO EXPAND ! 18043: * THE BUFFER. (THE STRING LENGTH IS LARGER THAN THE ! 18044: * SEGMENT BEING REPLACED.) ! 18045: * ! 18046: INS01 MOV XR,XL COPY BFBLK PTR ! 18047: PLC XL,WB SET SOURCE REG FOR MOVE BACKWARDS ! 18048: PSC XR,WC SET DESTINATION PTR FOR MOVE ! 18049: MCB MOVE BACKWARDS (POSSIBLE OVERLAP) ! 18050: * ! 18051: * MERGE HERE AFTER MOVE TO ADJUST PADDING AT NEW BUFFER END ! 18052: * ! 18053: INS02 MOV (XS)+,XL RESTORE SCBLK PTR ! 18054: MOV WC,WA COPY NEW BUFFER END ! 18055: CTB WA,0 ROUND OUT ! 18056: SUB WC,WA SUBTRACT TO GET REMAINDER ! 18057: BZE WA,INS04 NO PAD IF ALREADY EVEN BOUNDARY ! 18058: MOV (XS),XR GET BCBLK PTR ! 18059: MOV BCBUF(XR),XR GET BFBLK PTR ! 18060: PSC XR,WC PREPARE TO PAD ! 18061: ZER WB CLEAR WB ! 18062: LCT WA,WA LOAD LOOP COUNT ! 18063: * ! 18064: * LOOP HERE TO STUFF PAD CHARACTERS ! 18065: * ! 18066: INS03 SCH WB,(XR)+ STUFF ZERO PAD ! 18067: BCT WA,INS03 BRANCH FOR MORE ! 18068: EJC ! 18069: * ! 18070: * INSBF (CONTINUED) ! 18071: * ! 18072: * MERGE HERE WHEN PADDING OK. NOW COPY IN THE INSERT ! 18073: * STRING TO THE HOLE. ! 18074: * ! 18075: INS04 MOV (XS),XR GET BCBLK PTR ! 18076: MOV BCBUF(XR),XR GET BFBLK PTR ! 18077: MOV SCLEN(XL),WA GET MOVE LENGTH ! 18078: PLC XL PREPARE TO COPY FROM FIRST CHAR ! 18079: PSC XR,INSSA PREPARE TO STORE IN HOLE ! 18080: MVC COPY THE CHARACTERS ! 18081: MOV (XS)+,XR RESTORE ENTRY XR ! 18082: MOV (XS)+,XL RESTORE ENTRY XL ! 18083: MOV INSSA,WA RESTORE ENTRY WA ! 18084: MOV INSSB,WB RESTORE ENTRY WB ! 18085: MOV INSSC,WC RESTORE ENTRY WC ! 18086: EXI RETURN TO CALLER ! 18087: * ! 18088: * HERE TO TAKE STRING CONVERT ERROR EXIT ! 18089: * ! 18090: INS05 MOV (XS)+,XR RESTORE ENTRY XR ! 18091: MOV (XS)+,XL RESTORE ENTRY XL ! 18092: MOV INSSA,WA RESTORE ENTRY WA ! 18093: MOV INSSB,WB RESTORE ENTRY WB ! 18094: MOV INSSC,WC RESTORE ENTRY WC ! 18095: EXI 1 ALTERNATE EXIT ! 18096: * ! 18097: * HERE FOR INVALID OFFSET OR LENGTH ! 18098: * ! 18099: INS06 MOV (XS)+,XR RESTORE ENTRY XR ! 18100: MOV (XS)+,XL RESTORE ENTRY XL ! 18101: * ! 18102: * MERGE FOR LENGTH FAILURE EXIT WITH STACK SET ! 18103: * ! 18104: INS07 MOV INSSA,WA RESTORE ENTRY WA ! 18105: MOV INSSB,WB RESTORE ENTRY WB ! 18106: MOV INSSC,WC RESTORE ENTRY WC ! 18107: EXI 2 ALTERNATE EXIT ! 18108: ENP END PROCEDURE INSBF ! 18109: EJC ! 18110: * ! 18111: * IOFCB -- GET INPUT/OUTPUT FCBLK POINTER ! 18112: * ! 18113: * USED BY ENDFILE, EJECT AND REWIND TO FIND THE FCBLK ! 18114: * (IF ANY) CORRESPONDING TO THEIR ARGUMENT. ! 18115: * ! 18116: * -(XS) ARGUMENT ! 18117: * JSR IOFCB CALL TO FIND FCBLK ! 18118: * PPM LOC ARG IS AN UNSUITABLE NAME ! 18119: * PPM LOC ARG IS NULL STRING ! 18120: * (XS) POPPED ! 18121: * (XL) PTR TO FILEARG1 VRBLK ! 18122: * (XR) ARGUMENT ! 18123: * (WA) FCBLK PTR OR 0 ! 18124: * (WB) DESTROYED ! 18125: * ! 18126: IOFCB PRC N,2 ENTRY POINT ! 18127: JSR GTSTG GET ARG AS STRING ! 18128: PPM IOFC2 FAIL ! 18129: MOV XR,XL COPY STRING PTR ! 18130: JSR GTNVR GET AS NATURAL VARIABLE ! 18131: PPM IOFC3 FAIL IF NULL ! 18132: MOV XL,WB COPY STRING POINTER AGAIN ! 18133: MOV XR,XL COPY VRBLK PTR FOR RETURN ! 18134: ZER WA IN CASE NO TRBLK FOUND ! 18135: * ! 18136: * LOOP TO FIND FILE ARG1 TRBLK ! 18137: * ! 18138: IOFC1 MOV VRVAL(XR),XR GET POSSIBLE TRBLK PTR ! 18139: BNE (XR),=B$TRT,IOFC2 FAIL IF END OF CHAIN ! 18140: BNE TRTYP(XR),=TRTFC,IOFC1 LOOP IF NOT FILE ARG TRBLK ! 18141: MOV TRFPT(XR),WA GET FCBLK PTR ! 18142: MOV WB,XR COPY ARG ! 18143: EXI RETURN ! 18144: * ! 18145: * FAIL RETURN ! 18146: * ! 18147: IOFC2 EXI 1 FAIL ! 18148: * ! 18149: * NULL ARG ! 18150: * ! 18151: IOFC3 EXI 2 NULL ARG RETURN ! 18152: ENP END PROCEDURE IOFCB ! 18153: EJC ! 18154: * ! 18155: * IOPPF -- PROCESS FILEARG2 FOR IOPUT ! 18156: * ! 18157: * (R$XSC) FILEARG2 PTR ! 18158: * JSR IOPPF CALL TO PROCESS FILEARG2 ! 18159: * (XL) FILEARG1 PTR ! 18160: * (XR) FILE ARG2 PTR ! 18161: * -(XS)..-(XS) FIELDS EXTRACTED FROM FILEARG2 ! 18162: * (WC) NO. OF FIELDS EXTRACTED ! 18163: * (WB) INPUT/OUTPUT FLAG ! 18164: * (WA) FCBLK PTR OR 0 ! 18165: * ! 18166: IOPPF PRC N,0 ENTRY POINT ! 18167: ZER WB TO COUNT FIELDS EXTRACTED ! 18168: * ! 18169: * LOOP TO EXTRACT FIELDS ! 18170: * ! 18171: IOPP1 MOV =IODEL,XL GET DELIMITER ! 18172: MOV XL,WC COPY IT ! 18173: JSR XSCAN GET NEXT FIELD ! 18174: MOV XR,-(XS) STACK IT ! 18175: ICV WB INCREMENT COUNT ! 18176: BNZ WA,IOPP1 LOOP ! 18177: MOV WB,WC COUNT OF FIELDS ! 18178: MOV IOPTT,WB I/O MARKER ! 18179: MOV R$IOF,WA FCBLK PTR OR 0 ! 18180: MOV R$IO2,XR FILE ARG2 PTR ! 18181: MOV R$IO1,XL FILEARG1 ! 18182: EXI RETURN ! 18183: ENP END PROCEDURE IOPPF ! 18184: EJC ! 18185: * ! 18186: * IOPUT -- ROUTINE USED BY INPUT AND OUTPUT ! 18187: * ! 18188: * IOPUT SETS UP INPUT/OUTPUT ASSOCIATIONS. IT BUILDS ! 18189: * SUCH TRACE AND FILE CONTROL BLOCKS AS ARE NECESSARY AND ! 18190: * CALLS SYSFC,SYSIO TO PERFORM CHECKS ON THE ! 18191: * ARGUMENTS AND TO OPEN THE FILES. ! 18192: * ! 18193: * +-----------+ +---------------+ +-----------+ ! 18194: * +-.I I I I------.I =B$XRT I ! 18195: * I +-----------+ +---------------+ +-----------+ ! 18196: * I / / (R$FCB) I *4 I ! 18197: * I / / +-----------+ ! 18198: * I +-----------+ +---------------+ I I- ! 18199: * I I NAME +--.I =B$TRT I +-----------+ ! 18200: * I / / +---------------+ I I ! 18201: * I (FIRST ARG) I =TRTIN/=TRTOU I +-----------+ ! 18202: * I +---------------+ I ! 18203: * I I VALUE I I ! 18204: * I +---------------+ I ! 18205: * I I(TRTRF) 0 OR I--+ I ! 18206: * I +---------------+ I I ! 18207: * I I(TRFPT) 0 OR I----+ I ! 18208: * I +---------------+ I I I ! 18209: * I (I/O TRBLK) I I I ! 18210: * I +-----------+ I I I ! 18211: * I I I I I I ! 18212: * I +-----------+ I I I ! 18213: * I I I I I I ! 18214: * I +-----------+ +---------------+ I I I ! 18215: * I I +--.I =B$TRT I.-+ I I ! 18216: * I +-----------+ +---------------+ I I ! 18217: * I / / I =TRTFC I I I ! 18218: * I / / +---------------+ I I ! 18219: * I (FILEARG1 I VALUE I I I ! 18220: * I VRBLK) +---------------+ I I ! 18221: * I I(TRTRF) 0 OR I--+ I . ! 18222: * I +---------------+ I . +-----------+ ! 18223: * I I(TRFPT) 0 OR I------./ FCBLK / ! 18224: * I +---------------+ I +-----------+ ! 18225: * I (TRTRF) I ! 18226: * I I ! 18227: * I I ! 18228: * I +---------------+ I ! 18229: * I I =B$XRT I.-+ ! 18230: * I +---------------+ ! 18231: * I I *5 I ! 18232: * I +---------------+ ! 18233: * +------------------I I ! 18234: * +---------------+ +-----------+ ! 18235: * I(TRTRF) O OR I------.I =B$XRT I ! 18236: * +---------------+ +-----------+ ! 18237: * I NAME OFFSET I I ETC I ! 18238: * +---------------+ ! 18239: * (IOCHN - CHAIN OF NAME POINTERS) ! 18240: EJC ! 18241: * ! 18242: * IOPUT (CONTINUED) ! 18243: * ! 18244: * NO ADDITIONAL TRAP BLOCKS ARE USED FOR STANDARD INPUT/OUT ! 18245: * FILES. OTHERWISE AN I/O TRAP BLOCK IS ATTACHED TO SECOND ! 18246: * ARG (FILEARG1) VRBLK. SEE DIAGRAM ABOVE FOR DETAILS OF ! 18247: * THE STRUCTURE BUILT. ! 18248: * ! 18249: * -(XS) 1ST ARG (VBL TO BE ASSOCIATED) ! 18250: * -(XS) 2ND ARG (FILE ARG1) ! 18251: * -(XS) 3RD ARG (FILE ARG2) ! 18252: * (WB) 0 FOR INPUT, 3 FOR OUTPUT ASSOC. ! 18253: * JSR IOPUT CALL FOR INPUT/OUTPUT ASSOCIATION ! 18254: * PPM LOC 3RD ARG NOT A STRING ! 18255: * PPM LOC 2ND ARG NOT A SUITABLE NAME ! 18256: * PPM LOC 1ST ARG NOT A SUITABLE NAME ! 18257: * PPM LOC INAPPROPRIATE FILE SPEC FOR I/O ! 18258: * PPM LOC I/O FILE DOES NOT EXIST ! 18259: * PPM LOC I/O FILE CANNOT BE READ/WRITTEN ! 18260: * (XS) POPPED ! 18261: * (XL,XR,WA,WB,WC) DESTROYED ! 18262: * ! 18263: IOPUT PRC N,6 ENTRY POINT ! 18264: ZER R$IOT IN CASE NO TRTRF BLOCK USED ! 18265: ZER R$IOF IN CASE NO FCBLK ALOCATED ! 18266: MOV WB,IOPTT STORE I/O TRACE TYPE ! 18267: JSR XSCNI PREPARE TO SCAN FILEARG2 ! 18268: PPM IOP13 FAIL ! 18269: PPM IOPA0 NULL FILE ARG2 ! 18270: * ! 18271: IOPA0 MOV XR,R$IO2 KEEP FILE ARG2 ! 18272: MOV WA,XL COPY LENGTH ! 18273: JSR GTSTG CONVERT FILEARG1 TO STRING ! 18274: PPM IOP14 FAIL ! 18275: MOV XR,R$IO1 KEEP FILEARG1 PTR ! 18276: JSR GTNVR CONVERT TO NATURAL VARIABLE ! 18277: PPM IOP00 JUMP IF NULL ! 18278: BRN IOP04 JUMP TO PROCESS NON-NULL ARGS ! 18279: * ! 18280: * NULL FILEARG1 ! 18281: * ! 18282: IOP00 BZE XL,IOP01 SKIP IF BOTH ARGS NULL ! 18283: JSR IOPPF PROCESS FILEARG2 ! 18284: JSR SYSFC CALL FOR FILEARG2 CHECK ! 18285: PPM IOP16 FAIL ! 18286: BRN IOP11 COMPLETE FILE ASSOCIATION ! 18287: EJC ! 18288: * ! 18289: * IOPUT (CONTINUED) ! 18290: * ! 18291: * HERE WITH 0 OR FCBLK PTR IN (XL) ! 18292: * ! 18293: IOP01 MOV IOPTT,WB GET TRACE TYPE ! 18294: MOV R$IOT,XR GET 0 OR TRTRF PTR ! 18295: JSR TRBLD BUILD TRBLK ! 18296: MOV XR,WC COPY TRBLK POINTER ! 18297: MOV (XS)+,XR GET VARIABLE FROM STACK ! 18298: JSR GTVAR POINT TO VARIABLE ! 18299: PPM IOP15 FAIL ! 18300: MOV XL,R$ION SAVE NAME POINTER ! 18301: MOV XL,XR COPY NAME POINTER ! 18302: ADD WA,XR POINT TO VARIABLE ! 18303: SUB *VRVAL,XR SUBTRACT OFFSET,MERGE INTO LOOP ! 18304: * ! 18305: * LOOP TO END OF TRBLK CHAIN IF ANY ! 18306: * ! 18307: IOP02 MOV XR,XL COPY BLK PTR ! 18308: MOV VRVAL(XR),XR LOAD PTR TO NEXT TRBLK ! 18309: BNE (XR),=B$TRT,IOP03 JUMP IF NOT TRAPPED ! 18310: BNE TRTYP(XR),IOPTT,IOP02 LOOP IF NOT SAME ASSOCN ! 18311: MOV TRNXT(XR),XR GET VALUE AND DELETE OLD TRBLK ! 18312: * ! 18313: * IOPUT (CONTINUED) ! 18314: * ! 18315: * STORE NEW ASSOCIATION ! 18316: * ! 18317: IOP03 MOV WC,VRVAL(XL) LINK TO THIS TRBLK ! 18318: MOV WC,XL COPY POINTER ! 18319: MOV XR,TRNXT(XL) STORE VALUE IN TRBLK ! 18320: MOV R$ION,XR RESTORE POSSIBLE VRBLK POINTER ! 18321: MOV WA,WB KEEP OFFSET TO NAME ! 18322: JSR SETVR IF VRBLK, SET VRGET,VRSTO ! 18323: MOV R$IOT,XR GET 0 OR TRTRF PTR ! 18324: BNZ XR,IOP19 JUMP IF TRTRF BLOCK EXISTS ! 18325: EXI RETURN TO CALLER ! 18326: * ! 18327: * NON STANDARD FILE ! 18328: * SEE IF AN FCBLK HAS ALREADY BEEN ALLOCATED. ! 18329: * ! 18330: IOP04 ZER WA IN CASE NO FCBLK FOUND ! 18331: EJC ! 18332: * ! 18333: * IOPUT (CONTINUED) ! 18334: * ! 18335: * SEARCH POSSIBLE TRBLK CHAIN TO PICK UP THE FCBLK ! 18336: * ! 18337: IOP05 MOV XR,WB REMEMBER BLK PTR ! 18338: MOV VRVAL(XR),XR CHAIN ALONG ! 18339: BNE (XR),=B$TRT,IOP06 JUMP IF END OF TRBLK CHAIN ! 18340: BNE TRTYP(XR),=TRTFC,IOP05 LOOP IF MORE TO GO ! 18341: MOV XR,R$IOT POINT TO FILE ARG1 TRBLK ! 18342: MOV TRFPT(XR),WA GET FCBLK PTR FROM TRBLK ! 18343: * ! 18344: * WA = 0 OR FCBLK PTR ! 18345: * WB = PTR TO PRECEDING BLK TO WHICH ANY TRTRF BLOCK ! 18346: * FOR FILE ARG1 MUST BE CHAINED. ! 18347: * ! 18348: IOP06 MOV WA,R$IOF KEEP POSSIBLE FCBLK PTR ! 18349: MOV WB,R$IOP KEEP PRECEDING BLK PTR ! 18350: JSR IOPPF PROCESS FILEARG2 ! 18351: JSR SYSFC SEE IF FCBLK REQUIRED ! 18352: PPM IOP16 FAIL ! 18353: BZE WA,IOP12 SKIP IF NO NEW FCBLK WANTED ! 18354: BLT WC,=NUM02,IOP6A JUMP IF FCBLK IN DYNAMIC ! 18355: JSR ALOST GET IT IN STATIC ! 18356: BRN IOP6B SKIP ! 18357: * ! 18358: * OBTAIN FCBLK IN DYNAMIC ! 18359: * ! 18360: IOP6A JSR ALLOC GET SPACE FOR FCBLK ! 18361: * ! 18362: * MERGE ! 18363: * ! 18364: IOP6B MOV XR,XL POINT TO FCBLK ! 18365: MOV WA,WB COPY ITS LENGTH ! 18366: BTW WB GET COUNT AS WORDS (SGD APR80) ! 18367: LCT WB,WB LOOP COUNTER ! 18368: * ! 18369: * CLEAR FCBLK ! 18370: * ! 18371: IOP07 ZER (XR)+ CLEAR A WORD ! 18372: BCT WB,IOP07 LOOP ! 18373: BEQ WC,=NUM02,IOP09 SKIP IF IN STATIC - DONT SET FIELDS ! 18374: MOV =B$XNT,(XL) STORE XNBLK CODE IN CASE ! 18375: MOV WA,1(XL) STORE LENGTH ! 18376: BNZ WC,IOP09 JUMP IF XNBLK WANTED ! 18377: MOV =B$XRT,(XL) XRBLK CODE REQUESTED ! 18378: * ! 18379: EJC ! 18380: * IOPUT (CONTINUED) ! 18381: * ! 18382: * COMPLETE FCBLK INITIALISATION ! 18383: * ! 18384: IOP09 MOV R$IOT,XR GET POSSIBLE TRBLK PTR ! 18385: MOV XL,R$IOF STORE FCBLK PTR ! 18386: BNZ XR,IOP10 JUMP IF TRBLK ALREADY FOUND ! 18387: * ! 18388: * A NEW TRBLK IS NEEDED ! 18389: * ! 18390: MOV =TRTFC,WB TRTYP FOR FCBLK TRAP BLK ! 18391: JSR TRBLD MAKE THE BLOCK ! 18392: MOV XR,R$IOT COPY TRTRF PTR ! 18393: MOV R$IOP,XL POINT TO PRECEDING BLK ! 18394: MOV VRVAL(XL),VRVAL(XR) COPY VALUE FIELD TO TRBLK ! 18395: MOV XR,VRVAL(XL) LINK NEW TRBLK INTO CHAIN ! 18396: MOV XL,XR POINT TO PREDECESSOR BLK ! 18397: JSR SETVR SET TRACE INTERCEPTS ! 18398: MOV VRVAL(XR),XR RECOVER TRBLK PTR ! 18399: * ! 18400: * XR IS PTR TO TRBLK, XL IS FCBLK PTR OR 0 ! 18401: * ! 18402: IOP10 MOV R$IOF,TRFPT(XR) STORE FCBLK PTR ! 18403: * ! 18404: * CALL SYSIO TO COMPLETE FILE ACCESSING ! 18405: * ! 18406: IOP11 MOV R$IOF,WA COPY FCBLK PTR OR 0 ! 18407: MOV IOPTT,WB GET INPUT/OUTPUT FLAG ! 18408: MOV R$IO2,XR GET FILE ARG2 ! 18409: MOV R$IO1,XL GET FILE ARG1 ! 18410: JSR SYSIO ASSOCIATE TO THE FILE ! 18411: PPM IOP17 FAIL ! 18412: PPM IOP18 FAIL ! 18413: BNZ R$IOT,IOP01 NOT STD INPUT IF NON-NULL TRTRF BLK ! 18414: BNZ IOPTT,IOP01 JUMP IF OUTPUT ! 18415: BZE WC,IOP01 NO CHANGE TO STANDARD READ LENGTH ! 18416: MOV WC,CSWIN STORE NEW READ LENGTH FOR STD FILE ! 18417: BRN IOP01 MERGE TO FINISH THE TASK ! 18418: * ! 18419: * SYSFC MAY HAVE RETURNED A POINTER TO A PRIVATE FCBLK ! 18420: * ! 18421: IOP12 BNZ XL,IOP09 JUMP IF PRIVATE FCBLK ! 18422: BRN IOP11 FINISH THE ASSOCIATION ! 18423: * ! 18424: * FAILURE RETURNS ! 18425: * ! 18426: IOP13 EXI 1 3RD ARG NOT A STRING ! 18427: IOP14 EXI 2 2ND ARG UNSUITABLE ! 18428: IOP15 EXI 3 1ST ARG UNSUITABLE ! 18429: IOP16 EXI 4 FILE SPEC WRONG ! 18430: IOP17 EXI 5 I/O FILE DOES NOT EXIST ! 18431: IOP18 EXI 6 I/O FILE CANNOT BE READ/WRITTEN ! 18432: EJC ! 18433: * ! 18434: * IOPUT (CONTINUED) ! 18435: * ! 18436: * ADD TO IOCHN CHAIN OF ASSSOCIATED VARIABLES UNLESS ALREAD ! 18437: * PRESENT. ! 18438: * ! 18439: IOP19 MOV R$ION,WC WC = NAME BASE, WB = NAME OFFSET ! 18440: * ! 18441: * SEARCH LOOP ! 18442: * ! 18443: IOP20 MOV TRTRF(XR),XR NEXT LINK OF CHAIN ! 18444: BZE XR,IOP21 NOT FOUND ! 18445: BNE WC,IONMB(XR),IOP20 NO MATCH ! 18446: BEQ WB,IONMO(XR),IOP22 EXIT IF MATCHED ! 18447: BRN IOP20 LOOP ! 18448: * ! 18449: * NOT FOUND ! 18450: * ! 18451: IOP21 MOV *NUM05,WA SPACE NEEDED ! 18452: JSR ALLOC GET IT ! 18453: MOV =B$XRT,(XR) STORE XRBLK CODE ! 18454: MOV WA,1(XR) STORE LENGTH ! 18455: MOV WC,IONMB(XR) STORE NAME BASE ! 18456: MOV WB,IONMO(XR) STORE NAME OFFSET ! 18457: MOV R$IOT,XL POINT TO TRTRF BLK ! 18458: MOV TRTRF(XL),WA GET PTR FIELD CONTENTS ! 18459: MOV XR,TRTRF(XL) STORE PTR TO NEW BLOCK ! 18460: MOV WA,TRTRF(XR) COMPLETE THE LINKING ! 18461: * ! 18462: * INSERT FCBLK ON FCBLK CHAIN FOR SYSEJ, SYSXI ! 18463: * ! 18464: IOP22 BZE R$IOF,IOP25 SKIP IF NO FCBLK ! 18465: MOV R$FCB,XL PTR TO HEAD OF EXISTING CHAIN ! 18466: * ! 18467: * SEE IF FCBLK ALREADY ON CHAIN ! 18468: * ! 18469: IOP23 BZE XL,IOP24 NOT ON IF END OF CHAIN ! 18470: BEQ 3(XL),R$IOF,IOP25 DONT DUPLICATE IF FIND IT ! 18471: MOV 2(XL),XL GET NEXT LINK ! 18472: BRN IOP23 LOOP ! 18473: * ! 18474: * NOT FOUND SO ADD AN ENTRY FOR THIS FCBLK ! 18475: * ! 18476: IOP24 MOV *NUM04,WA SPACE NEEDED ! 18477: JSR ALLOC GET IT ! 18478: MOV =B$XRT,(XR) STORE BLOCK CODE ! 18479: MOV WA,1(XR) STORE LENGTH ! 18480: MOV R$FCB,2(XR) STORE PREVIOUS LINK IN THIS NODE ! 18481: MOV R$IOF,3(XR) STORE FCBLK PTR ! 18482: MOV XR,R$FCB INSERT NODE INTO FCBLK CHAIN ! 18483: * ! 18484: * RETURN ! 18485: * ! 18486: IOP25 EXI RETURN TO CALLER ! 18487: ENP END PROCEDURE IOPUT ! 18488: EJC ! 18489: * ! 18490: * KTREX -- EXECUTE KEYWORD TRACE ! 18491: * ! 18492: * KTREX IS USED TO EXECUTE A POSSIBLE KEYWORD TRACE. IT ! 18493: * INCLUDES THE TEST ON TRACE AND TESTS FOR TRACE ACTIVE. ! 18494: * ! 18495: * (XL) PTR TO TRBLK (OR 0 IF UNTRACED) ! 18496: * JSR KTREX CALL TO EXECUTE KEYWORD TRACE ! 18497: * (XL,WA,WB,WC) DESTROYED ! 18498: * (RA) DESTROYED ! 18499: * ! 18500: KTREX PRC R,0 ENTRY POINT (RECURSIVE) ! 18501: BZE XL,KTRX3 IMMEDIATE EXIT IF KEYWORD UNTRACED ! 18502: BZE KVTRA,KTRX3 IMMEDIATE EXIT IF TRACE = 0 ! 18503: DCV KVTRA ELSE DECREMENT TRACE ! 18504: MOV XR,-(XS) SAVE XR ! 18505: MOV XL,XR COPY TRBLK POINTER ! 18506: MOV TRKVR(XR),XL LOAD VRBLK POINTER (NMBAS) ! 18507: MOV *VRVAL,WA SET NAME OFFSET ! 18508: BZE TRFNC(XR),KTRX1 JUMP IF PRINT TRACE ! 18509: JSR TRXEQ ELSE EXECUTE FULL TRACE ! 18510: BRN KTRX2 AND JUMP TO EXIT ! 18511: * ! 18512: * HERE FOR PRINT TRACE ! 18513: * ! 18514: KTRX1 MOV XL,-(XS) STACK VRBLK PTR FOR KWNAM ! 18515: MOV WA,-(XS) STACK OFFSET FOR KWNAM ! 18516: JSR PRTSN PRINT STATEMENT NUMBER ! 18517: MOV =CH$AM,WA LOAD AMPERSAND ! 18518: JSR PRTCH PRINT AMPERSAND ! 18519: JSR PRTNM PRINT KEYWORD NAME ! 18520: MOV =TMBEB,XR POINT TO BLANK-EQUAL-BLANK ! 18521: JSR PRTST PRINT BLANK-EQUAL-BLANK ! 18522: JSR KWNAM GET KEYWORD PSEUDO-VARIABLE NAME ! 18523: MOV XR,DNAMP RESET PTR TO DELETE KVBLK ! 18524: JSR ACESS GET KEYWORD VALUE ! 18525: PPM FAILURE IS IMPOSSIBLE ! 18526: JSR PRTVL PRINT KEYWORD VALUE ! 18527: JSR PRTNL TERMINATE PRINT LINE ! 18528: * ! 18529: * HERE TO EXIT AFTER COMPLETING TRACE ! 18530: * ! 18531: KTRX2 MOV (XS)+,XR RESTORE ENTRY XR ! 18532: * ! 18533: * MERGE HERE TO EXIT IF NO TRACE REQUIRED ! 18534: * ! 18535: KTRX3 EXI RETURN TO KTREX CALLER ! 18536: ENP END PROCEDURE KTREX ! 18537: EJC ! 18538: * ! 18539: * KWNAM -- GET PSEUDO-VARIABLE NAME FOR KEYWORD ! 18540: * ! 18541: * 1(XS) NAME BASE FOR VRBLK ! 18542: * 0(XS) OFFSET (SHOULD BE *VRVAL) ! 18543: * JSR KWNAM CALL TO GET PSEUDO-VARIABLE NAME ! 18544: * (XS) POPPED TWICE ! 18545: * (XL,WA) RESULTING PSEUDO-VARIABLE NAME ! 18546: * (XR,WA,WB) DESTROYED ! 18547: * ! 18548: KWNAM PRC N,0 ENTRY POINT ! 18549: ICA XS IGNORE NAME OFFSET ! 18550: MOV (XS)+,XR LOAD NAME BASE ! 18551: BGE XR,STATE,KWNM1 JUMP IF NOT NATURAL VARIABLE NAME ! 18552: BNZ VRLEN(XR),KWNM1 ERROR IF NOT SYSTEM VARIABLE ! 18553: MOV VRSVP(XR),XR ELSE POINT TO SVBLK ! 18554: MOV SVBIT(XR),WA LOAD BIT MASK ! 18555: ANB BTKNM,WA AND WITH KEYWORD BIT ! 18556: ZRB WA,KWNM1 ERROR IF NO KEYWORD ASSOCIATION ! 18557: MOV SVLEN(XR),WA ELSE LOAD NAME LENGTH IN CHARACTERS ! 18558: CTB WA,SVCHS COMPUTE OFFSET TO FIELD WE WANT ! 18559: ADD WA,XR POINT TO SVKNM FIELD ! 18560: MOV (XR),WB LOAD SVKNM VALUE ! 18561: MOV *KVSI$,WA SET SIZE OF KVBLK ! 18562: JSR ALLOC ALLOCATE KVBLK ! 18563: MOV =B$KVT,(XR) STORE TYPE WORD ! 18564: MOV WB,KVNUM(XR) STORE KEYWORD NUMBER ! 18565: MOV =TRBKV,KVVAR(XR) SET DUMMY TRBLK POINTER ! 18566: MOV XR,XL COPY KVBLK POINTER ! 18567: MOV *KVVAR,WA SET PROPER OFFSET ! 18568: EXI RETURN TO KVNAM CALLER ! 18569: * ! 18570: * HERE IF NOT KEYWORD NAME ! 18571: * ! 18572: KWNM1 ERB 251,KEYWORD OPERAND IS NOT NAME OF DEFINED KEYWORD ! 18573: ENP END PROCEDURE KWNAM ! 18574: EJC ! 18575: * ! 18576: * LCOMP-- COMPARE TWO STRINGS LEXICALLY ! 18577: * ! 18578: * 1(XS) FIRST ARGUMENT ! 18579: * 0(XS) SECOND ARGUMENT ! 18580: * JSR LCOMP CALL TO COMPARE ARUMENTS ! 18581: * PPM LOC TRANSFER LOC FOR ARG1 NOT STRING ! 18582: * PPM LOC TRANSFER LOC FOR ARG2 NOT STRING ! 18583: * PPM LOC TRANSFER LOC IF ARG1 LLT ARG2 ! 18584: * PPM LOC TRANSFER LOC IF ARG1 LEQ ARG2 ! 18585: * PPM LOC TRANSFER LOC IF ARG1 LGT ARG2 ! 18586: * (THE NORMAL RETURN IS NEVER TAKEN) ! 18587: * (XS) POPPED TWICE ! 18588: * (XR,XL) DESTROYED ! 18589: * (WA,WB,WC,RA) DESTROYED ! 18590: * ! 18591: LCOMP PRC N,5 ENTRY POINT ! 18592: JSR GTSTG CONVERT SECOND ARG TO STRING ! 18593: PPM LCMP6 JUMP IF SECOND ARG NOT STRING ! 18594: MOV XR,XL ELSE SAVE POINTER ! 18595: MOV WA,WB AND LENGTH ! 18596: JSR GTSTG CONVERT FIRST ARGUMENT TO STRING ! 18597: PPM LCMP5 JUMP IF NOT STRING ! 18598: MOV WA,WC SAVE ARG 1 LENGTH ! 18599: PLC XR POINT TO CHARS OF ARG 1 ! 18600: PLC XL POINT TO CHARS OF ARG 2 ! 18601: BLO WA,WB,LCMP1 JUMP IF ARG 1 LENGTH IS SMALLER ! 18602: MOV WB,WA ELSE SET ARG 2 LENGTH AS SMALLER ! 18603: * ! 18604: * HERE WITH SMALLER LENGTH IN (WA) ! 18605: * ! 18606: LCMP1 CMC LCMP4,LCMP3 COMPARE STRINGS, JUMP IF UNEQUAL ! 18607: BNE WB,WC,LCMP2 IF EQUAL, JUMP IF LENGTHS UNEQUAL ! 18608: EXI 4 ELSE IDENTICAL STRINGS, LEQ EXIT ! 18609: EJC ! 18610: * ! 18611: * LCOMP (CONTINUED) ! 18612: * ! 18613: * HERE IF INITIAL STRINGS IDENTICAL, BUT LENGTHS UNEQUAL ! 18614: * ! 18615: LCMP2 BHI WC,WB,LCMP4 JUMP IF ARG 1 LENGTH GT ARG 2 LENG ! 18616: * ! 18617: * HERE IF FIRST ARG LLT SECOND ARG ! 18618: * ! 18619: LCMP3 EXI 3 TAKE LLT EXIT ! 18620: * ! 18621: * HERE IF FIRST ARG LGT SECOND ARG ! 18622: * ! 18623: LCMP4 EXI 5 TAKE LGT EXIT ! 18624: * ! 18625: * HERE IF FIRST ARG IS NOT A STRING ! 18626: * ! 18627: LCMP5 EXI 1 TAKE BAD FIRST ARG EXIT ! 18628: * ! 18629: * HERE FOR SECOND ARG NOT A STRING ! 18630: * ! 18631: LCMP6 EXI 2 TAKE BAD SECOND ARG ERROR EXIT ! 18632: ENP END PROCEDURE LCOMP ! 18633: EJC ! 18634: * ! 18635: * LISTR -- LIST SOURCE LINE ! 18636: * ! 18637: * LISTR IS USED TO LIST A SOURCE LINE DURING THE INITIAL ! 18638: * COMPILATION. IT IS CALLED FROM SCANE AND SCANL. ! 18639: * ! 18640: * JSR LISTR CALL TO LIST LINE ! 18641: * (XR,XL,WA,WB,WC) DESTROYED ! 18642: * ! 18643: * GLOBAL LOCATIONS USED BY LISTR ! 18644: * ! 18645: * ERLST IF LISTING ON ACCOUNT OF AN ERROR ! 18646: * ! 18647: * LSTLC COUNT LINES ON CURRENT PAGE ! 18648: * ! 18649: * LSTNP MAX NUMBER OF LINES/PAGE ! 18650: * ! 18651: * LSTPF SET NON-ZERO IF THE CURRENT SOURCE ! 18652: * LINE HAS BEEN LISTED, ELSE ZERO. ! 18653: * ! 18654: * LSTPG COMPILER LISTING PAGE NUMBER ! 18655: * ! 18656: * LSTSN SET IF STMNT NUM TO BE LISTED ! 18657: * ! 18658: * R$CIM POINTER TO CURRENT INPUT LINE. ! 18659: * ! 18660: * R$TTL TITLE FOR SOURCE LISTING ! 18661: * ! 18662: * R$STL PTR TO SUB-TITLE STRING ! 18663: * ! 18664: * ENTRY POINT ! 18665: * ! 18666: LISTR PRC E,0 ENTRY POINT ! 18667: BNZ CNTTL,LIST5 JUMP IF -TITLE OR -STITL ! 18668: BNZ LSTPF,LIST4 IMMEDIATE EXIT IF ALREADY LISTED ! 18669: BGE LSTLC,LSTNP,LIST6 JUMP IF NO ROOM ! 18670: * ! 18671: * HERE AFTER PRINTING TITLE (IF NEEDED) ! 18672: * ! 18673: LIST0 MOV R$CIM,XR LOAD POINTER TO CURRENT IMAGE ! 18674: PLC XR POINT TO CHARACTERS ! 18675: LCH WA,(XR) LOAD FIRST CHARACTER ! 18676: MOV LSTSN,XR LOAD STATEMENT NUMBER ! 18677: BZE XR,LIST2 JUMP IF NO STATEMENT NUMBER ! 18678: MTI XR ELSE GET STMNT NUMBER AS INTEGER ! 18679: BNE STAGE,=STGIC,LIST1 SKIP IF EXECUTE TIME ! 18680: BEQ WA,=CH$AS,LIST2 NO STMNT NUMBER LIST IF COMMENT ! 18681: BEQ WA,=CH$MN,LIST2 NO STMNT NO. IF CONTROL CARD ! 18682: * ! 18683: * PRINT STATEMENT NUMBER ! 18684: * ! 18685: LIST1 JSR PRTIN ELSE PRINT STATEMENT NUMBER ! 18686: ZER LSTSN AND CLEAR FOR NEXT TIME IN ! 18687: EJC ! 18688: * ! 18689: * LISTR (CONTINUED) ! 18690: * ! 18691: * MERGE HERE AFTER PRINTING STATEMENT NUMBER (IF REQUIRED) ! 18692: * ! 18693: LIST2 MOV =STNPD,PROFS POINT PAST STATEMENT NUMBER ! 18694: MOV R$CIM,XR LOAD POINTER TO CURRENT IMAGE ! 18695: JSR PRTST PRINT IT ! 18696: ICV LSTLC BUMP LINE COUNTER ! 18697: BNZ ERLST,LIST3 JUMP IF ERROR COPY TO INT.CH. ! 18698: JSR PRTNL TERMINATE LINE ! 18699: BZE CSWDB,LIST3 JUMP IF -SINGLE MODE ! 18700: JSR PRTNL ELSE ADD A BLANK LINE ! 18701: ICV LSTLC AND BUMP LINE COUNTER ! 18702: * ! 18703: * HERE AFTER PRINTING SOURCE IMAGE ! 18704: * ! 18705: LIST3 MNZ LSTPF SET FLAG FOR LINE PRINTED ! 18706: * ! 18707: * MERGE HERE TO EXIT ! 18708: * ! 18709: LIST4 EXI RETURN TO LISTR CALLER ! 18710: * ! 18711: * PRINT TITLE AFTER -TITLE OR -STITL CARD ! 18712: * ! 18713: LIST5 ZER CNTTL CLEAR FLAG ! 18714: * ! 18715: * EJECT TO NEW PAGE AND LIST TITLE ! 18716: * ! 18717: LIST6 JSR PRTPS EJECT ! 18718: BZE PRICH,LIST7 SKIP IF LISTING TO REGULAR PRINTER ! 18719: BEQ R$TTL,=NULLS,LIST0 TERMINAL LISTING OMITS NULL TITLE ! 18720: * ! 18721: * LIST TITLE ! 18722: * ! 18723: LIST7 JSR LISTT LIST TITLE ! 18724: BRN LIST0 MERGE ! 18725: ENP END PROCEDURE LISTR ! 18726: EJC ! 18727: * ! 18728: * LISTT -- LIST TITLE AND SUBTITLE ! 18729: * ! 18730: * USED DURING COMPILATION TO PRINT PAGE HEADING ! 18731: * ! 18732: * JSR LISTT CALL TO LIST TITLE ! 18733: * (XR,WA) DESTROYED ! 18734: * ! 18735: LISTT PRC E,0 ENTRY POINT ! 18736: MOV R$TTL,XR POINT TO SOURCE LISTING TITLE ! 18737: JSR PRTST PRINT TITLE ! 18738: MOV LSTPO,PROFS SET OFFSET ! 18739: MOV =LSTMS,XR SET PAGE MESSAGE ! 18740: JSR PRTST PRINT PAGE MESSAGE ! 18741: ICV LSTPG BUMP PAGE NUMBER ! 18742: MTI LSTPG LOAD PAGE NUMBER AS INTEGER ! 18743: JSR PRTIN PRINT PAGE NUMBER ! 18744: JSR PRTNL TERMINATE TITLE LINE ! 18745: ADD =NUM02,LSTLC COUNT TITLE LINE AND BLANK LINE ! 18746: * ! 18747: * PRINT SUB-TITLE (IF ANY) ! 18748: * ! 18749: MOV R$STL,XR LOAD POINTER TO SUB-TITLE ! 18750: BZE XR,LSTT1 JUMP IF NO SUB-TITLE ! 18751: JSR PRTST ELSE PRINT SUB-TITLE ! 18752: JSR PRTNL TERMINATE LINE ! 18753: ICV LSTLC BUMP LINE COUNT ! 18754: * ! 18755: * RETURN POINT ! 18756: * ! 18757: LSTT1 JSR PRTNL PRINT A BLANK LINE ! 18758: EXI RETURN TO CALLER ! 18759: ENP END PROCEDURE LISTT ! 18760: EJC ! 18761: * ! 18762: * NEXTS -- ACQUIRE NEXT SOURCE IMAGE ! 18763: * ! 18764: * NEXTS IS USED TO ACQUIRE THE NEXT SOURCE IMAGE AT COMPILE ! 18765: * TIME. IT ASSUMES THAT A PRIOR CALL TO READR HAS INPUT ! 18766: * A LINE IMAGE (SEE PROCEDURE READR). BEFORE THE CURRENT ! 18767: * IMAGE IS FINALLY LOST IT MAY BE LISTED HERE. ! 18768: * ! 18769: * JSR NEXTS CALL TO ACQUIRE NEXT INPUT LINE ! 18770: * (XR,XL,WA,WB,WC) DESTROYED ! 18771: * ! 18772: * GLOBAL VALUES AFFECTED ! 18773: * ! 18774: * R$CNI ON INPUT, NEXT IMAGE. ON ! 18775: * EXIT RESET TO ZERO ! 18776: * ! 18777: * R$CIM ON EXIT, SET TO POINT TO IMAGE ! 18778: * ! 18779: * SCNIL INPUT IMAGE LENGTH ON EXIT ! 18780: * ! 18781: * SCNSE RESET TO ZERO ON EXIT ! 18782: * ! 18783: * LSTPF SET ON EXIT IF LINE IS LISTED ! 18784: * ! 18785: NEXTS PRC E,0 ENTRY POINT ! 18786: BZE CSWLS,NXTS2 JUMP IF -NOLIST ! 18787: MOV R$CIM,XR POINT TO IMAGE ! 18788: BZE XR,NXTS2 JUMP IF NO IMAGE ! 18789: PLC XR GET CHAR PTR ! 18790: LCH WA,(XR) GET FIRST CHAR ! 18791: BNE WA,=CH$MN,NXTS1 JUMP IF NOT CTRL CARD ! 18792: BZE CSWPR,NXTS2 JUMP IF -NOPRINT ! 18793: * ! 18794: * HERE TO CALL LISTER ! 18795: * ! 18796: NXTS1 JSR LISTR LIST LINE ! 18797: * ! 18798: * HERE AFTER POSSIBLE LISTING ! 18799: * ! 18800: NXTS2 MOV R$CNI,XR POINT TO NEXT IMAGE ! 18801: MOV XR,R$CIM SET AS NEXT IMAGE ! 18802: ZER R$CNI CLEAR NEXT IMAGE POINTER ! 18803: MOV SCLEN(XR),WA GET INPUT IMAGE LENGTH ! 18804: MOV CSWIN,WB GET MAX ALLOWABLE LENGTH ! 18805: BLO WA,WB,NXTS3 SKIP IF NOT TOO LONG ! 18806: MOV WB,WA ELSE TRUNCATE ! 18807: * ! 18808: * HERE WITH LENGTH IN (WA) ! 18809: * ! 18810: NXTS3 MOV WA,SCNIL USE AS RECORD LENGTH ! 18811: ZER SCNSE RESET SCNSE ! 18812: ZER LSTPF SET LINE NOT LISTED YET ! 18813: EXI RETURN TO NEXTS CALLER ! 18814: ENP END PROCEDURE NEXTS ! 18815: EJC ! 18816: * ! 18817: * PATIN -- PATTERN CONSTRUCTION FOR LEN,POS,RPOS,TAB,RTAB ! 18818: * ! 18819: * THESE PATTERN TYPES ALL GENERATE A SIMILAR NODE TYPE. SO ! 18820: * THE CONSTRUCTION CODE IS SHARED. SEE FUNCTIONS SECTION ! 18821: * FOR ACTUAL ENTRY POINTS FOR THESE FIVE FUNCTIONS. ! 18822: * ! 18823: * (WA) PCODE FOR EXPRESSION ARG CASE ! 18824: * (WB) PCODE FOR INTEGER ARG CASE ! 18825: * JSR PATIN CALL TO BUILD PATTERN NODE ! 18826: * PPM LOC TRANSFER LOC FOR NOT INTEGER OR EXP ! 18827: * PPM LOC TRANSFER LOC FOR INT OUT OF RANGE ! 18828: * (XR) POINTER TO CONSTRUCTED NODE ! 18829: * (XL,WA,WB,WC,IA) DESTROYED ! 18830: * ! 18831: PATIN PRC N,2 ENTRY POINT ! 18832: MOV WA,XL PRESERVE EXPRESSION ARG PCODE ! 18833: JSR GTSMI TRY TO CONVERT ARG AS SMALL INTEGER ! 18834: PPM PTIN2 JUMP IF NOT INTEGER ! 18835: PPM PTIN3 JUMP IF OUT OF RANGE ! 18836: * ! 18837: * COMMON SUCCESSFUL EXIT POINT ! 18838: * ! 18839: PTIN1 JSR PBILD BUILD PATTERN NODE ! 18840: EXI RETURN TO CALLER ! 18841: * ! 18842: * HERE IF ARGUMENT IS NOT AN INTEGER ! 18843: * ! 18844: PTIN2 MOV XL,WB COPY EXPR ARG CASE PCODE ! 18845: BLO (XR),=B$E$$,PTIN1 ALL OK IF EXPRESSION ARG ! 18846: EXI 1 ELSE TAKE ERROR EXIT FOR WRONG TYPE ! 18847: * ! 18848: * HERE FOR ERROR OF OUT OF RANGE INTEGER ARGUMENT ! 18849: * ! 18850: PTIN3 EXI 2 TAKE OUT-OF-RANGE ERROR EXIT ! 18851: ENP END PROCEDURE PATIN ! 18852: EJC ! 18853: * ! 18854: * PATST -- PATTERN CONSTRUCTION FOR ANY,NOTANY, ! 18855: * BREAK,SPAN AND BREAKX PATTERN FUNCTIONS. ! 18856: * ! 18857: * THESE PATTERN FUNCTIONS BUILD SIMILAR TYPES OF NODES AND ! 18858: * THE CONSTRUCTION CODE IS SHARED. SEE FUNCTIONS SECTION ! 18859: * FOR ACTUAL ENTRY POINTS FOR THESE FIVE PATTERN FUNCTIONS. ! 18860: * ! 18861: * 0(XS) STRING ARGUMENT ! 18862: * (WB) PCODE FOR ONE CHAR ARGUMENT ! 18863: * (XL) PCODE FOR MULTI-CHAR ARGUMENT ! 18864: * (WC) PCODE FOR EXPRESSION ARGUMENT ! 18865: * JSR PATST CALL TO BUILD NODE ! 18866: * PPM LOC TRANSFER LOC IF NOT STRING OR EXPR ! 18867: * (XS) POPPED PAST STRING ARGUMENT ! 18868: * (XR) POINTER TO CONSTRUCTED NODE ! 18869: * (XL) DESTROYED ! 18870: * (WA,WB,WC,RA) DESTROYED ! 18871: * ! 18872: * NOTE THAT THERE IS A SPECIAL CALL TO PATST IN THE EVALS ! 18873: * PROCEDURE WITH A SLIGHTLY DIFFERENT FORM. SEE EVALS ! 18874: * FOR DETAILS OF THE FORM OF THIS CALL. ! 18875: * ! 18876: PATST PRC N,1 ENTRY POINT ! 18877: JSR GTSTG CONVERT ARGUMENT AS STRING ! 18878: PPM PATS7 JUMP IF NOT STRING ! 18879: BNE WA,=NUM01,PATS2 JUMP IF NOT ONE CHAR STRING ! 18880: * ! 18881: * HERE FOR ONE CHAR STRING CASE ! 18882: * ! 18883: BZE WB,PATS2 TREAT AS MULTI-CHAR IF EVALS CALL ! 18884: PLC XR POINT TO CHARACTER ! 18885: LCH XR,(XR) LOAD CHARACTER ! 18886: * ! 18887: * COMMON EXIT POINT AFTER SUCCESSFUL CONSTRUCTION ! 18888: * ! 18889: PATS1 JSR PBILD CALL ROUTINE TO BUILD NODE ! 18890: EXI RETURN TO PATST CALLER ! 18891: EJC ! 18892: * ! 18893: * PATST (CONTINUED) ! 18894: * ! 18895: * HERE FOR MULTI-CHARACTER STRING CASE ! 18896: * ! 18897: PATS2 MOV XL,-(XS) SAVE MULTI-CHAR PCODE ! 18898: MOV XR,-(XS) SAVE STRING POINTER ! 18899: MOV CTMSK,WC LOAD CURRENT MASK BIT ! 18900: LSH WC,1 SHIFT TO NEXT POSITION ! 18901: NZB WC,PATS4 SKIP IF POSITION LEFT IN THIS TBL ! 18902: * ! 18903: * HERE WE MUST ALLOCATE A NEW CHARACTER TABLE ! 18904: * ! 18905: MOV *CTSI$,WA SET SIZE OF CTBLK ! 18906: JSR ALLOC ALLOCATE CTBLK ! 18907: MOV XR,R$CTP STORE PTR TO NEW CTBLK ! 18908: MOV =B$CTT,(XR)+ STORE TYPE CODE, BUMP PTR ! 18909: LCT WB,=CFP$A SET NUMBER OF WORDS TO CLEAR ! 18910: MOV BITS0,WC LOAD ALL ZERO BITS ! 18911: * ! 18912: * LOOP TO CLEAR ALL BITS IN TABLE TO ZEROS ! 18913: * ! 18914: PATS3 MOV WC,(XR)+ MOVE WORD OF ZERO BITS ! 18915: BCT WB,PATS3 LOOP TILL ALL CLEARED ! 18916: MOV BITS1,WC SET INITIAL BIT POSITION ! 18917: * ! 18918: * MERGE HERE WITH BIT POSITION AVAILABLE ! 18919: * ! 18920: PATS4 MOV WC,CTMSK SAVE PARM2 (NEW BIT POSITION) ! 18921: MOV (XS)+,XL RESTORE POINTER TO ARGUMENT STRING ! 18922: MOV SCLEN(XL),WB LOAD STRING LENGTH ! 18923: BZE WB,PATS6 JUMP IF NULL STRING CASE ! 18924: LCT WB,WB ELSE SET LOOP COUNTER ! 18925: PLC XL POINT TO CHARACTERS IN ARGUMENT ! 18926: EJC ! 18927: * ! 18928: * PATST (CONTINUED) ! 18929: * ! 18930: * LOOP TO SET BITS IN COLUMN OF TABLE ! 18931: * ! 18932: PATS5 LCH WA,(XL)+ LOAD NEXT CHARACTER ! 18933: WTB WA CONVERT TO BYTE OFFSET ! 18934: MOV R$CTP,XR POINT TO CTBLK ! 18935: ADD WA,XR POINT TO CTBLK ENTRY ! 18936: MOV WC,WA COPY BIT MASK ! 18937: ORB CTCHS(XR),WA OR IN BITS ALREADY SET ! 18938: MOV WA,CTCHS(XR) STORE RESULTING BIT STRING ! 18939: BCT WB,PATS5 LOOP TILL ALL BITS SET ! 18940: * ! 18941: * COMPLETE PROCESSING FOR MUTI-CHAR STRING CASE ! 18942: * ! 18943: PATS6 MOV R$CTP,XR LOAD CTBLK PTR AS PARM1 FOR PBILD ! 18944: ZER XL CLEAR GARBAGE PTR IN XL ! 18945: MOV (XS)+,WB LOAD PCODE FOR MULTI-CHAR STR CASE ! 18946: BRN PATS1 BACK TO EXIT (WC=BITSTRING=PARM2) ! 18947: * ! 18948: * HERE IF ARGUMENT IS NOT A STRING ! 18949: * ! 18950: * NOTE THAT THE CALL FROM EVALS CANNOT PASS AN EXPRESSION ! 18951: * SINCE EVALP ALWAYS REEVALUATES EXPRESSIONS. ! 18952: * ! 18953: PATS7 MOV WC,WB SET PCODE FOR EXPRESSION ARGUMENT ! 18954: BLO (XR),=B$E$$,PATS1 JUMP TO EXIT IF EXPRESSION ARG ! 18955: EXI 1 ELSE TAKE WRONG TYPE ERROR EXIT ! 18956: ENP END PROCEDURE PATST ! 18957: EJC ! 18958: * ! 18959: * PBILD -- BUILD PATTERN NODE ! 18960: * ! 18961: * (XR) PARM1 (ONLY IF REQUIRED) ! 18962: * (WB) PCODE FOR NODE ! 18963: * (WC) PARM2 (ONLY IF REQUIRED) ! 18964: * JSR PBILD CALL TO BUILD NODE ! 18965: * (XR) POINTER TO CONSTRUCTED NODE ! 18966: * (WA) DESTROYED ! 18967: * ! 18968: PBILD PRC E,0 ENTRY POINT ! 18969: MOV XR,-(XS) STACK POSSIBLE PARM1 ! 18970: MOV WB,XR COPY PCODE ! 18971: LEI XR LOAD ENTRY POINT ID (BL$PX) ! 18972: BEQ XR,=BL$P1,PBLD1 JUMP IF ONE PARAMETER ! 18973: BEQ XR,=BL$P0,PBLD3 JUMP IF NO PARAMETERS ! 18974: * ! 18975: * HERE FOR TWO PARAMETER CASE ! 18976: * ! 18977: MOV *PCSI$,WA SET SIZE OF P2BLK ! 18978: JSR ALLOC ALLOCATE BLOCK ! 18979: MOV WC,PARM2(XR) STORE SECOND PARAMETER ! 18980: BRN PBLD2 MERGE WITH ONE PARM CASE ! 18981: * ! 18982: * HERE FOR ONE PARAMETER CASE ! 18983: * ! 18984: PBLD1 MOV *PBSI$,WA SET SIZE OF P1BLK ! 18985: JSR ALLOC ALLOCATE NODE ! 18986: * ! 18987: * MERGE HERE FROM TWO PARM CASE ! 18988: * ! 18989: PBLD2 MOV (XS),PARM1(XR) STORE FIRST PARAMETER ! 18990: BRN PBLD4 MERGE WITH NO PARAMETER CASE ! 18991: * ! 18992: * HERE FOR CASE OF NO PARAMETERS ! 18993: * ! 18994: PBLD3 MOV *PASI$,WA SET SIZE OF P0BLK ! 18995: JSR ALLOC ALLOCATE NODE ! 18996: * ! 18997: * MERGE HERE FROM OTHER CASES ! 18998: * ! 18999: PBLD4 MOV WB,(XR) STORE PCODE ! 19000: ICA XS POP FIRST PARAMETER ! 19001: MOV =NDNTH,PTHEN(XR) SET NOTHEN SUCCESSOR POINTER ! 19002: EXI RETURN TO PBILD CALLER ! 19003: ENP END PROCEDURE PBILD ! 19004: EJC ! 19005: * ! 19006: * PCONC -- CONCATENATE TWO PATTERNS ! 19007: * ! 19008: * (XL) PTR TO RIGHT PATTERN ! 19009: * (XR) PTR TO LEFT PATTERN ! 19010: * JSR PCONC CALL TO CONCATENATE PATTERNS ! 19011: * (XR) PTR TO CONCATENATED PATTERN ! 19012: * (XL,WA,WB,WC) DESTROYED ! 19013: * ! 19014: * ! 19015: * TO CONCATENATE TWO PATTERNS, ALL SUCCESSORS IN THE LEFT ! 19016: * PATTERN WHICH POINT TO THE NOTHEN NODE MUST BE CHANGED TO ! 19017: * POINT TO THE RIGHT PATTERN. HOWEVER, THIS MODIFICATION ! 19018: * MUST BE PERFORMED ON A COPY OF THE LEFT ARGUMENT RATHER ! 19019: * THAN THE LEFT ARGUMENT ITSELF, SINCE THE LEFT ARGUMENT ! 19020: * MAY BE POINTED TO BY SOME OTHER VARIABLE VALUE. ! 19021: * ! 19022: * ACCORDINGLY, IT IS NECESSARY TO COPY THE LEFT ARGUMENT. ! 19023: * THIS IS NOT A TRIVIAL PROCESS SINCE WE MUST AVOID COPYING ! 19024: * NODES MORE THAN ONCE AND THE PATTERN IS A GRAPH STRUCTURE ! 19025: * THE FOLLOWING ALGORITHM IS EMPLOYED. ! 19026: * ! 19027: * THE STACK IS USED TO STORE A LIST OF NODES WHICH ! 19028: * HAVE ALREADY BEEN COPIED. THE FORMAT OF THE ENTRIES ON ! 19029: * THIS LIST CONSISTS OF A TWO WORD BLOCK. THE FIRST WORD ! 19030: * IS THE OLD ADDRESS AND THE SECOND WORD IS THE ADDRESS ! 19031: * OF THE COPY. THIS LIST IS SEARCHED BY THE PCOPY ! 19032: * ROUTINE TO AVOID MAKING DUPLICATE COPIES. A TRICK IS ! 19033: * USED TO ACCOMPLISH THE CONCATENATION AT THE SAME TIME. ! 19034: * A SPECIAL ENTRY IS MADE TO START WITH ON THE STACK. THIS ! 19035: * ENTRY RECORDS THAT THE NOTHEN NODE HAS BEEN COPIED ! 19036: * ALREADY AND THE ADDRESS OF ITS COPY IS THE RIGHT PATTERN. ! 19037: * THIS AUTOMATICALLY PERFORMS THE CORRECT REPLACEMENTS. ! 19038: * ! 19039: PCONC PRC E,0 ENTRY POINT ! 19040: ZER -(XS) MAKE ROOM FOR ONE ENTRY AT BOTTOM ! 19041: MOV XS,WC STORE POINTER TO START OF LIST ! 19042: MOV =NDNTH,-(XS) STACK NOTHEN NODE AS OLD NODE ! 19043: MOV XL,-(XS) STORE RIGHT ARG AS COPY OF NOTHEN ! 19044: MOV XS,XT INITIALIZE POINTER TO STACK ENTRIES ! 19045: JSR PCOPY COPY FIRST NODE OF LEFT ARG ! 19046: MOV WA,2(XT) STORE AS RESULT UNDER LIST ! 19047: EJC ! 19048: * ! 19049: * PCONC (CONTINUED) ! 19050: * ! 19051: * THE FOLLOWING LOOP SCANS ENTRIES IN THE LIST AND MAKES ! 19052: * SURE THAT THEIR SUCCESSORS HAVE BEEN COPIED. ! 19053: * ! 19054: PCNC1 BEQ XT,XS,PCNC2 JUMP IF ALL ENTRIES PROCESSED ! 19055: MOV -(XT),XR ELSE LOAD NEXT OLD ADDRESS ! 19056: MOV PTHEN(XR),XR LOAD POINTER TO SUCCESSOR ! 19057: JSR PCOPY COPY SUCCESSOR NODE ! 19058: MOV -(XT),XR LOAD POINTER TO NEW NODE (COPY) ! 19059: MOV WA,PTHEN(XR) STORE PTR TO NEW SUCCESSOR ! 19060: * ! 19061: * NOW CHECK FOR SPECIAL CASE OF ALTERNATION NODE WHERE ! 19062: * PARM1 POINTS TO A NODE AND MUST BE COPIED LIKE PTHEN. ! 19063: * ! 19064: BNE (XR),=P$ALT,PCNC1 LOOP BACK IF NOT ! 19065: MOV PARM1(XR),XR ELSE LOAD POINTER TO ALTERNATIVE ! 19066: JSR PCOPY COPY IT ! 19067: MOV (XT),XR RESTORE PTR TO NEW NODE ! 19068: MOV WA,PARM1(XR) STORE PTR TO COPIED ALTERNATIVE ! 19069: BRN PCNC1 LOOP BACK FOR NEXT ENTRY ! 19070: * ! 19071: * HERE AT END OF COPY PROCESS ! 19072: * ! 19073: PCNC2 MOV WC,XS RESTORE STACK POINTER ! 19074: MOV (XS)+,XR LOAD POINTER TO COPY ! 19075: EXI RETURN TO PCONC CALLER ! 19076: ENP END PROCEDURE PCONC ! 19077: EJC ! 19078: * ! 19079: * PCOPY -- COPY A PATTERN NODE ! 19080: * ! 19081: * PCOPY IS CALLED FROM THE PCONC PROCEDURE TO COPY A SINGLE ! 19082: * PATTERN NODE. THE COPY IS ONLY CARRIED OUT IF THE NODE ! 19083: * HAS NOT BEEN COPIED ALREADY. ! 19084: * ! 19085: * (XR) POINTER TO NODE TO BE COPIED ! 19086: * (XT) PTR TO CURRENT LOC IN COPY LIST ! 19087: * (WC) POINTER TO LIST OF COPIED NODES ! 19088: * JSR PCOPY CALL TO COPY A NODE ! 19089: * (WA) POINTER TO COPY ! 19090: * (WB,XR) DESTROYED ! 19091: * ! 19092: PCOPY PRC N,0 ENTRY POINT ! 19093: MOV XT,WB SAVE XT ! 19094: MOV WC,XT POINT TO START OF LIST ! 19095: * ! 19096: * LOOP TO SEARCH LIST OF NODES COPIED ALREADY ! 19097: * ! 19098: PCOP1 DCA XT POINT TO NEXT ENTRY ON LIST ! 19099: BEQ XR,(XT),PCOP2 JUMP IF MATCH ! 19100: DCA XT ELSE SKIP OVER COPIED ADDRESS ! 19101: BNE XT,XS,PCOP1 LOOP BACK IF MORE TO TEST ! 19102: * ! 19103: * HERE IF NOT IN LIST, PERFORM COPY ! 19104: * ! 19105: MOV (XR),WA LOAD FIRST WORD OF BLOCK ! 19106: JSR BLKLN GET LENGTH OF BLOCK ! 19107: MOV XR,XL SAVE POINTER TO OLD NODE ! 19108: JSR ALLOC ALLOCATE SPACE FOR COPY ! 19109: MOV XL,-(XS) STORE OLD ADDRESS ON LIST ! 19110: MOV XR,-(XS) STORE NEW ADDRESS ON LIST ! 19111: CHK CHECK FOR STACK OVERFLOW ! 19112: MVW MOVE WORDS FROM OLD BLOCK TO COPY ! 19113: MOV (XS),WA LOAD POINTER TO COPY ! 19114: BRN PCOP3 JUMP TO EXIT ! 19115: * ! 19116: * HERE IF WE FIND ENTRY IN LIST ! 19117: * ! 19118: PCOP2 MOV -(XT),WA LOAD ADDRESS OF COPY FROM LIST ! 19119: * ! 19120: * COMMON EXIT POINT ! 19121: * ! 19122: PCOP3 MOV WB,XT RESTORE XT ! 19123: EXI RETURN TO PCOPY CALLER ! 19124: ENP END PROCEDURE PCOPY ! 19125: EJC ! 19126: * ! 19127: * PRFLR -- PRINT PROFILE ! 19128: * PRFLR IS CALLED TO PRINT THE CONTENTS OF THE PROFILE ! 19129: * TABLE IN A FAIRLY READABLE TABULAR FORMAT. ! 19130: * ! 19131: * JSR PRFLR CALL TO PRINT PROFILE ! 19132: * (WA,IA) DESTROYED ! 19133: * ! 19134: PRFLR PRC E,0 ! 19135: BZE PFDMP,PRFL4 NO PRINTING IF NO PROFILING DONE ! 19136: MOV XR,-(XS) PRESERVE ENTRY XR ! 19137: MOV WB,PFSVW AND ALSO WB ! 19138: JSR PRTPG EJECT ! 19139: MOV =PFMS1,XR LOAD MSG /PROGRAM PROFILE/ ! 19140: JSR PRTST AND PRINT IT ! 19141: JSR PRTNL FOLLOWED BY NEWLINE ! 19142: JSR PRTNL AND ANOTHER ! 19143: MOV =PFMS2,XR POINT TO FIRST HDR ! 19144: JSR PRTST PRINT IT ! 19145: JSR PRTNL NEW LINE ! 19146: MOV =PFMS3,XR SECOND HDR ! 19147: JSR PRTST PRINT IT ! 19148: JSR PRTNL NEW LINE ! 19149: JSR PRTNL AND ANOTHER BLANK LINE ! 19150: ZER WB INITIAL STMT COUNT ! 19151: MOV PFTBL,XR POINT TO TABLE ORIGIN ! 19152: ADD *NUM02,XR BIAS PAST XNBLK HEADER (SGD07) ! 19153: * ! 19154: * LOOP HERE TO PRINT SUCCESSIVE ENTRIES ! 19155: * ! 19156: PRFL1 ICV WB BUMP STMT NR ! 19157: LDI (XR) LOAD NR OF EXECUTIONS ! 19158: IEQ PRFL3 NO PRINTING IF ZERO ! 19159: MOV =PFPD1,PROFS POINT WHERE TO PRINT ! 19160: JSR PRTIN AND PRINT IT ! 19161: ZER PROFS BACK TO START OF LINE ! 19162: MTI WB LOAD STMT NR ! 19163: JSR PRTIN PRINT IT THERE ! 19164: MOV =PFPD2,PROFS AND PAD PAST COUNT ! 19165: LDI CFP$I(XR) LOAD TOTAL EXEC TIME ! 19166: JSR PRTIN PRINT THAT TOO ! 19167: LDI CFP$I(XR) RELOAD TIME ! 19168: MLI INTTH CONVERT TO MICROSEC ! 19169: IOV PRFL2 OMIT NEXT BIT IF OVERFLOW ! 19170: DVI (XR) DIVIDE BY EXECUTIONS ! 19171: MOV =PFPD3,PROFS PAD LAST PRINT ! 19172: JSR PRTIN AND PRINT MCSEC/EXECN ! 19173: * ! 19174: * MERGE AFTER PRINTING TIME ! 19175: * ! 19176: PRFL2 JSR PRTNL THATS ANOTHER LINE ! 19177: * ! 19178: * HERE TO GO TO NEXT ENTRY ! 19179: * ! 19180: PRFL3 ADD *PF$I2,XR BUMP INDEX PTR (SGD07) ! 19181: BLT WB,PFNTE,PRFL1 LOOP IF MORE STMTS ! 19182: MOV (XS)+,XR RESTORE CALLERS XR ! 19183: MOV PFSVW,WB AND WB TOO ! 19184: * ! 19185: * HERE TO EXIT ! 19186: * ! 19187: PRFL4 EXI RETURN ! 19188: ENP END OF PRFLR ! 19189: EJC ! 19190: * ! 19191: * PRFLU -- UPDATE AN ENTRY IN THE PROFILE TABLE ! 19192: * ! 19193: * ON ENTRY, KVSTN CONTAINS NR OF STMT TO PROFILE ! 19194: * ! 19195: * JSR PRFLU CALL TO UPDATE ENTRY ! 19196: * (IA) DESTROYED ! 19197: * ! 19198: PRFLU PRC E,0 ! 19199: BNZ PFFNC,PFLU4 SKIP IF JUST ENTERED FUNCTION ! 19200: MOV XR,-(XS) PRESERVE ENTRY XR ! 19201: MOV WA,PFSVW SAVE WA (SGD07) ! 19202: BNZ PFTBL,PFLU2 BRANCH IF TABLE ALLOCATED ! 19203: * ! 19204: * HERE IF SPACE FOR PROFILE TABLE NOT YET ALLOCATED. ! 19205: * CALCULATE SIZE NEEDED, ALLOCATE A STATIC XNBLK, AND ! 19206: * INITIALIZE IT ALL TO ZERO. ! 19207: * THE TIME TAKEN FOR THIS WILL BE ATTRIBUTED TO THE CURRENT ! 19208: * STATEMENT (ASSIGNMENT TO KEYWD PROFILE), BUT SINCE THE ! 19209: * TIMING FOR THIS STATEMENT IS UP THE POLE ANYWAY, THIS ! 19210: * DOESNT REALLY MATTER... ! 19211: * ! 19212: SUB =NUM01,PFNTE ADJUST FOR EXTRA COUNT (SGD07) ! 19213: MTI PFI2A CONVRT ENTRY SIZE TO INT ! 19214: STI PFSTE AND STORE SAFELY FOR LATER ! 19215: MTI PFNTE LOAD TABLE LENGTH AS INTEGER ! 19216: MLI PFSTE MULTIPLY BY ENTRY SIZE ! 19217: MFI WA GET BACK ADDRESS-STYLE ! 19218: ADD =NUM02,WA ADD ON 2 WORD OVERHEAD ! 19219: WTB WA CONVERT THE WHOLE LOT TO BYTES ! 19220: JSR ALOST GIMME THE SPACE ! 19221: MOV XR,PFTBL SAVE BLOCK POINTER ! 19222: MOV =B$XNT,(XR)+ PUT BLOCK TYPE AND ... ! 19223: MOV WA,(XR)+ ... LENGTH INTO HEADER ! 19224: MFI WA GET BACK NR OF WDS IN DATA AREA ! 19225: LCT WA,WA LOAD THE COUNTER ! 19226: * ! 19227: * LOOP HERE TO ZERO THE BLOCK DATA ! 19228: * ! 19229: PFLU1 ZER (XR)+ BLANK A WORD ! 19230: BCT WA,PFLU1 AND ALLLLLLL THE REST ! 19231: * ! 19232: * END OF ALLOCATION. MERGE BACK INTO ROUTINE ! 19233: * ! 19234: PFLU2 MTI KVSTN LOAD NR OF STMT JUST ENDED ! 19235: SBI INTV1 MAKE INTO INDEX OFFSET ! 19236: MLI PFSTE MAKE OFFSET OF TABLE ENTRY ! 19237: MFI WA CONVERT TO ADDRESS ! 19238: WTB WA GET AS BAUS ! 19239: ADD *NUM02,WA OFFSET INCLUDES TABLE HEADER ! 19240: MOV PFTBL,XR GET TABLE START ! 19241: BGE WA,NUM01(XR),PFLU3 IF OUT OF TABLE, SKIP IT ! 19242: ADD WA,XR ELSE POINT TO ENTRY ! 19243: LDI (XR) GET NR OF EXECUTIONS SO FAR ! 19244: ADI INTV1 NUDGE UP ONE ! 19245: STI (XR) AND PUT BACK ! 19246: JSR SYSTM GET TIME NOW ! 19247: STI PFETM STASH ENDING TIME ! 19248: SBI PFSTM SUBTRACT START TIME ! 19249: ADI CFP$I(XR) ADD CUMULATIVE TIME SO FAR ! 19250: STI CFP$I(XR) AND PUT BACK NEW TOTAL ! 19251: LDI PFETM LOAD END TIME OF THIS STMT ... ! 19252: STI PFSTM ... WHICH IS START TIME OF NEXT ! 19253: * ! 19254: * MERGE HERE TO EXIT ! 19255: * ! 19256: PFLU3 MOV (XS)+,XR RESTORE CALLERS XR ! 19257: MOV PFSVW,WA RESTORE SAVED REG ! 19258: EXI AND RETURN ! 19259: * ! 19260: * HERE IF PROFILE IS SUPPRESSED BECAUSE A PROGRAM DEFINED ! 19261: * FUNCTION IS ABOUT TO BE ENTERED, AND SO THE CURRENT STMT ! 19262: * HAS NOT YET FINISHED ! 19263: * ! 19264: PFLU4 ZER PFFNC RESET THE CONDITION FLAG ! 19265: EXI AND IMMEDIATE RETURN ! 19266: ENP END OF PROCEDURE PRFLU ! 19267: EJC ! 19268: * ! 19269: * PRPAR - PROCESS PRINT PARAMETERS ! 19270: * ! 19271: * (WC) IF NONZERO ASSOCIATE TERMINAL ONLY ! 19272: * JSR PRPAR CALL TO PROCESS PRINT PARAMETERS ! 19273: * (XL,XR,WA,WB,WC) DESTROYED ! 19274: * ! 19275: * SINCE MEMORY ALLOCATION IS UNDECIDED ON INITIAL CALL, ! 19276: * TERMINAL CANNOT BE ASSOCIATED. THE ENTRY WITH WC NON-ZERO ! 19277: * IS PROVIDED SO A LATER CALL CAN BE MADE TO COMPLETE THIS. ! 19278: * ! 19279: PRPAR PRC E,0 ENTRY POINT ! 19280: BNZ WC,PRPA7 JUMP TO ASSOCIATE TERMINAL ! 19281: JSR SYSPP GET PRINT PARAMETERS ! 19282: BNZ WB,PRPA1 JUMP IF LINES/PAGE SPECIFIED ! 19283: MOV =CFP$M,WB ELSE USE A LARGE VALUE ! 19284: RSH WB,1 BUT NOT TOO LARGE ! 19285: * ! 19286: * STORE LINE COUNT/PAGE ! 19287: * ! 19288: PRPA1 MOV WB,LSTNP STORE NUMBER OF LINES/PAGE ! 19289: MOV WB,LSTLC PRETEND PAGE IS FULL INITIALLY ! 19290: ZER LSTPG CLEAR PAGE NUMBER ! 19291: MOV PRLEN,WB GET PRIOR LENGTH IF ANY ! 19292: BZE WB,PRPA2 SKIP IF NO LENGTH ! 19293: BGT WA,WB,PRPA3 SKIP STORING IF TOO BIG ! 19294: * ! 19295: * STORE PRINT BUFFER LENGTH ! 19296: * ! 19297: PRPA2 MOV WA,PRLEN STORE VALUE ! 19298: * ! 19299: * PROCESS BITS OPTIONS ! 19300: * ! 19301: PRPA3 MOV BITS3,WB BIT 3 MASK ! 19302: ANB WC,WB GET -NOLIST BIT ! 19303: ZRB WB,PRPA4 SKIP IF CLEAR ! 19304: ZER CSWLS SET -NOLIST ! 19305: * ! 19306: * CHECK IF FAIL REPORTS GOTO INTERACTIVE CHANNEL ! 19307: * ! 19308: PRPA4 MOV BITS1,WB BIT 1 MASK ! 19309: ANB WC,WB GET BIT ! 19310: MOV WB,ERICH STORE INT. CHAN. ERROR FLAG ! 19311: MOV BITS2,WB BIT 2 MASK ! 19312: ANB WC,WB GET BIT ! 19313: MOV WB,PRICH FLAG FOR STD PRINTER ON INT. CHAN. ! 19314: MOV BITS4,WB BIT 4 MASK ! 19315: ANB WC,WB GET BIT ! 19316: MOV WB,CPSTS FLAG FOR COMPILE STATS SUPPRESSN. ! 19317: MOV BITS5,WB BIT 5 MASK ! 19318: ANB WC,WB GET BIT ! 19319: MOV WB,EXSTS FLAG FOR EXEC STATS SUPPRESSION ! 19320: EJC ! 19321: * ! 19322: * PRPAR (CONTINUED) ! 19323: * ! 19324: MOV BITS6,WB BIT 6 MASK ! 19325: ANB WC,WB GET BIT ! 19326: MOV WB,PRECL EXTENDED/COMPACT LISTING FLAG ! 19327: SUB =NUM08,WA POINT 8 CHARS FROM LINE END ! 19328: ZRB WB,PRPA5 JUMP IF NOT EXTENDED ! 19329: MOV WA,LSTPO STORE FOR LISTING PAGE HEADINGS ! 19330: * ! 19331: * CONTINUE OPTION PROCESSING ! 19332: * ! 19333: PRPA5 MOV BITS7,WB BIT 7 MASK ! 19334: ANB WC,WB GET BIT 7 ! 19335: MOV WB,CSWEX SET -NOEXECUTE IF NON-ZERO ! 19336: MOV BIT10,WB BIT 10 MASK ! 19337: ANB WC,WB GET BIT 10 ! 19338: MOV WB,HEADP PRETEND PRINTED TO OMIT HEADERS ! 19339: MOV BITS9,WB BIT 9 MASK ! 19340: ANB WC,WB GET BIT 9 ! 19341: MOV WB,PRSTO KEEP IT AS STD LISTING OPTION ! 19342: ZRB WB,PRPA6 SKIP IF CLEAR ! 19343: MOV PRLEN,WA GET PRINT BUFFER LENGTH ! 19344: SUB =NUM08,WA POINT 8 CHARS FROM LINE END ! 19345: MOV WA,LSTPO STORE PAGE OFFSET ! 19346: * ! 19347: * CHECK FOR TERMINAL ! 19348: * ! 19349: PRPA6 ANB BITS8,WC SEE IF TERMINAL TO BE ACTIVATED ! 19350: BNZ WC,PRPA7 JUMP IF TERMINAL REQUIRED ! 19351: BZE INITR,PRPA8 JUMP IF NO TERMINAL TO DETACH ! 19352: MOV =V$TER,XL PTR TO /TERMINAL/ ! 19353: JSR GTNVR GET VRBLK POINTER ! 19354: PPM CANT FAIL ! 19355: MOV =NULLS,VRVAL(XR) CLEAR VALUE OF TERMINAL ! 19356: JSR SETVR REMOVE ASSOCIATION ! 19357: BRN PRPA8 RETURN ! 19358: * ! 19359: * ASSOCIATE TERMINAL ! 19360: * ! 19361: PRPA7 MNZ INITR NOTE TERMINAL ASSOCIATED ! 19362: BZE DNAMB,PRPA8 CANT IF MEMORY NOT ORGANISED ! 19363: MOV =V$TER,XL POINT TO TERMINAL STRING ! 19364: MOV =TRTOU,WB OUTPUT TRACE TYPE ! 19365: JSR INOUT ATTACH OUTPUT TRBLK TO VRBLK ! 19366: MOV XR,-(XS) STACK TRBLK PTR ! 19367: MOV =V$TER,XL POINT TO TERMINAL STRING ! 19368: MOV =TRTIN,WB INPUT TRACE TYPE ! 19369: JSR INOUT ATTACH INPUT TRACE BLK ! 19370: MOV (XS)+,VRVAL(XR) ADD OUTPUT TRBLK TO CHAIN ! 19371: * ! 19372: * RETURN POINT ! 19373: * ! 19374: PRPA8 EXI RETURN ! 19375: ENP END PROCEDURE PRPAR ! 19376: EJC ! 19377: * ! 19378: * PRTCH -- PRINT A CHARACTER ! 19379: * ! 19380: * PRTCH IS USED TO PRINT A SINGLE CHARACTER ! 19381: * ! 19382: * (WA) CHARACTER TO BE PRINTED ! 19383: * JSR PRTCH CALL TO PRINT CHARACTER ! 19384: * ! 19385: PRTCH PRC E,0 ENTRY POINT ! 19386: MOV XR,-(XS) SAVE XR ! 19387: BNE PROFS,PRLEN,PRCH1 JUMP IF ROOM IN BUFFER ! 19388: JSR PRTNL ELSE PRINT THIS LINE ! 19389: * ! 19390: * HERE AFTER MAKING SURE WE HAVE ROOM ! 19391: * ! 19392: PRCH1 MOV PRBUF,XR POINT TO PRINT BUFFER ! 19393: PSC XR,PROFS POINT TO NEXT CHARACTER LOCATION ! 19394: SCH WA,(XR) STORE NEW CHARACTER ! 19395: CSC XR COMPLETE STORE CHARACTERS ! 19396: ICV PROFS BUMP POINTER ! 19397: MOV (XS)+,XR RESTORE ENTRY XR ! 19398: EXI RETURN TO PRTCH CALLER ! 19399: ENP END PROCEDURE PRTCH ! 19400: EJC ! 19401: * ! 19402: * PRTIC -- PRINT TO INTERACTIVE CHANNEL ! 19403: * ! 19404: * PRTIC IS CALLED TO PRINT THE CONTENTS OF THE STANDARD ! 19405: * PRINT BUFFER TO THE INTERACTIVE CHANNEL. IT IS ONLY ! 19406: * CALLED AFTER PRTST HAS SET UP THE STRING FOR PRINTING. ! 19407: * IT DOES NOT CLEAR THE BUFFER. ! 19408: * ! 19409: * JSR PRTIC CALL FOR PRINT ! 19410: * (WA,WB) DESTROYED ! 19411: * ! 19412: PRTIC PRC E,0 ENTRY POINT ! 19413: MOV XR,-(XS) SAVE XR ! 19414: MOV PRBUF,XR POINT TO BUFFER ! 19415: MOV PROFS,WA NO OF CHARS ! 19416: JSR SYSPI PRINT ! 19417: PPM PRTC2 FAIL RETURN ! 19418: * ! 19419: * RETURN ! 19420: * ! 19421: PRTC1 MOV (XS)+,XR RESTORE XR ! 19422: EXI RETURN ! 19423: * ! 19424: * ERROR OCCURED ! 19425: * ! 19426: PRTC2 ZER ERICH PREVENT LOOPING ! 19427: ERB 252,ERROR ON PRINTING TO INTERACTIVE CHANNEL ! 19428: BRN PRTC1 RETURN ! 19429: ENP PROCEDURE PRTIC ! 19430: EJC ! 19431: * ! 19432: * PRTIS -- PRINT TO INTERACTIVE AND STANDARD PRINTER ! 19433: * ! 19434: * PRTIS PUTS A LINE FROM THE PRINT BUFFER ONTO THE ! 19435: * INTERACTIVE CHANNEL (IF ANY) AND THE STANDARD PRINTER. ! 19436: * IT ALWAYS PRINTS TO THE STANDARD PRINTER BUT DOES ! 19437: * NOT DUPLICATE LINES IF THE STANDARD PRINTER IS ! 19438: * INTERACTIVE. IT CLEARS DOWN THE PRINT BUFFER. ! 19439: * ! 19440: * JSR PRTIS CALL FOR PRINTING ! 19441: * (WA,WB) DESTROYED ! 19442: * ! 19443: PRTIS PRC E,0 ENTRY POINT ! 19444: BNZ PRICH,PRTS1 JUMP IF STANDARD PRINTER IS INT.CH. ! 19445: BZE ERICH,PRTS1 SKIP IF NOT DOING INT. ERROR REPS. ! 19446: JSR PRTIC PRINT TO INTERACTIVE CHANNEL ! 19447: * ! 19448: * MERGE AND EXIT ! 19449: * ! 19450: PRTS1 JSR PRTNL PRINT TO STANDARD PRINTER ! 19451: EXI RETURN ! 19452: ENP END PROCEDURE PRTIS ! 19453: EJC ! 19454: * ! 19455: * PRTIN -- PRINT AN INTEGER ! 19456: * ! 19457: * PRTIN PRINTS THE INTEGER VALUE WHICH IS IN THE INTEGER ! 19458: * ACCUMULATOR. BLOCKS BUILT IN DYNAMIC STORAGE ! 19459: * DURING THIS PROCESS ARE IMMEDIATELY DELETED. ! 19460: * ! 19461: * (IA) INTEGER VALUE TO BE PRINTED ! 19462: * JSR PRTIN CALL TO PRINT INTEGER ! 19463: * (IA,RA) DESTROYED ! 19464: * ! 19465: PRTIN PRC E,0 ENTRY POINT ! 19466: MOV XR,-(XS) SAVE XR ! 19467: JSR ICBLD BUILD INTEGER BLOCK ! 19468: BLO XR,DNAMB,PRTI1 JUMP IF ICBLK BELOW DYNAMIC ! 19469: BHI XR,DNAMP,PRTI1 JUMP IF ABOVE DYNAMIC ! 19470: MOV XR,DNAMP IMMEDIATELY DELETE IT ! 19471: * ! 19472: * DELETE ICBLK FROM DYNAMIC STORE ! 19473: * ! 19474: PRTI1 MOV XR,-(XS) STACK PTR FOR GTSTG ! 19475: JSR GTSTG CONVERT TO STRING ! 19476: PPM CONVERT ERROR IS IMPOSSIBLE ! 19477: MOV XR,DNAMP RESET POINTER TO DELETE SCBLK ! 19478: JSR PRTST PRINT INTEGER STRING ! 19479: MOV (XS)+,XR RESTORE ENTRY XR ! 19480: EXI RETURN TO PRTIN CALLER ! 19481: ENP END PROCEDURE PRTIN ! 19482: EJC ! 19483: * ! 19484: * PRTMI -- PRINT MESSAGE AND INTEGER ! 19485: * ! 19486: * PRTMI IS USED TO PRINT MESSAGES TOGETHER WITH AN INTEGER ! 19487: * VALUE STARTING IN COLUMN 15 (USED BY THE ROUTINES AT ! 19488: * THE END OF COMPILATION). ! 19489: * ! 19490: * JSR PRTMI CALL TO PRINT MESSAGE AND INTEGER ! 19491: * ! 19492: PRTMI PRC E,0 ENTRY POINT ! 19493: JSR PRTST PRINT STRING MESSAGE ! 19494: MOV =PRTMF,PROFS SET OFFSET TO COL 15 ! 19495: JSR PRTIN PRINT INTEGER ! 19496: JSR PRTNL PRINT LINE ! 19497: EXI RETURN TO PRTMI CALLER ! 19498: ENP END PROCEDURE PRTMI ! 19499: EJC ! 19500: * ! 19501: * PRTMX -- AS PRTMI WITH EXTRA COPY TO INTERACTIVE CHAN. ! 19502: * ! 19503: * JSR PRTMX CALL FOR PRINTING ! 19504: * (WA,WB) DESTROYED ! 19505: * ! 19506: PRTMX PRC E,0 ENTRY POINT ! 19507: JSR PRTST PRINT STRING MESSAGE ! 19508: MOV =PRTMF,PROFS SET PTR TO COLUMN 15 ! 19509: JSR PRTIN PRINT INTEGER ! 19510: JSR PRTIS PRINT LINE ! 19511: EXI RETURN ! 19512: ENP END PROCEDURE PRTMX ! 19513: EJC ! 19514: * ! 19515: * PRTNL -- PRINT NEW LINE (END PRINT LINE) ! 19516: * ! 19517: * PRTNL PRINTS THE CONTENTS OF THE PRINT BUFFER, RESETS ! 19518: * THE BUFFER TO ALL BLANKS AND RESETS THE PRINT POINTER. ! 19519: * ! 19520: * JSR PRTNL CALL TO PRINT LINE ! 19521: * ! 19522: PRTNL PRC R,0 ENTRY POINT ! 19523: BNZ HEADP,PRNL0 WERE HEADERS PRINTED ! 19524: JSR PRTPS NO - PRINT THEM ! 19525: * ! 19526: * CALL SYSPR ! 19527: * ! 19528: PRNL0 MOV XR,-(XS) SAVE ENTRY XR ! 19529: MOV WA,PRTSA SAVE WA ! 19530: MOV WB,PRTSB SAVE WB ! 19531: MOV PRBUF,XR LOAD POINTER TO BUFFER ! 19532: MOV PROFS,WA LOAD NUMBER OF CHARS IN BUFFER ! 19533: JSR SYSPR CALL SYSTEM PRINT ROUTINE ! 19534: PPM PRNL2 JUMP IF FAILED ! 19535: LCT WA,PRLNW LOAD LENGTH OF BUFFER IN WORDS ! 19536: ADD *SCHAR,XR POINT TO CHARS OF BUFFER ! 19537: MOV NULLW,WB GET WORD OF BLANKS ! 19538: * ! 19539: * LOOP TO BLANK BUFFER ! 19540: * ! 19541: PRNL1 MOV WB,(XR)+ STORE WORD OF BLANKS, BUMP PTR ! 19542: BCT WA,PRNL1 LOOP TILL ALL BLANKED ! 19543: * ! 19544: * EXIT POINT ! 19545: * ! 19546: MOV PRTSB,WB RESTORE WB ! 19547: MOV PRTSA,WA RESTORE WA ! 19548: MOV (XS)+,XR RESTORE ENTRY XR ! 19549: ZER PROFS RESET PRINT BUFFER POINTER ! 19550: EXI RETURN TO PRTNL CALLER ! 19551: * ! 19552: * FILE FULL OR NO OUTPUT FILE FOR LOAD MODULE ! 19553: * ! 19554: PRNL2 BNZ PRTEF,PRNL3 JUMP IF NOT FIRST TIME ! 19555: MNZ PRTEF MARK FIRST OCCURRENCE ! 19556: ERB 253,PRINT LIMIT EXCEEDED ON STANDARD OUTPUT CHANNEL ! 19557: * ! 19558: * STOP AT ONCE ! 19559: * ! 19560: PRNL3 MOV =NINI8,WB ENDING CODE ! 19561: MOV KVSTN,WA STATEMENT NUMBER ! 19562: JSR SYSEJ STOP ! 19563: ENP END PROCEDURE PRTNL ! 19564: EJC ! 19565: * ! 19566: * PRTNM -- PRINT VARIABLE NAME ! 19567: * ! 19568: * PRTNM IS USED TO PRINT A CHARACTER REPRESENTATION OF THE ! 19569: * NAME OF A VARIABLE (NOT A VALUE OF DATATYPE NAME) ! 19570: * NAMES OF PSEUDO-VARIABLES MAY NOT BE PASSED TO PRTNM. ! 19571: * ! 19572: * (XL) NAME BASE ! 19573: * (WA) NAME OFFSET ! 19574: * JSR PRTNM CALL TO PRINT NAME ! 19575: * (WB,WC,RA) DESTROYED ! 19576: * ! 19577: PRTNM PRC R,0 ENTRY POINT (RECURSIVE, SEE PRTVL) ! 19578: MOV WA,-(XS) SAVE WA (OFFSET IS COLLECTABLE) ! 19579: MOV XR,-(XS) SAVE ENTRY XR ! 19580: MOV XL,-(XS) SAVE NAME BASE ! 19581: BHI XL,STATE,PRN02 JUMP IF NOT NATURAL VARIABLE ! 19582: * ! 19583: * HERE FOR NATURAL VARIABLE NAME, RECOGNIZED BY THE FACT ! 19584: * THAT THE NAME BASE POINTS INTO THE STATIC AREA. ! 19585: * ! 19586: MOV XL,XR POINT TO VRBLK ! 19587: JSR PRTVN PRINT NAME OF VARIABLE ! 19588: * ! 19589: * COMMON EXIT POINT ! 19590: * ! 19591: PRN01 MOV (XS)+,XL RESTORE NAME BASE ! 19592: MOV (XS)+,XR RESTORE ENTRY VALUE OF XR ! 19593: MOV (XS)+,WA RESTORE WA ! 19594: EXI RETURN TO PRTNM CALLER ! 19595: * ! 19596: * HERE FOR CASE OF NON-NATURAL VARIABLE ! 19597: * ! 19598: PRN02 MOV WA,WB COPY NAME OFFSET ! 19599: BNE (XL),=B$PDT,PRN03 JUMP IF ARRAY OR TABLE ! 19600: * ! 19601: * FOR PROGRAM DEFINED DATATYPE, PRT FLD NAME, LEFT PAREN ! 19602: * ! 19603: MOV PDDFP(XL),XR LOAD POINTER TO DFBLK ! 19604: ADD WA,XR ADD NAME OFFSET ! 19605: MOV PDFOF(XR),XR LOAD VRBLK POINTER FOR FIELD ! 19606: JSR PRTVN PRINT FIELD NAME ! 19607: MOV =CH$PP,WA LOAD LEFT PAREN ! 19608: JSR PRTCH PRINT CHARACTER ! 19609: EJC ! 19610: * ! 19611: * PRTNM (CONTINUED) ! 19612: * ! 19613: * NOW WE PRINT AN IDENTIFYING NAME FOR THE OBJECT IF ONE ! 19614: * CAN BE FOUND. THE FOLLOWING CODE SEARCHES FOR A NATURAL ! 19615: * VARIABLE WHICH CONTAINS THIS OBJECT AS VALUE. IF SUCH A ! 19616: * VARIABLE IS FOUND, ITS NAME IS PRINTED, ELSE THE VALUE ! 19617: * OF THE OBJECT (AS PRINTED BY PRTVL) IS USED INSTEAD. ! 19618: * ! 19619: * FIRST WE POINT TO THE PARENT TBBLK IF THIS IS THE CASE OF ! 19620: * A TABLE ELEMENT. TO DO THIS, CHASE DOWN THE TRNXT CHAIN. ! 19621: * ! 19622: PRN03 BNE (XL),=B$TET,PRN04 JUMP IF WE GOT THERE (OR NOT TE) ! 19623: MOV TENXT(XL),XL ELSE MOVE OUT ON CHAIN ! 19624: BRN PRN03 AND LOOP BACK ! 19625: * ! 19626: * NOW WE ARE READY FOR THE SEARCH. TO SPEED THINGS UP IN ! 19627: * THE CASE OF CALLS FROM DUMP WHERE THE SAME NAME BASE ! 19628: * WILL OCCUR REPEATEDLY WHILE DUMPING AN ARRAY OR TABLE, ! 19629: * WE REMEMBER THE LAST VRBLK POINTER FOUND IN PRNMV. SO ! 19630: * FIRST CHECK TO SEE IF WE HAVE THIS ONE AGAIN. ! 19631: * ! 19632: PRN04 MOV PRNMV,XR POINT TO VRBLK WE FOUND LAST TIME ! 19633: MOV HSHTB,WA POINT TO HASH TABLE IN CASE NOT ! 19634: BRN PRN07 JUMP INTO SEARCH FOR SPECIAL CHECK ! 19635: * ! 19636: * LOOP THROUGH HASH SLOTS ! 19637: * ! 19638: PRN05 MOV WA,XR COPY SLOT POINTER ! 19639: ICA WA BUMP SLOT POINTER ! 19640: SUB *VRNXT,XR INTRODUCE STANDARD VRBLK OFFSET ! 19641: * ! 19642: * LOOP THROUGH VRBLKS ON ONE HASH CHAIN ! 19643: * ! 19644: PRN06 MOV VRNXT(XR),XR POINT TO NEXT VRBLK ON HASH CHAIN ! 19645: * ! 19646: * MERGE HERE FIRST TIME TO CHECK BLOCK WE FOUND LAST TIME ! 19647: * ! 19648: PRN07 MOV XR,WC COPY VRBLK POINTER ! 19649: BZE WC,PRN09 JUMP IF CHAIN END (OR PRNMV ZERO) ! 19650: EJC ! 19651: * ! 19652: * PRTNM (CONTINUED) ! 19653: * ! 19654: * LOOP TO FIND VALUE (CHASE DOWN POSSIBLE TRBLK CHAIN) ! 19655: * ! 19656: PRN08 MOV VRVAL(XR),XR LOAD VALUE ! 19657: BEQ (XR),=B$TRT,PRN08 LOOP IF THAT WAS A TRBLK ! 19658: * ! 19659: * NOW WE HAVE THE VALUE, IS THIS THE BLOCK WE WANT ! 19660: * ! 19661: BEQ XR,XL,PRN10 JUMP IF THIS MATCHES THE NAME BASE ! 19662: MOV WC,XR ELSE POINT BACK TO THAT VRBLK ! 19663: BRN PRN06 AND LOOP BACK ! 19664: * ! 19665: * HERE TO MOVE TO NEXT HASH SLOT ! 19666: * ! 19667: PRN09 BLT WA,HSHTE,PRN05 LOOP BACK IF MORE TO GO ! 19668: MOV XL,XR ELSE NOT FOUND, COPY VALUE POINTER ! 19669: JSR PRTVL PRINT VALUE ! 19670: BRN PRN11 AND MERGE AHEAD ! 19671: * ! 19672: * HERE WHEN WE FIND A MATCHING ENTRY ! 19673: * ! 19674: PRN10 MOV WC,XR COPY VRBLK POINTER ! 19675: MOV XR,PRNMV SAVE FOR NEXT TIME IN ! 19676: JSR PRTVN PRINT VARIABLE NAME ! 19677: * ! 19678: * MERGE HERE IF NO ENTRY FOUND ! 19679: * ! 19680: PRN11 MOV (XL),WC LOAD FIRST WORD OF NAME BASE ! 19681: BNE WC,=B$PDT,PRN13 JUMP IF NOT PROGRAM DEFINED ! 19682: * ! 19683: * FOR PROGRAM DEFINED DATATYPE, ADD RIGHT PAREN AND EXIT ! 19684: * ! 19685: MOV =CH$RP,WA LOAD RIGHT PAREN, MERGE ! 19686: * ! 19687: * MERGE HERE TO PRINT FINAL RIGHT PAREN OR BRACKET ! 19688: * ! 19689: PRN12 JSR PRTCH PRINT FINAL CHARACTER ! 19690: MOV WB,WA RESTORE NAME OFFSET ! 19691: BRN PRN01 MERGE BACK TO EXIT ! 19692: EJC ! 19693: * ! 19694: * PRTNM (CONTINUED) ! 19695: * ! 19696: * HERE FOR ARRAY OR TABLE ! 19697: * ! 19698: PRN13 MOV =CH$BB,WA LOAD LEFT BRACKET ! 19699: JSR PRTCH AND PRINT IT ! 19700: MOV (XS),XL RESTORE BLOCK POINTER ! 19701: MOV (XL),WC LOAD TYPE WORD AGAIN ! 19702: BNE WC,=B$TET,PRN15 JUMP IF NOT TABLE ! 19703: * ! 19704: * HERE FOR TABLE, PRINT SUBSCRIPT VALUE ! 19705: * ! 19706: MOV TESUB(XL),XR LOAD SUBSCRIPT VALUE ! 19707: MOV WB,XL SAVE NAME OFFSET ! 19708: JSR PRTVL PRINT SUBSCRIPT VALUE ! 19709: MOV XL,WB RESTORE NAME OFFSET ! 19710: * ! 19711: * MERGE HERE FROM ARRAY CASE TO PRINT RIGHT BRACKET ! 19712: * ! 19713: PRN14 MOV =CH$RB,WA LOAD RIGHT BRACKET ! 19714: BRN PRN12 MERGE BACK TO PRINT IT ! 19715: * ! 19716: * HERE FOR ARRAY OR VECTOR, TO PRINT SUBSCRIPT(S) ! 19717: * ! 19718: PRN15 MOV WB,WA COPY NAME OFFSET ! 19719: BTW WA CONVERT TO WORDS ! 19720: BEQ WC,=B$ART,PRN16 JUMP IF ARBLK ! 19721: * ! 19722: * HERE FOR VECTOR ! 19723: * ! 19724: SUB =VCVLB,WA ADJUST FOR STANDARD FIELDS ! 19725: MTI WA MOVE TO INTEGER ACCUM ! 19726: JSR PRTIN PRINT LINEAR SUBSCRIPT ! 19727: BRN PRN14 MERGE BACK FOR RIGHT BRACKET ! 19728: EJC ! 19729: * ! 19730: * PRTNM (CONTINUED) ! 19731: * ! 19732: * HERE FOR ARRAY. FIRST CALCULATE ABSOLUTE SUBSCRIPT ! 19733: * OFFSETS BY SUCCESSIVE DIVISIONS BY THE DIMENSION VALUES. ! 19734: * THIS MUST BE DONE RIGHT TO LEFT SINCE THE ELEMENTS ARE ! 19735: * STORED ROW-WISE. THE SUBSCRIPTS ARE STACKED AS INTEGERS. ! 19736: * ! 19737: PRN16 MOV AROFS(XL),WC LOAD LENGTH OF BOUNDS INFO ! 19738: ICA WC ADJUST FOR ARPRO FIELD ! 19739: BTW WC CONVERT TO WORDS ! 19740: SUB WC,WA GET LINEAR ZERO-ORIGIN SUBSCRIPT ! 19741: MTI WA GET INTEGER VALUE ! 19742: LCT WA,ARNDM(XL) SET NUM OF DIMENSIONS AS LOOP COUNT ! 19743: ADD AROFS(XL),XL POINT PAST BOUNDS INFORMATION ! 19744: SUB *ARLBD,XL SET OK OFFSET FOR PROPER PTR LATER ! 19745: * ! 19746: * LOOP TO STACK SUBSCRIPT OFFSETS ! 19747: * ! 19748: PRN17 SUB *ARDMS,XL POINT TO NEXT SET OF BOUNDS ! 19749: STI PRNSI SAVE CURRENT OFFSET ! 19750: RMI ARDIM(XL) GET REMAINDER ON DIVIDING BY DIMENS ! 19751: MFI -(XS) STORE ON STACK (ONE WORD) ! 19752: LDI PRNSI RELOAD ARGUMENT ! 19753: DVI ARDIM(XL) DIVIDE TO GET QUOTIENT ! 19754: BCT WA,PRN17 LOOP TILL ALL STACKED ! 19755: ZER XR SET OFFSET TO FIRST SET OF BOUNDS ! 19756: LCT WB,ARNDM(XL) LOAD COUNT OF DIMS TO CONTROL LOOP ! 19757: BRN PRN19 JUMP INTO PRINT LOOP ! 19758: * ! 19759: * LOOP TO PRINT SUBSCRIPTS FROM STACK ADJUSTING BY ADDING ! 19760: * THE APPROPRIATE LOW BOUND VALUE FROM THE ARBLK ! 19761: * ! 19762: PRN18 MOV =CH$CM,WA LOAD A COMMA ! 19763: JSR PRTCH PRINT IT ! 19764: * ! 19765: * MERGE HERE FIRST TIME IN (NO COMMA REQUIRED) ! 19766: * ! 19767: PRN19 MTI (XS)+ LOAD SUBSCRIPT OFFSET AS INTEGER ! 19768: ADD XR,XL POINT TO CURRENT LBD ! 19769: ADI ARLBD(XL) ADD LBD TO GET SIGNED SUBSCRIPT ! 19770: SUB XR,XL POINT BACK TO START OF ARBLK ! 19771: JSR PRTIN PRINT SUBSCRIPT ! 19772: ADD *ARDMS,XR BUMP OFFSET TO NEXT BOUNDS ! 19773: BCT WB,PRN18 LOOP BACK TILL ALL PRINTED ! 19774: BRN PRN14 MERGE BACK TO PRINT RIGHT BRACKET ! 19775: ENP END PROCEDURE PRTNM ! 19776: EJC ! 19777: * ! 19778: * PRTNV -- PRINT NAME VALUE ! 19779: * ! 19780: * PRTNV IS USED BY THE TRACE AND DUMP ROUTINES TO PRINT ! 19781: * A LINE OF THE FORM ! 19782: * ! 19783: * NAME = VALUE ! 19784: * ! 19785: * NOTE THAT THE NAME INVOLVED CAN NEVER BE A PSEUDO-VAR ! 19786: * ! 19787: * (XL) NAME BASE ! 19788: * (WA) NAME OFFSET ! 19789: * JSR PRTNV CALL TO PRINT NAME = VALUE ! 19790: * (WB,WC,RA) DESTROYED ! 19791: * ! 19792: PRTNV PRC E,0 ENTRY POINT ! 19793: JSR PRTNM PRINT ARGUMENT NAME ! 19794: MOV XR,-(XS) SAVE ENTRY XR ! 19795: MOV WA,-(XS) SAVE NAME OFFSET (COLLECTABLE) ! 19796: MOV =TMBEB,XR POINT TO BLANK EQUAL BLANK ! 19797: JSR PRTST PRINT IT ! 19798: MOV XL,XR COPY NAME BASE ! 19799: ADD WA,XR POINT TO VALUE ! 19800: MOV (XR),XR LOAD VALUE POINTER ! 19801: JSR PRTVL PRINT VALUE ! 19802: JSR PRTNL TERMINATE LINE ! 19803: MOV (XS)+,WA RESTORE NAME OFFSET ! 19804: MOV (XS)+,XR RESTORE ENTRY XR ! 19805: EXI RETURN TO CALLER ! 19806: ENP END PROCEDURE PRTNV ! 19807: EJC ! 19808: * ! 19809: * PRTPG -- PRINT A PAGE THROW ! 19810: * ! 19811: * PRINTS A PAGE THROW OR A FEW BLANK LINES ON THE STANDARD ! 19812: * LISTING CHANNEL DEPENDING ON THE LISTING OPTIONS CHOSEN. ! 19813: * ! 19814: * JSR PRTPG CALL FOR PAGE EJECT ! 19815: * ! 19816: PRTPG PRC E,0 ENTRY POINT ! 19817: BEQ STAGE,=STGXT,PRP01 JUMP IF EXECUTION TIME ! 19818: BZE LSTLC,PRP06 RETURN IF TOP OF PAGE ALREADY ! 19819: ZER LSTLC CLEAR LINE COUNT ! 19820: * ! 19821: * CHECK TYPE OF LISTING ! 19822: * ! 19823: PRP01 MOV XR,-(XS) PRESERVE XR ! 19824: BNZ PRSTD,PRP02 EJECT IF FLAG SET ! 19825: BNZ PRICH,PRP03 JUMP IF INTERACTIVE LISTING CHANNEL ! 19826: BZE PRECL,PRP03 JUMP IF COMPACT LISTING ! 19827: * ! 19828: * PERFORM AN EJECT ! 19829: * ! 19830: PRP02 JSR SYSEP EJECT ! 19831: BRN PRP04 MERGE ! 19832: * ! 19833: * COMPACT OR INTERACTIVE CHANNEL LISTING. CANT PRINT ! 19834: * BLANKS UNTIL CHECK MADE FOR HEADERS PRINTED AND FLAG SET. ! 19835: * ! 19836: * ! 19837: PRP03 MOV HEADP,XR REMEMBER HEADP ! 19838: MNZ HEADP SET TO AVOID REPEATED PRTPG CALLS ! 19839: JSR PRTNL PRINT BLANK LINE ! 19840: JSR PRTNL PRINT BLANK LINE ! 19841: JSR PRTNL PRINT BLANK LINE ! 19842: MOV =NUM03,LSTLC COUNT BLANK LINES ! 19843: MOV XR,HEADP RESTORE HEADER FLAG ! 19844: EJC ! 19845: * ! 19846: * PRPTG (CONTINUED) ! 19847: * ! 19848: * PRINT THE HEADING ! 19849: * ! 19850: PRP04 BNZ HEADP,PRP05 JUMP IF HEADER LISTED ! 19851: MNZ HEADP MARK HEADERS PRINTED ! 19852: MOV XL,-(XS) KEEP XL ! 19853: MOV =HEADR,XR POINT TO LISTING HEADER ! 19854: JSR PRTST PLACE IT ! 19855: JSR SYSID GET SYSTEM IDENTIFICATION ! 19856: JSR PRTST APPEND EXTRA CHARS ! 19857: JSR PRTNL PRINT IT ! 19858: MOV XL,XR EXTRA HEADER LINE ! 19859: JSR PRTST PLACE IT ! 19860: JSR PRTNL PRINT IT ! 19861: JSR PRTNL PRINT A BLANK ! 19862: JSR PRTNL AND ANOTHER ! 19863: ADD =NUM04,LSTLC FOUR HEADER LINES PRINTED ! 19864: MOV (XS)+,XL RESTORE XL ! 19865: * ! 19866: * MERGE IF HEADER NOT PRINTED ! 19867: * ! 19868: PRP05 MOV (XS)+,XR RESTORE XR ! 19869: * ! 19870: * RETURN ! 19871: * ! 19872: PRP06 EXI RETURN ! 19873: ENP END PROCEDURE PRTPG ! 19874: EJC ! 19875: * ! 19876: * PRTPS - PRINT PAGE WITH TEST FOR STANDARD LISTING OPTION ! 19877: * ! 19878: * IF THE STANDARD LISTING OPTION IS SELECTED, INSIST THAT ! 19879: * AN EJECT BE DONE ! 19880: * ! 19881: * JSR PRTPS CALL FOR EJECT ! 19882: * ! 19883: PRTPS PRC E,0 ENTRY POINT ! 19884: MOV PRSTO,PRSTD COPY OPTION FLAG ! 19885: JSR PRTPG PRINT PAGE ! 19886: ZER PRSTD CLEAR FLAG ! 19887: EXI RETURN ! 19888: ENP END PROCEDURE PRTPS ! 19889: EJC ! 19890: * ! 19891: * PRTSN -- PRINT STATEMENT NUMBER ! 19892: * ! 19893: * PRTSN IS USED TO INITIATE A PRINT TRACE LINE BY PRINTING ! 19894: * ASTERISKS AND THE CURRENT STATEMENT NUMBER. THE ACTUAL ! 19895: * FORMAT OF THE OUTPUT GENERATED IS. ! 19896: * ! 19897: * ***NNNNN**** III.....IIII ! 19898: * ! 19899: * NNNNN IS THE STATEMENT NUMBER WITH LEADING ZEROS REPLACED ! 19900: * BY ASTERISKS (E.G. *******9****) ! 19901: * ! 19902: * III...III REPRESENTS A VARIABLE LENGTH OUTPUT CONSISTING ! 19903: * OF A NUMBER OF LETTER I CHARACTERS EQUAL TO FNCLEVEL. ! 19904: * ! 19905: * JSR PRTSN CALL TO PRINT STATEMENT NUMBER ! 19906: * (WC) DESTROYED ! 19907: * ! 19908: PRTSN PRC E,0 ENTRY POINT ! 19909: MOV XR,-(XS) SAVE ENTRY XR ! 19910: MOV WA,PRSNA SAVE ENTRY WA ! 19911: MOV =TMASB,XR POINT TO ASTERISKS ! 19912: JSR PRTST PRINT ASTERISKS ! 19913: MOV =NUM04,PROFS POINT INTO MIDDLE OF ASTERISKS ! 19914: MTI KVSTN LOAD STATEMENT NUMBER AS INTEGER ! 19915: JSR PRTIN PRINT INTEGER STATEMENT NUMBER ! 19916: MOV =PRSNF,PROFS POINT PAST ASTERISKS PLUS BLANK ! 19917: MOV KVFNC,XR GET FNCLEVEL ! 19918: MOV =CH$LI,WA SET LETTER I ! 19919: * ! 19920: * LOOP TO GENERATE LETTER I FNCLEVEL TIMES ! 19921: * ! 19922: PRSN1 BZE XR,PRSN2 JUMP IF ALL SET ! 19923: JSR PRTCH ELSE PRINT AN I ! 19924: DCV XR DECREMENT COUNTER ! 19925: BRN PRSN1 LOOP BACK ! 19926: * ! 19927: * MERRE WITH ALL LETTER I CHARACTERS GENERATED ! 19928: * ! 19929: PRSN2 MOV =CH$BL,WA GET BLANK ! 19930: JSR PRTCH PRINT BLANK ! 19931: MOV PRSNA,WA RESTORE ENTRY WA ! 19932: MOV (XS)+,XR RESTORE ENTRY XR ! 19933: EXI RETURN TO PRTSN CALLER ! 19934: ENP END PROCEDURE PRTSN ! 19935: EJC ! 19936: * ! 19937: * PRTST -- PRINT STRING ! 19938: * ! 19939: * PRTST PLACES A STRING OF CHARACTERS IN THE PRINT BUFFER ! 19940: * ! 19941: * SEE PRTNL FOR GLOBAL LOCATIONS USED ! 19942: * ! 19943: * NOTE THAT THE FIRST WORD OF THE BLOCK (NORMALLY B$SCL) ! 19944: * IS NOT USED AND NEED NOT BE SET CORRECTLY (SEE PRTVN) ! 19945: * ! 19946: * (XR) STRING TO BE PRINTED ! 19947: * JSR PRTST CALL TO PRINT STRING ! 19948: * (PROFS) UPDATED PAST CHARS PLACED ! 19949: * ! 19950: PRTST PRC R,0 ENTRY POINT ! 19951: BNZ HEADP,PRST0 WERE HEADERS PRINTED ! 19952: JSR PRTPS NO - PRINT THEM ! 19953: * ! 19954: * CALL SYSPR ! 19955: * ! 19956: PRST0 MOV WA,PRSVA SAVE WA ! 19957: MOV WB,PRSVB SAVE WB ! 19958: ZER WB SET CHARS PRINTED COUNT TO ZERO ! 19959: * ! 19960: * LOOP TO PRINT SUCCESSIVE LINES FOR LONG STRING ! 19961: * ! 19962: PRST1 MOV SCLEN(XR),WA LOAD STRING LENGTH ! 19963: SUB WB,WA SUBTRACT COUNT OF CHARS ALREADY OUT ! 19964: BZE WA,PRST4 JUMP TO EXIT IF NONE LEFT ! 19965: MOV XL,-(XS) ELSE STACK ENTRY XL ! 19966: MOV XR,-(XS) SAVE ARGUMENT ! 19967: MOV XR,XL COPY FOR EVENTUAL MOVE ! 19968: MOV PRLEN,XR LOAD PRINT BUFFER LENGTH ! 19969: SUB PROFS,XR GET CHARS LEFT IN PRINT BUFFER ! 19970: BNZ XR,PRST2 SKIP IF ROOM LEFT ON THIS LINE ! 19971: JSR PRTNL ELSE PRINT THIS LINE ! 19972: MOV PRLEN,XR AND SET FULL WIDTH AVAILABLE ! 19973: EJC ! 19974: * ! 19975: * PRTST (CONTINUED) ! 19976: * ! 19977: * HERE WITH CHARS TO PRINT AND SOME ROOM IN BUFFER ! 19978: * ! 19979: PRST2 BLO WA,XR,PRST3 JUMP IF ROOM FOR REST OF STRING ! 19980: MOV XR,WA ELSE SET TO FILL LINE ! 19981: * ! 19982: * MERGE HERE WITH CHARACTER COUNT IN WA ! 19983: * ! 19984: PRST3 MOV PRBUF,XR POINT TO PRINT BUFFER ! 19985: PLC XL,WB POINT TO LOCATION IN STRING ! 19986: PSC XR,PROFS POINT TO LOCATION IN BUFFER ! 19987: ADD WA,WB BUMP STRING CHARS COUNT ! 19988: ADD WA,PROFS BUMP BUFFER POINTER ! 19989: MOV WB,PRSVC PRESERVE CHAR COUNTER ! 19990: MVC MOVE CHARACTERS TO BUFFER ! 19991: MOV PRSVC,WB RECOVER CHAR COUNTER ! 19992: MOV (XS)+,XR RESTORE ARGUMENT POINTER ! 19993: MOV (XS)+,XL RESTORE ENTRY XL ! 19994: BRN PRST1 LOOP BACK TO TEST FOR MORE ! 19995: * ! 19996: * HERE TO EXIT AFTER PRINTING STRING ! 19997: * ! 19998: PRST4 MOV PRSVB,WB RESTORE ENTRY WB ! 19999: MOV PRSVA,WA RESTORE ENTRY WA ! 20000: EXI RETURN TO PRTST CALLER ! 20001: ENP END PROCEDURE PRTST ! 20002: EJC ! 20003: * ! 20004: * PRTTR -- PRINT TO TERMINAL ! 20005: * ! 20006: * CALLED TO PRINT CONTENTS OF STANDARD PRINT BUFFER TO ! 20007: * ONLINE TERMINAL. CLEARS BUFFER DOWN AND RESETS PROFS. ! 20008: * ! 20009: * JSR PRTTR CALL FOR PRINT ! 20010: * (WA,WB) DESTROYED ! 20011: * ! 20012: PRTTR PRC E,0 ENTRY POINT ! 20013: MOV XR,-(XS) SAVE XR ! 20014: JSR PRTIC PRINT BUFFER CONTENTS ! 20015: MOV PRBUF,XR POINT TO PRINT BFR TO CLEAR IT ! 20016: LCT WA,PRLNW GET BUFFER LENGTH ! 20017: ADD *SCHAR,XR POINT PAST SCBLK HEADER ! 20018: MOV NULLW,WB GET BLANKS ! 20019: * ! 20020: * LOOP TO CLEAR BUFFER ! 20021: * ! 20022: PRTT1 MOV WB,(XR)+ CLEAR A WORD ! 20023: BCT WA,PRTT1 LOOP ! 20024: ZER PROFS RESET PROFS ! 20025: MOV (XS)+,XR RESTORE XR ! 20026: EXI RETURN ! 20027: ENP END PROCEDURE PRTTR ! 20028: EJC ! 20029: * ! 20030: * PRTVL -- PRINT A VALUE ! 20031: * ! 20032: * PRTVL PLACES AN APPROPRIATE CHARACTER REPRESENTATION OF ! 20033: * A DATA VALUE IN THE PRINT BUFFER FOR DUMP/TRACE USE. ! 20034: * ! 20035: * (XR) VALUE TO BE PRINTED ! 20036: * JSR PRTVL CALL TO PRINT VALUE ! 20037: * (WA,WB,WC,RA) DESTROYED ! 20038: * ! 20039: PRTVL PRC R,0 ENTRY POINT, RECURSIVE ! 20040: MOV XL,-(XS) SAVE ENTRY XL ! 20041: MOV XR,-(XS) SAVE ARGUMENT ! 20042: CHK CHECK FOR STACK OVERFLOW ! 20043: * ! 20044: * LOOP BACK HERE AFTER FINDING A TRAP BLOCK (TRBLK) ! 20045: * ! 20046: PRV01 MOV IDVAL(XR),PRVSI COPY IDVAL (IF ANY) ! 20047: MOV (XR),XL LOAD FIRST WORD OF BLOCK ! 20048: LEI XL LOAD ENTRY POINT ID ! 20049: BSW XL,BL$$T,PRV02 SWITCH ON BLOCK TYPE ! 20050: IFF BL$TR,PRV04 TRBLK ! 20051: IFF BL$AR,PRV05 ARBLK ! 20052: IFF BL$IC,PRV08 ICBLK ! 20053: IFF BL$NM,PRV09 NMBLK ! 20054: IFF BL$PD,PRV10 PDBLK ! 20055: IFF BL$RC,PRV08 RCBLK ! 20056: IFF BL$SC,PRV11 SCBLK ! 20057: IFF BL$SE,PRV12 SEBLK ! 20058: IFF BL$TB,PRV13 TBBLK ! 20059: IFF BL$VC,PRV13 VCBLK ! 20060: IFF BL$BC,PRV15 BCBLK ! 20061: ESW END OF SWITCH ON BLOCK TYPE ! 20062: * ! 20063: * HERE FOR BLOCKS FOR WHICH WE JUST PRINT DATATYPE NAME ! 20064: * ! 20065: PRV02 JSR DTYPE GET DATATYPE NAME ! 20066: JSR PRTST PRINT DATATYPE NAME ! 20067: * ! 20068: * COMMON EXIT POINT ! 20069: * ! 20070: PRV03 MOV (XS)+,XR RELOAD ARGUMENT ! 20071: MOV (XS)+,XL RESTORE XL ! 20072: EXI RETURN TO PRTVL CALLER ! 20073: * ! 20074: * HERE FOR TRBLK ! 20075: * ! 20076: PRV04 MOV TRVAL(XR),XR LOAD REAL VALUE ! 20077: BRN PRV01 AND LOOP BACK ! 20078: EJC ! 20079: * ! 20080: * PRTVL (CONTINUED) ! 20081: * ! 20082: * HERE FOR ARRAY (ARBLK) ! 20083: * ! 20084: * PRINT ARRAY ( PROTOTYPE ) BLANK NUMBER IDVAL ! 20085: * ! 20086: PRV05 MOV XR,XL PRESERVE ARGUMENT ! 20087: MOV =SCARR,XR POINT TO DATATYPE NAME (ARRAY) ! 20088: JSR PRTST PRINT IT ! 20089: MOV =CH$PP,WA LOAD LEFT PAREN ! 20090: JSR PRTCH PRINT LEFT PAREN ! 20091: ADD AROFS(XL),XL POINT TO PROTOTYPE ! 20092: MOV (XL),XR LOAD PROTOTYPE ! 20093: JSR PRTST PRINT PROTOTYPE ! 20094: * ! 20095: * VCBLK, TBBLK, BCBLK MERGE HERE FOR ) BLANK NUMBER IDVAL ! 20096: * ! 20097: PRV06 MOV =CH$RP,WA LOAD RIGHT PAREN ! 20098: JSR PRTCH PRINT RIGHT PAREN ! 20099: * ! 20100: * PDBLK MERGES HERE TO PRINT BLANK NUMBER IDVAL ! 20101: * ! 20102: PRV07 MOV =CH$BL,WA LOAD BLANK ! 20103: JSR PRTCH PRINT IT ! 20104: MOV =CH$NM,WA LOAD NUMBER SIGN ! 20105: JSR PRTCH PRINT IT ! 20106: MTI PRVSI GET IDVAL ! 20107: JSR PRTIN PRINT ID NUMBER ! 20108: BRN PRV03 BACK TO EXIT ! 20109: * ! 20110: * HERE FOR INTEGER (ICBLK), REAL (RCBLK) ! 20111: * ! 20112: * PRINT CHARACTER REPRESENTATION OF VALUE ! 20113: * ! 20114: PRV08 MOV XR,-(XS) STACK ARGUMENT FOR GTSTG ! 20115: JSR GTSTG CONVERT TO STRING ! 20116: PPM ERROR RETURN IS IMPOSSIBLE ! 20117: JSR PRTST PRINT THE STRING ! 20118: MOV XR,DNAMP DELETE GARBAGE STRING FROM STORAGE ! 20119: BRN PRV03 BACK TO EXIT ! 20120: EJC ! 20121: * ! 20122: * PRTVL (CONTINUED) ! 20123: * ! 20124: * NAME (NMBLK) ! 20125: * ! 20126: * FOR PSEUDO-VARIABLE, JUST PRINT DATATYPE NAME (NAME) ! 20127: * FOR ALL OTHER NAMES, PRINT DOT FOLLOWED BY NAME REP ! 20128: * ! 20129: PRV09 MOV NMBAS(XR),XL LOAD NAME BASE ! 20130: MOV (XL),WA LOAD FIRST WORD OF BLOCK ! 20131: BEQ WA,=B$KVT,PRV02 JUST PRINT NAME IF KEYWORD ! 20132: BEQ WA,=B$EVT,PRV02 JUST PRINT NAME IF EXPRESSION VAR ! 20133: MOV =CH$DT,WA ELSE GET DOT ! 20134: JSR PRTCH AND PRINT IT ! 20135: MOV NMOFS(XR),WA LOAD NAME OFFSET ! 20136: JSR PRTNM PRINT NAME ! 20137: BRN PRV03 BACK TO EXIT ! 20138: * ! 20139: * PROGRAM DATATYPE (PDBLK) ! 20140: * ! 20141: * PRINT DATATYPE NAME CH$BL CH$NM IDVAL ! 20142: * ! 20143: PRV10 JSR DTYPE GET DATATYPE NAME ! 20144: JSR PRTST PRINT DATATYPE NAME ! 20145: BRN PRV07 MERGE BACK TO PRINT ID ! 20146: * ! 20147: * HERE FOR STRING (SCBLK) ! 20148: * ! 20149: * PRINT QUOTE STRING-CHARACTERS QUOTE ! 20150: * ! 20151: PRV11 MOV =CH$SQ,WA LOAD SINGLE QUOTE ! 20152: JSR PRTCH PRINT QUOTE ! 20153: JSR PRTST PRINT STRING VALUE ! 20154: JSR PRTCH PRINT ANOTHER QUOTE ! 20155: BRN PRV03 BACK TO EXIT ! 20156: EJC ! 20157: * ! 20158: * PRTVL (CONTINUED) ! 20159: * ! 20160: * HERE FOR SIMPLE EXPRESSION (SEBLK) ! 20161: * ! 20162: * PRINT ASTERISK VARIABLE-NAME ! 20163: * ! 20164: PRV12 MOV =CH$AS,WA LOAD ASTERISK ! 20165: JSR PRTCH PRINT ASTERISK ! 20166: MOV SEVAR(XR),XR LOAD VARIABLE POINTER ! 20167: JSR PRTVN PRINT VARIABLE NAME ! 20168: BRN PRV03 JUMP BACK TO EXIT ! 20169: * ! 20170: * HERE FOR TABLE (TBBLK) AND ARRAY (VCBLK) ! 20171: * ! 20172: * PRINT DATATYPE ( PROTOTYPE ) BLANK NUMBER IDVAL ! 20173: * ! 20174: PRV13 MOV XR,XL PRESERVE ARGUMENT ! 20175: JSR DTYPE GET DATATYPE NAME ! 20176: JSR PRTST PRINT DATATYPE NAME ! 20177: MOV =CH$PP,WA LOAD LEFT PAREN ! 20178: JSR PRTCH PRINT LEFT PAREN ! 20179: MOV TBLEN(XL),WA LOAD LENGTH OF BLOCK (=VCLEN) ! 20180: BTW WA CONVERT TO WORD COUNT ! 20181: SUB =TBSI$,WA ALLOW FOR STANDARD FIELDS ! 20182: BEQ (XL),=B$TBT,PRV14 JUMP IF TABLE ! 20183: ADD =VCTBD,WA FOR VCBLK, ADJUST SIZE ! 20184: * ! 20185: * PRINT PROTOTYPE ! 20186: * ! 20187: PRV14 MTI WA MOVE AS INTEGER ! 20188: JSR PRTIN PRINT INTEGER PROTOTYPE ! 20189: BRN PRV06 MERGE BACK FOR REST ! 20190: EJC ! 20191: * ! 20192: * PRTVL (CONTINUED) ! 20193: * ! 20194: * HERE FOR BUFFER (BCBLK) ! 20195: * ! 20196: PRV15 MOV XR,XL PRESERVE ARGUMENT ! 20197: MOV =SCBUF,XR POINT TO DATATYPE NAME (BUFFER) ! 20198: JSR PRTST PRINT IT ! 20199: MOV =CH$PP,WA LOAD LEFT PAREN ! 20200: JSR PRTCH PRINT LEFT PAREN ! 20201: MOV BCBUF(XL),XR POINT TO BFBLK ! 20202: MTI BFALC(XR) LOAD ALLOCATION SIZE ! 20203: JSR PRTIN PRINT IT ! 20204: MOV =CH$CM,WA LOAD COMMA ! 20205: JSR PRTCH PRINT IT ! 20206: MTI BCLEN(XL) LOAD DEFINED LENGTH ! 20207: JSR PRTIN PRINT IT ! 20208: BRN PRV06 MERGE TO FINISH UP ! 20209: ENP END PROCEDURE PRTVL ! 20210: EJC ! 20211: * ! 20212: * PRTVN -- PRINT NATURAL VARIABLE NAME ! 20213: * ! 20214: * PRTVN PRINTS THE NAME OF A NATURAL VARIABLE ! 20215: * ! 20216: * (XR) POINTER TO VRBLK ! 20217: * JSR PRTVN CALL TO PRINT VARIABLE NAME ! 20218: * ! 20219: PRTVN PRC E,0 ENTRY POINT ! 20220: MOV XR,-(XS) STACK VRBLK POINTER ! 20221: ADD *VRSOF,XR POINT TO POSSIBLE STRING NAME ! 20222: BNZ SCLEN(XR),PRVN1 JUMP IF NOT SYSTEM VARIABLE ! 20223: MOV VRSVO(XR),XR POINT TO SVBLK WITH NAME ! 20224: * ! 20225: * MERGE HERE WITH DUMMY SCBLK POINTER IN XR ! 20226: * ! 20227: PRVN1 JSR PRTST PRINT STRING NAME OF VARIABLE ! 20228: MOV (XS)+,XR RESTORE VRBLK POINTER ! 20229: EXI RETURN TO PRTVN CALLER ! 20230: ENP END PROCEDURE PRTVN ! 20231: EJC ! 20232: * ! 20233: * RCBLD -- BUILD A REAL BLOCK ! 20234: * ! 20235: * (RA) REAL VALUE FOR RCBLK ! 20236: * JSR RCBLD CALL TO BUILD REAL BLOCK ! 20237: * (XR) POINTER TO RESULT RCBLK ! 20238: * (WA) DESTROYED ! 20239: * ! 20240: RCBLD PRC E,0 ENTRY POINT ! 20241: MOV DNAMP,XR LOAD POINTER TO NEXT AVAILABLE LOC ! 20242: ADD *RCSI$,XR POINT PAST NEW RCBLK ! 20243: BLO XR,DNAME,RCBL1 JUMP IF THERE IS ROOM ! 20244: MOV *RCSI$,WA ELSE LOAD RCBLK LENGTH ! 20245: JSR ALLOC USE STANDARD ALLOCATOR TO GET BLOCK ! 20246: ADD WA,XR POINT PAST BLOCK TO MERGE ! 20247: * ! 20248: * MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED ! 20249: * ! 20250: RCBL1 MOV XR,DNAMP SET NEW POINTER ! 20251: SUB *RCSI$,XR POINT BACK TO START OF BLOCK ! 20252: MOV =B$RCL,(XR) STORE TYPE WORD ! 20253: STR RCVAL(XR) STORE REAL VALUE IN RCBLK ! 20254: EXI RETURN TO RCBLD CALLER ! 20255: ENP END PROCEDURE RCBLD ! 20256: EJC ! 20257: * ! 20258: * READR -- READ NEXT SOURCE IMAGE AT COMPILE TIME ! 20259: * ! 20260: * READR IS USED TO READ THE NEXT SOURCE IMAGE. TO PROCESS ! 20261: * CONTINUATION CARDS PROPERLY, THE COMPILER MUST READ ONE ! 20262: * LINE AHEAD. THUS READR DOES NOT DESTROY THE CURRENT IMAGE ! 20263: * SEE ALSO THE NEXTS ROUTINE WHICH ACTUALLY GETS THE IMAGE. ! 20264: * ! 20265: * JSR READR CALL TO READ NEXT IMAGE ! 20266: * (XR) PTR TO NEXT IMAGE (0 IF NONE) ! 20267: * (R$CNI) COPY OF POINTER ! 20268: * (WA,WB,WC,XL) DESTROYED ! 20269: * ! 20270: READR PRC E,0 ENTRY POINT ! 20271: MOV R$CNI,XR GET PTR TO NEXT IMAGE ! 20272: BNZ XR,READ3 EXIT IF ALREADY READ ! 20273: BNE STAGE,=STGIC,READ3 EXIT IF NOT INITIAL COMPILE ! 20274: MOV CSWIN,WA MAX READ LENGTH ! 20275: JSR ALOCS ALLOCATE BUFFER ! 20276: JSR SYSRD READ INPUT IMAGE ! 20277: PPM READ4 JUMP IF END OF FILE ! 20278: MNZ WB SET TRIMR TO PERFORM TRIM ! 20279: BLE SCLEN(XR),CSWIN,READ1 USE SMALLER OF STRING LNTH .. ! 20280: MOV CSWIN,SCLEN(XR) ... AND XXX OF -INXXX ! 20281: * ! 20282: * PERFORM THE TRIM ! 20283: * ! 20284: READ1 JSR TRIMR TRIM TRAILING BLANKS ! 20285: * ! 20286: * MERGE HERE AFTER READ ! 20287: * ! 20288: READ2 MOV XR,R$CNI STORE COPY OF POINTER ! 20289: * ! 20290: * MERGE HERE IF NO READ ATTEMPTED ! 20291: * ! 20292: READ3 EXI RETURN TO READR CALLER ! 20293: * ! 20294: * HERE ON END OF FILE ! 20295: * ! 20296: READ4 MOV XR,DNAMP POP UNUSED SCBLK ! 20297: ZER XR ZERO PTR AS RESULT ! 20298: BRN READ2 MERGE ! 20299: ENP END PROCEDURE READR ! 20300: EJC ! 20301: * ! 20302: * SBSTR -- BUILD A SUBSTRING ! 20303: * ! 20304: * (XL) PTR TO SCBLK/BFBLK WITH CHARS ! 20305: * (WA) NUMBER OF CHARS IN SUBSTRING ! 20306: * (WB) OFFSET TO FIRST CHAR IN SCBLK ! 20307: * JSR SBSTR CALL TO BUILD SUBSTRING ! 20308: * (XR) PTR TO NEW SCBLK WITH SUBSTRING ! 20309: * (XL) ZERO ! 20310: * (WA,WB,WC,XL,IA) DESTROYED ! 20311: * ! 20312: * NOTE THAT SBSTR IS CALLED WITH A DUMMY STRING POINTER ! 20313: * (POINTING INTO A VRBLK OR SVBLK) TO COPY THE NAME OF A ! 20314: * VARIABLE AS A STANDARD STRING VALUE. ! 20315: * ! 20316: SBSTR PRC E,0 ENTRY POINT ! 20317: BZE WA,SBST2 JUMP IF NULL SUBSTRING ! 20318: JSR ALOCS ELSE ALLOCATE SCBLK ! 20319: MOV WC,WA MOVE NUMBER OF CHARACTERS ! 20320: MOV XR,WC SAVE PTR TO NEW SCBLK ! 20321: PLC XL,WB PREPARE TO LOAD CHARS FROM OLD BLK ! 20322: PSC XR PREPARE TO STORE CHARS IN NEW BLK ! 20323: MVC MOVE CHARACTERS TO NEW STRING ! 20324: MOV WC,XR THEN RESTORE SCBLK POINTER ! 20325: * ! 20326: * RETURN POINT ! 20327: * ! 20328: SBST1 ZER XL CLEAR GARBAGE POINTER IN XL ! 20329: EXI RETURN TO SBSTR CALLER ! 20330: * ! 20331: * HERE FOR NULL SUBSTRING ! 20332: * ! 20333: SBST2 MOV =NULLS,XR SET NULL STRING AS RESULT ! 20334: BRN SBST1 RETURN ! 20335: ENP END PROCEDURE SBSTR ! 20336: EJC ! 20337: * ! 20338: * SCANE -- SCAN AN ELEMENT ! 20339: * ! 20340: * SCANE IS CALLED AT COMPILE TIME (BY EXPAN ,CMPIL,CNCRD) ! 20341: * TO SCAN ONE ELEMENT FROM THE INPUT IMAGE. ! 20342: * ! 20343: * (SCNCC) NON-ZERO IF CALLED FROM CNCRD ! 20344: * JSR SCANE CALL TO SCAN ELEMENT ! 20345: * (XR) RESULT POINTER (SEE BELOW) ! 20346: * (XL) SYNTAX TYPE CODE (T$XXX) ! 20347: * ! 20348: * THE FOLLOWING GLOBAL LOCATIONS ARE USED. ! 20349: * ! 20350: * R$CIM POINTER TO STRING BLOCK (SCBLK) ! 20351: * FOR CURRENT INPUT IMAGE. ! 20352: * ! 20353: * R$CNI POINTER TO NEXT INPUT IMAGE STRING ! 20354: * POINTER (ZERO IF NONE). ! 20355: * ! 20356: * R$SCP SAVE POINTER (EXIT XR) FROM LAST ! 20357: * CALL IN CASE RESCAN IS SET. ! 20358: * ! 20359: * SCNBL THIS LOCATION IS SET NON-ZERO ON ! 20360: * EXIT IF SCANE SCANNED PAST BLANKS ! 20361: * BEFORE LOCATING THE CURRENT ELEMENT ! 20362: * THE END OF A LINE COUNTS AS BLANKS. ! 20363: * ! 20364: * SCNCC CNCRD SETS THIS NON-ZERO TO SCAN ! 20365: * CONTROL CARD NAMES AND CLEARS IT ! 20366: * ON RETURN ! 20367: * ! 20368: * SCNIL LENGTH OF CURRENT INPUT IMAGE ! 20369: * ! 20370: * SCNGO IF SET NON-ZERO ON ENTRY, F AND S ! 20371: * ARE RETURNED AS SEPARATE SYNTAX ! 20372: * TYPES (NOT LETTERS) (GOTO PRO- ! 20373: * CESSING). SCNGO IS RESET ON EXIT. ! 20374: * ! 20375: * SCNPT OFFSET TO CURRENT LOC IN R$CIM ! 20376: * ! 20377: * SCNRS IF SET NON-ZERO ON ENTRY, SCANE ! 20378: * RETURNS THE SAME RESULT AS ON THE ! 20379: * LAST CALL (RESCAN). SCNRS IS RESET ! 20380: * ON EXIT FROM ANY CALL TO SCANE. ! 20381: * ! 20382: * SCNTP SAVE SYNTAX TYPE FROM LAST ! 20383: * CALL (IN CASE RESCAN IS SET). ! 20384: EJC ! 20385: * ! 20386: * SCANE (CONTINUED) ! 20387: * ! 20388: * ! 20389: * ! 20390: * ELEMENT SCANNED XL XR ! 20391: * --------------- -- -- ! 20392: * ! 20393: * CONTROL CARD NAME 0 POINTER TO SCBLK FOR NAME ! 20394: * ! 20395: * UNARY OPERATOR T$UOP PTR TO OPERATOR DVBLK ! 20396: * ! 20397: * LEFT PAREN T$LPR T$LPR ! 20398: * ! 20399: * LEFT BRACKET T$LBR T$LBR ! 20400: * ! 20401: * COMMA T$CMA T$CMA ! 20402: * ! 20403: * FUNCTION CALL T$FNC PTR TO FUNCTION VRBLK ! 20404: * ! 20405: * VARIABLE T$VAR PTR TO VRBLK ! 20406: * ! 20407: * STRING CONSTANT T$CON PTR TO SCBLK ! 20408: * ! 20409: * INTEGER CONSTANT T$CON PTR TO ICBLK ! 20410: * ! 20411: * REAL CONSTANT T$CON PTR TO RCBLK ! 20412: * ! 20413: * BINARY OPERATOR T$BOP PTR TO OPERATOR DVBLK ! 20414: * ! 20415: * RIGHT PAREN T$RPR T$RPR ! 20416: * ! 20417: * RIGHT BRACKET T$RBR T$RBR ! 20418: * ! 20419: * COLON T$COL T$COL ! 20420: * ! 20421: * SEMI-COLON T$SMC T$SMC ! 20422: * ! 20423: * F (SCNGO NE 0) T$FGO T$FGO ! 20424: * ! 20425: * S (SCNGO NE 0) T$SGO T$SGO ! 20426: EJC ! 20427: * ! 20428: * SCANE (CONTINUED) ! 20429: * ! 20430: * ENTRY POINT ! 20431: * ! 20432: SCANE PRC E,0 ENTRY POINT ! 20433: ZER SCNBL RESET BLANKS FLAG ! 20434: MOV WA,SCNSA SAVE WA ! 20435: MOV WB,SCNSB SAVE WB ! 20436: MOV WC,SCNSC SAVE WC ! 20437: BZE SCNRS,SCN03 JUMP IF NO RESCAN ! 20438: * ! 20439: * HERE FOR RESCAN REQUEST ! 20440: * ! 20441: MOV SCNTP,XL SET PREVIOUS RETURNED SCAN TYPE ! 20442: MOV R$SCP,XR SET PREVIOUS RETURNED POINTER ! 20443: ZER SCNRS RESET RESCAN SWITCH ! 20444: BRN SCN13 JUMP TO EXIT ! 20445: * ! 20446: * COME HERE TO READ NEW IMAGE TO TEST FOR CONTINUATION ! 20447: * ! 20448: SCN01 JSR READR READ NEXT IMAGE ! 20449: MOV *DVUBS,WB SET WB FOR NOT READING NAME ! 20450: BZE XR,SCN30 TREAT AS SEMI-COLON IF NONE ! 20451: PLC XR ELSE POINT TO FIRST CHARACTER ! 20452: LCH WC,(XR) LOAD FIRST CHARACTER ! 20453: BEQ WC,=CH$DT,SCN02 JUMP IF DOT FOR CONTINUATION ! 20454: BNE WC,=CH$PL,SCN30 ELSE TREAT AS SEMICOLON UNLESS PLUS ! 20455: * ! 20456: * HERE FOR CONTINUATION LINE ! 20457: * ! 20458: SCN02 JSR NEXTS ACQUIRE NEXT SOURCE IMAGE ! 20459: MOV =NUM01,SCNPT SET SCAN POINTER PAST CONTINUATION ! 20460: MNZ SCNBL SET BLANKS FLAG ! 20461: EJC ! 20462: * ! 20463: * SCANE (CONTINUED) ! 20464: * ! 20465: * MERGE HERE TO SCAN NEXT ELEMENT ON CURRENT LINE ! 20466: * ! 20467: SCN03 MOV SCNPT,WA LOAD CURRENT OFFSET ! 20468: BEQ WA,SCNIL,SCN01 CHECK CONTINUATION IF END ! 20469: MOV R$CIM,XL POINT TO CURRENT LINE ! 20470: PLC XL,WA POINT TO CURRENT CHARACTER ! 20471: MOV WA,SCNSE SET START OF ELEMENT LOCATION ! 20472: MOV =OPDVS,WC POINT TO OPERATOR DV LIST ! 20473: MOV *DVUBS,WB SET CONSTANT FOR OPERATOR CIRCUIT ! 20474: BRN SCN06 START SCANNING ! 20475: * ! 20476: * LOOP HERE TO IGNORE LEADING BLANKS AND TABS ! 20477: * ! 20478: SCN05 BZE WB,SCN10 JUMP IF TRAILING ! 20479: ICV SCNSE INCREMENT START OF ELEMENT ! 20480: BEQ WA,SCNIL,SCN01 JUMP IF END OF IMAGE ! 20481: MNZ SCNBL NOTE BLANKS SEEN ! 20482: * ! 20483: * THE FOLLOWING JUMP IS USED REPEATEDLY FOR SCANNING OUT ! 20484: * THE CHARACTERS OF A NUMERIC CONSTANT OR VARIABLE NAME. ! 20485: * THE REGISTERS ARE USED AS FOLLOWS. ! 20486: * ! 20487: * (XR) SCRATCH ! 20488: * (XL) PTR TO NEXT CHARACTER ! 20489: * (WA) CURRENT SCAN OFFSET ! 20490: * (WB) *DVUBS (0 IF SCANNING NAME,CONST) ! 20491: * (WC) =OPDVS (0 IF SCANNING CONSTANT) ! 20492: * ! 20493: SCN06 LCH XR,(XL)+ GET NEXT CHARACTER ! 20494: ICV WA BUMP SCAN OFFSET ! 20495: MOV WA,SCNPT STORE OFFSET PAST CHAR SCANNED ! 20496: BLO =CFP$U,XR,SCN07 QUICK CHECK FOR OTHER CHAR ! 20497: BSW XR,CFP$U,SCN07 SWITCH ON SCANNED CHARACTER ! 20498: * ! 20499: * SWITCH TABLE FOR SWITCH ON CHARACTER ! 20500: * ! 20501: IFF CH$BL,SCN05 BLANK ! 20502: IFF CH$HT,SCN05 HORIZONTAL TAB ! 20503: IFF CH$D0,SCN08 DIGIT 0 ! 20504: IFF CH$D1,SCN08 DIGIT 1 ! 20505: IFF CH$D2,SCN08 DIGIT 2 ! 20506: IFF CH$D3,SCN08 DIGIT 3 ! 20507: IFF CH$D4,SCN08 DIGIT 4 ! 20508: IFF CH$D5,SCN08 DIGIT 5 ! 20509: IFF CH$D6,SCN08 DIGIT 6 ! 20510: IFF CH$D7,SCN08 DIGIT 7 ! 20511: IFF CH$D8,SCN08 DIGIT 8 ! 20512: IFF CH$D9,SCN08 DIGIT 9 ! 20513: EJC ! 20514: * ! 20515: * SCANE (CONTINUED) ! 20516: * ! 20517: IFF CH$LA,SCN09 LETTER A ! 20518: IFF CH$LB,SCN09 LETTER B ! 20519: IFF CH$LC,SCN09 LETTER C ! 20520: IFF CH$LD,SCN09 LETTER D ! 20521: IFF CH$LE,SCN09 LETTER E ! 20522: IFF CH$LG,SCN09 LETTER G ! 20523: IFF CH$LH,SCN09 LETTER H ! 20524: IFF CH$LI,SCN09 LETTER I ! 20525: IFF CH$LJ,SCN09 LETTER J ! 20526: IFF CH$LK,SCN09 LETTER K ! 20527: IFF CH$LL,SCN09 LETTER L ! 20528: IFF CH$LM,SCN09 LETTER M ! 20529: IFF CH$LN,SCN09 LETTER N ! 20530: IFF CH$LO,SCN09 LETTER O ! 20531: IFF CH$LP,SCN09 LETTER P ! 20532: IFF CH$LQ,SCN09 LETTER Q ! 20533: IFF CH$LR,SCN09 LETTER R ! 20534: IFF CH$LT,SCN09 LETTER T ! 20535: IFF CH$LU,SCN09 LETTER U ! 20536: IFF CH$LV,SCN09 LETTER V ! 20537: IFF CH$LW,SCN09 LETTER W ! 20538: IFF CH$LX,SCN09 LETTER X ! 20539: IFF CH$LY,SCN09 LETTER Y ! 20540: IFF CH$L$,SCN09 LETTER Z ! 20541: IFF CH$$A,SCN09 SHIFTED A ! 20542: IFF CH$$B,SCN09 SHIFTED B ! 20543: IFF CH$$C,SCN09 SHIFTED C ! 20544: IFF CH$$D,SCN09 SHIFTED D ! 20545: IFF CH$$E,SCN09 SHIFTED E ! 20546: IFF CH$$F,SCN20 SHIFTED F ! 20547: IFF CH$$G,SCN09 SHIFTED G ! 20548: IFF CH$$H,SCN09 SHIFTED H ! 20549: IFF CH$$I,SCN09 SHIFTED I ! 20550: IFF CH$$J,SCN09 SHIFTED J ! 20551: IFF CH$$K,SCN09 SHIFTED K ! 20552: IFF CH$$L,SCN09 SHIFTED L ! 20553: IFF CH$$M,SCN09 SHIFTED M ! 20554: IFF CH$$N,SCN09 SHIFTED N ! 20555: IFF CH$$O,SCN09 SHIFTED O ! 20556: IFF CH$$P,SCN09 SHIFTED P ! 20557: IFF CH$$Q,SCN09 SHIFTED Q ! 20558: IFF CH$$R,SCN09 SHIFTED R ! 20559: IFF CH$$S,SCN21 SHIFTED S ! 20560: IFF CH$$T,SCN09 SHIFTED T ! 20561: IFF CH$$U,SCN09 SHIFTED U ! 20562: IFF CH$$V,SCN09 SHIFTED V ! 20563: IFF CH$$W,SCN09 SHIFTED W ! 20564: IFF CH$$X,SCN09 SHIFTED X ! 20565: IFF CH$$Y,SCN09 SHIFTED Y ! 20566: IFF CH$$$,SCN09 SHIFTED Z ! 20567: EJC ! 20568: * ! 20569: * SCANE (CONTINUED) ! 20570: * ! 20571: IFF CH$SQ,SCN16 SINGLE QUOTE ! 20572: IFF CH$DQ,SCN17 DOUBLE QUOTE ! 20573: IFF CH$LF,SCN20 LETTER F ! 20574: IFF CH$LS,SCN21 LETTER S ! 20575: IFF CH$UN,SCN24 UNDERLINE ! 20576: IFF CH$PP,SCN25 LEFT PAREN ! 20577: IFF CH$RP,SCN26 RIGHT PAREN ! 20578: IFF CH$RB,SCN27 RIGHT BRACKET ! 20579: IFF CH$BB,SCN28 LEFT BRACKET ! 20580: IFF CH$CB,SCN27 RIGHT BRACKET ! 20581: IFF CH$OB,SCN28 LEFT BRACKET ! 20582: IFF CH$CL,SCN29 COLON ! 20583: IFF CH$SM,SCN30 SEMI-COLON ! 20584: IFF CH$CM,SCN31 COMMA ! 20585: IFF CH$DT,SCN32 DOT ! 20586: IFF CH$PL,SCN33 PLUS ! 20587: IFF CH$MN,SCN34 MINUS ! 20588: IFF CH$NT,SCN35 NOT ! 20589: IFF CH$DL,SCN36 DOLLAR ! 20590: IFF CH$EX,SCN37 EXCLAMATION MARK ! 20591: IFF CH$PC,SCN38 PERCENT ! 20592: IFF CH$SL,SCN40 SLASH ! 20593: IFF CH$NM,SCN41 NUMBER SIGN ! 20594: IFF CH$AT,SCN42 AT ! 20595: IFF CH$BR,SCN43 VERTICAL BAR ! 20596: IFF CH$AM,SCN44 AMPERSAND ! 20597: IFF CH$QU,SCN45 QUESTION MARK ! 20598: IFF CH$EQ,SCN46 EQUAL ! 20599: IFF CH$AS,SCN49 ASTERISK ! 20600: ESW END SWITCH ON CHARACTER ! 20601: * ! 20602: * HERE FOR ILLEGAL CHARACTER (UNDERLINE MERGES) ! 20603: * ! 20604: SCN07 BZE WB,SCN10 JUMP IF SCANNING NAME OR CONSTANT ! 20605: ERB 230,SYNTAX ERROR. ILLEGAL CHARACTER ! 20606: EJC ! 20607: * ! 20608: * SCANE (CONTINUED) ! 20609: * ! 20610: * HERE FOR DIGITS 0-9 ! 20611: * ! 20612: SCN08 BZE WB,SCN09 KEEP SCANNING IF NAME/CONSTANT ! 20613: ZER WC ELSE SET FLAG FOR SCANNING CONSTANT ! 20614: * ! 20615: * HERE FOR LETTER. LOOP HERE WHEN SCANNING NAME/CONSTANT ! 20616: * ! 20617: SCN09 BEQ WA,SCNIL,SCN11 JUMP IF END OF IMAGE ! 20618: ZER WB SET FLAG FOR SCANNING NAME/CONST ! 20619: BRN SCN06 MERGE BACK TO CONTINUE SCAN ! 20620: * ! 20621: * COME HERE FOR DELIMITER ENDING NAME OR CONSTANT ! 20622: * ! 20623: SCN10 DCV WA RESET OFFSET TO POINT TO DELIMITER ! 20624: * ! 20625: * COME HERE AFTER FINISHING SCAN OF NAME OR CONSTANT ! 20626: * ! 20627: SCN11 MOV WA,SCNPT STORE UPDATED SCAN OFFSET ! 20628: MOV SCNSE,WB POINT TO START OF ELEMENT ! 20629: SUB WB,WA GET NUMBER OF CHARACTERS ! 20630: MOV R$CIM,XL POINT TO LINE IMAGE ! 20631: BNZ WC,SCN15 JUMP IF NAME ! 20632: * ! 20633: * HERE AFTER SCANNING OUT NUMERIC CONSTANT ! 20634: * ! 20635: JSR SBSTR GET STRING FOR CONSTANT ! 20636: MOV XR,DNAMP DELETE FROM STORAGE (NOT NEEDED) ! 20637: JSR GTNUM CONVERT TO NUMERIC ! 20638: PPM SCN14 JUMP IF CONVERSION FAILURE ! 20639: * ! 20640: * MERGE HERE TO EXIT WITH CONSTANT ! 20641: * ! 20642: SCN12 MOV =T$CON,XL SET RESULT TYPE OF CONSTANT ! 20643: EJC ! 20644: * ! 20645: * SCANE (CONTINUED) ! 20646: * ! 20647: * COMMON EXIT POINT (XR,XL) SET ! 20648: * ! 20649: SCN13 MOV SCNSA,WA RESTORE WA ! 20650: MOV SCNSB,WB RESTORE WB ! 20651: MOV SCNSC,WC RESTORE WC ! 20652: MOV XR,R$SCP SAVE XR IN CASE RESCAN ! 20653: MOV XL,SCNTP SAVE XL IN CASE RESCAN ! 20654: ZER SCNGO RESET POSSIBLE GOTO FLAG ! 20655: EXI RETURN TO SCANE CALLER ! 20656: * ! 20657: * HERE IF CONVERSION ERROR ON NUMERIC ITEM ! 20658: * ! 20659: SCN14 ERB 231,SYNTAX ERROR. INVALID NUMERIC ITEM ! 20660: * ! 20661: * HERE AFTER SCANNING OUT VARIABLE NAME ! 20662: * ! 20663: SCN15 JSR SBSTR BUILD STRING NAME OF VARIABLE ! 20664: BNZ SCNCC,SCN13 RETURN IF CNCRD CALL ! 20665: JSR GTNVR LOCATE/BUILD VRBLK ! 20666: PPM DUMMY (UNUSED) ERROR RETURN ! 20667: MOV =T$VAR,XL SET TYPE AS VARIABLE ! 20668: BRN SCN13 BACK TO EXIT ! 20669: * ! 20670: * HERE FOR SINGLE QUOTE (START OF STRING CONSTANT) ! 20671: * ! 20672: SCN16 BZE WB,SCN10 TERMINATOR IF SCANNING NAME OR CNST ! 20673: MOV =CH$SQ,WB SET TERMINATOR AS SINGLE QUOTE ! 20674: BRN SCN18 MERGE ! 20675: * ! 20676: * HERE FOR DOUBLE QUOTE (START OF STRING CONSTANT) ! 20677: * ! 20678: SCN17 BZE WB,SCN10 TERMINATOR IF SCANNING NAME OR CNST ! 20679: MOV =CH$DQ,WB SET DOUBLE QUOTE TERMINATOR, MERGE ! 20680: * ! 20681: * LOOP TO SCAN OUT STRING CONSTANT ! 20682: * ! 20683: SCN18 BEQ WA,SCNIL,SCN19 ERROR IF END OF IMAGE ! 20684: LCH WC,(XL)+ ELSE LOAD NEXT CHARACTER ! 20685: ICV WA BUMP OFFSET ! 20686: BNE WC,WB,SCN18 LOOP BACK IF NOT TERMINATOR ! 20687: EJC ! 20688: * ! 20689: * SCANE (CONTINUED) ! 20690: * ! 20691: * HERE AFTER SCANNING OUT STRING CONSTANT ! 20692: * ! 20693: MOV SCNPT,WB POINT TO FIRST CHARACTER ! 20694: MOV WA,SCNPT SAVE OFFSET PAST FINAL QUOTE ! 20695: DCV WA POINT BACK PAST LAST CHARACTER ! 20696: SUB WB,WA GET NUMBER OF CHARACTERS ! 20697: MOV R$CIM,XL POINT TO INPUT IMAGE ! 20698: JSR SBSTR BUILD SUBSTRING VALUE ! 20699: BRN SCN12 BACK TO EXIT WITH CONSTANT RESULT ! 20700: * ! 20701: * HERE IF NO MATCHING QUOTE FOUND ! 20702: * ! 20703: SCN19 MOV WA,SCNPT SET UPDATED SCAN POINTER ! 20704: ERB 232,SYNTAX ERROR. UNMATCHED STRING QUOTE ! 20705: * ! 20706: * HERE FOR F (POSSIBLE FAILURE GOTO) ! 20707: * ! 20708: SCN20 MOV =T$FGO,XR SET RETURN CODE FOR FAIL GOTO ! 20709: BRN SCN22 JUMP TO MERGE ! 20710: * ! 20711: * HERE FOR S (POSSIBLE SUCCESS GOTO) ! 20712: * ! 20713: SCN21 MOV =T$SGO,XR SET SUCCESS GOTO AS RETURN CODE ! 20714: * ! 20715: * SPECIAL GOTO CASES MERGE HERE ! 20716: * ! 20717: SCN22 BZE SCNGO,SCN09 TREAT AS NORMAL LETTER IF NOT GOTO ! 20718: * ! 20719: * MERGE HERE FOR SPECIAL CHARACTER EXIT ! 20720: * ! 20721: SCN23 BZE WB,SCN10 JUMP IF END OF NAME/CONSTANT ! 20722: MOV XR,XL ELSE COPY CODE ! 20723: BRN SCN13 AND JUMP TO EXIT ! 20724: * ! 20725: * HERE FOR UNDERLINE ! 20726: * ! 20727: SCN24 BZE WB,SCN09 PART OF NAME IF SCANNING NAME ! 20728: BRN SCN07 ELSE ILLEGAL ! 20729: EJC ! 20730: * ! 20731: * SCANE (CONTINUED) ! 20732: * ! 20733: * HERE FOR LEFT PAREN ! 20734: * ! 20735: SCN25 MOV =T$LPR,XR SET LEFT PAREN RETURN CODE ! 20736: BNZ WB,SCN23 RETURN LEFT PAREN UNLESS NAME ! 20737: BZE WC,SCN10 DELIMITER IF SCANNING CONSTANT ! 20738: * ! 20739: * HERE FOR LEFT PAREN AFTER NAME (FUNCTION CALL) ! 20740: * ! 20741: MOV SCNSE,WB POINT TO START OF NAME ! 20742: MOV WA,SCNPT SET POINTER PAST LEFT PAREN ! 20743: DCV WA POINT BACK PAST LAST CHAR OF NAME ! 20744: SUB WB,WA GET NAME LENGTH ! 20745: MOV R$CIM,XL POINT TO INPUT IMAGE ! 20746: JSR SBSTR GET STRING NAME FOR FUNCTION ! 20747: JSR GTNVR LOCATE/BUILD VRBLK ! 20748: PPM DUMMY (UNUSED) ERROR RETURN ! 20749: MOV =T$FNC,XL SET CODE FOR FUNCTION CALL ! 20750: BRN SCN13 BACK TO EXIT ! 20751: * ! 20752: * PROCESSING FOR SPECIAL CHARACTERS ! 20753: * ! 20754: SCN26 MOV =T$RPR,XR RIGHT PAREN, SET CODE ! 20755: BRN SCN23 TAKE SPECIAL CHARACTER EXIT ! 20756: * ! 20757: SCN27 MOV =T$RBR,XR RIGHT BRACKET, SET CODE ! 20758: BRN SCN23 TAKE SPECIAL CHARACTER EXIT ! 20759: * ! 20760: SCN28 MOV =T$LBR,XR LEFT BRACKET, SET CODE ! 20761: BRN SCN23 TAKE SPECIAL CHARACTER EXIT ! 20762: * ! 20763: SCN29 MOV =T$COL,XR COLON, SET CODE ! 20764: BRN SCN23 TAKE SPECIAL CHARACTER EXIT ! 20765: * ! 20766: SCN30 MOV =T$SMC,XR SEMI-COLON, SET CODE ! 20767: BRN SCN23 TAKE SPECIAL CHARACTER EXIT ! 20768: * ! 20769: SCN31 MOV =T$CMA,XR COMMA, SET CODE ! 20770: BRN SCN23 TAKE SPECIAL CHARACTER EXIT ! 20771: EJC ! 20772: * ! 20773: * SCANE (CONTINUED) ! 20774: * ! 20775: * HERE FOR OPERATORS. ON ENTRY, WC POINTS TO THE TABLE OF ! 20776: * OPERATOR DOPE VECTORS AND WB IS THE INCREMENT TO STEP ! 20777: * TO THE NEXT PAIR (BINARY/UNARY) OF DOPE VECTORS IN THE ! 20778: * LIST. ON REACHING SCN46, THE POINTER HAS BEEN ADJUSTED TO ! 20779: * POINT TO THE APPROPRIATE PAIR OF DOPE VECTORS. ! 20780: * THE FIRST THREE ENTRIES ARE SPECIAL SINCE THEY CAN OCCUR ! 20781: * AS PART OF A VARIABLE NAME (.) OR CONSTANT (.+-). ! 20782: * ! 20783: SCN32 BZE WB,SCN09 DOT CAN BE PART OF NAME OR CONSTANT ! 20784: ADD WB,WC ELSE BUMP POINTER ! 20785: * ! 20786: SCN33 BZE WC,SCN09 PLUS CAN BE PART OF CONSTANT ! 20787: BZE WB,SCN48 PLUS CANNOT BE PART OF NAME ! 20788: ADD WB,WC ELSE BUMP POINTER ! 20789: * ! 20790: SCN34 BZE WC,SCN09 MINUS CAN BE PART OF CONSTANT ! 20791: BZE WB,SCN48 MINUS CANNOT BE PART OF NAME ! 20792: ADD WB,WC ELSE BUMP POINTER ! 20793: * ! 20794: SCN35 ADD WB,WC NOT ! 20795: SCN36 ADD WB,WC DOLLAR ! 20796: SCN37 ADD WB,WC EXCLAMATION ! 20797: SCN38 ADD WB,WC PERCENT ! 20798: SCN39 ADD WB,WC ASTERISK ! 20799: SCN40 ADD WB,WC SLASH ! 20800: SCN41 ADD WB,WC NUMBER SIGN ! 20801: SCN42 ADD WB,WC AT SIGN ! 20802: SCN43 ADD WB,WC VERTICAL BAR ! 20803: SCN44 ADD WB,WC AMPERSAND ! 20804: SCN45 ADD WB,WC QUESTION MARK ! 20805: * ! 20806: * ALL OPERATORS COME HERE (EQUAL MERGES DIRECTLY) ! 20807: * (WC) POINTS TO THE BINARY/UNARY PAIR OF OPERATOR DVBLKS. ! 20808: * ! 20809: SCN46 BZE WB,SCN10 OPERATOR TERMINATES NAME/CONSTANT ! 20810: MOV WC,XR ELSE COPY DV POINTER ! 20811: LCH WC,(XL) LOAD NEXT CHARACTER ! 20812: MOV =T$BOP,XL SET BINARY OP IN CASE ! 20813: BEQ WA,SCNIL,SCN47 SHOULD BE BINARY IF IMAGE END ! 20814: BEQ WC,=CH$BL,SCN47 SHOULD BE BINARY IF FOLLOWED BY BLK ! 20815: BEQ WC,=CH$HT,SCN47 JUMP IF HORIZONTAL TAB ! 20816: BEQ WC,=CH$SM,SCN47 SEMICOLON CAN IMMEDIATELY FOLLOW = ! 20817: * ! 20818: * HERE FOR UNARY OPERATOR ! 20819: * ! 20820: ADD *DVBS$,XR POINT TO DV FOR UNARY OP ! 20821: MOV =T$UOP,XL SET TYPE FOR UNARY OPERATOR ! 20822: BLE SCNTP,=T$UOK,SCN13 OK UNARY IF OK PRECEDING ELEMENT ! 20823: EJC ! 20824: * ! 20825: * SCANE (CONTINUED) ! 20826: * ! 20827: * MERGE HERE TO REQUIRE PRECEDING BLANKS ! 20828: * ! 20829: SCN47 BNZ SCNBL,SCN13 ALL OK IF PRECEDING BLANKS, EXIT ! 20830: * ! 20831: * FAIL OPERATOR IN THIS POSITION ! 20832: * ! 20833: SCN48 ERB 233,SYNTAX ERROR. INVALID USE OF OPERATOR ! 20834: * ! 20835: * HERE FOR ASTERISK, COULD BE ** SUBSTITUTE FOR EXCLAMATION ! 20836: * ! 20837: SCN49 BZE WB,SCN10 END OF NAME IF SCANNING NAME ! 20838: BEQ WA,SCNIL,SCN39 NOT ** IF * AT IMAGE END ! 20839: MOV WA,XR ELSE SAVE OFFSET PAST FIRST * ! 20840: MOV WA,SCNOF SAVE ANOTHER COPY ! 20841: LCH WA,(XL)+ LOAD NEXT CHARACTER ! 20842: BNE WA,=CH$AS,SCN50 NOT ** IF NEXT CHAR NOT * ! 20843: ICV XR ELSE STEP OFFSET PAST SECOND * ! 20844: BEQ XR,SCNIL,SCN51 OK EXCLAM IF END OF IMAGE ! 20845: LCH WA,(XL) ELSE LOAD NEXT CHARACTER ! 20846: BEQ WA,=CH$BL,SCN51 EXCLAMATION IF BLANK ! 20847: BEQ WA,=CH$HT,SCN51 EXCLAMATION IF HORIZONTAL TAB ! 20848: * ! 20849: * UNARY * ! 20850: * ! 20851: SCN50 MOV SCNOF,WA RECOVER STORED OFFSET ! 20852: MOV R$CIM,XL POINT TO LINE AGAIN ! 20853: PLC XL,WA POINT TO CURRENT CHAR ! 20854: BRN SCN39 MERGE WITH UNARY * ! 20855: * ! 20856: * HERE FOR ** AS SUBSTITUTE FOR EXCLAMATION ! 20857: * ! 20858: SCN51 MOV XR,SCNPT SAVE SCAN POINTER PAST 2ND * ! 20859: MOV XR,WA COPY SCAN POINTER ! 20860: BRN SCN37 MERGE WITH EXCLAMATION ! 20861: ENP END PROCEDURE SCANE ! 20862: EJC ! 20863: * ! 20864: * SCNGF -- SCAN GOTO FIELD ! 20865: * ! 20866: * SCNGF IS CALLED FROM CMPIL TO SCAN AND ANALYZE A GOTO ! 20867: * FIELD INCLUDING THE SURROUNDING BRACKETS OR PARENTHESES. ! 20868: * FOR A NORMAL GOTO, THE RESULT RETURNED IS EITHER A VRBLK ! 20869: * POINTER FOR A SIMPLE LABEL OPERAND, OR A POINTER TO AN ! 20870: * EXPRESSION TREE WITH A SPECIAL OUTER UNARY OPERATOR ! 20871: * (O$GOC). FOR A DIRECT GOTO, THE RESULT RETURNED IS A ! 20872: * POINTER TO AN EXPRESSION TREE WITH THE SPECIAL OUTER ! 20873: * UNARY OPERATOR O$GOD. ! 20874: * ! 20875: * JSR SCNGF CALL TO SCAN GOTO FIELD ! 20876: * (XR) RESULT (SEE ABOVE) ! 20877: * (XL,WA,WB,WC) DESTROYED ! 20878: * ! 20879: SCNGF PRC E,0 ENTRY POINT ! 20880: JSR SCANE SCAN INITIAL ELEMENT ! 20881: BEQ XL,=T$LPR,SCNG1 SKIP IF LEFT PAREN (NORMAL GOTO) ! 20882: BEQ XL,=T$LBR,SCNG2 SKIP IF LEFT BRACKET (DIRECT GOTO) ! 20883: ERB 234,SYNTAX ERROR. GOTO FIELD INCORRECT ! 20884: * ! 20885: * HERE FOR LEFT PAREN (NORMAL GOTO) ! 20886: * ! 20887: SCNG1 MOV =NUM01,WB SET EXPAN FLAG FOR NORMAL GOTO ! 20888: JSR EXPAN ANALYZE GOTO FIELD ! 20889: MOV =OPDVN,WA POINT TO OPDV FOR COMPLEX GOTO ! 20890: BLE XR,STATB,SCNG3 JUMP IF NOT IN STATIC (SGD15) ! 20891: BLO XR,STATE,SCNG4 JUMP TO EXIT IF SIMPLE LABEL NAME ! 20892: BRN SCNG3 COMPLEX GOTO - MERGE ! 20893: * ! 20894: * HERE FOR LEFT BRACKET (DIRECT GOTO) ! 20895: * ! 20896: SCNG2 MOV =NUM02,WB SET EXPAN FLAG FOR DIRECT GOTO ! 20897: JSR EXPAN SCAN GOTO FIELD ! 20898: MOV =OPDVD,WA SET OPDV POINTER FOR DIRECT GOTO ! 20899: EJC ! 20900: * ! 20901: * SCNGF (CONTINUED) ! 20902: * ! 20903: * MERGE HERE TO BUILD OUTER UNARY OPERATOR BLOCK ! 20904: * ! 20905: SCNG3 MOV WA,-(XS) STACK OPERATOR DV POINTER ! 20906: MOV XR,-(XS) STACK POINTER TO EXPRESSION TREE ! 20907: JSR EXPOP POP OPERATOR OFF ! 20908: MOV (XS)+,XR RELOAD NEW EXPRESSION TREE POINTER ! 20909: * ! 20910: * COMMON EXIT POINT ! 20911: * ! 20912: SCNG4 EXI RETURN TO CALLER ! 20913: ENP END PROCEDURE SCNGF ! 20914: EJC ! 20915: * ! 20916: * SETVR -- SET VRGET,VRSTO FIELDS OF VRBLK ! 20917: * ! 20918: * SETVR SETS THE PROPER VALUES IN THE VRGET AND VRSTO ! 20919: * FIELDS OF A VRBLK. IT IS CALLED WHENEVER TRBLKS ARE ! 20920: * ADDED OR SUBTRACTED (TRACE,STOPTR,INPUT,OUTPUT,DETACH) ! 20921: * ! 20922: * (XR) POINTER TO VRBLK ! 20923: * JSR SETVR CALL TO SET FIELDS ! 20924: * (XL,WA) DESTROYED ! 20925: * ! 20926: * NOTE THAT SETVR IGNORES THE CALL IF XR DOES NOT POINT ! 20927: * INTO THE STATIC REGION (I.E. IS SOME OTHER NAME BASE) ! 20928: * ! 20929: SETVR PRC E,0 ENTRY POINT ! 20930: BHI XR,STATE,SETV1 EXIT IF NOT NATURAL VARIABLE ! 20931: * ! 20932: * HERE IF WE HAVE A VRBLK ! 20933: * ! 20934: MOV XR,XL COPY VRBLK POINTER ! 20935: MOV =B$VRL,VRGET(XR) STORE NORMAL GET VALUE ! 20936: BEQ VRSTO(XR),=B$VRE,SETV1 SKIP IF PROTECTED VARIABLE ! 20937: MOV =B$VRS,VRSTO(XR) STORE NORMAL STORE VALUE ! 20938: MOV VRVAL(XL),XL POINT TO NEXT ENTRY ON CHAIN ! 20939: BNE (XL),=B$TRT,SETV1 JUMP IF END OF TRBLK CHAIN ! 20940: MOV =B$VRA,VRGET(XR) STORE TRAPPED ROUTINE ADDRESS ! 20941: MOV =B$VRV,VRSTO(XR) SET TRAPPED ROUTINE ADDRESS ! 20942: * ! 20943: * MERGE HERE TO EXIT TO CALLER ! 20944: * ! 20945: SETV1 EXI RETURN TO SETVR CALLER ! 20946: ENP END PROCEDURE SETVR ! 20947: EJC ! 20948: * ! 20949: * SORTA -- SORT ARRAY ! 20950: * ! 20951: * ROUTINE TO SORT AN ARRAY OR TABLE ON SAME BASIS AS IN ! 20952: * SITBOL. A TABLE IS CONVERTED TO AN ARRAY, LEAVING TWO ! 20953: * DIMENSIONAL ARRAYS AND VECTORS AS CASES TO BE CONSIDERED. ! 20954: * WHOLE ROWS OF ARRAYS ARE PERMUTED ACCORDING TO THE ! 20955: * ORDERING OF THE KEYS THEY CONTAIN, AND THE STRIDE ! 20956: * REFERRED TO, IS THE THE LENGTH OF A ROW. IT IS ONE ! 20957: * FOR A VECTOR. ! 20958: * THE SORT USED IS HEAPSORT, FUNDAMENTALS OF DATA STRUCTURE ! 20959: * HOROWITZ AND SAHNI, PITMAN 1977, PAGE 347. ! 20960: * IT IS AN ORDER N*LOG(N) ALGORITHM. IN ORDER ! 20961: * TO MAKE IT STABLE, COMPARANDS MAY NOT COMPARE EQUAL. THIS ! 20962: * IS ACHIEVED BY SORTING A COPY ARRAY (REFERRED TO AS THE ! 20963: * SORT ARRAY) CONTAINING AT ITS HIGH ADDRESS END, BYTE ! 20964: * OFFSETS TO THE ROWS TO BE SORTED HELD IN THE ORIGINAL ! 20965: * ARRAY (REFERRED TO AS THE KEY ARRAY). SORTC, THE ! 20966: * COMPARISON ROUTINE, ACCESSES THE KEYS THROUGH THESE ! 20967: * OFFSETS AND IN THE CASE OF EQUALITY, RESOLVES IT BY ! 20968: * COMPARING THE OFFSETS THEMSELVES. THE SORT PERMUTES THE ! 20969: * OFFSETS WHICH ARE THEN USED IN A FINAL OPERATION TO COPY ! 20970: * THE ACTUAL ITEMS INTO THE NEW ARRAY IN SORTED ORDER. ! 20971: * REFERENCES TO ZEROTH ITEM ARE TO NOTIONAL ITEM ! 20972: * PRECEDING FIRST ACTUAL ITEM. ! 20973: * REVERSE SORTING FOR RSORT IS DONE BY HAVING THE LESS THAN ! 20974: * TEST FOR KEYS EFFECTIVELY BE REPLACED BY A ! 20975: * GREATER THAN TEST. ! 20976: * ! 20977: * 1(XS) FIRST ARG - ARRAY OR TABLE ! 20978: * 0(XS) 2ND ARG - INDEX OR PDTYPE NAME ! 20979: * (WA) 0 , NON-ZERO FOR SORT , RSORT ! 20980: * JSR SORTA CALL TO SORT ARRAY ! 20981: * (XR) SORTED ARRAY ! 20982: * (XL,WA,WB,WC) DESTROYED ! 20983: EJC ! 20984: * ! 20985: * SORTA (CONTINUED) ! 20986: * ! 20987: SORTA PRC N,0 ENTRY POINT ! 20988: MOV WA,SRTSR SORT/RSORT INDICATOR ! 20989: MOV *NUM01,SRTST DEFAULT STRIDE OF 1 ! 20990: ZER SRTOF DEFAULT ZERO OFFSET TO SORT KEY ! 20991: MOV =NULLS,SRTDF CLEAR DATATYPE FIELD NAME ! 20992: MOV (XS)+,R$SXR UNSTACK ARGUMENT 2 ! 20993: MOV (XS)+,XR GET FIRST ARGUMENT ! 20994: JSR GTARR CONVERT TO ARRAY ! 20995: PPM SRT16 FAIL ! 20996: MOV XR,-(XS) STACK PTR TO RESULTING KEY ARRAY ! 20997: MOV XR,-(XS) ANOTHER COPY FOR COPYB ! 20998: JSR COPYB GET COPY ARRAY FOR SORTING INTO ! 20999: PPM CANT FAIL ! 21000: MOV XR,-(XS) STACK POINTER TO SORT ARRAY ! 21001: MOV R$SXR,XR GET SECOND ARG ! 21002: MOV 1(XS),XL GET PTR TO KEY ARRAY ! 21003: BNE (XL),=B$VCT,SRT02 JUMP IF ARBLK ! 21004: BEQ XR,=NULLS,SRT01 JUMP IF NULL SECOND ARG ! 21005: JSR GTNVR GET VRBLK PTR FOR IT ! 21006: ERR 257,ERRONEOUS 2ND ARG IN SORT/RSORT OF VECTOR ! 21007: MOV XR,SRTDF STORE DATATYPE FIELD NAME VRBLK ! 21008: * ! 21009: * COMPUTE N AND OFFSET TO ITEM A(0) IN VECTOR CASE ! 21010: * ! 21011: SRT01 MOV *VCLEN,WC OFFSET TO A(0) ! 21012: MOV *VCVLS,WB OFFSET TO FIRST ITEM ! 21013: MOV VCLEN(XL),WA GET BLOCK LENGTH ! 21014: SUB *VCSI$,WA GET NO. OF ENTRIES, N (IN BYTES) ! 21015: BRN SRT04 MERGE ! 21016: * ! 21017: * HERE FOR ARRAY ! 21018: * ! 21019: SRT02 LDI ARDIM(XL) GET POSSIBLE DIMENSION ! 21020: MFI WA CONVERT TO SHORT INTEGER ! 21021: WTB WA FURTHER CONVERT TO BAUS ! 21022: MOV *ARVLS,WB OFFSET TO FIRST VALUE IF ONE ! 21023: MOV *ARPRO,WC OFFSET BEFORE VALUES IF ONE DIM. ! 21024: BEQ ARNDM(XL),=NUM01,SRT04 JUMP IN FACT IF ONE DIM. ! 21025: BNE ARNDM(XL),=NUM02,SRT16 FAIL UNLESS TWO DIMENS ! 21026: LDI ARLB2(XL) GET LOWER BOUND 2 AS DEFAULT ! 21027: BEQ XR,=NULLS,SRT03 JUMP IF DEFAULT SECOND ARG ! 21028: JSR GTINT CONVERT TO INTEGER ! 21029: PPM SRT17 FAIL ! 21030: LDI ICVAL(XR) GET ACTUAL INTEGER VALUE ! 21031: EJC ! 21032: * ! 21033: * SORTA (CONTINUED) ! 21034: * ! 21035: * HERE WITH SORT COLUMN INDEX IN IA IN ARRAY CASE ! 21036: * ! 21037: SRT03 SBI ARLB2(XL) SUBTRACT LOW BOUND ! 21038: IOV SRT17 FAIL IF OVERFLOW ! 21039: ILT SRT17 FAIL IF BELOW LOW BOUND ! 21040: SBI ARDM2(XL) CHECK AGAINST DIMENSION ! 21041: IGE SRT17 FAIL IF TOO LARGE ! 21042: ADI ARDM2(XL) RESTORE VALUE ! 21043: MFI WA GET AS SMALL INTEGER ! 21044: WTB WA OFFSET WITHIN ROW TO KEY ! 21045: MOV WA,SRTOF KEEP OFFSET ! 21046: LDI ARDM2(XL) SECOND DIMENSION IS ROW LENGTH ! 21047: MFI WA CONVERT TO SHORT INTEGER ! 21048: MOV WA,XR COPY ROW LENGTH ! 21049: WTB WA CONVERT TO BYTES ! 21050: MOV WA,SRTST STORE AS STRIDE ! 21051: LDI ARDIM(XL) GET NUMBER OF ROWS ! 21052: MFI WA AS A SHORT INTEGER ! 21053: WTB WA CONVERT N TO BAUS ! 21054: MOV ARLEN(XL),WC OFFSET PAST ARRAY END ! 21055: SUB WA,WC ADJUST, GIVING SPACE FOR N OFFSETS ! 21056: DCA WC POINT TO A(0) ! 21057: MOV AROFS(XL),WB OFFSET TO WORD BEFORE FIRST ITEM ! 21058: ICA WB OFFSET TO FIRST ITEM ! 21059: * ! 21060: * SEPARATE PRE-PROCESSING FOR ARRAYS AND VECTORS DONE. ! 21061: * TO SIMPLIFY LATER KEY COMPARISONS, REMOVAL OF ANY TRBLK ! 21062: * TRAP BLOCKS FROM ENTRIES IN KEY ARRAY IS EFFECTED. ! 21063: * ! 21064: * (XL) = 1(XS) = POINTER TO KEY ARRAY ! 21065: * (XS) = POINTER TO SORT ARRAY ! 21066: * WA = NUMBER OF ITEMS, N (CONVERTED TO BYTES). ! 21067: * WB = OFFSET TO FIRST ITEM OF ARRAYS. ! 21068: * WC = OFFSET TO A(0) ! 21069: * ! 21070: SRT04 BLE WA,*NUM01,SRT15 RETURN IF ONLY A SINGLE ITEM ! 21071: MOV WA,SRTSN STORE NUMBER OF ITEMS (IN BAUS) ! 21072: MOV WC,SRTSO STORE OFFSET TO A(0) ! 21073: MOV ARLEN(XL),WC LENGTH OF ARRAY OR VEC (=VCLEN) ! 21074: ADD XL,WC POINT PAST END OF ARRAY OR VECTOR ! 21075: MOV WB,SRTSF STORE OFFSET TO FIRST ROW ! 21076: ADD WB,XL POINT TO FIRST ITEM IN KEY ARRAY ! 21077: * ! 21078: * LOOP THROUGH ARRAY ! 21079: * ! 21080: SRT05 MOV (XL),XR GET AN ENTRY ! 21081: * ! 21082: * HUNT ALONG TRBLK CHAIN ! 21083: * ! 21084: SRT06 BNE (XR),=B$TRT,SRT07 JUMP OUT IF NOT TRBLK ! 21085: MOV TRVAL(XR),XR GET VALUE FIELD ! 21086: BRN SRT06 LOOP ! 21087: EJC ! 21088: * ! 21089: * SORTA (CONTINUED) ! 21090: * ! 21091: * XR IS VALUE FROM END OF CHAIN ! 21092: * ! 21093: SRT07 MOV XR,(XL)+ STORE AS ARRAY ENTRY ! 21094: BLT XL,WC,SRT05 LOOP IF NOT DONE ! 21095: MOV (XS),XL GET ADRS OF SORT ARRAY ! 21096: MOV SRTSF,XR INITIAL OFFSET TO FIRST KEY ! 21097: MOV SRTST,WB GET STRIDE ! 21098: ADD SRTSO,XL OFFSET TO A(0) ! 21099: ICA XL POINT TO A(1) ! 21100: MOV SRTSN,WC GET N ! 21101: BTW WC CONVERT FROM BYTES ! 21102: MOV WC,SRTNR STORE AS ROW COUNT ! 21103: LCT WC,WC LOOP COUNTER ! 21104: * ! 21105: * STORE KEY OFFSETS AT TOP OF SORT ARRAY ! 21106: * ! 21107: SRT08 MOV XR,(XL)+ STORE AN OFFSET ! 21108: ADD WB,XR BUMP OFFSET BY STRIDE ! 21109: BCT WC,SRT08 LOOP THROUGH ROWS ! 21110: * ! 21111: * PERFORM THE SORT ON OFFSETS IN SORT ARRAY. ! 21112: * ! 21113: * (SRTSN) NUMBER OF ITEMS TO SORT, N (BYTES) ! 21114: * (SRTSO) OFFSET TO A(0) ! 21115: * ! 21116: SRT09 MOV SRTSN,WA GET N ! 21117: MOV SRTNR,WC GET NUMBER OF ROWS ! 21118: RSH WC,1 I = N / 2 (WC=I, INDEX INTO ARRAY) ! 21119: WTB WC CONVERT BACK TO BYTES ! 21120: * ! 21121: * LOOP TO FORM INITIAL HEAP ! 21122: * ! 21123: SRT10 JSR SORTH SORTH(I,N) ! 21124: DCA WC I = I - 1 ! 21125: BNZ WC,SRT10 LOOP IF I GT 0 ! 21126: MOV WA,WC I = N ! 21127: * ! 21128: * SORTING LOOP. AT THIS POINT, A(1) IS THE LARGEST ! 21129: * ITEM, SINCE ALGORITHM INITIALISES IT AS, AND THEN MAINTAI ! 21130: * IT AS, ROOT OF TREE. ! 21131: * ! 21132: SRT11 DCA WC I = I - 1 (N - 1 INITIALLY) ! 21133: BZE WC,SRT12 JUMP IF DONE ! 21134: MOV (XS),XR GET SORT ARRAY ADDRESS ! 21135: ADD SRTSO,XR POINT TO A(0) ! 21136: MOV XR,XL A(0) ADDRESS ! 21137: ADD WC,XL A(I) ADDRESS ! 21138: MOV 1(XL),WB COPY A(I+1) ! 21139: MOV 1(XR),1(XL) MOVE A(1) TO A(I+1) ! 21140: MOV WB,1(XR) COMPLETE EXCHANGE OF A(1), A(I+1) ! 21141: MOV WC,WA N = I FOR SORTH ! 21142: MOV *NUM01,WC I = 1 FOR SORTH ! 21143: JSR SORTH SORTH(1,N) ! 21144: MOV WA,WC RESTORE WC ! 21145: BRN SRT11 LOOP ! 21146: EJC ! 21147: * ! 21148: * SORTA (CONTINUED) ! 21149: * ! 21150: * OFFSETS HAVE BEEN PERMUTED INTO REQUIRED ORDER BY SORT. ! 21151: * COPY ARRAY ELEMENTS OVER THEM. ! 21152: * ! 21153: SRT12 MOV (XS),XL BASE ADRS OF KEY ARRAY ! 21154: MOV XL,WC COPY IT ! 21155: ADD SRTSO,WC OFFSET OF A(0) ! 21156: ADD SRTSF,XL ADRS OF FIRST ROW OF SORT ARRAY ! 21157: MOV SRTST,WB GET STRIDE ! 21158: BTW WB CONVERT TO WORDS ! 21159: * ! 21160: * COPYING LOOP FOR SUCCESSIVE ITEMS. SORTED OFFSETS ARE ! 21161: * HELD AT END OF SORT ARRAY. ! 21162: * ! 21163: SRT13 ICA WC ADRS OF NEXT OF SORTED OFFSETS ! 21164: MOV WC,XR COPY IT FOR ACCESS ! 21165: MOV (XR),XR GET OFFSET ! 21166: ADD 1(XS),XR ADD KEY ARRAY BASE ADRS ! 21167: LCT WA,WB GET COUNT OF WORDS IN ROW ! 21168: * ! 21169: * COPY A COMPLETE ROW ! 21170: * ! 21171: SRT14 MOV (XR)+,(XL)+ MOVE A WORD ! 21172: BCT WA,SRT14 LOOP ! 21173: DCV SRTNR DECREMENT ROW COUNT ! 21174: BNZ SRTNR,SRT13 REPEAT TILL ALL ROWS DONE ! 21175: * ! 21176: * RETURN POINT ! 21177: * ! 21178: SRT15 MOV (XS)+,XR POP RESULT ARRAY PTR ! 21179: ICA XS POP KEY ARRAY PTR ! 21180: ZER R$SXL CLEAR JUNK ! 21181: ZER R$SXR CLEAR JUNK ! 21182: EXI RETURN ! 21183: * ! 21184: * ERROR POINT ! 21185: * ! 21186: SRT16 ERB 256,SORT/RSORT 1ST ARG NOT SUITABLE ARRAY OR TABLE ! 21187: SRT17 ERB 258,SORT/RSORT 2ND ARG OUT OF RANGE OR NON-INTEGER ! 21188: ENP END PROCUDURE SORTA ! 21189: EJC ! 21190: * ! 21191: * SORTC -- COMPARE SORT KEYS ! 21192: * ! 21193: * COMPARE TWO SORT KEYS GIVEN THEIR OFFSETS. IF ! 21194: * EQUAL, COMPARE KEY OFFSETS TO GIVE STABLE SORT. ! 21195: * NOTE THAT IF SRTSR IS NON-ZERO (REQUEST FOR REVERSE ! 21196: * SORT), THE QUOTED RETURNS ARE INVERTED. ! 21197: * FOR OBJECTS OF DIFFERING DATATYPES, THE ENTRY POINT ! 21198: * IDENTIFICATIONS ARE COMPARED. ! 21199: * ! 21200: * (XL) BASE ADRS FOR KEYS ! 21201: * (WA) OFFSET TO KEY 1 ITEM ! 21202: * (WB) OFFSET TO KEY 2 ITEM ! 21203: * (SRTSR) ZERO/NON-ZERO FOR SORT/RSORT ! 21204: * (SRTOF) OFFSET WITHIN ROW TO COMPARANDS ! 21205: * JSR SORTC CALL TO COMPARE KEYS ! 21206: * PPM LOC KEY1 LESS THAN KEY2 ! 21207: * NORMAL RETURN, KEY1 GT THAN KEY2 ! 21208: * (XL,XR,WA,WB) DESTROYED ! 21209: * ! 21210: SORTC PRC E,1 ENTRY POINT ! 21211: MOV WA,SRTS1 SAVE OFFSET 1 ! 21212: MOV WB,SRTS2 SAVE OFFSET 2 ! 21213: MOV WC,SRTSC SAVE WC ! 21214: ADD SRTOF,XL ADD OFFSET TO COMPARAND FIELD ! 21215: MOV XL,XR COPY BASE + OFFSET ! 21216: ADD WA,XL ADD KEY1 OFFSET ! 21217: ADD WB,XR ADD KEY2 OFFSET ! 21218: MOV (XL),XL GET KEY1 ! 21219: MOV (XR),XR GET KEY2 ! 21220: BNE SRTDF,=NULLS,SRC11 JUMP IF DATATYPE FIELD NAME USED ! 21221: EJC ! 21222: * ! 21223: * SORTC (CONTINUED) ! 21224: * ! 21225: * MERGE AFTER DEALING WITH FIELD NAME. TRY FOR STRINGS. ! 21226: * ! 21227: SRC01 MOV (XL),WC GET TYPE CODE ! 21228: BNE WC,(XR),SRC02 SKIP IF NOT SAME DATATYPE ! 21229: BEQ WC,=B$SCL,SRC09 JUMP IF BOTH STRINGS ! 21230: * ! 21231: * NOW TRY FOR NUMERIC ! 21232: * ! 21233: SRC02 MOV XL,R$SXL KEEP ARG1 ! 21234: MOV XR,R$SXR KEEP ARG2 ! 21235: MOV XL,-(XS) STACK ! 21236: MOV XR,-(XS) ARGS ! 21237: JSR ACOMP COMPARE OBJECTS ! 21238: PPM SRC10 NOT NUMERIC ! 21239: PPM SRC10 NOT NUMERIC ! 21240: PPM SRC03 KEY1 LESS ! 21241: PPM SRC08 KEYS EQUAL ! 21242: PPM SRC05 KEY1 GREATER ! 21243: * ! 21244: * RETURN IF KEY1 SMALLER (SORT), GREATER (RSORT) ! 21245: * ! 21246: SRC03 BNZ SRTSR,SRC06 JUMP IF RSORT ! 21247: * ! 21248: SRC04 MOV SRTSC,WC RESTORE WC ! 21249: EXI 1 RETURN ! 21250: * ! 21251: * RETURN IF KEY1 GREATER (SORT), SMALLER (RSORT) ! 21252: * ! 21253: SRC05 BNZ SRTSR,SRC04 JUMP IF RSORT ! 21254: * ! 21255: SRC06 MOV SRTSC,WC RESTORE WC ! 21256: EXI RETURN ! 21257: * ! 21258: * KEYS ARE OF SAME DATATYPE ! 21259: * ! 21260: SRC07 BLT XL,XR,SRC03 ITEM FIRST CREATED IS LESS ! 21261: BGT XL,XR,SRC05 ADDRESSES RISE IN ORDER OF CREATION ! 21262: * ! 21263: * DROP THROUGH OR MERGE FOR IDENTICAL OR EQUAL OBJECTS ! 21264: * ! 21265: SRC08 BLT SRTS1,SRTS2,SRC04 TEST OFFSETS OR KEY ADDRSS INSTEAD ! 21266: BRN SRC06 OFFSET 1 GREATER ! 21267: EJC ! 21268: * ! 21269: * SORTC (CONTINUED) ! 21270: * ! 21271: * STRINGS ! 21272: * ! 21273: SRC09 MOV XL,-(XS) STACK ! 21274: MOV XR,-(XS) ARGS ! 21275: JSR LCOMP COMPARE OBJECTS ! 21276: PPM CANT ! 21277: PPM FAIL ! 21278: PPM SRC03 KEY1 LESS ! 21279: PPM SRC08 KEYS EQUAL ! 21280: PPM SRC05 KEY1 GREATER ! 21281: * ! 21282: * ARITHMETIC COMPARISON FAILED - RECOVER ARGS ! 21283: * ! 21284: SRC10 MOV R$SXL,XL GET ARG1 ! 21285: MOV R$SXR,XR GET ARG2 ! 21286: MOV (XL),WC GET TYPE OF KEY1 ! 21287: BEQ WC,(XR),SRC07 JUMP IF KEYS OF SAME TYPE ! 21288: MOV WC,XL GET BLOCK TYPE WORD ! 21289: MOV (XR),XR GET BLOCK TYPE WORD ! 21290: LEI XL ENTRY POINT ID FOR KEY1 ! 21291: LEI XR ENTRY POINT ID FOR KEY2 ! 21292: BGT XL,XR,SRC05 JUMP IF KEY1 GT KEY2 ! 21293: BRN SRC03 KEY1 LT KEY2 ! 21294: * ! 21295: * DATATYPE FIELD NAME USED ! 21296: * ! 21297: SRC11 JSR SORTF CALL ROUTINE TO FIND FIELD 1 ! 21298: MOV XL,-(XS) STACK ITEM POINTER ! 21299: MOV XR,XL GET KEY2 ! 21300: JSR SORTF FIND FIELD 2 ! 21301: MOV XL,XR PLACE AS KEY2 ! 21302: MOV (XS)+,XL RECOVER KEY1 ! 21303: BRN SRC01 MERGE ! 21304: ENP PROCEDURE SORTC ! 21305: EJC ! 21306: * ! 21307: * SORTF -- FIND FIELD FOR SORTC ! 21308: * ! 21309: * ROUTINE USED BY SORTC TO OBTAIN ITEM CORRESPONDING ! 21310: * TO A GIVEN FIELD NAME, IF THIS EXISTS, IN A PROGRAMMER ! 21311: * DEFINED OBJECT PASSED AS ARGUMENT. ! 21312: * IF SUCH A MATCH OCCURS, RECORD IS KEPT OF DATATYPE ! 21313: * NAME, FIELD NAME AND OFFSET TO FIELD IN ORDER TO ! 21314: * SHORT-CIRCUIT LATER SEARCHES ON SAME TYPE. NOTE THAT ! 21315: * DFBLKS ARE STORED IN STATIC AND HENCE CANNOT BE MOVED. ! 21316: * ! 21317: * (SRTDF) VRBLK POINTER OF FIELD NAME ! 21318: * (XL) POSSIBLE PDBLK POINTER ! 21319: * JSR SORTF CALL TO SEARCH FOR FIELD NAME ! 21320: * (XL) ITEM FOUND OR ORIGINAL PDBLK PTR ! 21321: * (WC) DESTROYED ! 21322: * ! 21323: SORTF PRC E,0 ENTRY POINT ! 21324: BNE (XL),=B$PDT,SRTF3 RETURN IF NOT PDBLK ! 21325: MOV XR,-(XS) KEEP XR ! 21326: MOV SRTFD,XR GET POSSIBLE FORMER DFBLK PTR ! 21327: BZE XR,SRTF4 JUMP IF NOT ! 21328: BNE XR,PDDFP(XL),SRTF4 JUMP IF NOT RIGHT DATATYPE ! 21329: BNE SRTDF,SRTFF,SRTF4 JUMP IF NOT RIGHT FIELD NAME ! 21330: ADD SRTFO,XL ADD OFFSET TO REQUIRED FIELD ! 21331: * ! 21332: * HERE WITH XL POINTING TO FOUND FIELD ! 21333: * ! 21334: SRTF1 MOV (XL),XL GET ITEM FROM FIELD ! 21335: * ! 21336: * RETURN POINT ! 21337: * ! 21338: SRTF2 MOV (XS)+,XR RESTORE XR ! 21339: * ! 21340: SRTF3 EXI RETURN ! 21341: EJC ! 21342: * ! 21343: * SORTF (CONTINUED) ! 21344: * ! 21345: * CONDUCT A SEARCH ! 21346: * ! 21347: SRTF4 MOV XL,XR COPY ORIGINAL POINTER ! 21348: MOV PDDFP(XR),XR POINT TO DFBLK ! 21349: MOV XR,SRTFD KEEP A COPY ! 21350: MOV FARGS(XR),WC GET NUMBER OF FIELDS ! 21351: WTB WC CONVERT TO BYTES ! 21352: ADD DFLEN(XR),XR POINT PAST LAST FIELD ! 21353: * ! 21354: * LOOP TO FIND NAME IN PDFBLK ! 21355: * ! 21356: SRTF5 DCA WC COUNT DOWN ! 21357: DCA XR POINT IN FRONT ! 21358: BEQ (XR),SRTDF,SRTF6 SKIP OUT IF FOUND ! 21359: BNZ WC,SRTF5 LOOP ! 21360: BRN SRTF2 RETURN - NOT FOUND ! 21361: * ! 21362: * FOUND ! 21363: * ! 21364: SRTF6 MOV (XR),SRTFF KEEP FIELD NAME PTR ! 21365: ADD *PDFLD,WC ADD OFFSET TO FIRST FIELD ! 21366: MOV WC,SRTFO STORE AS FIELD OFFSET ! 21367: ADD WC,XL POINT TO FIELD ! 21368: BRN SRTF1 RETURN ! 21369: ENP PROCEDURE SORTF ! 21370: EJC ! 21371: * ! 21372: * SORTH -- HEAP ROUTINE FOR SORTA ! 21373: * ! 21374: * THIS ROUTINE CONSTRUCTS A HEAP FROM ELEMENTS OF ARRAY, A. ! 21375: * IN THIS APPLICATION, THE ELEMENTS ARE OFFSETS TO KEYS IN ! 21376: * A KEY ARRAY. ! 21377: * ! 21378: * (XS) POINTER TO SORT ARRAY BASE ! 21379: * 1(XS) POINTER TO KEY ARRAY BASE ! 21380: * (WA) MAX ARRAY INDEX, N (IN BYTES) ! 21381: * (WC) OFFSET J IN A TO ROOT (IN *1 TO *N) ! 21382: * JSR SORTH CALL SORTH(J,N) TO MAKE HEAP ! 21383: * (XL,XR,WB) DESTROYED ! 21384: * ! 21385: SORTH PRC N,0 ENTRY POINT ! 21386: MOV WA,SRTSN SAVE N ! 21387: MOV WC,SRTWC KEEP WC ! 21388: MOV (XS),XL SORT ARRAY BASE ADRS ! 21389: ADD SRTSO,XL ADD OFFSET TO A(0) ! 21390: ADD WC,XL POINT TO A(J) ! 21391: MOV (XL),SRTRT GET OFFSET TO ROOT ! 21392: ADD WC,WC DOUBLE J - CANT EXCEED N ! 21393: * ! 21394: * LOOP TO MOVE DOWN TREE USING DOUBLED INDEX J ! 21395: * ! 21396: SRH01 BGT WC,SRTSN,SRH03 DONE IF J GT N ! 21397: BEQ WC,SRTSN,SRH02 SKIP IF J EQUALS N ! 21398: MOV (XS),XR SORT ARRAY BASE ADRS ! 21399: MOV 1(XS),XL KEY ARRAY BASE ADRS ! 21400: ADD SRTSO,XR POINT TO A(0) ! 21401: ADD WC,XR ADRS OF A(J) ! 21402: MOV 1(XR),WA GET A(J+1) ! 21403: MOV (XR),WB GET A(J) ! 21404: * ! 21405: * COMPARE SONS. (WA) RIGHT SON, (WB) LEFT SON ! 21406: * ! 21407: JSR SORTC COMPARE KEYS - LT(A(J+1),A(J)) ! 21408: PPM SRH02 A(J+1) LT A(J) ! 21409: ICA WC POINT TO GREATER SON, A(J+1) ! 21410: EJC ! 21411: * ! 21412: * SORTH (CONTINUED) ! 21413: * ! 21414: * COMPARE ROOT WITH GREATER SON ! 21415: * ! 21416: SRH02 MOV 1(XS),XL KEY ARRAY BASE ADRS ! 21417: MOV (XS),XR GET SORT ARRAY ADDRESS ! 21418: ADD SRTSO,XR ADRS OF A(0) ! 21419: MOV XR,WB COPY THIS ADRS ! 21420: ADD WC,XR ADRS OF GREATER SON, A(J) ! 21421: MOV (XR),WA GET A(J) ! 21422: MOV WB,XR POINT BACK TO A(0) ! 21423: MOV SRTRT,WB GET ROOT ! 21424: JSR SORTC COMPARE THEM - LT(A(J),ROOT) ! 21425: PPM SRH03 FATHER EXCEEDS SONS - DONE ! 21426: MOV (XS),XR GET SORT ARRAY ADRS ! 21427: ADD SRTSO,XR POINT TO A(0) ! 21428: MOV XR,XL COPY IT ! 21429: MOV WC,WA COPY J ! 21430: BTW WC CONVERT TO WORDS ! 21431: RSH WC,1 GET J/2 ! 21432: WTB WC CONVERT BACK TO BYTES ! 21433: ADD WA,XL POINT TO A(J) ! 21434: ADD WC,XR ADRS OF A(J/2) ! 21435: MOV (XL),(XR) A(J/2) = A(J) ! 21436: MOV WA,WC RECOVER J ! 21437: AOV WC,WC,SRH03 J = J*2. DONE IF TOO BIG ! 21438: BRN SRH01 LOOP ! 21439: * ! 21440: * FINISH BY COPYING ROOT OFFSET BACK INTO ARRAY ! 21441: * ! 21442: SRH03 BTW WC CONVERT TO WORDS ! 21443: RSH WC,1 J = J/2 ! 21444: WTB WC CONVERT BACK TO BYTES ! 21445: MOV (XS),XR SORT ARRAY ADRS ! 21446: ADD SRTSO,XR ADRS OF A(0) ! 21447: ADD WC,XR ADRS OF A(J/2) ! 21448: MOV SRTRT,(XR) A(J/2) = ROOT ! 21449: MOV SRTSN,WA RESTORE WA ! 21450: MOV SRTWC,WC RESTORE WC ! 21451: EXI RETURN ! 21452: ENP END PROCEDURE SORTH ! 21453: EJC ! 21454: EJC ! 21455: * ! 21456: * TFIND -- LOCATE TABLE ELEMENT ! 21457: * ! 21458: * (XR) SUBSCRIPT VALUE FOR ELEMENT ! 21459: * (XL) POINTER TO TABLE ! 21460: * (WB) ZERO BY VALUE, NON-ZERO BY NAME ! 21461: * JSR TFIND CALL TO LOCATE ELEMENT ! 21462: * PPM LOC TRANSFER LOCATION IF ACCESS FAILS ! 21463: * (XR) ELEMENT VALUE (IF BY VALUE) ! 21464: * (XR) DESTROYED (IF BY NAME) ! 21465: * (XL,WA) TEBLK NAME (IF BY NAME) ! 21466: * (XL,WA) DESTROYED (IF BY VALUE) ! 21467: * (WC,RA) DESTROYED ! 21468: * ! 21469: * NOTE THAT IF A CALL BY VALUE SPECIFIES A NON-EXISTENT ! 21470: * SUBSCRIPT, NULL IS RETURNED WITHOUT BUILDING A NEW TEBLK. ! 21471: * ! 21472: TFIND PRC E,1 ENTRY POINT ! 21473: MOV WB,-(XS) SAVE NAME/VALUE INDICATOR ! 21474: MOV XR,-(XS) SAVE SUBSCRIPT VALUE ! 21475: MOV XL,-(XS) SAVE TABLE POINTER ! 21476: MOV TBLEN(XL),WA LOAD LENGTH OF TBBLK ! 21477: BTW WA CONVERT TO WORD COUNT ! 21478: SUB =TBBUK,WA GET NUMBER OF BUCKETS ! 21479: MTI WA CONVERT TO INTEGER VALUE ! 21480: STI TFNSI SAVE FOR LATER ! 21481: MOV (XR),XL LOAD FIRST WORD OF SUBSCRIPT ! 21482: LEI XL LOAD BLOCK ENTRY ID (BL$XX) ! 21483: BSW XL,BL$$D,TFN00 SWITCH ON BLOCK TYPE ! 21484: IFF BL$IC,TFN02 JUMP IF INTEGER ! 21485: IFF BL$RC,TFN02 REAL ! 21486: IFF BL$P0,TFN03 JUMP IF PATTERN ! 21487: IFF BL$P1,TFN03 JUMP IF PATTERN ! 21488: IFF BL$P2,TFN03 JUMP IF PATTERN ! 21489: IFF BL$NM,TFN04 JUMP IF NAME ! 21490: IFF BL$SC,TFN05 JUMP IF STRING ! 21491: ESW END SWITCH ON BLOCK TYPE ! 21492: * ! 21493: * HERE FOR BLOCKS FOR WHICH WE USE THE SECOND WORD OF THE ! 21494: * BLOCK AS THE HASH SOURCE (SEE BLOCK FORMATS FOR DETAILS). ! 21495: * ! 21496: TFN00 MOV 1(XR),WA LOAD SECOND WORD ! 21497: * ! 21498: * MERGE HERE WITH ONE WORD HASH SOURCE IN WA ! 21499: * ! 21500: TFN01 MTI WA CONVERT TO INTEGER ! 21501: BRN TFN06 JUMP TO MERGE ! 21502: EJC ! 21503: * ! 21504: * TFIND (CONTINUED) ! 21505: * ! 21506: * HERE FOR INTEGER OR REAL ! 21507: * ! 21508: TFN02 LDI 1(XR) LOAD VALUE AS HASH SOURCE ! 21509: IGE TFN06 OK IF POSITIVE OR ZERO ! 21510: NGI MAKE POSITIVE ! 21511: IOV TFN06 CLEAR POSSIBLE OVERFLOW ! 21512: BRN TFN06 MERGE ! 21513: * ! 21514: * FOR PATTERN, USE FIRST WORD (PCODE) AS SOURCE ! 21515: * ! 21516: TFN03 MOV (XR),WA LOAD FIRST WORD AS HASH SOURCE ! 21517: BRN TFN01 MERGE BACK ! 21518: * ! 21519: * FOR NAME, USE OFFSET AS HASH SOURCE ! 21520: * ! 21521: TFN04 MOV NMOFS(XR),WA LOAD OFFSET AS HASH SOURCE ! 21522: BRN TFN01 MERGE BACK ! 21523: * ! 21524: * HERE FOR STRING ! 21525: * ! 21526: TFN05 JSR HASHS CALL ROUTINE TO COMPUTE HASH ! 21527: * ! 21528: * MERGE HERE WITH HASH SOURCE IN (IA) ! 21529: * ! 21530: TFN06 RMI TFNSI COMPUTE HASH INDEX BY REMAINDERING ! 21531: MFI WC GET AS ONE WORD INTEGER ! 21532: WTB WC CONVERT TO BYTE OFFSET ! 21533: MOV (XS),XL GET TABLE PTR AGAIN ! 21534: ADD WC,XL POINT TO PROPER BUCKET ! 21535: MOV TBBUK(XL),XR LOAD FIRST TEBLK POINTER ! 21536: BEQ XR,(XS),TFN10 JUMP IF NO TEBLKS ON CHAIN ! 21537: * ! 21538: * LOOP THROUGH TEBLKS ON HASH CHAIN ! 21539: * ! 21540: TFN07 MOV XR,WB SAVE TEBLK POINTER ! 21541: MOV TESUB(XR),XR LOAD SUBSCRIPT VALUE ! 21542: MOV 1(XS),XL LOAD INPUT ARGUMENT SUBSCRIPT VAL ! 21543: JSR IDENT COMPARE THEM ! 21544: PPM TFN08 JUMP IF EQUAL (IDENT) ! 21545: * ! 21546: * HERE IF NO MATCH WITH THAT TEBLK ! 21547: * ! 21548: MOV WB,XL RESTORE TEBLK POINTER ! 21549: MOV TENXT(XL),XR POINT TO NEXT TEBLK ON CHAIN ! 21550: BNE XR,(XS),TFN07 JUMP IF THERE IS ONE ! 21551: * ! 21552: * HERE IF NO MATCH WITH ANY TEBLK ON CHAIN ! 21553: * ! 21554: MOV *TENXT,WC SET OFFSET TO LINK FIELD (XL BASE) ! 21555: BRN TFN11 JUMP TO MERGE ! 21556: EJC ! 21557: * ! 21558: * TFIND (CONTINUED) ! 21559: * ! 21560: * HERE WE HAVE FOUND A MATCHING ELEMENT ! 21561: * ! 21562: TFN08 MOV WB,XL RESTORE TEBLK POINTER ! 21563: MOV *TEVAL,WA SET TEBLK NAME OFFSET ! 21564: MOV 2(XS),WB RESTORE NAME/VALUE INDICATOR ! 21565: BNZ WB,TFN09 JUMP IF CALLED BY NAME ! 21566: JSR ACESS ELSE GET VALUE ! 21567: PPM TFN12 JUMP IF REFERENCE FAILS ! 21568: ZER WB RESTORE NAME/VALUE INDICATOR ! 21569: * ! 21570: * COMMON EXIT FOR ENTRY FOUND ! 21571: * ! 21572: TFN09 ADD *NUM03,XS POP STACK ENTRIES ! 21573: EXI RETURN TO TFIND CALLER ! 21574: * ! 21575: * HERE IF NO TEBLKS ON THE HASH CHAIN ! 21576: * ! 21577: TFN10 ADD *TBBUK,WC GET OFFSET TO BUCKET PTR ! 21578: MOV (XS),XL SET TBBLK PTR AS BASE ! 21579: * ! 21580: * MERGE HERE WITH (XL,WC) BASE,OFFSET OF FINAL LINK ! 21581: * ! 21582: TFN11 MOV (XS),XR TBBLK POINTER ! 21583: MOV TBINV(XR),XR LOAD DEFAULT VALUE IN CASE ! 21584: MOV 2(XS),WB LOAD NAME/VALUE INDICATOR ! 21585: BZE WB,TFN09 EXIT WITH DEFAULT IF VALUE CALL ! 21586: * ! 21587: * HERE WE MUST BUILD A NEW TEBLK ! 21588: * ! 21589: MOV *TESI$,WA SET SIZE OF TEBLK ! 21590: JSR ALLOC ALLOCATE TEBLK ! 21591: ADD WC,XL POINT TO HASH LINK ! 21592: MOV XR,(XL) LINK NEW TEBLK AT END OF CHAIN ! 21593: MOV =B$TET,(XR) STORE TYPE WORD ! 21594: MOV =NULLS,TEVAL(XR) SET NULL AS INITIAL VALUE ! 21595: MOV (XS)+,TENXT(XR) SET TBBLK PTR TO MARK END OF CHAIN ! 21596: MOV (XS)+,TESUB(XR) STORE SUBSCRIPT VALUE ! 21597: ICA XS POP PAST NAME/VALUE INDICATOR ! 21598: MOV XR,XL COPY TEBLK POINTER (NAME BASE) ! 21599: MOV *TEVAL,WA SET OFFSET ! 21600: EXI RETURN TO CALLER WITH NEW TEBLK ! 21601: * ! 21602: * ACESS FAIL RETURN ! 21603: * ! 21604: TFN12 EXI 1 ALTERNATIVE RETURN ! 21605: ENP END PROCEDURE TFIND ! 21606: EJC ! 21607: * ! 21608: * TRACE -- SET/RESET A TRACE ASSOCIATION ! 21609: * ! 21610: * THIS PROCEDURE IS SHARED BY TRACE AND STOPTR TO ! 21611: * EITHER INITIATE OR STOP A TRACE RESPECTIVELY. ! 21612: * ! 21613: * (XL) TRBLK PTR (TRACE) OR ZERO (STOPTR) ! 21614: * 1(XS) FIRST ARGUMENT (NAME) ! 21615: * 0(XS) SECOND ARGUMENT (TRACE TYPE) ! 21616: * JSR TRACE CALL TO SET/RESET TRACE ! 21617: * PPM LOC TRANSFER LOC IF 1ST ARG IS BAD NAME ! 21618: * PPM LOC TRANSFER LOC IF 2ND ARG IS BAD TYPE ! 21619: * (XS) POPPED ! 21620: * (XL,XR,WA,WB,WC,IA) DESTROYED ! 21621: * ! 21622: TRACE PRC N,2 ENTRY POINT ! 21623: JSR GTSTG GET TRACE TYPE STRING ! 21624: PPM TRC15 JUMP IF NOT STRING ! 21625: PLC XR ELSE POINT TO STRING ! 21626: LCH WA,(XR) LOAD FIRST CHARACTER ! 21627: FLC WA FOLD TO UPPER CASE ! 21628: MOV (XS),XR LOAD NAME ARGUMENT ! 21629: MOV XL,(XS) STACK TRBLK PTR OR ZERO ! 21630: MOV =TRTAC,WC SET TRTYP FOR ACCESS TRACE ! 21631: BEQ WA,=CH$LA,TRC10 JUMP IF A (ACCESS) ! 21632: MOV =TRTVL,WC SET TRTYP FOR VALUE TRACE ! 21633: BEQ WA,=CH$LV,TRC10 JUMP IF V (VALUE) ! 21634: BZE WA,TRC10 JUMP IF BLANK (VALUE) ! 21635: * ! 21636: * HERE FOR L,K,F,C,R ! 21637: * ! 21638: BEQ WA,=CH$LF,TRC01 JUMP IF F (FUNCTION) ! 21639: BEQ WA,=CH$LR,TRC01 JUMP IF R (RETURN) ! 21640: BEQ WA,=CH$LL,TRC03 JUMP IF L (LABEL) ! 21641: BEQ WA,=CH$LK,TRC06 JUMP IF K (KEYWORD) ! 21642: BNE WA,=CH$LC,TRC15 ELSE ERROR IF NOT C (CALL) ! 21643: * ! 21644: * HERE FOR F,C,R ! 21645: * ! 21646: TRC01 JSR GTNVR POINT TO VRBLK FOR NAME ! 21647: PPM TRC16 JUMP IF BAD NAME ! 21648: ICA XS POP STACK ! 21649: MOV VRFNC(XR),XR POINT TO FUNCTION BLOCK ! 21650: BNE (XR),=B$PFC,TRC17 ERROR IF NOT PROGRAM FUNCTION ! 21651: BEQ WA,=CH$LR,TRC02 JUMP IF R (RETURN) ! 21652: EJC ! 21653: * ! 21654: * TRACE (CONTINUED) ! 21655: * ! 21656: * HERE FOR F,C TO SET/RESET CALL TRACE ! 21657: * ! 21658: MOV XL,PFCTR(XR) SET/RESET CALL TRACE ! 21659: BEQ WA,=CH$LC,EXNUL EXIT WITH NULL IF C (CALL) ! 21660: * ! 21661: * HERE FOR F,R TO SET/RESET RETURN TRACE ! 21662: * ! 21663: TRC02 MOV XL,PFRTR(XR) SET/RESET RETURN TRACE ! 21664: EXI RETURN ! 21665: * ! 21666: * HERE FOR L TO SET/RESET LABEL TRACE ! 21667: * ! 21668: TRC03 JSR GTNVR POINT TO VRBLK ! 21669: PPM TRC16 JUMP IF BAD NAME ! 21670: MOV VRLBL(XR),XL LOAD LABEL POINTER ! 21671: BNE (XL),=B$TRT,TRC04 JUMP IF NO OLD TRACE ! 21672: MOV TRLBL(XL),XL ELSE DELETE OLD TRACE ASSOCIATION ! 21673: * ! 21674: * HERE WITH OLD LABEL TRACE ASSOCIATION DELETED ! 21675: * ! 21676: TRC04 BEQ XL,=STNDL,TRC16 ERROR IF UNDEFINED LABEL ! 21677: MOV (XS)+,WB GET TRBLK PTR AGAIN ! 21678: BZE WB,TRC05 JUMP IF STOPTR CASE ! 21679: MOV WB,VRLBL(XR) ELSE SET NEW TRBLK POINTER ! 21680: MOV =B$VRT,VRTRA(XR) SET LABEL TRACE ROUTINE ADDRESS ! 21681: MOV WB,XR COPY TRBLK POINTER ! 21682: MOV XL,TRLBL(XR) STORE REAL LABEL IN TRBLK ! 21683: EXI RETURN ! 21684: * ! 21685: * HERE FOR STOPTR CASE FOR LABEL ! 21686: * ! 21687: TRC05 MOV XL,VRLBL(XR) STORE LABEL PTR BACK IN VRBLK ! 21688: MOV =B$VRG,VRTRA(XR) STORE NORMAL TRANSFER ADDRESS ! 21689: EXI RETURN ! 21690: EJC ! 21691: * ! 21692: * TRACE (CONTINUED) ! 21693: * ! 21694: * HERE FOR K (KEYWORD) ! 21695: * ! 21696: TRC06 JSR GTNVR POINT TO VRBLK ! 21697: PPM TRC16 ERROR IF NOT NATURAL VAR ! 21698: BNZ VRLEN(XR),TRC16 ERROR IF NOT SYSTEM VAR ! 21699: ICA XS POP STACK ! 21700: BZE XL,TRC07 JUMP IF STOPTR CASE ! 21701: MOV XR,TRKVR(XL) STORE VRBLK PTR IN TRBLK FOR KTREX ! 21702: * ! 21703: * MERGE HERE WITH TRBLK SET UP IN WB (OR ZERO) ! 21704: * ! 21705: TRC07 MOV VRSVP(XR),XR POINT TO SVBLK ! 21706: BEQ XR,=V$ERT,TRC08 JUMP IF ERRTYPE ! 21707: BEQ XR,=V$STC,TRC09 JUMP IF STCOUNT ! 21708: BNE XR,=V$FNC,TRC17 ELSE ERROR IF NOT FNCLEVEL ! 21709: * ! 21710: * FNCLEVEL ! 21711: * ! 21712: MOV XL,R$FNC SET/RESET FNCLEVEL TRACE ! 21713: EXI RETURN ! 21714: * ! 21715: * ERRTYPE ! 21716: * ! 21717: TRC08 MOV XL,R$ERT SET/RESET ERRTYPE TRACE ! 21718: EXI RETURN ! 21719: * ! 21720: * STCOUNT ! 21721: * ! 21722: TRC09 MOV XL,R$STC SET/RESET STCOUNT TRACE ! 21723: EXI RETURN ! 21724: EJC ! 21725: * ! 21726: * TRACE (CONTINUED) ! 21727: * ! 21728: * A,V MERGE HERE WITH TRTYP VALUE IN WC ! 21729: * ! 21730: TRC10 JSR GTVAR LOCATE VARIABLE ! 21731: PPM TRC16 ERROR IF NOT APPROPRIATE NAME ! 21732: MOV (XS)+,WB GET NEW TRBLK PTR AGAIN ! 21733: ADD XL,WA POINT TO VARIABLE LOCATION ! 21734: MOV WA,XR COPY VARIABLE POINTER ! 21735: * ! 21736: * LOOP TO SEARCH TRBLK CHAIN ! 21737: * ! 21738: TRC11 MOV (XR),XL POINT TO NEXT ENTRY ! 21739: BNE (XL),=B$TRT,TRC13 JUMP IF NOT TRBLK ! 21740: BLT WC,TRTYP(XL),TRC13 JUMP IF TOO FAR OUT ON CHAIN ! 21741: BEQ WC,TRTYP(XL),TRC12 JUMP IF THIS MATCHES OUR TYPE ! 21742: ADD *TRNXT,XL ELSE POINT TO LINK FIELD ! 21743: MOV XL,XR COPY POINTER ! 21744: BRN TRC11 AND LOOP BACK ! 21745: * ! 21746: * HERE TO DELETE AN OLD TRBLK OF THE TYPE WE WERE GIVEN ! 21747: * ! 21748: TRC12 MOV TRNXT(XL),XL GET PTR TO NEXT BLOCK OR VALUE ! 21749: MOV XL,(XR) STORE TO DELETE THIS TRBLK ! 21750: * ! 21751: * HERE AFTER DELETING ANY OLD ASSOCIATION OF THIS TYPE ! 21752: * ! 21753: TRC13 BZE WB,TRC14 JUMP IF STOPTR CASE ! 21754: MOV WB,(XR) ELSE LINK NEW TRBLK IN ! 21755: MOV WB,XR COPY TRBLK POINTER ! 21756: MOV XL,TRNXT(XR) STORE FORWARD POINTER ! 21757: MOV WC,TRTYP(XR) STORE APPROPRIATE TRAP TYPE CODE ! 21758: * ! 21759: * HERE TO MAKE SURE VRGET,VRSTO ARE SET PROPERLY ! 21760: * ! 21761: TRC14 MOV WA,XR RECALL POSSIBLE VRBLK POINTER ! 21762: SUB *VRVAL,XR POINT BACK TO VRBLK ! 21763: JSR SETVR SET FIELDS IF VRBLK ! 21764: EXI RETURN ! 21765: * ! 21766: * HERE FOR BAD TRACE TYPE ! 21767: * ! 21768: TRC15 EXI 2 TAKE BAD TRACE TYPE ERROR EXIT ! 21769: * ! 21770: * POP STACK BEFORE FAILING ! 21771: * ! 21772: TRC16 ICA XS POP STACK ! 21773: * ! 21774: * HERE FOR BAD NAME ARGUMENT ! 21775: * ! 21776: TRC17 EXI 1 TAKE BAD NAME ERROR EXIT ! 21777: ENP END PROCEDURE TRACE ! 21778: EJC ! 21779: * ! 21780: * TRBLD -- BUILD TRBLK ! 21781: * ! 21782: * TRBLK IS USED BY THE INPUT, OUTPUT AND TRACE FUNCTIONS ! 21783: * TO CONSTRUCT A TRBLK (TRAP BLOCK) ! 21784: * ! 21785: * (XR) TRTAG OR TRTER ! 21786: * (XL) TRFNC OR TRFPT ! 21787: * (WB) TRTYP ! 21788: * JSR TRBLD CALL TO BUILD TRBLK ! 21789: * (XR) POINTER TO TRBLK ! 21790: * (WA) DESTROYED ! 21791: * ! 21792: TRBLD PRC E,0 ENTRY POINT ! 21793: MOV XR,-(XS) STACK TRTAG (OR TRFNM) ! 21794: MOV *TRSI$,WA SET SIZE OF TRBLK ! 21795: JSR ALLOC ALLOCATE TRBLK ! 21796: MOV =B$TRT,(XR) STORE FIRST WORD ! 21797: MOV XL,TRFNC(XR) STORE TRFNC (OR TRFPT) ! 21798: MOV (XS)+,TRTAG(XR) STORE TRTAG (OR TRFNM) ! 21799: MOV WB,TRTYP(XR) STORE TYPE ! 21800: MOV =NULLS,TRVAL(XR) FOR NOW, A NULL VALUE ! 21801: EXI RETURN TO CALLER ! 21802: ENP END PROCEDURE TRBLD ! 21803: EJC ! 21804: * ! 21805: * TRIMR -- TRIM TRAILING BLANKS ! 21806: * ! 21807: * TRIMR IS PASSED A POINTER TO AN SCBLK WHICH MUST BE THE ! 21808: * LAST BLOCK IN DYNAMIC STORAGE. TRAILING BLANKS ARE ! 21809: * TRIMMED OFF AND THE DYNAMIC STORAGE POINTER RESET TO ! 21810: * THE END OF THE (POSSIBLY) SHORTENED BLOCK. ! 21811: * ! 21812: * (WB) NON-ZERO TO TRIM TRAILING BLANKS ! 21813: * (XR) POINTER TO STRING TO TRIM ! 21814: * JSR TRIMR CALL TO TRIM STRING ! 21815: * (XR) POINTER TO TRIMMED STRING ! 21816: * (XL,WA,WB,WC) DESTROYED ! 21817: * ! 21818: * THE CALL WITH WB ZERO STILL PERFORMS THE END ZERO PAD ! 21819: * AND DNAMP READJUSTMENT. IT IS USED FROM ACESS IF KVTRM=0. ! 21820: * ! 21821: TRIMR PRC E,0 ENTRY POINT ! 21822: MOV XR,XL COPY STRING POINTER ! 21823: MOV SCLEN(XR),WA LOAD STRING LENGTH ! 21824: BZE WA,TRIM2 JUMP IF NULL INPUT ! 21825: PLC XL,WA ELSE POINT PAST LAST CHARACTER ! 21826: BZE WB,TRIM3 JUMP IF NO TRIM ! 21827: MOV =CH$BL,WC LOAD BLANK CHARACTER ! 21828: * ! 21829: * LOOP THROUGH CHARACTERS FROM RIGHT TO LEFT ! 21830: * ! 21831: TRIM0 LCH WB,-(XL) LOAD NEXT CHARACTER ! 21832: BEQ WB,=CH$HT,TRIM1 JUMP IF HORIZONTAL TAB ! 21833: BNE WB,WC,TRIM3 JUMP IF NON-BLANK FOUND ! 21834: TRIM1 DCV WA ELSE DECREMENT CHARACTER COUNT ! 21835: BNZ WA,TRIM0 LOOP BACK IF MORE TO CHECK ! 21836: * ! 21837: * HERE IF RESULT IS NULL (NULL OR ALL-BLANK INPUT) ! 21838: * ! 21839: TRIM2 MOV XR,DNAMP WIPE OUT INPUT STRING BLOCK ! 21840: MOV =NULLS,XR LOAD NULL RESULT ! 21841: BRN TRIM5 MERGE TO EXIT ! 21842: EJC ! 21843: * ! 21844: * TRIMR (CONTINUED) ! 21845: * ! 21846: * HERE WITH NON-BLANK FOUND (MERGE FOR NO TRIM) ! 21847: * ! 21848: TRIM3 MOV WA,SCLEN(XR) SET NEW LENGTH ! 21849: MOV XR,XL COPY STRING POINTER ! 21850: PSC XL,WA READY FOR STORING BLANKS ! 21851: CTB WA,SCHAR GET LENGTH OF BLOCK IN BYTES ! 21852: ADD XR,WA POINT PAST NEW BLOCK ! 21853: MOV WA,DNAMP SET NEW TOP OF STORAGE POINTER ! 21854: LCT WA,=CFP$C GET COUNT OF CHARS IN WORD ! 21855: ZER WC SET BLANK CHAR ! 21856: * ! 21857: * LOOP TO ZERO PAD LAST WORD OF CHARACTERS ! 21858: * ! 21859: TRIM4 SCH WC,(XL)+ STORE ZERO CHARACTER ! 21860: BCT WA,TRIM4 LOOP BACK TILL ALL STORED ! 21861: CSC XL COMPLETE STORE CHARACTERS ! 21862: * ! 21863: * COMMON EXIT POINT ! 21864: * ! 21865: TRIM5 ZER XL CLEAR GARBAGE XL POINTER ! 21866: EXI RETURN TO CALLER ! 21867: ENP END PROCEDURE TRIMR ! 21868: EJC ! 21869: * ! 21870: * TRXEQ -- EXECUTE FUNCTION TYPE TRACE ! 21871: * ! 21872: * TRXEQ IS USED TO EXECUTE A TRACE WHEN A FOURTH ARGUMENT ! 21873: * HAS BEEN SUPPLIED. TRACE HAS ALREADY BEEN DECREMENTED. ! 21874: * ! 21875: * (XR) POINTER TO TRBLK ! 21876: * (XL,WA) NAME BASE,OFFSET FOR VARIABLE ! 21877: * JSR TRXEQ CALL TO EXECUTE TRACE ! 21878: * (WB,WC,RA) DESTROYED ! 21879: * ! 21880: * THE FOLLOWING STACK ENTRIES ARE MADE BEFORE PASSING ! 21881: * CONTROL TO THE TRACE FUNCTION USING THE CFUNC ROUTINE. ! 21882: * ! 21883: * TRXEQ RETURN POINT WORD(S) ! 21884: * SAVED VALUE OF TRACE KEYWORD ! 21885: * TRBLK POINTER ! 21886: * NAME BASE ! 21887: * NAME OFFSET ! 21888: * SAVED VALUE OF R$COD ! 21889: * SAVED CODE PTR (-R$COD) ! 21890: * SAVED VALUE OF FLPTR ! 21891: * FLPTR --------------- ZERO (DUMMY FAIL OFFSET) ! 21892: * NMBLK FOR VARIABLE NAME ! 21893: * XS ------------------ TRACE TAG ! 21894: * ! 21895: * R$COD AND THE CODE PTR ARE SET TO DUMMY VALUES WHICH ! 21896: * CAUSE CONTROL TO RETURN TO THE TRXEQ PROCEDURE ON SUCCESS ! 21897: * OR FAILURE (TRXEQ IGNORES A FAILURE CONDITION). ! 21898: * ! 21899: TRXEQ PRC R,0 ENTRY POINT (RECURSIVE) ! 21900: MOV R$COD,WC LOAD CODE BLOCK POINTER ! 21901: SCP WB GET CURRENT CODE POINTER ! 21902: SUB WC,WB MAKE CODE POINTER INTO OFFSET ! 21903: MOV KVTRA,-(XS) STACK TRACE KEYWORD VALUE ! 21904: MOV XR,-(XS) STACK TRBLK POINTER ! 21905: MOV XL,-(XS) STACK NAME BASE ! 21906: MOV WA,-(XS) STACK NAME OFFSET ! 21907: MOV WC,-(XS) STACK CODE BLOCK POINTER ! 21908: MOV WB,-(XS) STACK CODE POINTER OFFSET ! 21909: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER ! 21910: ZER -(XS) SET DUMMY FAIL OFFSET ! 21911: MOV XS,FLPTR SET NEW FAILURE POINTER ! 21912: ZER KVTRA RESET TRACE KEYWORD TO ZERO ! 21913: MOV =TRXDC,WC LOAD NEW (DUMMY) CODE BLK POINTER ! 21914: MOV WC,R$COD SET AS CODE BLOCK POINTER ! 21915: LCP WC AND NEW CODE POINTER ! 21916: EJC ! 21917: * ! 21918: * TRXEQ (CONTINUED) ! 21919: * ! 21920: * NOW PREPARE ARGUMENTS FOR FUNCTION ! 21921: * ! 21922: MOV WA,WB SAVE NAME OFFSET ! 21923: MOV *NMSI$,WA LOAD NMBLK SIZE ! 21924: JSR ALLOC ALLOCATE SPACE FOR NMBLK ! 21925: MOV =B$NML,(XR) SET TYPE WORD ! 21926: MOV XL,NMBAS(XR) STORE NAME BASE ! 21927: MOV WB,NMOFS(XR) STORE NAME OFFSET ! 21928: MOV 6(XS),XL RELOAD POINTER TO TRBLK ! 21929: MOV XR,-(XS) STACK NMBLK POINTER (1ST ARGUMENT) ! 21930: MOV TRTAG(XL),-(XS) STACK TRACE TAG (2ND ARGUMENT) ! 21931: MOV TRFNC(XL),XL LOAD TRACE FUNCTION POINTER ! 21932: MOV =NUM02,WA SET NUMBER OF ARGUMENTS TO TWO ! 21933: BRN CFUNC JUMP TO CALL FUNCTION ! 21934: * ! 21935: * SEE O$TXR FOR DETAILS OF RETURN TO THIS POINT ! 21936: * ! 21937: TRXQ1 MOV FLPTR,XS POINT BACK TO OUR STACK ENTRIES ! 21938: ICA XS POP OFF GARBAGE FAIL OFFSET ! 21939: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER ! 21940: MOV (XS)+,WB RELOAD CODE OFFSET ! 21941: MOV (XS)+,WC LOAD OLD CODE BASE POINTER ! 21942: MOV WC,XR COPY CDBLK POINTER ! 21943: MOV CDSTM(XR),KVSTN RESTORE STMNT NO ! 21944: MOV (XS)+,WA RELOAD NAME OFFSET ! 21945: MOV (XS)+,XL RELOAD NAME BASE ! 21946: MOV (XS)+,XR RELOAD TRBLK POINTER ! 21947: MOV (XS)+,KVTRA RESTORE TRACE KEYWORD VALUE ! 21948: ADD WC,WB RECOMPUTE ABSOLUTE CODE POINTER ! 21949: LCP WB RESTORE CODE POINTER ! 21950: MOV WC,R$COD AND CODE BLOCK POINTER ! 21951: EXI RETURN TO TRXEQ CALLER ! 21952: ENP END PROCEDURE TRXEQ ! 21953: EJC ! 21954: * ! 21955: * XSCAN -- EXECUTION FUNCTION ARGUMENT SCAN ! 21956: * ! 21957: * XSCAN SCANS OUT ONE TOKEN IN A PROTOTYPE ARGUMENT IN ! 21958: * ARRAY,CLEAR,DATA,DEFINE,LOAD FUNCTION CALLS. XSCAN ! 21959: * CALLS MUST BE PRECEDED BY A CALL TO THE INITIALIZATION ! 21960: * PROCEDURE XSCNI. THE FOLLOWING VARIABLES ARE USED. ! 21961: * ! 21962: * R$XSC POINTER TO SCBLK FOR FUNCTION ARG ! 21963: * XSOFS OFFSET (NUM CHARS SCANNED SO FAR) ! 21964: * ! 21965: * (WC) DELIMITER ONE (CH$XX) ! 21966: * (XL) DELIMITER TWO (CH$XX) ! 21967: * JSR XSCAN CALL TO SCAN NEXT ITEM ! 21968: * (XR) POINTER TO SCBLK FOR TOKEN SCANNED ! 21969: * (WA) COMPLETION CODE (SEE BELOW) ! 21970: * (WC,XL) DESTROYED ! 21971: * ! 21972: * THE SCAN STARTS FROM THE CURRENT POSITION AND CONTINUES ! 21973: * UNTIL ONE OF THE FOLLOWING THREE CONDITIONS OCCURS. ! 21974: * ! 21975: * 1) DELIMITER ONE IS ENCOUNTERED (WA SET TO 1) ! 21976: * ! 21977: * 2) DELIMITER TWO ENCOUNTERED (WA SET TO 2) ! 21978: * ! 21979: * 3) END OF STRING ENCOUNTERED (WA SET TO 0) ! 21980: * ! 21981: * THE RESULT IS A STRING CONTAINING ALL CHARACTERS SCANNED ! 21982: * UP TO BUT NOT INCLUDING ANY DELIMITER CHARACTER. ! 21983: * THE POINTER IS LEFT POINTING PAST THE DELIMITER. ! 21984: * ! 21985: * IF ONLY ONE DELIMITER IS TO BE DETECTED, DELIMITER ONE ! 21986: * AND DELIMITER TWO SHOULD BE SET TO THE SAME VALUE. ! 21987: * ! 21988: * IN THE CASE WHERE THE END OF STRING IS ENCOUNTERED, THE ! 21989: * STRING INCLUDES ALL THE CHARACTERS TO THE END OF THE ! 21990: * STRING. NO FURTHER CALLS CAN BE MADE TO XSCAN UNTIL ! 21991: * XSCNI IS CALLED TO INITIALIZE A NEW ARGUMENT SCAN ! 21992: EJC ! 21993: * ! 21994: * XSCAN (CONTINUED) ! 21995: * ! 21996: XSCAN PRC E,0 ENTRY POINT ! 21997: MOV WB,XSCWB PRESERVE WB ! 21998: MOV R$XSC,XR POINT TO ARGUMENT STRING ! 21999: MOV SCLEN(XR),WA LOAD STRING LENGTH ! 22000: MOV XSOFS,WB LOAD CURRENT OFFSET ! 22001: SUB WB,WA GET NUMBER OF REMAINING CHARACTERS ! 22002: BZE WA,XSCN2 JUMP IF NO CHARACTERS LEFT ! 22003: PLC XR,WB POINT TO CURRENT CHARACTER ! 22004: * ! 22005: * LOOP TO SEARCH FOR DELIMITER ! 22006: * ! 22007: XSCN1 LCH WB,(XR)+ LOAD NEXT CHARACTER ! 22008: BEQ WB,WC,XSCN3 JUMP IF DELIMITER ONE FOUND ! 22009: BEQ WB,XL,XSCN4 JUMP IF DELIMITER TWO FOUND ! 22010: DCV WA DECREMENT COUNT OF CHARS LEFT ! 22011: BNZ WA,XSCN1 LOOP BACK IF MORE CHARS TO GO ! 22012: * ! 22013: * HERE FOR RUNOUT ! 22014: * ! 22015: XSCN2 MOV R$XSC,XL POINT TO STRING BLOCK ! 22016: MOV SCLEN(XL),WA GET STRING LENGTH ! 22017: MOV XSOFS,WB LOAD OFFSET ! 22018: SUB WB,WA GET SUBSTRING LENGTH ! 22019: ZER R$XSC CLEAR STRING PTR FOR COLLECTOR ! 22020: ZER XSCRT SET ZERO (RUNOUT) RETURN CODE ! 22021: BRN XSCN6 JUMP TO EXIT ! 22022: EJC ! 22023: * ! 22024: * XSCAN (CONTINUED) ! 22025: * ! 22026: * HERE IF DELIMITER ONE FOUND ! 22027: * ! 22028: XSCN3 MOV =NUM01,XSCRT SET RETURN CODE ! 22029: BRN XSCN5 JUMP TO MERGE ! 22030: * ! 22031: * HERE IF DELIMITER TWO FOUND ! 22032: * ! 22033: XSCN4 MOV =NUM02,XSCRT SET RETURN CODE ! 22034: * ! 22035: * MERGE HERE AFTER DETECTING A DELIMITER ! 22036: * ! 22037: XSCN5 MOV R$XSC,XL RELOAD POINTER TO STRING ! 22038: MOV SCLEN(XL),WC GET ORIGINAL LENGTH OF STRING ! 22039: SUB WA,WC MINUS CHARS LEFT = CHARS SCANNED ! 22040: MOV WC,WA MOVE TO REG FOR SBSTR ! 22041: MOV XSOFS,WB SET OFFSET ! 22042: SUB WB,WA COMPUTE LENGTH FOR SBSTR ! 22043: ICV WC ADJUST NEW CURSOR PAST DELIMITER ! 22044: MOV WC,XSOFS STORE NEW OFFSET ! 22045: * ! 22046: * COMMON EXIT POINT ! 22047: * ! 22048: XSCN6 ZER XR CLEAR GARBAGE CHARACTER PTR IN XR ! 22049: JSR SBSTR BUILD SUB-STRING ! 22050: MOV XSCRT,WA LOAD RETURN CODE ! 22051: MOV XSCWB,WB RESTORE WB ! 22052: EXI RETURN TO XSCAN CALLER ! 22053: ENP END PROCEDURE XSCAN ! 22054: EJC ! 22055: * ! 22056: * XSCNI -- EXECUTION FUNCTION ARGUMENT SCAN ! 22057: * ! 22058: * XSCNI INITIALIZES THE SCAN USED FOR PROTOTYPE ARGUMENTS ! 22059: * IN THE CLEAR, DEFINE, LOAD, DATA, ARRAY FUNCTIONS. SEE ! 22060: * XSCAN FOR THE PROCEDURE WHICH IS USED AFTER THIS CALL. ! 22061: * ! 22062: * -(XS) ARGUMENT TO BE SCANNED (ON STACK) ! 22063: * JSR XSCNI CALL TO SCAN ARGUMENT ! 22064: * PPM LOC TRANSFER LOC IF ARG IS NOT STRING ! 22065: * PPM LOC TRANSFER LOC IF ARGUMENT IS NULL ! 22066: * (XS) POPPED ! 22067: * (XR,R$XSC) ARGUMENT (SCBLK PTR) ! 22068: * (WA) ARGUMENT LENGTH ! 22069: * (IA,RA) DESTROYED ! 22070: * ! 22071: XSCNI PRC N,2 ENTRY POINT ! 22072: JSR GTSTG FETCH ARGUMENT AS STRING ! 22073: PPM XSCI1 JUMP IF NOT CONVERTIBLE ! 22074: MOV XR,R$XSC ELSE STORE SCBLK PTR FOR XSCAN ! 22075: ZER XSOFS SET OFFSET TO ZERO ! 22076: BZE WA,XSCI2 JUMP IF NULL STRING ! 22077: EXI RETURN TO XSCNI CALLER ! 22078: * ! 22079: * HERE IF ARGUMENT IS NOT A STRING ! 22080: * ! 22081: XSCI1 EXI 1 TAKE NOT-STRING ERROR EXIT ! 22082: * ! 22083: * HERE FOR NULL STRING ! 22084: * ! 22085: XSCI2 EXI 2 TAKE NULL-STRING ERROR EXIT ! 22086: ENP END PROCEDURE XSCNI ! 22087: TTL S P I T B O L -- UTILITY ROUTINES ! 22088: * ! 22089: * THE FOLLOWING SECTION CONTAINS UTILITY ROUTINES USED FOR ! 22090: * VARIOUS PURPOSES THROUGHOUT THE SYSTEM. THESE DIFFER ! 22091: * FROM THE PROCEDURES IN THE UTILITY PROCEDURES SECTION IN ! 22092: * THEY ARE NOT IN PROCEDURE FORM AND THEY DO NOT RETURN ! 22093: * TO THEIR CALLERS. THEY ARE ACCESSED WITH A BRANCH TYPE ! 22094: * INSTRUCTION AFTER SETTING THE REGISTERS TO APPROPRIATE ! 22095: * PARAMETER VALUES. ! 22096: * ! 22097: * THE REGISTER VALUES REQUIRED FOR EACH ROUTINE ARE ! 22098: * DOCUMENTED AT THE START OF EACH ROUTINE. REGISTERS NOT ! 22099: * MENTIONED MAY CONTAIN ANY VALUES EXCEPT THAT XR,XL ! 22100: * CAN ONLY CONTAIN PROPER COLLECTABLE POINTERS. ! 22101: * ! 22102: * SOME OF THESE ROUTINES WILL TOLERATE GARBAGE POINTERS ! 22103: * IN XL,XR ON ENTRY. THIS IS ALWAYS DOCUMENTED AND IN ! 22104: * EACH CASE, THE ROUTINE CLEARS THESE GARBAGE VALUES BEFORE ! 22105: * EXITING AFTER COMPLETING ITS TASK. ! 22106: * ! 22107: * THE ROUTINES HAVE NAMES CONSISTING OF FIVE LETTERS ! 22108: * AND ARE ASSEMBLED IN ALPHABETICAL ORDER. ! 22109: EJC ! 22110: * ARREF -- ARRAY REFERENCE ! 22111: * ! 22112: * (XL) MAY BE NON-COLLECTABLE ! 22113: * (XR) NUMBER OF SUBSCRIPTS ! 22114: * (WB) SET ZERO/NONZERO FOR VALUE/NAME ! 22115: * THE VALUE IN WB MUST BE COLLECTABLE ! 22116: * STACK SUBSCRIPTS AND ARRAY OPERAND ! 22117: * BRN ARREF JUMP TO CALL FUNCTION ! 22118: * ! 22119: * ARREF CONTINUES BY EXECUTING THE NEXT CODE WORD WITH ! 22120: * THE RESULT NAME OR VALUE PLACED ON TOP OF THE STACK. ! 22121: * TO DEAL WITH THE PROBLEM OF ACCESSING SUBSCRIPTS IN THE ! 22122: * ORDER OF STACKING, XL IS USED AS A SUBSCRIPT POINTER ! 22123: * WORKING BELOW THE STACK POINTER. ! 22124: * ! 22125: ARREF RTN ! 22126: MOV XR,WA COPY NUMBER OF SUBSCRIPTS ! 22127: MOV XS,XT POINT TO STACK FRONT ! 22128: WTB XR CONVERT TO BYTE OFFSET ! 22129: ADD XR,XT POINT TO ARRAY OPERAND ON STACK ! 22130: ICA XT FINAL VALUE FOR STACK POPPING ! 22131: MOV XT,ARFXS KEEP FOR LATER ! 22132: MOV -(XT),XR LOAD ARRAY OPERAND POINTER ! 22133: MOV XR,R$ARF KEEP ARRAY POINTER ! 22134: MOV XT,XR SAVE POINTER TO SUBSCRIPTS ! 22135: MOV R$ARF,XL POINT XL TO POSSIBLE VCBLK OR TBBLK ! 22136: MOV (XL),WC LOAD FIRST WORD ! 22137: BEQ WC,=B$ART,ARF01 JUMP IF ARBLK ! 22138: BEQ WC,=B$VCT,ARF07 JUMP IF VCBLK ! 22139: BEQ WC,=B$TBT,ARF10 JUMP IF TBBLK ! 22140: ERB 235,SUBSCRIPTED OPERAND IS NOT TABLE OR ARRAY ! 22141: * ! 22142: * HERE FOR ARRAY (ARBLK) ! 22143: * ! 22144: ARF01 BNE WA,ARNDM(XL),ARF09 JUMP IF WRONG NUMBER OF DIMS ! 22145: LDI INTV0 GET INITIAL SUBSCRIPT OF ZERO ! 22146: MOV XR,XT POINT BEFORE SUBSCRIPTS ! 22147: ZER WA INITIAL OFFSET TO BOUNDS ! 22148: BRN ARF03 JUMP INTO LOOP ! 22149: * ! 22150: * LOOP TO COMPUTE SUBSCRIPTS BY MULTIPLICATIONS ! 22151: * ! 22152: ARF02 MLI ARDM2(XR) MULTIPLY TOTAL BY NEXT DIMENSION ! 22153: * ! 22154: * MERGE HERE FIRST TIME ! 22155: * ! 22156: ARF03 MOV -(XT),XR LOAD NEXT SUBSCRIPT ! 22157: STI ARFSI SAVE CURRENT SUBSCRIPT ! 22158: LDI ICVAL(XR) LOAD INTEGER VALUE IN CASE ! 22159: BEQ (XR),=B$ICL,ARF04 JUMP IF IT WAS AN INTEGER ! 22160: EJC ! 22161: * ! 22162: * ARREF (CONTINUED) ! 22163: * ! 22164: * ! 22165: JSR GTINT CONVERT TO INTEGER ! 22166: PPM ARF12 JUMP IF NOT INTEGER ! 22167: LDI ICVAL(XR) IF OK, LOAD INTEGER VALUE ! 22168: * ! 22169: * HERE WITH INTEGER SUBSCRIPT IN (IA) ! 22170: * ! 22171: ARF04 MOV R$ARF,XR POINT TO ARRAY ! 22172: ADD WA,XR OFFSET TO NEXT BOUNDS ! 22173: SBI ARLBD(XR) SUBTRACT LOW BOUND TO COMPARE ! 22174: IOV ARF13 OUT OF RANGE FAIL IF OVERFLOW ! 22175: ILT ARF13 OUT OF RANGE FAIL IF TOO SMALL ! 22176: SBI ARDIM(XR) SUBTRACT DIMENSION ! 22177: IGE ARF13 OUT OF RANGE FAIL IF TOO LARGE ! 22178: ADI ARDIM(XR) ELSE RESTORE SUBSCRIPT OFFSET ! 22179: ADI ARFSI ADD TO CURRENT TOTAL ! 22180: ADD *ARDMS,WA POINT TO NEXT BOUNDS ! 22181: BNE XT,XS,ARF02 LOOP BACK IF MORE TO GO ! 22182: * ! 22183: * HERE WITH INTEGER SUBSCRIPT COMPUTED ! 22184: * ! 22185: MFI WA GET AS ONE WORD INTEGER ! 22186: WTB WA CONVERT TO OFFSET ! 22187: MOV R$ARF,XL POINT TO ARBLK ! 22188: ADD AROFS(XL),WA ADD OFFSET PAST BOUNDS ! 22189: ICA WA ADJUST FOR ARPRO FIELD ! 22190: BNZ WB,ARF08 EXIT WITH NAME IF NAME CALL ! 22191: * ! 22192: * MERGE HERE TO GET VALUE FOR VALUE CALL ! 22193: * ! 22194: ARF05 JSR ACESS GET VALUE ! 22195: PPM ARF13 FAIL IF ACESS FAILS ! 22196: * ! 22197: * RETURN VALUE ! 22198: * ! 22199: ARF06 MOV ARFXS,XS POP STACK ENTRIES ! 22200: ZER R$ARF FINISHED WITH ARRAY POINTER ! 22201: BRN EXIXR EXIT WITH VALUE IN XR ! 22202: EJC ! 22203: * ! 22204: * ARREF (CONTINUED) ! 22205: * ! 22206: * HERE FOR VECTOR ! 22207: * ! 22208: ARF07 BNE WA,=NUM01,ARF09 ERROR IF MORE THAN 1 SUBSCRIPT ! 22209: MOV (XS),XR ELSE LOAD SUBSCRIPT ! 22210: JSR GTINT CONVERT TO INTEGER ! 22211: PPM ARF12 ERROR IF NOT INTEGER ! 22212: LDI ICVAL(XR) ELSE LOAD INTEGER VALUE ! 22213: SBI INTV1 SUBTRACT FOR ONES OFFSET ! 22214: MFI WA,ARF13 GET SUBSCRIPT AS ONE WORD ! 22215: ADD =VCVLS,WA ADD OFFSET FOR STANDARD FIELDS ! 22216: WTB WA CONVERT OFFSET TO BYTES ! 22217: BGE WA,VCLEN(XL),ARF13 FAIL IF OUT OF RANGE SUBSCRIPT ! 22218: BZE WB,ARF05 BACK TO GET VALUE IF VALUE CALL ! 22219: * ! 22220: * RETURN NAME ! 22221: * ! 22222: ARF08 MOV ARFXS,XS POP STACK ENTRIES ! 22223: ZER R$ARF FINISHED WITH ARRAY POINTER ! 22224: BRN EXNAM ELSE EXIT WITH NAME ! 22225: * ! 22226: * HERE IF SUBSCRIPT COUNT IS WRONG ! 22227: * ! 22228: ARF09 ERB 236,ARRAY REFERENCED WITH WRONG NUMBER OF SUBSCRIPTS ! 22229: * ! 22230: * TABLE ! 22231: * ! 22232: ARF10 BNE WA,=NUM01,ARF11 ERROR IF MORE THAN 1 SUBSCRIPT ! 22233: MOV (XS),XR ELSE LOAD SUBSCRIPT ! 22234: JSR TFIND CALL TABLE SEARCH ROUTINE ! 22235: PPM ARF13 FAIL IF FAILED ! 22236: BNZ WB,ARF08 EXIT WITH NAME IF NAME CALL ! 22237: BRN ARF06 ELSE EXIT WITH VALUE ! 22238: * ! 22239: * HERE FOR BAD TABLE REFERENCE ! 22240: * ! 22241: ARF11 ERB 237,TABLE REFERENCED WITH MORE THAN ONE SUBSCRIPT ! 22242: * ! 22243: * HERE FOR BAD SUBSCRIPT ! 22244: * ! 22245: ARF12 ERB 238,ARRAY SUBSCRIPT IS NOT INTEGER ! 22246: * ! 22247: * HERE TO SIGNAL FAILURE ! 22248: * ! 22249: ARF13 ZER R$ARF FINISHED WITH ARRAY POINTER ! 22250: BRN EXFAL FAIL ! 22251: EJC ! 22252: * ! 22253: * CFUNC -- CALL A FUNCTION ! 22254: * ! 22255: * CFUNC IS USED TO CALL A SNOBOL LEVEL FUNCTION. IT IS ! 22256: * USED BY THE APPLY FUNCTION (S$APP), THE FUNCTION ! 22257: * TRACE ROUTINE (TRXEQ) AND THE MAIN FUNCTION CALL ENTRY ! 22258: * (O$FNC, O$FNS). IN THE LATTER CASES, CFUNC IS USED ONLY ! 22259: * IF THE NUMBER OF ARGUMENTS IS INCORRECT. ! 22260: * ! 22261: * (XL) POINTER TO FUNCTION BLOCK ! 22262: * (WA) ACTUAL NUMBER OF ARGUMENTS ! 22263: * (XS) POINTS TO STACKED ARGUMENTS ! 22264: * BRN CFUNC JUMP TO CALL FUNCTION ! 22265: * ! 22266: * CFUNC CONTINUES BY EXECUTING THE FUNCTION ! 22267: * ! 22268: CFUNC RTN ! 22269: BLT WA,FARGS(XL),CFNC1 JUMP IF TOO FEW ARGUMENTS ! 22270: BEQ WA,FARGS(XL),CFNC3 JUMP IF CORRECT NUMBER OF ARGS ! 22271: * ! 22272: * HERE IF TOO MANY ARGUMENTS SUPPLIED, POP THEM OFF ! 22273: * ! 22274: MOV WA,WB COPY ACTUAL NUMBER ! 22275: SUB FARGS(XL),WB GET NUMBER OF EXTRA ARGS ! 22276: WTB WB CONVERT TO BYTES ! 22277: ADD WB,XS POP OFF UNWANTED ARGUMENTS ! 22278: BRN CFNC3 JUMP TO GO OFF TO FUNCTION ! 22279: * ! 22280: * HERE IF TOO FEW ARGUMENTS ! 22281: * ! 22282: CFNC1 MOV FARGS(XL),WB LOAD REQUIRED NUMBER OF ARGUMENTS ! 22283: BEQ WB,=NINI9,CFNC3 JUMP IF CASE OF VAR NUM OF ARGS ! 22284: SUB WA,WB CALCULATE NUMBER MISSING ! 22285: LCT WB,WB SET COUNTER TO CONTROL LOOP ! 22286: * ! 22287: * LOOP TO SUPPLY EXTRA NULL ARGUMENTS ! 22288: * ! 22289: CFNC2 MOV =NULLS,-(XS) STACK A NULL ARGUMENT ! 22290: BCT WB,CFNC2 LOOP TILL PROPER NUMBER STACKED ! 22291: * ! 22292: * MERGE HERE TO JUMP TO FUNCTION ! 22293: * ! 22294: CFNC3 BRI (XL) JUMP THROUGH FCODE FIELD ! 22295: EJC ! 22296: * ! 22297: * EXFAL -- EXIT SIGNALLING SNOBOL FAILURE ! 22298: * ! 22299: * (XL,XR) MAY BE NON-COLLECTABLE ! 22300: * BRN EXFAL JUMP TO FAIL ! 22301: * ! 22302: * EXFAL CONTINUES BY EXECUTING THE APPROPRIATE FAIL GOTO ! 22303: * ! 22304: EXFAL RTN ! 22305: MOV FLPTR,XS POP STACK ! 22306: MOV (XS),XR LOAD FAILURE OFFSET ! 22307: ADD R$COD,XR POINT TO FAILURE CODE LOCATION ! 22308: LCP XR SET CODE POINTER ! 22309: BRN EXITS DO NEXT CODE WORD ! 22310: EJC ! 22311: * ! 22312: * EXINT -- EXIT WITH INTEGER RESULT ! 22313: * ! 22314: * (XL,XR) MAY BE NONCOLLECTABLE ! 22315: * (IA) INTEGER VALUE ! 22316: * BRN EXINT JUMP TO EXIT WITH INTEGER ! 22317: * ! 22318: * EXINT CONTINUES BY EXECUTING THE NEXT CODE WORD ! 22319: * WHICH IT DOES BY FALLING THROUGH TO EXIXR ! 22320: * ! 22321: EXINT RTN ! 22322: JSR ICBLD BUILD ICBLK ! 22323: EJC ! 22324: * EXIXR -- EXIT WITH RESULT IN (XR) ! 22325: * ! 22326: * (XR) RESULT ! 22327: * (XL) MAY BE NON-COLLECTABLE ! 22328: * BRN EXIXR JUMP TO EXIT WITH RESULT IN (XR) ! 22329: * ! 22330: * EXIXR CONTINUES BY EXECUTING THE NEXT CODE WORD ! 22331: * WHICH IT DOES BY FALLING THROUGH TO EXITS. ! 22332: EXIXR RTN ! 22333: * ! 22334: MOV XR,-(XS) STACK RESULT ! 22335: * ! 22336: * ! 22337: * EXITS -- EXIT WITH RESULT IF ANY STACKED ! 22338: * ! 22339: * (XR,XL) MAY BE NON-COLLECTABLE ! 22340: * ! 22341: * BRN EXITS ENTER EXITS ROUTINE ! 22342: * ! 22343: EXITS RTN ! 22344: LCW XR LOAD NEXT CODE WORD ! 22345: MOV (XR),XL LOAD ENTRY ADDRESS ! 22346: BRI XL JUMP TO EXECUTE NEXT CODE WORD ! 22347: EJC ! 22348: * ! 22349: * EXNAM -- EXIT WITH NAME IN (XL,WA) ! 22350: * ! 22351: * (XL) NAME BASE ! 22352: * (WA) NAME OFFSET ! 22353: * (XR) MAY BE NON-COLLECTABLE ! 22354: * BRN EXNAM JUMP TO EXIT WITH NAME IN (XL,WA) ! 22355: * ! 22356: * EXNAM CONTINUES BY EXECUTING THE NEXT CODE WORD ! 22357: * ! 22358: EXNAM RTN ! 22359: MOV XL,-(XS) STACK NAME BASE ! 22360: MOV WA,-(XS) STACK NAME OFFSET ! 22361: BRN EXITS DO NEXT CODE WORD ! 22362: EJC ! 22363: * ! 22364: * EXNUL -- EXIT WITH NULL RESULT ! 22365: * ! 22366: * (XL,XR) MAY BE NON-COLLECTABLE ! 22367: * BRN EXNUL JUMP TO EXIT WITH NULL VALUE ! 22368: * ! 22369: * EXNUL CONTINUES BY EXECUTING THE NEXT CODE WORD ! 22370: * ! 22371: EXNUL RTN ! 22372: MOV =NULLS,-(XS) STACK NULL VALUE ! 22373: BRN EXITS DO NEXT CODE WORD ! 22374: EJC ! 22375: * ! 22376: * EXREA -- EXIT WITH REAL RESULT ! 22377: * ! 22378: * (XL,XR) MAY BE NON-COLLECTABLE ! 22379: * (RA) REAL VALUE ! 22380: * BRN EXREA JUMP TO EXIT WITH REAL VALUE ! 22381: * ! 22382: * EXREA CONTINUES BY EXECUTING THE NEXT CODE WORD ! 22383: * ! 22384: EXREA RTN ! 22385: JSR RCBLD BUILD RCBLK ! 22386: BRN EXIXR JUMP TO EXIT WITH RESULT IN XR ! 22387: EJC ! 22388: * ! 22389: * EXSID -- EXIT SETTING ID FIELD ! 22390: * ! 22391: * EXSID IS USED TO EXIT AFTER BUILDING ANY OF THE FOLLOWING ! 22392: * BLOCKS (ARBLK, TBBLK, PDBLK, VCBLK). IT SETS THE IDVAL. ! 22393: * ! 22394: * (XR) PTR TO BLOCK WITH IDVAL FIELD ! 22395: * (XL) MAY BE NON-COLLECTABLE ! 22396: * BRN EXSID JUMP TO EXIT AFTER SETTING ID FIELD ! 22397: * ! 22398: * EXSID CONTINUES BY EXECUTING THE NEXT CODE WORD ! 22399: * ! 22400: EXSID RTN ! 22401: MOV CURID,WA LOAD CURRENT ID VALUE ! 22402: BNE WA,=CFP$M,EXSI1 JUMP IF NO OVERFLOW ! 22403: ZER WA ELSE RESET FOR WRAPAROUND ! 22404: * ! 22405: * HERE WITH OLD IDVAL IN WA ! 22406: * ! 22407: EXSI1 ICV WA BUMP ID VALUE ! 22408: MOV WA,CURID STORE FOR NEXT TIME ! 22409: MOV WA,IDVAL(XR) STORE ID VALUE ! 22410: BRN EXIXR EXIT WITH RESULT IN (XR) ! 22411: EJC ! 22412: * ! 22413: * EXVNM -- EXIT WITH NAME OF VARIABLE ! 22414: * ! 22415: * EXVNM EXITS AFTER STACKING A VALUE WHICH IS A NMBLK ! 22416: * REFERENCING THE NAME OF A GIVEN NATURAL VARIABLE. ! 22417: * ! 22418: * (XR) VRBLK POINTER ! 22419: * (XL) MAY BE NON-COLLECTABLE ! 22420: * BRN EXVNM EXIT WITH VRBLK POINTER IN XR ! 22421: * ! 22422: EXVNM RTN ! 22423: MOV XR,XL COPY NAME BASE POINTER ! 22424: MOV *NMSI$,WA SET SIZE OF NMBLK ! 22425: JSR ALLOC ALLOCATE NMBLK ! 22426: MOV =B$NML,(XR) STORE TYPE WORD ! 22427: MOV XL,NMBAS(XR) STORE NAME BASE ! 22428: MOV *VRVAL,NMOFS(XR) STORE NAME OFFSET ! 22429: BRN EXIXR EXIT WITH RESULT IN XR ! 22430: EJC ! 22431: * ! 22432: * FLPOP -- FAIL AND POP IN PATTERN MATCHING ! 22433: * ! 22434: * FLPOP POPS THE NODE AND CURSOR ON THE STACK AND THEN ! 22435: * DROPS THROUGH INTO FAILP TO CAUSE PATTERN FAILURE ! 22436: * ! 22437: * (XL,XR) MAY BE NON-COLLECTABLE ! 22438: * BRN FLPOP JUMP TO FAIL AND POP STACK ! 22439: * ! 22440: FLPOP RTN ! 22441: ADD *NUM02,XS POP TWO ENTRIES OFF STACK ! 22442: EJC ! 22443: * ! 22444: * FAILP -- FAILURE IN MATCHING PATTERN NODE ! 22445: * ! 22446: * FAILP IS USED AFTER FAILING TO MATCH A PATTERN NODE. ! 22447: * SEE PATTERN MATCH ROUTINES FOR DETAILS OF USE. ! 22448: * ! 22449: * (XL,XR) MAY BE NON-COLLECTABLE ! 22450: * BRN FAILP SIGNAL FAILURE TO MATCH ! 22451: * ! 22452: * FAILP CONTINUES BY MATCHING AN ALTERNATIVE FROM THE STACK ! 22453: * ! 22454: FAILP RTN ! 22455: MOV (XS)+,XR LOAD ALTERNATIVE NODE POINTER ! 22456: MOV (XS)+,WB RESTORE OLD CURSOR ! 22457: MOV (XR),XL LOAD PCODE ENTRY POINTER ! 22458: BRI XL JUMP TO EXECUTE CODE FOR NODE ! 22459: EJC ! 22460: * ! 22461: * INDIR -- COMPUTE INDIRECT REFERENCE ! 22462: * ! 22463: * (WB) NONZERO/ZERO FOR BY NAME/VALUE ! 22464: * BRN INDIR JUMP TO GET INDIRECT REF ON STACK ! 22465: * ! 22466: * INDIR CONTINUES BY EXECUTING THE NEXT CODE WORD ! 22467: * ! 22468: INDIR RTN ! 22469: MOV (XS)+,XR LOAD ARGUMENT ! 22470: BEQ (XR),=B$NML,INDR2 JUMP IF A NAME ! 22471: JSR GTNVR ELSE CONVERT TO VARIABLE ! 22472: ERR 239,INDIRECTION OPERAND IS NOT NAME ! 22473: BZE WB,INDR1 SKIP IF BY VALUE ! 22474: MOV XR,-(XS) ELSE STACK VRBLK PTR ! 22475: MOV *VRVAL,-(XS) STACK NAME OFFSET ! 22476: BRN EXITS EXIT WITH RESULT ON STACK ! 22477: * ! 22478: * HERE TO GET VALUE OF NATURAL VARIABLE ! 22479: * ! 22480: INDR1 BRI (XR) JUMP THROUGH VRGET FIELD OF VRBLK ! 22481: * ! 22482: * HERE IF OPERAND IS A NAME ! 22483: * ! 22484: INDR2 MOV NMBAS(XR),XL LOAD NAME BASE ! 22485: MOV NMOFS(XR),WA LOAD NAME OFFSET ! 22486: BNZ WB,EXNAM EXIT IF CALLED BY NAME ! 22487: JSR ACESS ELSE GET VALUE FIRST ! 22488: PPM EXFAL FAIL IF ACCESS FAILS ! 22489: BRN EXIXR ELSE RETURN WITH VALUE IN XR ! 22490: EJC ! 22491: * ! 22492: * MATCH -- INITIATE PATTERN MATCH ! 22493: * ! 22494: * (WB) MATCH TYPE CODE ! 22495: * BRN MATCH JUMP TO INITIATE PATTERN MATCH ! 22496: * ! 22497: * MATCH CONTINUES BY EXECUTING THE PATTERN MATCH. SEE ! 22498: * PATTERN MATCH ROUTINES (P$XXX) FOR FULL DETAILS. ! 22499: * ! 22500: MATCH RTN ! 22501: MOV (XS)+,XR LOAD PATTERN OPERAND ! 22502: JSR GTPAT CONVERT TO PATTERN ! 22503: ERR 240,PATTERN MATCH RIGHT OPERAND IS NOT PATTERN ! 22504: MOV XR,XL IF OK, SAVE PATTERN POINTER ! 22505: BNZ WB,MTCH1 JUMP IF NOT MATCH BY NAME ! 22506: MOV (XS),WA ELSE LOAD NAME OFFSET ! 22507: MOV XL,-(XS) SAVE PATTERN POINTER ! 22508: MOV 2(XS),XL LOAD NAME BASE ! 22509: JSR ACESS ACCESS SUBJECT VALUE ! 22510: PPM EXFAL FAIL IF ACCESS FAILS ! 22511: MOV (XS),XL RESTORE PATTERN POINTER ! 22512: MOV XR,(XS) STACK SUBJECT STRING VAL FOR MERGE ! 22513: ZER WB RESTORE TYPE CODE ! 22514: * ! 22515: * MERGE HERE WITH SUBJECT VALUE ON STACK ! 22516: * ! 22517: MTCH1 MOV (XS),XR LOAD SUBJECT VALUE ! 22518: ZER R$PMB ASSUME NOT A BUFFER ! 22519: BNE (XR),=B$BCT,MTCHA BRANCH IF NOT ! 22520: ICA XS ELSE POP VALUE ! 22521: MOV XR,R$PMB SAVE POINTER ! 22522: MOV BCLEN(XR),WA GET DEFINED LENGTH ! 22523: MOV BCBUF(XR),XR POINT TO BFBLK ! 22524: BRN MTCHB ! 22525: * ! 22526: * HERE IF NOT BUFFER TO CONVERT TO STRING ! 22527: * ! 22528: MTCHA JSR GTSTG NOT BUFFER - CONVERT TO STRING ! 22529: ERR 241,PATTERN MATCH LEFT OPERAND IS NOT STRING ! 22530: * ! 22531: * MERGE WITH BUFFER OR STRING ! 22532: * ! 22533: MTCHB MOV XR,R$PMS IF OK, STORE SUBJECT STRING POINTER ! 22534: MOV WA,PMSSL AND LENGTH ! 22535: MOV WB,-(XS) STACK MATCH TYPE CODE ! 22536: ZER -(XS) STACK INITIAL CURSOR (ZERO) ! 22537: ZER WB SET INITIAL CURSOR ! 22538: MOV XS,PMHBS SET HISTORY STACK BASE PTR ! 22539: ZER PMDFL RESET PATTERN ASSIGNMENT FLAG ! 22540: MOV XL,XR SET INITIAL NODE POINTER ! 22541: BNZ KVANC,MTCH2 JUMP IF ANCHORED ! 22542: * ! 22543: * HERE FOR UNANCHORED ! 22544: * ! 22545: MOV XR,-(XS) STACK INITIAL NODE POINTER ! 22546: MOV =NDUNA,-(XS) STACK POINTER TO ANCHOR MOVE NODE ! 22547: BRI (XR) START MATCH OF FIRST NODE ! 22548: * ! 22549: * HERE IN ANCHORED MODE ! 22550: * ! 22551: MTCH2 ZER -(XS) DUMMY CURSOR VALUE ! 22552: MOV =NDABO,-(XS) STACK POINTER TO ABORT NODE ! 22553: BRI (XR) START MATCH OF FIRST NODE ! 22554: EJC ! 22555: * ! 22556: * RETRN -- RETURN FROM FUNCTION ! 22557: * ! 22558: * (WA) STRING POINTER FOR RETURN TYPE ! 22559: * BRN RETRN JUMP TO RETURN FROM (SNOBOL) FUNC ! 22560: * ! 22561: * RETRN CONTINUES BY EXECUTING THE CODE AT THE RETURN POINT ! 22562: * THE STACK IS CLEANED OF ANY GARBAGE LEFT BY OTHER ! 22563: * ROUTINES WHICH MAY HAVE ALTERED FLPTR SINCE FUNCTION ! 22564: * ENTRY BY USING FLPRT, RESERVED FOR USE ONLY BY ! 22565: * FUNCTION CALL AND RETURN. ! 22566: * ! 22567: RETRN RTN ! 22568: BNZ KVFNC,RTN01 JUMP IF NOT LEVEL ZERO ! 22569: ERB 242,FUNCTION RETURN FROM LEVEL ZERO ! 22570: * ! 22571: * HERE IF NOT LEVEL ZERO RETURN ! 22572: * ! 22573: RTN01 MOV FLPRT,XS POP STACK ! 22574: ICA XS REMOVE FAILURE OFFSET ! 22575: MOV (XS)+,XR POP PFBLK POINTER ! 22576: MOV (XS)+,FLPTR POP FAILURE POINTER ! 22577: MOV (XS)+,FLPRT POP OLD FLPRT ! 22578: MOV (XS)+,WB POP CODE POINTER OFFSET ! 22579: MOV (XS)+,WC POP OLD CODE BLOCK POINTER ! 22580: ADD WC,WB MAKE OLD CODE POINTER ABSOLUTE ! 22581: LCP WB RESTORE OLD CODE POINTER ! 22582: MOV WC,R$COD RESTORE OLD CODE BLOCK POINTER ! 22583: DCV KVFNC DECREMENT FUNCTION LEVEL ! 22584: MOV KVTRA,WB LOAD TRACE ! 22585: ADD KVFTR,WB ADD FTRACE ! 22586: BZE WB,RTN06 JUMP IF NO TRACING POSSIBLE ! 22587: * ! 22588: * HERE IF THERE MAY BE A TRACE ! 22589: * ! 22590: MOV WA,-(XS) SAVE FUNCTION RETURN TYPE ! 22591: MOV XR,-(XS) SAVE PFBLK POINTER ! 22592: MOV WA,KVRTN SET RTNTYPE FOR TRACE FUNCTION ! 22593: MOV R$FNC,XL LOAD FNCLEVEL TRBLK PTR (IF ANY) ! 22594: JSR KTREX EXECUTE POSSIBLE FNCLEVEL TRACE ! 22595: MOV PFVBL(XR),XL LOAD VRBLK PTR (SGD13) ! 22596: BZE KVTRA,RTN02 JUMP IF TRACE IS OFF ! 22597: MOV PFRTR(XR),XR ELSE LOAD RETURN TRACE TRBLK PTR ! 22598: BZE XR,RTN02 JUMP IF NOT RETURN TRACED ! 22599: DCV KVTRA ELSE DECREMENT TRACE COUNT ! 22600: BZE TRFNC(XR),RTN03 JUMP IF PRINT TRACE ! 22601: MOV *VRVAL,WA ELSE SET NAME OFFSET ! 22602: MOV 1(XS),KVRTN MAKE SURE RTNTYPE IS SET RIGHT ! 22603: JSR TRXEQ EXECUTE FULL TRACE ! 22604: EJC ! 22605: * ! 22606: * RETRN (CONTINUED) ! 22607: * ! 22608: * HERE TO TEST FOR FTRACE ! 22609: * ! 22610: RTN02 BZE KVFTR,RTN05 JUMP IF FTRACE IS OFF ! 22611: DCV KVFTR ELSE DECREMENT FTRACE ! 22612: * ! 22613: * HERE FOR PRINT TRACE OF FUNCTION RETURN ! 22614: * ! 22615: RTN03 JSR PRTSN PRINT STATEMENT NUMBER ! 22616: MOV 1(XS),XR LOAD RETURN TYPE ! 22617: JSR PRTST PRINT IT ! 22618: MOV =CH$BL,WA LOAD BLANK ! 22619: JSR PRTCH PRINT IT ! 22620: MOV 0(XS),XL LOAD PFBLK PTR ! 22621: MOV PFVBL(XL),XL LOAD FUNCTION VRBLK PTR ! 22622: MOV *VRVAL,WA SET VRBLK NAME OFFSET ! 22623: BNE XR,=SCFRT,RTN04 JUMP IF NOT FRETURN CASE ! 22624: * ! 22625: * FOR FRETURN, JUST PRINT FUNCTION NAME ! 22626: * ! 22627: JSR PRTNM PRINT NAME ! 22628: JSR PRTNL TERMINATE PRINT LINE ! 22629: BRN RTN05 MERGE ! 22630: * ! 22631: * HERE FOR RETURN OR NRETURN, PRINT FUNCTION NAME = VALUE ! 22632: * ! 22633: RTN04 JSR PRTNV PRINT NAME = VALUE ! 22634: * ! 22635: * HERE AFTER COMPLETING TRACE ! 22636: * ! 22637: RTN05 MOV (XS)+,XR POP PFBLK POINTER ! 22638: MOV (XS)+,WA POP RETURN TYPE STRING ! 22639: * ! 22640: * MERGE HERE IF NO TRACE REQUIRED ! 22641: * ! 22642: RTN06 MOV WA,KVRTN SET RTNTYPE KEYWORD ! 22643: MOV PFVBL(XR),XL LOAD POINTER TO FN VRBLK ! 22644: EJC ! 22645: * RETRN (CONTINUED) ! 22646: * ! 22647: * GET VALUE OF FUNCTION ! 22648: * ! 22649: RTN07 MOV XL,RTNBP SAVE BLOCK POINTER ! 22650: MOV VRVAL(XL),XL LOAD VALUE ! 22651: BEQ (XL),=B$TRT,RTN07 LOOP BACK IF TRAPPED ! 22652: MOV XL,RTNFV ELSE SAVE FUNCTION RESULT VALUE ! 22653: MOV (XS)+,RTNSV SAVE ORIGINAL FUNCTION VALUE ! 22654: MOV (XS)+,XL POP SAVED POINTER ! 22655: BZE XL,RTN7C NO ACTION IF NONE ! 22656: BZE KVPFL,RTN7C JUMP IF NO PROFILING ! 22657: JSR PRFLU ELSE PROFILE LAST FUNC STMT ! 22658: BEQ KVPFL,=NUM02,RTN7A BRANCH ON VALUE OF PROFILE KEYWD ! 22659: * ! 22660: * HERE IF &PROFILE = 1. START TIME MUST BE FRIGGED TO ! 22661: * APPEAR EARLIER THAN IT ACTUALLY IS, BY AMOUNT USED BEFORE ! 22662: * THE CALL. ! 22663: * ! 22664: LDI PFSTM LOAD CURRENT TIME ! 22665: SBI ICVAL(XL) FRIG BY SUBTRACTING SAVED AMOUNT ! 22666: BRN RTN7B AND MERGE ! 22667: * ! 22668: * HERE IF &PROFILE = 2 ! 22669: * ! 22670: RTN7A LDI ICVAL(XL) LOAD SAVED TIME ! 22671: * ! 22672: * BOTH PROFILE TYPES MERGE HERE ! 22673: * ! 22674: RTN7B STI PFSTM STORE BACK CORRECT START TIME ! 22675: * ! 22676: * MERGE HERE IF NO PROFILING ! 22677: * ! 22678: RTN7C MOV FARGS(XR),WB GET NUMBER OF ARGS ! 22679: ADD PFNLO(XR),WB ADD NUMBER OF LOCALS ! 22680: BZE WB,RTN10 JUMP IF NO ARGS/LOCALS ! 22681: LCT WB,WB ELSE SET LOOP COUNTER ! 22682: ADD PFLEN(XR),XR AND POINT TO END OF PFBLK ! 22683: * ! 22684: * LOOP TO RESTORE FUNCTIONS AND LOCALS ! 22685: * ! 22686: RTN08 MOV -(XR),XL LOAD NEXT VRBLK POINTER ! 22687: * ! 22688: * LOOP TO FIND VALUE BLOCK ! 22689: * ! 22690: RTN09 MOV XL,WA SAVE BLOCK POINTER ! 22691: MOV VRVAL(XL),XL LOAD POINTER TO NEXT VALUE ! 22692: BEQ (XL),=B$TRT,RTN09 LOOP BACK IF TRAPPED ! 22693: MOV WA,XL ELSE RESTORE LAST BLOCK POINTER ! 22694: MOV (XS)+,VRVAL(XL) RESTORE OLD VARIABLE VALUE ! 22695: BCT WB,RTN08 LOOP TILL ALL PROCESSED ! 22696: * ! 22697: * NOW RESTORE FUNCTION VALUE AND EXIT ! 22698: * ! 22699: RTN10 MOV RTNBP,XL RESTORE PTR TO LAST FUNCTION BLOCK ! 22700: MOV RTNSV,VRVAL(XL) RESTORE OLD FUNCTION VALUE ! 22701: MOV RTNFV,XR RELOAD FUNCTION RESULT ! 22702: MOV R$COD,XL POINT TO NEW CODE BLOCK ! 22703: MOV KVSTN,KVLST SET LASTNO FROM STNO ! 22704: MOV CDSTM(XL),KVSTN RESET PROPER STNO VALUE ! 22705: MOV KVRTN,WA LOAD RETURN TYPE ! 22706: BEQ WA,=SCRTN,EXIXR EXIT WITH RESULT IN XR IF RETURN ! 22707: BEQ WA,=SCFRT,EXFAL FAIL IF FRETURN ! 22708: EJC ! 22709: * ! 22710: * RETRN (CONTINUED) ! 22711: * ! 22712: * HERE FOR NRETURN ! 22713: * ! 22714: BEQ (XR),=B$NML,RTN11 JUMP IF IS A NAME ! 22715: JSR GTNVR ELSE TRY CONVERT TO VARIABLE NAME ! 22716: ERR 243,FUNCTION RESULT IN NRETURN IS NOT NAME ! 22717: MOV XR,XL IF OK, COPY VRBLK (NAME BASE) PTR ! 22718: MOV *VRVAL,WA SET NAME OFFSET ! 22719: BRN RTN12 AND MERGE ! 22720: * ! 22721: * HERE IF RETURNED RESULT IS A NAME ! 22722: * ! 22723: RTN11 MOV NMBAS(XR),XL LOAD NAME BASE ! 22724: MOV NMOFS(XR),WA LOAD NAME OFFSET ! 22725: * ! 22726: * MERGE HERE WITH RETURNED NAME IN (XL,WA) ! 22727: * ! 22728: RTN12 MOV XL,XR PRESERVE XL ! 22729: LCW WB LOAD NEXT WORD ! 22730: MOV XR,XL RESTORE XL ! 22731: BEQ WB,=OFNE$,EXNAM EXIT IF CALLED BY NAME ! 22732: MOV WB,-(XS) ELSE SAVE CODE WORD ! 22733: JSR ACESS GET VALUE ! 22734: PPM EXFAL FAIL IF ACCESS FAILS ! 22735: MOV XR,XL IF OK, COPY RESULT ! 22736: MOV (XS),XR RELOAD NEXT CODE WORD ! 22737: MOV XL,(XS) STORE RESULT ON STACK ! 22738: MOV (XR),XL LOAD ROUTINE ADDRESS ! 22739: BRI XL JUMP TO EXECUTE NEXT CODE WORD ! 22740: EJC ! 22741: * ! 22742: * STCOV -- SIGNAL STATEMENT COUNTER OVERFLOW ! 22743: * ! 22744: * BRN STCOV JUMP TO SIGNAL STATEMENT COUNT OFLO ! 22745: * ! 22746: * PERMIT UP TO 10 MORE STATEMENTS TO BE OBEYED SO THAT ! 22747: * SETEXIT TRAP CAN REGAIN CONTROL. ! 22748: * STCOV CONTINUES BY ISSUING THE ERROR MESSAGE ! 22749: * ! 22750: STCOV RTN ! 22751: ICV ERRFT FATAL ERROR ! 22752: LDI INTVT GET 10 ! 22753: ADI KVSTL ADD TO FORMER LIMIT ! 22754: STI KVSTL STORE AS NEW STLIMIT ! 22755: LDI INTVT GET 10 ! 22756: STI KVSTC SET AS NEW COUNT ! 22757: ERB 244,STATEMENT COUNT EXCEEDS VALUE OF STLIMIT KEYWORD ! 22758: EJC ! 22759: * ! 22760: * STMGO -- START EXECUTION OF NEW STATEMENT ! 22761: * ! 22762: * (XR) POINTER TO CDBLK FOR NEW STATEMENT ! 22763: * BRN STMGO JUMP TO EXECUTE NEW STATEMENT ! 22764: * ! 22765: * STMGO CONTINUES BY EXECUTING THE NEXT STATEMENT ! 22766: * ! 22767: STMGO RTN ! 22768: MOV XR,R$COD SET NEW CODE BLOCK POINTER ! 22769: BZE KVPFL,STGO1 SKIP IF NO PROFILING ! 22770: JSR PRFLU ELSE PROFILE THE STATEMENT ! 22771: STGO1 MOV KVSTN,KVLST SET LASTNO ! 22772: MOV CDSTM(XR),KVSTN SET STNO ! 22773: ADD *CDCOD,XR POINT TO FIRST CODE WORD ! 22774: LCP XR SET CODE POINTER ! 22775: LDI KVSTC GET STMT COUNT ! 22776: ILT EXITS OMIT COUNTING IF NEGATIVE ! 22777: IEQ STCOV FAIL IF STLIMIT REACHED ! 22778: SBI INTV1 DECREMENT ! 22779: STI KVSTC REPLACE IT ! 22780: BZE R$STC,EXITS EXIT IF NO STCOUNT TRACE ! 22781: * ! 22782: * HERE FOR STCOUNT TRACE ! 22783: * ! 22784: ZER XR CLEAR GARBAGE VALUE IN XR ! 22785: MOV R$STC,XL LOAD POINTER TO STCOUNT TRBLK ! 22786: JSR KTREX EXECUTE KEYWORD TRACE ! 22787: BRN EXITS AND THEN EXIT FOR NEXT CODE WORD ! 22788: EJC ! 22789: * ! 22790: * STOPR -- TERMINATE RUN ! 22791: * ! 22792: * (XR) POINTS TO ENDING MESSAGE ! 22793: * BRN STOPR JUMP TO TERMINATE RUN ! 22794: * ! 22795: * TERMINATE RUN AND PRINT STATISTICS. ON ENTRY XR POINTS ! 22796: * TO ENDING MESSAGE OR IS ZERO IF MESSAGE PRINTED ALREADY. ! 22797: * ! 22798: STOPR RTN ! 22799: BZE XR,STPRA SKIP IF SYSAX ALREADY CALLED (REG04) ! 22800: JSR SYSAX CALL AFTER EXECUTION PROC ! 22801: STPRA ADD RSMEM,DNAME USE THE RESERVE MEMORY ! 22802: BNE XR,=ENDMS,STPR0 SKIP IF NOT NORMAL END MESSAGE ! 22803: BNZ EXSTS,STPR3 SKIP IF EXEC STATS SUPPRESSED ! 22804: ZER ERICH CLEAR ERRORS TO INT.CH. FLAG ! 22805: * ! 22806: * LOOK TO SEE IF AN ENDING MESSAGE IS SUPPLIED ! 22807: * ! 22808: STPR0 JSR PRTPG EJECT PRINTER ! 22809: BZE XR,STPR1 SKIP IF NO MESSAGE ! 22810: JSR PRTST PRINT MESSAGE ! 22811: * ! 22812: * MERGE HERE IF NO MESSAGE TO PRINT ! 22813: * ! 22814: STPR1 JSR PRTIS PRINT BLANK LINE ! 22815: MTI KVSTN GET STATEMENT NUMBER ! 22816: MOV =STPM1,XR POINT TO MESSAGE /IN STATEMENT XXX/ ! 22817: JSR PRTMX PRINT IT ! 22818: JSR SYSTM GET CURRENT TIME ! 22819: SBI TIMSX MINUS START TIME = ELAPSED EXEC TIM ! 22820: STI STPTI SAVE FOR LATER ! 22821: MOV =STPM3,XR POINT TO MSG /EXECUTION TIME MSEC / ! 22822: JSR PRTMX PRINT IT ! 22823: LDI KVSTL GET STATEMENT LIMIT ! 22824: ILT STPR2 SKIP IF NEGATIVE ! 22825: SBI KVSTC MINUS COUNTER = COUNT ! 22826: STI STPSI SAVE ! 22827: MOV =STPM2,XR POINT TO MESSAGE /STMTS EXECUTED/ ! 22828: JSR PRTMX PRINT IT ! 22829: LDI STPTI RELOAD ELAPSED TIME ! 22830: MLI INTTH *1000 (MICROSECS) ! 22831: IOV STPR2 JUMP IF WE CANNOT COMPUTE ! 22832: DVI STPSI DIVIDE BY STATEMENT COUNT ! 22833: IOV STPR2 JUMP IF OVERFLOW ! 22834: MOV =STPM4,XR POINT TO MSG (MCSEC PER STATEMENT / ! 22835: JSR PRTMX PRINT IT ! 22836: EJC ! 22837: * ! 22838: * STOPR (CONTINUED) ! 22839: * ! 22840: * MERGE TO SKIP MESSAGE (OVERFLOW OR NEGATIVE STLIMIT) ! 22841: * ! 22842: STPR2 MTI GBCNT LOAD COUNT OF COLLECTIONS ! 22843: MOV =STPM5,XR POINT TO MESSAGE /REGENERATIONS / ! 22844: JSR PRTMX PRINT IT ! 22845: JSR PRTIS ONE MORE BLANK FOR LUCK ! 22846: * ! 22847: * CHECK IF DUMP REQUESTED ! 22848: * ! 22849: STPR3 JSR PRFLR PRINT PROFILE IF WANTED ! 22850: * ! 22851: MOV KVDMP,XR LOAD DUMP KEYWORD ! 22852: JSR DUMPR EXECUTE DUMP IF REQUESTED ! 22853: MOV R$FCB,XL GET FCBLK CHAIN HEAD ! 22854: MOV KVABE,WA LOAD ABEND VALUE ! 22855: MOV KVCOD,WB LOAD CODE VALUE ! 22856: JSR SYSEJ EXIT TO SYSTEM ! 22857: EJC ! 22858: * ! 22859: * SUCCP -- SIGNAL SUCCESSFUL MATCH OF A PATTERN NODE ! 22860: * ! 22861: * SEE PATTERN MATCH ROUTINES FOR DETAILS ! 22862: * ! 22863: * (XR) CURRENT NODE ! 22864: * (WB) CURRENT CURSOR ! 22865: * (XL) MAY BE NON-COLLECTABLE ! 22866: * BRN SUCCP SIGNAL SUCCESSFUL PATTERN MATCH ! 22867: * ! 22868: * SUCCP CONTINUES BY MATCHING THE SUCCESSOR NODE ! 22869: * ! 22870: SUCCP RTN ! 22871: MOV PTHEN(XR),XR LOAD SUCCESSOR NODE ! 22872: MOV (XR),XL LOAD NODE CODE ENTRY ADDRESS ! 22873: BRI XL JUMP TO MATCH SUCCESSOR NODE ! 22874: EJC ! 22875: * ! 22876: * SYSAB -- PRINT /ABNORMAL END/ AND TERMINATE ! 22877: * ! 22878: SYSAB RTN ! 22879: MOV =ENDAB,XR POINT TO MESSAGE ! 22880: MOV =NUM01,KVABE SET ABEND FLAG ! 22881: JSR PRTNL SKIP TO NEW LINE ! 22882: BRN STOPR JUMP TO PACK UP ! 22883: EJC ! 22884: * ! 22885: * SYSTU -- PRINT /TIME UP/ AND TERMINATE ! 22886: * ! 22887: SYSTU RTN ! 22888: MOV =ENDTU,XR POINT TO MESSAGE ! 22889: MOV STRTU,WA GET CHARS /TU/ ! 22890: MOV WA,KVCOD PUT IN KVCOD ! 22891: MOV TIMUP,WA CHECK STATE OF TIMEUP SWITCH ! 22892: MNZ TIMUP SET SWITCH ! 22893: BNZ WA,STOPR STOP RUN IF ALREADY SET ! 22894: ERB 245,TRANSLATION/EXECUTION TIME EXPIRED ! 22895: TTL S P I T B O L -- STACK OVERFLOW SECTION ! 22896: * ! 22897: * CONTROL COMES HERE IF THE MAIN STACK OVERFLOWS ! 22898: * ! 22899: SEC START OF STACK OVERFLOW SECTION ! 22900: * ! 22901: ICV ERRFT FATAL ERROR ! 22902: MOV FLPTR,XS POP STACK TO AVOID MORE FAILS ! 22903: BNZ GBCFL,STAK1 JUMP IF GARBAGE COLLECTING ! 22904: ERB 246,STACK OVERFLOW ! 22905: * ! 22906: * NO CHANCE OF RECOVERY IN MID GARBAGE COLLECTION ! 22907: * ! 22908: STAK1 MOV =ENDSO,XR POINT TO MESSAGE ! 22909: ZER KVDMP MEMORY IS UNDUMPABLE ! 22910: BRN STOPR GIVE UP ! 22911: TTL S P I T B O L -- ERROR SECTION ! 22912: * ! 22913: * THIS SECTION OF CODE IS ENTERED WHENEVER A PROCEDURE ! 22914: * RETURN VIA AN ERR PARAMETER OR AN ERB OPCODE IS OBEYED. ! 22915: * ! 22916: * (WA) IS THE ERROR CODE ! 22917: * ! 22918: * THE GLOBAL VARIABLE STAGE INDICATES THE POINT AT WHICH ! 22919: * THE ERROR OCCURED AS FOLLOWS. ! 22920: * ! 22921: * STAGE=STGIC ERROR DURING INITIAL COMPILE ! 22922: * ! 22923: * STAGE=STGXC ERROR DURING COMPILE AT EXECUTE ! 22924: * TIME (CODE, CONVERT FUNCTION CALLS) ! 22925: * ! 22926: * STAGE=STGEV ERROR DURING COMPILATION OF ! 22927: * EXPRESSION AT EXECUTION TIME ! 22928: * (EVAL, CONVERT FUNCTION CALL). ! 22929: * ! 22930: * STAGE=STGXT ERROR AT EXECUTE TIME. COMPILER ! 22931: * NOT ACTIVE. ! 22932: * ! 22933: * STAGE=STGCE ERROR DURING INITIAL COMPILE AFTER ! 22934: * SCANNING OUT THE END LINE. ! 22935: * ! 22936: * STAGE=STGXE ERROR DURING COMPILE AT EXECUTE ! 22937: * TIME AFTER SCANNING END LINE. ! 22938: * ! 22939: * STAGE=STGEE ERROR DURING EXPRESSION EVALUATION ! 22940: * ! 22941: SEC START OF ERROR SECTION ! 22942: * ! 22943: ERROR BEQ R$CIM,=CMLAB,CMPLE JUMP IF ERROR IN SCANNING LABEL ! 22944: MOV WA,KVERT SAVE ERROR CODE ! 22945: ZER SCNRS RESET RESCAN SWITCH FOR SCANE ! 22946: ZER SCNGO RESET GOTO SWITCH FOR SCANE ! 22947: MOV STAGE,XR LOAD CURRENT STAGE ! 22948: BSW XR,STGNO JUMP TO APPROPRIATE ERROR CIRCUIT ! 22949: IFF STGIC,ERR01 INITIAL COMPILE ! 22950: IFF STGXC,ERR04 EXECUTE TIME COMPILE ! 22951: IFF STGEV,ERR04 EVAL COMPILING EXPR. ! 22952: IFF STGEE,ERR04 EVAL EVALUATING EXPR ! 22953: IFF STGXT,ERR05 EXECUTE TIME ! 22954: IFF STGCE,ERR01 COMPILE - AFTER END ! 22955: IFF STGXE,ERR04 XEQ COMPILE-PAST END ! 22956: ESW END SWITCH ON ERROR TYPE ! 22957: EJC ! 22958: * ! 22959: * ERROR DURING INITIAL COMPILE ! 22960: * ! 22961: * THE ERROR MESSAGE IS PRINTED AS PART OF THE COMPILER ! 22962: * OUTPUT. THIS PRINTOUT INCLUDES THE OFFENDING LINE (IF NOT ! 22963: * PRINTED ALREADY) AND AN ERROR FLAG UNDER THE APPROPRIATE ! 22964: * COLUMN AS INDICATED BY SCNSE UNLESS SCNSE IS SET TO ZERO. ! 22965: * ! 22966: * AFTER PRINTING THE MESSAGE, THE GENERATED CODE IS ! 22967: * MODIFIED TO AN ERROR CALL AND CONTROL IS RETURNED TO ! 22968: * THE CMPIL PROCEDURE AFTER RESETTING THE STACK POINTER. ! 22969: * ! 22970: * IF THE ERROR OCCURS AFTER THE END LINE, CONTROL RETURNS ! 22971: * IN A SLIGHTLY DIFFERENT MANNER TO ENSURE PROPER CLEANUP. ! 22972: * ! 22973: ERR01 MOV CMPXS,XS RESET STACK POINTER ! 22974: SSL CMPSS RESTORE S-R STACK PTR FOR CMPIL ! 22975: BNZ ERRSP,ERR03 JUMP IF ERROR SUPPRESS FLAG SET ! 22976: MOV ERICH,ERLST SET FLAG FOR LISTR ! 22977: JSR LISTR LIST LINE ! 22978: JSR PRTIS TERMINATE LISTING ! 22979: ZER ERLST CLEAR LISTR FLAG ! 22980: MOV SCNSE,WA LOAD SCAN ELEMENT OFFSET ! 22981: BZE WA,ERR02 SKIP IF NOT SET ! 22982: LCT WB,WA LOOP COUNTER ! 22983: ICV WA INCREASE FOR CH$EX ! 22984: JSR ALOCS STRING BLOCK FOR ERROR FLAG ! 22985: MOV XR,WA REMEMBER STRING PTR ! 22986: PSC XR READY FOR CHARACTER STORING ! 22987: MOV R$CIM,XL POINT TO BAD STATEMENT ! 22988: PLC XL READY TO GET CHARS ! 22989: * ! 22990: * LOOP TO REPLACE ALL CHARS BUT TABS BY BLANKS ! 22991: * ! 22992: ERRA1 LCH WC,(XL)+ GET NEXT CHAR ! 22993: BEQ WC,=CH$HT,ERRA2 SKIP IF TAB ! 22994: MOV =CH$BL,WC GET A BLANK ! 22995: EJC ! 22996: * ! 22997: * MERGE TO STORE BLANK OR TAB IN ERROR LINE ! 22998: * ! 22999: ERRA2 SCH WC,(XR)+ STORE CHAR ! 23000: BCT WB,ERRA1 LOOP ! 23001: MOV =CH$EX,XL EXCLAMATION MARK ! 23002: SCH XL,(XR) STORE AT END OF ERROR LINE ! 23003: CSC XR END OF SCH LOOP ! 23004: MOV =STNPD,PROFS ALLOW FOR STATEMENT NUMBER ! 23005: MOV WA,XR POINT TO ERROR LINE ! 23006: JSR PRTST PRINT ERROR LINE ! 23007: * ! 23008: * HERE AFTER PLACING ERROR FLAG AS REQUIRED ! 23009: * ! 23010: ERR02 JSR ERMSG GENERATE FLAG AND ERROR MESSAGE ! 23011: ADD =NUM03,LSTLC BUMP PAGE CTR FOR BLANK, ERROR, BLK ! 23012: ZER XR IN CASE OF FATAL ERROR ! 23013: BHI ERRFT,=NUM03,STOPR PACK UP IF SEVERAL FATALS ! 23014: * ! 23015: * COUNT ERROR, INHIBIT EXECUTION IF REQUIRED ! 23016: * ! 23017: ICV CMERC BUMP ERROR COUNT ! 23018: ADD CSWER,NOXEQ INHIBIT XEQ IF -NOERRORS ! 23019: BNE STAGE,=STGIC,CMP10 SPECIAL RETURN IF AFTER END LINE ! 23020: EJC ! 23021: * ! 23022: * LOOP TO SCAN TO END OF STATEMENT ! 23023: * ! 23024: ERR03 MOV R$CIM,XR POINT TO START OF IMAGE ! 23025: PLC XR POINT TO FIRST CHAR ! 23026: LCH XR,(XR) GET FIRST CHAR ! 23027: BEQ XR,=CH$MN,CMPCE JUMP IF ERROR IN CONTROL CARD ! 23028: ZER SCNRS CLEAR RESCAN FLAG ! 23029: MNZ ERRSP SET ERROR SUPPRESS FLAG ! 23030: JSR SCANE SCAN NEXT ELEMENT ! 23031: BNE XL,=T$SMC,ERR03 LOOP BACK IF NOT STATEMENT END ! 23032: ZER ERRSP CLEAR ERROR SUPPRESS FLAG ! 23033: * ! 23034: * GENERATE ERROR CALL IN CODE AND RETURN TO CMPIL ! 23035: * ! 23036: MOV *CDCOD,CWCOF RESET OFFSET IN CCBLK ! 23037: MOV =OCER$,WA LOAD COMPILE ERROR CALL ! 23038: JSR CDWRD GENERATE IT ! 23039: MOV CWCOF,CMSOC(XS) SET SUCCESS FILL IN OFFSET ! 23040: MNZ CMFFC(XS) SET FAILURE FILL IN FLAG ! 23041: JSR CDWRD GENERATE SUCC. FILL IN WORD ! 23042: BRN CMPSE MERGE TO GENERATE ERROR AS CDFAL ! 23043: * ! 23044: * ERROR DURING EXECUTE TIME COMPILE OR EXPRESSION EVALUATIO ! 23045: * ! 23046: * EXECUTE TIME COMPILATION IS INITIATED THROUGH GTCOD OR ! 23047: * GTEXP WHICH ARE CALLED BY COMPILE, CODE OR EVAL. ! 23048: * BEFORE CAUSING STATEMENT FAILURE THROUGH EXFAL IT IS ! 23049: * HELPFUL TO SET KEYWORD ERRTEXT AND FOR GENERALITY ! 23050: * THESE ERRORS MAY BE HANDLED BY THE SETEXIT MECHANISM. ! 23051: * ! 23052: ERR04 ZER R$CCB FORGET GARBAGE CODE BLOCK ! 23053: SSL INISS RESTORE MAIN PROG S-R STACK PTR ! 23054: JSR ERTEX GET FAIL MESSAGE TEXT ! 23055: DCA XS ENSURE STACK OK ON LOOP START ! 23056: * ! 23057: * POP STACK UNTIL FIND FLPTR FOR MOST DEEPLY NESTED PROG. ! 23058: * DEFINED FUNCTION CALL OR CALL OF EVAL / CODE. ! 23059: * ! 23060: ERRA4 ICA XS POP STACK ! 23061: BEQ XS,FLPRT,ERRC4 JUMP IF PROG DEFINED FN CALL FOUND ! 23062: BNE XS,GTCEF,ERRA4 LOOP IF NOT EVAL OR CODE CALL YET ! 23063: MOV =STGXT,STAGE RE-SET STAGE FOR EXECUTE ! 23064: MOV R$GTC,R$COD RECOVER CODE PTR ! 23065: MOV XS,FLPTR RESTORE FAIL POINTER ! 23066: ZER R$CIM FORGET POSSIBLE IMAGE ! 23067: * ! 23068: * TEST ERRLIMIT ! 23069: * ! 23070: ERRB4 BNZ KVERL,ERR07 JUMP IF ERRLIMIT NON-ZERO ! 23071: BRN EXFAL FAIL ! 23072: * ! 23073: * RETURN FROM PROG. DEFINED FUNCTION IS OUTSTANDING ! 23074: * ! 23075: ERRC4 MOV FLPTR,XS RESTORE STACK FROM FLPTR ! 23076: BRN ERRB4 MERGE ! 23077: EJC ! 23078: * ! 23079: * ERROR AT EXECUTE TIME. ! 23080: * ! 23081: * THE ACTION TAKEN ON AN ERROR IS AS FOLLOWS. ! 23082: * ! 23083: * IF ERRLIMIT KEYWORD IS ZERO, AN ABORT IS SIGNALLED, ! 23084: * SEE CODING FOR SYSTEM LABEL ABORT AT L$ABO. ! 23085: * ! 23086: * OTHERWISE, ERRLIMIT IS DECREMENTED AND AN ERRTYPE TRACE ! 23087: * GENERATED IF REQUIRED. CONTROL RETURNS EITHER VIA A JUMP ! 23088: * TO CONTINUE (TO TAKE THE FAILURE EXIT) OR A SPECIFIED ! 23089: * SETEXIT TRAP IS EXECUTED AND CONTROL PASSES TO THE TRAP. ! 23090: * IF 3 OR MORE FATAL ERRORS OCCUR AN ABORT IS SIGNALLED ! 23091: * REGARDLESS OF ERRLIMIT AND SETEXIT - LOOPING IS ALL TOO ! 23092: * PROBABLE OTHERWISE. FATAL ERRORS INCLUDE STACK OVERFLOW ! 23093: * AND EXCEEDING STLIMIT. ! 23094: * ! 23095: ERR05 SSL INISS RESTORE MAIN PROG S-R STACK PTR ! 23096: BNZ DMVCH,ERR08 JUMP IF IN MID-DUMP ! 23097: * ! 23098: * MERGE HERE FROM ERR08 ! 23099: * ! 23100: ERR06 BZE KVERL,LABO1 ABORT IF ERRLIMIT IS ZERO ! 23101: JSR ERTEX GET FAIL MESSAGE TEXT ! 23102: * ! 23103: * MERGE FROM ERR04 ! 23104: * ! 23105: ERR07 BGE ERRFT,=NUM03,LABO1 ABORT IF TOO MANY FATAL ERRORS ! 23106: DCV KVERL DECREMENT ERRLIMIT ! 23107: MOV R$ERT,XL LOAD ERRTYPE TRACE POINTER ! 23108: JSR KTREX GENERATE ERRTYPE TRACE IF REQUIRED ! 23109: MOV R$COD,R$CNT SET CDBLK PTR FOR CONTINUATION ! 23110: MOV FLPTR,XR SET PTR TO FAILURE OFFSET ! 23111: MOV (XR),STXOF SAVE FAILURE OFFSET FOR CONTINUE ! 23112: MOV R$SXC,XR LOAD SETEXIT CDBLK POINTER ! 23113: BZE XR,LCNT1 CONTINUE IF NO SETEXIT TRAP ! 23114: ZER R$SXC ELSE RESET TRAP ! 23115: MOV =NULLS,STXVR RESET SETEXIT ARG TO NULL ! 23116: MOV (XR),XL LOAD PTR TO CODE BLOCK ROUTINE ! 23117: BRI XL EXECUTE FIRST TRAP STATEMENT ! 23118: * ! 23119: * INTERRUPTED PARTLY THROUGH A DUMP WHILST STORE IS IN A ! 23120: * MESS SO DO A TIDY UP OPERATION. SEE DUMPR FOR DETAILS. ! 23121: * ! 23122: ERR08 MOV DMVCH,XR CHAIN HEAD FOR AFFECTED VRBLKS ! 23123: BZE XR,ERR06 DONE IF ZERO ! 23124: MOV (XR),DMVCH SET NEXT LINK AS CHAIN HEAD ! 23125: JSR SETVR RESTORE VRGET FIELD ! 23126: BRN ERR08 LOOP THROUGH CHAIN ! 23127: TTL S P I T B O L -- HERE ENDETH THE CODE ! 23128: * ! 23129: * END OF ASSEMBLY ! 23130: * ! 23131: END END MACRO-SPITBOL ASSEMBLY ! 23132: ! 23133: ! 23134: ! 23135: ! 23136: ! 23137: ! 23138: ! 23139: ! 23140: ! 23141: ! 23142:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.