![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to spitv35.min 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.min 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: .DEF .CASL ! 444: .DEF .CAHT ! 445: .DEF .CIOD ! 446: .DEF .CSAX ! 447: .DEF .CSN8 ! 448: .DEF .CUCF ! 449: .DEF .CUEJ ! 450: .DEF .CULC ! 451: .DEF .CUST ! 452: TTL S P I T B O L -- PROCEDURES SECTION ! 453: * ! 454: * THIS SECTION STARTS WITH DESCRIPTIONS OF THE OPERATING ! 455: * SYSTEM DEPENDENT PROCEDURES WHICH ARE USED BY THE SPITBOL ! 456: * TRANSLATOR. ALL SUCH PROCEDURES HAVE FIVE LETTER NAMES ! 457: * BEGINNING WITH SYS. THEY ARE LISTED IN ALPHABETICAL ! 458: * ORDER. ! 459: * ALL PROCEDURES HAVE A SPECIFICATION CONSISTING OF A ! 460: * MODEL CALL, PRECEDED BY A POSSIBLY EMPTY LIST OF REGISTER ! 461: * CONTENTS GIVING PARAMETERS AVAILABLE TO THE PROCEDURE AND ! 462: * FOLLOWED BY A POSSIBLY EMPTY LIST OF REGISTER CONTENTS ! 463: * REQUIRED ON RETURN FROM THE CALL OR WHICH MAY HAVE HAD ! 464: * THEIR CONTENTS DESTROYED. ONLY THOSE REGISTERS EXPLICITLY ! 465: * MENTIONED IN THE LIST AFTER THE CALL MAY HAVE THEIR ! 466: * VALUES CHANGED. ! 467: * THE SEGMENT OF CODE PROVIDING THE EXTERNAL PROCEDURES IS ! 468: * CONVENIENTLY REFERRED TO AS OSINT (OPERATING SYSTEM ! 469: * INTERFACE). THE SYSXX PROCEDURES IT CONTAINS PROVIDE ! 470: * FACILITIES NOT USUALLY AVAILABLE AS PRIMITIVES IN ! 471: * ASSEMBLY LANGUAGES. FOR PARTICULAR TARGET MACHINES, ! 472: * IMPLEMENTORS MAY CHOOSE FOR SOME MINIMAL OPCODES WHICH ! 473: * DO NOT HAVE REASONABLY DIRECT TRANSLATIONS, TO USE CALLS ! 474: * OF ADDITIONAL PROCEDURES WHICH THEY PROVIDE IN OSINT. ! 475: * E.G. MWB OR TRC MIGHT BE TRANSLATED AS JSR SYSMB, ! 476: * JSR SYSTC IN SOME IMPLEMENTATIONS. ! 477: * ! 478: * IN THE DESCRIPTIONS, REFERENCE IS MADE TO --BLK ! 479: * FORMATS (-- = A PAIR OF LETTERS). SEE THE SPITBOL ! 480: * DEFINITIONS SECTION FOR DETAILED DESCRIPTIONS OF ALL ! 481: * SUCH BLOCK FORMATS EXCEPT FCBLK FOR WHICH SYSFC SHOULD ! 482: * BE CONSULTED. ! 483: * ! 484: * SECTION 0 CONTAINS INP,INR SPECIFICATIONS OF INTERNAL ! 485: * PROCEDURES,ROUTINES. THIS GIVES A SINGLE PASS TRANSLATOR ! 486: * INFORMATION MAKING IT EASY TO GENERATE ALTERNATIVE CALLS ! 487: * IN THE TRANSLATION OF JSR-S FOR PROCEDURES OF DIFFERENT ! 488: * TYPES IF THIS PROVES NECESSARY. ! 489: * ! 490: SEC START OF PROCEDURES SECTION ! 491: .IF .CSAX ! 492: EJC ! 493: * ! 494: * SYSAX -- AFTER EXECUTION ! 495: * ! 496: SYSAX EXP DEFINE EXTERNAL ENTRY POINT ! 497: * ! 498: * IF THE CONDITIONAL ASSEMBLY SYMBOL .CSAX IS DEFINED, ! 499: * THIS ROUTINE IS CALLED IMMEDIATELY AFTER EXECUTION AND ! 500: * BEFORE PRINTING OF EXECUTION STATISTICS OR DUMP OUTPUT. ! 501: * PURPOSE OF CALL IS FOR IMPLEMENTOR TO DETERMINE AND ! 502: * IF THE CALL IS NOT REQUIRED IT WILL BE OMITTED IF .CSAX ! 503: * IS UNDEFINED. IN THIS CASE SYSAX NEED NOT BE CODED. ! 504: * ! 505: * JSR SYSAX CALL AFTER EXECUTION ! 506: .ELSE ! 507: .FI ! 508: EJC ! 509: * ! 510: * SYSBX -- BEFORE EXECUTION ! 511: * ! 512: SYSBX EXP DEFINE EXTERNAL ENTRY POINT ! 513: * ! 514: * CALLED AFTER INITIAL SPITBOL COMPILATION AND BEFORE ! 515: * COMMENCING EXECUTION IN CASE OSINT NEEDS ! 516: * TO ASSIGN FILES OR PERFORM OTHER NECESSARY SERVICES. ! 517: * OSINT MAY ALSO CHOOSE TO SEND A MESSAGE TO ONLINE ! 518: * TERMINAL (IF ANY) INDICATING THAT EXECUTION IS STARTING. ! 519: * ! 520: * JSR SYSBX CALL BEFORE EXECUTION STARTS ! 521: EJC ! 522: .IF .CNCI ! 523: * ! 524: * SYSCI -- CONVERT INTEGER ! 525: * ! 526: SYSCI EXP ! 527: * ! 528: * SYSCI IS AN OPTIONAL OSINT ROUTINE THAT CAUSES SPITBOL TO ! 529: * CALL SYSCI TO CONVERT INTEGER VALUES TO STRINGS, RATHER ! 530: * THAN USING SPITBOL'S OWN INTERNAL CONVERSION CODE. THIS ! 531: * CODE MAY BE LESS EFFICIENT ON MACHINES WITH HARDWARE ! 532: * CONVERSION INSTRUCTIONS AND IN SUCH CASES, IT MAY BE AN ! 533: * ADVANTAGE TO INCLUDE SYSCI. THE SYMBOL .CNCI MUST BE ! 534: * DEFINED IF THIS ROUTINE IS TO BE USED. ! 535: * ! 536: * THE RULES FOR CONVERTING INTEGERS TO STRINGS ARE THAT ! 537: * POSITIVE VALUES ARE REPRESENTED WITHOUT ANY SIGN, AND ! 538: * THERE ARE NEVER ANY LEADING BLANKS OR ZEROS, EXCEPT IN ! 539: * THE CASE OF ZERO ITSELF WHICH IS REPRESENTED AS A SINGLE ! 540: * ZERO DIGIT. NEGATIVE NUMBERS ARE REPRESENTED WITH A ! 541: * PRECEEDING MINUS SIGN. THERE ARE NEVER ANY TRAILING ! 542: * BLANKS, AND CONVERSION CANNOT FAIL. ! 543: * ! 544: * (IA) VALUE TO BE CONVERTED ! 545: * JSR SYSCI CALL TO CONVERT INTEGER VALUE ! 546: * (XL) POINTER TO PSEUDO-SCBLK WITH STRING ! 547: EJC ! 548: .FI ! 549: * ! 550: * SYSDC -- DATE CHECK ! 551: * ! 552: SYSDC EXP DEFINE EXTERNAL ENTRY POINT ! 553: * ! 554: * SYSDC IS CALLED TO CHECK THAT THE EXPIRY DATE FOR A TRIAL ! 555: * VERSION OF SPITBOL IS UNEXPIRED. ! 556: * ! 557: * JSR SYSDC CALL TO CHECK DATE ! 558: * RETURN ONLY IF DATE IS OK ! 559: EJC ! 560: * ! 561: * SYSDM -- DUMP CORE ! 562: * ! 563: SYSDM EXP DEFINE EXTERNAL ENTRY POINT ! 564: * ! 565: * SYSDM IS CALLED BY A SPITBOL PROGRAM CALL OF DUMP(N) WITH ! 566: * N GE 3. ITS PURPOSE IS TO PROVIDE A CORE DUMP. ! 567: * N COULD HOLD AN ENCODING OF THE START ADRS FOR DUMP AND ! 568: * AMOUNT TO BE DUMPED E.G. N = 256*A + S , S = START ADRS ! 569: * IN KILOWORDS, A = KILOWORDS TO DUMP ! 570: * ! 571: * (XR) PARAMETER N OF CALL DUMP(N) ! 572: * JSR SYSDM CALL TO ENTER ROUTINE ! 573: EJC ! 574: * ! 575: * SYSDT -- GET CURRENT DATE ! 576: * ! 577: SYSDT EXP DEFINE EXTERNAL ENTRY POINT ! 578: * ! 579: * SYSDT IS USED TO OBTAIN THE CURRENT DATE. THE DATE IS ! 580: * RETURNED AS A CHARACTER STRING IN ANY FORMAT APPROPRIATE ! 581: * TO THE OPERATING SYSTEM IN USE. IT MAY ALSO CONTAIN THE ! 582: * CURRENT TIME OF DAY. SYSDT IS USED TO IMPLEMENT THE ! 583: * SNOBOL4 FUNCTION DATE. ! 584: * ! 585: * JSR SYSDT CALL TO GET DATE ! 586: * (XL) POINTER TO BLOCK CONTAINING DATE ! 587: * ! 588: * THE FORMAT OF THE BLOCK IS LIKE AN SCBLK EXCEPT THAT ! 589: * THE FIRST WORD NEED NOT BE SET. THE RESULT IS COPIED ! 590: * INTO SPITBOL DYNAMIC MEMORY ON RETURN. ! 591: EJC ! 592: * ! 593: * SYSEF -- EJECT FILE ! 594: * ! 595: SYSEF EXP DEFINE EXTERNAL ENTRY POINT ! 596: * ! 597: * SYSEF IS USED TO WRITE A PAGE EJECT TO A NAMED FILE. IT ! 598: * MAY ONLY BE USED FOR FILES WHERE THIS CONCEPT MAKES ! 599: * SENSE. NOTE THAT SYSEF IS NOT NORMALLY USED FOR THE ! 600: * STANDARD OUTPUT FILE (SEE SYSEP). ! 601: * ! 602: * (WA) PTR TO FCBLK OR ZERO ! 603: * (XR) EJECT ARGUMENT (SCBLK PTR) ! 604: * JSR SYSEF CALL TO EJECT FILE ! 605: * PPM LOC RETURN HERE IF FILE DOES NOT EXIST ! 606: * PPM LOC RETURN HERE IF INAPPROPRIATE FILE ! 607: * PPM LOC RETURN HERE IF I/O ERROR ! 608: EJC ! 609: * ! 610: * SYSEJ -- END OF JOB ! 611: * ! 612: SYSEJ EXP DEFINE EXTERNAL ENTRY POINT ! 613: * ! 614: * SYSEJ IS CALLED ONCE AT THE END OF EXECUTION TO ! 615: * TERMINATE THE RUN. THE SIGNIFICANCE OF THE ABEND AND ! 616: * CODE VALUES IS SYSTEM DEPENDENT. IN GENERAL, THE CODE ! 617: * VALUE SHOULD BE MADE AVAILABLE FOR TESTING, AND THE ! 618: * ABEND VALUE SHOULD CAUSE SOME POST-MORTEM ACTION SUCH AS ! 619: * A DUMP. NOTE THAT SYSEJ DOES NOT RETURN TO ITS CALLER. ! 620: * SEE SYSXI FOR DETAILS OF FCBLK CHAIN ! 621: * ! 622: * (WA) VALUE OF ABEND KEYWORD ! 623: * (WB) VALUE OF CODE KEYWORD ! 624: * (XL) O OR PTR TO HEAD OF FCBLK CHAIN ! 625: * JSR SYSEJ CALL TO END JOB ! 626: * ! 627: * THE FOLLOWING SPECIAL VALUES ARE USED AS CODES IN (WB) ! 628: * 999 EXECUTION SUPPRESSED ! 629: * 998 STANDARD OUTPUT FILE FULL OR UNAVAILABLE IN A SYSXI ! 630: * LOAD MODULE. IN THESE CASES (WA) CONTAINS THE NUMBER ! 631: * OF THE STATEMENT CAUSING PREMATURE TERMINATION. ! 632: EJC ! 633: * ! 634: * SYSEM -- GET ERROR MESSAGE TEXT ! 635: * ! 636: SYSEM EXP DEFINE EXTERNAL ENTRY POINT ! 637: * ! 638: * SYSEM IS USED TO OBTAIN THE TEXT OF ERR, ERB CALLS IN THE ! 639: * SOURCE PROGRAM GIVEN THE ERROR CODE NUMBER. IT IS ALLOWED ! 640: * TO RETURN A NULL STRING IF THIS FACILITY IS UNAVAILABLE. ! 641: * ! 642: * (WA) ERROR CODE NUMBER ! 643: * JSR SYSEM CALL TO GET TEXT ! 644: * (XR) TEXT OF MESSAGE ! 645: * ! 646: * THE RETURNED VALUE IS A POINTER TO A BLOCK IN SCBLK ! 647: * FORMAT EXCEPT THAT THE FIRST WORD NEED NOT BE SET. THE ! 648: * STRING IS COPIED INTO DYNAMIC MEMORY ON RETURN. ! 649: * IF THE NULL STRING IS RETURNED EITHER BECAUSE SYSEM DOES ! 650: * NOT PROVIDE ERROR MESSAGE TEXTS OR BECAUSE WA IS OUT OF ! 651: * RANGE, SPITBOL WILL PRINT THE STRING STORED IN ERRTEXT ! 652: * KEYWORD. ! 653: EJC ! 654: * ! 655: * SYSEN -- ENDFILE ! 656: * ! 657: SYSEN EXP DEFINE EXTERNAL ENTRY POINT ! 658: * ! 659: * SYSEN IS USED TO IMPLEMENT THE SNOBOL4 FUNCTION ENDFILE. ! 660: * THE MEANING IS SYSTEM DEPENDENT. IN GENERAL, ENDFILE ! 661: * IMPLIES THAT NO FURTHER I/O OPERATIONS WILL BE PERFORMED, ! 662: * BUT DOES NOT GUARANTEE THIS TO BE THE CASE. THE FILE ! 663: * SHOULD BE CLOSED AFTER THE CALL, A SUBSEQUENT READ ! 664: * OR WRITE MAY REOPEN THE FILE AT THE START OR IT MAY BE ! 665: * NECESSARY TO REOPEN THE FILE VIA SYSIO. ! 666: * ! 667: * (WA) PTR TO FCBLK OR ZERO ! 668: * (XR) ENDFILE ARGUMENT (SCBLK PTR) ! 669: * JSR SYSEN CALL TO ENDFILE ! 670: * PPM LOC RETURN HERE IF FILE DOES NOT EXIST ! 671: * PPM LOC RETURN HERE IF ENDFILE NOT ALLOWED ! 672: * PPM LOC RETURN HERE IF I/O ERROR ! 673: * (WA,WB) DESTROYED ! 674: * ! 675: * THE SECOND ERROR RETURN IS USED FOR FILES FOR WHICH ! 676: * ENDFILE IS NOT PERMITTED. FOR EXAMPLE, IT MAY BE EXPECTED ! 677: * THAT THE STANDARD INPUT AND OUTPUT FILES ARE IN THIS ! 678: * CATEGORY. ! 679: EJC ! 680: * ! 681: * SYSEP -- EJECT PRINTER PAGE ! 682: * ! 683: SYSEP EXP DEFINE EXTERNAL ENTRY POINT ! 684: * ! 685: * SYSEP IS CALLED TO PERFORM A PAGE EJECT ON THE STANDARD ! 686: * PRINTER OUTPUT FILE (CORRESPONDING TO SYSPR OUTPUT). ! 687: * ! 688: * JSR SYSEP CALL TO EJECT PRINTER OUTPUT ! 689: EJC ! 690: * ! 691: * SYSEX -- CALL EXTERNAL FUNCTION ! 692: * ! 693: SYSEX EXP DEFINE EXTERNAL ENTRY POINT ! 694: * ! 695: * SYSEX IS CALLED TO PASS CONTROL TO AN EXTERNAL FUNCTION ! 696: * PREVIOUSLY LOADED WITH A CALL TO SYSLD. ! 697: * ! 698: * (XS) POINTER TO ARGUMENTS ON STACK ! 699: * (XL) POINTER TO CONTROL BLOCK (EFBLK) ! 700: * (WA) NUMBER OF ARGUMENTS ON STACK ! 701: * JSR SYSEX CALL TO PASS CONTROL TO FUNCTION ! 702: * PPM LOC RETURN HERE IF FUNCTION CALL FAILS ! 703: * (XS) POPPED PAST ARGUMENTS ! 704: * (XR) RESULT RETURNED ! 705: * ! 706: * THE ARGUMENTS ARE STORED ON THE STACK WITH ! 707: * THE LAST ARGUMENT AT 0(XS). ON RETURN, XS ! 708: * IS POPPED PAST THE ARGUMENTS. ! 709: * ! 710: * THE FORM OF THE ARGUMENTS AS PASSED IS THAT USED IN THE ! 711: * SPITBOL TRANSLATOR (SEE DEFINITIONS AND DATA STRUCTURES ! 712: * SECTION). THE CONTROL BLOCK FORMAT IS ALSO DESCRIBED ! 713: * (UNDER EFBLK) IN THIS SECTION. ! 714: * ! 715: * THERE ARE TWO WAYS OF RETURNING A RESULT. ! 716: * ! 717: * 1) RETURN A POINTER TO A BLOCK IN DYNAMIC STORAGE. THIS ! 718: * BLOCK MUST BE IN EXACTLY CORRECT FORMAT, INCLUDING ! 719: * THE FIRST WORD. ONLY FUNCTIONS WRITTEN WITH INTIMATE ! 720: * KNOWLEDGE OF THE SYSTEM WILL RETURN IN THIS WAY. ! 721: * ! 722: * 2) STRING, INTEGER AND REAL RESULTS MAY BE RETURNED BY ! 723: * POINTING TO A PSEUDO-BLOCK OUTSIDE DYNAMIC MEMORY. ! 724: * THIS BLOCK IS IN ICBLK, RCBLK OR SCBLK FORMAT EXCEPT ! 725: * THAT THE FIRST WORD WILL BE OVERWRITTEN ! 726: * BY A TYPE WORD ON RETURN AND SO NEED NOT ! 727: * BE CORRECTLY SET. SUCH A RESULT IS ! 728: * COPIED INTO MAIN STORAGE BEFORE PROCEEDING. ! 729: * UNCONVERTED RESULTS MAY SIMILARLY BE RETURNED IN A ! 730: * PSEUDO-BLOCK WHICH IS IN CORRECT FORMAT INCLUDING ! 731: * TYPE WORD RECOGNISABLE BY GARBAGE COLLECTOR SINCE ! 732: * BLOCK IS COPIED INTO DYNAMIC MEMORY. ! 733: EJC ! 734: * ! 735: * SYSFC -- FILE CONTROL BLOCK ROUTINE ! 736: * ! 737: SYSFC EXP DEFINE EXTERNAL ENTRY POINT ! 738: * ! 739: * SEE ALSO SYSIO ! 740: * INPUT AND OUTPUT HAVE 3 ARGUMENTS REFERRED TO AS SHOWN ! 741: * INPUT(VARIABLE NAME,FILE ARG1,FILE ARG2) ! 742: * OUTPUT(VARIABLE NAME,FILE ARG1,FILE ARG2) ! 743: * FILE ARG1 MAY BE AN INTEGER OR STRING USED TO IDENTIFY ! 744: * AN I/O CHANNEL. IT IS CONVERTED TO A STRING FOR CHECKING. ! 745: * THE EXACT SIGNIFICANCE OF FILE ARG2 ! 746: * IS NOT RIGOROUSLY PRESCRIBED BUT TO IMPROVE PORTABILITY, ! 747: * THE SCHEME DESCRIBED IN THE SPITBOL USER MANUAL ! 748: * SHOULD BE ADOPTED WHEN POSSIBLE. THE PREFERRED FORM IS ! 749: * A STRING $F$,R$R$,C$C$,I$I$,...,Z$Z$ WHERE ! 750: * $F$ IS AN OPTIONAL FILE NAME WHICH IS PLACED FIRST. ! 751: * REMAINING ITEMS MAY BE OMITTED OR INCLUDED IN ANY ORDER. ! 752: * $R$ IS MAXIMUM RECORD LENGTH ! 753: * $C$ IS A CARRIAGE CONTROL CHARACTER OR CHARACTER STRING ! 754: * $I$ IS SOME FORM OF CHANNEL IDENTIFICATION USED IN THE ! 755: * ABSENCE OF $F$ TO ASSOCIATE THE VARIABLE ! 756: * WITH A FILE ALLOCATED DYNAMICALLY BY JCL COMMANDS AT ! 757: * SPITBOL LOAD TIME. ! 758: * ,...,Z$Z$ ARE ADDITIONAL FIELDS. ! 759: * IF , (COMMA) CANNOT BE USED AS A DELIMITER, .CIOD ! 760: * SHOULD BE DEFINED TO INTRODUCE BY CONDITIONAL ASSEMBLY ! 761: * ANOTHER DELIMITER (SEE ! 762: * IODEL EQU * ! 763: * EARLY IN DEFINITIONS SECTION). ! 764: * SYSFC IS CALLED WHEN A VARIABLE IS INPUT OR OUTPUT ! 765: * ASSOCIATED TO CHECK FILE ARG1 AND FILE ARG2 AND ! 766: * TO REPORT WHETHER AN FCBLK (FILE CONTROL ! 767: * BLOCK) IS NECESSARY AND IF SO WHAT SIZE IT SHOULD BE. ! 768: * THIS MAKES IT POSSIBLE FOR SPITBOL RATHER THAN OSINT TO ! 769: * ALLOCATE SUCH A BLOCK IN DYNAMIC MEMORY IF REQUIRED ! 770: * OR ALTERNATIVELY IN STATIC MEMORY. ! 771: * THE SIGNIFICANCE OF AN FCBLK , IF ONE IS REQUESTED, IS ! 772: * ENTIRELY UP TO THE SYSTEM INTERFACE. THE ONLY RESTRICTION ! 773: * IS THAT IF THE FCBLK SHOULD APPEAR TO LIE IN DYNAMIC ! 774: * MEMORY , POINTERS TO IT SHOULD BE PROPER POINTERS TO ! 775: * THE START OF A RECOGNISABLE AND GARBAGE COLLECTABLE ! 776: * BLOCK (THIS CONDITION WILL BE MET IF SYSFC REQUESTS ! 777: * SPITBOL TO PROVIDE AN FCBLK). ! 778: * AN OPTION IS PROVIDED FOR OSINT TO RETURN A POINTER IN ! 779: * XL TO AN FCBLK WHICH IT PRIVATELY ALLOCATED. THIS PTR ! 780: * WILL BE MADE AVAILABLE WHEN I/O OCCURS LATER. ! 781: * PRIVATE FCBLKS MAY HAVE ARBITRARY CONTENTS AND SPITBOL ! 782: * STORES NOTHING IN THEM. ! 783: EJC ! 784: * THE REQUESTED SIZE FOR AN FCBLK IN DYNAMIC MEMORY ! 785: * SHOULD ALLOW A 2 WORD OVERHEAD FOR BLOCK TYPE AND ! 786: * LENGTH FIELDS. INFORMATION SUBSEQUENTLY STORED IN THE ! 787: * REMAINING WORDS MAY BE ARBITRARY IF AN XNBLK (EXTERNAL ! 788: * NON-RELOCATABLE BLOCK) IS REQUESTED. IF THE REQUEST IS ! 789: * FOR AN XRBLK (EXTERNAL RELOCATABLE BLOCK) THE ! 790: * CONTENTS OF WORDS SHOULD BE COLLECTABLE (I.E. ANY ! 791: * APPARENT POINTERS INTO DYNAMIC SHOULD BE GENUINE BLOCK ! 792: * POINTERS). THESE RESTRICTIONS DO NOT APPLY IF AN FCBLK ! 793: * IS ALLOCATED OUTSIDE DYNAMIC OR IS NOT ALLOCATED AT ALL. ! 794: * IF AN FCBLK IS REQUESTED, ITS FIELDS WILL BE INITIALISED ! 795: * TO ZERO BEFORE ENTRY TO SYSIO WITH THE EXCEPTION OF ! 796: * WORDS 0 AND 1 IN WHICH THE BLOCK TYPE AND LENGTH ! 797: * FIELDS ARE PLACED FOR FCBLKS IN DYNAMIC MEMORY ONLY. ! 798: * FOR THE POSSIBLE USE OF SYSEJ AND SYSXI, IF FCBLKS ! 799: * ARE USED, A CHAIN IS BUILT SO THAT THEY MAY ALL BE ! 800: * FOUND - SEE SYSXI FOR DETAILS. ! 801: * IF BOTH FILE ARG1 AND FILE ARG2 ARE NULL, CALLS OF SYSFC ! 802: * AND SYSIO ARE OMITTED. ! 803: * IF FILE ARG1 IS NULL (STANDARD INPUT/OUTPUT FILE), SYSFC ! 804: * IS CALLED TO CHECK NON-NULL FILE ARG2 BUT ANY REQUEST ! 805: * FOR AN FCBLK WILL BE IGNORED, SINCE SPITBOL HANDLES THE ! 806: * STANDARD FILES SPECIALLY AND CANNOT READILY KEEP FCBLK ! 807: * POINTERS FOR THEM. ! 808: * FILEARG1 IS TYPE CHECKED BY SPITBOL SO FURTHER CHECKING ! 809: * MAY BE UNNECCESSARY IN MANY IMPLEMENTATIONS. ! 810: * FILE ARG2 IS PASSED SO THAT SYSFC MAY ANALYSE AND ! 811: * CHECK IT. HOWEVER TO ASSIST IN THIS, SPITBOL ALSO PASSES ! 812: * ON THE STACK THE COMPONENTS OF THIS ARGUMENT WITH ! 813: * FILE NAME, $F$ (OTHERWISE NULL) EXTRACTED AND STACKED ! 814: * FIRST. ! 815: * THE OTHER FIELDS, IF ANY, ARE EXTRACTED AS SUBSTRINGS, ! 816: * POINTERS TO THEM ARE STACKED AND A COUNT OF ALL ITEMS ! 817: * STACKED IS PLACED IN WC. IF AN FCBLK WAS EARLIER ! 818: * ALLOCATED AND POINTED TO VIA FILE ARG1, SYSFC IS ALSO ! 819: * PASSED A POINTER TO THIS FCBLK. ! 820: * ! 821: * (XL) FILE ARG1 SCBLK PTR (2ND ARG) ! 822: * (XR) FILEARG2 (3RD ARG) OR NULL ! 823: * -(XS)...-(XS) SCBLKS FOR $F$,$R$,$C$,... ! 824: * (WC) NO. OF STACKED SCBLKS ABOVE ! 825: * (WA) EXISTING FILE ARG1 FCBLK PTR OR 0 ! 826: * (WB) 0/3 FOR INPUT/OUTPUT ASSOCN ! 827: * JSR SYSFC CALL TO CHECK NEED FOR FCBLK ! 828: * PPM LOC INVALID FILE ARGUMENT ! 829: * (XS) POPPED (WC) TIMES ! 830: * (WA NON ZERO) BYTE SIZE OF REQUESTED FCBLK ! 831: * (WA=0,XL NON ZERO) PRIVATE FCBLK PTR IN XL ! 832: * (WA=XL=0) NO FCBLK WANTED, NO PRIVATE FCBLK ! 833: * (WC) 0/1/2 REQUEST ALLOC OF XRBLK/XNBLK ! 834: * /STATIC BLOCK FOR USE AS FCBLK ! 835: * (WB) DESTROYED ! 836: EJC ! 837: * ! 838: * SYSHS -- GIVE ACCESS TO HOST COMPUTER FEATURES ! 839: * ! 840: SYSHS EXP DEFINE EXTERNAL ENTRY POINT ! 841: * ! 842: * PROVIDES MEANS FOR IMPLEMENTING SPECIAL FEATURES ! 843: * ON DIFFERENT HOST COMPUTERS. THE ONLY DEFINED ENTRY IS ! 844: * THAT WHERE ALL ARGUMENTS ARE NULL IN WHICH CASE SYSHS ! 845: * RETURNS AN SCBLK CONTAINING NAME OF COMPUTER, ! 846: * NAME OF OPERATING SYSTEM AND NAME OF SITE SEPARATED BY ! 847: * COLONS. THE SCBLK NEED NOT HAVE A CORRECT FIRST FIELD ! 848: * AS THIS IS SUPPLIED ON COPYING STRING TO DYNAMIC MEMORY. ! 849: * SPITBOL DOES NO ARGUMENT CHECKING BUT DOES PROVIDE A ! 850: * SINGLE ERROR RETURN FOR ARGUMENTS CHECKED AS ERRONEOUS ! 851: * BY OSINT. IT ALSO PROVIDES A SINGLE EXECUTION ERROR ! 852: * RETURN. IF THESE ARE INADEQUATE, USE MAY BE MADE OF THE ! 853: * MINIMAL ERROR SECTION DIRECT AS DESCRIBED IN MINIMAL ! 854: * DOCUMENTATION, SECTION 10. ! 855: * SEVERAL NON-ERROR RETURNS ARE PROVIDED. THE FIRST ! 856: * CORRESPONDS TO THE DEFINED ENTRY OR, FOR IMPLEMENTATION ! 857: * DEFINED ENTRIES, ANY STRING MAY BE RETURNED. THE OTHERS ! 858: * PERMIT RESPECTIVELY, RETURN A NULL RESULT, RETURN WITH A ! 859: * RESULT TO BE STACKED WHICH IS POINTED AT BY XR, AND A ! 860: * RETURN CAUSING SPITBOL STATEMENT FAILURE. IF A RETURNED ! 861: * RESULT IS IN DYNAMIC MEMORY IT MUST OBEY GARBAGE ! 862: * COLLECTOR RULES. THE ONLY RESULTS COPIED ON RETURN ! 863: * ARE STRINGS RETURNED VIA PPM LOC3 RETURN. ! 864: * ! 865: * (WA) ARGUMENT 1 ! 866: * (XL) ARGUMENT 2 ! 867: * (XR) ARGUMENT 3 ! 868: * JSR SYSHS CALL TO GET HOST INFORMATION ! 869: * PPM LOC1 ERRONEOUS ARG ! 870: * PPM LOC2 EXECUTION ERROR ! 871: * PPM LOC3 SCBLK PTR IN XL OR 0 IF UNAVAILABLE ! 872: * PPM LOC4 RETURN A NULL RESULT ! 873: * PPM LOC5 RETURN RESULT IN XR ! 874: * PPM LOC6 CAUSE STATEMENT FAILURE ! 875: EJC ! 876: * ! 877: * SYSID -- RETURN SYSTEM IDENTIFICATION ! 878: * ! 879: SYSID EXP DEFINE EXTERNAL ENTRY POINT ! 880: * ! 881: * THIS ROUTINE SHOULD RETURN STRINGS TO HEAD THE STANDARD ! 882: * PRINTER OUTPUT. THE FIRST STRING WILL BE APPENDED TO ! 883: * A HEADING LINE OF THE FORM ! 884: * MACRO SPITBOL VERSION V.V ! 885: * SUPPLIED BY SPITBOL ITSELF. V.V ARE DIGITS GIVING THE ! 886: * MAJOR VERSION NUMBER AND GENERALLY AT LEAST A MINOR ! 887: * VERSION NUMBER RELATING TO OSINT SHOULD BE SUPPLIED TO ! 888: * GIVE SAY ! 889: * MACRO SPITBOL VERSION V.V(M.M) ! 890: * THE SECOND STRING SHOULD IDENTIFY AT LEAST THE MACHINE ! 891: * AND OPERATING SYSTEM. PREFERABLY IT SHOULD INCLUDE ! 892: * THE DATE AND TIME OF THE RUN. ! 893: * OPTIONALLY THE STRINGS MAY INCLUDE SITE NAME OF THE ! 894: * THE IMPLEMENTOR AND/OR MACHINE ON WHICH RUN TAKES PLACE, ! 895: * UNIQUE SITE OR COPY NUMBER AND OTHER INFORMATION AS ! 896: * APPROPRIATE WITHOUT MAKING IT SO LONG AS TO BE A ! 897: * NUISANCE TO USERS. ! 898: * THE FIRST WORDS OF THE SCBLKS POINTED AT NEED NOT BE ! 899: * CORRECTLY SET. ! 900: * ! 901: * JSR SYSID CALL FOR SYSTEM IDENTIFICATION ! 902: * (XR) SCBLK PTR FOR ADDITION TO HEADER ! 903: * (XL) PTR TO SECOND HEADER SCBLK ! 904: EJC ! 905: * ! 906: * SYSIL -- GET INPUT RECORD LENGTH ! 907: * ! 908: SYSIL EXP DEFINE EXTERNAL ENTRY POINT ! 909: * ! 910: * SYSIL IS USED TO GET THE LENGTH OF THE NEXT INPUT RECORD ! 911: * FROM A FILE PREVIOUSLY INPUT ASSOCIATED WITH A SYSIO ! 912: * CALL. THE LENGTH RETURNED IS USED TO ESTABLISH A BUFFER ! 913: * FOR A SUBSEQUENT SYSIN CALL. ! 914: * ! 915: * (WA) PTR TO FCBLK OR ZERO ! 916: * JSR SYSIL CALL TO GET RECORD LENGTH ! 917: * (WA) LENGTH OR ZERO IF FILE CLOSED ! 918: * ! 919: * NO HARM IS DONE IF THE VALUE RETURNED IS TOO LONG SINCE ! 920: * UNUSED SPACE WILL BE RECLAIMED AFTER THE SYSIN CALL. ! 921: * ! 922: * NOTE THAT IT IS THE SYSIL CALL (NOT THE SYSIO CALL) WHICH ! 923: * CAUSES THE FILE TO BE OPENED AS REQUIRED FOR THE FIRST ! 924: * RECORD INPUT FROM THE FILE. ! 925: EJC ! 926: * ! 927: * SYSIN -- READ INPUT RECORD ! 928: * ! 929: SYSIN EXP DEFINE EXTERNAL ENTRY POINT ! 930: * ! 931: * SYSIN IS USED TO READ A RECORD FROM THE FILE WHICH WAS ! 932: * REFERENCED IN A PRIOR CALL TO SYSIL (I.E. THESE CALLS ! 933: * ALWAYS OCCUR IN PAIRS). THE BUFFER PROVIDED IS AN ! 934: * SCBLK FOR A STRING OF LENGTH SET FROM THE SYSIL CALL. ! 935: * IF THE ACTUAL LENGTH READ IS LESS THAN THIS, THE LENGTH ! 936: * FIELD OF THE SCBLK MUST BE MODIFIED BEFORE RETURNING ! 937: * UNLESS BUFFER IS RIGHT PADDED WITH ZEROES. ! 938: * IT IS ALSO PERMISSIBLE TO TAKE ANY OF THE ALTERNATIVE ! 939: * RETURNS AFTER SCBLK LENGTH HAS BEEN MODIFIED. ! 940: * ! 941: * (WA) PTR TO FCBLK OR ZERO ! 942: * (XR) POINTER TO BUFFER (SCBLK PTR) ! 943: * JSR SYSIN CALL TO READ RECORD ! 944: * PPM LOC ENDFILE OR NO I/P FILE AFTER SYSXI ! 945: * PPM LOC RETURN HERE IF I/O ERROR ! 946: * PPM LOC RETURN HERE IF RECORD FORMAT ERROR ! 947: * (WA,WB,WC) DESTROYED ! 948: EJC ! 949: * ! 950: * SYSIO -- INPUT/OUTPUT FILE ASSOCIATION ! 951: * ! 952: SYSIO EXP DEFINE EXTERNAL ENTRY POINT ! 953: * ! 954: * SEE ALSO SYSFC. ! 955: * SYSIO IS CALLED IN RESPONSE TO A SNOBOL4 INPUT OR OUTPUT ! 956: * FUNCTION CALL EXCEPT WHEN FILE ARG1 AND FILE ARG2 ! 957: * ARE BOTH NULL. ! 958: * ITS CALL ALWAYS FOLLOWS IMMEDIATELY AFTER A CALL ! 959: * OF SYSFC. IF SYSFC REQUESTED ALLOCATION ! 960: * OF AN FCBLK, ITS ADDRESS WILL BE IN WA. ! 961: * FOR INPUT FILES, NON-ZERO VALUES OF $R$ SHOULD BE ! 962: * COPIED TO WC FOR USE IN ALLOCATING INPUT BUFFERS. IF $R$ ! 963: * IS DEFAULTED OR NOT IMPLEMENTED, WC SHOULD BE ZEROISED. ! 964: * ONCE A FILE HAS BEEN OPENED, SUBSEQUENT INPUT(),OUTPUT() ! 965: * CALLS IN WHICH THE SECOND ARGUMENT IS IDENTICAL WITH THAT ! 966: * IN A PREVIOUS CALL, MERELY ASSOCIATE THE ADDITIONAL ! 967: * VARIABLE NAME (FIRST ARGUMENT) TO THE FILE AND DO NOT ! 968: * RESULT IN RE-OPENING THE FILE. ! 969: * IN SUBSEQUENT ASSOCIATED ACCESSES TO THE FILE A POINTER ! 970: * TO ANY FCBLK ALLOCATED WILL BE MADE AVAILABLE. ! 971: * ! 972: * (XL) FILE ARG1 SCBLK PTR (2ND ARG) ! 973: * (XR) FILE ARG2 SCBLK PTR (3RD ARG) ! 974: * (WA) FCBLK PTR (0 IF NONE) ! 975: * (WB) 0 FOR INPUT, 3 FOR OUTPUT ! 976: * JSR SYSIO CALL TO ASSOCIATE FILE ! 977: * PPM LOC RETURN HERE IF FILE DOES NOT EXIST ! 978: * PPM LOC RETURN IF INPUT/OUTPUT NOT ALLOWED ! 979: * (XL) FCBLK POINTER (0 IF NONE) ! 980: * (WC) 0 (FOR DEFAULT) OR MAX RECORD LNGTH ! 981: * (WA,WB) DESTROYED ! 982: * ! 983: * THE SECOND ERROR RETURN IS USED IF THE FILE NAMED EXISTS ! 984: * BUT INPUT/OUTPUT FROM THE FILE IS NOT ALLOWED. FOR ! 985: * EXAMPLE, THE STANDARD OUTPUT FILE MAY BE IN THIS CATEGORY ! 986: * AS REGARDS INPUT ASSOCIATION. ! 987: EJC ! 988: * ! 989: * SYSLD -- LOAD EXTERNAL FUNCTION ! 990: * ! 991: SYSLD EXP DEFINE EXTERNAL ENTRY POINT ! 992: * ! 993: * SYSLD IS CALLED IN RESPONSE TO THE USE OF THE SNOBOL4 ! 994: * LOAD FUNCTION. THE NAMED FUNCTION IS LOADED (WHATEVER ! 995: * THIS MEANS), AND A POINTER IS RETURNED. THE POINTER WILL ! 996: * BE USED ON SUBSEQUENT CALLS TO THE FUNCTION (SEE SYSEX). ! 997: * ! 998: * (XR) POINTER TO FUNCTION NAME (SCBLK) ! 999: * (XL) POINTER TO LIBRARY NAME (SCBLK) ! 1000: * JSR SYSLD CALL TO LOAD FUNCTION ! 1001: * PPM LOC RETURN HERE IF FUNC DOES NOT EXIST ! 1002: * PPM LOC RETURN HERE IF I/O ERROR ! 1003: * (XR) POINTER TO LOADED CODE ! 1004: * ! 1005: * THE SIGNIFICANCE OF THE POINTER RETURNED IS UP TO THE ! 1006: * SYSTEM INTERFACE ROUTINE. THE ONLY RESTRICTION IS THAT ! 1007: * IF THE POINTER IS WITHIN DYNAMIC STORAGE, IT MUST BE ! 1008: * A PROPER BLOCK POINTER. ! 1009: EJC ! 1010: * ! 1011: * SYSMM -- GET MORE MEMORY ! 1012: * ! 1013: SYSMM EXP DEFINE EXTERNAL ENTRY POINT ! 1014: * ! 1015: * SYSMM IS CALLED IN AN ATTEMPT TO ALLOCATE MORE DYNAMIC ! 1016: * MEMORY. THIS MEMORY MUST BE ALLOCATED CONTIGUOUSLY WITH ! 1017: * THE CURRENT DYNAMIC DATA AREA. ! 1018: * ! 1019: * THE AMOUNT ALLOCATED IS UP TO THE SYSTEM TO DECIDE. ANY ! 1020: * VALUE IS ACCEPTABLE INCLUDING ZERO IF ALLOCATION IS ! 1021: * IMPOSSIBLE. ! 1022: * ! 1023: * JSR SYSMM CALL TO GET MORE MEMORY ! 1024: * (XR) NUMBER OF ADDITIONAL WORDS OBTAINED ! 1025: EJC ! 1026: * ! 1027: * SYSMX -- SUPPLY MXLEN ! 1028: * ! 1029: SYSMX EXP DEFINE EXTERNAL ENTRY POINT ! 1030: * ! 1031: * BECAUSE OF THE METHOD OF GARBAGE COLLECTION, NO SPITBOL ! 1032: * OBJECT IS ALLOWED TO OCCUPY MORE BYTES OF MEMORY THAN ! 1033: * THE INTEGER GIVING THE LOWEST ADDRESS OF DYNAMIC ! 1034: * (GARBAGE COLLECTABLE) MEMORY. MXLEN IS THE NAME USED TO ! 1035: * REFER TO THIS MAXIMUM LENGTH OF AN OBJECT AND FOR MOST ! 1036: * USERS OF MOST IMPLEMENTATIONS, PROVIDED DYNAMIC MEMORY ! 1037: * STARTS AT AN ADDRESS OF AT LEAST A FEW THOUSAND WORDS, ! 1038: * THERE IS NO PROBLEM. ! 1039: * IF THE DEFAULT STARTING ADDRESS IS LESS THAN SAY 10000 OR ! 1040: * 20000, THEN A LOAD TIME OPTION SHOULD BE PROVIDED WHERE A ! 1041: * USER CAN REQUEST THAT HE BE ABLE TO CREATE LARGER ! 1042: * OBJECTS. THIS ROUTINE INFORMS SPITBOL OF THIS REQUEST IF ! 1043: * ANY. THE VALUE RETURNED IS EITHER AN INTEGER ! 1044: * REPRESENTING THE DESIRED VALUE OF MXLEN (AND HENCE THE ! 1045: * MINIMUM DYNAMIC STORE ADDRESS WHICH MAY RESULT IN ! 1046: * NON-USE OF SOME STORE) OR ZERO IF A DEFAULT IS ACCEPTABLE ! 1047: * IN WHICH MXLEN IS SET TO THE LOWEST ADDRESS ALLOCATED ! 1048: * TO DYNAMIC STORE BEFORE COMPILATION STARTS. ! 1049: * IF A NON-ZERO VALUE IS RETURNED, THIS IS USED FOR KEYWORD ! 1050: * MAXLNGTH. OTHERWISE THE INITIAL LOW ADDRESS OF DYNAMIC ! 1051: * MEMORY IS USED FOR THIS KEYWORD. ! 1052: * ! 1053: * JSR SYSMX CALL TO GET MXLEN ! 1054: * (WA) EITHER MXLEN OR 0 FOR DEFAULT ! 1055: EJC ! 1056: * ! 1057: * SYSOU -- OUTPUT RECORD ! 1058: * ! 1059: SYSOU EXP DEFINE EXTERNAL ENTRY POINT ! 1060: * ! 1061: * SYSOU IS USED TO WRITE A RECORD TO A FILE PREVIOUSLY ! 1062: * ASSOCIATED WITH A SYSIO CALL. ! 1063: * ! 1064: * (WA) PTR TO FCBLK OR ZERO ! 1065: * (XR) RECORD TO BE WRITTEN (SCBLK) ! 1066: * JSR SYSOU CALL TO OUTPUT RECORD ! 1067: * PPM LOC FILE FULL OR NO FILE AFTER SYSXI ! 1068: * PPM LOC RETURN HERE IF I/O ERROR ! 1069: * (WA,WB,WC) DESTROYED ! 1070: * ! 1071: * NOTE THAT IT IS THE SYSOU CALL (NOT THE SYSIO CALL) WHICH ! 1072: * CAUSES THE FILE TO BE OPENED AS REQUIRED FOR THE FIRST ! 1073: * RECORD OUTPUT TO THE FILE. ! 1074: EJC ! 1075: * ! 1076: * SYSPI -- PRINT ON INTERACTIVE CHANNEL ! 1077: * ! 1078: SYSPI EXP DEFINE EXTERNAL ENTRY POINT ! 1079: * ! 1080: * IF SPITBOL IS RUN FROM AN ONLINE TERMINAL, OSINT CAN ! 1081: * REQUEST THAT MESSAGES SUCH AS COPIES OF COMPILATION ! 1082: * ERRORS BE SENT TO THE TERMINAL (SEE SYSPP). IF RELEVANT ! 1083: * REPLY WAS MADE BY SYSPP THEN SYSPI IS CALLED TO SEND SUCH ! 1084: * MESSAGES TO THE INTERACTIVE CHANNEL. ! 1085: * SYSPI IS ALSO USED FOR SENDING OUTPUT TO THE TERMINAL ! 1086: * THROUGH THE SPECIAL VARIABLE NAME, TERMINAL. ! 1087: * ! 1088: * (XR) PTR TO LINE BUFFER (SCBLK) ! 1089: * (WA) LINE LENGTH ! 1090: * JSR SYSPI CALL TO PRINT LINE ! 1091: * PPM LOC FAILURE RETURN ! 1092: * (WA,WB) DESTROYED ! 1093: EJC ! 1094: * ! 1095: * SYSPP -- OBTAIN PRINT PARAMETERS ! 1096: * ! 1097: SYSPP EXP DEFINE EXTERNAL ENTRY POINT ! 1098: * ! 1099: * SYSPP IS CALLED ONCE DURING COMPILATION TO OBTAIN ! 1100: * PARAMETERS REQUIRED FOR CORRECT PRINTED OUTPUT FORMAT ! 1101: * AND TO SELECT OTHER OPTIONS. IT MAY ALSO BE CALLED AGAIN ! 1102: * AFTER SYSXI WHEN A LOAD MODULE IS RESUMED. IN THIS ! 1103: * CASE THE VALUE RETURNED IN WA MAY BE LESS THAN OR EQUAL ! 1104: * TO THAT RETURNED IN INITIAL CALL BUT MAY NOT BE ! 1105: * GREATER. ! 1106: * THE INFORMATION RETURNED IS - ! 1107: * 1. LINE LENGTH IN CHARS FOR STANDARD PRINT FILE ! 1108: * 2. NO OF LINES/PAGE. 0 IS PREFERABLE FOR A NON-PAGED ! 1109: * DEVICE (E.G. ONLINE TERMINAL) IN WHICH CASE LISTING ! 1110: * PAGE THROWS ARE SUPPRESSED AND PAGE HEADERS ! 1111: * RESULTING FROM -TITLE,-STITL LINES ARE KEPT SHORT. ! 1112: * 3. AN INITIAL -NOLIST OPTION TO SUPPRESS LISTING UNLESS ! 1113: * THE PROGRAM CONTAINS AN EXPLICIT -LIST. ! 1114: * 4. OPTIONS TO SUPPRESS LISTING OF COMPILATION AND/OR ! 1115: * EXECUTION STATS (USEFUL FOR ESTABLISHED PROGRAMS) - ! 1116: * COMBINED WITH 3. GIVES POSSIBILITY OF LISTING ! 1117: * FILE NEVER BEING OPENED. ! 1118: * 5. OPTION TO HAVE COPIES OF ERRORS SENT TO AN ! 1119: * INTERACTIVE CHANNEL IN ADDITION TO STANDARD PRINTER. ! 1120: * 6. OPTION TO KEEP PAGE HEADERS SHORT (E.G. IF LISTING ! 1121: * TO AN ONLINE TERMINAL). ! 1122: * 7. AN OPTION TO CHOOSE EXTENDED OR COMPACT LISTING ! 1123: * FORMAT. IN THE FORMER A PAGE EJECT AND IN THE LATTER ! 1124: * A FEW LINE FEEDS PRECEDE THE PRINTING OF EACH ! 1125: * OF-- LISTING, COMPILATION STATISTICS, EXECUTION ! 1126: * OUTPUT AND EXECUTION STATISTICS. ! 1127: * 8. AN OPTION TO SUPPRESS EXECUTION AS THOUGH A ! 1128: * -NOEXECUTE CARD WERE SUPPLIED. ! 1129: * 9. AN OPTION TO REQUEST THAT NAME /TERMINAL/ BE PRE- ! 1130: * ASSOCIATED TO AN ONLINE TERMINAL VIA SYSPI AND SYSRI ! 1131: * 10. AN INTERMEDIATE (STANDARD) LISTING OPTION REQUIRING ! 1132: * THAT PAGE EJECTS OCCUR IN SOURCE LISTINGS. REDUNDANT ! 1133: * IF EXTENDED OPTION CHOSEN BUT PARTIALLY EXTENDS ! 1134: * COMPACT OPTION. ! 1135: * 11. OPTION TO SUPPRESS SYSID IDENTIFICATION. ! 1136: * ! 1137: * JSR SYSPP CALL TO GET PRINT PARAMETERS ! 1138: * (WA) PRINT LINE LENGTH IN CHARS ! 1139: * (WB) NUMBER OF LINES/PAGE ! 1140: * (WC) BITS VALUE ...JIHGFEDCBA WHERE ! 1141: * A = 1 TO SEND ERROR COPY TO INT.CH. ! 1142: * B = 1 MEANS STD PRINTER IS INT. CH. ! 1143: * C = 1 FOR -NOLIST OPTION ! 1144: * D = 1 TO SUPPRESS COMPILN. STATS ! 1145: * E = 1 TO SUPPRESS EXECN. STATS ! 1146: * F = 1/0 FOR EXTNDED/COMPACT LISTING ! 1147: * G = 1 FOR -NOEXECUTE ! 1148: * H = 1 PRE-ASSOCIATE /TERMINAL/ ! 1149: * I = 1 FOR STANDARD LISTING OPTION. ! 1150: * J = 1 SUPPRESSES LISTING HEADER ! 1151: EJC ! 1152: * ! 1153: * SYSPR -- PRINT LINE ON STANDARD OUTPUT FILE ! 1154: * ! 1155: SYSPR EXP DEFINE EXTERNAL ENTRY POINT ! 1156: * ! 1157: * SYSPR IS USED TO PRINT A SINGLE LINE ON THE STANDARD ! 1158: * OUTPUT FILE. ! 1159: * ! 1160: * (XR) POINTER TO LINE BUFFER (SCBLK) ! 1161: * (WA) LINE LENGTH ! 1162: * JSR SYSPR CALL TO PRINT LINE ! 1163: * PPM LOC TOO MUCH O/P OR NO FILE AFTER SYSXI ! 1164: * (WA,WB) DESTROYED ! 1165: * ! 1166: * THE BUFFER POINTED TO IS THE LENGTH OBTAINED FROM THE ! 1167: * SYSPP CALL AND IS FILLED OUT WITH TRAILING BLANKS. THE ! 1168: * VALUE IN WA IS THE ACTUAL LINE LENGTH WHICH MAY BE LESS ! 1169: * THAN THE MAXIMUM LINE LENGTH POSSIBLE. THERE IS NO SPACE ! 1170: * CONTROL ASSOCIATED WITH THE LINE, ALL LINES ARE PRINTED ! 1171: * SINGLE SPACED. NOTE THAT NULL LINES (WA=0) ARE POSSIBLE ! 1172: * IN WHICH CASE A BLANK LINE IS TO BE PRINTED. ! 1173: * ! 1174: * THE ERROR EXIT IS USED FOR SYSTEMS WHICH LIMIT THE AMOUNT ! 1175: * OF PRINTED OUTPUT. IF POSSIBLE, PRINTING SHOULD BE ! 1176: * PERMITTED AFTER THIS CONDITION HAS BEEN SIGNALLED ONCE TO ! 1177: * ALLOW FOR DUMP AND OTHER DIAGNOSTIC INFORMATION. ! 1178: * ASSUMING THIS TO BE POSSIBLE, SPITBOL MAY MAKE MORE SYSPR ! 1179: * CALLS. IF THE ERROR RETURN OCCURS ANOTHER TIME, EXECUTION ! 1180: * IS TERMINATED BY A CALL OF SYSEJ WITH ENDING CODE 998. ! 1181: EJC ! 1182: * ! 1183: * SYSRD -- READ RECORD FROM STANDARD INPUT FILE ! 1184: * ! 1185: SYSRD EXP DEFINE EXTERNAL ENTRY POINT ! 1186: * ! 1187: * SYSRD IS USED TO READ A RECORD FROM THE STANDARD INPUT ! 1188: * FILE. THE BUFFER PROVIDED IS AN SCBLK FOR A STRING THE ! 1189: * LENGTH OF WHICH IN CHARACTERS IS GIVEN IN WC, THIS ! 1190: * CORRESPONDING TO THE MAXIMUM LENGTH OF STRING WHICH ! 1191: * SPITBOL IS PREPARED TO RECEIVE. AT COMPILE TIME IT ! 1192: * CORRESPONDS TO XXX IN THE MOST RECENT -INXXX CARD ! 1193: * (DEFAULT 72) AND AT EXECUTION TIME TO THE MOST RECENT ! 1194: * ,R$R$ (RECORD LENGTH) IN THE THIRD ARG OF AN INPUT() ! 1195: * STATEMENT FOR THE STANDARD INPUT FILE (DEFAULT 80). ! 1196: * IF FEWER THAN (WC) CHARACTERS ARE READ, THE LENGTH ! 1197: * FIELD OF THE SCBLK MUST BE ADJUSTED BEFORE RETURNING ! 1198: * UNLESS THE BUFFER IS RIGHT PADDED WITH ZEROES. ! 1199: * IT IS ALSO PERMISSIBLE TO TAKE THE ALTERNATIVE RETURN ! 1200: * AFTER SUCH AN ADJUSTMENT HAS BEEN MADE. ! 1201: * SPITBOL MAY CONTINUE TO MAKE CALLS AFTER AN ENDFILE ! 1202: * RETURN SO THIS ROUTINE SHOULD BE PREPARED TO MAKE ! 1203: * REPEATED ENDFILE RETURNS. ! 1204: * ! 1205: * (XR) POINTER TO BUFFER (SCBLK PTR) ! 1206: * (WC) LENGTH OF BUFFER IN CHARACTERS ! 1207: * JSR SYSRD CALL TO READ LINE ! 1208: * PPM LOC ENDFILE OR NO I/P FILE AFTER SYSXI ! 1209: * (WA,WB,WC) DESTROYED ! 1210: EJC ! 1211: * ! 1212: * SYSRI -- READ RECORD FROM INTERACTIVE CHANNEL ! 1213: * ! 1214: SYSRI EXP DEFINE EXTERNAL ENTRY POINT ! 1215: * ! 1216: * READS A RECORD FROM ONLINE TERMINAL FOR SPITBOL VARIABLE, ! 1217: * TERMINAL. IF ONLINE TERMINAL IS UNAVAILABLE THEN CODE THE ! 1218: * ENDFILE RETURN ONLY. ! 1219: * THE BUFFER PROVIDED IS OF LENGTH 120 CHARACTERS. SYSRI ! 1220: * SHOULD REPLACE THE COUNT IN THE SECOND WORD OF THE SCBLK ! 1221: * BY THE ACTUAL CHARACTER COUNT UNLESS BUFFER IS RIGHT ! 1222: * PADDED WITH ZEROES. ! 1223: * IT IS ALSO PERMISSIBLE TO TAKE THE ALTERNATIVE ! 1224: * RETURN AFTER ADJUSTING THE COUNT. ! 1225: * THE END OF FILE RETURN MAY BE USED IF THIS MAKES ! 1226: * SENSE ON THE TARGET MACHINE (E.G. IF THERE IS AN ! 1227: * EOF CHARACTER.) ! 1228: * ! 1229: * (XR) PTR TO 120 CHAR BUFFER (SCBLK PTR) ! 1230: * JSR SYSRI CALL TO READ LINE FROM TERMINAL ! 1231: * PPM LOC END OF FILE RETURN ! 1232: * (WA,WB,WC) MAY BE DESTROYED ! 1233: EJC ! 1234: * ! 1235: * SYSRW -- REWIND FILE ! 1236: * ! 1237: SYSRW EXP DEFINE EXTERNAL ENTRY POINT ! 1238: * ! 1239: * SYSRW IS USED TO REWIND A FILE I.E. REPOSITION THE FILE ! 1240: * AT THE START BEFORE THE FIRST RECORD. THE FILE SHOULD BE ! 1241: * CLOSED AND THE NEXT READ OR WRITE CALL WILL OPEN THE ! 1242: * FILE AT THE START. ! 1243: * ! 1244: * (WA) PTR TO FCBLK OR ZERO ! 1245: * (XR) REWIND ARG (SCBLK PTR) ! 1246: * JSR SYSRW CALL TO REWIND FILE ! 1247: * PPM LOC RETURN HERE IF FILE DOES NOT EXIST ! 1248: * PPM LOC RETURN HERE IF REWIND NOT ALLOWED ! 1249: * PPM LOC RETURN HERE IF I/O ERROR ! 1250: EJC ! 1251: .IF .CUST ! 1252: * ! 1253: * SYSST -- SET FILE POINTER ! 1254: * ! 1255: SYSST EXP DEFINE EXTERNAL ENTRY POINT ! 1256: * ! 1257: * SYSST IS CALLED TO CHANGE THE POSITION OF A FILE ! 1258: * POINTER. THIS IS ACCOMPLISHED IN A SYSTEM DEPENDENT ! 1259: * MANNER, AND THUS THE 2ND AND 3RD ARGUMENTS ARE PASSED ! 1260: * UNCONVERTED. ! 1261: * ! 1262: * (WA) FCBLK POINTER ! 1263: * (WB) 2ND ARGUMENT ! 1264: * (WC) 3RD ARGUMENT ! 1265: * JSR SYSST CALL TO SET FILE POINTER ! 1266: * PPM LOC RETURN HERE IF INVALID 2ND ARG ! 1267: * PPM LOC RETURN HERE IF INVALID 3RD ARG ! 1268: * PPM LOC RETURN HERE IF FILE DOES NOT EXIST ! 1269: * PPM LOC RETURN HERE IF SET NOT ALLOWED ! 1270: * PPM LOC RETURN HERE IF I/O ERROR ! 1271: * ! 1272: EJC ! 1273: .FI ! 1274: * ! 1275: * SYSTM -- GET EXECUTION TIME SO FAR ! 1276: * ! 1277: SYSTM EXP DEFINE EXTERNAL ENTRY POINT ! 1278: * ! 1279: * SYSTM IS USED TO OBTAIN THE AMOUNT OF EXECUTION TIME ! 1280: * USED SO FAR SINCE SPITBOL WAS GIVEN CONTROL. THE UNITS ! 1281: * ARE DESCRIBED AS MILLISECONDS IN THE SPITBOL OUTPUT, BUT ! 1282: * THE EXACT MEANING IS SYSTEM DEPENDENT. WHERE APPROPRIATE, ! 1283: * THIS VALUE SHOULD RELATE TO PROCESSOR RATHER THAN CLOCK ! 1284: * TIMING VALUES. ! 1285: * ! 1286: * JSR SYSTM CALL TO GET TIMER VALUE ! 1287: * (IA) TIME SO FAR IN MILLISECONDS ! 1288: EJC ! 1289: * ! 1290: * SYSTT -- TRACE TOGGLE ! 1291: * ! 1292: SYSTT EXP DEFINE EXTERNAL ENTRY POINT ! 1293: * ! 1294: * CALLED BY SPITBOL FUNCTION TRACE() WITH NO ARGS TO ! 1295: * TOGGLE THE SYSTEM TRACE SWITCH. THIS PERMITS TRACING OF ! 1296: * LABELS IN SPITBOL CODE TO BE TURNED ON OR OFF. ! 1297: * ! 1298: * JSR SYSTT CALL TO TOGGLE TRACE SWITCH ! 1299: EJC ! 1300: * ! 1301: * SYSUL -- UNLOAD EXTERNAL FUNCTION ! 1302: * ! 1303: SYSUL EXP DEFINE EXTERNAL ENTRY POINT ! 1304: * ! 1305: * SYSUL IS USED TO UNLOAD A FUNCTION PREVIOUSLY ! 1306: * LOADED WITH A CALL TO SYSLD. ! 1307: * ! 1308: * (XR) PTR TO CONTROL BLOCK (EFBLK) ! 1309: * JSR SYSUL CALL TO UNLOAD FUNCTION ! 1310: * ! 1311: * THE FUNCTION CANNOT BE CALLED FOLLOWING A SYSUL CALL ! 1312: * UNTIL ANOTHER SYSLD CALL IS MADE FOR THE SAME FUNCTION. ! 1313: * ! 1314: * THE EFBLK CONTAINS THE FUNCTION CODE POINTER AND ALSO A ! 1315: * POINTER TO THE VRBLK CONTAINING THE FUNCTION NAME (SEE ! 1316: * DEFINITIONS AND DATA STRUCTURES SECTION). ! 1317: .IF .CNEX ! 1318: .ELSE ! 1319: EJC ! 1320: * ! 1321: * SYSXI -- EXIT TO PRODUCE LOAD MODULE ! 1322: * ! 1323: SYSXI EXP DEFINE EXTERNAL ENTRY POINT ! 1324: * ! 1325: * WHEN SYSXI IS CALLED, XL CONTAINS EITHER A STRING POINTER ! 1326: * OR ZERO. IN THE FORMER CASE, THE STRING GIVES THE ! 1327: * CHARACTER NAME OF A PROGRAM. THE INTENTION IS THAT ! 1328: * SPITBOL EXECUTION SHOULD BE TERMINATED FORTHWITH AND ! 1329: * THE NAMED PROGRAM LOADED AND EXECUTED. THIS TYPE OF CHAIN ! 1330: * EXECUTION IS VERY SYSTEM DEPENDENT AND IMPLEMENTORS MAY ! 1331: * CHOOSE TO OMIT IT OR FIND IT IMPOSSIBLE TO PROVIDE. ! 1332: * IF (XL) IS ZERO,IA CONTAINS ONE OF THE FOLLOWING INTEGERS ! 1333: * ! 1334: * -1, -2, -3 ! 1335: * CREATE IF POSSIBLE A LOAD MODULE CONTAINING ONLY THE ! 1336: * IMPURE AREA OF MEMORY WHICH NEEDS TO BE LOADED WITH ! 1337: * A COMPATIBLE PURE SEGMENT FOR SUBSEQUENT EXECUTIONS. ! 1338: * VERSION NUMBERS TO CHECK COMPATIBILITY SHOULD BE ! 1339: * KEPT IN BOTH SEGMENTS AND CHECKED ON LOADING. ! 1340: * TO ASSIST WITH THIS CHECK, (XR) ON ENTRY IS A ! 1341: * POINTER TO AN SCBLK CONTAINING THE SPITBOL MAJOR ! 1342: * VERSION NUMBER V.V (SEE SYSID). ! 1343: * ! 1344: * 0 IF POSSIBLE, RETURN CONTROL TO JOB CONTROL ! 1345: * COMMAND LEVEL. THE EFFECT IF AVAILABLE WILL BE ! 1346: * SYSTEM DEPENDENT. ! 1347: * ! 1348: * +1, +2, +3 ! 1349: * CREATE IF POSSIBLE A LOAD MODULE FROM ALL OF ! 1350: * MEMORY. IT SHOULD BE POSSIBLE TO LOAD AND EXECUTE ! 1351: * THIS MODULE DIRECTLY. ! 1352: * ! 1353: * IN THE CASE OF SAVED LOAD MODULES, THE STATUS OF OPEN ! 1354: * FILES IS NOT PRESERVED AND IMPLEMENTORS MAY CHOOSE TO ! 1355: * OFFER MEANS OF ATTACHING FILES BEFORE EXECUTION OF LOAD ! 1356: * MODULES STARTS OR LEAVE IT TO THE USER TO INCLUDE ! 1357: * SUITABLE INPUT(), OUTPUT() CALLS IN HIS PROGRAM. ! 1358: * SYSXI SHOULD MAKE A NOTE THAT NO I/O CHANNELS, ! 1359: * INCLUDING STANDARD FILES, HAVE FILES ATTACHED SO THAT ! 1360: * CALLS OF SYSIN, SYSOU, SYSPR, SYSRD SHOULD FAIL UNLESS ! 1361: * NEW ASSOCIATIONS ARE MADE FOR THE LOAD MODULE. ! 1362: * AT LEAST IN THE CASE OF THE STANDARD OUTPUT FILE, IT IS ! 1363: * RECOMMENDED THAT EITHER THE USER BE REQUIRED TO ATTACH ! 1364: * A FILE OR THAT A DEFAULT FILE IS ATTACHED, SINCE THE ! 1365: * PROBLEM OF ERROR MESSAGES GENERATED BY THE LOAD MODULE ! 1366: * IS OTHERWISE SEVERE. AS A LAST RESORT, IF SPITBOL ! 1367: * ATTEMPTS TO WRITE TO THE STANDARD OUTPUT FILE AND GETS A ! 1368: * REPLY INDICATING THAT SUCH OUPUT IS UNACCEPTABLE IT STOPS ! 1369: * BY USING AN ENTRY TO SYSEJ WITH ENDING CODE 998. ! 1370: * AS DESCRIBED BELOW, PASSING OF SOME ARGUMENTS MAKES IT ! 1371: * CLEAR THAT LOAD MODULE WILL USE A STANDARD OUTPUT FILE. ! 1372: * ! 1373: * IF USE IS MADE OF FCBLKS FOR I/O ASSOCIATION, SPITBOL ! 1374: * BUILDS A CHAIN SO THAT THOSE IN USE MAY BE FOUND IN SYSXI ! 1375: * AND SYSEJ. THE NODES ARE 4 WORDS LONG. THIRD WORD ! 1376: * CONTAINS LINK TO NEXT NODE OR 0, FOURTH WORD CONTAINS ! 1377: * FCBLK POINTER. ! 1378: EJC ! 1379: * ! 1380: * SYSXI (CONTINUED) ! 1381: * ! 1382: * (XL) ZERO OR SCBLK PTR ! 1383: * (XR) PTR TO V.V SCBLK ! 1384: * (IA) SIGNED INTEGER ARGUMENT ! 1385: * (WB) 0 OR PTR TO HEAD OF FCBLK CHAIN ! 1386: * JSR SYSXI CALL TO EXIT ! 1387: * PPM LOC REQUESTED ACTION NOT POSSIBLE ! 1388: * PPM LOC ACTION CAUSED IRRECOVERABLE ERROR ! 1389: * (REGISTERS) SHOULD BE PRESERVED OVER CALL ! 1390: * ! 1391: * LOADING AND RUNNING THE LOAD MODULE OR RETURNING FROM ! 1392: * JCL COMMAND LEVEL CAUSES EXECUTION TO RESUME AT THE POINT ! 1393: * AFTER THE ERROR RETURNS WHICH FOLLOW THE CALL OF SYSXI. ! 1394: * THE VALUE PASSED AS EXIT ARGUMENT IS USED TO INDICATE ! 1395: * OPTIONS REQUIRED ON RESUMPTION OF LOAD MODULE. ! 1396: * +1 OR -1 REQUIRE THAT ON RESUMPTION, SYSID AND SYSPP BE ! 1397: * CALLED AND A HEADING PRINTED ON THE STANDARD OUTPUT FILE. ! 1398: * +2 OR -2 INDICATE THAT SYSPP WILL BE CALLED BUT NOT SYSID ! 1399: * AND NO HEADING WILL BE PUT ON STANDARD OUTPUT FILE. ! 1400: * ABOVE OPTIONS HAVE THE OBVIOUS IMPLICATION THAT A ! 1401: * STANDARD O/P FILE MUST BE PROVIDED FOR THE LOAD MODULE. ! 1402: * +3 OR -3 INDICATE CALLS OF NEITHER SYSID NOR SYSPP ! 1403: * AND NO HEADING WILL BE PLACED ON STANDARD OUTPUT FILE. ! 1404: * NO RETURN FROM SYSXI IS POSSIBLE IF ANOTHER PROGRAM ! 1405: * IS LOADED AND ENTERED. ! 1406: .FI ! 1407: EJC ! 1408: * ! 1409: * INTRODUCE THE INTERNAL PROCEDURES. ! 1410: * ! 1411: ACESS INP R,1 ! 1412: ACOMP INP N,5 ! 1413: ALLOC INP E,0 ! 1414: .IF .CNBF ! 1415: .ELSE ! 1416: ALOBF INP E,0 ! 1417: .FI ! 1418: ALOCS INP E,0 ! 1419: ALOST INP E,0 ! 1420: APNDB INP E,2 ! 1421: .IF .CNRA ! 1422: ARITH INP N,2 ! 1423: .ELSE ! 1424: ARITH INP N,3 ! 1425: .FI ! 1426: ASIGN INP R,1 ! 1427: ASINP INP R,1 ! 1428: BLKLN INP E,0 ! 1429: CDGCG INP E,0 ! 1430: CDGEX INP R,0 ! 1431: CDGNM INP R,0 ! 1432: CDGVL INP R,0 ! 1433: CDWRD INP E,0 ! 1434: CMGEN INP R,0 ! 1435: CMPIL INP E,0 ! 1436: CNCRD INP E,0 ! 1437: COPYB INP N,1 ! 1438: DFFNC INP E,0 ! 1439: DTACH INP E,0 ! 1440: DTYPE INP E,0 ! 1441: DUMPR INP E,0 ! 1442: ERMSG INP E,0 ! 1443: ERTEX INP E,0 ! 1444: EVALI INP R,4 ! 1445: EVALP INP R,1 ! 1446: EVALS INP R,3 ! 1447: EVALX INP R,1 ! 1448: EXBLD INP E,0 ! 1449: EXPAN INP E,0 ! 1450: EXPAP INP E,1 ! 1451: EXPDM INP N,0 ! 1452: EXPOP INP N,0 ! 1453: .IF .CULC ! 1454: FLSTG INP R,0 ! 1455: .FI ! 1456: GBCOL INP E,0 ! 1457: GBCPF INP E,0 ! 1458: GTARR INP E,1 ! 1459: EJC ! 1460: GTCOD INP E,1 ! 1461: GTEXP INP E,1 ! 1462: GTINT INP E,1 ! 1463: GTNUM INP E,1 ! 1464: GTNVR INP E,1 ! 1465: GTPAT INP E,1 ! 1466: .IF .CNRA ! 1467: .ELSE ! 1468: GTREA INP E,1 ! 1469: .FI ! 1470: GTSMI INP N,2 ! 1471: GTSTG INP N,1 ! 1472: GTVAR INP E,1 ! 1473: HASHS INP E,0 ! 1474: ICBLD INP E,0 ! 1475: IDENT INP E,1 ! 1476: INOUT INP E,0 ! 1477: .IF .CNBF ! 1478: .ELSE ! 1479: INSBF INP E,2 ! 1480: .FI ! 1481: IOFCB INP N,2 ! 1482: IOPPF INP N,0 ! 1483: IOPUT INP N,6 ! 1484: KTREX INP R,0 ! 1485: KWNAM INP N,0 ! 1486: LCOMP INP N,5 ! 1487: LISTR INP E,0 ! 1488: LISTT INP E,0 ! 1489: NEXTS INP E,0 ! 1490: PATIN INP N,2 ! 1491: PATST INP N,1 ! 1492: PBILD INP E,0 ! 1493: PCONC INP E,0 ! 1494: PCOPY INP N,0 ! 1495: .IF .CNPF ! 1496: .ELSE ! 1497: PRFLR INP E,0 ! 1498: PRFLU INP E,0 ! 1499: .FI ! 1500: PRPAR INP E,0 ! 1501: PRTCH INP E,0 ! 1502: PRTIC INP E,0 ! 1503: PRTIS INP E,0 ! 1504: PRTIN INP E,0 ! 1505: PRTMI INP E,0 ! 1506: PRTMX INP E,0 ! 1507: PRTNL INP R,0 ! 1508: PRTNM INP R,0 ! 1509: PRTNV INP E,0 ! 1510: PRTPG INP E,0 ! 1511: PRTPS INP E,0 ! 1512: PRTSN INP E,0 ! 1513: PRTST INP R,0 ! 1514: EJC ! 1515: PRTTR INP E,0 ! 1516: PRTVL INP R,0 ! 1517: PRTVN INP E,0 ! 1518: .IF .CNRA ! 1519: .ELSE ! 1520: RCBLD INP E,0 ! 1521: .FI ! 1522: READR INP E,0 ! 1523: SBSTR INP E,0 ! 1524: SCANE INP E,0 ! 1525: SCNGF INP E,0 ! 1526: SETVR INP E,0 ! 1527: .IF .CNSR ! 1528: .ELSE ! 1529: SORTA INP N,0 ! 1530: SORTC INP E,1 ! 1531: SORTF INP E,0 ! 1532: SORTH INP E,0 ! 1533: .FI ! 1534: TFIND INP E,1 ! 1535: TRACE INP N,2 ! 1536: TRBLD INP E,0 ! 1537: TRIMR INP E,0 ! 1538: TRXEQ INP R,0 ! 1539: XSCAN INP E,0 ! 1540: XSCNI INP N,2 ! 1541: * ! 1542: * INTRODUCE THE INTERNAL ROUTINES ! 1543: * ! 1544: ARREF INR ! 1545: CFUNC INR ! 1546: EXFAL INR ! 1547: EXINT INR ! 1548: EXITS INR ! 1549: EXIXR INR ! 1550: EXNAM INR ! 1551: EXNUL INR ! 1552: .IF .CNRA ! 1553: .ELSE ! 1554: EXREA INR ! 1555: .FI ! 1556: EXSID INR ! 1557: EXVNM INR ! 1558: FAILP INR ! 1559: FLPOP INR ! 1560: INDIR INR ! 1561: MATCH INR ! 1562: RETRN INR ! 1563: STCOV INR ! 1564: STMGO INR ! 1565: STOPR INR ! 1566: SUCCP INR ! 1567: SYSAB INR ! 1568: SYSTU INR ! 1569: TTL S P I T B O L -- DEFINITIONS AND DATA STRUCTURES ! 1570: SEC START OF DEFINITIONS SECTION ! 1571: * ! 1572: * DEFINITIONS OF MACHINE PARAMETERS ! 1573: * ! 1574: * THE MINIMAL TRANSLATOR SHOULD SUPPLY APPROPRIATE VALUES ! 1575: * FOR THE PARTICULAR TARGET MACHINE FOR ALL THE ! 1576: * EQU * ! 1577: * DEFINITIONS GIVEN AT THE START OF THIS SECTION. ! 1578: * ! 1579: CFP$A EQU * NUMBER OF CHARACTERS IN ALPHABET ! 1580: * ! 1581: CFP$B EQU * BYTES/WORD ADDRESSING FACTOR ! 1582: * ! 1583: CFP$C EQU * NUMBER OF CHARACTERS PER WORD ! 1584: * ! 1585: CFP$F EQU * OFFSET IN BYTES TO CHARS IN ! 1586: * SCBLK. SEE SCBLK FORMAT. ! 1587: * ! 1588: CFP$I EQU * NUMBER OF WORDS IN INTEGER CONSTANT ! 1589: * ! 1590: CFP$M EQU * MAX POSITIVE INTEGER IN ONE WORD ! 1591: * ! 1592: CFP$N EQU * NUMBER OF BITS IN ONE WORD ! 1593: * ! 1594: * THE FOLLOWING DEFINITIONS REQUIRE THE SUPPLY OF EITHER ! 1595: * A SINGLE PARAMETER IF REAL ARITHMETIC IS OMITTED OR ! 1596: * THREE PARAMETERS IF REAL ARITHMETIC IS INCLUDED. ! 1597: * ! 1598: .IF .CNRA ! 1599: NSTMX EQU * NO. OF DECIMAL DIGITS IN CFP$M ! 1600: .ELSE ! 1601: * ! 1602: CFP$R EQU * NUMBER OF WORDS IN REAL CONSTANT ! 1603: * ! 1604: CFP$S EQU * NUMBER OF SIG DIGS FOR REAL OUTPUT ! 1605: * ! 1606: CFP$X EQU * MAX DIGITS IN REAL EXPONENT ! 1607: * ! 1608: MXDGS EQU CFP$S+CFP$X MAX DIGITS IN REAL NUMBER ! 1609: * ! 1610: NSTMX EQU MXDGS+5 MAX SPACE FOR REAL (FOR +0.E+) ! 1611: .FI ! 1612: .IF .CUCF ! 1613: * ! 1614: * THE FOLLOWING DEFINITION FOR CFP$U SUPPLIES A REALISTIC ! 1615: * UPPER BOUND ON THE SIZE OF THE ALPHABET. CFP$U IS USED ! 1616: * TO SAVE SPACE IN THE SCANE BSW-IFF-ESW TABLE AND TO EASE ! 1617: * TRANSLATION STORAGE REQUIREMENTS. ! 1618: * ! 1619: CFP$U EQU * REALISTIC UPPER BOUND ON ALPHABET ! 1620: .FI ! 1621: EJC ! 1622: * ! 1623: * ENVIRONMENT PARAMETERS ! 1624: * ! 1625: * THE SPITBOL PROGRAM IS ESSENTIALLY INDEPENDENT OF ! 1626: * THE DEFINITIONS OF THESE PARAMETERS. HOWEVER, THE ! 1627: * EFFICIENCY OF THE SYSTEM MAY BE AFFECTED. CONSEQUENTLY, ! 1628: * THESE PARAMETERS MAY REQUIRE TUNING FOR A GIVEN VERSION ! 1629: * THE VALUES GIVEN IN COMMENTS HAVE BEEN SUCCESSFULLY USED. ! 1630: * ! 1631: * E$SRS IS THE NUMBER OF WORDS TO RESERVE AT THE END OF ! 1632: * STORAGE FOR END OF RUN PROCESSING. IT SHOULD BE ! 1633: * SET AS SMALL AS POSSIBLE WITHOUT CAUSING MEMORY OVERFLOW ! 1634: * IN CRITICAL SITUATIONS (E.G. MEMORY OVERFLOW TERMINATION) ! 1635: * AND SHOULD THUS RESERVE SUFFICIENT SPACE AT LEAST FOR ! 1636: * AN SCBLK CONTAINING SAY 30 CHARACTERS. ! 1637: * ! 1638: E$SRS EQU * 30 WORDS ! 1639: * ! 1640: * E$STS IS THE NUMBER OF WORDS GRABBED IN A CHUNK WHEN ! 1641: * STORAGE IS ALLOCATED IN THE STATIC REGION. THE MINIMUM ! 1642: * PERMITTED VALUE IS 256/CFP$B. LARGER VALUES WILL LEAD ! 1643: * TO INCREASED EFFICIENCY AT THE COST OF WASTING MEMORY. ! 1644: * ! 1645: E$STS EQU * 500 WORDS ! 1646: * ! 1647: * E$CBS IS THE SIZE OF CODE BLOCK ALLOCATED INITIALLY AND ! 1648: * THE EXPANSION INCREMENT IF OVERFLOW OCCURS. IF THIS VALUE ! 1649: * IS TOO SMALL OR TOO LARGE, EXCESSIVE GARBAGE COLLECTIONS ! 1650: * WILL OCCUR DURING COMPILATION AND MEMORY MAY BE LOST ! 1651: * IN THE CASE OF A TOO LARGE VALUE. ! 1652: * ! 1653: E$CBS EQU * 500 WORDS ! 1654: * ! 1655: * E$HNB IS THE NUMBER OF BUCKET HEADERS IN THE VARIABLE ! 1656: * HASH TABLE. IT SHOULD ALWAYS BE ODD. LARGER VALUES WILL ! 1657: * SPEED UP COMPILATION AND INDIRECT REFERENCES AT THE ! 1658: * EXPENSE OF ADDITIONAL STORAGE FOR THE HASH TABLE ITSELF. ! 1659: * ! 1660: E$HNB EQU * 127 BUCKET HEADERS ! 1661: * ! 1662: * E$HNW IS THE MAXIMUM NUMBER OF WORDS OF A STRING ! 1663: * NAME WHICH PARTICIPATE IN THE STRING HASH ALGORITHM. ! 1664: * LARGER VALUES GIVE A BETTER HASH AT THE EXPENSE OF TAKING ! 1665: * LONGER TO COMPUTE THE HASH. THERE IS SOME OPTIMAL VALUE. ! 1666: * ! 1667: E$HNW EQU * 6 WORDS ! 1668: * ! 1669: * E$FSP . IF THE AMOUNT OF FREE SPACE LEFT AFTER A GARBAGE ! 1670: * COLLECTION IS SMALL COMPARED TO THE TOTAL AMOUNT OF SPACE ! 1671: * IN USE GARBAGE COLLECTOR THRASHING IS LIKELY TO OCCUR AS ! 1672: * THIS SPACE IS USED UP. E$FSP IS A MEASURE OF THE ! 1673: * MINIMUM PERCENTAGE OF DYNAMIC MEMORY LEFT AS FREE SPACE ! 1674: * BEFORE THE SYSTEM ROUTINE SYSMM IS CALLED TO TRY TO ! 1675: * OBTAIN MORE MEMORY. ! 1676: * ! 1677: E$FSP EQU * 15 PERCENT ! 1678: EJC ! 1679: * ! 1680: * DEFINITIONS OF CODES FOR LETTERS ! 1681: * ! 1682: CH$LA EQU * LETTER A ! 1683: CH$LB EQU * LETTER B ! 1684: CH$LC EQU * LETTER C ! 1685: CH$LD EQU * LETTER D ! 1686: CH$LE EQU * LETTER E ! 1687: CH$LF EQU * LETTER F ! 1688: CH$LG EQU * LETTER G ! 1689: CH$LH EQU * LETTER H ! 1690: CH$LI EQU * LETTER I ! 1691: CH$LJ EQU * LETTER J ! 1692: CH$LK EQU * LETTER K ! 1693: CH$LL EQU * LETTER L ! 1694: CH$LM EQU * LETTER M ! 1695: CH$LN EQU * LETTER N ! 1696: CH$LO EQU * LETTER O ! 1697: CH$LP EQU * LETTER P ! 1698: CH$LQ EQU * LETTER Q ! 1699: CH$LR EQU * LETTER R ! 1700: CH$LS EQU * LETTER S ! 1701: CH$LT EQU * LETTER T ! 1702: CH$LU EQU * LETTER U ! 1703: CH$LV EQU * LETTER V ! 1704: CH$LW EQU * LETTER W ! 1705: CH$LX EQU * LETTER X ! 1706: CH$LY EQU * LETTER Y ! 1707: CH$L$ EQU * LETTER Z ! 1708: * ! 1709: * DEFINITIONS OF CODES FOR DIGITS ! 1710: * ! 1711: CH$D0 EQU * DIGIT 0 ! 1712: CH$D1 EQU * DIGIT 1 ! 1713: CH$D2 EQU * DIGIT 2 ! 1714: CH$D3 EQU * DIGIT 3 ! 1715: CH$D4 EQU * DIGIT 4 ! 1716: CH$D5 EQU * DIGIT 5 ! 1717: CH$D6 EQU * DIGIT 6 ! 1718: CH$D7 EQU * DIGIT 7 ! 1719: CH$D8 EQU * DIGIT 8 ! 1720: CH$D9 EQU * DIGIT 9 ! 1721: EJC ! 1722: * ! 1723: * DEFINITIONS OF CODES FOR SPECIAL CHARACTERS ! 1724: * ! 1725: * THE NAMES OF THESE CHARACTERS ARE RELATED TO THEIR ! 1726: * ORIGINAL REPRESENTATION IN THE EBCDIC SET CORRESPONDING ! 1727: * TO THE DESCRIPTION IN STANDARD SNOBOL4 MANUALS AND TEXTS. ! 1728: * ! 1729: CH$AM EQU * KEYWORD OPERATOR (AMPERSAND) ! 1730: CH$AS EQU * MULTIPLICATION SYMBOL (ASTERISK) ! 1731: CH$AT EQU * CURSOR POSITION OPERATOR (AT) ! 1732: CH$BB EQU * LEFT ARRAY BRACKET (LESS THAN) ! 1733: CH$BL EQU * BLANK ! 1734: CH$BR EQU * ALTERNATION OPERATOR (VERTICAL BAR) ! 1735: CH$CL EQU * GOTO SYMBOL (COLON) ! 1736: CH$CM EQU * COMMA ! 1737: CH$DL EQU * INDIRECTION OPERATOR (DOLLAR) ! 1738: CH$DT EQU * NAME OPERATOR (DOT) ! 1739: CH$DQ EQU * DOUBLE QUOTE ! 1740: CH$EQ EQU * EQUAL SIGN ! 1741: CH$EX EQU * EXPONENTIATION OPERATOR (EXCLM) ! 1742: CH$MN EQU * MINUS SIGN ! 1743: CH$NM EQU * NUMBER SIGN ! 1744: CH$NT EQU * NEGATION OPERATOR (NOT) ! 1745: CH$PC EQU * PERCENT ! 1746: CH$PL EQU * PLUS SIGN ! 1747: CH$PP EQU * LEFT PARENTHESIS ! 1748: CH$RB EQU * RIGHT ARRAY BRACKET (GRTR THAN) ! 1749: CH$RP EQU * RIGHT PARENTHESIS ! 1750: CH$QU EQU * INTERROGATION OPERATOR (QUESTION) ! 1751: CH$SL EQU * SLASH ! 1752: CH$SM EQU * SEMICOLON ! 1753: CH$SQ EQU * SINGLE QUOTE ! 1754: CH$UN EQU * SPECIAL IDENTIFIER CHAR (UNDERLINE) ! 1755: CH$OB EQU * OPENING BRACKET ! 1756: CH$CB EQU * CLOSING BRACKET ! 1757: EJC ! 1758: * ! 1759: * REMAINING CHARS ARE OPTIONAL ADDITIONS TO THE STANDARDS. ! 1760: .IF .CAHT ! 1761: * ! 1762: * TAB CHARACTERS - SYNTACTICALLY EQUIVALENT TO BLANK ! 1763: * ! 1764: CH$HT EQU * HORIZONTAL TAB ! 1765: .FI ! 1766: .IF .CAVT ! 1767: CH$VT EQU * VERTICAL TAB ! 1768: .FI ! 1769: .IF .CASL ! 1770: * ! 1771: * LOWER CASE OR SHIFTED CASE ALPHABETIC CHARS ! 1772: * ! 1773: CH$$A EQU * SHIFTED A ! 1774: CH$$B EQU * SHIFTED B ! 1775: CH$$C EQU * SHIFTED C ! 1776: CH$$D EQU * SHIFTED D ! 1777: CH$$E EQU * SHIFTED E ! 1778: CH$$F EQU * SHIFTED F ! 1779: CH$$G EQU * SHIFTED G ! 1780: CH$$H EQU * SHIFTED H ! 1781: CH$$I EQU * SHIFTED I ! 1782: CH$$J EQU * SHIFTED J ! 1783: CH$$K EQU * SHIFTED K ! 1784: CH$$L EQU * SHIFTED L ! 1785: CH$$M EQU * SHIFTED M ! 1786: CH$$N EQU * SHIFTED N ! 1787: CH$$O EQU * SHIFTED O ! 1788: CH$$P EQU * SHIFTED P ! 1789: CH$$Q EQU * SHIFTED Q ! 1790: CH$$R EQU * SHIFTED R ! 1791: CH$$S EQU * SHIFTED S ! 1792: CH$$T EQU * SHIFTED T ! 1793: CH$$U EQU * SHIFTED U ! 1794: CH$$V EQU * SHIFTED V ! 1795: CH$$W EQU * SHIFTED W ! 1796: CH$$X EQU * SHIFTED X ! 1797: CH$$Y EQU * SHIFTED Y ! 1798: CH$$$ EQU * SHIFTED Z ! 1799: .FI ! 1800: * IF A DELIMITER OTHER THAN CH$CM MUST BE USED IN ! 1801: * THE THIRD ARGUMENT OF INPUT(),OUTPUT() THEN .CIOD SHOULD ! 1802: * BE DEFINED AND A PARAMETER SUPPLIED FOR IODEL. ! 1803: * ! 1804: .IF .CIOD ! 1805: IODEL EQU * ! 1806: .ELSE ! 1807: IODEL EQU CH$CM ! 1808: .FI ! 1809: EJC ! 1810: * ! 1811: * DATA BLOCK FORMATS AND DEFINITIONS ! 1812: * ! 1813: * THE FOLLOWING SECTIONS DESCRIBE THE DETAILED FORMAT OF ! 1814: * ALL POSSIBLE DATA BLOCKS IN STATIC AND DYNAMIC MEMORY. ! 1815: * ! 1816: * EVERY BLOCK HAS A NAME OF THE FORM XXBLK WHERE XX IS A ! 1817: * UNIQUE TWO CHARACTER IDENTIFIER. THE FIRST WORD OF EVERY ! 1818: * BLOCK MUST CONTAIN A POINTER TO A PROGRAM LOCATION IN THE ! 1819: * INTERPRETOR WHICH IS IMMEDIATELY PRECEDED BY AN ADDRESS ! 1820: * CONSTANT CONTAINING THE VALUE BL$XX WHERE XX IS THE BLOCK ! 1821: * IDENTIFIER. THIS PROVIDES A UNIFORM MECHANISM FOR ! 1822: * DISTINGUISHING BETWEEN THE VARIOUS BLOCK TYPES. ! 1823: * ! 1824: * IN SOME CASES, THE CONTENTS OF THE FIRST WORD IS CONSTANT ! 1825: * FOR A GIVEN BLOCK TYPE AND MERELY SERVES AS A POINTER ! 1826: * TO THE IDENTIFYING ADDRESS CONSTANT. HOWEVER, IN OTHER ! 1827: * CASES THERE ARE SEVERAL POSSIBILITIES FOR THE FIRST ! 1828: * WORD IN WHICH CASE EACH OF THE SEVERAL PROGRAM ENTRY ! 1829: * POINTS MUST BE PRECEDED BY THE APPROPRIATE CONSTANT. ! 1830: * ! 1831: * IN EACH BLOCK, SOME OF THE FIELDS ARE RELOCATABLE. THIS ! 1832: * MEANS THAT THEY MAY CONTAIN A POINTER TO ANOTHER BLOCK ! 1833: * IN THE DYNAMIC AREA. (TO BE MORE PRECISE, IF THEY CONTAIN ! 1834: * A POINTER WITHIN THE DYNAMIC AREA, THEN IT IS A POINTER ! 1835: * TO A BLOCK). SUCH FIELDS MUST BE MODIFIED BY THE GARBAGE ! 1836: * COLLECTOR (PROCEDURE GBCOL) WHENEVER BLOCKS ARE COMPACTED ! 1837: * IN THE DYNAMIC REGION. THE GARBAGE COLLECTOR (ACTUALLY ! 1838: * PROCEDURE GBCPF) REQUIRES THAT ALL SUCH RELOCATABLE ! 1839: * FIELDS IN A BLOCK MUST BE CONTIGUOUS. ! 1840: EJC ! 1841: * ! 1842: * THE DESCRIPTION FORMAT USES THE FOLLOWING SCHEME. ! 1843: * ! 1844: * 1) BLOCK TITLE AND TWO CHARACTER IDENTIFIER ! 1845: * ! 1846: * 2) DESCRIPTION OF BASIC USE OF BLOCK AND INDICATION ! 1847: * OF CIRCUMSTANCES UNDER WHICH IT IS CONSTRUCTED. ! 1848: * ! 1849: * 3) PICTURE OF THE BLOCK FORMAT. IN THESE PICTURES LOW ! 1850: * MEMORY ADDRESSES ARE AT THE TOP OF THE PAGE. FIXED ! 1851: * LENGTH FIELDS ARE SURROUNDED BY I (LETTER I). FIELDS ! 1852: * WHICH ARE FIXED LENGTH BUT WHOSE LENGTH IS DEPENDENT ! 1853: * ON A CONFIGURATION PARAMETER ARE SURROUNDED BY * ! 1854: * (ASTERISK). VARIABLE LENGTH FIELDS ARE SURROUNDED ! 1855: * BY / (SLASH). ! 1856: * ! 1857: * 4) DEFINITION OF SYMBOLIC OFFSETS TO FIELDS IN ! 1858: * BLOCK AND OF THE SIZE OF THE BLOCK IF FIXED LENGTH ! 1859: * OR OF THE SIZE OF THE FIXED LENGTH FIELDS IF THE ! 1860: * BLOCK IS VARIABLE LENGTH. ! 1861: * NOTE THAT SOME ROUTINES SUCH AS GBCPF ASSUME ! 1862: * CERTAIN OFFSETS ARE EQUAL. THE DEFINITIONS ! 1863: * GIVEN HERE ENFORCE THIS. MAKE CHANGES TO ! 1864: * THEM ONLY WITH DUE CARE. ! 1865: * ! 1866: * DEFINITIONS OF COMMON OFFSETS ! 1867: * ! 1868: OFFS1 EQU 1 ! 1869: OFFS2 EQU 2 ! 1870: OFFS3 EQU 3 ! 1871: * ! 1872: * 5) DETAILED COMMENTS ON THE SIGNIFICANCE AND FORMATS ! 1873: * OF THE VARIOUS FIELDS. ! 1874: * ! 1875: * THE ORDER IS ALPHABETICAL BY IDENTIFICATION CODE. ! 1876: EJC ! 1877: * ! 1878: * DEFINITIONS OF BLOCK CODES ! 1879: * ! 1880: * THIS TABLE PROVIDES A UNIQUE IDENTIFICATION CODE FOR ! 1881: * EACH SEPARATE BLOCK TYPE. THE FIRST WORD OF A BLOCK IN ! 1882: * THE DYNAMIC AREA ALWAYS CONTAINS THE ADDRESS OF A PROGRAM ! 1883: * ENTRY POINT. THE BLOCK CODE IS USED AS THE ENTRY POINT ID ! 1884: * THE ORDER OF THESE CODES DICTATES THE ORDER OF THE TABLE ! 1885: * USED BY THE DATATYPE FUNCTION (SCNMT IN THE CONSTANT SEC) ! 1886: * ! 1887: * BLOCK CODES FOR ACCESSIBLE DATATYPES ! 1888: * ! 1889: BL$AR EQU 0 ARBLK ARRAY ! 1890: .IF .CNBF ! 1891: BL$CD EQU BL$AR+1 CDBLK CODE ! 1892: .ELSE ! 1893: BL$BC EQU BL$AR+1 BCBLK BUFFER ! 1894: BL$CD EQU BL$BC+1 CDBLK CODE ! 1895: .FI ! 1896: BL$EX EQU BL$CD+1 EXBLK EXPRESSION ! 1897: BL$IC EQU BL$EX+1 ICBLK INTEGER ! 1898: BL$NM EQU BL$IC+1 NMBLK NAME ! 1899: BL$P0 EQU BL$NM+1 P0BLK PATTERN ! 1900: BL$P1 EQU BL$P0+1 P1BLK PATTERN ! 1901: BL$P2 EQU BL$P1+1 P2BLK PATTERN ! 1902: .IF .CNRA ! 1903: BL$SC EQU BL$P2+1 SCBLK STRING ! 1904: .ELSE ! 1905: BL$RC EQU BL$P2+1 RCBLK REAL ! 1906: BL$SC EQU BL$RC+1 SCBLK STRING ! 1907: .FI ! 1908: BL$SE EQU BL$SC+1 SEBLK EXPRESSION ! 1909: BL$TB EQU BL$SE+1 TBBLK TABLE ! 1910: BL$VC EQU BL$TB+1 VCBLK ARRAY ! 1911: BL$XN EQU BL$VC+1 XNBLK EXTERNAL ! 1912: BL$XR EQU BL$XN+1 XRBLK EXTERNAL ! 1913: BL$PD EQU BL$XR+1 PDBLK PROGRAM DEFINED DATATYPE ! 1914: * ! 1915: BL$$D EQU BL$PD+1 NUMBER OF BLOCK CODES FOR DATA ! 1916: * ! 1917: * OTHER BLOCK CODES ! 1918: * ! 1919: BL$TR EQU BL$PD+1 TRBLK ! 1920: .IF .CNBF ! 1921: BL$CC EQU BL$TR+1 CCBLK ! 1922: .ELSE ! 1923: BL$BF EQU BL$TR+1 BFBLK ! 1924: BL$CC EQU BL$BF+1 CCBLK ! 1925: .FI ! 1926: BL$CM EQU BL$CC+1 CMBLK ! 1927: BL$CT EQU BL$CM+1 CTBLK ! 1928: BL$DF EQU BL$CT+1 DFBLK ! 1929: BL$EF EQU BL$DF+1 EFBLK ! 1930: BL$EV EQU BL$EF+1 EVBLK ! 1931: BL$FF EQU BL$EV+1 FFBLK ! 1932: BL$KV EQU BL$FF+1 KVBLK ! 1933: BL$PF EQU BL$KV+1 PFBLK ! 1934: BL$TE EQU BL$PF+1 TEBLK ! 1935: * ! 1936: BL$$I EQU 0 DEFAULT IDENTIFICATION CODE ! 1937: BL$$T EQU BL$TR+1 CODE FOR DATA OR TRACE BLOCK ! 1938: BL$$$ EQU BL$TE+1 NUMBER OF BLOCK CODES ! 1939: EJC ! 1940: * ! 1941: * FIELD REFERENCES ! 1942: * ! 1943: * REFERENCES TO THE FIELDS OF DATA BLOCKS ARE SYMBOLIC ! 1944: * (I.E. USE THE SYMBOLIC OFFSETS) WITH THE FOLLOWING ! 1945: * EXCEPTIONS. ! 1946: * ! 1947: * 1) REFERENCES TO THE FIRST WORD ARE USUALLY NOT ! 1948: * SYMBOLIC SINCE THEY USE THE (X) OPERAND FORMAT. ! 1949: * ! 1950: * 2) THE CODE WHICH CONSTRUCTS A BLOCK IS OFTEN NOT ! 1951: * SYMBOLIC AND SHOULD BE CHANGED IF THE CORRESPONDING ! 1952: * BLOCK FORMAT IS MODIFIED. ! 1953: * ! 1954: * 3) THE PLC AND PSC INSTRUCTIONS IMPLY AN OFFSET ! 1955: * CORRESPONDING TO THE DEFINITION OF CFP$F. ! 1956: * ! 1957: * 4) THERE ARE NON-SYMBOLIC REFERENCES (EASILY CHANGED) ! 1958: * IN THE GARBAGE COLLECTOR (PROCEDURES GBCPF, BLKLN). ! 1959: * ! 1960: * 5) THE FIELDS IDVAL, FARGS APPEAR IN SEVERAL BLOCKS ! 1961: * AND ANY CHANGES MUST BE MADE IN PARALLEL TO ALL ! 1962: * BLOCKS CONTAINING THE FIELDS. THE ACTUAL REFERENCES ! 1963: * TO THESE FIELDS ARE SYMBOLIC WITH THE ABOVE ! 1964: * LISTED EXCEPTIONS. ! 1965: * ! 1966: * 6) SEVERAL SPOTS IN THE CODE ASSUME THAT THE ! 1967: * DEFINITIONS OF THE FIELDS VRVAL, TEVAL, TRNXT ARE ! 1968: * THE SAME (THESE ARE SECTIONS OF CODE WHICH SEARCH ! 1969: * OUT ALONG A TRBLK CHAIN FROM A VARIABLE). ! 1970: * ! 1971: * 7) REFERENCES TO THE FIELDS OF AN ARRAY BLOCK IN THE ! 1972: * ARRAY REFERENCE ROUTINE ARREF ARE NON-SYMBOLIC. ! 1973: * ! 1974: * APART FROM THE EXCEPTIONS LISTED, REFERENCES ARE SYMBOLIC ! 1975: * AS FAR AS POSSIBLE AND MODIFYING THE ORDER OR NUMBER ! 1976: * OF FIELDS WILL NOT REQUIRE CHANGES. ! 1977: EJC ! 1978: * ! 1979: * COMMON FIELDS FOR FUNCTION BLOCKS ! 1980: * ! 1981: * BLOCKS WHICH REPRESENT CALLABLE FUNCTIONS HAVE TWO ! 1982: * COMMON FIELDS AT THE START OF THE BLOCK AS FOLLOWS. ! 1983: * ! 1984: * +------------------------------------+ ! 1985: * I FCODE I ! 1986: * +------------------------------------+ ! 1987: * I FARGS I ! 1988: * +------------------------------------+ ! 1989: * / / ! 1990: * / REST OF FUNCTION BLOCK / ! 1991: * / / ! 1992: * +------------------------------------+ ! 1993: * ! 1994: FCODE EQU 0 POINTER TO CODE FOR FUNCTION ! 1995: FARGS EQU 1 NUMBER OF ARGUMENTS ! 1996: * ! 1997: * FCODE IS A POINTER TO THE LOCATION IN THE INTERPRETOR ! 1998: * PROGRAM WHICH PROCESSES THIS TYPE OF FUNCTION CALL. ! 1999: * ! 2000: * FARGS IS THE EXPECTED NUMBER OF ARGUMENTS. THE ACTUAL ! 2001: * NUMBER OF ARGUMENTS IS ADJUSTED TO THIS AMOUNT BY ! 2002: * DELETING EXTRA ARGUMENTS OR SUPPLYING TRAILING NULLS ! 2003: * FOR MISSING ONES BEFORE TRANSFERRING THOUGH FCODE. ! 2004: * A VALUE OF 999 MAY BE USED IN THIS FIELD TO INDICATE A ! 2005: * VARIABLE NUMBER OF ARGUMENTS (SEE SVBLK FIELD SVNAR). ! 2006: * ! 2007: * THE BLOCK TYPES WHICH FOLLOW THIS SCHEME ARE. ! 2008: * ! 2009: * FFBLK FIELD FUNCTION ! 2010: * DFBLK DATATYPE FUNCTION ! 2011: * PFBLK PROGRAM DEFINED FUNCTION ! 2012: * EFBLK EXTERNAL LOADED FUNCTION ! 2013: EJC ! 2014: * ! 2015: * IDENTIFICATION FIELD ! 2016: * ! 2017: * ! 2018: * ID FIELD ! 2019: * ! 2020: * CERTAIN PROGRAM ACCESSIBLE OBJECTS (THOSE WHICH CONTAIN ! 2021: * OTHER DATA VALUES AND CAN BE COPIED) ARE GIVEN A UNIQUE ! 2022: * IDENTIFICATION NUMBER (SEE EXSID). THIS ID VALUE IS AN ! 2023: * ADDRESS INTEGER VALUE WHICH IS ALWAYS STORED IN WORD TWO. ! 2024: * ! 2025: IDVAL EQU 1 ID VALUE FIELD ! 2026: * ! 2027: * THE BLOCKS CONTAINING AN IDVAL FIELD ARE. ! 2028: * ! 2029: * ARBLK ARRAY ! 2030: .IF .CNBF ! 2031: .ELSE ! 2032: * BCBLK BUFFER CONTROL BLOCK ! 2033: .FI ! 2034: * PDBLK PROGRAM DEFINED DATATYPE ! 2035: * TBBLK TABLE ! 2036: * VCBLK VECTOR BLOCK (ARRAY) ! 2037: * ! 2038: * NOTE THAT A ZERO IDVAL MEANS THAT THE BLOCK IS ONLY ! 2039: * HALF BUILT AND SHOULD NOT BE DUMPED (SEE DUMPR). ! 2040: EJC ! 2041: * ! 2042: * ARRAY BLOCK (ARBLK) ! 2043: * ! 2044: * AN ARRAY BLOCK REPRESENTS AN ARRAY VALUE OTHER THAN ONE ! 2045: * WITH ONE DIMENSION WHOSE LOWER BOUND IS ONE (SEE VCBLK). ! 2046: * AN ARBLK IS BUILT WITH A CALL TO THE FUNCTIONS CONVERT ! 2047: * (S$CNV) OR ARRAY (S$ARR). ! 2048: * ! 2049: * +------------------------------------+ ! 2050: * I ARTYP I ! 2051: * +------------------------------------+ ! 2052: * I IDVAL I ! 2053: * +------------------------------------+ ! 2054: * I ARLEN I ! 2055: * +------------------------------------+ ! 2056: * I AROFS I ! 2057: * +------------------------------------+ ! 2058: * I ARNDM I ! 2059: * +------------------------------------+ ! 2060: * * ARLBD * ! 2061: * +------------------------------------+ ! 2062: * * ARDIM * ! 2063: * +------------------------------------+ ! 2064: * * * ! 2065: * * ABOVE 2 FLDS REPEATED FOR EACH DIM * ! 2066: * * * ! 2067: * +------------------------------------+ ! 2068: * I ARPRO I ! 2069: * +------------------------------------+ ! 2070: * / / ! 2071: * / ARVLS / ! 2072: * / / ! 2073: * +------------------------------------+ ! 2074: EJC ! 2075: * ! 2076: * ARRAY BLOCK (CONTINUED) ! 2077: * ! 2078: ARTYP EQU 0 POINTER TO DUMMY ROUTINE B$ART ! 2079: ARLEN EQU IDVAL+1 LENGTH OF ARBLK IN BYTES ! 2080: AROFS EQU ARLEN+1 OFFSET IN ARBLK TO ARPRO FIELD ! 2081: ARNDM EQU AROFS+1 NUMBER OF DIMENSIONS ! 2082: ARLBD EQU ARNDM+1 LOW BOUND (FIRST SUBSCRIPT) ! 2083: ARDIM EQU ARLBD+CFP$I DIMENSION (FIRST SUBSCRIPT) ! 2084: ARLB2 EQU ARDIM+CFP$I LOW BOUND (SECOND SUBSCRIPT) ! 2085: ARDM2 EQU ARLB2+CFP$I DIMENSION (SECOND SUBSCRIPT) ! 2086: ARPRO EQU ARDIM+CFP$I ARRAY PROTOTYPE (ONE DIMENSION) ! 2087: ARVLS EQU ARPRO+1 START OF VALUES (ONE DIMENSION) ! 2088: ARPR2 EQU ARDM2+CFP$I ARRAY PROTOTYPE (TWO DIMENSIONS) ! 2089: ARVL2 EQU ARPR2+1 START OF VALUES (TWO DIMENSIONS) ! 2090: ARSI$ EQU ARLBD NUMBER OF STANDARD FIELDS IN BLOCK ! 2091: ARDMS EQU ARLB2-ARLBD SIZE OF INFO FOR ONE SET OF BOUNDS ! 2092: * ! 2093: * THE BOUNDS AND DIMENSION FIELDS ARE SIGNED INTEGER ! 2094: * VALUES AND EACH OCCUPY CFP$I WORDS IN THE ARBLK. ! 2095: * ! 2096: * THE LENGTH OF AN ARBLK IN BYTES MAY NOT EXCEED MXLEN. ! 2097: * THIS IS REQUIRED TO KEEP NAME OFFSETS GARBAGE COLLECTABLE ! 2098: * ! 2099: * THE ACTUAL VALUES ARE ARRANGED IN ROW-WISE ORDER AND ! 2100: * CAN CONTAIN A DATA POINTER OR A POINTER TO A TRBLK. ! 2101: .IF .CNBF ! 2102: .ELSE ! 2103: * ! 2104: * BUFFER CONTROL BLOCK (BCBLK) ! 2105: * ! 2106: * A BCBLK IS BUILT FOR EVERY BFBLK. ! 2107: * ! 2108: * +------------------------------------+ ! 2109: * I BCTYP I ! 2110: * +------------------------------------+ ! 2111: * I IDVAL I ! 2112: * +------------------------------------+ ! 2113: * I BCLEN I ! 2114: * +------------------------------------+ ! 2115: * I BCBUF I ! 2116: * +------------------------------------+ ! 2117: * ! 2118: BCTYP EQU 0 PTR TO DUMMY ROUTINE B$BCT ! 2119: BCLEN EQU IDVAL+1 DEFINED BUFFER LENGTH ! 2120: BCBUF EQU BCLEN+1 PTR TO BFBLK ! 2121: BCSI$ EQU BCBUF+1 SIZE OF BCBLK ! 2122: * ! 2123: * A BCBLK IS AN INDIRECT CONTROL HEADER FOR BFBLK. ! 2124: * THE REASON FOR NOT STORING THIS DATA DIRECTLY ! 2125: * IN THE RELATED BFBLK IS SO THAT THE BFBLK CAN ! 2126: * MAINTAIN THE SAME SKELETAL STRUCTURE AS AN SCBLK ! 2127: * THUS FACILITATING TRANSPARENT STRING OPERATIONS ! 2128: * (FOR THE MOST PART). SPECIFICALLY, CFP$F IS THE ! 2129: * SAME FOR A BFBLK AS FOR AN SCBLK. BY CONVENTION, ! 2130: * WHEREEVER A BUFFER VALUE IS EMPLOYED, THE BCBLK ! 2131: * IS POINTED TO. ! 2132: * ! 2133: * THE CORRESPONDING BFBLK IS POINTED TO BY THE ! 2134: * BCBUF POINTER IN THE BCBLK. ! 2135: * ! 2136: * BCLEN IS THE CURRENT DEFINED SIZE OF THE CHARACTER ! 2137: * ARRAY IN THE BFBLK. CHARACTERS FOLLOWING THE OFFSET ! 2138: * OF BCLEN ARE UNDEFINED. ! 2139: * ! 2140: EJC ! 2141: * ! 2142: * STRING BUFFER BLOCK (BFBLK) ! 2143: * ! 2144: * A BFBLK IS BUILT BY A CALL TO BUFFER(...) ! 2145: * ! 2146: * +------------------------------------+ ! 2147: * I BFTYP I ! 2148: * +------------------------------------+ ! 2149: * I BFALC I ! 2150: * +------------------------------------+ ! 2151: * / / ! 2152: * / BFCHR / ! 2153: * / / ! 2154: * +------------------------------------+ ! 2155: * ! 2156: BFTYP EQU 0 PTR TO DUMMY ROUTINE B$BFT ! 2157: BFALC EQU BFTYP+1 ALLOCATED SIZE OF BUFFER ! 2158: BFCHR EQU BFALC+1 CHARACTERS OF STRING ! 2159: BFSI$ EQU BFCHR SIZE OF STANDARD FIELDS IN BFBLK ! 2160: * ! 2161: * THE CHARACTERS IN THE BUFFER ARE STORED LEFT JUSTIFIED. ! 2162: * THE FINAL WORD OF DEFINED CHARACTERS IS ALWAYS ZERO ! 2163: * (CHARACTER) PADDED. ANY TRAILING ALLOCATION PAST THE ! 2164: * WORD CONTAINING THE LAST CHARACTER CONTAINS ! 2165: * UNPREDICTABLE CONTENTS AND IS NEVER REFERENCED. ! 2166: * ! 2167: * NOTE THAT THE OFFSET TO THE CHARACTERS OF THE STRING ! 2168: * IS GIVEN BY CFP$F, AS WITH AN SCBLK. HOWEVER, THE ! 2169: * OFFSET WHICH IS OCCUPIED BY THE LENGTH FOR AN SCBLK ! 2170: * IS THE TOTAL CHAR SPACE FOR BFBLKS, AND ROUTINES WHICH ! 2171: * DEAL WITH BOTH MUST ACCOUNT FOR THIS DIFFERENCE. ! 2172: * ! 2173: * THE VALUE OF BFALC MAY NOT EXCEED MXLEN. THE VALUE OF ! 2174: * BCLEN IS ALWAYS LESS THAN OR EQUAL TO BFALC. ! 2175: * ! 2176: .FI ! 2177: EJC ! 2178: * ! 2179: * CODE CONSTRUCTION BLOCK (CCBLK) ! 2180: * ! 2181: * AT ANY ONE MOMENT THERE IS AT MOST ONE CCBLK INTO ! 2182: * WHICH THE COMPILER IS CURRENTLY STORING CODE (CDWRD). ! 2183: * ! 2184: * +------------------------------------+ ! 2185: * I CCTYP I ! 2186: * +------------------------------------+ ! 2187: * I CCLEN I ! 2188: * +------------------------------------+ ! 2189: * I CCUSE I ! 2190: * +------------------------------------+ ! 2191: * / / ! 2192: * / CCCOD / ! 2193: * / / ! 2194: * +------------------------------------+ ! 2195: * ! 2196: CCTYP EQU 0 POINTER TO DUMMY ROUTINE B$CCT ! 2197: CCLEN EQU CCTYP+1 LENGTH OF CCBLK IN BYTES ! 2198: CCUSE EQU CCLEN+1 OFFSET PAST LAST USED WORD (BYTES) ! 2199: CCCOD EQU CCUSE+1 START OF GENERATED CODE IN BLOCK ! 2200: * ! 2201: * THE REASON THAT THE CCBLK IS A SEPARATE BLOCK TYPE FROM ! 2202: * THE USUAL CDBLK IS THAT THE GARBAGE COLLECTOR MUST ! 2203: * ONLY PROCESS THOSE FIELDS WHICH HAVE BEEN SET (SEE GBCPF) ! 2204: EJC ! 2205: * ! 2206: * CODE BLOCK (CDBLK) ! 2207: * ! 2208: * A CODE BLOCK IS BUILT FOR EACH STATEMENT COMPILED DURING ! 2209: * THE INITIAL COMPILATION OR BY SUBSEQUENT CALLS TO CODE. ! 2210: * ! 2211: * +------------------------------------+ ! 2212: * I CDJMP I ! 2213: * +------------------------------------+ ! 2214: * I CDSTM I ! 2215: * +------------------------------------+ ! 2216: * I CDLEN I ! 2217: * +------------------------------------+ ! 2218: * I CDFAL I ! 2219: * +------------------------------------+ ! 2220: * / / ! 2221: * / CDCOD / ! 2222: * / / ! 2223: * +------------------------------------+ ! 2224: * ! 2225: CDJMP EQU 0 PTR TO ROUTINE TO EXECUTE STATEMENT ! 2226: CDSTM EQU CDJMP+1 STATEMENT NUMBER ! 2227: CDLEN EQU OFFS2 LENGTH OF CDBLK IN BYTES ! 2228: CDFAL EQU OFFS3 FAILURE EXIT (SEE BELOW) ! 2229: CDCOD EQU CDFAL+1 EXECUTABLE PSEUDO-CODE ! 2230: CDSI$ EQU CDCOD NUMBER OF STANDARD FIELDS IN CDBLK ! 2231: * ! 2232: * CDSTM IS THE STATEMENT NUMBER OF THE CURRENT STATEMENT. ! 2233: * ! 2234: * CDJMP, CDFAL ARE SET AS FOLLOWS. ! 2235: * ! 2236: * 1) IF THE FAILURE EXIT IS THE NEXT STATEMENT ! 2237: * ! 2238: * CDJMP = B$CDS ! 2239: * CDFAL = PTR TO CDBLK FOR NEXT STATEMENT ! 2240: * ! 2241: * 2) IF THE FAILURE EXIT IS A SIMPLE LABEL NAME ! 2242: * ! 2243: * CDJMP = B$CDS ! 2244: * CDFAL IS A PTR TO THE VRTRA FIELD OF THE VRBLK ! 2245: * ! 2246: * 3) IF THERE IS NO FAILURE EXIT (-NOFAIL MODE) ! 2247: * ! 2248: * CDJMP = B$CDS ! 2249: * CDFAL = O$UNF ! 2250: * ! 2251: * 4) IF THE FAILURE EXIT IS COMPLEX OR DIRECT ! 2252: * ! 2253: * CDJMP = B$CDC ! 2254: * CDFAL IS THE OFFSET TO THE O$GOF WORD ! 2255: EJC ! 2256: * ! 2257: * CODE BLOCK (CONTINUED) ! 2258: * ! 2259: * CDCOD IS THE START OF THE ACTUAL CODE. FIRST WE DESCRIBE ! 2260: * THE CODE GENERATED FOR AN EXPRESSION. IN AN EXPRESSION, ! 2261: * ELEMENTS ARE FETCHED BY NAME OR BY VALUE. FOR EXAMPLE, ! 2262: * THE BINARY EQUAL OPERATOR FETCHES ITS LEFT ARGUMENT ! 2263: * BY NAME AND ITS RIGHT ARGUMENT BY VALUE. THESE TWO ! 2264: * CASES GENERATE QUITE DIFFERENT CODE AND ARE DESCRIBED ! 2265: * SEPARATELY. FIRST WE CONSIDER THE CODE BY VALUE CASE. ! 2266: * ! 2267: * GENERATION OF CODE BY VALUE FOR EXPRESSIONS ELEMENTS. ! 2268: * ! 2269: * EXPRESSION POINTER TO EXBLK OR SEBLK ! 2270: * ! 2271: * INTEGER CONSTANT POINTER TO ICBLK ! 2272: * ! 2273: * NULL CONSTANT POINTER TO NULLS ! 2274: * ! 2275: * PATTERN (RESULTING FROM PREEVALUATION) ! 2276: * =O$LPT ! 2277: * POINTER TO P0BLK,P1BLK OR P2BLK ! 2278: * ! 2279: * REAL CONSTANT POINTER TO RCBLK ! 2280: * ! 2281: * STRING CONSTANT POINTER TO SCBLK ! 2282: * ! 2283: * VARIABLE POINTER TO VRGET FIELD OF VRBLK ! 2284: * ! 2285: * ADDITION VALUE CODE FOR LEFT OPERAND ! 2286: * VALUE CODE FOR RIGHT OPERAND ! 2287: * =O$ADD ! 2288: * ! 2289: * AFFIRMATION VALUE CODE FOR OPERAND ! 2290: * =O$AFF ! 2291: * ! 2292: * ALTERNATION VALUE CODE FOR LEFT OPERAND ! 2293: * VALUE CODE FOR RIGHT OPERAND ! 2294: * =O$ALT ! 2295: * ! 2296: * ARRAY REFERENCE (CASE OF ONE SUBSCRIPT) ! 2297: * VALUE CODE FOR ARRAY OPERAND ! 2298: * VALUE CODE FOR SUBSCRIPT OPERAND ! 2299: * =O$AOV ! 2300: * ! 2301: * (CASE OF MORE THAN ONE SUBSCRIPT) ! 2302: * VALUE CODE FOR ARRAY OPERAND ! 2303: * VALUE CODE FOR FIRST SUBSCRIPT ! 2304: * VALUE CODE FOR SECOND SUBSCRIPT ! 2305: * ... ! 2306: * VALUE CODE FOR LAST SUBSCRIPT ! 2307: * =O$AMV ! 2308: * NUMBER OF SUBSCRIPTS ! 2309: EJC ! 2310: * ! 2311: * CODE BLOCK (CONTINUED) ! 2312: * ! 2313: * ASSIGNMENT (TO NATURAL VARIABLE) ! 2314: * VALUE CODE FOR RIGHT OPERAND ! 2315: * POINTER TO VRSTO FIELD OF VRBLK ! 2316: * ! 2317: * (TO ANY OTHER VARIABLE) ! 2318: * NAME CODE FOR LEFT OPERAND ! 2319: * VALUE CODE FOR RIGHT OPERAND ! 2320: * =O$ASS ! 2321: * ! 2322: * COMPILE ERROR =O$CER ! 2323: * ! 2324: * ! 2325: * COMPLEMENTATION VALUE CODE FOR OPERAND ! 2326: * =O$COM ! 2327: * ! 2328: * CONCATENATION (CASE OF PRED FUNC LEFT OPERAND) ! 2329: * VALUE CODE FOR LEFT OPERAND ! 2330: * =O$POP ! 2331: * VALUE CODE FOR RIGHT OPERAND ! 2332: * ! 2333: * (ALL OTHER CASES) ! 2334: * VALUE CODE FOR LEFT OPERAND ! 2335: * VALUE CODE FOR RIGHT OPERAND ! 2336: * =O$CNC ! 2337: * ! 2338: * CURSOR ASSIGNMENT NAME CODE FOR OPERAND ! 2339: * =O$CAS ! 2340: * ! 2341: * DIVISION VALUE CODE FOR LEFT OPERAND ! 2342: * VALUE CODE FOR RIGHT OPERAND ! 2343: * =O$DVD ! 2344: * ! 2345: * EXPONENTIATION VALUE CODE FOR LEFT OPERAND ! 2346: * VALUE CODE FOR RIGHT OPERAND ! 2347: * =O$EXP ! 2348: * ! 2349: * FUNCTION CALL (CASE OF CALL TO SYSTEM FUNCTION) ! 2350: * VALUE CODE FOR FIRST ARGUMENT ! 2351: * VALUE CODE FOR SECOND ARGUMENT ! 2352: * ... ! 2353: * VALUE CODE FOR LAST ARGUMENT ! 2354: * POINTER TO SVFNC FIELD OF SVBLK ! 2355: * ! 2356: EJC ! 2357: * ! 2358: * CODE BLOCK (CONTINUED) ! 2359: * ! 2360: * FUNCTION CALL (CASE OF NON-SYSTEM FUNCTION 1 ARG) ! 2361: * VALUE CODE FOR ARGUMENT ! 2362: * =O$FNS ! 2363: * POINTER TO VRBLK FOR FUNCTION ! 2364: * ! 2365: * (NON-SYSTEM FUNCTION, GT 1 ARG) ! 2366: * VALUE CODE FOR FIRST ARGUMENT ! 2367: * VALUE CODE FOR SECOND ARGUMENT ! 2368: * ... ! 2369: * VALUE CODE FOR LAST ARGUMENT ! 2370: * =O$FNC ! 2371: * NUMBER OF ARGUMENTS ! 2372: * POINTER TO VRBLK FOR FUNCTION ! 2373: * ! 2374: * IMMEDIATE ASSIGNMENT VALUE CODE FOR LEFT OPERAND ! 2375: * NAME CODE FOR RIGHT OPERAND ! 2376: * =O$IMA ! 2377: * ! 2378: * INDIRECTION VALUE CODE FOR OPERAND ! 2379: * =O$INV ! 2380: * ! 2381: * INTERROGATION VALUE CODE FOR OPERAND ! 2382: * =O$INT ! 2383: * ! 2384: * KEYWORD REFERENCE NAME CODE FOR OPERAND ! 2385: * =O$KWV ! 2386: * ! 2387: * MULTIPLICATION VALUE CODE FOR LEFT OPERAND ! 2388: * VALUE CODE FOR RIGHT OPERAND ! 2389: * =O$MLT ! 2390: * ! 2391: * NAME REFERENCE (NATURAL VARIABLE CASE) ! 2392: * POINTER TO NMBLK FOR NAME ! 2393: * ! 2394: * (ALL OTHER CASES) ! 2395: * NAME CODE FOR OPERAND ! 2396: * =O$NAM ! 2397: * ! 2398: * NEGATION =O$NTA ! 2399: * CDBLK OFFSET OF O$NTC WORD ! 2400: * VALUE CODE FOR OPERAND ! 2401: * =O$NTB ! 2402: * =O$NTC ! 2403: EJC ! 2404: * ! 2405: * CODE BLOCK (CONTINUED) ! 2406: * ! 2407: * PATTERN ASSIGNMENT VALUE CODE FOR LEFT OPERAND ! 2408: * NAME CODE FOR RIGHT OPERAND ! 2409: * =O$PAS ! 2410: * ! 2411: * PATTERN MATCH VALUE CODE FOR LEFT OPERAND ! 2412: * VALUE CODE FOR RIGHT OPERAND ! 2413: * =O$PMV ! 2414: * ! 2415: * PATTERN REPLACEMENT NAME CODE FOR SUBJECT ! 2416: * VALUE CODE FOR PATTERN ! 2417: * =O$PMN ! 2418: * VALUE CODE FOR REPLACEMENT ! 2419: * =O$RPL ! 2420: * ! 2421: * SELECTION (FOR FIRST ALTERNATIVE) ! 2422: * =O$SLA ! 2423: * CDBLK OFFSET TO NEXT O$SLC WORD ! 2424: * VALUE CODE FOR FIRST ALTERNATIVE ! 2425: * =O$SLB ! 2426: * CDBLK OFFSET PAST ALTERNATIVES ! 2427: * ! 2428: * (FOR SUBSEQUENT ALTERNATIVES) ! 2429: * =O$SLC ! 2430: * CDBLK OFFSET TO NEXT O$SLC,O$SLD ! 2431: * VALUE CODE FOR ALTERNATIVE ! 2432: * =O$SLB ! 2433: * OFFSET IN CDBLK PAST ALTERNATIVES ! 2434: * ! 2435: * (FOR LAST ALTERNATIVE) ! 2436: * =O$SLD ! 2437: * VALUE CODE FOR LAST ALTERNATIVE ! 2438: * ! 2439: * SUBTRACTION VALUE CODE FOR LEFT OPERAND ! 2440: * VALUE CODE FOR RIGHT OPERAND ! 2441: * =O$SUB ! 2442: EJC ! 2443: * ! 2444: * CODE BLOCK (CONTINUED) ! 2445: * ! 2446: * GENERATION OF CODE BY NAME FOR EXPRESSION ELEMENTS. ! 2447: * ! 2448: * VARIABLE =O$LVN ! 2449: * POINTER TO VRBLK ! 2450: * ! 2451: * EXPRESSION (CASE OF *NATURAL VARIABLE) ! 2452: * =O$LVN ! 2453: * POINTER TO VRBLK ! 2454: * ! 2455: * (ALL OTHER CASES) ! 2456: * =O$LEX ! 2457: * POINTER TO EXBLK ! 2458: * ! 2459: * ! 2460: * ARRAY REFERENCE (CASE OF ONE SUBSCRIPT) ! 2461: * VALUE CODE FOR ARRAY OPERAND ! 2462: * VALUE CODE FOR SUBSCRIPT OPERAND ! 2463: * =O$AON ! 2464: * ! 2465: * (CASE OF MORE THAN ONE SUBSCRIPT) ! 2466: * VALUE CODE FOR ARRAY OPERAND ! 2467: * VALUE CODE FOR FIRST SUBSCRIPT ! 2468: * VALUE CODE FOR SECOND SUBSCRIPT ! 2469: * ... ! 2470: * VALUE CODE FOR LAST SUBSCRIPT ! 2471: * =O$AMN ! 2472: * NUMBER OF SUBSCRIPTS ! 2473: * ! 2474: * COMPILE ERROR =O$CER ! 2475: * ! 2476: * FUNCTION CALL (SAME CODE AS FOR VALUE CALL) ! 2477: * =O$FNE ! 2478: * ! 2479: * INDIRECTION VALUE CODE FOR OPERAND ! 2480: * =O$INN ! 2481: * ! 2482: * KEYWORD REFERENCE NAME CODE FOR OPERAND ! 2483: * =O$KWN ! 2484: * ! 2485: * ANY OTHER OPERAND IS AN ERROR IN A NAME POSITION ! 2486: * ! 2487: * NOTE THAT IN THIS DESCRIPTION, =O$XXX REFERS TO THE ! 2488: * GENERATION OF A WORD CONTAINING THE ADDRESS OF ANOTHER ! 2489: * WORD WHICH CONTAINS THE ENTRY POINT ADDRESS O$XXX. ! 2490: EJC ! 2491: * ! 2492: * CODE BLOCK (CONTINUED) ! 2493: * ! 2494: * NOW WE CONSIDER THE OVERALL STRUCTURE OF THE CODE BLOCK ! 2495: * FOR A STATEMENT WITH POSSIBLE GOTO FIELDS. ! 2496: * ! 2497: * FIRST COMES THE CODE FOR THE STATEMENT BODY. ! 2498: * THE STATEMENT BODY IS AN EXPRESSION TO BE EVALUATED ! 2499: * BY VALUE ALTHOUGH THE VALUE IS NOT ACTUALLY REQUIRED. ! 2500: * NORMAL VALUE CODE IS GENERATED FOR THE BODY OF THE ! 2501: * STATEMENT EXCEPT IN THE CASE OF A PATTERN MATCH BY ! 2502: * VALUE, IN WHICH CASE THE FOLLOWING IS GENERATED. ! 2503: * ! 2504: * VALUE CODE FOR LEFT OPERAND ! 2505: * VALUE CODE FOR RIGHT OPERAND ! 2506: * =O$PMS ! 2507: * ! 2508: * NEXT WE HAVE THE CODE FOR THE SUCCESS GOTO. THERE ARE ! 2509: * SEVERAL CASES AS FOLLOWS. ! 2510: * ! 2511: * 1) NO SUCCESS GOTO PTR TO CDBLK FOR NEXT STATEMENT ! 2512: * ! 2513: * 2) SIMPLE LABEL PTR TO VRTRA FIELD OF VRBLK ! 2514: * ! 2515: * 3) COMPLEX GOTO (CODE BY NAME FOR GOTO OPERAND) ! 2516: * =O$GOC ! 2517: * ! 2518: * 4) DIRECT GOTO (CODE BY VALUE FOR GOTO OPERAND) ! 2519: * =O$GOD ! 2520: * ! 2521: * FOLLOWING THIS WE GENERATE CODE FOR THE FAILURE GOTO IF ! 2522: * IT IS DIRECT OR IF IT IS COMPLEX, SIMPLE FAILURE GOTOS ! 2523: * HAVING BEEN HANDLED BY AN APPROPRIATE SETTING OF THE ! 2524: * CDFAL FIELD OF THE CDBLK. THE GENERATED CODE IS ONE ! 2525: * OF THE FOLLOWING. ! 2526: * ! 2527: * 1) COMPLEX FGOTO =O$FIF ! 2528: * =O$GOF ! 2529: * NAME CODE FOR GOTO OPERAND ! 2530: * =O$GOC ! 2531: * ! 2532: * 2) DIRECT FGOTO =O$FIF ! 2533: * =O$GOF ! 2534: * VALUE CODE FOR GOTO OPERAND ! 2535: * =O$GOD ! 2536: * ! 2537: * AN OPTIMIZATION OCCURS IF THE SUCCESS AND FAILURE GOTOS ! 2538: * ARE IDENTICAL AND EITHER COMPLEX OR DIRECT. IN THIS CASE, ! 2539: * NO CODE IS GENERATED FOR THE SUCCESS GOTO AND CONTROL ! 2540: * IS ALLOWED TO FALL INTO THE FAILURE GOTO ON SUCCESS. ! 2541: EJC ! 2542: * ! 2543: * COMPILER BLOCK (CMBLK) ! 2544: * ! 2545: * A COMPILER BLOCK (CMBLK) IS BUILT BY EXPAN TO REPRESENT ! 2546: * ONE NODE OF A TREE STRUCTURED EXPRESSION REPRESENTATION. ! 2547: * ! 2548: * +------------------------------------+ ! 2549: * I CMIDN I ! 2550: * +------------------------------------+ ! 2551: * I CMLEN I ! 2552: * +------------------------------------+ ! 2553: * I CMTYP I ! 2554: * +------------------------------------+ ! 2555: * I CMOPN I ! 2556: * +------------------------------------+ ! 2557: * / CMVLS OR CMROP / ! 2558: * / / ! 2559: * / CMLOP / ! 2560: * / / ! 2561: * +------------------------------------+ ! 2562: * ! 2563: CMIDN EQU 0 POINTER TO DUMMY ROUTINE B$CMT ! 2564: CMLEN EQU CMIDN+1 LENGTH OF CMBLK IN BYTES ! 2565: CMTYP EQU CMLEN+1 TYPE (C$XXX, SEE LIST BELOW) ! 2566: CMOPN EQU CMTYP+1 OPERAND POINTER (SEE BELOW) ! 2567: CMVLS EQU CMOPN+1 OPERAND VALUE POINTERS (SEE BELOW) ! 2568: CMROP EQU CMVLS RIGHT (ONLY) OPERATOR OPERAND ! 2569: CMLOP EQU CMVLS+1 LEFT OPERATOR OPERAND ! 2570: CMSI$ EQU CMVLS NUMBER OF STANDARD FIELDS IN CMBLK ! 2571: CMUS$ EQU CMSI$+1 SIZE OF UNARY OPERATOR CMBLK ! 2572: CMBS$ EQU CMSI$+2 SIZE OF BINARY OPERATOR CMBLK ! 2573: CMAR1 EQU CMVLS+1 ARRAY SUBSCRIPT POINTERS ! 2574: * ! 2575: * THE CMOPN AND CMVLS FIELDS ARE SET AS FOLLOWS ! 2576: * ! 2577: * ARRAY REFERENCE CMOPN = PTR TO ARRAY OPERAND ! 2578: * CMVLS = PTRS TO SUBSCRIPT OPERANDS ! 2579: * ! 2580: * FUNCTION CALL CMOPN = PTR TO VRBLK FOR FUNCTION ! 2581: * CMVLS = PTRS TO ARGUMENT OPERANDS ! 2582: * ! 2583: * SELECTION CMOPN = ZERO ! 2584: * CMVLS = PTRS TO ALTERNATE OPERANDS ! 2585: * ! 2586: * UNARY OPERATOR CMOPN = PTR TO OPERATOR DVBLK ! 2587: * CMROP = PTR TO OPERAND ! 2588: * ! 2589: * BINARY OPERATOR CMOPN = PTR TO OPERATOR DVBLK ! 2590: * CMROP = PTR TO RIGHT OPERAND ! 2591: * CMLOP = PTR TO LEFT OPERAND ! 2592: EJC ! 2593: * ! 2594: * CMTYP IS SET TO INDICATE THE TYPE OF EXPRESSION ELEMENT ! 2595: * AS SHOWN BY THE FOLLOWING TABLE OF DEFINITIONS. ! 2596: * ! 2597: C$ARR EQU 0 ARRAY REFERENCE ! 2598: C$FNC EQU C$ARR+1 FUNCTION CALL ! 2599: C$DEF EQU C$FNC+1 DEFERRED EXPRESSION (UNARY *) ! 2600: C$IND EQU C$DEF+1 INDIRECTION (UNARY $) ! 2601: C$KEY EQU C$IND+1 KEYWORD REFERENCE (UNARY AMPERSAND) ! 2602: C$UBO EQU C$KEY+1 UNDEFINED BINARY OPERATOR ! 2603: C$UUO EQU C$UBO+1 UNDEFINED UNARY OPERATOR ! 2604: C$UO$ EQU C$UUO+1 TEST VALUE (=C$UUO+1=C$UBO+2) ! 2605: C$$NM EQU C$UUO+1 NUMBER OF CODES FOR NAME OPERANDS ! 2606: * ! 2607: * THE REMAINING TYPES INDICATE EXPRESSION ELEMENTS WHICH ! 2608: * CAN ONLY BE EVALUATED BY VALUE (NOT BY NAME). ! 2609: * ! 2610: C$BVL EQU C$UUO+1 BINARY OP WITH VALUE OPERANDS ! 2611: C$UVL EQU C$BVL+1 UNARY OPERATOR WITH VALUE OPERAND ! 2612: C$ALT EQU C$UVL+1 ALTERNATION (BINARY BAR) ! 2613: C$CNC EQU C$ALT+1 CONCATENATION ! 2614: C$CNP EQU C$CNC+1 CONCATENATION, NOT PATTERN MATCH ! 2615: C$UNM EQU C$CNP+1 UNARY OP WITH NAME OPERAND ! 2616: C$BVN EQU C$UNM+1 BINARY OP (OPERANDS BY VALUE, NAME) ! 2617: C$ASS EQU C$BVN+1 ASSIGNMENT ! 2618: C$INT EQU C$ASS+1 INTERROGATION ! 2619: C$NEG EQU C$INT+1 NEGATION (UNARY NOT) ! 2620: C$SEL EQU C$NEG+1 SELECTION ! 2621: C$PMT EQU C$SEL+1 PATTERN MATCH ! 2622: * ! 2623: C$PR$ EQU C$BVN LAST PREEVALUABLE CODE ! 2624: C$$NV EQU C$PMT+1 NUMBER OF DIFFERENT CMBLK TYPES ! 2625: EJC ! 2626: * ! 2627: * CHARACTER TABLE BLOCK (CTBLK) ! 2628: * ! 2629: * A CHARACTER TABLE BLOCK IS USED TO HOLD LOGICAL CHARACTER ! 2630: * TABLES FOR USE WITH ANY,NOTANY,SPAN,BREAK,BREAKX ! 2631: * PATTERNS. EACH CHARACTER TABLE CAN BE USED TO STORE ! 2632: * CFP$N DISTINCT TABLES AS BIT COLUMNS. A BIT COLUMN ! 2633: * ALLOCATED FOR EACH ARGUMENT OF MORE THAN ONE CHARACTER ! 2634: * IN LENGTH TO ONE OF THE ABOVE LISTED PATTERN PRIMITIVES. ! 2635: * ! 2636: * +------------------------------------+ ! 2637: * I CTTYP I ! 2638: * +------------------------------------+ ! 2639: * * * ! 2640: * * * ! 2641: * * CTCHS * ! 2642: * * * ! 2643: * * * ! 2644: * +------------------------------------+ ! 2645: * ! 2646: CTTYP EQU 0 POINTER TO DUMMY ROUTINE B$CTT ! 2647: CTCHS EQU CTTYP+1 START OF CHARACTER TABLE WORDS ! 2648: CTSI$ EQU CTCHS+CFP$A NUMBER OF WORDS IN CTBLK ! 2649: * ! 2650: * CTCHS IS CFP$A WORDS LONG AND CONSISTS OF A ONE WORD ! 2651: * BIT STRING VALUE FOR EACH POSSIBLE CHARACTER IN THE ! 2652: * INTERNAL ALPHABET. EACH OF THE CFP$N POSSIBLE BITS IN ! 2653: * A BITSTRING IS USED TO FORM A COLUMN OF BIT INDICATORS. ! 2654: * A BIT IS SET ON IF THE CHARACTER IS IN THE TABLE AND OFF ! 2655: * IF THE CHARACTER IS NOT PRESENT. ! 2656: EJC ! 2657: * ! 2658: * DATATYPE FUNCTION BLOCK (DFBLK) ! 2659: * ! 2660: * A DATATYPE FUNCTION IS USED TO CONTROL THE CONSTRUCTION ! 2661: * OF A PROGRAM DEFINED DATATYPE OBJECT. A CALL TO THE ! 2662: * SYSTEM FUNCTION DATA BUILDS A DFBLK FOR THE DATATYPE NAME ! 2663: * ! 2664: * NOTE THAT THESE BLOCKS ARE BUILT IN STATIC BECAUSE PDBLK ! 2665: * LENGTH IS GOT FROM DFLEN FIELD. IF DFBLK WAS IN DYNAMIC ! 2666: * STORE THIS WOULD CAUSE TROUBLE DURING PASS TWO OF GARBAGE ! 2667: * COLLECTION. SCBLK REFERRED TO BY DFNAM FIELD IS ALSO PUT ! 2668: * IN STATIC SO THAT THERE ARE NO RELOC. FIELDS. THIS CUTS ! 2669: * GARBAGE COLLECTION TASK APPRECIABLY FOR PDBLKS WHICH ARE ! 2670: * LIKELY TO BE PRESENT IN LARGE NUMBERS. ! 2671: * ! 2672: * +------------------------------------+ ! 2673: * I FCODE I ! 2674: * +------------------------------------+ ! 2675: * I FARGS I ! 2676: * +------------------------------------+ ! 2677: * I DFLEN I ! 2678: * +------------------------------------+ ! 2679: * I DFPDL I ! 2680: * +------------------------------------+ ! 2681: * I DFNAM I ! 2682: * +------------------------------------+ ! 2683: * / / ! 2684: * / DFFLD / ! 2685: * / / ! 2686: * +------------------------------------+ ! 2687: * ! 2688: DFLEN EQU FARGS+1 LENGTH OF DFBLK IN BYTES ! 2689: DFPDL EQU DFLEN+1 LENGTH OF CORRESPONDING PDBLK ! 2690: DFNAM EQU DFPDL+1 POINTER TO SCBLK FOR DATATYPE NAME ! 2691: DFFLD EQU DFNAM+1 START OF VRBLK PTRS FOR FIELD NAMES ! 2692: DFFLB EQU DFFLD-1 OFFSET BEHIND DFFLD FOR FIELD FUNC ! 2693: DFSI$ EQU DFFLD NUMBER OF STANDARD FIELDS IN DFBLK ! 2694: * ! 2695: * THE FCODE FIELD POINTS TO THE ROUTINE B$DFC ! 2696: * ! 2697: * FARGS (THE NUMBER OF ARGUMENTS) IS THE NUMBER OF FIELDS. ! 2698: EJC ! 2699: * ! 2700: * DOPE VECTOR BLOCK (DVBLK) ! 2701: * ! 2702: * A DOPE VECTOR IS ASSEMBLED FOR EACH POSSIBLE OPERATOR IN ! 2703: * THE SNOBOL4 LANGUAGE AS PART OF THE CONSTANT SECTION. ! 2704: * ! 2705: * +------------------------------------+ ! 2706: * I DVOPN I ! 2707: * +------------------------------------+ ! 2708: * I DVTYP I ! 2709: * +------------------------------------+ ! 2710: * I DVLPR I ! 2711: * +------------------------------------+ ! 2712: * I DVRPR I ! 2713: * +------------------------------------+ ! 2714: * ! 2715: DVOPN EQU 0 ENTRY ADDRESS (PTR TO O$XXX) ! 2716: DVTYP EQU DVOPN+1 TYPE CODE (C$XXX, SEE CMBLK) ! 2717: DVLPR EQU DVTYP+1 LEFT PRECEDENCE (LLXXX, SEE BELOW) ! 2718: DVRPR EQU DVLPR+1 RIGHT PRECEDENCE (RRXXX, SEE BELOW) ! 2719: DVUS$ EQU DVLPR+1 SIZE OF UNARY OPERATOR DV ! 2720: DVBS$ EQU DVRPR+1 SIZE OF BINARY OPERATOR DV ! 2721: DVUBS EQU DVUS$+DVBS$ SIZE OF UNOP + BINOP (SEE SCANE) ! 2722: * ! 2723: * THE CONTENTS OF THE DVTYP FIELD IS COPIED INTO THE CMTYP ! 2724: * FIELD OF THE CMBLK FOR THE OPERATOR IF IT IS USED. ! 2725: * ! 2726: * THE CMOPN FIELD OF AN OPERATOR CMBLK POINTS TO THE DVBLK ! 2727: * ITSELF, PROVIDING THE REQUIRED ENTRY ADDRESS POINTER PTR. ! 2728: * ! 2729: * FOR NORMALLY UNDEFINED OPERATORS, THE DVOPN (AND CMOPN) ! 2730: * FIELDS CONTAIN A WORD OFFSET FROM R$UBA OF THE FUNCTION ! 2731: * BLOCK POINTER FOR THE OPERATOR (INSTEAD OF O$XXX PTR). ! 2732: * FOR CERTAIN SPECIAL OPERATORS, THE DVOPN FIELD IS NOT ! 2733: * REQUIRED AT ALL AND IS ASSEMBLED AS ZERO. ! 2734: * ! 2735: * THE LEFT PRECEDENCE IS USED IN COMPARING AN OPERATOR TO ! 2736: * THE LEFT OF SOME OTHER OPERATOR. IT THEREFORE GOVERNS THE ! 2737: * PRECEDENCE OF THE OPERATOR TOWARDS ITS RIGHT OPERAND. ! 2738: * ! 2739: * THE RIGHT PRECEDENCE IS USED IN COMPARING AN OPERATOR TO ! 2740: * THE RIGHT OF SOME OTHER OPERATOR. IT THEREFORE GOVERNS ! 2741: * THE PRECEDENCE OF THE OPERATOR TOWARDS ITS LEFT OPERAND. ! 2742: * ! 2743: * HIGHER PRECEDENCE VALUES CORRESPOND TO A TIGHTER BINDING ! 2744: * CAPABILITY. THUS WE HAVE THE LEFT PRECEDENCE LOWER ! 2745: * (HIGHER) THAN THE RIGHT PRECEDENCE FOR RIGHT (LEFT) ! 2746: * ASSOCIATIVE BINARY OPERATORS. ! 2747: * ! 2748: * THE LEFT PRECEDENCE OF UNARY OPERATORS IS SET TO AN ! 2749: * ARBITRARY HIGH VALUE. THE RIGHT VALUE IS NOT REQUIRED AND ! 2750: * CONSEQUENTLY THE DVRPR FIELD IS OMITTED FOR UNARY OPS. ! 2751: EJC ! 2752: * ! 2753: * TABLE OF OPERATOR PRECEDENCE VALUES ! 2754: * ! 2755: RRASS EQU 10 RIGHT EQUAL ! 2756: LLASS EQU 00 LEFT EQUAL ! 2757: RRPMT EQU 20 RIGHT QUESTION MARK ! 2758: LLPMT EQU 30 LEFT QUESTION MARK ! 2759: RRAMP EQU 40 RIGHT AMPERSAND ! 2760: LLAMP EQU 50 LEFT AMPERSAND ! 2761: RRALT EQU 70 RIGHT VERTICAL BAR ! 2762: LLALT EQU 60 LEFT VERTICAL BAR ! 2763: RRCNC EQU 90 RIGHT BLANK ! 2764: LLCNC EQU 80 LEFT BLANK ! 2765: RRATS EQU 110 RIGHT AT ! 2766: LLATS EQU 100 LEFT AT ! 2767: RRPLM EQU 120 RIGHT PLUS, MINUS ! 2768: LLPLM EQU 130 LEFT PLUS, MINUS ! 2769: RRNUM EQU 140 RIGHT NUMBER ! 2770: LLNUM EQU 150 LEFT NUMBER ! 2771: RRDVD EQU 160 RIGHT SLASH ! 2772: LLDVD EQU 170 LEFT SLASH ! 2773: RRMLT EQU 180 RIGHT ASTERISK ! 2774: LLMLT EQU 190 LEFT ASTERISK ! 2775: RRPCT EQU 200 RIGHT PERCENT ! 2776: LLPCT EQU 210 LEFT PERCENT ! 2777: RREXP EQU 230 RIGHT EXCLAMATION ! 2778: LLEXP EQU 220 LEFT EXCLAMATION ! 2779: RRDLD EQU 240 RIGHT DOLLAR, DOT ! 2780: LLDLD EQU 250 LEFT DOLLAR, DOT ! 2781: RRNOT EQU 270 RIGHT NOT ! 2782: LLNOT EQU 260 LEFT NOT ! 2783: LLUNO EQU 999 LEFT ALL UNARY OPERATORS ! 2784: * ! 2785: * PRECEDENCES ARE THE SAME AS IN BTL SNOBOL4 WITH THE ! 2786: * FOLLOWING EXCEPTIONS. ! 2787: * ! 2788: * 1) BINARY QUESTION MARK IS LOWERED AND MADE LEFT ASSOC- ! 2789: * IATIVE TO REFLECT ITS NEW USE FOR PATTERN MATCHING. ! 2790: * ! 2791: * 2) ALTERNATION AND CONCATENATION ARE MADE RIGHT ! 2792: * ASSOCIATIVE FOR GREATER EFFICIENCY IN PATTERN ! 2793: * CONSTRUCTION AND MATCHING RESPECTIVELY. THIS CHANGE ! 2794: * IS TRANSPARENT TO THE SNOBOL4 PROGRAMMER. ! 2795: * ! 2796: * 3) THE EQUAL SIGN HAS BEEN ADDED AS A LOW PRECEDENCE ! 2797: * OPERATOR WHICH IS RIGHT ASSOCIATIVE TO REFLECT ITS ! 2798: * MORE GENERAL USAGE IN THIS VERSION OF SNOBOL4. ! 2799: EJC ! 2800: * ! 2801: * EXTERNAL FUNCTION BLOCK (EFBLK) ! 2802: * ! 2803: * AN EXTERNAL FUNCTION BLOCK IS USED TO CONTROL THE CALLING ! 2804: * OF AN EXTERNAL FUNCTION. IT IS BUILT BY A CALL TO LOAD. ! 2805: * ! 2806: * +------------------------------------+ ! 2807: * I FCODE I ! 2808: * +------------------------------------+ ! 2809: * I FARGS I ! 2810: * +------------------------------------+ ! 2811: * I EFLEN I ! 2812: * +------------------------------------+ ! 2813: * I EFUSE I ! 2814: * +------------------------------------+ ! 2815: * I EFCOD I ! 2816: * +------------------------------------+ ! 2817: * I EFVAR I ! 2818: * +------------------------------------+ ! 2819: * I EFRSL I ! 2820: * +------------------------------------+ ! 2821: * / / ! 2822: * / EFTAR / ! 2823: * / / ! 2824: * +------------------------------------+ ! 2825: * ! 2826: EFLEN EQU FARGS+1 LENGTH OF EFBLK IN BYTES ! 2827: EFUSE EQU EFLEN+1 USE COUNT (FOR OPSYN) ! 2828: EFCOD EQU EFUSE+1 PTR TO CODE (FROM SYSLD) ! 2829: EFVAR EQU EFCOD+1 PTR TO ASSOCIATED VRBLK ! 2830: EFRSL EQU EFVAR+1 RESULT TYPE (SEE BELOW) ! 2831: EFTAR EQU EFRSL+1 ARGUMENT TYPES (SEE BELOW) ! 2832: EFSI$ EQU EFTAR NUMBER OF STANDARD FIELDS IN EFBLK ! 2833: * ! 2834: * THE FCODE FIELD POINTS TO THE ROUTINE B$EFC. ! 2835: * ! 2836: * EFUSE IS USED TO KEEP TRACK OF MULTIPLE USE WHEN OPSYN ! 2837: * IS EMPLOYED. THE FUNCTION IS AUTOMATICALLY UNLOADED ! 2838: * WHEN THERE ARE NO MORE REFERENCES TO THE FUNCTION. ! 2839: * ! 2840: * EFRSL AND EFTAR ARE TYPE CODES AS FOLLOWS. ! 2841: * ! 2842: * 0 TYPE IS UNCONVERTED ! 2843: * 1 TYPE IS STRING ! 2844: * 2 TYPE IS INTEGER ! 2845: * 3 TYPE IS REAL ! 2846: EJC ! 2847: * ! 2848: * EXPRESSION VARIABLE BLOCK (EVBLK) ! 2849: * ! 2850: * IN THIS VERSION OF SPITBOL, AN EXPRESSION CAN BE USED IN ! 2851: * ANY POSITION WHICH WOULD NORMALLY EXPECT A NAME (FOR ! 2852: * EXAMPLE ON THE LEFT SIDE OF EQUALS OR AS THE RIGHT ! 2853: * ARGUMENT OF BINARY DOT). THIS CORRESPONDS TO THE CREATION ! 2854: * OF A PSEUDO-VARIABLE WHICH IS REPRESENTED BY A POINTER TO ! 2855: * AN EXPRESSION VARIABLE BLOCK AS FOLLOWS. ! 2856: * ! 2857: * +------------------------------------+ ! 2858: * I EVTYP I ! 2859: * +------------------------------------+ ! 2860: * I EVEXP I ! 2861: * +------------------------------------+ ! 2862: * I EVVAR I ! 2863: * +------------------------------------+ ! 2864: * ! 2865: EVTYP EQU 0 POINTER TO DUMMY ROUTINE B$EVT ! 2866: EVEXP EQU EVTYP+1 POINTER TO EXBLK FOR EXPRESSION ! 2867: EVVAR EQU EVEXP+1 POINTER TO TRBEV DUMMY TRBLK ! 2868: EVSI$ EQU EVVAR+1 SIZE OF EVBLK ! 2869: * ! 2870: * THE NAME OF AN EXPRESSION VARIABLE IS REPRESENTED BY A ! 2871: * BASE POINTER TO THE EVBLK AND AN OFFSET OF EVVAR. THIS ! 2872: * VALUE APPEARS TO BE TRAPPED BY THE DUMMY TRBEV BLOCK. ! 2873: * ! 2874: * NOTE THAT THERE IS NO NEED TO ALLOW FOR THE CASE OF AN ! 2875: * EXPRESSION VARIABLE WHICH REFERENCES AN SEBLK SINCE A ! 2876: * VARIABLE WHICH IS OF THE FORM *VAR IS EQUIVALENT TO VAR. ! 2877: EJC ! 2878: * ! 2879: * EXPRESSION BLOCK (EXBLK) ! 2880: * ! 2881: * AN EXPRESSION BLOCK IS BUILT FOR EACH EXPRESSION ! 2882: * REFERENCED IN A PROGRAM OR CREATED BY EVAL OR CONVERT ! 2883: * DURING EXECUTION OF A PROGRAM. ! 2884: * ! 2885: * +------------------------------------+ ! 2886: * I EXTYP I ! 2887: * +------------------------------------+ ! 2888: * I EXSTM I ! 2889: * +------------------------------------+ ! 2890: * I EXLEN I ! 2891: * +------------------------------------+ ! 2892: * I EXFLC I ! 2893: * +------------------------------------+ ! 2894: * / / ! 2895: * / EXCOD / ! 2896: * / / ! 2897: * +------------------------------------+ ! 2898: * ! 2899: EXTYP EQU 0 PTR TO ROUTINE B$EXL TO LOAD EXPR ! 2900: EXSTM EQU CDSTM STORES STMNT NO. DURING EVALUATION ! 2901: EXLEN EQU EXSTM+1 LENGTH OF EXBLK IN BYTES ! 2902: EXFLC EQU EXLEN+1 FAILURE CODE (=O$FEX) ! 2903: EXCOD EQU EXFLC+1 PSEUDO-CODE FOR EXPRESSION ! 2904: EXSI$ EQU EXCOD NUMBER OF STANDARD FIELDS IN EXBLK ! 2905: * ! 2906: * THERE ARE TWO CASES FOR EXCOD DEPENDING ON WHETHER THE ! 2907: * EXPRESSION CAN BE EVALUATED BY NAME (SEE DESCRIPTION ! 2908: * OF CDBLK FOR DETAILS OF CODE FOR EXPRESSIONS). ! 2909: * ! 2910: * IF THE EXPRESSION CAN BE EVALUATED BY NAME WE HAVE. ! 2911: * ! 2912: * (CODE FOR EXPR BY NAME) ! 2913: * =O$RNM ! 2914: * ! 2915: * IF THE EXPRESSION CAN ONLY BE EVALUATED BY VALUE. ! 2916: * ! 2917: * (CODE FOR EXPR BY VALUE) ! 2918: * =O$RVL ! 2919: EJC ! 2920: * ! 2921: * FIELD FUNCTION BLOCK (FFBLK) ! 2922: * ! 2923: * A FIELD FUNCTION BLOCK IS USED TO CONTROL THE SELECTION ! 2924: * OF A FIELD FROM A PROGRAM DEFINED DATATYPE BLOCK. ! 2925: * A CALL TO DATA CREATES AN FFBLK FOR EACH FIELD. ! 2926: * ! 2927: * +------------------------------------+ ! 2928: * I FCODE I ! 2929: * +------------------------------------+ ! 2930: * I FARGS I ! 2931: * +------------------------------------+ ! 2932: * I FFDFP I ! 2933: * +------------------------------------+ ! 2934: * I FFNXT I ! 2935: * +------------------------------------+ ! 2936: * I FFOFS I ! 2937: * +------------------------------------+ ! 2938: * ! 2939: FFDFP EQU FARGS+1 POINTER TO ASSOCIATED DFBLK ! 2940: FFNXT EQU FFDFP+1 PTR TO NEXT FFBLK ON CHAIN OR ZERO ! 2941: FFOFS EQU FFNXT+1 OFFSET (BYTES) TO FIELD IN PDBLK ! 2942: FFSI$ EQU FFOFS+1 SIZE OF FFBLK IN WORDS ! 2943: * ! 2944: * THE FCODE FIELD POINTS TO THE ROUTINE B$FFC. ! 2945: * ! 2946: * FARGS ALWAYS CONTAINS ONE. ! 2947: * ! 2948: * FFDFP IS USED TO VERIFY THAT THE CORRECT PROGRAM DEFINED ! 2949: * DATATYPE IS BEING ACCESSED BY THIS CALL. ! 2950: * FFDFP IS NON-RELOC. BECAUSE DFBLK IS IN STATIC ! 2951: * ! 2952: * FFOFS IS USED TO SELECT THE APPROPRIATE FIELD. NOTE THAT ! 2953: * IT IS AN ACTUAL OFFSET (NOT A FIELD NUMBER) ! 2954: * ! 2955: * FFNXT IS USED TO POINT TO THE NEXT FFBLK OF THE SAME NAME ! 2956: * IN THE CASE WHERE THERE ARE SEVERAL FIELDS OF THE SAME ! 2957: * NAME FOR DIFFERENT DATATYPES. ZERO MARKS THE END OF CHAIN ! 2958: EJC ! 2959: * ! 2960: * INTEGER CONSTANT BLOCK (ICBLK) ! 2961: * ! 2962: * AN ICBLK IS CREATED FOR EVERY INTEGER REFERENCED OR ! 2963: * CREATED BY A PROGRAM. NOTE HOWEVER THAT CERTAIN INTERNAL ! 2964: * INTEGER VALUES ARE STORED AS ADDRESSES (E.G. THE LENGTH ! 2965: * FIELD IN A STRING CONSTANT BLOCK) ! 2966: * ! 2967: * +------------------------------------+ ! 2968: * I ICGET I ! 2969: * +------------------------------------+ ! 2970: * * ICVAL * ! 2971: * +------------------------------------+ ! 2972: * ! 2973: ICGET EQU 0 PTR TO ROUTINE B$ICL TO LOAD INT ! 2974: ICVAL EQU ICGET+1 INTEGER VALUE ! 2975: ICSI$ EQU ICVAL+CFP$I SIZE OF ICBLK ! 2976: * ! 2977: * THE LENGTH OF THE ICVAL FIELD IS CFP$I. ! 2978: EJC ! 2979: * ! 2980: * KEYWORD VARIABLE BLOCK (KVBLK) ! 2981: * ! 2982: * A KVBLK IS USED TO REPRESENT A KEYWORD PSEUDO-VARIABLE. ! 2983: * A KVBLK IS BUILT FOR EACH KEYWORD REFERENCE (KWNAM). ! 2984: * ! 2985: * +------------------------------------+ ! 2986: * I KVTYP I ! 2987: * +------------------------------------+ ! 2988: * I KVVAR I ! 2989: * +------------------------------------+ ! 2990: * I KVNUM I ! 2991: * +------------------------------------+ ! 2992: * ! 2993: KVTYP EQU 0 POINTER TO DUMMY ROUTINE B$KVT ! 2994: KVVAR EQU KVTYP+1 POINTER TO DUMMY BLOCK TRBKV ! 2995: KVNUM EQU KVVAR+1 KEYWORD NUMBER ! 2996: KVSI$ EQU KVNUM+1 SIZE OF KVBLK ! 2997: * ! 2998: * THE NAME OF A KEYWORD VARIABLE IS REPRESENTED BY A ! 2999: * BASE POINTER TO THE KVBLK AND AN OFFSET OF KVVAR. THE ! 3000: * VALUE APPEARS TO BE TRAPPED BY THE POINTER TO TRBKV. ! 3001: EJC ! 3002: * ! 3003: * NAME BLOCK (NMBLK) ! 3004: * ! 3005: * A NAME BLOCK IS USED WHEREVER A NAME MUST BE STORED AS ! 3006: * A VALUE FOLLOWING USE OF THE UNARY DOT OPERATOR. ! 3007: * ! 3008: * +------------------------------------+ ! 3009: * I NMTYP I ! 3010: * +------------------------------------+ ! 3011: * I NMBAS I ! 3012: * +------------------------------------+ ! 3013: * I NMOFS I ! 3014: * +------------------------------------+ ! 3015: * ! 3016: NMTYP EQU 0 PTR TO ROUTINE B$NML TO LOAD NAME ! 3017: NMBAS EQU NMTYP+1 BASE POINTER FOR VARIABLE ! 3018: NMOFS EQU NMBAS+1 OFFSET FOR VARIABLE ! 3019: NMSI$ EQU NMOFS+1 SIZE OF NMBLK ! 3020: * ! 3021: * THE ACTUAL FIELD REPRESENTING THE CONTENTS OF THE NAME ! 3022: * IS FOUND NMOFS BYTES PAST THE ADDRESS IN NMBAS. ! 3023: * ! 3024: * THE NAME IS SPLIT INTO BASE AND OFFSET FORM TO AVOID ! 3025: * CREATION OF A POINTER INTO THE MIDDLE OF A BLOCK WHICH ! 3026: * COULD NOT BE HANDLED PROPERLY BY THE GARBAGE COLLECTOR. ! 3027: * ! 3028: * A NAME MAY BE BUILT FOR ANY VARIABLE (SEE SECTION ON ! 3029: * REPRESENTATIONS OF VARIABLES) THIS INCLUDES THE ! 3030: * CASES OF PSEUDO-VARIABLES. ! 3031: EJC ! 3032: * ! 3033: * PATTERN BLOCK, NO PARAMETERS (P0BLK) ! 3034: * ! 3035: * A P0BLK IS USED TO REPRESENT PATTERN NODES WHICH DO ! 3036: * NOT REQUIRE THE USE OF ANY PARAMETER VALUES. ! 3037: * ! 3038: * +------------------------------------+ ! 3039: * I PCODE I ! 3040: * +------------------------------------+ ! 3041: * I PTHEN I ! 3042: * +------------------------------------+ ! 3043: * ! 3044: PCODE EQU 0 PTR TO MATCH ROUTINE (P$XXX) ! 3045: PTHEN EQU PCODE+1 POINTER TO SUBSEQUENT NODE ! 3046: PASI$ EQU PTHEN+1 SIZE OF P0BLK ! 3047: * ! 3048: * PTHEN POINTS TO THE PATTERN BLOCK FOR THE SUBSEQUENT ! 3049: * NODE TO BE MATCHED. THIS IS A POINTER TO THE PATTERN ! 3050: * BLOCK NDNTH IF THERE IS NO SUBSEQUENT (END OF PATTERN) ! 3051: * ! 3052: * PCODE IS A POINTER TO THE MATCH ROUTINE FOR THE NODE. ! 3053: EJC ! 3054: * ! 3055: * PATTERN BLOCK (ONE PARAMETER) ! 3056: * ! 3057: * A P1BLK IS USED TO REPRESENT PATTERN NODES WHICH ! 3058: * REQUIRE ONE PARAMETER VALUE. ! 3059: * ! 3060: * +------------------------------------+ ! 3061: * I PCODE I ! 3062: * +------------------------------------+ ! 3063: * I PTHEN I ! 3064: * +------------------------------------+ ! 3065: * I PARM1 I ! 3066: * +------------------------------------+ ! 3067: * ! 3068: PARM1 EQU PTHEN+1 FIRST PARAMETER VALUE ! 3069: PBSI$ EQU PARM1+1 SIZE OF P1BLK IN WORDS ! 3070: * ! 3071: * SEE P0BLK FOR DEFINITIONS OF PCODE, PTHEN ! 3072: * ! 3073: * PARM1 CONTAINS A PARAMETER VALUE USED IN MATCHING THE ! 3074: * NODE. FOR EXAMPLE, IN A LEN PATTERN, IT IS THE INTEGER ! 3075: * ARGUMENT TO LEN. THE DETAILS OF THE USE OF THE PARAMETER ! 3076: * FIELD ARE INCLUDED IN THE DESCRIPTION OF THE INDIVIDUAL ! 3077: * MATCH ROUTINES. PARM1 IS ALWAYS AN ADDRESS POINTER WHICH ! 3078: * IS PROCESSED BY THE GARBAGE COLLECTOR. ! 3079: EJC ! 3080: * ! 3081: * PATTERN BLOCK (TWO PARAMETERS) ! 3082: * ! 3083: * A P2BLK IS USED TO REPRESENT PATTERN NODES WHICH ! 3084: * REQUIRE TWO PARAMETER VALUES. ! 3085: * ! 3086: * +------------------------------------+ ! 3087: * I PCODE I ! 3088: * +------------------------------------+ ! 3089: * I PTHEN I ! 3090: * +------------------------------------+ ! 3091: * I PARM1 I ! 3092: * +------------------------------------+ ! 3093: * I PARM2 I ! 3094: * +------------------------------------+ ! 3095: * ! 3096: PARM2 EQU PARM1+1 SECOND PARAMETER VALUE ! 3097: PCSI$ EQU PARM2+1 SIZE OF P2BLK IN WORDS ! 3098: * ! 3099: * SEE P1BLK FOR DEFINITIONS OF PCODE, PTHEN, PARM1 ! 3100: * ! 3101: * PARM2 IS A PARAMETER WHICH PERFORMS THE SAME SORT OF ! 3102: * FUNCTION AS PARM1 (SEE DESCRIPTION OF P1BLK). ! 3103: * ! 3104: * PARM2 IS A NON-RELOCATABLE FIELD AND IS NOT ! 3105: * PROCESSED BY THE GARBAGE COLLECTOR. ACCORDINGLY, IT MAY ! 3106: * NOT CONTAIN A POINTER TO A BLOCK IN DYNAMIC MEMORY. ! 3107: EJC ! 3108: * ! 3109: * PROGRAM-DEFINED DATATYPE BLOCK ! 3110: * ! 3111: * A PDBLK REPRESENTS THE DATA ITEM FORMED BY A CALL TO A ! 3112: * DATATYPE FUNCTION AS DEFINED BY THE SYSTEM FUNCTION DATA. ! 3113: * ! 3114: * +------------------------------------+ ! 3115: * I PDTYP I ! 3116: * +------------------------------------+ ! 3117: * I IDVAL I ! 3118: * +------------------------------------+ ! 3119: * I PDDFP I ! 3120: * +------------------------------------+ ! 3121: * / / ! 3122: * / PDFLD / ! 3123: * / / ! 3124: * +------------------------------------+ ! 3125: * ! 3126: PDTYP EQU 0 PTR TO DUMMY ROUTINE B$PDT ! 3127: PDDFP EQU IDVAL+1 PTR TO ASSOCIATED DFBLK ! 3128: PDFLD EQU PDDFP+1 START OF FIELD VALUE POINTERS ! 3129: PDFOF EQU DFFLD-PDFLD DIFFERENCE IN OFFSET TO FIELD PTRS ! 3130: PDSI$ EQU PDFLD SIZE OF STANDARD FIELDS IN PDBLK ! 3131: PDDFS EQU DFSI$-PDSI$ DIFFERENCE IN DFBLK, PDBLK SIZES ! 3132: * ! 3133: * THE PDDFP POINTER MAY BE USED TO DETERMINE THE DATATYPE ! 3134: * AND THE NAMES OF THE FIELDS IF REQUIRED. THE DFBLK ALSO ! 3135: * CONTAINS THE LENGTH OF THE PDBLK IN BYTES (FIELD DFPDL). ! 3136: * PDDFP IS NON-RELOC. BECAUSE DFBLK IS IN STATIC ! 3137: * ! 3138: * PDFLD VALUES ARE STORED IN ORDER FROM LEFT TO RIGHT. ! 3139: * THEY CONTAIN VALUES OR POINTERS TO TRBLK CHAINS. ! 3140: EJC ! 3141: * ! 3142: * PROGRAM DEFINED FUNCTION BLOCK (PFBLK) ! 3143: * ! 3144: * A PFBLK IS CREATED FOR EACH CALL TO THE DEFINE FUNCTION ! 3145: * AND A POINTER TO THE PFBLK PLACED IN THE PROPER VRBLK. ! 3146: * ! 3147: * +------------------------------------+ ! 3148: * I FCODE I ! 3149: * +------------------------------------+ ! 3150: * I FARGS I ! 3151: * +------------------------------------+ ! 3152: * I PFLEN I ! 3153: * +------------------------------------+ ! 3154: * I PFVBL I ! 3155: * +------------------------------------+ ! 3156: * I PFNLO I ! 3157: * +------------------------------------+ ! 3158: * I PFCOD I ! 3159: * +------------------------------------+ ! 3160: * I PFCTR I ! 3161: * +------------------------------------+ ! 3162: * I PFRTR I ! 3163: * +------------------------------------+ ! 3164: * / / ! 3165: * / PFARG / ! 3166: * / / ! 3167: * +------------------------------------+ ! 3168: * ! 3169: PFLEN EQU FARGS+1 LENGTH OF PFBLK IN BYTES ! 3170: PFVBL EQU PFLEN+1 POINTER TO VRBLK FOR FUNCTION NAME ! 3171: PFNLO EQU PFVBL+1 NUMBER OF LOCALS ! 3172: PFCOD EQU PFNLO+1 PTR TO CDBLK FOR FIRST STATEMENT ! 3173: PFCTR EQU PFCOD+1 TRBLK PTR IF CALL TRACED ELSE 0 ! 3174: PFRTR EQU PFCTR+1 TRBLK PTR IF RETURN TRACED ELSE 0 ! 3175: PFARG EQU PFRTR+1 VRBLK PTRS FOR ARGUMENTS AND LOCALS ! 3176: PFAGB EQU PFARG-1 OFFSET BEHIND PFARG FOR ARG, LOCAL ! 3177: PFSI$ EQU PFARG NUMBER OF STANDARD FIELDS IN PFBLK ! 3178: * ! 3179: * THE FCODE FIELD POINTS TO THE ROUTINE B$PFC. ! 3180: * ! 3181: * PFARG IS STORED IN THE FOLLOWING ORDER. ! 3182: * ! 3183: * ARGUMENTS (LEFT TO RIGHT) ! 3184: * LOCALS (LEFT TO RIGHT) ! 3185: .IF .CNRA ! 3186: .ELSE ! 3187: EJC ! 3188: * ! 3189: * REAL CONSTANT BLOCK (RCBLK) ! 3190: * ! 3191: * AN RCBLK IS CREATED FOR EVERY REAL REFERENCED OR ! 3192: * CREATED BY A PROGRAM. ! 3193: * ! 3194: * +------------------------------------+ ! 3195: * I RCGET I ! 3196: * +------------------------------------+ ! 3197: * * RCVAL * ! 3198: * +------------------------------------+ ! 3199: * ! 3200: RCGET EQU 0 PTR TO ROUTINE B$RCL TO LOAD REAL ! 3201: RCVAL EQU RCGET+1 REAL VALUE ! 3202: RCSI$ EQU RCVAL+CFP$R SIZE OF RCBLK ! 3203: * ! 3204: * THE LENGTH OF THE RCVAL FIELD IS CFP$R. ! 3205: .FI ! 3206: EJC ! 3207: * ! 3208: * STRING CONSTANT BLOCK (SCBLK) ! 3209: * ! 3210: * AN SCBLK IS BUILT FOR EVERY STRING REFERENCED OR CREATED ! 3211: * BY A PROGRAM. ! 3212: * ! 3213: * +------------------------------------+ ! 3214: * I SCGET I ! 3215: * +------------------------------------+ ! 3216: * I SCLEN I ! 3217: * +------------------------------------+ ! 3218: * / / ! 3219: * / SCHAR / ! 3220: * / / ! 3221: * +------------------------------------+ ! 3222: * ! 3223: SCGET EQU 0 PTR TO ROUTINE B$SCL TO LOAD STRING ! 3224: SCLEN EQU SCGET+1 LENGTH OF STRING IN CHARACTERS ! 3225: SCHAR EQU SCLEN+1 CHARACTERS OF STRING ! 3226: SCSI$ EQU SCHAR SIZE OF STANDARD FIELDS IN SCBLK ! 3227: * ! 3228: * THE CHARACTERS OF THE STRING ARE STORED LEFT JUSTIFIED. ! 3229: * THE FINAL WORD IS PADDED ON THE RIGHT WITH ZEROS. ! 3230: * (I.E. THE CHARACTER WHOSE INTERNAL CODE IS ZERO). ! 3231: * ! 3232: * THE VALUE OF SCLEN MAY NOT EXCEED MXLEN. THIS ENSURES ! 3233: * THAT CHARACTER OFFSETS (E.G. THE PATTERN MATCH CURSOR) ! 3234: * CAN BE CORRECTLY PROCESSED BY THE GARBAGE COLLECTOR. ! 3235: * ! 3236: * NOTE THAT THE OFFSET TO THE CHARACTERS OF THE STRING ! 3237: * IS GIVEN IN BYTES BY CFP$F AND THAT THIS VALUE IS ! 3238: * AUTOMATICALLY ALLOWED FOR IN PLC, PSC. ! 3239: * NOTE THAT FOR A SPITBOL SCBLK, THE VALUE OF CFP$F ! 3240: * IS GIVEN BY CFP$B*SCHAR. ! 3241: EJC ! 3242: * ! 3243: * SIMPLE EXPRESSION BLOCK (SEBLK) ! 3244: * ! 3245: * AN SEBLK IS USED TO REPRESENT AN EXPRESSION OF THE FORM ! 3246: * *(NATURAL VARIABLE). ALL OTHER EXPRESSIONS ARE EXBLKS. ! 3247: * ! 3248: * +------------------------------------+ ! 3249: * I SETYP I ! 3250: * +------------------------------------+ ! 3251: * I SEVAR I ! 3252: * +------------------------------------+ ! 3253: * ! 3254: SETYP EQU 0 PTR TO ROUTINE B$SEL TO LOAD EXPR ! 3255: SEVAR EQU SETYP+1 PTR TO VRBLK FOR VARIABLE ! 3256: SESI$ EQU SEVAR+1 LENGTH OF SEBLK IN WORDS ! 3257: EJC ! 3258: * ! 3259: * STANDARD VARIABLE BLOCK (SVBLK) ! 3260: * ! 3261: * AN SVBLK IS ASSEMBLED IN THE CONSTANT SECTION FOR EACH ! 3262: * VARIABLE WHICH SATISFIES ONE OF THE FOLLOWING CONDITIONS. ! 3263: * ! 3264: * 1) IT IS THE NAME OF A SYSTEM FUNCTION ! 3265: * 2) IT HAS AN INITIAL VALUE ! 3266: * 3) IT HAS A KEYWORD ASSOCIATION ! 3267: * 4) IT HAS A STANDARD I/O ASSOCIATION ! 3268: * 6) IT HAS A STANDARD LABEL ASSOCIATION ! 3269: * ! 3270: * IF VRBLKS ARE CONSTRUCTED FOR ANY OF THESE VARIABLES, ! 3271: * THEN THE VRSVP FIELD POINTS TO THE SVBLK (SEE VRBLK) ! 3272: * ! 3273: * +------------------------------------+ ! 3274: * I SVBIT I ! 3275: * +------------------------------------+ ! 3276: * I SVLEN I ! 3277: * +------------------------------------+ ! 3278: * I SVCHS I ! 3279: * +------------------------------------+ ! 3280: * I SVKNM I ! 3281: * +------------------------------------+ ! 3282: * I SVFNC I ! 3283: * +------------------------------------+ ! 3284: * I SVNAR I ! 3285: * +------------------------------------+ ! 3286: * I SVLBL I ! 3287: * +------------------------------------+ ! 3288: * I SVVAL I ! 3289: * +------------------------------------+ ! 3290: EJC ! 3291: * ! 3292: * STANDARD VARIABLE BLOCK (CONTINUED) ! 3293: * ! 3294: SVBIT EQU 0 BIT STRING INDICATING ATTRIBUTES ! 3295: SVLEN EQU 1 (=SCLEN) LENGTH OF NAME IN CHARS ! 3296: SVCHS EQU 2 (=SCHAR) CHARACTERS OF NAME ! 3297: SVSI$ EQU 2 NUMBER OF STANDARD FIELDS IN SVBLK ! 3298: SVPRE EQU 1 SET IF PREEVALUATION PERMITTED ! 3299: SVFFC EQU SVPRE+SVPRE SET ON IF FAST CALL PERMITTED ! 3300: SVCKW EQU SVFFC+SVFFC SET ON IF KEYWORD VALUE CONSTANT ! 3301: SVPRD EQU SVCKW+SVCKW SET ON IF PREDICATE FUNCTION ! 3302: SVNBT EQU 4 NUMBER OF BITS TO RIGHT OF SVKNM ! 3303: SVKNM EQU SVPRD+SVPRD SET ON IF KEYWORD ASSOCIATION ! 3304: SVFNC EQU SVKNM+SVKNM SET ON IF SYSTEM FUNCTION ! 3305: SVNAR EQU SVFNC+SVFNC SET ON IF SYSTEM FUNCTION ! 3306: SVLBL EQU SVNAR+SVNAR SET ON IF SYSTEM LABEL ! 3307: SVVAL EQU SVLBL+SVLBL SET ON IF PREDEFINED VALUE ! 3308: * ! 3309: * NOTE THAT THE LAST FIVE BITS CORRESPOND IN ORDER ! 3310: * TO THE FIELDS WHICH ARE PRESENT (SEE PROCEDURE GTNVR). ! 3311: * ! 3312: * THE FOLLOWING DEFINITIONS ARE USED IN THE SVBLK TABLE ! 3313: * ! 3314: SVFNF EQU SVFNC+SVNAR FUNCTION WITH NO FAST CALL ! 3315: SVFNN EQU SVFNF+SVFFC FUNCTION WITH FAST CALL, NO PREEVAL ! 3316: SVFNP EQU SVFNN+SVPRE FUNCTION ALLOWING PREEVALUATION ! 3317: SVFPR EQU SVFNN+SVPRD PREDICATE FUNCTION ! 3318: SVFNK EQU SVFNN+SVKNM NO PREEVAL FUNC + KEYWORD ! 3319: SVKWV EQU SVKNM+SVVAL KEYWORD + VALUE ! 3320: SVKWC EQU SVCKW+SVKNM KEYWORD WITH CONSTANT VALUE ! 3321: SVKVC EQU SVKWV+SVCKW CONSTANT KEYWORD + VALUE ! 3322: SVKVL EQU SVKVC+SVLBL CONSTANT KEYWORD + VALUE + LABEL ! 3323: SVFPK EQU SVFNP+SVKVC PREEVAL FCN + CONST KEYWD + VAL ! 3324: * ! 3325: * THE SVPRE BIT ALLOWS THE COMPILER TO PREEVALUATE A CALL ! 3326: * TO THE ASSOCIATED SYSTEM FUNCTION IF ALL THE ARGUMENTS ! 3327: * ARE THEMSELVES CONSTANTS. FUNCTIONS IN THIS CATEGORY ! 3328: * MUST HAVE NO SIDE EFFECTS AND MUST NEVER CAUSE FAILURE. ! 3329: * THE CALL MAY GENERATE AN ERROR CONDITION. ! 3330: * ! 3331: * THE SVFFC BIT ALLOWS THE COMPILER TO GENERATE THE SPECIAL ! 3332: * FAST CALL AFTER ADJUSTING THE NUMBER OF ARGUMENTS. ONLY ! 3333: * THE ITEM AND APPLY FUNCTIONS FALL OUTSIDE THIS CATEGORY. ! 3334: * ! 3335: * THE SVCKW BIT IS SET IF THE ASSOCIATED KEYWORD VALUE IS ! 3336: * A CONSTANT, THUS ALLOWING PREEVALUATION FOR A VALUE CALL. ! 3337: * ! 3338: * THE SVPRD BIT IS SET ON FOR ALL PREDICATE FUNCTIONS TO ! 3339: * ENABLE THE SPECIAL CONCATENATION CODE OPTIMIZATION. ! 3340: EJC ! 3341: * ! 3342: * SVBLK (CONTINUED) ! 3343: * ! 3344: * SVKNM KEYWORD NUMBER ! 3345: * ! 3346: * SVKNM IS PRESENT ONLY FOR A STANDARD KEYWORD ASSOC. ! 3347: * IT CONTAINS A KEYWORD NUMBER AS DEFINED BY THE ! 3348: * KEYWORD NUMBER TABLE GIVEN LATER ON. ! 3349: * ! 3350: * SVFNC SYSTEM FUNCTION POINTER ! 3351: * ! 3352: * SVFNC IS PRESENT ONLY FOR A SYSTEM FUNCTION ASSOC. ! 3353: * IT IS A POINTER TO THE ACTUAL CODE FOR THE SYSTEM ! 3354: * FUNCTION. THE GENERATED CODE FOR A FAST CALL IS A ! 3355: * POINTER TO THE SVFNC FIELD OF THE SVBLK FOR THE ! 3356: * FUNCTION. THE VRFNC FIELD OF THE VRBLK POINTS TO ! 3357: * THIS SAME FIELD, IN WHICH CASE, IT SERVES AS THE ! 3358: * FCODE FIELD FOR THE FUNCTION CALL. ! 3359: * ! 3360: * SVNAR NUMBER OF FUNCTION ARGUMENTS ! 3361: * ! 3362: * SVNAR IS PRESENT ONLY FOR A SYSTEM FUNCTION ASSOC. ! 3363: * IT IS THE NUMBER OF ARGUMENTS REQUIRED FOR A CALL ! 3364: * TO THE SYSTEM FUNCTION. THE COMPILER USES THIS ! 3365: * VALUE TO ADJUST THE NUMBER OF ARGUMENTS IN A FAST ! 3366: * CALL AND IN THE CASE OF A FUNCTION CALLED THROUGH ! 3367: * THE VRFNC FIELD OF THE VRBLK, THE SVNAR FIELD ! 3368: * SERVES AS THE FARGS FIELD FOR O$FNC. A SPECIAL ! 3369: * CASE OCCURS IF THIS VALUE IS SET TO 999. THIS IS ! 3370: * USED TO INDICATE THAT THE FUNCTION HAS A VARIABLE ! 3371: * NUMBER OF ARGUMENTS AND CAUSES O$FNC TO PASS CONTROL ! 3372: * WITHOUT ADJUSTING THE ARGUMENT COUNT. THE ONLY ! 3373: * PREDEFINED FUNCTIONS USING THIS ARE APPLY AND ITEM. ! 3374: * ! 3375: * SVLBL SYSTEM LABEL POINTER ! 3376: * ! 3377: * SVLBL IS PRESENT ONLY FOR A STANDARD LABEL ASSOC. ! 3378: * IT IS A POINTER TO A SYSTEM LABEL ROUTINE (L$XXX). ! 3379: * THE VRLBL FIELD OF THE CORRESPONDING VRBLK POINTS TO ! 3380: * THE SVLBL FIELD OF THE SVBLK. ! 3381: * ! 3382: * SVVAL SYSTEM VALUE POINTER ! 3383: * ! 3384: * SVVAL IS PRESENT ONLY FOR A STANDARD VALUE. ! 3385: * IT IS A POINTER TO THE PATTERN NODE (NDXXX) WHICH ! 3386: * IS THE STANDARD INITIAL VALUE OF THE VARIABLE. ! 3387: * THIS VALUE IS COPIED TO THE VRVAL FIELD OF THE VRBLK ! 3388: EJC ! 3389: * ! 3390: * SVBLK (CONTINUED) ! 3391: * ! 3392: * KEYWORD NUMBER TABLE ! 3393: * ! 3394: * THE FOLLOWING TABLE GIVES SYMBOLIC NAMES FOR KEYWORD ! 3395: * NUMBERS. THESE VALUES ARE STORED IN THE SVKNM FIELD OF ! 3396: * SVBLKS AND IN THE KVNUM FIELD OF KVBLKS. SEE ALSO ! 3397: * PROCEDURES ASIGN, ACESS AND KWNAM. ! 3398: * ! 3399: * UNPROTECTED KEYWORDS WITH ONE WORD INTEGER VALUES ! 3400: * ! 3401: K$ABE EQU 0 ABEND ! 3402: K$ANC EQU K$ABE+CFP$B ANCHOR ! 3403: .IF .CULC ! 3404: K$CAS EQU K$ANC+CFP$B CASE ! 3405: K$COD EQU K$CAS+CFP$B CODE ! 3406: .ELSE ! 3407: K$COD EQU K$ANC+CFP$B CODE ! 3408: .FI ! 3409: K$DMP EQU K$COD+CFP$B DUMP ! 3410: K$ERL EQU K$DMP+CFP$B ERRLIMIT ! 3411: K$ERT EQU K$ERL+CFP$B ERRTYPE ! 3412: K$FTR EQU K$ERT+CFP$B FTRACE ! 3413: K$INP EQU K$FTR+CFP$B INPUT ! 3414: K$MXL EQU K$INP+CFP$B MAXLENGTH ! 3415: K$OUP EQU K$MXL+CFP$B OUTPUT ! 3416: .IF .CNPF ! 3417: K$TRA EQU K$OUP+CFP$B TRACE ! 3418: .ELSE ! 3419: K$PFL EQU K$OUP+CFP$B PROFILE ! 3420: K$TRA EQU K$PFL+CFP$B TRACE ! 3421: .FI ! 3422: K$TRM EQU K$TRA+CFP$B TRIM ! 3423: * ! 3424: * PROTECTED KEYWORDS WITH ONE WORD INTEGER VALUES ! 3425: * ! 3426: K$FNC EQU K$TRM+CFP$B FNCLEVEL ! 3427: K$LST EQU K$FNC+CFP$B LASTNO ! 3428: K$STN EQU K$LST+CFP$B STNO ! 3429: * ! 3430: * KEYWORDS WITH CONSTANT PATTERN VALUES ! 3431: * ! 3432: K$ABO EQU K$STN+CFP$B ABORT ! 3433: K$ARB EQU K$ABO+PASI$ ARB ! 3434: K$BAL EQU K$ARB+PASI$ BAL ! 3435: K$FAL EQU K$BAL+PASI$ FAIL ! 3436: K$FEN EQU K$FAL+PASI$ FENCE ! 3437: K$REM EQU K$FEN+PASI$ REM ! 3438: K$SUC EQU K$REM+PASI$ SUCCEED ! 3439: EJC ! 3440: * ! 3441: * KEYWORD NUMBER TABLE (CONTINUED) ! 3442: * ! 3443: * SPECIAL KEYWORDS ! 3444: * ! 3445: K$ALP EQU K$SUC+1 ALPHABET ! 3446: K$RTN EQU K$ALP+1 RTNTYPE ! 3447: K$STC EQU K$RTN+1 STCOUNT ! 3448: K$ETX EQU K$STC+1 ERRTEXT ! 3449: K$STL EQU K$ETX+1 STLIMIT ! 3450: * ! 3451: * RELATIVE OFFSETS OF SPECIAL KEYWORDS ! 3452: * ! 3453: K$$AL EQU K$ALP-K$ALP ALPHABET ! 3454: K$$RT EQU K$RTN-K$ALP RTNTYPE ! 3455: K$$SC EQU K$STC-K$ALP STCOUNT ! 3456: K$$ET EQU K$ETX-K$ALP ERRTEXT ! 3457: K$$SL EQU K$STL-K$ALP STLIMIT ! 3458: * ! 3459: * SYMBOLS USED IN ASIGN AND ACESS PROCEDURES ! 3460: * ! 3461: K$P$$ EQU K$FNC FIRST PROTECTED KEYWORD ! 3462: K$V$$ EQU K$ABO FIRST KEYWORD WITH CONSTANT VALUE ! 3463: K$S$$ EQU K$ALP FIRST KEYWORD WITH SPECIAL ACESS ! 3464: EJC ! 3465: * ! 3466: * FORMAT OF A TABLE BLOCK (TBBLK) ! 3467: * ! 3468: * A TABLE BLOCK IS USED TO REPRESENT A TABLE VALUE. ! 3469: * IT IS BUILT BY A CALL TO THE TABLE OR CONVERT FUNCTIONS. ! 3470: * ! 3471: * +------------------------------------+ ! 3472: * I TBTYP I ! 3473: * +------------------------------------+ ! 3474: * I IDVAL I ! 3475: * +------------------------------------+ ! 3476: * I TBLEN I ! 3477: * +------------------------------------+ ! 3478: * +------------------------------------+ ! 3479: * I TBINV I ! 3480: * +------------------------------------+ ! 3481: * / / ! 3482: * / TBBUK / ! 3483: * / / ! 3484: * +------------------------------------+ ! 3485: * ! 3486: TBTYP EQU 0 POINTER TO DUMMY ROUTINE B$TBT ! 3487: TBLEN EQU OFFS2 LENGTH OF TBBLK IN BYTES ! 3488: TBINV EQU OFFS3 DEFAULT INITIAL LOOKUP VALUE ! 3489: TBBUK EQU TBINV+1 START OF HASH BUCKET POINTERS ! 3490: TBSI$ EQU TBBUK SIZE OF STANDARD FIELDS IN TBBLK ! 3491: TBNBK EQU 11 DEFAULT NO. OF BUCKETS ! 3492: * ! 3493: * THE TABLE BLOCK IS A HASH TABLE WHICH POINTS TO CHAINS ! 3494: * OF TABLE ELEMENT BLOCKS REPRESENTING THE ELEMENTS ! 3495: * IN THE TABLE WHICH HASH INTO THE SAME BUCKET. ! 3496: * ! 3497: * TBBUK ENTRIES EITHER POINT TO THE FIRST TEBLK ON THE ! 3498: * CHAIN OR THEY POINT TO THE TBBLK ITSELF TO INDICATE THE ! 3499: * END OF THE CHAIN. ! 3500: EJC ! 3501: * ! 3502: * TABLE ELEMENT BLOCK (TEBLK) ! 3503: * ! 3504: * A TABLE ELEMENT IS USED TO REPRESENT A SINGLE ENTRY IN ! 3505: * A TABLE (SEE DESCRIPTION OF TBBLK FORMAT FOR HASH TABLE) ! 3506: * ! 3507: * +------------------------------------+ ! 3508: * I TETYP I ! 3509: * +------------------------------------+ ! 3510: * I TESUB I ! 3511: * +------------------------------------+ ! 3512: * I TEVAL I ! 3513: * +------------------------------------+ ! 3514: * I TENXT I ! 3515: * +------------------------------------+ ! 3516: * ! 3517: TETYP EQU 0 POINTER TO DUMMY ROUTINE B$TET ! 3518: TESUB EQU TETYP+1 SUBSCRIPT VALUE ! 3519: TEVAL EQU TESUB+1 (=VRVAL) TABLE ELEMENT VALUE ! 3520: TENXT EQU TEVAL+1 LINK TO NEXT TEBLK ! 3521: * SEE S$CNV WHERE RELATION IS ASSUMED WITH TENXT AND TBBUK ! 3522: TESI$ EQU TENXT+1 SIZE OF TEBLK IN WORDS ! 3523: * ! 3524: * TENXT POINTS TO THE NEXT TEBLK ON THE HASH CHAIN FROM THE ! 3525: * TBBUK CHAIN FOR THIS HASH INDEX. AT THE END OF THE CHAIN, ! 3526: * TENXT POINTS BACK TO THE START OF THE TBBLK. ! 3527: * ! 3528: * TEVAL CONTAINS A DATA POINTER OR A TRBLK POINTER. ! 3529: * ! 3530: * TESUB CONTAINS A DATA POINTER. ! 3531: EJC ! 3532: * ! 3533: * TRAP BLOCK (TRBLK) ! 3534: * ! 3535: * A TRAP BLOCK IS USED TO REPRESENT A TRACE OR INPUT OR ! 3536: * OUTPUT ASSOCIATION IN RESPONSE TO A CALL TO THE TRACE ! 3537: * INPUT OR OUTPUT SYSTEM FUNCTIONS. SEE BELOW FOR DETAILS ! 3538: * ! 3539: * +------------------------------------+ ! 3540: * I TRIDN I ! 3541: * +------------------------------------+ ! 3542: * I TRTYP I ! 3543: * +------------------------------------+ ! 3544: * I TRVAL OR TRLBL OR TRNXT OR TRKVR I ! 3545: * +------------------------------------+ ! 3546: * I TRTAG OR TRTER OR TRTRF I ! 3547: * +------------------------------------+ ! 3548: * I TRFNC OR TRFPT I ! 3549: * +------------------------------------+ ! 3550: * ! 3551: TRIDN EQU 0 POINTER TO DUMMY ROUTINE B$TRT ! 3552: TRTYP EQU TRIDN+1 TRAP TYPE CODE ! 3553: TRVAL EQU TRTYP+1 VALUE OF TRAPPED VARIABLE (=VRVAL) ! 3554: TRNXT EQU TRVAL PTR TO NEXT TRBLK ON TRBLK CHAIN ! 3555: TRLBL EQU TRVAL PTR TO ACTUAL LABEL (TRACED LABEL) ! 3556: TRKVR EQU TRVAL VRBLK POINTER FOR KEYWORD TRACE ! 3557: TRTAG EQU TRVAL+1 TRACE TAG ! 3558: TRTER EQU TRTAG PTR TO TERMINAL VRBLK OR NULL ! 3559: TRTRF EQU TRTAG PTR TO TRBLK HOLDING FCBLK PTR ! 3560: TRFNC EQU TRTAG+1 TRACE FUNCTION VRBLK (ZERO IF NONE) ! 3561: TRFPT EQU TRFNC FCBLK PTR FOR SYSIO ! 3562: TRSI$ EQU TRFNC+1 NUMBER OF WORDS IN TRBLK ! 3563: * ! 3564: TRTIN EQU 0 TRACE TYPE FOR INPUT ASSOCIATION ! 3565: TRTAC EQU TRTIN+1 TRACE TYPE FOR ACCESS TRACE ! 3566: TRTVL EQU TRTAC+1 TRACE TYPE FOR VALUE TRACE ! 3567: TRTOU EQU TRTVL+1 TRACE TYPE FOR OUTPUT ASSOCIATION ! 3568: TRTFC EQU TRTOU+1 TRACE TYPE FOR FCBLK IDENTIFICATION ! 3569: EJC ! 3570: * ! 3571: * TRAP BLOCK (CONTINUED) ! 3572: * ! 3573: * VARIABLE INPUT ASSOCIATION ! 3574: * ! 3575: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK ! 3576: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE ! 3577: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS ! 3578: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK. ! 3579: * ! 3580: * TRTYP IS SET TO TRTIN ! 3581: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL ! 3582: * TRTER IS A POINTER TO SVBLK IF ASSOCIATION IS ! 3583: * FOR INPUT, TERMINAL, ELSE IT IS NULL. ! 3584: * TRTRF POINTS TO THE TRAP BLOCK WHICH IN TURN POINTS ! 3585: * TO AN FCBLK USED FOR I/O ASSOCIATION. ! 3586: * TRFPT IS THE FCBLK PTR RETURNED BY SYSIO. ! 3587: * ! 3588: * VARIABLE ACCESS TRACE ASSOCIATION ! 3589: * ! 3590: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK ! 3591: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE ! 3592: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS ! 3593: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK. ! 3594: * ! 3595: * TRTYP IS SET TO TRTAC ! 3596: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL ! 3597: * TRTAG IS THE TRACE TAG (0 IF NONE) ! 3598: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 3599: * ! 3600: * VARIABLE VALUE TRACE ASSOCIATION ! 3601: * ! 3602: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK ! 3603: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE ! 3604: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS ! 3605: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK. ! 3606: * ! 3607: * TRTYP IS SET TO TRTVL ! 3608: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL ! 3609: * TRTAG IS THE TRACE TAG (0 IF NONE) ! 3610: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 3611: EJC ! 3612: * TRAP BLOCK (CONTINUED) ! 3613: * ! 3614: * VARIABLE OUTPUT ASSOCIATION ! 3615: * ! 3616: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK ! 3617: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE ! 3618: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS ! 3619: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK. ! 3620: * ! 3621: * TRTYP IS SET TO TRTOU ! 3622: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL ! 3623: * TRTER IS A POINTER TO SVBLK IF ASSOCIATION IS ! 3624: * FOR OUTPUT, TERMINAL, ELSE IT IS NULL. ! 3625: * TRTRF POINTS TO THE TRAP BLOCK WHICH IN TURN POINTS ! 3626: * TO AN FCBLK USED FOR I/O ASSOCIATION. ! 3627: * TRFPT IS THE FCBLK PTR RETURNED BY SYSIO. ! 3628: * ! 3629: * FUNCTION CALL TRACE ! 3630: * ! 3631: * THE PFCTR FIELD OF THE CORRESPONDING PFBLK IS SET ! 3632: * TO POINT TO A TRBLK. ! 3633: * ! 3634: * TRTYP IS SET TO TRTIN ! 3635: * TRNXT IS ZERO ! 3636: * TRTAG IS THE TRACE TAG (0 IF NONE) ! 3637: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 3638: * ! 3639: * FUNCTION RETURN TRACE ! 3640: * ! 3641: * THE PFRTR FIELD OF THE CORRESPONDING PFBLK IS SET ! 3642: * TO POINT TO A TRBLK ! 3643: * ! 3644: * TRTYP IS SET TO TRTIN ! 3645: * TRNXT IS ZERO ! 3646: * TRTAG IS THE TRACE TAG (0 IF NONE) ! 3647: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 3648: * ! 3649: * LABEL TRACE ! 3650: * ! 3651: * THE VRLBL OF THE VRBLK FOR THE LABEL IS ! 3652: * CHANGED TO POINT TO A TRBLK AND THE VRTRA FIELD IS ! 3653: * SET TO B$VRT TO ACTIVATE THE CHECK. ! 3654: * ! 3655: * TRTYP IS SET TO TRTIN ! 3656: * TRLBL POINTS TO THE ACTUAL LABEL (CDBLK) VALUE ! 3657: * TRTAG IS THE TRACE TAG (0 IF NONE) ! 3658: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 3659: EJC ! 3660: * ! 3661: * TRAP BLOCK (CONTINUED) ! 3662: * ! 3663: * KEYWORD TRACE ! 3664: * ! 3665: * KEYWORDS WHICH CAN BE TRACED POSSESS A UNIQUE ! 3666: * LOCATION WHICH IS ZERO IF THERE IS NO TRACE AND ! 3667: * POINTS TO A TRBLK IF THERE IS A TRACE. THE LOCATIONS ! 3668: * ARE AS FOLLOWS. ! 3669: * ! 3670: * R$ERT ERRTYPE ! 3671: * R$FNC FNCLEVEL ! 3672: * R$STC STCOUNT ! 3673: * ! 3674: * THE FORMAT OF THE TRBLK IS AS FOLLOWS. ! 3675: * ! 3676: * TRTYP IS SET TO TRTIN ! 3677: * TRKVR IS A POINTER TO THE VRBLK FOR THE KEYWORD ! 3678: * TRTAG IS THE TRACE TAG (0 IF NONE) ! 3679: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 3680: * ! 3681: * INPUT/OUTPUT FILE ARG1 TRAP BLOCK ! 3682: * ! 3683: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK ! 3684: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE OF ! 3685: * A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS ! 3686: * CONTAIN =B$VRA AND =B$VRV. THIS TRAP BLOCK IS USED ! 3687: * TO HOLD A POINTER TO THE FCBLK WHICH AN ! 3688: * IMPLEMENTATION MAY REQUEST TO HOLD INFORMATION ! 3689: * ABOUT A FILE. ! 3690: * ! 3691: * TRTYP IS SET TO TRTFC ! 3692: * TRNEXT POINTS TO NEXT TRBLK OR TRVAL IS VARIABLE VAL ! 3693: * TRFNM IS 0 ! 3694: * TRFPT IS THE FCBLK POINTER. ! 3695: * ! 3696: * NOTE THAT WHEN MULTIPLE TRAPS ARE SET ON A VARIABLE ! 3697: * THE ORDER IS IN ASCENDING VALUE OF TRTYP FIELD. ! 3698: * ! 3699: * INPUT ASSOCIATION (IF PRESENT) ! 3700: * ACCESS TRACE (IF PRESENT) ! 3701: * VALUE TRACE (IF PRESENT) ! 3702: * OUTPUT ASSOCIATION (IF PRESENT) ! 3703: * ! 3704: * THE ACTUAL VALUE OF THE VARIABLE IS STORED IN THE TRVAL ! 3705: * FIELD OF THE LAST TRBLK ON THE CHAIN. ! 3706: * ! 3707: * THIS IMPLEMENTATION DOES NOT PERMIT TRACE OR I/O ! 3708: * ASSOCIATIONS TO ANY OF THE PSEUDO-VARIABLES. ! 3709: EJC ! 3710: * ! 3711: * VECTOR BLOCK (VCBLK) ! 3712: * ! 3713: * A VCBLK IS USED TO REPRESENT AN ARRAY VALUE WHICH HAS ! 3714: * ONE DIMENSION WHOSE LOWER BOUND IS ONE. ALL OTHER ARRAYS ! 3715: * ARE REPRESENTED BY ARBLKS. A VCBLK IS CREATED BY THE ! 3716: * SYSTEM FUNCTION ARRAY (S$ARR) WHEN PASSED AN INTEGER ARG. ! 3717: * ! 3718: * +------------------------------------+ ! 3719: * I VCTYP I ! 3720: * +------------------------------------+ ! 3721: * I IDVAL I ! 3722: * +------------------------------------+ ! 3723: * I VCLEN I ! 3724: * +------------------------------------+ ! 3725: * I VCVLS I ! 3726: * +------------------------------------+ ! 3727: * ! 3728: VCTYP EQU 0 POINTER TO DUMMY ROUTINE B$VCT ! 3729: VCLEN EQU OFFS2 LENGTH OF VCBLK IN BYTES ! 3730: VCVLS EQU OFFS3 START OF VECTOR VALUES ! 3731: VCSI$ EQU VCVLS SIZE OF STANDARD FIELDS IN VCBLK ! 3732: VCVLB EQU VCVLS-1 OFFSET ONE WORD BEHIND VCVLS ! 3733: VCTBD EQU TBSI$-VCSI$ DIFFERENCE IN SIZES - SEE PRTVL ! 3734: * ! 3735: * VCVLS ARE EITHER DATA POINTERS OR TRBLK POINTERS ! 3736: * ! 3737: * THE DIMENSION CAN BE DEDUCED FROM VCLEN. ! 3738: EJC ! 3739: * ! 3740: * VARIABLE BLOCK (VRBLK) ! 3741: * ! 3742: * A VARIABLE BLOCK IS BUILT IN THE STATIC MEMORY AREA ! 3743: * FOR EVERY VARIABLE REFERENCED OR CREATED BY A PROGRAM. ! 3744: * ! 3745: * NOTE THAT SINCE THESE BLOCKS ONLY OCCUR IN THE STATIC ! 3746: * REGION, IT IS PERMISSIBLE TO POINT TO ANY WORD IN ! 3747: * THE BLOCK AND THIS IS USED TO PROVIDE THREE DISTINCT ! 3748: * ACCESS POINTS FROM THE GENERATED CODE AS FOLLOWS. ! 3749: * ! 3750: * 1) POINT TO VRGET (FIRST WORD OF VRBLK) TO LOAD THE ! 3751: * VALUE OF THE VARIABLE ONTO THE MAIN STACK. ! 3752: * ! 3753: * 2) POINT TO VRSTO (SECOND WORD OF VRBLK) TO STORE THE ! 3754: * TOP STACK ELEMENT AS THE VALUE OF THE VARIABLE. ! 3755: * ! 3756: * 3) POINT TO VRTRA (FOURTH WORD OF VRBLK) TO JUMP TO ! 3757: * THE LABEL ASSOCIATED WITH THE VARIABLE NAME. ! 3758: * ! 3759: * +------------------------------------+ ! 3760: * I VRGET I ! 3761: * +------------------------------------+ ! 3762: * I VRSTO I ! 3763: * +------------------------------------+ ! 3764: * I VRVAL I ! 3765: * +------------------------------------+ ! 3766: * I VRTRA I ! 3767: * +------------------------------------+ ! 3768: * I VRLBL I ! 3769: * +------------------------------------+ ! 3770: * I VRFNC I ! 3771: * +------------------------------------+ ! 3772: * I VRNXT I ! 3773: * +------------------------------------+ ! 3774: * I VRLEN I ! 3775: * +------------------------------------+ ! 3776: * / / ! 3777: * / VRCHS = VRSVP / ! 3778: * / / ! 3779: * +------------------------------------+ ! 3780: EJC ! 3781: * ! 3782: * VARIABLE BLOCK (CONTINUED) ! 3783: * ! 3784: VRGET EQU 0 POINTER TO ROUTINE TO LOAD VALUE ! 3785: VRSTO EQU VRGET+1 POINTER TO ROUTINE TO STORE VALUE ! 3786: VRVAL EQU VRSTO+1 VARIABLE VALUE ! 3787: VRVLO EQU VRVAL-VRSTO OFFSET TO VALUE FROM STORE FIELD ! 3788: VRTRA EQU VRVAL+1 POINTER TO ROUTINE TO JUMP TO LABEL ! 3789: VRLBL EQU VRTRA+1 POINTER TO CODE FOR LABEL ! 3790: VRLBO EQU VRLBL-VRTRA OFFSET TO LABEL FROM TRANSFER FIELD ! 3791: VRFNC EQU VRLBL+1 POINTER TO FUNCTION BLOCK ! 3792: VRNXT EQU VRFNC+1 POINTER TO NEXT VRBLK ON HASH CHAIN ! 3793: VRLEN EQU VRNXT+1 LENGTH OF NAME (OR ZERO) ! 3794: VRCHS EQU VRLEN+1 CHARACTERS OF NAME (VRLEN GT 0) ! 3795: VRSVP EQU VRLEN+1 PTR TO SVBLK (VRLEN EQ 0) ! 3796: VRSI$ EQU VRCHS+1 NUMBER OF STANDARD FIELDS IN VRBLK ! 3797: VRSOF EQU VRLEN-SCLEN OFFSET TO DUMMY SCBLK FOR NAME ! 3798: VRSVO EQU VRSVP-VRSOF PSEUDO-OFFSET TO VRSVP FIELD ! 3799: * ! 3800: * VRGET = B$VRL IF NOT INPUT ASSOCIATED OR ACCESS TRACED ! 3801: * VRGET = B$VRA IF INPUT ASSOCIATED OR ACCESS TRACED ! 3802: * ! 3803: * VRSTO = B$VRS IF NOT OUTPUT ASSOCIATED OR VALUE TRACED ! 3804: * VRSTO = B$VRV IF OUTPUT ASSOCIATED OR VALUE TRACED ! 3805: * VRSTO = B$VRE IF VALUE IS PROTECTED PATTERN VALUE ! 3806: * ! 3807: * VRVAL POINTS TO THE APPROPRIATE VALUE UNLESS THE ! 3808: * VARIABLE IS I/O/TRACE ASSOCIATED IN WHICH CASE, VRVAL ! 3809: * POINTS TO AN APPROPRIATE TRBLK (TRAP BLOCK) CHAIN. ! 3810: * ! 3811: * VRTRA = B$VRG IF THE LABEL IS NOT TRACED ! 3812: * VRTRA = B$VRT IF THE LABEL IS TRACED ! 3813: * ! 3814: * VRLBL POINTS TO A CDBLK IF THERE IS A LABEL ! 3815: * VRLBL POINTS TO THE SVBLK SVLBL FIELD FOR A SYSTEM LABEL ! 3816: * VRLBL POINTS TO STNDL FOR AN UNDEFINED LABEL ! 3817: * VRLBL POINTS TO A TRBLK IF THE LABEL IS TRACED ! 3818: * ! 3819: * VRFNC POINTS TO A FFBLK FOR A FIELD FUNCTION ! 3820: * VRFNC POINTS TO A DFBLK FOR A DATATYPE FUNCTION ! 3821: * VRFNC POINTS TO A PFBLK FOR A PROGRAM DEFINED FUNCTION ! 3822: * VRFNC POINTS TO A EFBLK FOR AN EXTERNAL LOADED FUNCTION ! 3823: * VRFNC POINTS TO SVFNC (SVBLK) FOR A SYSTEM FUNCTION ! 3824: * VRFNC POINTS TO STNDF IF THE FUNCTION IS UNDEFINED ! 3825: * ! 3826: * VRNXT POINTS TO THE NEXT VRBLK ON THIS CHAIN UNLESS ! 3827: * THIS IS THE END OF THE CHAIN IN WHICH CASE IT IS ZERO. ! 3828: * ! 3829: * VRLEN IS THE NAME LENGTH FOR A NON-SYSTEM VARIABLE. ! 3830: * VRLEN IS ZERO FOR A SYSTEM VARIABLE. ! 3831: * ! 3832: * VRCHS IS THE NAME (LJRZ) IF VRLEN IS NON-ZERO. ! 3833: * VRSVP IS A PTR TO THE SVBLK IF VRLEN IS ZERO. ! 3834: EJC ! 3835: * ! 3836: * FORMAT OF A NON-RELOCATABLE EXTERNAL BLOCK (XNBLK) ! 3837: * ! 3838: * AN XNBLK IS A BLOCK REPRESENTING AN UNKNOWN (EXTERNAL) ! 3839: * DATA VALUE. THE BLOCK CONTAINS NO POINTERS TO OTHER ! 3840: * RELOCATABLE BLOCKS. AN XNBLK IS USED BY EXTERNAL FUNCTION ! 3841: * PROCESSING OR POSSIBLY FOR SYSTEM I/O ROUTINES ETC. ! 3842: * THE MACRO-SYSTEM ITSELF DOES NOT USE XNBLKS. ! 3843: * THIS TYPE OF BLOCK MAY BE USED AS A FILE CONTROL BLOCK. ! 3844: * SEE SYSFC,SYSIN,SYSOU,S$INP,S$OUP FOR DETAILS. ! 3845: * ! 3846: * +------------------------------------+ ! 3847: * I XNTYP I ! 3848: * +------------------------------------+ ! 3849: * I XNLEN I ! 3850: * +------------------------------------+ ! 3851: * / / ! 3852: * / XNDTA / ! 3853: * / / ! 3854: * +------------------------------------+ ! 3855: * ! 3856: XNTYP EQU 0 POINTER TO DUMMY ROUTINE B$XNT ! 3857: XNLEN EQU XNTYP+1 LENGTH OF XNBLK IN BYTES ! 3858: XNDTA EQU XNLEN+1 DATA WORDS ! 3859: XNSI$ EQU XNDTA SIZE OF STANDARD FIELDS IN XNBLK ! 3860: * ! 3861: * NOTE THAT THE TERM NON-RELOCATABLE REFERS TO THE CONTENTS ! 3862: * AND NOT THE BLOCK ITSELF. AN XNBLK CAN BE MOVED AROUND IF ! 3863: * IT IS BUILT IN THE DYNAMIC MEMORY AREA. ! 3864: EJC ! 3865: * ! 3866: * RELOCATABLE EXTERNAL BLOCK (XRBLK) ! 3867: * ! 3868: * AN XRBLK IS A BLOCK REPRESENTING AN UNKNOWN (EXTERNAL) ! 3869: * DATA VALUE. THE DATA AREA IN THIS BLOCK CONSISTS ONLY ! 3870: * OF ADDRESS VALUES AND ANY ADDRESSES POINTING INTO THE ! 3871: * DYNAMIC MEMORY AREA MUST POINT TO THE START OF OTHER ! 3872: * DATA BLOCKS. SEE ALSO DESCRIPTION OF XNBLK. ! 3873: * THIS TYPE OF BLOCK MAY BE USED AS A FILE CONTROL BLOCK. ! 3874: * SEE SYSFC,SYSIN,SYSOU,S$INP,S$OUP FOR DETAILS. ! 3875: * ! 3876: * +------------------------------------+ ! 3877: * I XRTYP I ! 3878: * +------------------------------------+ ! 3879: * I XRLEN I ! 3880: * +------------------------------------+ ! 3881: * / / ! 3882: * / XRPTR / ! 3883: * / / ! 3884: * +------------------------------------+ ! 3885: * ! 3886: XRTYP EQU 0 POINTER TO DUMMY ROUTINE B$XRT ! 3887: XRLEN EQU XRTYP+1 LENGTH OF XRBLK IN BYTES ! 3888: XRPTR EQU XRLEN+1 START OF ADDRESS POINTERS ! 3889: XRSI$ EQU XRPTR SIZE OF STANDARD FIELDS IN XRBLK ! 3890: EJC ! 3891: * ! 3892: * S$CNV (CONVERT) FUNCTION SWITCH CONSTANTS. THE VALUES ! 3893: * ARE TIED TO THE ORDER OF THE ENTRIES IN THE SVCTB TABLE ! 3894: * AND HENCE TO THE BRANCH TABLE IN S$CNV. ! 3895: * ! 3896: CNVST EQU 8 MAX STANDARD TYPE CODE FOR CONVERT ! 3897: .IF .CNRA ! 3898: CNVRT EQU CNVST NO REALS - SAME AS STANDARD TYPES ! 3899: .ELSE ! 3900: CNVRT EQU CNVST+1 CONVERT CODE FOR REALS ! 3901: .FI ! 3902: .IF .CNBF ! 3903: CNVBT EQU CNVRT NO BUFFERS - SAME AS REAL CODE ! 3904: .ELSE ! 3905: CNVBT EQU CNVRT+1 CONVERT CODE FOR BUFFER ! 3906: .FI ! 3907: CNVTT EQU CNVBT+1 BSW CODE FOR CONVERT ! 3908: * ! 3909: * INPUT IMAGE LENGTH ! 3910: * ! 3911: INILN EQU 132 DEFAULT IMAGE LENGTH FOR COMPILER ! 3912: INILS EQU 80 IMAGE LENGTH IF -SEQU IN EFFECT ! 3913: * ! 3914: IONMB EQU 2 NAME BASE USED FOR IOCHN IN SYSIO ! 3915: IONMO EQU 4 NAME OFFSET USED FOR IOCHN IN SYSIO ! 3916: * ! 3917: * IN GENERAL, MEANINGFUL MNEMONICS SHOULD BE USED FOR ! 3918: * OFFSETS. HOWEVER FOR SMALL INTEGERS USED OFTEN IN ! 3919: * LITERALS THE FOLLOWING GENERAL DEFINITIONS ARE PROVIDED. ! 3920: * ! 3921: NUM01 EQU 1 ! 3922: NUM02 EQU 2 ! 3923: NUM03 EQU 3 ! 3924: NUM04 EQU 4 ! 3925: NUM05 EQU 5 ! 3926: NUM06 EQU 6 ! 3927: NUM07 EQU 7 ! 3928: NUM08 EQU 8 ! 3929: NUM09 EQU 9 ! 3930: NUM10 EQU 10 ! 3931: NINI8 EQU 998 ! 3932: NINI9 EQU 999 ! 3933: THSND EQU 1000 ! 3934: EJC ! 3935: * ! 3936: * NUMBERS OF UNDEFINED SPITBOL OPERATORS ! 3937: * ! 3938: OPBUN EQU 5 NO. OF BINARY UNDEFINED OPS ! 3939: OPUUN EQU 6 NO OF UNARY UNDEFINED OPS ! 3940: * ! 3941: * OFFSETS USED IN PRTSN, PRTMI AND ACESS ! 3942: * ! 3943: PRSNF EQU 13 OFFSET USED IN PRTSN ! 3944: PRTMF EQU 15 OFFSET TO COL 15 (PRTMI) ! 3945: RILEN EQU 120 BUFFER LENGTH FOR SYSRI ! 3946: * ! 3947: * CODES FOR STAGES OF PROCESSING ! 3948: * ! 3949: STGIC EQU 0 INITIAL COMPILE ! 3950: STGXC EQU STGIC+1 EXECUTION COMPILE (CODE) ! 3951: STGEV EQU STGXC+1 EXPRESSION EVAL DURING EXECUTION ! 3952: STGXT EQU STGEV+1 EXECUTION TIME ! 3953: STGCE EQU STGXT+1 INITIAL COMPILE AFTER END LINE ! 3954: STGXE EQU STGCE+1 EXEC. COMPILE AFTER END LINE ! 3955: STGND EQU STGCE-STGIC DIFFERENCE IN STAGE AFTER END ! 3956: STGEE EQU STGXE+1 EVAL EVALUATING EXPRESSION ! 3957: STGNO EQU STGEE+1 NUMBER OF CODES ! 3958: EJC ! 3959: * ! 3960: * ! 3961: * STATEMENT NUMBER PAD COUNT FOR LISTR ! 3962: * ! 3963: .DEF .CSN5 ! 3964: .IF .CSN6 ! 3965: STNPD EQU 6 STATEMENT NO. PAD COUNT ! 3966: .UNDEF .CSN5 ! 3967: .FI ! 3968: .IF .CSN8 ! 3969: STNPD EQU 8 STATEMENT NO. PAD COUNT ! 3970: .UNDEF .CSN5 ! 3971: .FI ! 3972: .IF .CSN5 ! 3973: STNPD EQU 5 STATEMENT NO. PAD COUNT ! 3974: .FI ! 3975: * ! 3976: * SYNTAX TYPE CODES ! 3977: * ! 3978: * THESE CODES ARE RETURNED FROM THE SCANE PROCEDURE. ! 3979: * ! 3980: * THEY ARE SPACED 3 APART FOR THE BENEFIT OF EXPAN. ! 3981: * ! 3982: T$UOP EQU 0 UNARY OPERATOR ! 3983: T$LPR EQU T$UOP+3 LEFT PAREN ! 3984: T$LBR EQU T$LPR+3 LEFT BRACKET ! 3985: T$CMA EQU T$LBR+3 COMMA ! 3986: T$FNC EQU T$CMA+3 FUNCTION CALL ! 3987: T$VAR EQU T$FNC+3 VARIABLE ! 3988: T$CON EQU T$VAR+3 CONSTANT ! 3989: T$BOP EQU T$CON+3 BINARY OPERATOR ! 3990: T$RPR EQU T$BOP+3 RIGHT PAREN ! 3991: T$RBR EQU T$RPR+3 RIGHT BRACKET ! 3992: T$COL EQU T$RBR+3 COLON ! 3993: T$SMC EQU T$COL+3 SEMI-COLON ! 3994: * ! 3995: * THE FOLLOWING DEFINITIONS ARE USED ONLY IN THE GOTO FIELD ! 3996: * ! 3997: T$FGO EQU T$SMC+1 FAILURE GOTO ! 3998: T$SGO EQU T$FGO+1 SUCCESS GOTO ! 3999: * ! 4000: * THE ABOVE CODES ARE GROUPED SO THAT CODES FOR ELEMENTS ! 4001: * WHICH CAN LEGITIMATELY IMMEDIATELY PRECEDE A UNARY ! 4002: * OPERATOR COME FIRST TO FACILITATE OPERATOR SYNTAX CHECK. ! 4003: * ! 4004: T$UOK EQU T$FNC LAST CODE OK BEFORE UNARY OPERATOR ! 4005: EJC ! 4006: * ! 4007: * DEFINITIONS OF VALUES FOR EXPAN JUMP TABLE ! 4008: * ! 4009: T$UO0 EQU T$UOP+0 UNARY OPERATOR, STATE ZERO ! 4010: T$UO1 EQU T$UOP+1 UNARY OPERATOR, STATE ONE ! 4011: T$UO2 EQU T$UOP+2 UNARY OPERATOR, STATE TWO ! 4012: T$LP0 EQU T$LPR+0 LEFT PAREN, STATE ZERO ! 4013: T$LP1 EQU T$LPR+1 LEFT PAREN, STATE ONE ! 4014: T$LP2 EQU T$LPR+2 LEFT PAREN, STATE TWO ! 4015: T$LB0 EQU T$LBR+0 LEFT BRACKET, STATE ZERO ! 4016: T$LB1 EQU T$LBR+1 LEFT BRACKET, STATE ONE ! 4017: T$LB2 EQU T$LBR+2 LEFT BRACKET, STATE TWO ! 4018: T$CM0 EQU T$CMA+0 COMMA, STATE ZERO ! 4019: T$CM1 EQU T$CMA+1 COMMA, STATE ONE ! 4020: T$CM2 EQU T$CMA+2 COMMA, STATE TWO ! 4021: T$FN0 EQU T$FNC+0 FUNCTION CALL, STATE ZERO ! 4022: T$FN1 EQU T$FNC+1 FUNCTION CALL, STATE ONE ! 4023: T$FN2 EQU T$FNC+2 FUNCTION CALL, STATE TWO ! 4024: T$VA0 EQU T$VAR+0 VARIABLE, STATE ZERO ! 4025: T$VA1 EQU T$VAR+1 VARIABLE, STATE ONE ! 4026: T$VA2 EQU T$VAR+2 VARIABLE, STATE TWO ! 4027: T$CO0 EQU T$CON+0 CONSTANT, STATE ZERO ! 4028: T$CO1 EQU T$CON+1 CONSTANT, STATE ONE ! 4029: T$CO2 EQU T$CON+2 CONSTANT, STATE TWO ! 4030: T$BO0 EQU T$BOP+0 BINARY OPERATOR, STATE ZERO ! 4031: T$BO1 EQU T$BOP+1 BINARY OPERATOR, STATE ONE ! 4032: T$BO2 EQU T$BOP+2 BINARY OPERATOR, STATE TWO ! 4033: T$RP0 EQU T$RPR+0 RIGHT PAREN, STATE ZERO ! 4034: T$RP1 EQU T$RPR+1 RIGHT PAREN, STATE ONE ! 4035: T$RP2 EQU T$RPR+2 RIGHT PAREN, STATE TWO ! 4036: T$RB0 EQU T$RBR+0 RIGHT BRACKET, STATE ZERO ! 4037: T$RB1 EQU T$RBR+1 RIGHT BRACKET, STATE ONE ! 4038: T$RB2 EQU T$RBR+2 RIGHT BRACKET, STATE TWO ! 4039: T$CL0 EQU T$COL+0 COLON, STATE ZERO ! 4040: T$CL1 EQU T$COL+1 COLON, STATE ONE ! 4041: T$CL2 EQU T$COL+2 COLON, STATE TWO ! 4042: T$SM0 EQU T$SMC+0 SEMICOLON, STATE ZERO ! 4043: T$SM1 EQU T$SMC+1 SEMICOLON, STATE ONE ! 4044: T$SM2 EQU T$SMC+2 SEMICOLON, STATE TWO ! 4045: * ! 4046: T$NES EQU T$SM2+1 NUMBER OF ENTRIES IN BRANCH TABLE ! 4047: EJC ! 4048: * ! 4049: * DEFINITION OF OFFSETS USED IN CONTROL CARD PROCESSING ! 4050: * ! 4051: .IF .CULC ! 4052: CC$CA EQU 0 -CASE ! 4053: CC$DO EQU CC$CA+1 -DOUBLE ! 4054: .ELSE ! 4055: CC$DO EQU 0 -DOUBLE ! 4056: .FI ! 4057: CC$DU EQU CC$DO+1 -DUMP ! 4058: CC$EJ EQU CC$DU+1 -EJECT ! 4059: CC$ER EQU CC$EJ+1 -ERRORS ! 4060: CC$EX EQU CC$ER+1 -EXECUTE ! 4061: CC$FA EQU CC$EX+1 -FAIL ! 4062: CC$LI EQU CC$FA+1 -LIST ! 4063: CC$NR EQU CC$LI+1 -NOERRORS ! 4064: CC$NX EQU CC$NR+1 -NOEXECUTE ! 4065: CC$NF EQU CC$NX+1 -NOFAIL ! 4066: CC$NL EQU CC$NF+1 -NOLIST ! 4067: CC$NO EQU CC$NL+1 -NOOPT ! 4068: CC$NP EQU CC$NO+1 -NOPRINT ! 4069: CC$OP EQU CC$NP+1 -OPTIMISE ! 4070: CC$PR EQU CC$OP+1 -PRINT ! 4071: CC$SI EQU CC$PR+1 -SINGLE ! 4072: CC$SP EQU CC$SI+1 -SPACE ! 4073: CC$ST EQU CC$SP+1 -STITL ! 4074: CC$TI EQU CC$ST+1 -TITLE ! 4075: CC$TR EQU CC$TI+1 -TRACE ! 4076: CC$NC EQU CC$TR+1 NUMBER OF CONTROL CARDS ! 4077: CCNOC EQU 4 NO. OF CHARS INCLUDED IN MATCH ! 4078: CCOFS EQU 7 OFFSET TO START OF TITLE/SUBTITLE ! 4079: EJC ! 4080: * ! 4081: * DEFINITIONS OF STACK OFFSETS USED IN CMPIL PROCEDURE ! 4082: * ! 4083: * SEE DESCRIPTION AT START OF CMPIL PROCEDURE FOR DETAILS ! 4084: * OF USE OF THESE LOCATIONS ON THE STACK. ! 4085: * ! 4086: CMSTM EQU 0 TREE FOR STATEMENT BODY ! 4087: CMSGO EQU CMSTM+1 TREE FOR SUCCESS GOTO ! 4088: CMFGO EQU CMSGO+1 TREE FOR FAIL GOTO ! 4089: CMCGO EQU CMFGO+1 CONDITIONAL GOTO FLAG ! 4090: CMPCD EQU CMCGO+1 PREVIOUS CDBLK POINTER ! 4091: CMFFP EQU CMPCD+1 FAILURE FILL IN FLAG FOR PREVIOUS ! 4092: CMFFC EQU CMFFP+1 FAILURE FILL IN FLAG FOR CURRENT ! 4093: CMSOP EQU CMFFC+1 SUCCESS FILL IN OFFSET FOR PREVIOUS ! 4094: CMSOC EQU CMSOP+1 SUCCESS FILL IN OFFSET FOR CURRENT ! 4095: CMLBL EQU CMSOC+1 PTR TO VRBLK FOR CURRENT LABEL ! 4096: CMTRA EQU CMLBL+1 PTR TO ENTRY CDBLK ! 4097: * ! 4098: CMNEN EQU CMTRA+1 COUNT OF STACK ENTRIES FOR CMPIL ! 4099: .IF .CNPF ! 4100: .ELSE ! 4101: * ! 4102: * A FEW CONSTANTS USED BY THE PROFILER ! 4103: PFPD1 EQU 8 PAD POSITIONS ... ! 4104: PFPD2 EQU 20 ... FOR PROFILE ... ! 4105: PFPD3 EQU 32 ... PRINTOUT ! 4106: PF$I2 EQU CFP$I+CFP$I SIZE OF TABLE ENTRY (2 INTS) ! 4107: .FI ! 4108: * ! 4109: TTL S P I T B O L -- CONSTANT SECTION ! 4110: * ! 4111: * THIS SECTION CONSISTS ENTIRELY OF ASSEMBLED CONSTANTS. ! 4112: * ! 4113: * ALL LABEL NAMES ARE FIVE LETTERS. THE ORDER IS ! 4114: * APPROXIMATELY ALPHABETICAL, BUT IN SOME CASES (ALWAYS ! 4115: * DOCUMENTED), CONSTANTS MUST BE PLACED IN SOME SPECIAL ! 4116: * ORDER WHICH MUST NOT BE DISTURBED. ! 4117: * ! 4118: * IT MUST ALSO BE REMEMBERED THAT THERE IS A REQUIREMENT ! 4119: * FOR NO FORWARD REFERENCES WHICH ALSO DISTURBS THE ! 4120: * ALPHABETICAL ORDER IN SOME CASES. ! 4121: * ! 4122: SEC START OF CONSTANT SECTION ! 4123: * ! 4124: * FREE STORE PERCENTAGE (USED BY ALLOC) ! 4125: * ! 4126: ALFSP DAC E$FSP FREE STORE PERCENTAGE ! 4127: * ! 4128: * BIT CONSTANTS FOR GENERAL USE ! 4129: * ! 4130: BITS0 DBC 0 ALL ZERO BITS ! 4131: BITS1 DBC 1 ONE BIT IN LOW ORDER POSITION ! 4132: BITS2 DBC 2 BIT IN POSITION 2 ! 4133: BITS3 DBC 4 BIT IN POSITION 3 ! 4134: BITS4 DBC 8 BIT IN POSITION 4 ! 4135: BITS5 DBC 16 BIT IN POSITION 5 ! 4136: BITS6 DBC 32 BIT IN POSITION 6 ! 4137: BITS7 DBC 64 BIT IN POSITION 7 ! 4138: BITS8 DBC 128 BIT IN POSITION 8 ! 4139: BITS9 DBC 256 BIT IN POSITION 9 ! 4140: BIT10 DBC 512 BIT IN POSITION 10 ! 4141: BITSM DBC CFP$M MASK FOR MAX INTEGER ! 4142: * ! 4143: * BIT CONSTANTS FOR SVBLK (SVBIT FIELD) TESTS ! 4144: * ! 4145: BTFNC DBC SVFNC BIT TO TEST FOR FUNCTION ! 4146: BTKNM DBC SVKNM BIT TO TEST FOR KEYWORD NUMBER ! 4147: BTLBL DBC SVLBL BIT TO TEST FOR LABEL ! 4148: BTFFC DBC SVFFC BIT TO TEST FOR FAST CALL ! 4149: BTCKW DBC SVCKW BIT TO TEST FOR CONSTANT KEYWORD ! 4150: BTPRD DBC SVPRD BIT TO TEST FOR PREDICATE FUNCTION ! 4151: BTPRE DBC SVPRE BIT TO TEST FOR PREEVALUATION ! 4152: BTVAL DBC SVVAL BIT TO TEST FOR VALUE ! 4153: EJC ! 4154: * ! 4155: * LIST OF NAMES USED FOR CONTROL CARD PROCESSING ! 4156: * ! 4157: .IF .CULC ! 4158: CCNMS DTC /CASE/ ! 4159: DTC /DOUB/ ! 4160: .ELSE ! 4161: CCNMS DTC /DOUB/ ! 4162: .FI ! 4163: DTC /DUMP/ ! 4164: DTC /EJEC/ ! 4165: DTC /ERRO/ ! 4166: DTC /EXEC/ ! 4167: DTC /FAIL/ ! 4168: DTC /LIST/ ! 4169: DTC /NOER/ ! 4170: DTC /NOEX/ ! 4171: DTC /NOFA/ ! 4172: DTC /NOLI/ ! 4173: DTC /NOOP/ ! 4174: DTC /NOPR/ ! 4175: DTC /OPTI/ ! 4176: DTC /PRIN/ ! 4177: DTC /SING/ ! 4178: DTC /SPAC/ ! 4179: DTC /STIT/ ! 4180: DTC /TITL/ ! 4181: DTC /TRAC/ ! 4182: * ! 4183: * HEADER MESSAGES FOR DUMPR PROCEDURE (SCBLK FORMAT) ! 4184: * ! 4185: DMHDK DAC B$SCL DUMP OF KEYWORD VALUES ! 4186: DAC 22 ! 4187: DTC /DUMP OF KEYWORD VALUES/ ! 4188: * ! 4189: DMHDV DAC B$SCL DUMP OF NATURAL VARIABLES ! 4190: DAC 25 ! 4191: DTC /DUMP OF NATURAL VARIABLES/ ! 4192: EJC ! 4193: * ! 4194: * MESSAGE TEXT FOR COMPILATION STATISTICS ! 4195: * ! 4196: ENCM1 DAC B$SCL ! 4197: DAC 10 ! 4198: DTC /STORE USED/ ! 4199: * ! 4200: ENCM2 DAC B$SCL ! 4201: DAC 10 ! 4202: DTC /STORE LEFT/ ! 4203: * ! 4204: ENCM3 DAC B$SCL ! 4205: DAC 11 ! 4206: DTC /COMP ERRORS/ ! 4207: * ! 4208: ENCM4 DAC B$SCL ! 4209: DAC 14 ! 4210: DTC /COMP TIME-MSEC/ ! 4211: * ! 4212: ENCM5 DAC B$SCL EXECUTION SUPPRESSED ! 4213: DAC 20 ! 4214: DTC /EXECUTION SUPPRESSED/ ! 4215: * ! 4216: * STRING CONSTANT FOR ABNORMAL END ! 4217: * ! 4218: ENDAB DAC B$SCL ! 4219: DAC 12 ! 4220: DTC /ABNORMAL END/ ! 4221: EJC ! 4222: * ! 4223: * MEMORY OVERFLOW DURING INITIALISATION ! 4224: * ! 4225: ENDMO DAC B$SCL ! 4226: ENDML DAC 15 ! 4227: DTC /MEMORY OVERFLOW/ ! 4228: * ! 4229: * STRING CONSTANT FOR MESSAGE ISSUED BY L$END ! 4230: * ! 4231: ENDMS DAC B$SCL ! 4232: DAC 10 ! 4233: DTC /NORMAL END/ ! 4234: * ! 4235: * FAIL MESSAGE FOR STACK FAIL SECTION ! 4236: * ! 4237: ENDSO DAC B$SCL STACK OVERFLOW IN GARBAGE COLLECTOR ! 4238: DAC 36 ! 4239: DTC /STACK OVERFLOW IN GARBAGE COLLECTION/ ! 4240: * ! 4241: * STRING CONSTANT FOR TIME UP ! 4242: * ! 4243: ENDTU DAC B$SCL ! 4244: DAC 15 ! 4245: DTC /ERROR - TIME UP/ ! 4246: EJC ! 4247: * ! 4248: * STRING CONSTANT FOR ERROR MESSAGE (ERROR SECTION) ! 4249: * ! 4250: ERMMS DAC B$SCL ERROR ! 4251: DAC 5 ! 4252: DTC /ERROR/ ! 4253: * ! 4254: ERMNS DAC B$SCL STRING / -- / ! 4255: DAC 4 ! 4256: DTC / -- / ! 4257: * ! 4258: * STRING CONSTANT FOR PAGE NUMBERING ! 4259: * ! 4260: LSTMS DAC B$SCL PAGE ! 4261: DAC 5 ! 4262: DTC /PAGE / ! 4263: * ! 4264: * LISTING HEADER MESSAGE ! 4265: * ! 4266: HEADR DAC B$SCL ! 4267: DAC 25 ! 4268: DTC /MACRO SPITBOL VERSION 3.5/ ! 4269: * ! 4270: HEADV DAC B$SCL FOR EXIT() VERSION NO. CHECK ! 4271: DAC 3 ! 4272: DTC /3.5/ ! 4273: * ! 4274: * INTEGER CONSTANTS FOR GENERAL USE ! 4275: * ICBLD OPTIMISATION USES THE FIRST THREE. ! 4276: * ! 4277: INT$R DAC B$ICL ! 4278: INTV0 DIC +0 0 ! 4279: INTON DAC B$ICL ! 4280: INTV1 DIC +1 1 ! 4281: INTTW DAC B$ICL ! 4282: INTV2 DIC +2 2 ! 4283: INTVT DIC +10 10 ! 4284: INTVH DIC +100 100 ! 4285: INTTH DIC +1000 1000 ! 4286: * ! 4287: * TABLE USED IN ICBLD OPTIMISATION ! 4288: * ! 4289: INTAB DAC INT$R POINTER TO 0 ! 4290: DAC INTON POINTER TO 1 ! 4291: DAC INTTW POINTER TO 2 ! 4292: EJC ! 4293: * ! 4294: * SPECIAL PATTERN NODES. THE FOLLOWING PATTERN NODES ! 4295: * CONSIST SIMPLY OF A PCODE POINTER, SEE MATCH ROUTINES ! 4296: * (P$XXX) FOR FULL DETAILS OF THEIR USE AND FORMAT). ! 4297: * ! 4298: NDABB DAC P$ABB ARBNO ! 4299: NDABD DAC P$ABD ARBNO ! 4300: NDARC DAC P$ARC ARB ! 4301: NDEXB DAC P$EXB EXPRESSION ! 4302: NDFNB DAC P$FNB FENCE() ! 4303: NDFND DAC P$FND FENCE() ! 4304: NDEXC DAC P$EXC EXPRESSION ! 4305: NDIMB DAC P$IMB IMMEDIATE ASSIGNMENT ! 4306: NDIMD DAC P$IMD IMMEDIATE ASSIGNMENT ! 4307: NDNTH DAC P$NTH PATTERN END (NULL PATTERN) ! 4308: NDPAB DAC P$PAB PATTERN ASSIGNMENT ! 4309: NDPAD DAC P$PAD PATTERN ASSIGNMENT ! 4310: NDUNA DAC P$UNA ANCHOR POINT MOVEMENT ! 4311: * ! 4312: * KEYWORD CONSTANT PATTERN NODES. THE FOLLOWING NODES ARE ! 4313: * USED AS THE VALUES OF PATTERN KEYWORDS AND THE INITIAL ! 4314: * VALUES OF THE CORRESPONDING NATURAL VARIABLES. ALL ! 4315: * NODES ARE IN P0BLK FORMAT AND THE ORDER IS TIED TO THE ! 4316: * DEFINITIONS OF CORRESPONDING K$XXX SYMBOLS. ! 4317: * ! 4318: NDABO DAC P$ABO ABORT ! 4319: DAC NDNTH ! 4320: NDARB DAC P$ARB ARB ! 4321: DAC NDNTH ! 4322: NDBAL DAC P$BAL BAL ! 4323: DAC NDNTH ! 4324: NDFAL DAC P$FAL FAIL ! 4325: DAC NDNTH ! 4326: NDFEN DAC P$FEN FENCE ! 4327: DAC NDNTH ! 4328: NDREM DAC P$REM REM ! 4329: DAC NDNTH ! 4330: NDSUC DAC P$SUC SUCCEED ! 4331: DAC NDNTH ! 4332: * ! 4333: * NULL STRING. ALL NULL VALUES POINT TO THIS STRING. THE ! 4334: * SVCHS FIELD CONTAINS A BLANK TO PROVIDE FOR EASY DEFAULT ! 4335: * PROCESSING IN TRACE, STOPTR, LPAD AND RPAD. ! 4336: * NULLW CONTAINS 10 BLANKS WHICH ENSURES AN ALL BLANK WORD ! 4337: * BUT FOR VERY EXCEPTIONAL MACHINES. ! 4338: * ! 4339: NULLS DAC B$SCL NULL STRING VALUE ! 4340: DAC 0 SCLEN = 0 ! 4341: NULLW DTC / / ! 4342: EJC ! 4343: * ! 4344: * OPERATOR DOPE VECTORS (SEE DVBLK FORMAT) ! 4345: * ! 4346: OPDVC DAC O$CNC CONCATENATION ! 4347: DAC C$CNC ! 4348: DAC LLCNC ! 4349: DAC RRCNC ! 4350: * ! 4351: * OPDVS IS USED WHEN SCANNING BELOW THE TOP LEVEL TO ! 4352: * INSURE THAT THE CONCATENATION WILL NOT BE LATER ! 4353: * MISTAKEN FOR PATTERN MATCHING ! 4354: * ! 4355: OPDVP DAC O$CNC CONCATENATION - NOT PATTERN MATCH ! 4356: DAC C$CNP ! 4357: DAC LLCNC ! 4358: DAC RRCNC ! 4359: * ! 4360: * NOTE THAT THE ORDER OF THE REMAINING ENTRIES IS TIED TO ! 4361: * THE ORDER OF THE CODING IN THE SCANE PROCEDURE. ! 4362: * ! 4363: OPDVS DAC O$ASS ASSIGNMENT ! 4364: DAC C$ASS ! 4365: DAC LLASS ! 4366: DAC RRASS ! 4367: * ! 4368: DAC 6 UNARY EQUAL ! 4369: DAC C$UUO ! 4370: DAC LLUNO ! 4371: * ! 4372: DAC O$PMV PATTERN MATCH ! 4373: DAC C$PMT ! 4374: DAC LLPMT ! 4375: DAC RRPMT ! 4376: * ! 4377: DAC O$INT INTERROGATION ! 4378: DAC C$UVL ! 4379: DAC LLUNO ! 4380: * ! 4381: DAC 1 BINARY AMPERSAND ! 4382: DAC C$UBO ! 4383: DAC LLAMP ! 4384: DAC RRAMP ! 4385: * ! 4386: DAC O$KWV KEYWORD REFERENCE ! 4387: DAC C$KEY ! 4388: DAC LLUNO ! 4389: * ! 4390: DAC O$ALT ALTERNATION ! 4391: DAC C$ALT ! 4392: DAC LLALT ! 4393: DAC RRALT ! 4394: EJC ! 4395: * ! 4396: * OPERATOR DOPE VECTORS (CONTINUED) ! 4397: * ! 4398: DAC 5 UNARY VERTICAL BAR ! 4399: DAC C$UUO ! 4400: DAC LLUNO ! 4401: * ! 4402: DAC 0 BINARY AT ! 4403: DAC C$UBO ! 4404: DAC LLATS ! 4405: DAC RRATS ! 4406: * ! 4407: DAC O$CAS CURSOR ASSIGNMENT ! 4408: DAC C$UNM ! 4409: DAC LLUNO ! 4410: * ! 4411: DAC 2 BINARY NUMBER SIGN ! 4412: DAC C$UBO ! 4413: DAC LLNUM ! 4414: DAC RRNUM ! 4415: * ! 4416: DAC 7 UNARY NUMBER SIGN ! 4417: DAC C$UUO ! 4418: DAC LLUNO ! 4419: * ! 4420: DAC O$DVD DIVISION ! 4421: DAC C$BVL ! 4422: DAC LLDVD ! 4423: DAC RRDVD ! 4424: * ! 4425: DAC 9 UNARY SLASH ! 4426: DAC C$UUO ! 4427: DAC LLUNO ! 4428: * ! 4429: DAC O$MLT MULTIPLICATION ! 4430: DAC C$BVL ! 4431: DAC LLMLT ! 4432: DAC RRMLT ! 4433: EJC ! 4434: * ! 4435: * OPERATOR DOPE VECTORS (CONTINUED) ! 4436: * ! 4437: DAC 0 DEFERRED EXPRESSION ! 4438: DAC C$DEF ! 4439: DAC LLUNO ! 4440: * ! 4441: DAC 3 BINARY PERCENT ! 4442: DAC C$UBO ! 4443: DAC LLPCT ! 4444: DAC RRPCT ! 4445: * ! 4446: DAC 8 UNARY PERCENT ! 4447: DAC C$UUO ! 4448: DAC LLUNO ! 4449: * ! 4450: DAC O$EXP EXPONENTIATION ! 4451: DAC C$BVL ! 4452: DAC LLEXP ! 4453: DAC RREXP ! 4454: * ! 4455: DAC 10 UNARY EXCLAMATION ! 4456: DAC C$UUO ! 4457: DAC LLUNO ! 4458: * ! 4459: DAC O$IMA IMMEDIATE ASSIGNMENT ! 4460: DAC C$BVN ! 4461: DAC LLDLD ! 4462: DAC RRDLD ! 4463: * ! 4464: DAC O$INV INDIRECTION ! 4465: DAC C$IND ! 4466: DAC LLUNO ! 4467: * ! 4468: DAC 4 BINARY NOT ! 4469: DAC C$UBO ! 4470: DAC LLNOT ! 4471: DAC RRNOT ! 4472: * ! 4473: DAC 0 NEGATION ! 4474: DAC C$NEG ! 4475: DAC LLUNO ! 4476: EJC ! 4477: * ! 4478: * OPERATOR DOPE VECTORS (CONTINUED) ! 4479: * ! 4480: DAC O$SUB SUBTRACTION ! 4481: DAC C$BVL ! 4482: DAC LLPLM ! 4483: DAC RRPLM ! 4484: * ! 4485: DAC O$COM COMPLEMENTATION ! 4486: DAC C$UVL ! 4487: DAC LLUNO ! 4488: * ! 4489: DAC O$ADD ADDITION ! 4490: DAC C$BVL ! 4491: DAC LLPLM ! 4492: DAC RRPLM ! 4493: * ! 4494: DAC O$AFF AFFIRMATION ! 4495: DAC C$UVL ! 4496: DAC LLUNO ! 4497: * ! 4498: DAC O$PAS PATTERN ASSIGNMENT ! 4499: DAC C$BVN ! 4500: DAC LLDLD ! 4501: DAC RRDLD ! 4502: * ! 4503: DAC O$NAM NAME REFERENCE ! 4504: DAC C$UNM ! 4505: DAC LLUNO ! 4506: * ! 4507: * SPECIAL DVS FOR GOTO OPERATORS (SEE PROCEDURE SCNGF) ! 4508: * ! 4509: OPDVD DAC O$GOD DIRECT GOTO ! 4510: DAC C$UVL ! 4511: DAC LLUNO ! 4512: * ! 4513: OPDVN DAC O$GOC COMPLEX NORMAL GOTO ! 4514: DAC C$UNM ! 4515: DAC LLUNO ! 4516: EJC ! 4517: * ! 4518: * OPERATOR ENTRY ADDRESS POINTERS, USED IN CODE ! 4519: * ! 4520: OAMN$ DAC O$AMN ARRAY REF (MULTI-SUBS BY VALUE) ! 4521: OAMV$ DAC O$AMV ARRAY REF (MULTI-SUBS BY VALUE) ! 4522: OAON$ DAC O$AON ARRAY REF (ONE SUB BY NAME) ! 4523: OAOV$ DAC O$AOV ARRAY REF (ONE SUB BY VALUE) ! 4524: OCER$ DAC O$CER COMPILATION ERROR ! 4525: OFEX$ DAC O$FEX FAILURE IN EXPRESSION EVALUATION ! 4526: OFIF$ DAC O$FIF FAILURE DURING GOTO EVALUATION ! 4527: OFNC$ DAC O$FNC FUNCTION CALL (MORE THAN ONE ARG) ! 4528: OFNE$ DAC O$FNE FUNCTION NAME ERROR ! 4529: OFNS$ DAC O$FNS FUNCTION CALL (SINGLE ARGUMENT) ! 4530: OGOF$ DAC O$GOF SET GOTO FAILURE TRAP ! 4531: OINN$ DAC O$INN INDIRECTION BY NAME ! 4532: OKWN$ DAC O$KWN KEYWORD REFERENCE BY NAME ! 4533: OLEX$ DAC O$LEX LOAD EXPRESSION BY NAME ! 4534: OLPT$ DAC O$LPT LOAD PATTERN ! 4535: OLVN$ DAC O$LVN LOAD VARIABLE NAME ! 4536: ONTA$ DAC O$NTA NEGATION, FIRST ENTRY ! 4537: ONTB$ DAC O$NTB NEGATION, SECOND ENTRY ! 4538: ONTC$ DAC O$NTC NEGATION, THIRD ENTRY ! 4539: OPMN$ DAC O$PMN PATTERN MATCH BY NAME ! 4540: OPMS$ DAC O$PMS PATTERN MATCH (STATEMENT) ! 4541: OPOP$ DAC O$POP POP TOP STACK ITEM ! 4542: ORNM$ DAC O$RNM RETURN NAME FROM EXPRESSION ! 4543: ORPL$ DAC O$RPL PATTERN REPLACEMENT ! 4544: ORVL$ DAC O$RVL RETURN VALUE FROM EXPRESSION ! 4545: OSLA$ DAC O$SLA SELECTION, FIRST ENTRY ! 4546: OSLB$ DAC O$SLB SELECTION, SECOND ENTRY ! 4547: OSLC$ DAC O$SLC SELECTION, THIRD ENTRY ! 4548: OSLD$ DAC O$SLD SELECTION, FOURTH ENTRY ! 4549: OSTP$ DAC O$STP STOP EXECUTION ! 4550: OUNF$ DAC O$UNF UNEXPECTED FAILURE ! 4551: EJC ! 4552: * ! 4553: * TABLE OF NAMES OF UNDEFINED BINARY OPERATORS FOR OPSYN ! 4554: * ! 4555: OPSNB DAC CH$AT AT ! 4556: DAC CH$AM AMPERSAND ! 4557: DAC CH$NM NUMBER ! 4558: DAC CH$PC PERCENT ! 4559: DAC CH$NT NOT ! 4560: * ! 4561: * TABLE OF NAMES OF UNDEFINED UNARY OPERATORS FOR OPSYN ! 4562: * ! 4563: OPNSU DAC CH$BR VERTICAL BAR ! 4564: DAC CH$EQ EQUAL ! 4565: DAC CH$NM NUMBER ! 4566: DAC CH$PC PERCENT ! 4567: DAC CH$SL SLASH ! 4568: DAC CH$EX EXCLAMATION ! 4569: .IF .CNPF ! 4570: .ELSE ! 4571: * ! 4572: * ADDRESS CONST CONTAINING PROFILE TABLE ENTRY SIZE ! 4573: * ! 4574: PFI2A DAC PF$I2 ! 4575: * ! 4576: * PROFILER MESSAGE STRINGS ! 4577: * ! 4578: PFMS1 DAC B$SCL ! 4579: DAC 15 ! 4580: DTC /PROGRAM PROFILE/ ! 4581: PFMS2 DAC B$SCL ! 4582: DAC 42 ! 4583: DTC /STMT NUMBER OF -- EXECUTION TIME --/ ! 4584: PFMS3 DAC B$SCL ! 4585: DAC 47 ! 4586: DTC /NUMBER EXECUTIONS TOTAL(MSEC) PER EXCN(MCSEC)/ ! 4587: .FI ! 4588: * ! 4589: .IF .CNRA ! 4590: .ELSE ! 4591: * ! 4592: * REAL CONSTANTS FOR GENERAL USE. NOTE THAT THE CONSTANTS ! 4593: * STARTING AT REAV1 FORM A POWERS OF TEN TABLE (GTSTG) ! 4594: * ! 4595: REAV0 DRC +0.0 0.0 ! 4596: REAP1 DRC +0.1 0.1 ! 4597: REAP5 DRC +0.5 0.5 ! 4598: REAV1 DRC +1.0 10**0 ! 4599: REAVT DRC +1.0E+1 10**1 ! 4600: DRC +1.0E+2 10**2 ! 4601: DRC +1.0E+3 10**3 ! 4602: DRC +1.0E+4 10**4 ! 4603: DRC +1.0E+5 10**5 ! 4604: DRC +1.0E+6 10**6 ! 4605: DRC +1.0E+7 10**7 ! 4606: DRC +1.0E+8 10**8 ! 4607: DRC +1.0E+9 10**9 ! 4608: REATT DRC +1.0E+10 10**10 ! 4609: .FI ! 4610: EJC ! 4611: * ! 4612: * STRING CONSTANTS (SCBLK FORMAT) FOR DTYPE PROCEDURE ! 4613: * ! 4614: SCARR DAC B$SCL ARRAY ! 4615: DAC 5 ! 4616: DTC /ARRAY/ ! 4617: * ! 4618: SCBUF DAC B$SCL BUFFER ! 4619: DAC 6 ! 4620: DTC /BUFFER/ ! 4621: * ! 4622: SCCOD DAC B$SCL CODE ! 4623: DAC 4 ! 4624: DTC /CODE/ ! 4625: * ! 4626: SCEXP DAC B$SCL EXPRESSION ! 4627: DAC 10 ! 4628: DTC /EXPRESSION/ ! 4629: * ! 4630: SCEXT DAC B$SCL EXTERNAL ! 4631: DAC 8 ! 4632: DTC /EXTERNAL/ ! 4633: * ! 4634: SCINT DAC B$SCL INTEGER ! 4635: DAC 7 ! 4636: DTC /INTEGER/ ! 4637: * ! 4638: SCNAM DAC B$SCL NAME ! 4639: DAC 4 ! 4640: DTC /NAME/ ! 4641: * ! 4642: SCNUM DAC B$SCL NUMERIC ! 4643: DAC 7 ! 4644: DTC /NUMERIC/ ! 4645: * ! 4646: SCPAT DAC B$SCL PATTERN ! 4647: DAC 7 ! 4648: DTC /PATTERN/ ! 4649: .IF .CNRA ! 4650: .ELSE ! 4651: * ! 4652: SCREA DAC B$SCL REAL ! 4653: DAC 4 ! 4654: DTC /REAL/ ! 4655: .FI ! 4656: * ! 4657: SCSTR DAC B$SCL STRING ! 4658: DAC 6 ! 4659: DTC /STRING/ ! 4660: * ! 4661: SCTAB DAC B$SCL TABLE ! 4662: DAC 5 ! 4663: DTC /TABLE/ ! 4664: EJC ! 4665: * ! 4666: * STRING CONSTANTS (SCBLK FORMAT) FOR KVRTN (SEE RETRN) ! 4667: * ! 4668: SCFRT DAC B$SCL FRETURN ! 4669: DAC 7 ! 4670: DTC /FRETURN/ ! 4671: * ! 4672: SCNRT DAC B$SCL NRETURN ! 4673: DAC 7 ! 4674: DTC /NRETURN/ ! 4675: * ! 4676: SCRTN DAC B$SCL RETURN ! 4677: DAC 6 ! 4678: DTC /RETURN/ ! 4679: * ! 4680: * DATATYPE NAME TABLE FOR DTYPE PROCEDURE. THE ORDER OF ! 4681: * THESE ENTRIES IS TIED TO THE B$XXX DEFINITIONS FOR BLOCKS ! 4682: * ! 4683: SCNMT DAC SCARR ARBLK ARRAY ! 4684: .IF .CNBF ! 4685: .ELSE ! 4686: DAC SCBUF BFBLK BUFFER ! 4687: .FI ! 4688: DAC SCCOD CDBLK CODE ! 4689: DAC SCEXP EXBLK EXPRESSION ! 4690: DAC SCINT ICBLK INTEGER ! 4691: DAC SCNAM NMBLK NAME ! 4692: DAC SCPAT P0BLK PATTERN ! 4693: DAC SCPAT P1BLK PATTERN ! 4694: DAC SCPAT P2BLK PATTERN ! 4695: .IF .CNRA ! 4696: .ELSE ! 4697: DAC SCREA RCBLK REAL ! 4698: .FI ! 4699: DAC SCSTR SCBLK STRING ! 4700: DAC SCEXP SEBLK EXPRESSION ! 4701: DAC SCTAB TBBLK TABLE ! 4702: DAC SCARR VCBLK ARRAY ! 4703: DAC SCEXT XNBLK EXTERNAL ! 4704: DAC SCEXT XRBLK EXTERNAL ! 4705: * ! 4706: .IF .CNRA ! 4707: .ELSE ! 4708: * STRING CONSTANT FOR REAL ZERO ! 4709: * ! 4710: SCRE0 DAC B$SCL ! 4711: DAC 2 ! 4712: DTC /0./ ! 4713: .FI ! 4714: EJC ! 4715: * ! 4716: * USED TO RE-INITIALISE KVSTL ! 4717: * ! 4718: STLIM DIC +50000 DEFAULT STATEMENT LIMIT ! 4719: * ! 4720: * DUMMY FUNCTION BLOCK USED FOR UNDEFINED FUNCTIONS ! 4721: * ! 4722: STNDF DAC O$FUN PTR TO UNDEFINED FUNCTION ERR CALL ! 4723: DAC 0 DUMMY FARGS COUNT FOR CALL CIRCUIT ! 4724: * ! 4725: * DUMMY CODE BLOCK USED FOR UNDEFINED LABELS ! 4726: * ! 4727: STNDL DAC L$UND CODE PTR POINTS TO UNDEFINED LBL ! 4728: * ! 4729: * DUMMY OPERATOR BLOCK USED FOR UNDEFINED OPERATORS ! 4730: * ! 4731: STNDO DAC O$OUN PTR TO UNDEFINED OPERATOR ERR CALL ! 4732: DAC 0 DUMMY FARGS COUNT FOR CALL CIRCUIT ! 4733: * ! 4734: * STANDARD VARIABLE BLOCK. THIS BLOCK IS USED TO INITIALIZE ! 4735: * THE FIRST SEVEN FIELDS OF A NEWLY CONSTRUCTED VRBLK. ! 4736: * ITS FORMAT IS TIED TO THE VRBLK DEFINITIONS (SEE GTNVR). ! 4737: * ! 4738: STNVR DAC B$VRL VRGET ! 4739: DAC B$VRS VRSTO ! 4740: DAC NULLS VRVAL ! 4741: DAC B$VRG VRTRA ! 4742: DAC STNDL VRLBL ! 4743: DAC STNDF VRFNC ! 4744: DAC 0 VRNXT ! 4745: EJC ! 4746: * ! 4747: * MESSAGES USED IN END OF RUN PROCESSING (STOPR) ! 4748: * ! 4749: STPM1 DAC B$SCL IN STATEMENT ! 4750: DAC 12 ! 4751: DTC /IN STATEMENT/ ! 4752: * ! 4753: STPM2 DAC B$SCL ! 4754: DAC 14 ! 4755: DTC /STMTS EXECUTED/ ! 4756: * ! 4757: STPM3 DAC B$SCL ! 4758: DAC 13 ! 4759: DTC /RUN TIME-MSEC/ ! 4760: * ! 4761: STPM4 DAC B$SCL ! 4762: DAC 12 ! 4763: DTC $MCSEC / STMT$ ! 4764: * ! 4765: STPM5 DAC B$SCL ! 4766: DAC 13 ! 4767: DTC /REGENERATIONS/ ! 4768: * ! 4769: * CHARS FOR /TU/ ENDING CODE ! 4770: * ! 4771: STRTU DTC /TU/ ! 4772: * ! 4773: * TABLE USED BY CONVERT FUNCTION TO CHECK DATATYPE NAME ! 4774: * THE ENTRIES ARE ORDERED TO CORRESPOND TO BRANCH TABLE ! 4775: * IN S$CNV ! 4776: * ! 4777: SVCTB DAC SCSTR STRING ! 4778: DAC SCINT INTEGER ! 4779: DAC SCNAM NAME ! 4780: DAC SCPAT PATTERN ! 4781: DAC SCARR ARRAY ! 4782: DAC SCTAB TABLE ! 4783: DAC SCEXP EXPRESSION ! 4784: DAC SCCOD CODE ! 4785: DAC SCNUM NUMERIC ! 4786: .IF .CNRA ! 4787: .ELSE ! 4788: DAC SCREA REAL ! 4789: .FI ! 4790: .IF .CNBF ! 4791: .ELSE ! 4792: DAC SCBUF BUFFER ! 4793: .FI ! 4794: DAC 0 ZERO MARKS END OF LIST ! 4795: EJC ! 4796: * ! 4797: * MESSAGES (SCBLK FORMAT) USED BY TRACE PROCEDURES ! 4798: * ! 4799: * ! 4800: TMASB DAC B$SCL ASTERISKS FOR TRACE STATEMENT NO ! 4801: DAC 13 ! 4802: DTC /************ / ! 4803: ! 4804: * ! 4805: TMBEB DAC B$SCL BLANK-EQUAL-BLANK ! 4806: DAC 3 ! 4807: DTC / = / ! 4808: * ! 4809: * DUMMY TRBLK FOR EXPRESSION VARIABLE ! 4810: * ! 4811: TRBEV DAC B$TRT DUMMY TRBLK ! 4812: * ! 4813: * DUMMY TRBLK FOR KEYWORD VARIABLE ! 4814: * ! 4815: TRBKV DAC B$TRT DUMMY TRBLK ! 4816: * ! 4817: * DUMMY CODE BLOCK TO RETURN CONTROL TO TRXEQ PROCEDURE ! 4818: * ! 4819: TRXDR DAC O$TXR BLOCK POINTS TO RETURN ROUTINE ! 4820: TRXDC DAC TRXDR POINTER TO BLOCK ! 4821: EJC ! 4822: * ! 4823: * STANDARD VARIABLE BLOCKS ! 4824: * ! 4825: * SEE SVBLK FORMAT FOR FULL DETAILS OF THE FORMAT. THE ! 4826: * VRBLKS ARE ORDERED BY LENGTH AND WITHIN EACH LENGTH THE ! 4827: * ORDER IS ALPHABETICAL BY NAME OF THE VARIABLE. ! 4828: * ! 4829: V$EQF DBC SVFPR EQ ! 4830: DAC 2 ! 4831: DTC /EQ/ ! 4832: DAC S$EQF ! 4833: DAC 2 ! 4834: * ! 4835: V$GEF DBC SVFPR GE ! 4836: DAC 2 ! 4837: DTC /GE/ ! 4838: DAC S$GEF ! 4839: DAC 2 ! 4840: * ! 4841: V$GTF DBC SVFPR GT ! 4842: DAC 2 ! 4843: DTC /GT/ ! 4844: DAC S$GTF ! 4845: DAC 2 ! 4846: * ! 4847: V$LEF DBC SVFPR LE ! 4848: DAC 2 ! 4849: DTC /LE/ ! 4850: DAC S$LEF ! 4851: DAC 2 ! 4852: * ! 4853: V$LTF DBC SVFPR LT ! 4854: DAC 2 ! 4855: DTC /LT/ ! 4856: DAC S$LTF ! 4857: DAC 2 ! 4858: * ! 4859: V$NEF DBC SVFPR NE ! 4860: DAC 2 ! 4861: DTC /NE/ ! 4862: DAC S$NEF ! 4863: DAC 2 ! 4864: * ! 4865: V$ANY DBC SVFNP ANY ! 4866: DAC 3 ! 4867: DTC /ANY/ ! 4868: DAC S$ANY ! 4869: DAC 1 ! 4870: * ! 4871: V$ARB DBC SVKVC ARB ! 4872: DAC 3 ! 4873: DTC /ARB/ ! 4874: DAC K$ARB ! 4875: DAC NDARB ! 4876: EJC ! 4877: * ! 4878: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 4879: * ! 4880: V$ARG DBC SVFNN ARG ! 4881: DAC 3 ! 4882: DTC /ARG/ ! 4883: DAC S$ARG ! 4884: DAC 2 ! 4885: * ! 4886: V$BAL DBC SVKVC BAL ! 4887: DAC 3 ! 4888: DTC /BAL/ ! 4889: DAC K$BAL ! 4890: DAC NDBAL ! 4891: * ! 4892: V$END DBC SVLBL END ! 4893: DAC 3 ! 4894: DTC /END/ ! 4895: DAC L$END ! 4896: * ! 4897: V$LEN DBC SVFNP LEN ! 4898: DAC 3 ! 4899: DTC /LEN/ ! 4900: DAC S$LEN ! 4901: DAC 1 ! 4902: * ! 4903: V$LEQ DBC SVFPR LEQ ! 4904: DAC 3 ! 4905: DTC /LEQ/ ! 4906: DAC S$LEQ ! 4907: DAC 2 ! 4908: * ! 4909: V$LGE DBC SVFPR LGE ! 4910: DAC 3 ! 4911: DTC /LGE/ ! 4912: DAC S$LGE ! 4913: DAC 2 ! 4914: * ! 4915: V$LGT DBC SVFPR LGT ! 4916: DAC 3 ! 4917: DTC /LGT/ ! 4918: DAC S$LGT ! 4919: DAC 2 ! 4920: * ! 4921: V$LLE DBC SVFPR LLE ! 4922: DAC 3 ! 4923: DTC /LLE/ ! 4924: DAC S$LLE ! 4925: DAC 2 ! 4926: EJC ! 4927: * ! 4928: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 4929: * ! 4930: V$LLT DBC SVFPR LLT ! 4931: DAC 3 ! 4932: DTC /LLT/ ! 4933: DAC S$LLT ! 4934: DAC 2 ! 4935: * ! 4936: V$LNE DBC SVFPR LNE ! 4937: DAC 3 ! 4938: DTC /LNE/ ! 4939: DAC S$LNE ! 4940: DAC 2 ! 4941: * ! 4942: V$POS DBC SVFNP POS ! 4943: DAC 3 ! 4944: DTC /POS/ ! 4945: DAC S$POS ! 4946: DAC 1 ! 4947: * ! 4948: V$REM DBC SVKVC REM ! 4949: DAC 3 ! 4950: DTC /REM/ ! 4951: DAC K$REM ! 4952: DAC NDREM ! 4953: .IF .CUST ! 4954: * ! 4955: V$SET DBC SVFNN SET ! 4956: DAC 3 ! 4957: DTC /SET/ ! 4958: DAC S$SET ! 4959: DAC 3 ! 4960: .FI ! 4961: * ! 4962: V$TAB DBC SVFNP TAB ! 4963: DAC 3 ! 4964: DTC /TAB/ ! 4965: DAC S$TAB ! 4966: DAC 1 ! 4967: .IF .CULC ! 4968: * ! 4969: V$CAS DBC SVKNM CASE ! 4970: DAC 4 ! 4971: DTC /CASE/ ! 4972: DAC K$CAS ! 4973: .FI ! 4974: * ! 4975: V$CHR DBC SVFNP CHAR ! 4976: DAC 4 ! 4977: DTC /CHAR/ ! 4978: DAC S$CHR ! 4979: DAC 1 ! 4980: * ! 4981: V$COD DBC SVFNK CODE ! 4982: DAC 4 ! 4983: DTC /CODE/ ! 4984: DAC K$COD ! 4985: DAC S$COD ! 4986: DAC 1 ! 4987: * ! 4988: V$COP DBC SVFNN COPY ! 4989: DAC 4 ! 4990: DTC /COPY/ ! 4991: DAC S$COP ! 4992: DAC 1 ! 4993: EJC ! 4994: * ! 4995: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 4996: * ! 4997: V$DAT DBC SVFNN DATA ! 4998: DAC 4 ! 4999: DTC /DATA/ ! 5000: DAC S$DAT ! 5001: DAC 1 ! 5002: * ! 5003: V$DTE DBC SVFNN DATE ! 5004: DAC 4 ! 5005: DTC /DATE/ ! 5006: DAC S$DTE ! 5007: DAC 0 ! 5008: * ! 5009: V$DMP DBC SVFNK DUMP ! 5010: DAC 4 ! 5011: DTC /DUMP/ ! 5012: DAC K$DMP ! 5013: DAC S$DMP ! 5014: DAC 1 ! 5015: * ! 5016: V$DUP DBC SVFNN DUPL ! 5017: DAC 4 ! 5018: DTC /DUPL/ ! 5019: DAC S$DUP ! 5020: DAC 2 ! 5021: * ! 5022: V$EVL DBC SVFNN EVAL ! 5023: DAC 4 ! 5024: DTC /EVAL/ ! 5025: DAC S$EVL ! 5026: DAC 1 ! 5027: .IF .CNEX ! 5028: .ELSE ! 5029: * ! 5030: V$EXT DBC SVFNN EXIT ! 5031: DAC 4 ! 5032: DTC /EXIT/ ! 5033: DAC S$EXT ! 5034: DAC 1 ! 5035: .FI ! 5036: * ! 5037: V$FAL DBC SVKVC FAIL ! 5038: DAC 4 ! 5039: DTC /FAIL/ ! 5040: DAC K$FAL ! 5041: DAC NDFAL ! 5042: * ! 5043: V$HST DBC SVFNN HOST ! 5044: DAC 4 ! 5045: DTC /HOST/ ! 5046: DAC S$HST ! 5047: DAC 3 ! 5048: EJC ! 5049: * ! 5050: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 5051: * ! 5052: V$ITM DBC SVFNF ITEM ! 5053: DAC 4 ! 5054: DTC /ITEM/ ! 5055: DAC S$ITM ! 5056: DAC 999 ! 5057: .IF .CNLD ! 5058: .ELSE ! 5059: * ! 5060: V$LOD DBC SVFNN LOAD ! 5061: DAC 4 ! 5062: DTC /LOAD/ ! 5063: DAC S$LOD ! 5064: DAC 2 ! 5065: .FI ! 5066: * ! 5067: V$LPD DBC SVFNP LPAD ! 5068: DAC 4 ! 5069: DTC /LPAD/ ! 5070: DAC S$LPD ! 5071: DAC 3 ! 5072: * ! 5073: V$RPD DBC SVFNP RPAD ! 5074: DAC 4 ! 5075: DTC /RPAD/ ! 5076: DAC S$RPD ! 5077: DAC 3 ! 5078: * ! 5079: V$RPS DBC SVFNP RPOS ! 5080: DAC 4 ! 5081: DTC /RPOS/ ! 5082: DAC S$RPS ! 5083: DAC 1 ! 5084: * ! 5085: V$RTB DBC SVFNP RTAB ! 5086: DAC 4 ! 5087: DTC /RTAB/ ! 5088: DAC S$RTB ! 5089: DAC 1 ! 5090: * ! 5091: V$SI$ DBC SVFNP SIZE ! 5092: DAC 4 ! 5093: DTC /SIZE/ ! 5094: DAC S$SI$ ! 5095: DAC 1 ! 5096: * ! 5097: .IF .CNSR ! 5098: .ELSE ! 5099: * ! 5100: V$SRT DBC SVFNN SORT ! 5101: DAC 4 ! 5102: DTC /SORT/ ! 5103: DAC S$SRT ! 5104: DAC 2 ! 5105: .FI ! 5106: V$SPN DBC SVFNP SPAN ! 5107: DAC 4 ! 5108: DTC /SPAN/ ! 5109: DAC S$SPN ! 5110: DAC 1 ! 5111: EJC ! 5112: * ! 5113: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 5114: * ! 5115: V$STN DBC SVKNM STNO ! 5116: DAC 4 ! 5117: DTC /STNO/ ! 5118: DAC K$STN ! 5119: * ! 5120: V$TIM DBC SVFNN TIME ! 5121: DAC 4 ! 5122: DTC /TIME/ ! 5123: DAC S$TIM ! 5124: DAC 0 ! 5125: * ! 5126: V$TRM DBC SVFNK TRIM ! 5127: DAC 4 ! 5128: DTC /TRIM/ ! 5129: DAC K$TRM ! 5130: DAC S$TRM ! 5131: DAC 1 ! 5132: * ! 5133: V$ABE DBC SVKNM ABEND ! 5134: DAC 5 ! 5135: DTC /ABEND/ ! 5136: DAC K$ABE ! 5137: * ! 5138: V$ABO DBC SVKVL ABORT ! 5139: DAC 5 ! 5140: DTC /ABORT/ ! 5141: DAC K$ABO ! 5142: DAC L$ABO ! 5143: DAC NDABO ! 5144: * ! 5145: V$APP DBC SVFNF APPLY ! 5146: DAC 5 ! 5147: DTC /APPLY/ ! 5148: DAC S$APP ! 5149: DAC 999 ! 5150: * ! 5151: V$ABN DBC SVFNP ARBNO ! 5152: DAC 5 ! 5153: DTC /ARBNO/ ! 5154: DAC S$ABN ! 5155: DAC 1 ! 5156: * ! 5157: V$ARR DBC SVFNN ARRAY ! 5158: DAC 5 ! 5159: DTC /ARRAY/ ! 5160: DAC S$ARR ! 5161: DAC 2 ! 5162: EJC ! 5163: * ! 5164: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 5165: * ! 5166: V$BRK DBC SVFNP BREAK ! 5167: DAC 5 ! 5168: DTC /BREAK/ ! 5169: DAC S$BRK ! 5170: DAC 1 ! 5171: * ! 5172: V$CLR DBC SVFNN CLEAR ! 5173: DAC 5 ! 5174: DTC /CLEAR/ ! 5175: DAC S$CLR ! 5176: DAC 1 ! 5177: * ! 5178: V$EJC DBC SVFNN EJECT ! 5179: DAC 5 ! 5180: DTC /EJECT/ ! 5181: DAC S$EJC ! 5182: DAC 1 ! 5183: * ! 5184: V$FEN DBC SVFPK FENCE ! 5185: DAC 5 ! 5186: DTC /FENCE/ ! 5187: DAC K$FEN ! 5188: DAC S$FNC ! 5189: DAC 1 ! 5190: DAC NDFEN ! 5191: * ! 5192: V$FLD DBC SVFNN FIELD ! 5193: DAC 5 ! 5194: DTC /FIELD/ ! 5195: DAC S$FLD ! 5196: DAC 2 ! 5197: * ! 5198: V$IDN DBC SVFPR IDENT ! 5199: DAC 5 ! 5200: DTC /IDENT/ ! 5201: DAC S$IDN ! 5202: DAC 2 ! 5203: * ! 5204: V$INP DBC SVFNK INPUT ! 5205: DAC 5 ! 5206: DTC /INPUT/ ! 5207: DAC K$INP ! 5208: DAC S$INP ! 5209: DAC 3 ! 5210: * ! 5211: V$LOC DBC SVFNN LOCAL ! 5212: DAC 5 ! 5213: DTC /LOCAL/ ! 5214: DAC S$LOC ! 5215: DAC 2 ! 5216: EJC ! 5217: * ! 5218: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 5219: * ! 5220: V$OPS DBC SVFNN OPSYN ! 5221: DAC 5 ! 5222: DTC /OPSYN/ ! 5223: DAC S$OPS ! 5224: DAC 3 ! 5225: * ! 5226: V$RMD DBC SVFNP REMDR ! 5227: DAC 5 ! 5228: DTC /REMDR/ ! 5229: DAC S$RMD ! 5230: DAC 2 ! 5231: .IF .CNSR ! 5232: .ELSE ! 5233: * ! 5234: V$RSR DBC SVFNN RSORT ! 5235: DAC 5 ! 5236: DTC /RSORT/ ! 5237: DAC S$RSR ! 5238: DAC 2 ! 5239: .FI ! 5240: * ! 5241: V$TBL DBC SVFNN TABLE ! 5242: DAC 5 ! 5243: DTC /TABLE/ ! 5244: DAC S$TBL ! 5245: DAC 3 ! 5246: * ! 5247: V$TRA DBC SVFNK TRACE ! 5248: DAC 5 ! 5249: DTC /TRACE/ ! 5250: DAC K$TRA ! 5251: DAC S$TRA ! 5252: DAC 4 ! 5253: * ! 5254: V$ANC DBC SVKNM ANCHOR ! 5255: DAC 6 ! 5256: DTC /ANCHOR/ ! 5257: DAC K$ANC ! 5258: .IF .CNBF ! 5259: .ELSE ! 5260: * ! 5261: V$APN DBC SVFNN ! 5262: DAC 6 ! 5263: DTC /APPEND/ ! 5264: DAC S$APN ! 5265: DAC 2 ! 5266: .FI ! 5267: * ! 5268: V$BKX DBC SVFNP BREAKX ! 5269: DAC 6 ! 5270: DTC /BREAKX/ ! 5271: DAC S$BKX ! 5272: DAC 1 ! 5273: * ! 5274: .IF .CNBF ! 5275: .ELSE ! 5276: V$BUF DBC SVFNN BUFFER ! 5277: DAC 6 ! 5278: DTC /BUFFER/ ! 5279: DAC S$BUF ! 5280: DAC 2 ! 5281: .FI ! 5282: * ! 5283: V$DEF DBC SVFNN DEFINE ! 5284: DAC 6 ! 5285: DTC /DEFINE/ ! 5286: DAC S$DEF ! 5287: DAC 2 ! 5288: * ! 5289: V$DET DBC SVFNN DETACH ! 5290: DAC 6 ! 5291: DTC /DETACH/ ! 5292: DAC S$DET ! 5293: DAC 1 ! 5294: EJC ! 5295: * ! 5296: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 5297: * ! 5298: V$DIF DBC SVFPR DIFFER ! 5299: DAC 6 ! 5300: DTC /DIFFER/ ! 5301: DAC S$DIF ! 5302: DAC 2 ! 5303: * ! 5304: V$FTR DBC SVKNM FTRACE ! 5305: DAC 6 ! 5306: DTC /FTRACE/ ! 5307: DAC K$FTR ! 5308: * ! 5309: .IF .CNBF ! 5310: .ELSE ! 5311: V$INS DBC SVFNN INSERT ! 5312: DAC 6 ! 5313: DTC /INSERT/ ! 5314: DAC S$INS ! 5315: DAC 4 ! 5316: * ! 5317: .FI ! 5318: V$LST DBC SVKNM LASTNO ! 5319: DAC 6 ! 5320: DTC /LASTNO/ ! 5321: DAC K$LST ! 5322: * ! 5323: V$NAY DBC SVFNP NOTANY ! 5324: DAC 6 ! 5325: DTC /NOTANY/ ! 5326: DAC S$NAY ! 5327: DAC 1 ! 5328: * ! 5329: V$OUP DBC SVFNK OUTPUT ! 5330: DAC 6 ! 5331: DTC /OUTPUT/ ! 5332: DAC K$OUP ! 5333: DAC S$OUP ! 5334: DAC 3 ! 5335: * ! 5336: V$RET DBC SVLBL RETURN ! 5337: DAC 6 ! 5338: DTC /RETURN/ ! 5339: DAC L$RTN ! 5340: * ! 5341: V$REW DBC SVFNN REWIND ! 5342: DAC 6 ! 5343: DTC /REWIND/ ! 5344: DAC S$REW ! 5345: DAC 1 ! 5346: * ! 5347: V$STT DBC SVFNN STOPTR ! 5348: DAC 6 ! 5349: DTC /STOPTR/ ! 5350: DAC S$STT ! 5351: DAC 2 ! 5352: EJC ! 5353: * ! 5354: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 5355: * ! 5356: V$SUB DBC SVFNN SUBSTR ! 5357: DAC 6 ! 5358: DTC /SUBSTR/ ! 5359: DAC S$SUB ! 5360: DAC 3 ! 5361: * ! 5362: V$UNL DBC SVFNN UNLOAD ! 5363: DAC 6 ! 5364: DTC /UNLOAD/ ! 5365: DAC S$UNL ! 5366: DAC 1 ! 5367: * ! 5368: V$COL DBC SVFNN COLLECT ! 5369: DAC 7 ! 5370: DTC /COLLECT/ ! 5371: DAC S$COL ! 5372: DAC 1 ! 5373: * ! 5374: V$CNV DBC SVFNN CONVERT ! 5375: DAC 7 ! 5376: DTC /CONVERT/ ! 5377: DAC S$CNV ! 5378: DAC 2 ! 5379: * ! 5380: V$ENF DBC SVFNN ENDFILE ! 5381: DAC 7 ! 5382: DTC /ENDFILE/ ! 5383: DAC S$ENF ! 5384: DAC 1 ! 5385: * ! 5386: V$ETX DBC SVKNM ERRTEXT ! 5387: DAC 7 ! 5388: DTC /ERRTEXT/ ! 5389: DAC K$ETX ! 5390: * ! 5391: V$ERT DBC SVKNM ERRTYPE ! 5392: DAC 7 ! 5393: DTC /ERRTYPE/ ! 5394: DAC K$ERT ! 5395: * ! 5396: V$FRT DBC SVLBL FRETURN ! 5397: DAC 7 ! 5398: DTC /FRETURN/ ! 5399: DAC L$FRT ! 5400: * ! 5401: V$INT DBC SVFPR INTEGER ! 5402: DAC 7 ! 5403: DTC /INTEGER/ ! 5404: DAC S$INT ! 5405: DAC 1 ! 5406: * ! 5407: V$NRT DBC SVLBL NRETURN ! 5408: DAC 7 ! 5409: DTC /NRETURN/ ! 5410: DAC L$NRT ! 5411: EJC ! 5412: * ! 5413: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 5414: * ! 5415: .IF .CNPF ! 5416: .ELSE ! 5417: * ! 5418: V$PFL DBC SVKNM PROFILE ! 5419: DAC 7 ! 5420: DTC /PROFILE/ ! 5421: DAC K$PFL ! 5422: .FI ! 5423: * ! 5424: V$RPL DBC SVFNP REPLACE ! 5425: DAC 7 ! 5426: DTC /REPLACE/ ! 5427: DAC S$RPL ! 5428: DAC 3 ! 5429: * ! 5430: V$RVS DBC SVFNP REVERSE ! 5431: DAC 7 ! 5432: DTC /REVERSE/ ! 5433: DAC S$RVS ! 5434: DAC 1 ! 5435: * ! 5436: V$RTN DBC SVKNM RTNTYPE ! 5437: DAC 7 ! 5438: DTC /RTNTYPE/ ! 5439: DAC K$RTN ! 5440: * ! 5441: V$STX DBC SVFNN SETEXIT ! 5442: DAC 7 ! 5443: DTC /SETEXIT/ ! 5444: DAC S$STX ! 5445: DAC 1 ! 5446: * ! 5447: V$STC DBC SVKNM STCOUNT ! 5448: DAC 7 ! 5449: DTC /STCOUNT/ ! 5450: DAC K$STC ! 5451: * ! 5452: V$STL DBC SVKNM STLIMIT ! 5453: DAC 7 ! 5454: DTC /STLIMIT/ ! 5455: DAC K$STL ! 5456: * ! 5457: V$SUC DBC SVKVC SUCCEED ! 5458: DAC 7 ! 5459: DTC /SUCCEED/ ! 5460: DAC K$SUC ! 5461: DAC NDSUC ! 5462: * ! 5463: V$ALP DBC SVKWC ALPHABET ! 5464: DAC 8 ! 5465: DTC /ALPHABET/ ! 5466: DAC K$ALP ! 5467: * ! 5468: V$CNT DBC SVLBL CONTINUE ! 5469: DAC 8 ! 5470: DTC /CONTINUE/ ! 5471: DAC L$CNT ! 5472: EJC ! 5473: * ! 5474: * STANDARD VARIABLE BLOCKS (CONTINUED) ! 5475: * ! 5476: V$DTP DBC SVFNP DATATYPE ! 5477: DAC 8 ! 5478: DTC /DATATYPE/ ! 5479: DAC S$DTP ! 5480: DAC 1 ! 5481: * ! 5482: V$ERL DBC SVKNM ERRLIMIT ! 5483: DAC 8 ! 5484: DTC /ERRLIMIT/ ! 5485: DAC K$ERL ! 5486: * ! 5487: V$FNC DBC SVKNM FNCLEVEL ! 5488: DAC 8 ! 5489: DTC /FNCLEVEL/ ! 5490: DAC K$FNC ! 5491: * ! 5492: V$MXL DBC SVKNM MAXLNGTH ! 5493: DAC 8 ! 5494: DTC /MAXLNGTH/ ! 5495: DAC K$MXL ! 5496: * ! 5497: V$TER DBC 0 TERMINAL ! 5498: DAC 8 ! 5499: DTC /TERMINAL/ ! 5500: DAC 0 ! 5501: * ! 5502: V$PRO DBC SVFNN PROTOTYPE ! 5503: DAC 9 ! 5504: DTC /PROTOTYPE/ ! 5505: DAC S$PRO ! 5506: DAC 1 ! 5507: * ! 5508: DBC 0 DUMMY ENTRY TO END LIST ! 5509: DAC 10 LENGTH GT 9 (PROTOTYPE) ! 5510: EJC ! 5511: * ! 5512: * LIST OF SVBLK POINTERS FOR KEYWORDS TO BE DUMPED. THE ! 5513: * LIST IS IN THE ORDER WHICH APPEARS ON THE DUMP OUTPUT. ! 5514: * ! 5515: VDMKW DAC V$ANC ANCHOR ! 5516: .IF .CULC ! 5517: DAC V$CAS CCASE ! 5518: .FI ! 5519: DAC V$COD CODE ! 5520: DAC V$DMP DUMP ! 5521: DAC V$ERL ERRLIMIT ! 5522: DAC V$ETX ERRTEXT ! 5523: DAC V$ERT ERRTYPE ! 5524: DAC V$FNC FNCLEVEL ! 5525: DAC V$FTR FTRACE ! 5526: DAC V$INP INPUT ! 5527: DAC V$LST LASTNO ! 5528: DAC V$MXL MAXLENGTH ! 5529: DAC V$OUP OUTPUT ! 5530: .IF .CNPF ! 5531: .ELSE ! 5532: DAC V$PFL PROFILE ! 5533: .FI ! 5534: DAC V$RTN RTNTYPE ! 5535: DAC V$STC STCOUNT ! 5536: DAC V$STL STLIMIT ! 5537: DAC V$STN STNO ! 5538: DAC V$TRA TRACE ! 5539: DAC V$TRM TRIM ! 5540: DAC 0 END OF LIST ! 5541: * ! 5542: * TABLE USED BY GTNVR TO SEARCH SVBLK LISTS ! 5543: * ! 5544: VSRCH DAC 0 DUMMY ENTRY TO GET PROPER INDEXING ! 5545: DAC V$EQF START OF 1 CHAR VARIABLES (NONE) ! 5546: DAC V$EQF START OF 2 CHAR VARIABLES ! 5547: DAC V$ANY START OF 3 CHAR VARIABLES ! 5548: .IF .CULC ! 5549: DAC V$CAS START OF 4 CHAR VARIABLES ! 5550: .ELSE ! 5551: DAC V$CHR START OF 4 CHAR VARIABLES ! 5552: .FI ! 5553: DAC V$ABE START OF 5 CHAR VARIABLES ! 5554: DAC V$ANC START OF 6 CHAR VARIABLES ! 5555: DAC V$COL START OF 7 CHAR VARIABLES ! 5556: DAC V$ALP START OF 8 CHAR VARIABLES ! 5557: DAC V$PRO START OF 9 CHAR VARIABLES ! 5558: TTL S P I T B O L -- WORKING STORAGE SECTION ! 5559: * ! 5560: * THE WORKING STORAGE SECTION CONTAINS AREAS WHICH ARE ! 5561: * CHANGED DURING EXECUTION OF THE PROGRAM. THE VALUE ! 5562: * ASSEMBLED IS THE INITIAL VALUE BEFORE EXECUTION STARTS. ! 5563: * ! 5564: * ALL THESE AREAS ARE FIXED LENGTH AREAS. VARIABLE LENGTH ! 5565: * DATA IS STORED IN THE STATIC OR DYNAMIC REGIONS OF THE ! 5566: * ALLOCATED DATA AREAS. ! 5567: * ! 5568: * THE VALUES IN THIS AREA ARE DESCRIBED EITHER AS WORK ! 5569: * AREAS OR AS GLOBAL VALUES. A WORK AREA IS USED IN AN ! 5570: * EPHEMERAL MANNER AND THE VALUE IS NOT SAVED FROM ONE ! 5571: * ENTRY INTO A ROUTINE TO ANOTHER. A GLOBAL VALUE IS A ! 5572: * LESS TEMPORARY LOCATION WHOSE VALUE IS SAVED FROM ONE ! 5573: * CALL TO ANOTHER. ! 5574: * ! 5575: * A GENERAL PART OF THE APPROACH IN THIS PROGRAM IS NOT ! 5576: * TO OVERLAP WORK AREAS BETWEEN PROCEDURES EVEN THOUGH A ! 5577: * SMALL AMOUNT OF SPACE COULD BE SAVED. SUCH OVERLAP IS ! 5578: * CONSIDERED A SOURCE OF PROGRAM ERRORS AND DECREASES THE ! 5579: * INFORMATION LEFT BEHIND AFTER A SYSTEM CRASH OF ANY KIND. ! 5580: * ! 5581: * THE NAMES OF THESE LOCATIONS ARE LABELS WITH FIVE LETTER ! 5582: * (A-Y,$) NAMES. AS FAR AS POSSIBLE THE ORDER IS KEPT ! 5583: * ALPHABETICAL BY THESE NAMES BUT IN SOME CASES THERE ! 5584: * ARE SLIGHT DEPARTURES CAUSED BY OTHER ORDER REQUIREMENTS. ! 5585: * ! 5586: * UNLESS OTHERWISE DOCUMENTED, THE ORDER OF WORK AREAS ! 5587: * DOES NOT AFFECT THE EXECUTION OF THE SPITBOL PROGRAM. ! 5588: * ! 5589: SEC START OF WORKING STORAGE SECTION ! 5590: EJC ! 5591: * ! 5592: * THIS AREA IS NOT CLEARED BY INITIAL CODE ! 5593: * ! 5594: CMLAB DAC B$SCL STRING USED TO CHECK LABEL LEGALITY ! 5595: DAC 2 ! 5596: DTC / / ! 5597: * ! 5598: * LABEL TO MARK START OF WORK AREA ! 5599: * ! 5600: AAAAA DAC 0 ! 5601: * ! 5602: * WORK AREAS FOR ALLOC PROCEDURE ! 5603: * ! 5604: ALDYN DAC 0 AMOUNT OF DYNAMIC STORE ! 5605: ALFSF DIC +0 FACTOR IN FREE STORE PCNTAGE CHECK ! 5606: ALLIA DIC +0 DUMP IA ! 5607: ALLSV DAC 0 SAVE WB IN ALLOC ! 5608: * ! 5609: * WORK AREAS FOR ALOST PROCEDURE ! 5610: * ! 5611: ALSTA DAC 0 SAVE WA IN ALOST ! 5612: * ! 5613: * SAVE AREAS FOR ARRAY FUNCTION (S$ARR) ! 5614: * ! 5615: ARCDM DAC 0 COUNT DIMENSIONS ! 5616: ARNEL DIC +0 COUNT ELEMENTS ! 5617: ARPTR DAC 0 OFFSET PTR INTO ARBLK ! 5618: ARSVL DIC +0 SAVE INTEGER LOW BOUND ! 5619: EJC ! 5620: * WORK AREAS FOR ARREF ROUTINE ! 5621: * ! 5622: ARFSI DIC +0 SAVE CURRENT EVOLVING SUBSCRIPT ! 5623: ARFXS DAC 0 SAVE BASE STACK POINTER ! 5624: * ! 5625: * WORK AREAS FOR B$EFC BLOCK ROUTINE ! 5626: * ! 5627: BEFOF DAC 0 SAVE OFFSET PTR INTO EFBLK ! 5628: * ! 5629: * WORK AREAS FOR B$PFC BLOCK ROUTINE ! 5630: * ! 5631: BPFPF DAC 0 SAVE PFBLK POINTER ! 5632: BPFSV DAC 0 SAVE OLD FUNCTION VALUE ! 5633: BPFXT DAC 0 POINTER TO STACKED ARGUMENTS ! 5634: * ! 5635: * SAVE AREAS FOR COLLECT FUNCTION (S$COL) ! 5636: * ! 5637: CLSVI DIC +0 SAVE INTEGER ARGUMENT ! 5638: * ! 5639: * GLOBAL VALUES FOR CMPIL PROCEDURE ! 5640: * ! 5641: CMERC DAC 0 COUNT OF INITIAL COMPILE ERRORS ! 5642: CMPXS DAC 0 SAVE STACK PTR IN CASE OF ERRORS ! 5643: CMPSN DAC 1 NUMBER OF NEXT STATEMENT TO COMPILE ! 5644: CMPSS DAC 0 SAVE SUBROUTINE STACK PTR ! 5645: * ! 5646: * WORK AREA FOR CNCRD ! 5647: * ! 5648: CNSCC DAC 0 POINTER TO CONTROL CARD STRING ! 5649: CNSWC DAC 0 WORD COUNT ! 5650: CNR$T DAC 0 POINTER TO R$TTL OR R$STL ! 5651: CNTTL DAC 0 FLAG FOR -TITLE, -STITL ! 5652: * ! 5653: * WORK AREAS FOR CONVERT FUNCTION (S$CNV) ! 5654: * ! 5655: CNVTP DAC 0 SAVE PTR INTO SCVTB ! 5656: * ! 5657: * FLAG FOR SUPPRESSION OF COMPILATION STATISTICS. ! 5658: * ! 5659: CPSTS DAC 0 SUPPRESS COMP. STATS IF NON ZERO ! 5660: * ! 5661: * GLOBAL VALUES FOR CONTROL CARD SWITCHES ! 5662: * ! 5663: CSWDB DAC 0 0/1 FOR -SINGLE/-DOUBLE ! 5664: CSWER DAC 0 0/1 FOR -ERRORS/-NOERRORS ! 5665: CSWEX DAC 0 0/1 FOR -EXECUTE/-NOEXECUTE ! 5666: CSWFL DAC 1 0/1 FOR -NOFAIL/-FAIL ! 5667: CSWIN DAC INILN XXX FOR -INXXX ! 5668: CSWLS DAC 1 0/1 FOR -NOLIST/-LIST ! 5669: CSWNO DAC 0 0/1 FOR -OPTIMISE/-NOOPT ! 5670: CSWPR DAC 0 0/1 FOR -NOPRINT/-PRINT ! 5671: * ! 5672: * GLOBAL LOCATION USED BY PATST PROCEDURE ! 5673: * ! 5674: CTMSK DBC 0 LAST BIT POSITION USED IN R$CTP ! 5675: CURID DAC 0 CURRENT ID VALUE ! 5676: EJC ! 5677: * ! 5678: * GLOBAL VALUE FOR CDWRD PROCEDURE ! 5679: * ! 5680: CWCOF DAC 0 NEXT WORD OFFSET IN CURRENT CCBLK ! 5681: * ! 5682: * WORK AREAS FOR DATA FUNCTION (S$DAT) ! 5683: * ! 5684: DATDV DAC 0 SAVE VRBLK PTR FOR DATATYPE NAME ! 5685: DATXS DAC 0 SAVE INITIAL STACK POINTER ! 5686: * ! 5687: * WORK AREAS FOR DEFINE FUNCTION (S$DEF) ! 5688: * ! 5689: DEFLB DAC 0 SAVE VRBLK PTR FOR LABEL ! 5690: DEFNA DAC 0 COUNT FUNCTION ARGUMENTS ! 5691: DEFVR DAC 0 SAVE VRBLK PTR FOR FUNCTION NAME ! 5692: DEFXS DAC 0 SAVE INITIAL STACK POINTER ! 5693: * ! 5694: * WORK AREAS FOR DUMPR PROCEDURE ! 5695: * ! 5696: DMARG DAC 0 DUMP ARGUMENT ! 5697: DMPKB DAC B$KVT DUMMY KVBLK FOR USE IN DUMPR ! 5698: DMPKT DAC TRBKV KVVAR TRBLK POINTER ! 5699: DMPKN DAC 0 KEYWORD NUMBER (MUST FOLLOW DMPKB) ! 5700: DMPSA DAC 0 PRESERVE WA OVER PRTVL CALL ! 5701: DMPSV DAC 0 GENERAL SCRATCH SAVE ! 5702: DMVCH DAC 0 CHAIN POINTER FOR VARIABLE BLOCKS ! 5703: DMPCH DAC 0 SAVE SORTED VRBLK CHAIN POINTER ! 5704: * ! 5705: * GLOBAL LOCATIONS FOR DYNAMIC STORAGE POINTERS ! 5706: * ! 5707: DNAMB DAC 0 START OF DYNAMIC AREA ! 5708: DNAMP DAC 0 NEXT AVAILABLE LOC IN DYNAMIC AREA ! 5709: DNAME DAC 0 END OF AVAILABLE DYNAMIC AREA ! 5710: * ! 5711: * WORK AREA FOR DTACH ! 5712: * ! 5713: DTCNB DAC 0 NAME BASE ! 5714: DTCNM DAC 0 NAME PTR ! 5715: * ! 5716: * WORK AREAS FOR DUPL FUNCTION (S$DUP) ! 5717: * ! 5718: DUPSI DIC +0 STORE INTEGER STRING LENGTH ! 5719: * ! 5720: * WORK AREA FOR ENDFILE (S$ENF) ! 5721: * ! 5722: ENFCH DAC 0 FOR IOCHN CHAIN HEAD ! 5723: * ! 5724: * WORK AREA FOR ERROR PROCESSING. ! 5725: * ! 5726: ERICH DAC 0 COPY ERROR REPORTS TO INT.CHAN IF 1 ! 5727: ERLST DAC 0 FOR LISTR WHEN ERRORS GO TO INT.CH. ! 5728: ERRFT DAC 0 FATAL ERROR FLAG ! 5729: ERRSP DAC 0 ERROR SUPPRESSION FLAG ! 5730: EJC ! 5731: * ! 5732: * DUMP AREA FOR ERTEX ! 5733: * ! 5734: ERTWA DAC 0 SAVE WA ! 5735: ERTWB DAC 0 SAVE WB ! 5736: * ! 5737: * GLOBAL VALUES FOR EVALI ! 5738: * ! 5739: EVLIN DAC P$LEN DUMMY PATTERN BLOCK PCODE ! 5740: EVLIS DAC 0 POINTER TO SUBSEQUENT NODE ! 5741: EVLIV DAC 0 VALUE OF PARAMETER ! 5742: * WORK AREA FOR EXPAN ! 5743: * ! 5744: EXPSV DAC 0 SAVE OP DOPE VECTOR POINTER ! 5745: * ! 5746: * FLAG FOR SUPPRESSION OF EXECUTION STATS ! 5747: * ! 5748: EXSTS DAC 0 SUPPRESS EXEC STATS IF SET ! 5749: * ! 5750: * GLOBAL VALUES FOR EXFAL AND RETURN ! 5751: * ! 5752: FLPRT DAC 0 LOCATION OF FAIL OFFSET FOR RETURN ! 5753: FLPTR DAC 0 LOCATION OF FAILURE OFFSET ON STACK ! 5754: * ! 5755: * WORK AREAS FOR GBCOL PROCEDURE ! 5756: * ! 5757: GBCFL DAC 0 GARBAGE COLLECTOR ACTIVE FLAG ! 5758: GBCLM DAC 0 POINTER TO LAST MOVE BLOCK (PASS 3) ! 5759: GBCNM DAC 0 DUMMY FIRST MOVE BLOCK ! 5760: GBCNS DAC 0 REST OF DUMMY BLOCK (FOLLOWS GBCNM) ! 5761: GBSVA DAC 0 SAVE WA ! 5762: GBSVB DAC 0 SAVE WB ! 5763: GBSVC DAC 0 SAVE WC ! 5764: * ! 5765: * GLOBAL LOCATION TO COUNT GARBAGE COLLECTIONS (GBCOL) ! 5766: * ! 5767: GBCNT DAC 0 COUNT OF GARBAGE COLLECTIONS ! 5768: * ! 5769: * WORK AREAS FOR GTNVR PROCEDURE ! 5770: * ! 5771: GNVHE DAC 0 PTR TO END OF HASH CHAIN ! 5772: GNVNW DAC 0 NUMBER OF WORDS IN STRING NAME ! 5773: GNVSA DAC 0 SAVE WA ! 5774: GNVSB DAC 0 SAVE WB ! 5775: GNVSP DAC 0 POINTER INTO VSRCH TABLE ! 5776: GNVST DAC 0 POINTER TO CHARS OF STRING ! 5777: * ! 5778: * GLOBAL VALUE FOR GTCOD AND GTEXP ! 5779: * ! 5780: GTCEF DAC 0 SAVE FAIL PTR IN CASE OF ERROR ! 5781: * ! 5782: * WORK AREAS FOR GTINT ! 5783: * ! 5784: GTINA DAC 0 SAVE WA ! 5785: GTINB DAC 0 SAVE WB ! 5786: EJC ! 5787: * ! 5788: * WORK AREAS FOR GTNUM PROCEDURE ! 5789: * ! 5790: GTNNF DAC 0 ZERO/NONZERO FOR RESULT +/- ! 5791: GTNSI DIC +0 GENERAL INTEGER SAVE ! 5792: .IF .CNRA ! 5793: .ELSE ! 5794: GTNDF DAC 0 0/1 FOR DEC POINT SO FAR NO/YES ! 5795: GTNES DAC 0 ZERO/NONZERO EXPONENT +/- ! 5796: GTNEX DIC +0 REAL EXPONENT ! 5797: GTNSC DAC 0 SCALE (PLACES AFTER POINT) ! 5798: GTNSR DRC +0.0 GENERAL REAL SAVE ! 5799: GTNRD DAC 0 FLAG FOR OK REAL NUMBER ! 5800: .FI ! 5801: * ! 5802: * WORK AREAS FOR GTPAT PROCEDURE ! 5803: * ! 5804: GTPSB DAC 0 SAVE WB ! 5805: * ! 5806: * WORK AREAS FOR GTSTG PROCEDURE ! 5807: * ! 5808: GTSSF DAC 0 0/1 FOR RESULT +/- ! 5809: GTSVC DAC 0 SAVE WC ! 5810: GTSVB DAC 0 SAVE WB ! 5811: GTSWK DAC 0 PTR TO WORK AREA FOR GTSTG ! 5812: .IF .CNRA ! 5813: .ELSE ! 5814: GTSES DAC 0 CHAR + OR - FOR EXPONENT +/- ! 5815: GTSRS DRC +0.0 GENERAL REAL SAVE ! 5816: * ! 5817: * GLOBAL LOCATIONS (CONSTANTS) FOR GTSTG PROCEDURE ! 5818: * ! 5819: GTSRN DRC +0.0 ROUNDING FACTOR 0.5*10**-CFP$S ! 5820: GTSSC DRC +0.0 SCALING VALUE 10**CFP$S ! 5821: .FI ! 5822: * ! 5823: * WORK AREAS FOR GTVAR PROCEDURE ! 5824: * ! 5825: GTVRC DAC 0 SAVE WC ! 5826: * ! 5827: * FLAG FOR HEADER PRINTING ! 5828: * ! 5829: HEADP DAC 0 HEADER PRINTED FLAG ! 5830: * ! 5831: * GLOBAL VALUES FOR VARIABLE HASH TABLE ! 5832: * ! 5833: HSHNB DIC +0 NUMBER OF HASH BUCKETS ! 5834: HSHTB DAC 0 POINTER TO START OF VRBLK HASH TABL ! 5835: HSHTE DAC 0 POINTER PAST END OF VRBLK HASH TABL ! 5836: * ! 5837: * WORK AREA FOR INIT ! 5838: * ! 5839: INISS DAC 0 SAVE SUBROUTINE STACK PTR ! 5840: INITR DAC 0 SAVE TERMINAL FLAG ! 5841: .IF .CNBF ! 5842: .ELSE ! 5843: * ! 5844: * SAVE AREA FOR INSBF ! 5845: * ! 5846: INSAB DAC 0 ENTRY WA + ENTRY WB ! 5847: INSSA DAC 0 SAVE ENTRY WA ! 5848: INSSB DAC 0 SAVE ENTRY WB ! 5849: INSSC DAC 0 SAVE ENTRY WC ! 5850: .FI ! 5851: * ! 5852: * WORK AREAS FOR IOPUT ! 5853: * ! 5854: IOPTT DAC 0 TYPE OF ASSOCIATION ! 5855: EJC ! 5856: * ! 5857: * GLOBAL VALUES FOR KEYWORD VALUES WHICH ARE STORED AS ONE ! 5858: * WORD INTEGERS. THESE VALUES MUST BE ASSEMBLED IN THE ! 5859: * FOLLOWING ORDER (AS DICTATED BY K$XXX DEFINITION VALUES). ! 5860: * ! 5861: KVABE DAC 0 ABEND ! 5862: KVANC DAC 0 ANCHOR ! 5863: .IF .CULC ! 5864: KVCAS DAC 0 CASE ! 5865: .FI ! 5866: KVCOD DAC 0 CODE ! 5867: KVDMP DAC 0 DUMP ! 5868: KVERL DAC 0 ERRLIMIT ! 5869: KVERT DAC 0 ERRTYPE ! 5870: KVFTR DAC 0 FTRACE ! 5871: KVINP DAC 1 INPUT ! 5872: KVMXL DAC 5000 MAXLENGTH ! 5873: KVOUP DAC 1 OUTPUT ! 5874: .IF .CNPF ! 5875: .ELSE ! 5876: KVPFL DAC 0 PROFILE ! 5877: .FI ! 5878: KVTRA DAC 0 TRACE ! 5879: KVTRM DAC 0 TRIM ! 5880: KVFNC DAC 0 FNCLEVEL ! 5881: KVLST DAC 0 LASTNO ! 5882: KVSTN DAC 0 STNO ! 5883: * ! 5884: * GLOBAL VALUES FOR OTHER KEYWORDS ! 5885: * ! 5886: KVALP DAC 0 ALPHABET ! 5887: KVRTN DAC NULLS RTNTYPE (SCBLK POINTER) ! 5888: KVSTL DIC +50000 STLIMIT ! 5889: KVSTC DIC +50000 STCOUNT (COUNTS DOWN FROM STLIMIT) ! 5890: .IF .CNLD ! 5891: .ELSE ! 5892: * ! 5893: * WORK AREAS FOR LOAD FUNCTION ! 5894: * ! 5895: LODFN DAC 0 POINTER TO VRBLK FOR FUNC NAME ! 5896: LODNA DAC 0 COUNT NUMBER OF ARGUMENTS ! 5897: .FI ! 5898: * ! 5899: * GLOBAL VALUES FOR LISTR PROCEDURE ! 5900: * ! 5901: LSTLC DAC 0 COUNT LINES ON SOURCE LIST PAGE ! 5902: LSTNP DAC 0 MAX NUMBER OF LINES ON PAGE ! 5903: LSTPF DAC 1 SET NONZERO IF CURRENT IMAGE LISTED ! 5904: LSTPG DAC 0 CURRENT SOURCE LIST PAGE NUMBER ! 5905: LSTPO DAC 0 OFFSET TO PAGE NNN MESSAGE ! 5906: LSTSN DAC 0 REMEMBER LAST STMNUM LISTED ! 5907: * ! 5908: * MAXIMUM SIZE OF SPITBOL OBJECTS ! 5909: * ! 5910: MXLEN DAC 0 INITIALISED BY SYSMX CALL ! 5911: * ! 5912: * EXECUTION CONTROL VARIABLE ! 5913: * ! 5914: NOXEQ DAC 0 SET NON-ZERO TO INHIBIT EXECUTION ! 5915: .IF .CNPF ! 5916: .ELSE ! 5917: * ! 5918: * PROFILER GLOBAL VALUES AND WORK LOCATIONS ! 5919: * ! 5920: PFDMP DAC 0 SET NON-0 IF &PROFILE SET NON-0 ! 5921: PFFNC DAC 0 SET NON-0 IF FUNCT JUST ENTERED ! 5922: PFSTM DIC +0 TO STORE STARTING TIME OF STMT ! 5923: PFETM DIC +0 TO STORE ENDING TIME OF STMT ! 5924: PFSVW DAC 0 TO SAVE A W-REG ! 5925: PFTBL DAC 0 GETS ADRS OF (IMAG) TABLE BASE ! 5926: PFNTE DAC 0 NR OF TABLE ENTRIES ! 5927: PFSTE DIC +0 GETS INT REP OF TABLE ENTRY SIZE ! 5928: .FI ! 5929: * ! 5930: EJC ! 5931: * ! 5932: * GLOBAL VALUES USED IN PATTERN MATCH ROUTINES ! 5933: * ! 5934: PMDFL DAC 0 PATTERN ASSIGNMENT FLAG ! 5935: PMHBS DAC 0 HISTORY STACK BASE POINTER ! 5936: PMSSL DAC 0 LENGTH OF SUBJECT STRING IN CHARS ! 5937: * ! 5938: * FLAGS USED FOR STANDARD FILE LISTING OPTIONS ! 5939: * ! 5940: PRICH DAC 0 PRINTER ON INTERACTIVE CHANNEL ! 5941: PRSTD DAC 0 TESTED BY PRTPG ! 5942: PRSTO DAC 0 STANDARD LISTING OPTION FLAG ! 5943: * ! 5944: * GLOBAL VALUE FOR PRTNM PROCEDURE ! 5945: * ! 5946: PRNMV DAC 0 VRBLK PTR FROM LAST NAME SEARCH ! 5947: * ! 5948: * WORK AREAS FOR PRTNM PROCEDURE ! 5949: * ! 5950: PRNSI DIC +0 SCRATCH INTEGER LOC ! 5951: * ! 5952: * WORK AREAS FOR PRTSN PROCEDURE ! 5953: * ! 5954: PRSNA DAC 0 SAVE WA ! 5955: * ! 5956: * GLOBAL VALUES FOR PRINT PROCEDURES ! 5957: * ! 5958: PRBUF DAC 0 PTR TO PRINT BFR IN STATIC ! 5959: PRECL DAC 0 EXTENDED/COMPACT LISTING FLAG ! 5960: PRLEN DAC 0 LENGTH OF PRINT BUFFER IN CHARS ! 5961: PRLNW DAC 0 LENGTH OF PRINT BUFFER IN WORDS ! 5962: PROFS DAC 0 OFFSET TO NEXT LOCATION IN PRBUF ! 5963: PRTEF DAC 0 ENDFILE FLAG ! 5964: * ! 5965: * WORK AREAS FOR PRTST PROCEDURE ! 5966: * ! 5967: PRSVA DAC 0 SAVE WA ! 5968: PRSVB DAC 0 SAVE WB ! 5969: PRSVC DAC 0 SAVE CHAR COUNTER ! 5970: * ! 5971: * WORK AREA FOR PRTNL ! 5972: * ! 5973: PRTSA DAC 0 SAVE WA ! 5974: PRTSB DAC 0 SAVE WB ! 5975: * ! 5976: * WORK AREA FOR PRTVL ! 5977: * ! 5978: PRVSI DAC 0 SAVE IDVAL ! 5979: * ! 5980: * WORK AREAS FOR PATTERN MATCH ROUTINES ! 5981: * ! 5982: PSAVE DAC 0 TEMPORARY SAVE FOR CURRENT NODE PTR ! 5983: PSAVC DAC 0 SAVE CURSOR IN P$SPN, P$STR ! 5984: EJC ! 5985: * ! 5986: * AMOUNT OF MEMORY RESERVED FOR END OF EXECUTION ! 5987: * ! 5988: RSMEM DAC 0 RESERVE MEMORY ! 5989: * ! 5990: * WORK AREAS FOR RETRN ROUTINE ! 5991: * ! 5992: RTNBP DAC 0 TO SAVE A BLOCK POINTER ! 5993: RTNFV DAC 0 NEW FUNCTION VALUE (RESULT) ! 5994: RTNSV DAC 0 OLD FUNCTION VALUE (SAVED VALUE) ! 5995: * ! 5996: * RELOCATABLE GLOBAL VALUES ! 5997: * ! 5998: * ALL THE POINTERS IN THIS SECTION CAN POINT TO BLOCKS IN ! 5999: * THE DYNAMIC STORAGE AREA AND MUST BE RELOCATED BY THE ! 6000: * GARBAGE COLLECTOR. THEY ARE IDENTIFIED BY R$XXX NAMES. ! 6001: * ! 6002: R$AAA DAC 0 START OF RELOCATABLE VALUES ! 6003: R$ARF DAC 0 ARRAY BLOCK POINTER FOR ARREF ! 6004: R$CCB DAC 0 PTR TO CCBLK BEING BUILT (CDWRD) ! 6005: R$CIM DAC 0 PTR TO CURRENT COMPILER INPUT STR ! 6006: R$CMP DAC 0 COPY OF R$CIM USED IN CMPIL ! 6007: R$CNI DAC 0 PTR TO NEXT COMPILER INPUT STRING ! 6008: R$CNT DAC 0 CDBLK POINTER FOR SETEXIT CONTINUE ! 6009: R$COD DAC 0 POINTER TO CURRENT CDBLK OR EXBLK ! 6010: R$CTP DAC 0 PTR TO CURRENT CTBLK FOR PATST ! 6011: R$ERT DAC 0 TRBLK POINTER FOR ERRTYPE TRACE ! 6012: R$ETX DAC NULLS POINTER TO ERRTEXT STRING ! 6013: R$EXS DAC 0 = SAVE XL IN EXPDM ! 6014: R$FCB DAC 0 FCBLK CHAIN HEAD ! 6015: R$FNC DAC 0 TRBLK POINTER FOR FNCLEVEL TRACE ! 6016: R$GTC DAC 0 KEEP CODE PTR FOR GTCOD,GTEXP ! 6017: R$IO1 DAC 0 FILE ARG1 FOR IOPUT ! 6018: R$IO2 DAC 0 FILE ARG2 FOR IOPUT ! 6019: R$IOF DAC 0 FCBLK PTR OR 0 ! 6020: R$ION DAC 0 NAME BASE PTR ! 6021: R$IOP DAC 0 PREDECESSOR BLOCK PTR FOR IOPUT ! 6022: R$IOT DAC 0 TRBLK PTR FOR IOPUT ! 6023: .IF .CNBF ! 6024: .ELSE ! 6025: R$PMB DAC 0 BUFFER PTR IN PATTERN MATCH ! 6026: .FI ! 6027: R$PMS DAC 0 SUBJECT STRING PTR IN PATTERN MATCH ! 6028: R$RA2 DAC 0 REPLACE SECOND ARGUMENT LAST TIME ! 6029: R$RA3 DAC 0 REPLACE THIRD ARGUMENT LAST TIME ! 6030: R$RPT DAC 0 PTR TO CTBLK REPLACE TABLE LAST USD ! 6031: R$SCP DAC 0 SAVE POINTER FROM LAST SCANE CALL ! 6032: R$SXL DAC 0 PRESERVE XL IN SORTC ! 6033: R$SXR DAC 0 PRESERVE XR IN SORTA/SORTC ! 6034: R$STC DAC 0 TRBLK POINTER FOR STCOUNT TRACE ! 6035: R$STL DAC 0 SOURCE LISTING SUB-TITLE ! 6036: R$SXC DAC 0 CODE (CDBLK) PTR FOR SETEXIT TRAP ! 6037: R$TTL DAC NULLS SOURCE LISTING TITLE ! 6038: R$XSC DAC 0 STRING POINTER FOR XSCAN ! 6039: EJC ! 6040: * ! 6041: * THE REMAINING POINTERS IN THIS LIST ARE USED TO POINT ! 6042: * TO FUNCTION BLOCKS FOR NORMALLY UNDEFINED OPERATORS. ! 6043: * ! 6044: R$UBA DAC STNDO BINARY AT ! 6045: R$UBM DAC STNDO BINARY AMPERSAND ! 6046: R$UBN DAC STNDO BINARY NUMBER SIGN ! 6047: R$UBP DAC STNDO BINARY PERCENT ! 6048: R$UBT DAC STNDO BINARY NOT ! 6049: R$UUB DAC STNDO UNARY VERTICAL BAR ! 6050: R$UUE DAC STNDO UNARY EQUAL ! 6051: R$UUN DAC STNDO UNARY NUMBER SIGN ! 6052: R$UUP DAC STNDO UNARY PERCENT ! 6053: R$UUS DAC STNDO UNARY SLASH ! 6054: R$UUX DAC STNDO UNARY EXCLAMATION ! 6055: R$YYY DAC 0 LAST RELOCATABLE LOCATION ! 6056: * ! 6057: * WORK AREAS FOR SUBSTR FUNCTION (S$SUB) ! 6058: * ! 6059: SBSSV DAC 0 SAVE THIRD ARGUMENT ! 6060: * ! 6061: * GLOBAL LOCATIONS USED IN SCAN PROCEDURE ! 6062: * ! 6063: SCNBL DAC 0 SET NON-ZERO IF SCANNED PAST BLANKS ! 6064: SCNCC DAC 0 NON-ZERO TO SCAN CONTROL CARD NAME ! 6065: SCNGO DAC 0 SET NON-ZERO TO SCAN GOTO FIELD ! 6066: SCNIL DAC 0 LENGTH OF CURRENT INPUT IMAGE ! 6067: SCNPT DAC 0 POINTER TO NEXT LOCATION IN R$CIM ! 6068: SCNRS DAC 0 SET NON-ZERO TO SIGNAL RESCAN ! 6069: SCNTP DAC 0 SAVE SYNTAX TYPE FROM LAST CALL ! 6070: * ! 6071: * WORK AREAS FOR SCAN PROCEDURE ! 6072: * ! 6073: SCNSA DAC 0 SAVE WA ! 6074: SCNSB DAC 0 SAVE WB ! 6075: SCNSC DAC 0 SAVE WC ! 6076: SCNSE DAC 0 START OF CURRENT ELEMENT ! 6077: SCNOF DAC 0 SAVE OFFSET ! 6078: .IF .CNSR ! 6079: .ELSE ! 6080: EJC ! 6081: * ! 6082: * WORK AREA USED BY SORTA, SORTC, SORTF, SORTH ! 6083: * ! 6084: SRTDF DAC 0 DATATYPE FIELD NAME ! 6085: SRTFD DAC 0 FOUND DFBLK ADDRESS ! 6086: SRTFF DAC 0 FOUND FIELD NAME ! 6087: SRTFO DAC 0 OFFSET TO FIELD NAME ! 6088: SRTNR DAC 0 NUMBER OF ROWS ! 6089: SRTOF DAC 0 OFFSET WITHIN ROW TO SORT KEY ! 6090: SRTRT DAC 0 ROOT OFFSET ! 6091: SRTS1 DAC 0 SAVE OFFSET 1 ! 6092: SRTS2 DAC 0 SAVE OFFSET 2 ! 6093: SRTSC DAC 0 SAVE WC ! 6094: SRTSF DAC 0 SORT ARRAY FIRST ROW OFFSET ! 6095: SRTSN DAC 0 SAVE N ! 6096: SRTSO DAC 0 OFFSET TO A(0) ! 6097: SRTSR DAC 0 0 , NON-ZERO FOR SORT, RSORT ! 6098: SRTST DAC 0 STRIDE FROM ONE ROW TO NEXT ! 6099: SRTWC DAC 0 DUMP WC ! 6100: .FI ! 6101: * ! 6102: * GLOBAL VALUE FOR INDICATING STAGE (SEE ERROR SECTION) ! 6103: * ! 6104: STAGE DAC 0 INITIAL VALUE = INITIAL COMPILE ! 6105: * ! 6106: * GLOBAL VALUES DEFINING EXTENT OF STATIC AREA (ALOST) ! 6107: * ! 6108: STATB DAC 0 START OF STATIC AREA ! 6109: STATE DAC 0 END OF STATIC AREA ! 6110: EJC ! 6111: * ! 6112: * GLOBAL STACK POINTER ! 6113: * ! 6114: STBAS DAC 0 POINTER PAST STACK BASE ! 6115: * ! 6116: * WORK AREAS FOR STOPR ROUTINE ! 6117: * ! 6118: STPSI DIC +0 SAVE VALUE OF STCOUNT ! 6119: STPTI DIC +0 SAVE TIME ELAPSED ! 6120: * ! 6121: * GLOBAL VALUES FOR SETEXIT FUNCTION (S$STX) ! 6122: * ! 6123: STXOF DAC 0 FAILURE OFFSET ! 6124: STXVR DAC NULLS VRBLK POINTER OR NULL ! 6125: * ! 6126: * WORK AREAS FOR TFIND PROCEDURE ! 6127: * ! 6128: TFNSI DIC +0 NUMBER OF HEADERS ! 6129: * ! 6130: * GLOBAL VALUE FOR TIME KEEPING ! 6131: * ! 6132: TIMSX DIC +0 TIME AT START OF EXECUTION ! 6133: TIMUP DAC 0 SET WHEN TIME UP OCCURS ! 6134: * ! 6135: * WORK AREAS FOR XSCAN PROCEDURE ! 6136: * ! 6137: XSCRT DAC 0 SAVE RETURN CODE ! 6138: XSCWB DAC 0 SAVE REGISTER WB ! 6139: * ! 6140: * GLOBAL VALUES FOR XSCAN AND XSCNI PROCEDURES ! 6141: * ! 6142: XSOFS DAC 0 OFFSET TO CURRENT LOCATION IN R$XSC ! 6143: * ! 6144: * LABEL TO MARK END OF WORK AREA ! 6145: * ! 6146: YYYYY DAC 0 ! 6147: TTL S P I T B O L -- INITIALIZATION ! 6148: * ! 6149: * INITIALISATION ! 6150: * THE FOLLOWING SECTION RECEIVES CONTROL FROM THE SYSTEM ! 6151: * AT THE START OF A RUN WITH THE REGISTERS SET AS FOLLOWS. ! 6152: * ! 6153: * (XS) POINTS PAST STACK BASE ! 6154: * (XR) POINTS TO FIRST WORD OF DATA AREA ! 6155: * (XL) POINTS TO LAST WORD OF DATA AREA ! 6156: * ! 6157: SEC START OF PROGRAM SECTION ! 6158: JSR SYSTM INITIALISE TIMER ! 6159: .IF .CNBT ! 6160: STI TIMSX STORE TIME ! 6161: MOV XR,STATB START ADDRESS OF STATIC ! 6162: .ELSE ! 6163: * ! 6164: * INITIALISE WORK AREA (ESSENTIAL FOR BATCHED RUNS) ! 6165: * ! 6166: MOV XR,WB PRESERVE XR ! 6167: MOV =YYYYY,WA POINT TO END OF WORK AREA ! 6168: SUB =AAAAA,WA GET LENGTH OF WORK AREA ! 6169: BTW WA CONVERT TO WORDS ! 6170: LCT WA,WA COUNT FOR LOOP ! 6171: MOV =AAAAA,XR SET UP INDEX REGISTER ! 6172: * ! 6173: * CLEAR WORK SPACE ! 6174: * ! 6175: INI01 ZER (XR)+ CLEAR A WORD ! 6176: BCT WA,INI01 LOOP TILL DONE ! 6177: MOV =STNDO,WA UNDEFINED OPERATORS POINTER ! 6178: MOV =R$YYY,WC POINT TO TABLE END ! 6179: SUB =R$UBA,WC LENGTH OF UNDEF. OPERATORS TABLE ! 6180: BTW WC CONVERT TO WORDS ! 6181: LCT WC,WC LOOP COUNTER ! 6182: MOV =R$UBA,XR SET UP XR ! 6183: * ! 6184: * SET CORRECT VALUE INTO UNDEFINED OPERATORS TABLE ! 6185: * ! 6186: INI02 MOV WA,(XR)+ STORE VALUE ! 6187: BCT WC,INI02 LOOP TILL ALL DONE ! 6188: MOV =NUM01,WA GET A 1 ! 6189: MOV WA,CMPSN STATEMENT NO ! 6190: MOV WA,CSWFL NOFAIL ! 6191: MOV WA,CSWLS LIST ! 6192: MOV WA,KVINP INPUT ! 6193: MOV WA,KVOUP OUTPUT ! 6194: MOV WA,LSTPF NOTHING FOR LISTR YET ! 6195: MOV =INILN,WA INPUT IMAGE LENGTH ! 6196: MOV WA,CSWIN -IN72 ! 6197: MOV =B$KVT,DMPKB DUMP ! 6198: MOV =TRBKV,DMPKT DUMP ! 6199: MOV =P$LEN,EVLIN EVAL ! 6200: EJC ! 6201: MOV =NULLS,WA GET NULLSTRING POINTER ! 6202: MOV WA,KVRTN RETURN ! 6203: MOV WA,R$ETX ERRTEXT ! 6204: MOV WA,R$TTL TITLE FOR LISTING ! 6205: MOV WA,STXVR SETEXIT ! 6206: STI TIMSX STORE TIME IN CORRECT PLACE ! 6207: LDI STLIM GET DEFAULT STLIMIT ! 6208: STI KVSTL STATEMENT LIMIT ! 6209: STI KVSTC STATEMENT COUNT ! 6210: MOV WB,STATB STORE START ADRS OF STATIC ! 6211: .FI ! 6212: MOV *E$SRS,RSMEM RESERVE MEMORY ! 6213: MOV XS,STBAS STORE STACK BASE ! 6214: SSS INISS SAVE S-R STACK PTR ! 6215: * ! 6216: * NOW CONVERT FREE STORE PERCENTAGE TO A SUITABLE FACTOR ! 6217: * FOR EASY TESTING IN ALLOC ROUTINE. ! 6218: * ! 6219: LDI INTVH GET 100 ! 6220: DVI ALFSP FORM 100 / ALFSP ! 6221: STI ALFSF STORE THE FACTOR ! 6222: .IF .CNRA ! 6223: .ELSE ! 6224: * ! 6225: * INITIALIZE VALUES FOR REAL CONVERSION ROUTINE ! 6226: * ! 6227: LCT WB,=CFP$S LOAD COUNTER FOR SIGNIFICANT DIGITS ! 6228: LDR REAV1 LOAD 1.0 ! 6229: * ! 6230: * LOOP TO COMPUTE 10**(MAX NUMBER SIGNIFICANT DIGITS) ! 6231: * ! 6232: INI03 MLR REAVT * 10.0 ! 6233: BCT WB,INI03 LOOP TILL DONE ! 6234: STR GTSSC STORE 10**(MAX SIG DIGITS) ! 6235: LDR REAP5 LOAD 0.5 ! 6236: DVR GTSSC COMPUTE 0.5*10**(MAX SIG DIGITS) ! 6237: STR GTSRN STORE AS ROUNDING BIAS ! 6238: .FI ! 6239: ZER WC SET TO READ PARAMETERS ! 6240: JSR PRPAR READ THEM ! 6241: EJC ! 6242: * ! 6243: * NOW COMPUTE STARTING ADDRESS FOR DYNAMIC STORE AND IF ! 6244: * NECESSARY REQUEST MORE MEMORY. ! 6245: * ! 6246: SUB *E$SRS,XL ALLOW FOR RESERVE MEMORY ! 6247: MOV PRLEN,WA GET PRINT BUFFER LENGTH ! 6248: ADD =CFP$A,WA ADD NO. OF CHARS IN ALPHABET ! 6249: ADD =NSTMX,WA ADD CHARS FOR GTSTG BFR ! 6250: CTB WA,8 CONVERT TO BYTES, ALLOWING A MARGIN ! 6251: MOV STATB,XR POINT TO STATIC BASE ! 6252: ADD WA,XR INCREMENT FOR ABOVE BUFFERS ! 6253: ADD *E$HNB,XR INCREMENT FOR HASH TABLE ! 6254: ADD *E$STS,XR BUMP FOR INITIAL STATIC BLOCK ! 6255: JSR SYSMX GET MXLEN ! 6256: MOV WA,KVMXL PROVISIONALLY STORE AS MAXLNGTH ! 6257: MOV WA,MXLEN AND AS MXLEN ! 6258: BGT XR,WA,INI06 SKIP IF STATIC HI EXCEEDS MXLEN ! 6259: MOV WA,XR USE MXLEN INSTEAD ! 6260: ICA XR MAKE BIGGER THAN MXLEN ! 6261: * ! 6262: * HERE TO STORE VALUES WHICH MARK INITIAL DIVISION ! 6263: * OF DATA AREA INTO STATIC AND DYNAMIC ! 6264: * ! 6265: INI06 MOV XR,DNAMB DYNAMIC BASE ADRS ! 6266: MOV XR,DNAMP DYNAMIC PTR ! 6267: BNZ WA,INI07 SKIP IF NON-ZERO MXLEN ! 6268: DCA XR POINT A WORD IN FRONT ! 6269: MOV XR,KVMXL USE AS MAXLNGTH ! 6270: MOV XR,MXLEN AND AS MXLEN ! 6271: EJC ! 6272: * ! 6273: * LOOP HERE IF NECESSARY TILL ENOUGH MEMORY OBTAINED ! 6274: * SO THAT DNAME IS ABOVE DNAMB ! 6275: * ! 6276: INI07 MOV XL,DNAME STORE DYNAMIC END ADDRESS ! 6277: BLT DNAMB,XL,INI09 SKIP IF HIGH ENOUGH ! 6278: JSR SYSMM REQUEST MORE MEMORY ! 6279: WTB XR GET AS BAUS (SGD05) ! 6280: ADD XR,XL BUMP BY AMOUNT OBTAINED ! 6281: BNZ XR,INI07 TRY AGAIN ! 6282: MOV =ENDMO,XR POINT TO FAILURE MESSAGE ! 6283: MOV ENDML,WA MESSAGE LENGTH ! 6284: JSR SYSPR PRINT IT (PRTST NOT YET USABLE) ! 6285: PPM SHOULD NOT FAIL ! 6286: JSR SYSEJ PACK UP (STOPR NOT YET USABLE) ! 6287: * ! 6288: * INITIALISE PRINT BUFFER WITH BLANK WORDS ! 6289: * ! 6290: INI09 MOV PRLEN,WC NO. OF CHARS IN PRINT BFR ! 6291: MOV STATB,XR POINT TO STATIC AGAIN ! 6292: MOV XR,PRBUF PRINT BFR IS PUT AT STATIC START ! 6293: MOV =B$SCL,(XR)+ STORE STRING TYPE CODE ! 6294: MOV WC,(XR)+ AND STRING LENGTH ! 6295: CTW WC,0 GET NUMBER OF WORDS IN BUFFER ! 6296: MOV WC,PRLNW STORE FOR BUFFER CLEAR ! 6297: LCT WC,WC WORDS TO CLEAR ! 6298: * ! 6299: * LOOP TO CLEAR BUFFER ! 6300: * ! 6301: INI10 MOV NULLW,(XR)+ STORE BLANK ! 6302: BCT WC,INI10 LOOP ! 6303: * ! 6304: * INITIALIZE NUMBER OF HASH HEADERS ! 6305: * ! 6306: MOV =E$HNB,WA GET NUMBER OF HASH HEADERS ! 6307: MTI WA CONVERT TO INTEGER ! 6308: STI HSHNB STORE FOR USE BY GTNVR PROCEDURE ! 6309: LCT WA,WA COUNTER FOR CLEARING HASH TABLE ! 6310: MOV XR,HSHTB POINTER TO HASH TABLE ! 6311: * ! 6312: * LOOP TO CLEAR HASH TABLE ! 6313: * ! 6314: INI11 ZER (XR)+ BLANK A WORD ! 6315: BCT WA,INI11 LOOP ! 6316: MOV XR,HSHTE END OF HASH TABLE ADRS IS KEPT ! 6317: * ! 6318: * ALLOCATE WORK AREA FOR GTSTG CONVERSION PROCEDURE ! 6319: * ! 6320: MOV =NSTMX,WA GET MAX NUM CHARS IN OUTPUT NUMBER ! 6321: CTB WA,SCSI$ NO OF BYTES NEEDED ! 6322: MOV XR,GTSWK STORE BFR ADRS ! 6323: ADD WA,XR BUMP FOR WORK BFR ! 6324: EJC ! 6325: * ! 6326: * BUILD ALPHABET STRING FOR ALPHABET KEYWORD AND REPLACE ! 6327: * ! 6328: MOV XR,KVALP SAVE ALPHABET POINTER ! 6329: MOV =B$SCL,(XR) STRING BLK TYPE ! 6330: MOV =CFP$A,WC NO OF CHARS IN ALPHABET ! 6331: MOV WC,SCLEN(XR) STORE AS STRING LENGTH ! 6332: MOV WC,WB COPY CHAR COUNT ! 6333: CTB WB,SCSI$ NO. OF BYTES NEEDED ! 6334: ADD XR,WB CURRENT END ADDRESS FOR STATIC ! 6335: MOV WB,STATE STORE STATIC END ADRS ! 6336: LCT WC,WC LOOP COUNTER ! 6337: PSC XR POINT TO CHARS OF STRING ! 6338: ZER WB SET INITIAL CHARACTER VALUE ! 6339: * ! 6340: * LOOP TO ENTER CHARACTER CODES IN ORDER ! 6341: * ! 6342: INI12 SCH WB,(XR)+ STORE NEXT CODE ! 6343: ICV WB BUMP CODE VALUE ! 6344: BCT WC,INI12 LOOP TILL ALL STORED ! 6345: CSC XR COMPLETE STORE CHARACTERS ! 6346: * ! 6347: * INITIALIZE VARIABLE BLOCKS FOR INPUT AND OUTPUT ! 6348: * ! 6349: MOV =V$INP,XL POINT TO STRING /INPUT/ ! 6350: MOV =TRTIN,WB TRBLK TYPE FOR INPUT ! 6351: JSR INOUT PERFORM INPUT ASSOCIATION ! 6352: MOV =V$OUP,XL POINT TO STRING /OUTPUT/ ! 6353: MOV =TRTOU,WB TRBLK TYPE FOR OUTPUT ! 6354: JSR INOUT PERFORM OUTPUT ASSOCIATION ! 6355: MOV INITR,WC TERMINAL FLAG ! 6356: BZE WC,INI13 SKIP IF NO TERMINAL ! 6357: JSR PRPAR ASSOCIATE TERMINAL ! 6358: EJC ! 6359: * ! 6360: * CHECK FOR EXPIRY DATE ! 6361: * ! 6362: INI13 JSR SYSDC CALL DATE CHECK ! 6363: MOV XS,FLPTR IN CASE STACK OVERFLOWS IN COMPILER ! 6364: * ! 6365: * NOW COMPILE SOURCE INPUT CODE ! 6366: * ! 6367: JSR CMPIL CALL COMPILER ! 6368: MOV XR,R$COD SET PTR TO FIRST CODE BLOCK ! 6369: MOV =NULLS,R$TTL FORGET TITLE (REG04) ! 6370: MOV =NULLS,R$STL FORGET SUB-TITLE (REG04) ! 6371: ZER R$CIM FORGET COMPILER INPUT IMAGE ! 6372: ZER XL CLEAR DUD VALUE ! 6373: ZER WB DONT SHIFT DYNAMIC STORE UP ! 6374: JSR GBCOL CLEAR GARBAGE LEFT FROM COMPILE ! 6375: BNZ CPSTS,INIX0 SKIP IF NO LISTING OF COMP STATS ! 6376: JSR PRTPG EJECT PAGE ! 6377: * ! 6378: * PRINT COMPILE STATISTICS ! 6379: * ! 6380: MOV DNAMP,WA NEXT AVAILABLE LOC ! 6381: SUB STATB,WA MINUS START ! 6382: BTW WA CONVERT TO WORDS ! 6383: MTI WA CONVERT TO INTEGER ! 6384: MOV =ENCM1,XR POINT TO /MEMORY USED (WORDS)/ ! 6385: JSR PRTMI PRINT MESSAGE ! 6386: MOV DNAME,WA END OF MEMORY ! 6387: SUB DNAMP,WA MINUS NEXT AVAILABLE LOC ! 6388: BTW WA CONVERT TO WORDS ! 6389: MTI WA CONVERT TO INTEGER ! 6390: MOV =ENCM2,XR POINT TO /MEMORY AVAILABLE (WORDS)/ ! 6391: JSR PRTMI PRINT LINE ! 6392: MTI CMERC GET COUNT OF ERRORS AS INTEGER ! 6393: MOV =ENCM3,XR POINT TO /COMPILE ERRORS/ ! 6394: JSR PRTMI PRINT IT ! 6395: MTI GBCNT GARBAGE COLLECTION COUNT ! 6396: SBI INTV1 ADJUST FOR UNAVOIDABLE COLLECT ! 6397: MOV =STPM5,XR POINT TO /STORAGE REGENERATIONS/ ! 6398: JSR PRTMI PRINT GBCOL COUNT ! 6399: JSR SYSTM GET TIME ! 6400: SBI TIMSX GET COMPILATION TIME ! 6401: MOV =ENCM4,XR POINT TO COMPILATION TIME (MSEC)/ ! 6402: JSR PRTMI PRINT MESSAGE ! 6403: ADD =NUM05,LSTLC BUMP LINE COUNT ! 6404: .IF .CUEJ ! 6405: BZE HEADP,INIX0 NO EJECT IF NOTHING PRINTED (SDG11) ! 6406: JSR PRTPG EJECT PRINTER ! 6407: .FI ! 6408: EJC ! 6409: * ! 6410: * PREPARE NOW TO START EXECUTION ! 6411: * ! 6412: * SET DEFAULT INPUT RECORD LENGTH ! 6413: * ! 6414: INIX0 BGT CSWIN,=INILN,INIX1 SKIP IF NOT DEFAULT -IN72 USED ! 6415: MOV =INILS,CSWIN ELSE USE DEFAULT RECORD LENGTH ! 6416: * ! 6417: * RESET TIMER ! 6418: * ! 6419: INIX1 JSR SYSTM GET TIME AGAIN ! 6420: STI TIMSX STORE FOR END RUN PROCESSING ! 6421: ADD CSWEX,NOXEQ ADD -NOEXECUTE FLAG ! 6422: BNZ NOXEQ,INIX2 JUMP IF EXECUTION SUPPRESSED ! 6423: ZER GBCNT INITIALISE COLLECT COUNT ! 6424: JSR SYSBX CALL BEFORE STARTING EXECUTION ! 6425: .IF .CUEJ ! 6426: .ELSE ! 6427: BZE HEADP,INIY0 NO EJECT IF NOTHING PRINTED (SGD11) ! 6428: JSR PRTPG EJECT PRINTER ! 6429: .FI ! 6430: * ! 6431: * MERGE WHEN LISTING FILE SET FOR EXECUTION ! 6432: * ! 6433: INIY0 MNZ HEADP MARK HEADERS OUT REGARDLESS ! 6434: ZER -(XS) SET FAILURE LOCATION ON STACK ! 6435: MOV XS,FLPTR SAVE PTR TO FAILURE OFFSET WORD ! 6436: MOV R$COD,XR LOAD PTR TO ENTRY CODE BLOCK ! 6437: MOV =STGXT,STAGE SET STAGE FOR EXECUTE TIME ! 6438: .IF .CNPF ! 6439: .ELSE ! 6440: MOV CMPSN,PFNTE COPY STMTS COMPILED COUNT IN CASE ! 6441: JSR SYSTM TIME YET AGAIN ! 6442: STI PFSTM ! 6443: .FI ! 6444: BRI (XR) START XEQ WITH FIRST STATEMENT ! 6445: * ! 6446: * HERE IF EXECUTION IS SUPPRESSED ! 6447: * ! 6448: INIX2 JSR PRTNL PRINT A BLANK LINE ! 6449: MOV =ENCM5,XR POINT TO /EXECUTION SUPPRESSED/ ! 6450: JSR PRTST PRINT STRING ! 6451: JSR PRTNL OUTPUT LINE ! 6452: ZER WA SET ABEND VALUE TO ZERO ! 6453: MOV =NINI9,WB SET SPECIAL CODE VALUE ! 6454: JSR SYSEJ END OF JOB, EXIT TO SYSTEM ! 6455: TTL S P I T B O L -- SNOBOL4 OPERATOR ROUTINES ! 6456: * ! 6457: * THIS SECTION INCLUDES ALL ROUTINES WHICH CAN BE ACCESSED ! 6458: * DIRECTLY FROM THE GENERATED CODE EXCEPT SYSTEM FUNCTIONS. ! 6459: * ! 6460: * ALL ROUTINES IN THIS SECTION START WITH A LABEL OF THE ! 6461: * FORM O$XXX WHERE XXX IS THREE LETTERS. THE GENERATED CODE ! 6462: * CONTAINS A POINTER TO THE APPROPRIATE ENTRY LABEL. ! 6463: * ! 6464: * SINCE THE GENERAL FORM OF THE GENERATED CODE CONSISTS OF ! 6465: * POINTERS TO BLOCKS WHOSE FIRST WORD IS THE ADDRESS OF THE ! 6466: * ACTUAL ENTRY POINT LABEL (O$XXX). ! 6467: * ! 6468: * THESE ROUTINES ARE IN ALPHABETICAL ORDER BY THEIR ! 6469: * ENTRY LABEL NAMES (I.E. BY THE XXX OF THE O$XXX NAME) ! 6470: * ! 6471: * THESE ROUTINES RECEIVE CONTROL AS FOLLOWS ! 6472: * ! 6473: * (CP) POINTER TO NEXT CODE WORD ! 6474: * (XS) CURRENT STACK POINTER ! 6475: EJC ! 6476: * ! 6477: * BINARY PLUS (ADDITION) ! 6478: * ! 6479: O$ADD ENT ENTRY POINT ! 6480: JSR ARITH FETCH ARITHMETIC OPERANDS ! 6481: ERR 001,ADDITION LEFT OPERAND IS NOT NUMERIC ! 6482: ERR 002,ADDITION RIGHT OPERAND IS NOT NUMERIC ! 6483: .IF .CNRA ! 6484: .ELSE ! 6485: PPM OADD1 JUMP IF REAL OPERANDS ! 6486: .FI ! 6487: * ! 6488: * HERE TO ADD TWO INTEGERS ! 6489: * ! 6490: ADI ICVAL(XL) ADD RIGHT OPERAND TO LEFT ! 6491: INO EXINT RETURN INTEGER IF NO OVERFLOW ! 6492: ERB 003,ADDITION CAUSED INTEGER OVERFLOW ! 6493: .IF .CNRA ! 6494: .ELSE ! 6495: * ! 6496: * HERE TO ADD TWO REALS ! 6497: * ! 6498: OADD1 ADR RCVAL(XL) ADD RIGHT OPERAND TO LEFT ! 6499: RNO EXREA RETURN REAL IF NO OVERFLOW ! 6500: ERB 261,ADDITION CAUSED REAL OVERFLOW ! 6501: .FI ! 6502: EJC ! 6503: * ! 6504: * UNARY PLUS (AFFIRMATION) ! 6505: * ! 6506: O$AFF ENT ENTRY POINT ! 6507: MOV (XS)+,XR LOAD OPERAND ! 6508: JSR GTNUM CONVERT TO NUMERIC ! 6509: ERR 004,AFFIRMATION OPERAND IS NOT NUMERIC ! 6510: BRN EXIXR RETURN IF CONVERTED TO NUMERIC ! 6511: EJC ! 6512: * ! 6513: * BINARY BAR (ALTERNATION) ! 6514: * ! 6515: O$ALT ENT ENTRY POINT ! 6516: MOV (XS)+,XR LOAD RIGHT OPERAND ! 6517: JSR GTPAT CONVERT TO PATTERN ! 6518: ERR 005,ALTERNATION RIGHT OPERAND IS NOT PATTERN ! 6519: * ! 6520: * MERGE HERE FROM SPECIAL (LEFT ALTERNATION) CASE ! 6521: * ! 6522: OALT1 MOV =P$ALT,WB SET PCODE FOR ALTERNATIVE NODE ! 6523: JSR PBILD BUILD ALTERNATIVE NODE ! 6524: MOV XR,XL SAVE ADDRESS OF ALTERNATIVE NODE ! 6525: MOV (XS)+,XR LOAD LEFT OPERAND ! 6526: JSR GTPAT CONVERT TO PATTERN ! 6527: ERR 006,ALTERNATION LEFT OPERAND IS NOT PATTERN ! 6528: BEQ XR,=P$ALT,OALT2 JUMP IF LEFT ARG IS ALTERNATION ! 6529: MOV XR,PTHEN(XL) SET LEFT OPERAND AS SUCCESSOR ! 6530: MOV XL,XR MOVE RESULT TO PROPER REGISTER ! 6531: BRN EXIXR JUMP FOR NEXT CODE WORD ! 6532: * ! 6533: * COME HERE IF LEFT ARGUMENT IS ITSELF AN ALTERNATION ! 6534: * ! 6535: * THE RESULT IS MORE EFFICIENT IF WE MAKE THE REPLACEMENT ! 6536: * ! 6537: * (A / B) / C = A / (B / C) ! 6538: * ! 6539: OALT2 MOV PARM1(XR),PTHEN(XL) BUILD THE (B / C) NODE ! 6540: MOV PTHEN(XR),-(XS) SET A AS NEW LEFT ARG ! 6541: MOV XL,XR SET (B / C) AS NEW RIGHT ARG ! 6542: BRN OALT1 MERGE BACK TO BUILD A / (B / C) ! 6543: EJC ! 6544: * ! 6545: * ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY NAME) ! 6546: * ! 6547: O$AMN ENT ENTRY POINT ! 6548: LCW XR LOAD NUMBER OF SUBSCRIPTS ! 6549: MOV XR,WB SET FLAG FOR BY NAME ! 6550: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE ! 6551: EJC ! 6552: * ! 6553: * ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY VALUE) ! 6554: * ! 6555: O$AMV ENT ENTRY POINT ! 6556: LCW XR LOAD NUMBER OF SUBSCRIPTS ! 6557: ZER WB SET FLAG FOR BY VALUE ! 6558: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE ! 6559: EJC ! 6560: * ! 6561: * ARRAY REFERENCE (ONE SUBSCRIPT, BY NAME) ! 6562: * ! 6563: O$AON ENT ENTRY POINT ! 6564: MOV (XS),XR LOAD SUBSCRIPT VALUE ! 6565: MOV 1(XS),XL LOAD ARRAY VALUE ! 6566: MOV (XL),WA LOAD FIRST WORD OF ARRAY OPERAND ! 6567: BEQ WA,=B$VCT,OAON2 JUMP IF VECTOR REFERENCE ! 6568: BEQ WA,=B$TBT,OAON3 JUMP IF TABLE REFERENCE ! 6569: * ! 6570: * HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE ! 6571: * ! 6572: OAON1 MOV =NUM01,XR SET NUMBER OF SUBSCRIPTS TO ONE ! 6573: MOV XR,WB SET FLAG FOR BY NAME ! 6574: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE ! 6575: * ! 6576: * HERE IF WE HAVE A VECTOR REFERENCE ! 6577: * ! 6578: OAON2 BNE (XR),=B$ICL,OAON1 USE LONG ROUTINE IF NOT INTEGER ! 6579: LDI ICVAL(XR) LOAD INTEGER SUBSCRIPT VALUE ! 6580: MFI WA,EXFAL COPY AS ADDRESS INT, FAIL IF OVFLO ! 6581: BZE WA,EXFAL FAIL IF ZERO ! 6582: ADD =VCVLB,WA COMPUTE OFFSET IN WORDS ! 6583: WTB WA CONVERT TO BYTES ! 6584: MOV WA,(XS) COMPLETE NAME ON STACK ! 6585: BLT WA,VCLEN(XL),EXITS EXIT IF SUBSCRIPT NOT TOO LARGE ! 6586: BRN EXFAL ELSE FAIL ! 6587: * ! 6588: * HERE FOR TABLE REFERENCE ! 6589: * ! 6590: OAON3 MNZ WB SET FLAG FOR NAME REFERENCE ! 6591: JSR TFIND LOCATE/CREATE TABLE ELEMENT ! 6592: PPM EXFAL FAIL IF ACCESS FAILS ! 6593: MOV XL,1(XS) STORE NAME BASE ON STACK ! 6594: MOV WA,(XS) STORE NAME OFFSET ON STACK ! 6595: BRN EXITS EXIT WITH RESULT ON STACK ! 6596: EJC ! 6597: * ! 6598: * ARRAY REFERENCE (ONE SUBSCRIPT, BY VALUE) ! 6599: * ! 6600: O$AOV ENT ENTRY POINT ! 6601: MOV (XS)+,XR LOAD SUBSCRIPT VALUE ! 6602: MOV (XS)+,XL LOAD ARRAY VALUE ! 6603: MOV (XL),WA LOAD FIRST WORD OF ARRAY OPERAND ! 6604: BEQ WA,=B$VCT,OAOV2 JUMP IF VECTOR REFERENCE ! 6605: BEQ WA,=B$TBT,OAOV3 JUMP IF TABLE REFERENCE ! 6606: * ! 6607: * HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE ! 6608: * ! 6609: OAOV1 MOV XL,-(XS) RESTACK ARRAY VALUE ! 6610: MOV XR,-(XS) RESTACK SUBSCRIPT ! 6611: MOV =NUM01,XR SET NUMBER OF SUBSCRIPTS TO ONE ! 6612: ZER WB SET FLAG FOR VALUE CALL ! 6613: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE ! 6614: * ! 6615: * HERE IF WE HAVE A VECTOR REFERENCE ! 6616: * ! 6617: OAOV2 BNE (XR),=B$ICL,OAOV1 USE LONG ROUTINE IF NOT INTEGER ! 6618: LDI ICVAL(XR) LOAD INTEGER SUBSCRIPT VALUE ! 6619: MFI WA,EXFAL MOVE AS ONE WORD INT, FAIL IF OVFLO ! 6620: BZE WA,EXFAL FAIL IF ZERO ! 6621: ADD =VCVLB,WA COMPUTE OFFSET IN WORDS ! 6622: WTB WA CONVERT TO BYTES ! 6623: BGE WA,VCLEN(XL),EXFAL FAIL IF SUBSCRIPT TOO LARGE ! 6624: JSR ACESS ACCESS VALUE ! 6625: PPM EXFAL FAIL IF ACCESS FAILS ! 6626: BRN EXIXR ELSE RETURN VALUE TO CALLER ! 6627: * ! 6628: * HERE FOR TABLE REFERENCE BY VALUE ! 6629: * ! 6630: OAOV3 ZER WB SET FLAG FOR VALUE REFERENCE ! 6631: JSR TFIND CALL TABLE SEARCH ROUTINE ! 6632: PPM EXFAL FAIL IF ACCESS FAILS ! 6633: BRN EXIXR EXIT WITH RESULT IN XR ! 6634: EJC ! 6635: * ! 6636: * ASSIGNMENT ! 6637: * ! 6638: O$ASS ENT ENTRY POINT ! 6639: * ! 6640: * O$RPL (PATTERN REPLACEMENT) MERGES HERE ! 6641: * ! 6642: OASS0 MOV (XS)+,WB LOAD VALUE TO BE ASSIGNED ! 6643: MOV (XS)+,WA LOAD NAME OFFSET ! 6644: MOV (XS),XL LOAD NAME BASE ! 6645: MOV WB,(XS) STORE ASSIGNED VALUE AS RESULT ! 6646: JSR ASIGN PERFORM ASSIGNMENT ! 6647: PPM EXFAL FAIL IF ASSIGNMENT FAILS ! 6648: BRN EXITS EXIT WITH RESULT ON STACK ! 6649: EJC ! 6650: * ! 6651: * COMPILATION ERROR ! 6652: * ! 6653: O$CER ENT ENTRY POINT ! 6654: ERB 007,COMPILATION ERROR ENCOUNTERED DURING EXECUTION ! 6655: EJC ! 6656: * ! 6657: * UNARY AT (CURSOR ASSIGNMENT) ! 6658: * ! 6659: O$CAS ENT ENTRY POINT ! 6660: MOV (XS)+,WC LOAD NAME OFFSET (PARM2) ! 6661: MOV (XS)+,XR LOAD NAME BASE (PARM1) ! 6662: MOV =P$CAS,WB SET PCODE FOR CURSOR ASSIGNMENT ! 6663: JSR PBILD BUILD NODE ! 6664: BRN EXIXR JUMP FOR NEXT CODE WORD ! 6665: EJC ! 6666: * ! 6667: * CONCATENATION ! 6668: * ! 6669: O$CNC ENT ENTRY POINT ! 6670: MOV (XS),XR LOAD RIGHT ARGUMENT ! 6671: BEQ XR,=NULLS,OCNC3 JUMP IF RIGHT ARG IS NULL ! 6672: MOV 1(XS),XL LOAD LEFT ARGUMENT ! 6673: BEQ XL,=NULLS,OCNC4 JUMP IF LEFT ARGUMENT IS NULL ! 6674: MOV =B$SCL,WA GET CONSTANT TO TEST FOR STRING ! 6675: BNE WA,(XL),OCNC2 JUMP IF LEFT ARG NOT A STRING ! 6676: BNE WA,(XR),OCNC2 JUMP IF RIGHT ARG NOT A STRING ! 6677: * ! 6678: * MERGE HERE TO CONCATENATE TWO STRINGS ! 6679: * ! 6680: OCNC1 MOV SCLEN(XL),WA LOAD LEFT ARGUMENT LENGTH ! 6681: ADD SCLEN(XR),WA COMPUTE RESULT LENGTH ! 6682: JSR ALOCS ALLOCATE SCBLK FOR RESULT ! 6683: MOV XR,1(XS) STORE RESULT PTR OVER LEFT ARGUMENT ! 6684: PSC XR PREPARE TO STORE CHARS OF RESULT ! 6685: MOV SCLEN(XL),WA GET NUMBER OF CHARS IN LEFT ARG ! 6686: PLC XL PREPARE TO LOAD LEFT ARG CHARS ! 6687: MVC MOVE CHARACTERS OF LEFT ARGUMENT ! 6688: MOV (XS)+,XL LOAD RIGHT ARG POINTER, POP STACK ! 6689: MOV SCLEN(XL),WA LOAD NUMBER OF CHARS IN RIGHT ARG ! 6690: PLC XL PREPARE TO LOAD RIGHT ARG CHARS ! 6691: MVC MOVE CHARACTERS OF RIGHT ARGUMENT ! 6692: BRN EXITS EXIT WITH RESULT ON STACK ! 6693: * ! 6694: * COME HERE IF ARGUMENTS ARE NOT BOTH STRINGS ! 6695: * ! 6696: OCNC2 JSR GTSTG CONVERT RIGHT ARG TO STRING ! 6697: PPM OCNC5 JUMP IF RIGHT ARG IS NOT STRING ! 6698: MOV XR,XL SAVE RIGHT ARG PTR ! 6699: JSR GTSTG CONVERT LEFT ARG TO STRING ! 6700: PPM OCNC6 JUMP IF LEFT ARG IS NOT A STRING ! 6701: MOV XR,-(XS) STACK LEFT ARGUMENT ! 6702: MOV XL,-(XS) STACK RIGHT ARGUMENT ! 6703: MOV XR,XL MOVE LEFT ARG TO PROPER REG ! 6704: MOV (XS),XR MOVE RIGHT ARG TO PROPER REG ! 6705: BRN OCNC1 MERGE BACK TO CONCATENATE STRINGS ! 6706: EJC ! 6707: * ! 6708: * CONCATENATION (CONTINUED) ! 6709: * ! 6710: * COME HERE FOR NULL RIGHT ARGUMENT ! 6711: * ! 6712: OCNC3 ICA XS REMOVE RIGHT ARG FROM STACK ! 6713: BRN EXITS RETURN WITH LEFT ARGUMENT ON STACK ! 6714: * ! 6715: * HERE FOR NULL LEFT ARGUMENT ! 6716: * ! 6717: OCNC4 ICA XS UNSTACK ONE ARGUMENT ! 6718: MOV XR,(XS) STORE RIGHT ARGUMENT ! 6719: BRN EXITS EXIT WITH RESULT ON STACK ! 6720: * ! 6721: * HERE IF RIGHT ARGUMENT IS NOT A STRING ! 6722: * ! 6723: OCNC5 MOV XR,XL MOVE RIGHT ARGUMENT PTR ! 6724: MOV (XS)+,XR LOAD LEFT ARG POINTER ! 6725: * ! 6726: * MERGE HERE WHEN LEFT ARGUMENT IS NOT A STRING ! 6727: * ! 6728: OCNC6 JSR GTPAT CONVERT LEFT ARG TO PATTERN ! 6729: ERR 008,CONCATENATION LEFT OPND IS NOT STRING OR PATTERN ! 6730: MOV XR,-(XS) SAVE RESULT ON STACK ! 6731: MOV XL,XR POINT TO RIGHT OPERAND ! 6732: JSR GTPAT CONVERT TO PATTERN ! 6733: ERR 009,CONCATENATION RIGHT OPD IS NOT STRING OR PATTERN ! 6734: MOV XR,XL MOVE FOR PCONC ! 6735: MOV (XS)+,XR RELOAD LEFT OPERAND PTR ! 6736: JSR PCONC CONCATENATE PATTERNS ! 6737: BRN EXIXR EXIT WITH RESULT IN XR ! 6738: EJC ! 6739: * ! 6740: * COMPLEMENTATION ! 6741: * ! 6742: O$COM ENT ENTRY POINT ! 6743: MOV (XS)+,XR LOAD OPERAND ! 6744: MOV (XR),WA LOAD TYPE WORD ! 6745: * ! 6746: * MERGE BACK HERE AFTER CONVERSION ! 6747: * ! 6748: OCOM1 BEQ WA,=B$ICL,OCOM2 JUMP IF INTEGER ! 6749: .IF .CNRA ! 6750: .ELSE ! 6751: BEQ WA,=B$RCL,OCOM3 JUMP IF REAL ! 6752: .FI ! 6753: JSR GTNUM ELSE CONVERT TO NUMERIC ! 6754: ERR 010,COMPLEMENTATION OPERAND IS NOT NUMERIC ! 6755: BRN OCOM1 BACK TO CHECK CASES ! 6756: * ! 6757: * HERE TO COMPLEMENT INTEGER ! 6758: * ! 6759: OCOM2 LDI ICVAL(XR) LOAD INTEGER VALUE ! 6760: NGI NEGATE ! 6761: INO EXINT RETURN INTEGER IF NO OVERFLOW ! 6762: ERB 011,COMPLEMENTATION CAUSED INTEGER OVERFLOW ! 6763: .IF .CNRA ! 6764: .ELSE ! 6765: * ! 6766: * HERE TO COMPLEMENT REAL ! 6767: * ! 6768: OCOM3 LDR RCVAL(XR) LOAD REAL VALUE ! 6769: NGR NEGATE ! 6770: BRN EXREA RETURN REAL RESULT ! 6771: .FI ! 6772: EJC ! 6773: * ! 6774: * BINARY SLASH (DIVISION) ! 6775: * ! 6776: O$DVD ENT ENTRY POINT ! 6777: JSR ARITH FETCH ARITHMETIC OPERANDS ! 6778: ERR 012,DIVISION LEFT OPERAND IS NOT NUMERIC ! 6779: ERR 013,DIVISION RIGHT OPERAND IS NOT NUMERIC ! 6780: .IF .CNRA ! 6781: .ELSE ! 6782: PPM ODVD2 JUMP IF REAL OPERANDS ! 6783: .FI ! 6784: * ! 6785: * HERE TO DIVIDE TWO INTEGERS ! 6786: * ! 6787: DVI ICVAL(XL) DIVIDE LEFT OPERAND BY RIGHT ! 6788: INO EXINT RESULT OK IF NO OVERFLOW ! 6789: ERB 014,DIVISION CAUSED INTEGER OVERFLOW ! 6790: .IF .CNRA ! 6791: .ELSE ! 6792: * ! 6793: * HERE TO DIVIDE TWO REALS ! 6794: * ! 6795: ODVD2 DVR RCVAL(XL) DIVIDE LEFT OPERAND BY RIGHT ! 6796: RNO EXREA RETURN REAL IF NO OVERFLOW ! 6797: ERB 262,DIVISION CAUSED REAL OVERFLOW ! 6798: .FI ! 6799: EJC ! 6800: * ! 6801: * EXPONENTIATION ! 6802: * ! 6803: O$EXP ENT ENTRY POINT ! 6804: MOV (XS)+,XR LOAD EXPONENT ! 6805: JSR GTNUM CONVERT TO NUMBER ! 6806: ERR 015,EXPONENTIATION RIGHT OPERAND IS NOT NUMERIC ! 6807: .IF .CNRA ! 6808: .ELSE ! 6809: BNE WA,=B$ICL,OEXP7 JUMP IF REAL ! 6810: .FI ! 6811: MOV XR,XL MOVE EXPONENT ! 6812: MOV (XS)+,XR LOAD BASE ! 6813: JSR GTNUM CONVERT TO NUMERIC ! 6814: ERR 016,EXPONENTIATION LEFT OPERAND IS NOT NUMERIC ! 6815: LDI ICVAL(XL) LOAD EXPONENT ! 6816: ILT OEXP8 ERROR IF NEGATIVE EXPONENT ! 6817: .IF .CNRA ! 6818: .ELSE ! 6819: BEQ WA,=B$RCL,OEXP3 JUMP IF BASE IS REAL ! 6820: .FI ! 6821: * ! 6822: * HERE TO EXPONENTIATE AN INTEGER ! 6823: * ! 6824: MFI WA,OEXP2 CONVERT EXPONENT TO 1 WORD INTEGER ! 6825: LCT WA,WA SET LOOP COUNTER ! 6826: LDI INTV1 LOAD INITIAL VALUE OF 1 ! 6827: BNZ WA,OEXP1 JUMP IF NON-ZERO EXPONENT ! 6828: INE EXINT GIVE ZERO AS RESULT FOR NONZERO**0 ! 6829: BRN OEXP4 ELSE ERROR OF 0**0 ! 6830: * ! 6831: * LOOP TO PERFORM EXPONENTIATION ! 6832: * ! 6833: OEXP1 MLI ICVAL(XR) MULTIPLY BY BASE ! 6834: IOV OEXP2 JUMP IF OVERFLOW ! 6835: BCT WA,OEXP1 LOOP BACK TILL COMPUTATION COMPLETE ! 6836: BRN EXINT THEN RETURN INTEGER RESULT ! 6837: * ! 6838: * HERE IF INTEGER OVERFLOW ! 6839: * ! 6840: OEXP2 ERB 017,EXPONENTIATION CAUSED INTEGER OVERFLOW ! 6841: EJC ! 6842: * ! 6843: * EXPONENTIATION (CONTINUED) ! 6844: .IF .CNRA ! 6845: .ELSE ! 6846: * ! 6847: * HERE TO EXPONENTIATE A REAL ! 6848: * ! 6849: OEXP3 MFI WA,OEXP6 CONVERT EXPONENT TO ONE WORD ! 6850: LCT WA,WA SET LOOP COUNTER ! 6851: LDR REAV1 LOAD 1.0 AS INITIAL VALUE ! 6852: BNZ WA,OEXP5 JUMP IF NON-ZERO EXPONENT ! 6853: RNE EXREA RETURN 1.0 IF NONZERO**ZERO ! 6854: .FI ! 6855: * ! 6856: * HERE FOR ERROR OF 0**0 OR 0.0**0 ! 6857: * ! 6858: OEXP4 ERB 018,EXPONENTIATION RESULT IS UNDEFINED ! 6859: .IF .CNRA ! 6860: .ELSE ! 6861: * ! 6862: * LOOP TO PERFORM EXPONENTIATION ! 6863: * ! 6864: OEXP5 MLR RCVAL(XR) MULTIPLY BY BASE ! 6865: ROV OEXP6 JUMP IF OVERFLOW ! 6866: BCT WA,OEXP5 LOOP TILL COMPUTATION COMPLETE ! 6867: BRN EXREA THEN RETURN REAL RESULT ! 6868: * ! 6869: * HERE IF REAL OVERFLOW ! 6870: * ! 6871: OEXP6 ERB 266,EXPONENTIATION CAUSED REAL OVERFLOW ! 6872: * ! 6873: * HERE IF REAL EXPONENT ! 6874: * ! 6875: OEXP7 ERB 267,EXPONENTIATION RIGHT OPERAND IS REAL NOT INTEGER ! 6876: .FI ! 6877: * ! 6878: * HERE FOR NEGATIVE EXPONENT ! 6879: * ! 6880: OEXP8 ERB 019,EXPONENTIATION RIGHT OPERAND IS NEGATIVE ! 6881: EJC ! 6882: * ! 6883: * FAILURE IN EXPRESSION EVALUATION ! 6884: * ! 6885: * THIS ENTRY POINT IS USED IF THE EVALUATION OF AN ! 6886: * EXPRESSION, INITIATED BY THE EVALX PROCEDURE, FAILS. ! 6887: * CONTROL IS RETURNED TO AN APPROPRIATE POINT IN EVALX. ! 6888: * ! 6889: O$FEX ENT ENTRY POINT ! 6890: BRN EVLX6 JUMP TO FAILURE LOC IN EVALX ! 6891: EJC ! 6892: * ! 6893: * FAILURE DURING EVALUATION OF A COMPLEX OR DIRECT GOTO ! 6894: * ! 6895: O$FIF ENT ENTRY POINT ! 6896: ERB 020,GOTO EVALUATION FAILURE ! 6897: EJC ! 6898: * ! 6899: * FUNCTION CALL (MORE THAN ONE ARGUMENT) ! 6900: * ! 6901: O$FNC ENT ENTRY POINT ! 6902: LCW WA LOAD NUMBER OF ARGUMENTS ! 6903: LCW XR LOAD FUNCTION VRBLK POINTER ! 6904: MOV VRFNC(XR),XL LOAD FUNCTION POINTER ! 6905: BNE WA,FARGS(XL),CFUNC USE CENTRAL ROUTINE IF WRONG NUM ! 6906: BRI (XL) JUMP TO FUNCTION IF ARG COUNT OK ! 6907: EJC ! 6908: * ! 6909: * FUNCTION NAME ERROR ! 6910: * ! 6911: O$FNE ENT ENTRY POINT ! 6912: LCW WA GET NEXT CODE WORD ! 6913: BNE WA,=ORNM$,OFNE1 FAIL IF NOT EVALUATING EXPRESSION ! 6914: BZE 2(XS),EVLX3 OK IF EXPR. WAS WANTED BY VALUE ! 6915: * ! 6916: * HERE FOR ERROR ! 6917: * ! 6918: OFNE1 ERB 021,FUNCTION CALLED BY NAME RETURNED A VALUE ! 6919: EJC ! 6920: * ! 6921: * FUNCTION CALL (SINGLE ARGUMENT) ! 6922: * ! 6923: O$FNS ENT ENTRY POINT ! 6924: LCW XR LOAD FUNCTION VRBLK POINTER ! 6925: MOV =NUM01,WA SET NUMBER OF ARGUMENTS TO ONE ! 6926: MOV VRFNC(XR),XL LOAD FUNCTION POINTER ! 6927: BNE WA,FARGS(XL),CFUNC USE CENTRAL ROUTINE IF WRONG NUM ! 6928: BRI (XL) JUMP TO FUNCTION IF ARG COUNT OK ! 6929: EJC ! 6930: * CALL TO UNDEFINED FUNCTION ! 6931: * ! 6932: O$FUN ENT ENTRY POINT ! 6933: ERB 022,UNDEFINED FUNCTION CALLED ! 6934: EJC ! 6935: * ! 6936: * EXECUTE COMPLEX GOTO ! 6937: * ! 6938: O$GOC ENT ENTRY POINT ! 6939: MOV 1(XS),XR LOAD NAME BASE POINTER ! 6940: BHI XR,STATE,OGOC1 JUMP IF NOT NATURAL VARIABLE ! 6941: ADD *VRTRA,XR ELSE POINT TO VRTRA FIELD ! 6942: BRI (XR) AND JUMP THROUGH IT ! 6943: * ! 6944: * HERE IF GOTO OPERAND IS NOT NATURAL VARIABLE ! 6945: * ! 6946: OGOC1 ERB 023,GOTO OPERAND IS NOT A NATURAL VARIABLE ! 6947: EJC ! 6948: * ! 6949: * EXECUTE DIRECT GOTO ! 6950: * ! 6951: O$GOD ENT ENTRY POINT ! 6952: MOV (XS),XR LOAD OPERAND ! 6953: MOV (XR),WA LOAD FIRST WORD ! 6954: BEQ WA,=B$CDS,BCDS0 JUMP IF CODE BLOCK TO CODE ROUTINE ! 6955: BEQ WA,=B$CDC,BCDC0 JUMP IF CODE BLOCK TO CODE ROUTINE ! 6956: ERB 024,GOTO OPERAND IN DIRECT GOTO IS NOT CODE ! 6957: EJC ! 6958: * ! 6959: * SET GOTO FAILURE TRAP ! 6960: * ! 6961: * THIS ROUTINE IS EXECUTED AT THE START OF A COMPLEX OR ! 6962: * DIRECT FAILURE GOTO TO TRAP A SUBSEQUENT FAIL (SEE EXFAL) ! 6963: * ! 6964: O$GOF ENT ENTRY POINT ! 6965: MOV FLPTR,XR POINT TO FAIL OFFSET ON STACK ! 6966: ICA (XR) POINT FAILURE TO O$FIF WORD ! 6967: ICP POINT TO NEXT CODE WORD ! 6968: BRN EXITS EXIT TO CONTINUE ! 6969: EJC ! 6970: * ! 6971: * BINARY DOLLAR (IMMEDIATE ASSIGNMENT) ! 6972: * ! 6973: * THE PATTERN BUILT BY BINARY DOLLAR IS A COMPOUND PATTERN. ! 6974: * SEE DESCRIPTION AT START OF PATTERN MATCH SECTION FOR ! 6975: * DETAILS OF THE STRUCTURE WHICH IS CONSTRUCTED. ! 6976: * ! 6977: O$IMA ENT ENTRY POINT ! 6978: MOV =P$IMC,WB SET PCODE FOR LAST NODE ! 6979: MOV (XS)+,WC POP NAME OFFSET (PARM2) ! 6980: MOV (XS)+,XR POP NAME BASE (PARM1) ! 6981: JSR PBILD BUILD P$IMC NODE ! 6982: MOV XR,XL SAVE PTR TO NODE ! 6983: MOV (XS),XR LOAD LEFT ARGUMENT ! 6984: JSR GTPAT CONVERT TO PATTERN ! 6985: ERR 025,IMMEDIATE ASSIGNMENT LEFT OPERAND IS NOT PATTERN ! 6986: MOV XR,(XS) SAVE PTR TO LEFT OPERAND PATTERN ! 6987: MOV =P$IMA,WB SET PCODE FOR FIRST NODE ! 6988: JSR PBILD BUILD P$IMA NODE ! 6989: MOV (XS)+,PTHEN(XR) SET LEFT OPERAND AS P$IMA SUCCESSOR ! 6990: JSR PCONC CONCATENATE TO FORM FINAL PATTERN ! 6991: BRN EXIXR ALL DONE ! 6992: EJC ! 6993: * ! 6994: * INDIRECTION (BY NAME) ! 6995: * ! 6996: O$INN ENT ENTRY POINT ! 6997: MNZ WB SET FLAG FOR RESULT BY NAME ! 6998: BRN INDIR JUMP TO COMMON ROUTINE ! 6999: EJC ! 7000: * ! 7001: * INTERROGATION ! 7002: * ! 7003: O$INT ENT ENTRY POINT ! 7004: MOV =NULLS,(XS) REPLACE OPERAND WITH NULL ! 7005: BRN EXITS EXIT FOR NEXT CODE WORD ! 7006: EJC ! 7007: * ! 7008: * INDIRECTION (BY VALUE) ! 7009: * ! 7010: O$INV ENT ENTRY POINT ! 7011: ZER WB SET FLAG FOR BY VALUE ! 7012: BRN INDIR JUMP TO COMMON ROUTINE ! 7013: EJC ! 7014: * ! 7015: * KEYWORD REFERENCE (BY NAME) ! 7016: * ! 7017: O$KWN ENT ENTRY POINT ! 7018: JSR KWNAM GET KEYWORD NAME ! 7019: BRN EXNAM EXIT WITH RESULT NAME ! 7020: EJC ! 7021: * ! 7022: * KEYWORD REFERENCE (BY VALUE) ! 7023: * ! 7024: O$KWV ENT ENTRY POINT ! 7025: JSR KWNAM GET KEYWORD NAME ! 7026: MOV XR,DNAMP DELETE KVBLK ! 7027: JSR ACESS ACCESS VALUE ! 7028: PPM EXNUL DUMMY (UNUSED) FAILURE RETURN ! 7029: BRN EXIXR JUMP WITH VALUE IN XR ! 7030: EJC ! 7031: * ! 7032: * LOAD EXPRESSION BY NAME ! 7033: * ! 7034: O$LEX ENT ENTRY POINT ! 7035: MOV *EVSI$,WA SET SIZE OF EVBLK ! 7036: JSR ALLOC ALLOCATE SPACE FOR EVBLK ! 7037: MOV =B$EVT,(XR) SET TYPE WORD ! 7038: MOV =TRBEV,EVVAR(XR) SET DUMMY TRBLK POINTER ! 7039: LCW WA LOAD EXBLK POINTER ! 7040: MOV WA,EVEXP(XR) SET EXBLK POINTER ! 7041: MOV XR,XL MOVE NAME BASE TO PROPER REG ! 7042: MOV *EVVAR,WA SET NAME OFFSET = ZERO ! 7043: BRN EXNAM EXIT WITH NAME IN (XL,WA) ! 7044: EJC ! 7045: * ! 7046: * LOAD PATTERN VALUE ! 7047: * ! 7048: O$LPT ENT ENTRY POINT ! 7049: LCW XR LOAD PATTERN POINTER ! 7050: BRN EXIXR STACK PTR AND OBEY NEXT CODE WORD ! 7051: EJC ! 7052: * ! 7053: * LOAD VARIABLE NAME ! 7054: * ! 7055: O$LVN ENT ENTRY POINT ! 7056: LCW WA LOAD VRBLK POINTER ! 7057: MOV WA,-(XS) STACK VRBLK PTR (NAME BASE) ! 7058: MOV *VRVAL,-(XS) STACK NAME OFFSET ! 7059: BRN EXITS EXIT WITH RESULT ON STACK ! 7060: EJC ! 7061: * ! 7062: * BINARY ASTERISK (MULTIPLICATION) ! 7063: * ! 7064: O$MLT ENT ENTRY POINT ! 7065: JSR ARITH FETCH ARITHMETIC OPERANDS ! 7066: ERR 026,MULTIPLICATION LEFT OPERAND IS NOT NUMERIC ! 7067: ERR 027,MULTIPLICATION RIGHT OPERAND IS NOT NUMERIC ! 7068: .IF .CNRA ! 7069: .ELSE ! 7070: PPM OMLT1 JUMP IF REAL OPERANDS ! 7071: .FI ! 7072: * ! 7073: * HERE TO MULTIPLY TWO INTEGERS ! 7074: * ! 7075: MLI ICVAL(XL) MULTIPLY LEFT OPERAND BY RIGHT ! 7076: INO EXINT RETURN INTEGER IF NO OVERFLOW ! 7077: ERB 028,MULTIPLICATION CAUSED INTEGER OVERFLOW ! 7078: .IF .CNRA ! 7079: .ELSE ! 7080: * ! 7081: * HERE TO MULTIPLY TWO REALS ! 7082: * ! 7083: OMLT1 MLR RCVAL(XL) MULTIPLY LEFT OPERAND BY RIGHT ! 7084: RNO EXREA RETURN REAL IF NO OVERFLOW ! 7085: ERB 263,MULTIPLICATION CAUSED REAL OVERFLOW ! 7086: .FI ! 7087: EJC ! 7088: * ! 7089: * NAME REFERENCE ! 7090: * ! 7091: O$NAM ENT ENTRY POINT ! 7092: MOV *NMSI$,WA SET LENGTH OF NMBLK ! 7093: JSR ALLOC ALLOCATE NMBLK ! 7094: MOV =B$NML,(XR) SET NAME BLOCK CODE ! 7095: MOV (XS)+,NMOFS(XR) SET NAME OFFSET FROM OPERAND ! 7096: MOV (XS)+,NMBAS(XR) SET NAME BASE FROM OPERAND ! 7097: BRN EXIXR EXIT WITH RESULT IN XR ! 7098: EJC ! 7099: * ! 7100: * NEGATION ! 7101: * ! 7102: * INITIAL ENTRY ! 7103: * ! 7104: O$NTA ENT ENTRY POINT ! 7105: LCW WA LOAD NEW FAILURE OFFSET ! 7106: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER ! 7107: MOV WA,-(XS) STACK NEW FAILURE OFFSET ! 7108: MOV XS,FLPTR SET NEW FAILURE POINTER ! 7109: BRN EXITS JUMP TO CONTINUE EXECUTION ! 7110: * ! 7111: * ENTRY AFTER SUCCESSFUL EVALUATION OF OPERAND ! 7112: * ! 7113: O$NTB ENT ENTRY POINT ! 7114: MOV 2(XS),FLPTR RESTORE OLD FAILURE POINTER ! 7115: BRN EXFAL AND FAIL ! 7116: * ! 7117: * ENTRY FOR FAILURE DURING OPERAND EVALUATION ! 7118: * ! 7119: O$NTC ENT ENTRY POINT ! 7120: ICA XS POP FAILURE OFFSET ! 7121: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER ! 7122: BRN EXNUL EXIT GIVING NULL RESULT ! 7123: EJC ! 7124: * ! 7125: * USE OF UNDEFINED OPERATOR ! 7126: * ! 7127: O$OUN ENT ENTRY POINT ! 7128: ERB 029,UNDEFINED OPERATOR REFERENCED ! 7129: EJC ! 7130: * ! 7131: * BINARY DOT (PATTERN ASSIGNMENT) ! 7132: * ! 7133: * THE PATTERN BUILT BY BINARY DOT IS A COMPOUND PATTERN. ! 7134: * SEE DESCRIPTION AT START OF PATTERN MATCH SECTION FOR ! 7135: * DETAILS OF THE STRUCTURE WHICH IS CONSTRUCTED. ! 7136: * ! 7137: O$PAS ENT ENTRY POINT ! 7138: MOV =P$PAC,WB LOAD PCODE FOR P$PAC NODE ! 7139: MOV (XS)+,WC LOAD NAME OFFSET (PARM2) ! 7140: MOV (XS)+,XR LOAD NAME BASE (PARM1) ! 7141: JSR PBILD BUILD P$PAC NODE ! 7142: MOV XR,XL SAVE PTR TO NODE ! 7143: MOV (XS),XR LOAD LEFT OPERAND ! 7144: JSR GTPAT CONVERT TO PATTERN ! 7145: ERR 030,PATTERN ASSIGNMENT LEFT OPERAND IS NOT PATTERN ! 7146: MOV XR,(XS) SAVE PTR TO LEFT OPERAND PATTERN ! 7147: MOV =P$PAA,WB SET PCODE FOR P$PAA NODE ! 7148: JSR PBILD BUILD P$PAA NODE ! 7149: MOV (XS)+,PTHEN(XR) SET LEFT OPERAND AS P$PAA SUCCESSOR ! 7150: JSR PCONC CONCATENATE TO FORM FINAL PATTERN ! 7151: BRN EXIXR JUMP FOR NEXT CODE WORD ! 7152: EJC ! 7153: * ! 7154: * PATTERN MATCH (BY NAME, FOR REPLACEMENT) ! 7155: * ! 7156: O$PMN ENT ENTRY POINT ! 7157: ZER WB SET TYPE CODE FOR MATCH BY NAME ! 7158: BRN MATCH JUMP TO ROUTINE TO START MATCH ! 7159: EJC ! 7160: * ! 7161: * PATTERN MATCH (STATEMENT) ! 7162: * ! 7163: * O$PMS IS USED IN PLACE OF O$PMV WHEN THE PATTERN MATCH ! 7164: * OCCURS AT THE OUTER (STATEMENT) LEVEL SINCE IN THIS ! 7165: * CASE THE SUBSTRING VALUE NEED NOT BE CONSTRUCTED. ! 7166: * ! 7167: O$PMS ENT ENTRY POINT ! 7168: MOV =NUM02,WB SET FLAG FOR STATEMENT TO MATCH ! 7169: BRN MATCH JUMP TO ROUTINE TO START MATCH ! 7170: EJC ! 7171: * ! 7172: * PATTERN MATCH (BY VALUE) ! 7173: * ! 7174: O$PMV ENT ENTRY POINT ! 7175: MOV =NUM01,WB SET TYPE CODE FOR VALUE MATCH ! 7176: BRN MATCH JUMP TO ROUTINE TO START MATCH ! 7177: EJC ! 7178: * ! 7179: * POP TOP ITEM ON STACK ! 7180: * ! 7181: O$POP ENT ENTRY POINT ! 7182: ICA XS POP TOP STACK ENTRY ! 7183: BRN EXITS OBEY NEXT CODE WORD ! 7184: EJC ! 7185: * ! 7186: * TERMINATE EXECUTION (CODE COMPILED FOR END STATEMENT) ! 7187: * ! 7188: O$STP ENT ENTRY POINT ! 7189: BRN LEND0 JUMP TO END CIRCUIT ! 7190: EJC ! 7191: * ! 7192: * RETURN NAME FROM EXPRESSION ! 7193: * THIS ENTRY POINTS IS USED IF THE EVALUATION OF AN ! 7194: * EXPRESSION, INITIATED BY THE EVALX PROCEDURE, RETURNS ! 7195: * A NAME. CONTROL IS RETURNED TO THE PROPER POINT IN EVALX. ! 7196: * ! 7197: O$RNM ENT ENTRY POINT ! 7198: BRN EVLX4 RETURN TO EVALX PROCEDURE ! 7199: EJC ! 7200: * ! 7201: * PATTERN REPLACEMENT ! 7202: * ! 7203: * WHEN THIS ROUTINE GETS CONTROL, THE FOLLOWING STACK ! 7204: * ENTRIES HAVE BEEN MADE (SEE END OF MATCH ROUTINE P$NTH) ! 7205: * ! 7206: * SUBJECT NAME BASE ! 7207: * SUBJECT NAME OFFSET ! 7208: * INITIAL CURSOR VALUE ! 7209: * FINAL CURSOR VALUE ! 7210: * SUBJECT POINTER ! 7211: * (XS) ---------------- REPLACEMENT VALUE ! 7212: * ! 7213: O$RPL ENT ENTRY POINT ! 7214: JSR GTSTG CONVERT REPLACEMENT VAL TO STRING ! 7215: ERR 031,PATTERN REPLACEMENT RIGHT OPERAND IS NOT STRING ! 7216: * ! 7217: * GET RESULT LENGTH AND ALLOCATE RESULT SCBLK ! 7218: * ! 7219: MOV (XS),XL LOAD SUBJECT STRING POINTER ! 7220: .IF .CNBF ! 7221: .ELSE ! 7222: BEQ (XL),=B$BCT,ORPL4 BRANCH IF BUFFER ASSIGNMENT ! 7223: .FI ! 7224: ADD SCLEN(XL),WA ADD SUBJECT STRING LENGTH ! 7225: ADD 2(XS),WA ADD STARTING CURSOR ! 7226: SUB 1(XS),WA MINUS FINAL CURSOR = TOTAL LENGTH ! 7227: BZE WA,ORPL3 JUMP IF RESULT IS NULL ! 7228: MOV XR,-(XS) RESTACK REPLACEMENT STRING ! 7229: JSR ALOCS ALLOCATE SCBLK FOR RESULT ! 7230: MOV 3(XS),WA GET INITIAL CURSOR (PART 1 LEN) ! 7231: MOV XR,3(XS) STACK RESULT POINTER ! 7232: PSC XR POINT TO CHARACTERS OF RESULT ! 7233: * ! 7234: * MOVE PART 1 (START OF SUBJECT) TO RESULT ! 7235: * ! 7236: BZE WA,ORPL1 JUMP IF FIRST PART IS NULL ! 7237: MOV 1(XS),XL ELSE POINT TO SUBJECT STRING ! 7238: PLC XL POINT TO SUBJECT STRING CHARS ! 7239: MVC MOVE FIRST PART TO RESULT ! 7240: EJC ! 7241: * PATTERN REPLACEMENT (CONTINUED) ! 7242: * ! 7243: * NOW MOVE IN REPLACEMENT VALUE ! 7244: * ! 7245: ORPL1 MOV (XS)+,XL LOAD REPLACEMENT STRING, POP ! 7246: MOV SCLEN(XL),WA LOAD LENGTH ! 7247: BZE WA,ORPL2 JUMP IF NULL REPLACEMENT ! 7248: PLC XL ELSE POINT TO CHARS OF REPLACEMENT ! 7249: MVC MOVE IN CHARS (PART 2) ! 7250: * ! 7251: * NOW MOVE IN REMAINDER OF STRING (PART 3) ! 7252: * ! 7253: ORPL2 MOV (XS)+,XL LOAD SUBJECT STRING POINTER, POP ! 7254: MOV (XS)+,WC LOAD FINAL CURSOR, POP ! 7255: MOV SCLEN(XL),WA LOAD SUBJECT STRING LENGTH ! 7256: SUB WC,WA MINUS FINAL CURSOR = PART 3 LENGTH ! 7257: BZE WA,OASS0 JUMP TO ASSIGN IF PART 3 IS NULL ! 7258: PLC XL,WC ELSE POINT TO LAST PART OF STRING ! 7259: MVC MOVE PART 3 TO RESULT ! 7260: BRN OASS0 JUMP TO PERFORM ASSIGNMENT ! 7261: * ! 7262: * HERE IF RESULT IS NULL ! 7263: * ! 7264: ORPL3 ADD *NUM02,XS POP SUBJECT STR PTR, FINAL CURSOR ! 7265: MOV =NULLS,(XS) SET NULL RESULT ! 7266: BRN OASS0 JUMP TO ASSIGN NULL VALUE ! 7267: .IF .CNBF ! 7268: .ELSE ! 7269: * ! 7270: * HERE FOR BUFFER SUBSTRING ASSIGNMENT ! 7271: * ! 7272: ORPL4 MOV XR,XL COPY SCBLK REPLACEMENT PTR ! 7273: MOV (XS)+,XR UNSTACK BCBLK PTR ! 7274: MOV (XS)+,WB GET FINAL CURSOR VALUE ! 7275: MOV (XS)+,WA GET INITIAL CURSOR ! 7276: SUB WA,WB GET LENGTH IN WB ! 7277: ADD *NUM02,XS GET RID OF NAME BASE/OFFSET ! 7278: JSR INSBF INSERT SUBSTRING ! 7279: PPM CONVERT FAIL IMPOSSIBLE ! 7280: PPM EXFAL FAIL IF INSERT FAILS ! 7281: BRN EXNUL ELSE NULL RESULT ! 7282: .FI ! 7283: EJC ! 7284: * ! 7285: * RETURN VALUE FROM EXPRESSION ! 7286: * ! 7287: * THIS ENTRY POINTS IS USED IF THE EVALUATION OF AN ! 7288: * EXPRESSION, INITIATED BY THE EVALX PROCEDURE, RETURNS ! 7289: * A VALUE. CONTROL IS RETURNED TO THE PROPER POINT IN EVALX ! 7290: * ! 7291: O$RVL ENT ENTRY POINT ! 7292: BRN EVLX3 RETURN TO EVALX PROCEDURE ! 7293: EJC ! 7294: * ! 7295: * SELECTION ! 7296: * ! 7297: * INITIAL ENTRY ! 7298: * ! 7299: O$SLA ENT ENTRY POINT ! 7300: LCW WA LOAD NEW FAILURE OFFSET ! 7301: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER ! 7302: MOV WA,-(XS) STACK NEW FAILURE OFFSET ! 7303: MOV XS,FLPTR SET NEW FAILURE POINTER ! 7304: BRN EXITS JUMP TO EXECUTE FIRST ALTERNATIVE ! 7305: * ! 7306: * ENTRY AFTER SUCCESSFUL EVALUATION OF ALTERNATIVE ! 7307: * ! 7308: O$SLB ENT ENTRY POINT ! 7309: MOV (XS)+,XR LOAD RESULT ! 7310: ICA XS POP FAIL OFFSET ! 7311: MOV (XS),FLPTR RESTORE OLD FAILURE POINTER ! 7312: MOV XR,(XS) RESTACK RESULT ! 7313: LCW WA LOAD NEW CODE OFFSET ! 7314: ADD R$COD,WA POINT TO ABSOLUTE CODE LOCATION ! 7315: LCP WA SET NEW CODE POINTER ! 7316: BRN EXITS JUMP TO CONTINUE PAST SELECTION ! 7317: * ! 7318: * ENTRY AT START OF SUBSEQUENT ALTERNATIVES ! 7319: * ! 7320: O$SLC ENT ENTRY POINT ! 7321: LCW WA LOAD NEW FAIL OFFSET ! 7322: MOV WA,(XS) STORE NEW FAIL OFFSET ! 7323: BRN EXITS JUMP TO EXECUTE NEXT ALTERNATIVE ! 7324: * ! 7325: * ENTRY AT START OF LAST ALTERNATIVE ! 7326: * ! 7327: O$SLD ENT ENTRY POINT ! 7328: ICA XS POP FAILURE OFFSET ! 7329: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER ! 7330: BRN EXITS JUMP TO EXECUTE LAST ALTERNATIVE ! 7331: EJC ! 7332: * ! 7333: * BINARY MINUS (SUBTRACTION) ! 7334: * ! 7335: O$SUB ENT ENTRY POINT ! 7336: JSR ARITH FETCH ARITHMETIC OPERANDS ! 7337: ERR 032,SUBTRACTION LEFT OPERAND IS NOT NUMERIC ! 7338: ERR 033,SUBTRACTION RIGHT OPERAND IS NOT NUMERIC ! 7339: .IF .CNRA ! 7340: .ELSE ! 7341: PPM OSUB1 JUMP IF REAL OPERANDS ! 7342: .FI ! 7343: * ! 7344: * HERE TO SUBTRACT TWO INTEGERS ! 7345: * ! 7346: SBI ICVAL(XL) SUBTRACT RIGHT OPERAND FROM LEFT ! 7347: INO EXINT RETURN INTEGER IF NO OVERFLOW ! 7348: ERB 034,SUBTRACTION CAUSED INTEGER OVERFLOW ! 7349: .IF .CNRA ! 7350: .ELSE ! 7351: * ! 7352: * HERE TO SUBTRACT TWO REALS ! 7353: * ! 7354: OSUB1 SBR RCVAL(XL) SUBTRACT RIGHT OPERAND FROM LEFT ! 7355: RNO EXREA RETURN REAL IF NO OVERFLOW ! 7356: ERB 264,SUBTRACTION CAUSED REAL OVERFLOW ! 7357: .FI ! 7358: EJC ! 7359: * ! 7360: * DUMMY OPERATOR TO RETURN CONTROL TO TRXEQ PROCEDURE ! 7361: * ! 7362: O$TXR ENT ENTRY POINT ! 7363: BRN TRXQ1 JUMP INTO TRXEQ PROCEDURE ! 7364: EJC ! 7365: * ! 7366: * UNEXPECTED FAILURE ! 7367: * ! 7368: * NOTE THAT IF A SETEXIT TRAP IS OPERATING THEN ! 7369: * TRANSFER TO SYSTEM LABEL CONTINUE ! 7370: * WILL RESULT IN LOOPING HERE. DIFFICULT TO AVOID EXCEPT ! 7371: * WITH A CONSIDERABLE OVERHEAD WHICH IS NOT WORTHWHILE OR ! 7372: * ELSE BY A TECHNIQUE SUCH AS SETTING KVERL TO ZERO. ! 7373: * ! 7374: O$UNF ENT ENTRY POINT ! 7375: ERB 035,UNEXPECTED FAILURE IN -NOFAIL MODE ! 7376: TTL S P I T B O L -- SNOBOL4 BUILTIN LABEL ROUTINES ! 7377: * ! 7378: * THE FOLLOWING SECTION CONTAINS THE ROUTINES FOR LABELS ! 7379: * WHICH HAVE A PREDEFINED MEANING IN SNOBOL4. ! 7380: * ! 7381: * CONTROL IS PASSED DIRECTLY TO THE LABEL NAME ENTRY POINT. ! 7382: * ! 7383: * ENTRY NAMES ARE OF THE FORM L$XXX WHERE XXX IS THE THREE ! 7384: * LETTER VARIABLE NAME IDENTIFIER. ! 7385: * ! 7386: * ENTRIES ARE IN ALPHABETICAL ORDER ! 7387: EJC ! 7388: * ! 7389: * ABORT ! 7390: * ! 7391: L$ABO ENT ENTRY POINT ! 7392: * ! 7393: * MERGE HERE IF EXECUTION TERMINATES IN ERROR ! 7394: * ! 7395: LABO1 MOV KVERT,WA LOAD ERROR CODE ! 7396: BZE WA,LABO2 JUMP IF NO ERROR HAS OCCURED ! 7397: .IF .CSAX ! 7398: JSR SYSAX CALL AFTER EXECUTION PROC (REG04) ! 7399: .ELSE ! 7400: .FI ! 7401: JSR PRTPG ELSE EJECT PRINTER ! 7402: JSR ERMSG PRINT ERROR MESSAGE ! 7403: ZER XR INDICATE NO MESSAGE TO PRINT ! 7404: BRN STOPR JUMP TO ROUTINE TO STOP RUN ! 7405: * ! 7406: * HERE IF NO ERROR HAD OCCURED ! 7407: * ! 7408: LABO2 ERB 036,GOTO ABORT WITH NO PRECEDING ERROR ! 7409: EJC ! 7410: * ! 7411: * CONTINUE ! 7412: * ! 7413: L$CNT ENT ENTRY POINT ! 7414: * ! 7415: * MERGE HERE AFTER EXECUTION ERROR ! 7416: * ! 7417: LCNT1 MOV R$CNT,XR LOAD CONTINUATION CODE BLOCK PTR ! 7418: BZE XR,LCNT2 JUMP IF NO PREVIOUS ERROR ! 7419: ZER R$CNT CLEAR FLAG ! 7420: MOV XR,R$COD ELSE STORE AS NEW CODE BLOCK PTR ! 7421: ADD STXOF,XR ADD FAILURE OFFSET ! 7422: LCP XR LOAD CODE POINTER ! 7423: MOV FLPTR,XS RESET STACK POINTER ! 7424: BRN EXITS JUMP TO TAKE INDICATED FAILURE ! 7425: * ! 7426: * HERE IF NO PREVIOUS ERROR ! 7427: * ! 7428: LCNT2 ERB 037,GOTO CONTINUE WITH NO PRECEDING ERROR ! 7429: EJC ! 7430: * ! 7431: * END ! 7432: * ! 7433: L$END ENT ENTRY POINT ! 7434: * ! 7435: * MERGE HERE FROM END CODE CIRCUIT ! 7436: * ! 7437: LEND0 MOV =ENDMS,XR POINT TO MESSAGE /NORMAL TERM../ ! 7438: BRN STOPR JUMP TO ROUTINE TO STOP RUN ! 7439: EJC ! 7440: * ! 7441: * FRETURN ! 7442: * ! 7443: L$FRT ENT ENTRY POINT ! 7444: MOV =SCFRT,WA POINT TO STRING /FRETURN/ ! 7445: BRN RETRN JUMP TO COMMON RETURN ROUTINE ! 7446: EJC ! 7447: * ! 7448: * NRETURN ! 7449: * ! 7450: L$NRT ENT ENTRY POINT ! 7451: MOV =SCNRT,WA POINT TO STRING /NRETURN/ ! 7452: BRN RETRN JUMP TO COMMON RETURN ROUTINE ! 7453: EJC ! 7454: * ! 7455: * RETURN ! 7456: * ! 7457: L$RTN ENT ENTRY POINT ! 7458: MOV =SCRTN,WA POINT TO STRING /RETURN/ ! 7459: BRN RETRN JUMP TO COMMON RETURN ROUTINE ! 7460: EJC ! 7461: * ! 7462: * UNDEFINED LABEL ! 7463: * ! 7464: L$UND ENT ENTRY POINT ! 7465: ERB 038,GOTO UNDEFINED LABEL ! 7466: TTL S P I T B O L -- BLOCK ACTION ROUTINES ! 7467: * ! 7468: * THE FIRST WORD OF EVERY BLOCK IN DYNAMIC STORAGE AND THE ! 7469: * VRGET, VRSTO AND VRTRA FIELDS OF A VRBLK CONTAIN A ! 7470: * POINTER TO AN ENTRY POINT IN THE PROGRAM. ALL SUCH ENTRY ! 7471: * POINTS ARE IN THE FOLLOWING SECTION EXCEPT THOSE FOR ! 7472: * PATTERN BLOCKS WHICH ARE IN THE PATTERN MATCHING SEGMENT ! 7473: * LATER ON (LABELS OF THE FORM P$XXX), AND DOPE VECTORS ! 7474: * (D$XXX) WHICH ARE IN THE DOPE VECTOR SECTION FOLLOWING ! 7475: * THE PATTERN ROUTINES (DOPE VECTORS ARE USED FOR CMBLKS). ! 7476: * ! 7477: * THE ENTRY POINTS IN THIS SECTION HAVE LABELS OF THE ! 7478: * FORM B$XXY WHERE XX IS THE TWO CHARACTER BLOCK TYPE FOR ! 7479: * THE CORRESPONDING BLOCK AND Y IS ANY LETTER. ! 7480: * ! 7481: * IN SOME CASES, THE POINTERS SERVE NO OTHER PURPOSE THAN ! 7482: * TO IDENTIFY THE BLOCK TYPE. IN THIS CASE THE ROUTINE ! 7483: * IS NEVER EXECUTED AND THUS NO CODE IS ASSEMBLED. ! 7484: * ! 7485: * FOR EACH OF THESE ENTRY POINTS CORRESPONDING TO A BLOCK ! 7486: * AN ENTRY POINT IDENTIFICATION IS ASSEMBLED (BL$XX). ! 7487: * ! 7488: * THE EXACT ENTRY CONDITIONS DEPEND ON THE MANNER IN ! 7489: * WHICH THE ROUTINE IS ACCESSED AND ARE DOCUMENTED WITH ! 7490: * THE INDIVIDUAL ROUTINES AS REQUIRED. ! 7491: * ! 7492: * THE ORDER OF THESE ROUTINES IS ALPHABETICAL WITH THE ! 7493: * FOLLOWING EXCEPTIONS. ! 7494: * ! 7495: * THE ROUTINES FOR SEBLK AND EXBLK ENTRIES OCCUR FIRST SO ! 7496: * THAT EXPRESSIONS CAN BE QUICKLY IDENTIFIED FROM THE FACT ! 7497: * THAT THEIR ROUTINES LIE BEFORE THE SYMBOL B$E$$. ! 7498: * ! 7499: * THESE ARE IMMEDIATELY FOLLOWED BY THE ROUTINE FOR A TRBLK ! 7500: * SO THAT THE TEST AGAINST THE SYMBOL B$T$$ CHECKS FOR ! 7501: * TRAPPED VALUES OR EXPRESSION VALUES (SEE PROCEDURE EVALP) ! 7502: * ! 7503: * THE PATTERN ROUTINES LIE AFTER THIS SECTION SO THAT ! 7504: * PATTERNS ARE IDENTIFIED WITH ROUTINES STARTING AT OR ! 7505: * AFTER THE INITIAL INSTRUCTION IN THESE ROUTINES (P$AAA). ! 7506: * ! 7507: * THE SYMBOL B$AAA DEFINES THE FIRST LOCATION FOR BLOCK ! 7508: * ROUTINES AND THE SYMBOL P$YYY (AT THE END OF THE PATTERN ! 7509: * MATCH ROUTINES SECTION) DEFINES THE LAST SUCH ENTRY POINT ! 7510: * ! 7511: B$AAA ENT BL$$I ENTRY POINT OF FIRST BLOCK ROUTINE ! 7512: EJC ! 7513: * ! 7514: * EXBLK ! 7515: * ! 7516: * THE ROUTINE FOR AN EXBLK LOADS THE EXPRESSION ONTO ! 7517: * THE STACK AS A VALUE. ! 7518: * ! 7519: * (XR) POINTER TO EXBLK ! 7520: * ! 7521: B$EXL ENT BL$EX ENTRY POINT (EXBLK) ! 7522: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD ! 7523: EJC ! 7524: * ! 7525: * SEBLK ! 7526: * ! 7527: * THE ROUTINE FOR SEBLK IS ACCESSED FROM THE GENERATED ! 7528: * CODE TO LOAD THE EXPRESSION VALUE ONTO THE STACK. ! 7529: * ! 7530: B$SEL ENT BL$SE ENTRY POINT (SEBLK) ! 7531: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD ! 7532: * ! 7533: * DEFINE SYMBOL WHICH MARKS END OF ENTRIES FOR EXPRESSIONS ! 7534: * ! 7535: B$E$$ ENT BL$$I ENTRY POINT ! 7536: EJC ! 7537: * ! 7538: * TRBLK ! 7539: * ! 7540: * THE ROUTINE FOR A TRBLK IS NEVER EXECUTED ! 7541: * ! 7542: B$TRT ENT BL$TR ENTRY POINT (TRBLK) ! 7543: * ! 7544: * DEFINE SYMBOL MARKING END OF TRAP AND EXPRESSION BLOCKS ! 7545: * ! 7546: B$T$$ ENT BL$$I END OF TRBLK,SEBLK,EXBLK ENTRIES ! 7547: EJC ! 7548: * ! 7549: * ARBLK ! 7550: * ! 7551: * THE ROUTINE FOR ARBLK IS NEVER EXECUTED ! 7552: * ! 7553: B$ART ENT BL$AR ENTRY POINT (ARBLK) ! 7554: EJC ! 7555: .IF .CNBF ! 7556: .ELSE ! 7557: * ! 7558: * BCBLK ! 7559: * ! 7560: * THE ROUTINE FOR A BCBLK IS NEVER EXECUTED ! 7561: * ! 7562: * (XR) POINTER TO BCBLK ! 7563: * ! 7564: B$BCT ENT BL$BC ENTRY POINT (BCBLK) ! 7565: EJC ! 7566: * ! 7567: * BFBLK ! 7568: * ! 7569: * THE ROUTINE FOR A BFBLK IS NEVER EXECUTED ! 7570: * ! 7571: * (XR) POINTER TO BFBLK ! 7572: * ! 7573: B$BFT ENT BL$BF ENTRY POINT (BFBLK) ! 7574: EJC ! 7575: .FI ! 7576: * ! 7577: * CCBLK ! 7578: * ! 7579: * THE ROUTINE FOR CCBLK IS NEVER ENTERED ! 7580: * ! 7581: B$CCT ENT BL$CC ENTRY POINT (CCBLK) ! 7582: EJC ! 7583: * ! 7584: * CDBLK ! 7585: * ! 7586: * THE CDBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE. ! 7587: * THERE ARE TWO CASES DEPENDING ON THE FORM OF CDFAL. ! 7588: * ! 7589: * ENTRY FOR COMPLEX FAILURE CODE AT CDFAL ! 7590: * ! 7591: * (XR) POINTER TO CDBLK ! 7592: * ! 7593: B$CDC ENT BL$CD ENTRY POINT (CDBLK) ! 7594: BCDC0 MOV FLPTR,XS POP GARBAGE OFF STACK ! 7595: MOV CDFAL(XR),(XS) SET FAILURE OFFSET ! 7596: BRN STMGO ENTER STMT ! 7597: EJC ! 7598: * ! 7599: * CDBLK (CONTINUED) ! 7600: * ! 7601: * ENTRY FOR SIMPLE FAILURE CODE AT CDFAL ! 7602: * ! 7603: * (XR) POINTER TO CDBLK ! 7604: * ! 7605: B$CDS ENT BL$CD ENTRY POINT (CDBLK) ! 7606: BCDS0 MOV FLPTR,XS POP GARBAGE OFF STACK ! 7607: MOV *CDFAL,(XS) SET FAILURE OFFSET ! 7608: BRN STMGO ENTER STMT ! 7609: EJC ! 7610: * ! 7611: * CMBLK ! 7612: * ! 7613: * THE ROUTINE FOR A CMBLK IS NEVER EXECUTED ! 7614: * ! 7615: B$CMT ENT BL$CM ENTRY POINT (CMBLK) ! 7616: EJC ! 7617: * ! 7618: * CTBLK ! 7619: * ! 7620: * THE ROUTINE FOR A CTBLK IS NEVER EXECUTED ! 7621: * ! 7622: B$CTT ENT BL$CT ENTRY POINT (CTBLK) ! 7623: EJC ! 7624: * ! 7625: * DFBLK ! 7626: * ! 7627: * THE ROUTINE FOR A DFBLK IS ACCESSED FROM THE O$FNC ENTRY ! 7628: * TO CALL A DATATYPE FUNCTION AND BUILD A PDBLK. ! 7629: * ! 7630: * (XL) POINTER TO DFBLK ! 7631: * ! 7632: B$DFC ENT BL$DF ENTRY POINT ! 7633: MOV DFPDL(XL),WA LOAD LENGTH OF PDBLK ! 7634: JSR ALLOC ALLOCATE PDBLK ! 7635: MOV =B$PDT,(XR) STORE TYPE WORD ! 7636: MOV XL,PDDFP(XR) STORE DFBLK POINTER ! 7637: MOV XR,WC SAVE POINTER TO PDBLK ! 7638: ADD WA,XR POINT PAST PDBLK ! 7639: LCT WA,FARGS(XL) SET TO COUNT FIELDS ! 7640: * ! 7641: * LOOP TO ACQUIRE FIELD VALUES FROM STACK ! 7642: * ! 7643: BDFC1 MOV (XS)+,-(XR) MOVE A FIELD VALUE ! 7644: BCT WA,BDFC1 LOOP TILL ALL MOVED ! 7645: MOV WC,XR RECALL POINTER TO PDBLK ! 7646: BRN EXSID EXIT SETTING ID FIELD ! 7647: EJC ! 7648: * ! 7649: * EFBLK ! 7650: * ! 7651: * THE ROUTINE FOR AN EFBLK IS PASSED CONTROL FORM THE O$FNC ! 7652: * ENTRY TO CALL AN EXTERNAL FUNCTION. ! 7653: * ! 7654: * (XL) POINTER TO EFBLK ! 7655: * ! 7656: B$EFC ENT BL$EF ENTRY POINT (EFBLK) ! 7657: .IF .CNLD ! 7658: .ELSE ! 7659: MOV FARGS(XL),WC LOAD NUMBER OF ARGUMENTS ! 7660: WTB WC CONVERT TO OFFSET ! 7661: MOV XL,-(XS) SAVE POINTER TO EFBLK ! 7662: MOV XS,XT COPY POINTER TO ARGUMENTS ! 7663: * ! 7664: * LOOP TO CONVERT ARGUMENTS ! 7665: * ! 7666: BEFC1 ICA XT POINT TO NEXT ENTRY ! 7667: MOV (XS),XR LOAD POINTER TO EFBLK ! 7668: DCA WC DECREMENT EFTAR OFFSET ! 7669: ADD WC,XR POINT TO NEXT EFTAR ENTRY ! 7670: MOV EFTAR(XR),XR LOAD EFTAR ENTRY ! 7671: .IF .CNRA ! 7672: BSW XR,3 SWITCH ON TYPE ! 7673: .ELSE ! 7674: BSW XR,4 SWITCH ON TYPE ! 7675: .FI ! 7676: IFF 0,BEFC7 NO CONVERSION NEEDED ! 7677: IFF 1,BEFC2 STRING ! 7678: IFF 2,BEFC3 INTEGER ! 7679: .IF .CNRA ! 7680: .ELSE ! 7681: IFF 3,BEFC4 REAL ! 7682: .FI ! 7683: ESW END OF SWITCH ON TYPE ! 7684: * ! 7685: * HERE TO CONVERT TO STRING ! 7686: * ! 7687: BEFC2 MOV (XT),-(XS) STACK ARG PTR ! 7688: JSR GTSTG CONVERT ARGUMENT TO STRING ! 7689: ERR 039,EXTERNAL FUNCTION ARGUMENT IS NOT STRING ! 7690: BRN BEFC6 JUMP TO MERGE ! 7691: EJC ! 7692: * ! 7693: * EFBLK (CONTINUED) ! 7694: * ! 7695: * HERE TO CONVERT AN INTEGER ! 7696: * ! 7697: BEFC3 MOV (XT),XR LOAD NEXT ARGUMENT ! 7698: MOV WC,BEFOF SAVE OFFSET ! 7699: JSR GTINT CONVERT TO INTEGER ! 7700: ERR 040,EXTERNAL FUNCTION ARGUMENT IS NOT INTEGER ! 7701: .IF .CNRA ! 7702: .ELSE ! 7703: BRN BEFC5 MERGE WITH REAL CASE ! 7704: * ! 7705: * HERE TO CONVERT A REAL ! 7706: * ! 7707: BEFC4 MOV (XT),XR LOAD NEXT ARGUMENT ! 7708: MOV WC,BEFOF SAVE OFFSET ! 7709: JSR GTREA CONVERT TO REAL ! 7710: ERR 265,EXTERNAL FUNCTION ARGUMENT IS NOT REAL ! 7711: .FI ! 7712: * ! 7713: * INTEGER CASE MERGES HERE ! 7714: * ! 7715: BEFC5 MOV BEFOF,WC RESTORE OFFSET ! 7716: * ! 7717: * STRING MERGES HERE ! 7718: * ! 7719: BEFC6 MOV XR,(XT) STORE CONVERTED RESULT ! 7720: * ! 7721: * NO CONVERSION MERGES HERE ! 7722: * ! 7723: BEFC7 BNZ WC,BEFC1 LOOP BACK IF MORE TO GO ! 7724: * ! 7725: * HERE AFTER CONVERTING ALL THE ARGUMENTS ! 7726: * ! 7727: MOV (XS)+,XL RESTORE EFBLK POINTER ! 7728: MOV FARGS(XL),WA GET NUMBER OF ARGS ! 7729: JSR SYSEX CALL ROUTINE TO CALL EXTERNAL FNC ! 7730: PPM EXFAL FAIL IF FAILURE ! 7731: EJC ! 7732: * ! 7733: * EFBLK (CONTINUED) ! 7734: * ! 7735: * RETURN HERE WITH RESULT IN XR ! 7736: * ! 7737: * FIRST DEFEND AGAINST NON-STANDARD NULL STRING RETURNED ! 7738: * ! 7739: MOV EFRSL(XL),WB GET RESULT TYPE ID ! 7740: BNZ WB,BEFA8 BRANCH IF NOT UNCONVERTED ! 7741: BNE (XR),=B$SCL,BEFC8 JUMP IF NOT A STRING ! 7742: BZE SCLEN(XR),EXNUL RETURN NULL IF NULL ! 7743: * ! 7744: * HERE IF CONVERTED RESULT TO CHECK FOR NULL STRING ! 7745: * ! 7746: BEFA8 BNE WB,=NUM01,BEFC8 JUMP IF NOT A STRING ! 7747: BZE SCLEN(XR),EXNUL RETURN NULL IF NULL ! 7748: * ! 7749: * RETURN IF RESULT IS IN DYNAMIC STORAGE ! 7750: * ! 7751: BEFC8 BLT XR,DNAMB,BEFC9 JUMP IF NOT IN DYNAMIC STORAGE ! 7752: BLE XR,DNAMP,EXIXR RETURN RESULT IF ALREADY DYNAMIC ! 7753: * ! 7754: * HERE WE COPY A RESULT INTO THE DYNAMIC REGION ! 7755: * ! 7756: BEFC9 MOV (XR),WA GET POSSIBLE TYPE WORD ! 7757: BZE WB,BEF11 JUMP IF UNCONVERTED RESULT ! 7758: MOV =B$SCL,WA STRING ! 7759: BEQ WB,=NUM01,BEF10 YES JUMP ! 7760: MOV =B$ICL,WA INTEGER ! 7761: BEQ WB,=NUM02,BEF10 YES JUMP ! 7762: .IF .CNRA ! 7763: .ELSE ! 7764: MOV =B$RCL,WA REAL ! 7765: .FI ! 7766: * ! 7767: * STORE TYPE WORD IN RESULT ! 7768: * ! 7769: BEF10 MOV WA,(XR) STORED BEFORE COPYING TO DYNAMIC ! 7770: * ! 7771: * MERGE FOR UNCONVERTED RESULT ! 7772: * ! 7773: BEF11 JSR BLKLN GET LENGTH OF BLOCK ! 7774: MOV XR,XL COPY ADDRESS OF OLD BLOCK ! 7775: JSR ALLOC ALLOCATE DYNAMIC BLOCK SAME SIZE ! 7776: MOV XR,-(XS) SET POINTER TO NEW BLOCK AS RESULT ! 7777: MVW COPY OLD BLOCK TO DYNAMIC BLOCK ! 7778: BRN EXITS EXIT WITH RESULT ON STACK ! 7779: .FI ! 7780: EJC ! 7781: * ! 7782: * EVBLK ! 7783: * ! 7784: * THE ROUTINE FOR AN EVBLK IS NEVER EXECUTED ! 7785: * ! 7786: B$EVT ENT BL$EV ENTRY POINT (EVBLK) ! 7787: EJC ! 7788: * ! 7789: * FFBLK ! 7790: * ! 7791: * THE ROUTINE FOR AN FFBLK IS EXECUTED FROM THE O$FNC ENTRY ! 7792: * TO CALL A FIELD FUNCTION AND EXTRACT A FIELD VALUE/NAME. ! 7793: * ! 7794: * (XL) POINTER TO FFBLK ! 7795: * ! 7796: B$FFC ENT BL$FF ENTRY POINT (FFBLK) ! 7797: MOV XL,XR COPY FFBLK POINTER ! 7798: LCW WC LOAD NEXT CODE WORD ! 7799: MOV (XS),XL LOAD PDBLK POINTER ! 7800: BNE (XL),=B$PDT,BFFC2 JUMP IF NOT PDBLK AT ALL ! 7801: MOV PDDFP(XL),WA LOAD DFBLK POINTER FROM PDBLK ! 7802: * ! 7803: * LOOP TO FIND CORRECT FFBLK FOR THIS PDBLK ! 7804: * ! 7805: BFFC1 BEQ WA,FFDFP(XR),BFFC3 JUMP IF THIS IS THE CORRECT FFBLK ! 7806: MOV FFNXT(XR),XR ELSE LINK TO NEXT FFBLK ON CHAIN ! 7807: BNZ XR,BFFC1 LOOP BACK IF ANOTHER ENTRY TO CHECK ! 7808: * ! 7809: * HERE FOR BAD ARGUMENT ! 7810: * ! 7811: BFFC2 ERB 041,FIELD FUNCTION ARGUMENT IS WRONG DATATYPE ! 7812: EJC ! 7813: * ! 7814: * FFBLK (CONTINUED) ! 7815: * ! 7816: * HERE AFTER LOCATING CORRECT FFBLK ! 7817: * ! 7818: BFFC3 MOV FFOFS(XR),WA LOAD FIELD OFFSET ! 7819: BEQ WC,=OFNE$,BFFC5 JUMP IF CALLED BY NAME ! 7820: ADD WA,XL ELSE POINT TO VALUE FIELD ! 7821: MOV (XL),XR LOAD VALUE ! 7822: BNE (XR),=B$TRT,BFFC4 JUMP IF NOT TRAPPED ! 7823: SUB WA,XL ELSE RESTORE NAME BASE,OFFSET ! 7824: MOV WC,(XS) SAVE NEXT CODE WORD OVER PDBLK PTR ! 7825: JSR ACESS ACCESS VALUE ! 7826: PPM EXFAL FAIL IF ACCESS FAILS ! 7827: MOV (XS),WC RESTORE NEXT CODE WORD ! 7828: * ! 7829: * HERE AFTER GETTING VALUE IN (XR) ! 7830: * ! 7831: BFFC4 MOV XR,(XS) STORE VALUE ON STACK (OVER PDBLK) ! 7832: MOV WC,XR COPY NEXT CODE WORD ! 7833: MOV (XR),XL LOAD ENTRY ADDRESS ! 7834: BRI XL JUMP TO ROUTINE FOR NEXT CODE WORD ! 7835: * ! 7836: * HERE IF CALLED BY NAME ! 7837: * ! 7838: BFFC5 MOV WA,-(XS) STORE NAME OFFSET (BASE IS SET) ! 7839: BRN EXITS EXIT WITH NAME ON STACK ! 7840: EJC ! 7841: * ! 7842: * ICBLK ! 7843: * ! 7844: * THE ROUTINE FOR ICBLK IS EXECUTED FROM THE GENERATED ! 7845: * CODE TO LOAD AN INTEGER VALUE ONTO THE STACK. ! 7846: * ! 7847: * (XR) POINTER TO ICBLK ! 7848: * ! 7849: B$ICL ENT BL$IC ENTRY POINT (ICBLK) ! 7850: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD ! 7851: EJC ! 7852: * ! 7853: * KVBLK ! 7854: * ! 7855: * THE ROUTINE FOR A KVBLK IS NEVER EXECUTED. ! 7856: * ! 7857: B$KVT ENT BL$KV ENTRY POINT (KVBLK) ! 7858: EJC ! 7859: * ! 7860: * NMBLK ! 7861: * ! 7862: * THE ROUTINE FOR A NMBLK IS EXECUTED FROM THE GENERATED ! 7863: * CODE FOR THE CASE OF LOADING A NAME ONTO THE STACK ! 7864: * WHERE THE NAME IS THAT OF A NATURAL VARIABLE WHICH CAN ! 7865: * BE PREEVALUATED AT COMPILE TIME. ! 7866: * ! 7867: * (XR) POINTER TO NMBLK ! 7868: * ! 7869: B$NML ENT BL$NM ENTRY POINT (NMBLK) ! 7870: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD ! 7871: EJC ! 7872: * ! 7873: * PDBLK ! 7874: * ! 7875: * THE ROUTINE FOR A PDBLK IS NEVER EXECUTED ! 7876: * ! 7877: B$PDT ENT BL$PD ENTRY POINT (PDBLK) ! 7878: EJC ! 7879: * ! 7880: * PFBLK ! 7881: * ! 7882: * THE ROUTINE FOR A PFBLK IS EXECUTED FROM THE ENTRY O$FNC ! 7883: * TO CALL A PROGRAM DEFINED FUNCTION. ! 7884: * ! 7885: * (XL) POINTER TO PFBLK ! 7886: * ! 7887: * THE FOLLOWING STACK ENTRIES ARE MADE BEFORE PASSING ! 7888: * CONTROL TO THE PROGRAM DEFINED FUNCTION. ! 7889: * ! 7890: * SAVED VALUE OF FIRST ARGUMENT ! 7891: * . ! 7892: * SAVED VALUE OF LAST ARGUMENT ! 7893: * SAVED VALUE OF FIRST LOCAL ! 7894: * . ! 7895: * SAVED VALUE OF LAST LOCAL ! 7896: * SAVED VALUE OF FUNCTION NAME ! 7897: * SAVED CODE BLOCK PTR (R$COD) ! 7898: * SAVED CODE POINTER (-R$COD) ! 7899: * SAVED VALUE OF FLPRT ! 7900: * SAVED VALUE OF FLPTR ! 7901: * POINTER TO PFBLK ! 7902: * FLPTR --------------- ZERO (TO BE OVERWRITTEN WITH OFFS) ! 7903: * ! 7904: B$PFC ENT BL$PF ENTRY POINT (PFBLK) ! 7905: MOV XL,BPFPF SAVE PFBLK PTR (NEED NOT BE RELOC) ! 7906: MOV XL,XR COPY FOR THE MOMENT ! 7907: MOV PFVBL(XR),XL POINT TO VRBLK FOR FUNCTION ! 7908: * ! 7909: * LOOP TO FIND OLD VALUE OF FUNCTION ! 7910: * ! 7911: BPF01 MOV XL,WB SAVE POINTER ! 7912: MOV VRVAL(XL),XL LOAD VALUE ! 7913: BEQ (XL),=B$TRT,BPF01 LOOP IF TRBLK ! 7914: * ! 7915: * SET VALUE TO NULL AND SAVE OLD FUNCTION VALUE ! 7916: * ! 7917: MOV XL,BPFSV SAVE OLD VALUE ! 7918: MOV WB,XL POINT BACK TO BLOCK WITH VALUE ! 7919: MOV =NULLS,VRVAL(XL) SET VALUE TO NULL ! 7920: MOV FARGS(XR),WA LOAD NUMBER OF ARGUMENTS ! 7921: ADD *PFARG,XR POINT TO PFARG ENTRIES ! 7922: BZE WA,BPF04 JUMP IF NO ARGUMENTS ! 7923: MOV XS,XT PTR TO LAST ARG ! 7924: WTB WA CONVERT NO. OF ARGS TO BYTES OFFSET ! 7925: ADD WA,XT POINT BEFORE FIRST ARG ! 7926: MOV XT,BPFXT REMEMBER ARG POINTER ! 7927: EJC ! 7928: * ! 7929: * PFBLK (CONTINUED) ! 7930: * ! 7931: * LOOP TO SAVE OLD ARGUMENT VALUES AND SET NEW ONES ! 7932: * ! 7933: BPF02 MOV (XR)+,XL LOAD VRBLK PTR FOR NEXT ARGUMENT ! 7934: * ! 7935: * LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE ! 7936: * ! 7937: BPF03 MOV XL,WC SAVE POINTER ! 7938: MOV VRVAL(XL),XL LOAD NEXT VALUE ! 7939: BEQ (XL),=B$TRT,BPF03 LOOP BACK IF TRBLK ! 7940: * ! 7941: * SAVE OLD VALUE AND GET NEW VALUE ! 7942: * ! 7943: MOV XL,WA KEEP OLD VALUE ! 7944: MOV BPFXT,XT POINT BEFORE NEXT STACKED ARG ! 7945: MOV -(XT),WB LOAD ARGUMENT (NEW VALUE) ! 7946: MOV WA,(XT) SAVE OLD VALUE ! 7947: MOV XT,BPFXT KEEP ARG PTR FOR NEXT TIME ! 7948: MOV WC,XL POINT BACK TO BLOCK WITH VALUE ! 7949: MOV WB,VRVAL(XL) SET NEW VALUE ! 7950: BNE XS,BPFXT,BPF02 LOOP IF NOT ALL DONE ! 7951: * ! 7952: * NOW PROCESS LOCALS ! 7953: * ! 7954: BPF04 MOV BPFPF,XL RESTORE PFBLK POINTER ! 7955: MOV PFNLO(XL),WA LOAD NUMBER OF LOCALS ! 7956: BZE WA,BPF07 JUMP IF NO LOCALS ! 7957: MOV =NULLS,WB GET NULL CONSTANT ! 7958: LCT WA,WA SET LOCAL COUNTER ! 7959: * ! 7960: * LOOP TO PROCESS LOCALS ! 7961: * ! 7962: BPF05 MOV (XR)+,XL LOAD VRBLK PTR FOR NEXT LOCAL ! 7963: * ! 7964: * LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE ! 7965: * ! 7966: BPF06 MOV XL,WC SAVE POINTER ! 7967: MOV VRVAL(XL),XL LOAD NEXT VALUE ! 7968: BEQ (XL),=B$TRT,BPF06 LOOP BACK IF TRBLK ! 7969: * ! 7970: * SAVE OLD VALUE AND SET NULL AS NEW VALUE ! 7971: * ! 7972: MOV XL,-(XS) STACK OLD VALUE ! 7973: MOV WC,XL POINT BACK TO BLOCK WITH VALUE ! 7974: MOV WB,VRVAL(XL) SET NULL AS NEW VALUE ! 7975: BCT WA,BPF05 LOOP TILL ALL LOCALS PROCESSED ! 7976: EJC ! 7977: * ! 7978: * PFBLK (CONTINUED) ! 7979: * ! 7980: * HERE AFTER PROCESSING ARGUMENTS AND LOCALS ! 7981: * ! 7982: .IF .CNPF ! 7983: BPF07 MOV R$COD,WA LOAD OLD CODE BLOCK POINTER ! 7984: .ELSE ! 7985: BPF07 ZER XR ZERO REG XR IN CASE ! 7986: BZE KVPFL,BPF7C SKIP IF PROFILING IS OFF ! 7987: BEQ KVPFL,=NUM02,BPF7A BRANCH ON TYPE OF PROFILE ! 7988: * ! 7989: * HERE IF &PROFILE = 1 ! 7990: * ! 7991: JSR SYSTM GET CURRENT TIME ! 7992: STI PFETM SAVE FOR A SEC ! 7993: SBI PFSTM FIND TIME USED BY CALLER ! 7994: JSR ICBLD BUILD INTO AN ICBLK ! 7995: LDI PFETM RELOAD CURRENT TIME ! 7996: BRN BPF7B MERGE ! 7997: * ! 7998: * HERE IF &PROFILE = 2 ! 7999: * ! 8000: BPF7A LDI PFSTM GET START TIME OF CALLING STMT ! 8001: JSR ICBLD ASSEMBLE AN ICBLK ROUND IT ! 8002: JSR SYSTM GET NOW TIME ! 8003: * ! 8004: * BOTH TYPES OF PROFILE MERGE HERE ! 8005: * ! 8006: BPF7B STI PFSTM SET START TIME OF 1ST FUNC STMT ! 8007: MNZ PFFNC FLAG FUNCTION ENTRY ! 8008: * ! 8009: * NO PROFILING MERGES HERE ! 8010: * ! 8011: BPF7C MOV XR,-(XS) STACK ICBLK PTR (OR ZERO) ! 8012: MOV R$COD,WA LOAD OLD CODE BLOCK POINTER ! 8013: .FI ! 8014: SCP WB GET CODE POINTER ! 8015: SUB WA,WB MAKE CODE POINTER INTO OFFSET ! 8016: MOV BPFPF,XL RECALL PFBLK POINTER ! 8017: MOV BPFSV,-(XS) STACK OLD VALUE OF FUNCTION NAME ! 8018: MOV WA,-(XS) STACK CODE BLOCK POINTER ! 8019: MOV WB,-(XS) STACK CODE OFFSET ! 8020: MOV FLPRT,-(XS) STACK OLD FLPRT ! 8021: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER ! 8022: MOV XL,-(XS) STACK POINTER TO PFBLK ! 8023: ZER -(XS) DUMMY ZERO ENTRY FOR FAIL RETURN ! 8024: CHK CHECK FOR STACK OVERFLOW ! 8025: MOV XS,FLPTR SET NEW FAIL RETURN VALUE ! 8026: MOV XS,FLPRT SET NEW FLPRT ! 8027: MOV KVTRA,WA LOAD TRACE VALUE ! 8028: ADD KVFTR,WA ADD FTRACE VALUE ! 8029: BNZ WA,BPF09 JUMP IF TRACING POSSIBLE ! 8030: ICV KVFNC ELSE BUMP FNCLEVEL ! 8031: * ! 8032: * HERE TO ACTUALLY JUMP TO FUNCTION ! 8033: * ! 8034: BPF08 MOV PFCOD(XL),XR POINT TO CODE ! 8035: BRI (XR) OFF TO EXECUTE FUNCTION ! 8036: * ! 8037: * HERE IF TRACING IS POSSIBLE ! 8038: * ! 8039: BPF09 MOV PFCTR(XL),XR LOAD POSSIBLE CALL TRACE TRBLK ! 8040: MOV PFVBL(XL),XL LOAD VRBLK POINTER FOR FUNCTION ! 8041: MOV *VRVAL,WA SET NAME OFFSET FOR VARIABLE ! 8042: BZE KVTRA,BPF10 JUMP IF TRACE MODE IS OFF ! 8043: BZE XR,BPF10 OR IF THERE IS NO CALL TRACE ! 8044: * ! 8045: * HERE IF CALL TRACED ! 8046: * ! 8047: DCV KVTRA DECREMENT TRACE COUNT ! 8048: BZE TRFNC(XR),BPF11 JUMP IF PRINT TRACE ! 8049: JSR TRXEQ EXECUTE FUNCTION TYPE TRACE ! 8050: EJC ! 8051: * ! 8052: * PFBLK (CONTINUED) ! 8053: * ! 8054: * HERE TO TEST FOR FTRACE TRACE ! 8055: * ! 8056: BPF10 BZE KVFTR,BPF16 JUMP IF FTRACE IS OFF ! 8057: DCV KVFTR ELSE DECREMENT FTRACE ! 8058: * ! 8059: * HERE FOR PRINT TRACE ! 8060: * ! 8061: BPF11 JSR PRTSN PRINT STATEMENT NUMBER ! 8062: JSR PRTNM PRINT FUNCTION NAME ! 8063: MOV =CH$PP,WA LOAD LEFT PAREN ! 8064: JSR PRTCH PRINT LEFT PAREN ! 8065: MOV 1(XS),XL RECOVER PFBLK POINTER ! 8066: BZE FARGS(XL),BPF15 SKIP IF NO ARGUMENTS ! 8067: ZER WB ELSE SET ARGUMENT COUNTER ! 8068: BRN BPF13 JUMP INTO LOOP ! 8069: * ! 8070: * LOOP TO PRINT ARGUMENT VALUES ! 8071: * ! 8072: BPF12 MOV =CH$CM,WA LOAD COMMA ! 8073: JSR PRTCH PRINT TO SEPARATE FROM LAST ARG ! 8074: * ! 8075: * MERGE HERE FIRST TIME (NO COMMA REQUIRED) ! 8076: * ! 8077: BPF13 MOV WB,(XS) SAVE ARG CTR (OVER FAILOFFS IS OK) ! 8078: WTB WB CONVERT TO BYTE OFFSET ! 8079: ADD WB,XL POINT TO NEXT ARGUMENT POINTER ! 8080: MOV PFARG(XL),XR LOAD NEXT ARGUMENT VRBLK PTR ! 8081: SUB WB,XL RESTORE PFBLK POINTER ! 8082: MOV VRVAL(XR),XR LOAD NEXT VALUE ! 8083: JSR PRTVL PRINT ARGUMENT VALUE ! 8084: EJC ! 8085: * ! 8086: * HERE AFTER DEALING WITH ONE ARGUMENT ! 8087: * ! 8088: MOV (XS),WB RESTORE ARGUMENT COUNTER ! 8089: ICV WB INCREMENT ARGUMENT COUNTER ! 8090: BLT WB,FARGS(XL),BPF12 LOOP IF MORE TO PRINT ! 8091: * ! 8092: * MERGE HERE IN NO ARGS CASE TO PRINT PAREN ! 8093: * ! 8094: BPF15 MOV =CH$RP,WA LOAD RIGHT PAREN ! 8095: JSR PRTCH PRINT TO TERMINATE OUTPUT ! 8096: JSR PRTNL TERMINATE PRINT LINE ! 8097: * ! 8098: * MERGE HERE TO EXIT WITH TEST FOR FNCLEVEL TRACE ! 8099: * ! 8100: BPF16 ICV KVFNC INCREMENT FNCLEVEL ! 8101: MOV R$FNC,XL LOAD PTR TO POSSIBLE TRBLK ! 8102: JSR KTREX CALL KEYWORD TRACE ROUTINE ! 8103: * ! 8104: * CALL FUNCTION AFTER TRACE TESTS COMPLETE ! 8105: * ! 8106: MOV 1(XS),XL RESTORE PFBLK POINTER ! 8107: BRN BPF08 JUMP BACK TO EXECUTE FUNCTION ! 8108: .IF .CNRA ! 8109: .ELSE ! 8110: EJC ! 8111: * ! 8112: * RCBLK ! 8113: * ! 8114: * THE ROUTINE FOR AN RCBLK IS EXECUTED FROM THE GENERATED ! 8115: * CODE TO LOAD A REAL VALUE ONTO THE STACK. ! 8116: * ! 8117: * (XR) POINTER TO RCBLK ! 8118: * ! 8119: B$RCL ENT BL$RC ENTRY POINT (RCBLK) ! 8120: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD ! 8121: .FI ! 8122: EJC ! 8123: * ! 8124: * SCBLK ! 8125: * ! 8126: * THE ROUTINE FOR AN SCBLK IS EXECUTED FROM THE GENERATED ! 8127: * CODE TO LOAD A STRING VALUE ONTO THE STACK. ! 8128: * ! 8129: * (XR) POINTER TO SCBLK ! 8130: * ! 8131: B$SCL ENT BL$SC ENTRY POINT (SCBLK) ! 8132: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD ! 8133: EJC ! 8134: * ! 8135: * TBBLK ! 8136: * ! 8137: * THE ROUTINE FOR A TBBLK IS NEVER EXECUTED ! 8138: * ! 8139: B$TBT ENT BL$TB ENTRY POINT (TBBLK) ! 8140: EJC ! 8141: * ! 8142: * TEBLK ! 8143: * ! 8144: * THE ROUTINE FOR A TEBLK IS NEVER EXECUTED ! 8145: * ! 8146: B$TET ENT BL$TE ENTRY POINT (TEBLK) ! 8147: EJC ! 8148: * ! 8149: * VCBLK ! 8150: * ! 8151: * THE ROUTINE FOR A VCBLK IS NEVER EXECUTED ! 8152: * ! 8153: B$VCT ENT BL$VC ENTRY POINT (VCBLK) ! 8154: EJC ! 8155: * ! 8156: * VRBLK ! 8157: * ! 8158: * THE VRBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE. ! 8159: * THERE ARE SIX ENTRIES FOR VRBLK COVERING VARIOUS CASES ! 8160: * ! 8161: B$VR$ ENT BL$$I MARK START OF VRBLK ENTRY POINTS ! 8162: * ! 8163: * ENTRY FOR VRGET (TRAPPED CASE). THIS ROUTINE IS CALLED ! 8164: * FROM THE GENERATED CODE TO LOAD THE VALUE OF A VARIABLE. ! 8165: * THIS ENTRY POINT IS USED IF AN ACCESS TRACE OR INPUT ! 8166: * ASSOCIATION IS CURRENTLY ACTIVE. ! 8167: * ! 8168: * (XR) POINTER TO VRGET FIELD OF VRBLK ! 8169: * ! 8170: B$VRA ENT BL$$I ENTRY POINT ! 8171: MOV XR,XL COPY NAME BASE (VRGET = 0) ! 8172: MOV *VRVAL,WA SET NAME OFFSET ! 8173: JSR ACESS ACCESS VALUE ! 8174: PPM EXFAL FAIL IF ACCESS FAILS ! 8175: BRN EXIXR ELSE EXIT WITH RESULT IN XR ! 8176: EJC ! 8177: * ! 8178: * VRBLK (CONTINUED) ! 8179: * ! 8180: * ENTRY FOR VRSTO (ERROR CASE. THIS ROUTINE IS CALLED FROM ! 8181: * THE EXECUTED CODE FOR AN ATTEMPT TO MODIFY THE VALUE ! 8182: * OF A PROTECTED (PATTERN VALUED) NATURAL VARIABLE. ! 8183: * ! 8184: B$VRE ENT ENTRY POINT ! 8185: ERB 042,ATTEMPT TO CHANGE VALUE OF PROTECTED VARIABLE ! 8186: EJC ! 8187: * ! 8188: * VRBLK (CONTINUED) ! 8189: * ! 8190: * ENTRY FOR VRTRA (UNTRAPPED CASE). THIS ROUTINE IS CALLED ! 8191: * FROM THE EXECUTED CODE TO TRANSFER TO A LABEL. ! 8192: * ! 8193: * (XR) POINTER TO VRTRA FIELD OF VRBLK ! 8194: * ! 8195: B$VRG ENT ENTRY POINT ! 8196: MOV VRLBO(XR),XR LOAD CODE POINTER ! 8197: MOV (XR),XL LOAD ENTRY ADDRESS ! 8198: BRI XL JUMP TO ROUTINE FOR NEXT CODE WORD ! 8199: EJC ! 8200: * ! 8201: * VRBLK (CONTINUED) ! 8202: * ! 8203: * ENTRY FOR VRGET (UNTRAPPED CASE). THIS ROUTINE IS CALLED ! 8204: * FROM THE GENERATED CODE TO LOAD THE VALUE OF A VARIABLE. ! 8205: * ! 8206: * (XR) POINTS TO VRGET FIELD OF VRBLK ! 8207: * ! 8208: B$VRL ENT ENTRY POINT ! 8209: MOV VRVAL(XR),-(XS) LOAD VALUE ONTO STACK (VRGET = 0) ! 8210: BRN EXITS OBEY NEXT CODE WORD ! 8211: EJC ! 8212: * ! 8213: * VRBLK (CONTINUED) ! 8214: * ! 8215: * ENTRY FOR VRSTO (UNTRAPPED CASE). THIS ROUTINE IS CALLED ! 8216: * FROM THE GENERATED CODE TO STORE THE VALUE OF A VARIABLE. ! 8217: * ! 8218: * (XR) POINTER TO VRSTO FIELD OF VRBLK ! 8219: * ! 8220: B$VRS ENT ENTRY POINT ! 8221: MOV (XS),VRVLO(XR) STORE VALUE, LEAVE ON STACK ! 8222: BRN EXITS OBEY NEXT CODE WORD ! 8223: EJC ! 8224: * ! 8225: * VRBLK (CONTINUED) ! 8226: * ! 8227: * VRTRA (TRAPPED CASE). THIS ROUTINE IS CALLED FROM THE ! 8228: * GENERATED CODE TO TRANSFER TO A LABEL WHEN A LABEL ! 8229: * TRACE IS CURRENTLY ACTIVE. ! 8230: * ! 8231: B$VRT ENT ENTRY POINT ! 8232: SUB *VRTRA,XR POINT BACK TO START OF VRBLK ! 8233: MOV XR,XL COPY VRBLK POINTER ! 8234: MOV *VRVAL,WA SET NAME OFFSET ! 8235: MOV VRLBL(XL),XR LOAD POINTER TO TRBLK ! 8236: BZE KVTRA,BVRT2 JUMP IF TRACE IS OFF ! 8237: DCV KVTRA ELSE DECREMENT TRACE COUNT ! 8238: BZE TRFNC(XR),BVRT1 JUMP IF PRINT TRACE CASE ! 8239: JSR TRXEQ ELSE EXECUTE FULL TRACE ! 8240: BRN BVRT2 MERGE TO JUMP TO LABEL ! 8241: * ! 8242: * HERE FOR PRINT TRACE -- PRINT COLON ( LABEL NAME ) ! 8243: * ! 8244: BVRT1 JSR PRTSN PRINT STATEMENT NUMBER ! 8245: MOV XL,XR COPY VRBLK POINTER ! 8246: MOV =CH$CL,WA COLON ! 8247: JSR PRTCH PRINT IT ! 8248: MOV =CH$PP,WA LEFT PAREN ! 8249: JSR PRTCH PRINT IT ! 8250: JSR PRTVN PRINT LABEL NAME ! 8251: MOV =CH$RP,WA RIGHT PAREN ! 8252: JSR PRTCH PRINT IT ! 8253: JSR PRTNL TERMINATE LINE ! 8254: MOV VRLBL(XL),XR POINT BACK TO TRBLK ! 8255: * ! 8256: * MERGE HERE TO JUMP TO LABEL ! 8257: * ! 8258: BVRT2 MOV TRLBL(XR),XR LOAD POINTER TO ACTUAL CODE ! 8259: BRI (XR) EXECUTE STATEMENT AT LABEL ! 8260: EJC ! 8261: * ! 8262: * VRBLK (CONTINUED) ! 8263: * ! 8264: * ENTRY FOR VRSTO (TRAPPED CASE). THIS ROUTINE IS CALLED ! 8265: * FROM THE GENERATED CODE TO STORE THE VALUE OF A VARIABLE. ! 8266: * THIS ENTRY IS USED WHEN A VALUE TRACE OR OUTPUT ! 8267: * ASSOCIATION IS CURRENTLY ACTIVE. ! 8268: * ! 8269: * (XR) POINTER TO VRSTO FIELD OF VRBLK ! 8270: * ! 8271: B$VRV ENT ENTRY POINT ! 8272: MOV (XS),WB LOAD VALUE (LEAVE COPY ON STACK) ! 8273: SUB *VRSTO,XR POINT TO VRBLK ! 8274: MOV XR,XL COPY VRBLK POINTER ! 8275: MOV *VRVAL,WA SET OFFSET ! 8276: JSR ASIGN CALL ASSIGNMENT ROUTINE ! 8277: PPM EXFAL FAIL IF ASSIGNMENT FAILS ! 8278: BRN EXITS ELSE RETURN WITH RESULT ON STACK ! 8279: EJC ! 8280: * ! 8281: * XNBLK ! 8282: * ! 8283: * THE ROUTINE FOR AN XNBLK IS NEVER EXECUTED ! 8284: * ! 8285: B$XNT ENT BL$XN ENTRY POINT (XNBLK) ! 8286: EJC ! 8287: * ! 8288: * XRBLK ! 8289: * ! 8290: * THE ROUTINE FOR AN XRBLK IS NEVER EXECUTED ! 8291: * ! 8292: B$XRT ENT BL$XR ENTRY POINT (XRBLK) ! 8293: * ! 8294: * MARK ENTRY ADDRESS PAST LAST BLOCK ACTION ROUTINE ! 8295: * ! 8296: B$YYY ENT BL$$I LAST BLOCK ROUTINE ENTRY POINT ! 8297: TTL S P I T B O L -- PATTERN MATCHING ROUTINES ! 8298: * ! 8299: * THE FOLLOWING SECTION CONSISTS OF THE PATTERN MATCHING ! 8300: * ROUTINES. ALL PATTERN NODES CONTAIN A POINTER (PCODE) ! 8301: * TO ONE OF THE ROUTINES IN THIS SECTION (P$XXX). ! 8302: * ! 8303: * NOTE THAT THIS SECTION FOLLOWS THE B$XXX ROUTINES TO ! 8304: * ENABLE A FAST TEST FOR THE PATTERN DATATYPE. ! 8305: * ! 8306: P$AAA ENT BL$$I ENTRY TO MARK FIRST PATTERN ! 8307: * ! 8308: * ! 8309: * THE ENTRY CONDITIONS TO THE MATCH ROUTINE ARE AS FOLLOWS ! 8310: * (SEE O$PMN, O$PMV, O$PMS AND PROCEDURE MATCH). ! 8311: * ! 8312: * STACK CONTENTS. ! 8313: * ! 8314: * NAME BASE (O$PMN ONLY) ! 8315: * NAME OFFSET (O$PMN ONLY) ! 8316: * TYPE (0-O$PMN, 1-O$PMV, 2-O$PMS) ! 8317: * PMHBS --------------- INITIAL CURSOR (ZERO) ! 8318: * INITIAL NODE POINTER ! 8319: * XS ------------------ =NDABO (ANCHORED), =NDUNA (UNANCH) ! 8320: * ! 8321: * REGISTER VALUES. ! 8322: * ! 8323: * (XS) SET AS SHOWN IN STACK DIAGRAM ! 8324: * (XR) POINTER TO INITIAL PATTERN NODE ! 8325: * (WB) INITIAL CURSOR (ZERO) ! 8326: * ! 8327: * GLOBAL PATTERN VALUES ! 8328: * ! 8329: * R$PMS POINTER TO SUBJECT STRING SCBLK ! 8330: * PMSSL LENGTH OF SUBJECT STRING IN CHARS ! 8331: * PMDFL DOT FLAG, INITIALLY ZERO ! 8332: * PMHBS SET AS SHOWN IN STACK DIAGRAM ! 8333: * ! 8334: * CONTROL IS PASSED BY BRANCHING THROUGH THE PCODE ! 8335: * FIELD OF THE INITIAL PATTERN NODE (BRI (XR)). ! 8336: EJC ! 8337: * ! 8338: * DESCRIPTION OF ALGORITHM ! 8339: * ! 8340: * A PATTERN STRUCTURE IS REPRESENTED AS A LINKED GRAPH ! 8341: * OF NODES WITH THE FOLLOWING STRUCTURE. ! 8342: * ! 8343: * +------------------------------------+ ! 8344: * I PCODE I ! 8345: * +------------------------------------+ ! 8346: * I PTHEN I ! 8347: * +------------------------------------+ ! 8348: * I PARM1 I ! 8349: * +------------------------------------+ ! 8350: * I PARM2 I ! 8351: * +------------------------------------+ ! 8352: * ! 8353: * PCODE IS A POINTER TO THE ROUTINE WHICH WILL PERFORM ! 8354: * THE MATCH OF THIS PARTICULAR NODE TYPE. ! 8355: * ! 8356: * PTHEN IS A POINTER TO THE SUCCESSOR NODE. I.E. THE NODE ! 8357: * TO BE MATCHED IF THE ATTEMPT TO MATCH THIS NODE SUCCEEDS. ! 8358: * IF THIS IS THE LAST NODE OF THE PATTERN PTHEN POINTS ! 8359: * TO THE DUMMY NODE NDNTH WHICH INITIATES PATTERN EXIT. ! 8360: * ! 8361: * PARM1, PARM2 ARE PARAMETERS WHOSE USE VARIES WITH THE ! 8362: * PARTICULAR NODE. THEY ARE ONLY PRESENT IF REQUIRED. ! 8363: * ! 8364: * ALTERNATIVES ARE HANDLED WITH THE SPECIAL ALTERNATIVE ! 8365: * NODE WHOSE PARAMETER POINTS TO THE NODE TO BE MATCHED ! 8366: * IF THERE IS A FAILURE ON THE SUCCESSOR PATH. ! 8367: * ! 8368: * THE FOLLOWING EXAMPLE ILLUSTRATES THE MANNER IN WHICH ! 8369: * THE STRUCTURE IS BUILT UP. THE PATTERN IS ! 8370: * ! 8371: * (A / B / C) (D / E) WHERE / IS ALTERNATION ! 8372: * ! 8373: * IN THE DIAGRAM, THE NODE MARKED + REPRESENTS AN ! 8374: * ALTERNATIVE NODE AND THE DOTTED LINE FROM A + NODE ! 8375: * REPRESENTS THE PARAMETER POINTER TO THE ALTERNATIVE. ! 8376: * ! 8377: * +---+ +---+ +---+ +---+ ! 8378: * I + I-----I A I-----I + I-----I D I----- ! 8379: * +---+ +---+ I +---+ +---+ ! 8380: * . I . ! 8381: * . I . ! 8382: * +---+ +---+ I +---+ ! 8383: * I + I-----I B I--I I E I----- ! 8384: * +---+ +---+ I +---+ ! 8385: * . I ! 8386: * . I ! 8387: * +---+ I ! 8388: * I C I------------I ! 8389: * +---+ ! 8390: EJC ! 8391: * ! 8392: * DURING THE MATCH, THE REGISTERS ARE USED AS FOLLOWS. ! 8393: * ! 8394: * (XR) POINTS TO THE CURRENT NODE ! 8395: * (XL) SCRATCH ! 8396: * (XS) MAIN STACK POINTER ! 8397: * (WB) CURSOR (NUMBER OF CHARS MATCHED) ! 8398: * (WA,WC) SCRATCH ! 8399: * ! 8400: * TO KEEP TRACK OF ALTERNATIVES, THE MAIN STACK IS USED AS ! 8401: * A HISTORY STACK AND CONTAINS TWO WORD ENTRIES. ! 8402: * ! 8403: * WORD 1 SAVED CURSOR VALUE ! 8404: * WORD 2 NODE TO MATCH ON FAILURE ! 8405: * ! 8406: * WHEN A FAILURE OCCURS, THE MOST RECENT ENTRY ON THIS ! 8407: * STACK IS POPPED OFF TO RESTORE THE CURSOR AND POINT ! 8408: * TO THE NODE TO BE MATCHED AS AN ALTERNATIVE. THE ENTRY ! 8409: * AT THE BOTTOM OF THE STACK POINTS TO THE FOLLOWING ! 8410: * SPECIAL NODES DEPENDING ON THE SCAN MODE. ! 8411: * ! 8412: * ANCHORED MODE THE BOTTOM ENTRY POINTS TO THE ! 8413: * SPECIAL NODE NDABO WHICH CAUSES AN ! 8414: * ABORT. THE CURSOR VALUE STORED ! 8415: * WITH THIS ENTRY IS ALWAYS ZERO. ! 8416: * ! 8417: * UNANCHORED MODE THE BOTTOM ENTRY POINTS TO THE ! 8418: * SPECIAL NODE NDUNA WHICH MOVES THE ! 8419: * ANCHOR POINT AND RESTARTS THE MATCH ! 8420: * THE CURSOR SAVED WITH THIS ENTRY ! 8421: * IS THE NUMBER OF CHARACTERS WHICH ! 8422: * LIE BEFORE THE INITIAL ANCHOR POINT ! 8423: * (I.E. THE NUMBER OF ANCHOR MOVES). ! 8424: * THIS ENTRY IS THREE WORDS LONG AND ! 8425: * ALSO CONTAINS THE INITIAL PATTERN. ! 8426: * ! 8427: * ENTRIES ARE MADE ON THIS HISTORY STACK BY ALTERNATIVE ! 8428: * NODES AND BY SOME SPECIAL COMPOUD PATTERNS AS DESCRIBED ! 8429: * LATER ON. THE FOLLOWING GLOBAL LOCATIONS ARE USED DURING ! 8430: * PATTERN MATCHING. ! 8431: * ! 8432: * R$PMS POINTER TO SUBJECT STRING ! 8433: * PMSSL LENGTH OF SUBJECT STRING ! 8434: * PMDFL FLAG SET NON-ZERO FOR DOT PATTERNS ! 8435: * PMHBS BASE PTR FOR CURRENT HISTORY STACK ! 8436: * ! 8437: * THE FOLLOWING EXIT POINTS ARE AVAILABLE TO MATCH ROUTINES ! 8438: * ! 8439: * SUCCP SUCCESS IN MATCHING CURRENT NODE ! 8440: * FAILP FAILURE IN MATCHING CURRENT NODE ! 8441: EJC ! 8442: * ! 8443: * COMPOUND PATTERNS ! 8444: * ! 8445: * SOME PATTERNS HAVE IMPLICIT ALTERNATIVES AND THEIR ! 8446: * REPRESENTATION IN THE PATTERN STRUCTURE CONSISTS OF A ! 8447: * LINKED SET OF NODES AS INDICATED BY THESE DIAGRAMS. ! 8448: * ! 8449: * AS BEFORE, THE + REPRESENTS AN ALTERNATIVE NODE AND ! 8450: * THE DOTTED LINE FROM A + NODE IS THE PARAMETER POINTER ! 8451: * TO THE ALTERNATIVE PATTERN. ! 8452: * ! 8453: * ARB ! 8454: * --- ! 8455: * ! 8456: * +---+ THIS NODE (P$ARB) MATCHES NULL ! 8457: * I B I----- AND STACKS CURSOR, SUCCESSOR PTR, ! 8458: * +---+ CURSOR (COPY) AND A PTR TO NDARC. ! 8459: * ! 8460: * ! 8461: * ! 8462: * ! 8463: * BAL ! 8464: * --- ! 8465: * ! 8466: * +---+ THE P$BAL NODE SCANS A BALANCED ! 8467: * I B I----- STRING AND THEN STACKS A POINTER ! 8468: * +---+ TO ITSELF ON THE HISTORY STACK. ! 8469: EJC ! 8470: * ! 8471: * COMPOUND PATTERN STRUCTURES (CONTINUED) ! 8472: * ! 8473: * ! 8474: * ARBNO ! 8475: * ----- ! 8476: * ! 8477: * +---+ THIS ALTERNATIVE NODE MATCHES NULL ! 8478: * +----I + I----- THE FIRST TIME AND STACKS A POINTER ! 8479: * I +---+ TO THE ARGUMENT PATTERN X. ! 8480: * I . ! 8481: * I . ! 8482: * I +---+ NODE (P$ABA) TO STACK CURSOR ! 8483: * I I A I AND HISTORY STACK BASE PTR. ! 8484: * I +---+ ! 8485: * I I ! 8486: * I I ! 8487: * I +---+ THIS IS THE ARGUMENT PATTERN. AS ! 8488: * I I X I INDICATED, THE SUCCESSOR OF THE ! 8489: * I +---+ PATTERN IS THE P$ABC NODE ! 8490: * I I ! 8491: * I I ! 8492: * I +---+ THIS NODE (P$ABC) POPS PMHBS, ! 8493: * +----I C I STACKS OLD PMHBS AND PTR TO NDABD ! 8494: * +---+ (UNLESS OPTIMISATION HAS OCCURRED) ! 8495: * ! 8496: * STRUCTURE AND EXECUTION OF THIS PATTERN RESEMBLE THOSE OF ! 8497: * RECURSIVE PATTERN MATCHING AND IMMEDIATE ASSIGNMENT. ! 8498: * THE ALTERNATIVE NODE AT THE HEAD OF THE STRUCTURE MATCHES ! 8499: * NULL INITIALLY BUT ON SUBSEQUENT FAILURE ENSURES ATTEMPT ! 8500: * TO MATCH THE ARGUMENT. BEFORE THE ARGUMENT IS MATCHED ! 8501: * P$ABA STACKS THE CURSOR,PMHBS AND A PTR TO P$ABB. IF ! 8502: * THE ARGUMENT CANT BE MATCHED , P$ABB REMOVES THIS SPECIAL ! 8503: * STACK ENTRY AND FAILS. ! 8504: * IF ARGUMENT IS MATCHED , P$ABC RESTORES THE OUTER PMHBS ! 8505: * VALUE (SAVED BY P$ABA) . THEN IF THE ARGUMENT HAS LEFT ! 8506: * ALTERNATIVES ON STACK IT STACKS THE INNER VALUE OF PMHBS ! 8507: * AND A PTR TO NDABD. IF ARGUMENT LEFT NOTHING ON THE STACK ! 8508: * IT OPTIMISES BY REMOVING ITEMS STACKED BY P$ABA. FINALLY ! 8509: * A CHECK IS MADE THAT ARGUMENT MATCHED MORE THAN THE NULL ! 8510: * STRING (CHECK IS INTENDED TO PREVENT USELESS LOOPING). ! 8511: * IF SO THE SUCCESSOR IS AGAIN THE ALTERNATIVE NODE AT THE ! 8512: * HEAD OF THE STRUCTURE , ENSURING A POSSIBLE EXTRA ATTEMPT ! 8513: * TO MATCH THE ARG IF NECESSARY. IF NOT , THE SUCCESSOR TO ! 8514: * ALTERNATIVE IS TAKEN SO AS TO TERMINATE THE LOOP. P$ABD ! 8515: * RESTORES INNER PMHBS PTR AND FAILS , THUS TRYING TO MATCH ! 8516: * ALTERNATIVES LEFT BY THE ARBNO ARGUMENT. ! 8517: EJC ! 8518: * ! 8519: * COMPOUND PATTERN STRUCTURES (CONTINUED) ! 8520: * ! 8521: * BREAKX ! 8522: * ------ ! 8523: * ! 8524: * +---+ THIS NODE IS A BREAK NODE FOR ! 8525: * +----I B I THE ARGUMENT TO BREAKX, IDENTICAL ! 8526: * I +---+ TO AN ORDINARY BREAK NODE. ! 8527: * I I ! 8528: * I I ! 8529: * I +---+ THIS ALTERNATIVE NODE STACKS A ! 8530: * I I + I----- POINTER TO THE BREAKX NODE TO ! 8531: * I +---+ ALLOW FOR SUBSEQUENT FAILURE ! 8532: * I . ! 8533: * I . ! 8534: * I +---+ THIS IS THE BREAKX NODE ITSELF. IT ! 8535: * +----I X I MATCHES ONE CHARACTER AND THEN ! 8536: * +---+ PROCEEDS BACK TO THE BREAK NODE. ! 8537: * ! 8538: * ! 8539: * ! 8540: * ! 8541: * FENCE ! 8542: * ----- ! 8543: * ! 8544: * +---+ THE FENCE NODE MATCHES NULL AND ! 8545: * I F I----- STACKS A POINTER TO NODE NDABO TO ! 8546: * +---+ ABORT ON A SUBSEQUENT REMATCH ! 8547: * ! 8548: * ! 8549: * ! 8550: * ! 8551: * SUCCEED ! 8552: * ------- ! 8553: * ! 8554: * +---+ THE NODE FOR SUCCEED MATCHES NULL ! 8555: * I S I----- AND STACKS A POINTER TO ITSELF ! 8556: * +---+ TO REPEAT THE MATCH ON A FAILURE. ! 8557: EJC ! 8558: * ! 8559: * COMPOUND PATTERNS (CONTINUED) ! 8560: * ! 8561: * BINARY DOT (PATTERN ASSIGNMENT) ! 8562: * ------------------------------- ! 8563: * ! 8564: * +---+ THIS NODE (P$PAA) SAVES THE CURRENT ! 8565: * I A I CURSOR AND A POINTER TO THE ! 8566: * +---+ SPECIAL NODE NDPAB ON THE STACK. ! 8567: * I ! 8568: * I ! 8569: * +---+ THIS IS THE STRUCTURE FOR THE ! 8570: * I X I PATTERN LEFT ARGUMENT OF THE ! 8571: * +---+ PATTERN ASSIGNMENT CALL. ! 8572: * I ! 8573: * I ! 8574: * +---+ THIS NODE (P$PAC) SAVES THE CURSOR, ! 8575: * I C I----- A PTR TO ITSELF, THE CURSOR (COPY) ! 8576: * +---+ AND A PTR TO NDPAD ON THE STACK. ! 8577: * ! 8578: * ! 8579: * THE FUNCTION OF THE MATCH ROUTINE FOR NDPAB (P$PAB) ! 8580: * IS SIMPLY TO UNSTACK ITSELF AND FAIL BACK ONTO THE STACK. ! 8581: * ! 8582: * THE MATCH ROUTINE FOR P$PAC ALSO SETS THE GLOBAL PATTERN ! 8583: * FLAG PMDFL NON-ZERO TO INDICATE THAT PATTERN ASSIGNMENTS ! 8584: * MAY HAVE OCCURED IN THE PATTERN MATCH ! 8585: * ! 8586: * IF PMDFL IS SET AT THE END OF THE MATCH (SEE P$NTH), THE ! 8587: * HISTORY STACK IS SCANNED FOR MATCHING NDPAB-NDPAD PAIRS ! 8588: * AND THE CORRESPONDING PATTERN ASSIGNMENTS ARE EXECUTED. ! 8589: * ! 8590: * THE FUNCTION OF THE MATCH ROUTINE FOR NDPAD (P$PAD) ! 8591: * IS SIMPLY TO REMOVE ITS ENTRY FROM THE STACK AND FAIL. ! 8592: * THIS INCLUDES REMOVING THE SPECIAL NODE POINTER STORED ! 8593: * IN ADDITION TO THE STANDARD TWO ENTRIES ON THE STACK. ! 8594: EJC ! 8595: * ! 8596: * COMPOUNT PATTERN STRUCTURES (CONTINUED) ! 8597: * ! 8598: * FENCE (FUNCTION) ! 8599: * ---------------- ! 8600: * ! 8601: * +---+ THIS NODE (P$FNA) SAVES THE ! 8602: * I A I CURRENT HISTORY STACK AND A ! 8603: * +---+ POINTER TO NDFNB ON THE STACK. ! 8604: * I ! 8605: * I ! 8606: * +---+ THIS IS THE PATTERN STRUCTURE ! 8607: * I X I GIVEN AS THE ARGUMENT TO THE ! 8608: * +---+ FENCE FUNCTION. ! 8609: * I ! 8610: * I ! 8611: * +---+ THIS NODE P$FNC RESTORES THE OUTER ! 8612: * I C I HISTORY STACK PTR SAVED IN P$FNA, ! 8613: * +---+ AND STACKS THE INNER STACK BASE ! 8614: * PTR AND A POINTER TO NDFND ON THE ! 8615: * STACK. ! 8616: * ! 8617: * NDFNB (F$FNB) SIMPLY IS THE FAILURE EXIT FOR PATTERN ! 8618: * ARGUMENT FAILURE, AND IT POPS ITSELF AND FAILS ONTO THE ! 8619: * STACK. ! 8620: * ! 8621: * THE MATCH ROUTINE P$FNC ALLOWS FOR AN OPTIMIZATION WHEN ! 8622: * THE FENCE PATTERN LEAVES NO ALTERNATIVES. IN THIS CASE, ! 8623: * THE NDFNB ENTRY IS POPPED, AND THE MATCH CONTINUES. ! 8624: * ! 8625: * NDFND (P$FND) IS ENTERED WHEN THE PATTERN FAILS AFTER ! 8626: * GOING THROUGH A NON-OPTIMIZED P$FNC, AND IT POPS THE ! 8627: * STACK BACK PAST THE INNTER STACK BASE CREATED BY P$FNA ! 8628: EJC ! 8629: * ! 8630: * COMPOUND PATTERNS (CONTINUED) ! 8631: * ! 8632: * EXPRESSION PATTERNS (RECURSIVE PATTERN MATCHES) ! 8633: * ----------------------------------------------- ! 8634: * ! 8635: * INITIAL ENTRY FOR A PATTERN NODE IS TO THE ROUTINE P$EXA. ! 8636: * IF THE EVALUATED RESULT OF THE EXPRESSION IS ITSELF A ! 8637: * PATTERN, THEN THE FOLLOWING STEPS ARE TAKEN TO ARRANGE ! 8638: * FOR PROPER RECURSIVE PROCESSING. ! 8639: * ! 8640: * 1) A POINTER TO THE CURRENT NODE (THE P$EXA NODE) IS ! 8641: * STORED ON THE HISTORY STACK WITH A DUMMY CURSOR. ! 8642: * ! 8643: * 2) A SPECIAL HISTORY STACK ENTRY IS MADE IN WHICH THE ! 8644: * NODE POINTER POINTS TO NDEXB, AND THE CURSOR VALUE ! 8645: * IS THE SAVED VALUE OF PMHBS ON ENTRY TO THIS NODE. ! 8646: * THE MATCH ROUTINE FOR NDEXB (P$EXB) RESTORES PMHBS ! 8647: * FROM THIS CURSOR ENTRY, POPS OFF THE P$EXA NODE ! 8648: * POINTER AND FAILS. ! 8649: * ! 8650: * 3) THE RESULTING HISTORY STACK POINTER IS SAVED IN ! 8651: * PMHBS TO ESTABLISH A NEW LEVEL OF HISTORY STACK. ! 8652: * ! 8653: * AFTER MATCHING A PATTERN, THE END OF MATCH ROUTINE GETS ! 8654: * CONTROL (P$NTH). THIS ROUTINE PROCEEDS AS FOLLOWS. ! 8655: * ! 8656: * 1) LOAD THE CURRENT VALUE OF PMHBS AND RECOGNIZE THE ! 8657: * OUTER LEVEL CASE BY THE FACT THAT THE ASSOCIATED ! 8658: * CURSOR IN THIS CASE IS THE PATTERN MATCH TYPE CODE ! 8659: * WHICH IS LESS THAN 3. TERMINATE THE MATCH IN THIS ! 8660: * CASE AND CONTINUE EXECUTION OF THE PROGRAM. ! 8661: * ! 8662: * 2) OTHERWISE MAKE A SPECIAL HISTORY STACK ENTRY IN ! 8663: * WHICH THE NODE POINTER POINTS TO THE SPECIAL NODE ! 8664: * NDEXC AND THE CURSOR IS THE CURRENT VALUE OF PMHBS. ! 8665: * THE MATCH ROUTINE FOR NDEXC (P$EXC) RESETS PMHBS TO ! 8666: * THIS (INNER) VALUE AND AND THEN FAILS. ! 8667: * ! 8668: * 3) USING THE HISTORY STACK ENTRY MADE ON STARTING THE ! 8669: * EXPRESSION (ACCESSIBLE WITH THE CURRENT VALUE OF ! 8670: * PMHBS), RESTORE THE P$EXA NODE POINTER AND THE OLD ! 8671: * PMHBS SETTING. TAKE THE SUCCESSOR AND CONTINUE. ! 8672: * ! 8673: * AN OPTIMIZATION IS POSSIBLE IF THE EXPRESSION PATTERN ! 8674: * MAKES NO ENTRIES ON THE HISTORY STACK. IN THIS CASE, ! 8675: * INSTEAD OF BUILDING THE P$EXC NODE IN STEP 2, IT IS MORE ! 8676: * EFFICIENT TO SIMPLY POP OFF THE P$EXB ENTRY AND ITS ! 8677: * ASSOCIATED NODE POINTER. THE EFFECT IS THE SAME. ! 8678: EJC ! 8679: * ! 8680: * COMPOUND PATTERNS (CONTINUED) ! 8681: * ! 8682: * BINARY DOLLAR (IMMEDIATE ASSIGNMENT) ! 8683: * ------------------------------------ ! 8684: * ! 8685: * +---+ THIS NODE (P$IMA) STACKS THE CURSOR ! 8686: * I A I PMHBS AND A PTR TO NDIMB AND RESETS ! 8687: * +---+ THE STACK PTR PMHBS. ! 8688: * I ! 8689: * I ! 8690: * +---+ THIS IS THE LEFT STRUCTURE FOR THE ! 8691: * I X I PATTERN LEFT ARGUMENT OF THE ! 8692: * +---+ IMMEDIATE ASSIGNMENT CALL. ! 8693: * I ! 8694: * I ! 8695: * +---+ THIS NODE (P$IMC) PERFORMS THE ! 8696: * I C I----- ASSIGNMENT, POPS PMHBS AND STACKS ! 8697: * +---+ THE OLD PMHBS AND A PTR TO NDIMD. ! 8698: * ! 8699: * ! 8700: * THE STRUCTURE AND EXECUTION OF THIS PATTERN ARE SIMILAR ! 8701: * TO THOSE OF THE RECURSIVE EXPRESSION PATTERN MATCHING. ! 8702: * ! 8703: * THE MATCH ROUTINE FOR NDIMB (P$IMB) RESTORES THE OUTER ! 8704: * LEVEL VALUE OF PMHBS, UNSTACKS THE SAVED CURSOR AND FAILS ! 8705: * ! 8706: * THE MATCH ROUTINE P$IMC USES THE CURRENT VALUE OF PMHBS ! 8707: * TO LOCATE THE P$IMB ENTRY. THIS ENTRY IS USED TO MAKE ! 8708: * THE ASSIGNMENT AND RESTORE THE OUTER LEVEL VALUE OF ! 8709: * PMHBS. FINALLY, THE INNER LEVEL VALUE OF PMHBS AND A ! 8710: * POINTER TO THE SPECIAL NODE NDIMD ARE STACKED. ! 8711: * ! 8712: * THE MATCH ROUTINE FOR NDIMD (P$IMD) RESTORES THE INNER ! 8713: * LEVEL VALUE OF PMHBS AND FAILS BACK INTO THE STACK. ! 8714: * ! 8715: * AN OPTIMIZATION OCCURS IF THE INNER PATTERN MAKES NO ! 8716: * ENTRIES ON THE HISTORY STACK. IN THIS CASE, P$IMC POPS ! 8717: * THE P$IMB ENTRY INSTEAD OF MAKING A P$IMD ENTRY. ! 8718: EJC ! 8719: * ! 8720: * ARBNO ! 8721: * ! 8722: * SEE COMPOUND PATTERNS SECTION FOR STUCTURE AND ! 8723: * ALGORITHM FOR MATCHING THIS NODE TYPE. ! 8724: * ! 8725: * NO PARAMETERS ! 8726: * ! 8727: P$ABA ENT BL$P0 P0BLK ! 8728: MOV WB,-(XS) STACK CURSOR ! 8729: MOV XR,-(XS) STACK DUMMY NODE PTR ! 8730: MOV PMHBS,-(XS) STACK OLD STACK BASE PTR ! 8731: MOV =NDABB,-(XS) STACK PTR TO NODE NDABB ! 8732: MOV XS,PMHBS STORE NEW STACK BASE PTR ! 8733: BRN SUCCP SUCCEED ! 8734: EJC ! 8735: * ! 8736: * ARBNO (REMOVE P$ABA SPECIAL STACK ENTRY) ! 8737: * ! 8738: * NO PARAMETERS (DUMMY PATTERN) ! 8739: * ! 8740: P$ABB ENT ENTRY POINT ! 8741: MOV WB,PMHBS RESTORE HISTORY STACK BASE PTR ! 8742: BRN FLPOP FAIL AND POP DUMMY NODE PTR ! 8743: EJC ! 8744: * ! 8745: * ARBNO (CHECK IF ARG MATCHED NULL STRING) ! 8746: * ! 8747: * NO PARAMETERS (DUMMY PATTERN) ! 8748: * ! 8749: P$ABC ENT BL$P0 P0BLK ! 8750: MOV PMHBS,XT KEEP P$ABB STACK BASE ! 8751: MOV 3(XT),WA LOAD INITIAL CURSOR ! 8752: MOV 1(XT),PMHBS RESTORE OUTER STACK BASE PTR ! 8753: BEQ XT,XS,PABC1 JUMP IF NO HISTORY STACK ENTRIES ! 8754: MOV XT,-(XS) ELSE SAVE INNER PMHBS ENTRY ! 8755: MOV =NDABD,-(XS) STACK PTR TO SPECIAL NODE NDABD ! 8756: BRN PABC2 MERGE ! 8757: * ! 8758: * OPTIMISE CASE OF NO EXTRA ENTRIES ON STACK FROM ARBNO ARG ! 8759: * ! 8760: PABC1 ADD *NUM04,XS REMOVE NDABB ENTRY AND CURSOR ! 8761: * ! 8762: * MERGE TO CHECK FOR MATCHING OF NULL STRING ! 8763: * ! 8764: PABC2 BNE WA,WB,SUCCP ALLOW FURTHER ATTEMPT IF NON-NULL ! 8765: MOV PTHEN(XR),XR BYPASS ALTERNATIVE NODE SO AS TO .. ! 8766: BRN SUCCP ... REFUSE FURTHER MATCH ATTEMPTS ! 8767: EJC ! 8768: * ! 8769: * ARBNO (TRY FOR ALTERNATIVES IN ARBNO ARGUMENT) ! 8770: * ! 8771: * NO PARAMETERS (DUMMY PATTERN) ! 8772: * ! 8773: P$ABD ENT ENTRY POINT ! 8774: MOV WB,PMHBS RESTORE INNER STACK BASE PTR ! 8775: BRN FAILP AND FAIL ! 8776: EJC ! 8777: * ! 8778: * ABORT ! 8779: * ! 8780: * NO PARAMETERS ! 8781: * ! 8782: P$ABO ENT BL$P0 P0BLK ! 8783: BRN EXFAL SIGNAL STATEMENT FAILURE ! 8784: EJC ! 8785: * ! 8786: * ALTERNATION ! 8787: * ! 8788: * PARM1 ALTERNATIVE NODE ! 8789: * ! 8790: P$ALT ENT BL$P1 P1BLK ! 8791: MOV WB,-(XS) STACK CURSOR ! 8792: MOV PARM1(XR),-(XS) STACK POINTER TO ALTERNATIVE ! 8793: CHK CHECK FOR STACK OVERFLOW ! 8794: BRN SUCCP IF ALL OK, THEN SUCCEED ! 8795: EJC ! 8796: * ! 8797: * ANY (ONE CHARACTER ARGUMENT) (1-CHAR STRING ALSO) ! 8798: * ! 8799: * PARM1 CHARACTER ARGUMENT ! 8800: * ! 8801: P$ANS ENT BL$P1 P1BLK ! 8802: BEQ WB,PMSSL,FAILP FAIL IF NO CHARS LEFT ! 8803: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING ! 8804: PLC XL,WB POINT TO CURRENT CHARACTER ! 8805: LCH WA,(XL) LOAD CURRENT CHARACTER ! 8806: BNE WA,PARM1(XR),FAILP FAIL IF NO MATCH ! 8807: ICV WB ELSE BUMP CURSOR ! 8808: BRN SUCCP AND SUCCEED ! 8809: EJC ! 8810: * ! 8811: * ANY (MULTI-CHARACTER ARGUMENT CASE) ! 8812: * ! 8813: * PARM1 POINTER TO CTBLK ! 8814: * PARM2 BIT MASK TO SELECT BIT IN CTBLK ! 8815: * ! 8816: P$ANY ENT BL$P2 P2BLK ! 8817: * ! 8818: * EXPRESSION ARGUMENT CASE MERGES HERE ! 8819: * ! 8820: PANY1 BEQ WB,PMSSL,FAILP FAIL IF NO CHARACTERS LEFT ! 8821: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING ! 8822: PLC XL,WB GET CHAR PTR TO CURRENT CHARACTER ! 8823: LCH WA,(XL) LOAD CURRENT CHARACTER ! 8824: MOV PARM1(XR),XL POINT TO CTBLK ! 8825: WTB WA CHANGE TO BYTE OFFSET ! 8826: ADD WA,XL POINT TO ENTRY IN CTBLK ! 8827: MOV CTCHS(XL),WA LOAD WORD FROM CTBLK ! 8828: ANB PARM2(XR),WA AND WITH SELECTED BIT ! 8829: ZRB WA,FAILP FAIL IF NO MATCH ! 8830: ICV WB ELSE BUMP CURSOR ! 8831: BRN SUCCP AND SUCCEED ! 8832: EJC ! 8833: * ! 8834: * ANY (EXPRESSION ARGUMENT) ! 8835: * ! 8836: * PARM1 EXPRESSION POINTER ! 8837: * ! 8838: P$AYD ENT BL$P1 P1BLK ! 8839: JSR EVALS EVALUATE STRING ARGUMENT ! 8840: ERR 043,ANY EVALUATED ARGUMENT IS NOT STRING ! 8841: PPM FAILP FAIL IF EVALUATION FAILURE ! 8842: PPM PANY1 MERGE MULTI-CHAR CASE IF OK ! 8843: EJC ! 8844: * ! 8845: * P$ARB INITIAL ARB MATCH ! 8846: * ! 8847: * NO PARAMETERS ! 8848: * ! 8849: * THE P$ARB NODE IS PART OF A COMPOUND PATTERN STRUCTURE ! 8850: * FOR AN ARB PATTERN (SEE DESCRIPTION OF COMPOUND PATTERNS) ! 8851: * ! 8852: P$ARB ENT BL$P0 P0BLK ! 8853: MOV PTHEN(XR),XR LOAD SUCCESSOR POINTER ! 8854: MOV WB,-(XS) STACK DUMMY CURSOR ! 8855: MOV XR,-(XS) STACK SUCCESSOR POINTER ! 8856: MOV WB,-(XS) STACK CURSOR ! 8857: MOV =NDARC,-(XS) STACK PTR TO SPECIAL NODE NDARC ! 8858: BRI (XR) EXECUTE NEXT NODE MATCHING NULL ! 8859: EJC ! 8860: * ! 8861: * P$ARC EXTEND ARB MATCH ! 8862: * ! 8863: * NO PARAMETERS (DUMMY PATTERN) ! 8864: * ! 8865: P$ARC ENT ENTRY POINT ! 8866: BEQ WB,PMSSL,FLPOP FAIL AND POP STACK TO SUCCESSOR ! 8867: ICV WB ELSE BUMP CURSOR ! 8868: MOV WB,-(XS) STACK UPDATED CURSOR ! 8869: MOV XR,-(XS) RESTACK POINTER TO NDARC NODE ! 8870: MOV 2(XS),XR LOAD SUCCESSOR POINTER ! 8871: BRI (XR) OFF TO REEXECUTE SUCCESSOR NODE ! 8872: EJC ! 8873: * ! 8874: * BAL ! 8875: * ! 8876: * NO PARAMETERS ! 8877: * ! 8878: * THE P$BAL NODE IS PART OF THE COMPOUND STRUCTURE BUILT ! 8879: * FOR BAL (SEE SECTION ON COMPOUND PATTERNS). ! 8880: * ! 8881: P$BAL ENT BL$P0 P0BLK ! 8882: ZER WC ZERO PARENTHESES LEVEL COUNTER ! 8883: MOV R$PMS,XL POINT TO SUBJECT STRING ! 8884: PLC XL,WB POINT TO CURRENT CHARACTER ! 8885: BRN PBAL2 JUMP INTO SCAN LOOP ! 8886: * ! 8887: * LOOP TO SCAN OUT CHARACTERS ! 8888: * ! 8889: PBAL1 LCH WA,(XL)+ LOAD NEXT CHARACTER, BUMP POINTER ! 8890: ICV WB PUSH CURSOR FOR CHARACTER ! 8891: BEQ WA,=CH$PP,PBAL3 JUMP IF LEFT PAREN ! 8892: BEQ WA,=CH$RP,PBAL4 JUMP IF RIGHT PAREN ! 8893: BZE WC,PBAL5 ELSE SUCCEED IF AT OUTER LEVEL ! 8894: * ! 8895: * HERE AFTER PROCESSING ONE CHARACTER ! 8896: * ! 8897: PBAL2 BNE WB,PMSSL,PBAL1 LOOP BACK UNLESS END OF STRING ! 8898: BRN FAILP IN WHICH CASE, FAIL ! 8899: * ! 8900: * HERE ON LEFT PAREN ! 8901: * ! 8902: PBAL3 ICV WC BUMP PAREN LEVEL ! 8903: BRN PBAL2 LOOP BACK TO CHECK END OF STRING ! 8904: * ! 8905: * HERE FOR RIGHT PAREN ! 8906: * ! 8907: PBAL4 BZE WC,FAILP FAIL IF NO MATCHING LEFT PAREN ! 8908: DCV WC ELSE DECREMENT LEVEL COUNTER ! 8909: BNZ WC,PBAL2 LOOP BACK IF NOT AT OUTER LEVEL ! 8910: * ! 8911: * HERE AFTER SUCCESSFULLY SCANNING A BALANCED STRING ! 8912: * ! 8913: PBAL5 MOV WB,-(XS) STACK CURSOR ! 8914: MOV XR,-(XS) STACK PTR TO BAL NODE FOR EXTEND ! 8915: BRN SUCCP AND SUCCEED ! 8916: EJC ! 8917: * ! 8918: * BREAK (EXPRESSION ARGUMENT) ! 8919: * ! 8920: * PARM1 EXPRESSION POINTER ! 8921: * ! 8922: P$BKD ENT BL$P1 P1BLK ! 8923: JSR EVALS EVALUATE STRING EXPRESSION ! 8924: ERR 044,BREAK EVALUATED ARGUMENT IS NOT STRING ! 8925: PPM FAILP FAIL IF EVALUATION FAILS ! 8926: PPM PBRK1 MERGE WITH MULTI-CHAR CASE IF OK ! 8927: EJC ! 8928: * ! 8929: * BREAK (ONE CHARACTER ARGUMENT) ! 8930: * ! 8931: * PARM1 CHARACTER ARGUMENT ! 8932: * ! 8933: P$BKS ENT BL$P1 P1BLK ! 8934: MOV PMSSL,WC GET SUBJECT STRING LENGTH ! 8935: SUB WB,WC GET NUMBER OF CHARACTERS LEFT ! 8936: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT ! 8937: LCT WC,WC SET COUNTER FOR CHARS LEFT ! 8938: MOV R$PMS,XL POINT TO SUBJECT STRING ! 8939: PLC XL,WB POINT TO CURRENT CHARACTER ! 8940: * ! 8941: * LOOP TO SCAN TILL BREAK CHARACTER FOUND ! 8942: * ! 8943: PBKS1 LCH WA,(XL)+ LOAD NEXT CHAR, BUMP POINTER ! 8944: BEQ WA,PARM1(XR),SUCCP SUCCEED IF BREAK CHARACTER FOUND ! 8945: ICV WB ELSE PUSH CURSOR ! 8946: BCT WC,PBKS1 LOOP BACK IF MORE TO GO ! 8947: BRN FAILP FAIL IF END OF STRING, NO BREAK CHR ! 8948: EJC ! 8949: * ! 8950: * BREAK (MULTI-CHARACTER ARGUMENT) ! 8951: * ! 8952: * PARM1 POINTER TO CTBLK ! 8953: * PARM2 BIT MASK TO SELECT BIT COLUMN ! 8954: * ! 8955: P$BRK ENT BL$P2 P2BLK ! 8956: * ! 8957: * EXPRESSION ARGUMENT MERGES HERE ! 8958: * ! 8959: PBRK1 MOV PMSSL,WC LOAD SUBJECT STRING LENGTH ! 8960: SUB WB,WC GET NUMBER OF CHARACTERS LEFT ! 8961: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT ! 8962: LCT WC,WC SET COUNTER FOR CHARACTERS LEFT ! 8963: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING ! 8964: PLC XL,WB POINT TO CURRENT CHARACTER ! 8965: MOV XR,PSAVE SAVE NODE POINTER ! 8966: * ! 8967: * LOOP TO SEARCH FOR BREAK CHARACTER ! 8968: * ! 8969: PBRK2 LCH WA,(XL)+ LOAD NEXT CHAR, BUMP POINTER ! 8970: MOV PARM1(XR),XR LOAD POINTER TO CTBLK ! 8971: WTB WA CONVERT TO BYTE OFFSET ! 8972: ADD WA,XR POINT TO CTBLK ENTRY ! 8973: MOV CTCHS(XR),WA LOAD CTBLK WORD ! 8974: MOV PSAVE,XR RESTORE NODE POINTER ! 8975: ANB PARM2(XR),WA AND WITH SELECTED BIT ! 8976: NZB WA,SUCCP SUCCEED IF BREAK CHARACTER FOUND ! 8977: ICV WB ELSE PUSH CURSOR ! 8978: BCT WC,PBRK2 LOOP BACK UNLESS END OF STRING ! 8979: BRN FAILP FAIL IF END OF STRING, NO BREAK CHR ! 8980: EJC ! 8981: * ! 8982: * BREAKX (EXTENSION) ! 8983: * ! 8984: * THIS IS THE ENTRY WHICH CAUSES AN EXTENSION OF A BREAKX ! 8985: * MATCH WHEN FAILURE OCCURS. SEE SECTION ON COMPOUND ! 8986: * PATTERNS FOR FULL DETAILS OF BREAKX MATCHING. ! 8987: * ! 8988: * NO PARAMETERS ! 8989: * ! 8990: P$BKX ENT BL$P0 P0BLK ! 8991: ICV WB STEP CURSOR PAST PREVIOUS BREAK CHR ! 8992: BRN SUCCP SUCCEED TO REMATCH BREAK ! 8993: EJC ! 8994: * ! 8995: * BREAKX (EXPRESSION ARGUMENT) ! 8996: * ! 8997: * SEE SECTION ON COMPOUND PATTERNS FOR FULL STRUCTURE OF ! 8998: * BREAKX PATTERN. THE ACTUAL CHARACTER MATCHING USES A ! 8999: * BREAK NODE. HOWEVER, THE ENTRY FOR THE EXPRESSION ! 9000: * ARGUMENT CASE IS SEPARATED TO GET PROPER ERROR MESSAGES. ! 9001: * ! 9002: * PARM1 EXPRESSION POINTER ! 9003: * ! 9004: P$BXD ENT BL$P1 P1BLK ! 9005: JSR EVALS EVALUATE STRING ARGUMENT ! 9006: ERR 045,BREAKX EVALUATED ARGUMENT IS NOT STRING ! 9007: PPM FAILP FAIL IF EVALUATION FAILS ! 9008: PPM PBRK1 MERGE WITH BREAK IF ALL OK ! 9009: EJC ! 9010: * ! 9011: * CURSOR ASSIGNMENT ! 9012: * ! 9013: * PARM1 NAME BASE ! 9014: * PARM2 NAME OFFSET ! 9015: * ! 9016: P$CAS ENT BL$P2 P2BLK ! 9017: MOV XR,-(XS) SAVE NODE POINTER ! 9018: MOV WB,-(XS) SAVE CURSOR ! 9019: MOV PARM1(XR),XL LOAD NAME BASE ! 9020: MTI WB LOAD CURSOR AS INTEGER ! 9021: MOV PARM2(XR),WB LOAD NAME OFFSET ! 9022: JSR ICBLD GET ICBLK FOR CURSOR VALUE ! 9023: MOV WB,WA MOVE NAME OFFSET ! 9024: MOV XR,WB MOVE VALUE TO ASSIGN ! 9025: JSR ASINP PERFORM ASSIGNMENT ! 9026: PPM FLPOP FAIL ON ASSIGNMENT FAILURE ! 9027: MOV (XS)+,WB ELSE RESTORE CURSOR ! 9028: MOV (XS)+,XR RESTORE NODE POINTER ! 9029: BRN SUCCP AND SUCCEED MATCHING NULL ! 9030: EJC ! 9031: * ! 9032: * EXPRESSION NODE (P$EXA, INITIAL ENTRY) ! 9033: * ! 9034: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9035: * ALGORITHMS FOR HANDLING EXPRESSION NODES. ! 9036: * ! 9037: * PARM1 EXPRESSION POINTER ! 9038: * ! 9039: P$EXA ENT BL$P1 P1BLK ! 9040: JSR EVALP EVALUATE EXPRESSION ! 9041: PPM FAILP FAIL IF EVALUATION FAILS ! 9042: BLO WA,=P$AAA,PEXA1 JUMP IF RESULT IS NOT A PATTERN ! 9043: * ! 9044: * HERE IF RESULT OF EXPRESSION IS A PATTERN ! 9045: * ! 9046: MOV WB,-(XS) STACK DUMMY CURSOR ! 9047: MOV XR,-(XS) STACK PTR TO P$EXA NODE ! 9048: MOV PMHBS,-(XS) STACK HISTORY STACK BASE PTR ! 9049: MOV =NDEXB,-(XS) STACK PTR TO SPECIAL NODE NDEXB ! 9050: MOV XS,PMHBS STORE NEW STACK BASE POINTER ! 9051: MOV XL,XR COPY NODE POINTER ! 9052: BRI (XR) MATCH FIRST NODE IN EXPRESSION PAT ! 9053: * ! 9054: * HERE IF RESULT OF EXPRESSION IS NOT A PATTERN ! 9055: * ! 9056: PEXA1 BEQ WA,=B$SCL,PEXA2 JUMP IF IT IS ALREADY A STRING ! 9057: MOV XL,-(XS) ELSE STACK RESULT ! 9058: MOV XR,XL SAVE NODE POINTER ! 9059: JSR GTSTG CONVERT RESULT TO STRING ! 9060: ERR 046,EXPRESSION DOES NOT EVALUATE TO PATTERN ! 9061: MOV XR,WC COPY STRING POINTER ! 9062: MOV XL,XR RESTORE NODE POINTER ! 9063: MOV WC,XL COPY STRING POINTER AGAIN ! 9064: * ! 9065: * MERGE HERE WITH STRING POINTER IN XL ! 9066: * ! 9067: PEXA2 BZE SCLEN(XL),SUCCP JUST SUCCEED IF NULL STRING ! 9068: BRN PSTR1 ELSE MERGE WITH STRING CIRCUIT ! 9069: EJC ! 9070: * ! 9071: * EXPRESSION NODE (P$EXB, REMOVE NDEXB ENTRY) ! 9072: * ! 9073: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9074: * ALGORITHMS FOR HANDLING EXPRESSION NODES. ! 9075: * ! 9076: * NO PARAMETERS (DUMMY PATTERN) ! 9077: * ! 9078: P$EXB ENT ENTRY POINT ! 9079: MOV WB,PMHBS RESTORE OUTER LEVEL STACK POINTER ! 9080: BRN FLPOP FAIL AND POP P$EXA NODE PTR ! 9081: EJC ! 9082: * ! 9083: * EXPRESSION NODE (P$EXC, REMOVE NDEXC ENTRY) ! 9084: * ! 9085: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9086: * ALGORITHMS FOR HANDLING EXPRESSION NODES. ! 9087: * ! 9088: * NO PARAMETERS (DUMMY PATTERN) ! 9089: * ! 9090: P$EXC ENT ENTRY POINT ! 9091: MOV WB,PMHBS RESTORE INNER STACK BASE POINTER ! 9092: BRN FAILP AND FAIL INTO EXPR PATTERN ALTERNVS ! 9093: EJC ! 9094: * ! 9095: * FAIL ! 9096: * ! 9097: * NO PARAMETERS ! 9098: * ! 9099: P$FAL ENT BL$P0 P0BLK ! 9100: BRN FAILP JUST SIGNAL FAILURE ! 9101: EJC ! 9102: * ! 9103: * FENCE ! 9104: * ! 9105: * SEE COMPOUND PATTERNS SECTION FOR THE STRUCTURE AND ! 9106: * ALGORITHM FOR MATCHING THIS NODE TYPE. ! 9107: * ! 9108: * NO PARAMETERS ! 9109: * ! 9110: P$FEN ENT BL$P0 P0BLK ! 9111: MOV WB,-(XS) STACK DUMMY CURSOR ! 9112: MOV =NDABO,-(XS) STACK PTR TO ABORT NODE ! 9113: BRN SUCCP AND SUCCEED MATCHING NULL ! 9114: EJC ! 9115: * ! 9116: * FENCE (FUNCTION) ! 9117: * ! 9118: * SEE COMPOUND PATTERNS COMMENTS AT START OF THIS SECTION ! 9119: * FOR DETAILS OF SCHEME ! 9120: * ! 9121: * NO PARAMETERS ! 9122: * ! 9123: P$FNA ENT BL$P0 P0BLK ! 9124: MOV PMHBS,-(XS) STACK CURRENT HISTORY STACK BASE ! 9125: MOV =NDFNB,-(XS) STACK INDIR PTR TO P$FNB (FAILURE) ! 9126: MOV XS,PMHBS BEGIN NEW HISTORY STACK ! 9127: BRN SUCCP SUCCEED ! 9128: EJC ! 9129: * ! 9130: * FENCE (FUNCTION) (RESET HISTORY STACK AND FAIL) ! 9131: * ! 9132: * NO PARAMETERS (DUMMY PATTERN) ! 9133: * ! 9134: P$FNB ENT BL$P0 P0BLK ! 9135: MOV WB,PMHBS RESTORE OUTER PMHBS STACK BASE ! 9136: BRN FAILP ...AND FAIL ! 9137: EJC ! 9138: * ! 9139: * FENCE (FUNCTION) (MAKE FENCE TRAP ENTRY ON STACK) ! 9140: * ! 9141: * NO PARAMETERS (DUMMY PATTERN) ! 9142: * ! 9143: P$FNC ENT BL$P0 P0BLK ! 9144: MOV PMHBS,XT GET INNER STACK BASE PTR ! 9145: MOV NUM01(XT),PMHBS RESTORE OUTER STACK BASE ! 9146: BEQ XT,XS,PFNC1 OPTIMIZE IF NO ALTERNATIVES ! 9147: MOV XT,-(XS) ELSE STACK INNER STACK BASE ! 9148: MOV =NDFND,-(XS) STACK PTR TO NDFND ! 9149: BRN SUCCP SUCCEED ! 9150: * ! 9151: * HERE WHEN FENCE FUNCTION LEFT NOTHING ON THE STACK ! 9152: * ! 9153: PFNC1 ADD *NUM02,XS POP OFF P$FNB ENTRY ! 9154: BRN SUCCP SUCCEED ! 9155: EJC ! 9156: * ! 9157: * FENCE (FUNCTION) (SKIP PAST ALTERNATIVES ON FAILURE) ! 9158: * ! 9159: * NO PARAMETERS (DUMMY PATTERN) ! 9160: * ! 9161: P$FND ENT BL$P0 P0BLK ! 9162: MOV WB,XS POP STACK TO FENCE() HISTORY BASE ! 9163: BRN FLPOP POP BASE ENTRY AND FAIL ! 9164: EJC ! 9165: * ! 9166: * IMMEDIATE ASSIGNMENT (INITIAL ENTRY, SAVE CURRENT CURSOR) ! 9167: * ! 9168: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE ! 9169: * STRUCTURE AND ALGORITHM FOR MATCHING THIS NODE TYPE. ! 9170: * ! 9171: * NO PARAMETERS ! 9172: * ! 9173: P$IMA ENT BL$P0 P0BLK ! 9174: MOV WB,-(XS) STACK CURSOR ! 9175: MOV XR,-(XS) STACK DUMMY NODE POINTER ! 9176: MOV PMHBS,-(XS) STACK OLD STACK BASE POINTER ! 9177: MOV =NDIMB,-(XS) STACK PTR TO SPECIAL NODE NDIMB ! 9178: MOV XS,PMHBS STORE NEW STACK BASE POINTER ! 9179: BRN SUCCP AND SUCCEED ! 9180: EJC ! 9181: * ! 9182: * IMMEDIATE ASSIGNMENT (REMOVE CURSOR MARK ENTRY) ! 9183: * ! 9184: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE ! 9185: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9186: * ! 9187: * NO PARAMETERS (DUMMY PATTERN) ! 9188: * ! 9189: P$IMB ENT ENTRY POINT ! 9190: MOV WB,PMHBS RESTORE HISTORY STACK BASE PTR ! 9191: BRN FLPOP FAIL AND POP DUMMY NODE PTR ! 9192: EJC ! 9193: * ! 9194: * IMMEDIATE ASSIGNMENT (PERFORM ACTUAL ASSIGNMENT) ! 9195: * ! 9196: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE ! 9197: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9198: * ! 9199: * PARM1 NAME BASE OF VARIABLE ! 9200: * PARM2 NAME OFFSET OF VARIABLE ! 9201: * ! 9202: P$IMC ENT BL$P2 P2BLK ! 9203: MOV PMHBS,XT LOAD POINTER TO P$IMB ENTRY ! 9204: MOV WB,WA COPY FINAL CURSOR ! 9205: MOV 3(XT),WB LOAD INITIAL CURSOR ! 9206: MOV 1(XT),PMHBS RESTORE OUTER STACK BASE POINTER ! 9207: BEQ XT,XS,PIMC1 JUMP IF NO HISTORY STACK ENTRIES ! 9208: MOV XT,-(XS) ELSE SAVE INNER PMHBS POINTER ! 9209: MOV =NDIMD,-(XS) AND A PTR TO SPECIAL NODE NDIMD ! 9210: BRN PIMC2 MERGE ! 9211: * ! 9212: * HERE IF NO ENTRIES MADE ON HISTORY STACK ! 9213: * ! 9214: PIMC1 ADD *NUM04,XS REMOVE NDIMB ENTRY AND CURSOR ! 9215: * ! 9216: * MERGE HERE TO PERFORM ASSIGNMENT ! 9217: * ! 9218: PIMC2 MOV WA,-(XS) SAVE CURRENT (FINAL) CURSOR ! 9219: MOV XR,-(XS) SAVE CURRENT NODE POINTER ! 9220: MOV R$PMS,XL POINT TO SUBJECT STRING ! 9221: SUB WB,WA COMPUTE SUBSTRING LENGTH ! 9222: JSR SBSTR BUILD SUBSTRING ! 9223: MOV XR,WB MOVE RESULT ! 9224: MOV (XS),XR RELOAD NODE POINTER ! 9225: MOV PARM1(XR),XL LOAD NAME BASE ! 9226: MOV PARM2(XR),WA LOAD NAME OFFSET ! 9227: JSR ASINP PERFORM ASSIGNMENT ! 9228: PPM FLPOP FAIL IF ASSIGNMENT FAILS ! 9229: MOV (XS)+,XR ELSE RESTORE NODE POINTER ! 9230: MOV (XS)+,WB RESTORE CURSOR ! 9231: BRN SUCCP AND SUCCEED ! 9232: EJC ! 9233: * ! 9234: * IMMEDIATE ASSIGNMENT (REMOVE NDIMD ENTRY ON FAILURE) ! 9235: * ! 9236: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE ! 9237: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9238: * ! 9239: * NO PARAMETERS (DUMMY PATTERN) ! 9240: * ! 9241: P$IMD ENT ENTRY POINT ! 9242: MOV WB,PMHBS RESTORE INNER STACK BASE POINTER ! 9243: BRN FAILP AND FAIL ! 9244: EJC ! 9245: * ! 9246: * LEN (INTEGER ARGUMENT) ! 9247: * ! 9248: * PARM1 INTEGER ARGUMENT ! 9249: * ! 9250: P$LEN ENT BL$P1 P1BLK ! 9251: * ! 9252: * EXPRESSION ARGUMENT CASE MERGES HERE ! 9253: * ! 9254: PLEN1 ADD PARM1(XR),WB PUSH CURSOR INDICATED AMOUNT ! 9255: BLE WB,PMSSL,SUCCP SUCCEED IF NOT OFF END ! 9256: BRN FAILP ELSE FAIL ! 9257: EJC ! 9258: * ! 9259: * LEN (EXPRESSION ARGUMENT) ! 9260: * ! 9261: * PARM1 EXPRESSION POINTER ! 9262: * ! 9263: P$LND ENT BL$P1 P1BLK ! 9264: JSR EVALI EVALUATE INTEGER ARGUMENT ! 9265: ERR 047,LEN EVALUATED ARGUMENT IS NOT INTEGER ! 9266: ERR 048,LEN EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE ! 9267: PPM FAILP FAIL IF EVALUATION FAILS ! 9268: PPM PLEN1 MERGE WITH NORMAL CIRCUIT IF OK ! 9269: EJC ! 9270: * ! 9271: * NOTANY (EXPRESSION ARGUMENT) ! 9272: * ! 9273: * PARM1 EXPRESSION POINTER ! 9274: * ! 9275: P$NAD ENT BL$P1 P1BLK ! 9276: JSR EVALS EVALUATE STRING ARGUMENT ! 9277: ERR 049,NOTANY EVALUATED ARGUMENT IS NOT STRING ! 9278: PPM FAILP FAIL IF EVALUATION FAILS ! 9279: PPM PNAY1 MERGE WITH MULTI-CHAR CASE IF OK ! 9280: EJC ! 9281: * ! 9282: * NOTANY (ONE CHARACTER ARGUMENT) ! 9283: * ! 9284: * PARM1 CHARACTER ARGUMENT ! 9285: * ! 9286: P$NAS ENT BL$P1 ENTRY POINT ! 9287: BEQ WB,PMSSL,FAILP FAIL IF NO CHARS LEFT ! 9288: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING ! 9289: PLC XL,WB POINT TO CURRENT CHARACTER IN STRIN ! 9290: LCH WA,(XL) LOAD CURRENT CHARACTER ! 9291: BEQ WA,PARM1(XR),FAILP FAIL IF MATCH ! 9292: ICV WB ELSE BUMP CURSOR ! 9293: BRN SUCCP AND SUCCEED ! 9294: EJC ! 9295: * ! 9296: * NOTANY (MULTI-CHARACTER STRING ARGUMENT) ! 9297: * ! 9298: * PARM1 POINTER TO CTBLK ! 9299: * PARM2 BIT MASK TO SELECT BIT COLUMN ! 9300: * ! 9301: P$NAY ENT BL$P2 P2BLK ! 9302: * ! 9303: * EXPRESSION ARGUMENT CASE MERGES HERE ! 9304: * ! 9305: PNAY1 BEQ WB,PMSSL,FAILP FAIL IF NO CHARACTERS LEFT ! 9306: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING ! 9307: PLC XL,WB POINT TO CURRENT CHARACTER ! 9308: LCH WA,(XL) LOAD CURRENT CHARACTER ! 9309: WTB WA CONVERT TO BYTE OFFSET ! 9310: MOV PARM1(XR),XL LOAD POINTER TO CTBLK ! 9311: ADD WA,XL POINT TO ENTRY IN CTBLK ! 9312: MOV CTCHS(XL),WA LOAD ENTRY FROM CTBLK ! 9313: ANB PARM2(XR),WA AND WITH SELECTED BIT ! 9314: NZB WA,FAILP FAIL IF CHARACTER IS MATCHED ! 9315: ICV WB ELSE BUMP CURSOR ! 9316: BRN SUCCP AND SUCCEED ! 9317: EJC ! 9318: * ! 9319: * END OF PATTERN MATCH ! 9320: * ! 9321: * THIS ROUTINE IS ENTERED ON SUCCESSFUL COMPLETION. ! 9322: * SEE DESCRIPTION OF EXPRESSION PATTERNS IN COMPOUND ! 9323: * PATTERN SECTION FOR HANDLING OF RECURSION IN MATCHING. ! 9324: * ! 9325: * NO PARAMETERS (DUMMY PATTERN) ! 9326: * ! 9327: P$NTH ENT ENTRY POINT ! 9328: MOV PMHBS,XT LOAD POINTER TO BASE OF STACK ! 9329: MOV 1(XT),WA LOAD SAVED PMHBS (OR PATTERN TYPE) ! 9330: BLE WA,=NUM02,PNTH2 JUMP IF OUTER LEVEL (PATTERN TYPE) ! 9331: * ! 9332: * HERE WE ARE AT THE END OF MATCHING AN EXPRESSION PATTERN ! 9333: * ! 9334: MOV WA,PMHBS RESTORE OUTER STACK BASE POINTER ! 9335: MOV 2(XT),XR RESTORE POINTER TO P$EXA NODE ! 9336: BEQ XT,XS,PNTH1 JUMP IF NO HISTORY STACK ENTRIES ! 9337: MOV XT,-(XS) ELSE STACK INNER STACK BASE PTR ! 9338: MOV =NDEXC,-(XS) STACK PTR TO SPECIAL NODE NDEXC ! 9339: BRN SUCCP AND SUCCEED ! 9340: * ! 9341: * HERE IF NO HISTORY STACK ENTRIES DURING PATTERN ! 9342: * ! 9343: PNTH1 ADD *NUM04,XS REMOVE P$EXB ENTRY AND NODE PTR ! 9344: BRN SUCCP AND SUCCEED ! 9345: * ! 9346: * HERE IF END OF MATCH AT OUTER LEVEL ! 9347: * ! 9348: PNTH2 MOV WB,PMSSL SAVE FINAL CURSOR IN SAFE PLACE ! 9349: BZE PMDFL,PNTH6 JUMP IF NO PATTERN ASSIGNMENTS ! 9350: EJC ! 9351: * ! 9352: * END OF PATTERN MATCH (CONTINUED) ! 9353: * ! 9354: * NOW WE MUST PERFORM PATTERN ASSIGNMENTS. THIS IS DONE BY ! 9355: * SCANNING THE HISTORY STACK FOR MATCHING NDPAB-NDPAD PAIRS ! 9356: * ! 9357: PNTH3 DCA XT POINT PAST CURSOR ENTRY ! 9358: MOV -(XT),WA LOAD NODE POINTER ! 9359: BEQ WA,=NDPAD,PNTH4 JUMP IF NDPAD ENTRY ! 9360: BNE WA,=NDPAB,PNTH5 JUMP IF NOT NDPAB ENTRY ! 9361: * ! 9362: * HERE FOR NDPAB ENTRY, STACK INITIAL CURSOR ! 9363: * NOTE THAT THERE MUST BE MORE ENTRIES ON THE STACK. ! 9364: * ! 9365: MOV 1(XT),-(XS) STACK INITIAL CURSOR ! 9366: CHK CHECK FOR STACK OVERFLOW ! 9367: BRN PNTH3 LOOP BACK IF OK ! 9368: * ! 9369: * HERE FOR NDPAD ENTRY. THE STARTING CURSOR FROM THE ! 9370: * MATCHING NDPAD ENTRY IS NOW THE TOP STACK ENTRY. ! 9371: * ! 9372: PNTH4 MOV 1(XT),WA LOAD FINAL CURSOR ! 9373: MOV (XS),WB LOAD INITIAL CURSOR FROM STACK ! 9374: MOV XT,(XS) SAVE HISTORY STACK SCAN PTR ! 9375: SUB WB,WA COMPUTE LENGTH OF STRING ! 9376: * ! 9377: * BUILD SUBSTRING AND PERFORM ASSIGNMENT ! 9378: * ! 9379: MOV R$PMS,XL POINT TO SUBJECT STRING ! 9380: JSR SBSTR CONSTRUCT SUBSTRING ! 9381: MOV XR,WB COPY SUBSTRING POINTER ! 9382: MOV (XS),XT RELOAD HISTORY STACK SCAN PTR ! 9383: MOV 2(XT),XL LOAD POINTER TO P$PAC NODE WITH NAM ! 9384: MOV PARM2(XL),WA LOAD NAME OFFSET ! 9385: MOV PARM1(XL),XL LOAD NAME BASE ! 9386: JSR ASINP PERFORM ASSIGNMENT ! 9387: PPM EXFAL MATCH FAILS IF NAME EVAL FAILS ! 9388: MOV (XS)+,XT ELSE RESTORE HISTORY STACK PTR ! 9389: EJC ! 9390: * ! 9391: * END OF PATTERN MATCH (CONTINUED) ! 9392: * ! 9393: * HERE CHECK FOR END OF ENTRIES ! 9394: * ! 9395: PNTH5 BNE XT,XS,PNTH3 LOOP IF MORE ENTRIES TO SCAN ! 9396: * ! 9397: * HERE AFTER DEALING WITH PATTERN ASSIGNMENTS ! 9398: * ! 9399: PNTH6 MOV PMHBS,XS WIPE OUT HISTORY STACK ! 9400: MOV (XS)+,WB LOAD INITIAL CURSOR ! 9401: MOV (XS)+,WC LOAD MATCH TYPE CODE ! 9402: MOV PMSSL,WA LOAD FINAL CURSOR VALUE ! 9403: MOV R$PMS,XL POINT TO SUBJECT STRING ! 9404: ZER R$PMS CLEAR SUBJECT STRING PTR FOR GBCOL ! 9405: BZE WC,PNTH7 JUMP IF CALL BY NAME ! 9406: BEQ WC,=NUM02,EXITS EXIT IF STATEMENT LEVEL CALL ! 9407: * ! 9408: * HERE WE HAVE A CALL BY VALUE, BUILD SUBSTRING ! 9409: * ! 9410: SUB WB,WA COMPUTE LENGTH OF STRING ! 9411: JSR SBSTR BUILD SUBSTRING ! 9412: BRN EXIXR AND EXIT WITH SUBSTRING VALUE ! 9413: * ! 9414: * HERE FOR CALL BY NAME, MAKE STACK ENTRIES FOR O$RPL ! 9415: * ! 9416: PNTH7 MOV WB,-(XS) STACK INITIAL CURSOR ! 9417: MOV WA,-(XS) STACK FINAL CURSOR ! 9418: .IF .CNBF ! 9419: .ELSE ! 9420: BZE R$PMB,PNTH8 SKIP IF SUBJECT NOT BUFFER ! 9421: MOV R$PMB,XL ELSE GET PTR TO BCBLK INSTEAD ! 9422: .FI ! 9423: * ! 9424: * HERE WITH XL POINTING TO SCBLK OR BCBLK ! 9425: * ! 9426: PNTH8 MOV XL,-(XS) STACK SUBJECT POINTER ! 9427: BRN EXITS EXIT WITH SPECIAL ENTRY ON STACK ! 9428: EJC ! 9429: * ! 9430: * POS (INTEGER ARGUMENT) ! 9431: * ! 9432: * PARM1 INTEGER ARGUMENT ! 9433: * ! 9434: P$POS ENT BL$P1 P1BLK ! 9435: * ! 9436: * EXPRESSION ARGUMENT CASE MERGES HERE ! 9437: * ! 9438: PPOS1 BEQ WB,PARM1(XR),SUCCP SUCCEED IF AT RIGHT LOCATION ! 9439: BRN FAILP ELSE FAIL ! 9440: EJC ! 9441: * ! 9442: * POS (EXPRESSION ARGUMENT) ! 9443: * ! 9444: * PARM1 EXPRESSION POINTER ! 9445: * ! 9446: P$PSD ENT BL$P1 P1BLK ! 9447: JSR EVALI EVALUATE INTEGER ARGUMENT ! 9448: ERR 050,POS EVALUATED ARGUMENT IS NOT INTEGER ! 9449: ERR 051,POS EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE ! 9450: PPM FAILP FAIL IF EVALUATION FAILS ! 9451: PPM PPOS1 MERGE WITH NORMAL CASE IF OK ! 9452: EJC ! 9453: * ! 9454: * PATTERN ASSIGNMENT (INITIAL ENTRY, SAVE CURSOR) ! 9455: * ! 9456: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9457: * ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9458: * ! 9459: * NO PARAMETERS ! 9460: * ! 9461: P$PAA ENT BL$P0 P0BLK ! 9462: MOV WB,-(XS) STACK INITIAL CURSOR ! 9463: MOV =NDPAB,-(XS) STACK PTR TO NDPAB SPECIAL NODE ! 9464: BRN SUCCP AND SUCCEED MATCHING NULL ! 9465: EJC ! 9466: * ! 9467: * PATTERN ASSIGNMENT (REMOVE SAVED CURSOR) ! 9468: * ! 9469: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9470: * ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9471: * ! 9472: * NO PARAMETERS (DUMMY PATTERN) ! 9473: * ! 9474: P$PAB ENT ENTRY POINT ! 9475: BRN FAILP JUST FAIL (ENTRY IS ALREADY POPPED) ! 9476: EJC ! 9477: * ! 9478: * PATTERN ASSIGNMENT (END OF MATCH, MAKE ASSIGN ENTRY) ! 9479: * ! 9480: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9481: * ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9482: * ! 9483: * PARM1 NAME BASE OF VARIABLE ! 9484: * PARM2 NAME OFFSET OF VARIABLE ! 9485: * ! 9486: P$PAC ENT BL$P2 P2BLK ! 9487: MOV WB,-(XS) STACK DUMMY CURSOR VALUE ! 9488: MOV XR,-(XS) STACK POINTER TO P$PAC NODE ! 9489: MOV WB,-(XS) STACK FINAL CURSOR ! 9490: MOV =NDPAD,-(XS) STACK PTR TO SPECIAL NDPAD NODE ! 9491: MNZ PMDFL SET DOT FLAG NON-ZERO ! 9492: BRN SUCCP AND SUCCEED ! 9493: EJC ! 9494: * ! 9495: * PATTERN ASSIGNMENT (REMOVE ASSIGN ENTRY) ! 9496: * ! 9497: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9498: * ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9499: * ! 9500: * NO PARAMETERS (DUMMY NODE) ! 9501: * ! 9502: P$PAD ENT ENTRY POINT ! 9503: BRN FLPOP FAIL AND REMOVE P$PAC NODE ! 9504: EJC ! 9505: * ! 9506: * REM ! 9507: * ! 9508: * NO PARAMETERS ! 9509: * ! 9510: P$REM ENT BL$P0 P0BLK ! 9511: MOV PMSSL,WB POINT CURSOR TO END OF STRING ! 9512: BRN SUCCP AND SUCCEED ! 9513: EJC ! 9514: * ! 9515: * RPOS (EXPRESSION ARGUMENT) ! 9516: * ! 9517: * PARM1 EXPRESSION POINTER ! 9518: * ! 9519: P$RPD ENT BL$P1 P1BLK ! 9520: JSR EVALI EVALUATE INTEGER ARGUMENT ! 9521: ERR 052,RPOS EVALUATED ARGUMENT IS NOT INTEGER ! 9522: ERR 053,RPOS EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE ! 9523: PPM FAILP FAIL IF EVALUATION FAILS ! 9524: PPM PRPS1 MERGE WITH NORMAL CASE IF OK ! 9525: EJC ! 9526: * ! 9527: * RPOS (INTEGER ARGUMENT) ! 9528: * ! 9529: * PARM1 INTEGER ARGUMENT ! 9530: * ! 9531: P$RPS ENT BL$P1 P1BLK ! 9532: * ! 9533: * EXPRESSION ARGUMENT CASE MERGES HERE ! 9534: * ! 9535: PRPS1 MOV PMSSL,WC GET LENGTH OF STRING ! 9536: SUB WB,WC GET NUMBER OF CHARACTERS REMAINING ! 9537: BEQ WC,PARM1(XR),SUCCP SUCCEED IF AT RIGHT LOCATION ! 9538: BRN FAILP ELSE FAIL ! 9539: EJC ! 9540: * ! 9541: * RTAB (INTEGER ARGUMENT) ! 9542: * ! 9543: * PARM1 INTEGER ARGUMENT ! 9544: * ! 9545: P$RTB ENT BL$P1 P1BLK ! 9546: * ! 9547: * EXPRESSION ARGUMENT CASE MERGES HERE ! 9548: * ! 9549: PRTB1 MOV WB,WC SAVE INITIAL CURSOR ! 9550: MOV PMSSL,WB POINT TO END OF STRING ! 9551: BLT WB,PARM1(XR),FAILP FAIL IF STRING NOT LONG ENOUGH ! 9552: SUB PARM1(XR),WB ELSE SET NEW CURSOR ! 9553: BGE WB,WC,SUCCP AND SUCCEED IF NOT TOO FAR ALREADY ! 9554: BRN FAILP IN WHICH CASE, FAIL ! 9555: EJC ! 9556: * ! 9557: * RTAB (EXPRESSION ARGUMENT) ! 9558: * ! 9559: * PARM1 EXPRESSION POINTER ! 9560: * ! 9561: P$RTD ENT BL$P1 P1BLK ! 9562: JSR EVALI EVALUATE INTEGER ARGUMENT ! 9563: ERR 054,RTAB EVALUATED ARGUMENT IS NOT INTEGER ! 9564: ERR 055,RTAB EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE ! 9565: PPM FAILP FAIL IF EVALUATION FAILS ! 9566: PPM PRTB1 MERGE WITH NORMAL CASE IF SUCCESS ! 9567: EJC ! 9568: * ! 9569: * SPAN (EXPRESSION ARGUMENT) ! 9570: * ! 9571: * PARM1 EXPRESSION POINTER ! 9572: * ! 9573: P$SPD ENT BL$P1 P1BLK ! 9574: JSR EVALS EVALUATE STRING ARGUMENT ! 9575: ERR 056,SPAN EVALUATED ARGUMENT IS NOT STRING ! 9576: PPM FAILP FAIL IF EVALUATION FAILS ! 9577: PPM PSPN1 MERGE WITH MULTI-CHAR CASE IF OK ! 9578: EJC ! 9579: * ! 9580: * SPAN (MULTI-CHARACTER ARGUMENT CASE) ! 9581: * ! 9582: * PARM1 POINTER TO CTBLK ! 9583: * PARM2 BIT MASK TO SELECT BIT COLUMN ! 9584: * ! 9585: P$SPN ENT BL$P2 P2BLK ! 9586: * ! 9587: * EXPRESSION ARGUMENT CASE MERGES HERE ! 9588: * ! 9589: PSPN1 MOV PMSSL,WC COPY SUBJECT STRING LENGTH ! 9590: SUB WB,WC CALCULATE NUMBER OF CHARACTERS LEFT ! 9591: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT ! 9592: MOV R$PMS,XL POINT TO SUBJECT STRING ! 9593: PLC XL,WB POINT TO CURRENT CHARACTER ! 9594: MOV WB,PSAVC SAVE INITIAL CURSOR ! 9595: MOV XR,PSAVE SAVE NODE POINTER ! 9596: LCT WC,WC SET COUNTER FOR CHARS LEFT ! 9597: * ! 9598: * LOOP TO SCAN MATCHING CHARACTERS ! 9599: * ! 9600: PSPN2 LCH WA,(XL)+ LOAD NEXT CHARACTER, BUMP POINTER ! 9601: WTB WA CONVERT TO BYTE OFFSET ! 9602: MOV PARM1(XR),XR POINT TO CTBLK ! 9603: ADD WA,XR POINT TO CTBLK ENTRY ! 9604: MOV CTCHS(XR),WA LOAD CTBLK ENTRY ! 9605: MOV PSAVE,XR RESTORE NODE POINTER ! 9606: ANB PARM2(XR),WA AND WITH SELECTED BIT ! 9607: ZRB WA,PSPN3 JUMP IF NO MATCH ! 9608: ICV WB ELSE PUSH CURSOR ! 9609: BCT WC,PSPN2 LOOP BACK UNLESS END OF STRING ! 9610: * ! 9611: * HERE AFTER SCANNING MATCHING CHARACTERS ! 9612: * ! 9613: PSPN3 BNE WB,PSAVC,SUCCP SUCCEED IF CHARS MATCHED ! 9614: BRN FAILP ELSE FAIL IF NULL STRING MATCHED ! 9615: EJC ! 9616: * ! 9617: * SPAN (ONE CHARACTER ARGUMENT) ! 9618: * ! 9619: * PARM1 CHARACTER ARGUMENT ! 9620: * ! 9621: P$SPS ENT BL$P1 P1BLK ! 9622: MOV PMSSL,WC GET SUBJECT STRING LENGTH ! 9623: SUB WB,WC CALCULATE NUMBER OF CHARACTERS LEFT ! 9624: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT ! 9625: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING ! 9626: PLC XL,WB POINT TO CURRENT CHARACTER ! 9627: MOV WB,PSAVC SAVE INITIAL CURSOR ! 9628: LCT WC,WC SET COUNTER FOR CHARACTERS LEFT ! 9629: * ! 9630: * LOOP TO SCAN MATCHING CHARACTERS ! 9631: * ! 9632: PSPS1 LCH WA,(XL)+ LOAD NEXT CHARACTER, BUMP POINTER ! 9633: BNE WA,PARM1(XR),PSPS2 JUMP IF NO MATCH ! 9634: ICV WB ELSE PUSH CURSOR ! 9635: BCT WC,PSPS1 AND LOOP UNLESS END OF STRING ! 9636: * ! 9637: * HERE AFTER SCANNING MATCHING CHARACTERS ! 9638: * ! 9639: PSPS2 BNE WB,PSAVC,SUCCP SUCCEED IF CHARS MATCHED ! 9640: BRN FAILP FAIL IF NULL STRING MATCHED ! 9641: EJC ! 9642: * ! 9643: * MULTI-CHARACTER STRING ! 9644: * ! 9645: * NOTE THAT ONE CHARACTER STRINGS USE THE CIRCUIT FOR ! 9646: * ONE CHARACTER ANY ARGUMENTS (P$AN1). ! 9647: * ! 9648: * PARM1 POINTER TO SCBLK FOR STRING ARG ! 9649: * ! 9650: P$STR ENT BL$P1 P1BLK ! 9651: MOV PARM1(XR),XL GET POINTER TO STRING ! 9652: * ! 9653: * MERGE HERE AFTER EVALUATING EXPRESSION WITH STRING VALUE ! 9654: * ! 9655: PSTR1 MOV XR,PSAVE SAVE NODE POINTER ! 9656: MOV R$PMS,XR LOAD SUBJECT STRING POINTER ! 9657: PLC XR,WB POINT TO CURRENT CHARACTER ! 9658: ADD SCLEN(XL),WB COMPUTE NEW CURSOR POSITION ! 9659: BGT WB,PMSSL,FAILP FAIL IF PAST END OF STRING ! 9660: MOV WB,PSAVC SAVE UPDATED CURSOR ! 9661: MOV SCLEN(XL),WA GET NUMBER OF CHARS TO COMPARE ! 9662: PLC XL POINT TO CHARS OF TEST STRING ! 9663: CMC FAILP,FAILP COMPARE, FAIL IF NOT EQUAL ! 9664: MOV PSAVE,XR IF ALL MATCHED, RESTORE NODE PTR ! 9665: MOV PSAVC,WB RESTORE UPDATED CURSOR ! 9666: BRN SUCCP AND SUCCEED ! 9667: EJC ! 9668: * ! 9669: * SUCCEED ! 9670: * ! 9671: * SEE SECTION ON COMPOUND PATTERNS FOR DETAILS OF THE ! 9672: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE ! 9673: * ! 9674: * NO PARAMETERS ! 9675: * ! 9676: P$SUC ENT BL$P0 P0BLK ! 9677: MOV WB,-(XS) STACK CURSOR ! 9678: MOV XR,-(XS) STACK POINTER TO THIS NODE ! 9679: BRN SUCCP SUCCEED MATCHING NULL ! 9680: EJC ! 9681: * ! 9682: * TAB (INTEGER ARGUMENT) ! 9683: * ! 9684: * PARM1 INTEGER ARGUMENT ! 9685: * ! 9686: P$TAB ENT BL$P1 P1BLK ! 9687: * ! 9688: * EXPRESSION ARGUMENT CASE MERGES HERE ! 9689: * ! 9690: PTAB1 BGT WB,PARM1(XR),FAILP FAIL IF TOO FAR ALREADY ! 9691: MOV PARM1(XR),WB ELSE SET NEW CURSOR POSITION ! 9692: BLE WB,PMSSL,SUCCP SUCCEED IF NOT OFF END ! 9693: BRN FAILP ELSE FAIL ! 9694: EJC ! 9695: * ! 9696: * TAB (EXPRESSION ARGUMENT) ! 9697: * ! 9698: * PARM1 EXPRESSION POINTER ! 9699: * ! 9700: P$TBD ENT BL$P1 P1BLK ! 9701: JSR EVALI EVALUATE INTEGER ARGUMENT ! 9702: ERR 057,TAB EVALUATED ARGUMENT IS NOT INTEGER ! 9703: ERR 058,TAB EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE ! 9704: PPM FAILP FAIL IF EVALUATION FAILS ! 9705: PPM PTAB1 MERGE WITH NORMAL CASE IF OK ! 9706: EJC ! 9707: * ! 9708: * ANCHOR MOVEMENT ! 9709: * ! 9710: * NO PARAMETERS (DUMMY NODE) ! 9711: * ! 9712: P$UNA ENT ENTRY POINT ! 9713: MOV WB,XR COPY INITIAL PATTERN NODE POINTER ! 9714: MOV (XS),WB GET INITIAL CURSOR ! 9715: BEQ WB,PMSSL,EXFAL MATCH FAILS IF AT END OF STRING ! 9716: ICV WB ELSE INCREMENT CURSOR ! 9717: MOV WB,(XS) STORE INCREMENTED CURSOR ! 9718: MOV XR,-(XS) RESTACK INITIAL NODE PTR ! 9719: MOV =NDUNA,-(XS) RESTACK UNANCHORED NODE ! 9720: BRI (XR) REMATCH FIRST NODE ! 9721: EJC ! 9722: * ! 9723: * END OF PATTERN MATCH ROUTINES ! 9724: * ! 9725: * THE FOLLOWING ENTRY POINT MARKS THE END OF THE PATTERN ! 9726: * MATCHING ROUTINES AND ALSO THE END OF THE ENTRY POINTS ! 9727: * REFERENCED FROM THE FIRST WORD OF BLOCKS IN DYNAMIC STORE ! 9728: * ! 9729: P$YYY ENT BL$$I MARK LAST ENTRY IN PATTERN SECTION ! 9730: TTL S P I T B O L -- PREDEFINED SNOBOL4 FUNCTIONS ! 9731: * ! 9732: * THE FOLLOWING SECTION CONTAINS CODING FOR FUNCTIONS ! 9733: * WHICH ARE PREDEFINED AND AVAILABLE AT THE SNOBOL LEVEL. ! 9734: * ! 9735: * THESE ROUTINES RECEIVE CONTROL DIRECTLY FROM THE CODE OR ! 9736: * INDIRECTLY THROUGH THE O$FNC, O$FNS OR CFUNC ROUTINES. ! 9737: * IN BOTH CASES THE CONDITIONS ON ENTRY ARE AS FOLLOWS ! 9738: * ! 9739: * THE ARGUMENTS ARE ON THE STACK. THE NUMBER OF ARGUMENTS ! 9740: * HAS BEEN ADJUSTED TO CORRESPOND TO THE SVBLK SVNAR FIELD. ! 9741: * ! 9742: * IN CERTAIN FUNCTIONS THE DIRECT CALL IS NOT PERMITTED ! 9743: * AND IN THESE INSTANCES WE ALSO HAVE. ! 9744: * ! 9745: * (WA) ACTUAL NUMBER OF ARGUMENTS IN CALL ! 9746: * ! 9747: * CONTROL RETURNS BY PLACING THE FUNCTION RESULT VALUE ON ! 9748: * ON THE STACK AND CONTINUING EXECUTION WITH THE NEXT ! 9749: * WORD FROM THE GENERATED CODE. ! 9750: * ! 9751: * THE NAMES OF THE ENTRY POINTS OF THESE FUNCTIONS ARE OF ! 9752: * THE FORM S$XXX WHERE XXX IS THE THREE LETTER CODE FOR ! 9753: * THE SYSTEM VARIABLE NAME. THE FUNCTIONS ARE IN ORDER ! 9754: * ALPHABETICALLY BY THEIR ENTRY NAMES. ! 9755: EJC ! 9756: * ! 9757: * ANY ! 9758: * ! 9759: S$ANY ENT ENTRY POINT ! 9760: MOV =P$ANS,WB SET PCODE FOR SINGLE CHAR CASE ! 9761: MOV =P$ANY,XL PCODE FOR MULTI-CHAR CASE ! 9762: MOV =P$AYD,WC PCODE FOR EXPRESSION CASE ! 9763: JSR PATST CALL COMMON ROUTINE TO BUILD NODE ! 9764: ERR 059,ANY ARGUMENT IS NOT STRING OR EXPRESSION ! 9765: BRN EXIXR JUMP FOR NEXT CODE WORD ! 9766: EJC ! 9767: .IF .CNBF ! 9768: .ELSE ! 9769: * ! 9770: * APPEND ! 9771: * ! 9772: S$APN ENT ENTRY POINT ! 9773: MOV (XS)+,XL GET APPEND ARGUMENT ! 9774: MOV (XS)+,XR GET BCBLK ! 9775: BEQ (XR),=B$BCT,SAPN1 OK IF FIRST ARG IS BCBLK ! 9776: ERB 275,APPEND FIRST ARGUMENT IS NOT BUFFER ! 9777: * ! 9778: * HERE TO DO THE APPEND ! 9779: * ! 9780: SAPN1 JSR APNDB DO THE APPEND ! 9781: ERR 276,APPEND SECOND ARGUMENT IS NOT STRING ! 9782: PPM EXFAL NO ROOM - FAIL ! 9783: BRN EXNUL EXIT WITH NULL RESULT ! 9784: EJC ! 9785: .FI ! 9786: * ! 9787: * APPLY ! 9788: * ! 9789: * APPLY DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT ! 9790: * WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED. ! 9791: * ! 9792: S$APP ENT ENTRY POINT ! 9793: BZE WA,SAPP3 JUMP IF NO ARGUMENTS ! 9794: DCV WA ELSE GET APPLIED FUNC ARG COUNT ! 9795: MOV WA,WB COPY ! 9796: WTB WB CONVERT TO BYTES ! 9797: MOV XS,XT COPY STACK POINTER ! 9798: ADD WB,XT POINT TO FUNCTION ARGUMENT ON STACK ! 9799: MOV (XT),XR LOAD FUNCTION PTR (APPLY 1ST ARG) ! 9800: BZE WA,SAPP2 JUMP IF NO ARGS FOR APPLIED FUNC ! 9801: LCT WB,WA ELSE SET COUNTER FOR LOOP ! 9802: * ! 9803: * LOOP TO MOVE ARGUMENTS UP ON STACK ! 9804: * ! 9805: SAPP1 DCA XT POINT TO NEXT ARGUMENT ! 9806: MOV (XT),1(XT) MOVE ARGUMENT UP ! 9807: BCT WB,SAPP1 LOOP TILL ALL MOVED ! 9808: * ! 9809: * MERGE HERE TO CALL FUNCTION (WA = NUMBER OF ARGUMENTS) ! 9810: * ! 9811: SAPP2 ICA XS ADJUST STACK PTR FOR APPLY 1ST ARG ! 9812: JSR GTNVR GET VARIABLE BLOCK ADDR FOR FUNC ! 9813: PPM SAPP3 JUMP IF NOT NATURAL VARIABLE ! 9814: MOV VRFNC(XR),XL ELSE POINT TO FUNCTION BLOCK ! 9815: BRN CFUNC GO CALL APPLIED FUNCTION ! 9816: * ! 9817: * HERE FOR INVALID FIRST ARGUMENT ! 9818: * ! 9819: SAPP3 ERB 060,APPLY FIRST ARG IS NOT NATURAL VARIABLE NAME ! 9820: EJC ! 9821: * ! 9822: * ARBNO ! 9823: * ! 9824: * ARBNO BUILDS A COMPOUND PATTERN. SEE DESCRIPTION AT ! 9825: * START OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED. ! 9826: * ! 9827: S$ABN ENT ENTRY POINT ! 9828: ZER XR SET PARM1 = 0 FOR THE MOMENT ! 9829: MOV =P$ALT,WB SET PCODE FOR ALTERNATIVE NODE ! 9830: JSR PBILD BUILD ALTERNATIVE NODE ! 9831: MOV XR,XL SAVE PTR TO ALTERNATIVE PATTERN ! 9832: MOV =P$ABC,WB PCODE FOR P$ABC ! 9833: ZER XR P0BLK ! 9834: JSR PBILD BUILD P$ABC NODE ! 9835: MOV XL,PTHEN(XR) PUT ALTERNATIVE NODE AS SUCCESSOR ! 9836: MOV XL,WA REMEMBER ALTERNATIVE NODE POINTER ! 9837: MOV XR,XL COPY P$ABC NODE PTR ! 9838: MOV (XS),XR LOAD ARBNO ARGUMENT ! 9839: MOV WA,(XS) STACK ALTERNATIVE NODE POINTER ! 9840: JSR GTPAT GET ARBNO ARGUMENT AS PATTERN ! 9841: ERR 061,ARBNO ARGUMENT IS NOT PATTERN ! 9842: JSR PCONC CONCAT ARG WITH P$ABC NODE ! 9843: MOV XR,XL REMEMBER PTR TO CONCD PATTERNS ! 9844: MOV =P$ABA,WB PCODE FOR P$ABA ! 9845: ZER XR P0BLK ! 9846: JSR PBILD BUILD P$ABA NODE ! 9847: MOV XL,PTHEN(XR) CONCATENATE NODES ! 9848: MOV (XS),XL RECALL PTR TO ALTERNATIVE NODE ! 9849: MOV XR,PARM1(XL) POINT ALTERNATIVE BACK TO ARGUMENT ! 9850: BRN EXITS JUMP FOR NEXT CODE WORD ! 9851: EJC ! 9852: * ! 9853: * ARG ! 9854: * ! 9855: S$ARG ENT ENTRY POINT ! 9856: JSR GTSMI GET SECOND ARG AS SMALL INTEGER ! 9857: ERR 062,ARG SECOND ARGUMENT IS NOT INTEGER ! 9858: PPM EXFAL FAIL IF OUT OF RANGE OR NEGATIVE ! 9859: MOV XR,WA SAVE ARGUMENT NUMBER ! 9860: MOV (XS)+,XR LOAD FIRST ARGUMENT ! 9861: JSR GTNVR LOCATE VRBLK ! 9862: PPM SARG1 JUMP IF NOT NATURAL VARIABLE ! 9863: MOV VRFNC(XR),XR ELSE LOAD FUNCTION BLOCK POINTER ! 9864: BNE (XR),=B$PFC,SARG1 JUMP IF NOT PROGRAM DEFINED ! 9865: BZE WA,EXFAL FAIL IF ARG NUMBER IS ZERO ! 9866: BGT WA,FARGS(XR),EXFAL FAIL IF ARG NUMBER IS TOO LARGE ! 9867: WTB WA ELSE CONVERT TO BYTE OFFSET ! 9868: ADD WA,XR POINT TO ARGUMENT SELECTED ! 9869: MOV PFAGB(XR),XR LOAD ARGUMENT VRBLK POINTER ! 9870: BRN EXVNM EXIT TO BUILD NMBLK ! 9871: * ! 9872: * HERE IF 1ST ARGUMENT IS BAD ! 9873: * ! 9874: SARG1 ERB 063,ARG FIRST ARGUMENT IS NOT PROGRAM FUNCTION NAME ! 9875: EJC ! 9876: * ! 9877: * ARRAY ! 9878: * ! 9879: S$ARR ENT ENTRY POINT ! 9880: MOV (XS)+,XL LOAD INITIAL ELEMENT VALUE ! 9881: MOV (XS)+,XR LOAD FIRST ARGUMENT ! 9882: JSR GTINT CONVERT FIRST ARG TO INTEGER ! 9883: PPM SAR02 JUMP IF NOT INTEGER ! 9884: * ! 9885: * HERE FOR INTEGER FIRST ARGUMENT, BUILD VCBLK ! 9886: * ! 9887: LDI ICVAL(XR) LOAD INTEGER VALUE ! 9888: ILE SAR10 JUMP IF ZERO OR NEG (BAD DIMENSION) ! 9889: MFI WA,SAR11 ELSE CONVERT TO ONE WORD, TEST OVFL ! 9890: LCT WB,WA COPY ELEMENTS FOR LOOP LATER ON ! 9891: ADD =VCSI$,WA ADD SPACE FOR STANDARD FIELDS ! 9892: WTB WA CONVERT LENGTH TO BYTES ! 9893: BGE WA,MXLEN,SAR11 FAIL IF TOO LARGE ! 9894: JSR ALLOC ALLOCATE SPACE FOR VCBLK ! 9895: MOV =B$VCT,(XR) STORE TYPE WORD ! 9896: MOV WA,VCLEN(XR) SET LENGTH ! 9897: MOV XL,WC COPY DEFAULT VALUE ! 9898: MOV XR,XL COPY VCBLK POINTER ! 9899: ADD *VCVLS,XL POINT TO FIRST ELEMENT VALUE ! 9900: * ! 9901: * LOOP TO SET VECTOR ELEMENTS TO DEFAULT VALUE ! 9902: * ! 9903: SAR01 MOV WC,(XL)+ STORE ONE VALUE ! 9904: BCT WB,SAR01 LOOP TILL ALL STORED ! 9905: BRN EXSID EXIT SETTING IDVAL ! 9906: EJC ! 9907: * ! 9908: * ARRAY (CONTINUED) ! 9909: * ! 9910: * HERE IF FIRST ARGUMENT IS NOT AN INTEGER ! 9911: * ! 9912: SAR02 MOV XR,-(XS) REPLACE ARGUMENT ON STACK ! 9913: JSR XSCNI INITIALIZE SCAN OF FIRST ARGUMENT ! 9914: ERR 064,ARRAY FIRST ARGUMENT IS NOT INTEGER OR STRING ! 9915: PPM EXNUL DUMMY (UNUSED) NULL STRING EXIT ! 9916: MOV R$XSC,-(XS) SAVE PROTOTYPE POINTER ! 9917: MOV XL,-(XS) SAVE DEFAULT VALUE ! 9918: ZER ARCDM ZERO COUNT OF DIMENSIONS ! 9919: ZER ARPTR ZERO OFFSET TO INDICATE PASS ONE ! 9920: LDI INTV1 LOAD INTEGER ONE ! 9921: STI ARNEL INITIALIZE ELEMENT COUNT ! 9922: * ! 9923: * THE FOLLOWING CODE IS EXECUTED TWICE. THE FIRST TIME ! 9924: * (ARPTR EQ 0), IT IS USED TO COUNT THE NUMBER OF ELEMENTS ! 9925: * AND NUMBER OF DIMENSIONS. THE SECOND TIME (ARPTR GT 0) IS ! 9926: * USED TO ACTUALLY FILL IN THE DIM,LBD FIELDS OF THE ARBLK. ! 9927: * ! 9928: SAR03 LDI INTV1 LOAD ONE AS DEFAULT LOW BOUND ! 9929: STI ARSVL SAVE AS LOW BOUND ! 9930: MOV =CH$CL,WC SET DELIMITER ONE = COLON ! 9931: MOV =CH$CM,XL SET DELIMITER TWO = COMMA ! 9932: JSR XSCAN SCAN NEXT BOUND ! 9933: BNE WA,=NUM01,SAR04 JUMP IF NOT COLON ! 9934: * ! 9935: * HERE WE HAVE A COLON ENDING A LOW BOUND ! 9936: * ! 9937: JSR GTINT CONVERT LOW BOUND ! 9938: ERR 065,ARRAY FIRST ARGUMENT LOWER BOUND IS NOT INTEGER ! 9939: LDI ICVAL(XR) LOAD VALUE OF LOW BOUND ! 9940: STI ARSVL STORE LOW BOUND VALUE ! 9941: MOV =CH$CM,WC SET DELIMITER ONE = COMMA ! 9942: MOV WC,XL AND DELIMITER TWO = COMMA ! 9943: JSR XSCAN SCAN HIGH BOUND ! 9944: EJC ! 9945: * ! 9946: * ARRAY (CONTINUED) ! 9947: * ! 9948: * MERGE HERE TO PROCESS UPPER BOUND ! 9949: * ! 9950: SAR04 JSR GTINT CONVERT HIGH BOUND TO INTEGER ! 9951: ERR 066,ARRAY FIRST ARGUMENT UPPER BOUND IS NOT INTEGER ! 9952: LDI ICVAL(XR) GET HIGH BOUND ! 9953: SBI ARSVL SUBTRACT LOWER BOUND ! 9954: IOV SAR10 BAD DIMENSION IF OVERFLOW ! 9955: ILT SAR10 BAD DIMENSION IF NEGATIVE ! 9956: ADI INTV1 ADD 1 TO GET DIMENSION ! 9957: IOV SAR10 BAD DIMENSION IF OVERFLOW ! 9958: MOV ARPTR,XL LOAD OFFSET (ALSO PASS INDICATOR) ! 9959: BZE XL,SAR05 JUMP IF FIRST PASS ! 9960: * ! 9961: * HERE IN SECOND PASS TO STORE LBD AND DIM IN ARBLK ! 9962: * ! 9963: ADD (XS),XL POINT TO CURRENT LOCATION IN ARBLK ! 9964: STI CFP$I(XL) STORE DIMENSION ! 9965: LDI ARSVL LOAD LOW BOUND ! 9966: STI (XL) STORE LOW BOUND ! 9967: ADD *ARDMS,ARPTR BUMP OFFSET TO NEXT BOUNDS ! 9968: BRN SAR06 JUMP TO CHECK FOR END OF BOUNDS ! 9969: * ! 9970: * HERE IN PASS 1 ! 9971: * ! 9972: SAR05 ICV ARCDM BUMP DIMENSION COUNT ! 9973: MLI ARNEL MULTIPLY DIMENSION BY COUNT SO FAR ! 9974: IOV SAR11 TOO LARGE IF OVERFLOW ! 9975: STI ARNEL ELSE STORE UPDATED ELEMENT COUNT ! 9976: * ! 9977: * MERGE HERE AFTER PROCESSING ONE SET OF BOUNDS ! 9978: * ! 9979: SAR06 BNZ WA,SAR03 LOOP BACK UNLESS END OF BOUNDS ! 9980: BNZ ARPTR,SAR09 JUMP IF END OF PASS 2 ! 9981: EJC ! 9982: * ! 9983: * ARRAY (CONTINUED) ! 9984: * ! 9985: * HERE AT END OF PASS ONE, BUILD ARBLK ! 9986: * ! 9987: LDI ARNEL GET NUMBER OF ELEMENTS ! 9988: MFI WB,SAR11 GET AS ADDR INTEGER, TEST OVFLO ! 9989: WTB WB ELSE CONVERT TO LENGTH IN BYTES ! 9990: MOV *ARSI$,WA SET SIZE OF STANDARD FIELDS ! 9991: LCT WC,ARCDM SET DIMENSION COUNT TO CONTROL LOOP ! 9992: * ! 9993: * LOOP TO ALLOW SPACE FOR DIMENSIONS ! 9994: * ! 9995: SAR07 ADD *ARDMS,WA ALLOW SPACE FOR ONE SET OF BOUNDS ! 9996: BCT WC,SAR07 LOOP BACK TILL ALL ACCOUNTED FOR ! 9997: MOV WA,XL SAVE SIZE (=AROFS) ! 9998: * ! 9999: * NOW ALLOCATE SPACE FOR ARBLK ! 10000: * ! 10001: ADD WB,WA ADD SPACE FOR ELEMENTS ! 10002: ICA WA ALLOW FOR ARPRO PROTOTYPE FIELD ! 10003: BGE WA,MXLEN,SAR11 FAIL IF TOO LARGE ! 10004: JSR ALLOC ELSE ALLOCATE ARBLK ! 10005: MOV (XS),WB LOAD DEFAULT VALUE ! 10006: MOV XR,(XS) SAVE ARBLK POINTER ! 10007: MOV WA,WC SAVE LENGTH IN BYTES ! 10008: BTW WA CONVERT LENGTH BACK TO WORDS ! 10009: LCT WA,WA SET COUNTER TO CONTROL LOOP ! 10010: * ! 10011: * LOOP TO CLEAR ENTIRE ARBLK TO DEFAULT VALUE ! 10012: * ! 10013: SAR08 MOV WB,(XR)+ SET ONE WORD ! 10014: BCT WA,SAR08 LOOP TILL ALL SET ! 10015: EJC ! 10016: * ! 10017: * ARRAY (CONTINUED) ! 10018: * ! 10019: * NOW SET INITIAL FIELDS OF ARBLK ! 10020: * ! 10021: MOV (XS)+,XR RELOAD ARBLK POINTER ! 10022: MOV (XS),WB LOAD PROTOTYPE ! 10023: MOV =B$ART,(XR) SET TYPE WORD ! 10024: MOV WC,ARLEN(XR) STORE LENGTH IN BYTES ! 10025: ZER IDVAL(XR) ZERO ID TILL WE GET IT BUILT ! 10026: MOV XL,AROFS(XR) SET PROTOTYPE FIELD PTR ! 10027: MOV ARCDM,ARNDM(XR) SET NUMBER OF DIMENSIONS ! 10028: MOV XR,WC SAVE ARBLK POINTER ! 10029: ADD XL,XR POINT TO PROTOTYPE FIELD ! 10030: MOV WB,(XR) STORE PROTOTYPE PTR IN ARBLK ! 10031: MOV *ARLBD,ARPTR SET OFFSET FOR PASS 2 BOUNDS SCAN ! 10032: MOV WB,R$XSC RESET STRING POINTER FOR XSCAN ! 10033: MOV WC,(XS) STORE ARBLK POINTER ON STACK ! 10034: ZER XSOFS RESET OFFSET PTR TO START OF STRING ! 10035: BRN SAR03 JUMP BACK TO RESCAN BOUNDS ! 10036: * ! 10037: * HERE AFTER FILLING IN BOUNDS INFORMATION (END PASS TWO) ! 10038: * ! 10039: SAR09 MOV (XS)+,XR RELOAD POINTER TO ARBLK ! 10040: BRN EXSID EXIT SETTING IDVAL ! 10041: * ! 10042: * HERE FOR BAD DIMENSION ! 10043: * ! 10044: SAR10 ERB 067,ARRAY DIMENSION IS ZERO,NEGATIVE OR OUT OF RANGE ! 10045: * ! 10046: * HERE IF ARRAY IS TOO LARGE ! 10047: * ! 10048: SAR11 ERB 068,ARRAY SIZE EXCEEDS MAXIMUM PERMITTED ! 10049: EJC ! 10050: .IF .CNBF ! 10051: .ELSE ! 10052: * ! 10053: * BUFFER ! 10054: * ! 10055: S$BUF ENT ENTRY POINT ! 10056: MOV (XS)+,XL GET INITIAL VALUE ! 10057: MOV (XS)+,XR GET REQUESTED ALLOCATION ! 10058: JSR GTINT CONVERT TO INTEGER ! 10059: ERR 269,BUFFER FIRST ARGUMENT IS NOT INTEGER ! 10060: LDI ICVAL(XR) GET VALUE ! 10061: ILE SBF01 BRANCH IF NEGATIVE OR ZERO ! 10062: MFI WA,SBF02 MOVE WITH OVERFLOW CHECK ! 10063: JSR ALOBF ALLOCATE THE BUFFER ! 10064: JSR APNDB COPY IT IN ! 10065: ERR 270,BUFFER SECOND ARGUMENT IS NOT STRING OR BUFFER ! 10066: ERR 271,BUFFER INITIAL VALUE TOO BIG FOR ALLOCATION ! 10067: BRN EXSID EXIT SETTING IDVAL ! 10068: * ! 10069: * HERE FOR INVALID ALLOCATION SIZE ! 10070: * ! 10071: SBF01 ERB 272,BUFFER FIRST ARGUMENT IS NOT POSITIVE ! 10072: * ! 10073: * HERE FOR ALLOCATION SIZE INTEGER OVERFLOW ! 10074: * ! 10075: SBF02 ERB 273,BUFFER SIZE IS TOO BIG ! 10076: EJC ! 10077: .FI ! 10078: * ! 10079: * BREAK ! 10080: * ! 10081: S$BRK ENT ENTRY POINT ! 10082: MOV =P$BKS,WB SET PCODE FOR SINGLE CHAR CASE ! 10083: MOV =P$BRK,XL PCODE FOR MULTI-CHAR CASE ! 10084: MOV =P$BKD,WC PCODE FOR EXPRESSION CASE ! 10085: JSR PATST CALL COMMON ROUTINE TO BUILD NODE ! 10086: ERR 069,BREAK ARGUMENT IS NOT STRING OR EXPRESSION ! 10087: BRN EXIXR JUMP FOR NEXT CODE WORD ! 10088: EJC ! 10089: * ! 10090: * BREAKX ! 10091: * ! 10092: * BREAKX IS A COMPOUND PATTERN. SEE DESCRIPTION AT START ! 10093: * OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED. ! 10094: * ! 10095: S$BKX ENT ENTRY POINT ! 10096: MOV =P$BKS,WB PCODE FOR SINGLE CHAR ARGUMENT ! 10097: MOV =P$BRK,XL PCODE FOR MULTI-CHAR ARGUMENT ! 10098: MOV =P$BXD,WC PCODE FOR EXPRESSION CASE ! 10099: JSR PATST CALL COMMON ROUTINE TO BUILD NODE ! 10100: ERR 070,BREAKX ARGUMENT IS NOT STRING OR EXPRESSION ! 10101: * ! 10102: * NOW HOOK BREAKX NODE ON AT FRONT END ! 10103: * ! 10104: MOV XR,-(XS) SAVE PTR TO BREAK NODE ! 10105: MOV =P$BKX,WB SET PCODE FOR BREAKX NODE ! 10106: JSR PBILD BUILD IT ! 10107: MOV (XS),PTHEN(XR) SET BREAK NODE AS SUCCESSOR ! 10108: MOV =P$ALT,WB SET PCODE FOR ALTERNATION NODE ! 10109: JSR PBILD BUILD (PARM1=ALT=BREAKX NODE) ! 10110: MOV XR,WA SAVE PTR TO ALTERNATION NODE ! 10111: MOV (XS),XR POINT TO BREAK NODE ! 10112: MOV WA,PTHEN(XR) SET ALTERNATE NODE AS SUCCESSOR ! 10113: BRN EXITS EXIT WITH RESULT ON STACK ! 10114: EJC ! 10115: * ! 10116: * CHAR ! 10117: * ! 10118: S$CHR ENT ENTRY POINT ! 10119: JSR GTSMI CONVERT ARG TO INTEGER ! 10120: ERR 281,CHAR ARGUMENT NOT INTEGER ! 10121: PPM SCHR1 TOO BIG ERROR EXIT ! 10122: BGE WC,=CFP$A,SCHR1 SEE IF OUT OF RANGE OF HOST SET ! 10123: MOV =NUM01,WA IF NOT SET SCBLK ALLOCATION ! 10124: MOV WC,WB SAVE CHAR CODE ! 10125: JSR ALOCS ALLOCATE 1 BAU SCBLK ! 10126: MOV XR,XL COPY SCBLK POINTER ! 10127: PSC XL GET SET TO STUFF CHAR ! 10128: SCH WB,(XL)+ STUFF IT ! 10129: ZER XL CLEAR SLOP IN XL ! 10130: BRN EXIXR EXIT WITH SCBLK POINTER ! 10131: * ! 10132: * HERE IF CHAR ARGUMENT IS OUT OF RANGE ! 10133: * ! 10134: SCHR1 ERB 282,CHAR ARGUMENT NOT IN RANGE ! 10135: EJC ! 10136: * ! 10137: * CLEAR ! 10138: * ! 10139: S$CLR ENT ENTRY POINT ! 10140: JSR XSCNI INITIALIZE TO SCAN ARGUMENT ! 10141: ERR 071,CLEAR ARGUMENT IS NOT STRING ! 10142: PPM SCLR2 JUMP IF NULL ! 10143: * ! 10144: * LOOP TO SCAN OUT NAMES IN FIRST ARGUMENT. VARIABLES IN ! 10145: * THE LIST ARE FALGGED BY SETTING VRGET OF VRBLK TO ZERO. ! 10146: * ! 10147: SCLR1 MOV =CH$CM,WC SET DELIMITER ONE = COMMA ! 10148: MOV WC,XL DELIMITER TWO = COMMA ! 10149: JSR XSCAN SCAN NEXT VARIABLE NAME ! 10150: JSR GTNVR LOCATE VRBLK ! 10151: ERR 072,CLEAR ARGUMENT HAS NULL VARIABLE NAME ! 10152: ZER VRGET(XR) ELSE FLAG BY ZEROING VRGET FIELD ! 10153: BNZ WA,SCLR1 LOOP BACK IF STOPPED BY COMMA ! 10154: * ! 10155: * HERE AFTER FLAGGING VARIABLES IN ARGUMENT LIST ! 10156: * ! 10157: SCLR2 MOV HSHTB,WB POINT TO START OF HASH TABLE ! 10158: * ! 10159: * LOOP THROUGH SLOTS IN HASH TABLE ! 10160: * ! 10161: SCLR3 BEQ WB,HSHTE,EXNUL EXIT RETURNING NULL IF NONE LEFT ! 10162: MOV WB,XR ELSE COPY SLOT POINTER ! 10163: ICA WB BUMP SLOT POINTER ! 10164: SUB *VRNXT,XR SET OFFSET TO MERGE INTO LOOP ! 10165: * ! 10166: * LOOP THROUGH VRBLKS ON ONE HASH CHAIN ! 10167: * ! 10168: SCLR4 MOV VRNXT(XR),XR POINT TO NEXT VRBLK ON CHAIN ! 10169: BZE XR,SCLR3 JUMP FOR NEXT BUCKET IF CHAIN END ! 10170: BNZ VRGET(XR),SCLR5 JUMP IF NOT FLAGGED ! 10171: EJC ! 10172: * ! 10173: * CLEAR (CONTINUED) ! 10174: * ! 10175: * HERE FOR FLAGGED VARIABLE, DO NOT SET VALUE TO NULL ! 10176: * ! 10177: JSR SETVR FOR FLAGGED VAR, RESTORE VRGET ! 10178: BRN SCLR4 AND LOOP BACK FOR NEXT VRBLK ! 10179: * ! 10180: * HERE TO SET VALUE OF A VARIABLE TO NULL ! 10181: * PRROTECTED VARIABLES (ARB, ETC) ARE EXEMPT ! 10182: * ! 10183: SCLR5 BEQ VRSTO(XR),=B$VRE,SCLR4 CHECK FOR PROTECTED VARIABLE (REG05) ! 10184: MOV XR,XL COPY VRBLK POINTER (REG05) ! 10185: * ! 10186: * LOOP TO LOCATE VALUE AT END OF POSSIBLE TRBLK CHAIN ! 10187: * ! 10188: SCLR6 MOV XL,WA SAVE BLOCK POINTER ! 10189: MOV VRVAL(XL),XL LOAD NEXT VALUE FIELD ! 10190: BEQ (XL),=B$TRT,SCLR6 LOOP BACK IF TRAPPED ! 10191: * ! 10192: * NOW STORE THE NULL VALUE ! 10193: * ! 10194: MOV WA,XL RESTORE BLOCK POINTER ! 10195: MOV =NULLS,VRVAL(XL) STORE NULL CONSTANT VALUE ! 10196: BRN SCLR4 LOOP BACK FOR NEXT VRBLK ! 10197: EJC ! 10198: * ! 10199: * CODE ! 10200: * ! 10201: S$COD ENT ENTRY POINT ! 10202: MOV (XS)+,XR LOAD ARGUMENT ! 10203: JSR GTCOD CONVERT TO CODE ! 10204: PPM EXFAL FAIL IF CONVERSION IS IMPOSSIBLE ! 10205: BRN EXIXR ELSE RETURN CODE AS RESULT ! 10206: EJC ! 10207: * ! 10208: * COLLECT ! 10209: * ! 10210: S$COL ENT ENTRY POINT ! 10211: MOV (XS)+,XR LOAD ARGUMENT ! 10212: JSR GTINT CONVERT TO INTEGER ! 10213: ERR 073,COLLECT ARGUMENT IS NOT INTEGER ! 10214: LDI ICVAL(XR) LOAD COLLECT ARGUMENT ! 10215: STI CLSVI SAVE COLLECT ARGUMENT ! 10216: ZER WB SET NO MOVE UP ! 10217: JSR GBCOL PERFORM GARBAGE COLLECTION ! 10218: MOV DNAME,WA POINT TO END OF MEMORY ! 10219: SUB DNAMP,WA SUBTRACT NEXT LOCATION ! 10220: BTW WA CONVERT BYTES TO WORDS ! 10221: MTI WA CONVERT WORDS AVAILABLE AS INTEGER ! 10222: SBI CLSVI SUBTRACT ARGUMENT ! 10223: IOV EXFAL FAIL IF OVERFLOW ! 10224: ILT EXFAL FAIL IF NOT ENOUGH ! 10225: ADI CLSVI ELSE RECOMPUTE AVAILABLE ! 10226: BRN EXINT AND EXIT WITH INTEGER RESULT ! 10227: EJC ! 10228: * ! 10229: * CONVERT ! 10230: * ! 10231: S$CNV ENT ENTRY POINT ! 10232: JSR GTSTG CONVERT SECOND ARGUMENT TO STRING ! 10233: ERR 074,CONVERT SECOND ARGUMENT IS NOT STRING ! 10234: .IF .CULC ! 10235: JSR FLSTG FOLD LOWER CASE TO UPPER CASE ! 10236: .FI ! 10237: MOV (XS),XL LOAD FIRST ARGUMENT ! 10238: BNE (XL),=B$PDT,SCV01 JUMP IF NOT PROGRAM DEFINED ! 10239: * ! 10240: * HERE FOR PROGRAM DEFINED DATATYPE ! 10241: * ! 10242: MOV PDDFP(XL),XL POINT TO DFBLK ! 10243: MOV DFNAM(XL),XL LOAD DATATYPE NAME ! 10244: JSR IDENT COMPARE WITH SECOND ARG ! 10245: PPM EXITS EXIT IF IDENT WITH ARG AS RESULT ! 10246: BRN EXFAL ELSE FAIL ! 10247: * ! 10248: * HERE IF NOT PROGRAM DEFINED DATATYPE ! 10249: * ! 10250: SCV01 MOV XR,-(XS) SAVE STRING ARGUMENT ! 10251: MOV =SVCTB,XL POINT TO TABLE OF NAMES TO COMPARE ! 10252: ZER WB INITIALIZE COUNTER ! 10253: MOV WA,WC SAVE LENGTH OF ARGUMENT STRING ! 10254: * ! 10255: * LOOP THROUGH TABLE ENTRIES ! 10256: * ! 10257: SCV02 MOV (XL)+,XR LOAD NEXT TABLE ENTRY, BUMP POINTER ! 10258: BZE XR,EXFAL FAIL IF ZERO MARKING END OF LIST ! 10259: BNE WC,SCLEN(XR),SCV05 JUMP IF WRONG LENGTH ! 10260: MOV XL,CNVTP ELSE STORE TABLE POINTER ! 10261: PLC XR POINT TO CHARS OF TABLE ENTRY ! 10262: MOV (XS),XL LOAD POINTER TO STRING ARGUMENT ! 10263: PLC XL POINT TO CHARS OF STRING ARG ! 10264: MOV WC,WA SET NUMBER OF CHARS TO COMPARE ! 10265: CMC SCV04,SCV04 COMPARE, JUMP IF NO MATCH ! 10266: EJC ! 10267: * ! 10268: * CONVERT (CONTINUED) ! 10269: * ! 10270: * HERE WE HAVE A MATCH ! 10271: * ! 10272: SCV03 MOV WB,XL COPY ENTRY NUMBER ! 10273: ICA XS POP STRING ARG OFF STACK ! 10274: MOV (XS)+,XR LOAD FIRST ARGUMENT ! 10275: BSW XL,CNVTT JUMP TO APPROPRIATE ROUTINE ! 10276: IFF 0,SCV06 STRING ! 10277: IFF 1,SCV07 INTEGER ! 10278: IFF 2,SCV09 NAME ! 10279: IFF 3,SCV10 PATTERN ! 10280: IFF 4,SCV11 ARRAY ! 10281: IFF 5,SCV19 TABLE ! 10282: IFF 6,SCV25 EXPRESSION ! 10283: IFF 7,SCV26 CODE ! 10284: IFF 8,SCV27 NUMERIC ! 10285: .IF .CNRA ! 10286: .ELSE ! 10287: IFF CNVRT,SCV08 REAL ! 10288: .FI ! 10289: .IF .CNBF ! 10290: .ELSE ! 10291: IFF CNVBT,SCV28 BUFFER ! 10292: .FI ! 10293: ESW END OF SWITCH TABLE ! 10294: * ! 10295: * HERE IF NO MATCH WITH TABLE ENTRY ! 10296: * ! 10297: SCV04 MOV CNVTP,XL RESTORE TABLE POINTER, MERGE ! 10298: * ! 10299: * MERGE HERE IF LENGTHS DID NOT MATCH ! 10300: * ! 10301: SCV05 ICV WB BUMP ENTRY NUMBER ! 10302: BRN SCV02 LOOP BACK TO CHECK NEXT ENTRY ! 10303: * ! 10304: * HERE TO CONVERT TO STRING ! 10305: * ! 10306: SCV06 MOV XR,-(XS) REPLACE STRING ARGUMENT ON STACK ! 10307: JSR GTSTG CONVERT TO STRING ! 10308: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE ! 10309: BRN EXIXR ELSE RETURN STRING ! 10310: EJC ! 10311: * ! 10312: * CONVERT (CONTINUED) ! 10313: * ! 10314: * HERE TO CONVERT TO INTEGER ! 10315: * ! 10316: SCV07 JSR GTINT CONVERT TO INTEGER ! 10317: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE ! 10318: BRN EXIXR ELSE RETURN INTEGER ! 10319: .IF .CNRA ! 10320: .ELSE ! 10321: * ! 10322: * HERE TO CONVERT TO REAL ! 10323: * ! 10324: SCV08 JSR GTREA CONVERT TO REAL ! 10325: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE ! 10326: BRN EXIXR ELSE RETURN REAL ! 10327: .FI ! 10328: * ! 10329: * HERE TO CONVERT TO NAME ! 10330: * ! 10331: SCV09 BEQ (XR),=B$NML,EXIXR RETURN IF ALREADY A NAME ! 10332: JSR GTNVR ELSE TRY STRING TO NAME CONVERT ! 10333: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE ! 10334: BRN EXVNM ELSE EXIT BUILDING NMBLK FOR VRBLK ! 10335: * ! 10336: * HERE TO CONVERT TO PATTERN ! 10337: * ! 10338: SCV10 JSR GTPAT CONVERT TO PATTERN ! 10339: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE ! 10340: BRN EXIXR ELSE RETURN PATTERN ! 10341: * ! 10342: * CONVERT TO ARRAY ! 10343: * ! 10344: SCV11 JSR GTARR GET AN ARRAY ! 10345: PPM EXFAL FAIL IF NOT CONVERTIBLE ! 10346: BRN EXSID EXIT SETTING ID FIELD ! 10347: * ! 10348: * CONVERT TO TABLE ! 10349: * ! 10350: SCV19 MOV (XR),WA LOAD FIRST WORD OF BLOCK ! 10351: MOV XR,-(XS) REPLACE ARBLK POINTER ON STACK ! 10352: BEQ WA,=B$TBT,EXITS RETURN ARG IF ALREADY A TABLE ! 10353: BNE WA,=B$ART,EXFAL ELSE FAIL IF NOT AN ARRAY ! 10354: EJC ! 10355: * ! 10356: * CONVERT (CONTINUED) ! 10357: * ! 10358: * HERE TO CONVERT AN ARRAY TO TABLE ! 10359: * ! 10360: BNE ARNDM(XR),=NUM02,EXFAL FAIL IF NOT 2-DIM ARRAY ! 10361: LDI ARDM2(XR) LOAD DIM 2 ! 10362: SBI INTV2 SUBTRACT 2 TO COMPARE ! 10363: INE EXFAL FAIL IF DIM2 NOT 2 ! 10364: * ! 10365: * HERE WE HAVE AN ARBLK OF THE RIGHT SHAPE ! 10366: * ! 10367: LDI ARDIM(XR) LOAD DIM 1 (NUMBER OF ELEMENTS) ! 10368: MFI WA GET AS ONE WORD INTEGER ! 10369: LCT WB,WA COPY TO CONTROL LOOP ! 10370: ADD =TBSI$,WA ADD SPACE FOR STANDARD FIELDS ! 10371: WTB WA CONVERT LENGTH TO BYTES ! 10372: JSR ALLOC ALLOCATE SPACE FOR TBBLK ! 10373: MOV XR,WC COPY TBBLK POINTER ! 10374: MOV XR,-(XS) SAVE TBBLK POINTER ! 10375: MOV =B$TBT,(XR)+ STORE TYPE WORD ! 10376: ZER (XR)+ STORE ZERO FOR IDVAL FOR NOW ! 10377: MOV WA,(XR)+ STORE LENGTH ! 10378: MOV =NULLS,(XR)+ NULL INITIAL LOOKUP VALUE ! 10379: * ! 10380: * LOOP TO INITIALIZE BUCKET PTRS TO POINT TO TABLE ! 10381: * ! 10382: SCV20 MOV WC,(XR)+ SET BUCKET PTR TO POINT TO TBBLK ! 10383: BCT WB,SCV20 LOOP TILL ALL INITIALIZED ! 10384: MOV *ARVL2,WB SET OFFSET TO FIRST ARBLK ELEMENT ! 10385: * ! 10386: * LOOP TO COPY ELEMENTS FROM ARRAY TO TABLE ! 10387: * ! 10388: SCV21 MOV 1(XS),XL POINT TO ARBLK ! 10389: BEQ WB,ARLEN(XL),SCV24 JUMP IF ALL MOVED ! 10390: ADD WB,XL ELSE POINT TO CURRENT LOCATION ! 10391: ADD *NUM02,WB BUMP OFFSET ! 10392: MOV (XL),XR LOAD SUBSCRIPT NAME ! 10393: DCA XL ADJUST PTR TO MERGE (TRVAL=1+1) ! 10394: EJC ! 10395: * ! 10396: * CONVERT (CONTINUED) ! 10397: * ! 10398: * LOOP TO CHASE DOWN TRBLK CHAIN FOR VALUE ! 10399: * ! 10400: SCV22 MOV TRVAL(XL),XL POINT TO NEXT VALUE ! 10401: BEQ (XL),=B$TRT,SCV22 LOOP BACK IF TRAPPED ! 10402: * ! 10403: * HERE WITH NAME IN XR, VALUE IN XL ! 10404: * ! 10405: SCV23 MOV XL,-(XS) STACK VALUE ! 10406: MOV 1(XS),XL LOAD TBBLK POINTER ! 10407: JSR TFIND BUILD TEBLK (NOTE WB GT 0 BY NAME) ! 10408: PPM EXFAL FAIL IF ACESS FAILS ! 10409: MOV (XS)+,TEVAL(XL) STORE VALUE IN TEBLK ! 10410: BRN SCV21 LOOP BACK FOR NEXT ELEMENT ! 10411: * ! 10412: * HERE AFTER MOVING ALL ELEMENTS TO TBBLK ! 10413: * ! 10414: SCV24 MOV (XS)+,XR LOAD TBBLK POINTER ! 10415: ICA XS POP ARBLK POINTER ! 10416: BRN EXSID EXIT SETTING IDVAL ! 10417: * ! 10418: * CONVERT TO EXPRESSION ! 10419: * ! 10420: SCV25 JSR GTEXP CONVERT TO EXPRESSION ! 10421: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE ! 10422: BRN EXIXR ELSE RETURN EXPRESSION ! 10423: * ! 10424: * CONVERT TO CODE ! 10425: * ! 10426: SCV26 JSR GTCOD CONVERT TO CODE ! 10427: PPM EXFAL FAIL IF CONVERSION IS NOT POSSIBLE ! 10428: BRN EXIXR ELSE RETURN CODE ! 10429: * ! 10430: * CONVERT TO NUMERIC ! 10431: * ! 10432: SCV27 JSR GTNUM CONVERT TO NUMERIC ! 10433: PPM EXFAL FAIL IF UNCONVERTIBLE ! 10434: BRN EXIXR RETURN NUMBER ! 10435: EJC ! 10436: .IF .CNBF ! 10437: .ELSE ! 10438: * ! 10439: * CONVERT TO BUFFER ! 10440: * ! 10441: SCV28 MOV XR,-(XS) STACK STRING FOR PROCEDURE ! 10442: JSR GTSTG CONVERT TO STRING ! 10443: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE ! 10444: MOV XR,XL SAVE STRING POINTER ! 10445: JSR ALOBF ALLOCATE BUFFER OF SAME SIZE ! 10446: JSR APNDB COPY IN THE STRING ! 10447: PPM ALREADY STRING - CANT FAIL TO CNV ! 10448: PPM MUST BE ENOUGH ROOM ! 10449: BRN EXSID EXIT SETTING IDVAL FIELD ! 10450: EJC ! 10451: .FI ! 10452: * ! 10453: * COPY ! 10454: * ! 10455: S$COP ENT ENTRY POINT ! 10456: JSR COPYB COPY THE BLOCK ! 10457: PPM EXITS RETURN IF NO IDVAL FIELD ! 10458: BRN EXSID EXIT SETTING ID VALUE ! 10459: EJC ! 10460: * ! 10461: * DATA ! 10462: * ! 10463: S$DAT ENT ENTRY POINT ! 10464: JSR XSCNI PREPARE TO SCAN ARGUMENT ! 10465: ERR 075,DATA ARGUMENT IS NOT STRING ! 10466: ERR 076,DATA ARGUMENT IS NULL ! 10467: * ! 10468: * SCAN OUT DATATYPE NAME ! 10469: * ! 10470: MOV =CH$PP,WC DELIMITER ONE = LEFT PAREN ! 10471: MOV WC,XL DELIMITER TWO = LEFT PAREN ! 10472: JSR XSCAN SCAN DATATYPE NAME ! 10473: BNZ WA,SDAT1 SKIP IF LEFT PAREN FOUND ! 10474: ERB 077,DATA ARGUMENT IS MISSING A LEFT PAREN ! 10475: * ! 10476: * HERE AFTER SCANNING DATATYPE NAME ! 10477: * ! 10478: .IF .CULC ! 10479: SDAT1 MOV SCLEN(XR),WA GET LENGTH ! 10480: JSR FLSTG FOLD LOWER CASE TO UPPER CASE ! 10481: MOV XR,XL SAVE NAME PTR ! 10482: .ELSE ! 10483: SDAT1 MOV XR,XL SAVE NAME PTR ! 10484: .FI ! 10485: MOV SCLEN(XR),WA GET LENGTH ! 10486: CTB WA,SCSI$ COMPUTE SPACE NEEDED ! 10487: JSR ALOST REQUEST STATIC STORE FOR NAME ! 10488: MOV XR,-(XS) SAVE DATATYPE NAME ! 10489: MVW COPY NAME TO STATIC ! 10490: MOV (XS),XR GET NAME PTR ! 10491: ZER XL SCRUB DUD REGISTER ! 10492: JSR GTNVR LOCATE VRBLK FOR DATATYPE NAME ! 10493: ERR 078,DATA ARGUMENT HAS NULL DATATYPE NAME ! 10494: MOV XR,DATDV SAVE VRBLK POINTER FOR DATATYPE ! 10495: MOV XS,DATXS STORE STARTING STACK VALUE ! 10496: ZER WB ZERO COUNT OF FIELD NAMES ! 10497: * ! 10498: * LOOP TO SCAN FIELD NAMES AND STACK VRBLK POINTERS ! 10499: * ! 10500: SDAT2 MOV =CH$RP,WC DELIMITER ONE = RIGHT PAREN ! 10501: MOV =CH$CM,XL DELIMITER TWO = COMMA ! 10502: JSR XSCAN SCAN NEXT FIELD NAME ! 10503: BNZ WA,SDAT3 JUMP IF DELIMITER FOUND ! 10504: ERB 079,DATA ARGUMENT IS MISSING A RIGHT PAREN ! 10505: * ! 10506: * HERE AFTER SCANNING OUT ONE FIELD NAME ! 10507: * ! 10508: SDAT3 JSR GTNVR LOCATE VRBLK FOR FIELD NAME ! 10509: ERR 080,DATA ARGUMENT HAS NULL FIELD NAME ! 10510: MOV XR,-(XS) STACK VRBLK POINTER ! 10511: ICV WB INCREMENT COUNTER ! 10512: BEQ WA,=NUM02,SDAT2 LOOP BACK IF STOPPED BY COMMA ! 10513: EJC ! 10514: * ! 10515: * DATA (CONTINUED) ! 10516: * ! 10517: * NOW BUILD THE DFBLK ! 10518: * ! 10519: MOV =DFSI$,WA SET SIZE OF DFBLK STANDARD FIELDS ! 10520: ADD WB,WA ADD NUMBER OF FIELDS ! 10521: WTB WA CONVERT LENGTH TO BYTES ! 10522: MOV WB,WC PRESERVE NO. OF FIELDS ! 10523: JSR ALOST ALLOCATE SPACE FOR DFBLK ! 10524: MOV WC,WB GET NO OF FIELDS ! 10525: MOV DATXS,XT POINT TO START OF STACK ! 10526: MOV (XT),WC LOAD DATATYPE NAME ! 10527: MOV XR,(XT) SAVE DFBLK POINTER ON STACK ! 10528: MOV =B$DFC,(XR)+ STORE TYPE WORD ! 10529: MOV WB,(XR)+ STORE NUMBER OF FIELDS (FARGS) ! 10530: MOV WA,(XR)+ STORE LENGTH (DFLEN) ! 10531: SUB *PDDFS,WA COMPUTE PDBLK LENGTH (FOR DFPDL) ! 10532: MOV WA,(XR)+ STORE PDBLK LENGTH (DFPDL) ! 10533: MOV WC,(XR)+ STORE DATATYPE NAME (DFNAM) ! 10534: LCT WC,WB COPY NUMBER OF FIELDS ! 10535: * ! 10536: * LOOP TO MOVE FIELD NAME VRBLK POINTERS TO DFBLK ! 10537: * ! 10538: SDAT4 MOV -(XT),(XR)+ MOVE ONE FIELD NAME VRBLK POINTER ! 10539: BCT WC,SDAT4 LOOP TILL ALL MOVED ! 10540: * ! 10541: * NOW DEFINE THE DATATYPE FUNCTION ! 10542: * ! 10543: MOV WA,WC COPY LENGTH OF PDBLK FOR LATER LOOP ! 10544: MOV DATDV,XR POINT TO VRBLK ! 10545: MOV DATXS,XT POINT BACK ON STACK ! 10546: MOV (XT),XL LOAD DFBLK POINTER ! 10547: JSR DFFNC DEFINE FUNCTION ! 10548: EJC ! 10549: * ! 10550: * DATA (CONTINUED) ! 10551: * ! 10552: * LOOP TO BUILD FFBLKS ! 10553: * ! 10554: * ! 10555: * NOTICE THAT THE FFBLKS ARE CONSTRUCTED IN REVERSE ORDER ! 10556: * SO THAT THE REQUIRED OFFSETS CAN BE OBTAINED FROM ! 10557: * SUCCESSIVE DECREMENTATION OF THE PDBLK LENGTH (IN WC). ! 10558: * ! 10559: SDAT5 MOV *FFSI$,WA SET LENGTH OF FFBLK ! 10560: JSR ALLOC ALLOCATE SPACE FOR FFBLK ! 10561: MOV =B$FFC,(XR) SET TYPE WORD ! 10562: MOV =NUM01,FARGS(XR) STORE FARGS (ALWAYS ONE) ! 10563: MOV DATXS,XT POINT BACK ON STACK ! 10564: MOV (XT),FFDFP(XR) COPY DFBLK PTR TO FFBLK ! 10565: DCA WC DECREMENT OLD DFPDL TO GET NEXT OFS ! 10566: MOV WC,FFOFS(XR) SET OFFSET TO THIS FIELD ! 10567: ZER FFNXT(XR) TENTATIVELY SET ZERO FORWARD PTR ! 10568: MOV XR,XL COPY FFBLK POINTER FOR DFFNC ! 10569: MOV (XS),XR LOAD VRBLK POINTER FOR FIELD ! 10570: MOV VRFNC(XR),XR LOAD CURRENT FUNCTION POINTER ! 10571: BNE (XR),=B$FFC,SDAT6 SKIP IF NOT CURRENTLY A FIELD FUNC ! 10572: * ! 10573: * HERE WE MUST CHAIN AN OLD FFBLK PTR TO PRESERVE IT IN THE ! 10574: * CASE OF MULTIPLE FIELD FUNCTIONS WITH THE SAME NAME ! 10575: * ! 10576: MOV XR,FFNXT(XL) LINK NEW FFBLK TO PREVIOUS CHAIN ! 10577: * ! 10578: * MERGE HERE TO DEFINE FIELD FUNCTION ! 10579: * ! 10580: SDAT6 MOV (XS)+,XR LOAD VRBLK POINTER ! 10581: JSR DFFNC DEFINE FIELD FUNCTION ! 10582: BNE XS,DATXS,SDAT5 LOOP BACK TILL ALL DONE ! 10583: ICA XS POP DFBLK POINTER ! 10584: BRN EXNUL RETURN WITH NULL RESULT ! 10585: EJC ! 10586: * ! 10587: * DATATYPE ! 10588: * ! 10589: S$DTP ENT ENTRY POINT ! 10590: MOV (XS)+,XR LOAD ARGUMENT ! 10591: JSR DTYPE GET DATATYPE ! 10592: BRN EXIXR AND RETURN IT AS RESULT ! 10593: EJC ! 10594: * ! 10595: * DATE ! 10596: * ! 10597: S$DTE ENT ENTRY POINT ! 10598: JSR SYSDT CALL SYSTEM DATE ROUTINE ! 10599: MOV 1(XL),WA LOAD LENGTH FOR SBSTR ! 10600: BZE WA,EXNUL RETURN NULL IF LENGTH IS ZERO ! 10601: ZER WB SET ZERO OFFSET ! 10602: JSR SBSTR USE SBSTR TO BUILD SCBLK ! 10603: BRN EXIXR RETURN DATE STRING ! 10604: EJC ! 10605: * ! 10606: * DEFINE ! 10607: * ! 10608: S$DEF ENT ENTRY POINT ! 10609: MOV (XS)+,XR LOAD SECOND ARGUMENT ! 10610: ZER DEFLB ZERO LABEL POINTER IN CASE NULL ! 10611: BEQ XR,=NULLS,SDF01 JUMP IF NULL SECOND ARGUMENT ! 10612: JSR GTNVR ELSE FIND VRBLK FOR LABEL ! 10613: PPM SDF13 JUMP IF NOT A VARIABLE NAME ! 10614: MOV XR,DEFLB ELSE SET SPECIFIED ENTRY ! 10615: * ! 10616: * SCAN FUNCTION NAME ! 10617: * ! 10618: SDF01 JSR XSCNI PREPARE TO SCAN FIRST ARGUMENT ! 10619: ERR 081,DEFINE FIRST ARGUMENT IS NOT STRING ! 10620: ERR 082,DEFINE FIRST ARGUMENT IS NULL ! 10621: MOV =CH$PP,WC DELIMITER ONE = LEFT PAREN ! 10622: MOV WC,XL DELIMITER TWO = LEFT PAREN ! 10623: JSR XSCAN SCAN OUT FUNCTION NAME ! 10624: BNZ WA,SDF02 JUMP IF LEFT PAREN FOUND ! 10625: ERB 083,DEFINE FIRST ARGUMENT IS MISSING A LEFT PAREN ! 10626: * ! 10627: * HERE AFTER SCANNING OUT FUNCTION NAME ! 10628: * ! 10629: SDF02 JSR GTNVR GET VARIABLE NAME ! 10630: ERR 084,DEFINE FIRST ARGUMENT HAS NULL FUNCTION NAME ! 10631: MOV XR,DEFVR SAVE VRBLK POINTER FOR FUNCTION NAM ! 10632: ZER WB ZERO COUNT OF ARGUMENTS ! 10633: MOV XS,DEFXS SAVE INITIAL STACK POINTER ! 10634: BNZ DEFLB,SDF03 JUMP IF SECOND ARGUMENT GIVEN ! 10635: MOV XR,DEFLB ELSE DEFAULT IS FUNCTION NAME ! 10636: * ! 10637: * LOOP TO SCAN ARGUMENT NAMES AND STACK VRBLK POINTERS ! 10638: * ! 10639: SDF03 MOV =CH$RP,WC DELIMITER ONE = RIGHT PAREN ! 10640: MOV =CH$CM,XL DELIMITER TWO = COMMA ! 10641: JSR XSCAN SCAN OUT NEXT ARGUMENT NAME ! 10642: BNZ WA,SDF04 SKIP IF DELIMITER FOUND ! 10643: ERB 085,NULL ARG NAME OR MISSING ) IN DEFINE FIRST ARG. ! 10644: EJC ! 10645: * ! 10646: * DEFINE (CONTINUED) ! 10647: * ! 10648: * HERE AFTER SCANNING AN ARGUMENT NAME ! 10649: * ! 10650: SDF04 BNE XR,=NULLS,SDF05 SKIP IF NON-NULL ! 10651: BZE WB,SDF06 IGNORE NULL IF CASE OF NO ARGUMENTS ! 10652: * ! 10653: * HERE AFTER DEALING WITH THE CASE OF NO ARGUMENTS ! 10654: * ! 10655: SDF05 JSR GTNVR GET VRBLK POINTER ! 10656: PPM SDF03 LOOP BACK TO IGNORE NULL NAME ! 10657: MOV XR,-(XS) STACK ARGUMENT VRBLK POINTER ! 10658: ICV WB INCREMENT COUNTER ! 10659: BEQ WA,=NUM02,SDF03 LOOP BACK IF STOPPED BY A COMMA ! 10660: * ! 10661: * HERE AFTER SCANNING OUT FUNCTION ARGUMENT NAMES ! 10662: * ! 10663: SDF06 MOV WB,DEFNA SAVE NUMBER OF ARGUMENTS ! 10664: ZER WB ZERO COUNT OF LOCALS ! 10665: * ! 10666: * LOOP TO SCAN LOCAL NAMES AND STACK VRBLK POINTERS ! 10667: * ! 10668: SDF07 MOV =CH$CM,WC SET DELIMITER ONE = COMMA ! 10669: MOV WC,XL SET DELIMITER TWO = COMMA ! 10670: JSR XSCAN SCAN OUT NEXT LOCAL NAME ! 10671: BNE XR,=NULLS,SDF08 SKIP IF NON-NULL ! 10672: BZE WB,SDF09 IGNORE NULL IF CASE OF NO LOCALS ! 10673: * ! 10674: * HERE AFTER SCANNING OUT A LOCAL NAME ! 10675: * ! 10676: SDF08 JSR GTNVR GET VRBLK POINTER ! 10677: PPM SDF07 LOOP BACK TO IGNORE NULL NAME ! 10678: ICV WB IF OK, INCREMENT COUNT ! 10679: MOV XR,-(XS) STACK VRBLK POINTER ! 10680: BNZ WA,SDF07 LOOP BACK IF STOPPED BY A COMMA ! 10681: EJC ! 10682: * ! 10683: * DEFINE (CONTINUED) ! 10684: * ! 10685: * HERE AFTER SCANNING LOCALS, BUILD PFBLK ! 10686: * ! 10687: SDF09 MOV WB,WA COPY COUNT OF LOCALS ! 10688: ADD DEFNA,WA ADD NUMBER OF ARGUMENTS ! 10689: MOV WA,WC SET SUM ARGS+LOCALS AS LOOP COUNT ! 10690: ADD =PFSI$,WA ADD SPACE FOR STANDARD FIELDS ! 10691: WTB WA CONVERT LENGTH TO BYTES ! 10692: JSR ALLOC ALLOCATE SPACE FOR PFBLK ! 10693: MOV XR,XL SAVE POINTER TO PFBLK ! 10694: MOV =B$PFC,(XR)+ STORE FIRST WORD ! 10695: MOV DEFNA,(XR)+ STORE NUMBER OF ARGUMENTS ! 10696: MOV WA,(XR)+ STORE LENGTH (PFLEN) ! 10697: MOV DEFVR,(XR)+ STORE VRBLK PTR FOR FUNCTION NAME ! 10698: MOV WB,(XR)+ STORE NUMBER OF LOCALS ! 10699: ZER (XR)+ DEAL WITH LABEL LATER ! 10700: ZER (XR)+ ZERO PFCTR ! 10701: ZER (XR)+ ZERO PFRTR ! 10702: BZE WC,SDF11 SKIP IF NO ARGS OR LOCALS ! 10703: MOV XL,WA KEEP PFBLK POINTER ! 10704: MOV DEFXS,XT POINT BEFORE ARGUMENTS ! 10705: LCT WC,WC GET COUNT OF ARGS+LOCALS FOR LOOP ! 10706: * ! 10707: * LOOP TO MOVE LOCALS AND ARGS TO PFBLK ! 10708: * ! 10709: SDF10 MOV -(XT),(XR)+ STORE ONE ENTRY AND BUMP POINTERS ! 10710: BCT WC,SDF10 LOOP TILL ALL STORED ! 10711: MOV WA,XL RECOVER PFBLK POINTER ! 10712: EJC ! 10713: * ! 10714: * DEFINE (CONTINUED) ! 10715: * ! 10716: * NOW DEAL WITH LABEL ! 10717: * ! 10718: SDF11 MOV DEFXS,XS POP STACK ! 10719: MOV DEFLB,XR POINT TO VRBLK FOR LABEL ! 10720: MOV VRLBL(XR),XR LOAD LABEL POINTER ! 10721: BNE (XR),=B$TRT,SDF12 SKIP IF NOT TRAPPED ! 10722: MOV TRLBL(XR),XR ELSE POINT TO REAL LABEL ! 10723: * ! 10724: * HERE AFTER LOCATING REAL LABEL POINTER ! 10725: * ! 10726: SDF12 BEQ XR,=STNDL,SDF13 JUMP IF LABEL IS NOT DEFINED ! 10727: MOV XR,PFCOD(XL) ELSE STORE LABEL POINTER ! 10728: MOV DEFVR,XR POINT BACK TO VRBLK FOR FUNCTION ! 10729: JSR DFFNC DEFINE FUNCTION ! 10730: BRN EXNUL AND EXIT RETURNING NULL ! 10731: * ! 10732: * HERE FOR ERRONEOUS LABEL ! 10733: * ! 10734: SDF13 ERB 086,DEFINE FUNCTION ENTRY POINT IS NOT DEFINED LABEL ! 10735: EJC ! 10736: * ! 10737: * DETACH ! 10738: * ! 10739: S$DET ENT ENTRY POINT ! 10740: MOV (XS)+,XR LOAD ARGUMENT ! 10741: JSR GTVAR LOCATE VARIABLE ! 10742: ERR 087,DETACH ARGUMENT IS NOT APPROPRIATE NAME ! 10743: JSR DTACH DETACH I/O ASSOCIATION FROM NAME ! 10744: BRN EXNUL RETURN NULL RESULT ! 10745: EJC ! 10746: * ! 10747: * DIFFER ! 10748: * ! 10749: S$DIF ENT ENTRY POINT ! 10750: MOV (XS)+,XR LOAD SECOND ARGUMENT ! 10751: MOV (XS)+,XL LOAD FIRST ARGUMENT ! 10752: JSR IDENT CALL IDENT COMPARISON ROUTINE ! 10753: PPM EXFAL FAIL IF IDENT ! 10754: BRN EXNUL RETURN NULL IF DIFFER ! 10755: EJC ! 10756: * ! 10757: * DUMP ! 10758: * ! 10759: S$DMP ENT ENTRY POINT ! 10760: JSR GTSMI LOAD DUMP ARG AS SMALL INTEGER ! 10761: ERR 088,DUMP ARGUMENT IS NOT INTEGER ! 10762: ERR 089,DUMP ARGUMENT IS NEGATIVE OR TOO LARGE ! 10763: JSR DUMPR ELSE CALL DUMP ROUTINE ! 10764: BRN EXNUL AND RETURN NULL AS RESULT ! 10765: EJC ! 10766: * ! 10767: * DUPL ! 10768: * ! 10769: S$DUP ENT ENTRY POINT ! 10770: JSR GTSMI GET SECOND ARGUMENT AS SMALL INTEGE ! 10771: ERR 090,DUPL SECOND ARGUMENT IS NOT INTEGER ! 10772: PPM SDUP7 JUMP IF NEGATIVE OT TOO BIG ! 10773: MOV XR,WB SAVE DUPLICATION FACTOR ! 10774: JSR GTSTG GET FIRST ARG AS STRING ! 10775: PPM SDUP4 JUMP IF NOT A STRING ! 10776: * ! 10777: * HERE FOR CASE OF DUPLICATION OF A STRING ! 10778: * ! 10779: MTI WA ACQUIRE LENGTH AS INTEGER ! 10780: STI DUPSI SAVE FOR THE MOMENT ! 10781: MTI WB GET DUPLICATION FACTOR AS INTEGER ! 10782: MLI DUPSI FORM PRODUCT ! 10783: IOV SDUP3 JUMP IF OVERFLOW ! 10784: IEQ EXNUL RETURN NULL IF RESULT LENGTH = 0 ! 10785: MFI WA,SDUP3 GET AS ADDR INTEGER, CHECK OVFLO ! 10786: * ! 10787: * MERGE HERE WITH RESULT LENGTH IN WA ! 10788: * ! 10789: SDUP1 MOV XR,XL SAVE STRING POINTER ! 10790: JSR ALOCS ALLOCATE SPACE FOR STRING ! 10791: MOV XR,-(XS) SAVE AS RESULT POINTER ! 10792: MOV XL,WC SAVE POINTER TO ARGUMENT STRING ! 10793: PSC XR PREPARE TO STORE CHARS OF RESULT ! 10794: LCT WB,WB SET COUNTER TO CONTROL LOOP ! 10795: * ! 10796: * LOOP THROUGH DUPLICATIONS ! 10797: * ! 10798: SDUP2 MOV WC,XL POINT BACK TO ARGUMENT STRING ! 10799: MOV SCLEN(XL),WA GET NUMBER OF CHARACTERS ! 10800: PLC XL POINT TO CHARS IN ARGUMENT STRING ! 10801: MVC MOVE CHARACTERS TO RESULT STRING ! 10802: BCT WB,SDUP2 LOOP TILL ALL DUPLICATIONS DONE ! 10803: BRN EXITS THEN EXIT FOR NEXT CODE WORD ! 10804: EJC ! 10805: * ! 10806: * DUPL (CONTINUED) ! 10807: * ! 10808: * HERE IF TOO LARGE, SET MAX LENGTH AND LET ALOCS CATCH IT ! 10809: * ! 10810: SDUP3 MOV DNAME,WA SET IMPOSSIBLE LENGTH FOR ALOCS ! 10811: BRN SDUP1 MERGE BACK ! 10812: * ! 10813: * HERE IF NOT A STRING ! 10814: * ! 10815: SDUP4 JSR GTPAT CONVERT ARGUMENT TO PATTERN ! 10816: ERR 091,DUPL FIRST ARGUMENT IS NOT STRING OR PATTERN ! 10817: * ! 10818: * HERE TO DUPLICATE A PATTERN ARGUMENT ! 10819: * ! 10820: MOV XR,-(XS) STORE PATTERN ON STACK ! 10821: MOV =NDNTH,XR START OFF WITH NULL PATTERN ! 10822: BZE WB,SDUP6 NULL PATTERN IS RESULT IF DUPFAC=0 ! 10823: MOV WB,-(XS) PRESERVE LOOP COUNT ! 10824: * ! 10825: * LOOP TO DUPLICATE BY SUCCESSIVE CONCATENATION ! 10826: * ! 10827: SDUP5 MOV XR,XL COPY CURRENT VALUE AS RIGHT ARGUMNT ! 10828: MOV 1(XS),XR GET A NEW COPY OF LEFT ! 10829: JSR PCONC CONCATENATE ! 10830: DCV (XS) COUNT DOWN ! 10831: BNZ (XS),SDUP5 LOOP ! 10832: ICA XS POP LOOP COUNT ! 10833: * ! 10834: * HERE TO EXIT AFTER CONSTRUCTING PATTERN ! 10835: * ! 10836: SDUP6 MOV XR,(XS) STORE RESULT ON STACK ! 10837: BRN EXITS EXIT WITH RESULT ON STACK ! 10838: * ! 10839: * FAIL IF SECOND ARG IS OUT OF RANGE ! 10840: * ! 10841: SDUP7 ICA XS POP FIRST ARGUMENT ! 10842: BRN EXFAL FAIL ! 10843: EJC ! 10844: * ! 10845: * EJECT ! 10846: * ! 10847: S$EJC ENT ENTRY POINT ! 10848: JSR IOFCB CALL FCBLK ROUTINE ! 10849: ERR 092,EJECT ARGUMENT IS NOT A SUITABLE NAME ! 10850: PPM SEJC1 NULL ARGUMENT ! 10851: JSR SYSEF CALL EJECT FILE FUNCTION ! 10852: ERR 093,EJECT FILE DOES NOT EXIST ! 10853: ERR 094,EJECT FILE DOES NOT PERMIT PAGE EJECT ! 10854: ERR 095,EJECT CAUSED NON-RECOVERABLE OUTPUT ERROR ! 10855: BRN EXNUL RETURN NULL AS RESULT ! 10856: * ! 10857: * HERE TO EJECT STANDARD OUTPUT FILE ! 10858: * ! 10859: SEJC1 JSR SYSEP CALL ROUTINE TO EJECT PRINTER ! 10860: BRN EXNUL EXIT WITH NULL RESULT ! 10861: EJC ! 10862: * ! 10863: * ENDFILE ! 10864: * ! 10865: S$ENF ENT ENTRY POINT ! 10866: JSR IOFCB CALL FCBLK ROUTINE ! 10867: ERR 096,ENDFILE ARGUMENT IS NOT A SUITABLE NAME ! 10868: ERR 097,ENDFILE ARGUMENT IS NULL ! 10869: JSR SYSEN CALL ENDFILE ROUTINE ! 10870: ERR 098,ENDFILE FILE DOES NOT EXIST ! 10871: ERR 099,ENDFILE FILE DOES NOT PERMIT ENDFILE ! 10872: ERR 100,ENDFILE CAUSED NON-RECOVERABLE OUTPUT ERROR ! 10873: MOV XL,WB REMEMBER VRBLK PTR FROM IOFCB CALL ! 10874: * ! 10875: * LOOP TO FIND TRTRF BLOCK ! 10876: * ! 10877: SENF1 MOV XL,XR COPY POINTER ! 10878: MOV TRVAL(XR),XR CHAIN ALONG ! 10879: BNE (XR),=B$TRT,EXNUL SKIP OUT IF CHAIN END ! 10880: BNE TRTYP(XR),=TRTFC,SENF1 LOOP IF NOT FOUND ! 10881: MOV TRVAL(XR),TRVAL(XL) REMOVE TRTRF ! 10882: MOV TRTRF(XR),ENFCH POINT TO HEAD OF IOCHN ! 10883: MOV TRFPT(XR),WC POINT TO FCBLK ! 10884: MOV WB,XR FILEARG1 VRBLK FROM IOFCB ! 10885: JSR SETVR RESET IT ! 10886: MOV =R$FCB,XL PTR TO HEAD OF FCBLK CHAIN ! 10887: SUB *NUM02,XL ADJUST READY TO ENTER LOOP ! 10888: * ! 10889: * FIND FCBLK ! 10890: * ! 10891: SENF2 MOV XL,XR COPY PTR ! 10892: MOV 2(XL),XL GET NEXT LINK ! 10893: BZE XL,SENF4 STOP IF CHAIN END ! 10894: BEQ 3(XL),WC,SENF3 JUMP IF FCBLK FOUND ! 10895: BRN SENF2 LOOP ! 10896: * ! 10897: * REMOVE FCBLK ! 10898: * ! 10899: SENF3 MOV 2(XL),2(XR) DELETE FCBLK FROM CHAIN ! 10900: * ! 10901: * LOOP WHICH DETACHES ALL VBLS ON IOCHN CHAIN ! 10902: * ! 10903: SENF4 MOV ENFCH,XL GET CHAIN HEAD ! 10904: BZE XL,EXNUL FINISHED IF CHAIN END ! 10905: MOV TRTRF(XL),ENFCH CHAIN ALONG ! 10906: MOV IONMO(XL),WA NAME OFFSET ! 10907: MOV IONMB(XL),XL NAME BASE ! 10908: JSR DTACH DETACH NAME ! 10909: BRN SENF4 LOOP TILL DONE ! 10910: EJC ! 10911: * ! 10912: * EQ ! 10913: * ! 10914: S$EQF ENT ENTRY POINT ! 10915: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE ! 10916: ERR 101,EQ FIRST ARGUMENT IS NOT NUMERIC ! 10917: ERR 102,EQ SECOND ARGUMENT IS NOT NUMERIC ! 10918: PPM EXFAL FAIL IF LT ! 10919: PPM EXNUL RETURN NULL IF EQ ! 10920: PPM EXFAL FAIL IF GT ! 10921: EJC ! 10922: * ! 10923: * EVAL ! 10924: * ! 10925: S$EVL ENT ENTRY POINT ! 10926: MOV (XS)+,XR LOAD ARGUMENT ! 10927: JSR GTEXP CONVERT TO EXPRESSION ! 10928: ERR 103,EVAL ARGUMENT IS NOT EXPRESSION ! 10929: LCW WC LOAD NEXT CODE WORD ! 10930: BNE WC,=OFNE$,SEVL1 JUMP IF CALLED BY VALUE ! 10931: SCP XL COPY CODE POINTER ! 10932: MOV (XL),WA GET NEXT CODE WORD ! 10933: BNE WA,=ORNM$,SEVL2 BY NAME UNLESS EXPRESSION ! 10934: BNZ 1(XS),SEVL2 JUMP IF BY NAME ! 10935: * ! 10936: * HERE IF CALLED BY VALUE ! 10937: * ! 10938: SEVL1 ZER WB SET FLAG FOR BY VALUE ! 10939: MOV WC,-(XS) SAVE CODE WORD ! 10940: JSR EVALX EVALUATE EXPRESSION BY VALUE ! 10941: PPM EXFAL FAIL IF EVALUATION FAILS ! 10942: MOV XR,XL COPY RESULT ! 10943: MOV (XS),XR RELOAD NEXT CODE WORD ! 10944: MOV XL,(XS) STACK RESULT ! 10945: BRI (XR) JUMP TO EXECUTE NEXT CODE WORD ! 10946: * ! 10947: * HERE IF CALLED BY NAME ! 10948: * ! 10949: SEVL2 MOV =NUM01,WB SET FLAG FOR BY NAME ! 10950: JSR EVALX EVALUATE EXPRESSION BY NAME ! 10951: PPM EXFAL FAIL IF EVALUATION FAILS ! 10952: BRN EXNAM EXIT WITH NAME ! 10953: .IF .CNEX ! 10954: .ELSE ! 10955: EJC ! 10956: * ! 10957: * EXIT ! 10958: * ! 10959: S$EXT ENT ENTRY POINT ! 10960: ZER WB CLEAR AMOUNT OF STATIC SHIFT ! 10961: JSR GBCOL COMPACT MEMORY BY COLLECTING ! 10962: JSR GTSTG CONVERT ARG TO STRING ! 10963: ERR 104,EXIT ARGUMENT IS NOT SUITABLE INTEGER OR STRING ! 10964: MOV XR,XL COPY STRING PTR ! 10965: JSR GTINT CHECK IT IS INTEGER ! 10966: PPM SEXT1 SKIP IF UNCONVERTIBLE ! 10967: ZER XL NOTE IT IS INTEGER ! 10968: LDI ICVAL(XR) GET INTEGER ARG ! 10969: MOV R$FCB,WB GET FCBLK CHAIN HEADER ! 10970: * ! 10971: * MERGE TO CALL OSINT EXIT ROUTINE ! 10972: * ! 10973: SEXT1 MOV =HEADV,XR POINT TO V.V STRING ! 10974: JSR SYSXI CALL EXTERNAL ROUTINE ! 10975: ERR 105,EXIT ACTION NOT AVAILABLE IN THIS IMPLEMENTATION ! 10976: ERR 106,EXIT ACTION CAUSED IRRECOVERABLE ERROR ! 10977: IEQ EXNUL RETURN IF ARGUMENT 0 ! 10978: ZER GBCNT RESUMING EXECUTION SO RESET ! 10979: IGT SEXT2 SKIP IF POSITIVE ! 10980: NGI MAKE POSITIVE ! 10981: * ! 10982: * CHECK FOR OPTION RESPECIFICATION ! 10983: * ! 10984: SEXT2 MFI WC GET VALUE IN WORK REG ! 10985: BEQ WC,=NUM03,SEXT3 SKIP IF WAS 3 ! 10986: MOV WC,-(XS) SAVE VALUE ! 10987: ZER WC SET TO READ OPTIONS ! 10988: JSR PRPAR READ SYSPP OPTIONS ! 10989: MOV (XS)+,WC RESTORE VALUE ! 10990: * ! 10991: * DEAL WITH HEADER OPTION (FIDDLED BY PRPAR) ! 10992: * ! 10993: SEXT3 MNZ HEADP ASSUME NO HEADERS ! 10994: BNE WC,=NUM01,SEXT4 SKIP IF NOT 1 ! 10995: ZER HEADP REQUEST HEADER PRINTING ! 10996: * ! 10997: * ALMOST READY TO RESUME RUNNING ! 10998: * ! 10999: SEXT4 JSR SYSTM GET EXECUTION TIME START (SGD11) ! 11000: STI TIMSX SAVE AS INITIAL TIME ! 11001: LDI KVSTC RESET TO ENSURE ... ! 11002: STI KVSTL ... CORRECT EXECUTION STATS ! 11003: BRN EXNUL RESUME EXECUTION ! 11004: .FI ! 11005: EJC ! 11006: * ! 11007: * FIELD ! 11008: * ! 11009: S$FLD ENT ENTRY POINT ! 11010: JSR GTSMI GET SECOND ARGUMENT (FIELD NUMBER) ! 11011: ERR 107,FIELD SECOND ARGUMENT IS NOT INTEGER ! 11012: PPM EXFAL FAIL IF OUT OF RANGE ! 11013: MOV XR,WB ELSE SAVE INTEGER VALUE ! 11014: MOV (XS)+,XR LOAD FIRST ARGUMENT ! 11015: JSR GTNVR POINT TO VRBLK ! 11016: PPM SFLD1 JUMP (ERROR) IF NOT VARIABLE NAME ! 11017: MOV VRFNC(XR),XR ELSE POINT TO FUNCTION BLOCK ! 11018: BNE (XR),=B$DFC,SFLD1 ERROR IF NOT DATATYPE FUNCTION ! 11019: * ! 11020: * HERE IF FIRST ARGUMENT IS A DATATYPE FUNCTION NAME ! 11021: * ! 11022: BZE WB,EXFAL FAIL IF ARGUMENT NUMBER IS ZERO ! 11023: BGT WB,FARGS(XR),EXFAL FAIL IF TOO LARGE ! 11024: WTB WB ELSE CONVERT TO BYTE OFFSET ! 11025: ADD WB,XR POINT TO FIELD NAME ! 11026: MOV DFFLB(XR),XR LOAD VRBLK POINTER ! 11027: BRN EXVNM EXIT TO BUILD NMBLK ! 11028: * ! 11029: * HERE FOR BAD FIRST ARGUMENT ! 11030: * ! 11031: SFLD1 ERB 108,FIELD FIRST ARGUMENT IS NOT DATATYPE NAME ! 11032: EJC ! 11033: * ! 11034: * FENCE ! 11035: * ! 11036: S$FNC ENT ENTRY POINT ! 11037: MOV =P$FNC,WB SET PCODE FOR P$FNC ! 11038: ZER XR P0BLK ! 11039: JSR PBILD BUILD P$FNC NODE ! 11040: MOV XR,XL SAVE POINTER TO IT ! 11041: MOV (XS)+,XR GET ARGUMENT ! 11042: JSR GTPAT CONVERT TO PATTERN ! 11043: ERR 259,FENCE ARGUMENT IS NOT PATTERN ! 11044: JSR PCONC CONCATENATE TO P$FNC NODE ! 11045: MOV XR,XL SAVE PTR TO CONCATENATED PATTERN ! 11046: MOV =P$FNA,WB SET FOR P$FNA PCODE ! 11047: ZER XR P0BLK ! 11048: JSR PBILD CONSTRUCT P$FNA NODE ! 11049: MOV XL,PTHEN(XR) SET PATTERN AS PTHEN ! 11050: MOV XR,-(XS) SET AS RESULT ! 11051: BRN EXITS DO NEXT CODE WORD ! 11052: EJC ! 11053: * ! 11054: * GE ! 11055: * ! 11056: S$GEF ENT ENTRY POINT ! 11057: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE ! 11058: ERR 109,GE FIRST ARGUMENT IS NOT NUMERIC ! 11059: ERR 110,GE SECOND ARGUMENT IS NOT NUMERIC ! 11060: PPM EXFAL FAIL IF LT ! 11061: PPM EXNUL RETURN NULL IF EQ ! 11062: PPM EXNUL RETURN NULL IF GT ! 11063: EJC ! 11064: * ! 11065: * GT ! 11066: * ! 11067: S$GTF ENT ENTRY POINT ! 11068: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE ! 11069: ERR 111,GT FIRST ARGUMENT IS NOT NUMERIC ! 11070: ERR 112,GT SECOND ARGUMENT IS NOT NUMERIC ! 11071: PPM EXFAL FAIL IF LT ! 11072: PPM EXFAL FAIL IF EQ ! 11073: PPM EXNUL RETURN NULL IF GT ! 11074: EJC ! 11075: * ! 11076: * HOST ! 11077: * ! 11078: S$HST ENT ENTRY POINT ! 11079: MOV (XS)+,XR GET THIRD ARG ! 11080: MOV (XS)+,XL GET SECOND ARG ! 11081: MOV (XS)+,WA GET FIRST ARG ! 11082: JSR SYSHS ENTER SYSHS ROUTINE ! 11083: ERR 254,ERRONEOUS ARGUMENT FOR HOST ! 11084: ERR 255,ERROR DURING EXECUTION OF HOST ! 11085: PPM SHST1 STORE HOST STRING ! 11086: PPM EXNUL RETURN NULL RESULT ! 11087: PPM EXIXR RETURN XR ! 11088: PPM EXFAL FAIL RETURN ! 11089: * ! 11090: * RETURN HOST STRING ! 11091: * ! 11092: SHST1 BZE XL,EXNUL NULL STRING IF SYSHS UNCOOPERATIVE ! 11093: MOV SCLEN(XL),WA LENGTH ! 11094: ZER WB ZERO OFFSET ! 11095: JSR SBSTR BUILD COPY OF STRING ! 11096: MOV XR,-(XS) STACK THE RESULT ! 11097: BRN EXITS RETURN RESULT ON STACK ! 11098: EJC ! 11099: * ! 11100: * IDENT ! 11101: * ! 11102: S$IDN ENT ENTRY POINT ! 11103: MOV (XS)+,XR LOAD SECOND ARGUMENT ! 11104: MOV (XS)+,XL LOAD FIRST ARGUMENT ! 11105: JSR IDENT CALL IDENT COMPARISON ROUTINE ! 11106: PPM EXNUL RETURN NULL IF IDENT ! 11107: BRN EXFAL FAIL IF DIFFER ! 11108: EJC ! 11109: * ! 11110: * INPUT ! 11111: * ! 11112: S$INP ENT ENTRY POINT ! 11113: ZER WB INPUT FLAG ! 11114: JSR IOPUT CALL INPUT/OUTPUT ASSOC. ROUTINE ! 11115: ERR 113,INPUT THIRD ARGUMENT IS NOT A STRING ! 11116: ERR 114,INAPPROPRIATE SECOND ARGUMENT FOR INPUT ! 11117: ERR 115,INAPPROPRIATE FIRST ARGUMENT FOR INPUT ! 11118: ERR 116,INAPPROPRIATE FILE SPECIFICATION FOR INPUT ! 11119: PPM EXFAL FAIL IF FILE DOES NOT EXIST ! 11120: ERR 117,INPUT FILE CANNOT BE READ ! 11121: BRN EXNUL RETURN NULL STRING ! 11122: EJC ! 11123: .IF .CNBF ! 11124: .ELSE ! 11125: * ! 11126: * INSERT ! 11127: * ! 11128: S$INS ENT ENTRY POINT ! 11129: MOV (XS)+,XL GET STRING ARG ! 11130: JSR GTSMI GET REPLACE LENGTH ! 11131: ERR 277,INSERT THIRD ARGUMENT NOT INTEGER ! 11132: PPM EXFAL FAIL IF OUT OF RANGE ! 11133: MOV WC,WB COPY TO PROPER REG ! 11134: JSR GTSMI GET REPLACE POSITION ! 11135: ERR 278,INSERT SECOND ARGUMENT NOT INTEGER ! 11136: PPM EXFAL FAIL IF OUT OF RANGE ! 11137: BZE WC,EXFAL FAIL IF ZERO ! 11138: DCV WC DECREMENT TO GET OFFSET ! 11139: MOV WC,WA PUT IN PROPER REGISTER ! 11140: MOV (XS)+,XR GET BUFFER ! 11141: BEQ (XR),=B$BCT,SINS1 PRESS ON IF TYPE OK ! 11142: ERB 279,INSERT FIRST ARGUMENT NOT BUFFER ! 11143: * ! 11144: * HERE WHEN EVERYTHING LOADED UP ! 11145: * ! 11146: SINS1 JSR INSBF CALL TO INSERT ! 11147: ERR 280,INSERT FOURTH ARGUMENT NOT A STRING ! 11148: PPM EXFAL FAIL IF OUT OF RANGE ! 11149: BRN EXNUL ELSE OK - EXIT WITH NULL ! 11150: EJC ! 11151: .FI ! 11152: * ! 11153: * INTEGER ! 11154: * ! 11155: S$INT ENT ENTRY POINT ! 11156: MOV (XS)+,XR LOAD ARGUMENT ! 11157: JSR GTNUM CONVERT TO NUMERIC ! 11158: PPM EXFAL FAIL IF NON-NUMERIC ! 11159: BEQ WA,=B$ICL,EXNUL RETURN NULL IF INTEGER ! 11160: BRN EXFAL FAIL IF REAL ! 11161: EJC ! 11162: * ! 11163: * ITEM ! 11164: * ! 11165: * ITEM DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT ! 11166: * WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED. ! 11167: * ! 11168: S$ITM ENT ENTRY POINT ! 11169: * ! 11170: * DEAL WITH CASE OF NO ARGS ! 11171: * ! 11172: BNZ WA,SITM1 JUMP IF AT LEAST ONE ARG ! 11173: MOV =NULLS,-(XS) ELSE SUPPLY GARBAGE NULL ARG ! 11174: MOV =NUM01,WA AND FIX ARGUMENT COUNT ! 11175: * ! 11176: * CHECK FOR NAME/VALUE CASES ! 11177: * ! 11178: SITM1 SCP XR GET CURRENT CODE POINTER ! 11179: MOV (XR),XL LOAD NEXT CODE WORD ! 11180: DCV WA GET NUMBER OF SUBSCRIPTS ! 11181: MOV WA,XR COPY FOR ARREF ! 11182: BEQ XL,=OFNE$,SITM2 JUMP IF CALLED BY NAME ! 11183: * ! 11184: * HERE IF CALLED BY VALUE ! 11185: * ! 11186: ZER WB SET CODE FOR CALL BY VALUE ! 11187: BRN ARREF OFF TO ARRAY REFERENCE ROUTINE ! 11188: * ! 11189: * HERE FOR CALL BY NAME ! 11190: * ! 11191: SITM2 MNZ WB SET CODE FOR CALL BY NAME ! 11192: LCW WA LOAD AND IGNORE OFNE$ CALL ! 11193: BRN ARREF OFF TO ARRAY REFERENCE ROUTINE ! 11194: EJC ! 11195: * ! 11196: * LE ! 11197: * ! 11198: S$LEF ENT ENTRY POINT ! 11199: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE ! 11200: ERR 118,LE FIRST ARGUMENT IS NOT NUMERIC ! 11201: ERR 119,LE SECOND ARGUMENT IS NOT NUMERIC ! 11202: PPM EXNUL RETURN NULL IF LT ! 11203: PPM EXNUL RETURN NULL IF EQ ! 11204: PPM EXFAL FAIL IF GT ! 11205: EJC ! 11206: * ! 11207: * LEN ! 11208: * ! 11209: S$LEN ENT ENTRY POINT ! 11210: MOV =P$LEN,WB SET PCODE FOR INTEGER ARG CASE ! 11211: MOV =P$LND,WA SET PCODE FOR EXPR ARG CASE ! 11212: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE ! 11213: ERR 120,LEN ARGUMENT IS NOT INTEGER OR EXPRESSION ! 11214: ERR 121,LEN ARGUMENT IS NEGATIVE OR TOO LARGE ! 11215: BRN EXIXR RETURN PATTERN NODE ! 11216: EJC ! 11217: * ! 11218: * LEQ ! 11219: * ! 11220: S$LEQ ENT ENTRY POINT ! 11221: JSR LCOMP CALL STRING COMPARISON ROUTINE ! 11222: ERR 122,LEQ FIRST ARGUMENT IS NOT STRING ! 11223: ERR 123,LEQ SECOND ARGUMENT IS NOT STRING ! 11224: PPM EXFAL FAIL IF LLT ! 11225: PPM EXNUL RETURN NULL IF LEQ ! 11226: PPM EXFAL FAIL IF LGT ! 11227: EJC ! 11228: * ! 11229: * LGE ! 11230: * ! 11231: S$LGE ENT ENTRY POINT ! 11232: JSR LCOMP CALL STRING COMPARISON ROUTINE ! 11233: ERR 124,LGE FIRST ARGUMENT IS NOT STRING ! 11234: ERR 125,LGE SECOND ARGUMENT IS NOT STRING ! 11235: PPM EXFAL FAIL IF LLT ! 11236: PPM EXNUL RETURN NULL IF LEQ ! 11237: PPM EXNUL RETURN NULL IF LGT ! 11238: EJC ! 11239: * ! 11240: * LGT ! 11241: * ! 11242: S$LGT ENT ENTRY POINT ! 11243: JSR LCOMP CALL STRING COMPARISON ROUTINE ! 11244: ERR 126,LGT FIRST ARGUMENT IS NOT STRING ! 11245: ERR 127,LGT SECOND ARGUMENT IS NOT STRING ! 11246: PPM EXFAL FAIL IF LLT ! 11247: PPM EXFAL FAIL IF LEQ ! 11248: PPM EXNUL RETURN NULL IF LGT ! 11249: EJC ! 11250: * ! 11251: * LLE ! 11252: * ! 11253: S$LLE ENT ENTRY POINT ! 11254: JSR LCOMP CALL STRING COMPARISON ROUTINE ! 11255: ERR 128,LLE FIRST ARGUMENT IS NOT STRING ! 11256: ERR 129,LLE SECOND ARGUMENT IS NOT STRING ! 11257: PPM EXNUL RETURN NULL IF LLT ! 11258: PPM EXNUL RETURN NULL IF LEQ ! 11259: PPM EXFAL FAIL IF LGT ! 11260: EJC ! 11261: * ! 11262: * LLT ! 11263: * ! 11264: S$LLT ENT ENTRY POINT ! 11265: JSR LCOMP CALL STRING COMPARISON ROUTINE ! 11266: ERR 130,LLT FIRST ARGUMENT IS NOT STRING ! 11267: ERR 131,LLT SECOND ARGUMENT IS NOT STRING ! 11268: PPM EXNUL RETURN NULL IF LLT ! 11269: PPM EXFAL FAIL IF LEQ ! 11270: PPM EXFAL FAIL IF LGT ! 11271: EJC ! 11272: * ! 11273: * LNE ! 11274: * ! 11275: S$LNE ENT ENTRY POINT ! 11276: JSR LCOMP CALL STRING COMPARISON ROUTINE ! 11277: ERR 132,LNE FIRST ARGUMENT IS NOT STRING ! 11278: ERR 133,LNE SECOND ARGUMENT IS NOT STRING ! 11279: PPM EXNUL RETURN NULL IF LLT ! 11280: PPM EXFAL FAIL IF LEQ ! 11281: PPM EXNUL RETURN NULL IF LGT ! 11282: EJC ! 11283: * ! 11284: * LOCAL ! 11285: * ! 11286: S$LOC ENT ENTRY POINT ! 11287: JSR GTSMI GET SECOND ARGUMENT (LOCAL NUMBER) ! 11288: ERR 134,LOCAL SECOND ARGUMENT IS NOT INTEGER ! 11289: PPM EXFAL FAIL IF OUT OF RANGE ! 11290: MOV XR,WB SAVE LOCAL NUMBER ! 11291: MOV (XS)+,XR LOAD FIRST ARGUMENT ! 11292: JSR GTNVR POINT TO VRBLK ! 11293: PPM SLOC1 JUMP IF NOT VARIABLE NAME ! 11294: MOV VRFNC(XR),XR ELSE LOAD FUNCTION POINTER ! 11295: BNE (XR),=B$PFC,SLOC1 JUMP IF NOT PROGRAM DEFINED ! 11296: * ! 11297: * HERE IF WE HAVE A PROGRAM DEFINED FUNCTION NAME ! 11298: * ! 11299: BZE WB,EXFAL FAIL IF SECOND ARG IS ZERO ! 11300: BGT WB,PFNLO(XR),EXFAL OR TOO LARGE ! 11301: ADD FARGS(XR),WB ELSE ADJUST OFFSET TO INCLUDE ARGS ! 11302: WTB WB CONVERT TO BYTES ! 11303: ADD WB,XR POINT TO LOCAL POINTER ! 11304: MOV PFAGB(XR),XR LOAD VRBLK POINTER ! 11305: BRN EXVNM EXIT BUILDING NMBLK ! 11306: * ! 11307: * HERE IF FIRST ARGUMENT IS NO GOOD ! 11308: * ! 11309: SLOC1 ERB 135,LOCAL FIRST ARG IS NOT A PROGRAM FUNCTION NAME ! 11310: .IF .CNLD ! 11311: .ELSE ! 11312: EJC ! 11313: * ! 11314: * LOAD ! 11315: * ! 11316: S$LOD ENT ENTRY POINT ! 11317: JSR GTSTG LOAD LIBRARY NAME ! 11318: ERR 136,LOAD SECOND ARGUMENT IS NOT STRING ! 11319: MOV XR,XL SAVE LIBRARY NAME ! 11320: JSR XSCNI PREPARE TO SCAN FIRST ARGUMENT ! 11321: ERR 137,LOAD FIRST ARGUMENT IS NOT STRING ! 11322: ERR 138,LOAD FIRST ARGUMENT IS NULL ! 11323: MOV XL,-(XS) STACK LIBRARY NAME ! 11324: MOV =CH$PP,WC SET DELIMITER ONE = LEFT PAREN ! 11325: MOV WC,XL SET DELIMITER TWO = LEFT PAREN ! 11326: JSR XSCAN SCAN FUNCTION NAME ! 11327: MOV XR,-(XS) SAVE PTR TO FUNCTION NAME ! 11328: BNZ WA,SLOD1 JUMP IF LEFT PAREN FOUND ! 11329: ERB 139,LOAD FIRST ARGUMENT IS MISSING A LEFT PAREN ! 11330: * ! 11331: * HERE AFTER SUCCESSFULLY SCANNING FUNCTION NAME ! 11332: * ! 11333: SLOD1 JSR GTNVR LOCATE VRBLK ! 11334: ERR 140,LOAD FIRST ARGUMENT HAS NULL FUNCTION NAME ! 11335: MOV XR,LODFN SAVE VRBLK POINTER ! 11336: ZER LODNA ZERO COUNT OF ARGUMENTS ! 11337: * ! 11338: * LOOP TO SCAN ARGUMENT DATATYPE NAMES ! 11339: * ! 11340: SLOD2 MOV =CH$RP,WC DELIMITER ONE IS RIGHT PAREN ! 11341: MOV =CH$CM,XL DELIMITER TWO IS COMMA ! 11342: JSR XSCAN SCAN NEXT ARGUMENT NAME ! 11343: ICV LODNA BUMP ARGUMENT COUNT ! 11344: BNZ WA,SLOD3 JUMP IF OK DELIMITER WAS FOUND ! 11345: ERB 141,LOAD FIRST ARGUMENT IS MISSING A RIGHT PAREN ! 11346: EJC ! 11347: * ! 11348: * LOAD (CONTINUED) ! 11349: * ! 11350: * COME HERE TO ANALYZE THE DATATYPE POINTER IN (XR). THIS ! 11351: * CODE IS USED BOTH FOR ARGUMENTS (WA=1,2) AND FOR THE ! 11352: * RESULT DATATYPE (WITH WA SET TO ZERO). ! 11353: * ! 11354: SLOD3 MOV XR,-(XS) STACK DATATYPE NAME POINTER ! 11355: MOV =NUM01,WB SET STRING CODE IN CASE ! 11356: MOV =SCSTR,XL POINT TO /STRING/ ! 11357: JSR IDENT CHECK FOR MATCH ! 11358: PPM SLOD4 JUMP IF MATCH ! 11359: MOV (XS),XR ELSE RELOAD NAME ! 11360: ADD WB,WB SET CODE FOR INTEGER (2) ! 11361: MOV =SCINT,XL POINT TO /INTEGER/ ! 11362: JSR IDENT CHECK FOR MATCH ! 11363: PPM SLOD4 JUMP IF MATCH ! 11364: .IF .CNRA ! 11365: .ELSE ! 11366: MOV (XS),XR ELSE RELOAD STRING POINTER ! 11367: ICV WB SET CODE FOR REAL (3) ! 11368: MOV =SCREA,XL POINT TO /REAL/ ! 11369: JSR IDENT CHECK FOR MATCH ! 11370: PPM SLOD4 JUMP IF MATCH ! 11371: .FI ! 11372: ZER WB ELSE GET CODE FOR NO CONVERT ! 11373: * ! 11374: * MERGE HERE WITH PROPER DATATYPE CODE IN WB ! 11375: * ! 11376: SLOD4 MOV WB,(XS) STORE CODE ON STACK ! 11377: BEQ WA,=NUM02,SLOD2 LOOP BACK IF ARG STOPPED BY COMMA ! 11378: BZE WA,SLOD5 JUMP IF THAT WAS THE RESULT TYPE ! 11379: * ! 11380: * HERE WE SCAN OUT THE RESULT TYPE (ARG STOPPED BY ) ) ! 11381: * ! 11382: MOV MXLEN,WC SET DUMMY (IMPOSSIBLE) DELIMITER 1 ! 11383: MOV WC,XL AND DELIMITER TWO ! 11384: JSR XSCAN SCAN RESULT NAME ! 11385: ZER WA SET CODE FOR PROCESSING RESULT ! 11386: BRN SLOD3 JUMP BACK TO PROCESS RESULT NAME ! 11387: EJC ! 11388: * ! 11389: * LOAD (CONTINUED) ! 11390: * ! 11391: * HERE AFTER PROCESSING ALL ARGS AND RESULT ! 11392: * ! 11393: SLOD5 MOV LODNA,WA GET NUMBER OF ARGUMENTS ! 11394: MOV WA,WC COPY FOR LATER ! 11395: WTB WA CONVERT LENGTH TO BYTES ! 11396: ADD *EFSI$,WA ADD SPACE FOR STANDARD FIELDS ! 11397: JSR ALLOC ALLOCATE EFBLK ! 11398: MOV =B$EFC,(XR) SET TYPE WORD ! 11399: MOV WC,FARGS(XR) SET NUMBER OF ARGUMENTS ! 11400: ZER EFUSE(XR) SET USE COUNT (DFFNC WILL SET TO 1) ! 11401: ZER EFCOD(XR) ZERO CODE POINTER FOR NOW ! 11402: MOV (XS)+,EFRSL(XR) STORE RESULT TYPE CODE ! 11403: MOV LODFN,EFVAR(XR) STORE FUNCTION VRBLK POINTER ! 11404: MOV WA,EFLEN(XR) STORE EFBLK LENGTH ! 11405: MOV XR,WB SAVE EFBLK POINTER ! 11406: ADD WA,XR POINT PAST END OF EFBLK ! 11407: LCT WC,WC SET NUMBER OF ARGUMENTS FOR LOOP ! 11408: * ! 11409: * LOOP TO SET ARGUMENT TYPE CODES FROM STACK ! 11410: * ! 11411: SLOD6 MOV (XS)+,-(XR) STORE ONE TYPE CODE FROM STACK ! 11412: BCT WC,SLOD6 LOOP TILL ALL STORED ! 11413: * ! 11414: * NOW LOAD THE EXTERNAL FUNCTION AND PERFORM DEFINITION ! 11415: * ! 11416: MOV (XS)+,XR LOAD FUNCTION STRING NAME ! 11417: MOV (XS),XL LOAD LIBRARY NAME ! 11418: MOV WB,(XS) STORE EFBLK POINTER ! 11419: JSR SYSLD CALL FUNCTION TO LOAD EXTERNAL FUNC ! 11420: ERR 142,LOAD FUNCTION DOES NOT EXIST ! 11421: ERR 143,LOAD FUNCTION CAUSED INPUT ERROR DURING LOAD ! 11422: MOV (XS)+,XL RECALL EFBLK POINTER ! 11423: MOV XR,EFCOD(XL) STORE CODE POINTER ! 11424: MOV LODFN,XR POINT TO VRBLK FOR FUNCTION ! 11425: JSR DFFNC PERFORM FUNCTION DEFINITION ! 11426: BRN EXNUL RETURN NULL RESULT ! 11427: .FI ! 11428: EJC ! 11429: * ! 11430: * LPAD ! 11431: * ! 11432: S$LPD ENT ENTRY POINT ! 11433: JSR GTSTG GET PAD CHARACTER ! 11434: ERR 144,LPAD THIRD ARGUMENT NOT A STRING ! 11435: PLC XR POINT TO CHARACTER (NULL IS BLANK) ! 11436: LCH WB,(XR) LOAD PAD CHARACTER ! 11437: JSR GTSMI GET PAD LENGTH ! 11438: ERR 145,LPAD SECOND ARGUMENT IS NOT INTEGER ! 11439: PPM SLPD3 SKIP IF NEGATIVE OR LARGE ! 11440: * ! 11441: * MERGE TO CHECK FIRST ARG ! 11442: * ! 11443: SLPD1 JSR GTSTG GET FIRST ARGUMENT (STRING TO PAD) ! 11444: ERR 146,LPAD FIRST ARGUMENT IS NOT STRING ! 11445: BGE WA,WC,EXIXR RETURN 1ST ARG IF TOO LONG TO PAD ! 11446: MOV XR,XL ELSE MOVE PTR TO STRING TO PAD ! 11447: * ! 11448: * NOW WE ARE READY FOR THE PAD ! 11449: * ! 11450: * (XL) POINTER TO STRING TO PAD ! 11451: * (WB) PAD CHARACTER ! 11452: * (WC) LENGTH TO PAD STRING TO ! 11453: * ! 11454: MOV WC,WA COPY LENGTH ! 11455: JSR ALOCS ALLOCATE SCBLK FOR NEW STRING ! 11456: MOV XR,-(XS) SAVE AS RESULT ! 11457: MOV SCLEN(XL),WA LOAD LENGTH OF ARGUMENT ! 11458: SUB WA,WC CALCULATE NUMBER OF PAD CHARACTERS ! 11459: PSC XR POINT TO CHARS IN RESULT STRING ! 11460: LCT WC,WC SET COUNTER FOR PAD LOOP ! 11461: * ! 11462: * LOOP TO PERFORM PAD ! 11463: * ! 11464: SLPD2 SCH WB,(XR)+ STORE PAD CHARACTER, BUMP PTR ! 11465: BCT WC,SLPD2 LOOP TILL ALL PAD CHARS STORED ! 11466: CSC XR COMPLETE STORE CHARACTERS ! 11467: * ! 11468: * NOW COPY STRING ! 11469: * ! 11470: BZE WA,EXITS EXIT IF NULL STRING ! 11471: PLC XL ELSE POINT TO CHARS IN ARGUMENT ! 11472: MVC MOVE CHARACTERS TO RESULT STRING ! 11473: BRN EXITS JUMP FOR NEXT CODE WORD ! 11474: * ! 11475: * HERE IF 2ND ARG IS NEGATIVE OR LARGE ! 11476: * ! 11477: SLPD3 ZER WC ZERO PAD COUNT ! 11478: BRN SLPD1 MERGE ! 11479: EJC ! 11480: * ! 11481: * LT ! 11482: * ! 11483: S$LTF ENT ENTRY POINT ! 11484: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE ! 11485: ERR 147,LT FIRST ARGUMENT IS NOT NUMERIC ! 11486: ERR 148,LT SECOND ARGUMENT IS NOT NUMERIC ! 11487: PPM EXNUL RETURN NULL IF LT ! 11488: PPM EXFAL FAIL IF EQ ! 11489: PPM EXFAL FAIL IF GT ! 11490: EJC ! 11491: * ! 11492: * NE ! 11493: * ! 11494: S$NEF ENT ENTRY POINT ! 11495: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE ! 11496: ERR 149,NE FIRST ARGUMENT IS NOT NUMERIC ! 11497: ERR 150,NE SECOND ARGUMENT IS NOT NUMERIC ! 11498: PPM EXNUL RETURN NULL IF LT ! 11499: PPM EXFAL FAIL IF EQ ! 11500: PPM EXNUL RETURN NULL IF GT ! 11501: EJC ! 11502: * ! 11503: * NOTANY ! 11504: * ! 11505: S$NAY ENT ENTRY POINT ! 11506: MOV =P$NAS,WB SET PCODE FOR SINGLE CHAR ARG ! 11507: MOV =P$NAY,XL PCODE FOR MULTI-CHAR ARG ! 11508: MOV =P$NAD,WC SET PCODE FOR EXPR ARG ! 11509: JSR PATST CALL COMMON ROUTINE TO BUILD NODE ! 11510: ERR 151,NOTANY ARGUMENT IS NOT STRING OR EXPRESSION ! 11511: BRN EXIXR JUMP FOR NEXT CODE WORD ! 11512: EJC ! 11513: * ! 11514: * OPSYN ! 11515: * ! 11516: S$OPS ENT ENTRY POINT ! 11517: JSR GTSMI LOAD THIRD ARGUMENT ! 11518: ERR 152,OPSYN THIRD ARGUMENT IS NOT INTEGER ! 11519: ERR 153,OPSYN THIRD ARGUMENT IS NEGATIVE OR TOO LARGE ! 11520: MOV WC,WB IF OK, SAVE THIRD ARGUMNET ! 11521: MOV (XS)+,XR LOAD SECOND ARGUMENT ! 11522: JSR GTNVR LOCATE VARIABLE BLOCK ! 11523: ERR 154,OPSYN SECOND ARG IS NOT NATURAL VARIABLE NAME ! 11524: MOV VRFNC(XR),XL IF OK, LOAD FUNCTION BLOCK POINTER ! 11525: BNZ WB,SOPS2 JUMP IF OPERATOR OPSYN CASE ! 11526: * ! 11527: * HERE FOR FUNCTION OPSYN (THIRD ARG ZERO) ! 11528: * ! 11529: MOV (XS)+,XR LOAD FIRST ARGUMENT ! 11530: JSR GTNVR GET VRBLK POINTER ! 11531: ERR 155,OPSYN FIRST ARG IS NOT NATURAL VARIABLE NAME ! 11532: * ! 11533: * MERGE HERE TO PERFORM FUNCTION DEFINITION ! 11534: * ! 11535: SOPS1 JSR DFFNC CALL FUNCTION DEFINER ! 11536: BRN EXNUL EXIT WITH NULL RESULT ! 11537: * ! 11538: * HERE FOR OPERATOR OPSYN (THIRD ARG NON-ZERO) ! 11539: * ! 11540: SOPS2 JSR GTSTG GET OPERATOR NAME ! 11541: PPM SOPS5 JUMP IF NOT STRING ! 11542: BNE WA,=NUM01,SOPS5 ERROR IF NOT ONE CHAR LONG ! 11543: PLC XR ELSE POINT TO CHARACTER ! 11544: LCH WC,(XR) LOAD CHARACTER NAME ! 11545: EJC ! 11546: * ! 11547: * OPSYN (CONTINUED) ! 11548: * ! 11549: * NOW SET TO SEARCH FOR MATCHING UNARY OR BINARY OPERATOR ! 11550: * NAME AS APPROPRIATE. NOTE THAT THERE ARE =OPBUN UNDEFINED ! 11551: * BINARY OPERATORS AND =OPUUN UNDEFINED UNARY OPERATORS. ! 11552: * ! 11553: MOV =R$UUB,WA POINT TO UNOP POINTERS IN CASE ! 11554: MOV =OPNSU,XR POINT TO NAMES OF UNARY OPERATORS ! 11555: ADD =OPBUN,WB ADD NO. OF UNDEFINED BINARY OPS ! 11556: BEQ WB,=OPUUN,SOPS3 JUMP IF UNOP (THIRD ARG WAS 1) ! 11557: MOV =R$UBA,WA ELSE POINT TO BINARY OPERATOR PTRS ! 11558: MOV =OPSNB,XR POINT TO NAMES OF BINARY OPERATORS ! 11559: MOV =OPBUN,WB SET NUMBER OF UNDEFINED BINOPS ! 11560: * ! 11561: * MERGE HERE TO CHECK LIST (WB = NUMBER TO CHECK) ! 11562: * ! 11563: SOPS3 LCT WB,WB SET COUNTER TO CONTROL LOOP ! 11564: * ! 11565: * LOOP TO SEARCH FOR NAME MATCH ! 11566: * ! 11567: SOPS4 BEQ WC,(XR),SOPS6 JUMP IF NAMES MATCH ! 11568: ICA WA ELSE PUSH POINTER TO FUNCTION PTR ! 11569: ICA XR BUMP POINTER ! 11570: BCT WB,SOPS4 LOOP BACK TILL ALL CHECKED ! 11571: * ! 11572: * HERE IF BAD OPERATOR NAME ! 11573: * ! 11574: SOPS5 ERB 156,OPSYN FIRST ARG IS NOT CORRECT OPERATOR NAME ! 11575: * ! 11576: * COME HERE ON FINDING A MATCH IN THE OPERATOR NAME TABLE ! 11577: * ! 11578: SOPS6 MOV WA,XR COPY POINTER TO FUNCTION BLOCK PTR ! 11579: SUB *VRFNC,XR MAKE IT LOOK LIKE DUMMY VRBLK ! 11580: BRN SOPS1 MERGE BACK TO DEFINE OPERATOR ! 11581: EJC ! 11582: * ! 11583: * OUTPUT ! 11584: * ! 11585: S$OUP ENT ENTRY POINT ! 11586: MOV =NUM03,WB OUTPUT FLAG ! 11587: JSR IOPUT CALL INPUT/OUTPUT ASSOC. ROUTINE ! 11588: ERR 157,OUTPUT THIRD ARGUMENT IS NOT A STRING ! 11589: ERR 158,INAPPROPRIATE SECOND ARGUMENT FOR OUTPUT ! 11590: ERR 159,INAPPROPRIATE FIRST ARGUMENT FOR OUTPUT ! 11591: ERR 160,INAPPROPRIATE FILE SPECIFICATION FOR OUTPUT ! 11592: PPM EXFAL FAIL IF FILE DOES NOT EXIST ! 11593: ERR 161,OUTPUT FILE CANNOT BE WRITTEN TO ! 11594: BRN EXNUL RETURN NULL STRING ! 11595: EJC ! 11596: * ! 11597: * POS ! 11598: * ! 11599: S$POS ENT ENTRY POINT ! 11600: MOV =P$POS,WB SET PCODE FOR INTEGER ARG CASE ! 11601: MOV =P$PSD,WA SET PCODE FOR EXPRESSION ARG CASE ! 11602: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE ! 11603: ERR 162,POS ARGUMENT IS NOT INTEGER OR EXPRESSION ! 11604: ERR 163,POS ARGUMENT IS NEGATIVE OR TOO LARGE ! 11605: BRN EXIXR RETURN PATTERN NODE ! 11606: EJC ! 11607: * ! 11608: * PROTOTYPE ! 11609: * ! 11610: S$PRO ENT ENTRY POINT ! 11611: MOV (XS)+,XR LOAD ARGUMENT ! 11612: MOV TBLEN(XR),WB LENGTH IF TABLE, VECTOR (=VCLEN) ! 11613: BTW WB CONVERT TO WORDS ! 11614: MOV (XR),WA LOAD TYPE WORD OF ARGUMENT BLOCK ! 11615: BEQ WA,=B$ART,SPRO4 JUMP IF ARRAY ! 11616: BEQ WA,=B$TBT,SPRO1 JUMP IF TABLE ! 11617: BEQ WA,=B$VCT,SPRO3 JUMP IF VECTOR ! 11618: BEQ WA,=B$BCT,SPR05 JUMP IF BUFFER ! 11619: ERB 164,PROTOTYPE ARGUMENT IS NOT VALID OBJECT ! 11620: * ! 11621: * HERE FOR TABLE ! 11622: * ! 11623: SPRO1 SUB =TBSI$,WB SUBTRACT STANDARD FIELDS ! 11624: * ! 11625: * MERGE FOR VECTOR ! 11626: * ! 11627: SPRO2 MTI WB CONVERT TO INTEGER ! 11628: BRN EXINT EXIT WITH INTEGER RESULT ! 11629: * ! 11630: * HERE FOR VECTOR ! 11631: * ! 11632: SPRO3 SUB =VCSI$,WB SUBTRACT STANDARD FIELDS ! 11633: BRN SPRO2 MERGE ! 11634: * ! 11635: * HERE FOR ARRAY ! 11636: * ! 11637: SPRO4 ADD AROFS(XR),XR POINT TO PROTOTYPE FIELD ! 11638: MOV (XR),XR LOAD PROTOTYPE ! 11639: BRN EXIXR RETURN PROTOTYPE AS RESULT ! 11640: .IF .CNBF ! 11641: .ELSE ! 11642: * ! 11643: * HERE FOR BUFFER ! 11644: * ! 11645: SPR05 MOV BCBUF(XR),XR POINT TO BFBLK ! 11646: MTI BFALC(XR) LOAD ALLOCATED LENGTH ! 11647: BRN EXINT EXIT WITH INTEGER ALLOCATION ! 11648: .FI ! 11649: EJC ! 11650: * ! 11651: * REMDR ! 11652: * ! 11653: S$RMD ENT ENTRY POINT ! 11654: ZER WB SET POSITIVE FLAG ! 11655: MOV (XS),XR LOAD SECOND ARGUMENT ! 11656: JSR GTINT CONVERT TO INTEGER ! 11657: ERR 165,REMDR SECOND ARGUMENT IS NOT INTEGER ! 11658: JSR ARITH CONVERT ARGS ! 11659: PPM SRM01 FIRST ARG NOT INTEGER ! 11660: PPM SECOND ARG CHECKED ABOVE ! 11661: .IF .CNRA ! 11662: .ELSE ! 11663: PPM SRM01 FIRST ARG REAL ! 11664: .FI ! 11665: LDI ICVAL(XR) LOAD LEFT ARGUMENT VALUE ! 11666: RMI ICVAL(XL) GET REMAINDER ! 11667: INO EXINT JUMP IF NO OVERFLOW ! 11668: ERB 167,REMDR CAUSED INTEGER OVERFLOW ! 11669: * ! 11670: * FAIL FIRST ARGUMENT ! 11671: * ! 11672: SRM01 ERB 166,REMDR FIRST ARGUMENT IS NOT INTEGER ! 11673: EJC ! 11674: * ! 11675: * REPLACE ! 11676: * ! 11677: * THE ACTUAL REPLACE OPERATION USES AN SCBLK WHOSE CFP$A ! 11678: * CHARS CONTAIN THE TRANSLATED VERSIONS OF ALL THE CHARS. ! 11679: * THE TABLE POINTER IS REMEMBERED FROM CALL TO CALL AND ! 11680: * THE TABLE IS ONLY BUILT WHEN THE ARGUMENTS CHANGE. ! 11681: * ! 11682: S$RPL ENT ENTRY POINT ! 11683: JSR GTSTG LOAD THIRD ARGUMENT AS STRING ! 11684: ERR 168,REPLACE THIRD ARGUMENT IS NOT STRING ! 11685: MOV XR,XL SAVE THIRD ARG PTR ! 11686: JSR GTSTG GET SECOND ARGUMENT ! 11687: ERR 169,REPLACE SECOND ARGUMENT IS NOT STRING ! 11688: * ! 11689: * CHECK TO SEE IF THIS IS THE SAME TABLE AS LAST TIME ! 11690: * ! 11691: BNE XR,R$RA2,SRPL1 JUMP IF 2ND ARGUMENT DIFFERENT ! 11692: BEQ XL,R$RA3,SRPL4 JUMP IF ARGS SAME AS LAST TIME ! 11693: * ! 11694: * HERE WE BUILD A NEW REPLACE TABLE (NOTE WA = 2ND ARG LEN) ! 11695: * ! 11696: SRPL1 MOV SCLEN(XL),WB LOAD 3RD ARGUMENT LENGTH ! 11697: BNE WA,WB,SRPL5 JUMP IF ARGUMENTS NOT SAME LENGTH ! 11698: BZE WB,SRPL5 JUMP IF NULL 2ND ARGUMENT ! 11699: MOV XL,R$RA3 SAVE THIRD ARG FOR NEXT TIME IN ! 11700: MOV XR,R$RA2 SAVE SECOND ARG FOR NEXT TIME IN ! 11701: MOV KVALP,XL POINT TO ALPHABET STRING ! 11702: MOV SCLEN(XL),WA LOAD ALPHABET SCBLK LENGTH ! 11703: MOV R$RPT,XR POINT TO CURRENT TABLE (IF ANY) ! 11704: BNZ XR,SRPL2 JUMP IF WE ALREADY HAVE A TABLE ! 11705: * ! 11706: * HERE WE ALLOCATE A NEW TABLE ! 11707: * ! 11708: JSR ALOCS ALLOCATE NEW TABLE ! 11709: MOV WC,WA KEEP SCBLK LENGTH ! 11710: MOV XR,R$RPT SAVE TABLE POINTER FOR NEXT TIME ! 11711: * ! 11712: * MERGE HERE WITH POINTER TO NEW TABLE BLOCK IN (XR) ! 11713: * ! 11714: SRPL2 CTB WA,SCSI$ COMPUTE LENGTH OF SCBLK ! 11715: MVW COPY TO GET INITIAL TABLE VALUES ! 11716: EJC ! 11717: * ! 11718: * REPLACE (CONTINUED) ! 11719: * ! 11720: * NOW WE MUST PLUG SELECTED ENTRIES AS REQUIRED. NOTE THAT ! 11721: * WE ARE SHORT OF INDEX REGISTERS FOR THE FOLLOWING LOOP. ! 11722: * HENCE THE NEED TO REPEATEDLY RE-INITIALISE CHAR PTR XL ! 11723: * ! 11724: MOV R$RA2,XL POINT TO SECOND ARGUMENT ! 11725: LCT WB,WB NUMBER OF CHARS TO PLUG ! 11726: ZER WC ZERO CHAR OFFSET ! 11727: MOV R$RA3,XR POINT TO 3RD ARG ! 11728: PLC XR GET CHAR PTR FOR 3RD ARG ! 11729: * ! 11730: * LOOP TO PLUG CHARS ! 11731: * ! 11732: SRPL3 MOV R$RA2,XL POINT TO 2ND ARG ! 11733: PLC XL,WC POINT TO NEXT CHAR ! 11734: ICV WC INCREMENT OFFSET ! 11735: LCH WA,(XL) GET NEXT CHAR ! 11736: MOV R$RPT,XL POINT TO TRANSLATE TABLE ! 11737: PSC XL,WA CONVERT CHAR TO OFFSET INTO TABLE ! 11738: LCH WA,(XR)+ GET TRANSLATED CHAR ! 11739: SCH WA,(XL) STORE IN TABLE ! 11740: CSC XL COMPLETE STORE CHARACTERS ! 11741: BCT WB,SRPL3 LOOP TILL DONE ! 11742: EJC ! 11743: * ! 11744: * REPLACE (CONTINUED) ! 11745: * ! 11746: * HERE TO PERFORM TRANSLATE ! 11747: * ! 11748: SRPL4 JSR GTSTG GET FIRST ARGUMENT ! 11749: ERR 170,REPLACE FIRST ARGUMENT IS NOT STRING ! 11750: BZE WA,EXNUL RETURN NULL IF NULL ARGUMENT ! 11751: MOV XR,XL COPY POINTER ! 11752: MOV WA,WC SAVE LENGTH ! 11753: CTB WA,SCHAR GET SCBLK LENGTH ! 11754: JSR ALLOC ALLOCATE SPACE FOR COPY ! 11755: MOV XR,WB SAVE ADDRESS OF COPY ! 11756: MVW MOVE SCBLK CONTENTS TO COPY ! 11757: MOV R$RPT,XR POINT TO REPLACE TABLE ! 11758: PLC XR POINT TO CHARS OF TABLE ! 11759: MOV WB,XL POINT TO STRING TO TRANSLATE ! 11760: PLC XL POINT TO CHARS OF STRING ! 11761: MOV WC,WA SET NUMBER OF CHARS TO TRANSLATE ! 11762: TRC PERFORM TRANSLATION ! 11763: MOV WB,-(XS) STACK NEW STRING AS RESULT ! 11764: BRN EXITS RETURN WITH RESULT ON STACK ! 11765: * ! 11766: * ERROR POINT ! 11767: * ! 11768: SRPL5 ERB 171,NULL OR UNEQUALLY LONG 2ND, 3RD ARGS TO REPLACE ! 11769: EJC ! 11770: * ! 11771: * REWIND ! 11772: * ! 11773: S$REW ENT ENTRY POINT ! 11774: JSR IOFCB CALL FCBLK ROUTINE ! 11775: ERR 172,REWIND ARGUMENT IS NOT A SUITABLE NAME ! 11776: ERR 173,REWIND ARGUMENT IS NULL ! 11777: JSR SYSRW CALL SYSTEM REWIND FUNCTION ! 11778: ERR 174,REWIND FILE DOES NOT EXIST ! 11779: ERR 175,REWIND FILE DOES NOT PERMIT REWIND ! 11780: ERR 176,REWIND CAUSED NON-RECOVERABLE ERROR ! 11781: BRN EXNUL EXIT WITH NULL RESULT IF NO ERROR ! 11782: EJC ! 11783: * ! 11784: * REVERSE ! 11785: * ! 11786: S$RVS ENT ENTRY POINT ! 11787: JSR GTSTG LOAD STRING ARGUMENT ! 11788: ERR 177,REVERSE ARGUMENT IS NOT STRING ! 11789: BZE WA,EXIXR RETURN ARGUMENT IF NULL ! 11790: MOV XR,XL ELSE SAVE POINTER TO STRING ARG ! 11791: JSR ALOCS ALLOCATE SPACE FOR NEW SCBLK ! 11792: MOV XR,-(XS) STORE SCBLK PTR ON STACK AS RESULT ! 11793: PSC XR PREPARE TO STORE IN NEW SCBLK ! 11794: PLC XL,WC POINT PAST LAST CHAR IN ARGUMENT ! 11795: LCT WC,WC SET LOOP COUNTER ! 11796: * ! 11797: * LOOP TO MOVE CHARS IN REVERSE ORDER ! 11798: * ! 11799: SRVS1 LCH WB,-(XL) LOAD NEXT CHAR FROM ARGUMENT ! 11800: SCH WB,(XR)+ STORE IN RESULT ! 11801: BCT WC,SRVS1 LOOP TILL ALL MOVED ! 11802: CSC XR COMPLETE STORE CHARACTERS ! 11803: BRN EXITS AND THEN JUMP FOR NEXT CODE WORD ! 11804: EJC ! 11805: * ! 11806: * RPAD ! 11807: * ! 11808: S$RPD ENT ENTRY POINT ! 11809: JSR GTSTG GET PAD CHARACTER ! 11810: ERR 178,RPAD THIRD ARGUMENT IS NOT STRING ! 11811: PLC XR POINT TO CHARACTER (NULL IS BLANK) ! 11812: LCH WB,(XR) LOAD PAD CHARACTER ! 11813: JSR GTSMI GET PAD LENGTH ! 11814: ERR 179,RPAD SECOND ARGUMENT IS NOT INTEGER ! 11815: PPM SRPD3 SKIP IF NEGATIVE OR LARGE ! 11816: * ! 11817: * MERGE TO CHECK FIRST ARG. ! 11818: * ! 11819: SRPD1 JSR GTSTG GET FIRST ARGUMENT (STRING TO PAD) ! 11820: ERR 180,RPAD FIRST ARGUMENT IS NOT STRING ! 11821: BGE WA,WC,EXIXR RETURN 1ST ARG IF TOO LONG TO PAD ! 11822: MOV XR,XL ELSE MOVE PTR TO STRING TO PAD ! 11823: * ! 11824: * NOW WE ARE READY FOR THE PAD ! 11825: * ! 11826: * (XL) POINTER TO STRING TO PAD ! 11827: * (WB) PAD CHARACTER ! 11828: * (WC) LENGTH TO PAD STRING TO ! 11829: * ! 11830: MOV WC,WA COPY LENGTH ! 11831: JSR ALOCS ALLOCATE SCBLK FOR NEW STRING ! 11832: MOV XR,-(XS) SAVE AS RESULT ! 11833: MOV SCLEN(XL),WA LOAD LENGTH OF ARGUMENT ! 11834: SUB WA,WC CALCULATE NUMBER OF PAD CHARACTERS ! 11835: PSC XR POINT TO CHARS IN RESULT STRING ! 11836: LCT WC,WC SET COUNTER FOR PAD LOOP ! 11837: * ! 11838: * COPY ARGUMENT STRING ! 11839: * ! 11840: BZE WA,SRPD2 JUMP IF ARGUMENT IS NULL ! 11841: PLC XL ELSE POINT TO ARGUMENT CHARS ! 11842: MVC MOVE CHARACTERS TO RESULT STRING ! 11843: * ! 11844: * LOOP TO SUPPLY PAD CHARACTERS ! 11845: * ! 11846: SRPD2 SCH WB,(XR)+ STORE PAD CHARACTER, BUMP PTR ! 11847: BCT WC,SRPD2 LOOP TILL ALL PAD CHARS STORED ! 11848: CSC XR COMPLETE CHARACTER STORING ! 11849: BRN EXITS AND EXIT FOR NEXT WORD ! 11850: * ! 11851: * HERE IF 2ND ARG IS NEGATIVE OR LARGE ! 11852: * ! 11853: SRPD3 ZER WC ZERO PAD COUNT ! 11854: BRN SRPD1 MERGE ! 11855: EJC ! 11856: * ! 11857: * RTAB ! 11858: * ! 11859: S$RTB ENT ENTRY POINT ! 11860: MOV =P$RTB,WB SET PCODE FOR INTEGER ARG CASE ! 11861: MOV =P$RTD,WA SET PCODE FOR EXPRESSION ARG CASE ! 11862: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE ! 11863: ERR 181,RTAB ARGUMENT IS NOT INTEGER OR EXPRESSION ! 11864: ERR 182,RTAB ARGUMENT IS NEGATIVE OR TOO LARGE ! 11865: BRN EXIXR RETURN PATTERN NODE ! 11866: EJC ! 11867: .IF .CUST ! 11868: * ! 11869: * SET ! 11870: * ! 11871: S$SET ENT ENTRY POINT ! 11872: MOV (XS)+,R$IO2 SAVE THIRD ARG ! 11873: MOV (XS)+,R$IO1 SAVE SECOND ARG ! 11874: JSR IOFCB CALL FCBLK ROUTINE ! 11875: ERR 291,SET FIRST ARGUMENT IS NOT A SUITABLE NAME ! 11876: ERR 292,SET FIRST ARGUMENT IS NULL ! 11877: MOV R$IO1,WB LOAD SECOND ARG ! 11878: MOV R$IO2,WC LOAD THIRD ARG ! 11879: JSR SYSST CALL SYSTEM SET ROUTINE ! 11880: ERR 293,INAPPROPRIATE SECOND ARGUMENT TO SET ! 11881: ERR 294,INAPPROPRIATE THIRD ARGUMENT TO SET ! 11882: ERR 295,SET FILE DOES NOT EXIST ! 11883: ERR 296,SET FILE DOES NOT PERMIT SETTING FILE POINTER ! 11884: ERR 297,SET CAUSED NON-RECOVERABLE I/O ERROR ! 11885: BRN EXNUL OTHERWISEW RETURN NULL ! 11886: EJC ! 11887: .FI ! 11888: * ! 11889: * TAB ! 11890: * ! 11891: S$TAB ENT ENTRY POINT ! 11892: MOV =P$TAB,WB SET PCODE FOR INTEGER ARG CASE ! 11893: MOV =P$TBD,WA SET PCODE FOR EXPRESSION ARG CASE ! 11894: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE ! 11895: ERR 183,TAB ARGUMENT IS NOT INTEGER OR EXPRESSION ! 11896: ERR 184,TAB ARGUMENT IS NEGATIVE OR TOO LARGE ! 11897: BRN EXIXR RETURN PATTERN NODE ! 11898: EJC ! 11899: * ! 11900: * RPOS ! 11901: * ! 11902: S$RPS ENT ENTRY POINT ! 11903: MOV =P$RPS,WB SET PCODE FOR INTEGER ARG CASE ! 11904: MOV =P$RPD,WA SET PCODE FOR EXPRESSION ARG CASE ! 11905: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE ! 11906: ERR 185,RPOS ARGUMENT IS NOT INTEGER OR EXPRESSION ! 11907: ERR 186,RPOS ARGUMENT IS NEGATIVE OR TOO LARGE ! 11908: BRN EXIXR RETURN PATTERN NODE ! 11909: .IF .CNSR ! 11910: .ELSE ! 11911: EJC ! 11912: * ! 11913: * RSORT ! 11914: * ! 11915: S$RSR ENT ENTRY POINT ! 11916: MNZ WA MARK AS RSORT ! 11917: JSR SORTA CALL SORT ROUTINE ! 11918: BRN EXSID RETURN, SETTING IDVAL ! 11919: .FI ! 11920: EJC ! 11921: * ! 11922: * SETEXIT ! 11923: * ! 11924: S$STX ENT ENTRY POINT ! 11925: MOV (XS)+,XR LOAD ARGUMENT ! 11926: MOV STXVR,WA LOAD OLD VRBLK POINTER ! 11927: ZER XL LOAD ZERO IN CASE NULL ARG ! 11928: BEQ XR,=NULLS,SSTX1 JUMP IF NULL ARGUMENT (RESET CALL) ! 11929: JSR GTNVR ELSE GET SPECIFIED VRBLK ! 11930: PPM SSTX2 JUMP IF NOT NATURAL VARIABLE ! 11931: MOV VRLBL(XR),XL ELSE LOAD LABEL ! 11932: BEQ XL,=STNDL,SSTX2 JUMP IF LABEL IS NOT DEFINED ! 11933: BNE (XL),=B$TRT,SSTX1 JUMP IF NOT TRAPPED ! 11934: MOV TRLBL(XL),XL ELSE LOAD PTR TO REAL LABEL CODE ! 11935: * ! 11936: * HERE TO SET/RESET SETEXIT TRAP ! 11937: * ! 11938: SSTX1 MOV XR,STXVR STORE NEW VRBLK POINTER (OR NULL) ! 11939: MOV XL,R$SXC STORE NEW CODE PTR (OR ZERO) ! 11940: BEQ WA,=NULLS,EXNUL RETURN NULL IF NULL RESULT ! 11941: MOV WA,XR ELSE COPY VRBLK POINTER ! 11942: BRN EXVNM AND RETURN BUILDING NMBLK ! 11943: * ! 11944: * HERE IF BAD ARGUMENT ! 11945: * ! 11946: SSTX2 ERB 187,SETEXIT ARGUMENT IS NOT LABEL NAME OR NULL ! 11947: .IF .CNSR ! 11948: .ELSE ! 11949: EJC ! 11950: * ! 11951: * SORT ! 11952: * ! 11953: S$SRT ENT ENTRY POINT ! 11954: ZER WA MARK AS SORT ! 11955: JSR SORTA CALL SORT ROUTINE ! 11956: BRN EXSID RETURN, SETTING IDVAL ! 11957: .FI ! 11958: EJC ! 11959: * ! 11960: * SPAN ! 11961: * ! 11962: S$SPN ENT ENTRY POINT ! 11963: MOV =P$SPS,WB SET PCODE FOR SINGLE CHAR ARG ! 11964: MOV =P$SPN,XL SET PCODE FOR MULTI-CHAR ARG ! 11965: MOV =P$SPD,WC SET PCODE FOR EXPRESSION ARG ! 11966: JSR PATST CALL COMMON ROUTINE TO BUILD NODE ! 11967: ERR 188,SPAN ARGUMENT IS NOT STRING OR EXPRESSION ! 11968: BRN EXIXR JUMP FOR NEXT CODE WORD ! 11969: EJC ! 11970: * ! 11971: * SIZE ! 11972: * ! 11973: S$SI$ ENT ENTRY POINT ! 11974: .IF .CNBF ! 11975: .ELSE ! 11976: MOV (XS),XR LOAD ARGUMENT ! 11977: BNE (XR),=B$BCT,SSI$1 BRANCH IF NOT BUFFER ! 11978: ICA XS ELSE POP ARGUMENT ! 11979: MTI BCLEN(XR) LOAD DEFINED LENGTH ! 11980: BRN EXINT EXIT WITH INTEGER ! 11981: .FI ! 11982: * ! 11983: * HERE IF NOT BUFFER ! 11984: * ! 11985: SSI$1 JSR GTSTG LOAD STRING ARGUMENT ! 11986: ERR 189,SIZE ARGUMENT IS NOT STRING ! 11987: MTI WA LOAD LENGTH AS INTEGER ! 11988: BRN EXINT EXIT WITH INTEGER RESULT ! 11989: EJC ! 11990: * ! 11991: * STOPTR ! 11992: * ! 11993: S$STT ENT ENTRY POINT ! 11994: ZER XL INDICATE STOPTR CASE ! 11995: JSR TRACE CALL TRACE PROCEDURE ! 11996: ERR 190,STOPTR FIRST ARGUMENT IS NOT APPROPRIATE NAME ! 11997: ERR 191,STOPTR SECOND ARGUMENT IS NOT TRACE TYPE ! 11998: BRN EXNUL RETURN NULL ! 11999: EJC ! 12000: * ! 12001: * SUBSTR ! 12002: * ! 12003: S$SUB ENT ENTRY POINT ! 12004: JSR GTSMI LOAD THIRD ARGUMENT ! 12005: ERR 192,SUBSTR THIRD ARGUMENT IS NOT INTEGER ! 12006: PPM EXFAL JUMP IF NEGATIVE OR TOO LARGE ! 12007: MOV XR,SBSSV SAVE THIRD ARGUMENT ! 12008: JSR GTSMI LOAD SECOND ARGUMENT ! 12009: ERR 193,SUBSTR SECOND ARGUMENT IS NOT INTEGER ! 12010: PPM EXFAL JUMP IF OUT OF RANGE ! 12011: MOV XR,WB SAVE SECOND ARGUMENT ! 12012: BZE WB,EXFAL JUMP IF SECOND ARGUMENT ZERO ! 12013: DCV WB ELSE DECREMENT FOR ONES ORIGIN ! 12014: .IF .CNBF ! 12015: .ELSE ! 12016: MOV (XS),XL GET FIRST ARG PTR ! 12017: BNE (XL),=B$BCT,SSUBA BRANCH IF NOT BUFFER ! 12018: MOV BCBUF(XL),XR GET BFBLK PTR ! 12019: MOV BCLEN(XL),WA GET LENGTH ! 12020: BRN SSUBB MERGE ! 12021: * ! 12022: * HERE IF NOT BUFFER TO GET STRING ! 12023: * ! 12024: .FI ! 12025: SSUBA JSR GTSTG LOAD FIRST ARGUMENT ! 12026: ERR 194,SUBSTR FIRST ARGUMENT IS NOT STRING ! 12027: * ! 12028: * MERGE WITH BFBLK OR SCBLK PTR IN XR. WA HAS LENGTH ! 12029: * ! 12030: SSUBB MOV SBSSV,WC RELOAD THIRD ARGUMENT ! 12031: BNZ WC,SSUB1 SKIP IF THIRD ARG GIVEN ! 12032: MOV WA,WC ELSE GET STRING LENGTH ! 12033: BGT WB,WC,EXFAL FAIL IF IMPROPER ! 12034: SUB WB,WC REDUCE BY OFFSET TO START ! 12035: * ! 12036: * MERGE ! 12037: * ! 12038: SSUB1 MOV WA,XL SAVE STRING LENGTH ! 12039: MOV WC,WA SET LENGTH OF SUBSTRING ! 12040: ADD WB,WC ADD 2ND ARG TO 3RD ARG ! 12041: BGT WC,XL,EXFAL JUMP IF IMPROPER SUBSTRING ! 12042: MOV XR,XL COPY POINTER TO FIRST ARG ! 12043: JSR SBSTR BUILD SUBSTRING ! 12044: BRN EXIXR AND JUMP FOR NEXT CODE WORD ! 12045: EJC ! 12046: * ! 12047: * TABLE ! 12048: * ! 12049: S$TBL ENT ENTRY POINT ! 12050: MOV (XS)+,XL GET INITIAL LOOKUP VALUE ! 12051: ICA XS POP SECOND ARGUMENT ! 12052: JSR GTSMI LOAD ARGUMENT ! 12053: ERR 195,TABLE ARGUMENT IS NOT INTEGER ! 12054: ERR 196,TABLE ARGUMENT IS OUT OF RANGE ! 12055: BNZ WC,STBL1 JUMP IF NON-ZERO ! 12056: MOV =TBNBK,WC ELSE SUPPLY DEFAULT VALUE ! 12057: * ! 12058: * MERGE HERE WITH NUMBER OF HEADERS IN WA ! 12059: * ! 12060: STBL1 MOV WC,WA COPY NUMBER OF HEADERS ! 12061: ADD =TBSI$,WA ADJUST FOR STANDARD FIELDS ! 12062: WTB WA CONVERT LENGTH TO BYTES ! 12063: JSR ALLOC ALLOCATE SPACE FOR TBBLK ! 12064: MOV XR,WB COPY POINTER TO TBBLK ! 12065: MOV =B$TBT,(XR)+ STORE TYPE WORD ! 12066: ZER (XR)+ ZERO ID FOR THE MOMENT ! 12067: MOV WA,(XR)+ STORE LENGTH (TBLEN) ! 12068: MOV XL,(XR)+ STORE INITIAL LOOKUP VALUE ! 12069: LCT WC,WC SET LOOP COUNTER (NUM HEADERS) ! 12070: * ! 12071: * LOOP TO INITIALIZE ALL BUCKET POINTERS ! 12072: * ! 12073: STBL2 MOV WB,(XR)+ STORE TBBLK PTR IN BUCKET HEADER ! 12074: BCT WC,STBL2 LOOP TILL ALL STORED ! 12075: MOV WB,XR RECALL POINTER TO TBBLK ! 12076: BRN EXSID EXIT SETTING IDVAL ! 12077: EJC ! 12078: * ! 12079: * TIME ! 12080: * ! 12081: S$TIM ENT ENTRY POINT ! 12082: JSR SYSTM GET TIMER VALUE ! 12083: SBI TIMSX SUBTRACT STARTING TIME ! 12084: BRN EXINT EXIT WITH INTEGER VALUE ! 12085: EJC ! 12086: * ! 12087: * TRACE ! 12088: * ! 12089: S$TRA ENT ENTRY POINT ! 12090: BEQ 3(XS),=NULLS,STR03 JUMP IF FIRST ARGUMENT IS NULL ! 12091: MOV (XS)+,XR LOAD FOURTH ARGUMENT ! 12092: ZER XL TENTATIVELY SET ZERO POINTER ! 12093: BEQ XR,=NULLS,STR02 JUMP IF 4TH ARGUMENT IS NULL ! 12094: JSR GTNVR ELSE POINT TO VRBLK ! 12095: PPM STR01 JUMP IF NOT VARIABLE NAME ! 12096: MOV VRFNC(XR),XL ELSE LOAD FUNCTION POINTER ! 12097: BNE XL,=STNDF,STR02 JUMP IF FUNCTION IS DEFINED ! 12098: * ! 12099: * HERE FOR BAD FOURTH ARGUMENT ! 12100: * ! 12101: STR01 ERB 197,TRACE FOURTH ARG IS NOT FUNCTION NAME OR NULL ! 12102: * ! 12103: * HERE WITH FUNCTION POINTER IN XL ! 12104: * ! 12105: STR02 MOV (XS)+,XR LOAD THIRD ARGUMENT (TAG) ! 12106: ZER WB SET ZERO AS TRTYP VALUE FOR NOW ! 12107: JSR TRBLD BUILD TRBLK FOR TRACE CALL ! 12108: MOV XR,XL MOVE TRBLK POINTER FOR TRACE ! 12109: JSR TRACE CALL TRACE PROCEDURE ! 12110: ERR 198,TRACE FIRST ARGUMENT IS NOT APPROPRIATE NAME ! 12111: ERR 199,TRACE SECOND ARGUMENT IS NOT TRACE TYPE ! 12112: BRN EXNUL RETURN NULL ! 12113: * ! 12114: * HERE TO CALL SYSTEM TRACE TOGGLE ROUTINE ! 12115: * ! 12116: STR03 JSR SYSTT CALL IT ! 12117: ADD *NUM04,XS POP TRACE ARGUMENTS ! 12118: BRN EXNUL RETURN ! 12119: EJC ! 12120: * ! 12121: * TRIM ! 12122: * ! 12123: S$TRM ENT ENTRY POINT ! 12124: JSR GTSTG LOAD ARGUMENT AS STRING ! 12125: ERR 200,TRIM ARGUMENT IS NOT STRING ! 12126: BZE WA,EXNUL RETURN NULL IF ARGUMENT IS NULL ! 12127: MOV XR,XL COPY STRING POINTER ! 12128: CTB WA,SCHAR GET BLOCK LENGTH ! 12129: JSR ALLOC ALLOCATE COPY SAME SIZE ! 12130: MOV XR,WB SAVE POINTER TO COPY ! 12131: MVW COPY OLD STRING BLOCK TO NEW ! 12132: MOV WB,XR RESTORE PTR TO NEW BLOCK ! 12133: JSR TRIMR TRIM BLANKS (WB IS NON-ZERO) ! 12134: BRN EXIXR EXIT WITH RESULT IN XR ! 12135: EJC ! 12136: * ! 12137: * UNLOAD ! 12138: * ! 12139: S$UNL ENT ENTRY POINT ! 12140: MOV (XS)+,XR LOAD ARGUMENT ! 12141: JSR GTNVR POINT TO VRBLK ! 12142: ERR 201,UNLOAD ARGUMENT IS NOT NATURAL VARIABLE NAME ! 12143: MOV =STNDF,XL GET PTR TO UNDEFINED FUNCTION ! 12144: JSR DFFNC UNDEFINE NAMED FUNCTION ! 12145: BRN EXNUL RETURN NULL AS RESULT ! 12146: TTL S P I T B O L -- UTILITY PROCEDURES ! 12147: * ! 12148: * THE FOLLOWING SECTION CONTAINS PROCEDURES WHICH ARE ! 12149: * USED FOR VARIOUS PURPOSES THROUGHOUT THE SYSTEM. ! 12150: * ! 12151: * EACH PROCEDURE IS PRECEDED BY A DESCRIPTION OF THE ! 12152: * CALLING SEQUENCE. USUALLY THE ARGUMENTS ARE IN REGISTERS ! 12153: * BUT ARGUMENTS CAN ALSO OCCUR ON THE STACK AND AS ! 12154: * PARAMETERS ASSEMBLED AFTER THE JSR INSTRUCTION. ! 12155: * ! 12156: * THE FOLLOWING CONSIDERATIONS APPLY TO THESE DESCRIPTIONS. ! 12157: * ! 12158: * 1) THE STACK POINTER (XS) IS NOT CHANGED UNLESS THE ! 12159: * CHANGE IS EXPLICITLY DOCUMENTED IN THE CALL. ! 12160: * ! 12161: * 2) REGISTERS WHOSE ENTRY VALUES ARE NOT MENTIONED ! 12162: * MAY CONTAIN ANY VALUE EXCEPT THAT XL,XR MAY ONLY ! 12163: * CONTAIN PROPER (COLLECTABLE) POINTER VALUES. ! 12164: * THIS CONDITION ON XR MEANS THAT THE CALLED ROUTINE ! 12165: * MAY IF IT CHOOSES PRESERVE XR BY STACKING. ! 12166: * ! 12167: * 3) REGISTERS NOT MENTIONED ON EXIT CONTAIN THE SAME ! 12168: * VALUES AS THEY DID ON ENTRY EXCEPT THAT VALUES IN ! 12169: * XR,XL MAY HAVE BEEN RELOCATED BY THE COLLECTOR. ! 12170: * ! 12171: * 4) REGISTERS WHICH ARE DESTROYED ON EXIT MAY CONTAIN ! 12172: * ANY VALUE EXCEPT THAT VALUES IN XL,XR ARE PROPER ! 12173: * (COLLECTABLE) POINTERS. ! 12174: * ! 12175: * 5) THE CODE POINTER REGISTER POINTS TO THE CURRENT ! 12176: * CODE LOCATION ON ENTRY AND IS UNCHANGED ON EXIT. ! 12177: * ! 12178: * IN THE ABOVE DESCRIPTION, A COLLECTABLE POINTER IS ONE ! 12179: * WHICH EITHER POINTS OUTSIDE THE DYNAMIC REGION OR ! 12180: * POINTS TO THE START OF A BLOCK IN THE DYNAMIC REGION. ! 12181: * ! 12182: * IN THOSE CASES WHERE THE CALLING SEQUENCE CONTAINS ! 12183: * PARAMETERS WHICH ARE USED AS ALTERNATE RETURN POINTS, ! 12184: * THESE PARAMETERS MAY BE REPLACED BY ERROR CODES ! 12185: * ASSEMBLED WITH THE ERR INSTRUCTION. THIS WILL RESULT ! 12186: * IN THE POSTING OF THE ERROR IF THE RETURN IS TAKEN. ! 12187: * ! 12188: * THE PROCEDURES ALL HAVE NAMES CONSISTING OF FIVE LETTERS ! 12189: * AND ARE IN ALPHABETICAL ORDER BY THEIR NAMES. ! 12190: EJC ! 12191: * ! 12192: * ACESS - ACCESS VARIABLE VALUE WITH TRACE/INPUT CHECKS ! 12193: * ! 12194: * ACESS LOADS THE VALUE OF A VARIABLE. TRACE AND INPUT ! 12195: * ASSOCIATIONS ARE TESTED FOR AND EXECUTED AS REQUIRED. ! 12196: * ACESS ALSO HANDLES THE SPECIAL CASES OF PSEUDO-VARIABLES. ! 12197: * ! 12198: * (XL) VARIABLE NAME BASE ! 12199: * (WA) VARIABLE NAME OFFSET ! 12200: * JSR ACESS CALL TO ACCESS VALUE ! 12201: * PPM LOC TRANSFER LOC IF ACCESS FAILURE ! 12202: * (XR) VARIABLE VALUE ! 12203: * (WA,WB,WC) DESTROYED ! 12204: * (XL,RA) DESTROYED ! 12205: * ! 12206: * FAILURE CAN OCCUR IF AN INPUT ASSOCIATION CAUSES AN END ! 12207: * OF FILE CONDITION OR IF THE EVALUATION OF AN EXPRESSION ! 12208: * ASSOCIATED WITH AN EXPRESSION VARIABLE FAILS. ! 12209: * ! 12210: ACESS PRC R,1 ENTRY POINT (RECURSIVE) ! 12211: MOV XL,XR COPY NAME BASE ! 12212: ADD WA,XR POINT TO VARIABLE LOCATION ! 12213: MOV (XR),XR LOAD VARIABLE VALUE ! 12214: * ! 12215: * LOOP HERE TO CHECK FOR SUCCESSIVE TRBLKS ! 12216: * ! 12217: ACS02 BNE (XR),=B$TRT,ACS18 JUMP IF NOT TRAPPED ! 12218: * ! 12219: * HERE IF TRAPPED ! 12220: * ! 12221: BEQ XR,=TRBKV,ACS12 JUMP IF KEYWORD VARIABLE ! 12222: BNE XR,=TRBEV,ACS05 JUMP IF NOT EXPRESSION VARIABLE ! 12223: * ! 12224: * HERE FOR EXPRESSION VARIABLE, EVALUATE VARIABLE ! 12225: * ! 12226: MOV EVEXP(XL),XR LOAD EXPRESSION POINTER ! 12227: ZER WB EVALUATE BY VALUE ! 12228: JSR EVALX EVALUATE EXPRESSION ! 12229: PPM ACS04 JUMP IF EVALUATION FAILURE ! 12230: BRN ACS02 CHECK VALUE FOR MORE TRBLKS ! 12231: EJC ! 12232: * ! 12233: * ACESS (CONTINUED) ! 12234: * ! 12235: * HERE ON READING END OF FILE ! 12236: * ! 12237: ACS03 ADD *NUM03,XS POP TRBLK PTR, NAME BASE AND OFFSET ! 12238: MOV XR,DNAMP POP UNUSED SCBLK ! 12239: * ! 12240: * MERGE HERE WHEN EVALUATION OF EXPRESSION FAILS ! 12241: * ! 12242: ACS04 EXI 1 TAKE ALTERNATE (FAILURE) RETURN ! 12243: * ! 12244: * HERE IF NOT KEYWORD OR EXPRESSION VARIABLE ! 12245: * ! 12246: ACS05 MOV TRTYP(XR),WB LOAD TRAP TYPE CODE ! 12247: BNZ WB,ACS10 JUMP IF NOT INPUT ASSOCIATION ! 12248: BZE KVINP,ACS09 IGNORE INPUT ASSOC IF INPUT IS OFF ! 12249: * ! 12250: * HERE FOR INPUT ASSOCIATION ! 12251: * ! 12252: MOV XL,-(XS) STACK NAME BASE ! 12253: MOV WA,-(XS) STACK NAME OFFSET ! 12254: MOV XR,-(XS) STACK TRBLK POINTER ! 12255: MOV TRFPT(XR),XL GET FILE CTRL BLK PTR OR ZERO ! 12256: BNZ XL,ACS06 JUMP IF NOT STANDARD INPUT FILE ! 12257: BEQ TRTER(XR),=V$TER,ACS21 JUMP IF TERMINAL ! 12258: * ! 12259: * HERE TO READ FROM STANDARD INPUT FILE ! 12260: * ! 12261: MOV CSWIN,WA LENGTH FOR READ BUFFER ! 12262: JSR ALOCS BUILD STRING OF APPROPRIATE LENGTH ! 12263: JSR SYSRD READ NEXT STANDARD INPUT IMAGE ! 12264: PPM ACS03 JUMP TO FAIL EXIT IF END OF FILE ! 12265: BRN ACS07 ELSE MERGE WITH OTHER FILE CASE ! 12266: * ! 12267: * HERE FOR INPUT FROM OTHER THAN STANDARD INPUT FILE ! 12268: * ! 12269: ACS06 MOV XL,WA FCBLK PTR ! 12270: JSR SYSIL GET INPUT RECORD MAX LENGTH (TO WA) ! 12271: JSR ALOCS ALLOCATE STRING OF CORRECT SIZE ! 12272: MOV XL,WA FCBLK PTR ! 12273: JSR SYSIN CALL SYSTEM INPUT ROUTINE ! 12274: PPM ACS03 JUMP TO FAIL EXIT IF END OF FILE ! 12275: PPM ACS22 ERROR ! 12276: PPM ACS23 ERROR ! 12277: EJC ! 12278: * ! 12279: * ACESS (CONTINUED) ! 12280: * ! 12281: * MERGE HERE AFTER OBTAINING INPUT RECORD ! 12282: * ! 12283: ACS07 MOV KVTRM,WB LOAD TRIM INDICATOR ! 12284: JSR TRIMR TRIM RECORD AS REQUIRED ! 12285: MOV XR,WB COPY RESULT POINTER ! 12286: MOV (XS),XR RELOAD POINTER TO TRBLK ! 12287: * ! 12288: * LOOP TO CHASE TO END OF TRBLK CHAIN AND STORE VALUE ! 12289: * ! 12290: ACS08 MOV XR,XL SAVE POINTER TO THIS TRBLK ! 12291: MOV TRNXT(XR),XR LOAD FORWARD POINTER ! 12292: BEQ (XR),=B$TRT,ACS08 LOOP IF THIS IS ANOTHER TRBLK ! 12293: MOV WB,TRNXT(XL) ELSE STORE RESULT AT END OF CHAIN ! 12294: MOV (XS)+,XR RESTORE INITIAL TRBLK POINTER ! 12295: MOV (XS)+,WA RESTORE NAME OFFSET ! 12296: MOV (XS)+,XL RESTORE NAME BASE POINTER ! 12297: * ! 12298: * COME HERE TO MOVE TO NEXT TRBLK ! 12299: * ! 12300: ACS09 MOV TRNXT(XR),XR LOAD FORWARD PTR TO NEXT VALUE ! 12301: BRN ACS02 BACK TO CHECK IF TRAPPED ! 12302: * ! 12303: * HERE TO CHECK FOR ACCESS TRACE TRBLK ! 12304: * ! 12305: ACS10 BNE WB,=TRTAC,ACS09 LOOP BACK IF NOT ACCESS TRACE ! 12306: BZE KVTRA,ACS09 IGNORE ACCESS TRACE IF TRACE OFF ! 12307: DCV KVTRA ELSE DECREMENT TRACE COUNT ! 12308: BZE TRFNC(XR),ACS11 JUMP IF PRINT TRACE ! 12309: EJC ! 12310: * ! 12311: * ACESS (CONTINUED) ! 12312: * ! 12313: * HERE FOR FULL FUNCTION TRACE ! 12314: * ! 12315: JSR TRXEQ CALL ROUTINE TO EXECUTE TRACE ! 12316: BRN ACS09 JUMP FOR NEXT TRBLK ! 12317: * ! 12318: * HERE FOR CASE OF PRINT TRACE ! 12319: * ! 12320: ACS11 JSR PRTSN PRINT STATEMENT NUMBER ! 12321: JSR PRTNV PRINT NAME = VALUE ! 12322: BRN ACS09 JUMP BACK FOR NEXT TRBLK ! 12323: * ! 12324: * HERE FOR KEYWORD VARIABLE ! 12325: * ! 12326: ACS12 MOV KVNUM(XL),XR LOAD KEYWORD NUMBER ! 12327: BGE XR,=K$V$$,ACS14 JUMP IF NOT ONE WORD VALUE ! 12328: MTI KVABE(XR) ELSE LOAD VALUE AS INTEGER ! 12329: * ! 12330: * COMMON EXIT WITH KEYWORD VALUE AS INTEGER IN (IA) ! 12331: * ! 12332: ACS13 JSR ICBLD BUILD ICBLK ! 12333: BRN ACS18 JUMP TO EXIT ! 12334: * ! 12335: * HERE IF NOT ONE WORD KEYWORD VALUE ! 12336: * ! 12337: ACS14 BGE XR,=K$S$$,ACS15 JUMP IF SPECIAL CASE ! 12338: SUB =K$V$$,XR ELSE GET OFFSET ! 12339: ADD =NDABO,XR POINT TO PATTERN VALUE ! 12340: BRN ACS18 JUMP TO EXIT ! 12341: * ! 12342: * HERE IF SPECIAL KEYWORD CASE ! 12343: * ! 12344: ACS15 MOV KVRTN,XL LOAD RTNTYPE IN CASE ! 12345: LDI KVSTL LOAD STLIMIT IN CASE ! 12346: SUB =K$S$$,XR GET CASE NUMBER ! 12347: BSW XR,5 SWITCH ON KEYWORD NUMBER ! 12348: IFF K$$AL,ACS16 JUMP IF ALPHABET ! 12349: IFF K$$RT,ACS17 RTNTYPE ! 12350: IFF K$$SC,ACS19 STCOUNT ! 12351: IFF K$$SL,ACS13 STLIMIT ! 12352: IFF K$$ET,ACS20 ERRTEXT ! 12353: ESW END SWITCH ON KEYWORD NUMBER ! 12354: EJC ! 12355: * ! 12356: * ACESS (CONTINUED) ! 12357: * ! 12358: * ALPHABET ! 12359: * ! 12360: ACS16 MOV KVALP,XL LOAD POINTER TO ALPHABET STRING ! 12361: * ! 12362: * RTNTYPE MERGES HERE ! 12363: * ! 12364: ACS17 MOV XL,XR COPY STRING PTR TO PROPER REG ! 12365: * ! 12366: * COMMON RETURN POINT ! 12367: * ! 12368: ACS18 EXI RETURN TO ACESS CALLER ! 12369: * ! 12370: * HERE FOR STCOUNT (IA HAS STLIMIT) ! 12371: * ! 12372: ACS19 SBI KVSTC STCOUNT = LIMIT - LEFT ! 12373: BRN ACS13 MERGE BACK WITH INTEGER RESULT ! 12374: * ! 12375: * ERRTEXT ! 12376: * ! 12377: ACS20 MOV R$ETX,XR GET ERRTEXT STRING ! 12378: BRN ACS18 MERGE WITH RESULT ! 12379: * ! 12380: * HERE TO READ A RECORD FROM TERMINAL ! 12381: * ! 12382: ACS21 MOV =RILEN,WA BUFFER LENGTH ! 12383: JSR ALOCS ALLOCATE BUFFER ! 12384: JSR SYSRI READ RECORD ! 12385: PPM ACS03 ENDFILE ! 12386: BRN ACS07 MERGE WITH RECORD READ ! 12387: * ! 12388: * ERROR RETURNS ! 12389: * ! 12390: ACS22 MOV XR,DNAMP POP UNUSED SCBLK ! 12391: ERB 202,INPUT FROM FILE CAUSED NON-RECOVERABLE ERROR ! 12392: * ! 12393: ACS23 MOV XR,DNAMP POP UNUSED SCBLK ! 12394: ERB 203,INPUT FILE RECORD HAS INCORRECT FORMAT ! 12395: ENP END PROCEDURE ACESS ! 12396: EJC ! 12397: * ! 12398: * ACOMP -- COMPARE TWO ARITHMETIC VALUES ! 12399: * ! 12400: * 1(XS) FIRST ARGUMENT ! 12401: * 0(XS) SECOND ARGUMENT ! 12402: * JSR ACOMP CALL TO COMPARE VALUES ! 12403: * PPM LOC TRANSFER LOC IF ARG1 IS NON-NUMERIC ! 12404: * PPM LOC TRANSFER LOC IF ARG2 IS NON-NUMERIC ! 12405: * PPM LOC TRANSFER LOC FOR ARG1 LT ARG2 ! 12406: * PPM LOC TRANSFER LOC FOR ARG1 EQ ARG2 ! 12407: * PPM LOC TRANSFER LOC FOR ARG1 GT ARG2 ! 12408: * (NORMAL RETURN IS NEVER GIVEN) ! 12409: * (WA,WB,WC,IA,RA) DESTROYED ! 12410: * (XL,XR) DESTROYED ! 12411: * ! 12412: ACOMP PRC N,5 ENTRY POINT ! 12413: JSR ARITH LOAD ARITHMETIC OPERANDS ! 12414: PPM ACMP7 JUMP IF FIRST ARG NON-NUMERIC ! 12415: PPM ACMP8 JUMP IF SECOND ARG NON-NUMERIC ! 12416: .IF .CNRA ! 12417: .ELSE ! 12418: PPM ACMP4 JUMP IF REAL ARGUMENTS ! 12419: .FI ! 12420: * ! 12421: * HERE FOR INTEGER ARGUMENTS ! 12422: * ! 12423: SBI ICVAL(XL) SUBTRACT TO COMPARE ! 12424: IOV ACMP3 JUMP IF OVERFLOW ! 12425: ILT ACMP5 ELSE JUMP IF ARG1 LT ARG2 ! 12426: IEQ ACMP2 JUMP IF ARG1 EQ ARG2 ! 12427: * ! 12428: * HERE IF ARG1 GT ARG2 ! 12429: * ! 12430: ACMP1 EXI 5 TAKE GT EXIT ! 12431: * ! 12432: * HERE IF ARG1 EQ ARG2 ! 12433: * ! 12434: ACMP2 EXI 4 TAKE EQ EXIT ! 12435: EJC ! 12436: * ! 12437: * ACOMP (CONTINUED) ! 12438: * ! 12439: * HERE FOR INTEGER OVERFLOW ON SUBTRACT ! 12440: * ! 12441: ACMP3 LDI ICVAL(XL) LOAD SECOND ARGUMENT ! 12442: ILT ACMP1 GT IF NEGATIVE ! 12443: BRN ACMP5 ELSE LT ! 12444: .IF .CNRA ! 12445: .ELSE ! 12446: * ! 12447: * HERE FOR REAL OPERANDS ! 12448: * ! 12449: ACMP4 SBR RCVAL(XL) SUBTRACT TO COMPARE ! 12450: ROV ACMP6 JUMP IF OVERFLOW ! 12451: RGT ACMP1 ELSE JUMP IF ARG1 GT ! 12452: REQ ACMP2 JUMP IF ARG1 EQ ARG2 ! 12453: .FI ! 12454: * ! 12455: * HERE IF ARG1 LT ARG2 ! 12456: * ! 12457: ACMP5 EXI 3 TAKE LT EXIT ! 12458: .IF .CNRA ! 12459: .ELSE ! 12460: * ! 12461: * HERE IF OVERFLOW ON REAL SUBTRACTION ! 12462: * ! 12463: ACMP6 LDR RCVAL(XL) RELOAD ARG2 ! 12464: RLT ACMP1 GT IF NEGATIVE ! 12465: BRN ACMP5 ELSE LT ! 12466: .FI ! 12467: * ! 12468: * HERE IF ARG1 NON-NUMERIC ! 12469: * ! 12470: ACMP7 EXI 1 TAKE ERROR EXIT ! 12471: * ! 12472: * HERE IF ARG2 NON-NUMERIC ! 12473: * ! 12474: ACMP8 EXI 2 TAKE ERROR EXIT ! 12475: ENP END PROCEDURE ACOMP ! 12476: EJC ! 12477: * ! 12478: * ALLOC ALLOCATE BLOCK OF DYNAMIC STORAGE ! 12479: * ! 12480: * (WA) LENGTH REQUIRED IN BYTES ! 12481: * JSR ALLOC CALL TO ALLOCATE BLOCK ! 12482: * (XR) POINTER TO ALLOCATED BLOCK ! 12483: * ! 12484: * A POSSIBLE ALTERNATIVE TO AOV .. AND FOLLOWING STMT IS - ! 12485: * MOV DNAME,XR . SUB WA,XR . BLO XR,DNAMP,ALOC2 . ! 12486: * MOV DNAMP,XR . ADD WA,XR ! 12487: * ! 12488: ALLOC PRC E,0 ENTRY POINT ! 12489: * ! 12490: * COMMON EXIT POINT ! 12491: * ! 12492: ALOC1 MOV DNAMP,XR POINT TO NEXT AVAILABLE LOC ! 12493: AOV WA,XR,ALOC2 POINT PAST ALLOCATED BLOCK ! 12494: BGT XR,DNAME,ALOC2 JUMP IF NOT ENOUGH ROOM ! 12495: MOV XR,DNAMP STORE NEW POINTER ! 12496: SUB WA,XR POINT BACK TO START OF ALLOCATED BK ! 12497: EXI RETURN TO CALLER ! 12498: * ! 12499: * HERE IF INSUFFICIENT ROOM, TRY A GARBAGE COLLECTION ! 12500: * ! 12501: ALOC2 MOV WB,ALLSV SAVE WB ! 12502: ZER WB SET NO UPWARD MOVE FOR GBCOL ! 12503: JSR GBCOL GARBAGE COLLECT ! 12504: * ! 12505: * SEE IF ROOM AFTER GBCOL OR SYSMM CALL ! 12506: * ! 12507: ALOC3 MOV DNAMP,XR POINT TO FIRST AVAILABLE LOC ! 12508: AOV WA,XR,ALC3A POINT PAST NEW BLOCK ! 12509: BLO XR,DNAME,ALOC4 JUMP IF THERE IS ROOM NOW ! 12510: * ! 12511: * FAILED AGAIN, SEE IF WE CAN GET MORE CORE ! 12512: * ! 12513: ALC3A JSR SYSMM TRY TO GET MORE MEMORY ! 12514: WTB XR CONVERT TO BAUS (SGD05) ! 12515: ADD XR,DNAME BUMP PTR BY AMOUNT OBTAINED ! 12516: BNZ XR,ALOC3 JUMP IF GOT MORE CORE ! 12517: ADD RSMEM,DNAME GET THE RESERVE MEMORY ! 12518: ZER RSMEM ONLY PERMISSIBLE ONCE ! 12519: ICV ERRFT FATAL ERROR ! 12520: ERB 204,MEMORY OVERFLOW ! 12521: EJC ! 12522: * ! 12523: * HERE AFTER SUCCESSFUL GARBAGE COLLECTION ! 12524: * ! 12525: ALOC4 STI ALLIA SAVE IA ! 12526: MOV DNAME,WB GET DYNAMIC END ADRS ! 12527: SUB DNAMP,WB COMPUTE FREE STORE ! 12528: BTW WB CONVERT BYTES TO WORDS ! 12529: MTI WB PUT FREE STORE IN IA ! 12530: MLI ALFSF MULTIPLY BY FREE STORE FACTOR ! 12531: IOV ALOC5 JUMP IF OVERFLOWED ! 12532: MOV DNAME,WB DYNAMIC END ADRS ! 12533: SUB DNAMB,WB COMPUTE TOTAL AMOUNT OF DYNAMIC ! 12534: BTW WB CONVERT TO WORDS ! 12535: MOV WB,ALDYN STORE IT ! 12536: SBI ALDYN SUBTRACT FROM SCALED UP FREE STORE ! 12537: IGT ALOC5 JUMP IF SUFFICIENT FREE STORE ! 12538: JSR SYSMM TRY TO GET MORE STORE ! 12539: WTB XR CONVERT TO BAUS (SGD05) ! 12540: ADD XR,DNAME ADJUST DYNAMIC END ADRS ! 12541: * ! 12542: * MERGE TO RESTORE IA AND WB ! 12543: * ! 12544: ALOC5 LDI ALLIA RECOVER IA ! 12545: MOV ALLSV,WB RESTORE WB ! 12546: BRN ALOC1 JUMP BACK TO EXIT ! 12547: ENP END PROCEDURE ALLOC ! 12548: EJC ! 12549: .IF .CNBF ! 12550: .ELSE ! 12551: * ! 12552: * ALOBF -- ALLOCATE BUFFER ! 12553: * ! 12554: * THIS ROUTINES ALLOCATES A NEW BUFFER. AS THE BFBLK ! 12555: * AND BCBLK COME IN PAIRS, BOTH ARE ALLOCATED HERE, ! 12556: * AND XR POINTS TO THE BCBLK ON RETURN. THE BFBLK ! 12557: * AND BCBLK ARE SET TO THE NULL BUFFER, AND THE IDVAL ! 12558: * IS ZERO ON RETURN. ! 12559: * ! 12560: * (WA) BUFFER SIZE IN CHARACTERS ! 12561: * JSR ALOBF CALL TO CREATE BUFFER ! 12562: * (XR) BCBLK PTR ! 12563: * (WA,WB) DESTROYED ! 12564: * ! 12565: ALOBF PRC E,0 ENTRY POINT ! 12566: MOV WA,WB HANG ONTO ALLOCATION SIZE ! 12567: CTB WA,BFSI$ GET TOTAL BLOCK SIZE ! 12568: BGE WA,MXLEN,ALB01 CHECK FOR MAXLEN EXCEEDED ! 12569: ADD *BCSI$,WA ADD IN ALLOCATION FOR BCBLK ! 12570: JSR ALLOC ALLOCATE FRAME ! 12571: MOV =B$BCT,(XR) SET TYPE ! 12572: ZER IDVAL(XR) NO ID YET ! 12573: ZER BCLEN(XR) NO DEFINED LENGTH ! 12574: MOV XL,WA SAVE XL ! 12575: MOV XR,XL COPY BCBLK PTR ! 12576: ADD *BCSI$,XL BIAS PAST PARTIALLY BUILT BCBLK ! 12577: MOV =B$BFT,(XL) SET BFBLK TYPE WORD ! 12578: MOV WB,BFALC(XL) SET ALLOCATED SIZE ! 12579: MOV XL,BCBUF(XR) SET POINTER IN BCBLK ! 12580: ZER BFCHR(XL) CLEAR FIRST WORD (NULL PAD) ! 12581: MOV WA,XL RESTORE ENTRY XL ! 12582: EXI RETURN TO CALLER ! 12583: * ! 12584: * HERE FOR MXLEN EXCEEDED ! 12585: * ! 12586: ALB01 ERB 274,REQUESTED BUFFER ALLOCATION EXCEEDS MXLEN ! 12587: ENP END PROCEDURE ALOBF ! 12588: EJC ! 12589: .FI ! 12590: * ! 12591: * ALOCS -- ALLOCATE STRING BLOCK ! 12592: * ! 12593: * ALOCS IS USED TO BUILD A FRAME FOR A STRING BLOCK INTO ! 12594: * WHICH THE ACTUAL CHARACTERS ARE PLACED BY THE CALLER. ! 12595: * ALL STRINGS ARE CREATED WITH A CALL TO ALOCS (THE ! 12596: * EXCEPTIONS OCCUR IN TRIMR AND S$RPL PROCEDURES). ! 12597: * ! 12598: * (WA) LENGTH OF STRING TO BE ALLOCATED ! 12599: * JSR ALOCS CALL TO ALLOCATE SCBLK ! 12600: * (XR) POINTER TO RESULTING SCBLK ! 12601: * (WA) DESTROYED ! 12602: * (WC) CHARACTER COUNT (ENTRY VALUE OF WA) ! 12603: * ! 12604: * THE RESULTING SCBLK HAS THE TYPE WORD AND THE LENGTH ! 12605: * FILLED IN AND THE LAST WORD IS CLEARED TO ZERO CHARACTERS ! 12606: * TO ENSURE CORRECT RIGHT PADDING OF THE FINAL WORD. ! 12607: * ! 12608: ALOCS PRC E,0 ENTRY POINT ! 12609: BGT WA,KVMXL,ALCS2 JUMP IF LENGTH EXCEEEDS MAXLENGTH ! 12610: MOV WA,WC ELSE COPY LENGTH ! 12611: CTB WA,SCSI$ COMPUTE LENGTH OF SCBLK IN BYTES ! 12612: MOV DNAMP,XR POINT TO NEXT AVAILABLE LOCATION ! 12613: AOV WA,XR,ALCS0 POINT PAST BLOCK ! 12614: BLO XR,DNAME,ALCS1 JUMP IF THERE IS ROOM ! 12615: * ! 12616: * INSUFFICIENT MEMORY ! 12617: * ! 12618: ALCS0 ZER XR ELSE CLEAR GARBAGE XR VALUE ! 12619: JSR ALLOC AND USE STANDARD ALLOCATOR ! 12620: ADD WA,XR POINT PAST END OF BLOCK TO MERGE ! 12621: * ! 12622: * MERGE HERE WITH XR POINTING BEYOND NEW BLOCK ! 12623: * ! 12624: ALCS1 MOV XR,DNAMP SET UPDATED STORAGE POINTER ! 12625: ZER -(XR) STORE ZERO CHARS IN LAST WORD ! 12626: DCA WA DECREMENT LENGTH ! 12627: SUB WA,XR POINT BACK TO START OF BLOCK ! 12628: MOV =B$SCL,(XR) SET TYPE WORD ! 12629: MOV WC,SCLEN(XR) STORE LENGTH IN CHARS ! 12630: EXI RETURN TO ALOCS CALLER ! 12631: * ! 12632: * COME HERE IF STRING IS TOO LONG ! 12633: * ! 12634: ALCS2 ERB 205,STRING LENGTH EXCEEDS VALUE OF MAXLNGTH KEYWORD ! 12635: ENP END PROCEDURE ALOCS ! 12636: EJC ! 12637: * ! 12638: * ALOST -- ALLOCATE SPACE IN STATIC REGION ! 12639: * ! 12640: * (WA) LENGTH REQUIRED IN BYTES ! 12641: * JSR ALOST CALL TO ALLOCATE SPACE ! 12642: * (XR) POINTER TO ALLOCATED BLOCK ! 12643: * (WB) DESTROYED ! 12644: * ! 12645: * NOTE THAT THE CODING ENSURES THAT THE RESULTING VALUE ! 12646: * OF STATE IS ALWAYS LESS THAN DNAMB. THIS FACT IS USED ! 12647: * IN TESTING A VARIABLE NAME FOR BEING IN THE STATIC REGION ! 12648: * ! 12649: ALOST PRC E,0 ENTRY POINT ! 12650: * ! 12651: * MERGE BACK HERE AFTER ALLOCATING NEW CHUNK ! 12652: * ! 12653: ALST1 MOV STATE,XR POINT TO CURRENT END OF AREA ! 12654: AOV WA,XR,ALST2 POINT BEYOND PROPOSED BLOCK ! 12655: BGE XR,DNAMB,ALST2 JUMP IF OVERLAP WITH DYNAMIC AREA ! 12656: MOV XR,STATE ELSE STORE NEW POINTER ! 12657: SUB WA,XR POINT BACK TO START OF BLOCK ! 12658: EXI RETURN TO ALOST CALLER ! 12659: * ! 12660: * HERE IF NO ROOM, PREPARE TO MOVE DYNAMIC STORAGE UP ! 12661: * ! 12662: ALST2 MOV WA,ALSTA SAVE WA ! 12663: BGE WA,*E$STS,ALST3 SKIP IF REQUESTED CHUNK IS LARGE ! 12664: MOV *E$STS,WA ELSE SET TO GET LARGE ENOUGH CHUNK ! 12665: * ! 12666: * HERE WITH AMOUNT TO MOVE UP IN WA ! 12667: * ! 12668: ALST3 JSR ALLOC ALLOCATE BLOCK TO ENSURE ROOM ! 12669: MOV XR,DNAMP AND DELETE IT ! 12670: MOV WA,WB COPY MOVE UP AMOUNT ! 12671: JSR GBCOL CALL GBCOL TO MOVE DYNAMIC AREA UP ! 12672: MOV ALSTA,WA RESTORE WA ! 12673: BRN ALST1 LOOP BACK TO TRY AGAIN ! 12674: ENP END PROCEDURE ALOST ! 12675: EJC ! 12676: .IF .CNBF ! 12677: .ELSE ! 12678: * ! 12679: * APNDB -- APPEND STRING TO BUFFER ! 12680: * ! 12681: * THIS ROUTINE IS USED BY BUFFER HANDLING ROUTINES TO ! 12682: * APPEND DATA TO AN EXISTING BFBLK. ! 12683: * ! 12684: * (XR) EXISTING BCBLK TO BE APPENDED ! 12685: * (XL) CONVERTABLE TO STRING ! 12686: * JSR APNDB CALL TO APPEND TO BUFFER ! 12687: * PPM LOC THREAD IF (XL) CANT BE CONVERTED ! 12688: * PPM LOC IF NOT ENOUGH ROOM ! 12689: * (WA,WB) DESTROYED ! 12690: * ! 12691: * IF MORE CHARACTERS ARE SPECIFIED THAN CAN BE INSERTED, ! 12692: * THEN NO ACTION IS TAKEN AND THE SECOND RETURN IS TAKEN. ! 12693: * ! 12694: APNDB PRC E,2 ENTRY POINT ! 12695: MOV BCLEN(XR),WA LOAD OFFSET TO INSERT ! 12696: ZER WB REPLACE SECTION IS NULL ! 12697: JSR INSBF CALL TO INSERT AT END ! 12698: PPM APN01 CONVERT ERROR ! 12699: PPM APN02 NO ROOM ! 12700: EXI RETURN TO CALLER ! 12701: * ! 12702: * HERE TO TAKE CONVERT FAILURE EXIT ! 12703: * ! 12704: APN01 EXI 1 RETURN TO CALLER ALTERNATE ! 12705: * ! 12706: * HERE FOR NO FIT EXIT ! 12707: * ! 12708: APN02 EXI 2 ALTERNATE EXIT TO CALLER ! 12709: ENP END PROCEDURE APNDB ! 12710: EJC ! 12711: .FI ! 12712: * ! 12713: * ARITH -- FETCH ARITHMETIC OPERANDS ! 12714: * ! 12715: * ARITH IS USED BY FUNCTIONS AND OPERATORS WHICH EXPECT ! 12716: * TWO NUMERIC ARGUMENTS (OPERANDS) WHICH MUST BOTH BE ! 12717: * INTEGER OR BOTH BE REAL. ARITH FETCHES TWO ARGUMENTS FROM ! 12718: * THE STACK AND PERFORMS ANY NECESSARY CONVERSIONS. ! 12719: * ! 12720: * 1(XS) FIRST ARGUMENT (LEFT OPERAND) ! 12721: * 0(XS) SECOND ARGUMENT (RIGHT OPERAND) ! 12722: * JSR ARITH CALL TO FETCH NUMERIC ARGUMENTS ! 12723: * PPM LOC TRANSFER LOC FOR OPND 1 NON-NUMERIC ! 12724: * PPM LOC TRANSFER LOC FOR OPND 2 NON-NUMERIC ! 12725: .IF .CNRA ! 12726: .ELSE ! 12727: * PPM LOC TRANSFER LOC FOR REAL OPERANDS ! 12728: .FI ! 12729: * ! 12730: * FOR INTEGER ARGS, CONTROL RETURNS PAST THE PARAMETERS ! 12731: * ! 12732: * (IA) LEFT OPERAND VALUE ! 12733: * (XR) PTR TO ICBLK FOR LEFT OPERAND ! 12734: * (XL) PTR TO ICBLK FOR RIGHT OPERAND ! 12735: * (XS) POPPED TWICE ! 12736: * (WA,WB,RA) DESTROYED ! 12737: .IF .CNRA ! 12738: .ELSE ! 12739: * ! 12740: * FOR REAL ARGUMENTS, CONTROL RETURNS TO THE LOCATION ! 12741: * SPECIFIED BY THE THIRD PARAMETER. ! 12742: * ! 12743: * (RA) LEFT OPERAND VALUE ! 12744: * (XR) PTR TO RCBLK FOR LEFT OPERAND ! 12745: * (XL) PTR TO RCBLK FOR RIGHT OPERAND ! 12746: * (WA,WB,WC) DESTROYED ! 12747: * (XS) POPPED TWICE ! 12748: .FI ! 12749: EJC ! 12750: * ! 12751: * ARITH (CONTINUED) ! 12752: * ! 12753: * ENTRY POINT ! 12754: * ! 12755: .IF .CNRA ! 12756: ARITH PRC N,2 ENTRY POINT ! 12757: .ELSE ! 12758: ARITH PRC N,3 ENTRY POINT ! 12759: .FI ! 12760: MOV (XS)+,XL LOAD RIGHT OPERAND ! 12761: MOV (XS)+,XR LOAD LEFT OPERAND ! 12762: MOV (XL),WA GET RIGHT OPERAND TYPE WORD ! 12763: BEQ WA,=B$ICL,ARTH1 JUMP IF INTEGER ! 12764: .IF .CNRA ! 12765: .ELSE ! 12766: BEQ WA,=B$RCL,ARTH4 JUMP IF REAL ! 12767: .FI ! 12768: MOV XR,-(XS) ELSE REPLACE LEFT ARG ON STACK ! 12769: MOV XL,XR COPY LEFT ARG POINTER ! 12770: JSR GTNUM CONVERT TO NUMERIC ! 12771: PPM ARTH6 JUMP IF UNCONVERTIBLE ! 12772: MOV XR,XL ELSE COPY CONVERTED RESULT ! 12773: MOV (XL),WA GET RIGHT OPERAND TYPE WORD ! 12774: MOV (XS)+,XR RELOAD LEFT ARGUMENT ! 12775: .IF .CNRA ! 12776: .ELSE ! 12777: BEQ WA,=B$RCL,ARTH4 JUMP IF RIGHT ARG IS REAL ! 12778: .FI ! 12779: * ! 12780: * HERE IF RIGHT ARG IS AN INTEGER ! 12781: * ! 12782: ARTH1 BNE (XR),=B$ICL,ARTH3 JUMP IF LEFT ARG NOT INTEGER ! 12783: * ! 12784: * EXIT FOR INTEGER CASE ! 12785: * ! 12786: ARTH2 LDI ICVAL(XR) LOAD LEFT OPERAND VALUE ! 12787: EXI RETURN TO ARITH CALLER ! 12788: * ! 12789: * HERE FOR RIGHT OPERAND INTEGER, LEFT OPERAND NOT ! 12790: * ! 12791: ARTH3 JSR GTNUM CONVERT LEFT ARG TO NUMERIC ! 12792: PPM ARTH7 JUMP IF NOT CONVERTIBLE ! 12793: BEQ WA,=B$ICL,ARTH2 JUMP BACK IF INTEGER-INTEGER ! 12794: .IF .CNRA ! 12795: .ELSE ! 12796: * ! 12797: * HERE WE MUST CONVERT REAL-INTEGER TO REAL-REAL ! 12798: * ! 12799: MOV XR,-(XS) PUT LEFT ARG BACK ON STACK ! 12800: LDI ICVAL(XL) LOAD RIGHT ARGUMENT VALUE ! 12801: ITR CONVERT TO REAL ! 12802: JSR RCBLD GET REAL BLOCK FOR RIGHT ARG, MERGE ! 12803: MOV XR,XL COPY RIGHT ARG PTR ! 12804: MOV (XS)+,XR LOAD LEFT ARGUMENT ! 12805: BRN ARTH5 MERGE FOR REAL-REAL CASE ! 12806: EJC ! 12807: * ! 12808: * ARITH (CONTINUED) ! 12809: * ! 12810: * HERE IF RIGHT ARGUMENT IS REAL ! 12811: * ! 12812: ARTH4 BEQ (XR),=B$RCL,ARTH5 JUMP IF LEFT ARG REAL ! 12813: JSR GTREA ELSE CONVERT TO REAL ! 12814: PPM ARTH7 ERROR IF UNCONVERTIBLE ! 12815: * ! 12816: * HERE FOR REAL-REAL ! 12817: * ! 12818: ARTH5 LDR RCVAL(XR) LOAD LEFT OPERAND VALUE ! 12819: EXI 3 TAKE REAL-REAL EXIT ! 12820: .FI ! 12821: * ! 12822: * HERE FOR ERROR CONVERTING RIGHT ARGUMENT ! 12823: * ! 12824: ARTH6 ICA XS POP UNWANTED LEFT ARG ! 12825: EXI 2 TAKE APPROPRIATE ERROR EXIT ! 12826: * ! 12827: * HERE FOR ERROR CONVERTING LEFT OPERAND ! 12828: * ! 12829: ARTH7 EXI 1 TAKE APPROPRIATE ERROR RETURN ! 12830: ENP END PROCEDURE ARITH ! 12831: EJC ! 12832: * ! 12833: * ASIGN -- PERFORM ASSIGNMENT ! 12834: * ! 12835: * ASIGN PERFORMS THE ASSIGNMENT OF A VALUE TO A VARIABLE ! 12836: * WITH APPROPRIATE CHECKS FOR OUTPUT ASSOCIATIONS AND ! 12837: * VALUE TRACE ASSOCIATIONS WHICH ARE EXECUTED AS REQUIRED. ! 12838: * ASIGN ALSO HANDLES THE SPECIAL CASES OF ASSIGNMENT TO ! 12839: * PATTERN AND EXPRESSION VARIABLES. ! 12840: * ! 12841: * (WB) VALUE TO BE ASSIGNED ! 12842: * (XL) BASE POINTER FOR VARIABLE ! 12843: * (WA) OFFSET FOR VARIABLE ! 12844: * JSR ASIGN CALL TO ASSIGN VALUE TO VARIABLE ! 12845: * PPM LOC TRANSFER LOC FOR FAILURE ! 12846: * (XR,XL,WA,WB,WC) DESTROYED ! 12847: * (RA) DESTROYED ! 12848: * ! 12849: * FAILURE OCCURS IF THE EVALUATION OF AN EXPRESSION ! 12850: * ASSOCIATED WITH AN EXPRESSION VARIABLE FAILS. ! 12851: * ! 12852: ASIGN PRC R,1 ENTRY POINT (RECURSIVE) ! 12853: * ! 12854: * MERGE BACK HERE TO ASSIGN RESULT TO EXPRESSION VARIABLE. ! 12855: * ! 12856: ASG01 ADD WA,XL POINT TO VARIABLE VALUE ! 12857: MOV (XL),XR LOAD VARIABLE VALUE ! 12858: BEQ (XR),=B$TRT,ASG02 JUMP IF TRAPPED ! 12859: MOV WB,(XL) ELSE PERFORM ASSIGNMENT ! 12860: ZER XL CLEAR GARBAGE VALUE IN XL ! 12861: EXI AND RETURN TO ASIGN CALLER ! 12862: * ! 12863: * HERE IF VALUE IS TRAPPED ! 12864: * ! 12865: ASG02 SUB WA,XL RESTORE NAME BASE ! 12866: BEQ XR,=TRBKV,ASG14 JUMP IF KEYWORD VARIABLE ! 12867: BNE XR,=TRBEV,ASG04 JUMP IF NOT EXPRESSION VARIABLE ! 12868: * ! 12869: * HERE FOR ASSIGNMENT TO EXPRESSION VARIABLE ! 12870: * ! 12871: MOV EVEXP(XL),XR POINT TO EXPRESSION ! 12872: MOV WB,-(XS) STORE VALUE TO ASSIGN ON STACK ! 12873: MOV =NUM01,WB SET FOR EVALUATION BY NAME ! 12874: JSR EVALX EVALUATE EXPRESSION BY NAME ! 12875: PPM ASG03 JUMP IF EVALUATION FAILS ! 12876: MOV (XS)+,WB ELSE RELOAD VALUE TO ASSIGN ! 12877: BRN ASG01 LOOP BACK TO PERFORM ASSIGNMENT ! 12878: EJC ! 12879: * ! 12880: * ASIGN (CONTINUED) ! 12881: * ! 12882: * HERE FOR FAILURE DURING EXPRESSION EVALUATION ! 12883: * ! 12884: ASG03 ICA XS REMOVE STACKED VALUE ENTRY ! 12885: EXI 1 TAKE FAILURE EXIT ! 12886: * ! 12887: * HERE IF NOT KEYWORD OR EXPRESSION VARIABLE ! 12888: * ! 12889: ASG04 MOV XR,-(XS) SAVE PTR TO FIRST TRBLK ! 12890: * ! 12891: * LOOP TO CHASE DOWN TRBLK CHAIN AND ASSIGN VALUE AT END ! 12892: * ! 12893: ASG05 MOV XR,WC SAVE PTR TO THIS TRBLK ! 12894: MOV TRNXT(XR),XR POINT TO NEXT TRBLK ! 12895: BEQ (XR),=B$TRT,ASG05 LOOP BACK IF ANOTHER TRBLK ! 12896: MOV WC,XR ELSE POINT BACK TO LAST TRBLK ! 12897: MOV WB,TRVAL(XR) STORE VALUE AT END OF CHAIN ! 12898: MOV (XS)+,XR RESTORE PTR TO FIRST TRBLK ! 12899: * ! 12900: * LOOP TO PROCESS TRBLK ENTRIES ON CHAIN ! 12901: * ! 12902: ASG06 MOV TRTYP(XR),WB LOAD TYPE CODE OF TRBLK ! 12903: BEQ WB,=TRTVL,ASG08 JUMP IF VALUE TRACE ! 12904: BEQ WB,=TRTOU,ASG10 JUMP IF OUTPUT ASSOCIATION ! 12905: * ! 12906: * HERE TO MOVE TO NEXT TRBLK ON CHAIN ! 12907: * ! 12908: ASG07 MOV TRNXT(XR),XR POINT TO NEXT TRBLK ON CHAIN ! 12909: BEQ (XR),=B$TRT,ASG06 LOOP BACK IF ANOTHER TRBLK ! 12910: EXI ELSE END OF CHAIN, RETURN TO CALLER ! 12911: * ! 12912: * HERE TO PROCESS VALUE TRACE ! 12913: * ! 12914: ASG08 BZE KVTRA,ASG07 IGNORE VALUE TRACE IF TRACE OFF ! 12915: DCV KVTRA ELSE DECREMENT TRACE COUNT ! 12916: BZE TRFNC(XR),ASG09 JUMP IF PRINT TRACE ! 12917: JSR TRXEQ ELSE EXECUTE FUNCTION TRACE ! 12918: BRN ASG07 AND LOOP BACK ! 12919: EJC ! 12920: * ! 12921: * ASIGN (CONTINUED) ! 12922: * ! 12923: * HERE FOR PRINT TRACE ! 12924: * ! 12925: ASG09 JSR PRTSN PRINT STATEMENT NUMBER ! 12926: JSR PRTNV PRINT NAME = VALUE ! 12927: BRN ASG07 LOOP BACK FOR NEXT TRBLK ! 12928: * ! 12929: * HERE FOR OUTPUT ASSOCIATION ! 12930: * ! 12931: ASG10 BZE KVOUP,ASG07 IGNORE OUTPUT ASSOC IF OUTPUT OFF ! 12932: MOV XR,XL ELSE COPY TRBLK POINTER ! 12933: MOV TRVAL(WC),-(XS) STACK VALUE TO OUTPUT (SGD01) ! 12934: JSR GTSTG CONVERT TO STRING ! 12935: PPM ASG12 GET DATATYPE NAME IF UNCONVERTIBLE ! 12936: * ! 12937: * MERGE WITH STRING FOR OUTPUT ! 12938: * ! 12939: ASG11 MOV TRFPT(XL),WA FCBLK PTR ! 12940: BZE WA,ASG13 JUMP IF STANDARD OUTPUT FILE ! 12941: * ! 12942: * HERE FOR OUTPUT TO NON-STANDARD OUTPUT FILE ! 12943: * ! 12944: JSR SYSOU CALL SYSTEM OUTPUT ROUTINE ! 12945: ERR 206,OUTPUT CAUSED FILE OVERFLOW ! 12946: ERR 207,OUTPUT CAUSED NON-RECOVERABLE ERROR ! 12947: EXI ELSE ALL DONE, RETURN TO CALLER ! 12948: * ! 12949: * IF NOT PRINTABLE, GET DATATYPE NAME INSTEAD ! 12950: * ! 12951: ASG12 JSR DTYPE CALL DATATYPE ROUTINE ! 12952: BRN ASG11 MERGE ! 12953: * ! 12954: * HERE TO PRINT A STRING ON THE PRINTER ! 12955: * ! 12956: ASG13 JSR PRTST PRINT STRING VALUE ! 12957: BEQ TRTER(XL),=V$TER,ASG20 JUMP IF TERMINAL OUTPUT ! 12958: JSR PRTNL END OF LINE ! 12959: EXI RETURN TO CALLER ! 12960: EJC ! 12961: * ! 12962: * ASIGN (CONTINUED) ! 12963: * ! 12964: * HERE FOR KEYWORD ASSIGNMENT ! 12965: * ! 12966: ASG14 MOV KVNUM(XL),XL LOAD KEYWORD NUMBER ! 12967: BEQ XL,=K$ETX,ASG19 JUMP IF ERRTEXT ! 12968: MOV WB,XR COPY VALUE TO BE ASSIGNED ! 12969: JSR GTINT CONVERT TO INTEGER ! 12970: ERR 208,KEYWORD VALUE ASSIGNED IS NOT INTEGER ! 12971: LDI ICVAL(XR) ELSE LOAD VALUE ! 12972: BEQ XL,=K$STL,ASG16 JUMP IF SPECIAL CASE OF STLIMIT ! 12973: MFI WA,ASG18 ELSE GET ADDR INTEGER, TEST OVFLOW ! 12974: BGE WA,MXLEN,ASG18 FAIL IF TOO LARGE ! 12975: BEQ XL,=K$ERT,ASG17 JUMP IF SPECIAL CASE OF ERRTYPE ! 12976: .IF .CNPF ! 12977: .ELSE ! 12978: BEQ XL,=K$PFL,ASG21 JUMP IF SPECIAL CASE OF PROFILE ! 12979: .FI ! 12980: BLT XL,=K$P$$,ASG15 JUMP UNLESS PROTECTED ! 12981: ERB 209,KEYWORD IN ASSIGNMENT IS PROTECTED ! 12982: * ! 12983: * HERE TO DO ASSIGNMENT IF NOT PROTECTED ! 12984: * ! 12985: ASG15 MOV WA,KVABE(XL) STORE NEW VALUE ! 12986: EXI RETURN TO ASIGN CALLER ! 12987: * ! 12988: * HERE FOR SPECIAL CASE OF STLIMIT ! 12989: * ! 12990: * SINCE STCOUNT IS MAINTAINED AS (STLIMIT-STCOUNT) ! 12991: * IT IS ALSO NECESSARY TO MODIFY STCOUNT APPROPRIATELY. ! 12992: * ! 12993: ASG16 SBI KVSTL SUBTRACT OLD LIMIT ! 12994: ADI KVSTC ADD OLD COUNTER ! 12995: STI KVSTC STORE NEW COUNTER VALUE ! 12996: LDI ICVAL(XR) RELOAD NEW LIMIT VALUE ! 12997: STI KVSTL STORE NEW LIMIT VALUE ! 12998: EXI RETURN TO ASIGN CALLER ! 12999: * ! 13000: * HERE FOR SPECIAL CASE OF ERRTYPE ! 13001: * ! 13002: ASG17 BLE WA,=NINI9,ERROR OK TO SIGNAL IF IN RANGE ! 13003: * ! 13004: * HERE IF VALUE ASSIGNED IS OUT OF RANGE ! 13005: * ! 13006: ASG18 ERB 210,KEYWORD VALUE ASSIGNED IS NEGATIVE OR TOO LARGE ! 13007: * ! 13008: * HERE FOR SPECIAL CASE OF ERRTEXT ! 13009: * ! 13010: ASG19 MOV WB,-(XS) STACK VALUE ! 13011: JSR GTSTG CONVERT TO STRING ! 13012: ERR 211,VALUE ASSIGNED TO KEYWORD ERRTEXT NOT A STRING ! 13013: MOV XR,R$ETX MAKE ASSIGNMENT ! 13014: EXI RETURN TO CALLER ! 13015: * ! 13016: * PRINT STRING TO TERMINAL ! 13017: * ! 13018: ASG20 JSR PRTTR PRINT ! 13019: EXI RETURN ! 13020: * ! 13021: .IF .CNPF ! 13022: .ELSE ! 13023: * HERE FOR KEYWORD PROFILE ! 13024: * ! 13025: ASG21 BGT WA,=NUM02,ASG18 MOAN IF NOT 0,1, OR 2 ! 13026: BZE WA,ASG15 JUST ASSIGN IF ZERO ! 13027: BZE PFDMP,ASG22 BRANCH IF FIRST ASSIGNMENT ! 13028: BEQ WA,PFDMP,ASG23 ALSO IF SAME VALUE AS BEFORE ! 13029: ERB 268,INCONSISTENT VALUE ASSIGNED TO KEYWORD PROFILE ! 13030: * ! 13031: ASG22 MOV WA,PFDMP NOTE VALUE ON FIRST ASSIGNMENT ! 13032: ASG23 JSR SYSTM GET THE TIME ! 13033: STI PFSTM FUDGE SOME KIND OF START TIME ! 13034: BRN ASG15 AND GO ASSIGN ! 13035: .FI ! 13036: ENP END PROCEDURE ASIGN ! 13037: EJC ! 13038: * ! 13039: * ASINP -- ASSIGN DURING PATTERN MATCH ! 13040: * ! 13041: * ASINP IS LIKE ASIGN AND HAS A SIMILAR CALLING SEQUENCE ! 13042: * AND EFFECT. THE DIFFERENCE IS THAT THE GLOBAL PATTERN ! 13043: * VARIABLES ARE SAVED AND RESTORED IF REQUIRED. ! 13044: * ! 13045: * (XL) BASE POINTER FOR VARIABLE ! 13046: * (WA) OFFSET FOR VARIABLE ! 13047: * (WB) VALUE TO BE ASSIGNED ! 13048: * JSR ASINP CALL TO ASSIGN VALUE TO VARIABLE ! 13049: * PPM LOC TRANSFER LOC IF FAILURE ! 13050: * (XR,XL) DESTROYED ! 13051: * (WA,WB,WC,RA) DESTROYED ! 13052: * ! 13053: ASINP PRC R,1 ENTRY POINT, RECURSIVE ! 13054: ADD WA,XL POINT TO VARIABLE ! 13055: MOV (XL),XR LOAD CURRENT CONTENTS ! 13056: BEQ (XR),=B$TRT,ASNP1 JUMP IF TRAPPED ! 13057: MOV WB,(XL) ELSE PERFORM ASSIGNMENT ! 13058: ZER XL CLEAR GARBAGE VALUE IN XL ! 13059: EXI RETURN TO ASINP CALLER ! 13060: * ! 13061: * HERE IF VARIABLE IS TRAPPED ! 13062: * ! 13063: ASNP1 SUB WA,XL RESTORE BASE POINTER ! 13064: MOV PMSSL,-(XS) STACK SUBJECT STRING LENGTH ! 13065: MOV PMHBS,-(XS) STACK HISTORY STACK BASE PTR ! 13066: MOV R$PMS,-(XS) STACK SUBJECT STRING POINTER ! 13067: MOV PMDFL,-(XS) STACK DOT FLAG ! 13068: JSR ASIGN CALL FULL-BLOWN ASSIGNMENT ROUTINE ! 13069: PPM ASNP2 JUMP IF FAILURE ! 13070: MOV (XS)+,PMDFL RESTORE DOT FLAG ! 13071: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER ! 13072: MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER ! 13073: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH ! 13074: EXI RETURN TO ASINP CALLER ! 13075: * ! 13076: * HERE IF FAILURE IN ASIGN CALL ! 13077: * ! 13078: ASNP2 MOV (XS)+,PMDFL RESTORE DOT FLAG ! 13079: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER ! 13080: MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER ! 13081: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH ! 13082: EXI 1 TAKE FAILURE EXIT ! 13083: ENP END PROCEDURE ASINP ! 13084: EJC ! 13085: * ! 13086: * BLKLN -- DETERMINE LENGTH OF BLOCK ! 13087: * ! 13088: * BLKLN DETERMINES THE LENGTH OF A BLOCK IN DYNAMIC STORE. ! 13089: * ! 13090: * (WA) FIRST WORD OF BLOCK ! 13091: * (XR) POINTER TO BLOCK ! 13092: * JSR BLKLN CALL TO GET BLOCK LENGTH ! 13093: * (WA) LENGTH OF BLOCK IN BYTES ! 13094: * (XL) DESTROYED ! 13095: * ! 13096: * BLKLN IS USED BY THE GARBAGE COLLECTOR AND IS NOT ! 13097: * PERMITTED TO CALL GBCOL DIRECTLY OR INDIRECTLY. ! 13098: * ! 13099: * THE FIRST WORD STORED IN THE BLOCK (I.E. AT XR) MAY ! 13100: * BE ANYTHING, BUT THE CONTENTS OF WA MUST BE CORRECT. ! 13101: * ! 13102: BLKLN PRC E,0 ENTRY POINT ! 13103: MOV WA,XL COPY FIRST WORD ! 13104: LEI XL GET ENTRY ID (BL$XX) ! 13105: BSW XL,BL$$$,BLN00 SWITCH ON BLOCK TYPE ! 13106: IFF BL$AR,BLN01 ARBLK ! 13107: .IF .CNBF ! 13108: .ELSE ! 13109: IFF BL$BC,BLN04 BCBLK ! 13110: IFF BL$BF,BLN11 BFBLK ! 13111: .FI ! 13112: IFF BL$CD,BLN01 CDBLK ! 13113: IFF BL$DF,BLN01 DFBLK ! 13114: IFF BL$EF,BLN01 EFBLK ! 13115: IFF BL$EX,BLN01 EXBLK ! 13116: IFF BL$PF,BLN01 PFBLK ! 13117: IFF BL$TB,BLN01 TBBLK ! 13118: IFF BL$VC,BLN01 VCBLK ! 13119: IFF BL$EV,BLN03 EVBLK ! 13120: IFF BL$KV,BLN03 KVBLK ! 13121: IFF BL$P0,BLN02 P0BLK ! 13122: IFF BL$SE,BLN02 SEBLK ! 13123: IFF BL$NM,BLN03 NMBLK ! 13124: IFF BL$P1,BLN03 P1BLK ! 13125: IFF BL$P2,BLN04 P2BLK ! 13126: IFF BL$TE,BLN04 TEBLK ! 13127: IFF BL$FF,BLN05 FFBLK ! 13128: IFF BL$TR,BLN05 TRBLK ! 13129: IFF BL$CT,BLN06 CTBLK ! 13130: IFF BL$IC,BLN07 ICBLK ! 13131: IFF BL$PD,BLN08 PDBLK ! 13132: .IF .CNRA ! 13133: .ELSE ! 13134: IFF BL$RC,BLN09 RCBLK ! 13135: .FI ! 13136: IFF BL$SC,BLN10 SCBLK ! 13137: ESW END OF JUMP TABLE ON BLOCK TYPE ! 13138: EJC ! 13139: * ! 13140: * BLKLN (CONTINUED) ! 13141: * ! 13142: * HERE FOR BLOCKS WITH LENGTH IN SECOND WORD ! 13143: * ! 13144: BLN00 MOV 1(XR),WA LOAD LENGTH ! 13145: EXI RETURN TO BLKLN CALLER ! 13146: * ! 13147: * HERE FOR LENGTH IN THIRD WORD (AR,CD,DF,EF,EX,PF,TB,VC) ! 13148: * ! 13149: BLN01 MOV 2(XR),WA LOAD LENGTH FROM THIRD WORD ! 13150: EXI RETURN TO BLKLN CALLER ! 13151: * ! 13152: * HERE FOR TWO WORD BLOCKS (P0,SE) ! 13153: * ! 13154: BLN02 MOV *NUM02,WA LOAD LENGTH (TWO WORDS) ! 13155: EXI RETURN TO BLKLN CALLER ! 13156: * ! 13157: * HERE FOR THREE WORD BLOCKS (NM,P1,EV,KV) ! 13158: * ! 13159: BLN03 MOV *NUM03,WA LOAD LENGTH (THREE WORDS) ! 13160: EXI RETURN TO BLKLN CALLER ! 13161: * ! 13162: * HERE FOR FOUR WORD BLOCKS (P2,TE,BC) ! 13163: * ! 13164: BLN04 MOV *NUM04,WA LOAD LENGTH (FOUR WORDS) ! 13165: EXI RETURN TO BLKLN CALLER ! 13166: * ! 13167: * HERE FOR FIVE WORD BLOCKS (FF,TR) ! 13168: * ! 13169: BLN05 MOV *NUM05,WA LOAD LENGTH ! 13170: EXI RETURN TO BLKLN CALLER ! 13171: EJC ! 13172: * ! 13173: * BLKLN (CONTINUED) ! 13174: * ! 13175: * HERE FOR CTBLK ! 13176: * ! 13177: BLN06 MOV *CTSI$,WA SET SIZE OF CTBLK ! 13178: EXI RETURN TO BLKLN CALLER ! 13179: * ! 13180: * HERE FOR ICBLK ! 13181: * ! 13182: BLN07 MOV *ICSI$,WA SET SIZE OF ICBLK ! 13183: EXI RETURN TO BLKLN CALLER ! 13184: * ! 13185: * HERE FOR PDBLK ! 13186: * ! 13187: BLN08 MOV PDDFP(XR),XL POINT TO DFBLK ! 13188: MOV DFPDL(XL),WA LOAD PDBLK LENGTH FROM DFBLK ! 13189: EXI RETURN TO BLKLN CALLER ! 13190: .IF .CNRA ! 13191: .ELSE ! 13192: * ! 13193: * HERE FOR RCBLK ! 13194: * ! 13195: BLN09 MOV *RCSI$,WA SET SIZE OF RCBLK ! 13196: EXI RETURN TO BLKLN CALLER ! 13197: .FI ! 13198: * ! 13199: * HERE FOR SCBLK ! 13200: * ! 13201: BLN10 MOV SCLEN(XR),WA LOAD LENGTH IN CHARACTERS ! 13202: CTB WA,SCSI$ CALCULATE LENGTH IN BYTES ! 13203: EXI RETURN TO BLKLN CALLER ! 13204: .IF .CNBF ! 13205: .ELSE ! 13206: * ! 13207: * HERE FOR BFBLK ! 13208: * ! 13209: BLN11 MOV BFALC(XR),WA GET ALLOCATION IN BYTES ! 13210: CTB WA,BFSI$ CALCULATE LENGTH IN BYTES ! 13211: EXI RETURN TO BLKLN CALLER ! 13212: .FI ! 13213: ENP END PROCEDURE BLKLN ! 13214: EJC ! 13215: * ! 13216: * COPYB -- COPY A BLOCK ! 13217: * ! 13218: * (XS) BLOCK TO BE COPIED ! 13219: * JSR COPYB CALL TO COPY BLOCK ! 13220: * PPM LOC RETURN IF BLOCK HAS NO IDVAL FIELD ! 13221: * NORMAL RETURN IF IDVAL FIELD ! 13222: * (XR) COPY OF BLOCK ! 13223: * (XS) POPPED ! 13224: * (XL,WA,WB,WC) DESTROYED ! 13225: * ! 13226: COPYB PRC N,1 ENTRY POINT ! 13227: MOV (XS),XR LOAD ARGUMENT ! 13228: BEQ XR,=NULLS,COP10 RETURN ARGUMENT IF IT IS NULL ! 13229: MOV (XR),WA ELSE LOAD TYPE WORD ! 13230: MOV WA,WB COPY TYPE WORD ! 13231: JSR BLKLN GET LENGTH OF ARGUMENT BLOCK ! 13232: MOV XR,XL COPY POINTER ! 13233: JSR ALLOC ALLOCATE BLOCK OF SAME SIZE ! 13234: MOV XR,(XS) STORE POINTER TO COPY ! 13235: MVW COPY CONTENTS OF OLD BLOCK TO NEW ! 13236: MOV (XS),XR RELOAD POINTER TO START OF COPY ! 13237: BEQ WB,=B$TBT,COP05 JUMP IF TABLE ! 13238: BEQ WB,=B$VCT,COP01 JUMP IF VECTOR ! 13239: BEQ WB,=B$PDT,COP01 JUMP IF PROGRAM DEFINED ! 13240: .IF .CNBF ! 13241: .ELSE ! 13242: BEQ WB,=B$BCT,COP11 JUMP IF BUFFER ! 13243: .FI ! 13244: BNE WB,=B$ART,COP10 RETURN COPY IF NOT ARRAY ! 13245: * ! 13246: * HERE FOR ARRAY (ARBLK) ! 13247: * ! 13248: ADD AROFS(XR),XR POINT TO PROTOTYPE FIELD ! 13249: BRN COP02 JUMP TO MERGE ! 13250: * ! 13251: * HERE FOR VECTOR, PROGRAM DEFINED ! 13252: * ! 13253: COP01 ADD *PDFLD,XR POINT TO PDFLD = VCVLS ! 13254: * ! 13255: * MERGE HERE FOR ARBLK, VCBLK, PDBLK TO DELETE TRAP ! 13256: * BLOCKS FROM ALL VALUE FIELDS (THE COPY IS UNTRAPPED) ! 13257: * ! 13258: COP02 MOV (XR),XL LOAD NEXT POINTER ! 13259: * ! 13260: * LOOP TO GET VALUE AT END OF TRBLK CHAIN ! 13261: * ! 13262: COP03 BNE (XL),=B$TRT,COP04 JUMP IF NOT TRAPPED ! 13263: MOV TRVAL(XL),XL ELSE POINT TO NEXT VALUE ! 13264: BRN COP03 AND LOOP BACK ! 13265: EJC ! 13266: * ! 13267: * COPYB (CONTINUED) ! 13268: * ! 13269: * HERE WITH UNTRAPPED VALUE IN XL ! 13270: * ! 13271: COP04 MOV XL,(XR)+ STORE REAL VALUE, BUMP POINTER ! 13272: BNE XR,DNAMP,COP02 LOOP BACK IF MORE TO GO ! 13273: BRN COP09 ELSE JUMP TO EXIT ! 13274: * ! 13275: * HERE TO COPY A TABLE ! 13276: * ! 13277: COP05 ZER IDVAL(XR) ZERO ID TO STOP DUMP BLOWING UP ! 13278: MOV *TESI$,WA SET SIZE OF TEBLK ! 13279: MOV *TBBUK,WC SET INITIAL OFFSET ! 13280: * ! 13281: * LOOP THROUGH BUCKETS IN TABLE ! 13282: * ! 13283: COP06 MOV (XS),XR LOAD TABLE POINTER ! 13284: BEQ WC,TBLEN(XR),COP09 JUMP TO EXIT IF ALL DONE ! 13285: ADD WC,XR ELSE POINT TO NEXT BUCKET HEADER ! 13286: ICA WC BUMP OFFSET ! 13287: SUB *TENXT,XR SUBTRACT LINK OFFSET TO MERGE ! 13288: * ! 13289: * LOOP THROUGH TEBLKS ON ONE CHAIN ! 13290: * ! 13291: COP07 MOV TENXT(XR),XL LOAD POINTER TO NEXT TEBLK ! 13292: MOV (XS),TENXT(XR) SET END OF CHAIN POINTER IN CASE ! 13293: BEQ (XL),=B$TBT,COP06 BACK FOR NEXT BUCKET IF CHAIN END ! 13294: MOV XR,-(XS) ELSE STACK PTR TO PREVIOUS BLOCK ! 13295: MOV *TESI$,WA SET SIZE OF TEBLK ! 13296: JSR ALLOC ALLOCATE NEW TEBLK ! 13297: MOV XR,WB SAVE PTR TO NEW TEBLK ! 13298: MVW COPY OLD TEBLK TO NEW TEBLK ! 13299: MOV WB,XR RESTORE POINTER TO NEW TEBLK ! 13300: MOV (XS)+,XL RESTORE POINTER TO PREVIOUS BLOCK ! 13301: MOV XR,TENXT(XL) LINK NEW BLOCK TO PREVIOUS ! 13302: MOV XR,XL COPY POINTER TO NEW BLOCK ! 13303: * ! 13304: * LOOP TO SET REAL VALUE AFTER REMOVING TRAP CHAIN ! 13305: * ! 13306: COP08 MOV TEVAL(XL),XL LOAD VALUE ! 13307: BEQ (XL),=B$TRT,COP08 LOOP BACK IF TRAPPED ! 13308: MOV XL,TEVAL(XR) STORE UNTRAPPED VALUE IN TEBLK ! 13309: BRN COP07 BACK FOR NEXT TEBLK ! 13310: * ! 13311: * COMMON EXIT POINT ! 13312: * ! 13313: COP09 MOV (XS)+,XR LOAD POINTER TO BLOCK ! 13314: EXI RETURN ! 13315: * ! 13316: * ALTERNATIVE RETURN ! 13317: * ! 13318: COP10 EXI 1 RETURN ! 13319: EJC ! 13320: .IF .CNBF ! 13321: .ELSE ! 13322: * ! 13323: * HERE TO COPY BUFFER ! 13324: * ! 13325: COP11 MOV BCBUF(XR),XL GET BFBLK PTR ! 13326: MOV BFALC(XL),WA GET ALLOCATION ! 13327: CTB WA,BFSI$ SET TOTAL SIZE ! 13328: MOV XR,XL SAVE BCBLK PTR ! 13329: JSR ALLOC ALLOCATE BFBLK ! 13330: MOV BCBUF(XL),WB GET OLD BFBLK ! 13331: MOV XR,BCBUF(XL) SET POINTER TO NEW BFBLK ! 13332: MOV WB,XL POINT TO OLD BFBLK ! 13333: MVW COPY BFBLK TOO ! 13334: ZER XL CLEAR RUBBISH PTR ! 13335: BRN COP09 BRANCH TO EXIT ! 13336: .FI ! 13337: ENP END PROCEDURE COPYB ! 13338: * ! 13339: * CDGCG -- GENERATE CODE FOR COMPLEX GOTO ! 13340: * ! 13341: * USED BY CMPIL TO PROCESS COMPLEX GOTO TREE ! 13342: * ! 13343: * (WB) MUST BE COLLECTABLE ! 13344: * (XR) EXPRESSION POINTER ! 13345: * JSR CDGCG CALL TO GENERATE COMPLEX GOTO ! 13346: * (XL,XR,WA) DESTROYED ! 13347: * ! 13348: CDGCG PRC E,0 ENTRY POINT ! 13349: MOV CMOPN(XR),XL GET UNARY GOTO OPERATOR ! 13350: MOV CMROP(XR),XR POINT TO GOTO OPERAND ! 13351: BEQ XL,=OPDVD,CDGC2 JUMP IF DIRECT GOTO ! 13352: JSR CDGNM GENERATE OPND BY NAME IF NOT DIRECT ! 13353: * ! 13354: * RETURN POINT ! 13355: * ! 13356: CDGC1 MOV XL,WA GOTO OPERATOR ! 13357: JSR CDWRD GENERATE IT ! 13358: EXI RETURN TO CALLER ! 13359: * ! 13360: * DIRECT GOTO ! 13361: * ! 13362: CDGC2 JSR CDGVL GENERATE OPERAND BY VALUE ! 13363: BRN CDGC1 MERGE TO RETURN ! 13364: ENP END PROCEDURE CDGCG ! 13365: EJC ! 13366: * ! 13367: * CDGEX -- BUILD EXPRESSION BLOCK ! 13368: * ! 13369: * CDGEX IS PASSED A POINTER TO AN EXPRESSION TREE (SEE ! 13370: * EXPAN) AND RETURNS AN EXPRESSION (SEBLK OR EXBLK). ! 13371: * ! 13372: * (WC) SOME COLLECTABLE VALUE ! 13373: * (WB) INTEGER IN RANGE 0 LE X LE MXLEN ! 13374: * (XL) PTR TO EXPRESSION TREE ! 13375: * JSR CDGEX CALL TO BUILD EXPRESSION ! 13376: * (XR) PTR TO SEBLK OR EXBLK ! 13377: * (XL,WA,WB) DESTROYED ! 13378: * ! 13379: CDGEX PRC R,0 ENTRY POINT, RECURSIVE ! 13380: BLO (XL),=B$VR$,CDGX1 JUMP IF NOT VARIABLE ! 13381: * ! 13382: * HERE FOR NATURAL VARIABLE, BUILD SEBLK ! 13383: * ! 13384: MOV *SESI$,WA SET SIZE OF SEBLK ! 13385: JSR ALLOC ALLOCATE SPACE FOR SEBLK ! 13386: MOV =B$SEL,(XR) SET TYPE WORD ! 13387: MOV XL,SEVAR(XR) STORE VRBLK POINTER ! 13388: EXI RETURN TO CDGEX CALLER ! 13389: * ! 13390: * HERE IF NOT VARIABLE, BUILD EXBLK ! 13391: * ! 13392: CDGX1 MOV XL,XR COPY TREE POINTER ! 13393: MOV WC,-(XS) SAVE WC ! 13394: MOV CWCOF,XL SAVE CURRENT OFFSET ! 13395: MOV (XR),WA GET TYPE WORD ! 13396: BNE WA,=B$CMT,CDGX2 CALL BY VALUE IF NOT CMBLK ! 13397: BGE CMTYP(XR),=C$$NM,CDGX2 JUMP IF CMBLK ONLY BY VALUE ! 13398: EJC ! 13399: * ! 13400: * CDGEX (CONTINUED) ! 13401: * ! 13402: * HERE IF EXPRESSION CAN BE EVALUATED BY NAME ! 13403: * ! 13404: JSR CDGNM GENERATE CODE BY NAME ! 13405: MOV =ORNM$,WA LOAD RETURN BY NAME WORD ! 13406: BRN CDGX3 MERGE WITH VALUE CASE ! 13407: * ! 13408: * HERE IF EXPRESSION CAN ONLY BE EVALUATED BY VALUE ! 13409: * ! 13410: CDGX2 JSR CDGVL GENERATE CODE BY VALUE ! 13411: MOV =ORVL$,WA LOAD RETURN BY VALUE WORD ! 13412: * ! 13413: * MERGE HERE TO CONSTRUCT EXBLK ! 13414: * ! 13415: CDGX3 JSR CDWRD GENERATE RETURN WORD ! 13416: JSR EXBLD BUILD EXBLK ! 13417: MOV (XS)+,WC RESTORE WC ! 13418: EXI RETURN TO CDGEX CALLER ! 13419: ENP END PROCEDURE CDGEX ! 13420: EJC ! 13421: * ! 13422: * CDGNM -- GENERATE CODE BY NAME ! 13423: * ! 13424: * CDGNM IS CALLED DURING THE COMPILATION PROCESS TO ! 13425: * GENERATE CODE BY NAME FOR AN EXPRESSION. SEE CDBLK ! 13426: * DESCRIPTION FOR DETAILS OF CODE GENERATED. THE INPUT ! 13427: * TO CDGNM IS AN EXPRESSION TREE AS GENERATED BY EXPAN. ! 13428: * ! 13429: * CDGNM IS A RECURSIVE PROCEDURE WHICH PROCEEDS BY MAKING ! 13430: * RECURSIVE CALLS TO GENERATE CODE FOR OPERANDS. ! 13431: * ! 13432: * (WB) INTEGER IN RANGE 0 LE N LE DNAMB ! 13433: * (XR) PTR TO TREE GENERATED BY EXPAN ! 13434: * (WC) CONSTANT FLAG (SEE BELOW) ! 13435: * JSR CDGNM CALL TO GENERATE CODE BY NAME ! 13436: * (XR,WA) DESTROYED ! 13437: * (WC) SET NON-ZERO IF NON-CONSTANT ! 13438: * ! 13439: * WC IS SET TO A NON-ZERO (COLLECTABLE) VALUE IF THE ! 13440: * EXPRESSION FOR WHICH CODE IS GENERATED CANNOT BE ! 13441: * EVALUATED AT COMPILE TIME, OTHERWISE WC IS UNCHANGED. ! 13442: * ! 13443: * THE CODE IS GENERATED IN THE CURRENT CCBLK (SEE CDWRD). ! 13444: * ! 13445: CDGNM PRC R,0 ENTRY POINT, RECURSIVE ! 13446: MOV XL,-(XS) SAVE ENTRY XL ! 13447: MOV WB,-(XS) SAVE ENTRY WB ! 13448: CHK CHECK FOR STACK OVERFLOW ! 13449: MOV (XR),WA LOAD TYPE WORD ! 13450: BEQ WA,=B$CMT,CGN04 JUMP IF CMBLK ! 13451: BHI WA,=B$VR$,CGN02 JUMP IF SIMPLE VARIABLE ! 13452: * ! 13453: * MERGE HERE FOR OPERAND YIELDING VALUE (E.G. CONSTANT) ! 13454: * ! 13455: CGN01 ERB 212,SYNTAX ERROR. VALUE USED WHERE NAME IS REQUIRED ! 13456: * ! 13457: * HERE FOR NATURAL VARIABLE REFERENCE ! 13458: * ! 13459: CGN02 MOV =OLVN$,WA LOAD VARIABLE LOAD CALL ! 13460: JSR CDWRD GENERATE IT ! 13461: MOV XR,WA COPY VRBLK POINTER ! 13462: JSR CDWRD GENERATE VRBLK POINTER ! 13463: EJC ! 13464: * ! 13465: * CDGNM (CONTINUED) ! 13466: * ! 13467: * HERE TO EXIT WITH WC SET CORRECTLY ! 13468: * ! 13469: CGN03 MOV (XS)+,WB RESTORE ENTRY WB ! 13470: MOV (XS)+,XL RESTORE ENTRY XL ! 13471: EXI RETURN TO CDGNM CALLER ! 13472: * ! 13473: * HERE FOR CMBLK ! 13474: * ! 13475: CGN04 MOV XR,XL COPY CMBLK POINTER ! 13476: MOV CMTYP(XR),XR LOAD CMBLK TYPE ! 13477: BGE XR,=C$$NM,CGN01 ERROR IF NOT NAME OPERAND ! 13478: BSW XR,C$$NM ELSE SWITCH ON TYPE ! 13479: IFF C$ARR,CGN05 ARRAY REFERENCE ! 13480: IFF C$FNC,CGN08 FUNCTION CALL ! 13481: IFF C$DEF,CGN09 DEFERRED EXPRESSION ! 13482: IFF C$IND,CGN10 INDIRECT REFERENCE ! 13483: IFF C$KEY,CGN11 KEYWORD REFERENCE ! 13484: IFF C$UBO,CGN08 UNDEFINED BINARY OP ! 13485: IFF C$UUO,CGN08 UNDEFINED UNARY OP ! 13486: ESW END SWITCH ON CMBLK TYPE ! 13487: * ! 13488: * HERE TO GENERATE CODE FOR ARRAY REFERENCE ! 13489: * ! 13490: CGN05 MOV *CMOPN,WB POINT TO ARRAY OPERAND ! 13491: * ! 13492: * LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS ! 13493: * ! 13494: CGN06 JSR CMGEN GENERATE CODE FOR NEXT OPERAND ! 13495: MOV CMLEN(XL),WC LOAD LENGTH OF CMBLK ! 13496: BLT WB,WC,CGN06 LOOP TILL ALL GENERATED ! 13497: * ! 13498: * GENERATE APPROPRIATE ARRAY CALL ! 13499: * ! 13500: MOV =OAON$,WA LOAD ONE-SUBSCRIPT CASE CALL ! 13501: BEQ WC,*CMAR1,CGN07 JUMP TO EXIT IF ONE SUBSCRIPT CASE ! 13502: MOV =OAMN$,WA ELSE LOAD MULTI-SUBSCRIPT CASE CALL ! 13503: JSR CDWRD GENERATE CALL ! 13504: MOV WC,WA COPY CMBLK LENGTH ! 13505: BTW WA CONVERT TO WORDS ! 13506: SUB =CMVLS,WA CALCULATE NUMBER OF SUBSCRIPTS ! 13507: EJC ! 13508: * ! 13509: * CDGNM (CONTINUED) ! 13510: * ! 13511: * HERE TO EXIT GENERATING WORD (NON-CONSTANT) ! 13512: * ! 13513: CGN07 MNZ WC SET RESULT NON-CONSTANT ! 13514: JSR CDWRD GENERATE WORD ! 13515: BRN CGN03 BACK TO EXIT ! 13516: * ! 13517: * HERE TO GENERATE CODE FOR FUNCTIONS AND UNDEFINED OPRS ! 13518: * ! 13519: CGN08 MOV XL,XR COPY CMBLK POINTER ! 13520: JSR CDGVL GEN CODE BY VALUE FOR CALL ! 13521: MOV =OFNE$,WA GET EXTRA CALL FOR BY NAME ! 13522: BRN CGN07 BACK TO GENERATE AND EXIT ! 13523: * ! 13524: * HERE TO GENERATE CODE FOR DEFERED EXPRESSION ! 13525: * ! 13526: CGN09 MOV CMROP(XL),XR CHECK IF VARIABLE ! 13527: BHI (XR),=B$VR$,CGN02 TREAT *VARIABLE AS SIMPLE VAR ! 13528: MOV XR,XL COPY PTR TO EXPRESSION TREE ! 13529: JSR CDGEX ELSE BUILD EXBLK ! 13530: MOV =OLEX$,WA SET CALL TO LOAD EXPR BY NAME ! 13531: JSR CDWRD GENERATE IT ! 13532: MOV XR,WA COPY EXBLK POINTER ! 13533: JSR CDWRD GENERATE EXBLK POINTER ! 13534: BRN CGN03 BACK TO EXIT ! 13535: * ! 13536: * HERE TO GENERATE CODE FOR INDIRECT REFERENCE ! 13537: * ! 13538: CGN10 MOV CMROP(XL),XR GET OPERAND ! 13539: JSR CDGVL GENERATE CODE BY VALUE FOR IT ! 13540: MOV =OINN$,WA LOAD CALL FOR INDIRECT BY NAME ! 13541: BRN CGN12 MERGE ! 13542: * ! 13543: * HERE TO GENERATE CODE FOR KEYWORD REFERENCE ! 13544: * ! 13545: CGN11 MOV CMROP(XL),XR GET OPERAND ! 13546: JSR CDGNM GENERATE CODE BY NAME FOR IT ! 13547: MOV =OKWN$,WA LOAD CALL FOR KEYWORD BY NAME ! 13548: * ! 13549: * KEYWORD, INDIRECT MERGE HERE ! 13550: * ! 13551: CGN12 JSR CDWRD GENERATE CODE FOR OPERATOR ! 13552: BRN CGN03 EXIT ! 13553: ENP END PROCEDURE CDGNM ! 13554: EJC ! 13555: * ! 13556: * CDGVL -- GENERATE CODE BY VALUE ! 13557: * ! 13558: * CDGVL IS CALLED DURING THE COMPILATION PROCESS TO ! 13559: * GENERATE CODE BY VALUE FOR AN EXPRESSION. SEE CDBLK ! 13560: * DESCRIPTION FOR DETAILS OF THE CODE GENERATED. THE INPUT ! 13561: * TO CDGVL IS AN EXPRESSION TREE AS GENERATED BY EXPAN. ! 13562: * ! 13563: * CDGVL IS A RECURSIVE PROCEDURE WHICH PROCEEDS BY MAKING ! 13564: * RECURSIVE CALLS TO GENERATE CODE FOR OPERANDS. ! 13565: * ! 13566: * (WB) INTEGER IN RANGE 0 LE N LE DNAMB ! 13567: * (XR) PTR TO TREE GENERATED BY EXPAN ! 13568: * (WC) CONSTANT FLAG (SEE BELOW) ! 13569: * JSR CDGVL CALL TO GENERATE CODE BY VALUE ! 13570: * (XR,WA) DESTROYED ! 13571: * (WC) SET NON-ZERO IF NON-CONSTANT ! 13572: * ! 13573: * WC IS SET TO A NON-ZERO (COLLECTABLE) VALUE IF THE ! 13574: * EXPRESSION FOR WHICH CODE IS GENERATED CANNOT BE ! 13575: * EVALUATED AT COMPILE TIME, OTHERWISE WC IS UNCHANGED. ! 13576: * ! 13577: * IF WC IS NON-ZERO ON ENTRY, THEN PREEVALUATION IS NOT ! 13578: * ALLOWED REGARDLESS OF THE NATURE OF THE OPERAND. ! 13579: * ! 13580: * THE CODE IS GENERATED IN THE CURRENT CCBLK (SEE CDWRD). ! 13581: * ! 13582: CDGVL PRC R,0 ENTRY POINT, RECURSIVE ! 13583: MOV (XR),WA LOAD TYPE WORD ! 13584: BEQ WA,=B$CMT,CGV01 JUMP IF CMBLK ! 13585: BLT WA,=B$VRA,CGV00 JUMP IF ICBLK, RCBLK, SCBLK ! 13586: BNZ VRLEN(XR),CGVL0 JUMP IF NOT SYSTEM VARIABLE ! 13587: MOV XR,-(XS) STACK XR ! 13588: MOV VRSVP(XR),XR POINT TO SVBLK ! 13589: MOV SVBIT(XR),WA GET SVBLK PROPERTY BITS ! 13590: MOV (XS)+,XR RECOVER XR ! 13591: ANB BTCKW,WA CHECK IF CONSTANT KEYWORD ! 13592: NZB WA,CGV00 JUMP IF CONSTANT KEYWORD ! 13593: * ! 13594: * HERE FOR VARIABLE VALUE REFERENCE ! 13595: * ! 13596: CGVL0 MNZ WC INDICATE NON-CONSTANT VALUE ! 13597: * ! 13598: * MERGE HERE FOR SIMPLE CONSTANT (ICBLK,RCBLK,SCBLK) ! 13599: * AND FOR VARIABLES CORRESPONDING TO CONSTANT KEYWORDS. ! 13600: * ! 13601: CGV00 MOV XR,WA COPY PTR TO VAR OR CONSTANT ! 13602: JSR CDWRD GENERATE AS CODE WORD ! 13603: EXI RETURN TO CALLER ! 13604: EJC ! 13605: * ! 13606: * CDGVL (CONTINUED) ! 13607: * ! 13608: * HERE FOR TREE NODE (CMBLK) ! 13609: * ! 13610: CGV01 MOV WB,-(XS) SAVE ENTRY WB ! 13611: MOV XL,-(XS) SAVE ENTRY XL ! 13612: MOV WC,-(XS) SAVE ENTRY CONSTANT FLAG ! 13613: MOV CWCOF,-(XS) SAVE INITIAL CODE OFFSET ! 13614: CHK CHECK FOR STACK OVERFLOW ! 13615: * ! 13616: * PREPARE TO GENERATE CODE FOR CMBLK. WC IS SET TO THE ! 13617: * VALUE OF CSWNO (ZERO IF -OPTIMISE, 1 IF -NOOPT) TO ! 13618: * START WITH AND IS RESET NON-ZERO FOR ANY NON-CONSTANT ! 13619: * CODE GENERATED. IF IT IS STILL ZERO AFTER GENERATING ALL ! 13620: * THE CMBLK CODE, THEN ITS VALUE IS COMPUTED AS THE RESULT. ! 13621: * ! 13622: MOV XR,XL COPY CMBLK POINTER ! 13623: MOV CMTYP(XR),XR LOAD CMBLK TYPE ! 13624: MOV CSWNO,WC RESET CONSTANT FLAG ! 13625: BLE XR,=C$PR$,CGV02 JUMP IF NOT PREDICATE VALUE ! 13626: MNZ WC ELSE FORCE NON-CONSTANT CASE ! 13627: * ! 13628: * HERE WITH WC SET APPROPRIATELY ! 13629: * ! 13630: CGV02 BSW XR,C$$NV SWITCH TO APPROPRIATE GENERATOR ! 13631: IFF C$ARR,CGV03 ARRAY REFERENCE ! 13632: IFF C$FNC,CGV05 FUNCTION CALL ! 13633: IFF C$DEF,CGV14 DEFERRED EXPRESSION ! 13634: IFF C$SEL,CGV15 SELECTION ! 13635: IFF C$IND,CGV31 INDIRECT REFERENCE ! 13636: IFF C$KEY,CGV27 KEYWORD REFERENCE ! 13637: IFF C$UBO,CGV29 UNDEFINED BINOP ! 13638: IFF C$UUO,CGV30 UNDEFINED UNOP ! 13639: IFF C$BVL,CGV18 BINOPS WITH VAL OPDS ! 13640: IFF C$ALT,CGV18 ALTERNATION ! 13641: IFF C$UVL,CGV19 UNOPS WITH VALU OPND ! 13642: IFF C$ASS,CGV21 ASSIGNMENT ! 13643: IFF C$CNC,CGV24 CONCATENATION ! 13644: IFF C$CNP,CGV24 CONCATENATION (NOT PATTERN MATCH) ! 13645: IFF C$UNM,CGV27 UNOPS WITH NAME OPND ! 13646: IFF C$BVN,CGV26 BINARY $ AND . ! 13647: IFF C$INT,CGV31 INTERROGATION ! 13648: IFF C$NEG,CGV28 NEGATION ! 13649: IFF C$PMT,CGV18 PATTERN MATCH ! 13650: ESW END SWITCH ON CMBLK TYPE ! 13651: EJC ! 13652: * ! 13653: * CDGVL (CONTINUED) ! 13654: * ! 13655: * HERE TO GENERATE CODE FOR ARRAY REFERENCE ! 13656: * ! 13657: CGV03 MOV *CMOPN,WB SET OFFSET TO ARRAY OPERAND ! 13658: * ! 13659: * LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS ! 13660: * ! 13661: CGV04 JSR CMGEN GEN VALUE CODE FOR NEXT OPERAND ! 13662: MOV CMLEN(XL),WC LOAD CMBLK LENGTH ! 13663: BLT WB,WC,CGV04 LOOP BACK IF MORE TO GO ! 13664: * ! 13665: * GENERATE CALL TO APPROPRIATE ARRAY REFERENCE ROUTINE ! 13666: * ! 13667: MOV =OAOV$,WA SET ONE SUBSCRIPT CALL IN CASE ! 13668: BEQ WC,*CMAR1,CGV32 JUMP TO EXIT IF 1-SUB CASE ! 13669: MOV =OAMV$,WA ELSE SET CALL FOR MULTI-SUBSCRIPTS ! 13670: JSR CDWRD GENERATE CALL ! 13671: MOV WC,WA COPY LENGTH OF CMBLK ! 13672: SUB *CMVLS,WA SUBTRACT STANDARD LENGTH ! 13673: BTW WA GET NUMBER OF WORDS ! 13674: BRN CGV32 JUMP TO GENERATE SUBSCRIPT COUNT ! 13675: * ! 13676: * HERE TO GENERATE CODE FOR FUNCTION CALL ! 13677: * ! 13678: CGV05 MOV *CMVLS,WB SET OFFSET TO FIRST ARGUMENT ! 13679: * ! 13680: * LOOP TO GENERATE CODE FOR ARGUMENTS ! 13681: * ! 13682: CGV06 BEQ WB,CMLEN(XL),CGV07 JUMP IF ALL GENERATED ! 13683: JSR CMGEN ELSE GEN VALUE CODE FOR NEXT ARG ! 13684: BRN CGV06 BACK TO GENERATE NEXT ARGUMENT ! 13685: * ! 13686: * HERE TO GENERATE ACTUAL FUNCTION CALL ! 13687: * ! 13688: CGV07 SUB *CMVLS,WB GET NUMBER OF ARG PTRS (BYTES) ! 13689: BTW WB CONVERT BYTES TO WORDS ! 13690: MOV CMOPN(XL),XR LOAD FUNCTION VRBLK POINTER ! 13691: BNZ VRLEN(XR),CGV12 JUMP IF NOT SYSTEM FUNCTION ! 13692: MOV VRSVP(XR),XL LOAD SVBLK PTR IF SYSTEM VAR ! 13693: MOV SVBIT(XL),WA LOAD BIT MASK ! 13694: ANB BTFFC,WA TEST FOR FAST FUNCTION CALL ALLOWED ! 13695: ZRB WA,CGV12 JUMP IF NOT ! 13696: EJC ! 13697: * ! 13698: * CDGVL (CONTINUED) ! 13699: * ! 13700: * HERE IF FAST FUNCTION CALL IS ALLOWED ! 13701: * ! 13702: MOV SVBIT(XL),WA RELOAD BIT INDICATORS ! 13703: ANB BTPRE,WA TEST FOR PREEVALUATION OK ! 13704: NZB WA,CGV08 JUMP IF PREEVALUATION PERMITTED ! 13705: MNZ WC ELSE SET RESULT NON-CONSTANT ! 13706: * ! 13707: * TEST FOR CORRECT NUMBER OF ARGS FOR FAST CALL ! 13708: * ! 13709: CGV08 MOV VRFNC(XR),XL LOAD PTR TO SVFNC FIELD ! 13710: MOV FARGS(XL),WA LOAD SVNAR FIELD VALUE ! 13711: BEQ WA,WB,CGV11 JUMP IF ARGUMENT COUNT IS CORRECT ! 13712: BHI WA,WB,CGV09 JUMP IF TOO FEW ARGUMENTS GIVEN ! 13713: * ! 13714: * HERE IF TOO MANY ARGUMENTS, PREPARE TO GENERATE O$POPS ! 13715: * ! 13716: SUB WA,WB GET NUMBER OF EXTRA ARGS ! 13717: LCT WB,WB SET AS COUNT TO CONTROL LOOP ! 13718: MOV =OPOP$,WA SET POP CALL ! 13719: BRN CGV10 JUMP TO COMMON LOOP ! 13720: * ! 13721: * HERE IF TOO FEW ARGUMENTS, PREPARE TO GENERATE NULLS ! 13722: * ! 13723: CGV09 SUB WB,WA GET NUMBER OF MISSING ARGUMENTS ! 13724: LCT WB,WA LOAD AS COUNT TO CONTROL LOOP ! 13725: MOV =NULLS,WA LOAD PTR TO NULL CONSTANT ! 13726: * ! 13727: * LOOP TO GENERATE CALLS TO FIX ARGUMENT COUNT ! 13728: * ! 13729: CGV10 JSR CDWRD GENERATE ONE CALL ! 13730: BCT WB,CGV10 LOOP TILL ALL GENERATED ! 13731: * ! 13732: * HERE AFTER ADJUSTING ARG COUNT AS REQUIRED ! 13733: * ! 13734: CGV11 MOV XL,WA COPY POINTER TO SVFNC FIELD ! 13735: BRN CGV36 JUMP TO GENERATE CALL ! 13736: EJC ! 13737: * ! 13738: * CDGVL (CONTINUED) ! 13739: * ! 13740: * COME HERE IF FAST CALL IS NOT PERMITTED ! 13741: * ! 13742: CGV12 MOV =OFNS$,WA SET ONE ARG CALL IN CASE ! 13743: BEQ WB,=NUM01,CGV13 JUMP IF ONE ARG CASE ! 13744: MOV =OFNC$,WA ELSE LOAD CALL FOR MORE THAN 1 ARG ! 13745: JSR CDWRD GENERATE IT ! 13746: MOV WB,WA COPY ARGUMENT COUNT ! 13747: * ! 13748: * ONE ARG CASE MERGES HERE ! 13749: * ! 13750: CGV13 JSR CDWRD GENERATE =O$FNS OR ARG COUNT ! 13751: MOV XR,WA COPY VRBLK POINTER ! 13752: BRN CGV32 JUMP TO GENERATE VRBLK PTR ! 13753: * ! 13754: * HERE FOR DEFERRED EXPRESSION ! 13755: * ! 13756: CGV14 MOV CMROP(XL),XL POINT TO EXPRESSION TREE ! 13757: JSR CDGEX BUILD EXBLK OR SEBLK ! 13758: MOV XR,WA COPY BLOCK PTR ! 13759: JSR CDWRD GENERATE PTR TO EXBLK OR SEBLK ! 13760: BRN CGV34 JUMP TO EXIT, CONSTANT TEST ! 13761: * ! 13762: * HERE TO GENERATE CODE FOR SELECTION ! 13763: * ! 13764: CGV15 ZER -(XS) ZERO PTR TO CHAIN OF FORWARD JUMPS ! 13765: ZER -(XS) ZERO PTR TO PREV O$SLC FORWARD PTR ! 13766: MOV *CMVLS,WB POINT TO FIRST ALTERNATIVE ! 13767: MOV =OSLA$,WA SET INITIAL CODE WORD ! 13768: * ! 13769: * 0(XS) IS THE OFFSET TO THE PREVIOUS WORD ! 13770: * WHICH REQUIRES FILLING IN WITH AN ! 13771: * OFFSET TO THE FOLLOWING O$SLC,O$SLD ! 13772: * ! 13773: * 1(XS) IS THE HEAD OF A CHAIN OF OFFSET ! 13774: * POINTERS INDICATING THOSE LOCATIONS ! 13775: * TO BE FILLED WITH OFFSETS PAST ! 13776: * THE END OF ALL THE ALTERNATIVES ! 13777: * ! 13778: CGV16 JSR CDWRD GENERATE O$SLC (O$SLA FIRST TIME) ! 13779: MOV CWCOF,(XS) SET CURRENT LOC AS PTR TO FILL IN ! 13780: JSR CDWRD GENERATE GARBAGE WORD THERE FOR NOW ! 13781: JSR CMGEN GEN VALUE CODE FOR ALTERNATIVE ! 13782: MOV =OSLB$,WA LOAD O$SLB POINTER ! 13783: JSR CDWRD GENERATE O$SLB CALL ! 13784: MOV 1(XS),WA LOAD OLD CHAIN PTR ! 13785: MOV CWCOF,1(XS) SET CURRENT LOC AS NEW CHAIN HEAD ! 13786: JSR CDWRD GENERATE FORWARD CHAIN LINK ! 13787: EJC ! 13788: * ! 13789: * CDGVL (CONTINUED) ! 13790: * ! 13791: * NOW TO FILL IN THE SKIP OFFSET TO O$SLC,O$SLD ! 13792: * ! 13793: MOV (XS),XR LOAD OFFSET TO WORD TO PLUG ! 13794: ADD R$CCB,XR POINT TO ACTUAL LOCATION TO PLUG ! 13795: MOV CWCOF,(XR) PLUG PROPER OFFSET IN ! 13796: MOV =OSLC$,WA LOAD O$SLC PTR FOR NEXT ALTERNATIVE ! 13797: MOV WB,XR COPY OFFSET (DESTROY GARBAGE XR) ! 13798: ICA XR BUMP EXTRA TIME FOR TEST ! 13799: BLT XR,CMLEN(XL),CGV16 LOOP BACK IF NOT LAST ALTERNATIVE ! 13800: * ! 13801: * HERE TO GENERATE CODE FOR LAST ALTERNATIVE ! 13802: * ! 13803: MOV =OSLD$,WA GET HEADER CALL ! 13804: JSR CDWRD GENERATE O$SLD CALL ! 13805: JSR CMGEN GENERATE CODE FOR LAST ALTERNATIVE ! 13806: ICA XS POP OFFSET PTR ! 13807: MOV (XS)+,XR LOAD CHAIN PTR ! 13808: * ! 13809: * LOOP TO PLUG OFFSETS PAST STRUCTURE ! 13810: * ! 13811: CGV17 ADD R$CCB,XR MAKE NEXT PTR ABSOLUTE ! 13812: MOV (XR),WA LOAD FORWARD PTR ! 13813: MOV CWCOF,(XR) PLUG REQUIRED OFFSET ! 13814: MOV WA,XR COPY FORWARD PTR ! 13815: BNZ WA,CGV17 LOOP BACK IF MORE TO GO ! 13816: BRN CGV33 ELSE JUMP TO EXIT (NOT CONSTANT) ! 13817: * ! 13818: * HERE FOR BINARY OPS WITH VALUE OPERANDS ! 13819: * ! 13820: CGV18 MOV CMLOP(XL),XR LOAD LEFT OPERAND POINTER ! 13821: JSR CDGVL GEN VALUE CODE FOR LEFT OPERAND ! 13822: * ! 13823: * HERE FOR UNARY OPS WITH VALUE OPERAND (BINOPS MERGE) ! 13824: * ! 13825: CGV19 MOV CMROP(XL),XR LOAD RIGHT (ONLY) OPERAND PTR ! 13826: JSR CDGVL GEN CODE BY VALUE ! 13827: EJC ! 13828: * ! 13829: * CDGVL (CONTINUED) ! 13830: * ! 13831: * MERGE HERE TO GENERATE OPERATOR CALL FROM CMOPN FIELD ! 13832: * ! 13833: CGV20 MOV CMOPN(XL),WA LOAD OPERATOR CALL POINTER ! 13834: BRN CGV36 JUMP TO GENERATE IT WITH CONS TEST ! 13835: * ! 13836: * HERE FOR ASSIGNMENT ! 13837: * ! 13838: CGV21 MOV CMLOP(XL),XR LOAD LEFT OPERAND POINTER ! 13839: BLO (XR),=B$VR$,CGV22 JUMP IF NOT VARIABLE ! 13840: * ! 13841: * HERE FOR ASSIGNMENT TO SIMPLE VARIABLE ! 13842: * ! 13843: MOV CMROP(XL),XR LOAD RIGHT OPERAND PTR ! 13844: JSR CDGVL GENERATE CODE BY VALUE ! 13845: MOV CMLOP(XL),WA RELOAD LEFT OPERAND VRBLK PTR ! 13846: ADD *VRSTO,WA POINT TO VRSTO FIELD ! 13847: BRN CGV32 JUMP TO GENERATE STORE PTR ! 13848: * ! 13849: * HERE IF NOT SIMPLE VARIABLE ASSIGNMENT ! 13850: * ! 13851: CGV22 JSR EXPAP TEST FOR PATTERN MATCH ON LEFT SIDE ! 13852: PPM CGV23 JUMP IF NOT PATTERN MATCH ! 13853: * ! 13854: * HERE FOR PATTERN REPLACEMENT ! 13855: * ! 13856: MOV CMROP(XR),CMLOP(XL) SAVE PATTERN PTR IN SAFE PLACE ! 13857: MOV CMLOP(XR),XR LOAD SUBJECT PTR ! 13858: JSR CDGNM GEN CODE BY NAME FOR SUBJECT ! 13859: MOV CMLOP(XL),XR LOAD PATTERN PTR ! 13860: JSR CDGVL GEN CODE BY VALUE FOR PATTERN ! 13861: MOV =OPMN$,WA LOAD MATCH BY NAME CALL ! 13862: JSR CDWRD GENERATE IT ! 13863: MOV CMROP(XL),XR LOAD REPLACEMENT VALUE PTR ! 13864: JSR CDGVL GEN CODE BY VALUE ! 13865: MOV =ORPL$,WA LOAD REPLACE CALL ! 13866: BRN CGV32 JUMP TO GEN AND EXIT (NOT CONSTANT) ! 13867: * ! 13868: * HERE FOR ASSIGNMENT TO COMPLEX VARIABLE ! 13869: * ! 13870: CGV23 MNZ WC INHIBIT PRE-EVALUATION ! 13871: JSR CDGNM GEN CODE BY NAME FOR LEFT SIDE ! 13872: BRN CGV31 MERGE WITH UNOP CIRCUIT ! 13873: EJC ! 13874: * ! 13875: * CDGVL (CONTINUED) ! 13876: * ! 13877: * HERE FOR CONCATENATION ! 13878: * ! 13879: CGV24 MOV CMLOP(XL),XR LOAD LEFT OPERAND PTR ! 13880: BNE (XR),=B$CMT,CGV18 ORDINARY BINOP IF NOT CMBLK ! 13881: MOV CMTYP(XR),WB LOAD CMBLK TYPE CODE ! 13882: BEQ WB,=C$INT,CGV25 SPECIAL CASE IF INTERROGATION ! 13883: BEQ WB,=C$NEG,CGV25 OR NEGATION ! 13884: BNE WB,=C$FNC,CGV18 ELSE ORDINARY BINOP IF NOT FUNCTION ! 13885: MOV CMOPN(XR),XR ELSE LOAD FUNCTION VRBLK PTR ! 13886: BNZ VRLEN(XR),CGV18 ORDINARY BINOP IF NOT SYSTEM VAR ! 13887: MOV VRSVP(XR),XR ELSE POINT TO SVBLK ! 13888: MOV SVBIT(XR),WA LOAD BIT INDICATORS ! 13889: ANB BTPRD,WA TEST FOR PREDICATE FUNCTION ! 13890: ZRB WA,CGV18 ORDINARY BINOP IF NOT ! 13891: * ! 13892: * HERE IF LEFT ARG OF CONCATENATION IS PREDICATE FUNCTION ! 13893: * ! 13894: CGV25 MOV CMLOP(XL),XR RELOAD LEFT ARG ! 13895: JSR CDGVL GEN CODE BY VALUE ! 13896: MOV =OPOP$,WA LOAD POP CALL ! 13897: JSR CDWRD GENERATE IT ! 13898: MOV CMROP(XL),XR LOAD RIGHT OPERAND ! 13899: JSR CDGVL GEN CODE BY VALUE AS RESULT CODE ! 13900: BRN CGV33 EXIT (NOT CONSTANT) ! 13901: * ! 13902: * HERE TO GENERATE CODE FOR PATTERN, IMMEDIATE ASSIGNMENT ! 13903: * ! 13904: CGV26 MOV CMLOP(XL),XR LOAD LEFT OPERAND ! 13905: JSR CDGVL GEN CODE BY VALUE, MERGE ! 13906: * ! 13907: * HERE FOR UNOPS WITH ARG BY NAME (BINARY $ . MERGE) ! 13908: * ! 13909: CGV27 MOV CMROP(XL),XR LOAD RIGHT OPERAND PTR ! 13910: JSR CDGNM GEN CODE BY NAME FOR RIGHT ARG ! 13911: MOV CMOPN(XL),XR GET OPERATOR CODE WORD ! 13912: BNE (XR),=O$KWV,CGV20 GEN CALL UNLESS KEYWORD VALUE ! 13913: EJC ! 13914: * ! 13915: * CDGVL (CONTINUED) ! 13916: * ! 13917: * HERE FOR KEYWORD BY VALUE. THIS IS CONSTANT ONLY IF ! 13918: * THE OPERAND IS ONE OF THE SPECIAL SYSTEM VARIABLES WITH ! 13919: * THE SVCKW BIT SET TO INDICATE A CONSTANT KEYWORD VALUE. ! 13920: * NOTE THAT THE ONLY CONSTANT OPERAND BY NAME IS A VARIABLE ! 13921: * ! 13922: BNZ WC,CGV20 GEN CALL IF NON-CONSTANT (NOT VAR) ! 13923: MNZ WC ELSE SET NON-CONSTANT IN CASE ! 13924: MOV CMROP(XL),XR LOAD PTR TO OPERAND VRBLK ! 13925: BNZ VRLEN(XR),CGV20 GEN (NON-CONSTANT) IF NOT SYS VAR ! 13926: MOV VRSVP(XR),XR ELSE LOAD PTR TO SVBLK ! 13927: MOV SVBIT(XR),WA LOAD BIT MASK ! 13928: ANB BTCKW,WA TEST FOR CONSTANT KEYWORD ! 13929: ZRB WA,CGV20 GO GEN IF NOT CONSTANT ! 13930: ZER WC ELSE SET RESULT CONSTANT ! 13931: BRN CGV20 AND JUMP BACK TO GENERATE CALL ! 13932: * ! 13933: * HERE TO GENERATE CODE FOR NEGATION ! 13934: * ! 13935: CGV28 MOV =ONTA$,WA GET INITIAL WORD ! 13936: JSR CDWRD GENERATE IT ! 13937: MOV CWCOF,WB SAVE NEXT OFFSET ! 13938: JSR CDWRD GENERATE GUNK WORD FOR NOW ! 13939: MOV CMROP(XL),XR LOAD RIGHT OPERAND PTR ! 13940: JSR CDGVL GEN CODE BY VALUE ! 13941: MOV =ONTB$,WA LOAD END OF EVALUATION CALL ! 13942: JSR CDWRD GENERATE IT ! 13943: MOV WB,XR COPY OFFSET TO WORD TO PLUG ! 13944: ADD R$CCB,XR POINT TO ACTUAL WORD TO PLUG ! 13945: MOV CWCOF,(XR) PLUG WORD WITH CURRENT OFFSET ! 13946: MOV =ONTC$,WA LOAD FINAL CALL ! 13947: BRN CGV32 JUMP TO GENERATE IT (NOT CONSTANT) ! 13948: * ! 13949: * HERE TO GENERATE CODE FOR UNDEFINED BINARY OPERATOR ! 13950: * ! 13951: CGV29 MOV CMLOP(XL),XR LOAD LEFT OPERAND PTR ! 13952: JSR CDGVL GENERATE CODE BY VALUE ! 13953: EJC ! 13954: * ! 13955: * CDGVL (CONTINUED) ! 13956: * ! 13957: * HERE TO GENERATE CODE FOR UNDEFINED UNARY OPERATOR ! 13958: * ! 13959: CGV30 MOV =C$UO$,WB SET UNOP CODE + 1 ! 13960: SUB CMTYP(XL),WB SET NUMBER OF ARGS (1 OR 2) ! 13961: * ! 13962: * MERGE HERE FOR UNDEFINED OPERATORS ! 13963: * ! 13964: MOV CMROP(XL),XR LOAD RIGHT (ONLY) OPERAND POINTER ! 13965: JSR CDGVL GEN VALUE CODE FOR RIGHT OPERAND ! 13966: MOV CMOPN(XL),XR LOAD POINTER TO OPERATOR DV ! 13967: MOV DVOPN(XR),XR LOAD POINTER OFFSET ! 13968: WTB XR CONVERT WORD OFFSET TO BYTES ! 13969: ADD =R$UBA,XR POINT TO PROPER FUNCTION PTR ! 13970: SUB *VRFNC,XR SET STANDARD FUNCTION OFFSET ! 13971: BRN CGV12 MERGE WITH FUNCTION CALL CIRCUIT ! 13972: * ! 13973: * HERE TO GENERATE CODE FOR INTERROGATION, INDIRECTION ! 13974: * ! 13975: CGV31 MNZ WC SET NON CONSTANT ! 13976: BRN CGV19 MERGE ! 13977: * ! 13978: * HERE TO EXIT GENERATING A WORD, RESULT NOT CONSTANT ! 13979: * ! 13980: CGV32 JSR CDWRD GENERATE WORD, MERGE ! 13981: * ! 13982: * HERE TO EXIT WITH NO WORD GENERATED, NOT CONSTANT ! 13983: * ! 13984: CGV33 MNZ WC INDICATE RESULT IS NOT CONSTANT ! 13985: * ! 13986: * COMMON EXIT POINT ! 13987: * ! 13988: CGV34 ICA XS POP INITIAL CODE OFFSET ! 13989: MOV (XS)+,WA RESTORE OLD CONSTANT FLAG ! 13990: MOV (XS)+,XL RESTORE ENTRY XL ! 13991: MOV (XS)+,WB RESTORE ENTRY WB ! 13992: BNZ WC,CGV35 JUMP IF NOT CONSTANT ! 13993: MOV WA,WC ELSE RESTORE ENTRY CONSTANT FLAG ! 13994: * ! 13995: * HERE TO RETURN AFTER DEALING WITH WC SETTING ! 13996: * ! 13997: CGV35 EXI RETURN TO CDGVL CALLER ! 13998: * ! 13999: * EXIT HERE TO GENERATE WORD AND TEST FOR CONSTANT ! 14000: * ! 14001: CGV36 JSR CDWRD GENERATE WORD ! 14002: BNZ WC,CGV34 JUMP TO EXIT IF NOT CONSTANT ! 14003: EJC ! 14004: * ! 14005: * CDGVL (CONTINUED) ! 14006: * ! 14007: * HERE TO PREEVALUATE CONSTANT SUB-EXPRESSION ! 14008: * ! 14009: MOV =ORVL$,WA LOAD CALL TO RETURN VALUE ! 14010: JSR CDWRD GENERATE IT ! 14011: MOV (XS),XL LOAD INITIAL CODE OFFSET ! 14012: JSR EXBLD BUILD EXBLK FOR EXPRESSION ! 14013: ZER WB SET TO EVALUATE BY VALUE ! 14014: JSR EVALX EVALUATE EXPRESSION ! 14015: PPM SHOULD NOT FAIL ! 14016: MOV (XR),WA LOAD TYPE WORD OF RESULT ! 14017: BLO WA,=P$AAA,CGV37 JUMP IF NOT PATTERN ! 14018: MOV =OLPT$,WA ELSE LOAD SPECIAL PATTERN LOAD CALL ! 14019: JSR CDWRD GENERATE IT ! 14020: * ! 14021: * MERGE HERE TO GENERATE POINTER TO RESULTING CONSTANT ! 14022: * ! 14023: CGV37 MOV XR,WA COPY CONSTANT POINTER ! 14024: JSR CDWRD GENERATE PTR ! 14025: ZER WC SET RESULT CONSTANT ! 14026: BRN CGV34 JUMP BACK TO EXIT ! 14027: ENP END PROCEDURE CDGVL ! 14028: EJC ! 14029: * ! 14030: * CDWRD -- GENERATE ONE WORD OF CODE ! 14031: * ! 14032: * CDWRD WRITES ONE WORD INTO THE CURRENT CODE BLOCK UNDER ! 14033: * CONSTRUCTION. A NEW, LARGER, BLOCK IS ALLOCATED IF THERE ! 14034: * IS INSUFFICIENT ROOM IN THE CURRENT BLOCK. CDWRD ENSURES ! 14035: * THAT THERE ARE AT LEAST THREE WORDS LEFT IN THE BLOCK ! 14036: * AFTER ENTERING THE NEW WORD. THIS GUARANTEES THAT ANY ! 14037: * EXTRA SPACE AT THE END CAN BE SPLIT OFF AS A CCBLK. ! 14038: * ! 14039: * (WA) WORD TO BE GENERATED ! 14040: * JSR CDWRD CALL TO GENERATE WORD ! 14041: * ! 14042: CDWRD PRC E,0 ENTRY POINT ! 14043: MOV XR,-(XS) SAVE ENTRY XR ! 14044: MOV WA,-(XS) SAVE CODE WORD TO BE GENERATED ! 14045: * ! 14046: * MERGE BACK HERE AFTER ALLOCATING LARGER BLOCK ! 14047: * ! 14048: CDWD1 MOV R$CCB,XR LOAD PTR TO CCBLK BEING BUILT ! 14049: BNZ XR,CDWD2 JUMP IF BLOCK ALLOCATED ! 14050: * ! 14051: * HERE WE ALLOCATE AN ENTIRELY FRESH BLOCK ! 14052: * ! 14053: MOV *E$CBS,WA LOAD INITIAL LENGTH ! 14054: JSR ALLOC ALLOCATE CCBLK ! 14055: MOV =B$CCT,(XR) STORE TYPE WORD ! 14056: MOV *CCCOD,CWCOF SET INITIAL OFFSET ! 14057: MOV WA,CCLEN(XR) STORE BLOCK LENGTH ! 14058: MOV XR,R$CCB STORE PTR TO NEW BLOCK ! 14059: * ! 14060: * HERE WE HAVE A BLOCK WE CAN USE ! 14061: * ! 14062: CDWD2 MOV CWCOF,WA LOAD CURRENT OFFSET ! 14063: ADD *NUM04,WA ADJUST FOR TEST (FOUR WORDS) ! 14064: BLO WA,CCLEN(XR),CDWD4 JUMP IF ROOM IN THIS BLOCK ! 14065: * ! 14066: * HERE IF NO ROOM IN CURRENT BLOCK ! 14067: * ! 14068: BGE WA,MXLEN,CDWD5 JUMP IF ALREADY AT MAX SIZE ! 14069: ADD *E$CBS,WA ELSE GET NEW SIZE ! 14070: MOV XL,-(XS) SAVE ENTRY XL ! 14071: MOV XR,XL COPY POINTER ! 14072: BLT WA,MXLEN,CDWD3 JUMP IF NOT TOO LARGE ! 14073: MOV MXLEN,WA ELSE RESET TO MAX ALLOWED SIZE ! 14074: EJC ! 14075: * ! 14076: * CDWRD (CONTINUED) ! 14077: * ! 14078: * HERE WITH NEW BLOCK SIZE IN WA ! 14079: * ! 14080: CDWD3 JSR ALLOC ALLOCATE NEW BLOCK ! 14081: MOV XR,R$CCB STORE POINTER TO NEW BLOCK ! 14082: MOV =B$CCT,(XR)+ STORE TYPE WORD IN NEW BLOCK ! 14083: MOV WA,(XR)+ STORE BLOCK LENGTH ! 14084: ADD *CCUSE,XL POINT TO CCUSE,CCCOD FIELDS IN OLD ! 14085: MOV (XL),WA LOAD CCUSE VALUE ! 14086: MVW COPY USEFUL WORDS FROM OLD BLOCK ! 14087: MOV (XS)+,XL RESTORE XL ! 14088: BRN CDWD1 MERGE BACK TO TRY AGAIN ! 14089: * ! 14090: * HERE WITH ROOM IN CURRENT BLOCK ! 14091: * ! 14092: CDWD4 MOV CWCOF,WA LOAD CURRENT OFFSET ! 14093: ICA WA GET NEW OFFSET ! 14094: MOV WA,CWCOF STORE NEW OFFSET ! 14095: MOV WA,CCUSE(XR) STORE IN CCBLK FOR GBCOL ! 14096: DCA WA RESTORE PTR TO THIS WORD ! 14097: ADD WA,XR POINT TO CURRENT ENTRY ! 14098: MOV (XS)+,WA RELOAD WORD TO GENERATE ! 14099: MOV WA,(XR) STORE WORD IN BLOCK ! 14100: MOV (XS)+,XR RESTORE ENTRY XR ! 14101: EXI RETURN TO CALLER ! 14102: * ! 14103: * HERE IF COMPILED CODE IS TOO LONG FOR CDBLK ! 14104: * ! 14105: CDWD5 ERB 213,SYNTAX ERROR. STATEMENT IS TOO COMPLICATED. ! 14106: ENP END PROCEDURE CDWRD ! 14107: EJC ! 14108: * ! 14109: * CMGEN -- GENERATE CODE FOR CMBLK PTR ! 14110: * ! 14111: * CMGEN IS A SUBSIDIARY PROCEDURE USED TO GENERATE VALUE ! 14112: * CODE FOR A CMBLK PTR FROM THE MAIN CODE GENERATORS. ! 14113: * ! 14114: * (XL) CMBLK POINTER ! 14115: * (WB) OFFSET TO POINTER IN CMBLK ! 14116: * JSR CMGEN CALL TO GENERATE CODE ! 14117: * (XR,WA) DESTROYED ! 14118: * (WB) BUMPED BY ONE WORD ! 14119: * ! 14120: CMGEN PRC R,0 ENTRY POINT, RECURSIVE ! 14121: MOV XL,XR COPY CMBLK POINTER ! 14122: ADD WB,XR POINT TO CMBLK POINTER ! 14123: MOV (XR),XR LOAD CMBLK POINTER ! 14124: JSR CDGVL GENERATE CODE BY VALUE ! 14125: ICA WB BUMP OFFSET ! 14126: EXI RETURN TO CALLER ! 14127: ENP END PROCEDURE CMGEN ! 14128: EJC ! 14129: * ! 14130: * CMPIL (COMPILE SOURCE CODE) ! 14131: * ! 14132: * CMPIL IS USED TO CONVERT SNOBOL4 SOURCE CODE TO INTERNAL ! 14133: * FORM (SEE CDBLK FORMAT). IT IS USED BOTH FOR THE INITIAL ! 14134: * COMPILE AND AT RUN TIME BY THE CODE AND CONVERT FUNCTIONS ! 14135: * THIS PROCEDURE HAS CONTROL FOR THE ENTIRE DURATION OF ! 14136: * INITIAL COMPILATION. AN ERROR IN ANY PROCEDURE CALLED ! 14137: * DURING COMPILATION WILL LEAD FIRST TO THE ERROR SECTION ! 14138: * AND ULTIMATELY BACK HERE FOR RESUMED COMPILATION. THE ! 14139: * RE-ENTRY POINTS AFTER AN ERROR ARE SPECIALLY LABELLED - ! 14140: * ! 14141: * CMPCE RESUME AFTER CONTROL CARD ERROR ! 14142: * CMPLE RESUME AFTER LABEL ERROR ! 14143: * CMPSE RESUME AFTER STATEMENT ERROR ! 14144: * ! 14145: * JSR CMPIL CALL TO COMPILE CODE ! 14146: * (XR) PTR TO CDBLK FOR ENTRY STATEMENT ! 14147: * (XL,WA,WB,WC,RA) DESTROYED ! 14148: * ! 14149: * THE FOLLOWING GLOBAL VARIABLES ARE REFERENCED ! 14150: * ! 14151: * CMPSN NUMBER OF NEXT STATEMENT ! 14152: * TO BE COMPILED. ! 14153: * ! 14154: * CSWXX CONTROL CARD SWITCH VALUES ARE ! 14155: * CHANGED WHEN RELEVANT CONTROL ! 14156: * CARDS ARE MET. ! 14157: * ! 14158: * CWCOF OFFSET TO NEXT WORD IN CODE BLOCK ! 14159: * BEING BUILT (SEE CDWRD). ! 14160: * ! 14161: * LSTSN NUMBER OF STATEMENT MOST RECENTLY ! 14162: * COMPILED (INITIALLY SET TO ZERO). ! 14163: * ! 14164: * R$CIM CURRENT (INITIAL) COMPILER IMAGE ! 14165: * (ZERO FOR INITIAL COMPILE CALL) ! 14166: * ! 14167: * R$CNI USED TO POINT TO FOLLOWING IMAGE. ! 14168: * (SEE READR PROCEDURE). ! 14169: * ! 14170: * SCNGO GOTO SWITCH FOR SCANE PROCEDURE ! 14171: * ! 14172: * SCNIL LENGTH OF CURRENT IMAGE EXCLUDING ! 14173: * CHARACTERS REMOVED BY -INPUT. ! 14174: * ! 14175: * SCNPT CURRENT SCAN OFFSET, SEE SCANE. ! 14176: * ! 14177: * SCNRS RESCAN SWITCH FOR SCANE PROCEDURE. ! 14178: * ! 14179: * SCNSE OFFSET (IN R$CIM) OF MOST RECENTLY ! 14180: * SCANNED ELEMENT. SET ZERO IF NOT ! 14181: * CURRENTLY SCANNING ITEMS ! 14182: EJC ! 14183: * ! 14184: * CMPIL (CONTINUED) ! 14185: * ! 14186: * STAGE STGIC INITIAL COMPILE IN PROGRESS ! 14187: * STGXC CODE/CONVERT COMPILE ! 14188: * STGEV BUILDING EXBLK FOR EVAL ! 14189: * STGXT EXECUTE TIME (OUTSIDE COMPILE) ! 14190: * STGCE INITIAL COMPILE AFTER END LINE ! 14191: * STGXE EXECUTE COMPILE AFTER END LINE ! 14192: * ! 14193: * CMPIL ALSO USES A FIXED NUMBER OF LOCATIONS ON THE ! 14194: * MAIN STACK AS FOLLOWS. (THE DEFINITIONS OF THE ACTUAL ! 14195: * OFFSETS ARE IN THE DEFINITIONS SECTION). ! 14196: * ! 14197: * CMSTM(XS) POINTER TO EXPAN TREE FOR BODY OF ! 14198: * STATEMENT (SEE EXPAN PROCEDURE). ! 14199: * ! 14200: * CMSGO(XS) POINTER TO TREE REPRESENTATION OF ! 14201: * SUCCESS GOTO (SEE PROCEDURE SCNGO)9 ! 14202: * ZERO IF NO SUCCESS GOTO IS GIVEN ! 14203: * ! 14204: * CMFGO(XS) LIKE CMSGO FOR FAILURE GOTO. ! 14205: * ! 14206: * CMCGO(XS) SET NON-ZERO ONLY IF THERE IS A ! 14207: * CONDITIONAL GOTO. USED FOR -FAIL, ! 14208: * -NOFAIL CODE GENERATION. ! 14209: * ! 14210: * CMPCD(XS) POINTER TO CDBLK FOR PREVIOUS ! 14211: * STATEMENT. ZERO FOR 1ST STATEMENT. ! 14212: * ! 14213: * CMFFP(XS) SET NON-ZERO IF CDFAL IN PREVIOUS ! 14214: * CDBLK NEEDS FILLING WITH FORWARD ! 14215: * POINTER, ELSE SET TO ZERO. ! 14216: * ! 14217: * CMFFC(XS) SAME AS CMFFP FOR CURRENT CDBLK ! 14218: * ! 14219: * CMSOP(XS) OFFSET TO WORD IN PREVIOUS CDBLK ! 14220: * TO BE FILLED IN WITH FORWARD PTR ! 14221: * TO NEXT CDBLK FOR SUCCESS GOTO. ! 14222: * ZERO IF NO FILL IN IS REQUIRED. ! 14223: * ! 14224: * CMSOC(XS) SAME AS CMSOP FOR CURRENT CDBLK. ! 14225: * ! 14226: * CMLBL(XS) POINTER TO VRBLK FOR LABEL OF ! 14227: * CURRENT STATEMENT. ZERO IF NO LABEL ! 14228: * ! 14229: * CMTRA(XS) POINTER TO CDBLK FOR ENTRY STMNT. ! 14230: EJC ! 14231: * ! 14232: * CMPIL (CONTINUED) ! 14233: * ! 14234: * ENTRY POINT ! 14235: * ! 14236: CMPIL PRC E,0 ENTRY POINT ! 14237: LCT WB,=CMNEN SET NUMBER OF STACK WORK LOCATIONS ! 14238: * ! 14239: * LOOP TO INITIALIZE STACK WORKING LOCATIONS ! 14240: * ! 14241: CMP00 ZER -(XS) STORE A ZERO, MAKE ONE ENTRY ! 14242: BCT WB,CMP00 LOOP BACK UNTIL ALL SET ! 14243: MOV XS,CMPXS SAVE STACK POINTER FOR ERROR SEC ! 14244: SSS CMPSS SAVE S-R STACK POINTER IF ANY ! 14245: * ! 14246: * LOOP THROUGH STATEMENTS ! 14247: * ! 14248: CMP01 MOV SCNPT,WB SET SCAN POINTER OFFSET ! 14249: MOV WB,SCNSE SET START OF ELEMENT LOCATION ! 14250: MOV =OCER$,WA POINT TO COMPILE ERROR CALL ! 14251: JSR CDWRD GENERATE AS TEMPORARY CDFAL ! 14252: BLT WB,SCNIL,CMP04 JUMP IF CHARS LEFT ON THIS IMAGE ! 14253: * ! 14254: * LOOP HERE AFTER COMMENT OR CONTROL CARD ! 14255: * ALSO SPECIAL ENTRY AFTER CONTROL CARD ERROR ! 14256: * ! 14257: CMPCE ZER XR CLEAR POSSIBLE GARBAGE XR VALUE ! 14258: BNE STAGE,=STGIC,CMP02 SKIP UNLESS INITIAL COMPILE ! 14259: JSR READR READ NEXT INPUT IMAGE ! 14260: BZE XR,CMP09 JUMP IF NO INPUT AVAILABLE ! 14261: JSR NEXTS ACQUIRE NEXT SOURCE IMAGE ! 14262: MOV CMPSN,LSTSN STORE STMT NO FOR USE BY LISTR ! 14263: ZER SCNPT RESET SCAN POINTER ! 14264: BRN CMP04 GO PROCESS IMAGE ! 14265: * ! 14266: * FOR EXECUTE TIME COMPILE, PERMIT EMBEDDED CONTROL CARDS ! 14267: * AND COMMENTS (BY SKIPPING TO NEXT SEMI-COLON) ! 14268: * ! 14269: CMP02 MOV R$CIM,XR GET CURRENT IMAGE ! 14270: MOV SCNPT,WB GET CURRENT OFFSET ! 14271: PLC XR,WB PREPARE TO GET CHARS ! 14272: * ! 14273: * SKIP TO SEMI-COLON ! 14274: * ! 14275: CMP03 LCH WC,(XR)+ GET CHAR ! 14276: ICV SCNPT ADVANCE OFFSET ! 14277: BEQ WC,=CH$SM,CMP04 SKIP IF SEMI-COLON FOUND ! 14278: BLT SCNPT,SCNIL,CMP03 LOOP IF MORE CHARS ! 14279: ZER XR CLEAR GARBAGE XR VALUE ! 14280: BRN CMP09 END OF IMAGE ! 14281: EJC ! 14282: * ! 14283: * CMPIL (CONTINUED) ! 14284: * ! 14285: * HERE WITH IMAGE AVAILABLE TO SCAN. NOTE THAT IF THE INPUT ! 14286: * STRING IS NULL, THEN EVERYTHING IS OK SINCE NULL IS ! 14287: * ACTUALLY ASSEMBLED AS A WORD OF BLANKS. ! 14288: * ! 14289: CMP04 MOV R$CIM,XR POINT TO CURRENT IMAGE ! 14290: MOV SCNPT,WB LOAD CURRENT OFFSET ! 14291: MOV WB,WA COPY FOR LABEL SCAN ! 14292: PLC XR,WB POINT TO FIRST CHARACTER ! 14293: LCH WC,(XR)+ LOAD FIRST CHARACTER ! 14294: BEQ WC,=CH$SM,CMP12 NO LABEL IF SEMICOLON ! 14295: BEQ WC,=CH$AS,CMPCE LOOP BACK IF COMMENT CARD ! 14296: BEQ WC,=CH$MN,CMP32 JUMP IF CONTROL CARD ! 14297: MOV R$CIM,R$CMP ABOUT TO DESTROY R$CIM ! 14298: MOV =CMLAB,XL POINT TO LABEL WORK STRING ! 14299: MOV XL,R$CIM SCANE IS TO SCAN WORK STRING ! 14300: PSC XL POINT TO FIRST CHARACTER POSITION ! 14301: SCH WC,(XL)+ STORE CHAR JUST LOADED ! 14302: MOV =CH$SM,WC GET A SEMICOLON ! 14303: SCH WC,(XL) STORE AFTER FIRST CHAR ! 14304: CSC XL FINISHED CHARACTER STORING ! 14305: ZER XL CLEAR POINTER ! 14306: ZER SCNPT START AT FIRST CHARACTER ! 14307: MOV SCNIL,-(XS) PRESERVE IMAGE LENGTH ! 14308: MOV =NUM02,SCNIL READ 2 CHARS AT MOST ! 14309: JSR SCANE SCAN FIRST CHAR FOR TYPE ! 14310: MOV (XS)+,SCNIL RESTORE IMAGE LENGTH ! 14311: MOV XL,WC NOTE RETURN CODE ! 14312: MOV R$CMP,XL GET OLD R$CIM ! 14313: MOV XL,R$CIM PUT IT BACK ! 14314: MOV WB,SCNPT REINSTATE OFFSET ! 14315: BNZ SCNBL,CMP12 BLANK SEEN - CANT BE LABEL ! 14316: MOV XL,XR POINT TO CURRENT IMAGE ! 14317: PLC XR,WB POINT TO FIRST CHAR AGAIN ! 14318: BEQ WC,=T$VAR,CMP06 OK IF LETTER ! 14319: BEQ WC,=T$CON,CMP06 OK IF DIGIT ! 14320: * ! 14321: * DROP IN OR JUMP FROM ERROR SECTION IF SCANE FAILED ! 14322: * ! 14323: CMPLE MOV R$CMP,R$CIM POINT TO BAD LINE ! 14324: ERB 214,BAD LABEL OR MISPLACED CONTINUATION LINE ! 14325: * ! 14326: * LOOP TO SCAN LABEL ! 14327: * ! 14328: CMP05 BEQ WC,=CH$SM,CMP07 SKIP IF SEMICOLON ! 14329: ICV WA BUMP OFFSET ! 14330: BEQ WA,SCNIL,CMP07 JUMP IF END OF IMAGE (LABEL END) ! 14331: EJC ! 14332: * ! 14333: * CMPIL (CONTINUED) ! 14334: * ! 14335: * ENTER LOOP AT THIS POINT ! 14336: * ! 14337: CMP06 LCH WC,(XR)+ ELSE LOAD NEXT CHARACTER ! 14338: .IF .CAHT ! 14339: BEQ WC,=CH$HT,CMP07 JUMP IF HORIZONTAL TAB ! 14340: .FI ! 14341: .IF .CAVT ! 14342: BEQ WC,=CH$VT,CMP07 JUMP IF VERTICAL TAB ! 14343: .FI ! 14344: BNE WC,=CH$BL,CMP05 LOOP BACK IF NON-BLANK ! 14345: * ! 14346: * HERE AFTER SCANNING OUT LABEL ! 14347: * ! 14348: CMP07 MOV WA,SCNPT SAVE UPDATED SCAN OFFSET ! 14349: SUB WB,WA GET LENGTH OF LABEL ! 14350: BZE WA,CMP12 SKIP IF LABEL LENGTH ZERO ! 14351: ZER XR CLEAR GARBAGE XR VALUE ! 14352: JSR SBSTR BUILD SCBLK FOR LABEL NAME ! 14353: JSR GTNVR LOCATE/CONTRUCT VRBLK ! 14354: PPM DUMMY (IMPOSSIBLE) ERROR RETURN ! 14355: MOV XR,CMLBL(XS) STORE LABEL POINTER ! 14356: BNZ VRLEN(XR),CMP11 JUMP IF NOT SYSTEM LABEL ! 14357: BNE VRSVP(XR),=V$END,CMP11 JUMP IF NOT END LABEL ! 14358: * ! 14359: * HERE FOR END LABEL SCANNED OUT ! 14360: * ! 14361: ADD =STGND,STAGE ADJUST STAGE APPROPRIATELY ! 14362: JSR SCANE SCAN OUT NEXT ELEMENT ! 14363: BEQ XL,=T$SMC,CMP10 JUMP IF END OF IMAGE ! 14364: BNE XL,=T$VAR,CMP08 ELSE ERROR IF NOT VARIABLE ! 14365: * ! 14366: * HERE CHECK FOR VALID INITIAL TRANSFER ! 14367: * ! 14368: BEQ VRLBL(XR),=STNDL,CMP08 JUMP IF NOT DEFINED (ERROR) ! 14369: MOV VRLBL(XR),CMTRA(XS) ELSE SET INITIAL ENTRY POINTER ! 14370: JSR SCANE SCAN NEXT ELEMENT ! 14371: BEQ XL,=T$SMC,CMP10 JUMP IF OK (END OF IMAGE) ! 14372: * ! 14373: * HERE FOR BAD TRANSFER LABEL ! 14374: * ! 14375: CMP08 ERB 215,SYNTAX ERROR. UNDEFINED OR ERRONEOUS ENTRY LABEL ! 14376: * ! 14377: * HERE FOR END OF INPUT (NO END LABEL DETECTED) ! 14378: * ! 14379: CMP09 ADD =STGND,STAGE ADJUST STAGE APPROPRIATELY ! 14380: BEQ STAGE,=STGXE,CMP10 JUMP IF CODE CALL (OK) ! 14381: ERB 216,SYNTAX ERROR. MISSING END LINE ! 14382: * ! 14383: * HERE AFTER PROCESSING END LINE (MERGE HERE ON END ERROR) ! 14384: * ! 14385: CMP10 MOV =OSTP$,WA SET STOP CALL POINTER ! 14386: JSR CDWRD GENERATE AS STATEMENT CALL ! 14387: BRN CMPSE JUMP TO GENERATE AS FAILURE ! 14388: EJC ! 14389: * ! 14390: * CMPIL (CONTINUED) ! 14391: * ! 14392: * HERE AFTER PROCESSING LABEL OTHER THAN END ! 14393: * ! 14394: CMP11 BNE STAGE,=STGIC,CMP12 JUMP IF CODE CALL - REDEF. OK ! 14395: BEQ VRLBL(XR),=STNDL,CMP12 ELSE CHECK FOR REDEFINITION ! 14396: ZER CMLBL(XS) LEAVE FIRST LABEL DECLN UNDISTURBED ! 14397: ERB 217,SYNTAX ERROR. DUPLICATE LABEL ! 14398: * ! 14399: * HERE AFTER DEALING WITH LABEL ! 14400: * ! 14401: CMP12 ZER WB SET FLAG FOR STATEMENT BODY ! 14402: JSR EXPAN GET TREE FOR STATEMENT BODY ! 14403: MOV XR,CMSTM(XS) STORE FOR LATER USE ! 14404: ZER CMSGO(XS) CLEAR SUCCESS GOTO POINTER ! 14405: ZER CMFGO(XS) CLEAR FAILURE GOTO POINTER ! 14406: ZER CMCGO(XS) CLEAR CONDITIONAL GOTO FLAG ! 14407: JSR SCANE SCAN NEXT ELEMENT ! 14408: BNE XL,=T$COL,CMP18 JUMP IT NOT COLON (NO GOTO) ! 14409: * ! 14410: * LOOP TO PROCESS GOTO FIELDS ! 14411: * ! 14412: CMP13 MNZ SCNGO SET GOTO FLAG ! 14413: JSR SCANE SCAN NEXT ELEMENT ! 14414: BEQ XL,=T$SMC,CMP31 JUMP IF NO FIELDS LEFT ! 14415: BEQ XL,=T$SGO,CMP14 JUMP IF S FOR SUCCESS GOTO ! 14416: BEQ XL,=T$FGO,CMP16 JUMP IF F FOR FAILURE GOTO ! 14417: * ! 14418: * HERE FOR UNCONDITIONAL GOTO (I.E. NOT F OR S) ! 14419: * ! 14420: MNZ SCNRS SET TO RESCAN ELEMENT NOT F,S ! 14421: JSR SCNGF SCAN OUT GOTO FIELD ! 14422: BNZ CMFGO(XS),CMP17 ERROR IF FGOTO ALREADY ! 14423: MOV XR,CMFGO(XS) ELSE SET AS FGOTO ! 14424: BRN CMP15 MERGE WITH SGOTO CIRCUIT ! 14425: * ! 14426: * HERE FOR SUCCESS GOTO ! 14427: * ! 14428: CMP14 JSR SCNGF SCAN SUCCESS GOTO FIELD ! 14429: MOV =NUM01,CMCGO(XS) SET CONDITIONAL GOTO FLAG ! 14430: * ! 14431: * UNCONTIONAL GOTO MERGES HERE ! 14432: * ! 14433: CMP15 BNZ CMSGO(XS),CMP17 ERROR IF SGOTO ALREADY GIVEN ! 14434: MOV XR,CMSGO(XS) ELSE SET SGOTO ! 14435: BRN CMP13 LOOP BACK FOR NEXT GOTO FIELD ! 14436: * ! 14437: * HERE FOR FAILURE GOTO ! 14438: * ! 14439: CMP16 JSR SCNGF SCAN GOTO FIELD ! 14440: MOV =NUM01,CMCGO(XS) SET CONDITONAL GOTO FLAG ! 14441: BNZ CMFGO(XS),CMP17 ERROR IF FGOTO ALREADY GIVEN ! 14442: MOV XR,CMFGO(XS) ELSE STORE FGOTO POINTER ! 14443: BRN CMP13 LOOP BACK FOR NEXT FIELD ! 14444: EJC ! 14445: * ! 14446: * CMPIL (CONTINUED) ! 14447: * ! 14448: * HERE FOR DUPLICATED GOTO FIELD ! 14449: * ! 14450: CMP17 ERB 218,SYNTAX ERROR. DUPLICATED GOTO FIELD ! 14451: * ! 14452: * HERE TO GENERATE CODE ! 14453: * ! 14454: CMP18 ZER SCNSE STOP POSITIONAL ERROR FLAGS ! 14455: MOV CMSTM(XS),XR LOAD TREE PTR FOR STATEMENT BODY ! 14456: ZER WB COLLECTABLE VALUE FOR WB FOR CDGVL ! 14457: ZER WC RESET CONSTANT FLAG FOR CDGVL ! 14458: JSR EXPAP TEST FOR PATTERN MATCH ! 14459: PPM CMP19 JUMP IF NOT PATTERN MATCH ! 14460: MOV =OPMS$,CMOPN(XR) ELSE SET PATTERN MATCH POINTER ! 14461: MOV =C$PMT,CMTYP(XR) ! 14462: * ! 14463: * HERE AFTER DEALING WITH SPECIAL PATTERN MATCH CASE ! 14464: * ! 14465: CMP19 JSR CDGVL GENERATE CODE FOR BODY OF STATEMENT ! 14466: MOV CMSGO(XS),XR LOAD SGOTO POINTER ! 14467: MOV XR,WA COPY IT ! 14468: BZE XR,CMP21 JUMP IF NO SUCCESS GOTO ! 14469: ZER CMSOC(XS) CLEAR SUCCESS OFFSET FILLIN PTR ! 14470: BHI XR,STATE,CMP20 JUMP IF COMPLEX GOTO ! 14471: * ! 14472: * HERE FOR SIMPLE SUCCESS GOTO (LABEL) ! 14473: * ! 14474: ADD *VRTRA,WA POINT TO VRTRA FIELD AS REQUIRED ! 14475: JSR CDWRD GENERATE SUCCESS GOTO ! 14476: BRN CMP22 JUMP TO DEAL WITH FGOTO ! 14477: * ! 14478: * HERE FOR COMPLEX SUCCESS GOTO ! 14479: * ! 14480: CMP20 BEQ XR,CMFGO(XS),CMP22 NO CODE IF SAME AS FGOTO ! 14481: ZER WB ELSE SET OK VALUE FOR CDGVL IN WB ! 14482: JSR CDGCG GENERATE CODE FOR SUCCESS GOTO ! 14483: BRN CMP22 JUMP TO DEAL WITH FGOTO ! 14484: * ! 14485: * HERE FOR NO SUCCESS GOTO ! 14486: * ! 14487: CMP21 MOV CWCOF,CMSOC(XS) SET SUCCESS FILL IN OFFSET ! 14488: MOV =OCER$,WA POINT TO COMPILE ERROR CALL ! 14489: JSR CDWRD GENERATE AS TEMPORARY VALUE ! 14490: EJC ! 14491: * ! 14492: * CMPIL (CONTINUED) ! 14493: * ! 14494: * HERE TO DEAL WITH FAILURE GOTO ! 14495: * ! 14496: CMP22 MOV CMFGO(XS),XR LOAD FAILURE GOTO POINTER ! 14497: MOV XR,WA COPY IT ! 14498: ZER CMFFC(XS) SET NO FILL IN REQUIRED YET ! 14499: BZE XR,CMP23 JUMP IF NO FAILURE GOTO GIVEN ! 14500: ADD *VRTRA,WA POINT TO VRTRA FIELD IN CASE ! 14501: BLO XR,STATE,CMPSE JUMP TO GEN IF SIMPLE FGOTO ! 14502: * ! 14503: * HERE FOR COMPLEX FAILURE GOTO ! 14504: * ! 14505: MOV CWCOF,WB SAVE OFFSET TO O$GOF CALL ! 14506: MOV =OGOF$,WA POINT TO FAILURE GOTO CALL ! 14507: JSR CDWRD GENERATE ! 14508: MOV =OFIF$,WA POINT TO FAIL IN FAIL WORD ! 14509: JSR CDWRD GENERATE ! 14510: JSR CDGCG GENERATE CODE FOR FAILURE GOTO ! 14511: MOV WB,WA COPY OFFSET TO O$GOF FOR CDFAL ! 14512: MOV =B$CDC,WB SET COMPLEX CASE CDTYP ! 14513: BRN CMP25 JUMP TO BUILD CDBLK ! 14514: * ! 14515: * HERE IF NO FAILURE GOTO GIVEN ! 14516: * ! 14517: CMP23 MOV =OUNF$,WA LOAD UNEXPECTED FAILURE CALL IN CAS ! 14518: MOV CSWFL,WC GET -NOFAIL FLAG ! 14519: ORB CMCGO(XS),WC CHECK IF CONDITIONAL GOTO ! 14520: ZRB WC,CMPSE JUMP IF -NOFAIL AND NO COND. GOTO ! 14521: MNZ CMFFC(XS) ELSE SET FILL IN FLAG ! 14522: MOV =OCER$,WA AND SET COMPILE ERROR FOR TEMPORARY ! 14523: * ! 14524: * MERGE HERE WITH CDFAL VALUE IN WA, SIMPLE CDBLK ! 14525: * ALSO SPECIAL ENTRY AFTER STATEMENT ERROR ! 14526: * ! 14527: CMPSE MOV =B$CDS,WB SET CDTYP FOR SIMPLE CASE ! 14528: EJC ! 14529: * ! 14530: * CMPIL (CONTINUED) ! 14531: * ! 14532: * MERGE HERE TO BUILD CDBLK ! 14533: * ! 14534: * (WA) CDFAL VALUE TO BE GENERATED ! 14535: * (WB) CDTYP VALUE TO BE GENERATED ! 14536: * ! 14537: * AT THIS STAGE, WE CHOP OFF AN APPROPRIATE CHUNK OF THE ! 14538: * CURRENT CCBLK AND CONVERT IT INTO A CDBLK. THE REMAINDER ! 14539: * OF THE CCBLK IS REFORMATTED TO BE THE NEW CCBLK. ! 14540: * ! 14541: CMP25 MOV R$CCB,XR POINT TO CCBLK ! 14542: MOV CMLBL(XS),XL GET POSSIBLE LABEL POINTER ! 14543: BZE XL,CMP26 SKIP IF NO LABEL ! 14544: ZER CMLBL(XS) CLEAR FLAG FOR NEXT STATEMENT ! 14545: MOV XR,VRLBL(XL) PUT CDBLK PTR IN VRBLK LABEL FIELD ! 14546: * ! 14547: * MERGE AFTER DOING LABEL ! 14548: * ! 14549: CMP26 MOV WB,(XR) SET TYPE WORD FOR NEW CDBLK ! 14550: MOV WA,CDFAL(XR) SET FAILURE WORD ! 14551: MOV XR,XL COPY POINTER TO CCBLK ! 14552: MOV CCUSE(XR),WB LOAD LENGTH GEN (= NEW CDLEN) ! 14553: MOV CCLEN(XR),WC LOAD TOTAL CCBLK LENGTH ! 14554: ADD WB,XL POINT PAST CDBLK ! 14555: SUB WB,WC GET LENGTH LEFT FOR CHOP OFF ! 14556: MOV =B$CCT,(XL) SET TYPE CODE FOR NEW CCBLK AT END ! 14557: MOV *CCCOD,CCUSE(XL) SET INITIAL CODE OFFSET ! 14558: MOV *CCCOD,CWCOF REINITIALISE CWCOF ! 14559: MOV WC,CCLEN(XL) SET NEW LENGTH ! 14560: MOV XL,R$CCB SET NEW CCBLK POINTER ! 14561: MOV CMPSN,CDSTM(XR) SET STATEMENT NUMBER ! 14562: ICV CMPSN BUMP STATEMENT NUMBER ! 14563: * ! 14564: * SET POINTERS IN PREVIOUS CODE BLOCK AS REQUIRED ! 14565: * ! 14566: MOV CMPCD(XS),XL LOAD PTR TO PREVIOUS CDBLK ! 14567: BZE CMFFP(XS),CMP27 JUMP IF NO FAILURE FILL IN REQUIRED ! 14568: MOV XR,CDFAL(XL) ELSE SET FAILURE PTR IN PREVIOUS ! 14569: * ! 14570: * HERE TO DEAL WITH SUCCESS FORWARD POINTER ! 14571: * ! 14572: CMP27 MOV CMSOP(XS),WA LOAD SUCCESS OFFSET ! 14573: BZE WA,CMP28 JUMP IF NO FILL IN REQUIRED ! 14574: ADD WA,XL ELSE POINT TO FILL IN LOCATION ! 14575: MOV XR,(XL) STORE FORWARD POINTER ! 14576: ZER XL CLEAR GARBAGE XL VALUE ! 14577: EJC ! 14578: * ! 14579: * CMPIL (CONTINUED) ! 14580: * ! 14581: * NOW SET FILL IN POINTERS FOR THIS STATEMENT ! 14582: * ! 14583: CMP28 MOV CMFFC(XS),CMFFP(XS) COPY FAILURE FILL IN FLAG ! 14584: MOV CMSOC(XS),CMSOP(XS) COPY SUCCESS FILL IN OFFSET ! 14585: MOV XR,CMPCD(XS) SAVE PTR TO THIS CDBLK ! 14586: BNZ CMTRA(XS),CMP29 JUMP IF INITIAL ENTRY ALREADY SET ! 14587: MOV XR,CMTRA(XS) ELSE SET PTR HERE AS DEFAULT ! 14588: * ! 14589: * HERE AFTER COMPILING ONE STATEMENT ! 14590: * ! 14591: CMP29 BLT STAGE,=STGCE,CMP01 JUMP IF NOT END LINE JUST DONE ! 14592: BZE CSWLS,CMP30 SKIP IF -NOLIST ! 14593: JSR LISTR LIST LAST LINE ! 14594: * ! 14595: * RETURN ! 14596: * ! 14597: CMP30 MOV CMTRA(XS),XR LOAD INITIAL ENTRY CDBLK POINTER ! 14598: ADD *CMNEN,XS POP WORK LOCATIONS OFF STACK ! 14599: EXI AND RETURN TO CMPIL CALLER ! 14600: * ! 14601: * HERE AT END OF GOTO FIELD ! 14602: * ! 14603: CMP31 MOV CMFGO(XS),WB GET FAIL GOTO ! 14604: ORB CMSGO(XS),WB OR IN SUCCESS GOTO ! 14605: BNZ WB,CMP18 OK IF NON-NULL FIELD ! 14606: ERB 219,SYNTAX ERROR. EMPTY GOTO FIELD ! 14607: * ! 14608: * CONTROL CARD FOUND ! 14609: * ! 14610: CMP32 ICV WB POINT PAST CH$MN ! 14611: JSR CNCRD PROCESS CONTROL CARD ! 14612: ZER SCNSE CLEAR START OF ELEMENT LOC. ! 14613: BRN CMPCE LOOP FOR NEXT STATEMENT ! 14614: ENP END PROCEDURE CMPIL ! 14615: EJC ! 14616: * ! 14617: * CNCRD -- CONTROL CARD PROCESSOR ! 14618: * ! 14619: * CALLED TO DEAL WITH CONTROL CARDS ! 14620: * ! 14621: * R$CIM POINTS TO CURRENT IMAGE ! 14622: * (WB) OFFSET TO 1ST CHAR OF CONTROL CARD ! 14623: * JSR CNCRD CALL TO PROCESS CONTROL CARDS ! 14624: * (XL,XR,WA,WB,WC,IA) DESTROYED ! 14625: * ! 14626: CNCRD PRC E,0 ENTRY POINT ! 14627: MOV WB,SCNPT OFFSET FOR CONTROL CARD SCAN ! 14628: MOV =CCNOC,WA NUMBER OF CHARS FOR COMPARISON ! 14629: CTW WA,0 CONVERT TO WORD COUNT ! 14630: MOV WA,CNSWC SAVE WORD COUNT ! 14631: * ! 14632: * LOOP HERE IF MORE THAN ONE CONTROL CARD ! 14633: * ! 14634: CNC01 BGE SCNPT,SCNIL,CNC09 RETURN IF END OF IMAGE ! 14635: MOV R$CIM,XR POINT TO IMAGE ! 14636: PLC XR,SCNPT CHAR PTR FOR FIRST CHAR ! 14637: LCH WA,(XR)+ GET FIRST CHAR ! 14638: .IF .CULC ! 14639: FLC WA FOLD TO UPPER CASE ! 14640: .FI ! 14641: BEQ WA,=CH$LI,CNC07 SPECIAL CASE OF -INXXX ! 14642: MNZ SCNCC SET FLAG FOR SCANE ! 14643: JSR SCANE SCAN CARD NAME ! 14644: ZER SCNCC CLEAR SCANE FLAG ! 14645: BNZ XL,CNC06 FAIL UNLESS CONTROL CARD NAME ! 14646: MOV =CCNOC,WA NO. OF CHARS TO BE COMPARED ! 14647: BLT SCLEN(XR),WA,CNC06 FAIL IF TOO FEW CHARS ! 14648: MOV XR,XL POINT TO CONTROL CARD NAME ! 14649: ZER WB ZERO OFFSET FOR SUBSTRING ! 14650: JSR SBSTR EXTRACT SUBSTRING FOR COMPARISON ! 14651: .IF .CULC ! 14652: MOV SCLEN(XR),WA RELOAD LENGTH ! 14653: JSR FLSTG FOLD TO UPPER CASE ! 14654: .FI ! 14655: MOV XR,CNSCC KEEP CONTROL CARD SUBSTRING PTR ! 14656: MOV =CCNMS,XR POINT TO LIST OF STANDARD NAMES ! 14657: ZER WB INITIALISE NAME OFFSET ! 14658: LCT WC,=CC$NC NUMBER OF STANDARD NAMES ! 14659: * ! 14660: * TRY TO MATCH NAME ! 14661: * ! 14662: CNC02 MOV CNSCC,XL POINT TO NAME ! 14663: LCT WA,CNSWC COUNTER FOR INNER LOOP ! 14664: BRN CNC04 JUMP INTO LOOP ! 14665: * ! 14666: * INNER LOOP TO MATCH CARD NAME CHARS ! 14667: * ! 14668: CNC03 ICA XR BUMP STANDARD NAMES PTR ! 14669: ICA XL BUMP NAME POINTER ! 14670: * ! 14671: * HERE TO INITIATE THE LOOP ! 14672: * ! 14673: CNC04 CNE SCHAR(XL),(XR),CNC05 COMP. UP TO CFP$C CHARS AT ONCE ! 14674: BCT WA,CNC03 LOOP IF MORE WORDS TO COMPARE ! 14675: EJC ! 14676: * ! 14677: * CNCRD (CONTINUED) ! 14678: * ! 14679: * MATCHED - BRANCH ON CARD OFFSET ! 14680: * ! 14681: MOV WB,XL GET NAME OFFSET ! 14682: BSW XL,CC$NC SWITCH ! 14683: .IF .CULC ! 14684: IFF CC$CA,CNC37 -CASE ! 14685: .FI ! 14686: IFF CC$DO,CNC10 -DOUBLE ! 14687: IFF CC$DU,CNC11 -DUMP ! 14688: IFF CC$EJ,CNC12 -EJECT ! 14689: IFF CC$ER,CNC13 -ERRORS ! 14690: IFF CC$EX,CNC14 -EXECUTE ! 14691: IFF CC$FA,CNC15 -FAIL ! 14692: IFF CC$LI,CNC16 -LIST ! 14693: IFF CC$NR,CNC17 -NOERRORS ! 14694: IFF CC$NX,CNC18 -NOEXECUTE ! 14695: IFF CC$NF,CNC19 -NOFAIL ! 14696: IFF CC$NL,CNC20 -NOLIST ! 14697: IFF CC$NO,CNC21 -NOOPT ! 14698: IFF CC$NP,CNC22 -NOPRINT ! 14699: IFF CC$OP,CNC24 -OPTIMISE ! 14700: IFF CC$PR,CNC25 -PRINT ! 14701: IFF CC$SI,CNC27 -SINGLE ! 14702: IFF CC$SP,CNC28 -SPACE ! 14703: IFF CC$ST,CNC31 -STITLE ! 14704: IFF CC$TI,CNC32 -TITLE ! 14705: IFF CC$TR,CNC36 -TRACE ! 14706: ESW END SWITCH ! 14707: * ! 14708: * NOT MATCHED YET. ALIGN STD NAMES PTR AND TRY AGAIN ! 14709: * ! 14710: CNC05 ICA XR BUMP STANDARD NAMES PTR ! 14711: BCT WA,CNC05 LOOP ! 14712: ICV WB BUMP NAMES OFFSET ! 14713: BCT WC,CNC02 CONTINUE IF MORE NAMES ! 14714: * ! 14715: * INVALID CONTROL CARD NAME ! 14716: * ! 14717: CNC06 ERB 247,INVALID CONTROL CARD ! 14718: * ! 14719: * SPECIAL PROCESSING FOR -INXXX ! 14720: * ! 14721: CNC07 LCH WA,(XR) GET NEXT CHAR ! 14722: .IF .CULC ! 14723: FLC WA FOLD TO UPPER CASE ! 14724: .FI ! 14725: BNE WA,=CH$LN,CNC06 FAIL IF NOT LETTER N ! 14726: ADD =NUM02,SCNPT BUMP OFFSET PAST -IN ! 14727: JSR SCANE SCAN INTEGER AFTER -IN ! 14728: MOV XR,-(XS) STACK SCANNED ITEM ! 14729: JSR GTSMI CHECK IF INTEGER ! 14730: PPM CNC06 FAIL IF NOT INTEGER ! 14731: PPM CNC06 FAIL IF NEGATIVE OR LARGE ! 14732: MOV XR,CSWIN KEEP INTEGER ! 14733: EJC ! 14734: * ! 14735: * CNCRD (CONTINUED) ! 14736: * ! 14737: * CHECK FOR MORE CONTROL CARDS BEFORE RETURNING ! 14738: * ! 14739: CNC08 MOV SCNPT,WA PRESERVE IN CASE XEQ TIME COMPILE ! 14740: JSR SCANE LOOK FOR COMMA ! 14741: BEQ XL,=T$CMA,CNC01 LOOP IF COMMA FOUND ! 14742: MOV WA,SCNPT RESTORE SCNPT IN CASE XEQ TIME ! 14743: * ! 14744: * RETURN POINT ! 14745: * ! 14746: CNC09 EXI RETURN ! 14747: * ! 14748: * -DOUBLE ! 14749: * ! 14750: CNC10 MNZ CSWDB SET SWITCH ! 14751: BRN CNC08 MERGE ! 14752: * ! 14753: * -DUMP ! 14754: * THIS IS USED FOR SYSTEM DEBUGGING . IT HAS THE EFFECT OF ! 14755: * PRODUCING A CORE DUMP AT COMPILATION TIME ! 14756: * ! 14757: CNC11 JSR SYSDM CALL DUMPER ! 14758: BRN CNC09 FINISHED ! 14759: * ! 14760: * -EJECT ! 14761: * ! 14762: CNC12 BZE CSWLS,CNC09 RETURN IF -NOLIST ! 14763: JSR PRTPS EJECT ! 14764: JSR LISTT LIST TITLE ! 14765: BRN CNC09 FINISHED ! 14766: * ! 14767: * -ERRORS ! 14768: * ! 14769: CNC13 ZER CSWER CLEAR SWITCH ! 14770: BRN CNC08 MERGE ! 14771: * ! 14772: * -EXECUTE ! 14773: * ! 14774: CNC14 ZER CSWEX CLEAR SWITCH ! 14775: BRN CNC08 MERGE ! 14776: * ! 14777: * -FAIL ! 14778: * ! 14779: CNC15 MNZ CSWFL SET SWITCH ! 14780: BRN CNC08 MERGE ! 14781: * ! 14782: * -LIST ! 14783: * ! 14784: CNC16 MNZ CSWLS SET SWITCH ! 14785: BEQ STAGE,=STGIC,CNC08 DONE IF COMPILE TIME ! 14786: * ! 14787: * LIST CODE LINE IF EXECUTE TIME COMPILE ! 14788: * ! 14789: ZER LSTPF PERMIT LISTING ! 14790: JSR LISTR LIST LINE ! 14791: BRN CNC08 MERGE ! 14792: EJC ! 14793: * ! 14794: * CNCRD (CONTINUED) ! 14795: * ! 14796: * -NOERRORS ! 14797: * ! 14798: CNC17 MNZ CSWER SET SWITCH ! 14799: BRN CNC08 MERGE ! 14800: * ! 14801: * -NOEXECUTE ! 14802: * ! 14803: CNC18 MNZ CSWEX SET SWITCH ! 14804: BRN CNC08 MERGE ! 14805: * ! 14806: * -NOFAIL ! 14807: * ! 14808: CNC19 ZER CSWFL CLEAR SWITCH ! 14809: BRN CNC08 MERGE ! 14810: * ! 14811: * -NOLIST ! 14812: * ! 14813: CNC20 ZER CSWLS CLEAR SWITCH ! 14814: BRN CNC08 MERGE ! 14815: * ! 14816: * -NOOPTIMISE ! 14817: * ! 14818: CNC21 MNZ CSWNO SET SWITCH ! 14819: BRN CNC08 MERGE ! 14820: * ! 14821: * -NOPRINT ! 14822: * ! 14823: CNC22 ZER CSWPR CLEAR SWITCH ! 14824: BRN CNC08 MERGE ! 14825: * ! 14826: * -OPTIMISE ! 14827: * ! 14828: CNC24 ZER CSWNO CLEAR SWITCH ! 14829: BRN CNC08 MERGE ! 14830: * ! 14831: * -PRINT ! 14832: * ! 14833: CNC25 MNZ CSWPR SET SWITCH ! 14834: BRN CNC08 MERGE ! 14835: EJC ! 14836: * ! 14837: * CNCRD (CONTINUED) ! 14838: * ! 14839: * -SINGLE ! 14840: * ! 14841: CNC27 ZER CSWDB CLEAR SWITCH ! 14842: BRN CNC08 MERGE ! 14843: * ! 14844: * -SPACE ! 14845: * ! 14846: CNC28 BZE CSWLS,CNC09 RETURN IF -NOLIST ! 14847: JSR SCANE SCAN INTEGER AFTER -SPACE ! 14848: MOV =NUM01,WC 1 SPACE IN CASE ! 14849: BEQ XR,=T$SMC,CNC29 JUMP IF NO INTEGER ! 14850: MOV XR,-(XS) STACK IT ! 14851: JSR GTSMI CHECK INTEGER ! 14852: PPM CNC06 FAIL IF NOT INTEGER ! 14853: PPM CNC06 FAIL IF NEGATIVE OR LARGE ! 14854: BNZ WC,CNC29 JUMP IF NON ZERO ! 14855: MOV =NUM01,WC ELSE 1 SPACE ! 14856: * ! 14857: * MERGE WITH COUNT OF LINES TO SKIP ! 14858: * ! 14859: CNC29 ADD WC,LSTLC BUMP LINE COUNT ! 14860: LCT WC,WC CONVERT TO LOOP COUNTER ! 14861: BLT LSTLC,LSTNP,CNC30 JUMP IF FITS ON PAGE ! 14862: JSR PRTPS EJECT ! 14863: JSR LISTT LIST TITLE ! 14864: BRN CNC09 MERGE ! 14865: * ! 14866: * SKIP LINES ! 14867: * ! 14868: CNC30 JSR PRTNL PRINT A BLANK ! 14869: BCT WC,CNC30 LOOP ! 14870: BRN CNC09 MERGE ! 14871: EJC ! 14872: * ! 14873: * CNCRD (CONTINUED) ! 14874: * ! 14875: * -STITL ! 14876: * ! 14877: CNC31 MOV =R$STL,CNR$T PTR TO R$STL ! 14878: BRN CNC33 MERGE ! 14879: * ! 14880: * -TITLE ! 14881: * ! 14882: CNC32 MOV =NULLS,R$STL CLEAR SUBTITLE ! 14883: MOV =R$TTL,CNR$T PTR TO R$TTL ! 14884: * ! 14885: * COMMON PROCESSING FOR -TITLE, -STITL ! 14886: * ! 14887: CNC33 MOV =NULLS,XR NULL IN CASE NEEDED ! 14888: MNZ CNTTL SET FLAG FOR NEXT LISTR CALL ! 14889: MOV =CCOFS,WB OFFSET TO TITLE/SUBTITLE ! 14890: MOV SCNIL,WA INPUT IMAGE LENGTH ! 14891: BLO WA,WB,CNC34 JUMP IF NO CHARS LEFT ! 14892: SUB WB,WA NO OF CHARS TO EXTRACT ! 14893: MOV R$CIM,XL POINT TO IMAGE ! 14894: JSR SBSTR GET TITLE/SUBTITLE ! 14895: * ! 14896: * STORE TITLE/SUBTITLE ! 14897: * ! 14898: CNC34 MOV CNR$T,XL POINT TO STORAGE LOCATION ! 14899: MOV XR,(XL) STORE TITLE/SUBTITLE ! 14900: BEQ XL,=R$STL,CNC09 RETURN IF STITL ! 14901: BNZ PRECL,CNC09 RETURN IF EXTENDED LISTING ! 14902: BZE PRICH,CNC09 RETURN IF REGULAR PRINTER ! 14903: MOV SCLEN(XR),XL GET LENGTH OF TITLE ! 14904: MOV XL,WA COPY IT ! 14905: BZE XL,CNC35 JUMP IF NULL ! 14906: ADD =NUM10,XL INCREMENT ! 14907: BHI XL,PRLEN,CNC09 USE DEFAULT LSTP0 VAL IF TOO LONG ! 14908: ADD =NUM04,WA POINT JUST PAST TITLE ! 14909: * ! 14910: * STORE OFFSET TO PAGE NN MESSAGE FOR SHORT TITLE ! 14911: * ! 14912: CNC35 MOV WA,LSTPO STORE OFFSET ! 14913: BRN CNC09 RETURN ! 14914: * ! 14915: * -TRACE ! 14916: * PROVIDED FOR SYSTEM DEBUGGING. TOGGLES THE SYSTEM LABEL ! 14917: * TRACE SWITCH AT COMPILE TIME ! 14918: * ! 14919: CNC36 JSR SYSTT TOGGLE SWITCH ! 14920: BRN CNC08 MERGE ! 14921: .IF .CULC ! 14922: * ! 14923: * -CASE ! 14924: * SETS VALUE OF KVCAS SO THAT NAMES ARE FOLDED OR NOT ! 14925: * DURING COMPILATION. ! 14926: * ! 14927: CNC37 JSR SCANE SCAN INTEGER AFTER -CASE ! 14928: ZER WC GET 0 IN CASE NONE THERE ! 14929: BEQ XL,=T$SMC,CNC38 SKIP IF NO INTEGER ! 14930: MOV XR,-(XS) STACK IT ! 14931: JSR GTSMI CHECK INTEGER ! 14932: PPM CNC06 FAIL IF NOT INTEGER ! 14933: PPM CNC06 FAIL IF NEGATIVE OR TOO LARGE ! 14934: CNC38 MOV WC,KVCAS STORE NEW CASE VALUE ! 14935: BRN CNC09 MERGE ! 14936: .FI ! 14937: ENP END PROCEDURE CNCRD ! 14938: EJC ! 14939: * ! 14940: * DFFNC -- DEFINE FUNCTION ! 14941: * ! 14942: * DFFNC IS CALLED WHENEVER A NEW FUNCTION IS ASSIGNED TO ! 14943: * A VARIABLE. IT DEALS WITH EXTERNAL FUNCTION USE COUNTS. ! 14944: * ! 14945: * (XR) POINTER TO VRBLK ! 14946: * (XL) POINTER TO NEW FUNCTION BLOCK ! 14947: * JSR DFFNC CALL TO DEFINE FUNCTION ! 14948: * (WA,WB) DESTROYED ! 14949: * ! 14950: DFFNC PRC E,0 ENTRY POINT ! 14951: BNE (XL),=B$EFC,DFFN1 SKIP IF NEW FUNCTION NOT EXTERNAL ! 14952: ICV EFUSE(XL) ELSE INCREMENT ITS USE COUNT ! 14953: * ! 14954: * HERE AFTER DEALING WITH NEW FUNCTION USE COUNT ! 14955: * ! 14956: DFFN1 MOV XR,WA SAVE VRBLK POINTER ! 14957: .IF .CNLD ! 14958: .ELSE ! 14959: MOV VRFNC(XR),XR LOAD OLD FUNCTION POINTER ! 14960: BNE (XR),=B$EFC,DFFN2 JUMP IF OLD FUNCTION NOT EXTERNAL ! 14961: MOV EFUSE(XR),WB ELSE GET USE COUNT ! 14962: DCV WB DECREMENT ! 14963: MOV WB,EFUSE(XR) STORE DECREMENTED VALUE ! 14964: BNZ WB,DFFN2 JUMP IF USE COUNT STILL NON-ZERO ! 14965: JSR SYSUL ELSE CALL SYSTEM UNLOAD FUNCTION ! 14966: .FI ! 14967: * ! 14968: * HERE AFTER DEALING WITH OLD FUNCTION USE COUNT ! 14969: * ! 14970: DFFN2 MOV WA,XR RESTORE VRBLK POINTER ! 14971: MOV XL,WA COPY FUNCTION BLOCK PTR ! 14972: BLT XR,=R$YYY,DFFN3 SKIP CHECKS IF OPSYN OP DEFINITION ! 14973: BNZ VRLEN(XR),DFFN3 JUMP IF NOT SYSTEM VARIABLE ! 14974: * ! 14975: * FOR SYSTEM VARIABLE, CHECK FOR ILLEGAL REDEFINITION ! 14976: * ! 14977: MOV VRSVP(XR),XL POINT TO SVBLK ! 14978: MOV SVBIT(XL),WB LOAD BIT INDICATORS ! 14979: ANB BTFNC,WB IS IT A SYSTEM FUNCTION ! 14980: ZRB WB,DFFN3 REDEF OK IF NOT ! 14981: ERB 248,ATTEMPTED REDEFINITION OF SYSTEM FUNCTION ! 14982: * ! 14983: * HERE IF REDEFINITION IS PERMITTED ! 14984: * ! 14985: DFFN3 MOV WA,VRFNC(XR) STORE NEW FUNCTION POINTER ! 14986: MOV WA,XL RESTORE FUNCTION BLOCK POINTER ! 14987: EXI RETURN TO DFFNC CALLER ! 14988: ENP END PROCEDURE DFFNC ! 14989: EJC ! 14990: * ! 14991: * DTACH -- DETACH I/O ASSOCIATED NAMES ! 14992: * ! 14993: * DETACHES TRBLKS FROM I/O ASSOCIATED VARIABLES, REMOVES ! 14994: * ENTRY FROM IOCHN CHAIN ATTACHED TO FILEARG1 VRBLK AND MAY ! 14995: * REMOVE VRBLK ACCESS AND STORE TRAPS. ! 14996: * INPUT, OUTPUT, TERMINAL ARE HANDLED SPECIALLY. ! 14997: * ! 14998: * (XL) I/O ASSOC. VBL NAME BASE PTR ! 14999: * (WA) OFFSET TO NAME ! 15000: * JSR DTACH CALL FOR DETACH OPERATION ! 15001: * (XL,XR,WA,WB,WC) DESTROYED ! 15002: * ! 15003: DTACH PRC E,0 ENTRY POINT ! 15004: MOV XL,DTCNB STORE NAME BASE (GBCOL NOT CALLED) ! 15005: ADD WA,XL POINT TO NAME LOCATION ! 15006: MOV XL,DTCNM STORE IT ! 15007: * ! 15008: * LOOP TO SEARCH FOR I/O TRBLK ! 15009: * ! 15010: DTCH1 MOV XL,XR COPY NAME POINTER ! 15011: * ! 15012: * CONTINUE AFTER BLOCK DELETION ! 15013: * ! 15014: DTCH2 MOV (XL),XL POINT TO NEXT VALUE ! 15015: BNE (XL),=B$TRT,DTCH6 JUMP AT CHAIN END ! 15016: MOV TRTYP(XL),WA GET TRAP BLOCK TYPE ! 15017: BEQ WA,=TRTIN,DTCH3 JUMP IF INPUT ! 15018: BEQ WA,=TRTOU,DTCH3 JUMP IF OUTPUT ! 15019: ADD *TRNXT,XL POINT TO NEXT LINK ! 15020: BRN DTCH1 LOOP ! 15021: * ! 15022: * DELETE AN OLD ASSOCIATION ! 15023: * ! 15024: DTCH3 MOV TRVAL(XL),(XR) DELETE TRBLK ! 15025: MOV XL,WA DUMP XL ... ! 15026: MOV XR,WB ... AND XR ! 15027: MOV TRTRF(XL),XL POINT TO TRTRF TRAP BLOCK ! 15028: BZE XL,DTCH5 JUMP IF NO IOCHN ! 15029: BNE (XL),=B$TRT,DTCH5 JUMP IF INPUT, OUTPUT, TERMINAL ! 15030: * ! 15031: * LOOP TO SEARCH IOCHN CHAIN FOR NAME PTR ! 15032: * ! 15033: DTCH4 MOV XL,XR REMEMBER LINK PTR ! 15034: MOV TRTRF(XL),XL POINT TO NEXT LINK ! 15035: BZE XL,DTCH5 JUMP IF END OF CHAIN ! 15036: MOV IONMB(XL),WC GET NAME BASE ! 15037: ADD IONMO(XL),WC ADD OFFSET ! 15038: BNE WC,DTCNM,DTCH4 LOOP IF NO MATCH ! 15039: MOV TRTRF(XL),TRTRF(XR) REMOVE NAME FROM CHAIN ! 15040: EJC ! 15041: * ! 15042: * DTACH (CONTINUED) ! 15043: * ! 15044: * PREPARE TO RESUME I/O TRBLK SCAN ! 15045: * ! 15046: DTCH5 MOV WA,XL RECOVER XL ... ! 15047: MOV WB,XR ... AND XR ! 15048: ADD *TRVAL,XL POINT TO VALUE FIELD ! 15049: BRN DTCH2 CONTINUE ! 15050: * ! 15051: * EXIT POINT ! 15052: * ! 15053: DTCH6 MOV DTCNB,XR POSSIBLE VRBLK PTR ! 15054: JSR SETVR RESET VRBLK IF NECESSARY ! 15055: EXI RETURN ! 15056: ENP END PROCEDURE DTACH ! 15057: EJC ! 15058: * ! 15059: * DTYPE -- GET DATATYPE NAME ! 15060: * ! 15061: * (XR) OBJECT WHOSE DATATYPE IS REQUIRED ! 15062: * JSR DTYPE CALL TO GET DATATYPE ! 15063: * (XR) RESULT DATATYPE ! 15064: * ! 15065: DTYPE PRC E,0 ENTRY POINT ! 15066: BEQ (XR),=B$PDT,DTYP1 JUMP IF PROG.DEFINED ! 15067: MOV (XR),XR LOAD TYPE WORD ! 15068: LEI XR GET ENTRY POINT ID (BLOCK CODE) ! 15069: WTB XR CONVERT TO BYTE OFFSET ! 15070: MOV SCNMT(XR),XR LOAD TABLE ENTRY ! 15071: EXI EXIT TO DTYPE CALLER ! 15072: * ! 15073: * HERE IF PROGRAM DEFINED ! 15074: * ! 15075: DTYP1 MOV PDDFP(XR),XR POINT TO DFBLK ! 15076: MOV DFNAM(XR),XR GET DATATYPE NAME FROM DFBLK ! 15077: EXI RETURN TO DTYPE CALLER ! 15078: ENP END PROCEDURE DTYPE ! 15079: EJC ! 15080: * ! 15081: * DUMPR -- PRINT DUMP OF STORAGE ! 15082: * ! 15083: * (XR) DUMP ARGUMENT (SEE BELOW) ! 15084: * JSR DUMPR CALL TO PRINT DUMP ! 15085: * (XR,XL) DESTROYED ! 15086: * (WA,WB,WC,RA) DESTROYED ! 15087: * ! 15088: * THE DUMP ARGUMENT HAS THE FOLLOWING SIGNIFICANCE ! 15089: * ! 15090: * DMARG = 0 NO DUMP PRINTED ! 15091: * DMARG = 1 PARTIAL DUMP (NAT VARS, KEYWORDS) ! 15092: * DMARG EQ 2 FULL DUMP (INCL ARRAYS ETC.) ! 15093: * DMARG GE 3 CORE DUMP ! 15094: * ! 15095: * SINCE DUMPR SCRAMBLES STORE, IT IS NOT PERMISSIBLE TO ! 15096: * COLLECT IN MID-DUMP. HENCE A COLLECT IS DONE INITIALLY ! 15097: * AND THEN IF STORE RUNS OUT AN ERROR MESSAGE IS PRODUCED. ! 15098: * ! 15099: DUMPR PRC E,0 ENTRY POINT ! 15100: BZE XR,DMP28 SKIP DUMP IF ARGUMENT IS ZERO ! 15101: BGT XR,=NUM02,DMP29 JUMP IF CORE DUMP REQUIRED ! 15102: ZER XL CLEAR XL ! 15103: ZER WB ZERO MOVE OFFSET ! 15104: MOV XR,DMARG SAVE DUMP ARGUMENT ! 15105: JSR GBCOL COLLECT GARBAGE ! 15106: JSR PRTPG EJECT PRINTER ! 15107: MOV =DMHDV,XR POINT TO HEADING FOR VARIABLES ! 15108: JSR PRTST PRINT IT ! 15109: JSR PRTNL TERMINATE PRINT LINE ! 15110: JSR PRTNL AND PRINT A BLANK LINE ! 15111: * ! 15112: * FIRST ALL NATURAL VARIABLE BLOCKS (VRBLK) WHOSE VALUES ! 15113: * ARE NON-NULL ARE LINKED IN LEXICAL ORDER USING DMVCH AS ! 15114: * THE CHAIN HEAD AND CHAINING THROUGH THE VRGET FIELDS. ! 15115: * NOTE THAT THIS SCRAMBLES STORE IF THE PROCESS IS ! 15116: * INTERRUPTED BEFORE COMPLETION E.G. BY EXCEEDING TIME OR ! 15117: * PRINT LIMITS. SINCE THE SUBSEQUENT CORE DUMPS AND ! 15118: * FAILURES IF EXECUTION IS RESUMED ARE VERY CONFUSING, THE ! 15119: * EXECUTION TIME ERROR ROUTINE CHECKS FOR THIS EVENT AND ! 15120: * ATTEMPTS AN UNSCRAMBLE. SIMILAR PRECAUTIONS SHOULD BE ! 15121: * OBSERVED IF TRANSLATE TIME DUMPING IS IMPLEMENTED. ! 15122: * ! 15123: ZER DMVCH SET NULL CHAIN TO START ! 15124: MOV HSHTB,WA POINT TO HASH TABLE ! 15125: * ! 15126: * LOOP THROUGH HEADERS IN HASH TABLE ! 15127: * ! 15128: DMP00 MOV WA,XR COPY HASH BUCKET POINTER ! 15129: ICA WA BUMP POINTER ! 15130: SUB *VRNXT,XR SET OFFSET TO MERGE ! 15131: * ! 15132: * LOOP THROUGH VRBLKS ON ONE CHAIN ! 15133: * ! 15134: DMP01 MOV VRNXT(XR),XR POINT TO NEXT VRBLK ON CHAIN ! 15135: BZE XR,DMP09 JUMP IF END OF THIS HASH CHAIN ! 15136: MOV XR,XL ELSE COPY VRBLK POINTER ! 15137: EJC ! 15138: * ! 15139: * DUMPR (CONTINUED) ! 15140: * ! 15141: * LOOP TO FIND VALUE AND SKIP IF NULL ! 15142: * ! 15143: DMP02 MOV VRVAL(XL),XL LOAD VALUE ! 15144: BEQ XL,=NULLS,DMP01 LOOP FOR NEXT VRBLK IF NULL VALUE ! 15145: BEQ (XL),=B$TRT,DMP02 LOOP BACK IF VALUE IS TRAPPED ! 15146: * ! 15147: * NON-NULL VALUE, PREPARE TO SEARCH CHAIN ! 15148: * ! 15149: MOV XR,WC SAVE VRBLK POINTER ! 15150: ADD *VRSOF,XR ADJUST PTR TO BE LIKE SCBLK PTR ! 15151: BNZ SCLEN(XR),DMP03 JUMP IF NON-SYSTEM VARIABLE ! 15152: MOV VRSVO(XR),XR ELSE LOAD PTR TO NAME IN SVBLK ! 15153: * ! 15154: * HERE WITH NAME POINTER FOR NEW BLOCK IN XR ! 15155: * ! 15156: DMP03 MOV XR,WB SAVE POINTER TO CHARS ! 15157: MOV WA,DMPSV SAVE HASH BUCKET POINTER ! 15158: MOV =DMVCH,WA POINT TO CHAIN HEAD ! 15159: * ! 15160: * LOOP TO SEARCH CHAIN FOR CORRECT INSERTION POINT ! 15161: * ! 15162: DMP04 MOV WA,DMPCH SAVE CHAIN POINTER ! 15163: MOV WA,XL COPY IT ! 15164: MOV (XL),XR LOAD POINTER TO NEXT ENTRY ! 15165: BZE XR,DMP08 JUMP IF END OF CHAIN TO INSERT ! 15166: ADD *VRSOF,XR ELSE GET NAME PTR FOR CHAINED VRBLK ! 15167: BNZ SCLEN(XR),DMP05 JUMP IF NOT SYSTEM VARIABLE ! 15168: MOV VRSVO(XR),XR ELSE POINT TO NAME IN SVBLK ! 15169: * ! 15170: * HERE PREPARE TO COMPARE THE NAMES ! 15171: * ! 15172: * (WA) SCRATCH ! 15173: * (WB) POINTER TO STRING OF ENTERING VRBLK ! 15174: * (WC) POINTER TO ENTERING VRBLK ! 15175: * (XR) POINTER TO STRING OF CURRENT BLOCK ! 15176: * (XL) SCRATCH ! 15177: * ! 15178: DMP05 MOV WB,XL POINT TO ENTERING VRBLK STRING ! 15179: MOV SCLEN(XL),WA LOAD ITS LENGTH ! 15180: PLC XL POINT TO CHARS OF ENTERING STRING ! 15181: BHI WA,SCLEN(XR),DMP06 JUMP IF ENTERING LENGTH HIGH ! 15182: PLC XR ELSE POINT TO CHARS OF OLD STRING ! 15183: CMC DMP08,DMP07 COMPARE, INSERT IF NEW IS LLT OLD ! 15184: BRN DMP08 OR IF LEQ (WE HAD SHORTER LENGTH) ! 15185: * ! 15186: * HERE WHEN NEW LENGTH IS LONGER THAN OLD LENGTH ! 15187: * ! 15188: DMP06 MOV SCLEN(XR),WA LOAD SHORTER LENGTH ! 15189: PLC XR POINT TO CHARS OF OLD STRING ! 15190: CMC DMP08,DMP07 COMPARE, INSERT IF NEW ONE LOW ! 15191: EJC ! 15192: * ! 15193: * DUMPR (CONTINUED) ! 15194: * ! 15195: * HERE WE MOVE OUT ON THE CHAIN ! 15196: * ! 15197: DMP07 MOV DMPCH,XL COPY CHAIN POINTER ! 15198: MOV (XL),WA MOVE TO NEXT ENTRY ON CHAIN ! 15199: BRN DMP04 LOOP BACK ! 15200: * ! 15201: * HERE AFTER LOCATING THE PROPER INSERTION POINT ! 15202: * ! 15203: DMP08 MOV DMPCH,XL COPY CHAIN POINTER ! 15204: MOV DMPSV,WA RESTORE HASH BUCKET POINTER ! 15205: MOV WC,XR RESTORE VRBLK POINTER ! 15206: MOV (XL),VRGET(XR) LINK VRBLK TO REST OF CHAIN ! 15207: MOV XR,(XL) LINK VRBLK INTO CURRENT CHAIN LOC ! 15208: BRN DMP01 LOOP BACK FOR NEXT VRBLK ! 15209: * ! 15210: * HERE AFTER PROCESSING ALL VRBLKS ON ONE CHAIN ! 15211: * ! 15212: DMP09 BNE WA,HSHTE,DMP00 LOOP BACK IF MORE BUCKETS TO GO ! 15213: * ! 15214: * LOOP TO GENERATE DUMP OF NATURAL VARIABLE VALUES ! 15215: * ! 15216: DMP10 MOV DMVCH,XR LOAD POINTER TO NEXT ENTRY ON CHAIN ! 15217: BZE XR,DMP11 JUMP IF END OF CHAIN ! 15218: MOV (XR),DMVCH ELSE UPDATE CHAIN PTR TO NEXT ENTRY ! 15219: JSR SETVR RESTORE VRGET FIELD ! 15220: MOV XR,XL COPY VRBLK POINTER (NAME BASE) ! 15221: MOV *VRVAL,WA SET OFFSET FOR VRBLK NAME ! 15222: JSR PRTNV PRINT NAME = VALUE ! 15223: BRN DMP10 LOOP BACK TILL ALL PRINTED ! 15224: * ! 15225: * PREPARE TO PRINT KEYWORDS ! 15226: * ! 15227: DMP11 JSR PRTNL PRINT BLANK LINE ! 15228: JSR PRTNL AND ANOTHER ! 15229: MOV =DMHDK,XR POINT TO KEYWORD HEADING ! 15230: JSR PRTST PRINT HEADING ! 15231: JSR PRTNL END LINE ! 15232: JSR PRTNL PRINT ONE BLANK LINE ! 15233: MOV =VDMKW,XL POINT TO LIST OF KEYWORD SVBLK PTRS ! 15234: EJC ! 15235: * ! 15236: * DUMPR (CONTINUED) ! 15237: * ! 15238: * LOOP TO DUMP KEYWORD VALUES ! 15239: * ! 15240: DMP12 MOV (XL)+,XR LOAD NEXT SVBLK PTR FROM TABLE ! 15241: BZE XR,DMP13 JUMP IF END OF LIST ! 15242: MOV =CH$AM,WA LOAD AMPERSAND ! 15243: JSR PRTCH PRINT AMPERSAND ! 15244: JSR PRTST PRINT KEYWORD NAME ! 15245: MOV SVLEN(XR),WA LOAD NAME LENGTH FROM SVBLK ! 15246: CTB WA,SVCHS GET LENGTH OF NAME ! 15247: ADD WA,XR POINT TO SVKNM FIELD ! 15248: MOV (XR),DMPKN STORE IN DUMMY KVBLK ! 15249: MOV =TMBEB,XR POINT TO BLANK-EQUAL-BLANK ! 15250: JSR PRTST PRINT IT ! 15251: MOV XL,DMPSV SAVE TABLE POINTER ! 15252: MOV =DMPKB,XL POINT TO DUMMY KVBLK ! 15253: MOV *KVVAR,WA SET ZERO OFFSET ! 15254: JSR ACESS GET KEYWORD VALUE ! 15255: PPM FAILURE IS IMPOSSIBLE ! 15256: JSR PRTVL PRINT KEYWORD VALUE ! 15257: JSR PRTNL TERMINATE PRINT LINE ! 15258: MOV DMPSV,XL RESTORE TABLE POINTER ! 15259: BRN DMP12 LOOP BACK TILL ALL PRINTED ! 15260: * ! 15261: * HERE AFTER COMPLETING PARTIAL DUMP ! 15262: * ! 15263: DMP13 BEQ DMARG,=NUM01,DMP27 EXIT IF PARTIAL DUMP COMPLETE ! 15264: MOV DNAMB,XR ELSE POINT TO FIRST DYNAMIC BLOCK ! 15265: * ! 15266: * LOOP THROUGH BLOCKS IN DYNAMIC STORAGE ! 15267: * ! 15268: DMP14 BEQ XR,DNAMP,DMP27 JUMP IF END OF USED REGION ! 15269: MOV (XR),WA ELSE LOAD FIRST WORD OF BLOCK ! 15270: BEQ WA,=B$VCT,DMP16 JUMP IF VECTOR ! 15271: BEQ WA,=B$ART,DMP17 JUMP IF ARRAY ! 15272: BEQ WA,=B$PDT,DMP18 JUMP IF PROGRAM DEFINED ! 15273: BEQ WA,=B$TBT,DMP19 JUMP IF TABLE ! 15274: .IF .CNBF ! 15275: .ELSE ! 15276: BEQ WA,=B$BCT,DMP30 JUMP IF BUFFER ! 15277: .FI ! 15278: * ! 15279: * MERGE HERE TO MOVE TO NEXT BLOCK ! 15280: * ! 15281: DMP15 JSR BLKLN GET LENGTH OF BLOCK ! 15282: ADD WA,XR POINT PAST THIS BLOCK ! 15283: BRN DMP14 LOOP BACK FOR NEXT BLOCK ! 15284: EJC ! 15285: * ! 15286: * DUMPR (CONTINUED) ! 15287: * ! 15288: * HERE FOR VECTOR ! 15289: * ! 15290: DMP16 MOV *VCVLS,WB SET OFFSET TO FIRST VALUE ! 15291: BRN DMP19 JUMP TO MERGE ! 15292: * ! 15293: * HERE FOR ARRAY ! 15294: * ! 15295: DMP17 MOV AROFS(XR),WB SET OFFSET TO ARPRO FIELD ! 15296: ICA WB BUMP TO GET OFFSET TO VALUES ! 15297: BRN DMP19 JUMP TO MERGE ! 15298: * ! 15299: * HERE FOR PROGRAM DEFINED ! 15300: * ! 15301: DMP18 MOV *PDFLD,WB POINT TO VALUES, MERGE ! 15302: * ! 15303: * HERE FOR TABLE (OTHERS MERGE) ! 15304: * ! 15305: DMP19 BZE IDVAL(XR),DMP15 IGNORE BLOCK IF ZERO ID VALUE ! 15306: JSR BLKLN ELSE GET BLOCK LENGTH ! 15307: MOV XR,XL COPY BLOCK POINTER ! 15308: MOV WA,DMPSV SAVE LENGTH ! 15309: MOV WB,WA COPY OFFSET TO FIRST VALUE ! 15310: JSR PRTNL PRINT BLANK LINE ! 15311: MOV WA,DMPSA PRESERVE OFFSET ! 15312: JSR PRTVL PRINT BLOCK VALUE (FOR TITLE) ! 15313: MOV DMPSA,WA RECOVER OFFSET ! 15314: JSR PRTNL END PRINT LINE ! 15315: BEQ (XR),=B$TBT,DMP22 JUMP IF TABLE ! 15316: DCA WA POINT BEFORE FIRST WORD ! 15317: * ! 15318: * LOOP TO PRINT CONTENTS OF ARRAY, VECTOR, OR PROGRAM DEF ! 15319: * ! 15320: DMP20 MOV XL,XR COPY BLOCK POINTER ! 15321: ICA WA BUMP OFFSET ! 15322: ADD WA,XR POINT TO NEXT VALUE ! 15323: BEQ WA,DMPSV,DMP14 EXIT IF END (XR PAST BLOCK) ! 15324: SUB *VRVAL,XR SUBTRACT OFFSET TO MERGE INTO LOOP ! 15325: * ! 15326: * LOOP TO FIND VALUE AND IGNORE NULLS ! 15327: * ! 15328: DMP21 MOV VRVAL(XR),XR LOAD NEXT VALUE ! 15329: BEQ XR,=NULLS,DMP20 LOOP BACK IF NULL VALUE ! 15330: BEQ (XR),=B$TRT,DMP21 LOOP BACK IF TRAPPED ! 15331: JSR PRTNV ELSE PRINT NAME = VALUE ! 15332: BRN DMP20 LOOP BACK FOR NEXT FIELD ! 15333: EJC ! 15334: * ! 15335: * DUMPR (CONTINUED) ! 15336: * ! 15337: * HERE TO DUMP A TABLE ! 15338: * ! 15339: DMP22 MOV *TBBUK,WC SET OFFSET TO FIRST BUCKET ! 15340: MOV *TEVAL,WA SET NAME OFFSET FOR ALL TEBLKS ! 15341: * ! 15342: * LOOP THROUGH TABLE BUCKETS ! 15343: * ! 15344: DMP23 MOV XL,-(XS) SAVE TBBLK POINTER ! 15345: ADD WC,XL POINT TO NEXT BUCKET HEADER ! 15346: ICA WC BUMP BUCKET OFFSET ! 15347: SUB *TENXT,XL SUBTRACT OFFSET TO MERGE INTO LOOP ! 15348: * ! 15349: * LOOP TO PROCESS TEBLKS ON ONE CHAIN ! 15350: * ! 15351: DMP24 MOV TENXT(XL),XL POINT TO NEXT TEBLK ! 15352: BEQ XL,(XS),DMP26 JUMP IF END OF CHAIN ! 15353: MOV XL,XR ELSE COPY TEBLK POINTER ! 15354: * ! 15355: * LOOP TO FIND VALUE AND IGNORE IF NULL ! 15356: * ! 15357: DMP25 MOV TEVAL(XR),XR LOAD NEXT VALUE ! 15358: BEQ XR,=NULLS,DMP24 IGNORE IF NULL VALUE ! 15359: BEQ (XR),=B$TRT,DMP25 LOOP BACK IF TRAPPED ! 15360: MOV WC,DMPSV ELSE SAVE OFFSET POINTER ! 15361: JSR PRTNV PRINT NAME = VALUE ! 15362: MOV DMPSV,WC RELOAD OFFSET ! 15363: BRN DMP24 LOOP BACK FOR NEXT TEBLK ! 15364: * ! 15365: * HERE TO MOVE TO NEXT HASH CHAIN ! 15366: * ! 15367: DMP26 MOV (XS)+,XL RESTORE TBBLK POINTER ! 15368: BNE WC,TBLEN(XL),DMP23 LOOP BACK IF MORE BUCKETS TO GO ! 15369: MOV XL,XR ELSE COPY TABLE POINTER ! 15370: ADD WC,XR POINT TO FOLLOWING BLOCK ! 15371: BRN DMP14 LOOP BACK TO PROCESS NEXT BLOCK ! 15372: * ! 15373: * HERE AFTER COMPLETING DUMP ! 15374: * ! 15375: DMP27 JSR PRTPG EJECT PRINTER ! 15376: * ! 15377: * MERGE HERE IF NO DUMP GIVEN (DMARG=0) ! 15378: * ! 15379: DMP28 EXI RETURN TO DUMP CALLER ! 15380: * ! 15381: * CALL SYSTEM CORE DUMP ROUTINE ! 15382: * ! 15383: DMP29 JSR SYSDM CALL IT ! 15384: BRN DMP28 RETURN ! 15385: .IF .CNBF ! 15386: .ELSE ! 15387: EJC ! 15388: * ! 15389: * DUMPR (CONTINUED) ! 15390: * ! 15391: * HERE TO DUMP BUFFER BLOCK ! 15392: * ! 15393: DMP30 JSR PRTNL PRINT BLANK LINE ! 15394: JSR PRTVL PRINT VALUE ID FOR TITLE ! 15395: JSR PRTNL FORCE NEW LINE ! 15396: MOV =CH$DQ,WA LOAD DOUBLE QUOTE ! 15397: JSR PRTCH PRINT IT ! 15398: MOV BCLEN(XR),WC LOAD DEFINED LENGTH ! 15399: BZE WC,DMP32 SKIP CHARACTERS IF NONE ! 15400: LCT WC,WC LOAD COUNT FOR LOOP ! 15401: MOV XR,WB SAVE BCBLK PTR ! 15402: MOV BCBUF(XR),XR POINT TO BFBLK ! 15403: PLC XR GET SET TO LOAD CHARACTERS ! 15404: * ! 15405: * LOOP HERE STUFFING CHARACTERS IN OUTPUT STREAM ! 15406: * ! 15407: DMP31 LCH WA,(XR)+ GET NEXT CHARACTER ! 15408: JSR PRTCH STUFF IT ! 15409: BCT WC,DMP31 BRANCH FOR NEXT ONE ! 15410: MOV WB,XR RESTORE BCBLK POINTER ! 15411: * ! 15412: * MERGE TO STUFF CLOSING QUOTE MARK ! 15413: * ! 15414: DMP32 MOV =CH$DQ,WA STUFF QUOTE ! 15415: JSR PRTCH PRINT IT ! 15416: JSR PRTNL PRINT NEW LINE ! 15417: MOV (XR),WA GET FIRST WD FOR BLKLN ! 15418: BRN DMP15 MERGE TO GET NEXT BLOCK ! 15419: .FI ! 15420: ENP END PROCEDURE DUMPR ! 15421: EJC ! 15422: * ! 15423: * ERMSG -- PRINT ERROR CODE AND ERROR MESSAGE ! 15424: * ! 15425: * KVERT ERROR CODE ! 15426: * JSR ERMSG CALL TO PRINT MESSAGE ! 15427: * (XR,XL,WA,WB,WC,IA) DESTROYED ! 15428: * ! 15429: ERMSG PRC E,0 ENTRY POINT ! 15430: JSR PRTIS PRINT ERROR PTR OR BLANK LINE ! 15431: MOV KVERT,WA LOAD ERROR CODE ! 15432: MOV =ERMMS,XR POINT TO ERROR MESSAGE /ERROR/ ! 15433: JSR PRTST PRINT IT ! 15434: JSR ERTEX GET ERROR MESSAGE TEXT ! 15435: ADD =THSND,WA BUMP ERROR CODE FOR PRINT ! 15436: MTI WA FAIL CODE IN INT ACC ! 15437: JSR PRTIN PRINT CODE (NOW HAVE ERROR1XXX) ! 15438: MOV PRBUF,XL POINT TO PRINT BUFFER ! 15439: PSC XL,=NUM05 POINT TO THE 1 ! 15440: MOV =CH$BL,WA LOAD A BLANK ! 15441: SCH WA,(XL) STORE BLANK OVER 1 (ERROR XXX) ! 15442: CSC XL COMPLETE STORE CHARACTERS ! 15443: ZER XL CLEAR GARBAGE POINTER IN XL ! 15444: MOV XR,WA KEEP ERROR TEXT ! 15445: MOV =ERMNS,XR POINT TO / -- / ! 15446: JSR PRTST PRINT IT ! 15447: MOV WA,XR GET ERROR TEXT AGAIN ! 15448: JSR PRTST PRINT ERROR MESSAGE TEXT ! 15449: JSR PRTIS PRINT LINE ! 15450: JSR PRTIS PRINT BLANK LINE ! 15451: EXI RETURN TO ERMSG CALLER ! 15452: ENP END PROCEDURE ERMSG ! 15453: EJC ! 15454: * ! 15455: * ERTEX -- GET ERROR MESSAGE TEXT ! 15456: * ! 15457: * (WA) ERROR CODE ! 15458: * JSR ERTEX CALL TO GET ERROR TEXT ! 15459: * (XR) PTR TO ERROR TEXT IN DYNAMIC ! 15460: * (R$ETX) COPY OF PTR TO ERROR TEXT ! 15461: * (XL,WC,IA) DESTROYED ! 15462: * ! 15463: ERTEX PRC E,0 ENTRY POINT ! 15464: MOV WA,ERTWA SAVE WA ! 15465: MOV WB,ERTWB SAVE WB ! 15466: JSR SYSEM GET FAILURE MESSAGE TEXT ! 15467: MOV XR,XL COPY POINTER TO IT ! 15468: MOV SCLEN(XR),WA GET LENGTH OF STRING ! 15469: BZE WA,ERT02 JUMP IF NULL ! 15470: ZER WB OFFSET OF ZERO ! 15471: JSR SBSTR COPY INTO DYNAMIC STORE ! 15472: MOV XR,R$ETX STORE FOR RELOCATION ! 15473: * ! 15474: * RETURN ! 15475: * ! 15476: ERT01 MOV ERTWB,WB RESTORE WB ! 15477: MOV ERTWA,WA RESTORE WA ! 15478: EXI RETURN TO CALLER ! 15479: * ! 15480: * RETURN ERRTEXT CONTENTS INSTEAD OF NULL ! 15481: * ! 15482: ERT02 MOV R$ETX,XR GET ERRTEXT ! 15483: BRN ERT01 RETURN ! 15484: ENP ! 15485: EJC ! 15486: * ! 15487: * EVALI -- EVALUATE INTEGER ARGUMENT ! 15488: * ! 15489: * EVALI IS USED BY PATTERN PRIMITIVES LEN,TAB,RTAB,POS,RPOS ! 15490: * WHEN THEIR ARGUMENT IS AN EXPRESSION VALUE. ! 15491: * ! 15492: * (XR) NODE POINTER ! 15493: * (WB) CURSOR ! 15494: * JSR EVALI CALL TO EVALUATE INTEGER ! 15495: * PPM LOC TRANSFER LOC FOR NON-INTEGER ARG ! 15496: * PPM LOC TRANSFER LOC FOR OUT OF RANGE ARG ! 15497: * PPM LOC TRANSFER LOC FOR EVALUATION FAILURE ! 15498: * PPM LOC TRANSFER LOC FOR SUCCESSFUL EVAL ! 15499: * (THE NORMAL RETURN IS NEVER TAKEN) ! 15500: * (XR) PTR TO NODE WITH INTEGER ARGUMENT ! 15501: * (WC,XL,RA) DESTROYED ! 15502: * ! 15503: * ON RETURN, THE NODE POINTED TO HAS THE INTEGER ARGUMENT ! 15504: * IN PARM1 AND THE PROPER SUCCESSOR POINTER IN PTHEN. ! 15505: * THIS ALLOWS MERGING WITH THE NORMAL (INTEGER ARG) CASE. ! 15506: * ! 15507: EVALI PRC R,4 ENTRY POINT (RECURSIVE) ! 15508: JSR EVALP EVALUATE EXPRESSION ! 15509: PPM EVLI1 JUMP ON FAILURE ! 15510: MOV XL,-(XS) STACK RESULT FOR GTSMI ! 15511: MOV PTHEN(XR),XL LOAD SUCCESSOR POINTER ! 15512: JSR GTSMI CONVERT ARG TO SMALL INTEGER ! 15513: PPM EVLI2 JUMP IF NOT INTEGER ! 15514: PPM EVLI3 JUMP IF OUT OF RANGE ! 15515: MOV XR,EVLIV STORE RESULT IN SPECIAL DUMMY NODE ! 15516: MOV XL,EVLIS STORE SUCCESSOR POINTER ! 15517: MOV =EVLIN,XR POINT TO DUMMY NODE WITH RESULT ! 15518: EXI 4 TAKE SUCCESSFUL EXIT ! 15519: * ! 15520: * HERE IF EVALUATION FAILS ! 15521: * ! 15522: EVLI1 EXI 3 TAKE FAILURE RETURN ! 15523: * ! 15524: * HERE IF ARGUMENT IS NOT INTEGER ! 15525: * ! 15526: EVLI2 EXI 1 TAKE NON-INTEGER ERROR EXIT ! 15527: * ! 15528: * HERE IF ARGUMENT IS OUT OF RANGE ! 15529: * ! 15530: EVLI3 EXI 2 TAKE OUT-OF-RANGE ERROR EXIT ! 15531: ENP END PROCEDURE EVALI ! 15532: EJC ! 15533: * ! 15534: * EVALP -- EVALUATE EXPRESSION DURING PATTERN MATCH ! 15535: * ! 15536: * EVALP IS USED TO EVALUATE AN EXPRESSION (BY VALUE) DURING ! 15537: * A PATTERN MATCH. THE EFFECT IS LIKE EVALX, BUT PATTERN ! 15538: * VARIABLES ARE STACKED AND RESTORED IF NECESSARY. ! 15539: * ! 15540: * EVALP ALSO DIFFERS FROM EVALX IN THAT IF THE RESULT IS ! 15541: * AN EXPRESSION IT IS REEVALUATED. THIS OCCURS REPEATEDLY. ! 15542: * ! 15543: * (XR) NODE POINTER ! 15544: * (WB) PATTERN MATCH CURSOR ! 15545: * JSR EVALP CALL TO EVALUATE EXPRESSION ! 15546: * PPM LOC TRANSFER LOC IF EVALUATION FAILS ! 15547: * (XL) RESULT ! 15548: * (WA) FIRST WORD OF RESULT BLOCK ! 15549: * (XR,WB) DESTROYED (FAILURE CASE ONLY) ! 15550: * (WC,RA) DESTROYED ! 15551: * ! 15552: * THE EXPRESSION POINTER IS STORED IN PARM1 OF THE NODE ! 15553: * ! 15554: * CONTROL RETURNS TO FAILP ON FAILURE OF EVALUATION ! 15555: * ! 15556: EVALP PRC R,1 ENTRY POINT (RECURSIVE) ! 15557: MOV PARM1(XR),XL LOAD EXPRESSION POINTER ! 15558: BEQ (XL),=B$EXL,EVLP1 JUMP IF EXBLK CASE ! 15559: * ! 15560: * HERE FOR CASE OF SEBLK ! 15561: * ! 15562: * WE CAN GIVE A FAST RETURN IF THE VALUE OF THE VRBLK IS ! 15563: * NOT AN EXPRESSION AND IS NOT TRAPPED. ! 15564: * ! 15565: MOV SEVAR(XL),XL LOAD VRBLK POINTER ! 15566: MOV VRVAL(XL),XL LOAD VALUE OF VRBLK ! 15567: MOV (XL),WA LOAD FIRST WORD OF VALUE ! 15568: BHI WA,=B$T$$,EVLP3 JUMP IF NOT SEBLK, TRBLK OR EXBLK ! 15569: * ! 15570: * HERE FOR EXBLK OR SEBLK WITH EXPR VALUE OR TRAPPED VALUE ! 15571: * ! 15572: EVLP1 MOV XR,-(XS) STACK NODE POINTER ! 15573: MOV WB,-(XS) STACK CURSOR ! 15574: MOV R$PMS,-(XS) STACK SUBJECT STRING POINTER ! 15575: MOV PMSSL,-(XS) STACK SUBJECT STRING LENGTH ! 15576: MOV PMDFL,-(XS) STACK DOT FLAG ! 15577: MOV PMHBS,-(XS) STACK HISTORY STACK BASE POINTER ! 15578: MOV PARM1(XR),XR LOAD EXPRESSION POINTER ! 15579: EJC ! 15580: * ! 15581: * EVALP (CONTINUED) ! 15582: * ! 15583: * LOOP BACK HERE TO REEVALUATE EXPRESSION RESULT ! 15584: * ! 15585: EVLP2 ZER WB SET FLAG FOR BY VALUE ! 15586: JSR EVALX EVALUATE EXPRESSION ! 15587: PPM EVLP4 JUMP ON FAILURE ! 15588: MOV (XR),WA ELSE LOAD FIRST WORD OF VALUE ! 15589: BLO WA,=B$E$$,EVLP2 LOOP BACK TO REEVALUATE EXPRESSION ! 15590: * ! 15591: * HERE TO RESTORE PATTERN VALUES AFTER SUCCESSFUL EVAL ! 15592: * ! 15593: MOV XR,XL COPY RESULT POINTER ! 15594: MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER ! 15595: MOV (XS)+,PMDFL RESTORE DOT FLAG ! 15596: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH ! 15597: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER ! 15598: MOV (XS)+,WB RESTORE CURSOR ! 15599: MOV (XS)+,XR RESTORE NODE POINTER ! 15600: * ! 15601: * COMMON EXIT POINT ! 15602: * ! 15603: EVLP3 EXI RETURN TO EVALP CALLER ! 15604: * ! 15605: * HERE FOR FAILURE DURING EVALUATION ! 15606: * ! 15607: EVLP4 MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER ! 15608: MOV (XS)+,PMDFL RESTORE DOT FLAG ! 15609: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH ! 15610: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER ! 15611: ADD *NUM02,XS REMOVE NODE PTR, CURSOR ! 15612: EXI 1 TAKE FAILURE EXIT ! 15613: ENP END PROCEDURE EVALP ! 15614: EJC ! 15615: * ! 15616: * EVALS -- EVALUATE STRING ARGUMENT ! 15617: * ! 15618: * EVALS IS USED BY SPAN, ANY, NOTANY, BREAK, BREAKX WHEN ! 15619: * THEY ARE PASSED AN EXPRESSION ARGUMENT. ! 15620: * ! 15621: * (XR) NODE POINTER ! 15622: * (WB) CURSOR ! 15623: * JSR EVALS CALL TO EVALUATE STRING ! 15624: * PPM LOC TRANSFER LOC FOR NON-STRING ARG ! 15625: * PPM LOC TRANSFER LOC FOR EVALUATION FAILURE ! 15626: * PPM LOC TRANSFER LOC FOR SUCCESSFUL EVAL ! 15627: * (THE NORMAL RETURN IS NEVER TAKEN) ! 15628: * (XR) PTR TO NODE WITH PARMS SET ! 15629: * (XL,WC,RA) DESTROYED ! 15630: * ! 15631: * ON RETURN, THE NODE POINTED TO HAS A CHARACTER TABLE ! 15632: * POINTER IN PARM1 AND A BIT MASK IN PARM2. THE PROPER ! 15633: * SUCCESSOR IS STORED IN PTHEN OF THIS NODE. THUS IT IS ! 15634: * OK FOR MERGING WITH THE NORMAL (MULTI-CHAR STRING) CASE. ! 15635: * ! 15636: EVALS PRC R,3 ENTRY POINT (RECURSIVE) ! 15637: JSR EVALP EVALUATE EXPRESSION ! 15638: PPM EVLS1 JUMP IF EVALUATION FAILS ! 15639: MOV PTHEN(XR),-(XS) SAVE SUCCESSOR POINTER ! 15640: MOV WB,-(XS) SAVE CURSOR ! 15641: MOV XL,-(XS) STACK RESULT PTR FOR PATST ! 15642: ZER WB DUMMY PCODE FOR ONE CHAR STRING ! 15643: ZER WC DUMMY PCODE FOR EXPRESSION ARG ! 15644: MOV =P$BRK,XL APPROPRIATE PCODE FOR OUR USE ! 15645: JSR PATST CALL ROUTINE TO BUILD NODE ! 15646: PPM EVLS2 JUMP IF NOT STRING ! 15647: MOV (XS)+,WB RESTORE CURSOR ! 15648: MOV (XS)+,PTHEN(XR) STORE SUCCESSOR POINTER ! 15649: EXI 3 TAKE SUCCESS RETURN ! 15650: * ! 15651: * HERE IF EVALUATION FAILS ! 15652: * ! 15653: EVLS1 EXI 2 TAKE FAILURE RETURN ! 15654: * ! 15655: * HERE IF ARGUMENT IS NOT STRING ! 15656: * ! 15657: EVLS2 ADD *NUM02,XS POP SUCCESSOR AND CURSOR ! 15658: EXI 1 TAKE NON-STRING ERROR EXIT ! 15659: ENP END PROCEDURE EVALS ! 15660: EJC ! 15661: * ! 15662: * EVALX -- EVALUATE EXPRESSION ! 15663: * ! 15664: * EVALX IS CALLED TO EVALUATE AN EXPRESSION ! 15665: * ! 15666: * (XR) POINTER TO EXBLK OR SEBLK ! 15667: * (WB) 0 IF BY VALUE, 1 IF BY NAME ! 15668: * JSR EVALX CALL TO EVALUATE EXPRESSION ! 15669: * PPM LOC TRANSFER LOC IF EVALUATION FAILS ! 15670: * (XR) RESULT IF CALLED BY VALUE ! 15671: * (XL,WA) RESULT NAME BASE,OFFSET IF BY NAME ! 15672: * (XR) DESTROYED (NAME CASE ONLY) ! 15673: * (XL,WA) DESTROYED (VALUE CASE ONLY) ! 15674: * (WB,WC,RA) DESTROYED ! 15675: * ! 15676: EVALX PRC R,1 ENTRY POINT, RECURSIVE ! 15677: BEQ (XR),=B$EXL,EVLX2 JUMP IF EXBLK CASE ! 15678: * ! 15679: * HERE FOR SEBLK ! 15680: * ! 15681: MOV SEVAR(XR),XL LOAD VRBLK POINTER (NAME BASE) ! 15682: MOV *VRVAL,WA SET NAME OFFSET ! 15683: BNZ WB,EVLX1 JUMP IF CALLED BY NAME ! 15684: JSR ACESS CALL ROUTINE TO ACCESS VALUE ! 15685: PPM EVLX9 JUMP IF FAILURE ON ACCESS ! 15686: * ! 15687: * MERGE HERE TO EXIT FOR SEBLK CASE ! 15688: * ! 15689: EVLX1 EXI RETURN TO EVALX CALLER ! 15690: EJC ! 15691: * ! 15692: * EVALX (CONTINUED) ! 15693: * ! 15694: * HERE FOR FULL EXPRESSION (EXBLK) CASE ! 15695: * ! 15696: * IF AN ERROR OCCURS IN THE EXPRESSION CODE AT EXECUTION ! 15697: * TIME, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL ! 15698: * WITHOUT RETURNING TO THIS ROUTINE. ! 15699: * THE FOLLOWING ENTRIES ARE MADE ON THE STACK BEFORE ! 15700: * GIVING CONTROL TO THE EXPRESSION CODE ! 15701: * ! 15702: * EVALX RETURN POINT ! 15703: * SAVED VALUE OF R$COD ! 15704: * CODE POINTER (-R$COD) ! 15705: * SAVED VALUE OF FLPTR ! 15706: * 0 IF BY VALUE, 1 IF BY NAME ! 15707: * FLPTR --------------- *EXFLC, FAIL OFFSET IN EXBLK ! 15708: * ! 15709: EVLX2 SCP WC GET CODE POINTER ! 15710: MOV R$COD,WA LOAD CODE BLOCK POINTER ! 15711: SUB WA,WC GET CODE POINTER AS OFFSET ! 15712: MOV WA,-(XS) STACK OLD CODE BLOCK POINTER ! 15713: MOV WC,-(XS) STACK RELATIVE CODE OFFSET ! 15714: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER ! 15715: MOV WB,-(XS) STACK NAME/VALUE INDICATOR ! 15716: MOV *EXFLC,-(XS) STACK NEW FAIL OFFSET ! 15717: MOV FLPTR,GTCEF KEEP IN CASE OF ERROR ! 15718: MOV R$COD,R$GTC KEEP CODE BLOCK POINTER SIMILARLY ! 15719: MOV XS,FLPTR SET NEW FAILURE POINTER ! 15720: MOV XR,R$COD SET NEW CODE BLOCK POINTER ! 15721: MOV KVSTN,EXSTM(XR) REMEMBER STMNT NUMBER ! 15722: ADD *EXCOD,XR POINT TO FIRST CODE WORD ! 15723: LCP XR SET CODE POINTER ! 15724: BNE STAGE,=STGXT,EXITS JUMP IF NOT EXECUTION TIME ! 15725: MOV =STGEE,STAGE EVALUATING EXPRESSION ! 15726: BRN EXITS JUMP TO EXECUTE FIRST CODE WORD ! 15727: EJC ! 15728: * ! 15729: * EVALX (CONTINUED) ! 15730: * ! 15731: * COME HERE IF SUCCESSFUL RETURN BY VALUE (SEE O$RVL) ! 15732: * ! 15733: EVLX3 MOV (XS)+,XR LOAD VALUE ! 15734: BZE 1(XS),EVLX5 JUMP IF CALLED BY VALUE ! 15735: ERB 249,EXPRESSION EVALUATED BY NAME RETURNED VALUE ! 15736: * ! 15737: * HERE FOR EXPRESSION RETURNING BY NAME (SEE O$RNM) ! 15738: * ! 15739: EVLX4 MOV (XS)+,WA LOAD NAME OFFSET ! 15740: MOV (XS)+,XL LOAD NAME BASE ! 15741: BNZ 1(XS),EVLX5 JUMP IF CALLED BY NAME ! 15742: JSR ACESS ELSE ACCESS VALUE FIRST ! 15743: PPM EVLX6 JUMP IF FAILURE DURING ACCESS ! 15744: * ! 15745: * HERE AFTER LOADING CORRECT RESULT INTO XR OR XL,WA ! 15746: * ! 15747: EVLX5 ZER WB NOTE SUCCESSFUL ! 15748: BRN EVLX7 MERGE ! 15749: * ! 15750: * HERE FOR FAILURE IN EXPRESSION EVALUATION (SEE O$FEX) ! 15751: * ! 15752: EVLX6 MNZ WB NOTE UNSUCCESSFUL ! 15753: * ! 15754: * RESTORE ENVIRONMENT ! 15755: * ! 15756: EVLX7 BNE STAGE,=STGEE,EVLX8 SKIP IF WAS NOT PREVIOUSLY XT ! 15757: MOV =STGXT,STAGE EXECUTE TIME ! 15758: * ! 15759: * MERGE WITH STAGE SET UP ! 15760: * ! 15761: EVLX8 ADD *NUM02,XS POP NAME/VALUE INDICATOR, *EXFAL ! 15762: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER ! 15763: MOV (XS)+,WC LOAD CODE OFFSET ! 15764: ADD (XS),WC MAKE CODE POINTER ABSOLUTE ! 15765: MOV (XS)+,R$COD RESTORE OLD CODE BLOCK POINTER ! 15766: LCP WC RESTORE OLD CODE POINTER ! 15767: BZE WB,EVLX1 JUMP FOR SUCCESSFUL RETURN ! 15768: * ! 15769: * MERGE HERE FOR FAILURE IN SEBLK CASE ! 15770: * ! 15771: EVLX9 EXI 1 TAKE FAILURE EXIT ! 15772: ENP END OF PROCEDURE EVALX ! 15773: EJC ! 15774: * ! 15775: * EXBLD -- BUILD EXBLK ! 15776: * ! 15777: * EXBLD IS USED TO BUILD AN EXPRESSION BLOCK FROM THE ! 15778: * CODE COMPILED MOST RECENTLY IN THE CURRENT CCBLK. ! 15779: * ! 15780: * (XL) OFFSET IN CCBLK TO START OF CODE ! 15781: * (WB) INTEGER IN RANGE 0 LE N LE MXLEN ! 15782: * JSR EXBLD CALL TO BUILD EXBLK ! 15783: * (XR) PTR TO CONSTRUCTED EXBLK ! 15784: * (WA,WB,XL) DESTROYED ! 15785: * ! 15786: EXBLD PRC E,0 ENTRY POINT ! 15787: MOV XL,WA COPY OFFSET TO START OF CODE ! 15788: SUB *EXCOD,WA CALC REDUCTION IN OFFSET IN EXBLK ! 15789: MOV WA,-(XS) STACK FOR LATER ! 15790: MOV CWCOF,WA LOAD FINAL OFFSET ! 15791: SUB XL,WA COMPUTE LENGTH OF CODE ! 15792: ADD *EXSI$,WA ADD SPACE FOR STANDARD FIELDS ! 15793: JSR ALLOC ALLOCATE SPACE FOR EXBLK ! 15794: MOV XR,-(XS) SAVE POINTER TO EXBLK ! 15795: MOV =B$EXL,EXTYP(XR) STORE TYPE WORD ! 15796: ZER EXSTM(XR) ZEROISE STMNT NUMBER FIELD ! 15797: MOV WA,EXLEN(XR) STORE LENGTH ! 15798: MOV =OFEX$,EXFLC(XR) STORE FAILURE WORD ! 15799: ADD *EXSI$,XR SET XR FOR SYSMW ! 15800: MOV XL,CWCOF RESET OFFSET TO START OF CODE ! 15801: ADD R$CCB,XL POINT TO START OF CODE ! 15802: SUB *EXSI$,WA LENGTH OF CODE TO MOVE ! 15803: MOV WA,-(XS) STACK LENGTH OF CODE ! 15804: MVW MOVE CODE TO EXBLK ! 15805: MOV (XS)+,WA GET LENGTH OF CODE ! 15806: BTW WA CONVERT BYTE COUNT TO WORD COUNT ! 15807: LCT WA,WA PREPARE COUNTER FOR LOOP ! 15808: MOV (XS),XL COPY EXBLK PTR, DONT UNSTACK ! 15809: ADD *EXCOD,XL POINT TO CODE ITSELF ! 15810: MOV 1(XS),WB GET REDUCTION IN OFFSET ! 15811: * ! 15812: * THIS LOOP SEARCHES FOR NEGATION AND SELECTION CODE SO ! 15813: * THAT THE OFFSETS COMPUTED WHILST CODE WAS IN CODE BLOCK ! 15814: * CAN BE TRANSFORMED TO REDUCED VALUES APPLICABLE IN AN ! 15815: * EXBLK. ! 15816: * ! 15817: EXBL1 MOV (XL)+,XR GET NEXT CODE WORD ! 15818: BEQ XR,=OSLA$,EXBL3 JUMP IF SELECTION FOUND ! 15819: BEQ XR,=ONTA$,EXBL3 JUMP IF NEGATION FOUND ! 15820: BCT WA,EXBL1 LOOP TO END OF CODE ! 15821: * ! 15822: * NO SELECTION FOUND OR MERGE TO EXIT ON TERMINATION ! 15823: * ! 15824: EXBL2 MOV (XS)+,XR POP EXBLK PTR INTO XR ! 15825: MOV (XS)+,XL POP REDUCTION CONSTANT ! 15826: EXI RETURN TO CALLER ! 15827: EJC ! 15828: * ! 15829: * EXBLD (CONTINUED) ! 15830: * ! 15831: * SELECTION OR NEGATION FOUND ! 15832: * REDUCE THE OFFSETS AS NEEDED. OFFSETS OCCUR IN WORDS ! 15833: * FOLLOWING CODE WORDS - ! 15834: * =ONTA$, =OSLA$, =OSLB$, =OSLC$ ! 15835: * ! 15836: EXBL3 SUB WB,(XL)+ ADJUST OFFSET ! 15837: BCT WA,EXBL4 DECREMENT COUNT ! 15838: * ! 15839: EXBL4 BCT WA,EXBL5 DECREMENT COUNT ! 15840: * ! 15841: * CONTINUE SEARCH FOR MORE OFFSETS ! 15842: * ! 15843: EXBL5 MOV (XL)+,XR GET NEXT CODE WORD ! 15844: BEQ XR,=OSLA$,EXBL3 JUMP IF OFFSET FOUND ! 15845: BEQ XR,=OSLB$,EXBL3 JUMP IF OFFSET FOUND ! 15846: BEQ XR,=OSLC$,EXBL3 JUMP IF OFFSET FOUND ! 15847: BEQ XR,=ONTA$,EXBL3 JUMP IF OFFSET FOUND ! 15848: BCT WA,EXBL5 LOOP ! 15849: BRN EXBL2 MERGE TO RETURN ! 15850: ENP END PROCEDURE EXBLD ! 15851: EJC ! 15852: * ! 15853: * EXPAN -- ANALYZE EXPRESSION ! 15854: * ! 15855: * THE EXPRESSION ANALYZER (EXPAN) PROCEDURE IS USED TO SCAN ! 15856: * AN EXPRESSION AND CONVERT IT INTO A TREE REPRESENTATION. ! 15857: * SEE DESCRIPTIONS OF CMBLK, CUBLK, CBBLK IN THE STRUCTURES ! 15858: * SECTION FOR DETAILED FORMAT OF TREE BLOCKS. ! 15859: * ! 15860: * THE ANALYZER USES A SIMPLE PRECEDENCE SCHEME IN WHICH ! 15861: * OPERANDS AND OPERATORS ARE PLACED ON A SINGLE STACK ! 15862: * AND CONDENSATIONS ARE MADE WHEN LOW PRECEDENCE OPERATORS ! 15863: * ARE STACKED AFTER A HIGHER PRECEDENCE OPERATOR. A GLOBAL ! 15864: * VARIABLE (IN WB) KEEPS TRACK OF THE LEVEL AS FOLLOWS. ! 15865: * ! 15866: * 0 SCANNING OUTER LEVEL OF STATEMENT OR EXPRESSION ! 15867: * 1 SCANNING OUTER LEVEL OF NORMAL GOTO ! 15868: * 2 SCANNING OUTER LEVEL OF DIRECT GOTO ! 15869: * 3 SCANNING INSIDE ARRAY BRACKETS ! 15870: * 4 SCANNING INSIDE GROUPING PARENTHESES ! 15871: * 5 SCANNING INSIDE FUNCTION PARENTHESES ! 15872: * ! 15873: * THIS VARIABLE IS SAVED ON THE STACK ON ENCOUNTERING A ! 15874: * GROUPING AND RESTORED AT THE END OF THE GROUPING. ! 15875: * ! 15876: * ANOTHER GLOBAL VARIABLE (IN WC) COUNTS THE NUMBER OF ! 15877: * ITEMS AT ONE GROUPING LEVEL AND IS INCREMENTED FOR EACH ! 15878: * COMMA ENCOUNTERED. IT IS STACKED WITH THE LEVEL INDICATOR ! 15879: * ! 15880: * THE SCAN IS CONTROLLED BY A THREE STATE FINITE MACHINE. ! 15881: * A GLOBAL VARIABLE STORED IN WA IS THE CURRENT STATE. ! 15882: * ! 15883: * WA=0 NOTHING SCANNED AT THIS LEVEL ! 15884: * WA=1 OPERAND EXPECTED ! 15885: * WA=2 OPERATOR EXPECTED ! 15886: * ! 15887: * (WB) CALL TYPE (SEE BELOW) ! 15888: * JSR EXPAN CALL TO ANALYZE EXPRESSION ! 15889: * (XR) POINTER TO RESULTING TREE ! 15890: * (XL,WA,WB,WC,RA) DESTROYED ! 15891: * ! 15892: * THE ENTRY VALUE OF WB INDICATES THE CALL TYPE AS FOLLOWS. ! 15893: * ! 15894: * 0 SCANNING EITHER THE MAIN BODY OF A STATEMENT OR THE ! 15895: * TEXT OF AN EXPRESSION (FROM EVAL CALL). VALID ! 15896: * TERMINATORS ARE COLON, SEMICOLON. THE RESCAN FLAG IS ! 15897: * SET TO RETURN THE TERMINATOR ON THE NEXT SCANE CALL. ! 15898: * ! 15899: * 1 SCANNING A NORMAL GOTO. THE ONLY VALID ! 15900: * TERMINATOR IS A RIGHT PAREN. ! 15901: * ! 15902: * 2 SCANNING A DIRECT GOTO. THE ONLY VALID ! 15903: * TERMINATOR IS A RIGHT BRACKET. ! 15904: EJC ! 15905: * ! 15906: * EXPAN (CONTINUED) ! 15907: * ! 15908: * ENTRY POINT ! 15909: * ! 15910: EXPAN PRC E,0 ENTRY POINT ! 15911: ZER -(XS) SET TOP OF STACK INDICATOR ! 15912: ZER WA SET INITIAL STATE TO ZERO ! 15913: ZER WC ZERO COUNTER VALUE ! 15914: * ! 15915: * LOOP HERE FOR SUCCESSIVE ENTRIES ! 15916: * ! 15917: EXP01 JSR SCANE SCAN NEXT ELEMENT ! 15918: ADD WA,XL ADD STATE TO SYNTAX CODE ! 15919: BSW XL,T$NES SWITCH ON ELEMENT TYPE/STATE ! 15920: IFF T$VA0,EXP03 VARIABLE, S=0 ! 15921: IFF T$VA1,EXP03 VARIABLE, STATE ONE ! 15922: IFF T$VA2,EXP04 VARIABLE, S=2 ! 15923: IFF T$CO0,EXP03 CONSTANT, S=0 ! 15924: IFF T$CO1,EXP03 CONSTANT, S=1 ! 15925: IFF T$CO2,EXP04 CONSTANT, S=2 ! 15926: IFF T$LP0,EXP06 LEFT PAREN, S=0 ! 15927: IFF T$LP1,EXP06 LEFT PAREN, S=1 ! 15928: IFF T$LP2,EXP04 LEFT PAREN, S=2 ! 15929: IFF T$FN0,EXP10 FUNCTION, S=0 ! 15930: IFF T$FN1,EXP10 FUNCTION, S=1 ! 15931: IFF T$FN2,EXP04 FUNCTION, S=2 ! 15932: IFF T$RP0,EXP02 RIGHT PAREN, S=0 ! 15933: IFF T$RP1,EXP05 RIGHT PAREN, S=1 ! 15934: IFF T$RP2,EXP12 RIGHT PAREN, S=2 ! 15935: IFF T$LB0,EXP08 LEFT BRKT, S=0 ! 15936: IFF T$LB1,EXP08 LEFT BRKT, S=1 ! 15937: IFF T$LB2,EXP09 LEFT BRKT, S=2 ! 15938: IFF T$RB0,EXP02 RIGHT BRKT, S=0 ! 15939: IFF T$RB1,EXP05 RIGHT BRKT, S=1 ! 15940: IFF T$RB2,EXP18 RIGHT BRKT, S=2 ! 15941: IFF T$UO0,EXP27 UNOP, S=0 ! 15942: IFF T$UO1,EXP27 UNOP, S=1 ! 15943: IFF T$UO2,EXP04 UNOP, S=2 ! 15944: IFF T$BO0,EXP05 BINOP, S=0 ! 15945: IFF T$BO1,EXP05 BINOP, S=1 ! 15946: IFF T$BO2,EXP26 BINOP, S=2 ! 15947: IFF T$CM0,EXP02 COMMA, S=0 ! 15948: IFF T$CM1,EXP05 COMMA, S=1 ! 15949: IFF T$CM2,EXP11 COMMA, S=2 ! 15950: IFF T$CL0,EXP02 COLON, S=0 ! 15951: IFF T$CL1,EXP05 COLON, S=1 ! 15952: IFF T$CL2,EXP19 COLON, S=2 ! 15953: IFF T$SM0,EXP02 SEMICOLON, S=0 ! 15954: IFF T$SM1,EXP05 SEMICOLON, S=1 ! 15955: IFF T$SM2,EXP19 SEMICOLON, S=2 ! 15956: ESW END SWITCH ON ELEMENT TYPE/STATE ! 15957: EJC ! 15958: * ! 15959: * EXPAN (CONTINUED) ! 15960: * ! 15961: * HERE FOR RBR,RPR,COL,SMC,CMA IN STATE 0 ! 15962: * ! 15963: * SET TO RESCAN THE TERMINATOR ENCOUNTERED AND CREATE ! 15964: * A NULL CONSTANT (CASE OF OMITTED NULL) ! 15965: * ! 15966: EXP02 MNZ SCNRS SET TO RESCAN ELEMENT ! 15967: MOV =NULLS,XR POINT TO NULL, MERGE ! 15968: * ! 15969: * HERE FOR VAR OR CON IN STATES 0,1 ! 15970: * ! 15971: * STACK THE VARIABLE/CONSTANT AND SET STATE=2 ! 15972: * ! 15973: EXP03 MOV XR,-(XS) STACK POINTER TO OPERAND ! 15974: MOV =NUM02,WA SET STATE 2 ! 15975: BRN EXP01 JUMP FOR NEXT ELEMENT ! 15976: * ! 15977: * HERE FOR VAR,CON,LPR,FNC,UOP IN STATE 2 ! 15978: * ! 15979: * WE RESCAN THE ELEMENT AND CREATE A CONCATENATION OPERATOR ! 15980: * THIS IS THE CASE OF THE BLANK CONCATENATION OPERATOR. ! 15981: * ! 15982: EXP04 MNZ SCNRS SET TO RESCAN ELEMENT ! 15983: MOV =OPDVC,XR POINT TO CONCAT OPERATOR DV ! 15984: BZE WB,EXP4A OK IF AT TOP LEVEL ! 15985: MOV =OPDVP,XR ELSE POINT TO UNMISTAKABLE CONCAT. ! 15986: * ! 15987: * MERGE HERE WHEN XR SET UP WITH PROPER CONCATENATION DVBLK ! 15988: * ! 15989: EXP4A BNZ SCNBL,EXP26 MERGE BOP IF BLANKS, ELSE ERROR ! 15990: DCV SCNSE ADJUST START OF ELEMENT LOCATION ! 15991: ERB 220,SYNTAX ERROR. MISSING OPERATOR ! 15992: * ! 15993: * HERE FOR CMA,RPR,RBR,COL,SMC,BOP(S=1) BOP(S=0) ! 15994: * ! 15995: * THIS IS AN ERRONOUS CONTRUCTION ! 15996: * ! 15997: EXP05 DCV SCNSE ADJUST START OF ELEMENT LOCATION ! 15998: ERB 221,SYNTAX ERROR. MISSING OPERAND ! 15999: * ! 16000: * HERE FOR LPR (S=0,1) ! 16001: * ! 16002: EXP06 MOV =NUM04,XL SET NEW LEVEL INDICATOR ! 16003: ZER XR SET ZERO VALUE FOR CMOPN ! 16004: EJC ! 16005: * ! 16006: * EXPAN (CONTINUED) ! 16007: * ! 16008: * MERGE HERE TO STORE OLD LEVEL ON STACK AND START NEW ONE ! 16009: * ! 16010: EXP07 MOV XR,-(XS) STACK CMOPN VALUE ! 16011: MOV WC,-(XS) STACK OLD COUNTER ! 16012: MOV WB,-(XS) STACK OLD LEVEL INDICATOR ! 16013: CHK CHECK FOR STACK OVERFLOW ! 16014: ZER WA SET NEW STATE TO ZERO ! 16015: MOV XL,WB SET NEW LEVEL INDICATOR ! 16016: MOV =NUM01,WC INITIALIZE NEW COUNTER ! 16017: BRN EXP01 JUMP TO SCAN NEXT ELEMENT ! 16018: * ! 16019: * HERE FOR LBR (S=0,1) ! 16020: * ! 16021: * THIS IS AN ILLEGAL USE OF LEFT BRACKET ! 16022: * ! 16023: EXP08 ERB 222,SYNTAX ERROR. INVALID USE OF LEFT BRACKET ! 16024: * ! 16025: * HERE FOR LBR (S=2) ! 16026: * ! 16027: * SET NEW LEVEL AND START TO SCAN SUBSCRIPTS ! 16028: * ! 16029: EXP09 MOV (XS)+,XR LOAD ARRAY PTR FOR CMOPN ! 16030: MOV =NUM03,XL SET NEW LEVEL INDICATOR ! 16031: BRN EXP07 JUMP TO STACK OLD AND START NEW ! 16032: * ! 16033: * HERE FOR FNC (S=0,1) ! 16034: * ! 16035: * STACK OLD LEVEL AND START TO SCAN ARGUMENTS ! 16036: * ! 16037: EXP10 MOV =NUM05,XL SET NEW LEV INDIC (XR=VRBLK=CMOPN) ! 16038: BRN EXP07 JUMP TO STACK OLD AND START NEW ! 16039: * ! 16040: * HERE FOR CMA (S=2) ! 16041: * ! 16042: * INCREMENT ARGUMENT COUNT AND CONTINUE ! 16043: * ! 16044: EXP11 ICV WC INCREMENT COUNTER ! 16045: JSR EXPDM DUMP OPERATORS AT THIS LEVEL ! 16046: ZER -(XS) SET NEW LEVEL FOR PARAMETER ! 16047: ZER WA SET NEW STATE ! 16048: BGT WB,=NUM02,EXP01 LOOP BACK UNLESS OUTER LEVEL ! 16049: ERB 223,SYNTAX ERROR. INVALID USE OF COMMA ! 16050: EJC ! 16051: * ! 16052: * EXPAN (CONTINUED) ! 16053: * ! 16054: * HERE FOR RPR (S=2) ! 16055: * ! 16056: * AT OUTER LEVEL IN A NORMAL GOTO THIS IS A TERMINATOR ! 16057: * OTHERWISE IT MUST TERMINATE A FUNCTION OR GROUPING ! 16058: * ! 16059: EXP12 BEQ WB,=NUM01,EXP20 END OF NORMAL GOTO ! 16060: BEQ WB,=NUM05,EXP13 END OF FUNCTION ARGUMENTS ! 16061: BEQ WB,=NUM04,EXP14 END OF GROUPING / SELECTION ! 16062: ERB 224,SYNTAX ERROR. UNBALANCED RIGHT PARENTHESIS ! 16063: * ! 16064: * HERE AT END OF FUNCTION ARGUMENTS ! 16065: * ! 16066: EXP13 MOV =C$FNC,XL SET CMTYP VALUE FOR FUNCTION ! 16067: BRN EXP15 JUMP TO BUILD CMBLK ! 16068: * ! 16069: * HERE FOR END OF GROUPING ! 16070: * ! 16071: EXP14 BEQ WC,=NUM01,EXP17 JUMP IF END OF GROUPING ! 16072: MOV =C$SEL,XL ELSE SET CMTYP FOR SELECTION ! 16073: * ! 16074: * MERGE HERE TO BUILD CMBLK FOR LEVEL JUST SCANNED AND ! 16075: * TO POP UP TO THE PREVIOUS SCAN LEVEL BEFORE CONTINUING. ! 16076: * ! 16077: EXP15 JSR EXPDM DUMP OPERATORS AT THIS LEVEL ! 16078: MOV WC,WA COPY COUNT ! 16079: ADD =CMVLS,WA ADD FOR STANDARD FIELDS AT START ! 16080: WTB WA CONVERT LENGTH TO BYTES ! 16081: JSR ALLOC ALLOCATE SPACE FOR CMBLK ! 16082: MOV =B$CMT,(XR) STORE TYPE CODE FOR CMBLK ! 16083: MOV XL,CMTYP(XR) STORE CMBLK NODE TYPE INDICATOR ! 16084: MOV WA,CMLEN(XR) STORE LENGTH ! 16085: ADD WA,XR POINT PAST END OF BLOCK ! 16086: LCT WC,WC SET LOOP COUNTER ! 16087: * ! 16088: * LOOP TO MOVE REMAINING WORDS TO CMBLK ! 16089: * ! 16090: EXP16 MOV (XS)+,-(XR) MOVE ONE OPERAND PTR FROM STACK ! 16091: MOV (XS)+,WB POP TO OLD LEVEL INDICATOR ! 16092: BCT WC,EXP16 LOOP TILL ALL MOVED ! 16093: EJC ! 16094: * ! 16095: * EXPAN (CONTINUED) ! 16096: * ! 16097: * COMPLETE CMBLK AND STACK POINTER TO IT ON STACK ! 16098: * ! 16099: SUB *CMVLS,XR POINT BACK TO START OF BLOCK ! 16100: MOV (XS)+,WC RESTORE OLD COUNTER ! 16101: MOV (XS),CMOPN(XR) STORE OPERAND PTR IN CMBLK ! 16102: MOV XR,(XS) STACK CMBLK POINTER ! 16103: MOV =NUM02,WA SET NEW STATE ! 16104: BRN EXP01 BACK FOR NEXT ELEMENT ! 16105: * ! 16106: * HERE AT END OF A PARENTHESIZED EXPRESSION ! 16107: * ! 16108: EXP17 JSR EXPDM DUMP OPERATORS AT THIS LEVEL ! 16109: MOV (XS)+,XR RESTORE XR ! 16110: MOV (XS)+,WB RESTORE OUTER LEVEL ! 16111: MOV (XS)+,WC RESTORE OUTER COUNT ! 16112: MOV XR,(XS) STORE OPND OVER UNUSED CMOPN VAL ! 16113: MOV =NUM02,WA SET NEW STATE ! 16114: BRN EXP01 BACK FOR NEXT ELE8ENT ! 16115: * ! 16116: * HERE FOR RBR (S=2) ! 16117: * ! 16118: * AT OUTER LEVEL IN A DIRECT GOTO, THIS IS A TERMINATOR. ! 16119: * OTHERWISE IT MUST TERMINATE A SUBSCRIPT LIST. ! 16120: * ! 16121: EXP18 MOV =C$ARR,XL SET CMTYP FOR ARRAY REFERENCE ! 16122: BEQ WB,=NUM03,EXP15 JUMP TO BUILD CMBLK IF END ARRAYREF ! 16123: BEQ WB,=NUM02,EXP20 JUMP IF END OF DIRECT GOTO ! 16124: ERB 225,SYNTAX ERROR. UNBALANCED RIGHT BRACKET ! 16125: EJC ! 16126: * ! 16127: * EXPAN (CONTINUED) ! 16128: * ! 16129: * HERE FOR COL,SMC (S=2) ! 16130: * ! 16131: * ERROR UNLESS TERMINATING STATEMENT BODY AT OUTER LEVEL ! 16132: * ! 16133: EXP19 MNZ SCNRS RESCAN TERMINATOR ! 16134: MOV WB,XL COPY LEVEL INDICATOR ! 16135: BSW XL,6 SWITCH ON LEVEL INDICATOR ! 16136: IFF 0,EXP20 NORMAL OUTER LEVEL ! 16137: IFF 1,EXP22 FAIL IF NORMAL GOTO ! 16138: IFF 2,EXP23 FAIL IF DIRECT GOTO ! 16139: IFF 3,EXP24 FAIL ARRAY BRACKETS ! 16140: IFF 4,EXP21 FAIL IF IN GROUPING ! 16141: IFF 5,EXP21 FAIL FUNCTION ARGS ! 16142: ESW END SWITCH ON LEVEL ! 16143: * ! 16144: * HERE AT NORMAL END OF EXPRESSION ! 16145: * ! 16146: EXP20 JSR EXPDM DUMP REMAINING OPERATORS ! 16147: MOV (XS)+,XR LOAD TREE POINTER ! 16148: ICA XS POP OFF BOTTOM OF STACK MARKER ! 16149: EXI RETURN TO EXPAN CALLER ! 16150: * ! 16151: * MISSING RIGHT PAREN ! 16152: * ! 16153: EXP21 ERB 226,SYNTAX ERROR. MISSING RIGHT PAREN ! 16154: * ! 16155: * MISSING RIGHT PAREN IN GOTO FIELD ! 16156: * ! 16157: EXP22 ERB 227,SYNTAX ERROR. RIGHT PAREN MISSING FROM GOTO ! 16158: * ! 16159: * MISSING BRACKET IN GOTO ! 16160: * ! 16161: EXP23 ERB 228,SYNTAX ERROR. RIGHT BRACKET MISSING FROM GOTO ! 16162: * ! 16163: * MISSING ARRAY BRACKET ! 16164: * ! 16165: EXP24 ERB 229,SYNTAX ERROR. MISSING RIGHT ARRAY BRACKET ! 16166: EJC ! 16167: * ! 16168: * EXPAN (CONTINUED) ! 16169: * ! 16170: * LOOP HERE WHEN AN OPERATOR CAUSES AN OPERATOR DUMP ! 16171: * ! 16172: EXP25 MOV XR,EXPSV ! 16173: JSR EXPOP POP ONE OPERATOR ! 16174: MOV EXPSV,XR RESTORE OP DV POINTER AND MERGE ! 16175: * ! 16176: * HERE FOR BOP (S=2) ! 16177: * ! 16178: * REMOVE OPERATORS (CONDENSE) FROM STACK UNTIL NO MORE ! 16179: * LEFT AT THIS LEVEL OR TOP ONE HAS LOWER PRECEDENCE. ! 16180: * LOOP HERE TILL THIS CONDITION IS MET. ! 16181: * ! 16182: EXP26 MOV 1(XS),XL LOAD OPERATOR DVPTR FROM STACK ! 16183: BLE XL,=NUM05,EXP27 JUMP IF BOTTOM OF STACK LEVEL ! 16184: BLT DVRPR(XR),DVLPR(XL),EXP25 ELSE POP IF NEW PREC IS LO ! 16185: * ! 16186: * HERE FOR UOP (S=0,1) ! 16187: * ! 16188: * BINARY OPERATOR MERGES AFTER PRECEDENCE CHECK ! 16189: * ! 16190: * THE OPERATOR DV IS STORED ON THE STACK AND THE SCAN ! 16191: * CONTINUES AFTER SETTING THE SCAN STATE TO ONE. ! 16192: * ! 16193: EXP27 MOV XR,-(XS) STACK OPERATOR DVPTR ON STACK ! 16194: CHK CHECK FOR STACK OVERFLOW ! 16195: MOV =NUM01,WA SET NEW STATE ! 16196: BNE XR,=OPDVS,EXP01 BACK FOR NEXT ELEMENT UNLESS = ! 16197: * ! 16198: * HERE FOR SPECIAL CASE OF BINARY =. THE SYNTAX ALLOWS A ! 16199: * NULL RIGHT ARGUMENT FOR THIS OPERATOR TO BE LEFT ! 16200: * OUT. ACCORDINGLY WE RESET TO STATE ZERO TO GET PROPER ! 16201: * ACTION ON A TERMINATOR (SUPPLY A NULL CONSTANT). ! 16202: * ! 16203: ZER WA SET STATE ZERO ! 16204: BRN EXP01 JUMP FOR NEXT ELEMENT ! 16205: ENP END PROCEDURE EXPAN ! 16206: EJC ! 16207: * ! 16208: * EXPAP -- TEST FOR PATTERN MATCH TREE ! 16209: * ! 16210: * EXPAP IS PASSED AN EXPRESSION TREE TO DETERMINE IF IT ! 16211: * IS A PATTERN MATCH. THE FOLLOWING ARE RECOGIZED AS ! 16212: * MATCHES IN THE CONTEXT OF THIS CALL. ! 16213: * ! 16214: * 1) AN EXPLICIT USE OF BINARY QUESTION MARK ! 16215: * 2) A CONCATENATION ! 16216: * 3) AN ALTERNATION WHOSE LEFT OPERAND IS A CONCATENATION ! 16217: * ! 16218: * (XR) PTR TO EXPAN TREE ! 16219: * JSR EXPAP CALL TO TEST FOR PATTERN MATCH ! 16220: * PPM LOC TRANSFER LOC IF NOT A PATTERN MATCH ! 16221: * (WA) DESTROYED ! 16222: * (XR) UNCHANGED (IF NOT MATCH) ! 16223: * (XR) PTR TO BINARY OPERATOR BLK IF MATCH ! 16224: * ! 16225: EXPAP PRC E,1 ENTRY POINT ! 16226: MOV XL,-(XS) SAVE XL ! 16227: BNE (XR),=B$CMT,EXPP2 NO MATCH IF NOT COMPLEX ! 16228: MOV CMTYP(XR),WA ELSE LOAD TYPE CODE ! 16229: BEQ WA,=C$CNC,EXPP1 CONCATENATION IS A MATCH ! 16230: BEQ WA,=C$PMT,EXPP1 BINARY QUESTION MARK IS A MATCH ! 16231: BNE WA,=C$ALT,EXPP2 ELSE NOT MATCH UNLESS ALTERNATION ! 16232: * ! 16233: * HERE FOR ALTERNATION. CHANGE (A B) / C TO A QM (B / C) ! 16234: * ! 16235: MOV CMLOP(XR),XL LOAD LEFT OPERAND POINTER ! 16236: BNE (XL),=B$CMT,EXPP2 NOT MATCH IF LEFT OPND NOT COMPLEX ! 16237: BNE CMTYP(XL),=C$CNC,EXPP2 NOT MATCH IF LEFT OP NOT CONC ! 16238: MOV CMROP(XL),CMLOP(XR) XR POINTS TO (B / C) ! 16239: MOV XR,CMROP(XL) SET XL OPNDS TO A, (B / C) ! 16240: MOV XL,XR POINT TO THIS ALTERED NODE ! 16241: * ! 16242: * EXIT HERE FOR PATTERN MATCH ! 16243: * ! 16244: EXPP1 MOV (XS)+,XL RESTORE ENTRY XL ! 16245: EXI GIVE PATTERN MATCH RETURN ! 16246: * ! 16247: * EXIT HERE IF NOT PATTERN MATCH ! 16248: * ! 16249: EXPP2 MOV (XS)+,XL RESTORE ENTRY XL ! 16250: EXI 1 GIVE NON-MATCH RETURN ! 16251: ENP END PROCEDURE EXPAP ! 16252: EJC ! 16253: * ! 16254: * EXPDM -- DUMP OPERATORS AT CURRENT LEVEL (FOR EXPAN) ! 16255: * ! 16256: * EXPDM USES EXPOP TO CONDENSE ALL OPERATORS AT THIS SYNTAX ! 16257: * LEVEL. THE STACK BOTTOM IS RECOGNIZED FROM THE LEVEL ! 16258: * VALUE WHICH IS SAVED ON THE TOP OF THE STACK. ! 16259: * ! 16260: * JSR EXPDM CALL TO DUMP OPERATORS ! 16261: * (XS) POPPED AS REQUIRED ! 16262: * (XR,WA) DESTROYED ! 16263: * ! 16264: EXPDM PRC N,0 ENTRY POINT ! 16265: MOV XL,R$EXS SAVE XL VALUE ! 16266: * ! 16267: * LOOP TO DUMP OPERATORS ! 16268: * ! 16269: EXDM1 BLE 1(XS),=NUM05,EXDM2 JUMP IF STACK BOTTOM (SAVED LEVEL ! 16270: JSR EXPOP ELSE POP ONE OPERATOR ! 16271: BRN EXDM1 AND LOOP BACK ! 16272: * ! 16273: * HERE AFTER POPPING ALL OPERATORS ! 16274: * ! 16275: EXDM2 MOV R$EXS,XL RESTORE XL ! 16276: ZER R$EXS RELEASE SAVE LOCATION ! 16277: EXI RETURN TO EXPDM CALLER ! 16278: ENP END PROCEDURE EXPDM ! 16279: EJC ! 16280: * ! 16281: * EXPOP-- POP OPERATOR (FOR EXPAN) ! 16282: * ! 16283: * EXPOP IS USED BY THE EXPAN ROUTINE TO CONDENSE ONE ! 16284: * OPERATOR FROM THE TOP OF THE SYNTAX STACK. AN APPROPRIATE ! 16285: * CMBLK IS BUILT FOR THE OPERATOR (UNARY OR BINARY) AND A ! 16286: * POINTER TO THIS CMBLK IS STACKED. ! 16287: * ! 16288: * EXPOP IS ALSO USED BY SCNGF (GOTO FIELD SCAN) PROCEDURE ! 16289: * ! 16290: * JSR EXPOP CALL TO POP OPERATOR ! 16291: * (XS) POPPED APPROPRIATELY ! 16292: * (XR,XL,WA) DESTROYED ! 16293: * ! 16294: EXPOP PRC N,0 ENTRY POINT ! 16295: MOV 1(XS),XR LOAD OPERATOR DV POINTER ! 16296: BEQ DVLPR(XR),=LLUNO,EXPO2 JUMP IF UNARY ! 16297: * ! 16298: * HERE FOR BINARY OPERATOR ! 16299: * ! 16300: MOV *CMBS$,WA SET SIZE OF BINARY OPERATOR CMBLK ! 16301: JSR ALLOC ALLOCATE SPACE FOR CMBLK ! 16302: MOV (XS)+,CMROP(XR) POP AND STORE RIGHT OPERAND PTR ! 16303: MOV (XS)+,XL POP AND LOAD OPERATOR DV PTR ! 16304: MOV (XS),CMLOP(XR) STORE LEFT OPERAND POINTER ! 16305: * ! 16306: * COMMON EXIT POINT ! 16307: * ! 16308: EXPO1 MOV =B$CMT,(XR) STORE TYPE CODE FOR CMBLK ! 16309: MOV DVTYP(XL),CMTYP(XR) STORE CMBLK NODE TYPE CODE ! 16310: MOV XL,CMOPN(XR) STORE DVPTR (=PTR TO DAC O$XXX) ! 16311: MOV WA,CMLEN(XR) STORE CMBLK LENGTH ! 16312: MOV XR,(XS) STORE RESULTING NODE PTR ON STACK ! 16313: EXI RETURN TO EXPOP CALLER ! 16314: * ! 16315: * HERE FOR UNARY OPERATOR ! 16316: * ! 16317: EXPO2 MOV *CMUS$,WA SET SIZE OF UNARY OPERATOR CMBLK ! 16318: JSR ALLOC ALLOCATE SPACE FOR CMBLK ! 16319: MOV (XS)+,CMROP(XR) POP AND STORE OPERAND POINTER ! 16320: MOV (XS),XL LOAD OPERATOR DV POINTER ! 16321: BRN EXPO1 MERGE BACK TO EXIT ! 16322: ENP END PROCEDURE EXPOP ! 16323: EJC ! 16324: .IF .CULC ! 16325: * ! 16326: * FLSTG -- FOLD STRING TO UPPER CASE ! 16327: * ! 16328: * FLSTG FOLDS A CHARACTER STRING CONTAINING LOWER CASE ! 16329: * CHARACCTERS TO ONE CONTAINING UPPER CASE CHARACTERS. ! 16330: * FOLDING IS ONLY DONE IF &CASE (KVCAS) IS NOT ZERO. ! 16331: * ! 16332: * (XR) STRING ARGUMENT ! 16333: * (WA) LENGTH OF STRING ! 16334: * JSR FLSTG CALL TO FOLD STRING ! 16335: * (XR) RESULT STRING (POSSIBLY ORIGINAL) ! 16336: * (WC) DESTROYED ! 16337: * ! 16338: FLSTG PRC R,0 ENTRY POINT ! 16339: BZE KVCAS,FST99 SKIP IF &CASE IS 0 ! 16340: MOV XL,-(XS) SAVE XL ACROSS CALL ! 16341: MOV XR,-(XS) SAVE ORIGINAL SCBLK PTR ! 16342: JSR ALOCS ALLOCATE NEW STRING BLOCK ! 16343: MOV (XS),XL POINT TO ORIGINAL SCBLK ! 16344: MOV XR,-(XS) SAVE POINTER TO NEW SCBLK ! 16345: PLC XL POINT TO ORIGINAL CHARS ! 16346: PLC XR POINT TO NEW CHARS ! 16347: ZER -(XS) INIT DID FOLD FLAG ! 16348: LCT WC,WC LOAD LOOP COUNTER ! 16349: FST01 LCH WA,(XL)+ LOAD CHARACTER ! 16350: BGT =CH$$A,WA,FST02 SKIP IF LESS THAN LC A ! 16351: BGT WA,=CH$$$,FST02 SKIP IF GREATER THAN LC Z ! 16352: FLC WA FOLD CHARACTER TO UPPER CASE ! 16353: MNZ (XS) SET DID FOLD CHARACTER FLAG ! 16354: FST02 SCH WA,(XR)+ STORE (POSSIBLY FOLDED) CHARACTER ! 16355: BCT WC,FST01 LOOP THRU ENTIRE STRING ! 16356: CSC XR COMPLETE STORE CHARACTERS ! 16357: BNZ (XS)+,FST10 SKIP IF FOLDING DONE ! 16358: MOV (XS)+,DNAMP DO NOT NEED NEW SCBLK ! 16359: MOV (XS)+,XR RETURN ORIGINAL SCBLK ! 16360: BRN FST20 MERGE BELOW ! 16361: FST10 MOV (XS)+,XR RETURN NEW SCBLK ! 16362: ICA XS THROW AWAY ORIGINAL SCBLK POINTER ! 16363: FST20 MOV SCLEN(XR),WA RELOAD STRING LENGTH ! 16364: MOV (XS)+,XL RESTORE XL ! 16365: FST99 EXI RETURN ! 16366: ENP ! 16367: EJC ! 16368: .FI ! 16369: * ! 16370: * GBCOL -- PERFORM GARBAGE COLLECTION ! 16371: * ! 16372: * GBCOL PERFORMS A GARBAGE COLLECTION ON THE DYNAMIC REGION ! 16373: * ALL BLOCKS WHICH ARE NO LONGER IN USE ARE ELIMINATED ! 16374: * BY MOVING BLOCKS WHICH ARE IN USE DOWN AND RESETTING ! 16375: * DNAMP, THE POINTER TO THE NEXT AVAILABLE LOCATION. ! 16376: * ! 16377: * (WB) MOVE OFFSET (SEE BELOW) ! 16378: * JSR GBCOL CALL TO COLLECT GARBAGE ! 16379: * (XR) DESTROYED ! 16380: * ! 16381: * THE FOLLOWING CONDITIONS MUST BE MET AT THE TIME WHEN ! 16382: * GBCOL IS CALLED. ! 16383: * ! 16384: * 1) ALL POINTERS TO BLOCKS IN THE DYNAMIC AREA MUST BE ! 16385: * ACCESSIBLE TO THE GARBAGE COLLECTOR. THIS MEANS ! 16386: * THAT THEY MUST OCCUR IN ONE OF THE FOLLOWING. ! 16387: * ! 16388: * A) MAIN STACK, WITH CURRENT TOP ! 16389: * ELEMENT BEING INDICATED BY XS ! 16390: * ! 16391: * B) IN RELOCATABLE FIELDS OF VRBLKS. ! 16392: * ! 16393: * C) IN REGISTER XL AT THE TIME OF CALL ! 16394: * ! 16395: * E) IN THE SPECIAL REGION OF WORKING ! 16396: * STORAGE WHERE NAMES BEGIN WITH R$. ! 16397: * ! 16398: * 2) ALL POINTERS MUST POINT TO THE START OF BLOCKS WITH ! 16399: * THE SOLE EXCEPTION OF THE CONTENTS OF THE CODE ! 16400: * POINTER REGISTER WHICH POINTS INTO THE R$COD BLOCK. ! 16401: * ! 16402: * 3) NO LOCATION WHICH APPEARS TO CONTAIN A POINTER ! 16403: * INTO THE DYNAMIC REGION MAY OCCUR UNLESS IT IS IN ! 16404: * FACT A POINTER TO THE START OF THE BLOCK. HOWEVER ! 16405: * POINTERS OUTSIDE THIS AREA MAY OCCUR AND WILL ! 16406: * NOT BE CHANGED BY THE GARBAGE COLLECTOR. ! 16407: * IT IS ESPECIALLY IMPORTANT TO MAKE SURE THAT XL ! 16408: * DOES NOT CONTAIN A GARBAGE VALUE FROM SOME PROCESS ! 16409: * CARRIED OUT BEFORE THE CALL TO THE COLLECTOR. ! 16410: * ! 16411: * GBCOL HAS THE CAPABILITY OF MOVING THE FINAL COMPACTED ! 16412: * RESULT UP IN MEMORY (WITH ADDRESSES ADJUSTED ACCORDINGLY) ! 16413: * THIS IS USED TO ADD SPACE TO THE STATIC REGION. THE ! 16414: * ENTRY VALUE OF WB IS THE NUMBER OF BYTES TO MOVE UP. ! 16415: * THE CALLER MUST GUARANTEE THAT THERE IS ENOUGH ROOM. ! 16416: * FURTHERMORE THE VALUE IN WB IF IT IS NON-ZERO, MUST BE AT ! 16417: * LEAST 256 SO THAT THE MWB INSTRUCTION CONDITIONS ARE MET. ! 16418: EJC ! 16419: * ! 16420: * GBCOL (CONTINUED) ! 16421: * ! 16422: * THE ALGORITHM, WHICH IS A MODIFICATION OF THE LISP-2 ! 16423: * GARBAGE COLLECTOR DEVISED BY R.DEWAR AND K.BELCHER ! 16424: * TAKES THREE PASSES AS FOLLOWS. ! 16425: * ! 16426: * 1) ALL POINTERS IN MEMORY ARE SCANNED AND BLOCKS IN USE ! 16427: * DETERMINED FROM THIS SCAN. NOTE THAT THIS PROCEDURE ! 16428: * IS RECURSIVE AND USES THE MAIN STACK FOR LINKAGE. ! 16429: * THE MARKING PROCESS IS THUS SIMILAR TO THAT USED IN ! 16430: * A STANDARD LISP COLLECTOR. HOWEVER THE METHOD OF ! 16431: * ACTUALLY MARKING THE BLOCKS IS DIFFERENT. ! 16432: * ! 16433: * THE FIRST FIELD OF A BLOCK NORMALLY CONTAINS A ! 16434: * CODE ENTRY POINT POINTER. SUCH AN ENTRY POINTER ! 16435: * CAN BE DISTINGUISHED FROM THE ADDRESS OF ANY POINTER ! 16436: * TO BE PROCESSED BY THE COLLECTOR. DURING GARBAGE ! 16437: * COLLECTION, THIS WORD IS USED TO BUILD A BACK CHAIN ! 16438: * OF POINTERS THROUGH FIELDS WHICH POINT TO THE BLOCK. ! 16439: * THE END OF THE CHAIN IS MARKED BY THE OCCURENCE ! 16440: * OF THE WORD WHICH USED TO BE IN THE FIRST WORD OF ! 16441: * THE BLOCK. THIS BACKCHAIN SERVES BOTH AS A MARK ! 16442: * INDICATING THAT THE BLOCK IS IN USE AND AS A LIST OF ! 16443: * REFERENCES FOR THE RELOCATION PHASE. ! 16444: * ! 16445: * 2) STORAGE IS SCANNED SEQUENTIALLY TO DISCOVER WHICH ! 16446: * BLOCKS ARE CURRENTLY IN USE AS INDICATED BY THE ! 16447: * PRESENCE OF A BACKCHAIN. TWO POINTERS ARE MAINTAINED ! 16448: * ONE SCANS THROUGH LOOKING AT EACH BLOCK. THE OTHER ! 16449: * IS INCREMENTED ONLY FOR BLOCKS FOUND TO BE IN USE. ! 16450: * IN THIS WAY, THE EVENTUAL LOCATION OF EACH BLOCK CAN ! 16451: * BE DETERMINED WITHOUT ACTUALLY MOVING ANY BLOCKS. ! 16452: * AS EACH BLOCK WHICH IS IN USE IS PROCESSED, THE BACK ! 16453: * CHAIN IS USED TO RESET ALL POINTERS WHICH POINT TO ! 16454: * THIS BLOCK TO CONTAIN ITS NEW ADDRESS, I.E. THE ! 16455: * ADDRESS IT WILL OCCUPY AFTER THE BLOCKS ARE MOVED. ! 16456: * THE FIRST WORD OF THE BLOCK, TAKEN FROM THE END OF ! 16457: * THE CHAIN IS RESTORED AT THIS POINT. ! 16458: * ! 16459: * DURING PASS 2, THE COLLECTOR BUILDS BLOCKS WHICH ! 16460: * DESCRIBE THE REGIONS OF STORAGE WHICH ARE TO BE ! 16461: * MOVED IN THE THIRD PASS. THERE IS ONE DESCRIPTOR FOR ! 16462: * EACH CONTIGUOUS SET OF GOOD BLOCKS. THE DESCRIPTOR ! 16463: * IS BUILT JUST BEHIND THE BLOCK TO BE MOVED AND ! 16464: * CONTAINS A POINTER TO THE NEXT BLOCK AND THE NUMBER ! 16465: * OF WORDS TO BE MOVED. ! 16466: * ! 16467: * 3) IN THE THIRD AND FINAL PASS, THE MOVE DESCRIPTOR ! 16468: * BLOCKS BUILT IN PASS TWO ARE USED TO ACTUALLY MOVE ! 16469: * THE BLOCKS DOWN TO THE BOTTOM OF THE DYNAMIC REGION. ! 16470: * THE COLLECTION IS THEN COMPLETE AND THE NEXT ! 16471: * AVAILABLE LOCATION POINTER IS RESET. ! 16472: EJC ! 16473: * ! 16474: * GBCOL (CONTINUED) ! 16475: * ! 16476: GBCOL PRC E,0 ENTRY POINT ! 16477: BNZ DMVCH,GBC14 FAIL IF IN MID-DUMP ! 16478: MNZ GBCFL NOTE GBCOL ENTERED ! 16479: MOV WA,GBSVA SAVE ENTRY WA ! 16480: MOV WB,GBSVB SAVE ENTRY WB ! 16481: MOV WC,GBSVC SAVE ENTRY WC ! 16482: MOV XL,-(XS) SAVE ENTRY XL ! 16483: SCP WA GET CODE POINTER VALUE ! 16484: SUB R$COD,WA MAKE RELATIVE ! 16485: LCP WA AND RESTORE ! 16486: * ! 16487: * PROCESS STACK ENTRIES ! 16488: * ! 16489: MOV XS,XR POINT TO STACK FRONT ! 16490: MOV STBAS,XL POINT PAST END OF STACK ! 16491: BGE XL,XR,GBC00 OK IF D-STACK ! 16492: MOV XL,XR REVERSE IF ... ! 16493: MOV XS,XL ... U-STACK ! 16494: * ! 16495: * PROCESS THE STACK ! 16496: * ! 16497: GBC00 JSR GBCPF PROCESS POINTERS ON STACK ! 16498: * ! 16499: * PROCESS SPECIAL WORK LOCATIONS ! 16500: * ! 16501: MOV =R$AAA,XR POINT TO START OF RELOCATABLE LOCS ! 16502: MOV =R$YYY,XL POINT PAST END OF RELOCATABLE LOCS ! 16503: JSR GBCPF PROCESS WORK FIELDS ! 16504: * ! 16505: * PREPARE TO PROCESS VARIABLE BLOCKS ! 16506: * ! 16507: MOV HSHTB,WA POINT TO FIRST HASH SLOT POINTER ! 16508: * ! 16509: * LOOP THROUGH HASH SLOTS ! 16510: * ! 16511: GBC01 MOV WA,XL POINT TO NEXT SLOT ! 16512: ICA WA BUMP BUCKET POINTER ! 16513: MOV WA,GBCNM SAVE BUCKET POINTER ! 16514: EJC ! 16515: * ! 16516: * GBCOL (CONTINUED) ! 16517: * ! 16518: * LOOP THROUGH VARIABLES ON ONE HASH CHAIN ! 16519: * ! 16520: GBC02 MOV (XL),XR LOAD PTR TO NEXT VRBLK ! 16521: BZE XR,GBC03 JUMP IF END OF CHAIN ! 16522: MOV XR,XL ELSE COPY VRBLK POINTER ! 16523: ADD *VRVAL,XR POINT TO FIRST RELOC FLD ! 16524: ADD *VRNXT,XL POINT PAST LAST (AND TO LINK PTR) ! 16525: JSR GBCPF PROCESS RELOC FIELDS IN VRBLK ! 16526: BRN GBC02 LOOP BACK FOR NEXT BLOCK ! 16527: * ! 16528: * HERE AT END OF ONE HASH CHAIN ! 16529: * ! 16530: GBC03 MOV GBCNM,WA RESTORE BUCKET POINTER ! 16531: BNE WA,HSHTE,GBC01 LOOP BACK IF MORE BUCKETS TO GO ! 16532: EJC ! 16533: * ! 16534: * GBCOL (CONTINUED) ! 16535: * ! 16536: * NOW WE ARE READY TO START PASS TWO. REGISTERS ARE USED ! 16537: * AS FOLLOWS IN PASS TWO. ! 16538: * ! 16539: * (XR) SCANS THROUGH ALL BLOCKS ! 16540: * (WC) POINTER TO EVENTUAL LOCATION ! 16541: * ! 16542: * THE MOVE DESCRIPTION BLOCKS BUILT IN THIS PASS HAVE ! 16543: * THE FOLLOWING FORMAT. ! 16544: * ! 16545: * WORD 1 POINTER TO NEXT MOVE BLOCK, ! 16546: * ZERO IF END OF CHAIN OF BLOCKS ! 16547: * ! 16548: * WORD 2 LENGTH OF BLOCKS TO BE MOVED IN ! 16549: * BYTES. SET TO THE ADDRESS OF THE ! 16550: * FIRST BYTE WHILE ACTUALLY SCANNING ! 16551: * THE BLOCKS. ! 16552: * ! 16553: * THE FIRST ENTRY ON THIS CHAIN IS A SPECIAL ENTRY ! 16554: * CONSISTING OF THE TWO WORDS GBCNM AND GBCNS. AFTER ! 16555: * BUILDING THE CHAIN OF MOVE DESCRIPTORS, GBCNM POINTS TO ! 16556: * THE FIRST REAL MOVE BLOCK, AND GBCNS IS THE LENGTH OF ! 16557: * BLOCKS IN USE AT THE START OF STORAGE WHICH NEED NOT ! 16558: * BE MOVED SINCE THEY ARE IN THE CORRECT POSITION. ! 16559: * ! 16560: GBC04 MOV DNAMB,XR POINT TO FIRST BLOCK ! 16561: MOV XR,WC SET AS FIRST EVENTUAL LOCATION ! 16562: ADD GBSVB,WC ADD OFFSET FOR EVENTUAL MOVE UP ! 16563: ZER GBCNM CLEAR INITIAL FORWARD POINTER ! 16564: MOV =GBCNM,GBCLM INITIALIZE PTR TO LAST MOVE BLOCK ! 16565: MOV XR,GBCNS INITIALIZE FIRST ADDRESS ! 16566: * ! 16567: * LOOP THROUGH A SERIES OF BLOCKS IN USE ! 16568: * ! 16569: GBC05 BEQ XR,DNAMP,GBC07 JUMP IF END OF USED REGION ! 16570: MOV (XR),WA ELSE GET FIRST WORD ! 16571: BHI WA,=P$YYY,GBC06 SKIP IF NOT ENTRY PTR (IN USE) ! 16572: BHI WA,=B$AAA,GBC07 JUMP IF ENTRY POINTER (UNUSED) ! 16573: * ! 16574: * HERE FOR BLOCK IN USE, LOOP TO RELOCATE REFERENCES ! 16575: * ! 16576: GBC06 MOV WA,XL COPY POINTER ! 16577: MOV (XL),WA LOAD FORWARD POINTER ! 16578: MOV WC,(XL) RELOCATE REFERENCE ! 16579: BHI WA,=P$YYY,GBC06 LOOP BACK IF NOT END OF CHAIN ! 16580: BLO WA,=B$AAA,GBC06 LOOP BACK IF NOT END OF CHAIN ! 16581: EJC ! 16582: * ! 16583: * GBCOL (CONTINUED) ! 16584: * ! 16585: * AT END OF CHAIN, RESTORE FIRST WORD AND BUMP PAST ! 16586: * ! 16587: MOV WA,(XR) RESTORE FIRST WORD ! 16588: JSR BLKLN GET LENGTH OF THIS BLOCK ! 16589: ADD WA,XR BUMP ACTUAL POINTER ! 16590: ADD WA,WC BUMP EVENTUAL POINTER ! 16591: BRN GBC05 LOOP BACK FOR NEXT BLOCK ! 16592: * ! 16593: * HERE AT END OF A SERIES OF BLOCKS IN USE ! 16594: * ! 16595: GBC07 MOV XR,WA COPY POINTER PAST LAST BLOCK ! 16596: MOV GBCLM,XL POINT TO PREVIOUS MOVE BLOCK ! 16597: SUB 1(XL),WA SUBTRACT STARTING ADDRESS ! 16598: MOV WA,1(XL) STORE LENGTH OF BLOCK TO BE MOVED ! 16599: * ! 16600: * LOOP THROUGH A SERIES OF BLOCKS NOT IN USE ! 16601: * ! 16602: GBC08 BEQ XR,DNAMP,GBC10 JUMP IF END OF USED REGION ! 16603: MOV (XR),WA ELSE LOAD FIRST WORD OF NEXT BLOCK ! 16604: BHI WA,=P$YYY,GBC09 JUMP IF IN USE ! 16605: BLO WA,=B$AAA,GBC09 JUMP IF IN USE ! 16606: JSR BLKLN ELSE GET LENGTH OF NEXT BLOCK ! 16607: ADD WA,XR PUSH POINTER ! 16608: BRN GBC08 AND LOOP BACK ! 16609: * ! 16610: * HERE FOR A BLOCK IN USE AFTER PROCESSING A SERIES OF ! 16611: * BLOCKS WHICH WERE NOT IN USE, BUILD NEW MOVE BLOCK. ! 16612: * ! 16613: GBC09 SUB *NUM02,XR POINT 2 WORDS BEHIND FOR MOVE BLOCK ! 16614: MOV GBCLM,XL POINT TO PREVIOUS MOVE BLOCK ! 16615: MOV XR,(XL) SET FORWARD PTR IN PREVIOUS BLOCK ! 16616: ZER (XR) ZERO FORWARD PTR OF NEW BLOCK ! 16617: MOV XR,GBCLM REMEMBER ADDRESS OF THIS BLOCK ! 16618: MOV XR,XL COPY PTR TO MOVE BLOCK ! 16619: ADD *NUM02,XR POINT BACK TO BLOCK IN USE ! 16620: MOV XR,1(XL) STORE STARTING ADDRESS ! 16621: BRN GBC06 JUMP TO PROCESS BLOCK IN USE ! 16622: EJC ! 16623: * ! 16624: * GBCOL (CONTINUED) ! 16625: * ! 16626: * HERE FOR PASS THREE -- ACTUALLY MOVE THE BLOCKS DOWN ! 16627: * ! 16628: * (XL) POINTER TO OLD LOCATION ! 16629: * (XR) POINTER TO NEW LOCATION ! 16630: * ! 16631: GBC10 MOV DNAMB,XR POINT TO START OF STORAGE ! 16632: ADD GBCNS,XR BUMP PAST UNMOVED BLOCKS AT START ! 16633: * ! 16634: * LOOP THROUGH MOVE DESCRIPTORS ! 16635: * ! 16636: GBC11 MOV GBCNM,XL POINT TO NEXT MOVE BLOCK ! 16637: BZE XL,GBC12 JUMP IF END OF CHAIN ! 16638: MOV (XL)+,GBCNM MOVE POINTER DOWN CHAIN ! 16639: MOV (XL)+,WA GET LENGTH TO MOVE ! 16640: MVW PERFORM MOVE ! 16641: BRN GBC11 LOOP BACK ! 16642: * ! 16643: * NOW TEST FOR MOVE UP ! 16644: * ! 16645: GBC12 MOV XR,DNAMP SET NEXT AVAILABLE LOC PTR ! 16646: MOV GBSVB,WB RELOAD MOVE OFFSET ! 16647: BZE WB,GBC13 JUMP IF NO MOVE REQUIRED ! 16648: MOV XR,XL ELSE COPY OLD TOP OF CORE ! 16649: ADD WB,XR POINT TO NEW TOP OF CORE ! 16650: MOV XR,DNAMP SAVE NEW TOP OF CORE POINTER ! 16651: MOV XL,WA COPY OLD TOP ! 16652: SUB DNAMB,WA MINUS OLD BOTTOM = LENGTH ! 16653: ADD WB,DNAMB BUMP BOTTOM TO GET NEW VALUE ! 16654: MWB PERFORM MOVE (BACKWARDS) ! 16655: * ! 16656: * MERGE HERE TO EXIT ! 16657: * ! 16658: GBC13 MOV GBSVA,WA RESTORE WA ! 16659: SCP WC GET CODE POINTER ! 16660: ADD R$COD,WC MAKE ABSOLUTE AGAIN ! 16661: LCP WC AND REPLACE ABSOLUTE VALUE ! 16662: MOV GBSVC,WC RESTORE WC ! 16663: MOV (XS)+,XL RESTORE ENTRY XL ! 16664: ICV GBCNT INCREMENT COUNT OF COLLECTIONS ! 16665: ZER XR CLEAR GARBAGE VALUE IN XR ! 16666: ZER GBCFL NOTE EXIT FROM GBCOL ! 16667: EXI EXIT TO GBCOL CALLER ! 16668: * ! 16669: * GARBAGE COLLECTION NOT ALLOWED WHILST DUMPING ! 16670: * ! 16671: GBC14 ICV ERRFT FATAL ERROR ! 16672: ERB 250,INSUFFICIENT MEMORY TO COMPLETE DUMP ! 16673: ENP END PROCEDURE GBCOL ! 16674: EJC ! 16675: * ! 16676: * GBCPF -- PROCESS FIELDS FOR GARBAGE COLLECTOR ! 16677: * ! 16678: * THIS PROCEDURE IS USED BY THE GARBAGE COLLECTOR TO ! 16679: * PROCESS FIELDS IN PASS ONE. SEE GBCOL FOR FULL DETAILS. ! 16680: * ! 16681: * (XR) PTR TO FIRST LOCATION TO PROCESS ! 16682: * (XL) PTR PAST LAST LOCATION TO PROCESS ! 16683: * JSR GBCPF CALL TO PROCESS FIELDS ! 16684: * (XR,WA,WB,WC,IA) DESTROYED ! 16685: * ! 16686: * NOTE THAT ALTHOUGH THIS PROCEDURE USES A RECURSIVE ! 16687: * APPROACH, IT CONTROLS ITS OWN STACK AND IS NOT RECURSIVE. ! 16688: * ! 16689: GBCPF PRC E,0 ENTRY POINT ! 16690: ZER -(XS) SET ZERO TO MARK BOTTOM OF STACK ! 16691: MOV XL,-(XS) SAVE END POINTER ! 16692: * ! 16693: * MERGE HERE TO GO DOWN A LEVEL AND START A NEW LOOP ! 16694: * ! 16695: * 1(XS) NEXT LVL FIELD PTR (0 AT OUTER LVL) ! 16696: * 0(XS) PTR PAST LAST FIELD TO PROCESS ! 16697: * (XR) PTR TO FIRST FIELD TO PROCESS ! 16698: * ! 16699: * LOOP TO PROCESS SUCCESSIVE FIELDS ! 16700: * ! 16701: GPF01 MOV (XR),XL LOAD FIELD CONTENTS ! 16702: MOV XR,WC SAVE FIELD POINTER ! 16703: BLT XL,DNAMB,GPF02 JUMP IF NOT PTR INTO DYNAMIC AREA ! 16704: BGE XL,DNAMP,GPF02 JUMP IF NOT PTR INTO DYNAMIC AREA ! 16705: * ! 16706: * HERE WE HAVE A PTR TO A BLOCK IN THE DYNAMIC AREA. ! 16707: * LINK THIS FIELD ONTO THE REFERENCE BACKCHAIN. ! 16708: * ! 16709: MOV (XL),WA LOAD PTR TO CHAIN (OR ENTRY PTR) ! 16710: MOV XR,(XL) SET THIS FIELD AS NEW HEAD OF CHAIN ! 16711: MOV WA,(XR) SET FORWARD POINTER ! 16712: * ! 16713: * NOW SEE IF THIS BLOCK HAS BEEN PROCESSED BEFORE ! 16714: * ! 16715: BHI WA,=P$YYY,GPF02 JUMP IF ALREADY PROCESSED ! 16716: BHI WA,=B$AAA,GPF03 JUMP IF NOT ALREADY PROCESSED ! 16717: * ! 16718: * HERE TO MOVE TO NEXT FIELD ! 16719: * ! 16720: GPF02 MOV WC,XR RESTORE FIELD POINTER ! 16721: ICA XR BUMP TO NEXT FIELD ! 16722: BNE XR,(XS),GPF01 LOOP BACK IF MORE TO GO ! 16723: EJC ! 16724: * ! 16725: * GBCPF (CONTINUED) ! 16726: * ! 16727: * HERE WE POP UP A LEVEL AFTER FINISHING A BLOCK ! 16728: * ! 16729: MOV (XS)+,XL RESTORE POINTER PAST END ! 16730: MOV (XS)+,WC RESTORE BLOCK POINTER ! 16731: BNZ WC,GPF02 CONTINUE LOOP UNLESS OUTER LEVL ! 16732: EXI RETURN TO CALLER IF OUTER LEVEL ! 16733: * ! 16734: * HERE TO PROCESS AN ACTIVE BLOCK WHICH HAS NOT BEEN DONE ! 16735: * ! 16736: GPF03 MOV XL,XR COPY BLOCK POINTER ! 16737: MOV WA,XL COPY FIRST WORD OF BLOCK ! 16738: LEI XL LOAD ENTRY POINT ID (BL$XX) ! 16739: * ! 16740: * BLOCK TYPE SWITCH. NOTE THAT BLOCKS WITH NO RELOCATABLE ! 16741: * FIELDS JUST RETURN TO GPF02 HERE TO CONTINE TO NEXT FLD. ! 16742: * ! 16743: BSW XL,BL$$$ SWITCH ON BLOCK TYPE ! 16744: IFF BL$AR,GPF06 ARBLK ! 16745: .IF .CNBF ! 16746: .ELSE ! 16747: IFF BL$BC,GPF18 BCBLK ! 16748: IFF BL$BF,GPF02 BFBLK ! 16749: .FI ! 16750: IFF BL$CC,GPF07 CCBLK ! 16751: IFF BL$CD,GPF08 CDBLK ! 16752: IFF BL$CM,GPF04 CMBLK ! 16753: IFF BL$DF,GPF02 DFBLK ! 16754: IFF BL$EV,GPF10 EVBLK ! 16755: IFF BL$EX,GPF17 EXBLK ! 16756: IFF BL$FF,GPF11 FFBLK ! 16757: IFF BL$NM,GPF10 NMBLK ! 16758: IFF BL$P0,GPF10 P0BLK ! 16759: IFF BL$P1,GPF12 P1BLK ! 16760: IFF BL$P2,GPF12 P2BLK ! 16761: IFF BL$PD,GPF13 PDBLK ! 16762: IFF BL$PF,GPF14 PFBLK ! 16763: IFF BL$TB,GPF08 TBBLK ! 16764: IFF BL$TE,GPF15 TEBLK ! 16765: IFF BL$TR,GPF16 TRBLK ! 16766: IFF BL$VC,GPF08 VCBLK ! 16767: IFF BL$XR,GPF09 XRBLK ! 16768: IFF BL$CT,GPF02 CTBLK ! 16769: IFF BL$EF,GPF02 EFBLK ! 16770: IFF BL$IC,GPF02 ICBLK ! 16771: IFF BL$KV,GPF02 KVBLK ! 16772: .IF .CNRA ! 16773: .ELSE ! 16774: IFF BL$RC,GPF02 RCBLK ! 16775: .FI ! 16776: IFF BL$SC,GPF02 SCBLK ! 16777: IFF BL$SE,GPF02 SEBLK ! 16778: IFF BL$XN,GPF02 XNBLK ! 16779: ESW END OF JUMP TABLE ! 16780: EJC ! 16781: * ! 16782: * GBCPF (CONTINUED) ! 16783: * ! 16784: * CMBLK ! 16785: * ! 16786: GPF04 MOV CMLEN(XR),WA LOAD LENGTH ! 16787: MOV *CMTYP,WB SET OFFSET ! 16788: * ! 16789: * HERE TO PUSH DOWN TO NEW LEVEL ! 16790: * ! 16791: * (WC) FIELD PTR AT PREVIOUS LEVEL ! 16792: * (XR) PTR TO NEW BLOCK ! 16793: * (WA) LENGTH (RELOC FLDS + FLDS AT START) ! 16794: * (WB) OFFSET TO FIRST RELOC FIELD ! 16795: * ! 16796: GPF05 ADD XR,WA POINT PAST LAST RELOC FIELD ! 16797: ADD WB,XR POINT TO FIRST RELOC FIELD ! 16798: MOV WC,-(XS) STACK OLD FIELD POINTER ! 16799: MOV WA,-(XS) STACK NEW LIMIT POINTER ! 16800: CHK CHECK FOR STACK OVERFLOW ! 16801: BRN GPF01 IF OK, BACK TO PROCESS ! 16802: * ! 16803: * ARBLK ! 16804: * ! 16805: GPF06 MOV ARLEN(XR),WA LOAD LENGTH ! 16806: MOV AROFS(XR),WB SET OFFSET TO 1ST RELOC FLD (ARPRO) ! 16807: BRN GPF05 ALL SET ! 16808: * ! 16809: * CCBLK ! 16810: * ! 16811: GPF07 MOV CCUSE(XR),WA SET LENGTH IN USE ! 16812: MOV *CCUSE,WB 1ST WORD (MAKE SURE AT LEAST ONE) ! 16813: BRN GPF05 ALL SET ! 16814: EJC ! 16815: * ! 16816: * GBCPF (CONTINUED) ! 16817: * ! 16818: * CDBLK, TBBLK, VCBLK ! 16819: * ! 16820: GPF08 MOV OFFS2(XR),WA LOAD LENGTH ! 16821: MOV *OFFS3,WB SET OFFSET ! 16822: BRN GPF05 JUMP BACK ! 16823: * ! 16824: * XRBLK ! 16825: * ! 16826: GPF09 MOV XRLEN(XR),WA LOAD LENGTH ! 16827: MOV *XRPTR,WB SET OFFSET ! 16828: BRN GPF05 JUMP BACK ! 16829: * ! 16830: * EVBLK, NMBLK, P0BLK ! 16831: * ! 16832: GPF10 MOV *OFFS2,WA POINT PAST SECOND FIELD ! 16833: MOV *OFFS1,WB OFFSET IS ONE (ONLY RELOC FLD IS 2) ! 16834: BRN GPF05 ALL SET ! 16835: * ! 16836: * FFBLK ! 16837: * ! 16838: GPF11 MOV *FFOFS,WA SET LENGTH ! 16839: MOV *FFNXT,WB SET OFFSET ! 16840: BRN GPF05 ALL SET ! 16841: * ! 16842: * P1BLK, P2BLK ! 16843: * ! 16844: GPF12 MOV *PARM2,WA LENGTH (PARM2 IS NON-RELOCATABLE) ! 16845: MOV *PTHEN,WB SET OFFSET ! 16846: BRN GPF05 ALL SET ! 16847: EJC ! 16848: * ! 16849: * GBCPF (CONTINUED) ! 16850: * ! 16851: * PDBLK ! 16852: * ! 16853: GPF13 MOV PDDFP(XR),XL LOAD PTR TO DFBLK ! 16854: MOV DFPDL(XL),WA GET PDBLK LENGTH ! 16855: MOV *PDFLD,WB SET OFFSET ! 16856: BRN GPF05 ALL SET ! 16857: * ! 16858: * PFBLK ! 16859: * ! 16860: GPF14 MOV *PFARG,WA LENGTH PAST LAST RELOC ! 16861: MOV *PFCOD,WB OFFSET TO FIRST RELOC ! 16862: BRN GPF05 ALL SET ! 16863: * ! 16864: * TEBLK ! 16865: * ! 16866: GPF15 MOV *TESI$,WA SET LENGTH ! 16867: MOV *TESUB,WB AND OFFSET ! 16868: BRN GPF05 ALL SET ! 16869: * ! 16870: * TRBLK ! 16871: * ! 16872: GPF16 MOV *TRSI$,WA SET LENGTH ! 16873: MOV *TRVAL,WB AND OFFSET ! 16874: BRN GPF05 ALL SET ! 16875: * ! 16876: * EXBLK ! 16877: * ! 16878: GPF17 MOV EXLEN(XR),WA LOAD LENGTH ! 16879: MOV *EXFLC,WB SET OFFSET ! 16880: BRN GPF05 JUMP BACK ! 16881: .IF .CNBF ! 16882: .ELSE ! 16883: * ! 16884: * BCBLK ! 16885: * ! 16886: GPF18 MOV *BCSI$,WA SET LENGTH ! 16887: MOV *BCBUF,WB AND OFFSET ! 16888: BRN GPF05 ALL SET ! 16889: .FI ! 16890: ENP END PROCEDURE GBCPF ! 16891: EJC ! 16892: * ! 16893: * GTARR -- GET ARRAY ! 16894: * ! 16895: * GTARR IS PASSED AN OBJECT AND RETURNS AN ARRAY IF POSSIBL ! 16896: * ! 16897: * (XR) VALUE TO BE CONVERTED ! 16898: * JSR GTARR CALL TO GET ARRAY ! 16899: * PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE ! 16900: * (XR) RESULTING ARRAY ! 16901: * (XL,WA,WB,WC) DESTROYED ! 16902: * ! 16903: GTARR PRC E,1 ENTRY POINT ! 16904: MOV (XR),WA LOAD TYPE WORD ! 16905: BEQ WA,=B$ART,GTAR8 EXIT IF ALREADY AN ARRAY ! 16906: BEQ WA,=B$VCT,GTAR8 EXIT IF ALREADY AN ARRAY ! 16907: BNE WA,=B$TBT,GTA9A ELSE FAIL IF NOT A TABLE (SGD02) ! 16908: * ! 16909: * HERE WE CONVERT A TABLE TO AN ARRAY ! 16910: * ! 16911: MOV XR,-(XS) REPLACE TBBLK POINTER ON STACK ! 16912: ZER XR SIGNAL FIRST PASS ! 16913: ZER WB ZERO NON-NULL ELEMENT COUNT ! 16914: * ! 16915: * THE FOLLOWING CODE IS EXECUTED TWICE. ON THE FIRST PASS, ! 16916: * SIGNALLED BY XR=0, THE NUMBER OF NON-NULL ELEMENTS IN ! 16917: * THE TABLE IS COUNTED IN WB. IN THE SECOND PASS, WHERE ! 16918: * XR IS A POINTER INTO THE ARBLK, THE NAME AND VALUE ARE ! 16919: * ENTERED INTO THE CURRENT ARBLK LOCATION. ! 16920: * ! 16921: GTAR1 MOV (XS),XL POINT TO TABLE ! 16922: ADD TBLEN(XL),XL POINT PAST LAST BUCKET ! 16923: SUB *TBBUK,XL SET FIRST BUCKET OFFSET ! 16924: MOV XL,WA COPY ADJUSTED POINTER ! 16925: * ! 16926: * LOOP THROUGH BUCKETS IN TABLE BLOCK ! 16927: * NEXT THREE LINES OF CODE RELY ON TENXT HAVING A VALUE ! 16928: * 1 LESS THAN TBBUK. ! 16929: * ! 16930: GTAR2 MOV WA,XL COPY BUCKET POINTER ! 16931: DCA WA DECREMENT BUCKET POINTER ! 16932: * ! 16933: * LOOP THROUGH TEBLKS ON ONE BUCKET CHAIN ! 16934: * ! 16935: GTAR3 MOV TENXT(XL),XL POINT TO NEXT TEBLK ! 16936: BEQ XL,(XS),GTAR6 JUMP IF CHAIN END (TBBLK PTR) ! 16937: MOV XL,CNVTP ELSE SAVE TEBLK POINTER ! 16938: * ! 16939: * LOOP TO FIND VALUE DOWN TRBLK CHAIN ! 16940: * ! 16941: GTAR4 MOV TEVAL(XL),XL LOAD VALUE ! 16942: BEQ (XL),=B$TRT,GTAR4 LOOP TILL VALUE FOUND ! 16943: MOV XL,WC COPY VALUE ! 16944: MOV CNVTP,XL RESTORE TEBLK POINTER ! 16945: EJC ! 16946: * ! 16947: * GTARR (CONTINUED) ! 16948: * ! 16949: * NOW CHECK FOR NULL AND TEST CASES ! 16950: * ! 16951: BEQ WC,=NULLS,GTAR3 LOOP BACK TO IGNORE NULL VALUE ! 16952: BNZ XR,GTAR5 JUMP IF SECOND PASS ! 16953: ICV WB FOR THE FIRST PASS, BUMP COUNT ! 16954: BRN GTAR3 AND LOOP BACK FOR NEXT TEBLK ! 16955: * ! 16956: * HERE IN SECOND PASS ! 16957: * ! 16958: GTAR5 MOV TESUB(XL),(XR)+ STORE SUBSCRIPT NAME ! 16959: MOV WC,(XR)+ STORE VALUE IN ARBLK ! 16960: BRN GTAR3 LOOP BACK FOR NEXT TEBLK ! 16961: * ! 16962: * HERE AFTER SCANNING TEBLKS ON ONE CHAIN ! 16963: * ! 16964: GTAR6 BNE WA,(XS),GTAR2 LOOP BACK IF MORE BUCKETS TO GO ! 16965: BNZ XR,GTAR7 ELSE JUMP IF SECOND PASS ! 16966: * ! 16967: * HERE AFTER COUNTING NON-NULL ELEMENTS ! 16968: * ! 16969: BZE WB,GTAR9 FAIL IF NO NON-NULL ELEMENTS ! 16970: MOV WB,WA ELSE COPY COUNT ! 16971: ADD WB,WA DOUBLE (TWO WORDS/ELEMENT) ! 16972: ADD =ARVL2,WA ADD SPACE FOR STANDARD FIELDS ! 16973: WTB WA CONVERT LENGTH TO BYTES ! 16974: BGE WA,MXLEN,GTAR9 FAIL IF TOO LONG FOR ARRAY ! 16975: JSR ALLOC ELSE ALLOCATE SPACE FOR ARBLK ! 16976: MOV =B$ART,(XR) STORE TYPE WORD ! 16977: ZER IDVAL(XR) ZERO ID FOR THE MOMENT ! 16978: MOV WA,ARLEN(XR) STORE LENGTH ! 16979: MOV =NUM02,ARNDM(XR) SET DIMENSIONS = 2 ! 16980: LDI INTV1 GET INTEGER ONE ! 16981: STI ARLBD(XR) STORE AS LBD 1 ! 16982: STI ARLB2(XR) STORE AS LBD 2 ! 16983: LDI INTV2 LOAD INTEGER TWO ! 16984: STI ARDM2(XR) STORE AS DIM 2 ! 16985: MTI WB GET ELEMENT COUNT AS INTEGER ! 16986: STI ARDIM(XR) STORE AS DIM 1 ! 16987: ZER ARPR2(XR) ZERO PROTOTYPE FIELD FOR NOW ! 16988: MOV *ARPR2,AROFS(XR) SET OFFSET FIELD (SIGNAL PASS 2) ! 16989: MOV XR,WB SAVE ARBLK POINTER ! 16990: ADD *ARVL2,XR POINT TO FIRST ELEMENT LOCATION ! 16991: BRN GTAR1 JUMP BACK TO FILL IN ELEMENTS ! 16992: EJC ! 16993: * ! 16994: * GTARR (CONTINUED) ! 16995: * ! 16996: * HERE AFTER FILLING IN ELEMENT VALUES ! 16997: * ! 16998: GTAR7 MOV WB,XR RESTORE ARBLK POINTER ! 16999: MOV WB,(XS) STORE AS RESULT ! 17000: * ! 17001: * NOW WE NEED THE ARRAY PROTOTYPE WHICH IS OF THE FORM NN,2 ! 17002: * THIS IS OBTAINED BY BUILDING THE STRING FOR NN02 AND ! 17003: * CHANGING THE ZERO TO A COMMA BEFORE STORING IT. ! 17004: * ! 17005: LDI ARDIM(XR) GET NUMBER OF ELEMENTS (NN) ! 17006: MLI INTVH MULTIPLY BY 100 ! 17007: ADI INTV2 ADD 2 (NN02) ! 17008: JSR ICBLD BUILD INTEGER ! 17009: MOV XR,-(XS) STORE PTR FOR GTSTG ! 17010: JSR GTSTG CONVERT TO STRING ! 17011: PPM CONVERT FAIL IS IMPOSSIBLE ! 17012: MOV XR,XL COPY STRING POINTER ! 17013: MOV (XS)+,XR RELOAD ARBLK POINTER ! 17014: MOV XL,ARPR2(XR) STORE PROTOTYPE PTR (NN02) ! 17015: SUB =NUM02,WA ADJUST LENGTH TO POINT TO ZERO ! 17016: PSC XL,WA POINT TO ZERO ! 17017: MOV =CH$CM,WB LOAD A COMMA ! 17018: SCH WB,(XL) STORE A COMMA OVER THE ZERO ! 17019: CSC XL COMPLETE STORE CHARACTERS ! 17020: * ! 17021: * NORMAL RETURN ! 17022: * ! 17023: GTAR8 EXI RETURN TO CALLER ! 17024: * ! 17025: * NON-CONVERSION RETURN ! 17026: * ! 17027: GTAR9 MOV (XS)+,XR RESTORE STACK FOR CONV ERR (SGD02) ! 17028: * ! 17029: * MERGE TO TAKE CONVERT ERROR WHEN STACK ADJUSTED OK ! 17030: * ! 17031: GTA9A EXI 1 RETURN ! 17032: ENP PROCEDURE GTARR ! 17033: EJC ! 17034: * ! 17035: * GTCOD -- CONVERT TO CODE ! 17036: * ! 17037: * (XR) OBJECT TO BE CONVERTED ! 17038: * JSR GTCOD CALL TO CONVERT TO CODE ! 17039: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 17040: * (XR) POINTER TO RESULTING CDBLK ! 17041: * (XL,WA,WB,WC,RA) DESTROYED ! 17042: * ! 17043: * IF A SPITBOL ERROR OCCURS DURING COMPILATION OR PRE- ! 17044: * EVALUATION, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL ! 17045: * WITHOUT RETURNING TO THIS ROUTINE. ! 17046: * ! 17047: GTCOD PRC E,1 ENTRY POINT ! 17048: BEQ (XR),=B$CDS,GTCD1 JUMP IF ALREADY CODE ! 17049: BEQ (XR),=B$CDC,GTCD1 JUMP IF ALREADY CODE ! 17050: * ! 17051: * HERE WE MUST GENERATE A CDBLK BY COMPILATION ! 17052: * ! 17053: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG ! 17054: JSR GTSTG CONVERT ARGUMENT TO STRING ! 17055: PPM GTCD2 JUMP IF NON-CONVERTIBLE ! 17056: MOV FLPTR,GTCEF SAVE FAIL PTR IN CASE OF ERROR ! 17057: MOV R$COD,R$GTC ALSO SAVE CODE PTR ! 17058: MOV XR,R$CIM ELSE SET IMAGE POINTER ! 17059: MOV WA,SCNIL SET IMAGE LENGTH ! 17060: ZER SCNPT SET SCAN POINTER ! 17061: MOV =STGXC,STAGE SET STAGE FOR EXECUTE COMPILE ! 17062: MOV CMPSN,LSTSN IN CASE LISTR CALLED ! 17063: JSR CMPIL COMPILE STRING ! 17064: MOV =STGXT,STAGE RESET STAGE FOR EXECUTE TIME ! 17065: ZER R$CIM CLEAR IMAGE ! 17066: * ! 17067: * MERGE HERE IF NO CONVERT REQUIRED ! 17068: * ! 17069: GTCD1 EXI GIVE NORMAL GTCOD RETURN ! 17070: * ! 17071: * HERE IF UNCONVERTIBLE ! 17072: * ! 17073: GTCD2 EXI 1 GIVE ERROR RETURN ! 17074: ENP END PROCEDURE GTCOD ! 17075: EJC ! 17076: * ! 17077: * GTEXP -- CONVERT TO EXPRESSION ! 17078: * ! 17079: * (XR) INPUT VALUE TO BE CONVERTED ! 17080: * JSR GTEXP CALL TO CONVERT TO EXPRESSION ! 17081: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 17082: * (XR) POINTER TO RESULT EXBLK OR SEBLK ! 17083: * (XL,WA,WB,WC,RA) DESTROYED ! 17084: * ! 17085: * IF A SPITBOL ERROR OCCURS DURING COMPILATION OR PRE- ! 17086: * EVALUATION, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL ! 17087: * WITHOUT RETURNING TO THIS ROUTINE. ! 17088: * ! 17089: GTEXP PRC E,1 ENTRY POINT ! 17090: BLO (XR),=B$E$$,GTEX1 JUMP IF ALREADY AN EXPRESSION ! 17091: MOV XR,-(XS) STORE ARGUMENT FOR GTSTG ! 17092: JSR GTSTG CONVERT ARGUMENT TO STRING ! 17093: PPM GTEX2 JUMP IF UNCONVERTIBLE ! 17094: * ! 17095: * CHECK THE LAST CHARACTER OF THE STRING FOR COLON OR ! 17096: * SEMICOLON. THESE CHARACTERS CAN LEGITIMATELY END AN ! 17097: * EXPRESSION IN OPEN CODE, SO EXPAN WILL NOT DETECT THEM ! 17098: * AS ERRORS, BUT THEY ARE INVALID AS TERMINATORS FOR A ! 17099: * STRING THAT IS BEING CONVERTED TO EXPRESSION FORM. ! 17100: * ! 17101: MOV XR,XL COPY INPUT STRING POINTER (REG06) ! 17102: PLC XL,WA POINT ONE PAST THE STRING END (REG06) ! 17103: LCH XL,-(XL) FETCH THE LAST CHARACTER (REG06) ! 17104: BEQ XL,=CH$CL,GTEX2 ERROR IF IT IS A SEMICOLON (REG06) ! 17105: BEQ XL,=CH$SM,GTEX2 OR IF IT IS A COLON (REG06) ! 17106: * ! 17107: * HERE WE CONVERT A STRING BY COMPILATION ! 17108: * ! 17109: MOV XR,R$CIM SET INPUT IMAGE POINTER ! 17110: ZER SCNPT SET SCAN POINTER ! 17111: MOV WA,SCNIL SET INPUT IMAGE LENGTH ! 17112: ZER WB SET CODE FOR NORMAL SCAN ! 17113: MOV FLPTR,GTCEF SAVE FAIL PTR IN CASE OF ERROR ! 17114: MOV R$COD,R$GTC ALSO SAVE CODE PTR ! 17115: MOV =STGEV,STAGE ADJUST STAGE FOR COMPILE ! 17116: MOV =T$UOK,SCNTP INDICATE UNARY OPERATOR ACCEPTABLE ! 17117: JSR EXPAN BUILD TREE FOR EXPRESSION ! 17118: ZER SCNRS RESET RESCAN FLAG ! 17119: BNE SCNPT,SCNIL,GTEX2 ERROR IF NOT END OF IMAGE ! 17120: ZER WB SET OK VALUE FOR CDGEX CALL ! 17121: MOV XR,XL COPY TREE POINTER ! 17122: JSR CDGEX BUILD EXPRESSION BLOCK ! 17123: ZER R$CIM CLEAR POINTER ! 17124: MOV =STGXT,STAGE RESTORE STAGE FOR EXECUTE TIME ! 17125: * ! 17126: * MERGE HERE IF NO CONVERSION REQUIRED ! 17127: * ! 17128: GTEX1 EXI RETURN TO GTEXP CALLER ! 17129: * ! 17130: * HERE IF UNCONVERTIBLE ! 17131: * ! 17132: GTEX2 EXI 1 TAKE ERROR EXIT ! 17133: ENP END PROCEDURE GTEXP ! 17134: EJC ! 17135: * ! 17136: * GTINT -- GET INTEGER VALUE ! 17137: * ! 17138: * GTINT IS PASSED AN OBJECT AND RETURNS AN INTEGER AFTER ! 17139: * PERFORMING ANY NECESSARY CONVERSIONS. ! 17140: * ! 17141: * (XR) VALUE TO BE CONVERTED ! 17142: * JSR GTINT CALL TO CONVERT TO INTEGER ! 17143: * PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE ! 17144: * (XR) RESULTING INTEGER ! 17145: * (WC,RA) DESTROYED ! 17146: * (WA,WB) DESTROYED (ONLY ON CONVERSION ERR) ! 17147: * (XR) UNCHANGED (ON CONVERT ERROR) ! 17148: * ! 17149: GTINT PRC E,1 ENTRY POINT ! 17150: BEQ (XR),=B$ICL,GTIN2 JUMP IF ALREADY AN INTEGER ! 17151: MOV WA,GTINA ELSE SAVE WA ! 17152: MOV WB,GTINB SAVE WB ! 17153: JSR GTNUM CONVERT TO NUMERIC ! 17154: PPM GTIN3 JUMP IF UNCONVERTIBLE ! 17155: .IF .CNRA ! 17156: .ELSE ! 17157: BEQ WA,=B$ICL,GTIN1 JUMP IF INTEGER ! 17158: * ! 17159: * HERE WE CONVERT A REAL TO INTEGER ! 17160: * ! 17161: LDR RCVAL(XR) LOAD REAL VALUE ! 17162: RTI GTIN3 CONVERT TO INTEGER (ERR IF OVFLOW) ! 17163: JSR ICBLD IF OK BUILD ICBLK ! 17164: .FI ! 17165: * ! 17166: * HERE AFTER SUCCESSFUL CONVERSION TO INTEGER ! 17167: * ! 17168: GTIN1 MOV GTINA,WA RESTORE WA ! 17169: MOV GTINB,WB RESTORE WB ! 17170: * ! 17171: * COMMON EXIT POINT ! 17172: * ! 17173: GTIN2 EXI RETURN TO GTINT CALLER ! 17174: * ! 17175: * HERE ON CONVERSION ERROR ! 17176: * ! 17177: GTIN3 EXI 1 TAKE CONVERT ERROR EXIT ! 17178: ENP END PROCEDURE GTINT ! 17179: EJC ! 17180: * ! 17181: * GTNUM -- GET NUMERIC VALUE ! 17182: * ! 17183: * GTNUM IS GIVEN AN OBJECT AND RETURNS EITHER AN INTEGER ! 17184: * OR A REAL, PERFORMING ANY NECESSARY CONVERSIONS. ! 17185: * ! 17186: * (XR) OBJECT TO BE CONVERTED ! 17187: * JSR GTNUM CALL TO CONVERT TO NUMERIC ! 17188: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 17189: * (XR) POINTER TO RESULT (INT OR REAL) ! 17190: * (WA) FIRST WORD OF RESULT BLOCK ! 17191: * (WB,WC,RA) DESTROYED ! 17192: * (XR) UNCHANGED (ON CONVERT ERROR) ! 17193: * ! 17194: GTNUM PRC E,1 ENTRY POINT ! 17195: MOV (XR),WA LOAD FIRST WORD OF BLOCK ! 17196: BEQ WA,=B$ICL,GTN34 JUMP IF INTEGER (NO CONVERSION) ! 17197: .IF .CNRA ! 17198: .ELSE ! 17199: BEQ WA,=B$RCL,GTN34 JUMP IF REAL (NO CONVERSION) ! 17200: .FI ! 17201: * ! 17202: * AT THIS POINT THE ONLY POSSIBILITY IS TO CONVERT A STRING ! 17203: * TO AN INTEGER OR REAL AS APPROPRIATE. ! 17204: * ! 17205: MOV XR,-(XS) STACK ARGUMENT IN CASE CONVERT ERR ! 17206: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG ! 17207: JSR GTSTG CONVERT ARGUMENT TO STRING ! 17208: PPM GTN36 JUMP IF UNCONVERTIBLE ! 17209: * ! 17210: * INITIALIZE NUMERIC CONVERSION ! 17211: * ! 17212: LDI INTV0 INITIALIZE INTEGER RESULT TO ZERO ! 17213: BZE WA,GTN32 JUMP TO EXIT WITH ZERO IF NULL ! 17214: LCT WA,WA SET BCT COUNTER FOR FOLLOWING LOOPS ! 17215: ZER GTNNF TENTATIVELY INDICATE RESULT + ! 17216: .IF .CNRA ! 17217: .ELSE ! 17218: STI GTNEX INITIALISE EXPONENT TO ZERO ! 17219: ZER GTNSC ZERO SCALE IN CASE REAL ! 17220: ZER GTNDF RESET FLAG FOR DEC POINT FOUND ! 17221: ZER GTNRD RESET FLAG FOR DIGITS FOUND ! 17222: LDR REAV0 ZERO REAL ACCUM IN CASE REAL ! 17223: .FI ! 17224: PLC XR POINT TO ARGUMENT CHARACTERS ! 17225: * ! 17226: * MERGE BACK HERE AFTER IGNORING LEADING BLANK ! 17227: * ! 17228: GTN01 LCH WB,(XR)+ LOAD FIRST CHARACTER ! 17229: BLT WB,=CH$D0,GTN02 JUMP IF NOT DIGIT ! 17230: BLE WB,=CH$D9,GTN06 JUMP IF FIRST CHAR IS A DIGIT ! 17231: EJC ! 17232: * ! 17233: * GTNUM (CONTINUED) ! 17234: * ! 17235: * HERE IF FIRST DIGIT IS NON-DIGIT ! 17236: * ! 17237: GTN02 BNE WB,=CH$BL,GTN03 JUMP IF NON-BLANK ! 17238: GTNA2 BCT WA,GTN01 ELSE DECR COUNT AND LOOP BACK ! 17239: BRN GTN07 JUMP TO RETURN ZERO IF ALL BLANKS ! 17240: * ! 17241: * HERE FOR FIRST CHARACTER NON-BLANK, NON-DIGIT ! 17242: * ! 17243: GTN03 BEQ WB,=CH$PL,GTN04 JUMP IF PLUS SIGN ! 17244: .IF .CAHT ! 17245: BEQ WB,=CH$HT,GTNA2 HORIZONTAL TAB EQUIV TO BLANK ! 17246: .FI ! 17247: .IF .CAVT ! 17248: BEQ WB,=CH$VT,GTNA2 VERTICAL TAB EQUIV TO BLANK ! 17249: .FI ! 17250: .IF .CNRA ! 17251: BNE WB,=CH$MN,GTN36 ELSE FAIL ! 17252: .ELSE ! 17253: BNE WB,=CH$MN,GTN12 JUMP IF NOT MINUS (MAY BE REAL) ! 17254: .FI ! 17255: MNZ GTNNF IF MINUS SIGN, SET NEGATIVE FLAG ! 17256: * ! 17257: * MERGE HERE AFTER PROCESSING SIGN ! 17258: * ! 17259: GTN04 BCT WA,GTN05 JUMP IF CHARS LEFT ! 17260: BRN GTN36 ELSE ERROR ! 17261: * ! 17262: * LOOP TO FETCH CHARACTERS OF AN INTEGER ! 17263: * ! 17264: GTN05 LCH WB,(XR)+ LOAD NEXT CHARACTER ! 17265: BLT WB,=CH$D0,GTN08 JUMP IF NOT A DIGIT ! 17266: BGT WB,=CH$D9,GTN08 JUMP IF NOT A DIGIT ! 17267: * ! 17268: * MERGE HERE FOR FIRST DIGIT ! 17269: * ! 17270: GTN06 STI GTNSI SAVE CURRENT VALUE ! 17271: .IF .CNRA ! 17272: CVM GTN36 CURRENT*10-(NEW DIG) JUMP IF OVFLOW ! 17273: .ELSE ! 17274: CVM GTN35 CURRENT*10-(NEW DIG) JUMP IF OVFLOW ! 17275: MNZ GTNRD SET DIGIT READ FLAG ! 17276: .FI ! 17277: BCT WA,GTN05 ELSE LOOP BACK IF MORE CHARS ! 17278: * ! 17279: * HERE TO EXIT WITH CONVERTED INTEGER VALUE ! 17280: * ! 17281: GTN07 BNZ GTNNF,GTN32 JUMP IF NEGATIVE (ALL SET) ! 17282: NGI ELSE NEGATE ! 17283: INO GTN32 JUMP IF NO OVERFLOW ! 17284: BRN GTN36 ELSE SIGNAL ERROR ! 17285: EJC ! 17286: * ! 17287: * GTNUM (CONTINUED) ! 17288: * ! 17289: * HERE FOR A NON-DIGIT CHARACTER WHILE ATTEMPTING TO ! 17290: * CONVERT AN INTEGER, CHECK FOR TRAILING BLANKS OR REAL. ! 17291: * ! 17292: GTN08 BEQ WB,=CH$BL,GTNA9 JUMP IF A BLANK ! 17293: .IF .CAHT ! 17294: BEQ WB,=CH$HT,GTNA9 JUMP IF HORIZONTAL TAB ! 17295: .FI ! 17296: .IF .CAVT ! 17297: BEQ WB,=CH$VT,GTNA9 JUMP IF VERTICAL TAB ! 17298: .FI ! 17299: .IF .CNRA ! 17300: BRN GTN36 ERROR ! 17301: .ELSE ! 17302: ITR ELSE CONVERT INTEGER TO REAL ! 17303: NGR NEGATE TO GET POSITIVE VALUE ! 17304: BRN GTN12 JUMP TO TRY FOR REAL ! 17305: .FI ! 17306: * ! 17307: * HERE WE SCAN OUT BLANKS TO END OF STRING ! 17308: * ! 17309: GTN09 LCH WB,(XR)+ GET NEXT CHAR ! 17310: .IF .CAHT ! 17311: BEQ WB,=CH$HT,GTNA9 JUMP IF HORIZONTAL TAB ! 17312: .FI ! 17313: .IF .CAVT ! 17314: BEQ WB,=CH$VT,GTNA9 JUMP IF VERTICAL TAB ! 17315: .FI ! 17316: BNE WB,=CH$BL,GTN36 ERROR IF NON-BLANK ! 17317: GTNA9 BCT WA,GTN09 LOOP BACK IF MORE CHARS TO CHECK ! 17318: BRN GTN07 RETURN INTEGER IF ALL BLANKS ! 17319: .IF .CNRA ! 17320: .ELSE ! 17321: * ! 17322: * LOOP TO COLLECT MANTISSA OF REAL ! 17323: * ! 17324: GTN10 LCH WB,(XR)+ LOAD NEXT CHARACTER ! 17325: BLT WB,=CH$D0,GTN12 JUMP IF NON-NUMERIC ! 17326: BGT WB,=CH$D9,GTN12 JUMP IF NON-NUMERIC ! 17327: * ! 17328: * MERGE HERE TO COLLECT FIRST REAL DIGIT ! 17329: * ! 17330: GTN11 SUB =CH$D0,WB CONVERT DIGIT TO NUMBER ! 17331: MLR REAVT MULTIPLY REAL BY 10.0 ! 17332: ROV GTN36 CONVERT ERROR IF OVERFLOW ! 17333: STR GTNSR SAVE RESULT ! 17334: MTI WB GET NEW DIGIT AS INTEGER ! 17335: ITR CONVERT NEW DIGIT TO REAL ! 17336: ADR GTNSR ADD TO GET NEW TOTAL ! 17337: ADD GTNDF,GTNSC INCREMENT SCALE IF AFTER DEC POINT ! 17338: MNZ GTNRD SET DIGIT FOUND FLAG ! 17339: BCT WA,GTN10 LOOP BACK IF MORE CHARS ! 17340: BRN GTN22 ELSE JUMP TO SCALE ! 17341: EJC ! 17342: * ! 17343: * GTNUM (CONTINUED) ! 17344: * ! 17345: * HERE IF NON-DIGIT FOUND WHILE COLLECTING A REAL ! 17346: * ! 17347: GTN12 BNE WB,=CH$DT,GTN13 JUMP IF NOT DEC POINT ! 17348: BNZ GTNDF,GTN36 IF DEC POINT, ERROR IF ONE ALREADY ! 17349: MOV =NUM01,GTNDF ELSE SET FLAG FOR DEC POINT ! 17350: BCT WA,GTN10 LOOP BACK IF MORE CHARS ! 17351: BRN GTN22 ELSE JUMP TO SCALE ! 17352: * ! 17353: * HERE IF NOT DECIMAL POINT ! 17354: * ! 17355: GTN13 BEQ WB,=CH$LE,GTN15 JUMP IF E FOR EXPONENT ! 17356: BEQ WB,=CH$LD,GTN15 JUMP IF D FOR EXPONENT ! 17357: .IF .CULC ! 17358: BEQ WB,=CH$$E,GTN15 JUMP IF E FOR EXPONENT ! 17359: BEQ WB,=CH$$D,GTN15 JUMP IF D FOR EXPONENT ! 17360: .FI ! 17361: * ! 17362: * HERE CHECK FOR TRAILING BLANKS ! 17363: * ! 17364: GTN14 BEQ WB,=CH$BL,GTNB4 JUMP IF BLANK ! 17365: .IF .CAHT ! 17366: BEQ WB,=CH$HT,GTNB4 JUMP IF HORIZONTAL TAB ! 17367: .FI ! 17368: .IF .CAVT ! 17369: BEQ WB,=CH$VT,GTNB4 JUMP IF VERTICAL TAB ! 17370: .FI ! 17371: BRN GTN36 ERROR IF NON-BLANK ! 17372: * ! 17373: GTNB4 LCH WB,(XR)+ GET NEXT CHARACTER ! 17374: BCT WA,GTN14 LOOP BACK TO CHECK IF MORE ! 17375: BRN GTN22 ELSE JUMP TO SCALE ! 17376: * ! 17377: * HERE TO READ AND PROCESS AN EXPONENT ! 17378: * ! 17379: GTN15 ZER GTNES SET EXPONENT SIGN POSITIVE ! 17380: LDI INTV0 INITIALIZE EXPONENT TO ZERO ! 17381: MNZ GTNDF RESET NO DEC POINT INDICATION ! 17382: BCT WA,GTN16 JUMP SKIPPING PAST E OR D ! 17383: BRN GTN36 ERROR IF NULL EXPONENT ! 17384: * ! 17385: * CHECK FOR EXPONENT SIGN ! 17386: * ! 17387: GTN16 LCH WB,(XR)+ LOAD FIRST EXPONENT CHARACTER ! 17388: BEQ WB,=CH$PL,GTN17 JUMP IF PLUS SIGN ! 17389: BNE WB,=CH$MN,GTN19 ELSE JUMP IF NOT MINUS SIGN ! 17390: MNZ GTNES SET SIGN NEGATIVE IF MINUS SIGN ! 17391: * ! 17392: * MERGE HERE AFTER PROCESSING EXPONENT SIGN ! 17393: * ! 17394: GTN17 BCT WA,GTN18 JUMP IF CHARS LEFT ! 17395: BRN GTN36 ELSE ERROR ! 17396: * ! 17397: * LOOP TO CONVERT EXPONENT DIGITS ! 17398: * ! 17399: GTN18 LCH WB,(XR)+ LOAD NEXT CHARACTER ! 17400: EJC ! 17401: * ! 17402: * GTNUM (CONTINUED) ! 17403: * ! 17404: * MERGE HERE FOR FIRST EXPONENT DIGIT ! 17405: * ! 17406: GTN19 BLT WB,=CH$D0,GTN20 JUMP IF NOT DIGIT ! 17407: BGT WB,=CH$D9,GTN20 JUMP IF NOT DIGIT ! 17408: CVM GTN36 ELSE CURRENT*10, SUBTRACT NEW DIGIT ! 17409: BCT WA,GTN18 LOOP BACK IF MORE CHARS ! 17410: BRN GTN21 JUMP IF EXPONENT FIELD IS EXHAUSTED ! 17411: * ! 17412: * HERE TO CHECK FOR TRAILING BLANKS AFTER EXPONENT ! 17413: * ! 17414: GTN20 BEQ WB,=CH$BL,GTNC0 JUMP IF BLANK ! 17415: .IF .CAHT ! 17416: BEQ WB,=CH$HT,GTNC0 JUMP IF HORIZONTAL TAB ! 17417: .FI ! 17418: .IF .CAVT ! 17419: BEQ WC,=CH$VT,GTNC0 JUMP IF VERTICAL TAB ! 17420: .FI ! 17421: BRN GTN36 ERROR IF NON-BLANK ! 17422: * ! 17423: GTNC0 LCH WB,(XR)+ GET NEXT CHARACTER ! 17424: BCT WA,GTN20 LOOP BACK TILL ALL BLANKS SCANNED ! 17425: * ! 17426: * MERGE HERE AFTER COLLECTING EXPONENT ! 17427: * ! 17428: GTN21 STI GTNEX SAVE COLLECTED EXPONENT ! 17429: BNZ GTNES,GTN22 JUMP IF IT WAS NEGATIVE ! 17430: NGI ELSE COMPLEMENT ! 17431: IOV GTN36 ERROR IF OVERFLOW ! 17432: STI GTNEX AND STORE POSITIVE EXPONENT ! 17433: * ! 17434: * MERGE HERE WITH EXPONENT (0 IF NONE GIVEN) ! 17435: * ! 17436: GTN22 BZE GTNRD,GTN36 ERROR IF NOT DIGITS COLLECTED ! 17437: BZE GTNDF,GTN36 ERROR IF NO EXPONENT OR DEC POINT ! 17438: MTI GTNSC ELSE LOAD SCALE AS INTEGER ! 17439: SBI GTNEX SUBTRACT EXPONENT ! 17440: IOV GTN36 ERROR IF OVERFLOW ! 17441: ILT GTN26 JUMP IF WE MUST SCALE UP ! 17442: * ! 17443: * HERE WE HAVE A NEGATIVE EXPONENT, SO SCALE DOWN ! 17444: * ! 17445: MFI WA,GTN36 LOAD SCALE FACTOR, ERR IF OVFLOW ! 17446: * ! 17447: * LOOP TO SCALE DOWN IN STEPS OF 10**10 ! 17448: * ! 17449: GTN23 BLE WA,=NUM10,GTN24 JUMP IF 10 OR LESS TO GO ! 17450: DVR REATT ELSE DIVIDE BY 10**10 ! 17451: SUB =NUM10,WA DECREMENT SCALE ! 17452: BRN GTN23 AND LOOP BACK ! 17453: EJC ! 17454: * ! 17455: * GTNUM (CONTINUED) ! 17456: * ! 17457: * HERE SCALE REST OF WAY FROM POWERS OF TEN TABLE ! 17458: * ! 17459: GTN24 BZE WA,GTN30 JUMP IF SCALED ! 17460: LCT WB,=CFP$R ELSE GET INDEXING FACTOR ! 17461: MOV =REAV1,XR POINT TO POWERS OF TEN TABLE ! 17462: WTB WA CONVERT REMAINING SCALE TO BYTE OFS ! 17463: * ! 17464: * LOOP TO POINT TO POWERS OF TEN TABLE ENTRY ! 17465: * ! 17466: GTN25 ADD WA,XR BUMP POINTER ! 17467: BCT WB,GTN25 ONCE FOR EACH VALUE WORD ! 17468: DVR (XR) SCALE DOWN AS REQUIRED ! 17469: BRN GTN30 AND JUMP ! 17470: * ! 17471: * COME HERE TO SCALE RESULT UP (POSITIVE EXPONENT) ! 17472: * ! 17473: GTN26 NGI GET ABSOLUTE VALUE OF EXPONENT ! 17474: IOV GTN36 ERROR IF OVERFLOW ! 17475: MFI WA,GTN36 ACQUIRE SCALE, ERROR IF OVFLOW ! 17476: * ! 17477: * LOOP TO SCALE UP IN STEPS OF 10**10 ! 17478: * ! 17479: GTN27 BLE WA,=NUM10,GTN28 JUMP IF 10 OR LESS TO GO ! 17480: MLR REATT ELSE MULTIPLY BY 10**10 ! 17481: ROV GTN36 ERROR IF OVERFLOW ! 17482: SUB =NUM10,WA ELSE DECREMENT SCALE ! 17483: BRN GTN27 AND LOOP BACK ! 17484: * ! 17485: * HERE TO SCALE UP REST OF WAY WITH TABLE ! 17486: * ! 17487: GTN28 BZE WA,GTN30 JUMP IF SCALED ! 17488: LCT WB,=CFP$R ELSE GET INDEXING FACTOR ! 17489: MOV =REAV1,XR POINT TO POWERS OF TEN TABLE ! 17490: WTB WA CONVERT REMAINING SCALE TO BYTE OFS ! 17491: * ! 17492: * LOOP TO POINT TO PROPER ENTRY IN POWERS OF TEN TABLE ! 17493: * ! 17494: GTN29 ADD WA,XR BUMP POINTER ! 17495: BCT WB,GTN29 ONCE FOR EACH WORD IN VALUE ! 17496: MLR (XR) SCALE UP ! 17497: ROV GTN36 ERROR IF OVERFLOW ! 17498: EJC ! 17499: * ! 17500: * GTNUM (CONTINUED) ! 17501: * ! 17502: * HERE WITH REAL VALUE SCALED AND READY EXCEPT FOR SIGN ! 17503: * ! 17504: GTN30 BZE GTNNF,GTN31 JUMP IF POSITIVE ! 17505: NGR ELSE NEGATE ! 17506: * ! 17507: * HERE WITH PROPERLY SIGNED REAL VALUE IN (RA) ! 17508: * ! 17509: GTN31 JSR RCBLD BUILD REAL BLOCK ! 17510: BRN GTN33 MERGE TO EXIT ! 17511: .FI ! 17512: * ! 17513: * HERE WITH PROPERLY SIGNED INTEGER VALUE IN (IA) ! 17514: * ! 17515: GTN32 JSR ICBLD BUILD ICBLK ! 17516: * ! 17517: * REAL MERGES HERE ! 17518: * ! 17519: GTN33 MOV (XR),WA LOAD FIRST WORD OF RESULT BLOCK ! 17520: ICA XS POP ARGUMENT OFF STACK ! 17521: * ! 17522: * COMMON EXIT POINT ! 17523: * ! 17524: GTN34 EXI RETURN TO GTNUM CALLER ! 17525: .IF .CNRA ! 17526: .ELSE ! 17527: * ! 17528: * COME HERE IF OVERFLOW OCCURS DURING COLLECTION OF INTEGER ! 17529: * ! 17530: GTN35 LDI GTNSI RELOAD INTEGER SO FAR ! 17531: ITR CONVERT TO REAL ! 17532: NGR MAKE VALUE POSITIVE ! 17533: BRN GTN11 MERGE WITH REAL CIRCUIT ! 17534: .FI ! 17535: * ! 17536: * HERE FOR UNCONVERTIBLE TO STRING OR CONVERSION ERROR ! 17537: * ! 17538: GTN36 MOV (XS)+,XR RELOAD ORIGINAL ARGUMENT ! 17539: EXI 1 TAKE CONVERT-ERROR EXIT ! 17540: ENP END PROCEDURE GTNUM ! 17541: EJC ! 17542: * ! 17543: * GTNVR -- CONVERT TO NATURAL VARIABLE ! 17544: * ! 17545: * GTNVR LOCATES A VARIABLE BLOCK (VRBLK) GIVEN EITHER AN ! 17546: * APPROPRIATE NAME (NMBLK) OR A NON-NULL STRING (SCBLK). ! 17547: * ! 17548: * (XR) ARGUMENT ! 17549: * JSR GTNVR CALL TO CONVERT TO NATURAL VARIABLE ! 17550: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 17551: * (XR) POINTER TO VRBLK ! 17552: * (WA,WB) DESTROYED (CONVERSION ERROR ONLY) ! 17553: * (WC) DESTROYED ! 17554: * ! 17555: GTNVR PRC E,1 ENTRY POINT ! 17556: BNE (XR),=B$NML,GNV02 JUMP IF NOT NAME ! 17557: MOV NMBAS(XR),XR ELSE LOAD NAME BASE IF NAME ! 17558: BLO XR,STATE,GNV07 SKIP IF VRBLK (IN STATIC REGION) ! 17559: * ! 17560: * COMMON ERROR EXIT ! 17561: * ! 17562: GNV01 EXI 1 TAKE CONVERT-ERROR EXIT ! 17563: * ! 17564: * HERE IF NOT NAME ! 17565: * ! 17566: GNV02 MOV WA,GNVSA SAVE WA ! 17567: MOV WB,GNVSB SAVE WB ! 17568: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG ! 17569: JSR GTSTG CONVERT ARGUMENT TO STRING ! 17570: PPM GNV01 JUMP IF CONVERSION ERROR ! 17571: BZE WA,GNV01 NULL STRING IS AN ERROR ! 17572: .IF .CULC ! 17573: JSR FLSTG FOLD LOWER CASE TO UPPER CASE ! 17574: .FI ! 17575: MOV XL,-(XS) SAVE XL ! 17576: MOV XR,-(XS) STACK STRING PTR FOR LATER ! 17577: MOV XR,WB COPY STRING POINTER ! 17578: ADD *SCHAR,WB POINT TO CHARACTERS OF STRING ! 17579: MOV WB,GNVST SAVE POINTER TO CHARACTERS ! 17580: MOV WA,WB COPY LENGTH ! 17581: CTW WB,0 GET NUMBER OF WORDS IN NAME ! 17582: MOV WB,GNVNW SAVE FOR LATER ! 17583: JSR HASHS COMPUTE HASH INDEX FOR STRING ! 17584: RMI HSHNB COMPUTE HASH OFFSET BY TAKING MOD ! 17585: MFI WC GET AS OFFSET ! 17586: WTB WC CONVERT OFFSET TO BYTES ! 17587: ADD HSHTB,WC POINT TO PROPER HASH CHAIN ! 17588: SUB *VRNXT,WC SUBTRACT OFFSET TO MERGE INTO LOOP ! 17589: EJC ! 17590: * ! 17591: * GTNVR (CONTINUED) ! 17592: * ! 17593: * LOOP TO SEARCH HASH CHAIN ! 17594: * ! 17595: GNV03 MOV WC,XL COPY HASH CHAIN POINTER ! 17596: MOV VRNXT(XL),XL POINT TO NEXT VRBLK ON CHAIN ! 17597: BZE XL,GNV08 JUMP IF END OF CHAIN ! 17598: MOV XL,WC SAVE POINTER TO THIS VRBLK ! 17599: BNZ VRLEN(XL),GNV04 JUMP IF NOT SYSTEM VARIABLE ! 17600: MOV VRSVP(XL),XL ELSE POINT TO SVBLK ! 17601: SUB *VRSOF,XL ADJUST OFFSET FOR MERGE ! 17602: * ! 17603: * MERGE HERE WITH STRING PTR (LIKE VRBLK) IN XL ! 17604: * ! 17605: GNV04 BNE WA,VRLEN(XL),GNV03 BACK FOR NEXT VRBLK IF LENGTHS NE ! 17606: ADD *VRCHS,XL ELSE POINT TO CHARS OF CHAIN ENTRY ! 17607: LCT WB,GNVNW GET WORD COUNTER TO CONTROL LOOP ! 17608: MOV GNVST,XR POINT TO CHARS OF NEW NAME ! 17609: * ! 17610: * LOOP TO COMPARE CHARACTERS OF THE TWO NAMES ! 17611: * ! 17612: GNV05 CNE (XR),(XL),GNV03 JUMP IF NO MATCH FOR NEXT VRBLK ! 17613: ICA XR BUMP NEW NAME POINTER ! 17614: ICA XL BUMP VRBLK IN CHAIN NAME POINTER ! 17615: BCT WB,GNV05 ELSE LOOP TILL ALL COMPARED ! 17616: MOV WC,XR WE HAVE FOUND A MATCH, GET VRBLK ! 17617: * ! 17618: * EXIT POINT AFTER FINDING VRBLK OR BUILDING NEW ONE ! 17619: * ! 17620: GNV06 MOV GNVSA,WA RESTORE WA ! 17621: MOV GNVSB,WB RESTORE WB ! 17622: ICA XS POP STRING POINTER ! 17623: MOV (XS)+,XL RESTORE XL ! 17624: * ! 17625: * COMMON EXIT POINT ! 17626: * ! 17627: GNV07 EXI RETURN TO GTNVR CALLER ! 17628: * ! 17629: * NOT FOUND, PREPARE TO SEARCH SYSTEM VARIABLE TABLE ! 17630: * ! 17631: GNV08 ZER XR CLEAR GARBAGE XR POINTER ! 17632: MOV WC,GNVHE SAVE PTR TO END OF HASH CHAIN ! 17633: BGT WA,=NUM09,GNV14 CANNOT BE SYSTEM VAR IF LENGTH GT 9 ! 17634: MOV WA,XL ELSE COPY LENGTH ! 17635: WTB XL CONVERT TO BYTE OFFSET ! 17636: MOV VSRCH(XL),XL POINT TO FIRST SVBLK OF THIS LENGTH ! 17637: EJC ! 17638: * ! 17639: * GTNVR (CONTINUED) ! 17640: * ! 17641: * LOOP TO SEARCH ENTRIES IN STANDARD VARIABLE TABLE ! 17642: * ! 17643: GNV09 MOV XL,GNVSP SAVE TABLE POINTER ! 17644: MOV (XL)+,WC LOAD SVBIT BIT STRING ! 17645: MOV (XL)+,WB LOAD LENGTH FROM TABLE ENTRY ! 17646: BNE WA,WB,GNV14 JUMP IF END OF RIGHT LENGTH ENTIRES ! 17647: LCT WB,GNVNW GET WORD COUNTER TO CONTROL LOOP ! 17648: MOV GNVST,XR POINT TO CHARS OF NEW NAME ! 17649: * ! 17650: * LOOP TO CHECK FOR MATCHING NAMES ! 17651: * ! 17652: GNV10 CNE (XR),(XL),GNV11 JUMP IF NAME MISMATCH ! 17653: ICA XR ELSE BUMP NEW NAME POINTER ! 17654: ICA XL BUMP SVBLK POINTER ! 17655: BCT WB,GNV10 ELSE LOOP UNTIL ALL CHECKED ! 17656: * ! 17657: * HERE WE HAVE A MATCH IN THE STANDARD VARIABLE TABLE ! 17658: * ! 17659: ZER WC SET VRLEN VALUE ZERO ! 17660: MOV *VRSI$,WA SET STANDARD SIZE ! 17661: BRN GNV15 JUMP TO BUILD VRBLK ! 17662: * ! 17663: * HERE IF NO MATCH WITH TABLE ENTRY IN SVBLKS TABLE ! 17664: * ! 17665: GNV11 ICA XL BUMP PAST WORD OF CHARS ! 17666: BCT WB,GNV11 LOOP BACK IF MORE TO GO ! 17667: RSH WC,SVNBT REMOVE UNINTERESTING BITS ! 17668: * ! 17669: * LOOP TO BUMP TABLE PTR FOR EACH FLAGGED WORD ! 17670: * ! 17671: GNV12 MOV BITS1,WB LOAD BIT TO TEST ! 17672: ANB WC,WB TEST FOR WORD PRESENT ! 17673: ZRB WB,GNV13 JUMP IF NOT PRESENT ! 17674: ICA XL ELSE BUMP TABLE POINTER ! 17675: * ! 17676: * HERE AFTER DEALING WITH ONE WORD (ONE BIT) ! 17677: * ! 17678: GNV13 RSH WC,1 REMOVE BIT ALREADY PROCESSED ! 17679: NZB WC,GNV12 LOOP BACK IF MORE BITS TO TEST ! 17680: BRN GNV09 ELSE LOOP BACK FOR NEXT SVBLK ! 17681: * ! 17682: * HERE IF NOT SYSTEM VARIABLE ! 17683: * ! 17684: GNV14 MOV WA,WC COPY VRLEN VALUE ! 17685: MOV =VRCHS,WA LOAD STANDARD SIZE -CHARS ! 17686: ADD GNVNW,WA ADJUST FOR CHARS OF NAME ! 17687: WTB WA CONVERT LENGTH TO BYTES ! 17688: EJC ! 17689: * ! 17690: * GTNVR (CONTINUED) ! 17691: * ! 17692: * MERGE HERE TO BUILD VRBLK ! 17693: * ! 17694: GNV15 JSR ALOST ALLOCATE SPACE FOR VRBLK (STATIC) ! 17695: MOV XR,WB SAVE VRBLK POINTER ! 17696: MOV =STNVR,XL POINT TO MODEL VARIABLE BLOCK ! 17697: MOV *VRLEN,WA SET LENGTH OF STANDARD FIELDS ! 17698: MVW SET INITIAL FIELDS OF NEW BLOCK ! 17699: MOV GNVHE,XL LOAD POINTER TO END OF HASH CHAIN ! 17700: MOV WB,VRNXT(XL) ADD NEW BLOCK TO END OF CHAIN ! 17701: MOV WC,(XR)+ SET VRLEN FIELD, BUMP PTR ! 17702: MOV GNVNW,WA GET LENGTH IN WORDS ! 17703: WTB WA CONVERT TO LENGTH IN BYTES ! 17704: BZE WC,GNV16 JUMP IF SYSTEM VARIABLE ! 17705: * ! 17706: * HERE FOR NON-SYSTEM VARIABLE -- SET CHARS OF NAME ! 17707: * ! 17708: MOV (XS),XL POINT BACK TO STRING NAME ! 17709: ADD *SCHAR,XL POINT TO CHARS OF NAME ! 17710: MVW MOVE CHARACTERS INTO PLACE ! 17711: MOV WB,XR RESTORE VRBLK POINTER ! 17712: BRN GNV06 JUMP BACK TO EXIT ! 17713: * ! 17714: * HERE FOR SYSTEM VARIABLE CASE TO FILL IN FIELDS WHERE ! 17715: * NECESSARY FROM THE FIELDS PRESENT IN THE SVBLK. ! 17716: * ! 17717: GNV16 MOV GNVSP,XL LOAD POINTER TO SVBLK ! 17718: MOV XL,(XR) SET SVBLK PTR IN VRBLK ! 17719: MOV WB,XR RESTORE VRBLK POINTER ! 17720: MOV SVBIT(XL),WB LOAD BIT INDICATORS ! 17721: ADD *SVCHS,XL POINT TO CHARACTERS OF NAME ! 17722: ADD WA,XL POINT PAST CHARACTERS ! 17723: * ! 17724: * SKIP PAST KEYWORD NUMBER (SVKNM) IF PRESENT ! 17725: * ! 17726: MOV BTKNM,WC LOAD TEST BIT ! 17727: ANB WB,WC AND TO TEST ! 17728: ZRB WC,GNV17 JUMP IF NO KEYWORD NUMBER ! 17729: ICA XL ELSE BUMP POINTER ! 17730: EJC ! 17731: * ! 17732: * GTNVR (CONTINUED) ! 17733: * ! 17734: * HERE TEST FOR FUNCTION (SVFNC AND SVNAR) ! 17735: * ! 17736: GNV17 MOV BTFNC,WC GET TEST BIT ! 17737: ANB WB,WC AND TO TEST ! 17738: ZRB WC,GNV18 SKIP IF NO SYSTEM FUNCTION ! 17739: MOV XL,VRFNC(XR) ELSE POINT VRFNC TO SVFNC FIELD ! 17740: ADD *NUM02,XL AND BUMP PAST SVFNC, SVNAR FIELDS ! 17741: * ! 17742: * NOW TEST FOR LABEL (SVLBL) ! 17743: * ! 17744: GNV18 MOV BTLBL,WC GET TEST BIT ! 17745: ANB WB,WC AND TO TEST ! 17746: ZRB WC,GNV19 JUMP IF BIT IS OFF (NO SYSTEM LABL) ! 17747: MOV XL,VRLBL(XR) ELSE POINT VRLBL TO SVLBL FIELD ! 17748: ICA XL BUMP PAST SVLBL FIELD ! 17749: * ! 17750: * NOW TEST FOR VALUE (SVVAL) ! 17751: * ! 17752: GNV19 MOV BTVAL,WC LOAD TEST BIT ! 17753: ANB WB,WC AND TO TEST ! 17754: ZRB WC,GNV06 ALL DONE IF NO VALUE ! 17755: MOV (XL),VRVAL(XR) ELSE SET INITIAL VALUE ! 17756: MOV =B$VRE,VRSTO(XR) SET ERROR STORE ACCESS ! 17757: BRN GNV06 MERGE BACK TO EXIT TO CALLER ! 17758: ENP END PROCEDURE GTNVR ! 17759: EJC ! 17760: * ! 17761: * GTPAT -- GET PATTERN ! 17762: * ! 17763: * GTPAT IS PASSED AN OBJECT IN (XR) AND RETURNS A ! 17764: * PATTERN AFTER PERFORMING ANY NECESSARY CONVERSIONS ! 17765: * ! 17766: * (XR) INPUT ARGUMENT ! 17767: * JSR GTPAT CALL TO CONVERT TO PATTERN ! 17768: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 17769: * (XR) RESULTING PATTERN ! 17770: * (WA) DESTROYED ! 17771: * (WB) DESTROYED (ONLY ON CONVERT ERROR) ! 17772: * (XR) UNCHANGED (ONLY ON CONVERT ERROR) ! 17773: * ! 17774: GTPAT PRC E,1 ENTRY POINT ! 17775: BHI (XR),=P$AAA,GTPT5 JUMP IF PATTERN ALREADY ! 17776: * ! 17777: * HERE IF NOT PATTERN, TRY FOR STRING ! 17778: * ! 17779: MOV WB,GTPSB SAVE WB ! 17780: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG ! 17781: JSR GTSTG CONVERT ARGUMENT TO STRING ! 17782: PPM GTPT2 JUMP IF IMPOSSIBLE ! 17783: * ! 17784: * HERE WE HAVE A STRING ! 17785: * ! 17786: BNZ WA,GTPT1 JUMP IF NON-NULL ! 17787: * ! 17788: * HERE FOR NULL STRING. GENERATE POINTER TO NULL PATTERN. ! 17789: * ! 17790: MOV =NDNTH,XR POINT TO NOTHEN NODE ! 17791: BRN GTPT4 JUMP TO EXIT ! 17792: EJC ! 17793: * ! 17794: * GTPAT (CONTINUED) ! 17795: * ! 17796: * HERE FOR NON-NULL STRING ! 17797: * ! 17798: GTPT1 MOV =P$STR,WB LOAD PCODE FOR MULTI-CHAR STRING ! 17799: BNE WA,=NUM01,GTPT3 JUMP IF MULTI-CHAR STRING ! 17800: * ! 17801: * HERE FOR ONE CHARACTER STRING, SHARE ONE CHARACTER ANY ! 17802: * ! 17803: PLC XR POINT TO CHARACTER ! 17804: LCH WA,(XR) LOAD CHARACTER ! 17805: MOV WA,XR SET AS PARM1 ! 17806: MOV =P$ANS,WB POINT TO PCODE FOR 1-CHAR ANY ! 17807: BRN GTPT3 JUMP TO BUILD NODE ! 17808: * ! 17809: * HERE IF ARGUMENT IS NOT CONVERTIBLE TO STRING ! 17810: * ! 17811: GTPT2 MOV =P$EXA,WB SET PCODE FOR EXPRESSION IN CASE ! 17812: BLO (XR),=B$E$$,GTPT3 JUMP TO BUILD NODE IF EXPRESSION ! 17813: * ! 17814: * HERE WE HAVE AN ERROR (CONVERSION IMPOSSIBLE) ! 17815: * ! 17816: EXI 1 TAKE CONVERT ERROR EXIT ! 17817: * ! 17818: * MERGE HERE TO BUILD NODE FOR STRING OR EXPRESSION ! 17819: * ! 17820: GTPT3 JSR PBILD CALL ROUTINE TO BUILD PATTERN NODE ! 17821: * ! 17822: * COMMON EXIT AFTER SUCCESSFUL CONVERSION ! 17823: * ! 17824: GTPT4 MOV GTPSB,WB RESTORE WB ! 17825: * ! 17826: * MERGE HERE TO EXIT OF NO CONVERSION REQUIRED ! 17827: * ! 17828: GTPT5 EXI RETURN TO GTPAT CALLER ! 17829: ENP END PROCEDURE GTPAT ! 17830: .IF .CNRA ! 17831: .ELSE ! 17832: EJC ! 17833: * ! 17834: * GTREA -- GET REAL VALUE ! 17835: * ! 17836: * GTREA IS PASSED AN OBJECT AND RETURNS A REAL VALUE ! 17837: * PERFORMING ANY NECESSARY CONVERSIONS. ! 17838: * ! 17839: * (XR) OBJECT TO BE CONVERTED ! 17840: * JSR GTREA CALL TO CONVERT OBJECT TO REAL ! 17841: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 17842: * (XR) POINTER TO RESULTING REAL ! 17843: * (WA,WB,WC,RA) DESTROYED ! 17844: * (XR) UNCHANGED (CONVERT ERROR ONLY) ! 17845: * ! 17846: GTREA PRC E,1 ENTRY POINT ! 17847: MOV (XR),WA GET FIRST WORD OF BLOCK ! 17848: BEQ WA,=B$RCL,GTRE2 JUMP IF REAL ! 17849: JSR GTNUM ELSE CONVERT ARGUMENT TO NUMERIC ! 17850: PPM GTRE3 JUMP IF UNCONVERTIBLE ! 17851: BEQ WA,=B$RCL,GTRE2 JUMP IF REAL WAS RETURNED ! 17852: * ! 17853: * HERE FOR CASE OF AN INTEGER TO CONVERT TO REAL ! 17854: * ! 17855: GTRE1 LDI ICVAL(XR) LOAD INTEGER ! 17856: ITR CONVERT TO REAL ! 17857: JSR RCBLD BUILD RCBLK ! 17858: * ! 17859: * EXIT WITH REAL ! 17860: * ! 17861: GTRE2 EXI RETURN TO GTREA CALLER ! 17862: * ! 17863: * HERE ON CONVERSION ERROR ! 17864: * ! 17865: GTRE3 EXI 1 TAKE CONVERT ERROR EXIT ! 17866: ENP END PROCEDURE GTREA ! 17867: .FI ! 17868: EJC ! 17869: * ! 17870: * GTSMI -- GET SMALL INTEGER ! 17871: * ! 17872: * GTSMI IS PASSED A SNOBOL OBJECT AND RETURNS AN ADDRESS ! 17873: * INTEGER IN THE RANGE (0 LE N LE DNAMB). SUCH A VALUE CAN ! 17874: * ONLY BE DERIVED FROM AN INTEGER IN THE APPROPRIATE RANGE. ! 17875: * SMALL INTEGERS NEVER APPEAR AS SNOBOL VALUES. HOWEVER, ! 17876: * THEY ARE USED INTERNALLY FOR A VARIETY OF PURPOSES. ! 17877: * ! 17878: * -(XS) ARGUMENT TO CONVERT (ON STACK) ! 17879: * JSR GTSMI CALL TO CONVERT TO SMALL INTEGER ! 17880: * PPM LOC TRANSFER LOC FOR NOT INTEGER ! 17881: * PPM LOC TRANSFER LOC FOR LT 0, GT DNAMB ! 17882: * (XR,WC) RESULTING SMALL INT (TWO COPIES) ! 17883: * (XS) POPPED ! 17884: * (RA) DESTROYED ! 17885: * (WA,WB) DESTROYED (ON CONVERT ERROR ONLY) ! 17886: * (XR) INPUT ARG (CONVERT ERROR ONLY) ! 17887: * ! 17888: GTSMI PRC N,2 ENTRY POINT ! 17889: MOV (XS)+,XR LOAD ARGUMENT ! 17890: BEQ (XR),=B$ICL,GTSM1 SKIP IF ALREADY AN INTEGER ! 17891: * ! 17892: * HERE IF NOT AN INTEGER ! 17893: * ! 17894: JSR GTINT CONVERT ARGUMENT TO INTEGER ! 17895: PPM GTSM2 JUMP IF CONVERT IS IMPOSSIBLE ! 17896: * ! 17897: * MERGE HERE WITH INTEGER ! 17898: * ! 17899: GTSM1 LDI ICVAL(XR) LOAD INTEGER VALUE ! 17900: MFI WC,GTSM3 MOVE AS ONE WORD, JUMP IF OVFLOW ! 17901: BGT WC,MXLEN,GTSM3 OR IF TOO SMALL ! 17902: MOV WC,XR COPY RESULT TO XR ! 17903: EXI RETURN TO GTSMI CALLER ! 17904: * ! 17905: * HERE IF UNCONVERTIBLE TO INTEGER ! 17906: * ! 17907: GTSM2 EXI 1 TAKE NON-INTEGER ERROR EXIT ! 17908: * ! 17909: * HERE IF OUT OF RANGE ! 17910: * ! 17911: GTSM3 EXI 2 TAKE OUT-OF-RANGE ERROR EXIT ! 17912: ENP END PROCEDURE GTSMI ! 17913: EJC ! 17914: * ! 17915: * GTSTG -- GET STRING ! 17916: * ! 17917: * GTSTG IS PASSED AN OBJECT AND RETURNS A STRING WITH ! 17918: * ANY NECESSARY CONVERSIONS PERFORMED. ! 17919: * ! 17920: * -(XS) INPUT ARGUMENT (ON STACK) ! 17921: * JSR GTSTG CALL TO CONVERT TO STRING ! 17922: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 17923: * (XR) POINTER TO RESULTING STRING ! 17924: * (WA) LENGTH OF STRING IN CHARACTERS ! 17925: * (XS) POPPED ! 17926: * (RA) DESTROYED ! 17927: * (XR) INPUT ARG (CONVERT ERROR ONLY) ! 17928: * ! 17929: GTSTG PRC N,1 ENTRY POINT ! 17930: MOV (XS)+,XR LOAD ARGUMENT, POP STACK ! 17931: BEQ (XR),=B$SCL,GTS30 JUMP IF ALREADY A STRING ! 17932: * ! 17933: * HERE IF NOT A STRING ALREADY ! 17934: * ! 17935: GTS01 MOV XR,-(XS) RESTACK ARGUMENT IN CASE ERROR ! 17936: MOV XL,-(XS) SAVE XL ! 17937: MOV WB,GTSVB SAVE WB ! 17938: MOV WC,GTSVC SAVE WC ! 17939: MOV (XR),WA LOAD FIRST WORD OF BLOCK ! 17940: BEQ WA,=B$ICL,GTS05 JUMP TO CONVERT INTEGER ! 17941: .IF .CNRA ! 17942: .ELSE ! 17943: BEQ WA,=B$RCL,GTS10 JUMP TO CONVERT REAL ! 17944: .FI ! 17945: BEQ WA,=B$NML,GTS03 JUMP TO CONVERT NAME ! 17946: .IF .CNBF ! 17947: .ELSE ! 17948: BEQ WA,=B$BCT,GTS32 JUMP TO CONVERT BUFFER ! 17949: .FI ! 17950: * ! 17951: * HERE ON CONVERSION ERROR ! 17952: * ! 17953: GTS02 MOV (XS)+,XL RESTORE XL ! 17954: MOV (XS)+,XR RELOAD INPUT ARGUMENT ! 17955: EXI 1 TAKE CONVERT ERROR EXIT ! 17956: EJC ! 17957: * ! 17958: * GTSTG (CONTINUED) ! 17959: * ! 17960: * HERE TO CONVERT A NAME (ONLY POSSIBLE IF NATURAL VAR) ! 17961: * ! 17962: GTS03 MOV NMBAS(XR),XL LOAD NAME BASE ! 17963: BHI XL,STATE,GTS02 ERROR IF NOT NATURAL VAR (STATIC) ! 17964: ADD *VRSOF,XL ELSE POINT TO POSSIBLE STRING NAME ! 17965: MOV SCLEN(XL),WA LOAD LENGTH ! 17966: BNZ WA,GTS04 JUMP IF NOT SYSTEM VARIABLE ! 17967: MOV VRSVO(XL),XL ELSE POINT TO SVBLK ! 17968: MOV SVLEN(XL),WA AND LOAD NAME LENGTH ! 17969: * ! 17970: * MERGE HERE WITH STRING IN XR, LENGTH IN WA ! 17971: * ! 17972: GTS04 ZER WB SET OFFSET TO ZERO ! 17973: JSR SBSTR USE SBSTR TO COPY STRING ! 17974: BRN GTS29 JUMP TO EXIT ! 17975: * ! 17976: * COME HERE TO CONVERT AN INTEGER ! 17977: * ! 17978: GTS05 LDI ICVAL(XR) LOAD INTEGER VALUE ! 17979: .IF .CNCI ! 17980: JSR SYSCI CONVERT INTEGER ! 17981: MOV SCLEN(XL),WA GET LENGTH ! 17982: ZER WB ZERO OFFSET FOR SBSTR ! 17983: JSR SBSTR COPY IN RESULT FROM SYSCI ! 17984: BRN GTS29 EXIT ! 17985: .ELSE ! 17986: MOV =NUM01,GTSSF SET SIGN FLAG NEGATIVE ! 17987: ILT GTS06 SKIP IF INTEGER IS NEGATIVE ! 17988: NGI ELSE NEGATE INTEGER ! 17989: ZER GTSSF AND RESET NEGATIVE FLAG ! 17990: EJC ! 17991: * ! 17992: * GTSTG (CONTINUED) ! 17993: * ! 17994: * HERE WITH SIGN FLAG SET AND SIGN FORCED NEGATIVE AS ! 17995: * REQUIRED BY THE CVD INSTRUCTION. ! 17996: * ! 17997: GTS06 MOV GTSWK,XR POINT TO RESULT WORK AREA ! 17998: MOV =NSTMX,WB INITIALIZE COUNTER TO MAX LENGTH ! 17999: PSC XR,WB PREPARE TO STORE (RIGHT-LEFT) ! 18000: * ! 18001: * LOOP TO CONVERT DIGITS INTO WORK AREA ! 18002: * ! 18003: GTS07 CVD CONVERT ONE DIGIT INTO WA ! 18004: SCH WA,-(XR) STORE IN WORK AREA ! 18005: DCV WB DECREMENT COUNTER ! 18006: INE GTS07 LOOP IF MORE DIGITS TO GO ! 18007: CSC XR COMPLETE STORE CHARACTERS ! 18008: .FI ! 18009: * ! 18010: * MERGE HERE AFTER CONVERTING INTEGER OR REAL INTO WORK ! 18011: * AREA. WB IS SET TO NSTMX - (NUMBER OF CHARS IN RESULT). ! 18012: * ! 18013: GTS08 MOV =NSTMX,WA GET MAX NUMBER OF CHARACTERS ! 18014: SUB WB,WA COMPUTE LENGTH OF RESULT ! 18015: MOV WA,XL REMEMBER LENGTH FOR MOVE LATER ON ! 18016: ADD GTSSF,WA ADD ONE FOR NEGATIVE SIGN IF NEEDED ! 18017: JSR ALOCS ALLOCATE STRING FOR RESULT ! 18018: MOV XR,WC SAVE RESULT POINTER FOR THE MOMENT ! 18019: PSC XR POINT TO CHARS OF RESULT BLOCK ! 18020: BZE GTSSF,GTS09 SKIP IF POSITIVE ! 18021: MOV =CH$MN,WA ELSE LOAD NEGATIVE SIGN ! 18022: SCH WA,(XR)+ AND STORE IT ! 18023: CSC XR COMPLETE STORE CHARACTERS ! 18024: * ! 18025: * HERE AFTER DEALING WITH SIGN ! 18026: * ! 18027: GTS09 MOV XL,WA RECALL LENGTH TO MOVE ! 18028: MOV GTSWK,XL POINT TO RESULT WORK AREA ! 18029: PLC XL,WB POINT TO FIRST RESULT CHARACTER ! 18030: MVC MOVE CHARS TO RESULT STRING ! 18031: MOV WC,XR RESTORE RESULT POINTER ! 18032: .IF .CNRA ! 18033: .ELSE ! 18034: BRN GTS29 JUMP TO EXIT ! 18035: EJC ! 18036: * ! 18037: * GTSTG (CONTINUED) ! 18038: * ! 18039: * HERE TO CONVERT A REAL ! 18040: * ! 18041: GTS10 LDR RCVAL(XR) LOAD REAL ! 18042: ZER GTSSF RESET NEGATIVE FLAG ! 18043: REQ GTS31 SKIP IF ZERO ! 18044: RGE GTS11 JUMP IF REAL IS POSITIVE ! 18045: MOV =NUM01,GTSSF ELSE SET NEGATIVE FLAG ! 18046: NGR AND GET ABSOLUTE VALUE OF REAL ! 18047: * ! 18048: * NOW SCALE THE REAL TO THE RANGE (0.1 LE X LT 1.0) ! 18049: * ! 18050: GTS11 LDI INTV0 INITIALIZE EXPONENT TO ZERO ! 18051: * ! 18052: * LOOP TO SCALE UP IN STEPS OF 10**10 ! 18053: * ! 18054: GTS12 STR GTSRS SAVE REAL VALUE ! 18055: SBR REAP1 SUBTRACT 0.1 TO COMPARE ! 18056: RGE GTS13 JUMP IF SCALE UP NOT REQUIRED ! 18057: LDR GTSRS ELSE RELOAD VALUE ! 18058: MLR REATT MULTIPLY BY 10**10 ! 18059: SBI INTVT DECREMENT EXPONENT BY 10 ! 18060: BRN GTS12 LOOP BACK TO TEST AGAIN ! 18061: * ! 18062: * TEST FOR SCALE DOWN REQUIRED ! 18063: * ! 18064: GTS13 LDR GTSRS RELOAD VALUE ! 18065: SBR REAV1 SUBTRACT 1.0 ! 18066: RLT GTS17 JUMP IF NO SCALE DOWN REQUIRED ! 18067: LDR GTSRS ELSE RELOAD VALUE ! 18068: * ! 18069: * LOOP TO SCALE DOWN IN STEPS OF 10**10 ! 18070: * ! 18071: GTS14 SBR REATT SUBTRACT 10**10 TO COMPARE ! 18072: RLT GTS15 JUMP IF LARGE STEP NOT REQUIRED ! 18073: LDR GTSRS ELSE RESTORE VALUE ! 18074: DVR REATT DIVIDE BY 10**10 ! 18075: STR GTSRS STORE NEW VALUE ! 18076: ADI INTVT INCREMENT EXPONENT BY 10 ! 18077: BRN GTS14 LOOP BACK ! 18078: EJC ! 18079: * ! 18080: * GTSTG (CONTINUED) ! 18081: * ! 18082: * AT THIS POINT WE HAVE (1.0 LE X LT 10**10) ! 18083: * COMPLETE SCALING WITH POWERS OF TEN TABLE ! 18084: * ! 18085: GTS15 MOV =REAV1,XR POINT TO POWERS OF TEN TABLE ! 18086: * ! 18087: * LOOP TO LOCATE CORRECT ENTRY IN TABLE ! 18088: * ! 18089: GTS16 LDR GTSRS RELOAD VALUE ! 18090: ADI INTV1 INCREMENT EXPONENT ! 18091: ADD *CFP$R,XR POINT TO NEXT ENTRY IN TABLE ! 18092: SBR (XR) SUBTRACT IT TO COMPARE ! 18093: RGE GTS16 LOOP TILL WE FIND A LARGER ENTRY ! 18094: LDR GTSRS THEN RELOAD THE VALUE ! 18095: DVR (XR) AND COMPLETE SCALING ! 18096: STR GTSRS STORE VALUE ! 18097: * ! 18098: * WE ARE NOW SCALED, SO ROUND BY ADDING 0.5 * 10**(-CFP$S) ! 18099: * ! 18100: GTS17 LDR GTSRS GET VALUE AGAIN ! 18101: ADR GTSRN ADD ROUNDING FACTOR ! 18102: STR GTSRS STORE RESULT ! 18103: * ! 18104: * THE ROUNDING OPERATION MAY HAVE PUSHED US UP PAST ! 18105: * 1.0 AGAIN, SO CHECK ONE MORE TIME. ! 18106: * ! 18107: SBR REAV1 SUBTRACT 1.0 TO COMPARE ! 18108: RLT GTS18 SKIP IF OK ! 18109: ADI INTV1 ELSE INCREMENT EXPONENT ! 18110: LDR GTSRS RELOAD VALUE ! 18111: DVR REAVT DIVIDE BY 10.0 TO RESCALE ! 18112: BRN GTS19 JUMP TO MERGE ! 18113: * ! 18114: * HERE IF ROUNDING DID NOT MUCK UP SCALING ! 18115: * ! 18116: GTS18 LDR GTSRS RELOAD ROUNDED VALUE ! 18117: EJC ! 18118: * ! 18119: * GTSTG (CONTINUED) ! 18120: * ! 18121: * NOW WE HAVE COMPLETED THE SCALING AS FOLLOWS ! 18122: * ! 18123: * (IA) SIGNED EXPONENT ! 18124: * (RA) SCALED REAL (ABSOLUTE VALUE) ! 18125: * ! 18126: * IF THE EXPONENT IS NEGATIVE OR GREATER THAN CFP$S, THEN ! 18127: * WE CONVERT THE NUMBER IN THE FORM. ! 18128: * ! 18129: * (NEG SIGN) 0 . (CPF$S DIGITS) E (EXP SIGN) (EXP DIGITS) ! 18130: * ! 18131: * IF THE EXPONENT IS POSITIVE AND LESS THAN OR EQUAL TO ! 18132: * CFP$S, THE NUMBER IS CONVERTED IN THE FORM. ! 18133: * ! 18134: * (NEG SIGN) (EXPONENT DIGITS) . (CFP$S-EXPONENT DIGITS) ! 18135: * ! 18136: * IN BOTH CASES, THE FORMATS OBTAINED FROM THE ABOVE ! 18137: * RULES ARE MODIFIED BY DELETING TRAILING ZEROS AFTER THE ! 18138: * DECIMAL POINT. THERE ARE NO LEADING ZEROS IN THE EXPONENT ! 18139: * AND THE EXPONENT SIGN IS ALWAYS PRESENT. ! 18140: * ! 18141: GTS19 MOV =CFP$S,XL SET NUM DEC DIGITS = CFP$S ! 18142: MOV =CH$MN,GTSES SET EXPONENT SIGN NEGATIVE ! 18143: ILT GTS21 ALL SET IF EXPONENT IS NEGATIVE ! 18144: MFI WA ELSE FETCH EXPONENT ! 18145: BLE WA,=CFP$S,GTS20 SKIP IF WE CAN USE SPECIAL FORMAT ! 18146: MTI WA ELSE RESTORE EXPONENT ! 18147: NGI SET NEGATIVE FOR CVD ! 18148: MOV =CH$PL,GTSES SET PLUS SIGN FOR EXPONENT SIGN ! 18149: BRN GTS21 JUMP TO GENERATE EXPONENT ! 18150: * ! 18151: * HERE IF WE CAN USE THE FORMAT WITHOUT AN EXPONENT ! 18152: * ! 18153: GTS20 SUB WA,XL COMPUTE DIGITS AFTER DECIMAL POINT ! 18154: LDI INTV0 RESET EXPONENT TO ZERO ! 18155: EJC ! 18156: * ! 18157: * GTSTG (CONTINUED) ! 18158: * ! 18159: * MERGE HERE AS FOLLOWS ! 18160: * ! 18161: * (IA) EXPONENT ABSOLUTE VALUE ! 18162: * GTSES CHARACTER FOR EXPONENT SIGN ! 18163: * (RA) POSITIVE FRACTION ! 18164: * (XL) NUMBER OF DIGITS AFTER DEC POINT ! 18165: * ! 18166: GTS21 MOV GTSWK,XR POINT TO WORK AREA ! 18167: MOV =NSTMX,WB SET CHARACTER CTR TO MAX LENGTH ! 18168: PSC XR,WB PREPARE TO STORE (RIGHT TO LEFT) ! 18169: IEQ GTS23 SKIP EXPONENT IF IT IS ZERO ! 18170: * ! 18171: * LOOP TO GENERATE DIGITS OF EXPONENT ! 18172: * ! 18173: GTS22 CVD CONVERT A DIGIT INTO WA ! 18174: SCH WA,-(XR) STORE IN WORK AREA ! 18175: DCV WB DECREMENT COUNTER ! 18176: INE GTS22 LOOP BACK IF MORE DIGITS TO GO ! 18177: * ! 18178: * HERE GENERATE EXPONENT SIGN AND E ! 18179: * ! 18180: MOV GTSES,WA LOAD EXPONENT SIGN ! 18181: SCH WA,-(XR) STORE IN WORK AREA ! 18182: MOV =CH$LE,WA GET CHARACTER LETTER E ! 18183: SCH WA,-(XR) STORE IN WORK AREA ! 18184: SUB =NUM02,WB DECREMENT COUNTER FOR SIGN AND E ! 18185: * ! 18186: * HERE TO GENERATE THE FRACTION ! 18187: * ! 18188: GTS23 MLR GTSSC CONVERT REAL TO INTEGER (10**CFP$S) ! 18189: RTI GET INTEGER (OVERFLOW IMPOSSIBLE) ! 18190: NGI NEGATE AS REQUIRED BY CVD ! 18191: * ! 18192: * LOOP TO SUPPRESS TRAILING ZEROS ! 18193: * ! 18194: GTS24 BZE XL,GTS27 JUMP IF NO DIGITS LEFT TO DO ! 18195: CVD ELSE CONVERT ONE DIGIT ! 18196: BNE WA,=CH$D0,GTS26 JUMP IF NOT A ZERO ! 18197: DCV XL DECREMENT COUNTER ! 18198: BRN GTS24 LOOP BACK FOR NEXT DIGIT ! 18199: EJC ! 18200: * ! 18201: * GTSTG (CONTINUED) ! 18202: * ! 18203: * LOOP TO GENERATE DIGITS AFTER DECIMAL POINT ! 18204: * ! 18205: GTS25 CVD CONVERT A DIGIT INTO WA ! 18206: * ! 18207: * MERGE HERE FIRST TIME ! 18208: * ! 18209: GTS26 SCH WA,-(XR) STORE DIGIT ! 18210: DCV WB DECREMENT COUNTER ! 18211: DCV XL DECREMENT COUNTER ! 18212: BNZ XL,GTS25 LOOP BACK IF MORE TO GO ! 18213: * ! 18214: * HERE GENERATE THE DECIMAL POINT ! 18215: * ! 18216: GTS27 MOV =CH$DT,WA LOAD DECIMAL POINT ! 18217: SCH WA,-(XR) STORE IN WORK AREA ! 18218: DCV WB DECREMENT COUNTER ! 18219: * ! 18220: * HERE GENERATE THE DIGITS BEFORE THE DECIMAL POINT ! 18221: * ! 18222: GTS28 CVD CONVERT A DIGIT INTO WA ! 18223: SCH WA,-(XR) STORE IN WORK AREA ! 18224: DCV WB DECREMENT COUNTER ! 18225: INE GTS28 LOOP BACK IF MORE TO GO ! 18226: CSC XR COMPLETE STORE CHARACTERS ! 18227: BRN GTS08 ELSE JUMP BACK TO EXIT ! 18228: .FI ! 18229: * ! 18230: * EXIT POINT AFTER SUCCESSFUL CONVERSION ! 18231: * ! 18232: GTS29 MOV (XS)+,XL RESTORE XL ! 18233: ICA XS POP ARGUMENT ! 18234: MOV GTSVB,WB RESTORE WB ! 18235: MOV GTSVC,WC RESTORE WC ! 18236: * ! 18237: * MERGE HERE IF NO CONVERSION REQUIRED ! 18238: * ! 18239: GTS30 MOV SCLEN(XR),WA LOAD STRING LENGTH ! 18240: EXI RETURN TO CALLER ! 18241: .IF .CNRA ! 18242: .ELSE ! 18243: * ! 18244: * HERE TO RETURN STRING FOR REAL ZERO ! 18245: * ! 18246: GTS31 MOV =SCRE0,XL POINT TO STRING ! 18247: MOV =NUM02,WA 2 CHARS ! 18248: ZER WB ZERO OFFSET ! 18249: JSR SBSTR COPY STRING ! 18250: BRN GTS29 RETURN ! 18251: .FI ! 18252: .IF .CNBF ! 18253: .ELSE ! 18254: EJC ! 18255: * ! 18256: * HERE TO CONVERT A BUFFER BLOCK ! 18257: * ! 18258: GTS32 MOV XR,XL COPY ARG PTR ! 18259: MOV BCLEN(XL),WA GET SIZE TO ALLOCATE ! 18260: BZE WA,GTS33 IF NULL THEN RETURN NULL ! 18261: JSR ALOCS ALLOCATE STRING FRAME ! 18262: MOV XR,WB SAVE STRING PTR ! 18263: MOV SCLEN(XR),WA GET LENGTH TO MOVE ! 18264: CTB WA,0 GET AS MULTIPLE OF WORD SIZE ! 18265: MOV BCBUF(XL),XL POINT TO BFBLK ! 18266: ADD *SCSI$,XR POINT TO START OF CHARACTER AREA ! 18267: ADD *BFSI$,XL POINT TO START OF BUFFER CHARS ! 18268: MVW COPY WORDS ! 18269: MOV WB,XR RESTORE SCBLK PTR ! 18270: BRN GTS29 EXIT WITH SCBLK ! 18271: * ! 18272: * HERE WHEN NULL BUFFER IS BEING CONVERTED ! 18273: * ! 18274: GTS33 MOV =NULLS,XR POINT TO NULL ! 18275: BRN GTS29 EXIT WITH NULL ! 18276: .FI ! 18277: ENP END PROCEDURE GTSTG ! 18278: EJC ! 18279: * ! 18280: * GTVAR -- GET VARIABLE FOR I/O/TRACE ASSOCIATION ! 18281: * ! 18282: * GTVAR IS USED TO POINT TO AN ACTUAL VARIABLE LOCATION ! 18283: * FOR THE DETACH,INPUT,OUTPUT,TRACE,STOPTR SYSTEM FUNCTIONS ! 18284: * ! 18285: * (XR) ARGUMENT TO FUNCTION ! 18286: * JSR GTVAR CALL TO LOCATE VARIABLE POINTER ! 18287: * PPM LOC TRANSFER LOC IF NOT OK VARIABLE ! 18288: * (XL,WA) NAME BASE,OFFSET OF VARIABLE ! 18289: * (XR,RA) DESTROYED ! 18290: * (WB,WC) DESTROYED (CONVERT ERROR ONLY) ! 18291: * (XR) INPUT ARG (CONVERT ERROR ONLY) ! 18292: * ! 18293: GTVAR PRC E,1 ENTRY POINT ! 18294: BNE (XR),=B$NML,GTVR2 JUMP IF NOT A NAME ! 18295: MOV NMOFS(XR),WA ELSE LOAD NAME OFFSET ! 18296: MOV NMBAS(XR),XL LOAD NAME BASE ! 18297: BEQ (XL),=B$EVT,GTVR1 ERROR IF EXPRESSION VARIABLE ! 18298: BNE (XL),=B$KVT,GTVR3 ALL OK IF NOT KEYWORD VARIABLE ! 18299: * ! 18300: * HERE ON CONVERSION ERROR ! 18301: * ! 18302: GTVR1 EXI 1 TAKE CONVERT ERROR EXIT ! 18303: * ! 18304: * HERE IF NOT A NAME, TRY CONVERT TO NATURAL VARIABLE ! 18305: * ! 18306: GTVR2 MOV WC,GTVRC SAVE WC ! 18307: JSR GTNVR LOCATE VRBLK IF POSSIBLE ! 18308: PPM GTVR1 JUMP IF CONVERT ERROR ! 18309: MOV XR,XL ELSE COPY VRBLK NAME BASE ! 18310: MOV *VRVAL,WA AND SET OFFSET ! 18311: MOV GTVRC,WC RESTORE WC ! 18312: * ! 18313: * HERE FOR NAME OBTAINED ! 18314: * ! 18315: GTVR3 BHI XL,STATE,GTVR4 ALL OK IF NOT NATURAL VARIABLE ! 18316: BEQ VRSTO(XL),=B$VRE,GTVR1 ERROR IF PROTECTED VARIABLE ! 18317: * ! 18318: * COMMON EXIT POINT ! 18319: * ! 18320: GTVR4 EXI RETURN TO CALLER ! 18321: ENP END PROCEDURE GTVAR ! 18322: EJC ! 18323: * ! 18324: * HASHS -- COMPUTE HASH INDEX FOR STRING ! 18325: * ! 18326: * HASHS IS USED TO CONVERT A STRING TO A UNIQUE INTEGER ! 18327: * VALUE. THE RESULTING HASH VALUE IS A POSITIVE INTEGER ! 18328: * IN THE RANGE 0 TO CFP$M ! 18329: * ! 18330: * (XR) STRING TO BE HASHED ! 18331: * JSR HASHS CALL TO HASH STRING ! 18332: * (IA) HASH VALUE ! 18333: * (XR,WB,WC) DESTROYED ! 18334: * ! 18335: * THE HASH FUNCTION USED IS AS FOLLOWS. ! 18336: * ! 18337: * START WITH THE LENGTH OF THE STRING (SGD07) ! 18338: * ! 18339: * TAKE THE FIRST E$HNW WORDS OF THE CHARACTERS FROM ! 18340: * THE STRING OR ALL THE WORDS IF FEWER THAN E$HNW. ! 18341: * ! 18342: * COMPUTE THE EXCLUSIVE OR OF ALL THESE WORDS TREATING ! 18343: * THEM AS ONE WORD BIT STRING VALUES. ! 18344: * ! 18345: * MOVE THE RESULT AS AN INTEGER WITH THE MTI INSTRUCTION. ! 18346: * ! 18347: HASHS PRC E,0 ENTRY POINT ! 18348: MOV SCLEN(XR),WC LOAD STRING LENGTH IN CHARACTERS ! 18349: MOV WC,WB INITIALIZE WITH LENGTH ! 18350: BZE WC,HSHS3 JUMP IF NULL STRING ! 18351: CTW WC,0 ELSE GET NUMBER OF WORDS OF CHARS ! 18352: ADD *SCHAR,XR POINT TO CHARACTERS OF STRING ! 18353: BLO WC,=E$HNW,HSHS1 USE WHOLE STRING IF SHORT ! 18354: MOV =E$HNW,WC ELSE SET TO INVOLVE FIRST E$HNW WDS ! 18355: * ! 18356: * HERE WITH COUNT OF WORDS TO CHECK IN WC ! 18357: * ! 18358: HSHS1 LCT WC,WC SET COUNTER TO CONTROL LOOP ! 18359: * ! 18360: * LOOP TO COMPUTE EXCLUSIVE OR ! 18361: * ! 18362: HSHS2 XOB (XR)+,WB EXCLUSIVE OR NEXT WORD OF CHARS ! 18363: BCT WC,HSHS2 LOOP TILL ALL PROCESSED ! 18364: * ! 18365: * MERGE HERE WITH EXCLUSIVE OR IN WB ! 18366: * ! 18367: HSHS3 ZGB WB ZEROISE UNDEFINED BITS ! 18368: ANB BITSM,WB ENSURE IN RANGE 0 TO CFP$M ! 18369: MTI WB MOVE RESULT AS INTEGER ! 18370: ZER XR CLEAR GARBAGE VALUE IN XR ! 18371: EXI RETURN TO HASHS CALLER ! 18372: ENP END PROCEDURE HASHS ! 18373: EJC ! 18374: * ! 18375: * ICBLD -- BUILD INTEGER BLOCK ! 18376: * ! 18377: * (IA) INTEGER VALUE FOR ICBLK ! 18378: * JSR ICBLD CALL TO BUILD INTEGER BLOCK ! 18379: * (XR) POINTER TO RESULT ICBLK ! 18380: * (WA) DESTROYED ! 18381: * ! 18382: ICBLD PRC E,0 ENTRY POINT ! 18383: MFI XR,ICBL1 COPY SMALL INTEGERS ! 18384: BLE XR,=NUM02,ICBL3 JUMP IF 0,1 OR 2 ! 18385: * ! 18386: * CONSTRUCT ICBLK ! 18387: * ! 18388: ICBL1 MOV DNAMP,XR LOAD POINTER TO NEXT AVAILABLE LOC ! 18389: ADD *ICSI$,XR POINT PAST NEW ICBLK ! 18390: BLO XR,DNAME,ICBL2 JUMP IF THERE IS ROOM ! 18391: MOV *ICSI$,WA ELSE LOAD LENGTH OF ICBLK ! 18392: JSR ALLOC USE STANDARD ALLOCATOR TO GET BLOCK ! 18393: ADD WA,XR POINT PAST BLOCK TO MERGE ! 18394: * ! 18395: * MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED ! 18396: * ! 18397: ICBL2 MOV XR,DNAMP SET NEW POINTER ! 18398: SUB *ICSI$,XR POINT BACK TO START OF BLOCK ! 18399: MOV =B$ICL,(XR) STORE TYPE WORD ! 18400: STI ICVAL(XR) STORE INTEGER VALUE IN ICBLK ! 18401: EXI RETURN TO ICBLD CALLER ! 18402: * ! 18403: * OPTIMISE BY NOT BUILDING ICBLKS FOR SMALL INTEGERS ! 18404: * ! 18405: ICBL3 WTB XR CONVERT INTEGER TO OFFSET ! 18406: MOV INTAB(XR),XR POINT TO PRE-BUILT ICBLK ! 18407: EXI RETURN ! 18408: ENP END PROCEDURE ICBLD ! 18409: EJC ! 18410: * ! 18411: * IDENT -- COMPARE TWO VALUES ! 18412: * ! 18413: * IDENT COMPARES TWO VALUES IN THE SENSE OF THE IDENT ! 18414: * DIFFER FUNCTIONS AVAILABLE AT THE SNOBOL LEVEL. ! 18415: * ! 18416: * (XR) FIRST ARGUMENT ! 18417: * (XL) SECOND ARGUMENT ! 18418: * JSR IDENT CALL TO COMPARE ARGUMENTS ! 18419: * PPM LOC TRANSFER LOC IF IDENT ! 18420: * (NORMAL RETURN IF DIFFER) ! 18421: * (XR,XL,WC,RA) DESTROYED ! 18422: * ! 18423: IDENT PRC E,1 ENTRY POINT ! 18424: BEQ XR,XL,IDEN7 JUMP IF SAME POINTER (IDENT) ! 18425: MOV (XR),WC ELSE LOAD ARG 1 TYPE WORD ! 18426: BNE WC,(XL),IDEN1 DIFFER IF ARG 2 TYPE WORD DIFFER ! 18427: BEQ WC,=B$SCL,IDEN2 JUMP IF STRINGS ! 18428: BEQ WC,=B$ICL,IDEN4 JUMP IF INTEGERS ! 18429: .IF .CNRA ! 18430: .ELSE ! 18431: BEQ WC,=B$RCL,IDEN5 JUMP IF REALS ! 18432: .FI ! 18433: BEQ WC,=B$NML,IDEN6 JUMP IF NAMES ! 18434: * ! 18435: * FOR ALL OTHER DATATYPES, MUST BE DIFFER IF XR NE XL ! 18436: * ! 18437: * MERGE HERE FOR DIFFER ! 18438: * ! 18439: IDEN1 EXI TAKE DIFFER EXIT ! 18440: * ! 18441: * HERE FOR STRINGS, IDENT ONLY IF LENGTHS AND CHARS SAME ! 18442: * ! 18443: IDEN2 MOV SCLEN(XR),WC LOAD ARG 1 LENGTH ! 18444: BNE WC,SCLEN(XL),IDEN1 DIFFER IF LENGTHS DIFFER ! 18445: CTW WC,0 GET NUMBER OF WORDS IN STRINGS ! 18446: ADD *SCHAR,XR POINT TO CHARS OF ARG 1 ! 18447: ADD *SCHAR,XL POINT TO CHARS OF ARG 2 ! 18448: LCT WC,WC SET LOOP COUNTER ! 18449: * ! 18450: * LOOP TO COMPARE CHARACTERS. NOTE THAT WA CANNOT BE ZERO ! 18451: * SINCE ALL NULL STRINGS POINT TO NULLS AND GIVE XL=XR. ! 18452: * ! 18453: IDEN3 CNE (XR),(XL),IDEN8 DIFFER IF CHARS DO NOT MATCH ! 18454: ICA XR ELSE BUMP ARG ONE POINTER ! 18455: ICA XL BUMP ARG TWO POINTER ! 18456: BCT WC,IDEN3 LOOP BACK TILL ALL CHECKED ! 18457: EJC ! 18458: * ! 18459: * IDENT (CONTINUED) ! 18460: * ! 18461: * HERE TO EXIT FOR CASE OF TWO IDENT STRINGS ! 18462: * ! 18463: ZER XL CLEAR GARBAGE VALUE IN XL ! 18464: ZER XR CLEAR GARBAGE VALUE IN XR ! 18465: EXI 1 TAKE IDENT EXIT ! 18466: * ! 18467: * HERE FOR INTEGERS, IDENT IF SAME VALUES ! 18468: * ! 18469: IDEN4 LDI ICVAL(XR) LOAD ARG 1 ! 18470: SBI ICVAL(XL) SUBTRACT ARG 2 TO COMPARE ! 18471: IOV IDEN1 DIFFER IF OVERFLOW ! 18472: INE IDEN1 DIFFER IF RESULT IS NOT ZERO ! 18473: EXI 1 TAKE IDENT EXIT ! 18474: .IF .CNRA ! 18475: .ELSE ! 18476: * ! 18477: * HERE FOR REALS, IDENT IF SAME VALUES ! 18478: * ! 18479: IDEN5 LDR RCVAL(XR) LOAD ARG 1 ! 18480: SBR RCVAL(XL) SUBTRACT ARG 2 TO COMPARE ! 18481: ROV IDEN1 DIFFER IF OVERFLOW ! 18482: RNE IDEN1 DIFFER IF RESULT IS NOT ZERO ! 18483: EXI 1 TAKE IDENT EXIT ! 18484: .FI ! 18485: * ! 18486: * HERE FOR NAMES, IDENT IF BASES AND OFFSETS SAME ! 18487: * ! 18488: IDEN6 BNE NMOFS(XR),NMOFS(XL),IDEN1 DIFFER IF DIFFERENT OFFSET ! 18489: BNE NMBAS(XR),NMBAS(XL),IDEN1 DIFFER IF DIFFERENT BASE ! 18490: * ! 18491: * MERGE HERE TO SIGNAL IDENT FOR IDENTICAL POINTERS ! 18492: * ! 18493: IDEN7 EXI 1 TAKE IDENT EXIT ! 18494: * ! 18495: * HERE FOR DIFFER STRINGS ! 18496: * ! 18497: IDEN8 ZER XR CLEAR GARBAGE PTR IN XR ! 18498: ZER XL CLEAR GARBAGE PTR IN XL ! 18499: EXI RETURN TO CALLER (DIFFER) ! 18500: ENP END PROCEDURE IDENT ! 18501: EJC ! 18502: * ! 18503: * INOUT - USED TO INITIALISE INPUT AND OUTPUT VARIABLES ! 18504: * ! 18505: * (XL) POINTER TO VBL NAME STRING ! 18506: * (WB) TRBLK TYPE ! 18507: * JSR INOUT CALL TO PERFORM INITIALISATION ! 18508: * (XL) VRBLK PTR ! 18509: * (XR) TRBLK PTR ! 18510: * (WA,WC) DESTROYED ! 18511: * ! 18512: * NOTE THAT TRTER (= TRTRF) FIELD OF STANDARD I/O VARIABLES ! 18513: * POINTS TO CORRESPONDING SVBLK NOT TO A TRBLK AS IS THE ! 18514: * CASE FOR ORDINARY VARIABLES. ! 18515: * ! 18516: INOUT PRC E,0 ENTRY POINT ! 18517: MOV WB,-(XS) STACK TRBLK TYPE ! 18518: MOV SCLEN(XL),WA GET NAME LENGTH ! 18519: ZER WB POINT TO START OF NAME ! 18520: JSR SBSTR BUILD A PROPER SCBLK ! 18521: JSR GTNVR BUILD VRBLK ! 18522: PPM NO ERROR RETURN ! 18523: MOV XR,WC SAVE VRBLK POINTER ! 18524: MOV (XS)+,WB GET TRTER FIELD ! 18525: ZER XL ZERO TRFPT ! 18526: JSR TRBLD BUILD TRBLK ! 18527: MOV WC,XL RECALL VRBLK POINTER ! 18528: MOV VRSVP(XL),TRTER(XR) STORE SVBLK POINTER ! 18529: MOV XR,VRVAL(XL) STORE TRBLK PTR IN VRBLK ! 18530: MOV =B$VRA,VRGET(XL) SET TRAPPED ACCESS ! 18531: MOV =B$VRV,VRSTO(XL) SET TRAPPED STORE ! 18532: EXI RETURN TO CALLER ! 18533: ENP END PROCEDURE INOUT ! 18534: EJC ! 18535: .IF .CNBF ! 18536: .ELSE ! 18537: * ! 18538: * INSBF -- INSERT STRING IN BUFFER ! 18539: * ! 18540: * THIS ROUTINE WILL REPLACE A SECTION OF A BUFFER WITH THE ! 18541: * CONTENTS OF A GIVEN STRING. IF THE LENGTH OF THE ! 18542: * SECTION TO BE REPLACED IS DIFFERENT THAN THE LENGTH OF ! 18543: * THE GIVEN STRING, AND THE REPLACEMENT IS NOT AN APPEND, ! 18544: * THEN THE UPPER SECTION OF THE BUFFER IS SHIFTED UP OR ! 18545: * DOWN TO CREATE THE PROPER SPACE FOR THE INSERT. ! 18546: * ! 18547: * (XR) POINTER TO BFBLK ! 18548: * (XL) OBJECT WHICH IS STRING CONVERTABLE ! 18549: * (WA) OFFSET OF START OF INSERT IN (XR) ! 18550: * (WB) LENGTH OF SECTION IN (XR) REPLACED ! 18551: * JSR INSBF CALL TO INSERT CHARACTERS IN BUFFER ! 18552: * PPM LOC THREAD IF (XR) NOT CONVERTABLE ! 18553: * PPM LOC THREAD IF INSERT NOT POSSIBLE ! 18554: * ! 18555: * THE SECOND ALTERNATE EXIT IS TAKEN IF THE INSERT WOULD ! 18556: * OVERFLOW THE BUFFER, OR IF THE INSERT IS OUT PAST THE ! 18557: * DEFINED END OF THE BUFFER AS GIVEN. ! 18558: * ! 18559: INSBF PRC E,2 ENTRY POINT ! 18560: MOV WA,INSSA SAVE ENTRY WA ! 18561: MOV WB,INSSB SAVE ENTRY WB ! 18562: MOV WC,INSSC SAVE ENTRY WC ! 18563: ADD WB,WA ADD TO GET OFFSET PAST REPLACE PART ! 18564: MOV WA,INSAB SAVE WA+WB ! 18565: MOV BCLEN(XR),WC GET CURRENT DEFINED LENGTH ! 18566: BGT INSSA,WC,INS07 FAIL IF START OFFSET TOO BIG ! 18567: BGT WA,WC,INS07 FAIL IF FINAL OFFSET TOO BIG ! 18568: MOV XL,-(XS) SAVE ENTRY XL ! 18569: MOV XR,-(XS) SAVE BCBLK PTR ! 18570: MOV XL,-(XS) STACK AGAIN FOR GTSTG ! 18571: JSR GTSTG CALL TO CONVERT TO STRING ! 18572: PPM INS05 TAKE STRING CONVERT ERR EXIT ! 18573: MOV XR,XL SAVE STRING PTR ! 18574: MOV (XS),XR RESTORE BCBLK PTR ! 18575: ADD WC,WA ADD BUFFER LEN TO STRING LEN ! 18576: SUB INSSB,WA BIAS OUT COMPONENT BEING REPLACED ! 18577: MOV BCBUF(XR),XR POINT TO BFBLK ! 18578: BGT WA,BFALC(XR),INS06 FAIL IF RESULT EXCEEDS ALLOCATION ! 18579: MOV (XS),XR RESTORE BCBLK PTR ! 18580: MOV WC,WA GET BUFFER LENGTH ! 18581: SUB INSAB,WA SUBTRACT TO GET SHIFT LENGTH ! 18582: ADD SCLEN(XL),WC ADD LENGTH OF NEW ! 18583: SUB INSSB,WC SUBTRACT OLD TO GET TOTAL NEW LEN ! 18584: MOV BCLEN(XR),WB GET OLD BCLEN ! 18585: MOV WC,BCLEN(XR) STUFF NEW LENGTH ! 18586: BZE WA,INS04 SKIP SHIFT IF NOTHING TO DO ! 18587: BEQ INSSB,SCLEN(XL),INS04 SKIP SHIFT IF LENGTHS MATCH ! 18588: MOV BCBUF(XR),XR POINT TO BFBLK ! 18589: MOV XL,-(XS) SAVE SCBLK PTR ! 18590: BLO INSSB,SCLEN(XL),INS01 BRN IF SHFT IS FOR MORE ROOM ! 18591: EJC ! 18592: * ! 18593: * INSBF (CONTINUED) ! 18594: * ! 18595: * WE ARE SHIFTING THE UPPER SEGMENT DOWN TO COMPACT ! 18596: * THE BUFFER. (THE STRING LENGTH IS SMALLER THAN THE ! 18597: * SEGMENT BEING REPLACED.) REGISTERS ARE SET AS: ! 18598: * ! 18599: * (WA) MOVE (SHIFT DOWN) LENGTH ! 18600: * (WB) OLD BCLEN ! 18601: * (WC) NEW BCLEN ! 18602: * (XR) BFBLK PTR ! 18603: * (XL),(XS) SCBLK PTR ! 18604: * ! 18605: MOV INSSA,WB GET OFFSET TO INSERT ! 18606: ADD SCLEN(XL),WB ADD INSERT LENGTH TO GET DEST OFF ! 18607: MOV XR,XL MAKE COPY ! 18608: PLC XL,INSAB PREPARE SOURCE FOR MOVE ! 18609: PSC XR,WB PREPARE DESTINATION REG FOR MOVE ! 18610: MVC MOVE EM OUT ! 18611: BRN INS02 BRANCH TO PAD ! 18612: * ! 18613: * WE ARE SHIFTING THE UPPER SEGMENT UP TO EXPAND ! 18614: * THE BUFFER. (THE STRING LENGTH IS LARGER THAN THE ! 18615: * SEGMENT BEING REPLACED.) ! 18616: * ! 18617: INS01 MOV XR,XL COPY BFBLK PTR ! 18618: PLC XL,WB SET SOURCE REG FOR MOVE BACKWARDS ! 18619: PSC XR,WC SET DESTINATION PTR FOR MOVE ! 18620: MCB MOVE BACKWARDS (POSSIBLE OVERLAP) ! 18621: * ! 18622: * MERGE HERE AFTER MOVE TO ADJUST PADDING AT NEW BUFFER END ! 18623: * ! 18624: INS02 MOV (XS)+,XL RESTORE SCBLK PTR ! 18625: MOV WC,WA COPY NEW BUFFER END ! 18626: CTB WA,0 ROUND OUT ! 18627: SUB WC,WA SUBTRACT TO GET REMAINDER ! 18628: BZE WA,INS04 NO PAD IF ALREADY EVEN BOUNDARY ! 18629: MOV (XS),XR GET BCBLK PTR ! 18630: MOV BCBUF(XR),XR GET BFBLK PTR ! 18631: PSC XR,WC PREPARE TO PAD ! 18632: ZER WB CLEAR WB ! 18633: LCT WA,WA LOAD LOOP COUNT ! 18634: * ! 18635: * LOOP HERE TO STUFF PAD CHARACTERS ! 18636: * ! 18637: INS03 SCH WB,(XR)+ STUFF ZERO PAD ! 18638: BCT WA,INS03 BRANCH FOR MORE ! 18639: EJC ! 18640: * ! 18641: * INSBF (CONTINUED) ! 18642: * ! 18643: * MERGE HERE WHEN PADDING OK. NOW COPY IN THE INSERT ! 18644: * STRING TO THE HOLE. ! 18645: * ! 18646: INS04 MOV (XS),XR GET BCBLK PTR ! 18647: MOV BCBUF(XR),XR GET BFBLK PTR ! 18648: MOV SCLEN(XL),WA GET MOVE LENGTH ! 18649: PLC XL PREPARE TO COPY FROM FIRST CHAR ! 18650: PSC XR,INSSA PREPARE TO STORE IN HOLE ! 18651: MVC COPY THE CHARACTERS ! 18652: MOV (XS)+,XR RESTORE ENTRY XR ! 18653: MOV (XS)+,XL RESTORE ENTRY XL ! 18654: MOV INSSA,WA RESTORE ENTRY WA ! 18655: MOV INSSB,WB RESTORE ENTRY WB ! 18656: MOV INSSC,WC RESTORE ENTRY WC ! 18657: EXI RETURN TO CALLER ! 18658: * ! 18659: * HERE TO TAKE STRING CONVERT ERROR EXIT ! 18660: * ! 18661: INS05 MOV (XS)+,XR RESTORE ENTRY XR ! 18662: MOV (XS)+,XL RESTORE ENTRY XL ! 18663: MOV INSSA,WA RESTORE ENTRY WA ! 18664: MOV INSSB,WB RESTORE ENTRY WB ! 18665: MOV INSSC,WC RESTORE ENTRY WC ! 18666: EXI 1 ALTERNATE EXIT ! 18667: * ! 18668: * HERE FOR INVALID OFFSET OR LENGTH ! 18669: * ! 18670: INS06 MOV (XS)+,XR RESTORE ENTRY XR ! 18671: MOV (XS)+,XL RESTORE ENTRY XL ! 18672: * ! 18673: * MERGE FOR LENGTH FAILURE EXIT WITH STACK SET ! 18674: * ! 18675: INS07 MOV INSSA,WA RESTORE ENTRY WA ! 18676: MOV INSSB,WB RESTORE ENTRY WB ! 18677: MOV INSSC,WC RESTORE ENTRY WC ! 18678: EXI 2 ALTERNATE EXIT ! 18679: ENP END PROCEDURE INSBF ! 18680: EJC ! 18681: .FI ! 18682: * ! 18683: * IOFCB -- GET INPUT/OUTPUT FCBLK POINTER ! 18684: * ! 18685: * USED BY ENDFILE, EJECT AND REWIND TO FIND THE FCBLK ! 18686: * (IF ANY) CORRESPONDING TO THEIR ARGUMENT. ! 18687: * ! 18688: * -(XS) ARGUMENT ! 18689: * JSR IOFCB CALL TO FIND FCBLK ! 18690: * PPM LOC ARG IS AN UNSUITABLE NAME ! 18691: * PPM LOC ARG IS NULL STRING ! 18692: * (XS) POPPED ! 18693: * (XL) PTR TO FILEARG1 VRBLK ! 18694: * (XR) ARGUMENT ! 18695: * (WA) FCBLK PTR OR 0 ! 18696: * (WB) DESTROYED ! 18697: * ! 18698: IOFCB PRC N,2 ENTRY POINT ! 18699: JSR GTSTG GET ARG AS STRING ! 18700: PPM IOFC2 FAIL ! 18701: MOV XR,XL COPY STRING PTR ! 18702: JSR GTNVR GET AS NATURAL VARIABLE ! 18703: PPM IOFC3 FAIL IF NULL ! 18704: MOV XL,WB COPY STRING POINTER AGAIN ! 18705: MOV XR,XL COPY VRBLK PTR FOR RETURN ! 18706: ZER WA IN CASE NO TRBLK FOUND ! 18707: * ! 18708: * LOOP TO FIND FILE ARG1 TRBLK ! 18709: * ! 18710: IOFC1 MOV VRVAL(XR),XR GET POSSIBLE TRBLK PTR ! 18711: BNE (XR),=B$TRT,IOFC2 FAIL IF END OF CHAIN ! 18712: BNE TRTYP(XR),=TRTFC,IOFC1 LOOP IF NOT FILE ARG TRBLK ! 18713: MOV TRFPT(XR),WA GET FCBLK PTR ! 18714: MOV WB,XR COPY ARG ! 18715: EXI RETURN ! 18716: * ! 18717: * FAIL RETURN ! 18718: * ! 18719: IOFC2 EXI 1 FAIL ! 18720: * ! 18721: * NULL ARG ! 18722: * ! 18723: IOFC3 EXI 2 NULL ARG RETURN ! 18724: ENP END PROCEDURE IOFCB ! 18725: EJC ! 18726: * ! 18727: * IOPPF -- PROCESS FILEARG2 FOR IOPUT ! 18728: * ! 18729: * (R$XSC) FILEARG2 PTR ! 18730: * JSR IOPPF CALL TO PROCESS FILEARG2 ! 18731: * (XL) FILEARG1 PTR ! 18732: * (XR) FILE ARG2 PTR ! 18733: * -(XS)..-(XS) FIELDS EXTRACTED FROM FILEARG2 ! 18734: * (WC) NO. OF FIELDS EXTRACTED ! 18735: * (WB) INPUT/OUTPUT FLAG ! 18736: * (WA) FCBLK PTR OR 0 ! 18737: * ! 18738: IOPPF PRC N,0 ENTRY POINT ! 18739: ZER WB TO COUNT FIELDS EXTRACTED ! 18740: * ! 18741: * LOOP TO EXTRACT FIELDS ! 18742: * ! 18743: IOPP1 MOV =IODEL,XL GET DELIMITER ! 18744: MOV XL,WC COPY IT ! 18745: JSR XSCAN GET NEXT FIELD ! 18746: MOV XR,-(XS) STACK IT ! 18747: ICV WB INCREMENT COUNT ! 18748: BNZ WA,IOPP1 LOOP ! 18749: MOV WB,WC COUNT OF FIELDS ! 18750: MOV IOPTT,WB I/O MARKER ! 18751: MOV R$IOF,WA FCBLK PTR OR 0 ! 18752: MOV R$IO2,XR FILE ARG2 PTR ! 18753: MOV R$IO1,XL FILEARG1 ! 18754: EXI RETURN ! 18755: ENP END PROCEDURE IOPPF ! 18756: EJC ! 18757: * ! 18758: * IOPUT -- ROUTINE USED BY INPUT AND OUTPUT ! 18759: * ! 18760: * IOPUT SETS UP INPUT/OUTPUT ASSOCIATIONS. IT BUILDS ! 18761: * SUCH TRACE AND FILE CONTROL BLOCKS AS ARE NECESSARY AND ! 18762: * CALLS SYSFC,SYSIO TO PERFORM CHECKS ON THE ! 18763: * ARGUMENTS AND TO OPEN THE FILES. ! 18764: * ! 18765: * +-----------+ +---------------+ +-----------+ ! 18766: * +-.I I I I------.I =B$XRT I ! 18767: * I +-----------+ +---------------+ +-----------+ ! 18768: * I / / (R$FCB) I *4 I ! 18769: * I / / +-----------+ ! 18770: * I +-----------+ +---------------+ I I- ! 18771: * I I NAME +--.I =B$TRT I +-----------+ ! 18772: * I / / +---------------+ I I ! 18773: * I (FIRST ARG) I =TRTIN/=TRTOU I +-----------+ ! 18774: * I +---------------+ I ! 18775: * I I VALUE I I ! 18776: * I +---------------+ I ! 18777: * I I(TRTRF) 0 OR I--+ I ! 18778: * I +---------------+ I I ! 18779: * I I(TRFPT) 0 OR I----+ I ! 18780: * I +---------------+ I I I ! 18781: * I (I/O TRBLK) I I I ! 18782: * I +-----------+ I I I ! 18783: * I I I I I I ! 18784: * I +-----------+ I I I ! 18785: * I I I I I I ! 18786: * I +-----------+ +---------------+ I I I ! 18787: * I I +--.I =B$TRT I.-+ I I ! 18788: * I +-----------+ +---------------+ I I ! 18789: * I / / I =TRTFC I I I ! 18790: * I / / +---------------+ I I ! 18791: * I (FILEARG1 I VALUE I I I ! 18792: * I VRBLK) +---------------+ I I ! 18793: * I I(TRTRF) 0 OR I--+ I . ! 18794: * I +---------------+ I . +-----------+ ! 18795: * I I(TRFPT) 0 OR I------./ FCBLK / ! 18796: * I +---------------+ I +-----------+ ! 18797: * I (TRTRF) I ! 18798: * I I ! 18799: * I I ! 18800: * I +---------------+ I ! 18801: * I I =B$XRT I.-+ ! 18802: * I +---------------+ ! 18803: * I I *5 I ! 18804: * I +---------------+ ! 18805: * +------------------I I ! 18806: * +---------------+ +-----------+ ! 18807: * I(TRTRF) O OR I------.I =B$XRT I ! 18808: * +---------------+ +-----------+ ! 18809: * I NAME OFFSET I I ETC I ! 18810: * +---------------+ ! 18811: * (IOCHN - CHAIN OF NAME POINTERS) ! 18812: EJC ! 18813: * ! 18814: * IOPUT (CONTINUED) ! 18815: * ! 18816: * NO ADDITIONAL TRAP BLOCKS ARE USED FOR STANDARD INPUT/OUT ! 18817: * FILES. OTHERWISE AN I/O TRAP BLOCK IS ATTACHED TO SECOND ! 18818: * ARG (FILEARG1) VRBLK. SEE DIAGRAM ABOVE FOR DETAILS OF ! 18819: * THE STRUCTURE BUILT. ! 18820: * ! 18821: * -(XS) 1ST ARG (VBL TO BE ASSOCIATED) ! 18822: * -(XS) 2ND ARG (FILE ARG1) ! 18823: * -(XS) 3RD ARG (FILE ARG2) ! 18824: * (WB) 0 FOR INPUT, 3 FOR OUTPUT ASSOC. ! 18825: * JSR IOPUT CALL FOR INPUT/OUTPUT ASSOCIATION ! 18826: * PPM LOC 3RD ARG NOT A STRING ! 18827: * PPM LOC 2ND ARG NOT A SUITABLE NAME ! 18828: * PPM LOC 1ST ARG NOT A SUITABLE NAME ! 18829: * PPM LOC INAPPROPRIATE FILE SPEC FOR I/O ! 18830: * PPM LOC I/O FILE DOES NOT EXIST ! 18831: * PPM LOC I/O FILE CANNOT BE READ/WRITTEN ! 18832: * (XS) POPPED ! 18833: * (XL,XR,WA,WB,WC) DESTROYED ! 18834: * ! 18835: IOPUT PRC N,6 ENTRY POINT ! 18836: ZER R$IOT IN CASE NO TRTRF BLOCK USED ! 18837: ZER R$IOF IN CASE NO FCBLK ALOCATED ! 18838: MOV WB,IOPTT STORE I/O TRACE TYPE ! 18839: JSR XSCNI PREPARE TO SCAN FILEARG2 ! 18840: PPM IOP13 FAIL ! 18841: PPM IOPA0 NULL FILE ARG2 ! 18842: * ! 18843: IOPA0 MOV XR,R$IO2 KEEP FILE ARG2 ! 18844: MOV WA,XL COPY LENGTH ! 18845: JSR GTSTG CONVERT FILEARG1 TO STRING ! 18846: PPM IOP14 FAIL ! 18847: MOV XR,R$IO1 KEEP FILEARG1 PTR ! 18848: JSR GTNVR CONVERT TO NATURAL VARIABLE ! 18849: PPM IOP00 JUMP IF NULL ! 18850: BRN IOP04 JUMP TO PROCESS NON-NULL ARGS ! 18851: * ! 18852: * NULL FILEARG1 ! 18853: * ! 18854: IOP00 BZE XL,IOP01 SKIP IF BOTH ARGS NULL ! 18855: JSR IOPPF PROCESS FILEARG2 ! 18856: JSR SYSFC CALL FOR FILEARG2 CHECK ! 18857: PPM IOP16 FAIL ! 18858: BRN IOP11 COMPLETE FILE ASSOCIATION ! 18859: EJC ! 18860: * ! 18861: * IOPUT (CONTINUED) ! 18862: * ! 18863: * HERE WITH 0 OR FCBLK PTR IN (XL) ! 18864: * ! 18865: IOP01 MOV IOPTT,WB GET TRACE TYPE ! 18866: MOV R$IOT,XR GET 0 OR TRTRF PTR ! 18867: JSR TRBLD BUILD TRBLK ! 18868: MOV XR,WC COPY TRBLK POINTER ! 18869: MOV (XS)+,XR GET VARIABLE FROM STACK ! 18870: JSR GTVAR POINT TO VARIABLE ! 18871: PPM IOP15 FAIL ! 18872: MOV XL,R$ION SAVE NAME POINTER ! 18873: MOV XL,XR COPY NAME POINTER ! 18874: ADD WA,XR POINT TO VARIABLE ! 18875: SUB *VRVAL,XR SUBTRACT OFFSET,MERGE INTO LOOP ! 18876: * ! 18877: * LOOP TO END OF TRBLK CHAIN IF ANY ! 18878: * ! 18879: IOP02 MOV XR,XL COPY BLK PTR ! 18880: MOV VRVAL(XR),XR LOAD PTR TO NEXT TRBLK ! 18881: BNE (XR),=B$TRT,IOP03 JUMP IF NOT TRAPPED ! 18882: BNE TRTYP(XR),IOPTT,IOP02 LOOP IF NOT SAME ASSOCN ! 18883: MOV TRNXT(XR),XR GET VALUE AND DELETE OLD TRBLK ! 18884: * ! 18885: * IOPUT (CONTINUED) ! 18886: * ! 18887: * STORE NEW ASSOCIATION ! 18888: * ! 18889: IOP03 MOV WC,VRVAL(XL) LINK TO THIS TRBLK ! 18890: MOV WC,XL COPY POINTER ! 18891: MOV XR,TRNXT(XL) STORE VALUE IN TRBLK ! 18892: MOV R$ION,XR RESTORE POSSIBLE VRBLK POINTER ! 18893: MOV WA,WB KEEP OFFSET TO NAME ! 18894: JSR SETVR IF VRBLK, SET VRGET,VRSTO ! 18895: MOV R$IOT,XR GET 0 OR TRTRF PTR ! 18896: BNZ XR,IOP19 JUMP IF TRTRF BLOCK EXISTS ! 18897: EXI RETURN TO CALLER ! 18898: * ! 18899: * NON STANDARD FILE ! 18900: * SEE IF AN FCBLK HAS ALREADY BEEN ALLOCATED. ! 18901: * ! 18902: IOP04 ZER WA IN CASE NO FCBLK FOUND ! 18903: EJC ! 18904: * ! 18905: * IOPUT (CONTINUED) ! 18906: * ! 18907: * SEARCH POSSIBLE TRBLK CHAIN TO PICK UP THE FCBLK ! 18908: * ! 18909: IOP05 MOV XR,WB REMEMBER BLK PTR ! 18910: MOV VRVAL(XR),XR CHAIN ALONG ! 18911: BNE (XR),=B$TRT,IOP06 JUMP IF END OF TRBLK CHAIN ! 18912: BNE TRTYP(XR),=TRTFC,IOP05 LOOP IF MORE TO GO ! 18913: MOV XR,R$IOT POINT TO FILE ARG1 TRBLK ! 18914: MOV TRFPT(XR),WA GET FCBLK PTR FROM TRBLK ! 18915: * ! 18916: * WA = 0 OR FCBLK PTR ! 18917: * WB = PTR TO PRECEDING BLK TO WHICH ANY TRTRF BLOCK ! 18918: * FOR FILE ARG1 MUST BE CHAINED. ! 18919: * ! 18920: IOP06 MOV WA,R$IOF KEEP POSSIBLE FCBLK PTR ! 18921: MOV WB,R$IOP KEEP PRECEDING BLK PTR ! 18922: JSR IOPPF PROCESS FILEARG2 ! 18923: JSR SYSFC SEE IF FCBLK REQUIRED ! 18924: PPM IOP16 FAIL ! 18925: BZE WA,IOP12 SKIP IF NO NEW FCBLK WANTED ! 18926: BLT WC,=NUM02,IOP6A JUMP IF FCBLK IN DYNAMIC ! 18927: JSR ALOST GET IT IN STATIC ! 18928: BRN IOP6B SKIP ! 18929: * ! 18930: * OBTAIN FCBLK IN DYNAMIC ! 18931: * ! 18932: IOP6A JSR ALLOC GET SPACE FOR FCBLK ! 18933: * ! 18934: * MERGE ! 18935: * ! 18936: IOP6B MOV XR,XL POINT TO FCBLK ! 18937: MOV WA,WB COPY ITS LENGTH ! 18938: BTW WB GET COUNT AS WORDS (SGD APR80) ! 18939: LCT WB,WB LOOP COUNTER ! 18940: * ! 18941: * CLEAR FCBLK ! 18942: * ! 18943: IOP07 ZER (XR)+ CLEAR A WORD ! 18944: BCT WB,IOP07 LOOP ! 18945: BEQ WC,=NUM02,IOP09 SKIP IF IN STATIC - DONT SET FIELDS ! 18946: MOV =B$XNT,(XL) STORE XNBLK CODE IN CASE ! 18947: MOV WA,1(XL) STORE LENGTH ! 18948: BNZ WC,IOP09 JUMP IF XNBLK WANTED ! 18949: MOV =B$XRT,(XL) XRBLK CODE REQUESTED ! 18950: * ! 18951: EJC ! 18952: * IOPUT (CONTINUED) ! 18953: * ! 18954: * COMPLETE FCBLK INITIALISATION ! 18955: * ! 18956: IOP09 MOV R$IOT,XR GET POSSIBLE TRBLK PTR ! 18957: MOV XL,R$IOF STORE FCBLK PTR ! 18958: BNZ XR,IOP10 JUMP IF TRBLK ALREADY FOUND ! 18959: * ! 18960: * A NEW TRBLK IS NEEDED ! 18961: * ! 18962: MOV =TRTFC,WB TRTYP FOR FCBLK TRAP BLK ! 18963: JSR TRBLD MAKE THE BLOCK ! 18964: MOV XR,R$IOT COPY TRTRF PTR ! 18965: MOV R$IOP,XL POINT TO PRECEDING BLK ! 18966: MOV VRVAL(XL),VRVAL(XR) COPY VALUE FIELD TO TRBLK ! 18967: MOV XR,VRVAL(XL) LINK NEW TRBLK INTO CHAIN ! 18968: MOV XL,XR POINT TO PREDECESSOR BLK ! 18969: JSR SETVR SET TRACE INTERCEPTS ! 18970: MOV VRVAL(XR),XR RECOVER TRBLK PTR ! 18971: * ! 18972: * XR IS PTR TO TRBLK, XL IS FCBLK PTR OR 0 ! 18973: * ! 18974: IOP10 MOV R$IOF,TRFPT(XR) STORE FCBLK PTR ! 18975: * ! 18976: * CALL SYSIO TO COMPLETE FILE ACCESSING ! 18977: * ! 18978: IOP11 MOV R$IOF,WA COPY FCBLK PTR OR 0 ! 18979: MOV IOPTT,WB GET INPUT/OUTPUT FLAG ! 18980: MOV R$IO2,XR GET FILE ARG2 ! 18981: MOV R$IO1,XL GET FILE ARG1 ! 18982: JSR SYSIO ASSOCIATE TO THE FILE ! 18983: PPM IOP17 FAIL ! 18984: PPM IOP18 FAIL ! 18985: BNZ R$IOT,IOP01 NOT STD INPUT IF NON-NULL TRTRF BLK ! 18986: BNZ IOPTT,IOP01 JUMP IF OUTPUT ! 18987: BZE WC,IOP01 NO CHANGE TO STANDARD READ LENGTH ! 18988: MOV WC,CSWIN STORE NEW READ LENGTH FOR STD FILE ! 18989: BRN IOP01 MERGE TO FINISH THE TASK ! 18990: * ! 18991: * SYSFC MAY HAVE RETURNED A POINTER TO A PRIVATE FCBLK ! 18992: * ! 18993: IOP12 BNZ XL,IOP09 JUMP IF PRIVATE FCBLK ! 18994: BRN IOP11 FINISH THE ASSOCIATION ! 18995: * ! 18996: * FAILURE RETURNS ! 18997: * ! 18998: IOP13 EXI 1 3RD ARG NOT A STRING ! 18999: IOP14 EXI 2 2ND ARG UNSUITABLE ! 19000: IOP15 EXI 3 1ST ARG UNSUITABLE ! 19001: IOP16 EXI 4 FILE SPEC WRONG ! 19002: IOP17 EXI 5 I/O FILE DOES NOT EXIST ! 19003: IOP18 EXI 6 I/O FILE CANNOT BE READ/WRITTEN ! 19004: EJC ! 19005: * ! 19006: * IOPUT (CONTINUED) ! 19007: * ! 19008: * ADD TO IOCHN CHAIN OF ASSSOCIATED VARIABLES UNLESS ALREAD ! 19009: * PRESENT. ! 19010: * ! 19011: IOP19 MOV R$ION,WC WC = NAME BASE, WB = NAME OFFSET ! 19012: * ! 19013: * SEARCH LOOP ! 19014: * ! 19015: IOP20 MOV TRTRF(XR),XR NEXT LINK OF CHAIN ! 19016: BZE XR,IOP21 NOT FOUND ! 19017: BNE WC,IONMB(XR),IOP20 NO MATCH ! 19018: BEQ WB,IONMO(XR),IOP22 EXIT IF MATCHED ! 19019: BRN IOP20 LOOP ! 19020: * ! 19021: * NOT FOUND ! 19022: * ! 19023: IOP21 MOV *NUM05,WA SPACE NEEDED ! 19024: JSR ALLOC GET IT ! 19025: MOV =B$XRT,(XR) STORE XRBLK CODE ! 19026: MOV WA,1(XR) STORE LENGTH ! 19027: MOV WC,IONMB(XR) STORE NAME BASE ! 19028: MOV WB,IONMO(XR) STORE NAME OFFSET ! 19029: MOV R$IOT,XL POINT TO TRTRF BLK ! 19030: MOV TRTRF(XL),WA GET PTR FIELD CONTENTS ! 19031: MOV XR,TRTRF(XL) STORE PTR TO NEW BLOCK ! 19032: MOV WA,TRTRF(XR) COMPLETE THE LINKING ! 19033: * ! 19034: * INSERT FCBLK ON FCBLK CHAIN FOR SYSEJ, SYSXI ! 19035: * ! 19036: IOP22 BZE R$IOF,IOP25 SKIP IF NO FCBLK ! 19037: MOV R$FCB,XL PTR TO HEAD OF EXISTING CHAIN ! 19038: * ! 19039: * SEE IF FCBLK ALREADY ON CHAIN ! 19040: * ! 19041: IOP23 BZE XL,IOP24 NOT ON IF END OF CHAIN ! 19042: BEQ 3(XL),R$IOF,IOP25 DONT DUPLICATE IF FIND IT ! 19043: MOV 2(XL),XL GET NEXT LINK ! 19044: BRN IOP23 LOOP ! 19045: * ! 19046: * NOT FOUND SO ADD AN ENTRY FOR THIS FCBLK ! 19047: * ! 19048: IOP24 MOV *NUM04,WA SPACE NEEDED ! 19049: JSR ALLOC GET IT ! 19050: MOV =B$XRT,(XR) STORE BLOCK CODE ! 19051: MOV WA,1(XR) STORE LENGTH ! 19052: MOV R$FCB,2(XR) STORE PREVIOUS LINK IN THIS NODE ! 19053: MOV R$IOF,3(XR) STORE FCBLK PTR ! 19054: MOV XR,R$FCB INSERT NODE INTO FCBLK CHAIN ! 19055: * ! 19056: * RETURN ! 19057: * ! 19058: IOP25 EXI RETURN TO CALLER ! 19059: ENP END PROCEDURE IOPUT ! 19060: EJC ! 19061: * ! 19062: * KTREX -- EXECUTE KEYWORD TRACE ! 19063: * ! 19064: * KTREX IS USED TO EXECUTE A POSSIBLE KEYWORD TRACE. IT ! 19065: * INCLUDES THE TEST ON TRACE AND TESTS FOR TRACE ACTIVE. ! 19066: * ! 19067: * (XL) PTR TO TRBLK (OR 0 IF UNTRACED) ! 19068: * JSR KTREX CALL TO EXECUTE KEYWORD TRACE ! 19069: * (XL,WA,WB,WC) DESTROYED ! 19070: * (RA) DESTROYED ! 19071: * ! 19072: KTREX PRC R,0 ENTRY POINT (RECURSIVE) ! 19073: BZE XL,KTRX3 IMMEDIATE EXIT IF KEYWORD UNTRACED ! 19074: BZE KVTRA,KTRX3 IMMEDIATE EXIT IF TRACE = 0 ! 19075: DCV KVTRA ELSE DECREMENT TRACE ! 19076: MOV XR,-(XS) SAVE XR ! 19077: MOV XL,XR COPY TRBLK POINTER ! 19078: MOV TRKVR(XR),XL LOAD VRBLK POINTER (NMBAS) ! 19079: MOV *VRVAL,WA SET NAME OFFSET ! 19080: BZE TRFNC(XR),KTRX1 JUMP IF PRINT TRACE ! 19081: JSR TRXEQ ELSE EXECUTE FULL TRACE ! 19082: BRN KTRX2 AND JUMP TO EXIT ! 19083: * ! 19084: * HERE FOR PRINT TRACE ! 19085: * ! 19086: KTRX1 MOV XL,-(XS) STACK VRBLK PTR FOR KWNAM ! 19087: MOV WA,-(XS) STACK OFFSET FOR KWNAM ! 19088: JSR PRTSN PRINT STATEMENT NUMBER ! 19089: MOV =CH$AM,WA LOAD AMPERSAND ! 19090: JSR PRTCH PRINT AMPERSAND ! 19091: JSR PRTNM PRINT KEYWORD NAME ! 19092: MOV =TMBEB,XR POINT TO BLANK-EQUAL-BLANK ! 19093: JSR PRTST PRINT BLANK-EQUAL-BLANK ! 19094: JSR KWNAM GET KEYWORD PSEUDO-VARIABLE NAME ! 19095: MOV XR,DNAMP RESET PTR TO DELETE KVBLK ! 19096: JSR ACESS GET KEYWORD VALUE ! 19097: PPM FAILURE IS IMPOSSIBLE ! 19098: JSR PRTVL PRINT KEYWORD VALUE ! 19099: JSR PRTNL TERMINATE PRINT LINE ! 19100: * ! 19101: * HERE TO EXIT AFTER COMPLETING TRACE ! 19102: * ! 19103: KTRX2 MOV (XS)+,XR RESTORE ENTRY XR ! 19104: * ! 19105: * MERGE HERE TO EXIT IF NO TRACE REQUIRED ! 19106: * ! 19107: KTRX3 EXI RETURN TO KTREX CALLER ! 19108: ENP END PROCEDURE KTREX ! 19109: EJC ! 19110: * ! 19111: * KWNAM -- GET PSEUDO-VARIABLE NAME FOR KEYWORD ! 19112: * ! 19113: * 1(XS) NAME BASE FOR VRBLK ! 19114: * 0(XS) OFFSET (SHOULD BE *VRVAL) ! 19115: * JSR KWNAM CALL TO GET PSEUDO-VARIABLE NAME ! 19116: * (XS) POPPED TWICE ! 19117: * (XL,WA) RESULTING PSEUDO-VARIABLE NAME ! 19118: * (XR,WA,WB) DESTROYED ! 19119: * ! 19120: KWNAM PRC N,0 ENTRY POINT ! 19121: ICA XS IGNORE NAME OFFSET ! 19122: MOV (XS)+,XR LOAD NAME BASE ! 19123: BGE XR,STATE,KWNM1 JUMP IF NOT NATURAL VARIABLE NAME ! 19124: BNZ VRLEN(XR),KWNM1 ERROR IF NOT SYSTEM VARIABLE ! 19125: MOV VRSVP(XR),XR ELSE POINT TO SVBLK ! 19126: MOV SVBIT(XR),WA LOAD BIT MASK ! 19127: ANB BTKNM,WA AND WITH KEYWORD BIT ! 19128: ZRB WA,KWNM1 ERROR IF NO KEYWORD ASSOCIATION ! 19129: MOV SVLEN(XR),WA ELSE LOAD NAME LENGTH IN CHARACTERS ! 19130: CTB WA,SVCHS COMPUTE OFFSET TO FIELD WE WANT ! 19131: ADD WA,XR POINT TO SVKNM FIELD ! 19132: MOV (XR),WB LOAD SVKNM VALUE ! 19133: MOV *KVSI$,WA SET SIZE OF KVBLK ! 19134: JSR ALLOC ALLOCATE KVBLK ! 19135: MOV =B$KVT,(XR) STORE TYPE WORD ! 19136: MOV WB,KVNUM(XR) STORE KEYWORD NUMBER ! 19137: MOV =TRBKV,KVVAR(XR) SET DUMMY TRBLK POINTER ! 19138: MOV XR,XL COPY KVBLK POINTER ! 19139: MOV *KVVAR,WA SET PROPER OFFSET ! 19140: EXI RETURN TO KVNAM CALLER ! 19141: * ! 19142: * HERE IF NOT KEYWORD NAME ! 19143: * ! 19144: KWNM1 ERB 251,KEYWORD OPERAND IS NOT NAME OF DEFINED KEYWORD ! 19145: ENP END PROCEDURE KWNAM ! 19146: EJC ! 19147: * ! 19148: * LCOMP-- COMPARE TWO STRINGS LEXICALLY ! 19149: * ! 19150: * 1(XS) FIRST ARGUMENT ! 19151: * 0(XS) SECOND ARGUMENT ! 19152: * JSR LCOMP CALL TO COMPARE ARUMENTS ! 19153: * PPM LOC TRANSFER LOC FOR ARG1 NOT STRING ! 19154: * PPM LOC TRANSFER LOC FOR ARG2 NOT STRING ! 19155: * PPM LOC TRANSFER LOC IF ARG1 LLT ARG2 ! 19156: * PPM LOC TRANSFER LOC IF ARG1 LEQ ARG2 ! 19157: * PPM LOC TRANSFER LOC IF ARG1 LGT ARG2 ! 19158: * (THE NORMAL RETURN IS NEVER TAKEN) ! 19159: * (XS) POPPED TWICE ! 19160: * (XR,XL) DESTROYED ! 19161: * (WA,WB,WC,RA) DESTROYED ! 19162: * ! 19163: LCOMP PRC N,5 ENTRY POINT ! 19164: JSR GTSTG CONVERT SECOND ARG TO STRING ! 19165: PPM LCMP6 JUMP IF SECOND ARG NOT STRING ! 19166: MOV XR,XL ELSE SAVE POINTER ! 19167: MOV WA,WB AND LENGTH ! 19168: JSR GTSTG CONVERT FIRST ARGUMENT TO STRING ! 19169: PPM LCMP5 JUMP IF NOT STRING ! 19170: MOV WA,WC SAVE ARG 1 LENGTH ! 19171: PLC XR POINT TO CHARS OF ARG 1 ! 19172: PLC XL POINT TO CHARS OF ARG 2 ! 19173: BLO WA,WB,LCMP1 JUMP IF ARG 1 LENGTH IS SMALLER ! 19174: MOV WB,WA ELSE SET ARG 2 LENGTH AS SMALLER ! 19175: * ! 19176: * HERE WITH SMALLER LENGTH IN (WA) ! 19177: * ! 19178: LCMP1 CMC LCMP4,LCMP3 COMPARE STRINGS, JUMP IF UNEQUAL ! 19179: BNE WB,WC,LCMP2 IF EQUAL, JUMP IF LENGTHS UNEQUAL ! 19180: EXI 4 ELSE IDENTICAL STRINGS, LEQ EXIT ! 19181: EJC ! 19182: * ! 19183: * LCOMP (CONTINUED) ! 19184: * ! 19185: * HERE IF INITIAL STRINGS IDENTICAL, BUT LENGTHS UNEQUAL ! 19186: * ! 19187: LCMP2 BHI WC,WB,LCMP4 JUMP IF ARG 1 LENGTH GT ARG 2 LENG ! 19188: * ! 19189: * HERE IF FIRST ARG LLT SECOND ARG ! 19190: * ! 19191: LCMP3 EXI 3 TAKE LLT EXIT ! 19192: * ! 19193: * HERE IF FIRST ARG LGT SECOND ARG ! 19194: * ! 19195: LCMP4 EXI 5 TAKE LGT EXIT ! 19196: * ! 19197: * HERE IF FIRST ARG IS NOT A STRING ! 19198: * ! 19199: LCMP5 EXI 1 TAKE BAD FIRST ARG EXIT ! 19200: * ! 19201: * HERE FOR SECOND ARG NOT A STRING ! 19202: * ! 19203: LCMP6 EXI 2 TAKE BAD SECOND ARG ERROR EXIT ! 19204: ENP END PROCEDURE LCOMP ! 19205: EJC ! 19206: * ! 19207: * LISTR -- LIST SOURCE LINE ! 19208: * ! 19209: * LISTR IS USED TO LIST A SOURCE LINE DURING THE INITIAL ! 19210: * COMPILATION. IT IS CALLED FROM SCANE AND SCANL. ! 19211: * ! 19212: * JSR LISTR CALL TO LIST LINE ! 19213: * (XR,XL,WA,WB,WC) DESTROYED ! 19214: * ! 19215: * GLOBAL LOCATIONS USED BY LISTR ! 19216: * ! 19217: * ERLST IF LISTING ON ACCOUNT OF AN ERROR ! 19218: * ! 19219: * LSTLC COUNT LINES ON CURRENT PAGE ! 19220: * ! 19221: * LSTNP MAX NUMBER OF LINES/PAGE ! 19222: * ! 19223: * LSTPF SET NON-ZERO IF THE CURRENT SOURCE ! 19224: * LINE HAS BEEN LISTED, ELSE ZERO. ! 19225: * ! 19226: * LSTPG COMPILER LISTING PAGE NUMBER ! 19227: * ! 19228: * LSTSN SET IF STMNT NUM TO BE LISTED ! 19229: * ! 19230: * R$CIM POINTER TO CURRENT INPUT LINE. ! 19231: * ! 19232: * R$TTL TITLE FOR SOURCE LISTING ! 19233: * ! 19234: * R$STL PTR TO SUB-TITLE STRING ! 19235: * ! 19236: * ENTRY POINT ! 19237: * ! 19238: LISTR PRC E,0 ENTRY POINT ! 19239: BNZ CNTTL,LIST5 JUMP IF -TITLE OR -STITL ! 19240: BNZ LSTPF,LIST4 IMMEDIATE EXIT IF ALREADY LISTED ! 19241: BGE LSTLC,LSTNP,LIST6 JUMP IF NO ROOM ! 19242: * ! 19243: * HERE AFTER PRINTING TITLE (IF NEEDED) ! 19244: * ! 19245: LIST0 MOV R$CIM,XR LOAD POINTER TO CURRENT IMAGE ! 19246: PLC XR POINT TO CHARACTERS ! 19247: LCH WA,(XR) LOAD FIRST CHARACTER ! 19248: MOV LSTSN,XR LOAD STATEMENT NUMBER ! 19249: BZE XR,LIST2 JUMP IF NO STATEMENT NUMBER ! 19250: MTI XR ELSE GET STMNT NUMBER AS INTEGER ! 19251: BNE STAGE,=STGIC,LIST1 SKIP IF EXECUTE TIME ! 19252: BEQ WA,=CH$AS,LIST2 NO STMNT NUMBER LIST IF COMMENT ! 19253: BEQ WA,=CH$MN,LIST2 NO STMNT NO. IF CONTROL CARD ! 19254: * ! 19255: * PRINT STATEMENT NUMBER ! 19256: * ! 19257: LIST1 JSR PRTIN ELSE PRINT STATEMENT NUMBER ! 19258: ZER LSTSN AND CLEAR FOR NEXT TIME IN ! 19259: EJC ! 19260: * ! 19261: * LISTR (CONTINUED) ! 19262: * ! 19263: * MERGE HERE AFTER PRINTING STATEMENT NUMBER (IF REQUIRED) ! 19264: * ! 19265: LIST2 MOV =STNPD,PROFS POINT PAST STATEMENT NUMBER ! 19266: MOV R$CIM,XR LOAD POINTER TO CURRENT IMAGE ! 19267: JSR PRTST PRINT IT ! 19268: ICV LSTLC BUMP LINE COUNTER ! 19269: BNZ ERLST,LIST3 JUMP IF ERROR COPY TO INT.CH. ! 19270: JSR PRTNL TERMINATE LINE ! 19271: BZE CSWDB,LIST3 JUMP IF -SINGLE MODE ! 19272: JSR PRTNL ELSE ADD A BLANK LINE ! 19273: ICV LSTLC AND BUMP LINE COUNTER ! 19274: * ! 19275: * HERE AFTER PRINTING SOURCE IMAGE ! 19276: * ! 19277: LIST3 MNZ LSTPF SET FLAG FOR LINE PRINTED ! 19278: * ! 19279: * MERGE HERE TO EXIT ! 19280: * ! 19281: LIST4 EXI RETURN TO LISTR CALLER ! 19282: * ! 19283: * PRINT TITLE AFTER -TITLE OR -STITL CARD ! 19284: * ! 19285: LIST5 ZER CNTTL CLEAR FLAG ! 19286: * ! 19287: * EJECT TO NEW PAGE AND LIST TITLE ! 19288: * ! 19289: LIST6 JSR PRTPS EJECT ! 19290: BZE PRICH,LIST7 SKIP IF LISTING TO REGULAR PRINTER ! 19291: BEQ R$TTL,=NULLS,LIST0 TERMINAL LISTING OMITS NULL TITLE ! 19292: * ! 19293: * LIST TITLE ! 19294: * ! 19295: LIST7 JSR LISTT LIST TITLE ! 19296: BRN LIST0 MERGE ! 19297: ENP END PROCEDURE LISTR ! 19298: EJC ! 19299: * ! 19300: * LISTT -- LIST TITLE AND SUBTITLE ! 19301: * ! 19302: * USED DURING COMPILATION TO PRINT PAGE HEADING ! 19303: * ! 19304: * JSR LISTT CALL TO LIST TITLE ! 19305: * (XR,WA) DESTROYED ! 19306: * ! 19307: LISTT PRC E,0 ENTRY POINT ! 19308: MOV R$TTL,XR POINT TO SOURCE LISTING TITLE ! 19309: JSR PRTST PRINT TITLE ! 19310: MOV LSTPO,PROFS SET OFFSET ! 19311: MOV =LSTMS,XR SET PAGE MESSAGE ! 19312: JSR PRTST PRINT PAGE MESSAGE ! 19313: ICV LSTPG BUMP PAGE NUMBER ! 19314: MTI LSTPG LOAD PAGE NUMBER AS INTEGER ! 19315: JSR PRTIN PRINT PAGE NUMBER ! 19316: JSR PRTNL TERMINATE TITLE LINE ! 19317: ADD =NUM02,LSTLC COUNT TITLE LINE AND BLANK LINE ! 19318: * ! 19319: * PRINT SUB-TITLE (IF ANY) ! 19320: * ! 19321: MOV R$STL,XR LOAD POINTER TO SUB-TITLE ! 19322: BZE XR,LSTT1 JUMP IF NO SUB-TITLE ! 19323: JSR PRTST ELSE PRINT SUB-TITLE ! 19324: JSR PRTNL TERMINATE LINE ! 19325: ICV LSTLC BUMP LINE COUNT ! 19326: * ! 19327: * RETURN POINT ! 19328: * ! 19329: LSTT1 JSR PRTNL PRINT A BLANK LINE ! 19330: EXI RETURN TO CALLER ! 19331: ENP END PROCEDURE LISTT ! 19332: EJC ! 19333: * ! 19334: * NEXTS -- ACQUIRE NEXT SOURCE IMAGE ! 19335: * ! 19336: * NEXTS IS USED TO ACQUIRE THE NEXT SOURCE IMAGE AT COMPILE ! 19337: * TIME. IT ASSUMES THAT A PRIOR CALL TO READR HAS INPUT ! 19338: * A LINE IMAGE (SEE PROCEDURE READR). BEFORE THE CURRENT ! 19339: * IMAGE IS FINALLY LOST IT MAY BE LISTED HERE. ! 19340: * ! 19341: * JSR NEXTS CALL TO ACQUIRE NEXT INPUT LINE ! 19342: * (XR,XL,WA,WB,WC) DESTROYED ! 19343: * ! 19344: * GLOBAL VALUES AFFECTED ! 19345: * ! 19346: * R$CNI ON INPUT, NEXT IMAGE. ON ! 19347: * EXIT RESET TO ZERO ! 19348: * ! 19349: * R$CIM ON EXIT, SET TO POINT TO IMAGE ! 19350: * ! 19351: * SCNIL INPUT IMAGE LENGTH ON EXIT ! 19352: * ! 19353: * SCNSE RESET TO ZERO ON EXIT ! 19354: * ! 19355: * LSTPF SET ON EXIT IF LINE IS LISTED ! 19356: * ! 19357: NEXTS PRC E,0 ENTRY POINT ! 19358: BZE CSWLS,NXTS2 JUMP IF -NOLIST ! 19359: MOV R$CIM,XR POINT TO IMAGE ! 19360: BZE XR,NXTS2 JUMP IF NO IMAGE ! 19361: PLC XR GET CHAR PTR ! 19362: LCH WA,(XR) GET FIRST CHAR ! 19363: BNE WA,=CH$MN,NXTS1 JUMP IF NOT CTRL CARD ! 19364: BZE CSWPR,NXTS2 JUMP IF -NOPRINT ! 19365: * ! 19366: * HERE TO CALL LISTER ! 19367: * ! 19368: NXTS1 JSR LISTR LIST LINE ! 19369: * ! 19370: * HERE AFTER POSSIBLE LISTING ! 19371: * ! 19372: NXTS2 MOV R$CNI,XR POINT TO NEXT IMAGE ! 19373: MOV XR,R$CIM SET AS NEXT IMAGE ! 19374: ZER R$CNI CLEAR NEXT IMAGE POINTER ! 19375: MOV SCLEN(XR),WA GET INPUT IMAGE LENGTH ! 19376: MOV CSWIN,WB GET MAX ALLOWABLE LENGTH ! 19377: BLO WA,WB,NXTS3 SKIP IF NOT TOO LONG ! 19378: MOV WB,WA ELSE TRUNCATE ! 19379: * ! 19380: * HERE WITH LENGTH IN (WA) ! 19381: * ! 19382: NXTS3 MOV WA,SCNIL USE AS RECORD LENGTH ! 19383: ZER SCNSE RESET SCNSE ! 19384: ZER LSTPF SET LINE NOT LISTED YET ! 19385: EXI RETURN TO NEXTS CALLER ! 19386: ENP END PROCEDURE NEXTS ! 19387: EJC ! 19388: * ! 19389: * PATIN -- PATTERN CONSTRUCTION FOR LEN,POS,RPOS,TAB,RTAB ! 19390: * ! 19391: * THESE PATTERN TYPES ALL GENERATE A SIMILAR NODE TYPE. SO ! 19392: * THE CONSTRUCTION CODE IS SHARED. SEE FUNCTIONS SECTION ! 19393: * FOR ACTUAL ENTRY POINTS FOR THESE FIVE FUNCTIONS. ! 19394: * ! 19395: * (WA) PCODE FOR EXPRESSION ARG CASE ! 19396: * (WB) PCODE FOR INTEGER ARG CASE ! 19397: * JSR PATIN CALL TO BUILD PATTERN NODE ! 19398: * PPM LOC TRANSFER LOC FOR NOT INTEGER OR EXP ! 19399: * PPM LOC TRANSFER LOC FOR INT OUT OF RANGE ! 19400: * (XR) POINTER TO CONSTRUCTED NODE ! 19401: * (XL,WA,WB,WC,IA) DESTROYED ! 19402: * ! 19403: PATIN PRC N,2 ENTRY POINT ! 19404: MOV WA,XL PRESERVE EXPRESSION ARG PCODE ! 19405: JSR GTSMI TRY TO CONVERT ARG AS SMALL INTEGER ! 19406: PPM PTIN2 JUMP IF NOT INTEGER ! 19407: PPM PTIN3 JUMP IF OUT OF RANGE ! 19408: * ! 19409: * COMMON SUCCESSFUL EXIT POINT ! 19410: * ! 19411: PTIN1 JSR PBILD BUILD PATTERN NODE ! 19412: EXI RETURN TO CALLER ! 19413: * ! 19414: * HERE IF ARGUMENT IS NOT AN INTEGER ! 19415: * ! 19416: PTIN2 MOV XL,WB COPY EXPR ARG CASE PCODE ! 19417: BLO (XR),=B$E$$,PTIN1 ALL OK IF EXPRESSION ARG ! 19418: EXI 1 ELSE TAKE ERROR EXIT FOR WRONG TYPE ! 19419: * ! 19420: * HERE FOR ERROR OF OUT OF RANGE INTEGER ARGUMENT ! 19421: * ! 19422: PTIN3 EXI 2 TAKE OUT-OF-RANGE ERROR EXIT ! 19423: ENP END PROCEDURE PATIN ! 19424: EJC ! 19425: * ! 19426: * PATST -- PATTERN CONSTRUCTION FOR ANY,NOTANY, ! 19427: * BREAK,SPAN AND BREAKX PATTERN FUNCTIONS. ! 19428: * ! 19429: * THESE PATTERN FUNCTIONS BUILD SIMILAR TYPES OF NODES AND ! 19430: * THE CONSTRUCTION CODE IS SHARED. SEE FUNCTIONS SECTION ! 19431: * FOR ACTUAL ENTRY POINTS FOR THESE FIVE PATTERN FUNCTIONS. ! 19432: * ! 19433: * 0(XS) STRING ARGUMENT ! 19434: * (WB) PCODE FOR ONE CHAR ARGUMENT ! 19435: * (XL) PCODE FOR MULTI-CHAR ARGUMENT ! 19436: * (WC) PCODE FOR EXPRESSION ARGUMENT ! 19437: * JSR PATST CALL TO BUILD NODE ! 19438: * PPM LOC TRANSFER LOC IF NOT STRING OR EXPR ! 19439: * (XS) POPPED PAST STRING ARGUMENT ! 19440: * (XR) POINTER TO CONSTRUCTED NODE ! 19441: * (XL) DESTROYED ! 19442: * (WA,WB,WC,RA) DESTROYED ! 19443: * ! 19444: * NOTE THAT THERE IS A SPECIAL CALL TO PATST IN THE EVALS ! 19445: * PROCEDURE WITH A SLIGHTLY DIFFERENT FORM. SEE EVALS ! 19446: * FOR DETAILS OF THE FORM OF THIS CALL. ! 19447: * ! 19448: PATST PRC N,1 ENTRY POINT ! 19449: JSR GTSTG CONVERT ARGUMENT AS STRING ! 19450: PPM PATS7 JUMP IF NOT STRING ! 19451: BNE WA,=NUM01,PATS2 JUMP IF NOT ONE CHAR STRING ! 19452: * ! 19453: * HERE FOR ONE CHAR STRING CASE ! 19454: * ! 19455: BZE WB,PATS2 TREAT AS MULTI-CHAR IF EVALS CALL ! 19456: PLC XR POINT TO CHARACTER ! 19457: LCH XR,(XR) LOAD CHARACTER ! 19458: * ! 19459: * COMMON EXIT POINT AFTER SUCCESSFUL CONSTRUCTION ! 19460: * ! 19461: PATS1 JSR PBILD CALL ROUTINE TO BUILD NODE ! 19462: EXI RETURN TO PATST CALLER ! 19463: EJC ! 19464: * ! 19465: * PATST (CONTINUED) ! 19466: * ! 19467: * HERE FOR MULTI-CHARACTER STRING CASE ! 19468: * ! 19469: PATS2 MOV XL,-(XS) SAVE MULTI-CHAR PCODE ! 19470: MOV XR,-(XS) SAVE STRING POINTER ! 19471: MOV CTMSK,WC LOAD CURRENT MASK BIT ! 19472: LSH WC,1 SHIFT TO NEXT POSITION ! 19473: NZB WC,PATS4 SKIP IF POSITION LEFT IN THIS TBL ! 19474: * ! 19475: * HERE WE MUST ALLOCATE A NEW CHARACTER TABLE ! 19476: * ! 19477: MOV *CTSI$,WA SET SIZE OF CTBLK ! 19478: JSR ALLOC ALLOCATE CTBLK ! 19479: MOV XR,R$CTP STORE PTR TO NEW CTBLK ! 19480: MOV =B$CTT,(XR)+ STORE TYPE CODE, BUMP PTR ! 19481: LCT WB,=CFP$A SET NUMBER OF WORDS TO CLEAR ! 19482: MOV BITS0,WC LOAD ALL ZERO BITS ! 19483: * ! 19484: * LOOP TO CLEAR ALL BITS IN TABLE TO ZEROS ! 19485: * ! 19486: PATS3 MOV WC,(XR)+ MOVE WORD OF ZERO BITS ! 19487: BCT WB,PATS3 LOOP TILL ALL CLEARED ! 19488: MOV BITS1,WC SET INITIAL BIT POSITION ! 19489: * ! 19490: * MERGE HERE WITH BIT POSITION AVAILABLE ! 19491: * ! 19492: PATS4 MOV WC,CTMSK SAVE PARM2 (NEW BIT POSITION) ! 19493: MOV (XS)+,XL RESTORE POINTER TO ARGUMENT STRING ! 19494: MOV SCLEN(XL),WB LOAD STRING LENGTH ! 19495: BZE WB,PATS6 JUMP IF NULL STRING CASE ! 19496: LCT WB,WB ELSE SET LOOP COUNTER ! 19497: PLC XL POINT TO CHARACTERS IN ARGUMENT ! 19498: EJC ! 19499: * ! 19500: * PATST (CONTINUED) ! 19501: * ! 19502: * LOOP TO SET BITS IN COLUMN OF TABLE ! 19503: * ! 19504: PATS5 LCH WA,(XL)+ LOAD NEXT CHARACTER ! 19505: WTB WA CONVERT TO BYTE OFFSET ! 19506: MOV R$CTP,XR POINT TO CTBLK ! 19507: ADD WA,XR POINT TO CTBLK ENTRY ! 19508: MOV WC,WA COPY BIT MASK ! 19509: ORB CTCHS(XR),WA OR IN BITS ALREADY SET ! 19510: MOV WA,CTCHS(XR) STORE RESULTING BIT STRING ! 19511: BCT WB,PATS5 LOOP TILL ALL BITS SET ! 19512: * ! 19513: * COMPLETE PROCESSING FOR MUTI-CHAR STRING CASE ! 19514: * ! 19515: PATS6 MOV R$CTP,XR LOAD CTBLK PTR AS PARM1 FOR PBILD ! 19516: ZER XL CLEAR GARBAGE PTR IN XL ! 19517: MOV (XS)+,WB LOAD PCODE FOR MULTI-CHAR STR CASE ! 19518: BRN PATS1 BACK TO EXIT (WC=BITSTRING=PARM2) ! 19519: * ! 19520: * HERE IF ARGUMENT IS NOT A STRING ! 19521: * ! 19522: * NOTE THAT THE CALL FROM EVALS CANNOT PASS AN EXPRESSION ! 19523: * SINCE EVALP ALWAYS REEVALUATES EXPRESSIONS. ! 19524: * ! 19525: PATS7 MOV WC,WB SET PCODE FOR EXPRESSION ARGUMENT ! 19526: BLO (XR),=B$E$$,PATS1 JUMP TO EXIT IF EXPRESSION ARG ! 19527: EXI 1 ELSE TAKE WRONG TYPE ERROR EXIT ! 19528: ENP END PROCEDURE PATST ! 19529: EJC ! 19530: * ! 19531: * PBILD -- BUILD PATTERN NODE ! 19532: * ! 19533: * (XR) PARM1 (ONLY IF REQUIRED) ! 19534: * (WB) PCODE FOR NODE ! 19535: * (WC) PARM2 (ONLY IF REQUIRED) ! 19536: * JSR PBILD CALL TO BUILD NODE ! 19537: * (XR) POINTER TO CONSTRUCTED NODE ! 19538: * (WA) DESTROYED ! 19539: * ! 19540: PBILD PRC E,0 ENTRY POINT ! 19541: MOV XR,-(XS) STACK POSSIBLE PARM1 ! 19542: MOV WB,XR COPY PCODE ! 19543: LEI XR LOAD ENTRY POINT ID (BL$PX) ! 19544: BEQ XR,=BL$P1,PBLD1 JUMP IF ONE PARAMETER ! 19545: BEQ XR,=BL$P0,PBLD3 JUMP IF NO PARAMETERS ! 19546: * ! 19547: * HERE FOR TWO PARAMETER CASE ! 19548: * ! 19549: MOV *PCSI$,WA SET SIZE OF P2BLK ! 19550: JSR ALLOC ALLOCATE BLOCK ! 19551: MOV WC,PARM2(XR) STORE SECOND PARAMETER ! 19552: BRN PBLD2 MERGE WITH ONE PARM CASE ! 19553: * ! 19554: * HERE FOR ONE PARAMETER CASE ! 19555: * ! 19556: PBLD1 MOV *PBSI$,WA SET SIZE OF P1BLK ! 19557: JSR ALLOC ALLOCATE NODE ! 19558: * ! 19559: * MERGE HERE FROM TWO PARM CASE ! 19560: * ! 19561: PBLD2 MOV (XS),PARM1(XR) STORE FIRST PARAMETER ! 19562: BRN PBLD4 MERGE WITH NO PARAMETER CASE ! 19563: * ! 19564: * HERE FOR CASE OF NO PARAMETERS ! 19565: * ! 19566: PBLD3 MOV *PASI$,WA SET SIZE OF P0BLK ! 19567: JSR ALLOC ALLOCATE NODE ! 19568: * ! 19569: * MERGE HERE FROM OTHER CASES ! 19570: * ! 19571: PBLD4 MOV WB,(XR) STORE PCODE ! 19572: ICA XS POP FIRST PARAMETER ! 19573: MOV =NDNTH,PTHEN(XR) SET NOTHEN SUCCESSOR POINTER ! 19574: EXI RETURN TO PBILD CALLER ! 19575: ENP END PROCEDURE PBILD ! 19576: EJC ! 19577: * ! 19578: * PCONC -- CONCATENATE TWO PATTERNS ! 19579: * ! 19580: * (XL) PTR TO RIGHT PATTERN ! 19581: * (XR) PTR TO LEFT PATTERN ! 19582: * JSR PCONC CALL TO CONCATENATE PATTERNS ! 19583: * (XR) PTR TO CONCATENATED PATTERN ! 19584: * (XL,WA,WB,WC) DESTROYED ! 19585: * ! 19586: * ! 19587: * TO CONCATENATE TWO PATTERNS, ALL SUCCESSORS IN THE LEFT ! 19588: * PATTERN WHICH POINT TO THE NOTHEN NODE MUST BE CHANGED TO ! 19589: * POINT TO THE RIGHT PATTERN. HOWEVER, THIS MODIFICATION ! 19590: * MUST BE PERFORMED ON A COPY OF THE LEFT ARGUMENT RATHER ! 19591: * THAN THE LEFT ARGUMENT ITSELF, SINCE THE LEFT ARGUMENT ! 19592: * MAY BE POINTED TO BY SOME OTHER VARIABLE VALUE. ! 19593: * ! 19594: * ACCORDINGLY, IT IS NECESSARY TO COPY THE LEFT ARGUMENT. ! 19595: * THIS IS NOT A TRIVIAL PROCESS SINCE WE MUST AVOID COPYING ! 19596: * NODES MORE THAN ONCE AND THE PATTERN IS A GRAPH STRUCTURE ! 19597: * THE FOLLOWING ALGORITHM IS EMPLOYED. ! 19598: * ! 19599: * THE STACK IS USED TO STORE A LIST OF NODES WHICH ! 19600: * HAVE ALREADY BEEN COPIED. THE FORMAT OF THE ENTRIES ON ! 19601: * THIS LIST CONSISTS OF A TWO WORD BLOCK. THE FIRST WORD ! 19602: * IS THE OLD ADDRESS AND THE SECOND WORD IS THE ADDRESS ! 19603: * OF THE COPY. THIS LIST IS SEARCHED BY THE PCOPY ! 19604: * ROUTINE TO AVOID MAKING DUPLICATE COPIES. A TRICK IS ! 19605: * USED TO ACCOMPLISH THE CONCATENATION AT THE SAME TIME. ! 19606: * A SPECIAL ENTRY IS MADE TO START WITH ON THE STACK. THIS ! 19607: * ENTRY RECORDS THAT THE NOTHEN NODE HAS BEEN COPIED ! 19608: * ALREADY AND THE ADDRESS OF ITS COPY IS THE RIGHT PATTERN. ! 19609: * THIS AUTOMATICALLY PERFORMS THE CORRECT REPLACEMENTS. ! 19610: * ! 19611: PCONC PRC E,0 ENTRY POINT ! 19612: ZER -(XS) MAKE ROOM FOR ONE ENTRY AT BOTTOM ! 19613: MOV XS,WC STORE POINTER TO START OF LIST ! 19614: MOV =NDNTH,-(XS) STACK NOTHEN NODE AS OLD NODE ! 19615: MOV XL,-(XS) STORE RIGHT ARG AS COPY OF NOTHEN ! 19616: MOV XS,XT INITIALIZE POINTER TO STACK ENTRIES ! 19617: JSR PCOPY COPY FIRST NODE OF LEFT ARG ! 19618: MOV WA,2(XT) STORE AS RESULT UNDER LIST ! 19619: EJC ! 19620: * ! 19621: * PCONC (CONTINUED) ! 19622: * ! 19623: * THE FOLLOWING LOOP SCANS ENTRIES IN THE LIST AND MAKES ! 19624: * SURE THAT THEIR SUCCESSORS HAVE BEEN COPIED. ! 19625: * ! 19626: PCNC1 BEQ XT,XS,PCNC2 JUMP IF ALL ENTRIES PROCESSED ! 19627: MOV -(XT),XR ELSE LOAD NEXT OLD ADDRESS ! 19628: MOV PTHEN(XR),XR LOAD POINTER TO SUCCESSOR ! 19629: JSR PCOPY COPY SUCCESSOR NODE ! 19630: MOV -(XT),XR LOAD POINTER TO NEW NODE (COPY) ! 19631: MOV WA,PTHEN(XR) STORE PTR TO NEW SUCCESSOR ! 19632: * ! 19633: * NOW CHECK FOR SPECIAL CASE OF ALTERNATION NODE WHERE ! 19634: * PARM1 POINTS TO A NODE AND MUST BE COPIED LIKE PTHEN. ! 19635: * ! 19636: BNE (XR),=P$ALT,PCNC1 LOOP BACK IF NOT ! 19637: MOV PARM1(XR),XR ELSE LOAD POINTER TO ALTERNATIVE ! 19638: JSR PCOPY COPY IT ! 19639: MOV (XT),XR RESTORE PTR TO NEW NODE ! 19640: MOV WA,PARM1(XR) STORE PTR TO COPIED ALTERNATIVE ! 19641: BRN PCNC1 LOOP BACK FOR NEXT ENTRY ! 19642: * ! 19643: * HERE AT END OF COPY PROCESS ! 19644: * ! 19645: PCNC2 MOV WC,XS RESTORE STACK POINTER ! 19646: MOV (XS)+,XR LOAD POINTER TO COPY ! 19647: EXI RETURN TO PCONC CALLER ! 19648: ENP END PROCEDURE PCONC ! 19649: EJC ! 19650: * ! 19651: * PCOPY -- COPY A PATTERN NODE ! 19652: * ! 19653: * PCOPY IS CALLED FROM THE PCONC PROCEDURE TO COPY A SINGLE ! 19654: * PATTERN NODE. THE COPY IS ONLY CARRIED OUT IF THE NODE ! 19655: * HAS NOT BEEN COPIED ALREADY. ! 19656: * ! 19657: * (XR) POINTER TO NODE TO BE COPIED ! 19658: * (XT) PTR TO CURRENT LOC IN COPY LIST ! 19659: * (WC) POINTER TO LIST OF COPIED NODES ! 19660: * JSR PCOPY CALL TO COPY A NODE ! 19661: * (WA) POINTER TO COPY ! 19662: * (WB,XR) DESTROYED ! 19663: * ! 19664: PCOPY PRC N,0 ENTRY POINT ! 19665: MOV XT,WB SAVE XT ! 19666: MOV WC,XT POINT TO START OF LIST ! 19667: * ! 19668: * LOOP TO SEARCH LIST OF NODES COPIED ALREADY ! 19669: * ! 19670: PCOP1 DCA XT POINT TO NEXT ENTRY ON LIST ! 19671: BEQ XR,(XT),PCOP2 JUMP IF MATCH ! 19672: DCA XT ELSE SKIP OVER COPIED ADDRESS ! 19673: BNE XT,XS,PCOP1 LOOP BACK IF MORE TO TEST ! 19674: * ! 19675: * HERE IF NOT IN LIST, PERFORM COPY ! 19676: * ! 19677: MOV (XR),WA LOAD FIRST WORD OF BLOCK ! 19678: JSR BLKLN GET LENGTH OF BLOCK ! 19679: MOV XR,XL SAVE POINTER TO OLD NODE ! 19680: JSR ALLOC ALLOCATE SPACE FOR COPY ! 19681: MOV XL,-(XS) STORE OLD ADDRESS ON LIST ! 19682: MOV XR,-(XS) STORE NEW ADDRESS ON LIST ! 19683: CHK CHECK FOR STACK OVERFLOW ! 19684: MVW MOVE WORDS FROM OLD BLOCK TO COPY ! 19685: MOV (XS),WA LOAD POINTER TO COPY ! 19686: BRN PCOP3 JUMP TO EXIT ! 19687: * ! 19688: * HERE IF WE FIND ENTRY IN LIST ! 19689: * ! 19690: PCOP2 MOV -(XT),WA LOAD ADDRESS OF COPY FROM LIST ! 19691: * ! 19692: * COMMON EXIT POINT ! 19693: * ! 19694: PCOP3 MOV WB,XT RESTORE XT ! 19695: EXI RETURN TO PCOPY CALLER ! 19696: ENP END PROCEDURE PCOPY ! 19697: EJC ! 19698: .IF .CNPF ! 19699: .ELSE ! 19700: * ! 19701: * PRFLR -- PRINT PROFILE ! 19702: * PRFLR IS CALLED TO PRINT THE CONTENTS OF THE PROFILE ! 19703: * TABLE IN A FAIRLY READABLE TABULAR FORMAT. ! 19704: * ! 19705: * JSR PRFLR CALL TO PRINT PROFILE ! 19706: * (WA,IA) DESTROYED ! 19707: * ! 19708: PRFLR PRC E,0 ! 19709: BZE PFDMP,PRFL4 NO PRINTING IF NO PROFILING DONE ! 19710: MOV XR,-(XS) PRESERVE ENTRY XR ! 19711: MOV WB,PFSVW AND ALSO WB ! 19712: JSR PRTPG EJECT ! 19713: MOV =PFMS1,XR LOAD MSG /PROGRAM PROFILE/ ! 19714: JSR PRTST AND PRINT IT ! 19715: JSR PRTNL FOLLOWED BY NEWLINE ! 19716: JSR PRTNL AND ANOTHER ! 19717: MOV =PFMS2,XR POINT TO FIRST HDR ! 19718: JSR PRTST PRINT IT ! 19719: JSR PRTNL NEW LINE ! 19720: MOV =PFMS3,XR SECOND HDR ! 19721: JSR PRTST PRINT IT ! 19722: JSR PRTNL NEW LINE ! 19723: JSR PRTNL AND ANOTHER BLANK LINE ! 19724: ZER WB INITIAL STMT COUNT ! 19725: MOV PFTBL,XR POINT TO TABLE ORIGIN ! 19726: ADD *NUM02,XR BIAS PAST XNBLK HEADER (SGD07) ! 19727: * ! 19728: * LOOP HERE TO PRINT SUCCESSIVE ENTRIES ! 19729: * ! 19730: PRFL1 ICV WB BUMP STMT NR ! 19731: LDI (XR) LOAD NR OF EXECUTIONS ! 19732: IEQ PRFL3 NO PRINTING IF ZERO ! 19733: MOV =PFPD1,PROFS POINT WHERE TO PRINT ! 19734: JSR PRTIN AND PRINT IT ! 19735: ZER PROFS BACK TO START OF LINE ! 19736: MTI WB LOAD STMT NR ! 19737: JSR PRTIN PRINT IT THERE ! 19738: MOV =PFPD2,PROFS AND PAD PAST COUNT ! 19739: LDI CFP$I(XR) LOAD TOTAL EXEC TIME ! 19740: JSR PRTIN PRINT THAT TOO ! 19741: LDI CFP$I(XR) RELOAD TIME ! 19742: MLI INTTH CONVERT TO MICROSEC ! 19743: IOV PRFL2 OMIT NEXT BIT IF OVERFLOW ! 19744: DVI (XR) DIVIDE BY EXECUTIONS ! 19745: MOV =PFPD3,PROFS PAD LAST PRINT ! 19746: JSR PRTIN AND PRINT MCSEC/EXECN ! 19747: * ! 19748: * MERGE AFTER PRINTING TIME ! 19749: * ! 19750: PRFL2 JSR PRTNL THATS ANOTHER LINE ! 19751: * ! 19752: * HERE TO GO TO NEXT ENTRY ! 19753: * ! 19754: PRFL3 ADD *PF$I2,XR BUMP INDEX PTR (SGD07) ! 19755: BLT WB,PFNTE,PRFL1 LOOP IF MORE STMTS ! 19756: MOV (XS)+,XR RESTORE CALLERS XR ! 19757: MOV PFSVW,WB AND WB TOO ! 19758: * ! 19759: * HERE TO EXIT ! 19760: * ! 19761: PRFL4 EXI RETURN ! 19762: ENP END OF PRFLR ! 19763: EJC ! 19764: * ! 19765: * PRFLU -- UPDATE AN ENTRY IN THE PROFILE TABLE ! 19766: * ! 19767: * ON ENTRY, KVSTN CONTAINS NR OF STMT TO PROFILE ! 19768: * ! 19769: * JSR PRFLU CALL TO UPDATE ENTRY ! 19770: * (IA) DESTROYED ! 19771: * ! 19772: PRFLU PRC E,0 ! 19773: BNZ PFFNC,PFLU4 SKIP IF JUST ENTERED FUNCTION ! 19774: MOV XR,-(XS) PRESERVE ENTRY XR ! 19775: MOV WA,PFSVW SAVE WA (SGD07) ! 19776: BNZ PFTBL,PFLU2 BRANCH IF TABLE ALLOCATED ! 19777: * ! 19778: * HERE IF SPACE FOR PROFILE TABLE NOT YET ALLOCATED. ! 19779: * CALCULATE SIZE NEEDED, ALLOCATE A STATIC XNBLK, AND ! 19780: * INITIALIZE IT ALL TO ZERO. ! 19781: * THE TIME TAKEN FOR THIS WILL BE ATTRIBUTED TO THE CURRENT ! 19782: * STATEMENT (ASSIGNMENT TO KEYWD PROFILE), BUT SINCE THE ! 19783: * TIMING FOR THIS STATEMENT IS UP THE POLE ANYWAY, THIS ! 19784: * DOESNT REALLY MATTER... ! 19785: * ! 19786: SUB =NUM01,PFNTE ADJUST FOR EXTRA COUNT (SGD07) ! 19787: MTI PFI2A CONVRT ENTRY SIZE TO INT ! 19788: STI PFSTE AND STORE SAFELY FOR LATER ! 19789: MTI PFNTE LOAD TABLE LENGTH AS INTEGER ! 19790: MLI PFSTE MULTIPLY BY ENTRY SIZE ! 19791: MFI WA GET BACK ADDRESS-STYLE ! 19792: ADD =NUM02,WA ADD ON 2 WORD OVERHEAD ! 19793: WTB WA CONVERT THE WHOLE LOT TO BYTES ! 19794: JSR ALOST GIMME THE SPACE ! 19795: MOV XR,PFTBL SAVE BLOCK POINTER ! 19796: MOV =B$XNT,(XR)+ PUT BLOCK TYPE AND ... ! 19797: MOV WA,(XR)+ ... LENGTH INTO HEADER ! 19798: MFI WA GET BACK NR OF WDS IN DATA AREA ! 19799: LCT WA,WA LOAD THE COUNTER ! 19800: * ! 19801: * LOOP HERE TO ZERO THE BLOCK DATA ! 19802: * ! 19803: PFLU1 ZER (XR)+ BLANK A WORD ! 19804: BCT WA,PFLU1 AND ALLLLLLL THE REST ! 19805: * ! 19806: * END OF ALLOCATION. MERGE BACK INTO ROUTINE ! 19807: * ! 19808: PFLU2 MTI KVSTN LOAD NR OF STMT JUST ENDED ! 19809: SBI INTV1 MAKE INTO INDEX OFFSET ! 19810: MLI PFSTE MAKE OFFSET OF TABLE ENTRY ! 19811: MFI WA CONVERT TO ADDRESS ! 19812: WTB WA GET AS BAUS ! 19813: ADD *NUM02,WA OFFSET INCLUDES TABLE HEADER ! 19814: MOV PFTBL,XR GET TABLE START ! 19815: BGE WA,NUM01(XR),PFLU3 IF OUT OF TABLE, SKIP IT ! 19816: ADD WA,XR ELSE POINT TO ENTRY ! 19817: LDI (XR) GET NR OF EXECUTIONS SO FAR ! 19818: ADI INTV1 NUDGE UP ONE ! 19819: STI (XR) AND PUT BACK ! 19820: JSR SYSTM GET TIME NOW ! 19821: STI PFETM STASH ENDING TIME ! 19822: SBI PFSTM SUBTRACT START TIME ! 19823: ADI CFP$I(XR) ADD CUMULATIVE TIME SO FAR ! 19824: STI CFP$I(XR) AND PUT BACK NEW TOTAL ! 19825: LDI PFETM LOAD END TIME OF THIS STMT ... ! 19826: STI PFSTM ... WHICH IS START TIME OF NEXT ! 19827: * ! 19828: * MERGE HERE TO EXIT ! 19829: * ! 19830: PFLU3 MOV (XS)+,XR RESTORE CALLERS XR ! 19831: MOV PFSVW,WA RESTORE SAVED REG ! 19832: EXI AND RETURN ! 19833: * ! 19834: * HERE IF PROFILE IS SUPPRESSED BECAUSE A PROGRAM DEFINED ! 19835: * FUNCTION IS ABOUT TO BE ENTERED, AND SO THE CURRENT STMT ! 19836: * HAS NOT YET FINISHED ! 19837: * ! 19838: PFLU4 ZER PFFNC RESET THE CONDITION FLAG ! 19839: EXI AND IMMEDIATE RETURN ! 19840: ENP END OF PROCEDURE PRFLU ! 19841: EJC ! 19842: .FI ! 19843: * ! 19844: * PRPAR - PROCESS PRINT PARAMETERS ! 19845: * ! 19846: * (WC) IF NONZERO ASSOCIATE TERMINAL ONLY ! 19847: * JSR PRPAR CALL TO PROCESS PRINT PARAMETERS ! 19848: * (XL,XR,WA,WB,WC) DESTROYED ! 19849: * ! 19850: * SINCE MEMORY ALLOCATION IS UNDECIDED ON INITIAL CALL, ! 19851: * TERMINAL CANNOT BE ASSOCIATED. THE ENTRY WITH WC NON-ZERO ! 19852: * IS PROVIDED SO A LATER CALL CAN BE MADE TO COMPLETE THIS. ! 19853: * ! 19854: PRPAR PRC E,0 ENTRY POINT ! 19855: BNZ WC,PRPA7 JUMP TO ASSOCIATE TERMINAL ! 19856: JSR SYSPP GET PRINT PARAMETERS ! 19857: BNZ WB,PRPA1 JUMP IF LINES/PAGE SPECIFIED ! 19858: MOV =CFP$M,WB ELSE USE A LARGE VALUE ! 19859: RSH WB,1 BUT NOT TOO LARGE ! 19860: * ! 19861: * STORE LINE COUNT/PAGE ! 19862: * ! 19863: PRPA1 MOV WB,LSTNP STORE NUMBER OF LINES/PAGE ! 19864: MOV WB,LSTLC PRETEND PAGE IS FULL INITIALLY ! 19865: ZER LSTPG CLEAR PAGE NUMBER ! 19866: MOV PRLEN,WB GET PRIOR LENGTH IF ANY ! 19867: BZE WB,PRPA2 SKIP IF NO LENGTH ! 19868: BGT WA,WB,PRPA3 SKIP STORING IF TOO BIG ! 19869: * ! 19870: * STORE PRINT BUFFER LENGTH ! 19871: * ! 19872: PRPA2 MOV WA,PRLEN STORE VALUE ! 19873: * ! 19874: * PROCESS BITS OPTIONS ! 19875: * ! 19876: PRPA3 MOV BITS3,WB BIT 3 MASK ! 19877: ANB WC,WB GET -NOLIST BIT ! 19878: ZRB WB,PRPA4 SKIP IF CLEAR ! 19879: ZER CSWLS SET -NOLIST ! 19880: * ! 19881: * CHECK IF FAIL REPORTS GOTO INTERACTIVE CHANNEL ! 19882: * ! 19883: PRPA4 MOV BITS1,WB BIT 1 MASK ! 19884: ANB WC,WB GET BIT ! 19885: MOV WB,ERICH STORE INT. CHAN. ERROR FLAG ! 19886: MOV BITS2,WB BIT 2 MASK ! 19887: ANB WC,WB GET BIT ! 19888: MOV WB,PRICH FLAG FOR STD PRINTER ON INT. CHAN. ! 19889: MOV BITS4,WB BIT 4 MASK ! 19890: ANB WC,WB GET BIT ! 19891: MOV WB,CPSTS FLAG FOR COMPILE STATS SUPPRESSN. ! 19892: MOV BITS5,WB BIT 5 MASK ! 19893: ANB WC,WB GET BIT ! 19894: MOV WB,EXSTS FLAG FOR EXEC STATS SUPPRESSION ! 19895: EJC ! 19896: * ! 19897: * PRPAR (CONTINUED) ! 19898: * ! 19899: MOV BITS6,WB BIT 6 MASK ! 19900: ANB WC,WB GET BIT ! 19901: MOV WB,PRECL EXTENDED/COMPACT LISTING FLAG ! 19902: SUB =NUM08,WA POINT 8 CHARS FROM LINE END ! 19903: ZRB WB,PRPA5 JUMP IF NOT EXTENDED ! 19904: MOV WA,LSTPO STORE FOR LISTING PAGE HEADINGS ! 19905: * ! 19906: * CONTINUE OPTION PROCESSING ! 19907: * ! 19908: PRPA5 MOV BITS7,WB BIT 7 MASK ! 19909: ANB WC,WB GET BIT 7 ! 19910: MOV WB,CSWEX SET -NOEXECUTE IF NON-ZERO ! 19911: MOV BIT10,WB BIT 10 MASK ! 19912: ANB WC,WB GET BIT 10 ! 19913: MOV WB,HEADP PRETEND PRINTED TO OMIT HEADERS ! 19914: MOV BITS9,WB BIT 9 MASK ! 19915: ANB WC,WB GET BIT 9 ! 19916: MOV WB,PRSTO KEEP IT AS STD LISTING OPTION ! 19917: ZRB WB,PRPA6 SKIP IF CLEAR ! 19918: MOV PRLEN,WA GET PRINT BUFFER LENGTH ! 19919: SUB =NUM08,WA POINT 8 CHARS FROM LINE END ! 19920: MOV WA,LSTPO STORE PAGE OFFSET ! 19921: * ! 19922: * CHECK FOR TERMINAL ! 19923: * ! 19924: PRPA6 ANB BITS8,WC SEE IF TERMINAL TO BE ACTIVATED ! 19925: BNZ WC,PRPA7 JUMP IF TERMINAL REQUIRED ! 19926: BZE INITR,PRPA8 JUMP IF NO TERMINAL TO DETACH ! 19927: MOV =V$TER,XL PTR TO /TERMINAL/ ! 19928: JSR GTNVR GET VRBLK POINTER ! 19929: PPM CANT FAIL ! 19930: MOV =NULLS,VRVAL(XR) CLEAR VALUE OF TERMINAL ! 19931: JSR SETVR REMOVE ASSOCIATION ! 19932: BRN PRPA8 RETURN ! 19933: * ! 19934: * ASSOCIATE TERMINAL ! 19935: * ! 19936: PRPA7 MNZ INITR NOTE TERMINAL ASSOCIATED ! 19937: BZE DNAMB,PRPA8 CANT IF MEMORY NOT ORGANISED ! 19938: MOV =V$TER,XL POINT TO TERMINAL STRING ! 19939: MOV =TRTOU,WB OUTPUT TRACE TYPE ! 19940: JSR INOUT ATTACH OUTPUT TRBLK TO VRBLK ! 19941: MOV XR,-(XS) STACK TRBLK PTR ! 19942: MOV =V$TER,XL POINT TO TERMINAL STRING ! 19943: MOV =TRTIN,WB INPUT TRACE TYPE ! 19944: JSR INOUT ATTACH INPUT TRACE BLK ! 19945: MOV (XS)+,VRVAL(XR) ADD OUTPUT TRBLK TO CHAIN ! 19946: * ! 19947: * RETURN POINT ! 19948: * ! 19949: PRPA8 EXI RETURN ! 19950: ENP END PROCEDURE PRPAR ! 19951: EJC ! 19952: * ! 19953: * PRTCH -- PRINT A CHARACTER ! 19954: * ! 19955: * PRTCH IS USED TO PRINT A SINGLE CHARACTER ! 19956: * ! 19957: * (WA) CHARACTER TO BE PRINTED ! 19958: * JSR PRTCH CALL TO PRINT CHARACTER ! 19959: * ! 19960: PRTCH PRC E,0 ENTRY POINT ! 19961: MOV XR,-(XS) SAVE XR ! 19962: BNE PROFS,PRLEN,PRCH1 JUMP IF ROOM IN BUFFER ! 19963: JSR PRTNL ELSE PRINT THIS LINE ! 19964: * ! 19965: * HERE AFTER MAKING SURE WE HAVE ROOM ! 19966: * ! 19967: PRCH1 MOV PRBUF,XR POINT TO PRINT BUFFER ! 19968: PSC XR,PROFS POINT TO NEXT CHARACTER LOCATION ! 19969: SCH WA,(XR) STORE NEW CHARACTER ! 19970: CSC XR COMPLETE STORE CHARACTERS ! 19971: ICV PROFS BUMP POINTER ! 19972: MOV (XS)+,XR RESTORE ENTRY XR ! 19973: EXI RETURN TO PRTCH CALLER ! 19974: ENP END PROCEDURE PRTCH ! 19975: EJC ! 19976: * ! 19977: * PRTIC -- PRINT TO INTERACTIVE CHANNEL ! 19978: * ! 19979: * PRTIC IS CALLED TO PRINT THE CONTENTS OF THE STANDARD ! 19980: * PRINT BUFFER TO THE INTERACTIVE CHANNEL. IT IS ONLY ! 19981: * CALLED AFTER PRTST HAS SET UP THE STRING FOR PRINTING. ! 19982: * IT DOES NOT CLEAR THE BUFFER. ! 19983: * ! 19984: * JSR PRTIC CALL FOR PRINT ! 19985: * (WA,WB) DESTROYED ! 19986: * ! 19987: PRTIC PRC E,0 ENTRY POINT ! 19988: MOV XR,-(XS) SAVE XR ! 19989: MOV PRBUF,XR POINT TO BUFFER ! 19990: MOV PROFS,WA NO OF CHARS ! 19991: JSR SYSPI PRINT ! 19992: PPM PRTC2 FAIL RETURN ! 19993: * ! 19994: * RETURN ! 19995: * ! 19996: PRTC1 MOV (XS)+,XR RESTORE XR ! 19997: EXI RETURN ! 19998: * ! 19999: * ERROR OCCURED ! 20000: * ! 20001: PRTC2 ZER ERICH PREVENT LOOPING ! 20002: ERB 252,ERROR ON PRINTING TO INTERACTIVE CHANNEL ! 20003: BRN PRTC1 RETURN ! 20004: ENP PROCEDURE PRTIC ! 20005: EJC ! 20006: * ! 20007: * PRTIS -- PRINT TO INTERACTIVE AND STANDARD PRINTER ! 20008: * ! 20009: * PRTIS PUTS A LINE FROM THE PRINT BUFFER ONTO THE ! 20010: * INTERACTIVE CHANNEL (IF ANY) AND THE STANDARD PRINTER. ! 20011: * IT ALWAYS PRINTS TO THE STANDARD PRINTER BUT DOES ! 20012: * NOT DUPLICATE LINES IF THE STANDARD PRINTER IS ! 20013: * INTERACTIVE. IT CLEARS DOWN THE PRINT BUFFER. ! 20014: * ! 20015: * JSR PRTIS CALL FOR PRINTING ! 20016: * (WA,WB) DESTROYED ! 20017: * ! 20018: PRTIS PRC E,0 ENTRY POINT ! 20019: BNZ PRICH,PRTS1 JUMP IF STANDARD PRINTER IS INT.CH. ! 20020: BZE ERICH,PRTS1 SKIP IF NOT DOING INT. ERROR REPS. ! 20021: JSR PRTIC PRINT TO INTERACTIVE CHANNEL ! 20022: * ! 20023: * MERGE AND EXIT ! 20024: * ! 20025: PRTS1 JSR PRTNL PRINT TO STANDARD PRINTER ! 20026: EXI RETURN ! 20027: ENP END PROCEDURE PRTIS ! 20028: EJC ! 20029: * ! 20030: * PRTIN -- PRINT AN INTEGER ! 20031: * ! 20032: * PRTIN PRINTS THE INTEGER VALUE WHICH IS IN THE INTEGER ! 20033: * ACCUMULATOR. BLOCKS BUILT IN DYNAMIC STORAGE ! 20034: * DURING THIS PROCESS ARE IMMEDIATELY DELETED. ! 20035: * ! 20036: * (IA) INTEGER VALUE TO BE PRINTED ! 20037: * JSR PRTIN CALL TO PRINT INTEGER ! 20038: * (IA,RA) DESTROYED ! 20039: * ! 20040: PRTIN PRC E,0 ENTRY POINT ! 20041: MOV XR,-(XS) SAVE XR ! 20042: JSR ICBLD BUILD INTEGER BLOCK ! 20043: BLO XR,DNAMB,PRTI1 JUMP IF ICBLK BELOW DYNAMIC ! 20044: BHI XR,DNAMP,PRTI1 JUMP IF ABOVE DYNAMIC ! 20045: MOV XR,DNAMP IMMEDIATELY DELETE IT ! 20046: * ! 20047: * DELETE ICBLK FROM DYNAMIC STORE ! 20048: * ! 20049: PRTI1 MOV XR,-(XS) STACK PTR FOR GTSTG ! 20050: JSR GTSTG CONVERT TO STRING ! 20051: PPM CONVERT ERROR IS IMPOSSIBLE ! 20052: MOV XR,DNAMP RESET POINTER TO DELETE SCBLK ! 20053: JSR PRTST PRINT INTEGER STRING ! 20054: MOV (XS)+,XR RESTORE ENTRY XR ! 20055: EXI RETURN TO PRTIN CALLER ! 20056: ENP END PROCEDURE PRTIN ! 20057: EJC ! 20058: * ! 20059: * PRTMI -- PRINT MESSAGE AND INTEGER ! 20060: * ! 20061: * PRTMI IS USED TO PRINT MESSAGES TOGETHER WITH AN INTEGER ! 20062: * VALUE STARTING IN COLUMN 15 (USED BY THE ROUTINES AT ! 20063: * THE END OF COMPILATION). ! 20064: * ! 20065: * JSR PRTMI CALL TO PRINT MESSAGE AND INTEGER ! 20066: * ! 20067: PRTMI PRC E,0 ENTRY POINT ! 20068: JSR PRTST PRINT STRING MESSAGE ! 20069: MOV =PRTMF,PROFS SET OFFSET TO COL 15 ! 20070: JSR PRTIN PRINT INTEGER ! 20071: JSR PRTNL PRINT LINE ! 20072: EXI RETURN TO PRTMI CALLER ! 20073: ENP END PROCEDURE PRTMI ! 20074: EJC ! 20075: * ! 20076: * PRTMX -- AS PRTMI WITH EXTRA COPY TO INTERACTIVE CHAN. ! 20077: * ! 20078: * JSR PRTMX CALL FOR PRINTING ! 20079: * (WA,WB) DESTROYED ! 20080: * ! 20081: PRTMX PRC E,0 ENTRY POINT ! 20082: JSR PRTST PRINT STRING MESSAGE ! 20083: MOV =PRTMF,PROFS SET PTR TO COLUMN 15 ! 20084: JSR PRTIN PRINT INTEGER ! 20085: JSR PRTIS PRINT LINE ! 20086: EXI RETURN ! 20087: ENP END PROCEDURE PRTMX ! 20088: EJC ! 20089: * ! 20090: * PRTNL -- PRINT NEW LINE (END PRINT LINE) ! 20091: * ! 20092: * PRTNL PRINTS THE CONTENTS OF THE PRINT BUFFER, RESETS ! 20093: * THE BUFFER TO ALL BLANKS AND RESETS THE PRINT POINTER. ! 20094: * ! 20095: * JSR PRTNL CALL TO PRINT LINE ! 20096: * ! 20097: PRTNL PRC R,0 ENTRY POINT ! 20098: BNZ HEADP,PRNL0 WERE HEADERS PRINTED ! 20099: JSR PRTPS NO - PRINT THEM ! 20100: * ! 20101: * CALL SYSPR ! 20102: * ! 20103: PRNL0 MOV XR,-(XS) SAVE ENTRY XR ! 20104: MOV WA,PRTSA SAVE WA ! 20105: MOV WB,PRTSB SAVE WB ! 20106: MOV PRBUF,XR LOAD POINTER TO BUFFER ! 20107: MOV PROFS,WA LOAD NUMBER OF CHARS IN BUFFER ! 20108: JSR SYSPR CALL SYSTEM PRINT ROUTINE ! 20109: PPM PRNL2 JUMP IF FAILED ! 20110: LCT WA,PRLNW LOAD LENGTH OF BUFFER IN WORDS ! 20111: ADD *SCHAR,XR POINT TO CHARS OF BUFFER ! 20112: MOV NULLW,WB GET WORD OF BLANKS ! 20113: * ! 20114: * LOOP TO BLANK BUFFER ! 20115: * ! 20116: PRNL1 MOV WB,(XR)+ STORE WORD OF BLANKS, BUMP PTR ! 20117: BCT WA,PRNL1 LOOP TILL ALL BLANKED ! 20118: * ! 20119: * EXIT POINT ! 20120: * ! 20121: MOV PRTSB,WB RESTORE WB ! 20122: MOV PRTSA,WA RESTORE WA ! 20123: MOV (XS)+,XR RESTORE ENTRY XR ! 20124: ZER PROFS RESET PRINT BUFFER POINTER ! 20125: EXI RETURN TO PRTNL CALLER ! 20126: * ! 20127: * FILE FULL OR NO OUTPUT FILE FOR LOAD MODULE ! 20128: * ! 20129: PRNL2 BNZ PRTEF,PRNL3 JUMP IF NOT FIRST TIME ! 20130: MNZ PRTEF MARK FIRST OCCURRENCE ! 20131: ERB 253,PRINT LIMIT EXCEEDED ON STANDARD OUTPUT CHANNEL ! 20132: * ! 20133: * STOP AT ONCE ! 20134: * ! 20135: PRNL3 MOV =NINI8,WB ENDING CODE ! 20136: MOV KVSTN,WA STATEMENT NUMBER ! 20137: JSR SYSEJ STOP ! 20138: ENP END PROCEDURE PRTNL ! 20139: EJC ! 20140: * ! 20141: * PRTNM -- PRINT VARIABLE NAME ! 20142: * ! 20143: * PRTNM IS USED TO PRINT A CHARACTER REPRESENTATION OF THE ! 20144: * NAME OF A VARIABLE (NOT A VALUE OF DATATYPE NAME) ! 20145: * NAMES OF PSEUDO-VARIABLES MAY NOT BE PASSED TO PRTNM. ! 20146: * ! 20147: * (XL) NAME BASE ! 20148: * (WA) NAME OFFSET ! 20149: * JSR PRTNM CALL TO PRINT NAME ! 20150: * (WB,WC,RA) DESTROYED ! 20151: * ! 20152: PRTNM PRC R,0 ENTRY POINT (RECURSIVE, SEE PRTVL) ! 20153: MOV WA,-(XS) SAVE WA (OFFSET IS COLLECTABLE) ! 20154: MOV XR,-(XS) SAVE ENTRY XR ! 20155: MOV XL,-(XS) SAVE NAME BASE ! 20156: BHI XL,STATE,PRN02 JUMP IF NOT NATURAL VARIABLE ! 20157: * ! 20158: * HERE FOR NATURAL VARIABLE NAME, RECOGNIZED BY THE FACT ! 20159: * THAT THE NAME BASE POINTS INTO THE STATIC AREA. ! 20160: * ! 20161: MOV XL,XR POINT TO VRBLK ! 20162: JSR PRTVN PRINT NAME OF VARIABLE ! 20163: * ! 20164: * COMMON EXIT POINT ! 20165: * ! 20166: PRN01 MOV (XS)+,XL RESTORE NAME BASE ! 20167: MOV (XS)+,XR RESTORE ENTRY VALUE OF XR ! 20168: MOV (XS)+,WA RESTORE WA ! 20169: EXI RETURN TO PRTNM CALLER ! 20170: * ! 20171: * HERE FOR CASE OF NON-NATURAL VARIABLE ! 20172: * ! 20173: PRN02 MOV WA,WB COPY NAME OFFSET ! 20174: BNE (XL),=B$PDT,PRN03 JUMP IF ARRAY OR TABLE ! 20175: * ! 20176: * FOR PROGRAM DEFINED DATATYPE, PRT FLD NAME, LEFT PAREN ! 20177: * ! 20178: MOV PDDFP(XL),XR LOAD POINTER TO DFBLK ! 20179: ADD WA,XR ADD NAME OFFSET ! 20180: MOV PDFOF(XR),XR LOAD VRBLK POINTER FOR FIELD ! 20181: JSR PRTVN PRINT FIELD NAME ! 20182: MOV =CH$PP,WA LOAD LEFT PAREN ! 20183: JSR PRTCH PRINT CHARACTER ! 20184: EJC ! 20185: * ! 20186: * PRTNM (CONTINUED) ! 20187: * ! 20188: * NOW WE PRINT AN IDENTIFYING NAME FOR THE OBJECT IF ONE ! 20189: * CAN BE FOUND. THE FOLLOWING CODE SEARCHES FOR A NATURAL ! 20190: * VARIABLE WHICH CONTAINS THIS OBJECT AS VALUE. IF SUCH A ! 20191: * VARIABLE IS FOUND, ITS NAME IS PRINTED, ELSE THE VALUE ! 20192: * OF THE OBJECT (AS PRINTED BY PRTVL) IS USED INSTEAD. ! 20193: * ! 20194: * FIRST WE POINT TO THE PARENT TBBLK IF THIS IS THE CASE OF ! 20195: * A TABLE ELEMENT. TO DO THIS, CHASE DOWN THE TRNXT CHAIN. ! 20196: * ! 20197: PRN03 BNE (XL),=B$TET,PRN04 JUMP IF WE GOT THERE (OR NOT TE) ! 20198: MOV TENXT(XL),XL ELSE MOVE OUT ON CHAIN ! 20199: BRN PRN03 AND LOOP BACK ! 20200: * ! 20201: * NOW WE ARE READY FOR THE SEARCH. TO SPEED THINGS UP IN ! 20202: * THE CASE OF CALLS FROM DUMP WHERE THE SAME NAME BASE ! 20203: * WILL OCCUR REPEATEDLY WHILE DUMPING AN ARRAY OR TABLE, ! 20204: * WE REMEMBER THE LAST VRBLK POINTER FOUND IN PRNMV. SO ! 20205: * FIRST CHECK TO SEE IF WE HAVE THIS ONE AGAIN. ! 20206: * ! 20207: PRN04 MOV PRNMV,XR POINT TO VRBLK WE FOUND LAST TIME ! 20208: MOV HSHTB,WA POINT TO HASH TABLE IN CASE NOT ! 20209: BRN PRN07 JUMP INTO SEARCH FOR SPECIAL CHECK ! 20210: * ! 20211: * LOOP THROUGH HASH SLOTS ! 20212: * ! 20213: PRN05 MOV WA,XR COPY SLOT POINTER ! 20214: ICA WA BUMP SLOT POINTER ! 20215: SUB *VRNXT,XR INTRODUCE STANDARD VRBLK OFFSET ! 20216: * ! 20217: * LOOP THROUGH VRBLKS ON ONE HASH CHAIN ! 20218: * ! 20219: PRN06 MOV VRNXT(XR),XR POINT TO NEXT VRBLK ON HASH CHAIN ! 20220: * ! 20221: * MERGE HERE FIRST TIME TO CHECK BLOCK WE FOUND LAST TIME ! 20222: * ! 20223: PRN07 MOV XR,WC COPY VRBLK POINTER ! 20224: BZE WC,PRN09 JUMP IF CHAIN END (OR PRNMV ZERO) ! 20225: EJC ! 20226: * ! 20227: * PRTNM (CONTINUED) ! 20228: * ! 20229: * LOOP TO FIND VALUE (CHASE DOWN POSSIBLE TRBLK CHAIN) ! 20230: * ! 20231: PRN08 MOV VRVAL(XR),XR LOAD VALUE ! 20232: BEQ (XR),=B$TRT,PRN08 LOOP IF THAT WAS A TRBLK ! 20233: * ! 20234: * NOW WE HAVE THE VALUE, IS THIS THE BLOCK WE WANT ! 20235: * ! 20236: BEQ XR,XL,PRN10 JUMP IF THIS MATCHES THE NAME BASE ! 20237: MOV WC,XR ELSE POINT BACK TO THAT VRBLK ! 20238: BRN PRN06 AND LOOP BACK ! 20239: * ! 20240: * HERE TO MOVE TO NEXT HASH SLOT ! 20241: * ! 20242: PRN09 BLT WA,HSHTE,PRN05 LOOP BACK IF MORE TO GO ! 20243: MOV XL,XR ELSE NOT FOUND, COPY VALUE POINTER ! 20244: JSR PRTVL PRINT VALUE ! 20245: BRN PRN11 AND MERGE AHEAD ! 20246: * ! 20247: * HERE WHEN WE FIND A MATCHING ENTRY ! 20248: * ! 20249: PRN10 MOV WC,XR COPY VRBLK POINTER ! 20250: MOV XR,PRNMV SAVE FOR NEXT TIME IN ! 20251: JSR PRTVN PRINT VARIABLE NAME ! 20252: * ! 20253: * MERGE HERE IF NO ENTRY FOUND ! 20254: * ! 20255: PRN11 MOV (XL),WC LOAD FIRST WORD OF NAME BASE ! 20256: BNE WC,=B$PDT,PRN13 JUMP IF NOT PROGRAM DEFINED ! 20257: * ! 20258: * FOR PROGRAM DEFINED DATATYPE, ADD RIGHT PAREN AND EXIT ! 20259: * ! 20260: MOV =CH$RP,WA LOAD RIGHT PAREN, MERGE ! 20261: * ! 20262: * MERGE HERE TO PRINT FINAL RIGHT PAREN OR BRACKET ! 20263: * ! 20264: PRN12 JSR PRTCH PRINT FINAL CHARACTER ! 20265: MOV WB,WA RESTORE NAME OFFSET ! 20266: BRN PRN01 MERGE BACK TO EXIT ! 20267: EJC ! 20268: * ! 20269: * PRTNM (CONTINUED) ! 20270: * ! 20271: * HERE FOR ARRAY OR TABLE ! 20272: * ! 20273: PRN13 MOV =CH$BB,WA LOAD LEFT BRACKET ! 20274: JSR PRTCH AND PRINT IT ! 20275: MOV (XS),XL RESTORE BLOCK POINTER ! 20276: MOV (XL),WC LOAD TYPE WORD AGAIN ! 20277: BNE WC,=B$TET,PRN15 JUMP IF NOT TABLE ! 20278: * ! 20279: * HERE FOR TABLE, PRINT SUBSCRIPT VALUE ! 20280: * ! 20281: MOV TESUB(XL),XR LOAD SUBSCRIPT VALUE ! 20282: MOV WB,XL SAVE NAME OFFSET ! 20283: JSR PRTVL PRINT SUBSCRIPT VALUE ! 20284: MOV XL,WB RESTORE NAME OFFSET ! 20285: * ! 20286: * MERGE HERE FROM ARRAY CASE TO PRINT RIGHT BRACKET ! 20287: * ! 20288: PRN14 MOV =CH$RB,WA LOAD RIGHT BRACKET ! 20289: BRN PRN12 MERGE BACK TO PRINT IT ! 20290: * ! 20291: * HERE FOR ARRAY OR VECTOR, TO PRINT SUBSCRIPT(S) ! 20292: * ! 20293: PRN15 MOV WB,WA COPY NAME OFFSET ! 20294: BTW WA CONVERT TO WORDS ! 20295: BEQ WC,=B$ART,PRN16 JUMP IF ARBLK ! 20296: * ! 20297: * HERE FOR VECTOR ! 20298: * ! 20299: SUB =VCVLB,WA ADJUST FOR STANDARD FIELDS ! 20300: MTI WA MOVE TO INTEGER ACCUM ! 20301: JSR PRTIN PRINT LINEAR SUBSCRIPT ! 20302: BRN PRN14 MERGE BACK FOR RIGHT BRACKET ! 20303: EJC ! 20304: * ! 20305: * PRTNM (CONTINUED) ! 20306: * ! 20307: * HERE FOR ARRAY. FIRST CALCULATE ABSOLUTE SUBSCRIPT ! 20308: * OFFSETS BY SUCCESSIVE DIVISIONS BY THE DIMENSION VALUES. ! 20309: * THIS MUST BE DONE RIGHT TO LEFT SINCE THE ELEMENTS ARE ! 20310: * STORED ROW-WISE. THE SUBSCRIPTS ARE STACKED AS INTEGERS. ! 20311: * ! 20312: PRN16 MOV AROFS(XL),WC LOAD LENGTH OF BOUNDS INFO ! 20313: ICA WC ADJUST FOR ARPRO FIELD ! 20314: BTW WC CONVERT TO WORDS ! 20315: SUB WC,WA GET LINEAR ZERO-ORIGIN SUBSCRIPT ! 20316: MTI WA GET INTEGER VALUE ! 20317: LCT WA,ARNDM(XL) SET NUM OF DIMENSIONS AS LOOP COUNT ! 20318: ADD AROFS(XL),XL POINT PAST BOUNDS INFORMATION ! 20319: SUB *ARLBD,XL SET OK OFFSET FOR PROPER PTR LATER ! 20320: * ! 20321: * LOOP TO STACK SUBSCRIPT OFFSETS ! 20322: * ! 20323: PRN17 SUB *ARDMS,XL POINT TO NEXT SET OF BOUNDS ! 20324: STI PRNSI SAVE CURRENT OFFSET ! 20325: RMI ARDIM(XL) GET REMAINDER ON DIVIDING BY DIMENS ! 20326: MFI -(XS) STORE ON STACK (ONE WORD) ! 20327: LDI PRNSI RELOAD ARGUMENT ! 20328: DVI ARDIM(XL) DIVIDE TO GET QUOTIENT ! 20329: BCT WA,PRN17 LOOP TILL ALL STACKED ! 20330: ZER XR SET OFFSET TO FIRST SET OF BOUNDS ! 20331: LCT WB,ARNDM(XL) LOAD COUNT OF DIMS TO CONTROL LOOP ! 20332: BRN PRN19 JUMP INTO PRINT LOOP ! 20333: * ! 20334: * LOOP TO PRINT SUBSCRIPTS FROM STACK ADJUSTING BY ADDING ! 20335: * THE APPROPRIATE LOW BOUND VALUE FROM THE ARBLK ! 20336: * ! 20337: PRN18 MOV =CH$CM,WA LOAD A COMMA ! 20338: JSR PRTCH PRINT IT ! 20339: * ! 20340: * MERGE HERE FIRST TIME IN (NO COMMA REQUIRED) ! 20341: * ! 20342: PRN19 MTI (XS)+ LOAD SUBSCRIPT OFFSET AS INTEGER ! 20343: ADD XR,XL POINT TO CURRENT LBD ! 20344: ADI ARLBD(XL) ADD LBD TO GET SIGNED SUBSCRIPT ! 20345: SUB XR,XL POINT BACK TO START OF ARBLK ! 20346: JSR PRTIN PRINT SUBSCRIPT ! 20347: ADD *ARDMS,XR BUMP OFFSET TO NEXT BOUNDS ! 20348: BCT WB,PRN18 LOOP BACK TILL ALL PRINTED ! 20349: BRN PRN14 MERGE BACK TO PRINT RIGHT BRACKET ! 20350: ENP END PROCEDURE PRTNM ! 20351: EJC ! 20352: * ! 20353: * PRTNV -- PRINT NAME VALUE ! 20354: * ! 20355: * PRTNV IS USED BY THE TRACE AND DUMP ROUTINES TO PRINT ! 20356: * A LINE OF THE FORM ! 20357: * ! 20358: * NAME = VALUE ! 20359: * ! 20360: * NOTE THAT THE NAME INVOLVED CAN NEVER BE A PSEUDO-VAR ! 20361: * ! 20362: * (XL) NAME BASE ! 20363: * (WA) NAME OFFSET ! 20364: * JSR PRTNV CALL TO PRINT NAME = VALUE ! 20365: * (WB,WC,RA) DESTROYED ! 20366: * ! 20367: PRTNV PRC E,0 ENTRY POINT ! 20368: JSR PRTNM PRINT ARGUMENT NAME ! 20369: MOV XR,-(XS) SAVE ENTRY XR ! 20370: MOV WA,-(XS) SAVE NAME OFFSET (COLLECTABLE) ! 20371: MOV =TMBEB,XR POINT TO BLANK EQUAL BLANK ! 20372: JSR PRTST PRINT IT ! 20373: MOV XL,XR COPY NAME BASE ! 20374: ADD WA,XR POINT TO VALUE ! 20375: MOV (XR),XR LOAD VALUE POINTER ! 20376: JSR PRTVL PRINT VALUE ! 20377: JSR PRTNL TERMINATE LINE ! 20378: MOV (XS)+,WA RESTORE NAME OFFSET ! 20379: MOV (XS)+,XR RESTORE ENTRY XR ! 20380: EXI RETURN TO CALLER ! 20381: ENP END PROCEDURE PRTNV ! 20382: EJC ! 20383: * ! 20384: * PRTPG -- PRINT A PAGE THROW ! 20385: * ! 20386: * PRINTS A PAGE THROW OR A FEW BLANK LINES ON THE STANDARD ! 20387: * LISTING CHANNEL DEPENDING ON THE LISTING OPTIONS CHOSEN. ! 20388: * ! 20389: * JSR PRTPG CALL FOR PAGE EJECT ! 20390: * ! 20391: PRTPG PRC E,0 ENTRY POINT ! 20392: BEQ STAGE,=STGXT,PRP01 JUMP IF EXECUTION TIME ! 20393: BZE LSTLC,PRP06 RETURN IF TOP OF PAGE ALREADY ! 20394: ZER LSTLC CLEAR LINE COUNT ! 20395: * ! 20396: * CHECK TYPE OF LISTING ! 20397: * ! 20398: PRP01 MOV XR,-(XS) PRESERVE XR ! 20399: BNZ PRSTD,PRP02 EJECT IF FLAG SET ! 20400: BNZ PRICH,PRP03 JUMP IF INTERACTIVE LISTING CHANNEL ! 20401: BZE PRECL,PRP03 JUMP IF COMPACT LISTING ! 20402: * ! 20403: * PERFORM AN EJECT ! 20404: * ! 20405: PRP02 JSR SYSEP EJECT ! 20406: BRN PRP04 MERGE ! 20407: * ! 20408: * COMPACT OR INTERACTIVE CHANNEL LISTING. CANT PRINT ! 20409: * BLANKS UNTIL CHECK MADE FOR HEADERS PRINTED AND FLAG SET. ! 20410: * ! 20411: * ! 20412: PRP03 MOV HEADP,XR REMEMBER HEADP ! 20413: MNZ HEADP SET TO AVOID REPEATED PRTPG CALLS ! 20414: JSR PRTNL PRINT BLANK LINE ! 20415: JSR PRTNL PRINT BLANK LINE ! 20416: JSR PRTNL PRINT BLANK LINE ! 20417: MOV =NUM03,LSTLC COUNT BLANK LINES ! 20418: MOV XR,HEADP RESTORE HEADER FLAG ! 20419: EJC ! 20420: * ! 20421: * PRPTG (CONTINUED) ! 20422: * ! 20423: * PRINT THE HEADING ! 20424: * ! 20425: PRP04 BNZ HEADP,PRP05 JUMP IF HEADER LISTED ! 20426: MNZ HEADP MARK HEADERS PRINTED ! 20427: MOV XL,-(XS) KEEP XL ! 20428: MOV =HEADR,XR POINT TO LISTING HEADER ! 20429: JSR PRTST PLACE IT ! 20430: JSR SYSID GET SYSTEM IDENTIFICATION ! 20431: JSR PRTST APPEND EXTRA CHARS ! 20432: JSR PRTNL PRINT IT ! 20433: MOV XL,XR EXTRA HEADER LINE ! 20434: JSR PRTST PLACE IT ! 20435: JSR PRTNL PRINT IT ! 20436: JSR PRTNL PRINT A BLANK ! 20437: JSR PRTNL AND ANOTHER ! 20438: ADD =NUM04,LSTLC FOUR HEADER LINES PRINTED ! 20439: MOV (XS)+,XL RESTORE XL ! 20440: * ! 20441: * MERGE IF HEADER NOT PRINTED ! 20442: * ! 20443: PRP05 MOV (XS)+,XR RESTORE XR ! 20444: * ! 20445: * RETURN ! 20446: * ! 20447: PRP06 EXI RETURN ! 20448: ENP END PROCEDURE PRTPG ! 20449: EJC ! 20450: * ! 20451: * PRTPS - PRINT PAGE WITH TEST FOR STANDARD LISTING OPTION ! 20452: * ! 20453: * IF THE STANDARD LISTING OPTION IS SELECTED, INSIST THAT ! 20454: * AN EJECT BE DONE ! 20455: * ! 20456: * JSR PRTPS CALL FOR EJECT ! 20457: * ! 20458: PRTPS PRC E,0 ENTRY POINT ! 20459: MOV PRSTO,PRSTD COPY OPTION FLAG ! 20460: JSR PRTPG PRINT PAGE ! 20461: ZER PRSTD CLEAR FLAG ! 20462: EXI RETURN ! 20463: ENP END PROCEDURE PRTPS ! 20464: EJC ! 20465: * ! 20466: * PRTSN -- PRINT STATEMENT NUMBER ! 20467: * ! 20468: * PRTSN IS USED TO INITIATE A PRINT TRACE LINE BY PRINTING ! 20469: * ASTERISKS AND THE CURRENT STATEMENT NUMBER. THE ACTUAL ! 20470: * FORMAT OF THE OUTPUT GENERATED IS. ! 20471: * ! 20472: * ***NNNNN**** III.....IIII ! 20473: * ! 20474: * NNNNN IS THE STATEMENT NUMBER WITH LEADING ZEROS REPLACED ! 20475: * BY ASTERISKS (E.G. *******9****) ! 20476: * ! 20477: * III...III REPRESENTS A VARIABLE LENGTH OUTPUT CONSISTING ! 20478: * OF A NUMBER OF LETTER I CHARACTERS EQUAL TO FNCLEVEL. ! 20479: * ! 20480: * JSR PRTSN CALL TO PRINT STATEMENT NUMBER ! 20481: * (WC) DESTROYED ! 20482: * ! 20483: PRTSN PRC E,0 ENTRY POINT ! 20484: MOV XR,-(XS) SAVE ENTRY XR ! 20485: MOV WA,PRSNA SAVE ENTRY WA ! 20486: MOV =TMASB,XR POINT TO ASTERISKS ! 20487: JSR PRTST PRINT ASTERISKS ! 20488: MOV =NUM04,PROFS POINT INTO MIDDLE OF ASTERISKS ! 20489: MTI KVSTN LOAD STATEMENT NUMBER AS INTEGER ! 20490: JSR PRTIN PRINT INTEGER STATEMENT NUMBER ! 20491: MOV =PRSNF,PROFS POINT PAST ASTERISKS PLUS BLANK ! 20492: MOV KVFNC,XR GET FNCLEVEL ! 20493: MOV =CH$LI,WA SET LETTER I ! 20494: * ! 20495: * LOOP TO GENERATE LETTER I FNCLEVEL TIMES ! 20496: * ! 20497: PRSN1 BZE XR,PRSN2 JUMP IF ALL SET ! 20498: JSR PRTCH ELSE PRINT AN I ! 20499: DCV XR DECREMENT COUNTER ! 20500: BRN PRSN1 LOOP BACK ! 20501: * ! 20502: * MERRE WITH ALL LETTER I CHARACTERS GENERATED ! 20503: * ! 20504: PRSN2 MOV =CH$BL,WA GET BLANK ! 20505: JSR PRTCH PRINT BLANK ! 20506: MOV PRSNA,WA RESTORE ENTRY WA ! 20507: MOV (XS)+,XR RESTORE ENTRY XR ! 20508: EXI RETURN TO PRTSN CALLER ! 20509: ENP END PROCEDURE PRTSN ! 20510: EJC ! 20511: * ! 20512: * PRTST -- PRINT STRING ! 20513: * ! 20514: * PRTST PLACES A STRING OF CHARACTERS IN THE PRINT BUFFER ! 20515: * ! 20516: * SEE PRTNL FOR GLOBAL LOCATIONS USED ! 20517: * ! 20518: * NOTE THAT THE FIRST WORD OF THE BLOCK (NORMALLY B$SCL) ! 20519: * IS NOT USED AND NEED NOT BE SET CORRECTLY (SEE PRTVN) ! 20520: * ! 20521: * (XR) STRING TO BE PRINTED ! 20522: * JSR PRTST CALL TO PRINT STRING ! 20523: * (PROFS) UPDATED PAST CHARS PLACED ! 20524: * ! 20525: PRTST PRC R,0 ENTRY POINT ! 20526: BNZ HEADP,PRST0 WERE HEADERS PRINTED ! 20527: JSR PRTPS NO - PRINT THEM ! 20528: * ! 20529: * CALL SYSPR ! 20530: * ! 20531: PRST0 MOV WA,PRSVA SAVE WA ! 20532: MOV WB,PRSVB SAVE WB ! 20533: ZER WB SET CHARS PRINTED COUNT TO ZERO ! 20534: * ! 20535: * LOOP TO PRINT SUCCESSIVE LINES FOR LONG STRING ! 20536: * ! 20537: PRST1 MOV SCLEN(XR),WA LOAD STRING LENGTH ! 20538: SUB WB,WA SUBTRACT COUNT OF CHARS ALREADY OUT ! 20539: BZE WA,PRST4 JUMP TO EXIT IF NONE LEFT ! 20540: MOV XL,-(XS) ELSE STACK ENTRY XL ! 20541: MOV XR,-(XS) SAVE ARGUMENT ! 20542: MOV XR,XL COPY FOR EVENTUAL MOVE ! 20543: MOV PRLEN,XR LOAD PRINT BUFFER LENGTH ! 20544: SUB PROFS,XR GET CHARS LEFT IN PRINT BUFFER ! 20545: BNZ XR,PRST2 SKIP IF ROOM LEFT ON THIS LINE ! 20546: JSR PRTNL ELSE PRINT THIS LINE ! 20547: MOV PRLEN,XR AND SET FULL WIDTH AVAILABLE ! 20548: EJC ! 20549: * ! 20550: * PRTST (CONTINUED) ! 20551: * ! 20552: * HERE WITH CHARS TO PRINT AND SOME ROOM IN BUFFER ! 20553: * ! 20554: PRST2 BLO WA,XR,PRST3 JUMP IF ROOM FOR REST OF STRING ! 20555: MOV XR,WA ELSE SET TO FILL LINE ! 20556: * ! 20557: * MERGE HERE WITH CHARACTER COUNT IN WA ! 20558: * ! 20559: PRST3 MOV PRBUF,XR POINT TO PRINT BUFFER ! 20560: PLC XL,WB POINT TO LOCATION IN STRING ! 20561: PSC XR,PROFS POINT TO LOCATION IN BUFFER ! 20562: ADD WA,WB BUMP STRING CHARS COUNT ! 20563: ADD WA,PROFS BUMP BUFFER POINTER ! 20564: MOV WB,PRSVC PRESERVE CHAR COUNTER ! 20565: MVC MOVE CHARACTERS TO BUFFER ! 20566: MOV PRSVC,WB RECOVER CHAR COUNTER ! 20567: MOV (XS)+,XR RESTORE ARGUMENT POINTER ! 20568: MOV (XS)+,XL RESTORE ENTRY XL ! 20569: BRN PRST1 LOOP BACK TO TEST FOR MORE ! 20570: * ! 20571: * HERE TO EXIT AFTER PRINTING STRING ! 20572: * ! 20573: PRST4 MOV PRSVB,WB RESTORE ENTRY WB ! 20574: MOV PRSVA,WA RESTORE ENTRY WA ! 20575: EXI RETURN TO PRTST CALLER ! 20576: ENP END PROCEDURE PRTST ! 20577: EJC ! 20578: * ! 20579: * PRTTR -- PRINT TO TERMINAL ! 20580: * ! 20581: * CALLED TO PRINT CONTENTS OF STANDARD PRINT BUFFER TO ! 20582: * ONLINE TERMINAL. CLEARS BUFFER DOWN AND RESETS PROFS. ! 20583: * ! 20584: * JSR PRTTR CALL FOR PRINT ! 20585: * (WA,WB) DESTROYED ! 20586: * ! 20587: PRTTR PRC E,0 ENTRY POINT ! 20588: MOV XR,-(XS) SAVE XR ! 20589: JSR PRTIC PRINT BUFFER CONTENTS ! 20590: MOV PRBUF,XR POINT TO PRINT BFR TO CLEAR IT ! 20591: LCT WA,PRLNW GET BUFFER LENGTH ! 20592: ADD *SCHAR,XR POINT PAST SCBLK HEADER ! 20593: MOV NULLW,WB GET BLANKS ! 20594: * ! 20595: * LOOP TO CLEAR BUFFER ! 20596: * ! 20597: PRTT1 MOV WB,(XR)+ CLEAR A WORD ! 20598: BCT WA,PRTT1 LOOP ! 20599: ZER PROFS RESET PROFS ! 20600: MOV (XS)+,XR RESTORE XR ! 20601: EXI RETURN ! 20602: ENP END PROCEDURE PRTTR ! 20603: EJC ! 20604: * ! 20605: * PRTVL -- PRINT A VALUE ! 20606: * ! 20607: * PRTVL PLACES AN APPROPRIATE CHARACTER REPRESENTATION OF ! 20608: * A DATA VALUE IN THE PRINT BUFFER FOR DUMP/TRACE USE. ! 20609: * ! 20610: * (XR) VALUE TO BE PRINTED ! 20611: * JSR PRTVL CALL TO PRINT VALUE ! 20612: * (WA,WB,WC,RA) DESTROYED ! 20613: * ! 20614: PRTVL PRC R,0 ENTRY POINT, RECURSIVE ! 20615: MOV XL,-(XS) SAVE ENTRY XL ! 20616: MOV XR,-(XS) SAVE ARGUMENT ! 20617: CHK CHECK FOR STACK OVERFLOW ! 20618: * ! 20619: * LOOP BACK HERE AFTER FINDING A TRAP BLOCK (TRBLK) ! 20620: * ! 20621: PRV01 MOV IDVAL(XR),PRVSI COPY IDVAL (IF ANY) ! 20622: MOV (XR),XL LOAD FIRST WORD OF BLOCK ! 20623: LEI XL LOAD ENTRY POINT ID ! 20624: BSW XL,BL$$T,PRV02 SWITCH ON BLOCK TYPE ! 20625: IFF BL$TR,PRV04 TRBLK ! 20626: IFF BL$AR,PRV05 ARBLK ! 20627: IFF BL$IC,PRV08 ICBLK ! 20628: IFF BL$NM,PRV09 NMBLK ! 20629: IFF BL$PD,PRV10 PDBLK ! 20630: .IF .CNRA ! 20631: .ELSE ! 20632: IFF BL$RC,PRV08 RCBLK ! 20633: .FI ! 20634: IFF BL$SC,PRV11 SCBLK ! 20635: IFF BL$SE,PRV12 SEBLK ! 20636: IFF BL$TB,PRV13 TBBLK ! 20637: IFF BL$VC,PRV13 VCBLK ! 20638: .IF .CNBF ! 20639: .ELSE ! 20640: IFF BL$BC,PRV15 BCBLK ! 20641: .FI ! 20642: ESW END OF SWITCH ON BLOCK TYPE ! 20643: * ! 20644: * HERE FOR BLOCKS FOR WHICH WE JUST PRINT DATATYPE NAME ! 20645: * ! 20646: PRV02 JSR DTYPE GET DATATYPE NAME ! 20647: JSR PRTST PRINT DATATYPE NAME ! 20648: * ! 20649: * COMMON EXIT POINT ! 20650: * ! 20651: PRV03 MOV (XS)+,XR RELOAD ARGUMENT ! 20652: MOV (XS)+,XL RESTORE XL ! 20653: EXI RETURN TO PRTVL CALLER ! 20654: * ! 20655: * HERE FOR TRBLK ! 20656: * ! 20657: PRV04 MOV TRVAL(XR),XR LOAD REAL VALUE ! 20658: BRN PRV01 AND LOOP BACK ! 20659: EJC ! 20660: * ! 20661: * PRTVL (CONTINUED) ! 20662: * ! 20663: * HERE FOR ARRAY (ARBLK) ! 20664: * ! 20665: * PRINT ARRAY ( PROTOTYPE ) BLANK NUMBER IDVAL ! 20666: * ! 20667: PRV05 MOV XR,XL PRESERVE ARGUMENT ! 20668: MOV =SCARR,XR POINT TO DATATYPE NAME (ARRAY) ! 20669: JSR PRTST PRINT IT ! 20670: MOV =CH$PP,WA LOAD LEFT PAREN ! 20671: JSR PRTCH PRINT LEFT PAREN ! 20672: ADD AROFS(XL),XL POINT TO PROTOTYPE ! 20673: MOV (XL),XR LOAD PROTOTYPE ! 20674: JSR PRTST PRINT PROTOTYPE ! 20675: * ! 20676: * VCBLK, TBBLK, BCBLK MERGE HERE FOR ) BLANK NUMBER IDVAL ! 20677: * ! 20678: PRV06 MOV =CH$RP,WA LOAD RIGHT PAREN ! 20679: JSR PRTCH PRINT RIGHT PAREN ! 20680: * ! 20681: * PDBLK MERGES HERE TO PRINT BLANK NUMBER IDVAL ! 20682: * ! 20683: PRV07 MOV =CH$BL,WA LOAD BLANK ! 20684: JSR PRTCH PRINT IT ! 20685: MOV =CH$NM,WA LOAD NUMBER SIGN ! 20686: JSR PRTCH PRINT IT ! 20687: MTI PRVSI GET IDVAL ! 20688: JSR PRTIN PRINT ID NUMBER ! 20689: BRN PRV03 BACK TO EXIT ! 20690: * ! 20691: * HERE FOR INTEGER (ICBLK), REAL (RCBLK) ! 20692: * ! 20693: * PRINT CHARACTER REPRESENTATION OF VALUE ! 20694: * ! 20695: PRV08 MOV XR,-(XS) STACK ARGUMENT FOR GTSTG ! 20696: JSR GTSTG CONVERT TO STRING ! 20697: PPM ERROR RETURN IS IMPOSSIBLE ! 20698: JSR PRTST PRINT THE STRING ! 20699: MOV XR,DNAMP DELETE GARBAGE STRING FROM STORAGE ! 20700: BRN PRV03 BACK TO EXIT ! 20701: EJC ! 20702: * ! 20703: * PRTVL (CONTINUED) ! 20704: * ! 20705: * NAME (NMBLK) ! 20706: * ! 20707: * FOR PSEUDO-VARIABLE, JUST PRINT DATATYPE NAME (NAME) ! 20708: * FOR ALL OTHER NAMES, PRINT DOT FOLLOWED BY NAME REP ! 20709: * ! 20710: PRV09 MOV NMBAS(XR),XL LOAD NAME BASE ! 20711: MOV (XL),WA LOAD FIRST WORD OF BLOCK ! 20712: BEQ WA,=B$KVT,PRV02 JUST PRINT NAME IF KEYWORD ! 20713: BEQ WA,=B$EVT,PRV02 JUST PRINT NAME IF EXPRESSION VAR ! 20714: MOV =CH$DT,WA ELSE GET DOT ! 20715: JSR PRTCH AND PRINT IT ! 20716: MOV NMOFS(XR),WA LOAD NAME OFFSET ! 20717: JSR PRTNM PRINT NAME ! 20718: BRN PRV03 BACK TO EXIT ! 20719: * ! 20720: * PROGRAM DATATYPE (PDBLK) ! 20721: * ! 20722: * PRINT DATATYPE NAME CH$BL CH$NM IDVAL ! 20723: * ! 20724: PRV10 JSR DTYPE GET DATATYPE NAME ! 20725: JSR PRTST PRINT DATATYPE NAME ! 20726: BRN PRV07 MERGE BACK TO PRINT ID ! 20727: * ! 20728: * HERE FOR STRING (SCBLK) ! 20729: * ! 20730: * PRINT QUOTE STRING-CHARACTERS QUOTE ! 20731: * ! 20732: PRV11 MOV =CH$SQ,WA LOAD SINGLE QUOTE ! 20733: JSR PRTCH PRINT QUOTE ! 20734: JSR PRTST PRINT STRING VALUE ! 20735: JSR PRTCH PRINT ANOTHER QUOTE ! 20736: BRN PRV03 BACK TO EXIT ! 20737: EJC ! 20738: * ! 20739: * PRTVL (CONTINUED) ! 20740: * ! 20741: * HERE FOR SIMPLE EXPRESSION (SEBLK) ! 20742: * ! 20743: * PRINT ASTERISK VARIABLE-NAME ! 20744: * ! 20745: PRV12 MOV =CH$AS,WA LOAD ASTERISK ! 20746: JSR PRTCH PRINT ASTERISK ! 20747: MOV SEVAR(XR),XR LOAD VARIABLE POINTER ! 20748: JSR PRTVN PRINT VARIABLE NAME ! 20749: BRN PRV03 JUMP BACK TO EXIT ! 20750: * ! 20751: * HERE FOR TABLE (TBBLK) AND ARRAY (VCBLK) ! 20752: * ! 20753: * PRINT DATATYPE ( PROTOTYPE ) BLANK NUMBER IDVAL ! 20754: * ! 20755: PRV13 MOV XR,XL PRESERVE ARGUMENT ! 20756: JSR DTYPE GET DATATYPE NAME ! 20757: JSR PRTST PRINT DATATYPE NAME ! 20758: MOV =CH$PP,WA LOAD LEFT PAREN ! 20759: JSR PRTCH PRINT LEFT PAREN ! 20760: MOV TBLEN(XL),WA LOAD LENGTH OF BLOCK (=VCLEN) ! 20761: BTW WA CONVERT TO WORD COUNT ! 20762: SUB =TBSI$,WA ALLOW FOR STANDARD FIELDS ! 20763: BEQ (XL),=B$TBT,PRV14 JUMP IF TABLE ! 20764: ADD =VCTBD,WA FOR VCBLK, ADJUST SIZE ! 20765: * ! 20766: * PRINT PROTOTYPE ! 20767: * ! 20768: PRV14 MTI WA MOVE AS INTEGER ! 20769: JSR PRTIN PRINT INTEGER PROTOTYPE ! 20770: BRN PRV06 MERGE BACK FOR REST ! 20771: .IF .CNBF ! 20772: .ELSE ! 20773: EJC ! 20774: * ! 20775: * PRTVL (CONTINUED) ! 20776: * ! 20777: * HERE FOR BUFFER (BCBLK) ! 20778: * ! 20779: PRV15 MOV XR,XL PRESERVE ARGUMENT ! 20780: MOV =SCBUF,XR POINT TO DATATYPE NAME (BUFFER) ! 20781: JSR PRTST PRINT IT ! 20782: MOV =CH$PP,WA LOAD LEFT PAREN ! 20783: JSR PRTCH PRINT LEFT PAREN ! 20784: MOV BCBUF(XL),XR POINT TO BFBLK ! 20785: MTI BFALC(XR) LOAD ALLOCATION SIZE ! 20786: JSR PRTIN PRINT IT ! 20787: MOV =CH$CM,WA LOAD COMMA ! 20788: JSR PRTCH PRINT IT ! 20789: MTI BCLEN(XL) LOAD DEFINED LENGTH ! 20790: JSR PRTIN PRINT IT ! 20791: BRN PRV06 MERGE TO FINISH UP ! 20792: .FI ! 20793: ENP END PROCEDURE PRTVL ! 20794: EJC ! 20795: * ! 20796: * PRTVN -- PRINT NATURAL VARIABLE NAME ! 20797: * ! 20798: * PRTVN PRINTS THE NAME OF A NATURAL VARIABLE ! 20799: * ! 20800: * (XR) POINTER TO VRBLK ! 20801: * JSR PRTVN CALL TO PRINT VARIABLE NAME ! 20802: * ! 20803: PRTVN PRC E,0 ENTRY POINT ! 20804: MOV XR,-(XS) STACK VRBLK POINTER ! 20805: ADD *VRSOF,XR POINT TO POSSIBLE STRING NAME ! 20806: BNZ SCLEN(XR),PRVN1 JUMP IF NOT SYSTEM VARIABLE ! 20807: MOV VRSVO(XR),XR POINT TO SVBLK WITH NAME ! 20808: * ! 20809: * MERGE HERE WITH DUMMY SCBLK POINTER IN XR ! 20810: * ! 20811: PRVN1 JSR PRTST PRINT STRING NAME OF VARIABLE ! 20812: MOV (XS)+,XR RESTORE VRBLK POINTER ! 20813: EXI RETURN TO PRTVN CALLER ! 20814: ENP END PROCEDURE PRTVN ! 20815: .IF .CNRA ! 20816: .ELSE ! 20817: EJC ! 20818: * ! 20819: * RCBLD -- BUILD A REAL BLOCK ! 20820: * ! 20821: * (RA) REAL VALUE FOR RCBLK ! 20822: * JSR RCBLD CALL TO BUILD REAL BLOCK ! 20823: * (XR) POINTER TO RESULT RCBLK ! 20824: * (WA) DESTROYED ! 20825: * ! 20826: RCBLD PRC E,0 ENTRY POINT ! 20827: MOV DNAMP,XR LOAD POINTER TO NEXT AVAILABLE LOC ! 20828: ADD *RCSI$,XR POINT PAST NEW RCBLK ! 20829: BLO XR,DNAME,RCBL1 JUMP IF THERE IS ROOM ! 20830: MOV *RCSI$,WA ELSE LOAD RCBLK LENGTH ! 20831: JSR ALLOC USE STANDARD ALLOCATOR TO GET BLOCK ! 20832: ADD WA,XR POINT PAST BLOCK TO MERGE ! 20833: * ! 20834: * MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED ! 20835: * ! 20836: RCBL1 MOV XR,DNAMP SET NEW POINTER ! 20837: SUB *RCSI$,XR POINT BACK TO START OF BLOCK ! 20838: MOV =B$RCL,(XR) STORE TYPE WORD ! 20839: STR RCVAL(XR) STORE REAL VALUE IN RCBLK ! 20840: EXI RETURN TO RCBLD CALLER ! 20841: ENP END PROCEDURE RCBLD ! 20842: .FI ! 20843: EJC ! 20844: * ! 20845: * READR -- READ NEXT SOURCE IMAGE AT COMPILE TIME ! 20846: * ! 20847: * READR IS USED TO READ THE NEXT SOURCE IMAGE. TO PROCESS ! 20848: * CONTINUATION CARDS PROPERLY, THE COMPILER MUST READ ONE ! 20849: * LINE AHEAD. THUS READR DOES NOT DESTROY THE CURRENT IMAGE ! 20850: * SEE ALSO THE NEXTS ROUTINE WHICH ACTUALLY GETS THE IMAGE. ! 20851: * ! 20852: * JSR READR CALL TO READ NEXT IMAGE ! 20853: * (XR) PTR TO NEXT IMAGE (0 IF NONE) ! 20854: * (R$CNI) COPY OF POINTER ! 20855: * (WA,WB,WC,XL) DESTROYED ! 20856: * ! 20857: READR PRC E,0 ENTRY POINT ! 20858: MOV R$CNI,XR GET PTR TO NEXT IMAGE ! 20859: BNZ XR,READ3 EXIT IF ALREADY READ ! 20860: BNE STAGE,=STGIC,READ3 EXIT IF NOT INITIAL COMPILE ! 20861: MOV CSWIN,WA MAX READ LENGTH ! 20862: JSR ALOCS ALLOCATE BUFFER ! 20863: JSR SYSRD READ INPUT IMAGE ! 20864: PPM READ4 JUMP IF END OF FILE ! 20865: MNZ WB SET TRIMR TO PERFORM TRIM ! 20866: BLE SCLEN(XR),CSWIN,READ1 USE SMALLER OF STRING LNTH .. ! 20867: MOV CSWIN,SCLEN(XR) ... AND XXX OF -INXXX ! 20868: * ! 20869: * PERFORM THE TRIM ! 20870: * ! 20871: READ1 JSR TRIMR TRIM TRAILING BLANKS ! 20872: * ! 20873: * MERGE HERE AFTER READ ! 20874: * ! 20875: READ2 MOV XR,R$CNI STORE COPY OF POINTER ! 20876: * ! 20877: * MERGE HERE IF NO READ ATTEMPTED ! 20878: * ! 20879: READ3 EXI RETURN TO READR CALLER ! 20880: * ! 20881: * HERE ON END OF FILE ! 20882: * ! 20883: READ4 MOV XR,DNAMP POP UNUSED SCBLK ! 20884: ZER XR ZERO PTR AS RESULT ! 20885: BRN READ2 MERGE ! 20886: ENP END PROCEDURE READR ! 20887: EJC ! 20888: * ! 20889: * SBSTR -- BUILD A SUBSTRING ! 20890: * ! 20891: * (XL) PTR TO SCBLK/BFBLK WITH CHARS ! 20892: * (WA) NUMBER OF CHARS IN SUBSTRING ! 20893: * (WB) OFFSET TO FIRST CHAR IN SCBLK ! 20894: * JSR SBSTR CALL TO BUILD SUBSTRING ! 20895: * (XR) PTR TO NEW SCBLK WITH SUBSTRING ! 20896: * (XL) ZERO ! 20897: * (WA,WB,WC,XL,IA) DESTROYED ! 20898: * ! 20899: * NOTE THAT SBSTR IS CALLED WITH A DUMMY STRING POINTER ! 20900: * (POINTING INTO A VRBLK OR SVBLK) TO COPY THE NAME OF A ! 20901: * VARIABLE AS A STANDARD STRING VALUE. ! 20902: * ! 20903: SBSTR PRC E,0 ENTRY POINT ! 20904: BZE WA,SBST2 JUMP IF NULL SUBSTRING ! 20905: JSR ALOCS ELSE ALLOCATE SCBLK ! 20906: MOV WC,WA MOVE NUMBER OF CHARACTERS ! 20907: MOV XR,WC SAVE PTR TO NEW SCBLK ! 20908: PLC XL,WB PREPARE TO LOAD CHARS FROM OLD BLK ! 20909: PSC XR PREPARE TO STORE CHARS IN NEW BLK ! 20910: MVC MOVE CHARACTERS TO NEW STRING ! 20911: MOV WC,XR THEN RESTORE SCBLK POINTER ! 20912: * ! 20913: * RETURN POINT ! 20914: * ! 20915: SBST1 ZER XL CLEAR GARBAGE POINTER IN XL ! 20916: EXI RETURN TO SBSTR CALLER ! 20917: * ! 20918: * HERE FOR NULL SUBSTRING ! 20919: * ! 20920: SBST2 MOV =NULLS,XR SET NULL STRING AS RESULT ! 20921: BRN SBST1 RETURN ! 20922: ENP END PROCEDURE SBSTR ! 20923: EJC ! 20924: * ! 20925: * SCANE -- SCAN AN ELEMENT ! 20926: * ! 20927: * SCANE IS CALLED AT COMPILE TIME (BY EXPAN ,CMPIL,CNCRD) ! 20928: * TO SCAN ONE ELEMENT FROM THE INPUT IMAGE. ! 20929: * ! 20930: * (SCNCC) NON-ZERO IF CALLED FROM CNCRD ! 20931: * JSR SCANE CALL TO SCAN ELEMENT ! 20932: * (XR) RESULT POINTER (SEE BELOW) ! 20933: * (XL) SYNTAX TYPE CODE (T$XXX) ! 20934: * ! 20935: * THE FOLLOWING GLOBAL LOCATIONS ARE USED. ! 20936: * ! 20937: * R$CIM POINTER TO STRING BLOCK (SCBLK) ! 20938: * FOR CURRENT INPUT IMAGE. ! 20939: * ! 20940: * R$CNI POINTER TO NEXT INPUT IMAGE STRING ! 20941: * POINTER (ZERO IF NONE). ! 20942: * ! 20943: * R$SCP SAVE POINTER (EXIT XR) FROM LAST ! 20944: * CALL IN CASE RESCAN IS SET. ! 20945: * ! 20946: * SCNBL THIS LOCATION IS SET NON-ZERO ON ! 20947: * EXIT IF SCANE SCANNED PAST BLANKS ! 20948: * BEFORE LOCATING THE CURRENT ELEMENT ! 20949: * THE END OF A LINE COUNTS AS BLANKS. ! 20950: * ! 20951: * SCNCC CNCRD SETS THIS NON-ZERO TO SCAN ! 20952: * CONTROL CARD NAMES AND CLEARS IT ! 20953: * ON RETURN ! 20954: * ! 20955: * SCNIL LENGTH OF CURRENT INPUT IMAGE ! 20956: * ! 20957: * SCNGO IF SET NON-ZERO ON ENTRY, F AND S ! 20958: * ARE RETURNED AS SEPARATE SYNTAX ! 20959: * TYPES (NOT LETTERS) (GOTO PRO- ! 20960: * CESSING). SCNGO IS RESET ON EXIT. ! 20961: * ! 20962: * SCNPT OFFSET TO CURRENT LOC IN R$CIM ! 20963: * ! 20964: * SCNRS IF SET NON-ZERO ON ENTRY, SCANE ! 20965: * RETURNS THE SAME RESULT AS ON THE ! 20966: * LAST CALL (RESCAN). SCNRS IS RESET ! 20967: * ON EXIT FROM ANY CALL TO SCANE. ! 20968: * ! 20969: * SCNTP SAVE SYNTAX TYPE FROM LAST ! 20970: * CALL (IN CASE RESCAN IS SET). ! 20971: EJC ! 20972: * ! 20973: * SCANE (CONTINUED) ! 20974: * ! 20975: * ! 20976: * ! 20977: * ELEMENT SCANNED XL XR ! 20978: * --------------- -- -- ! 20979: * ! 20980: * CONTROL CARD NAME 0 POINTER TO SCBLK FOR NAME ! 20981: * ! 20982: * UNARY OPERATOR T$UOP PTR TO OPERATOR DVBLK ! 20983: * ! 20984: * LEFT PAREN T$LPR T$LPR ! 20985: * ! 20986: * LEFT BRACKET T$LBR T$LBR ! 20987: * ! 20988: * COMMA T$CMA T$CMA ! 20989: * ! 20990: * FUNCTION CALL T$FNC PTR TO FUNCTION VRBLK ! 20991: * ! 20992: * VARIABLE T$VAR PTR TO VRBLK ! 20993: * ! 20994: * STRING CONSTANT T$CON PTR TO SCBLK ! 20995: * ! 20996: * INTEGER CONSTANT T$CON PTR TO ICBLK ! 20997: * ! 20998: .IF .CNRA ! 20999: .ELSE ! 21000: * REAL CONSTANT T$CON PTR TO RCBLK ! 21001: * ! 21002: .FI ! 21003: * BINARY OPERATOR T$BOP PTR TO OPERATOR DVBLK ! 21004: * ! 21005: * RIGHT PAREN T$RPR T$RPR ! 21006: * ! 21007: * RIGHT BRACKET T$RBR T$RBR ! 21008: * ! 21009: * COLON T$COL T$COL ! 21010: * ! 21011: * SEMI-COLON T$SMC T$SMC ! 21012: * ! 21013: * F (SCNGO NE 0) T$FGO T$FGO ! 21014: * ! 21015: * S (SCNGO NE 0) T$SGO T$SGO ! 21016: EJC ! 21017: * ! 21018: * SCANE (CONTINUED) ! 21019: * ! 21020: * ENTRY POINT ! 21021: * ! 21022: SCANE PRC E,0 ENTRY POINT ! 21023: ZER SCNBL RESET BLANKS FLAG ! 21024: MOV WA,SCNSA SAVE WA ! 21025: MOV WB,SCNSB SAVE WB ! 21026: MOV WC,SCNSC SAVE WC ! 21027: BZE SCNRS,SCN03 JUMP IF NO RESCAN ! 21028: * ! 21029: * HERE FOR RESCAN REQUEST ! 21030: * ! 21031: MOV SCNTP,XL SET PREVIOUS RETURNED SCAN TYPE ! 21032: MOV R$SCP,XR SET PREVIOUS RETURNED POINTER ! 21033: ZER SCNRS RESET RESCAN SWITCH ! 21034: BRN SCN13 JUMP TO EXIT ! 21035: * ! 21036: * COME HERE TO READ NEW IMAGE TO TEST FOR CONTINUATION ! 21037: * ! 21038: SCN01 JSR READR READ NEXT IMAGE ! 21039: MOV *DVUBS,WB SET WB FOR NOT READING NAME ! 21040: BZE XR,SCN30 TREAT AS SEMI-COLON IF NONE ! 21041: PLC XR ELSE POINT TO FIRST CHARACTER ! 21042: LCH WC,(XR) LOAD FIRST CHARACTER ! 21043: BEQ WC,=CH$DT,SCN02 JUMP IF DOT FOR CONTINUATION ! 21044: BNE WC,=CH$PL,SCN30 ELSE TREAT AS SEMICOLON UNLESS PLUS ! 21045: * ! 21046: * HERE FOR CONTINUATION LINE ! 21047: * ! 21048: SCN02 JSR NEXTS ACQUIRE NEXT SOURCE IMAGE ! 21049: MOV =NUM01,SCNPT SET SCAN POINTER PAST CONTINUATION ! 21050: MNZ SCNBL SET BLANKS FLAG ! 21051: EJC ! 21052: * ! 21053: * SCANE (CONTINUED) ! 21054: * ! 21055: * MERGE HERE TO SCAN NEXT ELEMENT ON CURRENT LINE ! 21056: * ! 21057: SCN03 MOV SCNPT,WA LOAD CURRENT OFFSET ! 21058: BEQ WA,SCNIL,SCN01 CHECK CONTINUATION IF END ! 21059: MOV R$CIM,XL POINT TO CURRENT LINE ! 21060: PLC XL,WA POINT TO CURRENT CHARACTER ! 21061: MOV WA,SCNSE SET START OF ELEMENT LOCATION ! 21062: MOV =OPDVS,WC POINT TO OPERATOR DV LIST ! 21063: MOV *DVUBS,WB SET CONSTANT FOR OPERATOR CIRCUIT ! 21064: BRN SCN06 START SCANNING ! 21065: * ! 21066: * LOOP HERE TO IGNORE LEADING BLANKS AND TABS ! 21067: * ! 21068: SCN05 BZE WB,SCN10 JUMP IF TRAILING ! 21069: ICV SCNSE INCREMENT START OF ELEMENT ! 21070: BEQ WA,SCNIL,SCN01 JUMP IF END OF IMAGE ! 21071: MNZ SCNBL NOTE BLANKS SEEN ! 21072: * ! 21073: * THE FOLLOWING JUMP IS USED REPEATEDLY FOR SCANNING OUT ! 21074: * THE CHARACTERS OF A NUMERIC CONSTANT OR VARIABLE NAME. ! 21075: * THE REGISTERS ARE USED AS FOLLOWS. ! 21076: * ! 21077: * (XR) SCRATCH ! 21078: * (XL) PTR TO NEXT CHARACTER ! 21079: * (WA) CURRENT SCAN OFFSET ! 21080: * (WB) *DVUBS (0 IF SCANNING NAME,CONST) ! 21081: * (WC) =OPDVS (0 IF SCANNING CONSTANT) ! 21082: * ! 21083: SCN06 LCH XR,(XL)+ GET NEXT CHARACTER ! 21084: ICV WA BUMP SCAN OFFSET ! 21085: MOV WA,SCNPT STORE OFFSET PAST CHAR SCANNED ! 21086: .IF .CUCF ! 21087: BLO =CFP$U,XR,SCN07 QUICK CHECK FOR OTHER CHAR ! 21088: BSW XR,CFP$U,SCN07 SWITCH ON SCANNED CHARACTER ! 21089: .ELSE ! 21090: BSW XR,CFP$A,SCN07 SWITCH ON SCANNED CHARACTER ! 21091: .FI ! 21092: * ! 21093: * SWITCH TABLE FOR SWITCH ON CHARACTER ! 21094: * ! 21095: IFF CH$BL,SCN05 BLANK ! 21096: .IF .CAHT ! 21097: IFF CH$HT,SCN05 HORIZONTAL TAB ! 21098: .FI ! 21099: .IF .CAVT ! 21100: IFF CH$VT,SCN05 VERTICAL TAB ! 21101: .FI ! 21102: IFF CH$D0,SCN08 DIGIT 0 ! 21103: IFF CH$D1,SCN08 DIGIT 1 ! 21104: IFF CH$D2,SCN08 DIGIT 2 ! 21105: IFF CH$D3,SCN08 DIGIT 3 ! 21106: IFF CH$D4,SCN08 DIGIT 4 ! 21107: IFF CH$D5,SCN08 DIGIT 5 ! 21108: IFF CH$D6,SCN08 DIGIT 6 ! 21109: IFF CH$D7,SCN08 DIGIT 7 ! 21110: IFF CH$D8,SCN08 DIGIT 8 ! 21111: IFF CH$D9,SCN08 DIGIT 9 ! 21112: EJC ! 21113: * ! 21114: * SCANE (CONTINUED) ! 21115: * ! 21116: IFF CH$LA,SCN09 LETTER A ! 21117: IFF CH$LB,SCN09 LETTER B ! 21118: IFF CH$LC,SCN09 LETTER C ! 21119: IFF CH$LD,SCN09 LETTER D ! 21120: IFF CH$LE,SCN09 LETTER E ! 21121: IFF CH$LG,SCN09 LETTER G ! 21122: IFF CH$LH,SCN09 LETTER H ! 21123: IFF CH$LI,SCN09 LETTER I ! 21124: IFF CH$LJ,SCN09 LETTER J ! 21125: IFF CH$LK,SCN09 LETTER K ! 21126: IFF CH$LL,SCN09 LETTER L ! 21127: IFF CH$LM,SCN09 LETTER M ! 21128: IFF CH$LN,SCN09 LETTER N ! 21129: IFF CH$LO,SCN09 LETTER O ! 21130: IFF CH$LP,SCN09 LETTER P ! 21131: IFF CH$LQ,SCN09 LETTER Q ! 21132: IFF CH$LR,SCN09 LETTER R ! 21133: IFF CH$LT,SCN09 LETTER T ! 21134: IFF CH$LU,SCN09 LETTER U ! 21135: IFF CH$LV,SCN09 LETTER V ! 21136: IFF CH$LW,SCN09 LETTER W ! 21137: IFF CH$LX,SCN09 LETTER X ! 21138: IFF CH$LY,SCN09 LETTER Y ! 21139: IFF CH$L$,SCN09 LETTER Z ! 21140: .IF .CASL ! 21141: IFF CH$$A,SCN09 SHIFTED A ! 21142: IFF CH$$B,SCN09 SHIFTED B ! 21143: IFF CH$$C,SCN09 SHIFTED C ! 21144: IFF CH$$D,SCN09 SHIFTED D ! 21145: IFF CH$$E,SCN09 SHIFTED E ! 21146: IFF CH$$F,SCN20 SHIFTED F ! 21147: IFF CH$$G,SCN09 SHIFTED G ! 21148: IFF CH$$H,SCN09 SHIFTED H ! 21149: IFF CH$$I,SCN09 SHIFTED I ! 21150: IFF CH$$J,SCN09 SHIFTED J ! 21151: IFF CH$$K,SCN09 SHIFTED K ! 21152: IFF CH$$L,SCN09 SHIFTED L ! 21153: IFF CH$$M,SCN09 SHIFTED M ! 21154: IFF CH$$N,SCN09 SHIFTED N ! 21155: IFF CH$$O,SCN09 SHIFTED O ! 21156: IFF CH$$P,SCN09 SHIFTED P ! 21157: IFF CH$$Q,SCN09 SHIFTED Q ! 21158: IFF CH$$R,SCN09 SHIFTED R ! 21159: IFF CH$$S,SCN21 SHIFTED S ! 21160: IFF CH$$T,SCN09 SHIFTED T ! 21161: IFF CH$$U,SCN09 SHIFTED U ! 21162: IFF CH$$V,SCN09 SHIFTED V ! 21163: IFF CH$$W,SCN09 SHIFTED W ! 21164: IFF CH$$X,SCN09 SHIFTED X ! 21165: IFF CH$$Y,SCN09 SHIFTED Y ! 21166: IFF CH$$$,SCN09 SHIFTED Z ! 21167: .FI ! 21168: EJC ! 21169: * ! 21170: * SCANE (CONTINUED) ! 21171: * ! 21172: IFF CH$SQ,SCN16 SINGLE QUOTE ! 21173: IFF CH$DQ,SCN17 DOUBLE QUOTE ! 21174: IFF CH$LF,SCN20 LETTER F ! 21175: IFF CH$LS,SCN21 LETTER S ! 21176: IFF CH$UN,SCN24 UNDERLINE ! 21177: IFF CH$PP,SCN25 LEFT PAREN ! 21178: IFF CH$RP,SCN26 RIGHT PAREN ! 21179: IFF CH$RB,SCN27 RIGHT BRACKET ! 21180: IFF CH$BB,SCN28 LEFT BRACKET ! 21181: IFF CH$CB,SCN27 RIGHT BRACKET ! 21182: IFF CH$OB,SCN28 LEFT BRACKET ! 21183: IFF CH$CL,SCN29 COLON ! 21184: IFF CH$SM,SCN30 SEMI-COLON ! 21185: IFF CH$CM,SCN31 COMMA ! 21186: IFF CH$DT,SCN32 DOT ! 21187: IFF CH$PL,SCN33 PLUS ! 21188: IFF CH$MN,SCN34 MINUS ! 21189: IFF CH$NT,SCN35 NOT ! 21190: IFF CH$DL,SCN36 DOLLAR ! 21191: IFF CH$EX,SCN37 EXCLAMATION MARK ! 21192: IFF CH$PC,SCN38 PERCENT ! 21193: IFF CH$SL,SCN40 SLASH ! 21194: IFF CH$NM,SCN41 NUMBER SIGN ! 21195: IFF CH$AT,SCN42 AT ! 21196: IFF CH$BR,SCN43 VERTICAL BAR ! 21197: IFF CH$AM,SCN44 AMPERSAND ! 21198: IFF CH$QU,SCN45 QUESTION MARK ! 21199: IFF CH$EQ,SCN46 EQUAL ! 21200: IFF CH$AS,SCN49 ASTERISK ! 21201: ESW END SWITCH ON CHARACTER ! 21202: * ! 21203: * HERE FOR ILLEGAL CHARACTER (UNDERLINE MERGES) ! 21204: * ! 21205: SCN07 BZE WB,SCN10 JUMP IF SCANNING NAME OR CONSTANT ! 21206: ERB 230,SYNTAX ERROR. ILLEGAL CHARACTER ! 21207: EJC ! 21208: * ! 21209: * SCANE (CONTINUED) ! 21210: * ! 21211: * HERE FOR DIGITS 0-9 ! 21212: * ! 21213: SCN08 BZE WB,SCN09 KEEP SCANNING IF NAME/CONSTANT ! 21214: ZER WC ELSE SET FLAG FOR SCANNING CONSTANT ! 21215: * ! 21216: * HERE FOR LETTER. LOOP HERE WHEN SCANNING NAME/CONSTANT ! 21217: * ! 21218: SCN09 BEQ WA,SCNIL,SCN11 JUMP IF END OF IMAGE ! 21219: ZER WB SET FLAG FOR SCANNING NAME/CONST ! 21220: BRN SCN06 MERGE BACK TO CONTINUE SCAN ! 21221: * ! 21222: * COME HERE FOR DELIMITER ENDING NAME OR CONSTANT ! 21223: * ! 21224: SCN10 DCV WA RESET OFFSET TO POINT TO DELIMITER ! 21225: * ! 21226: * COME HERE AFTER FINISHING SCAN OF NAME OR CONSTANT ! 21227: * ! 21228: SCN11 MOV WA,SCNPT STORE UPDATED SCAN OFFSET ! 21229: MOV SCNSE,WB POINT TO START OF ELEMENT ! 21230: SUB WB,WA GET NUMBER OF CHARACTERS ! 21231: MOV R$CIM,XL POINT TO LINE IMAGE ! 21232: BNZ WC,SCN15 JUMP IF NAME ! 21233: * ! 21234: * HERE AFTER SCANNING OUT NUMERIC CONSTANT ! 21235: * ! 21236: JSR SBSTR GET STRING FOR CONSTANT ! 21237: MOV XR,DNAMP DELETE FROM STORAGE (NOT NEEDED) ! 21238: JSR GTNUM CONVERT TO NUMERIC ! 21239: PPM SCN14 JUMP IF CONVERSION FAILURE ! 21240: * ! 21241: * MERGE HERE TO EXIT WITH CONSTANT ! 21242: * ! 21243: SCN12 MOV =T$CON,XL SET RESULT TYPE OF CONSTANT ! 21244: EJC ! 21245: * ! 21246: * SCANE (CONTINUED) ! 21247: * ! 21248: * COMMON EXIT POINT (XR,XL) SET ! 21249: * ! 21250: SCN13 MOV SCNSA,WA RESTORE WA ! 21251: MOV SCNSB,WB RESTORE WB ! 21252: MOV SCNSC,WC RESTORE WC ! 21253: MOV XR,R$SCP SAVE XR IN CASE RESCAN ! 21254: MOV XL,SCNTP SAVE XL IN CASE RESCAN ! 21255: ZER SCNGO RESET POSSIBLE GOTO FLAG ! 21256: EXI RETURN TO SCANE CALLER ! 21257: * ! 21258: * HERE IF CONVERSION ERROR ON NUMERIC ITEM ! 21259: * ! 21260: SCN14 ERB 231,SYNTAX ERROR. INVALID NUMERIC ITEM ! 21261: * ! 21262: * HERE AFTER SCANNING OUT VARIABLE NAME ! 21263: * ! 21264: SCN15 JSR SBSTR BUILD STRING NAME OF VARIABLE ! 21265: BNZ SCNCC,SCN13 RETURN IF CNCRD CALL ! 21266: JSR GTNVR LOCATE/BUILD VRBLK ! 21267: PPM DUMMY (UNUSED) ERROR RETURN ! 21268: MOV =T$VAR,XL SET TYPE AS VARIABLE ! 21269: BRN SCN13 BACK TO EXIT ! 21270: * ! 21271: * HERE FOR SINGLE QUOTE (START OF STRING CONSTANT) ! 21272: * ! 21273: SCN16 BZE WB,SCN10 TERMINATOR IF SCANNING NAME OR CNST ! 21274: MOV =CH$SQ,WB SET TERMINATOR AS SINGLE QUOTE ! 21275: BRN SCN18 MERGE ! 21276: * ! 21277: * HERE FOR DOUBLE QUOTE (START OF STRING CONSTANT) ! 21278: * ! 21279: SCN17 BZE WB,SCN10 TERMINATOR IF SCANNING NAME OR CNST ! 21280: MOV =CH$DQ,WB SET DOUBLE QUOTE TERMINATOR, MERGE ! 21281: * ! 21282: * LOOP TO SCAN OUT STRING CONSTANT ! 21283: * ! 21284: SCN18 BEQ WA,SCNIL,SCN19 ERROR IF END OF IMAGE ! 21285: LCH WC,(XL)+ ELSE LOAD NEXT CHARACTER ! 21286: ICV WA BUMP OFFSET ! 21287: BNE WC,WB,SCN18 LOOP BACK IF NOT TERMINATOR ! 21288: EJC ! 21289: * ! 21290: * SCANE (CONTINUED) ! 21291: * ! 21292: * HERE AFTER SCANNING OUT STRING CONSTANT ! 21293: * ! 21294: MOV SCNPT,WB POINT TO FIRST CHARACTER ! 21295: MOV WA,SCNPT SAVE OFFSET PAST FINAL QUOTE ! 21296: DCV WA POINT BACK PAST LAST CHARACTER ! 21297: SUB WB,WA GET NUMBER OF CHARACTERS ! 21298: MOV R$CIM,XL POINT TO INPUT IMAGE ! 21299: JSR SBSTR BUILD SUBSTRING VALUE ! 21300: BRN SCN12 BACK TO EXIT WITH CONSTANT RESULT ! 21301: * ! 21302: * HERE IF NO MATCHING QUOTE FOUND ! 21303: * ! 21304: SCN19 MOV WA,SCNPT SET UPDATED SCAN POINTER ! 21305: ERB 232,SYNTAX ERROR. UNMATCHED STRING QUOTE ! 21306: * ! 21307: * HERE FOR F (POSSIBLE FAILURE GOTO) ! 21308: * ! 21309: SCN20 MOV =T$FGO,XR SET RETURN CODE FOR FAIL GOTO ! 21310: BRN SCN22 JUMP TO MERGE ! 21311: * ! 21312: * HERE FOR S (POSSIBLE SUCCESS GOTO) ! 21313: * ! 21314: SCN21 MOV =T$SGO,XR SET SUCCESS GOTO AS RETURN CODE ! 21315: * ! 21316: * SPECIAL GOTO CASES MERGE HERE ! 21317: * ! 21318: SCN22 BZE SCNGO,SCN09 TREAT AS NORMAL LETTER IF NOT GOTO ! 21319: * ! 21320: * MERGE HERE FOR SPECIAL CHARACTER EXIT ! 21321: * ! 21322: SCN23 BZE WB,SCN10 JUMP IF END OF NAME/CONSTANT ! 21323: MOV XR,XL ELSE COPY CODE ! 21324: BRN SCN13 AND JUMP TO EXIT ! 21325: * ! 21326: * HERE FOR UNDERLINE ! 21327: * ! 21328: SCN24 BZE WB,SCN09 PART OF NAME IF SCANNING NAME ! 21329: BRN SCN07 ELSE ILLEGAL ! 21330: EJC ! 21331: * ! 21332: * SCANE (CONTINUED) ! 21333: * ! 21334: * HERE FOR LEFT PAREN ! 21335: * ! 21336: SCN25 MOV =T$LPR,XR SET LEFT PAREN RETURN CODE ! 21337: BNZ WB,SCN23 RETURN LEFT PAREN UNLESS NAME ! 21338: BZE WC,SCN10 DELIMITER IF SCANNING CONSTANT ! 21339: * ! 21340: * HERE FOR LEFT PAREN AFTER NAME (FUNCTION CALL) ! 21341: * ! 21342: MOV SCNSE,WB POINT TO START OF NAME ! 21343: MOV WA,SCNPT SET POINTER PAST LEFT PAREN ! 21344: DCV WA POINT BACK PAST LAST CHAR OF NAME ! 21345: SUB WB,WA GET NAME LENGTH ! 21346: MOV R$CIM,XL POINT TO INPUT IMAGE ! 21347: JSR SBSTR GET STRING NAME FOR FUNCTION ! 21348: JSR GTNVR LOCATE/BUILD VRBLK ! 21349: PPM DUMMY (UNUSED) ERROR RETURN ! 21350: MOV =T$FNC,XL SET CODE FOR FUNCTION CALL ! 21351: BRN SCN13 BACK TO EXIT ! 21352: * ! 21353: * PROCESSING FOR SPECIAL CHARACTERS ! 21354: * ! 21355: SCN26 MOV =T$RPR,XR RIGHT PAREN, SET CODE ! 21356: BRN SCN23 TAKE SPECIAL CHARACTER EXIT ! 21357: * ! 21358: SCN27 MOV =T$RBR,XR RIGHT BRACKET, SET CODE ! 21359: BRN SCN23 TAKE SPECIAL CHARACTER EXIT ! 21360: * ! 21361: SCN28 MOV =T$LBR,XR LEFT BRACKET, SET CODE ! 21362: BRN SCN23 TAKE SPECIAL CHARACTER EXIT ! 21363: * ! 21364: SCN29 MOV =T$COL,XR COLON, SET CODE ! 21365: BRN SCN23 TAKE SPECIAL CHARACTER EXIT ! 21366: * ! 21367: SCN30 MOV =T$SMC,XR SEMI-COLON, SET CODE ! 21368: BRN SCN23 TAKE SPECIAL CHARACTER EXIT ! 21369: * ! 21370: SCN31 MOV =T$CMA,XR COMMA, SET CODE ! 21371: BRN SCN23 TAKE SPECIAL CHARACTER EXIT ! 21372: EJC ! 21373: * ! 21374: * SCANE (CONTINUED) ! 21375: * ! 21376: * HERE FOR OPERATORS. ON ENTRY, WC POINTS TO THE TABLE OF ! 21377: * OPERATOR DOPE VECTORS AND WB IS THE INCREMENT TO STEP ! 21378: * TO THE NEXT PAIR (BINARY/UNARY) OF DOPE VECTORS IN THE ! 21379: * LIST. ON REACHING SCN46, THE POINTER HAS BEEN ADJUSTED TO ! 21380: * POINT TO THE APPROPRIATE PAIR OF DOPE VECTORS. ! 21381: * THE FIRST THREE ENTRIES ARE SPECIAL SINCE THEY CAN OCCUR ! 21382: * AS PART OF A VARIABLE NAME (.) OR CONSTANT (.+-). ! 21383: * ! 21384: SCN32 BZE WB,SCN09 DOT CAN BE PART OF NAME OR CONSTANT ! 21385: ADD WB,WC ELSE BUMP POINTER ! 21386: * ! 21387: SCN33 BZE WC,SCN09 PLUS CAN BE PART OF CONSTANT ! 21388: BZE WB,SCN48 PLUS CANNOT BE PART OF NAME ! 21389: ADD WB,WC ELSE BUMP POINTER ! 21390: * ! 21391: SCN34 BZE WC,SCN09 MINUS CAN BE PART OF CONSTANT ! 21392: BZE WB,SCN48 MINUS CANNOT BE PART OF NAME ! 21393: ADD WB,WC ELSE BUMP POINTER ! 21394: * ! 21395: SCN35 ADD WB,WC NOT ! 21396: SCN36 ADD WB,WC DOLLAR ! 21397: SCN37 ADD WB,WC EXCLAMATION ! 21398: SCN38 ADD WB,WC PERCENT ! 21399: SCN39 ADD WB,WC ASTERISK ! 21400: SCN40 ADD WB,WC SLASH ! 21401: SCN41 ADD WB,WC NUMBER SIGN ! 21402: SCN42 ADD WB,WC AT SIGN ! 21403: SCN43 ADD WB,WC VERTICAL BAR ! 21404: SCN44 ADD WB,WC AMPERSAND ! 21405: SCN45 ADD WB,WC QUESTION MARK ! 21406: * ! 21407: * ALL OPERATORS COME HERE (EQUAL MERGES DIRECTLY) ! 21408: * (WC) POINTS TO THE BINARY/UNARY PAIR OF OPERATOR DVBLKS. ! 21409: * ! 21410: SCN46 BZE WB,SCN10 OPERATOR TERMINATES NAME/CONSTANT ! 21411: MOV WC,XR ELSE COPY DV POINTER ! 21412: LCH WC,(XL) LOAD NEXT CHARACTER ! 21413: MOV =T$BOP,XL SET BINARY OP IN CASE ! 21414: BEQ WA,SCNIL,SCN47 SHOULD BE BINARY IF IMAGE END ! 21415: BEQ WC,=CH$BL,SCN47 SHOULD BE BINARY IF FOLLOWED BY BLK ! 21416: .IF .CAHT ! 21417: BEQ WC,=CH$HT,SCN47 JUMP IF HORIZONTAL TAB ! 21418: .FI ! 21419: .IF .CAVT ! 21420: BEQ WC,=CH$VT,SCN47 JUMP IF VERTICAL TAB ! 21421: .FI ! 21422: BEQ WC,=CH$SM,SCN47 SEMICOLON CAN IMMEDIATELY FOLLOW = ! 21423: * ! 21424: * HERE FOR UNARY OPERATOR ! 21425: * ! 21426: ADD *DVBS$,XR POINT TO DV FOR UNARY OP ! 21427: MOV =T$UOP,XL SET TYPE FOR UNARY OPERATOR ! 21428: BLE SCNTP,=T$UOK,SCN13 OK UNARY IF OK PRECEDING ELEMENT ! 21429: EJC ! 21430: * ! 21431: * SCANE (CONTINUED) ! 21432: * ! 21433: * MERGE HERE TO REQUIRE PRECEDING BLANKS ! 21434: * ! 21435: SCN47 BNZ SCNBL,SCN13 ALL OK IF PRECEDING BLANKS, EXIT ! 21436: * ! 21437: * FAIL OPERATOR IN THIS POSITION ! 21438: * ! 21439: SCN48 ERB 233,SYNTAX ERROR. INVALID USE OF OPERATOR ! 21440: * ! 21441: * HERE FOR ASTERISK, COULD BE ** SUBSTITUTE FOR EXCLAMATION ! 21442: * ! 21443: SCN49 BZE WB,SCN10 END OF NAME IF SCANNING NAME ! 21444: BEQ WA,SCNIL,SCN39 NOT ** IF * AT IMAGE END ! 21445: MOV WA,XR ELSE SAVE OFFSET PAST FIRST * ! 21446: MOV WA,SCNOF SAVE ANOTHER COPY ! 21447: LCH WA,(XL)+ LOAD NEXT CHARACTER ! 21448: BNE WA,=CH$AS,SCN50 NOT ** IF NEXT CHAR NOT * ! 21449: ICV XR ELSE STEP OFFSET PAST SECOND * ! 21450: BEQ XR,SCNIL,SCN51 OK EXCLAM IF END OF IMAGE ! 21451: LCH WA,(XL) ELSE LOAD NEXT CHARACTER ! 21452: BEQ WA,=CH$BL,SCN51 EXCLAMATION IF BLANK ! 21453: .IF .CAHT ! 21454: BEQ WA,=CH$HT,SCN51 EXCLAMATION IF HORIZONTAL TAB ! 21455: .FI ! 21456: .IF .CAVT ! 21457: BEQ WA,=CH$VT,SCN51 EXCLAMATION IF VERTICAL TAB ! 21458: .FI ! 21459: * ! 21460: * UNARY * ! 21461: * ! 21462: SCN50 MOV SCNOF,WA RECOVER STORED OFFSET ! 21463: MOV R$CIM,XL POINT TO LINE AGAIN ! 21464: PLC XL,WA POINT TO CURRENT CHAR ! 21465: BRN SCN39 MERGE WITH UNARY * ! 21466: * ! 21467: * HERE FOR ** AS SUBSTITUTE FOR EXCLAMATION ! 21468: * ! 21469: SCN51 MOV XR,SCNPT SAVE SCAN POINTER PAST 2ND * ! 21470: MOV XR,WA COPY SCAN POINTER ! 21471: BRN SCN37 MERGE WITH EXCLAMATION ! 21472: ENP END PROCEDURE SCANE ! 21473: EJC ! 21474: * ! 21475: * SCNGF -- SCAN GOTO FIELD ! 21476: * ! 21477: * SCNGF IS CALLED FROM CMPIL TO SCAN AND ANALYZE A GOTO ! 21478: * FIELD INCLUDING THE SURROUNDING BRACKETS OR PARENTHESES. ! 21479: * FOR A NORMAL GOTO, THE RESULT RETURNED IS EITHER A VRBLK ! 21480: * POINTER FOR A SIMPLE LABEL OPERAND, OR A POINTER TO AN ! 21481: * EXPRESSION TREE WITH A SPECIAL OUTER UNARY OPERATOR ! 21482: * (O$GOC). FOR A DIRECT GOTO, THE RESULT RETURNED IS A ! 21483: * POINTER TO AN EXPRESSION TREE WITH THE SPECIAL OUTER ! 21484: * UNARY OPERATOR O$GOD. ! 21485: * ! 21486: * JSR SCNGF CALL TO SCAN GOTO FIELD ! 21487: * (XR) RESULT (SEE ABOVE) ! 21488: * (XL,WA,WB,WC) DESTROYED ! 21489: * ! 21490: SCNGF PRC E,0 ENTRY POINT ! 21491: JSR SCANE SCAN INITIAL ELEMENT ! 21492: BEQ XL,=T$LPR,SCNG1 SKIP IF LEFT PAREN (NORMAL GOTO) ! 21493: BEQ XL,=T$LBR,SCNG2 SKIP IF LEFT BRACKET (DIRECT GOTO) ! 21494: ERB 234,SYNTAX ERROR. GOTO FIELD INCORRECT ! 21495: * ! 21496: * HERE FOR LEFT PAREN (NORMAL GOTO) ! 21497: * ! 21498: SCNG1 MOV =NUM01,WB SET EXPAN FLAG FOR NORMAL GOTO ! 21499: JSR EXPAN ANALYZE GOTO FIELD ! 21500: MOV =OPDVN,WA POINT TO OPDV FOR COMPLEX GOTO ! 21501: BLE XR,STATB,SCNG3 JUMP IF NOT IN STATIC (SGD15) ! 21502: BLO XR,STATE,SCNG4 JUMP TO EXIT IF SIMPLE LABEL NAME ! 21503: BRN SCNG3 COMPLEX GOTO - MERGE ! 21504: * ! 21505: * HERE FOR LEFT BRACKET (DIRECT GOTO) ! 21506: * ! 21507: SCNG2 MOV =NUM02,WB SET EXPAN FLAG FOR DIRECT GOTO ! 21508: JSR EXPAN SCAN GOTO FIELD ! 21509: MOV =OPDVD,WA SET OPDV POINTER FOR DIRECT GOTO ! 21510: EJC ! 21511: * ! 21512: * SCNGF (CONTINUED) ! 21513: * ! 21514: * MERGE HERE TO BUILD OUTER UNARY OPERATOR BLOCK ! 21515: * ! 21516: SCNG3 MOV WA,-(XS) STACK OPERATOR DV POINTER ! 21517: MOV XR,-(XS) STACK POINTER TO EXPRESSION TREE ! 21518: JSR EXPOP POP OPERATOR OFF ! 21519: MOV (XS)+,XR RELOAD NEW EXPRESSION TREE POINTER ! 21520: * ! 21521: * COMMON EXIT POINT ! 21522: * ! 21523: SCNG4 EXI RETURN TO CALLER ! 21524: ENP END PROCEDURE SCNGF ! 21525: EJC ! 21526: * ! 21527: * SETVR -- SET VRGET,VRSTO FIELDS OF VRBLK ! 21528: * ! 21529: * SETVR SETS THE PROPER VALUES IN THE VRGET AND VRSTO ! 21530: * FIELDS OF A VRBLK. IT IS CALLED WHENEVER TRBLKS ARE ! 21531: * ADDED OR SUBTRACTED (TRACE,STOPTR,INPUT,OUTPUT,DETACH) ! 21532: * ! 21533: * (XR) POINTER TO VRBLK ! 21534: * JSR SETVR CALL TO SET FIELDS ! 21535: * (XL,WA) DESTROYED ! 21536: * ! 21537: * NOTE THAT SETVR IGNORES THE CALL IF XR DOES NOT POINT ! 21538: * INTO THE STATIC REGION (I.E. IS SOME OTHER NAME BASE) ! 21539: * ! 21540: SETVR PRC E,0 ENTRY POINT ! 21541: BHI XR,STATE,SETV1 EXIT IF NOT NATURAL VARIABLE ! 21542: * ! 21543: * HERE IF WE HAVE A VRBLK ! 21544: * ! 21545: MOV XR,XL COPY VRBLK POINTER ! 21546: MOV =B$VRL,VRGET(XR) STORE NORMAL GET VALUE ! 21547: BEQ VRSTO(XR),=B$VRE,SETV1 SKIP IF PROTECTED VARIABLE ! 21548: MOV =B$VRS,VRSTO(XR) STORE NORMAL STORE VALUE ! 21549: MOV VRVAL(XL),XL POINT TO NEXT ENTRY ON CHAIN ! 21550: BNE (XL),=B$TRT,SETV1 JUMP IF END OF TRBLK CHAIN ! 21551: MOV =B$VRA,VRGET(XR) STORE TRAPPED ROUTINE ADDRESS ! 21552: MOV =B$VRV,VRSTO(XR) SET TRAPPED ROUTINE ADDRESS ! 21553: * ! 21554: * MERGE HERE TO EXIT TO CALLER ! 21555: * ! 21556: SETV1 EXI RETURN TO SETVR CALLER ! 21557: ENP END PROCEDURE SETVR ! 21558: .IF .CNSR ! 21559: .ELSE ! 21560: EJC ! 21561: * ! 21562: * SORTA -- SORT ARRAY ! 21563: * ! 21564: * ROUTINE TO SORT AN ARRAY OR TABLE ON SAME BASIS AS IN ! 21565: * SITBOL. A TABLE IS CONVERTED TO AN ARRAY, LEAVING TWO ! 21566: * DIMENSIONAL ARRAYS AND VECTORS AS CASES TO BE CONSIDERED. ! 21567: * WHOLE ROWS OF ARRAYS ARE PERMUTED ACCORDING TO THE ! 21568: * ORDERING OF THE KEYS THEY CONTAIN, AND THE STRIDE ! 21569: * REFERRED TO, IS THE THE LENGTH OF A ROW. IT IS ONE ! 21570: * FOR A VECTOR. ! 21571: * THE SORT USED IS HEAPSORT, FUNDAMENTALS OF DATA STRUCTURE ! 21572: * HOROWITZ AND SAHNI, PITMAN 1977, PAGE 347. ! 21573: * IT IS AN ORDER N*LOG(N) ALGORITHM. IN ORDER ! 21574: * TO MAKE IT STABLE, COMPARANDS MAY NOT COMPARE EQUAL. THIS ! 21575: * IS ACHIEVED BY SORTING A COPY ARRAY (REFERRED TO AS THE ! 21576: * SORT ARRAY) CONTAINING AT ITS HIGH ADDRESS END, BYTE ! 21577: * OFFSETS TO THE ROWS TO BE SORTED HELD IN THE ORIGINAL ! 21578: * ARRAY (REFERRED TO AS THE KEY ARRAY). SORTC, THE ! 21579: * COMPARISON ROUTINE, ACCESSES THE KEYS THROUGH THESE ! 21580: * OFFSETS AND IN THE CASE OF EQUALITY, RESOLVES IT BY ! 21581: * COMPARING THE OFFSETS THEMSELVES. THE SORT PERMUTES THE ! 21582: * OFFSETS WHICH ARE THEN USED IN A FINAL OPERATION TO COPY ! 21583: * THE ACTUAL ITEMS INTO THE NEW ARRAY IN SORTED ORDER. ! 21584: * REFERENCES TO ZEROTH ITEM ARE TO NOTIONAL ITEM ! 21585: * PRECEDING FIRST ACTUAL ITEM. ! 21586: * REVERSE SORTING FOR RSORT IS DONE BY HAVING THE LESS THAN ! 21587: * TEST FOR KEYS EFFECTIVELY BE REPLACED BY A ! 21588: * GREATER THAN TEST. ! 21589: * ! 21590: * 1(XS) FIRST ARG - ARRAY OR TABLE ! 21591: * 0(XS) 2ND ARG - INDEX OR PDTYPE NAME ! 21592: * (WA) 0 , NON-ZERO FOR SORT , RSORT ! 21593: * JSR SORTA CALL TO SORT ARRAY ! 21594: * (XR) SORTED ARRAY ! 21595: * (XL,WA,WB,WC) DESTROYED ! 21596: EJC ! 21597: * ! 21598: * SORTA (CONTINUED) ! 21599: * ! 21600: SORTA PRC N,0 ENTRY POINT ! 21601: MOV WA,SRTSR SORT/RSORT INDICATOR ! 21602: MOV *NUM01,SRTST DEFAULT STRIDE OF 1 ! 21603: ZER SRTOF DEFAULT ZERO OFFSET TO SORT KEY ! 21604: MOV =NULLS,SRTDF CLEAR DATATYPE FIELD NAME ! 21605: MOV (XS)+,R$SXR UNSTACK ARGUMENT 2 ! 21606: MOV (XS)+,XR GET FIRST ARGUMENT ! 21607: JSR GTARR CONVERT TO ARRAY ! 21608: PPM SRT16 FAIL ! 21609: MOV XR,-(XS) STACK PTR TO RESULTING KEY ARRAY ! 21610: MOV XR,-(XS) ANOTHER COPY FOR COPYB ! 21611: JSR COPYB GET COPY ARRAY FOR SORTING INTO ! 21612: PPM CANT FAIL ! 21613: MOV XR,-(XS) STACK POINTER TO SORT ARRAY ! 21614: MOV R$SXR,XR GET SECOND ARG ! 21615: MOV 1(XS),XL GET PTR TO KEY ARRAY ! 21616: BNE (XL),=B$VCT,SRT02 JUMP IF ARBLK ! 21617: BEQ XR,=NULLS,SRT01 JUMP IF NULL SECOND ARG ! 21618: JSR GTNVR GET VRBLK PTR FOR IT ! 21619: ERR 257,ERRONEOUS 2ND ARG IN SORT/RSORT OF VECTOR ! 21620: MOV XR,SRTDF STORE DATATYPE FIELD NAME VRBLK ! 21621: * ! 21622: * COMPUTE N AND OFFSET TO ITEM A(0) IN VECTOR CASE ! 21623: * ! 21624: SRT01 MOV *VCLEN,WC OFFSET TO A(0) ! 21625: MOV *VCVLS,WB OFFSET TO FIRST ITEM ! 21626: MOV VCLEN(XL),WA GET BLOCK LENGTH ! 21627: SUB *VCSI$,WA GET NO. OF ENTRIES, N (IN BYTES) ! 21628: BRN SRT04 MERGE ! 21629: * ! 21630: * HERE FOR ARRAY ! 21631: * ! 21632: SRT02 LDI ARDIM(XL) GET POSSIBLE DIMENSION ! 21633: MFI WA CONVERT TO SHORT INTEGER ! 21634: WTB WA FURTHER CONVERT TO BAUS ! 21635: MOV *ARVLS,WB OFFSET TO FIRST VALUE IF ONE ! 21636: MOV *ARPRO,WC OFFSET BEFORE VALUES IF ONE DIM. ! 21637: BEQ ARNDM(XL),=NUM01,SRT04 JUMP IN FACT IF ONE DIM. ! 21638: BNE ARNDM(XL),=NUM02,SRT16 FAIL UNLESS TWO DIMENS ! 21639: LDI ARLB2(XL) GET LOWER BOUND 2 AS DEFAULT ! 21640: BEQ XR,=NULLS,SRT03 JUMP IF DEFAULT SECOND ARG ! 21641: JSR GTINT CONVERT TO INTEGER ! 21642: PPM SRT17 FAIL ! 21643: LDI ICVAL(XR) GET ACTUAL INTEGER VALUE ! 21644: EJC ! 21645: * ! 21646: * SORTA (CONTINUED) ! 21647: * ! 21648: * HERE WITH SORT COLUMN INDEX IN IA IN ARRAY CASE ! 21649: * ! 21650: SRT03 SBI ARLB2(XL) SUBTRACT LOW BOUND ! 21651: IOV SRT17 FAIL IF OVERFLOW ! 21652: ILT SRT17 FAIL IF BELOW LOW BOUND ! 21653: SBI ARDM2(XL) CHECK AGAINST DIMENSION ! 21654: IGE SRT17 FAIL IF TOO LARGE ! 21655: ADI ARDM2(XL) RESTORE VALUE ! 21656: MFI WA GET AS SMALL INTEGER ! 21657: WTB WA OFFSET WITHIN ROW TO KEY ! 21658: MOV WA,SRTOF KEEP OFFSET ! 21659: LDI ARDM2(XL) SECOND DIMENSION IS ROW LENGTH ! 21660: MFI WA CONVERT TO SHORT INTEGER ! 21661: MOV WA,XR COPY ROW LENGTH ! 21662: WTB WA CONVERT TO BYTES ! 21663: MOV WA,SRTST STORE AS STRIDE ! 21664: LDI ARDIM(XL) GET NUMBER OF ROWS ! 21665: MFI WA AS A SHORT INTEGER ! 21666: WTB WA CONVERT N TO BAUS ! 21667: MOV ARLEN(XL),WC OFFSET PAST ARRAY END ! 21668: SUB WA,WC ADJUST, GIVING SPACE FOR N OFFSETS ! 21669: DCA WC POINT TO A(0) ! 21670: MOV AROFS(XL),WB OFFSET TO WORD BEFORE FIRST ITEM ! 21671: ICA WB OFFSET TO FIRST ITEM ! 21672: * ! 21673: * SEPARATE PRE-PROCESSING FOR ARRAYS AND VECTORS DONE. ! 21674: * TO SIMPLIFY LATER KEY COMPARISONS, REMOVAL OF ANY TRBLK ! 21675: * TRAP BLOCKS FROM ENTRIES IN KEY ARRAY IS EFFECTED. ! 21676: * ! 21677: * (XL) = 1(XS) = POINTER TO KEY ARRAY ! 21678: * (XS) = POINTER TO SORT ARRAY ! 21679: * WA = NUMBER OF ITEMS, N (CONVERTED TO BYTES). ! 21680: * WB = OFFSET TO FIRST ITEM OF ARRAYS. ! 21681: * WC = OFFSET TO A(0) ! 21682: * ! 21683: SRT04 BLE WA,*NUM01,SRT15 RETURN IF ONLY A SINGLE ITEM ! 21684: MOV WA,SRTSN STORE NUMBER OF ITEMS (IN BAUS) ! 21685: MOV WC,SRTSO STORE OFFSET TO A(0) ! 21686: MOV ARLEN(XL),WC LENGTH OF ARRAY OR VEC (=VCLEN) ! 21687: ADD XL,WC POINT PAST END OF ARRAY OR VECTOR ! 21688: MOV WB,SRTSF STORE OFFSET TO FIRST ROW ! 21689: ADD WB,XL POINT TO FIRST ITEM IN KEY ARRAY ! 21690: * ! 21691: * LOOP THROUGH ARRAY ! 21692: * ! 21693: SRT05 MOV (XL),XR GET AN ENTRY ! 21694: * ! 21695: * HUNT ALONG TRBLK CHAIN ! 21696: * ! 21697: SRT06 BNE (XR),=B$TRT,SRT07 JUMP OUT IF NOT TRBLK ! 21698: MOV TRVAL(XR),XR GET VALUE FIELD ! 21699: BRN SRT06 LOOP ! 21700: EJC ! 21701: * ! 21702: * SORTA (CONTINUED) ! 21703: * ! 21704: * XR IS VALUE FROM END OF CHAIN ! 21705: * ! 21706: SRT07 MOV XR,(XL)+ STORE AS ARRAY ENTRY ! 21707: BLT XL,WC,SRT05 LOOP IF NOT DONE ! 21708: MOV (XS),XL GET ADRS OF SORT ARRAY ! 21709: MOV SRTSF,XR INITIAL OFFSET TO FIRST KEY ! 21710: MOV SRTST,WB GET STRIDE ! 21711: ADD SRTSO,XL OFFSET TO A(0) ! 21712: ICA XL POINT TO A(1) ! 21713: MOV SRTSN,WC GET N ! 21714: BTW WC CONVERT FROM BYTES ! 21715: MOV WC,SRTNR STORE AS ROW COUNT ! 21716: LCT WC,WC LOOP COUNTER ! 21717: * ! 21718: * STORE KEY OFFSETS AT TOP OF SORT ARRAY ! 21719: * ! 21720: SRT08 MOV XR,(XL)+ STORE AN OFFSET ! 21721: ADD WB,XR BUMP OFFSET BY STRIDE ! 21722: BCT WC,SRT08 LOOP THROUGH ROWS ! 21723: * ! 21724: * PERFORM THE SORT ON OFFSETS IN SORT ARRAY. ! 21725: * ! 21726: * (SRTSN) NUMBER OF ITEMS TO SORT, N (BYTES) ! 21727: * (SRTSO) OFFSET TO A(0) ! 21728: * ! 21729: SRT09 MOV SRTSN,WA GET N ! 21730: MOV SRTNR,WC GET NUMBER OF ROWS ! 21731: RSH WC,1 I = N / 2 (WC=I, INDEX INTO ARRAY) ! 21732: WTB WC CONVERT BACK TO BYTES ! 21733: * ! 21734: * LOOP TO FORM INITIAL HEAP ! 21735: * ! 21736: SRT10 JSR SORTH SORTH(I,N) ! 21737: DCA WC I = I - 1 ! 21738: BNZ WC,SRT10 LOOP IF I GT 0 ! 21739: MOV WA,WC I = N ! 21740: * ! 21741: * SORTING LOOP. AT THIS POINT, A(1) IS THE LARGEST ! 21742: * ITEM, SINCE ALGORITHM INITIALISES IT AS, AND THEN MAINTAI ! 21743: * IT AS, ROOT OF TREE. ! 21744: * ! 21745: SRT11 DCA WC I = I - 1 (N - 1 INITIALLY) ! 21746: BZE WC,SRT12 JUMP IF DONE ! 21747: MOV (XS),XR GET SORT ARRAY ADDRESS ! 21748: ADD SRTSO,XR POINT TO A(0) ! 21749: MOV XR,XL A(0) ADDRESS ! 21750: ADD WC,XL A(I) ADDRESS ! 21751: MOV 1(XL),WB COPY A(I+1) ! 21752: MOV 1(XR),1(XL) MOVE A(1) TO A(I+1) ! 21753: MOV WB,1(XR) COMPLETE EXCHANGE OF A(1), A(I+1) ! 21754: MOV WC,WA N = I FOR SORTH ! 21755: MOV *NUM01,WC I = 1 FOR SORTH ! 21756: JSR SORTH SORTH(1,N) ! 21757: MOV WA,WC RESTORE WC ! 21758: BRN SRT11 LOOP ! 21759: EJC ! 21760: * ! 21761: * SORTA (CONTINUED) ! 21762: * ! 21763: * OFFSETS HAVE BEEN PERMUTED INTO REQUIRED ORDER BY SORT. ! 21764: * COPY ARRAY ELEMENTS OVER THEM. ! 21765: * ! 21766: SRT12 MOV (XS),XL BASE ADRS OF KEY ARRAY ! 21767: MOV XL,WC COPY IT ! 21768: ADD SRTSO,WC OFFSET OF A(0) ! 21769: ADD SRTSF,XL ADRS OF FIRST ROW OF SORT ARRAY ! 21770: MOV SRTST,WB GET STRIDE ! 21771: BTW WB CONVERT TO WORDS ! 21772: * ! 21773: * COPYING LOOP FOR SUCCESSIVE ITEMS. SORTED OFFSETS ARE ! 21774: * HELD AT END OF SORT ARRAY. ! 21775: * ! 21776: SRT13 ICA WC ADRS OF NEXT OF SORTED OFFSETS ! 21777: MOV WC,XR COPY IT FOR ACCESS ! 21778: MOV (XR),XR GET OFFSET ! 21779: ADD 1(XS),XR ADD KEY ARRAY BASE ADRS ! 21780: LCT WA,WB GET COUNT OF WORDS IN ROW ! 21781: * ! 21782: * COPY A COMPLETE ROW ! 21783: * ! 21784: SRT14 MOV (XR)+,(XL)+ MOVE A WORD ! 21785: BCT WA,SRT14 LOOP ! 21786: DCV SRTNR DECREMENT ROW COUNT ! 21787: BNZ SRTNR,SRT13 REPEAT TILL ALL ROWS DONE ! 21788: * ! 21789: * RETURN POINT ! 21790: * ! 21791: SRT15 MOV (XS)+,XR POP RESULT ARRAY PTR ! 21792: ICA XS POP KEY ARRAY PTR ! 21793: ZER R$SXL CLEAR JUNK ! 21794: ZER R$SXR CLEAR JUNK ! 21795: EXI RETURN ! 21796: * ! 21797: * ERROR POINT ! 21798: * ! 21799: SRT16 ERB 256,SORT/RSORT 1ST ARG NOT SUITABLE ARRAY OR TABLE ! 21800: SRT17 ERB 258,SORT/RSORT 2ND ARG OUT OF RANGE OR NON-INTEGER ! 21801: ENP END PROCUDURE SORTA ! 21802: EJC ! 21803: * ! 21804: * SORTC -- COMPARE SORT KEYS ! 21805: * ! 21806: * COMPARE TWO SORT KEYS GIVEN THEIR OFFSETS. IF ! 21807: * EQUAL, COMPARE KEY OFFSETS TO GIVE STABLE SORT. ! 21808: * NOTE THAT IF SRTSR IS NON-ZERO (REQUEST FOR REVERSE ! 21809: * SORT), THE QUOTED RETURNS ARE INVERTED. ! 21810: * FOR OBJECTS OF DIFFERING DATATYPES, THE ENTRY POINT ! 21811: * IDENTIFICATIONS ARE COMPARED. ! 21812: * ! 21813: * (XL) BASE ADRS FOR KEYS ! 21814: * (WA) OFFSET TO KEY 1 ITEM ! 21815: * (WB) OFFSET TO KEY 2 ITEM ! 21816: * (SRTSR) ZERO/NON-ZERO FOR SORT/RSORT ! 21817: * (SRTOF) OFFSET WITHIN ROW TO COMPARANDS ! 21818: * JSR SORTC CALL TO COMPARE KEYS ! 21819: * PPM LOC KEY1 LESS THAN KEY2 ! 21820: * NORMAL RETURN, KEY1 GT THAN KEY2 ! 21821: * (XL,XR,WA,WB) DESTROYED ! 21822: * ! 21823: SORTC PRC E,1 ENTRY POINT ! 21824: MOV WA,SRTS1 SAVE OFFSET 1 ! 21825: MOV WB,SRTS2 SAVE OFFSET 2 ! 21826: MOV WC,SRTSC SAVE WC ! 21827: ADD SRTOF,XL ADD OFFSET TO COMPARAND FIELD ! 21828: MOV XL,XR COPY BASE + OFFSET ! 21829: ADD WA,XL ADD KEY1 OFFSET ! 21830: ADD WB,XR ADD KEY2 OFFSET ! 21831: MOV (XL),XL GET KEY1 ! 21832: MOV (XR),XR GET KEY2 ! 21833: BNE SRTDF,=NULLS,SRC11 JUMP IF DATATYPE FIELD NAME USED ! 21834: EJC ! 21835: * ! 21836: * SORTC (CONTINUED) ! 21837: * ! 21838: * MERGE AFTER DEALING WITH FIELD NAME. TRY FOR STRINGS. ! 21839: * ! 21840: SRC01 MOV (XL),WC GET TYPE CODE ! 21841: BNE WC,(XR),SRC02 SKIP IF NOT SAME DATATYPE ! 21842: BEQ WC,=B$SCL,SRC09 JUMP IF BOTH STRINGS ! 21843: * ! 21844: * NOW TRY FOR NUMERIC ! 21845: * ! 21846: SRC02 MOV XL,R$SXL KEEP ARG1 ! 21847: MOV XR,R$SXR KEEP ARG2 ! 21848: MOV XL,-(XS) STACK ! 21849: MOV XR,-(XS) ARGS ! 21850: JSR ACOMP COMPARE OBJECTS ! 21851: PPM SRC10 NOT NUMERIC ! 21852: PPM SRC10 NOT NUMERIC ! 21853: PPM SRC03 KEY1 LESS ! 21854: PPM SRC08 KEYS EQUAL ! 21855: PPM SRC05 KEY1 GREATER ! 21856: * ! 21857: * RETURN IF KEY1 SMALLER (SORT), GREATER (RSORT) ! 21858: * ! 21859: SRC03 BNZ SRTSR,SRC06 JUMP IF RSORT ! 21860: * ! 21861: SRC04 MOV SRTSC,WC RESTORE WC ! 21862: EXI 1 RETURN ! 21863: * ! 21864: * RETURN IF KEY1 GREATER (SORT), SMALLER (RSORT) ! 21865: * ! 21866: SRC05 BNZ SRTSR,SRC04 JUMP IF RSORT ! 21867: * ! 21868: SRC06 MOV SRTSC,WC RESTORE WC ! 21869: EXI RETURN ! 21870: * ! 21871: * KEYS ARE OF SAME DATATYPE ! 21872: * ! 21873: SRC07 BLT XL,XR,SRC03 ITEM FIRST CREATED IS LESS ! 21874: BGT XL,XR,SRC05 ADDRESSES RISE IN ORDER OF CREATION ! 21875: * ! 21876: * DROP THROUGH OR MERGE FOR IDENTICAL OR EQUAL OBJECTS ! 21877: * ! 21878: SRC08 BLT SRTS1,SRTS2,SRC04 TEST OFFSETS OR KEY ADDRSS INSTEAD ! 21879: BRN SRC06 OFFSET 1 GREATER ! 21880: EJC ! 21881: * ! 21882: * SORTC (CONTINUED) ! 21883: * ! 21884: * STRINGS ! 21885: * ! 21886: SRC09 MOV XL,-(XS) STACK ! 21887: MOV XR,-(XS) ARGS ! 21888: JSR LCOMP COMPARE OBJECTS ! 21889: PPM CANT ! 21890: PPM FAIL ! 21891: PPM SRC03 KEY1 LESS ! 21892: PPM SRC08 KEYS EQUAL ! 21893: PPM SRC05 KEY1 GREATER ! 21894: * ! 21895: * ARITHMETIC COMPARISON FAILED - RECOVER ARGS ! 21896: * ! 21897: SRC10 MOV R$SXL,XL GET ARG1 ! 21898: MOV R$SXR,XR GET ARG2 ! 21899: MOV (XL),WC GET TYPE OF KEY1 ! 21900: BEQ WC,(XR),SRC07 JUMP IF KEYS OF SAME TYPE ! 21901: MOV WC,XL GET BLOCK TYPE WORD ! 21902: MOV (XR),XR GET BLOCK TYPE WORD ! 21903: LEI XL ENTRY POINT ID FOR KEY1 ! 21904: LEI XR ENTRY POINT ID FOR KEY2 ! 21905: BGT XL,XR,SRC05 JUMP IF KEY1 GT KEY2 ! 21906: BRN SRC03 KEY1 LT KEY2 ! 21907: * ! 21908: * DATATYPE FIELD NAME USED ! 21909: * ! 21910: SRC11 JSR SORTF CALL ROUTINE TO FIND FIELD 1 ! 21911: MOV XL,-(XS) STACK ITEM POINTER ! 21912: MOV XR,XL GET KEY2 ! 21913: JSR SORTF FIND FIELD 2 ! 21914: MOV XL,XR PLACE AS KEY2 ! 21915: MOV (XS)+,XL RECOVER KEY1 ! 21916: BRN SRC01 MERGE ! 21917: ENP PROCEDURE SORTC ! 21918: EJC ! 21919: * ! 21920: * SORTF -- FIND FIELD FOR SORTC ! 21921: * ! 21922: * ROUTINE USED BY SORTC TO OBTAIN ITEM CORRESPONDING ! 21923: * TO A GIVEN FIELD NAME, IF THIS EXISTS, IN A PROGRAMMER ! 21924: * DEFINED OBJECT PASSED AS ARGUMENT. ! 21925: * IF SUCH A MATCH OCCURS, RECORD IS KEPT OF DATATYPE ! 21926: * NAME, FIELD NAME AND OFFSET TO FIELD IN ORDER TO ! 21927: * SHORT-CIRCUIT LATER SEARCHES ON SAME TYPE. NOTE THAT ! 21928: * DFBLKS ARE STORED IN STATIC AND HENCE CANNOT BE MOVED. ! 21929: * ! 21930: * (SRTDF) VRBLK POINTER OF FIELD NAME ! 21931: * (XL) POSSIBLE PDBLK POINTER ! 21932: * JSR SORTF CALL TO SEARCH FOR FIELD NAME ! 21933: * (XL) ITEM FOUND OR ORIGINAL PDBLK PTR ! 21934: * (WC) DESTROYED ! 21935: * ! 21936: SORTF PRC E,0 ENTRY POINT ! 21937: BNE (XL),=B$PDT,SRTF3 RETURN IF NOT PDBLK ! 21938: MOV XR,-(XS) KEEP XR ! 21939: MOV SRTFD,XR GET POSSIBLE FORMER DFBLK PTR ! 21940: BZE XR,SRTF4 JUMP IF NOT ! 21941: BNE XR,PDDFP(XL),SRTF4 JUMP IF NOT RIGHT DATATYPE ! 21942: BNE SRTDF,SRTFF,SRTF4 JUMP IF NOT RIGHT FIELD NAME ! 21943: ADD SRTFO,XL ADD OFFSET TO REQUIRED FIELD ! 21944: * ! 21945: * HERE WITH XL POINTING TO FOUND FIELD ! 21946: * ! 21947: SRTF1 MOV (XL),XL GET ITEM FROM FIELD ! 21948: * ! 21949: * RETURN POINT ! 21950: * ! 21951: SRTF2 MOV (XS)+,XR RESTORE XR ! 21952: * ! 21953: SRTF3 EXI RETURN ! 21954: EJC ! 21955: * ! 21956: * SORTF (CONTINUED) ! 21957: * ! 21958: * CONDUCT A SEARCH ! 21959: * ! 21960: SRTF4 MOV XL,XR COPY ORIGINAL POINTER ! 21961: MOV PDDFP(XR),XR POINT TO DFBLK ! 21962: MOV XR,SRTFD KEEP A COPY ! 21963: MOV FARGS(XR),WC GET NUMBER OF FIELDS ! 21964: WTB WC CONVERT TO BYTES ! 21965: ADD DFLEN(XR),XR POINT PAST LAST FIELD ! 21966: * ! 21967: * LOOP TO FIND NAME IN PDFBLK ! 21968: * ! 21969: SRTF5 DCA WC COUNT DOWN ! 21970: DCA XR POINT IN FRONT ! 21971: BEQ (XR),SRTDF,SRTF6 SKIP OUT IF FOUND ! 21972: BNZ WC,SRTF5 LOOP ! 21973: BRN SRTF2 RETURN - NOT FOUND ! 21974: * ! 21975: * FOUND ! 21976: * ! 21977: SRTF6 MOV (XR),SRTFF KEEP FIELD NAME PTR ! 21978: ADD *PDFLD,WC ADD OFFSET TO FIRST FIELD ! 21979: MOV WC,SRTFO STORE AS FIELD OFFSET ! 21980: ADD WC,XL POINT TO FIELD ! 21981: BRN SRTF1 RETURN ! 21982: ENP PROCEDURE SORTF ! 21983: EJC ! 21984: * ! 21985: * SORTH -- HEAP ROUTINE FOR SORTA ! 21986: * ! 21987: * THIS ROUTINE CONSTRUCTS A HEAP FROM ELEMENTS OF ARRAY, A. ! 21988: * IN THIS APPLICATION, THE ELEMENTS ARE OFFSETS TO KEYS IN ! 21989: * A KEY ARRAY. ! 21990: * ! 21991: * (XS) POINTER TO SORT ARRAY BASE ! 21992: * 1(XS) POINTER TO KEY ARRAY BASE ! 21993: * (WA) MAX ARRAY INDEX, N (IN BYTES) ! 21994: * (WC) OFFSET J IN A TO ROOT (IN *1 TO *N) ! 21995: * JSR SORTH CALL SORTH(J,N) TO MAKE HEAP ! 21996: * (XL,XR,WB) DESTROYED ! 21997: * ! 21998: SORTH PRC N,0 ENTRY POINT ! 21999: MOV WA,SRTSN SAVE N ! 22000: MOV WC,SRTWC KEEP WC ! 22001: MOV (XS),XL SORT ARRAY BASE ADRS ! 22002: ADD SRTSO,XL ADD OFFSET TO A(0) ! 22003: ADD WC,XL POINT TO A(J) ! 22004: MOV (XL),SRTRT GET OFFSET TO ROOT ! 22005: ADD WC,WC DOUBLE J - CANT EXCEED N ! 22006: * ! 22007: * LOOP TO MOVE DOWN TREE USING DOUBLED INDEX J ! 22008: * ! 22009: SRH01 BGT WC,SRTSN,SRH03 DONE IF J GT N ! 22010: BEQ WC,SRTSN,SRH02 SKIP IF J EQUALS N ! 22011: MOV (XS),XR SORT ARRAY BASE ADRS ! 22012: MOV 1(XS),XL KEY ARRAY BASE ADRS ! 22013: ADD SRTSO,XR POINT TO A(0) ! 22014: ADD WC,XR ADRS OF A(J) ! 22015: MOV 1(XR),WA GET A(J+1) ! 22016: MOV (XR),WB GET A(J) ! 22017: * ! 22018: * COMPARE SONS. (WA) RIGHT SON, (WB) LEFT SON ! 22019: * ! 22020: JSR SORTC COMPARE KEYS - LT(A(J+1),A(J)) ! 22021: PPM SRH02 A(J+1) LT A(J) ! 22022: ICA WC POINT TO GREATER SON, A(J+1) ! 22023: EJC ! 22024: * ! 22025: * SORTH (CONTINUED) ! 22026: * ! 22027: * COMPARE ROOT WITH GREATER SON ! 22028: * ! 22029: SRH02 MOV 1(XS),XL KEY ARRAY BASE ADRS ! 22030: MOV (XS),XR GET SORT ARRAY ADDRESS ! 22031: ADD SRTSO,XR ADRS OF A(0) ! 22032: MOV XR,WB COPY THIS ADRS ! 22033: ADD WC,XR ADRS OF GREATER SON, A(J) ! 22034: MOV (XR),WA GET A(J) ! 22035: MOV WB,XR POINT BACK TO A(0) ! 22036: MOV SRTRT,WB GET ROOT ! 22037: JSR SORTC COMPARE THEM - LT(A(J),ROOT) ! 22038: PPM SRH03 FATHER EXCEEDS SONS - DONE ! 22039: MOV (XS),XR GET SORT ARRAY ADRS ! 22040: ADD SRTSO,XR POINT TO A(0) ! 22041: MOV XR,XL COPY IT ! 22042: MOV WC,WA COPY J ! 22043: BTW WC CONVERT TO WORDS ! 22044: RSH WC,1 GET J/2 ! 22045: WTB WC CONVERT BACK TO BYTES ! 22046: ADD WA,XL POINT TO A(J) ! 22047: ADD WC,XR ADRS OF A(J/2) ! 22048: MOV (XL),(XR) A(J/2) = A(J) ! 22049: MOV WA,WC RECOVER J ! 22050: AOV WC,WC,SRH03 J = J*2. DONE IF TOO BIG ! 22051: BRN SRH01 LOOP ! 22052: * ! 22053: * FINISH BY COPYING ROOT OFFSET BACK INTO ARRAY ! 22054: * ! 22055: SRH03 BTW WC CONVERT TO WORDS ! 22056: RSH WC,1 J = J/2 ! 22057: WTB WC CONVERT BACK TO BYTES ! 22058: MOV (XS),XR SORT ARRAY ADRS ! 22059: ADD SRTSO,XR ADRS OF A(0) ! 22060: ADD WC,XR ADRS OF A(J/2) ! 22061: MOV SRTRT,(XR) A(J/2) = ROOT ! 22062: MOV SRTSN,WA RESTORE WA ! 22063: MOV SRTWC,WC RESTORE WC ! 22064: EXI RETURN ! 22065: ENP END PROCEDURE SORTH ! 22066: EJC ! 22067: .FI ! 22068: EJC ! 22069: * ! 22070: * TFIND -- LOCATE TABLE ELEMENT ! 22071: * ! 22072: * (XR) SUBSCRIPT VALUE FOR ELEMENT ! 22073: * (XL) POINTER TO TABLE ! 22074: * (WB) ZERO BY VALUE, NON-ZERO BY NAME ! 22075: * JSR TFIND CALL TO LOCATE ELEMENT ! 22076: * PPM LOC TRANSFER LOCATION IF ACCESS FAILS ! 22077: * (XR) ELEMENT VALUE (IF BY VALUE) ! 22078: * (XR) DESTROYED (IF BY NAME) ! 22079: * (XL,WA) TEBLK NAME (IF BY NAME) ! 22080: * (XL,WA) DESTROYED (IF BY VALUE) ! 22081: * (WC,RA) DESTROYED ! 22082: * ! 22083: * NOTE THAT IF A CALL BY VALUE SPECIFIES A NON-EXISTENT ! 22084: * SUBSCRIPT, NULL IS RETURNED WITHOUT BUILDING A NEW TEBLK. ! 22085: * ! 22086: TFIND PRC E,1 ENTRY POINT ! 22087: MOV WB,-(XS) SAVE NAME/VALUE INDICATOR ! 22088: MOV XR,-(XS) SAVE SUBSCRIPT VALUE ! 22089: MOV XL,-(XS) SAVE TABLE POINTER ! 22090: MOV TBLEN(XL),WA LOAD LENGTH OF TBBLK ! 22091: BTW WA CONVERT TO WORD COUNT ! 22092: SUB =TBBUK,WA GET NUMBER OF BUCKETS ! 22093: MTI WA CONVERT TO INTEGER VALUE ! 22094: STI TFNSI SAVE FOR LATER ! 22095: MOV (XR),XL LOAD FIRST WORD OF SUBSCRIPT ! 22096: LEI XL LOAD BLOCK ENTRY ID (BL$XX) ! 22097: BSW XL,BL$$D,TFN00 SWITCH ON BLOCK TYPE ! 22098: IFF BL$IC,TFN02 JUMP IF INTEGER ! 22099: .IF .CNRA ! 22100: .ELSE ! 22101: IFF BL$RC,TFN02 REAL ! 22102: .FI ! 22103: IFF BL$P0,TFN03 JUMP IF PATTERN ! 22104: IFF BL$P1,TFN03 JUMP IF PATTERN ! 22105: IFF BL$P2,TFN03 JUMP IF PATTERN ! 22106: IFF BL$NM,TFN04 JUMP IF NAME ! 22107: IFF BL$SC,TFN05 JUMP IF STRING ! 22108: ESW END SWITCH ON BLOCK TYPE ! 22109: * ! 22110: * HERE FOR BLOCKS FOR WHICH WE USE THE SECOND WORD OF THE ! 22111: * BLOCK AS THE HASH SOURCE (SEE BLOCK FORMATS FOR DETAILS). ! 22112: * ! 22113: TFN00 MOV 1(XR),WA LOAD SECOND WORD ! 22114: * ! 22115: * MERGE HERE WITH ONE WORD HASH SOURCE IN WA ! 22116: * ! 22117: TFN01 MTI WA CONVERT TO INTEGER ! 22118: BRN TFN06 JUMP TO MERGE ! 22119: EJC ! 22120: * ! 22121: * TFIND (CONTINUED) ! 22122: * ! 22123: * HERE FOR INTEGER OR REAL ! 22124: * ! 22125: TFN02 LDI 1(XR) LOAD VALUE AS HASH SOURCE ! 22126: IGE TFN06 OK IF POSITIVE OR ZERO ! 22127: NGI MAKE POSITIVE ! 22128: IOV TFN06 CLEAR POSSIBLE OVERFLOW ! 22129: BRN TFN06 MERGE ! 22130: * ! 22131: * FOR PATTERN, USE FIRST WORD (PCODE) AS SOURCE ! 22132: * ! 22133: TFN03 MOV (XR),WA LOAD FIRST WORD AS HASH SOURCE ! 22134: BRN TFN01 MERGE BACK ! 22135: * ! 22136: * FOR NAME, USE OFFSET AS HASH SOURCE ! 22137: * ! 22138: TFN04 MOV NMOFS(XR),WA LOAD OFFSET AS HASH SOURCE ! 22139: BRN TFN01 MERGE BACK ! 22140: * ! 22141: * HERE FOR STRING ! 22142: * ! 22143: TFN05 JSR HASHS CALL ROUTINE TO COMPUTE HASH ! 22144: * ! 22145: * MERGE HERE WITH HASH SOURCE IN (IA) ! 22146: * ! 22147: TFN06 RMI TFNSI COMPUTE HASH INDEX BY REMAINDERING ! 22148: MFI WC GET AS ONE WORD INTEGER ! 22149: WTB WC CONVERT TO BYTE OFFSET ! 22150: MOV (XS),XL GET TABLE PTR AGAIN ! 22151: ADD WC,XL POINT TO PROPER BUCKET ! 22152: MOV TBBUK(XL),XR LOAD FIRST TEBLK POINTER ! 22153: BEQ XR,(XS),TFN10 JUMP IF NO TEBLKS ON CHAIN ! 22154: * ! 22155: * LOOP THROUGH TEBLKS ON HASH CHAIN ! 22156: * ! 22157: TFN07 MOV XR,WB SAVE TEBLK POINTER ! 22158: MOV TESUB(XR),XR LOAD SUBSCRIPT VALUE ! 22159: MOV 1(XS),XL LOAD INPUT ARGUMENT SUBSCRIPT VAL ! 22160: JSR IDENT COMPARE THEM ! 22161: PPM TFN08 JUMP IF EQUAL (IDENT) ! 22162: * ! 22163: * HERE IF NO MATCH WITH THAT TEBLK ! 22164: * ! 22165: MOV WB,XL RESTORE TEBLK POINTER ! 22166: MOV TENXT(XL),XR POINT TO NEXT TEBLK ON CHAIN ! 22167: BNE XR,(XS),TFN07 JUMP IF THERE IS ONE ! 22168: * ! 22169: * HERE IF NO MATCH WITH ANY TEBLK ON CHAIN ! 22170: * ! 22171: MOV *TENXT,WC SET OFFSET TO LINK FIELD (XL BASE) ! 22172: BRN TFN11 JUMP TO MERGE ! 22173: EJC ! 22174: * ! 22175: * TFIND (CONTINUED) ! 22176: * ! 22177: * HERE WE HAVE FOUND A MATCHING ELEMENT ! 22178: * ! 22179: TFN08 MOV WB,XL RESTORE TEBLK POINTER ! 22180: MOV *TEVAL,WA SET TEBLK NAME OFFSET ! 22181: MOV 2(XS),WB RESTORE NAME/VALUE INDICATOR ! 22182: BNZ WB,TFN09 JUMP IF CALLED BY NAME ! 22183: JSR ACESS ELSE GET VALUE ! 22184: PPM TFN12 JUMP IF REFERENCE FAILS ! 22185: ZER WB RESTORE NAME/VALUE INDICATOR ! 22186: * ! 22187: * COMMON EXIT FOR ENTRY FOUND ! 22188: * ! 22189: TFN09 ADD *NUM03,XS POP STACK ENTRIES ! 22190: EXI RETURN TO TFIND CALLER ! 22191: * ! 22192: * HERE IF NO TEBLKS ON THE HASH CHAIN ! 22193: * ! 22194: TFN10 ADD *TBBUK,WC GET OFFSET TO BUCKET PTR ! 22195: MOV (XS),XL SET TBBLK PTR AS BASE ! 22196: * ! 22197: * MERGE HERE WITH (XL,WC) BASE,OFFSET OF FINAL LINK ! 22198: * ! 22199: TFN11 MOV (XS),XR TBBLK POINTER ! 22200: MOV TBINV(XR),XR LOAD DEFAULT VALUE IN CASE ! 22201: MOV 2(XS),WB LOAD NAME/VALUE INDICATOR ! 22202: BZE WB,TFN09 EXIT WITH DEFAULT IF VALUE CALL ! 22203: * ! 22204: * HERE WE MUST BUILD A NEW TEBLK ! 22205: * ! 22206: MOV *TESI$,WA SET SIZE OF TEBLK ! 22207: JSR ALLOC ALLOCATE TEBLK ! 22208: ADD WC,XL POINT TO HASH LINK ! 22209: MOV XR,(XL) LINK NEW TEBLK AT END OF CHAIN ! 22210: MOV =B$TET,(XR) STORE TYPE WORD ! 22211: MOV =NULLS,TEVAL(XR) SET NULL AS INITIAL VALUE ! 22212: MOV (XS)+,TENXT(XR) SET TBBLK PTR TO MARK END OF CHAIN ! 22213: MOV (XS)+,TESUB(XR) STORE SUBSCRIPT VALUE ! 22214: ICA XS POP PAST NAME/VALUE INDICATOR ! 22215: MOV XR,XL COPY TEBLK POINTER (NAME BASE) ! 22216: MOV *TEVAL,WA SET OFFSET ! 22217: EXI RETURN TO CALLER WITH NEW TEBLK ! 22218: * ! 22219: * ACESS FAIL RETURN ! 22220: * ! 22221: TFN12 EXI 1 ALTERNATIVE RETURN ! 22222: ENP END PROCEDURE TFIND ! 22223: EJC ! 22224: * ! 22225: * TRACE -- SET/RESET A TRACE ASSOCIATION ! 22226: * ! 22227: * THIS PROCEDURE IS SHARED BY TRACE AND STOPTR TO ! 22228: * EITHER INITIATE OR STOP A TRACE RESPECTIVELY. ! 22229: * ! 22230: * (XL) TRBLK PTR (TRACE) OR ZERO (STOPTR) ! 22231: * 1(XS) FIRST ARGUMENT (NAME) ! 22232: * 0(XS) SECOND ARGUMENT (TRACE TYPE) ! 22233: * JSR TRACE CALL TO SET/RESET TRACE ! 22234: * PPM LOC TRANSFER LOC IF 1ST ARG IS BAD NAME ! 22235: * PPM LOC TRANSFER LOC IF 2ND ARG IS BAD TYPE ! 22236: * (XS) POPPED ! 22237: * (XL,XR,WA,WB,WC,IA) DESTROYED ! 22238: * ! 22239: TRACE PRC N,2 ENTRY POINT ! 22240: JSR GTSTG GET TRACE TYPE STRING ! 22241: PPM TRC15 JUMP IF NOT STRING ! 22242: PLC XR ELSE POINT TO STRING ! 22243: LCH WA,(XR) LOAD FIRST CHARACTER ! 22244: .IF .CULC ! 22245: FLC WA FOLD TO UPPER CASE ! 22246: .FI ! 22247: MOV (XS),XR LOAD NAME ARGUMENT ! 22248: MOV XL,(XS) STACK TRBLK PTR OR ZERO ! 22249: MOV =TRTAC,WC SET TRTYP FOR ACCESS TRACE ! 22250: BEQ WA,=CH$LA,TRC10 JUMP IF A (ACCESS) ! 22251: MOV =TRTVL,WC SET TRTYP FOR VALUE TRACE ! 22252: BEQ WA,=CH$LV,TRC10 JUMP IF V (VALUE) ! 22253: .IF .CULC ! 22254: BZE WA,TRC10 JUMP IF BLANK (VALUE) ! 22255: .ELSE ! 22256: BEQ WA,=CH$BL,TRC10 JUMP IF BLANK (VALUE) ! 22257: .FI ! 22258: * ! 22259: * HERE FOR L,K,F,C,R ! 22260: * ! 22261: BEQ WA,=CH$LF,TRC01 JUMP IF F (FUNCTION) ! 22262: BEQ WA,=CH$LR,TRC01 JUMP IF R (RETURN) ! 22263: BEQ WA,=CH$LL,TRC03 JUMP IF L (LABEL) ! 22264: BEQ WA,=CH$LK,TRC06 JUMP IF K (KEYWORD) ! 22265: BNE WA,=CH$LC,TRC15 ELSE ERROR IF NOT C (CALL) ! 22266: * ! 22267: * HERE FOR F,C,R ! 22268: * ! 22269: TRC01 JSR GTNVR POINT TO VRBLK FOR NAME ! 22270: PPM TRC16 JUMP IF BAD NAME ! 22271: ICA XS POP STACK ! 22272: MOV VRFNC(XR),XR POINT TO FUNCTION BLOCK ! 22273: BNE (XR),=B$PFC,TRC17 ERROR IF NOT PROGRAM FUNCTION ! 22274: BEQ WA,=CH$LR,TRC02 JUMP IF R (RETURN) ! 22275: EJC ! 22276: * ! 22277: * TRACE (CONTINUED) ! 22278: * ! 22279: * HERE FOR F,C TO SET/RESET CALL TRACE ! 22280: * ! 22281: MOV XL,PFCTR(XR) SET/RESET CALL TRACE ! 22282: BEQ WA,=CH$LC,EXNUL EXIT WITH NULL IF C (CALL) ! 22283: * ! 22284: * HERE FOR F,R TO SET/RESET RETURN TRACE ! 22285: * ! 22286: TRC02 MOV XL,PFRTR(XR) SET/RESET RETURN TRACE ! 22287: EXI RETURN ! 22288: * ! 22289: * HERE FOR L TO SET/RESET LABEL TRACE ! 22290: * ! 22291: TRC03 JSR GTNVR POINT TO VRBLK ! 22292: PPM TRC16 JUMP IF BAD NAME ! 22293: MOV VRLBL(XR),XL LOAD LABEL POINTER ! 22294: BNE (XL),=B$TRT,TRC04 JUMP IF NO OLD TRACE ! 22295: MOV TRLBL(XL),XL ELSE DELETE OLD TRACE ASSOCIATION ! 22296: * ! 22297: * HERE WITH OLD LABEL TRACE ASSOCIATION DELETED ! 22298: * ! 22299: TRC04 BEQ XL,=STNDL,TRC16 ERROR IF UNDEFINED LABEL ! 22300: MOV (XS)+,WB GET TRBLK PTR AGAIN ! 22301: BZE WB,TRC05 JUMP IF STOPTR CASE ! 22302: MOV WB,VRLBL(XR) ELSE SET NEW TRBLK POINTER ! 22303: MOV =B$VRT,VRTRA(XR) SET LABEL TRACE ROUTINE ADDRESS ! 22304: MOV WB,XR COPY TRBLK POINTER ! 22305: MOV XL,TRLBL(XR) STORE REAL LABEL IN TRBLK ! 22306: EXI RETURN ! 22307: * ! 22308: * HERE FOR STOPTR CASE FOR LABEL ! 22309: * ! 22310: TRC05 MOV XL,VRLBL(XR) STORE LABEL PTR BACK IN VRBLK ! 22311: MOV =B$VRG,VRTRA(XR) STORE NORMAL TRANSFER ADDRESS ! 22312: EXI RETURN ! 22313: EJC ! 22314: * ! 22315: * TRACE (CONTINUED) ! 22316: * ! 22317: * HERE FOR K (KEYWORD) ! 22318: * ! 22319: TRC06 JSR GTNVR POINT TO VRBLK ! 22320: PPM TRC16 ERROR IF NOT NATURAL VAR ! 22321: BNZ VRLEN(XR),TRC16 ERROR IF NOT SYSTEM VAR ! 22322: ICA XS POP STACK ! 22323: BZE XL,TRC07 JUMP IF STOPTR CASE ! 22324: MOV XR,TRKVR(XL) STORE VRBLK PTR IN TRBLK FOR KTREX ! 22325: * ! 22326: * MERGE HERE WITH TRBLK SET UP IN WB (OR ZERO) ! 22327: * ! 22328: TRC07 MOV VRSVP(XR),XR POINT TO SVBLK ! 22329: BEQ XR,=V$ERT,TRC08 JUMP IF ERRTYPE ! 22330: BEQ XR,=V$STC,TRC09 JUMP IF STCOUNT ! 22331: BNE XR,=V$FNC,TRC17 ELSE ERROR IF NOT FNCLEVEL ! 22332: * ! 22333: * FNCLEVEL ! 22334: * ! 22335: MOV XL,R$FNC SET/RESET FNCLEVEL TRACE ! 22336: EXI RETURN ! 22337: * ! 22338: * ERRTYPE ! 22339: * ! 22340: TRC08 MOV XL,R$ERT SET/RESET ERRTYPE TRACE ! 22341: EXI RETURN ! 22342: * ! 22343: * STCOUNT ! 22344: * ! 22345: TRC09 MOV XL,R$STC SET/RESET STCOUNT TRACE ! 22346: EXI RETURN ! 22347: EJC ! 22348: * ! 22349: * TRACE (CONTINUED) ! 22350: * ! 22351: * A,V MERGE HERE WITH TRTYP VALUE IN WC ! 22352: * ! 22353: TRC10 JSR GTVAR LOCATE VARIABLE ! 22354: PPM TRC16 ERROR IF NOT APPROPRIATE NAME ! 22355: MOV (XS)+,WB GET NEW TRBLK PTR AGAIN ! 22356: ADD XL,WA POINT TO VARIABLE LOCATION ! 22357: MOV WA,XR COPY VARIABLE POINTER ! 22358: * ! 22359: * LOOP TO SEARCH TRBLK CHAIN ! 22360: * ! 22361: TRC11 MOV (XR),XL POINT TO NEXT ENTRY ! 22362: BNE (XL),=B$TRT,TRC13 JUMP IF NOT TRBLK ! 22363: BLT WC,TRTYP(XL),TRC13 JUMP IF TOO FAR OUT ON CHAIN ! 22364: BEQ WC,TRTYP(XL),TRC12 JUMP IF THIS MATCHES OUR TYPE ! 22365: ADD *TRNXT,XL ELSE POINT TO LINK FIELD ! 22366: MOV XL,XR COPY POINTER ! 22367: BRN TRC11 AND LOOP BACK ! 22368: * ! 22369: * HERE TO DELETE AN OLD TRBLK OF THE TYPE WE WERE GIVEN ! 22370: * ! 22371: TRC12 MOV TRNXT(XL),XL GET PTR TO NEXT BLOCK OR VALUE ! 22372: MOV XL,(XR) STORE TO DELETE THIS TRBLK ! 22373: * ! 22374: * HERE AFTER DELETING ANY OLD ASSOCIATION OF THIS TYPE ! 22375: * ! 22376: TRC13 BZE WB,TRC14 JUMP IF STOPTR CASE ! 22377: MOV WB,(XR) ELSE LINK NEW TRBLK IN ! 22378: MOV WB,XR COPY TRBLK POINTER ! 22379: MOV XL,TRNXT(XR) STORE FORWARD POINTER ! 22380: MOV WC,TRTYP(XR) STORE APPROPRIATE TRAP TYPE CODE ! 22381: * ! 22382: * HERE TO MAKE SURE VRGET,VRSTO ARE SET PROPERLY ! 22383: * ! 22384: TRC14 MOV WA,XR RECALL POSSIBLE VRBLK POINTER ! 22385: SUB *VRVAL,XR POINT BACK TO VRBLK ! 22386: JSR SETVR SET FIELDS IF VRBLK ! 22387: EXI RETURN ! 22388: * ! 22389: * HERE FOR BAD TRACE TYPE ! 22390: * ! 22391: TRC15 EXI 2 TAKE BAD TRACE TYPE ERROR EXIT ! 22392: * ! 22393: * POP STACK BEFORE FAILING ! 22394: * ! 22395: TRC16 ICA XS POP STACK ! 22396: * ! 22397: * HERE FOR BAD NAME ARGUMENT ! 22398: * ! 22399: TRC17 EXI 1 TAKE BAD NAME ERROR EXIT ! 22400: ENP END PROCEDURE TRACE ! 22401: EJC ! 22402: * ! 22403: * TRBLD -- BUILD TRBLK ! 22404: * ! 22405: * TRBLK IS USED BY THE INPUT, OUTPUT AND TRACE FUNCTIONS ! 22406: * TO CONSTRUCT A TRBLK (TRAP BLOCK) ! 22407: * ! 22408: * (XR) TRTAG OR TRTER ! 22409: * (XL) TRFNC OR TRFPT ! 22410: * (WB) TRTYP ! 22411: * JSR TRBLD CALL TO BUILD TRBLK ! 22412: * (XR) POINTER TO TRBLK ! 22413: * (WA) DESTROYED ! 22414: * ! 22415: TRBLD PRC E,0 ENTRY POINT ! 22416: MOV XR,-(XS) STACK TRTAG (OR TRFNM) ! 22417: MOV *TRSI$,WA SET SIZE OF TRBLK ! 22418: JSR ALLOC ALLOCATE TRBLK ! 22419: MOV =B$TRT,(XR) STORE FIRST WORD ! 22420: MOV XL,TRFNC(XR) STORE TRFNC (OR TRFPT) ! 22421: MOV (XS)+,TRTAG(XR) STORE TRTAG (OR TRFNM) ! 22422: MOV WB,TRTYP(XR) STORE TYPE ! 22423: MOV =NULLS,TRVAL(XR) FOR NOW, A NULL VALUE ! 22424: EXI RETURN TO CALLER ! 22425: ENP END PROCEDURE TRBLD ! 22426: EJC ! 22427: * ! 22428: * TRIMR -- TRIM TRAILING BLANKS ! 22429: * ! 22430: * TRIMR IS PASSED A POINTER TO AN SCBLK WHICH MUST BE THE ! 22431: * LAST BLOCK IN DYNAMIC STORAGE. TRAILING BLANKS ARE ! 22432: * TRIMMED OFF AND THE DYNAMIC STORAGE POINTER RESET TO ! 22433: * THE END OF THE (POSSIBLY) SHORTENED BLOCK. ! 22434: * ! 22435: * (WB) NON-ZERO TO TRIM TRAILING BLANKS ! 22436: * (XR) POINTER TO STRING TO TRIM ! 22437: * JSR TRIMR CALL TO TRIM STRING ! 22438: * (XR) POINTER TO TRIMMED STRING ! 22439: * (XL,WA,WB,WC) DESTROYED ! 22440: * ! 22441: * THE CALL WITH WB ZERO STILL PERFORMS THE END ZERO PAD ! 22442: * AND DNAMP READJUSTMENT. IT IS USED FROM ACESS IF KVTRM=0. ! 22443: * ! 22444: TRIMR PRC E,0 ENTRY POINT ! 22445: MOV XR,XL COPY STRING POINTER ! 22446: MOV SCLEN(XR),WA LOAD STRING LENGTH ! 22447: BZE WA,TRIM2 JUMP IF NULL INPUT ! 22448: PLC XL,WA ELSE POINT PAST LAST CHARACTER ! 22449: BZE WB,TRIM3 JUMP IF NO TRIM ! 22450: MOV =CH$BL,WC LOAD BLANK CHARACTER ! 22451: * ! 22452: * LOOP THROUGH CHARACTERS FROM RIGHT TO LEFT ! 22453: * ! 22454: TRIM0 LCH WB,-(XL) LOAD NEXT CHARACTER ! 22455: .IF .CAHT ! 22456: BEQ WB,=CH$HT,TRIM1 JUMP IF HORIZONTAL TAB ! 22457: .FI ! 22458: BNE WB,WC,TRIM3 JUMP IF NON-BLANK FOUND ! 22459: TRIM1 DCV WA ELSE DECREMENT CHARACTER COUNT ! 22460: BNZ WA,TRIM0 LOOP BACK IF MORE TO CHECK ! 22461: * ! 22462: * HERE IF RESULT IS NULL (NULL OR ALL-BLANK INPUT) ! 22463: * ! 22464: TRIM2 MOV XR,DNAMP WIPE OUT INPUT STRING BLOCK ! 22465: MOV =NULLS,XR LOAD NULL RESULT ! 22466: BRN TRIM5 MERGE TO EXIT ! 22467: EJC ! 22468: * ! 22469: * TRIMR (CONTINUED) ! 22470: * ! 22471: * HERE WITH NON-BLANK FOUND (MERGE FOR NO TRIM) ! 22472: * ! 22473: TRIM3 MOV WA,SCLEN(XR) SET NEW LENGTH ! 22474: MOV XR,XL COPY STRING POINTER ! 22475: PSC XL,WA READY FOR STORING BLANKS ! 22476: CTB WA,SCHAR GET LENGTH OF BLOCK IN BYTES ! 22477: ADD XR,WA POINT PAST NEW BLOCK ! 22478: MOV WA,DNAMP SET NEW TOP OF STORAGE POINTER ! 22479: LCT WA,=CFP$C GET COUNT OF CHARS IN WORD ! 22480: ZER WC SET BLANK CHAR ! 22481: * ! 22482: * LOOP TO ZERO PAD LAST WORD OF CHARACTERS ! 22483: * ! 22484: TRIM4 SCH WC,(XL)+ STORE ZERO CHARACTER ! 22485: BCT WA,TRIM4 LOOP BACK TILL ALL STORED ! 22486: CSC XL COMPLETE STORE CHARACTERS ! 22487: * ! 22488: * COMMON EXIT POINT ! 22489: * ! 22490: TRIM5 ZER XL CLEAR GARBAGE XL POINTER ! 22491: EXI RETURN TO CALLER ! 22492: ENP END PROCEDURE TRIMR ! 22493: EJC ! 22494: * ! 22495: * TRXEQ -- EXECUTE FUNCTION TYPE TRACE ! 22496: * ! 22497: * TRXEQ IS USED TO EXECUTE A TRACE WHEN A FOURTH ARGUMENT ! 22498: * HAS BEEN SUPPLIED. TRACE HAS ALREADY BEEN DECREMENTED. ! 22499: * ! 22500: * (XR) POINTER TO TRBLK ! 22501: * (XL,WA) NAME BASE,OFFSET FOR VARIABLE ! 22502: * JSR TRXEQ CALL TO EXECUTE TRACE ! 22503: * (WB,WC,RA) DESTROYED ! 22504: * ! 22505: * THE FOLLOWING STACK ENTRIES ARE MADE BEFORE PASSING ! 22506: * CONTROL TO THE TRACE FUNCTION USING THE CFUNC ROUTINE. ! 22507: * ! 22508: * TRXEQ RETURN POINT WORD(S) ! 22509: * SAVED VALUE OF TRACE KEYWORD ! 22510: * TRBLK POINTER ! 22511: * NAME BASE ! 22512: * NAME OFFSET ! 22513: * SAVED VALUE OF R$COD ! 22514: * SAVED CODE PTR (-R$COD) ! 22515: * SAVED VALUE OF FLPTR ! 22516: * FLPTR --------------- ZERO (DUMMY FAIL OFFSET) ! 22517: * NMBLK FOR VARIABLE NAME ! 22518: * XS ------------------ TRACE TAG ! 22519: * ! 22520: * R$COD AND THE CODE PTR ARE SET TO DUMMY VALUES WHICH ! 22521: * CAUSE CONTROL TO RETURN TO THE TRXEQ PROCEDURE ON SUCCESS ! 22522: * OR FAILURE (TRXEQ IGNORES A FAILURE CONDITION). ! 22523: * ! 22524: TRXEQ PRC R,0 ENTRY POINT (RECURSIVE) ! 22525: MOV R$COD,WC LOAD CODE BLOCK POINTER ! 22526: SCP WB GET CURRENT CODE POINTER ! 22527: SUB WC,WB MAKE CODE POINTER INTO OFFSET ! 22528: MOV KVTRA,-(XS) STACK TRACE KEYWORD VALUE ! 22529: MOV XR,-(XS) STACK TRBLK POINTER ! 22530: MOV XL,-(XS) STACK NAME BASE ! 22531: MOV WA,-(XS) STACK NAME OFFSET ! 22532: MOV WC,-(XS) STACK CODE BLOCK POINTER ! 22533: MOV WB,-(XS) STACK CODE POINTER OFFSET ! 22534: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER ! 22535: ZER -(XS) SET DUMMY FAIL OFFSET ! 22536: MOV XS,FLPTR SET NEW FAILURE POINTER ! 22537: ZER KVTRA RESET TRACE KEYWORD TO ZERO ! 22538: MOV =TRXDC,WC LOAD NEW (DUMMY) CODE BLK POINTER ! 22539: MOV WC,R$COD SET AS CODE BLOCK POINTER ! 22540: LCP WC AND NEW CODE POINTER ! 22541: EJC ! 22542: * ! 22543: * TRXEQ (CONTINUED) ! 22544: * ! 22545: * NOW PREPARE ARGUMENTS FOR FUNCTION ! 22546: * ! 22547: MOV WA,WB SAVE NAME OFFSET ! 22548: MOV *NMSI$,WA LOAD NMBLK SIZE ! 22549: JSR ALLOC ALLOCATE SPACE FOR NMBLK ! 22550: MOV =B$NML,(XR) SET TYPE WORD ! 22551: MOV XL,NMBAS(XR) STORE NAME BASE ! 22552: MOV WB,NMOFS(XR) STORE NAME OFFSET ! 22553: MOV 6(XS),XL RELOAD POINTER TO TRBLK ! 22554: MOV XR,-(XS) STACK NMBLK POINTER (1ST ARGUMENT) ! 22555: MOV TRTAG(XL),-(XS) STACK TRACE TAG (2ND ARGUMENT) ! 22556: MOV TRFNC(XL),XL LOAD TRACE FUNCTION POINTER ! 22557: MOV =NUM02,WA SET NUMBER OF ARGUMENTS TO TWO ! 22558: BRN CFUNC JUMP TO CALL FUNCTION ! 22559: * ! 22560: * SEE O$TXR FOR DETAILS OF RETURN TO THIS POINT ! 22561: * ! 22562: TRXQ1 MOV FLPTR,XS POINT BACK TO OUR STACK ENTRIES ! 22563: ICA XS POP OFF GARBAGE FAIL OFFSET ! 22564: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER ! 22565: MOV (XS)+,WB RELOAD CODE OFFSET ! 22566: MOV (XS)+,WC LOAD OLD CODE BASE POINTER ! 22567: MOV WC,XR COPY CDBLK POINTER ! 22568: MOV CDSTM(XR),KVSTN RESTORE STMNT NO ! 22569: MOV (XS)+,WA RELOAD NAME OFFSET ! 22570: MOV (XS)+,XL RELOAD NAME BASE ! 22571: MOV (XS)+,XR RELOAD TRBLK POINTER ! 22572: MOV (XS)+,KVTRA RESTORE TRACE KEYWORD VALUE ! 22573: ADD WC,WB RECOMPUTE ABSOLUTE CODE POINTER ! 22574: LCP WB RESTORE CODE POINTER ! 22575: MOV WC,R$COD AND CODE BLOCK POINTER ! 22576: EXI RETURN TO TRXEQ CALLER ! 22577: ENP END PROCEDURE TRXEQ ! 22578: EJC ! 22579: * ! 22580: * XSCAN -- EXECUTION FUNCTION ARGUMENT SCAN ! 22581: * ! 22582: * XSCAN SCANS OUT ONE TOKEN IN A PROTOTYPE ARGUMENT IN ! 22583: * ARRAY,CLEAR,DATA,DEFINE,LOAD FUNCTION CALLS. XSCAN ! 22584: * CALLS MUST BE PRECEDED BY A CALL TO THE INITIALIZATION ! 22585: * PROCEDURE XSCNI. THE FOLLOWING VARIABLES ARE USED. ! 22586: * ! 22587: * R$XSC POINTER TO SCBLK FOR FUNCTION ARG ! 22588: * XSOFS OFFSET (NUM CHARS SCANNED SO FAR) ! 22589: * ! 22590: * (WC) DELIMITER ONE (CH$XX) ! 22591: * (XL) DELIMITER TWO (CH$XX) ! 22592: * JSR XSCAN CALL TO SCAN NEXT ITEM ! 22593: * (XR) POINTER TO SCBLK FOR TOKEN SCANNED ! 22594: * (WA) COMPLETION CODE (SEE BELOW) ! 22595: * (WC,XL) DESTROYED ! 22596: * ! 22597: * THE SCAN STARTS FROM THE CURRENT POSITION AND CONTINUES ! 22598: * UNTIL ONE OF THE FOLLOWING THREE CONDITIONS OCCURS. ! 22599: * ! 22600: * 1) DELIMITER ONE IS ENCOUNTERED (WA SET TO 1) ! 22601: * ! 22602: * 2) DELIMITER TWO ENCOUNTERED (WA SET TO 2) ! 22603: * ! 22604: * 3) END OF STRING ENCOUNTERED (WA SET TO 0) ! 22605: * ! 22606: * THE RESULT IS A STRING CONTAINING ALL CHARACTERS SCANNED ! 22607: * UP TO BUT NOT INCLUDING ANY DELIMITER CHARACTER. ! 22608: * THE POINTER IS LEFT POINTING PAST THE DELIMITER. ! 22609: * ! 22610: * IF ONLY ONE DELIMITER IS TO BE DETECTED, DELIMITER ONE ! 22611: * AND DELIMITER TWO SHOULD BE SET TO THE SAME VALUE. ! 22612: * ! 22613: * IN THE CASE WHERE THE END OF STRING IS ENCOUNTERED, THE ! 22614: * STRING INCLUDES ALL THE CHARACTERS TO THE END OF THE ! 22615: * STRING. NO FURTHER CALLS CAN BE MADE TO XSCAN UNTIL ! 22616: * XSCNI IS CALLED TO INITIALIZE A NEW ARGUMENT SCAN ! 22617: EJC ! 22618: * ! 22619: * XSCAN (CONTINUED) ! 22620: * ! 22621: XSCAN PRC E,0 ENTRY POINT ! 22622: MOV WB,XSCWB PRESERVE WB ! 22623: MOV R$XSC,XR POINT TO ARGUMENT STRING ! 22624: MOV SCLEN(XR),WA LOAD STRING LENGTH ! 22625: MOV XSOFS,WB LOAD CURRENT OFFSET ! 22626: SUB WB,WA GET NUMBER OF REMAINING CHARACTERS ! 22627: BZE WA,XSCN2 JUMP IF NO CHARACTERS LEFT ! 22628: PLC XR,WB POINT TO CURRENT CHARACTER ! 22629: * ! 22630: * LOOP TO SEARCH FOR DELIMITER ! 22631: * ! 22632: XSCN1 LCH WB,(XR)+ LOAD NEXT CHARACTER ! 22633: BEQ WB,WC,XSCN3 JUMP IF DELIMITER ONE FOUND ! 22634: BEQ WB,XL,XSCN4 JUMP IF DELIMITER TWO FOUND ! 22635: DCV WA DECREMENT COUNT OF CHARS LEFT ! 22636: BNZ WA,XSCN1 LOOP BACK IF MORE CHARS TO GO ! 22637: * ! 22638: * HERE FOR RUNOUT ! 22639: * ! 22640: XSCN2 MOV R$XSC,XL POINT TO STRING BLOCK ! 22641: MOV SCLEN(XL),WA GET STRING LENGTH ! 22642: MOV XSOFS,WB LOAD OFFSET ! 22643: SUB WB,WA GET SUBSTRING LENGTH ! 22644: ZER R$XSC CLEAR STRING PTR FOR COLLECTOR ! 22645: ZER XSCRT SET ZERO (RUNOUT) RETURN CODE ! 22646: BRN XSCN6 JUMP TO EXIT ! 22647: EJC ! 22648: * ! 22649: * XSCAN (CONTINUED) ! 22650: * ! 22651: * HERE IF DELIMITER ONE FOUND ! 22652: * ! 22653: XSCN3 MOV =NUM01,XSCRT SET RETURN CODE ! 22654: BRN XSCN5 JUMP TO MERGE ! 22655: * ! 22656: * HERE IF DELIMITER TWO FOUND ! 22657: * ! 22658: XSCN4 MOV =NUM02,XSCRT SET RETURN CODE ! 22659: * ! 22660: * MERGE HERE AFTER DETECTING A DELIMITER ! 22661: * ! 22662: XSCN5 MOV R$XSC,XL RELOAD POINTER TO STRING ! 22663: MOV SCLEN(XL),WC GET ORIGINAL LENGTH OF STRING ! 22664: SUB WA,WC MINUS CHARS LEFT = CHARS SCANNED ! 22665: MOV WC,WA MOVE TO REG FOR SBSTR ! 22666: MOV XSOFS,WB SET OFFSET ! 22667: SUB WB,WA COMPUTE LENGTH FOR SBSTR ! 22668: ICV WC ADJUST NEW CURSOR PAST DELIMITER ! 22669: MOV WC,XSOFS STORE NEW OFFSET ! 22670: * ! 22671: * COMMON EXIT POINT ! 22672: * ! 22673: XSCN6 ZER XR CLEAR GARBAGE CHARACTER PTR IN XR ! 22674: JSR SBSTR BUILD SUB-STRING ! 22675: MOV XSCRT,WA LOAD RETURN CODE ! 22676: MOV XSCWB,WB RESTORE WB ! 22677: EXI RETURN TO XSCAN CALLER ! 22678: ENP END PROCEDURE XSCAN ! 22679: EJC ! 22680: * ! 22681: * XSCNI -- EXECUTION FUNCTION ARGUMENT SCAN ! 22682: * ! 22683: * XSCNI INITIALIZES THE SCAN USED FOR PROTOTYPE ARGUMENTS ! 22684: * IN THE CLEAR, DEFINE, LOAD, DATA, ARRAY FUNCTIONS. SEE ! 22685: * XSCAN FOR THE PROCEDURE WHICH IS USED AFTER THIS CALL. ! 22686: * ! 22687: * -(XS) ARGUMENT TO BE SCANNED (ON STACK) ! 22688: * JSR XSCNI CALL TO SCAN ARGUMENT ! 22689: * PPM LOC TRANSFER LOC IF ARG IS NOT STRING ! 22690: * PPM LOC TRANSFER LOC IF ARGUMENT IS NULL ! 22691: * (XS) POPPED ! 22692: * (XR,R$XSC) ARGUMENT (SCBLK PTR) ! 22693: * (WA) ARGUMENT LENGTH ! 22694: * (IA,RA) DESTROYED ! 22695: * ! 22696: XSCNI PRC N,2 ENTRY POINT ! 22697: JSR GTSTG FETCH ARGUMENT AS STRING ! 22698: PPM XSCI1 JUMP IF NOT CONVERTIBLE ! 22699: MOV XR,R$XSC ELSE STORE SCBLK PTR FOR XSCAN ! 22700: ZER XSOFS SET OFFSET TO ZERO ! 22701: BZE WA,XSCI2 JUMP IF NULL STRING ! 22702: EXI RETURN TO XSCNI CALLER ! 22703: * ! 22704: * HERE IF ARGUMENT IS NOT A STRING ! 22705: * ! 22706: XSCI1 EXI 1 TAKE NOT-STRING ERROR EXIT ! 22707: * ! 22708: * HERE FOR NULL STRING ! 22709: * ! 22710: XSCI2 EXI 2 TAKE NULL-STRING ERROR EXIT ! 22711: ENP END PROCEDURE XSCNI ! 22712: TTL S P I T B O L -- UTILITY ROUTINES ! 22713: * ! 22714: * THE FOLLOWING SECTION CONTAINS UTILITY ROUTINES USED FOR ! 22715: * VARIOUS PURPOSES THROUGHOUT THE SYSTEM. THESE DIFFER ! 22716: * FROM THE PROCEDURES IN THE UTILITY PROCEDURES SECTION IN ! 22717: * THEY ARE NOT IN PROCEDURE FORM AND THEY DO NOT RETURN ! 22718: * TO THEIR CALLERS. THEY ARE ACCESSED WITH A BRANCH TYPE ! 22719: * INSTRUCTION AFTER SETTING THE REGISTERS TO APPROPRIATE ! 22720: * PARAMETER VALUES. ! 22721: * ! 22722: * THE REGISTER VALUES REQUIRED FOR EACH ROUTINE ARE ! 22723: * DOCUMENTED AT THE START OF EACH ROUTINE. REGISTERS NOT ! 22724: * MENTIONED MAY CONTAIN ANY VALUES EXCEPT THAT XR,XL ! 22725: * CAN ONLY CONTAIN PROPER COLLECTABLE POINTERS. ! 22726: * ! 22727: * SOME OF THESE ROUTINES WILL TOLERATE GARBAGE POINTERS ! 22728: * IN XL,XR ON ENTRY. THIS IS ALWAYS DOCUMENTED AND IN ! 22729: * EACH CASE, THE ROUTINE CLEARS THESE GARBAGE VALUES BEFORE ! 22730: * EXITING AFTER COMPLETING ITS TASK. ! 22731: * ! 22732: * THE ROUTINES HAVE NAMES CONSISTING OF FIVE LETTERS ! 22733: * AND ARE ASSEMBLED IN ALPHABETICAL ORDER. ! 22734: EJC ! 22735: * ARREF -- ARRAY REFERENCE ! 22736: * ! 22737: * (XL) MAY BE NON-COLLECTABLE ! 22738: * (XR) NUMBER OF SUBSCRIPTS ! 22739: * (WB) SET ZERO/NONZERO FOR VALUE/NAME ! 22740: * THE VALUE IN WB MUST BE COLLECTABLE ! 22741: * STACK SUBSCRIPTS AND ARRAY OPERAND ! 22742: * BRN ARREF JUMP TO CALL FUNCTION ! 22743: * ! 22744: * ARREF CONTINUES BY EXECUTING THE NEXT CODE WORD WITH ! 22745: * THE RESULT NAME OR VALUE PLACED ON TOP OF THE STACK. ! 22746: * TO DEAL WITH THE PROBLEM OF ACCESSING SUBSCRIPTS IN THE ! 22747: * ORDER OF STACKING, XL IS USED AS A SUBSCRIPT POINTER ! 22748: * WORKING BELOW THE STACK POINTER. ! 22749: * ! 22750: ARREF RTN ! 22751: MOV XR,WA COPY NUMBER OF SUBSCRIPTS ! 22752: MOV XS,XT POINT TO STACK FRONT ! 22753: WTB XR CONVERT TO BYTE OFFSET ! 22754: ADD XR,XT POINT TO ARRAY OPERAND ON STACK ! 22755: ICA XT FINAL VALUE FOR STACK POPPING ! 22756: MOV XT,ARFXS KEEP FOR LATER ! 22757: MOV -(XT),XR LOAD ARRAY OPERAND POINTER ! 22758: MOV XR,R$ARF KEEP ARRAY POINTER ! 22759: MOV XT,XR SAVE POINTER TO SUBSCRIPTS ! 22760: MOV R$ARF,XL POINT XL TO POSSIBLE VCBLK OR TBBLK ! 22761: MOV (XL),WC LOAD FIRST WORD ! 22762: BEQ WC,=B$ART,ARF01 JUMP IF ARBLK ! 22763: BEQ WC,=B$VCT,ARF07 JUMP IF VCBLK ! 22764: BEQ WC,=B$TBT,ARF10 JUMP IF TBBLK ! 22765: ERB 235,SUBSCRIPTED OPERAND IS NOT TABLE OR ARRAY ! 22766: * ! 22767: * HERE FOR ARRAY (ARBLK) ! 22768: * ! 22769: ARF01 BNE WA,ARNDM(XL),ARF09 JUMP IF WRONG NUMBER OF DIMS ! 22770: LDI INTV0 GET INITIAL SUBSCRIPT OF ZERO ! 22771: MOV XR,XT POINT BEFORE SUBSCRIPTS ! 22772: ZER WA INITIAL OFFSET TO BOUNDS ! 22773: BRN ARF03 JUMP INTO LOOP ! 22774: * ! 22775: * LOOP TO COMPUTE SUBSCRIPTS BY MULTIPLICATIONS ! 22776: * ! 22777: ARF02 MLI ARDM2(XR) MULTIPLY TOTAL BY NEXT DIMENSION ! 22778: * ! 22779: * MERGE HERE FIRST TIME ! 22780: * ! 22781: ARF03 MOV -(XT),XR LOAD NEXT SUBSCRIPT ! 22782: STI ARFSI SAVE CURRENT SUBSCRIPT ! 22783: LDI ICVAL(XR) LOAD INTEGER VALUE IN CASE ! 22784: BEQ (XR),=B$ICL,ARF04 JUMP IF IT WAS AN INTEGER ! 22785: EJC ! 22786: * ! 22787: * ARREF (CONTINUED) ! 22788: * ! 22789: * ! 22790: JSR GTINT CONVERT TO INTEGER ! 22791: PPM ARF12 JUMP IF NOT INTEGER ! 22792: LDI ICVAL(XR) IF OK, LOAD INTEGER VALUE ! 22793: * ! 22794: * HERE WITH INTEGER SUBSCRIPT IN (IA) ! 22795: * ! 22796: ARF04 MOV R$ARF,XR POINT TO ARRAY ! 22797: ADD WA,XR OFFSET TO NEXT BOUNDS ! 22798: SBI ARLBD(XR) SUBTRACT LOW BOUND TO COMPARE ! 22799: IOV ARF13 OUT OF RANGE FAIL IF OVERFLOW ! 22800: ILT ARF13 OUT OF RANGE FAIL IF TOO SMALL ! 22801: SBI ARDIM(XR) SUBTRACT DIMENSION ! 22802: IGE ARF13 OUT OF RANGE FAIL IF TOO LARGE ! 22803: ADI ARDIM(XR) ELSE RESTORE SUBSCRIPT OFFSET ! 22804: ADI ARFSI ADD TO CURRENT TOTAL ! 22805: ADD *ARDMS,WA POINT TO NEXT BOUNDS ! 22806: BNE XT,XS,ARF02 LOOP BACK IF MORE TO GO ! 22807: * ! 22808: * HERE WITH INTEGER SUBSCRIPT COMPUTED ! 22809: * ! 22810: MFI WA GET AS ONE WORD INTEGER ! 22811: WTB WA CONVERT TO OFFSET ! 22812: MOV R$ARF,XL POINT TO ARBLK ! 22813: ADD AROFS(XL),WA ADD OFFSET PAST BOUNDS ! 22814: ICA WA ADJUST FOR ARPRO FIELD ! 22815: BNZ WB,ARF08 EXIT WITH NAME IF NAME CALL ! 22816: * ! 22817: * MERGE HERE TO GET VALUE FOR VALUE CALL ! 22818: * ! 22819: ARF05 JSR ACESS GET VALUE ! 22820: PPM ARF13 FAIL IF ACESS FAILS ! 22821: * ! 22822: * RETURN VALUE ! 22823: * ! 22824: ARF06 MOV ARFXS,XS POP STACK ENTRIES ! 22825: ZER R$ARF FINISHED WITH ARRAY POINTER ! 22826: BRN EXIXR EXIT WITH VALUE IN XR ! 22827: EJC ! 22828: * ! 22829: * ARREF (CONTINUED) ! 22830: * ! 22831: * HERE FOR VECTOR ! 22832: * ! 22833: ARF07 BNE WA,=NUM01,ARF09 ERROR IF MORE THAN 1 SUBSCRIPT ! 22834: MOV (XS),XR ELSE LOAD SUBSCRIPT ! 22835: JSR GTINT CONVERT TO INTEGER ! 22836: PPM ARF12 ERROR IF NOT INTEGER ! 22837: LDI ICVAL(XR) ELSE LOAD INTEGER VALUE ! 22838: SBI INTV1 SUBTRACT FOR ONES OFFSET ! 22839: MFI WA,ARF13 GET SUBSCRIPT AS ONE WORD ! 22840: ADD =VCVLS,WA ADD OFFSET FOR STANDARD FIELDS ! 22841: WTB WA CONVERT OFFSET TO BYTES ! 22842: BGE WA,VCLEN(XL),ARF13 FAIL IF OUT OF RANGE SUBSCRIPT ! 22843: BZE WB,ARF05 BACK TO GET VALUE IF VALUE CALL ! 22844: * ! 22845: * RETURN NAME ! 22846: * ! 22847: ARF08 MOV ARFXS,XS POP STACK ENTRIES ! 22848: ZER R$ARF FINISHED WITH ARRAY POINTER ! 22849: BRN EXNAM ELSE EXIT WITH NAME ! 22850: * ! 22851: * HERE IF SUBSCRIPT COUNT IS WRONG ! 22852: * ! 22853: ARF09 ERB 236,ARRAY REFERENCED WITH WRONG NUMBER OF SUBSCRIPTS ! 22854: * ! 22855: * TABLE ! 22856: * ! 22857: ARF10 BNE WA,=NUM01,ARF11 ERROR IF MORE THAN 1 SUBSCRIPT ! 22858: MOV (XS),XR ELSE LOAD SUBSCRIPT ! 22859: JSR TFIND CALL TABLE SEARCH ROUTINE ! 22860: PPM ARF13 FAIL IF FAILED ! 22861: BNZ WB,ARF08 EXIT WITH NAME IF NAME CALL ! 22862: BRN ARF06 ELSE EXIT WITH VALUE ! 22863: * ! 22864: * HERE FOR BAD TABLE REFERENCE ! 22865: * ! 22866: ARF11 ERB 237,TABLE REFERENCED WITH MORE THAN ONE SUBSCRIPT ! 22867: * ! 22868: * HERE FOR BAD SUBSCRIPT ! 22869: * ! 22870: ARF12 ERB 238,ARRAY SUBSCRIPT IS NOT INTEGER ! 22871: * ! 22872: * HERE TO SIGNAL FAILURE ! 22873: * ! 22874: ARF13 ZER R$ARF FINISHED WITH ARRAY POINTER ! 22875: BRN EXFAL FAIL ! 22876: EJC ! 22877: * ! 22878: * CFUNC -- CALL A FUNCTION ! 22879: * ! 22880: * CFUNC IS USED TO CALL A SNOBOL LEVEL FUNCTION. IT IS ! 22881: * USED BY THE APPLY FUNCTION (S$APP), THE FUNCTION ! 22882: * TRACE ROUTINE (TRXEQ) AND THE MAIN FUNCTION CALL ENTRY ! 22883: * (O$FNC, O$FNS). IN THE LATTER CASES, CFUNC IS USED ONLY ! 22884: * IF THE NUMBER OF ARGUMENTS IS INCORRECT. ! 22885: * ! 22886: * (XL) POINTER TO FUNCTION BLOCK ! 22887: * (WA) ACTUAL NUMBER OF ARGUMENTS ! 22888: * (XS) POINTS TO STACKED ARGUMENTS ! 22889: * BRN CFUNC JUMP TO CALL FUNCTION ! 22890: * ! 22891: * CFUNC CONTINUES BY EXECUTING THE FUNCTION ! 22892: * ! 22893: CFUNC RTN ! 22894: BLT WA,FARGS(XL),CFNC1 JUMP IF TOO FEW ARGUMENTS ! 22895: BEQ WA,FARGS(XL),CFNC3 JUMP IF CORRECT NUMBER OF ARGS ! 22896: * ! 22897: * HERE IF TOO MANY ARGUMENTS SUPPLIED, POP THEM OFF ! 22898: * ! 22899: MOV WA,WB COPY ACTUAL NUMBER ! 22900: SUB FARGS(XL),WB GET NUMBER OF EXTRA ARGS ! 22901: WTB WB CONVERT TO BYTES ! 22902: ADD WB,XS POP OFF UNWANTED ARGUMENTS ! 22903: BRN CFNC3 JUMP TO GO OFF TO FUNCTION ! 22904: * ! 22905: * HERE IF TOO FEW ARGUMENTS ! 22906: * ! 22907: CFNC1 MOV FARGS(XL),WB LOAD REQUIRED NUMBER OF ARGUMENTS ! 22908: BEQ WB,=NINI9,CFNC3 JUMP IF CASE OF VAR NUM OF ARGS ! 22909: SUB WA,WB CALCULATE NUMBER MISSING ! 22910: LCT WB,WB SET COUNTER TO CONTROL LOOP ! 22911: * ! 22912: * LOOP TO SUPPLY EXTRA NULL ARGUMENTS ! 22913: * ! 22914: CFNC2 MOV =NULLS,-(XS) STACK A NULL ARGUMENT ! 22915: BCT WB,CFNC2 LOOP TILL PROPER NUMBER STACKED ! 22916: * ! 22917: * MERGE HERE TO JUMP TO FUNCTION ! 22918: * ! 22919: CFNC3 BRI (XL) JUMP THROUGH FCODE FIELD ! 22920: EJC ! 22921: * ! 22922: * EXFAL -- EXIT SIGNALLING SNOBOL FAILURE ! 22923: * ! 22924: * (XL,XR) MAY BE NON-COLLECTABLE ! 22925: * BRN EXFAL JUMP TO FAIL ! 22926: * ! 22927: * EXFAL CONTINUES BY EXECUTING THE APPROPRIATE FAIL GOTO ! 22928: * ! 22929: EXFAL RTN ! 22930: MOV FLPTR,XS POP STACK ! 22931: MOV (XS),XR LOAD FAILURE OFFSET ! 22932: ADD R$COD,XR POINT TO FAILURE CODE LOCATION ! 22933: LCP XR SET CODE POINTER ! 22934: BRN EXITS DO NEXT CODE WORD ! 22935: EJC ! 22936: * ! 22937: * EXINT -- EXIT WITH INTEGER RESULT ! 22938: * ! 22939: * (XL,XR) MAY BE NONCOLLECTABLE ! 22940: * (IA) INTEGER VALUE ! 22941: * BRN EXINT JUMP TO EXIT WITH INTEGER ! 22942: * ! 22943: * EXINT CONTINUES BY EXECUTING THE NEXT CODE WORD ! 22944: * WHICH IT DOES BY FALLING THROUGH TO EXIXR ! 22945: * ! 22946: EXINT RTN ! 22947: JSR ICBLD BUILD ICBLK ! 22948: EJC ! 22949: * EXIXR -- EXIT WITH RESULT IN (XR) ! 22950: * ! 22951: * (XR) RESULT ! 22952: * (XL) MAY BE NON-COLLECTABLE ! 22953: * BRN EXIXR JUMP TO EXIT WITH RESULT IN (XR) ! 22954: * ! 22955: * EXIXR CONTINUES BY EXECUTING THE NEXT CODE WORD ! 22956: * WHICH IT DOES BY FALLING THROUGH TO EXITS. ! 22957: EXIXR RTN ! 22958: * ! 22959: MOV XR,-(XS) STACK RESULT ! 22960: * ! 22961: * ! 22962: * EXITS -- EXIT WITH RESULT IF ANY STACKED ! 22963: * ! 22964: * (XR,XL) MAY BE NON-COLLECTABLE ! 22965: * ! 22966: * BRN EXITS ENTER EXITS ROUTINE ! 22967: * ! 22968: EXITS RTN ! 22969: LCW XR LOAD NEXT CODE WORD ! 22970: MOV (XR),XL LOAD ENTRY ADDRESS ! 22971: BRI XL JUMP TO EXECUTE NEXT CODE WORD ! 22972: EJC ! 22973: * ! 22974: * EXNAM -- EXIT WITH NAME IN (XL,WA) ! 22975: * ! 22976: * (XL) NAME BASE ! 22977: * (WA) NAME OFFSET ! 22978: * (XR) MAY BE NON-COLLECTABLE ! 22979: * BRN EXNAM JUMP TO EXIT WITH NAME IN (XL,WA) ! 22980: * ! 22981: * EXNAM CONTINUES BY EXECUTING THE NEXT CODE WORD ! 22982: * ! 22983: EXNAM RTN ! 22984: MOV XL,-(XS) STACK NAME BASE ! 22985: MOV WA,-(XS) STACK NAME OFFSET ! 22986: BRN EXITS DO NEXT CODE WORD ! 22987: EJC ! 22988: * ! 22989: * EXNUL -- EXIT WITH NULL RESULT ! 22990: * ! 22991: * (XL,XR) MAY BE NON-COLLECTABLE ! 22992: * BRN EXNUL JUMP TO EXIT WITH NULL VALUE ! 22993: * ! 22994: * EXNUL CONTINUES BY EXECUTING THE NEXT CODE WORD ! 22995: * ! 22996: EXNUL RTN ! 22997: MOV =NULLS,-(XS) STACK NULL VALUE ! 22998: BRN EXITS DO NEXT CODE WORD ! 22999: EJC ! 23000: .IF .CNRA ! 23001: .ELSE ! 23002: * ! 23003: * EXREA -- EXIT WITH REAL RESULT ! 23004: * ! 23005: * (XL,XR) MAY BE NON-COLLECTABLE ! 23006: * (RA) REAL VALUE ! 23007: * BRN EXREA JUMP TO EXIT WITH REAL VALUE ! 23008: * ! 23009: * EXREA CONTINUES BY EXECUTING THE NEXT CODE WORD ! 23010: * ! 23011: EXREA RTN ! 23012: JSR RCBLD BUILD RCBLK ! 23013: BRN EXIXR JUMP TO EXIT WITH RESULT IN XR ! 23014: .FI ! 23015: EJC ! 23016: * ! 23017: * EXSID -- EXIT SETTING ID FIELD ! 23018: * ! 23019: * EXSID IS USED TO EXIT AFTER BUILDING ANY OF THE FOLLOWING ! 23020: * BLOCKS (ARBLK, TBBLK, PDBLK, VCBLK). IT SETS THE IDVAL. ! 23021: * ! 23022: * (XR) PTR TO BLOCK WITH IDVAL FIELD ! 23023: * (XL) MAY BE NON-COLLECTABLE ! 23024: * BRN EXSID JUMP TO EXIT AFTER SETTING ID FIELD ! 23025: * ! 23026: * EXSID CONTINUES BY EXECUTING THE NEXT CODE WORD ! 23027: * ! 23028: EXSID RTN ! 23029: MOV CURID,WA LOAD CURRENT ID VALUE ! 23030: BNE WA,=CFP$M,EXSI1 JUMP IF NO OVERFLOW ! 23031: ZER WA ELSE RESET FOR WRAPAROUND ! 23032: * ! 23033: * HERE WITH OLD IDVAL IN WA ! 23034: * ! 23035: EXSI1 ICV WA BUMP ID VALUE ! 23036: MOV WA,CURID STORE FOR NEXT TIME ! 23037: MOV WA,IDVAL(XR) STORE ID VALUE ! 23038: BRN EXIXR EXIT WITH RESULT IN (XR) ! 23039: EJC ! 23040: * ! 23041: * EXVNM -- EXIT WITH NAME OF VARIABLE ! 23042: * ! 23043: * EXVNM EXITS AFTER STACKING A VALUE WHICH IS A NMBLK ! 23044: * REFERENCING THE NAME OF A GIVEN NATURAL VARIABLE. ! 23045: * ! 23046: * (XR) VRBLK POINTER ! 23047: * (XL) MAY BE NON-COLLECTABLE ! 23048: * BRN EXVNM EXIT WITH VRBLK POINTER IN XR ! 23049: * ! 23050: EXVNM RTN ! 23051: MOV XR,XL COPY NAME BASE POINTER ! 23052: MOV *NMSI$,WA SET SIZE OF NMBLK ! 23053: JSR ALLOC ALLOCATE NMBLK ! 23054: MOV =B$NML,(XR) STORE TYPE WORD ! 23055: MOV XL,NMBAS(XR) STORE NAME BASE ! 23056: MOV *VRVAL,NMOFS(XR) STORE NAME OFFSET ! 23057: BRN EXIXR EXIT WITH RESULT IN XR ! 23058: EJC ! 23059: * ! 23060: * FLPOP -- FAIL AND POP IN PATTERN MATCHING ! 23061: * ! 23062: * FLPOP POPS THE NODE AND CURSOR ON THE STACK AND THEN ! 23063: * DROPS THROUGH INTO FAILP TO CAUSE PATTERN FAILURE ! 23064: * ! 23065: * (XL,XR) MAY BE NON-COLLECTABLE ! 23066: * BRN FLPOP JUMP TO FAIL AND POP STACK ! 23067: * ! 23068: FLPOP RTN ! 23069: ADD *NUM02,XS POP TWO ENTRIES OFF STACK ! 23070: EJC ! 23071: * ! 23072: * FAILP -- FAILURE IN MATCHING PATTERN NODE ! 23073: * ! 23074: * FAILP IS USED AFTER FAILING TO MATCH A PATTERN NODE. ! 23075: * SEE PATTERN MATCH ROUTINES FOR DETAILS OF USE. ! 23076: * ! 23077: * (XL,XR) MAY BE NON-COLLECTABLE ! 23078: * BRN FAILP SIGNAL FAILURE TO MATCH ! 23079: * ! 23080: * FAILP CONTINUES BY MATCHING AN ALTERNATIVE FROM THE STACK ! 23081: * ! 23082: FAILP RTN ! 23083: MOV (XS)+,XR LOAD ALTERNATIVE NODE POINTER ! 23084: MOV (XS)+,WB RESTORE OLD CURSOR ! 23085: MOV (XR),XL LOAD PCODE ENTRY POINTER ! 23086: BRI XL JUMP TO EXECUTE CODE FOR NODE ! 23087: EJC ! 23088: * ! 23089: * INDIR -- COMPUTE INDIRECT REFERENCE ! 23090: * ! 23091: * (WB) NONZERO/ZERO FOR BY NAME/VALUE ! 23092: * BRN INDIR JUMP TO GET INDIRECT REF ON STACK ! 23093: * ! 23094: * INDIR CONTINUES BY EXECUTING THE NEXT CODE WORD ! 23095: * ! 23096: INDIR RTN ! 23097: MOV (XS)+,XR LOAD ARGUMENT ! 23098: BEQ (XR),=B$NML,INDR2 JUMP IF A NAME ! 23099: JSR GTNVR ELSE CONVERT TO VARIABLE ! 23100: ERR 239,INDIRECTION OPERAND IS NOT NAME ! 23101: BZE WB,INDR1 SKIP IF BY VALUE ! 23102: MOV XR,-(XS) ELSE STACK VRBLK PTR ! 23103: MOV *VRVAL,-(XS) STACK NAME OFFSET ! 23104: BRN EXITS EXIT WITH RESULT ON STACK ! 23105: * ! 23106: * HERE TO GET VALUE OF NATURAL VARIABLE ! 23107: * ! 23108: INDR1 BRI (XR) JUMP THROUGH VRGET FIELD OF VRBLK ! 23109: * ! 23110: * HERE IF OPERAND IS A NAME ! 23111: * ! 23112: INDR2 MOV NMBAS(XR),XL LOAD NAME BASE ! 23113: MOV NMOFS(XR),WA LOAD NAME OFFSET ! 23114: BNZ WB,EXNAM EXIT IF CALLED BY NAME ! 23115: JSR ACESS ELSE GET VALUE FIRST ! 23116: PPM EXFAL FAIL IF ACCESS FAILS ! 23117: BRN EXIXR ELSE RETURN WITH VALUE IN XR ! 23118: EJC ! 23119: * ! 23120: * MATCH -- INITIATE PATTERN MATCH ! 23121: * ! 23122: * (WB) MATCH TYPE CODE ! 23123: * BRN MATCH JUMP TO INITIATE PATTERN MATCH ! 23124: * ! 23125: * MATCH CONTINUES BY EXECUTING THE PATTERN MATCH. SEE ! 23126: * PATTERN MATCH ROUTINES (P$XXX) FOR FULL DETAILS. ! 23127: * ! 23128: MATCH RTN ! 23129: MOV (XS)+,XR LOAD PATTERN OPERAND ! 23130: JSR GTPAT CONVERT TO PATTERN ! 23131: ERR 240,PATTERN MATCH RIGHT OPERAND IS NOT PATTERN ! 23132: MOV XR,XL IF OK, SAVE PATTERN POINTER ! 23133: BNZ WB,MTCH1 JUMP IF NOT MATCH BY NAME ! 23134: MOV (XS),WA ELSE LOAD NAME OFFSET ! 23135: MOV XL,-(XS) SAVE PATTERN POINTER ! 23136: MOV 2(XS),XL LOAD NAME BASE ! 23137: JSR ACESS ACCESS SUBJECT VALUE ! 23138: PPM EXFAL FAIL IF ACCESS FAILS ! 23139: MOV (XS),XL RESTORE PATTERN POINTER ! 23140: MOV XR,(XS) STACK SUBJECT STRING VAL FOR MERGE ! 23141: ZER WB RESTORE TYPE CODE ! 23142: * ! 23143: * MERGE HERE WITH SUBJECT VALUE ON STACK ! 23144: * ! 23145: .IF .CNBF ! 23146: MTCH1 JSR GTSTG CONVERT SUBJECT TO STRING ! 23147: .ELSE ! 23148: MTCH1 MOV (XS),XR LOAD SUBJECT VALUE ! 23149: ZER R$PMB ASSUME NOT A BUFFER ! 23150: BNE (XR),=B$BCT,MTCHA BRANCH IF NOT ! 23151: ICA XS ELSE POP VALUE ! 23152: MOV XR,R$PMB SAVE POINTER ! 23153: MOV BCLEN(XR),WA GET DEFINED LENGTH ! 23154: MOV BCBUF(XR),XR POINT TO BFBLK ! 23155: BRN MTCHB ! 23156: * ! 23157: * HERE IF NOT BUFFER TO CONVERT TO STRING ! 23158: * ! 23159: MTCHA JSR GTSTG NOT BUFFER - CONVERT TO STRING ! 23160: .FI ! 23161: ERR 241,PATTERN MATCH LEFT OPERAND IS NOT STRING ! 23162: * ! 23163: * MERGE WITH BUFFER OR STRING ! 23164: * ! 23165: MTCHB MOV XR,R$PMS IF OK, STORE SUBJECT STRING POINTER ! 23166: MOV WA,PMSSL AND LENGTH ! 23167: MOV WB,-(XS) STACK MATCH TYPE CODE ! 23168: ZER -(XS) STACK INITIAL CURSOR (ZERO) ! 23169: ZER WB SET INITIAL CURSOR ! 23170: MOV XS,PMHBS SET HISTORY STACK BASE PTR ! 23171: ZER PMDFL RESET PATTERN ASSIGNMENT FLAG ! 23172: MOV XL,XR SET INITIAL NODE POINTER ! 23173: BNZ KVANC,MTCH2 JUMP IF ANCHORED ! 23174: * ! 23175: * HERE FOR UNANCHORED ! 23176: * ! 23177: MOV XR,-(XS) STACK INITIAL NODE POINTER ! 23178: MOV =NDUNA,-(XS) STACK POINTER TO ANCHOR MOVE NODE ! 23179: BRI (XR) START MATCH OF FIRST NODE ! 23180: * ! 23181: * HERE IN ANCHORED MODE ! 23182: * ! 23183: MTCH2 ZER -(XS) DUMMY CURSOR VALUE ! 23184: MOV =NDABO,-(XS) STACK POINTER TO ABORT NODE ! 23185: BRI (XR) START MATCH OF FIRST NODE ! 23186: EJC ! 23187: * ! 23188: * RETRN -- RETURN FROM FUNCTION ! 23189: * ! 23190: * (WA) STRING POINTER FOR RETURN TYPE ! 23191: * BRN RETRN JUMP TO RETURN FROM (SNOBOL) FUNC ! 23192: * ! 23193: * RETRN CONTINUES BY EXECUTING THE CODE AT THE RETURN POINT ! 23194: * THE STACK IS CLEANED OF ANY GARBAGE LEFT BY OTHER ! 23195: * ROUTINES WHICH MAY HAVE ALTERED FLPTR SINCE FUNCTION ! 23196: * ENTRY BY USING FLPRT, RESERVED FOR USE ONLY BY ! 23197: * FUNCTION CALL AND RETURN. ! 23198: * ! 23199: RETRN RTN ! 23200: BNZ KVFNC,RTN01 JUMP IF NOT LEVEL ZERO ! 23201: ERB 242,FUNCTION RETURN FROM LEVEL ZERO ! 23202: * ! 23203: * HERE IF NOT LEVEL ZERO RETURN ! 23204: * ! 23205: RTN01 MOV FLPRT,XS POP STACK ! 23206: ICA XS REMOVE FAILURE OFFSET ! 23207: MOV (XS)+,XR POP PFBLK POINTER ! 23208: MOV (XS)+,FLPTR POP FAILURE POINTER ! 23209: MOV (XS)+,FLPRT POP OLD FLPRT ! 23210: MOV (XS)+,WB POP CODE POINTER OFFSET ! 23211: MOV (XS)+,WC POP OLD CODE BLOCK POINTER ! 23212: ADD WC,WB MAKE OLD CODE POINTER ABSOLUTE ! 23213: LCP WB RESTORE OLD CODE POINTER ! 23214: MOV WC,R$COD RESTORE OLD CODE BLOCK POINTER ! 23215: DCV KVFNC DECREMENT FUNCTION LEVEL ! 23216: MOV KVTRA,WB LOAD TRACE ! 23217: ADD KVFTR,WB ADD FTRACE ! 23218: BZE WB,RTN06 JUMP IF NO TRACING POSSIBLE ! 23219: * ! 23220: * HERE IF THERE MAY BE A TRACE ! 23221: * ! 23222: MOV WA,-(XS) SAVE FUNCTION RETURN TYPE ! 23223: MOV XR,-(XS) SAVE PFBLK POINTER ! 23224: MOV WA,KVRTN SET RTNTYPE FOR TRACE FUNCTION ! 23225: MOV R$FNC,XL LOAD FNCLEVEL TRBLK PTR (IF ANY) ! 23226: JSR KTREX EXECUTE POSSIBLE FNCLEVEL TRACE ! 23227: MOV PFVBL(XR),XL LOAD VRBLK PTR (SGD13) ! 23228: BZE KVTRA,RTN02 JUMP IF TRACE IS OFF ! 23229: MOV PFRTR(XR),XR ELSE LOAD RETURN TRACE TRBLK PTR ! 23230: BZE XR,RTN02 JUMP IF NOT RETURN TRACED ! 23231: DCV KVTRA ELSE DECREMENT TRACE COUNT ! 23232: BZE TRFNC(XR),RTN03 JUMP IF PRINT TRACE ! 23233: MOV *VRVAL,WA ELSE SET NAME OFFSET ! 23234: MOV 1(XS),KVRTN MAKE SURE RTNTYPE IS SET RIGHT ! 23235: JSR TRXEQ EXECUTE FULL TRACE ! 23236: EJC ! 23237: * ! 23238: * RETRN (CONTINUED) ! 23239: * ! 23240: * HERE TO TEST FOR FTRACE ! 23241: * ! 23242: RTN02 BZE KVFTR,RTN05 JUMP IF FTRACE IS OFF ! 23243: DCV KVFTR ELSE DECREMENT FTRACE ! 23244: * ! 23245: * HERE FOR PRINT TRACE OF FUNCTION RETURN ! 23246: * ! 23247: RTN03 JSR PRTSN PRINT STATEMENT NUMBER ! 23248: MOV 1(XS),XR LOAD RETURN TYPE ! 23249: JSR PRTST PRINT IT ! 23250: MOV =CH$BL,WA LOAD BLANK ! 23251: JSR PRTCH PRINT IT ! 23252: MOV 0(XS),XL LOAD PFBLK PTR ! 23253: MOV PFVBL(XL),XL LOAD FUNCTION VRBLK PTR ! 23254: MOV *VRVAL,WA SET VRBLK NAME OFFSET ! 23255: BNE XR,=SCFRT,RTN04 JUMP IF NOT FRETURN CASE ! 23256: * ! 23257: * FOR FRETURN, JUST PRINT FUNCTION NAME ! 23258: * ! 23259: JSR PRTNM PRINT NAME ! 23260: JSR PRTNL TERMINATE PRINT LINE ! 23261: BRN RTN05 MERGE ! 23262: * ! 23263: * HERE FOR RETURN OR NRETURN, PRINT FUNCTION NAME = VALUE ! 23264: * ! 23265: RTN04 JSR PRTNV PRINT NAME = VALUE ! 23266: * ! 23267: * HERE AFTER COMPLETING TRACE ! 23268: * ! 23269: RTN05 MOV (XS)+,XR POP PFBLK POINTER ! 23270: MOV (XS)+,WA POP RETURN TYPE STRING ! 23271: * ! 23272: * MERGE HERE IF NO TRACE REQUIRED ! 23273: * ! 23274: RTN06 MOV WA,KVRTN SET RTNTYPE KEYWORD ! 23275: MOV PFVBL(XR),XL LOAD POINTER TO FN VRBLK ! 23276: EJC ! 23277: * RETRN (CONTINUED) ! 23278: * ! 23279: * GET VALUE OF FUNCTION ! 23280: * ! 23281: RTN07 MOV XL,RTNBP SAVE BLOCK POINTER ! 23282: MOV VRVAL(XL),XL LOAD VALUE ! 23283: BEQ (XL),=B$TRT,RTN07 LOOP BACK IF TRAPPED ! 23284: MOV XL,RTNFV ELSE SAVE FUNCTION RESULT VALUE ! 23285: MOV (XS)+,RTNSV SAVE ORIGINAL FUNCTION VALUE ! 23286: .IF .CNPF ! 23287: MOV FARGS(XR),WB GET NUMBER OF ARGUMENTS ! 23288: .ELSE ! 23289: MOV (XS)+,XL POP SAVED POINTER ! 23290: BZE XL,RTN7C NO ACTION IF NONE ! 23291: BZE KVPFL,RTN7C JUMP IF NO PROFILING ! 23292: JSR PRFLU ELSE PROFILE LAST FUNC STMT ! 23293: BEQ KVPFL,=NUM02,RTN7A BRANCH ON VALUE OF PROFILE KEYWD ! 23294: * ! 23295: * HERE IF &PROFILE = 1. START TIME MUST BE FRIGGED TO ! 23296: * APPEAR EARLIER THAN IT ACTUALLY IS, BY AMOUNT USED BEFORE ! 23297: * THE CALL. ! 23298: * ! 23299: LDI PFSTM LOAD CURRENT TIME ! 23300: SBI ICVAL(XL) FRIG BY SUBTRACTING SAVED AMOUNT ! 23301: BRN RTN7B AND MERGE ! 23302: * ! 23303: * HERE IF &PROFILE = 2 ! 23304: * ! 23305: RTN7A LDI ICVAL(XL) LOAD SAVED TIME ! 23306: * ! 23307: * BOTH PROFILE TYPES MERGE HERE ! 23308: * ! 23309: RTN7B STI PFSTM STORE BACK CORRECT START TIME ! 23310: * ! 23311: * MERGE HERE IF NO PROFILING ! 23312: * ! 23313: RTN7C MOV FARGS(XR),WB GET NUMBER OF ARGS ! 23314: .FI ! 23315: ADD PFNLO(XR),WB ADD NUMBER OF LOCALS ! 23316: BZE WB,RTN10 JUMP IF NO ARGS/LOCALS ! 23317: LCT WB,WB ELSE SET LOOP COUNTER ! 23318: ADD PFLEN(XR),XR AND POINT TO END OF PFBLK ! 23319: * ! 23320: * LOOP TO RESTORE FUNCTIONS AND LOCALS ! 23321: * ! 23322: RTN08 MOV -(XR),XL LOAD NEXT VRBLK POINTER ! 23323: * ! 23324: * LOOP TO FIND VALUE BLOCK ! 23325: * ! 23326: RTN09 MOV XL,WA SAVE BLOCK POINTER ! 23327: MOV VRVAL(XL),XL LOAD POINTER TO NEXT VALUE ! 23328: BEQ (XL),=B$TRT,RTN09 LOOP BACK IF TRAPPED ! 23329: MOV WA,XL ELSE RESTORE LAST BLOCK POINTER ! 23330: MOV (XS)+,VRVAL(XL) RESTORE OLD VARIABLE VALUE ! 23331: BCT WB,RTN08 LOOP TILL ALL PROCESSED ! 23332: * ! 23333: * NOW RESTORE FUNCTION VALUE AND EXIT ! 23334: * ! 23335: RTN10 MOV RTNBP,XL RESTORE PTR TO LAST FUNCTION BLOCK ! 23336: MOV RTNSV,VRVAL(XL) RESTORE OLD FUNCTION VALUE ! 23337: MOV RTNFV,XR RELOAD FUNCTION RESULT ! 23338: MOV R$COD,XL POINT TO NEW CODE BLOCK ! 23339: MOV KVSTN,KVLST SET LASTNO FROM STNO ! 23340: MOV CDSTM(XL),KVSTN RESET PROPER STNO VALUE ! 23341: MOV KVRTN,WA LOAD RETURN TYPE ! 23342: BEQ WA,=SCRTN,EXIXR EXIT WITH RESULT IN XR IF RETURN ! 23343: BEQ WA,=SCFRT,EXFAL FAIL IF FRETURN ! 23344: EJC ! 23345: * ! 23346: * RETRN (CONTINUED) ! 23347: * ! 23348: * HERE FOR NRETURN ! 23349: * ! 23350: BEQ (XR),=B$NML,RTN11 JUMP IF IS A NAME ! 23351: JSR GTNVR ELSE TRY CONVERT TO VARIABLE NAME ! 23352: ERR 243,FUNCTION RESULT IN NRETURN IS NOT NAME ! 23353: MOV XR,XL IF OK, COPY VRBLK (NAME BASE) PTR ! 23354: MOV *VRVAL,WA SET NAME OFFSET ! 23355: BRN RTN12 AND MERGE ! 23356: * ! 23357: * HERE IF RETURNED RESULT IS A NAME ! 23358: * ! 23359: RTN11 MOV NMBAS(XR),XL LOAD NAME BASE ! 23360: MOV NMOFS(XR),WA LOAD NAME OFFSET ! 23361: * ! 23362: * MERGE HERE WITH RETURNED NAME IN (XL,WA) ! 23363: * ! 23364: RTN12 MOV XL,XR PRESERVE XL ! 23365: LCW WB LOAD NEXT WORD ! 23366: MOV XR,XL RESTORE XL ! 23367: BEQ WB,=OFNE$,EXNAM EXIT IF CALLED BY NAME ! 23368: MOV WB,-(XS) ELSE SAVE CODE WORD ! 23369: JSR ACESS GET VALUE ! 23370: PPM EXFAL FAIL IF ACCESS FAILS ! 23371: MOV XR,XL IF OK, COPY RESULT ! 23372: MOV (XS),XR RELOAD NEXT CODE WORD ! 23373: MOV XL,(XS) STORE RESULT ON STACK ! 23374: MOV (XR),XL LOAD ROUTINE ADDRESS ! 23375: BRI XL JUMP TO EXECUTE NEXT CODE WORD ! 23376: EJC ! 23377: * ! 23378: * STCOV -- SIGNAL STATEMENT COUNTER OVERFLOW ! 23379: * ! 23380: * BRN STCOV JUMP TO SIGNAL STATEMENT COUNT OFLO ! 23381: * ! 23382: * PERMIT UP TO 10 MORE STATEMENTS TO BE OBEYED SO THAT ! 23383: * SETEXIT TRAP CAN REGAIN CONTROL. ! 23384: * STCOV CONTINUES BY ISSUING THE ERROR MESSAGE ! 23385: * ! 23386: STCOV RTN ! 23387: ICV ERRFT FATAL ERROR ! 23388: LDI INTVT GET 10 ! 23389: ADI KVSTL ADD TO FORMER LIMIT ! 23390: STI KVSTL STORE AS NEW STLIMIT ! 23391: LDI INTVT GET 10 ! 23392: STI KVSTC SET AS NEW COUNT ! 23393: ERB 244,STATEMENT COUNT EXCEEDS VALUE OF STLIMIT KEYWORD ! 23394: EJC ! 23395: * ! 23396: * STMGO -- START EXECUTION OF NEW STATEMENT ! 23397: * ! 23398: * (XR) POINTER TO CDBLK FOR NEW STATEMENT ! 23399: * BRN STMGO JUMP TO EXECUTE NEW STATEMENT ! 23400: * ! 23401: * STMGO CONTINUES BY EXECUTING THE NEXT STATEMENT ! 23402: * ! 23403: STMGO RTN ! 23404: MOV XR,R$COD SET NEW CODE BLOCK POINTER ! 23405: .IF .CNPF ! 23406: MOV KVSTN,KVLST SET LASTNO ! 23407: .ELSE ! 23408: BZE KVPFL,STGO1 SKIP IF NO PROFILING ! 23409: JSR PRFLU ELSE PROFILE THE STATEMENT ! 23410: STGO1 MOV KVSTN,KVLST SET LASTNO ! 23411: .FI ! 23412: MOV CDSTM(XR),KVSTN SET STNO ! 23413: ADD *CDCOD,XR POINT TO FIRST CODE WORD ! 23414: LCP XR SET CODE POINTER ! 23415: LDI KVSTC GET STMT COUNT ! 23416: ILT EXITS OMIT COUNTING IF NEGATIVE ! 23417: IEQ STCOV FAIL IF STLIMIT REACHED ! 23418: SBI INTV1 DECREMENT ! 23419: STI KVSTC REPLACE IT ! 23420: BZE R$STC,EXITS EXIT IF NO STCOUNT TRACE ! 23421: * ! 23422: * HERE FOR STCOUNT TRACE ! 23423: * ! 23424: ZER XR CLEAR GARBAGE VALUE IN XR ! 23425: MOV R$STC,XL LOAD POINTER TO STCOUNT TRBLK ! 23426: JSR KTREX EXECUTE KEYWORD TRACE ! 23427: BRN EXITS AND THEN EXIT FOR NEXT CODE WORD ! 23428: EJC ! 23429: * ! 23430: * STOPR -- TERMINATE RUN ! 23431: * ! 23432: * (XR) POINTS TO ENDING MESSAGE ! 23433: * BRN STOPR JUMP TO TERMINATE RUN ! 23434: * ! 23435: * TERMINATE RUN AND PRINT STATISTICS. ON ENTRY XR POINTS ! 23436: * TO ENDING MESSAGE OR IS ZERO IF MESSAGE PRINTED ALREADY. ! 23437: * ! 23438: STOPR RTN ! 23439: .IF .CSAX ! 23440: BZE XR,STPRA SKIP IF SYSAX ALREADY CALLED (REG04) ! 23441: JSR SYSAX CALL AFTER EXECUTION PROC ! 23442: STPRA ADD RSMEM,DNAME USE THE RESERVE MEMORY ! 23443: .ELSE ! 23444: ADD RSMEM,DNAME USE THE RESERVE MEMORY ! 23445: .FI ! 23446: BNE XR,=ENDMS,STPR0 SKIP IF NOT NORMAL END MESSAGE ! 23447: BNZ EXSTS,STPR3 SKIP IF EXEC STATS SUPPRESSED ! 23448: ZER ERICH CLEAR ERRORS TO INT.CH. FLAG ! 23449: * ! 23450: * LOOK TO SEE IF AN ENDING MESSAGE IS SUPPLIED ! 23451: * ! 23452: STPR0 JSR PRTPG EJECT PRINTER ! 23453: BZE XR,STPR1 SKIP IF NO MESSAGE ! 23454: JSR PRTST PRINT MESSAGE ! 23455: * ! 23456: * MERGE HERE IF NO MESSAGE TO PRINT ! 23457: * ! 23458: STPR1 JSR PRTIS PRINT BLANK LINE ! 23459: MTI KVSTN GET STATEMENT NUMBER ! 23460: MOV =STPM1,XR POINT TO MESSAGE /IN STATEMENT XXX/ ! 23461: JSR PRTMX PRINT IT ! 23462: JSR SYSTM GET CURRENT TIME ! 23463: SBI TIMSX MINUS START TIME = ELAPSED EXEC TIM ! 23464: STI STPTI SAVE FOR LATER ! 23465: MOV =STPM3,XR POINT TO MSG /EXECUTION TIME MSEC / ! 23466: JSR PRTMX PRINT IT ! 23467: LDI KVSTL GET STATEMENT LIMIT ! 23468: ILT STPR2 SKIP IF NEGATIVE ! 23469: SBI KVSTC MINUS COUNTER = COUNT ! 23470: STI STPSI SAVE ! 23471: MOV =STPM2,XR POINT TO MESSAGE /STMTS EXECUTED/ ! 23472: JSR PRTMX PRINT IT ! 23473: LDI STPTI RELOAD ELAPSED TIME ! 23474: MLI INTTH *1000 (MICROSECS) ! 23475: IOV STPR2 JUMP IF WE CANNOT COMPUTE ! 23476: DVI STPSI DIVIDE BY STATEMENT COUNT ! 23477: IOV STPR2 JUMP IF OVERFLOW ! 23478: MOV =STPM4,XR POINT TO MSG (MCSEC PER STATEMENT / ! 23479: JSR PRTMX PRINT IT ! 23480: EJC ! 23481: * ! 23482: * STOPR (CONTINUED) ! 23483: * ! 23484: * MERGE TO SKIP MESSAGE (OVERFLOW OR NEGATIVE STLIMIT) ! 23485: * ! 23486: STPR2 MTI GBCNT LOAD COUNT OF COLLECTIONS ! 23487: MOV =STPM5,XR POINT TO MESSAGE /REGENERATIONS / ! 23488: JSR PRTMX PRINT IT ! 23489: JSR PRTIS ONE MORE BLANK FOR LUCK ! 23490: * ! 23491: * CHECK IF DUMP REQUESTED ! 23492: * ! 23493: .IF .CNPF ! 23494: STPR3 MOV KVDMP,XR LOAD DUMP KEYWORD ! 23495: .ELSE ! 23496: STPR3 JSR PRFLR PRINT PROFILE IF WANTED ! 23497: * ! 23498: MOV KVDMP,XR LOAD DUMP KEYWORD ! 23499: .FI ! 23500: JSR DUMPR EXECUTE DUMP IF REQUESTED ! 23501: MOV R$FCB,XL GET FCBLK CHAIN HEAD ! 23502: MOV KVABE,WA LOAD ABEND VALUE ! 23503: MOV KVCOD,WB LOAD CODE VALUE ! 23504: JSR SYSEJ EXIT TO SYSTEM ! 23505: EJC ! 23506: * ! 23507: * SUCCP -- SIGNAL SUCCESSFUL MATCH OF A PATTERN NODE ! 23508: * ! 23509: * SEE PATTERN MATCH ROUTINES FOR DETAILS ! 23510: * ! 23511: * (XR) CURRENT NODE ! 23512: * (WB) CURRENT CURSOR ! 23513: * (XL) MAY BE NON-COLLECTABLE ! 23514: * BRN SUCCP SIGNAL SUCCESSFUL PATTERN MATCH ! 23515: * ! 23516: * SUCCP CONTINUES BY MATCHING THE SUCCESSOR NODE ! 23517: * ! 23518: SUCCP RTN ! 23519: MOV PTHEN(XR),XR LOAD SUCCESSOR NODE ! 23520: MOV (XR),XL LOAD NODE CODE ENTRY ADDRESS ! 23521: BRI XL JUMP TO MATCH SUCCESSOR NODE ! 23522: EJC ! 23523: * ! 23524: * SYSAB -- PRINT /ABNORMAL END/ AND TERMINATE ! 23525: * ! 23526: SYSAB RTN ! 23527: MOV =ENDAB,XR POINT TO MESSAGE ! 23528: MOV =NUM01,KVABE SET ABEND FLAG ! 23529: JSR PRTNL SKIP TO NEW LINE ! 23530: BRN STOPR JUMP TO PACK UP ! 23531: EJC ! 23532: * ! 23533: * SYSTU -- PRINT /TIME UP/ AND TERMINATE ! 23534: * ! 23535: SYSTU RTN ! 23536: MOV =ENDTU,XR POINT TO MESSAGE ! 23537: MOV STRTU,WA GET CHARS /TU/ ! 23538: MOV WA,KVCOD PUT IN KVCOD ! 23539: MOV TIMUP,WA CHECK STATE OF TIMEUP SWITCH ! 23540: MNZ TIMUP SET SWITCH ! 23541: BNZ WA,STOPR STOP RUN IF ALREADY SET ! 23542: ERB 245,TRANSLATION/EXECUTION TIME EXPIRED ! 23543: TTL S P I T B O L -- STACK OVERFLOW SECTION ! 23544: * ! 23545: * CONTROL COMES HERE IF THE MAIN STACK OVERFLOWS ! 23546: * ! 23547: SEC START OF STACK OVERFLOW SECTION ! 23548: * ! 23549: ICV ERRFT FATAL ERROR ! 23550: MOV FLPTR,XS POP STACK TO AVOID MORE FAILS ! 23551: BNZ GBCFL,STAK1 JUMP IF GARBAGE COLLECTING ! 23552: ERB 246,STACK OVERFLOW ! 23553: * ! 23554: * NO CHANCE OF RECOVERY IN MID GARBAGE COLLECTION ! 23555: * ! 23556: STAK1 MOV =ENDSO,XR POINT TO MESSAGE ! 23557: ZER KVDMP MEMORY IS UNDUMPABLE ! 23558: BRN STOPR GIVE UP ! 23559: TTL S P I T B O L -- ERROR SECTION ! 23560: * ! 23561: * THIS SECTION OF CODE IS ENTERED WHENEVER A PROCEDURE ! 23562: * RETURN VIA AN ERR PARAMETER OR AN ERB OPCODE IS OBEYED. ! 23563: * ! 23564: * (WA) IS THE ERROR CODE ! 23565: * ! 23566: * THE GLOBAL VARIABLE STAGE INDICATES THE POINT AT WHICH ! 23567: * THE ERROR OCCURED AS FOLLOWS. ! 23568: * ! 23569: * STAGE=STGIC ERROR DURING INITIAL COMPILE ! 23570: * ! 23571: * STAGE=STGXC ERROR DURING COMPILE AT EXECUTE ! 23572: * TIME (CODE, CONVERT FUNCTION CALLS) ! 23573: * ! 23574: * STAGE=STGEV ERROR DURING COMPILATION OF ! 23575: * EXPRESSION AT EXECUTION TIME ! 23576: * (EVAL, CONVERT FUNCTION CALL). ! 23577: * ! 23578: * STAGE=STGXT ERROR AT EXECUTE TIME. COMPILER ! 23579: * NOT ACTIVE. ! 23580: * ! 23581: * STAGE=STGCE ERROR DURING INITIAL COMPILE AFTER ! 23582: * SCANNING OUT THE END LINE. ! 23583: * ! 23584: * STAGE=STGXE ERROR DURING COMPILE AT EXECUTE ! 23585: * TIME AFTER SCANNING END LINE. ! 23586: * ! 23587: * STAGE=STGEE ERROR DURING EXPRESSION EVALUATION ! 23588: * ! 23589: SEC START OF ERROR SECTION ! 23590: * ! 23591: ERROR BEQ R$CIM,=CMLAB,CMPLE JUMP IF ERROR IN SCANNING LABEL ! 23592: MOV WA,KVERT SAVE ERROR CODE ! 23593: ZER SCNRS RESET RESCAN SWITCH FOR SCANE ! 23594: ZER SCNGO RESET GOTO SWITCH FOR SCANE ! 23595: MOV STAGE,XR LOAD CURRENT STAGE ! 23596: BSW XR,STGNO JUMP TO APPROPRIATE ERROR CIRCUIT ! 23597: IFF STGIC,ERR01 INITIAL COMPILE ! 23598: IFF STGXC,ERR04 EXECUTE TIME COMPILE ! 23599: IFF STGEV,ERR04 EVAL COMPILING EXPR. ! 23600: IFF STGEE,ERR04 EVAL EVALUATING EXPR ! 23601: IFF STGXT,ERR05 EXECUTE TIME ! 23602: IFF STGCE,ERR01 COMPILE - AFTER END ! 23603: IFF STGXE,ERR04 XEQ COMPILE-PAST END ! 23604: ESW END SWITCH ON ERROR TYPE ! 23605: EJC ! 23606: * ! 23607: * ERROR DURING INITIAL COMPILE ! 23608: * ! 23609: * THE ERROR MESSAGE IS PRINTED AS PART OF THE COMPILER ! 23610: * OUTPUT. THIS PRINTOUT INCLUDES THE OFFENDING LINE (IF NOT ! 23611: * PRINTED ALREADY) AND AN ERROR FLAG UNDER THE APPROPRIATE ! 23612: * COLUMN AS INDICATED BY SCNSE UNLESS SCNSE IS SET TO ZERO. ! 23613: * ! 23614: * AFTER PRINTING THE MESSAGE, THE GENERATED CODE IS ! 23615: * MODIFIED TO AN ERROR CALL AND CONTROL IS RETURNED TO ! 23616: * THE CMPIL PROCEDURE AFTER RESETTING THE STACK POINTER. ! 23617: * ! 23618: * IF THE ERROR OCCURS AFTER THE END LINE, CONTROL RETURNS ! 23619: * IN A SLIGHTLY DIFFERENT MANNER TO ENSURE PROPER CLEANUP. ! 23620: * ! 23621: ERR01 MOV CMPXS,XS RESET STACK POINTER ! 23622: SSL CMPSS RESTORE S-R STACK PTR FOR CMPIL ! 23623: BNZ ERRSP,ERR03 JUMP IF ERROR SUPPRESS FLAG SET ! 23624: MOV ERICH,ERLST SET FLAG FOR LISTR ! 23625: JSR LISTR LIST LINE ! 23626: JSR PRTIS TERMINATE LISTING ! 23627: ZER ERLST CLEAR LISTR FLAG ! 23628: MOV SCNSE,WA LOAD SCAN ELEMENT OFFSET ! 23629: BZE WA,ERR02 SKIP IF NOT SET ! 23630: .IF .CAHT ! 23631: LCT WB,WA LOOP COUNTER ! 23632: ICV WA INCREASE FOR CH$EX ! 23633: JSR ALOCS STRING BLOCK FOR ERROR FLAG ! 23634: MOV XR,WA REMEMBER STRING PTR ! 23635: PSC XR READY FOR CHARACTER STORING ! 23636: MOV R$CIM,XL POINT TO BAD STATEMENT ! 23637: PLC XL READY TO GET CHARS ! 23638: * ! 23639: * LOOP TO REPLACE ALL CHARS BUT TABS BY BLANKS ! 23640: * ! 23641: ERRA1 LCH WC,(XL)+ GET NEXT CHAR ! 23642: BEQ WC,=CH$HT,ERRA2 SKIP IF TAB ! 23643: MOV =CH$BL,WC GET A BLANK ! 23644: EJC ! 23645: * ! 23646: * MERGE TO STORE BLANK OR TAB IN ERROR LINE ! 23647: * ! 23648: ERRA2 SCH WC,(XR)+ STORE CHAR ! 23649: BCT WB,ERRA1 LOOP ! 23650: MOV =CH$EX,XL EXCLAMATION MARK ! 23651: SCH XL,(XR) STORE AT END OF ERROR LINE ! 23652: CSC XR END OF SCH LOOP ! 23653: MOV =STNPD,PROFS ALLOW FOR STATEMENT NUMBER ! 23654: MOV WA,XR POINT TO ERROR LINE ! 23655: JSR PRTST PRINT ERROR LINE ! 23656: .ELSE ! 23657: MTI PRLEN GET PRINT BUFFER LENGTH ! 23658: MFI GTNSI STORE AS SIGNED INTEGER ! 23659: ADD =STNPD,WA ADJUST FOR STATEMENT NUMBER ! 23660: MTI WA COPY TO INTEGER ACCUMULATOR ! 23661: RMI GTNSI REMAINDER MODULO PRINT BFR LENGTH ! 23662: STI PROFS USE AS CHARACTER OFFSET ! 23663: MOV =CH$EX,WA GET EXCLAMATION MARK ! 23664: JSR PRTCH GENERATE UNDER BAD COLUMN ! 23665: .FI ! 23666: * ! 23667: * HERE AFTER PLACING ERROR FLAG AS REQUIRED ! 23668: * ! 23669: ERR02 JSR ERMSG GENERATE FLAG AND ERROR MESSAGE ! 23670: ADD =NUM03,LSTLC BUMP PAGE CTR FOR BLANK, ERROR, BLK ! 23671: ZER XR IN CASE OF FATAL ERROR ! 23672: BHI ERRFT,=NUM03,STOPR PACK UP IF SEVERAL FATALS ! 23673: * ! 23674: * COUNT ERROR, INHIBIT EXECUTION IF REQUIRED ! 23675: * ! 23676: ICV CMERC BUMP ERROR COUNT ! 23677: ADD CSWER,NOXEQ INHIBIT XEQ IF -NOERRORS ! 23678: BNE STAGE,=STGIC,CMP10 SPECIAL RETURN IF AFTER END LINE ! 23679: EJC ! 23680: * ! 23681: * LOOP TO SCAN TO END OF STATEMENT ! 23682: * ! 23683: ERR03 MOV R$CIM,XR POINT TO START OF IMAGE ! 23684: PLC XR POINT TO FIRST CHAR ! 23685: LCH XR,(XR) GET FIRST CHAR ! 23686: BEQ XR,=CH$MN,CMPCE JUMP IF ERROR IN CONTROL CARD ! 23687: ZER SCNRS CLEAR RESCAN FLAG ! 23688: MNZ ERRSP SET ERROR SUPPRESS FLAG ! 23689: JSR SCANE SCAN NEXT ELEMENT ! 23690: BNE XL,=T$SMC,ERR03 LOOP BACK IF NOT STATEMENT END ! 23691: ZER ERRSP CLEAR ERROR SUPPRESS FLAG ! 23692: * ! 23693: * GENERATE ERROR CALL IN CODE AND RETURN TO CMPIL ! 23694: * ! 23695: MOV *CDCOD,CWCOF RESET OFFSET IN CCBLK ! 23696: MOV =OCER$,WA LOAD COMPILE ERROR CALL ! 23697: JSR CDWRD GENERATE IT ! 23698: MOV CWCOF,CMSOC(XS) SET SUCCESS FILL IN OFFSET ! 23699: MNZ CMFFC(XS) SET FAILURE FILL IN FLAG ! 23700: JSR CDWRD GENERATE SUCC. FILL IN WORD ! 23701: BRN CMPSE MERGE TO GENERATE ERROR AS CDFAL ! 23702: * ! 23703: * ERROR DURING EXECUTE TIME COMPILE OR EXPRESSION EVALUATIO ! 23704: * ! 23705: * EXECUTE TIME COMPILATION IS INITIATED THROUGH GTCOD OR ! 23706: * GTEXP WHICH ARE CALLED BY COMPILE, CODE OR EVAL. ! 23707: * BEFORE CAUSING STATEMENT FAILURE THROUGH EXFAL IT IS ! 23708: * HELPFUL TO SET KEYWORD ERRTEXT AND FOR GENERALITY ! 23709: * THESE ERRORS MAY BE HANDLED BY THE SETEXIT MECHANISM. ! 23710: * ! 23711: ERR04 ZER R$CCB FORGET GARBAGE CODE BLOCK ! 23712: SSL INISS RESTORE MAIN PROG S-R STACK PTR ! 23713: JSR ERTEX GET FAIL MESSAGE TEXT ! 23714: DCA XS ENSURE STACK OK ON LOOP START ! 23715: * ! 23716: * POP STACK UNTIL FIND FLPTR FOR MOST DEEPLY NESTED PROG. ! 23717: * DEFINED FUNCTION CALL OR CALL OF EVAL / CODE. ! 23718: * ! 23719: ERRA4 ICA XS POP STACK ! 23720: BEQ XS,FLPRT,ERRC4 JUMP IF PROG DEFINED FN CALL FOUND ! 23721: BNE XS,GTCEF,ERRA4 LOOP IF NOT EVAL OR CODE CALL YET ! 23722: MOV =STGXT,STAGE RE-SET STAGE FOR EXECUTE ! 23723: MOV R$GTC,R$COD RECOVER CODE PTR ! 23724: MOV XS,FLPTR RESTORE FAIL POINTER ! 23725: ZER R$CIM FORGET POSSIBLE IMAGE ! 23726: * ! 23727: * TEST ERRLIMIT ! 23728: * ! 23729: ERRB4 BNZ KVERL,ERR07 JUMP IF ERRLIMIT NON-ZERO ! 23730: BRN EXFAL FAIL ! 23731: * ! 23732: * RETURN FROM PROG. DEFINED FUNCTION IS OUTSTANDING ! 23733: * ! 23734: ERRC4 MOV FLPTR,XS RESTORE STACK FROM FLPTR ! 23735: BRN ERRB4 MERGE ! 23736: EJC ! 23737: * ! 23738: * ERROR AT EXECUTE TIME. ! 23739: * ! 23740: * THE ACTION TAKEN ON AN ERROR IS AS FOLLOWS. ! 23741: * ! 23742: * IF ERRLIMIT KEYWORD IS ZERO, AN ABORT IS SIGNALLED, ! 23743: * SEE CODING FOR SYSTEM LABEL ABORT AT L$ABO. ! 23744: * ! 23745: * OTHERWISE, ERRLIMIT IS DECREMENTED AND AN ERRTYPE TRACE ! 23746: * GENERATED IF REQUIRED. CONTROL RETURNS EITHER VIA A JUMP ! 23747: * TO CONTINUE (TO TAKE THE FAILURE EXIT) OR A SPECIFIED ! 23748: * SETEXIT TRAP IS EXECUTED AND CONTROL PASSES TO THE TRAP. ! 23749: * IF 3 OR MORE FATAL ERRORS OCCUR AN ABORT IS SIGNALLED ! 23750: * REGARDLESS OF ERRLIMIT AND SETEXIT - LOOPING IS ALL TOO ! 23751: * PROBABLE OTHERWISE. FATAL ERRORS INCLUDE STACK OVERFLOW ! 23752: * AND EXCEEDING STLIMIT. ! 23753: * ! 23754: ERR05 SSL INISS RESTORE MAIN PROG S-R STACK PTR ! 23755: BNZ DMVCH,ERR08 JUMP IF IN MID-DUMP ! 23756: * ! 23757: * MERGE HERE FROM ERR08 ! 23758: * ! 23759: ERR06 BZE KVERL,LABO1 ABORT IF ERRLIMIT IS ZERO ! 23760: JSR ERTEX GET FAIL MESSAGE TEXT ! 23761: * ! 23762: * MERGE FROM ERR04 ! 23763: * ! 23764: ERR07 BGE ERRFT,=NUM03,LABO1 ABORT IF TOO MANY FATAL ERRORS ! 23765: DCV KVERL DECREMENT ERRLIMIT ! 23766: MOV R$ERT,XL LOAD ERRTYPE TRACE POINTER ! 23767: JSR KTREX GENERATE ERRTYPE TRACE IF REQUIRED ! 23768: MOV R$COD,R$CNT SET CDBLK PTR FOR CONTINUATION ! 23769: MOV FLPTR,XR SET PTR TO FAILURE OFFSET ! 23770: MOV (XR),STXOF SAVE FAILURE OFFSET FOR CONTINUE ! 23771: MOV R$SXC,XR LOAD SETEXIT CDBLK POINTER ! 23772: BZE XR,LCNT1 CONTINUE IF NO SETEXIT TRAP ! 23773: ZER R$SXC ELSE RESET TRAP ! 23774: MOV =NULLS,STXVR RESET SETEXIT ARG TO NULL ! 23775: MOV (XR),XL LOAD PTR TO CODE BLOCK ROUTINE ! 23776: BRI XL EXECUTE FIRST TRAP STATEMENT ! 23777: * ! 23778: * INTERRUPTED PARTLY THROUGH A DUMP WHILST STORE IS IN A ! 23779: * MESS SO DO A TIDY UP OPERATION. SEE DUMPR FOR DETAILS. ! 23780: * ! 23781: ERR08 MOV DMVCH,XR CHAIN HEAD FOR AFFECTED VRBLKS ! 23782: BZE XR,ERR06 DONE IF ZERO ! 23783: MOV (XR),DMVCH SET NEXT LINK AS CHAIN HEAD ! 23784: JSR SETVR RESTORE VRGET FIELD ! 23785: BRN ERR08 LOOP THROUGH CHAIN ! 23786: TTL S P I T B O L -- HERE ENDETH THE CODE ! 23787: * ! 23788: * END OF ASSEMBLY ! 23789: * ! 23790: END END MACRO-SPITBOL ASSEMBLY ! 23791: ! 23792: ! 23793: ! 23794: ! 23795: ! 23796: ! 23797: ! 23798: ! 23799: ! 23800: ! 23801:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.