![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to spitv35.src 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.src CVS log | Up to [Research Unix] / researchv10no / cmd / spitbol |
1.1 ! root 1: #title s p i t b o l - revision history ! 2: #page ! 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: #title s p i t b o l -- basic information ! 91: #page ! 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: #page ! 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: #page ! 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: #page ! 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: #page ! 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: #page ! 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: #page ! 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: #page ! 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: #title s p i t b o l -- procedures section ! 444: # ! 445: # THIS SECTION STARTS WITH DESCRIPTIONS OF THE OPERATING ! 446: # SYSTEM DEPENDENT PROCEDURES WHICH ARE USED BY THE SPITBOL ! 447: # TRANSLATOR. ALL SUCH PROCEDURES HAVE FIVE LETTER NAMES ! 448: # BEGINNING WITH SYS. THEY ARE LISTED IN ALPHABETICAL ! 449: # ORDER. ! 450: # ALL PROCEDURES HAVE A SPECIFICATION CONSISTING OF A ! 451: # MODEL CALL, PRECEDED BY A POSSIBLY EMPTY LIST OF REGISTER ! 452: # CONTENTS GIVING PARAMETERS AVAILABLE TO THE PROCEDURE AND ! 453: # FOLLOWED BY A POSSIBLY EMPTY LIST OF REGISTER CONTENTS ! 454: # REQUIRED ON RETURN FROM THE CALL OR WHICH MAY HAVE HAD ! 455: # THEIR CONTENTS DESTROYED. ONLY THOSE REGISTERS EXPLICITLY ! 456: # MENTIONED IN THE LIST AFTER THE CALL MAY HAVE THEIR ! 457: # VALUES CHANGED. ! 458: # THE SEGMENT OF CODE PROVIDING THE EXTERNAL PROCEDURES IS ! 459: # CONVENIENTLY REFERRED TO AS OSINT (OPERATING SYSTEM ! 460: # INTERFACE). THE SYSXX PROCEDURES IT CONTAINS PROVIDE ! 461: # FACILITIES NOT USUALLY AVAILABLE AS PRIMITIVES IN ! 462: # ASSEMBLY LANGUAGES. FOR PARTICULAR TARGET MACHINES, ! 463: # IMPLEMENTORS MAY CHOOSE FOR SOME MINIMAL OPCODES WHICH ! 464: # DO NOT HAVE REASONABLY DIRECT TRANSLATIONS, TO USE CALLS ! 465: # OF ADDITIONAL PROCEDURES WHICH THEY PROVIDE IN OSINT. ! 466: # E.G. MWB OR TRC MIGHT BE TRANSLATED AS JSR SYSMB, ! 467: # JSR SYSTC IN SOME IMPLEMENTATIONS. ! 468: # ! 469: # IN THE DESCRIPTIONS, REFERENCE IS MADE TO --BLK ! 470: # FORMATS (-- = A PAIR OF LETTERS). SEE THE SPITBOL ! 471: # DEFINITIONS SECTION FOR DETAILED DESCRIPTIONS OF ALL ! 472: # SUCH BLOCK FORMATS EXCEPT FCBLK FOR WHICH SYSFC SHOULD ! 473: # BE CONSULTED. ! 474: # ! 475: # SECTION 0 CONTAINS INP,INR SPECIFICATIONS OF INTERNAL ! 476: # PROCEDURES,ROUTINES. THIS GIVES A SINGLE PASS TRANSLATOR ! 477: # INFORMATION MAKING IT EASY TO GENERATE ALTERNATIVE CALLS ! 478: # IN THE TRANSLATION OF JSR-S FOR PROCEDURES OF DIFFERENT ! 479: # TYPES IF THIS PROVES NECESSARY. ! 480: # ! 481: #sec # start of procedures section ! 482: #page ! 483: # ! 484: # SYSAX -- AFTER EXECUTION ! 485: # ! 486: .globl sysax # define external entry point ! 487: # ! 488: # IF THE CONDITIONAL ASSEMBLY SYMBOL .CSAX IS DEFINED, ! 489: # THIS ROUTINE IS CALLED IMMEDIATELY AFTER EXECUTION AND ! 490: # BEFORE PRINTING OF EXECUTION STATISTICS OR DUMP OUTPUT. ! 491: # PURPOSE OF CALL IS FOR IMPLEMENTOR TO DETERMINE AND ! 492: # IF THE CALL IS NOT REQUIRED IT WILL BE OMITTED IF .CSAX ! 493: # IS UNDEFINED. IN THIS CASE SYSAX NEED NOT BE CODED. ! 494: # ! 495: # JSR SYSAX CALL AFTER EXECUTION ! 496: #page ! 497: # ! 498: # SYSBX -- BEFORE EXECUTION ! 499: # ! 500: .globl sysbx # define external entry point ! 501: # ! 502: # CALLED AFTER INITIAL SPITBOL COMPILATION AND BEFORE ! 503: # COMMENCING EXECUTION IN CASE OSINT NEEDS ! 504: # TO ASSIGN FILES OR PERFORM OTHER NECESSARY SERVICES. ! 505: # OSINT MAY ALSO CHOOSE TO SEND A MESSAGE TO ONLINE ! 506: # TERMINAL (IF ANY) INDICATING THAT EXECUTION IS STARTING. ! 507: # ! 508: # JSR SYSBX CALL BEFORE EXECUTION STARTS ! 509: #page ! 510: # ! 511: # SYSDC -- DATE CHECK ! 512: # ! 513: .globl sysdc # define external entry point ! 514: # ! 515: # SYSDC IS CALLED TO CHECK THAT THE EXPIRY DATE FOR A TRIAL ! 516: # VERSION OF SPITBOL IS UNEXPIRED. ! 517: # ! 518: # JSR SYSDC CALL TO CHECK DATE ! 519: # RETURN ONLY IF DATE IS OK ! 520: #page ! 521: # ! 522: # SYSDM -- DUMP CORE ! 523: # ! 524: .globl sysdm # define external entry point ! 525: # ! 526: # SYSDM IS CALLED BY A SPITBOL PROGRAM CALL OF DUMP(N) WITH ! 527: # N GE 3. ITS PURPOSE IS TO PROVIDE A CORE DUMP. ! 528: # N COULD HOLD AN ENCODING OF THE START ADRS FOR DUMP AND ! 529: # AMOUNT TO BE DUMPED E.G. N = 256*A + S , S = START ADRS ! 530: # IN KILOWORDS, A = KILOWORDS TO DUMP ! 531: # ! 532: # (XR) PARAMETER N OF CALL DUMP(N) ! 533: # JSR SYSDM CALL TO ENTER ROUTINE ! 534: #page ! 535: # ! 536: # SYSDT -- GET CURRENT DATE ! 537: # ! 538: .globl sysdt # define external entry point ! 539: # ! 540: # SYSDT IS USED TO OBTAIN THE CURRENT DATE. THE DATE IS ! 541: # RETURNED AS A CHARACTER STRING IN ANY FORMAT APPROPRIATE ! 542: # TO THE OPERATING SYSTEM IN USE. IT MAY ALSO CONTAIN THE ! 543: # CURRENT TIME OF DAY. SYSDT IS USED TO IMPLEMENT THE ! 544: # SNOBOL4 FUNCTION DATE. ! 545: # ! 546: # JSR SYSDT CALL TO GET DATE ! 547: # (XL) POINTER TO BLOCK CONTAINING DATE ! 548: # ! 549: # THE FORMAT OF THE BLOCK IS LIKE AN SCBLK EXCEPT THAT ! 550: # THE FIRST WORD NEED NOT BE SET. THE RESULT IS COPIED ! 551: # INTO SPITBOL DYNAMIC MEMORY ON RETURN. ! 552: #page ! 553: # ! 554: # SYSEF -- EJECT FILE ! 555: # ! 556: .globl sysef # define external entry point ! 557: # ! 558: # SYSEF IS USED TO WRITE A PAGE EJECT TO A NAMED FILE. IT ! 559: # MAY ONLY BE USED FOR FILES WHERE THIS CONCEPT MAKES ! 560: # SENSE. NOTE THAT SYSEF IS NOT NORMALLY USED FOR THE ! 561: # STANDARD OUTPUT FILE (SEE SYSEP). ! 562: # ! 563: # (WA) PTR TO FCBLK OR ZERO ! 564: # (XR) EJECT ARGUMENT (SCBLK PTR) ! 565: # JSR SYSEF CALL TO EJECT FILE ! 566: # PPM LOC RETURN HERE IF FILE DOES NOT EXIST ! 567: # PPM LOC RETURN HERE IF INAPPROPRIATE FILE ! 568: # PPM LOC RETURN HERE IF I/O ERROR ! 569: #page ! 570: # ! 571: # SYSEJ -- END OF JOB ! 572: # ! 573: .globl sysej # define external entry point ! 574: # ! 575: # SYSEJ IS CALLED ONCE AT THE END OF EXECUTION TO ! 576: # TERMINATE THE RUN. THE SIGNIFICANCE OF THE ABEND AND ! 577: # CODE VALUES IS SYSTEM DEPENDENT. IN GENERAL, THE CODE ! 578: # VALUE SHOULD BE MADE AVAILABLE FOR TESTING, AND THE ! 579: # ABEND VALUE SHOULD CAUSE SOME POST-MORTEM ACTION SUCH AS ! 580: # A DUMP. NOTE THAT SYSEJ DOES NOT RETURN TO ITS CALLER. ! 581: # SEE SYSXI FOR DETAILS OF FCBLK CHAIN ! 582: # ! 583: # (WA) VALUE OF ABEND KEYWORD ! 584: # (WB) VALUE OF CODE KEYWORD ! 585: # (XL) O OR PTR TO HEAD OF FCBLK CHAIN ! 586: # JSR SYSEJ CALL TO END JOB ! 587: # ! 588: # THE FOLLOWING SPECIAL VALUES ARE USED AS CODES IN (WB) ! 589: # 999 EXECUTION SUPPRESSED ! 590: # 998 STANDARD OUTPUT FILE FULL OR UNAVAILABLE IN A SYSXI ! 591: # LOAD MODULE. IN THESE CASES (WA) CONTAINS THE NUMBER ! 592: # OF THE STATEMENT CAUSING PREMATURE TERMINATION. ! 593: #page ! 594: # ! 595: # SYSEM -- GET ERROR MESSAGE TEXT ! 596: # ! 597: .globl sysem # define external entry point ! 598: # ! 599: # SYSEM IS USED TO OBTAIN THE TEXT OF ERR, ERB CALLS IN THE ! 600: # SOURCE PROGRAM GIVEN THE ERROR CODE NUMBER. IT IS ALLOWED ! 601: # TO RETURN A NULL STRING IF THIS FACILITY IS UNAVAILABLE. ! 602: # ! 603: # (WA) ERROR CODE NUMBER ! 604: # JSR SYSEM CALL TO GET TEXT ! 605: # (XR) TEXT OF MESSAGE ! 606: # ! 607: # THE RETURNED VALUE IS A POINTER TO A BLOCK IN SCBLK ! 608: # FORMAT EXCEPT THAT THE FIRST WORD NEED NOT BE SET. THE ! 609: # STRING IS COPIED INTO DYNAMIC MEMORY ON RETURN. ! 610: # IF THE NULL STRING IS RETURNED EITHER BECAUSE SYSEM DOES ! 611: # NOT PROVIDE ERROR MESSAGE TEXTS OR BECAUSE WA IS OUT OF ! 612: # RANGE, SPITBOL WILL PRINT THE STRING STORED IN ERRTEXT ! 613: # KEYWORD. ! 614: #page ! 615: # ! 616: # SYSEN -- ENDFILE ! 617: # ! 618: .globl sysen # define external entry point ! 619: # ! 620: # SYSEN IS USED TO IMPLEMENT THE SNOBOL4 FUNCTION ENDFILE. ! 621: # THE MEANING IS SYSTEM DEPENDENT. IN GENERAL, ENDFILE ! 622: # IMPLIES THAT NO FURTHER I/O OPERATIONS WILL BE PERFORMED, ! 623: # BUT DOES NOT GUARANTEE THIS TO BE THE CASE. THE FILE ! 624: # SHOULD BE CLOSED AFTER THE CALL, A SUBSEQUENT READ ! 625: # OR WRITE MAY REOPEN THE FILE AT THE START OR IT MAY BE ! 626: # NECESSARY TO REOPEN THE FILE VIA SYSIO. ! 627: # ! 628: # (WA) PTR TO FCBLK OR ZERO ! 629: # (XR) ENDFILE ARGUMENT (SCBLK PTR) ! 630: # JSR SYSEN CALL TO ENDFILE ! 631: # PPM LOC RETURN HERE IF FILE DOES NOT EXIST ! 632: # PPM LOC RETURN HERE IF ENDFILE NOT ALLOWED ! 633: # PPM LOC RETURN HERE IF I/O ERROR ! 634: # (WA,WB) DESTROYED ! 635: # ! 636: # THE SECOND ERROR RETURN IS USED FOR FILES FOR WHICH ! 637: # ENDFILE IS NOT PERMITTED. FOR EXAMPLE, IT MAY BE EXPECTED ! 638: # THAT THE STANDARD INPUT AND OUTPUT FILES ARE IN THIS ! 639: # CATEGORY. ! 640: #page ! 641: # ! 642: # SYSEP -- EJECT PRINTER PAGE ! 643: # ! 644: .globl sysep # define external entry point ! 645: # ! 646: # SYSEP IS CALLED TO PERFORM A PAGE EJECT ON THE STANDARD ! 647: # PRINTER OUTPUT FILE (CORRESPONDING TO SYSPR OUTPUT). ! 648: # ! 649: # JSR SYSEP CALL TO EJECT PRINTER OUTPUT ! 650: #page ! 651: # ! 652: # SYSEX -- CALL EXTERNAL FUNCTION ! 653: # ! 654: .globl sysex # define external entry point ! 655: # ! 656: # SYSEX IS CALLED TO PASS CONTROL TO AN EXTERNAL FUNCTION ! 657: # PREVIOUSLY LOADED WITH A CALL TO SYSLD. ! 658: # ! 659: # (XS) POINTER TO ARGUMENTS ON STACK ! 660: # (XL) POINTER TO CONTROL BLOCK (EFBLK) ! 661: # (WA) NUMBER OF ARGUMENTS ON STACK ! 662: # JSR SYSEX CALL TO PASS CONTROL TO FUNCTION ! 663: # PPM LOC RETURN HERE IF FUNCTION CALL FAILS ! 664: # (XS) POPPED PAST ARGUMENTS ! 665: # (XR) RESULT RETURNED ! 666: # ! 667: # THE ARGUMENTS ARE STORED ON THE STACK WITH ! 668: # THE LAST ARGUMENT AT 0(XS). ON RETURN, XS ! 669: # IS POPPED PAST THE ARGUMENTS. ! 670: # ! 671: # THE FORM OF THE ARGUMENTS AS PASSED IS THAT USED IN THE ! 672: # SPITBOL TRANSLATOR (SEE DEFINITIONS AND DATA STRUCTURES ! 673: # SECTION). THE CONTROL BLOCK FORMAT IS ALSO DESCRIBED ! 674: # (UNDER EFBLK) IN THIS SECTION. ! 675: # ! 676: # THERE ARE TWO WAYS OF RETURNING A RESULT. ! 677: # ! 678: # 1) RETURN A POINTER TO A BLOCK IN DYNAMIC STORAGE. THIS ! 679: # BLOCK MUST BE IN EXACTLY CORRECT FORMAT, INCLUDING ! 680: # THE FIRST WORD. ONLY FUNCTIONS WRITTEN WITH INTIMATE ! 681: # KNOWLEDGE OF THE SYSTEM WILL RETURN IN THIS WAY. ! 682: # ! 683: # 2) STRING, INTEGER AND REAL RESULTS MAY BE RETURNED BY ! 684: # POINTING TO A PSEUDO-BLOCK OUTSIDE DYNAMIC MEMORY. ! 685: # THIS BLOCK IS IN ICBLK, RCBLK OR SCBLK FORMAT EXCEPT ! 686: # THAT THE FIRST WORD WILL BE OVERWRITTEN ! 687: # BY A TYPE WORD ON RETURN AND SO NEED NOT ! 688: # BE CORRECTLY SET. SUCH A RESULT IS ! 689: # COPIED INTO MAIN STORAGE BEFORE PROCEEDING. ! 690: # UNCONVERTED RESULTS MAY SIMILARLY BE RETURNED IN A ! 691: # PSEUDO-BLOCK WHICH IS IN CORRECT FORMAT INCLUDING ! 692: # TYPE WORD RECOGNISABLE BY GARBAGE COLLECTOR SINCE ! 693: # BLOCK IS COPIED INTO DYNAMIC MEMORY. ! 694: #page ! 695: # ! 696: # SYSFC -- FILE CONTROL BLOCK ROUTINE ! 697: # ! 698: .globl sysfc # define external entry point ! 699: # ! 700: # SEE ALSO SYSIO ! 701: # INPUT AND OUTPUT HAVE 3 ARGUMENTS REFERRED TO AS SHOWN ! 702: # INPUT(VARIABLE NAME,FILE ARG1,FILE ARG2) ! 703: # OUTPUT(VARIABLE NAME,FILE ARG1,FILE ARG2) ! 704: # FILE ARG1 MAY BE AN INTEGER OR STRING USED TO IDENTIFY ! 705: # AN I/O CHANNEL. IT IS CONVERTED TO A STRING FOR CHECKING. ! 706: # THE EXACT SIGNIFICANCE OF FILE ARG2 ! 707: # IS NOT RIGOROUSLY PRESCRIBED BUT TO IMPROVE PORTABILITY, ! 708: # THE SCHEME DESCRIBED IN THE SPITBOL USER MANUAL ! 709: # SHOULD BE ADOPTED WHEN POSSIBLE. THE PREFERRED FORM IS ! 710: # A STRING $F$,R$R$,C$C$,I$I$,...,Z$Z$ WHERE ! 711: # $F$ IS AN OPTIONAL FILE NAME WHICH IS PLACED FIRST. ! 712: # REMAINING ITEMS MAY BE OMITTED OR INCLUDED IN ANY ORDER. ! 713: # $R$ IS MAXIMUM RECORD LENGTH ! 714: # $C$ IS A CARRIAGE CONTROL CHARACTER OR CHARACTER STRING ! 715: # $I$ IS SOME FORM OF CHANNEL IDENTIFICATION USED IN THE ! 716: # ABSENCE OF $F$ TO ASSOCIATE THE VARIABLE ! 717: # WITH A FILE ALLOCATED DYNAMICALLY BY JCL COMMANDS AT ! 718: # SPITBOL LOAD TIME. ! 719: # ,...,Z$Z$ ARE ADDITIONAL FIELDS. ! 720: # IF , (COMMA) CANNOT BE USED AS A DELIMITER, .CIOD ! 721: # SHOULD BE DEFINED TO INTRODUCE BY CONDITIONAL ASSEMBLY ! 722: # ANOTHER DELIMITER (SEE ! 723: # IODEL EQU * ! 724: # EARLY IN DEFINITIONS SECTION). ! 725: # SYSFC IS CALLED WHEN A VARIABLE IS INPUT OR OUTPUT ! 726: # ASSOCIATED TO CHECK FILE ARG1 AND FILE ARG2 AND ! 727: # TO REPORT WHETHER AN FCBLK (FILE CONTROL ! 728: # BLOCK) IS NECESSARY AND IF SO WHAT SIZE IT SHOULD BE. ! 729: # THIS MAKES IT POSSIBLE FOR SPITBOL RATHER THAN OSINT TO ! 730: # ALLOCATE SUCH A BLOCK IN DYNAMIC MEMORY IF REQUIRED ! 731: # OR ALTERNATIVELY IN STATIC MEMORY. ! 732: # THE SIGNIFICANCE OF AN FCBLK , IF ONE IS REQUESTED, IS ! 733: # ENTIRELY UP TO THE SYSTEM INTERFACE. THE ONLY RESTRICTION ! 734: # IS THAT IF THE FCBLK SHOULD APPEAR TO LIE IN DYNAMIC ! 735: # MEMORY , POINTERS TO IT SHOULD BE PROPER POINTERS TO ! 736: # THE START OF A RECOGNISABLE AND GARBAGE COLLECTABLE ! 737: # BLOCK (THIS CONDITION WILL BE MET IF SYSFC REQUESTS ! 738: # SPITBOL TO PROVIDE AN FCBLK). ! 739: # AN OPTION IS PROVIDED FOR OSINT TO RETURN A POINTER IN ! 740: # XL TO AN FCBLK WHICH IT PRIVATELY ALLOCATED. THIS PTR ! 741: # WILL BE MADE AVAILABLE WHEN I/O OCCURS LATER. ! 742: # PRIVATE FCBLKS MAY HAVE ARBITRARY CONTENTS AND SPITBOL ! 743: # STORES NOTHING IN THEM. ! 744: #page ! 745: # THE REQUESTED SIZE FOR AN FCBLK IN DYNAMIC MEMORY ! 746: # SHOULD ALLOW A 2 WORD OVERHEAD FOR BLOCK TYPE AND ! 747: # LENGTH FIELDS. INFORMATION SUBSEQUENTLY STORED IN THE ! 748: # REMAINING WORDS MAY BE ARBITRARY IF AN XNBLK (EXTERNAL ! 749: # NON-RELOCATABLE BLOCK) IS REQUESTED. IF THE REQUEST IS ! 750: # FOR AN XRBLK (EXTERNAL RELOCATABLE BLOCK) THE ! 751: # CONTENTS OF WORDS SHOULD BE COLLECTABLE (I.E. ANY ! 752: # APPARENT POINTERS INTO DYNAMIC SHOULD BE GENUINE BLOCK ! 753: # POINTERS). THESE RESTRICTIONS DO NOT APPLY IF AN FCBLK ! 754: # IS ALLOCATED OUTSIDE DYNAMIC OR IS NOT ALLOCATED AT ALL. ! 755: # IF AN FCBLK IS REQUESTED, ITS FIELDS WILL BE INITIALISED ! 756: # TO ZERO BEFORE ENTRY TO SYSIO WITH THE EXCEPTION OF ! 757: # WORDS 0 AND 1 IN WHICH THE BLOCK TYPE AND LENGTH ! 758: # FIELDS ARE PLACED FOR FCBLKS IN DYNAMIC MEMORY ONLY. ! 759: # FOR THE POSSIBLE USE OF SYSEJ AND SYSXI, IF FCBLKS ! 760: # ARE USED, A CHAIN IS BUILT SO THAT THEY MAY ALL BE ! 761: # FOUND - SEE SYSXI FOR DETAILS. ! 762: # IF BOTH FILE ARG1 AND FILE ARG2 ARE NULL, CALLS OF SYSFC ! 763: # AND SYSIO ARE OMITTED. ! 764: # IF FILE ARG1 IS NULL (STANDARD INPUT/OUTPUT FILE), SYSFC ! 765: # IS CALLED TO CHECK NON-NULL FILE ARG2 BUT ANY REQUEST ! 766: # FOR AN FCBLK WILL BE IGNORED, SINCE SPITBOL HANDLES THE ! 767: # STANDARD FILES SPECIALLY AND CANNOT READILY KEEP FCBLK ! 768: # POINTERS FOR THEM. ! 769: # FILEARG1 IS TYPE CHECKED BY SPITBOL SO FURTHER CHECKING ! 770: # MAY BE UNNECCESSARY IN MANY IMPLEMENTATIONS. ! 771: # FILE ARG2 IS PASSED SO THAT SYSFC MAY ANALYSE AND ! 772: # CHECK IT. HOWEVER TO ASSIST IN THIS, SPITBOL ALSO PASSES ! 773: # ON THE STACK THE COMPONENTS OF THIS ARGUMENT WITH ! 774: # FILE NAME, $F$ (OTHERWISE NULL) EXTRACTED AND STACKED ! 775: # FIRST. ! 776: # THE OTHER FIELDS, IF ANY, ARE EXTRACTED AS SUBSTRINGS, ! 777: # POINTERS TO THEM ARE STACKED AND A COUNT OF ALL ITEMS ! 778: # STACKED IS PLACED IN WC. IF AN FCBLK WAS EARLIER ! 779: # ALLOCATED AND POINTED TO VIA FILE ARG1, SYSFC IS ALSO ! 780: # PASSED A POINTER TO THIS FCBLK. ! 781: # ! 782: # (XL) FILE ARG1 SCBLK PTR (2ND ARG) ! 783: # (XR) FILEARG2 (3RD ARG) OR NULL ! 784: # -(XS)...-(XS) SCBLKS FOR $F$,$R$,$C$,... ! 785: # (WC) NO. OF STACKED SCBLKS ABOVE ! 786: # (WA) EXISTING FILE ARG1 FCBLK PTR OR 0 ! 787: # (WB) 0/3 FOR INPUT/OUTPUT ASSOCN ! 788: # JSR SYSFC CALL TO CHECK NEED FOR FCBLK ! 789: # PPM LOC INVALID FILE ARGUMENT ! 790: # (XS) POPPED (WC) TIMES ! 791: # (WA NON ZERO) BYTE SIZE OF REQUESTED FCBLK ! 792: # (WA=0,XL NON ZERO) PRIVATE FCBLK PTR IN XL ! 793: # (WA=XL=0) NO FCBLK WANTED, NO PRIVATE FCBLK ! 794: # (WC) 0/1/2 REQUEST ALLOC OF XRBLK/XNBLK ! 795: # /STATIC BLOCK FOR USE AS FCBLK ! 796: # (WB) DESTROYED ! 797: #page ! 798: # ! 799: # SYSHS -- GIVE ACCESS TO HOST COMPUTER FEATURES ! 800: # ! 801: .globl syshs # define external entry point ! 802: # ! 803: # PROVIDES MEANS FOR IMPLEMENTING SPECIAL FEATURES ! 804: # ON DIFFERENT HOST COMPUTERS. THE ONLY DEFINED ENTRY IS ! 805: # THAT WHERE ALL ARGUMENTS ARE NULL IN WHICH CASE SYSHS ! 806: # RETURNS AN SCBLK CONTAINING NAME OF COMPUTER, ! 807: # NAME OF OPERATING SYSTEM AND NAME OF SITE SEPARATED BY ! 808: # COLONS. THE SCBLK NEED NOT HAVE A CORRECT FIRST FIELD ! 809: # AS THIS IS SUPPLIED ON COPYING STRING TO DYNAMIC MEMORY. ! 810: # SPITBOL DOES NO ARGUMENT CHECKING BUT DOES PROVIDE A ! 811: # SINGLE ERROR RETURN FOR ARGUMENTS CHECKED AS ERRONEOUS ! 812: # BY OSINT. IT ALSO PROVIDES A SINGLE EXECUTION ERROR ! 813: # RETURN. IF THESE ARE INADEQUATE, USE MAY BE MADE OF THE ! 814: # MINIMAL ERROR SECTION DIRECT AS DESCRIBED IN MINIMAL ! 815: # DOCUMENTATION, SECTION 10. ! 816: # SEVERAL NON-ERROR RETURNS ARE PROVIDED. THE FIRST ! 817: # CORRESPONDS TO THE DEFINED ENTRY OR, FOR IMPLEMENTATION ! 818: # DEFINED ENTRIES, ANY STRING MAY BE RETURNED. THE OTHERS ! 819: # PERMIT RESPECTIVELY, RETURN A NULL RESULT, RETURN WITH A ! 820: # RESULT TO BE STACKED WHICH IS POINTED AT BY XR, AND A ! 821: # RETURN CAUSING SPITBOL STATEMENT FAILURE. IF A RETURNED ! 822: # RESULT IS IN DYNAMIC MEMORY IT MUST OBEY GARBAGE ! 823: # COLLECTOR RULES. THE ONLY RESULTS COPIED ON RETURN ! 824: # ARE STRINGS RETURNED VIA PPM LOC3 RETURN. ! 825: # ! 826: # (WA) ARGUMENT 1 ! 827: # (XL) ARGUMENT 2 ! 828: # (XR) ARGUMENT 3 ! 829: # JSR SYSHS CALL TO GET HOST INFORMATION ! 830: # PPM LOC1 ERRONEOUS ARG ! 831: # PPM LOC2 EXECUTION ERROR ! 832: # PPM LOC3 SCBLK PTR IN XL OR 0 IF UNAVAILABLE ! 833: # PPM LOC4 RETURN A NULL RESULT ! 834: # PPM LOC5 RETURN RESULT IN XR ! 835: # PPM LOC6 CAUSE STATEMENT FAILURE ! 836: #page ! 837: # ! 838: # SYSID -- RETURN SYSTEM IDENTIFICATION ! 839: # ! 840: .globl sysid # define external entry point ! 841: # ! 842: # THIS ROUTINE SHOULD RETURN STRINGS TO HEAD THE STANDARD ! 843: # PRINTER OUTPUT. THE FIRST STRING WILL BE APPENDED TO ! 844: # A HEADING LINE OF THE FORM ! 845: # MACRO SPITBOL VERSION V.V ! 846: # SUPPLIED BY SPITBOL ITSELF. V.V ARE DIGITS GIVING THE ! 847: # MAJOR VERSION NUMBER AND GENERALLY AT LEAST A MINOR ! 848: # VERSION NUMBER RELATING TO OSINT SHOULD BE SUPPLIED TO ! 849: # GIVE SAY ! 850: # MACRO SPITBOL VERSION V.V(M.M) ! 851: # THE SECOND STRING SHOULD IDENTIFY AT LEAST THE MACHINE ! 852: # AND OPERATING SYSTEM. PREFERABLY IT SHOULD INCLUDE ! 853: # THE DATE AND TIME OF THE RUN. ! 854: # OPTIONALLY THE STRINGS MAY INCLUDE SITE NAME OF THE ! 855: # THE IMPLEMENTOR AND/OR MACHINE ON WHICH RUN TAKES PLACE, ! 856: # UNIQUE SITE OR COPY NUMBER AND OTHER INFORMATION AS ! 857: # APPROPRIATE WITHOUT MAKING IT SO LONG AS TO BE A ! 858: # NUISANCE TO USERS. ! 859: # THE FIRST WORDS OF THE SCBLKS POINTED AT NEED NOT BE ! 860: # CORRECTLY SET. ! 861: # ! 862: # JSR SYSID CALL FOR SYSTEM IDENTIFICATION ! 863: # (XR) SCBLK PTR FOR ADDITION TO HEADER ! 864: # (XL) PTR TO SECOND HEADER SCBLK ! 865: #page ! 866: # ! 867: # SYSIL -- GET INPUT RECORD LENGTH ! 868: # ! 869: .globl sysil # define external entry point ! 870: # ! 871: # SYSIL IS USED TO GET THE LENGTH OF THE NEXT INPUT RECORD ! 872: # FROM A FILE PREVIOUSLY INPUT ASSOCIATED WITH A SYSIO ! 873: # CALL. THE LENGTH RETURNED IS USED TO ESTABLISH A BUFFER ! 874: # FOR A SUBSEQUENT SYSIN CALL. ! 875: # ! 876: # (WA) PTR TO FCBLK OR ZERO ! 877: # JSR SYSIL CALL TO GET RECORD LENGTH ! 878: # (WA) LENGTH OR ZERO IF FILE CLOSED ! 879: # ! 880: # NO HARM IS DONE IF THE VALUE RETURNED IS TOO LONG SINCE ! 881: # UNUSED SPACE WILL BE RECLAIMED AFTER THE SYSIN CALL. ! 882: # ! 883: # NOTE THAT IT IS THE SYSIL CALL (NOT THE SYSIO CALL) WHICH ! 884: # CAUSES THE FILE TO BE OPENED AS REQUIRED FOR THE FIRST ! 885: # RECORD INPUT FROM THE FILE. ! 886: #page ! 887: # ! 888: # SYSIN -- READ INPUT RECORD ! 889: # ! 890: .globl sysin # define external entry point ! 891: # ! 892: # SYSIN IS USED TO READ A RECORD FROM THE FILE WHICH WAS ! 893: # REFERENCED IN A PRIOR CALL TO SYSIL (I.E. THESE CALLS ! 894: # ALWAYS OCCUR IN PAIRS). THE BUFFER PROVIDED IS AN ! 895: # SCBLK FOR A STRING OF LENGTH SET FROM THE SYSIL CALL. ! 896: # IF THE ACTUAL LENGTH READ IS LESS THAN THIS, THE LENGTH ! 897: # FIELD OF THE SCBLK MUST BE MODIFIED BEFORE RETURNING ! 898: # UNLESS BUFFER IS RIGHT PADDED WITH ZEROES. ! 899: # IT IS ALSO PERMISSIBLE TO TAKE ANY OF THE ALTERNATIVE ! 900: # RETURNS AFTER SCBLK LENGTH HAS BEEN MODIFIED. ! 901: # ! 902: # (WA) PTR TO FCBLK OR ZERO ! 903: # (XR) POINTER TO BUFFER (SCBLK PTR) ! 904: # JSR SYSIN CALL TO READ RECORD ! 905: # PPM LOC ENDFILE OR NO I/P FILE AFTER SYSXI ! 906: # PPM LOC RETURN HERE IF I/O ERROR ! 907: # PPM LOC RETURN HERE IF RECORD FORMAT ERROR ! 908: # (WA,WB,WC) DESTROYED ! 909: #page ! 910: # ! 911: # SYSIO -- INPUT/OUTPUT FILE ASSOCIATION ! 912: # ! 913: .globl sysio # define external entry point ! 914: # ! 915: # SEE ALSO SYSFC. ! 916: # SYSIO IS CALLED IN RESPONSE TO A SNOBOL4 INPUT OR OUTPUT ! 917: # FUNCTION CALL EXCEPT WHEN FILE ARG1 AND FILE ARG2 ! 918: # ARE BOTH NULL. ! 919: # ITS CALL ALWAYS FOLLOWS IMMEDIATELY AFTER A CALL ! 920: # OF SYSFC. IF SYSFC REQUESTED ALLOCATION ! 921: # OF AN FCBLK, ITS ADDRESS WILL BE IN WA. ! 922: # FOR INPUT FILES, NON-ZERO VALUES OF $R$ SHOULD BE ! 923: # COPIED TO WC FOR USE IN ALLOCATING INPUT BUFFERS. IF $R$ ! 924: # IS DEFAULTED OR NOT IMPLEMENTED, WC SHOULD BE ZEROISED. ! 925: # ONCE A FILE HAS BEEN OPENED, SUBSEQUENT INPUT(),OUTPUT() ! 926: # CALLS IN WHICH THE SECOND ARGUMENT IS IDENTICAL WITH THAT ! 927: # IN A PREVIOUS CALL, MERELY ASSOCIATE THE ADDITIONAL ! 928: # VARIABLE NAME (FIRST ARGUMENT) TO THE FILE AND DO NOT ! 929: # RESULT IN RE-OPENING THE FILE. ! 930: # IN SUBSEQUENT ASSOCIATED ACCESSES TO THE FILE A POINTER ! 931: # TO ANY FCBLK ALLOCATED WILL BE MADE AVAILABLE. ! 932: # ! 933: # (XL) FILE ARG1 SCBLK PTR (2ND ARG) ! 934: # (XR) FILE ARG2 SCBLK PTR (3RD ARG) ! 935: # (WA) FCBLK PTR (0 IF NONE) ! 936: # (WB) 0 FOR INPUT, 3 FOR OUTPUT ! 937: # JSR SYSIO CALL TO ASSOCIATE FILE ! 938: # PPM LOC RETURN HERE IF FILE DOES NOT EXIST ! 939: # PPM LOC RETURN IF INPUT/OUTPUT NOT ALLOWED ! 940: # (XL) FCBLK POINTER (0 IF NONE) ! 941: # (WC) 0 (FOR DEFAULT) OR MAX RECORD LNGTH ! 942: # (WA,WB) DESTROYED ! 943: # ! 944: # THE SECOND ERROR RETURN IS USED IF THE FILE NAMED EXISTS ! 945: # BUT INPUT/OUTPUT FROM THE FILE IS NOT ALLOWED. FOR ! 946: # EXAMPLE, THE STANDARD OUTPUT FILE MAY BE IN THIS CATEGORY ! 947: # AS REGARDS INPUT ASSOCIATION. ! 948: #page ! 949: # ! 950: # SYSLD -- LOAD EXTERNAL FUNCTION ! 951: # ! 952: .globl sysld # define external entry point ! 953: # ! 954: # SYSLD IS CALLED IN RESPONSE TO THE USE OF THE SNOBOL4 ! 955: # LOAD FUNCTION. THE NAMED FUNCTION IS LOADED (WHATEVER ! 956: # THIS MEANS), AND A POINTER IS RETURNED. THE POINTER WILL ! 957: # BE USED ON SUBSEQUENT CALLS TO THE FUNCTION (SEE SYSEX). ! 958: # ! 959: # (XR) POINTER TO FUNCTION NAME (SCBLK) ! 960: # (XL) POINTER TO LIBRARY NAME (SCBLK) ! 961: # JSR SYSLD CALL TO LOAD FUNCTION ! 962: # PPM LOC RETURN HERE IF FUNC DOES NOT EXIST ! 963: # PPM LOC RETURN HERE IF I/O ERROR ! 964: # (XR) POINTER TO LOADED CODE ! 965: # ! 966: # THE SIGNIFICANCE OF THE POINTER RETURNED IS UP TO THE ! 967: # SYSTEM INTERFACE ROUTINE. THE ONLY RESTRICTION IS THAT ! 968: # IF THE POINTER IS WITHIN DYNAMIC STORAGE, IT MUST BE ! 969: # A PROPER BLOCK POINTER. ! 970: #page ! 971: # ! 972: # SYSMM -- GET MORE MEMORY ! 973: # ! 974: .globl sysmm # define external entry point ! 975: # ! 976: # SYSMM IS CALLED IN AN ATTEMPT TO ALLOCATE MORE DYNAMIC ! 977: # MEMORY. THIS MEMORY MUST BE ALLOCATED CONTIGUOUSLY WITH ! 978: # THE CURRENT DYNAMIC DATA AREA. ! 979: # ! 980: # THE AMOUNT ALLOCATED IS UP TO THE SYSTEM TO DECIDE. ANY ! 981: # VALUE IS ACCEPTABLE INCLUDING ZERO IF ALLOCATION IS ! 982: # IMPOSSIBLE. ! 983: # ! 984: # JSR SYSMM CALL TO GET MORE MEMORY ! 985: # (XR) NUMBER OF ADDITIONAL WORDS OBTAINED ! 986: #page ! 987: # ! 988: # SYSMX -- SUPPLY MXLEN ! 989: # ! 990: .globl sysmx # define external entry point ! 991: # ! 992: # BECAUSE OF THE METHOD OF GARBAGE COLLECTION, NO SPITBOL ! 993: # OBJECT IS ALLOWED TO OCCUPY MORE BYTES OF MEMORY THAN ! 994: # THE INTEGER GIVING THE LOWEST ADDRESS OF DYNAMIC ! 995: # (GARBAGE COLLECTABLE) MEMORY. MXLEN IS THE NAME USED TO ! 996: # REFER TO THIS MAXIMUM LENGTH OF AN OBJECT AND FOR MOST ! 997: # USERS OF MOST IMPLEMENTATIONS, PROVIDED DYNAMIC MEMORY ! 998: # STARTS AT AN ADDRESS OF AT LEAST A FEW THOUSAND WORDS, ! 999: # THERE IS NO PROBLEM. ! 1000: # IF THE DEFAULT STARTING ADDRESS IS LESS THAN SAY 10000 OR ! 1001: # 20000, THEN A LOAD TIME OPTION SHOULD BE PROVIDED WHERE A ! 1002: # USER CAN REQUEST THAT HE BE ABLE TO CREATE LARGER ! 1003: # OBJECTS. THIS ROUTINE INFORMS SPITBOL OF THIS REQUEST IF ! 1004: # ANY. THE VALUE RETURNED IS EITHER AN INTEGER ! 1005: # REPRESENTING THE DESIRED VALUE OF MXLEN (AND HENCE THE ! 1006: # MINIMUM DYNAMIC STORE ADDRESS WHICH MAY RESULT IN ! 1007: # NON-USE OF SOME STORE) OR ZERO IF A DEFAULT IS ACCEPTABLE ! 1008: # IN WHICH MXLEN IS SET TO THE LOWEST ADDRESS ALLOCATED ! 1009: # TO DYNAMIC STORE BEFORE COMPILATION STARTS. ! 1010: # IF A NON-ZERO VALUE IS RETURNED, THIS IS USED FOR KEYWORD ! 1011: # MAXLNGTH. OTHERWISE THE INITIAL LOW ADDRESS OF DYNAMIC ! 1012: # MEMORY IS USED FOR THIS KEYWORD. ! 1013: # ! 1014: # JSR SYSMX CALL TO GET MXLEN ! 1015: # (WA) EITHER MXLEN OR 0 FOR DEFAULT ! 1016: #page ! 1017: # ! 1018: # SYSOU -- OUTPUT RECORD ! 1019: # ! 1020: .globl sysou # define external entry point ! 1021: # ! 1022: # SYSOU IS USED TO WRITE A RECORD TO A FILE PREVIOUSLY ! 1023: # ASSOCIATED WITH A SYSIO CALL. ! 1024: # ! 1025: # (WA) PTR TO FCBLK OR ZERO ! 1026: # (XR) RECORD TO BE WRITTEN (SCBLK) ! 1027: # JSR SYSOU CALL TO OUTPUT RECORD ! 1028: # PPM LOC FILE FULL OR NO FILE AFTER SYSXI ! 1029: # PPM LOC RETURN HERE IF I/O ERROR ! 1030: # (WA,WB,WC) DESTROYED ! 1031: # ! 1032: # NOTE THAT IT IS THE SYSOU CALL (NOT THE SYSIO CALL) WHICH ! 1033: # CAUSES THE FILE TO BE OPENED AS REQUIRED FOR THE FIRST ! 1034: # RECORD OUTPUT TO THE FILE. ! 1035: #page ! 1036: # ! 1037: # SYSPI -- PRINT ON INTERACTIVE CHANNEL ! 1038: # ! 1039: .globl syspi # define external entry point ! 1040: # ! 1041: # IF SPITBOL IS RUN FROM AN ONLINE TERMINAL, OSINT CAN ! 1042: # REQUEST THAT MESSAGES SUCH AS COPIES OF COMPILATION ! 1043: # ERRORS BE SENT TO THE TERMINAL (SEE SYSPP). IF RELEVANT ! 1044: # REPLY WAS MADE BY SYSPP THEN SYSPI IS CALLED TO SEND SUCH ! 1045: # MESSAGES TO THE INTERACTIVE CHANNEL. ! 1046: # SYSPI IS ALSO USED FOR SENDING OUTPUT TO THE TERMINAL ! 1047: # THROUGH THE SPECIAL VARIABLE NAME, TERMINAL. ! 1048: # ! 1049: # (XR) PTR TO LINE BUFFER (SCBLK) ! 1050: # (WA) LINE LENGTH ! 1051: # JSR SYSPI CALL TO PRINT LINE ! 1052: # PPM LOC FAILURE RETURN ! 1053: # (WA,WB) DESTROYED ! 1054: #page ! 1055: # ! 1056: # SYSPP -- OBTAIN PRINT PARAMETERS ! 1057: # ! 1058: .globl syspp # define external entry point ! 1059: # ! 1060: # SYSPP IS CALLED ONCE DURING COMPILATION TO OBTAIN ! 1061: # PARAMETERS REQUIRED FOR CORRECT PRINTED OUTPUT FORMAT ! 1062: # AND TO SELECT OTHER OPTIONS. IT MAY ALSO BE CALLED AGAIN ! 1063: # AFTER SYSXI WHEN A LOAD MODULE IS RESUMED. IN THIS ! 1064: # CASE THE VALUE RETURNED IN WA MAY BE LESS THAN OR EQUAL ! 1065: # TO THAT RETURNED IN INITIAL CALL BUT MAY NOT BE ! 1066: # GREATER. ! 1067: # THE INFORMATION RETURNED IS - ! 1068: # 1. LINE LENGTH IN CHARS FOR STANDARD PRINT FILE ! 1069: # 2. NO OF LINES/PAGE. 0 IS PREFERABLE FOR A NON-PAGED ! 1070: # DEVICE (E.G. ONLINE TERMINAL) IN WHICH CASE LISTING ! 1071: # PAGE THROWS ARE SUPPRESSED AND PAGE HEADERS ! 1072: # RESULTING FROM -TITLE,-STITL LINES ARE KEPT SHORT. ! 1073: # 3. AN INITIAL -NOLIST OPTION TO SUPPRESS LISTING UNLESS ! 1074: # THE PROGRAM CONTAINS AN EXPLICIT -LIST. ! 1075: # 4. OPTIONS TO SUPPRESS LISTING OF COMPILATION AND/OR ! 1076: # EXECUTION STATS (USEFUL FOR ESTABLISHED PROGRAMS) - ! 1077: # COMBINED WITH 3. GIVES POSSIBILITY OF LISTING ! 1078: # FILE NEVER BEING OPENED. ! 1079: # 5. OPTION TO HAVE COPIES OF ERRORS SENT TO AN ! 1080: # INTERACTIVE CHANNEL IN ADDITION TO STANDARD PRINTER. ! 1081: # 6. OPTION TO KEEP PAGE HEADERS SHORT (E.G. IF LISTING ! 1082: # TO AN ONLINE TERMINAL). ! 1083: # 7. AN OPTION TO CHOOSE EXTENDED OR COMPACT LISTING ! 1084: # FORMAT. IN THE FORMER A PAGE EJECT AND IN THE LATTER ! 1085: # A FEW LINE FEEDS PRECEDE THE PRINTING OF EACH ! 1086: # OF-- LISTING, COMPILATION STATISTICS, EXECUTION ! 1087: # OUTPUT AND EXECUTION STATISTICS. ! 1088: # 8. AN OPTION TO SUPPRESS EXECUTION AS THOUGH A ! 1089: # -NOEXECUTE CARD WERE SUPPLIED. ! 1090: # 9. AN OPTION TO REQUEST THAT NAME /TERMINAL/ BE PRE- ! 1091: # ASSOCIATED TO AN ONLINE TERMINAL VIA SYSPI AND SYSRI ! 1092: # 10. AN INTERMEDIATE (STANDARD) LISTING OPTION REQUIRING ! 1093: # THAT PAGE EJECTS OCCUR IN SOURCE LISTINGS. REDUNDANT ! 1094: # IF EXTENDED OPTION CHOSEN BUT PARTIALLY EXTENDS ! 1095: # COMPACT OPTION. ! 1096: # 11. OPTION TO SUPPRESS SYSID IDENTIFICATION. ! 1097: # ! 1098: # JSR SYSPP CALL TO GET PRINT PARAMETERS ! 1099: # (WA) PRINT LINE LENGTH IN CHARS ! 1100: # (WB) NUMBER OF LINES/PAGE ! 1101: # (WC) BITS VALUE ...JIHGFEDCBA WHERE ! 1102: # A = 1 TO SEND ERROR COPY TO INT.CH. ! 1103: # B = 1 MEANS STD PRINTER IS INT. CH. ! 1104: # C = 1 FOR -NOLIST OPTION ! 1105: # D = 1 TO SUPPRESS COMPILN. STATS ! 1106: # E = 1 TO SUPPRESS EXECN. STATS ! 1107: # F = 1/0 FOR EXTNDED/COMPACT LISTING ! 1108: # G = 1 FOR -NOEXECUTE ! 1109: # H = 1 PRE-ASSOCIATE /TERMINAL/ ! 1110: # I = 1 FOR STANDARD LISTING OPTION. ! 1111: # J = 1 SUPPRESSES LISTING HEADER ! 1112: #page ! 1113: # ! 1114: # SYSPR -- PRINT LINE ON STANDARD OUTPUT FILE ! 1115: # ! 1116: .globl syspr # define external entry point ! 1117: # ! 1118: # SYSPR IS USED TO PRINT A SINGLE LINE ON THE STANDARD ! 1119: # OUTPUT FILE. ! 1120: # ! 1121: # (XR) POINTER TO LINE BUFFER (SCBLK) ! 1122: # (WA) LINE LENGTH ! 1123: # JSR SYSPR CALL TO PRINT LINE ! 1124: # PPM LOC TOO MUCH O/P OR NO FILE AFTER SYSXI ! 1125: # (WA,WB) DESTROYED ! 1126: # ! 1127: # THE BUFFER POINTED TO IS THE LENGTH OBTAINED FROM THE ! 1128: # SYSPP CALL AND IS FILLED OUT WITH TRAILING BLANKS. THE ! 1129: # VALUE IN WA IS THE ACTUAL LINE LENGTH WHICH MAY BE LESS ! 1130: # THAN THE MAXIMUM LINE LENGTH POSSIBLE. THERE IS NO SPACE ! 1131: # CONTROL ASSOCIATED WITH THE LINE, ALL LINES ARE PRINTED ! 1132: # SINGLE SPACED. NOTE THAT NULL LINES (WA=0) ARE POSSIBLE ! 1133: # IN WHICH CASE A BLANK LINE IS TO BE PRINTED. ! 1134: # ! 1135: # THE ERROR EXIT IS USED FOR SYSTEMS WHICH LIMIT THE AMOUNT ! 1136: # OF PRINTED OUTPUT. IF POSSIBLE, PRINTING SHOULD BE ! 1137: # PERMITTED AFTER THIS CONDITION HAS BEEN SIGNALLED ONCE TO ! 1138: # ALLOW FOR DUMP AND OTHER DIAGNOSTIC INFORMATION. ! 1139: # ASSUMING THIS TO BE POSSIBLE, SPITBOL MAY MAKE MORE SYSPR ! 1140: # CALLS. IF THE ERROR RETURN OCCURS ANOTHER TIME, EXECUTION ! 1141: # IS TERMINATED BY A CALL OF SYSEJ WITH ENDING CODE 998. ! 1142: #page ! 1143: # ! 1144: # SYSRD -- READ RECORD FROM STANDARD INPUT FILE ! 1145: # ! 1146: .globl sysrd # define external entry point ! 1147: # ! 1148: # SYSRD IS USED TO READ A RECORD FROM THE STANDARD INPUT ! 1149: # FILE. THE BUFFER PROVIDED IS AN SCBLK FOR A STRING THE ! 1150: # LENGTH OF WHICH IN CHARACTERS IS GIVEN IN WC, THIS ! 1151: # CORRESPONDING TO THE MAXIMUM LENGTH OF STRING WHICH ! 1152: # SPITBOL IS PREPARED TO RECEIVE. AT COMPILE TIME IT ! 1153: # CORRESPONDS TO XXX IN THE MOST RECENT -INXXX CARD ! 1154: # (DEFAULT 72) AND AT EXECUTION TIME TO THE MOST RECENT ! 1155: # ,R$R$ (RECORD LENGTH) IN THE THIRD ARG OF AN INPUT() ! 1156: # STATEMENT FOR THE STANDARD INPUT FILE (DEFAULT 80). ! 1157: # IF FEWER THAN (WC) CHARACTERS ARE READ, THE LENGTH ! 1158: # FIELD OF THE SCBLK MUST BE ADJUSTED BEFORE RETURNING ! 1159: # UNLESS THE BUFFER IS RIGHT PADDED WITH ZEROES. ! 1160: # IT IS ALSO PERMISSIBLE TO TAKE THE ALTERNATIVE RETURN ! 1161: # AFTER SUCH AN ADJUSTMENT HAS BEEN MADE. ! 1162: # SPITBOL MAY CONTINUE TO MAKE CALLS AFTER AN ENDFILE ! 1163: # RETURN SO THIS ROUTINE SHOULD BE PREPARED TO MAKE ! 1164: # REPEATED ENDFILE RETURNS. ! 1165: # ! 1166: # (XR) POINTER TO BUFFER (SCBLK PTR) ! 1167: # (WC) LENGTH OF BUFFER IN CHARACTERS ! 1168: # JSR SYSRD CALL TO READ LINE ! 1169: # PPM LOC ENDFILE OR NO I/P FILE AFTER SYSXI ! 1170: # (WA,WB,WC) DESTROYED ! 1171: #page ! 1172: # ! 1173: # SYSRI -- READ RECORD FROM INTERACTIVE CHANNEL ! 1174: # ! 1175: .globl sysri # define external entry point ! 1176: # ! 1177: # READS A RECORD FROM ONLINE TERMINAL FOR SPITBOL VARIABLE, ! 1178: # TERMINAL. IF ONLINE TERMINAL IS UNAVAILABLE THEN CODE THE ! 1179: # ENDFILE RETURN ONLY. ! 1180: # THE BUFFER PROVIDED IS OF LENGTH 120 CHARACTERS. SYSRI ! 1181: # SHOULD REPLACE THE COUNT IN THE SECOND WORD OF THE SCBLK ! 1182: # BY THE ACTUAL CHARACTER COUNT UNLESS BUFFER IS RIGHT ! 1183: # PADDED WITH ZEROES. ! 1184: # IT IS ALSO PERMISSIBLE TO TAKE THE ALTERNATIVE ! 1185: # RETURN AFTER ADJUSTING THE COUNT. ! 1186: # THE END OF FILE RETURN MAY BE USED IF THIS MAKES ! 1187: # SENSE ON THE TARGET MACHINE (E.G. IF THERE IS AN ! 1188: # EOF CHARACTER.) ! 1189: # ! 1190: # (XR) PTR TO 120 CHAR BUFFER (SCBLK PTR) ! 1191: # JSR SYSRI CALL TO READ LINE FROM TERMINAL ! 1192: # PPM LOC END OF FILE RETURN ! 1193: # (WA,WB,WC) MAY BE DESTROYED ! 1194: #page ! 1195: # ! 1196: # SYSRW -- REWIND FILE ! 1197: # ! 1198: .globl sysrw # define external entry point ! 1199: # ! 1200: # SYSRW IS USED TO REWIND A FILE I.E. REPOSITION THE FILE ! 1201: # AT THE START BEFORE THE FIRST RECORD. THE FILE SHOULD BE ! 1202: # CLOSED AND THE NEXT READ OR WRITE CALL WILL OPEN THE ! 1203: # FILE AT THE START. ! 1204: # ! 1205: # (WA) PTR TO FCBLK OR ZERO ! 1206: # (XR) REWIND ARG (SCBLK PTR) ! 1207: # JSR SYSRW CALL TO REWIND FILE ! 1208: # PPM LOC RETURN HERE IF FILE DOES NOT EXIST ! 1209: # PPM LOC RETURN HERE IF REWIND NOT ALLOWED ! 1210: # PPM LOC RETURN HERE IF I/O ERROR ! 1211: #page ! 1212: # ! 1213: # SYSST -- SET FILE POINTER ! 1214: # ! 1215: .globl sysst # define external entry point ! 1216: # ! 1217: # SYSST IS CALLED TO CHANGE THE POSITION OF A FILE ! 1218: # POINTER. THIS IS ACCOMPLISHED IN A SYSTEM DEPENDENT ! 1219: # MANNER, AND THUS THE 2ND AND 3RD ARGUMENTS ARE PASSED ! 1220: # UNCONVERTED. ! 1221: # ! 1222: # (WA) FCBLK POINTER ! 1223: # (WB) 2ND ARGUMENT ! 1224: # (WC) 3RD ARGUMENT ! 1225: # JSR SYSST CALL TO SET FILE POINTER ! 1226: # PPM LOC RETURN HERE IF INVALID 2ND ARG ! 1227: # PPM LOC RETURN HERE IF INVALID 3RD ARG ! 1228: # PPM LOC RETURN HERE IF FILE DOES NOT EXIST ! 1229: # PPM LOC RETURN HERE IF SET NOT ALLOWED ! 1230: # PPM LOC RETURN HERE IF I/O ERROR ! 1231: # ! 1232: #page ! 1233: # ! 1234: # SYSTM -- GET EXECUTION TIME SO FAR ! 1235: # ! 1236: .globl systm # define external entry point ! 1237: # ! 1238: # SYSTM IS USED TO OBTAIN THE AMOUNT OF EXECUTION TIME ! 1239: # USED SO FAR SINCE SPITBOL WAS GIVEN CONTROL. THE UNITS ! 1240: # ARE DESCRIBED AS MILLISECONDS IN THE SPITBOL OUTPUT, BUT ! 1241: # THE EXACT MEANING IS SYSTEM DEPENDENT. WHERE APPROPRIATE, ! 1242: # THIS VALUE SHOULD RELATE TO PROCESSOR RATHER THAN CLOCK ! 1243: # TIMING VALUES. ! 1244: # ! 1245: # JSR SYSTM CALL TO GET TIMER VALUE ! 1246: # (IA) TIME SO FAR IN MILLISECONDS ! 1247: #page ! 1248: # ! 1249: # SYSTT -- TRACE TOGGLE ! 1250: # ! 1251: .globl systt # define external entry point ! 1252: # ! 1253: # CALLED BY SPITBOL FUNCTION TRACE() WITH NO ARGS TO ! 1254: # TOGGLE THE SYSTEM TRACE SWITCH. THIS PERMITS TRACING OF ! 1255: # LABELS IN SPITBOL CODE TO BE TURNED ON OR OFF. ! 1256: # ! 1257: # JSR SYSTT CALL TO TOGGLE TRACE SWITCH ! 1258: #page ! 1259: # ! 1260: # SYSUL -- UNLOAD EXTERNAL FUNCTION ! 1261: # ! 1262: .globl sysul # define external entry point ! 1263: # ! 1264: # SYSUL IS USED TO UNLOAD A FUNCTION PREVIOUSLY ! 1265: # LOADED WITH A CALL TO SYSLD. ! 1266: # ! 1267: # (XR) PTR TO CONTROL BLOCK (EFBLK) ! 1268: # JSR SYSUL CALL TO UNLOAD FUNCTION ! 1269: # ! 1270: # THE FUNCTION CANNOT BE CALLED FOLLOWING A SYSUL CALL ! 1271: # UNTIL ANOTHER SYSLD CALL IS MADE FOR THE SAME FUNCTION. ! 1272: # ! 1273: # THE EFBLK CONTAINS THE FUNCTION CODE POINTER AND ALSO A ! 1274: # POINTER TO THE VRBLK CONTAINING THE FUNCTION NAME (SEE ! 1275: # DEFINITIONS AND DATA STRUCTURES SECTION). ! 1276: #page ! 1277: # ! 1278: # SYSXI -- EXIT TO PRODUCE LOAD MODULE ! 1279: # ! 1280: .globl sysxi # define external entry point ! 1281: # ! 1282: # WHEN SYSXI IS CALLED, XL CONTAINS EITHER A STRING POINTER ! 1283: # OR ZERO. IN THE FORMER CASE, THE STRING GIVES THE ! 1284: # CHARACTER NAME OF A PROGRAM. THE INTENTION IS THAT ! 1285: # SPITBOL EXECUTION SHOULD BE TERMINATED FORTHWITH AND ! 1286: # THE NAMED PROGRAM LOADED AND EXECUTED. THIS TYPE OF CHAIN ! 1287: # EXECUTION IS VERY SYSTEM DEPENDENT AND IMPLEMENTORS MAY ! 1288: # CHOOSE TO OMIT IT OR FIND IT IMPOSSIBLE TO PROVIDE. ! 1289: # IF (XL) IS ZERO,IA CONTAINS ONE OF THE FOLLOWING INTEGERS ! 1290: # ! 1291: # -1, -2, -3 ! 1292: # CREATE IF POSSIBLE A LOAD MODULE CONTAINING ONLY THE ! 1293: # IMPURE AREA OF MEMORY WHICH NEEDS TO BE LOADED WITH ! 1294: # A COMPATIBLE PURE SEGMENT FOR SUBSEQUENT EXECUTIONS. ! 1295: # VERSION NUMBERS TO CHECK COMPATIBILITY SHOULD BE ! 1296: # KEPT IN BOTH SEGMENTS AND CHECKED ON LOADING. ! 1297: # TO ASSIST WITH THIS CHECK, (XR) ON ENTRY IS A ! 1298: # POINTER TO AN SCBLK CONTAINING THE SPITBOL MAJOR ! 1299: # VERSION NUMBER V.V (SEE SYSID). ! 1300: # ! 1301: # 0 IF POSSIBLE, RETURN CONTROL TO JOB CONTROL ! 1302: # COMMAND LEVEL. THE EFFECT IF AVAILABLE WILL BE ! 1303: # SYSTEM DEPENDENT. ! 1304: # ! 1305: # +1, +2, +3 ! 1306: # CREATE IF POSSIBLE A LOAD MODULE FROM ALL OF ! 1307: # MEMORY. IT SHOULD BE POSSIBLE TO LOAD AND EXECUTE ! 1308: # THIS MODULE DIRECTLY. ! 1309: # ! 1310: # IN THE CASE OF SAVED LOAD MODULES, THE STATUS OF OPEN ! 1311: # FILES IS NOT PRESERVED AND IMPLEMENTORS MAY CHOOSE TO ! 1312: # OFFER MEANS OF ATTACHING FILES BEFORE EXECUTION OF LOAD ! 1313: # MODULES STARTS OR LEAVE IT TO THE USER TO INCLUDE ! 1314: # SUITABLE INPUT(), OUTPUT() CALLS IN HIS PROGRAM. ! 1315: # SYSXI SHOULD MAKE A NOTE THAT NO I/O CHANNELS, ! 1316: # INCLUDING STANDARD FILES, HAVE FILES ATTACHED SO THAT ! 1317: # CALLS OF SYSIN, SYSOU, SYSPR, SYSRD SHOULD FAIL UNLESS ! 1318: # NEW ASSOCIATIONS ARE MADE FOR THE LOAD MODULE. ! 1319: # AT LEAST IN THE CASE OF THE STANDARD OUTPUT FILE, IT IS ! 1320: # RECOMMENDED THAT EITHER THE USER BE REQUIRED TO ATTACH ! 1321: # A FILE OR THAT A DEFAULT FILE IS ATTACHED, SINCE THE ! 1322: # PROBLEM OF ERROR MESSAGES GENERATED BY THE LOAD MODULE ! 1323: # IS OTHERWISE SEVERE. AS A LAST RESORT, IF SPITBOL ! 1324: # ATTEMPTS TO WRITE TO THE STANDARD OUTPUT FILE AND GETS A ! 1325: # REPLY INDICATING THAT SUCH OUPUT IS UNACCEPTABLE IT STOPS ! 1326: # BY USING AN ENTRY TO SYSEJ WITH ENDING CODE 998. ! 1327: # AS DESCRIBED BELOW, PASSING OF SOME ARGUMENTS MAKES IT ! 1328: # CLEAR THAT LOAD MODULE WILL USE A STANDARD OUTPUT FILE. ! 1329: # ! 1330: # IF USE IS MADE OF FCBLKS FOR I/O ASSOCIATION, SPITBOL ! 1331: # BUILDS A CHAIN SO THAT THOSE IN USE MAY BE FOUND IN SYSXI ! 1332: # AND SYSEJ. THE NODES ARE 4 WORDS LONG. THIRD WORD ! 1333: # CONTAINS LINK TO NEXT NODE OR 0, FOURTH WORD CONTAINS ! 1334: # FCBLK POINTER. ! 1335: #page ! 1336: # ! 1337: # SYSXI (CONTINUED) ! 1338: # ! 1339: # (XL) ZERO OR SCBLK PTR ! 1340: # (XR) PTR TO V.V SCBLK ! 1341: # (IA) SIGNED INTEGER ARGUMENT ! 1342: # (WB) 0 OR PTR TO HEAD OF FCBLK CHAIN ! 1343: # JSR SYSXI CALL TO EXIT ! 1344: # PPM LOC REQUESTED ACTION NOT POSSIBLE ! 1345: # PPM LOC ACTION CAUSED IRRECOVERABLE ERROR ! 1346: # (REGISTERS) SHOULD BE PRESERVED OVER CALL ! 1347: # ! 1348: # LOADING AND RUNNING THE LOAD MODULE OR RETURNING FROM ! 1349: # JCL COMMAND LEVEL CAUSES EXECUTION TO RESUME AT THE POINT ! 1350: # AFTER THE ERROR RETURNS WHICH FOLLOW THE CALL OF SYSXI. ! 1351: # THE VALUE PASSED AS EXIT ARGUMENT IS USED TO INDICATE ! 1352: # OPTIONS REQUIRED ON RESUMPTION OF LOAD MODULE. ! 1353: # +1 OR -1 REQUIRE THAT ON RESUMPTION, SYSID AND SYSPP BE ! 1354: # CALLED AND A HEADING PRINTED ON THE STANDARD OUTPUT FILE. ! 1355: # +2 OR -2 INDICATE THAT SYSPP WILL BE CALLED BUT NOT SYSID ! 1356: # AND NO HEADING WILL BE PUT ON STANDARD OUTPUT FILE. ! 1357: # ABOVE OPTIONS HAVE THE OBVIOUS IMPLICATION THAT A ! 1358: # STANDARD O/P FILE MUST BE PROVIDED FOR THE LOAD MODULE. ! 1359: # +3 OR -3 INDICATE CALLS OF NEITHER SYSID NOR SYSPP ! 1360: # AND NO HEADING WILL BE PLACED ON STANDARD OUTPUT FILE. ! 1361: # NO RETURN FROM SYSXI IS POSSIBLE IF ANOTHER PROGRAM ! 1362: # IS LOADED AND ENTERED. ! 1363: #page ! 1364: # ! 1365: # INTRODUCE THE INTERNAL PROCEDURES. ! 1366: # ! 1367: .globl acess ! 1368: .globl acomp ! 1369: .globl alloc ! 1370: .globl alobf ! 1371: .globl alocs ! 1372: .globl alost ! 1373: .globl apndb ! 1374: .globl arith ! 1375: .globl asign ! 1376: .globl asinp ! 1377: .globl blkln ! 1378: .globl cdgcg ! 1379: .globl cdgex ! 1380: .globl cdgnm ! 1381: .globl cdgvl ! 1382: .globl cdwrd ! 1383: .globl cmgen ! 1384: .globl cmpil ! 1385: .globl cncrd ! 1386: .globl copyb ! 1387: .globl dffnc ! 1388: .globl dtach ! 1389: .globl dtype ! 1390: .globl dumpr ! 1391: .globl ermsg ! 1392: .globl ertex ! 1393: .globl evali ! 1394: .globl evalp ! 1395: .globl evals ! 1396: .globl evalx ! 1397: .globl exbld ! 1398: .globl expan ! 1399: .globl expap ! 1400: .globl expdm ! 1401: .globl expop ! 1402: .globl flstg ! 1403: .globl gbcol ! 1404: .globl gbcpf ! 1405: .globl gtarr ! 1406: #page ! 1407: .globl gtcod ! 1408: .globl gtexp ! 1409: .globl gtint ! 1410: .globl gtnum ! 1411: .globl gtnvr ! 1412: .globl gtpat ! 1413: .globl gtrea ! 1414: .globl gtsmi ! 1415: .globl gtstg ! 1416: .globl gtvar ! 1417: .globl hashs ! 1418: .globl icbld ! 1419: .globl ident ! 1420: .globl inout ! 1421: .globl insbf ! 1422: .globl iofcb ! 1423: .globl ioppf ! 1424: .globl ioput ! 1425: .globl ktrex ! 1426: .globl kwnam ! 1427: .globl lcomp ! 1428: .globl listr ! 1429: .globl listt ! 1430: .globl nexts ! 1431: .globl patin ! 1432: .globl patst ! 1433: .globl pbild ! 1434: .globl pconc ! 1435: .globl pcopy ! 1436: .globl prflr ! 1437: .globl prflu ! 1438: .globl prpar ! 1439: .globl prtch ! 1440: .globl prtic ! 1441: .globl prtis ! 1442: .globl prtin ! 1443: .globl prtmi ! 1444: .globl prtmx ! 1445: .globl prtnl ! 1446: .globl prtnm ! 1447: .globl prtnv ! 1448: .globl prtpg ! 1449: .globl prtps ! 1450: .globl prtsn ! 1451: .globl prtst ! 1452: #page ! 1453: .globl prttr ! 1454: .globl prtvl ! 1455: .globl prtvn ! 1456: .globl rcbld ! 1457: .globl readr ! 1458: .globl sbstr ! 1459: .globl scane ! 1460: .globl scngf ! 1461: .globl setvr ! 1462: .globl sorta ! 1463: .globl sortc ! 1464: .globl sortf ! 1465: .globl sorth ! 1466: .globl tfind ! 1467: .globl trace ! 1468: .globl trbld ! 1469: .globl trimr ! 1470: .globl trxeq ! 1471: .globl xscan ! 1472: .globl xscni ! 1473: # ! 1474: # INTRODUCE THE INTERNAL ROUTINES ! 1475: # ! 1476: .globl arref ! 1477: .globl cfunc ! 1478: .globl exfal ! 1479: .globl exint ! 1480: .globl exits ! 1481: .globl exixr ! 1482: .globl exnam ! 1483: .globl exnul ! 1484: .globl exrea ! 1485: .globl exsid ! 1486: .globl exvnm ! 1487: .globl failp ! 1488: .globl flpop ! 1489: .globl indir ! 1490: .globl match ! 1491: .globl retrn ! 1492: .globl stcov ! 1493: .globl stmgo ! 1494: .globl stopr ! 1495: .globl succp ! 1496: .globl sysab ! 1497: .globl systu ! 1498: #title s p i t b o l -- definitions and data structures ! 1499: #sec # start of definitions section ! 1500: # ! 1501: # DEFINITIONS OF MACHINE PARAMETERS ! 1502: # ! 1503: # THE MINIMAL TRANSLATOR SHOULD SUPPLY APPROPRIATE VALUES ! 1504: # FOR THE PARTICULAR TARGET MACHINE FOR ALL THE ! 1505: # EQU * ! 1506: # DEFINITIONS GIVEN AT THE START OF THIS SECTION. ! 1507: # ! 1508: .set cfp$a,256 # number of characters in alphabet ! 1509: # ! 1510: .set cfp$b,4 # bytes/word addressing factor ! 1511: # ! 1512: .set cfp$c,4 # number of characters per word ! 1513: # ! 1514: .set cfp$f,8 # offset in bytes to chars in ! 1515: # SCBLK. SEE SCBLK FORMAT. ! 1516: # ! 1517: .set cfp$i,1 # number of words in integer constant ! 1518: # ! 1519: .set cfp$m,0x7fffffff# max positive integer in one word ! 1520: # ! 1521: .set cfp$n,32 # number of bits in one word ! 1522: # ! 1523: # THE FOLLOWING DEFINITIONS REQUIRE THE SUPPLY OF EITHER ! 1524: # A SINGLE PARAMETER IF REAL ARITHMETIC IS OMITTED OR ! 1525: # THREE PARAMETERS IF REAL ARITHMETIC IS INCLUDED. ! 1526: # ! 1527: # ! 1528: .set cfp$r,1 # number of words in real constant ! 1529: # ! 1530: .set cfp$s,6 # number of sig digs for real output ! 1531: # ! 1532: .set cfp$x,2 # max digits in real exponent ! 1533: # ! 1534: .set mxdgs,cfp$s+cfp$x# max digits in real number ! 1535: # ! 1536: .set nstmx,mxdgs+5 # max space for real (for +0.e+) ! 1537: # ! 1538: # THE FOLLOWING DEFINITION FOR CFP$U SUPPLIES A REALISTIC ! 1539: # UPPER BOUND ON THE SIZE OF THE ALPHABET. CFP$U IS USED ! 1540: # TO SAVE SPACE IN THE SCANE BSW-IFF-ESW TABLE AND TO EASE ! 1541: # TRANSLATION STORAGE REQUIREMENTS. ! 1542: # ! 1543: .set cfp$u,128 # realistic upper bound on alphabet ! 1544: #page ! 1545: # ! 1546: # ENVIRONMENT PARAMETERS ! 1547: # ! 1548: # THE SPITBOL PROGRAM IS ESSENTIALLY INDEPENDENT OF ! 1549: # THE DEFINITIONS OF THESE PARAMETERS. HOWEVER, THE ! 1550: # EFFICIENCY OF THE SYSTEM MAY BE AFFECTED. CONSEQUENTLY, ! 1551: # THESE PARAMETERS MAY REQUIRE TUNING FOR A GIVEN VERSION ! 1552: # THE VALUES GIVEN IN COMMENTS HAVE BEEN SUCCESSFULLY USED. ! 1553: # ! 1554: # E$SRS IS THE NUMBER OF WORDS TO RESERVE AT THE END OF ! 1555: # STORAGE FOR END OF RUN PROCESSING. IT SHOULD BE ! 1556: # SET AS SMALL AS POSSIBLE WITHOUT CAUSING MEMORY OVERFLOW ! 1557: # IN CRITICAL SITUATIONS (E.G. MEMORY OVERFLOW TERMINATION) ! 1558: # AND SHOULD THUS RESERVE SUFFICIENT SPACE AT LEAST FOR ! 1559: # AN SCBLK CONTAINING SAY 30 CHARACTERS. ! 1560: # ! 1561: .set e$srs,50 # 30 words ! 1562: # ! 1563: # E$STS IS THE NUMBER OF WORDS GRABBED IN A CHUNK WHEN ! 1564: # STORAGE IS ALLOCATED IN THE STATIC REGION. THE MINIMUM ! 1565: # PERMITTED VALUE IS 256/CFP$B. LARGER VALUES WILL LEAD ! 1566: # TO INCREASED EFFICIENCY AT THE COST OF WASTING MEMORY. ! 1567: # ! 1568: .set e$sts,512 # 500 words ! 1569: # ! 1570: # E$CBS IS THE SIZE OF CODE BLOCK ALLOCATED INITIALLY AND ! 1571: # THE EXPANSION INCREMENT IF OVERFLOW OCCURS. IF THIS VALUE ! 1572: # IS TOO SMALL OR TOO LARGE, EXCESSIVE GARBAGE COLLECTIONS ! 1573: # WILL OCCUR DURING COMPILATION AND MEMORY MAY BE LOST ! 1574: # IN THE CASE OF A TOO LARGE VALUE. ! 1575: # ! 1576: .set e$cbs,512 # 500 words ! 1577: # ! 1578: # E$HNB IS THE NUMBER OF BUCKET HEADERS IN THE VARIABLE ! 1579: # HASH TABLE. IT SHOULD ALWAYS BE ODD. LARGER VALUES WILL ! 1580: # SPEED UP COMPILATION AND INDIRECT REFERENCES AT THE ! 1581: # EXPENSE OF ADDITIONAL STORAGE FOR THE HASH TABLE ITSELF. ! 1582: # ! 1583: .set e$hnb,253 # 127 bucket headers ! 1584: # ! 1585: # E$HNW IS THE MAXIMUM NUMBER OF WORDS OF A STRING ! 1586: # NAME WHICH PARTICIPATE IN THE STRING HASH ALGORITHM. ! 1587: # LARGER VALUES GIVE A BETTER HASH AT THE EXPENSE OF TAKING ! 1588: # LONGER TO COMPUTE THE HASH. THERE IS SOME OPTIMAL VALUE. ! 1589: # ! 1590: .set e$hnw,3 # 6 words ! 1591: # ! 1592: # E$FSP . IF THE AMOUNT OF FREE SPACE LEFT AFTER A GARBAGE ! 1593: # COLLECTION IS SMALL COMPARED TO THE TOTAL AMOUNT OF SPACE ! 1594: # IN USE GARBAGE COLLECTOR THRASHING IS LIKELY TO OCCUR AS ! 1595: # THIS SPACE IS USED UP. E$FSP IS A MEASURE OF THE ! 1596: # MINIMUM PERCENTAGE OF DYNAMIC MEMORY LEFT AS FREE SPACE ! 1597: # BEFORE THE SYSTEM ROUTINE SYSMM IS CALLED TO TRY TO ! 1598: # OBTAIN MORE MEMORY. ! 1599: # ! 1600: .set e$fsp,20 # 15 percent ! 1601: #page ! 1602: # ! 1603: # DEFINITIONS OF CODES FOR LETTERS ! 1604: # ! 1605: .set ch$la,65 # letter a ! 1606: .set ch$lb,66 # letter b ! 1607: .set ch$lc,67 # letter c ! 1608: .set ch$ld,68 # letter d ! 1609: .set ch$le,69 # letter e ! 1610: .set ch$lf,70 # letter f ! 1611: .set ch$lg,71 # letter g ! 1612: .set ch$lh,72 # letter h ! 1613: .set ch$li,73 # letter i ! 1614: .set ch$lj,74 # letter j ! 1615: .set ch$lk,75 # letter k ! 1616: .set ch$ll,76 # letter l ! 1617: .set ch$lm,77 # letter m ! 1618: .set ch$ln,78 # letter n ! 1619: .set ch$lo,79 # letter o ! 1620: .set ch$lp,80 # letter p ! 1621: .set ch$lq,81 # letter q ! 1622: .set ch$lr,82 # letter r ! 1623: .set ch$ls,83 # letter s ! 1624: .set ch$lt,84 # letter t ! 1625: .set ch$lu,85 # letter u ! 1626: .set ch$lv,86 # letter v ! 1627: .set ch$lw,87 # letter w ! 1628: .set ch$lx,88 # letter x ! 1629: .set ch$ly,89 # letter y ! 1630: .set ch$l$,90 # letter z ! 1631: # ! 1632: # DEFINITIONS OF CODES FOR DIGITS ! 1633: # ! 1634: .set ch$d0,48 # digit 0 ! 1635: .set ch$d1,49 # digit 1 ! 1636: .set ch$d2,50 # digit 2 ! 1637: .set ch$d3,51 # digit 3 ! 1638: .set ch$d4,52 # digit 4 ! 1639: .set ch$d5,53 # digit 5 ! 1640: .set ch$d6,54 # digit 6 ! 1641: .set ch$d7,55 # digit 7 ! 1642: .set ch$d8,56 # digit 8 ! 1643: .set ch$d9,57 # digit 9 ! 1644: #page ! 1645: # ! 1646: # DEFINITIONS OF CODES FOR SPECIAL CHARACTERS ! 1647: # ! 1648: # THE NAMES OF THESE CHARACTERS ARE RELATED TO THEIR ! 1649: # ORIGINAL REPRESENTATION IN THE EBCDIC SET CORRESPONDING ! 1650: # TO THE DESCRIPTION IN STANDARD SNOBOL4 MANUALS AND TEXTS. ! 1651: # ! 1652: .set ch$am,38 # keyword operator (ampersand) ! 1653: .set ch$as,42 # multiplication symbol (asterisk) ! 1654: .set ch$at,64 # cursor position operator (at) ! 1655: .set ch$bb,60 # left array bracket (less than) ! 1656: .set ch$bl,32 # blank ! 1657: .set ch$br,124 # alternation operator (vertical bar) ! 1658: .set ch$cl,58 # goto symbol (colon) ! 1659: .set ch$cm,44 # comma ! 1660: .set ch$dl,36 # indirection operator (dollar) ! 1661: .set ch$dt,46 # name operator (dot) ! 1662: .set ch$dq,34 # double quote ! 1663: .set ch$eq,61 # equal sign ! 1664: .set ch$ex,33 # exponentiation operator (exclm) ! 1665: .set ch$mn,45 # minus sign ! 1666: .set ch$nm,35 # number sign ! 1667: .set ch$nt,126 # negation operator (not) ! 1668: .set ch$pc,37 # percent ! 1669: .set ch$pl,43 # plus sign ! 1670: .set ch$pp,40 # left parenthesis ! 1671: .set ch$rb,62 # right array bracket (grtr than) ! 1672: .set ch$rp,41 # right parenthesis ! 1673: .set ch$qu,63 # interrogation operator (question) ! 1674: .set ch$sl,47 # slash ! 1675: .set ch$sm,59 # semicolon ! 1676: .set ch$sq,39 # single quote ! 1677: .set ch$un,95 # special identifier char (underline) ! 1678: .set ch$ob,91 # opening bracket ! 1679: .set ch$cb,93 # closing bracket ! 1680: #page ! 1681: # ! 1682: # REMAINING CHARS ARE OPTIONAL ADDITIONS TO THE STANDARDS. ! 1683: # ! 1684: # TAB CHARACTERS - SYNTACTICALLY EQUIVALENT TO BLANK ! 1685: # ! 1686: .set ch$ht,9 # horizontal tab ! 1687: # ! 1688: # LOWER CASE OR SHIFTED CASE ALPHABETIC CHARS ! 1689: # ! 1690: .set ch$$a,97 # shifted a ! 1691: .set ch$$b,98 # shifted b ! 1692: .set ch$$c,99 # shifted c ! 1693: .set ch$$d,100 # shifted d ! 1694: .set ch$$e,101 # shifted e ! 1695: .set ch$$f,102 # shifted f ! 1696: .set ch$$g,103 # shifted g ! 1697: .set ch$$h,104 # shifted h ! 1698: .set ch$$i,105 # shifted i ! 1699: .set ch$$j,106 # shifted j ! 1700: .set ch$$k,107 # shifted k ! 1701: .set ch$$l,108 # shifted l ! 1702: .set ch$$m,109 # shifted m ! 1703: .set ch$$n,110 # shifted n ! 1704: .set ch$$o,111 # shifted o ! 1705: .set ch$$p,112 # shifted p ! 1706: .set ch$$q,113 # shifted q ! 1707: .set ch$$r,114 # shifted r ! 1708: .set ch$$s,115 # shifted s ! 1709: .set ch$$t,116 # shifted t ! 1710: .set ch$$u,117 # shifted u ! 1711: .set ch$$v,118 # shifted v ! 1712: .set ch$$w,119 # shifted w ! 1713: .set ch$$x,120 # shifted x ! 1714: .set ch$$y,121 # shifted y ! 1715: .set ch$$$,122 # shifted z ! 1716: # IF A DELIMITER OTHER THAN CH$CM MUST BE USED IN ! 1717: # THE THIRD ARGUMENT OF INPUT(),OUTPUT() THEN .CIOD SHOULD ! 1718: # BE DEFINED AND A PARAMETER SUPPLIED FOR IODEL. ! 1719: # ! 1720: .set iodel,0 ! 1721: #page ! 1722: # ! 1723: # DATA BLOCK FORMATS AND DEFINITIONS ! 1724: # ! 1725: # THE FOLLOWING SECTIONS DESCRIBE THE DETAILED FORMAT OF ! 1726: # ALL POSSIBLE DATA BLOCKS IN STATIC AND DYNAMIC MEMORY. ! 1727: # ! 1728: # EVERY BLOCK HAS A NAME OF THE FORM XXBLK WHERE XX IS A ! 1729: # UNIQUE TWO CHARACTER IDENTIFIER. THE FIRST WORD OF EVERY ! 1730: # BLOCK MUST CONTAIN A POINTER TO A PROGRAM LOCATION IN THE ! 1731: # INTERPRETOR WHICH IS IMMEDIATELY PRECEDED BY AN ADDRESS ! 1732: # CONSTANT CONTAINING THE VALUE BL$XX WHERE XX IS THE BLOCK ! 1733: # IDENTIFIER. THIS PROVIDES A UNIFORM MECHANISM FOR ! 1734: # DISTINGUISHING BETWEEN THE VARIOUS BLOCK TYPES. ! 1735: # ! 1736: # IN SOME CASES, THE CONTENTS OF THE FIRST WORD IS CONSTANT ! 1737: # FOR A GIVEN BLOCK TYPE AND MERELY SERVES AS A POINTER ! 1738: # TO THE IDENTIFYING ADDRESS CONSTANT. HOWEVER, IN OTHER ! 1739: # CASES THERE ARE SEVERAL POSSIBILITIES FOR THE FIRST ! 1740: # WORD IN WHICH CASE EACH OF THE SEVERAL PROGRAM ENTRY ! 1741: # POINTS MUST BE PRECEDED BY THE APPROPRIATE CONSTANT. ! 1742: # ! 1743: # IN EACH BLOCK, SOME OF THE FIELDS ARE RELOCATABLE. THIS ! 1744: # MEANS THAT THEY MAY CONTAIN A POINTER TO ANOTHER BLOCK ! 1745: # IN THE DYNAMIC AREA. (TO BE MORE PRECISE, IF THEY CONTAIN ! 1746: # A POINTER WITHIN THE DYNAMIC AREA, THEN IT IS A POINTER ! 1747: # TO A BLOCK). SUCH FIELDS MUST BE MODIFIED BY THE GARBAGE ! 1748: # COLLECTOR (PROCEDURE GBCOL) WHENEVER BLOCKS ARE COMPACTED ! 1749: # IN THE DYNAMIC REGION. THE GARBAGE COLLECTOR (ACTUALLY ! 1750: # PROCEDURE GBCPF) REQUIRES THAT ALL SUCH RELOCATABLE ! 1751: # FIELDS IN A BLOCK MUST BE CONTIGUOUS. ! 1752: #page ! 1753: # ! 1754: # THE DESCRIPTION FORMAT USES THE FOLLOWING SCHEME. ! 1755: # ! 1756: # 1) BLOCK TITLE AND TWO CHARACTER IDENTIFIER ! 1757: # ! 1758: # 2) DESCRIPTION OF BASIC USE OF BLOCK AND INDICATION ! 1759: # OF CIRCUMSTANCES UNDER WHICH IT IS CONSTRUCTED. ! 1760: # ! 1761: # 3) PICTURE OF THE BLOCK FORMAT. IN THESE PICTURES LOW ! 1762: # MEMORY ADDRESSES ARE AT THE TOP OF THE PAGE. FIXED ! 1763: # LENGTH FIELDS ARE SURROUNDED BY I (LETTER I). FIELDS ! 1764: # WHICH ARE FIXED LENGTH BUT WHOSE LENGTH IS DEPENDENT ! 1765: # ON A CONFIGURATION PARAMETER ARE SURROUNDED BY * ! 1766: # (ASTERISK). VARIABLE LENGTH FIELDS ARE SURROUNDED ! 1767: # BY / (SLASH). ! 1768: # ! 1769: # 4) DEFINITION OF SYMBOLIC OFFSETS TO FIELDS IN ! 1770: # BLOCK AND OF THE SIZE OF THE BLOCK IF FIXED LENGTH ! 1771: # OR OF THE SIZE OF THE FIXED LENGTH FIELDS IF THE ! 1772: # BLOCK IS VARIABLE LENGTH. ! 1773: # NOTE THAT SOME ROUTINES SUCH AS GBCPF ASSUME ! 1774: # CERTAIN OFFSETS ARE EQUAL. THE DEFINITIONS ! 1775: # GIVEN HERE ENFORCE THIS. MAKE CHANGES TO ! 1776: # THEM ONLY WITH DUE CARE. ! 1777: # ! 1778: # DEFINITIONS OF COMMON OFFSETS ! 1779: # ! 1780: .set offs1,1 ! 1781: .set offs2,2 ! 1782: .set offs3,3 ! 1783: # ! 1784: # 5) DETAILED COMMENTS ON THE SIGNIFICANCE AND FORMATS ! 1785: # OF THE VARIOUS FIELDS. ! 1786: # ! 1787: # THE ORDER IS ALPHABETICAL BY IDENTIFICATION CODE. ! 1788: #page ! 1789: # ! 1790: # DEFINITIONS OF BLOCK CODES ! 1791: # ! 1792: # THIS TABLE PROVIDES A UNIQUE IDENTIFICATION CODE FOR ! 1793: # EACH SEPARATE BLOCK TYPE. THE FIRST WORD OF A BLOCK IN ! 1794: # THE DYNAMIC AREA ALWAYS CONTAINS THE ADDRESS OF A PROGRAM ! 1795: # ENTRY POINT. THE BLOCK CODE IS USED AS THE ENTRY POINT ID ! 1796: # THE ORDER OF THESE CODES DICTATES THE ORDER OF THE TABLE ! 1797: # USED BY THE DATATYPE FUNCTION (SCNMT IN THE CONSTANT SEC) ! 1798: # ! 1799: # BLOCK CODES FOR ACCESSIBLE DATATYPES ! 1800: # ! 1801: .set bl$ar,0 # arblk array ! 1802: .set bl$bc,bl$ar+1 # bcblk buffer ! 1803: .set bl$cd,bl$bc+1 # cdblk code ! 1804: .set bl$ex,bl$cd+1 # exblk expression ! 1805: .set bl$ic,bl$ex+1 # icblk integer ! 1806: .set bl$nm,bl$ic+1 # nmblk name ! 1807: .set bl$p0,bl$nm+1 # p0blk pattern ! 1808: .set bl$p1,bl$p0+1 # p1blk pattern ! 1809: .set bl$p2,bl$p1+1 # p2blk pattern ! 1810: .set bl$rc,bl$p2+1 # rcblk real ! 1811: .set bl$sc,bl$rc+1 # scblk string ! 1812: .set bl$se,bl$sc+1 # seblk expression ! 1813: .set bl$tb,bl$se+1 # tbblk table ! 1814: .set bl$vc,bl$tb+1 # vcblk array ! 1815: .set bl$xn,bl$vc+1 # xnblk external ! 1816: .set bl$xr,bl$xn+1 # xrblk external ! 1817: .set bl$pd,bl$xr+1 # pdblk program defined datatype ! 1818: # ! 1819: .set bl$$d,bl$pd+1 # number of block codes for data ! 1820: # ! 1821: # OTHER BLOCK CODES ! 1822: # ! 1823: .set bl$tr,bl$pd+1 # trblk ! 1824: .set bl$bf,bl$tr+1 # bfblk ! 1825: .set bl$cc,bl$bf+1 # ccblk ! 1826: .set bl$cm,bl$cc+1 # cmblk ! 1827: .set bl$ct,bl$cm+1 # ctblk ! 1828: .set bl$df,bl$ct+1 # dfblk ! 1829: .set bl$ef,bl$df+1 # efblk ! 1830: .set bl$ev,bl$ef+1 # evblk ! 1831: .set bl$ff,bl$ev+1 # ffblk ! 1832: .set bl$kv,bl$ff+1 # kvblk ! 1833: .set bl$pf,bl$kv+1 # pfblk ! 1834: .set bl$te,bl$pf+1 # teblk ! 1835: # ! 1836: .set bl$$i,0 # default identification code ! 1837: .set bl$$t,bl$tr+1 # code for data or trace block ! 1838: .set bl$$$,bl$te+1 # number of block codes ! 1839: #page ! 1840: # ! 1841: # FIELD REFERENCES ! 1842: # ! 1843: # REFERENCES TO THE FIELDS OF DATA BLOCKS ARE SYMBOLIC ! 1844: # (I.E. USE THE SYMBOLIC OFFSETS) WITH THE FOLLOWING ! 1845: # EXCEPTIONS. ! 1846: # ! 1847: # 1) REFERENCES TO THE FIRST WORD ARE USUALLY NOT ! 1848: # SYMBOLIC SINCE THEY USE THE (X) OPERAND FORMAT. ! 1849: # ! 1850: # 2) THE CODE WHICH CONSTRUCTS A BLOCK IS OFTEN NOT ! 1851: # SYMBOLIC AND SHOULD BE CHANGED IF THE CORRESPONDING ! 1852: # BLOCK FORMAT IS MODIFIED. ! 1853: # ! 1854: # 3) THE PLC AND PSC INSTRUCTIONS IMPLY AN OFFSET ! 1855: # CORRESPONDING TO THE DEFINITION OF CFP$F. ! 1856: # ! 1857: # 4) THERE ARE NON-SYMBOLIC REFERENCES (EASILY CHANGED) ! 1858: # IN THE GARBAGE COLLECTOR (PROCEDURES GBCPF, BLKLN). ! 1859: # ! 1860: # 5) THE FIELDS IDVAL, FARGS APPEAR IN SEVERAL BLOCKS ! 1861: # AND ANY CHANGES MUST BE MADE IN PARALLEL TO ALL ! 1862: # BLOCKS CONTAINING THE FIELDS. THE ACTUAL REFERENCES ! 1863: # TO THESE FIELDS ARE SYMBOLIC WITH THE ABOVE ! 1864: # LISTED EXCEPTIONS. ! 1865: # ! 1866: # 6) SEVERAL SPOTS IN THE CODE ASSUME THAT THE ! 1867: # DEFINITIONS OF THE FIELDS VRVAL, TEVAL, TRNXT ARE ! 1868: # THE SAME (THESE ARE SECTIONS OF CODE WHICH SEARCH ! 1869: # OUT ALONG A TRBLK CHAIN FROM A VARIABLE). ! 1870: # ! 1871: # 7) REFERENCES TO THE FIELDS OF AN ARRAY BLOCK IN THE ! 1872: # ARRAY REFERENCE ROUTINE ARREF ARE NON-SYMBOLIC. ! 1873: # ! 1874: # APART FROM THE EXCEPTIONS LISTED, REFERENCES ARE SYMBOLIC ! 1875: # AS FAR AS POSSIBLE AND MODIFYING THE ORDER OR NUMBER ! 1876: # OF FIELDS WILL NOT REQUIRE CHANGES. ! 1877: #page ! 1878: # ! 1879: # COMMON FIELDS FOR FUNCTION BLOCKS ! 1880: # ! 1881: # BLOCKS WHICH REPRESENT CALLABLE FUNCTIONS HAVE TWO ! 1882: # COMMON FIELDS AT THE START OF THE BLOCK AS FOLLOWS. ! 1883: # ! 1884: # +------------------------------------+ ! 1885: # I FCODE I ! 1886: # +------------------------------------+ ! 1887: # I FARGS I ! 1888: # +------------------------------------+ ! 1889: # / / ! 1890: # / REST OF FUNCTION BLOCK / ! 1891: # / / ! 1892: # +------------------------------------+ ! 1893: # ! 1894: .set fcode,0 # pointer to code for function ! 1895: .set fargs,1 # number of arguments ! 1896: # ! 1897: # FCODE IS A POINTER TO THE LOCATION IN THE INTERPRETOR ! 1898: # PROGRAM WHICH PROCESSES THIS TYPE OF FUNCTION CALL. ! 1899: # ! 1900: # FARGS IS THE EXPECTED NUMBER OF ARGUMENTS. THE ACTUAL ! 1901: # NUMBER OF ARGUMENTS IS ADJUSTED TO THIS AMOUNT BY ! 1902: # DELETING EXTRA ARGUMENTS OR SUPPLYING TRAILING NULLS ! 1903: # FOR MISSING ONES BEFORE TRANSFERRING THOUGH FCODE. ! 1904: # A VALUE OF 999 MAY BE USED IN THIS FIELD TO INDICATE A ! 1905: # VARIABLE NUMBER OF ARGUMENTS (SEE SVBLK FIELD SVNAR). ! 1906: # ! 1907: # THE BLOCK TYPES WHICH FOLLOW THIS SCHEME ARE. ! 1908: # ! 1909: # FFBLK FIELD FUNCTION ! 1910: # DFBLK DATATYPE FUNCTION ! 1911: # PFBLK PROGRAM DEFINED FUNCTION ! 1912: # EFBLK EXTERNAL LOADED FUNCTION ! 1913: #page ! 1914: # ! 1915: # IDENTIFICATION FIELD ! 1916: # ! 1917: # ! 1918: # ID FIELD ! 1919: # ! 1920: # CERTAIN PROGRAM ACCESSIBLE OBJECTS (THOSE WHICH CONTAIN ! 1921: # OTHER DATA VALUES AND CAN BE COPIED) ARE GIVEN A UNIQUE ! 1922: # IDENTIFICATION NUMBER (SEE EXSID). THIS ID VALUE IS AN ! 1923: # ADDRESS INTEGER VALUE WHICH IS ALWAYS STORED IN WORD TWO. ! 1924: # ! 1925: .set idval,1 # id value field ! 1926: # ! 1927: # THE BLOCKS CONTAINING AN IDVAL FIELD ARE. ! 1928: # ! 1929: # ARBLK ARRAY ! 1930: # BCBLK BUFFER CONTROL BLOCK ! 1931: # PDBLK PROGRAM DEFINED DATATYPE ! 1932: # TBBLK TABLE ! 1933: # VCBLK VECTOR BLOCK (ARRAY) ! 1934: # ! 1935: # NOTE THAT A ZERO IDVAL MEANS THAT THE BLOCK IS ONLY ! 1936: # HALF BUILT AND SHOULD NOT BE DUMPED (SEE DUMPR). ! 1937: #page ! 1938: # ! 1939: # ARRAY BLOCK (ARBLK) ! 1940: # ! 1941: # AN ARRAY BLOCK REPRESENTS AN ARRAY VALUE OTHER THAN ONE ! 1942: # WITH ONE DIMENSION WHOSE LOWER BOUND IS ONE (SEE VCBLK). ! 1943: # AN ARBLK IS BUILT WITH A CALL TO THE FUNCTIONS CONVERT ! 1944: # (S$CNV) OR ARRAY (S$ARR). ! 1945: # ! 1946: # +------------------------------------+ ! 1947: # I ARTYP I ! 1948: # +------------------------------------+ ! 1949: # I IDVAL I ! 1950: # +------------------------------------+ ! 1951: # I ARLEN I ! 1952: # +------------------------------------+ ! 1953: # I AROFS I ! 1954: # +------------------------------------+ ! 1955: # I ARNDM I ! 1956: # +------------------------------------+ ! 1957: # * ARLBD * ! 1958: # +------------------------------------+ ! 1959: # * ARDIM * ! 1960: # +------------------------------------+ ! 1961: # * * ! 1962: # * ABOVE 2 FLDS REPEATED FOR EACH DIM * ! 1963: # * * ! 1964: # +------------------------------------+ ! 1965: # I ARPRO I ! 1966: # +------------------------------------+ ! 1967: # / / ! 1968: # / ARVLS / ! 1969: # / / ! 1970: # +------------------------------------+ ! 1971: #page ! 1972: # ! 1973: # ARRAY BLOCK (CONTINUED) ! 1974: # ! 1975: .set artyp,0 # pointer to dummy routine b$art ! 1976: .set arlen,idval+1 # length of arblk in bytes ! 1977: .set arofs,arlen+1 # offset in arblk to arpro field ! 1978: .set arndm,arofs+1 # number of dimensions ! 1979: .set arlbd,arndm+1 # low bound (first subscript) ! 1980: .set ardim,arlbd+cfp$i# dimension (first subscript) ! 1981: .set arlb2,ardim+cfp$i# low bound (second subscript) ! 1982: .set ardm2,arlb2+cfp$i# dimension (second subscript) ! 1983: .set arpro,ardim+cfp$i# array prototype (one dimension) ! 1984: .set arvls,arpro+1 # start of values (one dimension) ! 1985: .set arpr2,ardm2+cfp$i# array prototype (two dimensions) ! 1986: .set arvl2,arpr2+1 # start of values (two dimensions) ! 1987: .set arsi$,arlbd # number of standard fields in block ! 1988: .set ardms,arlb2-arlbd# size of info for one set of bounds ! 1989: # ! 1990: # THE BOUNDS AND DIMENSION FIELDS ARE SIGNED INTEGER ! 1991: # VALUES AND EACH OCCUPY CFP$I WORDS IN THE ARBLK. ! 1992: # ! 1993: # THE LENGTH OF AN ARBLK IN BYTES MAY NOT EXCEED MXLEN. ! 1994: # THIS IS REQUIRED TO KEEP NAME OFFSETS GARBAGE COLLECTABLE ! 1995: # ! 1996: # THE ACTUAL VALUES ARE ARRANGED IN ROW-WISE ORDER AND ! 1997: # CAN CONTAIN A DATA POINTER OR A POINTER TO A TRBLK. ! 1998: # ! 1999: # BUFFER CONTROL BLOCK (BCBLK) ! 2000: # ! 2001: # A BCBLK IS BUILT FOR EVERY BFBLK. ! 2002: # ! 2003: # +------------------------------------+ ! 2004: # I BCTYP I ! 2005: # +------------------------------------+ ! 2006: # I IDVAL I ! 2007: # +------------------------------------+ ! 2008: # I BCLEN I ! 2009: # +------------------------------------+ ! 2010: # I BCBUF I ! 2011: # +------------------------------------+ ! 2012: # ! 2013: .set bctyp,0 # ptr to dummy routine b$bct ! 2014: .set bclen,idval+1 # defined buffer length ! 2015: .set bcbuf,bclen+1 # ptr to bfblk ! 2016: .set bcsi$,bcbuf+1 # size of bcblk ! 2017: # ! 2018: # A BCBLK IS AN INDIRECT CONTROL HEADER FOR BFBLK. ! 2019: # THE REASON FOR NOT STORING THIS DATA DIRECTLY ! 2020: # IN THE RELATED BFBLK IS SO THAT THE BFBLK CAN ! 2021: # MAINTAIN THE SAME SKELETAL STRUCTURE AS AN SCBLK ! 2022: # THUS FACILITATING TRANSPARENT STRING OPERATIONS ! 2023: # (FOR THE MOST PART). SPECIFICALLY, CFP$F IS THE ! 2024: # SAME FOR A BFBLK AS FOR AN SCBLK. BY CONVENTION, ! 2025: # WHEREEVER A BUFFER VALUE IS EMPLOYED, THE BCBLK ! 2026: # IS POINTED TO. ! 2027: # ! 2028: # THE CORRESPONDING BFBLK IS POINTED TO BY THE ! 2029: # BCBUF POINTER IN THE BCBLK. ! 2030: # ! 2031: # BCLEN IS THE CURRENT DEFINED SIZE OF THE CHARACTER ! 2032: # ARRAY IN THE BFBLK. CHARACTERS FOLLOWING THE OFFSET ! 2033: # OF BCLEN ARE UNDEFINED. ! 2034: # ! 2035: #page ! 2036: # ! 2037: # STRING BUFFER BLOCK (BFBLK) ! 2038: # ! 2039: # A BFBLK IS BUILT BY A CALL TO BUFFER(...) ! 2040: # ! 2041: # +------------------------------------+ ! 2042: # I BFTYP I ! 2043: # +------------------------------------+ ! 2044: # I BFALC I ! 2045: # +------------------------------------+ ! 2046: # / / ! 2047: # / BFCHR / ! 2048: # / / ! 2049: # +------------------------------------+ ! 2050: # ! 2051: .set bftyp,0 # ptr to dummy routine b$bft ! 2052: .set bfalc,bftyp+1 # allocated size of buffer ! 2053: .set bfchr,bfalc+1 # characters of string ! 2054: .set bfsi$,bfchr # size of standard fields in bfblk ! 2055: # ! 2056: # THE CHARACTERS IN THE BUFFER ARE STORED LEFT JUSTIFIED. ! 2057: # THE FINAL WORD OF DEFINED CHARACTERS IS ALWAYS ZERO ! 2058: # (CHARACTER) PADDED. ANY TRAILING ALLOCATION PAST THE ! 2059: # WORD CONTAINING THE LAST CHARACTER CONTAINS ! 2060: # UNPREDICTABLE CONTENTS AND IS NEVER REFERENCED. ! 2061: # ! 2062: # NOTE THAT THE OFFSET TO THE CHARACTERS OF THE STRING ! 2063: # IS GIVEN BY CFP$F, AS WITH AN SCBLK. HOWEVER, THE ! 2064: # OFFSET WHICH IS OCCUPIED BY THE LENGTH FOR AN SCBLK ! 2065: # IS THE TOTAL CHAR SPACE FOR BFBLKS, AND ROUTINES WHICH ! 2066: # DEAL WITH BOTH MUST ACCOUNT FOR THIS DIFFERENCE. ! 2067: # ! 2068: # THE VALUE OF BFALC MAY NOT EXCEED MXLEN. THE VALUE OF ! 2069: # BCLEN IS ALWAYS LESS THAN OR EQUAL TO BFALC. ! 2070: # ! 2071: #page ! 2072: # ! 2073: # CODE CONSTRUCTION BLOCK (CCBLK) ! 2074: # ! 2075: # AT ANY ONE MOMENT THERE IS AT MOST ONE CCBLK INTO ! 2076: # WHICH THE COMPILER IS CURRENTLY STORING CODE (CDWRD). ! 2077: # ! 2078: # +------------------------------------+ ! 2079: # I CCTYP I ! 2080: # +------------------------------------+ ! 2081: # I CCLEN I ! 2082: # +------------------------------------+ ! 2083: # I CCUSE I ! 2084: # +------------------------------------+ ! 2085: # / / ! 2086: # / CCCOD / ! 2087: # / / ! 2088: # +------------------------------------+ ! 2089: # ! 2090: .set cctyp,0 # pointer to dummy routine b$cct ! 2091: .set cclen,cctyp+1 # length of ccblk in bytes ! 2092: .set ccuse,cclen+1 # offset past last used word (bytes) ! 2093: .set cccod,ccuse+1 # start of generated code in block ! 2094: # ! 2095: # THE REASON THAT THE CCBLK IS A SEPARATE BLOCK TYPE FROM ! 2096: # THE USUAL CDBLK IS THAT THE GARBAGE COLLECTOR MUST ! 2097: # ONLY PROCESS THOSE FIELDS WHICH HAVE BEEN SET (SEE GBCPF) ! 2098: #page ! 2099: # ! 2100: # CODE BLOCK (CDBLK) ! 2101: # ! 2102: # A CODE BLOCK IS BUILT FOR EACH STATEMENT COMPILED DURING ! 2103: # THE INITIAL COMPILATION OR BY SUBSEQUENT CALLS TO CODE. ! 2104: # ! 2105: # +------------------------------------+ ! 2106: # I CDJMP I ! 2107: # +------------------------------------+ ! 2108: # I CDSTM I ! 2109: # +------------------------------------+ ! 2110: # I CDLEN I ! 2111: # +------------------------------------+ ! 2112: # I CDFAL I ! 2113: # +------------------------------------+ ! 2114: # / / ! 2115: # / CDCOD / ! 2116: # / / ! 2117: # +------------------------------------+ ! 2118: # ! 2119: .set cdjmp,0 # ptr to routine to execute statement ! 2120: .set cdstm,cdjmp+1 # statement number ! 2121: .set cdlen,offs2 # length of cdblk in bytes ! 2122: .set cdfal,offs3 # failure exit (see below) ! 2123: .set cdcod,cdfal+1 # executable pseudo-code ! 2124: .set cdsi$,cdcod # number of standard fields in cdblk ! 2125: # ! 2126: # CDSTM IS THE STATEMENT NUMBER OF THE CURRENT STATEMENT. ! 2127: # ! 2128: # CDJMP, CDFAL ARE SET AS FOLLOWS. ! 2129: # ! 2130: # 1) IF THE FAILURE EXIT IS THE NEXT STATEMENT ! 2131: # ! 2132: # CDJMP = B$CDS ! 2133: # CDFAL = PTR TO CDBLK FOR NEXT STATEMENT ! 2134: # ! 2135: # 2) IF THE FAILURE EXIT IS A SIMPLE LABEL NAME ! 2136: # ! 2137: # CDJMP = B$CDS ! 2138: # CDFAL IS A PTR TO THE VRTRA FIELD OF THE VRBLK ! 2139: # ! 2140: # 3) IF THERE IS NO FAILURE EXIT (-NOFAIL MODE) ! 2141: # ! 2142: # CDJMP = B$CDS ! 2143: # CDFAL = O$UNF ! 2144: # ! 2145: # 4) IF THE FAILURE EXIT IS COMPLEX OR DIRECT ! 2146: # ! 2147: # CDJMP = B$CDC ! 2148: # CDFAL IS THE OFFSET TO THE O$GOF WORD ! 2149: #page ! 2150: # ! 2151: # CODE BLOCK (CONTINUED) ! 2152: # ! 2153: # CDCOD IS THE START OF THE ACTUAL CODE. FIRST WE DESCRIBE ! 2154: # THE CODE GENERATED FOR AN EXPRESSION. IN AN EXPRESSION, ! 2155: # ELEMENTS ARE FETCHED BY NAME OR BY VALUE. FOR EXAMPLE, ! 2156: # THE BINARY EQUAL OPERATOR FETCHES ITS LEFT ARGUMENT ! 2157: # BY NAME AND ITS RIGHT ARGUMENT BY VALUE. THESE TWO ! 2158: # CASES GENERATE QUITE DIFFERENT CODE AND ARE DESCRIBED ! 2159: # SEPARATELY. FIRST WE CONSIDER THE CODE BY VALUE CASE. ! 2160: # ! 2161: # GENERATION OF CODE BY VALUE FOR EXPRESSIONS ELEMENTS. ! 2162: # ! 2163: # EXPRESSION POINTER TO EXBLK OR SEBLK ! 2164: # ! 2165: # INTEGER CONSTANT POINTER TO ICBLK ! 2166: # ! 2167: # NULL CONSTANT POINTER TO NULLS ! 2168: # ! 2169: # PATTERN (RESULTING FROM PREEVALUATION) ! 2170: # =O$LPT ! 2171: # POINTER TO P0BLK,P1BLK OR P2BLK ! 2172: # ! 2173: # REAL CONSTANT POINTER TO RCBLK ! 2174: # ! 2175: # STRING CONSTANT POINTER TO SCBLK ! 2176: # ! 2177: # VARIABLE POINTER TO VRGET FIELD OF VRBLK ! 2178: # ! 2179: # ADDITION VALUE CODE FOR LEFT OPERAND ! 2180: # VALUE CODE FOR RIGHT OPERAND ! 2181: # =O$ADD ! 2182: # ! 2183: # AFFIRMATION VALUE CODE FOR OPERAND ! 2184: # =O$AFF ! 2185: # ! 2186: # ALTERNATION VALUE CODE FOR LEFT OPERAND ! 2187: # VALUE CODE FOR RIGHT OPERAND ! 2188: # =O$ALT ! 2189: # ! 2190: # ARRAY REFERENCE (CASE OF ONE SUBSCRIPT) ! 2191: # VALUE CODE FOR ARRAY OPERAND ! 2192: # VALUE CODE FOR SUBSCRIPT OPERAND ! 2193: # =O$AOV ! 2194: # ! 2195: # (CASE OF MORE THAN ONE SUBSCRIPT) ! 2196: # VALUE CODE FOR ARRAY OPERAND ! 2197: # VALUE CODE FOR FIRST SUBSCRIPT ! 2198: # VALUE CODE FOR SECOND SUBSCRIPT ! 2199: # ... ! 2200: # VALUE CODE FOR LAST SUBSCRIPT ! 2201: # =O$AMV ! 2202: # NUMBER OF SUBSCRIPTS ! 2203: #page ! 2204: # ! 2205: # CODE BLOCK (CONTINUED) ! 2206: # ! 2207: # ASSIGNMENT (TO NATURAL VARIABLE) ! 2208: # VALUE CODE FOR RIGHT OPERAND ! 2209: # POINTER TO VRSTO FIELD OF VRBLK ! 2210: # ! 2211: # (TO ANY OTHER VARIABLE) ! 2212: # NAME CODE FOR LEFT OPERAND ! 2213: # VALUE CODE FOR RIGHT OPERAND ! 2214: # =O$ASS ! 2215: # ! 2216: # COMPILE ERROR =O$CER ! 2217: # ! 2218: # ! 2219: # COMPLEMENTATION VALUE CODE FOR OPERAND ! 2220: # =O$COM ! 2221: # ! 2222: # CONCATENATION (CASE OF PRED FUNC LEFT OPERAND) ! 2223: # VALUE CODE FOR LEFT OPERAND ! 2224: # =O$POP ! 2225: # VALUE CODE FOR RIGHT OPERAND ! 2226: # ! 2227: # (ALL OTHER CASES) ! 2228: # VALUE CODE FOR LEFT OPERAND ! 2229: # VALUE CODE FOR RIGHT OPERAND ! 2230: # =O$CNC ! 2231: # ! 2232: # CURSOR ASSIGNMENT NAME CODE FOR OPERAND ! 2233: # =O$CAS ! 2234: # ! 2235: # DIVISION VALUE CODE FOR LEFT OPERAND ! 2236: # VALUE CODE FOR RIGHT OPERAND ! 2237: # =O$DVD ! 2238: # ! 2239: # EXPONENTIATION VALUE CODE FOR LEFT OPERAND ! 2240: # VALUE CODE FOR RIGHT OPERAND ! 2241: # =O$EXP ! 2242: # ! 2243: # FUNCTION CALL (CASE OF CALL TO SYSTEM FUNCTION) ! 2244: # VALUE CODE FOR FIRST ARGUMENT ! 2245: # VALUE CODE FOR SECOND ARGUMENT ! 2246: # ... ! 2247: # VALUE CODE FOR LAST ARGUMENT ! 2248: # POINTER TO SVFNC FIELD OF SVBLK ! 2249: # ! 2250: #page ! 2251: # ! 2252: # CODE BLOCK (CONTINUED) ! 2253: # ! 2254: # FUNCTION CALL (CASE OF NON-SYSTEM FUNCTION 1 ARG) ! 2255: # VALUE CODE FOR ARGUMENT ! 2256: # =O$FNS ! 2257: # POINTER TO VRBLK FOR FUNCTION ! 2258: # ! 2259: # (NON-SYSTEM FUNCTION, GT 1 ARG) ! 2260: # VALUE CODE FOR FIRST ARGUMENT ! 2261: # VALUE CODE FOR SECOND ARGUMENT ! 2262: # ... ! 2263: # VALUE CODE FOR LAST ARGUMENT ! 2264: # =O$FNC ! 2265: # NUMBER OF ARGUMENTS ! 2266: # POINTER TO VRBLK FOR FUNCTION ! 2267: # ! 2268: # IMMEDIATE ASSIGNMENT VALUE CODE FOR LEFT OPERAND ! 2269: # NAME CODE FOR RIGHT OPERAND ! 2270: # =O$IMA ! 2271: # ! 2272: # INDIRECTION VALUE CODE FOR OPERAND ! 2273: # =O$INV ! 2274: # ! 2275: # INTERROGATION VALUE CODE FOR OPERAND ! 2276: # =O$INT ! 2277: # ! 2278: # KEYWORD REFERENCE NAME CODE FOR OPERAND ! 2279: # =O$KWV ! 2280: # ! 2281: # MULTIPLICATION VALUE CODE FOR LEFT OPERAND ! 2282: # VALUE CODE FOR RIGHT OPERAND ! 2283: # =O$MLT ! 2284: # ! 2285: # NAME REFERENCE (NATURAL VARIABLE CASE) ! 2286: # POINTER TO NMBLK FOR NAME ! 2287: # ! 2288: # (ALL OTHER CASES) ! 2289: # NAME CODE FOR OPERAND ! 2290: # =O$NAM ! 2291: # ! 2292: # NEGATION =O$NTA ! 2293: # CDBLK OFFSET OF O$NTC WORD ! 2294: # VALUE CODE FOR OPERAND ! 2295: # =O$NTB ! 2296: # =O$NTC ! 2297: #page ! 2298: # ! 2299: # CODE BLOCK (CONTINUED) ! 2300: # ! 2301: # PATTERN ASSIGNMENT VALUE CODE FOR LEFT OPERAND ! 2302: # NAME CODE FOR RIGHT OPERAND ! 2303: # =O$PAS ! 2304: # ! 2305: # PATTERN MATCH VALUE CODE FOR LEFT OPERAND ! 2306: # VALUE CODE FOR RIGHT OPERAND ! 2307: # =O$PMV ! 2308: # ! 2309: # PATTERN REPLACEMENT NAME CODE FOR SUBJECT ! 2310: # VALUE CODE FOR PATTERN ! 2311: # =O$PMN ! 2312: # VALUE CODE FOR REPLACEMENT ! 2313: # =O$RPL ! 2314: # ! 2315: # SELECTION (FOR FIRST ALTERNATIVE) ! 2316: # =O$SLA ! 2317: # CDBLK OFFSET TO NEXT O$SLC WORD ! 2318: # VALUE CODE FOR FIRST ALTERNATIVE ! 2319: # =O$SLB ! 2320: # CDBLK OFFSET PAST ALTERNATIVES ! 2321: # ! 2322: # (FOR SUBSEQUENT ALTERNATIVES) ! 2323: # =O$SLC ! 2324: # CDBLK OFFSET TO NEXT O$SLC,O$SLD ! 2325: # VALUE CODE FOR ALTERNATIVE ! 2326: # =O$SLB ! 2327: # OFFSET IN CDBLK PAST ALTERNATIVES ! 2328: # ! 2329: # (FOR LAST ALTERNATIVE) ! 2330: # =O$SLD ! 2331: # VALUE CODE FOR LAST ALTERNATIVE ! 2332: # ! 2333: # SUBTRACTION VALUE CODE FOR LEFT OPERAND ! 2334: # VALUE CODE FOR RIGHT OPERAND ! 2335: # =O$SUB ! 2336: #page ! 2337: # ! 2338: # CODE BLOCK (CONTINUED) ! 2339: # ! 2340: # GENERATION OF CODE BY NAME FOR EXPRESSION ELEMENTS. ! 2341: # ! 2342: # VARIABLE =O$LVN ! 2343: # POINTER TO VRBLK ! 2344: # ! 2345: # EXPRESSION (CASE OF *NATURAL VARIABLE) ! 2346: # =O$LVN ! 2347: # POINTER TO VRBLK ! 2348: # ! 2349: # (ALL OTHER CASES) ! 2350: # =O$LEX ! 2351: # POINTER TO EXBLK ! 2352: # ! 2353: # ! 2354: # ARRAY REFERENCE (CASE OF ONE SUBSCRIPT) ! 2355: # VALUE CODE FOR ARRAY OPERAND ! 2356: # VALUE CODE FOR SUBSCRIPT OPERAND ! 2357: # =O$AON ! 2358: # ! 2359: # (CASE OF MORE THAN ONE SUBSCRIPT) ! 2360: # VALUE CODE FOR ARRAY OPERAND ! 2361: # VALUE CODE FOR FIRST SUBSCRIPT ! 2362: # VALUE CODE FOR SECOND SUBSCRIPT ! 2363: # ... ! 2364: # VALUE CODE FOR LAST SUBSCRIPT ! 2365: # =O$AMN ! 2366: # NUMBER OF SUBSCRIPTS ! 2367: # ! 2368: # COMPILE ERROR =O$CER ! 2369: # ! 2370: # FUNCTION CALL (SAME CODE AS FOR VALUE CALL) ! 2371: # =O$FNE ! 2372: # ! 2373: # INDIRECTION VALUE CODE FOR OPERAND ! 2374: # =O$INN ! 2375: # ! 2376: # KEYWORD REFERENCE NAME CODE FOR OPERAND ! 2377: # =O$KWN ! 2378: # ! 2379: # ANY OTHER OPERAND IS AN ERROR IN A NAME POSITION ! 2380: # ! 2381: # NOTE THAT IN THIS DESCRIPTION, =O$XXX REFERS TO THE ! 2382: # GENERATION OF A WORD CONTAINING THE ADDRESS OF ANOTHER ! 2383: # WORD WHICH CONTAINS THE ENTRY POINT ADDRESS O$XXX. ! 2384: #page ! 2385: # ! 2386: # CODE BLOCK (CONTINUED) ! 2387: # ! 2388: # NOW WE CONSIDER THE OVERALL STRUCTURE OF THE CODE BLOCK ! 2389: # FOR A STATEMENT WITH POSSIBLE GOTO FIELDS. ! 2390: # ! 2391: # FIRST COMES THE CODE FOR THE STATEMENT BODY. ! 2392: # THE STATEMENT BODY IS AN EXPRESSION TO BE EVALUATED ! 2393: # BY VALUE ALTHOUGH THE VALUE IS NOT ACTUALLY REQUIRED. ! 2394: # NORMAL VALUE CODE IS GENERATED FOR THE BODY OF THE ! 2395: # STATEMENT EXCEPT IN THE CASE OF A PATTERN MATCH BY ! 2396: # VALUE, IN WHICH CASE THE FOLLOWING IS GENERATED. ! 2397: # ! 2398: # VALUE CODE FOR LEFT OPERAND ! 2399: # VALUE CODE FOR RIGHT OPERAND ! 2400: # =O$PMS ! 2401: # ! 2402: # NEXT WE HAVE THE CODE FOR THE SUCCESS GOTO. THERE ARE ! 2403: # SEVERAL CASES AS FOLLOWS. ! 2404: # ! 2405: # 1) NO SUCCESS GOTO PTR TO CDBLK FOR NEXT STATEMENT ! 2406: # ! 2407: # 2) SIMPLE LABEL PTR TO VRTRA FIELD OF VRBLK ! 2408: # ! 2409: # 3) COMPLEX GOTO (CODE BY NAME FOR GOTO OPERAND) ! 2410: # =O$GOC ! 2411: # ! 2412: # 4) DIRECT GOTO (CODE BY VALUE FOR GOTO OPERAND) ! 2413: # =O$GOD ! 2414: # ! 2415: # FOLLOWING THIS WE GENERATE CODE FOR THE FAILURE GOTO IF ! 2416: # IT IS DIRECT OR IF IT IS COMPLEX, SIMPLE FAILURE GOTOS ! 2417: # HAVING BEEN HANDLED BY AN APPROPRIATE SETTING OF THE ! 2418: # CDFAL FIELD OF THE CDBLK. THE GENERATED CODE IS ONE ! 2419: # OF THE FOLLOWING. ! 2420: # ! 2421: # 1) COMPLEX FGOTO =O$FIF ! 2422: # =O$GOF ! 2423: # NAME CODE FOR GOTO OPERAND ! 2424: # =O$GOC ! 2425: # ! 2426: # 2) DIRECT FGOTO =O$FIF ! 2427: # =O$GOF ! 2428: # VALUE CODE FOR GOTO OPERAND ! 2429: # =O$GOD ! 2430: # ! 2431: # AN OPTIMIZATION OCCURS IF THE SUCCESS AND FAILURE GOTOS ! 2432: # ARE IDENTICAL AND EITHER COMPLEX OR DIRECT. IN THIS CASE, ! 2433: # NO CODE IS GENERATED FOR THE SUCCESS GOTO AND CONTROL ! 2434: # IS ALLOWED TO FALL INTO THE FAILURE GOTO ON SUCCESS. ! 2435: #page ! 2436: # ! 2437: # COMPILER BLOCK (CMBLK) ! 2438: # ! 2439: # A COMPILER BLOCK (CMBLK) IS BUILT BY EXPAN TO REPRESENT ! 2440: # ONE NODE OF A TREE STRUCTURED EXPRESSION REPRESENTATION. ! 2441: # ! 2442: # +------------------------------------+ ! 2443: # I CMIDN I ! 2444: # +------------------------------------+ ! 2445: # I CMLEN I ! 2446: # +------------------------------------+ ! 2447: # I CMTYP I ! 2448: # +------------------------------------+ ! 2449: # I CMOPN I ! 2450: # +------------------------------------+ ! 2451: # / CMVLS OR CMROP / ! 2452: # / / ! 2453: # / CMLOP / ! 2454: # / / ! 2455: # +------------------------------------+ ! 2456: # ! 2457: .set cmidn,0 # pointer to dummy routine b$cmt ! 2458: .set cmlen,cmidn+1 # length of cmblk in bytes ! 2459: .set cmtyp,cmlen+1 # type (c$xxx, see list below) ! 2460: .set cmopn,cmtyp+1 # operand pointer (see below) ! 2461: .set cmvls,cmopn+1 # operand value pointers (see below) ! 2462: .set cmrop,cmvls # right (only) operator operand ! 2463: .set cmlop,cmvls+1 # left operator operand ! 2464: .set cmsi$,cmvls # number of standard fields in cmblk ! 2465: .set cmus$,cmsi$+1 # size of unary operator cmblk ! 2466: .set cmbs$,cmsi$+2 # size of binary operator cmblk ! 2467: .set cmar1,cmvls+1 # array subscript pointers ! 2468: # ! 2469: # THE CMOPN AND CMVLS FIELDS ARE SET AS FOLLOWS ! 2470: # ! 2471: # ARRAY REFERENCE CMOPN = PTR TO ARRAY OPERAND ! 2472: # CMVLS = PTRS TO SUBSCRIPT OPERANDS ! 2473: # ! 2474: # FUNCTION CALL CMOPN = PTR TO VRBLK FOR FUNCTION ! 2475: # CMVLS = PTRS TO ARGUMENT OPERANDS ! 2476: # ! 2477: # SELECTION CMOPN = ZERO ! 2478: # CMVLS = PTRS TO ALTERNATE OPERANDS ! 2479: # ! 2480: # UNARY OPERATOR CMOPN = PTR TO OPERATOR DVBLK ! 2481: # CMROP = PTR TO OPERAND ! 2482: # ! 2483: # BINARY OPERATOR CMOPN = PTR TO OPERATOR DVBLK ! 2484: # CMROP = PTR TO RIGHT OPERAND ! 2485: # CMLOP = PTR TO LEFT OPERAND ! 2486: #page ! 2487: # ! 2488: # CMTYP IS SET TO INDICATE THE TYPE OF EXPRESSION ELEMENT ! 2489: # AS SHOWN BY THE FOLLOWING TABLE OF DEFINITIONS. ! 2490: # ! 2491: .set c$arr,0 # array reference ! 2492: .set c$fnc,c$arr+1 # function call ! 2493: .set c$def,c$fnc+1 # deferred expression (unary *) ! 2494: .set c$ind,c$def+1 # indirection (unary $) ! 2495: .set c$key,c$ind+1 # keyword reference (unary ampersand) ! 2496: .set c$ubo,c$key+1 # undefined binary operator ! 2497: .set c$uuo,c$ubo+1 # undefined unary operator ! 2498: .set c$uo$,c$uuo+1 # test value (=c$uuo+1=c$ubo+2) ! 2499: .set c$$nm,c$uuo+1 # number of codes for name operands ! 2500: # ! 2501: # THE REMAINING TYPES INDICATE EXPRESSION ELEMENTS WHICH ! 2502: # CAN ONLY BE EVALUATED BY VALUE (NOT BY NAME). ! 2503: # ! 2504: .set c$bvl,c$uuo+1 # binary op with value operands ! 2505: .set c$uvl,c$bvl+1 # unary operator with value operand ! 2506: .set c$alt,c$uvl+1 # alternation (binary bar) ! 2507: .set c$cnc,c$alt+1 # concatenation ! 2508: .set c$cnp,c$cnc+1 # concatenation, not pattern match ! 2509: .set c$unm,c$cnp+1 # unary op with name operand ! 2510: .set c$bvn,c$unm+1 # binary op (operands by value, name) ! 2511: .set c$ass,c$bvn+1 # assignment ! 2512: .set c$int,c$ass+1 # interrogation ! 2513: .set c$neg,c$int+1 # negation (unary not) ! 2514: .set c$sel,c$neg+1 # selection ! 2515: .set c$pmt,c$sel+1 # pattern match ! 2516: # ! 2517: .set c$pr$,c$bvn # last preevaluable code ! 2518: .set c$$nv,c$pmt+1 # number of different cmblk types ! 2519: #page ! 2520: # ! 2521: # CHARACTER TABLE BLOCK (CTBLK) ! 2522: # ! 2523: # A CHARACTER TABLE BLOCK IS USED TO HOLD LOGICAL CHARACTER ! 2524: # TABLES FOR USE WITH ANY,NOTANY,SPAN,BREAK,BREAKX ! 2525: # PATTERNS. EACH CHARACTER TABLE CAN BE USED TO STORE ! 2526: # CFP$N DISTINCT TABLES AS BIT COLUMNS. A BIT COLUMN ! 2527: # ALLOCATED FOR EACH ARGUMENT OF MORE THAN ONE CHARACTER ! 2528: # IN LENGTH TO ONE OF THE ABOVE LISTED PATTERN PRIMITIVES. ! 2529: # ! 2530: # +------------------------------------+ ! 2531: # I CTTYP I ! 2532: # +------------------------------------+ ! 2533: # * * ! 2534: # * * ! 2535: # * CTCHS * ! 2536: # * * ! 2537: # * * ! 2538: # +------------------------------------+ ! 2539: # ! 2540: .set cttyp,0 # pointer to dummy routine b$ctt ! 2541: .set ctchs,cttyp+1 # start of character table words ! 2542: .set ctsi$,ctchs+cfp$a# number of words in ctblk ! 2543: # ! 2544: # CTCHS IS CFP$A WORDS LONG AND CONSISTS OF A ONE WORD ! 2545: # BIT STRING VALUE FOR EACH POSSIBLE CHARACTER IN THE ! 2546: # INTERNAL ALPHABET. EACH OF THE CFP$N POSSIBLE BITS IN ! 2547: # A BITSTRING IS USED TO FORM A COLUMN OF BIT INDICATORS. ! 2548: # A BIT IS SET ON IF THE CHARACTER IS IN THE TABLE AND OFF ! 2549: # IF THE CHARACTER IS NOT PRESENT. ! 2550: #page ! 2551: # ! 2552: # DATATYPE FUNCTION BLOCK (DFBLK) ! 2553: # ! 2554: # A DATATYPE FUNCTION IS USED TO CONTROL THE CONSTRUCTION ! 2555: # OF A PROGRAM DEFINED DATATYPE OBJECT. A CALL TO THE ! 2556: # SYSTEM FUNCTION DATA BUILDS A DFBLK FOR THE DATATYPE NAME ! 2557: # ! 2558: # NOTE THAT THESE BLOCKS ARE BUILT IN STATIC BECAUSE PDBLK ! 2559: # LENGTH IS GOT FROM DFLEN FIELD. IF DFBLK WAS IN DYNAMIC ! 2560: # STORE THIS WOULD CAUSE TROUBLE DURING PASS TWO OF GARBAGE ! 2561: # COLLECTION. SCBLK REFERRED TO BY DFNAM FIELD IS ALSO PUT ! 2562: # IN STATIC SO THAT THERE ARE NO RELOC. FIELDS. THIS CUTS ! 2563: # GARBAGE COLLECTION TASK APPRECIABLY FOR PDBLKS WHICH ARE ! 2564: # LIKELY TO BE PRESENT IN LARGE NUMBERS. ! 2565: # ! 2566: # +------------------------------------+ ! 2567: # I FCODE I ! 2568: # +------------------------------------+ ! 2569: # I FARGS I ! 2570: # +------------------------------------+ ! 2571: # I DFLEN I ! 2572: # +------------------------------------+ ! 2573: # I DFPDL I ! 2574: # +------------------------------------+ ! 2575: # I DFNAM I ! 2576: # +------------------------------------+ ! 2577: # / / ! 2578: # / DFFLD / ! 2579: # / / ! 2580: # +------------------------------------+ ! 2581: # ! 2582: .set dflen,fargs+1 # length of dfblk in bytes ! 2583: .set dfpdl,dflen+1 # length of corresponding pdblk ! 2584: .set dfnam,dfpdl+1 # pointer to scblk for datatype name ! 2585: .set dffld,dfnam+1 # start of vrblk ptrs for field names ! 2586: .set dfflb,dffld-1 # offset behind dffld for field func ! 2587: .set dfsi$,dffld # number of standard fields in dfblk ! 2588: # ! 2589: # THE FCODE FIELD POINTS TO THE ROUTINE B$DFC ! 2590: # ! 2591: # FARGS (THE NUMBER OF ARGUMENTS) IS THE NUMBER OF FIELDS. ! 2592: #page ! 2593: # ! 2594: # DOPE VECTOR BLOCK (DVBLK) ! 2595: # ! 2596: # A DOPE VECTOR IS ASSEMBLED FOR EACH POSSIBLE OPERATOR IN ! 2597: # THE SNOBOL4 LANGUAGE AS PART OF THE CONSTANT SECTION. ! 2598: # ! 2599: # +------------------------------------+ ! 2600: # I DVOPN I ! 2601: # +------------------------------------+ ! 2602: # I DVTYP I ! 2603: # +------------------------------------+ ! 2604: # I DVLPR I ! 2605: # +------------------------------------+ ! 2606: # I DVRPR I ! 2607: # +------------------------------------+ ! 2608: # ! 2609: .set dvopn,0 # entry address (ptr to o$xxx) ! 2610: .set dvtyp,dvopn+1 # type code (c$xxx, see cmblk) ! 2611: .set dvlpr,dvtyp+1 # left precedence (llxxx, see below) ! 2612: .set dvrpr,dvlpr+1 # right precedence (rrxxx, see below) ! 2613: .set dvus$,dvlpr+1 # size of unary operator dv ! 2614: .set dvbs$,dvrpr+1 # size of binary operator dv ! 2615: .set dvubs,dvus$+dvbs$# size of unop + binop (see scane) ! 2616: # ! 2617: # THE CONTENTS OF THE DVTYP FIELD IS COPIED INTO THE CMTYP ! 2618: # FIELD OF THE CMBLK FOR THE OPERATOR IF IT IS USED. ! 2619: # ! 2620: # THE CMOPN FIELD OF AN OPERATOR CMBLK POINTS TO THE DVBLK ! 2621: # ITSELF, PROVIDING THE REQUIRED ENTRY ADDRESS POINTER PTR. ! 2622: # ! 2623: # FOR NORMALLY UNDEFINED OPERATORS, THE DVOPN (AND CMOPN) ! 2624: # FIELDS CONTAIN A WORD OFFSET FROM R$UBA OF THE FUNCTION ! 2625: # BLOCK POINTER FOR THE OPERATOR (INSTEAD OF O$XXX PTR). ! 2626: # FOR CERTAIN SPECIAL OPERATORS, THE DVOPN FIELD IS NOT ! 2627: # REQUIRED AT ALL AND IS ASSEMBLED AS ZERO. ! 2628: # ! 2629: # THE LEFT PRECEDENCE IS USED IN COMPARING AN OPERATOR TO ! 2630: # THE LEFT OF SOME OTHER OPERATOR. IT THEREFORE GOVERNS THE ! 2631: # PRECEDENCE OF THE OPERATOR TOWARDS ITS RIGHT OPERAND. ! 2632: # ! 2633: # THE RIGHT PRECEDENCE IS USED IN COMPARING AN OPERATOR TO ! 2634: # THE RIGHT OF SOME OTHER OPERATOR. IT THEREFORE GOVERNS ! 2635: # THE PRECEDENCE OF THE OPERATOR TOWARDS ITS LEFT OPERAND. ! 2636: # ! 2637: # HIGHER PRECEDENCE VALUES CORRESPOND TO A TIGHTER BINDING ! 2638: # CAPABILITY. THUS WE HAVE THE LEFT PRECEDENCE LOWER ! 2639: # (HIGHER) THAN THE RIGHT PRECEDENCE FOR RIGHT (LEFT) ! 2640: # ASSOCIATIVE BINARY OPERATORS. ! 2641: # ! 2642: # THE LEFT PRECEDENCE OF UNARY OPERATORS IS SET TO AN ! 2643: # ARBITRARY HIGH VALUE. THE RIGHT VALUE IS NOT REQUIRED AND ! 2644: # CONSEQUENTLY THE DVRPR FIELD IS OMITTED FOR UNARY OPS. ! 2645: #page ! 2646: # ! 2647: # TABLE OF OPERATOR PRECEDENCE VALUES ! 2648: # ! 2649: .set rrass,10 # right equal ! 2650: .set llass,00 # left equal ! 2651: .set rrpmt,20 # right question mark ! 2652: .set llpmt,30 # left question mark ! 2653: .set rramp,40 # right ampersand ! 2654: .set llamp,50 # left ampersand ! 2655: .set rralt,70 # right vertical bar ! 2656: .set llalt,60 # left vertical bar ! 2657: .set rrcnc,90 # right blank ! 2658: .set llcnc,80 # left blank ! 2659: .set rrats,110 # right at ! 2660: .set llats,100 # left at ! 2661: .set rrplm,120 # right plus, minus ! 2662: .set llplm,130 # left plus, minus ! 2663: .set rrnum,140 # right number ! 2664: .set llnum,150 # left number ! 2665: .set rrdvd,160 # right slash ! 2666: .set lldvd,170 # left slash ! 2667: .set rrmlt,180 # right asterisk ! 2668: .set llmlt,190 # left asterisk ! 2669: .set rrpct,200 # right percent ! 2670: .set llpct,210 # left percent ! 2671: .set rrexp,230 # right exclamation ! 2672: .set llexp,220 # left exclamation ! 2673: .set rrdld,240 # right dollar, dot ! 2674: .set lldld,250 # left dollar, dot ! 2675: .set rrnot,270 # right not ! 2676: .set llnot,260 # left not ! 2677: .set lluno,999 # left all unary operators ! 2678: # ! 2679: # PRECEDENCES ARE THE SAME AS IN BTL SNOBOL4 WITH THE ! 2680: # FOLLOWING EXCEPTIONS. ! 2681: # ! 2682: # 1) BINARY QUESTION MARK IS LOWERED AND MADE LEFT ASSOC- ! 2683: # IATIVE TO REFLECT ITS NEW USE FOR PATTERN MATCHING. ! 2684: # ! 2685: # 2) ALTERNATION AND CONCATENATION ARE MADE RIGHT ! 2686: # ASSOCIATIVE FOR GREATER EFFICIENCY IN PATTERN ! 2687: # CONSTRUCTION AND MATCHING RESPECTIVELY. THIS CHANGE ! 2688: # IS TRANSPARENT TO THE SNOBOL4 PROGRAMMER. ! 2689: # ! 2690: # 3) THE EQUAL SIGN HAS BEEN ADDED AS A LOW PRECEDENCE ! 2691: # OPERATOR WHICH IS RIGHT ASSOCIATIVE TO REFLECT ITS ! 2692: # MORE GENERAL USAGE IN THIS VERSION OF SNOBOL4. ! 2693: #page ! 2694: # ! 2695: # EXTERNAL FUNCTION BLOCK (EFBLK) ! 2696: # ! 2697: # AN EXTERNAL FUNCTION BLOCK IS USED TO CONTROL THE CALLING ! 2698: # OF AN EXTERNAL FUNCTION. IT IS BUILT BY A CALL TO LOAD. ! 2699: # ! 2700: # +------------------------------------+ ! 2701: # I FCODE I ! 2702: # +------------------------------------+ ! 2703: # I FARGS I ! 2704: # +------------------------------------+ ! 2705: # I EFLEN I ! 2706: # +------------------------------------+ ! 2707: # I EFUSE I ! 2708: # +------------------------------------+ ! 2709: # I EFCOD I ! 2710: # +------------------------------------+ ! 2711: # I EFVAR I ! 2712: # +------------------------------------+ ! 2713: # I EFRSL I ! 2714: # +------------------------------------+ ! 2715: # / / ! 2716: # / EFTAR / ! 2717: # / / ! 2718: # +------------------------------------+ ! 2719: # ! 2720: .set eflen,fargs+1 # length of efblk in bytes ! 2721: .set efuse,eflen+1 # use count (for opsyn) ! 2722: .set efcod,efuse+1 # ptr to code (from sysld) ! 2723: .set efvar,efcod+1 # ptr to associated vrblk ! 2724: .set efrsl,efvar+1 # result type (see below) ! 2725: .set eftar,efrsl+1 # argument types (see below) ! 2726: .set efsi$,eftar # number of standard fields in efblk ! 2727: # ! 2728: # THE FCODE FIELD POINTS TO THE ROUTINE B$EFC. ! 2729: # ! 2730: # EFUSE IS USED TO KEEP TRACK OF MULTIPLE USE WHEN OPSYN ! 2731: # IS EMPLOYED. THE FUNCTION IS AUTOMATICALLY UNLOADED ! 2732: # WHEN THERE ARE NO MORE REFERENCES TO THE FUNCTION. ! 2733: # ! 2734: # EFRSL AND EFTAR ARE TYPE CODES AS FOLLOWS. ! 2735: # ! 2736: # 0 TYPE IS UNCONVERTED ! 2737: # 1 TYPE IS STRING ! 2738: # 2 TYPE IS INTEGER ! 2739: # 3 TYPE IS REAL ! 2740: #page ! 2741: # ! 2742: # EXPRESSION VARIABLE BLOCK (EVBLK) ! 2743: # ! 2744: # IN THIS VERSION OF SPITBOL, AN EXPRESSION CAN BE USED IN ! 2745: # ANY POSITION WHICH WOULD NORMALLY EXPECT A NAME (FOR ! 2746: # EXAMPLE ON THE LEFT SIDE OF EQUALS OR AS THE RIGHT ! 2747: # ARGUMENT OF BINARY DOT). THIS CORRESPONDS TO THE CREATION ! 2748: # OF A PSEUDO-VARIABLE WHICH IS REPRESENTED BY A POINTER TO ! 2749: # AN EXPRESSION VARIABLE BLOCK AS FOLLOWS. ! 2750: # ! 2751: # +------------------------------------+ ! 2752: # I EVTYP I ! 2753: # +------------------------------------+ ! 2754: # I EVEXP I ! 2755: # +------------------------------------+ ! 2756: # I EVVAR I ! 2757: # +------------------------------------+ ! 2758: # ! 2759: .set evtyp,0 # pointer to dummy routine b$evt ! 2760: .set evexp,evtyp+1 # pointer to exblk for expression ! 2761: .set evvar,evexp+1 # pointer to trbev dummy trblk ! 2762: .set evsi$,evvar+1 # size of evblk ! 2763: # ! 2764: # THE NAME OF AN EXPRESSION VARIABLE IS REPRESENTED BY A ! 2765: # BASE POINTER TO THE EVBLK AND AN OFFSET OF EVVAR. THIS ! 2766: # VALUE APPEARS TO BE TRAPPED BY THE DUMMY TRBEV BLOCK. ! 2767: # ! 2768: # NOTE THAT THERE IS NO NEED TO ALLOW FOR THE CASE OF AN ! 2769: # EXPRESSION VARIABLE WHICH REFERENCES AN SEBLK SINCE A ! 2770: # VARIABLE WHICH IS OF THE FORM *VAR IS EQUIVALENT TO VAR. ! 2771: #page ! 2772: # ! 2773: # EXPRESSION BLOCK (EXBLK) ! 2774: # ! 2775: # AN EXPRESSION BLOCK IS BUILT FOR EACH EXPRESSION ! 2776: # REFERENCED IN A PROGRAM OR CREATED BY EVAL OR CONVERT ! 2777: # DURING EXECUTION OF A PROGRAM. ! 2778: # ! 2779: # +------------------------------------+ ! 2780: # I EXTYP I ! 2781: # +------------------------------------+ ! 2782: # I EXSTM I ! 2783: # +------------------------------------+ ! 2784: # I EXLEN I ! 2785: # +------------------------------------+ ! 2786: # I EXFLC I ! 2787: # +------------------------------------+ ! 2788: # / / ! 2789: # / EXCOD / ! 2790: # / / ! 2791: # +------------------------------------+ ! 2792: # ! 2793: .set extyp,0 # ptr to routine b$exl to load expr ! 2794: .set exstm,cdstm # stores stmnt no. during evaluation ! 2795: .set exlen,exstm+1 # length of exblk in bytes ! 2796: .set exflc,exlen+1 # failure code (=o$fex) ! 2797: .set excod,exflc+1 # pseudo-code for expression ! 2798: .set exsi$,excod # number of standard fields in exblk ! 2799: # ! 2800: # THERE ARE TWO CASES FOR EXCOD DEPENDING ON WHETHER THE ! 2801: # EXPRESSION CAN BE EVALUATED BY NAME (SEE DESCRIPTION ! 2802: # OF CDBLK FOR DETAILS OF CODE FOR EXPRESSIONS). ! 2803: # ! 2804: # IF THE EXPRESSION CAN BE EVALUATED BY NAME WE HAVE. ! 2805: # ! 2806: # (CODE FOR EXPR BY NAME) ! 2807: # =O$RNM ! 2808: # ! 2809: # IF THE EXPRESSION CAN ONLY BE EVALUATED BY VALUE. ! 2810: # ! 2811: # (CODE FOR EXPR BY VALUE) ! 2812: # =O$RVL ! 2813: #page ! 2814: # ! 2815: # FIELD FUNCTION BLOCK (FFBLK) ! 2816: # ! 2817: # A FIELD FUNCTION BLOCK IS USED TO CONTROL THE SELECTION ! 2818: # OF A FIELD FROM A PROGRAM DEFINED DATATYPE BLOCK. ! 2819: # A CALL TO DATA CREATES AN FFBLK FOR EACH FIELD. ! 2820: # ! 2821: # +------------------------------------+ ! 2822: # I FCODE I ! 2823: # +------------------------------------+ ! 2824: # I FARGS I ! 2825: # +------------------------------------+ ! 2826: # I FFDFP I ! 2827: # +------------------------------------+ ! 2828: # I FFNXT I ! 2829: # +------------------------------------+ ! 2830: # I FFOFS I ! 2831: # +------------------------------------+ ! 2832: # ! 2833: .set ffdfp,fargs+1 # pointer to associated dfblk ! 2834: .set ffnxt,ffdfp+1 # ptr to next ffblk on chain or zero ! 2835: .set ffofs,ffnxt+1 # offset (bytes) to field in pdblk ! 2836: .set ffsi$,ffofs+1 # size of ffblk in words ! 2837: # ! 2838: # THE FCODE FIELD POINTS TO THE ROUTINE B$FFC. ! 2839: # ! 2840: # FARGS ALWAYS CONTAINS ONE. ! 2841: # ! 2842: # FFDFP IS USED TO VERIFY THAT THE CORRECT PROGRAM DEFINED ! 2843: # DATATYPE IS BEING ACCESSED BY THIS CALL. ! 2844: # FFDFP IS NON-RELOC. BECAUSE DFBLK IS IN STATIC ! 2845: # ! 2846: # FFOFS IS USED TO SELECT THE APPROPRIATE FIELD. NOTE THAT ! 2847: # IT IS AN ACTUAL OFFSET (NOT A FIELD NUMBER) ! 2848: # ! 2849: # FFNXT IS USED TO POINT TO THE NEXT FFBLK OF THE SAME NAME ! 2850: # IN THE CASE WHERE THERE ARE SEVERAL FIELDS OF THE SAME ! 2851: # NAME FOR DIFFERENT DATATYPES. ZERO MARKS THE END OF CHAIN ! 2852: #page ! 2853: # ! 2854: # INTEGER CONSTANT BLOCK (ICBLK) ! 2855: # ! 2856: # AN ICBLK IS CREATED FOR EVERY INTEGER REFERENCED OR ! 2857: # CREATED BY A PROGRAM. NOTE HOWEVER THAT CERTAIN INTERNAL ! 2858: # INTEGER VALUES ARE STORED AS ADDRESSES (E.G. THE LENGTH ! 2859: # FIELD IN A STRING CONSTANT BLOCK) ! 2860: # ! 2861: # +------------------------------------+ ! 2862: # I ICGET I ! 2863: # +------------------------------------+ ! 2864: # * ICVAL * ! 2865: # +------------------------------------+ ! 2866: # ! 2867: .set icget,0 # ptr to routine b$icl to load int ! 2868: .set icval,icget+1 # integer value ! 2869: .set icsi$,icval+cfp$i# size of icblk ! 2870: # ! 2871: # THE LENGTH OF THE ICVAL FIELD IS CFP$I. ! 2872: #page ! 2873: # ! 2874: # KEYWORD VARIABLE BLOCK (KVBLK) ! 2875: # ! 2876: # A KVBLK IS USED TO REPRESENT A KEYWORD PSEUDO-VARIABLE. ! 2877: # A KVBLK IS BUILT FOR EACH KEYWORD REFERENCE (KWNAM). ! 2878: # ! 2879: # +------------------------------------+ ! 2880: # I KVTYP I ! 2881: # +------------------------------------+ ! 2882: # I KVVAR I ! 2883: # +------------------------------------+ ! 2884: # I KVNUM I ! 2885: # +------------------------------------+ ! 2886: # ! 2887: .set kvtyp,0 # pointer to dummy routine b$kvt ! 2888: .set kvvar,kvtyp+1 # pointer to dummy block trbkv ! 2889: .set kvnum,kvvar+1 # keyword number ! 2890: .set kvsi$,kvnum+1 # size of kvblk ! 2891: # ! 2892: # THE NAME OF A KEYWORD VARIABLE IS REPRESENTED BY A ! 2893: # BASE POINTER TO THE KVBLK AND AN OFFSET OF KVVAR. THE ! 2894: # VALUE APPEARS TO BE TRAPPED BY THE POINTER TO TRBKV. ! 2895: #page ! 2896: # ! 2897: # NAME BLOCK (NMBLK) ! 2898: # ! 2899: # A NAME BLOCK IS USED WHEREVER A NAME MUST BE STORED AS ! 2900: # A VALUE FOLLOWING USE OF THE UNARY DOT OPERATOR. ! 2901: # ! 2902: # +------------------------------------+ ! 2903: # I NMTYP I ! 2904: # +------------------------------------+ ! 2905: # I NMBAS I ! 2906: # +------------------------------------+ ! 2907: # I NMOFS I ! 2908: # +------------------------------------+ ! 2909: # ! 2910: .set nmtyp,0 # ptr to routine b$nml to load name ! 2911: .set nmbas,nmtyp+1 # base pointer for variable ! 2912: .set nmofs,nmbas+1 # offset for variable ! 2913: .set nmsi$,nmofs+1 # size of nmblk ! 2914: # ! 2915: # THE ACTUAL FIELD REPRESENTING THE CONTENTS OF THE NAME ! 2916: # IS FOUND NMOFS BYTES PAST THE ADDRESS IN NMBAS. ! 2917: # ! 2918: # THE NAME IS SPLIT INTO BASE AND OFFSET FORM TO AVOID ! 2919: # CREATION OF A POINTER INTO THE MIDDLE OF A BLOCK WHICH ! 2920: # COULD NOT BE HANDLED PROPERLY BY THE GARBAGE COLLECTOR. ! 2921: # ! 2922: # A NAME MAY BE BUILT FOR ANY VARIABLE (SEE SECTION ON ! 2923: # REPRESENTATIONS OF VARIABLES) THIS INCLUDES THE ! 2924: # CASES OF PSEUDO-VARIABLES. ! 2925: #page ! 2926: # ! 2927: # PATTERN BLOCK, NO PARAMETERS (P0BLK) ! 2928: # ! 2929: # A P0BLK IS USED TO REPRESENT PATTERN NODES WHICH DO ! 2930: # NOT REQUIRE THE USE OF ANY PARAMETER VALUES. ! 2931: # ! 2932: # +------------------------------------+ ! 2933: # I PCODE I ! 2934: # +------------------------------------+ ! 2935: # I PTHEN I ! 2936: # +------------------------------------+ ! 2937: # ! 2938: .set pcode,0 # ptr to match routine (p$xxx) ! 2939: .set pthen,pcode+1 # pointer to subsequent node ! 2940: .set pasi$,pthen+1 # size of p0blk ! 2941: # ! 2942: # PTHEN POINTS TO THE PATTERN BLOCK FOR THE SUBSEQUENT ! 2943: # NODE TO BE MATCHED. THIS IS A POINTER TO THE PATTERN ! 2944: # BLOCK NDNTH IF THERE IS NO SUBSEQUENT (END OF PATTERN) ! 2945: # ! 2946: # PCODE IS A POINTER TO THE MATCH ROUTINE FOR THE NODE. ! 2947: #page ! 2948: # ! 2949: # PATTERN BLOCK (ONE PARAMETER) ! 2950: # ! 2951: # A P1BLK IS USED TO REPRESENT PATTERN NODES WHICH ! 2952: # REQUIRE ONE PARAMETER VALUE. ! 2953: # ! 2954: # +------------------------------------+ ! 2955: # I PCODE I ! 2956: # +------------------------------------+ ! 2957: # I PTHEN I ! 2958: # +------------------------------------+ ! 2959: # I PARM1 I ! 2960: # +------------------------------------+ ! 2961: # ! 2962: .set parm1,pthen+1 # first parameter value ! 2963: .set pbsi$,parm1+1 # size of p1blk in words ! 2964: # ! 2965: # SEE P0BLK FOR DEFINITIONS OF PCODE, PTHEN ! 2966: # ! 2967: # PARM1 CONTAINS A PARAMETER VALUE USED IN MATCHING THE ! 2968: # NODE. FOR EXAMPLE, IN A LEN PATTERN, IT IS THE INTEGER ! 2969: # ARGUMENT TO LEN. THE DETAILS OF THE USE OF THE PARAMETER ! 2970: # FIELD ARE INCLUDED IN THE DESCRIPTION OF THE INDIVIDUAL ! 2971: # MATCH ROUTINES. PARM1 IS ALWAYS AN ADDRESS POINTER WHICH ! 2972: # IS PROCESSED BY THE GARBAGE COLLECTOR. ! 2973: #page ! 2974: # ! 2975: # PATTERN BLOCK (TWO PARAMETERS) ! 2976: # ! 2977: # A P2BLK IS USED TO REPRESENT PATTERN NODES WHICH ! 2978: # REQUIRE TWO PARAMETER VALUES. ! 2979: # ! 2980: # +------------------------------------+ ! 2981: # I PCODE I ! 2982: # +------------------------------------+ ! 2983: # I PTHEN I ! 2984: # +------------------------------------+ ! 2985: # I PARM1 I ! 2986: # +------------------------------------+ ! 2987: # I PARM2 I ! 2988: # +------------------------------------+ ! 2989: # ! 2990: .set parm2,parm1+1 # second parameter value ! 2991: .set pcsi$,parm2+1 # size of p2blk in words ! 2992: # ! 2993: # SEE P1BLK FOR DEFINITIONS OF PCODE, PTHEN, PARM1 ! 2994: # ! 2995: # PARM2 IS A PARAMETER WHICH PERFORMS THE SAME SORT OF ! 2996: # FUNCTION AS PARM1 (SEE DESCRIPTION OF P1BLK). ! 2997: # ! 2998: # PARM2 IS A NON-RELOCATABLE FIELD AND IS NOT ! 2999: # PROCESSED BY THE GARBAGE COLLECTOR. ACCORDINGLY, IT MAY ! 3000: # NOT CONTAIN A POINTER TO A BLOCK IN DYNAMIC MEMORY. ! 3001: #page ! 3002: # ! 3003: # PROGRAM-DEFINED DATATYPE BLOCK ! 3004: # ! 3005: # A PDBLK REPRESENTS THE DATA ITEM FORMED BY A CALL TO A ! 3006: # DATATYPE FUNCTION AS DEFINED BY THE SYSTEM FUNCTION DATA. ! 3007: # ! 3008: # +------------------------------------+ ! 3009: # I PDTYP I ! 3010: # +------------------------------------+ ! 3011: # I IDVAL I ! 3012: # +------------------------------------+ ! 3013: # I PDDFP I ! 3014: # +------------------------------------+ ! 3015: # / / ! 3016: # / PDFLD / ! 3017: # / / ! 3018: # +------------------------------------+ ! 3019: # ! 3020: .set pdtyp,0 # ptr to dummy routine b$pdt ! 3021: .set pddfp,idval+1 # ptr to associated dfblk ! 3022: .set pdfld,pddfp+1 # start of field value pointers ! 3023: .set pdfof,dffld-pdfld# difference in offset to field ptrs ! 3024: .set pdsi$,pdfld # size of standard fields in pdblk ! 3025: .set pddfs,dfsi$-pdsi$# difference in dfblk, pdblk sizes ! 3026: # ! 3027: # THE PDDFP POINTER MAY BE USED TO DETERMINE THE DATATYPE ! 3028: # AND THE NAMES OF THE FIELDS IF REQUIRED. THE DFBLK ALSO ! 3029: # CONTAINS THE LENGTH OF THE PDBLK IN BYTES (FIELD DFPDL). ! 3030: # PDDFP IS NON-RELOC. BECAUSE DFBLK IS IN STATIC ! 3031: # ! 3032: # PDFLD VALUES ARE STORED IN ORDER FROM LEFT TO RIGHT. ! 3033: # THEY CONTAIN VALUES OR POINTERS TO TRBLK CHAINS. ! 3034: #page ! 3035: # ! 3036: # PROGRAM DEFINED FUNCTION BLOCK (PFBLK) ! 3037: # ! 3038: # A PFBLK IS CREATED FOR EACH CALL TO THE DEFINE FUNCTION ! 3039: # AND A POINTER TO THE PFBLK PLACED IN THE PROPER VRBLK. ! 3040: # ! 3041: # +------------------------------------+ ! 3042: # I FCODE I ! 3043: # +------------------------------------+ ! 3044: # I FARGS I ! 3045: # +------------------------------------+ ! 3046: # I PFLEN I ! 3047: # +------------------------------------+ ! 3048: # I PFVBL I ! 3049: # +------------------------------------+ ! 3050: # I PFNLO I ! 3051: # +------------------------------------+ ! 3052: # I PFCOD I ! 3053: # +------------------------------------+ ! 3054: # I PFCTR I ! 3055: # +------------------------------------+ ! 3056: # I PFRTR I ! 3057: # +------------------------------------+ ! 3058: # / / ! 3059: # / PFARG / ! 3060: # / / ! 3061: # +------------------------------------+ ! 3062: # ! 3063: .set pflen,fargs+1 # length of pfblk in bytes ! 3064: .set pfvbl,pflen+1 # pointer to vrblk for function name ! 3065: .set pfnlo,pfvbl+1 # number of locals ! 3066: .set pfcod,pfnlo+1 # ptr to cdblk for first statement ! 3067: .set pfctr,pfcod+1 # trblk ptr if call traced else 0 ! 3068: .set pfrtr,pfctr+1 # trblk ptr if return traced else 0 ! 3069: .set pfarg,pfrtr+1 # vrblk ptrs for arguments and locals ! 3070: .set pfagb,pfarg-1 # offset behind pfarg for arg, local ! 3071: .set pfsi$,pfarg # number of standard fields in pfblk ! 3072: # ! 3073: # THE FCODE FIELD POINTS TO THE ROUTINE B$PFC. ! 3074: # ! 3075: # PFARG IS STORED IN THE FOLLOWING ORDER. ! 3076: # ! 3077: # ARGUMENTS (LEFT TO RIGHT) ! 3078: # LOCALS (LEFT TO RIGHT) ! 3079: #page ! 3080: # ! 3081: # REAL CONSTANT BLOCK (RCBLK) ! 3082: # ! 3083: # AN RCBLK IS CREATED FOR EVERY REAL REFERENCED OR ! 3084: # CREATED BY A PROGRAM. ! 3085: # ! 3086: # +------------------------------------+ ! 3087: # I RCGET I ! 3088: # +------------------------------------+ ! 3089: # * RCVAL * ! 3090: # +------------------------------------+ ! 3091: # ! 3092: .set rcget,0 # ptr to routine b$rcl to load real ! 3093: .set rcval,rcget+1 # real value ! 3094: .set rcsi$,rcval+cfp$r# size of rcblk ! 3095: # ! 3096: # THE LENGTH OF THE RCVAL FIELD IS CFP$R. ! 3097: #page ! 3098: # ! 3099: # STRING CONSTANT BLOCK (SCBLK) ! 3100: # ! 3101: # AN SCBLK IS BUILT FOR EVERY STRING REFERENCED OR CREATED ! 3102: # BY A PROGRAM. ! 3103: # ! 3104: # +------------------------------------+ ! 3105: # I SCGET I ! 3106: # +------------------------------------+ ! 3107: # I SCLEN I ! 3108: # +------------------------------------+ ! 3109: # / / ! 3110: # / SCHAR / ! 3111: # / / ! 3112: # +------------------------------------+ ! 3113: # ! 3114: .set scget,0 # ptr to routine b$scl to load string ! 3115: .set sclen,scget+1 # length of string in characters ! 3116: .set schar,sclen+1 # characters of string ! 3117: .set scsi$,schar # size of standard fields in scblk ! 3118: # ! 3119: # THE CHARACTERS OF THE STRING ARE STORED LEFT JUSTIFIED. ! 3120: # THE FINAL WORD IS PADDED ON THE RIGHT WITH ZEROS. ! 3121: # (I.E. THE CHARACTER WHOSE INTERNAL CODE IS ZERO). ! 3122: # ! 3123: # THE VALUE OF SCLEN MAY NOT EXCEED MXLEN. THIS ENSURES ! 3124: # THAT CHARACTER OFFSETS (E.G. THE PATTERN MATCH CURSOR) ! 3125: # CAN BE CORRECTLY PROCESSED BY THE GARBAGE COLLECTOR. ! 3126: # ! 3127: # NOTE THAT THE OFFSET TO THE CHARACTERS OF THE STRING ! 3128: # IS GIVEN IN BYTES BY CFP$F AND THAT THIS VALUE IS ! 3129: # AUTOMATICALLY ALLOWED FOR IN PLC, PSC. ! 3130: # NOTE THAT FOR A SPITBOL SCBLK, THE VALUE OF CFP$F ! 3131: # IS GIVEN BY CFP$B*SCHAR. ! 3132: #page ! 3133: # ! 3134: # SIMPLE EXPRESSION BLOCK (SEBLK) ! 3135: # ! 3136: # AN SEBLK IS USED TO REPRESENT AN EXPRESSION OF THE FORM ! 3137: # *(NATURAL VARIABLE). ALL OTHER EXPRESSIONS ARE EXBLKS. ! 3138: # ! 3139: # +------------------------------------+ ! 3140: # I SETYP I ! 3141: # +------------------------------------+ ! 3142: # I SEVAR I ! 3143: # +------------------------------------+ ! 3144: # ! 3145: .set setyp,0 # ptr to routine b$sel to load expr ! 3146: .set sevar,setyp+1 # ptr to vrblk for variable ! 3147: .set sesi$,sevar+1 # length of seblk in words ! 3148: #page ! 3149: # ! 3150: # STANDARD VARIABLE BLOCK (SVBLK) ! 3151: # ! 3152: # AN SVBLK IS ASSEMBLED IN THE CONSTANT SECTION FOR EACH ! 3153: # VARIABLE WHICH SATISFIES ONE OF THE FOLLOWING CONDITIONS. ! 3154: # ! 3155: # 1) IT IS THE NAME OF A SYSTEM FUNCTION ! 3156: # 2) IT HAS AN INITIAL VALUE ! 3157: # 3) IT HAS A KEYWORD ASSOCIATION ! 3158: # 4) IT HAS A STANDARD I/O ASSOCIATION ! 3159: # 6) IT HAS A STANDARD LABEL ASSOCIATION ! 3160: # ! 3161: # IF VRBLKS ARE CONSTRUCTED FOR ANY OF THESE VARIABLES, ! 3162: # THEN THE VRSVP FIELD POINTS TO THE SVBLK (SEE VRBLK) ! 3163: # ! 3164: # +------------------------------------+ ! 3165: # I SVBIT I ! 3166: # +------------------------------------+ ! 3167: # I SVLEN I ! 3168: # +------------------------------------+ ! 3169: # I SVCHS I ! 3170: # +------------------------------------+ ! 3171: # I SVKNM I ! 3172: # +------------------------------------+ ! 3173: # I SVFNC I ! 3174: # +------------------------------------+ ! 3175: # I SVNAR I ! 3176: # +------------------------------------+ ! 3177: # I SVLBL I ! 3178: # +------------------------------------+ ! 3179: # I SVVAL I ! 3180: # +------------------------------------+ ! 3181: #page ! 3182: # ! 3183: # STANDARD VARIABLE BLOCK (CONTINUED) ! 3184: # ! 3185: .set svbit,0 # bit string indicating attributes ! 3186: .set svlen,1 # (=sclen) length of name in chars ! 3187: .set svchs,2 # (=schar) characters of name ! 3188: .set svsi$,2 # number of standard fields in svblk ! 3189: .set svpre,1 # set if preevaluation permitted ! 3190: .set svffc,svpre+svpre# set on if fast call permitted ! 3191: .set svckw,svffc+svffc# set on if keyword value constant ! 3192: .set svprd,svckw+svckw# set on if predicate function ! 3193: .set svnbt,4 # number of bits to right of svknm ! 3194: .set svknm,svprd+svprd# set on if keyword association ! 3195: .set svfnc,svknm+svknm# set on if system function ! 3196: .set svnar,svfnc+svfnc# set on if system function ! 3197: .set svlbl,svnar+svnar# set on if system label ! 3198: .set svval,svlbl+svlbl# set on if predefined value ! 3199: # ! 3200: # NOTE THAT THE LAST FIVE BITS CORRESPOND IN ORDER ! 3201: # TO THE FIELDS WHICH ARE PRESENT (SEE PROCEDURE GTNVR). ! 3202: # ! 3203: # THE FOLLOWING DEFINITIONS ARE USED IN THE SVBLK TABLE ! 3204: # ! 3205: .set svfnf,svfnc+svnar# function with no fast call ! 3206: .set svfnn,svfnf+svffc# function with fast call, no preeval ! 3207: .set svfnp,svfnn+svpre# function allowing preevaluation ! 3208: .set svfpr,svfnn+svprd# predicate function ! 3209: .set svfnk,svfnn+svknm# no preeval func + keyword ! 3210: .set svkwv,svknm+svval# keyword + value ! 3211: .set svkwc,svckw+svknm# keyword with constant value ! 3212: .set svkvc,svkwv+svckw# constant keyword + value ! 3213: .set svkvl,svkvc+svlbl# constant keyword + value + label ! 3214: .set svfpk,svfnp+svkvc# preeval fcn + const keywd + val ! 3215: # ! 3216: # THE SVPRE BIT ALLOWS THE COMPILER TO PREEVALUATE A CALL ! 3217: # TO THE ASSOCIATED SYSTEM FUNCTION IF ALL THE ARGUMENTS ! 3218: # ARE THEMSELVES CONSTANTS. FUNCTIONS IN THIS CATEGORY ! 3219: # MUST HAVE NO SIDE EFFECTS AND MUST NEVER CAUSE FAILURE. ! 3220: # THE CALL MAY GENERATE AN ERROR CONDITION. ! 3221: # ! 3222: # THE SVFFC BIT ALLOWS THE COMPILER TO GENERATE THE SPECIAL ! 3223: # FAST CALL AFTER ADJUSTING THE NUMBER OF ARGUMENTS. ONLY ! 3224: # THE ITEM AND APPLY FUNCTIONS FALL OUTSIDE THIS CATEGORY. ! 3225: # ! 3226: # THE SVCKW BIT IS SET IF THE ASSOCIATED KEYWORD VALUE IS ! 3227: # A CONSTANT, THUS ALLOWING PREEVALUATION FOR A VALUE CALL. ! 3228: # ! 3229: # THE SVPRD BIT IS SET ON FOR ALL PREDICATE FUNCTIONS TO ! 3230: # ENABLE THE SPECIAL CONCATENATION CODE OPTIMIZATION. ! 3231: #page ! 3232: # ! 3233: # SVBLK (CONTINUED) ! 3234: # ! 3235: # SVKNM KEYWORD NUMBER ! 3236: # ! 3237: # SVKNM IS PRESENT ONLY FOR A STANDARD KEYWORD ASSOC. ! 3238: # IT CONTAINS A KEYWORD NUMBER AS DEFINED BY THE ! 3239: # KEYWORD NUMBER TABLE GIVEN LATER ON. ! 3240: # ! 3241: # SVFNC SYSTEM FUNCTION POINTER ! 3242: # ! 3243: # SVFNC IS PRESENT ONLY FOR A SYSTEM FUNCTION ASSOC. ! 3244: # IT IS A POINTER TO THE ACTUAL CODE FOR THE SYSTEM ! 3245: # FUNCTION. THE GENERATED CODE FOR A FAST CALL IS A ! 3246: # POINTER TO THE SVFNC FIELD OF THE SVBLK FOR THE ! 3247: # FUNCTION. THE VRFNC FIELD OF THE VRBLK POINTS TO ! 3248: # THIS SAME FIELD, IN WHICH CASE, IT SERVES AS THE ! 3249: # FCODE FIELD FOR THE FUNCTION CALL. ! 3250: # ! 3251: # SVNAR NUMBER OF FUNCTION ARGUMENTS ! 3252: # ! 3253: # SVNAR IS PRESENT ONLY FOR A SYSTEM FUNCTION ASSOC. ! 3254: # IT IS THE NUMBER OF ARGUMENTS REQUIRED FOR A CALL ! 3255: # TO THE SYSTEM FUNCTION. THE COMPILER USES THIS ! 3256: # VALUE TO ADJUST THE NUMBER OF ARGUMENTS IN A FAST ! 3257: # CALL AND IN THE CASE OF A FUNCTION CALLED THROUGH ! 3258: # THE VRFNC FIELD OF THE VRBLK, THE SVNAR FIELD ! 3259: # SERVES AS THE FARGS FIELD FOR O$FNC. A SPECIAL ! 3260: # CASE OCCURS IF THIS VALUE IS SET TO 999. THIS IS ! 3261: # USED TO INDICATE THAT THE FUNCTION HAS A VARIABLE ! 3262: # NUMBER OF ARGUMENTS AND CAUSES O$FNC TO PASS CONTROL ! 3263: # WITHOUT ADJUSTING THE ARGUMENT COUNT. THE ONLY ! 3264: # PREDEFINED FUNCTIONS USING THIS ARE APPLY AND ITEM. ! 3265: # ! 3266: # SVLBL SYSTEM LABEL POINTER ! 3267: # ! 3268: # SVLBL IS PRESENT ONLY FOR A STANDARD LABEL ASSOC. ! 3269: # IT IS A POINTER TO A SYSTEM LABEL ROUTINE (L$XXX). ! 3270: # THE VRLBL FIELD OF THE CORRESPONDING VRBLK POINTS TO ! 3271: # THE SVLBL FIELD OF THE SVBLK. ! 3272: # ! 3273: # SVVAL SYSTEM VALUE POINTER ! 3274: # ! 3275: # SVVAL IS PRESENT ONLY FOR A STANDARD VALUE. ! 3276: # IT IS A POINTER TO THE PATTERN NODE (NDXXX) WHICH ! 3277: # IS THE STANDARD INITIAL VALUE OF THE VARIABLE. ! 3278: # THIS VALUE IS COPIED TO THE VRVAL FIELD OF THE VRBLK ! 3279: #page ! 3280: # ! 3281: # SVBLK (CONTINUED) ! 3282: # ! 3283: # KEYWORD NUMBER TABLE ! 3284: # ! 3285: # THE FOLLOWING TABLE GIVES SYMBOLIC NAMES FOR KEYWORD ! 3286: # NUMBERS. THESE VALUES ARE STORED IN THE SVKNM FIELD OF ! 3287: # SVBLKS AND IN THE KVNUM FIELD OF KVBLKS. SEE ALSO ! 3288: # PROCEDURES ASIGN, ACESS AND KWNAM. ! 3289: # ! 3290: # UNPROTECTED KEYWORDS WITH ONE WORD INTEGER VALUES ! 3291: # ! 3292: .set k$abe,0 # abend ! 3293: .set k$anc,k$abe+cfp$b# anchor ! 3294: .set k$cas,k$anc+cfp$b# case ! 3295: .set k$cod,k$cas+cfp$b# code ! 3296: .set k$dmp,k$cod+cfp$b# dump ! 3297: .set k$erl,k$dmp+cfp$b# errlimit ! 3298: .set k$ert,k$erl+cfp$b# errtype ! 3299: .set k$ftr,k$ert+cfp$b# ftrace ! 3300: .set k$inp,k$ftr+cfp$b# input ! 3301: .set k$mxl,k$inp+cfp$b# maxlength ! 3302: .set k$oup,k$mxl+cfp$b# output ! 3303: .set k$pfl,k$oup+cfp$b# profile ! 3304: .set k$tra,k$pfl+cfp$b# trace ! 3305: .set k$trm,k$tra+cfp$b# trim ! 3306: # ! 3307: # PROTECTED KEYWORDS WITH ONE WORD INTEGER VALUES ! 3308: # ! 3309: .set k$fnc,k$trm+cfp$b# fnclevel ! 3310: .set k$lst,k$fnc+cfp$b# lastno ! 3311: .set k$stn,k$lst+cfp$b# stno ! 3312: # ! 3313: # KEYWORDS WITH CONSTANT PATTERN VALUES ! 3314: # ! 3315: .set k$abo,k$stn+cfp$b# abort ! 3316: .set k$arb,k$abo+pasi$# arb ! 3317: .set k$bal,k$arb+pasi$# bal ! 3318: .set k$fal,k$bal+pasi$# fail ! 3319: .set k$fen,k$fal+pasi$# fence ! 3320: .set k$rem,k$fen+pasi$# rem ! 3321: .set k$suc,k$rem+pasi$# succeed ! 3322: #page ! 3323: # ! 3324: # KEYWORD NUMBER TABLE (CONTINUED) ! 3325: # ! 3326: # SPECIAL KEYWORDS ! 3327: # ! 3328: .set k$alp,k$suc+1 # alphabet ! 3329: .set k$rtn,k$alp+1 # rtntype ! 3330: .set k$stc,k$rtn+1 # stcount ! 3331: .set k$etx,k$stc+1 # errtext ! 3332: .set k$stl,k$etx+1 # stlimit ! 3333: # ! 3334: # RELATIVE OFFSETS OF SPECIAL KEYWORDS ! 3335: # ! 3336: .set k$$al,k$alp-k$alp# alphabet ! 3337: .set k$$rt,k$rtn-k$alp# rtntype ! 3338: .set k$$sc,k$stc-k$alp# stcount ! 3339: .set k$$et,k$etx-k$alp# errtext ! 3340: .set k$$sl,k$stl-k$alp# stlimit ! 3341: # ! 3342: # SYMBOLS USED IN ASIGN AND ACESS PROCEDURES ! 3343: # ! 3344: .set k$p$$,k$fnc # first protected keyword ! 3345: .set k$v$$,k$abo # first keyword with constant value ! 3346: .set k$s$$,k$alp # first keyword with special acess ! 3347: #page ! 3348: # ! 3349: # FORMAT OF A TABLE BLOCK (TBBLK) ! 3350: # ! 3351: # A TABLE BLOCK IS USED TO REPRESENT A TABLE VALUE. ! 3352: # IT IS BUILT BY A CALL TO THE TABLE OR CONVERT FUNCTIONS. ! 3353: # ! 3354: # +------------------------------------+ ! 3355: # I TBTYP I ! 3356: # +------------------------------------+ ! 3357: # I IDVAL I ! 3358: # +------------------------------------+ ! 3359: # I TBLEN I ! 3360: # +------------------------------------+ ! 3361: # +------------------------------------+ ! 3362: # I TBINV I ! 3363: # +------------------------------------+ ! 3364: # / / ! 3365: # / TBBUK / ! 3366: # / / ! 3367: # +------------------------------------+ ! 3368: # ! 3369: .set tbtyp,0 # pointer to dummy routine b$tbt ! 3370: .set tblen,offs2 # length of tbblk in bytes ! 3371: .set tbinv,offs3 # default initial lookup value ! 3372: .set tbbuk,tbinv+1 # start of hash bucket pointers ! 3373: .set tbsi$,tbbuk # size of standard fields in tbblk ! 3374: .set tbnbk,11 # default no. of buckets ! 3375: # ! 3376: # THE TABLE BLOCK IS A HASH TABLE WHICH POINTS TO CHAINS ! 3377: # OF TABLE ELEMENT BLOCKS REPRESENTING THE ELEMENTS ! 3378: # IN THE TABLE WHICH HASH INTO THE SAME BUCKET. ! 3379: # ! 3380: # TBBUK ENTRIES EITHER POINT TO THE FIRST TEBLK ON THE ! 3381: # CHAIN OR THEY POINT TO THE TBBLK ITSELF TO INDICATE THE ! 3382: # END OF THE CHAIN. ! 3383: #page ! 3384: # ! 3385: # TABLE ELEMENT BLOCK (TEBLK) ! 3386: # ! 3387: # A TABLE ELEMENT IS USED TO REPRESENT A SINGLE ENTRY IN ! 3388: # A TABLE (SEE DESCRIPTION OF TBBLK FORMAT FOR HASH TABLE) ! 3389: # ! 3390: # +------------------------------------+ ! 3391: # I TETYP I ! 3392: # +------------------------------------+ ! 3393: # I TESUB I ! 3394: # +------------------------------------+ ! 3395: # I TEVAL I ! 3396: # +------------------------------------+ ! 3397: # I TENXT I ! 3398: # +------------------------------------+ ! 3399: # ! 3400: .set tetyp,0 # pointer to dummy routine b$tet ! 3401: .set tesub,tetyp+1 # subscript value ! 3402: .set teval,tesub+1 # (=vrval) table element value ! 3403: .set tenxt,teval+1 # link to next teblk ! 3404: # SEE S$CNV WHERE RELATION IS ASSUMED WITH TENXT AND TBBUK ! 3405: .set tesi$,tenxt+1 # size of teblk in words ! 3406: # ! 3407: # TENXT POINTS TO THE NEXT TEBLK ON THE HASH CHAIN FROM THE ! 3408: # TBBUK CHAIN FOR THIS HASH INDEX. AT THE END OF THE CHAIN, ! 3409: # TENXT POINTS BACK TO THE START OF THE TBBLK. ! 3410: # ! 3411: # TEVAL CONTAINS A DATA POINTER OR A TRBLK POINTER. ! 3412: # ! 3413: # TESUB CONTAINS A DATA POINTER. ! 3414: #page ! 3415: # ! 3416: # TRAP BLOCK (TRBLK) ! 3417: # ! 3418: # A TRAP BLOCK IS USED TO REPRESENT A TRACE OR INPUT OR ! 3419: # OUTPUT ASSOCIATION IN RESPONSE TO A CALL TO THE TRACE ! 3420: # INPUT OR OUTPUT SYSTEM FUNCTIONS. SEE BELOW FOR DETAILS ! 3421: # ! 3422: # +------------------------------------+ ! 3423: # I TRIDN I ! 3424: # +------------------------------------+ ! 3425: # I TRTYP I ! 3426: # +------------------------------------+ ! 3427: # I TRVAL OR TRLBL OR TRNXT OR TRKVR I ! 3428: # +------------------------------------+ ! 3429: # I TRTAG OR TRTER OR TRTRF I ! 3430: # +------------------------------------+ ! 3431: # I TRFNC OR TRFPT I ! 3432: # +------------------------------------+ ! 3433: # ! 3434: .set tridn,0 # pointer to dummy routine b$trt ! 3435: .set trtyp,tridn+1 # trap type code ! 3436: .set trval,trtyp+1 # value of trapped variable (=vrval) ! 3437: .set trnxt,trval # ptr to next trblk on trblk chain ! 3438: .set trlbl,trval # ptr to actual label (traced label) ! 3439: .set trkvr,trval # vrblk pointer for keyword trace ! 3440: .set trtag,trval+1 # trace tag ! 3441: .set trter,trtag # ptr to terminal vrblk or null ! 3442: .set trtrf,trtag # ptr to trblk holding fcblk ptr ! 3443: .set trfnc,trtag+1 # trace function vrblk (zero if none) ! 3444: .set trfpt,trfnc # fcblk ptr for sysio ! 3445: .set trsi$,trfnc+1 # number of words in trblk ! 3446: # ! 3447: .set trtin,0 # trace type for input association ! 3448: .set trtac,trtin+1 # trace type for access trace ! 3449: .set trtvl,trtac+1 # trace type for value trace ! 3450: .set trtou,trtvl+1 # trace type for output association ! 3451: .set trtfc,trtou+1 # trace type for fcblk identification ! 3452: #page ! 3453: # ! 3454: # TRAP BLOCK (CONTINUED) ! 3455: # ! 3456: # VARIABLE INPUT ASSOCIATION ! 3457: # ! 3458: # THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK ! 3459: # INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE ! 3460: # OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS ! 3461: # CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK. ! 3462: # ! 3463: # TRTYP IS SET TO TRTIN ! 3464: # TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL ! 3465: # TRTER IS A POINTER TO SVBLK IF ASSOCIATION IS ! 3466: # FOR INPUT, TERMINAL, ELSE IT IS NULL. ! 3467: # TRTRF POINTS TO THE TRAP BLOCK WHICH IN TURN POINTS ! 3468: # TO AN FCBLK USED FOR I/O ASSOCIATION. ! 3469: # TRFPT IS THE FCBLK PTR RETURNED BY SYSIO. ! 3470: # ! 3471: # VARIABLE ACCESS TRACE ASSOCIATION ! 3472: # ! 3473: # THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK ! 3474: # INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE ! 3475: # OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS ! 3476: # CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK. ! 3477: # ! 3478: # TRTYP IS SET TO TRTAC ! 3479: # TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL ! 3480: # TRTAG IS THE TRACE TAG (0 IF NONE) ! 3481: # TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 3482: # ! 3483: # VARIABLE VALUE TRACE ASSOCIATION ! 3484: # ! 3485: # THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK ! 3486: # INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE ! 3487: # OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS ! 3488: # CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK. ! 3489: # ! 3490: # TRTYP IS SET TO TRTVL ! 3491: # TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL ! 3492: # TRTAG IS THE TRACE TAG (0 IF NONE) ! 3493: # TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 3494: #page ! 3495: # TRAP BLOCK (CONTINUED) ! 3496: # ! 3497: # VARIABLE OUTPUT ASSOCIATION ! 3498: # ! 3499: # THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK ! 3500: # INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE ! 3501: # OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS ! 3502: # CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK. ! 3503: # ! 3504: # TRTYP IS SET TO TRTOU ! 3505: # TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL ! 3506: # TRTER IS A POINTER TO SVBLK IF ASSOCIATION IS ! 3507: # FOR OUTPUT, TERMINAL, ELSE IT IS NULL. ! 3508: # TRTRF POINTS TO THE TRAP BLOCK WHICH IN TURN POINTS ! 3509: # TO AN FCBLK USED FOR I/O ASSOCIATION. ! 3510: # TRFPT IS THE FCBLK PTR RETURNED BY SYSIO. ! 3511: # ! 3512: # FUNCTION CALL TRACE ! 3513: # ! 3514: # THE PFCTR FIELD OF THE CORRESPONDING PFBLK IS SET ! 3515: # TO POINT TO A TRBLK. ! 3516: # ! 3517: # TRTYP IS SET TO TRTIN ! 3518: # TRNXT IS ZERO ! 3519: # TRTAG IS THE TRACE TAG (0 IF NONE) ! 3520: # TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 3521: # ! 3522: # FUNCTION RETURN TRACE ! 3523: # ! 3524: # THE PFRTR FIELD OF THE CORRESPONDING PFBLK IS SET ! 3525: # TO POINT TO A TRBLK ! 3526: # ! 3527: # TRTYP IS SET TO TRTIN ! 3528: # TRNXT IS ZERO ! 3529: # TRTAG IS THE TRACE TAG (0 IF NONE) ! 3530: # TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 3531: # ! 3532: # LABEL TRACE ! 3533: # ! 3534: # THE VRLBL OF THE VRBLK FOR THE LABEL IS ! 3535: # CHANGED TO POINT TO A TRBLK AND THE VRTRA FIELD IS ! 3536: # SET TO B$VRT TO ACTIVATE THE CHECK. ! 3537: # ! 3538: # TRTYP IS SET TO TRTIN ! 3539: # TRLBL POINTS TO THE ACTUAL LABEL (CDBLK) VALUE ! 3540: # TRTAG IS THE TRACE TAG (0 IF NONE) ! 3541: # TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 3542: #page ! 3543: # ! 3544: # TRAP BLOCK (CONTINUED) ! 3545: # ! 3546: # KEYWORD TRACE ! 3547: # ! 3548: # KEYWORDS WHICH CAN BE TRACED POSSESS A UNIQUE ! 3549: # LOCATION WHICH IS ZERO IF THERE IS NO TRACE AND ! 3550: # POINTS TO A TRBLK IF THERE IS A TRACE. THE LOCATIONS ! 3551: # ARE AS FOLLOWS. ! 3552: # ! 3553: # R$ERT ERRTYPE ! 3554: # R$FNC FNCLEVEL ! 3555: # R$STC STCOUNT ! 3556: # ! 3557: # THE FORMAT OF THE TRBLK IS AS FOLLOWS. ! 3558: # ! 3559: # TRTYP IS SET TO TRTIN ! 3560: # TRKVR IS A POINTER TO THE VRBLK FOR THE KEYWORD ! 3561: # TRTAG IS THE TRACE TAG (0 IF NONE) ! 3562: # TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE) ! 3563: # ! 3564: # INPUT/OUTPUT FILE ARG1 TRAP BLOCK ! 3565: # ! 3566: # THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK ! 3567: # INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE OF ! 3568: # A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS ! 3569: # CONTAIN =B$VRA AND =B$VRV. THIS TRAP BLOCK IS USED ! 3570: # TO HOLD A POINTER TO THE FCBLK WHICH AN ! 3571: # IMPLEMENTATION MAY REQUEST TO HOLD INFORMATION ! 3572: # ABOUT A FILE. ! 3573: # ! 3574: # TRTYP IS SET TO TRTFC ! 3575: # TRNEXT POINTS TO NEXT TRBLK OR TRVAL IS VARIABLE VAL ! 3576: # TRFNM IS 0 ! 3577: # TRFPT IS THE FCBLK POINTER. ! 3578: # ! 3579: # NOTE THAT WHEN MULTIPLE TRAPS ARE SET ON A VARIABLE ! 3580: # THE ORDER IS IN ASCENDING VALUE OF TRTYP FIELD. ! 3581: # ! 3582: # INPUT ASSOCIATION (IF PRESENT) ! 3583: # ACCESS TRACE (IF PRESENT) ! 3584: # VALUE TRACE (IF PRESENT) ! 3585: # OUTPUT ASSOCIATION (IF PRESENT) ! 3586: # ! 3587: # THE ACTUAL VALUE OF THE VARIABLE IS STORED IN THE TRVAL ! 3588: # FIELD OF THE LAST TRBLK ON THE CHAIN. ! 3589: # ! 3590: # THIS IMPLEMENTATION DOES NOT PERMIT TRACE OR I/O ! 3591: # ASSOCIATIONS TO ANY OF THE PSEUDO-VARIABLES. ! 3592: #page ! 3593: # ! 3594: # VECTOR BLOCK (VCBLK) ! 3595: # ! 3596: # A VCBLK IS USED TO REPRESENT AN ARRAY VALUE WHICH HAS ! 3597: # ONE DIMENSION WHOSE LOWER BOUND IS ONE. ALL OTHER ARRAYS ! 3598: # ARE REPRESENTED BY ARBLKS. A VCBLK IS CREATED BY THE ! 3599: # SYSTEM FUNCTION ARRAY (S$ARR) WHEN PASSED AN INTEGER ARG. ! 3600: # ! 3601: # +------------------------------------+ ! 3602: # I VCTYP I ! 3603: # +------------------------------------+ ! 3604: # I IDVAL I ! 3605: # +------------------------------------+ ! 3606: # I VCLEN I ! 3607: # +------------------------------------+ ! 3608: # I VCVLS I ! 3609: # +------------------------------------+ ! 3610: # ! 3611: .set vctyp,0 # pointer to dummy routine b$vct ! 3612: .set vclen,offs2 # length of vcblk in bytes ! 3613: .set vcvls,offs3 # start of vector values ! 3614: .set vcsi$,vcvls # size of standard fields in vcblk ! 3615: .set vcvlb,vcvls-1 # offset one word behind vcvls ! 3616: .set vctbd,tbsi$-vcsi$# difference in sizes - see prtvl ! 3617: # ! 3618: # VCVLS ARE EITHER DATA POINTERS OR TRBLK POINTERS ! 3619: # ! 3620: # THE DIMENSION CAN BE DEDUCED FROM VCLEN. ! 3621: #page ! 3622: # ! 3623: # VARIABLE BLOCK (VRBLK) ! 3624: # ! 3625: # A VARIABLE BLOCK IS BUILT IN THE STATIC MEMORY AREA ! 3626: # FOR EVERY VARIABLE REFERENCED OR CREATED BY A PROGRAM. ! 3627: # ! 3628: # NOTE THAT SINCE THESE BLOCKS ONLY OCCUR IN THE STATIC ! 3629: # REGION, IT IS PERMISSIBLE TO POINT TO ANY WORD IN ! 3630: # THE BLOCK AND THIS IS USED TO PROVIDE THREE DISTINCT ! 3631: # ACCESS POINTS FROM THE GENERATED CODE AS FOLLOWS. ! 3632: # ! 3633: # 1) POINT TO VRGET (FIRST WORD OF VRBLK) TO LOAD THE ! 3634: # VALUE OF THE VARIABLE ONTO THE MAIN STACK. ! 3635: # ! 3636: # 2) POINT TO VRSTO (SECOND WORD OF VRBLK) TO STORE THE ! 3637: # TOP STACK ELEMENT AS THE VALUE OF THE VARIABLE. ! 3638: # ! 3639: # 3) POINT TO VRTRA (FOURTH WORD OF VRBLK) TO JUMP TO ! 3640: # THE LABEL ASSOCIATED WITH THE VARIABLE NAME. ! 3641: # ! 3642: # +------------------------------------+ ! 3643: # I VRGET I ! 3644: # +------------------------------------+ ! 3645: # I VRSTO I ! 3646: # +------------------------------------+ ! 3647: # I VRVAL I ! 3648: # +------------------------------------+ ! 3649: # I VRTRA I ! 3650: # +------------------------------------+ ! 3651: # I VRLBL I ! 3652: # +------------------------------------+ ! 3653: # I VRFNC I ! 3654: # +------------------------------------+ ! 3655: # I VRNXT I ! 3656: # +------------------------------------+ ! 3657: # I VRLEN I ! 3658: # +------------------------------------+ ! 3659: # / / ! 3660: # / VRCHS = VRSVP / ! 3661: # / / ! 3662: # +------------------------------------+ ! 3663: #page ! 3664: # ! 3665: # VARIABLE BLOCK (CONTINUED) ! 3666: # ! 3667: .set vrget,0 # pointer to routine to load value ! 3668: .set vrsto,vrget+1 # pointer to routine to store value ! 3669: .set vrval,vrsto+1 # variable value ! 3670: .set vrvlo,vrval-vrsto# offset to value from store field ! 3671: .set vrtra,vrval+1 # pointer to routine to jump to label ! 3672: .set vrlbl,vrtra+1 # pointer to code for label ! 3673: .set vrlbo,vrlbl-vrtra# offset to label from transfer field ! 3674: .set vrfnc,vrlbl+1 # pointer to function block ! 3675: .set vrnxt,vrfnc+1 # pointer to next vrblk on hash chain ! 3676: .set vrlen,vrnxt+1 # length of name (or zero) ! 3677: .set vrchs,vrlen+1 # characters of name (vrlen gt 0) ! 3678: .set vrsvp,vrlen+1 # ptr to svblk (vrlen eq 0) ! 3679: .set vrsi$,vrchs+1 # number of standard fields in vrblk ! 3680: .set vrsof,vrlen-sclen# offset to dummy scblk for name ! 3681: .set vrsvo,vrsvp-vrsof# pseudo-offset to vrsvp field ! 3682: # ! 3683: # VRGET = B$VRL IF NOT INPUT ASSOCIATED OR ACCESS TRACED ! 3684: # VRGET = B$VRA IF INPUT ASSOCIATED OR ACCESS TRACED ! 3685: # ! 3686: # VRSTO = B$VRS IF NOT OUTPUT ASSOCIATED OR VALUE TRACED ! 3687: # VRSTO = B$VRV IF OUTPUT ASSOCIATED OR VALUE TRACED ! 3688: # VRSTO = B$VRE IF VALUE IS PROTECTED PATTERN VALUE ! 3689: # ! 3690: # VRVAL POINTS TO THE APPROPRIATE VALUE UNLESS THE ! 3691: # VARIABLE IS I/O/TRACE ASSOCIATED IN WHICH CASE, VRVAL ! 3692: # POINTS TO AN APPROPRIATE TRBLK (TRAP BLOCK) CHAIN. ! 3693: # ! 3694: # VRTRA = B$VRG IF THE LABEL IS NOT TRACED ! 3695: # VRTRA = B$VRT IF THE LABEL IS TRACED ! 3696: # ! 3697: # VRLBL POINTS TO A CDBLK IF THERE IS A LABEL ! 3698: # VRLBL POINTS TO THE SVBLK SVLBL FIELD FOR A SYSTEM LABEL ! 3699: # VRLBL POINTS TO STNDL FOR AN UNDEFINED LABEL ! 3700: # VRLBL POINTS TO A TRBLK IF THE LABEL IS TRACED ! 3701: # ! 3702: # VRFNC POINTS TO A FFBLK FOR A FIELD FUNCTION ! 3703: # VRFNC POINTS TO A DFBLK FOR A DATATYPE FUNCTION ! 3704: # VRFNC POINTS TO A PFBLK FOR A PROGRAM DEFINED FUNCTION ! 3705: # VRFNC POINTS TO A EFBLK FOR AN EXTERNAL LOADED FUNCTION ! 3706: # VRFNC POINTS TO SVFNC (SVBLK) FOR A SYSTEM FUNCTION ! 3707: # VRFNC POINTS TO STNDF IF THE FUNCTION IS UNDEFINED ! 3708: # ! 3709: # VRNXT POINTS TO THE NEXT VRBLK ON THIS CHAIN UNLESS ! 3710: # THIS IS THE END OF THE CHAIN IN WHICH CASE IT IS ZERO. ! 3711: # ! 3712: # VRLEN IS THE NAME LENGTH FOR A NON-SYSTEM VARIABLE. ! 3713: # VRLEN IS ZERO FOR A SYSTEM VARIABLE. ! 3714: # ! 3715: # VRCHS IS THE NAME (LJRZ) IF VRLEN IS NON-ZERO. ! 3716: # VRSVP IS A PTR TO THE SVBLK IF VRLEN IS ZERO. ! 3717: #page ! 3718: # ! 3719: # FORMAT OF A NON-RELOCATABLE EXTERNAL BLOCK (XNBLK) ! 3720: # ! 3721: # AN XNBLK IS A BLOCK REPRESENTING AN UNKNOWN (EXTERNAL) ! 3722: # DATA VALUE. THE BLOCK CONTAINS NO POINTERS TO OTHER ! 3723: # RELOCATABLE BLOCKS. AN XNBLK IS USED BY EXTERNAL FUNCTION ! 3724: # PROCESSING OR POSSIBLY FOR SYSTEM I/O ROUTINES ETC. ! 3725: # THE MACRO-SYSTEM ITSELF DOES NOT USE XNBLKS. ! 3726: # THIS TYPE OF BLOCK MAY BE USED AS A FILE CONTROL BLOCK. ! 3727: # SEE SYSFC,SYSIN,SYSOU,S$INP,S$OUP FOR DETAILS. ! 3728: # ! 3729: # +------------------------------------+ ! 3730: # I XNTYP I ! 3731: # +------------------------------------+ ! 3732: # I XNLEN I ! 3733: # +------------------------------------+ ! 3734: # / / ! 3735: # / XNDTA / ! 3736: # / / ! 3737: # +------------------------------------+ ! 3738: # ! 3739: .set xntyp,0 # pointer to dummy routine b$xnt ! 3740: .set xnlen,xntyp+1 # length of xnblk in bytes ! 3741: .set xndta,xnlen+1 # data words ! 3742: .set xnsi$,xndta # size of standard fields in xnblk ! 3743: # ! 3744: # NOTE THAT THE TERM NON-RELOCATABLE REFERS TO THE CONTENTS ! 3745: # AND NOT THE BLOCK ITSELF. AN XNBLK CAN BE MOVED AROUND IF ! 3746: # IT IS BUILT IN THE DYNAMIC MEMORY AREA. ! 3747: #page ! 3748: # ! 3749: # RELOCATABLE EXTERNAL BLOCK (XRBLK) ! 3750: # ! 3751: # AN XRBLK IS A BLOCK REPRESENTING AN UNKNOWN (EXTERNAL) ! 3752: # DATA VALUE. THE DATA AREA IN THIS BLOCK CONSISTS ONLY ! 3753: # OF ADDRESS VALUES AND ANY ADDRESSES POINTING INTO THE ! 3754: # DYNAMIC MEMORY AREA MUST POINT TO THE START OF OTHER ! 3755: # DATA BLOCKS. SEE ALSO DESCRIPTION OF XNBLK. ! 3756: # THIS TYPE OF BLOCK MAY BE USED AS A FILE CONTROL BLOCK. ! 3757: # SEE SYSFC,SYSIN,SYSOU,S$INP,S$OUP FOR DETAILS. ! 3758: # ! 3759: # +------------------------------------+ ! 3760: # I XRTYP I ! 3761: # +------------------------------------+ ! 3762: # I XRLEN I ! 3763: # +------------------------------------+ ! 3764: # / / ! 3765: # / XRPTR / ! 3766: # / / ! 3767: # +------------------------------------+ ! 3768: # ! 3769: .set xrtyp,0 # pointer to dummy routine b$xrt ! 3770: .set xrlen,xrtyp+1 # length of xrblk in bytes ! 3771: .set xrptr,xrlen+1 # start of address pointers ! 3772: .set xrsi$,xrptr # size of standard fields in xrblk ! 3773: #page ! 3774: # ! 3775: # S$CNV (CONVERT) FUNCTION SWITCH CONSTANTS. THE VALUES ! 3776: # ARE TIED TO THE ORDER OF THE ENTRIES IN THE SVCTB TABLE ! 3777: # AND HENCE TO THE BRANCH TABLE IN S$CNV. ! 3778: # ! 3779: .set cnvst,8 # max standard type code for convert ! 3780: .set cnvrt,cnvst+1 # convert code for reals ! 3781: .set cnvbt,cnvrt+1 # convert code for buffer ! 3782: .set cnvtt,cnvbt+1 # bsw code for convert ! 3783: # ! 3784: # INPUT IMAGE LENGTH ! 3785: # ! 3786: .set iniln,132 # default image length for compiler ! 3787: .set inils,80 # image length if -sequ in effect ! 3788: # ! 3789: .set ionmb,2 # name base used for iochn in sysio ! 3790: .set ionmo,4 # name offset used for iochn in sysio ! 3791: # ! 3792: # IN GENERAL, MEANINGFUL MNEMONICS SHOULD BE USED FOR ! 3793: # OFFSETS. HOWEVER FOR SMALL INTEGERS USED OFTEN IN ! 3794: # LITERALS THE FOLLOWING GENERAL DEFINITIONS ARE PROVIDED. ! 3795: # ! 3796: .set num01,1 ! 3797: .set num02,2 ! 3798: .set num03,3 ! 3799: .set num04,4 ! 3800: .set num05,5 ! 3801: .set num06,6 ! 3802: .set num07,7 ! 3803: .set num08,8 ! 3804: .set num09,9 ! 3805: .set num10,10 ! 3806: .set nini8,998 ! 3807: .set nini9,999 ! 3808: .set thsnd,1000 ! 3809: #page ! 3810: # ! 3811: # NUMBERS OF UNDEFINED SPITBOL OPERATORS ! 3812: # ! 3813: .set opbun,5 # no. of binary undefined ops ! 3814: .set opuun,6 # no of unary undefined ops ! 3815: # ! 3816: # OFFSETS USED IN PRTSN, PRTMI AND ACESS ! 3817: # ! 3818: .set prsnf,13 # offset used in prtsn ! 3819: .set prtmf,15 # offset to col 15 (prtmi) ! 3820: .set rilen,120 # buffer length for sysri ! 3821: # ! 3822: # CODES FOR STAGES OF PROCESSING ! 3823: # ! 3824: .set stgic,0 # initial compile ! 3825: .set stgxc,stgic+1 # execution compile (code) ! 3826: .set stgev,stgxc+1 # expression eval during execution ! 3827: .set stgxt,stgev+1 # execution time ! 3828: .set stgce,stgxt+1 # initial compile after end line ! 3829: .set stgxe,stgce+1 # exec. compile after end line ! 3830: .set stgnd,stgce-stgic# difference in stage after end ! 3831: .set stgee,stgxe+1 # eval evaluating expression ! 3832: .set stgno,stgee+1 # number of codes ! 3833: #page ! 3834: # ! 3835: # ! 3836: # STATEMENT NUMBER PAD COUNT FOR LISTR ! 3837: # ! 3838: .set stnpd,8 # statement no. pad count ! 3839: # ! 3840: # SYNTAX TYPE CODES ! 3841: # ! 3842: # THESE CODES ARE RETURNED FROM THE SCANE PROCEDURE. ! 3843: # ! 3844: # THEY ARE SPACED 3 APART FOR THE BENEFIT OF EXPAN. ! 3845: # ! 3846: .set t$uop,0 # unary operator ! 3847: .set t$lpr,t$uop+3 # left paren ! 3848: .set t$lbr,t$lpr+3 # left bracket ! 3849: .set t$cma,t$lbr+3 # comma ! 3850: .set t$fnc,t$cma+3 # function call ! 3851: .set t$var,t$fnc+3 # variable ! 3852: .set t$con,t$var+3 # constant ! 3853: .set t$bop,t$con+3 # binary operator ! 3854: .set t$rpr,t$bop+3 # right paren ! 3855: .set t$rbr,t$rpr+3 # right bracket ! 3856: .set t$col,t$rbr+3 # colon ! 3857: .set t$smc,t$col+3 # semi-colon ! 3858: # ! 3859: # THE FOLLOWING DEFINITIONS ARE USED ONLY IN THE GOTO FIELD ! 3860: # ! 3861: .set t$fgo,t$smc+1 # failure goto ! 3862: .set t$sgo,t$fgo+1 # success goto ! 3863: # ! 3864: # THE ABOVE CODES ARE GROUPED SO THAT CODES FOR ELEMENTS ! 3865: # WHICH CAN LEGITIMATELY IMMEDIATELY PRECEDE A UNARY ! 3866: # OPERATOR COME FIRST TO FACILITATE OPERATOR SYNTAX CHECK. ! 3867: # ! 3868: .set t$uok,t$fnc # last code ok before unary operator ! 3869: #page ! 3870: # ! 3871: # DEFINITIONS OF VALUES FOR EXPAN JUMP TABLE ! 3872: # ! 3873: .set t$uo0,t$uop+0 # unary operator, state zero ! 3874: .set t$uo1,t$uop+1 # unary operator, state one ! 3875: .set t$uo2,t$uop+2 # unary operator, state two ! 3876: .set t$lp0,t$lpr+0 # left paren, state zero ! 3877: .set t$lp1,t$lpr+1 # left paren, state one ! 3878: .set t$lp2,t$lpr+2 # left paren, state two ! 3879: .set t$lb0,t$lbr+0 # left bracket, state zero ! 3880: .set t$lb1,t$lbr+1 # left bracket, state one ! 3881: .set t$lb2,t$lbr+2 # left bracket, state two ! 3882: .set t$cm0,t$cma+0 # comma, state zero ! 3883: .set t$cm1,t$cma+1 # comma, state one ! 3884: .set t$cm2,t$cma+2 # comma, state two ! 3885: .set t$fn0,t$fnc+0 # function call, state zero ! 3886: .set t$fn1,t$fnc+1 # function call, state one ! 3887: .set t$fn2,t$fnc+2 # function call, state two ! 3888: .set t$va0,t$var+0 # variable, state zero ! 3889: .set t$va1,t$var+1 # variable, state one ! 3890: .set t$va2,t$var+2 # variable, state two ! 3891: .set t$co0,t$con+0 # constant, state zero ! 3892: .set t$co1,t$con+1 # constant, state one ! 3893: .set t$co2,t$con+2 # constant, state two ! 3894: .set t$bo0,t$bop+0 # binary operator, state zero ! 3895: .set t$bo1,t$bop+1 # binary operator, state one ! 3896: .set t$bo2,t$bop+2 # binary operator, state two ! 3897: .set t$rp0,t$rpr+0 # right paren, state zero ! 3898: .set t$rp1,t$rpr+1 # right paren, state one ! 3899: .set t$rp2,t$rpr+2 # right paren, state two ! 3900: .set t$rb0,t$rbr+0 # right bracket, state zero ! 3901: .set t$rb1,t$rbr+1 # right bracket, state one ! 3902: .set t$rb2,t$rbr+2 # right bracket, state two ! 3903: .set t$cl0,t$col+0 # colon, state zero ! 3904: .set t$cl1,t$col+1 # colon, state one ! 3905: .set t$cl2,t$col+2 # colon, state two ! 3906: .set t$sm0,t$smc+0 # semicolon, state zero ! 3907: .set t$sm1,t$smc+1 # semicolon, state one ! 3908: .set t$sm2,t$smc+2 # semicolon, state two ! 3909: # ! 3910: .set t$nes,t$sm2+1 # number of entries in branch table ! 3911: #page ! 3912: # ! 3913: # DEFINITION OF OFFSETS USED IN CONTROL CARD PROCESSING ! 3914: # ! 3915: .set cc$ca,0 # -case ! 3916: .set cc$do,cc$ca+1 # -double ! 3917: .set cc$du,cc$do+1 # -dump ! 3918: .set cc$ej,cc$du+1 # -eject ! 3919: .set cc$er,cc$ej+1 # -errors ! 3920: .set cc$ex,cc$er+1 # -execute ! 3921: .set cc$fa,cc$ex+1 # -fail ! 3922: .set cc$li,cc$fa+1 # -list ! 3923: .set cc$nr,cc$li+1 # -noerrors ! 3924: .set cc$nx,cc$nr+1 # -noexecute ! 3925: .set cc$nf,cc$nx+1 # -nofail ! 3926: .set cc$nl,cc$nf+1 # -nolist ! 3927: .set cc$no,cc$nl+1 # -noopt ! 3928: .set cc$np,cc$no+1 # -noprint ! 3929: .set cc$op,cc$np+1 # -optimise ! 3930: .set cc$pr,cc$op+1 # -print ! 3931: .set cc$si,cc$pr+1 # -single ! 3932: .set cc$sp,cc$si+1 # -space ! 3933: .set cc$st,cc$sp+1 # -stitl ! 3934: .set cc$ti,cc$st+1 # -title ! 3935: .set cc$tr,cc$ti+1 # -trace ! 3936: .set cc$nc,cc$tr+1 # number of control cards ! 3937: .set ccnoc,4 # no. of chars included in match ! 3938: .set ccofs,7 # offset to start of title/subtitle ! 3939: #page ! 3940: # ! 3941: # DEFINITIONS OF STACK OFFSETS USED IN CMPIL PROCEDURE ! 3942: # ! 3943: # SEE DESCRIPTION AT START OF CMPIL PROCEDURE FOR DETAILS ! 3944: # OF USE OF THESE LOCATIONS ON THE STACK. ! 3945: # ! 3946: .set cmstm,0 # tree for statement body ! 3947: .set cmsgo,cmstm+1 # tree for success goto ! 3948: .set cmfgo,cmsgo+1 # tree for fail goto ! 3949: .set cmcgo,cmfgo+1 # conditional goto flag ! 3950: .set cmpcd,cmcgo+1 # previous cdblk pointer ! 3951: .set cmffp,cmpcd+1 # failure fill in flag for previous ! 3952: .set cmffc,cmffp+1 # failure fill in flag for current ! 3953: .set cmsop,cmffc+1 # success fill in offset for previous ! 3954: .set cmsoc,cmsop+1 # success fill in offset for current ! 3955: .set cmlbl,cmsoc+1 # ptr to vrblk for current label ! 3956: .set cmtra,cmlbl+1 # ptr to entry cdblk ! 3957: # ! 3958: .set cmnen,cmtra+1 # count of stack entries for cmpil ! 3959: # ! 3960: # A FEW CONSTANTS USED BY THE PROFILER ! 3961: .set pfpd1,8 # pad positions ... ! 3962: .set pfpd2,20 # ... for profile ... ! 3963: .set pfpd3,32 # ... printout ! 3964: .set pf$i2,cfp$i+cfp$i# size of table entry (2 ints) ! 3965: # ! 3966: #title s p i t b o l -- constant section ! 3967: # ! 3968: # THIS SECTION CONSISTS ENTIRELY OF ASSEMBLED CONSTANTS. ! 3969: # ! 3970: # ALL LABEL NAMES ARE FIVE LETTERS. THE ORDER IS ! 3971: # APPROXIMATELY ALPHABETICAL, BUT IN SOME CASES (ALWAYS ! 3972: # DOCUMENTED), CONSTANTS MUST BE PLACED IN SOME SPECIAL ! 3973: # ORDER WHICH MUST NOT BE DISTURBED. ! 3974: # ! 3975: # IT MUST ALSO BE REMEMBERED THAT THERE IS A REQUIREMENT ! 3976: # FOR NO FORWARD REFERENCES WHICH ALSO DISTURBS THE ! 3977: # ALPHABETICAL ORDER IN SOME CASES. ! 3978: # ! 3979: .data 0 ! 3980: #sec # start of constant section ! 3981: # ! 3982: # FREE STORE PERCENTAGE (USED BY ALLOC) ! 3983: # ! 3984: alfsp: .long e$fsp # free store percentage ! 3985: # ! 3986: # BIT CONSTANTS FOR GENERAL USE ! 3987: # ! 3988: bits0: .long 0 # all zero bits ! 3989: bits1: .long 1 # one bit in low order position ! 3990: bits2: .long 2 # bit in position 2 ! 3991: bits3: .long 4 # bit in position 3 ! 3992: bits4: .long 8 # bit in position 4 ! 3993: bits5: .long 16 # bit in position 5 ! 3994: bits6: .long 32 # bit in position 6 ! 3995: bits7: .long 64 # bit in position 7 ! 3996: bits8: .long 128 # bit in position 8 ! 3997: bits9: .long 256 # bit in position 9 ! 3998: bit10: .long 512 # bit in position 10 ! 3999: bitsm: .long cfp$m # mask for max integer ! 4000: # ! 4001: # BIT CONSTANTS FOR SVBLK (SVBIT FIELD) TESTS ! 4002: # ! 4003: btfnc: .long svfnc # bit to test for function ! 4004: btknm: .long svknm # bit to test for keyword number ! 4005: btlbl: .long svlbl # bit to test for label ! 4006: btffc: .long svffc # bit to test for fast call ! 4007: btckw: .long svckw # bit to test for constant keyword ! 4008: btprd: .long svprd # bit to test for predicate function ! 4009: btpre: .long svpre # bit to test for preevaluation ! 4010: btval: .long svval # bit to test for value ! 4011: #page ! 4012: # ! 4013: # LIST OF NAMES USED FOR CONTROL CARD PROCESSING ! 4014: # ! 4015: ccnms: .ascii "CASE" ! 4016: .align 2 ! 4017: .ascii "DOUB" ! 4018: .align 2 ! 4019: .ascii "DUMP" ! 4020: .align 2 ! 4021: .ascii "EJEC" ! 4022: .align 2 ! 4023: .ascii "ERRO" ! 4024: .align 2 ! 4025: .ascii "EXEC" ! 4026: .align 2 ! 4027: .ascii "FAIL" ! 4028: .align 2 ! 4029: .ascii "LIST" ! 4030: .align 2 ! 4031: .ascii "NOER" ! 4032: .align 2 ! 4033: .ascii "NOEX" ! 4034: .align 2 ! 4035: .ascii "NOFA" ! 4036: .align 2 ! 4037: .ascii "NOLI" ! 4038: .align 2 ! 4039: .ascii "NOOP" ! 4040: .align 2 ! 4041: .ascii "NOPR" ! 4042: .align 2 ! 4043: .ascii "OPTI" ! 4044: .align 2 ! 4045: .ascii "PRIN" ! 4046: .align 2 ! 4047: .ascii "SING" ! 4048: .align 2 ! 4049: .ascii "SPAC" ! 4050: .align 2 ! 4051: .ascii "STIT" ! 4052: .align 2 ! 4053: .ascii "TITL" ! 4054: .align 2 ! 4055: .ascii "TRAC" ! 4056: .align 2 ! 4057: # ! 4058: # HEADER MESSAGES FOR DUMPR PROCEDURE (SCBLK FORMAT) ! 4059: # ! 4060: dmhdk: .long b$scl # dump of keyword values ! 4061: .long 22 ! 4062: .ascii "DUMP OF KEYWORD VALUES" ! 4063: .align 2 ! 4064: # ! 4065: dmhdv: .long b$scl # dump of natural variables ! 4066: .long 25 ! 4067: .ascii "DUMP OF NATURAL VARIABLES" ! 4068: .align 2 ! 4069: #page ! 4070: # ! 4071: # MESSAGE TEXT FOR COMPILATION STATISTICS ! 4072: # ! 4073: encm1: .long b$scl ! 4074: .long 10 ! 4075: .ascii "STORE USED" ! 4076: .align 2 ! 4077: # ! 4078: encm2: .long b$scl ! 4079: .long 10 ! 4080: .ascii "STORE LEFT" ! 4081: .align 2 ! 4082: # ! 4083: encm3: .long b$scl ! 4084: .long 11 ! 4085: .ascii "COMP ERRORS" ! 4086: .align 2 ! 4087: # ! 4088: encm4: .long b$scl ! 4089: .long 14 ! 4090: .ascii "COMP TIME-MSEC" ! 4091: .align 2 ! 4092: # ! 4093: encm5: .long b$scl # execution suppressed ! 4094: .long 20 ! 4095: .ascii "EXECUTION SUPPRESSED" ! 4096: .align 2 ! 4097: # ! 4098: # STRING CONSTANT FOR ABNORMAL END ! 4099: # ! 4100: endab: .long b$scl ! 4101: .long 12 ! 4102: .ascii "ABNORMAL END" ! 4103: .align 2 ! 4104: #page ! 4105: # ! 4106: # MEMORY OVERFLOW DURING INITIALISATION ! 4107: # ! 4108: endmo: .long b$scl ! 4109: endml: .long 15 ! 4110: .ascii "MEMORY OVERFLOW" ! 4111: .align 2 ! 4112: # ! 4113: # STRING CONSTANT FOR MESSAGE ISSUED BY L$END ! 4114: # ! 4115: endms: .long b$scl ! 4116: .long 10 ! 4117: .ascii "NORMAL END" ! 4118: .align 2 ! 4119: # ! 4120: # FAIL MESSAGE FOR STACK FAIL SECTION ! 4121: # ! 4122: endso: .long b$scl # stack overflow in garbage collector ! 4123: .long 36 ! 4124: .ascii "STACK OVERFLOW IN GARBAGE COLLECTION" ! 4125: .align 2 ! 4126: # ! 4127: # STRING CONSTANT FOR TIME UP ! 4128: # ! 4129: endtu: .long b$scl ! 4130: .long 15 ! 4131: .ascii "ERROR - TIME UP" ! 4132: .align 2 ! 4133: #page ! 4134: # ! 4135: # STRING CONSTANT FOR ERROR MESSAGE (ERROR SECTION) ! 4136: # ! 4137: ermms: .long b$scl # error ! 4138: .long 5 ! 4139: .ascii "ERROR" ! 4140: .align 2 ! 4141: # ! 4142: ermns: .long b$scl # string / -- / ! 4143: .long 4 ! 4144: .ascii " -- " ! 4145: .align 2 ! 4146: # ! 4147: # STRING CONSTANT FOR PAGE NUMBERING ! 4148: # ! 4149: lstms: .long b$scl # page ! 4150: .long 5 ! 4151: .ascii "PAGE " ! 4152: .align 2 ! 4153: # ! 4154: # LISTING HEADER MESSAGE ! 4155: # ! 4156: headr: .long b$scl ! 4157: .long 25 ! 4158: .ascii "MACRO SPITBOL VERSION 3.5" ! 4159: .align 2 ! 4160: # ! 4161: headv: .long b$scl # for exit() version no. check ! 4162: .long 3 ! 4163: .ascii "3.5" ! 4164: .align 2 ! 4165: # ! 4166: # INTEGER CONSTANTS FOR GENERAL USE ! 4167: # ICBLD OPTIMISATION USES THE FIRST THREE. ! 4168: # ! 4169: int$r: .long b$icl ! 4170: intv0: .long 0 # 0 ! 4171: inton: .long b$icl ! 4172: intv1: .long 1 # 1 ! 4173: inttw: .long b$icl ! 4174: intv2: .long 2 # 2 ! 4175: intvt: .long 10 # 10 ! 4176: intvh: .long 100 # 100 ! 4177: intth: .long 1000 # 1000 ! 4178: # ! 4179: # TABLE USED IN ICBLD OPTIMISATION ! 4180: # ! 4181: intab: .long int$r # pointer to 0 ! 4182: .long inton # pointer to 1 ! 4183: .long inttw # pointer to 2 ! 4184: #page ! 4185: # ! 4186: # SPECIAL PATTERN NODES. THE FOLLOWING PATTERN NODES ! 4187: # CONSIST SIMPLY OF A PCODE POINTER, SEE MATCH ROUTINES ! 4188: # (P$XXX) FOR FULL DETAILS OF THEIR USE AND FORMAT). ! 4189: # ! 4190: ndabb: .long p$abb # arbno ! 4191: ndabd: .long p$abd # arbno ! 4192: ndarc: .long p$arc # arb ! 4193: ndexb: .long p$exb # expression ! 4194: ndfnb: .long p$fnb # fence() ! 4195: ndfnd: .long p$fnd # fence() ! 4196: ndexc: .long p$exc # expression ! 4197: ndimb: .long p$imb # immediate assignment ! 4198: ndimd: .long p$imd # immediate assignment ! 4199: ndnth: .long p$nth # pattern end (null pattern) ! 4200: ndpab: .long p$pab # pattern assignment ! 4201: ndpad: .long p$pad # pattern assignment ! 4202: nduna: .long p$una # anchor point movement ! 4203: # ! 4204: # KEYWORD CONSTANT PATTERN NODES. THE FOLLOWING NODES ARE ! 4205: # USED AS THE VALUES OF PATTERN KEYWORDS AND THE INITIAL ! 4206: # VALUES OF THE CORRESPONDING NATURAL VARIABLES. ALL ! 4207: # NODES ARE IN P0BLK FORMAT AND THE ORDER IS TIED TO THE ! 4208: # DEFINITIONS OF CORRESPONDING K$XXX SYMBOLS. ! 4209: # ! 4210: ndabo: .long p$abo # abort ! 4211: .long ndnth ! 4212: ndarb: .long p$arb # arb ! 4213: .long ndnth ! 4214: ndbal: .long p$bal # bal ! 4215: .long ndnth ! 4216: ndfal: .long p$fal # fail ! 4217: .long ndnth ! 4218: ndfen: .long p$fen # fence ! 4219: .long ndnth ! 4220: ndrem: .long p$rem # rem ! 4221: .long ndnth ! 4222: ndsuc: .long p$suc # succeed ! 4223: .long ndnth ! 4224: # ! 4225: # NULL STRING. ALL NULL VALUES POINT TO THIS STRING. THE ! 4226: # SVCHS FIELD CONTAINS A BLANK TO PROVIDE FOR EASY DEFAULT ! 4227: # PROCESSING IN TRACE, STOPTR, LPAD AND RPAD. ! 4228: # NULLW CONTAINS 10 BLANKS WHICH ENSURES AN ALL BLANK WORD ! 4229: # BUT FOR VERY EXCEPTIONAL MACHINES. ! 4230: # ! 4231: nulls: .long b$scl # null string value ! 4232: .long 0 # sclen = 0 ! 4233: nullw: .ascii " " ! 4234: .align 2 ! 4235: #page ! 4236: # ! 4237: # OPERATOR DOPE VECTORS (SEE DVBLK FORMAT) ! 4238: # ! 4239: opdvc: .long o$cnc # concatenation ! 4240: .long c$cnc ! 4241: .long llcnc ! 4242: .long rrcnc ! 4243: # ! 4244: # OPDVS IS USED WHEN SCANNING BELOW THE TOP LEVEL TO ! 4245: # INSURE THAT THE CONCATENATION WILL NOT BE LATER ! 4246: # MISTAKEN FOR PATTERN MATCHING ! 4247: # ! 4248: opdvp: .long o$cnc # concatenation - not pattern match ! 4249: .long c$cnp ! 4250: .long llcnc ! 4251: .long rrcnc ! 4252: # ! 4253: # NOTE THAT THE ORDER OF THE REMAINING ENTRIES IS TIED TO ! 4254: # THE ORDER OF THE CODING IN THE SCANE PROCEDURE. ! 4255: # ! 4256: opdvs: .long o$ass # assignment ! 4257: .long c$ass ! 4258: .long llass ! 4259: .long rrass ! 4260: # ! 4261: .long 6 # unary equal ! 4262: .long c$uuo ! 4263: .long lluno ! 4264: # ! 4265: .long o$pmv # pattern match ! 4266: .long c$pmt ! 4267: .long llpmt ! 4268: .long rrpmt ! 4269: # ! 4270: .long o$int # interrogation ! 4271: .long c$uvl ! 4272: .long lluno ! 4273: # ! 4274: .long 1 # binary ampersand ! 4275: .long c$ubo ! 4276: .long llamp ! 4277: .long rramp ! 4278: # ! 4279: .long o$kwv # keyword reference ! 4280: .long c$key ! 4281: .long lluno ! 4282: # ! 4283: .long o$alt # alternation ! 4284: .long c$alt ! 4285: .long llalt ! 4286: .long rralt ! 4287: #page ! 4288: # ! 4289: # OPERATOR DOPE VECTORS (CONTINUED) ! 4290: # ! 4291: .long 5 # unary vertical bar ! 4292: .long c$uuo ! 4293: .long lluno ! 4294: # ! 4295: .long 0 # binary at ! 4296: .long c$ubo ! 4297: .long llats ! 4298: .long rrats ! 4299: # ! 4300: .long o$cas # cursor assignment ! 4301: .long c$unm ! 4302: .long lluno ! 4303: # ! 4304: .long 2 # binary number sign ! 4305: .long c$ubo ! 4306: .long llnum ! 4307: .long rrnum ! 4308: # ! 4309: .long 7 # unary number sign ! 4310: .long c$uuo ! 4311: .long lluno ! 4312: # ! 4313: .long o$dvd # division ! 4314: .long c$bvl ! 4315: .long lldvd ! 4316: .long rrdvd ! 4317: # ! 4318: .long 9 # unary slash ! 4319: .long c$uuo ! 4320: .long lluno ! 4321: # ! 4322: .long o$mlt # multiplication ! 4323: .long c$bvl ! 4324: .long llmlt ! 4325: .long rrmlt ! 4326: #page ! 4327: # ! 4328: # OPERATOR DOPE VECTORS (CONTINUED) ! 4329: # ! 4330: .long 0 # deferred expression ! 4331: .long c$def ! 4332: .long lluno ! 4333: # ! 4334: .long 3 # binary percent ! 4335: .long c$ubo ! 4336: .long llpct ! 4337: .long rrpct ! 4338: # ! 4339: .long 8 # unary percent ! 4340: .long c$uuo ! 4341: .long lluno ! 4342: # ! 4343: .long o$exp # exponentiation ! 4344: .long c$bvl ! 4345: .long llexp ! 4346: .long rrexp ! 4347: # ! 4348: .long 10 # unary exclamation ! 4349: .long c$uuo ! 4350: .long lluno ! 4351: # ! 4352: .long o$ima # immediate assignment ! 4353: .long c$bvn ! 4354: .long lldld ! 4355: .long rrdld ! 4356: # ! 4357: .long o$inv # indirection ! 4358: .long c$ind ! 4359: .long lluno ! 4360: # ! 4361: .long 4 # binary not ! 4362: .long c$ubo ! 4363: .long llnot ! 4364: .long rrnot ! 4365: # ! 4366: .long 0 # negation ! 4367: .long c$neg ! 4368: .long lluno ! 4369: #page ! 4370: # ! 4371: # OPERATOR DOPE VECTORS (CONTINUED) ! 4372: # ! 4373: .long o$sub # subtraction ! 4374: .long c$bvl ! 4375: .long llplm ! 4376: .long rrplm ! 4377: # ! 4378: .long o$com # complementation ! 4379: .long c$uvl ! 4380: .long lluno ! 4381: # ! 4382: .long o$add # addition ! 4383: .long c$bvl ! 4384: .long llplm ! 4385: .long rrplm ! 4386: # ! 4387: .long o$aff # affirmation ! 4388: .long c$uvl ! 4389: .long lluno ! 4390: # ! 4391: .long o$pas # pattern assignment ! 4392: .long c$bvn ! 4393: .long lldld ! 4394: .long rrdld ! 4395: # ! 4396: .long o$nam # name reference ! 4397: .long c$unm ! 4398: .long lluno ! 4399: # ! 4400: # SPECIAL DVS FOR GOTO OPERATORS (SEE PROCEDURE SCNGF) ! 4401: # ! 4402: opdvd: .long o$god # direct goto ! 4403: .long c$uvl ! 4404: .long lluno ! 4405: # ! 4406: opdvn: .long o$goc # complex normal goto ! 4407: .long c$unm ! 4408: .long lluno ! 4409: #page ! 4410: # ! 4411: # OPERATOR ENTRY ADDRESS POINTERS, USED IN CODE ! 4412: # ! 4413: oamn$: .long o$amn # array ref (multi-subs by value) ! 4414: oamv$: .long o$amv # array ref (multi-subs by value) ! 4415: oaon$: .long o$aon # array ref (one sub by name) ! 4416: oaov$: .long o$aov # array ref (one sub by value) ! 4417: ocer$: .long o$cer # compilation error ! 4418: ofex$: .long o$fex # failure in expression evaluation ! 4419: ofif$: .long o$fif # failure during goto evaluation ! 4420: ofnc$: .long o$fnc # function call (more than one arg) ! 4421: ofne$: .long o$fne # function name error ! 4422: ofns$: .long o$fns # function call (single argument) ! 4423: ogof$: .long o$gof # set goto failure trap ! 4424: oinn$: .long o$inn # indirection by name ! 4425: okwn$: .long o$kwn # keyword reference by name ! 4426: olex$: .long o$lex # load expression by name ! 4427: olpt$: .long o$lpt # load pattern ! 4428: olvn$: .long o$lvn # load variable name ! 4429: onta$: .long o$nta # negation, first entry ! 4430: ontb$: .long o$ntb # negation, second entry ! 4431: ontc$: .long o$ntc # negation, third entry ! 4432: opmn$: .long o$pmn # pattern match by name ! 4433: opms$: .long o$pms # pattern match (statement) ! 4434: opop$: .long o$pop # pop top stack item ! 4435: ornm$: .long o$rnm # return name from expression ! 4436: orpl$: .long o$rpl # pattern replacement ! 4437: orvl$: .long o$rvl # return value from expression ! 4438: osla$: .long o$sla # selection, first entry ! 4439: oslb$: .long o$slb # selection, second entry ! 4440: oslc$: .long o$slc # selection, third entry ! 4441: osld$: .long o$sld # selection, fourth entry ! 4442: ostp$: .long o$stp # stop execution ! 4443: ounf$: .long o$unf # unexpected failure ! 4444: #page ! 4445: # ! 4446: # TABLE OF NAMES OF UNDEFINED BINARY OPERATORS FOR OPSYN ! 4447: # ! 4448: opsnb: .long ch$at # at ! 4449: .long ch$am # ampersand ! 4450: .long ch$nm # number ! 4451: .long ch$pc # percent ! 4452: .long ch$nt # not ! 4453: # ! 4454: # TABLE OF NAMES OF UNDEFINED UNARY OPERATORS FOR OPSYN ! 4455: # ! 4456: opnsu: .long ch$br # vertical bar ! 4457: .long ch$eq # equal ! 4458: .long ch$nm # number ! 4459: .long ch$pc # percent ! 4460: .long ch$sl # slash ! 4461: .long ch$ex # exclamation ! 4462: # ! 4463: # ADDRESS CONST CONTAINING PROFILE TABLE ENTRY SIZE ! 4464: # ! 4465: pfi2a: .long pf$i2 ! 4466: # ! 4467: # PROFILER MESSAGE STRINGS ! 4468: # ! 4469: pfms1: .long b$scl ! 4470: .long 15 ! 4471: .ascii "PROGRAM PROFILE" ! 4472: .align 2 ! 4473: pfms2: .long b$scl ! 4474: .long 42 ! 4475: .ascii "STMT NUMBER OF -- EXECUTION TIME --" ! 4476: .align 2 ! 4477: pfms3: .long b$scl ! 4478: .long 47 ! 4479: .ascii "NUMBER EXECUTIONS TOTAL(MSEC) PER EXCN(MCSEC)" ! 4480: .align 2 ! 4481: # ! 4482: # ! 4483: # REAL CONSTANTS FOR GENERAL USE. NOTE THAT THE CONSTANTS ! 4484: # STARTING AT REAV1 FORM A POWERS OF TEN TABLE (GTSTG) ! 4485: # ! 4486: reav0: .float 0f0.0 # 0.0 ! 4487: reap1: .float 0f0.1 # 0.1 ! 4488: reap5: .float 0f0.5 # 0.5 ! 4489: reav1: .float 0f1.0 # 10**0 ! 4490: reavt: .float 0f1.0e+1 # 10**1 ! 4491: .float 0f1.0e+2 # 10**2 ! 4492: .float 0f1.0e+3 # 10**3 ! 4493: .float 0f1.0e+4 # 10**4 ! 4494: .float 0f1.0e+5 # 10**5 ! 4495: .float 0f1.0e+6 # 10**6 ! 4496: .float 0f1.0e+7 # 10**7 ! 4497: .float 0f1.0e+8 # 10**8 ! 4498: .float 0f1.0e+9 # 10**9 ! 4499: reatt: .float 0f1.0e+10 # 10**10 ! 4500: #page ! 4501: # ! 4502: # STRING CONSTANTS (SCBLK FORMAT) FOR DTYPE PROCEDURE ! 4503: # ! 4504: scarr: .long b$scl # array ! 4505: .long 5 ! 4506: .ascii "ARRAY" ! 4507: .align 2 ! 4508: # ! 4509: scbuf: .long b$scl # buffer ! 4510: .long 6 ! 4511: .ascii "BUFFER" ! 4512: .align 2 ! 4513: # ! 4514: sccod: .long b$scl # code ! 4515: .long 4 ! 4516: .ascii "CODE" ! 4517: .align 2 ! 4518: # ! 4519: scexp: .long b$scl # expression ! 4520: .long 10 ! 4521: .ascii "EXPRESSION" ! 4522: .align 2 ! 4523: # ! 4524: scext: .long b$scl # external ! 4525: .long 8 ! 4526: .ascii "EXTERNAL" ! 4527: .align 2 ! 4528: # ! 4529: scint: .long b$scl # integer ! 4530: .long 7 ! 4531: .ascii "INTEGER" ! 4532: .align 2 ! 4533: # ! 4534: scnam: .long b$scl # name ! 4535: .long 4 ! 4536: .ascii "NAME" ! 4537: .align 2 ! 4538: # ! 4539: scnum: .long b$scl # numeric ! 4540: .long 7 ! 4541: .ascii "NUMERIC" ! 4542: .align 2 ! 4543: # ! 4544: scpat: .long b$scl # pattern ! 4545: .long 7 ! 4546: .ascii "PATTERN" ! 4547: .align 2 ! 4548: # ! 4549: screa: .long b$scl # real ! 4550: .long 4 ! 4551: .ascii "REAL" ! 4552: .align 2 ! 4553: # ! 4554: scstr: .long b$scl # string ! 4555: .long 6 ! 4556: .ascii "STRING" ! 4557: .align 2 ! 4558: # ! 4559: sctab: .long b$scl # table ! 4560: .long 5 ! 4561: .ascii "TABLE" ! 4562: .align 2 ! 4563: #page ! 4564: # ! 4565: # STRING CONSTANTS (SCBLK FORMAT) FOR KVRTN (SEE RETRN) ! 4566: # ! 4567: scfrt: .long b$scl # freturn ! 4568: .long 7 ! 4569: .ascii "FRETURN" ! 4570: .align 2 ! 4571: # ! 4572: scnrt: .long b$scl # nreturn ! 4573: .long 7 ! 4574: .ascii "NRETURN" ! 4575: .align 2 ! 4576: # ! 4577: scrtn: .long b$scl # return ! 4578: .long 6 ! 4579: .ascii "RETURN" ! 4580: .align 2 ! 4581: # ! 4582: # DATATYPE NAME TABLE FOR DTYPE PROCEDURE. THE ORDER OF ! 4583: # THESE ENTRIES IS TIED TO THE B$XXX DEFINITIONS FOR BLOCKS ! 4584: # ! 4585: scnmt: .long scarr # arblk array ! 4586: .long scbuf # bfblk buffer ! 4587: .long sccod # cdblk code ! 4588: .long scexp # exblk expression ! 4589: .long scint # icblk integer ! 4590: .long scnam # nmblk name ! 4591: .long scpat # p0blk pattern ! 4592: .long scpat # p1blk pattern ! 4593: .long scpat # p2blk pattern ! 4594: .long screa # rcblk real ! 4595: .long scstr # scblk string ! 4596: .long scexp # seblk expression ! 4597: .long sctab # tbblk table ! 4598: .long scarr # vcblk array ! 4599: .long scext # xnblk external ! 4600: .long scext # xrblk external ! 4601: # ! 4602: # STRING CONSTANT FOR REAL ZERO ! 4603: # ! 4604: scre0: .long b$scl ! 4605: .long 2 ! 4606: .ascii "0." ! 4607: .align 2 ! 4608: #page ! 4609: # ! 4610: # USED TO RE-INITIALISE KVSTL ! 4611: # ! 4612: stlim: .long 50000 # default statement limit ! 4613: # ! 4614: # DUMMY FUNCTION BLOCK USED FOR UNDEFINED FUNCTIONS ! 4615: # ! 4616: stndf: .long o$fun # ptr to undefined function err call ! 4617: .long 0 # dummy fargs count for call circuit ! 4618: # ! 4619: # DUMMY CODE BLOCK USED FOR UNDEFINED LABELS ! 4620: # ! 4621: stndl: .long l$und # code ptr points to undefined lbl ! 4622: # ! 4623: # DUMMY OPERATOR BLOCK USED FOR UNDEFINED OPERATORS ! 4624: # ! 4625: stndo: .long o$oun # ptr to undefined operator err call ! 4626: .long 0 # dummy fargs count for call circuit ! 4627: # ! 4628: # STANDARD VARIABLE BLOCK. THIS BLOCK IS USED TO INITIALIZE ! 4629: # THE FIRST SEVEN FIELDS OF A NEWLY CONSTRUCTED VRBLK. ! 4630: # ITS FORMAT IS TIED TO THE VRBLK DEFINITIONS (SEE GTNVR). ! 4631: # ! 4632: stnvr: .long b$vrl # vrget ! 4633: .long b$vrs # vrsto ! 4634: .long nulls # vrval ! 4635: .long b$vrg # vrtra ! 4636: .long stndl # vrlbl ! 4637: .long stndf # vrfnc ! 4638: .long 0 # vrnxt ! 4639: #page ! 4640: # ! 4641: # MESSAGES USED IN END OF RUN PROCESSING (STOPR) ! 4642: # ! 4643: stpm1: .long b$scl # in statement ! 4644: .long 12 ! 4645: .ascii "IN STATEMENT" ! 4646: .align 2 ! 4647: # ! 4648: stpm2: .long b$scl ! 4649: .long 14 ! 4650: .ascii "STMTS EXECUTED" ! 4651: .align 2 ! 4652: # ! 4653: stpm3: .long b$scl ! 4654: .long 13 ! 4655: .ascii "RUN TIME-MSEC" ! 4656: .align 2 ! 4657: # ! 4658: stpm4: .long b$scl ! 4659: .long 12 ! 4660: .ascii "MCSEC / STMT" ! 4661: .align 2 ! 4662: # ! 4663: stpm5: .long b$scl ! 4664: .long 13 ! 4665: .ascii "REGENERATIONS" ! 4666: .align 2 ! 4667: # ! 4668: # CHARS FOR /TU/ ENDING CODE ! 4669: # ! 4670: strtu: .ascii "TU" ! 4671: .align 2 ! 4672: # ! 4673: # TABLE USED BY CONVERT FUNCTION TO CHECK DATATYPE NAME ! 4674: # THE ENTRIES ARE ORDERED TO CORRESPOND TO BRANCH TABLE ! 4675: # IN S$CNV ! 4676: # ! 4677: svctb: .long scstr # string ! 4678: .long scint # integer ! 4679: .long scnam # name ! 4680: .long scpat # pattern ! 4681: .long scarr # array ! 4682: .long sctab # table ! 4683: .long scexp # expression ! 4684: .long sccod # code ! 4685: .long scnum # numeric ! 4686: .long screa # real ! 4687: .long scbuf # buffer ! 4688: .long 0 # zero marks end of list ! 4689: #page ! 4690: # ! 4691: # MESSAGES (SCBLK FORMAT) USED BY TRACE PROCEDURES ! 4692: # ! 4693: # ! 4694: tmasb: .long b$scl # asterisks for trace statement no ! 4695: .long 13 ! 4696: .ascii "************ " ! 4697: .align 2 ! 4698: # ! 4699: tmbeb: .long b$scl # blank-equal-blank ! 4700: .long 3 ! 4701: .ascii " = " ! 4702: .align 2 ! 4703: # ! 4704: # DUMMY TRBLK FOR EXPRESSION VARIABLE ! 4705: # ! 4706: trbev: .long b$trt # dummy trblk ! 4707: # ! 4708: # DUMMY TRBLK FOR KEYWORD VARIABLE ! 4709: # ! 4710: trbkv: .long b$trt # dummy trblk ! 4711: # ! 4712: # DUMMY CODE BLOCK TO RETURN CONTROL TO TRXEQ PROCEDURE ! 4713: # ! 4714: trxdr: .long o$txr # block points to return routine ! 4715: trxdc: .long trxdr # pointer to block ! 4716: #page ! 4717: # ! 4718: # STANDARD VARIABLE BLOCKS ! 4719: # ! 4720: # SEE SVBLK FORMAT FOR FULL DETAILS OF THE FORMAT. THE ! 4721: # VRBLKS ARE ORDERED BY LENGTH AND WITHIN EACH LENGTH THE ! 4722: # ORDER IS ALPHABETICAL BY NAME OF THE VARIABLE. ! 4723: # ! 4724: v$eqf: .long svfpr # eq ! 4725: .long 2 ! 4726: .ascii "EQ" ! 4727: .align 2 ! 4728: .long s$eqf ! 4729: .long 2 ! 4730: # ! 4731: v$gef: .long svfpr # ge ! 4732: .long 2 ! 4733: .ascii "GE" ! 4734: .align 2 ! 4735: .long s$gef ! 4736: .long 2 ! 4737: # ! 4738: v$gtf: .long svfpr # gt ! 4739: .long 2 ! 4740: .ascii "GT" ! 4741: .align 2 ! 4742: .long s$gtf ! 4743: .long 2 ! 4744: # ! 4745: v$lef: .long svfpr # le ! 4746: .long 2 ! 4747: .ascii "LE" ! 4748: .align 2 ! 4749: .long s$lef ! 4750: .long 2 ! 4751: # ! 4752: v$ltf: .long svfpr # lt ! 4753: .long 2 ! 4754: .ascii "LT" ! 4755: .align 2 ! 4756: .long s$ltf ! 4757: .long 2 ! 4758: # ! 4759: v$nef: .long svfpr # ne ! 4760: .long 2 ! 4761: .ascii "NE" ! 4762: .align 2 ! 4763: .long s$nef ! 4764: .long 2 ! 4765: # ! 4766: v$any: .long svfnp # any ! 4767: .long 3 ! 4768: .ascii "ANY" ! 4769: .align 2 ! 4770: .long s$any ! 4771: .long 1 ! 4772: # ! 4773: v$arb: .long svkvc # arb ! 4774: .long 3 ! 4775: .ascii "ARB" ! 4776: .align 2 ! 4777: .long k$arb ! 4778: .long ndarb ! 4779: #page ! 4780: # ! 4781: # STANDARD VARIABLE BLOCKS (CONTINUED) ! 4782: # ! 4783: v$arg: .long svfnn # arg ! 4784: .long 3 ! 4785: .ascii "ARG" ! 4786: .align 2 ! 4787: .long s$arg ! 4788: .long 2 ! 4789: # ! 4790: v$bal: .long svkvc # bal ! 4791: .long 3 ! 4792: .ascii "BAL" ! 4793: .align 2 ! 4794: .long k$bal ! 4795: .long ndbal ! 4796: # ! 4797: v$end: .long svlbl # end ! 4798: .long 3 ! 4799: .ascii "END" ! 4800: .align 2 ! 4801: .long l$end ! 4802: # ! 4803: v$len: .long svfnp # len ! 4804: .long 3 ! 4805: .ascii "LEN" ! 4806: .align 2 ! 4807: .long s$len ! 4808: .long 1 ! 4809: # ! 4810: v$leq: .long svfpr # leq ! 4811: .long 3 ! 4812: .ascii "LEQ" ! 4813: .align 2 ! 4814: .long s$leq ! 4815: .long 2 ! 4816: # ! 4817: v$lge: .long svfpr # lge ! 4818: .long 3 ! 4819: .ascii "LGE" ! 4820: .align 2 ! 4821: .long s$lge ! 4822: .long 2 ! 4823: # ! 4824: v$lgt: .long svfpr # lgt ! 4825: .long 3 ! 4826: .ascii "LGT" ! 4827: .align 2 ! 4828: .long s$lgt ! 4829: .long 2 ! 4830: # ! 4831: v$lle: .long svfpr # lle ! 4832: .long 3 ! 4833: .ascii "LLE" ! 4834: .align 2 ! 4835: .long s$lle ! 4836: .long 2 ! 4837: #page ! 4838: # ! 4839: # STANDARD VARIABLE BLOCKS (CONTINUED) ! 4840: # ! 4841: v$llt: .long svfpr # llt ! 4842: .long 3 ! 4843: .ascii "LLT" ! 4844: .align 2 ! 4845: .long s$llt ! 4846: .long 2 ! 4847: # ! 4848: v$lne: .long svfpr # lne ! 4849: .long 3 ! 4850: .ascii "LNE" ! 4851: .align 2 ! 4852: .long s$lne ! 4853: .long 2 ! 4854: # ! 4855: v$pos: .long svfnp # pos ! 4856: .long 3 ! 4857: .ascii "POS" ! 4858: .align 2 ! 4859: .long s$pos ! 4860: .long 1 ! 4861: # ! 4862: v$rem: .long svkvc # rem ! 4863: .long 3 ! 4864: .ascii "REM" ! 4865: .align 2 ! 4866: .long k$rem ! 4867: .long ndrem ! 4868: # ! 4869: v$set: .long svfnn # set ! 4870: .long 3 ! 4871: .ascii "SET" ! 4872: .align 2 ! 4873: .long s$set ! 4874: .long 3 ! 4875: # ! 4876: v$tab: .long svfnp # tab ! 4877: .long 3 ! 4878: .ascii "TAB" ! 4879: .align 2 ! 4880: .long s$tab ! 4881: .long 1 ! 4882: # ! 4883: v$cas: .long svknm # case ! 4884: .long 4 ! 4885: .ascii "CASE" ! 4886: .align 2 ! 4887: .long k$cas ! 4888: # ! 4889: v$chr: .long svfnp # char ! 4890: .long 4 ! 4891: .ascii "CHAR" ! 4892: .align 2 ! 4893: .long s$chr ! 4894: .long 1 ! 4895: # ! 4896: v$cod: .long svfnk # code ! 4897: .long 4 ! 4898: .ascii "CODE" ! 4899: .align 2 ! 4900: .long k$cod ! 4901: .long s$cod ! 4902: .long 1 ! 4903: # ! 4904: v$cop: .long svfnn # copy ! 4905: .long 4 ! 4906: .ascii "COPY" ! 4907: .align 2 ! 4908: .long s$cop ! 4909: .long 1 ! 4910: #page ! 4911: # ! 4912: # STANDARD VARIABLE BLOCKS (CONTINUED) ! 4913: # ! 4914: v$dat: .long svfnn # data ! 4915: .long 4 ! 4916: .ascii "DATA" ! 4917: .align 2 ! 4918: .long s$dat ! 4919: .long 1 ! 4920: # ! 4921: v$dte: .long svfnn # date ! 4922: .long 4 ! 4923: .ascii "DATE" ! 4924: .align 2 ! 4925: .long s$dte ! 4926: .long 0 ! 4927: # ! 4928: v$dmp: .long svfnk # dump ! 4929: .long 4 ! 4930: .ascii "DUMP" ! 4931: .align 2 ! 4932: .long k$dmp ! 4933: .long s$dmp ! 4934: .long 1 ! 4935: # ! 4936: v$dup: .long svfnn # dupl ! 4937: .long 4 ! 4938: .ascii "DUPL" ! 4939: .align 2 ! 4940: .long s$dup ! 4941: .long 2 ! 4942: # ! 4943: v$evl: .long svfnn # eval ! 4944: .long 4 ! 4945: .ascii "EVAL" ! 4946: .align 2 ! 4947: .long s$evl ! 4948: .long 1 ! 4949: # ! 4950: v$ext: .long svfnn # exit ! 4951: .long 4 ! 4952: .ascii "EXIT" ! 4953: .align 2 ! 4954: .long s$ext ! 4955: .long 1 ! 4956: # ! 4957: v$fal: .long svkvc # fail ! 4958: .long 4 ! 4959: .ascii "FAIL" ! 4960: .align 2 ! 4961: .long k$fal ! 4962: .long ndfal ! 4963: # ! 4964: v$hst: .long svfnn # host ! 4965: .long 4 ! 4966: .ascii "HOST" ! 4967: .align 2 ! 4968: .long s$hst ! 4969: .long 3 ! 4970: #page ! 4971: # ! 4972: # STANDARD VARIABLE BLOCKS (CONTINUED) ! 4973: # ! 4974: v$itm: .long svfnf # item ! 4975: .long 4 ! 4976: .ascii "ITEM" ! 4977: .align 2 ! 4978: .long s$itm ! 4979: .long 999 ! 4980: # ! 4981: v$lod: .long svfnn # load ! 4982: .long 4 ! 4983: .ascii "LOAD" ! 4984: .align 2 ! 4985: .long s$lod ! 4986: .long 2 ! 4987: # ! 4988: v$lpd: .long svfnp # lpad ! 4989: .long 4 ! 4990: .ascii "LPAD" ! 4991: .align 2 ! 4992: .long s$lpd ! 4993: .long 3 ! 4994: # ! 4995: v$rpd: .long svfnp # rpad ! 4996: .long 4 ! 4997: .ascii "RPAD" ! 4998: .align 2 ! 4999: .long s$rpd ! 5000: .long 3 ! 5001: # ! 5002: v$rps: .long svfnp # rpos ! 5003: .long 4 ! 5004: .ascii "RPOS" ! 5005: .align 2 ! 5006: .long s$rps ! 5007: .long 1 ! 5008: # ! 5009: v$rtb: .long svfnp # rtab ! 5010: .long 4 ! 5011: .ascii "RTAB" ! 5012: .align 2 ! 5013: .long s$rtb ! 5014: .long 1 ! 5015: # ! 5016: v$si$: .long svfnp # size ! 5017: .long 4 ! 5018: .ascii "SIZE" ! 5019: .align 2 ! 5020: .long s$si$ ! 5021: .long 1 ! 5022: # ! 5023: # ! 5024: v$srt: .long svfnn # sort ! 5025: .long 4 ! 5026: .ascii "SORT" ! 5027: .align 2 ! 5028: .long s$srt ! 5029: .long 2 ! 5030: v$spn: .long svfnp # span ! 5031: .long 4 ! 5032: .ascii "SPAN" ! 5033: .align 2 ! 5034: .long s$spn ! 5035: .long 1 ! 5036: #page ! 5037: # ! 5038: # STANDARD VARIABLE BLOCKS (CONTINUED) ! 5039: # ! 5040: v$stn: .long svknm # stno ! 5041: .long 4 ! 5042: .ascii "STNO" ! 5043: .align 2 ! 5044: .long k$stn ! 5045: # ! 5046: v$tim: .long svfnn # time ! 5047: .long 4 ! 5048: .ascii "TIME" ! 5049: .align 2 ! 5050: .long s$tim ! 5051: .long 0 ! 5052: # ! 5053: v$trm: .long svfnk # trim ! 5054: .long 4 ! 5055: .ascii "TRIM" ! 5056: .align 2 ! 5057: .long k$trm ! 5058: .long s$trm ! 5059: .long 1 ! 5060: # ! 5061: v$abe: .long svknm # abend ! 5062: .long 5 ! 5063: .ascii "ABEND" ! 5064: .align 2 ! 5065: .long k$abe ! 5066: # ! 5067: v$abo: .long svkvl # abort ! 5068: .long 5 ! 5069: .ascii "ABORT" ! 5070: .align 2 ! 5071: .long k$abo ! 5072: .long l$abo ! 5073: .long ndabo ! 5074: # ! 5075: v$app: .long svfnf # apply ! 5076: .long 5 ! 5077: .ascii "APPLY" ! 5078: .align 2 ! 5079: .long s$app ! 5080: .long 999 ! 5081: # ! 5082: v$abn: .long svfnp # arbno ! 5083: .long 5 ! 5084: .ascii "ARBNO" ! 5085: .align 2 ! 5086: .long s$abn ! 5087: .long 1 ! 5088: # ! 5089: v$arr: .long svfnn # array ! 5090: .long 5 ! 5091: .ascii "ARRAY" ! 5092: .align 2 ! 5093: .long s$arr ! 5094: .long 2 ! 5095: #page ! 5096: # ! 5097: # STANDARD VARIABLE BLOCKS (CONTINUED) ! 5098: # ! 5099: v$brk: .long svfnp # break ! 5100: .long 5 ! 5101: .ascii "BREAK" ! 5102: .align 2 ! 5103: .long s$brk ! 5104: .long 1 ! 5105: # ! 5106: v$clr: .long svfnn # clear ! 5107: .long 5 ! 5108: .ascii "CLEAR" ! 5109: .align 2 ! 5110: .long s$clr ! 5111: .long 1 ! 5112: # ! 5113: v$ejc: .long svfnn # eject ! 5114: .long 5 ! 5115: .ascii "EJECT" ! 5116: .align 2 ! 5117: .long s$ejc ! 5118: .long 1 ! 5119: # ! 5120: v$fen: .long svfpk # fence ! 5121: .long 5 ! 5122: .ascii "FENCE" ! 5123: .align 2 ! 5124: .long k$fen ! 5125: .long s$fnc ! 5126: .long 1 ! 5127: .long ndfen ! 5128: # ! 5129: v$fld: .long svfnn # field ! 5130: .long 5 ! 5131: .ascii "FIELD" ! 5132: .align 2 ! 5133: .long s$fld ! 5134: .long 2 ! 5135: # ! 5136: v$idn: .long svfpr # ident ! 5137: .long 5 ! 5138: .ascii "IDENT" ! 5139: .align 2 ! 5140: .long s$idn ! 5141: .long 2 ! 5142: # ! 5143: v$inp: .long svfnk # input ! 5144: .long 5 ! 5145: .ascii "INPUT" ! 5146: .align 2 ! 5147: .long k$inp ! 5148: .long s$inp ! 5149: .long 3 ! 5150: # ! 5151: v$loc: .long svfnn # local ! 5152: .long 5 ! 5153: .ascii "LOCAL" ! 5154: .align 2 ! 5155: .long s$loc ! 5156: .long 2 ! 5157: #page ! 5158: # ! 5159: # STANDARD VARIABLE BLOCKS (CONTINUED) ! 5160: # ! 5161: v$ops: .long svfnn # opsyn ! 5162: .long 5 ! 5163: .ascii "OPSYN" ! 5164: .align 2 ! 5165: .long s$ops ! 5166: .long 3 ! 5167: # ! 5168: v$rmd: .long svfnp # remdr ! 5169: .long 5 ! 5170: .ascii "REMDR" ! 5171: .align 2 ! 5172: .long s$rmd ! 5173: .long 2 ! 5174: # ! 5175: v$rsr: .long svfnn # rsort ! 5176: .long 5 ! 5177: .ascii "RSORT" ! 5178: .align 2 ! 5179: .long s$rsr ! 5180: .long 2 ! 5181: # ! 5182: v$tbl: .long svfnn # table ! 5183: .long 5 ! 5184: .ascii "TABLE" ! 5185: .align 2 ! 5186: .long s$tbl ! 5187: .long 3 ! 5188: # ! 5189: v$tra: .long svfnk # trace ! 5190: .long 5 ! 5191: .ascii "TRACE" ! 5192: .align 2 ! 5193: .long k$tra ! 5194: .long s$tra ! 5195: .long 4 ! 5196: # ! 5197: v$anc: .long svknm # anchor ! 5198: .long 6 ! 5199: .ascii "ANCHOR" ! 5200: .align 2 ! 5201: .long k$anc ! 5202: # ! 5203: v$apn: .long svfnn ! 5204: .long 6 ! 5205: .ascii "APPEND" ! 5206: .align 2 ! 5207: .long s$apn ! 5208: .long 2 ! 5209: # ! 5210: v$bkx: .long svfnp # breakx ! 5211: .long 6 ! 5212: .ascii "BREAKX" ! 5213: .align 2 ! 5214: .long s$bkx ! 5215: .long 1 ! 5216: # ! 5217: v$buf: .long svfnn # buffer ! 5218: .long 6 ! 5219: .ascii "BUFFER" ! 5220: .align 2 ! 5221: .long s$buf ! 5222: .long 2 ! 5223: # ! 5224: v$def: .long svfnn # define ! 5225: .long 6 ! 5226: .ascii "DEFINE" ! 5227: .align 2 ! 5228: .long s$def ! 5229: .long 2 ! 5230: # ! 5231: v$det: .long svfnn # detach ! 5232: .long 6 ! 5233: .ascii "DETACH" ! 5234: .align 2 ! 5235: .long s$det ! 5236: .long 1 ! 5237: #page ! 5238: # ! 5239: # STANDARD VARIABLE BLOCKS (CONTINUED) ! 5240: # ! 5241: v$dif: .long svfpr # differ ! 5242: .long 6 ! 5243: .ascii "DIFFER" ! 5244: .align 2 ! 5245: .long s$dif ! 5246: .long 2 ! 5247: # ! 5248: v$ftr: .long svknm # ftrace ! 5249: .long 6 ! 5250: .ascii "FTRACE" ! 5251: .align 2 ! 5252: .long k$ftr ! 5253: # ! 5254: v$ins: .long svfnn # insert ! 5255: .long 6 ! 5256: .ascii "INSERT" ! 5257: .align 2 ! 5258: .long s$ins ! 5259: .long 4 ! 5260: # ! 5261: v$lst: .long svknm # lastno ! 5262: .long 6 ! 5263: .ascii "LASTNO" ! 5264: .align 2 ! 5265: .long k$lst ! 5266: # ! 5267: v$nay: .long svfnp # notany ! 5268: .long 6 ! 5269: .ascii "NOTANY" ! 5270: .align 2 ! 5271: .long s$nay ! 5272: .long 1 ! 5273: # ! 5274: v$oup: .long svfnk # output ! 5275: .long 6 ! 5276: .ascii "OUTPUT" ! 5277: .align 2 ! 5278: .long k$oup ! 5279: .long s$oup ! 5280: .long 3 ! 5281: # ! 5282: v$ret: .long svlbl # return ! 5283: .long 6 ! 5284: .ascii "RETURN" ! 5285: .align 2 ! 5286: .long l$rtn ! 5287: # ! 5288: v$rew: .long svfnn # rewind ! 5289: .long 6 ! 5290: .ascii "REWIND" ! 5291: .align 2 ! 5292: .long s$rew ! 5293: .long 1 ! 5294: # ! 5295: v$stt: .long svfnn # stoptr ! 5296: .long 6 ! 5297: .ascii "STOPTR" ! 5298: .align 2 ! 5299: .long s$stt ! 5300: .long 2 ! 5301: #page ! 5302: # ! 5303: # STANDARD VARIABLE BLOCKS (CONTINUED) ! 5304: # ! 5305: v$sub: .long svfnn # substr ! 5306: .long 6 ! 5307: .ascii "SUBSTR" ! 5308: .align 2 ! 5309: .long s$sub ! 5310: .long 3 ! 5311: # ! 5312: v$unl: .long svfnn # unload ! 5313: .long 6 ! 5314: .ascii "UNLOAD" ! 5315: .align 2 ! 5316: .long s$unl ! 5317: .long 1 ! 5318: # ! 5319: v$col: .long svfnn # collect ! 5320: .long 7 ! 5321: .ascii "COLLECT" ! 5322: .align 2 ! 5323: .long s$col ! 5324: .long 1 ! 5325: # ! 5326: v$cnv: .long svfnn # convert ! 5327: .long 7 ! 5328: .ascii "CONVERT" ! 5329: .align 2 ! 5330: .long s$cnv ! 5331: .long 2 ! 5332: # ! 5333: v$enf: .long svfnn # endfile ! 5334: .long 7 ! 5335: .ascii "ENDFILE" ! 5336: .align 2 ! 5337: .long s$enf ! 5338: .long 1 ! 5339: # ! 5340: v$etx: .long svknm # errtext ! 5341: .long 7 ! 5342: .ascii "ERRTEXT" ! 5343: .align 2 ! 5344: .long k$etx ! 5345: # ! 5346: v$ert: .long svknm # errtype ! 5347: .long 7 ! 5348: .ascii "ERRTYPE" ! 5349: .align 2 ! 5350: .long k$ert ! 5351: # ! 5352: v$frt: .long svlbl # freturn ! 5353: .long 7 ! 5354: .ascii "FRETURN" ! 5355: .align 2 ! 5356: .long l$frt ! 5357: # ! 5358: v$int: .long svfpr # integer ! 5359: .long 7 ! 5360: .ascii "INTEGER" ! 5361: .align 2 ! 5362: .long s$int ! 5363: .long 1 ! 5364: # ! 5365: v$nrt: .long svlbl # nreturn ! 5366: .long 7 ! 5367: .ascii "NRETURN" ! 5368: .align 2 ! 5369: .long l$nrt ! 5370: #page ! 5371: # ! 5372: # STANDARD VARIABLE BLOCKS (CONTINUED) ! 5373: # ! 5374: # ! 5375: v$pfl: .long svknm # profile ! 5376: .long 7 ! 5377: .ascii "PROFILE" ! 5378: .align 2 ! 5379: .long k$pfl ! 5380: # ! 5381: v$rpl: .long svfnp # replace ! 5382: .long 7 ! 5383: .ascii "REPLACE" ! 5384: .align 2 ! 5385: .long s$rpl ! 5386: .long 3 ! 5387: # ! 5388: v$rvs: .long svfnp # reverse ! 5389: .long 7 ! 5390: .ascii "REVERSE" ! 5391: .align 2 ! 5392: .long s$rvs ! 5393: .long 1 ! 5394: # ! 5395: v$rtn: .long svknm # rtntype ! 5396: .long 7 ! 5397: .ascii "RTNTYPE" ! 5398: .align 2 ! 5399: .long k$rtn ! 5400: # ! 5401: v$stx: .long svfnn # setexit ! 5402: .long 7 ! 5403: .ascii "SETEXIT" ! 5404: .align 2 ! 5405: .long s$stx ! 5406: .long 1 ! 5407: # ! 5408: v$stc: .long svknm # stcount ! 5409: .long 7 ! 5410: .ascii "STCOUNT" ! 5411: .align 2 ! 5412: .long k$stc ! 5413: # ! 5414: v$stl: .long svknm # stlimit ! 5415: .long 7 ! 5416: .ascii "STLIMIT" ! 5417: .align 2 ! 5418: .long k$stl ! 5419: # ! 5420: v$suc: .long svkvc # succeed ! 5421: .long 7 ! 5422: .ascii "SUCCEED" ! 5423: .align 2 ! 5424: .long k$suc ! 5425: .long ndsuc ! 5426: # ! 5427: v$alp: .long svkwc # alphabet ! 5428: .long 8 ! 5429: .ascii "ALPHABET" ! 5430: .align 2 ! 5431: .long k$alp ! 5432: # ! 5433: v$cnt: .long svlbl # continue ! 5434: .long 8 ! 5435: .ascii "CONTINUE" ! 5436: .align 2 ! 5437: .long l$cnt ! 5438: #page ! 5439: # ! 5440: # STANDARD VARIABLE BLOCKS (CONTINUED) ! 5441: # ! 5442: v$dtp: .long svfnp # datatype ! 5443: .long 8 ! 5444: .ascii "DATATYPE" ! 5445: .align 2 ! 5446: .long s$dtp ! 5447: .long 1 ! 5448: # ! 5449: v$erl: .long svknm # errlimit ! 5450: .long 8 ! 5451: .ascii "ERRLIMIT" ! 5452: .align 2 ! 5453: .long k$erl ! 5454: # ! 5455: v$fnc: .long svknm # fnclevel ! 5456: .long 8 ! 5457: .ascii "FNCLEVEL" ! 5458: .align 2 ! 5459: .long k$fnc ! 5460: # ! 5461: v$mxl: .long svknm # maxlngth ! 5462: .long 8 ! 5463: .ascii "MAXLNGTH" ! 5464: .align 2 ! 5465: .long k$mxl ! 5466: # ! 5467: v$ter: .long 0 # terminal ! 5468: .long 8 ! 5469: .ascii "TERMINAL" ! 5470: .align 2 ! 5471: .long 0 ! 5472: # ! 5473: v$pro: .long svfnn # prototype ! 5474: .long 9 ! 5475: .ascii "PROTOTYPE" ! 5476: .align 2 ! 5477: .long s$pro ! 5478: .long 1 ! 5479: # ! 5480: .long 0 # dummy entry to end list ! 5481: .long 10 # length gt 9 (prototype) ! 5482: #page ! 5483: # ! 5484: # LIST OF SVBLK POINTERS FOR KEYWORDS TO BE DUMPED. THE ! 5485: # LIST IS IN THE ORDER WHICH APPEARS ON THE DUMP OUTPUT. ! 5486: # ! 5487: vdmkw: .long v$anc # anchor ! 5488: .long v$cas # ccase ! 5489: .long v$cod # code ! 5490: .long v$dmp # dump ! 5491: .long v$erl # errlimit ! 5492: .long v$etx # errtext ! 5493: .long v$ert # errtype ! 5494: .long v$fnc # fnclevel ! 5495: .long v$ftr # ftrace ! 5496: .long v$inp # input ! 5497: .long v$lst # lastno ! 5498: .long v$mxl # maxlength ! 5499: .long v$oup # output ! 5500: .long v$pfl # profile ! 5501: .long v$rtn # rtntype ! 5502: .long v$stc # stcount ! 5503: .long v$stl # stlimit ! 5504: .long v$stn # stno ! 5505: .long v$tra # trace ! 5506: .long v$trm # trim ! 5507: .long 0 # end of list ! 5508: # ! 5509: # TABLE USED BY GTNVR TO SEARCH SVBLK LISTS ! 5510: # ! 5511: vsrch: .long 0 # dummy entry to get proper indexing ! 5512: .long v$eqf # start of 1 char variables (none) ! 5513: .long v$eqf # start of 2 char variables ! 5514: .long v$any # start of 3 char variables ! 5515: .long v$cas # start of 4 char variables ! 5516: .long v$abe # start of 5 char variables ! 5517: .long v$anc # start of 6 char variables ! 5518: .long v$col # start of 7 char variables ! 5519: .long v$alp # start of 8 char variables ! 5520: .long v$pro # start of 9 char variables ! 5521: #title s p i t b o l -- working storage section ! 5522: # ! 5523: # THE WORKING STORAGE SECTION CONTAINS AREAS WHICH ARE ! 5524: # CHANGED DURING EXECUTION OF THE PROGRAM. THE VALUE ! 5525: # ASSEMBLED IS THE INITIAL VALUE BEFORE EXECUTION STARTS. ! 5526: # ! 5527: # ALL THESE AREAS ARE FIXED LENGTH AREAS. VARIABLE LENGTH ! 5528: # DATA IS STORED IN THE STATIC OR DYNAMIC REGIONS OF THE ! 5529: # ALLOCATED DATA AREAS. ! 5530: # ! 5531: # THE VALUES IN THIS AREA ARE DESCRIBED EITHER AS WORK ! 5532: # AREAS OR AS GLOBAL VALUES. A WORK AREA IS USED IN AN ! 5533: # EPHEMERAL MANNER AND THE VALUE IS NOT SAVED FROM ONE ! 5534: # ENTRY INTO A ROUTINE TO ANOTHER. A GLOBAL VALUE IS A ! 5535: # LESS TEMPORARY LOCATION WHOSE VALUE IS SAVED FROM ONE ! 5536: # CALL TO ANOTHER. ! 5537: # ! 5538: # A GENERAL PART OF THE APPROACH IN THIS PROGRAM IS NOT ! 5539: # TO OVERLAP WORK AREAS BETWEEN PROCEDURES EVEN THOUGH A ! 5540: # SMALL AMOUNT OF SPACE COULD BE SAVED. SUCH OVERLAP IS ! 5541: # CONSIDERED A SOURCE OF PROGRAM ERRORS AND DECREASES THE ! 5542: # INFORMATION LEFT BEHIND AFTER A SYSTEM CRASH OF ANY KIND. ! 5543: # ! 5544: # THE NAMES OF THESE LOCATIONS ARE LABELS WITH FIVE LETTER ! 5545: # (A-Y,$) NAMES. AS FAR AS POSSIBLE THE ORDER IS KEPT ! 5546: # ALPHABETICAL BY THESE NAMES BUT IN SOME CASES THERE ! 5547: # ARE SLIGHT DEPARTURES CAUSED BY OTHER ORDER REQUIREMENTS. ! 5548: # ! 5549: # UNLESS OTHERWISE DOCUMENTED, THE ORDER OF WORK AREAS ! 5550: # DOES NOT AFFECT THE EXECUTION OF THE SPITBOL PROGRAM. ! 5551: # ! 5552: .data 1 ! 5553: #sec # start of working storage section ! 5554: #page ! 5555: # ! 5556: # THIS AREA IS NOT CLEARED BY INITIAL CODE ! 5557: # ! 5558: cmlab: .long b$scl # string used to check label legality ! 5559: .long 2 ! 5560: .ascii " " ! 5561: .align 2 ! 5562: # ! 5563: # LABEL TO MARK START OF WORK AREA ! 5564: # ! 5565: aaaaa: .long 0 ! 5566: # ! 5567: # WORK AREAS FOR ALLOC PROCEDURE ! 5568: # ! 5569: aldyn: .long 0 # amount of dynamic store ! 5570: alfsf: .long 0 # factor in free store pcntage check ! 5571: allia: .long 0 # dump ia ! 5572: allsv: .long 0 # save wb in alloc ! 5573: # ! 5574: # WORK AREAS FOR ALOST PROCEDURE ! 5575: # ! 5576: alsta: .long 0 # save wa in alost ! 5577: # ! 5578: # SAVE AREAS FOR ARRAY FUNCTION (S$ARR) ! 5579: # ! 5580: arcdm: .long 0 # count dimensions ! 5581: arnel: .long 0 # count elements ! 5582: arptr: .long 0 # offset ptr into arblk ! 5583: arsvl: .long 0 # save integer low bound ! 5584: #page ! 5585: # WORK AREAS FOR ARREF ROUTINE ! 5586: # ! 5587: arfsi: .long 0 # save current evolving subscript ! 5588: arfxs: .long 0 # save base stack pointer ! 5589: # ! 5590: # WORK AREAS FOR B$EFC BLOCK ROUTINE ! 5591: # ! 5592: befof: .long 0 # save offset ptr into efblk ! 5593: # ! 5594: # WORK AREAS FOR B$PFC BLOCK ROUTINE ! 5595: # ! 5596: bpfpf: .long 0 # save pfblk pointer ! 5597: bpfsv: .long 0 # save old function value ! 5598: bpfxt: .long 0 # pointer to stacked arguments ! 5599: # ! 5600: # SAVE AREAS FOR COLLECT FUNCTION (S$COL) ! 5601: # ! 5602: clsvi: .long 0 # save integer argument ! 5603: # ! 5604: # GLOBAL VALUES FOR CMPIL PROCEDURE ! 5605: # ! 5606: cmerc: .long 0 # count of initial compile errors ! 5607: cmpxs: .long 0 # save stack ptr in case of errors ! 5608: cmpsn: .long 1 # number of next statement to compile ! 5609: cmpss: .long 0 # save subroutine stack ptr ! 5610: # ! 5611: # WORK AREA FOR CNCRD ! 5612: # ! 5613: cnscc: .long 0 # pointer to control card string ! 5614: cnswc: .long 0 # word count ! 5615: cnr$t: .long 0 # pointer to r$ttl or r$stl ! 5616: cnttl: .long 0 # flag for -title, -stitl ! 5617: # ! 5618: # WORK AREAS FOR CONVERT FUNCTION (S$CNV) ! 5619: # ! 5620: cnvtp: .long 0 # save ptr into scvtb ! 5621: # ! 5622: # FLAG FOR SUPPRESSION OF COMPILATION STATISTICS. ! 5623: # ! 5624: cpsts: .long 0 # suppress comp. stats if non zero ! 5625: # ! 5626: # GLOBAL VALUES FOR CONTROL CARD SWITCHES ! 5627: # ! 5628: cswdb: .long 0 # 0/1 for -single/-double ! 5629: cswer: .long 0 # 0/1 for -errors/-noerrors ! 5630: cswex: .long 0 # 0/1 for -execute/-noexecute ! 5631: cswfl: .long 1 # 0/1 for -nofail/-fail ! 5632: cswin: .long iniln # xxx for -inxxx ! 5633: cswls: .long 1 # 0/1 for -nolist/-list ! 5634: cswno: .long 0 # 0/1 for -optimise/-noopt ! 5635: cswpr: .long 0 # 0/1 for -noprint/-print ! 5636: # ! 5637: # GLOBAL LOCATION USED BY PATST PROCEDURE ! 5638: # ! 5639: ctmsk: .long 0 # last bit position used in r$ctp ! 5640: curid: .long 0 # current id value ! 5641: #page ! 5642: # ! 5643: # GLOBAL VALUE FOR CDWRD PROCEDURE ! 5644: # ! 5645: cwcof: .long 0 # next word offset in current ccblk ! 5646: # ! 5647: # WORK AREAS FOR DATA FUNCTION (S$DAT) ! 5648: # ! 5649: datdv: .long 0 # save vrblk ptr for datatype name ! 5650: datxs: .long 0 # save initial stack pointer ! 5651: # ! 5652: # WORK AREAS FOR DEFINE FUNCTION (S$DEF) ! 5653: # ! 5654: deflb: .long 0 # save vrblk ptr for label ! 5655: defna: .long 0 # count function arguments ! 5656: defvr: .long 0 # save vrblk ptr for function name ! 5657: defxs: .long 0 # save initial stack pointer ! 5658: # ! 5659: # WORK AREAS FOR DUMPR PROCEDURE ! 5660: # ! 5661: dmarg: .long 0 # dump argument ! 5662: dmpkb: .long b$kvt # dummy kvblk for use in dumpr ! 5663: dmpkt: .long trbkv # kvvar trblk pointer ! 5664: dmpkn: .long 0 # keyword number (must follow dmpkb) ! 5665: dmpsa: .long 0 # preserve wa over prtvl call ! 5666: dmpsv: .long 0 # general scratch save ! 5667: dmvch: .long 0 # chain pointer for variable blocks ! 5668: dmpch: .long 0 # save sorted vrblk chain pointer ! 5669: # ! 5670: # GLOBAL LOCATIONS FOR DYNAMIC STORAGE POINTERS ! 5671: # ! 5672: dnamb: .long 0 # start of dynamic area ! 5673: dnamp: .long 0 # next available loc in dynamic area ! 5674: dname: .long 0 # end of available dynamic area ! 5675: # ! 5676: # WORK AREA FOR DTACH ! 5677: # ! 5678: dtcnb: .long 0 # name base ! 5679: dtcnm: .long 0 # name ptr ! 5680: # ! 5681: # WORK AREAS FOR DUPL FUNCTION (S$DUP) ! 5682: # ! 5683: dupsi: .long 0 # store integer string length ! 5684: # ! 5685: # WORK AREA FOR ENDFILE (S$ENF) ! 5686: # ! 5687: enfch: .long 0 # for iochn chain head ! 5688: # ! 5689: # WORK AREA FOR ERROR PROCESSING. ! 5690: # ! 5691: erich: .long 0 # copy error reports to int.chan if 1 ! 5692: erlst: .long 0 # for listr when errors go to int.ch. ! 5693: errft: .long 0 # fatal error flag ! 5694: errsp: .long 0 # error suppression flag ! 5695: #page ! 5696: # ! 5697: # DUMP AREA FOR ERTEX ! 5698: # ! 5699: ertwa: .long 0 # save wa ! 5700: ertwb: .long 0 # save wb ! 5701: # ! 5702: # GLOBAL VALUES FOR EVALI ! 5703: # ! 5704: evlin: .long p$len # dummy pattern block pcode ! 5705: evlis: .long 0 # pointer to subsequent node ! 5706: evliv: .long 0 # value of parameter ! 5707: # WORK AREA FOR EXPAN ! 5708: # ! 5709: expsv: .long 0 # save op dope vector pointer ! 5710: # ! 5711: # FLAG FOR SUPPRESSION OF EXECUTION STATS ! 5712: # ! 5713: exsts: .long 0 # suppress exec stats if set ! 5714: # ! 5715: # GLOBAL VALUES FOR EXFAL AND RETURN ! 5716: # ! 5717: flprt: .long 0 # location of fail offset for return ! 5718: flptr: .long 0 # location of failure offset on stack ! 5719: # ! 5720: # WORK AREAS FOR GBCOL PROCEDURE ! 5721: # ! 5722: gbcfl: .long 0 # garbage collector active flag ! 5723: gbclm: .long 0 # pointer to last move block (pass 3) ! 5724: gbcnm: .long 0 # dummy first move block ! 5725: gbcns: .long 0 # rest of dummy block (follows gbcnm) ! 5726: gbsva: .long 0 # save wa ! 5727: gbsvb: .long 0 # save wb ! 5728: gbsvc: .long 0 # save wc ! 5729: # ! 5730: # GLOBAL LOCATION TO COUNT GARBAGE COLLECTIONS (GBCOL) ! 5731: # ! 5732: gbcnt: .long 0 # count of garbage collections ! 5733: # ! 5734: # WORK AREAS FOR GTNVR PROCEDURE ! 5735: # ! 5736: gnvhe: .long 0 # ptr to end of hash chain ! 5737: gnvnw: .long 0 # number of words in string name ! 5738: gnvsa: .long 0 # save wa ! 5739: gnvsb: .long 0 # save wb ! 5740: gnvsp: .long 0 # pointer into vsrch table ! 5741: gnvst: .long 0 # pointer to chars of string ! 5742: # ! 5743: # GLOBAL VALUE FOR GTCOD AND GTEXP ! 5744: # ! 5745: gtcef: .long 0 # save fail ptr in case of error ! 5746: # ! 5747: # WORK AREAS FOR GTINT ! 5748: # ! 5749: gtina: .long 0 # save wa ! 5750: gtinb: .long 0 # save wb ! 5751: #page ! 5752: # ! 5753: # WORK AREAS FOR GTNUM PROCEDURE ! 5754: # ! 5755: gtnnf: .long 0 # zero/nonzero for result +/- ! 5756: gtnsi: .long 0 # general integer save ! 5757: gtndf: .long 0 # 0/1 for dec point so far no/yes ! 5758: gtnes: .long 0 # zero/nonzero exponent +/- ! 5759: gtnex: .long 0 # real exponent ! 5760: gtnsc: .long 0 # scale (places after point) ! 5761: gtnsr: .float 0f0.0 # general real save ! 5762: gtnrd: .long 0 # flag for ok real number ! 5763: # ! 5764: # WORK AREAS FOR GTPAT PROCEDURE ! 5765: # ! 5766: gtpsb: .long 0 # save wb ! 5767: # ! 5768: # WORK AREAS FOR GTSTG PROCEDURE ! 5769: # ! 5770: gtssf: .long 0 # 0/1 for result +/- ! 5771: gtsvc: .long 0 # save wc ! 5772: gtsvb: .long 0 # save wb ! 5773: gtswk: .long 0 # ptr to work area for gtstg ! 5774: gtses: .long 0 # char + or - for exponent +/- ! 5775: gtsrs: .float 0f0.0 # general real save ! 5776: # ! 5777: # GLOBAL LOCATIONS (CONSTANTS) FOR GTSTG PROCEDURE ! 5778: # ! 5779: gtsrn: .float 0f0.0 # rounding factor 0.5*10**-cfp$s ! 5780: gtssc: .float 0f0.0 # scaling value 10**cfp$s ! 5781: # ! 5782: # WORK AREAS FOR GTVAR PROCEDURE ! 5783: # ! 5784: gtvrc: .long 0 # save wc ! 5785: # ! 5786: # FLAG FOR HEADER PRINTING ! 5787: # ! 5788: headp: .long 0 # header printed flag ! 5789: # ! 5790: # GLOBAL VALUES FOR VARIABLE HASH TABLE ! 5791: # ! 5792: hshnb: .long 0 # number of hash buckets ! 5793: hshtb: .long 0 # pointer to start of vrblk hash tabl ! 5794: hshte: .long 0 # pointer past end of vrblk hash tabl ! 5795: # ! 5796: # WORK AREA FOR INIT ! 5797: # ! 5798: iniss: .long 0 # save subroutine stack ptr ! 5799: initr: .long 0 # save terminal flag ! 5800: # ! 5801: # SAVE AREA FOR INSBF ! 5802: # ! 5803: insab: .long 0 # entry wa + entry wb ! 5804: inssa: .long 0 # save entry wa ! 5805: inssb: .long 0 # save entry wb ! 5806: inssc: .long 0 # save entry wc ! 5807: # ! 5808: # WORK AREAS FOR IOPUT ! 5809: # ! 5810: ioptt: .long 0 # type of association ! 5811: #page ! 5812: # ! 5813: # GLOBAL VALUES FOR KEYWORD VALUES WHICH ARE STORED AS ONE ! 5814: # WORD INTEGERS. THESE VALUES MUST BE ASSEMBLED IN THE ! 5815: # FOLLOWING ORDER (AS DICTATED BY K$XXX DEFINITION VALUES). ! 5816: # ! 5817: kvabe: .long 0 # abend ! 5818: kvanc: .long 0 # anchor ! 5819: kvcas: .long 0 # case ! 5820: kvcod: .long 0 # code ! 5821: kvdmp: .long 0 # dump ! 5822: kverl: .long 0 # errlimit ! 5823: kvert: .long 0 # errtype ! 5824: kvftr: .long 0 # ftrace ! 5825: kvinp: .long 1 # input ! 5826: kvmxl: .long 5000 # maxlength ! 5827: kvoup: .long 1 # output ! 5828: kvpfl: .long 0 # profile ! 5829: kvtra: .long 0 # trace ! 5830: kvtrm: .long 0 # trim ! 5831: kvfnc: .long 0 # fnclevel ! 5832: kvlst: .long 0 # lastno ! 5833: kvstn: .long 0 # stno ! 5834: # ! 5835: # GLOBAL VALUES FOR OTHER KEYWORDS ! 5836: # ! 5837: kvalp: .long 0 # alphabet ! 5838: kvrtn: .long nulls # rtntype (scblk pointer) ! 5839: kvstl: .long 50000 # stlimit ! 5840: kvstc: .long 50000 # stcount (counts down from stlimit) ! 5841: # ! 5842: # WORK AREAS FOR LOAD FUNCTION ! 5843: # ! 5844: lodfn: .long 0 # pointer to vrblk for func name ! 5845: lodna: .long 0 # count number of arguments ! 5846: # ! 5847: # GLOBAL VALUES FOR LISTR PROCEDURE ! 5848: # ! 5849: lstlc: .long 0 # count lines on source list page ! 5850: lstnp: .long 0 # max number of lines on page ! 5851: lstpf: .long 1 # set nonzero if current image listed ! 5852: lstpg: .long 0 # current source list page number ! 5853: lstpo: .long 0 # offset to page nnn message ! 5854: lstsn: .long 0 # remember last stmnum listed ! 5855: # ! 5856: # MAXIMUM SIZE OF SPITBOL OBJECTS ! 5857: # ! 5858: mxlen: .long 0 # initialised by sysmx call ! 5859: # ! 5860: # EXECUTION CONTROL VARIABLE ! 5861: # ! 5862: noxeq: .long 0 # set non-zero to inhibit execution ! 5863: # ! 5864: # PROFILER GLOBAL VALUES AND WORK LOCATIONS ! 5865: # ! 5866: pfdmp: .long 0 # set non-0 if &profile set non-0 ! 5867: pffnc: .long 0 # set non-0 if funct just entered ! 5868: pfstm: .long 0 # to store starting time of stmt ! 5869: pfetm: .long 0 # to store ending time of stmt ! 5870: pfsvw: .long 0 # to save a w-reg ! 5871: pftbl: .long 0 # gets adrs of (imag) table base ! 5872: pfnte: .long 0 # nr of table entries ! 5873: pfste: .long 0 # gets int rep of table entry size ! 5874: # ! 5875: #page ! 5876: # ! 5877: # GLOBAL VALUES USED IN PATTERN MATCH ROUTINES ! 5878: # ! 5879: pmdfl: .long 0 # pattern assignment flag ! 5880: pmhbs: .long 0 # history stack base pointer ! 5881: pmssl: .long 0 # length of subject string in chars ! 5882: # ! 5883: # FLAGS USED FOR STANDARD FILE LISTING OPTIONS ! 5884: # ! 5885: prich: .long 0 # printer on interactive channel ! 5886: prstd: .long 0 # tested by prtpg ! 5887: prsto: .long 0 # standard listing option flag ! 5888: # ! 5889: # GLOBAL VALUE FOR PRTNM PROCEDURE ! 5890: # ! 5891: prnmv: .long 0 # vrblk ptr from last name search ! 5892: # ! 5893: # WORK AREAS FOR PRTNM PROCEDURE ! 5894: # ! 5895: prnsi: .long 0 # scratch integer loc ! 5896: # ! 5897: # WORK AREAS FOR PRTSN PROCEDURE ! 5898: # ! 5899: prsna: .long 0 # save wa ! 5900: # ! 5901: # GLOBAL VALUES FOR PRINT PROCEDURES ! 5902: # ! 5903: prbuf: .long 0 # ptr to print bfr in static ! 5904: precl: .long 0 # extended/compact listing flag ! 5905: prlen: .long 0 # length of print buffer in chars ! 5906: prlnw: .long 0 # length of print buffer in words ! 5907: profs: .long 0 # offset to next location in prbuf ! 5908: prtef: .long 0 # endfile flag ! 5909: # ! 5910: # WORK AREAS FOR PRTST PROCEDURE ! 5911: # ! 5912: prsva: .long 0 # save wa ! 5913: prsvb: .long 0 # save wb ! 5914: prsvc: .long 0 # save char counter ! 5915: # ! 5916: # WORK AREA FOR PRTNL ! 5917: # ! 5918: prtsa: .long 0 # save wa ! 5919: prtsb: .long 0 # save wb ! 5920: # ! 5921: # WORK AREA FOR PRTVL ! 5922: # ! 5923: prvsi: .long 0 # save idval ! 5924: # ! 5925: # WORK AREAS FOR PATTERN MATCH ROUTINES ! 5926: # ! 5927: psave: .long 0 # temporary save for current node ptr ! 5928: psavc: .long 0 # save cursor in p$spn, p$str ! 5929: #page ! 5930: # ! 5931: # AMOUNT OF MEMORY RESERVED FOR END OF EXECUTION ! 5932: # ! 5933: rsmem: .long 0 # reserve memory ! 5934: # ! 5935: # WORK AREAS FOR RETRN ROUTINE ! 5936: # ! 5937: rtnbp: .long 0 # to save a block pointer ! 5938: rtnfv: .long 0 # new function value (result) ! 5939: rtnsv: .long 0 # old function value (saved value) ! 5940: # ! 5941: # RELOCATABLE GLOBAL VALUES ! 5942: # ! 5943: # ALL THE POINTERS IN THIS SECTION CAN POINT TO BLOCKS IN ! 5944: # THE DYNAMIC STORAGE AREA AND MUST BE RELOCATED BY THE ! 5945: # GARBAGE COLLECTOR. THEY ARE IDENTIFIED BY R$XXX NAMES. ! 5946: # ! 5947: r$aaa: .long 0 # start of relocatable values ! 5948: r$arf: .long 0 # array block pointer for arref ! 5949: r$ccb: .long 0 # ptr to ccblk being built (cdwrd) ! 5950: r$cim: .long 0 # ptr to current compiler input str ! 5951: r$cmp: .long 0 # copy of r$cim used in cmpil ! 5952: r$cni: .long 0 # ptr to next compiler input string ! 5953: r$cnt: .long 0 # cdblk pointer for setexit continue ! 5954: r$cod: .long 0 # pointer to current cdblk or exblk ! 5955: r$ctp: .long 0 # ptr to current ctblk for patst ! 5956: r$ert: .long 0 # trblk pointer for errtype trace ! 5957: r$etx: .long nulls # pointer to errtext string ! 5958: r$exs: .long 0 # = save xl in expdm ! 5959: r$fcb: .long 0 # fcblk chain head ! 5960: r$fnc: .long 0 # trblk pointer for fnclevel trace ! 5961: r$gtc: .long 0 # keep code ptr for gtcod,gtexp ! 5962: r$io1: .long 0 # file arg1 for ioput ! 5963: r$io2: .long 0 # file arg2 for ioput ! 5964: r$iof: .long 0 # fcblk ptr or 0 ! 5965: r$ion: .long 0 # name base ptr ! 5966: r$iop: .long 0 # predecessor block ptr for ioput ! 5967: r$iot: .long 0 # trblk ptr for ioput ! 5968: r$pmb: .long 0 # buffer ptr in pattern match ! 5969: r$pms: .long 0 # subject string ptr in pattern match ! 5970: r$ra2: .long 0 # replace second argument last time ! 5971: r$ra3: .long 0 # replace third argument last time ! 5972: r$rpt: .long 0 # ptr to ctblk replace table last usd ! 5973: r$scp: .long 0 # save pointer from last scane call ! 5974: r$sxl: .long 0 # preserve xl in sortc ! 5975: r$sxr: .long 0 # preserve xr in sorta/sortc ! 5976: r$stc: .long 0 # trblk pointer for stcount trace ! 5977: r$stl: .long 0 # source listing sub-title ! 5978: r$sxc: .long 0 # code (cdblk) ptr for setexit trap ! 5979: r$ttl: .long nulls # source listing title ! 5980: r$xsc: .long 0 # string pointer for xscan ! 5981: #page ! 5982: # ! 5983: # THE REMAINING POINTERS IN THIS LIST ARE USED TO POINT ! 5984: # TO FUNCTION BLOCKS FOR NORMALLY UNDEFINED OPERATORS. ! 5985: # ! 5986: r$uba: .long stndo # binary at ! 5987: r$ubm: .long stndo # binary ampersand ! 5988: r$ubn: .long stndo # binary number sign ! 5989: r$ubp: .long stndo # binary percent ! 5990: r$ubt: .long stndo # binary not ! 5991: r$uub: .long stndo # unary vertical bar ! 5992: r$uue: .long stndo # unary equal ! 5993: r$uun: .long stndo # unary number sign ! 5994: r$uup: .long stndo # unary percent ! 5995: r$uus: .long stndo # unary slash ! 5996: r$uux: .long stndo # unary exclamation ! 5997: r$yyy: .long 0 # last relocatable location ! 5998: # ! 5999: # WORK AREAS FOR SUBSTR FUNCTION (S$SUB) ! 6000: # ! 6001: sbssv: .long 0 # save third argument ! 6002: # ! 6003: # GLOBAL LOCATIONS USED IN SCAN PROCEDURE ! 6004: # ! 6005: scnbl: .long 0 # set non-zero if scanned past blanks ! 6006: scncc: .long 0 # non-zero to scan control card name ! 6007: scngo: .long 0 # set non-zero to scan goto field ! 6008: scnil: .long 0 # length of current input image ! 6009: scnpt: .long 0 # pointer to next location in r$cim ! 6010: scnrs: .long 0 # set non-zero to signal rescan ! 6011: scntp: .long 0 # save syntax type from last call ! 6012: # ! 6013: # WORK AREAS FOR SCAN PROCEDURE ! 6014: # ! 6015: scnsa: .long 0 # save wa ! 6016: scnsb: .long 0 # save wb ! 6017: scnsc: .long 0 # save wc ! 6018: scnse: .long 0 # start of current element ! 6019: scnof: .long 0 # save offset ! 6020: #page ! 6021: # ! 6022: # WORK AREA USED BY SORTA, SORTC, SORTF, SORTH ! 6023: # ! 6024: srtdf: .long 0 # datatype field name ! 6025: srtfd: .long 0 # found dfblk address ! 6026: srtff: .long 0 # found field name ! 6027: srtfo: .long 0 # offset to field name ! 6028: srtnr: .long 0 # number of rows ! 6029: srtof: .long 0 # offset within row to sort key ! 6030: srtrt: .long 0 # root offset ! 6031: srts1: .long 0 # save offset 1 ! 6032: srts2: .long 0 # save offset 2 ! 6033: srtsc: .long 0 # save wc ! 6034: srtsf: .long 0 # sort array first row offset ! 6035: srtsn: .long 0 # save n ! 6036: srtso: .long 0 # offset to a(0) ! 6037: srtsr: .long 0 # 0 , non-zero for sort, rsort ! 6038: srtst: .long 0 # stride from one row to next ! 6039: srtwc: .long 0 # dump wc ! 6040: # ! 6041: # GLOBAL VALUE FOR INDICATING STAGE (SEE ERROR SECTION) ! 6042: # ! 6043: stage: .long 0 # initial value = initial compile ! 6044: # ! 6045: # GLOBAL VALUES DEFINING EXTENT OF STATIC AREA (ALOST) ! 6046: # ! 6047: statb: .long 0 # start of static area ! 6048: state: .long 0 # end of static area ! 6049: #page ! 6050: # ! 6051: # GLOBAL STACK POINTER ! 6052: # ! 6053: stbas: .long 0 # pointer past stack base ! 6054: # ! 6055: # WORK AREAS FOR STOPR ROUTINE ! 6056: # ! 6057: stpsi: .long 0 # save value of stcount ! 6058: stpti: .long 0 # save time elapsed ! 6059: # ! 6060: # GLOBAL VALUES FOR SETEXIT FUNCTION (S$STX) ! 6061: # ! 6062: stxof: .long 0 # failure offset ! 6063: stxvr: .long nulls # vrblk pointer or null ! 6064: # ! 6065: # WORK AREAS FOR TFIND PROCEDURE ! 6066: # ! 6067: tfnsi: .long 0 # number of headers ! 6068: # ! 6069: # GLOBAL VALUE FOR TIME KEEPING ! 6070: # ! 6071: timsx: .long 0 # time at start of execution ! 6072: timup: .long 0 # set when time up occurs ! 6073: # ! 6074: # WORK AREAS FOR XSCAN PROCEDURE ! 6075: # ! 6076: xscrt: .long 0 # save return code ! 6077: xscwb: .long 0 # save register wb ! 6078: # ! 6079: # GLOBAL VALUES FOR XSCAN AND XSCNI PROCEDURES ! 6080: # ! 6081: xsofs: .long 0 # offset to current location in r$xsc ! 6082: # ! 6083: # LABEL TO MARK END OF WORK AREA ! 6084: # ! 6085: yyyyy: .long 0 ! 6086: #title s p i t b o l -- initialization ! 6087: # ! 6088: # INITIALISATION ! 6089: # THE FOLLOWING SECTION RECEIVES CONTROL FROM THE SYSTEM ! 6090: # AT THE START OF A RUN WITH THE REGISTERS SET AS FOLLOWS. ! 6091: # ! 6092: # (XS) POINTS PAST STACK BASE ! 6093: # (XR) POINTS TO FIRST WORD OF DATA AREA ! 6094: # (XL) POINTS TO LAST WORD OF DATA AREA ! 6095: # ! 6096: .text 0 ! 6097: .globl sec04 ! 6098: sec04: ! 6099: #sec # start of program section ! 6100: jsb systm # initialise timer ! 6101: # ! 6102: # INITIALISE WORK AREA (ESSENTIAL FOR BATCHED RUNS) ! 6103: # ! 6104: movl r9,r7 # preserve xr ! 6105: movl $yyyyy,r6 # point to end of work area ! 6106: subl2 $aaaaa,r6 # get length of work area ! 6107: ashl $-2,r6,r6 # convert to words ! 6108: # count for loop ! 6109: movl $aaaaa,r9 # set up index register ! 6110: # ! 6111: # CLEAR WORK SPACE ! 6112: # ! 6113: ini01: clrl (r9)+ # clear a word ! 6114: sobgtr r6,ini01 # loop till done ! 6115: movl $stndo,r6 # undefined operators pointer ! 6116: movl $r$yyy,r8 # point to table end ! 6117: subl2 $r$uba,r8 # length of undef. operators table ! 6118: ashl $-2,r8,r8 # convert to words ! 6119: # loop counter ! 6120: movl $r$uba,r9 # set up xr ! 6121: # ! 6122: # SET CORRECT VALUE INTO UNDEFINED OPERATORS TABLE ! 6123: # ! 6124: ini02: movl r6,(r9)+ # store value ! 6125: sobgtr r8,ini02 # loop till all done ! 6126: movl $num01,r6 # get a 1 ! 6127: movl r6,cmpsn # statement no ! 6128: movl r6,cswfl # nofail ! 6129: movl r6,cswls # list ! 6130: movl r6,kvinp # input ! 6131: movl r6,kvoup # output ! 6132: movl r6,lstpf # nothing for listr yet ! 6133: movl $iniln,r6 # input image length ! 6134: movl r6,cswin # -in72 ! 6135: movl $b$kvt,dmpkb # dump ! 6136: movl $trbkv,dmpkt # dump ! 6137: movl $p$len,evlin # eval ! 6138: #page ! 6139: movl $nulls,r6 # get nullstring pointer ! 6140: movl r6,kvrtn # return ! 6141: movl r6,r$etx # errtext ! 6142: movl r6,r$ttl # title for listing ! 6143: movl r6,stxvr # setexit ! 6144: movl r5,timsx # store time in correct place ! 6145: movl stlim,r5 # get default stlimit ! 6146: movl r5,kvstl # statement limit ! 6147: movl r5,kvstc # statement count ! 6148: movl r7,statb # store start adrs of static ! 6149: movl $4*e$srs,rsmem # reserve memory ! 6150: movl sp,stbas # store stack base ! 6151: #sss iniss # save s-r stack ptr ! 6152: # ! 6153: # NOW CONVERT FREE STORE PERCENTAGE TO A SUITABLE FACTOR ! 6154: # FOR EASY TESTING IN ALLOC ROUTINE. ! 6155: # ! 6156: movl intvh,r5 # get 100 ! 6157: divl2 alfsp,r5 # form 100 / alfsp ! 6158: movl r5,alfsf # store the factor ! 6159: # ! 6160: # INITIALIZE VALUES FOR REAL CONVERSION ROUTINE ! 6161: # ! 6162: movl $cfp$s,r7 # load counter for significant digits ! 6163: movf reav1,r2 # load 1.0 ! 6164: # ! 6165: # LOOP TO COMPUTE 10**(MAX NUMBER SIGNIFICANT DIGITS) ! 6166: # ! 6167: ini03: mulf2 reavt,r2 # * 10.0 ! 6168: sobgtr r7,ini03 # loop till done ! 6169: movf r2,gtssc # store 10**(max sig digits) ! 6170: movf reap5,r2 # load 0.5 ! 6171: divf2 gtssc,r2 # compute 0.5*10**(max sig digits) ! 6172: movf r2,gtsrn # store as rounding bias ! 6173: clrl r8 # set to read parameters ! 6174: jsb prpar # read them ! 6175: #page ! 6176: # ! 6177: # NOW COMPUTE STARTING ADDRESS FOR DYNAMIC STORE AND IF ! 6178: # NECESSARY REQUEST MORE MEMORY. ! 6179: # ! 6180: subl2 $4*e$srs,r10 # allow for reserve memory ! 6181: movl prlen,r6 # get print buffer length ! 6182: addl2 $cfp$a,r6 # add no. of chars in alphabet ! 6183: addl2 $nstmx,r6 # add chars for gtstg bfr ! 6184: movab 3+(4*8)(r6),r6 # convert to bytes, allowing a margin ! 6185: bicl2 $3,r6 ! 6186: movl statb,r9 # point to static base ! 6187: addl2 r6,r9 # increment for above buffers ! 6188: addl2 $4*e$hnb,r9 # increment for hash table ! 6189: addl2 $4*e$sts,r9 # bump for initial static block ! 6190: jsb sysmx # get mxlen ! 6191: movl r6,kvmxl # provisionally store as maxlngth ! 6192: movl r6,mxlen # and as mxlen ! 6193: cmpl r9,r6 # skip if static hi exceeds mxlen ! 6194: bgtru ini06 ! 6195: movl r6,r9 # use mxlen instead ! 6196: addl2 $4,r9 # make bigger than mxlen ! 6197: # ! 6198: # HERE TO STORE VALUES WHICH MARK INITIAL DIVISION ! 6199: # OF DATA AREA INTO STATIC AND DYNAMIC ! 6200: # ! 6201: ini06: movl r9,dnamb # dynamic base adrs ! 6202: movl r9,dnamp # dynamic ptr ! 6203: tstl r6 # skip if non-zero mxlen ! 6204: bnequ ini07 ! 6205: subl2 $4,r9 # point a word in front ! 6206: movl r9,kvmxl # use as maxlngth ! 6207: movl r9,mxlen # and as mxlen ! 6208: #page ! 6209: # ! 6210: # LOOP HERE IF NECESSARY TILL ENOUGH MEMORY OBTAINED ! 6211: # SO THAT DNAME IS ABOVE DNAMB ! 6212: # ! 6213: ini07: movl r10,dname # store dynamic end address ! 6214: cmpl dnamb,r10 # skip if high enough ! 6215: blssu ini09 ! 6216: jsb sysmm # request more memory ! 6217: moval 0[r9],r9 # get as baus (sgd05) ! 6218: addl2 r9,r10 # bump by amount obtained ! 6219: tstl r9 # try again ! 6220: bnequ ini07 ! 6221: movl $endmo,r9 # point to failure message ! 6222: movl endml,r6 # message length ! 6223: jsb syspr # print it (prtst not yet usable) ! 6224: .long invalid$ # should not fail ! 6225: jsb sysej # pack up (stopr not yet usable) ! 6226: # ! 6227: # INITIALISE PRINT BUFFER WITH BLANK WORDS ! 6228: # ! 6229: ini09: movl prlen,r8 # no. of chars in print bfr ! 6230: movl statb,r9 # point to static again ! 6231: movl r9,prbuf # print bfr is put at static start ! 6232: movl $b$scl,(r9)+ # store string type code ! 6233: movl r8,(r9)+ # and string length ! 6234: movab 3+(4*0)(r8),r8 # get number of words in buffer ! 6235: ashl $-2,r8,r8 ! 6236: movl r8,prlnw # store for buffer clear ! 6237: # words to clear ! 6238: # ! 6239: # LOOP TO CLEAR BUFFER ! 6240: # ! 6241: ini10: movl nullw,(r9)+ # store blank ! 6242: sobgtr r8,ini10 # loop ! 6243: # ! 6244: # INITIALIZE NUMBER OF HASH HEADERS ! 6245: # ! 6246: movl $e$hnb,r6 # get number of hash headers ! 6247: movl r6,r5 # convert to integer ! 6248: movl r5,hshnb # store for use by gtnvr procedure ! 6249: # counter for clearing hash table ! 6250: movl r9,hshtb # pointer to hash table ! 6251: # ! 6252: # LOOP TO CLEAR HASH TABLE ! 6253: # ! 6254: ini11: clrl (r9)+ # blank a word ! 6255: sobgtr r6,ini11 # loop ! 6256: movl r9,hshte # end of hash table adrs is kept ! 6257: # ! 6258: # ALLOCATE WORK AREA FOR GTSTG CONVERSION PROCEDURE ! 6259: # ! 6260: movl $nstmx,r6 # get max num chars in output number ! 6261: movab 3+(4*scsi$)(r6),r6 # no of bytes needed ! 6262: bicl2 $3,r6 ! 6263: movl r9,gtswk # store bfr adrs ! 6264: addl2 r6,r9 # bump for work bfr ! 6265: #page ! 6266: # ! 6267: # BUILD ALPHABET STRING FOR ALPHABET KEYWORD AND REPLACE ! 6268: # ! 6269: movl r9,kvalp # save alphabet pointer ! 6270: movl $b$scl,(r9) # string blk type ! 6271: movl $cfp$a,r8 # no of chars in alphabet ! 6272: movl r8,4*sclen(r9) # store as string length ! 6273: movl r8,r7 # copy char count ! 6274: movab 3+(4*scsi$)(r7),r7 # no. of bytes needed ! 6275: bicl2 $3,r7 ! 6276: addl2 r9,r7 # current end address for static ! 6277: movl r7,state # store static end adrs ! 6278: # loop counter ! 6279: movab cfp$f(r9),r9 # point to chars of string ! 6280: clrl r7 # set initial character value ! 6281: # ! 6282: # LOOP TO ENTER CHARACTER CODES IN ORDER ! 6283: # ! 6284: ini12: movb r7,(r9)+ # store next code ! 6285: incl r7 # bump code value ! 6286: sobgtr r8,ini12 # loop till all stored ! 6287: #csc r9 # complete store characters ! 6288: # ! 6289: # INITIALIZE VARIABLE BLOCKS FOR INPUT AND OUTPUT ! 6290: # ! 6291: movl $v$inp,r10 # point to string /input/ ! 6292: movl $trtin,r7 # trblk type for input ! 6293: jsb inout # perform input association ! 6294: movl $v$oup,r10 # point to string /output/ ! 6295: movl $trtou,r7 # trblk type for output ! 6296: jsb inout # perform output association ! 6297: movl initr,r8 # terminal flag ! 6298: tstl r8 # skip if no terminal ! 6299: beqlu ini13 ! 6300: jsb prpar # associate terminal ! 6301: #page ! 6302: # ! 6303: # CHECK FOR EXPIRY DATE ! 6304: # ! 6305: ini13: jsb sysdc # call date check ! 6306: movl sp,flptr # in case stack overflows in compiler ! 6307: # ! 6308: # NOW COMPILE SOURCE INPUT CODE ! 6309: # ! 6310: jsb cmpil # call compiler ! 6311: movl r9,r$cod # set ptr to first code block ! 6312: movl $nulls,r$ttl # forget title (reg04) ! 6313: movl $nulls,r$stl # forget sub-title (reg04) ! 6314: clrl r$cim # forget compiler input image ! 6315: clrl r10 # clear dud value ! 6316: clrl r7 # dont shift dynamic store up ! 6317: jsb gbcol # clear garbage left from compile ! 6318: tstl cpsts # skip if no listing of comp stats ! 6319: beqlu 0f ! 6320: jmp inix0 ! 6321: 0: ! 6322: jsb prtpg # eject page ! 6323: # ! 6324: # PRINT COMPILE STATISTICS ! 6325: # ! 6326: movl dnamp,r6 # next available loc ! 6327: subl2 statb,r6 # minus start ! 6328: ashl $-2,r6,r6 # convert to words ! 6329: movl r6,r5 # convert to integer ! 6330: movl $encm1,r9 # point to /memory used (words)/ ! 6331: jsb prtmi # print message ! 6332: movl dname,r6 # end of memory ! 6333: subl2 dnamp,r6 # minus next available loc ! 6334: ashl $-2,r6,r6 # convert to words ! 6335: movl r6,r5 # convert to integer ! 6336: movl $encm2,r9 # point to /memory available (words)/ ! 6337: jsb prtmi # print line ! 6338: movl cmerc,r5 # get count of errors as integer ! 6339: movl $encm3,r9 # point to /compile errors/ ! 6340: jsb prtmi # print it ! 6341: movl gbcnt,r5 # garbage collection count ! 6342: subl2 intv1,r5 # adjust for unavoidable collect ! 6343: movl $stpm5,r9 # point to /storage regenerations/ ! 6344: jsb prtmi # print gbcol count ! 6345: jsb systm # get time ! 6346: subl2 timsx,r5 # get compilation time ! 6347: movl $encm4,r9 # point to compilation time (msec)/ ! 6348: jsb prtmi # print message ! 6349: addl2 $num05,lstlc # bump line count ! 6350: tstl headp # no eject if nothing printed (sdg11) ! 6351: bnequ 0f ! 6352: jmp inix0 ! 6353: 0: ! 6354: jsb prtpg # eject printer ! 6355: #page ! 6356: # ! 6357: # PREPARE NOW TO START EXECUTION ! 6358: # ! 6359: # SET DEFAULT INPUT RECORD LENGTH ! 6360: # ! 6361: inix0: cmpl cswin,$iniln # skip if not default -in72 used ! 6362: bgtru inix1 ! 6363: movl $inils,cswin # else use default record length ! 6364: # ! 6365: # RESET TIMER ! 6366: # ! 6367: inix1: jsb systm # get time again ! 6368: movl r5,timsx # store for end run processing ! 6369: addl2 cswex,noxeq # add -noexecute flag ! 6370: tstl noxeq # jump if execution suppressed ! 6371: bnequ inix2 ! 6372: clrl gbcnt # initialise collect count ! 6373: jsb sysbx # call before starting execution ! 6374: # ! 6375: # MERGE WHEN LISTING FILE SET FOR EXECUTION ! 6376: # ! 6377: iniy0: movl sp,headp # mark headers out regardless ! 6378: clrl -(sp) # set failure location on stack ! 6379: movl sp,flptr # save ptr to failure offset word ! 6380: movl r$cod,r9 # load ptr to entry code block ! 6381: movl $stgxt,stage # set stage for execute time ! 6382: movl cmpsn,pfnte # copy stmts compiled count in case ! 6383: jsb systm # time yet again ! 6384: movl r5,pfstm ! 6385: movl (r9),r11 # start xeq with first statement ! 6386: jmp (r11) ! 6387: # ! 6388: # HERE IF EXECUTION IS SUPPRESSED ! 6389: # ! 6390: inix2: jsb prtnl # print a blank line ! 6391: movl $encm5,r9 # point to /execution suppressed/ ! 6392: jsb prtst # print string ! 6393: jsb prtnl # output line ! 6394: clrl r6 # set abend value to zero ! 6395: movl $nini9,r7 # set special code value ! 6396: jsb sysej # end of job, exit to system ! 6397: #title s p i t b o l -- snobol4 operator routines ! 6398: # ! 6399: # THIS SECTION INCLUDES ALL ROUTINES WHICH CAN BE ACCESSED ! 6400: # DIRECTLY FROM THE GENERATED CODE EXCEPT SYSTEM FUNCTIONS. ! 6401: # ! 6402: # ALL ROUTINES IN THIS SECTION START WITH A LABEL OF THE ! 6403: # FORM O$XXX WHERE XXX IS THREE LETTERS. THE GENERATED CODE ! 6404: # CONTAINS A POINTER TO THE APPROPRIATE ENTRY LABEL. ! 6405: # ! 6406: # SINCE THE GENERAL FORM OF THE GENERATED CODE CONSISTS OF ! 6407: # POINTERS TO BLOCKS WHOSE FIRST WORD IS THE ADDRESS OF THE ! 6408: # ACTUAL ENTRY POINT LABEL (O$XXX). ! 6409: # ! 6410: # THESE ROUTINES ARE IN ALPHABETICAL ORDER BY THEIR ! 6411: # ENTRY LABEL NAMES (I.E. BY THE XXX OF THE O$XXX NAME) ! 6412: # ! 6413: # THESE ROUTINES RECEIVE CONTROL AS FOLLOWS ! 6414: # ! 6415: # (CP) POINTER TO NEXT CODE WORD ! 6416: # (XS) CURRENT STACK POINTER ! 6417: #page ! 6418: # ! 6419: # BINARY PLUS (ADDITION) ! 6420: # ! 6421: o$add: # entry point ! 6422: jsb arith # fetch arithmetic operands ! 6423: .long er_001 # addition left operand is not numeric ! 6424: .long er_002 # addition right operand is not numeric ! 6425: .long oadd1 # jump if real operands ! 6426: # ! 6427: # HERE TO ADD TWO INTEGERS ! 6428: # ! 6429: addl2 4*icval(r10),r5 # add right operand to left ! 6430: bvs 0f ! 6431: jmp exint ! 6432: 0: ! 6433: jmp er_003 # addition caused integer overflow ! 6434: # ! 6435: # HERE TO ADD TWO REALS ! 6436: # ! 6437: oadd1: addf2 4*rcval(r10),r2 # add right operand to left ! 6438: bvs 0f ! 6439: jmp exrea ! 6440: 0: ! 6441: jmp er_261 # addition caused real overflow ! 6442: #page ! 6443: # ! 6444: # UNARY PLUS (AFFIRMATION) ! 6445: # ! 6446: o$aff: # entry point ! 6447: movl (sp)+,r9 # load operand ! 6448: jsb gtnum # convert to numeric ! 6449: .long er_004 # affirmation operand is not numeric ! 6450: jmp exixr # return if converted to numeric ! 6451: #page ! 6452: # ! 6453: # BINARY BAR (ALTERNATION) ! 6454: # ! 6455: o$alt: # entry point ! 6456: movl (sp)+,r9 # load right operand ! 6457: jsb gtpat # convert to pattern ! 6458: .long er_005 # alternation right operand is not pattern ! 6459: # ! 6460: # MERGE HERE FROM SPECIAL (LEFT ALTERNATION) CASE ! 6461: # ! 6462: oalt1: movl $p$alt,r7 # set pcode for alternative node ! 6463: jsb pbild # build alternative node ! 6464: movl r9,r10 # save address of alternative node ! 6465: movl (sp)+,r9 # load left operand ! 6466: jsb gtpat # convert to pattern ! 6467: .long er_006 # alternation left operand is not pattern ! 6468: cmpl r9,$p$alt # jump if left arg is alternation ! 6469: beqlu oalt2 ! 6470: movl r9,4*pthen(r10) # set left operand as successor ! 6471: movl r10,r9 # move result to proper register ! 6472: jmp exixr # jump for next code word ! 6473: # ! 6474: # COME HERE IF LEFT ARGUMENT IS ITSELF AN ALTERNATION ! 6475: # ! 6476: # THE RESULT IS MORE EFFICIENT IF WE MAKE THE REPLACEMENT ! 6477: # ! 6478: # (A / B) / C = A / (B / C) ! 6479: # ! 6480: oalt2: movl 4*parm1(r9),4*pthen(r10) # build the (b / c) node ! 6481: movl 4*pthen(r9),-(sp)# set a as new left arg ! 6482: movl r10,r9 # set (b / c) as new right arg ! 6483: jmp oalt1 # merge back to build a / (b / c) ! 6484: #page ! 6485: # ! 6486: # ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY NAME) ! 6487: # ! 6488: o$amn: # entry point ! 6489: movl (r3)+,r9 # load number of subscripts ! 6490: movl r9,r7 # set flag for by name ! 6491: jmp arref # jump to array reference routine ! 6492: #page ! 6493: # ! 6494: # ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY VALUE) ! 6495: # ! 6496: o$amv: # entry point ! 6497: movl (r3)+,r9 # load number of subscripts ! 6498: clrl r7 # set flag for by value ! 6499: jmp arref # jump to array reference routine ! 6500: #page ! 6501: # ! 6502: # ARRAY REFERENCE (ONE SUBSCRIPT, BY NAME) ! 6503: # ! 6504: o$aon: # entry point ! 6505: movl (sp),r9 # load subscript value ! 6506: movl 4*1(sp),r10 # load array value ! 6507: movl (r10),r6 # load first word of array operand ! 6508: cmpl r6,$b$vct # jump if vector reference ! 6509: beqlu oaon2 ! 6510: cmpl r6,$b$tbt # jump if table reference ! 6511: beqlu oaon3 ! 6512: # ! 6513: # HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE ! 6514: # ! 6515: oaon1: movl $num01,r9 # set number of subscripts to one ! 6516: movl r9,r7 # set flag for by name ! 6517: jmp arref # jump to array reference routine ! 6518: # ! 6519: # HERE IF WE HAVE A VECTOR REFERENCE ! 6520: # ! 6521: oaon2: cmpl (r9),$b$icl # use long routine if not integer ! 6522: bnequ oaon1 ! 6523: movl 4*icval(r9),r5 # load integer subscript value ! 6524: movl r5,r6 # copy as address int, fail if ovflo ! 6525: bgeq 0f ! 6526: jmp exfal ! 6527: 0: ! 6528: tstl r6 # fail if zero ! 6529: bnequ 0f ! 6530: jmp exfal ! 6531: 0: ! 6532: addl2 $vcvlb,r6 # compute offset in words ! 6533: moval 0[r6],r6 # convert to bytes ! 6534: movl r6,(sp) # complete name on stack ! 6535: cmpl r6,4*vclen(r10) # exit if subscript not too large ! 6536: bgequ 0f ! 6537: jmp exits ! 6538: 0: ! 6539: jmp exfal # else fail ! 6540: # ! 6541: # HERE FOR TABLE REFERENCE ! 6542: # ! 6543: oaon3: movl sp,r7 # set flag for name reference ! 6544: jsb tfind # locate/create table element ! 6545: .long exfal # fail if access fails ! 6546: movl r10,4*1(sp) # store name base on stack ! 6547: movl r6,(sp) # store name offset on stack ! 6548: jmp exits # exit with result on stack ! 6549: #page ! 6550: # ! 6551: # ARRAY REFERENCE (ONE SUBSCRIPT, BY VALUE) ! 6552: # ! 6553: o$aov: # entry point ! 6554: movl (sp)+,r9 # load subscript value ! 6555: movl (sp)+,r10 # load array value ! 6556: movl (r10),r6 # load first word of array operand ! 6557: cmpl r6,$b$vct # jump if vector reference ! 6558: beqlu oaov2 ! 6559: cmpl r6,$b$tbt # jump if table reference ! 6560: beqlu oaov3 ! 6561: # ! 6562: # HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE ! 6563: # ! 6564: oaov1: movl r10,-(sp) # restack array value ! 6565: movl r9,-(sp) # restack subscript ! 6566: movl $num01,r9 # set number of subscripts to one ! 6567: clrl r7 # set flag for value call ! 6568: jmp arref # jump to array reference routine ! 6569: # ! 6570: # HERE IF WE HAVE A VECTOR REFERENCE ! 6571: # ! 6572: oaov2: cmpl (r9),$b$icl # use long routine if not integer ! 6573: bnequ oaov1 ! 6574: movl 4*icval(r9),r5 # load integer subscript value ! 6575: movl r5,r6 # move as one word int, fail if ovflo ! 6576: bgeq 0f ! 6577: jmp exfal ! 6578: 0: ! 6579: tstl r6 # fail if zero ! 6580: bnequ 0f ! 6581: jmp exfal ! 6582: 0: ! 6583: addl2 $vcvlb,r6 # compute offset in words ! 6584: moval 0[r6],r6 # convert to bytes ! 6585: cmpl r6,4*vclen(r10) # fail if subscript too large ! 6586: blssu 0f ! 6587: jmp exfal ! 6588: 0: ! 6589: jsb acess # access value ! 6590: .long exfal # fail if access fails ! 6591: jmp exixr # else return value to caller ! 6592: # ! 6593: # HERE FOR TABLE REFERENCE BY VALUE ! 6594: # ! 6595: oaov3: clrl r7 # set flag for value reference ! 6596: jsb tfind # call table search routine ! 6597: .long exfal # fail if access fails ! 6598: jmp exixr # exit with result in xr ! 6599: #page ! 6600: # ! 6601: # ASSIGNMENT ! 6602: # ! 6603: o$ass: # entry point ! 6604: # ! 6605: # O$RPL (PATTERN REPLACEMENT) MERGES HERE ! 6606: # ! 6607: oass0: movl (sp)+,r7 # load value to be assigned ! 6608: movl (sp)+,r6 # load name offset ! 6609: movl (sp),r10 # load name base ! 6610: movl r7,(sp) # store assigned value as result ! 6611: jsb asign # perform assignment ! 6612: .long exfal # fail if assignment fails ! 6613: jmp exits # exit with result on stack ! 6614: #page ! 6615: # ! 6616: # COMPILATION ERROR ! 6617: # ! 6618: o$cer: # entry point ! 6619: jmp er_007 # compilation error encountered during execution ! 6620: #page ! 6621: # ! 6622: # UNARY AT (CURSOR ASSIGNMENT) ! 6623: # ! 6624: o$cas: # entry point ! 6625: movl (sp)+,r8 # load name offset (parm2) ! 6626: movl (sp)+,r9 # load name base (parm1) ! 6627: movl $p$cas,r7 # set pcode for cursor assignment ! 6628: jsb pbild # build node ! 6629: jmp exixr # jump for next code word ! 6630: #page ! 6631: # ! 6632: # CONCATENATION ! 6633: # ! 6634: o$cnc: # entry point ! 6635: movl (sp),r9 # load right argument ! 6636: cmpl r9,$nulls # jump if right arg is null ! 6637: bnequ 0f ! 6638: jmp ocnc3 ! 6639: 0: ! 6640: movl 4*1(sp),r10 # load left argument ! 6641: cmpl r10,$nulls # jump if left argument is null ! 6642: bnequ 0f ! 6643: jmp ocnc4 ! 6644: 0: ! 6645: movl $b$scl,r6 # get constant to test for string ! 6646: cmpl r6,(r10) # jump if left arg not a string ! 6647: beqlu 0f ! 6648: jmp ocnc2 ! 6649: 0: ! 6650: cmpl r6,(r9) # jump if right arg not a string ! 6651: beqlu 0f ! 6652: jmp ocnc2 ! 6653: 0: ! 6654: # ! 6655: # MERGE HERE TO CONCATENATE TWO STRINGS ! 6656: # ! 6657: ocnc1: movl 4*sclen(r10),r6 # load left argument length ! 6658: addl2 4*sclen(r9),r6 # compute result length ! 6659: jsb alocs # allocate scblk for result ! 6660: movl r9,4*1(sp) # store result ptr over left argument ! 6661: movab cfp$f(r9),r9 # prepare to store chars of result ! 6662: movl 4*sclen(r10),r6 # get number of chars in left arg ! 6663: movab cfp$f(r10),r10 # prepare to load left arg chars ! 6664: jsb sbmvc # move characters of left argument ! 6665: movl (sp)+,r10 # load right arg pointer, pop stack ! 6666: movl 4*sclen(r10),r6 # load number of chars in right arg ! 6667: movab cfp$f(r10),r10 # prepare to load right arg chars ! 6668: jsb sbmvc # move characters of right argument ! 6669: jmp exits # exit with result on stack ! 6670: # ! 6671: # COME HERE IF ARGUMENTS ARE NOT BOTH STRINGS ! 6672: # ! 6673: ocnc2: jsb gtstg # convert right arg to string ! 6674: .long ocnc5 # jump if right arg is not string ! 6675: movl r9,r10 # save right arg ptr ! 6676: jsb gtstg # convert left arg to string ! 6677: .long ocnc6 # jump if left arg is not a string ! 6678: movl r9,-(sp) # stack left argument ! 6679: movl r10,-(sp) # stack right argument ! 6680: movl r9,r10 # move left arg to proper reg ! 6681: movl (sp),r9 # move right arg to proper reg ! 6682: jmp ocnc1 # merge back to concatenate strings ! 6683: #page ! 6684: # ! 6685: # CONCATENATION (CONTINUED) ! 6686: # ! 6687: # COME HERE FOR NULL RIGHT ARGUMENT ! 6688: # ! 6689: ocnc3: addl2 $4,sp # remove right arg from stack ! 6690: jmp exits # return with left argument on stack ! 6691: # ! 6692: # HERE FOR NULL LEFT ARGUMENT ! 6693: # ! 6694: ocnc4: addl2 $4,sp # unstack one argument ! 6695: movl r9,(sp) # store right argument ! 6696: jmp exits # exit with result on stack ! 6697: # ! 6698: # HERE IF RIGHT ARGUMENT IS NOT A STRING ! 6699: # ! 6700: ocnc5: movl r9,r10 # move right argument ptr ! 6701: movl (sp)+,r9 # load left arg pointer ! 6702: # ! 6703: # MERGE HERE WHEN LEFT ARGUMENT IS NOT A STRING ! 6704: # ! 6705: ocnc6: jsb gtpat # convert left arg to pattern ! 6706: .long er_008 # concatenation left opnd is not string or pattern ! 6707: movl r9,-(sp) # save result on stack ! 6708: movl r10,r9 # point to right operand ! 6709: jsb gtpat # convert to pattern ! 6710: .long er_009 # concatenation right opd is not string or pattern ! 6711: movl r9,r10 # move for pconc ! 6712: movl (sp)+,r9 # reload left operand ptr ! 6713: jsb pconc # concatenate patterns ! 6714: jmp exixr # exit with result in xr ! 6715: #page ! 6716: # ! 6717: # COMPLEMENTATION ! 6718: # ! 6719: o$com: # entry point ! 6720: movl (sp)+,r9 # load operand ! 6721: movl (r9),r6 # load type word ! 6722: # ! 6723: # MERGE BACK HERE AFTER CONVERSION ! 6724: # ! 6725: ocom1: cmpl r6,$b$icl # jump if integer ! 6726: beqlu ocom2 ! 6727: cmpl r6,$b$rcl # jump if real ! 6728: beqlu ocom3 ! 6729: jsb gtnum # else convert to numeric ! 6730: .long er_010 # complementation operand is not numeric ! 6731: jmp ocom1 # back to check cases ! 6732: # ! 6733: # HERE TO COMPLEMENT INTEGER ! 6734: # ! 6735: ocom2: movl 4*icval(r9),r5 # load integer value ! 6736: mnegl r5,r5 # negate ! 6737: bvs 0f ! 6738: jmp exint ! 6739: 0: ! 6740: jmp er_011 # complementation caused integer overflow ! 6741: # ! 6742: # HERE TO COMPLEMENT REAL ! 6743: # ! 6744: ocom3: movf 4*rcval(r9),r2 # load real value ! 6745: mnegf r2,r2 # negate ! 6746: jmp exrea # return real result ! 6747: #page ! 6748: # ! 6749: # BINARY SLASH (DIVISION) ! 6750: # ! 6751: o$dvd: # entry point ! 6752: jsb arith # fetch arithmetic operands ! 6753: .long er_012 # division left operand is not numeric ! 6754: .long er_013 # division right operand is not numeric ! 6755: .long odvd2 # jump if real operands ! 6756: # ! 6757: # HERE TO DIVIDE TWO INTEGERS ! 6758: # ! 6759: divl2 4*icval(r10),r5 # divide left operand by right ! 6760: bvs 0f ! 6761: jmp exint ! 6762: 0: ! 6763: jmp er_014 # division caused integer overflow ! 6764: # ! 6765: # HERE TO DIVIDE TWO REALS ! 6766: # ! 6767: odvd2: divf2 4*rcval(r10),r2 # divide left operand by right ! 6768: bvs 0f ! 6769: jmp exrea ! 6770: 0: ! 6771: jmp er_262 # division caused real overflow ! 6772: #page ! 6773: # ! 6774: # EXPONENTIATION ! 6775: # ! 6776: o$exp: # entry point ! 6777: movl (sp)+,r9 # load exponent ! 6778: jsb gtnum # convert to number ! 6779: .long er_015 # exponentiation right operand is not numeric ! 6780: cmpl r6,$b$icl # jump if real ! 6781: beqlu 0f ! 6782: jmp oexp7 ! 6783: 0: ! 6784: movl r9,r10 # move exponent ! 6785: movl (sp)+,r9 # load base ! 6786: jsb gtnum # convert to numeric ! 6787: .long er_016 # exponentiation left operand is not numeric ! 6788: movl 4*icval(r10),r5 # load exponent ! 6789: tstl r5 # error if negative exponent ! 6790: bgeq 0f ! 6791: jmp oexp8 ! 6792: 0: ! 6793: cmpl r6,$b$rcl # jump if base is real ! 6794: beqlu oexp3 ! 6795: # ! 6796: # HERE TO EXPONENTIATE AN INTEGER ! 6797: # ! 6798: movl r5,r6 # convert exponent to 1 word integer ! 6799: bgeq 0f ! 6800: jmp oexp2 ! 6801: 0: ! 6802: # set loop counter ! 6803: movl intv1,r5 # load initial value of 1 ! 6804: tstl r6 # jump if non-zero exponent ! 6805: bnequ oexp1 ! 6806: tstl r5 # give zero as result for nonzero**0 ! 6807: beql 0f ! 6808: jmp exint ! 6809: 0: ! 6810: jmp oexp4 # else error of 0**0 ! 6811: # ! 6812: # LOOP TO PERFORM EXPONENTIATION ! 6813: # ! 6814: oexp1: mull2 4*icval(r9),r5 # multiply by base ! 6815: bvs oexp2 ! 6816: sobgtr r6,oexp1 # loop back till computation complete ! 6817: jmp exint # then return integer result ! 6818: # ! 6819: # HERE IF INTEGER OVERFLOW ! 6820: # ! 6821: oexp2: jmp er_017 # exponentiation caused integer overflow ! 6822: #page ! 6823: # ! 6824: # EXPONENTIATION (CONTINUED) ! 6825: # ! 6826: # HERE TO EXPONENTIATE A REAL ! 6827: # ! 6828: oexp3: movl r5,r6 # convert exponent to one word ! 6829: bgeq 0f ! 6830: jmp oexp6 ! 6831: 0: ! 6832: # set loop counter ! 6833: movf reav1,r2 # load 1.0 as initial value ! 6834: tstl r6 # jump if non-zero exponent ! 6835: bnequ oexp5 ! 6836: tstf r2 # return 1.0 if nonzero**zero ! 6837: beql 0f ! 6838: jmp exrea ! 6839: 0: ! 6840: # ! 6841: # HERE FOR ERROR OF 0**0 OR 0.0**0 ! 6842: # ! 6843: oexp4: jmp er_018 # exponentiation result is undefined ! 6844: # ! 6845: # LOOP TO PERFORM EXPONENTIATION ! 6846: # ! 6847: oexp5: mulf2 4*rcval(r9),r2 # multiply by base ! 6848: bvs oexp6 ! 6849: sobgtr r6,oexp5 # loop till computation complete ! 6850: jmp exrea # then return real result ! 6851: # ! 6852: # HERE IF REAL OVERFLOW ! 6853: # ! 6854: oexp6: jmp er_266 # exponentiation caused real overflow ! 6855: # ! 6856: # HERE IF REAL EXPONENT ! 6857: # ! 6858: oexp7: jmp er_267 # exponentiation right operand is real not integer ! 6859: # ! 6860: # HERE FOR NEGATIVE EXPONENT ! 6861: # ! 6862: oexp8: jmp er_019 # exponentiation right operand is negative ! 6863: #page ! 6864: # ! 6865: # FAILURE IN EXPRESSION EVALUATION ! 6866: # ! 6867: # THIS ENTRY POINT IS USED IF THE EVALUATION OF AN ! 6868: # EXPRESSION, INITIATED BY THE EVALX PROCEDURE, FAILS. ! 6869: # CONTROL IS RETURNED TO AN APPROPRIATE POINT IN EVALX. ! 6870: # ! 6871: o$fex: # entry point ! 6872: jmp evlx6 # jump to failure loc in evalx ! 6873: #page ! 6874: # ! 6875: # FAILURE DURING EVALUATION OF A COMPLEX OR DIRECT GOTO ! 6876: # ! 6877: o$fif: # entry point ! 6878: jmp er_020 # goto evaluation failure ! 6879: #page ! 6880: # ! 6881: # FUNCTION CALL (MORE THAN ONE ARGUMENT) ! 6882: # ! 6883: o$fnc: # entry point ! 6884: movl (r3)+,r6 # load number of arguments ! 6885: movl (r3)+,r9 # load function vrblk pointer ! 6886: movl 4*vrfnc(r9),r10 # load function pointer ! 6887: cmpl r6,4*fargs(r10) # use central routine if wrong num ! 6888: beqlu 0f ! 6889: jmp cfunc ! 6890: 0: ! 6891: movl (r10),r11 # jump to function if arg count ok ! 6892: jmp (r11) ! 6893: #page ! 6894: # ! 6895: # FUNCTION NAME ERROR ! 6896: # ! 6897: o$fne: # entry point ! 6898: movl (r3)+,r6 # get next code word ! 6899: cmpl r6,$ornm$ # fail if not evaluating expression ! 6900: bnequ ofne1 ! 6901: tstl 4*2(sp) # ok if expr. was wanted by value ! 6902: bnequ 0f ! 6903: jmp evlx3 ! 6904: 0: ! 6905: # ! 6906: # HERE FOR ERROR ! 6907: # ! 6908: ofne1: jmp er_021 # function called by name returned a value ! 6909: #page ! 6910: # ! 6911: # FUNCTION CALL (SINGLE ARGUMENT) ! 6912: # ! 6913: o$fns: # entry point ! 6914: movl (r3)+,r9 # load function vrblk pointer ! 6915: movl $num01,r6 # set number of arguments to one ! 6916: movl 4*vrfnc(r9),r10 # load function pointer ! 6917: cmpl r6,4*fargs(r10) # use central routine if wrong num ! 6918: beqlu 0f ! 6919: jmp cfunc ! 6920: 0: ! 6921: movl (r10),r11 # jump to function if arg count ok ! 6922: jmp (r11) ! 6923: #page ! 6924: # CALL TO UNDEFINED FUNCTION ! 6925: # ! 6926: o$fun: # entry point ! 6927: jmp er_022 # undefined function called ! 6928: #page ! 6929: # ! 6930: # EXECUTE COMPLEX GOTO ! 6931: # ! 6932: o$goc: # entry point ! 6933: movl 4*1(sp),r9 # load name base pointer ! 6934: cmpl r9,state # jump if not natural variable ! 6935: bgequ ogoc1 ! 6936: addl2 $4*vrtra,r9 # else point to vrtra field ! 6937: movl (r9),r11 # and jump through it ! 6938: jmp (r11) ! 6939: # ! 6940: # HERE IF GOTO OPERAND IS NOT NATURAL VARIABLE ! 6941: # ! 6942: ogoc1: jmp er_023 # goto operand is not a natural variable ! 6943: #page ! 6944: # ! 6945: # EXECUTE DIRECT GOTO ! 6946: # ! 6947: o$god: # entry point ! 6948: movl (sp),r9 # load operand ! 6949: movl (r9),r6 # load first word ! 6950: cmpl r6,$b$cds # jump if code block to code routine ! 6951: bnequ 0f ! 6952: jmp bcds0 ! 6953: 0: ! 6954: cmpl r6,$b$cdc # jump if code block to code routine ! 6955: bnequ 0f ! 6956: jmp bcdc0 ! 6957: 0: ! 6958: jmp er_024 # goto operand in direct goto is not code ! 6959: #page ! 6960: # ! 6961: # SET GOTO FAILURE TRAP ! 6962: # ! 6963: # THIS ROUTINE IS EXECUTED AT THE START OF A COMPLEX OR ! 6964: # DIRECT FAILURE GOTO TO TRAP A SUBSEQUENT FAIL (SEE EXFAL) ! 6965: # ! 6966: o$gof: # entry point ! 6967: movl flptr,r9 # point to fail offset on stack ! 6968: addl2 $4,(r9) # point failure to o$fif word ! 6969: tstl (r3)+ # point to next code word ! 6970: jmp exits # exit to continue ! 6971: #page ! 6972: # ! 6973: # BINARY DOLLAR (IMMEDIATE ASSIGNMENT) ! 6974: # ! 6975: # THE PATTERN BUILT BY BINARY DOLLAR IS A COMPOUND PATTERN. ! 6976: # SEE DESCRIPTION AT START OF PATTERN MATCH SECTION FOR ! 6977: # DETAILS OF THE STRUCTURE WHICH IS CONSTRUCTED. ! 6978: # ! 6979: o$ima: # entry point ! 6980: movl $p$imc,r7 # set pcode for last node ! 6981: movl (sp)+,r8 # pop name offset (parm2) ! 6982: movl (sp)+,r9 # pop name base (parm1) ! 6983: jsb pbild # build p$imc node ! 6984: movl r9,r10 # save ptr to node ! 6985: movl (sp),r9 # load left argument ! 6986: jsb gtpat # convert to pattern ! 6987: .long er_025 # immediate assignment left operand is not pattern ! 6988: movl r9,(sp) # save ptr to left operand pattern ! 6989: movl $p$ima,r7 # set pcode for first node ! 6990: jsb pbild # build p$ima node ! 6991: movl (sp)+,4*pthen(r9)# set left operand as p$ima successor ! 6992: jsb pconc # concatenate to form final pattern ! 6993: jmp exixr # all done ! 6994: #page ! 6995: # ! 6996: # INDIRECTION (BY NAME) ! 6997: # ! 6998: o$inn: # entry point ! 6999: movl sp,r7 # set flag for result by name ! 7000: jmp indir # jump to common routine ! 7001: #page ! 7002: # ! 7003: # INTERROGATION ! 7004: # ! 7005: o$int: # entry point ! 7006: movl $nulls,(sp) # replace operand with null ! 7007: jmp exits # exit for next code word ! 7008: #page ! 7009: # ! 7010: # INDIRECTION (BY VALUE) ! 7011: # ! 7012: o$inv: # entry point ! 7013: clrl r7 # set flag for by value ! 7014: jmp indir # jump to common routine ! 7015: #page ! 7016: # ! 7017: # KEYWORD REFERENCE (BY NAME) ! 7018: # ! 7019: o$kwn: # entry point ! 7020: jsb kwnam # get keyword name ! 7021: jmp exnam # exit with result name ! 7022: #page ! 7023: # ! 7024: # KEYWORD REFERENCE (BY VALUE) ! 7025: # ! 7026: o$kwv: # entry point ! 7027: jsb kwnam # get keyword name ! 7028: movl r9,dnamp # delete kvblk ! 7029: jsb acess # access value ! 7030: .long exnul # dummy (unused) failure return ! 7031: jmp exixr # jump with value in xr ! 7032: #page ! 7033: # ! 7034: # LOAD EXPRESSION BY NAME ! 7035: # ! 7036: o$lex: # entry point ! 7037: movl $4*evsi$,r6 # set size of evblk ! 7038: jsb alloc # allocate space for evblk ! 7039: movl $b$evt,(r9) # set type word ! 7040: movl $trbev,4*evvar(r9) # set dummy trblk pointer ! 7041: movl (r3)+,r6 # load exblk pointer ! 7042: movl r6,4*evexp(r9) # set exblk pointer ! 7043: movl r9,r10 # move name base to proper reg ! 7044: movl $4*evvar,r6 # set name offset = zero ! 7045: jmp exnam # exit with name in (xl,wa) ! 7046: #page ! 7047: # ! 7048: # LOAD PATTERN VALUE ! 7049: # ! 7050: o$lpt: # entry point ! 7051: movl (r3)+,r9 # load pattern pointer ! 7052: jmp exixr # stack ptr and obey next code word ! 7053: #page ! 7054: # ! 7055: # LOAD VARIABLE NAME ! 7056: # ! 7057: o$lvn: # entry point ! 7058: movl (r3)+,r6 # load vrblk pointer ! 7059: movl r6,-(sp) # stack vrblk ptr (name base) ! 7060: movl $4*vrval,-(sp) # stack name offset ! 7061: jmp exits # exit with result on stack ! 7062: #page ! 7063: # ! 7064: # BINARY ASTERISK (MULTIPLICATION) ! 7065: # ! 7066: o$mlt: # entry point ! 7067: jsb arith # fetch arithmetic operands ! 7068: .long er_026 # multiplication left operand is not numeric ! 7069: .long er_027 # multiplication right operand is not numeric ! 7070: .long omlt1 # jump if real operands ! 7071: # ! 7072: # HERE TO MULTIPLY TWO INTEGERS ! 7073: # ! 7074: mull2 4*icval(r10),r5 # multiply left operand by right ! 7075: bvs 0f ! 7076: jmp exint ! 7077: 0: ! 7078: jmp er_028 # multiplication caused integer overflow ! 7079: # ! 7080: # HERE TO MULTIPLY TWO REALS ! 7081: # ! 7082: omlt1: mulf2 4*rcval(r10),r2 # multiply left operand by right ! 7083: bvs 0f ! 7084: jmp exrea ! 7085: 0: ! 7086: jmp er_263 # multiplication caused real overflow ! 7087: #page ! 7088: # ! 7089: # NAME REFERENCE ! 7090: # ! 7091: o$nam: # entry point ! 7092: movl $4*nmsi$,r6 # set length of nmblk ! 7093: jsb alloc # allocate nmblk ! 7094: movl $b$nml,(r9) # set name block code ! 7095: movl (sp)+,4*nmofs(r9)# set name offset from operand ! 7096: movl (sp)+,4*nmbas(r9)# set name base from operand ! 7097: jmp exixr # exit with result in xr ! 7098: #page ! 7099: # ! 7100: # NEGATION ! 7101: # ! 7102: # INITIAL ENTRY ! 7103: # ! 7104: o$nta: # entry point ! 7105: movl (r3)+,r6 # load new failure offset ! 7106: movl flptr,-(sp) # stack old failure pointer ! 7107: movl r6,-(sp) # stack new failure offset ! 7108: movl sp,flptr # set new failure pointer ! 7109: jmp exits # jump to continue execution ! 7110: # ! 7111: # ENTRY AFTER SUCCESSFUL EVALUATION OF OPERAND ! 7112: # ! 7113: o$ntb: # entry point ! 7114: movl 4*2(sp),flptr # restore old failure pointer ! 7115: jmp exfal # and fail ! 7116: # ! 7117: # ENTRY FOR FAILURE DURING OPERAND EVALUATION ! 7118: # ! 7119: o$ntc: # entry point ! 7120: addl2 $4,sp # pop failure offset ! 7121: movl (sp)+,flptr # restore old failure pointer ! 7122: jmp exnul # exit giving null result ! 7123: #page ! 7124: # ! 7125: # USE OF UNDEFINED OPERATOR ! 7126: # ! 7127: o$oun: # entry point ! 7128: jmp er_029 # undefined operator referenced ! 7129: #page ! 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: # entry point ! 7138: movl $p$pac,r7 # load pcode for p$pac node ! 7139: movl (sp)+,r8 # load name offset (parm2) ! 7140: movl (sp)+,r9 # load name base (parm1) ! 7141: jsb pbild # build p$pac node ! 7142: movl r9,r10 # save ptr to node ! 7143: movl (sp),r9 # load left operand ! 7144: jsb gtpat # convert to pattern ! 7145: .long er_030 # pattern assignment left operand is not pattern ! 7146: movl r9,(sp) # save ptr to left operand pattern ! 7147: movl $p$paa,r7 # set pcode for p$paa node ! 7148: jsb pbild # build p$paa node ! 7149: movl (sp)+,4*pthen(r9)# set left operand as p$paa successor ! 7150: jsb pconc # concatenate to form final pattern ! 7151: jmp exixr # jump for next code word ! 7152: #page ! 7153: # ! 7154: # PATTERN MATCH (BY NAME, FOR REPLACEMENT) ! 7155: # ! 7156: o$pmn: # entry point ! 7157: clrl r7 # set type code for match by name ! 7158: jmp match # jump to routine to start match ! 7159: #page ! 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: # entry point ! 7168: movl $num02,r7 # set flag for statement to match ! 7169: jmp match # jump to routine to start match ! 7170: #page ! 7171: # ! 7172: # PATTERN MATCH (BY VALUE) ! 7173: # ! 7174: o$pmv: # entry point ! 7175: movl $num01,r7 # set type code for value match ! 7176: jmp match # jump to routine to start match ! 7177: #page ! 7178: # ! 7179: # POP TOP ITEM ON STACK ! 7180: # ! 7181: o$pop: # entry point ! 7182: addl2 $4,sp # pop top stack entry ! 7183: jmp exits # obey next code word ! 7184: #page ! 7185: # ! 7186: # TERMINATE EXECUTION (CODE COMPILED FOR END STATEMENT) ! 7187: # ! 7188: o$stp: # entry point ! 7189: jmp lend0 # jump to end circuit ! 7190: #page ! 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: # entry point ! 7198: jmp evlx4 # return to evalx procedure ! 7199: #page ! 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: # entry point ! 7214: jsb gtstg # convert replacement val to string ! 7215: .long er_031 # pattern replacement right operand is not string ! 7216: # ! 7217: # GET RESULT LENGTH AND ALLOCATE RESULT SCBLK ! 7218: # ! 7219: movl (sp),r10 # load subject string pointer ! 7220: cmpl (r10),$b$bct # branch if buffer assignment ! 7221: bnequ 0f ! 7222: jmp orpl4 ! 7223: 0: ! 7224: addl2 4*sclen(r10),r6 # add subject string length ! 7225: addl2 4*2(sp),r6 # add starting cursor ! 7226: subl2 4*1(sp),r6 # minus final cursor = total length ! 7227: tstl r6 # jump if result is null ! 7228: bnequ 0f ! 7229: jmp orpl3 ! 7230: 0: ! 7231: movl r9,-(sp) # restack replacement string ! 7232: jsb alocs # allocate scblk for result ! 7233: movl 4*3(sp),r6 # get initial cursor (part 1 len) ! 7234: movl r9,4*3(sp) # stack result pointer ! 7235: movab cfp$f(r9),r9 # point to characters of result ! 7236: # ! 7237: # MOVE PART 1 (START OF SUBJECT) TO RESULT ! 7238: # ! 7239: tstl r6 # jump if first part is null ! 7240: beqlu orpl1 ! 7241: movl 4*1(sp),r10 # else point to subject string ! 7242: movab cfp$f(r10),r10 # point to subject string chars ! 7243: jsb sbmvc # move first part to result ! 7244: #page ! 7245: # PATTERN REPLACEMENT (CONTINUED) ! 7246: # ! 7247: # NOW MOVE IN REPLACEMENT VALUE ! 7248: # ! 7249: orpl1: movl (sp)+,r10 # load replacement string, pop ! 7250: movl 4*sclen(r10),r6 # load length ! 7251: tstl r6 # jump if null replacement ! 7252: beqlu orpl2 ! 7253: movab cfp$f(r10),r10 # else point to chars of replacement ! 7254: jsb sbmvc # move in chars (part 2) ! 7255: # ! 7256: # NOW MOVE IN REMAINDER OF STRING (PART 3) ! 7257: # ! 7258: orpl2: movl (sp)+,r10 # load subject string pointer, pop ! 7259: movl (sp)+,r8 # load final cursor, pop ! 7260: movl 4*sclen(r10),r6 # load subject string length ! 7261: subl2 r8,r6 # minus final cursor = part 3 length ! 7262: tstl r6 # jump to assign if part 3 is null ! 7263: bnequ 0f ! 7264: jmp oass0 ! 7265: 0: ! 7266: movab cfp$f(r10)[r8],r10 # else point to last part of string ! 7267: jsb sbmvc # move part 3 to result ! 7268: jmp oass0 # jump to perform assignment ! 7269: # ! 7270: # HERE IF RESULT IS NULL ! 7271: # ! 7272: orpl3: addl2 $4*num02,sp # pop subject str ptr, final cursor ! 7273: movl $nulls,(sp) # set null result ! 7274: jmp oass0 # jump to assign null value ! 7275: # ! 7276: # HERE FOR BUFFER SUBSTRING ASSIGNMENT ! 7277: # ! 7278: orpl4: movl r9,r10 # copy scblk replacement ptr ! 7279: movl (sp)+,r9 # unstack bcblk ptr ! 7280: movl (sp)+,r7 # get final cursor value ! 7281: movl (sp)+,r6 # get initial cursor ! 7282: subl2 r6,r7 # get length in wb ! 7283: addl2 $4*num02,sp # get rid of name base/offset ! 7284: jsb insbf # insert substring ! 7285: .long invalid$ # convert fail impossible ! 7286: .long exfal # fail if insert fails ! 7287: jmp exnul # else null result ! 7288: #page ! 7289: # ! 7290: # RETURN VALUE FROM EXPRESSION ! 7291: # ! 7292: # THIS ENTRY POINTS IS USED IF THE EVALUATION OF AN ! 7293: # EXPRESSION, INITIATED BY THE EVALX PROCEDURE, RETURNS ! 7294: # A VALUE. CONTROL IS RETURNED TO THE PROPER POINT IN EVALX ! 7295: # ! 7296: o$rvl: # entry point ! 7297: jmp evlx3 # return to evalx procedure ! 7298: #page ! 7299: # ! 7300: # SELECTION ! 7301: # ! 7302: # INITIAL ENTRY ! 7303: # ! 7304: o$sla: # entry point ! 7305: movl (r3)+,r6 # load new failure offset ! 7306: movl flptr,-(sp) # stack old failure pointer ! 7307: movl r6,-(sp) # stack new failure offset ! 7308: movl sp,flptr # set new failure pointer ! 7309: jmp exits # jump to execute first alternative ! 7310: # ! 7311: # ENTRY AFTER SUCCESSFUL EVALUATION OF ALTERNATIVE ! 7312: # ! 7313: o$slb: # entry point ! 7314: movl (sp)+,r9 # load result ! 7315: addl2 $4,sp # pop fail offset ! 7316: movl (sp),flptr # restore old failure pointer ! 7317: movl r9,(sp) # restack result ! 7318: movl (r3)+,r6 # load new code offset ! 7319: addl2 r$cod,r6 # point to absolute code location ! 7320: movl r6,r3 # set new code pointer ! 7321: jmp exits # jump to continue past selection ! 7322: # ! 7323: # ENTRY AT START OF SUBSEQUENT ALTERNATIVES ! 7324: # ! 7325: o$slc: # entry point ! 7326: movl (r3)+,r6 # load new fail offset ! 7327: movl r6,(sp) # store new fail offset ! 7328: jmp exits # jump to execute next alternative ! 7329: # ! 7330: # ENTRY AT START OF LAST ALTERNATIVE ! 7331: # ! 7332: o$sld: # entry point ! 7333: addl2 $4,sp # pop failure offset ! 7334: movl (sp)+,flptr # restore old failure pointer ! 7335: jmp exits # jump to execute last alternative ! 7336: #page ! 7337: # ! 7338: # BINARY MINUS (SUBTRACTION) ! 7339: # ! 7340: o$sub: # entry point ! 7341: jsb arith # fetch arithmetic operands ! 7342: .long er_032 # subtraction left operand is not numeric ! 7343: .long er_033 # subtraction right operand is not numeric ! 7344: .long osub1 # jump if real operands ! 7345: # ! 7346: # HERE TO SUBTRACT TWO INTEGERS ! 7347: # ! 7348: subl2 4*icval(r10),r5 # subtract right operand from left ! 7349: bvs 0f ! 7350: jmp exint ! 7351: 0: ! 7352: jmp er_034 # subtraction caused integer overflow ! 7353: # ! 7354: # HERE TO SUBTRACT TWO REALS ! 7355: # ! 7356: osub1: subf2 4*rcval(r10),r2 # subtract right operand from left ! 7357: bvs 0f ! 7358: jmp exrea ! 7359: 0: ! 7360: jmp er_264 # subtraction caused real overflow ! 7361: #page ! 7362: # ! 7363: # DUMMY OPERATOR TO RETURN CONTROL TO TRXEQ PROCEDURE ! 7364: # ! 7365: o$txr: # entry point ! 7366: jmp trxq1 # jump into trxeq procedure ! 7367: #page ! 7368: # ! 7369: # UNEXPECTED FAILURE ! 7370: # ! 7371: # NOTE THAT IF A SETEXIT TRAP IS OPERATING THEN ! 7372: # TRANSFER TO SYSTEM LABEL CONTINUE ! 7373: # WILL RESULT IN LOOPING HERE. DIFFICULT TO AVOID EXCEPT ! 7374: # WITH A CONSIDERABLE OVERHEAD WHICH IS NOT WORTHWHILE OR ! 7375: # ELSE BY A TECHNIQUE SUCH AS SETTING KVERL TO ZERO. ! 7376: # ! 7377: o$unf: # entry point ! 7378: jmp er_035 # unexpected failure in -nofail mode ! 7379: #title s p i t b o l -- snobol4 builtin label routines ! 7380: # ! 7381: # THE FOLLOWING SECTION CONTAINS THE ROUTINES FOR LABELS ! 7382: # WHICH HAVE A PREDEFINED MEANING IN SNOBOL4. ! 7383: # ! 7384: # CONTROL IS PASSED DIRECTLY TO THE LABEL NAME ENTRY POINT. ! 7385: # ! 7386: # ENTRY NAMES ARE OF THE FORM L$XXX WHERE XXX IS THE THREE ! 7387: # LETTER VARIABLE NAME IDENTIFIER. ! 7388: # ! 7389: # ENTRIES ARE IN ALPHABETICAL ORDER ! 7390: #page ! 7391: # ! 7392: # ABORT ! 7393: # ! 7394: l$abo: # entry point ! 7395: # ! 7396: # MERGE HERE IF EXECUTION TERMINATES IN ERROR ! 7397: # ! 7398: labo1: movl kvert,r6 # load error code ! 7399: tstl r6 # jump if no error has occured ! 7400: beqlu labo2 ! 7401: jsb sysax # call after execution proc (reg04) ! 7402: jsb prtpg # else eject printer ! 7403: jsb ermsg # print error message ! 7404: clrl r9 # indicate no message to print ! 7405: jmp stopr # jump to routine to stop run ! 7406: # ! 7407: # HERE IF NO ERROR HAD OCCURED ! 7408: # ! 7409: labo2: jmp er_036 # goto abort with no preceding error ! 7410: #page ! 7411: # ! 7412: # CONTINUE ! 7413: # ! 7414: l$cnt: # entry point ! 7415: # ! 7416: # MERGE HERE AFTER EXECUTION ERROR ! 7417: # ! 7418: lcnt1: movl r$cnt,r9 # load continuation code block ptr ! 7419: tstl r9 # jump if no previous error ! 7420: beqlu lcnt2 ! 7421: clrl r$cnt # clear flag ! 7422: movl r9,r$cod # else store as new code block ptr ! 7423: addl2 stxof,r9 # add failure offset ! 7424: movl r9,r3 # load code pointer ! 7425: movl flptr,sp # reset stack pointer ! 7426: jmp exits # jump to take indicated failure ! 7427: # ! 7428: # HERE IF NO PREVIOUS ERROR ! 7429: # ! 7430: lcnt2: jmp er_037 # goto continue with no preceding error ! 7431: #page ! 7432: # ! 7433: # END ! 7434: # ! 7435: l$end: # entry point ! 7436: # ! 7437: # MERGE HERE FROM END CODE CIRCUIT ! 7438: # ! 7439: lend0: movl $endms,r9 # point to message /normal term../ ! 7440: jmp stopr # jump to routine to stop run ! 7441: #page ! 7442: # ! 7443: # FRETURN ! 7444: # ! 7445: l$frt: # entry point ! 7446: movl $scfrt,r6 # point to string /freturn/ ! 7447: jmp retrn # jump to common return routine ! 7448: #page ! 7449: # ! 7450: # NRETURN ! 7451: # ! 7452: l$nrt: # entry point ! 7453: movl $scnrt,r6 # point to string /nreturn/ ! 7454: jmp retrn # jump to common return routine ! 7455: #page ! 7456: # ! 7457: # RETURN ! 7458: # ! 7459: l$rtn: # entry point ! 7460: movl $scrtn,r6 # point to string /return/ ! 7461: jmp retrn # jump to common return routine ! 7462: #page ! 7463: # ! 7464: # UNDEFINED LABEL ! 7465: # ! 7466: l$und: # entry point ! 7467: jmp er_038 # goto undefined label ! 7468: #title s p i t b o l -- block action routines ! 7469: # ! 7470: # THE FIRST WORD OF EVERY BLOCK IN DYNAMIC STORAGE AND THE ! 7471: # VRGET, VRSTO AND VRTRA FIELDS OF A VRBLK CONTAIN A ! 7472: # POINTER TO AN ENTRY POINT IN THE PROGRAM. ALL SUCH ENTRY ! 7473: # POINTS ARE IN THE FOLLOWING SECTION EXCEPT THOSE FOR ! 7474: # PATTERN BLOCKS WHICH ARE IN THE PATTERN MATCHING SEGMENT ! 7475: # LATER ON (LABELS OF THE FORM P$XXX), AND DOPE VECTORS ! 7476: # (D$XXX) WHICH ARE IN THE DOPE VECTOR SECTION FOLLOWING ! 7477: # THE PATTERN ROUTINES (DOPE VECTORS ARE USED FOR CMBLKS). ! 7478: # ! 7479: # THE ENTRY POINTS IN THIS SECTION HAVE LABELS OF THE ! 7480: # FORM B$XXY WHERE XX IS THE TWO CHARACTER BLOCK TYPE FOR ! 7481: # THE CORRESPONDING BLOCK AND Y IS ANY LETTER. ! 7482: # ! 7483: # IN SOME CASES, THE POINTERS SERVE NO OTHER PURPOSE THAN ! 7484: # TO IDENTIFY THE BLOCK TYPE. IN THIS CASE THE ROUTINE ! 7485: # IS NEVER EXECUTED AND THUS NO CODE IS ASSEMBLED. ! 7486: # ! 7487: # FOR EACH OF THESE ENTRY POINTS CORRESPONDING TO A BLOCK ! 7488: # AN ENTRY POINT IDENTIFICATION IS ASSEMBLED (BL$XX). ! 7489: # ! 7490: # THE EXACT ENTRY CONDITIONS DEPEND ON THE MANNER IN ! 7491: # WHICH THE ROUTINE IS ACCESSED AND ARE DOCUMENTED WITH ! 7492: # THE INDIVIDUAL ROUTINES AS REQUIRED. ! 7493: # ! 7494: # THE ORDER OF THESE ROUTINES IS ALPHABETICAL WITH THE ! 7495: # FOLLOWING EXCEPTIONS. ! 7496: # ! 7497: # THE ROUTINES FOR SEBLK AND EXBLK ENTRIES OCCUR FIRST SO ! 7498: # THAT EXPRESSIONS CAN BE QUICKLY IDENTIFIED FROM THE FACT ! 7499: # THAT THEIR ROUTINES LIE BEFORE THE SYMBOL B$E$$. ! 7500: # ! 7501: # THESE ARE IMMEDIATELY FOLLOWED BY THE ROUTINE FOR A TRBLK ! 7502: # SO THAT THE TEST AGAINST THE SYMBOL B$T$$ CHECKS FOR ! 7503: # TRAPPED VALUES OR EXPRESSION VALUES (SEE PROCEDURE EVALP) ! 7504: # ! 7505: # THE PATTERN ROUTINES LIE AFTER THIS SECTION SO THAT ! 7506: # PATTERNS ARE IDENTIFIED WITH ROUTINES STARTING AT OR ! 7507: # AFTER THE INITIAL INSTRUCTION IN THESE ROUTINES (P$AAA). ! 7508: # ! 7509: # THE SYMBOL B$AAA DEFINES THE FIRST LOCATION FOR BLOCK ! 7510: # ROUTINES AND THE SYMBOL P$YYY (AT THE END OF THE PATTERN ! 7511: # MATCH ROUTINES SECTION) DEFINES THE LAST SUCH ENTRY POINT ! 7512: # ! 7513: .align 2 ! 7514: .word bl$$i ! 7515: b$aaa: # entry point of first block routine ! 7516: #page ! 7517: # ! 7518: # EXBLK ! 7519: # ! 7520: # THE ROUTINE FOR AN EXBLK LOADS THE EXPRESSION ONTO ! 7521: # THE STACK AS A VALUE. ! 7522: # ! 7523: # (XR) POINTER TO EXBLK ! 7524: # ! 7525: .align 2 ! 7526: .word bl$ex ! 7527: b$exl: # entry point (exblk) ! 7528: jmp exixr # stack xr and obey next code word ! 7529: #page ! 7530: # ! 7531: # SEBLK ! 7532: # ! 7533: # THE ROUTINE FOR SEBLK IS ACCESSED FROM THE GENERATED ! 7534: # CODE TO LOAD THE EXPRESSION VALUE ONTO THE STACK. ! 7535: # ! 7536: .align 2 ! 7537: .word bl$se ! 7538: b$sel: # entry point (seblk) ! 7539: jmp exixr # stack xr and obey next code word ! 7540: # ! 7541: # DEFINE SYMBOL WHICH MARKS END OF ENTRIES FOR EXPRESSIONS ! 7542: # ! 7543: .align 2 ! 7544: .word bl$$i ! 7545: b$e$$: # entry point ! 7546: #page ! 7547: # ! 7548: # TRBLK ! 7549: # ! 7550: # THE ROUTINE FOR A TRBLK IS NEVER EXECUTED ! 7551: # ! 7552: .align 2 ! 7553: .word bl$tr ! 7554: b$trt: # entry point (trblk) ! 7555: # ! 7556: # DEFINE SYMBOL MARKING END OF TRAP AND EXPRESSION BLOCKS ! 7557: # ! 7558: .align 2 ! 7559: .word bl$$i ! 7560: b$t$$: # end of trblk,seblk,exblk entries ! 7561: #page ! 7562: # ! 7563: # ARBLK ! 7564: # ! 7565: # THE ROUTINE FOR ARBLK IS NEVER EXECUTED ! 7566: # ! 7567: .align 2 ! 7568: .word bl$ar ! 7569: b$art: # entry point (arblk) ! 7570: #page ! 7571: # ! 7572: # BCBLK ! 7573: # ! 7574: # THE ROUTINE FOR A BCBLK IS NEVER EXECUTED ! 7575: # ! 7576: # (XR) POINTER TO BCBLK ! 7577: # ! 7578: .align 2 ! 7579: .word bl$bc ! 7580: b$bct: # entry point (bcblk) ! 7581: #page ! 7582: # ! 7583: # BFBLK ! 7584: # ! 7585: # THE ROUTINE FOR A BFBLK IS NEVER EXECUTED ! 7586: # ! 7587: # (XR) POINTER TO BFBLK ! 7588: # ! 7589: .align 2 ! 7590: .word bl$bf ! 7591: b$bft: # entry point (bfblk) ! 7592: #page ! 7593: # ! 7594: # CCBLK ! 7595: # ! 7596: # THE ROUTINE FOR CCBLK IS NEVER ENTERED ! 7597: # ! 7598: .align 2 ! 7599: .word bl$cc ! 7600: b$cct: # entry point (ccblk) ! 7601: #page ! 7602: # ! 7603: # CDBLK ! 7604: # ! 7605: # THE CDBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE. ! 7606: # THERE ARE TWO CASES DEPENDING ON THE FORM OF CDFAL. ! 7607: # ! 7608: # ENTRY FOR COMPLEX FAILURE CODE AT CDFAL ! 7609: # ! 7610: # (XR) POINTER TO CDBLK ! 7611: # ! 7612: .align 2 ! 7613: .word bl$cd ! 7614: b$cdc: # entry point (cdblk) ! 7615: bcdc0: movl flptr,sp # pop garbage off stack ! 7616: movl 4*cdfal(r9),(sp)# set failure offset ! 7617: jmp stmgo # enter stmt ! 7618: #page ! 7619: # ! 7620: # CDBLK (CONTINUED) ! 7621: # ! 7622: # ENTRY FOR SIMPLE FAILURE CODE AT CDFAL ! 7623: # ! 7624: # (XR) POINTER TO CDBLK ! 7625: # ! 7626: .align 2 ! 7627: .word bl$cd ! 7628: b$cds: # entry point (cdblk) ! 7629: bcds0: movl flptr,sp # pop garbage off stack ! 7630: movl $4*cdfal,(sp) # set failure offset ! 7631: jmp stmgo # enter stmt ! 7632: #page ! 7633: # ! 7634: # CMBLK ! 7635: # ! 7636: # THE ROUTINE FOR A CMBLK IS NEVER EXECUTED ! 7637: # ! 7638: .align 2 ! 7639: .word bl$cm ! 7640: b$cmt: # entry point (cmblk) ! 7641: #page ! 7642: # ! 7643: # CTBLK ! 7644: # ! 7645: # THE ROUTINE FOR A CTBLK IS NEVER EXECUTED ! 7646: # ! 7647: .align 2 ! 7648: .word bl$ct ! 7649: b$ctt: # entry point (ctblk) ! 7650: #page ! 7651: # ! 7652: # DFBLK ! 7653: # ! 7654: # THE ROUTINE FOR A DFBLK IS ACCESSED FROM THE O$FNC ENTRY ! 7655: # TO CALL A DATATYPE FUNCTION AND BUILD A PDBLK. ! 7656: # ! 7657: # (XL) POINTER TO DFBLK ! 7658: # ! 7659: .align 2 ! 7660: .word bl$df ! 7661: b$dfc: # entry point ! 7662: movl 4*dfpdl(r10),r6 # load length of pdblk ! 7663: jsb alloc # allocate pdblk ! 7664: movl $b$pdt,(r9) # store type word ! 7665: movl r10,4*pddfp(r9) # store dfblk pointer ! 7666: movl r9,r8 # save pointer to pdblk ! 7667: addl2 r6,r9 # point past pdblk ! 7668: movl 4*fargs(r10),r6 # set to count fields ! 7669: # ! 7670: # LOOP TO ACQUIRE FIELD VALUES FROM STACK ! 7671: # ! 7672: bdfc1: movl (sp)+,-(r9) # move a field value ! 7673: sobgtr r6,bdfc1 # loop till all moved ! 7674: movl r8,r9 # recall pointer to pdblk ! 7675: jmp exsid # exit setting id field ! 7676: #page ! 7677: # ! 7678: # EFBLK ! 7679: # ! 7680: # THE ROUTINE FOR AN EFBLK IS PASSED CONTROL FORM THE O$FNC ! 7681: # ENTRY TO CALL AN EXTERNAL FUNCTION. ! 7682: # ! 7683: # (XL) POINTER TO EFBLK ! 7684: # ! 7685: .align 2 ! 7686: .word bl$ef ! 7687: b$efc: # entry point (efblk) ! 7688: movl 4*fargs(r10),r8 # load number of arguments ! 7689: moval 0[r8],r8 # convert to offset ! 7690: movl r10,-(sp) # save pointer to efblk ! 7691: movl sp,r10 # copy pointer to arguments ! 7692: # ! 7693: # LOOP TO CONVERT ARGUMENTS ! 7694: # ! 7695: befc1: addl2 $4,r10 # point to next entry ! 7696: movl (sp),r9 # load pointer to efblk ! 7697: subl2 $4,r8 # decrement eftar offset ! 7698: addl2 r8,r9 # point to next eftar entry ! 7699: movl 4*eftar(r9),r9 # load eftar entry ! 7700: casel r9,$0,$4 # switch on type ! 7701: 5: ! 7702: .word befc7-5b # no conversion needed ! 7703: .word befc2-5b # string ! 7704: .word befc3-5b # integer ! 7705: .word befc4-5b # real ! 7706: #esw # end of switch on type ! 7707: # ! 7708: # HERE TO CONVERT TO STRING ! 7709: # ! 7710: befc2: movl (r10),-(sp) # stack arg ptr ! 7711: jsb gtstg # convert argument to string ! 7712: .long er_039 # external function argument is not string ! 7713: jmp befc6 # jump to merge ! 7714: #page ! 7715: # ! 7716: # EFBLK (CONTINUED) ! 7717: # ! 7718: # HERE TO CONVERT AN INTEGER ! 7719: # ! 7720: befc3: movl (r10),r9 # load next argument ! 7721: movl r8,befof # save offset ! 7722: jsb gtint # convert to integer ! 7723: .long er_040 # external function argument is not integer ! 7724: jmp befc5 # merge with real case ! 7725: # ! 7726: # HERE TO CONVERT A REAL ! 7727: # ! 7728: befc4: movl (r10),r9 # load next argument ! 7729: movl r8,befof # save offset ! 7730: jsb gtrea # convert to real ! 7731: .long er_265 # external function argument is not real ! 7732: # ! 7733: # INTEGER CASE MERGES HERE ! 7734: # ! 7735: befc5: movl befof,r8 # restore offset ! 7736: # ! 7737: # STRING MERGES HERE ! 7738: # ! 7739: befc6: movl r9,(r10) # store converted result ! 7740: # ! 7741: # NO CONVERSION MERGES HERE ! 7742: # ! 7743: befc7: tstl r8 # loop back if more to go ! 7744: bnequ befc1 ! 7745: # ! 7746: # HERE AFTER CONVERTING ALL THE ARGUMENTS ! 7747: # ! 7748: movl (sp)+,r10 # restore efblk pointer ! 7749: movl 4*fargs(r10),r6 # get number of args ! 7750: jsb sysex # call routine to call external fnc ! 7751: .long exfal # fail if failure ! 7752: #page ! 7753: # ! 7754: # EFBLK (CONTINUED) ! 7755: # ! 7756: # RETURN HERE WITH RESULT IN XR ! 7757: # ! 7758: # FIRST DEFEND AGAINST NON-STANDARD NULL STRING RETURNED ! 7759: # ! 7760: movl 4*efrsl(r10),r7 # get result type id ! 7761: tstl r7 # branch if not unconverted ! 7762: bnequ befa8 ! 7763: cmpl (r9),$b$scl # jump if not a string ! 7764: bnequ befc8 ! 7765: tstl 4*sclen(r9) # return null if null ! 7766: bnequ 0f ! 7767: jmp exnul ! 7768: 0: ! 7769: # ! 7770: # HERE IF CONVERTED RESULT TO CHECK FOR NULL STRING ! 7771: # ! 7772: befa8: cmpl r7,$num01 # jump if not a string ! 7773: bnequ befc8 ! 7774: tstl 4*sclen(r9) # return null if null ! 7775: bnequ 0f ! 7776: jmp exnul ! 7777: 0: ! 7778: # ! 7779: # RETURN IF RESULT IS IN DYNAMIC STORAGE ! 7780: # ! 7781: befc8: cmpl r9,dnamb # jump if not in dynamic storage ! 7782: blssu befc9 ! 7783: cmpl r9,dnamp # return result if already dynamic ! 7784: bgtru 0f ! 7785: jmp exixr ! 7786: 0: ! 7787: # ! 7788: # HERE WE COPY A RESULT INTO THE DYNAMIC REGION ! 7789: # ! 7790: befc9: movl (r9),r6 # get possible type word ! 7791: tstl r7 # jump if unconverted result ! 7792: beqlu bef11 ! 7793: movl $b$scl,r6 # string ! 7794: cmpl r7,$num01 # yes jump ! 7795: beqlu bef10 ! 7796: movl $b$icl,r6 # integer ! 7797: cmpl r7,$num02 # yes jump ! 7798: beqlu bef10 ! 7799: movl $b$rcl,r6 # real ! 7800: # ! 7801: # STORE TYPE WORD IN RESULT ! 7802: # ! 7803: bef10: movl r6,(r9) # stored before copying to dynamic ! 7804: # ! 7805: # MERGE FOR UNCONVERTED RESULT ! 7806: # ! 7807: bef11: jsb blkln # get length of block ! 7808: movl r9,r10 # copy address of old block ! 7809: jsb alloc # allocate dynamic block same size ! 7810: movl r9,-(sp) # set pointer to new block as result ! 7811: jsb sbmvw # copy old block to dynamic block ! 7812: jmp exits # exit with result on stack ! 7813: #page ! 7814: # ! 7815: # EVBLK ! 7816: # ! 7817: # THE ROUTINE FOR AN EVBLK IS NEVER EXECUTED ! 7818: # ! 7819: .align 2 ! 7820: .word bl$ev ! 7821: b$evt: # entry point (evblk) ! 7822: #page ! 7823: # ! 7824: # FFBLK ! 7825: # ! 7826: # THE ROUTINE FOR AN FFBLK IS EXECUTED FROM THE O$FNC ENTRY ! 7827: # TO CALL A FIELD FUNCTION AND EXTRACT A FIELD VALUE/NAME. ! 7828: # ! 7829: # (XL) POINTER TO FFBLK ! 7830: # ! 7831: .align 2 ! 7832: .word bl$ff ! 7833: b$ffc: # entry point (ffblk) ! 7834: movl r10,r9 # copy ffblk pointer ! 7835: movl (r3)+,r8 # load next code word ! 7836: movl (sp),r10 # load pdblk pointer ! 7837: cmpl (r10),$b$pdt # jump if not pdblk at all ! 7838: bnequ bffc2 ! 7839: movl 4*pddfp(r10),r6 # load dfblk pointer from pdblk ! 7840: # ! 7841: # LOOP TO FIND CORRECT FFBLK FOR THIS PDBLK ! 7842: # ! 7843: bffc1: cmpl r6,4*ffdfp(r9) # jump if this is the correct ffblk ! 7844: beqlu bffc3 ! 7845: movl 4*ffnxt(r9),r9 # else link to next ffblk on chain ! 7846: tstl r9 # loop back if another entry to check ! 7847: bnequ bffc1 ! 7848: # ! 7849: # HERE FOR BAD ARGUMENT ! 7850: # ! 7851: bffc2: jmp er_041 # field function argument is wrong datatype ! 7852: #page ! 7853: # ! 7854: # FFBLK (CONTINUED) ! 7855: # ! 7856: # HERE AFTER LOCATING CORRECT FFBLK ! 7857: # ! 7858: bffc3: movl 4*ffofs(r9),r6 # load field offset ! 7859: cmpl r8,$ofne$ # jump if called by name ! 7860: beqlu bffc5 ! 7861: addl2 r6,r10 # else point to value field ! 7862: movl (r10),r9 # load value ! 7863: cmpl (r9),$b$trt # jump if not trapped ! 7864: bnequ bffc4 ! 7865: subl2 r6,r10 # else restore name base,offset ! 7866: movl r8,(sp) # save next code word over pdblk ptr ! 7867: jsb acess # access value ! 7868: .long exfal # fail if access fails ! 7869: movl (sp),r8 # restore next code word ! 7870: # ! 7871: # HERE AFTER GETTING VALUE IN (XR) ! 7872: # ! 7873: bffc4: movl r9,(sp) # store value on stack (over pdblk) ! 7874: movl r8,r9 # copy next code word ! 7875: movl (r9),r10 # load entry address ! 7876: movl r10,r11 # jump to routine for next code word ! 7877: jmp (r11) ! 7878: # ! 7879: # HERE IF CALLED BY NAME ! 7880: # ! 7881: bffc5: movl r6,-(sp) # store name offset (base is set) ! 7882: jmp exits # exit with name on stack ! 7883: #page ! 7884: # ! 7885: # ICBLK ! 7886: # ! 7887: # THE ROUTINE FOR ICBLK IS EXECUTED FROM THE GENERATED ! 7888: # CODE TO LOAD AN INTEGER VALUE ONTO THE STACK. ! 7889: # ! 7890: # (XR) POINTER TO ICBLK ! 7891: # ! 7892: .align 2 ! 7893: .word bl$ic ! 7894: b$icl: # entry point (icblk) ! 7895: jmp exixr # stack xr and obey next code word ! 7896: #page ! 7897: # ! 7898: # KVBLK ! 7899: # ! 7900: # THE ROUTINE FOR A KVBLK IS NEVER EXECUTED. ! 7901: # ! 7902: .align 2 ! 7903: .word bl$kv ! 7904: b$kvt: # entry point (kvblk) ! 7905: #page ! 7906: # ! 7907: # NMBLK ! 7908: # ! 7909: # THE ROUTINE FOR A NMBLK IS EXECUTED FROM THE GENERATED ! 7910: # CODE FOR THE CASE OF LOADING A NAME ONTO THE STACK ! 7911: # WHERE THE NAME IS THAT OF A NATURAL VARIABLE WHICH CAN ! 7912: # BE PREEVALUATED AT COMPILE TIME. ! 7913: # ! 7914: # (XR) POINTER TO NMBLK ! 7915: # ! 7916: .align 2 ! 7917: .word bl$nm ! 7918: b$nml: # entry point (nmblk) ! 7919: jmp exixr # stack xr and obey next code word ! 7920: #page ! 7921: # ! 7922: # PDBLK ! 7923: # ! 7924: # THE ROUTINE FOR A PDBLK IS NEVER EXECUTED ! 7925: # ! 7926: .align 2 ! 7927: .word bl$pd ! 7928: b$pdt: # entry point (pdblk) ! 7929: #page ! 7930: # ! 7931: # PFBLK ! 7932: # ! 7933: # THE ROUTINE FOR A PFBLK IS EXECUTED FROM THE ENTRY O$FNC ! 7934: # TO CALL A PROGRAM DEFINED FUNCTION. ! 7935: # ! 7936: # (XL) POINTER TO PFBLK ! 7937: # ! 7938: # THE FOLLOWING STACK ENTRIES ARE MADE BEFORE PASSING ! 7939: # CONTROL TO THE PROGRAM DEFINED FUNCTION. ! 7940: # ! 7941: # SAVED VALUE OF FIRST ARGUMENT ! 7942: # . ! 7943: # SAVED VALUE OF LAST ARGUMENT ! 7944: # SAVED VALUE OF FIRST LOCAL ! 7945: # . ! 7946: # SAVED VALUE OF LAST LOCAL ! 7947: # SAVED VALUE OF FUNCTION NAME ! 7948: # SAVED CODE BLOCK PTR (R$COD) ! 7949: # SAVED CODE POINTER (-R$COD) ! 7950: # SAVED VALUE OF FLPRT ! 7951: # SAVED VALUE OF FLPTR ! 7952: # POINTER TO PFBLK ! 7953: # FLPTR --------------- ZERO (TO BE OVERWRITTEN WITH OFFS) ! 7954: # ! 7955: .align 2 ! 7956: .word bl$pf ! 7957: b$pfc: # entry point (pfblk) ! 7958: movl r10,bpfpf # save pfblk ptr (need not be reloc) ! 7959: movl r10,r9 # copy for the moment ! 7960: movl 4*pfvbl(r9),r10 # point to vrblk for function ! 7961: # ! 7962: # LOOP TO FIND OLD VALUE OF FUNCTION ! 7963: # ! 7964: bpf01: movl r10,r7 # save pointer ! 7965: movl 4*vrval(r10),r10# load value ! 7966: cmpl (r10),$b$trt # loop if trblk ! 7967: beqlu bpf01 ! 7968: # ! 7969: # SET VALUE TO NULL AND SAVE OLD FUNCTION VALUE ! 7970: # ! 7971: movl r10,bpfsv # save old value ! 7972: movl r7,r10 # point back to block with value ! 7973: movl $nulls,4*vrval(r10) # set value to null ! 7974: movl 4*fargs(r9),r6 # load number of arguments ! 7975: addl2 $4*pfarg,r9 # point to pfarg entries ! 7976: tstl r6 # jump if no arguments ! 7977: beqlu bpf04 ! 7978: movl sp,r10 # ptr to last arg ! 7979: moval 0[r6],r6 # convert no. of args to bytes offset ! 7980: addl2 r6,r10 # point before first arg ! 7981: movl r10,bpfxt # remember arg pointer ! 7982: #page ! 7983: # ! 7984: # PFBLK (CONTINUED) ! 7985: # ! 7986: # LOOP TO SAVE OLD ARGUMENT VALUES AND SET NEW ONES ! 7987: # ! 7988: bpf02: movl (r9)+,r10 # load vrblk ptr for next argument ! 7989: # ! 7990: # LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE ! 7991: # ! 7992: bpf03: movl r10,r8 # save pointer ! 7993: movl 4*vrval(r10),r10# load next value ! 7994: cmpl (r10),$b$trt # loop back if trblk ! 7995: beqlu bpf03 ! 7996: # ! 7997: # SAVE OLD VALUE AND GET NEW VALUE ! 7998: # ! 7999: movl r10,r6 # keep old value ! 8000: movl bpfxt,r10 # point before next stacked arg ! 8001: movl -(r10),r7 # load argument (new value) ! 8002: movl r6,(r10) # save old value ! 8003: movl r10,bpfxt # keep arg ptr for next time ! 8004: movl r8,r10 # point back to block with value ! 8005: movl r7,4*vrval(r10) # set new value ! 8006: cmpl sp,bpfxt # loop if not all done ! 8007: bnequ bpf02 ! 8008: # ! 8009: # NOW PROCESS LOCALS ! 8010: # ! 8011: bpf04: movl bpfpf,r10 # restore pfblk pointer ! 8012: movl 4*pfnlo(r10),r6 # load number of locals ! 8013: tstl r6 # jump if no locals ! 8014: beqlu bpf07 ! 8015: movl $nulls,r7 # get null constant ! 8016: # set local counter ! 8017: # ! 8018: # LOOP TO PROCESS LOCALS ! 8019: # ! 8020: bpf05: movl (r9)+,r10 # load vrblk ptr for next local ! 8021: # ! 8022: # LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE ! 8023: # ! 8024: bpf06: movl r10,r8 # save pointer ! 8025: movl 4*vrval(r10),r10# load next value ! 8026: cmpl (r10),$b$trt # loop back if trblk ! 8027: beqlu bpf06 ! 8028: # ! 8029: # SAVE OLD VALUE AND SET NULL AS NEW VALUE ! 8030: # ! 8031: movl r10,-(sp) # stack old value ! 8032: movl r8,r10 # point back to block with value ! 8033: movl r7,4*vrval(r10) # set null as new value ! 8034: sobgtr r6,bpf05 # loop till all locals processed ! 8035: #page ! 8036: # ! 8037: # PFBLK (CONTINUED) ! 8038: # ! 8039: # HERE AFTER PROCESSING ARGUMENTS AND LOCALS ! 8040: # ! 8041: bpf07: clrl r9 # zero reg xr in case ! 8042: tstl kvpfl # skip if profiling is off ! 8043: beqlu bpf7c ! 8044: cmpl kvpfl,$num02 # branch on type of profile ! 8045: beqlu bpf7a ! 8046: # ! 8047: # HERE IF &PROFILE = 1 ! 8048: # ! 8049: jsb systm # get current time ! 8050: movl r5,pfetm # save for a sec ! 8051: subl2 pfstm,r5 # find time used by caller ! 8052: jsb icbld # build into an icblk ! 8053: movl pfetm,r5 # reload current time ! 8054: jmp bpf7b # merge ! 8055: # ! 8056: # HERE IF &PROFILE = 2 ! 8057: # ! 8058: bpf7a: movl pfstm,r5 # get start time of calling stmt ! 8059: jsb icbld # assemble an icblk round it ! 8060: jsb systm # get now time ! 8061: # ! 8062: # BOTH TYPES OF PROFILE MERGE HERE ! 8063: # ! 8064: bpf7b: movl r5,pfstm # set start time of 1st func stmt ! 8065: movl sp,pffnc # flag function entry ! 8066: # ! 8067: # NO PROFILING MERGES HERE ! 8068: # ! 8069: bpf7c: movl r9,-(sp) # stack icblk ptr (or zero) ! 8070: movl r$cod,r6 # load old code block pointer ! 8071: movl r3,r7 # get code pointer ! 8072: subl2 r6,r7 # make code pointer into offset ! 8073: movl bpfpf,r10 # recall pfblk pointer ! 8074: movl bpfsv,-(sp) # stack old value of function name ! 8075: movl r6,-(sp) # stack code block pointer ! 8076: movl r7,-(sp) # stack code offset ! 8077: movl flprt,-(sp) # stack old flprt ! 8078: movl flptr,-(sp) # stack old failure pointer ! 8079: movl r10,-(sp) # stack pointer to pfblk ! 8080: clrl -(sp) # dummy zero entry for fail return ! 8081: jsb sbchk # check for stack overflow ! 8082: movl sp,flptr # set new fail return value ! 8083: movl sp,flprt # set new flprt ! 8084: movl kvtra,r6 # load trace value ! 8085: addl2 kvftr,r6 # add ftrace value ! 8086: tstl r6 # jump if tracing possible ! 8087: bnequ bpf09 ! 8088: incl kvfnc # else bump fnclevel ! 8089: # ! 8090: # HERE TO ACTUALLY JUMP TO FUNCTION ! 8091: # ! 8092: bpf08: movl 4*pfcod(r10),r9 # point to code ! 8093: movl (r9),r11 # off to execute function ! 8094: jmp (r11) ! 8095: # ! 8096: # HERE IF TRACING IS POSSIBLE ! 8097: # ! 8098: bpf09: movl 4*pfctr(r10),r9 # load possible call trace trblk ! 8099: movl 4*pfvbl(r10),r10# load vrblk pointer for function ! 8100: movl $4*vrval,r6 # set name offset for variable ! 8101: tstl kvtra # jump if trace mode is off ! 8102: beqlu bpf10 ! 8103: tstl r9 # or if there is no call trace ! 8104: beqlu bpf10 ! 8105: # ! 8106: # HERE IF CALL TRACED ! 8107: # ! 8108: decl kvtra # decrement trace count ! 8109: tstl 4*trfnc(r9) # jump if print trace ! 8110: beqlu bpf11 ! 8111: jsb trxeq # execute function type trace ! 8112: #page ! 8113: # ! 8114: # PFBLK (CONTINUED) ! 8115: # ! 8116: # HERE TO TEST FOR FTRACE TRACE ! 8117: # ! 8118: bpf10: tstl kvftr # jump if ftrace is off ! 8119: beqlu bpf16 ! 8120: decl kvftr # else decrement ftrace ! 8121: # ! 8122: # HERE FOR PRINT TRACE ! 8123: # ! 8124: bpf11: jsb prtsn # print statement number ! 8125: jsb prtnm # print function name ! 8126: movl $ch$pp,r6 # load left paren ! 8127: jsb prtch # print left paren ! 8128: movl 4*1(sp),r10 # recover pfblk pointer ! 8129: tstl 4*fargs(r10) # skip if no arguments ! 8130: beqlu bpf15 ! 8131: clrl r7 # else set argument counter ! 8132: jmp bpf13 # jump into loop ! 8133: # ! 8134: # LOOP TO PRINT ARGUMENT VALUES ! 8135: # ! 8136: bpf12: movl $ch$cm,r6 # load comma ! 8137: jsb prtch # print to separate from last arg ! 8138: # ! 8139: # MERGE HERE FIRST TIME (NO COMMA REQUIRED) ! 8140: # ! 8141: bpf13: movl r7,(sp) # save arg ctr (over failoffs is ok) ! 8142: moval 0[r7],r7 # convert to byte offset ! 8143: addl2 r7,r10 # point to next argument pointer ! 8144: movl 4*pfarg(r10),r9 # load next argument vrblk ptr ! 8145: subl2 r7,r10 # restore pfblk pointer ! 8146: movl 4*vrval(r9),r9 # load next value ! 8147: jsb prtvl # print argument value ! 8148: #page ! 8149: # ! 8150: # HERE AFTER DEALING WITH ONE ARGUMENT ! 8151: # ! 8152: movl (sp),r7 # restore argument counter ! 8153: incl r7 # increment argument counter ! 8154: cmpl r7,4*fargs(r10) # loop if more to print ! 8155: blssu bpf12 ! 8156: # ! 8157: # MERGE HERE IN NO ARGS CASE TO PRINT PAREN ! 8158: # ! 8159: bpf15: movl $ch$rp,r6 # load right paren ! 8160: jsb prtch # print to terminate output ! 8161: jsb prtnl # terminate print line ! 8162: # ! 8163: # MERGE HERE TO EXIT WITH TEST FOR FNCLEVEL TRACE ! 8164: # ! 8165: bpf16: incl kvfnc # increment fnclevel ! 8166: movl r$fnc,r10 # load ptr to possible trblk ! 8167: jsb ktrex # call keyword trace routine ! 8168: # ! 8169: # CALL FUNCTION AFTER TRACE TESTS COMPLETE ! 8170: # ! 8171: movl 4*1(sp),r10 # restore pfblk pointer ! 8172: jmp bpf08 # jump back to execute function ! 8173: #page ! 8174: # ! 8175: # RCBLK ! 8176: # ! 8177: # THE ROUTINE FOR AN RCBLK IS EXECUTED FROM THE GENERATED ! 8178: # CODE TO LOAD A REAL VALUE ONTO THE STACK. ! 8179: # ! 8180: # (XR) POINTER TO RCBLK ! 8181: # ! 8182: .align 2 ! 8183: .word bl$rc ! 8184: b$rcl: # entry point (rcblk) ! 8185: jmp exixr # stack xr and obey next code word ! 8186: #page ! 8187: # ! 8188: # SCBLK ! 8189: # ! 8190: # THE ROUTINE FOR AN SCBLK IS EXECUTED FROM THE GENERATED ! 8191: # CODE TO LOAD A STRING VALUE ONTO THE STACK. ! 8192: # ! 8193: # (XR) POINTER TO SCBLK ! 8194: # ! 8195: .align 2 ! 8196: .word bl$sc ! 8197: b$scl: # entry point (scblk) ! 8198: jmp exixr # stack xr and obey next code word ! 8199: #page ! 8200: # ! 8201: # TBBLK ! 8202: # ! 8203: # THE ROUTINE FOR A TBBLK IS NEVER EXECUTED ! 8204: # ! 8205: .align 2 ! 8206: .word bl$tb ! 8207: b$tbt: # entry point (tbblk) ! 8208: #page ! 8209: # ! 8210: # TEBLK ! 8211: # ! 8212: # THE ROUTINE FOR A TEBLK IS NEVER EXECUTED ! 8213: # ! 8214: .align 2 ! 8215: .word bl$te ! 8216: b$tet: # entry point (teblk) ! 8217: #page ! 8218: # ! 8219: # VCBLK ! 8220: # ! 8221: # THE ROUTINE FOR A VCBLK IS NEVER EXECUTED ! 8222: # ! 8223: .align 2 ! 8224: .word bl$vc ! 8225: b$vct: # entry point (vcblk) ! 8226: #page ! 8227: # ! 8228: # VRBLK ! 8229: # ! 8230: # THE VRBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE. ! 8231: # THERE ARE SIX ENTRIES FOR VRBLK COVERING VARIOUS CASES ! 8232: # ! 8233: .align 2 ! 8234: .word bl$$i ! 8235: b$vr$: # mark start of vrblk entry points ! 8236: # ! 8237: # ENTRY FOR VRGET (TRAPPED CASE). THIS ROUTINE IS CALLED ! 8238: # FROM THE GENERATED CODE TO LOAD THE VALUE OF A VARIABLE. ! 8239: # THIS ENTRY POINT IS USED IF AN ACCESS TRACE OR INPUT ! 8240: # ASSOCIATION IS CURRENTLY ACTIVE. ! 8241: # ! 8242: # (XR) POINTER TO VRGET FIELD OF VRBLK ! 8243: # ! 8244: .align 2 ! 8245: .word bl$$i ! 8246: b$vra: # entry point ! 8247: movl r9,r10 # copy name base (vrget = 0) ! 8248: movl $4*vrval,r6 # set name offset ! 8249: jsb acess # access value ! 8250: .long exfal # fail if access fails ! 8251: jmp exixr # else exit with result in xr ! 8252: #page ! 8253: # ! 8254: # VRBLK (CONTINUED) ! 8255: # ! 8256: # ENTRY FOR VRSTO (ERROR CASE. THIS ROUTINE IS CALLED FROM ! 8257: # THE EXECUTED CODE FOR AN ATTEMPT TO MODIFY THE VALUE ! 8258: # OF A PROTECTED (PATTERN VALUED) NATURAL VARIABLE. ! 8259: # ! 8260: b$vre: # entry point ! 8261: jmp er_042 # attempt to change value of protected variable ! 8262: #page ! 8263: # ! 8264: # VRBLK (CONTINUED) ! 8265: # ! 8266: # ENTRY FOR VRTRA (UNTRAPPED CASE). THIS ROUTINE IS CALLED ! 8267: # FROM THE EXECUTED CODE TO TRANSFER TO A LABEL. ! 8268: # ! 8269: # (XR) POINTER TO VRTRA FIELD OF VRBLK ! 8270: # ! 8271: b$vrg: # entry point ! 8272: movl 4*vrlbo(r9),r9 # load code pointer ! 8273: movl (r9),r10 # load entry address ! 8274: movl r10,r11 # jump to routine for next code word ! 8275: jmp (r11) ! 8276: #page ! 8277: # ! 8278: # VRBLK (CONTINUED) ! 8279: # ! 8280: # ENTRY FOR VRGET (UNTRAPPED CASE). THIS ROUTINE IS CALLED ! 8281: # FROM THE GENERATED CODE TO LOAD THE VALUE OF A VARIABLE. ! 8282: # ! 8283: # (XR) POINTS TO VRGET FIELD OF VRBLK ! 8284: # ! 8285: b$vrl: # entry point ! 8286: movl 4*vrval(r9),-(sp)# load value onto stack (vrget = 0) ! 8287: jmp exits # obey next code word ! 8288: #page ! 8289: # ! 8290: # VRBLK (CONTINUED) ! 8291: # ! 8292: # ENTRY FOR VRSTO (UNTRAPPED CASE). THIS ROUTINE IS CALLED ! 8293: # FROM THE GENERATED CODE TO STORE THE VALUE OF A VARIABLE. ! 8294: # ! 8295: # (XR) POINTER TO VRSTO FIELD OF VRBLK ! 8296: # ! 8297: b$vrs: # entry point ! 8298: movl (sp),4*vrvlo(r9)# store value, leave on stack ! 8299: jmp exits # obey next code word ! 8300: #page ! 8301: # ! 8302: # VRBLK (CONTINUED) ! 8303: # ! 8304: # VRTRA (TRAPPED CASE). THIS ROUTINE IS CALLED FROM THE ! 8305: # GENERATED CODE TO TRANSFER TO A LABEL WHEN A LABEL ! 8306: # TRACE IS CURRENTLY ACTIVE. ! 8307: # ! 8308: b$vrt: # entry point ! 8309: subl2 $4*vrtra,r9 # point back to start of vrblk ! 8310: movl r9,r10 # copy vrblk pointer ! 8311: movl $4*vrval,r6 # set name offset ! 8312: movl 4*vrlbl(r10),r9 # load pointer to trblk ! 8313: tstl kvtra # jump if trace is off ! 8314: beqlu bvrt2 ! 8315: decl kvtra # else decrement trace count ! 8316: tstl 4*trfnc(r9) # jump if print trace case ! 8317: beqlu bvrt1 ! 8318: jsb trxeq # else execute full trace ! 8319: jmp bvrt2 # merge to jump to label ! 8320: # ! 8321: # HERE FOR PRINT TRACE -- PRINT COLON ( LABEL NAME ) ! 8322: # ! 8323: bvrt1: jsb prtsn # print statement number ! 8324: movl r10,r9 # copy vrblk pointer ! 8325: movl $ch$cl,r6 # colon ! 8326: jsb prtch # print it ! 8327: movl $ch$pp,r6 # left paren ! 8328: jsb prtch # print it ! 8329: jsb prtvn # print label name ! 8330: movl $ch$rp,r6 # right paren ! 8331: jsb prtch # print it ! 8332: jsb prtnl # terminate line ! 8333: movl 4*vrlbl(r10),r9 # point back to trblk ! 8334: # ! 8335: # MERGE HERE TO JUMP TO LABEL ! 8336: # ! 8337: bvrt2: movl 4*trlbl(r9),r9 # load pointer to actual code ! 8338: movl (r9),r11 # execute statement at label ! 8339: jmp (r11) ! 8340: #page ! 8341: # ! 8342: # VRBLK (CONTINUED) ! 8343: # ! 8344: # ENTRY FOR VRSTO (TRAPPED CASE). THIS ROUTINE IS CALLED ! 8345: # FROM THE GENERATED CODE TO STORE THE VALUE OF A VARIABLE. ! 8346: # THIS ENTRY IS USED WHEN A VALUE TRACE OR OUTPUT ! 8347: # ASSOCIATION IS CURRENTLY ACTIVE. ! 8348: # ! 8349: # (XR) POINTER TO VRSTO FIELD OF VRBLK ! 8350: # ! 8351: b$vrv: # entry point ! 8352: movl (sp),r7 # load value (leave copy on stack) ! 8353: subl2 $4*vrsto,r9 # point to vrblk ! 8354: movl r9,r10 # copy vrblk pointer ! 8355: movl $4*vrval,r6 # set offset ! 8356: jsb asign # call assignment routine ! 8357: .long exfal # fail if assignment fails ! 8358: jmp exits # else return with result on stack ! 8359: #page ! 8360: # ! 8361: # XNBLK ! 8362: # ! 8363: # THE ROUTINE FOR AN XNBLK IS NEVER EXECUTED ! 8364: # ! 8365: .align 2 ! 8366: .word bl$xn ! 8367: b$xnt: # entry point (xnblk) ! 8368: #page ! 8369: # ! 8370: # XRBLK ! 8371: # ! 8372: # THE ROUTINE FOR AN XRBLK IS NEVER EXECUTED ! 8373: # ! 8374: .align 2 ! 8375: .word bl$xr ! 8376: b$xrt: # entry point (xrblk) ! 8377: # ! 8378: # MARK ENTRY ADDRESS PAST LAST BLOCK ACTION ROUTINE ! 8379: # ! 8380: .align 2 ! 8381: .word bl$$i ! 8382: b$yyy: # last block routine entry point ! 8383: #title s p i t b o l -- pattern matching routines ! 8384: # ! 8385: # THE FOLLOWING SECTION CONSISTS OF THE PATTERN MATCHING ! 8386: # ROUTINES. ALL PATTERN NODES CONTAIN A POINTER (PCODE) ! 8387: # TO ONE OF THE ROUTINES IN THIS SECTION (P$XXX). ! 8388: # ! 8389: # NOTE THAT THIS SECTION FOLLOWS THE B$XXX ROUTINES TO ! 8390: # ENABLE A FAST TEST FOR THE PATTERN DATATYPE. ! 8391: # ! 8392: .align 2 ! 8393: .word bl$$i ! 8394: p$aaa: # entry to mark first pattern ! 8395: # ! 8396: # ! 8397: # THE ENTRY CONDITIONS TO THE MATCH ROUTINE ARE AS FOLLOWS ! 8398: # (SEE O$PMN, O$PMV, O$PMS AND PROCEDURE MATCH). ! 8399: # ! 8400: # STACK CONTENTS. ! 8401: # ! 8402: # NAME BASE (O$PMN ONLY) ! 8403: # NAME OFFSET (O$PMN ONLY) ! 8404: # TYPE (0-O$PMN, 1-O$PMV, 2-O$PMS) ! 8405: # PMHBS --------------- INITIAL CURSOR (ZERO) ! 8406: # INITIAL NODE POINTER ! 8407: # XS ------------------ =NDABO (ANCHORED), =NDUNA (UNANCH) ! 8408: # ! 8409: # REGISTER VALUES. ! 8410: # ! 8411: # (XS) SET AS SHOWN IN STACK DIAGRAM ! 8412: # (XR) POINTER TO INITIAL PATTERN NODE ! 8413: # (WB) INITIAL CURSOR (ZERO) ! 8414: # ! 8415: # GLOBAL PATTERN VALUES ! 8416: # ! 8417: # R$PMS POINTER TO SUBJECT STRING SCBLK ! 8418: # PMSSL LENGTH OF SUBJECT STRING IN CHARS ! 8419: # PMDFL DOT FLAG, INITIALLY ZERO ! 8420: # PMHBS SET AS SHOWN IN STACK DIAGRAM ! 8421: # ! 8422: # CONTROL IS PASSED BY BRANCHING THROUGH THE PCODE ! 8423: # FIELD OF THE INITIAL PATTERN NODE (BRI (XR)). ! 8424: #page ! 8425: # ! 8426: # DESCRIPTION OF ALGORITHM ! 8427: # ! 8428: # A PATTERN STRUCTURE IS REPRESENTED AS A LINKED GRAPH ! 8429: # OF NODES WITH THE FOLLOWING STRUCTURE. ! 8430: # ! 8431: # +------------------------------------+ ! 8432: # I PCODE I ! 8433: # +------------------------------------+ ! 8434: # I PTHEN I ! 8435: # +------------------------------------+ ! 8436: # I PARM1 I ! 8437: # +------------------------------------+ ! 8438: # I PARM2 I ! 8439: # +------------------------------------+ ! 8440: # ! 8441: # PCODE IS A POINTER TO THE ROUTINE WHICH WILL PERFORM ! 8442: # THE MATCH OF THIS PARTICULAR NODE TYPE. ! 8443: # ! 8444: # PTHEN IS A POINTER TO THE SUCCESSOR NODE. I.E. THE NODE ! 8445: # TO BE MATCHED IF THE ATTEMPT TO MATCH THIS NODE SUCCEEDS. ! 8446: # IF THIS IS THE LAST NODE OF THE PATTERN PTHEN POINTS ! 8447: # TO THE DUMMY NODE NDNTH WHICH INITIATES PATTERN EXIT. ! 8448: # ! 8449: # PARM1, PARM2 ARE PARAMETERS WHOSE USE VARIES WITH THE ! 8450: # PARTICULAR NODE. THEY ARE ONLY PRESENT IF REQUIRED. ! 8451: # ! 8452: # ALTERNATIVES ARE HANDLED WITH THE SPECIAL ALTERNATIVE ! 8453: # NODE WHOSE PARAMETER POINTS TO THE NODE TO BE MATCHED ! 8454: # IF THERE IS A FAILURE ON THE SUCCESSOR PATH. ! 8455: # ! 8456: # THE FOLLOWING EXAMPLE ILLUSTRATES THE MANNER IN WHICH ! 8457: # THE STRUCTURE IS BUILT UP. THE PATTERN IS ! 8458: # ! 8459: # (A / B / C) (D / E) WHERE / IS ALTERNATION ! 8460: # ! 8461: # IN THE DIAGRAM, THE NODE MARKED + REPRESENTS AN ! 8462: # ALTERNATIVE NODE AND THE DOTTED LINE FROM A + NODE ! 8463: # REPRESENTS THE PARAMETER POINTER TO THE ALTERNATIVE. ! 8464: # ! 8465: # +---+ +---+ +---+ +---+ ! 8466: # I + I-----I A I-----I + I-----I D I----- ! 8467: # +---+ +---+ I +---+ +---+ ! 8468: # . I . ! 8469: # . I . ! 8470: # +---+ +---+ I +---+ ! 8471: # I + I-----I B I--I I E I----- ! 8472: # +---+ +---+ I +---+ ! 8473: # . I ! 8474: # . I ! 8475: # +---+ I ! 8476: # I C I------------I ! 8477: # +---+ ! 8478: #page ! 8479: # ! 8480: # DURING THE MATCH, THE REGISTERS ARE USED AS FOLLOWS. ! 8481: # ! 8482: # (XR) POINTS TO THE CURRENT NODE ! 8483: # (XL) SCRATCH ! 8484: # (XS) MAIN STACK POINTER ! 8485: # (WB) CURSOR (NUMBER OF CHARS MATCHED) ! 8486: # (WA,WC) SCRATCH ! 8487: # ! 8488: # TO KEEP TRACK OF ALTERNATIVES, THE MAIN STACK IS USED AS ! 8489: # A HISTORY STACK AND CONTAINS TWO WORD ENTRIES. ! 8490: # ! 8491: # WORD 1 SAVED CURSOR VALUE ! 8492: # WORD 2 NODE TO MATCH ON FAILURE ! 8493: # ! 8494: # WHEN A FAILURE OCCURS, THE MOST RECENT ENTRY ON THIS ! 8495: # STACK IS POPPED OFF TO RESTORE THE CURSOR AND POINT ! 8496: # TO THE NODE TO BE MATCHED AS AN ALTERNATIVE. THE ENTRY ! 8497: # AT THE BOTTOM OF THE STACK POINTS TO THE FOLLOWING ! 8498: # SPECIAL NODES DEPENDING ON THE SCAN MODE. ! 8499: # ! 8500: # ANCHORED MODE THE BOTTOM ENTRY POINTS TO THE ! 8501: # SPECIAL NODE NDABO WHICH CAUSES AN ! 8502: # ABORT. THE CURSOR VALUE STORED ! 8503: # WITH THIS ENTRY IS ALWAYS ZERO. ! 8504: # ! 8505: # UNANCHORED MODE THE BOTTOM ENTRY POINTS TO THE ! 8506: # SPECIAL NODE NDUNA WHICH MOVES THE ! 8507: # ANCHOR POINT AND RESTARTS THE MATCH ! 8508: # THE CURSOR SAVED WITH THIS ENTRY ! 8509: # IS THE NUMBER OF CHARACTERS WHICH ! 8510: # LIE BEFORE THE INITIAL ANCHOR POINT ! 8511: # (I.E. THE NUMBER OF ANCHOR MOVES). ! 8512: # THIS ENTRY IS THREE WORDS LONG AND ! 8513: # ALSO CONTAINS THE INITIAL PATTERN. ! 8514: # ! 8515: # ENTRIES ARE MADE ON THIS HISTORY STACK BY ALTERNATIVE ! 8516: # NODES AND BY SOME SPECIAL COMPOUD PATTERNS AS DESCRIBED ! 8517: # LATER ON. THE FOLLOWING GLOBAL LOCATIONS ARE USED DURING ! 8518: # PATTERN MATCHING. ! 8519: # ! 8520: # R$PMS POINTER TO SUBJECT STRING ! 8521: # PMSSL LENGTH OF SUBJECT STRING ! 8522: # PMDFL FLAG SET NON-ZERO FOR DOT PATTERNS ! 8523: # PMHBS BASE PTR FOR CURRENT HISTORY STACK ! 8524: # ! 8525: # THE FOLLOWING EXIT POINTS ARE AVAILABLE TO MATCH ROUTINES ! 8526: # ! 8527: # SUCCP SUCCESS IN MATCHING CURRENT NODE ! 8528: # FAILP FAILURE IN MATCHING CURRENT NODE ! 8529: #page ! 8530: # ! 8531: # COMPOUND PATTERNS ! 8532: # ! 8533: # SOME PATTERNS HAVE IMPLICIT ALTERNATIVES AND THEIR ! 8534: # REPRESENTATION IN THE PATTERN STRUCTURE CONSISTS OF A ! 8535: # LINKED SET OF NODES AS INDICATED BY THESE DIAGRAMS. ! 8536: # ! 8537: # AS BEFORE, THE + REPRESENTS AN ALTERNATIVE NODE AND ! 8538: # THE DOTTED LINE FROM A + NODE IS THE PARAMETER POINTER ! 8539: # TO THE ALTERNATIVE PATTERN. ! 8540: # ! 8541: # ARB ! 8542: # --- ! 8543: # ! 8544: # +---+ THIS NODE (P$ARB) MATCHES NULL ! 8545: # I B I----- AND STACKS CURSOR, SUCCESSOR PTR, ! 8546: # +---+ CURSOR (COPY) AND A PTR TO NDARC. ! 8547: # ! 8548: # ! 8549: # ! 8550: # ! 8551: # BAL ! 8552: # --- ! 8553: # ! 8554: # +---+ THE P$BAL NODE SCANS A BALANCED ! 8555: # I B I----- STRING AND THEN STACKS A POINTER ! 8556: # +---+ TO ITSELF ON THE HISTORY STACK. ! 8557: #page ! 8558: # ! 8559: # COMPOUND PATTERN STRUCTURES (CONTINUED) ! 8560: # ! 8561: # ! 8562: # ARBNO ! 8563: # ----- ! 8564: # ! 8565: # +---+ THIS ALTERNATIVE NODE MATCHES NULL ! 8566: # +----I + I----- THE FIRST TIME AND STACKS A POINTER ! 8567: # I +---+ TO THE ARGUMENT PATTERN X. ! 8568: # I . ! 8569: # I . ! 8570: # I +---+ NODE (P$ABA) TO STACK CURSOR ! 8571: # I I A I AND HISTORY STACK BASE PTR. ! 8572: # I +---+ ! 8573: # I I ! 8574: # I I ! 8575: # I +---+ THIS IS THE ARGUMENT PATTERN. AS ! 8576: # I I X I INDICATED, THE SUCCESSOR OF THE ! 8577: # I +---+ PATTERN IS THE P$ABC NODE ! 8578: # I I ! 8579: # I I ! 8580: # I +---+ THIS NODE (P$ABC) POPS PMHBS, ! 8581: # +----I C I STACKS OLD PMHBS AND PTR TO NDABD ! 8582: # +---+ (UNLESS OPTIMISATION HAS OCCURRED) ! 8583: # ! 8584: # STRUCTURE AND EXECUTION OF THIS PATTERN RESEMBLE THOSE OF ! 8585: # RECURSIVE PATTERN MATCHING AND IMMEDIATE ASSIGNMENT. ! 8586: # THE ALTERNATIVE NODE AT THE HEAD OF THE STRUCTURE MATCHES ! 8587: # NULL INITIALLY BUT ON SUBSEQUENT FAILURE ENSURES ATTEMPT ! 8588: # TO MATCH THE ARGUMENT. BEFORE THE ARGUMENT IS MATCHED ! 8589: # P$ABA STACKS THE CURSOR,PMHBS AND A PTR TO P$ABB. IF ! 8590: # THE ARGUMENT CANT BE MATCHED , P$ABB REMOVES THIS SPECIAL ! 8591: # STACK ENTRY AND FAILS. ! 8592: # IF ARGUMENT IS MATCHED , P$ABC RESTORES THE OUTER PMHBS ! 8593: # VALUE (SAVED BY P$ABA) . THEN IF THE ARGUMENT HAS LEFT ! 8594: # ALTERNATIVES ON STACK IT STACKS THE INNER VALUE OF PMHBS ! 8595: # AND A PTR TO NDABD. IF ARGUMENT LEFT NOTHING ON THE STACK ! 8596: # IT OPTIMISES BY REMOVING ITEMS STACKED BY P$ABA. FINALLY ! 8597: # A CHECK IS MADE THAT ARGUMENT MATCHED MORE THAN THE NULL ! 8598: # STRING (CHECK IS INTENDED TO PREVENT USELESS LOOPING). ! 8599: # IF SO THE SUCCESSOR IS AGAIN THE ALTERNATIVE NODE AT THE ! 8600: # HEAD OF THE STRUCTURE , ENSURING A POSSIBLE EXTRA ATTEMPT ! 8601: # TO MATCH THE ARG IF NECESSARY. IF NOT , THE SUCCESSOR TO ! 8602: # ALTERNATIVE IS TAKEN SO AS TO TERMINATE THE LOOP. P$ABD ! 8603: # RESTORES INNER PMHBS PTR AND FAILS , THUS TRYING TO MATCH ! 8604: # ALTERNATIVES LEFT BY THE ARBNO ARGUMENT. ! 8605: #page ! 8606: # ! 8607: # COMPOUND PATTERN STRUCTURES (CONTINUED) ! 8608: # ! 8609: # BREAKX ! 8610: # ------ ! 8611: # ! 8612: # +---+ THIS NODE IS A BREAK NODE FOR ! 8613: # +----I B I THE ARGUMENT TO BREAKX, IDENTICAL ! 8614: # I +---+ TO AN ORDINARY BREAK NODE. ! 8615: # I I ! 8616: # I I ! 8617: # I +---+ THIS ALTERNATIVE NODE STACKS A ! 8618: # I I + I----- POINTER TO THE BREAKX NODE TO ! 8619: # I +---+ ALLOW FOR SUBSEQUENT FAILURE ! 8620: # I . ! 8621: # I . ! 8622: # I +---+ THIS IS THE BREAKX NODE ITSELF. IT ! 8623: # +----I X I MATCHES ONE CHARACTER AND THEN ! 8624: # +---+ PROCEEDS BACK TO THE BREAK NODE. ! 8625: # ! 8626: # ! 8627: # ! 8628: # ! 8629: # FENCE ! 8630: # ----- ! 8631: # ! 8632: # +---+ THE FENCE NODE MATCHES NULL AND ! 8633: # I F I----- STACKS A POINTER TO NODE NDABO TO ! 8634: # +---+ ABORT ON A SUBSEQUENT REMATCH ! 8635: # ! 8636: # ! 8637: # ! 8638: # ! 8639: # SUCCEED ! 8640: # ------- ! 8641: # ! 8642: # +---+ THE NODE FOR SUCCEED MATCHES NULL ! 8643: # I S I----- AND STACKS A POINTER TO ITSELF ! 8644: # +---+ TO REPEAT THE MATCH ON A FAILURE. ! 8645: #page ! 8646: # ! 8647: # COMPOUND PATTERNS (CONTINUED) ! 8648: # ! 8649: # BINARY DOT (PATTERN ASSIGNMENT) ! 8650: # ------------------------------- ! 8651: # ! 8652: # +---+ THIS NODE (P$PAA) SAVES THE CURRENT ! 8653: # I A I CURSOR AND A POINTER TO THE ! 8654: # +---+ SPECIAL NODE NDPAB ON THE STACK. ! 8655: # I ! 8656: # I ! 8657: # +---+ THIS IS THE STRUCTURE FOR THE ! 8658: # I X I PATTERN LEFT ARGUMENT OF THE ! 8659: # +---+ PATTERN ASSIGNMENT CALL. ! 8660: # I ! 8661: # I ! 8662: # +---+ THIS NODE (P$PAC) SAVES THE CURSOR, ! 8663: # I C I----- A PTR TO ITSELF, THE CURSOR (COPY) ! 8664: # +---+ AND A PTR TO NDPAD ON THE STACK. ! 8665: # ! 8666: # ! 8667: # THE FUNCTION OF THE MATCH ROUTINE FOR NDPAB (P$PAB) ! 8668: # IS SIMPLY TO UNSTACK ITSELF AND FAIL BACK ONTO THE STACK. ! 8669: # ! 8670: # THE MATCH ROUTINE FOR P$PAC ALSO SETS THE GLOBAL PATTERN ! 8671: # FLAG PMDFL NON-ZERO TO INDICATE THAT PATTERN ASSIGNMENTS ! 8672: # MAY HAVE OCCURED IN THE PATTERN MATCH ! 8673: # ! 8674: # IF PMDFL IS SET AT THE END OF THE MATCH (SEE P$NTH), THE ! 8675: # HISTORY STACK IS SCANNED FOR MATCHING NDPAB-NDPAD PAIRS ! 8676: # AND THE CORRESPONDING PATTERN ASSIGNMENTS ARE EXECUTED. ! 8677: # ! 8678: # THE FUNCTION OF THE MATCH ROUTINE FOR NDPAD (P$PAD) ! 8679: # IS SIMPLY TO REMOVE ITS ENTRY FROM THE STACK AND FAIL. ! 8680: # THIS INCLUDES REMOVING THE SPECIAL NODE POINTER STORED ! 8681: # IN ADDITION TO THE STANDARD TWO ENTRIES ON THE STACK. ! 8682: #page ! 8683: # ! 8684: # COMPOUNT PATTERN STRUCTURES (CONTINUED) ! 8685: # ! 8686: # FENCE (FUNCTION) ! 8687: # ---------------- ! 8688: # ! 8689: # +---+ THIS NODE (P$FNA) SAVES THE ! 8690: # I A I CURRENT HISTORY STACK AND A ! 8691: # +---+ POINTER TO NDFNB ON THE STACK. ! 8692: # I ! 8693: # I ! 8694: # +---+ THIS IS THE PATTERN STRUCTURE ! 8695: # I X I GIVEN AS THE ARGUMENT TO THE ! 8696: # +---+ FENCE FUNCTION. ! 8697: # I ! 8698: # I ! 8699: # +---+ THIS NODE P$FNC RESTORES THE OUTER ! 8700: # I C I HISTORY STACK PTR SAVED IN P$FNA, ! 8701: # +---+ AND STACKS THE INNER STACK BASE ! 8702: # PTR AND A POINTER TO NDFND ON THE ! 8703: # STACK. ! 8704: # ! 8705: # NDFNB (F$FNB) SIMPLY IS THE FAILURE EXIT FOR PATTERN ! 8706: # ARGUMENT FAILURE, AND IT POPS ITSELF AND FAILS ONTO THE ! 8707: # STACK. ! 8708: # ! 8709: # THE MATCH ROUTINE P$FNC ALLOWS FOR AN OPTIMIZATION WHEN ! 8710: # THE FENCE PATTERN LEAVES NO ALTERNATIVES. IN THIS CASE, ! 8711: # THE NDFNB ENTRY IS POPPED, AND THE MATCH CONTINUES. ! 8712: # ! 8713: # NDFND (P$FND) IS ENTERED WHEN THE PATTERN FAILS AFTER ! 8714: # GOING THROUGH A NON-OPTIMIZED P$FNC, AND IT POPS THE ! 8715: # STACK BACK PAST THE INNTER STACK BASE CREATED BY P$FNA ! 8716: #page ! 8717: # ! 8718: # COMPOUND PATTERNS (CONTINUED) ! 8719: # ! 8720: # EXPRESSION PATTERNS (RECURSIVE PATTERN MATCHES) ! 8721: # ----------------------------------------------- ! 8722: # ! 8723: # INITIAL ENTRY FOR A PATTERN NODE IS TO THE ROUTINE P$EXA. ! 8724: # IF THE EVALUATED RESULT OF THE EXPRESSION IS ITSELF A ! 8725: # PATTERN, THEN THE FOLLOWING STEPS ARE TAKEN TO ARRANGE ! 8726: # FOR PROPER RECURSIVE PROCESSING. ! 8727: # ! 8728: # 1) A POINTER TO THE CURRENT NODE (THE P$EXA NODE) IS ! 8729: # STORED ON THE HISTORY STACK WITH A DUMMY CURSOR. ! 8730: # ! 8731: # 2) A SPECIAL HISTORY STACK ENTRY IS MADE IN WHICH THE ! 8732: # NODE POINTER POINTS TO NDEXB, AND THE CURSOR VALUE ! 8733: # IS THE SAVED VALUE OF PMHBS ON ENTRY TO THIS NODE. ! 8734: # THE MATCH ROUTINE FOR NDEXB (P$EXB) RESTORES PMHBS ! 8735: # FROM THIS CURSOR ENTRY, POPS OFF THE P$EXA NODE ! 8736: # POINTER AND FAILS. ! 8737: # ! 8738: # 3) THE RESULTING HISTORY STACK POINTER IS SAVED IN ! 8739: # PMHBS TO ESTABLISH A NEW LEVEL OF HISTORY STACK. ! 8740: # ! 8741: # AFTER MATCHING A PATTERN, THE END OF MATCH ROUTINE GETS ! 8742: # CONTROL (P$NTH). THIS ROUTINE PROCEEDS AS FOLLOWS. ! 8743: # ! 8744: # 1) LOAD THE CURRENT VALUE OF PMHBS AND RECOGNIZE THE ! 8745: # OUTER LEVEL CASE BY THE FACT THAT THE ASSOCIATED ! 8746: # CURSOR IN THIS CASE IS THE PATTERN MATCH TYPE CODE ! 8747: # WHICH IS LESS THAN 3. TERMINATE THE MATCH IN THIS ! 8748: # CASE AND CONTINUE EXECUTION OF THE PROGRAM. ! 8749: # ! 8750: # 2) OTHERWISE MAKE A SPECIAL HISTORY STACK ENTRY IN ! 8751: # WHICH THE NODE POINTER POINTS TO THE SPECIAL NODE ! 8752: # NDEXC AND THE CURSOR IS THE CURRENT VALUE OF PMHBS. ! 8753: # THE MATCH ROUTINE FOR NDEXC (P$EXC) RESETS PMHBS TO ! 8754: # THIS (INNER) VALUE AND AND THEN FAILS. ! 8755: # ! 8756: # 3) USING THE HISTORY STACK ENTRY MADE ON STARTING THE ! 8757: # EXPRESSION (ACCESSIBLE WITH THE CURRENT VALUE OF ! 8758: # PMHBS), RESTORE THE P$EXA NODE POINTER AND THE OLD ! 8759: # PMHBS SETTING. TAKE THE SUCCESSOR AND CONTINUE. ! 8760: # ! 8761: # AN OPTIMIZATION IS POSSIBLE IF THE EXPRESSION PATTERN ! 8762: # MAKES NO ENTRIES ON THE HISTORY STACK. IN THIS CASE, ! 8763: # INSTEAD OF BUILDING THE P$EXC NODE IN STEP 2, IT IS MORE ! 8764: # EFFICIENT TO SIMPLY POP OFF THE P$EXB ENTRY AND ITS ! 8765: # ASSOCIATED NODE POINTER. THE EFFECT IS THE SAME. ! 8766: #page ! 8767: # ! 8768: # COMPOUND PATTERNS (CONTINUED) ! 8769: # ! 8770: # BINARY DOLLAR (IMMEDIATE ASSIGNMENT) ! 8771: # ------------------------------------ ! 8772: # ! 8773: # +---+ THIS NODE (P$IMA) STACKS THE CURSOR ! 8774: # I A I PMHBS AND A PTR TO NDIMB AND RESETS ! 8775: # +---+ THE STACK PTR PMHBS. ! 8776: # I ! 8777: # I ! 8778: # +---+ THIS IS THE LEFT STRUCTURE FOR THE ! 8779: # I X I PATTERN LEFT ARGUMENT OF THE ! 8780: # +---+ IMMEDIATE ASSIGNMENT CALL. ! 8781: # I ! 8782: # I ! 8783: # +---+ THIS NODE (P$IMC) PERFORMS THE ! 8784: # I C I----- ASSIGNMENT, POPS PMHBS AND STACKS ! 8785: # +---+ THE OLD PMHBS AND A PTR TO NDIMD. ! 8786: # ! 8787: # ! 8788: # THE STRUCTURE AND EXECUTION OF THIS PATTERN ARE SIMILAR ! 8789: # TO THOSE OF THE RECURSIVE EXPRESSION PATTERN MATCHING. ! 8790: # ! 8791: # THE MATCH ROUTINE FOR NDIMB (P$IMB) RESTORES THE OUTER ! 8792: # LEVEL VALUE OF PMHBS, UNSTACKS THE SAVED CURSOR AND FAILS ! 8793: # ! 8794: # THE MATCH ROUTINE P$IMC USES THE CURRENT VALUE OF PMHBS ! 8795: # TO LOCATE THE P$IMB ENTRY. THIS ENTRY IS USED TO MAKE ! 8796: # THE ASSIGNMENT AND RESTORE THE OUTER LEVEL VALUE OF ! 8797: # PMHBS. FINALLY, THE INNER LEVEL VALUE OF PMHBS AND A ! 8798: # POINTER TO THE SPECIAL NODE NDIMD ARE STACKED. ! 8799: # ! 8800: # THE MATCH ROUTINE FOR NDIMD (P$IMD) RESTORES THE INNER ! 8801: # LEVEL VALUE OF PMHBS AND FAILS BACK INTO THE STACK. ! 8802: # ! 8803: # AN OPTIMIZATION OCCURS IF THE INNER PATTERN MAKES NO ! 8804: # ENTRIES ON THE HISTORY STACK. IN THIS CASE, P$IMC POPS ! 8805: # THE P$IMB ENTRY INSTEAD OF MAKING A P$IMD ENTRY. ! 8806: #page ! 8807: # ! 8808: # ARBNO ! 8809: # ! 8810: # SEE COMPOUND PATTERNS SECTION FOR STUCTURE AND ! 8811: # ALGORITHM FOR MATCHING THIS NODE TYPE. ! 8812: # ! 8813: # NO PARAMETERS ! 8814: # ! 8815: .align 2 ! 8816: .word bl$p0 ! 8817: p$aba: # p0blk ! 8818: movl r7,-(sp) # stack cursor ! 8819: movl r9,-(sp) # stack dummy node ptr ! 8820: movl pmhbs,-(sp) # stack old stack base ptr ! 8821: movl $ndabb,-(sp) # stack ptr to node ndabb ! 8822: movl sp,pmhbs # store new stack base ptr ! 8823: jmp succp # succeed ! 8824: #page ! 8825: # ! 8826: # ARBNO (REMOVE P$ABA SPECIAL STACK ENTRY) ! 8827: # ! 8828: # NO PARAMETERS (DUMMY PATTERN) ! 8829: # ! 8830: p$abb: # entry point ! 8831: movl r7,pmhbs # restore history stack base ptr ! 8832: jmp flpop # fail and pop dummy node ptr ! 8833: #page ! 8834: # ! 8835: # ARBNO (CHECK IF ARG MATCHED NULL STRING) ! 8836: # ! 8837: # NO PARAMETERS (DUMMY PATTERN) ! 8838: # ! 8839: .align 2 ! 8840: .word bl$p0 ! 8841: p$abc: # p0blk ! 8842: movl pmhbs,r10 # keep p$abb stack base ! 8843: movl 4*3(r10),r6 # load initial cursor ! 8844: movl 4*1(r10),pmhbs # restore outer stack base ptr ! 8845: cmpl r10,sp # jump if no history stack entries ! 8846: beqlu pabc1 ! 8847: movl r10,-(sp) # else save inner pmhbs entry ! 8848: movl $ndabd,-(sp) # stack ptr to special node ndabd ! 8849: jmp pabc2 # merge ! 8850: # ! 8851: # OPTIMISE CASE OF NO EXTRA ENTRIES ON STACK FROM ARBNO ARG ! 8852: # ! 8853: pabc1: addl2 $4*num04,sp # remove ndabb entry and cursor ! 8854: # ! 8855: # MERGE TO CHECK FOR MATCHING OF NULL STRING ! 8856: # ! 8857: pabc2: cmpl r6,r7 # allow further attempt if non-null ! 8858: beqlu 0f ! 8859: jmp succp ! 8860: 0: ! 8861: movl 4*pthen(r9),r9 # bypass alternative node so as to .. ! 8862: jmp succp # ... refuse further match attempts ! 8863: #page ! 8864: # ! 8865: # ARBNO (TRY FOR ALTERNATIVES IN ARBNO ARGUMENT) ! 8866: # ! 8867: # NO PARAMETERS (DUMMY PATTERN) ! 8868: # ! 8869: p$abd: # entry point ! 8870: movl r7,pmhbs # restore inner stack base ptr ! 8871: jmp failp # and fail ! 8872: #page ! 8873: # ! 8874: # ABORT ! 8875: # ! 8876: # NO PARAMETERS ! 8877: # ! 8878: .align 2 ! 8879: .word bl$p0 ! 8880: p$abo: # p0blk ! 8881: jmp exfal # signal statement failure ! 8882: #page ! 8883: # ! 8884: # ALTERNATION ! 8885: # ! 8886: # PARM1 ALTERNATIVE NODE ! 8887: # ! 8888: .align 2 ! 8889: .word bl$p1 ! 8890: p$alt: # p1blk ! 8891: movl r7,-(sp) # stack cursor ! 8892: movl 4*parm1(r9),-(sp)# stack pointer to alternative ! 8893: jsb sbchk # check for stack overflow ! 8894: jmp succp # if all ok, then succeed ! 8895: #page ! 8896: # ! 8897: # ANY (ONE CHARACTER ARGUMENT) (1-CHAR STRING ALSO) ! 8898: # ! 8899: # PARM1 CHARACTER ARGUMENT ! 8900: # ! 8901: .align 2 ! 8902: .word bl$p1 ! 8903: p$ans: # p1blk ! 8904: cmpl r7,pmssl # fail if no chars left ! 8905: bnequ 0f ! 8906: jmp failp ! 8907: 0: ! 8908: movl r$pms,r10 # else point to subject string ! 8909: movab cfp$f(r10)[r7],r10 # point to current character ! 8910: movzbl (r10),r6 # load current character ! 8911: cmpl r6,4*parm1(r9) # fail if no match ! 8912: beqlu 0f ! 8913: jmp failp ! 8914: 0: ! 8915: incl r7 # else bump cursor ! 8916: jmp succp # and succeed ! 8917: #page ! 8918: # ! 8919: # ANY (MULTI-CHARACTER ARGUMENT CASE) ! 8920: # ! 8921: # PARM1 POINTER TO CTBLK ! 8922: # PARM2 BIT MASK TO SELECT BIT IN CTBLK ! 8923: # ! 8924: .align 2 ! 8925: .word bl$p2 ! 8926: p$any: # p2blk ! 8927: # ! 8928: # EXPRESSION ARGUMENT CASE MERGES HERE ! 8929: # ! 8930: pany1: cmpl r7,pmssl # fail if no characters left ! 8931: bnequ 0f ! 8932: jmp failp ! 8933: 0: ! 8934: movl r$pms,r10 # else point to subject string ! 8935: movab cfp$f(r10)[r7],r10 # get char ptr to current character ! 8936: movzbl (r10),r6 # load current character ! 8937: movl 4*parm1(r9),r10 # point to ctblk ! 8938: moval 0[r6],r6 # change to byte offset ! 8939: addl2 r6,r10 # point to entry in ctblk ! 8940: movl 4*ctchs(r10),r6 # load word from ctblk ! 8941: mcoml 4*parm2(r9),r11 # and with selected bit ! 8942: bicl2 r11,r6 ! 8943: tstl r6 # fail if no match ! 8944: bnequ 0f ! 8945: jmp failp ! 8946: 0: ! 8947: incl r7 # else bump cursor ! 8948: jmp succp # and succeed ! 8949: #page ! 8950: # ! 8951: # ANY (EXPRESSION ARGUMENT) ! 8952: # ! 8953: # PARM1 EXPRESSION POINTER ! 8954: # ! 8955: .align 2 ! 8956: .word bl$p1 ! 8957: p$ayd: # p1blk ! 8958: jsb evals # evaluate string argument ! 8959: .long er_043 # any evaluated argument is not string ! 8960: .long failp # fail if evaluation failure ! 8961: .long pany1 # merge multi-char case if ok ! 8962: #page ! 8963: # ! 8964: # P$ARB INITIAL ARB MATCH ! 8965: # ! 8966: # NO PARAMETERS ! 8967: # ! 8968: # THE P$ARB NODE IS PART OF A COMPOUND PATTERN STRUCTURE ! 8969: # FOR AN ARB PATTERN (SEE DESCRIPTION OF COMPOUND PATTERNS) ! 8970: # ! 8971: .align 2 ! 8972: .word bl$p0 ! 8973: p$arb: # p0blk ! 8974: movl 4*pthen(r9),r9 # load successor pointer ! 8975: movl r7,-(sp) # stack dummy cursor ! 8976: movl r9,-(sp) # stack successor pointer ! 8977: movl r7,-(sp) # stack cursor ! 8978: movl $ndarc,-(sp) # stack ptr to special node ndarc ! 8979: movl (r9),r11 # execute next node matching null ! 8980: jmp (r11) ! 8981: #page ! 8982: # ! 8983: # P$ARC EXTEND ARB MATCH ! 8984: # ! 8985: # NO PARAMETERS (DUMMY PATTERN) ! 8986: # ! 8987: p$arc: # entry point ! 8988: cmpl r7,pmssl # fail and pop stack to successor ! 8989: bnequ 0f ! 8990: jmp flpop ! 8991: 0: ! 8992: incl r7 # else bump cursor ! 8993: movl r7,-(sp) # stack updated cursor ! 8994: movl r9,-(sp) # restack pointer to ndarc node ! 8995: movl 4*2(sp),r9 # load successor pointer ! 8996: movl (r9),r11 # off to reexecute successor node ! 8997: jmp (r11) ! 8998: #page ! 8999: # ! 9000: # BAL ! 9001: # ! 9002: # NO PARAMETERS ! 9003: # ! 9004: # THE P$BAL NODE IS PART OF THE COMPOUND STRUCTURE BUILT ! 9005: # FOR BAL (SEE SECTION ON COMPOUND PATTERNS). ! 9006: # ! 9007: .align 2 ! 9008: .word bl$p0 ! 9009: p$bal: # p0blk ! 9010: clrl r8 # zero parentheses level counter ! 9011: movl r$pms,r10 # point to subject string ! 9012: movab cfp$f(r10)[r7],r10 # point to current character ! 9013: jmp pbal2 # jump into scan loop ! 9014: # ! 9015: # LOOP TO SCAN OUT CHARACTERS ! 9016: # ! 9017: pbal1: movzbl (r10)+,r6 # load next character, bump pointer ! 9018: incl r7 # push cursor for character ! 9019: cmpl r6,$ch$pp # jump if left paren ! 9020: beqlu pbal3 ! 9021: cmpl r6,$ch$rp # jump if right paren ! 9022: beqlu pbal4 ! 9023: tstl r8 # else succeed if at outer level ! 9024: beqlu pbal5 ! 9025: # ! 9026: # HERE AFTER PROCESSING ONE CHARACTER ! 9027: # ! 9028: pbal2: cmpl r7,pmssl # loop back unless end of string ! 9029: bnequ pbal1 ! 9030: jmp failp # in which case, fail ! 9031: # ! 9032: # HERE ON LEFT PAREN ! 9033: # ! 9034: pbal3: incl r8 # bump paren level ! 9035: jmp pbal2 # loop back to check end of string ! 9036: # ! 9037: # HERE FOR RIGHT PAREN ! 9038: # ! 9039: pbal4: tstl r8 # fail if no matching left paren ! 9040: bnequ 0f ! 9041: jmp failp ! 9042: 0: ! 9043: decl r8 # else decrement level counter ! 9044: tstl r8 # loop back if not at outer level ! 9045: bnequ pbal2 ! 9046: # ! 9047: # HERE AFTER SUCCESSFULLY SCANNING A BALANCED STRING ! 9048: # ! 9049: pbal5: movl r7,-(sp) # stack cursor ! 9050: movl r9,-(sp) # stack ptr to bal node for extend ! 9051: jmp succp # and succeed ! 9052: #page ! 9053: # ! 9054: # BREAK (EXPRESSION ARGUMENT) ! 9055: # ! 9056: # PARM1 EXPRESSION POINTER ! 9057: # ! 9058: .align 2 ! 9059: .word bl$p1 ! 9060: p$bkd: # p1blk ! 9061: jsb evals # evaluate string expression ! 9062: .long er_044 # break evaluated argument is not string ! 9063: .long failp # fail if evaluation fails ! 9064: .long pbrk1 # merge with multi-char case if ok ! 9065: #page ! 9066: # ! 9067: # BREAK (ONE CHARACTER ARGUMENT) ! 9068: # ! 9069: # PARM1 CHARACTER ARGUMENT ! 9070: # ! 9071: .align 2 ! 9072: .word bl$p1 ! 9073: p$bks: # p1blk ! 9074: movl pmssl,r8 # get subject string length ! 9075: subl2 r7,r8 # get number of characters left ! 9076: tstl r8 # fail if no characters left ! 9077: bnequ 0f ! 9078: jmp failp ! 9079: 0: ! 9080: # set counter for chars left ! 9081: movl r$pms,r10 # point to subject string ! 9082: movab cfp$f(r10)[r7],r10 # point to current character ! 9083: # ! 9084: # LOOP TO SCAN TILL BREAK CHARACTER FOUND ! 9085: # ! 9086: pbks1: movzbl (r10)+,r6 # load next char, bump pointer ! 9087: cmpl r6,4*parm1(r9) # succeed if break character found ! 9088: bnequ 0f ! 9089: jmp succp ! 9090: 0: ! 9091: incl r7 # else push cursor ! 9092: sobgtr r8,pbks1 # loop back if more to go ! 9093: jmp failp # fail if end of string, no break chr ! 9094: #page ! 9095: # ! 9096: # BREAK (MULTI-CHARACTER ARGUMENT) ! 9097: # ! 9098: # PARM1 POINTER TO CTBLK ! 9099: # PARM2 BIT MASK TO SELECT BIT COLUMN ! 9100: # ! 9101: .align 2 ! 9102: .word bl$p2 ! 9103: p$brk: # p2blk ! 9104: # ! 9105: # EXPRESSION ARGUMENT MERGES HERE ! 9106: # ! 9107: pbrk1: movl pmssl,r8 # load subject string length ! 9108: subl2 r7,r8 # get number of characters left ! 9109: tstl r8 # fail if no characters left ! 9110: bnequ 0f ! 9111: jmp failp ! 9112: 0: ! 9113: # set counter for characters left ! 9114: movl r$pms,r10 # else point to subject string ! 9115: movab cfp$f(r10)[r7],r10 # point to current character ! 9116: movl r9,psave # save node pointer ! 9117: # ! 9118: # LOOP TO SEARCH FOR BREAK CHARACTER ! 9119: # ! 9120: pbrk2: movzbl (r10)+,r6 # load next char, bump pointer ! 9121: movl 4*parm1(r9),r9 # load pointer to ctblk ! 9122: moval 0[r6],r6 # convert to byte offset ! 9123: addl2 r6,r9 # point to ctblk entry ! 9124: movl 4*ctchs(r9),r6 # load ctblk word ! 9125: movl psave,r9 # restore node pointer ! 9126: mcoml 4*parm2(r9),r11 # and with selected bit ! 9127: bicl2 r11,r6 ! 9128: tstl r6 # succeed if break character found ! 9129: beqlu 0f ! 9130: jmp succp ! 9131: 0: ! 9132: incl r7 # else push cursor ! 9133: sobgtr r8,pbrk2 # loop back unless end of string ! 9134: jmp failp # fail if end of string, no break chr ! 9135: #page ! 9136: # ! 9137: # BREAKX (EXTENSION) ! 9138: # ! 9139: # THIS IS THE ENTRY WHICH CAUSES AN EXTENSION OF A BREAKX ! 9140: # MATCH WHEN FAILURE OCCURS. SEE SECTION ON COMPOUND ! 9141: # PATTERNS FOR FULL DETAILS OF BREAKX MATCHING. ! 9142: # ! 9143: # NO PARAMETERS ! 9144: # ! 9145: .align 2 ! 9146: .word bl$p0 ! 9147: p$bkx: # p0blk ! 9148: incl r7 # step cursor past previous break chr ! 9149: jmp succp # succeed to rematch break ! 9150: #page ! 9151: # ! 9152: # BREAKX (EXPRESSION ARGUMENT) ! 9153: # ! 9154: # SEE SECTION ON COMPOUND PATTERNS FOR FULL STRUCTURE OF ! 9155: # BREAKX PATTERN. THE ACTUAL CHARACTER MATCHING USES A ! 9156: # BREAK NODE. HOWEVER, THE ENTRY FOR THE EXPRESSION ! 9157: # ARGUMENT CASE IS SEPARATED TO GET PROPER ERROR MESSAGES. ! 9158: # ! 9159: # PARM1 EXPRESSION POINTER ! 9160: # ! 9161: .align 2 ! 9162: .word bl$p1 ! 9163: p$bxd: # p1blk ! 9164: jsb evals # evaluate string argument ! 9165: .long er_045 # breakx evaluated argument is not string ! 9166: .long failp # fail if evaluation fails ! 9167: .long pbrk1 # merge with break if all ok ! 9168: #page ! 9169: # ! 9170: # CURSOR ASSIGNMENT ! 9171: # ! 9172: # PARM1 NAME BASE ! 9173: # PARM2 NAME OFFSET ! 9174: # ! 9175: .align 2 ! 9176: .word bl$p2 ! 9177: p$cas: # p2blk ! 9178: movl r9,-(sp) # save node pointer ! 9179: movl r7,-(sp) # save cursor ! 9180: movl 4*parm1(r9),r10 # load name base ! 9181: movl r7,r5 # load cursor as integer ! 9182: movl 4*parm2(r9),r7 # load name offset ! 9183: jsb icbld # get icblk for cursor value ! 9184: movl r7,r6 # move name offset ! 9185: movl r9,r7 # move value to assign ! 9186: jsb asinp # perform assignment ! 9187: .long flpop # fail on assignment failure ! 9188: movl (sp)+,r7 # else restore cursor ! 9189: movl (sp)+,r9 # restore node pointer ! 9190: jmp succp # and succeed matching null ! 9191: #page ! 9192: # ! 9193: # EXPRESSION NODE (P$EXA, INITIAL ENTRY) ! 9194: # ! 9195: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9196: # ALGORITHMS FOR HANDLING EXPRESSION NODES. ! 9197: # ! 9198: # PARM1 EXPRESSION POINTER ! 9199: # ! 9200: .align 2 ! 9201: .word bl$p1 ! 9202: p$exa: # p1blk ! 9203: jsb evalp # evaluate expression ! 9204: .long failp # fail if evaluation fails ! 9205: cmpl r6,$p$aaa # jump if result is not a pattern ! 9206: blequ pexa1 ! 9207: # ! 9208: # HERE IF RESULT OF EXPRESSION IS A PATTERN ! 9209: # ! 9210: movl r7,-(sp) # stack dummy cursor ! 9211: movl r9,-(sp) # stack ptr to p$exa node ! 9212: movl pmhbs,-(sp) # stack history stack base ptr ! 9213: movl $ndexb,-(sp) # stack ptr to special node ndexb ! 9214: movl sp,pmhbs # store new stack base pointer ! 9215: movl r10,r9 # copy node pointer ! 9216: movl (r9),r11 # match first node in expression pat ! 9217: jmp (r11) ! 9218: # ! 9219: # HERE IF RESULT OF EXPRESSION IS NOT A PATTERN ! 9220: # ! 9221: pexa1: cmpl r6,$b$scl # jump if it is already a string ! 9222: beqlu pexa2 ! 9223: movl r10,-(sp) # else stack result ! 9224: movl r9,r10 # save node pointer ! 9225: jsb gtstg # convert result to string ! 9226: .long er_046 # expression does not evaluate to pattern ! 9227: movl r9,r8 # copy string pointer ! 9228: movl r10,r9 # restore node pointer ! 9229: movl r8,r10 # copy string pointer again ! 9230: # ! 9231: # MERGE HERE WITH STRING POINTER IN XL ! 9232: # ! 9233: pexa2: tstl 4*sclen(r10) # just succeed if null string ! 9234: bnequ 0f ! 9235: jmp succp ! 9236: 0: ! 9237: jmp pstr1 # else merge with string circuit ! 9238: #page ! 9239: # ! 9240: # EXPRESSION NODE (P$EXB, REMOVE NDEXB ENTRY) ! 9241: # ! 9242: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9243: # ALGORITHMS FOR HANDLING EXPRESSION NODES. ! 9244: # ! 9245: # NO PARAMETERS (DUMMY PATTERN) ! 9246: # ! 9247: p$exb: # entry point ! 9248: movl r7,pmhbs # restore outer level stack pointer ! 9249: jmp flpop # fail and pop p$exa node ptr ! 9250: #page ! 9251: # ! 9252: # EXPRESSION NODE (P$EXC, REMOVE NDEXC ENTRY) ! 9253: # ! 9254: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9255: # ALGORITHMS FOR HANDLING EXPRESSION NODES. ! 9256: # ! 9257: # NO PARAMETERS (DUMMY PATTERN) ! 9258: # ! 9259: p$exc: # entry point ! 9260: movl r7,pmhbs # restore inner stack base pointer ! 9261: jmp failp # and fail into expr pattern alternvs ! 9262: #page ! 9263: # ! 9264: # FAIL ! 9265: # ! 9266: # NO PARAMETERS ! 9267: # ! 9268: .align 2 ! 9269: .word bl$p0 ! 9270: p$fal: # p0blk ! 9271: jmp failp # just signal failure ! 9272: #page ! 9273: # ! 9274: # FENCE ! 9275: # ! 9276: # SEE COMPOUND PATTERNS SECTION FOR THE STRUCTURE AND ! 9277: # ALGORITHM FOR MATCHING THIS NODE TYPE. ! 9278: # ! 9279: # NO PARAMETERS ! 9280: # ! 9281: .align 2 ! 9282: .word bl$p0 ! 9283: p$fen: # p0blk ! 9284: movl r7,-(sp) # stack dummy cursor ! 9285: movl $ndabo,-(sp) # stack ptr to abort node ! 9286: jmp succp # and succeed matching null ! 9287: #page ! 9288: # ! 9289: # FENCE (FUNCTION) ! 9290: # ! 9291: # SEE COMPOUND PATTERNS COMMENTS AT START OF THIS SECTION ! 9292: # FOR DETAILS OF SCHEME ! 9293: # ! 9294: # NO PARAMETERS ! 9295: # ! 9296: .align 2 ! 9297: .word bl$p0 ! 9298: p$fna: # p0blk ! 9299: movl pmhbs,-(sp) # stack current history stack base ! 9300: movl $ndfnb,-(sp) # stack indir ptr to p$fnb (failure) ! 9301: movl sp,pmhbs # begin new history stack ! 9302: jmp succp # succeed ! 9303: #page ! 9304: # ! 9305: # FENCE (FUNCTION) (RESET HISTORY STACK AND FAIL) ! 9306: # ! 9307: # NO PARAMETERS (DUMMY PATTERN) ! 9308: # ! 9309: .align 2 ! 9310: .word bl$p0 ! 9311: p$fnb: # p0blk ! 9312: movl r7,pmhbs # restore outer pmhbs stack base ! 9313: jmp failp # ...and fail ! 9314: #page ! 9315: # ! 9316: # FENCE (FUNCTION) (MAKE FENCE TRAP ENTRY ON STACK) ! 9317: # ! 9318: # NO PARAMETERS (DUMMY PATTERN) ! 9319: # ! 9320: .align 2 ! 9321: .word bl$p0 ! 9322: p$fnc: # p0blk ! 9323: movl pmhbs,r10 # get inner stack base ptr ! 9324: movl 4*num01(r10),pmhbs # restore outer stack base ! 9325: cmpl r10,sp # optimize if no alternatives ! 9326: beqlu pfnc1 ! 9327: movl r10,-(sp) # else stack inner stack base ! 9328: movl $ndfnd,-(sp) # stack ptr to ndfnd ! 9329: jmp succp # succeed ! 9330: # ! 9331: # HERE WHEN FENCE FUNCTION LEFT NOTHING ON THE STACK ! 9332: # ! 9333: pfnc1: addl2 $4*num02,sp # pop off p$fnb entry ! 9334: jmp succp # succeed ! 9335: #page ! 9336: # ! 9337: # FENCE (FUNCTION) (SKIP PAST ALTERNATIVES ON FAILURE) ! 9338: # ! 9339: # NO PARAMETERS (DUMMY PATTERN) ! 9340: # ! 9341: .align 2 ! 9342: .word bl$p0 ! 9343: p$fnd: # p0blk ! 9344: movl r7,sp # pop stack to fence() history base ! 9345: jmp flpop # pop base entry and fail ! 9346: #page ! 9347: # ! 9348: # IMMEDIATE ASSIGNMENT (INITIAL ENTRY, SAVE CURRENT CURSOR) ! 9349: # ! 9350: # SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE ! 9351: # STRUCTURE AND ALGORITHM FOR MATCHING THIS NODE TYPE. ! 9352: # ! 9353: # NO PARAMETERS ! 9354: # ! 9355: .align 2 ! 9356: .word bl$p0 ! 9357: p$ima: # p0blk ! 9358: movl r7,-(sp) # stack cursor ! 9359: movl r9,-(sp) # stack dummy node pointer ! 9360: movl pmhbs,-(sp) # stack old stack base pointer ! 9361: movl $ndimb,-(sp) # stack ptr to special node ndimb ! 9362: movl sp,pmhbs # store new stack base pointer ! 9363: jmp succp # and succeed ! 9364: #page ! 9365: # ! 9366: # IMMEDIATE ASSIGNMENT (REMOVE CURSOR MARK ENTRY) ! 9367: # ! 9368: # SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE ! 9369: # STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9370: # ! 9371: # NO PARAMETERS (DUMMY PATTERN) ! 9372: # ! 9373: p$imb: # entry point ! 9374: movl r7,pmhbs # restore history stack base ptr ! 9375: jmp flpop # fail and pop dummy node ptr ! 9376: #page ! 9377: # ! 9378: # IMMEDIATE ASSIGNMENT (PERFORM ACTUAL ASSIGNMENT) ! 9379: # ! 9380: # SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE ! 9381: # STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9382: # ! 9383: # PARM1 NAME BASE OF VARIABLE ! 9384: # PARM2 NAME OFFSET OF VARIABLE ! 9385: # ! 9386: .align 2 ! 9387: .word bl$p2 ! 9388: p$imc: # p2blk ! 9389: movl pmhbs,r10 # load pointer to p$imb entry ! 9390: movl r7,r6 # copy final cursor ! 9391: movl 4*3(r10),r7 # load initial cursor ! 9392: movl 4*1(r10),pmhbs # restore outer stack base pointer ! 9393: cmpl r10,sp # jump if no history stack entries ! 9394: beqlu pimc1 ! 9395: movl r10,-(sp) # else save inner pmhbs pointer ! 9396: movl $ndimd,-(sp) # and a ptr to special node ndimd ! 9397: jmp pimc2 # merge ! 9398: # ! 9399: # HERE IF NO ENTRIES MADE ON HISTORY STACK ! 9400: # ! 9401: pimc1: addl2 $4*num04,sp # remove ndimb entry and cursor ! 9402: # ! 9403: # MERGE HERE TO PERFORM ASSIGNMENT ! 9404: # ! 9405: pimc2: movl r6,-(sp) # save current (final) cursor ! 9406: movl r9,-(sp) # save current node pointer ! 9407: movl r$pms,r10 # point to subject string ! 9408: subl2 r7,r6 # compute substring length ! 9409: jsb sbstr # build substring ! 9410: movl r9,r7 # move result ! 9411: movl (sp),r9 # reload node pointer ! 9412: movl 4*parm1(r9),r10 # load name base ! 9413: movl 4*parm2(r9),r6 # load name offset ! 9414: jsb asinp # perform assignment ! 9415: .long flpop # fail if assignment fails ! 9416: movl (sp)+,r9 # else restore node pointer ! 9417: movl (sp)+,r7 # restore cursor ! 9418: jmp succp # and succeed ! 9419: #page ! 9420: # ! 9421: # IMMEDIATE ASSIGNMENT (REMOVE NDIMD ENTRY ON FAILURE) ! 9422: # ! 9423: # SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE ! 9424: # STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9425: # ! 9426: # NO PARAMETERS (DUMMY PATTERN) ! 9427: # ! 9428: p$imd: # entry point ! 9429: movl r7,pmhbs # restore inner stack base pointer ! 9430: jmp failp # and fail ! 9431: #page ! 9432: # ! 9433: # LEN (INTEGER ARGUMENT) ! 9434: # ! 9435: # PARM1 INTEGER ARGUMENT ! 9436: # ! 9437: .align 2 ! 9438: .word bl$p1 ! 9439: p$len: # p1blk ! 9440: # ! 9441: # EXPRESSION ARGUMENT CASE MERGES HERE ! 9442: # ! 9443: plen1: addl2 4*parm1(r9),r7 # push cursor indicated amount ! 9444: cmpl r7,pmssl # succeed if not off end ! 9445: bgtru 0f ! 9446: jmp succp ! 9447: 0: ! 9448: jmp failp # else fail ! 9449: #page ! 9450: # ! 9451: # LEN (EXPRESSION ARGUMENT) ! 9452: # ! 9453: # PARM1 EXPRESSION POINTER ! 9454: # ! 9455: .align 2 ! 9456: .word bl$p1 ! 9457: p$lnd: # p1blk ! 9458: jsb evali # evaluate integer argument ! 9459: .long er_047 # len evaluated argument is not integer ! 9460: .long er_048 # len evaluated argument is negative or too large ! 9461: .long failp # fail if evaluation fails ! 9462: .long plen1 # merge with normal circuit if ok ! 9463: #page ! 9464: # ! 9465: # NOTANY (EXPRESSION ARGUMENT) ! 9466: # ! 9467: # PARM1 EXPRESSION POINTER ! 9468: # ! 9469: .align 2 ! 9470: .word bl$p1 ! 9471: p$nad: # p1blk ! 9472: jsb evals # evaluate string argument ! 9473: .long er_049 # notany evaluated argument is not string ! 9474: .long failp # fail if evaluation fails ! 9475: .long pnay1 # merge with multi-char case if ok ! 9476: #page ! 9477: # ! 9478: # NOTANY (ONE CHARACTER ARGUMENT) ! 9479: # ! 9480: # PARM1 CHARACTER ARGUMENT ! 9481: # ! 9482: .align 2 ! 9483: .word bl$p1 ! 9484: p$nas: # entry point ! 9485: cmpl r7,pmssl # fail if no chars left ! 9486: bnequ 0f ! 9487: jmp failp ! 9488: 0: ! 9489: movl r$pms,r10 # else point to subject string ! 9490: movab cfp$f(r10)[r7],r10 # point to current character in strin ! 9491: movzbl (r10),r6 # load current character ! 9492: cmpl r6,4*parm1(r9) # fail if match ! 9493: bnequ 0f ! 9494: jmp failp ! 9495: 0: ! 9496: incl r7 # else bump cursor ! 9497: jmp succp # and succeed ! 9498: #page ! 9499: # ! 9500: # NOTANY (MULTI-CHARACTER STRING ARGUMENT) ! 9501: # ! 9502: # PARM1 POINTER TO CTBLK ! 9503: # PARM2 BIT MASK TO SELECT BIT COLUMN ! 9504: # ! 9505: .align 2 ! 9506: .word bl$p2 ! 9507: p$nay: # p2blk ! 9508: # ! 9509: # EXPRESSION ARGUMENT CASE MERGES HERE ! 9510: # ! 9511: pnay1: cmpl r7,pmssl # fail if no characters left ! 9512: bnequ 0f ! 9513: jmp failp ! 9514: 0: ! 9515: movl r$pms,r10 # else point to subject string ! 9516: movab cfp$f(r10)[r7],r10 # point to current character ! 9517: movzbl (r10),r6 # load current character ! 9518: moval 0[r6],r6 # convert to byte offset ! 9519: movl 4*parm1(r9),r10 # load pointer to ctblk ! 9520: addl2 r6,r10 # point to entry in ctblk ! 9521: movl 4*ctchs(r10),r6 # load entry from ctblk ! 9522: mcoml 4*parm2(r9),r11 # and with selected bit ! 9523: bicl2 r11,r6 ! 9524: tstl r6 # fail if character is matched ! 9525: beqlu 0f ! 9526: jmp failp ! 9527: 0: ! 9528: incl r7 # else bump cursor ! 9529: jmp succp # and succeed ! 9530: #page ! 9531: # ! 9532: # END OF PATTERN MATCH ! 9533: # ! 9534: # THIS ROUTINE IS ENTERED ON SUCCESSFUL COMPLETION. ! 9535: # SEE DESCRIPTION OF EXPRESSION PATTERNS IN COMPOUND ! 9536: # PATTERN SECTION FOR HANDLING OF RECURSION IN MATCHING. ! 9537: # ! 9538: # NO PARAMETERS (DUMMY PATTERN) ! 9539: # ! 9540: p$nth: # entry point ! 9541: movl pmhbs,r10 # load pointer to base of stack ! 9542: movl 4*1(r10),r6 # load saved pmhbs (or pattern type) ! 9543: cmpl r6,$num02 # jump if outer level (pattern type) ! 9544: blequ pnth2 ! 9545: # ! 9546: # HERE WE ARE AT THE END OF MATCHING AN EXPRESSION PATTERN ! 9547: # ! 9548: movl r6,pmhbs # restore outer stack base pointer ! 9549: movl 4*2(r10),r9 # restore pointer to p$exa node ! 9550: cmpl r10,sp # jump if no history stack entries ! 9551: beqlu pnth1 ! 9552: movl r10,-(sp) # else stack inner stack base ptr ! 9553: movl $ndexc,-(sp) # stack ptr to special node ndexc ! 9554: jmp succp # and succeed ! 9555: # ! 9556: # HERE IF NO HISTORY STACK ENTRIES DURING PATTERN ! 9557: # ! 9558: pnth1: addl2 $4*num04,sp # remove p$exb entry and node ptr ! 9559: jmp succp # and succeed ! 9560: # ! 9561: # HERE IF END OF MATCH AT OUTER LEVEL ! 9562: # ! 9563: pnth2: movl r7,pmssl # save final cursor in safe place ! 9564: tstl pmdfl # jump if no pattern assignments ! 9565: beqlu pnth6 ! 9566: #page ! 9567: # ! 9568: # END OF PATTERN MATCH (CONTINUED) ! 9569: # ! 9570: # NOW WE MUST PERFORM PATTERN ASSIGNMENTS. THIS IS DONE BY ! 9571: # SCANNING THE HISTORY STACK FOR MATCHING NDPAB-NDPAD PAIRS ! 9572: # ! 9573: pnth3: subl2 $4,r10 # point past cursor entry ! 9574: movl -(r10),r6 # load node pointer ! 9575: cmpl r6,$ndpad # jump if ndpad entry ! 9576: beqlu pnth4 ! 9577: cmpl r6,$ndpab # jump if not ndpab entry ! 9578: bnequ pnth5 ! 9579: # ! 9580: # HERE FOR NDPAB ENTRY, STACK INITIAL CURSOR ! 9581: # NOTE THAT THERE MUST BE MORE ENTRIES ON THE STACK. ! 9582: # ! 9583: movl 4*1(r10),-(sp) # stack initial cursor ! 9584: jsb sbchk # check for stack overflow ! 9585: jmp pnth3 # loop back if ok ! 9586: # ! 9587: # HERE FOR NDPAD ENTRY. THE STARTING CURSOR FROM THE ! 9588: # MATCHING NDPAD ENTRY IS NOW THE TOP STACK ENTRY. ! 9589: # ! 9590: pnth4: movl 4*1(r10),r6 # load final cursor ! 9591: movl (sp),r7 # load initial cursor from stack ! 9592: movl r10,(sp) # save history stack scan ptr ! 9593: subl2 r7,r6 # compute length of string ! 9594: # ! 9595: # BUILD SUBSTRING AND PERFORM ASSIGNMENT ! 9596: # ! 9597: movl r$pms,r10 # point to subject string ! 9598: jsb sbstr # construct substring ! 9599: movl r9,r7 # copy substring pointer ! 9600: movl (sp),r10 # reload history stack scan ptr ! 9601: movl 4*2(r10),r10 # load pointer to p$pac node with nam ! 9602: movl 4*parm2(r10),r6 # load name offset ! 9603: movl 4*parm1(r10),r10# load name base ! 9604: jsb asinp # perform assignment ! 9605: .long exfal # match fails if name eval fails ! 9606: movl (sp)+,r10 # else restore history stack ptr ! 9607: #page ! 9608: # ! 9609: # END OF PATTERN MATCH (CONTINUED) ! 9610: # ! 9611: # HERE CHECK FOR END OF ENTRIES ! 9612: # ! 9613: pnth5: cmpl r10,sp # loop if more entries to scan ! 9614: bnequ pnth3 ! 9615: # ! 9616: # HERE AFTER DEALING WITH PATTERN ASSIGNMENTS ! 9617: # ! 9618: pnth6: movl pmhbs,sp # wipe out history stack ! 9619: movl (sp)+,r7 # load initial cursor ! 9620: movl (sp)+,r8 # load match type code ! 9621: movl pmssl,r6 # load final cursor value ! 9622: movl r$pms,r10 # point to subject string ! 9623: clrl r$pms # clear subject string ptr for gbcol ! 9624: tstl r8 # jump if call by name ! 9625: beqlu pnth7 ! 9626: cmpl r8,$num02 # exit if statement level call ! 9627: bnequ 0f ! 9628: jmp exits ! 9629: 0: ! 9630: # ! 9631: # HERE WE HAVE A CALL BY VALUE, BUILD SUBSTRING ! 9632: # ! 9633: subl2 r7,r6 # compute length of string ! 9634: jsb sbstr # build substring ! 9635: jmp exixr # and exit with substring value ! 9636: # ! 9637: # HERE FOR CALL BY NAME, MAKE STACK ENTRIES FOR O$RPL ! 9638: # ! 9639: pnth7: movl r7,-(sp) # stack initial cursor ! 9640: movl r6,-(sp) # stack final cursor ! 9641: tstl r$pmb # skip if subject not buffer ! 9642: beqlu pnth8 ! 9643: movl r$pmb,r10 # else get ptr to bcblk instead ! 9644: # ! 9645: # HERE WITH XL POINTING TO SCBLK OR BCBLK ! 9646: # ! 9647: pnth8: movl r10,-(sp) # stack subject pointer ! 9648: jmp exits # exit with special entry on stack ! 9649: #page ! 9650: # ! 9651: # POS (INTEGER ARGUMENT) ! 9652: # ! 9653: # PARM1 INTEGER ARGUMENT ! 9654: # ! 9655: .align 2 ! 9656: .word bl$p1 ! 9657: p$pos: # p1blk ! 9658: # ! 9659: # EXPRESSION ARGUMENT CASE MERGES HERE ! 9660: # ! 9661: ppos1: cmpl r7,4*parm1(r9) # succeed if at right location ! 9662: bnequ 0f ! 9663: jmp succp ! 9664: 0: ! 9665: jmp failp # else fail ! 9666: #page ! 9667: # ! 9668: # POS (EXPRESSION ARGUMENT) ! 9669: # ! 9670: # PARM1 EXPRESSION POINTER ! 9671: # ! 9672: .align 2 ! 9673: .word bl$p1 ! 9674: p$psd: # p1blk ! 9675: jsb evali # evaluate integer argument ! 9676: .long er_050 # pos evaluated argument is not integer ! 9677: .long er_051 # pos evaluated argument is negative or too large ! 9678: .long failp # fail if evaluation fails ! 9679: .long ppos1 # merge with normal case if ok ! 9680: #page ! 9681: # ! 9682: # PATTERN ASSIGNMENT (INITIAL ENTRY, SAVE CURSOR) ! 9683: # ! 9684: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9685: # ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9686: # ! 9687: # NO PARAMETERS ! 9688: # ! 9689: .align 2 ! 9690: .word bl$p0 ! 9691: p$paa: # p0blk ! 9692: movl r7,-(sp) # stack initial cursor ! 9693: movl $ndpab,-(sp) # stack ptr to ndpab special node ! 9694: jmp succp # and succeed matching null ! 9695: #page ! 9696: # ! 9697: # PATTERN ASSIGNMENT (REMOVE SAVED CURSOR) ! 9698: # ! 9699: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9700: # ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9701: # ! 9702: # NO PARAMETERS (DUMMY PATTERN) ! 9703: # ! 9704: p$pab: # entry point ! 9705: jmp failp # just fail (entry is already popped) ! 9706: #page ! 9707: # ! 9708: # PATTERN ASSIGNMENT (END OF MATCH, MAKE ASSIGN ENTRY) ! 9709: # ! 9710: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9711: # ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9712: # ! 9713: # PARM1 NAME BASE OF VARIABLE ! 9714: # PARM2 NAME OFFSET OF VARIABLE ! 9715: # ! 9716: .align 2 ! 9717: .word bl$p2 ! 9718: p$pac: # p2blk ! 9719: movl r7,-(sp) # stack dummy cursor value ! 9720: movl r9,-(sp) # stack pointer to p$pac node ! 9721: movl r7,-(sp) # stack final cursor ! 9722: movl $ndpad,-(sp) # stack ptr to special ndpad node ! 9723: movl sp,pmdfl # set dot flag non-zero ! 9724: jmp succp # and succeed ! 9725: #page ! 9726: # ! 9727: # PATTERN ASSIGNMENT (REMOVE ASSIGN ENTRY) ! 9728: # ! 9729: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9730: # ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9731: # ! 9732: # NO PARAMETERS (DUMMY NODE) ! 9733: # ! 9734: p$pad: # entry point ! 9735: jmp flpop # fail and remove p$pac node ! 9736: #page ! 9737: # ! 9738: # REM ! 9739: # ! 9740: # NO PARAMETERS ! 9741: # ! 9742: .align 2 ! 9743: .word bl$p0 ! 9744: p$rem: # p0blk ! 9745: movl pmssl,r7 # point cursor to end of string ! 9746: jmp succp # and succeed ! 9747: #page ! 9748: # ! 9749: # RPOS (EXPRESSION ARGUMENT) ! 9750: # ! 9751: # PARM1 EXPRESSION POINTER ! 9752: # ! 9753: .align 2 ! 9754: .word bl$p1 ! 9755: p$rpd: # p1blk ! 9756: jsb evali # evaluate integer argument ! 9757: .long er_052 # rpos evaluated argument is not integer ! 9758: .long er_053 # rpos evaluated argument is negative or too large ! 9759: .long failp # fail if evaluation fails ! 9760: .long prps1 # merge with normal case if ok ! 9761: #page ! 9762: # ! 9763: # RPOS (INTEGER ARGUMENT) ! 9764: # ! 9765: # PARM1 INTEGER ARGUMENT ! 9766: # ! 9767: .align 2 ! 9768: .word bl$p1 ! 9769: p$rps: # p1blk ! 9770: # ! 9771: # EXPRESSION ARGUMENT CASE MERGES HERE ! 9772: # ! 9773: prps1: movl pmssl,r8 # get length of string ! 9774: subl2 r7,r8 # get number of characters remaining ! 9775: cmpl r8,4*parm1(r9) # succeed if at right location ! 9776: bnequ 0f ! 9777: jmp succp ! 9778: 0: ! 9779: jmp failp # else fail ! 9780: #page ! 9781: # ! 9782: # RTAB (INTEGER ARGUMENT) ! 9783: # ! 9784: # PARM1 INTEGER ARGUMENT ! 9785: # ! 9786: .align 2 ! 9787: .word bl$p1 ! 9788: p$rtb: # p1blk ! 9789: # ! 9790: # EXPRESSION ARGUMENT CASE MERGES HERE ! 9791: # ! 9792: prtb1: movl r7,r8 # save initial cursor ! 9793: movl pmssl,r7 # point to end of string ! 9794: cmpl r7,4*parm1(r9) # fail if string not long enough ! 9795: bgequ 0f ! 9796: jmp failp ! 9797: 0: ! 9798: subl2 4*parm1(r9),r7 # else set new cursor ! 9799: cmpl r7,r8 # and succeed if not too far already ! 9800: blssu 0f ! 9801: jmp succp ! 9802: 0: ! 9803: jmp failp # in which case, fail ! 9804: #page ! 9805: # ! 9806: # RTAB (EXPRESSION ARGUMENT) ! 9807: # ! 9808: # PARM1 EXPRESSION POINTER ! 9809: # ! 9810: .align 2 ! 9811: .word bl$p1 ! 9812: p$rtd: # p1blk ! 9813: jsb evali # evaluate integer argument ! 9814: .long er_054 # rtab evaluated argument is not integer ! 9815: .long er_055 # rtab evaluated argument is negative or too large ! 9816: .long failp # fail if evaluation fails ! 9817: .long prtb1 # merge with normal case if success ! 9818: #page ! 9819: # ! 9820: # SPAN (EXPRESSION ARGUMENT) ! 9821: # ! 9822: # PARM1 EXPRESSION POINTER ! 9823: # ! 9824: .align 2 ! 9825: .word bl$p1 ! 9826: p$spd: # p1blk ! 9827: jsb evals # evaluate string argument ! 9828: .long er_056 # span evaluated argument is not string ! 9829: .long failp # fail if evaluation fails ! 9830: .long pspn1 # merge with multi-char case if ok ! 9831: #page ! 9832: # ! 9833: # SPAN (MULTI-CHARACTER ARGUMENT CASE) ! 9834: # ! 9835: # PARM1 POINTER TO CTBLK ! 9836: # PARM2 BIT MASK TO SELECT BIT COLUMN ! 9837: # ! 9838: .align 2 ! 9839: .word bl$p2 ! 9840: p$spn: # p2blk ! 9841: # ! 9842: # EXPRESSION ARGUMENT CASE MERGES HERE ! 9843: # ! 9844: pspn1: movl pmssl,r8 # copy subject string length ! 9845: subl2 r7,r8 # calculate number of characters left ! 9846: tstl r8 # fail if no characters left ! 9847: bnequ 0f ! 9848: jmp failp ! 9849: 0: ! 9850: movl r$pms,r10 # point to subject string ! 9851: movab cfp$f(r10)[r7],r10 # point to current character ! 9852: movl r7,psavc # save initial cursor ! 9853: movl r9,psave # save node pointer ! 9854: # set counter for chars left ! 9855: # ! 9856: # LOOP TO SCAN MATCHING CHARACTERS ! 9857: # ! 9858: pspn2: movzbl (r10)+,r6 # load next character, bump pointer ! 9859: moval 0[r6],r6 # convert to byte offset ! 9860: movl 4*parm1(r9),r9 # point to ctblk ! 9861: addl2 r6,r9 # point to ctblk entry ! 9862: movl 4*ctchs(r9),r6 # load ctblk entry ! 9863: movl psave,r9 # restore node pointer ! 9864: mcoml 4*parm2(r9),r11 # and with selected bit ! 9865: bicl2 r11,r6 ! 9866: tstl r6 # jump if no match ! 9867: beqlu pspn3 ! 9868: incl r7 # else push cursor ! 9869: sobgtr r8,pspn2 # loop back unless end of string ! 9870: # ! 9871: # HERE AFTER SCANNING MATCHING CHARACTERS ! 9872: # ! 9873: pspn3: cmpl r7,psavc # succeed if chars matched ! 9874: beqlu 0f ! 9875: jmp succp ! 9876: 0: ! 9877: jmp failp # else fail if null string matched ! 9878: #page ! 9879: # ! 9880: # SPAN (ONE CHARACTER ARGUMENT) ! 9881: # ! 9882: # PARM1 CHARACTER ARGUMENT ! 9883: # ! 9884: .align 2 ! 9885: .word bl$p1 ! 9886: p$sps: # p1blk ! 9887: movl pmssl,r8 # get subject string length ! 9888: subl2 r7,r8 # calculate number of characters left ! 9889: tstl r8 # fail if no characters left ! 9890: bnequ 0f ! 9891: jmp failp ! 9892: 0: ! 9893: movl r$pms,r10 # else point to subject string ! 9894: movab cfp$f(r10)[r7],r10 # point to current character ! 9895: movl r7,psavc # save initial cursor ! 9896: # set counter for characters left ! 9897: # ! 9898: # LOOP TO SCAN MATCHING CHARACTERS ! 9899: # ! 9900: psps1: movzbl (r10)+,r6 # load next character, bump pointer ! 9901: cmpl r6,4*parm1(r9) # jump if no match ! 9902: bnequ psps2 ! 9903: incl r7 # else push cursor ! 9904: sobgtr r8,psps1 # and loop unless end of string ! 9905: # ! 9906: # HERE AFTER SCANNING MATCHING CHARACTERS ! 9907: # ! 9908: psps2: cmpl r7,psavc # succeed if chars matched ! 9909: beqlu 0f ! 9910: jmp succp ! 9911: 0: ! 9912: jmp failp # fail if null string matched ! 9913: #page ! 9914: # ! 9915: # MULTI-CHARACTER STRING ! 9916: # ! 9917: # NOTE THAT ONE CHARACTER STRINGS USE THE CIRCUIT FOR ! 9918: # ONE CHARACTER ANY ARGUMENTS (P$AN1). ! 9919: # ! 9920: # PARM1 POINTER TO SCBLK FOR STRING ARG ! 9921: # ! 9922: .align 2 ! 9923: .word bl$p1 ! 9924: p$str: # p1blk ! 9925: movl 4*parm1(r9),r10 # get pointer to string ! 9926: # ! 9927: # MERGE HERE AFTER EVALUATING EXPRESSION WITH STRING VALUE ! 9928: # ! 9929: pstr1: movl r9,psave # save node pointer ! 9930: movl r$pms,r9 # load subject string pointer ! 9931: movab cfp$f(r9)[r7],r9# point to current character ! 9932: addl2 4*sclen(r10),r7 # compute new cursor position ! 9933: cmpl r7,pmssl # fail if past end of string ! 9934: blequ 0f ! 9935: jmp failp ! 9936: 0: ! 9937: movl r7,psavc # save updated cursor ! 9938: movl 4*sclen(r10),r6 # get number of chars to compare ! 9939: movab cfp$f(r10),r10 # point to chars of test string ! 9940: jsb sbcmc # compare, fail if not equal ! 9941: .long failp ! 9942: .long failp ! 9943: movl psave,r9 # if all matched, restore node ptr ! 9944: movl psavc,r7 # restore updated cursor ! 9945: jmp succp # and succeed ! 9946: #page ! 9947: # ! 9948: # SUCCEED ! 9949: # ! 9950: # SEE SECTION ON COMPOUND PATTERNS FOR DETAILS OF THE ! 9951: # STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE ! 9952: # ! 9953: # NO PARAMETERS ! 9954: # ! 9955: .align 2 ! 9956: .word bl$p0 ! 9957: p$suc: # p0blk ! 9958: movl r7,-(sp) # stack cursor ! 9959: movl r9,-(sp) # stack pointer to this node ! 9960: jmp succp # succeed matching null ! 9961: #page ! 9962: # ! 9963: # TAB (INTEGER ARGUMENT) ! 9964: # ! 9965: # PARM1 INTEGER ARGUMENT ! 9966: # ! 9967: .align 2 ! 9968: .word bl$p1 ! 9969: p$tab: # p1blk ! 9970: # ! 9971: # EXPRESSION ARGUMENT CASE MERGES HERE ! 9972: # ! 9973: ptab1: cmpl r7,4*parm1(r9) # fail if too far already ! 9974: blequ 0f ! 9975: jmp failp ! 9976: 0: ! 9977: movl 4*parm1(r9),r7 # else set new cursor position ! 9978: cmpl r7,pmssl # succeed if not off end ! 9979: bgtru 0f ! 9980: jmp succp ! 9981: 0: ! 9982: jmp failp # else fail ! 9983: #page ! 9984: # ! 9985: # TAB (EXPRESSION ARGUMENT) ! 9986: # ! 9987: # PARM1 EXPRESSION POINTER ! 9988: # ! 9989: .align 2 ! 9990: .word bl$p1 ! 9991: p$tbd: # p1blk ! 9992: jsb evali # evaluate integer argument ! 9993: .long er_057 # tab evaluated argument is not integer ! 9994: .long er_058 # tab evaluated argument is negative or too large ! 9995: .long failp # fail if evaluation fails ! 9996: .long ptab1 # merge with normal case if ok ! 9997: #page ! 9998: # ! 9999: # ANCHOR MOVEMENT ! 10000: # ! 10001: # NO PARAMETERS (DUMMY NODE) ! 10002: # ! 10003: p$una: # entry point ! 10004: movl r7,r9 # copy initial pattern node pointer ! 10005: movl (sp),r7 # get initial cursor ! 10006: cmpl r7,pmssl # match fails if at end of string ! 10007: bnequ 0f ! 10008: jmp exfal ! 10009: 0: ! 10010: incl r7 # else increment cursor ! 10011: movl r7,(sp) # store incremented cursor ! 10012: movl r9,-(sp) # restack initial node ptr ! 10013: movl $nduna,-(sp) # restack unanchored node ! 10014: movl (r9),r11 # rematch first node ! 10015: jmp (r11) ! 10016: #page ! 10017: # ! 10018: # END OF PATTERN MATCH ROUTINES ! 10019: # ! 10020: # THE FOLLOWING ENTRY POINT MARKS THE END OF THE PATTERN ! 10021: # MATCHING ROUTINES AND ALSO THE END OF THE ENTRY POINTS ! 10022: # REFERENCED FROM THE FIRST WORD OF BLOCKS IN DYNAMIC STORE ! 10023: # ! 10024: .align 2 ! 10025: .word bl$$i ! 10026: p$yyy: # mark last entry in pattern section ! 10027: #title s p i t b o l -- predefined snobol4 functions ! 10028: # ! 10029: # THE FOLLOWING SECTION CONTAINS CODING FOR FUNCTIONS ! 10030: # WHICH ARE PREDEFINED AND AVAILABLE AT THE SNOBOL LEVEL. ! 10031: # ! 10032: # THESE ROUTINES RECEIVE CONTROL DIRECTLY FROM THE CODE OR ! 10033: # INDIRECTLY THROUGH THE O$FNC, O$FNS OR CFUNC ROUTINES. ! 10034: # IN BOTH CASES THE CONDITIONS ON ENTRY ARE AS FOLLOWS ! 10035: # ! 10036: # THE ARGUMENTS ARE ON THE STACK. THE NUMBER OF ARGUMENTS ! 10037: # HAS BEEN ADJUSTED TO CORRESPOND TO THE SVBLK SVNAR FIELD. ! 10038: # ! 10039: # IN CERTAIN FUNCTIONS THE DIRECT CALL IS NOT PERMITTED ! 10040: # AND IN THESE INSTANCES WE ALSO HAVE. ! 10041: # ! 10042: # (WA) ACTUAL NUMBER OF ARGUMENTS IN CALL ! 10043: # ! 10044: # CONTROL RETURNS BY PLACING THE FUNCTION RESULT VALUE ON ! 10045: # ON THE STACK AND CONTINUING EXECUTION WITH THE NEXT ! 10046: # WORD FROM THE GENERATED CODE. ! 10047: # ! 10048: # THE NAMES OF THE ENTRY POINTS OF THESE FUNCTIONS ARE OF ! 10049: # THE FORM S$XXX WHERE XXX IS THE THREE LETTER CODE FOR ! 10050: # THE SYSTEM VARIABLE NAME. THE FUNCTIONS ARE IN ORDER ! 10051: # ALPHABETICALLY BY THEIR ENTRY NAMES. ! 10052: #page ! 10053: # ! 10054: # ANY ! 10055: # ! 10056: s$any: # entry point ! 10057: movl $p$ans,r7 # set pcode for single char case ! 10058: movl $p$any,r10 # pcode for multi-char case ! 10059: movl $p$ayd,r8 # pcode for expression case ! 10060: jsb patst # call common routine to build node ! 10061: .long er_059 # any argument is not string or expression ! 10062: jmp exixr # jump for next code word ! 10063: #page ! 10064: # ! 10065: # APPEND ! 10066: # ! 10067: s$apn: # entry point ! 10068: movl (sp)+,r10 # get append argument ! 10069: movl (sp)+,r9 # get bcblk ! 10070: cmpl (r9),$b$bct # ok if first arg is bcblk ! 10071: beqlu sapn1 ! 10072: jmp er_275 # append first argument is not buffer ! 10073: # ! 10074: # HERE TO DO THE APPEND ! 10075: # ! 10076: sapn1: jsb apndb # do the append ! 10077: .long er_276 # append second argument is not string ! 10078: .long exfal # no room - fail ! 10079: jmp exnul # exit with null result ! 10080: #page ! 10081: # ! 10082: # APPLY ! 10083: # ! 10084: # APPLY DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT ! 10085: # WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED. ! 10086: # ! 10087: s$app: # entry point ! 10088: tstl r6 # jump if no arguments ! 10089: beqlu sapp3 ! 10090: decl r6 # else get applied func arg count ! 10091: movl r6,r7 # copy ! 10092: moval 0[r7],r7 # convert to bytes ! 10093: movl sp,r10 # copy stack pointer ! 10094: addl2 r7,r10 # point to function argument on stack ! 10095: movl (r10),r9 # load function ptr (apply 1st arg) ! 10096: tstl r6 # jump if no args for applied func ! 10097: beqlu sapp2 ! 10098: movl r6,r7 # else set counter for loop ! 10099: # ! 10100: # LOOP TO MOVE ARGUMENTS UP ON STACK ! 10101: # ! 10102: sapp1: subl2 $4,r10 # point to next argument ! 10103: movl (r10),4*1(r10) # move argument up ! 10104: sobgtr r7,sapp1 # loop till all moved ! 10105: # ! 10106: # MERGE HERE TO CALL FUNCTION (WA = NUMBER OF ARGUMENTS) ! 10107: # ! 10108: sapp2: addl2 $4,sp # adjust stack ptr for apply 1st arg ! 10109: jsb gtnvr # get variable block addr for func ! 10110: .long sapp3 # jump if not natural variable ! 10111: movl 4*vrfnc(r9),r10 # else point to function block ! 10112: jmp cfunc # go call applied function ! 10113: # ! 10114: # HERE FOR INVALID FIRST ARGUMENT ! 10115: # ! 10116: sapp3: jmp er_060 # apply first arg is not natural variable name ! 10117: #page ! 10118: # ! 10119: # ARBNO ! 10120: # ! 10121: # ARBNO BUILDS A COMPOUND PATTERN. SEE DESCRIPTION AT ! 10122: # START OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED. ! 10123: # ! 10124: s$abn: # entry point ! 10125: clrl r9 # set parm1 = 0 for the moment ! 10126: movl $p$alt,r7 # set pcode for alternative node ! 10127: jsb pbild # build alternative node ! 10128: movl r9,r10 # save ptr to alternative pattern ! 10129: movl $p$abc,r7 # pcode for p$abc ! 10130: clrl r9 # p0blk ! 10131: jsb pbild # build p$abc node ! 10132: movl r10,4*pthen(r9) # put alternative node as successor ! 10133: movl r10,r6 # remember alternative node pointer ! 10134: movl r9,r10 # copy p$abc node ptr ! 10135: movl (sp),r9 # load arbno argument ! 10136: movl r6,(sp) # stack alternative node pointer ! 10137: jsb gtpat # get arbno argument as pattern ! 10138: .long er_061 # arbno argument is not pattern ! 10139: jsb pconc # concat arg with p$abc node ! 10140: movl r9,r10 # remember ptr to concd patterns ! 10141: movl $p$aba,r7 # pcode for p$aba ! 10142: clrl r9 # p0blk ! 10143: jsb pbild # build p$aba node ! 10144: movl r10,4*pthen(r9) # concatenate nodes ! 10145: movl (sp),r10 # recall ptr to alternative node ! 10146: movl r9,4*parm1(r10) # point alternative back to argument ! 10147: jmp exits # jump for next code word ! 10148: #page ! 10149: # ! 10150: # ARG ! 10151: # ! 10152: s$arg: # entry point ! 10153: jsb gtsmi # get second arg as small integer ! 10154: .long er_062 # arg second argument is not integer ! 10155: .long exfal # fail if out of range or negative ! 10156: movl r9,r6 # save argument number ! 10157: movl (sp)+,r9 # load first argument ! 10158: jsb gtnvr # locate vrblk ! 10159: .long sarg1 # jump if not natural variable ! 10160: movl 4*vrfnc(r9),r9 # else load function block pointer ! 10161: cmpl (r9),$b$pfc # jump if not program defined ! 10162: bnequ sarg1 ! 10163: tstl r6 # fail if arg number is zero ! 10164: bnequ 0f ! 10165: jmp exfal ! 10166: 0: ! 10167: cmpl r6,4*fargs(r9) # fail if arg number is too large ! 10168: blequ 0f ! 10169: jmp exfal ! 10170: 0: ! 10171: moval 0[r6],r6 # else convert to byte offset ! 10172: addl2 r6,r9 # point to argument selected ! 10173: movl 4*pfagb(r9),r9 # load argument vrblk pointer ! 10174: jmp exvnm # exit to build nmblk ! 10175: # ! 10176: # HERE IF 1ST ARGUMENT IS BAD ! 10177: # ! 10178: sarg1: jmp er_063 # arg first argument is not program function name ! 10179: #page ! 10180: # ! 10181: # ARRAY ! 10182: # ! 10183: s$arr: # entry point ! 10184: movl (sp)+,r10 # load initial element value ! 10185: movl (sp)+,r9 # load first argument ! 10186: jsb gtint # convert first arg to integer ! 10187: .long sar02 # jump if not integer ! 10188: # ! 10189: # HERE FOR INTEGER FIRST ARGUMENT, BUILD VCBLK ! 10190: # ! 10191: movl 4*icval(r9),r5 # load integer value ! 10192: tstl r5 # jump if zero or neg (bad dimension) ! 10193: bgtr 0f ! 10194: jmp sar10 ! 10195: 0: ! 10196: movl r5,r6 # else convert to one word, test ovfl ! 10197: bgeq 0f ! 10198: jmp sar11 ! 10199: 0: ! 10200: movl r6,r7 # copy elements for loop later on ! 10201: addl2 $vcsi$,r6 # add space for standard fields ! 10202: moval 0[r6],r6 # convert length to bytes ! 10203: cmpl r6,mxlen # fail if too large ! 10204: blssu 0f ! 10205: jmp sar11 ! 10206: 0: ! 10207: jsb alloc # allocate space for vcblk ! 10208: movl $b$vct,(r9) # store type word ! 10209: movl r6,4*vclen(r9) # set length ! 10210: movl r10,r8 # copy default value ! 10211: movl r9,r10 # copy vcblk pointer ! 10212: addl2 $4*vcvls,r10 # point to first element value ! 10213: # ! 10214: # LOOP TO SET VECTOR ELEMENTS TO DEFAULT VALUE ! 10215: # ! 10216: sar01: movl r8,(r10)+ # store one value ! 10217: sobgtr r7,sar01 # loop till all stored ! 10218: jmp exsid # exit setting idval ! 10219: #page ! 10220: # ! 10221: # ARRAY (CONTINUED) ! 10222: # ! 10223: # HERE IF FIRST ARGUMENT IS NOT AN INTEGER ! 10224: # ! 10225: sar02: movl r9,-(sp) # replace argument on stack ! 10226: jsb xscni # initialize scan of first argument ! 10227: .long er_064 # array first argument is not integer or string ! 10228: .long exnul # dummy (unused) null string exit ! 10229: movl r$xsc,-(sp) # save prototype pointer ! 10230: movl r10,-(sp) # save default value ! 10231: clrl arcdm # zero count of dimensions ! 10232: clrl arptr # zero offset to indicate pass one ! 10233: movl intv1,r5 # load integer one ! 10234: movl r5,arnel # initialize element count ! 10235: # ! 10236: # THE FOLLOWING CODE IS EXECUTED TWICE. THE FIRST TIME ! 10237: # (ARPTR EQ 0), IT IS USED TO COUNT THE NUMBER OF ELEMENTS ! 10238: # AND NUMBER OF DIMENSIONS. THE SECOND TIME (ARPTR GT 0) IS ! 10239: # USED TO ACTUALLY FILL IN THE DIM,LBD FIELDS OF THE ARBLK. ! 10240: # ! 10241: sar03: movl intv1,r5 # load one as default low bound ! 10242: movl r5,arsvl # save as low bound ! 10243: movl $ch$cl,r8 # set delimiter one = colon ! 10244: movl $ch$cm,r10 # set delimiter two = comma ! 10245: jsb xscan # scan next bound ! 10246: cmpl r6,$num01 # jump if not colon ! 10247: bnequ sar04 ! 10248: # ! 10249: # HERE WE HAVE A COLON ENDING A LOW BOUND ! 10250: # ! 10251: jsb gtint # convert low bound ! 10252: .long er_065 # array first argument lower bound is not integer ! 10253: movl 4*icval(r9),r5 # load value of low bound ! 10254: movl r5,arsvl # store low bound value ! 10255: movl $ch$cm,r8 # set delimiter one = comma ! 10256: movl r8,r10 # and delimiter two = comma ! 10257: jsb xscan # scan high bound ! 10258: #page ! 10259: # ! 10260: # ARRAY (CONTINUED) ! 10261: # ! 10262: # MERGE HERE TO PROCESS UPPER BOUND ! 10263: # ! 10264: sar04: jsb gtint # convert high bound to integer ! 10265: .long er_066 # array first argument upper bound is not integer ! 10266: movl 4*icval(r9),r5 # get high bound ! 10267: subl2 arsvl,r5 # subtract lower bound ! 10268: bvc 0f ! 10269: jmp sar10 ! 10270: 0: ! 10271: tstl r5 # bad dimension if negative ! 10272: bgeq 0f ! 10273: jmp sar10 ! 10274: 0: ! 10275: addl2 intv1,r5 # add 1 to get dimension ! 10276: bvc 0f ! 10277: jmp sar10 ! 10278: 0: ! 10279: movl arptr,r10 # load offset (also pass indicator) ! 10280: tstl r10 # jump if first pass ! 10281: beqlu sar05 ! 10282: # ! 10283: # HERE IN SECOND PASS TO STORE LBD AND DIM IN ARBLK ! 10284: # ! 10285: addl2 (sp),r10 # point to current location in arblk ! 10286: movl r5,4*cfp$i(r10) # store dimension ! 10287: movl arsvl,r5 # load low bound ! 10288: movl r5,(r10) # store low bound ! 10289: addl2 $4*ardms,arptr # bump offset to next bounds ! 10290: jmp sar06 # jump to check for end of bounds ! 10291: # ! 10292: # HERE IN PASS 1 ! 10293: # ! 10294: sar05: incl arcdm # bump dimension count ! 10295: mull2 arnel,r5 # multiply dimension by count so far ! 10296: bvc 0f ! 10297: jmp sar11 ! 10298: 0: ! 10299: movl r5,arnel # else store updated element count ! 10300: # ! 10301: # MERGE HERE AFTER PROCESSING ONE SET OF BOUNDS ! 10302: # ! 10303: sar06: tstl r6 # loop back unless end of bounds ! 10304: beqlu 0f ! 10305: jmp sar03 ! 10306: 0: ! 10307: tstl arptr # jump if end of pass 2 ! 10308: beqlu 0f ! 10309: jmp sar09 ! 10310: 0: ! 10311: #page ! 10312: # ! 10313: # ARRAY (CONTINUED) ! 10314: # ! 10315: # HERE AT END OF PASS ONE, BUILD ARBLK ! 10316: # ! 10317: movl arnel,r5 # get number of elements ! 10318: movl r5,r7 # get as addr integer, test ovflo ! 10319: bgeq 0f ! 10320: jmp sar11 ! 10321: 0: ! 10322: moval 0[r7],r7 # else convert to length in bytes ! 10323: movl $4*arsi$,r6 # set size of standard fields ! 10324: movl arcdm,r8 # set dimension count to control loop ! 10325: # ! 10326: # LOOP TO ALLOW SPACE FOR DIMENSIONS ! 10327: # ! 10328: sar07: addl2 $4*ardms,r6 # allow space for one set of bounds ! 10329: sobgtr r8,sar07 # loop back till all accounted for ! 10330: movl r6,r10 # save size (=arofs) ! 10331: # ! 10332: # NOW ALLOCATE SPACE FOR ARBLK ! 10333: # ! 10334: addl2 r7,r6 # add space for elements ! 10335: addl2 $4,r6 # allow for arpro prototype field ! 10336: cmpl r6,mxlen # fail if too large ! 10337: blssu 0f ! 10338: jmp sar11 ! 10339: 0: ! 10340: jsb alloc # else allocate arblk ! 10341: movl (sp),r7 # load default value ! 10342: movl r9,(sp) # save arblk pointer ! 10343: movl r6,r8 # save length in bytes ! 10344: ashl $-2,r6,r6 # convert length back to words ! 10345: # set counter to control loop ! 10346: # ! 10347: # LOOP TO CLEAR ENTIRE ARBLK TO DEFAULT VALUE ! 10348: # ! 10349: sar08: movl r7,(r9)+ # set one word ! 10350: sobgtr r6,sar08 # loop till all set ! 10351: #page ! 10352: # ! 10353: # ARRAY (CONTINUED) ! 10354: # ! 10355: # NOW SET INITIAL FIELDS OF ARBLK ! 10356: # ! 10357: movl (sp)+,r9 # reload arblk pointer ! 10358: movl (sp),r7 # load prototype ! 10359: movl $b$art,(r9) # set type word ! 10360: movl r8,4*arlen(r9) # store length in bytes ! 10361: clrl 4*idval(r9) # zero id till we get it built ! 10362: movl r10,4*arofs(r9) # set prototype field ptr ! 10363: movl arcdm,4*arndm(r9)# set number of dimensions ! 10364: movl r9,r8 # save arblk pointer ! 10365: addl2 r10,r9 # point to prototype field ! 10366: movl r7,(r9) # store prototype ptr in arblk ! 10367: movl $4*arlbd,arptr # set offset for pass 2 bounds scan ! 10368: movl r7,r$xsc # reset string pointer for xscan ! 10369: movl r8,(sp) # store arblk pointer on stack ! 10370: clrl xsofs # reset offset ptr to start of string ! 10371: jmp sar03 # jump back to rescan bounds ! 10372: # ! 10373: # HERE AFTER FILLING IN BOUNDS INFORMATION (END PASS TWO) ! 10374: # ! 10375: sar09: movl (sp)+,r9 # reload pointer to arblk ! 10376: jmp exsid # exit setting idval ! 10377: # ! 10378: # HERE FOR BAD DIMENSION ! 10379: # ! 10380: sar10: jmp er_067 # array dimension is zero,negative or out of range ! 10381: # ! 10382: # HERE IF ARRAY IS TOO LARGE ! 10383: # ! 10384: sar11: jmp er_068 # array size exceeds maximum permitted ! 10385: #page ! 10386: # ! 10387: # BUFFER ! 10388: # ! 10389: s$buf: # entry point ! 10390: movl (sp)+,r10 # get initial value ! 10391: movl (sp)+,r9 # get requested allocation ! 10392: jsb gtint # convert to integer ! 10393: .long er_269 # buffer first argument is not integer ! 10394: movl 4*icval(r9),r5 # get value ! 10395: tstl r5 # branch if negative or zero ! 10396: bleq sbf01 ! 10397: movl r5,r6 # move with overflow check ! 10398: bgeq 0f ! 10399: jmp sbf02 ! 10400: 0: ! 10401: jsb alobf # allocate the buffer ! 10402: jsb apndb # copy it in ! 10403: .long er_270 # buffer second argument is not string or buffer ! 10404: .long er_271 # buffer initial value too big for allocation ! 10405: jmp exsid # exit setting idval ! 10406: # ! 10407: # HERE FOR INVALID ALLOCATION SIZE ! 10408: # ! 10409: sbf01: jmp er_272 # buffer first argument is not positive ! 10410: # ! 10411: # HERE FOR ALLOCATION SIZE INTEGER OVERFLOW ! 10412: # ! 10413: sbf02: jmp er_273 # buffer size is too big ! 10414: #page ! 10415: # ! 10416: # BREAK ! 10417: # ! 10418: s$brk: # entry point ! 10419: movl $p$bks,r7 # set pcode for single char case ! 10420: movl $p$brk,r10 # pcode for multi-char case ! 10421: movl $p$bkd,r8 # pcode for expression case ! 10422: jsb patst # call common routine to build node ! 10423: .long er_069 # break argument is not string or expression ! 10424: jmp exixr # jump for next code word ! 10425: #page ! 10426: # ! 10427: # BREAKX ! 10428: # ! 10429: # BREAKX IS A COMPOUND PATTERN. SEE DESCRIPTION AT START ! 10430: # OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED. ! 10431: # ! 10432: s$bkx: # entry point ! 10433: movl $p$bks,r7 # pcode for single char argument ! 10434: movl $p$brk,r10 # pcode for multi-char argument ! 10435: movl $p$bxd,r8 # pcode for expression case ! 10436: jsb patst # call common routine to build node ! 10437: .long er_070 # breakx argument is not string or expression ! 10438: # ! 10439: # NOW HOOK BREAKX NODE ON AT FRONT END ! 10440: # ! 10441: movl r9,-(sp) # save ptr to break node ! 10442: movl $p$bkx,r7 # set pcode for breakx node ! 10443: jsb pbild # build it ! 10444: movl (sp),4*pthen(r9)# set break node as successor ! 10445: movl $p$alt,r7 # set pcode for alternation node ! 10446: jsb pbild # build (parm1=alt=breakx node) ! 10447: movl r9,r6 # save ptr to alternation node ! 10448: movl (sp),r9 # point to break node ! 10449: movl r6,4*pthen(r9) # set alternate node as successor ! 10450: jmp exits # exit with result on stack ! 10451: #page ! 10452: # ! 10453: # CHAR ! 10454: # ! 10455: s$chr: # entry point ! 10456: jsb gtsmi # convert arg to integer ! 10457: .long er_281 # char argument not integer ! 10458: .long schr1 # too big error exit ! 10459: cmpl r8,$cfp$a # see if out of range of host set ! 10460: bgequ schr1 ! 10461: movl $num01,r6 # if not set scblk allocation ! 10462: movl r8,r7 # save char code ! 10463: jsb alocs # allocate 1 bau scblk ! 10464: movl r9,r10 # copy scblk pointer ! 10465: movab cfp$f(r10),r10 # get set to stuff char ! 10466: movb r7,(r10)+ # stuff it ! 10467: clrl r10 # clear slop in xl ! 10468: jmp exixr # exit with scblk pointer ! 10469: # ! 10470: # HERE IF CHAR ARGUMENT IS OUT OF RANGE ! 10471: # ! 10472: schr1: jmp er_282 # char argument not in range ! 10473: #page ! 10474: # ! 10475: # CLEAR ! 10476: # ! 10477: s$clr: # entry point ! 10478: jsb xscni # initialize to scan argument ! 10479: .long er_071 # clear argument is not string ! 10480: .long sclr2 # jump if null ! 10481: # ! 10482: # LOOP TO SCAN OUT NAMES IN FIRST ARGUMENT. VARIABLES IN ! 10483: # THE LIST ARE FALGGED BY SETTING VRGET OF VRBLK TO ZERO. ! 10484: # ! 10485: sclr1: movl $ch$cm,r8 # set delimiter one = comma ! 10486: movl r8,r10 # delimiter two = comma ! 10487: jsb xscan # scan next variable name ! 10488: jsb gtnvr # locate vrblk ! 10489: .long er_072 # clear argument has null variable name ! 10490: clrl 4*vrget(r9) # else flag by zeroing vrget field ! 10491: tstl r6 # loop back if stopped by comma ! 10492: bnequ sclr1 ! 10493: # ! 10494: # HERE AFTER FLAGGING VARIABLES IN ARGUMENT LIST ! 10495: # ! 10496: sclr2: movl hshtb,r7 # point to start of hash table ! 10497: # ! 10498: # LOOP THROUGH SLOTS IN HASH TABLE ! 10499: # ! 10500: sclr3: cmpl r7,hshte # exit returning null if none left ! 10501: bnequ 0f ! 10502: jmp exnul ! 10503: 0: ! 10504: movl r7,r9 # else copy slot pointer ! 10505: addl2 $4,r7 # bump slot pointer ! 10506: subl2 $4*vrnxt,r9 # set offset to merge into loop ! 10507: # ! 10508: # LOOP THROUGH VRBLKS ON ONE HASH CHAIN ! 10509: # ! 10510: sclr4: movl 4*vrnxt(r9),r9 # point to next vrblk on chain ! 10511: tstl r9 # jump for next bucket if chain end ! 10512: beqlu sclr3 ! 10513: tstl 4*vrget(r9) # jump if not flagged ! 10514: bnequ sclr5 ! 10515: #page ! 10516: # ! 10517: # CLEAR (CONTINUED) ! 10518: # ! 10519: # HERE FOR FLAGGED VARIABLE, DO NOT SET VALUE TO NULL ! 10520: # ! 10521: jsb setvr # for flagged var, restore vrget ! 10522: jmp sclr4 # and loop back for next vrblk ! 10523: # ! 10524: # HERE TO SET VALUE OF A VARIABLE TO NULL ! 10525: # PRROTECTED VARIABLES (ARB, ETC) ARE EXEMPT ! 10526: # ! 10527: sclr5: cmpl 4*vrsto(r9),$b$vre # check for protected variable (reg05) ! 10528: beqlu sclr4 ! 10529: movl r9,r10 # copy vrblk pointer (reg05) ! 10530: # ! 10531: # LOOP TO LOCATE VALUE AT END OF POSSIBLE TRBLK CHAIN ! 10532: # ! 10533: sclr6: movl r10,r6 # save block pointer ! 10534: movl 4*vrval(r10),r10# load next value field ! 10535: cmpl (r10),$b$trt # loop back if trapped ! 10536: beqlu sclr6 ! 10537: # ! 10538: # NOW STORE THE NULL VALUE ! 10539: # ! 10540: movl r6,r10 # restore block pointer ! 10541: movl $nulls,4*vrval(r10) # store null constant value ! 10542: jmp sclr4 # loop back for next vrblk ! 10543: #page ! 10544: # ! 10545: # CODE ! 10546: # ! 10547: s$cod: # entry point ! 10548: movl (sp)+,r9 # load argument ! 10549: jsb gtcod # convert to code ! 10550: .long exfal # fail if conversion is impossible ! 10551: jmp exixr # else return code as result ! 10552: #page ! 10553: # ! 10554: # COLLECT ! 10555: # ! 10556: s$col: # entry point ! 10557: movl (sp)+,r9 # load argument ! 10558: jsb gtint # convert to integer ! 10559: .long er_073 # collect argument is not integer ! 10560: movl 4*icval(r9),r5 # load collect argument ! 10561: movl r5,clsvi # save collect argument ! 10562: clrl r7 # set no move up ! 10563: jsb gbcol # perform garbage collection ! 10564: movl dname,r6 # point to end of memory ! 10565: subl2 dnamp,r6 # subtract next location ! 10566: ashl $-2,r6,r6 # convert bytes to words ! 10567: movl r6,r5 # convert words available as integer ! 10568: subl2 clsvi,r5 # subtract argument ! 10569: bvc 0f ! 10570: jmp exfal ! 10571: 0: ! 10572: tstl r5 # fail if not enough ! 10573: bgeq 0f ! 10574: jmp exfal ! 10575: 0: ! 10576: addl2 clsvi,r5 # else recompute available ! 10577: jmp exint # and exit with integer result ! 10578: #page ! 10579: # ! 10580: # CONVERT ! 10581: # ! 10582: s$cnv: # entry point ! 10583: jsb gtstg # convert second argument to string ! 10584: .long er_074 # convert second argument is not string ! 10585: jsb flstg # fold lower case to upper case ! 10586: movl (sp),r10 # load first argument ! 10587: cmpl (r10),$b$pdt # jump if not program defined ! 10588: bnequ scv01 ! 10589: # ! 10590: # HERE FOR PROGRAM DEFINED DATATYPE ! 10591: # ! 10592: movl 4*pddfp(r10),r10# point to dfblk ! 10593: movl 4*dfnam(r10),r10# load datatype name ! 10594: jsb ident # compare with second arg ! 10595: .long exits # exit if ident with arg as result ! 10596: jmp exfal # else fail ! 10597: # ! 10598: # HERE IF NOT PROGRAM DEFINED DATATYPE ! 10599: # ! 10600: scv01: movl r9,-(sp) # save string argument ! 10601: movl $svctb,r10 # point to table of names to compare ! 10602: clrl r7 # initialize counter ! 10603: movl r6,r8 # save length of argument string ! 10604: # ! 10605: # LOOP THROUGH TABLE ENTRIES ! 10606: # ! 10607: scv02: movl (r10)+,r9 # load next table entry, bump pointer ! 10608: tstl r9 # fail if zero marking end of list ! 10609: bnequ 0f ! 10610: jmp exfal ! 10611: 0: ! 10612: cmpl r8,4*sclen(r9) # jump if wrong length ! 10613: beqlu 0f ! 10614: jmp scv05 ! 10615: 0: ! 10616: movl r10,cnvtp # else store table pointer ! 10617: movab cfp$f(r9),r9 # point to chars of table entry ! 10618: movl (sp),r10 # load pointer to string argument ! 10619: movab cfp$f(r10),r10 # point to chars of string arg ! 10620: movl r8,r6 # set number of chars to compare ! 10621: jsb sbcmc # compare, jump if no match ! 10622: .long scv04 ! 10623: .long scv04 ! 10624: #page ! 10625: # ! 10626: # CONVERT (CONTINUED) ! 10627: # ! 10628: # HERE WE HAVE A MATCH ! 10629: # ! 10630: scv03: movl r7,r10 # copy entry number ! 10631: addl2 $4,sp # pop string arg off stack ! 10632: movl (sp)+,r9 # load first argument ! 10633: casel r10,$0,$cnvtt # jump to appropriate routine ! 10634: 5: ! 10635: .word scv06-5b # string ! 10636: .word scv07-5b # integer ! 10637: .word scv09-5b # name ! 10638: .word scv10-5b # pattern ! 10639: .word scv11-5b # array ! 10640: .word scv19-5b # table ! 10641: .word scv25-5b # expression ! 10642: .word scv26-5b # code ! 10643: .word scv27-5b # numeric ! 10644: .word scv08-5b # real ! 10645: .word scv28-5b # buffer ! 10646: #esw # end of switch table ! 10647: # ! 10648: # HERE IF NO MATCH WITH TABLE ENTRY ! 10649: # ! 10650: scv04: movl cnvtp,r10 # restore table pointer, merge ! 10651: # ! 10652: # MERGE HERE IF LENGTHS DID NOT MATCH ! 10653: # ! 10654: scv05: incl r7 # bump entry number ! 10655: jmp scv02 # loop back to check next entry ! 10656: # ! 10657: # HERE TO CONVERT TO STRING ! 10658: # ! 10659: scv06: movl r9,-(sp) # replace string argument on stack ! 10660: jsb gtstg # convert to string ! 10661: .long exfal # fail if conversion not possible ! 10662: jmp exixr # else return string ! 10663: #page ! 10664: # ! 10665: # CONVERT (CONTINUED) ! 10666: # ! 10667: # HERE TO CONVERT TO INTEGER ! 10668: # ! 10669: scv07: jsb gtint # convert to integer ! 10670: .long exfal # fail if conversion not possible ! 10671: jmp exixr # else return integer ! 10672: # ! 10673: # HERE TO CONVERT TO REAL ! 10674: # ! 10675: scv08: jsb gtrea # convert to real ! 10676: .long exfal # fail if conversion not possible ! 10677: jmp exixr # else return real ! 10678: # ! 10679: # HERE TO CONVERT TO NAME ! 10680: # ! 10681: scv09: cmpl (r9),$b$nml # return if already a name ! 10682: bnequ 0f ! 10683: jmp exixr ! 10684: 0: ! 10685: jsb gtnvr # else try string to name convert ! 10686: .long exfal # fail if conversion not possible ! 10687: jmp exvnm # else exit building nmblk for vrblk ! 10688: # ! 10689: # HERE TO CONVERT TO PATTERN ! 10690: # ! 10691: scv10: jsb gtpat # convert to pattern ! 10692: .long exfal # fail if conversion not possible ! 10693: jmp exixr # else return pattern ! 10694: # ! 10695: # CONVERT TO ARRAY ! 10696: # ! 10697: scv11: jsb gtarr # get an array ! 10698: .long exfal # fail if not convertible ! 10699: jmp exsid # exit setting id field ! 10700: # ! 10701: # CONVERT TO TABLE ! 10702: # ! 10703: scv19: movl (r9),r6 # load first word of block ! 10704: movl r9,-(sp) # replace arblk pointer on stack ! 10705: cmpl r6,$b$tbt # return arg if already a table ! 10706: bnequ 0f ! 10707: jmp exits ! 10708: 0: ! 10709: cmpl r6,$b$art # else fail if not an array ! 10710: beqlu 0f ! 10711: jmp exfal ! 10712: 0: ! 10713: #page ! 10714: # ! 10715: # CONVERT (CONTINUED) ! 10716: # ! 10717: # HERE TO CONVERT AN ARRAY TO TABLE ! 10718: # ! 10719: cmpl 4*arndm(r9),$num02 # fail if not 2-dim array ! 10720: beqlu 0f ! 10721: jmp exfal ! 10722: 0: ! 10723: movl 4*ardm2(r9),r5 # load dim 2 ! 10724: subl2 intv2,r5 # subtract 2 to compare ! 10725: tstl r5 # fail if dim2 not 2 ! 10726: beql 0f ! 10727: jmp exfal ! 10728: 0: ! 10729: # ! 10730: # HERE WE HAVE AN ARBLK OF THE RIGHT SHAPE ! 10731: # ! 10732: movl 4*ardim(r9),r5 # load dim 1 (number of elements) ! 10733: movl r5,r6 # get as one word integer ! 10734: movl r6,r7 # copy to control loop ! 10735: addl2 $tbsi$,r6 # add space for standard fields ! 10736: moval 0[r6],r6 # convert length to bytes ! 10737: jsb alloc # allocate space for tbblk ! 10738: movl r9,r8 # copy tbblk pointer ! 10739: movl r9,-(sp) # save tbblk pointer ! 10740: movl $b$tbt,(r9)+ # store type word ! 10741: clrl (r9)+ # store zero for idval for now ! 10742: movl r6,(r9)+ # store length ! 10743: movl $nulls,(r9)+ # null initial lookup value ! 10744: # ! 10745: # LOOP TO INITIALIZE BUCKET PTRS TO POINT TO TABLE ! 10746: # ! 10747: scv20: movl r8,(r9)+ # set bucket ptr to point to tbblk ! 10748: sobgtr r7,scv20 # loop till all initialized ! 10749: movl $4*arvl2,r7 # set offset to first arblk element ! 10750: # ! 10751: # LOOP TO COPY ELEMENTS FROM ARRAY TO TABLE ! 10752: # ! 10753: scv21: movl 4*1(sp),r10 # point to arblk ! 10754: cmpl r7,4*arlen(r10) # jump if all moved ! 10755: beqlu scv24 ! 10756: addl2 r7,r10 # else point to current location ! 10757: addl2 $4*num02,r7 # bump offset ! 10758: movl (r10),r9 # load subscript name ! 10759: subl2 $4,r10 # adjust ptr to merge (trval=1+1) ! 10760: #page ! 10761: # ! 10762: # CONVERT (CONTINUED) ! 10763: # ! 10764: # LOOP TO CHASE DOWN TRBLK CHAIN FOR VALUE ! 10765: # ! 10766: scv22: movl 4*trval(r10),r10# point to next value ! 10767: cmpl (r10),$b$trt # loop back if trapped ! 10768: beqlu scv22 ! 10769: # ! 10770: # HERE WITH NAME IN XR, VALUE IN XL ! 10771: # ! 10772: scv23: movl r10,-(sp) # stack value ! 10773: movl 4*1(sp),r10 # load tbblk pointer ! 10774: jsb tfind # build teblk (note wb gt 0 by name) ! 10775: .long exfal # fail if acess fails ! 10776: movl (sp)+,4*teval(r10) # store value in teblk ! 10777: jmp scv21 # loop back for next element ! 10778: # ! 10779: # HERE AFTER MOVING ALL ELEMENTS TO TBBLK ! 10780: # ! 10781: scv24: movl (sp)+,r9 # load tbblk pointer ! 10782: addl2 $4,sp # pop arblk pointer ! 10783: jmp exsid # exit setting idval ! 10784: # ! 10785: # CONVERT TO EXPRESSION ! 10786: # ! 10787: scv25: jsb gtexp # convert to expression ! 10788: .long exfal # fail if conversion not possible ! 10789: jmp exixr # else return expression ! 10790: # ! 10791: # CONVERT TO CODE ! 10792: # ! 10793: scv26: jsb gtcod # convert to code ! 10794: .long exfal # fail if conversion is not possible ! 10795: jmp exixr # else return code ! 10796: # ! 10797: # CONVERT TO NUMERIC ! 10798: # ! 10799: scv27: jsb gtnum # convert to numeric ! 10800: .long exfal # fail if unconvertible ! 10801: jmp exixr # return number ! 10802: #page ! 10803: # ! 10804: # CONVERT TO BUFFER ! 10805: # ! 10806: scv28: movl r9,-(sp) # stack string for procedure ! 10807: jsb gtstg # convert to string ! 10808: .long exfal # fail if conversion not possible ! 10809: movl r9,r10 # save string pointer ! 10810: jsb alobf # allocate buffer of same size ! 10811: jsb apndb # copy in the string ! 10812: .long invalid$ # already string - cant fail to cnv ! 10813: .long invalid$ # must be enough room ! 10814: jmp exsid # exit setting idval field ! 10815: #page ! 10816: # ! 10817: # COPY ! 10818: # ! 10819: s$cop: # entry point ! 10820: jsb copyb # copy the block ! 10821: .long exits # return if no idval field ! 10822: jmp exsid # exit setting id value ! 10823: #page ! 10824: # ! 10825: # DATA ! 10826: # ! 10827: s$dat: # entry point ! 10828: jsb xscni # prepare to scan argument ! 10829: .long er_075 # data argument is not string ! 10830: .long er_076 # data argument is null ! 10831: # ! 10832: # SCAN OUT DATATYPE NAME ! 10833: # ! 10834: movl $ch$pp,r8 # delimiter one = left paren ! 10835: movl r8,r10 # delimiter two = left paren ! 10836: jsb xscan # scan datatype name ! 10837: tstl r6 # skip if left paren found ! 10838: bnequ sdat1 ! 10839: jmp er_077 # data argument is missing a left paren ! 10840: # ! 10841: # HERE AFTER SCANNING DATATYPE NAME ! 10842: # ! 10843: sdat1: movl 4*sclen(r9),r6 # get length ! 10844: jsb flstg # fold lower case to upper case ! 10845: movl r9,r10 # save name ptr ! 10846: movl 4*sclen(r9),r6 # get length ! 10847: movab 3+(4*scsi$)(r6),r6 # compute space needed ! 10848: bicl2 $3,r6 ! 10849: jsb alost # request static store for name ! 10850: movl r9,-(sp) # save datatype name ! 10851: jsb sbmvw # copy name to static ! 10852: movl (sp),r9 # get name ptr ! 10853: clrl r10 # scrub dud register ! 10854: jsb gtnvr # locate vrblk for datatype name ! 10855: .long er_078 # data argument has null datatype name ! 10856: movl r9,datdv # save vrblk pointer for datatype ! 10857: movl sp,datxs # store starting stack value ! 10858: clrl r7 # zero count of field names ! 10859: # ! 10860: # LOOP TO SCAN FIELD NAMES AND STACK VRBLK POINTERS ! 10861: # ! 10862: sdat2: movl $ch$rp,r8 # delimiter one = right paren ! 10863: movl $ch$cm,r10 # delimiter two = comma ! 10864: jsb xscan # scan next field name ! 10865: tstl r6 # jump if delimiter found ! 10866: bnequ sdat3 ! 10867: jmp er_079 # data argument is missing a right paren ! 10868: # ! 10869: # HERE AFTER SCANNING OUT ONE FIELD NAME ! 10870: # ! 10871: sdat3: jsb gtnvr # locate vrblk for field name ! 10872: .long er_080 # data argument has null field name ! 10873: movl r9,-(sp) # stack vrblk pointer ! 10874: incl r7 # increment counter ! 10875: cmpl r6,$num02 # loop back if stopped by comma ! 10876: beqlu sdat2 ! 10877: #page ! 10878: # ! 10879: # DATA (CONTINUED) ! 10880: # ! 10881: # NOW BUILD THE DFBLK ! 10882: # ! 10883: movl $dfsi$,r6 # set size of dfblk standard fields ! 10884: addl2 r7,r6 # add number of fields ! 10885: moval 0[r6],r6 # convert length to bytes ! 10886: movl r7,r8 # preserve no. of fields ! 10887: jsb alost # allocate space for dfblk ! 10888: movl r8,r7 # get no of fields ! 10889: movl datxs,r10 # point to start of stack ! 10890: movl (r10),r8 # load datatype name ! 10891: movl r9,(r10) # save dfblk pointer on stack ! 10892: movl $b$dfc,(r9)+ # store type word ! 10893: movl r7,(r9)+ # store number of fields (fargs) ! 10894: movl r6,(r9)+ # store length (dflen) ! 10895: subl2 $4*pddfs,r6 # compute pdblk length (for dfpdl) ! 10896: movl r6,(r9)+ # store pdblk length (dfpdl) ! 10897: movl r8,(r9)+ # store datatype name (dfnam) ! 10898: movl r7,r8 # copy number of fields ! 10899: # ! 10900: # LOOP TO MOVE FIELD NAME VRBLK POINTERS TO DFBLK ! 10901: # ! 10902: sdat4: movl -(r10),(r9)+ # move one field name vrblk pointer ! 10903: sobgtr r8,sdat4 # loop till all moved ! 10904: # ! 10905: # NOW DEFINE THE DATATYPE FUNCTION ! 10906: # ! 10907: movl r6,r8 # copy length of pdblk for later loop ! 10908: movl datdv,r9 # point to vrblk ! 10909: movl datxs,r10 # point back on stack ! 10910: movl (r10),r10 # load dfblk pointer ! 10911: jsb dffnc # define function ! 10912: #page ! 10913: # ! 10914: # DATA (CONTINUED) ! 10915: # ! 10916: # LOOP TO BUILD FFBLKS ! 10917: # ! 10918: # ! 10919: # NOTICE THAT THE FFBLKS ARE CONSTRUCTED IN REVERSE ORDER ! 10920: # SO THAT THE REQUIRED OFFSETS CAN BE OBTAINED FROM ! 10921: # SUCCESSIVE DECREMENTATION OF THE PDBLK LENGTH (IN WC). ! 10922: # ! 10923: sdat5: movl $4*ffsi$,r6 # set length of ffblk ! 10924: jsb alloc # allocate space for ffblk ! 10925: movl $b$ffc,(r9) # set type word ! 10926: movl $num01,4*fargs(r9) # store fargs (always one) ! 10927: movl datxs,r10 # point back on stack ! 10928: movl (r10),4*ffdfp(r9)# copy dfblk ptr to ffblk ! 10929: subl2 $4,r8 # decrement old dfpdl to get next ofs ! 10930: movl r8,4*ffofs(r9) # set offset to this field ! 10931: clrl 4*ffnxt(r9) # tentatively set zero forward ptr ! 10932: movl r9,r10 # copy ffblk pointer for dffnc ! 10933: movl (sp),r9 # load vrblk pointer for field ! 10934: movl 4*vrfnc(r9),r9 # load current function pointer ! 10935: cmpl (r9),$b$ffc # skip if not currently a field func ! 10936: bnequ sdat6 ! 10937: # ! 10938: # HERE WE MUST CHAIN AN OLD FFBLK PTR TO PRESERVE IT IN THE ! 10939: # CASE OF MULTIPLE FIELD FUNCTIONS WITH THE SAME NAME ! 10940: # ! 10941: movl r9,4*ffnxt(r10) # link new ffblk to previous chain ! 10942: # ! 10943: # MERGE HERE TO DEFINE FIELD FUNCTION ! 10944: # ! 10945: sdat6: movl (sp)+,r9 # load vrblk pointer ! 10946: jsb dffnc # define field function ! 10947: cmpl sp,datxs # loop back till all done ! 10948: bnequ sdat5 ! 10949: addl2 $4,sp # pop dfblk pointer ! 10950: jmp exnul # return with null result ! 10951: #page ! 10952: # ! 10953: # DATATYPE ! 10954: # ! 10955: s$dtp: # entry point ! 10956: movl (sp)+,r9 # load argument ! 10957: jsb dtype # get datatype ! 10958: jmp exixr # and return it as result ! 10959: #page ! 10960: # ! 10961: # DATE ! 10962: # ! 10963: s$dte: # entry point ! 10964: jsb sysdt # call system date routine ! 10965: movl 4*1(r10),r6 # load length for sbstr ! 10966: tstl r6 # return null if length is zero ! 10967: bnequ 0f ! 10968: jmp exnul ! 10969: 0: ! 10970: clrl r7 # set zero offset ! 10971: jsb sbstr # use sbstr to build scblk ! 10972: jmp exixr # return date string ! 10973: #page ! 10974: # ! 10975: # DEFINE ! 10976: # ! 10977: s$def: # entry point ! 10978: movl (sp)+,r9 # load second argument ! 10979: clrl deflb # zero label pointer in case null ! 10980: cmpl r9,$nulls # jump if null second argument ! 10981: beqlu sdf01 ! 10982: jsb gtnvr # else find vrblk for label ! 10983: .long sdf13 # jump if not a variable name ! 10984: movl r9,deflb # else set specified entry ! 10985: # ! 10986: # SCAN FUNCTION NAME ! 10987: # ! 10988: sdf01: jsb xscni # prepare to scan first argument ! 10989: .long er_081 # define first argument is not string ! 10990: .long er_082 # define first argument is null ! 10991: movl $ch$pp,r8 # delimiter one = left paren ! 10992: movl r8,r10 # delimiter two = left paren ! 10993: jsb xscan # scan out function name ! 10994: tstl r6 # jump if left paren found ! 10995: bnequ sdf02 ! 10996: jmp er_083 # define first argument is missing a left paren ! 10997: # ! 10998: # HERE AFTER SCANNING OUT FUNCTION NAME ! 10999: # ! 11000: sdf02: jsb gtnvr # get variable name ! 11001: .long er_084 # define first argument has null function name ! 11002: movl r9,defvr # save vrblk pointer for function nam ! 11003: clrl r7 # zero count of arguments ! 11004: movl sp,defxs # save initial stack pointer ! 11005: tstl deflb # jump if second argument given ! 11006: bnequ sdf03 ! 11007: movl r9,deflb # else default is function name ! 11008: # ! 11009: # LOOP TO SCAN ARGUMENT NAMES AND STACK VRBLK POINTERS ! 11010: # ! 11011: sdf03: movl $ch$rp,r8 # delimiter one = right paren ! 11012: movl $ch$cm,r10 # delimiter two = comma ! 11013: jsb xscan # scan out next argument name ! 11014: tstl r6 # skip if delimiter found ! 11015: bnequ sdf04 ! 11016: jmp er_085 # null arg name or missing ) in define first arg. ! 11017: #page ! 11018: # ! 11019: # DEFINE (CONTINUED) ! 11020: # ! 11021: # HERE AFTER SCANNING AN ARGUMENT NAME ! 11022: # ! 11023: sdf04: cmpl r9,$nulls # skip if non-null ! 11024: bnequ sdf05 ! 11025: tstl r7 # ignore null if case of no arguments ! 11026: beqlu sdf06 ! 11027: # ! 11028: # HERE AFTER DEALING WITH THE CASE OF NO ARGUMENTS ! 11029: # ! 11030: sdf05: jsb gtnvr # get vrblk pointer ! 11031: .long sdf03 # loop back to ignore null name ! 11032: movl r9,-(sp) # stack argument vrblk pointer ! 11033: incl r7 # increment counter ! 11034: cmpl r6,$num02 # loop back if stopped by a comma ! 11035: beqlu sdf03 ! 11036: # ! 11037: # HERE AFTER SCANNING OUT FUNCTION ARGUMENT NAMES ! 11038: # ! 11039: sdf06: movl r7,defna # save number of arguments ! 11040: clrl r7 # zero count of locals ! 11041: # ! 11042: # LOOP TO SCAN LOCAL NAMES AND STACK VRBLK POINTERS ! 11043: # ! 11044: sdf07: movl $ch$cm,r8 # set delimiter one = comma ! 11045: movl r8,r10 # set delimiter two = comma ! 11046: jsb xscan # scan out next local name ! 11047: cmpl r9,$nulls # skip if non-null ! 11048: bnequ sdf08 ! 11049: tstl r7 # ignore null if case of no locals ! 11050: beqlu sdf09 ! 11051: # ! 11052: # HERE AFTER SCANNING OUT A LOCAL NAME ! 11053: # ! 11054: sdf08: jsb gtnvr # get vrblk pointer ! 11055: .long sdf07 # loop back to ignore null name ! 11056: incl r7 # if ok, increment count ! 11057: movl r9,-(sp) # stack vrblk pointer ! 11058: tstl r6 # loop back if stopped by a comma ! 11059: bnequ sdf07 ! 11060: #page ! 11061: # ! 11062: # DEFINE (CONTINUED) ! 11063: # ! 11064: # HERE AFTER SCANNING LOCALS, BUILD PFBLK ! 11065: # ! 11066: sdf09: movl r7,r6 # copy count of locals ! 11067: addl2 defna,r6 # add number of arguments ! 11068: movl r6,r8 # set sum args+locals as loop count ! 11069: addl2 $pfsi$,r6 # add space for standard fields ! 11070: moval 0[r6],r6 # convert length to bytes ! 11071: jsb alloc # allocate space for pfblk ! 11072: movl r9,r10 # save pointer to pfblk ! 11073: movl $b$pfc,(r9)+ # store first word ! 11074: movl defna,(r9)+ # store number of arguments ! 11075: movl r6,(r9)+ # store length (pflen) ! 11076: movl defvr,(r9)+ # store vrblk ptr for function name ! 11077: movl r7,(r9)+ # store number of locals ! 11078: clrl (r9)+ # deal with label later ! 11079: clrl (r9)+ # zero pfctr ! 11080: clrl (r9)+ # zero pfrtr ! 11081: tstl r8 # skip if no args or locals ! 11082: beqlu sdf11 ! 11083: movl r10,r6 # keep pfblk pointer ! 11084: movl defxs,r10 # point before arguments ! 11085: # get count of args+locals for loop ! 11086: # ! 11087: # LOOP TO MOVE LOCALS AND ARGS TO PFBLK ! 11088: # ! 11089: sdf10: movl -(r10),(r9)+ # store one entry and bump pointers ! 11090: sobgtr r8,sdf10 # loop till all stored ! 11091: movl r6,r10 # recover pfblk pointer ! 11092: #page ! 11093: # ! 11094: # DEFINE (CONTINUED) ! 11095: # ! 11096: # NOW DEAL WITH LABEL ! 11097: # ! 11098: sdf11: movl defxs,sp # pop stack ! 11099: movl deflb,r9 # point to vrblk for label ! 11100: movl 4*vrlbl(r9),r9 # load label pointer ! 11101: cmpl (r9),$b$trt # skip if not trapped ! 11102: bnequ sdf12 ! 11103: movl 4*trlbl(r9),r9 # else point to real label ! 11104: # ! 11105: # HERE AFTER LOCATING REAL LABEL POINTER ! 11106: # ! 11107: sdf12: cmpl r9,$stndl # jump if label is not defined ! 11108: beqlu sdf13 ! 11109: movl r9,4*pfcod(r10) # else store label pointer ! 11110: movl defvr,r9 # point back to vrblk for function ! 11111: jsb dffnc # define function ! 11112: jmp exnul # and exit returning null ! 11113: # ! 11114: # HERE FOR ERRONEOUS LABEL ! 11115: # ! 11116: sdf13: jmp er_086 # define function entry point is not defined label ! 11117: #page ! 11118: # ! 11119: # DETACH ! 11120: # ! 11121: s$det: # entry point ! 11122: movl (sp)+,r9 # load argument ! 11123: jsb gtvar # locate variable ! 11124: .long er_087 # detach argument is not appropriate name ! 11125: jsb dtach # detach i/o association from name ! 11126: jmp exnul # return null result ! 11127: #page ! 11128: # ! 11129: # DIFFER ! 11130: # ! 11131: s$dif: # entry point ! 11132: movl (sp)+,r9 # load second argument ! 11133: movl (sp)+,r10 # load first argument ! 11134: jsb ident # call ident comparison routine ! 11135: .long exfal # fail if ident ! 11136: jmp exnul # return null if differ ! 11137: #page ! 11138: # ! 11139: # DUMP ! 11140: # ! 11141: s$dmp: # entry point ! 11142: jsb gtsmi # load dump arg as small integer ! 11143: .long er_088 # dump argument is not integer ! 11144: .long er_089 # dump argument is negative or too large ! 11145: jsb dumpr # else call dump routine ! 11146: jmp exnul # and return null as result ! 11147: #page ! 11148: # ! 11149: # DUPL ! 11150: # ! 11151: s$dup: # entry point ! 11152: jsb gtsmi # get second argument as small intege ! 11153: .long er_090 # dupl second argument is not integer ! 11154: .long sdup7 # jump if negative ot too big ! 11155: movl r9,r7 # save duplication factor ! 11156: jsb gtstg # get first arg as string ! 11157: .long sdup4 # jump if not a string ! 11158: # ! 11159: # HERE FOR CASE OF DUPLICATION OF A STRING ! 11160: # ! 11161: movl r6,r5 # acquire length as integer ! 11162: movl r5,dupsi # save for the moment ! 11163: movl r7,r5 # get duplication factor as integer ! 11164: mull2 dupsi,r5 # form product ! 11165: bvs sdup3 ! 11166: tstl r5 # return null if result length = 0 ! 11167: bneq 0f ! 11168: jmp exnul ! 11169: 0: ! 11170: movl r5,r6 # get as addr integer, check ovflo ! 11171: bgeq 0f ! 11172: jmp sdup3 ! 11173: 0: ! 11174: # ! 11175: # MERGE HERE WITH RESULT LENGTH IN WA ! 11176: # ! 11177: sdup1: movl r9,r10 # save string pointer ! 11178: jsb alocs # allocate space for string ! 11179: movl r9,-(sp) # save as result pointer ! 11180: movl r10,r8 # save pointer to argument string ! 11181: movab cfp$f(r9),r9 # prepare to store chars of result ! 11182: # set counter to control loop ! 11183: # ! 11184: # LOOP THROUGH DUPLICATIONS ! 11185: # ! 11186: sdup2: movl r8,r10 # point back to argument string ! 11187: movl 4*sclen(r10),r6 # get number of characters ! 11188: movab cfp$f(r10),r10 # point to chars in argument string ! 11189: jsb sbmvc # move characters to result string ! 11190: sobgtr r7,sdup2 # loop till all duplications done ! 11191: jmp exits # then exit for next code word ! 11192: #page ! 11193: # ! 11194: # DUPL (CONTINUED) ! 11195: # ! 11196: # HERE IF TOO LARGE, SET MAX LENGTH AND LET ALOCS CATCH IT ! 11197: # ! 11198: sdup3: movl dname,r6 # set impossible length for alocs ! 11199: jmp sdup1 # merge back ! 11200: # ! 11201: # HERE IF NOT A STRING ! 11202: # ! 11203: sdup4: jsb gtpat # convert argument to pattern ! 11204: .long er_091 # dupl first argument is not string or pattern ! 11205: # ! 11206: # HERE TO DUPLICATE A PATTERN ARGUMENT ! 11207: # ! 11208: movl r9,-(sp) # store pattern on stack ! 11209: movl $ndnth,r9 # start off with null pattern ! 11210: tstl r7 # null pattern is result if dupfac=0 ! 11211: beqlu sdup6 ! 11212: movl r7,-(sp) # preserve loop count ! 11213: # ! 11214: # LOOP TO DUPLICATE BY SUCCESSIVE CONCATENATION ! 11215: # ! 11216: sdup5: movl r9,r10 # copy current value as right argumnt ! 11217: movl 4*1(sp),r9 # get a new copy of left ! 11218: jsb pconc # concatenate ! 11219: decl (sp) # count down ! 11220: tstl (sp) # loop ! 11221: bnequ sdup5 ! 11222: addl2 $4,sp # pop loop count ! 11223: # ! 11224: # HERE TO EXIT AFTER CONSTRUCTING PATTERN ! 11225: # ! 11226: sdup6: movl r9,(sp) # store result on stack ! 11227: jmp exits # exit with result on stack ! 11228: # ! 11229: # FAIL IF SECOND ARG IS OUT OF RANGE ! 11230: # ! 11231: sdup7: addl2 $4,sp # pop first argument ! 11232: jmp exfal # fail ! 11233: #page ! 11234: # ! 11235: # EJECT ! 11236: # ! 11237: s$ejc: # entry point ! 11238: jsb iofcb # call fcblk routine ! 11239: .long er_092 # eject argument is not a suitable name ! 11240: .long sejc1 # null argument ! 11241: jsb sysef # call eject file function ! 11242: .long er_093 # eject file does not exist ! 11243: .long er_094 # eject file does not permit page eject ! 11244: .long er_095 # eject caused non-recoverable output error ! 11245: jmp exnul # return null as result ! 11246: # ! 11247: # HERE TO EJECT STANDARD OUTPUT FILE ! 11248: # ! 11249: sejc1: jsb sysep # call routine to eject printer ! 11250: jmp exnul # exit with null result ! 11251: #page ! 11252: # ! 11253: # ENDFILE ! 11254: # ! 11255: s$enf: # entry point ! 11256: jsb iofcb # call fcblk routine ! 11257: .long er_096 # endfile argument is not a suitable name ! 11258: .long er_097 # endfile argument is null ! 11259: jsb sysen # call endfile routine ! 11260: .long er_098 # endfile file does not exist ! 11261: .long er_099 # endfile file does not permit endfile ! 11262: .long er_100 # endfile caused non-recoverable output error ! 11263: movl r10,r7 # remember vrblk ptr from iofcb call ! 11264: # ! 11265: # LOOP TO FIND TRTRF BLOCK ! 11266: # ! 11267: senf1: movl r10,r9 # copy pointer ! 11268: movl 4*trval(r9),r9 # chain along ! 11269: cmpl (r9),$b$trt # skip out if chain end ! 11270: beqlu 0f ! 11271: jmp exnul ! 11272: 0: ! 11273: cmpl 4*trtyp(r9),$trtfc # loop if not found ! 11274: bnequ senf1 ! 11275: movl 4*trval(r9),4*trval(r10) # remove trtrf ! 11276: movl 4*trtrf(r9),enfch# point to head of iochn ! 11277: movl 4*trfpt(r9),r8 # point to fcblk ! 11278: movl r7,r9 # filearg1 vrblk from iofcb ! 11279: jsb setvr # reset it ! 11280: movl $r$fcb,r10 # ptr to head of fcblk chain ! 11281: subl2 $4*num02,r10 # adjust ready to enter loop ! 11282: # ! 11283: # FIND FCBLK ! 11284: # ! 11285: senf2: movl r10,r9 # copy ptr ! 11286: movl 4*2(r10),r10 # get next link ! 11287: tstl r10 # stop if chain end ! 11288: beqlu senf4 ! 11289: cmpl 4*3(r10),r8 # jump if fcblk found ! 11290: beqlu senf3 ! 11291: jmp senf2 # loop ! 11292: # ! 11293: # REMOVE FCBLK ! 11294: # ! 11295: senf3: movl 4*2(r10),4*2(r9)# delete fcblk from chain ! 11296: # ! 11297: # LOOP WHICH DETACHES ALL VBLS ON IOCHN CHAIN ! 11298: # ! 11299: senf4: movl enfch,r10 # get chain head ! 11300: tstl r10 # finished if chain end ! 11301: bnequ 0f ! 11302: jmp exnul ! 11303: 0: ! 11304: movl 4*trtrf(r10),enfch # chain along ! 11305: movl 4*ionmo(r10),r6 # name offset ! 11306: movl 4*ionmb(r10),r10# name base ! 11307: jsb dtach # detach name ! 11308: jmp senf4 # loop till done ! 11309: #page ! 11310: # ! 11311: # EQ ! 11312: # ! 11313: s$eqf: # entry point ! 11314: jsb acomp # call arithmetic comparison routine ! 11315: .long er_101 # eq first argument is not numeric ! 11316: .long er_102 # eq second argument is not numeric ! 11317: .long exfal # fail if lt ! 11318: .long exnul # return null if eq ! 11319: .long exfal # fail if gt ! 11320: #page ! 11321: # ! 11322: # EVAL ! 11323: # ! 11324: s$evl: # entry point ! 11325: movl (sp)+,r9 # load argument ! 11326: jsb gtexp # convert to expression ! 11327: .long er_103 # eval argument is not expression ! 11328: movl (r3)+,r8 # load next code word ! 11329: cmpl r8,$ofne$ # jump if called by value ! 11330: bnequ sevl1 ! 11331: movl r3,r10 # copy code pointer ! 11332: movl (r10),r6 # get next code word ! 11333: cmpl r6,$ornm$ # by name unless expression ! 11334: bnequ sevl2 ! 11335: tstl 4*1(sp) # jump if by name ! 11336: bnequ sevl2 ! 11337: # ! 11338: # HERE IF CALLED BY VALUE ! 11339: # ! 11340: sevl1: clrl r7 # set flag for by value ! 11341: movl r8,-(sp) # save code word ! 11342: jsb evalx # evaluate expression by value ! 11343: .long exfal # fail if evaluation fails ! 11344: movl r9,r10 # copy result ! 11345: movl (sp),r9 # reload next code word ! 11346: movl r10,(sp) # stack result ! 11347: movl (r9),r11 # jump to execute next code word ! 11348: jmp (r11) ! 11349: # ! 11350: # HERE IF CALLED BY NAME ! 11351: # ! 11352: sevl2: movl $num01,r7 # set flag for by name ! 11353: jsb evalx # evaluate expression by name ! 11354: .long exfal # fail if evaluation fails ! 11355: jmp exnam # exit with name ! 11356: #page ! 11357: # ! 11358: # EXIT ! 11359: # ! 11360: s$ext: # entry point ! 11361: clrl r7 # clear amount of static shift ! 11362: jsb gbcol # compact memory by collecting ! 11363: jsb gtstg # convert arg to string ! 11364: .long er_104 # exit argument is not suitable integer or string ! 11365: movl r9,r10 # copy string ptr ! 11366: jsb gtint # check it is integer ! 11367: .long sext1 # skip if unconvertible ! 11368: clrl r10 # note it is integer ! 11369: movl 4*icval(r9),r5 # get integer arg ! 11370: movl r$fcb,r7 # get fcblk chain header ! 11371: # ! 11372: # MERGE TO CALL OSINT EXIT ROUTINE ! 11373: # ! 11374: sext1: movl $headv,r9 # point to v.v string ! 11375: jsb sysxi # call external routine ! 11376: .long er_105 # exit action not available in this implementation ! 11377: .long er_106 # exit action caused irrecoverable error ! 11378: tstl r5 # return if argument 0 ! 11379: bneq 0f ! 11380: jmp exnul ! 11381: 0: ! 11382: clrl gbcnt # resuming execution so reset ! 11383: tstl r5 # skip if positive ! 11384: bgtr sext2 ! 11385: mnegl r5,r5 # make positive ! 11386: # ! 11387: # CHECK FOR OPTION RESPECIFICATION ! 11388: # ! 11389: sext2: movl r5,r8 # get value in work reg ! 11390: cmpl r8,$num03 # skip if was 3 ! 11391: beqlu sext3 ! 11392: movl r8,-(sp) # save value ! 11393: clrl r8 # set to read options ! 11394: jsb prpar # read syspp options ! 11395: movl (sp)+,r8 # restore value ! 11396: # ! 11397: # DEAL WITH HEADER OPTION (FIDDLED BY PRPAR) ! 11398: # ! 11399: sext3: movl sp,headp # assume no headers ! 11400: cmpl r8,$num01 # skip if not 1 ! 11401: bnequ sext4 ! 11402: clrl headp # request header printing ! 11403: # ! 11404: # ALMOST READY TO RESUME RUNNING ! 11405: # ! 11406: sext4: jsb systm # get execution time start (sgd11) ! 11407: movl r5,timsx # save as initial time ! 11408: movl kvstc,r5 # reset to ensure ... ! 11409: movl r5,kvstl # ... correct execution stats ! 11410: jmp exnul # resume execution ! 11411: #page ! 11412: # ! 11413: # FIELD ! 11414: # ! 11415: s$fld: # entry point ! 11416: jsb gtsmi # get second argument (field number) ! 11417: .long er_107 # field second argument is not integer ! 11418: .long exfal # fail if out of range ! 11419: movl r9,r7 # else save integer value ! 11420: movl (sp)+,r9 # load first argument ! 11421: jsb gtnvr # point to vrblk ! 11422: .long sfld1 # jump (error) if not variable name ! 11423: movl 4*vrfnc(r9),r9 # else point to function block ! 11424: cmpl (r9),$b$dfc # error if not datatype function ! 11425: bnequ sfld1 ! 11426: # ! 11427: # HERE IF FIRST ARGUMENT IS A DATATYPE FUNCTION NAME ! 11428: # ! 11429: tstl r7 # fail if argument number is zero ! 11430: bnequ 0f ! 11431: jmp exfal ! 11432: 0: ! 11433: cmpl r7,4*fargs(r9) # fail if too large ! 11434: blequ 0f ! 11435: jmp exfal ! 11436: 0: ! 11437: moval 0[r7],r7 # else convert to byte offset ! 11438: addl2 r7,r9 # point to field name ! 11439: movl 4*dfflb(r9),r9 # load vrblk pointer ! 11440: jmp exvnm # exit to build nmblk ! 11441: # ! 11442: # HERE FOR BAD FIRST ARGUMENT ! 11443: # ! 11444: sfld1: jmp er_108 # field first argument is not datatype name ! 11445: #page ! 11446: # ! 11447: # FENCE ! 11448: # ! 11449: s$fnc: # entry point ! 11450: movl $p$fnc,r7 # set pcode for p$fnc ! 11451: clrl r9 # p0blk ! 11452: jsb pbild # build p$fnc node ! 11453: movl r9,r10 # save pointer to it ! 11454: movl (sp)+,r9 # get argument ! 11455: jsb gtpat # convert to pattern ! 11456: .long er_259 # fence argument is not pattern ! 11457: jsb pconc # concatenate to p$fnc node ! 11458: movl r9,r10 # save ptr to concatenated pattern ! 11459: movl $p$fna,r7 # set for p$fna pcode ! 11460: clrl r9 # p0blk ! 11461: jsb pbild # construct p$fna node ! 11462: movl r10,4*pthen(r9) # set pattern as pthen ! 11463: movl r9,-(sp) # set as result ! 11464: jmp exits # do next code word ! 11465: #page ! 11466: # ! 11467: # GE ! 11468: # ! 11469: s$gef: # entry point ! 11470: jsb acomp # call arithmetic comparison routine ! 11471: .long er_109 # ge first argument is not numeric ! 11472: .long er_110 # ge second argument is not numeric ! 11473: .long exfal # fail if lt ! 11474: .long exnul # return null if eq ! 11475: .long exnul # return null if gt ! 11476: #page ! 11477: # ! 11478: # GT ! 11479: # ! 11480: s$gtf: # entry point ! 11481: jsb acomp # call arithmetic comparison routine ! 11482: .long er_111 # gt first argument is not numeric ! 11483: .long er_112 # gt second argument is not numeric ! 11484: .long exfal # fail if lt ! 11485: .long exfal # fail if eq ! 11486: .long exnul # return null if gt ! 11487: #page ! 11488: # ! 11489: # HOST ! 11490: # ! 11491: s$hst: # entry point ! 11492: movl (sp)+,r9 # get third arg ! 11493: movl (sp)+,r10 # get second arg ! 11494: movl (sp)+,r6 # get first arg ! 11495: jsb syshs # enter syshs routine ! 11496: .long er_254 # erroneous argument for host ! 11497: .long er_255 # error during execution of host ! 11498: .long shst1 # store host string ! 11499: .long exnul # return null result ! 11500: .long exixr # return xr ! 11501: .long exfal # fail return ! 11502: # ! 11503: # RETURN HOST STRING ! 11504: # ! 11505: shst1: tstl r10 # null string if syshs uncooperative ! 11506: bnequ 0f ! 11507: jmp exnul ! 11508: 0: ! 11509: movl 4*sclen(r10),r6 # length ! 11510: clrl r7 # zero offset ! 11511: jsb sbstr # build copy of string ! 11512: movl r9,-(sp) # stack the result ! 11513: jmp exits # return result on stack ! 11514: #page ! 11515: # ! 11516: # IDENT ! 11517: # ! 11518: s$idn: # entry point ! 11519: movl (sp)+,r9 # load second argument ! 11520: movl (sp)+,r10 # load first argument ! 11521: jsb ident # call ident comparison routine ! 11522: .long exnul # return null if ident ! 11523: jmp exfal # fail if differ ! 11524: #page ! 11525: # ! 11526: # INPUT ! 11527: # ! 11528: s$inp: # entry point ! 11529: clrl r7 # input flag ! 11530: jsb ioput # call input/output assoc. routine ! 11531: .long er_113 # input third argument is not a string ! 11532: .long er_114 # inappropriate second argument for input ! 11533: .long er_115 # inappropriate first argument for input ! 11534: .long er_116 # inappropriate file specification for input ! 11535: .long exfal # fail if file does not exist ! 11536: .long er_117 # input file cannot be read ! 11537: jmp exnul # return null string ! 11538: #page ! 11539: # ! 11540: # INSERT ! 11541: # ! 11542: s$ins: # entry point ! 11543: movl (sp)+,r10 # get string arg ! 11544: jsb gtsmi # get replace length ! 11545: .long er_277 # insert third argument not integer ! 11546: .long exfal # fail if out of range ! 11547: movl r8,r7 # copy to proper reg ! 11548: jsb gtsmi # get replace position ! 11549: .long er_278 # insert second argument not integer ! 11550: .long exfal # fail if out of range ! 11551: tstl r8 # fail if zero ! 11552: bnequ 0f ! 11553: jmp exfal ! 11554: 0: ! 11555: decl r8 # decrement to get offset ! 11556: movl r8,r6 # put in proper register ! 11557: movl (sp)+,r9 # get buffer ! 11558: cmpl (r9),$b$bct # press on if type ok ! 11559: beqlu sins1 ! 11560: jmp er_279 # insert first argument not buffer ! 11561: # ! 11562: # HERE WHEN EVERYTHING LOADED UP ! 11563: # ! 11564: sins1: jsb insbf # call to insert ! 11565: .long er_280 # insert fourth argument not a string ! 11566: .long exfal # fail if out of range ! 11567: jmp exnul # else ok - exit with null ! 11568: #page ! 11569: # ! 11570: # INTEGER ! 11571: # ! 11572: s$int: # entry point ! 11573: movl (sp)+,r9 # load argument ! 11574: jsb gtnum # convert to numeric ! 11575: .long exfal # fail if non-numeric ! 11576: cmpl r6,$b$icl # return null if integer ! 11577: bnequ 0f ! 11578: jmp exnul ! 11579: 0: ! 11580: jmp exfal # fail if real ! 11581: #page ! 11582: # ! 11583: # ITEM ! 11584: # ! 11585: # ITEM DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT ! 11586: # WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED. ! 11587: # ! 11588: s$itm: # entry point ! 11589: # ! 11590: # DEAL WITH CASE OF NO ARGS ! 11591: # ! 11592: tstl r6 # jump if at least one arg ! 11593: bnequ sitm1 ! 11594: movl $nulls,-(sp) # else supply garbage null arg ! 11595: movl $num01,r6 # and fix argument count ! 11596: # ! 11597: # CHECK FOR NAME/VALUE CASES ! 11598: # ! 11599: sitm1: movl r3,r9 # get current code pointer ! 11600: movl (r9),r10 # load next code word ! 11601: decl r6 # get number of subscripts ! 11602: movl r6,r9 # copy for arref ! 11603: cmpl r10,$ofne$ # jump if called by name ! 11604: beqlu sitm2 ! 11605: # ! 11606: # HERE IF CALLED BY VALUE ! 11607: # ! 11608: clrl r7 # set code for call by value ! 11609: jmp arref # off to array reference routine ! 11610: # ! 11611: # HERE FOR CALL BY NAME ! 11612: # ! 11613: sitm2: movl sp,r7 # set code for call by name ! 11614: movl (r3)+,r6 # load and ignore ofne$ call ! 11615: jmp arref # off to array reference routine ! 11616: #page ! 11617: # ! 11618: # LE ! 11619: # ! 11620: s$lef: # entry point ! 11621: jsb acomp # call arithmetic comparison routine ! 11622: .long er_118 # le first argument is not numeric ! 11623: .long er_119 # le second argument is not numeric ! 11624: .long exnul # return null if lt ! 11625: .long exnul # return null if eq ! 11626: .long exfal # fail if gt ! 11627: #page ! 11628: # ! 11629: # LEN ! 11630: # ! 11631: s$len: # entry point ! 11632: movl $p$len,r7 # set pcode for integer arg case ! 11633: movl $p$lnd,r6 # set pcode for expr arg case ! 11634: jsb patin # call common routine to build node ! 11635: .long er_120 # len argument is not integer or expression ! 11636: .long er_121 # len argument is negative or too large ! 11637: jmp exixr # return pattern node ! 11638: #page ! 11639: # ! 11640: # LEQ ! 11641: # ! 11642: s$leq: # entry point ! 11643: jsb lcomp # call string comparison routine ! 11644: .long er_122 # leq first argument is not string ! 11645: .long er_123 # leq second argument is not string ! 11646: .long exfal # fail if llt ! 11647: .long exnul # return null if leq ! 11648: .long exfal # fail if lgt ! 11649: #page ! 11650: # ! 11651: # LGE ! 11652: # ! 11653: s$lge: # entry point ! 11654: jsb lcomp # call string comparison routine ! 11655: .long er_124 # lge first argument is not string ! 11656: .long er_125 # lge second argument is not string ! 11657: .long exfal # fail if llt ! 11658: .long exnul # return null if leq ! 11659: .long exnul # return null if lgt ! 11660: #page ! 11661: # ! 11662: # LGT ! 11663: # ! 11664: s$lgt: # entry point ! 11665: jsb lcomp # call string comparison routine ! 11666: .long er_126 # lgt first argument is not string ! 11667: .long er_127 # lgt second argument is not string ! 11668: .long exfal # fail if llt ! 11669: .long exfal # fail if leq ! 11670: .long exnul # return null if lgt ! 11671: #page ! 11672: # ! 11673: # LLE ! 11674: # ! 11675: s$lle: # entry point ! 11676: jsb lcomp # call string comparison routine ! 11677: .long er_128 # lle first argument is not string ! 11678: .long er_129 # lle second argument is not string ! 11679: .long exnul # return null if llt ! 11680: .long exnul # return null if leq ! 11681: .long exfal # fail if lgt ! 11682: #page ! 11683: # ! 11684: # LLT ! 11685: # ! 11686: s$llt: # entry point ! 11687: jsb lcomp # call string comparison routine ! 11688: .long er_130 # llt first argument is not string ! 11689: .long er_131 # llt second argument is not string ! 11690: .long exnul # return null if llt ! 11691: .long exfal # fail if leq ! 11692: .long exfal # fail if lgt ! 11693: #page ! 11694: # ! 11695: # LNE ! 11696: # ! 11697: s$lne: # entry point ! 11698: jsb lcomp # call string comparison routine ! 11699: .long er_132 # lne first argument is not string ! 11700: .long er_133 # lne second argument is not string ! 11701: .long exnul # return null if llt ! 11702: .long exfal # fail if leq ! 11703: .long exnul # return null if lgt ! 11704: #page ! 11705: # ! 11706: # LOCAL ! 11707: # ! 11708: s$loc: # entry point ! 11709: jsb gtsmi # get second argument (local number) ! 11710: .long er_134 # local second argument is not integer ! 11711: .long exfal # fail if out of range ! 11712: movl r9,r7 # save local number ! 11713: movl (sp)+,r9 # load first argument ! 11714: jsb gtnvr # point to vrblk ! 11715: .long sloc1 # jump if not variable name ! 11716: movl 4*vrfnc(r9),r9 # else load function pointer ! 11717: cmpl (r9),$b$pfc # jump if not program defined ! 11718: bnequ sloc1 ! 11719: # ! 11720: # HERE IF WE HAVE A PROGRAM DEFINED FUNCTION NAME ! 11721: # ! 11722: tstl r7 # fail if second arg is zero ! 11723: bnequ 0f ! 11724: jmp exfal ! 11725: 0: ! 11726: cmpl r7,4*pfnlo(r9) # or too large ! 11727: blequ 0f ! 11728: jmp exfal ! 11729: 0: ! 11730: addl2 4*fargs(r9),r7 # else adjust offset to include args ! 11731: moval 0[r7],r7 # convert to bytes ! 11732: addl2 r7,r9 # point to local pointer ! 11733: movl 4*pfagb(r9),r9 # load vrblk pointer ! 11734: jmp exvnm # exit building nmblk ! 11735: # ! 11736: # HERE IF FIRST ARGUMENT IS NO GOOD ! 11737: # ! 11738: sloc1: jmp er_135 # local first arg is not a program function name ! 11739: #page ! 11740: # ! 11741: # LOAD ! 11742: # ! 11743: s$lod: # entry point ! 11744: jsb gtstg # load library name ! 11745: .long er_136 # load second argument is not string ! 11746: movl r9,r10 # save library name ! 11747: jsb xscni # prepare to scan first argument ! 11748: .long er_137 # load first argument is not string ! 11749: .long er_138 # load first argument is null ! 11750: movl r10,-(sp) # stack library name ! 11751: movl $ch$pp,r8 # set delimiter one = left paren ! 11752: movl r8,r10 # set delimiter two = left paren ! 11753: jsb xscan # scan function name ! 11754: movl r9,-(sp) # save ptr to function name ! 11755: tstl r6 # jump if left paren found ! 11756: bnequ slod1 ! 11757: jmp er_139 # load first argument is missing a left paren ! 11758: # ! 11759: # HERE AFTER SUCCESSFULLY SCANNING FUNCTION NAME ! 11760: # ! 11761: slod1: jsb gtnvr # locate vrblk ! 11762: .long er_140 # load first argument has null function name ! 11763: movl r9,lodfn # save vrblk pointer ! 11764: clrl lodna # zero count of arguments ! 11765: # ! 11766: # LOOP TO SCAN ARGUMENT DATATYPE NAMES ! 11767: # ! 11768: slod2: movl $ch$rp,r8 # delimiter one is right paren ! 11769: movl $ch$cm,r10 # delimiter two is comma ! 11770: jsb xscan # scan next argument name ! 11771: incl lodna # bump argument count ! 11772: tstl r6 # jump if ok delimiter was found ! 11773: bnequ slod3 ! 11774: jmp er_141 # load first argument is missing a right paren ! 11775: #page ! 11776: # ! 11777: # LOAD (CONTINUED) ! 11778: # ! 11779: # COME HERE TO ANALYZE THE DATATYPE POINTER IN (XR). THIS ! 11780: # CODE IS USED BOTH FOR ARGUMENTS (WA=1,2) AND FOR THE ! 11781: # RESULT DATATYPE (WITH WA SET TO ZERO). ! 11782: # ! 11783: slod3: movl r9,-(sp) # stack datatype name pointer ! 11784: movl $num01,r7 # set string code in case ! 11785: movl $scstr,r10 # point to /string/ ! 11786: jsb ident # check for match ! 11787: .long slod4 # jump if match ! 11788: movl (sp),r9 # else reload name ! 11789: addl2 r7,r7 # set code for integer (2) ! 11790: movl $scint,r10 # point to /integer/ ! 11791: jsb ident # check for match ! 11792: .long slod4 # jump if match ! 11793: movl (sp),r9 # else reload string pointer ! 11794: incl r7 # set code for real (3) ! 11795: movl $screa,r10 # point to /real/ ! 11796: jsb ident # check for match ! 11797: .long slod4 # jump if match ! 11798: clrl r7 # else get code for no convert ! 11799: # ! 11800: # MERGE HERE WITH PROPER DATATYPE CODE IN WB ! 11801: # ! 11802: slod4: movl r7,(sp) # store code on stack ! 11803: cmpl r6,$num02 # loop back if arg stopped by comma ! 11804: beqlu slod2 ! 11805: tstl r6 # jump if that was the result type ! 11806: beqlu slod5 ! 11807: # ! 11808: # HERE WE SCAN OUT THE RESULT TYPE (ARG STOPPED BY ) ) ! 11809: # ! 11810: movl mxlen,r8 # set dummy (impossible) delimiter 1 ! 11811: movl r8,r10 # and delimiter two ! 11812: jsb xscan # scan result name ! 11813: clrl r6 # set code for processing result ! 11814: jmp slod3 # jump back to process result name ! 11815: #page ! 11816: # ! 11817: # LOAD (CONTINUED) ! 11818: # ! 11819: # HERE AFTER PROCESSING ALL ARGS AND RESULT ! 11820: # ! 11821: slod5: movl lodna,r6 # get number of arguments ! 11822: movl r6,r8 # copy for later ! 11823: moval 0[r6],r6 # convert length to bytes ! 11824: addl2 $4*efsi$,r6 # add space for standard fields ! 11825: jsb alloc # allocate efblk ! 11826: movl $b$efc,(r9) # set type word ! 11827: movl r8,4*fargs(r9) # set number of arguments ! 11828: clrl 4*efuse(r9) # set use count (dffnc will set to 1) ! 11829: clrl 4*efcod(r9) # zero code pointer for now ! 11830: movl (sp)+,4*efrsl(r9)# store result type code ! 11831: movl lodfn,4*efvar(r9)# store function vrblk pointer ! 11832: movl r6,4*eflen(r9) # store efblk length ! 11833: movl r9,r7 # save efblk pointer ! 11834: addl2 r6,r9 # point past end of efblk ! 11835: # set number of arguments for loop ! 11836: # ! 11837: # LOOP TO SET ARGUMENT TYPE CODES FROM STACK ! 11838: # ! 11839: slod6: movl (sp)+,-(r9) # store one type code from stack ! 11840: sobgtr r8,slod6 # loop till all stored ! 11841: # ! 11842: # NOW LOAD THE EXTERNAL FUNCTION AND PERFORM DEFINITION ! 11843: # ! 11844: movl (sp)+,r9 # load function string name ! 11845: movl (sp),r10 # load library name ! 11846: movl r7,(sp) # store efblk pointer ! 11847: jsb sysld # call function to load external func ! 11848: .long er_142 # load function does not exist ! 11849: .long er_143 # load function caused input error during load ! 11850: movl (sp)+,r10 # recall efblk pointer ! 11851: movl r9,4*efcod(r10) # store code pointer ! 11852: movl lodfn,r9 # point to vrblk for function ! 11853: jsb dffnc # perform function definition ! 11854: jmp exnul # return null result ! 11855: #page ! 11856: # ! 11857: # LPAD ! 11858: # ! 11859: s$lpd: # entry point ! 11860: jsb gtstg # get pad character ! 11861: .long er_144 # lpad third argument not a string ! 11862: movab cfp$f(r9),r9 # point to character (null is blank) ! 11863: movzbl (r9),r7 # load pad character ! 11864: jsb gtsmi # get pad length ! 11865: .long er_145 # lpad second argument is not integer ! 11866: .long slpd3 # skip if negative or large ! 11867: # ! 11868: # MERGE TO CHECK FIRST ARG ! 11869: # ! 11870: slpd1: jsb gtstg # get first argument (string to pad) ! 11871: .long er_146 # lpad first argument is not string ! 11872: cmpl r6,r8 # return 1st arg if too long to pad ! 11873: blssu 0f ! 11874: jmp exixr ! 11875: 0: ! 11876: movl r9,r10 # else move ptr to string to pad ! 11877: # ! 11878: # NOW WE ARE READY FOR THE PAD ! 11879: # ! 11880: # (XL) POINTER TO STRING TO PAD ! 11881: # (WB) PAD CHARACTER ! 11882: # (WC) LENGTH TO PAD STRING TO ! 11883: # ! 11884: movl r8,r6 # copy length ! 11885: jsb alocs # allocate scblk for new string ! 11886: movl r9,-(sp) # save as result ! 11887: movl 4*sclen(r10),r6 # load length of argument ! 11888: subl2 r6,r8 # calculate number of pad characters ! 11889: movab cfp$f(r9),r9 # point to chars in result string ! 11890: # set counter for pad loop ! 11891: # ! 11892: # LOOP TO PERFORM PAD ! 11893: # ! 11894: slpd2: movb r7,(r9)+ # store pad character, bump ptr ! 11895: sobgtr r8,slpd2 # loop till all pad chars stored ! 11896: #csc r9 # complete store characters ! 11897: # ! 11898: # NOW COPY STRING ! 11899: # ! 11900: tstl r6 # exit if null string ! 11901: bnequ 0f ! 11902: jmp exits ! 11903: 0: ! 11904: movab cfp$f(r10),r10 # else point to chars in argument ! 11905: jsb sbmvc # move characters to result string ! 11906: jmp exits # jump for next code word ! 11907: # ! 11908: # HERE IF 2ND ARG IS NEGATIVE OR LARGE ! 11909: # ! 11910: slpd3: clrl r8 # zero pad count ! 11911: jmp slpd1 # merge ! 11912: #page ! 11913: # ! 11914: # LT ! 11915: # ! 11916: s$ltf: # entry point ! 11917: jsb acomp # call arithmetic comparison routine ! 11918: .long er_147 # lt first argument is not numeric ! 11919: .long er_148 # lt second argument is not numeric ! 11920: .long exnul # return null if lt ! 11921: .long exfal # fail if eq ! 11922: .long exfal # fail if gt ! 11923: #page ! 11924: # ! 11925: # NE ! 11926: # ! 11927: s$nef: # entry point ! 11928: jsb acomp # call arithmetic comparison routine ! 11929: .long er_149 # ne first argument is not numeric ! 11930: .long er_150 # ne second argument is not numeric ! 11931: .long exnul # return null if lt ! 11932: .long exfal # fail if eq ! 11933: .long exnul # return null if gt ! 11934: #page ! 11935: # ! 11936: # NOTANY ! 11937: # ! 11938: s$nay: # entry point ! 11939: movl $p$nas,r7 # set pcode for single char arg ! 11940: movl $p$nay,r10 # pcode for multi-char arg ! 11941: movl $p$nad,r8 # set pcode for expr arg ! 11942: jsb patst # call common routine to build node ! 11943: .long er_151 # notany argument is not string or expression ! 11944: jmp exixr # jump for next code word ! 11945: #page ! 11946: # ! 11947: # OPSYN ! 11948: # ! 11949: s$ops: # entry point ! 11950: jsb gtsmi # load third argument ! 11951: .long er_152 # opsyn third argument is not integer ! 11952: .long er_153 # opsyn third argument is negative or too large ! 11953: movl r8,r7 # if ok, save third argumnet ! 11954: movl (sp)+,r9 # load second argument ! 11955: jsb gtnvr # locate variable block ! 11956: .long er_154 # opsyn second arg is not natural variable name ! 11957: movl 4*vrfnc(r9),r10 # if ok, load function block pointer ! 11958: tstl r7 # jump if operator opsyn case ! 11959: bnequ sops2 ! 11960: # ! 11961: # HERE FOR FUNCTION OPSYN (THIRD ARG ZERO) ! 11962: # ! 11963: movl (sp)+,r9 # load first argument ! 11964: jsb gtnvr # get vrblk pointer ! 11965: .long er_155 # opsyn first arg is not natural variable name ! 11966: # ! 11967: # MERGE HERE TO PERFORM FUNCTION DEFINITION ! 11968: # ! 11969: sops1: jsb dffnc # call function definer ! 11970: jmp exnul # exit with null result ! 11971: # ! 11972: # HERE FOR OPERATOR OPSYN (THIRD ARG NON-ZERO) ! 11973: # ! 11974: sops2: jsb gtstg # get operator name ! 11975: .long sops5 # jump if not string ! 11976: cmpl r6,$num01 # error if not one char long ! 11977: bnequ sops5 ! 11978: movab cfp$f(r9),r9 # else point to character ! 11979: movzbl (r9),r8 # load character name ! 11980: #page ! 11981: # ! 11982: # OPSYN (CONTINUED) ! 11983: # ! 11984: # NOW SET TO SEARCH FOR MATCHING UNARY OR BINARY OPERATOR ! 11985: # NAME AS APPROPRIATE. NOTE THAT THERE ARE =OPBUN UNDEFINED ! 11986: # BINARY OPERATORS AND =OPUUN UNDEFINED UNARY OPERATORS. ! 11987: # ! 11988: movl $r$uub,r6 # point to unop pointers in case ! 11989: movl $opnsu,r9 # point to names of unary operators ! 11990: addl2 $opbun,r7 # add no. of undefined binary ops ! 11991: cmpl r7,$opuun # jump if unop (third arg was 1) ! 11992: beqlu sops3 ! 11993: movl $r$uba,r6 # else point to binary operator ptrs ! 11994: movl $opsnb,r9 # point to names of binary operators ! 11995: movl $opbun,r7 # set number of undefined binops ! 11996: # ! 11997: # MERGE HERE TO CHECK LIST (WB = NUMBER TO CHECK) ! 11998: # ! 11999: sops3: # set counter to control loop ! 12000: # ! 12001: # LOOP TO SEARCH FOR NAME MATCH ! 12002: # ! 12003: sops4: cmpl r8,(r9) # jump if names match ! 12004: beqlu sops6 ! 12005: addl2 $4,r6 # else push pointer to function ptr ! 12006: addl2 $4,r9 # bump pointer ! 12007: sobgtr r7,sops4 # loop back till all checked ! 12008: # ! 12009: # HERE IF BAD OPERATOR NAME ! 12010: # ! 12011: sops5: jmp er_156 # opsyn first arg is not correct operator name ! 12012: # ! 12013: # COME HERE ON FINDING A MATCH IN THE OPERATOR NAME TABLE ! 12014: # ! 12015: sops6: movl r6,r9 # copy pointer to function block ptr ! 12016: subl2 $4*vrfnc,r9 # make it look like dummy vrblk ! 12017: jmp sops1 # merge back to define operator ! 12018: #page ! 12019: # ! 12020: # OUTPUT ! 12021: # ! 12022: s$oup: # entry point ! 12023: movl $num03,r7 # output flag ! 12024: jsb ioput # call input/output assoc. routine ! 12025: .long er_157 # output third argument is not a string ! 12026: .long er_158 # inappropriate second argument for output ! 12027: .long er_159 # inappropriate first argument for output ! 12028: .long er_160 # inappropriate file specification for output ! 12029: .long exfal # fail if file does not exist ! 12030: .long er_161 # output file cannot be written to ! 12031: jmp exnul # return null string ! 12032: #page ! 12033: # ! 12034: # POS ! 12035: # ! 12036: s$pos: # entry point ! 12037: movl $p$pos,r7 # set pcode for integer arg case ! 12038: movl $p$psd,r6 # set pcode for expression arg case ! 12039: jsb patin # call common routine to build node ! 12040: .long er_162 # pos argument is not integer or expression ! 12041: .long er_163 # pos argument is negative or too large ! 12042: jmp exixr # return pattern node ! 12043: #page ! 12044: # ! 12045: # PROTOTYPE ! 12046: # ! 12047: s$pro: # entry point ! 12048: movl (sp)+,r9 # load argument ! 12049: movl 4*tblen(r9),r7 # length if table, vector (=vclen) ! 12050: ashl $-2,r7,r7 # convert to words ! 12051: movl (r9),r6 # load type word of argument block ! 12052: cmpl r6,$b$art # jump if array ! 12053: beqlu spro4 ! 12054: cmpl r6,$b$tbt # jump if table ! 12055: beqlu spro1 ! 12056: cmpl r6,$b$vct # jump if vector ! 12057: beqlu spro3 ! 12058: cmpl r6,$b$bct # jump if buffer ! 12059: beqlu spr05 ! 12060: jmp er_164 # prototype argument is not valid object ! 12061: # ! 12062: # HERE FOR TABLE ! 12063: # ! 12064: spro1: subl2 $tbsi$,r7 # subtract standard fields ! 12065: # ! 12066: # MERGE FOR VECTOR ! 12067: # ! 12068: spro2: movl r7,r5 # convert to integer ! 12069: jmp exint # exit with integer result ! 12070: # ! 12071: # HERE FOR VECTOR ! 12072: # ! 12073: spro3: subl2 $vcsi$,r7 # subtract standard fields ! 12074: jmp spro2 # merge ! 12075: # ! 12076: # HERE FOR ARRAY ! 12077: # ! 12078: spro4: addl2 4*arofs(r9),r9 # point to prototype field ! 12079: movl (r9),r9 # load prototype ! 12080: jmp exixr # return prototype as result ! 12081: # ! 12082: # HERE FOR BUFFER ! 12083: # ! 12084: spr05: movl 4*bcbuf(r9),r9 # point to bfblk ! 12085: movl 4*bfalc(r9),r5 # load allocated length ! 12086: jmp exint # exit with integer allocation ! 12087: #page ! 12088: # ! 12089: # REMDR ! 12090: # ! 12091: s$rmd: # entry point ! 12092: clrl r7 # set positive flag ! 12093: movl (sp),r9 # load second argument ! 12094: jsb gtint # convert to integer ! 12095: .long er_165 # remdr second argument is not integer ! 12096: jsb arith # convert args ! 12097: .long srm01 # first arg not integer ! 12098: .long invalid$ # second arg checked above ! 12099: .long srm01 # first arg real ! 12100: movl 4*icval(r9),r5 # load left argument value ! 12101: ashq $-32,r4,r4 # get remainder ! 12102: ediv 4*icval(r10),r4,r11,r5 ! 12103: bvs 0f ! 12104: jmp exint ! 12105: 0: ! 12106: jmp er_167 # remdr caused integer overflow ! 12107: # ! 12108: # FAIL FIRST ARGUMENT ! 12109: # ! 12110: srm01: jmp er_166 # remdr first argument is not integer ! 12111: #page ! 12112: # ! 12113: # REPLACE ! 12114: # ! 12115: # THE ACTUAL REPLACE OPERATION USES AN SCBLK WHOSE CFP$A ! 12116: # CHARS CONTAIN THE TRANSLATED VERSIONS OF ALL THE CHARS. ! 12117: # THE TABLE POINTER IS REMEMBERED FROM CALL TO CALL AND ! 12118: # THE TABLE IS ONLY BUILT WHEN THE ARGUMENTS CHANGE. ! 12119: # ! 12120: s$rpl: # entry point ! 12121: jsb gtstg # load third argument as string ! 12122: .long er_168 # replace third argument is not string ! 12123: movl r9,r10 # save third arg ptr ! 12124: jsb gtstg # get second argument ! 12125: .long er_169 # replace second argument is not string ! 12126: # ! 12127: # CHECK TO SEE IF THIS IS THE SAME TABLE AS LAST TIME ! 12128: # ! 12129: cmpl r9,r$ra2 # jump if 2nd argument different ! 12130: bnequ srpl1 ! 12131: cmpl r10,r$ra3 # jump if args same as last time ! 12132: bnequ 0f ! 12133: jmp srpl4 ! 12134: 0: ! 12135: # ! 12136: # HERE WE BUILD A NEW REPLACE TABLE (NOTE WA = 2ND ARG LEN) ! 12137: # ! 12138: srpl1: movl 4*sclen(r10),r7 # load 3rd argument length ! 12139: cmpl r6,r7 # jump if arguments not same length ! 12140: beqlu 0f ! 12141: jmp srpl5 ! 12142: 0: ! 12143: tstl r7 # jump if null 2nd argument ! 12144: bnequ 0f ! 12145: jmp srpl5 ! 12146: 0: ! 12147: movl r10,r$ra3 # save third arg for next time in ! 12148: movl r9,r$ra2 # save second arg for next time in ! 12149: movl kvalp,r10 # point to alphabet string ! 12150: movl 4*sclen(r10),r6 # load alphabet scblk length ! 12151: movl r$rpt,r9 # point to current table (if any) ! 12152: tstl r9 # jump if we already have a table ! 12153: bnequ srpl2 ! 12154: # ! 12155: # HERE WE ALLOCATE A NEW TABLE ! 12156: # ! 12157: jsb alocs # allocate new table ! 12158: movl r8,r6 # keep scblk length ! 12159: movl r9,r$rpt # save table pointer for next time ! 12160: # ! 12161: # MERGE HERE WITH POINTER TO NEW TABLE BLOCK IN (XR) ! 12162: # ! 12163: srpl2: movab 3+(4*scsi$)(r6),r6 # compute length of scblk ! 12164: bicl2 $3,r6 ! 12165: jsb sbmvw # copy to get initial table values ! 12166: #page ! 12167: # ! 12168: # REPLACE (CONTINUED) ! 12169: # ! 12170: # NOW WE MUST PLUG SELECTED ENTRIES AS REQUIRED. NOTE THAT ! 12171: # WE ARE SHORT OF INDEX REGISTERS FOR THE FOLLOWING LOOP. ! 12172: # HENCE THE NEED TO REPEATEDLY RE-INITIALISE CHAR PTR XL ! 12173: # ! 12174: movl r$ra2,r10 # point to second argument ! 12175: # number of chars to plug ! 12176: clrl r8 # zero char offset ! 12177: movl r$ra3,r9 # point to 3rd arg ! 12178: movab cfp$f(r9),r9 # get char ptr for 3rd arg ! 12179: # ! 12180: # LOOP TO PLUG CHARS ! 12181: # ! 12182: srpl3: movl r$ra2,r10 # point to 2nd arg ! 12183: movab cfp$f(r10)[r8],r10 # point to next char ! 12184: incl r8 # increment offset ! 12185: movzbl (r10),r6 # get next char ! 12186: movl r$rpt,r10 # point to translate table ! 12187: movab cfp$f(r10)[r6],r10 # convert char to offset into table ! 12188: movzbl (r9)+,r6 # get translated char ! 12189: movb r6,(r10) # store in table ! 12190: #csc r10 # complete store characters ! 12191: sobgtr r7,srpl3 # loop till done ! 12192: #page ! 12193: # ! 12194: # REPLACE (CONTINUED) ! 12195: # ! 12196: # HERE TO PERFORM TRANSLATE ! 12197: # ! 12198: srpl4: jsb gtstg # get first argument ! 12199: .long er_170 # replace first argument is not string ! 12200: tstl r6 # return null if null argument ! 12201: bnequ 0f ! 12202: jmp exnul ! 12203: 0: ! 12204: movl r9,r10 # copy pointer ! 12205: movl r6,r8 # save length ! 12206: movab 3+(4*schar)(r6),r6 # get scblk length ! 12207: bicl2 $3,r6 ! 12208: jsb alloc # allocate space for copy ! 12209: movl r9,r7 # save address of copy ! 12210: jsb sbmvw # move scblk contents to copy ! 12211: movl r$rpt,r9 # point to replace table ! 12212: movab cfp$f(r9),r9 # point to chars of table ! 12213: movl r7,r10 # point to string to translate ! 12214: movab cfp$f(r10),r10 # point to chars of string ! 12215: movl r8,r6 # set number of chars to translate ! 12216: jsb sbtrc # perform translation ! 12217: movl r7,-(sp) # stack new string as result ! 12218: jmp exits # return with result on stack ! 12219: # ! 12220: # ERROR POINT ! 12221: # ! 12222: srpl5: jmp er_171 # null or unequally long 2nd, 3rd args to replace ! 12223: #page ! 12224: # ! 12225: # REWIND ! 12226: # ! 12227: s$rew: # entry point ! 12228: jsb iofcb # call fcblk routine ! 12229: .long er_172 # rewind argument is not a suitable name ! 12230: .long er_173 # rewind argument is null ! 12231: jsb sysrw # call system rewind function ! 12232: .long er_174 # rewind file does not exist ! 12233: .long er_175 # rewind file does not permit rewind ! 12234: .long er_176 # rewind caused non-recoverable error ! 12235: jmp exnul # exit with null result if no error ! 12236: #page ! 12237: # ! 12238: # REVERSE ! 12239: # ! 12240: s$rvs: # entry point ! 12241: jsb gtstg # load string argument ! 12242: .long er_177 # reverse argument is not string ! 12243: tstl r6 # return argument if null ! 12244: bnequ 0f ! 12245: jmp exixr ! 12246: 0: ! 12247: movl r9,r10 # else save pointer to string arg ! 12248: jsb alocs # allocate space for new scblk ! 12249: movl r9,-(sp) # store scblk ptr on stack as result ! 12250: movab cfp$f(r9),r9 # prepare to store in new scblk ! 12251: movab cfp$f(r10)[r8],r10 # point past last char in argument ! 12252: # set loop counter ! 12253: # ! 12254: # LOOP TO MOVE CHARS IN REVERSE ORDER ! 12255: # ! 12256: srvs1: movzbl -(r10),r7 # load next char from argument ! 12257: movb r7,(r9)+ # store in result ! 12258: sobgtr r8,srvs1 # loop till all moved ! 12259: #csc r9 # complete store characters ! 12260: jmp exits # and then jump for next code word ! 12261: #page ! 12262: # ! 12263: # RPAD ! 12264: # ! 12265: s$rpd: # entry point ! 12266: jsb gtstg # get pad character ! 12267: .long er_178 # rpad third argument is not string ! 12268: movab cfp$f(r9),r9 # point to character (null is blank) ! 12269: movzbl (r9),r7 # load pad character ! 12270: jsb gtsmi # get pad length ! 12271: .long er_179 # rpad second argument is not integer ! 12272: .long srpd3 # skip if negative or large ! 12273: # ! 12274: # MERGE TO CHECK FIRST ARG. ! 12275: # ! 12276: srpd1: jsb gtstg # get first argument (string to pad) ! 12277: .long er_180 # rpad first argument is not string ! 12278: cmpl r6,r8 # return 1st arg if too long to pad ! 12279: blssu 0f ! 12280: jmp exixr ! 12281: 0: ! 12282: movl r9,r10 # else move ptr to string to pad ! 12283: # ! 12284: # NOW WE ARE READY FOR THE PAD ! 12285: # ! 12286: # (XL) POINTER TO STRING TO PAD ! 12287: # (WB) PAD CHARACTER ! 12288: # (WC) LENGTH TO PAD STRING TO ! 12289: # ! 12290: movl r8,r6 # copy length ! 12291: jsb alocs # allocate scblk for new string ! 12292: movl r9,-(sp) # save as result ! 12293: movl 4*sclen(r10),r6 # load length of argument ! 12294: subl2 r6,r8 # calculate number of pad characters ! 12295: movab cfp$f(r9),r9 # point to chars in result string ! 12296: # set counter for pad loop ! 12297: # ! 12298: # COPY ARGUMENT STRING ! 12299: # ! 12300: tstl r6 # jump if argument is null ! 12301: beqlu srpd2 ! 12302: movab cfp$f(r10),r10 # else point to argument chars ! 12303: jsb sbmvc # move characters to result string ! 12304: # ! 12305: # LOOP TO SUPPLY PAD CHARACTERS ! 12306: # ! 12307: srpd2: movb r7,(r9)+ # store pad character, bump ptr ! 12308: sobgtr r8,srpd2 # loop till all pad chars stored ! 12309: #csc r9 # complete character storing ! 12310: jmp exits # and exit for next word ! 12311: # ! 12312: # HERE IF 2ND ARG IS NEGATIVE OR LARGE ! 12313: # ! 12314: srpd3: clrl r8 # zero pad count ! 12315: jmp srpd1 # merge ! 12316: #page ! 12317: # ! 12318: # RTAB ! 12319: # ! 12320: s$rtb: # entry point ! 12321: movl $p$rtb,r7 # set pcode for integer arg case ! 12322: movl $p$rtd,r6 # set pcode for expression arg case ! 12323: jsb patin # call common routine to build node ! 12324: .long er_181 # rtab argument is not integer or expression ! 12325: .long er_182 # rtab argument is negative or too large ! 12326: jmp exixr # return pattern node ! 12327: #page ! 12328: # ! 12329: # SET ! 12330: # ! 12331: s$set: # entry point ! 12332: movl (sp)+,r$io2 # save third arg ! 12333: movl (sp)+,r$io1 # save second arg ! 12334: jsb iofcb # call fcblk routine ! 12335: .long er_291 # set first argument is not a suitable name ! 12336: .long er_292 # set first argument is null ! 12337: movl r$io1,r7 # load second arg ! 12338: movl r$io2,r8 # load third arg ! 12339: jsb sysst # call system set routine ! 12340: .long er_293 # inappropriate second argument to set ! 12341: .long er_294 # inappropriate third argument to set ! 12342: .long er_295 # set file does not exist ! 12343: .long er_296 # set file does not permit setting file pointer ! 12344: .long er_297 # set caused non-recoverable i/o error ! 12345: jmp exnul # otherwisew return null ! 12346: #page ! 12347: # ! 12348: # TAB ! 12349: # ! 12350: s$tab: # entry point ! 12351: movl $p$tab,r7 # set pcode for integer arg case ! 12352: movl $p$tbd,r6 # set pcode for expression arg case ! 12353: jsb patin # call common routine to build node ! 12354: .long er_183 # tab argument is not integer or expression ! 12355: .long er_184 # tab argument is negative or too large ! 12356: jmp exixr # return pattern node ! 12357: #page ! 12358: # ! 12359: # RPOS ! 12360: # ! 12361: s$rps: # entry point ! 12362: movl $p$rps,r7 # set pcode for integer arg case ! 12363: movl $p$rpd,r6 # set pcode for expression arg case ! 12364: jsb patin # call common routine to build node ! 12365: .long er_185 # rpos argument is not integer or expression ! 12366: .long er_186 # rpos argument is negative or too large ! 12367: jmp exixr # return pattern node ! 12368: #page ! 12369: # ! 12370: # RSORT ! 12371: # ! 12372: s$rsr: # entry point ! 12373: movl sp,r6 # mark as rsort ! 12374: jsb sorta # call sort routine ! 12375: jmp exsid # return, setting idval ! 12376: #page ! 12377: # ! 12378: # SETEXIT ! 12379: # ! 12380: s$stx: # entry point ! 12381: movl (sp)+,r9 # load argument ! 12382: movl stxvr,r6 # load old vrblk pointer ! 12383: clrl r10 # load zero in case null arg ! 12384: cmpl r9,$nulls # jump if null argument (reset call) ! 12385: beqlu sstx1 ! 12386: jsb gtnvr # else get specified vrblk ! 12387: .long sstx2 # jump if not natural variable ! 12388: movl 4*vrlbl(r9),r10 # else load label ! 12389: cmpl r10,$stndl # jump if label is not defined ! 12390: beqlu sstx2 ! 12391: cmpl (r10),$b$trt # jump if not trapped ! 12392: bnequ sstx1 ! 12393: movl 4*trlbl(r10),r10# else load ptr to real label code ! 12394: # ! 12395: # HERE TO SET/RESET SETEXIT TRAP ! 12396: # ! 12397: sstx1: movl r9,stxvr # store new vrblk pointer (or null) ! 12398: movl r10,r$sxc # store new code ptr (or zero) ! 12399: cmpl r6,$nulls # return null if null result ! 12400: bnequ 0f ! 12401: jmp exnul ! 12402: 0: ! 12403: movl r6,r9 # else copy vrblk pointer ! 12404: jmp exvnm # and return building nmblk ! 12405: # ! 12406: # HERE IF BAD ARGUMENT ! 12407: # ! 12408: sstx2: jmp er_187 # setexit argument is not label name or null ! 12409: #page ! 12410: # ! 12411: # SORT ! 12412: # ! 12413: s$srt: # entry point ! 12414: clrl r6 # mark as sort ! 12415: jsb sorta # call sort routine ! 12416: jmp exsid # return, setting idval ! 12417: #page ! 12418: # ! 12419: # SPAN ! 12420: # ! 12421: s$spn: # entry point ! 12422: movl $p$sps,r7 # set pcode for single char arg ! 12423: movl $p$spn,r10 # set pcode for multi-char arg ! 12424: movl $p$spd,r8 # set pcode for expression arg ! 12425: jsb patst # call common routine to build node ! 12426: .long er_188 # span argument is not string or expression ! 12427: jmp exixr # jump for next code word ! 12428: #page ! 12429: # ! 12430: # SIZE ! 12431: # ! 12432: s$si$: # entry point ! 12433: movl (sp),r9 # load argument ! 12434: cmpl (r9),$b$bct # branch if not buffer ! 12435: bnequ ssi$1 ! 12436: addl2 $4,sp # else pop argument ! 12437: movl 4*bclen(r9),r5 # load defined length ! 12438: jmp exint # exit with integer ! 12439: # ! 12440: # HERE IF NOT BUFFER ! 12441: # ! 12442: ssi$1: jsb gtstg # load string argument ! 12443: .long er_189 # size argument is not string ! 12444: movl r6,r5 # load length as integer ! 12445: jmp exint # exit with integer result ! 12446: #page ! 12447: # ! 12448: # STOPTR ! 12449: # ! 12450: s$stt: # entry point ! 12451: clrl r10 # indicate stoptr case ! 12452: jsb trace # call trace procedure ! 12453: .long er_190 # stoptr first argument is not appropriate name ! 12454: .long er_191 # stoptr second argument is not trace type ! 12455: jmp exnul # return null ! 12456: #page ! 12457: # ! 12458: # SUBSTR ! 12459: # ! 12460: s$sub: # entry point ! 12461: jsb gtsmi # load third argument ! 12462: .long er_192 # substr third argument is not integer ! 12463: .long exfal # jump if negative or too large ! 12464: movl r9,sbssv # save third argument ! 12465: jsb gtsmi # load second argument ! 12466: .long er_193 # substr second argument is not integer ! 12467: .long exfal # jump if out of range ! 12468: movl r9,r7 # save second argument ! 12469: tstl r7 # jump if second argument zero ! 12470: bnequ 0f ! 12471: jmp exfal ! 12472: 0: ! 12473: decl r7 # else decrement for ones origin ! 12474: movl (sp),r10 # get first arg ptr ! 12475: cmpl (r10),$b$bct # branch if not buffer ! 12476: bnequ ssuba ! 12477: movl 4*bcbuf(r10),r9 # get bfblk ptr ! 12478: movl 4*bclen(r10),r6 # get length ! 12479: jmp ssubb # merge ! 12480: # ! 12481: # HERE IF NOT BUFFER TO GET STRING ! 12482: # ! 12483: ssuba: jsb gtstg # load first argument ! 12484: .long er_194 # substr first argument is not string ! 12485: # ! 12486: # MERGE WITH BFBLK OR SCBLK PTR IN XR. WA HAS LENGTH ! 12487: # ! 12488: ssubb: movl sbssv,r8 # reload third argument ! 12489: tstl r8 # skip if third arg given ! 12490: bnequ ssub1 ! 12491: movl r6,r8 # else get string length ! 12492: cmpl r7,r8 # fail if improper ! 12493: blequ 0f ! 12494: jmp exfal ! 12495: 0: ! 12496: subl2 r7,r8 # reduce by offset to start ! 12497: # ! 12498: # MERGE ! 12499: # ! 12500: ssub1: movl r6,r10 # save string length ! 12501: movl r8,r6 # set length of substring ! 12502: addl2 r7,r8 # add 2nd arg to 3rd arg ! 12503: cmpl r8,r10 # jump if improper substring ! 12504: blequ 0f ! 12505: jmp exfal ! 12506: 0: ! 12507: movl r9,r10 # copy pointer to first arg ! 12508: jsb sbstr # build substring ! 12509: jmp exixr # and jump for next code word ! 12510: #page ! 12511: # ! 12512: # TABLE ! 12513: # ! 12514: s$tbl: # entry point ! 12515: movl (sp)+,r10 # get initial lookup value ! 12516: addl2 $4,sp # pop second argument ! 12517: jsb gtsmi # load argument ! 12518: .long er_195 # table argument is not integer ! 12519: .long er_196 # table argument is out of range ! 12520: tstl r8 # jump if non-zero ! 12521: bnequ stbl1 ! 12522: movl $tbnbk,r8 # else supply default value ! 12523: # ! 12524: # MERGE HERE WITH NUMBER OF HEADERS IN WA ! 12525: # ! 12526: stbl1: movl r8,r6 # copy number of headers ! 12527: addl2 $tbsi$,r6 # adjust for standard fields ! 12528: moval 0[r6],r6 # convert length to bytes ! 12529: jsb alloc # allocate space for tbblk ! 12530: movl r9,r7 # copy pointer to tbblk ! 12531: movl $b$tbt,(r9)+ # store type word ! 12532: clrl (r9)+ # zero id for the moment ! 12533: movl r6,(r9)+ # store length (tblen) ! 12534: movl r10,(r9)+ # store initial lookup value ! 12535: # set loop counter (num headers) ! 12536: # ! 12537: # LOOP TO INITIALIZE ALL BUCKET POINTERS ! 12538: # ! 12539: stbl2: movl r7,(r9)+ # store tbblk ptr in bucket header ! 12540: sobgtr r8,stbl2 # loop till all stored ! 12541: movl r7,r9 # recall pointer to tbblk ! 12542: jmp exsid # exit setting idval ! 12543: #page ! 12544: # ! 12545: # TIME ! 12546: # ! 12547: s$tim: # entry point ! 12548: jsb systm # get timer value ! 12549: subl2 timsx,r5 # subtract starting time ! 12550: jmp exint # exit with integer value ! 12551: #page ! 12552: # ! 12553: # TRACE ! 12554: # ! 12555: s$tra: # entry point ! 12556: cmpl 4*3(sp),$nulls # jump if first argument is null ! 12557: beqlu str03 ! 12558: movl (sp)+,r9 # load fourth argument ! 12559: clrl r10 # tentatively set zero pointer ! 12560: cmpl r9,$nulls # jump if 4th argument is null ! 12561: beqlu str02 ! 12562: jsb gtnvr # else point to vrblk ! 12563: .long str01 # jump if not variable name ! 12564: movl 4*vrfnc(r9),r10 # else load function pointer ! 12565: cmpl r10,$stndf # jump if function is defined ! 12566: bnequ str02 ! 12567: # ! 12568: # HERE FOR BAD FOURTH ARGUMENT ! 12569: # ! 12570: str01: jmp er_197 # trace fourth arg is not function name or null ! 12571: # ! 12572: # HERE WITH FUNCTION POINTER IN XL ! 12573: # ! 12574: str02: movl (sp)+,r9 # load third argument (tag) ! 12575: clrl r7 # set zero as trtyp value for now ! 12576: jsb trbld # build trblk for trace call ! 12577: movl r9,r10 # move trblk pointer for trace ! 12578: jsb trace # call trace procedure ! 12579: .long er_198 # trace first argument is not appropriate name ! 12580: .long er_199 # trace second argument is not trace type ! 12581: jmp exnul # return null ! 12582: # ! 12583: # HERE TO CALL SYSTEM TRACE TOGGLE ROUTINE ! 12584: # ! 12585: str03: jsb systt # call it ! 12586: addl2 $4*num04,sp # pop trace arguments ! 12587: jmp exnul # return ! 12588: #page ! 12589: # ! 12590: # TRIM ! 12591: # ! 12592: s$trm: # entry point ! 12593: jsb gtstg # load argument as string ! 12594: .long er_200 # trim argument is not string ! 12595: tstl r6 # return null if argument is null ! 12596: bnequ 0f ! 12597: jmp exnul ! 12598: 0: ! 12599: movl r9,r10 # copy string pointer ! 12600: movab 3+(4*schar)(r6),r6 # get block length ! 12601: bicl2 $3,r6 ! 12602: jsb alloc # allocate copy same size ! 12603: movl r9,r7 # save pointer to copy ! 12604: jsb sbmvw # copy old string block to new ! 12605: movl r7,r9 # restore ptr to new block ! 12606: jsb trimr # trim blanks (wb is non-zero) ! 12607: jmp exixr # exit with result in xr ! 12608: #page ! 12609: # ! 12610: # UNLOAD ! 12611: # ! 12612: s$unl: # entry point ! 12613: movl (sp)+,r9 # load argument ! 12614: jsb gtnvr # point to vrblk ! 12615: .long er_201 # unload argument is not natural variable name ! 12616: movl $stndf,r10 # get ptr to undefined function ! 12617: jsb dffnc # undefine named function ! 12618: jmp exnul # return null as result ! 12619: #title s p i t b o l -- utility procedures ! 12620: # ! 12621: # THE FOLLOWING SECTION CONTAINS PROCEDURES WHICH ARE ! 12622: # USED FOR VARIOUS PURPOSES THROUGHOUT THE SYSTEM. ! 12623: # ! 12624: # EACH PROCEDURE IS PRECEDED BY A DESCRIPTION OF THE ! 12625: # CALLING SEQUENCE. USUALLY THE ARGUMENTS ARE IN REGISTERS ! 12626: # BUT ARGUMENTS CAN ALSO OCCUR ON THE STACK AND AS ! 12627: # PARAMETERS ASSEMBLED AFTER THE JSR INSTRUCTION. ! 12628: # ! 12629: # THE FOLLOWING CONSIDERATIONS APPLY TO THESE DESCRIPTIONS. ! 12630: # ! 12631: # 1) THE STACK POINTER (XS) IS NOT CHANGED UNLESS THE ! 12632: # CHANGE IS EXPLICITLY DOCUMENTED IN THE CALL. ! 12633: # ! 12634: # 2) REGISTERS WHOSE ENTRY VALUES ARE NOT MENTIONED ! 12635: # MAY CONTAIN ANY VALUE EXCEPT THAT XL,XR MAY ONLY ! 12636: # CONTAIN PROPER (COLLECTABLE) POINTER VALUES. ! 12637: # THIS CONDITION ON XR MEANS THAT THE CALLED ROUTINE ! 12638: # MAY IF IT CHOOSES PRESERVE XR BY STACKING. ! 12639: # ! 12640: # 3) REGISTERS NOT MENTIONED ON EXIT CONTAIN THE SAME ! 12641: # VALUES AS THEY DID ON ENTRY EXCEPT THAT VALUES IN ! 12642: # XR,XL MAY HAVE BEEN RELOCATED BY THE COLLECTOR. ! 12643: # ! 12644: # 4) REGISTERS WHICH ARE DESTROYED ON EXIT MAY CONTAIN ! 12645: # ANY VALUE EXCEPT THAT VALUES IN XL,XR ARE PROPER ! 12646: # (COLLECTABLE) POINTERS. ! 12647: # ! 12648: # 5) THE CODE POINTER REGISTER POINTS TO THE CURRENT ! 12649: # CODE LOCATION ON ENTRY AND IS UNCHANGED ON EXIT. ! 12650: # ! 12651: # IN THE ABOVE DESCRIPTION, A COLLECTABLE POINTER IS ONE ! 12652: # WHICH EITHER POINTS OUTSIDE THE DYNAMIC REGION OR ! 12653: # POINTS TO THE START OF A BLOCK IN THE DYNAMIC REGION. ! 12654: # ! 12655: # IN THOSE CASES WHERE THE CALLING SEQUENCE CONTAINS ! 12656: # PARAMETERS WHICH ARE USED AS ALTERNATE RETURN POINTS, ! 12657: # THESE PARAMETERS MAY BE REPLACED BY ERROR CODES ! 12658: # ASSEMBLED WITH THE ERR INSTRUCTION. THIS WILL RESULT ! 12659: # IN THE POSTING OF THE ERROR IF THE RETURN IS TAKEN. ! 12660: # ! 12661: # THE PROCEDURES ALL HAVE NAMES CONSISTING OF FIVE LETTERS ! 12662: # AND ARE IN ALPHABETICAL ORDER BY THEIR NAMES. ! 12663: #page ! 12664: # ! 12665: # ACESS - ACCESS VARIABLE VALUE WITH TRACE/INPUT CHECKS ! 12666: # ! 12667: # ACESS LOADS THE VALUE OF A VARIABLE. TRACE AND INPUT ! 12668: # ASSOCIATIONS ARE TESTED FOR AND EXECUTED AS REQUIRED. ! 12669: # ACESS ALSO HANDLES THE SPECIAL CASES OF PSEUDO-VARIABLES. ! 12670: # ! 12671: # (XL) VARIABLE NAME BASE ! 12672: # (WA) VARIABLE NAME OFFSET ! 12673: # JSR ACESS CALL TO ACCESS VALUE ! 12674: # PPM LOC TRANSFER LOC IF ACCESS FAILURE ! 12675: # (XR) VARIABLE VALUE ! 12676: # (WA,WB,WC) DESTROYED ! 12677: # (XL,RA) DESTROYED ! 12678: # ! 12679: # FAILURE CAN OCCUR IF AN INPUT ASSOCIATION CAUSES AN END ! 12680: # OF FILE CONDITION OR IF THE EVALUATION OF AN EXPRESSION ! 12681: # ASSOCIATED WITH AN EXPRESSION VARIABLE FAILS. ! 12682: # ! 12683: acess: #prc # entry point (recursive) ! 12684: movl r10,r9 # copy name base ! 12685: addl2 r6,r9 # point to variable location ! 12686: movl (r9),r9 # load variable value ! 12687: # ! 12688: # LOOP HERE TO CHECK FOR SUCCESSIVE TRBLKS ! 12689: # ! 12690: acs02: cmpl (r9),$b$trt # jump if not trapped ! 12691: beqlu 0f ! 12692: jmp acs18 ! 12693: 0: ! 12694: # ! 12695: # HERE IF TRAPPED ! 12696: # ! 12697: cmpl r9,$trbkv # jump if keyword variable ! 12698: bnequ 0f ! 12699: jmp acs12 ! 12700: 0: ! 12701: cmpl r9,$trbev # jump if not expression variable ! 12702: bnequ acs05 ! 12703: # ! 12704: # HERE FOR EXPRESSION VARIABLE, EVALUATE VARIABLE ! 12705: # ! 12706: movl 4*evexp(r10),r9 # load expression pointer ! 12707: clrl r7 # evaluate by value ! 12708: jsb evalx # evaluate expression ! 12709: .long acs04 # jump if evaluation failure ! 12710: jmp acs02 # check value for more trblks ! 12711: #page ! 12712: # ! 12713: # ACESS (CONTINUED) ! 12714: # ! 12715: # HERE ON READING END OF FILE ! 12716: # ! 12717: acs03: addl2 $4*num03,sp # pop trblk ptr, name base and offset ! 12718: movl r9,dnamp # pop unused scblk ! 12719: # ! 12720: # MERGE HERE WHEN EVALUATION OF EXPRESSION FAILS ! 12721: # ! 12722: acs04: movl (sp)+,r11 # take alternate (failure) return ! 12723: jmp *(r11)+ ! 12724: # ! 12725: # HERE IF NOT KEYWORD OR EXPRESSION VARIABLE ! 12726: # ! 12727: acs05: movl 4*trtyp(r9),r7 # load trap type code ! 12728: tstl r7 # jump if not input association ! 12729: beqlu 0f ! 12730: jmp acs10 ! 12731: 0: ! 12732: tstl kvinp # ignore input assoc if input is off ! 12733: bnequ 0f ! 12734: jmp acs09 ! 12735: 0: ! 12736: # ! 12737: # HERE FOR INPUT ASSOCIATION ! 12738: # ! 12739: movl r10,-(sp) # stack name base ! 12740: movl r6,-(sp) # stack name offset ! 12741: movl r9,-(sp) # stack trblk pointer ! 12742: movl 4*trfpt(r9),r10 # get file ctrl blk ptr or zero ! 12743: tstl r10 # jump if not standard input file ! 12744: bnequ acs06 ! 12745: cmpl 4*trter(r9),$v$ter # jump if terminal ! 12746: bnequ 0f ! 12747: jmp acs21 ! 12748: 0: ! 12749: # ! 12750: # HERE TO READ FROM STANDARD INPUT FILE ! 12751: # ! 12752: movl cswin,r6 # length for read buffer ! 12753: jsb alocs # build string of appropriate length ! 12754: jsb sysrd # read next standard input image ! 12755: .long acs03 # jump to fail exit if end of file ! 12756: jmp acs07 # else merge with other file case ! 12757: # ! 12758: # HERE FOR INPUT FROM OTHER THAN STANDARD INPUT FILE ! 12759: # ! 12760: acs06: movl r10,r6 # fcblk ptr ! 12761: jsb sysil # get input record max length (to wa) ! 12762: jsb alocs # allocate string of correct size ! 12763: movl r10,r6 # fcblk ptr ! 12764: jsb sysin # call system input routine ! 12765: .long acs03 # jump to fail exit if end of file ! 12766: .long acs22 # error ! 12767: .long acs23 # error ! 12768: #page ! 12769: # ! 12770: # ACESS (CONTINUED) ! 12771: # ! 12772: # MERGE HERE AFTER OBTAINING INPUT RECORD ! 12773: # ! 12774: acs07: movl kvtrm,r7 # load trim indicator ! 12775: jsb trimr # trim record as required ! 12776: movl r9,r7 # copy result pointer ! 12777: movl (sp),r9 # reload pointer to trblk ! 12778: # ! 12779: # LOOP TO CHASE TO END OF TRBLK CHAIN AND STORE VALUE ! 12780: # ! 12781: acs08: movl r9,r10 # save pointer to this trblk ! 12782: movl 4*trnxt(r9),r9 # load forward pointer ! 12783: cmpl (r9),$b$trt # loop if this is another trblk ! 12784: beqlu acs08 ! 12785: movl r7,4*trnxt(r10) # else store result at end of chain ! 12786: movl (sp)+,r9 # restore initial trblk pointer ! 12787: movl (sp)+,r6 # restore name offset ! 12788: movl (sp)+,r10 # restore name base pointer ! 12789: # ! 12790: # COME HERE TO MOVE TO NEXT TRBLK ! 12791: # ! 12792: acs09: movl 4*trnxt(r9),r9 # load forward ptr to next value ! 12793: jmp acs02 # back to check if trapped ! 12794: # ! 12795: # HERE TO CHECK FOR ACCESS TRACE TRBLK ! 12796: # ! 12797: acs10: cmpl r7,$trtac # loop back if not access trace ! 12798: beqlu 0f ! 12799: jmp acs09 ! 12800: 0: ! 12801: tstl kvtra # ignore access trace if trace off ! 12802: bnequ 0f ! 12803: jmp acs09 ! 12804: 0: ! 12805: decl kvtra # else decrement trace count ! 12806: tstl 4*trfnc(r9) # jump if print trace ! 12807: beqlu acs11 ! 12808: #page ! 12809: # ! 12810: # ACESS (CONTINUED) ! 12811: # ! 12812: # HERE FOR FULL FUNCTION TRACE ! 12813: # ! 12814: jsb trxeq # call routine to execute trace ! 12815: jmp acs09 # jump for next trblk ! 12816: # ! 12817: # HERE FOR CASE OF PRINT TRACE ! 12818: # ! 12819: acs11: jsb prtsn # print statement number ! 12820: jsb prtnv # print name = value ! 12821: jmp acs09 # jump back for next trblk ! 12822: # ! 12823: # HERE FOR KEYWORD VARIABLE ! 12824: # ! 12825: acs12: movl 4*kvnum(r10),r9 # load keyword number ! 12826: cmpl r9,$k$v$$ # jump if not one word value ! 12827: bgequ acs14 ! 12828: movl l^kvabe(r9),r5 # else load value as integer ! 12829: # ! 12830: # COMMON EXIT WITH KEYWORD VALUE AS INTEGER IN (IA) ! 12831: # ! 12832: acs13: jsb icbld # build icblk ! 12833: jmp acs18 # jump to exit ! 12834: # ! 12835: # HERE IF NOT ONE WORD KEYWORD VALUE ! 12836: # ! 12837: acs14: cmpl r9,$k$s$$ # jump if special case ! 12838: bgequ acs15 ! 12839: subl2 $k$v$$,r9 # else get offset ! 12840: addl2 $ndabo,r9 # point to pattern value ! 12841: jmp acs18 # jump to exit ! 12842: # ! 12843: # HERE IF SPECIAL KEYWORD CASE ! 12844: # ! 12845: acs15: movl kvrtn,r10 # load rtntype in case ! 12846: movl kvstl,r5 # load stlimit in case ! 12847: subl2 $k$s$$,r9 # get case number ! 12848: casel r9,$0,$5 # switch on keyword number ! 12849: 5: ! 12850: .word acs16-5b # jump if alphabet ! 12851: .word acs17-5b # rtntype ! 12852: .word acs19-5b # stcount ! 12853: .word acs20-5b # errtext ! 12854: .word acs13-5b # stlimit ! 12855: #esw # end switch on keyword number ! 12856: #page ! 12857: # ! 12858: # ACESS (CONTINUED) ! 12859: # ! 12860: # ALPHABET ! 12861: # ! 12862: acs16: movl kvalp,r10 # load pointer to alphabet string ! 12863: # ! 12864: # RTNTYPE MERGES HERE ! 12865: # ! 12866: acs17: movl r10,r9 # copy string ptr to proper reg ! 12867: # ! 12868: # COMMON RETURN POINT ! 12869: # ! 12870: acs18: addl2 $4*1,(sp) # return to acess caller ! 12871: rsb ! 12872: # ! 12873: # HERE FOR STCOUNT (IA HAS STLIMIT) ! 12874: # ! 12875: acs19: subl2 kvstc,r5 # stcount = limit - left ! 12876: jmp acs13 # merge back with integer result ! 12877: # ! 12878: # ERRTEXT ! 12879: # ! 12880: acs20: movl r$etx,r9 # get errtext string ! 12881: jmp acs18 # merge with result ! 12882: # ! 12883: # HERE TO READ A RECORD FROM TERMINAL ! 12884: # ! 12885: acs21: movl $rilen,r6 # buffer length ! 12886: jsb alocs # allocate buffer ! 12887: jsb sysri # read record ! 12888: .long acs03 # endfile ! 12889: jmp acs07 # merge with record read ! 12890: # ! 12891: # ERROR RETURNS ! 12892: # ! 12893: acs22: movl r9,dnamp # pop unused scblk ! 12894: jmp er_202 # input from file caused non-recoverable error ! 12895: # ! 12896: acs23: movl r9,dnamp # pop unused scblk ! 12897: jmp er_203 # input file record has incorrect format ! 12898: #enp # end procedure acess ! 12899: #page ! 12900: # ! 12901: # ACOMP -- COMPARE TWO ARITHMETIC VALUES ! 12902: # ! 12903: # 1(XS) FIRST ARGUMENT ! 12904: # 0(XS) SECOND ARGUMENT ! 12905: # JSR ACOMP CALL TO COMPARE VALUES ! 12906: # PPM LOC TRANSFER LOC IF ARG1 IS NON-NUMERIC ! 12907: # PPM LOC TRANSFER LOC IF ARG2 IS NON-NUMERIC ! 12908: # PPM LOC TRANSFER LOC FOR ARG1 LT ARG2 ! 12909: # PPM LOC TRANSFER LOC FOR ARG1 EQ ARG2 ! 12910: # PPM LOC TRANSFER LOC FOR ARG1 GT ARG2 ! 12911: # (NORMAL RETURN IS NEVER GIVEN) ! 12912: # (WA,WB,WC,IA,RA) DESTROYED ! 12913: # (XL,XR) DESTROYED ! 12914: # ! 12915: .data 1 ! 12916: acomp_s: .long 0 ! 12917: .text 0 ! 12918: acomp: movl (sp)+,acomp_s # entry point ! 12919: jsb arith # load arithmetic operands ! 12920: .long acmp7 # jump if first arg non-numeric ! 12921: .long acmp8 # jump if second arg non-numeric ! 12922: .long acmp4 # jump if real arguments ! 12923: # ! 12924: # HERE FOR INTEGER ARGUMENTS ! 12925: # ! 12926: subl2 4*icval(r10),r5 # subtract to compare ! 12927: bvs acmp3 ! 12928: tstl r5 # else jump if arg1 lt arg2 ! 12929: blss acmp5 ! 12930: tstl r5 # jump if arg1 eq arg2 ! 12931: beql acmp2 ! 12932: # ! 12933: # HERE IF ARG1 GT ARG2 ! 12934: # ! 12935: acmp1: addl3 $4*4,acomp_s,r11 # take gt exit ! 12936: jmp *(r11)+ ! 12937: # ! 12938: # HERE IF ARG1 EQ ARG2 ! 12939: # ! 12940: acmp2: addl3 $4*3,acomp_s,r11 # take eq exit ! 12941: jmp *(r11)+ ! 12942: #page ! 12943: # ! 12944: # ACOMP (CONTINUED) ! 12945: # ! 12946: # HERE FOR INTEGER OVERFLOW ON SUBTRACT ! 12947: # ! 12948: acmp3: movl 4*icval(r10),r5 # load second argument ! 12949: tstl r5 # gt if negative ! 12950: blss acmp1 ! 12951: jmp acmp5 # else lt ! 12952: # ! 12953: # HERE FOR REAL OPERANDS ! 12954: # ! 12955: acmp4: subf2 4*rcval(r10),r2 # subtract to compare ! 12956: bvs acmp6 ! 12957: tstf r2 # else jump if arg1 gt ! 12958: bgtr acmp1 ! 12959: tstf r2 # jump if arg1 eq arg2 ! 12960: beql acmp2 ! 12961: # ! 12962: # HERE IF ARG1 LT ARG2 ! 12963: # ! 12964: acmp5: addl3 $4*2,acomp_s,r11 # take lt exit ! 12965: jmp *(r11)+ ! 12966: # ! 12967: # HERE IF OVERFLOW ON REAL SUBTRACTION ! 12968: # ! 12969: acmp6: movf 4*rcval(r10),r2 # reload arg2 ! 12970: tstf r2 # gt if negative ! 12971: blss acmp1 ! 12972: jmp acmp5 # else lt ! 12973: # ! 12974: # HERE IF ARG1 NON-NUMERIC ! 12975: # ! 12976: acmp7: movl acomp_s,r11 # take error exit ! 12977: jmp *(r11)+ ! 12978: # ! 12979: # HERE IF ARG2 NON-NUMERIC ! 12980: # ! 12981: acmp8: addl3 $4*1,acomp_s,r11 # take error exit ! 12982: jmp *(r11)+ ! 12983: #enp # end procedure acomp ! 12984: #page ! 12985: # ! 12986: # ALLOC ALLOCATE BLOCK OF DYNAMIC STORAGE ! 12987: # ! 12988: # (WA) LENGTH REQUIRED IN BYTES ! 12989: # JSR ALLOC CALL TO ALLOCATE BLOCK ! 12990: # (XR) POINTER TO ALLOCATED BLOCK ! 12991: # ! 12992: # A POSSIBLE ALTERNATIVE TO AOV .. AND FOLLOWING STMT IS - ! 12993: # MOV DNAME,XR . SUB WA,XR . BLO XR,DNAMP,ALOC2 . ! 12994: # MOV DNAMP,XR . ADD WA,XR ! 12995: # ! 12996: alloc: #prc # entry point ! 12997: # ! 12998: # COMMON EXIT POINT ! 12999: # ! 13000: aloc1: movl dnamp,r9 # point to next available loc ! 13001: addl2 r6,r9 # point past allocated block ! 13002: bvc 0f ! 13003: jmp aloc2 ! 13004: 0: ! 13005: cmpl r9,dname # jump if not enough room ! 13006: bgtru aloc2 ! 13007: movl r9,dnamp # store new pointer ! 13008: subl2 r6,r9 # point back to start of allocated bk ! 13009: rsb # return to caller ! 13010: # ! 13011: # HERE IF INSUFFICIENT ROOM, TRY A GARBAGE COLLECTION ! 13012: # ! 13013: aloc2: movl r7,allsv # save wb ! 13014: clrl r7 # set no upward move for gbcol ! 13015: jsb gbcol # garbage collect ! 13016: # ! 13017: # SEE IF ROOM AFTER GBCOL OR SYSMM CALL ! 13018: # ! 13019: aloc3: movl dnamp,r9 # point to first available loc ! 13020: addl2 r6,r9 # point past new block ! 13021: bvc 0f ! 13022: jmp alc3a ! 13023: 0: ! 13024: cmpl r9,dname # jump if there is room now ! 13025: blequ aloc4 ! 13026: # ! 13027: # FAILED AGAIN, SEE IF WE CAN GET MORE CORE ! 13028: # ! 13029: alc3a: jsb sysmm # try to get more memory ! 13030: moval 0[r9],r9 # convert to baus (sgd05) ! 13031: addl2 r9,dname # bump ptr by amount obtained ! 13032: tstl r9 # jump if got more core ! 13033: bnequ aloc3 ! 13034: addl2 rsmem,dname # get the reserve memory ! 13035: clrl rsmem # only permissible once ! 13036: incl errft # fatal error ! 13037: jmp er_204 # memory overflow ! 13038: #page ! 13039: # ! 13040: # HERE AFTER SUCCESSFUL GARBAGE COLLECTION ! 13041: # ! 13042: aloc4: movl r5,allia # save ia ! 13043: movl dname,r7 # get dynamic end adrs ! 13044: subl2 dnamp,r7 # compute free store ! 13045: ashl $-2,r7,r7 # convert bytes to words ! 13046: movl r7,r5 # put free store in ia ! 13047: mull2 alfsf,r5 # multiply by free store factor ! 13048: bvs aloc5 ! 13049: movl dname,r7 # dynamic end adrs ! 13050: subl2 dnamb,r7 # compute total amount of dynamic ! 13051: ashl $-2,r7,r7 # convert to words ! 13052: movl r7,aldyn # store it ! 13053: subl2 aldyn,r5 # subtract from scaled up free store ! 13054: tstl r5 # jump if sufficient free store ! 13055: bgtr aloc5 ! 13056: jsb sysmm # try to get more store ! 13057: moval 0[r9],r9 # convert to baus (sgd05) ! 13058: addl2 r9,dname # adjust dynamic end adrs ! 13059: # ! 13060: # MERGE TO RESTORE IA AND WB ! 13061: # ! 13062: aloc5: movl allia,r5 # recover ia ! 13063: movl allsv,r7 # restore wb ! 13064: jmp aloc1 # jump back to exit ! 13065: #enp # end procedure alloc ! 13066: #page ! 13067: # ! 13068: # ALOBF -- ALLOCATE BUFFER ! 13069: # ! 13070: # THIS ROUTINES ALLOCATES A NEW BUFFER. AS THE BFBLK ! 13071: # AND BCBLK COME IN PAIRS, BOTH ARE ALLOCATED HERE, ! 13072: # AND XR POINTS TO THE BCBLK ON RETURN. THE BFBLK ! 13073: # AND BCBLK ARE SET TO THE NULL BUFFER, AND THE IDVAL ! 13074: # IS ZERO ON RETURN. ! 13075: # ! 13076: # (WA) BUFFER SIZE IN CHARACTERS ! 13077: # JSR ALOBF CALL TO CREATE BUFFER ! 13078: # (XR) BCBLK PTR ! 13079: # (WA,WB) DESTROYED ! 13080: # ! 13081: alobf: #prc # entry point ! 13082: movl r6,r7 # hang onto allocation size ! 13083: movab 3+(4*bfsi$)(r6),r6 # get total block size ! 13084: bicl2 $3,r6 ! 13085: cmpl r6,mxlen # check for maxlen exceeded ! 13086: bgequ alb01 ! 13087: addl2 $4*bcsi$,r6 # add in allocation for bcblk ! 13088: jsb alloc # allocate frame ! 13089: movl $b$bct,(r9) # set type ! 13090: clrl 4*idval(r9) # no id yet ! 13091: clrl 4*bclen(r9) # no defined length ! 13092: movl r10,r6 # save xl ! 13093: movl r9,r10 # copy bcblk ptr ! 13094: addl2 $4*bcsi$,r10 # bias past partially built bcblk ! 13095: movl $b$bft,(r10) # set bfblk type word ! 13096: movl r7,4*bfalc(r10) # set allocated size ! 13097: movl r10,4*bcbuf(r9) # set pointer in bcblk ! 13098: clrl 4*bfchr(r10) # clear first word (null pad) ! 13099: movl r6,r10 # restore entry xl ! 13100: rsb # return to caller ! 13101: # ! 13102: # HERE FOR MXLEN EXCEEDED ! 13103: # ! 13104: alb01: jmp er_274 # requested buffer allocation exceeds mxlen ! 13105: #enp # end procedure alobf ! 13106: #page ! 13107: # ! 13108: # ALOCS -- ALLOCATE STRING BLOCK ! 13109: # ! 13110: # ALOCS IS USED TO BUILD A FRAME FOR A STRING BLOCK INTO ! 13111: # WHICH THE ACTUAL CHARACTERS ARE PLACED BY THE CALLER. ! 13112: # ALL STRINGS ARE CREATED WITH A CALL TO ALOCS (THE ! 13113: # EXCEPTIONS OCCUR IN TRIMR AND S$RPL PROCEDURES). ! 13114: # ! 13115: # (WA) LENGTH OF STRING TO BE ALLOCATED ! 13116: # JSR ALOCS CALL TO ALLOCATE SCBLK ! 13117: # (XR) POINTER TO RESULTING SCBLK ! 13118: # (WA) DESTROYED ! 13119: # (WC) CHARACTER COUNT (ENTRY VALUE OF WA) ! 13120: # ! 13121: # THE RESULTING SCBLK HAS THE TYPE WORD AND THE LENGTH ! 13122: # FILLED IN AND THE LAST WORD IS CLEARED TO ZERO CHARACTERS ! 13123: # TO ENSURE CORRECT RIGHT PADDING OF THE FINAL WORD. ! 13124: # ! 13125: alocs: #prc # entry point ! 13126: cmpl r6,kvmxl # jump if length exceeeds maxlength ! 13127: bgtru alcs2 ! 13128: movl r6,r8 # else copy length ! 13129: movab 3+(4*scsi$)(r6),r6 # compute length of scblk in bytes ! 13130: bicl2 $3,r6 ! 13131: movl dnamp,r9 # point to next available location ! 13132: addl2 r6,r9 # point past block ! 13133: bvc 0f ! 13134: jmp alcs0 ! 13135: 0: ! 13136: cmpl r9,dname # jump if there is room ! 13137: blequ alcs1 ! 13138: # ! 13139: # INSUFFICIENT MEMORY ! 13140: # ! 13141: alcs0: clrl r9 # else clear garbage xr value ! 13142: jsb alloc # and use standard allocator ! 13143: addl2 r6,r9 # point past end of block to merge ! 13144: # ! 13145: # MERGE HERE WITH XR POINTING BEYOND NEW BLOCK ! 13146: # ! 13147: alcs1: movl r9,dnamp # set updated storage pointer ! 13148: clrl -(r9) # store zero chars in last word ! 13149: subl2 $4,r6 # decrement length ! 13150: subl2 r6,r9 # point back to start of block ! 13151: movl $b$scl,(r9) # set type word ! 13152: movl r8,4*sclen(r9) # store length in chars ! 13153: rsb # return to alocs caller ! 13154: # ! 13155: # COME HERE IF STRING IS TOO LONG ! 13156: # ! 13157: alcs2: jmp er_205 # string length exceeds value of maxlngth keyword ! 13158: #enp # end procedure alocs ! 13159: #page ! 13160: # ! 13161: # ALOST -- ALLOCATE SPACE IN STATIC REGION ! 13162: # ! 13163: # (WA) LENGTH REQUIRED IN BYTES ! 13164: # JSR ALOST CALL TO ALLOCATE SPACE ! 13165: # (XR) POINTER TO ALLOCATED BLOCK ! 13166: # (WB) DESTROYED ! 13167: # ! 13168: # NOTE THAT THE CODING ENSURES THAT THE RESULTING VALUE ! 13169: # OF STATE IS ALWAYS LESS THAN DNAMB. THIS FACT IS USED ! 13170: # IN TESTING A VARIABLE NAME FOR BEING IN THE STATIC REGION ! 13171: # ! 13172: alost: #prc # entry point ! 13173: # ! 13174: # MERGE BACK HERE AFTER ALLOCATING NEW CHUNK ! 13175: # ! 13176: alst1: movl state,r9 # point to current end of area ! 13177: addl2 r6,r9 # point beyond proposed block ! 13178: bvc 0f ! 13179: jmp alst2 ! 13180: 0: ! 13181: cmpl r9,dnamb # jump if overlap with dynamic area ! 13182: bgequ alst2 ! 13183: movl r9,state # else store new pointer ! 13184: subl2 r6,r9 # point back to start of block ! 13185: rsb # return to alost caller ! 13186: # ! 13187: # HERE IF NO ROOM, PREPARE TO MOVE DYNAMIC STORAGE UP ! 13188: # ! 13189: alst2: movl r6,alsta # save wa ! 13190: cmpl r6,$4*e$sts # skip if requested chunk is large ! 13191: bgequ alst3 ! 13192: movl $4*e$sts,r6 # else set to get large enough chunk ! 13193: # ! 13194: # HERE WITH AMOUNT TO MOVE UP IN WA ! 13195: # ! 13196: alst3: jsb alloc # allocate block to ensure room ! 13197: movl r9,dnamp # and delete it ! 13198: movl r6,r7 # copy move up amount ! 13199: jsb gbcol # call gbcol to move dynamic area up ! 13200: movl alsta,r6 # restore wa ! 13201: jmp alst1 # loop back to try again ! 13202: #enp # end procedure alost ! 13203: #page ! 13204: # ! 13205: # APNDB -- APPEND STRING TO BUFFER ! 13206: # ! 13207: # THIS ROUTINE IS USED BY BUFFER HANDLING ROUTINES TO ! 13208: # APPEND DATA TO AN EXISTING BFBLK. ! 13209: # ! 13210: # (XR) EXISTING BCBLK TO BE APPENDED ! 13211: # (XL) CONVERTABLE TO STRING ! 13212: # JSR APNDB CALL TO APPEND TO BUFFER ! 13213: # PPM LOC THREAD IF (XL) CANT BE CONVERTED ! 13214: # PPM LOC IF NOT ENOUGH ROOM ! 13215: # (WA,WB) DESTROYED ! 13216: # ! 13217: # IF MORE CHARACTERS ARE SPECIFIED THAN CAN BE INSERTED, ! 13218: # THEN NO ACTION IS TAKEN AND THE SECOND RETURN IS TAKEN. ! 13219: # ! 13220: apndb: #prc # entry point ! 13221: movl 4*bclen(r9),r6 # load offset to insert ! 13222: clrl r7 # replace section is null ! 13223: jsb insbf # call to insert at end ! 13224: .long apn01 # convert error ! 13225: .long apn02 # no room ! 13226: addl2 $4*2,(sp) # return to caller ! 13227: rsb ! 13228: # ! 13229: # HERE TO TAKE CONVERT FAILURE EXIT ! 13230: # ! 13231: apn01: movl (sp)+,r11 # return to caller alternate ! 13232: jmp *(r11)+ ! 13233: # ! 13234: # HERE FOR NO FIT EXIT ! 13235: # ! 13236: apn02: addl3 $4*1,(sp)+,r11 # alternate exit to caller ! 13237: jmp *(r11)+ ! 13238: #enp # end procedure apndb ! 13239: #page ! 13240: # ! 13241: # ARITH -- FETCH ARITHMETIC OPERANDS ! 13242: # ! 13243: # ARITH IS USED BY FUNCTIONS AND OPERATORS WHICH EXPECT ! 13244: # TWO NUMERIC ARGUMENTS (OPERANDS) WHICH MUST BOTH BE ! 13245: # INTEGER OR BOTH BE REAL. ARITH FETCHES TWO ARGUMENTS FROM ! 13246: # THE STACK AND PERFORMS ANY NECESSARY CONVERSIONS. ! 13247: # ! 13248: # 1(XS) FIRST ARGUMENT (LEFT OPERAND) ! 13249: # 0(XS) SECOND ARGUMENT (RIGHT OPERAND) ! 13250: # JSR ARITH CALL TO FETCH NUMERIC ARGUMENTS ! 13251: # PPM LOC TRANSFER LOC FOR OPND 1 NON-NUMERIC ! 13252: # PPM LOC TRANSFER LOC FOR OPND 2 NON-NUMERIC ! 13253: # PPM LOC TRANSFER LOC FOR REAL OPERANDS ! 13254: # ! 13255: # FOR INTEGER ARGS, CONTROL RETURNS PAST THE PARAMETERS ! 13256: # ! 13257: # (IA) LEFT OPERAND VALUE ! 13258: # (XR) PTR TO ICBLK FOR LEFT OPERAND ! 13259: # (XL) PTR TO ICBLK FOR RIGHT OPERAND ! 13260: # (XS) POPPED TWICE ! 13261: # (WA,WB,RA) DESTROYED ! 13262: # ! 13263: # FOR REAL ARGUMENTS, CONTROL RETURNS TO THE LOCATION ! 13264: # SPECIFIED BY THE THIRD PARAMETER. ! 13265: # ! 13266: # (RA) LEFT OPERAND VALUE ! 13267: # (XR) PTR TO RCBLK FOR LEFT OPERAND ! 13268: # (XL) PTR TO RCBLK FOR RIGHT OPERAND ! 13269: # (WA,WB,WC) DESTROYED ! 13270: # (XS) POPPED TWICE ! 13271: #page ! 13272: # ! 13273: # ARITH (CONTINUED) ! 13274: # ! 13275: # ENTRY POINT ! 13276: # ! 13277: .data 1 ! 13278: arith_s: .long 0 ! 13279: .text 0 ! 13280: arith: movl (sp)+,arith_s # entry point ! 13281: movl (sp)+,r10 # load right operand ! 13282: movl (sp)+,r9 # load left operand ! 13283: movl (r10),r6 # get right operand type word ! 13284: cmpl r6,$b$icl # jump if integer ! 13285: beqlu arth1 ! 13286: cmpl r6,$b$rcl # jump if real ! 13287: beqlu arth4 ! 13288: movl r9,-(sp) # else replace left arg on stack ! 13289: movl r10,r9 # copy left arg pointer ! 13290: jsb gtnum # convert to numeric ! 13291: .long arth6 # jump if unconvertible ! 13292: movl r9,r10 # else copy converted result ! 13293: movl (r10),r6 # get right operand type word ! 13294: movl (sp)+,r9 # reload left argument ! 13295: cmpl r6,$b$rcl # jump if right arg is real ! 13296: beqlu arth4 ! 13297: # ! 13298: # HERE IF RIGHT ARG IS AN INTEGER ! 13299: # ! 13300: arth1: cmpl (r9),$b$icl # jump if left arg not integer ! 13301: bnequ arth3 ! 13302: # ! 13303: # EXIT FOR INTEGER CASE ! 13304: # ! 13305: arth2: movl 4*icval(r9),r5 # load left operand value ! 13306: addl3 $4*3,arith_s,r11 # return to arith caller ! 13307: jmp (r11) ! 13308: # ! 13309: # HERE FOR RIGHT OPERAND INTEGER, LEFT OPERAND NOT ! 13310: # ! 13311: arth3: jsb gtnum # convert left arg to numeric ! 13312: .long arth7 # jump if not convertible ! 13313: cmpl r6,$b$icl # jump back if integer-integer ! 13314: beqlu arth2 ! 13315: # ! 13316: # HERE WE MUST CONVERT REAL-INTEGER TO REAL-REAL ! 13317: # ! 13318: movl r9,-(sp) # put left arg back on stack ! 13319: movl 4*icval(r10),r5 # load right argument value ! 13320: cvtlf r5,r2 # convert to real ! 13321: jsb rcbld # get real block for right arg, merge ! 13322: movl r9,r10 # copy right arg ptr ! 13323: movl (sp)+,r9 # load left argument ! 13324: jmp arth5 # merge for real-real case ! 13325: #page ! 13326: # ! 13327: # ARITH (CONTINUED) ! 13328: # ! 13329: # HERE IF RIGHT ARGUMENT IS REAL ! 13330: # ! 13331: arth4: cmpl (r9),$b$rcl # jump if left arg real ! 13332: beqlu arth5 ! 13333: jsb gtrea # else convert to real ! 13334: .long arth7 # error if unconvertible ! 13335: # ! 13336: # HERE FOR REAL-REAL ! 13337: # ! 13338: arth5: movf 4*rcval(r9),r2 # load left operand value ! 13339: addl3 $4*2,arith_s,r11 # take real-real exit ! 13340: jmp *(r11)+ ! 13341: # ! 13342: # HERE FOR ERROR CONVERTING RIGHT ARGUMENT ! 13343: # ! 13344: arth6: addl2 $4,sp # pop unwanted left arg ! 13345: addl3 $4*1,arith_s,r11 # take appropriate error exit ! 13346: jmp *(r11)+ ! 13347: # ! 13348: # HERE FOR ERROR CONVERTING LEFT OPERAND ! 13349: # ! 13350: arth7: movl arith_s,r11 # take appropriate error return ! 13351: jmp *(r11)+ ! 13352: #enp # end procedure arith ! 13353: #page ! 13354: # ! 13355: # ASIGN -- PERFORM ASSIGNMENT ! 13356: # ! 13357: # ASIGN PERFORMS THE ASSIGNMENT OF A VALUE TO A VARIABLE ! 13358: # WITH APPROPRIATE CHECKS FOR OUTPUT ASSOCIATIONS AND ! 13359: # VALUE TRACE ASSOCIATIONS WHICH ARE EXECUTED AS REQUIRED. ! 13360: # ASIGN ALSO HANDLES THE SPECIAL CASES OF ASSIGNMENT TO ! 13361: # PATTERN AND EXPRESSION VARIABLES. ! 13362: # ! 13363: # (WB) VALUE TO BE ASSIGNED ! 13364: # (XL) BASE POINTER FOR VARIABLE ! 13365: # (WA) OFFSET FOR VARIABLE ! 13366: # JSR ASIGN CALL TO ASSIGN VALUE TO VARIABLE ! 13367: # PPM LOC TRANSFER LOC FOR FAILURE ! 13368: # (XR,XL,WA,WB,WC) DESTROYED ! 13369: # (RA) DESTROYED ! 13370: # ! 13371: # FAILURE OCCURS IF THE EVALUATION OF AN EXPRESSION ! 13372: # ASSOCIATED WITH AN EXPRESSION VARIABLE FAILS. ! 13373: # ! 13374: asign: #prc # entry point (recursive) ! 13375: # ! 13376: # MERGE BACK HERE TO ASSIGN RESULT TO EXPRESSION VARIABLE. ! 13377: # ! 13378: asg01: addl2 r6,r10 # point to variable value ! 13379: movl (r10),r9 # load variable value ! 13380: cmpl (r9),$b$trt # jump if trapped ! 13381: beqlu asg02 ! 13382: movl r7,(r10) # else perform assignment ! 13383: clrl r10 # clear garbage value in xl ! 13384: addl2 $4*1,(sp) # and return to asign caller ! 13385: rsb ! 13386: # ! 13387: # HERE IF VALUE IS TRAPPED ! 13388: # ! 13389: asg02: subl2 r6,r10 # restore name base ! 13390: cmpl r9,$trbkv # jump if keyword variable ! 13391: bnequ 0f ! 13392: jmp asg14 ! 13393: 0: ! 13394: cmpl r9,$trbev # jump if not expression variable ! 13395: bnequ asg04 ! 13396: # ! 13397: # HERE FOR ASSIGNMENT TO EXPRESSION VARIABLE ! 13398: # ! 13399: movl 4*evexp(r10),r9 # point to expression ! 13400: movl r7,-(sp) # store value to assign on stack ! 13401: movl $num01,r7 # set for evaluation by name ! 13402: jsb evalx # evaluate expression by name ! 13403: .long asg03 # jump if evaluation fails ! 13404: movl (sp)+,r7 # else reload value to assign ! 13405: jmp asg01 # loop back to perform assignment ! 13406: #page ! 13407: # ! 13408: # ASIGN (CONTINUED) ! 13409: # ! 13410: # HERE FOR FAILURE DURING EXPRESSION EVALUATION ! 13411: # ! 13412: asg03: addl2 $4,sp # remove stacked value entry ! 13413: movl (sp)+,r11 # take failure exit ! 13414: jmp *(r11)+ ! 13415: # ! 13416: # HERE IF NOT KEYWORD OR EXPRESSION VARIABLE ! 13417: # ! 13418: asg04: movl r9,-(sp) # save ptr to first trblk ! 13419: # ! 13420: # LOOP TO CHASE DOWN TRBLK CHAIN AND ASSIGN VALUE AT END ! 13421: # ! 13422: asg05: movl r9,r8 # save ptr to this trblk ! 13423: movl 4*trnxt(r9),r9 # point to next trblk ! 13424: cmpl (r9),$b$trt # loop back if another trblk ! 13425: beqlu asg05 ! 13426: movl r8,r9 # else point back to last trblk ! 13427: movl r7,4*trval(r9) # store value at end of chain ! 13428: movl (sp)+,r9 # restore ptr to first trblk ! 13429: # ! 13430: # LOOP TO PROCESS TRBLK ENTRIES ON CHAIN ! 13431: # ! 13432: asg06: movl 4*trtyp(r9),r7 # load type code of trblk ! 13433: cmpl r7,$trtvl # jump if value trace ! 13434: beqlu asg08 ! 13435: cmpl r7,$trtou # jump if output association ! 13436: beqlu asg10 ! 13437: # ! 13438: # HERE TO MOVE TO NEXT TRBLK ON CHAIN ! 13439: # ! 13440: asg07: movl 4*trnxt(r9),r9 # point to next trblk on chain ! 13441: cmpl (r9),$b$trt # loop back if another trblk ! 13442: beqlu asg06 ! 13443: addl2 $4*1,(sp) # else end of chain, return to caller ! 13444: rsb ! 13445: # ! 13446: # HERE TO PROCESS VALUE TRACE ! 13447: # ! 13448: asg08: tstl kvtra # ignore value trace if trace off ! 13449: beqlu asg07 ! 13450: decl kvtra # else decrement trace count ! 13451: tstl 4*trfnc(r9) # jump if print trace ! 13452: beqlu asg09 ! 13453: jsb trxeq # else execute function trace ! 13454: jmp asg07 # and loop back ! 13455: #page ! 13456: # ! 13457: # ASIGN (CONTINUED) ! 13458: # ! 13459: # HERE FOR PRINT TRACE ! 13460: # ! 13461: asg09: jsb prtsn # print statement number ! 13462: jsb prtnv # print name = value ! 13463: jmp asg07 # loop back for next trblk ! 13464: # ! 13465: # HERE FOR OUTPUT ASSOCIATION ! 13466: # ! 13467: asg10: tstl kvoup # ignore output assoc if output off ! 13468: beqlu asg07 ! 13469: movl r9,r10 # else copy trblk pointer ! 13470: movl 4*trval(r8),-(sp)# stack value to output (sgd01) ! 13471: jsb gtstg # convert to string ! 13472: .long asg12 # get datatype name if unconvertible ! 13473: # ! 13474: # MERGE WITH STRING FOR OUTPUT ! 13475: # ! 13476: asg11: movl 4*trfpt(r10),r6 # fcblk ptr ! 13477: tstl r6 # jump if standard output file ! 13478: beqlu asg13 ! 13479: # ! 13480: # HERE FOR OUTPUT TO NON-STANDARD OUTPUT FILE ! 13481: # ! 13482: jsb sysou # call system output routine ! 13483: .long er_206 # output caused file overflow ! 13484: .long er_207 # output caused non-recoverable error ! 13485: addl2 $4*1,(sp) # else all done, return to caller ! 13486: rsb ! 13487: # ! 13488: # IF NOT PRINTABLE, GET DATATYPE NAME INSTEAD ! 13489: # ! 13490: asg12: jsb dtype # call datatype routine ! 13491: jmp asg11 # merge ! 13492: # ! 13493: # HERE TO PRINT A STRING ON THE PRINTER ! 13494: # ! 13495: asg13: jsb prtst # print string value ! 13496: cmpl 4*trter(r10),$v$ter # jump if terminal output ! 13497: bnequ 0f ! 13498: jmp asg20 ! 13499: 0: ! 13500: jsb prtnl # end of line ! 13501: addl2 $4*1,(sp) # return to caller ! 13502: rsb ! 13503: #page ! 13504: # ! 13505: # ASIGN (CONTINUED) ! 13506: # ! 13507: # HERE FOR KEYWORD ASSIGNMENT ! 13508: # ! 13509: asg14: movl 4*kvnum(r10),r10# load keyword number ! 13510: cmpl r10,$k$etx # jump if errtext ! 13511: bnequ 0f ! 13512: jmp asg19 ! 13513: 0: ! 13514: movl r7,r9 # copy value to be assigned ! 13515: jsb gtint # convert to integer ! 13516: .long er_208 # keyword value assigned is not integer ! 13517: movl 4*icval(r9),r5 # else load value ! 13518: cmpl r10,$k$stl # jump if special case of stlimit ! 13519: beqlu asg16 ! 13520: movl r5,r6 # else get addr integer, test ovflow ! 13521: bgeq 0f ! 13522: jmp asg18 ! 13523: 0: ! 13524: cmpl r6,mxlen # fail if too large ! 13525: bgequ asg18 ! 13526: cmpl r10,$k$ert # jump if special case of errtype ! 13527: beqlu asg17 ! 13528: cmpl r10,$k$pfl # jump if special case of profile ! 13529: beqlu asg21 ! 13530: cmpl r10,$k$p$$ # jump unless protected ! 13531: blssu asg15 ! 13532: jmp er_209 # keyword in assignment is protected ! 13533: # ! 13534: # HERE TO DO ASSIGNMENT IF NOT PROTECTED ! 13535: # ! 13536: asg15: movl r6,l^kvabe(r10) # store new value ! 13537: addl2 $4*1,(sp) # return to asign caller ! 13538: rsb ! 13539: # ! 13540: # HERE FOR SPECIAL CASE OF STLIMIT ! 13541: # ! 13542: # SINCE STCOUNT IS MAINTAINED AS (STLIMIT-STCOUNT) ! 13543: # IT IS ALSO NECESSARY TO MODIFY STCOUNT APPROPRIATELY. ! 13544: # ! 13545: asg16: subl2 kvstl,r5 # subtract old limit ! 13546: addl2 kvstc,r5 # add old counter ! 13547: movl r5,kvstc # store new counter value ! 13548: movl 4*icval(r9),r5 # reload new limit value ! 13549: movl r5,kvstl # store new limit value ! 13550: addl2 $4*1,(sp) # return to asign caller ! 13551: rsb ! 13552: # ! 13553: # HERE FOR SPECIAL CASE OF ERRTYPE ! 13554: # ! 13555: asg17: cmpl r6,$nini9 # ok to signal if in range ! 13556: bgtru 0f ! 13557: jmp error ! 13558: 0: ! 13559: # ! 13560: # HERE IF VALUE ASSIGNED IS OUT OF RANGE ! 13561: # ! 13562: asg18: jmp er_210 # keyword value assigned is negative or too large ! 13563: # ! 13564: # HERE FOR SPECIAL CASE OF ERRTEXT ! 13565: # ! 13566: asg19: movl r7,-(sp) # stack value ! 13567: jsb gtstg # convert to string ! 13568: .long er_211 # value assigned to keyword errtext not a string ! 13569: movl r9,r$etx # make assignment ! 13570: addl2 $4*1,(sp) # return to caller ! 13571: rsb ! 13572: # ! 13573: # PRINT STRING TO TERMINAL ! 13574: # ! 13575: asg20: jsb prttr # print ! 13576: addl2 $4*1,(sp) # return ! 13577: rsb ! 13578: # ! 13579: # HERE FOR KEYWORD PROFILE ! 13580: # ! 13581: asg21: cmpl r6,$num02 # moan if not 0,1, or 2 ! 13582: bgtru asg18 ! 13583: tstl r6 # just assign if zero ! 13584: beqlu asg15 ! 13585: tstl pfdmp # branch if first assignment ! 13586: beqlu asg22 ! 13587: cmpl r6,pfdmp # also if same value as before ! 13588: beqlu asg23 ! 13589: jmp er_268 # inconsistent value assigned to keyword profile ! 13590: # ! 13591: asg22: movl r6,pfdmp # note value on first assignment ! 13592: asg23: jsb systm # get the time ! 13593: movl r5,pfstm # fudge some kind of start time ! 13594: jmp asg15 # and go assign ! 13595: #enp # end procedure asign ! 13596: #page ! 13597: # ! 13598: # ASINP -- ASSIGN DURING PATTERN MATCH ! 13599: # ! 13600: # ASINP IS LIKE ASIGN AND HAS A SIMILAR CALLING SEQUENCE ! 13601: # AND EFFECT. THE DIFFERENCE IS THAT THE GLOBAL PATTERN ! 13602: # VARIABLES ARE SAVED AND RESTORED IF REQUIRED. ! 13603: # ! 13604: # (XL) BASE POINTER FOR VARIABLE ! 13605: # (WA) OFFSET FOR VARIABLE ! 13606: # (WB) VALUE TO BE ASSIGNED ! 13607: # JSR ASINP CALL TO ASSIGN VALUE TO VARIABLE ! 13608: # PPM LOC TRANSFER LOC IF FAILURE ! 13609: # (XR,XL) DESTROYED ! 13610: # (WA,WB,WC,RA) DESTROYED ! 13611: # ! 13612: asinp: #prc # entry point, recursive ! 13613: addl2 r6,r10 # point to variable ! 13614: movl (r10),r9 # load current contents ! 13615: cmpl (r9),$b$trt # jump if trapped ! 13616: beqlu asnp1 ! 13617: movl r7,(r10) # else perform assignment ! 13618: clrl r10 # clear garbage value in xl ! 13619: addl2 $4*1,(sp) # return to asinp caller ! 13620: rsb ! 13621: # ! 13622: # HERE IF VARIABLE IS TRAPPED ! 13623: # ! 13624: asnp1: subl2 r6,r10 # restore base pointer ! 13625: movl pmssl,-(sp) # stack subject string length ! 13626: movl pmhbs,-(sp) # stack history stack base ptr ! 13627: movl r$pms,-(sp) # stack subject string pointer ! 13628: movl pmdfl,-(sp) # stack dot flag ! 13629: jsb asign # call full-blown assignment routine ! 13630: .long asnp2 # jump if failure ! 13631: movl (sp)+,pmdfl # restore dot flag ! 13632: movl (sp)+,r$pms # restore subject string pointer ! 13633: movl (sp)+,pmhbs # restore history stack base pointer ! 13634: movl (sp)+,pmssl # restore subject string length ! 13635: addl2 $4*1,(sp) # return to asinp caller ! 13636: rsb ! 13637: # ! 13638: # HERE IF FAILURE IN ASIGN CALL ! 13639: # ! 13640: asnp2: movl (sp)+,pmdfl # restore dot flag ! 13641: movl (sp)+,r$pms # restore subject string pointer ! 13642: movl (sp)+,pmhbs # restore history stack base pointer ! 13643: movl (sp)+,pmssl # restore subject string length ! 13644: movl (sp)+,r11 # take failure exit ! 13645: jmp *(r11)+ ! 13646: #enp # end procedure asinp ! 13647: #page ! 13648: # ! 13649: # BLKLN -- DETERMINE LENGTH OF BLOCK ! 13650: # ! 13651: # BLKLN DETERMINES THE LENGTH OF A BLOCK IN DYNAMIC STORE. ! 13652: # ! 13653: # (WA) FIRST WORD OF BLOCK ! 13654: # (XR) POINTER TO BLOCK ! 13655: # JSR BLKLN CALL TO GET BLOCK LENGTH ! 13656: # (WA) LENGTH OF BLOCK IN BYTES ! 13657: # (XL) DESTROYED ! 13658: # ! 13659: # BLKLN IS USED BY THE GARBAGE COLLECTOR AND IS NOT ! 13660: # PERMITTED TO CALL GBCOL DIRECTLY OR INDIRECTLY. ! 13661: # ! 13662: # THE FIRST WORD STORED IN THE BLOCK (I.E. AT XR) MAY ! 13663: # BE ANYTHING, BUT THE CONTENTS OF WA MUST BE CORRECT. ! 13664: # ! 13665: blkln: #prc # entry point ! 13666: movl r6,r10 # copy first word ! 13667: movzwl -2(r10),r10 # get entry id (bl$xx) ! 13668: casel r10,$0,$bl$$$ # switch on block type ! 13669: 5: ! 13670: .word bln01-5b # arblk ! 13671: .word bln04-5b # bcblk ! 13672: .word bln01-5b # cdblk ! 13673: .word bln01-5b # exblk ! 13674: .word bln07-5b # icblk ! 13675: .word bln03-5b # nmblk ! 13676: .word bln02-5b # p0blk ! 13677: .word bln03-5b # p1blk ! 13678: .word bln04-5b # p2blk ! 13679: .word bln09-5b # rcblk ! 13680: .word bln10-5b # scblk ! 13681: .word bln02-5b # seblk ! 13682: .word bln01-5b # tbblk ! 13683: .word bln01-5b # vcblk ! 13684: .word bln00-5b ! 13685: .word bln00-5b ! 13686: .word bln08-5b # pdblk ! 13687: .word bln05-5b # trblk ! 13688: .word bln11-5b # bfblk ! 13689: .word bln00-5b ! 13690: .word bln00-5b ! 13691: .word bln06-5b # ctblk ! 13692: .word bln01-5b # dfblk ! 13693: .word bln01-5b # efblk ! 13694: .word bln03-5b # evblk ! 13695: .word bln05-5b # ffblk ! 13696: .word bln03-5b # kvblk ! 13697: .word bln01-5b # pfblk ! 13698: .word bln04-5b # teblk ! 13699: #esw # end of jump table on block type ! 13700: #page ! 13701: # ! 13702: # BLKLN (CONTINUED) ! 13703: # ! 13704: # HERE FOR BLOCKS WITH LENGTH IN SECOND WORD ! 13705: # ! 13706: bln00: movl 4*1(r9),r6 # load length ! 13707: rsb # return to blkln caller ! 13708: # ! 13709: # HERE FOR LENGTH IN THIRD WORD (AR,CD,DF,EF,EX,PF,TB,VC) ! 13710: # ! 13711: bln01: movl 4*2(r9),r6 # load length from third word ! 13712: rsb # return to blkln caller ! 13713: # ! 13714: # HERE FOR TWO WORD BLOCKS (P0,SE) ! 13715: # ! 13716: bln02: movl $4*num02,r6 # load length (two words) ! 13717: rsb # return to blkln caller ! 13718: # ! 13719: # HERE FOR THREE WORD BLOCKS (NM,P1,EV,KV) ! 13720: # ! 13721: bln03: movl $4*num03,r6 # load length (three words) ! 13722: rsb # return to blkln caller ! 13723: # ! 13724: # HERE FOR FOUR WORD BLOCKS (P2,TE,BC) ! 13725: # ! 13726: bln04: movl $4*num04,r6 # load length (four words) ! 13727: rsb # return to blkln caller ! 13728: # ! 13729: # HERE FOR FIVE WORD BLOCKS (FF,TR) ! 13730: # ! 13731: bln05: movl $4*num05,r6 # load length ! 13732: rsb # return to blkln caller ! 13733: #page ! 13734: # ! 13735: # BLKLN (CONTINUED) ! 13736: # ! 13737: # HERE FOR CTBLK ! 13738: # ! 13739: bln06: movl $4*ctsi$,r6 # set size of ctblk ! 13740: rsb # return to blkln caller ! 13741: # ! 13742: # HERE FOR ICBLK ! 13743: # ! 13744: bln07: movl $4*icsi$,r6 # set size of icblk ! 13745: rsb # return to blkln caller ! 13746: # ! 13747: # HERE FOR PDBLK ! 13748: # ! 13749: bln08: movl 4*pddfp(r9),r10 # point to dfblk ! 13750: movl 4*dfpdl(r10),r6 # load pdblk length from dfblk ! 13751: rsb # return to blkln caller ! 13752: # ! 13753: # HERE FOR RCBLK ! 13754: # ! 13755: bln09: movl $4*rcsi$,r6 # set size of rcblk ! 13756: rsb # return to blkln caller ! 13757: # ! 13758: # HERE FOR SCBLK ! 13759: # ! 13760: bln10: movl 4*sclen(r9),r6 # load length in characters ! 13761: movab 3+(4*scsi$)(r6),r6 # calculate length in bytes ! 13762: bicl2 $3,r6 ! 13763: rsb # return to blkln caller ! 13764: # ! 13765: # HERE FOR BFBLK ! 13766: # ! 13767: bln11: movl 4*bfalc(r9),r6 # get allocation in bytes ! 13768: movab 3+(4*bfsi$)(r6),r6 # calculate length in bytes ! 13769: bicl2 $3,r6 ! 13770: rsb # return to blkln caller ! 13771: #enp # end procedure blkln ! 13772: #page ! 13773: # ! 13774: # COPYB -- COPY A BLOCK ! 13775: # ! 13776: # (XS) BLOCK TO BE COPIED ! 13777: # JSR COPYB CALL TO COPY BLOCK ! 13778: # PPM LOC RETURN IF BLOCK HAS NO IDVAL FIELD ! 13779: # NORMAL RETURN IF IDVAL FIELD ! 13780: # (XR) COPY OF BLOCK ! 13781: # (XS) POPPED ! 13782: # (XL,WA,WB,WC) DESTROYED ! 13783: # ! 13784: .data 1 ! 13785: copyb_s: .long 0 ! 13786: .text 0 ! 13787: copyb: movl (sp)+,copyb_s # entry point ! 13788: movl (sp),r9 # load argument ! 13789: cmpl r9,$nulls # return argument if it is null ! 13790: bnequ 0f ! 13791: jmp cop10 ! 13792: 0: ! 13793: movl (r9),r6 # else load type word ! 13794: movl r6,r7 # copy type word ! 13795: jsb blkln # get length of argument block ! 13796: movl r9,r10 # copy pointer ! 13797: jsb alloc # allocate block of same size ! 13798: movl r9,(sp) # store pointer to copy ! 13799: jsb sbmvw # copy contents of old block to new ! 13800: movl (sp),r9 # reload pointer to start of copy ! 13801: cmpl r7,$b$tbt # jump if table ! 13802: beqlu cop05 ! 13803: cmpl r7,$b$vct # jump if vector ! 13804: beqlu cop01 ! 13805: cmpl r7,$b$pdt # jump if program defined ! 13806: beqlu cop01 ! 13807: cmpl r7,$b$bct # jump if buffer ! 13808: bnequ 0f ! 13809: jmp cop11 ! 13810: 0: ! 13811: cmpl r7,$b$art # return copy if not array ! 13812: beqlu 0f ! 13813: jmp cop10 ! 13814: 0: ! 13815: # ! 13816: # HERE FOR ARRAY (ARBLK) ! 13817: # ! 13818: addl2 4*arofs(r9),r9 # point to prototype field ! 13819: jmp cop02 # jump to merge ! 13820: # ! 13821: # HERE FOR VECTOR, PROGRAM DEFINED ! 13822: # ! 13823: cop01: addl2 $4*pdfld,r9 # point to pdfld = vcvls ! 13824: # ! 13825: # MERGE HERE FOR ARBLK, VCBLK, PDBLK TO DELETE TRAP ! 13826: # BLOCKS FROM ALL VALUE FIELDS (THE COPY IS UNTRAPPED) ! 13827: # ! 13828: cop02: movl (r9),r10 # load next pointer ! 13829: # ! 13830: # LOOP TO GET VALUE AT END OF TRBLK CHAIN ! 13831: # ! 13832: cop03: cmpl (r10),$b$trt # jump if not trapped ! 13833: bnequ cop04 ! 13834: movl 4*trval(r10),r10# else point to next value ! 13835: jmp cop03 # and loop back ! 13836: #page ! 13837: # ! 13838: # COPYB (CONTINUED) ! 13839: # ! 13840: # HERE WITH UNTRAPPED VALUE IN XL ! 13841: # ! 13842: cop04: movl r10,(r9)+ # store real value, bump pointer ! 13843: cmpl r9,dnamp # loop back if more to go ! 13844: bnequ cop02 ! 13845: jmp cop09 # else jump to exit ! 13846: # ! 13847: # HERE TO COPY A TABLE ! 13848: # ! 13849: cop05: clrl 4*idval(r9) # zero id to stop dump blowing up ! 13850: movl $4*tesi$,r6 # set size of teblk ! 13851: movl $4*tbbuk,r8 # set initial offset ! 13852: # ! 13853: # LOOP THROUGH BUCKETS IN TABLE ! 13854: # ! 13855: cop06: movl (sp),r9 # load table pointer ! 13856: cmpl r8,4*tblen(r9) # jump to exit if all done ! 13857: beqlu cop09 ! 13858: addl2 r8,r9 # else point to next bucket header ! 13859: addl2 $4,r8 # bump offset ! 13860: subl2 $4*tenxt,r9 # subtract link offset to merge ! 13861: # ! 13862: # LOOP THROUGH TEBLKS ON ONE CHAIN ! 13863: # ! 13864: cop07: movl 4*tenxt(r9),r10 # load pointer to next teblk ! 13865: movl (sp),4*tenxt(r9)# set end of chain pointer in case ! 13866: cmpl (r10),$b$tbt # back for next bucket if chain end ! 13867: beqlu cop06 ! 13868: movl r9,-(sp) # else stack ptr to previous block ! 13869: movl $4*tesi$,r6 # set size of teblk ! 13870: jsb alloc # allocate new teblk ! 13871: movl r9,r7 # save ptr to new teblk ! 13872: jsb sbmvw # copy old teblk to new teblk ! 13873: movl r7,r9 # restore pointer to new teblk ! 13874: movl (sp)+,r10 # restore pointer to previous block ! 13875: movl r9,4*tenxt(r10) # link new block to previous ! 13876: movl r9,r10 # copy pointer to new block ! 13877: # ! 13878: # LOOP TO SET REAL VALUE AFTER REMOVING TRAP CHAIN ! 13879: # ! 13880: cop08: movl 4*teval(r10),r10# load value ! 13881: cmpl (r10),$b$trt # loop back if trapped ! 13882: beqlu cop08 ! 13883: movl r10,4*teval(r9) # store untrapped value in teblk ! 13884: jmp cop07 # back for next teblk ! 13885: # ! 13886: # COMMON EXIT POINT ! 13887: # ! 13888: cop09: movl (sp)+,r9 # load pointer to block ! 13889: addl3 $4*1,copyb_s,r11 # return ! 13890: jmp (r11) ! 13891: # ! 13892: # ALTERNATIVE RETURN ! 13893: # ! 13894: cop10: movl copyb_s,r11 # return ! 13895: jmp *(r11)+ ! 13896: #page ! 13897: # ! 13898: # HERE TO COPY BUFFER ! 13899: # ! 13900: cop11: movl 4*bcbuf(r9),r10 # get bfblk ptr ! 13901: movl 4*bfalc(r10),r6 # get allocation ! 13902: movab 3+(4*bfsi$)(r6),r6 # set total size ! 13903: bicl2 $3,r6 ! 13904: movl r9,r10 # save bcblk ptr ! 13905: jsb alloc # allocate bfblk ! 13906: movl 4*bcbuf(r10),r7 # get old bfblk ! 13907: movl r9,4*bcbuf(r10) # set pointer to new bfblk ! 13908: movl r7,r10 # point to old bfblk ! 13909: jsb sbmvw # copy bfblk too ! 13910: clrl r10 # clear rubbish ptr ! 13911: jmp cop09 # branch to exit ! 13912: #enp # end procedure copyb ! 13913: # ! 13914: # CDGCG -- GENERATE CODE FOR COMPLEX GOTO ! 13915: # ! 13916: # USED BY CMPIL TO PROCESS COMPLEX GOTO TREE ! 13917: # ! 13918: # (WB) MUST BE COLLECTABLE ! 13919: # (XR) EXPRESSION POINTER ! 13920: # JSR CDGCG CALL TO GENERATE COMPLEX GOTO ! 13921: # (XL,XR,WA) DESTROYED ! 13922: # ! 13923: cdgcg: #prc # entry point ! 13924: movl 4*cmopn(r9),r10 # get unary goto operator ! 13925: movl 4*cmrop(r9),r9 # point to goto operand ! 13926: cmpl r10,$opdvd # jump if direct goto ! 13927: beqlu cdgc2 ! 13928: jsb cdgnm # generate opnd by name if not direct ! 13929: # ! 13930: # RETURN POINT ! 13931: # ! 13932: cdgc1: movl r10,r6 # goto operator ! 13933: jsb cdwrd # generate it ! 13934: rsb # return to caller ! 13935: # ! 13936: # DIRECT GOTO ! 13937: # ! 13938: cdgc2: jsb cdgvl # generate operand by value ! 13939: jmp cdgc1 # merge to return ! 13940: #enp # end procedure cdgcg ! 13941: #page ! 13942: # ! 13943: # CDGEX -- BUILD EXPRESSION BLOCK ! 13944: # ! 13945: # CDGEX IS PASSED A POINTER TO AN EXPRESSION TREE (SEE ! 13946: # EXPAN) AND RETURNS AN EXPRESSION (SEBLK OR EXBLK). ! 13947: # ! 13948: # (WC) SOME COLLECTABLE VALUE ! 13949: # (WB) INTEGER IN RANGE 0 LE X LE MXLEN ! 13950: # (XL) PTR TO EXPRESSION TREE ! 13951: # JSR CDGEX CALL TO BUILD EXPRESSION ! 13952: # (XR) PTR TO SEBLK OR EXBLK ! 13953: # (XL,WA,WB) DESTROYED ! 13954: # ! 13955: cdgex: #prc # entry point, recursive ! 13956: cmpl (r10),$b$vr$ # jump if not variable ! 13957: blequ cdgx1 ! 13958: # ! 13959: # HERE FOR NATURAL VARIABLE, BUILD SEBLK ! 13960: # ! 13961: movl $4*sesi$,r6 # set size of seblk ! 13962: jsb alloc # allocate space for seblk ! 13963: movl $b$sel,(r9) # set type word ! 13964: movl r10,4*sevar(r9) # store vrblk pointer ! 13965: rsb # return to cdgex caller ! 13966: # ! 13967: # HERE IF NOT VARIABLE, BUILD EXBLK ! 13968: # ! 13969: cdgx1: movl r10,r9 # copy tree pointer ! 13970: movl r8,-(sp) # save wc ! 13971: movl cwcof,r10 # save current offset ! 13972: movl (r9),r6 # get type word ! 13973: cmpl r6,$b$cmt # call by value if not cmblk ! 13974: bnequ cdgx2 ! 13975: cmpl 4*cmtyp(r9),$c$$nm # jump if cmblk only by value ! 13976: bgequ cdgx2 ! 13977: #page ! 13978: # ! 13979: # CDGEX (CONTINUED) ! 13980: # ! 13981: # HERE IF EXPRESSION CAN BE EVALUATED BY NAME ! 13982: # ! 13983: jsb cdgnm # generate code by name ! 13984: movl $ornm$,r6 # load return by name word ! 13985: jmp cdgx3 # merge with value case ! 13986: # ! 13987: # HERE IF EXPRESSION CAN ONLY BE EVALUATED BY VALUE ! 13988: # ! 13989: cdgx2: jsb cdgvl # generate code by value ! 13990: movl $orvl$,r6 # load return by value word ! 13991: # ! 13992: # MERGE HERE TO CONSTRUCT EXBLK ! 13993: # ! 13994: cdgx3: jsb cdwrd # generate return word ! 13995: jsb exbld # build exblk ! 13996: movl (sp)+,r8 # restore wc ! 13997: rsb # return to cdgex caller ! 13998: #enp # end procedure cdgex ! 13999: #page ! 14000: # ! 14001: # CDGNM -- GENERATE CODE BY NAME ! 14002: # ! 14003: # CDGNM IS CALLED DURING THE COMPILATION PROCESS TO ! 14004: # GENERATE CODE BY NAME FOR AN EXPRESSION. SEE CDBLK ! 14005: # DESCRIPTION FOR DETAILS OF CODE GENERATED. THE INPUT ! 14006: # TO CDGNM IS AN EXPRESSION TREE AS GENERATED BY EXPAN. ! 14007: # ! 14008: # CDGNM IS A RECURSIVE PROCEDURE WHICH PROCEEDS BY MAKING ! 14009: # RECURSIVE CALLS TO GENERATE CODE FOR OPERANDS. ! 14010: # ! 14011: # (WB) INTEGER IN RANGE 0 LE N LE DNAMB ! 14012: # (XR) PTR TO TREE GENERATED BY EXPAN ! 14013: # (WC) CONSTANT FLAG (SEE BELOW) ! 14014: # JSR CDGNM CALL TO GENERATE CODE BY NAME ! 14015: # (XR,WA) DESTROYED ! 14016: # (WC) SET NON-ZERO IF NON-CONSTANT ! 14017: # ! 14018: # WC IS SET TO A NON-ZERO (COLLECTABLE) VALUE IF THE ! 14019: # EXPRESSION FOR WHICH CODE IS GENERATED CANNOT BE ! 14020: # EVALUATED AT COMPILE TIME, OTHERWISE WC IS UNCHANGED. ! 14021: # ! 14022: # THE CODE IS GENERATED IN THE CURRENT CCBLK (SEE CDWRD). ! 14023: # ! 14024: cdgnm: #prc # entry point, recursive ! 14025: movl r10,-(sp) # save entry xl ! 14026: movl r7,-(sp) # save entry wb ! 14027: jsb sbchk # check for stack overflow ! 14028: movl (r9),r6 # load type word ! 14029: cmpl r6,$b$cmt # jump if cmblk ! 14030: beqlu cgn04 ! 14031: cmpl r6,$b$vr$ # jump if simple variable ! 14032: blssu 0f ! 14033: jmp cgn02 ! 14034: 0: ! 14035: # ! 14036: # MERGE HERE FOR OPERAND YIELDING VALUE (E.G. CONSTANT) ! 14037: # ! 14038: cgn01: jmp er_212 # syntax error. value used where name is required ! 14039: # ! 14040: # HERE FOR NATURAL VARIABLE REFERENCE ! 14041: # ! 14042: cgn02: movl $olvn$,r6 # load variable load call ! 14043: jsb cdwrd # generate it ! 14044: movl r9,r6 # copy vrblk pointer ! 14045: jsb cdwrd # generate vrblk pointer ! 14046: #page ! 14047: # ! 14048: # CDGNM (CONTINUED) ! 14049: # ! 14050: # HERE TO EXIT WITH WC SET CORRECTLY ! 14051: # ! 14052: cgn03: movl (sp)+,r7 # restore entry wb ! 14053: movl (sp)+,r10 # restore entry xl ! 14054: rsb # return to cdgnm caller ! 14055: # ! 14056: # HERE FOR CMBLK ! 14057: # ! 14058: cgn04: movl r9,r10 # copy cmblk pointer ! 14059: movl 4*cmtyp(r9),r9 # load cmblk type ! 14060: cmpl r9,$c$$nm # error if not name operand ! 14061: bgequ cgn01 ! 14062: casel r9,$0,$c$$nm # else switch on type ! 14063: 5: ! 14064: .word cgn05-5b # array reference ! 14065: .word cgn08-5b # function call ! 14066: .word cgn09-5b # deferred expression ! 14067: .word cgn10-5b # indirect reference ! 14068: .word cgn11-5b # keyword reference ! 14069: .word cgn08-5b # undefined binary op ! 14070: .word cgn08-5b # undefined unary op ! 14071: #esw # end switch on cmblk type ! 14072: # ! 14073: # HERE TO GENERATE CODE FOR ARRAY REFERENCE ! 14074: # ! 14075: cgn05: movl $4*cmopn,r7 # point to array operand ! 14076: # ! 14077: # LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS ! 14078: # ! 14079: cgn06: jsb cmgen # generate code for next operand ! 14080: movl 4*cmlen(r10),r8 # load length of cmblk ! 14081: cmpl r7,r8 # loop till all generated ! 14082: blssu cgn06 ! 14083: # ! 14084: # GENERATE APPROPRIATE ARRAY CALL ! 14085: # ! 14086: movl $oaon$,r6 # load one-subscript case call ! 14087: cmpl r8,$4*cmar1 # jump to exit if one subscript case ! 14088: beqlu cgn07 ! 14089: movl $oamn$,r6 # else load multi-subscript case call ! 14090: jsb cdwrd # generate call ! 14091: movl r8,r6 # copy cmblk length ! 14092: ashl $-2,r6,r6 # convert to words ! 14093: subl2 $cmvls,r6 # calculate number of subscripts ! 14094: #page ! 14095: # ! 14096: # CDGNM (CONTINUED) ! 14097: # ! 14098: # HERE TO EXIT GENERATING WORD (NON-CONSTANT) ! 14099: # ! 14100: cgn07: movl sp,r8 # set result non-constant ! 14101: jsb cdwrd # generate word ! 14102: jmp cgn03 # back to exit ! 14103: # ! 14104: # HERE TO GENERATE CODE FOR FUNCTIONS AND UNDEFINED OPRS ! 14105: # ! 14106: cgn08: movl r10,r9 # copy cmblk pointer ! 14107: jsb cdgvl # gen code by value for call ! 14108: movl $ofne$,r6 # get extra call for by name ! 14109: jmp cgn07 # back to generate and exit ! 14110: # ! 14111: # HERE TO GENERATE CODE FOR DEFERED EXPRESSION ! 14112: # ! 14113: cgn09: movl 4*cmrop(r10),r9 # check if variable ! 14114: cmpl (r9),$b$vr$ # treat *variable as simple var ! 14115: blssu 0f ! 14116: jmp cgn02 ! 14117: 0: ! 14118: movl r9,r10 # copy ptr to expression tree ! 14119: jsb cdgex # else build exblk ! 14120: movl $olex$,r6 # set call to load expr by name ! 14121: jsb cdwrd # generate it ! 14122: movl r9,r6 # copy exblk pointer ! 14123: jsb cdwrd # generate exblk pointer ! 14124: jmp cgn03 # back to exit ! 14125: # ! 14126: # HERE TO GENERATE CODE FOR INDIRECT REFERENCE ! 14127: # ! 14128: cgn10: movl 4*cmrop(r10),r9 # get operand ! 14129: jsb cdgvl # generate code by value for it ! 14130: movl $oinn$,r6 # load call for indirect by name ! 14131: jmp cgn12 # merge ! 14132: # ! 14133: # HERE TO GENERATE CODE FOR KEYWORD REFERENCE ! 14134: # ! 14135: cgn11: movl 4*cmrop(r10),r9 # get operand ! 14136: jsb cdgnm # generate code by name for it ! 14137: movl $okwn$,r6 # load call for keyword by name ! 14138: # ! 14139: # KEYWORD, INDIRECT MERGE HERE ! 14140: # ! 14141: cgn12: jsb cdwrd # generate code for operator ! 14142: jmp cgn03 # exit ! 14143: #enp # end procedure cdgnm ! 14144: #page ! 14145: # ! 14146: # CDGVL -- GENERATE CODE BY VALUE ! 14147: # ! 14148: # CDGVL IS CALLED DURING THE COMPILATION PROCESS TO ! 14149: # GENERATE CODE BY VALUE FOR AN EXPRESSION. SEE CDBLK ! 14150: # DESCRIPTION FOR DETAILS OF THE CODE GENERATED. THE INPUT ! 14151: # TO CDGVL IS AN EXPRESSION TREE AS GENERATED BY EXPAN. ! 14152: # ! 14153: # CDGVL IS A RECURSIVE PROCEDURE WHICH PROCEEDS BY MAKING ! 14154: # RECURSIVE CALLS TO GENERATE CODE FOR OPERANDS. ! 14155: # ! 14156: # (WB) INTEGER IN RANGE 0 LE N LE DNAMB ! 14157: # (XR) PTR TO TREE GENERATED BY EXPAN ! 14158: # (WC) CONSTANT FLAG (SEE BELOW) ! 14159: # JSR CDGVL CALL TO GENERATE CODE BY VALUE ! 14160: # (XR,WA) DESTROYED ! 14161: # (WC) SET NON-ZERO IF NON-CONSTANT ! 14162: # ! 14163: # WC IS SET TO A NON-ZERO (COLLECTABLE) VALUE IF THE ! 14164: # EXPRESSION FOR WHICH CODE IS GENERATED CANNOT BE ! 14165: # EVALUATED AT COMPILE TIME, OTHERWISE WC IS UNCHANGED. ! 14166: # ! 14167: # IF WC IS NON-ZERO ON ENTRY, THEN PREEVALUATION IS NOT ! 14168: # ALLOWED REGARDLESS OF THE NATURE OF THE OPERAND. ! 14169: # ! 14170: # THE CODE IS GENERATED IN THE CURRENT CCBLK (SEE CDWRD). ! 14171: # ! 14172: cdgvl: #prc # entry point, recursive ! 14173: movl (r9),r6 # load type word ! 14174: cmpl r6,$b$cmt # jump if cmblk ! 14175: beqlu cgv01 ! 14176: cmpl r6,$b$vra # jump if icblk, rcblk, scblk ! 14177: blssu cgv00 ! 14178: tstl 4*vrlen(r9) # jump if not system variable ! 14179: bnequ cgvl0 ! 14180: movl r9,-(sp) # stack xr ! 14181: movl 4*vrsvp(r9),r9 # point to svblk ! 14182: movl 4*svbit(r9),r6 # get svblk property bits ! 14183: movl (sp)+,r9 # recover xr ! 14184: mcoml btckw,r11 # check if constant keyword ! 14185: bicl2 r11,r6 ! 14186: tstl r6 # jump if constant keyword ! 14187: bnequ cgv00 ! 14188: # ! 14189: # HERE FOR VARIABLE VALUE REFERENCE ! 14190: # ! 14191: cgvl0: movl sp,r8 # indicate non-constant value ! 14192: # ! 14193: # MERGE HERE FOR SIMPLE CONSTANT (ICBLK,RCBLK,SCBLK) ! 14194: # AND FOR VARIABLES CORRESPONDING TO CONSTANT KEYWORDS. ! 14195: # ! 14196: cgv00: movl r9,r6 # copy ptr to var or constant ! 14197: jsb cdwrd # generate as code word ! 14198: rsb # return to caller ! 14199: #page ! 14200: # ! 14201: # CDGVL (CONTINUED) ! 14202: # ! 14203: # HERE FOR TREE NODE (CMBLK) ! 14204: # ! 14205: cgv01: movl r7,-(sp) # save entry wb ! 14206: movl r10,-(sp) # save entry xl ! 14207: movl r8,-(sp) # save entry constant flag ! 14208: movl cwcof,-(sp) # save initial code offset ! 14209: jsb sbchk # check for stack overflow ! 14210: # ! 14211: # PREPARE TO GENERATE CODE FOR CMBLK. WC IS SET TO THE ! 14212: # VALUE OF CSWNO (ZERO IF -OPTIMISE, 1 IF -NOOPT) TO ! 14213: # START WITH AND IS RESET NON-ZERO FOR ANY NON-CONSTANT ! 14214: # CODE GENERATED. IF IT IS STILL ZERO AFTER GENERATING ALL ! 14215: # THE CMBLK CODE, THEN ITS VALUE IS COMPUTED AS THE RESULT. ! 14216: # ! 14217: movl r9,r10 # copy cmblk pointer ! 14218: movl 4*cmtyp(r9),r9 # load cmblk type ! 14219: movl cswno,r8 # reset constant flag ! 14220: cmpl r9,$c$pr$ # jump if not predicate value ! 14221: blequ cgv02 ! 14222: movl sp,r8 # else force non-constant case ! 14223: # ! 14224: # HERE WITH WC SET APPROPRIATELY ! 14225: # ! 14226: cgv02: casel r9,$0,$c$$nv # switch to appropriate generator ! 14227: 5: ! 14228: .word cgv03-5b # array reference ! 14229: .word cgv05-5b # function call ! 14230: .word cgv14-5b # deferred expression ! 14231: .word cgv31-5b # indirect reference ! 14232: .word cgv27-5b # keyword reference ! 14233: .word cgv29-5b # undefined binop ! 14234: .word cgv30-5b # undefined unop ! 14235: .word cgv18-5b # binops with val opds ! 14236: .word cgv19-5b # unops with valu opnd ! 14237: .word cgv18-5b # alternation ! 14238: .word cgv24-5b # concatenation ! 14239: .word cgv24-5b # concatenation (not pattern match) ! 14240: .word cgv27-5b # unops with name opnd ! 14241: .word cgv26-5b # binary $ and . ! 14242: .word cgv21-5b # assignment ! 14243: .word cgv31-5b # interrogation ! 14244: .word cgv28-5b # negation ! 14245: .word cgv15-5b # selection ! 14246: .word cgv18-5b # pattern match ! 14247: #esw # end switch on cmblk type ! 14248: #page ! 14249: # ! 14250: # CDGVL (CONTINUED) ! 14251: # ! 14252: # HERE TO GENERATE CODE FOR ARRAY REFERENCE ! 14253: # ! 14254: cgv03: movl $4*cmopn,r7 # set offset to array operand ! 14255: # ! 14256: # LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS ! 14257: # ! 14258: cgv04: jsb cmgen # gen value code for next operand ! 14259: movl 4*cmlen(r10),r8 # load cmblk length ! 14260: cmpl r7,r8 # loop back if more to go ! 14261: blssu cgv04 ! 14262: # ! 14263: # GENERATE CALL TO APPROPRIATE ARRAY REFERENCE ROUTINE ! 14264: # ! 14265: movl $oaov$,r6 # set one subscript call in case ! 14266: cmpl r8,$4*cmar1 # jump to exit if 1-sub case ! 14267: bnequ 0f ! 14268: jmp cgv32 ! 14269: 0: ! 14270: movl $oamv$,r6 # else set call for multi-subscripts ! 14271: jsb cdwrd # generate call ! 14272: movl r8,r6 # copy length of cmblk ! 14273: subl2 $4*cmvls,r6 # subtract standard length ! 14274: ashl $-2,r6,r6 # get number of words ! 14275: jmp cgv32 # jump to generate subscript count ! 14276: # ! 14277: # HERE TO GENERATE CODE FOR FUNCTION CALL ! 14278: # ! 14279: cgv05: movl $4*cmvls,r7 # set offset to first argument ! 14280: # ! 14281: # LOOP TO GENERATE CODE FOR ARGUMENTS ! 14282: # ! 14283: cgv06: cmpl r7,4*cmlen(r10) # jump if all generated ! 14284: beqlu cgv07 ! 14285: jsb cmgen # else gen value code for next arg ! 14286: jmp cgv06 # back to generate next argument ! 14287: # ! 14288: # HERE TO GENERATE ACTUAL FUNCTION CALL ! 14289: # ! 14290: cgv07: subl2 $4*cmvls,r7 # get number of arg ptrs (bytes) ! 14291: ashl $-2,r7,r7 # convert bytes to words ! 14292: movl 4*cmopn(r10),r9 # load function vrblk pointer ! 14293: tstl 4*vrlen(r9) # jump if not system function ! 14294: bnequ cgv12 ! 14295: movl 4*vrsvp(r9),r10 # load svblk ptr if system var ! 14296: movl 4*svbit(r10),r6 # load bit mask ! 14297: mcoml btffc,r11 # test for fast function call allowed ! 14298: bicl2 r11,r6 ! 14299: tstl r6 # jump if not ! 14300: beqlu cgv12 ! 14301: #page ! 14302: # ! 14303: # CDGVL (CONTINUED) ! 14304: # ! 14305: # HERE IF FAST FUNCTION CALL IS ALLOWED ! 14306: # ! 14307: movl 4*svbit(r10),r6 # reload bit indicators ! 14308: mcoml btpre,r11 # test for preevaluation ok ! 14309: bicl2 r11,r6 ! 14310: tstl r6 # jump if preevaluation permitted ! 14311: bnequ cgv08 ! 14312: movl sp,r8 # else set result non-constant ! 14313: # ! 14314: # TEST FOR CORRECT NUMBER OF ARGS FOR FAST CALL ! 14315: # ! 14316: cgv08: movl 4*vrfnc(r9),r10 # load ptr to svfnc field ! 14317: movl 4*fargs(r10),r6 # load svnar field value ! 14318: cmpl r6,r7 # jump if argument count is correct ! 14319: beqlu cgv11 ! 14320: cmpl r6,r7 # jump if too few arguments given ! 14321: bgequ cgv09 ! 14322: # ! 14323: # HERE IF TOO MANY ARGUMENTS, PREPARE TO GENERATE O$POPS ! 14324: # ! 14325: subl2 r6,r7 # get number of extra args ! 14326: # set as count to control loop ! 14327: movl $opop$,r6 # set pop call ! 14328: jmp cgv10 # jump to common loop ! 14329: # ! 14330: # HERE IF TOO FEW ARGUMENTS, PREPARE TO GENERATE NULLS ! 14331: # ! 14332: cgv09: subl2 r7,r6 # get number of missing arguments ! 14333: movl r6,r7 # load as count to control loop ! 14334: movl $nulls,r6 # load ptr to null constant ! 14335: # ! 14336: # LOOP TO GENERATE CALLS TO FIX ARGUMENT COUNT ! 14337: # ! 14338: cgv10: jsb cdwrd # generate one call ! 14339: sobgtr r7,cgv10 # loop till all generated ! 14340: # ! 14341: # HERE AFTER ADJUSTING ARG COUNT AS REQUIRED ! 14342: # ! 14343: cgv11: movl r10,r6 # copy pointer to svfnc field ! 14344: jmp cgv36 # jump to generate call ! 14345: #page ! 14346: # ! 14347: # CDGVL (CONTINUED) ! 14348: # ! 14349: # COME HERE IF FAST CALL IS NOT PERMITTED ! 14350: # ! 14351: cgv12: movl $ofns$,r6 # set one arg call in case ! 14352: cmpl r7,$num01 # jump if one arg case ! 14353: beqlu cgv13 ! 14354: movl $ofnc$,r6 # else load call for more than 1 arg ! 14355: jsb cdwrd # generate it ! 14356: movl r7,r6 # copy argument count ! 14357: # ! 14358: # ONE ARG CASE MERGES HERE ! 14359: # ! 14360: cgv13: jsb cdwrd # generate =o$fns or arg count ! 14361: movl r9,r6 # copy vrblk pointer ! 14362: jmp cgv32 # jump to generate vrblk ptr ! 14363: # ! 14364: # HERE FOR DEFERRED EXPRESSION ! 14365: # ! 14366: cgv14: movl 4*cmrop(r10),r10# point to expression tree ! 14367: jsb cdgex # build exblk or seblk ! 14368: movl r9,r6 # copy block ptr ! 14369: jsb cdwrd # generate ptr to exblk or seblk ! 14370: jmp cgv34 # jump to exit, constant test ! 14371: # ! 14372: # HERE TO GENERATE CODE FOR SELECTION ! 14373: # ! 14374: cgv15: clrl -(sp) # zero ptr to chain of forward jumps ! 14375: clrl -(sp) # zero ptr to prev o$slc forward ptr ! 14376: movl $4*cmvls,r7 # point to first alternative ! 14377: movl $osla$,r6 # set initial code word ! 14378: # ! 14379: # 0(XS) IS THE OFFSET TO THE PREVIOUS WORD ! 14380: # WHICH REQUIRES FILLING IN WITH AN ! 14381: # OFFSET TO THE FOLLOWING O$SLC,O$SLD ! 14382: # ! 14383: # 1(XS) IS THE HEAD OF A CHAIN OF OFFSET ! 14384: # POINTERS INDICATING THOSE LOCATIONS ! 14385: # TO BE FILLED WITH OFFSETS PAST ! 14386: # THE END OF ALL THE ALTERNATIVES ! 14387: # ! 14388: cgv16: jsb cdwrd # generate o$slc (o$sla first time) ! 14389: movl cwcof,(sp) # set current loc as ptr to fill in ! 14390: jsb cdwrd # generate garbage word there for now ! 14391: jsb cmgen # gen value code for alternative ! 14392: movl $oslb$,r6 # load o$slb pointer ! 14393: jsb cdwrd # generate o$slb call ! 14394: movl 4*1(sp),r6 # load old chain ptr ! 14395: movl cwcof,4*1(sp) # set current loc as new chain head ! 14396: jsb cdwrd # generate forward chain link ! 14397: #page ! 14398: # ! 14399: # CDGVL (CONTINUED) ! 14400: # ! 14401: # NOW TO FILL IN THE SKIP OFFSET TO O$SLC,O$SLD ! 14402: # ! 14403: movl (sp),r9 # load offset to word to plug ! 14404: addl2 r$ccb,r9 # point to actual location to plug ! 14405: movl cwcof,(r9) # plug proper offset in ! 14406: movl $oslc$,r6 # load o$slc ptr for next alternative ! 14407: movl r7,r9 # copy offset (destroy garbage xr) ! 14408: addl2 $4,r9 # bump extra time for test ! 14409: cmpl r9,4*cmlen(r10) # loop back if not last alternative ! 14410: blssu cgv16 ! 14411: # ! 14412: # HERE TO GENERATE CODE FOR LAST ALTERNATIVE ! 14413: # ! 14414: movl $osld$,r6 # get header call ! 14415: jsb cdwrd # generate o$sld call ! 14416: jsb cmgen # generate code for last alternative ! 14417: addl2 $4,sp # pop offset ptr ! 14418: movl (sp)+,r9 # load chain ptr ! 14419: # ! 14420: # LOOP TO PLUG OFFSETS PAST STRUCTURE ! 14421: # ! 14422: cgv17: addl2 r$ccb,r9 # make next ptr absolute ! 14423: movl (r9),r6 # load forward ptr ! 14424: movl cwcof,(r9) # plug required offset ! 14425: movl r6,r9 # copy forward ptr ! 14426: tstl r6 # loop back if more to go ! 14427: bnequ cgv17 ! 14428: jmp cgv33 # else jump to exit (not constant) ! 14429: # ! 14430: # HERE FOR BINARY OPS WITH VALUE OPERANDS ! 14431: # ! 14432: cgv18: movl 4*cmlop(r10),r9 # load left operand pointer ! 14433: jsb cdgvl # gen value code for left operand ! 14434: # ! 14435: # HERE FOR UNARY OPS WITH VALUE OPERAND (BINOPS MERGE) ! 14436: # ! 14437: cgv19: movl 4*cmrop(r10),r9 # load right (only) operand ptr ! 14438: jsb cdgvl # gen code by value ! 14439: #page ! 14440: # ! 14441: # CDGVL (CONTINUED) ! 14442: # ! 14443: # MERGE HERE TO GENERATE OPERATOR CALL FROM CMOPN FIELD ! 14444: # ! 14445: cgv20: movl 4*cmopn(r10),r6 # load operator call pointer ! 14446: jmp cgv36 # jump to generate it with cons test ! 14447: # ! 14448: # HERE FOR ASSIGNMENT ! 14449: # ! 14450: cgv21: movl 4*cmlop(r10),r9 # load left operand pointer ! 14451: cmpl (r9),$b$vr$ # jump if not variable ! 14452: blequ cgv22 ! 14453: # ! 14454: # HERE FOR ASSIGNMENT TO SIMPLE VARIABLE ! 14455: # ! 14456: movl 4*cmrop(r10),r9 # load right operand ptr ! 14457: jsb cdgvl # generate code by value ! 14458: movl 4*cmlop(r10),r6 # reload left operand vrblk ptr ! 14459: addl2 $4*vrsto,r6 # point to vrsto field ! 14460: jmp cgv32 # jump to generate store ptr ! 14461: # ! 14462: # HERE IF NOT SIMPLE VARIABLE ASSIGNMENT ! 14463: # ! 14464: cgv22: jsb expap # test for pattern match on left side ! 14465: .long cgv23 # jump if not pattern match ! 14466: # ! 14467: # HERE FOR PATTERN REPLACEMENT ! 14468: # ! 14469: movl 4*cmrop(r9),4*cmlop(r10) # save pattern ptr in safe place ! 14470: movl 4*cmlop(r9),r9 # load subject ptr ! 14471: jsb cdgnm # gen code by name for subject ! 14472: movl 4*cmlop(r10),r9 # load pattern ptr ! 14473: jsb cdgvl # gen code by value for pattern ! 14474: movl $opmn$,r6 # load match by name call ! 14475: jsb cdwrd # generate it ! 14476: movl 4*cmrop(r10),r9 # load replacement value ptr ! 14477: jsb cdgvl # gen code by value ! 14478: movl $orpl$,r6 # load replace call ! 14479: jmp cgv32 # jump to gen and exit (not constant) ! 14480: # ! 14481: # HERE FOR ASSIGNMENT TO COMPLEX VARIABLE ! 14482: # ! 14483: cgv23: movl sp,r8 # inhibit pre-evaluation ! 14484: jsb cdgnm # gen code by name for left side ! 14485: jmp cgv31 # merge with unop circuit ! 14486: #page ! 14487: # ! 14488: # CDGVL (CONTINUED) ! 14489: # ! 14490: # HERE FOR CONCATENATION ! 14491: # ! 14492: cgv24: movl 4*cmlop(r10),r9 # load left operand ptr ! 14493: cmpl (r9),$b$cmt # ordinary binop if not cmblk ! 14494: beqlu 0f ! 14495: jmp cgv18 ! 14496: 0: ! 14497: movl 4*cmtyp(r9),r7 # load cmblk type code ! 14498: cmpl r7,$c$int # special case if interrogation ! 14499: beqlu cgv25 ! 14500: cmpl r7,$c$neg # or negation ! 14501: beqlu cgv25 ! 14502: cmpl r7,$c$fnc # else ordinary binop if not function ! 14503: beqlu 0f ! 14504: jmp cgv18 ! 14505: 0: ! 14506: movl 4*cmopn(r9),r9 # else load function vrblk ptr ! 14507: tstl 4*vrlen(r9) # ordinary binop if not system var ! 14508: beqlu 0f ! 14509: jmp cgv18 ! 14510: 0: ! 14511: movl 4*vrsvp(r9),r9 # else point to svblk ! 14512: movl 4*svbit(r9),r6 # load bit indicators ! 14513: mcoml btprd,r11 # test for predicate function ! 14514: bicl2 r11,r6 ! 14515: tstl r6 # ordinary binop if not ! 14516: bnequ 0f ! 14517: jmp cgv18 ! 14518: 0: ! 14519: # ! 14520: # HERE IF LEFT ARG OF CONCATENATION IS PREDICATE FUNCTION ! 14521: # ! 14522: cgv25: movl 4*cmlop(r10),r9 # reload left arg ! 14523: jsb cdgvl # gen code by value ! 14524: movl $opop$,r6 # load pop call ! 14525: jsb cdwrd # generate it ! 14526: movl 4*cmrop(r10),r9 # load right operand ! 14527: jsb cdgvl # gen code by value as result code ! 14528: jmp cgv33 # exit (not constant) ! 14529: # ! 14530: # HERE TO GENERATE CODE FOR PATTERN, IMMEDIATE ASSIGNMENT ! 14531: # ! 14532: cgv26: movl 4*cmlop(r10),r9 # load left operand ! 14533: jsb cdgvl # gen code by value, merge ! 14534: # ! 14535: # HERE FOR UNOPS WITH ARG BY NAME (BINARY $ . MERGE) ! 14536: # ! 14537: cgv27: movl 4*cmrop(r10),r9 # load right operand ptr ! 14538: jsb cdgnm # gen code by name for right arg ! 14539: movl 4*cmopn(r10),r9 # get operator code word ! 14540: cmpl (r9),$o$kwv # gen call unless keyword value ! 14541: beqlu 0f ! 14542: jmp cgv20 ! 14543: 0: ! 14544: #page ! 14545: # ! 14546: # CDGVL (CONTINUED) ! 14547: # ! 14548: # HERE FOR KEYWORD BY VALUE. THIS IS CONSTANT ONLY IF ! 14549: # THE OPERAND IS ONE OF THE SPECIAL SYSTEM VARIABLES WITH ! 14550: # THE SVCKW BIT SET TO INDICATE A CONSTANT KEYWORD VALUE. ! 14551: # NOTE THAT THE ONLY CONSTANT OPERAND BY NAME IS A VARIABLE ! 14552: # ! 14553: tstl r8 # gen call if non-constant (not var) ! 14554: beqlu 0f ! 14555: jmp cgv20 ! 14556: 0: ! 14557: movl sp,r8 # else set non-constant in case ! 14558: movl 4*cmrop(r10),r9 # load ptr to operand vrblk ! 14559: tstl 4*vrlen(r9) # gen (non-constant) if not sys var ! 14560: beqlu 0f ! 14561: jmp cgv20 ! 14562: 0: ! 14563: movl 4*vrsvp(r9),r9 # else load ptr to svblk ! 14564: movl 4*svbit(r9),r6 # load bit mask ! 14565: mcoml btckw,r11 # test for constant keyword ! 14566: bicl2 r11,r6 ! 14567: tstl r6 # go gen if not constant ! 14568: bnequ 0f ! 14569: jmp cgv20 ! 14570: 0: ! 14571: clrl r8 # else set result constant ! 14572: jmp cgv20 # and jump back to generate call ! 14573: # ! 14574: # HERE TO GENERATE CODE FOR NEGATION ! 14575: # ! 14576: cgv28: movl $onta$,r6 # get initial word ! 14577: jsb cdwrd # generate it ! 14578: movl cwcof,r7 # save next offset ! 14579: jsb cdwrd # generate gunk word for now ! 14580: movl 4*cmrop(r10),r9 # load right operand ptr ! 14581: jsb cdgvl # gen code by value ! 14582: movl $ontb$,r6 # load end of evaluation call ! 14583: jsb cdwrd # generate it ! 14584: movl r7,r9 # copy offset to word to plug ! 14585: addl2 r$ccb,r9 # point to actual word to plug ! 14586: movl cwcof,(r9) # plug word with current offset ! 14587: movl $ontc$,r6 # load final call ! 14588: jmp cgv32 # jump to generate it (not constant) ! 14589: # ! 14590: # HERE TO GENERATE CODE FOR UNDEFINED BINARY OPERATOR ! 14591: # ! 14592: cgv29: movl 4*cmlop(r10),r9 # load left operand ptr ! 14593: jsb cdgvl # generate code by value ! 14594: #page ! 14595: # ! 14596: # CDGVL (CONTINUED) ! 14597: # ! 14598: # HERE TO GENERATE CODE FOR UNDEFINED UNARY OPERATOR ! 14599: # ! 14600: cgv30: movl $c$uo$,r7 # set unop code + 1 ! 14601: subl2 4*cmtyp(r10),r7 # set number of args (1 or 2) ! 14602: # ! 14603: # MERGE HERE FOR UNDEFINED OPERATORS ! 14604: # ! 14605: movl 4*cmrop(r10),r9 # load right (only) operand pointer ! 14606: jsb cdgvl # gen value code for right operand ! 14607: movl 4*cmopn(r10),r9 # load pointer to operator dv ! 14608: movl 4*dvopn(r9),r9 # load pointer offset ! 14609: moval 0[r9],r9 # convert word offset to bytes ! 14610: addl2 $r$uba,r9 # point to proper function ptr ! 14611: subl2 $4*vrfnc,r9 # set standard function offset ! 14612: jmp cgv12 # merge with function call circuit ! 14613: # ! 14614: # HERE TO GENERATE CODE FOR INTERROGATION, INDIRECTION ! 14615: # ! 14616: cgv31: movl sp,r8 # set non constant ! 14617: jmp cgv19 # merge ! 14618: # ! 14619: # HERE TO EXIT GENERATING A WORD, RESULT NOT CONSTANT ! 14620: # ! 14621: cgv32: jsb cdwrd # generate word, merge ! 14622: # ! 14623: # HERE TO EXIT WITH NO WORD GENERATED, NOT CONSTANT ! 14624: # ! 14625: cgv33: movl sp,r8 # indicate result is not constant ! 14626: # ! 14627: # COMMON EXIT POINT ! 14628: # ! 14629: cgv34: addl2 $4,sp # pop initial code offset ! 14630: movl (sp)+,r6 # restore old constant flag ! 14631: movl (sp)+,r10 # restore entry xl ! 14632: movl (sp)+,r7 # restore entry wb ! 14633: tstl r8 # jump if not constant ! 14634: bnequ cgv35 ! 14635: movl r6,r8 # else restore entry constant flag ! 14636: # ! 14637: # HERE TO RETURN AFTER DEALING WITH WC SETTING ! 14638: # ! 14639: cgv35: rsb # return to cdgvl caller ! 14640: # ! 14641: # EXIT HERE TO GENERATE WORD AND TEST FOR CONSTANT ! 14642: # ! 14643: cgv36: jsb cdwrd # generate word ! 14644: tstl r8 # jump to exit if not constant ! 14645: bnequ cgv34 ! 14646: #page ! 14647: # ! 14648: # CDGVL (CONTINUED) ! 14649: # ! 14650: # HERE TO PREEVALUATE CONSTANT SUB-EXPRESSION ! 14651: # ! 14652: movl $orvl$,r6 # load call to return value ! 14653: jsb cdwrd # generate it ! 14654: movl (sp),r10 # load initial code offset ! 14655: jsb exbld # build exblk for expression ! 14656: clrl r7 # set to evaluate by value ! 14657: jsb evalx # evaluate expression ! 14658: .long invalid$ # should not fail ! 14659: movl (r9),r6 # load type word of result ! 14660: cmpl r6,$p$aaa # jump if not pattern ! 14661: blequ cgv37 ! 14662: movl $olpt$,r6 # else load special pattern load call ! 14663: jsb cdwrd # generate it ! 14664: # ! 14665: # MERGE HERE TO GENERATE POINTER TO RESULTING CONSTANT ! 14666: # ! 14667: cgv37: movl r9,r6 # copy constant pointer ! 14668: jsb cdwrd # generate ptr ! 14669: clrl r8 # set result constant ! 14670: jmp cgv34 # jump back to exit ! 14671: #enp # end procedure cdgvl ! 14672: #page ! 14673: # ! 14674: # CDWRD -- GENERATE ONE WORD OF CODE ! 14675: # ! 14676: # CDWRD WRITES ONE WORD INTO THE CURRENT CODE BLOCK UNDER ! 14677: # CONSTRUCTION. A NEW, LARGER, BLOCK IS ALLOCATED IF THERE ! 14678: # IS INSUFFICIENT ROOM IN THE CURRENT BLOCK. CDWRD ENSURES ! 14679: # THAT THERE ARE AT LEAST THREE WORDS LEFT IN THE BLOCK ! 14680: # AFTER ENTERING THE NEW WORD. THIS GUARANTEES THAT ANY ! 14681: # EXTRA SPACE AT THE END CAN BE SPLIT OFF AS A CCBLK. ! 14682: # ! 14683: # (WA) WORD TO BE GENERATED ! 14684: # JSR CDWRD CALL TO GENERATE WORD ! 14685: # ! 14686: cdwrd: #prc # entry point ! 14687: movl r9,-(sp) # save entry xr ! 14688: movl r6,-(sp) # save code word to be generated ! 14689: # ! 14690: # MERGE BACK HERE AFTER ALLOCATING LARGER BLOCK ! 14691: # ! 14692: cdwd1: movl r$ccb,r9 # load ptr to ccblk being built ! 14693: tstl r9 # jump if block allocated ! 14694: bnequ cdwd2 ! 14695: # ! 14696: # HERE WE ALLOCATE AN ENTIRELY FRESH BLOCK ! 14697: # ! 14698: movl $4*e$cbs,r6 # load initial length ! 14699: jsb alloc # allocate ccblk ! 14700: movl $b$cct,(r9) # store type word ! 14701: movl $4*cccod,cwcof # set initial offset ! 14702: movl r6,4*cclen(r9) # store block length ! 14703: movl r9,r$ccb # store ptr to new block ! 14704: # ! 14705: # HERE WE HAVE A BLOCK WE CAN USE ! 14706: # ! 14707: cdwd2: movl cwcof,r6 # load current offset ! 14708: addl2 $4*num04,r6 # adjust for test (four words) ! 14709: cmpl r6,4*cclen(r9) # jump if room in this block ! 14710: bgtru 0f ! 14711: jmp cdwd4 ! 14712: 0: ! 14713: # ! 14714: # HERE IF NO ROOM IN CURRENT BLOCK ! 14715: # ! 14716: cmpl r6,mxlen # jump if already at max size ! 14717: blssu 0f ! 14718: jmp cdwd5 ! 14719: 0: ! 14720: addl2 $4*e$cbs,r6 # else get new size ! 14721: movl r10,-(sp) # save entry xl ! 14722: movl r9,r10 # copy pointer ! 14723: cmpl r6,mxlen # jump if not too large ! 14724: blssu cdwd3 ! 14725: movl mxlen,r6 # else reset to max allowed size ! 14726: #page ! 14727: # ! 14728: # CDWRD (CONTINUED) ! 14729: # ! 14730: # HERE WITH NEW BLOCK SIZE IN WA ! 14731: # ! 14732: cdwd3: jsb alloc # allocate new block ! 14733: movl r9,r$ccb # store pointer to new block ! 14734: movl $b$cct,(r9)+ # store type word in new block ! 14735: movl r6,(r9)+ # store block length ! 14736: addl2 $4*ccuse,r10 # point to ccuse,cccod fields in old ! 14737: movl (r10),r6 # load ccuse value ! 14738: jsb sbmvw # copy useful words from old block ! 14739: movl (sp)+,r10 # restore xl ! 14740: jmp cdwd1 # merge back to try again ! 14741: # ! 14742: # HERE WITH ROOM IN CURRENT BLOCK ! 14743: # ! 14744: cdwd4: movl cwcof,r6 # load current offset ! 14745: addl2 $4,r6 # get new offset ! 14746: movl r6,cwcof # store new offset ! 14747: movl r6,4*ccuse(r9) # store in ccblk for gbcol ! 14748: subl2 $4,r6 # restore ptr to this word ! 14749: addl2 r6,r9 # point to current entry ! 14750: movl (sp)+,r6 # reload word to generate ! 14751: movl r6,(r9) # store word in block ! 14752: movl (sp)+,r9 # restore entry xr ! 14753: rsb # return to caller ! 14754: # ! 14755: # HERE IF COMPILED CODE IS TOO LONG FOR CDBLK ! 14756: # ! 14757: cdwd5: jmp er_213 # syntax error. statement is too complicated. ! 14758: #enp # end procedure cdwrd ! 14759: #page ! 14760: # ! 14761: # CMGEN -- GENERATE CODE FOR CMBLK PTR ! 14762: # ! 14763: # CMGEN IS A SUBSIDIARY PROCEDURE USED TO GENERATE VALUE ! 14764: # CODE FOR A CMBLK PTR FROM THE MAIN CODE GENERATORS. ! 14765: # ! 14766: # (XL) CMBLK POINTER ! 14767: # (WB) OFFSET TO POINTER IN CMBLK ! 14768: # JSR CMGEN CALL TO GENERATE CODE ! 14769: # (XR,WA) DESTROYED ! 14770: # (WB) BUMPED BY ONE WORD ! 14771: # ! 14772: cmgen: #prc # entry point, recursive ! 14773: movl r10,r9 # copy cmblk pointer ! 14774: addl2 r7,r9 # point to cmblk pointer ! 14775: movl (r9),r9 # load cmblk pointer ! 14776: jsb cdgvl # generate code by value ! 14777: addl2 $4,r7 # bump offset ! 14778: rsb # return to caller ! 14779: #enp # end procedure cmgen ! 14780: #page ! 14781: # ! 14782: # CMPIL (COMPILE SOURCE CODE) ! 14783: # ! 14784: # CMPIL IS USED TO CONVERT SNOBOL4 SOURCE CODE TO INTERNAL ! 14785: # FORM (SEE CDBLK FORMAT). IT IS USED BOTH FOR THE INITIAL ! 14786: # COMPILE AND AT RUN TIME BY THE CODE AND CONVERT FUNCTIONS ! 14787: # THIS PROCEDURE HAS CONTROL FOR THE ENTIRE DURATION OF ! 14788: # INITIAL COMPILATION. AN ERROR IN ANY PROCEDURE CALLED ! 14789: # DURING COMPILATION WILL LEAD FIRST TO THE ERROR SECTION ! 14790: # AND ULTIMATELY BACK HERE FOR RESUMED COMPILATION. THE ! 14791: # RE-ENTRY POINTS AFTER AN ERROR ARE SPECIALLY LABELLED - ! 14792: # ! 14793: # CMPCE RESUME AFTER CONTROL CARD ERROR ! 14794: # CMPLE RESUME AFTER LABEL ERROR ! 14795: # CMPSE RESUME AFTER STATEMENT ERROR ! 14796: # ! 14797: # JSR CMPIL CALL TO COMPILE CODE ! 14798: # (XR) PTR TO CDBLK FOR ENTRY STATEMENT ! 14799: # (XL,WA,WB,WC,RA) DESTROYED ! 14800: # ! 14801: # THE FOLLOWING GLOBAL VARIABLES ARE REFERENCED ! 14802: # ! 14803: # CMPSN NUMBER OF NEXT STATEMENT ! 14804: # TO BE COMPILED. ! 14805: # ! 14806: # CSWXX CONTROL CARD SWITCH VALUES ARE ! 14807: # CHANGED WHEN RELEVANT CONTROL ! 14808: # CARDS ARE MET. ! 14809: # ! 14810: # CWCOF OFFSET TO NEXT WORD IN CODE BLOCK ! 14811: # BEING BUILT (SEE CDWRD). ! 14812: # ! 14813: # LSTSN NUMBER OF STATEMENT MOST RECENTLY ! 14814: # COMPILED (INITIALLY SET TO ZERO). ! 14815: # ! 14816: # R$CIM CURRENT (INITIAL) COMPILER IMAGE ! 14817: # (ZERO FOR INITIAL COMPILE CALL) ! 14818: # ! 14819: # R$CNI USED TO POINT TO FOLLOWING IMAGE. ! 14820: # (SEE READR PROCEDURE). ! 14821: # ! 14822: # SCNGO GOTO SWITCH FOR SCANE PROCEDURE ! 14823: # ! 14824: # SCNIL LENGTH OF CURRENT IMAGE EXCLUDING ! 14825: # CHARACTERS REMOVED BY -INPUT. ! 14826: # ! 14827: # SCNPT CURRENT SCAN OFFSET, SEE SCANE. ! 14828: # ! 14829: # SCNRS RESCAN SWITCH FOR SCANE PROCEDURE. ! 14830: # ! 14831: # SCNSE OFFSET (IN R$CIM) OF MOST RECENTLY ! 14832: # SCANNED ELEMENT. SET ZERO IF NOT ! 14833: # CURRENTLY SCANNING ITEMS ! 14834: #page ! 14835: # ! 14836: # CMPIL (CONTINUED) ! 14837: # ! 14838: # STAGE STGIC INITIAL COMPILE IN PROGRESS ! 14839: # STGXC CODE/CONVERT COMPILE ! 14840: # STGEV BUILDING EXBLK FOR EVAL ! 14841: # STGXT EXECUTE TIME (OUTSIDE COMPILE) ! 14842: # STGCE INITIAL COMPILE AFTER END LINE ! 14843: # STGXE EXECUTE COMPILE AFTER END LINE ! 14844: # ! 14845: # CMPIL ALSO USES A FIXED NUMBER OF LOCATIONS ON THE ! 14846: # MAIN STACK AS FOLLOWS. (THE DEFINITIONS OF THE ACTUAL ! 14847: # OFFSETS ARE IN THE DEFINITIONS SECTION). ! 14848: # ! 14849: # CMSTM(XS) POINTER TO EXPAN TREE FOR BODY OF ! 14850: # STATEMENT (SEE EXPAN PROCEDURE). ! 14851: # ! 14852: # CMSGO(XS) POINTER TO TREE REPRESENTATION OF ! 14853: # SUCCESS GOTO (SEE PROCEDURE SCNGO)9 ! 14854: # ZERO IF NO SUCCESS GOTO IS GIVEN ! 14855: # ! 14856: # CMFGO(XS) LIKE CMSGO FOR FAILURE GOTO. ! 14857: # ! 14858: # CMCGO(XS) SET NON-ZERO ONLY IF THERE IS A ! 14859: # CONDITIONAL GOTO. USED FOR -FAIL, ! 14860: # -NOFAIL CODE GENERATION. ! 14861: # ! 14862: # CMPCD(XS) POINTER TO CDBLK FOR PREVIOUS ! 14863: # STATEMENT. ZERO FOR 1ST STATEMENT. ! 14864: # ! 14865: # CMFFP(XS) SET NON-ZERO IF CDFAL IN PREVIOUS ! 14866: # CDBLK NEEDS FILLING WITH FORWARD ! 14867: # POINTER, ELSE SET TO ZERO. ! 14868: # ! 14869: # CMFFC(XS) SAME AS CMFFP FOR CURRENT CDBLK ! 14870: # ! 14871: # CMSOP(XS) OFFSET TO WORD IN PREVIOUS CDBLK ! 14872: # TO BE FILLED IN WITH FORWARD PTR ! 14873: # TO NEXT CDBLK FOR SUCCESS GOTO. ! 14874: # ZERO IF NO FILL IN IS REQUIRED. ! 14875: # ! 14876: # CMSOC(XS) SAME AS CMSOP FOR CURRENT CDBLK. ! 14877: # ! 14878: # CMLBL(XS) POINTER TO VRBLK FOR LABEL OF ! 14879: # CURRENT STATEMENT. ZERO IF NO LABEL ! 14880: # ! 14881: # CMTRA(XS) POINTER TO CDBLK FOR ENTRY STMNT. ! 14882: #page ! 14883: # ! 14884: # CMPIL (CONTINUED) ! 14885: # ! 14886: # ENTRY POINT ! 14887: # ! 14888: cmpil: #prc # entry point ! 14889: movl $cmnen,r7 # set number of stack work locations ! 14890: # ! 14891: # LOOP TO INITIALIZE STACK WORKING LOCATIONS ! 14892: # ! 14893: cmp00: clrl -(sp) # store a zero, make one entry ! 14894: sobgtr r7,cmp00 # loop back until all set ! 14895: movl sp,cmpxs # save stack pointer for error sec ! 14896: #sss cmpss # save s-r stack pointer if any ! 14897: # ! 14898: # LOOP THROUGH STATEMENTS ! 14899: # ! 14900: cmp01: movl scnpt,r7 # set scan pointer offset ! 14901: movl r7,scnse # set start of element location ! 14902: movl $ocer$,r6 # point to compile error call ! 14903: jsb cdwrd # generate as temporary cdfal ! 14904: cmpl r7,scnil # jump if chars left on this image ! 14905: blssu cmp04 ! 14906: # ! 14907: # LOOP HERE AFTER COMMENT OR CONTROL CARD ! 14908: # ALSO SPECIAL ENTRY AFTER CONTROL CARD ERROR ! 14909: # ! 14910: cmpce: clrl r9 # clear possible garbage xr value ! 14911: cmpl stage,$stgic # skip unless initial compile ! 14912: bnequ cmp02 ! 14913: jsb readr # read next input image ! 14914: tstl r9 # jump if no input available ! 14915: bnequ 0f ! 14916: jmp cmp09 ! 14917: 0: ! 14918: jsb nexts # acquire next source image ! 14919: movl cmpsn,lstsn # store stmt no for use by listr ! 14920: clrl scnpt # reset scan pointer ! 14921: jmp cmp04 # go process image ! 14922: # ! 14923: # FOR EXECUTE TIME COMPILE, PERMIT EMBEDDED CONTROL CARDS ! 14924: # AND COMMENTS (BY SKIPPING TO NEXT SEMI-COLON) ! 14925: # ! 14926: cmp02: movl r$cim,r9 # get current image ! 14927: movl scnpt,r7 # get current offset ! 14928: movab cfp$f(r9)[r7],r9# prepare to get chars ! 14929: # ! 14930: # SKIP TO SEMI-COLON ! 14931: # ! 14932: cmp03: movzbl (r9)+,r8 # get char ! 14933: incl scnpt # advance offset ! 14934: cmpl r8,$ch$sm # skip if semi-colon found ! 14935: beqlu cmp04 ! 14936: cmpl scnpt,scnil # loop if more chars ! 14937: blssu cmp03 ! 14938: clrl r9 # clear garbage xr value ! 14939: jmp cmp09 # end of image ! 14940: #page ! 14941: # ! 14942: # CMPIL (CONTINUED) ! 14943: # ! 14944: # HERE WITH IMAGE AVAILABLE TO SCAN. NOTE THAT IF THE INPUT ! 14945: # STRING IS NULL, THEN EVERYTHING IS OK SINCE NULL IS ! 14946: # ACTUALLY ASSEMBLED AS A WORD OF BLANKS. ! 14947: # ! 14948: cmp04: movl r$cim,r9 # point to current image ! 14949: movl scnpt,r7 # load current offset ! 14950: movl r7,r6 # copy for label scan ! 14951: movab cfp$f(r9)[r7],r9# point to first character ! 14952: movzbl (r9)+,r8 # load first character ! 14953: cmpl r8,$ch$sm # no label if semicolon ! 14954: bnequ 0f ! 14955: jmp cmp12 ! 14956: 0: ! 14957: cmpl r8,$ch$as # loop back if comment card ! 14958: bnequ 0f ! 14959: jmp cmpce ! 14960: 0: ! 14961: cmpl r8,$ch$mn # jump if control card ! 14962: bnequ 0f ! 14963: jmp cmp32 ! 14964: 0: ! 14965: movl r$cim,r$cmp # about to destroy r$cim ! 14966: movl $cmlab,r10 # point to label work string ! 14967: movl r10,r$cim # scane is to scan work string ! 14968: movab cfp$f(r10),r10 # point to first character position ! 14969: movb r8,(r10)+ # store char just loaded ! 14970: movl $ch$sm,r8 # get a semicolon ! 14971: movb r8,(r10) # store after first char ! 14972: #csc r10 # finished character storing ! 14973: clrl r10 # clear pointer ! 14974: clrl scnpt # start at first character ! 14975: movl scnil,-(sp) # preserve image length ! 14976: movl $num02,scnil # read 2 chars at most ! 14977: jsb scane # scan first char for type ! 14978: movl (sp)+,scnil # restore image length ! 14979: movl r10,r8 # note return code ! 14980: movl r$cmp,r10 # get old r$cim ! 14981: movl r10,r$cim # put it back ! 14982: movl r7,scnpt # reinstate offset ! 14983: tstl scnbl # blank seen - cant be label ! 14984: beqlu 0f ! 14985: jmp cmp12 ! 14986: 0: ! 14987: movl r10,r9 # point to current image ! 14988: movab cfp$f(r9)[r7],r9# point to first char again ! 14989: cmpl r8,$t$var # ok if letter ! 14990: beqlu cmp06 ! 14991: cmpl r8,$t$con # ok if digit ! 14992: beqlu cmp06 ! 14993: # ! 14994: # DROP IN OR JUMP FROM ERROR SECTION IF SCANE FAILED ! 14995: # ! 14996: cmple: movl r$cmp,r$cim # point to bad line ! 14997: jmp er_214 # bad label or misplaced continuation line ! 14998: # ! 14999: # LOOP TO SCAN LABEL ! 15000: # ! 15001: cmp05: cmpl r8,$ch$sm # skip if semicolon ! 15002: beqlu cmp07 ! 15003: incl r6 # bump offset ! 15004: cmpl r6,scnil # jump if end of image (label end) ! 15005: beqlu cmp07 ! 15006: #page ! 15007: # ! 15008: # CMPIL (CONTINUED) ! 15009: # ! 15010: # ENTER LOOP AT THIS POINT ! 15011: # ! 15012: cmp06: movzbl (r9)+,r8 # else load next character ! 15013: cmpl r8,$ch$ht # jump if horizontal tab ! 15014: beqlu cmp07 ! 15015: cmpl r8,$ch$bl # loop back if non-blank ! 15016: bnequ cmp05 ! 15017: # ! 15018: # HERE AFTER SCANNING OUT LABEL ! 15019: # ! 15020: cmp07: movl r6,scnpt # save updated scan offset ! 15021: subl2 r7,r6 # get length of label ! 15022: tstl r6 # skip if label length zero ! 15023: bnequ 0f ! 15024: jmp cmp12 ! 15025: 0: ! 15026: clrl r9 # clear garbage xr value ! 15027: jsb sbstr # build scblk for label name ! 15028: jsb gtnvr # locate/contruct vrblk ! 15029: .long invalid$ # dummy (impossible) error return ! 15030: movl r9,4*cmlbl(sp) # store label pointer ! 15031: tstl 4*vrlen(r9) # jump if not system label ! 15032: bnequ cmp11 ! 15033: cmpl 4*vrsvp(r9),$v$end # jump if not end label ! 15034: bnequ cmp11 ! 15035: # ! 15036: # HERE FOR END LABEL SCANNED OUT ! 15037: # ! 15038: addl2 $stgnd,stage # adjust stage appropriately ! 15039: jsb scane # scan out next element ! 15040: cmpl r10,$t$smc # jump if end of image ! 15041: bnequ 0f ! 15042: jmp cmp10 ! 15043: 0: ! 15044: cmpl r10,$t$var # else error if not variable ! 15045: bnequ cmp08 ! 15046: # ! 15047: # HERE CHECK FOR VALID INITIAL TRANSFER ! 15048: # ! 15049: cmpl 4*vrlbl(r9),$stndl # jump if not defined (error) ! 15050: beqlu cmp08 ! 15051: movl 4*vrlbl(r9),4*cmtra(sp) # else set initial entry pointer ! 15052: jsb scane # scan next element ! 15053: cmpl r10,$t$smc # jump if ok (end of image) ! 15054: bnequ 0f ! 15055: jmp cmp10 ! 15056: 0: ! 15057: # ! 15058: # HERE FOR BAD TRANSFER LABEL ! 15059: # ! 15060: cmp08: jmp er_215 # syntax error. undefined or erroneous entry label ! 15061: # ! 15062: # HERE FOR END OF INPUT (NO END LABEL DETECTED) ! 15063: # ! 15064: cmp09: addl2 $stgnd,stage # adjust stage appropriately ! 15065: cmpl stage,$stgxe # jump if code call (ok) ! 15066: bnequ 0f ! 15067: jmp cmp10 ! 15068: 0: ! 15069: jmp er_216 # syntax error. missing end line ! 15070: # ! 15071: # HERE AFTER PROCESSING END LINE (MERGE HERE ON END ERROR) ! 15072: # ! 15073: cmp10: movl $ostp$,r6 # set stop call pointer ! 15074: jsb cdwrd # generate as statement call ! 15075: jmp cmpse # jump to generate as failure ! 15076: #page ! 15077: # ! 15078: # CMPIL (CONTINUED) ! 15079: # ! 15080: # HERE AFTER PROCESSING LABEL OTHER THAN END ! 15081: # ! 15082: cmp11: cmpl stage,$stgic # jump if code call - redef. ok ! 15083: beqlu 0f ! 15084: jmp cmp12 ! 15085: 0: ! 15086: cmpl 4*vrlbl(r9),$stndl # else check for redefinition ! 15087: bnequ 0f ! 15088: jmp cmp12 ! 15089: 0: ! 15090: clrl 4*cmlbl(sp) # leave first label decln undisturbed ! 15091: jmp er_217 # syntax error. duplicate label ! 15092: # ! 15093: # HERE AFTER DEALING WITH LABEL ! 15094: # ! 15095: cmp12: clrl r7 # set flag for statement body ! 15096: jsb expan # get tree for statement body ! 15097: movl r9,4*cmstm(sp) # store for later use ! 15098: clrl 4*cmsgo(sp) # clear success goto pointer ! 15099: clrl 4*cmfgo(sp) # clear failure goto pointer ! 15100: clrl 4*cmcgo(sp) # clear conditional goto flag ! 15101: jsb scane # scan next element ! 15102: cmpl r10,$t$col # jump it not colon (no goto) ! 15103: beqlu 0f ! 15104: jmp cmp18 ! 15105: 0: ! 15106: # ! 15107: # LOOP TO PROCESS GOTO FIELDS ! 15108: # ! 15109: cmp13: movl sp,scngo # set goto flag ! 15110: jsb scane # scan next element ! 15111: cmpl r10,$t$smc # jump if no fields left ! 15112: bnequ 0f ! 15113: jmp cmp31 ! 15114: 0: ! 15115: cmpl r10,$t$sgo # jump if s for success goto ! 15116: beqlu cmp14 ! 15117: cmpl r10,$t$fgo # jump if f for failure goto ! 15118: beqlu cmp16 ! 15119: # ! 15120: # HERE FOR UNCONDITIONAL GOTO (I.E. NOT F OR S) ! 15121: # ! 15122: movl sp,scnrs # set to rescan element not f,s ! 15123: jsb scngf # scan out goto field ! 15124: tstl 4*cmfgo(sp) # error if fgoto already ! 15125: bnequ cmp17 ! 15126: movl r9,4*cmfgo(sp) # else set as fgoto ! 15127: jmp cmp15 # merge with sgoto circuit ! 15128: # ! 15129: # HERE FOR SUCCESS GOTO ! 15130: # ! 15131: cmp14: jsb scngf # scan success goto field ! 15132: movl $num01,4*cmcgo(sp) # set conditional goto flag ! 15133: # ! 15134: # UNCONTIONAL GOTO MERGES HERE ! 15135: # ! 15136: cmp15: tstl 4*cmsgo(sp) # error if sgoto already given ! 15137: bnequ cmp17 ! 15138: movl r9,4*cmsgo(sp) # else set sgoto ! 15139: jmp cmp13 # loop back for next goto field ! 15140: # ! 15141: # HERE FOR FAILURE GOTO ! 15142: # ! 15143: cmp16: jsb scngf # scan goto field ! 15144: movl $num01,4*cmcgo(sp) # set conditonal goto flag ! 15145: tstl 4*cmfgo(sp) # error if fgoto already given ! 15146: bnequ cmp17 ! 15147: movl r9,4*cmfgo(sp) # else store fgoto pointer ! 15148: jmp cmp13 # loop back for next field ! 15149: #page ! 15150: # ! 15151: # CMPIL (CONTINUED) ! 15152: # ! 15153: # HERE FOR DUPLICATED GOTO FIELD ! 15154: # ! 15155: cmp17: jmp er_218 # syntax error. duplicated goto field ! 15156: # ! 15157: # HERE TO GENERATE CODE ! 15158: # ! 15159: cmp18: clrl scnse # stop positional error flags ! 15160: movl 4*cmstm(sp),r9 # load tree ptr for statement body ! 15161: clrl r7 # collectable value for wb for cdgvl ! 15162: clrl r8 # reset constant flag for cdgvl ! 15163: jsb expap # test for pattern match ! 15164: .long cmp19 # jump if not pattern match ! 15165: movl $opms$,4*cmopn(r9) # else set pattern match pointer ! 15166: movl $c$pmt,4*cmtyp(r9) ! 15167: # ! 15168: # HERE AFTER DEALING WITH SPECIAL PATTERN MATCH CASE ! 15169: # ! 15170: cmp19: jsb cdgvl # generate code for body of statement ! 15171: movl 4*cmsgo(sp),r9 # load sgoto pointer ! 15172: movl r9,r6 # copy it ! 15173: tstl r9 # jump if no success goto ! 15174: beqlu cmp21 ! 15175: clrl 4*cmsoc(sp) # clear success offset fillin ptr ! 15176: cmpl r9,state # jump if complex goto ! 15177: bgequ cmp20 ! 15178: # ! 15179: # HERE FOR SIMPLE SUCCESS GOTO (LABEL) ! 15180: # ! 15181: addl2 $4*vrtra,r6 # point to vrtra field as required ! 15182: jsb cdwrd # generate success goto ! 15183: jmp cmp22 # jump to deal with fgoto ! 15184: # ! 15185: # HERE FOR COMPLEX SUCCESS GOTO ! 15186: # ! 15187: cmp20: cmpl r9,4*cmfgo(sp) # no code if same as fgoto ! 15188: beqlu cmp22 ! 15189: clrl r7 # else set ok value for cdgvl in wb ! 15190: jsb cdgcg # generate code for success goto ! 15191: jmp cmp22 # jump to deal with fgoto ! 15192: # ! 15193: # HERE FOR NO SUCCESS GOTO ! 15194: # ! 15195: cmp21: movl cwcof,4*cmsoc(sp)# set success fill in offset ! 15196: movl $ocer$,r6 # point to compile error call ! 15197: jsb cdwrd # generate as temporary value ! 15198: #page ! 15199: # ! 15200: # CMPIL (CONTINUED) ! 15201: # ! 15202: # HERE TO DEAL WITH FAILURE GOTO ! 15203: # ! 15204: cmp22: movl 4*cmfgo(sp),r9 # load failure goto pointer ! 15205: movl r9,r6 # copy it ! 15206: clrl 4*cmffc(sp) # set no fill in required yet ! 15207: tstl r9 # jump if no failure goto given ! 15208: beqlu cmp23 ! 15209: addl2 $4*vrtra,r6 # point to vrtra field in case ! 15210: cmpl r9,state # jump to gen if simple fgoto ! 15211: blequ cmpse ! 15212: # ! 15213: # HERE FOR COMPLEX FAILURE GOTO ! 15214: # ! 15215: movl cwcof,r7 # save offset to o$gof call ! 15216: movl $ogof$,r6 # point to failure goto call ! 15217: jsb cdwrd # generate ! 15218: movl $ofif$,r6 # point to fail in fail word ! 15219: jsb cdwrd # generate ! 15220: jsb cdgcg # generate code for failure goto ! 15221: movl r7,r6 # copy offset to o$gof for cdfal ! 15222: movl $b$cdc,r7 # set complex case cdtyp ! 15223: jmp cmp25 # jump to build cdblk ! 15224: # ! 15225: # HERE IF NO FAILURE GOTO GIVEN ! 15226: # ! 15227: cmp23: movl $ounf$,r6 # load unexpected failure call in cas ! 15228: movl cswfl,r8 # get -nofail flag ! 15229: bisl2 4*cmcgo(sp),r8 # check if conditional goto ! 15230: tstl r8 # jump if -nofail and no cond. goto ! 15231: beqlu cmpse ! 15232: movl sp,4*cmffc(sp) # else set fill in flag ! 15233: movl $ocer$,r6 # and set compile error for temporary ! 15234: # ! 15235: # MERGE HERE WITH CDFAL VALUE IN WA, SIMPLE CDBLK ! 15236: # ALSO SPECIAL ENTRY AFTER STATEMENT ERROR ! 15237: # ! 15238: cmpse: movl $b$cds,r7 # set cdtyp for simple case ! 15239: #page ! 15240: # ! 15241: # CMPIL (CONTINUED) ! 15242: # ! 15243: # MERGE HERE TO BUILD CDBLK ! 15244: # ! 15245: # (WA) CDFAL VALUE TO BE GENERATED ! 15246: # (WB) CDTYP VALUE TO BE GENERATED ! 15247: # ! 15248: # AT THIS STAGE, WE CHOP OFF AN APPROPRIATE CHUNK OF THE ! 15249: # CURRENT CCBLK AND CONVERT IT INTO A CDBLK. THE REMAINDER ! 15250: # OF THE CCBLK IS REFORMATTED TO BE THE NEW CCBLK. ! 15251: # ! 15252: cmp25: movl r$ccb,r9 # point to ccblk ! 15253: movl 4*cmlbl(sp),r10 # get possible label pointer ! 15254: tstl r10 # skip if no label ! 15255: beqlu cmp26 ! 15256: clrl 4*cmlbl(sp) # clear flag for next statement ! 15257: movl r9,4*vrlbl(r10) # put cdblk ptr in vrblk label field ! 15258: # ! 15259: # MERGE AFTER DOING LABEL ! 15260: # ! 15261: cmp26: movl r7,(r9) # set type word for new cdblk ! 15262: movl r6,4*cdfal(r9) # set failure word ! 15263: movl r9,r10 # copy pointer to ccblk ! 15264: movl 4*ccuse(r9),r7 # load length gen (= new cdlen) ! 15265: movl 4*cclen(r9),r8 # load total ccblk length ! 15266: addl2 r7,r10 # point past cdblk ! 15267: subl2 r7,r8 # get length left for chop off ! 15268: movl $b$cct,(r10) # set type code for new ccblk at end ! 15269: movl $4*cccod,4*ccuse(r10) # set initial code offset ! 15270: movl $4*cccod,cwcof # reinitialise cwcof ! 15271: movl r8,4*cclen(r10) # set new length ! 15272: movl r10,r$ccb # set new ccblk pointer ! 15273: movl cmpsn,4*cdstm(r9)# set statement number ! 15274: incl cmpsn # bump statement number ! 15275: # ! 15276: # SET POINTERS IN PREVIOUS CODE BLOCK AS REQUIRED ! 15277: # ! 15278: movl 4*cmpcd(sp),r10 # load ptr to previous cdblk ! 15279: tstl 4*cmffp(sp) # jump if no failure fill in required ! 15280: beqlu cmp27 ! 15281: movl r9,4*cdfal(r10) # else set failure ptr in previous ! 15282: # ! 15283: # HERE TO DEAL WITH SUCCESS FORWARD POINTER ! 15284: # ! 15285: cmp27: movl 4*cmsop(sp),r6 # load success offset ! 15286: tstl r6 # jump if no fill in required ! 15287: beqlu cmp28 ! 15288: addl2 r6,r10 # else point to fill in location ! 15289: movl r9,(r10) # store forward pointer ! 15290: clrl r10 # clear garbage xl value ! 15291: #page ! 15292: # ! 15293: # CMPIL (CONTINUED) ! 15294: # ! 15295: # NOW SET FILL IN POINTERS FOR THIS STATEMENT ! 15296: # ! 15297: cmp28: movl 4*cmffc(sp),4*cmffp(sp) # copy failure fill in flag ! 15298: movl 4*cmsoc(sp),4*cmsop(sp) # copy success fill in offset ! 15299: movl r9,4*cmpcd(sp) # save ptr to this cdblk ! 15300: tstl 4*cmtra(sp) # jump if initial entry already set ! 15301: bnequ cmp29 ! 15302: movl r9,4*cmtra(sp) # else set ptr here as default ! 15303: # ! 15304: # HERE AFTER COMPILING ONE STATEMENT ! 15305: # ! 15306: cmp29: cmpl stage,$stgce # jump if not end line just done ! 15307: bgequ 0f ! 15308: jmp cmp01 ! 15309: 0: ! 15310: tstl cswls # skip if -nolist ! 15311: beqlu cmp30 ! 15312: jsb listr # list last line ! 15313: # ! 15314: # RETURN ! 15315: # ! 15316: cmp30: movl 4*cmtra(sp),r9 # load initial entry cdblk pointer ! 15317: addl2 $4*cmnen,sp # pop work locations off stack ! 15318: rsb # and return to cmpil caller ! 15319: # ! 15320: # HERE AT END OF GOTO FIELD ! 15321: # ! 15322: cmp31: movl 4*cmfgo(sp),r7 # get fail goto ! 15323: bisl2 4*cmsgo(sp),r7 # or in success goto ! 15324: tstl r7 # ok if non-null field ! 15325: beqlu 0f ! 15326: jmp cmp18 ! 15327: 0: ! 15328: jmp er_219 # syntax error. empty goto field ! 15329: # ! 15330: # CONTROL CARD FOUND ! 15331: # ! 15332: cmp32: incl r7 # point past ch$mn ! 15333: jsb cncrd # process control card ! 15334: clrl scnse # clear start of element loc. ! 15335: jmp cmpce # loop for next statement ! 15336: #enp # end procedure cmpil ! 15337: #page ! 15338: # ! 15339: # CNCRD -- CONTROL CARD PROCESSOR ! 15340: # ! 15341: # CALLED TO DEAL WITH CONTROL CARDS ! 15342: # ! 15343: # R$CIM POINTS TO CURRENT IMAGE ! 15344: # (WB) OFFSET TO 1ST CHAR OF CONTROL CARD ! 15345: # JSR CNCRD CALL TO PROCESS CONTROL CARDS ! 15346: # (XL,XR,WA,WB,WC,IA) DESTROYED ! 15347: # ! 15348: cncrd: #prc # entry point ! 15349: movl r7,scnpt # offset for control card scan ! 15350: movl $ccnoc,r6 # number of chars for comparison ! 15351: movab 3+(4*0)(r6),r6 # convert to word count ! 15352: ashl $-2,r6,r6 ! 15353: movl r6,cnswc # save word count ! 15354: # ! 15355: # LOOP HERE IF MORE THAN ONE CONTROL CARD ! 15356: # ! 15357: cnc01: cmpl scnpt,scnil # return if end of image ! 15358: blssu 0f ! 15359: jmp cnc09 ! 15360: 0: ! 15361: movl r$cim,r9 # point to image ! 15362: movl scnpt,r11 # [get in scratch register] ! 15363: movab cfp$f(r9)[r11],r9# char ptr for first char ! 15364: movzbl (r9)+,r6 # get first char ! 15365: bicl2 $ch$bl,r6 # fold to upper case ! 15366: cmpl r6,$ch$li # special case of -inxxx ! 15367: bnequ 0f ! 15368: jmp cnc07 ! 15369: 0: ! 15370: movl sp,scncc # set flag for scane ! 15371: jsb scane # scan card name ! 15372: clrl scncc # clear scane flag ! 15373: tstl r10 # fail unless control card name ! 15374: beqlu 0f ! 15375: jmp cnc06 ! 15376: 0: ! 15377: movl $ccnoc,r6 # no. of chars to be compared ! 15378: cmpl 4*sclen(r9),r6 # fail if too few chars ! 15379: bgequ 0f ! 15380: jmp cnc06 ! 15381: 0: ! 15382: movl r9,r10 # point to control card name ! 15383: clrl r7 # zero offset for substring ! 15384: jsb sbstr # extract substring for comparison ! 15385: movl 4*sclen(r9),r6 # reload length ! 15386: jsb flstg # fold to upper case ! 15387: movl r9,cnscc # keep control card substring ptr ! 15388: movl $ccnms,r9 # point to list of standard names ! 15389: clrl r7 # initialise name offset ! 15390: movl $cc$nc,r8 # number of standard names ! 15391: # ! 15392: # TRY TO MATCH NAME ! 15393: # ! 15394: cnc02: movl cnscc,r10 # point to name ! 15395: movl cnswc,r6 # counter for inner loop ! 15396: jmp cnc04 # jump into loop ! 15397: # ! 15398: # INNER LOOP TO MATCH CARD NAME CHARS ! 15399: # ! 15400: cnc03: addl2 $4,r9 # bump standard names ptr ! 15401: addl2 $4,r10 # bump name pointer ! 15402: # ! 15403: # HERE TO INITIATE THE LOOP ! 15404: # ! 15405: cnc04: cmpl 4*schar(r10),(r9)# comp. up to cfp$c chars at once ! 15406: bnequ cnc05 ! 15407: sobgtr r6,cnc03 # loop if more words to compare ! 15408: #page ! 15409: # ! 15410: # CNCRD (CONTINUED) ! 15411: # ! 15412: # MATCHED - BRANCH ON CARD OFFSET ! 15413: # ! 15414: movl r7,r10 # get name offset ! 15415: casel r10,$0,$cc$nc # switch ! 15416: 5: ! 15417: .word cnc37-5b # -case ! 15418: .word cnc10-5b # -double ! 15419: .word cnc11-5b # -dump ! 15420: .word cnc12-5b # -eject ! 15421: .word cnc13-5b # -errors ! 15422: .word cnc14-5b # -execute ! 15423: .word cnc15-5b # -fail ! 15424: .word cnc16-5b # -list ! 15425: .word cnc17-5b # -noerrors ! 15426: .word cnc18-5b # -noexecute ! 15427: .word cnc19-5b # -nofail ! 15428: .word cnc20-5b # -nolist ! 15429: .word cnc21-5b # -noopt ! 15430: .word cnc22-5b # -noprint ! 15431: .word cnc24-5b # -optimise ! 15432: .word cnc25-5b # -print ! 15433: .word cnc27-5b # -single ! 15434: .word cnc28-5b # -space ! 15435: .word cnc31-5b # -stitle ! 15436: .word cnc32-5b # -title ! 15437: .word cnc36-5b # -trace ! 15438: #esw # end switch ! 15439: # ! 15440: # NOT MATCHED YET. ALIGN STD NAMES PTR AND TRY AGAIN ! 15441: # ! 15442: cnc05: addl2 $4,r9 # bump standard names ptr ! 15443: sobgtr r6,cnc05 # loop ! 15444: incl r7 # bump names offset ! 15445: sobgtr r8,cnc02 # continue if more names ! 15446: # ! 15447: # INVALID CONTROL CARD NAME ! 15448: # ! 15449: cnc06: jmp er_247 # invalid control card ! 15450: # ! 15451: # SPECIAL PROCESSING FOR -INXXX ! 15452: # ! 15453: cnc07: movzbl (r9),r6 # get next char ! 15454: bicl2 $ch$bl,r6 # fold to upper case ! 15455: cmpl r6,$ch$ln # fail if not letter n ! 15456: beqlu 0f ! 15457: jmp cnc06 ! 15458: 0: ! 15459: addl2 $num02,scnpt # bump offset past -in ! 15460: jsb scane # scan integer after -in ! 15461: movl r9,-(sp) # stack scanned item ! 15462: jsb gtsmi # check if integer ! 15463: .long cnc06 # fail if not integer ! 15464: .long cnc06 # fail if negative or large ! 15465: movl r9,cswin # keep integer ! 15466: #page ! 15467: # ! 15468: # CNCRD (CONTINUED) ! 15469: # ! 15470: # CHECK FOR MORE CONTROL CARDS BEFORE RETURNING ! 15471: # ! 15472: cnc08: movl scnpt,r6 # preserve in case xeq time compile ! 15473: jsb scane # look for comma ! 15474: cmpl r10,$t$cma # loop if comma found ! 15475: bnequ 0f ! 15476: jmp cnc01 ! 15477: 0: ! 15478: movl r6,scnpt # restore scnpt in case xeq time ! 15479: # ! 15480: # RETURN POINT ! 15481: # ! 15482: cnc09: rsb # return ! 15483: # ! 15484: # -DOUBLE ! 15485: # ! 15486: cnc10: movl sp,cswdb # set switch ! 15487: jmp cnc08 # merge ! 15488: # ! 15489: # -DUMP ! 15490: # THIS IS USED FOR SYSTEM DEBUGGING . IT HAS THE EFFECT OF ! 15491: # PRODUCING A CORE DUMP AT COMPILATION TIME ! 15492: # ! 15493: cnc11: jsb sysdm # call dumper ! 15494: jmp cnc09 # finished ! 15495: # ! 15496: # -EJECT ! 15497: # ! 15498: cnc12: tstl cswls # return if -nolist ! 15499: bnequ 0f ! 15500: jmp cnc09 ! 15501: 0: ! 15502: jsb prtps # eject ! 15503: jsb listt # list title ! 15504: jmp cnc09 # finished ! 15505: # ! 15506: # -ERRORS ! 15507: # ! 15508: cnc13: clrl cswer # clear switch ! 15509: jmp cnc08 # merge ! 15510: # ! 15511: # -EXECUTE ! 15512: # ! 15513: cnc14: clrl cswex # clear switch ! 15514: jmp cnc08 # merge ! 15515: # ! 15516: # -FAIL ! 15517: # ! 15518: cnc15: movl sp,cswfl # set switch ! 15519: jmp cnc08 # merge ! 15520: # ! 15521: # -LIST ! 15522: # ! 15523: cnc16: movl sp,cswls # set switch ! 15524: cmpl stage,$stgic # done if compile time ! 15525: beqlu cnc08 ! 15526: # ! 15527: # LIST CODE LINE IF EXECUTE TIME COMPILE ! 15528: # ! 15529: clrl lstpf # permit listing ! 15530: jsb listr # list line ! 15531: jmp cnc08 # merge ! 15532: #page ! 15533: # ! 15534: # CNCRD (CONTINUED) ! 15535: # ! 15536: # -NOERRORS ! 15537: # ! 15538: cnc17: movl sp,cswer # set switch ! 15539: jmp cnc08 # merge ! 15540: # ! 15541: # -NOEXECUTE ! 15542: # ! 15543: cnc18: movl sp,cswex # set switch ! 15544: jmp cnc08 # merge ! 15545: # ! 15546: # -NOFAIL ! 15547: # ! 15548: cnc19: clrl cswfl # clear switch ! 15549: jmp cnc08 # merge ! 15550: # ! 15551: # -NOLIST ! 15552: # ! 15553: cnc20: clrl cswls # clear switch ! 15554: jmp cnc08 # merge ! 15555: # ! 15556: # -NOOPTIMISE ! 15557: # ! 15558: cnc21: movl sp,cswno # set switch ! 15559: jmp cnc08 # merge ! 15560: # ! 15561: # -NOPRINT ! 15562: # ! 15563: cnc22: clrl cswpr # clear switch ! 15564: jmp cnc08 # merge ! 15565: # ! 15566: # -OPTIMISE ! 15567: # ! 15568: cnc24: clrl cswno # clear switch ! 15569: jmp cnc08 # merge ! 15570: # ! 15571: # -PRINT ! 15572: # ! 15573: cnc25: movl sp,cswpr # set switch ! 15574: jmp cnc08 # merge ! 15575: #page ! 15576: # ! 15577: # CNCRD (CONTINUED) ! 15578: # ! 15579: # -SINGLE ! 15580: # ! 15581: cnc27: clrl cswdb # clear switch ! 15582: jmp cnc08 # merge ! 15583: # ! 15584: # -SPACE ! 15585: # ! 15586: cnc28: tstl cswls # return if -nolist ! 15587: bnequ 0f ! 15588: jmp cnc09 ! 15589: 0: ! 15590: jsb scane # scan integer after -space ! 15591: movl $num01,r8 # 1 space in case ! 15592: cmpl r9,$t$smc # jump if no integer ! 15593: beqlu cnc29 ! 15594: movl r9,-(sp) # stack it ! 15595: jsb gtsmi # check integer ! 15596: .long cnc06 # fail if not integer ! 15597: .long cnc06 # fail if negative or large ! 15598: tstl r8 # jump if non zero ! 15599: bnequ cnc29 ! 15600: movl $num01,r8 # else 1 space ! 15601: # ! 15602: # MERGE WITH COUNT OF LINES TO SKIP ! 15603: # ! 15604: cnc29: addl2 r8,lstlc # bump line count ! 15605: # convert to loop counter ! 15606: cmpl lstlc,lstnp # jump if fits on page ! 15607: blssu cnc30 ! 15608: jsb prtps # eject ! 15609: jsb listt # list title ! 15610: jmp cnc09 # merge ! 15611: # ! 15612: # SKIP LINES ! 15613: # ! 15614: cnc30: jsb prtnl # print a blank ! 15615: sobgtr r8,cnc30 # loop ! 15616: jmp cnc09 # merge ! 15617: #page ! 15618: # ! 15619: # CNCRD (CONTINUED) ! 15620: # ! 15621: # -STITL ! 15622: # ! 15623: cnc31: movl $r$stl,cnr$t # ptr to r$stl ! 15624: jmp cnc33 # merge ! 15625: # ! 15626: # -TITLE ! 15627: # ! 15628: cnc32: movl $nulls,r$stl # clear subtitle ! 15629: movl $r$ttl,cnr$t # ptr to r$ttl ! 15630: # ! 15631: # COMMON PROCESSING FOR -TITLE, -STITL ! 15632: # ! 15633: cnc33: movl $nulls,r9 # null in case needed ! 15634: movl sp,cnttl # set flag for next listr call ! 15635: movl $ccofs,r7 # offset to title/subtitle ! 15636: movl scnil,r6 # input image length ! 15637: cmpl r6,r7 # jump if no chars left ! 15638: blequ cnc34 ! 15639: subl2 r7,r6 # no of chars to extract ! 15640: movl r$cim,r10 # point to image ! 15641: jsb sbstr # get title/subtitle ! 15642: # ! 15643: # STORE TITLE/SUBTITLE ! 15644: # ! 15645: cnc34: movl cnr$t,r10 # point to storage location ! 15646: movl r9,(r10) # store title/subtitle ! 15647: cmpl r10,$r$stl # return if stitl ! 15648: bnequ 0f ! 15649: jmp cnc09 ! 15650: 0: ! 15651: tstl precl # return if extended listing ! 15652: beqlu 0f ! 15653: jmp cnc09 ! 15654: 0: ! 15655: tstl prich # return if regular printer ! 15656: bnequ 0f ! 15657: jmp cnc09 ! 15658: 0: ! 15659: movl 4*sclen(r9),r10 # get length of title ! 15660: movl r10,r6 # copy it ! 15661: tstl r10 # jump if null ! 15662: beqlu cnc35 ! 15663: addl2 $num10,r10 # increment ! 15664: cmpl r10,prlen # use default lstp0 val if too long ! 15665: blssu 0f ! 15666: jmp cnc09 ! 15667: 0: ! 15668: addl2 $num04,r6 # point just past title ! 15669: # ! 15670: # STORE OFFSET TO PAGE NN MESSAGE FOR SHORT TITLE ! 15671: # ! 15672: cnc35: movl r6,lstpo # store offset ! 15673: jmp cnc09 # return ! 15674: # ! 15675: # -TRACE ! 15676: # PROVIDED FOR SYSTEM DEBUGGING. TOGGLES THE SYSTEM LABEL ! 15677: # TRACE SWITCH AT COMPILE TIME ! 15678: # ! 15679: cnc36: jsb systt # toggle switch ! 15680: jmp cnc08 # merge ! 15681: # ! 15682: # -CASE ! 15683: # SETS VALUE OF KVCAS SO THAT NAMES ARE FOLDED OR NOT ! 15684: # DURING COMPILATION. ! 15685: # ! 15686: cnc37: jsb scane # scan integer after -case ! 15687: clrl r8 # get 0 in case none there ! 15688: cmpl r10,$t$smc # skip if no integer ! 15689: beqlu cnc38 ! 15690: movl r9,-(sp) # stack it ! 15691: jsb gtsmi # check integer ! 15692: .long cnc06 # fail if not integer ! 15693: .long cnc06 # fail if negative or too large ! 15694: cnc38: movl r8,kvcas # store new case value ! 15695: jmp cnc09 # merge ! 15696: #enp # end procedure cncrd ! 15697: #page ! 15698: # ! 15699: # DFFNC -- DEFINE FUNCTION ! 15700: # ! 15701: # DFFNC IS CALLED WHENEVER A NEW FUNCTION IS ASSIGNED TO ! 15702: # A VARIABLE. IT DEALS WITH EXTERNAL FUNCTION USE COUNTS. ! 15703: # ! 15704: # (XR) POINTER TO VRBLK ! 15705: # (XL) POINTER TO NEW FUNCTION BLOCK ! 15706: # JSR DFFNC CALL TO DEFINE FUNCTION ! 15707: # (WA,WB) DESTROYED ! 15708: # ! 15709: dffnc: #prc # entry point ! 15710: cmpl (r10),$b$efc # skip if new function not external ! 15711: bnequ dffn1 ! 15712: incl 4*efuse(r10) # else increment its use count ! 15713: # ! 15714: # HERE AFTER DEALING WITH NEW FUNCTION USE COUNT ! 15715: # ! 15716: dffn1: movl r9,r6 # save vrblk pointer ! 15717: movl 4*vrfnc(r9),r9 # load old function pointer ! 15718: cmpl (r9),$b$efc # jump if old function not external ! 15719: bnequ dffn2 ! 15720: movl 4*efuse(r9),r7 # else get use count ! 15721: decl r7 # decrement ! 15722: movl r7,4*efuse(r9) # store decremented value ! 15723: tstl r7 # jump if use count still non-zero ! 15724: bnequ dffn2 ! 15725: jsb sysul # else call system unload function ! 15726: # ! 15727: # HERE AFTER DEALING WITH OLD FUNCTION USE COUNT ! 15728: # ! 15729: dffn2: movl r6,r9 # restore vrblk pointer ! 15730: movl r10,r6 # copy function block ptr ! 15731: cmpl r9,$r$yyy # skip checks if opsyn op definition ! 15732: blssu dffn3 ! 15733: tstl 4*vrlen(r9) # jump if not system variable ! 15734: bnequ dffn3 ! 15735: # ! 15736: # FOR SYSTEM VARIABLE, CHECK FOR ILLEGAL REDEFINITION ! 15737: # ! 15738: movl 4*vrsvp(r9),r10 # point to svblk ! 15739: movl 4*svbit(r10),r7 # load bit indicators ! 15740: mcoml btfnc,r11 # is it a system function ! 15741: bicl2 r11,r7 ! 15742: tstl r7 # redef ok if not ! 15743: beqlu dffn3 ! 15744: jmp er_248 # attempted redefinition of system function ! 15745: # ! 15746: # HERE IF REDEFINITION IS PERMITTED ! 15747: # ! 15748: dffn3: movl r6,4*vrfnc(r9) # store new function pointer ! 15749: movl r6,r10 # restore function block pointer ! 15750: rsb # return to dffnc caller ! 15751: #enp # end procedure dffnc ! 15752: #page ! 15753: # ! 15754: # DTACH -- DETACH I/O ASSOCIATED NAMES ! 15755: # ! 15756: # DETACHES TRBLKS FROM I/O ASSOCIATED VARIABLES, REMOVES ! 15757: # ENTRY FROM IOCHN CHAIN ATTACHED TO FILEARG1 VRBLK AND MAY ! 15758: # REMOVE VRBLK ACCESS AND STORE TRAPS. ! 15759: # INPUT, OUTPUT, TERMINAL ARE HANDLED SPECIALLY. ! 15760: # ! 15761: # (XL) I/O ASSOC. VBL NAME BASE PTR ! 15762: # (WA) OFFSET TO NAME ! 15763: # JSR DTACH CALL FOR DETACH OPERATION ! 15764: # (XL,XR,WA,WB,WC) DESTROYED ! 15765: # ! 15766: dtach: #prc # entry point ! 15767: movl r10,dtcnb # store name base (gbcol not called) ! 15768: addl2 r6,r10 # point to name location ! 15769: movl r10,dtcnm # store it ! 15770: # ! 15771: # LOOP TO SEARCH FOR I/O TRBLK ! 15772: # ! 15773: dtch1: movl r10,r9 # copy name pointer ! 15774: # ! 15775: # CONTINUE AFTER BLOCK DELETION ! 15776: # ! 15777: dtch2: movl (r10),r10 # point to next value ! 15778: cmpl (r10),$b$trt # jump at chain end ! 15779: bnequ dtch6 ! 15780: movl 4*trtyp(r10),r6 # get trap block type ! 15781: cmpl r6,$trtin # jump if input ! 15782: beqlu dtch3 ! 15783: cmpl r6,$trtou # jump if output ! 15784: beqlu dtch3 ! 15785: addl2 $4*trnxt,r10 # point to next link ! 15786: jmp dtch1 # loop ! 15787: # ! 15788: # DELETE AN OLD ASSOCIATION ! 15789: # ! 15790: dtch3: movl 4*trval(r10),(r9)# delete trblk ! 15791: movl r10,r6 # dump xl ... ! 15792: movl r9,r7 # ... and xr ! 15793: movl 4*trtrf(r10),r10# point to trtrf trap block ! 15794: tstl r10 # jump if no iochn ! 15795: beqlu dtch5 ! 15796: cmpl (r10),$b$trt # jump if input, output, terminal ! 15797: bnequ dtch5 ! 15798: # ! 15799: # LOOP TO SEARCH IOCHN CHAIN FOR NAME PTR ! 15800: # ! 15801: dtch4: movl r10,r9 # remember link ptr ! 15802: movl 4*trtrf(r10),r10# point to next link ! 15803: tstl r10 # jump if end of chain ! 15804: beqlu dtch5 ! 15805: movl 4*ionmb(r10),r8 # get name base ! 15806: addl2 4*ionmo(r10),r8 # add offset ! 15807: cmpl r8,dtcnm # loop if no match ! 15808: bnequ dtch4 ! 15809: movl 4*trtrf(r10),4*trtrf(r9) # remove name from chain ! 15810: #page ! 15811: # ! 15812: # DTACH (CONTINUED) ! 15813: # ! 15814: # PREPARE TO RESUME I/O TRBLK SCAN ! 15815: # ! 15816: dtch5: movl r6,r10 # recover xl ... ! 15817: movl r7,r9 # ... and xr ! 15818: addl2 $4*trval,r10 # point to value field ! 15819: jmp dtch2 # continue ! 15820: # ! 15821: # EXIT POINT ! 15822: # ! 15823: dtch6: movl dtcnb,r9 # possible vrblk ptr ! 15824: jsb setvr # reset vrblk if necessary ! 15825: rsb # return ! 15826: #enp # end procedure dtach ! 15827: #page ! 15828: # ! 15829: # DTYPE -- GET DATATYPE NAME ! 15830: # ! 15831: # (XR) OBJECT WHOSE DATATYPE IS REQUIRED ! 15832: # JSR DTYPE CALL TO GET DATATYPE ! 15833: # (XR) RESULT DATATYPE ! 15834: # ! 15835: dtype: #prc # entry point ! 15836: cmpl (r9),$b$pdt # jump if prog.defined ! 15837: beqlu dtyp1 ! 15838: movl (r9),r9 # load type word ! 15839: movzwl -2(r9),r9 # get entry point id (block code) ! 15840: moval 0[r9],r9 # convert to byte offset ! 15841: movl l^scnmt(r9),r9 # load table entry ! 15842: rsb # exit to dtype caller ! 15843: # ! 15844: # HERE IF PROGRAM DEFINED ! 15845: # ! 15846: dtyp1: movl 4*pddfp(r9),r9 # point to dfblk ! 15847: movl 4*dfnam(r9),r9 # get datatype name from dfblk ! 15848: rsb # return to dtype caller ! 15849: #enp # end procedure dtype ! 15850: #page ! 15851: # ! 15852: # DUMPR -- PRINT DUMP OF STORAGE ! 15853: # ! 15854: # (XR) DUMP ARGUMENT (SEE BELOW) ! 15855: # JSR DUMPR CALL TO PRINT DUMP ! 15856: # (XR,XL) DESTROYED ! 15857: # (WA,WB,WC,RA) DESTROYED ! 15858: # ! 15859: # THE DUMP ARGUMENT HAS THE FOLLOWING SIGNIFICANCE ! 15860: # ! 15861: # DMARG = 0 NO DUMP PRINTED ! 15862: # DMARG = 1 PARTIAL DUMP (NAT VARS, KEYWORDS) ! 15863: # DMARG EQ 2 FULL DUMP (INCL ARRAYS ETC.) ! 15864: # DMARG GE 3 CORE DUMP ! 15865: # ! 15866: # SINCE DUMPR SCRAMBLES STORE, IT IS NOT PERMISSIBLE TO ! 15867: # COLLECT IN MID-DUMP. HENCE A COLLECT IS DONE INITIALLY ! 15868: # AND THEN IF STORE RUNS OUT AN ERROR MESSAGE IS PRODUCED. ! 15869: # ! 15870: dumpr: #prc # entry point ! 15871: tstl r9 # skip dump if argument is zero ! 15872: bnequ 0f ! 15873: jmp dmp28 ! 15874: 0: ! 15875: cmpl r9,$num02 # jump if core dump required ! 15876: blequ 0f ! 15877: jmp dmp29 ! 15878: 0: ! 15879: clrl r10 # clear xl ! 15880: clrl r7 # zero move offset ! 15881: movl r9,dmarg # save dump argument ! 15882: jsb gbcol # collect garbage ! 15883: jsb prtpg # eject printer ! 15884: movl $dmhdv,r9 # point to heading for variables ! 15885: jsb prtst # print it ! 15886: jsb prtnl # terminate print line ! 15887: jsb prtnl # and print a blank line ! 15888: # ! 15889: # FIRST ALL NATURAL VARIABLE BLOCKS (VRBLK) WHOSE VALUES ! 15890: # ARE NON-NULL ARE LINKED IN LEXICAL ORDER USING DMVCH AS ! 15891: # THE CHAIN HEAD AND CHAINING THROUGH THE VRGET FIELDS. ! 15892: # NOTE THAT THIS SCRAMBLES STORE IF THE PROCESS IS ! 15893: # INTERRUPTED BEFORE COMPLETION E.G. BY EXCEEDING TIME OR ! 15894: # PRINT LIMITS. SINCE THE SUBSEQUENT CORE DUMPS AND ! 15895: # FAILURES IF EXECUTION IS RESUMED ARE VERY CONFUSING, THE ! 15896: # EXECUTION TIME ERROR ROUTINE CHECKS FOR THIS EVENT AND ! 15897: # ATTEMPTS AN UNSCRAMBLE. SIMILAR PRECAUTIONS SHOULD BE ! 15898: # OBSERVED IF TRANSLATE TIME DUMPING IS IMPLEMENTED. ! 15899: # ! 15900: clrl dmvch # set null chain to start ! 15901: movl hshtb,r6 # point to hash table ! 15902: # ! 15903: # LOOP THROUGH HEADERS IN HASH TABLE ! 15904: # ! 15905: dmp00: movl r6,r9 # copy hash bucket pointer ! 15906: addl2 $4,r6 # bump pointer ! 15907: subl2 $4*vrnxt,r9 # set offset to merge ! 15908: # ! 15909: # LOOP THROUGH VRBLKS ON ONE CHAIN ! 15910: # ! 15911: dmp01: movl 4*vrnxt(r9),r9 # point to next vrblk on chain ! 15912: tstl r9 # jump if end of this hash chain ! 15913: bnequ 0f ! 15914: jmp dmp09 ! 15915: 0: ! 15916: movl r9,r10 # else copy vrblk pointer ! 15917: #page ! 15918: # ! 15919: # DUMPR (CONTINUED) ! 15920: # ! 15921: # LOOP TO FIND VALUE AND SKIP IF NULL ! 15922: # ! 15923: dmp02: movl 4*vrval(r10),r10# load value ! 15924: cmpl r10,$nulls # loop for next vrblk if null value ! 15925: beqlu dmp01 ! 15926: cmpl (r10),$b$trt # loop back if value is trapped ! 15927: beqlu dmp02 ! 15928: # ! 15929: # NON-NULL VALUE, PREPARE TO SEARCH CHAIN ! 15930: # ! 15931: movl r9,r8 # save vrblk pointer ! 15932: addl2 $4*vrsof,r9 # adjust ptr to be like scblk ptr ! 15933: tstl 4*sclen(r9) # jump if non-system variable ! 15934: bnequ dmp03 ! 15935: movl 4*vrsvo(r9),r9 # else load ptr to name in svblk ! 15936: # ! 15937: # HERE WITH NAME POINTER FOR NEW BLOCK IN XR ! 15938: # ! 15939: dmp03: movl r9,r7 # save pointer to chars ! 15940: movl r6,dmpsv # save hash bucket pointer ! 15941: movl $dmvch,r6 # point to chain head ! 15942: # ! 15943: # LOOP TO SEARCH CHAIN FOR CORRECT INSERTION POINT ! 15944: # ! 15945: dmp04: movl r6,dmpch # save chain pointer ! 15946: movl r6,r10 # copy it ! 15947: movl (r10),r9 # load pointer to next entry ! 15948: tstl r9 # jump if end of chain to insert ! 15949: bnequ 0f ! 15950: jmp dmp08 ! 15951: 0: ! 15952: addl2 $4*vrsof,r9 # else get name ptr for chained vrblk ! 15953: tstl 4*sclen(r9) # jump if not system variable ! 15954: bnequ dmp05 ! 15955: movl 4*vrsvo(r9),r9 # else point to name in svblk ! 15956: # ! 15957: # HERE PREPARE TO COMPARE THE NAMES ! 15958: # ! 15959: # (WA) SCRATCH ! 15960: # (WB) POINTER TO STRING OF ENTERING VRBLK ! 15961: # (WC) POINTER TO ENTERING VRBLK ! 15962: # (XR) POINTER TO STRING OF CURRENT BLOCK ! 15963: # (XL) SCRATCH ! 15964: # ! 15965: dmp05: movl r7,r10 # point to entering vrblk string ! 15966: movl 4*sclen(r10),r6 # load its length ! 15967: movab cfp$f(r10),r10 # point to chars of entering string ! 15968: cmpl r6,4*sclen(r9) # jump if entering length high ! 15969: bgequ dmp06 ! 15970: movab cfp$f(r9),r9 # else point to chars of old string ! 15971: jsb sbcmc # compare, insert if new is llt old ! 15972: .long dmp08 ! 15973: .long dmp07 ! 15974: jmp dmp08 # or if leq (we had shorter length) ! 15975: # ! 15976: # HERE WHEN NEW LENGTH IS LONGER THAN OLD LENGTH ! 15977: # ! 15978: dmp06: movl 4*sclen(r9),r6 # load shorter length ! 15979: movab cfp$f(r9),r9 # point to chars of old string ! 15980: jsb sbcmc # compare, insert if new one low ! 15981: .long dmp08 ! 15982: .long dmp07 ! 15983: #page ! 15984: # ! 15985: # DUMPR (CONTINUED) ! 15986: # ! 15987: # HERE WE MOVE OUT ON THE CHAIN ! 15988: # ! 15989: dmp07: movl dmpch,r10 # copy chain pointer ! 15990: movl (r10),r6 # move to next entry on chain ! 15991: jmp dmp04 # loop back ! 15992: # ! 15993: # HERE AFTER LOCATING THE PROPER INSERTION POINT ! 15994: # ! 15995: dmp08: movl dmpch,r10 # copy chain pointer ! 15996: movl dmpsv,r6 # restore hash bucket pointer ! 15997: movl r8,r9 # restore vrblk pointer ! 15998: movl (r10),4*vrget(r9)# link vrblk to rest of chain ! 15999: movl r9,(r10) # link vrblk into current chain loc ! 16000: jmp dmp01 # loop back for next vrblk ! 16001: # ! 16002: # HERE AFTER PROCESSING ALL VRBLKS ON ONE CHAIN ! 16003: # ! 16004: dmp09: cmpl r6,hshte # loop back if more buckets to go ! 16005: beqlu 0f ! 16006: jmp dmp00 ! 16007: 0: ! 16008: # ! 16009: # LOOP TO GENERATE DUMP OF NATURAL VARIABLE VALUES ! 16010: # ! 16011: dmp10: movl dmvch,r9 # load pointer to next entry on chain ! 16012: tstl r9 # jump if end of chain ! 16013: beqlu dmp11 ! 16014: movl (r9),dmvch # else update chain ptr to next entry ! 16015: jsb setvr # restore vrget field ! 16016: movl r9,r10 # copy vrblk pointer (name base) ! 16017: movl $4*vrval,r6 # set offset for vrblk name ! 16018: jsb prtnv # print name = value ! 16019: jmp dmp10 # loop back till all printed ! 16020: # ! 16021: # PREPARE TO PRINT KEYWORDS ! 16022: # ! 16023: dmp11: jsb prtnl # print blank line ! 16024: jsb prtnl # and another ! 16025: movl $dmhdk,r9 # point to keyword heading ! 16026: jsb prtst # print heading ! 16027: jsb prtnl # end line ! 16028: jsb prtnl # print one blank line ! 16029: movl $vdmkw,r10 # point to list of keyword svblk ptrs ! 16030: #page ! 16031: # ! 16032: # DUMPR (CONTINUED) ! 16033: # ! 16034: # LOOP TO DUMP KEYWORD VALUES ! 16035: # ! 16036: dmp12: movl (r10)+,r9 # load next svblk ptr from table ! 16037: tstl r9 # jump if end of list ! 16038: beqlu dmp13 ! 16039: movl $ch$am,r6 # load ampersand ! 16040: jsb prtch # print ampersand ! 16041: jsb prtst # print keyword name ! 16042: movl 4*svlen(r9),r6 # load name length from svblk ! 16043: movab 3+(4*svchs)(r6),r6 # get length of name ! 16044: bicl2 $3,r6 ! 16045: addl2 r6,r9 # point to svknm field ! 16046: movl (r9),dmpkn # store in dummy kvblk ! 16047: movl $tmbeb,r9 # point to blank-equal-blank ! 16048: jsb prtst # print it ! 16049: movl r10,dmpsv # save table pointer ! 16050: movl $dmpkb,r10 # point to dummy kvblk ! 16051: movl $4*kvvar,r6 # set zero offset ! 16052: jsb acess # get keyword value ! 16053: .long invalid$ # failure is impossible ! 16054: jsb prtvl # print keyword value ! 16055: jsb prtnl # terminate print line ! 16056: movl dmpsv,r10 # restore table pointer ! 16057: jmp dmp12 # loop back till all printed ! 16058: # ! 16059: # HERE AFTER COMPLETING PARTIAL DUMP ! 16060: # ! 16061: dmp13: cmpl dmarg,$num01 # exit if partial dump complete ! 16062: bnequ 0f ! 16063: jmp dmp27 ! 16064: 0: ! 16065: movl dnamb,r9 # else point to first dynamic block ! 16066: # ! 16067: # LOOP THROUGH BLOCKS IN DYNAMIC STORAGE ! 16068: # ! 16069: dmp14: cmpl r9,dnamp # jump if end of used region ! 16070: bnequ 0f ! 16071: jmp dmp27 ! 16072: 0: ! 16073: movl (r9),r6 # else load first word of block ! 16074: cmpl r6,$b$vct # jump if vector ! 16075: beqlu dmp16 ! 16076: cmpl r6,$b$art # jump if array ! 16077: beqlu dmp17 ! 16078: cmpl r6,$b$pdt # jump if program defined ! 16079: beqlu dmp18 ! 16080: cmpl r6,$b$tbt # jump if table ! 16081: beqlu dmp19 ! 16082: cmpl r6,$b$bct # jump if buffer ! 16083: bnequ 0f ! 16084: jmp dmp30 ! 16085: 0: ! 16086: # ! 16087: # MERGE HERE TO MOVE TO NEXT BLOCK ! 16088: # ! 16089: dmp15: jsb blkln # get length of block ! 16090: addl2 r6,r9 # point past this block ! 16091: jmp dmp14 # loop back for next block ! 16092: #page ! 16093: # ! 16094: # DUMPR (CONTINUED) ! 16095: # ! 16096: # HERE FOR VECTOR ! 16097: # ! 16098: dmp16: movl $4*vcvls,r7 # set offset to first value ! 16099: jmp dmp19 # jump to merge ! 16100: # ! 16101: # HERE FOR ARRAY ! 16102: # ! 16103: dmp17: movl 4*arofs(r9),r7 # set offset to arpro field ! 16104: addl2 $4,r7 # bump to get offset to values ! 16105: jmp dmp19 # jump to merge ! 16106: # ! 16107: # HERE FOR PROGRAM DEFINED ! 16108: # ! 16109: dmp18: movl $4*pdfld,r7 # point to values, merge ! 16110: # ! 16111: # HERE FOR TABLE (OTHERS MERGE) ! 16112: # ! 16113: dmp19: tstl 4*idval(r9) # ignore block if zero id value ! 16114: bnequ 0f ! 16115: jmp dmp15 ! 16116: 0: ! 16117: jsb blkln # else get block length ! 16118: movl r9,r10 # copy block pointer ! 16119: movl r6,dmpsv # save length ! 16120: movl r7,r6 # copy offset to first value ! 16121: jsb prtnl # print blank line ! 16122: movl r6,dmpsa # preserve offset ! 16123: jsb prtvl # print block value (for title) ! 16124: movl dmpsa,r6 # recover offset ! 16125: jsb prtnl # end print line ! 16126: cmpl (r9),$b$tbt # jump if table ! 16127: beqlu dmp22 ! 16128: subl2 $4,r6 # point before first word ! 16129: # ! 16130: # LOOP TO PRINT CONTENTS OF ARRAY, VECTOR, OR PROGRAM DEF ! 16131: # ! 16132: dmp20: movl r10,r9 # copy block pointer ! 16133: addl2 $4,r6 # bump offset ! 16134: addl2 r6,r9 # point to next value ! 16135: cmpl r6,dmpsv # exit if end (xr past block) ! 16136: bnequ 0f ! 16137: jmp dmp14 ! 16138: 0: ! 16139: subl2 $4*vrval,r9 # subtract offset to merge into loop ! 16140: # ! 16141: # LOOP TO FIND VALUE AND IGNORE NULLS ! 16142: # ! 16143: dmp21: movl 4*vrval(r9),r9 # load next value ! 16144: cmpl r9,$nulls # loop back if null value ! 16145: beqlu dmp20 ! 16146: cmpl (r9),$b$trt # loop back if trapped ! 16147: beqlu dmp21 ! 16148: jsb prtnv # else print name = value ! 16149: jmp dmp20 # loop back for next field ! 16150: #page ! 16151: # ! 16152: # DUMPR (CONTINUED) ! 16153: # ! 16154: # HERE TO DUMP A TABLE ! 16155: # ! 16156: dmp22: movl $4*tbbuk,r8 # set offset to first bucket ! 16157: movl $4*teval,r6 # set name offset for all teblks ! 16158: # ! 16159: # LOOP THROUGH TABLE BUCKETS ! 16160: # ! 16161: dmp23: movl r10,-(sp) # save tbblk pointer ! 16162: addl2 r8,r10 # point to next bucket header ! 16163: addl2 $4,r8 # bump bucket offset ! 16164: subl2 $4*tenxt,r10 # subtract offset to merge into loop ! 16165: # ! 16166: # LOOP TO PROCESS TEBLKS ON ONE CHAIN ! 16167: # ! 16168: dmp24: movl 4*tenxt(r10),r10# point to next teblk ! 16169: cmpl r10,(sp) # jump if end of chain ! 16170: beqlu dmp26 ! 16171: movl r10,r9 # else copy teblk pointer ! 16172: # ! 16173: # LOOP TO FIND VALUE AND IGNORE IF NULL ! 16174: # ! 16175: dmp25: movl 4*teval(r9),r9 # load next value ! 16176: cmpl r9,$nulls # ignore if null value ! 16177: beqlu dmp24 ! 16178: cmpl (r9),$b$trt # loop back if trapped ! 16179: beqlu dmp25 ! 16180: movl r8,dmpsv # else save offset pointer ! 16181: jsb prtnv # print name = value ! 16182: movl dmpsv,r8 # reload offset ! 16183: jmp dmp24 # loop back for next teblk ! 16184: # ! 16185: # HERE TO MOVE TO NEXT HASH CHAIN ! 16186: # ! 16187: dmp26: movl (sp)+,r10 # restore tbblk pointer ! 16188: cmpl r8,4*tblen(r10) # loop back if more buckets to go ! 16189: bnequ dmp23 ! 16190: movl r10,r9 # else copy table pointer ! 16191: addl2 r8,r9 # point to following block ! 16192: jmp dmp14 # loop back to process next block ! 16193: # ! 16194: # HERE AFTER COMPLETING DUMP ! 16195: # ! 16196: dmp27: jsb prtpg # eject printer ! 16197: # ! 16198: # MERGE HERE IF NO DUMP GIVEN (DMARG=0) ! 16199: # ! 16200: dmp28: rsb # return to dump caller ! 16201: # ! 16202: # CALL SYSTEM CORE DUMP ROUTINE ! 16203: # ! 16204: dmp29: jsb sysdm # call it ! 16205: jmp dmp28 # return ! 16206: #page ! 16207: # ! 16208: # DUMPR (CONTINUED) ! 16209: # ! 16210: # HERE TO DUMP BUFFER BLOCK ! 16211: # ! 16212: dmp30: jsb prtnl # print blank line ! 16213: jsb prtvl # print value id for title ! 16214: jsb prtnl # force new line ! 16215: movl $ch$dq,r6 # load double quote ! 16216: jsb prtch # print it ! 16217: movl 4*bclen(r9),r8 # load defined length ! 16218: tstl r8 # skip characters if none ! 16219: beqlu dmp32 ! 16220: # load count for loop ! 16221: movl r9,r7 # save bcblk ptr ! 16222: movl 4*bcbuf(r9),r9 # point to bfblk ! 16223: movab cfp$f(r9),r9 # get set to load characters ! 16224: # ! 16225: # LOOP HERE STUFFING CHARACTERS IN OUTPUT STREAM ! 16226: # ! 16227: dmp31: movzbl (r9)+,r6 # get next character ! 16228: jsb prtch # stuff it ! 16229: sobgtr r8,dmp31 # branch for next one ! 16230: movl r7,r9 # restore bcblk pointer ! 16231: # ! 16232: # MERGE TO STUFF CLOSING QUOTE MARK ! 16233: # ! 16234: dmp32: movl $ch$dq,r6 # stuff quote ! 16235: jsb prtch # print it ! 16236: jsb prtnl # print new line ! 16237: movl (r9),r6 # get first wd for blkln ! 16238: jmp dmp15 # merge to get next block ! 16239: #enp # end procedure dumpr ! 16240: #page ! 16241: # ! 16242: # ERMSG -- PRINT ERROR CODE AND ERROR MESSAGE ! 16243: # ! 16244: # KVERT ERROR CODE ! 16245: # JSR ERMSG CALL TO PRINT MESSAGE ! 16246: # (XR,XL,WA,WB,WC,IA) DESTROYED ! 16247: # ! 16248: ermsg: #prc # entry point ! 16249: jsb prtis # print error ptr or blank line ! 16250: movl kvert,r6 # load error code ! 16251: movl $ermms,r9 # point to error message /error/ ! 16252: jsb prtst # print it ! 16253: jsb ertex # get error message text ! 16254: addl2 $thsnd,r6 # bump error code for print ! 16255: movl r6,r5 # fail code in int acc ! 16256: jsb prtin # print code (now have error1xxx) ! 16257: movl prbuf,r10 # point to print buffer ! 16258: movl $num05,r11 # [get in scratch register] ! 16259: movab cfp$f(r10)[r11],r10 # point to the 1 ! 16260: movl $ch$bl,r6 # load a blank ! 16261: movb r6,(r10) # store blank over 1 (error xxx) ! 16262: #csc r10 # complete store characters ! 16263: clrl r10 # clear garbage pointer in xl ! 16264: movl r9,r6 # keep error text ! 16265: movl $ermns,r9 # point to / -- / ! 16266: jsb prtst # print it ! 16267: movl r6,r9 # get error text again ! 16268: jsb prtst # print error message text ! 16269: jsb prtis # print line ! 16270: jsb prtis # print blank line ! 16271: rsb # return to ermsg caller ! 16272: #enp # end procedure ermsg ! 16273: #page ! 16274: # ! 16275: # ERTEX -- GET ERROR MESSAGE TEXT ! 16276: # ! 16277: # (WA) ERROR CODE ! 16278: # JSR ERTEX CALL TO GET ERROR TEXT ! 16279: # (XR) PTR TO ERROR TEXT IN DYNAMIC ! 16280: # (R$ETX) COPY OF PTR TO ERROR TEXT ! 16281: # (XL,WC,IA) DESTROYED ! 16282: # ! 16283: ertex: #prc # entry point ! 16284: movl r6,ertwa # save wa ! 16285: movl r7,ertwb # save wb ! 16286: jsb sysem # get failure message text ! 16287: movl r9,r10 # copy pointer to it ! 16288: movl 4*sclen(r9),r6 # get length of string ! 16289: tstl r6 # jump if null ! 16290: beqlu ert02 ! 16291: clrl r7 # offset of zero ! 16292: jsb sbstr # copy into dynamic store ! 16293: movl r9,r$etx # store for relocation ! 16294: # ! 16295: # RETURN ! 16296: # ! 16297: ert01: movl ertwb,r7 # restore wb ! 16298: movl ertwa,r6 # restore wa ! 16299: rsb # return to caller ! 16300: # ! 16301: # RETURN ERRTEXT CONTENTS INSTEAD OF NULL ! 16302: # ! 16303: ert02: movl r$etx,r9 # get errtext ! 16304: jmp ert01 # return ! 16305: #enp ! 16306: #page ! 16307: # ! 16308: # EVALI -- EVALUATE INTEGER ARGUMENT ! 16309: # ! 16310: # EVALI IS USED BY PATTERN PRIMITIVES LEN,TAB,RTAB,POS,RPOS ! 16311: # WHEN THEIR ARGUMENT IS AN EXPRESSION VALUE. ! 16312: # ! 16313: # (XR) NODE POINTER ! 16314: # (WB) CURSOR ! 16315: # JSR EVALI CALL TO EVALUATE INTEGER ! 16316: # PPM LOC TRANSFER LOC FOR NON-INTEGER ARG ! 16317: # PPM LOC TRANSFER LOC FOR OUT OF RANGE ARG ! 16318: # PPM LOC TRANSFER LOC FOR EVALUATION FAILURE ! 16319: # PPM LOC TRANSFER LOC FOR SUCCESSFUL EVAL ! 16320: # (THE NORMAL RETURN IS NEVER TAKEN) ! 16321: # (XR) PTR TO NODE WITH INTEGER ARGUMENT ! 16322: # (WC,XL,RA) DESTROYED ! 16323: # ! 16324: # ON RETURN, THE NODE POINTED TO HAS THE INTEGER ARGUMENT ! 16325: # IN PARM1 AND THE PROPER SUCCESSOR POINTER IN PTHEN. ! 16326: # THIS ALLOWS MERGING WITH THE NORMAL (INTEGER ARG) CASE. ! 16327: # ! 16328: evali: #prc # entry point (recursive) ! 16329: jsb evalp # evaluate expression ! 16330: .long evli1 # jump on failure ! 16331: movl r10,-(sp) # stack result for gtsmi ! 16332: movl 4*pthen(r9),r10 # load successor pointer ! 16333: jsb gtsmi # convert arg to small integer ! 16334: .long evli2 # jump if not integer ! 16335: .long evli3 # jump if out of range ! 16336: movl r9,evliv # store result in special dummy node ! 16337: movl r10,evlis # store successor pointer ! 16338: movl $evlin,r9 # point to dummy node with result ! 16339: addl3 $4*3,(sp)+,r11 # take successful exit ! 16340: jmp *(r11)+ ! 16341: # ! 16342: # HERE IF EVALUATION FAILS ! 16343: # ! 16344: evli1: addl3 $4*2,(sp)+,r11 # take failure return ! 16345: jmp *(r11)+ ! 16346: # ! 16347: # HERE IF ARGUMENT IS NOT INTEGER ! 16348: # ! 16349: evli2: movl (sp)+,r11 # take non-integer error exit ! 16350: jmp *(r11)+ ! 16351: # ! 16352: # HERE IF ARGUMENT IS OUT OF RANGE ! 16353: # ! 16354: evli3: addl3 $4*1,(sp)+,r11 # take out-of-range error exit ! 16355: jmp *(r11)+ ! 16356: #enp # end procedure evali ! 16357: #page ! 16358: # ! 16359: # EVALP -- EVALUATE EXPRESSION DURING PATTERN MATCH ! 16360: # ! 16361: # EVALP IS USED TO EVALUATE AN EXPRESSION (BY VALUE) DURING ! 16362: # A PATTERN MATCH. THE EFFECT IS LIKE EVALX, BUT PATTERN ! 16363: # VARIABLES ARE STACKED AND RESTORED IF NECESSARY. ! 16364: # ! 16365: # EVALP ALSO DIFFERS FROM EVALX IN THAT IF THE RESULT IS ! 16366: # AN EXPRESSION IT IS REEVALUATED. THIS OCCURS REPEATEDLY. ! 16367: # ! 16368: # (XR) NODE POINTER ! 16369: # (WB) PATTERN MATCH CURSOR ! 16370: # JSR EVALP CALL TO EVALUATE EXPRESSION ! 16371: # PPM LOC TRANSFER LOC IF EVALUATION FAILS ! 16372: # (XL) RESULT ! 16373: # (WA) FIRST WORD OF RESULT BLOCK ! 16374: # (XR,WB) DESTROYED (FAILURE CASE ONLY) ! 16375: # (WC,RA) DESTROYED ! 16376: # ! 16377: # THE EXPRESSION POINTER IS STORED IN PARM1 OF THE NODE ! 16378: # ! 16379: # CONTROL RETURNS TO FAILP ON FAILURE OF EVALUATION ! 16380: # ! 16381: evalp: #prc # entry point (recursive) ! 16382: movl 4*parm1(r9),r10 # load expression pointer ! 16383: cmpl (r10),$b$exl # jump if exblk case ! 16384: beqlu evlp1 ! 16385: # ! 16386: # HERE FOR CASE OF SEBLK ! 16387: # ! 16388: # WE CAN GIVE A FAST RETURN IF THE VALUE OF THE VRBLK IS ! 16389: # NOT AN EXPRESSION AND IS NOT TRAPPED. ! 16390: # ! 16391: movl 4*sevar(r10),r10# load vrblk pointer ! 16392: movl 4*vrval(r10),r10# load value of vrblk ! 16393: movl (r10),r6 # load first word of value ! 16394: cmpl r6,$b$t$$ # jump if not seblk, trblk or exblk ! 16395: bgequ evlp3 ! 16396: # ! 16397: # HERE FOR EXBLK OR SEBLK WITH EXPR VALUE OR TRAPPED VALUE ! 16398: # ! 16399: evlp1: movl r9,-(sp) # stack node pointer ! 16400: movl r7,-(sp) # stack cursor ! 16401: movl r$pms,-(sp) # stack subject string pointer ! 16402: movl pmssl,-(sp) # stack subject string length ! 16403: movl pmdfl,-(sp) # stack dot flag ! 16404: movl pmhbs,-(sp) # stack history stack base pointer ! 16405: movl 4*parm1(r9),r9 # load expression pointer ! 16406: #page ! 16407: # ! 16408: # EVALP (CONTINUED) ! 16409: # ! 16410: # LOOP BACK HERE TO REEVALUATE EXPRESSION RESULT ! 16411: # ! 16412: evlp2: clrl r7 # set flag for by value ! 16413: jsb evalx # evaluate expression ! 16414: .long evlp4 # jump on failure ! 16415: movl (r9),r6 # else load first word of value ! 16416: cmpl r6,$b$e$$ # loop back to reevaluate expression ! 16417: blequ evlp2 ! 16418: # ! 16419: # HERE TO RESTORE PATTERN VALUES AFTER SUCCESSFUL EVAL ! 16420: # ! 16421: movl r9,r10 # copy result pointer ! 16422: movl (sp)+,pmhbs # restore history stack base pointer ! 16423: movl (sp)+,pmdfl # restore dot flag ! 16424: movl (sp)+,pmssl # restore subject string length ! 16425: movl (sp)+,r$pms # restore subject string pointer ! 16426: movl (sp)+,r7 # restore cursor ! 16427: movl (sp)+,r9 # restore node pointer ! 16428: # ! 16429: # COMMON EXIT POINT ! 16430: # ! 16431: evlp3: addl2 $4*1,(sp) # return to evalp caller ! 16432: rsb ! 16433: # ! 16434: # HERE FOR FAILURE DURING EVALUATION ! 16435: # ! 16436: evlp4: movl (sp)+,pmhbs # restore history stack base pointer ! 16437: movl (sp)+,pmdfl # restore dot flag ! 16438: movl (sp)+,pmssl # restore subject string length ! 16439: movl (sp)+,r$pms # restore subject string pointer ! 16440: addl2 $4*num02,sp # remove node ptr, cursor ! 16441: movl (sp)+,r11 # take failure exit ! 16442: jmp *(r11)+ ! 16443: #enp # end procedure evalp ! 16444: #page ! 16445: # ! 16446: # EVALS -- EVALUATE STRING ARGUMENT ! 16447: # ! 16448: # EVALS IS USED BY SPAN, ANY, NOTANY, BREAK, BREAKX WHEN ! 16449: # THEY ARE PASSED AN EXPRESSION ARGUMENT. ! 16450: # ! 16451: # (XR) NODE POINTER ! 16452: # (WB) CURSOR ! 16453: # JSR EVALS CALL TO EVALUATE STRING ! 16454: # PPM LOC TRANSFER LOC FOR NON-STRING ARG ! 16455: # PPM LOC TRANSFER LOC FOR EVALUATION FAILURE ! 16456: # PPM LOC TRANSFER LOC FOR SUCCESSFUL EVAL ! 16457: # (THE NORMAL RETURN IS NEVER TAKEN) ! 16458: # (XR) PTR TO NODE WITH PARMS SET ! 16459: # (XL,WC,RA) DESTROYED ! 16460: # ! 16461: # ON RETURN, THE NODE POINTED TO HAS A CHARACTER TABLE ! 16462: # POINTER IN PARM1 AND A BIT MASK IN PARM2. THE PROPER ! 16463: # SUCCESSOR IS STORED IN PTHEN OF THIS NODE. THUS IT IS ! 16464: # OK FOR MERGING WITH THE NORMAL (MULTI-CHAR STRING) CASE. ! 16465: # ! 16466: evals: #prc # entry point (recursive) ! 16467: jsb evalp # evaluate expression ! 16468: .long evls1 # jump if evaluation fails ! 16469: movl 4*pthen(r9),-(sp)# save successor pointer ! 16470: movl r7,-(sp) # save cursor ! 16471: movl r10,-(sp) # stack result ptr for patst ! 16472: clrl r7 # dummy pcode for one char string ! 16473: clrl r8 # dummy pcode for expression arg ! 16474: movl $p$brk,r10 # appropriate pcode for our use ! 16475: jsb patst # call routine to build node ! 16476: .long evls2 # jump if not string ! 16477: movl (sp)+,r7 # restore cursor ! 16478: movl (sp)+,4*pthen(r9)# store successor pointer ! 16479: addl3 $4*2,(sp)+,r11 # take success return ! 16480: jmp *(r11)+ ! 16481: # ! 16482: # HERE IF EVALUATION FAILS ! 16483: # ! 16484: evls1: addl3 $4*1,(sp)+,r11 # take failure return ! 16485: jmp *(r11)+ ! 16486: # ! 16487: # HERE IF ARGUMENT IS NOT STRING ! 16488: # ! 16489: evls2: addl2 $4*num02,sp # pop successor and cursor ! 16490: movl (sp)+,r11 # take non-string error exit ! 16491: jmp *(r11)+ ! 16492: #enp # end procedure evals ! 16493: #page ! 16494: # ! 16495: # EVALX -- EVALUATE EXPRESSION ! 16496: # ! 16497: # EVALX IS CALLED TO EVALUATE AN EXPRESSION ! 16498: # ! 16499: # (XR) POINTER TO EXBLK OR SEBLK ! 16500: # (WB) 0 IF BY VALUE, 1 IF BY NAME ! 16501: # JSR EVALX CALL TO EVALUATE EXPRESSION ! 16502: # PPM LOC TRANSFER LOC IF EVALUATION FAILS ! 16503: # (XR) RESULT IF CALLED BY VALUE ! 16504: # (XL,WA) RESULT NAME BASE,OFFSET IF BY NAME ! 16505: # (XR) DESTROYED (NAME CASE ONLY) ! 16506: # (XL,WA) DESTROYED (VALUE CASE ONLY) ! 16507: # (WB,WC,RA) DESTROYED ! 16508: # ! 16509: evalx: #prc # entry point, recursive ! 16510: cmpl (r9),$b$exl # jump if exblk case ! 16511: beqlu evlx2 ! 16512: # ! 16513: # HERE FOR SEBLK ! 16514: # ! 16515: movl 4*sevar(r9),r10 # load vrblk pointer (name base) ! 16516: movl $4*vrval,r6 # set name offset ! 16517: tstl r7 # jump if called by name ! 16518: beqlu 0f ! 16519: jmp evlx1 ! 16520: 0: ! 16521: jsb acess # call routine to access value ! 16522: .long evlx9 # jump if failure on access ! 16523: # ! 16524: # MERGE HERE TO EXIT FOR SEBLK CASE ! 16525: # ! 16526: evlx1: addl2 $4*1,(sp) # return to evalx caller ! 16527: rsb ! 16528: #page ! 16529: # ! 16530: # EVALX (CONTINUED) ! 16531: # ! 16532: # HERE FOR FULL EXPRESSION (EXBLK) CASE ! 16533: # ! 16534: # IF AN ERROR OCCURS IN THE EXPRESSION CODE AT EXECUTION ! 16535: # TIME, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL ! 16536: # WITHOUT RETURNING TO THIS ROUTINE. ! 16537: # THE FOLLOWING ENTRIES ARE MADE ON THE STACK BEFORE ! 16538: # GIVING CONTROL TO THE EXPRESSION CODE ! 16539: # ! 16540: # EVALX RETURN POINT ! 16541: # SAVED VALUE OF R$COD ! 16542: # CODE POINTER (-R$COD) ! 16543: # SAVED VALUE OF FLPTR ! 16544: # 0 IF BY VALUE, 1 IF BY NAME ! 16545: # FLPTR --------------- *EXFLC, FAIL OFFSET IN EXBLK ! 16546: # ! 16547: evlx2: movl r3,r8 # get code pointer ! 16548: movl r$cod,r6 # load code block pointer ! 16549: subl2 r6,r8 # get code pointer as offset ! 16550: movl r6,-(sp) # stack old code block pointer ! 16551: movl r8,-(sp) # stack relative code offset ! 16552: movl flptr,-(sp) # stack old failure pointer ! 16553: movl r7,-(sp) # stack name/value indicator ! 16554: movl $4*exflc,-(sp) # stack new fail offset ! 16555: movl flptr,gtcef # keep in case of error ! 16556: movl r$cod,r$gtc # keep code block pointer similarly ! 16557: movl sp,flptr # set new failure pointer ! 16558: movl r9,r$cod # set new code block pointer ! 16559: movl kvstn,4*exstm(r9)# remember stmnt number ! 16560: addl2 $4*excod,r9 # point to first code word ! 16561: movl r9,r3 # set code pointer ! 16562: cmpl stage,$stgxt # jump if not execution time ! 16563: beqlu 0f ! 16564: jmp exits ! 16565: 0: ! 16566: movl $stgee,stage # evaluating expression ! 16567: jmp exits # jump to execute first code word ! 16568: #page ! 16569: # ! 16570: # EVALX (CONTINUED) ! 16571: # ! 16572: # COME HERE IF SUCCESSFUL RETURN BY VALUE (SEE O$RVL) ! 16573: # ! 16574: evlx3: movl (sp)+,r9 # load value ! 16575: tstl 4*1(sp) # jump if called by value ! 16576: beqlu evlx5 ! 16577: jmp er_249 # expression evaluated by name returned value ! 16578: # ! 16579: # HERE FOR EXPRESSION RETURNING BY NAME (SEE O$RNM) ! 16580: # ! 16581: evlx4: movl (sp)+,r6 # load name offset ! 16582: movl (sp)+,r10 # load name base ! 16583: tstl 4*1(sp) # jump if called by name ! 16584: bnequ evlx5 ! 16585: jsb acess # else access value first ! 16586: .long evlx6 # jump if failure during access ! 16587: # ! 16588: # HERE AFTER LOADING CORRECT RESULT INTO XR OR XL,WA ! 16589: # ! 16590: evlx5: clrl r7 # note successful ! 16591: jmp evlx7 # merge ! 16592: # ! 16593: # HERE FOR FAILURE IN EXPRESSION EVALUATION (SEE O$FEX) ! 16594: # ! 16595: evlx6: movl sp,r7 # note unsuccessful ! 16596: # ! 16597: # RESTORE ENVIRONMENT ! 16598: # ! 16599: evlx7: cmpl stage,$stgee # skip if was not previously xt ! 16600: bnequ evlx8 ! 16601: movl $stgxt,stage # execute time ! 16602: # ! 16603: # MERGE WITH STAGE SET UP ! 16604: # ! 16605: evlx8: addl2 $4*num02,sp # pop name/value indicator, *exfal ! 16606: movl (sp)+,flptr # restore old failure pointer ! 16607: movl (sp)+,r8 # load code offset ! 16608: addl2 (sp),r8 # make code pointer absolute ! 16609: movl (sp)+,r$cod # restore old code block pointer ! 16610: movl r8,r3 # restore old code pointer ! 16611: tstl r7 # jump for successful return ! 16612: bnequ 0f ! 16613: jmp evlx1 ! 16614: 0: ! 16615: # ! 16616: # MERGE HERE FOR FAILURE IN SEBLK CASE ! 16617: # ! 16618: evlx9: movl (sp)+,r11 # take failure exit ! 16619: jmp *(r11)+ ! 16620: #enp # end of procedure evalx ! 16621: #page ! 16622: # ! 16623: # EXBLD -- BUILD EXBLK ! 16624: # ! 16625: # EXBLD IS USED TO BUILD AN EXPRESSION BLOCK FROM THE ! 16626: # CODE COMPILED MOST RECENTLY IN THE CURRENT CCBLK. ! 16627: # ! 16628: # (XL) OFFSET IN CCBLK TO START OF CODE ! 16629: # (WB) INTEGER IN RANGE 0 LE N LE MXLEN ! 16630: # JSR EXBLD CALL TO BUILD EXBLK ! 16631: # (XR) PTR TO CONSTRUCTED EXBLK ! 16632: # (WA,WB,XL) DESTROYED ! 16633: # ! 16634: exbld: #prc # entry point ! 16635: movl r10,r6 # copy offset to start of code ! 16636: subl2 $4*excod,r6 # calc reduction in offset in exblk ! 16637: movl r6,-(sp) # stack for later ! 16638: movl cwcof,r6 # load final offset ! 16639: subl2 r10,r6 # compute length of code ! 16640: addl2 $4*exsi$,r6 # add space for standard fields ! 16641: jsb alloc # allocate space for exblk ! 16642: movl r9,-(sp) # save pointer to exblk ! 16643: movl $b$exl,4*extyp(r9) # store type word ! 16644: clrl 4*exstm(r9) # zeroise stmnt number field ! 16645: movl r6,4*exlen(r9) # store length ! 16646: movl $ofex$,4*exflc(r9) # store failure word ! 16647: addl2 $4*exsi$,r9 # set xr for sysmw ! 16648: movl r10,cwcof # reset offset to start of code ! 16649: addl2 r$ccb,r10 # point to start of code ! 16650: subl2 $4*exsi$,r6 # length of code to move ! 16651: movl r6,-(sp) # stack length of code ! 16652: jsb sbmvw # move code to exblk ! 16653: movl (sp)+,r6 # get length of code ! 16654: ashl $-2,r6,r6 # convert byte count to word count ! 16655: # prepare counter for loop ! 16656: movl (sp),r10 # copy exblk ptr, dont unstack ! 16657: addl2 $4*excod,r10 # point to code itself ! 16658: movl 4*1(sp),r7 # get reduction in offset ! 16659: # ! 16660: # THIS LOOP SEARCHES FOR NEGATION AND SELECTION CODE SO ! 16661: # THAT THE OFFSETS COMPUTED WHILST CODE WAS IN CODE BLOCK ! 16662: # CAN BE TRANSFORMED TO REDUCED VALUES APPLICABLE IN AN ! 16663: # EXBLK. ! 16664: # ! 16665: exbl1: movl (r10)+,r9 # get next code word ! 16666: cmpl r9,$osla$ # jump if selection found ! 16667: beqlu exbl3 ! 16668: cmpl r9,$onta$ # jump if negation found ! 16669: beqlu exbl3 ! 16670: sobgtr r6,exbl1 # loop to end of code ! 16671: # ! 16672: # NO SELECTION FOUND OR MERGE TO EXIT ON TERMINATION ! 16673: # ! 16674: exbl2: movl (sp)+,r9 # pop exblk ptr into xr ! 16675: movl (sp)+,r10 # pop reduction constant ! 16676: rsb # return to caller ! 16677: #page ! 16678: # ! 16679: # EXBLD (CONTINUED) ! 16680: # ! 16681: # SELECTION OR NEGATION FOUND ! 16682: # REDUCE THE OFFSETS AS NEEDED. OFFSETS OCCUR IN WORDS ! 16683: # FOLLOWING CODE WORDS - ! 16684: # =ONTA$, =OSLA$, =OSLB$, =OSLC$ ! 16685: # ! 16686: exbl3: subl2 r7,(r10)+ # adjust offset ! 16687: sobgtr r6,exbl4 # decrement count ! 16688: # ! 16689: exbl4: sobgtr r6,exbl5 # decrement count ! 16690: # ! 16691: # CONTINUE SEARCH FOR MORE OFFSETS ! 16692: # ! 16693: exbl5: movl (r10)+,r9 # get next code word ! 16694: cmpl r9,$osla$ # jump if offset found ! 16695: beqlu exbl3 ! 16696: cmpl r9,$oslb$ # jump if offset found ! 16697: beqlu exbl3 ! 16698: cmpl r9,$oslc$ # jump if offset found ! 16699: beqlu exbl3 ! 16700: cmpl r9,$onta$ # jump if offset found ! 16701: beqlu exbl3 ! 16702: sobgtr r6,exbl5 # loop ! 16703: jmp exbl2 # merge to return ! 16704: #enp # end procedure exbld ! 16705: #page ! 16706: # ! 16707: # EXPAN -- ANALYZE EXPRESSION ! 16708: # ! 16709: # THE EXPRESSION ANALYZER (EXPAN) PROCEDURE IS USED TO SCAN ! 16710: # AN EXPRESSION AND CONVERT IT INTO A TREE REPRESENTATION. ! 16711: # SEE DESCRIPTIONS OF CMBLK, CUBLK, CBBLK IN THE STRUCTURES ! 16712: # SECTION FOR DETAILED FORMAT OF TREE BLOCKS. ! 16713: # ! 16714: # THE ANALYZER USES A SIMPLE PRECEDENCE SCHEME IN WHICH ! 16715: # OPERANDS AND OPERATORS ARE PLACED ON A SINGLE STACK ! 16716: # AND CONDENSATIONS ARE MADE WHEN LOW PRECEDENCE OPERATORS ! 16717: # ARE STACKED AFTER A HIGHER PRECEDENCE OPERATOR. A GLOBAL ! 16718: # VARIABLE (IN WB) KEEPS TRACK OF THE LEVEL AS FOLLOWS. ! 16719: # ! 16720: # 0 SCANNING OUTER LEVEL OF STATEMENT OR EXPRESSION ! 16721: # 1 SCANNING OUTER LEVEL OF NORMAL GOTO ! 16722: # 2 SCANNING OUTER LEVEL OF DIRECT GOTO ! 16723: # 3 SCANNING INSIDE ARRAY BRACKETS ! 16724: # 4 SCANNING INSIDE GROUPING PARENTHESES ! 16725: # 5 SCANNING INSIDE FUNCTION PARENTHESES ! 16726: # ! 16727: # THIS VARIABLE IS SAVED ON THE STACK ON ENCOUNTERING A ! 16728: # GROUPING AND RESTORED AT THE END OF THE GROUPING. ! 16729: # ! 16730: # ANOTHER GLOBAL VARIABLE (IN WC) COUNTS THE NUMBER OF ! 16731: # ITEMS AT ONE GROUPING LEVEL AND IS INCREMENTED FOR EACH ! 16732: # COMMA ENCOUNTERED. IT IS STACKED WITH THE LEVEL INDICATOR ! 16733: # ! 16734: # THE SCAN IS CONTROLLED BY A THREE STATE FINITE MACHINE. ! 16735: # A GLOBAL VARIABLE STORED IN WA IS THE CURRENT STATE. ! 16736: # ! 16737: # WA=0 NOTHING SCANNED AT THIS LEVEL ! 16738: # WA=1 OPERAND EXPECTED ! 16739: # WA=2 OPERATOR EXPECTED ! 16740: # ! 16741: # (WB) CALL TYPE (SEE BELOW) ! 16742: # JSR EXPAN CALL TO ANALYZE EXPRESSION ! 16743: # (XR) POINTER TO RESULTING TREE ! 16744: # (XL,WA,WB,WC,RA) DESTROYED ! 16745: # ! 16746: # THE ENTRY VALUE OF WB INDICATES THE CALL TYPE AS FOLLOWS. ! 16747: # ! 16748: # 0 SCANNING EITHER THE MAIN BODY OF A STATEMENT OR THE ! 16749: # TEXT OF AN EXPRESSION (FROM EVAL CALL). VALID ! 16750: # TERMINATORS ARE COLON, SEMICOLON. THE RESCAN FLAG IS ! 16751: # SET TO RETURN THE TERMINATOR ON THE NEXT SCANE CALL. ! 16752: # ! 16753: # 1 SCANNING A NORMAL GOTO. THE ONLY VALID ! 16754: # TERMINATOR IS A RIGHT PAREN. ! 16755: # ! 16756: # 2 SCANNING A DIRECT GOTO. THE ONLY VALID ! 16757: # TERMINATOR IS A RIGHT BRACKET. ! 16758: #page ! 16759: # ! 16760: # EXPAN (CONTINUED) ! 16761: # ! 16762: # ENTRY POINT ! 16763: # ! 16764: expan: #prc # entry point ! 16765: clrl -(sp) # set top of stack indicator ! 16766: clrl r6 # set initial state to zero ! 16767: clrl r8 # zero counter value ! 16768: # ! 16769: # LOOP HERE FOR SUCCESSIVE ENTRIES ! 16770: # ! 16771: exp01: jsb scane # scan next element ! 16772: addl2 r6,r10 # add state to syntax code ! 16773: casel r10,$0,$t$nes # switch on element type/state ! 16774: 5: ! 16775: .word exp27-5b # unop, s=0 ! 16776: .word exp27-5b # unop, s=1 ! 16777: .word exp04-5b # unop, s=2 ! 16778: .word exp06-5b # left paren, s=0 ! 16779: .word exp06-5b # left paren, s=1 ! 16780: .word exp04-5b # left paren, s=2 ! 16781: .word exp08-5b # left brkt, s=0 ! 16782: .word exp08-5b # left brkt, s=1 ! 16783: .word exp09-5b # left brkt, s=2 ! 16784: .word exp02-5b # comma, s=0 ! 16785: .word exp05-5b # comma, s=1 ! 16786: .word exp11-5b # comma, s=2 ! 16787: .word exp10-5b # function, s=0 ! 16788: .word exp10-5b # function, s=1 ! 16789: .word exp04-5b # function, s=2 ! 16790: .word exp03-5b # variable, s=0 ! 16791: .word exp03-5b # variable, state one ! 16792: .word exp04-5b # variable, s=2 ! 16793: .word exp03-5b # constant, s=0 ! 16794: .word exp03-5b # constant, s=1 ! 16795: .word exp04-5b # constant, s=2 ! 16796: .word exp05-5b # binop, s=0 ! 16797: .word exp05-5b # binop, s=1 ! 16798: .word exp26-5b # binop, s=2 ! 16799: .word exp02-5b # right paren, s=0 ! 16800: .word exp05-5b # right paren, s=1 ! 16801: .word exp12-5b # right paren, s=2 ! 16802: .word exp02-5b # right brkt, s=0 ! 16803: .word exp05-5b # right brkt, s=1 ! 16804: .word exp18-5b # right brkt, s=2 ! 16805: .word exp02-5b # colon, s=0 ! 16806: .word exp05-5b # colon, s=1 ! 16807: .word exp19-5b # colon, s=2 ! 16808: .word exp02-5b # semicolon, s=0 ! 16809: .word exp05-5b # semicolon, s=1 ! 16810: .word exp19-5b # semicolon, s=2 ! 16811: #esw # end switch on element type/state ! 16812: #page ! 16813: # ! 16814: # EXPAN (CONTINUED) ! 16815: # ! 16816: # HERE FOR RBR,RPR,COL,SMC,CMA IN STATE 0 ! 16817: # ! 16818: # SET TO RESCAN THE TERMINATOR ENCOUNTERED AND CREATE ! 16819: # A NULL CONSTANT (CASE OF OMITTED NULL) ! 16820: # ! 16821: exp02: movl sp,scnrs # set to rescan element ! 16822: movl $nulls,r9 # point to null, merge ! 16823: # ! 16824: # HERE FOR VAR OR CON IN STATES 0,1 ! 16825: # ! 16826: # STACK THE VARIABLE/CONSTANT AND SET STATE=2 ! 16827: # ! 16828: exp03: movl r9,-(sp) # stack pointer to operand ! 16829: movl $num02,r6 # set state 2 ! 16830: jmp exp01 # jump for next element ! 16831: # ! 16832: # HERE FOR VAR,CON,LPR,FNC,UOP IN STATE 2 ! 16833: # ! 16834: # WE RESCAN THE ELEMENT AND CREATE A CONCATENATION OPERATOR ! 16835: # THIS IS THE CASE OF THE BLANK CONCATENATION OPERATOR. ! 16836: # ! 16837: exp04: movl sp,scnrs # set to rescan element ! 16838: movl $opdvc,r9 # point to concat operator dv ! 16839: tstl r7 # ok if at top level ! 16840: beqlu exp4a ! 16841: movl $opdvp,r9 # else point to unmistakable concat. ! 16842: # ! 16843: # MERGE HERE WHEN XR SET UP WITH PROPER CONCATENATION DVBLK ! 16844: # ! 16845: exp4a: tstl scnbl # merge bop if blanks, else error ! 16846: beqlu 0f ! 16847: jmp exp26 ! 16848: 0: ! 16849: decl scnse # adjust start of element location ! 16850: jmp er_220 # syntax error. missing operator ! 16851: # ! 16852: # HERE FOR CMA,RPR,RBR,COL,SMC,BOP(S=1) BOP(S=0) ! 16853: # ! 16854: # THIS IS AN ERRONOUS CONTRUCTION ! 16855: # ! 16856: exp05: decl scnse # adjust start of element location ! 16857: jmp er_221 # syntax error. missing operand ! 16858: # ! 16859: # HERE FOR LPR (S=0,1) ! 16860: # ! 16861: exp06: movl $num04,r10 # set new level indicator ! 16862: clrl r9 # set zero value for cmopn ! 16863: #page ! 16864: # ! 16865: # EXPAN (CONTINUED) ! 16866: # ! 16867: # MERGE HERE TO STORE OLD LEVEL ON STACK AND START NEW ONE ! 16868: # ! 16869: exp07: movl r9,-(sp) # stack cmopn value ! 16870: movl r8,-(sp) # stack old counter ! 16871: movl r7,-(sp) # stack old level indicator ! 16872: jsb sbchk # check for stack overflow ! 16873: clrl r6 # set new state to zero ! 16874: movl r10,r7 # set new level indicator ! 16875: movl $num01,r8 # initialize new counter ! 16876: jmp exp01 # jump to scan next element ! 16877: # ! 16878: # HERE FOR LBR (S=0,1) ! 16879: # ! 16880: # THIS IS AN ILLEGAL USE OF LEFT BRACKET ! 16881: # ! 16882: exp08: jmp er_222 # syntax error. invalid use of left bracket ! 16883: # ! 16884: # HERE FOR LBR (S=2) ! 16885: # ! 16886: # SET NEW LEVEL AND START TO SCAN SUBSCRIPTS ! 16887: # ! 16888: exp09: movl (sp)+,r9 # load array ptr for cmopn ! 16889: movl $num03,r10 # set new level indicator ! 16890: jmp exp07 # jump to stack old and start new ! 16891: # ! 16892: # HERE FOR FNC (S=0,1) ! 16893: # ! 16894: # STACK OLD LEVEL AND START TO SCAN ARGUMENTS ! 16895: # ! 16896: exp10: movl $num05,r10 # set new lev indic (xr=vrblk=cmopn) ! 16897: jmp exp07 # jump to stack old and start new ! 16898: # ! 16899: # HERE FOR CMA (S=2) ! 16900: # ! 16901: # INCREMENT ARGUMENT COUNT AND CONTINUE ! 16902: # ! 16903: exp11: incl r8 # increment counter ! 16904: jsb expdm # dump operators at this level ! 16905: clrl -(sp) # set new level for parameter ! 16906: clrl r6 # set new state ! 16907: cmpl r7,$num02 # loop back unless outer level ! 16908: blequ 0f ! 16909: jmp exp01 ! 16910: 0: ! 16911: jmp er_223 # syntax error. invalid use of comma ! 16912: #page ! 16913: # ! 16914: # EXPAN (CONTINUED) ! 16915: # ! 16916: # HERE FOR RPR (S=2) ! 16917: # ! 16918: # AT OUTER LEVEL IN A NORMAL GOTO THIS IS A TERMINATOR ! 16919: # OTHERWISE IT MUST TERMINATE A FUNCTION OR GROUPING ! 16920: # ! 16921: exp12: cmpl r7,$num01 # end of normal goto ! 16922: bnequ 0f ! 16923: jmp exp20 ! 16924: 0: ! 16925: cmpl r7,$num05 # end of function arguments ! 16926: beqlu exp13 ! 16927: cmpl r7,$num04 # end of grouping / selection ! 16928: beqlu exp14 ! 16929: jmp er_224 # syntax error. unbalanced right parenthesis ! 16930: # ! 16931: # HERE AT END OF FUNCTION ARGUMENTS ! 16932: # ! 16933: exp13: movl $c$fnc,r10 # set cmtyp value for function ! 16934: jmp exp15 # jump to build cmblk ! 16935: # ! 16936: # HERE FOR END OF GROUPING ! 16937: # ! 16938: exp14: cmpl r8,$num01 # jump if end of grouping ! 16939: beqlu exp17 ! 16940: movl $c$sel,r10 # else set cmtyp for selection ! 16941: # ! 16942: # MERGE HERE TO BUILD CMBLK FOR LEVEL JUST SCANNED AND ! 16943: # TO POP UP TO THE PREVIOUS SCAN LEVEL BEFORE CONTINUING. ! 16944: # ! 16945: exp15: jsb expdm # dump operators at this level ! 16946: movl r8,r6 # copy count ! 16947: addl2 $cmvls,r6 # add for standard fields at start ! 16948: moval 0[r6],r6 # convert length to bytes ! 16949: jsb alloc # allocate space for cmblk ! 16950: movl $b$cmt,(r9) # store type code for cmblk ! 16951: movl r10,4*cmtyp(r9) # store cmblk node type indicator ! 16952: movl r6,4*cmlen(r9) # store length ! 16953: addl2 r6,r9 # point past end of block ! 16954: # set loop counter ! 16955: # ! 16956: # LOOP TO MOVE REMAINING WORDS TO CMBLK ! 16957: # ! 16958: exp16: movl (sp)+,-(r9) # move one operand ptr from stack ! 16959: movl (sp)+,r7 # pop to old level indicator ! 16960: sobgtr r8,exp16 # loop till all moved ! 16961: #page ! 16962: # ! 16963: # EXPAN (CONTINUED) ! 16964: # ! 16965: # COMPLETE CMBLK AND STACK POINTER TO IT ON STACK ! 16966: # ! 16967: subl2 $4*cmvls,r9 # point back to start of block ! 16968: movl (sp)+,r8 # restore old counter ! 16969: movl (sp),4*cmopn(r9)# store operand ptr in cmblk ! 16970: movl r9,(sp) # stack cmblk pointer ! 16971: movl $num02,r6 # set new state ! 16972: jmp exp01 # back for next element ! 16973: # ! 16974: # HERE AT END OF A PARENTHESIZED EXPRESSION ! 16975: # ! 16976: exp17: jsb expdm # dump operators at this level ! 16977: movl (sp)+,r9 # restore xr ! 16978: movl (sp)+,r7 # restore outer level ! 16979: movl (sp)+,r8 # restore outer count ! 16980: movl r9,(sp) # store opnd over unused cmopn val ! 16981: movl $num02,r6 # set new state ! 16982: jmp exp01 # back for next ele8ent ! 16983: # ! 16984: # HERE FOR RBR (S=2) ! 16985: # ! 16986: # AT OUTER LEVEL IN A DIRECT GOTO, THIS IS A TERMINATOR. ! 16987: # OTHERWISE IT MUST TERMINATE A SUBSCRIPT LIST. ! 16988: # ! 16989: exp18: movl $c$arr,r10 # set cmtyp for array reference ! 16990: cmpl r7,$num03 # jump to build cmblk if end arrayref ! 16991: beqlu exp15 ! 16992: cmpl r7,$num02 # jump if end of direct goto ! 16993: bnequ 0f ! 16994: jmp exp20 ! 16995: 0: ! 16996: jmp er_225 # syntax error. unbalanced right bracket ! 16997: #page ! 16998: # ! 16999: # EXPAN (CONTINUED) ! 17000: # ! 17001: # HERE FOR COL,SMC (S=2) ! 17002: # ! 17003: # ERROR UNLESS TERMINATING STATEMENT BODY AT OUTER LEVEL ! 17004: # ! 17005: exp19: movl sp,scnrs # rescan terminator ! 17006: movl r7,r10 # copy level indicator ! 17007: casel r10,$0,$6 # switch on level indicator ! 17008: 5: ! 17009: .word exp20-5b # normal outer level ! 17010: .word exp22-5b # fail if normal goto ! 17011: .word exp23-5b # fail if direct goto ! 17012: .word exp24-5b # fail array brackets ! 17013: .word exp21-5b # fail if in grouping ! 17014: .word exp21-5b # fail function args ! 17015: #esw # end switch on level ! 17016: # ! 17017: # HERE AT NORMAL END OF EXPRESSION ! 17018: # ! 17019: exp20: jsb expdm # dump remaining operators ! 17020: movl (sp)+,r9 # load tree pointer ! 17021: addl2 $4,sp # pop off bottom of stack marker ! 17022: rsb # return to expan caller ! 17023: # ! 17024: # MISSING RIGHT PAREN ! 17025: # ! 17026: exp21: jmp er_226 # syntax error. missing right paren ! 17027: # ! 17028: # MISSING RIGHT PAREN IN GOTO FIELD ! 17029: # ! 17030: exp22: jmp er_227 # syntax error. right paren missing from goto ! 17031: # ! 17032: # MISSING BRACKET IN GOTO ! 17033: # ! 17034: exp23: jmp er_228 # syntax error. right bracket missing from goto ! 17035: # ! 17036: # MISSING ARRAY BRACKET ! 17037: # ! 17038: exp24: jmp er_229 # syntax error. missing right array bracket ! 17039: #page ! 17040: # ! 17041: # EXPAN (CONTINUED) ! 17042: # ! 17043: # LOOP HERE WHEN AN OPERATOR CAUSES AN OPERATOR DUMP ! 17044: # ! 17045: exp25: movl r9,expsv ! 17046: jsb expop # pop one operator ! 17047: movl expsv,r9 # restore op dv pointer and merge ! 17048: # ! 17049: # HERE FOR BOP (S=2) ! 17050: # ! 17051: # REMOVE OPERATORS (CONDENSE) FROM STACK UNTIL NO MORE ! 17052: # LEFT AT THIS LEVEL OR TOP ONE HAS LOWER PRECEDENCE. ! 17053: # LOOP HERE TILL THIS CONDITION IS MET. ! 17054: # ! 17055: exp26: movl 4*1(sp),r10 # load operator dvptr from stack ! 17056: cmpl r10,$num05 # jump if bottom of stack level ! 17057: blequ exp27 ! 17058: cmpl 4*dvrpr(r9),4*dvlpr(r10) # else pop if new prec is lo ! 17059: blssu exp25 ! 17060: # ! 17061: # HERE FOR UOP (S=0,1) ! 17062: # ! 17063: # BINARY OPERATOR MERGES AFTER PRECEDENCE CHECK ! 17064: # ! 17065: # THE OPERATOR DV IS STORED ON THE STACK AND THE SCAN ! 17066: # CONTINUES AFTER SETTING THE SCAN STATE TO ONE. ! 17067: # ! 17068: exp27: movl r9,-(sp) # stack operator dvptr on stack ! 17069: jsb sbchk # check for stack overflow ! 17070: movl $num01,r6 # set new state ! 17071: cmpl r9,$opdvs # back for next element unless = ! 17072: beqlu 0f ! 17073: jmp exp01 ! 17074: 0: ! 17075: # ! 17076: # HERE FOR SPECIAL CASE OF BINARY =. THE SYNTAX ALLOWS A ! 17077: # NULL RIGHT ARGUMENT FOR THIS OPERATOR TO BE LEFT ! 17078: # OUT. ACCORDINGLY WE RESET TO STATE ZERO TO GET PROPER ! 17079: # ACTION ON A TERMINATOR (SUPPLY A NULL CONSTANT). ! 17080: # ! 17081: clrl r6 # set state zero ! 17082: jmp exp01 # jump for next element ! 17083: #enp # end procedure expan ! 17084: #page ! 17085: # ! 17086: # EXPAP -- TEST FOR PATTERN MATCH TREE ! 17087: # ! 17088: # EXPAP IS PASSED AN EXPRESSION TREE TO DETERMINE IF IT ! 17089: # IS A PATTERN MATCH. THE FOLLOWING ARE RECOGIZED AS ! 17090: # MATCHES IN THE CONTEXT OF THIS CALL. ! 17091: # ! 17092: # 1) AN EXPLICIT USE OF BINARY QUESTION MARK ! 17093: # 2) A CONCATENATION ! 17094: # 3) AN ALTERNATION WHOSE LEFT OPERAND IS A CONCATENATION ! 17095: # ! 17096: # (XR) PTR TO EXPAN TREE ! 17097: # JSR EXPAP CALL TO TEST FOR PATTERN MATCH ! 17098: # PPM LOC TRANSFER LOC IF NOT A PATTERN MATCH ! 17099: # (WA) DESTROYED ! 17100: # (XR) UNCHANGED (IF NOT MATCH) ! 17101: # (XR) PTR TO BINARY OPERATOR BLK IF MATCH ! 17102: # ! 17103: expap: #prc # entry point ! 17104: movl r10,-(sp) # save xl ! 17105: cmpl (r9),$b$cmt # no match if not complex ! 17106: bnequ expp2 ! 17107: movl 4*cmtyp(r9),r6 # else load type code ! 17108: cmpl r6,$c$cnc # concatenation is a match ! 17109: beqlu expp1 ! 17110: cmpl r6,$c$pmt # binary question mark is a match ! 17111: beqlu expp1 ! 17112: cmpl r6,$c$alt # else not match unless alternation ! 17113: bnequ expp2 ! 17114: # ! 17115: # HERE FOR ALTERNATION. CHANGE (A B) / C TO A QM (B / C) ! 17116: # ! 17117: movl 4*cmlop(r9),r10 # load left operand pointer ! 17118: cmpl (r10),$b$cmt # not match if left opnd not complex ! 17119: bnequ expp2 ! 17120: cmpl 4*cmtyp(r10),$c$cnc # not match if left op not conc ! 17121: bnequ expp2 ! 17122: movl 4*cmrop(r10),4*cmlop(r9) # xr points to (b / c) ! 17123: movl r9,4*cmrop(r10) # set xl opnds to a, (b / c) ! 17124: movl r10,r9 # point to this altered node ! 17125: # ! 17126: # EXIT HERE FOR PATTERN MATCH ! 17127: # ! 17128: expp1: movl (sp)+,r10 # restore entry xl ! 17129: addl2 $4*1,(sp) # give pattern match return ! 17130: rsb ! 17131: # ! 17132: # EXIT HERE IF NOT PATTERN MATCH ! 17133: # ! 17134: expp2: movl (sp)+,r10 # restore entry xl ! 17135: movl (sp)+,r11 # give non-match return ! 17136: jmp *(r11)+ ! 17137: #enp # end procedure expap ! 17138: #page ! 17139: # ! 17140: # EXPDM -- DUMP OPERATORS AT CURRENT LEVEL (FOR EXPAN) ! 17141: # ! 17142: # EXPDM USES EXPOP TO CONDENSE ALL OPERATORS AT THIS SYNTAX ! 17143: # LEVEL. THE STACK BOTTOM IS RECOGNIZED FROM THE LEVEL ! 17144: # VALUE WHICH IS SAVED ON THE TOP OF THE STACK. ! 17145: # ! 17146: # JSR EXPDM CALL TO DUMP OPERATORS ! 17147: # (XS) POPPED AS REQUIRED ! 17148: # (XR,WA) DESTROYED ! 17149: # ! 17150: .data 1 ! 17151: expdm_s: .long 0 ! 17152: .text 0 ! 17153: expdm: movl (sp)+,expdm_s # entry point ! 17154: movl r10,r$exs # save xl value ! 17155: # ! 17156: # LOOP TO DUMP OPERATORS ! 17157: # ! 17158: exdm1: cmpl 4*1(sp),$num05 # jump if stack bottom (saved level ! 17159: blequ exdm2 ! 17160: jsb expop # else pop one operator ! 17161: jmp exdm1 # and loop back ! 17162: # ! 17163: # HERE AFTER POPPING ALL OPERATORS ! 17164: # ! 17165: exdm2: movl r$exs,r10 # restore xl ! 17166: clrl r$exs # release save location ! 17167: jmp *expdm_s # return to expdm caller ! 17168: #enp # end procedure expdm ! 17169: #page ! 17170: # ! 17171: # EXPOP-- POP OPERATOR (FOR EXPAN) ! 17172: # ! 17173: # EXPOP IS USED BY THE EXPAN ROUTINE TO CONDENSE ONE ! 17174: # OPERATOR FROM THE TOP OF THE SYNTAX STACK. AN APPROPRIATE ! 17175: # CMBLK IS BUILT FOR THE OPERATOR (UNARY OR BINARY) AND A ! 17176: # POINTER TO THIS CMBLK IS STACKED. ! 17177: # ! 17178: # EXPOP IS ALSO USED BY SCNGF (GOTO FIELD SCAN) PROCEDURE ! 17179: # ! 17180: # JSR EXPOP CALL TO POP OPERATOR ! 17181: # (XS) POPPED APPROPRIATELY ! 17182: # (XR,XL,WA) DESTROYED ! 17183: # ! 17184: .data 1 ! 17185: expop_s: .long 0 ! 17186: .text 0 ! 17187: expop: movl (sp)+,expop_s # entry point ! 17188: movl 4*1(sp),r9 # load operator dv pointer ! 17189: cmpl 4*dvlpr(r9),$lluno # jump if unary ! 17190: beqlu expo2 ! 17191: # ! 17192: # HERE FOR BINARY OPERATOR ! 17193: # ! 17194: movl $4*cmbs$,r6 # set size of binary operator cmblk ! 17195: jsb alloc # allocate space for cmblk ! 17196: movl (sp)+,4*cmrop(r9)# pop and store right operand ptr ! 17197: movl (sp)+,r10 # pop and load operator dv ptr ! 17198: movl (sp),4*cmlop(r9)# store left operand pointer ! 17199: # ! 17200: # COMMON EXIT POINT ! 17201: # ! 17202: expo1: movl $b$cmt,(r9) # store type code for cmblk ! 17203: movl 4*dvtyp(r10),4*cmtyp(r9) # store cmblk node type code ! 17204: movl r10,4*cmopn(r9) # store dvptr (=ptr to dac o$xxx) ! 17205: movl r6,4*cmlen(r9) # store cmblk length ! 17206: movl r9,(sp) # store resulting node ptr on stack ! 17207: jmp *expop_s # return to expop caller ! 17208: # ! 17209: # HERE FOR UNARY OPERATOR ! 17210: # ! 17211: expo2: movl $4*cmus$,r6 # set size of unary operator cmblk ! 17212: jsb alloc # allocate space for cmblk ! 17213: movl (sp)+,4*cmrop(r9)# pop and store operand pointer ! 17214: movl (sp),r10 # load operator dv pointer ! 17215: jmp expo1 # merge back to exit ! 17216: #enp # end procedure expop ! 17217: #page ! 17218: # ! 17219: # FLSTG -- FOLD STRING TO UPPER CASE ! 17220: # ! 17221: # FLSTG FOLDS A CHARACTER STRING CONTAINING LOWER CASE ! 17222: # CHARACCTERS TO ONE CONTAINING UPPER CASE CHARACTERS. ! 17223: # FOLDING IS ONLY DONE IF &CASE (KVCAS) IS NOT ZERO. ! 17224: # ! 17225: # (XR) STRING ARGUMENT ! 17226: # (WA) LENGTH OF STRING ! 17227: # JSR FLSTG CALL TO FOLD STRING ! 17228: # (XR) RESULT STRING (POSSIBLY ORIGINAL) ! 17229: # (WC) DESTROYED ! 17230: # ! 17231: flstg: #prc # entry point ! 17232: tstl kvcas # skip if &case is 0 ! 17233: beqlu fst99 ! 17234: movl r10,-(sp) # save xl across call ! 17235: movl r9,-(sp) # save original scblk ptr ! 17236: jsb alocs # allocate new string block ! 17237: movl (sp),r10 # point to original scblk ! 17238: movl r9,-(sp) # save pointer to new scblk ! 17239: movab cfp$f(r10),r10 # point to original chars ! 17240: movab cfp$f(r9),r9 # point to new chars ! 17241: clrl -(sp) # init did fold flag ! 17242: # load loop counter ! 17243: fst01: movzbl (r10)+,r6 # load character ! 17244: cmpl $ch$$a,r6 # skip if less than lc a ! 17245: bgtru fst02 ! 17246: cmpl r6,$ch$$$ # skip if greater than lc z ! 17247: bgtru fst02 ! 17248: bicl2 $ch$bl,r6 # fold character to upper case ! 17249: movl sp,(sp) # set did fold character flag ! 17250: fst02: movb r6,(r9)+ # store (possibly folded) character ! 17251: sobgtr r8,fst01 # loop thru entire string ! 17252: #csc r9 # complete store characters ! 17253: tstl (sp)+ # skip if folding done ! 17254: bnequ fst10 ! 17255: movl (sp)+,dnamp # do not need new scblk ! 17256: movl (sp)+,r9 # return original scblk ! 17257: jmp fst20 # merge below ! 17258: fst10: movl (sp)+,r9 # return new scblk ! 17259: addl2 $4,sp # throw away original scblk pointer ! 17260: fst20: movl 4*sclen(r9),r6 # reload string length ! 17261: movl (sp)+,r10 # restore xl ! 17262: fst99: rsb # return ! 17263: #enp ! 17264: #page ! 17265: # ! 17266: # GBCOL -- PERFORM GARBAGE COLLECTION ! 17267: # ! 17268: # GBCOL PERFORMS A GARBAGE COLLECTION ON THE DYNAMIC REGION ! 17269: # ALL BLOCKS WHICH ARE NO LONGER IN USE ARE ELIMINATED ! 17270: # BY MOVING BLOCKS WHICH ARE IN USE DOWN AND RESETTING ! 17271: # DNAMP, THE POINTER TO THE NEXT AVAILABLE LOCATION. ! 17272: # ! 17273: # (WB) MOVE OFFSET (SEE BELOW) ! 17274: # JSR GBCOL CALL TO COLLECT GARBAGE ! 17275: # (XR) DESTROYED ! 17276: # ! 17277: # THE FOLLOWING CONDITIONS MUST BE MET AT THE TIME WHEN ! 17278: # GBCOL IS CALLED. ! 17279: # ! 17280: # 1) ALL POINTERS TO BLOCKS IN THE DYNAMIC AREA MUST BE ! 17281: # ACCESSIBLE TO THE GARBAGE COLLECTOR. THIS MEANS ! 17282: # THAT THEY MUST OCCUR IN ONE OF THE FOLLOWING. ! 17283: # ! 17284: # A) MAIN STACK, WITH CURRENT TOP ! 17285: # ELEMENT BEING INDICATED BY XS ! 17286: # ! 17287: # B) IN RELOCATABLE FIELDS OF VRBLKS. ! 17288: # ! 17289: # C) IN REGISTER XL AT THE TIME OF CALL ! 17290: # ! 17291: # E) IN THE SPECIAL REGION OF WORKING ! 17292: # STORAGE WHERE NAMES BEGIN WITH R$. ! 17293: # ! 17294: # 2) ALL POINTERS MUST POINT TO THE START OF BLOCKS WITH ! 17295: # THE SOLE EXCEPTION OF THE CONTENTS OF THE CODE ! 17296: # POINTER REGISTER WHICH POINTS INTO THE R$COD BLOCK. ! 17297: # ! 17298: # 3) NO LOCATION WHICH APPEARS TO CONTAIN A POINTER ! 17299: # INTO THE DYNAMIC REGION MAY OCCUR UNLESS IT IS IN ! 17300: # FACT A POINTER TO THE START OF THE BLOCK. HOWEVER ! 17301: # POINTERS OUTSIDE THIS AREA MAY OCCUR AND WILL ! 17302: # NOT BE CHANGED BY THE GARBAGE COLLECTOR. ! 17303: # IT IS ESPECIALLY IMPORTANT TO MAKE SURE THAT XL ! 17304: # DOES NOT CONTAIN A GARBAGE VALUE FROM SOME PROCESS ! 17305: # CARRIED OUT BEFORE THE CALL TO THE COLLECTOR. ! 17306: # ! 17307: # GBCOL HAS THE CAPABILITY OF MOVING THE FINAL COMPACTED ! 17308: # RESULT UP IN MEMORY (WITH ADDRESSES ADJUSTED ACCORDINGLY) ! 17309: # THIS IS USED TO ADD SPACE TO THE STATIC REGION. THE ! 17310: # ENTRY VALUE OF WB IS THE NUMBER OF BYTES TO MOVE UP. ! 17311: # THE CALLER MUST GUARANTEE THAT THERE IS ENOUGH ROOM. ! 17312: # FURTHERMORE THE VALUE IN WB IF IT IS NON-ZERO, MUST BE AT ! 17313: # LEAST 256 SO THAT THE MWB INSTRUCTION CONDITIONS ARE MET. ! 17314: #page ! 17315: # ! 17316: # GBCOL (CONTINUED) ! 17317: # ! 17318: # THE ALGORITHM, WHICH IS A MODIFICATION OF THE LISP-2 ! 17319: # GARBAGE COLLECTOR DEVISED BY R.DEWAR AND K.BELCHER ! 17320: # TAKES THREE PASSES AS FOLLOWS. ! 17321: # ! 17322: # 1) ALL POINTERS IN MEMORY ARE SCANNED AND BLOCKS IN USE ! 17323: # DETERMINED FROM THIS SCAN. NOTE THAT THIS PROCEDURE ! 17324: # IS RECURSIVE AND USES THE MAIN STACK FOR LINKAGE. ! 17325: # THE MARKING PROCESS IS THUS SIMILAR TO THAT USED IN ! 17326: # A STANDARD LISP COLLECTOR. HOWEVER THE METHOD OF ! 17327: # ACTUALLY MARKING THE BLOCKS IS DIFFERENT. ! 17328: # ! 17329: # THE FIRST FIELD OF A BLOCK NORMALLY CONTAINS A ! 17330: # CODE ENTRY POINT POINTER. SUCH AN ENTRY POINTER ! 17331: # CAN BE DISTINGUISHED FROM THE ADDRESS OF ANY POINTER ! 17332: # TO BE PROCESSED BY THE COLLECTOR. DURING GARBAGE ! 17333: # COLLECTION, THIS WORD IS USED TO BUILD A BACK CHAIN ! 17334: # OF POINTERS THROUGH FIELDS WHICH POINT TO THE BLOCK. ! 17335: # THE END OF THE CHAIN IS MARKED BY THE OCCURENCE ! 17336: # OF THE WORD WHICH USED TO BE IN THE FIRST WORD OF ! 17337: # THE BLOCK. THIS BACKCHAIN SERVES BOTH AS A MARK ! 17338: # INDICATING THAT THE BLOCK IS IN USE AND AS A LIST OF ! 17339: # REFERENCES FOR THE RELOCATION PHASE. ! 17340: # ! 17341: # 2) STORAGE IS SCANNED SEQUENTIALLY TO DISCOVER WHICH ! 17342: # BLOCKS ARE CURRENTLY IN USE AS INDICATED BY THE ! 17343: # PRESENCE OF A BACKCHAIN. TWO POINTERS ARE MAINTAINED ! 17344: # ONE SCANS THROUGH LOOKING AT EACH BLOCK. THE OTHER ! 17345: # IS INCREMENTED ONLY FOR BLOCKS FOUND TO BE IN USE. ! 17346: # IN THIS WAY, THE EVENTUAL LOCATION OF EACH BLOCK CAN ! 17347: # BE DETERMINED WITHOUT ACTUALLY MOVING ANY BLOCKS. ! 17348: # AS EACH BLOCK WHICH IS IN USE IS PROCESSED, THE BACK ! 17349: # CHAIN IS USED TO RESET ALL POINTERS WHICH POINT TO ! 17350: # THIS BLOCK TO CONTAIN ITS NEW ADDRESS, I.E. THE ! 17351: # ADDRESS IT WILL OCCUPY AFTER THE BLOCKS ARE MOVED. ! 17352: # THE FIRST WORD OF THE BLOCK, TAKEN FROM THE END OF ! 17353: # THE CHAIN IS RESTORED AT THIS POINT. ! 17354: # ! 17355: # DURING PASS 2, THE COLLECTOR BUILDS BLOCKS WHICH ! 17356: # DESCRIBE THE REGIONS OF STORAGE WHICH ARE TO BE ! 17357: # MOVED IN THE THIRD PASS. THERE IS ONE DESCRIPTOR FOR ! 17358: # EACH CONTIGUOUS SET OF GOOD BLOCKS. THE DESCRIPTOR ! 17359: # IS BUILT JUST BEHIND THE BLOCK TO BE MOVED AND ! 17360: # CONTAINS A POINTER TO THE NEXT BLOCK AND THE NUMBER ! 17361: # OF WORDS TO BE MOVED. ! 17362: # ! 17363: # 3) IN THE THIRD AND FINAL PASS, THE MOVE DESCRIPTOR ! 17364: # BLOCKS BUILT IN PASS TWO ARE USED TO ACTUALLY MOVE ! 17365: # THE BLOCKS DOWN TO THE BOTTOM OF THE DYNAMIC REGION. ! 17366: # THE COLLECTION IS THEN COMPLETE AND THE NEXT ! 17367: # AVAILABLE LOCATION POINTER IS RESET. ! 17368: #page ! 17369: # ! 17370: # GBCOL (CONTINUED) ! 17371: # ! 17372: gbcol: #prc # entry point ! 17373: tstl dmvch # fail if in mid-dump ! 17374: beqlu 0f ! 17375: jmp gbc14 ! 17376: 0: ! 17377: movl sp,gbcfl # note gbcol entered ! 17378: movl r6,gbsva # save entry wa ! 17379: movl r7,gbsvb # save entry wb ! 17380: movl r8,gbsvc # save entry wc ! 17381: movl r10,-(sp) # save entry xl ! 17382: movl r3,r6 # get code pointer value ! 17383: subl2 r$cod,r6 # make relative ! 17384: movl r6,r3 # and restore ! 17385: # ! 17386: # PROCESS STACK ENTRIES ! 17387: # ! 17388: movl sp,r9 # point to stack front ! 17389: movl stbas,r10 # point past end of stack ! 17390: cmpl r10,r9 # ok if d-stack ! 17391: bgequ gbc00 ! 17392: movl r10,r9 # reverse if ... ! 17393: movl sp,r10 # ... u-stack ! 17394: # ! 17395: # PROCESS THE STACK ! 17396: # ! 17397: gbc00: jsb gbcpf # process pointers on stack ! 17398: # ! 17399: # PROCESS SPECIAL WORK LOCATIONS ! 17400: # ! 17401: movl $r$aaa,r9 # point to start of relocatable locs ! 17402: movl $r$yyy,r10 # point past end of relocatable locs ! 17403: jsb gbcpf # process work fields ! 17404: # ! 17405: # PREPARE TO PROCESS VARIABLE BLOCKS ! 17406: # ! 17407: movl hshtb,r6 # point to first hash slot pointer ! 17408: # ! 17409: # LOOP THROUGH HASH SLOTS ! 17410: # ! 17411: gbc01: movl r6,r10 # point to next slot ! 17412: addl2 $4,r6 # bump bucket pointer ! 17413: movl r6,gbcnm # save bucket pointer ! 17414: #page ! 17415: # ! 17416: # GBCOL (CONTINUED) ! 17417: # ! 17418: # LOOP THROUGH VARIABLES ON ONE HASH CHAIN ! 17419: # ! 17420: gbc02: movl (r10),r9 # load ptr to next vrblk ! 17421: tstl r9 # jump if end of chain ! 17422: beqlu gbc03 ! 17423: movl r9,r10 # else copy vrblk pointer ! 17424: addl2 $4*vrval,r9 # point to first reloc fld ! 17425: addl2 $4*vrnxt,r10 # point past last (and to link ptr) ! 17426: jsb gbcpf # process reloc fields in vrblk ! 17427: jmp gbc02 # loop back for next block ! 17428: # ! 17429: # HERE AT END OF ONE HASH CHAIN ! 17430: # ! 17431: gbc03: movl gbcnm,r6 # restore bucket pointer ! 17432: cmpl r6,hshte # loop back if more buckets to go ! 17433: bnequ gbc01 ! 17434: #page ! 17435: # ! 17436: # GBCOL (CONTINUED) ! 17437: # ! 17438: # NOW WE ARE READY TO START PASS TWO. REGISTERS ARE USED ! 17439: # AS FOLLOWS IN PASS TWO. ! 17440: # ! 17441: # (XR) SCANS THROUGH ALL BLOCKS ! 17442: # (WC) POINTER TO EVENTUAL LOCATION ! 17443: # ! 17444: # THE MOVE DESCRIPTION BLOCKS BUILT IN THIS PASS HAVE ! 17445: # THE FOLLOWING FORMAT. ! 17446: # ! 17447: # WORD 1 POINTER TO NEXT MOVE BLOCK, ! 17448: # ZERO IF END OF CHAIN OF BLOCKS ! 17449: # ! 17450: # WORD 2 LENGTH OF BLOCKS TO BE MOVED IN ! 17451: # BYTES. SET TO THE ADDRESS OF THE ! 17452: # FIRST BYTE WHILE ACTUALLY SCANNING ! 17453: # THE BLOCKS. ! 17454: # ! 17455: # THE FIRST ENTRY ON THIS CHAIN IS A SPECIAL ENTRY ! 17456: # CONSISTING OF THE TWO WORDS GBCNM AND GBCNS. AFTER ! 17457: # BUILDING THE CHAIN OF MOVE DESCRIPTORS, GBCNM POINTS TO ! 17458: # THE FIRST REAL MOVE BLOCK, AND GBCNS IS THE LENGTH OF ! 17459: # BLOCKS IN USE AT THE START OF STORAGE WHICH NEED NOT ! 17460: # BE MOVED SINCE THEY ARE IN THE CORRECT POSITION. ! 17461: # ! 17462: gbc04: movl dnamb,r9 # point to first block ! 17463: movl r9,r8 # set as first eventual location ! 17464: addl2 gbsvb,r8 # add offset for eventual move up ! 17465: clrl gbcnm # clear initial forward pointer ! 17466: movl $gbcnm,gbclm # initialize ptr to last move block ! 17467: movl r9,gbcns # initialize first address ! 17468: # ! 17469: # LOOP THROUGH A SERIES OF BLOCKS IN USE ! 17470: # ! 17471: gbc05: cmpl r9,dnamp # jump if end of used region ! 17472: beqlu gbc07 ! 17473: movl (r9),r6 # else get first word ! 17474: cmpl r6,$p$yyy # skip if not entry ptr (in use) ! 17475: bgequ gbc06 ! 17476: cmpl r6,$b$aaa # jump if entry pointer (unused) ! 17477: bgequ gbc07 ! 17478: # ! 17479: # HERE FOR BLOCK IN USE, LOOP TO RELOCATE REFERENCES ! 17480: # ! 17481: gbc06: movl r6,r10 # copy pointer ! 17482: movl (r10),r6 # load forward pointer ! 17483: movl r8,(r10) # relocate reference ! 17484: cmpl r6,$p$yyy # loop back if not end of chain ! 17485: bgequ gbc06 ! 17486: cmpl r6,$b$aaa # loop back if not end of chain ! 17487: blequ gbc06 ! 17488: #page ! 17489: # ! 17490: # GBCOL (CONTINUED) ! 17491: # ! 17492: # AT END OF CHAIN, RESTORE FIRST WORD AND BUMP PAST ! 17493: # ! 17494: movl r6,(r9) # restore first word ! 17495: jsb blkln # get length of this block ! 17496: addl2 r6,r9 # bump actual pointer ! 17497: addl2 r6,r8 # bump eventual pointer ! 17498: jmp gbc05 # loop back for next block ! 17499: # ! 17500: # HERE AT END OF A SERIES OF BLOCKS IN USE ! 17501: # ! 17502: gbc07: movl r9,r6 # copy pointer past last block ! 17503: movl gbclm,r10 # point to previous move block ! 17504: subl2 4*1(r10),r6 # subtract starting address ! 17505: movl r6,4*1(r10) # store length of block to be moved ! 17506: # ! 17507: # LOOP THROUGH A SERIES OF BLOCKS NOT IN USE ! 17508: # ! 17509: gbc08: cmpl r9,dnamp # jump if end of used region ! 17510: beqlu gbc10 ! 17511: movl (r9),r6 # else load first word of next block ! 17512: cmpl r6,$p$yyy # jump if in use ! 17513: bgequ gbc09 ! 17514: cmpl r6,$b$aaa # jump if in use ! 17515: blequ gbc09 ! 17516: jsb blkln # else get length of next block ! 17517: addl2 r6,r9 # push pointer ! 17518: jmp gbc08 # and loop back ! 17519: # ! 17520: # HERE FOR A BLOCK IN USE AFTER PROCESSING A SERIES OF ! 17521: # BLOCKS WHICH WERE NOT IN USE, BUILD NEW MOVE BLOCK. ! 17522: # ! 17523: gbc09: subl2 $4*num02,r9 # point 2 words behind for move block ! 17524: movl gbclm,r10 # point to previous move block ! 17525: movl r9,(r10) # set forward ptr in previous block ! 17526: clrl (r9) # zero forward ptr of new block ! 17527: movl r9,gbclm # remember address of this block ! 17528: movl r9,r10 # copy ptr to move block ! 17529: addl2 $4*num02,r9 # point back to block in use ! 17530: movl r9,4*1(r10) # store starting address ! 17531: jmp gbc06 # jump to process block in use ! 17532: #page ! 17533: # ! 17534: # GBCOL (CONTINUED) ! 17535: # ! 17536: # HERE FOR PASS THREE -- ACTUALLY MOVE THE BLOCKS DOWN ! 17537: # ! 17538: # (XL) POINTER TO OLD LOCATION ! 17539: # (XR) POINTER TO NEW LOCATION ! 17540: # ! 17541: gbc10: movl dnamb,r9 # point to start of storage ! 17542: addl2 gbcns,r9 # bump past unmoved blocks at start ! 17543: # ! 17544: # LOOP THROUGH MOVE DESCRIPTORS ! 17545: # ! 17546: gbc11: movl gbcnm,r10 # point to next move block ! 17547: tstl r10 # jump if end of chain ! 17548: beqlu gbc12 ! 17549: movl (r10)+,gbcnm # move pointer down chain ! 17550: movl (r10)+,r6 # get length to move ! 17551: jsb sbmvw # perform move ! 17552: jmp gbc11 # loop back ! 17553: # ! 17554: # NOW TEST FOR MOVE UP ! 17555: # ! 17556: gbc12: movl r9,dnamp # set next available loc ptr ! 17557: movl gbsvb,r7 # reload move offset ! 17558: tstl r7 # jump if no move required ! 17559: beqlu gbc13 ! 17560: movl r9,r10 # else copy old top of core ! 17561: addl2 r7,r9 # point to new top of core ! 17562: movl r9,dnamp # save new top of core pointer ! 17563: movl r10,r6 # copy old top ! 17564: subl2 dnamb,r6 # minus old bottom = length ! 17565: addl2 r7,dnamb # bump bottom to get new value ! 17566: jsb sbmwb # perform move (backwards) ! 17567: # ! 17568: # MERGE HERE TO EXIT ! 17569: # ! 17570: gbc13: movl gbsva,r6 # restore wa ! 17571: movl r3,r8 # get code pointer ! 17572: addl2 r$cod,r8 # make absolute again ! 17573: movl r8,r3 # and replace absolute value ! 17574: movl gbsvc,r8 # restore wc ! 17575: movl (sp)+,r10 # restore entry xl ! 17576: incl gbcnt # increment count of collections ! 17577: clrl r9 # clear garbage value in xr ! 17578: clrl gbcfl # note exit from gbcol ! 17579: rsb # exit to gbcol caller ! 17580: # ! 17581: # GARBAGE COLLECTION NOT ALLOWED WHILST DUMPING ! 17582: # ! 17583: gbc14: incl errft # fatal error ! 17584: jmp er_250 # insufficient memory to complete dump ! 17585: #enp # end procedure gbcol ! 17586: #page ! 17587: # ! 17588: # GBCPF -- PROCESS FIELDS FOR GARBAGE COLLECTOR ! 17589: # ! 17590: # THIS PROCEDURE IS USED BY THE GARBAGE COLLECTOR TO ! 17591: # PROCESS FIELDS IN PASS ONE. SEE GBCOL FOR FULL DETAILS. ! 17592: # ! 17593: # (XR) PTR TO FIRST LOCATION TO PROCESS ! 17594: # (XL) PTR PAST LAST LOCATION TO PROCESS ! 17595: # JSR GBCPF CALL TO PROCESS FIELDS ! 17596: # (XR,WA,WB,WC,IA) DESTROYED ! 17597: # ! 17598: # NOTE THAT ALTHOUGH THIS PROCEDURE USES A RECURSIVE ! 17599: # APPROACH, IT CONTROLS ITS OWN STACK AND IS NOT RECURSIVE. ! 17600: # ! 17601: gbcpf: #prc # entry point ! 17602: clrl -(sp) # set zero to mark bottom of stack ! 17603: movl r10,-(sp) # save end pointer ! 17604: # ! 17605: # MERGE HERE TO GO DOWN A LEVEL AND START A NEW LOOP ! 17606: # ! 17607: # 1(XS) NEXT LVL FIELD PTR (0 AT OUTER LVL) ! 17608: # 0(XS) PTR PAST LAST FIELD TO PROCESS ! 17609: # (XR) PTR TO FIRST FIELD TO PROCESS ! 17610: # ! 17611: # LOOP TO PROCESS SUCCESSIVE FIELDS ! 17612: # ! 17613: gpf01: movl (r9),r10 # load field contents ! 17614: movl r9,r8 # save field pointer ! 17615: cmpl r10,dnamb # jump if not ptr into dynamic area ! 17616: blssu gpf02 ! 17617: cmpl r10,dnamp # jump if not ptr into dynamic area ! 17618: bgequ gpf02 ! 17619: # ! 17620: # HERE WE HAVE A PTR TO A BLOCK IN THE DYNAMIC AREA. ! 17621: # LINK THIS FIELD ONTO THE REFERENCE BACKCHAIN. ! 17622: # ! 17623: movl (r10),r6 # load ptr to chain (or entry ptr) ! 17624: movl r9,(r10) # set this field as new head of chain ! 17625: movl r6,(r9) # set forward pointer ! 17626: # ! 17627: # NOW SEE IF THIS BLOCK HAS BEEN PROCESSED BEFORE ! 17628: # ! 17629: cmpl r6,$p$yyy # jump if already processed ! 17630: bgequ gpf02 ! 17631: cmpl r6,$b$aaa # jump if not already processed ! 17632: bgequ gpf03 ! 17633: # ! 17634: # HERE TO MOVE TO NEXT FIELD ! 17635: # ! 17636: gpf02: movl r8,r9 # restore field pointer ! 17637: addl2 $4,r9 # bump to next field ! 17638: cmpl r9,(sp) # loop back if more to go ! 17639: bnequ gpf01 ! 17640: #page ! 17641: # ! 17642: # GBCPF (CONTINUED) ! 17643: # ! 17644: # HERE WE POP UP A LEVEL AFTER FINISHING A BLOCK ! 17645: # ! 17646: movl (sp)+,r10 # restore pointer past end ! 17647: movl (sp)+,r8 # restore block pointer ! 17648: tstl r8 # continue loop unless outer levl ! 17649: bnequ gpf02 ! 17650: rsb # return to caller if outer level ! 17651: # ! 17652: # HERE TO PROCESS AN ACTIVE BLOCK WHICH HAS NOT BEEN DONE ! 17653: # ! 17654: gpf03: movl r10,r9 # copy block pointer ! 17655: movl r6,r10 # copy first word of block ! 17656: movzwl -2(r10),r10 # load entry point id (bl$xx) ! 17657: # ! 17658: # BLOCK TYPE SWITCH. NOTE THAT BLOCKS WITH NO RELOCATABLE ! 17659: # FIELDS JUST RETURN TO GPF02 HERE TO CONTINE TO NEXT FLD. ! 17660: # ! 17661: casel r10,$0,$bl$$$ # switch on block type ! 17662: 5: ! 17663: .word gpf06-5b # arblk ! 17664: .word gpf18-5b # bcblk ! 17665: .word gpf08-5b # cdblk ! 17666: .word gpf17-5b # exblk ! 17667: .word gpf02-5b # icblk ! 17668: .word gpf10-5b # nmblk ! 17669: .word gpf10-5b # p0blk ! 17670: .word gpf12-5b # p1blk ! 17671: .word gpf12-5b # p2blk ! 17672: .word gpf02-5b # rcblk ! 17673: .word gpf02-5b # scblk ! 17674: .word gpf02-5b # seblk ! 17675: .word gpf08-5b # tbblk ! 17676: .word gpf08-5b # vcblk ! 17677: .word gpf02-5b # xnblk ! 17678: .word gpf09-5b # xrblk ! 17679: .word gpf13-5b # pdblk ! 17680: .word gpf16-5b # trblk ! 17681: .word gpf02-5b # bfblk ! 17682: .word gpf07-5b # ccblk ! 17683: .word gpf04-5b # cmblk ! 17684: .word gpf02-5b # ctblk ! 17685: .word gpf02-5b # dfblk ! 17686: .word gpf02-5b # efblk ! 17687: .word gpf10-5b # evblk ! 17688: .word gpf11-5b # ffblk ! 17689: .word gpf02-5b # kvblk ! 17690: .word gpf14-5b # pfblk ! 17691: .word gpf15-5b # teblk ! 17692: #esw # end of jump table ! 17693: #page ! 17694: # ! 17695: # GBCPF (CONTINUED) ! 17696: # ! 17697: # CMBLK ! 17698: # ! 17699: gpf04: movl 4*cmlen(r9),r6 # load length ! 17700: movl $4*cmtyp,r7 # set offset ! 17701: # ! 17702: # HERE TO PUSH DOWN TO NEW LEVEL ! 17703: # ! 17704: # (WC) FIELD PTR AT PREVIOUS LEVEL ! 17705: # (XR) PTR TO NEW BLOCK ! 17706: # (WA) LENGTH (RELOC FLDS + FLDS AT START) ! 17707: # (WB) OFFSET TO FIRST RELOC FIELD ! 17708: # ! 17709: gpf05: addl2 r9,r6 # point past last reloc field ! 17710: addl2 r7,r9 # point to first reloc field ! 17711: movl r8,-(sp) # stack old field pointer ! 17712: movl r6,-(sp) # stack new limit pointer ! 17713: jsb sbchk # check for stack overflow ! 17714: jmp gpf01 # if ok, back to process ! 17715: # ! 17716: # ARBLK ! 17717: # ! 17718: gpf06: movl 4*arlen(r9),r6 # load length ! 17719: movl 4*arofs(r9),r7 # set offset to 1st reloc fld (arpro) ! 17720: jmp gpf05 # all set ! 17721: # ! 17722: # CCBLK ! 17723: # ! 17724: gpf07: movl 4*ccuse(r9),r6 # set length in use ! 17725: movl $4*ccuse,r7 # 1st word (make sure at least one) ! 17726: jmp gpf05 # all set ! 17727: #page ! 17728: # ! 17729: # GBCPF (CONTINUED) ! 17730: # ! 17731: # CDBLK, TBBLK, VCBLK ! 17732: # ! 17733: gpf08: movl 4*offs2(r9),r6 # load length ! 17734: movl $4*offs3,r7 # set offset ! 17735: jmp gpf05 # jump back ! 17736: # ! 17737: # XRBLK ! 17738: # ! 17739: gpf09: movl 4*xrlen(r9),r6 # load length ! 17740: movl $4*xrptr,r7 # set offset ! 17741: jmp gpf05 # jump back ! 17742: # ! 17743: # EVBLK, NMBLK, P0BLK ! 17744: # ! 17745: gpf10: movl $4*offs2,r6 # point past second field ! 17746: movl $4*offs1,r7 # offset is one (only reloc fld is 2) ! 17747: jmp gpf05 # all set ! 17748: # ! 17749: # FFBLK ! 17750: # ! 17751: gpf11: movl $4*ffofs,r6 # set length ! 17752: movl $4*ffnxt,r7 # set offset ! 17753: jmp gpf05 # all set ! 17754: # ! 17755: # P1BLK, P2BLK ! 17756: # ! 17757: gpf12: movl $4*parm2,r6 # length (parm2 is non-relocatable) ! 17758: movl $4*pthen,r7 # set offset ! 17759: jmp gpf05 # all set ! 17760: #page ! 17761: # ! 17762: # GBCPF (CONTINUED) ! 17763: # ! 17764: # PDBLK ! 17765: # ! 17766: gpf13: movl 4*pddfp(r9),r10 # load ptr to dfblk ! 17767: movl 4*dfpdl(r10),r6 # get pdblk length ! 17768: movl $4*pdfld,r7 # set offset ! 17769: jmp gpf05 # all set ! 17770: # ! 17771: # PFBLK ! 17772: # ! 17773: gpf14: movl $4*pfarg,r6 # length past last reloc ! 17774: movl $4*pfcod,r7 # offset to first reloc ! 17775: jmp gpf05 # all set ! 17776: # ! 17777: # TEBLK ! 17778: # ! 17779: gpf15: movl $4*tesi$,r6 # set length ! 17780: movl $4*tesub,r7 # and offset ! 17781: jmp gpf05 # all set ! 17782: # ! 17783: # TRBLK ! 17784: # ! 17785: gpf16: movl $4*trsi$,r6 # set length ! 17786: movl $4*trval,r7 # and offset ! 17787: jmp gpf05 # all set ! 17788: # ! 17789: # EXBLK ! 17790: # ! 17791: gpf17: movl 4*exlen(r9),r6 # load length ! 17792: movl $4*exflc,r7 # set offset ! 17793: jmp gpf05 # jump back ! 17794: # ! 17795: # BCBLK ! 17796: # ! 17797: gpf18: movl $4*bcsi$,r6 # set length ! 17798: movl $4*bcbuf,r7 # and offset ! 17799: jmp gpf05 # all set ! 17800: #enp # end procedure gbcpf ! 17801: #page ! 17802: # ! 17803: # GTARR -- GET ARRAY ! 17804: # ! 17805: # GTARR IS PASSED AN OBJECT AND RETURNS AN ARRAY IF POSSIBL ! 17806: # ! 17807: # (XR) VALUE TO BE CONVERTED ! 17808: # JSR GTARR CALL TO GET ARRAY ! 17809: # PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE ! 17810: # (XR) RESULTING ARRAY ! 17811: # (XL,WA,WB,WC) DESTROYED ! 17812: # ! 17813: gtarr: #prc # entry point ! 17814: movl (r9),r6 # load type word ! 17815: cmpl r6,$b$art # exit if already an array ! 17816: bnequ 0f ! 17817: jmp gtar8 ! 17818: 0: ! 17819: cmpl r6,$b$vct # exit if already an array ! 17820: bnequ 0f ! 17821: jmp gtar8 ! 17822: 0: ! 17823: cmpl r6,$b$tbt # else fail if not a table (sgd02) ! 17824: beqlu 0f ! 17825: jmp gta9a ! 17826: 0: ! 17827: # ! 17828: # HERE WE CONVERT A TABLE TO AN ARRAY ! 17829: # ! 17830: movl r9,-(sp) # replace tbblk pointer on stack ! 17831: clrl r9 # signal first pass ! 17832: clrl r7 # zero non-null element count ! 17833: # ! 17834: # THE FOLLOWING CODE IS EXECUTED TWICE. ON THE FIRST PASS, ! 17835: # SIGNALLED BY XR=0, THE NUMBER OF NON-NULL ELEMENTS IN ! 17836: # THE TABLE IS COUNTED IN WB. IN THE SECOND PASS, WHERE ! 17837: # XR IS A POINTER INTO THE ARBLK, THE NAME AND VALUE ARE ! 17838: # ENTERED INTO THE CURRENT ARBLK LOCATION. ! 17839: # ! 17840: gtar1: movl (sp),r10 # point to table ! 17841: addl2 4*tblen(r10),r10# point past last bucket ! 17842: subl2 $4*tbbuk,r10 # set first bucket offset ! 17843: movl r10,r6 # copy adjusted pointer ! 17844: # ! 17845: # LOOP THROUGH BUCKETS IN TABLE BLOCK ! 17846: # NEXT THREE LINES OF CODE RELY ON TENXT HAVING A VALUE ! 17847: # 1 LESS THAN TBBUK. ! 17848: # ! 17849: gtar2: movl r6,r10 # copy bucket pointer ! 17850: subl2 $4,r6 # decrement bucket pointer ! 17851: # ! 17852: # LOOP THROUGH TEBLKS ON ONE BUCKET CHAIN ! 17853: # ! 17854: gtar3: movl 4*tenxt(r10),r10# point to next teblk ! 17855: cmpl r10,(sp) # jump if chain end (tbblk ptr) ! 17856: beqlu gtar6 ! 17857: movl r10,cnvtp # else save teblk pointer ! 17858: # ! 17859: # LOOP TO FIND VALUE DOWN TRBLK CHAIN ! 17860: # ! 17861: gtar4: movl 4*teval(r10),r10# load value ! 17862: cmpl (r10),$b$trt # loop till value found ! 17863: beqlu gtar4 ! 17864: movl r10,r8 # copy value ! 17865: movl cnvtp,r10 # restore teblk pointer ! 17866: #page ! 17867: # ! 17868: # GTARR (CONTINUED) ! 17869: # ! 17870: # NOW CHECK FOR NULL AND TEST CASES ! 17871: # ! 17872: cmpl r8,$nulls # loop back to ignore null value ! 17873: beqlu gtar3 ! 17874: tstl r9 # jump if second pass ! 17875: bnequ gtar5 ! 17876: incl r7 # for the first pass, bump count ! 17877: jmp gtar3 # and loop back for next teblk ! 17878: # ! 17879: # HERE IN SECOND PASS ! 17880: # ! 17881: gtar5: movl 4*tesub(r10),(r9)+ # store subscript name ! 17882: movl r8,(r9)+ # store value in arblk ! 17883: jmp gtar3 # loop back for next teblk ! 17884: # ! 17885: # HERE AFTER SCANNING TEBLKS ON ONE CHAIN ! 17886: # ! 17887: gtar6: cmpl r6,(sp) # loop back if more buckets to go ! 17888: bnequ gtar2 ! 17889: tstl r9 # else jump if second pass ! 17890: bnequ gtar7 ! 17891: # ! 17892: # HERE AFTER COUNTING NON-NULL ELEMENTS ! 17893: # ! 17894: tstl r7 # fail if no non-null elements ! 17895: bnequ 0f ! 17896: jmp gtar9 ! 17897: 0: ! 17898: movl r7,r6 # else copy count ! 17899: addl2 r7,r6 # double (two words/element) ! 17900: addl2 $arvl2,r6 # add space for standard fields ! 17901: moval 0[r6],r6 # convert length to bytes ! 17902: cmpl r6,mxlen # fail if too long for array ! 17903: blssu 0f ! 17904: jmp gtar9 ! 17905: 0: ! 17906: jsb alloc # else allocate space for arblk ! 17907: movl $b$art,(r9) # store type word ! 17908: clrl 4*idval(r9) # zero id for the moment ! 17909: movl r6,4*arlen(r9) # store length ! 17910: movl $num02,4*arndm(r9) # set dimensions = 2 ! 17911: movl intv1,r5 # get integer one ! 17912: movl r5,4*arlbd(r9) # store as lbd 1 ! 17913: movl r5,4*arlb2(r9) # store as lbd 2 ! 17914: movl intv2,r5 # load integer two ! 17915: movl r5,4*ardm2(r9) # store as dim 2 ! 17916: movl r7,r5 # get element count as integer ! 17917: movl r5,4*ardim(r9) # store as dim 1 ! 17918: clrl 4*arpr2(r9) # zero prototype field for now ! 17919: movl $4*arpr2,4*arofs(r9) # set offset field (signal pass 2) ! 17920: movl r9,r7 # save arblk pointer ! 17921: addl2 $4*arvl2,r9 # point to first element location ! 17922: jmp gtar1 # jump back to fill in elements ! 17923: #page ! 17924: # ! 17925: # GTARR (CONTINUED) ! 17926: # ! 17927: # HERE AFTER FILLING IN ELEMENT VALUES ! 17928: # ! 17929: gtar7: movl r7,r9 # restore arblk pointer ! 17930: movl r7,(sp) # store as result ! 17931: # ! 17932: # NOW WE NEED THE ARRAY PROTOTYPE WHICH IS OF THE FORM NN,2 ! 17933: # THIS IS OBTAINED BY BUILDING THE STRING FOR NN02 AND ! 17934: # CHANGING THE ZERO TO A COMMA BEFORE STORING IT. ! 17935: # ! 17936: movl 4*ardim(r9),r5 # get number of elements (nn) ! 17937: mull2 intvh,r5 # multiply by 100 ! 17938: addl2 intv2,r5 # add 2 (nn02) ! 17939: jsb icbld # build integer ! 17940: movl r9,-(sp) # store ptr for gtstg ! 17941: jsb gtstg # convert to string ! 17942: .long invalid$ # convert fail is impossible ! 17943: movl r9,r10 # copy string pointer ! 17944: movl (sp)+,r9 # reload arblk pointer ! 17945: movl r10,4*arpr2(r9) # store prototype ptr (nn02) ! 17946: subl2 $num02,r6 # adjust length to point to zero ! 17947: movab cfp$f(r10)[r6],r10 # point to zero ! 17948: movl $ch$cm,r7 # load a comma ! 17949: movb r7,(r10) # store a comma over the zero ! 17950: #csc r10 # complete store characters ! 17951: # ! 17952: # NORMAL RETURN ! 17953: # ! 17954: gtar8: addl2 $4*1,(sp) # return to caller ! 17955: rsb ! 17956: # ! 17957: # NON-CONVERSION RETURN ! 17958: # ! 17959: gtar9: movl (sp)+,r9 # restore stack for conv err (sgd02) ! 17960: # ! 17961: # MERGE TO TAKE CONVERT ERROR WHEN STACK ADJUSTED OK ! 17962: # ! 17963: gta9a: movl (sp)+,r11 # return ! 17964: jmp *(r11)+ ! 17965: #enp # procedure gtarr ! 17966: #page ! 17967: # ! 17968: # GTCOD -- CONVERT TO CODE ! 17969: # ! 17970: # (XR) OBJECT TO BE CONVERTED ! 17971: # JSR GTCOD CALL TO CONVERT TO CODE ! 17972: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 17973: # (XR) POINTER TO RESULTING CDBLK ! 17974: # (XL,WA,WB,WC,RA) DESTROYED ! 17975: # ! 17976: # IF A SPITBOL ERROR OCCURS DURING COMPILATION OR PRE- ! 17977: # EVALUATION, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL ! 17978: # WITHOUT RETURNING TO THIS ROUTINE. ! 17979: # ! 17980: gtcod: #prc # entry point ! 17981: cmpl (r9),$b$cds # jump if already code ! 17982: beqlu gtcd1 ! 17983: cmpl (r9),$b$cdc # jump if already code ! 17984: beqlu gtcd1 ! 17985: # ! 17986: # HERE WE MUST GENERATE A CDBLK BY COMPILATION ! 17987: # ! 17988: movl r9,-(sp) # stack argument for gtstg ! 17989: jsb gtstg # convert argument to string ! 17990: .long gtcd2 # jump if non-convertible ! 17991: movl flptr,gtcef # save fail ptr in case of error ! 17992: movl r$cod,r$gtc # also save code ptr ! 17993: movl r9,r$cim # else set image pointer ! 17994: movl r6,scnil # set image length ! 17995: clrl scnpt # set scan pointer ! 17996: movl $stgxc,stage # set stage for execute compile ! 17997: movl cmpsn,lstsn # in case listr called ! 17998: jsb cmpil # compile string ! 17999: movl $stgxt,stage # reset stage for execute time ! 18000: clrl r$cim # clear image ! 18001: # ! 18002: # MERGE HERE IF NO CONVERT REQUIRED ! 18003: # ! 18004: gtcd1: addl2 $4*1,(sp) # give normal gtcod return ! 18005: rsb ! 18006: # ! 18007: # HERE IF UNCONVERTIBLE ! 18008: # ! 18009: gtcd2: movl (sp)+,r11 # give error return ! 18010: jmp *(r11)+ ! 18011: #enp # end procedure gtcod ! 18012: #page ! 18013: # ! 18014: # GTEXP -- CONVERT TO EXPRESSION ! 18015: # ! 18016: # (XR) INPUT VALUE TO BE CONVERTED ! 18017: # JSR GTEXP CALL TO CONVERT TO EXPRESSION ! 18018: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 18019: # (XR) POINTER TO RESULT EXBLK OR SEBLK ! 18020: # (XL,WA,WB,WC,RA) DESTROYED ! 18021: # ! 18022: # IF A SPITBOL ERROR OCCURS DURING COMPILATION OR PRE- ! 18023: # EVALUATION, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL ! 18024: # WITHOUT RETURNING TO THIS ROUTINE. ! 18025: # ! 18026: gtexp: #prc # entry point ! 18027: cmpl (r9),$b$e$$ # jump if already an expression ! 18028: bgtru 0f ! 18029: jmp gtex1 ! 18030: 0: ! 18031: movl r9,-(sp) # store argument for gtstg ! 18032: jsb gtstg # convert argument to string ! 18033: .long gtex2 # jump if unconvertible ! 18034: # ! 18035: # CHECK THE LAST CHARACTER OF THE STRING FOR COLON OR ! 18036: # SEMICOLON. THESE CHARACTERS CAN LEGITIMATELY END AN ! 18037: # EXPRESSION IN OPEN CODE, SO EXPAN WILL NOT DETECT THEM ! 18038: # AS ERRORS, BUT THEY ARE INVALID AS TERMINATORS FOR A ! 18039: # STRING THAT IS BEING CONVERTED TO EXPRESSION FORM. ! 18040: # ! 18041: movl r9,r10 # copy input string pointer (reg06) ! 18042: movab cfp$f(r10)[r6],r10 # point one past the string end (reg06) ! 18043: movzbl -(r10),r10 # fetch the last character (reg06) ! 18044: cmpl r10,$ch$cl # error if it is a semicolon (reg06) ! 18045: beqlu gtex2 ! 18046: cmpl r10,$ch$sm # or if it is a colon (reg06) ! 18047: beqlu gtex2 ! 18048: # ! 18049: # HERE WE CONVERT A STRING BY COMPILATION ! 18050: # ! 18051: movl r9,r$cim # set input image pointer ! 18052: clrl scnpt # set scan pointer ! 18053: movl r6,scnil # set input image length ! 18054: clrl r7 # set code for normal scan ! 18055: movl flptr,gtcef # save fail ptr in case of error ! 18056: movl r$cod,r$gtc # also save code ptr ! 18057: movl $stgev,stage # adjust stage for compile ! 18058: movl $t$uok,scntp # indicate unary operator acceptable ! 18059: jsb expan # build tree for expression ! 18060: clrl scnrs # reset rescan flag ! 18061: cmpl scnpt,scnil # error if not end of image ! 18062: bnequ gtex2 ! 18063: clrl r7 # set ok value for cdgex call ! 18064: movl r9,r10 # copy tree pointer ! 18065: jsb cdgex # build expression block ! 18066: clrl r$cim # clear pointer ! 18067: movl $stgxt,stage # restore stage for execute time ! 18068: # ! 18069: # MERGE HERE IF NO CONVERSION REQUIRED ! 18070: # ! 18071: gtex1: addl2 $4*1,(sp) # return to gtexp caller ! 18072: rsb ! 18073: # ! 18074: # HERE IF UNCONVERTIBLE ! 18075: # ! 18076: gtex2: movl (sp)+,r11 # take error exit ! 18077: jmp *(r11)+ ! 18078: #enp # end procedure gtexp ! 18079: #page ! 18080: # ! 18081: # GTINT -- GET INTEGER VALUE ! 18082: # ! 18083: # GTINT IS PASSED AN OBJECT AND RETURNS AN INTEGER AFTER ! 18084: # PERFORMING ANY NECESSARY CONVERSIONS. ! 18085: # ! 18086: # (XR) VALUE TO BE CONVERTED ! 18087: # JSR GTINT CALL TO CONVERT TO INTEGER ! 18088: # PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE ! 18089: # (XR) RESULTING INTEGER ! 18090: # (WC,RA) DESTROYED ! 18091: # (WA,WB) DESTROYED (ONLY ON CONVERSION ERR) ! 18092: # (XR) UNCHANGED (ON CONVERT ERROR) ! 18093: # ! 18094: gtint: #prc # entry point ! 18095: cmpl (r9),$b$icl # jump if already an integer ! 18096: beqlu gtin2 ! 18097: movl r6,gtina # else save wa ! 18098: movl r7,gtinb # save wb ! 18099: jsb gtnum # convert to numeric ! 18100: .long gtin3 # jump if unconvertible ! 18101: cmpl r6,$b$icl # jump if integer ! 18102: beqlu gtin1 ! 18103: # ! 18104: # HERE WE CONVERT A REAL TO INTEGER ! 18105: # ! 18106: movf 4*rcval(r9),r2 # load real value ! 18107: cvtfl r2,r5 # convert to integer (err if ovflow) ! 18108: bvs gtin3 ! 18109: jsb icbld # if ok build icblk ! 18110: # ! 18111: # HERE AFTER SUCCESSFUL CONVERSION TO INTEGER ! 18112: # ! 18113: gtin1: movl gtina,r6 # restore wa ! 18114: movl gtinb,r7 # restore wb ! 18115: # ! 18116: # COMMON EXIT POINT ! 18117: # ! 18118: gtin2: addl2 $4*1,(sp) # return to gtint caller ! 18119: rsb ! 18120: # ! 18121: # HERE ON CONVERSION ERROR ! 18122: # ! 18123: gtin3: movl (sp)+,r11 # take convert error exit ! 18124: jmp *(r11)+ ! 18125: #enp # end procedure gtint ! 18126: #page ! 18127: # ! 18128: # GTNUM -- GET NUMERIC VALUE ! 18129: # ! 18130: # GTNUM IS GIVEN AN OBJECT AND RETURNS EITHER AN INTEGER ! 18131: # OR A REAL, PERFORMING ANY NECESSARY CONVERSIONS. ! 18132: # ! 18133: # (XR) OBJECT TO BE CONVERTED ! 18134: # JSR GTNUM CALL TO CONVERT TO NUMERIC ! 18135: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 18136: # (XR) POINTER TO RESULT (INT OR REAL) ! 18137: # (WA) FIRST WORD OF RESULT BLOCK ! 18138: # (WB,WC,RA) DESTROYED ! 18139: # (XR) UNCHANGED (ON CONVERT ERROR) ! 18140: # ! 18141: gtnum: #prc # entry point ! 18142: movl (r9),r6 # load first word of block ! 18143: cmpl r6,$b$icl # jump if integer (no conversion) ! 18144: bnequ 0f ! 18145: jmp gtn34 ! 18146: 0: ! 18147: cmpl r6,$b$rcl # jump if real (no conversion) ! 18148: bnequ 0f ! 18149: jmp gtn34 ! 18150: 0: ! 18151: # ! 18152: # AT THIS POINT THE ONLY POSSIBILITY IS TO CONVERT A STRING ! 18153: # TO AN INTEGER OR REAL AS APPROPRIATE. ! 18154: # ! 18155: movl r9,-(sp) # stack argument in case convert err ! 18156: movl r9,-(sp) # stack argument for gtstg ! 18157: jsb gtstg # convert argument to string ! 18158: .long gtn36 # jump if unconvertible ! 18159: # ! 18160: # INITIALIZE NUMERIC CONVERSION ! 18161: # ! 18162: movl intv0,r5 # initialize integer result to zero ! 18163: tstl r6 # jump to exit with zero if null ! 18164: bnequ 0f ! 18165: jmp gtn32 ! 18166: 0: ! 18167: # set bct counter for following loops ! 18168: clrl gtnnf # tentatively indicate result + ! 18169: movl r5,gtnex # initialise exponent to zero ! 18170: clrl gtnsc # zero scale in case real ! 18171: clrl gtndf # reset flag for dec point found ! 18172: clrl gtnrd # reset flag for digits found ! 18173: movf reav0,r2 # zero real accum in case real ! 18174: movab cfp$f(r9),r9 # point to argument characters ! 18175: # ! 18176: # MERGE BACK HERE AFTER IGNORING LEADING BLANK ! 18177: # ! 18178: gtn01: movzbl (r9)+,r7 # load first character ! 18179: cmpl r7,$ch$d0 # jump if not digit ! 18180: blssu gtn02 ! 18181: cmpl r7,$ch$d9 # jump if first char is a digit ! 18182: blequ gtn06 ! 18183: #page ! 18184: # ! 18185: # GTNUM (CONTINUED) ! 18186: # ! 18187: # HERE IF FIRST DIGIT IS NON-DIGIT ! 18188: # ! 18189: gtn02: cmpl r7,$ch$bl # jump if non-blank ! 18190: bnequ gtn03 ! 18191: gtna2: sobgtr r6,gtn01 # else decr count and loop back ! 18192: jmp gtn07 # jump to return zero if all blanks ! 18193: # ! 18194: # HERE FOR FIRST CHARACTER NON-BLANK, NON-DIGIT ! 18195: # ! 18196: gtn03: cmpl r7,$ch$pl # jump if plus sign ! 18197: beqlu gtn04 ! 18198: cmpl r7,$ch$ht # horizontal tab equiv to blank ! 18199: beqlu gtna2 ! 18200: cmpl r7,$ch$mn # jump if not minus (may be real) ! 18201: beqlu 0f ! 18202: jmp gtn12 ! 18203: 0: ! 18204: movl sp,gtnnf # if minus sign, set negative flag ! 18205: # ! 18206: # MERGE HERE AFTER PROCESSING SIGN ! 18207: # ! 18208: gtn04: sobgtr r6,gtn05 # jump if chars left ! 18209: jmp gtn36 # else error ! 18210: # ! 18211: # LOOP TO FETCH CHARACTERS OF AN INTEGER ! 18212: # ! 18213: gtn05: movzbl (r9)+,r7 # load next character ! 18214: cmpl r7,$ch$d0 # jump if not a digit ! 18215: blssu gtn08 ! 18216: cmpl r7,$ch$d9 # jump if not a digit ! 18217: bgtru gtn08 ! 18218: # ! 18219: # MERGE HERE FOR FIRST DIGIT ! 18220: # ! 18221: gtn06: movl r5,gtnsi # save current value ! 18222: mull2 $10,r5 # current*10-(new dig) jump if ovflow ! 18223: bvc 0f ! 18224: jmp gtn35 ! 18225: 0: bicl2 $0xfffffff0,r7 ! 18226: subl2 r7,r5 ! 18227: bvc 1f ! 18228: jmp gtn35 ! 18229: 1: ! 18230: movl sp,gtnrd # set digit read flag ! 18231: sobgtr r6,gtn05 # else loop back if more chars ! 18232: # ! 18233: # HERE TO EXIT WITH CONVERTED INTEGER VALUE ! 18234: # ! 18235: gtn07: tstl gtnnf # jump if negative (all set) ! 18236: beqlu 0f ! 18237: jmp gtn32 ! 18238: 0: ! 18239: mnegl r5,r5 # else negate ! 18240: bvs 0f ! 18241: jmp gtn32 ! 18242: 0: ! 18243: jmp gtn36 # else signal error ! 18244: #page ! 18245: # ! 18246: # GTNUM (CONTINUED) ! 18247: # ! 18248: # HERE FOR A NON-DIGIT CHARACTER WHILE ATTEMPTING TO ! 18249: # CONVERT AN INTEGER, CHECK FOR TRAILING BLANKS OR REAL. ! 18250: # ! 18251: gtn08: cmpl r7,$ch$bl # jump if a blank ! 18252: beqlu gtna9 ! 18253: cmpl r7,$ch$ht # jump if horizontal tab ! 18254: beqlu gtna9 ! 18255: cvtlf r5,r2 # else convert integer to real ! 18256: mnegf r2,r2 # negate to get positive value ! 18257: jmp gtn12 # jump to try for real ! 18258: # ! 18259: # HERE WE SCAN OUT BLANKS TO END OF STRING ! 18260: # ! 18261: gtn09: movzbl (r9)+,r7 # get next char ! 18262: cmpl r7,$ch$ht # jump if horizontal tab ! 18263: beqlu gtna9 ! 18264: cmpl r7,$ch$bl # error if non-blank ! 18265: beqlu 0f ! 18266: jmp gtn36 ! 18267: 0: ! 18268: gtna9: sobgtr r6,gtn09 # loop back if more chars to check ! 18269: jmp gtn07 # return integer if all blanks ! 18270: # ! 18271: # LOOP TO COLLECT MANTISSA OF REAL ! 18272: # ! 18273: gtn10: movzbl (r9)+,r7 # load next character ! 18274: cmpl r7,$ch$d0 # jump if non-numeric ! 18275: bgequ 0f ! 18276: jmp gtn12 ! 18277: 0: ! 18278: cmpl r7,$ch$d9 # jump if non-numeric ! 18279: blequ 0f ! 18280: jmp gtn12 ! 18281: 0: ! 18282: # ! 18283: # MERGE HERE TO COLLECT FIRST REAL DIGIT ! 18284: # ! 18285: gtn11: subl2 $ch$d0,r7 # convert digit to number ! 18286: mulf2 reavt,r2 # multiply real by 10.0 ! 18287: bvc 0f ! 18288: jmp gtn36 ! 18289: 0: ! 18290: movf r2,gtnsr # save result ! 18291: movl r7,r5 # get new digit as integer ! 18292: cvtlf r5,r2 # convert new digit to real ! 18293: addf2 gtnsr,r2 # add to get new total ! 18294: addl2 gtndf,gtnsc # increment scale if after dec point ! 18295: movl sp,gtnrd # set digit found flag ! 18296: sobgtr r6,gtn10 # loop back if more chars ! 18297: jmp gtn22 # else jump to scale ! 18298: #page ! 18299: # ! 18300: # GTNUM (CONTINUED) ! 18301: # ! 18302: # HERE IF NON-DIGIT FOUND WHILE COLLECTING A REAL ! 18303: # ! 18304: gtn12: cmpl r7,$ch$dt # jump if not dec point ! 18305: bnequ gtn13 ! 18306: tstl gtndf # if dec point, error if one already ! 18307: beqlu 0f ! 18308: jmp gtn36 ! 18309: 0: ! 18310: movl $num01,gtndf # else set flag for dec point ! 18311: sobgtr r6,gtn10 # loop back if more chars ! 18312: jmp gtn22 # else jump to scale ! 18313: # ! 18314: # HERE IF NOT DECIMAL POINT ! 18315: # ! 18316: gtn13: cmpl r7,$ch$le # jump if e for exponent ! 18317: beqlu gtn15 ! 18318: cmpl r7,$ch$ld # jump if d for exponent ! 18319: beqlu gtn15 ! 18320: cmpl r7,$ch$$e # jump if e for exponent ! 18321: beqlu gtn15 ! 18322: cmpl r7,$ch$$d # jump if d for exponent ! 18323: beqlu gtn15 ! 18324: # ! 18325: # HERE CHECK FOR TRAILING BLANKS ! 18326: # ! 18327: gtn14: cmpl r7,$ch$bl # jump if blank ! 18328: beqlu gtnb4 ! 18329: cmpl r7,$ch$ht # jump if horizontal tab ! 18330: beqlu gtnb4 ! 18331: jmp gtn36 # error if non-blank ! 18332: # ! 18333: gtnb4: movzbl (r9)+,r7 # get next character ! 18334: sobgtr r6,gtn14 # loop back to check if more ! 18335: jmp gtn22 # else jump to scale ! 18336: # ! 18337: # HERE TO READ AND PROCESS AN EXPONENT ! 18338: # ! 18339: gtn15: clrl gtnes # set exponent sign positive ! 18340: movl intv0,r5 # initialize exponent to zero ! 18341: movl sp,gtndf # reset no dec point indication ! 18342: sobgtr r6,gtn16 # jump skipping past e or d ! 18343: jmp gtn36 # error if null exponent ! 18344: # ! 18345: # CHECK FOR EXPONENT SIGN ! 18346: # ! 18347: gtn16: movzbl (r9)+,r7 # load first exponent character ! 18348: cmpl r7,$ch$pl # jump if plus sign ! 18349: beqlu gtn17 ! 18350: cmpl r7,$ch$mn # else jump if not minus sign ! 18351: bnequ gtn19 ! 18352: movl sp,gtnes # set sign negative if minus sign ! 18353: # ! 18354: # MERGE HERE AFTER PROCESSING EXPONENT SIGN ! 18355: # ! 18356: gtn17: sobgtr r6,gtn18 # jump if chars left ! 18357: jmp gtn36 # else error ! 18358: # ! 18359: # LOOP TO CONVERT EXPONENT DIGITS ! 18360: # ! 18361: gtn18: movzbl (r9)+,r7 # load next character ! 18362: #page ! 18363: # ! 18364: # GTNUM (CONTINUED) ! 18365: # ! 18366: # MERGE HERE FOR FIRST EXPONENT DIGIT ! 18367: # ! 18368: gtn19: cmpl r7,$ch$d0 # jump if not digit ! 18369: blssu gtn20 ! 18370: cmpl r7,$ch$d9 # jump if not digit ! 18371: bgtru gtn20 ! 18372: mull2 $10,r5 # else current*10, subtract new digit ! 18373: bvc 0f ! 18374: jmp gtn36 ! 18375: 0: bicl2 $0xfffffff0,r7 ! 18376: subl2 r7,r5 ! 18377: bvc 1f ! 18378: jmp gtn36 ! 18379: 1: ! 18380: sobgtr r6,gtn18 # loop back if more chars ! 18381: jmp gtn21 # jump if exponent field is exhausted ! 18382: # ! 18383: # HERE TO CHECK FOR TRAILING BLANKS AFTER EXPONENT ! 18384: # ! 18385: gtn20: cmpl r7,$ch$bl # jump if blank ! 18386: beqlu gtnc0 ! 18387: cmpl r7,$ch$ht # jump if horizontal tab ! 18388: beqlu gtnc0 ! 18389: jmp gtn36 # error if non-blank ! 18390: # ! 18391: gtnc0: movzbl (r9)+,r7 # get next character ! 18392: sobgtr r6,gtn20 # loop back till all blanks scanned ! 18393: # ! 18394: # MERGE HERE AFTER COLLECTING EXPONENT ! 18395: # ! 18396: gtn21: movl r5,gtnex # save collected exponent ! 18397: tstl gtnes # jump if it was negative ! 18398: bnequ gtn22 ! 18399: mnegl r5,r5 # else complement ! 18400: bvc 0f ! 18401: jmp gtn36 ! 18402: 0: ! 18403: movl r5,gtnex # and store positive exponent ! 18404: # ! 18405: # MERGE HERE WITH EXPONENT (0 IF NONE GIVEN) ! 18406: # ! 18407: gtn22: tstl gtnrd # error if not digits collected ! 18408: bnequ 0f ! 18409: jmp gtn36 ! 18410: 0: ! 18411: tstl gtndf # error if no exponent or dec point ! 18412: bnequ 0f ! 18413: jmp gtn36 ! 18414: 0: ! 18415: movl gtnsc,r5 # else load scale as integer ! 18416: subl2 gtnex,r5 # subtract exponent ! 18417: bvc 0f ! 18418: jmp gtn36 ! 18419: 0: ! 18420: tstl r5 # jump if we must scale up ! 18421: blss gtn26 ! 18422: # ! 18423: # HERE WE HAVE A NEGATIVE EXPONENT, SO SCALE DOWN ! 18424: # ! 18425: movl r5,r6 # load scale factor, err if ovflow ! 18426: bgeq 0f ! 18427: jmp gtn36 ! 18428: 0: ! 18429: # ! 18430: # LOOP TO SCALE DOWN IN STEPS OF 10**10 ! 18431: # ! 18432: gtn23: cmpl r6,$num10 # jump if 10 or less to go ! 18433: blequ gtn24 ! 18434: divf2 reatt,r2 # else divide by 10**10 ! 18435: subl2 $num10,r6 # decrement scale ! 18436: jmp gtn23 # and loop back ! 18437: #page ! 18438: # ! 18439: # GTNUM (CONTINUED) ! 18440: # ! 18441: # HERE SCALE REST OF WAY FROM POWERS OF TEN TABLE ! 18442: # ! 18443: gtn24: tstl r6 # jump if scaled ! 18444: beqlu gtn30 ! 18445: movl $cfp$r,r7 # else get indexing factor ! 18446: movl $reav1,r9 # point to powers of ten table ! 18447: moval 0[r6],r6 # convert remaining scale to byte ofs ! 18448: # ! 18449: # LOOP TO POINT TO POWERS OF TEN TABLE ENTRY ! 18450: # ! 18451: gtn25: addl2 r6,r9 # bump pointer ! 18452: sobgtr r7,gtn25 # once for each value word ! 18453: divf2 (r9),r2 # scale down as required ! 18454: jmp gtn30 # and jump ! 18455: # ! 18456: # COME HERE TO SCALE RESULT UP (POSITIVE EXPONENT) ! 18457: # ! 18458: gtn26: mnegl r5,r5 # get absolute value of exponent ! 18459: bvc 0f ! 18460: jmp gtn36 ! 18461: 0: ! 18462: movl r5,r6 # acquire scale, error if ovflow ! 18463: bgeq 0f ! 18464: jmp gtn36 ! 18465: 0: ! 18466: # ! 18467: # LOOP TO SCALE UP IN STEPS OF 10**10 ! 18468: # ! 18469: gtn27: cmpl r6,$num10 # jump if 10 or less to go ! 18470: blequ gtn28 ! 18471: mulf2 reatt,r2 # else multiply by 10**10 ! 18472: bvc 0f ! 18473: jmp gtn36 ! 18474: 0: ! 18475: subl2 $num10,r6 # else decrement scale ! 18476: jmp gtn27 # and loop back ! 18477: # ! 18478: # HERE TO SCALE UP REST OF WAY WITH TABLE ! 18479: # ! 18480: gtn28: tstl r6 # jump if scaled ! 18481: beqlu gtn30 ! 18482: movl $cfp$r,r7 # else get indexing factor ! 18483: movl $reav1,r9 # point to powers of ten table ! 18484: moval 0[r6],r6 # convert remaining scale to byte ofs ! 18485: # ! 18486: # LOOP TO POINT TO PROPER ENTRY IN POWERS OF TEN TABLE ! 18487: # ! 18488: gtn29: addl2 r6,r9 # bump pointer ! 18489: sobgtr r7,gtn29 # once for each word in value ! 18490: mulf2 (r9),r2 # scale up ! 18491: bvc 0f ! 18492: jmp gtn36 ! 18493: 0: ! 18494: #page ! 18495: # ! 18496: # GTNUM (CONTINUED) ! 18497: # ! 18498: # HERE WITH REAL VALUE SCALED AND READY EXCEPT FOR SIGN ! 18499: # ! 18500: gtn30: tstl gtnnf # jump if positive ! 18501: beqlu gtn31 ! 18502: mnegf r2,r2 # else negate ! 18503: # ! 18504: # HERE WITH PROPERLY SIGNED REAL VALUE IN (RA) ! 18505: # ! 18506: gtn31: jsb rcbld # build real block ! 18507: jmp gtn33 # merge to exit ! 18508: # ! 18509: # HERE WITH PROPERLY SIGNED INTEGER VALUE IN (IA) ! 18510: # ! 18511: gtn32: jsb icbld # build icblk ! 18512: # ! 18513: # REAL MERGES HERE ! 18514: # ! 18515: gtn33: movl (r9),r6 # load first word of result block ! 18516: addl2 $4,sp # pop argument off stack ! 18517: # ! 18518: # COMMON EXIT POINT ! 18519: # ! 18520: gtn34: addl2 $4*1,(sp) # return to gtnum caller ! 18521: rsb ! 18522: # ! 18523: # COME HERE IF OVERFLOW OCCURS DURING COLLECTION OF INTEGER ! 18524: # ! 18525: gtn35: movl gtnsi,r5 # reload integer so far ! 18526: cvtlf r5,r2 # convert to real ! 18527: mnegf r2,r2 # make value positive ! 18528: jmp gtn11 # merge with real circuit ! 18529: # ! 18530: # HERE FOR UNCONVERTIBLE TO STRING OR CONVERSION ERROR ! 18531: # ! 18532: gtn36: movl (sp)+,r9 # reload original argument ! 18533: movl (sp)+,r11 # take convert-error exit ! 18534: jmp *(r11)+ ! 18535: #enp # end procedure gtnum ! 18536: #page ! 18537: # ! 18538: # GTNVR -- CONVERT TO NATURAL VARIABLE ! 18539: # ! 18540: # GTNVR LOCATES A VARIABLE BLOCK (VRBLK) GIVEN EITHER AN ! 18541: # APPROPRIATE NAME (NMBLK) OR A NON-NULL STRING (SCBLK). ! 18542: # ! 18543: # (XR) ARGUMENT ! 18544: # JSR GTNVR CALL TO CONVERT TO NATURAL VARIABLE ! 18545: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 18546: # (XR) POINTER TO VRBLK ! 18547: # (WA,WB) DESTROYED (CONVERSION ERROR ONLY) ! 18548: # (WC) DESTROYED ! 18549: # ! 18550: gtnvr: #prc # entry point ! 18551: cmpl (r9),$b$nml # jump if not name ! 18552: bnequ gnv02 ! 18553: movl 4*nmbas(r9),r9 # else load name base if name ! 18554: cmpl r9,state # skip if vrblk (in static region) ! 18555: bgtru 0f ! 18556: jmp gnv07 ! 18557: 0: ! 18558: # ! 18559: # COMMON ERROR EXIT ! 18560: # ! 18561: gnv01: movl (sp)+,r11 # take convert-error exit ! 18562: jmp *(r11)+ ! 18563: # ! 18564: # HERE IF NOT NAME ! 18565: # ! 18566: gnv02: movl r6,gnvsa # save wa ! 18567: movl r7,gnvsb # save wb ! 18568: movl r9,-(sp) # stack argument for gtstg ! 18569: jsb gtstg # convert argument to string ! 18570: .long gnv01 # jump if conversion error ! 18571: tstl r6 # null string is an error ! 18572: beqlu gnv01 ! 18573: jsb flstg # fold lower case to upper case ! 18574: movl r10,-(sp) # save xl ! 18575: movl r9,-(sp) # stack string ptr for later ! 18576: movl r9,r7 # copy string pointer ! 18577: addl2 $4*schar,r7 # point to characters of string ! 18578: movl r7,gnvst # save pointer to characters ! 18579: movl r6,r7 # copy length ! 18580: movab 3+(4*0)(r7),r7 # get number of words in name ! 18581: ashl $-2,r7,r7 ! 18582: movl r7,gnvnw # save for later ! 18583: jsb hashs # compute hash index for string ! 18584: ashq $-32,r4,r4 # compute hash offset by taking mod ! 18585: ediv hshnb,r4,r11,r5 ! 18586: movl r5,r8 # get as offset ! 18587: moval 0[r8],r8 # convert offset to bytes ! 18588: addl2 hshtb,r8 # point to proper hash chain ! 18589: subl2 $4*vrnxt,r8 # subtract offset to merge into loop ! 18590: #page ! 18591: # ! 18592: # GTNVR (CONTINUED) ! 18593: # ! 18594: # LOOP TO SEARCH HASH CHAIN ! 18595: # ! 18596: gnv03: movl r8,r10 # copy hash chain pointer ! 18597: movl 4*vrnxt(r10),r10# point to next vrblk on chain ! 18598: tstl r10 # jump if end of chain ! 18599: beqlu gnv08 ! 18600: movl r10,r8 # save pointer to this vrblk ! 18601: tstl 4*vrlen(r10) # jump if not system variable ! 18602: bnequ gnv04 ! 18603: movl 4*vrsvp(r10),r10# else point to svblk ! 18604: subl2 $4*vrsof,r10 # adjust offset for merge ! 18605: # ! 18606: # MERGE HERE WITH STRING PTR (LIKE VRBLK) IN XL ! 18607: # ! 18608: gnv04: cmpl r6,4*vrlen(r10) # back for next vrblk if lengths ne ! 18609: bnequ gnv03 ! 18610: addl2 $4*vrchs,r10 # else point to chars of chain entry ! 18611: movl gnvnw,r7 # get word counter to control loop ! 18612: movl gnvst,r9 # point to chars of new name ! 18613: # ! 18614: # LOOP TO COMPARE CHARACTERS OF THE TWO NAMES ! 18615: # ! 18616: gnv05: cmpl (r9),(r10) # jump if no match for next vrblk ! 18617: bnequ gnv03 ! 18618: addl2 $4,r9 # bump new name pointer ! 18619: addl2 $4,r10 # bump vrblk in chain name pointer ! 18620: sobgtr r7,gnv05 # else loop till all compared ! 18621: movl r8,r9 # we have found a match, get vrblk ! 18622: # ! 18623: # EXIT POINT AFTER FINDING VRBLK OR BUILDING NEW ONE ! 18624: # ! 18625: gnv06: movl gnvsa,r6 # restore wa ! 18626: movl gnvsb,r7 # restore wb ! 18627: addl2 $4,sp # pop string pointer ! 18628: movl (sp)+,r10 # restore xl ! 18629: # ! 18630: # COMMON EXIT POINT ! 18631: # ! 18632: gnv07: addl2 $4*1,(sp) # return to gtnvr caller ! 18633: rsb ! 18634: # ! 18635: # NOT FOUND, PREPARE TO SEARCH SYSTEM VARIABLE TABLE ! 18636: # ! 18637: gnv08: clrl r9 # clear garbage xr pointer ! 18638: movl r8,gnvhe # save ptr to end of hash chain ! 18639: cmpl r6,$num09 # cannot be system var if length gt 9 ! 18640: bgtru gnv14 ! 18641: movl r6,r10 # else copy length ! 18642: moval 0[r10],r10 # convert to byte offset ! 18643: movl l^vsrch(r10),r10# point to first svblk of this length ! 18644: #page ! 18645: # ! 18646: # GTNVR (CONTINUED) ! 18647: # ! 18648: # LOOP TO SEARCH ENTRIES IN STANDARD VARIABLE TABLE ! 18649: # ! 18650: gnv09: movl r10,gnvsp # save table pointer ! 18651: movl (r10)+,r8 # load svbit bit string ! 18652: movl (r10)+,r7 # load length from table entry ! 18653: cmpl r6,r7 # jump if end of right length entires ! 18654: bnequ gnv14 ! 18655: movl gnvnw,r7 # get word counter to control loop ! 18656: movl gnvst,r9 # point to chars of new name ! 18657: # ! 18658: # LOOP TO CHECK FOR MATCHING NAMES ! 18659: # ! 18660: gnv10: cmpl (r9),(r10) # jump if name mismatch ! 18661: bnequ gnv11 ! 18662: addl2 $4,r9 # else bump new name pointer ! 18663: addl2 $4,r10 # bump svblk pointer ! 18664: sobgtr r7,gnv10 # else loop until all checked ! 18665: # ! 18666: # HERE WE HAVE A MATCH IN THE STANDARD VARIABLE TABLE ! 18667: # ! 18668: clrl r8 # set vrlen value zero ! 18669: movl $4*vrsi$,r6 # set standard size ! 18670: jmp gnv15 # jump to build vrblk ! 18671: # ! 18672: # HERE IF NO MATCH WITH TABLE ENTRY IN SVBLKS TABLE ! 18673: # ! 18674: gnv11: addl2 $4,r10 # bump past word of chars ! 18675: sobgtr r7,gnv11 # loop back if more to go ! 18676: ashl $-svnbt,r8,r8 # remove uninteresting bits ! 18677: # ! 18678: # LOOP TO BUMP TABLE PTR FOR EACH FLAGGED WORD ! 18679: # ! 18680: gnv12: movl bits1,r7 # load bit to test ! 18681: mcoml r8,r11 # test for word present ! 18682: bicl2 r11,r7 ! 18683: tstl r7 # jump if not present ! 18684: beqlu gnv13 ! 18685: addl2 $4,r10 # else bump table pointer ! 18686: # ! 18687: # HERE AFTER DEALING WITH ONE WORD (ONE BIT) ! 18688: # ! 18689: gnv13: ashl $-1,r8,r8 # remove bit already processed ! 18690: tstl r8 # loop back if more bits to test ! 18691: bnequ gnv12 ! 18692: jmp gnv09 # else loop back for next svblk ! 18693: # ! 18694: # HERE IF NOT SYSTEM VARIABLE ! 18695: # ! 18696: gnv14: movl r6,r8 # copy vrlen value ! 18697: movl $vrchs,r6 # load standard size -chars ! 18698: addl2 gnvnw,r6 # adjust for chars of name ! 18699: moval 0[r6],r6 # convert length to bytes ! 18700: #page ! 18701: # ! 18702: # GTNVR (CONTINUED) ! 18703: # ! 18704: # MERGE HERE TO BUILD VRBLK ! 18705: # ! 18706: gnv15: jsb alost # allocate space for vrblk (static) ! 18707: movl r9,r7 # save vrblk pointer ! 18708: movl $stnvr,r10 # point to model variable block ! 18709: movl $4*vrlen,r6 # set length of standard fields ! 18710: jsb sbmvw # set initial fields of new block ! 18711: movl gnvhe,r10 # load pointer to end of hash chain ! 18712: movl r7,4*vrnxt(r10) # add new block to end of chain ! 18713: movl r8,(r9)+ # set vrlen field, bump ptr ! 18714: movl gnvnw,r6 # get length in words ! 18715: moval 0[r6],r6 # convert to length in bytes ! 18716: tstl r8 # jump if system variable ! 18717: beqlu gnv16 ! 18718: # ! 18719: # HERE FOR NON-SYSTEM VARIABLE -- SET CHARS OF NAME ! 18720: # ! 18721: movl (sp),r10 # point back to string name ! 18722: addl2 $4*schar,r10 # point to chars of name ! 18723: jsb sbmvw # move characters into place ! 18724: movl r7,r9 # restore vrblk pointer ! 18725: jmp gnv06 # jump back to exit ! 18726: # ! 18727: # HERE FOR SYSTEM VARIABLE CASE TO FILL IN FIELDS WHERE ! 18728: # NECESSARY FROM THE FIELDS PRESENT IN THE SVBLK. ! 18729: # ! 18730: gnv16: movl gnvsp,r10 # load pointer to svblk ! 18731: movl r10,(r9) # set svblk ptr in vrblk ! 18732: movl r7,r9 # restore vrblk pointer ! 18733: movl 4*svbit(r10),r7 # load bit indicators ! 18734: addl2 $4*svchs,r10 # point to characters of name ! 18735: addl2 r6,r10 # point past characters ! 18736: # ! 18737: # SKIP PAST KEYWORD NUMBER (SVKNM) IF PRESENT ! 18738: # ! 18739: movl btknm,r8 # load test bit ! 18740: mcoml r7,r11 # and to test ! 18741: bicl2 r11,r8 ! 18742: tstl r8 # jump if no keyword number ! 18743: beqlu gnv17 ! 18744: addl2 $4,r10 # else bump pointer ! 18745: #page ! 18746: # ! 18747: # GTNVR (CONTINUED) ! 18748: # ! 18749: # HERE TEST FOR FUNCTION (SVFNC AND SVNAR) ! 18750: # ! 18751: gnv17: movl btfnc,r8 # get test bit ! 18752: mcoml r7,r11 # and to test ! 18753: bicl2 r11,r8 ! 18754: tstl r8 # skip if no system function ! 18755: beqlu gnv18 ! 18756: movl r10,4*vrfnc(r9) # else point vrfnc to svfnc field ! 18757: addl2 $4*num02,r10 # and bump past svfnc, svnar fields ! 18758: # ! 18759: # NOW TEST FOR LABEL (SVLBL) ! 18760: # ! 18761: gnv18: movl btlbl,r8 # get test bit ! 18762: mcoml r7,r11 # and to test ! 18763: bicl2 r11,r8 ! 18764: tstl r8 # jump if bit is off (no system labl) ! 18765: beqlu gnv19 ! 18766: movl r10,4*vrlbl(r9) # else point vrlbl to svlbl field ! 18767: addl2 $4,r10 # bump past svlbl field ! 18768: # ! 18769: # NOW TEST FOR VALUE (SVVAL) ! 18770: # ! 18771: gnv19: movl btval,r8 # load test bit ! 18772: mcoml r7,r11 # and to test ! 18773: bicl2 r11,r8 ! 18774: tstl r8 # all done if no value ! 18775: bnequ 0f ! 18776: jmp gnv06 ! 18777: 0: ! 18778: movl (r10),4*vrval(r9)# else set initial value ! 18779: movl $b$vre,4*vrsto(r9) # set error store access ! 18780: jmp gnv06 # merge back to exit to caller ! 18781: #enp # end procedure gtnvr ! 18782: #page ! 18783: # ! 18784: # GTPAT -- GET PATTERN ! 18785: # ! 18786: # GTPAT IS PASSED AN OBJECT IN (XR) AND RETURNS A ! 18787: # PATTERN AFTER PERFORMING ANY NECESSARY CONVERSIONS ! 18788: # ! 18789: # (XR) INPUT ARGUMENT ! 18790: # JSR GTPAT CALL TO CONVERT TO PATTERN ! 18791: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 18792: # (XR) RESULTING PATTERN ! 18793: # (WA) DESTROYED ! 18794: # (WB) DESTROYED (ONLY ON CONVERT ERROR) ! 18795: # (XR) UNCHANGED (ONLY ON CONVERT ERROR) ! 18796: # ! 18797: gtpat: #prc # entry point ! 18798: cmpl (r9),$p$aaa # jump if pattern already ! 18799: bgequ gtpt5 ! 18800: # ! 18801: # HERE IF NOT PATTERN, TRY FOR STRING ! 18802: # ! 18803: movl r7,gtpsb # save wb ! 18804: movl r9,-(sp) # stack argument for gtstg ! 18805: jsb gtstg # convert argument to string ! 18806: .long gtpt2 # jump if impossible ! 18807: # ! 18808: # HERE WE HAVE A STRING ! 18809: # ! 18810: tstl r6 # jump if non-null ! 18811: bnequ gtpt1 ! 18812: # ! 18813: # HERE FOR NULL STRING. GENERATE POINTER TO NULL PATTERN. ! 18814: # ! 18815: movl $ndnth,r9 # point to nothen node ! 18816: jmp gtpt4 # jump to exit ! 18817: #page ! 18818: # ! 18819: # GTPAT (CONTINUED) ! 18820: # ! 18821: # HERE FOR NON-NULL STRING ! 18822: # ! 18823: gtpt1: movl $p$str,r7 # load pcode for multi-char string ! 18824: cmpl r6,$num01 # jump if multi-char string ! 18825: bnequ gtpt3 ! 18826: # ! 18827: # HERE FOR ONE CHARACTER STRING, SHARE ONE CHARACTER ANY ! 18828: # ! 18829: movab cfp$f(r9),r9 # point to character ! 18830: movzbl (r9),r6 # load character ! 18831: movl r6,r9 # set as parm1 ! 18832: movl $p$ans,r7 # point to pcode for 1-char any ! 18833: jmp gtpt3 # jump to build node ! 18834: # ! 18835: # HERE IF ARGUMENT IS NOT CONVERTIBLE TO STRING ! 18836: # ! 18837: gtpt2: movl $p$exa,r7 # set pcode for expression in case ! 18838: cmpl (r9),$b$e$$ # jump to build node if expression ! 18839: blequ gtpt3 ! 18840: # ! 18841: # HERE WE HAVE AN ERROR (CONVERSION IMPOSSIBLE) ! 18842: # ! 18843: movl (sp)+,r11 # take convert error exit ! 18844: jmp *(r11)+ ! 18845: # ! 18846: # MERGE HERE TO BUILD NODE FOR STRING OR EXPRESSION ! 18847: # ! 18848: gtpt3: jsb pbild # call routine to build pattern node ! 18849: # ! 18850: # COMMON EXIT AFTER SUCCESSFUL CONVERSION ! 18851: # ! 18852: gtpt4: movl gtpsb,r7 # restore wb ! 18853: # ! 18854: # MERGE HERE TO EXIT OF NO CONVERSION REQUIRED ! 18855: # ! 18856: gtpt5: addl2 $4*1,(sp) # return to gtpat caller ! 18857: rsb ! 18858: #enp # end procedure gtpat ! 18859: #page ! 18860: # ! 18861: # GTREA -- GET REAL VALUE ! 18862: # ! 18863: # GTREA IS PASSED AN OBJECT AND RETURNS A REAL VALUE ! 18864: # PERFORMING ANY NECESSARY CONVERSIONS. ! 18865: # ! 18866: # (XR) OBJECT TO BE CONVERTED ! 18867: # JSR GTREA CALL TO CONVERT OBJECT TO REAL ! 18868: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 18869: # (XR) POINTER TO RESULTING REAL ! 18870: # (WA,WB,WC,RA) DESTROYED ! 18871: # (XR) UNCHANGED (CONVERT ERROR ONLY) ! 18872: # ! 18873: gtrea: #prc # entry point ! 18874: movl (r9),r6 # get first word of block ! 18875: cmpl r6,$b$rcl # jump if real ! 18876: beqlu gtre2 ! 18877: jsb gtnum # else convert argument to numeric ! 18878: .long gtre3 # jump if unconvertible ! 18879: cmpl r6,$b$rcl # jump if real was returned ! 18880: beqlu gtre2 ! 18881: # ! 18882: # HERE FOR CASE OF AN INTEGER TO CONVERT TO REAL ! 18883: # ! 18884: gtre1: movl 4*icval(r9),r5 # load integer ! 18885: cvtlf r5,r2 # convert to real ! 18886: jsb rcbld # build rcblk ! 18887: # ! 18888: # EXIT WITH REAL ! 18889: # ! 18890: gtre2: addl2 $4*1,(sp) # return to gtrea caller ! 18891: rsb ! 18892: # ! 18893: # HERE ON CONVERSION ERROR ! 18894: # ! 18895: gtre3: movl (sp)+,r11 # take convert error exit ! 18896: jmp *(r11)+ ! 18897: #enp # end procedure gtrea ! 18898: #page ! 18899: # ! 18900: # GTSMI -- GET SMALL INTEGER ! 18901: # ! 18902: # GTSMI IS PASSED A SNOBOL OBJECT AND RETURNS AN ADDRESS ! 18903: # INTEGER IN THE RANGE (0 LE N LE DNAMB). SUCH A VALUE CAN ! 18904: # ONLY BE DERIVED FROM AN INTEGER IN THE APPROPRIATE RANGE. ! 18905: # SMALL INTEGERS NEVER APPEAR AS SNOBOL VALUES. HOWEVER, ! 18906: # THEY ARE USED INTERNALLY FOR A VARIETY OF PURPOSES. ! 18907: # ! 18908: # -(XS) ARGUMENT TO CONVERT (ON STACK) ! 18909: # JSR GTSMI CALL TO CONVERT TO SMALL INTEGER ! 18910: # PPM LOC TRANSFER LOC FOR NOT INTEGER ! 18911: # PPM LOC TRANSFER LOC FOR LT 0, GT DNAMB ! 18912: # (XR,WC) RESULTING SMALL INT (TWO COPIES) ! 18913: # (XS) POPPED ! 18914: # (RA) DESTROYED ! 18915: # (WA,WB) DESTROYED (ON CONVERT ERROR ONLY) ! 18916: # (XR) INPUT ARG (CONVERT ERROR ONLY) ! 18917: # ! 18918: .data 1 ! 18919: gtsmi_s: .long 0 ! 18920: .text 0 ! 18921: gtsmi: movl (sp)+,gtsmi_s # entry point ! 18922: movl (sp)+,r9 # load argument ! 18923: cmpl (r9),$b$icl # skip if already an integer ! 18924: beqlu gtsm1 ! 18925: # ! 18926: # HERE IF NOT AN INTEGER ! 18927: # ! 18928: jsb gtint # convert argument to integer ! 18929: .long gtsm2 # jump if convert is impossible ! 18930: # ! 18931: # MERGE HERE WITH INTEGER ! 18932: # ! 18933: gtsm1: movl 4*icval(r9),r5 # load integer value ! 18934: movl r5,r8 # move as one word, jump if ovflow ! 18935: bgeq 0f ! 18936: jmp gtsm3 ! 18937: 0: ! 18938: cmpl r8,mxlen # or if too small ! 18939: bgtru gtsm3 ! 18940: movl r8,r9 # copy result to xr ! 18941: addl3 $4*2,gtsmi_s,r11 # return to gtsmi caller ! 18942: jmp (r11) ! 18943: # ! 18944: # HERE IF UNCONVERTIBLE TO INTEGER ! 18945: # ! 18946: gtsm2: movl gtsmi_s,r11 # take non-integer error exit ! 18947: jmp *(r11)+ ! 18948: # ! 18949: # HERE IF OUT OF RANGE ! 18950: # ! 18951: gtsm3: addl3 $4*1,gtsmi_s,r11 # take out-of-range error exit ! 18952: jmp *(r11)+ ! 18953: #enp # end procedure gtsmi ! 18954: #page ! 18955: # ! 18956: # GTSTG -- GET STRING ! 18957: # ! 18958: # GTSTG IS PASSED AN OBJECT AND RETURNS A STRING WITH ! 18959: # ANY NECESSARY CONVERSIONS PERFORMED. ! 18960: # ! 18961: # -(XS) INPUT ARGUMENT (ON STACK) ! 18962: # JSR GTSTG CALL TO CONVERT TO STRING ! 18963: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 18964: # (XR) POINTER TO RESULTING STRING ! 18965: # (WA) LENGTH OF STRING IN CHARACTERS ! 18966: # (XS) POPPED ! 18967: # (RA) DESTROYED ! 18968: # (XR) INPUT ARG (CONVERT ERROR ONLY) ! 18969: # ! 18970: .data 1 ! 18971: gtstg_s: .long 0 ! 18972: .text 0 ! 18973: gtstg: movl (sp)+,gtstg_s # entry point ! 18974: movl (sp)+,r9 # load argument, pop stack ! 18975: cmpl (r9),$b$scl # jump if already a string ! 18976: bnequ 0f ! 18977: jmp gts30 ! 18978: 0: ! 18979: # ! 18980: # HERE IF NOT A STRING ALREADY ! 18981: # ! 18982: gts01: movl r9,-(sp) # restack argument in case error ! 18983: movl r10,-(sp) # save xl ! 18984: movl r7,gtsvb # save wb ! 18985: movl r8,gtsvc # save wc ! 18986: movl (r9),r6 # load first word of block ! 18987: cmpl r6,$b$icl # jump to convert integer ! 18988: beqlu gts05 ! 18989: cmpl r6,$b$rcl # jump to convert real ! 18990: bnequ 0f ! 18991: jmp gts10 ! 18992: 0: ! 18993: cmpl r6,$b$nml # jump to convert name ! 18994: beqlu gts03 ! 18995: cmpl r6,$b$bct # jump to convert buffer ! 18996: bnequ 0f ! 18997: jmp gts32 ! 18998: 0: ! 18999: # ! 19000: # HERE ON CONVERSION ERROR ! 19001: # ! 19002: gts02: movl (sp)+,r10 # restore xl ! 19003: movl (sp)+,r9 # reload input argument ! 19004: movl gtstg_s,r11 # take convert error exit ! 19005: jmp *(r11)+ ! 19006: #page ! 19007: # ! 19008: # GTSTG (CONTINUED) ! 19009: # ! 19010: # HERE TO CONVERT A NAME (ONLY POSSIBLE IF NATURAL VAR) ! 19011: # ! 19012: gts03: movl 4*nmbas(r9),r10 # load name base ! 19013: cmpl r10,state # error if not natural var (static) ! 19014: bgequ gts02 ! 19015: addl2 $4*vrsof,r10 # else point to possible string name ! 19016: movl 4*sclen(r10),r6 # load length ! 19017: tstl r6 # jump if not system variable ! 19018: bnequ gts04 ! 19019: movl 4*vrsvo(r10),r10# else point to svblk ! 19020: movl 4*svlen(r10),r6 # and load name length ! 19021: # ! 19022: # MERGE HERE WITH STRING IN XR, LENGTH IN WA ! 19023: # ! 19024: gts04: clrl r7 # set offset to zero ! 19025: jsb sbstr # use sbstr to copy string ! 19026: jmp gts29 # jump to exit ! 19027: # ! 19028: # COME HERE TO CONVERT AN INTEGER ! 19029: # ! 19030: gts05: movl 4*icval(r9),r5 # load integer value ! 19031: movl $num01,gtssf # set sign flag negative ! 19032: tstl r5 # skip if integer is negative ! 19033: blss gts06 ! 19034: mnegl r5,r5 # else negate integer ! 19035: clrl gtssf # and reset negative flag ! 19036: #page ! 19037: # ! 19038: # GTSTG (CONTINUED) ! 19039: # ! 19040: # HERE WITH SIGN FLAG SET AND SIGN FORCED NEGATIVE AS ! 19041: # REQUIRED BY THE CVD INSTRUCTION. ! 19042: # ! 19043: gts06: movl gtswk,r9 # point to result work area ! 19044: movl $nstmx,r7 # initialize counter to max length ! 19045: movab cfp$f(r9)[r7],r9# prepare to store (right-left) ! 19046: # ! 19047: # LOOP TO CONVERT DIGITS INTO WORK AREA ! 19048: # ! 19049: gts07: ashq $-32,r4,r4 # convert one digit into wa ! 19050: ediv $10,r4,r5,r6 ! 19051: mnegl r6,r6 ! 19052: bisb2 $0x30,r6 ! 19053: movb r6,-(r9) # store in work area ! 19054: decl r7 # decrement counter ! 19055: tstl r5 # loop if more digits to go ! 19056: bneq gts07 ! 19057: #csc r9 # complete store characters ! 19058: # ! 19059: # MERGE HERE AFTER CONVERTING INTEGER OR REAL INTO WORK ! 19060: # AREA. WB IS SET TO NSTMX - (NUMBER OF CHARS IN RESULT). ! 19061: # ! 19062: gts08: movl $nstmx,r6 # get max number of characters ! 19063: subl2 r7,r6 # compute length of result ! 19064: movl r6,r10 # remember length for move later on ! 19065: addl2 gtssf,r6 # add one for negative sign if needed ! 19066: jsb alocs # allocate string for result ! 19067: movl r9,r8 # save result pointer for the moment ! 19068: movab cfp$f(r9),r9 # point to chars of result block ! 19069: tstl gtssf # skip if positive ! 19070: beqlu gts09 ! 19071: movl $ch$mn,r6 # else load negative sign ! 19072: movb r6,(r9)+ # and store it ! 19073: #csc r9 # complete store characters ! 19074: # ! 19075: # HERE AFTER DEALING WITH SIGN ! 19076: # ! 19077: gts09: movl r10,r6 # recall length to move ! 19078: movl gtswk,r10 # point to result work area ! 19079: movab cfp$f(r10)[r7],r10 # point to first result character ! 19080: jsb sbmvc # move chars to result string ! 19081: movl r8,r9 # restore result pointer ! 19082: jmp gts29 # jump to exit ! 19083: #page ! 19084: # ! 19085: # GTSTG (CONTINUED) ! 19086: # ! 19087: # HERE TO CONVERT A REAL ! 19088: # ! 19089: gts10: movf 4*rcval(r9),r2 # load real ! 19090: clrl gtssf # reset negative flag ! 19091: tstf r2 # skip if zero ! 19092: bneq 0f ! 19093: jmp gts31 ! 19094: 0: ! 19095: tstf r2 # jump if real is positive ! 19096: bgeq gts11 ! 19097: movl $num01,gtssf # else set negative flag ! 19098: mnegf r2,r2 # and get absolute value of real ! 19099: # ! 19100: # NOW SCALE THE REAL TO THE RANGE (0.1 LE X LT 1.0) ! 19101: # ! 19102: gts11: movl intv0,r5 # initialize exponent to zero ! 19103: # ! 19104: # LOOP TO SCALE UP IN STEPS OF 10**10 ! 19105: # ! 19106: gts12: movf r2,gtsrs # save real value ! 19107: subf2 reap1,r2 # subtract 0.1 to compare ! 19108: tstf r2 # jump if scale up not required ! 19109: bgeq gts13 ! 19110: movf gtsrs,r2 # else reload value ! 19111: mulf2 reatt,r2 # multiply by 10**10 ! 19112: subl2 intvt,r5 # decrement exponent by 10 ! 19113: jmp gts12 # loop back to test again ! 19114: # ! 19115: # TEST FOR SCALE DOWN REQUIRED ! 19116: # ! 19117: gts13: movf gtsrs,r2 # reload value ! 19118: subf2 reav1,r2 # subtract 1.0 ! 19119: tstf r2 # jump if no scale down required ! 19120: blss gts17 ! 19121: movf gtsrs,r2 # else reload value ! 19122: # ! 19123: # LOOP TO SCALE DOWN IN STEPS OF 10**10 ! 19124: # ! 19125: gts14: subf2 reatt,r2 # subtract 10**10 to compare ! 19126: tstf r2 # jump if large step not required ! 19127: blss gts15 ! 19128: movf gtsrs,r2 # else restore value ! 19129: divf2 reatt,r2 # divide by 10**10 ! 19130: movf r2,gtsrs # store new value ! 19131: addl2 intvt,r5 # increment exponent by 10 ! 19132: jmp gts14 # loop back ! 19133: #page ! 19134: # ! 19135: # GTSTG (CONTINUED) ! 19136: # ! 19137: # AT THIS POINT WE HAVE (1.0 LE X LT 10**10) ! 19138: # COMPLETE SCALING WITH POWERS OF TEN TABLE ! 19139: # ! 19140: gts15: movl $reav1,r9 # point to powers of ten table ! 19141: # ! 19142: # LOOP TO LOCATE CORRECT ENTRY IN TABLE ! 19143: # ! 19144: gts16: movf gtsrs,r2 # reload value ! 19145: addl2 intv1,r5 # increment exponent ! 19146: addl2 $4*cfp$r,r9 # point to next entry in table ! 19147: subf2 (r9),r2 # subtract it to compare ! 19148: tstf r2 # loop till we find a larger entry ! 19149: bgeq gts16 ! 19150: movf gtsrs,r2 # then reload the value ! 19151: divf2 (r9),r2 # and complete scaling ! 19152: movf r2,gtsrs # store value ! 19153: # ! 19154: # WE ARE NOW SCALED, SO ROUND BY ADDING 0.5 * 10**(-CFP$S) ! 19155: # ! 19156: gts17: movf gtsrs,r2 # get value again ! 19157: addf2 gtsrn,r2 # add rounding factor ! 19158: movf r2,gtsrs # store result ! 19159: # ! 19160: # THE ROUNDING OPERATION MAY HAVE PUSHED US UP PAST ! 19161: # 1.0 AGAIN, SO CHECK ONE MORE TIME. ! 19162: # ! 19163: subf2 reav1,r2 # subtract 1.0 to compare ! 19164: tstf r2 # skip if ok ! 19165: blss gts18 ! 19166: addl2 intv1,r5 # else increment exponent ! 19167: movf gtsrs,r2 # reload value ! 19168: divf2 reavt,r2 # divide by 10.0 to rescale ! 19169: jmp gts19 # jump to merge ! 19170: # ! 19171: # HERE IF ROUNDING DID NOT MUCK UP SCALING ! 19172: # ! 19173: gts18: movf gtsrs,r2 # reload rounded value ! 19174: #page ! 19175: # ! 19176: # GTSTG (CONTINUED) ! 19177: # ! 19178: # NOW WE HAVE COMPLETED THE SCALING AS FOLLOWS ! 19179: # ! 19180: # (IA) SIGNED EXPONENT ! 19181: # (RA) SCALED REAL (ABSOLUTE VALUE) ! 19182: # ! 19183: # IF THE EXPONENT IS NEGATIVE OR GREATER THAN CFP$S, THEN ! 19184: # WE CONVERT THE NUMBER IN THE FORM. ! 19185: # ! 19186: # (NEG SIGN) 0 . (CPF$S DIGITS) E (EXP SIGN) (EXP DIGITS) ! 19187: # ! 19188: # IF THE EXPONENT IS POSITIVE AND LESS THAN OR EQUAL TO ! 19189: # CFP$S, THE NUMBER IS CONVERTED IN THE FORM. ! 19190: # ! 19191: # (NEG SIGN) (EXPONENT DIGITS) . (CFP$S-EXPONENT DIGITS) ! 19192: # ! 19193: # IN BOTH CASES, THE FORMATS OBTAINED FROM THE ABOVE ! 19194: # RULES ARE MODIFIED BY DELETING TRAILING ZEROS AFTER THE ! 19195: # DECIMAL POINT. THERE ARE NO LEADING ZEROS IN THE EXPONENT ! 19196: # AND THE EXPONENT SIGN IS ALWAYS PRESENT. ! 19197: # ! 19198: gts19: movl $cfp$s,r10 # set num dec digits = cfp$s ! 19199: movl $ch$mn,gtses # set exponent sign negative ! 19200: tstl r5 # all set if exponent is negative ! 19201: blss gts21 ! 19202: movl r5,r6 # else fetch exponent ! 19203: cmpl r6,$cfp$s # skip if we can use special format ! 19204: blequ gts20 ! 19205: movl r6,r5 # else restore exponent ! 19206: mnegl r5,r5 # set negative for cvd ! 19207: movl $ch$pl,gtses # set plus sign for exponent sign ! 19208: jmp gts21 # jump to generate exponent ! 19209: # ! 19210: # HERE IF WE CAN USE THE FORMAT WITHOUT AN EXPONENT ! 19211: # ! 19212: gts20: subl2 r6,r10 # compute digits after decimal point ! 19213: movl intv0,r5 # reset exponent to zero ! 19214: #page ! 19215: # ! 19216: # GTSTG (CONTINUED) ! 19217: # ! 19218: # MERGE HERE AS FOLLOWS ! 19219: # ! 19220: # (IA) EXPONENT ABSOLUTE VALUE ! 19221: # GTSES CHARACTER FOR EXPONENT SIGN ! 19222: # (RA) POSITIVE FRACTION ! 19223: # (XL) NUMBER OF DIGITS AFTER DEC POINT ! 19224: # ! 19225: gts21: movl gtswk,r9 # point to work area ! 19226: movl $nstmx,r7 # set character ctr to max length ! 19227: movab cfp$f(r9)[r7],r9# prepare to store (right to left) ! 19228: tstl r5 # skip exponent if it is zero ! 19229: beql gts23 ! 19230: # ! 19231: # LOOP TO GENERATE DIGITS OF EXPONENT ! 19232: # ! 19233: gts22: ashq $-32,r4,r4 # convert a digit into wa ! 19234: ediv $10,r4,r5,r6 ! 19235: mnegl r6,r6 ! 19236: bisb2 $0x30,r6 ! 19237: movb r6,-(r9) # store in work area ! 19238: decl r7 # decrement counter ! 19239: tstl r5 # loop back if more digits to go ! 19240: bneq gts22 ! 19241: # ! 19242: # HERE GENERATE EXPONENT SIGN AND E ! 19243: # ! 19244: movl gtses,r6 # load exponent sign ! 19245: movb r6,-(r9) # store in work area ! 19246: movl $ch$le,r6 # get character letter e ! 19247: movb r6,-(r9) # store in work area ! 19248: subl2 $num02,r7 # decrement counter for sign and e ! 19249: # ! 19250: # HERE TO GENERATE THE FRACTION ! 19251: # ! 19252: gts23: mulf2 gtssc,r2 # convert real to integer (10**cfp$s) ! 19253: cvtfl r2,r5 # get integer (overflow impossible) ! 19254: mnegl r5,r5 # negate as required by cvd ! 19255: # ! 19256: # LOOP TO SUPPRESS TRAILING ZEROS ! 19257: # ! 19258: gts24: tstl r10 # jump if no digits left to do ! 19259: beqlu gts27 ! 19260: ashq $-32,r4,r4 # else convert one digit ! 19261: ediv $10,r4,r5,r6 ! 19262: mnegl r6,r6 ! 19263: bisb2 $0x30,r6 ! 19264: cmpl r6,$ch$d0 # jump if not a zero ! 19265: bnequ gts26 ! 19266: decl r10 # decrement counter ! 19267: jmp gts24 # loop back for next digit ! 19268: #page ! 19269: # ! 19270: # GTSTG (CONTINUED) ! 19271: # ! 19272: # LOOP TO GENERATE DIGITS AFTER DECIMAL POINT ! 19273: # ! 19274: gts25: ashq $-32,r4,r4 # convert a digit into wa ! 19275: ediv $10,r4,r5,r6 ! 19276: mnegl r6,r6 ! 19277: bisb2 $0x30,r6 ! 19278: # ! 19279: # MERGE HERE FIRST TIME ! 19280: # ! 19281: gts26: movb r6,-(r9) # store digit ! 19282: decl r7 # decrement counter ! 19283: decl r10 # decrement counter ! 19284: tstl r10 # loop back if more to go ! 19285: bnequ gts25 ! 19286: # ! 19287: # HERE GENERATE THE DECIMAL POINT ! 19288: # ! 19289: gts27: movl $ch$dt,r6 # load decimal point ! 19290: movb r6,-(r9) # store in work area ! 19291: decl r7 # decrement counter ! 19292: # ! 19293: # HERE GENERATE THE DIGITS BEFORE THE DECIMAL POINT ! 19294: # ! 19295: gts28: ashq $-32,r4,r4 # convert a digit into wa ! 19296: ediv $10,r4,r5,r6 ! 19297: mnegl r6,r6 ! 19298: bisb2 $0x30,r6 ! 19299: movb r6,-(r9) # store in work area ! 19300: decl r7 # decrement counter ! 19301: tstl r5 # loop back if more to go ! 19302: bneq gts28 ! 19303: #csc r9 # complete store characters ! 19304: jmp gts08 # else jump back to exit ! 19305: # ! 19306: # EXIT POINT AFTER SUCCESSFUL CONVERSION ! 19307: # ! 19308: gts29: movl (sp)+,r10 # restore xl ! 19309: addl2 $4,sp # pop argument ! 19310: movl gtsvb,r7 # restore wb ! 19311: movl gtsvc,r8 # restore wc ! 19312: # ! 19313: # MERGE HERE IF NO CONVERSION REQUIRED ! 19314: # ! 19315: gts30: movl 4*sclen(r9),r6 # load string length ! 19316: addl3 $4*1,gtstg_s,r11 # return to caller ! 19317: jmp (r11) ! 19318: # ! 19319: # HERE TO RETURN STRING FOR REAL ZERO ! 19320: # ! 19321: gts31: movl $scre0,r10 # point to string ! 19322: movl $num02,r6 # 2 chars ! 19323: clrl r7 # zero offset ! 19324: jsb sbstr # copy string ! 19325: jmp gts29 # return ! 19326: #page ! 19327: # ! 19328: # HERE TO CONVERT A BUFFER BLOCK ! 19329: # ! 19330: gts32: movl r9,r10 # copy arg ptr ! 19331: movl 4*bclen(r10),r6 # get size to allocate ! 19332: tstl r6 # if null then return null ! 19333: beqlu gts33 ! 19334: jsb alocs # allocate string frame ! 19335: movl r9,r7 # save string ptr ! 19336: movl 4*sclen(r9),r6 # get length to move ! 19337: movab 3+(4*0)(r6),r6 # get as multiple of word size ! 19338: bicl2 $3,r6 ! 19339: movl 4*bcbuf(r10),r10# point to bfblk ! 19340: addl2 $4*scsi$,r9 # point to start of character area ! 19341: addl2 $4*bfsi$,r10 # point to start of buffer chars ! 19342: jsb sbmvw # copy words ! 19343: movl r7,r9 # restore scblk ptr ! 19344: jmp gts29 # exit with scblk ! 19345: # ! 19346: # HERE WHEN NULL BUFFER IS BEING CONVERTED ! 19347: # ! 19348: gts33: movl $nulls,r9 # point to null ! 19349: jmp gts29 # exit with null ! 19350: #enp # end procedure gtstg ! 19351: #page ! 19352: # ! 19353: # GTVAR -- GET VARIABLE FOR I/O/TRACE ASSOCIATION ! 19354: # ! 19355: # GTVAR IS USED TO POINT TO AN ACTUAL VARIABLE LOCATION ! 19356: # FOR THE DETACH,INPUT,OUTPUT,TRACE,STOPTR SYSTEM FUNCTIONS ! 19357: # ! 19358: # (XR) ARGUMENT TO FUNCTION ! 19359: # JSR GTVAR CALL TO LOCATE VARIABLE POINTER ! 19360: # PPM LOC TRANSFER LOC IF NOT OK VARIABLE ! 19361: # (XL,WA) NAME BASE,OFFSET OF VARIABLE ! 19362: # (XR,RA) DESTROYED ! 19363: # (WB,WC) DESTROYED (CONVERT ERROR ONLY) ! 19364: # (XR) INPUT ARG (CONVERT ERROR ONLY) ! 19365: # ! 19366: gtvar: #prc # entry point ! 19367: cmpl (r9),$b$nml # jump if not a name ! 19368: bnequ gtvr2 ! 19369: movl 4*nmofs(r9),r6 # else load name offset ! 19370: movl 4*nmbas(r9),r10 # load name base ! 19371: cmpl (r10),$b$evt # error if expression variable ! 19372: beqlu gtvr1 ! 19373: cmpl (r10),$b$kvt # all ok if not keyword variable ! 19374: bnequ gtvr3 ! 19375: # ! 19376: # HERE ON CONVERSION ERROR ! 19377: # ! 19378: gtvr1: movl (sp)+,r11 # take convert error exit ! 19379: jmp *(r11)+ ! 19380: # ! 19381: # HERE IF NOT A NAME, TRY CONVERT TO NATURAL VARIABLE ! 19382: # ! 19383: gtvr2: movl r8,gtvrc # save wc ! 19384: jsb gtnvr # locate vrblk if possible ! 19385: .long gtvr1 # jump if convert error ! 19386: movl r9,r10 # else copy vrblk name base ! 19387: movl $4*vrval,r6 # and set offset ! 19388: movl gtvrc,r8 # restore wc ! 19389: # ! 19390: # HERE FOR NAME OBTAINED ! 19391: # ! 19392: gtvr3: cmpl r10,state # all ok if not natural variable ! 19393: bgequ gtvr4 ! 19394: cmpl 4*vrsto(r10),$b$vre # error if protected variable ! 19395: beqlu gtvr1 ! 19396: # ! 19397: # COMMON EXIT POINT ! 19398: # ! 19399: gtvr4: addl2 $4*1,(sp) # return to caller ! 19400: rsb ! 19401: #enp # end procedure gtvar ! 19402: #page ! 19403: # ! 19404: # HASHS -- COMPUTE HASH INDEX FOR STRING ! 19405: # ! 19406: # HASHS IS USED TO CONVERT A STRING TO A UNIQUE INTEGER ! 19407: # VALUE. THE RESULTING HASH VALUE IS A POSITIVE INTEGER ! 19408: # IN THE RANGE 0 TO CFP$M ! 19409: # ! 19410: # (XR) STRING TO BE HASHED ! 19411: # JSR HASHS CALL TO HASH STRING ! 19412: # (IA) HASH VALUE ! 19413: # (XR,WB,WC) DESTROYED ! 19414: # ! 19415: # THE HASH FUNCTION USED IS AS FOLLOWS. ! 19416: # ! 19417: # START WITH THE LENGTH OF THE STRING (SGD07) ! 19418: # ! 19419: # TAKE THE FIRST E$HNW WORDS OF THE CHARACTERS FROM ! 19420: # THE STRING OR ALL THE WORDS IF FEWER THAN E$HNW. ! 19421: # ! 19422: # COMPUTE THE EXCLUSIVE OR OF ALL THESE WORDS TREATING ! 19423: # THEM AS ONE WORD BIT STRING VALUES. ! 19424: # ! 19425: # MOVE THE RESULT AS AN INTEGER WITH THE MTI INSTRUCTION. ! 19426: # ! 19427: hashs: #prc # entry point ! 19428: movl 4*sclen(r9),r8 # load string length in characters ! 19429: movl r8,r7 # initialize with length ! 19430: tstl r8 # jump if null string ! 19431: beqlu hshs3 ! 19432: movab 3+(4*0)(r8),r8 # else get number of words of chars ! 19433: ashl $-2,r8,r8 ! 19434: addl2 $4*schar,r9 # point to characters of string ! 19435: cmpl r8,$e$hnw # use whole string if short ! 19436: blequ hshs1 ! 19437: movl $e$hnw,r8 # else set to involve first e$hnw wds ! 19438: # ! 19439: # HERE WITH COUNT OF WORDS TO CHECK IN WC ! 19440: # ! 19441: hshs1: # set counter to control loop ! 19442: # ! 19443: # LOOP TO COMPUTE EXCLUSIVE OR ! 19444: # ! 19445: hshs2: xorl2 (r9)+,r7 # exclusive or next word of chars ! 19446: sobgtr r8,hshs2 # loop till all processed ! 19447: # ! 19448: # MERGE HERE WITH EXCLUSIVE OR IN WB ! 19449: # ! 19450: hshs3: #zgb r7 # zeroise undefined bits ! 19451: mcoml bitsm,r11 # ensure in range 0 to cfp$m ! 19452: bicl2 r11,r7 ! 19453: movl r7,r5 # move result as integer ! 19454: clrl r9 # clear garbage value in xr ! 19455: rsb # return to hashs caller ! 19456: #enp # end procedure hashs ! 19457: #page ! 19458: # ! 19459: # ICBLD -- BUILD INTEGER BLOCK ! 19460: # ! 19461: # (IA) INTEGER VALUE FOR ICBLK ! 19462: # JSR ICBLD CALL TO BUILD INTEGER BLOCK ! 19463: # (XR) POINTER TO RESULT ICBLK ! 19464: # (WA) DESTROYED ! 19465: # ! 19466: icbld: #prc # entry point ! 19467: movl r5,r9 # copy small integers ! 19468: bgeq 0f ! 19469: jmp icbl1 ! 19470: 0: ! 19471: cmpl r9,$num02 # jump if 0,1 or 2 ! 19472: blequ icbl3 ! 19473: # ! 19474: # CONSTRUCT ICBLK ! 19475: # ! 19476: icbl1: movl dnamp,r9 # load pointer to next available loc ! 19477: addl2 $4*icsi$,r9 # point past new icblk ! 19478: cmpl r9,dname # jump if there is room ! 19479: blequ icbl2 ! 19480: movl $4*icsi$,r6 # else load length of icblk ! 19481: jsb alloc # use standard allocator to get block ! 19482: addl2 r6,r9 # point past block to merge ! 19483: # ! 19484: # MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED ! 19485: # ! 19486: icbl2: movl r9,dnamp # set new pointer ! 19487: subl2 $4*icsi$,r9 # point back to start of block ! 19488: movl $b$icl,(r9) # store type word ! 19489: movl r5,4*icval(r9) # store integer value in icblk ! 19490: rsb # return to icbld caller ! 19491: # ! 19492: # OPTIMISE BY NOT BUILDING ICBLKS FOR SMALL INTEGERS ! 19493: # ! 19494: icbl3: moval 0[r9],r9 # convert integer to offset ! 19495: movl l^intab(r9),r9 # point to pre-built icblk ! 19496: rsb # return ! 19497: #enp # end procedure icbld ! 19498: #page ! 19499: # ! 19500: # IDENT -- COMPARE TWO VALUES ! 19501: # ! 19502: # IDENT COMPARES TWO VALUES IN THE SENSE OF THE IDENT ! 19503: # DIFFER FUNCTIONS AVAILABLE AT THE SNOBOL LEVEL. ! 19504: # ! 19505: # (XR) FIRST ARGUMENT ! 19506: # (XL) SECOND ARGUMENT ! 19507: # JSR IDENT CALL TO COMPARE ARGUMENTS ! 19508: # PPM LOC TRANSFER LOC IF IDENT ! 19509: # (NORMAL RETURN IF DIFFER) ! 19510: # (XR,XL,WC,RA) DESTROYED ! 19511: # ! 19512: ident: #prc # entry point ! 19513: cmpl r9,r10 # jump if same pointer (ident) ! 19514: bnequ 0f ! 19515: jmp iden7 ! 19516: 0: ! 19517: movl (r9),r8 # else load arg 1 type word ! 19518: cmpl r8,(r10) # differ if arg 2 type word differ ! 19519: bnequ iden1 ! 19520: cmpl r8,$b$scl # jump if strings ! 19521: beqlu iden2 ! 19522: cmpl r8,$b$icl # jump if integers ! 19523: beqlu iden4 ! 19524: cmpl r8,$b$rcl # jump if reals ! 19525: beqlu iden5 ! 19526: cmpl r8,$b$nml # jump if names ! 19527: beqlu iden6 ! 19528: # ! 19529: # FOR ALL OTHER DATATYPES, MUST BE DIFFER IF XR NE XL ! 19530: # ! 19531: # MERGE HERE FOR DIFFER ! 19532: # ! 19533: iden1: addl2 $4*1,(sp) # take differ exit ! 19534: rsb ! 19535: # ! 19536: # HERE FOR STRINGS, IDENT ONLY IF LENGTHS AND CHARS SAME ! 19537: # ! 19538: iden2: movl 4*sclen(r9),r8 # load arg 1 length ! 19539: cmpl r8,4*sclen(r10) # differ if lengths differ ! 19540: bnequ iden1 ! 19541: movab 3+(4*0)(r8),r8 # get number of words in strings ! 19542: ashl $-2,r8,r8 ! 19543: addl2 $4*schar,r9 # point to chars of arg 1 ! 19544: addl2 $4*schar,r10 # point to chars of arg 2 ! 19545: # set loop counter ! 19546: # ! 19547: # LOOP TO COMPARE CHARACTERS. NOTE THAT WA CANNOT BE ZERO ! 19548: # SINCE ALL NULL STRINGS POINT TO NULLS AND GIVE XL=XR. ! 19549: # ! 19550: iden3: cmpl (r9),(r10) # differ if chars do not match ! 19551: bnequ iden8 ! 19552: addl2 $4,r9 # else bump arg one pointer ! 19553: addl2 $4,r10 # bump arg two pointer ! 19554: sobgtr r8,iden3 # loop back till all checked ! 19555: #page ! 19556: # ! 19557: # IDENT (CONTINUED) ! 19558: # ! 19559: # HERE TO EXIT FOR CASE OF TWO IDENT STRINGS ! 19560: # ! 19561: clrl r10 # clear garbage value in xl ! 19562: clrl r9 # clear garbage value in xr ! 19563: movl (sp)+,r11 # take ident exit ! 19564: jmp *(r11)+ ! 19565: # ! 19566: # HERE FOR INTEGERS, IDENT IF SAME VALUES ! 19567: # ! 19568: iden4: movl 4*icval(r9),r5 # load arg 1 ! 19569: subl2 4*icval(r10),r5 # subtract arg 2 to compare ! 19570: bvs iden1 ! 19571: tstl r5 # differ if result is not zero ! 19572: bneq iden1 ! 19573: movl (sp)+,r11 # take ident exit ! 19574: jmp *(r11)+ ! 19575: # ! 19576: # HERE FOR REALS, IDENT IF SAME VALUES ! 19577: # ! 19578: iden5: movf 4*rcval(r9),r2 # load arg 1 ! 19579: subf2 4*rcval(r10),r2 # subtract arg 2 to compare ! 19580: bvs iden1 ! 19581: tstf r2 # differ if result is not zero ! 19582: bneq iden1 ! 19583: movl (sp)+,r11 # take ident exit ! 19584: jmp *(r11)+ ! 19585: # ! 19586: # HERE FOR NAMES, IDENT IF BASES AND OFFSETS SAME ! 19587: # ! 19588: iden6: cmpl 4*nmofs(r9),4*nmofs(r10) # differ if different offset ! 19589: bnequ iden1 ! 19590: cmpl 4*nmbas(r9),4*nmbas(r10) # differ if different base ! 19591: bnequ iden1 ! 19592: # ! 19593: # MERGE HERE TO SIGNAL IDENT FOR IDENTICAL POINTERS ! 19594: # ! 19595: iden7: movl (sp)+,r11 # take ident exit ! 19596: jmp *(r11)+ ! 19597: # ! 19598: # HERE FOR DIFFER STRINGS ! 19599: # ! 19600: iden8: clrl r9 # clear garbage ptr in xr ! 19601: clrl r10 # clear garbage ptr in xl ! 19602: addl2 $4*1,(sp) # return to caller (differ) ! 19603: rsb ! 19604: #enp # end procedure ident ! 19605: #page ! 19606: # ! 19607: # INOUT - USED TO INITIALISE INPUT AND OUTPUT VARIABLES ! 19608: # ! 19609: # (XL) POINTER TO VBL NAME STRING ! 19610: # (WB) TRBLK TYPE ! 19611: # JSR INOUT CALL TO PERFORM INITIALISATION ! 19612: # (XL) VRBLK PTR ! 19613: # (XR) TRBLK PTR ! 19614: # (WA,WC) DESTROYED ! 19615: # ! 19616: # NOTE THAT TRTER (= TRTRF) FIELD OF STANDARD I/O VARIABLES ! 19617: # POINTS TO CORRESPONDING SVBLK NOT TO A TRBLK AS IS THE ! 19618: # CASE FOR ORDINARY VARIABLES. ! 19619: # ! 19620: inout: #prc # entry point ! 19621: movl r7,-(sp) # stack trblk type ! 19622: movl 4*sclen(r10),r6 # get name length ! 19623: clrl r7 # point to start of name ! 19624: jsb sbstr # build a proper scblk ! 19625: jsb gtnvr # build vrblk ! 19626: .long invalid$ # no error return ! 19627: movl r9,r8 # save vrblk pointer ! 19628: movl (sp)+,r7 # get trter field ! 19629: clrl r10 # zero trfpt ! 19630: jsb trbld # build trblk ! 19631: movl r8,r10 # recall vrblk pointer ! 19632: movl 4*vrsvp(r10),4*trter(r9) # store svblk pointer ! 19633: movl r9,4*vrval(r10) # store trblk ptr in vrblk ! 19634: movl $b$vra,4*vrget(r10) # set trapped access ! 19635: movl $b$vrv,4*vrsto(r10) # set trapped store ! 19636: rsb # return to caller ! 19637: #enp # end procedure inout ! 19638: #page ! 19639: # ! 19640: # INSBF -- INSERT STRING IN BUFFER ! 19641: # ! 19642: # THIS ROUTINE WILL REPLACE A SECTION OF A BUFFER WITH THE ! 19643: # CONTENTS OF A GIVEN STRING. IF THE LENGTH OF THE ! 19644: # SECTION TO BE REPLACED IS DIFFERENT THAN THE LENGTH OF ! 19645: # THE GIVEN STRING, AND THE REPLACEMENT IS NOT AN APPEND, ! 19646: # THEN THE UPPER SECTION OF THE BUFFER IS SHIFTED UP OR ! 19647: # DOWN TO CREATE THE PROPER SPACE FOR THE INSERT. ! 19648: # ! 19649: # (XR) POINTER TO BFBLK ! 19650: # (XL) OBJECT WHICH IS STRING CONVERTABLE ! 19651: # (WA) OFFSET OF START OF INSERT IN (XR) ! 19652: # (WB) LENGTH OF SECTION IN (XR) REPLACED ! 19653: # JSR INSBF CALL TO INSERT CHARACTERS IN BUFFER ! 19654: # PPM LOC THREAD IF (XR) NOT CONVERTABLE ! 19655: # PPM LOC THREAD IF INSERT NOT POSSIBLE ! 19656: # ! 19657: # THE SECOND ALTERNATE EXIT IS TAKEN IF THE INSERT WOULD ! 19658: # OVERFLOW THE BUFFER, OR IF THE INSERT IS OUT PAST THE ! 19659: # DEFINED END OF THE BUFFER AS GIVEN. ! 19660: # ! 19661: insbf: #prc # entry point ! 19662: movl r6,inssa # save entry wa ! 19663: movl r7,inssb # save entry wb ! 19664: movl r8,inssc # save entry wc ! 19665: addl2 r7,r6 # add to get offset past replace part ! 19666: movl r6,insab # save wa+wb ! 19667: movl 4*bclen(r9),r8 # get current defined length ! 19668: cmpl inssa,r8 # fail if start offset too big ! 19669: blequ 0f ! 19670: jmp ins07 ! 19671: 0: ! 19672: cmpl r6,r8 # fail if final offset too big ! 19673: blequ 0f ! 19674: jmp ins07 ! 19675: 0: ! 19676: movl r10,-(sp) # save entry xl ! 19677: movl r9,-(sp) # save bcblk ptr ! 19678: movl r10,-(sp) # stack again for gtstg ! 19679: jsb gtstg # call to convert to string ! 19680: .long ins05 # take string convert err exit ! 19681: movl r9,r10 # save string ptr ! 19682: movl (sp),r9 # restore bcblk ptr ! 19683: addl2 r8,r6 # add buffer len to string len ! 19684: subl2 inssb,r6 # bias out component being replaced ! 19685: movl 4*bcbuf(r9),r9 # point to bfblk ! 19686: cmpl r6,4*bfalc(r9) # fail if result exceeds allocation ! 19687: blequ 0f ! 19688: jmp ins06 ! 19689: 0: ! 19690: movl (sp),r9 # restore bcblk ptr ! 19691: movl r8,r6 # get buffer length ! 19692: subl2 insab,r6 # subtract to get shift length ! 19693: addl2 4*sclen(r10),r8 # add length of new ! 19694: subl2 inssb,r8 # subtract old to get total new len ! 19695: movl 4*bclen(r9),r7 # get old bclen ! 19696: movl r8,4*bclen(r9) # stuff new length ! 19697: tstl r6 # skip shift if nothing to do ! 19698: bnequ 0f ! 19699: jmp ins04 ! 19700: 0: ! 19701: cmpl inssb,4*sclen(r10) # skip shift if lengths match ! 19702: bnequ 0f ! 19703: jmp ins04 ! 19704: 0: ! 19705: movl 4*bcbuf(r9),r9 # point to bfblk ! 19706: movl r10,-(sp) # save scblk ptr ! 19707: cmpl inssb,4*sclen(r10) # brn if shft is for more room ! 19708: blequ ins01 ! 19709: #page ! 19710: # ! 19711: # INSBF (CONTINUED) ! 19712: # ! 19713: # WE ARE SHIFTING THE UPPER SEGMENT DOWN TO COMPACT ! 19714: # THE BUFFER. (THE STRING LENGTH IS SMALLER THAN THE ! 19715: # SEGMENT BEING REPLACED.) REGISTERS ARE SET AS: ! 19716: # ! 19717: # (WA) MOVE (SHIFT DOWN) LENGTH ! 19718: # (WB) OLD BCLEN ! 19719: # (WC) NEW BCLEN ! 19720: # (XR) BFBLK PTR ! 19721: # (XL),(XS) SCBLK PTR ! 19722: # ! 19723: movl inssa,r7 # get offset to insert ! 19724: addl2 4*sclen(r10),r7 # add insert length to get dest off ! 19725: movl r9,r10 # make copy ! 19726: movl insab,r11 # [get in scratch register] ! 19727: movab cfp$f(r10)[r11],r10 # prepare source for move ! 19728: movab cfp$f(r9)[r7],r9# prepare destination reg for move ! 19729: jsb sbmvc # move em out ! 19730: jmp ins02 # branch to pad ! 19731: # ! 19732: # WE ARE SHIFTING THE UPPER SEGMENT UP TO EXPAND ! 19733: # THE BUFFER. (THE STRING LENGTH IS LARGER THAN THE ! 19734: # SEGMENT BEING REPLACED.) ! 19735: # ! 19736: ins01: movl r9,r10 # copy bfblk ptr ! 19737: movab cfp$f(r10)[r7],r10 # set source reg for move backwards ! 19738: movab cfp$f(r9)[r8],r9# set destination ptr for move ! 19739: jsb sbmcb # move backwards (possible overlap) ! 19740: # ! 19741: # MERGE HERE AFTER MOVE TO ADJUST PADDING AT NEW BUFFER END ! 19742: # ! 19743: ins02: movl (sp)+,r10 # restore scblk ptr ! 19744: movl r8,r6 # copy new buffer end ! 19745: movab 3+(4*0)(r6),r6 # round out ! 19746: bicl2 $3,r6 ! 19747: subl2 r8,r6 # subtract to get remainder ! 19748: tstl r6 # no pad if already even boundary ! 19749: bnequ 0f ! 19750: jmp ins04 ! 19751: 0: ! 19752: movl (sp),r9 # get bcblk ptr ! 19753: movl 4*bcbuf(r9),r9 # get bfblk ptr ! 19754: movab cfp$f(r9)[r8],r9# prepare to pad ! 19755: clrl r7 # clear wb ! 19756: # load loop count ! 19757: # ! 19758: # LOOP HERE TO STUFF PAD CHARACTERS ! 19759: # ! 19760: ins03: movb r7,(r9)+ # stuff zero pad ! 19761: sobgtr r6,ins03 # branch for more ! 19762: #page ! 19763: # ! 19764: # INSBF (CONTINUED) ! 19765: # ! 19766: # MERGE HERE WHEN PADDING OK. NOW COPY IN THE INSERT ! 19767: # STRING TO THE HOLE. ! 19768: # ! 19769: ins04: movl (sp),r9 # get bcblk ptr ! 19770: movl 4*bcbuf(r9),r9 # get bfblk ptr ! 19771: movl 4*sclen(r10),r6 # get move length ! 19772: movab cfp$f(r10),r10 # prepare to copy from first char ! 19773: movl inssa,r11 # [get in scratch register] ! 19774: movab cfp$f(r9)[r11],r9# prepare to store in hole ! 19775: jsb sbmvc # copy the characters ! 19776: movl (sp)+,r9 # restore entry xr ! 19777: movl (sp)+,r10 # restore entry xl ! 19778: movl inssa,r6 # restore entry wa ! 19779: movl inssb,r7 # restore entry wb ! 19780: movl inssc,r8 # restore entry wc ! 19781: addl2 $4*2,(sp) # return to caller ! 19782: rsb ! 19783: # ! 19784: # HERE TO TAKE STRING CONVERT ERROR EXIT ! 19785: # ! 19786: ins05: movl (sp)+,r9 # restore entry xr ! 19787: movl (sp)+,r10 # restore entry xl ! 19788: movl inssa,r6 # restore entry wa ! 19789: movl inssb,r7 # restore entry wb ! 19790: movl inssc,r8 # restore entry wc ! 19791: movl (sp)+,r11 # alternate exit ! 19792: jmp *(r11)+ ! 19793: # ! 19794: # HERE FOR INVALID OFFSET OR LENGTH ! 19795: # ! 19796: ins06: movl (sp)+,r9 # restore entry xr ! 19797: movl (sp)+,r10 # restore entry xl ! 19798: # ! 19799: # MERGE FOR LENGTH FAILURE EXIT WITH STACK SET ! 19800: # ! 19801: ins07: movl inssa,r6 # restore entry wa ! 19802: movl inssb,r7 # restore entry wb ! 19803: movl inssc,r8 # restore entry wc ! 19804: addl3 $4*1,(sp)+,r11 # alternate exit ! 19805: jmp *(r11)+ ! 19806: #enp # end procedure insbf ! 19807: #page ! 19808: # ! 19809: # IOFCB -- GET INPUT/OUTPUT FCBLK POINTER ! 19810: # ! 19811: # USED BY ENDFILE, EJECT AND REWIND TO FIND THE FCBLK ! 19812: # (IF ANY) CORRESPONDING TO THEIR ARGUMENT. ! 19813: # ! 19814: # -(XS) ARGUMENT ! 19815: # JSR IOFCB CALL TO FIND FCBLK ! 19816: # PPM LOC ARG IS AN UNSUITABLE NAME ! 19817: # PPM LOC ARG IS NULL STRING ! 19818: # (XS) POPPED ! 19819: # (XL) PTR TO FILEARG1 VRBLK ! 19820: # (XR) ARGUMENT ! 19821: # (WA) FCBLK PTR OR 0 ! 19822: # (WB) DESTROYED ! 19823: # ! 19824: .data 1 ! 19825: iofcb_s: .long 0 ! 19826: .text 0 ! 19827: iofcb: movl (sp)+,iofcb_s # entry point ! 19828: jsb gtstg # get arg as string ! 19829: .long iofc2 # fail ! 19830: movl r9,r10 # copy string ptr ! 19831: jsb gtnvr # get as natural variable ! 19832: .long iofc3 # fail if null ! 19833: movl r10,r7 # copy string pointer again ! 19834: movl r9,r10 # copy vrblk ptr for return ! 19835: clrl r6 # in case no trblk found ! 19836: # ! 19837: # LOOP TO FIND FILE ARG1 TRBLK ! 19838: # ! 19839: iofc1: movl 4*vrval(r9),r9 # get possible trblk ptr ! 19840: cmpl (r9),$b$trt # fail if end of chain ! 19841: bnequ iofc2 ! 19842: cmpl 4*trtyp(r9),$trtfc # loop if not file arg trblk ! 19843: bnequ iofc1 ! 19844: movl 4*trfpt(r9),r6 # get fcblk ptr ! 19845: movl r7,r9 # copy arg ! 19846: addl3 $4*2,iofcb_s,r11 # return ! 19847: jmp (r11) ! 19848: # ! 19849: # FAIL RETURN ! 19850: # ! 19851: iofc2: movl iofcb_s,r11 # fail ! 19852: jmp *(r11)+ ! 19853: # ! 19854: # NULL ARG ! 19855: # ! 19856: iofc3: addl3 $4*1,iofcb_s,r11 # null arg return ! 19857: jmp *(r11)+ ! 19858: #enp # end procedure iofcb ! 19859: #page ! 19860: # ! 19861: # IOPPF -- PROCESS FILEARG2 FOR IOPUT ! 19862: # ! 19863: # (R$XSC) FILEARG2 PTR ! 19864: # JSR IOPPF CALL TO PROCESS FILEARG2 ! 19865: # (XL) FILEARG1 PTR ! 19866: # (XR) FILE ARG2 PTR ! 19867: # -(XS)..-(XS) FIELDS EXTRACTED FROM FILEARG2 ! 19868: # (WC) NO. OF FIELDS EXTRACTED ! 19869: # (WB) INPUT/OUTPUT FLAG ! 19870: # (WA) FCBLK PTR OR 0 ! 19871: # ! 19872: .data 1 ! 19873: ioppf_s: .long 0 ! 19874: .text 0 ! 19875: ioppf: movl (sp)+,ioppf_s # entry point ! 19876: clrl r7 # to count fields extracted ! 19877: # ! 19878: # LOOP TO EXTRACT FIELDS ! 19879: # ! 19880: iopp1: movl $iodel,r10 # get delimiter ! 19881: movl r10,r8 # copy it ! 19882: jsb xscan # get next field ! 19883: movl r9,-(sp) # stack it ! 19884: incl r7 # increment count ! 19885: tstl r6 # loop ! 19886: bnequ iopp1 ! 19887: movl r7,r8 # count of fields ! 19888: movl ioptt,r7 # i/o marker ! 19889: movl r$iof,r6 # fcblk ptr or 0 ! 19890: movl r$io2,r9 # file arg2 ptr ! 19891: movl r$io1,r10 # filearg1 ! 19892: jmp *ioppf_s # return ! 19893: #enp # end procedure ioppf ! 19894: #page ! 19895: # ! 19896: # IOPUT -- ROUTINE USED BY INPUT AND OUTPUT ! 19897: # ! 19898: # IOPUT SETS UP INPUT/OUTPUT ASSOCIATIONS. IT BUILDS ! 19899: # SUCH TRACE AND FILE CONTROL BLOCKS AS ARE NECESSARY AND ! 19900: # CALLS SYSFC,SYSIO TO PERFORM CHECKS ON THE ! 19901: # ARGUMENTS AND TO OPEN THE FILES. ! 19902: # ! 19903: # +-----------+ +---------------+ +-----------+ ! 19904: # +-.I I I I------.I =B$XRT I ! 19905: # I +-----------+ +---------------+ +-----------+ ! 19906: # I / / (R$FCB) I *4 I ! 19907: # I / / +-----------+ ! 19908: # I +-----------+ +---------------+ I I- ! 19909: # I I NAME +--.I =B$TRT I +-----------+ ! 19910: # I / / +---------------+ I I ! 19911: # I (FIRST ARG) I =TRTIN/=TRTOU I +-----------+ ! 19912: # I +---------------+ I ! 19913: # I I VALUE I I ! 19914: # I +---------------+ I ! 19915: # I I(TRTRF) 0 OR I--+ I ! 19916: # I +---------------+ I I ! 19917: # I I(TRFPT) 0 OR I----+ I ! 19918: # I +---------------+ I I I ! 19919: # I (I/O TRBLK) I I I ! 19920: # I +-----------+ I I I ! 19921: # I I I I I I ! 19922: # I +-----------+ I I I ! 19923: # I I I I I I ! 19924: # I +-----------+ +---------------+ I I I ! 19925: # I I +--.I =B$TRT I.-+ I I ! 19926: # I +-----------+ +---------------+ I I ! 19927: # I / / I =TRTFC I I I ! 19928: # I / / +---------------+ I I ! 19929: # I (FILEARG1 I VALUE I I I ! 19930: # I VRBLK) +---------------+ I I ! 19931: # I I(TRTRF) 0 OR I--+ I . ! 19932: # I +---------------+ I . +-----------+ ! 19933: # I I(TRFPT) 0 OR I------./ FCBLK / ! 19934: # I +---------------+ I +-----------+ ! 19935: # I (TRTRF) I ! 19936: # I I ! 19937: # I I ! 19938: # I +---------------+ I ! 19939: # I I =B$XRT I.-+ ! 19940: # I +---------------+ ! 19941: # I I *5 I ! 19942: # I +---------------+ ! 19943: # +------------------I I ! 19944: # +---------------+ +-----------+ ! 19945: # I(TRTRF) O OR I------.I =B$XRT I ! 19946: # +---------------+ +-----------+ ! 19947: # I NAME OFFSET I I ETC I ! 19948: # +---------------+ ! 19949: # (IOCHN - CHAIN OF NAME POINTERS) ! 19950: #page ! 19951: # ! 19952: # IOPUT (CONTINUED) ! 19953: # ! 19954: # NO ADDITIONAL TRAP BLOCKS ARE USED FOR STANDARD INPUT/OUT ! 19955: # FILES. OTHERWISE AN I/O TRAP BLOCK IS ATTACHED TO SECOND ! 19956: # ARG (FILEARG1) VRBLK. SEE DIAGRAM ABOVE FOR DETAILS OF ! 19957: # THE STRUCTURE BUILT. ! 19958: # ! 19959: # -(XS) 1ST ARG (VBL TO BE ASSOCIATED) ! 19960: # -(XS) 2ND ARG (FILE ARG1) ! 19961: # -(XS) 3RD ARG (FILE ARG2) ! 19962: # (WB) 0 FOR INPUT, 3 FOR OUTPUT ASSOC. ! 19963: # JSR IOPUT CALL FOR INPUT/OUTPUT ASSOCIATION ! 19964: # PPM LOC 3RD ARG NOT A STRING ! 19965: # PPM LOC 2ND ARG NOT A SUITABLE NAME ! 19966: # PPM LOC 1ST ARG NOT A SUITABLE NAME ! 19967: # PPM LOC INAPPROPRIATE FILE SPEC FOR I/O ! 19968: # PPM LOC I/O FILE DOES NOT EXIST ! 19969: # PPM LOC I/O FILE CANNOT BE READ/WRITTEN ! 19970: # (XS) POPPED ! 19971: # (XL,XR,WA,WB,WC) DESTROYED ! 19972: # ! 19973: .data 1 ! 19974: ioput_s: .long 0 ! 19975: .text 0 ! 19976: ioput: movl (sp)+,ioput_s # entry point ! 19977: clrl r$iot # in case no trtrf block used ! 19978: clrl r$iof # in case no fcblk alocated ! 19979: movl r7,ioptt # store i/o trace type ! 19980: jsb xscni # prepare to scan filearg2 ! 19981: .long iop13 # fail ! 19982: .long iopa0 # null file arg2 ! 19983: # ! 19984: iopa0: movl r9,r$io2 # keep file arg2 ! 19985: movl r6,r10 # copy length ! 19986: jsb gtstg # convert filearg1 to string ! 19987: .long iop14 # fail ! 19988: movl r9,r$io1 # keep filearg1 ptr ! 19989: jsb gtnvr # convert to natural variable ! 19990: .long iop00 # jump if null ! 19991: jmp iop04 # jump to process non-null args ! 19992: # ! 19993: # NULL FILEARG1 ! 19994: # ! 19995: iop00: tstl r10 # skip if both args null ! 19996: bnequ 0f ! 19997: jmp iop01 ! 19998: 0: ! 19999: jsb ioppf # process filearg2 ! 20000: jsb sysfc # call for filearg2 check ! 20001: .long iop16 # fail ! 20002: jmp iop11 # complete file association ! 20003: #page ! 20004: # ! 20005: # IOPUT (CONTINUED) ! 20006: # ! 20007: # HERE WITH 0 OR FCBLK PTR IN (XL) ! 20008: # ! 20009: iop01: movl ioptt,r7 # get trace type ! 20010: movl r$iot,r9 # get 0 or trtrf ptr ! 20011: jsb trbld # build trblk ! 20012: movl r9,r8 # copy trblk pointer ! 20013: movl (sp)+,r9 # get variable from stack ! 20014: jsb gtvar # point to variable ! 20015: .long iop15 # fail ! 20016: movl r10,r$ion # save name pointer ! 20017: movl r10,r9 # copy name pointer ! 20018: addl2 r6,r9 # point to variable ! 20019: subl2 $4*vrval,r9 # subtract offset,merge into loop ! 20020: # ! 20021: # LOOP TO END OF TRBLK CHAIN IF ANY ! 20022: # ! 20023: iop02: movl r9,r10 # copy blk ptr ! 20024: movl 4*vrval(r9),r9 # load ptr to next trblk ! 20025: cmpl (r9),$b$trt # jump if not trapped ! 20026: bnequ iop03 ! 20027: cmpl 4*trtyp(r9),ioptt# loop if not same assocn ! 20028: bnequ iop02 ! 20029: movl 4*trnxt(r9),r9 # get value and delete old trblk ! 20030: # ! 20031: # IOPUT (CONTINUED) ! 20032: # ! 20033: # STORE NEW ASSOCIATION ! 20034: # ! 20035: iop03: movl r8,4*vrval(r10) # link to this trblk ! 20036: movl r8,r10 # copy pointer ! 20037: movl r9,4*trnxt(r10) # store value in trblk ! 20038: movl r$ion,r9 # restore possible vrblk pointer ! 20039: movl r6,r7 # keep offset to name ! 20040: jsb setvr # if vrblk, set vrget,vrsto ! 20041: movl r$iot,r9 # get 0 or trtrf ptr ! 20042: tstl r9 # jump if trtrf block exists ! 20043: beqlu 0f ! 20044: jmp iop19 ! 20045: 0: ! 20046: addl3 $4*6,ioput_s,r11 # return to caller ! 20047: jmp (r11) ! 20048: # ! 20049: # NON STANDARD FILE ! 20050: # SEE IF AN FCBLK HAS ALREADY BEEN ALLOCATED. ! 20051: # ! 20052: iop04: clrl r6 # in case no fcblk found ! 20053: #page ! 20054: # ! 20055: # IOPUT (CONTINUED) ! 20056: # ! 20057: # SEARCH POSSIBLE TRBLK CHAIN TO PICK UP THE FCBLK ! 20058: # ! 20059: iop05: movl r9,r7 # remember blk ptr ! 20060: movl 4*vrval(r9),r9 # chain along ! 20061: cmpl (r9),$b$trt # jump if end of trblk chain ! 20062: bnequ iop06 ! 20063: cmpl 4*trtyp(r9),$trtfc # loop if more to go ! 20064: bnequ iop05 ! 20065: movl r9,r$iot # point to file arg1 trblk ! 20066: movl 4*trfpt(r9),r6 # get fcblk ptr from trblk ! 20067: # ! 20068: # WA = 0 OR FCBLK PTR ! 20069: # WB = PTR TO PRECEDING BLK TO WHICH ANY TRTRF BLOCK ! 20070: # FOR FILE ARG1 MUST BE CHAINED. ! 20071: # ! 20072: iop06: movl r6,r$iof # keep possible fcblk ptr ! 20073: movl r7,r$iop # keep preceding blk ptr ! 20074: jsb ioppf # process filearg2 ! 20075: jsb sysfc # see if fcblk required ! 20076: .long iop16 # fail ! 20077: tstl r6 # skip if no new fcblk wanted ! 20078: bnequ 0f ! 20079: jmp iop12 ! 20080: 0: ! 20081: cmpl r8,$num02 # jump if fcblk in dynamic ! 20082: blssu iop6a ! 20083: jsb alost # get it in static ! 20084: jmp iop6b # skip ! 20085: # ! 20086: # OBTAIN FCBLK IN DYNAMIC ! 20087: # ! 20088: iop6a: jsb alloc # get space for fcblk ! 20089: # ! 20090: # MERGE ! 20091: # ! 20092: iop6b: movl r9,r10 # point to fcblk ! 20093: movl r6,r7 # copy its length ! 20094: ashl $-2,r7,r7 # get count as words (sgd apr80) ! 20095: # loop counter ! 20096: # ! 20097: # CLEAR FCBLK ! 20098: # ! 20099: iop07: clrl (r9)+ # clear a word ! 20100: sobgtr r7,iop07 # loop ! 20101: cmpl r8,$num02 # skip if in static - dont set fields ! 20102: bnequ 0f ! 20103: jmp iop09 ! 20104: 0: ! 20105: movl $b$xnt,(r10) # store xnblk code in case ! 20106: movl r6,4*1(r10) # store length ! 20107: tstl r8 # jump if xnblk wanted ! 20108: beqlu 0f ! 20109: jmp iop09 ! 20110: 0: ! 20111: movl $b$xrt,(r10) # xrblk code requested ! 20112: # ! 20113: #page ! 20114: # IOPUT (CONTINUED) ! 20115: # ! 20116: # COMPLETE FCBLK INITIALISATION ! 20117: # ! 20118: iop09: movl r$iot,r9 # get possible trblk ptr ! 20119: movl r10,r$iof # store fcblk ptr ! 20120: tstl r9 # jump if trblk already found ! 20121: bnequ iop10 ! 20122: # ! 20123: # A NEW TRBLK IS NEEDED ! 20124: # ! 20125: movl $trtfc,r7 # trtyp for fcblk trap blk ! 20126: jsb trbld # make the block ! 20127: movl r9,r$iot # copy trtrf ptr ! 20128: movl r$iop,r10 # point to preceding blk ! 20129: movl 4*vrval(r10),4*vrval(r9) # copy value field to trblk ! 20130: movl r9,4*vrval(r10) # link new trblk into chain ! 20131: movl r10,r9 # point to predecessor blk ! 20132: jsb setvr # set trace intercepts ! 20133: movl 4*vrval(r9),r9 # recover trblk ptr ! 20134: # ! 20135: # XR IS PTR TO TRBLK, XL IS FCBLK PTR OR 0 ! 20136: # ! 20137: iop10: movl r$iof,4*trfpt(r9)# store fcblk ptr ! 20138: # ! 20139: # CALL SYSIO TO COMPLETE FILE ACCESSING ! 20140: # ! 20141: iop11: movl r$iof,r6 # copy fcblk ptr or 0 ! 20142: movl ioptt,r7 # get input/output flag ! 20143: movl r$io2,r9 # get file arg2 ! 20144: movl r$io1,r10 # get file arg1 ! 20145: jsb sysio # associate to the file ! 20146: .long iop17 # fail ! 20147: .long iop18 # fail ! 20148: tstl r$iot # not std input if non-null trtrf blk ! 20149: beqlu 0f ! 20150: jmp iop01 ! 20151: 0: ! 20152: tstl ioptt # jump if output ! 20153: beqlu 0f ! 20154: jmp iop01 ! 20155: 0: ! 20156: tstl r8 # no change to standard read length ! 20157: bnequ 0f ! 20158: jmp iop01 ! 20159: 0: ! 20160: movl r8,cswin # store new read length for std file ! 20161: jmp iop01 # merge to finish the task ! 20162: # ! 20163: # SYSFC MAY HAVE RETURNED A POINTER TO A PRIVATE FCBLK ! 20164: # ! 20165: iop12: tstl r10 # jump if private fcblk ! 20166: beqlu 0f ! 20167: jmp iop09 ! 20168: 0: ! 20169: jmp iop11 # finish the association ! 20170: # ! 20171: # FAILURE RETURNS ! 20172: # ! 20173: iop13: movl ioput_s,r11 # 3rd arg not a string ! 20174: jmp *(r11)+ ! 20175: iop14: addl3 $4*1,ioput_s,r11 # 2nd arg unsuitable ! 20176: jmp *(r11)+ ! 20177: iop15: addl3 $4*2,ioput_s,r11 # 1st arg unsuitable ! 20178: jmp *(r11)+ ! 20179: iop16: addl3 $4*3,ioput_s,r11 # file spec wrong ! 20180: jmp *(r11)+ ! 20181: iop17: addl3 $4*4,ioput_s,r11 # i/o file does not exist ! 20182: jmp *(r11)+ ! 20183: iop18: addl3 $4*5,ioput_s,r11 # i/o file cannot be read/written ! 20184: jmp *(r11)+ ! 20185: #page ! 20186: # ! 20187: # IOPUT (CONTINUED) ! 20188: # ! 20189: # ADD TO IOCHN CHAIN OF ASSSOCIATED VARIABLES UNLESS ALREAD ! 20190: # PRESENT. ! 20191: # ! 20192: iop19: movl r$ion,r8 # wc = name base, wb = name offset ! 20193: # ! 20194: # SEARCH LOOP ! 20195: # ! 20196: iop20: movl 4*trtrf(r9),r9 # next link of chain ! 20197: tstl r9 # not found ! 20198: beqlu iop21 ! 20199: cmpl r8,4*ionmb(r9) # no match ! 20200: bnequ iop20 ! 20201: cmpl r7,4*ionmo(r9) # exit if matched ! 20202: beqlu iop22 ! 20203: jmp iop20 # loop ! 20204: # ! 20205: # NOT FOUND ! 20206: # ! 20207: iop21: movl $4*num05,r6 # space needed ! 20208: jsb alloc # get it ! 20209: movl $b$xrt,(r9) # store xrblk code ! 20210: movl r6,4*1(r9) # store length ! 20211: movl r8,4*ionmb(r9) # store name base ! 20212: movl r7,4*ionmo(r9) # store name offset ! 20213: movl r$iot,r10 # point to trtrf blk ! 20214: movl 4*trtrf(r10),r6 # get ptr field contents ! 20215: movl r9,4*trtrf(r10) # store ptr to new block ! 20216: movl r6,4*trtrf(r9) # complete the linking ! 20217: # ! 20218: # INSERT FCBLK ON FCBLK CHAIN FOR SYSEJ, SYSXI ! 20219: # ! 20220: iop22: tstl r$iof # skip if no fcblk ! 20221: beqlu iop25 ! 20222: movl r$fcb,r10 # ptr to head of existing chain ! 20223: # ! 20224: # SEE IF FCBLK ALREADY ON CHAIN ! 20225: # ! 20226: iop23: tstl r10 # not on if end of chain ! 20227: beqlu iop24 ! 20228: cmpl 4*3(r10),r$iof # dont duplicate if find it ! 20229: beqlu iop25 ! 20230: movl 4*2(r10),r10 # get next link ! 20231: jmp iop23 # loop ! 20232: # ! 20233: # NOT FOUND SO ADD AN ENTRY FOR THIS FCBLK ! 20234: # ! 20235: iop24: movl $4*num04,r6 # space needed ! 20236: jsb alloc # get it ! 20237: movl $b$xrt,(r9) # store block code ! 20238: movl r6,4*1(r9) # store length ! 20239: movl r$fcb,4*2(r9) # store previous link in this node ! 20240: movl r$iof,4*3(r9) # store fcblk ptr ! 20241: movl r9,r$fcb # insert node into fcblk chain ! 20242: # ! 20243: # RETURN ! 20244: # ! 20245: iop25: addl3 $4*6,ioput_s,r11 # return to caller ! 20246: jmp (r11) ! 20247: #enp # end procedure ioput ! 20248: #page ! 20249: # ! 20250: # KTREX -- EXECUTE KEYWORD TRACE ! 20251: # ! 20252: # KTREX IS USED TO EXECUTE A POSSIBLE KEYWORD TRACE. IT ! 20253: # INCLUDES THE TEST ON TRACE AND TESTS FOR TRACE ACTIVE. ! 20254: # ! 20255: # (XL) PTR TO TRBLK (OR 0 IF UNTRACED) ! 20256: # JSR KTREX CALL TO EXECUTE KEYWORD TRACE ! 20257: # (XL,WA,WB,WC) DESTROYED ! 20258: # (RA) DESTROYED ! 20259: # ! 20260: ktrex: #prc # entry point (recursive) ! 20261: tstl r10 # immediate exit if keyword untraced ! 20262: beqlu ktrx3 ! 20263: tstl kvtra # immediate exit if trace = 0 ! 20264: beqlu ktrx3 ! 20265: decl kvtra # else decrement trace ! 20266: movl r9,-(sp) # save xr ! 20267: movl r10,r9 # copy trblk pointer ! 20268: movl 4*trkvr(r9),r10 # load vrblk pointer (nmbas) ! 20269: movl $4*vrval,r6 # set name offset ! 20270: tstl 4*trfnc(r9) # jump if print trace ! 20271: beqlu ktrx1 ! 20272: jsb trxeq # else execute full trace ! 20273: jmp ktrx2 # and jump to exit ! 20274: # ! 20275: # HERE FOR PRINT TRACE ! 20276: # ! 20277: ktrx1: movl r10,-(sp) # stack vrblk ptr for kwnam ! 20278: movl r6,-(sp) # stack offset for kwnam ! 20279: jsb prtsn # print statement number ! 20280: movl $ch$am,r6 # load ampersand ! 20281: jsb prtch # print ampersand ! 20282: jsb prtnm # print keyword name ! 20283: movl $tmbeb,r9 # point to blank-equal-blank ! 20284: jsb prtst # print blank-equal-blank ! 20285: jsb kwnam # get keyword pseudo-variable name ! 20286: movl r9,dnamp # reset ptr to delete kvblk ! 20287: jsb acess # get keyword value ! 20288: .long invalid$ # failure is impossible ! 20289: jsb prtvl # print keyword value ! 20290: jsb prtnl # terminate print line ! 20291: # ! 20292: # HERE TO EXIT AFTER COMPLETING TRACE ! 20293: # ! 20294: ktrx2: movl (sp)+,r9 # restore entry xr ! 20295: # ! 20296: # MERGE HERE TO EXIT IF NO TRACE REQUIRED ! 20297: # ! 20298: ktrx3: rsb # return to ktrex caller ! 20299: #enp # end procedure ktrex ! 20300: #page ! 20301: # ! 20302: # KWNAM -- GET PSEUDO-VARIABLE NAME FOR KEYWORD ! 20303: # ! 20304: # 1(XS) NAME BASE FOR VRBLK ! 20305: # 0(XS) OFFSET (SHOULD BE *VRVAL) ! 20306: # JSR KWNAM CALL TO GET PSEUDO-VARIABLE NAME ! 20307: # (XS) POPPED TWICE ! 20308: # (XL,WA) RESULTING PSEUDO-VARIABLE NAME ! 20309: # (XR,WA,WB) DESTROYED ! 20310: # ! 20311: .data 1 ! 20312: kwnam_s: .long 0 ! 20313: .text 0 ! 20314: kwnam: movl (sp)+,kwnam_s # entry point ! 20315: addl2 $4,sp # ignore name offset ! 20316: movl (sp)+,r9 # load name base ! 20317: cmpl r9,state # jump if not natural variable name ! 20318: bgequ kwnm1 ! 20319: tstl 4*vrlen(r9) # error if not system variable ! 20320: bnequ kwnm1 ! 20321: movl 4*vrsvp(r9),r9 # else point to svblk ! 20322: movl 4*svbit(r9),r6 # load bit mask ! 20323: mcoml btknm,r11 # and with keyword bit ! 20324: bicl2 r11,r6 ! 20325: tstl r6 # error if no keyword association ! 20326: beqlu kwnm1 ! 20327: movl 4*svlen(r9),r6 # else load name length in characters ! 20328: movab 3+(4*svchs)(r6),r6 # compute offset to field we want ! 20329: bicl2 $3,r6 ! 20330: addl2 r6,r9 # point to svknm field ! 20331: movl (r9),r7 # load svknm value ! 20332: movl $4*kvsi$,r6 # set size of kvblk ! 20333: jsb alloc # allocate kvblk ! 20334: movl $b$kvt,(r9) # store type word ! 20335: movl r7,4*kvnum(r9) # store keyword number ! 20336: movl $trbkv,4*kvvar(r9) # set dummy trblk pointer ! 20337: movl r9,r10 # copy kvblk pointer ! 20338: movl $4*kvvar,r6 # set proper offset ! 20339: jmp *kwnam_s # return to kvnam caller ! 20340: # ! 20341: # HERE IF NOT KEYWORD NAME ! 20342: # ! 20343: kwnm1: jmp er_251 # keyword operand is not name of defined keyword ! 20344: #enp # end procedure kwnam ! 20345: #page ! 20346: # ! 20347: # LCOMP-- COMPARE TWO STRINGS LEXICALLY ! 20348: # ! 20349: # 1(XS) FIRST ARGUMENT ! 20350: # 0(XS) SECOND ARGUMENT ! 20351: # JSR LCOMP CALL TO COMPARE ARUMENTS ! 20352: # PPM LOC TRANSFER LOC FOR ARG1 NOT STRING ! 20353: # PPM LOC TRANSFER LOC FOR ARG2 NOT STRING ! 20354: # PPM LOC TRANSFER LOC IF ARG1 LLT ARG2 ! 20355: # PPM LOC TRANSFER LOC IF ARG1 LEQ ARG2 ! 20356: # PPM LOC TRANSFER LOC IF ARG1 LGT ARG2 ! 20357: # (THE NORMAL RETURN IS NEVER TAKEN) ! 20358: # (XS) POPPED TWICE ! 20359: # (XR,XL) DESTROYED ! 20360: # (WA,WB,WC,RA) DESTROYED ! 20361: # ! 20362: .data 1 ! 20363: lcomp_s: .long 0 ! 20364: .text 0 ! 20365: lcomp: movl (sp)+,lcomp_s # entry point ! 20366: jsb gtstg # convert second arg to string ! 20367: .long lcmp6 # jump if second arg not string ! 20368: movl r9,r10 # else save pointer ! 20369: movl r6,r7 # and length ! 20370: jsb gtstg # convert first argument to string ! 20371: .long lcmp5 # jump if not string ! 20372: movl r6,r8 # save arg 1 length ! 20373: movab cfp$f(r9),r9 # point to chars of arg 1 ! 20374: movab cfp$f(r10),r10 # point to chars of arg 2 ! 20375: cmpl r6,r7 # jump if arg 1 length is smaller ! 20376: blequ lcmp1 ! 20377: movl r7,r6 # else set arg 2 length as smaller ! 20378: # ! 20379: # HERE WITH SMALLER LENGTH IN (WA) ! 20380: # ! 20381: lcmp1: jsb sbcmc # compare strings, jump if unequal ! 20382: .long lcmp4 ! 20383: .long lcmp3 ! 20384: cmpl r7,r8 # if equal, jump if lengths unequal ! 20385: bnequ lcmp2 ! 20386: addl3 $4*3,lcomp_s,r11 # else identical strings, leq exit ! 20387: jmp *(r11)+ ! 20388: #page ! 20389: # ! 20390: # LCOMP (CONTINUED) ! 20391: # ! 20392: # HERE IF INITIAL STRINGS IDENTICAL, BUT LENGTHS UNEQUAL ! 20393: # ! 20394: lcmp2: cmpl r8,r7 # jump if arg 1 length gt arg 2 leng ! 20395: bgequ lcmp4 ! 20396: # ! 20397: # HERE IF FIRST ARG LLT SECOND ARG ! 20398: # ! 20399: lcmp3: addl3 $4*2,lcomp_s,r11 # take llt exit ! 20400: jmp *(r11)+ ! 20401: # ! 20402: # HERE IF FIRST ARG LGT SECOND ARG ! 20403: # ! 20404: lcmp4: addl3 $4*4,lcomp_s,r11 # take lgt exit ! 20405: jmp *(r11)+ ! 20406: # ! 20407: # HERE IF FIRST ARG IS NOT A STRING ! 20408: # ! 20409: lcmp5: movl lcomp_s,r11 # take bad first arg exit ! 20410: jmp *(r11)+ ! 20411: # ! 20412: # HERE FOR SECOND ARG NOT A STRING ! 20413: # ! 20414: lcmp6: addl3 $4*1,lcomp_s,r11 # take bad second arg error exit ! 20415: jmp *(r11)+ ! 20416: #enp # end procedure lcomp ! 20417: #page ! 20418: # ! 20419: # LISTR -- LIST SOURCE LINE ! 20420: # ! 20421: # LISTR IS USED TO LIST A SOURCE LINE DURING THE INITIAL ! 20422: # COMPILATION. IT IS CALLED FROM SCANE AND SCANL. ! 20423: # ! 20424: # JSR LISTR CALL TO LIST LINE ! 20425: # (XR,XL,WA,WB,WC) DESTROYED ! 20426: # ! 20427: # GLOBAL LOCATIONS USED BY LISTR ! 20428: # ! 20429: # ERLST IF LISTING ON ACCOUNT OF AN ERROR ! 20430: # ! 20431: # LSTLC COUNT LINES ON CURRENT PAGE ! 20432: # ! 20433: # LSTNP MAX NUMBER OF LINES/PAGE ! 20434: # ! 20435: # LSTPF SET NON-ZERO IF THE CURRENT SOURCE ! 20436: # LINE HAS BEEN LISTED, ELSE ZERO. ! 20437: # ! 20438: # LSTPG COMPILER LISTING PAGE NUMBER ! 20439: # ! 20440: # LSTSN SET IF STMNT NUM TO BE LISTED ! 20441: # ! 20442: # R$CIM POINTER TO CURRENT INPUT LINE. ! 20443: # ! 20444: # R$TTL TITLE FOR SOURCE LISTING ! 20445: # ! 20446: # R$STL PTR TO SUB-TITLE STRING ! 20447: # ! 20448: # ENTRY POINT ! 20449: # ! 20450: listr: #prc # entry point ! 20451: tstl cnttl # jump if -title or -stitl ! 20452: beqlu 0f ! 20453: jmp list5 ! 20454: 0: ! 20455: tstl lstpf # immediate exit if already listed ! 20456: beqlu 0f ! 20457: jmp list4 ! 20458: 0: ! 20459: cmpl lstlc,lstnp # jump if no room ! 20460: blssu 0f ! 20461: jmp list6 ! 20462: 0: ! 20463: # ! 20464: # HERE AFTER PRINTING TITLE (IF NEEDED) ! 20465: # ! 20466: list0: movl r$cim,r9 # load pointer to current image ! 20467: movab cfp$f(r9),r9 # point to characters ! 20468: movzbl (r9),r6 # load first character ! 20469: movl lstsn,r9 # load statement number ! 20470: tstl r9 # jump if no statement number ! 20471: beqlu list2 ! 20472: movl r9,r5 # else get stmnt number as integer ! 20473: cmpl stage,$stgic # skip if execute time ! 20474: bnequ list1 ! 20475: cmpl r6,$ch$as # no stmnt number list if comment ! 20476: beqlu list2 ! 20477: cmpl r6,$ch$mn # no stmnt no. if control card ! 20478: beqlu list2 ! 20479: # ! 20480: # PRINT STATEMENT NUMBER ! 20481: # ! 20482: list1: jsb prtin # else print statement number ! 20483: clrl lstsn # and clear for next time in ! 20484: #page ! 20485: # ! 20486: # LISTR (CONTINUED) ! 20487: # ! 20488: # MERGE HERE AFTER PRINTING STATEMENT NUMBER (IF REQUIRED) ! 20489: # ! 20490: list2: movl $stnpd,profs # point past statement number ! 20491: movl r$cim,r9 # load pointer to current image ! 20492: jsb prtst # print it ! 20493: incl lstlc # bump line counter ! 20494: tstl erlst # jump if error copy to int.ch. ! 20495: bnequ list3 ! 20496: jsb prtnl # terminate line ! 20497: tstl cswdb # jump if -single mode ! 20498: beqlu list3 ! 20499: jsb prtnl # else add a blank line ! 20500: incl lstlc # and bump line counter ! 20501: # ! 20502: # HERE AFTER PRINTING SOURCE IMAGE ! 20503: # ! 20504: list3: movl sp,lstpf # set flag for line printed ! 20505: # ! 20506: # MERGE HERE TO EXIT ! 20507: # ! 20508: list4: rsb # return to listr caller ! 20509: # ! 20510: # PRINT TITLE AFTER -TITLE OR -STITL CARD ! 20511: # ! 20512: list5: clrl cnttl # clear flag ! 20513: # ! 20514: # EJECT TO NEW PAGE AND LIST TITLE ! 20515: # ! 20516: list6: jsb prtps # eject ! 20517: tstl prich # skip if listing to regular printer ! 20518: beqlu list7 ! 20519: cmpl r$ttl,$nulls # terminal listing omits null title ! 20520: bnequ 0f ! 20521: jmp list0 ! 20522: 0: ! 20523: # ! 20524: # LIST TITLE ! 20525: # ! 20526: list7: jsb listt # list title ! 20527: jmp list0 # merge ! 20528: #enp # end procedure listr ! 20529: #page ! 20530: # ! 20531: # LISTT -- LIST TITLE AND SUBTITLE ! 20532: # ! 20533: # USED DURING COMPILATION TO PRINT PAGE HEADING ! 20534: # ! 20535: # JSR LISTT CALL TO LIST TITLE ! 20536: # (XR,WA) DESTROYED ! 20537: # ! 20538: listt: #prc # entry point ! 20539: movl r$ttl,r9 # point to source listing title ! 20540: jsb prtst # print title ! 20541: movl lstpo,profs # set offset ! 20542: movl $lstms,r9 # set page message ! 20543: jsb prtst # print page message ! 20544: incl lstpg # bump page number ! 20545: movl lstpg,r5 # load page number as integer ! 20546: jsb prtin # print page number ! 20547: jsb prtnl # terminate title line ! 20548: addl2 $num02,lstlc # count title line and blank line ! 20549: # ! 20550: # PRINT SUB-TITLE (IF ANY) ! 20551: # ! 20552: movl r$stl,r9 # load pointer to sub-title ! 20553: tstl r9 # jump if no sub-title ! 20554: beqlu lstt1 ! 20555: jsb prtst # else print sub-title ! 20556: jsb prtnl # terminate line ! 20557: incl lstlc # bump line count ! 20558: # ! 20559: # RETURN POINT ! 20560: # ! 20561: lstt1: jsb prtnl # print a blank line ! 20562: rsb # return to caller ! 20563: #enp # end procedure listt ! 20564: #page ! 20565: # ! 20566: # NEXTS -- ACQUIRE NEXT SOURCE IMAGE ! 20567: # ! 20568: # NEXTS IS USED TO ACQUIRE THE NEXT SOURCE IMAGE AT COMPILE ! 20569: # TIME. IT ASSUMES THAT A PRIOR CALL TO READR HAS INPUT ! 20570: # A LINE IMAGE (SEE PROCEDURE READR). BEFORE THE CURRENT ! 20571: # IMAGE IS FINALLY LOST IT MAY BE LISTED HERE. ! 20572: # ! 20573: # JSR NEXTS CALL TO ACQUIRE NEXT INPUT LINE ! 20574: # (XR,XL,WA,WB,WC) DESTROYED ! 20575: # ! 20576: # GLOBAL VALUES AFFECTED ! 20577: # ! 20578: # R$CNI ON INPUT, NEXT IMAGE. ON ! 20579: # EXIT RESET TO ZERO ! 20580: # ! 20581: # R$CIM ON EXIT, SET TO POINT TO IMAGE ! 20582: # ! 20583: # SCNIL INPUT IMAGE LENGTH ON EXIT ! 20584: # ! 20585: # SCNSE RESET TO ZERO ON EXIT ! 20586: # ! 20587: # LSTPF SET ON EXIT IF LINE IS LISTED ! 20588: # ! 20589: nexts: #prc # entry point ! 20590: tstl cswls # jump if -nolist ! 20591: beqlu nxts2 ! 20592: movl r$cim,r9 # point to image ! 20593: tstl r9 # jump if no image ! 20594: beqlu nxts2 ! 20595: movab cfp$f(r9),r9 # get char ptr ! 20596: movzbl (r9),r6 # get first char ! 20597: cmpl r6,$ch$mn # jump if not ctrl card ! 20598: bnequ nxts1 ! 20599: tstl cswpr # jump if -noprint ! 20600: beqlu nxts2 ! 20601: # ! 20602: # HERE TO CALL LISTER ! 20603: # ! 20604: nxts1: jsb listr # list line ! 20605: # ! 20606: # HERE AFTER POSSIBLE LISTING ! 20607: # ! 20608: nxts2: movl r$cni,r9 # point to next image ! 20609: movl r9,r$cim # set as next image ! 20610: clrl r$cni # clear next image pointer ! 20611: movl 4*sclen(r9),r6 # get input image length ! 20612: movl cswin,r7 # get max allowable length ! 20613: cmpl r6,r7 # skip if not too long ! 20614: blequ nxts3 ! 20615: movl r7,r6 # else truncate ! 20616: # ! 20617: # HERE WITH LENGTH IN (WA) ! 20618: # ! 20619: nxts3: movl r6,scnil # use as record length ! 20620: clrl scnse # reset scnse ! 20621: clrl lstpf # set line not listed yet ! 20622: rsb # return to nexts caller ! 20623: #enp # end procedure nexts ! 20624: #page ! 20625: # ! 20626: # PATIN -- PATTERN CONSTRUCTION FOR LEN,POS,RPOS,TAB,RTAB ! 20627: # ! 20628: # THESE PATTERN TYPES ALL GENERATE A SIMILAR NODE TYPE. SO ! 20629: # THE CONSTRUCTION CODE IS SHARED. SEE FUNCTIONS SECTION ! 20630: # FOR ACTUAL ENTRY POINTS FOR THESE FIVE FUNCTIONS. ! 20631: # ! 20632: # (WA) PCODE FOR EXPRESSION ARG CASE ! 20633: # (WB) PCODE FOR INTEGER ARG CASE ! 20634: # JSR PATIN CALL TO BUILD PATTERN NODE ! 20635: # PPM LOC TRANSFER LOC FOR NOT INTEGER OR EXP ! 20636: # PPM LOC TRANSFER LOC FOR INT OUT OF RANGE ! 20637: # (XR) POINTER TO CONSTRUCTED NODE ! 20638: # (XL,WA,WB,WC,IA) DESTROYED ! 20639: # ! 20640: .data 1 ! 20641: patin_s: .long 0 ! 20642: .text 0 ! 20643: patin: movl (sp)+,patin_s # entry point ! 20644: movl r6,r10 # preserve expression arg pcode ! 20645: jsb gtsmi # try to convert arg as small integer ! 20646: .long ptin2 # jump if not integer ! 20647: .long ptin3 # jump if out of range ! 20648: # ! 20649: # COMMON SUCCESSFUL EXIT POINT ! 20650: # ! 20651: ptin1: jsb pbild # build pattern node ! 20652: addl3 $4*2,patin_s,r11 # return to caller ! 20653: jmp (r11) ! 20654: # ! 20655: # HERE IF ARGUMENT IS NOT AN INTEGER ! 20656: # ! 20657: ptin2: movl r10,r7 # copy expr arg case pcode ! 20658: cmpl (r9),$b$e$$ # all ok if expression arg ! 20659: blequ ptin1 ! 20660: movl patin_s,r11 # else take error exit for wrong type ! 20661: jmp *(r11)+ ! 20662: # ! 20663: # HERE FOR ERROR OF OUT OF RANGE INTEGER ARGUMENT ! 20664: # ! 20665: ptin3: addl3 $4*1,patin_s,r11 # take out-of-range error exit ! 20666: jmp *(r11)+ ! 20667: #enp # end procedure patin ! 20668: #page ! 20669: # ! 20670: # PATST -- PATTERN CONSTRUCTION FOR ANY,NOTANY, ! 20671: # BREAK,SPAN AND BREAKX PATTERN FUNCTIONS. ! 20672: # ! 20673: # THESE PATTERN FUNCTIONS BUILD SIMILAR TYPES OF NODES AND ! 20674: # THE CONSTRUCTION CODE IS SHARED. SEE FUNCTIONS SECTION ! 20675: # FOR ACTUAL ENTRY POINTS FOR THESE FIVE PATTERN FUNCTIONS. ! 20676: # ! 20677: # 0(XS) STRING ARGUMENT ! 20678: # (WB) PCODE FOR ONE CHAR ARGUMENT ! 20679: # (XL) PCODE FOR MULTI-CHAR ARGUMENT ! 20680: # (WC) PCODE FOR EXPRESSION ARGUMENT ! 20681: # JSR PATST CALL TO BUILD NODE ! 20682: # PPM LOC TRANSFER LOC IF NOT STRING OR EXPR ! 20683: # (XS) POPPED PAST STRING ARGUMENT ! 20684: # (XR) POINTER TO CONSTRUCTED NODE ! 20685: # (XL) DESTROYED ! 20686: # (WA,WB,WC,RA) DESTROYED ! 20687: # ! 20688: # NOTE THAT THERE IS A SPECIAL CALL TO PATST IN THE EVALS ! 20689: # PROCEDURE WITH A SLIGHTLY DIFFERENT FORM. SEE EVALS ! 20690: # FOR DETAILS OF THE FORM OF THIS CALL. ! 20691: # ! 20692: .data 1 ! 20693: patst_s: .long 0 ! 20694: .text 0 ! 20695: patst: movl (sp)+,patst_s # entry point ! 20696: jsb gtstg # convert argument as string ! 20697: .long pats7 # jump if not string ! 20698: cmpl r6,$num01 # jump if not one char string ! 20699: bnequ pats2 ! 20700: # ! 20701: # HERE FOR ONE CHAR STRING CASE ! 20702: # ! 20703: tstl r7 # treat as multi-char if evals call ! 20704: beqlu pats2 ! 20705: movab cfp$f(r9),r9 # point to character ! 20706: movzbl (r9),r9 # load character ! 20707: # ! 20708: # COMMON EXIT POINT AFTER SUCCESSFUL CONSTRUCTION ! 20709: # ! 20710: pats1: jsb pbild # call routine to build node ! 20711: addl3 $4*1,patst_s,r11 # return to patst caller ! 20712: jmp (r11) ! 20713: #page ! 20714: # ! 20715: # PATST (CONTINUED) ! 20716: # ! 20717: # HERE FOR MULTI-CHARACTER STRING CASE ! 20718: # ! 20719: pats2: movl r10,-(sp) # save multi-char pcode ! 20720: movl r9,-(sp) # save string pointer ! 20721: movl ctmsk,r8 # load current mask bit ! 20722: ashl $1,r8,r8 # shift to next position ! 20723: tstl r8 # skip if position left in this tbl ! 20724: bnequ pats4 ! 20725: # ! 20726: # HERE WE MUST ALLOCATE A NEW CHARACTER TABLE ! 20727: # ! 20728: movl $4*ctsi$,r6 # set size of ctblk ! 20729: jsb alloc # allocate ctblk ! 20730: movl r9,r$ctp # store ptr to new ctblk ! 20731: movl $b$ctt,(r9)+ # store type code, bump ptr ! 20732: movl $cfp$a,r7 # set number of words to clear ! 20733: movl bits0,r8 # load all zero bits ! 20734: # ! 20735: # LOOP TO CLEAR ALL BITS IN TABLE TO ZEROS ! 20736: # ! 20737: pats3: movl r8,(r9)+ # move word of zero bits ! 20738: sobgtr r7,pats3 # loop till all cleared ! 20739: movl bits1,r8 # set initial bit position ! 20740: # ! 20741: # MERGE HERE WITH BIT POSITION AVAILABLE ! 20742: # ! 20743: pats4: movl r8,ctmsk # save parm2 (new bit position) ! 20744: movl (sp)+,r10 # restore pointer to argument string ! 20745: movl 4*sclen(r10),r7 # load string length ! 20746: tstl r7 # jump if null string case ! 20747: beqlu pats6 ! 20748: # else set loop counter ! 20749: movab cfp$f(r10),r10 # point to characters in argument ! 20750: #page ! 20751: # ! 20752: # PATST (CONTINUED) ! 20753: # ! 20754: # LOOP TO SET BITS IN COLUMN OF TABLE ! 20755: # ! 20756: pats5: movzbl (r10)+,r6 # load next character ! 20757: moval 0[r6],r6 # convert to byte offset ! 20758: movl r$ctp,r9 # point to ctblk ! 20759: addl2 r6,r9 # point to ctblk entry ! 20760: movl r8,r6 # copy bit mask ! 20761: bisl2 4*ctchs(r9),r6 # or in bits already set ! 20762: movl r6,4*ctchs(r9) # store resulting bit string ! 20763: sobgtr r7,pats5 # loop till all bits set ! 20764: # ! 20765: # COMPLETE PROCESSING FOR MUTI-CHAR STRING CASE ! 20766: # ! 20767: pats6: movl r$ctp,r9 # load ctblk ptr as parm1 for pbild ! 20768: clrl r10 # clear garbage ptr in xl ! 20769: movl (sp)+,r7 # load pcode for multi-char str case ! 20770: jmp pats1 # back to exit (wc=bitstring=parm2) ! 20771: # ! 20772: # HERE IF ARGUMENT IS NOT A STRING ! 20773: # ! 20774: # NOTE THAT THE CALL FROM EVALS CANNOT PASS AN EXPRESSION ! 20775: # SINCE EVALP ALWAYS REEVALUATES EXPRESSIONS. ! 20776: # ! 20777: pats7: movl r8,r7 # set pcode for expression argument ! 20778: cmpl (r9),$b$e$$ # jump to exit if expression arg ! 20779: bgtru 0f ! 20780: jmp pats1 ! 20781: 0: ! 20782: movl patst_s,r11 # else take wrong type error exit ! 20783: jmp *(r11)+ ! 20784: #enp # end procedure patst ! 20785: #page ! 20786: # ! 20787: # PBILD -- BUILD PATTERN NODE ! 20788: # ! 20789: # (XR) PARM1 (ONLY IF REQUIRED) ! 20790: # (WB) PCODE FOR NODE ! 20791: # (WC) PARM2 (ONLY IF REQUIRED) ! 20792: # JSR PBILD CALL TO BUILD NODE ! 20793: # (XR) POINTER TO CONSTRUCTED NODE ! 20794: # (WA) DESTROYED ! 20795: # ! 20796: pbild: #prc # entry point ! 20797: movl r9,-(sp) # stack possible parm1 ! 20798: movl r7,r9 # copy pcode ! 20799: movzwl -2(r9),r9 # load entry point id (bl$px) ! 20800: cmpl r9,$bl$p1 # jump if one parameter ! 20801: beqlu pbld1 ! 20802: cmpl r9,$bl$p0 # jump if no parameters ! 20803: beqlu pbld3 ! 20804: # ! 20805: # HERE FOR TWO PARAMETER CASE ! 20806: # ! 20807: movl $4*pcsi$,r6 # set size of p2blk ! 20808: jsb alloc # allocate block ! 20809: movl r8,4*parm2(r9) # store second parameter ! 20810: jmp pbld2 # merge with one parm case ! 20811: # ! 20812: # HERE FOR ONE PARAMETER CASE ! 20813: # ! 20814: pbld1: movl $4*pbsi$,r6 # set size of p1blk ! 20815: jsb alloc # allocate node ! 20816: # ! 20817: # MERGE HERE FROM TWO PARM CASE ! 20818: # ! 20819: pbld2: movl (sp),4*parm1(r9)# store first parameter ! 20820: jmp pbld4 # merge with no parameter case ! 20821: # ! 20822: # HERE FOR CASE OF NO PARAMETERS ! 20823: # ! 20824: pbld3: movl $4*pasi$,r6 # set size of p0blk ! 20825: jsb alloc # allocate node ! 20826: # ! 20827: # MERGE HERE FROM OTHER CASES ! 20828: # ! 20829: pbld4: movl r7,(r9) # store pcode ! 20830: addl2 $4,sp # pop first parameter ! 20831: movl $ndnth,4*pthen(r9) # set nothen successor pointer ! 20832: rsb # return to pbild caller ! 20833: #enp # end procedure pbild ! 20834: #page ! 20835: # ! 20836: # PCONC -- CONCATENATE TWO PATTERNS ! 20837: # ! 20838: # (XL) PTR TO RIGHT PATTERN ! 20839: # (XR) PTR TO LEFT PATTERN ! 20840: # JSR PCONC CALL TO CONCATENATE PATTERNS ! 20841: # (XR) PTR TO CONCATENATED PATTERN ! 20842: # (XL,WA,WB,WC) DESTROYED ! 20843: # ! 20844: # ! 20845: # TO CONCATENATE TWO PATTERNS, ALL SUCCESSORS IN THE LEFT ! 20846: # PATTERN WHICH POINT TO THE NOTHEN NODE MUST BE CHANGED TO ! 20847: # POINT TO THE RIGHT PATTERN. HOWEVER, THIS MODIFICATION ! 20848: # MUST BE PERFORMED ON A COPY OF THE LEFT ARGUMENT RATHER ! 20849: # THAN THE LEFT ARGUMENT ITSELF, SINCE THE LEFT ARGUMENT ! 20850: # MAY BE POINTED TO BY SOME OTHER VARIABLE VALUE. ! 20851: # ! 20852: # ACCORDINGLY, IT IS NECESSARY TO COPY THE LEFT ARGUMENT. ! 20853: # THIS IS NOT A TRIVIAL PROCESS SINCE WE MUST AVOID COPYING ! 20854: # NODES MORE THAN ONCE AND THE PATTERN IS A GRAPH STRUCTURE ! 20855: # THE FOLLOWING ALGORITHM IS EMPLOYED. ! 20856: # ! 20857: # THE STACK IS USED TO STORE A LIST OF NODES WHICH ! 20858: # HAVE ALREADY BEEN COPIED. THE FORMAT OF THE ENTRIES ON ! 20859: # THIS LIST CONSISTS OF A TWO WORD BLOCK. THE FIRST WORD ! 20860: # IS THE OLD ADDRESS AND THE SECOND WORD IS THE ADDRESS ! 20861: # OF THE COPY. THIS LIST IS SEARCHED BY THE PCOPY ! 20862: # ROUTINE TO AVOID MAKING DUPLICATE COPIES. A TRICK IS ! 20863: # USED TO ACCOMPLISH THE CONCATENATION AT THE SAME TIME. ! 20864: # A SPECIAL ENTRY IS MADE TO START WITH ON THE STACK. THIS ! 20865: # ENTRY RECORDS THAT THE NOTHEN NODE HAS BEEN COPIED ! 20866: # ALREADY AND THE ADDRESS OF ITS COPY IS THE RIGHT PATTERN. ! 20867: # THIS AUTOMATICALLY PERFORMS THE CORRECT REPLACEMENTS. ! 20868: # ! 20869: pconc: #prc # entry point ! 20870: clrl -(sp) # make room for one entry at bottom ! 20871: movl sp,r8 # store pointer to start of list ! 20872: movl $ndnth,-(sp) # stack nothen node as old node ! 20873: movl r10,-(sp) # store right arg as copy of nothen ! 20874: movl sp,r10 # initialize pointer to stack entries ! 20875: jsb pcopy # copy first node of left arg ! 20876: movl r6,4*2(r10) # store as result under list ! 20877: #page ! 20878: # ! 20879: # PCONC (CONTINUED) ! 20880: # ! 20881: # THE FOLLOWING LOOP SCANS ENTRIES IN THE LIST AND MAKES ! 20882: # SURE THAT THEIR SUCCESSORS HAVE BEEN COPIED. ! 20883: # ! 20884: pcnc1: cmpl r10,sp # jump if all entries processed ! 20885: beqlu pcnc2 ! 20886: movl -(r10),r9 # else load next old address ! 20887: movl 4*pthen(r9),r9 # load pointer to successor ! 20888: jsb pcopy # copy successor node ! 20889: movl -(r10),r9 # load pointer to new node (copy) ! 20890: movl r6,4*pthen(r9) # store ptr to new successor ! 20891: # ! 20892: # NOW CHECK FOR SPECIAL CASE OF ALTERNATION NODE WHERE ! 20893: # PARM1 POINTS TO A NODE AND MUST BE COPIED LIKE PTHEN. ! 20894: # ! 20895: cmpl (r9),$p$alt # loop back if not ! 20896: bnequ pcnc1 ! 20897: movl 4*parm1(r9),r9 # else load pointer to alternative ! 20898: jsb pcopy # copy it ! 20899: movl (r10),r9 # restore ptr to new node ! 20900: movl r6,4*parm1(r9) # store ptr to copied alternative ! 20901: jmp pcnc1 # loop back for next entry ! 20902: # ! 20903: # HERE AT END OF COPY PROCESS ! 20904: # ! 20905: pcnc2: movl r8,sp # restore stack pointer ! 20906: movl (sp)+,r9 # load pointer to copy ! 20907: rsb # return to pconc caller ! 20908: #enp # end procedure pconc ! 20909: #page ! 20910: # ! 20911: # PCOPY -- COPY A PATTERN NODE ! 20912: # ! 20913: # PCOPY IS CALLED FROM THE PCONC PROCEDURE TO COPY A SINGLE ! 20914: # PATTERN NODE. THE COPY IS ONLY CARRIED OUT IF THE NODE ! 20915: # HAS NOT BEEN COPIED ALREADY. ! 20916: # ! 20917: # (XR) POINTER TO NODE TO BE COPIED ! 20918: # (XT) PTR TO CURRENT LOC IN COPY LIST ! 20919: # (WC) POINTER TO LIST OF COPIED NODES ! 20920: # JSR PCOPY CALL TO COPY A NODE ! 20921: # (WA) POINTER TO COPY ! 20922: # (WB,XR) DESTROYED ! 20923: # ! 20924: .data 1 ! 20925: pcopy_s: .long 0 ! 20926: .text 0 ! 20927: pcopy: movl (sp)+,pcopy_s # entry point ! 20928: movl r10,r7 # save xt ! 20929: movl r8,r10 # point to start of list ! 20930: # ! 20931: # LOOP TO SEARCH LIST OF NODES COPIED ALREADY ! 20932: # ! 20933: pcop1: subl2 $4,r10 # point to next entry on list ! 20934: cmpl r9,(r10) # jump if match ! 20935: beqlu pcop2 ! 20936: subl2 $4,r10 # else skip over copied address ! 20937: cmpl r10,sp # loop back if more to test ! 20938: bnequ pcop1 ! 20939: # ! 20940: # HERE IF NOT IN LIST, PERFORM COPY ! 20941: # ! 20942: movl (r9),r6 # load first word of block ! 20943: jsb blkln # get length of block ! 20944: movl r9,r10 # save pointer to old node ! 20945: jsb alloc # allocate space for copy ! 20946: movl r10,-(sp) # store old address on list ! 20947: movl r9,-(sp) # store new address on list ! 20948: jsb sbchk # check for stack overflow ! 20949: jsb sbmvw # move words from old block to copy ! 20950: movl (sp),r6 # load pointer to copy ! 20951: jmp pcop3 # jump to exit ! 20952: # ! 20953: # HERE IF WE FIND ENTRY IN LIST ! 20954: # ! 20955: pcop2: movl -(r10),r6 # load address of copy from list ! 20956: # ! 20957: # COMMON EXIT POINT ! 20958: # ! 20959: pcop3: movl r7,r10 # restore xt ! 20960: jmp *pcopy_s # return to pcopy caller ! 20961: #enp # end procedure pcopy ! 20962: #page ! 20963: # ! 20964: # PRFLR -- PRINT PROFILE ! 20965: # PRFLR IS CALLED TO PRINT THE CONTENTS OF THE PROFILE ! 20966: # TABLE IN A FAIRLY READABLE TABULAR FORMAT. ! 20967: # ! 20968: # JSR PRFLR CALL TO PRINT PROFILE ! 20969: # (WA,IA) DESTROYED ! 20970: # ! 20971: prflr: #prc ! 20972: tstl pfdmp # no printing if no profiling done ! 20973: bnequ 0f ! 20974: jmp prfl4 ! 20975: 0: ! 20976: movl r9,-(sp) # preserve entry xr ! 20977: movl r7,pfsvw # and also wb ! 20978: jsb prtpg # eject ! 20979: movl $pfms1,r9 # load msg /program profile/ ! 20980: jsb prtst # and print it ! 20981: jsb prtnl # followed by newline ! 20982: jsb prtnl # and another ! 20983: movl $pfms2,r9 # point to first hdr ! 20984: jsb prtst # print it ! 20985: jsb prtnl # new line ! 20986: movl $pfms3,r9 # second hdr ! 20987: jsb prtst # print it ! 20988: jsb prtnl # new line ! 20989: jsb prtnl # and another blank line ! 20990: clrl r7 # initial stmt count ! 20991: movl pftbl,r9 # point to table origin ! 20992: addl2 $4*num02,r9 # bias past xnblk header (sgd07) ! 20993: # ! 20994: # LOOP HERE TO PRINT SUCCESSIVE ENTRIES ! 20995: # ! 20996: prfl1: incl r7 # bump stmt nr ! 20997: movl (r9),r5 # load nr of executions ! 20998: tstl r5 # no printing if zero ! 20999: beql prfl3 ! 21000: movl $pfpd1,profs # point where to print ! 21001: jsb prtin # and print it ! 21002: clrl profs # back to start of line ! 21003: movl r7,r5 # load stmt nr ! 21004: jsb prtin # print it there ! 21005: movl $pfpd2,profs # and pad past count ! 21006: movl 4*cfp$i(r9),r5 # load total exec time ! 21007: jsb prtin # print that too ! 21008: movl 4*cfp$i(r9),r5 # reload time ! 21009: mull2 intth,r5 # convert to microsec ! 21010: bvs prfl2 ! 21011: divl2 (r9),r5 # divide by executions ! 21012: movl $pfpd3,profs # pad last print ! 21013: jsb prtin # and print mcsec/execn ! 21014: # ! 21015: # MERGE AFTER PRINTING TIME ! 21016: # ! 21017: prfl2: jsb prtnl # thats another line ! 21018: # ! 21019: # HERE TO GO TO NEXT ENTRY ! 21020: # ! 21021: prfl3: addl2 $4*pf$i2,r9 # bump index ptr (sgd07) ! 21022: cmpl r7,pfnte # loop if more stmts ! 21023: blssu prfl1 ! 21024: movl (sp)+,r9 # restore callers xr ! 21025: movl pfsvw,r7 # and wb too ! 21026: # ! 21027: # HERE TO EXIT ! 21028: # ! 21029: prfl4: rsb # return ! 21030: #enp # end of prflr ! 21031: #page ! 21032: # ! 21033: # PRFLU -- UPDATE AN ENTRY IN THE PROFILE TABLE ! 21034: # ! 21035: # ON ENTRY, KVSTN CONTAINS NR OF STMT TO PROFILE ! 21036: # ! 21037: # JSR PRFLU CALL TO UPDATE ENTRY ! 21038: # (IA) DESTROYED ! 21039: # ! 21040: prflu: #prc ! 21041: tstl pffnc # skip if just entered function ! 21042: beqlu 0f ! 21043: jmp pflu4 ! 21044: 0: ! 21045: movl r9,-(sp) # preserve entry xr ! 21046: movl r6,pfsvw # save wa (sgd07) ! 21047: tstl pftbl # branch if table allocated ! 21048: bnequ pflu2 ! 21049: # ! 21050: # HERE IF SPACE FOR PROFILE TABLE NOT YET ALLOCATED. ! 21051: # CALCULATE SIZE NEEDED, ALLOCATE A STATIC XNBLK, AND ! 21052: # INITIALIZE IT ALL TO ZERO. ! 21053: # THE TIME TAKEN FOR THIS WILL BE ATTRIBUTED TO THE CURRENT ! 21054: # STATEMENT (ASSIGNMENT TO KEYWD PROFILE), BUT SINCE THE ! 21055: # TIMING FOR THIS STATEMENT IS UP THE POLE ANYWAY, THIS ! 21056: # DOESNT REALLY MATTER... ! 21057: # ! 21058: subl2 $num01,pfnte # adjust for extra count (sgd07) ! 21059: movl pfi2a,r5 # convrt entry size to int ! 21060: movl r5,pfste # and store safely for later ! 21061: movl pfnte,r5 # load table length as integer ! 21062: mull2 pfste,r5 # multiply by entry size ! 21063: movl r5,r6 # get back address-style ! 21064: addl2 $num02,r6 # add on 2 word overhead ! 21065: moval 0[r6],r6 # convert the whole lot to bytes ! 21066: jsb alost # gimme the space ! 21067: movl r9,pftbl # save block pointer ! 21068: movl $b$xnt,(r9)+ # put block type and ... ! 21069: movl r6,(r9)+ # ... length into header ! 21070: movl r5,r6 # get back nr of wds in data area ! 21071: # load the counter ! 21072: # ! 21073: # LOOP HERE TO ZERO THE BLOCK DATA ! 21074: # ! 21075: pflu1: clrl (r9)+ # blank a word ! 21076: sobgtr r6,pflu1 # and alllllll the rest ! 21077: # ! 21078: # END OF ALLOCATION. MERGE BACK INTO ROUTINE ! 21079: # ! 21080: pflu2: movl kvstn,r5 # load nr of stmt just ended ! 21081: subl2 intv1,r5 # make into index offset ! 21082: mull2 pfste,r5 # make offset of table entry ! 21083: movl r5,r6 # convert to address ! 21084: moval 0[r6],r6 # get as baus ! 21085: addl2 $4*num02,r6 # offset includes table header ! 21086: movl pftbl,r9 # get table start ! 21087: cmpl r6,4*num01(r9) # if out of table, skip it ! 21088: bgequ pflu3 ! 21089: addl2 r6,r9 # else point to entry ! 21090: movl (r9),r5 # get nr of executions so far ! 21091: addl2 intv1,r5 # nudge up one ! 21092: movl r5,(r9) # and put back ! 21093: jsb systm # get time now ! 21094: movl r5,pfetm # stash ending time ! 21095: subl2 pfstm,r5 # subtract start time ! 21096: addl2 4*cfp$i(r9),r5 # add cumulative time so far ! 21097: movl r5,4*cfp$i(r9) # and put back new total ! 21098: movl pfetm,r5 # load end time of this stmt ... ! 21099: movl r5,pfstm # ... which is start time of next ! 21100: # ! 21101: # MERGE HERE TO EXIT ! 21102: # ! 21103: pflu3: movl (sp)+,r9 # restore callers xr ! 21104: movl pfsvw,r6 # restore saved reg ! 21105: rsb # and return ! 21106: # ! 21107: # HERE IF PROFILE IS SUPPRESSED BECAUSE A PROGRAM DEFINED ! 21108: # FUNCTION IS ABOUT TO BE ENTERED, AND SO THE CURRENT STMT ! 21109: # HAS NOT YET FINISHED ! 21110: # ! 21111: pflu4: clrl pffnc # reset the condition flag ! 21112: rsb # and immediate return ! 21113: #enp # end of procedure prflu ! 21114: #page ! 21115: # ! 21116: # PRPAR - PROCESS PRINT PARAMETERS ! 21117: # ! 21118: # (WC) IF NONZERO ASSOCIATE TERMINAL ONLY ! 21119: # JSR PRPAR CALL TO PROCESS PRINT PARAMETERS ! 21120: # (XL,XR,WA,WB,WC) DESTROYED ! 21121: # ! 21122: # SINCE MEMORY ALLOCATION IS UNDECIDED ON INITIAL CALL, ! 21123: # TERMINAL CANNOT BE ASSOCIATED. THE ENTRY WITH WC NON-ZERO ! 21124: # IS PROVIDED SO A LATER CALL CAN BE MADE TO COMPLETE THIS. ! 21125: # ! 21126: prpar: #prc # entry point ! 21127: tstl r8 # jump to associate terminal ! 21128: beqlu 0f ! 21129: jmp prpa7 ! 21130: 0: ! 21131: jsb syspp # get print parameters ! 21132: tstl r7 # jump if lines/page specified ! 21133: bnequ prpa1 ! 21134: movl $cfp$m,r7 # else use a large value ! 21135: ashl $-1,r7,r7 # but not too large ! 21136: # ! 21137: # STORE LINE COUNT/PAGE ! 21138: # ! 21139: prpa1: movl r7,lstnp # store number of lines/page ! 21140: movl r7,lstlc # pretend page is full initially ! 21141: clrl lstpg # clear page number ! 21142: movl prlen,r7 # get prior length if any ! 21143: tstl r7 # skip if no length ! 21144: beqlu prpa2 ! 21145: cmpl r6,r7 # skip storing if too big ! 21146: bgtru prpa3 ! 21147: # ! 21148: # STORE PRINT BUFFER LENGTH ! 21149: # ! 21150: prpa2: movl r6,prlen # store value ! 21151: # ! 21152: # PROCESS BITS OPTIONS ! 21153: # ! 21154: prpa3: movl bits3,r7 # bit 3 mask ! 21155: mcoml r8,r11 # get -nolist bit ! 21156: bicl2 r11,r7 ! 21157: tstl r7 # skip if clear ! 21158: beqlu prpa4 ! 21159: clrl cswls # set -nolist ! 21160: # ! 21161: # CHECK IF FAIL REPORTS GOTO INTERACTIVE CHANNEL ! 21162: # ! 21163: prpa4: movl bits1,r7 # bit 1 mask ! 21164: mcoml r8,r11 # get bit ! 21165: bicl2 r11,r7 ! 21166: movl r7,erich # store int. chan. error flag ! 21167: movl bits2,r7 # bit 2 mask ! 21168: mcoml r8,r11 # get bit ! 21169: bicl2 r11,r7 ! 21170: movl r7,prich # flag for std printer on int. chan. ! 21171: movl bits4,r7 # bit 4 mask ! 21172: mcoml r8,r11 # get bit ! 21173: bicl2 r11,r7 ! 21174: movl r7,cpsts # flag for compile stats suppressn. ! 21175: movl bits5,r7 # bit 5 mask ! 21176: mcoml r8,r11 # get bit ! 21177: bicl2 r11,r7 ! 21178: movl r7,exsts # flag for exec stats suppression ! 21179: #page ! 21180: # ! 21181: # PRPAR (CONTINUED) ! 21182: # ! 21183: movl bits6,r7 # bit 6 mask ! 21184: mcoml r8,r11 # get bit ! 21185: bicl2 r11,r7 ! 21186: movl r7,precl # extended/compact listing flag ! 21187: subl2 $num08,r6 # point 8 chars from line end ! 21188: tstl r7 # jump if not extended ! 21189: beqlu prpa5 ! 21190: movl r6,lstpo # store for listing page headings ! 21191: # ! 21192: # CONTINUE OPTION PROCESSING ! 21193: # ! 21194: prpa5: movl bits7,r7 # bit 7 mask ! 21195: mcoml r8,r11 # get bit 7 ! 21196: bicl2 r11,r7 ! 21197: movl r7,cswex # set -noexecute if non-zero ! 21198: movl bit10,r7 # bit 10 mask ! 21199: mcoml r8,r11 # get bit 10 ! 21200: bicl2 r11,r7 ! 21201: movl r7,headp # pretend printed to omit headers ! 21202: movl bits9,r7 # bit 9 mask ! 21203: mcoml r8,r11 # get bit 9 ! 21204: bicl2 r11,r7 ! 21205: movl r7,prsto # keep it as std listing option ! 21206: tstl r7 # skip if clear ! 21207: beqlu prpa6 ! 21208: movl prlen,r6 # get print buffer length ! 21209: subl2 $num08,r6 # point 8 chars from line end ! 21210: movl r6,lstpo # store page offset ! 21211: # ! 21212: # CHECK FOR TERMINAL ! 21213: # ! 21214: prpa6: mcoml bits8,r11 # see if terminal to be activated ! 21215: bicl2 r11,r8 ! 21216: tstl r8 # jump if terminal required ! 21217: beqlu 0f ! 21218: jmp prpa7 ! 21219: 0: ! 21220: tstl initr # jump if no terminal to detach ! 21221: beqlu prpa8 ! 21222: movl $v$ter,r10 # ptr to /terminal/ ! 21223: jsb gtnvr # get vrblk pointer ! 21224: .long invalid$ # cant fail ! 21225: movl $nulls,4*vrval(r9) # clear value of terminal ! 21226: jsb setvr # remove association ! 21227: jmp prpa8 # return ! 21228: # ! 21229: # ASSOCIATE TERMINAL ! 21230: # ! 21231: prpa7: movl sp,initr # note terminal associated ! 21232: tstl dnamb # cant if memory not organised ! 21233: beqlu prpa8 ! 21234: movl $v$ter,r10 # point to terminal string ! 21235: movl $trtou,r7 # output trace type ! 21236: jsb inout # attach output trblk to vrblk ! 21237: movl r9,-(sp) # stack trblk ptr ! 21238: movl $v$ter,r10 # point to terminal string ! 21239: movl $trtin,r7 # input trace type ! 21240: jsb inout # attach input trace blk ! 21241: movl (sp)+,4*vrval(r9)# add output trblk to chain ! 21242: # ! 21243: # RETURN POINT ! 21244: # ! 21245: prpa8: rsb # return ! 21246: #enp # end procedure prpar ! 21247: #page ! 21248: # ! 21249: # PRTCH -- PRINT A CHARACTER ! 21250: # ! 21251: # PRTCH IS USED TO PRINT A SINGLE CHARACTER ! 21252: # ! 21253: # (WA) CHARACTER TO BE PRINTED ! 21254: # JSR PRTCH CALL TO PRINT CHARACTER ! 21255: # ! 21256: prtch: #prc # entry point ! 21257: movl r9,-(sp) # save xr ! 21258: cmpl profs,prlen # jump if room in buffer ! 21259: bnequ prch1 ! 21260: jsb prtnl # else print this line ! 21261: # ! 21262: # HERE AFTER MAKING SURE WE HAVE ROOM ! 21263: # ! 21264: prch1: movl prbuf,r9 # point to print buffer ! 21265: movl profs,r11 # [get in scratch register] ! 21266: movab cfp$f(r9)[r11],r9# point to next character location ! 21267: movb r6,(r9) # store new character ! 21268: #csc r9 # complete store characters ! 21269: incl profs # bump pointer ! 21270: movl (sp)+,r9 # restore entry xr ! 21271: rsb # return to prtch caller ! 21272: #enp # end procedure prtch ! 21273: #page ! 21274: # ! 21275: # PRTIC -- PRINT TO INTERACTIVE CHANNEL ! 21276: # ! 21277: # PRTIC IS CALLED TO PRINT THE CONTENTS OF THE STANDARD ! 21278: # PRINT BUFFER TO THE INTERACTIVE CHANNEL. IT IS ONLY ! 21279: # CALLED AFTER PRTST HAS SET UP THE STRING FOR PRINTING. ! 21280: # IT DOES NOT CLEAR THE BUFFER. ! 21281: # ! 21282: # JSR PRTIC CALL FOR PRINT ! 21283: # (WA,WB) DESTROYED ! 21284: # ! 21285: prtic: #prc # entry point ! 21286: movl r9,-(sp) # save xr ! 21287: movl prbuf,r9 # point to buffer ! 21288: movl profs,r6 # no of chars ! 21289: jsb syspi # print ! 21290: .long prtc2 # fail return ! 21291: # ! 21292: # RETURN ! 21293: # ! 21294: prtc1: movl (sp)+,r9 # restore xr ! 21295: rsb # return ! 21296: # ! 21297: # ERROR OCCURED ! 21298: # ! 21299: prtc2: clrl erich # prevent looping ! 21300: jmp er_252 # error on printing to interactive channel ! 21301: jmp prtc1 # return ! 21302: #enp # procedure prtic ! 21303: #page ! 21304: # ! 21305: # PRTIS -- PRINT TO INTERACTIVE AND STANDARD PRINTER ! 21306: # ! 21307: # PRTIS PUTS A LINE FROM THE PRINT BUFFER ONTO THE ! 21308: # INTERACTIVE CHANNEL (IF ANY) AND THE STANDARD PRINTER. ! 21309: # IT ALWAYS PRINTS TO THE STANDARD PRINTER BUT DOES ! 21310: # NOT DUPLICATE LINES IF THE STANDARD PRINTER IS ! 21311: # INTERACTIVE. IT CLEARS DOWN THE PRINT BUFFER. ! 21312: # ! 21313: # JSR PRTIS CALL FOR PRINTING ! 21314: # (WA,WB) DESTROYED ! 21315: # ! 21316: prtis: #prc # entry point ! 21317: tstl prich # jump if standard printer is int.ch. ! 21318: bnequ prts1 ! 21319: tstl erich # skip if not doing int. error reps. ! 21320: beqlu prts1 ! 21321: jsb prtic # print to interactive channel ! 21322: # ! 21323: # MERGE AND EXIT ! 21324: # ! 21325: prts1: jsb prtnl # print to standard printer ! 21326: rsb # return ! 21327: #enp # end procedure prtis ! 21328: #page ! 21329: # ! 21330: # PRTIN -- PRINT AN INTEGER ! 21331: # ! 21332: # PRTIN PRINTS THE INTEGER VALUE WHICH IS IN THE INTEGER ! 21333: # ACCUMULATOR. BLOCKS BUILT IN DYNAMIC STORAGE ! 21334: # DURING THIS PROCESS ARE IMMEDIATELY DELETED. ! 21335: # ! 21336: # (IA) INTEGER VALUE TO BE PRINTED ! 21337: # JSR PRTIN CALL TO PRINT INTEGER ! 21338: # (IA,RA) DESTROYED ! 21339: # ! 21340: prtin: #prc # entry point ! 21341: movl r9,-(sp) # save xr ! 21342: jsb icbld # build integer block ! 21343: cmpl r9,dnamb # jump if icblk below dynamic ! 21344: blequ prti1 ! 21345: cmpl r9,dnamp # jump if above dynamic ! 21346: bgequ prti1 ! 21347: movl r9,dnamp # immediately delete it ! 21348: # ! 21349: # DELETE ICBLK FROM DYNAMIC STORE ! 21350: # ! 21351: prti1: movl r9,-(sp) # stack ptr for gtstg ! 21352: jsb gtstg # convert to string ! 21353: .long invalid$ # convert error is impossible ! 21354: movl r9,dnamp # reset pointer to delete scblk ! 21355: jsb prtst # print integer string ! 21356: movl (sp)+,r9 # restore entry xr ! 21357: rsb # return to prtin caller ! 21358: #enp # end procedure prtin ! 21359: #page ! 21360: # ! 21361: # PRTMI -- PRINT MESSAGE AND INTEGER ! 21362: # ! 21363: # PRTMI IS USED TO PRINT MESSAGES TOGETHER WITH AN INTEGER ! 21364: # VALUE STARTING IN COLUMN 15 (USED BY THE ROUTINES AT ! 21365: # THE END OF COMPILATION). ! 21366: # ! 21367: # JSR PRTMI CALL TO PRINT MESSAGE AND INTEGER ! 21368: # ! 21369: prtmi: #prc # entry point ! 21370: jsb prtst # print string message ! 21371: movl $prtmf,profs # set offset to col 15 ! 21372: jsb prtin # print integer ! 21373: jsb prtnl # print line ! 21374: rsb # return to prtmi caller ! 21375: #enp # end procedure prtmi ! 21376: #page ! 21377: # ! 21378: # PRTMX -- AS PRTMI WITH EXTRA COPY TO INTERACTIVE CHAN. ! 21379: # ! 21380: # JSR PRTMX CALL FOR PRINTING ! 21381: # (WA,WB) DESTROYED ! 21382: # ! 21383: prtmx: #prc # entry point ! 21384: jsb prtst # print string message ! 21385: movl $prtmf,profs # set ptr to column 15 ! 21386: jsb prtin # print integer ! 21387: jsb prtis # print line ! 21388: rsb # return ! 21389: #enp # end procedure prtmx ! 21390: #page ! 21391: # ! 21392: # PRTNL -- PRINT NEW LINE (END PRINT LINE) ! 21393: # ! 21394: # PRTNL PRINTS THE CONTENTS OF THE PRINT BUFFER, RESETS ! 21395: # THE BUFFER TO ALL BLANKS AND RESETS THE PRINT POINTER. ! 21396: # ! 21397: # JSR PRTNL CALL TO PRINT LINE ! 21398: # ! 21399: prtnl: #prc # entry point ! 21400: tstl headp # were headers printed ! 21401: bnequ prnl0 ! 21402: jsb prtps # no - print them ! 21403: # ! 21404: # CALL SYSPR ! 21405: # ! 21406: prnl0: movl r9,-(sp) # save entry xr ! 21407: movl r6,prtsa # save wa ! 21408: movl r7,prtsb # save wb ! 21409: movl prbuf,r9 # load pointer to buffer ! 21410: movl profs,r6 # load number of chars in buffer ! 21411: jsb syspr # call system print routine ! 21412: .long prnl2 # jump if failed ! 21413: movl prlnw,r6 # load length of buffer in words ! 21414: addl2 $4*schar,r9 # point to chars of buffer ! 21415: movl nullw,r7 # get word of blanks ! 21416: # ! 21417: # LOOP TO BLANK BUFFER ! 21418: # ! 21419: prnl1: movl r7,(r9)+ # store word of blanks, bump ptr ! 21420: sobgtr r6,prnl1 # loop till all blanked ! 21421: # ! 21422: # EXIT POINT ! 21423: # ! 21424: movl prtsb,r7 # restore wb ! 21425: movl prtsa,r6 # restore wa ! 21426: movl (sp)+,r9 # restore entry xr ! 21427: clrl profs # reset print buffer pointer ! 21428: rsb # return to prtnl caller ! 21429: # ! 21430: # FILE FULL OR NO OUTPUT FILE FOR LOAD MODULE ! 21431: # ! 21432: prnl2: tstl prtef # jump if not first time ! 21433: bnequ prnl3 ! 21434: movl sp,prtef # mark first occurrence ! 21435: jmp er_253 # print limit exceeded on standard output channel ! 21436: # ! 21437: # STOP AT ONCE ! 21438: # ! 21439: prnl3: movl $nini8,r7 # ending code ! 21440: movl kvstn,r6 # statement number ! 21441: jsb sysej # stop ! 21442: #enp # end procedure prtnl ! 21443: #page ! 21444: # ! 21445: # PRTNM -- PRINT VARIABLE NAME ! 21446: # ! 21447: # PRTNM IS USED TO PRINT A CHARACTER REPRESENTATION OF THE ! 21448: # NAME OF A VARIABLE (NOT A VALUE OF DATATYPE NAME) ! 21449: # NAMES OF PSEUDO-VARIABLES MAY NOT BE PASSED TO PRTNM. ! 21450: # ! 21451: # (XL) NAME BASE ! 21452: # (WA) NAME OFFSET ! 21453: # JSR PRTNM CALL TO PRINT NAME ! 21454: # (WB,WC,RA) DESTROYED ! 21455: # ! 21456: prtnm: #prc # entry point (recursive, see prtvl) ! 21457: movl r6,-(sp) # save wa (offset is collectable) ! 21458: movl r9,-(sp) # save entry xr ! 21459: movl r10,-(sp) # save name base ! 21460: cmpl r10,state # jump if not natural variable ! 21461: bgequ prn02 ! 21462: # ! 21463: # HERE FOR NATURAL VARIABLE NAME, RECOGNIZED BY THE FACT ! 21464: # THAT THE NAME BASE POINTS INTO THE STATIC AREA. ! 21465: # ! 21466: movl r10,r9 # point to vrblk ! 21467: jsb prtvn # print name of variable ! 21468: # ! 21469: # COMMON EXIT POINT ! 21470: # ! 21471: prn01: movl (sp)+,r10 # restore name base ! 21472: movl (sp)+,r9 # restore entry value of xr ! 21473: movl (sp)+,r6 # restore wa ! 21474: rsb # return to prtnm caller ! 21475: # ! 21476: # HERE FOR CASE OF NON-NATURAL VARIABLE ! 21477: # ! 21478: prn02: movl r6,r7 # copy name offset ! 21479: cmpl (r10),$b$pdt # jump if array or table ! 21480: bnequ prn03 ! 21481: # ! 21482: # FOR PROGRAM DEFINED DATATYPE, PRT FLD NAME, LEFT PAREN ! 21483: # ! 21484: movl 4*pddfp(r10),r9 # load pointer to dfblk ! 21485: addl2 r6,r9 # add name offset ! 21486: movl 4*pdfof(r9),r9 # load vrblk pointer for field ! 21487: jsb prtvn # print field name ! 21488: movl $ch$pp,r6 # load left paren ! 21489: jsb prtch # print character ! 21490: #page ! 21491: # ! 21492: # PRTNM (CONTINUED) ! 21493: # ! 21494: # NOW WE PRINT AN IDENTIFYING NAME FOR THE OBJECT IF ONE ! 21495: # CAN BE FOUND. THE FOLLOWING CODE SEARCHES FOR A NATURAL ! 21496: # VARIABLE WHICH CONTAINS THIS OBJECT AS VALUE. IF SUCH A ! 21497: # VARIABLE IS FOUND, ITS NAME IS PRINTED, ELSE THE VALUE ! 21498: # OF THE OBJECT (AS PRINTED BY PRTVL) IS USED INSTEAD. ! 21499: # ! 21500: # FIRST WE POINT TO THE PARENT TBBLK IF THIS IS THE CASE OF ! 21501: # A TABLE ELEMENT. TO DO THIS, CHASE DOWN THE TRNXT CHAIN. ! 21502: # ! 21503: prn03: cmpl (r10),$b$tet # jump if we got there (or not te) ! 21504: bnequ prn04 ! 21505: movl 4*tenxt(r10),r10# else move out on chain ! 21506: jmp prn03 # and loop back ! 21507: # ! 21508: # NOW WE ARE READY FOR THE SEARCH. TO SPEED THINGS UP IN ! 21509: # THE CASE OF CALLS FROM DUMP WHERE THE SAME NAME BASE ! 21510: # WILL OCCUR REPEATEDLY WHILE DUMPING AN ARRAY OR TABLE, ! 21511: # WE REMEMBER THE LAST VRBLK POINTER FOUND IN PRNMV. SO ! 21512: # FIRST CHECK TO SEE IF WE HAVE THIS ONE AGAIN. ! 21513: # ! 21514: prn04: movl prnmv,r9 # point to vrblk we found last time ! 21515: movl hshtb,r6 # point to hash table in case not ! 21516: jmp prn07 # jump into search for special check ! 21517: # ! 21518: # LOOP THROUGH HASH SLOTS ! 21519: # ! 21520: prn05: movl r6,r9 # copy slot pointer ! 21521: addl2 $4,r6 # bump slot pointer ! 21522: subl2 $4*vrnxt,r9 # introduce standard vrblk offset ! 21523: # ! 21524: # LOOP THROUGH VRBLKS ON ONE HASH CHAIN ! 21525: # ! 21526: prn06: movl 4*vrnxt(r9),r9 # point to next vrblk on hash chain ! 21527: # ! 21528: # MERGE HERE FIRST TIME TO CHECK BLOCK WE FOUND LAST TIME ! 21529: # ! 21530: prn07: movl r9,r8 # copy vrblk pointer ! 21531: tstl r8 # jump if chain end (or prnmv zero) ! 21532: beqlu prn09 ! 21533: #page ! 21534: # ! 21535: # PRTNM (CONTINUED) ! 21536: # ! 21537: # LOOP TO FIND VALUE (CHASE DOWN POSSIBLE TRBLK CHAIN) ! 21538: # ! 21539: prn08: movl 4*vrval(r9),r9 # load value ! 21540: cmpl (r9),$b$trt # loop if that was a trblk ! 21541: beqlu prn08 ! 21542: # ! 21543: # NOW WE HAVE THE VALUE, IS THIS THE BLOCK WE WANT ! 21544: # ! 21545: cmpl r9,r10 # jump if this matches the name base ! 21546: beqlu prn10 ! 21547: movl r8,r9 # else point back to that vrblk ! 21548: jmp prn06 # and loop back ! 21549: # ! 21550: # HERE TO MOVE TO NEXT HASH SLOT ! 21551: # ! 21552: prn09: cmpl r6,hshte # loop back if more to go ! 21553: blssu prn05 ! 21554: movl r10,r9 # else not found, copy value pointer ! 21555: jsb prtvl # print value ! 21556: jmp prn11 # and merge ahead ! 21557: # ! 21558: # HERE WHEN WE FIND A MATCHING ENTRY ! 21559: # ! 21560: prn10: movl r8,r9 # copy vrblk pointer ! 21561: movl r9,prnmv # save for next time in ! 21562: jsb prtvn # print variable name ! 21563: # ! 21564: # MERGE HERE IF NO ENTRY FOUND ! 21565: # ! 21566: prn11: movl (r10),r8 # load first word of name base ! 21567: cmpl r8,$b$pdt # jump if not program defined ! 21568: bnequ prn13 ! 21569: # ! 21570: # FOR PROGRAM DEFINED DATATYPE, ADD RIGHT PAREN AND EXIT ! 21571: # ! 21572: movl $ch$rp,r6 # load right paren, merge ! 21573: # ! 21574: # MERGE HERE TO PRINT FINAL RIGHT PAREN OR BRACKET ! 21575: # ! 21576: prn12: jsb prtch # print final character ! 21577: movl r7,r6 # restore name offset ! 21578: jmp prn01 # merge back to exit ! 21579: #page ! 21580: # ! 21581: # PRTNM (CONTINUED) ! 21582: # ! 21583: # HERE FOR ARRAY OR TABLE ! 21584: # ! 21585: prn13: movl $ch$bb,r6 # load left bracket ! 21586: jsb prtch # and print it ! 21587: movl (sp),r10 # restore block pointer ! 21588: movl (r10),r8 # load type word again ! 21589: cmpl r8,$b$tet # jump if not table ! 21590: bnequ prn15 ! 21591: # ! 21592: # HERE FOR TABLE, PRINT SUBSCRIPT VALUE ! 21593: # ! 21594: movl 4*tesub(r10),r9 # load subscript value ! 21595: movl r7,r10 # save name offset ! 21596: jsb prtvl # print subscript value ! 21597: movl r10,r7 # restore name offset ! 21598: # ! 21599: # MERGE HERE FROM ARRAY CASE TO PRINT RIGHT BRACKET ! 21600: # ! 21601: prn14: movl $ch$rb,r6 # load right bracket ! 21602: jmp prn12 # merge back to print it ! 21603: # ! 21604: # HERE FOR ARRAY OR VECTOR, TO PRINT SUBSCRIPT(S) ! 21605: # ! 21606: prn15: movl r7,r6 # copy name offset ! 21607: ashl $-2,r6,r6 # convert to words ! 21608: cmpl r8,$b$art # jump if arblk ! 21609: beqlu prn16 ! 21610: # ! 21611: # HERE FOR VECTOR ! 21612: # ! 21613: subl2 $vcvlb,r6 # adjust for standard fields ! 21614: movl r6,r5 # move to integer accum ! 21615: jsb prtin # print linear subscript ! 21616: jmp prn14 # merge back for right bracket ! 21617: #page ! 21618: # ! 21619: # PRTNM (CONTINUED) ! 21620: # ! 21621: # HERE FOR ARRAY. FIRST CALCULATE ABSOLUTE SUBSCRIPT ! 21622: # OFFSETS BY SUCCESSIVE DIVISIONS BY THE DIMENSION VALUES. ! 21623: # THIS MUST BE DONE RIGHT TO LEFT SINCE THE ELEMENTS ARE ! 21624: # STORED ROW-WISE. THE SUBSCRIPTS ARE STACKED AS INTEGERS. ! 21625: # ! 21626: prn16: movl 4*arofs(r10),r8 # load length of bounds info ! 21627: addl2 $4,r8 # adjust for arpro field ! 21628: ashl $-2,r8,r8 # convert to words ! 21629: subl2 r8,r6 # get linear zero-origin subscript ! 21630: movl r6,r5 # get integer value ! 21631: movl 4*arndm(r10),r6 # set num of dimensions as loop count ! 21632: addl2 4*arofs(r10),r10# point past bounds information ! 21633: subl2 $4*arlbd,r10 # set ok offset for proper ptr later ! 21634: # ! 21635: # LOOP TO STACK SUBSCRIPT OFFSETS ! 21636: # ! 21637: prn17: subl2 $4*ardms,r10 # point to next set of bounds ! 21638: movl r5,prnsi # save current offset ! 21639: ashq $-32,r4,r4 # get remainder on dividing by dimens ! 21640: ediv 4*ardim(r10),r4,r11,r5 ! 21641: movl r5,-(sp) # store on stack (one word) ! 21642: movl prnsi,r5 # reload argument ! 21643: divl2 4*ardim(r10),r5 # divide to get quotient ! 21644: sobgtr r6,prn17 # loop till all stacked ! 21645: clrl r9 # set offset to first set of bounds ! 21646: movl 4*arndm(r10),r7 # load count of dims to control loop ! 21647: jmp prn19 # jump into print loop ! 21648: # ! 21649: # LOOP TO PRINT SUBSCRIPTS FROM STACK ADJUSTING BY ADDING ! 21650: # THE APPROPRIATE LOW BOUND VALUE FROM THE ARBLK ! 21651: # ! 21652: prn18: movl $ch$cm,r6 # load a comma ! 21653: jsb prtch # print it ! 21654: # ! 21655: # MERGE HERE FIRST TIME IN (NO COMMA REQUIRED) ! 21656: # ! 21657: prn19: movl (sp)+,r5 # load subscript offset as integer ! 21658: addl2 r9,r10 # point to current lbd ! 21659: addl2 4*arlbd(r10),r5 # add lbd to get signed subscript ! 21660: subl2 r9,r10 # point back to start of arblk ! 21661: jsb prtin # print subscript ! 21662: addl2 $4*ardms,r9 # bump offset to next bounds ! 21663: sobgtr r7,prn18 # loop back till all printed ! 21664: jmp prn14 # merge back to print right bracket ! 21665: #enp # end procedure prtnm ! 21666: #page ! 21667: # ! 21668: # PRTNV -- PRINT NAME VALUE ! 21669: # ! 21670: # PRTNV IS USED BY THE TRACE AND DUMP ROUTINES TO PRINT ! 21671: # A LINE OF THE FORM ! 21672: # ! 21673: # NAME = VALUE ! 21674: # ! 21675: # NOTE THAT THE NAME INVOLVED CAN NEVER BE A PSEUDO-VAR ! 21676: # ! 21677: # (XL) NAME BASE ! 21678: # (WA) NAME OFFSET ! 21679: # JSR PRTNV CALL TO PRINT NAME = VALUE ! 21680: # (WB,WC,RA) DESTROYED ! 21681: # ! 21682: prtnv: #prc # entry point ! 21683: jsb prtnm # print argument name ! 21684: movl r9,-(sp) # save entry xr ! 21685: movl r6,-(sp) # save name offset (collectable) ! 21686: movl $tmbeb,r9 # point to blank equal blank ! 21687: jsb prtst # print it ! 21688: movl r10,r9 # copy name base ! 21689: addl2 r6,r9 # point to value ! 21690: movl (r9),r9 # load value pointer ! 21691: jsb prtvl # print value ! 21692: jsb prtnl # terminate line ! 21693: movl (sp)+,r6 # restore name offset ! 21694: movl (sp)+,r9 # restore entry xr ! 21695: rsb # return to caller ! 21696: #enp # end procedure prtnv ! 21697: #page ! 21698: # ! 21699: # PRTPG -- PRINT A PAGE THROW ! 21700: # ! 21701: # PRINTS A PAGE THROW OR A FEW BLANK LINES ON THE STANDARD ! 21702: # LISTING CHANNEL DEPENDING ON THE LISTING OPTIONS CHOSEN. ! 21703: # ! 21704: # JSR PRTPG CALL FOR PAGE EJECT ! 21705: # ! 21706: prtpg: #prc # entry point ! 21707: cmpl stage,$stgxt # jump if execution time ! 21708: beqlu prp01 ! 21709: tstl lstlc # return if top of page already ! 21710: bnequ 0f ! 21711: jmp prp06 ! 21712: 0: ! 21713: clrl lstlc # clear line count ! 21714: # ! 21715: # CHECK TYPE OF LISTING ! 21716: # ! 21717: prp01: movl r9,-(sp) # preserve xr ! 21718: tstl prstd # eject if flag set ! 21719: bnequ prp02 ! 21720: tstl prich # jump if interactive listing channel ! 21721: bnequ prp03 ! 21722: tstl precl # jump if compact listing ! 21723: beqlu prp03 ! 21724: # ! 21725: # PERFORM AN EJECT ! 21726: # ! 21727: prp02: jsb sysep # eject ! 21728: jmp prp04 # merge ! 21729: # ! 21730: # COMPACT OR INTERACTIVE CHANNEL LISTING. CANT PRINT ! 21731: # BLANKS UNTIL CHECK MADE FOR HEADERS PRINTED AND FLAG SET. ! 21732: # ! 21733: # ! 21734: prp03: movl headp,r9 # remember headp ! 21735: movl sp,headp # set to avoid repeated prtpg calls ! 21736: jsb prtnl # print blank line ! 21737: jsb prtnl # print blank line ! 21738: jsb prtnl # print blank line ! 21739: movl $num03,lstlc # count blank lines ! 21740: movl r9,headp # restore header flag ! 21741: #page ! 21742: # ! 21743: # PRPTG (CONTINUED) ! 21744: # ! 21745: # PRINT THE HEADING ! 21746: # ! 21747: prp04: tstl headp # jump if header listed ! 21748: bnequ prp05 ! 21749: movl sp,headp # mark headers printed ! 21750: movl r10,-(sp) # keep xl ! 21751: movl $headr,r9 # point to listing header ! 21752: jsb prtst # place it ! 21753: jsb sysid # get system identification ! 21754: jsb prtst # append extra chars ! 21755: jsb prtnl # print it ! 21756: movl r10,r9 # extra header line ! 21757: jsb prtst # place it ! 21758: jsb prtnl # print it ! 21759: jsb prtnl # print a blank ! 21760: jsb prtnl # and another ! 21761: addl2 $num04,lstlc # four header lines printed ! 21762: movl (sp)+,r10 # restore xl ! 21763: # ! 21764: # MERGE IF HEADER NOT PRINTED ! 21765: # ! 21766: prp05: movl (sp)+,r9 # restore xr ! 21767: # ! 21768: # RETURN ! 21769: # ! 21770: prp06: rsb # return ! 21771: #enp # end procedure prtpg ! 21772: #page ! 21773: # ! 21774: # PRTPS - PRINT PAGE WITH TEST FOR STANDARD LISTING OPTION ! 21775: # ! 21776: # IF THE STANDARD LISTING OPTION IS SELECTED, INSIST THAT ! 21777: # AN EJECT BE DONE ! 21778: # ! 21779: # JSR PRTPS CALL FOR EJECT ! 21780: # ! 21781: prtps: #prc # entry point ! 21782: movl prsto,prstd # copy option flag ! 21783: jsb prtpg # print page ! 21784: clrl prstd # clear flag ! 21785: rsb # return ! 21786: #enp # end procedure prtps ! 21787: #page ! 21788: # ! 21789: # PRTSN -- PRINT STATEMENT NUMBER ! 21790: # ! 21791: # PRTSN IS USED TO INITIATE A PRINT TRACE LINE BY PRINTING ! 21792: # ASTERISKS AND THE CURRENT STATEMENT NUMBER. THE ACTUAL ! 21793: # FORMAT OF THE OUTPUT GENERATED IS. ! 21794: # ! 21795: # ***NNNNN**** III.....IIII ! 21796: # ! 21797: # NNNNN IS THE STATEMENT NUMBER WITH LEADING ZEROS REPLACED ! 21798: # BY ASTERISKS (E.G. *******9****) ! 21799: # ! 21800: # III...III REPRESENTS A VARIABLE LENGTH OUTPUT CONSISTING ! 21801: # OF A NUMBER OF LETTER I CHARACTERS EQUAL TO FNCLEVEL. ! 21802: # ! 21803: # JSR PRTSN CALL TO PRINT STATEMENT NUMBER ! 21804: # (WC) DESTROYED ! 21805: # ! 21806: prtsn: #prc # entry point ! 21807: movl r9,-(sp) # save entry xr ! 21808: movl r6,prsna # save entry wa ! 21809: movl $tmasb,r9 # point to asterisks ! 21810: jsb prtst # print asterisks ! 21811: movl $num04,profs # point into middle of asterisks ! 21812: movl kvstn,r5 # load statement number as integer ! 21813: jsb prtin # print integer statement number ! 21814: movl $prsnf,profs # point past asterisks plus blank ! 21815: movl kvfnc,r9 # get fnclevel ! 21816: movl $ch$li,r6 # set letter i ! 21817: # ! 21818: # LOOP TO GENERATE LETTER I FNCLEVEL TIMES ! 21819: # ! 21820: prsn1: tstl r9 # jump if all set ! 21821: beqlu prsn2 ! 21822: jsb prtch # else print an i ! 21823: decl r9 # decrement counter ! 21824: jmp prsn1 # loop back ! 21825: # ! 21826: # MERRE WITH ALL LETTER I CHARACTERS GENERATED ! 21827: # ! 21828: prsn2: movl $ch$bl,r6 # get blank ! 21829: jsb prtch # print blank ! 21830: movl prsna,r6 # restore entry wa ! 21831: movl (sp)+,r9 # restore entry xr ! 21832: rsb # return to prtsn caller ! 21833: #enp # end procedure prtsn ! 21834: #page ! 21835: # ! 21836: # PRTST -- PRINT STRING ! 21837: # ! 21838: # PRTST PLACES A STRING OF CHARACTERS IN THE PRINT BUFFER ! 21839: # ! 21840: # SEE PRTNL FOR GLOBAL LOCATIONS USED ! 21841: # ! 21842: # NOTE THAT THE FIRST WORD OF THE BLOCK (NORMALLY B$SCL) ! 21843: # IS NOT USED AND NEED NOT BE SET CORRECTLY (SEE PRTVN) ! 21844: # ! 21845: # (XR) STRING TO BE PRINTED ! 21846: # JSR PRTST CALL TO PRINT STRING ! 21847: # (PROFS) UPDATED PAST CHARS PLACED ! 21848: # ! 21849: prtst: #prc # entry point ! 21850: tstl headp # were headers printed ! 21851: bnequ prst0 ! 21852: jsb prtps # no - print them ! 21853: # ! 21854: # CALL SYSPR ! 21855: # ! 21856: prst0: movl r6,prsva # save wa ! 21857: movl r7,prsvb # save wb ! 21858: clrl r7 # set chars printed count to zero ! 21859: # ! 21860: # LOOP TO PRINT SUCCESSIVE LINES FOR LONG STRING ! 21861: # ! 21862: prst1: movl 4*sclen(r9),r6 # load string length ! 21863: subl2 r7,r6 # subtract count of chars already out ! 21864: tstl r6 # jump to exit if none left ! 21865: bnequ 0f ! 21866: jmp prst4 ! 21867: 0: ! 21868: movl r10,-(sp) # else stack entry xl ! 21869: movl r9,-(sp) # save argument ! 21870: movl r9,r10 # copy for eventual move ! 21871: movl prlen,r9 # load print buffer length ! 21872: subl2 profs,r9 # get chars left in print buffer ! 21873: tstl r9 # skip if room left on this line ! 21874: bnequ prst2 ! 21875: jsb prtnl # else print this line ! 21876: movl prlen,r9 # and set full width available ! 21877: #page ! 21878: # ! 21879: # PRTST (CONTINUED) ! 21880: # ! 21881: # HERE WITH CHARS TO PRINT AND SOME ROOM IN BUFFER ! 21882: # ! 21883: prst2: cmpl r6,r9 # jump if room for rest of string ! 21884: blequ prst3 ! 21885: movl r9,r6 # else set to fill line ! 21886: # ! 21887: # MERGE HERE WITH CHARACTER COUNT IN WA ! 21888: # ! 21889: prst3: movl prbuf,r9 # point to print buffer ! 21890: movab cfp$f(r10)[r7],r10 # point to location in string ! 21891: movl profs,r11 # [get in scratch register] ! 21892: movab cfp$f(r9)[r11],r9# point to location in buffer ! 21893: addl2 r6,r7 # bump string chars count ! 21894: addl2 r6,profs # bump buffer pointer ! 21895: movl r7,prsvc # preserve char counter ! 21896: jsb sbmvc # move characters to buffer ! 21897: movl prsvc,r7 # recover char counter ! 21898: movl (sp)+,r9 # restore argument pointer ! 21899: movl (sp)+,r10 # restore entry xl ! 21900: jmp prst1 # loop back to test for more ! 21901: # ! 21902: # HERE TO EXIT AFTER PRINTING STRING ! 21903: # ! 21904: prst4: movl prsvb,r7 # restore entry wb ! 21905: movl prsva,r6 # restore entry wa ! 21906: rsb # return to prtst caller ! 21907: #enp # end procedure prtst ! 21908: #page ! 21909: # ! 21910: # PRTTR -- PRINT TO TERMINAL ! 21911: # ! 21912: # CALLED TO PRINT CONTENTS OF STANDARD PRINT BUFFER TO ! 21913: # ONLINE TERMINAL. CLEARS BUFFER DOWN AND RESETS PROFS. ! 21914: # ! 21915: # JSR PRTTR CALL FOR PRINT ! 21916: # (WA,WB) DESTROYED ! 21917: # ! 21918: prttr: #prc # entry point ! 21919: movl r9,-(sp) # save xr ! 21920: jsb prtic # print buffer contents ! 21921: movl prbuf,r9 # point to print bfr to clear it ! 21922: movl prlnw,r6 # get buffer length ! 21923: addl2 $4*schar,r9 # point past scblk header ! 21924: movl nullw,r7 # get blanks ! 21925: # ! 21926: # LOOP TO CLEAR BUFFER ! 21927: # ! 21928: prtt1: movl r7,(r9)+ # clear a word ! 21929: sobgtr r6,prtt1 # loop ! 21930: clrl profs # reset profs ! 21931: movl (sp)+,r9 # restore xr ! 21932: rsb # return ! 21933: #enp # end procedure prttr ! 21934: #page ! 21935: # ! 21936: # PRTVL -- PRINT A VALUE ! 21937: # ! 21938: # PRTVL PLACES AN APPROPRIATE CHARACTER REPRESENTATION OF ! 21939: # A DATA VALUE IN THE PRINT BUFFER FOR DUMP/TRACE USE. ! 21940: # ! 21941: # (XR) VALUE TO BE PRINTED ! 21942: # JSR PRTVL CALL TO PRINT VALUE ! 21943: # (WA,WB,WC,RA) DESTROYED ! 21944: # ! 21945: prtvl: #prc # entry point, recursive ! 21946: movl r10,-(sp) # save entry xl ! 21947: movl r9,-(sp) # save argument ! 21948: jsb sbchk # check for stack overflow ! 21949: # ! 21950: # LOOP BACK HERE AFTER FINDING A TRAP BLOCK (TRBLK) ! 21951: # ! 21952: prv01: movl 4*idval(r9),prvsi# copy idval (if any) ! 21953: movl (r9),r10 # load first word of block ! 21954: movzwl -2(r10),r10 # load entry point id ! 21955: casel r10,$0,$bl$$t # switch on block type ! 21956: 5: ! 21957: .word prv05-5b # arblk ! 21958: .word prv15-5b # bcblk ! 21959: .word prv02-5b ! 21960: .word prv02-5b ! 21961: .word prv08-5b # icblk ! 21962: .word prv09-5b # nmblk ! 21963: .word prv02-5b ! 21964: .word prv02-5b ! 21965: .word prv02-5b ! 21966: .word prv08-5b # rcblk ! 21967: .word prv11-5b # scblk ! 21968: .word prv12-5b # seblk ! 21969: .word prv13-5b # tbblk ! 21970: .word prv13-5b # vcblk ! 21971: .word prv02-5b ! 21972: .word prv02-5b ! 21973: .word prv10-5b # pdblk ! 21974: .word prv04-5b # trblk ! 21975: #esw # end of switch on block type ! 21976: # ! 21977: # HERE FOR BLOCKS FOR WHICH WE JUST PRINT DATATYPE NAME ! 21978: # ! 21979: prv02: jsb dtype # get datatype name ! 21980: jsb prtst # print datatype name ! 21981: # ! 21982: # COMMON EXIT POINT ! 21983: # ! 21984: prv03: movl (sp)+,r9 # reload argument ! 21985: movl (sp)+,r10 # restore xl ! 21986: rsb # return to prtvl caller ! 21987: # ! 21988: # HERE FOR TRBLK ! 21989: # ! 21990: prv04: movl 4*trval(r9),r9 # load real value ! 21991: jmp prv01 # and loop back ! 21992: #page ! 21993: # ! 21994: # PRTVL (CONTINUED) ! 21995: # ! 21996: # HERE FOR ARRAY (ARBLK) ! 21997: # ! 21998: # PRINT ARRAY ( PROTOTYPE ) BLANK NUMBER IDVAL ! 21999: # ! 22000: prv05: movl r9,r10 # preserve argument ! 22001: movl $scarr,r9 # point to datatype name (array) ! 22002: jsb prtst # print it ! 22003: movl $ch$pp,r6 # load left paren ! 22004: jsb prtch # print left paren ! 22005: addl2 4*arofs(r10),r10# point to prototype ! 22006: movl (r10),r9 # load prototype ! 22007: jsb prtst # print prototype ! 22008: # ! 22009: # VCBLK, TBBLK, BCBLK MERGE HERE FOR ) BLANK NUMBER IDVAL ! 22010: # ! 22011: prv06: movl $ch$rp,r6 # load right paren ! 22012: jsb prtch # print right paren ! 22013: # ! 22014: # PDBLK MERGES HERE TO PRINT BLANK NUMBER IDVAL ! 22015: # ! 22016: prv07: movl $ch$bl,r6 # load blank ! 22017: jsb prtch # print it ! 22018: movl $ch$nm,r6 # load number sign ! 22019: jsb prtch # print it ! 22020: movl prvsi,r5 # get idval ! 22021: jsb prtin # print id number ! 22022: jmp prv03 # back to exit ! 22023: # ! 22024: # HERE FOR INTEGER (ICBLK), REAL (RCBLK) ! 22025: # ! 22026: # PRINT CHARACTER REPRESENTATION OF VALUE ! 22027: # ! 22028: prv08: movl r9,-(sp) # stack argument for gtstg ! 22029: jsb gtstg # convert to string ! 22030: .long invalid$ # error return is impossible ! 22031: jsb prtst # print the string ! 22032: movl r9,dnamp # delete garbage string from storage ! 22033: jmp prv03 # back to exit ! 22034: #page ! 22035: # ! 22036: # PRTVL (CONTINUED) ! 22037: # ! 22038: # NAME (NMBLK) ! 22039: # ! 22040: # FOR PSEUDO-VARIABLE, JUST PRINT DATATYPE NAME (NAME) ! 22041: # FOR ALL OTHER NAMES, PRINT DOT FOLLOWED BY NAME REP ! 22042: # ! 22043: prv09: movl 4*nmbas(r9),r10 # load name base ! 22044: movl (r10),r6 # load first word of block ! 22045: cmpl r6,$b$kvt # just print name if keyword ! 22046: bnequ 0f ! 22047: jmp prv02 ! 22048: 0: ! 22049: cmpl r6,$b$evt # just print name if expression var ! 22050: bnequ 0f ! 22051: jmp prv02 ! 22052: 0: ! 22053: movl $ch$dt,r6 # else get dot ! 22054: jsb prtch # and print it ! 22055: movl 4*nmofs(r9),r6 # load name offset ! 22056: jsb prtnm # print name ! 22057: jmp prv03 # back to exit ! 22058: # ! 22059: # PROGRAM DATATYPE (PDBLK) ! 22060: # ! 22061: # PRINT DATATYPE NAME CH$BL CH$NM IDVAL ! 22062: # ! 22063: prv10: jsb dtype # get datatype name ! 22064: jsb prtst # print datatype name ! 22065: jmp prv07 # merge back to print id ! 22066: # ! 22067: # HERE FOR STRING (SCBLK) ! 22068: # ! 22069: # PRINT QUOTE STRING-CHARACTERS QUOTE ! 22070: # ! 22071: prv11: movl $ch$sq,r6 # load single quote ! 22072: jsb prtch # print quote ! 22073: jsb prtst # print string value ! 22074: jsb prtch # print another quote ! 22075: jmp prv03 # back to exit ! 22076: #page ! 22077: # ! 22078: # PRTVL (CONTINUED) ! 22079: # ! 22080: # HERE FOR SIMPLE EXPRESSION (SEBLK) ! 22081: # ! 22082: # PRINT ASTERISK VARIABLE-NAME ! 22083: # ! 22084: prv12: movl $ch$as,r6 # load asterisk ! 22085: jsb prtch # print asterisk ! 22086: movl 4*sevar(r9),r9 # load variable pointer ! 22087: jsb prtvn # print variable name ! 22088: jmp prv03 # jump back to exit ! 22089: # ! 22090: # HERE FOR TABLE (TBBLK) AND ARRAY (VCBLK) ! 22091: # ! 22092: # PRINT DATATYPE ( PROTOTYPE ) BLANK NUMBER IDVAL ! 22093: # ! 22094: prv13: movl r9,r10 # preserve argument ! 22095: jsb dtype # get datatype name ! 22096: jsb prtst # print datatype name ! 22097: movl $ch$pp,r6 # load left paren ! 22098: jsb prtch # print left paren ! 22099: movl 4*tblen(r10),r6 # load length of block (=vclen) ! 22100: ashl $-2,r6,r6 # convert to word count ! 22101: subl2 $tbsi$,r6 # allow for standard fields ! 22102: cmpl (r10),$b$tbt # jump if table ! 22103: beqlu prv14 ! 22104: addl2 $vctbd,r6 # for vcblk, adjust size ! 22105: # ! 22106: # PRINT PROTOTYPE ! 22107: # ! 22108: prv14: movl r6,r5 # move as integer ! 22109: jsb prtin # print integer prototype ! 22110: jmp prv06 # merge back for rest ! 22111: #page ! 22112: # ! 22113: # PRTVL (CONTINUED) ! 22114: # ! 22115: # HERE FOR BUFFER (BCBLK) ! 22116: # ! 22117: prv15: movl r9,r10 # preserve argument ! 22118: movl $scbuf,r9 # point to datatype name (buffer) ! 22119: jsb prtst # print it ! 22120: movl $ch$pp,r6 # load left paren ! 22121: jsb prtch # print left paren ! 22122: movl 4*bcbuf(r10),r9 # point to bfblk ! 22123: movl 4*bfalc(r9),r5 # load allocation size ! 22124: jsb prtin # print it ! 22125: movl $ch$cm,r6 # load comma ! 22126: jsb prtch # print it ! 22127: movl 4*bclen(r10),r5 # load defined length ! 22128: jsb prtin # print it ! 22129: jmp prv06 # merge to finish up ! 22130: #enp # end procedure prtvl ! 22131: #page ! 22132: # ! 22133: # PRTVN -- PRINT NATURAL VARIABLE NAME ! 22134: # ! 22135: # PRTVN PRINTS THE NAME OF A NATURAL VARIABLE ! 22136: # ! 22137: # (XR) POINTER TO VRBLK ! 22138: # JSR PRTVN CALL TO PRINT VARIABLE NAME ! 22139: # ! 22140: prtvn: #prc # entry point ! 22141: movl r9,-(sp) # stack vrblk pointer ! 22142: addl2 $4*vrsof,r9 # point to possible string name ! 22143: tstl 4*sclen(r9) # jump if not system variable ! 22144: bnequ prvn1 ! 22145: movl 4*vrsvo(r9),r9 # point to svblk with name ! 22146: # ! 22147: # MERGE HERE WITH DUMMY SCBLK POINTER IN XR ! 22148: # ! 22149: prvn1: jsb prtst # print string name of variable ! 22150: movl (sp)+,r9 # restore vrblk pointer ! 22151: rsb # return to prtvn caller ! 22152: #enp # end procedure prtvn ! 22153: #page ! 22154: # ! 22155: # RCBLD -- BUILD A REAL BLOCK ! 22156: # ! 22157: # (RA) REAL VALUE FOR RCBLK ! 22158: # JSR RCBLD CALL TO BUILD REAL BLOCK ! 22159: # (XR) POINTER TO RESULT RCBLK ! 22160: # (WA) DESTROYED ! 22161: # ! 22162: rcbld: #prc # entry point ! 22163: movl dnamp,r9 # load pointer to next available loc ! 22164: addl2 $4*rcsi$,r9 # point past new rcblk ! 22165: cmpl r9,dname # jump if there is room ! 22166: blequ rcbl1 ! 22167: movl $4*rcsi$,r6 # else load rcblk length ! 22168: jsb alloc # use standard allocator to get block ! 22169: addl2 r6,r9 # point past block to merge ! 22170: # ! 22171: # MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED ! 22172: # ! 22173: rcbl1: movl r9,dnamp # set new pointer ! 22174: subl2 $4*rcsi$,r9 # point back to start of block ! 22175: movl $b$rcl,(r9) # store type word ! 22176: movf r2,4*rcval(r9) # store real value in rcblk ! 22177: rsb # return to rcbld caller ! 22178: #enp # end procedure rcbld ! 22179: #page ! 22180: # ! 22181: # READR -- READ NEXT SOURCE IMAGE AT COMPILE TIME ! 22182: # ! 22183: # READR IS USED TO READ THE NEXT SOURCE IMAGE. TO PROCESS ! 22184: # CONTINUATION CARDS PROPERLY, THE COMPILER MUST READ ONE ! 22185: # LINE AHEAD. THUS READR DOES NOT DESTROY THE CURRENT IMAGE ! 22186: # SEE ALSO THE NEXTS ROUTINE WHICH ACTUALLY GETS THE IMAGE. ! 22187: # ! 22188: # JSR READR CALL TO READ NEXT IMAGE ! 22189: # (XR) PTR TO NEXT IMAGE (0 IF NONE) ! 22190: # (R$CNI) COPY OF POINTER ! 22191: # (WA,WB,WC,XL) DESTROYED ! 22192: # ! 22193: readr: #prc # entry point ! 22194: movl r$cni,r9 # get ptr to next image ! 22195: tstl r9 # exit if already read ! 22196: bnequ read3 ! 22197: cmpl stage,$stgic # exit if not initial compile ! 22198: bnequ read3 ! 22199: movl cswin,r6 # max read length ! 22200: jsb alocs # allocate buffer ! 22201: jsb sysrd # read input image ! 22202: .long read4 # jump if end of file ! 22203: movl sp,r7 # set trimr to perform trim ! 22204: cmpl 4*sclen(r9),cswin# use smaller of string lnth .. ! 22205: blequ read1 ! 22206: movl cswin,4*sclen(r9)# ... and xxx of -inxxx ! 22207: # ! 22208: # PERFORM THE TRIM ! 22209: # ! 22210: read1: jsb trimr # trim trailing blanks ! 22211: # ! 22212: # MERGE HERE AFTER READ ! 22213: # ! 22214: read2: movl r9,r$cni # store copy of pointer ! 22215: # ! 22216: # MERGE HERE IF NO READ ATTEMPTED ! 22217: # ! 22218: read3: rsb # return to readr caller ! 22219: # ! 22220: # HERE ON END OF FILE ! 22221: # ! 22222: read4: movl r9,dnamp # pop unused scblk ! 22223: clrl r9 # zero ptr as result ! 22224: jmp read2 # merge ! 22225: #enp # end procedure readr ! 22226: #page ! 22227: # ! 22228: # SBSTR -- BUILD A SUBSTRING ! 22229: # ! 22230: # (XL) PTR TO SCBLK/BFBLK WITH CHARS ! 22231: # (WA) NUMBER OF CHARS IN SUBSTRING ! 22232: # (WB) OFFSET TO FIRST CHAR IN SCBLK ! 22233: # JSR SBSTR CALL TO BUILD SUBSTRING ! 22234: # (XR) PTR TO NEW SCBLK WITH SUBSTRING ! 22235: # (XL) ZERO ! 22236: # (WA,WB,WC,XL,IA) DESTROYED ! 22237: # ! 22238: # NOTE THAT SBSTR IS CALLED WITH A DUMMY STRING POINTER ! 22239: # (POINTING INTO A VRBLK OR SVBLK) TO COPY THE NAME OF A ! 22240: # VARIABLE AS A STANDARD STRING VALUE. ! 22241: # ! 22242: sbstr: #prc # entry point ! 22243: tstl r6 # jump if null substring ! 22244: beqlu sbst2 ! 22245: jsb alocs # else allocate scblk ! 22246: movl r8,r6 # move number of characters ! 22247: movl r9,r8 # save ptr to new scblk ! 22248: movab cfp$f(r10)[r7],r10 # prepare to load chars from old blk ! 22249: movab cfp$f(r9),r9 # prepare to store chars in new blk ! 22250: jsb sbmvc # move characters to new string ! 22251: movl r8,r9 # then restore scblk pointer ! 22252: # ! 22253: # RETURN POINT ! 22254: # ! 22255: sbst1: clrl r10 # clear garbage pointer in xl ! 22256: rsb # return to sbstr caller ! 22257: # ! 22258: # HERE FOR NULL SUBSTRING ! 22259: # ! 22260: sbst2: movl $nulls,r9 # set null string as result ! 22261: jmp sbst1 # return ! 22262: #enp # end procedure sbstr ! 22263: #page ! 22264: # ! 22265: # SCANE -- SCAN AN ELEMENT ! 22266: # ! 22267: # SCANE IS CALLED AT COMPILE TIME (BY EXPAN ,CMPIL,CNCRD) ! 22268: # TO SCAN ONE ELEMENT FROM THE INPUT IMAGE. ! 22269: # ! 22270: # (SCNCC) NON-ZERO IF CALLED FROM CNCRD ! 22271: # JSR SCANE CALL TO SCAN ELEMENT ! 22272: # (XR) RESULT POINTER (SEE BELOW) ! 22273: # (XL) SYNTAX TYPE CODE (T$XXX) ! 22274: # ! 22275: # THE FOLLOWING GLOBAL LOCATIONS ARE USED. ! 22276: # ! 22277: # R$CIM POINTER TO STRING BLOCK (SCBLK) ! 22278: # FOR CURRENT INPUT IMAGE. ! 22279: # ! 22280: # R$CNI POINTER TO NEXT INPUT IMAGE STRING ! 22281: # POINTER (ZERO IF NONE). ! 22282: # ! 22283: # R$SCP SAVE POINTER (EXIT XR) FROM LAST ! 22284: # CALL IN CASE RESCAN IS SET. ! 22285: # ! 22286: # SCNBL THIS LOCATION IS SET NON-ZERO ON ! 22287: # EXIT IF SCANE SCANNED PAST BLANKS ! 22288: # BEFORE LOCATING THE CURRENT ELEMENT ! 22289: # THE END OF A LINE COUNTS AS BLANKS. ! 22290: # ! 22291: # SCNCC CNCRD SETS THIS NON-ZERO TO SCAN ! 22292: # CONTROL CARD NAMES AND CLEARS IT ! 22293: # ON RETURN ! 22294: # ! 22295: # SCNIL LENGTH OF CURRENT INPUT IMAGE ! 22296: # ! 22297: # SCNGO IF SET NON-ZERO ON ENTRY, F AND S ! 22298: # ARE RETURNED AS SEPARATE SYNTAX ! 22299: # TYPES (NOT LETTERS) (GOTO PRO- ! 22300: # CESSING). SCNGO IS RESET ON EXIT. ! 22301: # ! 22302: # SCNPT OFFSET TO CURRENT LOC IN R$CIM ! 22303: # ! 22304: # SCNRS IF SET NON-ZERO ON ENTRY, SCANE ! 22305: # RETURNS THE SAME RESULT AS ON THE ! 22306: # LAST CALL (RESCAN). SCNRS IS RESET ! 22307: # ON EXIT FROM ANY CALL TO SCANE. ! 22308: # ! 22309: # SCNTP SAVE SYNTAX TYPE FROM LAST ! 22310: # CALL (IN CASE RESCAN IS SET). ! 22311: #page ! 22312: # ! 22313: # SCANE (CONTINUED) ! 22314: # ! 22315: # ! 22316: # ! 22317: # ELEMENT SCANNED XL XR ! 22318: # --------------- -- -- ! 22319: # ! 22320: # CONTROL CARD NAME 0 POINTER TO SCBLK FOR NAME ! 22321: # ! 22322: # UNARY OPERATOR T$UOP PTR TO OPERATOR DVBLK ! 22323: # ! 22324: # LEFT PAREN T$LPR T$LPR ! 22325: # ! 22326: # LEFT BRACKET T$LBR T$LBR ! 22327: # ! 22328: # COMMA T$CMA T$CMA ! 22329: # ! 22330: # FUNCTION CALL T$FNC PTR TO FUNCTION VRBLK ! 22331: # ! 22332: # VARIABLE T$VAR PTR TO VRBLK ! 22333: # ! 22334: # STRING CONSTANT T$CON PTR TO SCBLK ! 22335: # ! 22336: # INTEGER CONSTANT T$CON PTR TO ICBLK ! 22337: # ! 22338: # REAL CONSTANT T$CON PTR TO RCBLK ! 22339: # ! 22340: # BINARY OPERATOR T$BOP PTR TO OPERATOR DVBLK ! 22341: # ! 22342: # RIGHT PAREN T$RPR T$RPR ! 22343: # ! 22344: # RIGHT BRACKET T$RBR T$RBR ! 22345: # ! 22346: # COLON T$COL T$COL ! 22347: # ! 22348: # SEMI-COLON T$SMC T$SMC ! 22349: # ! 22350: # F (SCNGO NE 0) T$FGO T$FGO ! 22351: # ! 22352: # S (SCNGO NE 0) T$SGO T$SGO ! 22353: #page ! 22354: # ! 22355: # SCANE (CONTINUED) ! 22356: # ! 22357: # ENTRY POINT ! 22358: # ! 22359: scane: #prc # entry point ! 22360: clrl scnbl # reset blanks flag ! 22361: movl r6,scnsa # save wa ! 22362: movl r7,scnsb # save wb ! 22363: movl r8,scnsc # save wc ! 22364: tstl scnrs # jump if no rescan ! 22365: beqlu scn03 ! 22366: # ! 22367: # HERE FOR RESCAN REQUEST ! 22368: # ! 22369: movl scntp,r10 # set previous returned scan type ! 22370: movl r$scp,r9 # set previous returned pointer ! 22371: clrl scnrs # reset rescan switch ! 22372: jmp scn13 # jump to exit ! 22373: # ! 22374: # COME HERE TO READ NEW IMAGE TO TEST FOR CONTINUATION ! 22375: # ! 22376: scn01: jsb readr # read next image ! 22377: movl $4*dvubs,r7 # set wb for not reading name ! 22378: tstl r9 # treat as semi-colon if none ! 22379: bnequ 0f ! 22380: jmp scn30 ! 22381: 0: ! 22382: movab cfp$f(r9),r9 # else point to first character ! 22383: movzbl (r9),r8 # load first character ! 22384: cmpl r8,$ch$dt # jump if dot for continuation ! 22385: beqlu scn02 ! 22386: cmpl r8,$ch$pl # else treat as semicolon unless plus ! 22387: beqlu 0f ! 22388: jmp scn30 ! 22389: 0: ! 22390: # ! 22391: # HERE FOR CONTINUATION LINE ! 22392: # ! 22393: scn02: jsb nexts # acquire next source image ! 22394: movl $num01,scnpt # set scan pointer past continuation ! 22395: movl sp,scnbl # set blanks flag ! 22396: #page ! 22397: # ! 22398: # SCANE (CONTINUED) ! 22399: # ! 22400: # MERGE HERE TO SCAN NEXT ELEMENT ON CURRENT LINE ! 22401: # ! 22402: scn03: movl scnpt,r6 # load current offset ! 22403: cmpl r6,scnil # check continuation if end ! 22404: bnequ 0f ! 22405: jmp scn01 ! 22406: 0: ! 22407: movl r$cim,r10 # point to current line ! 22408: movab cfp$f(r10)[r6],r10 # point to current character ! 22409: movl r6,scnse # set start of element location ! 22410: movl $opdvs,r8 # point to operator dv list ! 22411: movl $4*dvubs,r7 # set constant for operator circuit ! 22412: jmp scn06 # start scanning ! 22413: # ! 22414: # LOOP HERE TO IGNORE LEADING BLANKS AND TABS ! 22415: # ! 22416: scn05: tstl r7 # jump if trailing ! 22417: bnequ 0f ! 22418: jmp scn10 ! 22419: 0: ! 22420: incl scnse # increment start of element ! 22421: cmpl r6,scnil # jump if end of image ! 22422: bnequ 0f ! 22423: jmp scn01 ! 22424: 0: ! 22425: movl sp,scnbl # note blanks seen ! 22426: # ! 22427: # THE FOLLOWING JUMP IS USED REPEATEDLY FOR SCANNING OUT ! 22428: # THE CHARACTERS OF A NUMERIC CONSTANT OR VARIABLE NAME. ! 22429: # THE REGISTERS ARE USED AS FOLLOWS. ! 22430: # ! 22431: # (XR) SCRATCH ! 22432: # (XL) PTR TO NEXT CHARACTER ! 22433: # (WA) CURRENT SCAN OFFSET ! 22434: # (WB) *DVUBS (0 IF SCANNING NAME,CONST) ! 22435: # (WC) =OPDVS (0 IF SCANNING CONSTANT) ! 22436: # ! 22437: scn06: movzbl (r10)+,r9 # get next character ! 22438: incl r6 # bump scan offset ! 22439: movl r6,scnpt # store offset past char scanned ! 22440: cmpl $cfp$u,r9 # quick check for other char ! 22441: bgtru 0f ! 22442: jmp scn07 ! 22443: 0: ! 22444: casel r9,$0,$cfp$u # switch on scanned character ! 22445: 5: ! 22446: # ! 22447: # SWITCH TABLE FOR SWITCH ON CHARACTER ! 22448: # ! 22449: #page ! 22450: # ! 22451: # SCANE (CONTINUED) ! 22452: # ! 22453: #page ! 22454: # ! 22455: # SCANE (CONTINUED) ! 22456: # ! 22457: .word scn07-5b ! 22458: .word scn07-5b ! 22459: .word scn07-5b ! 22460: .word scn07-5b ! 22461: .word scn07-5b ! 22462: .word scn07-5b ! 22463: .word scn07-5b ! 22464: .word scn07-5b ! 22465: .word scn07-5b ! 22466: .word scn05-5b # horizontal tab ! 22467: .word scn07-5b ! 22468: .word scn07-5b ! 22469: .word scn07-5b ! 22470: .word scn07-5b ! 22471: .word scn07-5b ! 22472: .word scn07-5b ! 22473: .word scn07-5b ! 22474: .word scn07-5b ! 22475: .word scn07-5b ! 22476: .word scn07-5b ! 22477: .word scn07-5b ! 22478: .word scn07-5b ! 22479: .word scn07-5b ! 22480: .word scn07-5b ! 22481: .word scn07-5b ! 22482: .word scn07-5b ! 22483: .word scn07-5b ! 22484: .word scn07-5b ! 22485: .word scn07-5b ! 22486: .word scn07-5b ! 22487: .word scn07-5b ! 22488: .word scn07-5b ! 22489: .word scn05-5b # blank ! 22490: .word scn37-5b # exclamation mark ! 22491: .word scn17-5b # double quote ! 22492: .word scn41-5b # number sign ! 22493: .word scn36-5b # dollar ! 22494: .word scn38-5b # percent ! 22495: .word scn44-5b # ampersand ! 22496: .word scn16-5b # single quote ! 22497: .word scn25-5b # left paren ! 22498: .word scn26-5b # right paren ! 22499: .word scn49-5b # asterisk ! 22500: .word scn33-5b # plus ! 22501: .word scn31-5b # comma ! 22502: .word scn34-5b # minus ! 22503: .word scn32-5b # dot ! 22504: .word scn40-5b # slash ! 22505: .word scn08-5b # digit 0 ! 22506: .word scn08-5b # digit 1 ! 22507: .word scn08-5b # digit 2 ! 22508: .word scn08-5b # digit 3 ! 22509: .word scn08-5b # digit 4 ! 22510: .word scn08-5b # digit 5 ! 22511: .word scn08-5b # digit 6 ! 22512: .word scn08-5b # digit 7 ! 22513: .word scn08-5b # digit 8 ! 22514: .word scn08-5b # digit 9 ! 22515: .word scn29-5b # colon ! 22516: .word scn30-5b # semi-colon ! 22517: .word scn28-5b # left bracket ! 22518: .word scn46-5b # equal ! 22519: .word scn27-5b # right bracket ! 22520: .word scn45-5b # question mark ! 22521: .word scn42-5b # at ! 22522: .word scn09-5b # letter a ! 22523: .word scn09-5b # letter b ! 22524: .word scn09-5b # letter c ! 22525: .word scn09-5b # letter d ! 22526: .word scn09-5b # letter e ! 22527: .word scn20-5b # letter f ! 22528: .word scn09-5b # letter g ! 22529: .word scn09-5b # letter h ! 22530: .word scn09-5b # letter i ! 22531: .word scn09-5b # letter j ! 22532: .word scn09-5b # letter k ! 22533: .word scn09-5b # letter l ! 22534: .word scn09-5b # letter m ! 22535: .word scn09-5b # letter n ! 22536: .word scn09-5b # letter o ! 22537: .word scn09-5b # letter p ! 22538: .word scn09-5b # letter q ! 22539: .word scn09-5b # letter r ! 22540: .word scn21-5b # letter s ! 22541: .word scn09-5b # letter t ! 22542: .word scn09-5b # letter u ! 22543: .word scn09-5b # letter v ! 22544: .word scn09-5b # letter w ! 22545: .word scn09-5b # letter x ! 22546: .word scn09-5b # letter y ! 22547: .word scn09-5b # letter z ! 22548: .word scn28-5b # left bracket ! 22549: .word scn07-5b ! 22550: .word scn27-5b # right bracket ! 22551: .word scn07-5b ! 22552: .word scn24-5b # underline ! 22553: .word scn07-5b ! 22554: .word scn09-5b # shifted a ! 22555: .word scn09-5b # shifted b ! 22556: .word scn09-5b # shifted c ! 22557: .word scn09-5b # shifted d ! 22558: .word scn09-5b # shifted e ! 22559: .word scn20-5b # shifted f ! 22560: .word scn09-5b # shifted g ! 22561: .word scn09-5b # shifted h ! 22562: .word scn09-5b # shifted i ! 22563: .word scn09-5b # shifted j ! 22564: .word scn09-5b # shifted k ! 22565: .word scn09-5b # shifted l ! 22566: .word scn09-5b # shifted m ! 22567: .word scn09-5b # shifted n ! 22568: .word scn09-5b # shifted o ! 22569: .word scn09-5b # shifted p ! 22570: .word scn09-5b # shifted q ! 22571: .word scn09-5b # shifted r ! 22572: .word scn21-5b # shifted s ! 22573: .word scn09-5b # shifted t ! 22574: .word scn09-5b # shifted u ! 22575: .word scn09-5b # shifted v ! 22576: .word scn09-5b # shifted w ! 22577: .word scn09-5b # shifted x ! 22578: .word scn09-5b # shifted y ! 22579: .word scn09-5b # shifted z ! 22580: .word scn07-5b ! 22581: .word scn43-5b # vertical bar ! 22582: .word scn07-5b ! 22583: .word scn35-5b # not ! 22584: .word scn07-5b ! 22585: #esw # end switch on character ! 22586: # ! 22587: # HERE FOR ILLEGAL CHARACTER (UNDERLINE MERGES) ! 22588: # ! 22589: scn07: tstl r7 # jump if scanning name or constant ! 22590: bnequ 0f ! 22591: jmp scn10 ! 22592: 0: ! 22593: jmp er_230 # syntax error. illegal character ! 22594: #page ! 22595: # ! 22596: # SCANE (CONTINUED) ! 22597: # ! 22598: # HERE FOR DIGITS 0-9 ! 22599: # ! 22600: scn08: tstl r7 # keep scanning if name/constant ! 22601: bnequ 0f ! 22602: jmp scn09 ! 22603: 0: ! 22604: clrl r8 # else set flag for scanning constant ! 22605: # ! 22606: # HERE FOR LETTER. LOOP HERE WHEN SCANNING NAME/CONSTANT ! 22607: # ! 22608: scn09: cmpl r6,scnil # jump if end of image ! 22609: beqlu scn11 ! 22610: clrl r7 # set flag for scanning name/const ! 22611: jmp scn06 # merge back to continue scan ! 22612: # ! 22613: # COME HERE FOR DELIMITER ENDING NAME OR CONSTANT ! 22614: # ! 22615: scn10: decl r6 # reset offset to point to delimiter ! 22616: # ! 22617: # COME HERE AFTER FINISHING SCAN OF NAME OR CONSTANT ! 22618: # ! 22619: scn11: movl r6,scnpt # store updated scan offset ! 22620: movl scnse,r7 # point to start of element ! 22621: subl2 r7,r6 # get number of characters ! 22622: movl r$cim,r10 # point to line image ! 22623: tstl r8 # jump if name ! 22624: bnequ scn15 ! 22625: # ! 22626: # HERE AFTER SCANNING OUT NUMERIC CONSTANT ! 22627: # ! 22628: jsb sbstr # get string for constant ! 22629: movl r9,dnamp # delete from storage (not needed) ! 22630: jsb gtnum # convert to numeric ! 22631: .long scn14 # jump if conversion failure ! 22632: # ! 22633: # MERGE HERE TO EXIT WITH CONSTANT ! 22634: # ! 22635: scn12: movl $t$con,r10 # set result type of constant ! 22636: #page ! 22637: # ! 22638: # SCANE (CONTINUED) ! 22639: # ! 22640: # COMMON EXIT POINT (XR,XL) SET ! 22641: # ! 22642: scn13: movl scnsa,r6 # restore wa ! 22643: movl scnsb,r7 # restore wb ! 22644: movl scnsc,r8 # restore wc ! 22645: movl r9,r$scp # save xr in case rescan ! 22646: movl r10,scntp # save xl in case rescan ! 22647: clrl scngo # reset possible goto flag ! 22648: rsb # return to scane caller ! 22649: # ! 22650: # HERE IF CONVERSION ERROR ON NUMERIC ITEM ! 22651: # ! 22652: scn14: jmp er_231 # syntax error. invalid numeric item ! 22653: # ! 22654: # HERE AFTER SCANNING OUT VARIABLE NAME ! 22655: # ! 22656: scn15: jsb sbstr # build string name of variable ! 22657: tstl scncc # return if cncrd call ! 22658: beqlu 0f ! 22659: jmp scn13 ! 22660: 0: ! 22661: jsb gtnvr # locate/build vrblk ! 22662: .long invalid$ # dummy (unused) error return ! 22663: movl $t$var,r10 # set type as variable ! 22664: jmp scn13 # back to exit ! 22665: # ! 22666: # HERE FOR SINGLE QUOTE (START OF STRING CONSTANT) ! 22667: # ! 22668: scn16: tstl r7 # terminator if scanning name or cnst ! 22669: bnequ 0f ! 22670: jmp scn10 ! 22671: 0: ! 22672: movl $ch$sq,r7 # set terminator as single quote ! 22673: jmp scn18 # merge ! 22674: # ! 22675: # HERE FOR DOUBLE QUOTE (START OF STRING CONSTANT) ! 22676: # ! 22677: scn17: tstl r7 # terminator if scanning name or cnst ! 22678: bnequ 0f ! 22679: jmp scn10 ! 22680: 0: ! 22681: movl $ch$dq,r7 # set double quote terminator, merge ! 22682: # ! 22683: # LOOP TO SCAN OUT STRING CONSTANT ! 22684: # ! 22685: scn18: cmpl r6,scnil # error if end of image ! 22686: beqlu scn19 ! 22687: movzbl (r10)+,r8 # else load next character ! 22688: incl r6 # bump offset ! 22689: cmpl r8,r7 # loop back if not terminator ! 22690: bnequ scn18 ! 22691: #page ! 22692: # ! 22693: # SCANE (CONTINUED) ! 22694: # ! 22695: # HERE AFTER SCANNING OUT STRING CONSTANT ! 22696: # ! 22697: movl scnpt,r7 # point to first character ! 22698: movl r6,scnpt # save offset past final quote ! 22699: decl r6 # point back past last character ! 22700: subl2 r7,r6 # get number of characters ! 22701: movl r$cim,r10 # point to input image ! 22702: jsb sbstr # build substring value ! 22703: jmp scn12 # back to exit with constant result ! 22704: # ! 22705: # HERE IF NO MATCHING QUOTE FOUND ! 22706: # ! 22707: scn19: movl r6,scnpt # set updated scan pointer ! 22708: jmp er_232 # syntax error. unmatched string quote ! 22709: # ! 22710: # HERE FOR F (POSSIBLE FAILURE GOTO) ! 22711: # ! 22712: scn20: movl $t$fgo,r9 # set return code for fail goto ! 22713: jmp scn22 # jump to merge ! 22714: # ! 22715: # HERE FOR S (POSSIBLE SUCCESS GOTO) ! 22716: # ! 22717: scn21: movl $t$sgo,r9 # set success goto as return code ! 22718: # ! 22719: # SPECIAL GOTO CASES MERGE HERE ! 22720: # ! 22721: scn22: tstl scngo # treat as normal letter if not goto ! 22722: bnequ 0f ! 22723: jmp scn09 ! 22724: 0: ! 22725: # ! 22726: # MERGE HERE FOR SPECIAL CHARACTER EXIT ! 22727: # ! 22728: scn23: tstl r7 # jump if end of name/constant ! 22729: bnequ 0f ! 22730: jmp scn10 ! 22731: 0: ! 22732: movl r9,r10 # else copy code ! 22733: jmp scn13 # and jump to exit ! 22734: # ! 22735: # HERE FOR UNDERLINE ! 22736: # ! 22737: scn24: tstl r7 # part of name if scanning name ! 22738: bnequ 0f ! 22739: jmp scn09 ! 22740: 0: ! 22741: jmp scn07 # else illegal ! 22742: #page ! 22743: # ! 22744: # SCANE (CONTINUED) ! 22745: # ! 22746: # HERE FOR LEFT PAREN ! 22747: # ! 22748: scn25: movl $t$lpr,r9 # set left paren return code ! 22749: tstl r7 # return left paren unless name ! 22750: bnequ scn23 ! 22751: tstl r8 # delimiter if scanning constant ! 22752: bnequ 0f ! 22753: jmp scn10 ! 22754: 0: ! 22755: # ! 22756: # HERE FOR LEFT PAREN AFTER NAME (FUNCTION CALL) ! 22757: # ! 22758: movl scnse,r7 # point to start of name ! 22759: movl r6,scnpt # set pointer past left paren ! 22760: decl r6 # point back past last char of name ! 22761: subl2 r7,r6 # get name length ! 22762: movl r$cim,r10 # point to input image ! 22763: jsb sbstr # get string name for function ! 22764: jsb gtnvr # locate/build vrblk ! 22765: .long invalid$ # dummy (unused) error return ! 22766: movl $t$fnc,r10 # set code for function call ! 22767: jmp scn13 # back to exit ! 22768: # ! 22769: # PROCESSING FOR SPECIAL CHARACTERS ! 22770: # ! 22771: scn26: movl $t$rpr,r9 # right paren, set code ! 22772: jmp scn23 # take special character exit ! 22773: # ! 22774: scn27: movl $t$rbr,r9 # right bracket, set code ! 22775: jmp scn23 # take special character exit ! 22776: # ! 22777: scn28: movl $t$lbr,r9 # left bracket, set code ! 22778: jmp scn23 # take special character exit ! 22779: # ! 22780: scn29: movl $t$col,r9 # colon, set code ! 22781: jmp scn23 # take special character exit ! 22782: # ! 22783: scn30: movl $t$smc,r9 # semi-colon, set code ! 22784: jmp scn23 # take special character exit ! 22785: # ! 22786: scn31: movl $t$cma,r9 # comma, set code ! 22787: jmp scn23 # take special character exit ! 22788: #page ! 22789: # ! 22790: # SCANE (CONTINUED) ! 22791: # ! 22792: # HERE FOR OPERATORS. ON ENTRY, WC POINTS TO THE TABLE OF ! 22793: # OPERATOR DOPE VECTORS AND WB IS THE INCREMENT TO STEP ! 22794: # TO THE NEXT PAIR (BINARY/UNARY) OF DOPE VECTORS IN THE ! 22795: # LIST. ON REACHING SCN46, THE POINTER HAS BEEN ADJUSTED TO ! 22796: # POINT TO THE APPROPRIATE PAIR OF DOPE VECTORS. ! 22797: # THE FIRST THREE ENTRIES ARE SPECIAL SINCE THEY CAN OCCUR ! 22798: # AS PART OF A VARIABLE NAME (.) OR CONSTANT (.+-). ! 22799: # ! 22800: scn32: tstl r7 # dot can be part of name or constant ! 22801: bnequ 0f ! 22802: jmp scn09 ! 22803: 0: ! 22804: addl2 r7,r8 # else bump pointer ! 22805: # ! 22806: scn33: tstl r8 # plus can be part of constant ! 22807: bnequ 0f ! 22808: jmp scn09 ! 22809: 0: ! 22810: tstl r7 # plus cannot be part of name ! 22811: bnequ 0f ! 22812: jmp scn48 ! 22813: 0: ! 22814: addl2 r7,r8 # else bump pointer ! 22815: # ! 22816: scn34: tstl r8 # minus can be part of constant ! 22817: bnequ 0f ! 22818: jmp scn09 ! 22819: 0: ! 22820: tstl r7 # minus cannot be part of name ! 22821: bnequ 0f ! 22822: jmp scn48 ! 22823: 0: ! 22824: addl2 r7,r8 # else bump pointer ! 22825: # ! 22826: scn35: addl2 r7,r8 # not ! 22827: scn36: addl2 r7,r8 # dollar ! 22828: scn37: addl2 r7,r8 # exclamation ! 22829: scn38: addl2 r7,r8 # percent ! 22830: scn39: addl2 r7,r8 # asterisk ! 22831: scn40: addl2 r7,r8 # slash ! 22832: scn41: addl2 r7,r8 # number sign ! 22833: scn42: addl2 r7,r8 # at sign ! 22834: scn43: addl2 r7,r8 # vertical bar ! 22835: scn44: addl2 r7,r8 # ampersand ! 22836: scn45: addl2 r7,r8 # question mark ! 22837: # ! 22838: # ALL OPERATORS COME HERE (EQUAL MERGES DIRECTLY) ! 22839: # (WC) POINTS TO THE BINARY/UNARY PAIR OF OPERATOR DVBLKS. ! 22840: # ! 22841: scn46: tstl r7 # operator terminates name/constant ! 22842: bnequ 0f ! 22843: jmp scn10 ! 22844: 0: ! 22845: movl r8,r9 # else copy dv pointer ! 22846: movzbl (r10),r8 # load next character ! 22847: movl $t$bop,r10 # set binary op in case ! 22848: cmpl r6,scnil # should be binary if image end ! 22849: beqlu scn47 ! 22850: cmpl r8,$ch$bl # should be binary if followed by blk ! 22851: beqlu scn47 ! 22852: cmpl r8,$ch$ht # jump if horizontal tab ! 22853: beqlu scn47 ! 22854: cmpl r8,$ch$sm # semicolon can immediately follow = ! 22855: beqlu scn47 ! 22856: # ! 22857: # HERE FOR UNARY OPERATOR ! 22858: # ! 22859: addl2 $4*dvbs$,r9 # point to dv for unary op ! 22860: movl $t$uop,r10 # set type for unary operator ! 22861: cmpl scntp,$t$uok # ok unary if ok preceding element ! 22862: bgtru 0f ! 22863: jmp scn13 ! 22864: 0: ! 22865: #page ! 22866: # ! 22867: # SCANE (CONTINUED) ! 22868: # ! 22869: # MERGE HERE TO REQUIRE PRECEDING BLANKS ! 22870: # ! 22871: scn47: tstl scnbl # all ok if preceding blanks, exit ! 22872: beqlu 0f ! 22873: jmp scn13 ! 22874: 0: ! 22875: # ! 22876: # FAIL OPERATOR IN THIS POSITION ! 22877: # ! 22878: scn48: jmp er_233 # syntax error. invalid use of operator ! 22879: # ! 22880: # HERE FOR ASTERISK, COULD BE ** SUBSTITUTE FOR EXCLAMATION ! 22881: # ! 22882: scn49: tstl r7 # end of name if scanning name ! 22883: bnequ 0f ! 22884: jmp scn10 ! 22885: 0: ! 22886: cmpl r6,scnil # not ** if * at image end ! 22887: beqlu scn39 ! 22888: movl r6,r9 # else save offset past first * ! 22889: movl r6,scnof # save another copy ! 22890: movzbl (r10)+,r6 # load next character ! 22891: cmpl r6,$ch$as # not ** if next char not * ! 22892: bnequ scn50 ! 22893: incl r9 # else step offset past second * ! 22894: cmpl r9,scnil # ok exclam if end of image ! 22895: beqlu scn51 ! 22896: movzbl (r10),r6 # else load next character ! 22897: cmpl r6,$ch$bl # exclamation if blank ! 22898: beqlu scn51 ! 22899: cmpl r6,$ch$ht # exclamation if horizontal tab ! 22900: beqlu scn51 ! 22901: # ! 22902: # UNARY * ! 22903: # ! 22904: scn50: movl scnof,r6 # recover stored offset ! 22905: movl r$cim,r10 # point to line again ! 22906: movab cfp$f(r10)[r6],r10 # point to current char ! 22907: jmp scn39 # merge with unary * ! 22908: # ! 22909: # HERE FOR ** AS SUBSTITUTE FOR EXCLAMATION ! 22910: # ! 22911: scn51: movl r9,scnpt # save scan pointer past 2nd * ! 22912: movl r9,r6 # copy scan pointer ! 22913: jmp scn37 # merge with exclamation ! 22914: #enp # end procedure scane ! 22915: #page ! 22916: # ! 22917: # SCNGF -- SCAN GOTO FIELD ! 22918: # ! 22919: # SCNGF IS CALLED FROM CMPIL TO SCAN AND ANALYZE A GOTO ! 22920: # FIELD INCLUDING THE SURROUNDING BRACKETS OR PARENTHESES. ! 22921: # FOR A NORMAL GOTO, THE RESULT RETURNED IS EITHER A VRBLK ! 22922: # POINTER FOR A SIMPLE LABEL OPERAND, OR A POINTER TO AN ! 22923: # EXPRESSION TREE WITH A SPECIAL OUTER UNARY OPERATOR ! 22924: # (O$GOC). FOR A DIRECT GOTO, THE RESULT RETURNED IS A ! 22925: # POINTER TO AN EXPRESSION TREE WITH THE SPECIAL OUTER ! 22926: # UNARY OPERATOR O$GOD. ! 22927: # ! 22928: # JSR SCNGF CALL TO SCAN GOTO FIELD ! 22929: # (XR) RESULT (SEE ABOVE) ! 22930: # (XL,WA,WB,WC) DESTROYED ! 22931: # ! 22932: scngf: #prc # entry point ! 22933: jsb scane # scan initial element ! 22934: cmpl r10,$t$lpr # skip if left paren (normal goto) ! 22935: beqlu scng1 ! 22936: cmpl r10,$t$lbr # skip if left bracket (direct goto) ! 22937: beqlu scng2 ! 22938: jmp er_234 # syntax error. goto field incorrect ! 22939: # ! 22940: # HERE FOR LEFT PAREN (NORMAL GOTO) ! 22941: # ! 22942: scng1: movl $num01,r7 # set expan flag for normal goto ! 22943: jsb expan # analyze goto field ! 22944: movl $opdvn,r6 # point to opdv for complex goto ! 22945: cmpl r9,statb # jump if not in static (sgd15) ! 22946: blequ scng3 ! 22947: cmpl r9,state # jump to exit if simple label name ! 22948: blequ scng4 ! 22949: jmp scng3 # complex goto - merge ! 22950: # ! 22951: # HERE FOR LEFT BRACKET (DIRECT GOTO) ! 22952: # ! 22953: scng2: movl $num02,r7 # set expan flag for direct goto ! 22954: jsb expan # scan goto field ! 22955: movl $opdvd,r6 # set opdv pointer for direct goto ! 22956: #page ! 22957: # ! 22958: # SCNGF (CONTINUED) ! 22959: # ! 22960: # MERGE HERE TO BUILD OUTER UNARY OPERATOR BLOCK ! 22961: # ! 22962: scng3: movl r6,-(sp) # stack operator dv pointer ! 22963: movl r9,-(sp) # stack pointer to expression tree ! 22964: jsb expop # pop operator off ! 22965: movl (sp)+,r9 # reload new expression tree pointer ! 22966: # ! 22967: # COMMON EXIT POINT ! 22968: # ! 22969: scng4: rsb # return to caller ! 22970: #enp # end procedure scngf ! 22971: #page ! 22972: # ! 22973: # SETVR -- SET VRGET,VRSTO FIELDS OF VRBLK ! 22974: # ! 22975: # SETVR SETS THE PROPER VALUES IN THE VRGET AND VRSTO ! 22976: # FIELDS OF A VRBLK. IT IS CALLED WHENEVER TRBLKS ARE ! 22977: # ADDED OR SUBTRACTED (TRACE,STOPTR,INPUT,OUTPUT,DETACH) ! 22978: # ! 22979: # (XR) POINTER TO VRBLK ! 22980: # JSR SETVR CALL TO SET FIELDS ! 22981: # (XL,WA) DESTROYED ! 22982: # ! 22983: # NOTE THAT SETVR IGNORES THE CALL IF XR DOES NOT POINT ! 22984: # INTO THE STATIC REGION (I.E. IS SOME OTHER NAME BASE) ! 22985: # ! 22986: setvr: #prc # entry point ! 22987: cmpl r9,state # exit if not natural variable ! 22988: bgequ setv1 ! 22989: # ! 22990: # HERE IF WE HAVE A VRBLK ! 22991: # ! 22992: movl r9,r10 # copy vrblk pointer ! 22993: movl $b$vrl,4*vrget(r9) # store normal get value ! 22994: cmpl 4*vrsto(r9),$b$vre # skip if protected variable ! 22995: beqlu setv1 ! 22996: movl $b$vrs,4*vrsto(r9) # store normal store value ! 22997: movl 4*vrval(r10),r10# point to next entry on chain ! 22998: cmpl (r10),$b$trt # jump if end of trblk chain ! 22999: bnequ setv1 ! 23000: movl $b$vra,4*vrget(r9) # store trapped routine address ! 23001: movl $b$vrv,4*vrsto(r9) # set trapped routine address ! 23002: # ! 23003: # MERGE HERE TO EXIT TO CALLER ! 23004: # ! 23005: setv1: rsb # return to setvr caller ! 23006: #enp # end procedure setvr ! 23007: #page ! 23008: # ! 23009: # SORTA -- SORT ARRAY ! 23010: # ! 23011: # ROUTINE TO SORT AN ARRAY OR TABLE ON SAME BASIS AS IN ! 23012: # SITBOL. A TABLE IS CONVERTED TO AN ARRAY, LEAVING TWO ! 23013: # DIMENSIONAL ARRAYS AND VECTORS AS CASES TO BE CONSIDERED. ! 23014: # WHOLE ROWS OF ARRAYS ARE PERMUTED ACCORDING TO THE ! 23015: # ORDERING OF THE KEYS THEY CONTAIN, AND THE STRIDE ! 23016: # REFERRED TO, IS THE THE LENGTH OF A ROW. IT IS ONE ! 23017: # FOR A VECTOR. ! 23018: # THE SORT USED IS HEAPSORT, FUNDAMENTALS OF DATA STRUCTURE ! 23019: # HOROWITZ AND SAHNI, PITMAN 1977, PAGE 347. ! 23020: # IT IS AN ORDER N*LOG(N) ALGORITHM. IN ORDER ! 23021: # TO MAKE IT STABLE, COMPARANDS MAY NOT COMPARE EQUAL. THIS ! 23022: # IS ACHIEVED BY SORTING A COPY ARRAY (REFERRED TO AS THE ! 23023: # SORT ARRAY) CONTAINING AT ITS HIGH ADDRESS END, BYTE ! 23024: # OFFSETS TO THE ROWS TO BE SORTED HELD IN THE ORIGINAL ! 23025: # ARRAY (REFERRED TO AS THE KEY ARRAY). SORTC, THE ! 23026: # COMPARISON ROUTINE, ACCESSES THE KEYS THROUGH THESE ! 23027: # OFFSETS AND IN THE CASE OF EQUALITY, RESOLVES IT BY ! 23028: # COMPARING THE OFFSETS THEMSELVES. THE SORT PERMUTES THE ! 23029: # OFFSETS WHICH ARE THEN USED IN A FINAL OPERATION TO COPY ! 23030: # THE ACTUAL ITEMS INTO THE NEW ARRAY IN SORTED ORDER. ! 23031: # REFERENCES TO ZEROTH ITEM ARE TO NOTIONAL ITEM ! 23032: # PRECEDING FIRST ACTUAL ITEM. ! 23033: # REVERSE SORTING FOR RSORT IS DONE BY HAVING THE LESS THAN ! 23034: # TEST FOR KEYS EFFECTIVELY BE REPLACED BY A ! 23035: # GREATER THAN TEST. ! 23036: # ! 23037: # 1(XS) FIRST ARG - ARRAY OR TABLE ! 23038: # 0(XS) 2ND ARG - INDEX OR PDTYPE NAME ! 23039: # (WA) 0 , NON-ZERO FOR SORT , RSORT ! 23040: # JSR SORTA CALL TO SORT ARRAY ! 23041: # (XR) SORTED ARRAY ! 23042: # (XL,WA,WB,WC) DESTROYED ! 23043: #page ! 23044: # ! 23045: # SORTA (CONTINUED) ! 23046: # ! 23047: .data 1 ! 23048: sorta_s: .long 0 ! 23049: .text 0 ! 23050: sorta: movl (sp)+,sorta_s # entry point ! 23051: movl r6,srtsr # sort/rsort indicator ! 23052: movl $4*num01,srtst # default stride of 1 ! 23053: clrl srtof # default zero offset to sort key ! 23054: movl $nulls,srtdf # clear datatype field name ! 23055: movl (sp)+,r$sxr # unstack argument 2 ! 23056: movl (sp)+,r9 # get first argument ! 23057: jsb gtarr # convert to array ! 23058: .long srt16 # fail ! 23059: movl r9,-(sp) # stack ptr to resulting key array ! 23060: movl r9,-(sp) # another copy for copyb ! 23061: jsb copyb # get copy array for sorting into ! 23062: .long invalid$ # cant fail ! 23063: movl r9,-(sp) # stack pointer to sort array ! 23064: movl r$sxr,r9 # get second arg ! 23065: movl 4*1(sp),r10 # get ptr to key array ! 23066: cmpl (r10),$b$vct # jump if arblk ! 23067: bnequ srt02 ! 23068: cmpl r9,$nulls # jump if null second arg ! 23069: beqlu srt01 ! 23070: jsb gtnvr # get vrblk ptr for it ! 23071: .long er_257 # erroneous 2nd arg in sort/rsort of vector ! 23072: movl r9,srtdf # store datatype field name vrblk ! 23073: # ! 23074: # COMPUTE N AND OFFSET TO ITEM A(0) IN VECTOR CASE ! 23075: # ! 23076: srt01: movl $4*vclen,r8 # offset to a(0) ! 23077: movl $4*vcvls,r7 # offset to first item ! 23078: movl 4*vclen(r10),r6 # get block length ! 23079: subl2 $4*vcsi$,r6 # get no. of entries, n (in bytes) ! 23080: jmp srt04 # merge ! 23081: # ! 23082: # HERE FOR ARRAY ! 23083: # ! 23084: srt02: movl 4*ardim(r10),r5 # get possible dimension ! 23085: movl r5,r6 # convert to short integer ! 23086: moval 0[r6],r6 # further convert to baus ! 23087: movl $4*arvls,r7 # offset to first value if one ! 23088: movl $4*arpro,r8 # offset before values if one dim. ! 23089: cmpl 4*arndm(r10),$num01 # jump in fact if one dim. ! 23090: bnequ 0f ! 23091: jmp srt04 ! 23092: 0: ! 23093: cmpl 4*arndm(r10),$num02 # fail unless two dimens ! 23094: beqlu 0f ! 23095: jmp srt16 ! 23096: 0: ! 23097: movl 4*arlb2(r10),r5 # get lower bound 2 as default ! 23098: cmpl r9,$nulls # jump if default second arg ! 23099: beqlu srt03 ! 23100: jsb gtint # convert to integer ! 23101: .long srt17 # fail ! 23102: movl 4*icval(r9),r5 # get actual integer value ! 23103: #page ! 23104: # ! 23105: # SORTA (CONTINUED) ! 23106: # ! 23107: # HERE WITH SORT COLUMN INDEX IN IA IN ARRAY CASE ! 23108: # ! 23109: srt03: subl2 4*arlb2(r10),r5 # subtract low bound ! 23110: bvc 0f ! 23111: jmp srt17 ! 23112: 0: ! 23113: tstl r5 # fail if below low bound ! 23114: bgeq 0f ! 23115: jmp srt17 ! 23116: 0: ! 23117: subl2 4*ardm2(r10),r5 # check against dimension ! 23118: tstl r5 # fail if too large ! 23119: blss 0f ! 23120: jmp srt17 ! 23121: 0: ! 23122: addl2 4*ardm2(r10),r5 # restore value ! 23123: movl r5,r6 # get as small integer ! 23124: moval 0[r6],r6 # offset within row to key ! 23125: movl r6,srtof # keep offset ! 23126: movl 4*ardm2(r10),r5 # second dimension is row length ! 23127: movl r5,r6 # convert to short integer ! 23128: movl r6,r9 # copy row length ! 23129: moval 0[r6],r6 # convert to bytes ! 23130: movl r6,srtst # store as stride ! 23131: movl 4*ardim(r10),r5 # get number of rows ! 23132: movl r5,r6 # as a short integer ! 23133: moval 0[r6],r6 # convert n to baus ! 23134: movl 4*arlen(r10),r8 # offset past array end ! 23135: subl2 r6,r8 # adjust, giving space for n offsets ! 23136: subl2 $4,r8 # point to a(0) ! 23137: movl 4*arofs(r10),r7 # offset to word before first item ! 23138: addl2 $4,r7 # offset to first item ! 23139: # ! 23140: # SEPARATE PRE-PROCESSING FOR ARRAYS AND VECTORS DONE. ! 23141: # TO SIMPLIFY LATER KEY COMPARISONS, REMOVAL OF ANY TRBLK ! 23142: # TRAP BLOCKS FROM ENTRIES IN KEY ARRAY IS EFFECTED. ! 23143: # ! 23144: # (XL) = 1(XS) = POINTER TO KEY ARRAY ! 23145: # (XS) = POINTER TO SORT ARRAY ! 23146: # WA = NUMBER OF ITEMS, N (CONVERTED TO BYTES). ! 23147: # WB = OFFSET TO FIRST ITEM OF ARRAYS. ! 23148: # WC = OFFSET TO A(0) ! 23149: # ! 23150: srt04: cmpl r6,$4*num01 # return if only a single item ! 23151: bgtru 0f ! 23152: jmp srt15 ! 23153: 0: ! 23154: movl r6,srtsn # store number of items (in baus) ! 23155: movl r8,srtso # store offset to a(0) ! 23156: movl 4*arlen(r10),r8 # length of array or vec (=vclen) ! 23157: addl2 r10,r8 # point past end of array or vector ! 23158: movl r7,srtsf # store offset to first row ! 23159: addl2 r7,r10 # point to first item in key array ! 23160: # ! 23161: # LOOP THROUGH ARRAY ! 23162: # ! 23163: srt05: movl (r10),r9 # get an entry ! 23164: # ! 23165: # HUNT ALONG TRBLK CHAIN ! 23166: # ! 23167: srt06: cmpl (r9),$b$trt # jump out if not trblk ! 23168: bnequ srt07 ! 23169: movl 4*trval(r9),r9 # get value field ! 23170: jmp srt06 # loop ! 23171: #page ! 23172: # ! 23173: # SORTA (CONTINUED) ! 23174: # ! 23175: # XR IS VALUE FROM END OF CHAIN ! 23176: # ! 23177: srt07: movl r9,(r10)+ # store as array entry ! 23178: cmpl r10,r8 # loop if not done ! 23179: blssu srt05 ! 23180: movl (sp),r10 # get adrs of sort array ! 23181: movl srtsf,r9 # initial offset to first key ! 23182: movl srtst,r7 # get stride ! 23183: addl2 srtso,r10 # offset to a(0) ! 23184: addl2 $4,r10 # point to a(1) ! 23185: movl srtsn,r8 # get n ! 23186: ashl $-2,r8,r8 # convert from bytes ! 23187: movl r8,srtnr # store as row count ! 23188: # loop counter ! 23189: # ! 23190: # STORE KEY OFFSETS AT TOP OF SORT ARRAY ! 23191: # ! 23192: srt08: movl r9,(r10)+ # store an offset ! 23193: addl2 r7,r9 # bump offset by stride ! 23194: sobgtr r8,srt08 # loop through rows ! 23195: # ! 23196: # PERFORM THE SORT ON OFFSETS IN SORT ARRAY. ! 23197: # ! 23198: # (SRTSN) NUMBER OF ITEMS TO SORT, N (BYTES) ! 23199: # (SRTSO) OFFSET TO A(0) ! 23200: # ! 23201: srt09: movl srtsn,r6 # get n ! 23202: movl srtnr,r8 # get number of rows ! 23203: ashl $-1,r8,r8 # i = n / 2 (wc=i, index into array) ! 23204: moval 0[r8],r8 # convert back to bytes ! 23205: # ! 23206: # LOOP TO FORM INITIAL HEAP ! 23207: # ! 23208: srt10: jsb sorth # sorth(i,n) ! 23209: subl2 $4,r8 # i = i - 1 ! 23210: tstl r8 # loop if i gt 0 ! 23211: bnequ srt10 ! 23212: movl r6,r8 # i = n ! 23213: # ! 23214: # SORTING LOOP. AT THIS POINT, A(1) IS THE LARGEST ! 23215: # ITEM, SINCE ALGORITHM INITIALISES IT AS, AND THEN MAINTAI ! 23216: # IT AS, ROOT OF TREE. ! 23217: # ! 23218: srt11: subl2 $4,r8 # i = i - 1 (n - 1 initially) ! 23219: tstl r8 # jump if done ! 23220: beqlu srt12 ! 23221: movl (sp),r9 # get sort array address ! 23222: addl2 srtso,r9 # point to a(0) ! 23223: movl r9,r10 # a(0) address ! 23224: addl2 r8,r10 # a(i) address ! 23225: movl 4*1(r10),r7 # copy a(i+1) ! 23226: movl 4*1(r9),4*1(r10)# move a(1) to a(i+1) ! 23227: movl r7,4*1(r9) # complete exchange of a(1), a(i+1) ! 23228: movl r8,r6 # n = i for sorth ! 23229: movl $4*num01,r8 # i = 1 for sorth ! 23230: jsb sorth # sorth(1,n) ! 23231: movl r6,r8 # restore wc ! 23232: jmp srt11 # loop ! 23233: #page ! 23234: # ! 23235: # SORTA (CONTINUED) ! 23236: # ! 23237: # OFFSETS HAVE BEEN PERMUTED INTO REQUIRED ORDER BY SORT. ! 23238: # COPY ARRAY ELEMENTS OVER THEM. ! 23239: # ! 23240: srt12: movl (sp),r10 # base adrs of key array ! 23241: movl r10,r8 # copy it ! 23242: addl2 srtso,r8 # offset of a(0) ! 23243: addl2 srtsf,r10 # adrs of first row of sort array ! 23244: movl srtst,r7 # get stride ! 23245: ashl $-2,r7,r7 # convert to words ! 23246: # ! 23247: # COPYING LOOP FOR SUCCESSIVE ITEMS. SORTED OFFSETS ARE ! 23248: # HELD AT END OF SORT ARRAY. ! 23249: # ! 23250: srt13: addl2 $4,r8 # adrs of next of sorted offsets ! 23251: movl r8,r9 # copy it for access ! 23252: movl (r9),r9 # get offset ! 23253: addl2 4*1(sp),r9 # add key array base adrs ! 23254: movl r7,r6 # get count of words in row ! 23255: # ! 23256: # COPY A COMPLETE ROW ! 23257: # ! 23258: srt14: movl (r9)+,(r10)+ # move a word ! 23259: sobgtr r6,srt14 # loop ! 23260: decl srtnr # decrement row count ! 23261: tstl srtnr # repeat till all rows done ! 23262: bnequ srt13 ! 23263: # ! 23264: # RETURN POINT ! 23265: # ! 23266: srt15: movl (sp)+,r9 # pop result array ptr ! 23267: addl2 $4,sp # pop key array ptr ! 23268: clrl r$sxl # clear junk ! 23269: clrl r$sxr # clear junk ! 23270: jmp *sorta_s # return ! 23271: # ! 23272: # ERROR POINT ! 23273: # ! 23274: srt16: jmp er_256 # sort/rsort 1st arg not suitable array or table ! 23275: srt17: jmp er_258 # sort/rsort 2nd arg out of range or non-integer ! 23276: #enp # end procudure sorta ! 23277: #page ! 23278: # ! 23279: # SORTC -- COMPARE SORT KEYS ! 23280: # ! 23281: # COMPARE TWO SORT KEYS GIVEN THEIR OFFSETS. IF ! 23282: # EQUAL, COMPARE KEY OFFSETS TO GIVE STABLE SORT. ! 23283: # NOTE THAT IF SRTSR IS NON-ZERO (REQUEST FOR REVERSE ! 23284: # SORT), THE QUOTED RETURNS ARE INVERTED. ! 23285: # FOR OBJECTS OF DIFFERING DATATYPES, THE ENTRY POINT ! 23286: # IDENTIFICATIONS ARE COMPARED. ! 23287: # ! 23288: # (XL) BASE ADRS FOR KEYS ! 23289: # (WA) OFFSET TO KEY 1 ITEM ! 23290: # (WB) OFFSET TO KEY 2 ITEM ! 23291: # (SRTSR) ZERO/NON-ZERO FOR SORT/RSORT ! 23292: # (SRTOF) OFFSET WITHIN ROW TO COMPARANDS ! 23293: # JSR SORTC CALL TO COMPARE KEYS ! 23294: # PPM LOC KEY1 LESS THAN KEY2 ! 23295: # NORMAL RETURN, KEY1 GT THAN KEY2 ! 23296: # (XL,XR,WA,WB) DESTROYED ! 23297: # ! 23298: sortc: #prc # entry point ! 23299: movl r6,srts1 # save offset 1 ! 23300: movl r7,srts2 # save offset 2 ! 23301: movl r8,srtsc # save wc ! 23302: addl2 srtof,r10 # add offset to comparand field ! 23303: movl r10,r9 # copy base + offset ! 23304: addl2 r6,r10 # add key1 offset ! 23305: addl2 r7,r9 # add key2 offset ! 23306: movl (r10),r10 # get key1 ! 23307: movl (r9),r9 # get key2 ! 23308: cmpl srtdf,$nulls # jump if datatype field name used ! 23309: beqlu 0f ! 23310: jmp src11 ! 23311: 0: ! 23312: #page ! 23313: # ! 23314: # SORTC (CONTINUED) ! 23315: # ! 23316: # MERGE AFTER DEALING WITH FIELD NAME. TRY FOR STRINGS. ! 23317: # ! 23318: src01: movl (r10),r8 # get type code ! 23319: cmpl r8,(r9) # skip if not same datatype ! 23320: bnequ src02 ! 23321: cmpl r8,$b$scl # jump if both strings ! 23322: beqlu src09 ! 23323: # ! 23324: # NOW TRY FOR NUMERIC ! 23325: # ! 23326: src02: movl r10,r$sxl # keep arg1 ! 23327: movl r9,r$sxr # keep arg2 ! 23328: movl r10,-(sp) # stack ! 23329: movl r9,-(sp) # args ! 23330: jsb acomp # compare objects ! 23331: .long src10 # not numeric ! 23332: .long src10 # not numeric ! 23333: .long src03 # key1 less ! 23334: .long src08 # keys equal ! 23335: .long src05 # key1 greater ! 23336: # ! 23337: # RETURN IF KEY1 SMALLER (SORT), GREATER (RSORT) ! 23338: # ! 23339: src03: tstl srtsr # jump if rsort ! 23340: bnequ src06 ! 23341: # ! 23342: src04: movl srtsc,r8 # restore wc ! 23343: movl (sp)+,r11 # return ! 23344: jmp *(r11)+ ! 23345: # ! 23346: # RETURN IF KEY1 GREATER (SORT), SMALLER (RSORT) ! 23347: # ! 23348: src05: tstl srtsr # jump if rsort ! 23349: bnequ src04 ! 23350: # ! 23351: src06: movl srtsc,r8 # restore wc ! 23352: addl2 $4*1,(sp) # return ! 23353: rsb ! 23354: # ! 23355: # KEYS ARE OF SAME DATATYPE ! 23356: # ! 23357: src07: cmpl r10,r9 # item first created is less ! 23358: blssu src03 ! 23359: cmpl r10,r9 # addresses rise in order of creation ! 23360: bgtru src05 ! 23361: # ! 23362: # DROP THROUGH OR MERGE FOR IDENTICAL OR EQUAL OBJECTS ! 23363: # ! 23364: src08: cmpl srts1,srts2 # test offsets or key addrss instead ! 23365: blssu src04 ! 23366: jmp src06 # offset 1 greater ! 23367: #page ! 23368: # ! 23369: # SORTC (CONTINUED) ! 23370: # ! 23371: # STRINGS ! 23372: # ! 23373: src09: movl r10,-(sp) # stack ! 23374: movl r9,-(sp) # args ! 23375: jsb lcomp # compare objects ! 23376: .long invalid$ # cant ! 23377: .long invalid$ # fail ! 23378: .long src03 # key1 less ! 23379: .long src08 # keys equal ! 23380: .long src05 # key1 greater ! 23381: # ! 23382: # ARITHMETIC COMPARISON FAILED - RECOVER ARGS ! 23383: # ! 23384: src10: movl r$sxl,r10 # get arg1 ! 23385: movl r$sxr,r9 # get arg2 ! 23386: movl (r10),r8 # get type of key1 ! 23387: cmpl r8,(r9) # jump if keys of same type ! 23388: beqlu src07 ! 23389: movl r8,r10 # get block type word ! 23390: movl (r9),r9 # get block type word ! 23391: movzwl -2(r10),r10 # entry point id for key1 ! 23392: movzwl -2(r9),r9 # entry point id for key2 ! 23393: cmpl r10,r9 # jump if key1 gt key2 ! 23394: bgtru src05 ! 23395: jmp src03 # key1 lt key2 ! 23396: # ! 23397: # DATATYPE FIELD NAME USED ! 23398: # ! 23399: src11: jsb sortf # call routine to find field 1 ! 23400: movl r10,-(sp) # stack item pointer ! 23401: movl r9,r10 # get key2 ! 23402: jsb sortf # find field 2 ! 23403: movl r10,r9 # place as key2 ! 23404: movl (sp)+,r10 # recover key1 ! 23405: jmp src01 # merge ! 23406: #enp # procedure sortc ! 23407: #page ! 23408: # ! 23409: # SORTF -- FIND FIELD FOR SORTC ! 23410: # ! 23411: # ROUTINE USED BY SORTC TO OBTAIN ITEM CORRESPONDING ! 23412: # TO A GIVEN FIELD NAME, IF THIS EXISTS, IN A PROGRAMMER ! 23413: # DEFINED OBJECT PASSED AS ARGUMENT. ! 23414: # IF SUCH A MATCH OCCURS, RECORD IS KEPT OF DATATYPE ! 23415: # NAME, FIELD NAME AND OFFSET TO FIELD IN ORDER TO ! 23416: # SHORT-CIRCUIT LATER SEARCHES ON SAME TYPE. NOTE THAT ! 23417: # DFBLKS ARE STORED IN STATIC AND HENCE CANNOT BE MOVED. ! 23418: # ! 23419: # (SRTDF) VRBLK POINTER OF FIELD NAME ! 23420: # (XL) POSSIBLE PDBLK POINTER ! 23421: # JSR SORTF CALL TO SEARCH FOR FIELD NAME ! 23422: # (XL) ITEM FOUND OR ORIGINAL PDBLK PTR ! 23423: # (WC) DESTROYED ! 23424: # ! 23425: sortf: #prc # entry point ! 23426: cmpl (r10),$b$pdt # return if not pdblk ! 23427: bnequ srtf3 ! 23428: movl r9,-(sp) # keep xr ! 23429: movl srtfd,r9 # get possible former dfblk ptr ! 23430: tstl r9 # jump if not ! 23431: beqlu srtf4 ! 23432: cmpl r9,4*pddfp(r10) # jump if not right datatype ! 23433: bnequ srtf4 ! 23434: cmpl srtdf,srtff # jump if not right field name ! 23435: bnequ srtf4 ! 23436: addl2 srtfo,r10 # add offset to required field ! 23437: # ! 23438: # HERE WITH XL POINTING TO FOUND FIELD ! 23439: # ! 23440: srtf1: movl (r10),r10 # get item from field ! 23441: # ! 23442: # RETURN POINT ! 23443: # ! 23444: srtf2: movl (sp)+,r9 # restore xr ! 23445: # ! 23446: srtf3: rsb # return ! 23447: #page ! 23448: # ! 23449: # SORTF (CONTINUED) ! 23450: # ! 23451: # CONDUCT A SEARCH ! 23452: # ! 23453: srtf4: movl r10,r9 # copy original pointer ! 23454: movl 4*pddfp(r9),r9 # point to dfblk ! 23455: movl r9,srtfd # keep a copy ! 23456: movl 4*fargs(r9),r8 # get number of fields ! 23457: moval 0[r8],r8 # convert to bytes ! 23458: addl2 4*dflen(r9),r9 # point past last field ! 23459: # ! 23460: # LOOP TO FIND NAME IN PDFBLK ! 23461: # ! 23462: srtf5: subl2 $4,r8 # count down ! 23463: subl2 $4,r9 # point in front ! 23464: cmpl (r9),srtdf # skip out if found ! 23465: beqlu srtf6 ! 23466: tstl r8 # loop ! 23467: bnequ srtf5 ! 23468: jmp srtf2 # return - not found ! 23469: # ! 23470: # FOUND ! 23471: # ! 23472: srtf6: movl (r9),srtff # keep field name ptr ! 23473: addl2 $4*pdfld,r8 # add offset to first field ! 23474: movl r8,srtfo # store as field offset ! 23475: addl2 r8,r10 # point to field ! 23476: jmp srtf1 # return ! 23477: #enp # procedure sortf ! 23478: #page ! 23479: # ! 23480: # SORTH -- HEAP ROUTINE FOR SORTA ! 23481: # ! 23482: # THIS ROUTINE CONSTRUCTS A HEAP FROM ELEMENTS OF ARRAY, A. ! 23483: # IN THIS APPLICATION, THE ELEMENTS ARE OFFSETS TO KEYS IN ! 23484: # A KEY ARRAY. ! 23485: # ! 23486: # (XS) POINTER TO SORT ARRAY BASE ! 23487: # 1(XS) POINTER TO KEY ARRAY BASE ! 23488: # (WA) MAX ARRAY INDEX, N (IN BYTES) ! 23489: # (WC) OFFSET J IN A TO ROOT (IN *1 TO *N) ! 23490: # JSR SORTH CALL SORTH(J,N) TO MAKE HEAP ! 23491: # (XL,XR,WB) DESTROYED ! 23492: # ! 23493: .data 1 ! 23494: sorth_s: .long 0 ! 23495: .text 0 ! 23496: sorth: movl (sp)+,sorth_s # entry point ! 23497: movl r6,srtsn # save n ! 23498: movl r8,srtwc # keep wc ! 23499: movl (sp),r10 # sort array base adrs ! 23500: addl2 srtso,r10 # add offset to a(0) ! 23501: addl2 r8,r10 # point to a(j) ! 23502: movl (r10),srtrt # get offset to root ! 23503: addl2 r8,r8 # double j - cant exceed n ! 23504: # ! 23505: # LOOP TO MOVE DOWN TREE USING DOUBLED INDEX J ! 23506: # ! 23507: srh01: cmpl r8,srtsn # done if j gt n ! 23508: bgtru srh03 ! 23509: cmpl r8,srtsn # skip if j equals n ! 23510: beqlu srh02 ! 23511: movl (sp),r9 # sort array base adrs ! 23512: movl 4*1(sp),r10 # key array base adrs ! 23513: addl2 srtso,r9 # point to a(0) ! 23514: addl2 r8,r9 # adrs of a(j) ! 23515: movl 4*1(r9),r6 # get a(j+1) ! 23516: movl (r9),r7 # get a(j) ! 23517: # ! 23518: # COMPARE SONS. (WA) RIGHT SON, (WB) LEFT SON ! 23519: # ! 23520: jsb sortc # compare keys - lt(a(j+1),a(j)) ! 23521: .long srh02 # a(j+1) lt a(j) ! 23522: addl2 $4,r8 # point to greater son, a(j+1) ! 23523: #page ! 23524: # ! 23525: # SORTH (CONTINUED) ! 23526: # ! 23527: # COMPARE ROOT WITH GREATER SON ! 23528: # ! 23529: srh02: movl 4*1(sp),r10 # key array base adrs ! 23530: movl (sp),r9 # get sort array address ! 23531: addl2 srtso,r9 # adrs of a(0) ! 23532: movl r9,r7 # copy this adrs ! 23533: addl2 r8,r9 # adrs of greater son, a(j) ! 23534: movl (r9),r6 # get a(j) ! 23535: movl r7,r9 # point back to a(0) ! 23536: movl srtrt,r7 # get root ! 23537: jsb sortc # compare them - lt(a(j),root) ! 23538: .long srh03 # father exceeds sons - done ! 23539: movl (sp),r9 # get sort array adrs ! 23540: addl2 srtso,r9 # point to a(0) ! 23541: movl r9,r10 # copy it ! 23542: movl r8,r6 # copy j ! 23543: ashl $-2,r8,r8 # convert to words ! 23544: ashl $-1,r8,r8 # get j/2 ! 23545: moval 0[r8],r8 # convert back to bytes ! 23546: addl2 r6,r10 # point to a(j) ! 23547: addl2 r8,r9 # adrs of a(j/2) ! 23548: movl (r10),(r9) # a(j/2) = a(j) ! 23549: movl r6,r8 # recover j ! 23550: addl2 r8,r8 # j = j*2. done if too big ! 23551: bvc 0f ! 23552: jmp srh03 ! 23553: 0: ! 23554: jmp srh01 # loop ! 23555: # ! 23556: # FINISH BY COPYING ROOT OFFSET BACK INTO ARRAY ! 23557: # ! 23558: srh03: ashl $-2,r8,r8 # convert to words ! 23559: ashl $-1,r8,r8 # j = j/2 ! 23560: moval 0[r8],r8 # convert back to bytes ! 23561: movl (sp),r9 # sort array adrs ! 23562: addl2 srtso,r9 # adrs of a(0) ! 23563: addl2 r8,r9 # adrs of a(j/2) ! 23564: movl srtrt,(r9) # a(j/2) = root ! 23565: movl srtsn,r6 # restore wa ! 23566: movl srtwc,r8 # restore wc ! 23567: jmp *sorth_s # return ! 23568: #enp # end procedure sorth ! 23569: #page ! 23570: #page ! 23571: # ! 23572: # TFIND -- LOCATE TABLE ELEMENT ! 23573: # ! 23574: # (XR) SUBSCRIPT VALUE FOR ELEMENT ! 23575: # (XL) POINTER TO TABLE ! 23576: # (WB) ZERO BY VALUE, NON-ZERO BY NAME ! 23577: # JSR TFIND CALL TO LOCATE ELEMENT ! 23578: # PPM LOC TRANSFER LOCATION IF ACCESS FAILS ! 23579: # (XR) ELEMENT VALUE (IF BY VALUE) ! 23580: # (XR) DESTROYED (IF BY NAME) ! 23581: # (XL,WA) TEBLK NAME (IF BY NAME) ! 23582: # (XL,WA) DESTROYED (IF BY VALUE) ! 23583: # (WC,RA) DESTROYED ! 23584: # ! 23585: # NOTE THAT IF A CALL BY VALUE SPECIFIES A NON-EXISTENT ! 23586: # SUBSCRIPT, NULL IS RETURNED WITHOUT BUILDING A NEW TEBLK. ! 23587: # ! 23588: tfind: #prc # entry point ! 23589: movl r7,-(sp) # save name/value indicator ! 23590: movl r9,-(sp) # save subscript value ! 23591: movl r10,-(sp) # save table pointer ! 23592: movl 4*tblen(r10),r6 # load length of tbblk ! 23593: ashl $-2,r6,r6 # convert to word count ! 23594: subl2 $tbbuk,r6 # get number of buckets ! 23595: movl r6,r5 # convert to integer value ! 23596: movl r5,tfnsi # save for later ! 23597: movl (r9),r10 # load first word of subscript ! 23598: movzwl -2(r10),r10 # load block entry id (bl$xx) ! 23599: casel r10,$0,$bl$$d # switch on block type ! 23600: 5: ! 23601: .word tfn00-5b ! 23602: .word tfn00-5b ! 23603: .word tfn00-5b ! 23604: .word tfn00-5b ! 23605: .word tfn02-5b # jump if integer ! 23606: .word tfn04-5b # jump if name ! 23607: .word tfn03-5b # jump if pattern ! 23608: .word tfn03-5b # jump if pattern ! 23609: .word tfn03-5b # jump if pattern ! 23610: .word tfn02-5b # real ! 23611: .word tfn05-5b # jump if string ! 23612: .word tfn00-5b ! 23613: .word tfn00-5b ! 23614: .word tfn00-5b ! 23615: .word tfn00-5b ! 23616: .word tfn00-5b ! 23617: .word tfn00-5b ! 23618: #esw # end switch on block type ! 23619: # ! 23620: # HERE FOR BLOCKS FOR WHICH WE USE THE SECOND WORD OF THE ! 23621: # BLOCK AS THE HASH SOURCE (SEE BLOCK FORMATS FOR DETAILS). ! 23622: # ! 23623: tfn00: movl 4*1(r9),r6 # load second word ! 23624: # ! 23625: # MERGE HERE WITH ONE WORD HASH SOURCE IN WA ! 23626: # ! 23627: tfn01: movl r6,r5 # convert to integer ! 23628: jmp tfn06 # jump to merge ! 23629: #page ! 23630: # ! 23631: # TFIND (CONTINUED) ! 23632: # ! 23633: # HERE FOR INTEGER OR REAL ! 23634: # ! 23635: tfn02: movl 4*1(r9),r5 # load value as hash source ! 23636: tstl r5 # ok if positive or zero ! 23637: bgeq tfn06 ! 23638: mnegl r5,r5 # make positive ! 23639: bvs tfn06 ! 23640: jmp tfn06 # merge ! 23641: # ! 23642: # FOR PATTERN, USE FIRST WORD (PCODE) AS SOURCE ! 23643: # ! 23644: tfn03: movl (r9),r6 # load first word as hash source ! 23645: jmp tfn01 # merge back ! 23646: # ! 23647: # FOR NAME, USE OFFSET AS HASH SOURCE ! 23648: # ! 23649: tfn04: movl 4*nmofs(r9),r6 # load offset as hash source ! 23650: jmp tfn01 # merge back ! 23651: # ! 23652: # HERE FOR STRING ! 23653: # ! 23654: tfn05: jsb hashs # call routine to compute hash ! 23655: # ! 23656: # MERGE HERE WITH HASH SOURCE IN (IA) ! 23657: # ! 23658: tfn06: ashq $-32,r4,r4 # compute hash index by remaindering ! 23659: ediv tfnsi,r4,r11,r5 ! 23660: movl r5,r8 # get as one word integer ! 23661: moval 0[r8],r8 # convert to byte offset ! 23662: movl (sp),r10 # get table ptr again ! 23663: addl2 r8,r10 # point to proper bucket ! 23664: movl 4*tbbuk(r10),r9 # load first teblk pointer ! 23665: cmpl r9,(sp) # jump if no teblks on chain ! 23666: beqlu tfn10 ! 23667: # ! 23668: # LOOP THROUGH TEBLKS ON HASH CHAIN ! 23669: # ! 23670: tfn07: movl r9,r7 # save teblk pointer ! 23671: movl 4*tesub(r9),r9 # load subscript value ! 23672: movl 4*1(sp),r10 # load input argument subscript val ! 23673: jsb ident # compare them ! 23674: .long tfn08 # jump if equal (ident) ! 23675: # ! 23676: # HERE IF NO MATCH WITH THAT TEBLK ! 23677: # ! 23678: movl r7,r10 # restore teblk pointer ! 23679: movl 4*tenxt(r10),r9 # point to next teblk on chain ! 23680: cmpl r9,(sp) # jump if there is one ! 23681: bnequ tfn07 ! 23682: # ! 23683: # HERE IF NO MATCH WITH ANY TEBLK ON CHAIN ! 23684: # ! 23685: movl $4*tenxt,r8 # set offset to link field (xl base) ! 23686: jmp tfn11 # jump to merge ! 23687: #page ! 23688: # ! 23689: # TFIND (CONTINUED) ! 23690: # ! 23691: # HERE WE HAVE FOUND A MATCHING ELEMENT ! 23692: # ! 23693: tfn08: movl r7,r10 # restore teblk pointer ! 23694: movl $4*teval,r6 # set teblk name offset ! 23695: movl 4*2(sp),r7 # restore name/value indicator ! 23696: tstl r7 # jump if called by name ! 23697: bnequ tfn09 ! 23698: jsb acess # else get value ! 23699: .long tfn12 # jump if reference fails ! 23700: clrl r7 # restore name/value indicator ! 23701: # ! 23702: # COMMON EXIT FOR ENTRY FOUND ! 23703: # ! 23704: tfn09: addl2 $4*num03,sp # pop stack entries ! 23705: addl2 $4*1,(sp) # return to tfind caller ! 23706: rsb ! 23707: # ! 23708: # HERE IF NO TEBLKS ON THE HASH CHAIN ! 23709: # ! 23710: tfn10: addl2 $4*tbbuk,r8 # get offset to bucket ptr ! 23711: movl (sp),r10 # set tbblk ptr as base ! 23712: # ! 23713: # MERGE HERE WITH (XL,WC) BASE,OFFSET OF FINAL LINK ! 23714: # ! 23715: tfn11: movl (sp),r9 # tbblk pointer ! 23716: movl 4*tbinv(r9),r9 # load default value in case ! 23717: movl 4*2(sp),r7 # load name/value indicator ! 23718: tstl r7 # exit with default if value call ! 23719: beqlu tfn09 ! 23720: # ! 23721: # HERE WE MUST BUILD A NEW TEBLK ! 23722: # ! 23723: movl $4*tesi$,r6 # set size of teblk ! 23724: jsb alloc # allocate teblk ! 23725: addl2 r8,r10 # point to hash link ! 23726: movl r9,(r10) # link new teblk at end of chain ! 23727: movl $b$tet,(r9) # store type word ! 23728: movl $nulls,4*teval(r9) # set null as initial value ! 23729: movl (sp)+,4*tenxt(r9)# set tbblk ptr to mark end of chain ! 23730: movl (sp)+,4*tesub(r9)# store subscript value ! 23731: addl2 $4,sp # pop past name/value indicator ! 23732: movl r9,r10 # copy teblk pointer (name base) ! 23733: movl $4*teval,r6 # set offset ! 23734: addl2 $4*1,(sp) # return to caller with new teblk ! 23735: rsb ! 23736: # ! 23737: # ACESS FAIL RETURN ! 23738: # ! 23739: tfn12: movl (sp)+,r11 # alternative return ! 23740: jmp *(r11)+ ! 23741: #enp # end procedure tfind ! 23742: #page ! 23743: # ! 23744: # TRACE -- SET/RESET A TRACE ASSOCIATION ! 23745: # ! 23746: # THIS PROCEDURE IS SHARED BY TRACE AND STOPTR TO ! 23747: # EITHER INITIATE OR STOP A TRACE RESPECTIVELY. ! 23748: # ! 23749: # (XL) TRBLK PTR (TRACE) OR ZERO (STOPTR) ! 23750: # 1(XS) FIRST ARGUMENT (NAME) ! 23751: # 0(XS) SECOND ARGUMENT (TRACE TYPE) ! 23752: # JSR TRACE CALL TO SET/RESET TRACE ! 23753: # PPM LOC TRANSFER LOC IF 1ST ARG IS BAD NAME ! 23754: # PPM LOC TRANSFER LOC IF 2ND ARG IS BAD TYPE ! 23755: # (XS) POPPED ! 23756: # (XL,XR,WA,WB,WC,IA) DESTROYED ! 23757: # ! 23758: .data 1 ! 23759: trace_s: .long 0 ! 23760: .text 0 ! 23761: trace: movl (sp)+,trace_s # entry point ! 23762: jsb gtstg # get trace type string ! 23763: .long trc15 # jump if not string ! 23764: movab cfp$f(r9),r9 # else point to string ! 23765: movzbl (r9),r6 # load first character ! 23766: bicl2 $ch$bl,r6 # fold to upper case ! 23767: movl (sp),r9 # load name argument ! 23768: movl r10,(sp) # stack trblk ptr or zero ! 23769: movl $trtac,r8 # set trtyp for access trace ! 23770: cmpl r6,$ch$la # jump if a (access) ! 23771: bnequ 0f ! 23772: jmp trc10 ! 23773: 0: ! 23774: movl $trtvl,r8 # set trtyp for value trace ! 23775: cmpl r6,$ch$lv # jump if v (value) ! 23776: bnequ 0f ! 23777: jmp trc10 ! 23778: 0: ! 23779: tstl r6 # jump if blank (value) ! 23780: bnequ 0f ! 23781: jmp trc10 ! 23782: 0: ! 23783: # ! 23784: # HERE FOR L,K,F,C,R ! 23785: # ! 23786: cmpl r6,$ch$lf # jump if f (function) ! 23787: beqlu trc01 ! 23788: cmpl r6,$ch$lr # jump if r (return) ! 23789: beqlu trc01 ! 23790: cmpl r6,$ch$ll # jump if l (label) ! 23791: beqlu trc03 ! 23792: cmpl r6,$ch$lk # jump if k (keyword) ! 23793: bnequ 0f ! 23794: jmp trc06 ! 23795: 0: ! 23796: cmpl r6,$ch$lc # else error if not c (call) ! 23797: beqlu 0f ! 23798: jmp trc15 ! 23799: 0: ! 23800: # ! 23801: # HERE FOR F,C,R ! 23802: # ! 23803: trc01: jsb gtnvr # point to vrblk for name ! 23804: .long trc16 # jump if bad name ! 23805: addl2 $4,sp # pop stack ! 23806: movl 4*vrfnc(r9),r9 # point to function block ! 23807: cmpl (r9),$b$pfc # error if not program function ! 23808: beqlu 0f ! 23809: jmp trc17 ! 23810: 0: ! 23811: cmpl r6,$ch$lr # jump if r (return) ! 23812: beqlu trc02 ! 23813: #page ! 23814: # ! 23815: # TRACE (CONTINUED) ! 23816: # ! 23817: # HERE FOR F,C TO SET/RESET CALL TRACE ! 23818: # ! 23819: movl r10,4*pfctr(r9) # set/reset call trace ! 23820: cmpl r6,$ch$lc # exit with null if c (call) ! 23821: bnequ 0f ! 23822: jmp exnul ! 23823: 0: ! 23824: # ! 23825: # HERE FOR F,R TO SET/RESET RETURN TRACE ! 23826: # ! 23827: trc02: movl r10,4*pfrtr(r9) # set/reset return trace ! 23828: addl3 $4*2,trace_s,r11 # return ! 23829: jmp (r11) ! 23830: # ! 23831: # HERE FOR L TO SET/RESET LABEL TRACE ! 23832: # ! 23833: trc03: jsb gtnvr # point to vrblk ! 23834: .long trc16 # jump if bad name ! 23835: movl 4*vrlbl(r9),r10 # load label pointer ! 23836: cmpl (r10),$b$trt # jump if no old trace ! 23837: bnequ trc04 ! 23838: movl 4*trlbl(r10),r10# else delete old trace association ! 23839: # ! 23840: # HERE WITH OLD LABEL TRACE ASSOCIATION DELETED ! 23841: # ! 23842: trc04: cmpl r10,$stndl # error if undefined label ! 23843: bnequ 0f ! 23844: jmp trc16 ! 23845: 0: ! 23846: movl (sp)+,r7 # get trblk ptr again ! 23847: tstl r7 # jump if stoptr case ! 23848: beqlu trc05 ! 23849: movl r7,4*vrlbl(r9) # else set new trblk pointer ! 23850: movl $b$vrt,4*vrtra(r9) # set label trace routine address ! 23851: movl r7,r9 # copy trblk pointer ! 23852: movl r10,4*trlbl(r9) # store real label in trblk ! 23853: addl3 $4*2,trace_s,r11 # return ! 23854: jmp (r11) ! 23855: # ! 23856: # HERE FOR STOPTR CASE FOR LABEL ! 23857: # ! 23858: trc05: movl r10,4*vrlbl(r9) # store label ptr back in vrblk ! 23859: movl $b$vrg,4*vrtra(r9) # store normal transfer address ! 23860: addl3 $4*2,trace_s,r11 # return ! 23861: jmp (r11) ! 23862: #page ! 23863: # ! 23864: # TRACE (CONTINUED) ! 23865: # ! 23866: # HERE FOR K (KEYWORD) ! 23867: # ! 23868: trc06: jsb gtnvr # point to vrblk ! 23869: .long trc16 # error if not natural var ! 23870: tstl 4*vrlen(r9) # error if not system var ! 23871: beqlu 0f ! 23872: jmp trc16 ! 23873: 0: ! 23874: addl2 $4,sp # pop stack ! 23875: tstl r10 # jump if stoptr case ! 23876: beqlu trc07 ! 23877: movl r9,4*trkvr(r10) # store vrblk ptr in trblk for ktrex ! 23878: # ! 23879: # MERGE HERE WITH TRBLK SET UP IN WB (OR ZERO) ! 23880: # ! 23881: trc07: movl 4*vrsvp(r9),r9 # point to svblk ! 23882: cmpl r9,$v$ert # jump if errtype ! 23883: beqlu trc08 ! 23884: cmpl r9,$v$stc # jump if stcount ! 23885: beqlu trc09 ! 23886: cmpl r9,$v$fnc # else error if not fnclevel ! 23887: beqlu 0f ! 23888: jmp trc17 ! 23889: 0: ! 23890: # ! 23891: # FNCLEVEL ! 23892: # ! 23893: movl r10,r$fnc # set/reset fnclevel trace ! 23894: addl3 $4*2,trace_s,r11 # return ! 23895: jmp (r11) ! 23896: # ! 23897: # ERRTYPE ! 23898: # ! 23899: trc08: movl r10,r$ert # set/reset errtype trace ! 23900: addl3 $4*2,trace_s,r11 # return ! 23901: jmp (r11) ! 23902: # ! 23903: # STCOUNT ! 23904: # ! 23905: trc09: movl r10,r$stc # set/reset stcount trace ! 23906: addl3 $4*2,trace_s,r11 # return ! 23907: jmp (r11) ! 23908: #page ! 23909: # ! 23910: # TRACE (CONTINUED) ! 23911: # ! 23912: # A,V MERGE HERE WITH TRTYP VALUE IN WC ! 23913: # ! 23914: trc10: jsb gtvar # locate variable ! 23915: .long trc16 # error if not appropriate name ! 23916: movl (sp)+,r7 # get new trblk ptr again ! 23917: addl2 r10,r6 # point to variable location ! 23918: movl r6,r9 # copy variable pointer ! 23919: # ! 23920: # LOOP TO SEARCH TRBLK CHAIN ! 23921: # ! 23922: trc11: movl (r9),r10 # point to next entry ! 23923: cmpl (r10),$b$trt # jump if not trblk ! 23924: bnequ trc13 ! 23925: cmpl r8,4*trtyp(r10) # jump if too far out on chain ! 23926: blssu trc13 ! 23927: cmpl r8,4*trtyp(r10) # jump if this matches our type ! 23928: beqlu trc12 ! 23929: addl2 $4*trnxt,r10 # else point to link field ! 23930: movl r10,r9 # copy pointer ! 23931: jmp trc11 # and loop back ! 23932: # ! 23933: # HERE TO DELETE AN OLD TRBLK OF THE TYPE WE WERE GIVEN ! 23934: # ! 23935: trc12: movl 4*trnxt(r10),r10# get ptr to next block or value ! 23936: movl r10,(r9) # store to delete this trblk ! 23937: # ! 23938: # HERE AFTER DELETING ANY OLD ASSOCIATION OF THIS TYPE ! 23939: # ! 23940: trc13: tstl r7 # jump if stoptr case ! 23941: beqlu trc14 ! 23942: movl r7,(r9) # else link new trblk in ! 23943: movl r7,r9 # copy trblk pointer ! 23944: movl r10,4*trnxt(r9) # store forward pointer ! 23945: movl r8,4*trtyp(r9) # store appropriate trap type code ! 23946: # ! 23947: # HERE TO MAKE SURE VRGET,VRSTO ARE SET PROPERLY ! 23948: # ! 23949: trc14: movl r6,r9 # recall possible vrblk pointer ! 23950: subl2 $4*vrval,r9 # point back to vrblk ! 23951: jsb setvr # set fields if vrblk ! 23952: addl3 $4*2,trace_s,r11 # return ! 23953: jmp (r11) ! 23954: # ! 23955: # HERE FOR BAD TRACE TYPE ! 23956: # ! 23957: trc15: addl3 $4*1,trace_s,r11 # take bad trace type error exit ! 23958: jmp *(r11)+ ! 23959: # ! 23960: # POP STACK BEFORE FAILING ! 23961: # ! 23962: trc16: addl2 $4,sp # pop stack ! 23963: # ! 23964: # HERE FOR BAD NAME ARGUMENT ! 23965: # ! 23966: trc17: movl trace_s,r11 # take bad name error exit ! 23967: jmp *(r11)+ ! 23968: #enp # end procedure trace ! 23969: #page ! 23970: # ! 23971: # TRBLD -- BUILD TRBLK ! 23972: # ! 23973: # TRBLK IS USED BY THE INPUT, OUTPUT AND TRACE FUNCTIONS ! 23974: # TO CONSTRUCT A TRBLK (TRAP BLOCK) ! 23975: # ! 23976: # (XR) TRTAG OR TRTER ! 23977: # (XL) TRFNC OR TRFPT ! 23978: # (WB) TRTYP ! 23979: # JSR TRBLD CALL TO BUILD TRBLK ! 23980: # (XR) POINTER TO TRBLK ! 23981: # (WA) DESTROYED ! 23982: # ! 23983: trbld: #prc # entry point ! 23984: movl r9,-(sp) # stack trtag (or trfnm) ! 23985: movl $4*trsi$,r6 # set size of trblk ! 23986: jsb alloc # allocate trblk ! 23987: movl $b$trt,(r9) # store first word ! 23988: movl r10,4*trfnc(r9) # store trfnc (or trfpt) ! 23989: movl (sp)+,4*trtag(r9)# store trtag (or trfnm) ! 23990: movl r7,4*trtyp(r9) # store type ! 23991: movl $nulls,4*trval(r9) # for now, a null value ! 23992: rsb # return to caller ! 23993: #enp # end procedure trbld ! 23994: #page ! 23995: # ! 23996: # TRIMR -- TRIM TRAILING BLANKS ! 23997: # ! 23998: # TRIMR IS PASSED A POINTER TO AN SCBLK WHICH MUST BE THE ! 23999: # LAST BLOCK IN DYNAMIC STORAGE. TRAILING BLANKS ARE ! 24000: # TRIMMED OFF AND THE DYNAMIC STORAGE POINTER RESET TO ! 24001: # THE END OF THE (POSSIBLY) SHORTENED BLOCK. ! 24002: # ! 24003: # (WB) NON-ZERO TO TRIM TRAILING BLANKS ! 24004: # (XR) POINTER TO STRING TO TRIM ! 24005: # JSR TRIMR CALL TO TRIM STRING ! 24006: # (XR) POINTER TO TRIMMED STRING ! 24007: # (XL,WA,WB,WC) DESTROYED ! 24008: # ! 24009: # THE CALL WITH WB ZERO STILL PERFORMS THE END ZERO PAD ! 24010: # AND DNAMP READJUSTMENT. IT IS USED FROM ACESS IF KVTRM=0. ! 24011: # ! 24012: trimr: #prc # entry point ! 24013: movl r9,r10 # copy string pointer ! 24014: movl 4*sclen(r9),r6 # load string length ! 24015: tstl r6 # jump if null input ! 24016: beqlu trim2 ! 24017: movab cfp$f(r10)[r6],r10 # else point past last character ! 24018: tstl r7 # jump if no trim ! 24019: beqlu trim3 ! 24020: movl $ch$bl,r8 # load blank character ! 24021: # ! 24022: # LOOP THROUGH CHARACTERS FROM RIGHT TO LEFT ! 24023: # ! 24024: trim0: movzbl -(r10),r7 # load next character ! 24025: cmpl r7,$ch$ht # jump if horizontal tab ! 24026: beqlu trim1 ! 24027: cmpl r7,r8 # jump if non-blank found ! 24028: bnequ trim3 ! 24029: trim1: decl r6 # else decrement character count ! 24030: tstl r6 # loop back if more to check ! 24031: bnequ trim0 ! 24032: # ! 24033: # HERE IF RESULT IS NULL (NULL OR ALL-BLANK INPUT) ! 24034: # ! 24035: trim2: movl r9,dnamp # wipe out input string block ! 24036: movl $nulls,r9 # load null result ! 24037: jmp trim5 # merge to exit ! 24038: #page ! 24039: # ! 24040: # TRIMR (CONTINUED) ! 24041: # ! 24042: # HERE WITH NON-BLANK FOUND (MERGE FOR NO TRIM) ! 24043: # ! 24044: trim3: movl r6,4*sclen(r9) # set new length ! 24045: movl r9,r10 # copy string pointer ! 24046: movab cfp$f(r10)[r6],r10 # ready for storing blanks ! 24047: movab 3+(4*schar)(r6),r6 # get length of block in bytes ! 24048: bicl2 $3,r6 ! 24049: addl2 r9,r6 # point past new block ! 24050: movl r6,dnamp # set new top of storage pointer ! 24051: movl $cfp$c,r6 # get count of chars in word ! 24052: clrl r8 # set blank char ! 24053: # ! 24054: # LOOP TO ZERO PAD LAST WORD OF CHARACTERS ! 24055: # ! 24056: trim4: movb r8,(r10)+ # store zero character ! 24057: sobgtr r6,trim4 # loop back till all stored ! 24058: #csc r10 # complete store characters ! 24059: # ! 24060: # COMMON EXIT POINT ! 24061: # ! 24062: trim5: clrl r10 # clear garbage xl pointer ! 24063: rsb # return to caller ! 24064: #enp # end procedure trimr ! 24065: #page ! 24066: # ! 24067: # TRXEQ -- EXECUTE FUNCTION TYPE TRACE ! 24068: # ! 24069: # TRXEQ IS USED TO EXECUTE A TRACE WHEN A FOURTH ARGUMENT ! 24070: # HAS BEEN SUPPLIED. TRACE HAS ALREADY BEEN DECREMENTED. ! 24071: # ! 24072: # (XR) POINTER TO TRBLK ! 24073: # (XL,WA) NAME BASE,OFFSET FOR VARIABLE ! 24074: # JSR TRXEQ CALL TO EXECUTE TRACE ! 24075: # (WB,WC,RA) DESTROYED ! 24076: # ! 24077: # THE FOLLOWING STACK ENTRIES ARE MADE BEFORE PASSING ! 24078: # CONTROL TO THE TRACE FUNCTION USING THE CFUNC ROUTINE. ! 24079: # ! 24080: # TRXEQ RETURN POINT WORD(S) ! 24081: # SAVED VALUE OF TRACE KEYWORD ! 24082: # TRBLK POINTER ! 24083: # NAME BASE ! 24084: # NAME OFFSET ! 24085: # SAVED VALUE OF R$COD ! 24086: # SAVED CODE PTR (-R$COD) ! 24087: # SAVED VALUE OF FLPTR ! 24088: # FLPTR --------------- ZERO (DUMMY FAIL OFFSET) ! 24089: # NMBLK FOR VARIABLE NAME ! 24090: # XS ------------------ TRACE TAG ! 24091: # ! 24092: # R$COD AND THE CODE PTR ARE SET TO DUMMY VALUES WHICH ! 24093: # CAUSE CONTROL TO RETURN TO THE TRXEQ PROCEDURE ON SUCCESS ! 24094: # OR FAILURE (TRXEQ IGNORES A FAILURE CONDITION). ! 24095: # ! 24096: trxeq: #prc # entry point (recursive) ! 24097: movl r$cod,r8 # load code block pointer ! 24098: movl r3,r7 # get current code pointer ! 24099: subl2 r8,r7 # make code pointer into offset ! 24100: movl kvtra,-(sp) # stack trace keyword value ! 24101: movl r9,-(sp) # stack trblk pointer ! 24102: movl r10,-(sp) # stack name base ! 24103: movl r6,-(sp) # stack name offset ! 24104: movl r8,-(sp) # stack code block pointer ! 24105: movl r7,-(sp) # stack code pointer offset ! 24106: movl flptr,-(sp) # stack old failure pointer ! 24107: clrl -(sp) # set dummy fail offset ! 24108: movl sp,flptr # set new failure pointer ! 24109: clrl kvtra # reset trace keyword to zero ! 24110: movl $trxdc,r8 # load new (dummy) code blk pointer ! 24111: movl r8,r$cod # set as code block pointer ! 24112: movl r8,r3 # and new code pointer ! 24113: #page ! 24114: # ! 24115: # TRXEQ (CONTINUED) ! 24116: # ! 24117: # NOW PREPARE ARGUMENTS FOR FUNCTION ! 24118: # ! 24119: movl r6,r7 # save name offset ! 24120: movl $4*nmsi$,r6 # load nmblk size ! 24121: jsb alloc # allocate space for nmblk ! 24122: movl $b$nml,(r9) # set type word ! 24123: movl r10,4*nmbas(r9) # store name base ! 24124: movl r7,4*nmofs(r9) # store name offset ! 24125: movl 4*6(sp),r10 # reload pointer to trblk ! 24126: movl r9,-(sp) # stack nmblk pointer (1st argument) ! 24127: movl 4*trtag(r10),-(sp) # stack trace tag (2nd argument) ! 24128: movl 4*trfnc(r10),r10# load trace function pointer ! 24129: movl $num02,r6 # set number of arguments to two ! 24130: jmp cfunc # jump to call function ! 24131: # ! 24132: # SEE O$TXR FOR DETAILS OF RETURN TO THIS POINT ! 24133: # ! 24134: trxq1: movl flptr,sp # point back to our stack entries ! 24135: addl2 $4,sp # pop off garbage fail offset ! 24136: movl (sp)+,flptr # restore old failure pointer ! 24137: movl (sp)+,r7 # reload code offset ! 24138: movl (sp)+,r8 # load old code base pointer ! 24139: movl r8,r9 # copy cdblk pointer ! 24140: movl 4*cdstm(r9),kvstn# restore stmnt no ! 24141: movl (sp)+,r6 # reload name offset ! 24142: movl (sp)+,r10 # reload name base ! 24143: movl (sp)+,r9 # reload trblk pointer ! 24144: movl (sp)+,kvtra # restore trace keyword value ! 24145: addl2 r8,r7 # recompute absolute code pointer ! 24146: movl r7,r3 # restore code pointer ! 24147: movl r8,r$cod # and code block pointer ! 24148: rsb # return to trxeq caller ! 24149: #enp # end procedure trxeq ! 24150: #page ! 24151: # ! 24152: # XSCAN -- EXECUTION FUNCTION ARGUMENT SCAN ! 24153: # ! 24154: # XSCAN SCANS OUT ONE TOKEN IN A PROTOTYPE ARGUMENT IN ! 24155: # ARRAY,CLEAR,DATA,DEFINE,LOAD FUNCTION CALLS. XSCAN ! 24156: # CALLS MUST BE PRECEDED BY A CALL TO THE INITIALIZATION ! 24157: # PROCEDURE XSCNI. THE FOLLOWING VARIABLES ARE USED. ! 24158: # ! 24159: # R$XSC POINTER TO SCBLK FOR FUNCTION ARG ! 24160: # XSOFS OFFSET (NUM CHARS SCANNED SO FAR) ! 24161: # ! 24162: # (WC) DELIMITER ONE (CH$XX) ! 24163: # (XL) DELIMITER TWO (CH$XX) ! 24164: # JSR XSCAN CALL TO SCAN NEXT ITEM ! 24165: # (XR) POINTER TO SCBLK FOR TOKEN SCANNED ! 24166: # (WA) COMPLETION CODE (SEE BELOW) ! 24167: # (WC,XL) DESTROYED ! 24168: # ! 24169: # THE SCAN STARTS FROM THE CURRENT POSITION AND CONTINUES ! 24170: # UNTIL ONE OF THE FOLLOWING THREE CONDITIONS OCCURS. ! 24171: # ! 24172: # 1) DELIMITER ONE IS ENCOUNTERED (WA SET TO 1) ! 24173: # ! 24174: # 2) DELIMITER TWO ENCOUNTERED (WA SET TO 2) ! 24175: # ! 24176: # 3) END OF STRING ENCOUNTERED (WA SET TO 0) ! 24177: # ! 24178: # THE RESULT IS A STRING CONTAINING ALL CHARACTERS SCANNED ! 24179: # UP TO BUT NOT INCLUDING ANY DELIMITER CHARACTER. ! 24180: # THE POINTER IS LEFT POINTING PAST THE DELIMITER. ! 24181: # ! 24182: # IF ONLY ONE DELIMITER IS TO BE DETECTED, DELIMITER ONE ! 24183: # AND DELIMITER TWO SHOULD BE SET TO THE SAME VALUE. ! 24184: # ! 24185: # IN THE CASE WHERE THE END OF STRING IS ENCOUNTERED, THE ! 24186: # STRING INCLUDES ALL THE CHARACTERS TO THE END OF THE ! 24187: # STRING. NO FURTHER CALLS CAN BE MADE TO XSCAN UNTIL ! 24188: # XSCNI IS CALLED TO INITIALIZE A NEW ARGUMENT SCAN ! 24189: #page ! 24190: # ! 24191: # XSCAN (CONTINUED) ! 24192: # ! 24193: xscan: #prc # entry point ! 24194: movl r7,xscwb # preserve wb ! 24195: movl r$xsc,r9 # point to argument string ! 24196: movl 4*sclen(r9),r6 # load string length ! 24197: movl xsofs,r7 # load current offset ! 24198: subl2 r7,r6 # get number of remaining characters ! 24199: tstl r6 # jump if no characters left ! 24200: beqlu xscn2 ! 24201: movab cfp$f(r9)[r7],r9# point to current character ! 24202: # ! 24203: # LOOP TO SEARCH FOR DELIMITER ! 24204: # ! 24205: xscn1: movzbl (r9)+,r7 # load next character ! 24206: cmpl r7,r8 # jump if delimiter one found ! 24207: beqlu xscn3 ! 24208: cmpl r7,r10 # jump if delimiter two found ! 24209: beqlu xscn4 ! 24210: decl r6 # decrement count of chars left ! 24211: tstl r6 # loop back if more chars to go ! 24212: bnequ xscn1 ! 24213: # ! 24214: # HERE FOR RUNOUT ! 24215: # ! 24216: xscn2: movl r$xsc,r10 # point to string block ! 24217: movl 4*sclen(r10),r6 # get string length ! 24218: movl xsofs,r7 # load offset ! 24219: subl2 r7,r6 # get substring length ! 24220: clrl r$xsc # clear string ptr for collector ! 24221: clrl xscrt # set zero (runout) return code ! 24222: jmp xscn6 # jump to exit ! 24223: #page ! 24224: # ! 24225: # XSCAN (CONTINUED) ! 24226: # ! 24227: # HERE IF DELIMITER ONE FOUND ! 24228: # ! 24229: xscn3: movl $num01,xscrt # set return code ! 24230: jmp xscn5 # jump to merge ! 24231: # ! 24232: # HERE IF DELIMITER TWO FOUND ! 24233: # ! 24234: xscn4: movl $num02,xscrt # set return code ! 24235: # ! 24236: # MERGE HERE AFTER DETECTING A DELIMITER ! 24237: # ! 24238: xscn5: movl r$xsc,r10 # reload pointer to string ! 24239: movl 4*sclen(r10),r8 # get original length of string ! 24240: subl2 r6,r8 # minus chars left = chars scanned ! 24241: movl r8,r6 # move to reg for sbstr ! 24242: movl xsofs,r7 # set offset ! 24243: subl2 r7,r6 # compute length for sbstr ! 24244: incl r8 # adjust new cursor past delimiter ! 24245: movl r8,xsofs # store new offset ! 24246: # ! 24247: # COMMON EXIT POINT ! 24248: # ! 24249: xscn6: clrl r9 # clear garbage character ptr in xr ! 24250: jsb sbstr # build sub-string ! 24251: movl xscrt,r6 # load return code ! 24252: movl xscwb,r7 # restore wb ! 24253: rsb # return to xscan caller ! 24254: #enp # end procedure xscan ! 24255: #page ! 24256: # ! 24257: # XSCNI -- EXECUTION FUNCTION ARGUMENT SCAN ! 24258: # ! 24259: # XSCNI INITIALIZES THE SCAN USED FOR PROTOTYPE ARGUMENTS ! 24260: # IN THE CLEAR, DEFINE, LOAD, DATA, ARRAY FUNCTIONS. SEE ! 24261: # XSCAN FOR THE PROCEDURE WHICH IS USED AFTER THIS CALL. ! 24262: # ! 24263: # -(XS) ARGUMENT TO BE SCANNED (ON STACK) ! 24264: # JSR XSCNI CALL TO SCAN ARGUMENT ! 24265: # PPM LOC TRANSFER LOC IF ARG IS NOT STRING ! 24266: # PPM LOC TRANSFER LOC IF ARGUMENT IS NULL ! 24267: # (XS) POPPED ! 24268: # (XR,R$XSC) ARGUMENT (SCBLK PTR) ! 24269: # (WA) ARGUMENT LENGTH ! 24270: # (IA,RA) DESTROYED ! 24271: # ! 24272: .data 1 ! 24273: xscni_s: .long 0 ! 24274: .text 0 ! 24275: xscni: movl (sp)+,xscni_s # entry point ! 24276: jsb gtstg # fetch argument as string ! 24277: .long xsci1 # jump if not convertible ! 24278: movl r9,r$xsc # else store scblk ptr for xscan ! 24279: clrl xsofs # set offset to zero ! 24280: tstl r6 # jump if null string ! 24281: beqlu xsci2 ! 24282: addl3 $4*2,xscni_s,r11 # return to xscni caller ! 24283: jmp (r11) ! 24284: # ! 24285: # HERE IF ARGUMENT IS NOT A STRING ! 24286: # ! 24287: xsci1: movl xscni_s,r11 # take not-string error exit ! 24288: jmp *(r11)+ ! 24289: # ! 24290: # HERE FOR NULL STRING ! 24291: # ! 24292: xsci2: addl3 $4*1,xscni_s,r11 # take null-string error exit ! 24293: jmp *(r11)+ ! 24294: #enp # end procedure xscni ! 24295: #title s p i t b o l -- utility routines ! 24296: # ! 24297: # THE FOLLOWING SECTION CONTAINS UTILITY ROUTINES USED FOR ! 24298: # VARIOUS PURPOSES THROUGHOUT THE SYSTEM. THESE DIFFER ! 24299: # FROM THE PROCEDURES IN THE UTILITY PROCEDURES SECTION IN ! 24300: # THEY ARE NOT IN PROCEDURE FORM AND THEY DO NOT RETURN ! 24301: # TO THEIR CALLERS. THEY ARE ACCESSED WITH A BRANCH TYPE ! 24302: # INSTRUCTION AFTER SETTING THE REGISTERS TO APPROPRIATE ! 24303: # PARAMETER VALUES. ! 24304: # ! 24305: # THE REGISTER VALUES REQUIRED FOR EACH ROUTINE ARE ! 24306: # DOCUMENTED AT THE START OF EACH ROUTINE. REGISTERS NOT ! 24307: # MENTIONED MAY CONTAIN ANY VALUES EXCEPT THAT XR,XL ! 24308: # CAN ONLY CONTAIN PROPER COLLECTABLE POINTERS. ! 24309: # ! 24310: # SOME OF THESE ROUTINES WILL TOLERATE GARBAGE POINTERS ! 24311: # IN XL,XR ON ENTRY. THIS IS ALWAYS DOCUMENTED AND IN ! 24312: # EACH CASE, THE ROUTINE CLEARS THESE GARBAGE VALUES BEFORE ! 24313: # EXITING AFTER COMPLETING ITS TASK. ! 24314: # ! 24315: # THE ROUTINES HAVE NAMES CONSISTING OF FIVE LETTERS ! 24316: # AND ARE ASSEMBLED IN ALPHABETICAL ORDER. ! 24317: #page ! 24318: # ARREF -- ARRAY REFERENCE ! 24319: # ! 24320: # (XL) MAY BE NON-COLLECTABLE ! 24321: # (XR) NUMBER OF SUBSCRIPTS ! 24322: # (WB) SET ZERO/NONZERO FOR VALUE/NAME ! 24323: # THE VALUE IN WB MUST BE COLLECTABLE ! 24324: # STACK SUBSCRIPTS AND ARRAY OPERAND ! 24325: # BRN ARREF JUMP TO CALL FUNCTION ! 24326: # ! 24327: # ARREF CONTINUES BY EXECUTING THE NEXT CODE WORD WITH ! 24328: # THE RESULT NAME OR VALUE PLACED ON TOP OF THE STACK. ! 24329: # TO DEAL WITH THE PROBLEM OF ACCESSING SUBSCRIPTS IN THE ! 24330: # ORDER OF STACKING, XL IS USED AS A SUBSCRIPT POINTER ! 24331: # WORKING BELOW THE STACK POINTER. ! 24332: # ! 24333: arref: #rtn ! 24334: movl r9,r6 # copy number of subscripts ! 24335: movl sp,r10 # point to stack front ! 24336: moval 0[r9],r9 # convert to byte offset ! 24337: addl2 r9,r10 # point to array operand on stack ! 24338: addl2 $4,r10 # final value for stack popping ! 24339: movl r10,arfxs # keep for later ! 24340: movl -(r10),r9 # load array operand pointer ! 24341: movl r9,r$arf # keep array pointer ! 24342: movl r10,r9 # save pointer to subscripts ! 24343: movl r$arf,r10 # point xl to possible vcblk or tbblk ! 24344: movl (r10),r8 # load first word ! 24345: cmpl r8,$b$art # jump if arblk ! 24346: beqlu arf01 ! 24347: cmpl r8,$b$vct # jump if vcblk ! 24348: bnequ 0f ! 24349: jmp arf07 ! 24350: 0: ! 24351: cmpl r8,$b$tbt # jump if tbblk ! 24352: bnequ 0f ! 24353: jmp arf10 ! 24354: 0: ! 24355: jmp er_235 # subscripted operand is not table or array ! 24356: # ! 24357: # HERE FOR ARRAY (ARBLK) ! 24358: # ! 24359: arf01: cmpl r6,4*arndm(r10) # jump if wrong number of dims ! 24360: beqlu 0f ! 24361: jmp arf09 ! 24362: 0: ! 24363: movl intv0,r5 # get initial subscript of zero ! 24364: movl r9,r10 # point before subscripts ! 24365: clrl r6 # initial offset to bounds ! 24366: jmp arf03 # jump into loop ! 24367: # ! 24368: # LOOP TO COMPUTE SUBSCRIPTS BY MULTIPLICATIONS ! 24369: # ! 24370: arf02: mull2 4*ardm2(r9),r5 # multiply total by next dimension ! 24371: # ! 24372: # MERGE HERE FIRST TIME ! 24373: # ! 24374: arf03: movl -(r10),r9 # load next subscript ! 24375: movl r5,arfsi # save current subscript ! 24376: movl 4*icval(r9),r5 # load integer value in case ! 24377: cmpl (r9),$b$icl # jump if it was an integer ! 24378: beqlu arf04 ! 24379: #page ! 24380: # ! 24381: # ARREF (CONTINUED) ! 24382: # ! 24383: # ! 24384: jsb gtint # convert to integer ! 24385: .long arf12 # jump if not integer ! 24386: movl 4*icval(r9),r5 # if ok, load integer value ! 24387: # ! 24388: # HERE WITH INTEGER SUBSCRIPT IN (IA) ! 24389: # ! 24390: arf04: movl r$arf,r9 # point to array ! 24391: addl2 r6,r9 # offset to next bounds ! 24392: subl2 4*arlbd(r9),r5 # subtract low bound to compare ! 24393: bvc 0f ! 24394: jmp arf13 ! 24395: 0: ! 24396: tstl r5 # out of range fail if too small ! 24397: bgeq 0f ! 24398: jmp arf13 ! 24399: 0: ! 24400: subl2 4*ardim(r9),r5 # subtract dimension ! 24401: tstl r5 # out of range fail if too large ! 24402: blss 0f ! 24403: jmp arf13 ! 24404: 0: ! 24405: addl2 4*ardim(r9),r5 # else restore subscript offset ! 24406: addl2 arfsi,r5 # add to current total ! 24407: addl2 $4*ardms,r6 # point to next bounds ! 24408: cmpl r10,sp # loop back if more to go ! 24409: bnequ arf02 ! 24410: # ! 24411: # HERE WITH INTEGER SUBSCRIPT COMPUTED ! 24412: # ! 24413: movl r5,r6 # get as one word integer ! 24414: moval 0[r6],r6 # convert to offset ! 24415: movl r$arf,r10 # point to arblk ! 24416: addl2 4*arofs(r10),r6 # add offset past bounds ! 24417: addl2 $4,r6 # adjust for arpro field ! 24418: tstl r7 # exit with name if name call ! 24419: bnequ arf08 ! 24420: # ! 24421: # MERGE HERE TO GET VALUE FOR VALUE CALL ! 24422: # ! 24423: arf05: jsb acess # get value ! 24424: .long arf13 # fail if acess fails ! 24425: # ! 24426: # RETURN VALUE ! 24427: # ! 24428: arf06: movl arfxs,sp # pop stack entries ! 24429: clrl r$arf # finished with array pointer ! 24430: jmp exixr # exit with value in xr ! 24431: #page ! 24432: # ! 24433: # ARREF (CONTINUED) ! 24434: # ! 24435: # HERE FOR VECTOR ! 24436: # ! 24437: arf07: cmpl r6,$num01 # error if more than 1 subscript ! 24438: beqlu 0f ! 24439: jmp arf09 ! 24440: 0: ! 24441: movl (sp),r9 # else load subscript ! 24442: jsb gtint # convert to integer ! 24443: .long arf12 # error if not integer ! 24444: movl 4*icval(r9),r5 # else load integer value ! 24445: subl2 intv1,r5 # subtract for ones offset ! 24446: movl r5,r6 # get subscript as one word ! 24447: bgeq 0f ! 24448: jmp arf13 ! 24449: 0: ! 24450: addl2 $vcvls,r6 # add offset for standard fields ! 24451: moval 0[r6],r6 # convert offset to bytes ! 24452: cmpl r6,4*vclen(r10) # fail if out of range subscript ! 24453: blssu 0f ! 24454: jmp arf13 ! 24455: 0: ! 24456: tstl r7 # back to get value if value call ! 24457: beqlu arf05 ! 24458: # ! 24459: # RETURN NAME ! 24460: # ! 24461: arf08: movl arfxs,sp # pop stack entries ! 24462: clrl r$arf # finished with array pointer ! 24463: jmp exnam # else exit with name ! 24464: # ! 24465: # HERE IF SUBSCRIPT COUNT IS WRONG ! 24466: # ! 24467: arf09: jmp er_236 # array referenced with wrong number of subscripts ! 24468: # ! 24469: # TABLE ! 24470: # ! 24471: arf10: cmpl r6,$num01 # error if more than 1 subscript ! 24472: bnequ arf11 ! 24473: movl (sp),r9 # else load subscript ! 24474: jsb tfind # call table search routine ! 24475: .long arf13 # fail if failed ! 24476: tstl r7 # exit with name if name call ! 24477: bnequ arf08 ! 24478: jmp arf06 # else exit with value ! 24479: # ! 24480: # HERE FOR BAD TABLE REFERENCE ! 24481: # ! 24482: arf11: jmp er_237 # table referenced with more than one subscript ! 24483: # ! 24484: # HERE FOR BAD SUBSCRIPT ! 24485: # ! 24486: arf12: jmp er_238 # array subscript is not integer ! 24487: # ! 24488: # HERE TO SIGNAL FAILURE ! 24489: # ! 24490: arf13: clrl r$arf # finished with array pointer ! 24491: jmp exfal # fail ! 24492: #page ! 24493: # ! 24494: # CFUNC -- CALL A FUNCTION ! 24495: # ! 24496: # CFUNC IS USED TO CALL A SNOBOL LEVEL FUNCTION. IT IS ! 24497: # USED BY THE APPLY FUNCTION (S$APP), THE FUNCTION ! 24498: # TRACE ROUTINE (TRXEQ) AND THE MAIN FUNCTION CALL ENTRY ! 24499: # (O$FNC, O$FNS). IN THE LATTER CASES, CFUNC IS USED ONLY ! 24500: # IF THE NUMBER OF ARGUMENTS IS INCORRECT. ! 24501: # ! 24502: # (XL) POINTER TO FUNCTION BLOCK ! 24503: # (WA) ACTUAL NUMBER OF ARGUMENTS ! 24504: # (XS) POINTS TO STACKED ARGUMENTS ! 24505: # BRN CFUNC JUMP TO CALL FUNCTION ! 24506: # ! 24507: # CFUNC CONTINUES BY EXECUTING THE FUNCTION ! 24508: # ! 24509: cfunc: #rtn ! 24510: cmpl r6,4*fargs(r10) # jump if too few arguments ! 24511: blssu cfnc1 ! 24512: cmpl r6,4*fargs(r10) # jump if correct number of args ! 24513: beqlu cfnc3 ! 24514: # ! 24515: # HERE IF TOO MANY ARGUMENTS SUPPLIED, POP THEM OFF ! 24516: # ! 24517: movl r6,r7 # copy actual number ! 24518: subl2 4*fargs(r10),r7 # get number of extra args ! 24519: moval 0[r7],r7 # convert to bytes ! 24520: addl2 r7,sp # pop off unwanted arguments ! 24521: jmp cfnc3 # jump to go off to function ! 24522: # ! 24523: # HERE IF TOO FEW ARGUMENTS ! 24524: # ! 24525: cfnc1: movl 4*fargs(r10),r7 # load required number of arguments ! 24526: cmpl r7,$nini9 # jump if case of var num of args ! 24527: beqlu cfnc3 ! 24528: subl2 r6,r7 # calculate number missing ! 24529: # set counter to control loop ! 24530: # ! 24531: # LOOP TO SUPPLY EXTRA NULL ARGUMENTS ! 24532: # ! 24533: cfnc2: movl $nulls,-(sp) # stack a null argument ! 24534: sobgtr r7,cfnc2 # loop till proper number stacked ! 24535: # ! 24536: # MERGE HERE TO JUMP TO FUNCTION ! 24537: # ! 24538: cfnc3: movl (r10),r11 # jump through fcode field ! 24539: jmp (r11) ! 24540: #page ! 24541: # ! 24542: # EXFAL -- EXIT SIGNALLING SNOBOL FAILURE ! 24543: # ! 24544: # (XL,XR) MAY BE NON-COLLECTABLE ! 24545: # BRN EXFAL JUMP TO FAIL ! 24546: # ! 24547: # EXFAL CONTINUES BY EXECUTING THE APPROPRIATE FAIL GOTO ! 24548: # ! 24549: exfal: #rtn ! 24550: movl flptr,sp # pop stack ! 24551: movl (sp),r9 # load failure offset ! 24552: addl2 r$cod,r9 # point to failure code location ! 24553: movl r9,r3 # set code pointer ! 24554: jmp exits # do next code word ! 24555: #page ! 24556: # ! 24557: # EXINT -- EXIT WITH INTEGER RESULT ! 24558: # ! 24559: # (XL,XR) MAY BE NONCOLLECTABLE ! 24560: # (IA) INTEGER VALUE ! 24561: # BRN EXINT JUMP TO EXIT WITH INTEGER ! 24562: # ! 24563: # EXINT CONTINUES BY EXECUTING THE NEXT CODE WORD ! 24564: # WHICH IT DOES BY FALLING THROUGH TO EXIXR ! 24565: # ! 24566: exint: #rtn ! 24567: jsb icbld # build icblk ! 24568: #page ! 24569: # EXIXR -- EXIT WITH RESULT IN (XR) ! 24570: # ! 24571: # (XR) RESULT ! 24572: # (XL) MAY BE NON-COLLECTABLE ! 24573: # BRN EXIXR JUMP TO EXIT WITH RESULT IN (XR) ! 24574: # ! 24575: # EXIXR CONTINUES BY EXECUTING THE NEXT CODE WORD ! 24576: # WHICH IT DOES BY FALLING THROUGH TO EXITS. ! 24577: exixr: #rtn ! 24578: # ! 24579: movl r9,-(sp) # stack result ! 24580: # ! 24581: # ! 24582: # EXITS -- EXIT WITH RESULT IF ANY STACKED ! 24583: # ! 24584: # (XR,XL) MAY BE NON-COLLECTABLE ! 24585: # ! 24586: # BRN EXITS ENTER EXITS ROUTINE ! 24587: # ! 24588: exits: #rtn ! 24589: movl (r3)+,r9 # load next code word ! 24590: movl (r9),r10 # load entry address ! 24591: movl r10,r11 # jump to execute next code word ! 24592: jmp (r11) ! 24593: #page ! 24594: # ! 24595: # EXNAM -- EXIT WITH NAME IN (XL,WA) ! 24596: # ! 24597: # (XL) NAME BASE ! 24598: # (WA) NAME OFFSET ! 24599: # (XR) MAY BE NON-COLLECTABLE ! 24600: # BRN EXNAM JUMP TO EXIT WITH NAME IN (XL,WA) ! 24601: # ! 24602: # EXNAM CONTINUES BY EXECUTING THE NEXT CODE WORD ! 24603: # ! 24604: exnam: #rtn ! 24605: movl r10,-(sp) # stack name base ! 24606: movl r6,-(sp) # stack name offset ! 24607: jmp exits # do next code word ! 24608: #page ! 24609: # ! 24610: # EXNUL -- EXIT WITH NULL RESULT ! 24611: # ! 24612: # (XL,XR) MAY BE NON-COLLECTABLE ! 24613: # BRN EXNUL JUMP TO EXIT WITH NULL VALUE ! 24614: # ! 24615: # EXNUL CONTINUES BY EXECUTING THE NEXT CODE WORD ! 24616: # ! 24617: exnul: #rtn ! 24618: movl $nulls,-(sp) # stack null value ! 24619: jmp exits # do next code word ! 24620: #page ! 24621: # ! 24622: # EXREA -- EXIT WITH REAL RESULT ! 24623: # ! 24624: # (XL,XR) MAY BE NON-COLLECTABLE ! 24625: # (RA) REAL VALUE ! 24626: # BRN EXREA JUMP TO EXIT WITH REAL VALUE ! 24627: # ! 24628: # EXREA CONTINUES BY EXECUTING THE NEXT CODE WORD ! 24629: # ! 24630: exrea: #rtn ! 24631: jsb rcbld # build rcblk ! 24632: jmp exixr # jump to exit with result in xr ! 24633: #page ! 24634: # ! 24635: # EXSID -- EXIT SETTING ID FIELD ! 24636: # ! 24637: # EXSID IS USED TO EXIT AFTER BUILDING ANY OF THE FOLLOWING ! 24638: # BLOCKS (ARBLK, TBBLK, PDBLK, VCBLK). IT SETS THE IDVAL. ! 24639: # ! 24640: # (XR) PTR TO BLOCK WITH IDVAL FIELD ! 24641: # (XL) MAY BE NON-COLLECTABLE ! 24642: # BRN EXSID JUMP TO EXIT AFTER SETTING ID FIELD ! 24643: # ! 24644: # EXSID CONTINUES BY EXECUTING THE NEXT CODE WORD ! 24645: # ! 24646: exsid: #rtn ! 24647: movl curid,r6 # load current id value ! 24648: cmpl r6,$cfp$m # jump if no overflow ! 24649: bnequ exsi1 ! 24650: clrl r6 # else reset for wraparound ! 24651: # ! 24652: # HERE WITH OLD IDVAL IN WA ! 24653: # ! 24654: exsi1: incl r6 # bump id value ! 24655: movl r6,curid # store for next time ! 24656: movl r6,4*idval(r9) # store id value ! 24657: jmp exixr # exit with result in (xr) ! 24658: #page ! 24659: # ! 24660: # EXVNM -- EXIT WITH NAME OF VARIABLE ! 24661: # ! 24662: # EXVNM EXITS AFTER STACKING A VALUE WHICH IS A NMBLK ! 24663: # REFERENCING THE NAME OF A GIVEN NATURAL VARIABLE. ! 24664: # ! 24665: # (XR) VRBLK POINTER ! 24666: # (XL) MAY BE NON-COLLECTABLE ! 24667: # BRN EXVNM EXIT WITH VRBLK POINTER IN XR ! 24668: # ! 24669: exvnm: #rtn ! 24670: movl r9,r10 # copy name base pointer ! 24671: movl $4*nmsi$,r6 # set size of nmblk ! 24672: jsb alloc # allocate nmblk ! 24673: movl $b$nml,(r9) # store type word ! 24674: movl r10,4*nmbas(r9) # store name base ! 24675: movl $4*vrval,4*nmofs(r9) # store name offset ! 24676: jmp exixr # exit with result in xr ! 24677: #page ! 24678: # ! 24679: # FLPOP -- FAIL AND POP IN PATTERN MATCHING ! 24680: # ! 24681: # FLPOP POPS THE NODE AND CURSOR ON THE STACK AND THEN ! 24682: # DROPS THROUGH INTO FAILP TO CAUSE PATTERN FAILURE ! 24683: # ! 24684: # (XL,XR) MAY BE NON-COLLECTABLE ! 24685: # BRN FLPOP JUMP TO FAIL AND POP STACK ! 24686: # ! 24687: flpop: #rtn ! 24688: addl2 $4*num02,sp # pop two entries off stack ! 24689: #page ! 24690: # ! 24691: # FAILP -- FAILURE IN MATCHING PATTERN NODE ! 24692: # ! 24693: # FAILP IS USED AFTER FAILING TO MATCH A PATTERN NODE. ! 24694: # SEE PATTERN MATCH ROUTINES FOR DETAILS OF USE. ! 24695: # ! 24696: # (XL,XR) MAY BE NON-COLLECTABLE ! 24697: # BRN FAILP SIGNAL FAILURE TO MATCH ! 24698: # ! 24699: # FAILP CONTINUES BY MATCHING AN ALTERNATIVE FROM THE STACK ! 24700: # ! 24701: failp: #rtn ! 24702: movl (sp)+,r9 # load alternative node pointer ! 24703: movl (sp)+,r7 # restore old cursor ! 24704: movl (r9),r10 # load pcode entry pointer ! 24705: movl r10,r11 # jump to execute code for node ! 24706: jmp (r11) ! 24707: #page ! 24708: # ! 24709: # INDIR -- COMPUTE INDIRECT REFERENCE ! 24710: # ! 24711: # (WB) NONZERO/ZERO FOR BY NAME/VALUE ! 24712: # BRN INDIR JUMP TO GET INDIRECT REF ON STACK ! 24713: # ! 24714: # INDIR CONTINUES BY EXECUTING THE NEXT CODE WORD ! 24715: # ! 24716: indir: #rtn ! 24717: movl (sp)+,r9 # load argument ! 24718: cmpl (r9),$b$nml # jump if a name ! 24719: beqlu indr2 ! 24720: jsb gtnvr # else convert to variable ! 24721: .long er_239 # indirection operand is not name ! 24722: tstl r7 # skip if by value ! 24723: beqlu indr1 ! 24724: movl r9,-(sp) # else stack vrblk ptr ! 24725: movl $4*vrval,-(sp) # stack name offset ! 24726: jmp exits # exit with result on stack ! 24727: # ! 24728: # HERE TO GET VALUE OF NATURAL VARIABLE ! 24729: # ! 24730: indr1: movl (r9),r11 # jump through vrget field of vrblk ! 24731: jmp (r11) ! 24732: # ! 24733: # HERE IF OPERAND IS A NAME ! 24734: # ! 24735: indr2: movl 4*nmbas(r9),r10 # load name base ! 24736: movl 4*nmofs(r9),r6 # load name offset ! 24737: tstl r7 # exit if called by name ! 24738: beqlu 0f ! 24739: jmp exnam ! 24740: 0: ! 24741: jsb acess # else get value first ! 24742: .long exfal # fail if access fails ! 24743: jmp exixr # else return with value in xr ! 24744: #page ! 24745: # ! 24746: # MATCH -- INITIATE PATTERN MATCH ! 24747: # ! 24748: # (WB) MATCH TYPE CODE ! 24749: # BRN MATCH JUMP TO INITIATE PATTERN MATCH ! 24750: # ! 24751: # MATCH CONTINUES BY EXECUTING THE PATTERN MATCH. SEE ! 24752: # PATTERN MATCH ROUTINES (P$XXX) FOR FULL DETAILS. ! 24753: # ! 24754: match: #rtn ! 24755: movl (sp)+,r9 # load pattern operand ! 24756: jsb gtpat # convert to pattern ! 24757: .long er_240 # pattern match right operand is not pattern ! 24758: movl r9,r10 # if ok, save pattern pointer ! 24759: tstl r7 # jump if not match by name ! 24760: bnequ mtch1 ! 24761: movl (sp),r6 # else load name offset ! 24762: movl r10,-(sp) # save pattern pointer ! 24763: movl 4*2(sp),r10 # load name base ! 24764: jsb acess # access subject value ! 24765: .long exfal # fail if access fails ! 24766: movl (sp),r10 # restore pattern pointer ! 24767: movl r9,(sp) # stack subject string val for merge ! 24768: clrl r7 # restore type code ! 24769: # ! 24770: # MERGE HERE WITH SUBJECT VALUE ON STACK ! 24771: # ! 24772: mtch1: movl (sp),r9 # load subject value ! 24773: clrl r$pmb # assume not a buffer ! 24774: cmpl (r9),$b$bct # branch if not ! 24775: bnequ mtcha ! 24776: addl2 $4,sp # else pop value ! 24777: movl r9,r$pmb # save pointer ! 24778: movl 4*bclen(r9),r6 # get defined length ! 24779: movl 4*bcbuf(r9),r9 # point to bfblk ! 24780: jmp mtchb ! 24781: # ! 24782: # HERE IF NOT BUFFER TO CONVERT TO STRING ! 24783: # ! 24784: mtcha: jsb gtstg # not buffer - convert to string ! 24785: .long er_241 # pattern match left operand is not string ! 24786: # ! 24787: # MERGE WITH BUFFER OR STRING ! 24788: # ! 24789: mtchb: movl r9,r$pms # if ok, store subject string pointer ! 24790: movl r6,pmssl # and length ! 24791: movl r7,-(sp) # stack match type code ! 24792: clrl -(sp) # stack initial cursor (zero) ! 24793: clrl r7 # set initial cursor ! 24794: movl sp,pmhbs # set history stack base ptr ! 24795: clrl pmdfl # reset pattern assignment flag ! 24796: movl r10,r9 # set initial node pointer ! 24797: tstl kvanc # jump if anchored ! 24798: bnequ mtch2 ! 24799: # ! 24800: # HERE FOR UNANCHORED ! 24801: # ! 24802: movl r9,-(sp) # stack initial node pointer ! 24803: movl $nduna,-(sp) # stack pointer to anchor move node ! 24804: movl (r9),r11 # start match of first node ! 24805: jmp (r11) ! 24806: # ! 24807: # HERE IN ANCHORED MODE ! 24808: # ! 24809: mtch2: clrl -(sp) # dummy cursor value ! 24810: movl $ndabo,-(sp) # stack pointer to abort node ! 24811: movl (r9),r11 # start match of first node ! 24812: jmp (r11) ! 24813: #page ! 24814: # ! 24815: # RETRN -- RETURN FROM FUNCTION ! 24816: # ! 24817: # (WA) STRING POINTER FOR RETURN TYPE ! 24818: # BRN RETRN JUMP TO RETURN FROM (SNOBOL) FUNC ! 24819: # ! 24820: # RETRN CONTINUES BY EXECUTING THE CODE AT THE RETURN POINT ! 24821: # THE STACK IS CLEANED OF ANY GARBAGE LEFT BY OTHER ! 24822: # ROUTINES WHICH MAY HAVE ALTERED FLPTR SINCE FUNCTION ! 24823: # ENTRY BY USING FLPRT, RESERVED FOR USE ONLY BY ! 24824: # FUNCTION CALL AND RETURN. ! 24825: # ! 24826: retrn: #rtn ! 24827: tstl kvfnc # jump if not level zero ! 24828: bnequ rtn01 ! 24829: jmp er_242 # function return from level zero ! 24830: # ! 24831: # HERE IF NOT LEVEL ZERO RETURN ! 24832: # ! 24833: rtn01: movl flprt,sp # pop stack ! 24834: addl2 $4,sp # remove failure offset ! 24835: movl (sp)+,r9 # pop pfblk pointer ! 24836: movl (sp)+,flptr # pop failure pointer ! 24837: movl (sp)+,flprt # pop old flprt ! 24838: movl (sp)+,r7 # pop code pointer offset ! 24839: movl (sp)+,r8 # pop old code block pointer ! 24840: addl2 r8,r7 # make old code pointer absolute ! 24841: movl r7,r3 # restore old code pointer ! 24842: movl r8,r$cod # restore old code block pointer ! 24843: decl kvfnc # decrement function level ! 24844: movl kvtra,r7 # load trace ! 24845: addl2 kvftr,r7 # add ftrace ! 24846: tstl r7 # jump if no tracing possible ! 24847: bnequ 0f ! 24848: jmp rtn06 ! 24849: 0: ! 24850: # ! 24851: # HERE IF THERE MAY BE A TRACE ! 24852: # ! 24853: movl r6,-(sp) # save function return type ! 24854: movl r9,-(sp) # save pfblk pointer ! 24855: movl r6,kvrtn # set rtntype for trace function ! 24856: movl r$fnc,r10 # load fnclevel trblk ptr (if any) ! 24857: jsb ktrex # execute possible fnclevel trace ! 24858: movl 4*pfvbl(r9),r10 # load vrblk ptr (sgd13) ! 24859: tstl kvtra # jump if trace is off ! 24860: beqlu rtn02 ! 24861: movl 4*pfrtr(r9),r9 # else load return trace trblk ptr ! 24862: tstl r9 # jump if not return traced ! 24863: beqlu rtn02 ! 24864: decl kvtra # else decrement trace count ! 24865: tstl 4*trfnc(r9) # jump if print trace ! 24866: beqlu rtn03 ! 24867: movl $4*vrval,r6 # else set name offset ! 24868: movl 4*1(sp),kvrtn # make sure rtntype is set right ! 24869: jsb trxeq # execute full trace ! 24870: #page ! 24871: # ! 24872: # RETRN (CONTINUED) ! 24873: # ! 24874: # HERE TO TEST FOR FTRACE ! 24875: # ! 24876: rtn02: tstl kvftr # jump if ftrace is off ! 24877: beqlu rtn05 ! 24878: decl kvftr # else decrement ftrace ! 24879: # ! 24880: # HERE FOR PRINT TRACE OF FUNCTION RETURN ! 24881: # ! 24882: rtn03: jsb prtsn # print statement number ! 24883: movl 4*1(sp),r9 # load return type ! 24884: jsb prtst # print it ! 24885: movl $ch$bl,r6 # load blank ! 24886: jsb prtch # print it ! 24887: movl (sp),r10 # load pfblk ptr ! 24888: movl 4*pfvbl(r10),r10# load function vrblk ptr ! 24889: movl $4*vrval,r6 # set vrblk name offset ! 24890: cmpl r9,$scfrt # jump if not freturn case ! 24891: bnequ rtn04 ! 24892: # ! 24893: # FOR FRETURN, JUST PRINT FUNCTION NAME ! 24894: # ! 24895: jsb prtnm # print name ! 24896: jsb prtnl # terminate print line ! 24897: jmp rtn05 # merge ! 24898: # ! 24899: # HERE FOR RETURN OR NRETURN, PRINT FUNCTION NAME = VALUE ! 24900: # ! 24901: rtn04: jsb prtnv # print name = value ! 24902: # ! 24903: # HERE AFTER COMPLETING TRACE ! 24904: # ! 24905: rtn05: movl (sp)+,r9 # pop pfblk pointer ! 24906: movl (sp)+,r6 # pop return type string ! 24907: # ! 24908: # MERGE HERE IF NO TRACE REQUIRED ! 24909: # ! 24910: rtn06: movl r6,kvrtn # set rtntype keyword ! 24911: movl 4*pfvbl(r9),r10 # load pointer to fn vrblk ! 24912: #page ! 24913: # RETRN (CONTINUED) ! 24914: # ! 24915: # GET VALUE OF FUNCTION ! 24916: # ! 24917: rtn07: movl r10,rtnbp # save block pointer ! 24918: movl 4*vrval(r10),r10# load value ! 24919: cmpl (r10),$b$trt # loop back if trapped ! 24920: beqlu rtn07 ! 24921: movl r10,rtnfv # else save function result value ! 24922: movl (sp)+,rtnsv # save original function value ! 24923: movl (sp)+,r10 # pop saved pointer ! 24924: tstl r10 # no action if none ! 24925: beqlu rtn7c ! 24926: tstl kvpfl # jump if no profiling ! 24927: beqlu rtn7c ! 24928: jsb prflu # else profile last func stmt ! 24929: cmpl kvpfl,$num02 # branch on value of profile keywd ! 24930: beqlu rtn7a ! 24931: # ! 24932: # HERE IF &PROFILE = 1. START TIME MUST BE FRIGGED TO ! 24933: # APPEAR EARLIER THAN IT ACTUALLY IS, BY AMOUNT USED BEFORE ! 24934: # THE CALL. ! 24935: # ! 24936: movl pfstm,r5 # load current time ! 24937: subl2 4*icval(r10),r5 # frig by subtracting saved amount ! 24938: jmp rtn7b # and merge ! 24939: # ! 24940: # HERE IF &PROFILE = 2 ! 24941: # ! 24942: rtn7a: movl 4*icval(r10),r5 # load saved time ! 24943: # ! 24944: # BOTH PROFILE TYPES MERGE HERE ! 24945: # ! 24946: rtn7b: movl r5,pfstm # store back correct start time ! 24947: # ! 24948: # MERGE HERE IF NO PROFILING ! 24949: # ! 24950: rtn7c: movl 4*fargs(r9),r7 # get number of args ! 24951: addl2 4*pfnlo(r9),r7 # add number of locals ! 24952: tstl r7 # jump if no args/locals ! 24953: beqlu rtn10 ! 24954: # else set loop counter ! 24955: addl2 4*pflen(r9),r9 # and point to end of pfblk ! 24956: # ! 24957: # LOOP TO RESTORE FUNCTIONS AND LOCALS ! 24958: # ! 24959: rtn08: movl -(r9),r10 # load next vrblk pointer ! 24960: # ! 24961: # LOOP TO FIND VALUE BLOCK ! 24962: # ! 24963: rtn09: movl r10,r6 # save block pointer ! 24964: movl 4*vrval(r10),r10# load pointer to next value ! 24965: cmpl (r10),$b$trt # loop back if trapped ! 24966: beqlu rtn09 ! 24967: movl r6,r10 # else restore last block pointer ! 24968: movl (sp)+,4*vrval(r10) # restore old variable value ! 24969: sobgtr r7,rtn08 # loop till all processed ! 24970: # ! 24971: # NOW RESTORE FUNCTION VALUE AND EXIT ! 24972: # ! 24973: rtn10: movl rtnbp,r10 # restore ptr to last function block ! 24974: movl rtnsv,4*vrval(r10) # restore old function value ! 24975: movl rtnfv,r9 # reload function result ! 24976: movl r$cod,r10 # point to new code block ! 24977: movl kvstn,kvlst # set lastno from stno ! 24978: movl 4*cdstm(r10),kvstn # reset proper stno value ! 24979: movl kvrtn,r6 # load return type ! 24980: cmpl r6,$scrtn # exit with result in xr if return ! 24981: bnequ 0f ! 24982: jmp exixr ! 24983: 0: ! 24984: cmpl r6,$scfrt # fail if freturn ! 24985: bnequ 0f ! 24986: jmp exfal ! 24987: 0: ! 24988: #page ! 24989: # ! 24990: # RETRN (CONTINUED) ! 24991: # ! 24992: # HERE FOR NRETURN ! 24993: # ! 24994: cmpl (r9),$b$nml # jump if is a name ! 24995: beqlu rtn11 ! 24996: jsb gtnvr # else try convert to variable name ! 24997: .long er_243 # function result in nreturn is not name ! 24998: movl r9,r10 # if ok, copy vrblk (name base) ptr ! 24999: movl $4*vrval,r6 # set name offset ! 25000: jmp rtn12 # and merge ! 25001: # ! 25002: # HERE IF RETURNED RESULT IS A NAME ! 25003: # ! 25004: rtn11: movl 4*nmbas(r9),r10 # load name base ! 25005: movl 4*nmofs(r9),r6 # load name offset ! 25006: # ! 25007: # MERGE HERE WITH RETURNED NAME IN (XL,WA) ! 25008: # ! 25009: rtn12: movl r10,r9 # preserve xl ! 25010: movl (r3)+,r7 # load next word ! 25011: movl r9,r10 # restore xl ! 25012: cmpl r7,$ofne$ # exit if called by name ! 25013: bnequ 0f ! 25014: jmp exnam ! 25015: 0: ! 25016: movl r7,-(sp) # else save code word ! 25017: jsb acess # get value ! 25018: .long exfal # fail if access fails ! 25019: movl r9,r10 # if ok, copy result ! 25020: movl (sp),r9 # reload next code word ! 25021: movl r10,(sp) # store result on stack ! 25022: movl (r9),r10 # load routine address ! 25023: movl r10,r11 # jump to execute next code word ! 25024: jmp (r11) ! 25025: #page ! 25026: # ! 25027: # STCOV -- SIGNAL STATEMENT COUNTER OVERFLOW ! 25028: # ! 25029: # BRN STCOV JUMP TO SIGNAL STATEMENT COUNT OFLO ! 25030: # ! 25031: # PERMIT UP TO 10 MORE STATEMENTS TO BE OBEYED SO THAT ! 25032: # SETEXIT TRAP CAN REGAIN CONTROL. ! 25033: # STCOV CONTINUES BY ISSUING THE ERROR MESSAGE ! 25034: # ! 25035: stcov: #rtn ! 25036: incl errft # fatal error ! 25037: movl intvt,r5 # get 10 ! 25038: addl2 kvstl,r5 # add to former limit ! 25039: movl r5,kvstl # store as new stlimit ! 25040: movl intvt,r5 # get 10 ! 25041: movl r5,kvstc # set as new count ! 25042: jmp er_244 # statement count exceeds value of stlimit keyword ! 25043: #page ! 25044: # ! 25045: # STMGO -- START EXECUTION OF NEW STATEMENT ! 25046: # ! 25047: # (XR) POINTER TO CDBLK FOR NEW STATEMENT ! 25048: # BRN STMGO JUMP TO EXECUTE NEW STATEMENT ! 25049: # ! 25050: # STMGO CONTINUES BY EXECUTING THE NEXT STATEMENT ! 25051: # ! 25052: stmgo: #rtn ! 25053: movl r9,r$cod # set new code block pointer ! 25054: tstl kvpfl # skip if no profiling ! 25055: beqlu stgo1 ! 25056: jsb prflu # else profile the statement ! 25057: stgo1: movl kvstn,kvlst # set lastno ! 25058: movl 4*cdstm(r9),kvstn# set stno ! 25059: addl2 $4*cdcod,r9 # point to first code word ! 25060: movl r9,r3 # set code pointer ! 25061: movl kvstc,r5 # get stmt count ! 25062: tstl r5 # omit counting if negative ! 25063: bgeq 0f ! 25064: jmp exits ! 25065: 0: ! 25066: tstl r5 # fail if stlimit reached ! 25067: beql stcov ! 25068: subl2 intv1,r5 # decrement ! 25069: movl r5,kvstc # replace it ! 25070: tstl r$stc # exit if no stcount trace ! 25071: bnequ 0f ! 25072: jmp exits ! 25073: 0: ! 25074: # ! 25075: # HERE FOR STCOUNT TRACE ! 25076: # ! 25077: clrl r9 # clear garbage value in xr ! 25078: movl r$stc,r10 # load pointer to stcount trblk ! 25079: jsb ktrex # execute keyword trace ! 25080: jmp exits # and then exit for next code word ! 25081: #page ! 25082: # ! 25083: # STOPR -- TERMINATE RUN ! 25084: # ! 25085: # (XR) POINTS TO ENDING MESSAGE ! 25086: # BRN STOPR JUMP TO TERMINATE RUN ! 25087: # ! 25088: # TERMINATE RUN AND PRINT STATISTICS. ON ENTRY XR POINTS ! 25089: # TO ENDING MESSAGE OR IS ZERO IF MESSAGE PRINTED ALREADY. ! 25090: # ! 25091: stopr: #rtn ! 25092: tstl r9 # skip if sysax already called (reg04) ! 25093: beqlu stpra ! 25094: jsb sysax # call after execution proc ! 25095: stpra: addl2 rsmem,dname # use the reserve memory ! 25096: cmpl r9,$endms # skip if not normal end message ! 25097: bnequ stpr0 ! 25098: tstl exsts # skip if exec stats suppressed ! 25099: beqlu 0f ! 25100: jmp stpr3 ! 25101: 0: ! 25102: clrl erich # clear errors to int.ch. flag ! 25103: # ! 25104: # LOOK TO SEE IF AN ENDING MESSAGE IS SUPPLIED ! 25105: # ! 25106: stpr0: jsb prtpg # eject printer ! 25107: tstl r9 # skip if no message ! 25108: beqlu stpr1 ! 25109: jsb prtst # print message ! 25110: # ! 25111: # MERGE HERE IF NO MESSAGE TO PRINT ! 25112: # ! 25113: stpr1: jsb prtis # print blank line ! 25114: movl kvstn,r5 # get statement number ! 25115: movl $stpm1,r9 # point to message /in statement xxx/ ! 25116: jsb prtmx # print it ! 25117: jsb systm # get current time ! 25118: subl2 timsx,r5 # minus start time = elapsed exec tim ! 25119: movl r5,stpti # save for later ! 25120: movl $stpm3,r9 # point to msg /execution time msec / ! 25121: jsb prtmx # print it ! 25122: movl kvstl,r5 # get statement limit ! 25123: tstl r5 # skip if negative ! 25124: blss stpr2 ! 25125: subl2 kvstc,r5 # minus counter = count ! 25126: movl r5,stpsi # save ! 25127: movl $stpm2,r9 # point to message /stmts executed/ ! 25128: jsb prtmx # print it ! 25129: movl stpti,r5 # reload elapsed time ! 25130: mull2 intth,r5 # *1000 (microsecs) ! 25131: bvs stpr2 ! 25132: divl2 stpsi,r5 # divide by statement count ! 25133: bvs stpr2 ! 25134: movl $stpm4,r9 # point to msg (mcsec per statement / ! 25135: jsb prtmx # print it ! 25136: #page ! 25137: # ! 25138: # STOPR (CONTINUED) ! 25139: # ! 25140: # MERGE TO SKIP MESSAGE (OVERFLOW OR NEGATIVE STLIMIT) ! 25141: # ! 25142: stpr2: movl gbcnt,r5 # load count of collections ! 25143: movl $stpm5,r9 # point to message /regenerations / ! 25144: jsb prtmx # print it ! 25145: jsb prtis # one more blank for luck ! 25146: # ! 25147: # CHECK IF DUMP REQUESTED ! 25148: # ! 25149: stpr3: jsb prflr # print profile if wanted ! 25150: # ! 25151: movl kvdmp,r9 # load dump keyword ! 25152: jsb dumpr # execute dump if requested ! 25153: movl r$fcb,r10 # get fcblk chain head ! 25154: movl kvabe,r6 # load abend value ! 25155: movl kvcod,r7 # load code value ! 25156: jsb sysej # exit to system ! 25157: #page ! 25158: # ! 25159: # SUCCP -- SIGNAL SUCCESSFUL MATCH OF A PATTERN NODE ! 25160: # ! 25161: # SEE PATTERN MATCH ROUTINES FOR DETAILS ! 25162: # ! 25163: # (XR) CURRENT NODE ! 25164: # (WB) CURRENT CURSOR ! 25165: # (XL) MAY BE NON-COLLECTABLE ! 25166: # BRN SUCCP SIGNAL SUCCESSFUL PATTERN MATCH ! 25167: # ! 25168: # SUCCP CONTINUES BY MATCHING THE SUCCESSOR NODE ! 25169: # ! 25170: succp: #rtn ! 25171: movl 4*pthen(r9),r9 # load successor node ! 25172: movl (r9),r10 # load node code entry address ! 25173: movl r10,r11 # jump to match successor node ! 25174: jmp (r11) ! 25175: #page ! 25176: # ! 25177: # SYSAB -- PRINT /ABNORMAL END/ AND TERMINATE ! 25178: # ! 25179: sysab: #rtn ! 25180: movl $endab,r9 # point to message ! 25181: movl $num01,kvabe # set abend flag ! 25182: jsb prtnl # skip to new line ! 25183: jmp stopr # jump to pack up ! 25184: #page ! 25185: # ! 25186: # SYSTU -- PRINT /TIME UP/ AND TERMINATE ! 25187: # ! 25188: systu: #rtn ! 25189: movl $endtu,r9 # point to message ! 25190: movl strtu,r6 # get chars /tu/ ! 25191: movl r6,kvcod # put in kvcod ! 25192: movl timup,r6 # check state of timeup switch ! 25193: movl sp,timup # set switch ! 25194: tstl r6 # stop run if already set ! 25195: beqlu 0f ! 25196: jmp stopr ! 25197: 0: ! 25198: jmp er_245 # translation/execution time expired ! 25199: #title s p i t b o l -- stack overflow section ! 25200: # ! 25201: # CONTROL COMES HERE IF THE MAIN STACK OVERFLOWS ! 25202: # ! 25203: er_001: movzwl $1,r6 ! 25204: jmp error ! 25205: er_002: movzwl $2,r6 ! 25206: jmp error ! 25207: er_003: movzwl $3,r6 ! 25208: jmp error ! 25209: er_004: movzwl $4,r6 ! 25210: jmp error ! 25211: er_005: movzwl $5,r6 ! 25212: jmp error ! 25213: er_006: movzwl $6,r6 ! 25214: jmp error ! 25215: er_007: movzwl $7,r6 ! 25216: jmp error ! 25217: er_008: movzwl $8,r6 ! 25218: jmp error ! 25219: er_009: movzwl $9,r6 ! 25220: jmp error ! 25221: er_010: movzwl $10,r6 ! 25222: jmp error ! 25223: er_011: movzwl $11,r6 ! 25224: jmp error ! 25225: er_012: movzwl $12,r6 ! 25226: jmp error ! 25227: er_013: movzwl $13,r6 ! 25228: jmp error ! 25229: er_014: movzwl $14,r6 ! 25230: jmp error ! 25231: er_015: movzwl $15,r6 ! 25232: jmp error ! 25233: er_016: movzwl $16,r6 ! 25234: jmp error ! 25235: er_017: movzwl $17,r6 ! 25236: jmp error ! 25237: er_018: movzwl $18,r6 ! 25238: jmp error ! 25239: er_019: movzwl $19,r6 ! 25240: jmp error ! 25241: er_020: movzwl $20,r6 ! 25242: jmp error ! 25243: er_021: movzwl $21,r6 ! 25244: jmp error ! 25245: er_022: movzwl $22,r6 ! 25246: jmp error ! 25247: er_023: movzwl $23,r6 ! 25248: jmp error ! 25249: er_024: movzwl $24,r6 ! 25250: jmp error ! 25251: er_025: movzwl $25,r6 ! 25252: jmp error ! 25253: er_026: movzwl $26,r6 ! 25254: jmp error ! 25255: er_027: movzwl $27,r6 ! 25256: jmp error ! 25257: er_028: movzwl $28,r6 ! 25258: jmp error ! 25259: er_029: movzwl $29,r6 ! 25260: jmp error ! 25261: er_030: movzwl $30,r6 ! 25262: jmp error ! 25263: er_031: movzwl $31,r6 ! 25264: jmp error ! 25265: er_032: movzwl $32,r6 ! 25266: jmp error ! 25267: er_033: movzwl $33,r6 ! 25268: jmp error ! 25269: er_034: movzwl $34,r6 ! 25270: jmp error ! 25271: er_035: movzwl $35,r6 ! 25272: jmp error ! 25273: er_036: movzwl $36,r6 ! 25274: jmp error ! 25275: er_037: movzwl $37,r6 ! 25276: jmp error ! 25277: er_038: movzwl $38,r6 ! 25278: jmp error ! 25279: er_039: movzwl $39,r6 ! 25280: jmp error ! 25281: er_040: movzwl $40,r6 ! 25282: jmp error ! 25283: er_041: movzwl $41,r6 ! 25284: jmp error ! 25285: er_042: movzwl $42,r6 ! 25286: jmp error ! 25287: er_043: movzwl $43,r6 ! 25288: jmp error ! 25289: er_044: movzwl $44,r6 ! 25290: jmp error ! 25291: er_045: movzwl $45,r6 ! 25292: jmp error ! 25293: er_046: movzwl $46,r6 ! 25294: jmp error ! 25295: er_047: movzwl $47,r6 ! 25296: jmp error ! 25297: er_048: movzwl $48,r6 ! 25298: jmp error ! 25299: er_049: movzwl $49,r6 ! 25300: jmp error ! 25301: er_050: movzwl $50,r6 ! 25302: jmp error ! 25303: er_051: movzwl $51,r6 ! 25304: jmp error ! 25305: er_052: movzwl $52,r6 ! 25306: jmp error ! 25307: er_053: movzwl $53,r6 ! 25308: jmp error ! 25309: er_054: movzwl $54,r6 ! 25310: jmp error ! 25311: er_055: movzwl $55,r6 ! 25312: jmp error ! 25313: er_056: movzwl $56,r6 ! 25314: jmp error ! 25315: er_057: movzwl $57,r6 ! 25316: jmp error ! 25317: er_058: movzwl $58,r6 ! 25318: jmp error ! 25319: er_059: movzwl $59,r6 ! 25320: jmp error ! 25321: er_060: movzwl $60,r6 ! 25322: jmp error ! 25323: er_061: movzwl $61,r6 ! 25324: jmp error ! 25325: er_062: movzwl $62,r6 ! 25326: jmp error ! 25327: er_063: movzwl $63,r6 ! 25328: jmp error ! 25329: er_064: movzwl $64,r6 ! 25330: jmp error ! 25331: er_065: movzwl $65,r6 ! 25332: jmp error ! 25333: er_066: movzwl $66,r6 ! 25334: jmp error ! 25335: er_067: movzwl $67,r6 ! 25336: jmp error ! 25337: er_068: movzwl $68,r6 ! 25338: jmp error ! 25339: er_069: movzwl $69,r6 ! 25340: jmp error ! 25341: er_070: movzwl $70,r6 ! 25342: jmp error ! 25343: er_071: movzwl $71,r6 ! 25344: jmp error ! 25345: er_072: movzwl $72,r6 ! 25346: jmp error ! 25347: er_073: movzwl $73,r6 ! 25348: jmp error ! 25349: er_074: movzwl $74,r6 ! 25350: jmp error ! 25351: er_075: movzwl $75,r6 ! 25352: jmp error ! 25353: er_076: movzwl $76,r6 ! 25354: jmp error ! 25355: er_077: movzwl $77,r6 ! 25356: jmp error ! 25357: er_078: movzwl $78,r6 ! 25358: jmp error ! 25359: er_079: movzwl $79,r6 ! 25360: jmp error ! 25361: er_080: movzwl $80,r6 ! 25362: jmp error ! 25363: er_081: movzwl $81,r6 ! 25364: jmp error ! 25365: er_082: movzwl $82,r6 ! 25366: jmp error ! 25367: er_083: movzwl $83,r6 ! 25368: jmp error ! 25369: er_084: movzwl $84,r6 ! 25370: jmp error ! 25371: er_085: movzwl $85,r6 ! 25372: jmp error ! 25373: er_086: movzwl $86,r6 ! 25374: jmp error ! 25375: er_087: movzwl $87,r6 ! 25376: jmp error ! 25377: er_088: movzwl $88,r6 ! 25378: jmp error ! 25379: er_089: movzwl $89,r6 ! 25380: jmp error ! 25381: er_090: movzwl $90,r6 ! 25382: jmp error ! 25383: er_091: movzwl $91,r6 ! 25384: jmp error ! 25385: er_092: movzwl $92,r6 ! 25386: jmp error ! 25387: er_093: movzwl $93,r6 ! 25388: jmp error ! 25389: er_094: movzwl $94,r6 ! 25390: jmp error ! 25391: er_095: movzwl $95,r6 ! 25392: jmp error ! 25393: er_096: movzwl $96,r6 ! 25394: jmp error ! 25395: er_097: movzwl $97,r6 ! 25396: jmp error ! 25397: er_098: movzwl $98,r6 ! 25398: jmp error ! 25399: er_099: movzwl $99,r6 ! 25400: jmp error ! 25401: er_100: movzwl $100,r6 ! 25402: jmp error ! 25403: er_101: movzwl $101,r6 ! 25404: jmp error ! 25405: er_102: movzwl $102,r6 ! 25406: jmp error ! 25407: er_103: movzwl $103,r6 ! 25408: jmp error ! 25409: er_104: movzwl $104,r6 ! 25410: jmp error ! 25411: er_105: movzwl $105,r6 ! 25412: jmp error ! 25413: er_106: movzwl $106,r6 ! 25414: jmp error ! 25415: er_107: movzwl $107,r6 ! 25416: jmp error ! 25417: er_108: movzwl $108,r6 ! 25418: jmp error ! 25419: er_109: movzwl $109,r6 ! 25420: jmp error ! 25421: er_110: movzwl $110,r6 ! 25422: jmp error ! 25423: er_111: movzwl $111,r6 ! 25424: jmp error ! 25425: er_112: movzwl $112,r6 ! 25426: jmp error ! 25427: er_113: movzwl $113,r6 ! 25428: jmp error ! 25429: er_114: movzwl $114,r6 ! 25430: jmp error ! 25431: er_115: movzwl $115,r6 ! 25432: jmp error ! 25433: er_116: movzwl $116,r6 ! 25434: jmp error ! 25435: er_117: movzwl $117,r6 ! 25436: jmp error ! 25437: er_118: movzwl $118,r6 ! 25438: jmp error ! 25439: er_119: movzwl $119,r6 ! 25440: jmp error ! 25441: er_120: movzwl $120,r6 ! 25442: jmp error ! 25443: er_121: movzwl $121,r6 ! 25444: jmp error ! 25445: er_122: movzwl $122,r6 ! 25446: jmp error ! 25447: er_123: movzwl $123,r6 ! 25448: jmp error ! 25449: er_124: movzwl $124,r6 ! 25450: jmp error ! 25451: er_125: movzwl $125,r6 ! 25452: jmp error ! 25453: er_126: movzwl $126,r6 ! 25454: jmp error ! 25455: er_127: movzwl $127,r6 ! 25456: jmp error ! 25457: er_128: movzwl $128,r6 ! 25458: jmp error ! 25459: er_129: movzwl $129,r6 ! 25460: jmp error ! 25461: er_130: movzwl $130,r6 ! 25462: jmp error ! 25463: er_131: movzwl $131,r6 ! 25464: jmp error ! 25465: er_132: movzwl $132,r6 ! 25466: jmp error ! 25467: er_133: movzwl $133,r6 ! 25468: jmp error ! 25469: er_134: movzwl $134,r6 ! 25470: jmp error ! 25471: er_135: movzwl $135,r6 ! 25472: jmp error ! 25473: er_136: movzwl $136,r6 ! 25474: jmp error ! 25475: er_137: movzwl $137,r6 ! 25476: jmp error ! 25477: er_138: movzwl $138,r6 ! 25478: jmp error ! 25479: er_139: movzwl $139,r6 ! 25480: jmp error ! 25481: er_140: movzwl $140,r6 ! 25482: jmp error ! 25483: er_141: movzwl $141,r6 ! 25484: jmp error ! 25485: er_142: movzwl $142,r6 ! 25486: jmp error ! 25487: er_143: movzwl $143,r6 ! 25488: jmp error ! 25489: er_144: movzwl $144,r6 ! 25490: jmp error ! 25491: er_145: movzwl $145,r6 ! 25492: jmp error ! 25493: er_146: movzwl $146,r6 ! 25494: jmp error ! 25495: er_147: movzwl $147,r6 ! 25496: jmp error ! 25497: er_148: movzwl $148,r6 ! 25498: jmp error ! 25499: er_149: movzwl $149,r6 ! 25500: jmp error ! 25501: er_150: movzwl $150,r6 ! 25502: jmp error ! 25503: er_151: movzwl $151,r6 ! 25504: jmp error ! 25505: er_152: movzwl $152,r6 ! 25506: jmp error ! 25507: er_153: movzwl $153,r6 ! 25508: jmp error ! 25509: er_154: movzwl $154,r6 ! 25510: jmp error ! 25511: er_155: movzwl $155,r6 ! 25512: jmp error ! 25513: er_156: movzwl $156,r6 ! 25514: jmp error ! 25515: er_157: movzwl $157,r6 ! 25516: jmp error ! 25517: er_158: movzwl $158,r6 ! 25518: jmp error ! 25519: er_159: movzwl $159,r6 ! 25520: jmp error ! 25521: er_160: movzwl $160,r6 ! 25522: jmp error ! 25523: er_161: movzwl $161,r6 ! 25524: jmp error ! 25525: er_162: movzwl $162,r6 ! 25526: jmp error ! 25527: er_163: movzwl $163,r6 ! 25528: jmp error ! 25529: er_164: movzwl $164,r6 ! 25530: jmp error ! 25531: er_165: movzwl $165,r6 ! 25532: jmp error ! 25533: er_166: movzwl $166,r6 ! 25534: jmp error ! 25535: er_167: movzwl $167,r6 ! 25536: jmp error ! 25537: er_168: movzwl $168,r6 ! 25538: jmp error ! 25539: er_169: movzwl $169,r6 ! 25540: jmp error ! 25541: er_170: movzwl $170,r6 ! 25542: jmp error ! 25543: er_171: movzwl $171,r6 ! 25544: jmp error ! 25545: er_172: movzwl $172,r6 ! 25546: jmp error ! 25547: er_173: movzwl $173,r6 ! 25548: jmp error ! 25549: er_174: movzwl $174,r6 ! 25550: jmp error ! 25551: er_175: movzwl $175,r6 ! 25552: jmp error ! 25553: er_176: movzwl $176,r6 ! 25554: jmp error ! 25555: er_177: movzwl $177,r6 ! 25556: jmp error ! 25557: er_178: movzwl $178,r6 ! 25558: jmp error ! 25559: er_179: movzwl $179,r6 ! 25560: jmp error ! 25561: er_180: movzwl $180,r6 ! 25562: jmp error ! 25563: er_181: movzwl $181,r6 ! 25564: jmp error ! 25565: er_182: movzwl $182,r6 ! 25566: jmp error ! 25567: er_183: movzwl $183,r6 ! 25568: jmp error ! 25569: er_184: movzwl $184,r6 ! 25570: jmp error ! 25571: er_185: movzwl $185,r6 ! 25572: jmp error ! 25573: er_186: movzwl $186,r6 ! 25574: jmp error ! 25575: er_187: movzwl $187,r6 ! 25576: jmp error ! 25577: er_188: movzwl $188,r6 ! 25578: jmp error ! 25579: er_189: movzwl $189,r6 ! 25580: jmp error ! 25581: er_190: movzwl $190,r6 ! 25582: jmp error ! 25583: er_191: movzwl $191,r6 ! 25584: jmp error ! 25585: er_192: movzwl $192,r6 ! 25586: jmp error ! 25587: er_193: movzwl $193,r6 ! 25588: jmp error ! 25589: er_194: movzwl $194,r6 ! 25590: jmp error ! 25591: er_195: movzwl $195,r6 ! 25592: jmp error ! 25593: er_196: movzwl $196,r6 ! 25594: jmp error ! 25595: er_197: movzwl $197,r6 ! 25596: jmp error ! 25597: er_198: movzwl $198,r6 ! 25598: jmp error ! 25599: er_199: movzwl $199,r6 ! 25600: jmp error ! 25601: er_200: movzwl $200,r6 ! 25602: jmp error ! 25603: er_201: movzwl $201,r6 ! 25604: jmp error ! 25605: er_202: movzwl $202,r6 ! 25606: jmp error ! 25607: er_203: movzwl $203,r6 ! 25608: jmp error ! 25609: er_204: movzwl $204,r6 ! 25610: jmp error ! 25611: er_205: movzwl $205,r6 ! 25612: jmp error ! 25613: er_206: movzwl $206,r6 ! 25614: jmp error ! 25615: er_207: movzwl $207,r6 ! 25616: jmp error ! 25617: er_208: movzwl $208,r6 ! 25618: jmp error ! 25619: er_209: movzwl $209,r6 ! 25620: jmp error ! 25621: er_210: movzwl $210,r6 ! 25622: jmp error ! 25623: er_211: movzwl $211,r6 ! 25624: jmp error ! 25625: er_212: movzwl $212,r6 ! 25626: jmp error ! 25627: er_213: movzwl $213,r6 ! 25628: jmp error ! 25629: er_214: movzwl $214,r6 ! 25630: jmp error ! 25631: er_215: movzwl $215,r6 ! 25632: jmp error ! 25633: er_216: movzwl $216,r6 ! 25634: jmp error ! 25635: er_217: movzwl $217,r6 ! 25636: jmp error ! 25637: er_218: movzwl $218,r6 ! 25638: jmp error ! 25639: er_219: movzwl $219,r6 ! 25640: jmp error ! 25641: er_220: movzwl $220,r6 ! 25642: jmp error ! 25643: er_221: movzwl $221,r6 ! 25644: jmp error ! 25645: er_222: movzwl $222,r6 ! 25646: jmp error ! 25647: er_223: movzwl $223,r6 ! 25648: jmp error ! 25649: er_224: movzwl $224,r6 ! 25650: jmp error ! 25651: er_225: movzwl $225,r6 ! 25652: jmp error ! 25653: er_226: movzwl $226,r6 ! 25654: jmp error ! 25655: er_227: movzwl $227,r6 ! 25656: jmp error ! 25657: er_228: movzwl $228,r6 ! 25658: jmp error ! 25659: er_229: movzwl $229,r6 ! 25660: jmp error ! 25661: er_230: movzwl $230,r6 ! 25662: jmp error ! 25663: er_231: movzwl $231,r6 ! 25664: jmp error ! 25665: er_232: movzwl $232,r6 ! 25666: jmp error ! 25667: er_233: movzwl $233,r6 ! 25668: jmp error ! 25669: er_234: movzwl $234,r6 ! 25670: jmp error ! 25671: er_235: movzwl $235,r6 ! 25672: jmp error ! 25673: er_236: movzwl $236,r6 ! 25674: jmp error ! 25675: er_237: movzwl $237,r6 ! 25676: jmp error ! 25677: er_238: movzwl $238,r6 ! 25678: jmp error ! 25679: er_239: movzwl $239,r6 ! 25680: jmp error ! 25681: er_240: movzwl $240,r6 ! 25682: jmp error ! 25683: er_241: movzwl $241,r6 ! 25684: jmp error ! 25685: er_242: movzwl $242,r6 ! 25686: jmp error ! 25687: er_243: movzwl $243,r6 ! 25688: jmp error ! 25689: er_244: movzwl $244,r6 ! 25690: jmp error ! 25691: er_245: movzwl $245,r6 ! 25692: jmp error ! 25693: er_246: movzwl $246,r6 ! 25694: jmp error ! 25695: er_247: movzwl $247,r6 ! 25696: jmp error ! 25697: er_248: movzwl $248,r6 ! 25698: jmp error ! 25699: er_249: movzwl $249,r6 ! 25700: jmp error ! 25701: er_250: movzwl $250,r6 ! 25702: jmp error ! 25703: er_251: movzwl $251,r6 ! 25704: jmp error ! 25705: er_252: movzwl $252,r6 ! 25706: jmp error ! 25707: er_253: movzwl $253,r6 ! 25708: jmp error ! 25709: er_254: movzwl $254,r6 ! 25710: jmp error ! 25711: er_255: movzwl $255,r6 ! 25712: jmp error ! 25713: er_256: movzwl $256,r6 ! 25714: jmp error ! 25715: er_257: movzwl $257,r6 ! 25716: jmp error ! 25717: er_258: movzwl $258,r6 ! 25718: jmp error ! 25719: er_259: movzwl $259,r6 ! 25720: jmp error ! 25721: er_260: movzwl $260,r6 ! 25722: jmp error ! 25723: er_261: movzwl $261,r6 ! 25724: jmp error ! 25725: er_262: movzwl $262,r6 ! 25726: jmp error ! 25727: er_263: movzwl $263,r6 ! 25728: jmp error ! 25729: er_264: movzwl $264,r6 ! 25730: jmp error ! 25731: er_265: movzwl $265,r6 ! 25732: jmp error ! 25733: er_266: movzwl $266,r6 ! 25734: jmp error ! 25735: er_267: movzwl $267,r6 ! 25736: jmp error ! 25737: er_268: movzwl $268,r6 ! 25738: jmp error ! 25739: er_269: movzwl $269,r6 ! 25740: jmp error ! 25741: er_270: movzwl $270,r6 ! 25742: jmp error ! 25743: er_271: movzwl $271,r6 ! 25744: jmp error ! 25745: er_272: movzwl $272,r6 ! 25746: jmp error ! 25747: er_273: movzwl $273,r6 ! 25748: jmp error ! 25749: er_274: movzwl $274,r6 ! 25750: jmp error ! 25751: er_275: movzwl $275,r6 ! 25752: jmp error ! 25753: er_276: movzwl $276,r6 ! 25754: jmp error ! 25755: er_277: movzwl $277,r6 ! 25756: jmp error ! 25757: er_278: movzwl $278,r6 ! 25758: jmp error ! 25759: er_279: movzwl $279,r6 ! 25760: jmp error ! 25761: er_280: movzwl $280,r6 ! 25762: jmp error ! 25763: er_281: movzwl $281,r6 ! 25764: jmp error ! 25765: er_282: movzwl $282,r6 ! 25766: jmp error ! 25767: er_283: movzwl $283,r6 ! 25768: jmp error ! 25769: er_284: movzwl $284,r6 ! 25770: jmp error ! 25771: er_285: movzwl $285,r6 ! 25772: jmp error ! 25773: er_286: movzwl $286,r6 ! 25774: jmp error ! 25775: er_287: movzwl $287,r6 ! 25776: jmp error ! 25777: er_288: movzwl $288,r6 ! 25778: jmp error ! 25779: er_289: movzwl $289,r6 ! 25780: jmp error ! 25781: er_290: movzwl $290,r6 ! 25782: jmp error ! 25783: er_291: movzwl $291,r6 ! 25784: jmp error ! 25785: er_292: movzwl $292,r6 ! 25786: jmp error ! 25787: er_293: movzwl $293,r6 ! 25788: jmp error ! 25789: er_294: movzwl $294,r6 ! 25790: jmp error ! 25791: er_295: movzwl $295,r6 ! 25792: jmp error ! 25793: er_296: movzwl $296,r6 ! 25794: jmp error ! 25795: er_297: movzwl $297,r6 ! 25796: jmp error ! 25797: .globl sec05 ! 25798: sec05: ! 25799: #sec # start of stack overflow section ! 25800: # ! 25801: incl errft # fatal error ! 25802: movl flptr,sp # pop stack to avoid more fails ! 25803: tstl gbcfl # jump if garbage collecting ! 25804: bnequ stak1 ! 25805: jmp er_246 # stack overflow ! 25806: # ! 25807: # NO CHANCE OF RECOVERY IN MID GARBAGE COLLECTION ! 25808: # ! 25809: stak1: movl $endso,r9 # point to message ! 25810: clrl kvdmp # memory is undumpable ! 25811: jmp stopr # give up ! 25812: #title s p i t b o l -- error section ! 25813: # ! 25814: # THIS SECTION OF CODE IS ENTERED WHENEVER A PROCEDURE ! 25815: # RETURN VIA AN ERR PARAMETER OR AN ERB OPCODE IS OBEYED. ! 25816: # ! 25817: # (WA) IS THE ERROR CODE ! 25818: # ! 25819: # THE GLOBAL VARIABLE STAGE INDICATES THE POINT AT WHICH ! 25820: # THE ERROR OCCURED AS FOLLOWS. ! 25821: # ! 25822: # STAGE=STGIC ERROR DURING INITIAL COMPILE ! 25823: # ! 25824: # STAGE=STGXC ERROR DURING COMPILE AT EXECUTE ! 25825: # TIME (CODE, CONVERT FUNCTION CALLS) ! 25826: # ! 25827: # STAGE=STGEV ERROR DURING COMPILATION OF ! 25828: # EXPRESSION AT EXECUTION TIME ! 25829: # (EVAL, CONVERT FUNCTION CALL). ! 25830: # ! 25831: # STAGE=STGXT ERROR AT EXECUTE TIME. COMPILER ! 25832: # NOT ACTIVE. ! 25833: # ! 25834: # STAGE=STGCE ERROR DURING INITIAL COMPILE AFTER ! 25835: # SCANNING OUT THE END LINE. ! 25836: # ! 25837: # STAGE=STGXE ERROR DURING COMPILE AT EXECUTE ! 25838: # TIME AFTER SCANNING END LINE. ! 25839: # ! 25840: # STAGE=STGEE ERROR DURING EXPRESSION EVALUATION ! 25841: # ! 25842: #sec # start of error section ! 25843: # ! 25844: error: cmpl r$cim,$cmlab # jump if error in scanning label ! 25845: bnequ 0f ! 25846: jmp cmple ! 25847: 0: ! 25848: movl r6,kvert # save error code ! 25849: clrl scnrs # reset rescan switch for scane ! 25850: clrl scngo # reset goto switch for scane ! 25851: movl stage,r9 # load current stage ! 25852: casel r9,$0,$stgno # jump to appropriate error circuit ! 25853: 5: ! 25854: .word err01-5b # initial compile ! 25855: .word err04-5b # execute time compile ! 25856: .word err04-5b # eval compiling expr. ! 25857: .word err05-5b # execute time ! 25858: .word err01-5b # compile - after end ! 25859: .word err04-5b # xeq compile-past end ! 25860: .word err04-5b # eval evaluating expr ! 25861: #esw # end switch on error type ! 25862: #page ! 25863: # ! 25864: # ERROR DURING INITIAL COMPILE ! 25865: # ! 25866: # THE ERROR MESSAGE IS PRINTED AS PART OF THE COMPILER ! 25867: # OUTPUT. THIS PRINTOUT INCLUDES THE OFFENDING LINE (IF NOT ! 25868: # PRINTED ALREADY) AND AN ERROR FLAG UNDER THE APPROPRIATE ! 25869: # COLUMN AS INDICATED BY SCNSE UNLESS SCNSE IS SET TO ZERO. ! 25870: # ! 25871: # AFTER PRINTING THE MESSAGE, THE GENERATED CODE IS ! 25872: # MODIFIED TO AN ERROR CALL AND CONTROL IS RETURNED TO ! 25873: # THE CMPIL PROCEDURE AFTER RESETTING THE STACK POINTER. ! 25874: # ! 25875: # IF THE ERROR OCCURS AFTER THE END LINE, CONTROL RETURNS ! 25876: # IN A SLIGHTLY DIFFERENT MANNER TO ENSURE PROPER CLEANUP. ! 25877: # ! 25878: err01: movl cmpxs,sp # reset stack pointer ! 25879: #ssl cmpss # restore s-r stack ptr for cmpil ! 25880: tstl errsp # jump if error suppress flag set ! 25881: beqlu 0f ! 25882: jmp err03 ! 25883: 0: ! 25884: movl erich,erlst # set flag for listr ! 25885: jsb listr # list line ! 25886: jsb prtis # terminate listing ! 25887: clrl erlst # clear listr flag ! 25888: movl scnse,r6 # load scan element offset ! 25889: tstl r6 # skip if not set ! 25890: beqlu err02 ! 25891: movl r6,r7 # loop counter ! 25892: incl r6 # increase for ch$ex ! 25893: jsb alocs # string block for error flag ! 25894: movl r9,r6 # remember string ptr ! 25895: movab cfp$f(r9),r9 # ready for character storing ! 25896: movl r$cim,r10 # point to bad statement ! 25897: movab cfp$f(r10),r10 # ready to get chars ! 25898: # ! 25899: # LOOP TO REPLACE ALL CHARS BUT TABS BY BLANKS ! 25900: # ! 25901: erra1: movzbl (r10)+,r8 # get next char ! 25902: cmpl r8,$ch$ht # skip if tab ! 25903: beqlu erra2 ! 25904: movl $ch$bl,r8 # get a blank ! 25905: #page ! 25906: # ! 25907: # MERGE TO STORE BLANK OR TAB IN ERROR LINE ! 25908: # ! 25909: erra2: movb r8,(r9)+ # store char ! 25910: sobgtr r7,erra1 # loop ! 25911: movl $ch$ex,r10 # exclamation mark ! 25912: movb r10,(r9) # store at end of error line ! 25913: #csc r9 # end of sch loop ! 25914: movl $stnpd,profs # allow for statement number ! 25915: movl r6,r9 # point to error line ! 25916: jsb prtst # print error line ! 25917: # ! 25918: # HERE AFTER PLACING ERROR FLAG AS REQUIRED ! 25919: # ! 25920: err02: jsb ermsg # generate flag and error message ! 25921: addl2 $num03,lstlc # bump page ctr for blank, error, blk ! 25922: clrl r9 # in case of fatal error ! 25923: cmpl errft,$num03 # pack up if several fatals ! 25924: blssu 0f ! 25925: jmp stopr ! 25926: 0: ! 25927: # ! 25928: # COUNT ERROR, INHIBIT EXECUTION IF REQUIRED ! 25929: # ! 25930: incl cmerc # bump error count ! 25931: addl2 cswer,noxeq # inhibit xeq if -noerrors ! 25932: cmpl stage,$stgic # special return if after end line ! 25933: beqlu 0f ! 25934: jmp cmp10 ! 25935: 0: ! 25936: #page ! 25937: # ! 25938: # LOOP TO SCAN TO END OF STATEMENT ! 25939: # ! 25940: err03: movl r$cim,r9 # point to start of image ! 25941: movab cfp$f(r9),r9 # point to first char ! 25942: movzbl (r9),r9 # get first char ! 25943: cmpl r9,$ch$mn # jump if error in control card ! 25944: bnequ 0f ! 25945: jmp cmpce ! 25946: 0: ! 25947: clrl scnrs # clear rescan flag ! 25948: movl sp,errsp # set error suppress flag ! 25949: jsb scane # scan next element ! 25950: cmpl r10,$t$smc # loop back if not statement end ! 25951: beqlu 0f ! 25952: jmp err03 ! 25953: 0: ! 25954: clrl errsp # clear error suppress flag ! 25955: # ! 25956: # GENERATE ERROR CALL IN CODE AND RETURN TO CMPIL ! 25957: # ! 25958: movl $4*cdcod,cwcof # reset offset in ccblk ! 25959: movl $ocer$,r6 # load compile error call ! 25960: jsb cdwrd # generate it ! 25961: movl cwcof,4*cmsoc(sp)# set success fill in offset ! 25962: movl sp,4*cmffc(sp) # set failure fill in flag ! 25963: jsb cdwrd # generate succ. fill in word ! 25964: jmp cmpse # merge to generate error as cdfal ! 25965: # ! 25966: # ERROR DURING EXECUTE TIME COMPILE OR EXPRESSION EVALUATIO ! 25967: # ! 25968: # EXECUTE TIME COMPILATION IS INITIATED THROUGH GTCOD OR ! 25969: # GTEXP WHICH ARE CALLED BY COMPILE, CODE OR EVAL. ! 25970: # BEFORE CAUSING STATEMENT FAILURE THROUGH EXFAL IT IS ! 25971: # HELPFUL TO SET KEYWORD ERRTEXT AND FOR GENERALITY ! 25972: # THESE ERRORS MAY BE HANDLED BY THE SETEXIT MECHANISM. ! 25973: # ! 25974: err04: clrl r$ccb # forget garbage code block ! 25975: #ssl iniss # restore main prog s-r stack ptr ! 25976: jsb ertex # get fail message text ! 25977: subl2 $4,sp # ensure stack ok on loop start ! 25978: # ! 25979: # POP STACK UNTIL FIND FLPTR FOR MOST DEEPLY NESTED PROG. ! 25980: # DEFINED FUNCTION CALL OR CALL OF EVAL / CODE. ! 25981: # ! 25982: erra4: addl2 $4,sp # pop stack ! 25983: cmpl sp,flprt # jump if prog defined fn call found ! 25984: beqlu errc4 ! 25985: cmpl sp,gtcef # loop if not eval or code call yet ! 25986: bnequ erra4 ! 25987: movl $stgxt,stage # re-set stage for execute ! 25988: movl r$gtc,r$cod # recover code ptr ! 25989: movl sp,flptr # restore fail pointer ! 25990: clrl r$cim # forget possible image ! 25991: # ! 25992: # TEST ERRLIMIT ! 25993: # ! 25994: errb4: tstl kverl # jump if errlimit non-zero ! 25995: bnequ err07 ! 25996: jmp exfal # fail ! 25997: # ! 25998: # RETURN FROM PROG. DEFINED FUNCTION IS OUTSTANDING ! 25999: # ! 26000: errc4: movl flptr,sp # restore stack from flptr ! 26001: jmp errb4 # merge ! 26002: #page ! 26003: # ! 26004: # ERROR AT EXECUTE TIME. ! 26005: # ! 26006: # THE ACTION TAKEN ON AN ERROR IS AS FOLLOWS. ! 26007: # ! 26008: # IF ERRLIMIT KEYWORD IS ZERO, AN ABORT IS SIGNALLED, ! 26009: # SEE CODING FOR SYSTEM LABEL ABORT AT L$ABO. ! 26010: # ! 26011: # OTHERWISE, ERRLIMIT IS DECREMENTED AND AN ERRTYPE TRACE ! 26012: # GENERATED IF REQUIRED. CONTROL RETURNS EITHER VIA A JUMP ! 26013: # TO CONTINUE (TO TAKE THE FAILURE EXIT) OR A SPECIFIED ! 26014: # SETEXIT TRAP IS EXECUTED AND CONTROL PASSES TO THE TRAP. ! 26015: # IF 3 OR MORE FATAL ERRORS OCCUR AN ABORT IS SIGNALLED ! 26016: # REGARDLESS OF ERRLIMIT AND SETEXIT - LOOPING IS ALL TOO ! 26017: # PROBABLE OTHERWISE. FATAL ERRORS INCLUDE STACK OVERFLOW ! 26018: # AND EXCEEDING STLIMIT. ! 26019: # ! 26020: err05: #ssl iniss # restore main prog s-r stack ptr ! 26021: tstl dmvch # jump if in mid-dump ! 26022: bnequ err08 ! 26023: # ! 26024: # MERGE HERE FROM ERR08 ! 26025: # ! 26026: err06: tstl kverl # abort if errlimit is zero ! 26027: bnequ 0f ! 26028: jmp labo1 ! 26029: 0: ! 26030: jsb ertex # get fail message text ! 26031: # ! 26032: # MERGE FROM ERR04 ! 26033: # ! 26034: err07: cmpl errft,$num03 # abort if too many fatal errors ! 26035: blssu 0f ! 26036: jmp labo1 ! 26037: 0: ! 26038: decl kverl # decrement errlimit ! 26039: movl r$ert,r10 # load errtype trace pointer ! 26040: jsb ktrex # generate errtype trace if required ! 26041: movl r$cod,r$cnt # set cdblk ptr for continuation ! 26042: movl flptr,r9 # set ptr to failure offset ! 26043: movl (r9),stxof # save failure offset for continue ! 26044: movl r$sxc,r9 # load setexit cdblk pointer ! 26045: tstl r9 # continue if no setexit trap ! 26046: bnequ 0f ! 26047: jmp lcnt1 ! 26048: 0: ! 26049: clrl r$sxc # else reset trap ! 26050: movl $nulls,stxvr # reset setexit arg to null ! 26051: movl (r9),r10 # load ptr to code block routine ! 26052: movl r10,r11 # execute first trap statement ! 26053: jmp (r11) ! 26054: # ! 26055: # INTERRUPTED PARTLY THROUGH A DUMP WHILST STORE IS IN A ! 26056: # MESS SO DO A TIDY UP OPERATION. SEE DUMPR FOR DETAILS. ! 26057: # ! 26058: err08: movl dmvch,r9 # chain head for affected vrblks ! 26059: tstl r9 # done if zero ! 26060: beqlu err06 ! 26061: movl (r9),dmvch # set next link as chain head ! 26062: jsb setvr # restore vrget field ! 26063: jmp err08 # loop through chain ! 26064: #title s p i t b o l -- here endeth the code ! 26065: # ! 26066: # END OF ASSEMBLY ! 26067: # ! 26068: #end # end macro-spitbol assembly
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.