![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to spitv35.s 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.s 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: beqlu ini13 # skip if no terminal ! 6299: jsb prpar # associate terminal ! 6300: #page ! 6301: # ! 6302: # CHECK FOR EXPIRY DATE ! 6303: # ! 6304: ini13: jsb sysdc # call date check ! 6305: movl sp,flptr # in case stack overflows in compiler ! 6306: # ! 6307: # NOW COMPILE SOURCE INPUT CODE ! 6308: # ! 6309: jsb cmpil # call compiler ! 6310: movl r9,r$cod # set ptr to first code block ! 6311: movl $nulls,r$ttl # forget title (reg04) ! 6312: movl $nulls,r$stl # forget sub-title (reg04) ! 6313: clrl r$cim # forget compiler input image ! 6314: clrl r10 # clear dud value ! 6315: clrl r7 # dont shift dynamic store up ! 6316: jsb gbcol # clear garbage left from compile ! 6317: tstl cpsts # skip if no listing of comp stats ! 6318: beqlu 0f ! 6319: jmp inix0 ! 6320: 0: ! 6321: jsb prtpg # eject page ! 6322: # ! 6323: # PRINT COMPILE STATISTICS ! 6324: # ! 6325: movl dnamp,r6 # next available loc ! 6326: subl2 statb,r6 # minus start ! 6327: ashl $-2,r6,r6 # convert to words ! 6328: movl r6,r5 # convert to integer ! 6329: movl $encm1,r9 # point to /memory used (words)/ ! 6330: jsb prtmi # print message ! 6331: movl dname,r6 # end of memory ! 6332: subl2 dnamp,r6 # minus next available loc ! 6333: ashl $-2,r6,r6 # convert to words ! 6334: movl r6,r5 # convert to integer ! 6335: movl $encm2,r9 # point to /memory available (words)/ ! 6336: jsb prtmi # print line ! 6337: movl cmerc,r5 # get count of errors as integer ! 6338: movl $encm3,r9 # point to /compile errors/ ! 6339: jsb prtmi # print it ! 6340: movl gbcnt,r5 # garbage collection count ! 6341: subl2 intv1,r5 # adjust for unavoidable collect ! 6342: movl $stpm5,r9 # point to /storage regenerations/ ! 6343: jsb prtmi # print gbcol count ! 6344: jsb systm # get time ! 6345: subl2 timsx,r5 # get compilation time ! 6346: movl $encm4,r9 # point to compilation time (msec)/ ! 6347: jsb prtmi # print message ! 6348: addl2 $num05,lstlc # bump line count ! 6349: tstl headp # no eject if nothing printed (sdg11) ! 6350: bnequ 0f ! 6351: jmp inix0 ! 6352: 0: ! 6353: jsb prtpg # eject printer ! 6354: #page ! 6355: # ! 6356: # PREPARE NOW TO START EXECUTION ! 6357: # ! 6358: # SET DEFAULT INPUT RECORD LENGTH ! 6359: # ! 6360: inix0: cmpl cswin,$iniln # skip if not default -in72 used ! 6361: bgtru inix1 ! 6362: movl $inils,cswin # else use default record length ! 6363: # ! 6364: # RESET TIMER ! 6365: # ! 6366: inix1: jsb systm # get time again ! 6367: movl r5,timsx # store for end run processing ! 6368: addl2 cswex,noxeq # add -noexecute flag ! 6369: bnequ inix2 # jump if execution suppressed ! 6370: clrl gbcnt # initialise collect count ! 6371: jsb sysbx # call before starting execution ! 6372: # ! 6373: # MERGE WHEN LISTING FILE SET FOR EXECUTION ! 6374: # ! 6375: iniy0: movl sp,headp # mark headers out regardless ! 6376: clrl -(sp) # set failure location on stack ! 6377: movl sp,flptr # save ptr to failure offset word ! 6378: movl r$cod,r9 # load ptr to entry code block ! 6379: movl $stgxt,stage # set stage for execute time ! 6380: movl cmpsn,pfnte # copy stmts compiled count in case ! 6381: jsb systm # time yet again ! 6382: movl r5,pfstm ! 6383: movl (r9),r11 # start xeq with first statement ! 6384: jmp (r11) ! 6385: # ! 6386: # HERE IF EXECUTION IS SUPPRESSED ! 6387: # ! 6388: inix2: jsb prtnl # print a blank line ! 6389: movl $encm5,r9 # point to /execution suppressed/ ! 6390: jsb prtst # print string ! 6391: jsb prtnl # output line ! 6392: clrl r6 # set abend value to zero ! 6393: movl $nini9,r7 # set special code value ! 6394: jsb sysej # end of job, exit to system ! 6395: #title s p i t b o l -- snobol4 operator routines ! 6396: # ! 6397: # THIS SECTION INCLUDES ALL ROUTINES WHICH CAN BE ACCESSED ! 6398: # DIRECTLY FROM THE GENERATED CODE EXCEPT SYSTEM FUNCTIONS. ! 6399: # ! 6400: # ALL ROUTINES IN THIS SECTION START WITH A LABEL OF THE ! 6401: # FORM O$XXX WHERE XXX IS THREE LETTERS. THE GENERATED CODE ! 6402: # CONTAINS A POINTER TO THE APPROPRIATE ENTRY LABEL. ! 6403: # ! 6404: # SINCE THE GENERAL FORM OF THE GENERATED CODE CONSISTS OF ! 6405: # POINTERS TO BLOCKS WHOSE FIRST WORD IS THE ADDRESS OF THE ! 6406: # ACTUAL ENTRY POINT LABEL (O$XXX). ! 6407: # ! 6408: # THESE ROUTINES ARE IN ALPHABETICAL ORDER BY THEIR ! 6409: # ENTRY LABEL NAMES (I.E. BY THE XXX OF THE O$XXX NAME) ! 6410: # ! 6411: # THESE ROUTINES RECEIVE CONTROL AS FOLLOWS ! 6412: # ! 6413: # (CP) POINTER TO NEXT CODE WORD ! 6414: # (XS) CURRENT STACK POINTER ! 6415: #page ! 6416: # ! 6417: # BINARY PLUS (ADDITION) ! 6418: # ! 6419: o$add: # entry point ! 6420: jsb arith # fetch arithmetic operands ! 6421: .long er_001 # addition left operand is not numeric ! 6422: .long er_002 # addition right operand is not numeric ! 6423: .long oadd1 # jump if real operands ! 6424: # ! 6425: # HERE TO ADD TWO INTEGERS ! 6426: # ! 6427: addl2 4*icval(r10),r5 # add right operand to left ! 6428: bvs 0f ! 6429: jmp exint ! 6430: 0: ! 6431: jmp er_003 # addition caused integer overflow ! 6432: # ! 6433: # HERE TO ADD TWO REALS ! 6434: # ! 6435: oadd1: addf2 4*rcval(r10),r2 # add right operand to left ! 6436: bvs 0f ! 6437: jmp exrea ! 6438: 0: ! 6439: jmp er_261 # addition caused real overflow ! 6440: #page ! 6441: # ! 6442: # UNARY PLUS (AFFIRMATION) ! 6443: # ! 6444: o$aff: # entry point ! 6445: movl (sp)+,r9 # load operand ! 6446: jsb gtnum # convert to numeric ! 6447: .long er_004 # affirmation operand is not numeric ! 6448: jmp exixr # return if converted to numeric ! 6449: #page ! 6450: # ! 6451: # BINARY BAR (ALTERNATION) ! 6452: # ! 6453: o$alt: # entry point ! 6454: movl (sp)+,r9 # load right operand ! 6455: jsb gtpat # convert to pattern ! 6456: .long er_005 # alternation right operand is not pattern ! 6457: # ! 6458: # MERGE HERE FROM SPECIAL (LEFT ALTERNATION) CASE ! 6459: # ! 6460: oalt1: movl $p$alt,r7 # set pcode for alternative node ! 6461: jsb pbild # build alternative node ! 6462: movl r9,r10 # save address of alternative node ! 6463: movl (sp)+,r9 # load left operand ! 6464: jsb gtpat # convert to pattern ! 6465: .long er_006 # alternation left operand is not pattern ! 6466: cmpl r9,$p$alt # jump if left arg is alternation ! 6467: beqlu oalt2 ! 6468: movl r9,4*pthen(r10) # set left operand as successor ! 6469: movl r10,r9 # move result to proper register ! 6470: jmp exixr # jump for next code word ! 6471: # ! 6472: # COME HERE IF LEFT ARGUMENT IS ITSELF AN ALTERNATION ! 6473: # ! 6474: # THE RESULT IS MORE EFFICIENT IF WE MAKE THE REPLACEMENT ! 6475: # ! 6476: # (A / B) / C = A / (B / C) ! 6477: # ! 6478: oalt2: movl 4*parm1(r9),4*pthen(r10) # build the (b / c) node ! 6479: movl 4*pthen(r9),-(sp)# set a as new left arg ! 6480: movl r10,r9 # set (b / c) as new right arg ! 6481: jmp oalt1 # merge back to build a / (b / c) ! 6482: #page ! 6483: # ! 6484: # ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY NAME) ! 6485: # ! 6486: o$amn: # entry point ! 6487: movl (r3)+,r9 # load number of subscripts ! 6488: movl r9,r7 # set flag for by name ! 6489: jmp arref # jump to array reference routine ! 6490: #page ! 6491: # ! 6492: # ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY VALUE) ! 6493: # ! 6494: o$amv: # entry point ! 6495: movl (r3)+,r9 # load number of subscripts ! 6496: clrl r7 # set flag for by value ! 6497: jmp arref # jump to array reference routine ! 6498: #page ! 6499: # ! 6500: # ARRAY REFERENCE (ONE SUBSCRIPT, BY NAME) ! 6501: # ! 6502: o$aon: # entry point ! 6503: movl (sp),r9 # load subscript value ! 6504: movl 4*1(sp),r10 # load array value ! 6505: movl (r10),r6 # load first word of array operand ! 6506: cmpl r6,$b$vct # jump if vector reference ! 6507: beqlu oaon2 ! 6508: cmpl r6,$b$tbt # jump if table reference ! 6509: beqlu oaon3 ! 6510: # ! 6511: # HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE ! 6512: # ! 6513: oaon1: movl $num01,r9 # set number of subscripts to one ! 6514: movl r9,r7 # set flag for by name ! 6515: jmp arref # jump to array reference routine ! 6516: # ! 6517: # HERE IF WE HAVE A VECTOR REFERENCE ! 6518: # ! 6519: oaon2: cmpl (r9),$b$icl # use long routine if not integer ! 6520: bnequ oaon1 ! 6521: movl 4*icval(r9),r5 # load integer subscript value ! 6522: movl r5,r6 # copy as address int, fail if ovflo ! 6523: bgeq 0f ! 6524: jmp exfal ! 6525: 0: ! 6526: tstl r6 # fail if zero ! 6527: bnequ 0f ! 6528: jmp exfal ! 6529: 0: ! 6530: addl2 $vcvlb,r6 # compute offset in words ! 6531: moval 0[r6],r6 # convert to bytes ! 6532: movl r6,(sp) # complete name on stack ! 6533: cmpl r6,4*vclen(r10) # exit if subscript not too large ! 6534: bgequ 0f ! 6535: jmp exits ! 6536: 0: ! 6537: jmp exfal # else fail ! 6538: # ! 6539: # HERE FOR TABLE REFERENCE ! 6540: # ! 6541: oaon3: movl sp,r7 # set flag for name reference ! 6542: jsb tfind # locate/create table element ! 6543: .long exfal # fail if access fails ! 6544: movl r10,4*1(sp) # store name base on stack ! 6545: movl r6,(sp) # store name offset on stack ! 6546: jmp exits # exit with result on stack ! 6547: #page ! 6548: # ! 6549: # ARRAY REFERENCE (ONE SUBSCRIPT, BY VALUE) ! 6550: # ! 6551: o$aov: # entry point ! 6552: movl (sp)+,r9 # load subscript value ! 6553: movl (sp)+,r10 # load array value ! 6554: movl (r10),r6 # load first word of array operand ! 6555: cmpl r6,$b$vct # jump if vector reference ! 6556: beqlu oaov2 ! 6557: cmpl r6,$b$tbt # jump if table reference ! 6558: beqlu oaov3 ! 6559: # ! 6560: # HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE ! 6561: # ! 6562: oaov1: movl r10,-(sp) # restack array value ! 6563: movl r9,-(sp) # restack subscript ! 6564: movl $num01,r9 # set number of subscripts to one ! 6565: clrl r7 # set flag for value call ! 6566: jmp arref # jump to array reference routine ! 6567: # ! 6568: # HERE IF WE HAVE A VECTOR REFERENCE ! 6569: # ! 6570: oaov2: cmpl (r9),$b$icl # use long routine if not integer ! 6571: bnequ oaov1 ! 6572: movl 4*icval(r9),r5 # load integer subscript value ! 6573: movl r5,r6 # move as one word int, fail if ovflo ! 6574: bgeq 0f ! 6575: jmp exfal ! 6576: 0: ! 6577: tstl r6 # fail if zero ! 6578: bnequ 0f ! 6579: jmp exfal ! 6580: 0: ! 6581: addl2 $vcvlb,r6 # compute offset in words ! 6582: moval 0[r6],r6 # convert to bytes ! 6583: cmpl r6,4*vclen(r10) # fail if subscript too large ! 6584: blssu 0f ! 6585: jmp exfal ! 6586: 0: ! 6587: jsb acess # access value ! 6588: .long exfal # fail if access fails ! 6589: jmp exixr # else return value to caller ! 6590: # ! 6591: # HERE FOR TABLE REFERENCE BY VALUE ! 6592: # ! 6593: oaov3: clrl r7 # set flag for value reference ! 6594: jsb tfind # call table search routine ! 6595: .long exfal # fail if access fails ! 6596: jmp exixr # exit with result in xr ! 6597: #page ! 6598: # ! 6599: # ASSIGNMENT ! 6600: # ! 6601: o$ass: # entry point ! 6602: # ! 6603: # O$RPL (PATTERN REPLACEMENT) MERGES HERE ! 6604: # ! 6605: oass0: movl (sp)+,r7 # load value to be assigned ! 6606: movl (sp)+,r6 # load name offset ! 6607: movl (sp),r10 # load name base ! 6608: movl r7,(sp) # store assigned value as result ! 6609: jsb asign # perform assignment ! 6610: .long exfal # fail if assignment fails ! 6611: jmp exits # exit with result on stack ! 6612: #page ! 6613: # ! 6614: # COMPILATION ERROR ! 6615: # ! 6616: o$cer: # entry point ! 6617: jmp er_007 # compilation error encountered during execution ! 6618: #page ! 6619: # ! 6620: # UNARY AT (CURSOR ASSIGNMENT) ! 6621: # ! 6622: o$cas: # entry point ! 6623: movl (sp)+,r8 # load name offset (parm2) ! 6624: movl (sp)+,r9 # load name base (parm1) ! 6625: movl $p$cas,r7 # set pcode for cursor assignment ! 6626: jsb pbild # build node ! 6627: jmp exixr # jump for next code word ! 6628: #page ! 6629: # ! 6630: # CONCATENATION ! 6631: # ! 6632: o$cnc: # entry point ! 6633: movl (sp),r9 # load right argument ! 6634: cmpl r9,$nulls # jump if right arg is null ! 6635: bnequ 0f ! 6636: jmp ocnc3 ! 6637: 0: ! 6638: movl 4*1(sp),r10 # load left argument ! 6639: cmpl r10,$nulls # jump if left argument is null ! 6640: bnequ 0f ! 6641: jmp ocnc4 ! 6642: 0: ! 6643: movl $b$scl,r6 # get constant to test for string ! 6644: cmpl r6,(r10) # jump if left arg not a string ! 6645: beqlu 0f ! 6646: jmp ocnc2 ! 6647: 0: ! 6648: cmpl r6,(r9) # jump if right arg not a string ! 6649: beqlu 0f ! 6650: jmp ocnc2 ! 6651: 0: ! 6652: # ! 6653: # MERGE HERE TO CONCATENATE TWO STRINGS ! 6654: # ! 6655: ocnc1: movl 4*sclen(r10),r6 # load left argument length ! 6656: addl2 4*sclen(r9),r6 # compute result length ! 6657: jsb alocs # allocate scblk for result ! 6658: movl r9,4*1(sp) # store result ptr over left argument ! 6659: movab cfp$f(r9),r9 # prepare to store chars of result ! 6660: movl 4*sclen(r10),r6 # get number of chars in left arg ! 6661: movab cfp$f(r10),r10 # prepare to load left arg chars ! 6662: jsb sbmvc # move characters of left argument ! 6663: movl (sp)+,r10 # load right arg pointer, pop stack ! 6664: movl 4*sclen(r10),r6 # load number of chars in right arg ! 6665: movab cfp$f(r10),r10 # prepare to load right arg chars ! 6666: jsb sbmvc # move characters of right argument ! 6667: jmp exits # exit with result on stack ! 6668: # ! 6669: # COME HERE IF ARGUMENTS ARE NOT BOTH STRINGS ! 6670: # ! 6671: ocnc2: jsb gtstg # convert right arg to string ! 6672: .long ocnc5 # jump if right arg is not string ! 6673: movl r9,r10 # save right arg ptr ! 6674: jsb gtstg # convert left arg to string ! 6675: .long ocnc6 # jump if left arg is not a string ! 6676: movl r9,-(sp) # stack left argument ! 6677: movl r10,-(sp) # stack right argument ! 6678: movl r9,r10 # move left arg to proper reg ! 6679: movl (sp),r9 # move right arg to proper reg ! 6680: jmp ocnc1 # merge back to concatenate strings ! 6681: #page ! 6682: # ! 6683: # CONCATENATION (CONTINUED) ! 6684: # ! 6685: # COME HERE FOR NULL RIGHT ARGUMENT ! 6686: # ! 6687: ocnc3: addl2 $4,sp # remove right arg from stack ! 6688: jmp exits # return with left argument on stack ! 6689: # ! 6690: # HERE FOR NULL LEFT ARGUMENT ! 6691: # ! 6692: ocnc4: addl2 $4,sp # unstack one argument ! 6693: movl r9,(sp) # store right argument ! 6694: jmp exits # exit with result on stack ! 6695: # ! 6696: # HERE IF RIGHT ARGUMENT IS NOT A STRING ! 6697: # ! 6698: ocnc5: movl r9,r10 # move right argument ptr ! 6699: movl (sp)+,r9 # load left arg pointer ! 6700: # ! 6701: # MERGE HERE WHEN LEFT ARGUMENT IS NOT A STRING ! 6702: # ! 6703: ocnc6: jsb gtpat # convert left arg to pattern ! 6704: .long er_008 # concatenation left opnd is not string or pattern ! 6705: movl r9,-(sp) # save result on stack ! 6706: movl r10,r9 # point to right operand ! 6707: jsb gtpat # convert to pattern ! 6708: .long er_009 # concatenation right opd is not string or pattern ! 6709: movl r9,r10 # move for pconc ! 6710: movl (sp)+,r9 # reload left operand ptr ! 6711: jsb pconc # concatenate patterns ! 6712: jmp exixr # exit with result in xr ! 6713: #page ! 6714: # ! 6715: # COMPLEMENTATION ! 6716: # ! 6717: o$com: # entry point ! 6718: movl (sp)+,r9 # load operand ! 6719: movl (r9),r6 # load type word ! 6720: # ! 6721: # MERGE BACK HERE AFTER CONVERSION ! 6722: # ! 6723: ocom1: cmpl r6,$b$icl # jump if integer ! 6724: beqlu ocom2 ! 6725: cmpl r6,$b$rcl # jump if real ! 6726: beqlu ocom3 ! 6727: jsb gtnum # else convert to numeric ! 6728: .long er_010 # complementation operand is not numeric ! 6729: jmp ocom1 # back to check cases ! 6730: # ! 6731: # HERE TO COMPLEMENT INTEGER ! 6732: # ! 6733: ocom2: movl 4*icval(r9),r5 # load integer value ! 6734: mnegl r5,r5 # negate ! 6735: bvs 0f ! 6736: jmp exint ! 6737: 0: ! 6738: jmp er_011 # complementation caused integer overflow ! 6739: # ! 6740: # HERE TO COMPLEMENT REAL ! 6741: # ! 6742: ocom3: movf 4*rcval(r9),r2 # load real value ! 6743: mnegf r2,r2 # negate ! 6744: jmp exrea # return real result ! 6745: #page ! 6746: # ! 6747: # BINARY SLASH (DIVISION) ! 6748: # ! 6749: o$dvd: # entry point ! 6750: jsb arith # fetch arithmetic operands ! 6751: .long er_012 # division left operand is not numeric ! 6752: .long er_013 # division right operand is not numeric ! 6753: .long odvd2 # jump if real operands ! 6754: # ! 6755: # HERE TO DIVIDE TWO INTEGERS ! 6756: # ! 6757: divl2 4*icval(r10),r5 # divide left operand by right ! 6758: bvs 0f ! 6759: jmp exint ! 6760: 0: ! 6761: jmp er_014 # division caused integer overflow ! 6762: # ! 6763: # HERE TO DIVIDE TWO REALS ! 6764: # ! 6765: odvd2: divf2 4*rcval(r10),r2 # divide left operand by right ! 6766: bvs 0f ! 6767: jmp exrea ! 6768: 0: ! 6769: jmp er_262 # division caused real overflow ! 6770: #page ! 6771: # ! 6772: # EXPONENTIATION ! 6773: # ! 6774: o$exp: # entry point ! 6775: movl (sp)+,r9 # load exponent ! 6776: jsb gtnum # convert to number ! 6777: .long er_015 # exponentiation right operand is not numeric ! 6778: cmpl r6,$b$icl # jump if real ! 6779: beqlu 0f ! 6780: jmp oexp7 ! 6781: 0: ! 6782: movl r9,r10 # move exponent ! 6783: movl (sp)+,r9 # load base ! 6784: jsb gtnum # convert to numeric ! 6785: .long er_016 # exponentiation left operand is not numeric ! 6786: movl 4*icval(r10),r5 # load exponent ! 6787: bgeq 0f # error if negative exponent ! 6788: jmp oexp8 ! 6789: 0: ! 6790: cmpl r6,$b$rcl # jump if base is real ! 6791: beqlu oexp3 ! 6792: # ! 6793: # HERE TO EXPONENTIATE AN INTEGER ! 6794: # ! 6795: movl r5,r6 # convert exponent to 1 word integer ! 6796: bgeq 0f ! 6797: jmp oexp2 ! 6798: 0: ! 6799: # set loop counter ! 6800: movl intv1,r5 # load initial value of 1 ! 6801: tstl r6 # jump if non-zero exponent ! 6802: bnequ oexp1 ! 6803: tstl r5 # give zero as result for nonzero**0 ! 6804: beql 0f ! 6805: jmp exint ! 6806: 0: ! 6807: jmp oexp4 # else error of 0**0 ! 6808: # ! 6809: # LOOP TO PERFORM EXPONENTIATION ! 6810: # ! 6811: oexp1: mull2 4*icval(r9),r5 # multiply by base ! 6812: bvs oexp2 ! 6813: sobgtr r6,oexp1 # loop back till computation complete ! 6814: jmp exint # then return integer result ! 6815: # ! 6816: # HERE IF INTEGER OVERFLOW ! 6817: # ! 6818: oexp2: jmp er_017 # exponentiation caused integer overflow ! 6819: #page ! 6820: # ! 6821: # EXPONENTIATION (CONTINUED) ! 6822: # ! 6823: # HERE TO EXPONENTIATE A REAL ! 6824: # ! 6825: oexp3: movl r5,r6 # convert exponent to one word ! 6826: bgeq 0f ! 6827: jmp oexp6 ! 6828: 0: ! 6829: # set loop counter ! 6830: movf reav1,r2 # load 1.0 as initial value ! 6831: tstl r6 # jump if non-zero exponent ! 6832: bnequ oexp5 ! 6833: tstf r2 # return 1.0 if nonzero**zero ! 6834: beql 0f ! 6835: jmp exrea ! 6836: 0: ! 6837: # ! 6838: # HERE FOR ERROR OF 0**0 OR 0.0**0 ! 6839: # ! 6840: oexp4: jmp er_018 # exponentiation result is undefined ! 6841: # ! 6842: # LOOP TO PERFORM EXPONENTIATION ! 6843: # ! 6844: oexp5: mulf2 4*rcval(r9),r2 # multiply by base ! 6845: bvs oexp6 ! 6846: sobgtr r6,oexp5 # loop till computation complete ! 6847: jmp exrea # then return real result ! 6848: # ! 6849: # HERE IF REAL OVERFLOW ! 6850: # ! 6851: oexp6: jmp er_266 # exponentiation caused real overflow ! 6852: # ! 6853: # HERE IF REAL EXPONENT ! 6854: # ! 6855: oexp7: jmp er_267 # exponentiation right operand is real not integer ! 6856: # ! 6857: # HERE FOR NEGATIVE EXPONENT ! 6858: # ! 6859: oexp8: jmp er_019 # exponentiation right operand is negative ! 6860: #page ! 6861: # ! 6862: # FAILURE IN EXPRESSION EVALUATION ! 6863: # ! 6864: # THIS ENTRY POINT IS USED IF THE EVALUATION OF AN ! 6865: # EXPRESSION, INITIATED BY THE EVALX PROCEDURE, FAILS. ! 6866: # CONTROL IS RETURNED TO AN APPROPRIATE POINT IN EVALX. ! 6867: # ! 6868: o$fex: # entry point ! 6869: jmp evlx6 # jump to failure loc in evalx ! 6870: #page ! 6871: # ! 6872: # FAILURE DURING EVALUATION OF A COMPLEX OR DIRECT GOTO ! 6873: # ! 6874: o$fif: # entry point ! 6875: jmp er_020 # goto evaluation failure ! 6876: #page ! 6877: # ! 6878: # FUNCTION CALL (MORE THAN ONE ARGUMENT) ! 6879: # ! 6880: o$fnc: # entry point ! 6881: movl (r3)+,r6 # load number of arguments ! 6882: movl (r3)+,r9 # load function vrblk pointer ! 6883: movl 4*vrfnc(r9),r10 # load function pointer ! 6884: cmpl r6,4*fargs(r10) # use central routine if wrong num ! 6885: beqlu 0f ! 6886: jmp cfunc ! 6887: 0: ! 6888: movl (r10),r11 # jump to function if arg count ok ! 6889: jmp (r11) ! 6890: #page ! 6891: # ! 6892: # FUNCTION NAME ERROR ! 6893: # ! 6894: o$fne: # entry point ! 6895: movl (r3)+,r6 # get next code word ! 6896: cmpl r6,$ornm$ # fail if not evaluating expression ! 6897: bnequ ofne1 ! 6898: tstl 4*2(sp) # ok if expr. was wanted by value ! 6899: bnequ 0f ! 6900: jmp evlx3 ! 6901: 0: ! 6902: # ! 6903: # HERE FOR ERROR ! 6904: # ! 6905: ofne1: jmp er_021 # function called by name returned a value ! 6906: #page ! 6907: # ! 6908: # FUNCTION CALL (SINGLE ARGUMENT) ! 6909: # ! 6910: o$fns: # entry point ! 6911: movl (r3)+,r9 # load function vrblk pointer ! 6912: movl $num01,r6 # set number of arguments to one ! 6913: movl 4*vrfnc(r9),r10 # load function pointer ! 6914: cmpl r6,4*fargs(r10) # use central routine if wrong num ! 6915: beqlu 0f ! 6916: jmp cfunc ! 6917: 0: ! 6918: movl (r10),r11 # jump to function if arg count ok ! 6919: jmp (r11) ! 6920: #page ! 6921: # CALL TO UNDEFINED FUNCTION ! 6922: # ! 6923: o$fun: # entry point ! 6924: jmp er_022 # undefined function called ! 6925: #page ! 6926: # ! 6927: # EXECUTE COMPLEX GOTO ! 6928: # ! 6929: o$goc: # entry point ! 6930: movl 4*1(sp),r9 # load name base pointer ! 6931: cmpl r9,state # jump if not natural variable ! 6932: bgequ ogoc1 ! 6933: addl2 $4*vrtra,r9 # else point to vrtra field ! 6934: movl (r9),r11 # and jump through it ! 6935: jmp (r11) ! 6936: # ! 6937: # HERE IF GOTO OPERAND IS NOT NATURAL VARIABLE ! 6938: # ! 6939: ogoc1: jmp er_023 # goto operand is not a natural variable ! 6940: #page ! 6941: # ! 6942: # EXECUTE DIRECT GOTO ! 6943: # ! 6944: o$god: # entry point ! 6945: movl (sp),r9 # load operand ! 6946: movl (r9),r6 # load first word ! 6947: cmpl r6,$b$cds # jump if code block to code routine ! 6948: bnequ 0f ! 6949: jmp bcds0 ! 6950: 0: ! 6951: cmpl r6,$b$cdc # jump if code block to code routine ! 6952: bnequ 0f ! 6953: jmp bcdc0 ! 6954: 0: ! 6955: jmp er_024 # goto operand in direct goto is not code ! 6956: #page ! 6957: # ! 6958: # SET GOTO FAILURE TRAP ! 6959: # ! 6960: # THIS ROUTINE IS EXECUTED AT THE START OF A COMPLEX OR ! 6961: # DIRECT FAILURE GOTO TO TRAP A SUBSEQUENT FAIL (SEE EXFAL) ! 6962: # ! 6963: o$gof: # entry point ! 6964: movl flptr,r9 # point to fail offset on stack ! 6965: addl2 $4,(r9) # point failure to o$fif word ! 6966: tstl (r3)+ # point to next code word ! 6967: jmp exits # exit to continue ! 6968: #page ! 6969: # ! 6970: # BINARY DOLLAR (IMMEDIATE ASSIGNMENT) ! 6971: # ! 6972: # THE PATTERN BUILT BY BINARY DOLLAR IS A COMPOUND PATTERN. ! 6973: # SEE DESCRIPTION AT START OF PATTERN MATCH SECTION FOR ! 6974: # DETAILS OF THE STRUCTURE WHICH IS CONSTRUCTED. ! 6975: # ! 6976: o$ima: # entry point ! 6977: movl $p$imc,r7 # set pcode for last node ! 6978: movl (sp)+,r8 # pop name offset (parm2) ! 6979: movl (sp)+,r9 # pop name base (parm1) ! 6980: jsb pbild # build p$imc node ! 6981: movl r9,r10 # save ptr to node ! 6982: movl (sp),r9 # load left argument ! 6983: jsb gtpat # convert to pattern ! 6984: .long er_025 # immediate assignment left operand is not pattern ! 6985: movl r9,(sp) # save ptr to left operand pattern ! 6986: movl $p$ima,r7 # set pcode for first node ! 6987: jsb pbild # build p$ima node ! 6988: movl (sp)+,4*pthen(r9)# set left operand as p$ima successor ! 6989: jsb pconc # concatenate to form final pattern ! 6990: jmp exixr # all done ! 6991: #page ! 6992: # ! 6993: # INDIRECTION (BY NAME) ! 6994: # ! 6995: o$inn: # entry point ! 6996: movl sp,r7 # set flag for result by name ! 6997: jmp indir # jump to common routine ! 6998: #page ! 6999: # ! 7000: # INTERROGATION ! 7001: # ! 7002: o$int: # entry point ! 7003: movl $nulls,(sp) # replace operand with null ! 7004: jmp exits # exit for next code word ! 7005: #page ! 7006: # ! 7007: # INDIRECTION (BY VALUE) ! 7008: # ! 7009: o$inv: # entry point ! 7010: clrl r7 # set flag for by value ! 7011: jmp indir # jump to common routine ! 7012: #page ! 7013: # ! 7014: # KEYWORD REFERENCE (BY NAME) ! 7015: # ! 7016: o$kwn: # entry point ! 7017: jsb kwnam # get keyword name ! 7018: jmp exnam # exit with result name ! 7019: #page ! 7020: # ! 7021: # KEYWORD REFERENCE (BY VALUE) ! 7022: # ! 7023: o$kwv: # entry point ! 7024: jsb kwnam # get keyword name ! 7025: movl r9,dnamp # delete kvblk ! 7026: jsb acess # access value ! 7027: .long exnul # dummy (unused) failure return ! 7028: jmp exixr # jump with value in xr ! 7029: #page ! 7030: # ! 7031: # LOAD EXPRESSION BY NAME ! 7032: # ! 7033: o$lex: # entry point ! 7034: movl $4*evsi$,r6 # set size of evblk ! 7035: jsb alloc # allocate space for evblk ! 7036: movl $b$evt,(r9) # set type word ! 7037: movl $trbev,4*evvar(r9) # set dummy trblk pointer ! 7038: movl (r3)+,r6 # load exblk pointer ! 7039: movl r6,4*evexp(r9) # set exblk pointer ! 7040: movl r9,r10 # move name base to proper reg ! 7041: movl $4*evvar,r6 # set name offset = zero ! 7042: jmp exnam # exit with name in (xl,wa) ! 7043: #page ! 7044: # ! 7045: # LOAD PATTERN VALUE ! 7046: # ! 7047: o$lpt: # entry point ! 7048: movl (r3)+,r9 # load pattern pointer ! 7049: jmp exixr # stack ptr and obey next code word ! 7050: #page ! 7051: # ! 7052: # LOAD VARIABLE NAME ! 7053: # ! 7054: o$lvn: # entry point ! 7055: movl (r3)+,r6 # load vrblk pointer ! 7056: movl r6,-(sp) # stack vrblk ptr (name base) ! 7057: movl $4*vrval,-(sp) # stack name offset ! 7058: jmp exits # exit with result on stack ! 7059: #page ! 7060: # ! 7061: # BINARY ASTERISK (MULTIPLICATION) ! 7062: # ! 7063: o$mlt: # entry point ! 7064: jsb arith # fetch arithmetic operands ! 7065: .long er_026 # multiplication left operand is not numeric ! 7066: .long er_027 # multiplication right operand is not numeric ! 7067: .long omlt1 # jump if real operands ! 7068: # ! 7069: # HERE TO MULTIPLY TWO INTEGERS ! 7070: # ! 7071: mull2 4*icval(r10),r5 # multiply left operand by right ! 7072: bvs 0f ! 7073: jmp exint ! 7074: 0: ! 7075: jmp er_028 # multiplication caused integer overflow ! 7076: # ! 7077: # HERE TO MULTIPLY TWO REALS ! 7078: # ! 7079: omlt1: mulf2 4*rcval(r10),r2 # multiply left operand by right ! 7080: bvs 0f ! 7081: jmp exrea ! 7082: 0: ! 7083: jmp er_263 # multiplication caused real overflow ! 7084: #page ! 7085: # ! 7086: # NAME REFERENCE ! 7087: # ! 7088: o$nam: # entry point ! 7089: movl $4*nmsi$,r6 # set length of nmblk ! 7090: jsb alloc # allocate nmblk ! 7091: movl $b$nml,(r9) # set name block code ! 7092: movl (sp)+,4*nmofs(r9)# set name offset from operand ! 7093: movl (sp)+,4*nmbas(r9)# set name base from operand ! 7094: jmp exixr # exit with result in xr ! 7095: #page ! 7096: # ! 7097: # NEGATION ! 7098: # ! 7099: # INITIAL ENTRY ! 7100: # ! 7101: o$nta: # entry point ! 7102: movl (r3)+,r6 # load new failure offset ! 7103: movl flptr,-(sp) # stack old failure pointer ! 7104: movl r6,-(sp) # stack new failure offset ! 7105: movl sp,flptr # set new failure pointer ! 7106: jmp exits # jump to continue execution ! 7107: # ! 7108: # ENTRY AFTER SUCCESSFUL EVALUATION OF OPERAND ! 7109: # ! 7110: o$ntb: # entry point ! 7111: movl 4*2(sp),flptr # restore old failure pointer ! 7112: jmp exfal # and fail ! 7113: # ! 7114: # ENTRY FOR FAILURE DURING OPERAND EVALUATION ! 7115: # ! 7116: o$ntc: # entry point ! 7117: addl2 $4,sp # pop failure offset ! 7118: movl (sp)+,flptr # restore old failure pointer ! 7119: jmp exnul # exit giving null result ! 7120: #page ! 7121: # ! 7122: # USE OF UNDEFINED OPERATOR ! 7123: # ! 7124: o$oun: # entry point ! 7125: jmp er_029 # undefined operator referenced ! 7126: #page ! 7127: # ! 7128: # BINARY DOT (PATTERN ASSIGNMENT) ! 7129: # ! 7130: # THE PATTERN BUILT BY BINARY DOT IS A COMPOUND PATTERN. ! 7131: # SEE DESCRIPTION AT START OF PATTERN MATCH SECTION FOR ! 7132: # DETAILS OF THE STRUCTURE WHICH IS CONSTRUCTED. ! 7133: # ! 7134: o$pas: # entry point ! 7135: movl $p$pac,r7 # load pcode for p$pac node ! 7136: movl (sp)+,r8 # load name offset (parm2) ! 7137: movl (sp)+,r9 # load name base (parm1) ! 7138: jsb pbild # build p$pac node ! 7139: movl r9,r10 # save ptr to node ! 7140: movl (sp),r9 # load left operand ! 7141: jsb gtpat # convert to pattern ! 7142: .long er_030 # pattern assignment left operand is not pattern ! 7143: movl r9,(sp) # save ptr to left operand pattern ! 7144: movl $p$paa,r7 # set pcode for p$paa node ! 7145: jsb pbild # build p$paa node ! 7146: movl (sp)+,4*pthen(r9)# set left operand as p$paa successor ! 7147: jsb pconc # concatenate to form final pattern ! 7148: jmp exixr # jump for next code word ! 7149: #page ! 7150: # ! 7151: # PATTERN MATCH (BY NAME, FOR REPLACEMENT) ! 7152: # ! 7153: o$pmn: # entry point ! 7154: clrl r7 # set type code for match by name ! 7155: jmp match # jump to routine to start match ! 7156: #page ! 7157: # ! 7158: # PATTERN MATCH (STATEMENT) ! 7159: # ! 7160: # O$PMS IS USED IN PLACE OF O$PMV WHEN THE PATTERN MATCH ! 7161: # OCCURS AT THE OUTER (STATEMENT) LEVEL SINCE IN THIS ! 7162: # CASE THE SUBSTRING VALUE NEED NOT BE CONSTRUCTED. ! 7163: # ! 7164: o$pms: # entry point ! 7165: movl $num02,r7 # set flag for statement to match ! 7166: jmp match # jump to routine to start match ! 7167: #page ! 7168: # ! 7169: # PATTERN MATCH (BY VALUE) ! 7170: # ! 7171: o$pmv: # entry point ! 7172: movl $num01,r7 # set type code for value match ! 7173: jmp match # jump to routine to start match ! 7174: #page ! 7175: # ! 7176: # POP TOP ITEM ON STACK ! 7177: # ! 7178: o$pop: # entry point ! 7179: addl2 $4,sp # pop top stack entry ! 7180: jmp exits # obey next code word ! 7181: #page ! 7182: # ! 7183: # TERMINATE EXECUTION (CODE COMPILED FOR END STATEMENT) ! 7184: # ! 7185: o$stp: # entry point ! 7186: jmp lend0 # jump to end circuit ! 7187: #page ! 7188: # ! 7189: # RETURN NAME FROM EXPRESSION ! 7190: # THIS ENTRY POINTS IS USED IF THE EVALUATION OF AN ! 7191: # EXPRESSION, INITIATED BY THE EVALX PROCEDURE, RETURNS ! 7192: # A NAME. CONTROL IS RETURNED TO THE PROPER POINT IN EVALX. ! 7193: # ! 7194: o$rnm: # entry point ! 7195: jmp evlx4 # return to evalx procedure ! 7196: #page ! 7197: # ! 7198: # PATTERN REPLACEMENT ! 7199: # ! 7200: # WHEN THIS ROUTINE GETS CONTROL, THE FOLLOWING STACK ! 7201: # ENTRIES HAVE BEEN MADE (SEE END OF MATCH ROUTINE P$NTH) ! 7202: # ! 7203: # SUBJECT NAME BASE ! 7204: # SUBJECT NAME OFFSET ! 7205: # INITIAL CURSOR VALUE ! 7206: # FINAL CURSOR VALUE ! 7207: # SUBJECT POINTER ! 7208: # (XS) ---------------- REPLACEMENT VALUE ! 7209: # ! 7210: o$rpl: # entry point ! 7211: jsb gtstg # convert replacement val to string ! 7212: .long er_031 # pattern replacement right operand is not string ! 7213: # ! 7214: # GET RESULT LENGTH AND ALLOCATE RESULT SCBLK ! 7215: # ! 7216: movl (sp),r10 # load subject string pointer ! 7217: cmpl (r10),$b$bct # branch if buffer assignment ! 7218: bnequ 0f ! 7219: jmp orpl4 ! 7220: 0: ! 7221: addl2 4*sclen(r10),r6 # add subject string length ! 7222: addl2 4*2(sp),r6 # add starting cursor ! 7223: subl2 4*1(sp),r6 # minus final cursor = total length ! 7224: bnequ 0f # jump if result is null ! 7225: jmp orpl3 ! 7226: 0: ! 7227: movl r9,-(sp) # restack replacement string ! 7228: jsb alocs # allocate scblk for result ! 7229: movl 4*3(sp),r6 # get initial cursor (part 1 len) ! 7230: movl r9,4*3(sp) # stack result pointer ! 7231: movab cfp$f(r9),r9 # point to characters of result ! 7232: # ! 7233: # MOVE PART 1 (START OF SUBJECT) TO RESULT ! 7234: # ! 7235: tstl r6 # jump if first part is null ! 7236: beqlu orpl1 ! 7237: movl 4*1(sp),r10 # else point to subject string ! 7238: movab cfp$f(r10),r10 # point to subject string chars ! 7239: jsb sbmvc # move first part to result ! 7240: #page ! 7241: # PATTERN REPLACEMENT (CONTINUED) ! 7242: # ! 7243: # NOW MOVE IN REPLACEMENT VALUE ! 7244: # ! 7245: orpl1: movl (sp)+,r10 # load replacement string, pop ! 7246: movl 4*sclen(r10),r6 # load length ! 7247: beqlu orpl2 # jump if null replacement ! 7248: movab cfp$f(r10),r10 # else point to chars of replacement ! 7249: jsb sbmvc # move in chars (part 2) ! 7250: # ! 7251: # NOW MOVE IN REMAINDER OF STRING (PART 3) ! 7252: # ! 7253: orpl2: movl (sp)+,r10 # load subject string pointer, pop ! 7254: movl (sp)+,r8 # load final cursor, pop ! 7255: movl 4*sclen(r10),r6 # load subject string length ! 7256: subl2 r8,r6 # minus final cursor = part 3 length ! 7257: bnequ 0f # jump to assign if part 3 is null ! 7258: jmp oass0 ! 7259: 0: ! 7260: movab cfp$f(r10)[r8],r10 # else point to last part of string ! 7261: jsb sbmvc # move part 3 to result ! 7262: jmp oass0 # jump to perform assignment ! 7263: # ! 7264: # HERE IF RESULT IS NULL ! 7265: # ! 7266: orpl3: addl2 $4*num02,sp # pop subject str ptr, final cursor ! 7267: movl $nulls,(sp) # set null result ! 7268: jmp oass0 # jump to assign null value ! 7269: # ! 7270: # HERE FOR BUFFER SUBSTRING ASSIGNMENT ! 7271: # ! 7272: orpl4: movl r9,r10 # copy scblk replacement ptr ! 7273: movl (sp)+,r9 # unstack bcblk ptr ! 7274: movl (sp)+,r7 # get final cursor value ! 7275: movl (sp)+,r6 # get initial cursor ! 7276: subl2 r6,r7 # get length in wb ! 7277: addl2 $4*num02,sp # get rid of name base/offset ! 7278: jsb insbf # insert substring ! 7279: .long invalid$ # convert fail impossible ! 7280: .long exfal # fail if insert fails ! 7281: jmp exnul # else null result ! 7282: #page ! 7283: # ! 7284: # RETURN VALUE FROM EXPRESSION ! 7285: # ! 7286: # THIS ENTRY POINTS IS USED IF THE EVALUATION OF AN ! 7287: # EXPRESSION, INITIATED BY THE EVALX PROCEDURE, RETURNS ! 7288: # A VALUE. CONTROL IS RETURNED TO THE PROPER POINT IN EVALX ! 7289: # ! 7290: o$rvl: # entry point ! 7291: jmp evlx3 # return to evalx procedure ! 7292: #page ! 7293: # ! 7294: # SELECTION ! 7295: # ! 7296: # INITIAL ENTRY ! 7297: # ! 7298: o$sla: # entry point ! 7299: movl (r3)+,r6 # load new failure offset ! 7300: movl flptr,-(sp) # stack old failure pointer ! 7301: movl r6,-(sp) # stack new failure offset ! 7302: movl sp,flptr # set new failure pointer ! 7303: jmp exits # jump to execute first alternative ! 7304: # ! 7305: # ENTRY AFTER SUCCESSFUL EVALUATION OF ALTERNATIVE ! 7306: # ! 7307: o$slb: # entry point ! 7308: movl (sp)+,r9 # load result ! 7309: addl2 $4,sp # pop fail offset ! 7310: movl (sp),flptr # restore old failure pointer ! 7311: movl r9,(sp) # restack result ! 7312: movl (r3)+,r6 # load new code offset ! 7313: addl2 r$cod,r6 # point to absolute code location ! 7314: movl r6,r3 # set new code pointer ! 7315: jmp exits # jump to continue past selection ! 7316: # ! 7317: # ENTRY AT START OF SUBSEQUENT ALTERNATIVES ! 7318: # ! 7319: o$slc: # entry point ! 7320: movl (r3)+,r6 # load new fail offset ! 7321: movl r6,(sp) # store new fail offset ! 7322: jmp exits # jump to execute next alternative ! 7323: # ! 7324: # ENTRY AT START OF LAST ALTERNATIVE ! 7325: # ! 7326: o$sld: # entry point ! 7327: addl2 $4,sp # pop failure offset ! 7328: movl (sp)+,flptr # restore old failure pointer ! 7329: jmp exits # jump to execute last alternative ! 7330: #page ! 7331: # ! 7332: # BINARY MINUS (SUBTRACTION) ! 7333: # ! 7334: o$sub: # entry point ! 7335: jsb arith # fetch arithmetic operands ! 7336: .long er_032 # subtraction left operand is not numeric ! 7337: .long er_033 # subtraction right operand is not numeric ! 7338: .long osub1 # jump if real operands ! 7339: # ! 7340: # HERE TO SUBTRACT TWO INTEGERS ! 7341: # ! 7342: subl2 4*icval(r10),r5 # subtract right operand from left ! 7343: bvs 0f ! 7344: jmp exint ! 7345: 0: ! 7346: jmp er_034 # subtraction caused integer overflow ! 7347: # ! 7348: # HERE TO SUBTRACT TWO REALS ! 7349: # ! 7350: osub1: subf2 4*rcval(r10),r2 # subtract right operand from left ! 7351: bvs 0f ! 7352: jmp exrea ! 7353: 0: ! 7354: jmp er_264 # subtraction caused real overflow ! 7355: #page ! 7356: # ! 7357: # DUMMY OPERATOR TO RETURN CONTROL TO TRXEQ PROCEDURE ! 7358: # ! 7359: o$txr: # entry point ! 7360: jmp trxq1 # jump into trxeq procedure ! 7361: #page ! 7362: # ! 7363: # UNEXPECTED FAILURE ! 7364: # ! 7365: # NOTE THAT IF A SETEXIT TRAP IS OPERATING THEN ! 7366: # TRANSFER TO SYSTEM LABEL CONTINUE ! 7367: # WILL RESULT IN LOOPING HERE. DIFFICULT TO AVOID EXCEPT ! 7368: # WITH A CONSIDERABLE OVERHEAD WHICH IS NOT WORTHWHILE OR ! 7369: # ELSE BY A TECHNIQUE SUCH AS SETTING KVERL TO ZERO. ! 7370: # ! 7371: o$unf: # entry point ! 7372: jmp er_035 # unexpected failure in -nofail mode ! 7373: #title s p i t b o l -- snobol4 builtin label routines ! 7374: # ! 7375: # THE FOLLOWING SECTION CONTAINS THE ROUTINES FOR LABELS ! 7376: # WHICH HAVE A PREDEFINED MEANING IN SNOBOL4. ! 7377: # ! 7378: # CONTROL IS PASSED DIRECTLY TO THE LABEL NAME ENTRY POINT. ! 7379: # ! 7380: # ENTRY NAMES ARE OF THE FORM L$XXX WHERE XXX IS THE THREE ! 7381: # LETTER VARIABLE NAME IDENTIFIER. ! 7382: # ! 7383: # ENTRIES ARE IN ALPHABETICAL ORDER ! 7384: #page ! 7385: # ! 7386: # ABORT ! 7387: # ! 7388: l$abo: # entry point ! 7389: # ! 7390: # MERGE HERE IF EXECUTION TERMINATES IN ERROR ! 7391: # ! 7392: labo1: movl kvert,r6 # load error code ! 7393: beqlu labo2 # jump if no error has occured ! 7394: jsb sysax # call after execution proc (reg04) ! 7395: jsb prtpg # else eject printer ! 7396: jsb ermsg # print error message ! 7397: clrl r9 # indicate no message to print ! 7398: jmp stopr # jump to routine to stop run ! 7399: # ! 7400: # HERE IF NO ERROR HAD OCCURED ! 7401: # ! 7402: labo2: jmp er_036 # goto abort with no preceding error ! 7403: #page ! 7404: # ! 7405: # CONTINUE ! 7406: # ! 7407: l$cnt: # entry point ! 7408: # ! 7409: # MERGE HERE AFTER EXECUTION ERROR ! 7410: # ! 7411: lcnt1: movl r$cnt,r9 # load continuation code block ptr ! 7412: beqlu lcnt2 # jump if no previous error ! 7413: clrl r$cnt # clear flag ! 7414: movl r9,r$cod # else store as new code block ptr ! 7415: addl2 stxof,r9 # add failure offset ! 7416: movl r9,r3 # load code pointer ! 7417: movl flptr,sp # reset stack pointer ! 7418: jmp exits # jump to take indicated failure ! 7419: # ! 7420: # HERE IF NO PREVIOUS ERROR ! 7421: # ! 7422: lcnt2: jmp er_037 # goto continue with no preceding error ! 7423: #page ! 7424: # ! 7425: # END ! 7426: # ! 7427: l$end: # entry point ! 7428: # ! 7429: # MERGE HERE FROM END CODE CIRCUIT ! 7430: # ! 7431: lend0: movl $endms,r9 # point to message /normal term../ ! 7432: jmp stopr # jump to routine to stop run ! 7433: #page ! 7434: # ! 7435: # FRETURN ! 7436: # ! 7437: l$frt: # entry point ! 7438: movl $scfrt,r6 # point to string /freturn/ ! 7439: jmp retrn # jump to common return routine ! 7440: #page ! 7441: # ! 7442: # NRETURN ! 7443: # ! 7444: l$nrt: # entry point ! 7445: movl $scnrt,r6 # point to string /nreturn/ ! 7446: jmp retrn # jump to common return routine ! 7447: #page ! 7448: # ! 7449: # RETURN ! 7450: # ! 7451: l$rtn: # entry point ! 7452: movl $scrtn,r6 # point to string /return/ ! 7453: jmp retrn # jump to common return routine ! 7454: #page ! 7455: # ! 7456: # UNDEFINED LABEL ! 7457: # ! 7458: l$und: # entry point ! 7459: jmp er_038 # goto undefined label ! 7460: #title s p i t b o l -- block action routines ! 7461: # ! 7462: # THE FIRST WORD OF EVERY BLOCK IN DYNAMIC STORAGE AND THE ! 7463: # VRGET, VRSTO AND VRTRA FIELDS OF A VRBLK CONTAIN A ! 7464: # POINTER TO AN ENTRY POINT IN THE PROGRAM. ALL SUCH ENTRY ! 7465: # POINTS ARE IN THE FOLLOWING SECTION EXCEPT THOSE FOR ! 7466: # PATTERN BLOCKS WHICH ARE IN THE PATTERN MATCHING SEGMENT ! 7467: # LATER ON (LABELS OF THE FORM P$XXX), AND DOPE VECTORS ! 7468: # (D$XXX) WHICH ARE IN THE DOPE VECTOR SECTION FOLLOWING ! 7469: # THE PATTERN ROUTINES (DOPE VECTORS ARE USED FOR CMBLKS). ! 7470: # ! 7471: # THE ENTRY POINTS IN THIS SECTION HAVE LABELS OF THE ! 7472: # FORM B$XXY WHERE XX IS THE TWO CHARACTER BLOCK TYPE FOR ! 7473: # THE CORRESPONDING BLOCK AND Y IS ANY LETTER. ! 7474: # ! 7475: # IN SOME CASES, THE POINTERS SERVE NO OTHER PURPOSE THAN ! 7476: # TO IDENTIFY THE BLOCK TYPE. IN THIS CASE THE ROUTINE ! 7477: # IS NEVER EXECUTED AND THUS NO CODE IS ASSEMBLED. ! 7478: # ! 7479: # FOR EACH OF THESE ENTRY POINTS CORRESPONDING TO A BLOCK ! 7480: # AN ENTRY POINT IDENTIFICATION IS ASSEMBLED (BL$XX). ! 7481: # ! 7482: # THE EXACT ENTRY CONDITIONS DEPEND ON THE MANNER IN ! 7483: # WHICH THE ROUTINE IS ACCESSED AND ARE DOCUMENTED WITH ! 7484: # THE INDIVIDUAL ROUTINES AS REQUIRED. ! 7485: # ! 7486: # THE ORDER OF THESE ROUTINES IS ALPHABETICAL WITH THE ! 7487: # FOLLOWING EXCEPTIONS. ! 7488: # ! 7489: # THE ROUTINES FOR SEBLK AND EXBLK ENTRIES OCCUR FIRST SO ! 7490: # THAT EXPRESSIONS CAN BE QUICKLY IDENTIFIED FROM THE FACT ! 7491: # THAT THEIR ROUTINES LIE BEFORE THE SYMBOL B$E$$. ! 7492: # ! 7493: # THESE ARE IMMEDIATELY FOLLOWED BY THE ROUTINE FOR A TRBLK ! 7494: # SO THAT THE TEST AGAINST THE SYMBOL B$T$$ CHECKS FOR ! 7495: # TRAPPED VALUES OR EXPRESSION VALUES (SEE PROCEDURE EVALP) ! 7496: # ! 7497: # THE PATTERN ROUTINES LIE AFTER THIS SECTION SO THAT ! 7498: # PATTERNS ARE IDENTIFIED WITH ROUTINES STARTING AT OR ! 7499: # AFTER THE INITIAL INSTRUCTION IN THESE ROUTINES (P$AAA). ! 7500: # ! 7501: # THE SYMBOL B$AAA DEFINES THE FIRST LOCATION FOR BLOCK ! 7502: # ROUTINES AND THE SYMBOL P$YYY (AT THE END OF THE PATTERN ! 7503: # MATCH ROUTINES SECTION) DEFINES THE LAST SUCH ENTRY POINT ! 7504: # ! 7505: .align 2 ! 7506: .word bl$$i ! 7507: b$aaa: # entry point of first block routine ! 7508: #page ! 7509: # ! 7510: # EXBLK ! 7511: # ! 7512: # THE ROUTINE FOR AN EXBLK LOADS THE EXPRESSION ONTO ! 7513: # THE STACK AS A VALUE. ! 7514: # ! 7515: # (XR) POINTER TO EXBLK ! 7516: # ! 7517: .align 2 ! 7518: .word bl$ex ! 7519: b$exl: # entry point (exblk) ! 7520: jmp exixr # stack xr and obey next code word ! 7521: #page ! 7522: # ! 7523: # SEBLK ! 7524: # ! 7525: # THE ROUTINE FOR SEBLK IS ACCESSED FROM THE GENERATED ! 7526: # CODE TO LOAD THE EXPRESSION VALUE ONTO THE STACK. ! 7527: # ! 7528: .align 2 ! 7529: .word bl$se ! 7530: b$sel: # entry point (seblk) ! 7531: jmp exixr # stack xr and obey next code word ! 7532: # ! 7533: # DEFINE SYMBOL WHICH MARKS END OF ENTRIES FOR EXPRESSIONS ! 7534: # ! 7535: .align 2 ! 7536: .word bl$$i ! 7537: b$e$$: # entry point ! 7538: #page ! 7539: # ! 7540: # TRBLK ! 7541: # ! 7542: # THE ROUTINE FOR A TRBLK IS NEVER EXECUTED ! 7543: # ! 7544: .align 2 ! 7545: .word bl$tr ! 7546: b$trt: # entry point (trblk) ! 7547: # ! 7548: # DEFINE SYMBOL MARKING END OF TRAP AND EXPRESSION BLOCKS ! 7549: # ! 7550: .align 2 ! 7551: .word bl$$i ! 7552: b$t$$: # end of trblk,seblk,exblk entries ! 7553: #page ! 7554: # ! 7555: # ARBLK ! 7556: # ! 7557: # THE ROUTINE FOR ARBLK IS NEVER EXECUTED ! 7558: # ! 7559: .align 2 ! 7560: .word bl$ar ! 7561: b$art: # entry point (arblk) ! 7562: #page ! 7563: # ! 7564: # BCBLK ! 7565: # ! 7566: # THE ROUTINE FOR A BCBLK IS NEVER EXECUTED ! 7567: # ! 7568: # (XR) POINTER TO BCBLK ! 7569: # ! 7570: .align 2 ! 7571: .word bl$bc ! 7572: b$bct: # entry point (bcblk) ! 7573: #page ! 7574: # ! 7575: # BFBLK ! 7576: # ! 7577: # THE ROUTINE FOR A BFBLK IS NEVER EXECUTED ! 7578: # ! 7579: # (XR) POINTER TO BFBLK ! 7580: # ! 7581: .align 2 ! 7582: .word bl$bf ! 7583: b$bft: # entry point (bfblk) ! 7584: #page ! 7585: # ! 7586: # CCBLK ! 7587: # ! 7588: # THE ROUTINE FOR CCBLK IS NEVER ENTERED ! 7589: # ! 7590: .align 2 ! 7591: .word bl$cc ! 7592: b$cct: # entry point (ccblk) ! 7593: #page ! 7594: # ! 7595: # CDBLK ! 7596: # ! 7597: # THE CDBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE. ! 7598: # THERE ARE TWO CASES DEPENDING ON THE FORM OF CDFAL. ! 7599: # ! 7600: # ENTRY FOR COMPLEX FAILURE CODE AT CDFAL ! 7601: # ! 7602: # (XR) POINTER TO CDBLK ! 7603: # ! 7604: .align 2 ! 7605: .word bl$cd ! 7606: b$cdc: # entry point (cdblk) ! 7607: bcdc0: movl flptr,sp # pop garbage off stack ! 7608: movl 4*cdfal(r9),(sp)# set failure offset ! 7609: jmp stmgo # enter stmt ! 7610: #page ! 7611: # ! 7612: # CDBLK (CONTINUED) ! 7613: # ! 7614: # ENTRY FOR SIMPLE FAILURE CODE AT CDFAL ! 7615: # ! 7616: # (XR) POINTER TO CDBLK ! 7617: # ! 7618: .align 2 ! 7619: .word bl$cd ! 7620: b$cds: # entry point (cdblk) ! 7621: bcds0: movl flptr,sp # pop garbage off stack ! 7622: movl $4*cdfal,(sp) # set failure offset ! 7623: jmp stmgo # enter stmt ! 7624: #page ! 7625: # ! 7626: # CMBLK ! 7627: # ! 7628: # THE ROUTINE FOR A CMBLK IS NEVER EXECUTED ! 7629: # ! 7630: .align 2 ! 7631: .word bl$cm ! 7632: b$cmt: # entry point (cmblk) ! 7633: #page ! 7634: # ! 7635: # CTBLK ! 7636: # ! 7637: # THE ROUTINE FOR A CTBLK IS NEVER EXECUTED ! 7638: # ! 7639: .align 2 ! 7640: .word bl$ct ! 7641: b$ctt: # entry point (ctblk) ! 7642: #page ! 7643: # ! 7644: # DFBLK ! 7645: # ! 7646: # THE ROUTINE FOR A DFBLK IS ACCESSED FROM THE O$FNC ENTRY ! 7647: # TO CALL A DATATYPE FUNCTION AND BUILD A PDBLK. ! 7648: # ! 7649: # (XL) POINTER TO DFBLK ! 7650: # ! 7651: .align 2 ! 7652: .word bl$df ! 7653: b$dfc: # entry point ! 7654: movl 4*dfpdl(r10),r6 # load length of pdblk ! 7655: jsb alloc # allocate pdblk ! 7656: movl $b$pdt,(r9) # store type word ! 7657: movl r10,4*pddfp(r9) # store dfblk pointer ! 7658: movl r9,r8 # save pointer to pdblk ! 7659: addl2 r6,r9 # point past pdblk ! 7660: movl 4*fargs(r10),r6 # set to count fields ! 7661: # ! 7662: # LOOP TO ACQUIRE FIELD VALUES FROM STACK ! 7663: # ! 7664: bdfc1: movl (sp)+,-(r9) # move a field value ! 7665: sobgtr r6,bdfc1 # loop till all moved ! 7666: movl r8,r9 # recall pointer to pdblk ! 7667: jmp exsid # exit setting id field ! 7668: #page ! 7669: # ! 7670: # EFBLK ! 7671: # ! 7672: # THE ROUTINE FOR AN EFBLK IS PASSED CONTROL FORM THE O$FNC ! 7673: # ENTRY TO CALL AN EXTERNAL FUNCTION. ! 7674: # ! 7675: # (XL) POINTER TO EFBLK ! 7676: # ! 7677: .align 2 ! 7678: .word bl$ef ! 7679: b$efc: # entry point (efblk) ! 7680: movl 4*fargs(r10),r8 # load number of arguments ! 7681: moval 0[r8],r8 # convert to offset ! 7682: movl r10,-(sp) # save pointer to efblk ! 7683: movl sp,r10 # copy pointer to arguments ! 7684: # ! 7685: # LOOP TO CONVERT ARGUMENTS ! 7686: # ! 7687: befc1: addl2 $4,r10 # point to next entry ! 7688: movl (sp),r9 # load pointer to efblk ! 7689: subl2 $4,r8 # decrement eftar offset ! 7690: addl2 r8,r9 # point to next eftar entry ! 7691: movl 4*eftar(r9),r9 # load eftar entry ! 7692: casel r9,$0,$4 # switch on type ! 7693: 5: ! 7694: .word befc7-5b # no conversion needed ! 7695: .word befc2-5b # string ! 7696: .word befc3-5b # integer ! 7697: .word befc4-5b # real ! 7698: #esw # end of switch on type ! 7699: # ! 7700: # HERE TO CONVERT TO STRING ! 7701: # ! 7702: befc2: movl (r10),-(sp) # stack arg ptr ! 7703: jsb gtstg # convert argument to string ! 7704: .long er_039 # external function argument is not string ! 7705: jmp befc6 # jump to merge ! 7706: #page ! 7707: # ! 7708: # EFBLK (CONTINUED) ! 7709: # ! 7710: # HERE TO CONVERT AN INTEGER ! 7711: # ! 7712: befc3: movl (r10),r9 # load next argument ! 7713: movl r8,befof # save offset ! 7714: jsb gtint # convert to integer ! 7715: .long er_040 # external function argument is not integer ! 7716: jmp befc5 # merge with real case ! 7717: # ! 7718: # HERE TO CONVERT A REAL ! 7719: # ! 7720: befc4: movl (r10),r9 # load next argument ! 7721: movl r8,befof # save offset ! 7722: jsb gtrea # convert to real ! 7723: .long er_265 # external function argument is not real ! 7724: # ! 7725: # INTEGER CASE MERGES HERE ! 7726: # ! 7727: befc5: movl befof,r8 # restore offset ! 7728: # ! 7729: # STRING MERGES HERE ! 7730: # ! 7731: befc6: movl r9,(r10) # store converted result ! 7732: # ! 7733: # NO CONVERSION MERGES HERE ! 7734: # ! 7735: befc7: tstl r8 # loop back if more to go ! 7736: bnequ befc1 ! 7737: # ! 7738: # HERE AFTER CONVERTING ALL THE ARGUMENTS ! 7739: # ! 7740: movl (sp)+,r10 # restore efblk pointer ! 7741: movl 4*fargs(r10),r6 # get number of args ! 7742: jsb sysex # call routine to call external fnc ! 7743: .long exfal # fail if failure ! 7744: #page ! 7745: # ! 7746: # EFBLK (CONTINUED) ! 7747: # ! 7748: # RETURN HERE WITH RESULT IN XR ! 7749: # ! 7750: # FIRST DEFEND AGAINST NON-STANDARD NULL STRING RETURNED ! 7751: # ! 7752: movl 4*efrsl(r10),r7 # get result type id ! 7753: bnequ befa8 # branch if not unconverted ! 7754: cmpl (r9),$b$scl # jump if not a string ! 7755: bnequ befc8 ! 7756: tstl 4*sclen(r9) # return null if null ! 7757: bnequ 0f ! 7758: jmp exnul ! 7759: 0: ! 7760: # ! 7761: # HERE IF CONVERTED RESULT TO CHECK FOR NULL STRING ! 7762: # ! 7763: befa8: cmpl r7,$num01 # 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: # RETURN IF RESULT IS IN DYNAMIC STORAGE ! 7771: # ! 7772: befc8: cmpl r9,dnamb # jump if not in dynamic storage ! 7773: blssu befc9 ! 7774: cmpl r9,dnamp # return result if already dynamic ! 7775: bgtru 0f ! 7776: jmp exixr ! 7777: 0: ! 7778: # ! 7779: # HERE WE COPY A RESULT INTO THE DYNAMIC REGION ! 7780: # ! 7781: befc9: movl (r9),r6 # get possible type word ! 7782: tstl r7 # jump if unconverted result ! 7783: beqlu bef11 ! 7784: movl $b$scl,r6 # string ! 7785: cmpl r7,$num01 # yes jump ! 7786: beqlu bef10 ! 7787: movl $b$icl,r6 # integer ! 7788: cmpl r7,$num02 # yes jump ! 7789: beqlu bef10 ! 7790: movl $b$rcl,r6 # real ! 7791: # ! 7792: # STORE TYPE WORD IN RESULT ! 7793: # ! 7794: bef10: movl r6,(r9) # stored before copying to dynamic ! 7795: # ! 7796: # MERGE FOR UNCONVERTED RESULT ! 7797: # ! 7798: bef11: jsb blkln # get length of block ! 7799: movl r9,r10 # copy address of old block ! 7800: jsb alloc # allocate dynamic block same size ! 7801: movl r9,-(sp) # set pointer to new block as result ! 7802: jsb sbmvw # copy old block to dynamic block ! 7803: jmp exits # exit with result on stack ! 7804: #page ! 7805: # ! 7806: # EVBLK ! 7807: # ! 7808: # THE ROUTINE FOR AN EVBLK IS NEVER EXECUTED ! 7809: # ! 7810: .align 2 ! 7811: .word bl$ev ! 7812: b$evt: # entry point (evblk) ! 7813: #page ! 7814: # ! 7815: # FFBLK ! 7816: # ! 7817: # THE ROUTINE FOR AN FFBLK IS EXECUTED FROM THE O$FNC ENTRY ! 7818: # TO CALL A FIELD FUNCTION AND EXTRACT A FIELD VALUE/NAME. ! 7819: # ! 7820: # (XL) POINTER TO FFBLK ! 7821: # ! 7822: .align 2 ! 7823: .word bl$ff ! 7824: b$ffc: # entry point (ffblk) ! 7825: movl r10,r9 # copy ffblk pointer ! 7826: movl (r3)+,r8 # load next code word ! 7827: movl (sp),r10 # load pdblk pointer ! 7828: cmpl (r10),$b$pdt # jump if not pdblk at all ! 7829: bnequ bffc2 ! 7830: movl 4*pddfp(r10),r6 # load dfblk pointer from pdblk ! 7831: # ! 7832: # LOOP TO FIND CORRECT FFBLK FOR THIS PDBLK ! 7833: # ! 7834: bffc1: cmpl r6,4*ffdfp(r9) # jump if this is the correct ffblk ! 7835: beqlu bffc3 ! 7836: movl 4*ffnxt(r9),r9 # else link to next ffblk on chain ! 7837: bnequ bffc1 # loop back if another entry to check ! 7838: # ! 7839: # HERE FOR BAD ARGUMENT ! 7840: # ! 7841: bffc2: jmp er_041 # field function argument is wrong datatype ! 7842: #page ! 7843: # ! 7844: # FFBLK (CONTINUED) ! 7845: # ! 7846: # HERE AFTER LOCATING CORRECT FFBLK ! 7847: # ! 7848: bffc3: movl 4*ffofs(r9),r6 # load field offset ! 7849: cmpl r8,$ofne$ # jump if called by name ! 7850: beqlu bffc5 ! 7851: addl2 r6,r10 # else point to value field ! 7852: movl (r10),r9 # load value ! 7853: cmpl (r9),$b$trt # jump if not trapped ! 7854: bnequ bffc4 ! 7855: subl2 r6,r10 # else restore name base,offset ! 7856: movl r8,(sp) # save next code word over pdblk ptr ! 7857: jsb acess # access value ! 7858: .long exfal # fail if access fails ! 7859: movl (sp),r8 # restore next code word ! 7860: # ! 7861: # HERE AFTER GETTING VALUE IN (XR) ! 7862: # ! 7863: bffc4: movl r9,(sp) # store value on stack (over pdblk) ! 7864: movl r8,r9 # copy next code word ! 7865: movl (r9),r10 # load entry address ! 7866: movl r10,r11 # jump to routine for next code word ! 7867: jmp (r11) ! 7868: # ! 7869: # HERE IF CALLED BY NAME ! 7870: # ! 7871: bffc5: movl r6,-(sp) # store name offset (base is set) ! 7872: jmp exits # exit with name on stack ! 7873: #page ! 7874: # ! 7875: # ICBLK ! 7876: # ! 7877: # THE ROUTINE FOR ICBLK IS EXECUTED FROM THE GENERATED ! 7878: # CODE TO LOAD AN INTEGER VALUE ONTO THE STACK. ! 7879: # ! 7880: # (XR) POINTER TO ICBLK ! 7881: # ! 7882: .align 2 ! 7883: .word bl$ic ! 7884: b$icl: # entry point (icblk) ! 7885: jmp exixr # stack xr and obey next code word ! 7886: #page ! 7887: # ! 7888: # KVBLK ! 7889: # ! 7890: # THE ROUTINE FOR A KVBLK IS NEVER EXECUTED. ! 7891: # ! 7892: .align 2 ! 7893: .word bl$kv ! 7894: b$kvt: # entry point (kvblk) ! 7895: #page ! 7896: # ! 7897: # NMBLK ! 7898: # ! 7899: # THE ROUTINE FOR A NMBLK IS EXECUTED FROM THE GENERATED ! 7900: # CODE FOR THE CASE OF LOADING A NAME ONTO THE STACK ! 7901: # WHERE THE NAME IS THAT OF A NATURAL VARIABLE WHICH CAN ! 7902: # BE PREEVALUATED AT COMPILE TIME. ! 7903: # ! 7904: # (XR) POINTER TO NMBLK ! 7905: # ! 7906: .align 2 ! 7907: .word bl$nm ! 7908: b$nml: # entry point (nmblk) ! 7909: jmp exixr # stack xr and obey next code word ! 7910: #page ! 7911: # ! 7912: # PDBLK ! 7913: # ! 7914: # THE ROUTINE FOR A PDBLK IS NEVER EXECUTED ! 7915: # ! 7916: .align 2 ! 7917: .word bl$pd ! 7918: b$pdt: # entry point (pdblk) ! 7919: #page ! 7920: # ! 7921: # PFBLK ! 7922: # ! 7923: # THE ROUTINE FOR A PFBLK IS EXECUTED FROM THE ENTRY O$FNC ! 7924: # TO CALL A PROGRAM DEFINED FUNCTION. ! 7925: # ! 7926: # (XL) POINTER TO PFBLK ! 7927: # ! 7928: # THE FOLLOWING STACK ENTRIES ARE MADE BEFORE PASSING ! 7929: # CONTROL TO THE PROGRAM DEFINED FUNCTION. ! 7930: # ! 7931: # SAVED VALUE OF FIRST ARGUMENT ! 7932: # . ! 7933: # SAVED VALUE OF LAST ARGUMENT ! 7934: # SAVED VALUE OF FIRST LOCAL ! 7935: # . ! 7936: # SAVED VALUE OF LAST LOCAL ! 7937: # SAVED VALUE OF FUNCTION NAME ! 7938: # SAVED CODE BLOCK PTR (R$COD) ! 7939: # SAVED CODE POINTER (-R$COD) ! 7940: # SAVED VALUE OF FLPRT ! 7941: # SAVED VALUE OF FLPTR ! 7942: # POINTER TO PFBLK ! 7943: # FLPTR --------------- ZERO (TO BE OVERWRITTEN WITH OFFS) ! 7944: # ! 7945: .align 2 ! 7946: .word bl$pf ! 7947: b$pfc: # entry point (pfblk) ! 7948: movl r10,bpfpf # save pfblk ptr (need not be reloc) ! 7949: movl r10,r9 # copy for the moment ! 7950: movl 4*pfvbl(r9),r10 # point to vrblk for function ! 7951: # ! 7952: # LOOP TO FIND OLD VALUE OF FUNCTION ! 7953: # ! 7954: bpf01: movl r10,r7 # save pointer ! 7955: movl 4*vrval(r10),r10# load value ! 7956: cmpl (r10),$b$trt # loop if trblk ! 7957: beqlu bpf01 ! 7958: # ! 7959: # SET VALUE TO NULL AND SAVE OLD FUNCTION VALUE ! 7960: # ! 7961: movl r10,bpfsv # save old value ! 7962: movl r7,r10 # point back to block with value ! 7963: movl $nulls,4*vrval(r10) # set value to null ! 7964: movl 4*fargs(r9),r6 # load number of arguments ! 7965: addl2 $4*pfarg,r9 # point to pfarg entries ! 7966: tstl r6 # jump if no arguments ! 7967: beqlu bpf04 ! 7968: movl sp,r10 # ptr to last arg ! 7969: moval 0[r6],r6 # convert no. of args to bytes offset ! 7970: addl2 r6,r10 # point before first arg ! 7971: movl r10,bpfxt # remember arg pointer ! 7972: #page ! 7973: # ! 7974: # PFBLK (CONTINUED) ! 7975: # ! 7976: # LOOP TO SAVE OLD ARGUMENT VALUES AND SET NEW ONES ! 7977: # ! 7978: bpf02: movl (r9)+,r10 # load vrblk ptr for next argument ! 7979: # ! 7980: # LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE ! 7981: # ! 7982: bpf03: movl r10,r8 # save pointer ! 7983: movl 4*vrval(r10),r10# load next value ! 7984: cmpl (r10),$b$trt # loop back if trblk ! 7985: beqlu bpf03 ! 7986: # ! 7987: # SAVE OLD VALUE AND GET NEW VALUE ! 7988: # ! 7989: movl r10,r6 # keep old value ! 7990: movl bpfxt,r10 # point before next stacked arg ! 7991: movl -(r10),r7 # load argument (new value) ! 7992: movl r6,(r10) # save old value ! 7993: movl r10,bpfxt # keep arg ptr for next time ! 7994: movl r8,r10 # point back to block with value ! 7995: movl r7,4*vrval(r10) # set new value ! 7996: cmpl sp,bpfxt # loop if not all done ! 7997: bnequ bpf02 ! 7998: # ! 7999: # NOW PROCESS LOCALS ! 8000: # ! 8001: bpf04: movl bpfpf,r10 # restore pfblk pointer ! 8002: movl 4*pfnlo(r10),r6 # load number of locals ! 8003: beqlu bpf07 # jump if no locals ! 8004: movl $nulls,r7 # get null constant ! 8005: # set local counter ! 8006: # ! 8007: # LOOP TO PROCESS LOCALS ! 8008: # ! 8009: bpf05: movl (r9)+,r10 # load vrblk ptr for next local ! 8010: # ! 8011: # LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE ! 8012: # ! 8013: bpf06: movl r10,r8 # save pointer ! 8014: movl 4*vrval(r10),r10# load next value ! 8015: cmpl (r10),$b$trt # loop back if trblk ! 8016: beqlu bpf06 ! 8017: # ! 8018: # SAVE OLD VALUE AND SET NULL AS NEW VALUE ! 8019: # ! 8020: movl r10,-(sp) # stack old value ! 8021: movl r8,r10 # point back to block with value ! 8022: movl r7,4*vrval(r10) # set null as new value ! 8023: sobgtr r6,bpf05 # loop till all locals processed ! 8024: #page ! 8025: # ! 8026: # PFBLK (CONTINUED) ! 8027: # ! 8028: # HERE AFTER PROCESSING ARGUMENTS AND LOCALS ! 8029: # ! 8030: bpf07: clrl r9 # zero reg xr in case ! 8031: tstl kvpfl # skip if profiling is off ! 8032: beqlu bpf7c ! 8033: cmpl kvpfl,$num02 # branch on type of profile ! 8034: beqlu bpf7a ! 8035: # ! 8036: # HERE IF &PROFILE = 1 ! 8037: # ! 8038: jsb systm # get current time ! 8039: movl r5,pfetm # save for a sec ! 8040: subl2 pfstm,r5 # find time used by caller ! 8041: jsb icbld # build into an icblk ! 8042: movl pfetm,r5 # reload current time ! 8043: jmp bpf7b # merge ! 8044: # ! 8045: # HERE IF &PROFILE = 2 ! 8046: # ! 8047: bpf7a: movl pfstm,r5 # get start time of calling stmt ! 8048: jsb icbld # assemble an icblk round it ! 8049: jsb systm # get now time ! 8050: # ! 8051: # BOTH TYPES OF PROFILE MERGE HERE ! 8052: # ! 8053: bpf7b: movl r5,pfstm # set start time of 1st func stmt ! 8054: movl sp,pffnc # flag function entry ! 8055: # ! 8056: # NO PROFILING MERGES HERE ! 8057: # ! 8058: bpf7c: movl r9,-(sp) # stack icblk ptr (or zero) ! 8059: movl r$cod,r6 # load old code block pointer ! 8060: movl r3,r7 # get code pointer ! 8061: subl2 r6,r7 # make code pointer into offset ! 8062: movl bpfpf,r10 # recall pfblk pointer ! 8063: movl bpfsv,-(sp) # stack old value of function name ! 8064: movl r6,-(sp) # stack code block pointer ! 8065: movl r7,-(sp) # stack code offset ! 8066: movl flprt,-(sp) # stack old flprt ! 8067: movl flptr,-(sp) # stack old failure pointer ! 8068: movl r10,-(sp) # stack pointer to pfblk ! 8069: clrl -(sp) # dummy zero entry for fail return ! 8070: jsb sbchk # check for stack overflow ! 8071: movl sp,flptr # set new fail return value ! 8072: movl sp,flprt # set new flprt ! 8073: movl kvtra,r6 # load trace value ! 8074: addl2 kvftr,r6 # add ftrace value ! 8075: bnequ bpf09 # jump if tracing possible ! 8076: incl kvfnc # else bump fnclevel ! 8077: # ! 8078: # HERE TO ACTUALLY JUMP TO FUNCTION ! 8079: # ! 8080: bpf08: movl 4*pfcod(r10),r9 # point to code ! 8081: movl (r9),r11 # off to execute function ! 8082: jmp (r11) ! 8083: # ! 8084: # HERE IF TRACING IS POSSIBLE ! 8085: # ! 8086: bpf09: movl 4*pfctr(r10),r9 # load possible call trace trblk ! 8087: movl 4*pfvbl(r10),r10# load vrblk pointer for function ! 8088: movl $4*vrval,r6 # set name offset for variable ! 8089: tstl kvtra # jump if trace mode is off ! 8090: beqlu bpf10 ! 8091: tstl r9 # or if there is no call trace ! 8092: beqlu bpf10 ! 8093: # ! 8094: # HERE IF CALL TRACED ! 8095: # ! 8096: decl kvtra # decrement trace count ! 8097: tstl 4*trfnc(r9) # jump if print trace ! 8098: beqlu bpf11 ! 8099: jsb trxeq # execute function type trace ! 8100: #page ! 8101: # ! 8102: # PFBLK (CONTINUED) ! 8103: # ! 8104: # HERE TO TEST FOR FTRACE TRACE ! 8105: # ! 8106: bpf10: tstl kvftr # jump if ftrace is off ! 8107: beqlu bpf16 ! 8108: decl kvftr # else decrement ftrace ! 8109: # ! 8110: # HERE FOR PRINT TRACE ! 8111: # ! 8112: bpf11: jsb prtsn # print statement number ! 8113: jsb prtnm # print function name ! 8114: movl $ch$pp,r6 # load left paren ! 8115: jsb prtch # print left paren ! 8116: movl 4*1(sp),r10 # recover pfblk pointer ! 8117: tstl 4*fargs(r10) # skip if no arguments ! 8118: beqlu bpf15 ! 8119: clrl r7 # else set argument counter ! 8120: jmp bpf13 # jump into loop ! 8121: # ! 8122: # LOOP TO PRINT ARGUMENT VALUES ! 8123: # ! 8124: bpf12: movl $ch$cm,r6 # load comma ! 8125: jsb prtch # print to separate from last arg ! 8126: # ! 8127: # MERGE HERE FIRST TIME (NO COMMA REQUIRED) ! 8128: # ! 8129: bpf13: movl r7,(sp) # save arg ctr (over failoffs is ok) ! 8130: moval 0[r7],r7 # convert to byte offset ! 8131: addl2 r7,r10 # point to next argument pointer ! 8132: movl 4*pfarg(r10),r9 # load next argument vrblk ptr ! 8133: subl2 r7,r10 # restore pfblk pointer ! 8134: movl 4*vrval(r9),r9 # load next value ! 8135: jsb prtvl # print argument value ! 8136: #page ! 8137: # ! 8138: # HERE AFTER DEALING WITH ONE ARGUMENT ! 8139: # ! 8140: movl (sp),r7 # restore argument counter ! 8141: incl r7 # increment argument counter ! 8142: cmpl r7,4*fargs(r10) # loop if more to print ! 8143: blssu bpf12 ! 8144: # ! 8145: # MERGE HERE IN NO ARGS CASE TO PRINT PAREN ! 8146: # ! 8147: bpf15: movl $ch$rp,r6 # load right paren ! 8148: jsb prtch # print to terminate output ! 8149: jsb prtnl # terminate print line ! 8150: # ! 8151: # MERGE HERE TO EXIT WITH TEST FOR FNCLEVEL TRACE ! 8152: # ! 8153: bpf16: incl kvfnc # increment fnclevel ! 8154: movl r$fnc,r10 # load ptr to possible trblk ! 8155: jsb ktrex # call keyword trace routine ! 8156: # ! 8157: # CALL FUNCTION AFTER TRACE TESTS COMPLETE ! 8158: # ! 8159: movl 4*1(sp),r10 # restore pfblk pointer ! 8160: jmp bpf08 # jump back to execute function ! 8161: #page ! 8162: # ! 8163: # RCBLK ! 8164: # ! 8165: # THE ROUTINE FOR AN RCBLK IS EXECUTED FROM THE GENERATED ! 8166: # CODE TO LOAD A REAL VALUE ONTO THE STACK. ! 8167: # ! 8168: # (XR) POINTER TO RCBLK ! 8169: # ! 8170: .align 2 ! 8171: .word bl$rc ! 8172: b$rcl: # entry point (rcblk) ! 8173: jmp exixr # stack xr and obey next code word ! 8174: #page ! 8175: # ! 8176: # SCBLK ! 8177: # ! 8178: # THE ROUTINE FOR AN SCBLK IS EXECUTED FROM THE GENERATED ! 8179: # CODE TO LOAD A STRING VALUE ONTO THE STACK. ! 8180: # ! 8181: # (XR) POINTER TO SCBLK ! 8182: # ! 8183: .align 2 ! 8184: .word bl$sc ! 8185: b$scl: # entry point (scblk) ! 8186: jmp exixr # stack xr and obey next code word ! 8187: #page ! 8188: # ! 8189: # TBBLK ! 8190: # ! 8191: # THE ROUTINE FOR A TBBLK IS NEVER EXECUTED ! 8192: # ! 8193: .align 2 ! 8194: .word bl$tb ! 8195: b$tbt: # entry point (tbblk) ! 8196: #page ! 8197: # ! 8198: # TEBLK ! 8199: # ! 8200: # THE ROUTINE FOR A TEBLK IS NEVER EXECUTED ! 8201: # ! 8202: .align 2 ! 8203: .word bl$te ! 8204: b$tet: # entry point (teblk) ! 8205: #page ! 8206: # ! 8207: # VCBLK ! 8208: # ! 8209: # THE ROUTINE FOR A VCBLK IS NEVER EXECUTED ! 8210: # ! 8211: .align 2 ! 8212: .word bl$vc ! 8213: b$vct: # entry point (vcblk) ! 8214: #page ! 8215: # ! 8216: # VRBLK ! 8217: # ! 8218: # THE VRBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE. ! 8219: # THERE ARE SIX ENTRIES FOR VRBLK COVERING VARIOUS CASES ! 8220: # ! 8221: .align 2 ! 8222: .word bl$$i ! 8223: b$vr$: # mark start of vrblk entry points ! 8224: # ! 8225: # ENTRY FOR VRGET (TRAPPED CASE). THIS ROUTINE IS CALLED ! 8226: # FROM THE GENERATED CODE TO LOAD THE VALUE OF A VARIABLE. ! 8227: # THIS ENTRY POINT IS USED IF AN ACCESS TRACE OR INPUT ! 8228: # ASSOCIATION IS CURRENTLY ACTIVE. ! 8229: # ! 8230: # (XR) POINTER TO VRGET FIELD OF VRBLK ! 8231: # ! 8232: .align 2 ! 8233: .word bl$$i ! 8234: b$vra: # entry point ! 8235: movl r9,r10 # copy name base (vrget = 0) ! 8236: movl $4*vrval,r6 # set name offset ! 8237: jsb acess # access value ! 8238: .long exfal # fail if access fails ! 8239: jmp exixr # else exit with result in xr ! 8240: #page ! 8241: # ! 8242: # VRBLK (CONTINUED) ! 8243: # ! 8244: # ENTRY FOR VRSTO (ERROR CASE. THIS ROUTINE IS CALLED FROM ! 8245: # THE EXECUTED CODE FOR AN ATTEMPT TO MODIFY THE VALUE ! 8246: # OF A PROTECTED (PATTERN VALUED) NATURAL VARIABLE. ! 8247: # ! 8248: b$vre: # entry point ! 8249: jmp er_042 # attempt to change value of protected variable ! 8250: #page ! 8251: # ! 8252: # VRBLK (CONTINUED) ! 8253: # ! 8254: # ENTRY FOR VRTRA (UNTRAPPED CASE). THIS ROUTINE IS CALLED ! 8255: # FROM THE EXECUTED CODE TO TRANSFER TO A LABEL. ! 8256: # ! 8257: # (XR) POINTER TO VRTRA FIELD OF VRBLK ! 8258: # ! 8259: b$vrg: # entry point ! 8260: movl 4*vrlbo(r9),r9 # load code pointer ! 8261: movl (r9),r10 # load entry address ! 8262: movl r10,r11 # jump to routine for next code word ! 8263: jmp (r11) ! 8264: #page ! 8265: # ! 8266: # VRBLK (CONTINUED) ! 8267: # ! 8268: # ENTRY FOR VRGET (UNTRAPPED CASE). THIS ROUTINE IS CALLED ! 8269: # FROM THE GENERATED CODE TO LOAD THE VALUE OF A VARIABLE. ! 8270: # ! 8271: # (XR) POINTS TO VRGET FIELD OF VRBLK ! 8272: # ! 8273: b$vrl: # entry point ! 8274: movl 4*vrval(r9),-(sp)# load value onto stack (vrget = 0) ! 8275: jmp exits # obey next code word ! 8276: #page ! 8277: # ! 8278: # VRBLK (CONTINUED) ! 8279: # ! 8280: # ENTRY FOR VRSTO (UNTRAPPED CASE). THIS ROUTINE IS CALLED ! 8281: # FROM THE GENERATED CODE TO STORE THE VALUE OF A VARIABLE. ! 8282: # ! 8283: # (XR) POINTER TO VRSTO FIELD OF VRBLK ! 8284: # ! 8285: b$vrs: # entry point ! 8286: movl (sp),4*vrvlo(r9)# store value, leave on stack ! 8287: jmp exits # obey next code word ! 8288: #page ! 8289: # ! 8290: # VRBLK (CONTINUED) ! 8291: # ! 8292: # VRTRA (TRAPPED CASE). THIS ROUTINE IS CALLED FROM THE ! 8293: # GENERATED CODE TO TRANSFER TO A LABEL WHEN A LABEL ! 8294: # TRACE IS CURRENTLY ACTIVE. ! 8295: # ! 8296: b$vrt: # entry point ! 8297: subl2 $4*vrtra,r9 # point back to start of vrblk ! 8298: movl r9,r10 # copy vrblk pointer ! 8299: movl $4*vrval,r6 # set name offset ! 8300: movl 4*vrlbl(r10),r9 # load pointer to trblk ! 8301: tstl kvtra # jump if trace is off ! 8302: beqlu bvrt2 ! 8303: decl kvtra # else decrement trace count ! 8304: tstl 4*trfnc(r9) # jump if print trace case ! 8305: beqlu bvrt1 ! 8306: jsb trxeq # else execute full trace ! 8307: jmp bvrt2 # merge to jump to label ! 8308: # ! 8309: # HERE FOR PRINT TRACE -- PRINT COLON ( LABEL NAME ) ! 8310: # ! 8311: bvrt1: jsb prtsn # print statement number ! 8312: movl r10,r9 # copy vrblk pointer ! 8313: movl $ch$cl,r6 # colon ! 8314: jsb prtch # print it ! 8315: movl $ch$pp,r6 # left paren ! 8316: jsb prtch # print it ! 8317: jsb prtvn # print label name ! 8318: movl $ch$rp,r6 # right paren ! 8319: jsb prtch # print it ! 8320: jsb prtnl # terminate line ! 8321: movl 4*vrlbl(r10),r9 # point back to trblk ! 8322: # ! 8323: # MERGE HERE TO JUMP TO LABEL ! 8324: # ! 8325: bvrt2: movl 4*trlbl(r9),r9 # load pointer to actual code ! 8326: movl (r9),r11 # execute statement at label ! 8327: jmp (r11) ! 8328: #page ! 8329: # ! 8330: # VRBLK (CONTINUED) ! 8331: # ! 8332: # ENTRY FOR VRSTO (TRAPPED CASE). THIS ROUTINE IS CALLED ! 8333: # FROM THE GENERATED CODE TO STORE THE VALUE OF A VARIABLE. ! 8334: # THIS ENTRY IS USED WHEN A VALUE TRACE OR OUTPUT ! 8335: # ASSOCIATION IS CURRENTLY ACTIVE. ! 8336: # ! 8337: # (XR) POINTER TO VRSTO FIELD OF VRBLK ! 8338: # ! 8339: b$vrv: # entry point ! 8340: movl (sp),r7 # load value (leave copy on stack) ! 8341: subl2 $4*vrsto,r9 # point to vrblk ! 8342: movl r9,r10 # copy vrblk pointer ! 8343: movl $4*vrval,r6 # set offset ! 8344: jsb asign # call assignment routine ! 8345: .long exfal # fail if assignment fails ! 8346: jmp exits # else return with result on stack ! 8347: #page ! 8348: # ! 8349: # XNBLK ! 8350: # ! 8351: # THE ROUTINE FOR AN XNBLK IS NEVER EXECUTED ! 8352: # ! 8353: .align 2 ! 8354: .word bl$xn ! 8355: b$xnt: # entry point (xnblk) ! 8356: #page ! 8357: # ! 8358: # XRBLK ! 8359: # ! 8360: # THE ROUTINE FOR AN XRBLK IS NEVER EXECUTED ! 8361: # ! 8362: .align 2 ! 8363: .word bl$xr ! 8364: b$xrt: # entry point (xrblk) ! 8365: # ! 8366: # MARK ENTRY ADDRESS PAST LAST BLOCK ACTION ROUTINE ! 8367: # ! 8368: .align 2 ! 8369: .word bl$$i ! 8370: b$yyy: # last block routine entry point ! 8371: #title s p i t b o l -- pattern matching routines ! 8372: # ! 8373: # THE FOLLOWING SECTION CONSISTS OF THE PATTERN MATCHING ! 8374: # ROUTINES. ALL PATTERN NODES CONTAIN A POINTER (PCODE) ! 8375: # TO ONE OF THE ROUTINES IN THIS SECTION (P$XXX). ! 8376: # ! 8377: # NOTE THAT THIS SECTION FOLLOWS THE B$XXX ROUTINES TO ! 8378: # ENABLE A FAST TEST FOR THE PATTERN DATATYPE. ! 8379: # ! 8380: .align 2 ! 8381: .word bl$$i ! 8382: p$aaa: # entry to mark first pattern ! 8383: # ! 8384: # ! 8385: # THE ENTRY CONDITIONS TO THE MATCH ROUTINE ARE AS FOLLOWS ! 8386: # (SEE O$PMN, O$PMV, O$PMS AND PROCEDURE MATCH). ! 8387: # ! 8388: # STACK CONTENTS. ! 8389: # ! 8390: # NAME BASE (O$PMN ONLY) ! 8391: # NAME OFFSET (O$PMN ONLY) ! 8392: # TYPE (0-O$PMN, 1-O$PMV, 2-O$PMS) ! 8393: # PMHBS --------------- INITIAL CURSOR (ZERO) ! 8394: # INITIAL NODE POINTER ! 8395: # XS ------------------ =NDABO (ANCHORED), =NDUNA (UNANCH) ! 8396: # ! 8397: # REGISTER VALUES. ! 8398: # ! 8399: # (XS) SET AS SHOWN IN STACK DIAGRAM ! 8400: # (XR) POINTER TO INITIAL PATTERN NODE ! 8401: # (WB) INITIAL CURSOR (ZERO) ! 8402: # ! 8403: # GLOBAL PATTERN VALUES ! 8404: # ! 8405: # R$PMS POINTER TO SUBJECT STRING SCBLK ! 8406: # PMSSL LENGTH OF SUBJECT STRING IN CHARS ! 8407: # PMDFL DOT FLAG, INITIALLY ZERO ! 8408: # PMHBS SET AS SHOWN IN STACK DIAGRAM ! 8409: # ! 8410: # CONTROL IS PASSED BY BRANCHING THROUGH THE PCODE ! 8411: # FIELD OF THE INITIAL PATTERN NODE (BRI (XR)). ! 8412: #page ! 8413: # ! 8414: # DESCRIPTION OF ALGORITHM ! 8415: # ! 8416: # A PATTERN STRUCTURE IS REPRESENTED AS A LINKED GRAPH ! 8417: # OF NODES WITH THE FOLLOWING STRUCTURE. ! 8418: # ! 8419: # +------------------------------------+ ! 8420: # I PCODE I ! 8421: # +------------------------------------+ ! 8422: # I PTHEN I ! 8423: # +------------------------------------+ ! 8424: # I PARM1 I ! 8425: # +------------------------------------+ ! 8426: # I PARM2 I ! 8427: # +------------------------------------+ ! 8428: # ! 8429: # PCODE IS A POINTER TO THE ROUTINE WHICH WILL PERFORM ! 8430: # THE MATCH OF THIS PARTICULAR NODE TYPE. ! 8431: # ! 8432: # PTHEN IS A POINTER TO THE SUCCESSOR NODE. I.E. THE NODE ! 8433: # TO BE MATCHED IF THE ATTEMPT TO MATCH THIS NODE SUCCEEDS. ! 8434: # IF THIS IS THE LAST NODE OF THE PATTERN PTHEN POINTS ! 8435: # TO THE DUMMY NODE NDNTH WHICH INITIATES PATTERN EXIT. ! 8436: # ! 8437: # PARM1, PARM2 ARE PARAMETERS WHOSE USE VARIES WITH THE ! 8438: # PARTICULAR NODE. THEY ARE ONLY PRESENT IF REQUIRED. ! 8439: # ! 8440: # ALTERNATIVES ARE HANDLED WITH THE SPECIAL ALTERNATIVE ! 8441: # NODE WHOSE PARAMETER POINTS TO THE NODE TO BE MATCHED ! 8442: # IF THERE IS A FAILURE ON THE SUCCESSOR PATH. ! 8443: # ! 8444: # THE FOLLOWING EXAMPLE ILLUSTRATES THE MANNER IN WHICH ! 8445: # THE STRUCTURE IS BUILT UP. THE PATTERN IS ! 8446: # ! 8447: # (A / B / C) (D / E) WHERE / IS ALTERNATION ! 8448: # ! 8449: # IN THE DIAGRAM, THE NODE MARKED + REPRESENTS AN ! 8450: # ALTERNATIVE NODE AND THE DOTTED LINE FROM A + NODE ! 8451: # REPRESENTS THE PARAMETER POINTER TO THE ALTERNATIVE. ! 8452: # ! 8453: # +---+ +---+ +---+ +---+ ! 8454: # I + I-----I A I-----I + I-----I D I----- ! 8455: # +---+ +---+ I +---+ +---+ ! 8456: # . I . ! 8457: # . I . ! 8458: # +---+ +---+ I +---+ ! 8459: # I + I-----I B I--I I E I----- ! 8460: # +---+ +---+ I +---+ ! 8461: # . I ! 8462: # . I ! 8463: # +---+ I ! 8464: # I C I------------I ! 8465: # +---+ ! 8466: #page ! 8467: # ! 8468: # DURING THE MATCH, THE REGISTERS ARE USED AS FOLLOWS. ! 8469: # ! 8470: # (XR) POINTS TO THE CURRENT NODE ! 8471: # (XL) SCRATCH ! 8472: # (XS) MAIN STACK POINTER ! 8473: # (WB) CURSOR (NUMBER OF CHARS MATCHED) ! 8474: # (WA,WC) SCRATCH ! 8475: # ! 8476: # TO KEEP TRACK OF ALTERNATIVES, THE MAIN STACK IS USED AS ! 8477: # A HISTORY STACK AND CONTAINS TWO WORD ENTRIES. ! 8478: # ! 8479: # WORD 1 SAVED CURSOR VALUE ! 8480: # WORD 2 NODE TO MATCH ON FAILURE ! 8481: # ! 8482: # WHEN A FAILURE OCCURS, THE MOST RECENT ENTRY ON THIS ! 8483: # STACK IS POPPED OFF TO RESTORE THE CURSOR AND POINT ! 8484: # TO THE NODE TO BE MATCHED AS AN ALTERNATIVE. THE ENTRY ! 8485: # AT THE BOTTOM OF THE STACK POINTS TO THE FOLLOWING ! 8486: # SPECIAL NODES DEPENDING ON THE SCAN MODE. ! 8487: # ! 8488: # ANCHORED MODE THE BOTTOM ENTRY POINTS TO THE ! 8489: # SPECIAL NODE NDABO WHICH CAUSES AN ! 8490: # ABORT. THE CURSOR VALUE STORED ! 8491: # WITH THIS ENTRY IS ALWAYS ZERO. ! 8492: # ! 8493: # UNANCHORED MODE THE BOTTOM ENTRY POINTS TO THE ! 8494: # SPECIAL NODE NDUNA WHICH MOVES THE ! 8495: # ANCHOR POINT AND RESTARTS THE MATCH ! 8496: # THE CURSOR SAVED WITH THIS ENTRY ! 8497: # IS THE NUMBER OF CHARACTERS WHICH ! 8498: # LIE BEFORE THE INITIAL ANCHOR POINT ! 8499: # (I.E. THE NUMBER OF ANCHOR MOVES). ! 8500: # THIS ENTRY IS THREE WORDS LONG AND ! 8501: # ALSO CONTAINS THE INITIAL PATTERN. ! 8502: # ! 8503: # ENTRIES ARE MADE ON THIS HISTORY STACK BY ALTERNATIVE ! 8504: # NODES AND BY SOME SPECIAL COMPOUD PATTERNS AS DESCRIBED ! 8505: # LATER ON. THE FOLLOWING GLOBAL LOCATIONS ARE USED DURING ! 8506: # PATTERN MATCHING. ! 8507: # ! 8508: # R$PMS POINTER TO SUBJECT STRING ! 8509: # PMSSL LENGTH OF SUBJECT STRING ! 8510: # PMDFL FLAG SET NON-ZERO FOR DOT PATTERNS ! 8511: # PMHBS BASE PTR FOR CURRENT HISTORY STACK ! 8512: # ! 8513: # THE FOLLOWING EXIT POINTS ARE AVAILABLE TO MATCH ROUTINES ! 8514: # ! 8515: # SUCCP SUCCESS IN MATCHING CURRENT NODE ! 8516: # FAILP FAILURE IN MATCHING CURRENT NODE ! 8517: #page ! 8518: # ! 8519: # COMPOUND PATTERNS ! 8520: # ! 8521: # SOME PATTERNS HAVE IMPLICIT ALTERNATIVES AND THEIR ! 8522: # REPRESENTATION IN THE PATTERN STRUCTURE CONSISTS OF A ! 8523: # LINKED SET OF NODES AS INDICATED BY THESE DIAGRAMS. ! 8524: # ! 8525: # AS BEFORE, THE + REPRESENTS AN ALTERNATIVE NODE AND ! 8526: # THE DOTTED LINE FROM A + NODE IS THE PARAMETER POINTER ! 8527: # TO THE ALTERNATIVE PATTERN. ! 8528: # ! 8529: # ARB ! 8530: # --- ! 8531: # ! 8532: # +---+ THIS NODE (P$ARB) MATCHES NULL ! 8533: # I B I----- AND STACKS CURSOR, SUCCESSOR PTR, ! 8534: # +---+ CURSOR (COPY) AND A PTR TO NDARC. ! 8535: # ! 8536: # ! 8537: # ! 8538: # ! 8539: # BAL ! 8540: # --- ! 8541: # ! 8542: # +---+ THE P$BAL NODE SCANS A BALANCED ! 8543: # I B I----- STRING AND THEN STACKS A POINTER ! 8544: # +---+ TO ITSELF ON THE HISTORY STACK. ! 8545: #page ! 8546: # ! 8547: # COMPOUND PATTERN STRUCTURES (CONTINUED) ! 8548: # ! 8549: # ! 8550: # ARBNO ! 8551: # ----- ! 8552: # ! 8553: # +---+ THIS ALTERNATIVE NODE MATCHES NULL ! 8554: # +----I + I----- THE FIRST TIME AND STACKS A POINTER ! 8555: # I +---+ TO THE ARGUMENT PATTERN X. ! 8556: # I . ! 8557: # I . ! 8558: # I +---+ NODE (P$ABA) TO STACK CURSOR ! 8559: # I I A I AND HISTORY STACK BASE PTR. ! 8560: # I +---+ ! 8561: # I I ! 8562: # I I ! 8563: # I +---+ THIS IS THE ARGUMENT PATTERN. AS ! 8564: # I I X I INDICATED, THE SUCCESSOR OF THE ! 8565: # I +---+ PATTERN IS THE P$ABC NODE ! 8566: # I I ! 8567: # I I ! 8568: # I +---+ THIS NODE (P$ABC) POPS PMHBS, ! 8569: # +----I C I STACKS OLD PMHBS AND PTR TO NDABD ! 8570: # +---+ (UNLESS OPTIMISATION HAS OCCURRED) ! 8571: # ! 8572: # STRUCTURE AND EXECUTION OF THIS PATTERN RESEMBLE THOSE OF ! 8573: # RECURSIVE PATTERN MATCHING AND IMMEDIATE ASSIGNMENT. ! 8574: # THE ALTERNATIVE NODE AT THE HEAD OF THE STRUCTURE MATCHES ! 8575: # NULL INITIALLY BUT ON SUBSEQUENT FAILURE ENSURES ATTEMPT ! 8576: # TO MATCH THE ARGUMENT. BEFORE THE ARGUMENT IS MATCHED ! 8577: # P$ABA STACKS THE CURSOR,PMHBS AND A PTR TO P$ABB. IF ! 8578: # THE ARGUMENT CANT BE MATCHED , P$ABB REMOVES THIS SPECIAL ! 8579: # STACK ENTRY AND FAILS. ! 8580: # IF ARGUMENT IS MATCHED , P$ABC RESTORES THE OUTER PMHBS ! 8581: # VALUE (SAVED BY P$ABA) . THEN IF THE ARGUMENT HAS LEFT ! 8582: # ALTERNATIVES ON STACK IT STACKS THE INNER VALUE OF PMHBS ! 8583: # AND A PTR TO NDABD. IF ARGUMENT LEFT NOTHING ON THE STACK ! 8584: # IT OPTIMISES BY REMOVING ITEMS STACKED BY P$ABA. FINALLY ! 8585: # A CHECK IS MADE THAT ARGUMENT MATCHED MORE THAN THE NULL ! 8586: # STRING (CHECK IS INTENDED TO PREVENT USELESS LOOPING). ! 8587: # IF SO THE SUCCESSOR IS AGAIN THE ALTERNATIVE NODE AT THE ! 8588: # HEAD OF THE STRUCTURE , ENSURING A POSSIBLE EXTRA ATTEMPT ! 8589: # TO MATCH THE ARG IF NECESSARY. IF NOT , THE SUCCESSOR TO ! 8590: # ALTERNATIVE IS TAKEN SO AS TO TERMINATE THE LOOP. P$ABD ! 8591: # RESTORES INNER PMHBS PTR AND FAILS , THUS TRYING TO MATCH ! 8592: # ALTERNATIVES LEFT BY THE ARBNO ARGUMENT. ! 8593: #page ! 8594: # ! 8595: # COMPOUND PATTERN STRUCTURES (CONTINUED) ! 8596: # ! 8597: # BREAKX ! 8598: # ------ ! 8599: # ! 8600: # +---+ THIS NODE IS A BREAK NODE FOR ! 8601: # +----I B I THE ARGUMENT TO BREAKX, IDENTICAL ! 8602: # I +---+ TO AN ORDINARY BREAK NODE. ! 8603: # I I ! 8604: # I I ! 8605: # I +---+ THIS ALTERNATIVE NODE STACKS A ! 8606: # I I + I----- POINTER TO THE BREAKX NODE TO ! 8607: # I +---+ ALLOW FOR SUBSEQUENT FAILURE ! 8608: # I . ! 8609: # I . ! 8610: # I +---+ THIS IS THE BREAKX NODE ITSELF. IT ! 8611: # +----I X I MATCHES ONE CHARACTER AND THEN ! 8612: # +---+ PROCEEDS BACK TO THE BREAK NODE. ! 8613: # ! 8614: # ! 8615: # ! 8616: # ! 8617: # FENCE ! 8618: # ----- ! 8619: # ! 8620: # +---+ THE FENCE NODE MATCHES NULL AND ! 8621: # I F I----- STACKS A POINTER TO NODE NDABO TO ! 8622: # +---+ ABORT ON A SUBSEQUENT REMATCH ! 8623: # ! 8624: # ! 8625: # ! 8626: # ! 8627: # SUCCEED ! 8628: # ------- ! 8629: # ! 8630: # +---+ THE NODE FOR SUCCEED MATCHES NULL ! 8631: # I S I----- AND STACKS A POINTER TO ITSELF ! 8632: # +---+ TO REPEAT THE MATCH ON A FAILURE. ! 8633: #page ! 8634: # ! 8635: # COMPOUND PATTERNS (CONTINUED) ! 8636: # ! 8637: # BINARY DOT (PATTERN ASSIGNMENT) ! 8638: # ------------------------------- ! 8639: # ! 8640: # +---+ THIS NODE (P$PAA) SAVES THE CURRENT ! 8641: # I A I CURSOR AND A POINTER TO THE ! 8642: # +---+ SPECIAL NODE NDPAB ON THE STACK. ! 8643: # I ! 8644: # I ! 8645: # +---+ THIS IS THE STRUCTURE FOR THE ! 8646: # I X I PATTERN LEFT ARGUMENT OF THE ! 8647: # +---+ PATTERN ASSIGNMENT CALL. ! 8648: # I ! 8649: # I ! 8650: # +---+ THIS NODE (P$PAC) SAVES THE CURSOR, ! 8651: # I C I----- A PTR TO ITSELF, THE CURSOR (COPY) ! 8652: # +---+ AND A PTR TO NDPAD ON THE STACK. ! 8653: # ! 8654: # ! 8655: # THE FUNCTION OF THE MATCH ROUTINE FOR NDPAB (P$PAB) ! 8656: # IS SIMPLY TO UNSTACK ITSELF AND FAIL BACK ONTO THE STACK. ! 8657: # ! 8658: # THE MATCH ROUTINE FOR P$PAC ALSO SETS THE GLOBAL PATTERN ! 8659: # FLAG PMDFL NON-ZERO TO INDICATE THAT PATTERN ASSIGNMENTS ! 8660: # MAY HAVE OCCURED IN THE PATTERN MATCH ! 8661: # ! 8662: # IF PMDFL IS SET AT THE END OF THE MATCH (SEE P$NTH), THE ! 8663: # HISTORY STACK IS SCANNED FOR MATCHING NDPAB-NDPAD PAIRS ! 8664: # AND THE CORRESPONDING PATTERN ASSIGNMENTS ARE EXECUTED. ! 8665: # ! 8666: # THE FUNCTION OF THE MATCH ROUTINE FOR NDPAD (P$PAD) ! 8667: # IS SIMPLY TO REMOVE ITS ENTRY FROM THE STACK AND FAIL. ! 8668: # THIS INCLUDES REMOVING THE SPECIAL NODE POINTER STORED ! 8669: # IN ADDITION TO THE STANDARD TWO ENTRIES ON THE STACK. ! 8670: #page ! 8671: # ! 8672: # COMPOUNT PATTERN STRUCTURES (CONTINUED) ! 8673: # ! 8674: # FENCE (FUNCTION) ! 8675: # ---------------- ! 8676: # ! 8677: # +---+ THIS NODE (P$FNA) SAVES THE ! 8678: # I A I CURRENT HISTORY STACK AND A ! 8679: # +---+ POINTER TO NDFNB ON THE STACK. ! 8680: # I ! 8681: # I ! 8682: # +---+ THIS IS THE PATTERN STRUCTURE ! 8683: # I X I GIVEN AS THE ARGUMENT TO THE ! 8684: # +---+ FENCE FUNCTION. ! 8685: # I ! 8686: # I ! 8687: # +---+ THIS NODE P$FNC RESTORES THE OUTER ! 8688: # I C I HISTORY STACK PTR SAVED IN P$FNA, ! 8689: # +---+ AND STACKS THE INNER STACK BASE ! 8690: # PTR AND A POINTER TO NDFND ON THE ! 8691: # STACK. ! 8692: # ! 8693: # NDFNB (F$FNB) SIMPLY IS THE FAILURE EXIT FOR PATTERN ! 8694: # ARGUMENT FAILURE, AND IT POPS ITSELF AND FAILS ONTO THE ! 8695: # STACK. ! 8696: # ! 8697: # THE MATCH ROUTINE P$FNC ALLOWS FOR AN OPTIMIZATION WHEN ! 8698: # THE FENCE PATTERN LEAVES NO ALTERNATIVES. IN THIS CASE, ! 8699: # THE NDFNB ENTRY IS POPPED, AND THE MATCH CONTINUES. ! 8700: # ! 8701: # NDFND (P$FND) IS ENTERED WHEN THE PATTERN FAILS AFTER ! 8702: # GOING THROUGH A NON-OPTIMIZED P$FNC, AND IT POPS THE ! 8703: # STACK BACK PAST THE INNTER STACK BASE CREATED BY P$FNA ! 8704: #page ! 8705: # ! 8706: # COMPOUND PATTERNS (CONTINUED) ! 8707: # ! 8708: # EXPRESSION PATTERNS (RECURSIVE PATTERN MATCHES) ! 8709: # ----------------------------------------------- ! 8710: # ! 8711: # INITIAL ENTRY FOR A PATTERN NODE IS TO THE ROUTINE P$EXA. ! 8712: # IF THE EVALUATED RESULT OF THE EXPRESSION IS ITSELF A ! 8713: # PATTERN, THEN THE FOLLOWING STEPS ARE TAKEN TO ARRANGE ! 8714: # FOR PROPER RECURSIVE PROCESSING. ! 8715: # ! 8716: # 1) A POINTER TO THE CURRENT NODE (THE P$EXA NODE) IS ! 8717: # STORED ON THE HISTORY STACK WITH A DUMMY CURSOR. ! 8718: # ! 8719: # 2) A SPECIAL HISTORY STACK ENTRY IS MADE IN WHICH THE ! 8720: # NODE POINTER POINTS TO NDEXB, AND THE CURSOR VALUE ! 8721: # IS THE SAVED VALUE OF PMHBS ON ENTRY TO THIS NODE. ! 8722: # THE MATCH ROUTINE FOR NDEXB (P$EXB) RESTORES PMHBS ! 8723: # FROM THIS CURSOR ENTRY, POPS OFF THE P$EXA NODE ! 8724: # POINTER AND FAILS. ! 8725: # ! 8726: # 3) THE RESULTING HISTORY STACK POINTER IS SAVED IN ! 8727: # PMHBS TO ESTABLISH A NEW LEVEL OF HISTORY STACK. ! 8728: # ! 8729: # AFTER MATCHING A PATTERN, THE END OF MATCH ROUTINE GETS ! 8730: # CONTROL (P$NTH). THIS ROUTINE PROCEEDS AS FOLLOWS. ! 8731: # ! 8732: # 1) LOAD THE CURRENT VALUE OF PMHBS AND RECOGNIZE THE ! 8733: # OUTER LEVEL CASE BY THE FACT THAT THE ASSOCIATED ! 8734: # CURSOR IN THIS CASE IS THE PATTERN MATCH TYPE CODE ! 8735: # WHICH IS LESS THAN 3. TERMINATE THE MATCH IN THIS ! 8736: # CASE AND CONTINUE EXECUTION OF THE PROGRAM. ! 8737: # ! 8738: # 2) OTHERWISE MAKE A SPECIAL HISTORY STACK ENTRY IN ! 8739: # WHICH THE NODE POINTER POINTS TO THE SPECIAL NODE ! 8740: # NDEXC AND THE CURSOR IS THE CURRENT VALUE OF PMHBS. ! 8741: # THE MATCH ROUTINE FOR NDEXC (P$EXC) RESETS PMHBS TO ! 8742: # THIS (INNER) VALUE AND AND THEN FAILS. ! 8743: # ! 8744: # 3) USING THE HISTORY STACK ENTRY MADE ON STARTING THE ! 8745: # EXPRESSION (ACCESSIBLE WITH THE CURRENT VALUE OF ! 8746: # PMHBS), RESTORE THE P$EXA NODE POINTER AND THE OLD ! 8747: # PMHBS SETTING. TAKE THE SUCCESSOR AND CONTINUE. ! 8748: # ! 8749: # AN OPTIMIZATION IS POSSIBLE IF THE EXPRESSION PATTERN ! 8750: # MAKES NO ENTRIES ON THE HISTORY STACK. IN THIS CASE, ! 8751: # INSTEAD OF BUILDING THE P$EXC NODE IN STEP 2, IT IS MORE ! 8752: # EFFICIENT TO SIMPLY POP OFF THE P$EXB ENTRY AND ITS ! 8753: # ASSOCIATED NODE POINTER. THE EFFECT IS THE SAME. ! 8754: #page ! 8755: # ! 8756: # COMPOUND PATTERNS (CONTINUED) ! 8757: # ! 8758: # BINARY DOLLAR (IMMEDIATE ASSIGNMENT) ! 8759: # ------------------------------------ ! 8760: # ! 8761: # +---+ THIS NODE (P$IMA) STACKS THE CURSOR ! 8762: # I A I PMHBS AND A PTR TO NDIMB AND RESETS ! 8763: # +---+ THE STACK PTR PMHBS. ! 8764: # I ! 8765: # I ! 8766: # +---+ THIS IS THE LEFT STRUCTURE FOR THE ! 8767: # I X I PATTERN LEFT ARGUMENT OF THE ! 8768: # +---+ IMMEDIATE ASSIGNMENT CALL. ! 8769: # I ! 8770: # I ! 8771: # +---+ THIS NODE (P$IMC) PERFORMS THE ! 8772: # I C I----- ASSIGNMENT, POPS PMHBS AND STACKS ! 8773: # +---+ THE OLD PMHBS AND A PTR TO NDIMD. ! 8774: # ! 8775: # ! 8776: # THE STRUCTURE AND EXECUTION OF THIS PATTERN ARE SIMILAR ! 8777: # TO THOSE OF THE RECURSIVE EXPRESSION PATTERN MATCHING. ! 8778: # ! 8779: # THE MATCH ROUTINE FOR NDIMB (P$IMB) RESTORES THE OUTER ! 8780: # LEVEL VALUE OF PMHBS, UNSTACKS THE SAVED CURSOR AND FAILS ! 8781: # ! 8782: # THE MATCH ROUTINE P$IMC USES THE CURRENT VALUE OF PMHBS ! 8783: # TO LOCATE THE P$IMB ENTRY. THIS ENTRY IS USED TO MAKE ! 8784: # THE ASSIGNMENT AND RESTORE THE OUTER LEVEL VALUE OF ! 8785: # PMHBS. FINALLY, THE INNER LEVEL VALUE OF PMHBS AND A ! 8786: # POINTER TO THE SPECIAL NODE NDIMD ARE STACKED. ! 8787: # ! 8788: # THE MATCH ROUTINE FOR NDIMD (P$IMD) RESTORES THE INNER ! 8789: # LEVEL VALUE OF PMHBS AND FAILS BACK INTO THE STACK. ! 8790: # ! 8791: # AN OPTIMIZATION OCCURS IF THE INNER PATTERN MAKES NO ! 8792: # ENTRIES ON THE HISTORY STACK. IN THIS CASE, P$IMC POPS ! 8793: # THE P$IMB ENTRY INSTEAD OF MAKING A P$IMD ENTRY. ! 8794: #page ! 8795: # ! 8796: # ARBNO ! 8797: # ! 8798: # SEE COMPOUND PATTERNS SECTION FOR STUCTURE AND ! 8799: # ALGORITHM FOR MATCHING THIS NODE TYPE. ! 8800: # ! 8801: # NO PARAMETERS ! 8802: # ! 8803: .align 2 ! 8804: .word bl$p0 ! 8805: p$aba: # p0blk ! 8806: movl r7,-(sp) # stack cursor ! 8807: movl r9,-(sp) # stack dummy node ptr ! 8808: movl pmhbs,-(sp) # stack old stack base ptr ! 8809: movl $ndabb,-(sp) # stack ptr to node ndabb ! 8810: movl sp,pmhbs # store new stack base ptr ! 8811: jmp succp # succeed ! 8812: #page ! 8813: # ! 8814: # ARBNO (REMOVE P$ABA SPECIAL STACK ENTRY) ! 8815: # ! 8816: # NO PARAMETERS (DUMMY PATTERN) ! 8817: # ! 8818: p$abb: # entry point ! 8819: movl r7,pmhbs # restore history stack base ptr ! 8820: jmp flpop # fail and pop dummy node ptr ! 8821: #page ! 8822: # ! 8823: # ARBNO (CHECK IF ARG MATCHED NULL STRING) ! 8824: # ! 8825: # NO PARAMETERS (DUMMY PATTERN) ! 8826: # ! 8827: .align 2 ! 8828: .word bl$p0 ! 8829: p$abc: # p0blk ! 8830: movl pmhbs,r10 # keep p$abb stack base ! 8831: movl 4*3(r10),r6 # load initial cursor ! 8832: movl 4*1(r10),pmhbs # restore outer stack base ptr ! 8833: cmpl r10,sp # jump if no history stack entries ! 8834: beqlu pabc1 ! 8835: movl r10,-(sp) # else save inner pmhbs entry ! 8836: movl $ndabd,-(sp) # stack ptr to special node ndabd ! 8837: jmp pabc2 # merge ! 8838: # ! 8839: # OPTIMISE CASE OF NO EXTRA ENTRIES ON STACK FROM ARBNO ARG ! 8840: # ! 8841: pabc1: addl2 $4*num04,sp # remove ndabb entry and cursor ! 8842: # ! 8843: # MERGE TO CHECK FOR MATCHING OF NULL STRING ! 8844: # ! 8845: pabc2: cmpl r6,r7 # allow further attempt if non-null ! 8846: beqlu 0f ! 8847: jmp succp ! 8848: 0: ! 8849: movl 4*pthen(r9),r9 # bypass alternative node so as to .. ! 8850: jmp succp # ... refuse further match attempts ! 8851: #page ! 8852: # ! 8853: # ARBNO (TRY FOR ALTERNATIVES IN ARBNO ARGUMENT) ! 8854: # ! 8855: # NO PARAMETERS (DUMMY PATTERN) ! 8856: # ! 8857: p$abd: # entry point ! 8858: movl r7,pmhbs # restore inner stack base ptr ! 8859: jmp failp # and fail ! 8860: #page ! 8861: # ! 8862: # ABORT ! 8863: # ! 8864: # NO PARAMETERS ! 8865: # ! 8866: .align 2 ! 8867: .word bl$p0 ! 8868: p$abo: # p0blk ! 8869: jmp exfal # signal statement failure ! 8870: #page ! 8871: # ! 8872: # ALTERNATION ! 8873: # ! 8874: # PARM1 ALTERNATIVE NODE ! 8875: # ! 8876: .align 2 ! 8877: .word bl$p1 ! 8878: p$alt: # p1blk ! 8879: movl r7,-(sp) # stack cursor ! 8880: movl 4*parm1(r9),-(sp)# stack pointer to alternative ! 8881: jsb sbchk # check for stack overflow ! 8882: jmp succp # if all ok, then succeed ! 8883: #page ! 8884: # ! 8885: # ANY (ONE CHARACTER ARGUMENT) (1-CHAR STRING ALSO) ! 8886: # ! 8887: # PARM1 CHARACTER ARGUMENT ! 8888: # ! 8889: .align 2 ! 8890: .word bl$p1 ! 8891: p$ans: # p1blk ! 8892: cmpl r7,pmssl # fail if no chars left ! 8893: bnequ 0f ! 8894: jmp failp ! 8895: 0: ! 8896: movl r$pms,r10 # else point to subject string ! 8897: movab cfp$f(r10)[r7],r10 # point to current character ! 8898: movzbl (r10),r6 # load current character ! 8899: cmpl r6,4*parm1(r9) # fail if no match ! 8900: beqlu 0f ! 8901: jmp failp ! 8902: 0: ! 8903: incl r7 # else bump cursor ! 8904: jmp succp # and succeed ! 8905: #page ! 8906: # ! 8907: # ANY (MULTI-CHARACTER ARGUMENT CASE) ! 8908: # ! 8909: # PARM1 POINTER TO CTBLK ! 8910: # PARM2 BIT MASK TO SELECT BIT IN CTBLK ! 8911: # ! 8912: .align 2 ! 8913: .word bl$p2 ! 8914: p$any: # p2blk ! 8915: # ! 8916: # EXPRESSION ARGUMENT CASE MERGES HERE ! 8917: # ! 8918: pany1: cmpl r7,pmssl # fail if no characters left ! 8919: bnequ 0f ! 8920: jmp failp ! 8921: 0: ! 8922: movl r$pms,r10 # else point to subject string ! 8923: movab cfp$f(r10)[r7],r10 # get char ptr to current character ! 8924: movzbl (r10),r6 # load current character ! 8925: movl 4*parm1(r9),r10 # point to ctblk ! 8926: moval 0[r6],r6 # change to byte offset ! 8927: addl2 r6,r10 # point to entry in ctblk ! 8928: movl 4*ctchs(r10),r6 # load word from ctblk ! 8929: mcoml 4*parm2(r9),r11 # and with selected bit ! 8930: bicl2 r11,r6 ! 8931: bnequ 0f # fail if no match ! 8932: jmp failp ! 8933: 0: ! 8934: incl r7 # else bump cursor ! 8935: jmp succp # and succeed ! 8936: #page ! 8937: # ! 8938: # ANY (EXPRESSION ARGUMENT) ! 8939: # ! 8940: # PARM1 EXPRESSION POINTER ! 8941: # ! 8942: .align 2 ! 8943: .word bl$p1 ! 8944: p$ayd: # p1blk ! 8945: jsb evals # evaluate string argument ! 8946: .long er_043 # any evaluated argument is not string ! 8947: .long failp # fail if evaluation failure ! 8948: .long pany1 # merge multi-char case if ok ! 8949: #page ! 8950: # ! 8951: # P$ARB INITIAL ARB MATCH ! 8952: # ! 8953: # NO PARAMETERS ! 8954: # ! 8955: # THE P$ARB NODE IS PART OF A COMPOUND PATTERN STRUCTURE ! 8956: # FOR AN ARB PATTERN (SEE DESCRIPTION OF COMPOUND PATTERNS) ! 8957: # ! 8958: .align 2 ! 8959: .word bl$p0 ! 8960: p$arb: # p0blk ! 8961: movl 4*pthen(r9),r9 # load successor pointer ! 8962: movl r7,-(sp) # stack dummy cursor ! 8963: movl r9,-(sp) # stack successor pointer ! 8964: movl r7,-(sp) # stack cursor ! 8965: movl $ndarc,-(sp) # stack ptr to special node ndarc ! 8966: movl (r9),r11 # execute next node matching null ! 8967: jmp (r11) ! 8968: #page ! 8969: # ! 8970: # P$ARC EXTEND ARB MATCH ! 8971: # ! 8972: # NO PARAMETERS (DUMMY PATTERN) ! 8973: # ! 8974: p$arc: # entry point ! 8975: cmpl r7,pmssl # fail and pop stack to successor ! 8976: bnequ 0f ! 8977: jmp flpop ! 8978: 0: ! 8979: incl r7 # else bump cursor ! 8980: movl r7,-(sp) # stack updated cursor ! 8981: movl r9,-(sp) # restack pointer to ndarc node ! 8982: movl 4*2(sp),r9 # load successor pointer ! 8983: movl (r9),r11 # off to reexecute successor node ! 8984: jmp (r11) ! 8985: #page ! 8986: # ! 8987: # BAL ! 8988: # ! 8989: # NO PARAMETERS ! 8990: # ! 8991: # THE P$BAL NODE IS PART OF THE COMPOUND STRUCTURE BUILT ! 8992: # FOR BAL (SEE SECTION ON COMPOUND PATTERNS). ! 8993: # ! 8994: .align 2 ! 8995: .word bl$p0 ! 8996: p$bal: # p0blk ! 8997: clrl r8 # zero parentheses level counter ! 8998: movl r$pms,r10 # point to subject string ! 8999: movab cfp$f(r10)[r7],r10 # point to current character ! 9000: jmp pbal2 # jump into scan loop ! 9001: # ! 9002: # LOOP TO SCAN OUT CHARACTERS ! 9003: # ! 9004: pbal1: movzbl (r10)+,r6 # load next character, bump pointer ! 9005: incl r7 # push cursor for character ! 9006: cmpl r6,$ch$pp # jump if left paren ! 9007: beqlu pbal3 ! 9008: cmpl r6,$ch$rp # jump if right paren ! 9009: beqlu pbal4 ! 9010: tstl r8 # else succeed if at outer level ! 9011: beqlu pbal5 ! 9012: # ! 9013: # HERE AFTER PROCESSING ONE CHARACTER ! 9014: # ! 9015: pbal2: cmpl r7,pmssl # loop back unless end of string ! 9016: bnequ pbal1 ! 9017: jmp failp # in which case, fail ! 9018: # ! 9019: # HERE ON LEFT PAREN ! 9020: # ! 9021: pbal3: incl r8 # bump paren level ! 9022: jmp pbal2 # loop back to check end of string ! 9023: # ! 9024: # HERE FOR RIGHT PAREN ! 9025: # ! 9026: pbal4: tstl r8 # fail if no matching left paren ! 9027: bnequ 0f ! 9028: jmp failp ! 9029: 0: ! 9030: decl r8 # else decrement level counter ! 9031: bnequ pbal2 # loop back if not at outer level ! 9032: # ! 9033: # HERE AFTER SUCCESSFULLY SCANNING A BALANCED STRING ! 9034: # ! 9035: pbal5: movl r7,-(sp) # stack cursor ! 9036: movl r9,-(sp) # stack ptr to bal node for extend ! 9037: jmp succp # and succeed ! 9038: #page ! 9039: # ! 9040: # BREAK (EXPRESSION ARGUMENT) ! 9041: # ! 9042: # PARM1 EXPRESSION POINTER ! 9043: # ! 9044: .align 2 ! 9045: .word bl$p1 ! 9046: p$bkd: # p1blk ! 9047: jsb evals # evaluate string expression ! 9048: .long er_044 # break evaluated argument is not string ! 9049: .long failp # fail if evaluation fails ! 9050: .long pbrk1 # merge with multi-char case if ok ! 9051: #page ! 9052: # ! 9053: # BREAK (ONE CHARACTER ARGUMENT) ! 9054: # ! 9055: # PARM1 CHARACTER ARGUMENT ! 9056: # ! 9057: .align 2 ! 9058: .word bl$p1 ! 9059: p$bks: # p1blk ! 9060: movl pmssl,r8 # get subject string length ! 9061: subl2 r7,r8 # get number of characters left ! 9062: bnequ 0f # fail if no characters left ! 9063: jmp failp ! 9064: 0: ! 9065: # set counter for chars left ! 9066: movl r$pms,r10 # point to subject string ! 9067: movab cfp$f(r10)[r7],r10 # point to current character ! 9068: # ! 9069: # LOOP TO SCAN TILL BREAK CHARACTER FOUND ! 9070: # ! 9071: pbks1: movzbl (r10)+,r6 # load next char, bump pointer ! 9072: cmpl r6,4*parm1(r9) # succeed if break character found ! 9073: bnequ 0f ! 9074: jmp succp ! 9075: 0: ! 9076: incl r7 # else push cursor ! 9077: sobgtr r8,pbks1 # loop back if more to go ! 9078: jmp failp # fail if end of string, no break chr ! 9079: #page ! 9080: # ! 9081: # BREAK (MULTI-CHARACTER ARGUMENT) ! 9082: # ! 9083: # PARM1 POINTER TO CTBLK ! 9084: # PARM2 BIT MASK TO SELECT BIT COLUMN ! 9085: # ! 9086: .align 2 ! 9087: .word bl$p2 ! 9088: p$brk: # p2blk ! 9089: # ! 9090: # EXPRESSION ARGUMENT MERGES HERE ! 9091: # ! 9092: pbrk1: movl pmssl,r8 # load subject string length ! 9093: subl2 r7,r8 # get number of characters left ! 9094: bnequ 0f # fail if no characters left ! 9095: jmp failp ! 9096: 0: ! 9097: # set counter for characters left ! 9098: movl r$pms,r10 # else point to subject string ! 9099: movab cfp$f(r10)[r7],r10 # point to current character ! 9100: movl r9,psave # save node pointer ! 9101: # ! 9102: # LOOP TO SEARCH FOR BREAK CHARACTER ! 9103: # ! 9104: pbrk2: movzbl (r10)+,r6 # load next char, bump pointer ! 9105: movl 4*parm1(r9),r9 # load pointer to ctblk ! 9106: moval 0[r6],r6 # convert to byte offset ! 9107: addl2 r6,r9 # point to ctblk entry ! 9108: movl 4*ctchs(r9),r6 # load ctblk word ! 9109: movl psave,r9 # restore node pointer ! 9110: mcoml 4*parm2(r9),r11 # and with selected bit ! 9111: bicl2 r11,r6 ! 9112: beqlu 0f # succeed if break character found ! 9113: jmp succp ! 9114: 0: ! 9115: incl r7 # else push cursor ! 9116: sobgtr r8,pbrk2 # loop back unless end of string ! 9117: jmp failp # fail if end of string, no break chr ! 9118: #page ! 9119: # ! 9120: # BREAKX (EXTENSION) ! 9121: # ! 9122: # THIS IS THE ENTRY WHICH CAUSES AN EXTENSION OF A BREAKX ! 9123: # MATCH WHEN FAILURE OCCURS. SEE SECTION ON COMPOUND ! 9124: # PATTERNS FOR FULL DETAILS OF BREAKX MATCHING. ! 9125: # ! 9126: # NO PARAMETERS ! 9127: # ! 9128: .align 2 ! 9129: .word bl$p0 ! 9130: p$bkx: # p0blk ! 9131: incl r7 # step cursor past previous break chr ! 9132: jmp succp # succeed to rematch break ! 9133: #page ! 9134: # ! 9135: # BREAKX (EXPRESSION ARGUMENT) ! 9136: # ! 9137: # SEE SECTION ON COMPOUND PATTERNS FOR FULL STRUCTURE OF ! 9138: # BREAKX PATTERN. THE ACTUAL CHARACTER MATCHING USES A ! 9139: # BREAK NODE. HOWEVER, THE ENTRY FOR THE EXPRESSION ! 9140: # ARGUMENT CASE IS SEPARATED TO GET PROPER ERROR MESSAGES. ! 9141: # ! 9142: # PARM1 EXPRESSION POINTER ! 9143: # ! 9144: .align 2 ! 9145: .word bl$p1 ! 9146: p$bxd: # p1blk ! 9147: jsb evals # evaluate string argument ! 9148: .long er_045 # breakx evaluated argument is not string ! 9149: .long failp # fail if evaluation fails ! 9150: .long pbrk1 # merge with break if all ok ! 9151: #page ! 9152: # ! 9153: # CURSOR ASSIGNMENT ! 9154: # ! 9155: # PARM1 NAME BASE ! 9156: # PARM2 NAME OFFSET ! 9157: # ! 9158: .align 2 ! 9159: .word bl$p2 ! 9160: p$cas: # p2blk ! 9161: movl r9,-(sp) # save node pointer ! 9162: movl r7,-(sp) # save cursor ! 9163: movl 4*parm1(r9),r10 # load name base ! 9164: movl r7,r5 # load cursor as integer ! 9165: movl 4*parm2(r9),r7 # load name offset ! 9166: jsb icbld # get icblk for cursor value ! 9167: movl r7,r6 # move name offset ! 9168: movl r9,r7 # move value to assign ! 9169: jsb asinp # perform assignment ! 9170: .long flpop # fail on assignment failure ! 9171: movl (sp)+,r7 # else restore cursor ! 9172: movl (sp)+,r9 # restore node pointer ! 9173: jmp succp # and succeed matching null ! 9174: #page ! 9175: # ! 9176: # EXPRESSION NODE (P$EXA, INITIAL ENTRY) ! 9177: # ! 9178: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9179: # ALGORITHMS FOR HANDLING EXPRESSION NODES. ! 9180: # ! 9181: # PARM1 EXPRESSION POINTER ! 9182: # ! 9183: .align 2 ! 9184: .word bl$p1 ! 9185: p$exa: # p1blk ! 9186: jsb evalp # evaluate expression ! 9187: .long failp # fail if evaluation fails ! 9188: cmpl r6,$p$aaa # jump if result is not a pattern ! 9189: blequ pexa1 ! 9190: # ! 9191: # HERE IF RESULT OF EXPRESSION IS A PATTERN ! 9192: # ! 9193: movl r7,-(sp) # stack dummy cursor ! 9194: movl r9,-(sp) # stack ptr to p$exa node ! 9195: movl pmhbs,-(sp) # stack history stack base ptr ! 9196: movl $ndexb,-(sp) # stack ptr to special node ndexb ! 9197: movl sp,pmhbs # store new stack base pointer ! 9198: movl r10,r9 # copy node pointer ! 9199: movl (r9),r11 # match first node in expression pat ! 9200: jmp (r11) ! 9201: # ! 9202: # HERE IF RESULT OF EXPRESSION IS NOT A PATTERN ! 9203: # ! 9204: pexa1: cmpl r6,$b$scl # jump if it is already a string ! 9205: beqlu pexa2 ! 9206: movl r10,-(sp) # else stack result ! 9207: movl r9,r10 # save node pointer ! 9208: jsb gtstg # convert result to string ! 9209: .long er_046 # expression does not evaluate to pattern ! 9210: movl r9,r8 # copy string pointer ! 9211: movl r10,r9 # restore node pointer ! 9212: movl r8,r10 # copy string pointer again ! 9213: # ! 9214: # MERGE HERE WITH STRING POINTER IN XL ! 9215: # ! 9216: pexa2: tstl 4*sclen(r10) # just succeed if null string ! 9217: bnequ 0f ! 9218: jmp succp ! 9219: 0: ! 9220: jmp pstr1 # else merge with string circuit ! 9221: #page ! 9222: # ! 9223: # EXPRESSION NODE (P$EXB, REMOVE NDEXB ENTRY) ! 9224: # ! 9225: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9226: # ALGORITHMS FOR HANDLING EXPRESSION NODES. ! 9227: # ! 9228: # NO PARAMETERS (DUMMY PATTERN) ! 9229: # ! 9230: p$exb: # entry point ! 9231: movl r7,pmhbs # restore outer level stack pointer ! 9232: jmp flpop # fail and pop p$exa node ptr ! 9233: #page ! 9234: # ! 9235: # EXPRESSION NODE (P$EXC, REMOVE NDEXC ENTRY) ! 9236: # ! 9237: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9238: # ALGORITHMS FOR HANDLING EXPRESSION NODES. ! 9239: # ! 9240: # NO PARAMETERS (DUMMY PATTERN) ! 9241: # ! 9242: p$exc: # entry point ! 9243: movl r7,pmhbs # restore inner stack base pointer ! 9244: jmp failp # and fail into expr pattern alternvs ! 9245: #page ! 9246: # ! 9247: # FAIL ! 9248: # ! 9249: # NO PARAMETERS ! 9250: # ! 9251: .align 2 ! 9252: .word bl$p0 ! 9253: p$fal: # p0blk ! 9254: jmp failp # just signal failure ! 9255: #page ! 9256: # ! 9257: # FENCE ! 9258: # ! 9259: # SEE COMPOUND PATTERNS SECTION FOR THE STRUCTURE AND ! 9260: # ALGORITHM FOR MATCHING THIS NODE TYPE. ! 9261: # ! 9262: # NO PARAMETERS ! 9263: # ! 9264: .align 2 ! 9265: .word bl$p0 ! 9266: p$fen: # p0blk ! 9267: movl r7,-(sp) # stack dummy cursor ! 9268: movl $ndabo,-(sp) # stack ptr to abort node ! 9269: jmp succp # and succeed matching null ! 9270: #page ! 9271: # ! 9272: # FENCE (FUNCTION) ! 9273: # ! 9274: # SEE COMPOUND PATTERNS COMMENTS AT START OF THIS SECTION ! 9275: # FOR DETAILS OF SCHEME ! 9276: # ! 9277: # NO PARAMETERS ! 9278: # ! 9279: .align 2 ! 9280: .word bl$p0 ! 9281: p$fna: # p0blk ! 9282: movl pmhbs,-(sp) # stack current history stack base ! 9283: movl $ndfnb,-(sp) # stack indir ptr to p$fnb (failure) ! 9284: movl sp,pmhbs # begin new history stack ! 9285: jmp succp # succeed ! 9286: #page ! 9287: # ! 9288: # FENCE (FUNCTION) (RESET HISTORY STACK AND FAIL) ! 9289: # ! 9290: # NO PARAMETERS (DUMMY PATTERN) ! 9291: # ! 9292: .align 2 ! 9293: .word bl$p0 ! 9294: p$fnb: # p0blk ! 9295: movl r7,pmhbs # restore outer pmhbs stack base ! 9296: jmp failp # ...and fail ! 9297: #page ! 9298: # ! 9299: # FENCE (FUNCTION) (MAKE FENCE TRAP ENTRY ON STACK) ! 9300: # ! 9301: # NO PARAMETERS (DUMMY PATTERN) ! 9302: # ! 9303: .align 2 ! 9304: .word bl$p0 ! 9305: p$fnc: # p0blk ! 9306: movl pmhbs,r10 # get inner stack base ptr ! 9307: movl 4*num01(r10),pmhbs # restore outer stack base ! 9308: cmpl r10,sp # optimize if no alternatives ! 9309: beqlu pfnc1 ! 9310: movl r10,-(sp) # else stack inner stack base ! 9311: movl $ndfnd,-(sp) # stack ptr to ndfnd ! 9312: jmp succp # succeed ! 9313: # ! 9314: # HERE WHEN FENCE FUNCTION LEFT NOTHING ON THE STACK ! 9315: # ! 9316: pfnc1: addl2 $4*num02,sp # pop off p$fnb entry ! 9317: jmp succp # succeed ! 9318: #page ! 9319: # ! 9320: # FENCE (FUNCTION) (SKIP PAST ALTERNATIVES ON FAILURE) ! 9321: # ! 9322: # NO PARAMETERS (DUMMY PATTERN) ! 9323: # ! 9324: .align 2 ! 9325: .word bl$p0 ! 9326: p$fnd: # p0blk ! 9327: movl r7,sp # pop stack to fence() history base ! 9328: jmp flpop # pop base entry and fail ! 9329: #page ! 9330: # ! 9331: # IMMEDIATE ASSIGNMENT (INITIAL ENTRY, SAVE CURRENT CURSOR) ! 9332: # ! 9333: # SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE ! 9334: # STRUCTURE AND ALGORITHM FOR MATCHING THIS NODE TYPE. ! 9335: # ! 9336: # NO PARAMETERS ! 9337: # ! 9338: .align 2 ! 9339: .word bl$p0 ! 9340: p$ima: # p0blk ! 9341: movl r7,-(sp) # stack cursor ! 9342: movl r9,-(sp) # stack dummy node pointer ! 9343: movl pmhbs,-(sp) # stack old stack base pointer ! 9344: movl $ndimb,-(sp) # stack ptr to special node ndimb ! 9345: movl sp,pmhbs # store new stack base pointer ! 9346: jmp succp # and succeed ! 9347: #page ! 9348: # ! 9349: # IMMEDIATE ASSIGNMENT (REMOVE CURSOR MARK ENTRY) ! 9350: # ! 9351: # SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE ! 9352: # STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9353: # ! 9354: # NO PARAMETERS (DUMMY PATTERN) ! 9355: # ! 9356: p$imb: # entry point ! 9357: movl r7,pmhbs # restore history stack base ptr ! 9358: jmp flpop # fail and pop dummy node ptr ! 9359: #page ! 9360: # ! 9361: # IMMEDIATE ASSIGNMENT (PERFORM ACTUAL ASSIGNMENT) ! 9362: # ! 9363: # SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE ! 9364: # STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9365: # ! 9366: # PARM1 NAME BASE OF VARIABLE ! 9367: # PARM2 NAME OFFSET OF VARIABLE ! 9368: # ! 9369: .align 2 ! 9370: .word bl$p2 ! 9371: p$imc: # p2blk ! 9372: movl pmhbs,r10 # load pointer to p$imb entry ! 9373: movl r7,r6 # copy final cursor ! 9374: movl 4*3(r10),r7 # load initial cursor ! 9375: movl 4*1(r10),pmhbs # restore outer stack base pointer ! 9376: cmpl r10,sp # jump if no history stack entries ! 9377: beqlu pimc1 ! 9378: movl r10,-(sp) # else save inner pmhbs pointer ! 9379: movl $ndimd,-(sp) # and a ptr to special node ndimd ! 9380: jmp pimc2 # merge ! 9381: # ! 9382: # HERE IF NO ENTRIES MADE ON HISTORY STACK ! 9383: # ! 9384: pimc1: addl2 $4*num04,sp # remove ndimb entry and cursor ! 9385: # ! 9386: # MERGE HERE TO PERFORM ASSIGNMENT ! 9387: # ! 9388: pimc2: movl r6,-(sp) # save current (final) cursor ! 9389: movl r9,-(sp) # save current node pointer ! 9390: movl r$pms,r10 # point to subject string ! 9391: subl2 r7,r6 # compute substring length ! 9392: jsb sbstr # build substring ! 9393: movl r9,r7 # move result ! 9394: movl (sp),r9 # reload node pointer ! 9395: movl 4*parm1(r9),r10 # load name base ! 9396: movl 4*parm2(r9),r6 # load name offset ! 9397: jsb asinp # perform assignment ! 9398: .long flpop # fail if assignment fails ! 9399: movl (sp)+,r9 # else restore node pointer ! 9400: movl (sp)+,r7 # restore cursor ! 9401: jmp succp # and succeed ! 9402: #page ! 9403: # ! 9404: # IMMEDIATE ASSIGNMENT (REMOVE NDIMD ENTRY ON FAILURE) ! 9405: # ! 9406: # SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE ! 9407: # STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9408: # ! 9409: # NO PARAMETERS (DUMMY PATTERN) ! 9410: # ! 9411: p$imd: # entry point ! 9412: movl r7,pmhbs # restore inner stack base pointer ! 9413: jmp failp # and fail ! 9414: #page ! 9415: # ! 9416: # LEN (INTEGER ARGUMENT) ! 9417: # ! 9418: # PARM1 INTEGER ARGUMENT ! 9419: # ! 9420: .align 2 ! 9421: .word bl$p1 ! 9422: p$len: # p1blk ! 9423: # ! 9424: # EXPRESSION ARGUMENT CASE MERGES HERE ! 9425: # ! 9426: plen1: addl2 4*parm1(r9),r7 # push cursor indicated amount ! 9427: cmpl r7,pmssl # succeed if not off end ! 9428: bgtru 0f ! 9429: jmp succp ! 9430: 0: ! 9431: jmp failp # else fail ! 9432: #page ! 9433: # ! 9434: # LEN (EXPRESSION ARGUMENT) ! 9435: # ! 9436: # PARM1 EXPRESSION POINTER ! 9437: # ! 9438: .align 2 ! 9439: .word bl$p1 ! 9440: p$lnd: # p1blk ! 9441: jsb evali # evaluate integer argument ! 9442: .long er_047 # len evaluated argument is not integer ! 9443: .long er_048 # len evaluated argument is negative or too large ! 9444: .long failp # fail if evaluation fails ! 9445: .long plen1 # merge with normal circuit if ok ! 9446: #page ! 9447: # ! 9448: # NOTANY (EXPRESSION ARGUMENT) ! 9449: # ! 9450: # PARM1 EXPRESSION POINTER ! 9451: # ! 9452: .align 2 ! 9453: .word bl$p1 ! 9454: p$nad: # p1blk ! 9455: jsb evals # evaluate string argument ! 9456: .long er_049 # notany evaluated argument is not string ! 9457: .long failp # fail if evaluation fails ! 9458: .long pnay1 # merge with multi-char case if ok ! 9459: #page ! 9460: # ! 9461: # NOTANY (ONE CHARACTER ARGUMENT) ! 9462: # ! 9463: # PARM1 CHARACTER ARGUMENT ! 9464: # ! 9465: .align 2 ! 9466: .word bl$p1 ! 9467: p$nas: # entry point ! 9468: cmpl r7,pmssl # fail if no chars left ! 9469: bnequ 0f ! 9470: jmp failp ! 9471: 0: ! 9472: movl r$pms,r10 # else point to subject string ! 9473: movab cfp$f(r10)[r7],r10 # point to current character in strin ! 9474: movzbl (r10),r6 # load current character ! 9475: cmpl r6,4*parm1(r9) # fail if match ! 9476: bnequ 0f ! 9477: jmp failp ! 9478: 0: ! 9479: incl r7 # else bump cursor ! 9480: jmp succp # and succeed ! 9481: #page ! 9482: # ! 9483: # NOTANY (MULTI-CHARACTER STRING ARGUMENT) ! 9484: # ! 9485: # PARM1 POINTER TO CTBLK ! 9486: # PARM2 BIT MASK TO SELECT BIT COLUMN ! 9487: # ! 9488: .align 2 ! 9489: .word bl$p2 ! 9490: p$nay: # p2blk ! 9491: # ! 9492: # EXPRESSION ARGUMENT CASE MERGES HERE ! 9493: # ! 9494: pnay1: cmpl r7,pmssl # fail if no characters left ! 9495: bnequ 0f ! 9496: jmp failp ! 9497: 0: ! 9498: movl r$pms,r10 # else point to subject string ! 9499: movab cfp$f(r10)[r7],r10 # point to current character ! 9500: movzbl (r10),r6 # load current character ! 9501: moval 0[r6],r6 # convert to byte offset ! 9502: movl 4*parm1(r9),r10 # load pointer to ctblk ! 9503: addl2 r6,r10 # point to entry in ctblk ! 9504: movl 4*ctchs(r10),r6 # load entry from ctblk ! 9505: mcoml 4*parm2(r9),r11 # and with selected bit ! 9506: bicl2 r11,r6 ! 9507: beqlu 0f # fail if character is matched ! 9508: jmp failp ! 9509: 0: ! 9510: incl r7 # else bump cursor ! 9511: jmp succp # and succeed ! 9512: #page ! 9513: # ! 9514: # END OF PATTERN MATCH ! 9515: # ! 9516: # THIS ROUTINE IS ENTERED ON SUCCESSFUL COMPLETION. ! 9517: # SEE DESCRIPTION OF EXPRESSION PATTERNS IN COMPOUND ! 9518: # PATTERN SECTION FOR HANDLING OF RECURSION IN MATCHING. ! 9519: # ! 9520: # NO PARAMETERS (DUMMY PATTERN) ! 9521: # ! 9522: p$nth: # entry point ! 9523: movl pmhbs,r10 # load pointer to base of stack ! 9524: movl 4*1(r10),r6 # load saved pmhbs (or pattern type) ! 9525: cmpl r6,$num02 # jump if outer level (pattern type) ! 9526: blequ pnth2 ! 9527: # ! 9528: # HERE WE ARE AT THE END OF MATCHING AN EXPRESSION PATTERN ! 9529: # ! 9530: movl r6,pmhbs # restore outer stack base pointer ! 9531: movl 4*2(r10),r9 # restore pointer to p$exa node ! 9532: cmpl r10,sp # jump if no history stack entries ! 9533: beqlu pnth1 ! 9534: movl r10,-(sp) # else stack inner stack base ptr ! 9535: movl $ndexc,-(sp) # stack ptr to special node ndexc ! 9536: jmp succp # and succeed ! 9537: # ! 9538: # HERE IF NO HISTORY STACK ENTRIES DURING PATTERN ! 9539: # ! 9540: pnth1: addl2 $4*num04,sp # remove p$exb entry and node ptr ! 9541: jmp succp # and succeed ! 9542: # ! 9543: # HERE IF END OF MATCH AT OUTER LEVEL ! 9544: # ! 9545: pnth2: movl r7,pmssl # save final cursor in safe place ! 9546: tstl pmdfl # jump if no pattern assignments ! 9547: beqlu pnth6 ! 9548: #page ! 9549: # ! 9550: # END OF PATTERN MATCH (CONTINUED) ! 9551: # ! 9552: # NOW WE MUST PERFORM PATTERN ASSIGNMENTS. THIS IS DONE BY ! 9553: # SCANNING THE HISTORY STACK FOR MATCHING NDPAB-NDPAD PAIRS ! 9554: # ! 9555: pnth3: subl2 $4,r10 # point past cursor entry ! 9556: movl -(r10),r6 # load node pointer ! 9557: cmpl r6,$ndpad # jump if ndpad entry ! 9558: beqlu pnth4 ! 9559: cmpl r6,$ndpab # jump if not ndpab entry ! 9560: bnequ pnth5 ! 9561: # ! 9562: # HERE FOR NDPAB ENTRY, STACK INITIAL CURSOR ! 9563: # NOTE THAT THERE MUST BE MORE ENTRIES ON THE STACK. ! 9564: # ! 9565: movl 4*1(r10),-(sp) # stack initial cursor ! 9566: jsb sbchk # check for stack overflow ! 9567: jmp pnth3 # loop back if ok ! 9568: # ! 9569: # HERE FOR NDPAD ENTRY. THE STARTING CURSOR FROM THE ! 9570: # MATCHING NDPAD ENTRY IS NOW THE TOP STACK ENTRY. ! 9571: # ! 9572: pnth4: movl 4*1(r10),r6 # load final cursor ! 9573: movl (sp),r7 # load initial cursor from stack ! 9574: movl r10,(sp) # save history stack scan ptr ! 9575: subl2 r7,r6 # compute length of string ! 9576: # ! 9577: # BUILD SUBSTRING AND PERFORM ASSIGNMENT ! 9578: # ! 9579: movl r$pms,r10 # point to subject string ! 9580: jsb sbstr # construct substring ! 9581: movl r9,r7 # copy substring pointer ! 9582: movl (sp),r10 # reload history stack scan ptr ! 9583: movl 4*2(r10),r10 # load pointer to p$pac node with nam ! 9584: movl 4*parm2(r10),r6 # load name offset ! 9585: movl 4*parm1(r10),r10# load name base ! 9586: jsb asinp # perform assignment ! 9587: .long exfal # match fails if name eval fails ! 9588: movl (sp)+,r10 # else restore history stack ptr ! 9589: #page ! 9590: # ! 9591: # END OF PATTERN MATCH (CONTINUED) ! 9592: # ! 9593: # HERE CHECK FOR END OF ENTRIES ! 9594: # ! 9595: pnth5: cmpl r10,sp # loop if more entries to scan ! 9596: bnequ pnth3 ! 9597: # ! 9598: # HERE AFTER DEALING WITH PATTERN ASSIGNMENTS ! 9599: # ! 9600: pnth6: movl pmhbs,sp # wipe out history stack ! 9601: movl (sp)+,r7 # load initial cursor ! 9602: movl (sp)+,r8 # load match type code ! 9603: movl pmssl,r6 # load final cursor value ! 9604: movl r$pms,r10 # point to subject string ! 9605: clrl r$pms # clear subject string ptr for gbcol ! 9606: tstl r8 # jump if call by name ! 9607: beqlu pnth7 ! 9608: cmpl r8,$num02 # exit if statement level call ! 9609: bnequ 0f ! 9610: jmp exits ! 9611: 0: ! 9612: # ! 9613: # HERE WE HAVE A CALL BY VALUE, BUILD SUBSTRING ! 9614: # ! 9615: subl2 r7,r6 # compute length of string ! 9616: jsb sbstr # build substring ! 9617: jmp exixr # and exit with substring value ! 9618: # ! 9619: # HERE FOR CALL BY NAME, MAKE STACK ENTRIES FOR O$RPL ! 9620: # ! 9621: pnth7: movl r7,-(sp) # stack initial cursor ! 9622: movl r6,-(sp) # stack final cursor ! 9623: tstl r$pmb # skip if subject not buffer ! 9624: beqlu pnth8 ! 9625: movl r$pmb,r10 # else get ptr to bcblk instead ! 9626: # ! 9627: # HERE WITH XL POINTING TO SCBLK OR BCBLK ! 9628: # ! 9629: pnth8: movl r10,-(sp) # stack subject pointer ! 9630: jmp exits # exit with special entry on stack ! 9631: #page ! 9632: # ! 9633: # POS (INTEGER ARGUMENT) ! 9634: # ! 9635: # PARM1 INTEGER ARGUMENT ! 9636: # ! 9637: .align 2 ! 9638: .word bl$p1 ! 9639: p$pos: # p1blk ! 9640: # ! 9641: # EXPRESSION ARGUMENT CASE MERGES HERE ! 9642: # ! 9643: ppos1: cmpl r7,4*parm1(r9) # succeed if at right location ! 9644: bnequ 0f ! 9645: jmp succp ! 9646: 0: ! 9647: jmp failp # else fail ! 9648: #page ! 9649: # ! 9650: # POS (EXPRESSION ARGUMENT) ! 9651: # ! 9652: # PARM1 EXPRESSION POINTER ! 9653: # ! 9654: .align 2 ! 9655: .word bl$p1 ! 9656: p$psd: # p1blk ! 9657: jsb evali # evaluate integer argument ! 9658: .long er_050 # pos evaluated argument is not integer ! 9659: .long er_051 # pos evaluated argument is negative or too large ! 9660: .long failp # fail if evaluation fails ! 9661: .long ppos1 # merge with normal case if ok ! 9662: #page ! 9663: # ! 9664: # PATTERN ASSIGNMENT (INITIAL ENTRY, SAVE CURSOR) ! 9665: # ! 9666: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9667: # ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9668: # ! 9669: # NO PARAMETERS ! 9670: # ! 9671: .align 2 ! 9672: .word bl$p0 ! 9673: p$paa: # p0blk ! 9674: movl r7,-(sp) # stack initial cursor ! 9675: movl $ndpab,-(sp) # stack ptr to ndpab special node ! 9676: jmp succp # and succeed matching null ! 9677: #page ! 9678: # ! 9679: # PATTERN ASSIGNMENT (REMOVE SAVED CURSOR) ! 9680: # ! 9681: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9682: # ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9683: # ! 9684: # NO PARAMETERS (DUMMY PATTERN) ! 9685: # ! 9686: p$pab: # entry point ! 9687: jmp failp # just fail (entry is already popped) ! 9688: #page ! 9689: # ! 9690: # PATTERN ASSIGNMENT (END OF MATCH, MAKE ASSIGN ENTRY) ! 9691: # ! 9692: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9693: # ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9694: # ! 9695: # PARM1 NAME BASE OF VARIABLE ! 9696: # PARM2 NAME OFFSET OF VARIABLE ! 9697: # ! 9698: .align 2 ! 9699: .word bl$p2 ! 9700: p$pac: # p2blk ! 9701: movl r7,-(sp) # stack dummy cursor value ! 9702: movl r9,-(sp) # stack pointer to p$pac node ! 9703: movl r7,-(sp) # stack final cursor ! 9704: movl $ndpad,-(sp) # stack ptr to special ndpad node ! 9705: movl sp,pmdfl # set dot flag non-zero ! 9706: jmp succp # and succeed ! 9707: #page ! 9708: # ! 9709: # PATTERN ASSIGNMENT (REMOVE ASSIGN ENTRY) ! 9710: # ! 9711: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND ! 9712: # ALGORITHMS FOR MATCHING THIS NODE TYPE. ! 9713: # ! 9714: # NO PARAMETERS (DUMMY NODE) ! 9715: # ! 9716: p$pad: # entry point ! 9717: jmp flpop # fail and remove p$pac node ! 9718: #page ! 9719: # ! 9720: # REM ! 9721: # ! 9722: # NO PARAMETERS ! 9723: # ! 9724: .align 2 ! 9725: .word bl$p0 ! 9726: p$rem: # p0blk ! 9727: movl pmssl,r7 # point cursor to end of string ! 9728: jmp succp # and succeed ! 9729: #page ! 9730: # ! 9731: # RPOS (EXPRESSION ARGUMENT) ! 9732: # ! 9733: # PARM1 EXPRESSION POINTER ! 9734: # ! 9735: .align 2 ! 9736: .word bl$p1 ! 9737: p$rpd: # p1blk ! 9738: jsb evali # evaluate integer argument ! 9739: .long er_052 # rpos evaluated argument is not integer ! 9740: .long er_053 # rpos evaluated argument is negative or too large ! 9741: .long failp # fail if evaluation fails ! 9742: .long prps1 # merge with normal case if ok ! 9743: #page ! 9744: # ! 9745: # RPOS (INTEGER ARGUMENT) ! 9746: # ! 9747: # PARM1 INTEGER ARGUMENT ! 9748: # ! 9749: .align 2 ! 9750: .word bl$p1 ! 9751: p$rps: # p1blk ! 9752: # ! 9753: # EXPRESSION ARGUMENT CASE MERGES HERE ! 9754: # ! 9755: prps1: movl pmssl,r8 # get length of string ! 9756: subl2 r7,r8 # get number of characters remaining ! 9757: cmpl r8,4*parm1(r9) # succeed if at right location ! 9758: bnequ 0f ! 9759: jmp succp ! 9760: 0: ! 9761: jmp failp # else fail ! 9762: #page ! 9763: # ! 9764: # RTAB (INTEGER ARGUMENT) ! 9765: # ! 9766: # PARM1 INTEGER ARGUMENT ! 9767: # ! 9768: .align 2 ! 9769: .word bl$p1 ! 9770: p$rtb: # p1blk ! 9771: # ! 9772: # EXPRESSION ARGUMENT CASE MERGES HERE ! 9773: # ! 9774: prtb1: movl r7,r8 # save initial cursor ! 9775: movl pmssl,r7 # point to end of string ! 9776: cmpl r7,4*parm1(r9) # fail if string not long enough ! 9777: bgequ 0f ! 9778: jmp failp ! 9779: 0: ! 9780: subl2 4*parm1(r9),r7 # else set new cursor ! 9781: cmpl r7,r8 # and succeed if not too far already ! 9782: blssu 0f ! 9783: jmp succp ! 9784: 0: ! 9785: jmp failp # in which case, fail ! 9786: #page ! 9787: # ! 9788: # RTAB (EXPRESSION ARGUMENT) ! 9789: # ! 9790: # PARM1 EXPRESSION POINTER ! 9791: # ! 9792: .align 2 ! 9793: .word bl$p1 ! 9794: p$rtd: # p1blk ! 9795: jsb evali # evaluate integer argument ! 9796: .long er_054 # rtab evaluated argument is not integer ! 9797: .long er_055 # rtab evaluated argument is negative or too large ! 9798: .long failp # fail if evaluation fails ! 9799: .long prtb1 # merge with normal case if success ! 9800: #page ! 9801: # ! 9802: # SPAN (EXPRESSION ARGUMENT) ! 9803: # ! 9804: # PARM1 EXPRESSION POINTER ! 9805: # ! 9806: .align 2 ! 9807: .word bl$p1 ! 9808: p$spd: # p1blk ! 9809: jsb evals # evaluate string argument ! 9810: .long er_056 # span evaluated argument is not string ! 9811: .long failp # fail if evaluation fails ! 9812: .long pspn1 # merge with multi-char case if ok ! 9813: #page ! 9814: # ! 9815: # SPAN (MULTI-CHARACTER ARGUMENT CASE) ! 9816: # ! 9817: # PARM1 POINTER TO CTBLK ! 9818: # PARM2 BIT MASK TO SELECT BIT COLUMN ! 9819: # ! 9820: .align 2 ! 9821: .word bl$p2 ! 9822: p$spn: # p2blk ! 9823: # ! 9824: # EXPRESSION ARGUMENT CASE MERGES HERE ! 9825: # ! 9826: pspn1: movl pmssl,r8 # copy subject string length ! 9827: subl2 r7,r8 # calculate number of characters left ! 9828: bnequ 0f # fail if no characters left ! 9829: jmp failp ! 9830: 0: ! 9831: movl r$pms,r10 # point to subject string ! 9832: movab cfp$f(r10)[r7],r10 # point to current character ! 9833: movl r7,psavc # save initial cursor ! 9834: movl r9,psave # save node pointer ! 9835: # set counter for chars left ! 9836: # ! 9837: # LOOP TO SCAN MATCHING CHARACTERS ! 9838: # ! 9839: pspn2: movzbl (r10)+,r6 # load next character, bump pointer ! 9840: moval 0[r6],r6 # convert to byte offset ! 9841: movl 4*parm1(r9),r9 # point to ctblk ! 9842: addl2 r6,r9 # point to ctblk entry ! 9843: movl 4*ctchs(r9),r6 # load ctblk entry ! 9844: movl psave,r9 # restore node pointer ! 9845: mcoml 4*parm2(r9),r11 # and with selected bit ! 9846: bicl2 r11,r6 ! 9847: beqlu pspn3 # jump if no match ! 9848: incl r7 # else push cursor ! 9849: sobgtr r8,pspn2 # loop back unless end of string ! 9850: # ! 9851: # HERE AFTER SCANNING MATCHING CHARACTERS ! 9852: # ! 9853: pspn3: cmpl r7,psavc # succeed if chars matched ! 9854: beqlu 0f ! 9855: jmp succp ! 9856: 0: ! 9857: jmp failp # else fail if null string matched ! 9858: #page ! 9859: # ! 9860: # SPAN (ONE CHARACTER ARGUMENT) ! 9861: # ! 9862: # PARM1 CHARACTER ARGUMENT ! 9863: # ! 9864: .align 2 ! 9865: .word bl$p1 ! 9866: p$sps: # p1blk ! 9867: movl pmssl,r8 # get subject string length ! 9868: subl2 r7,r8 # calculate number of characters left ! 9869: bnequ 0f # fail if no characters left ! 9870: jmp failp ! 9871: 0: ! 9872: movl r$pms,r10 # else point to subject string ! 9873: movab cfp$f(r10)[r7],r10 # point to current character ! 9874: movl r7,psavc # save initial cursor ! 9875: # set counter for characters left ! 9876: # ! 9877: # LOOP TO SCAN MATCHING CHARACTERS ! 9878: # ! 9879: psps1: movzbl (r10)+,r6 # load next character, bump pointer ! 9880: cmpl r6,4*parm1(r9) # jump if no match ! 9881: bnequ psps2 ! 9882: incl r7 # else push cursor ! 9883: sobgtr r8,psps1 # and loop unless end of string ! 9884: # ! 9885: # HERE AFTER SCANNING MATCHING CHARACTERS ! 9886: # ! 9887: psps2: cmpl r7,psavc # succeed if chars matched ! 9888: beqlu 0f ! 9889: jmp succp ! 9890: 0: ! 9891: jmp failp # fail if null string matched ! 9892: #page ! 9893: # ! 9894: # MULTI-CHARACTER STRING ! 9895: # ! 9896: # NOTE THAT ONE CHARACTER STRINGS USE THE CIRCUIT FOR ! 9897: # ONE CHARACTER ANY ARGUMENTS (P$AN1). ! 9898: # ! 9899: # PARM1 POINTER TO SCBLK FOR STRING ARG ! 9900: # ! 9901: .align 2 ! 9902: .word bl$p1 ! 9903: p$str: # p1blk ! 9904: movl 4*parm1(r9),r10 # get pointer to string ! 9905: # ! 9906: # MERGE HERE AFTER EVALUATING EXPRESSION WITH STRING VALUE ! 9907: # ! 9908: pstr1: movl r9,psave # save node pointer ! 9909: movl r$pms,r9 # load subject string pointer ! 9910: movab cfp$f(r9)[r7],r9# point to current character ! 9911: addl2 4*sclen(r10),r7 # compute new cursor position ! 9912: cmpl r7,pmssl # fail if past end of string ! 9913: blequ 0f ! 9914: jmp failp ! 9915: 0: ! 9916: movl r7,psavc # save updated cursor ! 9917: movl 4*sclen(r10),r6 # get number of chars to compare ! 9918: movab cfp$f(r10),r10 # point to chars of test string ! 9919: jsb sbcmc # compare, fail if not equal ! 9920: .long failp ! 9921: .long failp ! 9922: movl psave,r9 # if all matched, restore node ptr ! 9923: movl psavc,r7 # restore updated cursor ! 9924: jmp succp # and succeed ! 9925: #page ! 9926: # ! 9927: # SUCCEED ! 9928: # ! 9929: # SEE SECTION ON COMPOUND PATTERNS FOR DETAILS OF THE ! 9930: # STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE ! 9931: # ! 9932: # NO PARAMETERS ! 9933: # ! 9934: .align 2 ! 9935: .word bl$p0 ! 9936: p$suc: # p0blk ! 9937: movl r7,-(sp) # stack cursor ! 9938: movl r9,-(sp) # stack pointer to this node ! 9939: jmp succp # succeed matching null ! 9940: #page ! 9941: # ! 9942: # TAB (INTEGER ARGUMENT) ! 9943: # ! 9944: # PARM1 INTEGER ARGUMENT ! 9945: # ! 9946: .align 2 ! 9947: .word bl$p1 ! 9948: p$tab: # p1blk ! 9949: # ! 9950: # EXPRESSION ARGUMENT CASE MERGES HERE ! 9951: # ! 9952: ptab1: cmpl r7,4*parm1(r9) # fail if too far already ! 9953: blequ 0f ! 9954: jmp failp ! 9955: 0: ! 9956: movl 4*parm1(r9),r7 # else set new cursor position ! 9957: cmpl r7,pmssl # succeed if not off end ! 9958: bgtru 0f ! 9959: jmp succp ! 9960: 0: ! 9961: jmp failp # else fail ! 9962: #page ! 9963: # ! 9964: # TAB (EXPRESSION ARGUMENT) ! 9965: # ! 9966: # PARM1 EXPRESSION POINTER ! 9967: # ! 9968: .align 2 ! 9969: .word bl$p1 ! 9970: p$tbd: # p1blk ! 9971: jsb evali # evaluate integer argument ! 9972: .long er_057 # tab evaluated argument is not integer ! 9973: .long er_058 # tab evaluated argument is negative or too large ! 9974: .long failp # fail if evaluation fails ! 9975: .long ptab1 # merge with normal case if ok ! 9976: #page ! 9977: # ! 9978: # ANCHOR MOVEMENT ! 9979: # ! 9980: # NO PARAMETERS (DUMMY NODE) ! 9981: # ! 9982: p$una: # entry point ! 9983: movl r7,r9 # copy initial pattern node pointer ! 9984: movl (sp),r7 # get initial cursor ! 9985: cmpl r7,pmssl # match fails if at end of string ! 9986: bnequ 0f ! 9987: jmp exfal ! 9988: 0: ! 9989: incl r7 # else increment cursor ! 9990: movl r7,(sp) # store incremented cursor ! 9991: movl r9,-(sp) # restack initial node ptr ! 9992: movl $nduna,-(sp) # restack unanchored node ! 9993: movl (r9),r11 # rematch first node ! 9994: jmp (r11) ! 9995: #page ! 9996: # ! 9997: # END OF PATTERN MATCH ROUTINES ! 9998: # ! 9999: # THE FOLLOWING ENTRY POINT MARKS THE END OF THE PATTERN ! 10000: # MATCHING ROUTINES AND ALSO THE END OF THE ENTRY POINTS ! 10001: # REFERENCED FROM THE FIRST WORD OF BLOCKS IN DYNAMIC STORE ! 10002: # ! 10003: .align 2 ! 10004: .word bl$$i ! 10005: p$yyy: # mark last entry in pattern section ! 10006: #title s p i t b o l -- predefined snobol4 functions ! 10007: # ! 10008: # THE FOLLOWING SECTION CONTAINS CODING FOR FUNCTIONS ! 10009: # WHICH ARE PREDEFINED AND AVAILABLE AT THE SNOBOL LEVEL. ! 10010: # ! 10011: # THESE ROUTINES RECEIVE CONTROL DIRECTLY FROM THE CODE OR ! 10012: # INDIRECTLY THROUGH THE O$FNC, O$FNS OR CFUNC ROUTINES. ! 10013: # IN BOTH CASES THE CONDITIONS ON ENTRY ARE AS FOLLOWS ! 10014: # ! 10015: # THE ARGUMENTS ARE ON THE STACK. THE NUMBER OF ARGUMENTS ! 10016: # HAS BEEN ADJUSTED TO CORRESPOND TO THE SVBLK SVNAR FIELD. ! 10017: # ! 10018: # IN CERTAIN FUNCTIONS THE DIRECT CALL IS NOT PERMITTED ! 10019: # AND IN THESE INSTANCES WE ALSO HAVE. ! 10020: # ! 10021: # (WA) ACTUAL NUMBER OF ARGUMENTS IN CALL ! 10022: # ! 10023: # CONTROL RETURNS BY PLACING THE FUNCTION RESULT VALUE ON ! 10024: # ON THE STACK AND CONTINUING EXECUTION WITH THE NEXT ! 10025: # WORD FROM THE GENERATED CODE. ! 10026: # ! 10027: # THE NAMES OF THE ENTRY POINTS OF THESE FUNCTIONS ARE OF ! 10028: # THE FORM S$XXX WHERE XXX IS THE THREE LETTER CODE FOR ! 10029: # THE SYSTEM VARIABLE NAME. THE FUNCTIONS ARE IN ORDER ! 10030: # ALPHABETICALLY BY THEIR ENTRY NAMES. ! 10031: #page ! 10032: # ! 10033: # ANY ! 10034: # ! 10035: s$any: # entry point ! 10036: movl $p$ans,r7 # set pcode for single char case ! 10037: movl $p$any,r10 # pcode for multi-char case ! 10038: movl $p$ayd,r8 # pcode for expression case ! 10039: jsb patst # call common routine to build node ! 10040: .long er_059 # any argument is not string or expression ! 10041: jmp exixr # jump for next code word ! 10042: #page ! 10043: # ! 10044: # APPEND ! 10045: # ! 10046: s$apn: # entry point ! 10047: movl (sp)+,r10 # get append argument ! 10048: movl (sp)+,r9 # get bcblk ! 10049: cmpl (r9),$b$bct # ok if first arg is bcblk ! 10050: beqlu sapn1 ! 10051: jmp er_275 # append first argument is not buffer ! 10052: # ! 10053: # HERE TO DO THE APPEND ! 10054: # ! 10055: sapn1: jsb apndb # do the append ! 10056: .long er_276 # append second argument is not string ! 10057: .long exfal # no room - fail ! 10058: jmp exnul # exit with null result ! 10059: #page ! 10060: # ! 10061: # APPLY ! 10062: # ! 10063: # APPLY DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT ! 10064: # WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED. ! 10065: # ! 10066: s$app: # entry point ! 10067: tstl r6 # jump if no arguments ! 10068: beqlu sapp3 ! 10069: decl r6 # else get applied func arg count ! 10070: movl r6,r7 # copy ! 10071: moval 0[r7],r7 # convert to bytes ! 10072: movl sp,r10 # copy stack pointer ! 10073: addl2 r7,r10 # point to function argument on stack ! 10074: movl (r10),r9 # load function ptr (apply 1st arg) ! 10075: tstl r6 # jump if no args for applied func ! 10076: beqlu sapp2 ! 10077: movl r6,r7 # else set counter for loop ! 10078: # ! 10079: # LOOP TO MOVE ARGUMENTS UP ON STACK ! 10080: # ! 10081: sapp1: subl2 $4,r10 # point to next argument ! 10082: movl (r10),4*1(r10) # move argument up ! 10083: sobgtr r7,sapp1 # loop till all moved ! 10084: # ! 10085: # MERGE HERE TO CALL FUNCTION (WA = NUMBER OF ARGUMENTS) ! 10086: # ! 10087: sapp2: addl2 $4,sp # adjust stack ptr for apply 1st arg ! 10088: jsb gtnvr # get variable block addr for func ! 10089: .long sapp3 # jump if not natural variable ! 10090: movl 4*vrfnc(r9),r10 # else point to function block ! 10091: jmp cfunc # go call applied function ! 10092: # ! 10093: # HERE FOR INVALID FIRST ARGUMENT ! 10094: # ! 10095: sapp3: jmp er_060 # apply first arg is not natural variable name ! 10096: #page ! 10097: # ! 10098: # ARBNO ! 10099: # ! 10100: # ARBNO BUILDS A COMPOUND PATTERN. SEE DESCRIPTION AT ! 10101: # START OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED. ! 10102: # ! 10103: s$abn: # entry point ! 10104: clrl r9 # set parm1 = 0 for the moment ! 10105: movl $p$alt,r7 # set pcode for alternative node ! 10106: jsb pbild # build alternative node ! 10107: movl r9,r10 # save ptr to alternative pattern ! 10108: movl $p$abc,r7 # pcode for p$abc ! 10109: clrl r9 # p0blk ! 10110: jsb pbild # build p$abc node ! 10111: movl r10,4*pthen(r9) # put alternative node as successor ! 10112: movl r10,r6 # remember alternative node pointer ! 10113: movl r9,r10 # copy p$abc node ptr ! 10114: movl (sp),r9 # load arbno argument ! 10115: movl r6,(sp) # stack alternative node pointer ! 10116: jsb gtpat # get arbno argument as pattern ! 10117: .long er_061 # arbno argument is not pattern ! 10118: jsb pconc # concat arg with p$abc node ! 10119: movl r9,r10 # remember ptr to concd patterns ! 10120: movl $p$aba,r7 # pcode for p$aba ! 10121: clrl r9 # p0blk ! 10122: jsb pbild # build p$aba node ! 10123: movl r10,4*pthen(r9) # concatenate nodes ! 10124: movl (sp),r10 # recall ptr to alternative node ! 10125: movl r9,4*parm1(r10) # point alternative back to argument ! 10126: jmp exits # jump for next code word ! 10127: #page ! 10128: # ! 10129: # ARG ! 10130: # ! 10131: s$arg: # entry point ! 10132: jsb gtsmi # get second arg as small integer ! 10133: .long er_062 # arg second argument is not integer ! 10134: .long exfal # fail if out of range or negative ! 10135: movl r9,r6 # save argument number ! 10136: movl (sp)+,r9 # load first argument ! 10137: jsb gtnvr # locate vrblk ! 10138: .long sarg1 # jump if not natural variable ! 10139: movl 4*vrfnc(r9),r9 # else load function block pointer ! 10140: cmpl (r9),$b$pfc # jump if not program defined ! 10141: bnequ sarg1 ! 10142: tstl r6 # fail if arg number is zero ! 10143: bnequ 0f ! 10144: jmp exfal ! 10145: 0: ! 10146: cmpl r6,4*fargs(r9) # fail if arg number is too large ! 10147: blequ 0f ! 10148: jmp exfal ! 10149: 0: ! 10150: moval 0[r6],r6 # else convert to byte offset ! 10151: addl2 r6,r9 # point to argument selected ! 10152: movl 4*pfagb(r9),r9 # load argument vrblk pointer ! 10153: jmp exvnm # exit to build nmblk ! 10154: # ! 10155: # HERE IF 1ST ARGUMENT IS BAD ! 10156: # ! 10157: sarg1: jmp er_063 # arg first argument is not program function name ! 10158: #page ! 10159: # ! 10160: # ARRAY ! 10161: # ! 10162: s$arr: # entry point ! 10163: movl (sp)+,r10 # load initial element value ! 10164: movl (sp)+,r9 # load first argument ! 10165: jsb gtint # convert first arg to integer ! 10166: .long sar02 # jump if not integer ! 10167: # ! 10168: # HERE FOR INTEGER FIRST ARGUMENT, BUILD VCBLK ! 10169: # ! 10170: movl 4*icval(r9),r5 # load integer value ! 10171: bgtr 0f # jump if zero or neg (bad dimension) ! 10172: jmp sar10 ! 10173: 0: ! 10174: movl r5,r6 # else convert to one word, test ovfl ! 10175: bgeq 0f ! 10176: jmp sar11 ! 10177: 0: ! 10178: movl r6,r7 # copy elements for loop later on ! 10179: addl2 $vcsi$,r6 # add space for standard fields ! 10180: moval 0[r6],r6 # convert length to bytes ! 10181: cmpl r6,mxlen # fail if too large ! 10182: blssu 0f ! 10183: jmp sar11 ! 10184: 0: ! 10185: jsb alloc # allocate space for vcblk ! 10186: movl $b$vct,(r9) # store type word ! 10187: movl r6,4*vclen(r9) # set length ! 10188: movl r10,r8 # copy default value ! 10189: movl r9,r10 # copy vcblk pointer ! 10190: addl2 $4*vcvls,r10 # point to first element value ! 10191: # ! 10192: # LOOP TO SET VECTOR ELEMENTS TO DEFAULT VALUE ! 10193: # ! 10194: sar01: movl r8,(r10)+ # store one value ! 10195: sobgtr r7,sar01 # loop till all stored ! 10196: jmp exsid # exit setting idval ! 10197: #page ! 10198: # ! 10199: # ARRAY (CONTINUED) ! 10200: # ! 10201: # HERE IF FIRST ARGUMENT IS NOT AN INTEGER ! 10202: # ! 10203: sar02: movl r9,-(sp) # replace argument on stack ! 10204: jsb xscni # initialize scan of first argument ! 10205: .long er_064 # array first argument is not integer or string ! 10206: .long exnul # dummy (unused) null string exit ! 10207: movl r$xsc,-(sp) # save prototype pointer ! 10208: movl r10,-(sp) # save default value ! 10209: clrl arcdm # zero count of dimensions ! 10210: clrl arptr # zero offset to indicate pass one ! 10211: movl intv1,r5 # load integer one ! 10212: movl r5,arnel # initialize element count ! 10213: # ! 10214: # THE FOLLOWING CODE IS EXECUTED TWICE. THE FIRST TIME ! 10215: # (ARPTR EQ 0), IT IS USED TO COUNT THE NUMBER OF ELEMENTS ! 10216: # AND NUMBER OF DIMENSIONS. THE SECOND TIME (ARPTR GT 0) IS ! 10217: # USED TO ACTUALLY FILL IN THE DIM,LBD FIELDS OF THE ARBLK. ! 10218: # ! 10219: sar03: movl intv1,r5 # load one as default low bound ! 10220: movl r5,arsvl # save as low bound ! 10221: movl $ch$cl,r8 # set delimiter one = colon ! 10222: movl $ch$cm,r10 # set delimiter two = comma ! 10223: jsb xscan # scan next bound ! 10224: cmpl r6,$num01 # jump if not colon ! 10225: bnequ sar04 ! 10226: # ! 10227: # HERE WE HAVE A COLON ENDING A LOW BOUND ! 10228: # ! 10229: jsb gtint # convert low bound ! 10230: .long er_065 # array first argument lower bound is not integer ! 10231: movl 4*icval(r9),r5 # load value of low bound ! 10232: movl r5,arsvl # store low bound value ! 10233: movl $ch$cm,r8 # set delimiter one = comma ! 10234: movl r8,r10 # and delimiter two = comma ! 10235: jsb xscan # scan high bound ! 10236: #page ! 10237: # ! 10238: # ARRAY (CONTINUED) ! 10239: # ! 10240: # MERGE HERE TO PROCESS UPPER BOUND ! 10241: # ! 10242: sar04: jsb gtint # convert high bound to integer ! 10243: .long er_066 # array first argument upper bound is not integer ! 10244: movl 4*icval(r9),r5 # get high bound ! 10245: subl2 arsvl,r5 # subtract lower bound ! 10246: bvc 0f ! 10247: jmp sar10 ! 10248: 0: ! 10249: tstl r5 # bad dimension if negative ! 10250: bgeq 0f ! 10251: jmp sar10 ! 10252: 0: ! 10253: addl2 intv1,r5 # add 1 to get dimension ! 10254: bvc 0f ! 10255: jmp sar10 ! 10256: 0: ! 10257: movl arptr,r10 # load offset (also pass indicator) ! 10258: beqlu sar05 # jump if first pass ! 10259: # ! 10260: # HERE IN SECOND PASS TO STORE LBD AND DIM IN ARBLK ! 10261: # ! 10262: addl2 (sp),r10 # point to current location in arblk ! 10263: movl r5,4*cfp$i(r10) # store dimension ! 10264: movl arsvl,r5 # load low bound ! 10265: movl r5,(r10) # store low bound ! 10266: addl2 $4*ardms,arptr # bump offset to next bounds ! 10267: jmp sar06 # jump to check for end of bounds ! 10268: # ! 10269: # HERE IN PASS 1 ! 10270: # ! 10271: sar05: incl arcdm # bump dimension count ! 10272: mull2 arnel,r5 # multiply dimension by count so far ! 10273: bvc 0f ! 10274: jmp sar11 ! 10275: 0: ! 10276: movl r5,arnel # else store updated element count ! 10277: # ! 10278: # MERGE HERE AFTER PROCESSING ONE SET OF BOUNDS ! 10279: # ! 10280: sar06: tstl r6 # loop back unless end of bounds ! 10281: beqlu 0f ! 10282: jmp sar03 ! 10283: 0: ! 10284: tstl arptr # jump if end of pass 2 ! 10285: beqlu 0f ! 10286: jmp sar09 ! 10287: 0: ! 10288: #page ! 10289: # ! 10290: # ARRAY (CONTINUED) ! 10291: # ! 10292: # HERE AT END OF PASS ONE, BUILD ARBLK ! 10293: # ! 10294: movl arnel,r5 # get number of elements ! 10295: movl r5,r7 # get as addr integer, test ovflo ! 10296: bgeq 0f ! 10297: jmp sar11 ! 10298: 0: ! 10299: moval 0[r7],r7 # else convert to length in bytes ! 10300: movl $4*arsi$,r6 # set size of standard fields ! 10301: movl arcdm,r8 # set dimension count to control loop ! 10302: # ! 10303: # LOOP TO ALLOW SPACE FOR DIMENSIONS ! 10304: # ! 10305: sar07: addl2 $4*ardms,r6 # allow space for one set of bounds ! 10306: sobgtr r8,sar07 # loop back till all accounted for ! 10307: movl r6,r10 # save size (=arofs) ! 10308: # ! 10309: # NOW ALLOCATE SPACE FOR ARBLK ! 10310: # ! 10311: addl2 r7,r6 # add space for elements ! 10312: addl2 $4,r6 # allow for arpro prototype field ! 10313: cmpl r6,mxlen # fail if too large ! 10314: blssu 0f ! 10315: jmp sar11 ! 10316: 0: ! 10317: jsb alloc # else allocate arblk ! 10318: movl (sp),r7 # load default value ! 10319: movl r9,(sp) # save arblk pointer ! 10320: movl r6,r8 # save length in bytes ! 10321: ashl $-2,r6,r6 # convert length back to words ! 10322: # set counter to control loop ! 10323: # ! 10324: # LOOP TO CLEAR ENTIRE ARBLK TO DEFAULT VALUE ! 10325: # ! 10326: sar08: movl r7,(r9)+ # set one word ! 10327: sobgtr r6,sar08 # loop till all set ! 10328: #page ! 10329: # ! 10330: # ARRAY (CONTINUED) ! 10331: # ! 10332: # NOW SET INITIAL FIELDS OF ARBLK ! 10333: # ! 10334: movl (sp)+,r9 # reload arblk pointer ! 10335: movl (sp),r7 # load prototype ! 10336: movl $b$art,(r9) # set type word ! 10337: movl r8,4*arlen(r9) # store length in bytes ! 10338: clrl 4*idval(r9) # zero id till we get it built ! 10339: movl r10,4*arofs(r9) # set prototype field ptr ! 10340: movl arcdm,4*arndm(r9)# set number of dimensions ! 10341: movl r9,r8 # save arblk pointer ! 10342: addl2 r10,r9 # point to prototype field ! 10343: movl r7,(r9) # store prototype ptr in arblk ! 10344: movl $4*arlbd,arptr # set offset for pass 2 bounds scan ! 10345: movl r7,r$xsc # reset string pointer for xscan ! 10346: movl r8,(sp) # store arblk pointer on stack ! 10347: clrl xsofs # reset offset ptr to start of string ! 10348: jmp sar03 # jump back to rescan bounds ! 10349: # ! 10350: # HERE AFTER FILLING IN BOUNDS INFORMATION (END PASS TWO) ! 10351: # ! 10352: sar09: movl (sp)+,r9 # reload pointer to arblk ! 10353: jmp exsid # exit setting idval ! 10354: # ! 10355: # HERE FOR BAD DIMENSION ! 10356: # ! 10357: sar10: jmp er_067 # array dimension is zero,negative or out of range ! 10358: # ! 10359: # HERE IF ARRAY IS TOO LARGE ! 10360: # ! 10361: sar11: jmp er_068 # array size exceeds maximum permitted ! 10362: #page ! 10363: # ! 10364: # BUFFER ! 10365: # ! 10366: s$buf: # entry point ! 10367: movl (sp)+,r10 # get initial value ! 10368: movl (sp)+,r9 # get requested allocation ! 10369: jsb gtint # convert to integer ! 10370: .long er_269 # buffer first argument is not integer ! 10371: movl 4*icval(r9),r5 # get value ! 10372: bleq sbf01 # branch if negative or zero ! 10373: movl r5,r6 # move with overflow check ! 10374: bgeq 0f ! 10375: jmp sbf02 ! 10376: 0: ! 10377: jsb alobf # allocate the buffer ! 10378: jsb apndb # copy it in ! 10379: .long er_270 # buffer second argument is not string or buffer ! 10380: .long er_271 # buffer initial value too big for allocation ! 10381: jmp exsid # exit setting idval ! 10382: # ! 10383: # HERE FOR INVALID ALLOCATION SIZE ! 10384: # ! 10385: sbf01: jmp er_272 # buffer first argument is not positive ! 10386: # ! 10387: # HERE FOR ALLOCATION SIZE INTEGER OVERFLOW ! 10388: # ! 10389: sbf02: jmp er_273 # buffer size is too big ! 10390: #page ! 10391: # ! 10392: # BREAK ! 10393: # ! 10394: s$brk: # entry point ! 10395: movl $p$bks,r7 # set pcode for single char case ! 10396: movl $p$brk,r10 # pcode for multi-char case ! 10397: movl $p$bkd,r8 # pcode for expression case ! 10398: jsb patst # call common routine to build node ! 10399: .long er_069 # break argument is not string or expression ! 10400: jmp exixr # jump for next code word ! 10401: #page ! 10402: # ! 10403: # BREAKX ! 10404: # ! 10405: # BREAKX IS A COMPOUND PATTERN. SEE DESCRIPTION AT START ! 10406: # OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED. ! 10407: # ! 10408: s$bkx: # entry point ! 10409: movl $p$bks,r7 # pcode for single char argument ! 10410: movl $p$brk,r10 # pcode for multi-char argument ! 10411: movl $p$bxd,r8 # pcode for expression case ! 10412: jsb patst # call common routine to build node ! 10413: .long er_070 # breakx argument is not string or expression ! 10414: # ! 10415: # NOW HOOK BREAKX NODE ON AT FRONT END ! 10416: # ! 10417: movl r9,-(sp) # save ptr to break node ! 10418: movl $p$bkx,r7 # set pcode for breakx node ! 10419: jsb pbild # build it ! 10420: movl (sp),4*pthen(r9)# set break node as successor ! 10421: movl $p$alt,r7 # set pcode for alternation node ! 10422: jsb pbild # build (parm1=alt=breakx node) ! 10423: movl r9,r6 # save ptr to alternation node ! 10424: movl (sp),r9 # point to break node ! 10425: movl r6,4*pthen(r9) # set alternate node as successor ! 10426: jmp exits # exit with result on stack ! 10427: #page ! 10428: # ! 10429: # CHAR ! 10430: # ! 10431: s$chr: # entry point ! 10432: jsb gtsmi # convert arg to integer ! 10433: .long er_281 # char argument not integer ! 10434: .long schr1 # too big error exit ! 10435: cmpl r8,$cfp$a # see if out of range of host set ! 10436: bgequ schr1 ! 10437: movl $num01,r6 # if not set scblk allocation ! 10438: movl r8,r7 # save char code ! 10439: jsb alocs # allocate 1 bau scblk ! 10440: movl r9,r10 # copy scblk pointer ! 10441: movab cfp$f(r10),r10 # get set to stuff char ! 10442: movb r7,(r10)+ # stuff it ! 10443: clrl r10 # clear slop in xl ! 10444: jmp exixr # exit with scblk pointer ! 10445: # ! 10446: # HERE IF CHAR ARGUMENT IS OUT OF RANGE ! 10447: # ! 10448: schr1: jmp er_282 # char argument not in range ! 10449: #page ! 10450: # ! 10451: # CLEAR ! 10452: # ! 10453: s$clr: # entry point ! 10454: jsb xscni # initialize to scan argument ! 10455: .long er_071 # clear argument is not string ! 10456: .long sclr2 # jump if null ! 10457: # ! 10458: # LOOP TO SCAN OUT NAMES IN FIRST ARGUMENT. VARIABLES IN ! 10459: # THE LIST ARE FALGGED BY SETTING VRGET OF VRBLK TO ZERO. ! 10460: # ! 10461: sclr1: movl $ch$cm,r8 # set delimiter one = comma ! 10462: movl r8,r10 # delimiter two = comma ! 10463: jsb xscan # scan next variable name ! 10464: jsb gtnvr # locate vrblk ! 10465: .long er_072 # clear argument has null variable name ! 10466: clrl 4*vrget(r9) # else flag by zeroing vrget field ! 10467: tstl r6 # loop back if stopped by comma ! 10468: bnequ sclr1 ! 10469: # ! 10470: # HERE AFTER FLAGGING VARIABLES IN ARGUMENT LIST ! 10471: # ! 10472: sclr2: movl hshtb,r7 # point to start of hash table ! 10473: # ! 10474: # LOOP THROUGH SLOTS IN HASH TABLE ! 10475: # ! 10476: sclr3: cmpl r7,hshte # exit returning null if none left ! 10477: bnequ 0f ! 10478: jmp exnul ! 10479: 0: ! 10480: movl r7,r9 # else copy slot pointer ! 10481: addl2 $4,r7 # bump slot pointer ! 10482: subl2 $4*vrnxt,r9 # set offset to merge into loop ! 10483: # ! 10484: # LOOP THROUGH VRBLKS ON ONE HASH CHAIN ! 10485: # ! 10486: sclr4: movl 4*vrnxt(r9),r9 # point to next vrblk on chain ! 10487: beqlu sclr3 # jump for next bucket if chain end ! 10488: tstl 4*vrget(r9) # jump if not flagged ! 10489: bnequ sclr5 ! 10490: #page ! 10491: # ! 10492: # CLEAR (CONTINUED) ! 10493: # ! 10494: # HERE FOR FLAGGED VARIABLE, DO NOT SET VALUE TO NULL ! 10495: # ! 10496: jsb setvr # for flagged var, restore vrget ! 10497: jmp sclr4 # and loop back for next vrblk ! 10498: # ! 10499: # HERE TO SET VALUE OF A VARIABLE TO NULL ! 10500: # PRROTECTED VARIABLES (ARB, ETC) ARE EXEMPT ! 10501: # ! 10502: sclr5: cmpl 4*vrsto(r9),$b$vre # check for protected variable (reg05) ! 10503: beqlu sclr4 ! 10504: movl r9,r10 # copy vrblk pointer (reg05) ! 10505: # ! 10506: # LOOP TO LOCATE VALUE AT END OF POSSIBLE TRBLK CHAIN ! 10507: # ! 10508: sclr6: movl r10,r6 # save block pointer ! 10509: movl 4*vrval(r10),r10# load next value field ! 10510: cmpl (r10),$b$trt # loop back if trapped ! 10511: beqlu sclr6 ! 10512: # ! 10513: # NOW STORE THE NULL VALUE ! 10514: # ! 10515: movl r6,r10 # restore block pointer ! 10516: movl $nulls,4*vrval(r10) # store null constant value ! 10517: jmp sclr4 # loop back for next vrblk ! 10518: #page ! 10519: # ! 10520: # CODE ! 10521: # ! 10522: s$cod: # entry point ! 10523: movl (sp)+,r9 # load argument ! 10524: jsb gtcod # convert to code ! 10525: .long exfal # fail if conversion is impossible ! 10526: jmp exixr # else return code as result ! 10527: #page ! 10528: # ! 10529: # COLLECT ! 10530: # ! 10531: s$col: # entry point ! 10532: movl (sp)+,r9 # load argument ! 10533: jsb gtint # convert to integer ! 10534: .long er_073 # collect argument is not integer ! 10535: movl 4*icval(r9),r5 # load collect argument ! 10536: movl r5,clsvi # save collect argument ! 10537: clrl r7 # set no move up ! 10538: jsb gbcol # perform garbage collection ! 10539: movl dname,r6 # point to end of memory ! 10540: subl2 dnamp,r6 # subtract next location ! 10541: ashl $-2,r6,r6 # convert bytes to words ! 10542: movl r6,r5 # convert words available as integer ! 10543: subl2 clsvi,r5 # subtract argument ! 10544: bvc 0f ! 10545: jmp exfal ! 10546: 0: ! 10547: tstl r5 # fail if not enough ! 10548: bgeq 0f ! 10549: jmp exfal ! 10550: 0: ! 10551: addl2 clsvi,r5 # else recompute available ! 10552: jmp exint # and exit with integer result ! 10553: #page ! 10554: # ! 10555: # CONVERT ! 10556: # ! 10557: s$cnv: # entry point ! 10558: jsb gtstg # convert second argument to string ! 10559: .long er_074 # convert second argument is not string ! 10560: jsb flstg # fold lower case to upper case ! 10561: movl (sp),r10 # load first argument ! 10562: cmpl (r10),$b$pdt # jump if not program defined ! 10563: bnequ scv01 ! 10564: # ! 10565: # HERE FOR PROGRAM DEFINED DATATYPE ! 10566: # ! 10567: movl 4*pddfp(r10),r10# point to dfblk ! 10568: movl 4*dfnam(r10),r10# load datatype name ! 10569: jsb ident # compare with second arg ! 10570: .long exits # exit if ident with arg as result ! 10571: jmp exfal # else fail ! 10572: # ! 10573: # HERE IF NOT PROGRAM DEFINED DATATYPE ! 10574: # ! 10575: scv01: movl r9,-(sp) # save string argument ! 10576: movl $svctb,r10 # point to table of names to compare ! 10577: clrl r7 # initialize counter ! 10578: movl r6,r8 # save length of argument string ! 10579: # ! 10580: # LOOP THROUGH TABLE ENTRIES ! 10581: # ! 10582: scv02: movl (r10)+,r9 # load next table entry, bump pointer ! 10583: bnequ 0f # fail if zero marking end of list ! 10584: jmp exfal ! 10585: 0: ! 10586: cmpl r8,4*sclen(r9) # jump if wrong length ! 10587: beqlu 0f ! 10588: jmp scv05 ! 10589: 0: ! 10590: movl r10,cnvtp # else store table pointer ! 10591: movab cfp$f(r9),r9 # point to chars of table entry ! 10592: movl (sp),r10 # load pointer to string argument ! 10593: movab cfp$f(r10),r10 # point to chars of string arg ! 10594: movl r8,r6 # set number of chars to compare ! 10595: jsb sbcmc # compare, jump if no match ! 10596: .long scv04 ! 10597: .long scv04 ! 10598: #page ! 10599: # ! 10600: # CONVERT (CONTINUED) ! 10601: # ! 10602: # HERE WE HAVE A MATCH ! 10603: # ! 10604: scv03: movl r7,r10 # copy entry number ! 10605: addl2 $4,sp # pop string arg off stack ! 10606: movl (sp)+,r9 # load first argument ! 10607: casel r10,$0,$cnvtt # jump to appropriate routine ! 10608: 5: ! 10609: .word scv06-5b # string ! 10610: .word scv07-5b # integer ! 10611: .word scv09-5b # name ! 10612: .word scv10-5b # pattern ! 10613: .word scv11-5b # array ! 10614: .word scv19-5b # table ! 10615: .word scv25-5b # expression ! 10616: .word scv26-5b # code ! 10617: .word scv27-5b # numeric ! 10618: .word scv08-5b # real ! 10619: .word scv28-5b # buffer ! 10620: #esw # end of switch table ! 10621: # ! 10622: # HERE IF NO MATCH WITH TABLE ENTRY ! 10623: # ! 10624: scv04: movl cnvtp,r10 # restore table pointer, merge ! 10625: # ! 10626: # MERGE HERE IF LENGTHS DID NOT MATCH ! 10627: # ! 10628: scv05: incl r7 # bump entry number ! 10629: jmp scv02 # loop back to check next entry ! 10630: # ! 10631: # HERE TO CONVERT TO STRING ! 10632: # ! 10633: scv06: movl r9,-(sp) # replace string argument on stack ! 10634: jsb gtstg # convert to string ! 10635: .long exfal # fail if conversion not possible ! 10636: jmp exixr # else return string ! 10637: #page ! 10638: # ! 10639: # CONVERT (CONTINUED) ! 10640: # ! 10641: # HERE TO CONVERT TO INTEGER ! 10642: # ! 10643: scv07: jsb gtint # convert to integer ! 10644: .long exfal # fail if conversion not possible ! 10645: jmp exixr # else return integer ! 10646: # ! 10647: # HERE TO CONVERT TO REAL ! 10648: # ! 10649: scv08: jsb gtrea # convert to real ! 10650: .long exfal # fail if conversion not possible ! 10651: jmp exixr # else return real ! 10652: # ! 10653: # HERE TO CONVERT TO NAME ! 10654: # ! 10655: scv09: cmpl (r9),$b$nml # return if already a name ! 10656: bnequ 0f ! 10657: jmp exixr ! 10658: 0: ! 10659: jsb gtnvr # else try string to name convert ! 10660: .long exfal # fail if conversion not possible ! 10661: jmp exvnm # else exit building nmblk for vrblk ! 10662: # ! 10663: # HERE TO CONVERT TO PATTERN ! 10664: # ! 10665: scv10: jsb gtpat # convert to pattern ! 10666: .long exfal # fail if conversion not possible ! 10667: jmp exixr # else return pattern ! 10668: # ! 10669: # CONVERT TO ARRAY ! 10670: # ! 10671: scv11: jsb gtarr # get an array ! 10672: .long exfal # fail if not convertible ! 10673: jmp exsid # exit setting id field ! 10674: # ! 10675: # CONVERT TO TABLE ! 10676: # ! 10677: scv19: movl (r9),r6 # load first word of block ! 10678: movl r9,-(sp) # replace arblk pointer on stack ! 10679: cmpl r6,$b$tbt # return arg if already a table ! 10680: bnequ 0f ! 10681: jmp exits ! 10682: 0: ! 10683: cmpl r6,$b$art # else fail if not an array ! 10684: beqlu 0f ! 10685: jmp exfal ! 10686: 0: ! 10687: #page ! 10688: # ! 10689: # CONVERT (CONTINUED) ! 10690: # ! 10691: # HERE TO CONVERT AN ARRAY TO TABLE ! 10692: # ! 10693: cmpl 4*arndm(r9),$num02 # fail if not 2-dim array ! 10694: beqlu 0f ! 10695: jmp exfal ! 10696: 0: ! 10697: movl 4*ardm2(r9),r5 # load dim 2 ! 10698: subl2 intv2,r5 # subtract 2 to compare ! 10699: beql 0f # fail if dim2 not 2 ! 10700: jmp exfal ! 10701: 0: ! 10702: # ! 10703: # HERE WE HAVE AN ARBLK OF THE RIGHT SHAPE ! 10704: # ! 10705: movl 4*ardim(r9),r5 # load dim 1 (number of elements) ! 10706: movl r5,r6 # get as one word integer ! 10707: movl r6,r7 # copy to control loop ! 10708: addl2 $tbsi$,r6 # add space for standard fields ! 10709: moval 0[r6],r6 # convert length to bytes ! 10710: jsb alloc # allocate space for tbblk ! 10711: movl r9,r8 # copy tbblk pointer ! 10712: movl r9,-(sp) # save tbblk pointer ! 10713: movl $b$tbt,(r9)+ # store type word ! 10714: clrl (r9)+ # store zero for idval for now ! 10715: movl r6,(r9)+ # store length ! 10716: movl $nulls,(r9)+ # null initial lookup value ! 10717: # ! 10718: # LOOP TO INITIALIZE BUCKET PTRS TO POINT TO TABLE ! 10719: # ! 10720: scv20: movl r8,(r9)+ # set bucket ptr to point to tbblk ! 10721: sobgtr r7,scv20 # loop till all initialized ! 10722: movl $4*arvl2,r7 # set offset to first arblk element ! 10723: # ! 10724: # LOOP TO COPY ELEMENTS FROM ARRAY TO TABLE ! 10725: # ! 10726: scv21: movl 4*1(sp),r10 # point to arblk ! 10727: cmpl r7,4*arlen(r10) # jump if all moved ! 10728: beqlu scv24 ! 10729: addl2 r7,r10 # else point to current location ! 10730: addl2 $4*num02,r7 # bump offset ! 10731: movl (r10),r9 # load subscript name ! 10732: subl2 $4,r10 # adjust ptr to merge (trval=1+1) ! 10733: #page ! 10734: # ! 10735: # CONVERT (CONTINUED) ! 10736: # ! 10737: # LOOP TO CHASE DOWN TRBLK CHAIN FOR VALUE ! 10738: # ! 10739: scv22: movl 4*trval(r10),r10# point to next value ! 10740: cmpl (r10),$b$trt # loop back if trapped ! 10741: beqlu scv22 ! 10742: # ! 10743: # HERE WITH NAME IN XR, VALUE IN XL ! 10744: # ! 10745: scv23: movl r10,-(sp) # stack value ! 10746: movl 4*1(sp),r10 # load tbblk pointer ! 10747: jsb tfind # build teblk (note wb gt 0 by name) ! 10748: .long exfal # fail if acess fails ! 10749: movl (sp)+,4*teval(r10) # store value in teblk ! 10750: jmp scv21 # loop back for next element ! 10751: # ! 10752: # HERE AFTER MOVING ALL ELEMENTS TO TBBLK ! 10753: # ! 10754: scv24: movl (sp)+,r9 # load tbblk pointer ! 10755: addl2 $4,sp # pop arblk pointer ! 10756: jmp exsid # exit setting idval ! 10757: # ! 10758: # CONVERT TO EXPRESSION ! 10759: # ! 10760: scv25: jsb gtexp # convert to expression ! 10761: .long exfal # fail if conversion not possible ! 10762: jmp exixr # else return expression ! 10763: # ! 10764: # CONVERT TO CODE ! 10765: # ! 10766: scv26: jsb gtcod # convert to code ! 10767: .long exfal # fail if conversion is not possible ! 10768: jmp exixr # else return code ! 10769: # ! 10770: # CONVERT TO NUMERIC ! 10771: # ! 10772: scv27: jsb gtnum # convert to numeric ! 10773: .long exfal # fail if unconvertible ! 10774: jmp exixr # return number ! 10775: #page ! 10776: # ! 10777: # CONVERT TO BUFFER ! 10778: # ! 10779: scv28: movl r9,-(sp) # stack string for procedure ! 10780: jsb gtstg # convert to string ! 10781: .long exfal # fail if conversion not possible ! 10782: movl r9,r10 # save string pointer ! 10783: jsb alobf # allocate buffer of same size ! 10784: jsb apndb # copy in the string ! 10785: .long invalid$ # already string - cant fail to cnv ! 10786: .long invalid$ # must be enough room ! 10787: jmp exsid # exit setting idval field ! 10788: #page ! 10789: # ! 10790: # COPY ! 10791: # ! 10792: s$cop: # entry point ! 10793: jsb copyb # copy the block ! 10794: .long exits # return if no idval field ! 10795: jmp exsid # exit setting id value ! 10796: #page ! 10797: # ! 10798: # DATA ! 10799: # ! 10800: s$dat: # entry point ! 10801: jsb xscni # prepare to scan argument ! 10802: .long er_075 # data argument is not string ! 10803: .long er_076 # data argument is null ! 10804: # ! 10805: # SCAN OUT DATATYPE NAME ! 10806: # ! 10807: movl $ch$pp,r8 # delimiter one = left paren ! 10808: movl r8,r10 # delimiter two = left paren ! 10809: jsb xscan # scan datatype name ! 10810: tstl r6 # skip if left paren found ! 10811: bnequ sdat1 ! 10812: jmp er_077 # data argument is missing a left paren ! 10813: # ! 10814: # HERE AFTER SCANNING DATATYPE NAME ! 10815: # ! 10816: sdat1: movl 4*sclen(r9),r6 # get length ! 10817: jsb flstg # fold lower case to upper case ! 10818: movl r9,r10 # save name ptr ! 10819: movl 4*sclen(r9),r6 # get length ! 10820: movab 3+(4*scsi$)(r6),r6 # compute space needed ! 10821: bicl2 $3,r6 ! 10822: jsb alost # request static store for name ! 10823: movl r9,-(sp) # save datatype name ! 10824: jsb sbmvw # copy name to static ! 10825: movl (sp),r9 # get name ptr ! 10826: clrl r10 # scrub dud register ! 10827: jsb gtnvr # locate vrblk for datatype name ! 10828: .long er_078 # data argument has null datatype name ! 10829: movl r9,datdv # save vrblk pointer for datatype ! 10830: movl sp,datxs # store starting stack value ! 10831: clrl r7 # zero count of field names ! 10832: # ! 10833: # LOOP TO SCAN FIELD NAMES AND STACK VRBLK POINTERS ! 10834: # ! 10835: sdat2: movl $ch$rp,r8 # delimiter one = right paren ! 10836: movl $ch$cm,r10 # delimiter two = comma ! 10837: jsb xscan # scan next field name ! 10838: tstl r6 # jump if delimiter found ! 10839: bnequ sdat3 ! 10840: jmp er_079 # data argument is missing a right paren ! 10841: # ! 10842: # HERE AFTER SCANNING OUT ONE FIELD NAME ! 10843: # ! 10844: sdat3: jsb gtnvr # locate vrblk for field name ! 10845: .long er_080 # data argument has null field name ! 10846: movl r9,-(sp) # stack vrblk pointer ! 10847: incl r7 # increment counter ! 10848: cmpl r6,$num02 # loop back if stopped by comma ! 10849: beqlu sdat2 ! 10850: #page ! 10851: # ! 10852: # DATA (CONTINUED) ! 10853: # ! 10854: # NOW BUILD THE DFBLK ! 10855: # ! 10856: movl $dfsi$,r6 # set size of dfblk standard fields ! 10857: addl2 r7,r6 # add number of fields ! 10858: moval 0[r6],r6 # convert length to bytes ! 10859: movl r7,r8 # preserve no. of fields ! 10860: jsb alost # allocate space for dfblk ! 10861: movl r8,r7 # get no of fields ! 10862: movl datxs,r10 # point to start of stack ! 10863: movl (r10),r8 # load datatype name ! 10864: movl r9,(r10) # save dfblk pointer on stack ! 10865: movl $b$dfc,(r9)+ # store type word ! 10866: movl r7,(r9)+ # store number of fields (fargs) ! 10867: movl r6,(r9)+ # store length (dflen) ! 10868: subl2 $4*pddfs,r6 # compute pdblk length (for dfpdl) ! 10869: movl r6,(r9)+ # store pdblk length (dfpdl) ! 10870: movl r8,(r9)+ # store datatype name (dfnam) ! 10871: movl r7,r8 # copy number of fields ! 10872: # ! 10873: # LOOP TO MOVE FIELD NAME VRBLK POINTERS TO DFBLK ! 10874: # ! 10875: sdat4: movl -(r10),(r9)+ # move one field name vrblk pointer ! 10876: sobgtr r8,sdat4 # loop till all moved ! 10877: # ! 10878: # NOW DEFINE THE DATATYPE FUNCTION ! 10879: # ! 10880: movl r6,r8 # copy length of pdblk for later loop ! 10881: movl datdv,r9 # point to vrblk ! 10882: movl datxs,r10 # point back on stack ! 10883: movl (r10),r10 # load dfblk pointer ! 10884: jsb dffnc # define function ! 10885: #page ! 10886: # ! 10887: # DATA (CONTINUED) ! 10888: # ! 10889: # LOOP TO BUILD FFBLKS ! 10890: # ! 10891: # ! 10892: # NOTICE THAT THE FFBLKS ARE CONSTRUCTED IN REVERSE ORDER ! 10893: # SO THAT THE REQUIRED OFFSETS CAN BE OBTAINED FROM ! 10894: # SUCCESSIVE DECREMENTATION OF THE PDBLK LENGTH (IN WC). ! 10895: # ! 10896: sdat5: movl $4*ffsi$,r6 # set length of ffblk ! 10897: jsb alloc # allocate space for ffblk ! 10898: movl $b$ffc,(r9) # set type word ! 10899: movl $num01,4*fargs(r9) # store fargs (always one) ! 10900: movl datxs,r10 # point back on stack ! 10901: movl (r10),4*ffdfp(r9)# copy dfblk ptr to ffblk ! 10902: subl2 $4,r8 # decrement old dfpdl to get next ofs ! 10903: movl r8,4*ffofs(r9) # set offset to this field ! 10904: clrl 4*ffnxt(r9) # tentatively set zero forward ptr ! 10905: movl r9,r10 # copy ffblk pointer for dffnc ! 10906: movl (sp),r9 # load vrblk pointer for field ! 10907: movl 4*vrfnc(r9),r9 # load current function pointer ! 10908: cmpl (r9),$b$ffc # skip if not currently a field func ! 10909: bnequ sdat6 ! 10910: # ! 10911: # HERE WE MUST CHAIN AN OLD FFBLK PTR TO PRESERVE IT IN THE ! 10912: # CASE OF MULTIPLE FIELD FUNCTIONS WITH THE SAME NAME ! 10913: # ! 10914: movl r9,4*ffnxt(r10) # link new ffblk to previous chain ! 10915: # ! 10916: # MERGE HERE TO DEFINE FIELD FUNCTION ! 10917: # ! 10918: sdat6: movl (sp)+,r9 # load vrblk pointer ! 10919: jsb dffnc # define field function ! 10920: cmpl sp,datxs # loop back till all done ! 10921: bnequ sdat5 ! 10922: addl2 $4,sp # pop dfblk pointer ! 10923: jmp exnul # return with null result ! 10924: #page ! 10925: # ! 10926: # DATATYPE ! 10927: # ! 10928: s$dtp: # entry point ! 10929: movl (sp)+,r9 # load argument ! 10930: jsb dtype # get datatype ! 10931: jmp exixr # and return it as result ! 10932: #page ! 10933: # ! 10934: # DATE ! 10935: # ! 10936: s$dte: # entry point ! 10937: jsb sysdt # call system date routine ! 10938: movl 4*1(r10),r6 # load length for sbstr ! 10939: bnequ 0f # return null if length is zero ! 10940: jmp exnul ! 10941: 0: ! 10942: clrl r7 # set zero offset ! 10943: jsb sbstr # use sbstr to build scblk ! 10944: jmp exixr # return date string ! 10945: #page ! 10946: # ! 10947: # DEFINE ! 10948: # ! 10949: s$def: # entry point ! 10950: movl (sp)+,r9 # load second argument ! 10951: clrl deflb # zero label pointer in case null ! 10952: cmpl r9,$nulls # jump if null second argument ! 10953: beqlu sdf01 ! 10954: jsb gtnvr # else find vrblk for label ! 10955: .long sdf13 # jump if not a variable name ! 10956: movl r9,deflb # else set specified entry ! 10957: # ! 10958: # SCAN FUNCTION NAME ! 10959: # ! 10960: sdf01: jsb xscni # prepare to scan first argument ! 10961: .long er_081 # define first argument is not string ! 10962: .long er_082 # define first argument is null ! 10963: movl $ch$pp,r8 # delimiter one = left paren ! 10964: movl r8,r10 # delimiter two = left paren ! 10965: jsb xscan # scan out function name ! 10966: tstl r6 # jump if left paren found ! 10967: bnequ sdf02 ! 10968: jmp er_083 # define first argument is missing a left paren ! 10969: # ! 10970: # HERE AFTER SCANNING OUT FUNCTION NAME ! 10971: # ! 10972: sdf02: jsb gtnvr # get variable name ! 10973: .long er_084 # define first argument has null function name ! 10974: movl r9,defvr # save vrblk pointer for function nam ! 10975: clrl r7 # zero count of arguments ! 10976: movl sp,defxs # save initial stack pointer ! 10977: tstl deflb # jump if second argument given ! 10978: bnequ sdf03 ! 10979: movl r9,deflb # else default is function name ! 10980: # ! 10981: # LOOP TO SCAN ARGUMENT NAMES AND STACK VRBLK POINTERS ! 10982: # ! 10983: sdf03: movl $ch$rp,r8 # delimiter one = right paren ! 10984: movl $ch$cm,r10 # delimiter two = comma ! 10985: jsb xscan # scan out next argument name ! 10986: tstl r6 # skip if delimiter found ! 10987: bnequ sdf04 ! 10988: jmp er_085 # null arg name or missing ) in define first arg. ! 10989: #page ! 10990: # ! 10991: # DEFINE (CONTINUED) ! 10992: # ! 10993: # HERE AFTER SCANNING AN ARGUMENT NAME ! 10994: # ! 10995: sdf04: cmpl r9,$nulls # skip if non-null ! 10996: bnequ sdf05 ! 10997: tstl r7 # ignore null if case of no arguments ! 10998: beqlu sdf06 ! 10999: # ! 11000: # HERE AFTER DEALING WITH THE CASE OF NO ARGUMENTS ! 11001: # ! 11002: sdf05: jsb gtnvr # get vrblk pointer ! 11003: .long sdf03 # loop back to ignore null name ! 11004: movl r9,-(sp) # stack argument vrblk pointer ! 11005: incl r7 # increment counter ! 11006: cmpl r6,$num02 # loop back if stopped by a comma ! 11007: beqlu sdf03 ! 11008: # ! 11009: # HERE AFTER SCANNING OUT FUNCTION ARGUMENT NAMES ! 11010: # ! 11011: sdf06: movl r7,defna # save number of arguments ! 11012: clrl r7 # zero count of locals ! 11013: # ! 11014: # LOOP TO SCAN LOCAL NAMES AND STACK VRBLK POINTERS ! 11015: # ! 11016: sdf07: movl $ch$cm,r8 # set delimiter one = comma ! 11017: movl r8,r10 # set delimiter two = comma ! 11018: jsb xscan # scan out next local name ! 11019: cmpl r9,$nulls # skip if non-null ! 11020: bnequ sdf08 ! 11021: tstl r7 # ignore null if case of no locals ! 11022: beqlu sdf09 ! 11023: # ! 11024: # HERE AFTER SCANNING OUT A LOCAL NAME ! 11025: # ! 11026: sdf08: jsb gtnvr # get vrblk pointer ! 11027: .long sdf07 # loop back to ignore null name ! 11028: incl r7 # if ok, increment count ! 11029: movl r9,-(sp) # stack vrblk pointer ! 11030: tstl r6 # loop back if stopped by a comma ! 11031: bnequ sdf07 ! 11032: #page ! 11033: # ! 11034: # DEFINE (CONTINUED) ! 11035: # ! 11036: # HERE AFTER SCANNING LOCALS, BUILD PFBLK ! 11037: # ! 11038: sdf09: movl r7,r6 # copy count of locals ! 11039: addl2 defna,r6 # add number of arguments ! 11040: movl r6,r8 # set sum args+locals as loop count ! 11041: addl2 $pfsi$,r6 # add space for standard fields ! 11042: moval 0[r6],r6 # convert length to bytes ! 11043: jsb alloc # allocate space for pfblk ! 11044: movl r9,r10 # save pointer to pfblk ! 11045: movl $b$pfc,(r9)+ # store first word ! 11046: movl defna,(r9)+ # store number of arguments ! 11047: movl r6,(r9)+ # store length (pflen) ! 11048: movl defvr,(r9)+ # store vrblk ptr for function name ! 11049: movl r7,(r9)+ # store number of locals ! 11050: clrl (r9)+ # deal with label later ! 11051: clrl (r9)+ # zero pfctr ! 11052: clrl (r9)+ # zero pfrtr ! 11053: tstl r8 # skip if no args or locals ! 11054: beqlu sdf11 ! 11055: movl r10,r6 # keep pfblk pointer ! 11056: movl defxs,r10 # point before arguments ! 11057: # get count of args+locals for loop ! 11058: # ! 11059: # LOOP TO MOVE LOCALS AND ARGS TO PFBLK ! 11060: # ! 11061: sdf10: movl -(r10),(r9)+ # store one entry and bump pointers ! 11062: sobgtr r8,sdf10 # loop till all stored ! 11063: movl r6,r10 # recover pfblk pointer ! 11064: #page ! 11065: # ! 11066: # DEFINE (CONTINUED) ! 11067: # ! 11068: # NOW DEAL WITH LABEL ! 11069: # ! 11070: sdf11: movl defxs,sp # pop stack ! 11071: movl deflb,r9 # point to vrblk for label ! 11072: movl 4*vrlbl(r9),r9 # load label pointer ! 11073: cmpl (r9),$b$trt # skip if not trapped ! 11074: bnequ sdf12 ! 11075: movl 4*trlbl(r9),r9 # else point to real label ! 11076: # ! 11077: # HERE AFTER LOCATING REAL LABEL POINTER ! 11078: # ! 11079: sdf12: cmpl r9,$stndl # jump if label is not defined ! 11080: beqlu sdf13 ! 11081: movl r9,4*pfcod(r10) # else store label pointer ! 11082: movl defvr,r9 # point back to vrblk for function ! 11083: jsb dffnc # define function ! 11084: jmp exnul # and exit returning null ! 11085: # ! 11086: # HERE FOR ERRONEOUS LABEL ! 11087: # ! 11088: sdf13: jmp er_086 # define function entry point is not defined label ! 11089: #page ! 11090: # ! 11091: # DETACH ! 11092: # ! 11093: s$det: # entry point ! 11094: movl (sp)+,r9 # load argument ! 11095: jsb gtvar # locate variable ! 11096: .long er_087 # detach argument is not appropriate name ! 11097: jsb dtach # detach i/o association from name ! 11098: jmp exnul # return null result ! 11099: #page ! 11100: # ! 11101: # DIFFER ! 11102: # ! 11103: s$dif: # entry point ! 11104: movl (sp)+,r9 # load second argument ! 11105: movl (sp)+,r10 # load first argument ! 11106: jsb ident # call ident comparison routine ! 11107: .long exfal # fail if ident ! 11108: jmp exnul # return null if differ ! 11109: #page ! 11110: # ! 11111: # DUMP ! 11112: # ! 11113: s$dmp: # entry point ! 11114: jsb gtsmi # load dump arg as small integer ! 11115: .long er_088 # dump argument is not integer ! 11116: .long er_089 # dump argument is negative or too large ! 11117: jsb dumpr # else call dump routine ! 11118: jmp exnul # and return null as result ! 11119: #page ! 11120: # ! 11121: # DUPL ! 11122: # ! 11123: s$dup: # entry point ! 11124: jsb gtsmi # get second argument as small intege ! 11125: .long er_090 # dupl second argument is not integer ! 11126: .long sdup7 # jump if negative ot too big ! 11127: movl r9,r7 # save duplication factor ! 11128: jsb gtstg # get first arg as string ! 11129: .long sdup4 # jump if not a string ! 11130: # ! 11131: # HERE FOR CASE OF DUPLICATION OF A STRING ! 11132: # ! 11133: movl r6,r5 # acquire length as integer ! 11134: movl r5,dupsi # save for the moment ! 11135: movl r7,r5 # get duplication factor as integer ! 11136: mull2 dupsi,r5 # form product ! 11137: bvs sdup3 ! 11138: tstl r5 # return null if result length = 0 ! 11139: bneq 0f ! 11140: jmp exnul ! 11141: 0: ! 11142: movl r5,r6 # get as addr integer, check ovflo ! 11143: bgeq 0f ! 11144: jmp sdup3 ! 11145: 0: ! 11146: # ! 11147: # MERGE HERE WITH RESULT LENGTH IN WA ! 11148: # ! 11149: sdup1: movl r9,r10 # save string pointer ! 11150: jsb alocs # allocate space for string ! 11151: movl r9,-(sp) # save as result pointer ! 11152: movl r10,r8 # save pointer to argument string ! 11153: movab cfp$f(r9),r9 # prepare to store chars of result ! 11154: # set counter to control loop ! 11155: # ! 11156: # LOOP THROUGH DUPLICATIONS ! 11157: # ! 11158: sdup2: movl r8,r10 # point back to argument string ! 11159: movl 4*sclen(r10),r6 # get number of characters ! 11160: movab cfp$f(r10),r10 # point to chars in argument string ! 11161: jsb sbmvc # move characters to result string ! 11162: sobgtr r7,sdup2 # loop till all duplications done ! 11163: jmp exits # then exit for next code word ! 11164: #page ! 11165: # ! 11166: # DUPL (CONTINUED) ! 11167: # ! 11168: # HERE IF TOO LARGE, SET MAX LENGTH AND LET ALOCS CATCH IT ! 11169: # ! 11170: sdup3: movl dname,r6 # set impossible length for alocs ! 11171: jmp sdup1 # merge back ! 11172: # ! 11173: # HERE IF NOT A STRING ! 11174: # ! 11175: sdup4: jsb gtpat # convert argument to pattern ! 11176: .long er_091 # dupl first argument is not string or pattern ! 11177: # ! 11178: # HERE TO DUPLICATE A PATTERN ARGUMENT ! 11179: # ! 11180: movl r9,-(sp) # store pattern on stack ! 11181: movl $ndnth,r9 # start off with null pattern ! 11182: tstl r7 # null pattern is result if dupfac=0 ! 11183: beqlu sdup6 ! 11184: movl r7,-(sp) # preserve loop count ! 11185: # ! 11186: # LOOP TO DUPLICATE BY SUCCESSIVE CONCATENATION ! 11187: # ! 11188: sdup5: movl r9,r10 # copy current value as right argumnt ! 11189: movl 4*1(sp),r9 # get a new copy of left ! 11190: jsb pconc # concatenate ! 11191: decl (sp) # count down ! 11192: bnequ sdup5 # loop ! 11193: addl2 $4,sp # pop loop count ! 11194: # ! 11195: # HERE TO EXIT AFTER CONSTRUCTING PATTERN ! 11196: # ! 11197: sdup6: movl r9,(sp) # store result on stack ! 11198: jmp exits # exit with result on stack ! 11199: # ! 11200: # FAIL IF SECOND ARG IS OUT OF RANGE ! 11201: # ! 11202: sdup7: addl2 $4,sp # pop first argument ! 11203: jmp exfal # fail ! 11204: #page ! 11205: # ! 11206: # EJECT ! 11207: # ! 11208: s$ejc: # entry point ! 11209: jsb iofcb # call fcblk routine ! 11210: .long er_092 # eject argument is not a suitable name ! 11211: .long sejc1 # null argument ! 11212: jsb sysef # call eject file function ! 11213: .long er_093 # eject file does not exist ! 11214: .long er_094 # eject file does not permit page eject ! 11215: .long er_095 # eject caused non-recoverable output error ! 11216: jmp exnul # return null as result ! 11217: # ! 11218: # HERE TO EJECT STANDARD OUTPUT FILE ! 11219: # ! 11220: sejc1: jsb sysep # call routine to eject printer ! 11221: jmp exnul # exit with null result ! 11222: #page ! 11223: # ! 11224: # ENDFILE ! 11225: # ! 11226: s$enf: # entry point ! 11227: jsb iofcb # call fcblk routine ! 11228: .long er_096 # endfile argument is not a suitable name ! 11229: .long er_097 # endfile argument is null ! 11230: jsb sysen # call endfile routine ! 11231: .long er_098 # endfile file does not exist ! 11232: .long er_099 # endfile file does not permit endfile ! 11233: .long er_100 # endfile caused non-recoverable output error ! 11234: movl r10,r7 # remember vrblk ptr from iofcb call ! 11235: # ! 11236: # LOOP TO FIND TRTRF BLOCK ! 11237: # ! 11238: senf1: movl r10,r9 # copy pointer ! 11239: movl 4*trval(r9),r9 # chain along ! 11240: cmpl (r9),$b$trt # skip out if chain end ! 11241: beqlu 0f ! 11242: jmp exnul ! 11243: 0: ! 11244: cmpl 4*trtyp(r9),$trtfc # loop if not found ! 11245: bnequ senf1 ! 11246: movl 4*trval(r9),4*trval(r10) # remove trtrf ! 11247: movl 4*trtrf(r9),enfch# point to head of iochn ! 11248: movl 4*trfpt(r9),r8 # point to fcblk ! 11249: movl r7,r9 # filearg1 vrblk from iofcb ! 11250: jsb setvr # reset it ! 11251: movl $r$fcb,r10 # ptr to head of fcblk chain ! 11252: subl2 $4*num02,r10 # adjust ready to enter loop ! 11253: # ! 11254: # FIND FCBLK ! 11255: # ! 11256: senf2: movl r10,r9 # copy ptr ! 11257: movl 4*2(r10),r10 # get next link ! 11258: beqlu senf4 # stop if chain end ! 11259: cmpl 4*3(r10),r8 # jump if fcblk found ! 11260: beqlu senf3 ! 11261: jmp senf2 # loop ! 11262: # ! 11263: # REMOVE FCBLK ! 11264: # ! 11265: senf3: movl 4*2(r10),4*2(r9)# delete fcblk from chain ! 11266: # ! 11267: # LOOP WHICH DETACHES ALL VBLS ON IOCHN CHAIN ! 11268: # ! 11269: senf4: movl enfch,r10 # get chain head ! 11270: bnequ 0f # finished if chain end ! 11271: jmp exnul ! 11272: 0: ! 11273: movl 4*trtrf(r10),enfch # chain along ! 11274: movl 4*ionmo(r10),r6 # name offset ! 11275: movl 4*ionmb(r10),r10# name base ! 11276: jsb dtach # detach name ! 11277: jmp senf4 # loop till done ! 11278: #page ! 11279: # ! 11280: # EQ ! 11281: # ! 11282: s$eqf: # entry point ! 11283: jsb acomp # call arithmetic comparison routine ! 11284: .long er_101 # eq first argument is not numeric ! 11285: .long er_102 # eq second argument is not numeric ! 11286: .long exfal # fail if lt ! 11287: .long exnul # return null if eq ! 11288: .long exfal # fail if gt ! 11289: #page ! 11290: # ! 11291: # EVAL ! 11292: # ! 11293: s$evl: # entry point ! 11294: movl (sp)+,r9 # load argument ! 11295: jsb gtexp # convert to expression ! 11296: .long er_103 # eval argument is not expression ! 11297: movl (r3)+,r8 # load next code word ! 11298: cmpl r8,$ofne$ # jump if called by value ! 11299: bnequ sevl1 ! 11300: movl r3,r10 # copy code pointer ! 11301: movl (r10),r6 # get next code word ! 11302: cmpl r6,$ornm$ # by name unless expression ! 11303: bnequ sevl2 ! 11304: tstl 4*1(sp) # jump if by name ! 11305: bnequ sevl2 ! 11306: # ! 11307: # HERE IF CALLED BY VALUE ! 11308: # ! 11309: sevl1: clrl r7 # set flag for by value ! 11310: movl r8,-(sp) # save code word ! 11311: jsb evalx # evaluate expression by value ! 11312: .long exfal # fail if evaluation fails ! 11313: movl r9,r10 # copy result ! 11314: movl (sp),r9 # reload next code word ! 11315: movl r10,(sp) # stack result ! 11316: movl (r9),r11 # jump to execute next code word ! 11317: jmp (r11) ! 11318: # ! 11319: # HERE IF CALLED BY NAME ! 11320: # ! 11321: sevl2: movl $num01,r7 # set flag for by name ! 11322: jsb evalx # evaluate expression by name ! 11323: .long exfal # fail if evaluation fails ! 11324: jmp exnam # exit with name ! 11325: #page ! 11326: # ! 11327: # EXIT ! 11328: # ! 11329: s$ext: # entry point ! 11330: clrl r7 # clear amount of static shift ! 11331: jsb gbcol # compact memory by collecting ! 11332: jsb gtstg # convert arg to string ! 11333: .long er_104 # exit argument is not suitable integer or string ! 11334: movl r9,r10 # copy string ptr ! 11335: jsb gtint # check it is integer ! 11336: .long sext1 # skip if unconvertible ! 11337: clrl r10 # note it is integer ! 11338: movl 4*icval(r9),r5 # get integer arg ! 11339: movl r$fcb,r7 # get fcblk chain header ! 11340: # ! 11341: # MERGE TO CALL OSINT EXIT ROUTINE ! 11342: # ! 11343: sext1: movl $headv,r9 # point to v.v string ! 11344: jsb sysxi # call external routine ! 11345: .long er_105 # exit action not available in this implementation ! 11346: .long er_106 # exit action caused irrecoverable error ! 11347: tstl r5 # return if argument 0 ! 11348: bneq 0f ! 11349: jmp exnul ! 11350: 0: ! 11351: clrl gbcnt # resuming execution so reset ! 11352: tstl r5 # skip if positive ! 11353: bgtr sext2 ! 11354: mnegl r5,r5 # make positive ! 11355: # ! 11356: # CHECK FOR OPTION RESPECIFICATION ! 11357: # ! 11358: sext2: movl r5,r8 # get value in work reg ! 11359: cmpl r8,$num03 # skip if was 3 ! 11360: beqlu sext3 ! 11361: movl r8,-(sp) # save value ! 11362: clrl r8 # set to read options ! 11363: jsb prpar # read syspp options ! 11364: movl (sp)+,r8 # restore value ! 11365: # ! 11366: # DEAL WITH HEADER OPTION (FIDDLED BY PRPAR) ! 11367: # ! 11368: sext3: movl sp,headp # assume no headers ! 11369: cmpl r8,$num01 # skip if not 1 ! 11370: bnequ sext4 ! 11371: clrl headp # request header printing ! 11372: # ! 11373: # ALMOST READY TO RESUME RUNNING ! 11374: # ! 11375: sext4: jsb systm # get execution time start (sgd11) ! 11376: movl r5,timsx # save as initial time ! 11377: movl kvstc,r5 # reset to ensure ... ! 11378: movl r5,kvstl # ... correct execution stats ! 11379: jmp exnul # resume execution ! 11380: #page ! 11381: # ! 11382: # FIELD ! 11383: # ! 11384: s$fld: # entry point ! 11385: jsb gtsmi # get second argument (field number) ! 11386: .long er_107 # field second argument is not integer ! 11387: .long exfal # fail if out of range ! 11388: movl r9,r7 # else save integer value ! 11389: movl (sp)+,r9 # load first argument ! 11390: jsb gtnvr # point to vrblk ! 11391: .long sfld1 # jump (error) if not variable name ! 11392: movl 4*vrfnc(r9),r9 # else point to function block ! 11393: cmpl (r9),$b$dfc # error if not datatype function ! 11394: bnequ sfld1 ! 11395: # ! 11396: # HERE IF FIRST ARGUMENT IS A DATATYPE FUNCTION NAME ! 11397: # ! 11398: tstl r7 # fail if argument number is zero ! 11399: bnequ 0f ! 11400: jmp exfal ! 11401: 0: ! 11402: cmpl r7,4*fargs(r9) # fail if too large ! 11403: blequ 0f ! 11404: jmp exfal ! 11405: 0: ! 11406: moval 0[r7],r7 # else convert to byte offset ! 11407: addl2 r7,r9 # point to field name ! 11408: movl 4*dfflb(r9),r9 # load vrblk pointer ! 11409: jmp exvnm # exit to build nmblk ! 11410: # ! 11411: # HERE FOR BAD FIRST ARGUMENT ! 11412: # ! 11413: sfld1: jmp er_108 # field first argument is not datatype name ! 11414: #page ! 11415: # ! 11416: # FENCE ! 11417: # ! 11418: s$fnc: # entry point ! 11419: movl $p$fnc,r7 # set pcode for p$fnc ! 11420: clrl r9 # p0blk ! 11421: jsb pbild # build p$fnc node ! 11422: movl r9,r10 # save pointer to it ! 11423: movl (sp)+,r9 # get argument ! 11424: jsb gtpat # convert to pattern ! 11425: .long er_259 # fence argument is not pattern ! 11426: jsb pconc # concatenate to p$fnc node ! 11427: movl r9,r10 # save ptr to concatenated pattern ! 11428: movl $p$fna,r7 # set for p$fna pcode ! 11429: clrl r9 # p0blk ! 11430: jsb pbild # construct p$fna node ! 11431: movl r10,4*pthen(r9) # set pattern as pthen ! 11432: movl r9,-(sp) # set as result ! 11433: jmp exits # do next code word ! 11434: #page ! 11435: # ! 11436: # GE ! 11437: # ! 11438: s$gef: # entry point ! 11439: jsb acomp # call arithmetic comparison routine ! 11440: .long er_109 # ge first argument is not numeric ! 11441: .long er_110 # ge second argument is not numeric ! 11442: .long exfal # fail if lt ! 11443: .long exnul # return null if eq ! 11444: .long exnul # return null if gt ! 11445: #page ! 11446: # ! 11447: # GT ! 11448: # ! 11449: s$gtf: # entry point ! 11450: jsb acomp # call arithmetic comparison routine ! 11451: .long er_111 # gt first argument is not numeric ! 11452: .long er_112 # gt second argument is not numeric ! 11453: .long exfal # fail if lt ! 11454: .long exfal # fail if eq ! 11455: .long exnul # return null if gt ! 11456: #page ! 11457: # ! 11458: # HOST ! 11459: # ! 11460: s$hst: # entry point ! 11461: movl (sp)+,r9 # get third arg ! 11462: movl (sp)+,r10 # get second arg ! 11463: movl (sp)+,r6 # get first arg ! 11464: jsb syshs # enter syshs routine ! 11465: .long er_254 # erroneous argument for host ! 11466: .long er_255 # error during execution of host ! 11467: .long shst1 # store host string ! 11468: .long exnul # return null result ! 11469: .long exixr # return xr ! 11470: .long exfal # fail return ! 11471: # ! 11472: # RETURN HOST STRING ! 11473: # ! 11474: shst1: tstl r10 # null string if syshs uncooperative ! 11475: bnequ 0f ! 11476: jmp exnul ! 11477: 0: ! 11478: movl 4*sclen(r10),r6 # length ! 11479: clrl r7 # zero offset ! 11480: jsb sbstr # build copy of string ! 11481: movl r9,-(sp) # stack the result ! 11482: jmp exits # return result on stack ! 11483: #page ! 11484: # ! 11485: # IDENT ! 11486: # ! 11487: s$idn: # entry point ! 11488: movl (sp)+,r9 # load second argument ! 11489: movl (sp)+,r10 # load first argument ! 11490: jsb ident # call ident comparison routine ! 11491: .long exnul # return null if ident ! 11492: jmp exfal # fail if differ ! 11493: #page ! 11494: # ! 11495: # INPUT ! 11496: # ! 11497: s$inp: # entry point ! 11498: clrl r7 # input flag ! 11499: jsb ioput # call input/output assoc. routine ! 11500: .long er_113 # input third argument is not a string ! 11501: .long er_114 # inappropriate second argument for input ! 11502: .long er_115 # inappropriate first argument for input ! 11503: .long er_116 # inappropriate file specification for input ! 11504: .long exfal # fail if file does not exist ! 11505: .long er_117 # input file cannot be read ! 11506: jmp exnul # return null string ! 11507: #page ! 11508: # ! 11509: # INSERT ! 11510: # ! 11511: s$ins: # entry point ! 11512: movl (sp)+,r10 # get string arg ! 11513: jsb gtsmi # get replace length ! 11514: .long er_277 # insert third argument not integer ! 11515: .long exfal # fail if out of range ! 11516: movl r8,r7 # copy to proper reg ! 11517: jsb gtsmi # get replace position ! 11518: .long er_278 # insert second argument not integer ! 11519: .long exfal # fail if out of range ! 11520: tstl r8 # fail if zero ! 11521: bnequ 0f ! 11522: jmp exfal ! 11523: 0: ! 11524: decl r8 # decrement to get offset ! 11525: movl r8,r6 # put in proper register ! 11526: movl (sp)+,r9 # get buffer ! 11527: cmpl (r9),$b$bct # press on if type ok ! 11528: beqlu sins1 ! 11529: jmp er_279 # insert first argument not buffer ! 11530: # ! 11531: # HERE WHEN EVERYTHING LOADED UP ! 11532: # ! 11533: sins1: jsb insbf # call to insert ! 11534: .long er_280 # insert fourth argument not a string ! 11535: .long exfal # fail if out of range ! 11536: jmp exnul # else ok - exit with null ! 11537: #page ! 11538: # ! 11539: # INTEGER ! 11540: # ! 11541: s$int: # entry point ! 11542: movl (sp)+,r9 # load argument ! 11543: jsb gtnum # convert to numeric ! 11544: .long exfal # fail if non-numeric ! 11545: cmpl r6,$b$icl # return null if integer ! 11546: bnequ 0f ! 11547: jmp exnul ! 11548: 0: ! 11549: jmp exfal # fail if real ! 11550: #page ! 11551: # ! 11552: # ITEM ! 11553: # ! 11554: # ITEM DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT ! 11555: # WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED. ! 11556: # ! 11557: s$itm: # entry point ! 11558: # ! 11559: # DEAL WITH CASE OF NO ARGS ! 11560: # ! 11561: tstl r6 # jump if at least one arg ! 11562: bnequ sitm1 ! 11563: movl $nulls,-(sp) # else supply garbage null arg ! 11564: movl $num01,r6 # and fix argument count ! 11565: # ! 11566: # CHECK FOR NAME/VALUE CASES ! 11567: # ! 11568: sitm1: movl r3,r9 # get current code pointer ! 11569: movl (r9),r10 # load next code word ! 11570: decl r6 # get number of subscripts ! 11571: movl r6,r9 # copy for arref ! 11572: cmpl r10,$ofne$ # jump if called by name ! 11573: beqlu sitm2 ! 11574: # ! 11575: # HERE IF CALLED BY VALUE ! 11576: # ! 11577: clrl r7 # set code for call by value ! 11578: jmp arref # off to array reference routine ! 11579: # ! 11580: # HERE FOR CALL BY NAME ! 11581: # ! 11582: sitm2: movl sp,r7 # set code for call by name ! 11583: movl (r3)+,r6 # load and ignore ofne$ call ! 11584: jmp arref # off to array reference routine ! 11585: #page ! 11586: # ! 11587: # LE ! 11588: # ! 11589: s$lef: # entry point ! 11590: jsb acomp # call arithmetic comparison routine ! 11591: .long er_118 # le first argument is not numeric ! 11592: .long er_119 # le second argument is not numeric ! 11593: .long exnul # return null if lt ! 11594: .long exnul # return null if eq ! 11595: .long exfal # fail if gt ! 11596: #page ! 11597: # ! 11598: # LEN ! 11599: # ! 11600: s$len: # entry point ! 11601: movl $p$len,r7 # set pcode for integer arg case ! 11602: movl $p$lnd,r6 # set pcode for expr arg case ! 11603: jsb patin # call common routine to build node ! 11604: .long er_120 # len argument is not integer or expression ! 11605: .long er_121 # len argument is negative or too large ! 11606: jmp exixr # return pattern node ! 11607: #page ! 11608: # ! 11609: # LEQ ! 11610: # ! 11611: s$leq: # entry point ! 11612: jsb lcomp # call string comparison routine ! 11613: .long er_122 # leq first argument is not string ! 11614: .long er_123 # leq second argument is not string ! 11615: .long exfal # fail if llt ! 11616: .long exnul # return null if leq ! 11617: .long exfal # fail if lgt ! 11618: #page ! 11619: # ! 11620: # LGE ! 11621: # ! 11622: s$lge: # entry point ! 11623: jsb lcomp # call string comparison routine ! 11624: .long er_124 # lge first argument is not string ! 11625: .long er_125 # lge second argument is not string ! 11626: .long exfal # fail if llt ! 11627: .long exnul # return null if leq ! 11628: .long exnul # return null if lgt ! 11629: #page ! 11630: # ! 11631: # LGT ! 11632: # ! 11633: s$lgt: # entry point ! 11634: jsb lcomp # call string comparison routine ! 11635: .long er_126 # lgt first argument is not string ! 11636: .long er_127 # lgt second argument is not string ! 11637: .long exfal # fail if llt ! 11638: .long exfal # fail if leq ! 11639: .long exnul # return null if lgt ! 11640: #page ! 11641: # ! 11642: # LLE ! 11643: # ! 11644: s$lle: # entry point ! 11645: jsb lcomp # call string comparison routine ! 11646: .long er_128 # lle first argument is not string ! 11647: .long er_129 # lle second argument is not string ! 11648: .long exnul # return null if llt ! 11649: .long exnul # return null if leq ! 11650: .long exfal # fail if lgt ! 11651: #page ! 11652: # ! 11653: # LLT ! 11654: # ! 11655: s$llt: # entry point ! 11656: jsb lcomp # call string comparison routine ! 11657: .long er_130 # llt first argument is not string ! 11658: .long er_131 # llt second argument is not string ! 11659: .long exnul # return null if llt ! 11660: .long exfal # fail if leq ! 11661: .long exfal # fail if lgt ! 11662: #page ! 11663: # ! 11664: # LNE ! 11665: # ! 11666: s$lne: # entry point ! 11667: jsb lcomp # call string comparison routine ! 11668: .long er_132 # lne first argument is not string ! 11669: .long er_133 # lne second argument is not string ! 11670: .long exnul # return null if llt ! 11671: .long exfal # fail if leq ! 11672: .long exnul # return null if lgt ! 11673: #page ! 11674: # ! 11675: # LOCAL ! 11676: # ! 11677: s$loc: # entry point ! 11678: jsb gtsmi # get second argument (local number) ! 11679: .long er_134 # local second argument is not integer ! 11680: .long exfal # fail if out of range ! 11681: movl r9,r7 # save local number ! 11682: movl (sp)+,r9 # load first argument ! 11683: jsb gtnvr # point to vrblk ! 11684: .long sloc1 # jump if not variable name ! 11685: movl 4*vrfnc(r9),r9 # else load function pointer ! 11686: cmpl (r9),$b$pfc # jump if not program defined ! 11687: bnequ sloc1 ! 11688: # ! 11689: # HERE IF WE HAVE A PROGRAM DEFINED FUNCTION NAME ! 11690: # ! 11691: tstl r7 # fail if second arg is zero ! 11692: bnequ 0f ! 11693: jmp exfal ! 11694: 0: ! 11695: cmpl r7,4*pfnlo(r9) # or too large ! 11696: blequ 0f ! 11697: jmp exfal ! 11698: 0: ! 11699: addl2 4*fargs(r9),r7 # else adjust offset to include args ! 11700: moval 0[r7],r7 # convert to bytes ! 11701: addl2 r7,r9 # point to local pointer ! 11702: movl 4*pfagb(r9),r9 # load vrblk pointer ! 11703: jmp exvnm # exit building nmblk ! 11704: # ! 11705: # HERE IF FIRST ARGUMENT IS NO GOOD ! 11706: # ! 11707: sloc1: jmp er_135 # local first arg is not a program function name ! 11708: #page ! 11709: # ! 11710: # LOAD ! 11711: # ! 11712: s$lod: # entry point ! 11713: jsb gtstg # load library name ! 11714: .long er_136 # load second argument is not string ! 11715: movl r9,r10 # save library name ! 11716: jsb xscni # prepare to scan first argument ! 11717: .long er_137 # load first argument is not string ! 11718: .long er_138 # load first argument is null ! 11719: movl r10,-(sp) # stack library name ! 11720: movl $ch$pp,r8 # set delimiter one = left paren ! 11721: movl r8,r10 # set delimiter two = left paren ! 11722: jsb xscan # scan function name ! 11723: movl r9,-(sp) # save ptr to function name ! 11724: tstl r6 # jump if left paren found ! 11725: bnequ slod1 ! 11726: jmp er_139 # load first argument is missing a left paren ! 11727: # ! 11728: # HERE AFTER SUCCESSFULLY SCANNING FUNCTION NAME ! 11729: # ! 11730: slod1: jsb gtnvr # locate vrblk ! 11731: .long er_140 # load first argument has null function name ! 11732: movl r9,lodfn # save vrblk pointer ! 11733: clrl lodna # zero count of arguments ! 11734: # ! 11735: # LOOP TO SCAN ARGUMENT DATATYPE NAMES ! 11736: # ! 11737: slod2: movl $ch$rp,r8 # delimiter one is right paren ! 11738: movl $ch$cm,r10 # delimiter two is comma ! 11739: jsb xscan # scan next argument name ! 11740: incl lodna # bump argument count ! 11741: tstl r6 # jump if ok delimiter was found ! 11742: bnequ slod3 ! 11743: jmp er_141 # load first argument is missing a right paren ! 11744: #page ! 11745: # ! 11746: # LOAD (CONTINUED) ! 11747: # ! 11748: # COME HERE TO ANALYZE THE DATATYPE POINTER IN (XR). THIS ! 11749: # CODE IS USED BOTH FOR ARGUMENTS (WA=1,2) AND FOR THE ! 11750: # RESULT DATATYPE (WITH WA SET TO ZERO). ! 11751: # ! 11752: slod3: movl r9,-(sp) # stack datatype name pointer ! 11753: movl $num01,r7 # set string code in case ! 11754: movl $scstr,r10 # point to /string/ ! 11755: jsb ident # check for match ! 11756: .long slod4 # jump if match ! 11757: movl (sp),r9 # else reload name ! 11758: addl2 r7,r7 # set code for integer (2) ! 11759: movl $scint,r10 # point to /integer/ ! 11760: jsb ident # check for match ! 11761: .long slod4 # jump if match ! 11762: movl (sp),r9 # else reload string pointer ! 11763: incl r7 # set code for real (3) ! 11764: movl $screa,r10 # point to /real/ ! 11765: jsb ident # check for match ! 11766: .long slod4 # jump if match ! 11767: clrl r7 # else get code for no convert ! 11768: # ! 11769: # MERGE HERE WITH PROPER DATATYPE CODE IN WB ! 11770: # ! 11771: slod4: movl r7,(sp) # store code on stack ! 11772: cmpl r6,$num02 # loop back if arg stopped by comma ! 11773: beqlu slod2 ! 11774: tstl r6 # jump if that was the result type ! 11775: beqlu slod5 ! 11776: # ! 11777: # HERE WE SCAN OUT THE RESULT TYPE (ARG STOPPED BY ) ) ! 11778: # ! 11779: movl mxlen,r8 # set dummy (impossible) delimiter 1 ! 11780: movl r8,r10 # and delimiter two ! 11781: jsb xscan # scan result name ! 11782: clrl r6 # set code for processing result ! 11783: jmp slod3 # jump back to process result name ! 11784: #page ! 11785: # ! 11786: # LOAD (CONTINUED) ! 11787: # ! 11788: # HERE AFTER PROCESSING ALL ARGS AND RESULT ! 11789: # ! 11790: slod5: movl lodna,r6 # get number of arguments ! 11791: movl r6,r8 # copy for later ! 11792: moval 0[r6],r6 # convert length to bytes ! 11793: addl2 $4*efsi$,r6 # add space for standard fields ! 11794: jsb alloc # allocate efblk ! 11795: movl $b$efc,(r9) # set type word ! 11796: movl r8,4*fargs(r9) # set number of arguments ! 11797: clrl 4*efuse(r9) # set use count (dffnc will set to 1) ! 11798: clrl 4*efcod(r9) # zero code pointer for now ! 11799: movl (sp)+,4*efrsl(r9)# store result type code ! 11800: movl lodfn,4*efvar(r9)# store function vrblk pointer ! 11801: movl r6,4*eflen(r9) # store efblk length ! 11802: movl r9,r7 # save efblk pointer ! 11803: addl2 r6,r9 # point past end of efblk ! 11804: # set number of arguments for loop ! 11805: # ! 11806: # LOOP TO SET ARGUMENT TYPE CODES FROM STACK ! 11807: # ! 11808: slod6: movl (sp)+,-(r9) # store one type code from stack ! 11809: sobgtr r8,slod6 # loop till all stored ! 11810: # ! 11811: # NOW LOAD THE EXTERNAL FUNCTION AND PERFORM DEFINITION ! 11812: # ! 11813: movl (sp)+,r9 # load function string name ! 11814: movl (sp),r10 # load library name ! 11815: movl r7,(sp) # store efblk pointer ! 11816: jsb sysld # call function to load external func ! 11817: .long er_142 # load function does not exist ! 11818: .long er_143 # load function caused input error during load ! 11819: movl (sp)+,r10 # recall efblk pointer ! 11820: movl r9,4*efcod(r10) # store code pointer ! 11821: movl lodfn,r9 # point to vrblk for function ! 11822: jsb dffnc # perform function definition ! 11823: jmp exnul # return null result ! 11824: #page ! 11825: # ! 11826: # LPAD ! 11827: # ! 11828: s$lpd: # entry point ! 11829: jsb gtstg # get pad character ! 11830: .long er_144 # lpad third argument not a string ! 11831: movab cfp$f(r9),r9 # point to character (null is blank) ! 11832: movzbl (r9),r7 # load pad character ! 11833: jsb gtsmi # get pad length ! 11834: .long er_145 # lpad second argument is not integer ! 11835: .long slpd3 # skip if negative or large ! 11836: # ! 11837: # MERGE TO CHECK FIRST ARG ! 11838: # ! 11839: slpd1: jsb gtstg # get first argument (string to pad) ! 11840: .long er_146 # lpad first argument is not string ! 11841: cmpl r6,r8 # return 1st arg if too long to pad ! 11842: blssu 0f ! 11843: jmp exixr ! 11844: 0: ! 11845: movl r9,r10 # else move ptr to string to pad ! 11846: # ! 11847: # NOW WE ARE READY FOR THE PAD ! 11848: # ! 11849: # (XL) POINTER TO STRING TO PAD ! 11850: # (WB) PAD CHARACTER ! 11851: # (WC) LENGTH TO PAD STRING TO ! 11852: # ! 11853: movl r8,r6 # copy length ! 11854: jsb alocs # allocate scblk for new string ! 11855: movl r9,-(sp) # save as result ! 11856: movl 4*sclen(r10),r6 # load length of argument ! 11857: subl2 r6,r8 # calculate number of pad characters ! 11858: movab cfp$f(r9),r9 # point to chars in result string ! 11859: # set counter for pad loop ! 11860: # ! 11861: # LOOP TO PERFORM PAD ! 11862: # ! 11863: slpd2: movb r7,(r9)+ # store pad character, bump ptr ! 11864: sobgtr r8,slpd2 # loop till all pad chars stored ! 11865: #csc r9 # complete store characters ! 11866: # ! 11867: # NOW COPY STRING ! 11868: # ! 11869: tstl r6 # exit if null string ! 11870: bnequ 0f ! 11871: jmp exits ! 11872: 0: ! 11873: movab cfp$f(r10),r10 # else point to chars in argument ! 11874: jsb sbmvc # move characters to result string ! 11875: jmp exits # jump for next code word ! 11876: # ! 11877: # HERE IF 2ND ARG IS NEGATIVE OR LARGE ! 11878: # ! 11879: slpd3: clrl r8 # zero pad count ! 11880: jmp slpd1 # merge ! 11881: #page ! 11882: # ! 11883: # LT ! 11884: # ! 11885: s$ltf: # entry point ! 11886: jsb acomp # call arithmetic comparison routine ! 11887: .long er_147 # lt first argument is not numeric ! 11888: .long er_148 # lt second argument is not numeric ! 11889: .long exnul # return null if lt ! 11890: .long exfal # fail if eq ! 11891: .long exfal # fail if gt ! 11892: #page ! 11893: # ! 11894: # NE ! 11895: # ! 11896: s$nef: # entry point ! 11897: jsb acomp # call arithmetic comparison routine ! 11898: .long er_149 # ne first argument is not numeric ! 11899: .long er_150 # ne second argument is not numeric ! 11900: .long exnul # return null if lt ! 11901: .long exfal # fail if eq ! 11902: .long exnul # return null if gt ! 11903: #page ! 11904: # ! 11905: # NOTANY ! 11906: # ! 11907: s$nay: # entry point ! 11908: movl $p$nas,r7 # set pcode for single char arg ! 11909: movl $p$nay,r10 # pcode for multi-char arg ! 11910: movl $p$nad,r8 # set pcode for expr arg ! 11911: jsb patst # call common routine to build node ! 11912: .long er_151 # notany argument is not string or expression ! 11913: jmp exixr # jump for next code word ! 11914: #page ! 11915: # ! 11916: # OPSYN ! 11917: # ! 11918: s$ops: # entry point ! 11919: jsb gtsmi # load third argument ! 11920: .long er_152 # opsyn third argument is not integer ! 11921: .long er_153 # opsyn third argument is negative or too large ! 11922: movl r8,r7 # if ok, save third argumnet ! 11923: movl (sp)+,r9 # load second argument ! 11924: jsb gtnvr # locate variable block ! 11925: .long er_154 # opsyn second arg is not natural variable name ! 11926: movl 4*vrfnc(r9),r10 # if ok, load function block pointer ! 11927: tstl r7 # jump if operator opsyn case ! 11928: bnequ sops2 ! 11929: # ! 11930: # HERE FOR FUNCTION OPSYN (THIRD ARG ZERO) ! 11931: # ! 11932: movl (sp)+,r9 # load first argument ! 11933: jsb gtnvr # get vrblk pointer ! 11934: .long er_155 # opsyn first arg is not natural variable name ! 11935: # ! 11936: # MERGE HERE TO PERFORM FUNCTION DEFINITION ! 11937: # ! 11938: sops1: jsb dffnc # call function definer ! 11939: jmp exnul # exit with null result ! 11940: # ! 11941: # HERE FOR OPERATOR OPSYN (THIRD ARG NON-ZERO) ! 11942: # ! 11943: sops2: jsb gtstg # get operator name ! 11944: .long sops5 # jump if not string ! 11945: cmpl r6,$num01 # error if not one char long ! 11946: bnequ sops5 ! 11947: movab cfp$f(r9),r9 # else point to character ! 11948: movzbl (r9),r8 # load character name ! 11949: #page ! 11950: # ! 11951: # OPSYN (CONTINUED) ! 11952: # ! 11953: # NOW SET TO SEARCH FOR MATCHING UNARY OR BINARY OPERATOR ! 11954: # NAME AS APPROPRIATE. NOTE THAT THERE ARE =OPBUN UNDEFINED ! 11955: # BINARY OPERATORS AND =OPUUN UNDEFINED UNARY OPERATORS. ! 11956: # ! 11957: movl $r$uub,r6 # point to unop pointers in case ! 11958: movl $opnsu,r9 # point to names of unary operators ! 11959: addl2 $opbun,r7 # add no. of undefined binary ops ! 11960: cmpl r7,$opuun # jump if unop (third arg was 1) ! 11961: beqlu sops3 ! 11962: movl $r$uba,r6 # else point to binary operator ptrs ! 11963: movl $opsnb,r9 # point to names of binary operators ! 11964: movl $opbun,r7 # set number of undefined binops ! 11965: # ! 11966: # MERGE HERE TO CHECK LIST (WB = NUMBER TO CHECK) ! 11967: # ! 11968: sops3: # set counter to control loop ! 11969: # ! 11970: # LOOP TO SEARCH FOR NAME MATCH ! 11971: # ! 11972: sops4: cmpl r8,(r9) # jump if names match ! 11973: beqlu sops6 ! 11974: addl2 $4,r6 # else push pointer to function ptr ! 11975: addl2 $4,r9 # bump pointer ! 11976: sobgtr r7,sops4 # loop back till all checked ! 11977: # ! 11978: # HERE IF BAD OPERATOR NAME ! 11979: # ! 11980: sops5: jmp er_156 # opsyn first arg is not correct operator name ! 11981: # ! 11982: # COME HERE ON FINDING A MATCH IN THE OPERATOR NAME TABLE ! 11983: # ! 11984: sops6: movl r6,r9 # copy pointer to function block ptr ! 11985: subl2 $4*vrfnc,r9 # make it look like dummy vrblk ! 11986: jmp sops1 # merge back to define operator ! 11987: #page ! 11988: # ! 11989: # OUTPUT ! 11990: # ! 11991: s$oup: # entry point ! 11992: movl $num03,r7 # output flag ! 11993: jsb ioput # call input/output assoc. routine ! 11994: .long er_157 # output third argument is not a string ! 11995: .long er_158 # inappropriate second argument for output ! 11996: .long er_159 # inappropriate first argument for output ! 11997: .long er_160 # inappropriate file specification for output ! 11998: .long exfal # fail if file does not exist ! 11999: .long er_161 # output file cannot be written to ! 12000: jmp exnul # return null string ! 12001: #page ! 12002: # ! 12003: # POS ! 12004: # ! 12005: s$pos: # entry point ! 12006: movl $p$pos,r7 # set pcode for integer arg case ! 12007: movl $p$psd,r6 # set pcode for expression arg case ! 12008: jsb patin # call common routine to build node ! 12009: .long er_162 # pos argument is not integer or expression ! 12010: .long er_163 # pos argument is negative or too large ! 12011: jmp exixr # return pattern node ! 12012: #page ! 12013: # ! 12014: # PROTOTYPE ! 12015: # ! 12016: s$pro: # entry point ! 12017: movl (sp)+,r9 # load argument ! 12018: movl 4*tblen(r9),r7 # length if table, vector (=vclen) ! 12019: ashl $-2,r7,r7 # convert to words ! 12020: movl (r9),r6 # load type word of argument block ! 12021: cmpl r6,$b$art # jump if array ! 12022: beqlu spro4 ! 12023: cmpl r6,$b$tbt # jump if table ! 12024: beqlu spro1 ! 12025: cmpl r6,$b$vct # jump if vector ! 12026: beqlu spro3 ! 12027: cmpl r6,$b$bct # jump if buffer ! 12028: beqlu spr05 ! 12029: jmp er_164 # prototype argument is not valid object ! 12030: # ! 12031: # HERE FOR TABLE ! 12032: # ! 12033: spro1: subl2 $tbsi$,r7 # subtract standard fields ! 12034: # ! 12035: # MERGE FOR VECTOR ! 12036: # ! 12037: spro2: movl r7,r5 # convert to integer ! 12038: jmp exint # exit with integer result ! 12039: # ! 12040: # HERE FOR VECTOR ! 12041: # ! 12042: spro3: subl2 $vcsi$,r7 # subtract standard fields ! 12043: jmp spro2 # merge ! 12044: # ! 12045: # HERE FOR ARRAY ! 12046: # ! 12047: spro4: addl2 4*arofs(r9),r9 # point to prototype field ! 12048: movl (r9),r9 # load prototype ! 12049: jmp exixr # return prototype as result ! 12050: # ! 12051: # HERE FOR BUFFER ! 12052: # ! 12053: spr05: movl 4*bcbuf(r9),r9 # point to bfblk ! 12054: movl 4*bfalc(r9),r5 # load allocated length ! 12055: jmp exint # exit with integer allocation ! 12056: #page ! 12057: # ! 12058: # REMDR ! 12059: # ! 12060: s$rmd: # entry point ! 12061: clrl r7 # set positive flag ! 12062: movl (sp),r9 # load second argument ! 12063: jsb gtint # convert to integer ! 12064: .long er_165 # remdr second argument is not integer ! 12065: jsb arith # convert args ! 12066: .long srm01 # first arg not integer ! 12067: .long invalid$ # second arg checked above ! 12068: .long srm01 # first arg real ! 12069: movl 4*icval(r9),r5 # load left argument value ! 12070: ashq $-32,r4,r4 # get remainder ! 12071: ediv 4*icval(r10),r4,r11,r5 ! 12072: bvs 0f ! 12073: jmp exint ! 12074: 0: ! 12075: jmp er_167 # remdr caused integer overflow ! 12076: # ! 12077: # FAIL FIRST ARGUMENT ! 12078: # ! 12079: srm01: jmp er_166 # remdr first argument is not integer ! 12080: #page ! 12081: # ! 12082: # REPLACE ! 12083: # ! 12084: # THE ACTUAL REPLACE OPERATION USES AN SCBLK WHOSE CFP$A ! 12085: # CHARS CONTAIN THE TRANSLATED VERSIONS OF ALL THE CHARS. ! 12086: # THE TABLE POINTER IS REMEMBERED FROM CALL TO CALL AND ! 12087: # THE TABLE IS ONLY BUILT WHEN THE ARGUMENTS CHANGE. ! 12088: # ! 12089: s$rpl: # entry point ! 12090: jsb gtstg # load third argument as string ! 12091: .long er_168 # replace third argument is not string ! 12092: movl r9,r10 # save third arg ptr ! 12093: jsb gtstg # get second argument ! 12094: .long er_169 # replace second argument is not string ! 12095: # ! 12096: # CHECK TO SEE IF THIS IS THE SAME TABLE AS LAST TIME ! 12097: # ! 12098: cmpl r9,r$ra2 # jump if 2nd argument different ! 12099: bnequ srpl1 ! 12100: cmpl r10,r$ra3 # jump if args same as last time ! 12101: bnequ 0f ! 12102: jmp srpl4 ! 12103: 0: ! 12104: # ! 12105: # HERE WE BUILD A NEW REPLACE TABLE (NOTE WA = 2ND ARG LEN) ! 12106: # ! 12107: srpl1: movl 4*sclen(r10),r7 # load 3rd argument length ! 12108: cmpl r6,r7 # jump if arguments not same length ! 12109: beqlu 0f ! 12110: jmp srpl5 ! 12111: 0: ! 12112: tstl r7 # jump if null 2nd argument ! 12113: bnequ 0f ! 12114: jmp srpl5 ! 12115: 0: ! 12116: movl r10,r$ra3 # save third arg for next time in ! 12117: movl r9,r$ra2 # save second arg for next time in ! 12118: movl kvalp,r10 # point to alphabet string ! 12119: movl 4*sclen(r10),r6 # load alphabet scblk length ! 12120: movl r$rpt,r9 # point to current table (if any) ! 12121: bnequ srpl2 # jump if we already have a table ! 12122: # ! 12123: # HERE WE ALLOCATE A NEW TABLE ! 12124: # ! 12125: jsb alocs # allocate new table ! 12126: movl r8,r6 # keep scblk length ! 12127: movl r9,r$rpt # save table pointer for next time ! 12128: # ! 12129: # MERGE HERE WITH POINTER TO NEW TABLE BLOCK IN (XR) ! 12130: # ! 12131: srpl2: movab 3+(4*scsi$)(r6),r6 # compute length of scblk ! 12132: bicl2 $3,r6 ! 12133: jsb sbmvw # copy to get initial table values ! 12134: #page ! 12135: # ! 12136: # REPLACE (CONTINUED) ! 12137: # ! 12138: # NOW WE MUST PLUG SELECTED ENTRIES AS REQUIRED. NOTE THAT ! 12139: # WE ARE SHORT OF INDEX REGISTERS FOR THE FOLLOWING LOOP. ! 12140: # HENCE THE NEED TO REPEATEDLY RE-INITIALISE CHAR PTR XL ! 12141: # ! 12142: movl r$ra2,r10 # point to second argument ! 12143: # number of chars to plug ! 12144: clrl r8 # zero char offset ! 12145: movl r$ra3,r9 # point to 3rd arg ! 12146: movab cfp$f(r9),r9 # get char ptr for 3rd arg ! 12147: # ! 12148: # LOOP TO PLUG CHARS ! 12149: # ! 12150: srpl3: movl r$ra2,r10 # point to 2nd arg ! 12151: movab cfp$f(r10)[r8],r10 # point to next char ! 12152: incl r8 # increment offset ! 12153: movzbl (r10),r6 # get next char ! 12154: movl r$rpt,r10 # point to translate table ! 12155: movab cfp$f(r10)[r6],r10 # convert char to offset into table ! 12156: movzbl (r9)+,r6 # get translated char ! 12157: movb r6,(r10) # store in table ! 12158: #csc r10 # complete store characters ! 12159: sobgtr r7,srpl3 # loop till done ! 12160: #page ! 12161: # ! 12162: # REPLACE (CONTINUED) ! 12163: # ! 12164: # HERE TO PERFORM TRANSLATE ! 12165: # ! 12166: srpl4: jsb gtstg # get first argument ! 12167: .long er_170 # replace first argument is not string ! 12168: tstl r6 # return null if null argument ! 12169: bnequ 0f ! 12170: jmp exnul ! 12171: 0: ! 12172: movl r9,r10 # copy pointer ! 12173: movl r6,r8 # save length ! 12174: movab 3+(4*schar)(r6),r6 # get scblk length ! 12175: bicl2 $3,r6 ! 12176: jsb alloc # allocate space for copy ! 12177: movl r9,r7 # save address of copy ! 12178: jsb sbmvw # move scblk contents to copy ! 12179: movl r$rpt,r9 # point to replace table ! 12180: movab cfp$f(r9),r9 # point to chars of table ! 12181: movl r7,r10 # point to string to translate ! 12182: movab cfp$f(r10),r10 # point to chars of string ! 12183: movl r8,r6 # set number of chars to translate ! 12184: jsb sbtrc # perform translation ! 12185: movl r7,-(sp) # stack new string as result ! 12186: jmp exits # return with result on stack ! 12187: # ! 12188: # ERROR POINT ! 12189: # ! 12190: srpl5: jmp er_171 # null or unequally long 2nd, 3rd args to replace ! 12191: #page ! 12192: # ! 12193: # REWIND ! 12194: # ! 12195: s$rew: # entry point ! 12196: jsb iofcb # call fcblk routine ! 12197: .long er_172 # rewind argument is not a suitable name ! 12198: .long er_173 # rewind argument is null ! 12199: jsb sysrw # call system rewind function ! 12200: .long er_174 # rewind file does not exist ! 12201: .long er_175 # rewind file does not permit rewind ! 12202: .long er_176 # rewind caused non-recoverable error ! 12203: jmp exnul # exit with null result if no error ! 12204: #page ! 12205: # ! 12206: # REVERSE ! 12207: # ! 12208: s$rvs: # entry point ! 12209: jsb gtstg # load string argument ! 12210: .long er_177 # reverse argument is not string ! 12211: tstl r6 # return argument if null ! 12212: bnequ 0f ! 12213: jmp exixr ! 12214: 0: ! 12215: movl r9,r10 # else save pointer to string arg ! 12216: jsb alocs # allocate space for new scblk ! 12217: movl r9,-(sp) # store scblk ptr on stack as result ! 12218: movab cfp$f(r9),r9 # prepare to store in new scblk ! 12219: movab cfp$f(r10)[r8],r10 # point past last char in argument ! 12220: # set loop counter ! 12221: # ! 12222: # LOOP TO MOVE CHARS IN REVERSE ORDER ! 12223: # ! 12224: srvs1: movzbl -(r10),r7 # load next char from argument ! 12225: movb r7,(r9)+ # store in result ! 12226: sobgtr r8,srvs1 # loop till all moved ! 12227: #csc r9 # complete store characters ! 12228: jmp exits # and then jump for next code word ! 12229: #page ! 12230: # ! 12231: # RPAD ! 12232: # ! 12233: s$rpd: # entry point ! 12234: jsb gtstg # get pad character ! 12235: .long er_178 # rpad third argument is not string ! 12236: movab cfp$f(r9),r9 # point to character (null is blank) ! 12237: movzbl (r9),r7 # load pad character ! 12238: jsb gtsmi # get pad length ! 12239: .long er_179 # rpad second argument is not integer ! 12240: .long srpd3 # skip if negative or large ! 12241: # ! 12242: # MERGE TO CHECK FIRST ARG. ! 12243: # ! 12244: srpd1: jsb gtstg # get first argument (string to pad) ! 12245: .long er_180 # rpad first argument is not string ! 12246: cmpl r6,r8 # return 1st arg if too long to pad ! 12247: blssu 0f ! 12248: jmp exixr ! 12249: 0: ! 12250: movl r9,r10 # else move ptr to string to pad ! 12251: # ! 12252: # NOW WE ARE READY FOR THE PAD ! 12253: # ! 12254: # (XL) POINTER TO STRING TO PAD ! 12255: # (WB) PAD CHARACTER ! 12256: # (WC) LENGTH TO PAD STRING TO ! 12257: # ! 12258: movl r8,r6 # copy length ! 12259: jsb alocs # allocate scblk for new string ! 12260: movl r9,-(sp) # save as result ! 12261: movl 4*sclen(r10),r6 # load length of argument ! 12262: subl2 r6,r8 # calculate number of pad characters ! 12263: movab cfp$f(r9),r9 # point to chars in result string ! 12264: # set counter for pad loop ! 12265: # ! 12266: # COPY ARGUMENT STRING ! 12267: # ! 12268: tstl r6 # jump if argument is null ! 12269: beqlu srpd2 ! 12270: movab cfp$f(r10),r10 # else point to argument chars ! 12271: jsb sbmvc # move characters to result string ! 12272: # ! 12273: # LOOP TO SUPPLY PAD CHARACTERS ! 12274: # ! 12275: srpd2: movb r7,(r9)+ # store pad character, bump ptr ! 12276: sobgtr r8,srpd2 # loop till all pad chars stored ! 12277: #csc r9 # complete character storing ! 12278: jmp exits # and exit for next word ! 12279: # ! 12280: # HERE IF 2ND ARG IS NEGATIVE OR LARGE ! 12281: # ! 12282: srpd3: clrl r8 # zero pad count ! 12283: jmp srpd1 # merge ! 12284: #page ! 12285: # ! 12286: # RTAB ! 12287: # ! 12288: s$rtb: # entry point ! 12289: movl $p$rtb,r7 # set pcode for integer arg case ! 12290: movl $p$rtd,r6 # set pcode for expression arg case ! 12291: jsb patin # call common routine to build node ! 12292: .long er_181 # rtab argument is not integer or expression ! 12293: .long er_182 # rtab argument is negative or too large ! 12294: jmp exixr # return pattern node ! 12295: #page ! 12296: # ! 12297: # SET ! 12298: # ! 12299: s$set: # entry point ! 12300: movl (sp)+,r$io2 # save third arg ! 12301: movl (sp)+,r$io1 # save second arg ! 12302: jsb iofcb # call fcblk routine ! 12303: .long er_291 # set first argument is not a suitable name ! 12304: .long er_292 # set first argument is null ! 12305: movl r$io1,r7 # load second arg ! 12306: movl r$io2,r8 # load third arg ! 12307: jsb sysst # call system set routine ! 12308: .long er_293 # inappropriate second argument to set ! 12309: .long er_294 # inappropriate third argument to set ! 12310: .long er_295 # set file does not exist ! 12311: .long er_296 # set file does not permit setting file pointer ! 12312: .long er_297 # set caused non-recoverable i/o error ! 12313: jmp exnul # otherwisew return null ! 12314: #page ! 12315: # ! 12316: # TAB ! 12317: # ! 12318: s$tab: # entry point ! 12319: movl $p$tab,r7 # set pcode for integer arg case ! 12320: movl $p$tbd,r6 # set pcode for expression arg case ! 12321: jsb patin # call common routine to build node ! 12322: .long er_183 # tab argument is not integer or expression ! 12323: .long er_184 # tab argument is negative or too large ! 12324: jmp exixr # return pattern node ! 12325: #page ! 12326: # ! 12327: # RPOS ! 12328: # ! 12329: s$rps: # entry point ! 12330: movl $p$rps,r7 # set pcode for integer arg case ! 12331: movl $p$rpd,r6 # set pcode for expression arg case ! 12332: jsb patin # call common routine to build node ! 12333: .long er_185 # rpos argument is not integer or expression ! 12334: .long er_186 # rpos argument is negative or too large ! 12335: jmp exixr # return pattern node ! 12336: #page ! 12337: # ! 12338: # RSORT ! 12339: # ! 12340: s$rsr: # entry point ! 12341: movl sp,r6 # mark as rsort ! 12342: jsb sorta # call sort routine ! 12343: jmp exsid # return, setting idval ! 12344: #page ! 12345: # ! 12346: # SETEXIT ! 12347: # ! 12348: s$stx: # entry point ! 12349: movl (sp)+,r9 # load argument ! 12350: movl stxvr,r6 # load old vrblk pointer ! 12351: clrl r10 # load zero in case null arg ! 12352: cmpl r9,$nulls # jump if null argument (reset call) ! 12353: beqlu sstx1 ! 12354: jsb gtnvr # else get specified vrblk ! 12355: .long sstx2 # jump if not natural variable ! 12356: movl 4*vrlbl(r9),r10 # else load label ! 12357: cmpl r10,$stndl # jump if label is not defined ! 12358: beqlu sstx2 ! 12359: cmpl (r10),$b$trt # jump if not trapped ! 12360: bnequ sstx1 ! 12361: movl 4*trlbl(r10),r10# else load ptr to real label code ! 12362: # ! 12363: # HERE TO SET/RESET SETEXIT TRAP ! 12364: # ! 12365: sstx1: movl r9,stxvr # store new vrblk pointer (or null) ! 12366: movl r10,r$sxc # store new code ptr (or zero) ! 12367: cmpl r6,$nulls # return null if null result ! 12368: bnequ 0f ! 12369: jmp exnul ! 12370: 0: ! 12371: movl r6,r9 # else copy vrblk pointer ! 12372: jmp exvnm # and return building nmblk ! 12373: # ! 12374: # HERE IF BAD ARGUMENT ! 12375: # ! 12376: sstx2: jmp er_187 # setexit argument is not label name or null ! 12377: #page ! 12378: # ! 12379: # SORT ! 12380: # ! 12381: s$srt: # entry point ! 12382: clrl r6 # mark as sort ! 12383: jsb sorta # call sort routine ! 12384: jmp exsid # return, setting idval ! 12385: #page ! 12386: # ! 12387: # SPAN ! 12388: # ! 12389: s$spn: # entry point ! 12390: movl $p$sps,r7 # set pcode for single char arg ! 12391: movl $p$spn,r10 # set pcode for multi-char arg ! 12392: movl $p$spd,r8 # set pcode for expression arg ! 12393: jsb patst # call common routine to build node ! 12394: .long er_188 # span argument is not string or expression ! 12395: jmp exixr # jump for next code word ! 12396: #page ! 12397: # ! 12398: # SIZE ! 12399: # ! 12400: s$si$: # entry point ! 12401: movl (sp),r9 # load argument ! 12402: cmpl (r9),$b$bct # branch if not buffer ! 12403: bnequ ssi$1 ! 12404: addl2 $4,sp # else pop argument ! 12405: movl 4*bclen(r9),r5 # load defined length ! 12406: jmp exint # exit with integer ! 12407: # ! 12408: # HERE IF NOT BUFFER ! 12409: # ! 12410: ssi$1: jsb gtstg # load string argument ! 12411: .long er_189 # size argument is not string ! 12412: movl r6,r5 # load length as integer ! 12413: jmp exint # exit with integer result ! 12414: #page ! 12415: # ! 12416: # STOPTR ! 12417: # ! 12418: s$stt: # entry point ! 12419: clrl r10 # indicate stoptr case ! 12420: jsb trace # call trace procedure ! 12421: .long er_190 # stoptr first argument is not appropriate name ! 12422: .long er_191 # stoptr second argument is not trace type ! 12423: jmp exnul # return null ! 12424: #page ! 12425: # ! 12426: # SUBSTR ! 12427: # ! 12428: s$sub: # entry point ! 12429: jsb gtsmi # load third argument ! 12430: .long er_192 # substr third argument is not integer ! 12431: .long exfal # jump if negative or too large ! 12432: movl r9,sbssv # save third argument ! 12433: jsb gtsmi # load second argument ! 12434: .long er_193 # substr second argument is not integer ! 12435: .long exfal # jump if out of range ! 12436: movl r9,r7 # save second argument ! 12437: bnequ 0f # jump if second argument zero ! 12438: jmp exfal ! 12439: 0: ! 12440: decl r7 # else decrement for ones origin ! 12441: movl (sp),r10 # get first arg ptr ! 12442: cmpl (r10),$b$bct # branch if not buffer ! 12443: bnequ ssuba ! 12444: movl 4*bcbuf(r10),r9 # get bfblk ptr ! 12445: movl 4*bclen(r10),r6 # get length ! 12446: jmp ssubb # merge ! 12447: # ! 12448: # HERE IF NOT BUFFER TO GET STRING ! 12449: # ! 12450: ssuba: jsb gtstg # load first argument ! 12451: .long er_194 # substr first argument is not string ! 12452: # ! 12453: # MERGE WITH BFBLK OR SCBLK PTR IN XR. WA HAS LENGTH ! 12454: # ! 12455: ssubb: movl sbssv,r8 # reload third argument ! 12456: bnequ ssub1 # skip if third arg given ! 12457: movl r6,r8 # else get string length ! 12458: cmpl r7,r8 # fail if improper ! 12459: blequ 0f ! 12460: jmp exfal ! 12461: 0: ! 12462: subl2 r7,r8 # reduce by offset to start ! 12463: # ! 12464: # MERGE ! 12465: # ! 12466: ssub1: movl r6,r10 # save string length ! 12467: movl r8,r6 # set length of substring ! 12468: addl2 r7,r8 # add 2nd arg to 3rd arg ! 12469: cmpl r8,r10 # jump if improper substring ! 12470: blequ 0f ! 12471: jmp exfal ! 12472: 0: ! 12473: movl r9,r10 # copy pointer to first arg ! 12474: jsb sbstr # build substring ! 12475: jmp exixr # and jump for next code word ! 12476: #page ! 12477: # ! 12478: # TABLE ! 12479: # ! 12480: s$tbl: # entry point ! 12481: movl (sp)+,r10 # get initial lookup value ! 12482: addl2 $4,sp # pop second argument ! 12483: jsb gtsmi # load argument ! 12484: .long er_195 # table argument is not integer ! 12485: .long er_196 # table argument is out of range ! 12486: tstl r8 # jump if non-zero ! 12487: bnequ stbl1 ! 12488: movl $tbnbk,r8 # else supply default value ! 12489: # ! 12490: # MERGE HERE WITH NUMBER OF HEADERS IN WA ! 12491: # ! 12492: stbl1: movl r8,r6 # copy number of headers ! 12493: addl2 $tbsi$,r6 # adjust for standard fields ! 12494: moval 0[r6],r6 # convert length to bytes ! 12495: jsb alloc # allocate space for tbblk ! 12496: movl r9,r7 # copy pointer to tbblk ! 12497: movl $b$tbt,(r9)+ # store type word ! 12498: clrl (r9)+ # zero id for the moment ! 12499: movl r6,(r9)+ # store length (tblen) ! 12500: movl r10,(r9)+ # store initial lookup value ! 12501: # set loop counter (num headers) ! 12502: # ! 12503: # LOOP TO INITIALIZE ALL BUCKET POINTERS ! 12504: # ! 12505: stbl2: movl r7,(r9)+ # store tbblk ptr in bucket header ! 12506: sobgtr r8,stbl2 # loop till all stored ! 12507: movl r7,r9 # recall pointer to tbblk ! 12508: jmp exsid # exit setting idval ! 12509: #page ! 12510: # ! 12511: # TIME ! 12512: # ! 12513: s$tim: # entry point ! 12514: jsb systm # get timer value ! 12515: subl2 timsx,r5 # subtract starting time ! 12516: jmp exint # exit with integer value ! 12517: #page ! 12518: # ! 12519: # TRACE ! 12520: # ! 12521: s$tra: # entry point ! 12522: cmpl 4*3(sp),$nulls # jump if first argument is null ! 12523: beqlu str03 ! 12524: movl (sp)+,r9 # load fourth argument ! 12525: clrl r10 # tentatively set zero pointer ! 12526: cmpl r9,$nulls # jump if 4th argument is null ! 12527: beqlu str02 ! 12528: jsb gtnvr # else point to vrblk ! 12529: .long str01 # jump if not variable name ! 12530: movl 4*vrfnc(r9),r10 # else load function pointer ! 12531: cmpl r10,$stndf # jump if function is defined ! 12532: bnequ str02 ! 12533: # ! 12534: # HERE FOR BAD FOURTH ARGUMENT ! 12535: # ! 12536: str01: jmp er_197 # trace fourth arg is not function name or null ! 12537: # ! 12538: # HERE WITH FUNCTION POINTER IN XL ! 12539: # ! 12540: str02: movl (sp)+,r9 # load third argument (tag) ! 12541: clrl r7 # set zero as trtyp value for now ! 12542: jsb trbld # build trblk for trace call ! 12543: movl r9,r10 # move trblk pointer for trace ! 12544: jsb trace # call trace procedure ! 12545: .long er_198 # trace first argument is not appropriate name ! 12546: .long er_199 # trace second argument is not trace type ! 12547: jmp exnul # return null ! 12548: # ! 12549: # HERE TO CALL SYSTEM TRACE TOGGLE ROUTINE ! 12550: # ! 12551: str03: jsb systt # call it ! 12552: addl2 $4*num04,sp # pop trace arguments ! 12553: jmp exnul # return ! 12554: #page ! 12555: # ! 12556: # TRIM ! 12557: # ! 12558: s$trm: # entry point ! 12559: jsb gtstg # load argument as string ! 12560: .long er_200 # trim argument is not string ! 12561: tstl r6 # return null if argument is null ! 12562: bnequ 0f ! 12563: jmp exnul ! 12564: 0: ! 12565: movl r9,r10 # copy string pointer ! 12566: movab 3+(4*schar)(r6),r6 # get block length ! 12567: bicl2 $3,r6 ! 12568: jsb alloc # allocate copy same size ! 12569: movl r9,r7 # save pointer to copy ! 12570: jsb sbmvw # copy old string block to new ! 12571: movl r7,r9 # restore ptr to new block ! 12572: jsb trimr # trim blanks (wb is non-zero) ! 12573: jmp exixr # exit with result in xr ! 12574: #page ! 12575: # ! 12576: # UNLOAD ! 12577: # ! 12578: s$unl: # entry point ! 12579: movl (sp)+,r9 # load argument ! 12580: jsb gtnvr # point to vrblk ! 12581: .long er_201 # unload argument is not natural variable name ! 12582: movl $stndf,r10 # get ptr to undefined function ! 12583: jsb dffnc # undefine named function ! 12584: jmp exnul # return null as result ! 12585: #title s p i t b o l -- utility procedures ! 12586: # ! 12587: # THE FOLLOWING SECTION CONTAINS PROCEDURES WHICH ARE ! 12588: # USED FOR VARIOUS PURPOSES THROUGHOUT THE SYSTEM. ! 12589: # ! 12590: # EACH PROCEDURE IS PRECEDED BY A DESCRIPTION OF THE ! 12591: # CALLING SEQUENCE. USUALLY THE ARGUMENTS ARE IN REGISTERS ! 12592: # BUT ARGUMENTS CAN ALSO OCCUR ON THE STACK AND AS ! 12593: # PARAMETERS ASSEMBLED AFTER THE JSR INSTRUCTION. ! 12594: # ! 12595: # THE FOLLOWING CONSIDERATIONS APPLY TO THESE DESCRIPTIONS. ! 12596: # ! 12597: # 1) THE STACK POINTER (XS) IS NOT CHANGED UNLESS THE ! 12598: # CHANGE IS EXPLICITLY DOCUMENTED IN THE CALL. ! 12599: # ! 12600: # 2) REGISTERS WHOSE ENTRY VALUES ARE NOT MENTIONED ! 12601: # MAY CONTAIN ANY VALUE EXCEPT THAT XL,XR MAY ONLY ! 12602: # CONTAIN PROPER (COLLECTABLE) POINTER VALUES. ! 12603: # THIS CONDITION ON XR MEANS THAT THE CALLED ROUTINE ! 12604: # MAY IF IT CHOOSES PRESERVE XR BY STACKING. ! 12605: # ! 12606: # 3) REGISTERS NOT MENTIONED ON EXIT CONTAIN THE SAME ! 12607: # VALUES AS THEY DID ON ENTRY EXCEPT THAT VALUES IN ! 12608: # XR,XL MAY HAVE BEEN RELOCATED BY THE COLLECTOR. ! 12609: # ! 12610: # 4) REGISTERS WHICH ARE DESTROYED ON EXIT MAY CONTAIN ! 12611: # ANY VALUE EXCEPT THAT VALUES IN XL,XR ARE PROPER ! 12612: # (COLLECTABLE) POINTERS. ! 12613: # ! 12614: # 5) THE CODE POINTER REGISTER POINTS TO THE CURRENT ! 12615: # CODE LOCATION ON ENTRY AND IS UNCHANGED ON EXIT. ! 12616: # ! 12617: # IN THE ABOVE DESCRIPTION, A COLLECTABLE POINTER IS ONE ! 12618: # WHICH EITHER POINTS OUTSIDE THE DYNAMIC REGION OR ! 12619: # POINTS TO THE START OF A BLOCK IN THE DYNAMIC REGION. ! 12620: # ! 12621: # IN THOSE CASES WHERE THE CALLING SEQUENCE CONTAINS ! 12622: # PARAMETERS WHICH ARE USED AS ALTERNATE RETURN POINTS, ! 12623: # THESE PARAMETERS MAY BE REPLACED BY ERROR CODES ! 12624: # ASSEMBLED WITH THE ERR INSTRUCTION. THIS WILL RESULT ! 12625: # IN THE POSTING OF THE ERROR IF THE RETURN IS TAKEN. ! 12626: # ! 12627: # THE PROCEDURES ALL HAVE NAMES CONSISTING OF FIVE LETTERS ! 12628: # AND ARE IN ALPHABETICAL ORDER BY THEIR NAMES. ! 12629: #page ! 12630: # ! 12631: # ACESS - ACCESS VARIABLE VALUE WITH TRACE/INPUT CHECKS ! 12632: # ! 12633: # ACESS LOADS THE VALUE OF A VARIABLE. TRACE AND INPUT ! 12634: # ASSOCIATIONS ARE TESTED FOR AND EXECUTED AS REQUIRED. ! 12635: # ACESS ALSO HANDLES THE SPECIAL CASES OF PSEUDO-VARIABLES. ! 12636: # ! 12637: # (XL) VARIABLE NAME BASE ! 12638: # (WA) VARIABLE NAME OFFSET ! 12639: # JSR ACESS CALL TO ACCESS VALUE ! 12640: # PPM LOC TRANSFER LOC IF ACCESS FAILURE ! 12641: # (XR) VARIABLE VALUE ! 12642: # (WA,WB,WC) DESTROYED ! 12643: # (XL,RA) DESTROYED ! 12644: # ! 12645: # FAILURE CAN OCCUR IF AN INPUT ASSOCIATION CAUSES AN END ! 12646: # OF FILE CONDITION OR IF THE EVALUATION OF AN EXPRESSION ! 12647: # ASSOCIATED WITH AN EXPRESSION VARIABLE FAILS. ! 12648: # ! 12649: acess: #prc # entry point (recursive) ! 12650: movl r10,r9 # copy name base ! 12651: addl2 r6,r9 # point to variable location ! 12652: movl (r9),r9 # load variable value ! 12653: # ! 12654: # LOOP HERE TO CHECK FOR SUCCESSIVE TRBLKS ! 12655: # ! 12656: acs02: cmpl (r9),$b$trt # jump if not trapped ! 12657: beqlu 0f ! 12658: jmp acs18 ! 12659: 0: ! 12660: # ! 12661: # HERE IF TRAPPED ! 12662: # ! 12663: cmpl r9,$trbkv # jump if keyword variable ! 12664: bnequ 0f ! 12665: jmp acs12 ! 12666: 0: ! 12667: cmpl r9,$trbev # jump if not expression variable ! 12668: bnequ acs05 ! 12669: # ! 12670: # HERE FOR EXPRESSION VARIABLE, EVALUATE VARIABLE ! 12671: # ! 12672: movl 4*evexp(r10),r9 # load expression pointer ! 12673: clrl r7 # evaluate by value ! 12674: jsb evalx # evaluate expression ! 12675: .long acs04 # jump if evaluation failure ! 12676: jmp acs02 # check value for more trblks ! 12677: #page ! 12678: # ! 12679: # ACESS (CONTINUED) ! 12680: # ! 12681: # HERE ON READING END OF FILE ! 12682: # ! 12683: acs03: addl2 $4*num03,sp # pop trblk ptr, name base and offset ! 12684: movl r9,dnamp # pop unused scblk ! 12685: # ! 12686: # MERGE HERE WHEN EVALUATION OF EXPRESSION FAILS ! 12687: # ! 12688: acs04: movl (sp)+,r11 # take alternate (failure) return ! 12689: jmp *(r11)+ ! 12690: # ! 12691: # HERE IF NOT KEYWORD OR EXPRESSION VARIABLE ! 12692: # ! 12693: acs05: movl 4*trtyp(r9),r7 # load trap type code ! 12694: beqlu 0f # jump if not input association ! 12695: jmp acs10 ! 12696: 0: ! 12697: tstl kvinp # ignore input assoc if input is off ! 12698: bnequ 0f ! 12699: jmp acs09 ! 12700: 0: ! 12701: # ! 12702: # HERE FOR INPUT ASSOCIATION ! 12703: # ! 12704: movl r10,-(sp) # stack name base ! 12705: movl r6,-(sp) # stack name offset ! 12706: movl r9,-(sp) # stack trblk pointer ! 12707: movl 4*trfpt(r9),r10 # get file ctrl blk ptr or zero ! 12708: bnequ acs06 # jump if not standard input file ! 12709: cmpl 4*trter(r9),$v$ter # jump if terminal ! 12710: bnequ 0f ! 12711: jmp acs21 ! 12712: 0: ! 12713: # ! 12714: # HERE TO READ FROM STANDARD INPUT FILE ! 12715: # ! 12716: movl cswin,r6 # length for read buffer ! 12717: jsb alocs # build string of appropriate length ! 12718: jsb sysrd # read next standard input image ! 12719: .long acs03 # jump to fail exit if end of file ! 12720: jmp acs07 # else merge with other file case ! 12721: # ! 12722: # HERE FOR INPUT FROM OTHER THAN STANDARD INPUT FILE ! 12723: # ! 12724: acs06: movl r10,r6 # fcblk ptr ! 12725: jsb sysil # get input record max length (to wa) ! 12726: jsb alocs # allocate string of correct size ! 12727: movl r10,r6 # fcblk ptr ! 12728: jsb sysin # call system input routine ! 12729: .long acs03 # jump to fail exit if end of file ! 12730: .long acs22 # error ! 12731: .long acs23 # error ! 12732: #page ! 12733: # ! 12734: # ACESS (CONTINUED) ! 12735: # ! 12736: # MERGE HERE AFTER OBTAINING INPUT RECORD ! 12737: # ! 12738: acs07: movl kvtrm,r7 # load trim indicator ! 12739: jsb trimr # trim record as required ! 12740: movl r9,r7 # copy result pointer ! 12741: movl (sp),r9 # reload pointer to trblk ! 12742: # ! 12743: # LOOP TO CHASE TO END OF TRBLK CHAIN AND STORE VALUE ! 12744: # ! 12745: acs08: movl r9,r10 # save pointer to this trblk ! 12746: movl 4*trnxt(r9),r9 # load forward pointer ! 12747: cmpl (r9),$b$trt # loop if this is another trblk ! 12748: beqlu acs08 ! 12749: movl r7,4*trnxt(r10) # else store result at end of chain ! 12750: movl (sp)+,r9 # restore initial trblk pointer ! 12751: movl (sp)+,r6 # restore name offset ! 12752: movl (sp)+,r10 # restore name base pointer ! 12753: # ! 12754: # COME HERE TO MOVE TO NEXT TRBLK ! 12755: # ! 12756: acs09: movl 4*trnxt(r9),r9 # load forward ptr to next value ! 12757: jmp acs02 # back to check if trapped ! 12758: # ! 12759: # HERE TO CHECK FOR ACCESS TRACE TRBLK ! 12760: # ! 12761: acs10: cmpl r7,$trtac # loop back if not access trace ! 12762: beqlu 0f ! 12763: jmp acs09 ! 12764: 0: ! 12765: tstl kvtra # ignore access trace if trace off ! 12766: bnequ 0f ! 12767: jmp acs09 ! 12768: 0: ! 12769: decl kvtra # else decrement trace count ! 12770: tstl 4*trfnc(r9) # jump if print trace ! 12771: beqlu acs11 ! 12772: #page ! 12773: # ! 12774: # ACESS (CONTINUED) ! 12775: # ! 12776: # HERE FOR FULL FUNCTION TRACE ! 12777: # ! 12778: jsb trxeq # call routine to execute trace ! 12779: jmp acs09 # jump for next trblk ! 12780: # ! 12781: # HERE FOR CASE OF PRINT TRACE ! 12782: # ! 12783: acs11: jsb prtsn # print statement number ! 12784: jsb prtnv # print name = value ! 12785: jmp acs09 # jump back for next trblk ! 12786: # ! 12787: # HERE FOR KEYWORD VARIABLE ! 12788: # ! 12789: acs12: movl 4*kvnum(r10),r9 # load keyword number ! 12790: cmpl r9,$k$v$$ # jump if not one word value ! 12791: bgequ acs14 ! 12792: movl l^kvabe(r9),r5 # else load value as integer ! 12793: # ! 12794: # COMMON EXIT WITH KEYWORD VALUE AS INTEGER IN (IA) ! 12795: # ! 12796: acs13: jsb icbld # build icblk ! 12797: jmp acs18 # jump to exit ! 12798: # ! 12799: # HERE IF NOT ONE WORD KEYWORD VALUE ! 12800: # ! 12801: acs14: cmpl r9,$k$s$$ # jump if special case ! 12802: bgequ acs15 ! 12803: subl2 $k$v$$,r9 # else get offset ! 12804: addl2 $ndabo,r9 # point to pattern value ! 12805: jmp acs18 # jump to exit ! 12806: # ! 12807: # HERE IF SPECIAL KEYWORD CASE ! 12808: # ! 12809: acs15: movl kvrtn,r10 # load rtntype in case ! 12810: movl kvstl,r5 # load stlimit in case ! 12811: subl2 $k$s$$,r9 # get case number ! 12812: casel r9,$0,$5 # switch on keyword number ! 12813: 5: ! 12814: .word acs16-5b # jump if alphabet ! 12815: .word acs17-5b # rtntype ! 12816: .word acs19-5b # stcount ! 12817: .word acs20-5b # errtext ! 12818: .word acs13-5b # stlimit ! 12819: #esw # end switch on keyword number ! 12820: #page ! 12821: # ! 12822: # ACESS (CONTINUED) ! 12823: # ! 12824: # ALPHABET ! 12825: # ! 12826: acs16: movl kvalp,r10 # load pointer to alphabet string ! 12827: # ! 12828: # RTNTYPE MERGES HERE ! 12829: # ! 12830: acs17: movl r10,r9 # copy string ptr to proper reg ! 12831: # ! 12832: # COMMON RETURN POINT ! 12833: # ! 12834: acs18: addl2 $4*1,(sp) # return to acess caller ! 12835: rsb ! 12836: # ! 12837: # HERE FOR STCOUNT (IA HAS STLIMIT) ! 12838: # ! 12839: acs19: subl2 kvstc,r5 # stcount = limit - left ! 12840: jmp acs13 # merge back with integer result ! 12841: # ! 12842: # ERRTEXT ! 12843: # ! 12844: acs20: movl r$etx,r9 # get errtext string ! 12845: jmp acs18 # merge with result ! 12846: # ! 12847: # HERE TO READ A RECORD FROM TERMINAL ! 12848: # ! 12849: acs21: movl $rilen,r6 # buffer length ! 12850: jsb alocs # allocate buffer ! 12851: jsb sysri # read record ! 12852: .long acs03 # endfile ! 12853: jmp acs07 # merge with record read ! 12854: # ! 12855: # ERROR RETURNS ! 12856: # ! 12857: acs22: movl r9,dnamp # pop unused scblk ! 12858: jmp er_202 # input from file caused non-recoverable error ! 12859: # ! 12860: acs23: movl r9,dnamp # pop unused scblk ! 12861: jmp er_203 # input file record has incorrect format ! 12862: #enp # end procedure acess ! 12863: #page ! 12864: # ! 12865: # ACOMP -- COMPARE TWO ARITHMETIC VALUES ! 12866: # ! 12867: # 1(XS) FIRST ARGUMENT ! 12868: # 0(XS) SECOND ARGUMENT ! 12869: # JSR ACOMP CALL TO COMPARE VALUES ! 12870: # PPM LOC TRANSFER LOC IF ARG1 IS NON-NUMERIC ! 12871: # PPM LOC TRANSFER LOC IF ARG2 IS NON-NUMERIC ! 12872: # PPM LOC TRANSFER LOC FOR ARG1 LT ARG2 ! 12873: # PPM LOC TRANSFER LOC FOR ARG1 EQ ARG2 ! 12874: # PPM LOC TRANSFER LOC FOR ARG1 GT ARG2 ! 12875: # (NORMAL RETURN IS NEVER GIVEN) ! 12876: # (WA,WB,WC,IA,RA) DESTROYED ! 12877: # (XL,XR) DESTROYED ! 12878: # ! 12879: .data 1 ! 12880: acomp_s: .long 0 ! 12881: .text 0 ! 12882: acomp: movl (sp)+,acomp_s # entry point ! 12883: jsb arith # load arithmetic operands ! 12884: .long acmp7 # jump if first arg non-numeric ! 12885: .long acmp8 # jump if second arg non-numeric ! 12886: .long acmp4 # jump if real arguments ! 12887: # ! 12888: # HERE FOR INTEGER ARGUMENTS ! 12889: # ! 12890: subl2 4*icval(r10),r5 # subtract to compare ! 12891: bvs acmp3 ! 12892: tstl r5 # else jump if arg1 lt arg2 ! 12893: blss acmp5 ! 12894: tstl r5 # jump if arg1 eq arg2 ! 12895: beql acmp2 ! 12896: # ! 12897: # HERE IF ARG1 GT ARG2 ! 12898: # ! 12899: acmp1: addl3 $4*4,acomp_s,r11 # take gt exit ! 12900: jmp *(r11)+ ! 12901: # ! 12902: # HERE IF ARG1 EQ ARG2 ! 12903: # ! 12904: acmp2: addl3 $4*3,acomp_s,r11 # take eq exit ! 12905: jmp *(r11)+ ! 12906: #page ! 12907: # ! 12908: # ACOMP (CONTINUED) ! 12909: # ! 12910: # HERE FOR INTEGER OVERFLOW ON SUBTRACT ! 12911: # ! 12912: acmp3: movl 4*icval(r10),r5 # load second argument ! 12913: blss acmp1 # gt if negative ! 12914: jmp acmp5 # else lt ! 12915: # ! 12916: # HERE FOR REAL OPERANDS ! 12917: # ! 12918: acmp4: subf2 4*rcval(r10),r2 # subtract to compare ! 12919: bvs acmp6 ! 12920: tstf r2 # else jump if arg1 gt ! 12921: bgtr acmp1 ! 12922: tstf r2 # jump if arg1 eq arg2 ! 12923: beql acmp2 ! 12924: # ! 12925: # HERE IF ARG1 LT ARG2 ! 12926: # ! 12927: acmp5: addl3 $4*2,acomp_s,r11 # take lt exit ! 12928: jmp *(r11)+ ! 12929: # ! 12930: # HERE IF OVERFLOW ON REAL SUBTRACTION ! 12931: # ! 12932: acmp6: movf 4*rcval(r10),r2 # reload arg2 ! 12933: tstf r2 # gt if negative ! 12934: blss acmp1 ! 12935: jmp acmp5 # else lt ! 12936: # ! 12937: # HERE IF ARG1 NON-NUMERIC ! 12938: # ! 12939: acmp7: movl acomp_s,r11 # take error exit ! 12940: jmp *(r11)+ ! 12941: # ! 12942: # HERE IF ARG2 NON-NUMERIC ! 12943: # ! 12944: acmp8: addl3 $4*1,acomp_s,r11 # take error exit ! 12945: jmp *(r11)+ ! 12946: #enp # end procedure acomp ! 12947: #page ! 12948: # ! 12949: # ALLOC ALLOCATE BLOCK OF DYNAMIC STORAGE ! 12950: # ! 12951: # (WA) LENGTH REQUIRED IN BYTES ! 12952: # JSR ALLOC CALL TO ALLOCATE BLOCK ! 12953: # (XR) POINTER TO ALLOCATED BLOCK ! 12954: # ! 12955: # A POSSIBLE ALTERNATIVE TO AOV .. AND FOLLOWING STMT IS - ! 12956: # MOV DNAME,XR . SUB WA,XR . BLO XR,DNAMP,ALOC2 . ! 12957: # MOV DNAMP,XR . ADD WA,XR ! 12958: # ! 12959: alloc: #prc # entry point ! 12960: # ! 12961: # COMMON EXIT POINT ! 12962: # ! 12963: aloc1: movl dnamp,r9 # point to next available loc ! 12964: addl2 r6,r9 # point past allocated block ! 12965: bvc 0f ! 12966: jmp aloc2 ! 12967: 0: ! 12968: cmpl r9,dname # jump if not enough room ! 12969: bgtru aloc2 ! 12970: movl r9,dnamp # store new pointer ! 12971: subl2 r6,r9 # point back to start of allocated bk ! 12972: rsb # return to caller ! 12973: # ! 12974: # HERE IF INSUFFICIENT ROOM, TRY A GARBAGE COLLECTION ! 12975: # ! 12976: aloc2: movl r7,allsv # save wb ! 12977: clrl r7 # set no upward move for gbcol ! 12978: jsb gbcol # garbage collect ! 12979: # ! 12980: # SEE IF ROOM AFTER GBCOL OR SYSMM CALL ! 12981: # ! 12982: aloc3: movl dnamp,r9 # point to first available loc ! 12983: addl2 r6,r9 # point past new block ! 12984: bvc 0f ! 12985: jmp alc3a ! 12986: 0: ! 12987: cmpl r9,dname # jump if there is room now ! 12988: blequ aloc4 ! 12989: # ! 12990: # FAILED AGAIN, SEE IF WE CAN GET MORE CORE ! 12991: # ! 12992: alc3a: jsb sysmm # try to get more memory ! 12993: moval 0[r9],r9 # convert to baus (sgd05) ! 12994: addl2 r9,dname # bump ptr by amount obtained ! 12995: tstl r9 # jump if got more core ! 12996: bnequ aloc3 ! 12997: addl2 rsmem,dname # get the reserve memory ! 12998: clrl rsmem # only permissible once ! 12999: incl errft # fatal error ! 13000: jmp er_204 # memory overflow ! 13001: #page ! 13002: # ! 13003: # HERE AFTER SUCCESSFUL GARBAGE COLLECTION ! 13004: # ! 13005: aloc4: movl r5,allia # save ia ! 13006: movl dname,r7 # get dynamic end adrs ! 13007: subl2 dnamp,r7 # compute free store ! 13008: ashl $-2,r7,r7 # convert bytes to words ! 13009: movl r7,r5 # put free store in ia ! 13010: mull2 alfsf,r5 # multiply by free store factor ! 13011: bvs aloc5 ! 13012: movl dname,r7 # dynamic end adrs ! 13013: subl2 dnamb,r7 # compute total amount of dynamic ! 13014: ashl $-2,r7,r7 # convert to words ! 13015: movl r7,aldyn # store it ! 13016: subl2 aldyn,r5 # subtract from scaled up free store ! 13017: bgtr aloc5 # jump if sufficient free store ! 13018: jsb sysmm # try to get more store ! 13019: moval 0[r9],r9 # convert to baus (sgd05) ! 13020: addl2 r9,dname # adjust dynamic end adrs ! 13021: # ! 13022: # MERGE TO RESTORE IA AND WB ! 13023: # ! 13024: aloc5: movl allia,r5 # recover ia ! 13025: movl allsv,r7 # restore wb ! 13026: jmp aloc1 # jump back to exit ! 13027: #enp # end procedure alloc ! 13028: #page ! 13029: # ! 13030: # ALOBF -- ALLOCATE BUFFER ! 13031: # ! 13032: # THIS ROUTINES ALLOCATES A NEW BUFFER. AS THE BFBLK ! 13033: # AND BCBLK COME IN PAIRS, BOTH ARE ALLOCATED HERE, ! 13034: # AND XR POINTS TO THE BCBLK ON RETURN. THE BFBLK ! 13035: # AND BCBLK ARE SET TO THE NULL BUFFER, AND THE IDVAL ! 13036: # IS ZERO ON RETURN. ! 13037: # ! 13038: # (WA) BUFFER SIZE IN CHARACTERS ! 13039: # JSR ALOBF CALL TO CREATE BUFFER ! 13040: # (XR) BCBLK PTR ! 13041: # (WA,WB) DESTROYED ! 13042: # ! 13043: alobf: #prc # entry point ! 13044: movl r6,r7 # hang onto allocation size ! 13045: movab 3+(4*bfsi$)(r6),r6 # get total block size ! 13046: bicl2 $3,r6 ! 13047: cmpl r6,mxlen # check for maxlen exceeded ! 13048: bgequ alb01 ! 13049: addl2 $4*bcsi$,r6 # add in allocation for bcblk ! 13050: jsb alloc # allocate frame ! 13051: movl $b$bct,(r9) # set type ! 13052: clrl 4*idval(r9) # no id yet ! 13053: clrl 4*bclen(r9) # no defined length ! 13054: movl r10,r6 # save xl ! 13055: movl r9,r10 # copy bcblk ptr ! 13056: addl2 $4*bcsi$,r10 # bias past partially built bcblk ! 13057: movl $b$bft,(r10) # set bfblk type word ! 13058: movl r7,4*bfalc(r10) # set allocated size ! 13059: movl r10,4*bcbuf(r9) # set pointer in bcblk ! 13060: clrl 4*bfchr(r10) # clear first word (null pad) ! 13061: movl r6,r10 # restore entry xl ! 13062: rsb # return to caller ! 13063: # ! 13064: # HERE FOR MXLEN EXCEEDED ! 13065: # ! 13066: alb01: jmp er_274 # requested buffer allocation exceeds mxlen ! 13067: #enp # end procedure alobf ! 13068: #page ! 13069: # ! 13070: # ALOCS -- ALLOCATE STRING BLOCK ! 13071: # ! 13072: # ALOCS IS USED TO BUILD A FRAME FOR A STRING BLOCK INTO ! 13073: # WHICH THE ACTUAL CHARACTERS ARE PLACED BY THE CALLER. ! 13074: # ALL STRINGS ARE CREATED WITH A CALL TO ALOCS (THE ! 13075: # EXCEPTIONS OCCUR IN TRIMR AND S$RPL PROCEDURES). ! 13076: # ! 13077: # (WA) LENGTH OF STRING TO BE ALLOCATED ! 13078: # JSR ALOCS CALL TO ALLOCATE SCBLK ! 13079: # (XR) POINTER TO RESULTING SCBLK ! 13080: # (WA) DESTROYED ! 13081: # (WC) CHARACTER COUNT (ENTRY VALUE OF WA) ! 13082: # ! 13083: # THE RESULTING SCBLK HAS THE TYPE WORD AND THE LENGTH ! 13084: # FILLED IN AND THE LAST WORD IS CLEARED TO ZERO CHARACTERS ! 13085: # TO ENSURE CORRECT RIGHT PADDING OF THE FINAL WORD. ! 13086: # ! 13087: alocs: #prc # entry point ! 13088: cmpl r6,kvmxl # jump if length exceeeds maxlength ! 13089: bgtru alcs2 ! 13090: movl r6,r8 # else copy length ! 13091: movab 3+(4*scsi$)(r6),r6 # compute length of scblk in bytes ! 13092: bicl2 $3,r6 ! 13093: movl dnamp,r9 # point to next available location ! 13094: addl2 r6,r9 # point past block ! 13095: bvc 0f ! 13096: jmp alcs0 ! 13097: 0: ! 13098: cmpl r9,dname # jump if there is room ! 13099: blequ alcs1 ! 13100: # ! 13101: # INSUFFICIENT MEMORY ! 13102: # ! 13103: alcs0: clrl r9 # else clear garbage xr value ! 13104: jsb alloc # and use standard allocator ! 13105: addl2 r6,r9 # point past end of block to merge ! 13106: # ! 13107: # MERGE HERE WITH XR POINTING BEYOND NEW BLOCK ! 13108: # ! 13109: alcs1: movl r9,dnamp # set updated storage pointer ! 13110: clrl -(r9) # store zero chars in last word ! 13111: subl2 $4,r6 # decrement length ! 13112: subl2 r6,r9 # point back to start of block ! 13113: movl $b$scl,(r9) # set type word ! 13114: movl r8,4*sclen(r9) # store length in chars ! 13115: rsb # return to alocs caller ! 13116: # ! 13117: # COME HERE IF STRING IS TOO LONG ! 13118: # ! 13119: alcs2: jmp er_205 # string length exceeds value of maxlngth keyword ! 13120: #enp # end procedure alocs ! 13121: #page ! 13122: # ! 13123: # ALOST -- ALLOCATE SPACE IN STATIC REGION ! 13124: # ! 13125: # (WA) LENGTH REQUIRED IN BYTES ! 13126: # JSR ALOST CALL TO ALLOCATE SPACE ! 13127: # (XR) POINTER TO ALLOCATED BLOCK ! 13128: # (WB) DESTROYED ! 13129: # ! 13130: # NOTE THAT THE CODING ENSURES THAT THE RESULTING VALUE ! 13131: # OF STATE IS ALWAYS LESS THAN DNAMB. THIS FACT IS USED ! 13132: # IN TESTING A VARIABLE NAME FOR BEING IN THE STATIC REGION ! 13133: # ! 13134: alost: #prc # entry point ! 13135: # ! 13136: # MERGE BACK HERE AFTER ALLOCATING NEW CHUNK ! 13137: # ! 13138: alst1: movl state,r9 # point to current end of area ! 13139: addl2 r6,r9 # point beyond proposed block ! 13140: bvc 0f ! 13141: jmp alst2 ! 13142: 0: ! 13143: cmpl r9,dnamb # jump if overlap with dynamic area ! 13144: bgequ alst2 ! 13145: movl r9,state # else store new pointer ! 13146: subl2 r6,r9 # point back to start of block ! 13147: rsb # return to alost caller ! 13148: # ! 13149: # HERE IF NO ROOM, PREPARE TO MOVE DYNAMIC STORAGE UP ! 13150: # ! 13151: alst2: movl r6,alsta # save wa ! 13152: cmpl r6,$4*e$sts # skip if requested chunk is large ! 13153: bgequ alst3 ! 13154: movl $4*e$sts,r6 # else set to get large enough chunk ! 13155: # ! 13156: # HERE WITH AMOUNT TO MOVE UP IN WA ! 13157: # ! 13158: alst3: jsb alloc # allocate block to ensure room ! 13159: movl r9,dnamp # and delete it ! 13160: movl r6,r7 # copy move up amount ! 13161: jsb gbcol # call gbcol to move dynamic area up ! 13162: movl alsta,r6 # restore wa ! 13163: jmp alst1 # loop back to try again ! 13164: #enp # end procedure alost ! 13165: #page ! 13166: # ! 13167: # APNDB -- APPEND STRING TO BUFFER ! 13168: # ! 13169: # THIS ROUTINE IS USED BY BUFFER HANDLING ROUTINES TO ! 13170: # APPEND DATA TO AN EXISTING BFBLK. ! 13171: # ! 13172: # (XR) EXISTING BCBLK TO BE APPENDED ! 13173: # (XL) CONVERTABLE TO STRING ! 13174: # JSR APNDB CALL TO APPEND TO BUFFER ! 13175: # PPM LOC THREAD IF (XL) CANT BE CONVERTED ! 13176: # PPM LOC IF NOT ENOUGH ROOM ! 13177: # (WA,WB) DESTROYED ! 13178: # ! 13179: # IF MORE CHARACTERS ARE SPECIFIED THAN CAN BE INSERTED, ! 13180: # THEN NO ACTION IS TAKEN AND THE SECOND RETURN IS TAKEN. ! 13181: # ! 13182: apndb: #prc # entry point ! 13183: movl 4*bclen(r9),r6 # load offset to insert ! 13184: clrl r7 # replace section is null ! 13185: jsb insbf # call to insert at end ! 13186: .long apn01 # convert error ! 13187: .long apn02 # no room ! 13188: addl2 $4*2,(sp) # return to caller ! 13189: rsb ! 13190: # ! 13191: # HERE TO TAKE CONVERT FAILURE EXIT ! 13192: # ! 13193: apn01: movl (sp)+,r11 # return to caller alternate ! 13194: jmp *(r11)+ ! 13195: # ! 13196: # HERE FOR NO FIT EXIT ! 13197: # ! 13198: apn02: addl3 $4*1,(sp)+,r11 # alternate exit to caller ! 13199: jmp *(r11)+ ! 13200: #enp # end procedure apndb ! 13201: #page ! 13202: # ! 13203: # ARITH -- FETCH ARITHMETIC OPERANDS ! 13204: # ! 13205: # ARITH IS USED BY FUNCTIONS AND OPERATORS WHICH EXPECT ! 13206: # TWO NUMERIC ARGUMENTS (OPERANDS) WHICH MUST BOTH BE ! 13207: # INTEGER OR BOTH BE REAL. ARITH FETCHES TWO ARGUMENTS FROM ! 13208: # THE STACK AND PERFORMS ANY NECESSARY CONVERSIONS. ! 13209: # ! 13210: # 1(XS) FIRST ARGUMENT (LEFT OPERAND) ! 13211: # 0(XS) SECOND ARGUMENT (RIGHT OPERAND) ! 13212: # JSR ARITH CALL TO FETCH NUMERIC ARGUMENTS ! 13213: # PPM LOC TRANSFER LOC FOR OPND 1 NON-NUMERIC ! 13214: # PPM LOC TRANSFER LOC FOR OPND 2 NON-NUMERIC ! 13215: # PPM LOC TRANSFER LOC FOR REAL OPERANDS ! 13216: # ! 13217: # FOR INTEGER ARGS, CONTROL RETURNS PAST THE PARAMETERS ! 13218: # ! 13219: # (IA) LEFT OPERAND VALUE ! 13220: # (XR) PTR TO ICBLK FOR LEFT OPERAND ! 13221: # (XL) PTR TO ICBLK FOR RIGHT OPERAND ! 13222: # (XS) POPPED TWICE ! 13223: # (WA,WB,RA) DESTROYED ! 13224: # ! 13225: # FOR REAL ARGUMENTS, CONTROL RETURNS TO THE LOCATION ! 13226: # SPECIFIED BY THE THIRD PARAMETER. ! 13227: # ! 13228: # (RA) LEFT OPERAND VALUE ! 13229: # (XR) PTR TO RCBLK FOR LEFT OPERAND ! 13230: # (XL) PTR TO RCBLK FOR RIGHT OPERAND ! 13231: # (WA,WB,WC) DESTROYED ! 13232: # (XS) POPPED TWICE ! 13233: #page ! 13234: # ! 13235: # ARITH (CONTINUED) ! 13236: # ! 13237: # ENTRY POINT ! 13238: # ! 13239: .data 1 ! 13240: arith_s: .long 0 ! 13241: .text 0 ! 13242: arith: movl (sp)+,arith_s # entry point ! 13243: movl (sp)+,r10 # load right operand ! 13244: movl (sp)+,r9 # load left operand ! 13245: movl (r10),r6 # get right operand type word ! 13246: cmpl r6,$b$icl # jump if integer ! 13247: beqlu arth1 ! 13248: cmpl r6,$b$rcl # jump if real ! 13249: beqlu arth4 ! 13250: movl r9,-(sp) # else replace left arg on stack ! 13251: movl r10,r9 # copy left arg pointer ! 13252: jsb gtnum # convert to numeric ! 13253: .long arth6 # jump if unconvertible ! 13254: movl r9,r10 # else copy converted result ! 13255: movl (r10),r6 # get right operand type word ! 13256: movl (sp)+,r9 # reload left argument ! 13257: cmpl r6,$b$rcl # jump if right arg is real ! 13258: beqlu arth4 ! 13259: # ! 13260: # HERE IF RIGHT ARG IS AN INTEGER ! 13261: # ! 13262: arth1: cmpl (r9),$b$icl # jump if left arg not integer ! 13263: bnequ arth3 ! 13264: # ! 13265: # EXIT FOR INTEGER CASE ! 13266: # ! 13267: arth2: movl 4*icval(r9),r5 # load left operand value ! 13268: addl3 $4*3,arith_s,r11 # return to arith caller ! 13269: jmp (r11) ! 13270: # ! 13271: # HERE FOR RIGHT OPERAND INTEGER, LEFT OPERAND NOT ! 13272: # ! 13273: arth3: jsb gtnum # convert left arg to numeric ! 13274: .long arth7 # jump if not convertible ! 13275: cmpl r6,$b$icl # jump back if integer-integer ! 13276: beqlu arth2 ! 13277: # ! 13278: # HERE WE MUST CONVERT REAL-INTEGER TO REAL-REAL ! 13279: # ! 13280: movl r9,-(sp) # put left arg back on stack ! 13281: movl 4*icval(r10),r5 # load right argument value ! 13282: cvtlf r5,r2 # convert to real ! 13283: jsb rcbld # get real block for right arg, merge ! 13284: movl r9,r10 # copy right arg ptr ! 13285: movl (sp)+,r9 # load left argument ! 13286: jmp arth5 # merge for real-real case ! 13287: #page ! 13288: # ! 13289: # ARITH (CONTINUED) ! 13290: # ! 13291: # HERE IF RIGHT ARGUMENT IS REAL ! 13292: # ! 13293: arth4: cmpl (r9),$b$rcl # jump if left arg real ! 13294: beqlu arth5 ! 13295: jsb gtrea # else convert to real ! 13296: .long arth7 # error if unconvertible ! 13297: # ! 13298: # HERE FOR REAL-REAL ! 13299: # ! 13300: arth5: movf 4*rcval(r9),r2 # load left operand value ! 13301: addl3 $4*2,arith_s,r11 # take real-real exit ! 13302: jmp *(r11)+ ! 13303: # ! 13304: # HERE FOR ERROR CONVERTING RIGHT ARGUMENT ! 13305: # ! 13306: arth6: addl2 $4,sp # pop unwanted left arg ! 13307: addl3 $4*1,arith_s,r11 # take appropriate error exit ! 13308: jmp *(r11)+ ! 13309: # ! 13310: # HERE FOR ERROR CONVERTING LEFT OPERAND ! 13311: # ! 13312: arth7: movl arith_s,r11 # take appropriate error return ! 13313: jmp *(r11)+ ! 13314: #enp # end procedure arith ! 13315: #page ! 13316: # ! 13317: # ASIGN -- PERFORM ASSIGNMENT ! 13318: # ! 13319: # ASIGN PERFORMS THE ASSIGNMENT OF A VALUE TO A VARIABLE ! 13320: # WITH APPROPRIATE CHECKS FOR OUTPUT ASSOCIATIONS AND ! 13321: # VALUE TRACE ASSOCIATIONS WHICH ARE EXECUTED AS REQUIRED. ! 13322: # ASIGN ALSO HANDLES THE SPECIAL CASES OF ASSIGNMENT TO ! 13323: # PATTERN AND EXPRESSION VARIABLES. ! 13324: # ! 13325: # (WB) VALUE TO BE ASSIGNED ! 13326: # (XL) BASE POINTER FOR VARIABLE ! 13327: # (WA) OFFSET FOR VARIABLE ! 13328: # JSR ASIGN CALL TO ASSIGN VALUE TO VARIABLE ! 13329: # PPM LOC TRANSFER LOC FOR FAILURE ! 13330: # (XR,XL,WA,WB,WC) DESTROYED ! 13331: # (RA) DESTROYED ! 13332: # ! 13333: # FAILURE OCCURS IF THE EVALUATION OF AN EXPRESSION ! 13334: # ASSOCIATED WITH AN EXPRESSION VARIABLE FAILS. ! 13335: # ! 13336: asign: #prc # entry point (recursive) ! 13337: # ! 13338: # MERGE BACK HERE TO ASSIGN RESULT TO EXPRESSION VARIABLE. ! 13339: # ! 13340: asg01: addl2 r6,r10 # point to variable value ! 13341: movl (r10),r9 # load variable value ! 13342: cmpl (r9),$b$trt # jump if trapped ! 13343: beqlu asg02 ! 13344: movl r7,(r10) # else perform assignment ! 13345: clrl r10 # clear garbage value in xl ! 13346: addl2 $4*1,(sp) # and return to asign caller ! 13347: rsb ! 13348: # ! 13349: # HERE IF VALUE IS TRAPPED ! 13350: # ! 13351: asg02: subl2 r6,r10 # restore name base ! 13352: cmpl r9,$trbkv # jump if keyword variable ! 13353: bnequ 0f ! 13354: jmp asg14 ! 13355: 0: ! 13356: cmpl r9,$trbev # jump if not expression variable ! 13357: bnequ asg04 ! 13358: # ! 13359: # HERE FOR ASSIGNMENT TO EXPRESSION VARIABLE ! 13360: # ! 13361: movl 4*evexp(r10),r9 # point to expression ! 13362: movl r7,-(sp) # store value to assign on stack ! 13363: movl $num01,r7 # set for evaluation by name ! 13364: jsb evalx # evaluate expression by name ! 13365: .long asg03 # jump if evaluation fails ! 13366: movl (sp)+,r7 # else reload value to assign ! 13367: jmp asg01 # loop back to perform assignment ! 13368: #page ! 13369: # ! 13370: # ASIGN (CONTINUED) ! 13371: # ! 13372: # HERE FOR FAILURE DURING EXPRESSION EVALUATION ! 13373: # ! 13374: asg03: addl2 $4,sp # remove stacked value entry ! 13375: movl (sp)+,r11 # take failure exit ! 13376: jmp *(r11)+ ! 13377: # ! 13378: # HERE IF NOT KEYWORD OR EXPRESSION VARIABLE ! 13379: # ! 13380: asg04: movl r9,-(sp) # save ptr to first trblk ! 13381: # ! 13382: # LOOP TO CHASE DOWN TRBLK CHAIN AND ASSIGN VALUE AT END ! 13383: # ! 13384: asg05: movl r9,r8 # save ptr to this trblk ! 13385: movl 4*trnxt(r9),r9 # point to next trblk ! 13386: cmpl (r9),$b$trt # loop back if another trblk ! 13387: beqlu asg05 ! 13388: movl r8,r9 # else point back to last trblk ! 13389: movl r7,4*trval(r9) # store value at end of chain ! 13390: movl (sp)+,r9 # restore ptr to first trblk ! 13391: # ! 13392: # LOOP TO PROCESS TRBLK ENTRIES ON CHAIN ! 13393: # ! 13394: asg06: movl 4*trtyp(r9),r7 # load type code of trblk ! 13395: cmpl r7,$trtvl # jump if value trace ! 13396: beqlu asg08 ! 13397: cmpl r7,$trtou # jump if output association ! 13398: beqlu asg10 ! 13399: # ! 13400: # HERE TO MOVE TO NEXT TRBLK ON CHAIN ! 13401: # ! 13402: asg07: movl 4*trnxt(r9),r9 # point to next trblk on chain ! 13403: cmpl (r9),$b$trt # loop back if another trblk ! 13404: beqlu asg06 ! 13405: addl2 $4*1,(sp) # else end of chain, return to caller ! 13406: rsb ! 13407: # ! 13408: # HERE TO PROCESS VALUE TRACE ! 13409: # ! 13410: asg08: tstl kvtra # ignore value trace if trace off ! 13411: beqlu asg07 ! 13412: decl kvtra # else decrement trace count ! 13413: tstl 4*trfnc(r9) # jump if print trace ! 13414: beqlu asg09 ! 13415: jsb trxeq # else execute function trace ! 13416: jmp asg07 # and loop back ! 13417: #page ! 13418: # ! 13419: # ASIGN (CONTINUED) ! 13420: # ! 13421: # HERE FOR PRINT TRACE ! 13422: # ! 13423: asg09: jsb prtsn # print statement number ! 13424: jsb prtnv # print name = value ! 13425: jmp asg07 # loop back for next trblk ! 13426: # ! 13427: # HERE FOR OUTPUT ASSOCIATION ! 13428: # ! 13429: asg10: tstl kvoup # ignore output assoc if output off ! 13430: beqlu asg07 ! 13431: movl r9,r10 # else copy trblk pointer ! 13432: movl 4*trval(r8),-(sp)# stack value to output (sgd01) ! 13433: jsb gtstg # convert to string ! 13434: .long asg12 # get datatype name if unconvertible ! 13435: # ! 13436: # MERGE WITH STRING FOR OUTPUT ! 13437: # ! 13438: asg11: movl 4*trfpt(r10),r6 # fcblk ptr ! 13439: beqlu asg13 # jump if standard output file ! 13440: # ! 13441: # HERE FOR OUTPUT TO NON-STANDARD OUTPUT FILE ! 13442: # ! 13443: jsb sysou # call system output routine ! 13444: .long er_206 # output caused file overflow ! 13445: .long er_207 # output caused non-recoverable error ! 13446: addl2 $4*1,(sp) # else all done, return to caller ! 13447: rsb ! 13448: # ! 13449: # IF NOT PRINTABLE, GET DATATYPE NAME INSTEAD ! 13450: # ! 13451: asg12: jsb dtype # call datatype routine ! 13452: jmp asg11 # merge ! 13453: # ! 13454: # HERE TO PRINT A STRING ON THE PRINTER ! 13455: # ! 13456: asg13: jsb prtst # print string value ! 13457: cmpl 4*trter(r10),$v$ter # jump if terminal output ! 13458: bnequ 0f ! 13459: jmp asg20 ! 13460: 0: ! 13461: jsb prtnl # end of line ! 13462: addl2 $4*1,(sp) # return to caller ! 13463: rsb ! 13464: #page ! 13465: # ! 13466: # ASIGN (CONTINUED) ! 13467: # ! 13468: # HERE FOR KEYWORD ASSIGNMENT ! 13469: # ! 13470: asg14: movl 4*kvnum(r10),r10# load keyword number ! 13471: cmpl r10,$k$etx # jump if errtext ! 13472: bnequ 0f ! 13473: jmp asg19 ! 13474: 0: ! 13475: movl r7,r9 # copy value to be assigned ! 13476: jsb gtint # convert to integer ! 13477: .long er_208 # keyword value assigned is not integer ! 13478: movl 4*icval(r9),r5 # else load value ! 13479: cmpl r10,$k$stl # jump if special case of stlimit ! 13480: beqlu asg16 ! 13481: movl r5,r6 # else get addr integer, test ovflow ! 13482: bgeq 0f ! 13483: jmp asg18 ! 13484: 0: ! 13485: cmpl r6,mxlen # fail if too large ! 13486: bgequ asg18 ! 13487: cmpl r10,$k$ert # jump if special case of errtype ! 13488: beqlu asg17 ! 13489: cmpl r10,$k$pfl # jump if special case of profile ! 13490: beqlu asg21 ! 13491: cmpl r10,$k$p$$ # jump unless protected ! 13492: blssu asg15 ! 13493: jmp er_209 # keyword in assignment is protected ! 13494: # ! 13495: # HERE TO DO ASSIGNMENT IF NOT PROTECTED ! 13496: # ! 13497: asg15: movl r6,l^kvabe(r10) # store new value ! 13498: addl2 $4*1,(sp) # return to asign caller ! 13499: rsb ! 13500: # ! 13501: # HERE FOR SPECIAL CASE OF STLIMIT ! 13502: # ! 13503: # SINCE STCOUNT IS MAINTAINED AS (STLIMIT-STCOUNT) ! 13504: # IT IS ALSO NECESSARY TO MODIFY STCOUNT APPROPRIATELY. ! 13505: # ! 13506: asg16: subl2 kvstl,r5 # subtract old limit ! 13507: addl2 kvstc,r5 # add old counter ! 13508: movl r5,kvstc # store new counter value ! 13509: movl 4*icval(r9),r5 # reload new limit value ! 13510: movl r5,kvstl # store new limit value ! 13511: addl2 $4*1,(sp) # return to asign caller ! 13512: rsb ! 13513: # ! 13514: # HERE FOR SPECIAL CASE OF ERRTYPE ! 13515: # ! 13516: asg17: cmpl r6,$nini9 # ok to signal if in range ! 13517: bgtru 0f ! 13518: jmp error ! 13519: 0: ! 13520: # ! 13521: # HERE IF VALUE ASSIGNED IS OUT OF RANGE ! 13522: # ! 13523: asg18: jmp er_210 # keyword value assigned is negative or too large ! 13524: # ! 13525: # HERE FOR SPECIAL CASE OF ERRTEXT ! 13526: # ! 13527: asg19: movl r7,-(sp) # stack value ! 13528: jsb gtstg # convert to string ! 13529: .long er_211 # value assigned to keyword errtext not a string ! 13530: movl r9,r$etx # make assignment ! 13531: addl2 $4*1,(sp) # return to caller ! 13532: rsb ! 13533: # ! 13534: # PRINT STRING TO TERMINAL ! 13535: # ! 13536: asg20: jsb prttr # print ! 13537: addl2 $4*1,(sp) # return ! 13538: rsb ! 13539: # ! 13540: # HERE FOR KEYWORD PROFILE ! 13541: # ! 13542: asg21: cmpl r6,$num02 # moan if not 0,1, or 2 ! 13543: bgtru asg18 ! 13544: tstl r6 # just assign if zero ! 13545: beqlu asg15 ! 13546: tstl pfdmp # branch if first assignment ! 13547: beqlu asg22 ! 13548: cmpl r6,pfdmp # also if same value as before ! 13549: beqlu asg23 ! 13550: jmp er_268 # inconsistent value assigned to keyword profile ! 13551: # ! 13552: asg22: movl r6,pfdmp # note value on first assignment ! 13553: asg23: jsb systm # get the time ! 13554: movl r5,pfstm # fudge some kind of start time ! 13555: jmp asg15 # and go assign ! 13556: #enp # end procedure asign ! 13557: #page ! 13558: # ! 13559: # ASINP -- ASSIGN DURING PATTERN MATCH ! 13560: # ! 13561: # ASINP IS LIKE ASIGN AND HAS A SIMILAR CALLING SEQUENCE ! 13562: # AND EFFECT. THE DIFFERENCE IS THAT THE GLOBAL PATTERN ! 13563: # VARIABLES ARE SAVED AND RESTORED IF REQUIRED. ! 13564: # ! 13565: # (XL) BASE POINTER FOR VARIABLE ! 13566: # (WA) OFFSET FOR VARIABLE ! 13567: # (WB) VALUE TO BE ASSIGNED ! 13568: # JSR ASINP CALL TO ASSIGN VALUE TO VARIABLE ! 13569: # PPM LOC TRANSFER LOC IF FAILURE ! 13570: # (XR,XL) DESTROYED ! 13571: # (WA,WB,WC,RA) DESTROYED ! 13572: # ! 13573: asinp: #prc # entry point, recursive ! 13574: addl2 r6,r10 # point to variable ! 13575: movl (r10),r9 # load current contents ! 13576: cmpl (r9),$b$trt # jump if trapped ! 13577: beqlu asnp1 ! 13578: movl r7,(r10) # else perform assignment ! 13579: clrl r10 # clear garbage value in xl ! 13580: addl2 $4*1,(sp) # return to asinp caller ! 13581: rsb ! 13582: # ! 13583: # HERE IF VARIABLE IS TRAPPED ! 13584: # ! 13585: asnp1: subl2 r6,r10 # restore base pointer ! 13586: movl pmssl,-(sp) # stack subject string length ! 13587: movl pmhbs,-(sp) # stack history stack base ptr ! 13588: movl r$pms,-(sp) # stack subject string pointer ! 13589: movl pmdfl,-(sp) # stack dot flag ! 13590: jsb asign # call full-blown assignment routine ! 13591: .long asnp2 # jump if failure ! 13592: movl (sp)+,pmdfl # restore dot flag ! 13593: movl (sp)+,r$pms # restore subject string pointer ! 13594: movl (sp)+,pmhbs # restore history stack base pointer ! 13595: movl (sp)+,pmssl # restore subject string length ! 13596: addl2 $4*1,(sp) # return to asinp caller ! 13597: rsb ! 13598: # ! 13599: # HERE IF FAILURE IN ASIGN CALL ! 13600: # ! 13601: asnp2: movl (sp)+,pmdfl # restore dot flag ! 13602: movl (sp)+,r$pms # restore subject string pointer ! 13603: movl (sp)+,pmhbs # restore history stack base pointer ! 13604: movl (sp)+,pmssl # restore subject string length ! 13605: movl (sp)+,r11 # take failure exit ! 13606: jmp *(r11)+ ! 13607: #enp # end procedure asinp ! 13608: #page ! 13609: # ! 13610: # BLKLN -- DETERMINE LENGTH OF BLOCK ! 13611: # ! 13612: # BLKLN DETERMINES THE LENGTH OF A BLOCK IN DYNAMIC STORE. ! 13613: # ! 13614: # (WA) FIRST WORD OF BLOCK ! 13615: # (XR) POINTER TO BLOCK ! 13616: # JSR BLKLN CALL TO GET BLOCK LENGTH ! 13617: # (WA) LENGTH OF BLOCK IN BYTES ! 13618: # (XL) DESTROYED ! 13619: # ! 13620: # BLKLN IS USED BY THE GARBAGE COLLECTOR AND IS NOT ! 13621: # PERMITTED TO CALL GBCOL DIRECTLY OR INDIRECTLY. ! 13622: # ! 13623: # THE FIRST WORD STORED IN THE BLOCK (I.E. AT XR) MAY ! 13624: # BE ANYTHING, BUT THE CONTENTS OF WA MUST BE CORRECT. ! 13625: # ! 13626: blkln: #prc # entry point ! 13627: movl r6,r10 # copy first word ! 13628: movzwl -2(r10),r10 # get entry id (bl$xx) ! 13629: casel r10,$0,$bl$$$ # switch on block type ! 13630: 5: ! 13631: .word bln01-5b # arblk ! 13632: .word bln04-5b # bcblk ! 13633: .word bln01-5b # cdblk ! 13634: .word bln01-5b # exblk ! 13635: .word bln07-5b # icblk ! 13636: .word bln03-5b # nmblk ! 13637: .word bln02-5b # p0blk ! 13638: .word bln03-5b # p1blk ! 13639: .word bln04-5b # p2blk ! 13640: .word bln09-5b # rcblk ! 13641: .word bln10-5b # scblk ! 13642: .word bln02-5b # seblk ! 13643: .word bln01-5b # tbblk ! 13644: .word bln01-5b # vcblk ! 13645: .word bln00-5b ! 13646: .word bln00-5b ! 13647: .word bln08-5b # pdblk ! 13648: .word bln05-5b # trblk ! 13649: .word bln11-5b # bfblk ! 13650: .word bln00-5b ! 13651: .word bln00-5b ! 13652: .word bln06-5b # ctblk ! 13653: .word bln01-5b # dfblk ! 13654: .word bln01-5b # efblk ! 13655: .word bln03-5b # evblk ! 13656: .word bln05-5b # ffblk ! 13657: .word bln03-5b # kvblk ! 13658: .word bln01-5b # pfblk ! 13659: .word bln04-5b # teblk ! 13660: #esw # end of jump table on block type ! 13661: #page ! 13662: # ! 13663: # BLKLN (CONTINUED) ! 13664: # ! 13665: # HERE FOR BLOCKS WITH LENGTH IN SECOND WORD ! 13666: # ! 13667: bln00: movl 4*1(r9),r6 # load length ! 13668: rsb # return to blkln caller ! 13669: # ! 13670: # HERE FOR LENGTH IN THIRD WORD (AR,CD,DF,EF,EX,PF,TB,VC) ! 13671: # ! 13672: bln01: movl 4*2(r9),r6 # load length from third word ! 13673: rsb # return to blkln caller ! 13674: # ! 13675: # HERE FOR TWO WORD BLOCKS (P0,SE) ! 13676: # ! 13677: bln02: movl $4*num02,r6 # load length (two words) ! 13678: rsb # return to blkln caller ! 13679: # ! 13680: # HERE FOR THREE WORD BLOCKS (NM,P1,EV,KV) ! 13681: # ! 13682: bln03: movl $4*num03,r6 # load length (three words) ! 13683: rsb # return to blkln caller ! 13684: # ! 13685: # HERE FOR FOUR WORD BLOCKS (P2,TE,BC) ! 13686: # ! 13687: bln04: movl $4*num04,r6 # load length (four words) ! 13688: rsb # return to blkln caller ! 13689: # ! 13690: # HERE FOR FIVE WORD BLOCKS (FF,TR) ! 13691: # ! 13692: bln05: movl $4*num05,r6 # load length ! 13693: rsb # return to blkln caller ! 13694: #page ! 13695: # ! 13696: # BLKLN (CONTINUED) ! 13697: # ! 13698: # HERE FOR CTBLK ! 13699: # ! 13700: bln06: movl $4*ctsi$,r6 # set size of ctblk ! 13701: rsb # return to blkln caller ! 13702: # ! 13703: # HERE FOR ICBLK ! 13704: # ! 13705: bln07: movl $4*icsi$,r6 # set size of icblk ! 13706: rsb # return to blkln caller ! 13707: # ! 13708: # HERE FOR PDBLK ! 13709: # ! 13710: bln08: movl 4*pddfp(r9),r10 # point to dfblk ! 13711: movl 4*dfpdl(r10),r6 # load pdblk length from dfblk ! 13712: rsb # return to blkln caller ! 13713: # ! 13714: # HERE FOR RCBLK ! 13715: # ! 13716: bln09: movl $4*rcsi$,r6 # set size of rcblk ! 13717: rsb # return to blkln caller ! 13718: # ! 13719: # HERE FOR SCBLK ! 13720: # ! 13721: bln10: movl 4*sclen(r9),r6 # load length in characters ! 13722: movab 3+(4*scsi$)(r6),r6 # calculate length in bytes ! 13723: bicl2 $3,r6 ! 13724: rsb # return to blkln caller ! 13725: # ! 13726: # HERE FOR BFBLK ! 13727: # ! 13728: bln11: movl 4*bfalc(r9),r6 # get allocation in bytes ! 13729: movab 3+(4*bfsi$)(r6),r6 # calculate length in bytes ! 13730: bicl2 $3,r6 ! 13731: rsb # return to blkln caller ! 13732: #enp # end procedure blkln ! 13733: #page ! 13734: # ! 13735: # COPYB -- COPY A BLOCK ! 13736: # ! 13737: # (XS) BLOCK TO BE COPIED ! 13738: # JSR COPYB CALL TO COPY BLOCK ! 13739: # PPM LOC RETURN IF BLOCK HAS NO IDVAL FIELD ! 13740: # NORMAL RETURN IF IDVAL FIELD ! 13741: # (XR) COPY OF BLOCK ! 13742: # (XS) POPPED ! 13743: # (XL,WA,WB,WC) DESTROYED ! 13744: # ! 13745: .data 1 ! 13746: copyb_s: .long 0 ! 13747: .text 0 ! 13748: copyb: movl (sp)+,copyb_s # entry point ! 13749: movl (sp),r9 # load argument ! 13750: cmpl r9,$nulls # return argument if it is null ! 13751: bnequ 0f ! 13752: jmp cop10 ! 13753: 0: ! 13754: movl (r9),r6 # else load type word ! 13755: movl r6,r7 # copy type word ! 13756: jsb blkln # get length of argument block ! 13757: movl r9,r10 # copy pointer ! 13758: jsb alloc # allocate block of same size ! 13759: movl r9,(sp) # store pointer to copy ! 13760: jsb sbmvw # copy contents of old block to new ! 13761: movl (sp),r9 # reload pointer to start of copy ! 13762: cmpl r7,$b$tbt # jump if table ! 13763: beqlu cop05 ! 13764: cmpl r7,$b$vct # jump if vector ! 13765: beqlu cop01 ! 13766: cmpl r7,$b$pdt # jump if program defined ! 13767: beqlu cop01 ! 13768: cmpl r7,$b$bct # jump if buffer ! 13769: bnequ 0f ! 13770: jmp cop11 ! 13771: 0: ! 13772: cmpl r7,$b$art # return copy if not array ! 13773: beqlu 0f ! 13774: jmp cop10 ! 13775: 0: ! 13776: # ! 13777: # HERE FOR ARRAY (ARBLK) ! 13778: # ! 13779: addl2 4*arofs(r9),r9 # point to prototype field ! 13780: jmp cop02 # jump to merge ! 13781: # ! 13782: # HERE FOR VECTOR, PROGRAM DEFINED ! 13783: # ! 13784: cop01: addl2 $4*pdfld,r9 # point to pdfld = vcvls ! 13785: # ! 13786: # MERGE HERE FOR ARBLK, VCBLK, PDBLK TO DELETE TRAP ! 13787: # BLOCKS FROM ALL VALUE FIELDS (THE COPY IS UNTRAPPED) ! 13788: # ! 13789: cop02: movl (r9),r10 # load next pointer ! 13790: # ! 13791: # LOOP TO GET VALUE AT END OF TRBLK CHAIN ! 13792: # ! 13793: cop03: cmpl (r10),$b$trt # jump if not trapped ! 13794: bnequ cop04 ! 13795: movl 4*trval(r10),r10# else point to next value ! 13796: jmp cop03 # and loop back ! 13797: #page ! 13798: # ! 13799: # COPYB (CONTINUED) ! 13800: # ! 13801: # HERE WITH UNTRAPPED VALUE IN XL ! 13802: # ! 13803: cop04: movl r10,(r9)+ # store real value, bump pointer ! 13804: cmpl r9,dnamp # loop back if more to go ! 13805: bnequ cop02 ! 13806: jmp cop09 # else jump to exit ! 13807: # ! 13808: # HERE TO COPY A TABLE ! 13809: # ! 13810: cop05: clrl 4*idval(r9) # zero id to stop dump blowing up ! 13811: movl $4*tesi$,r6 # set size of teblk ! 13812: movl $4*tbbuk,r8 # set initial offset ! 13813: # ! 13814: # LOOP THROUGH BUCKETS IN TABLE ! 13815: # ! 13816: cop06: movl (sp),r9 # load table pointer ! 13817: cmpl r8,4*tblen(r9) # jump to exit if all done ! 13818: beqlu cop09 ! 13819: addl2 r8,r9 # else point to next bucket header ! 13820: addl2 $4,r8 # bump offset ! 13821: subl2 $4*tenxt,r9 # subtract link offset to merge ! 13822: # ! 13823: # LOOP THROUGH TEBLKS ON ONE CHAIN ! 13824: # ! 13825: cop07: movl 4*tenxt(r9),r10 # load pointer to next teblk ! 13826: movl (sp),4*tenxt(r9)# set end of chain pointer in case ! 13827: cmpl (r10),$b$tbt # back for next bucket if chain end ! 13828: beqlu cop06 ! 13829: movl r9,-(sp) # else stack ptr to previous block ! 13830: movl $4*tesi$,r6 # set size of teblk ! 13831: jsb alloc # allocate new teblk ! 13832: movl r9,r7 # save ptr to new teblk ! 13833: jsb sbmvw # copy old teblk to new teblk ! 13834: movl r7,r9 # restore pointer to new teblk ! 13835: movl (sp)+,r10 # restore pointer to previous block ! 13836: movl r9,4*tenxt(r10) # link new block to previous ! 13837: movl r9,r10 # copy pointer to new block ! 13838: # ! 13839: # LOOP TO SET REAL VALUE AFTER REMOVING TRAP CHAIN ! 13840: # ! 13841: cop08: movl 4*teval(r10),r10# load value ! 13842: cmpl (r10),$b$trt # loop back if trapped ! 13843: beqlu cop08 ! 13844: movl r10,4*teval(r9) # store untrapped value in teblk ! 13845: jmp cop07 # back for next teblk ! 13846: # ! 13847: # COMMON EXIT POINT ! 13848: # ! 13849: cop09: movl (sp)+,r9 # load pointer to block ! 13850: addl3 $4*1,copyb_s,r11 # return ! 13851: jmp (r11) ! 13852: # ! 13853: # ALTERNATIVE RETURN ! 13854: # ! 13855: cop10: movl copyb_s,r11 # return ! 13856: jmp *(r11)+ ! 13857: #page ! 13858: # ! 13859: # HERE TO COPY BUFFER ! 13860: # ! 13861: cop11: movl 4*bcbuf(r9),r10 # get bfblk ptr ! 13862: movl 4*bfalc(r10),r6 # get allocation ! 13863: movab 3+(4*bfsi$)(r6),r6 # set total size ! 13864: bicl2 $3,r6 ! 13865: movl r9,r10 # save bcblk ptr ! 13866: jsb alloc # allocate bfblk ! 13867: movl 4*bcbuf(r10),r7 # get old bfblk ! 13868: movl r9,4*bcbuf(r10) # set pointer to new bfblk ! 13869: movl r7,r10 # point to old bfblk ! 13870: jsb sbmvw # copy bfblk too ! 13871: clrl r10 # clear rubbish ptr ! 13872: jmp cop09 # branch to exit ! 13873: #enp # end procedure copyb ! 13874: # ! 13875: # CDGCG -- GENERATE CODE FOR COMPLEX GOTO ! 13876: # ! 13877: # USED BY CMPIL TO PROCESS COMPLEX GOTO TREE ! 13878: # ! 13879: # (WB) MUST BE COLLECTABLE ! 13880: # (XR) EXPRESSION POINTER ! 13881: # JSR CDGCG CALL TO GENERATE COMPLEX GOTO ! 13882: # (XL,XR,WA) DESTROYED ! 13883: # ! 13884: cdgcg: #prc # entry point ! 13885: movl 4*cmopn(r9),r10 # get unary goto operator ! 13886: movl 4*cmrop(r9),r9 # point to goto operand ! 13887: cmpl r10,$opdvd # jump if direct goto ! 13888: beqlu cdgc2 ! 13889: jsb cdgnm # generate opnd by name if not direct ! 13890: # ! 13891: # RETURN POINT ! 13892: # ! 13893: cdgc1: movl r10,r6 # goto operator ! 13894: jsb cdwrd # generate it ! 13895: rsb # return to caller ! 13896: # ! 13897: # DIRECT GOTO ! 13898: # ! 13899: cdgc2: jsb cdgvl # generate operand by value ! 13900: jmp cdgc1 # merge to return ! 13901: #enp # end procedure cdgcg ! 13902: #page ! 13903: # ! 13904: # CDGEX -- BUILD EXPRESSION BLOCK ! 13905: # ! 13906: # CDGEX IS PASSED A POINTER TO AN EXPRESSION TREE (SEE ! 13907: # EXPAN) AND RETURNS AN EXPRESSION (SEBLK OR EXBLK). ! 13908: # ! 13909: # (WC) SOME COLLECTABLE VALUE ! 13910: # (WB) INTEGER IN RANGE 0 LE X LE MXLEN ! 13911: # (XL) PTR TO EXPRESSION TREE ! 13912: # JSR CDGEX CALL TO BUILD EXPRESSION ! 13913: # (XR) PTR TO SEBLK OR EXBLK ! 13914: # (XL,WA,WB) DESTROYED ! 13915: # ! 13916: cdgex: #prc # entry point, recursive ! 13917: cmpl (r10),$b$vr$ # jump if not variable ! 13918: blequ cdgx1 ! 13919: # ! 13920: # HERE FOR NATURAL VARIABLE, BUILD SEBLK ! 13921: # ! 13922: movl $4*sesi$,r6 # set size of seblk ! 13923: jsb alloc # allocate space for seblk ! 13924: movl $b$sel,(r9) # set type word ! 13925: movl r10,4*sevar(r9) # store vrblk pointer ! 13926: rsb # return to cdgex caller ! 13927: # ! 13928: # HERE IF NOT VARIABLE, BUILD EXBLK ! 13929: # ! 13930: cdgx1: movl r10,r9 # copy tree pointer ! 13931: movl r8,-(sp) # save wc ! 13932: movl cwcof,r10 # save current offset ! 13933: movl (r9),r6 # get type word ! 13934: cmpl r6,$b$cmt # call by value if not cmblk ! 13935: bnequ cdgx2 ! 13936: cmpl 4*cmtyp(r9),$c$$nm # jump if cmblk only by value ! 13937: bgequ cdgx2 ! 13938: #page ! 13939: # ! 13940: # CDGEX (CONTINUED) ! 13941: # ! 13942: # HERE IF EXPRESSION CAN BE EVALUATED BY NAME ! 13943: # ! 13944: jsb cdgnm # generate code by name ! 13945: movl $ornm$,r6 # load return by name word ! 13946: jmp cdgx3 # merge with value case ! 13947: # ! 13948: # HERE IF EXPRESSION CAN ONLY BE EVALUATED BY VALUE ! 13949: # ! 13950: cdgx2: jsb cdgvl # generate code by value ! 13951: movl $orvl$,r6 # load return by value word ! 13952: # ! 13953: # MERGE HERE TO CONSTRUCT EXBLK ! 13954: # ! 13955: cdgx3: jsb cdwrd # generate return word ! 13956: jsb exbld # build exblk ! 13957: movl (sp)+,r8 # restore wc ! 13958: rsb # return to cdgex caller ! 13959: #enp # end procedure cdgex ! 13960: #page ! 13961: # ! 13962: # CDGNM -- GENERATE CODE BY NAME ! 13963: # ! 13964: # CDGNM IS CALLED DURING THE COMPILATION PROCESS TO ! 13965: # GENERATE CODE BY NAME FOR AN EXPRESSION. SEE CDBLK ! 13966: # DESCRIPTION FOR DETAILS OF CODE GENERATED. THE INPUT ! 13967: # TO CDGNM IS AN EXPRESSION TREE AS GENERATED BY EXPAN. ! 13968: # ! 13969: # CDGNM IS A RECURSIVE PROCEDURE WHICH PROCEEDS BY MAKING ! 13970: # RECURSIVE CALLS TO GENERATE CODE FOR OPERANDS. ! 13971: # ! 13972: # (WB) INTEGER IN RANGE 0 LE N LE DNAMB ! 13973: # (XR) PTR TO TREE GENERATED BY EXPAN ! 13974: # (WC) CONSTANT FLAG (SEE BELOW) ! 13975: # JSR CDGNM CALL TO GENERATE CODE BY NAME ! 13976: # (XR,WA) DESTROYED ! 13977: # (WC) SET NON-ZERO IF NON-CONSTANT ! 13978: # ! 13979: # WC IS SET TO A NON-ZERO (COLLECTABLE) VALUE IF THE ! 13980: # EXPRESSION FOR WHICH CODE IS GENERATED CANNOT BE ! 13981: # EVALUATED AT COMPILE TIME, OTHERWISE WC IS UNCHANGED. ! 13982: # ! 13983: # THE CODE IS GENERATED IN THE CURRENT CCBLK (SEE CDWRD). ! 13984: # ! 13985: cdgnm: #prc # entry point, recursive ! 13986: movl r10,-(sp) # save entry xl ! 13987: movl r7,-(sp) # save entry wb ! 13988: jsb sbchk # check for stack overflow ! 13989: movl (r9),r6 # load type word ! 13990: cmpl r6,$b$cmt # jump if cmblk ! 13991: beqlu cgn04 ! 13992: cmpl r6,$b$vr$ # jump if simple variable ! 13993: blssu 0f ! 13994: jmp cgn02 ! 13995: 0: ! 13996: # ! 13997: # MERGE HERE FOR OPERAND YIELDING VALUE (E.G. CONSTANT) ! 13998: # ! 13999: cgn01: jmp er_212 # syntax error. value used where name is required ! 14000: # ! 14001: # HERE FOR NATURAL VARIABLE REFERENCE ! 14002: # ! 14003: cgn02: movl $olvn$,r6 # load variable load call ! 14004: jsb cdwrd # generate it ! 14005: movl r9,r6 # copy vrblk pointer ! 14006: jsb cdwrd # generate vrblk pointer ! 14007: #page ! 14008: # ! 14009: # CDGNM (CONTINUED) ! 14010: # ! 14011: # HERE TO EXIT WITH WC SET CORRECTLY ! 14012: # ! 14013: cgn03: movl (sp)+,r7 # restore entry wb ! 14014: movl (sp)+,r10 # restore entry xl ! 14015: rsb # return to cdgnm caller ! 14016: # ! 14017: # HERE FOR CMBLK ! 14018: # ! 14019: cgn04: movl r9,r10 # copy cmblk pointer ! 14020: movl 4*cmtyp(r9),r9 # load cmblk type ! 14021: cmpl r9,$c$$nm # error if not name operand ! 14022: bgequ cgn01 ! 14023: casel r9,$0,$c$$nm # else switch on type ! 14024: 5: ! 14025: .word cgn05-5b # array reference ! 14026: .word cgn08-5b # function call ! 14027: .word cgn09-5b # deferred expression ! 14028: .word cgn10-5b # indirect reference ! 14029: .word cgn11-5b # keyword reference ! 14030: .word cgn08-5b # undefined binary op ! 14031: .word cgn08-5b # undefined unary op ! 14032: #esw # end switch on cmblk type ! 14033: # ! 14034: # HERE TO GENERATE CODE FOR ARRAY REFERENCE ! 14035: # ! 14036: cgn05: movl $4*cmopn,r7 # point to array operand ! 14037: # ! 14038: # LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS ! 14039: # ! 14040: cgn06: jsb cmgen # generate code for next operand ! 14041: movl 4*cmlen(r10),r8 # load length of cmblk ! 14042: cmpl r7,r8 # loop till all generated ! 14043: blssu cgn06 ! 14044: # ! 14045: # GENERATE APPROPRIATE ARRAY CALL ! 14046: # ! 14047: movl $oaon$,r6 # load one-subscript case call ! 14048: cmpl r8,$4*cmar1 # jump to exit if one subscript case ! 14049: beqlu cgn07 ! 14050: movl $oamn$,r6 # else load multi-subscript case call ! 14051: jsb cdwrd # generate call ! 14052: movl r8,r6 # copy cmblk length ! 14053: ashl $-2,r6,r6 # convert to words ! 14054: subl2 $cmvls,r6 # calculate number of subscripts ! 14055: #page ! 14056: # ! 14057: # CDGNM (CONTINUED) ! 14058: # ! 14059: # HERE TO EXIT GENERATING WORD (NON-CONSTANT) ! 14060: # ! 14061: cgn07: movl sp,r8 # set result non-constant ! 14062: jsb cdwrd # generate word ! 14063: jmp cgn03 # back to exit ! 14064: # ! 14065: # HERE TO GENERATE CODE FOR FUNCTIONS AND UNDEFINED OPRS ! 14066: # ! 14067: cgn08: movl r10,r9 # copy cmblk pointer ! 14068: jsb cdgvl # gen code by value for call ! 14069: movl $ofne$,r6 # get extra call for by name ! 14070: jmp cgn07 # back to generate and exit ! 14071: # ! 14072: # HERE TO GENERATE CODE FOR DEFERED EXPRESSION ! 14073: # ! 14074: cgn09: movl 4*cmrop(r10),r9 # check if variable ! 14075: cmpl (r9),$b$vr$ # treat *variable as simple var ! 14076: blssu 0f ! 14077: jmp cgn02 ! 14078: 0: ! 14079: movl r9,r10 # copy ptr to expression tree ! 14080: jsb cdgex # else build exblk ! 14081: movl $olex$,r6 # set call to load expr by name ! 14082: jsb cdwrd # generate it ! 14083: movl r9,r6 # copy exblk pointer ! 14084: jsb cdwrd # generate exblk pointer ! 14085: jmp cgn03 # back to exit ! 14086: # ! 14087: # HERE TO GENERATE CODE FOR INDIRECT REFERENCE ! 14088: # ! 14089: cgn10: movl 4*cmrop(r10),r9 # get operand ! 14090: jsb cdgvl # generate code by value for it ! 14091: movl $oinn$,r6 # load call for indirect by name ! 14092: jmp cgn12 # merge ! 14093: # ! 14094: # HERE TO GENERATE CODE FOR KEYWORD REFERENCE ! 14095: # ! 14096: cgn11: movl 4*cmrop(r10),r9 # get operand ! 14097: jsb cdgnm # generate code by name for it ! 14098: movl $okwn$,r6 # load call for keyword by name ! 14099: # ! 14100: # KEYWORD, INDIRECT MERGE HERE ! 14101: # ! 14102: cgn12: jsb cdwrd # generate code for operator ! 14103: jmp cgn03 # exit ! 14104: #enp # end procedure cdgnm ! 14105: #page ! 14106: # ! 14107: # CDGVL -- GENERATE CODE BY VALUE ! 14108: # ! 14109: # CDGVL IS CALLED DURING THE COMPILATION PROCESS TO ! 14110: # GENERATE CODE BY VALUE FOR AN EXPRESSION. SEE CDBLK ! 14111: # DESCRIPTION FOR DETAILS OF THE CODE GENERATED. THE INPUT ! 14112: # TO CDGVL IS AN EXPRESSION TREE AS GENERATED BY EXPAN. ! 14113: # ! 14114: # CDGVL IS A RECURSIVE PROCEDURE WHICH PROCEEDS BY MAKING ! 14115: # RECURSIVE CALLS TO GENERATE CODE FOR OPERANDS. ! 14116: # ! 14117: # (WB) INTEGER IN RANGE 0 LE N LE DNAMB ! 14118: # (XR) PTR TO TREE GENERATED BY EXPAN ! 14119: # (WC) CONSTANT FLAG (SEE BELOW) ! 14120: # JSR CDGVL CALL TO GENERATE CODE BY VALUE ! 14121: # (XR,WA) DESTROYED ! 14122: # (WC) SET NON-ZERO IF NON-CONSTANT ! 14123: # ! 14124: # WC IS SET TO A NON-ZERO (COLLECTABLE) VALUE IF THE ! 14125: # EXPRESSION FOR WHICH CODE IS GENERATED CANNOT BE ! 14126: # EVALUATED AT COMPILE TIME, OTHERWISE WC IS UNCHANGED. ! 14127: # ! 14128: # IF WC IS NON-ZERO ON ENTRY, THEN PREEVALUATION IS NOT ! 14129: # ALLOWED REGARDLESS OF THE NATURE OF THE OPERAND. ! 14130: # ! 14131: # THE CODE IS GENERATED IN THE CURRENT CCBLK (SEE CDWRD). ! 14132: # ! 14133: cdgvl: #prc # entry point, recursive ! 14134: movl (r9),r6 # load type word ! 14135: cmpl r6,$b$cmt # jump if cmblk ! 14136: beqlu cgv01 ! 14137: cmpl r6,$b$vra # jump if icblk, rcblk, scblk ! 14138: blssu cgv00 ! 14139: tstl 4*vrlen(r9) # jump if not system variable ! 14140: bnequ cgvl0 ! 14141: movl r9,-(sp) # stack xr ! 14142: movl 4*vrsvp(r9),r9 # point to svblk ! 14143: movl 4*svbit(r9),r6 # get svblk property bits ! 14144: movl (sp)+,r9 # recover xr ! 14145: mcoml btckw,r11 # check if constant keyword ! 14146: bicl2 r11,r6 ! 14147: bnequ cgv00 # jump if constant keyword ! 14148: # ! 14149: # HERE FOR VARIABLE VALUE REFERENCE ! 14150: # ! 14151: cgvl0: movl sp,r8 # indicate non-constant value ! 14152: # ! 14153: # MERGE HERE FOR SIMPLE CONSTANT (ICBLK,RCBLK,SCBLK) ! 14154: # AND FOR VARIABLES CORRESPONDING TO CONSTANT KEYWORDS. ! 14155: # ! 14156: cgv00: movl r9,r6 # copy ptr to var or constant ! 14157: jsb cdwrd # generate as code word ! 14158: rsb # return to caller ! 14159: #page ! 14160: # ! 14161: # CDGVL (CONTINUED) ! 14162: # ! 14163: # HERE FOR TREE NODE (CMBLK) ! 14164: # ! 14165: cgv01: movl r7,-(sp) # save entry wb ! 14166: movl r10,-(sp) # save entry xl ! 14167: movl r8,-(sp) # save entry constant flag ! 14168: movl cwcof,-(sp) # save initial code offset ! 14169: jsb sbchk # check for stack overflow ! 14170: # ! 14171: # PREPARE TO GENERATE CODE FOR CMBLK. WC IS SET TO THE ! 14172: # VALUE OF CSWNO (ZERO IF -OPTIMISE, 1 IF -NOOPT) TO ! 14173: # START WITH AND IS RESET NON-ZERO FOR ANY NON-CONSTANT ! 14174: # CODE GENERATED. IF IT IS STILL ZERO AFTER GENERATING ALL ! 14175: # THE CMBLK CODE, THEN ITS VALUE IS COMPUTED AS THE RESULT. ! 14176: # ! 14177: movl r9,r10 # copy cmblk pointer ! 14178: movl 4*cmtyp(r9),r9 # load cmblk type ! 14179: movl cswno,r8 # reset constant flag ! 14180: cmpl r9,$c$pr$ # jump if not predicate value ! 14181: blequ cgv02 ! 14182: movl sp,r8 # else force non-constant case ! 14183: # ! 14184: # HERE WITH WC SET APPROPRIATELY ! 14185: # ! 14186: cgv02: casel r9,$0,$c$$nv # switch to appropriate generator ! 14187: 5: ! 14188: .word cgv03-5b # array reference ! 14189: .word cgv05-5b # function call ! 14190: .word cgv14-5b # deferred expression ! 14191: .word cgv31-5b # indirect reference ! 14192: .word cgv27-5b # keyword reference ! 14193: .word cgv29-5b # undefined binop ! 14194: .word cgv30-5b # undefined unop ! 14195: .word cgv18-5b # binops with val opds ! 14196: .word cgv19-5b # unops with valu opnd ! 14197: .word cgv18-5b # alternation ! 14198: .word cgv24-5b # concatenation ! 14199: .word cgv24-5b # concatenation (not pattern match) ! 14200: .word cgv27-5b # unops with name opnd ! 14201: .word cgv26-5b # binary $ and . ! 14202: .word cgv21-5b # assignment ! 14203: .word cgv31-5b # interrogation ! 14204: .word cgv28-5b # negation ! 14205: .word cgv15-5b # selection ! 14206: .word cgv18-5b # pattern match ! 14207: #esw # end switch on cmblk type ! 14208: #page ! 14209: # ! 14210: # CDGVL (CONTINUED) ! 14211: # ! 14212: # HERE TO GENERATE CODE FOR ARRAY REFERENCE ! 14213: # ! 14214: cgv03: movl $4*cmopn,r7 # set offset to array operand ! 14215: # ! 14216: # LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS ! 14217: # ! 14218: cgv04: jsb cmgen # gen value code for next operand ! 14219: movl 4*cmlen(r10),r8 # load cmblk length ! 14220: cmpl r7,r8 # loop back if more to go ! 14221: blssu cgv04 ! 14222: # ! 14223: # GENERATE CALL TO APPROPRIATE ARRAY REFERENCE ROUTINE ! 14224: # ! 14225: movl $oaov$,r6 # set one subscript call in case ! 14226: cmpl r8,$4*cmar1 # jump to exit if 1-sub case ! 14227: bnequ 0f ! 14228: jmp cgv32 ! 14229: 0: ! 14230: movl $oamv$,r6 # else set call for multi-subscripts ! 14231: jsb cdwrd # generate call ! 14232: movl r8,r6 # copy length of cmblk ! 14233: subl2 $4*cmvls,r6 # subtract standard length ! 14234: ashl $-2,r6,r6 # get number of words ! 14235: jmp cgv32 # jump to generate subscript count ! 14236: # ! 14237: # HERE TO GENERATE CODE FOR FUNCTION CALL ! 14238: # ! 14239: cgv05: movl $4*cmvls,r7 # set offset to first argument ! 14240: # ! 14241: # LOOP TO GENERATE CODE FOR ARGUMENTS ! 14242: # ! 14243: cgv06: cmpl r7,4*cmlen(r10) # jump if all generated ! 14244: beqlu cgv07 ! 14245: jsb cmgen # else gen value code for next arg ! 14246: jmp cgv06 # back to generate next argument ! 14247: # ! 14248: # HERE TO GENERATE ACTUAL FUNCTION CALL ! 14249: # ! 14250: cgv07: subl2 $4*cmvls,r7 # get number of arg ptrs (bytes) ! 14251: ashl $-2,r7,r7 # convert bytes to words ! 14252: movl 4*cmopn(r10),r9 # load function vrblk pointer ! 14253: tstl 4*vrlen(r9) # jump if not system function ! 14254: bnequ cgv12 ! 14255: movl 4*vrsvp(r9),r10 # load svblk ptr if system var ! 14256: movl 4*svbit(r10),r6 # load bit mask ! 14257: mcoml btffc,r11 # test for fast function call allowed ! 14258: bicl2 r11,r6 ! 14259: beqlu cgv12 # jump if not ! 14260: #page ! 14261: # ! 14262: # CDGVL (CONTINUED) ! 14263: # ! 14264: # HERE IF FAST FUNCTION CALL IS ALLOWED ! 14265: # ! 14266: movl 4*svbit(r10),r6 # reload bit indicators ! 14267: mcoml btpre,r11 # test for preevaluation ok ! 14268: bicl2 r11,r6 ! 14269: bnequ cgv08 # jump if preevaluation permitted ! 14270: movl sp,r8 # else set result non-constant ! 14271: # ! 14272: # TEST FOR CORRECT NUMBER OF ARGS FOR FAST CALL ! 14273: # ! 14274: cgv08: movl 4*vrfnc(r9),r10 # load ptr to svfnc field ! 14275: movl 4*fargs(r10),r6 # load svnar field value ! 14276: cmpl r6,r7 # jump if argument count is correct ! 14277: beqlu cgv11 ! 14278: cmpl r6,r7 # jump if too few arguments given ! 14279: bgequ cgv09 ! 14280: # ! 14281: # HERE IF TOO MANY ARGUMENTS, PREPARE TO GENERATE O$POPS ! 14282: # ! 14283: subl2 r6,r7 # get number of extra args ! 14284: # set as count to control loop ! 14285: movl $opop$,r6 # set pop call ! 14286: jmp cgv10 # jump to common loop ! 14287: # ! 14288: # HERE IF TOO FEW ARGUMENTS, PREPARE TO GENERATE NULLS ! 14289: # ! 14290: cgv09: subl2 r7,r6 # get number of missing arguments ! 14291: movl r6,r7 # load as count to control loop ! 14292: movl $nulls,r6 # load ptr to null constant ! 14293: # ! 14294: # LOOP TO GENERATE CALLS TO FIX ARGUMENT COUNT ! 14295: # ! 14296: cgv10: jsb cdwrd # generate one call ! 14297: sobgtr r7,cgv10 # loop till all generated ! 14298: # ! 14299: # HERE AFTER ADJUSTING ARG COUNT AS REQUIRED ! 14300: # ! 14301: cgv11: movl r10,r6 # copy pointer to svfnc field ! 14302: jmp cgv36 # jump to generate call ! 14303: #page ! 14304: # ! 14305: # CDGVL (CONTINUED) ! 14306: # ! 14307: # COME HERE IF FAST CALL IS NOT PERMITTED ! 14308: # ! 14309: cgv12: movl $ofns$,r6 # set one arg call in case ! 14310: cmpl r7,$num01 # jump if one arg case ! 14311: beqlu cgv13 ! 14312: movl $ofnc$,r6 # else load call for more than 1 arg ! 14313: jsb cdwrd # generate it ! 14314: movl r7,r6 # copy argument count ! 14315: # ! 14316: # ONE ARG CASE MERGES HERE ! 14317: # ! 14318: cgv13: jsb cdwrd # generate =o$fns or arg count ! 14319: movl r9,r6 # copy vrblk pointer ! 14320: jmp cgv32 # jump to generate vrblk ptr ! 14321: # ! 14322: # HERE FOR DEFERRED EXPRESSION ! 14323: # ! 14324: cgv14: movl 4*cmrop(r10),r10# point to expression tree ! 14325: jsb cdgex # build exblk or seblk ! 14326: movl r9,r6 # copy block ptr ! 14327: jsb cdwrd # generate ptr to exblk or seblk ! 14328: jmp cgv34 # jump to exit, constant test ! 14329: # ! 14330: # HERE TO GENERATE CODE FOR SELECTION ! 14331: # ! 14332: cgv15: clrl -(sp) # zero ptr to chain of forward jumps ! 14333: clrl -(sp) # zero ptr to prev o$slc forward ptr ! 14334: movl $4*cmvls,r7 # point to first alternative ! 14335: movl $osla$,r6 # set initial code word ! 14336: # ! 14337: # 0(XS) IS THE OFFSET TO THE PREVIOUS WORD ! 14338: # WHICH REQUIRES FILLING IN WITH AN ! 14339: # OFFSET TO THE FOLLOWING O$SLC,O$SLD ! 14340: # ! 14341: # 1(XS) IS THE HEAD OF A CHAIN OF OFFSET ! 14342: # POINTERS INDICATING THOSE LOCATIONS ! 14343: # TO BE FILLED WITH OFFSETS PAST ! 14344: # THE END OF ALL THE ALTERNATIVES ! 14345: # ! 14346: cgv16: jsb cdwrd # generate o$slc (o$sla first time) ! 14347: movl cwcof,(sp) # set current loc as ptr to fill in ! 14348: jsb cdwrd # generate garbage word there for now ! 14349: jsb cmgen # gen value code for alternative ! 14350: movl $oslb$,r6 # load o$slb pointer ! 14351: jsb cdwrd # generate o$slb call ! 14352: movl 4*1(sp),r6 # load old chain ptr ! 14353: movl cwcof,4*1(sp) # set current loc as new chain head ! 14354: jsb cdwrd # generate forward chain link ! 14355: #page ! 14356: # ! 14357: # CDGVL (CONTINUED) ! 14358: # ! 14359: # NOW TO FILL IN THE SKIP OFFSET TO O$SLC,O$SLD ! 14360: # ! 14361: movl (sp),r9 # load offset to word to plug ! 14362: addl2 r$ccb,r9 # point to actual location to plug ! 14363: movl cwcof,(r9) # plug proper offset in ! 14364: movl $oslc$,r6 # load o$slc ptr for next alternative ! 14365: movl r7,r9 # copy offset (destroy garbage xr) ! 14366: addl2 $4,r9 # bump extra time for test ! 14367: cmpl r9,4*cmlen(r10) # loop back if not last alternative ! 14368: blssu cgv16 ! 14369: # ! 14370: # HERE TO GENERATE CODE FOR LAST ALTERNATIVE ! 14371: # ! 14372: movl $osld$,r6 # get header call ! 14373: jsb cdwrd # generate o$sld call ! 14374: jsb cmgen # generate code for last alternative ! 14375: addl2 $4,sp # pop offset ptr ! 14376: movl (sp)+,r9 # load chain ptr ! 14377: # ! 14378: # LOOP TO PLUG OFFSETS PAST STRUCTURE ! 14379: # ! 14380: cgv17: addl2 r$ccb,r9 # make next ptr absolute ! 14381: movl (r9),r6 # load forward ptr ! 14382: movl cwcof,(r9) # plug required offset ! 14383: movl r6,r9 # copy forward ptr ! 14384: tstl r6 # loop back if more to go ! 14385: bnequ cgv17 ! 14386: jmp cgv33 # else jump to exit (not constant) ! 14387: # ! 14388: # HERE FOR BINARY OPS WITH VALUE OPERANDS ! 14389: # ! 14390: cgv18: movl 4*cmlop(r10),r9 # load left operand pointer ! 14391: jsb cdgvl # gen value code for left operand ! 14392: # ! 14393: # HERE FOR UNARY OPS WITH VALUE OPERAND (BINOPS MERGE) ! 14394: # ! 14395: cgv19: movl 4*cmrop(r10),r9 # load right (only) operand ptr ! 14396: jsb cdgvl # gen code by value ! 14397: #page ! 14398: # ! 14399: # CDGVL (CONTINUED) ! 14400: # ! 14401: # MERGE HERE TO GENERATE OPERATOR CALL FROM CMOPN FIELD ! 14402: # ! 14403: cgv20: movl 4*cmopn(r10),r6 # load operator call pointer ! 14404: jmp cgv36 # jump to generate it with cons test ! 14405: # ! 14406: # HERE FOR ASSIGNMENT ! 14407: # ! 14408: cgv21: movl 4*cmlop(r10),r9 # load left operand pointer ! 14409: cmpl (r9),$b$vr$ # jump if not variable ! 14410: blequ cgv22 ! 14411: # ! 14412: # HERE FOR ASSIGNMENT TO SIMPLE VARIABLE ! 14413: # ! 14414: movl 4*cmrop(r10),r9 # load right operand ptr ! 14415: jsb cdgvl # generate code by value ! 14416: movl 4*cmlop(r10),r6 # reload left operand vrblk ptr ! 14417: addl2 $4*vrsto,r6 # point to vrsto field ! 14418: jmp cgv32 # jump to generate store ptr ! 14419: # ! 14420: # HERE IF NOT SIMPLE VARIABLE ASSIGNMENT ! 14421: # ! 14422: cgv22: jsb expap # test for pattern match on left side ! 14423: .long cgv23 # jump if not pattern match ! 14424: # ! 14425: # HERE FOR PATTERN REPLACEMENT ! 14426: # ! 14427: movl 4*cmrop(r9),4*cmlop(r10) # save pattern ptr in safe place ! 14428: movl 4*cmlop(r9),r9 # load subject ptr ! 14429: jsb cdgnm # gen code by name for subject ! 14430: movl 4*cmlop(r10),r9 # load pattern ptr ! 14431: jsb cdgvl # gen code by value for pattern ! 14432: movl $opmn$,r6 # load match by name call ! 14433: jsb cdwrd # generate it ! 14434: movl 4*cmrop(r10),r9 # load replacement value ptr ! 14435: jsb cdgvl # gen code by value ! 14436: movl $orpl$,r6 # load replace call ! 14437: jmp cgv32 # jump to gen and exit (not constant) ! 14438: # ! 14439: # HERE FOR ASSIGNMENT TO COMPLEX VARIABLE ! 14440: # ! 14441: cgv23: movl sp,r8 # inhibit pre-evaluation ! 14442: jsb cdgnm # gen code by name for left side ! 14443: jmp cgv31 # merge with unop circuit ! 14444: #page ! 14445: # ! 14446: # CDGVL (CONTINUED) ! 14447: # ! 14448: # HERE FOR CONCATENATION ! 14449: # ! 14450: cgv24: movl 4*cmlop(r10),r9 # load left operand ptr ! 14451: cmpl (r9),$b$cmt # ordinary binop if not cmblk ! 14452: beqlu 0f ! 14453: jmp cgv18 ! 14454: 0: ! 14455: movl 4*cmtyp(r9),r7 # load cmblk type code ! 14456: cmpl r7,$c$int # special case if interrogation ! 14457: beqlu cgv25 ! 14458: cmpl r7,$c$neg # or negation ! 14459: beqlu cgv25 ! 14460: cmpl r7,$c$fnc # else ordinary binop if not function ! 14461: beqlu 0f ! 14462: jmp cgv18 ! 14463: 0: ! 14464: movl 4*cmopn(r9),r9 # else load function vrblk ptr ! 14465: tstl 4*vrlen(r9) # ordinary binop if not system var ! 14466: beqlu 0f ! 14467: jmp cgv18 ! 14468: 0: ! 14469: movl 4*vrsvp(r9),r9 # else point to svblk ! 14470: movl 4*svbit(r9),r6 # load bit indicators ! 14471: mcoml btprd,r11 # test for predicate function ! 14472: bicl2 r11,r6 ! 14473: bnequ 0f # ordinary binop if not ! 14474: jmp cgv18 ! 14475: 0: ! 14476: # ! 14477: # HERE IF LEFT ARG OF CONCATENATION IS PREDICATE FUNCTION ! 14478: # ! 14479: cgv25: movl 4*cmlop(r10),r9 # reload left arg ! 14480: jsb cdgvl # gen code by value ! 14481: movl $opop$,r6 # load pop call ! 14482: jsb cdwrd # generate it ! 14483: movl 4*cmrop(r10),r9 # load right operand ! 14484: jsb cdgvl # gen code by value as result code ! 14485: jmp cgv33 # exit (not constant) ! 14486: # ! 14487: # HERE TO GENERATE CODE FOR PATTERN, IMMEDIATE ASSIGNMENT ! 14488: # ! 14489: cgv26: movl 4*cmlop(r10),r9 # load left operand ! 14490: jsb cdgvl # gen code by value, merge ! 14491: # ! 14492: # HERE FOR UNOPS WITH ARG BY NAME (BINARY $ . MERGE) ! 14493: # ! 14494: cgv27: movl 4*cmrop(r10),r9 # load right operand ptr ! 14495: jsb cdgnm # gen code by name for right arg ! 14496: movl 4*cmopn(r10),r9 # get operator code word ! 14497: cmpl (r9),$o$kwv # gen call unless keyword value ! 14498: beqlu 0f ! 14499: jmp cgv20 ! 14500: 0: ! 14501: #page ! 14502: # ! 14503: # CDGVL (CONTINUED) ! 14504: # ! 14505: # HERE FOR KEYWORD BY VALUE. THIS IS CONSTANT ONLY IF ! 14506: # THE OPERAND IS ONE OF THE SPECIAL SYSTEM VARIABLES WITH ! 14507: # THE SVCKW BIT SET TO INDICATE A CONSTANT KEYWORD VALUE. ! 14508: # NOTE THAT THE ONLY CONSTANT OPERAND BY NAME IS A VARIABLE ! 14509: # ! 14510: tstl r8 # gen call if non-constant (not var) ! 14511: beqlu 0f ! 14512: jmp cgv20 ! 14513: 0: ! 14514: movl sp,r8 # else set non-constant in case ! 14515: movl 4*cmrop(r10),r9 # load ptr to operand vrblk ! 14516: tstl 4*vrlen(r9) # gen (non-constant) if not sys var ! 14517: beqlu 0f ! 14518: jmp cgv20 ! 14519: 0: ! 14520: movl 4*vrsvp(r9),r9 # else load ptr to svblk ! 14521: movl 4*svbit(r9),r6 # load bit mask ! 14522: mcoml btckw,r11 # test for constant keyword ! 14523: bicl2 r11,r6 ! 14524: bnequ 0f # go gen if not constant ! 14525: jmp cgv20 ! 14526: 0: ! 14527: clrl r8 # else set result constant ! 14528: jmp cgv20 # and jump back to generate call ! 14529: # ! 14530: # HERE TO GENERATE CODE FOR NEGATION ! 14531: # ! 14532: cgv28: movl $onta$,r6 # get initial word ! 14533: jsb cdwrd # generate it ! 14534: movl cwcof,r7 # save next offset ! 14535: jsb cdwrd # generate gunk word for now ! 14536: movl 4*cmrop(r10),r9 # load right operand ptr ! 14537: jsb cdgvl # gen code by value ! 14538: movl $ontb$,r6 # load end of evaluation call ! 14539: jsb cdwrd # generate it ! 14540: movl r7,r9 # copy offset to word to plug ! 14541: addl2 r$ccb,r9 # point to actual word to plug ! 14542: movl cwcof,(r9) # plug word with current offset ! 14543: movl $ontc$,r6 # load final call ! 14544: jmp cgv32 # jump to generate it (not constant) ! 14545: # ! 14546: # HERE TO GENERATE CODE FOR UNDEFINED BINARY OPERATOR ! 14547: # ! 14548: cgv29: movl 4*cmlop(r10),r9 # load left operand ptr ! 14549: jsb cdgvl # generate code by value ! 14550: #page ! 14551: # ! 14552: # CDGVL (CONTINUED) ! 14553: # ! 14554: # HERE TO GENERATE CODE FOR UNDEFINED UNARY OPERATOR ! 14555: # ! 14556: cgv30: movl $c$uo$,r7 # set unop code + 1 ! 14557: subl2 4*cmtyp(r10),r7 # set number of args (1 or 2) ! 14558: # ! 14559: # MERGE HERE FOR UNDEFINED OPERATORS ! 14560: # ! 14561: movl 4*cmrop(r10),r9 # load right (only) operand pointer ! 14562: jsb cdgvl # gen value code for right operand ! 14563: movl 4*cmopn(r10),r9 # load pointer to operator dv ! 14564: movl 4*dvopn(r9),r9 # load pointer offset ! 14565: moval 0[r9],r9 # convert word offset to bytes ! 14566: addl2 $r$uba,r9 # point to proper function ptr ! 14567: subl2 $4*vrfnc,r9 # set standard function offset ! 14568: jmp cgv12 # merge with function call circuit ! 14569: # ! 14570: # HERE TO GENERATE CODE FOR INTERROGATION, INDIRECTION ! 14571: # ! 14572: cgv31: movl sp,r8 # set non constant ! 14573: jmp cgv19 # merge ! 14574: # ! 14575: # HERE TO EXIT GENERATING A WORD, RESULT NOT CONSTANT ! 14576: # ! 14577: cgv32: jsb cdwrd # generate word, merge ! 14578: # ! 14579: # HERE TO EXIT WITH NO WORD GENERATED, NOT CONSTANT ! 14580: # ! 14581: cgv33: movl sp,r8 # indicate result is not constant ! 14582: # ! 14583: # COMMON EXIT POINT ! 14584: # ! 14585: cgv34: addl2 $4,sp # pop initial code offset ! 14586: movl (sp)+,r6 # restore old constant flag ! 14587: movl (sp)+,r10 # restore entry xl ! 14588: movl (sp)+,r7 # restore entry wb ! 14589: tstl r8 # jump if not constant ! 14590: bnequ cgv35 ! 14591: movl r6,r8 # else restore entry constant flag ! 14592: # ! 14593: # HERE TO RETURN AFTER DEALING WITH WC SETTING ! 14594: # ! 14595: cgv35: rsb # return to cdgvl caller ! 14596: # ! 14597: # EXIT HERE TO GENERATE WORD AND TEST FOR CONSTANT ! 14598: # ! 14599: cgv36: jsb cdwrd # generate word ! 14600: tstl r8 # jump to exit if not constant ! 14601: bnequ cgv34 ! 14602: #page ! 14603: # ! 14604: # CDGVL (CONTINUED) ! 14605: # ! 14606: # HERE TO PREEVALUATE CONSTANT SUB-EXPRESSION ! 14607: # ! 14608: movl $orvl$,r6 # load call to return value ! 14609: jsb cdwrd # generate it ! 14610: movl (sp),r10 # load initial code offset ! 14611: jsb exbld # build exblk for expression ! 14612: clrl r7 # set to evaluate by value ! 14613: jsb evalx # evaluate expression ! 14614: .long invalid$ # should not fail ! 14615: movl (r9),r6 # load type word of result ! 14616: cmpl r6,$p$aaa # jump if not pattern ! 14617: blequ cgv37 ! 14618: movl $olpt$,r6 # else load special pattern load call ! 14619: jsb cdwrd # generate it ! 14620: # ! 14621: # MERGE HERE TO GENERATE POINTER TO RESULTING CONSTANT ! 14622: # ! 14623: cgv37: movl r9,r6 # copy constant pointer ! 14624: jsb cdwrd # generate ptr ! 14625: clrl r8 # set result constant ! 14626: jmp cgv34 # jump back to exit ! 14627: #enp # end procedure cdgvl ! 14628: #page ! 14629: # ! 14630: # CDWRD -- GENERATE ONE WORD OF CODE ! 14631: # ! 14632: # CDWRD WRITES ONE WORD INTO THE CURRENT CODE BLOCK UNDER ! 14633: # CONSTRUCTION. A NEW, LARGER, BLOCK IS ALLOCATED IF THERE ! 14634: # IS INSUFFICIENT ROOM IN THE CURRENT BLOCK. CDWRD ENSURES ! 14635: # THAT THERE ARE AT LEAST THREE WORDS LEFT IN THE BLOCK ! 14636: # AFTER ENTERING THE NEW WORD. THIS GUARANTEES THAT ANY ! 14637: # EXTRA SPACE AT THE END CAN BE SPLIT OFF AS A CCBLK. ! 14638: # ! 14639: # (WA) WORD TO BE GENERATED ! 14640: # JSR CDWRD CALL TO GENERATE WORD ! 14641: # ! 14642: cdwrd: #prc # entry point ! 14643: movl r9,-(sp) # save entry xr ! 14644: movl r6,-(sp) # save code word to be generated ! 14645: # ! 14646: # MERGE BACK HERE AFTER ALLOCATING LARGER BLOCK ! 14647: # ! 14648: cdwd1: movl r$ccb,r9 # load ptr to ccblk being built ! 14649: bnequ cdwd2 # jump if block allocated ! 14650: # ! 14651: # HERE WE ALLOCATE AN ENTIRELY FRESH BLOCK ! 14652: # ! 14653: movl $4*e$cbs,r6 # load initial length ! 14654: jsb alloc # allocate ccblk ! 14655: movl $b$cct,(r9) # store type word ! 14656: movl $4*cccod,cwcof # set initial offset ! 14657: movl r6,4*cclen(r9) # store block length ! 14658: movl r9,r$ccb # store ptr to new block ! 14659: # ! 14660: # HERE WE HAVE A BLOCK WE CAN USE ! 14661: # ! 14662: cdwd2: movl cwcof,r6 # load current offset ! 14663: addl2 $4*num04,r6 # adjust for test (four words) ! 14664: cmpl r6,4*cclen(r9) # jump if room in this block ! 14665: bgtru 0f ! 14666: jmp cdwd4 ! 14667: 0: ! 14668: # ! 14669: # HERE IF NO ROOM IN CURRENT BLOCK ! 14670: # ! 14671: cmpl r6,mxlen # jump if already at max size ! 14672: blssu 0f ! 14673: jmp cdwd5 ! 14674: 0: ! 14675: addl2 $4*e$cbs,r6 # else get new size ! 14676: movl r10,-(sp) # save entry xl ! 14677: movl r9,r10 # copy pointer ! 14678: cmpl r6,mxlen # jump if not too large ! 14679: blssu cdwd3 ! 14680: movl mxlen,r6 # else reset to max allowed size ! 14681: #page ! 14682: # ! 14683: # CDWRD (CONTINUED) ! 14684: # ! 14685: # HERE WITH NEW BLOCK SIZE IN WA ! 14686: # ! 14687: cdwd3: jsb alloc # allocate new block ! 14688: movl r9,r$ccb # store pointer to new block ! 14689: movl $b$cct,(r9)+ # store type word in new block ! 14690: movl r6,(r9)+ # store block length ! 14691: addl2 $4*ccuse,r10 # point to ccuse,cccod fields in old ! 14692: movl (r10),r6 # load ccuse value ! 14693: jsb sbmvw # copy useful words from old block ! 14694: movl (sp)+,r10 # restore xl ! 14695: jmp cdwd1 # merge back to try again ! 14696: # ! 14697: # HERE WITH ROOM IN CURRENT BLOCK ! 14698: # ! 14699: cdwd4: movl cwcof,r6 # load current offset ! 14700: addl2 $4,r6 # get new offset ! 14701: movl r6,cwcof # store new offset ! 14702: movl r6,4*ccuse(r9) # store in ccblk for gbcol ! 14703: subl2 $4,r6 # restore ptr to this word ! 14704: addl2 r6,r9 # point to current entry ! 14705: movl (sp)+,r6 # reload word to generate ! 14706: movl r6,(r9) # store word in block ! 14707: movl (sp)+,r9 # restore entry xr ! 14708: rsb # return to caller ! 14709: # ! 14710: # HERE IF COMPILED CODE IS TOO LONG FOR CDBLK ! 14711: # ! 14712: cdwd5: jmp er_213 # syntax error. statement is too complicated. ! 14713: #enp # end procedure cdwrd ! 14714: #page ! 14715: # ! 14716: # CMGEN -- GENERATE CODE FOR CMBLK PTR ! 14717: # ! 14718: # CMGEN IS A SUBSIDIARY PROCEDURE USED TO GENERATE VALUE ! 14719: # CODE FOR A CMBLK PTR FROM THE MAIN CODE GENERATORS. ! 14720: # ! 14721: # (XL) CMBLK POINTER ! 14722: # (WB) OFFSET TO POINTER IN CMBLK ! 14723: # JSR CMGEN CALL TO GENERATE CODE ! 14724: # (XR,WA) DESTROYED ! 14725: # (WB) BUMPED BY ONE WORD ! 14726: # ! 14727: cmgen: #prc # entry point, recursive ! 14728: movl r10,r9 # copy cmblk pointer ! 14729: addl2 r7,r9 # point to cmblk pointer ! 14730: movl (r9),r9 # load cmblk pointer ! 14731: jsb cdgvl # generate code by value ! 14732: addl2 $4,r7 # bump offset ! 14733: rsb # return to caller ! 14734: #enp # end procedure cmgen ! 14735: #page ! 14736: # ! 14737: # CMPIL (COMPILE SOURCE CODE) ! 14738: # ! 14739: # CMPIL IS USED TO CONVERT SNOBOL4 SOURCE CODE TO INTERNAL ! 14740: # FORM (SEE CDBLK FORMAT). IT IS USED BOTH FOR THE INITIAL ! 14741: # COMPILE AND AT RUN TIME BY THE CODE AND CONVERT FUNCTIONS ! 14742: # THIS PROCEDURE HAS CONTROL FOR THE ENTIRE DURATION OF ! 14743: # INITIAL COMPILATION. AN ERROR IN ANY PROCEDURE CALLED ! 14744: # DURING COMPILATION WILL LEAD FIRST TO THE ERROR SECTION ! 14745: # AND ULTIMATELY BACK HERE FOR RESUMED COMPILATION. THE ! 14746: # RE-ENTRY POINTS AFTER AN ERROR ARE SPECIALLY LABELLED - ! 14747: # ! 14748: # CMPCE RESUME AFTER CONTROL CARD ERROR ! 14749: # CMPLE RESUME AFTER LABEL ERROR ! 14750: # CMPSE RESUME AFTER STATEMENT ERROR ! 14751: # ! 14752: # JSR CMPIL CALL TO COMPILE CODE ! 14753: # (XR) PTR TO CDBLK FOR ENTRY STATEMENT ! 14754: # (XL,WA,WB,WC,RA) DESTROYED ! 14755: # ! 14756: # THE FOLLOWING GLOBAL VARIABLES ARE REFERENCED ! 14757: # ! 14758: # CMPSN NUMBER OF NEXT STATEMENT ! 14759: # TO BE COMPILED. ! 14760: # ! 14761: # CSWXX CONTROL CARD SWITCH VALUES ARE ! 14762: # CHANGED WHEN RELEVANT CONTROL ! 14763: # CARDS ARE MET. ! 14764: # ! 14765: # CWCOF OFFSET TO NEXT WORD IN CODE BLOCK ! 14766: # BEING BUILT (SEE CDWRD). ! 14767: # ! 14768: # LSTSN NUMBER OF STATEMENT MOST RECENTLY ! 14769: # COMPILED (INITIALLY SET TO ZERO). ! 14770: # ! 14771: # R$CIM CURRENT (INITIAL) COMPILER IMAGE ! 14772: # (ZERO FOR INITIAL COMPILE CALL) ! 14773: # ! 14774: # R$CNI USED TO POINT TO FOLLOWING IMAGE. ! 14775: # (SEE READR PROCEDURE). ! 14776: # ! 14777: # SCNGO GOTO SWITCH FOR SCANE PROCEDURE ! 14778: # ! 14779: # SCNIL LENGTH OF CURRENT IMAGE EXCLUDING ! 14780: # CHARACTERS REMOVED BY -INPUT. ! 14781: # ! 14782: # SCNPT CURRENT SCAN OFFSET, SEE SCANE. ! 14783: # ! 14784: # SCNRS RESCAN SWITCH FOR SCANE PROCEDURE. ! 14785: # ! 14786: # SCNSE OFFSET (IN R$CIM) OF MOST RECENTLY ! 14787: # SCANNED ELEMENT. SET ZERO IF NOT ! 14788: # CURRENTLY SCANNING ITEMS ! 14789: #page ! 14790: # ! 14791: # CMPIL (CONTINUED) ! 14792: # ! 14793: # STAGE STGIC INITIAL COMPILE IN PROGRESS ! 14794: # STGXC CODE/CONVERT COMPILE ! 14795: # STGEV BUILDING EXBLK FOR EVAL ! 14796: # STGXT EXECUTE TIME (OUTSIDE COMPILE) ! 14797: # STGCE INITIAL COMPILE AFTER END LINE ! 14798: # STGXE EXECUTE COMPILE AFTER END LINE ! 14799: # ! 14800: # CMPIL ALSO USES A FIXED NUMBER OF LOCATIONS ON THE ! 14801: # MAIN STACK AS FOLLOWS. (THE DEFINITIONS OF THE ACTUAL ! 14802: # OFFSETS ARE IN THE DEFINITIONS SECTION). ! 14803: # ! 14804: # CMSTM(XS) POINTER TO EXPAN TREE FOR BODY OF ! 14805: # STATEMENT (SEE EXPAN PROCEDURE). ! 14806: # ! 14807: # CMSGO(XS) POINTER TO TREE REPRESENTATION OF ! 14808: # SUCCESS GOTO (SEE PROCEDURE SCNGO)9 ! 14809: # ZERO IF NO SUCCESS GOTO IS GIVEN ! 14810: # ! 14811: # CMFGO(XS) LIKE CMSGO FOR FAILURE GOTO. ! 14812: # ! 14813: # CMCGO(XS) SET NON-ZERO ONLY IF THERE IS A ! 14814: # CONDITIONAL GOTO. USED FOR -FAIL, ! 14815: # -NOFAIL CODE GENERATION. ! 14816: # ! 14817: # CMPCD(XS) POINTER TO CDBLK FOR PREVIOUS ! 14818: # STATEMENT. ZERO FOR 1ST STATEMENT. ! 14819: # ! 14820: # CMFFP(XS) SET NON-ZERO IF CDFAL IN PREVIOUS ! 14821: # CDBLK NEEDS FILLING WITH FORWARD ! 14822: # POINTER, ELSE SET TO ZERO. ! 14823: # ! 14824: # CMFFC(XS) SAME AS CMFFP FOR CURRENT CDBLK ! 14825: # ! 14826: # CMSOP(XS) OFFSET TO WORD IN PREVIOUS CDBLK ! 14827: # TO BE FILLED IN WITH FORWARD PTR ! 14828: # TO NEXT CDBLK FOR SUCCESS GOTO. ! 14829: # ZERO IF NO FILL IN IS REQUIRED. ! 14830: # ! 14831: # CMSOC(XS) SAME AS CMSOP FOR CURRENT CDBLK. ! 14832: # ! 14833: # CMLBL(XS) POINTER TO VRBLK FOR LABEL OF ! 14834: # CURRENT STATEMENT. ZERO IF NO LABEL ! 14835: # ! 14836: # CMTRA(XS) POINTER TO CDBLK FOR ENTRY STMNT. ! 14837: #page ! 14838: # ! 14839: # CMPIL (CONTINUED) ! 14840: # ! 14841: # ENTRY POINT ! 14842: # ! 14843: cmpil: #prc # entry point ! 14844: movl $cmnen,r7 # set number of stack work locations ! 14845: # ! 14846: # LOOP TO INITIALIZE STACK WORKING LOCATIONS ! 14847: # ! 14848: cmp00: clrl -(sp) # store a zero, make one entry ! 14849: sobgtr r7,cmp00 # loop back until all set ! 14850: movl sp,cmpxs # save stack pointer for error sec ! 14851: #sss cmpss # save s-r stack pointer if any ! 14852: # ! 14853: # LOOP THROUGH STATEMENTS ! 14854: # ! 14855: cmp01: movl scnpt,r7 # set scan pointer offset ! 14856: movl r7,scnse # set start of element location ! 14857: movl $ocer$,r6 # point to compile error call ! 14858: jsb cdwrd # generate as temporary cdfal ! 14859: cmpl r7,scnil # jump if chars left on this image ! 14860: blssu cmp04 ! 14861: # ! 14862: # LOOP HERE AFTER COMMENT OR CONTROL CARD ! 14863: # ALSO SPECIAL ENTRY AFTER CONTROL CARD ERROR ! 14864: # ! 14865: cmpce: clrl r9 # clear possible garbage xr value ! 14866: cmpl stage,$stgic # skip unless initial compile ! 14867: bnequ cmp02 ! 14868: jsb readr # read next input image ! 14869: tstl r9 # jump if no input available ! 14870: bnequ 0f ! 14871: jmp cmp09 ! 14872: 0: ! 14873: jsb nexts # acquire next source image ! 14874: movl cmpsn,lstsn # store stmt no for use by listr ! 14875: clrl scnpt # reset scan pointer ! 14876: jmp cmp04 # go process image ! 14877: # ! 14878: # FOR EXECUTE TIME COMPILE, PERMIT EMBEDDED CONTROL CARDS ! 14879: # AND COMMENTS (BY SKIPPING TO NEXT SEMI-COLON) ! 14880: # ! 14881: cmp02: movl r$cim,r9 # get current image ! 14882: movl scnpt,r7 # get current offset ! 14883: movab cfp$f(r9)[r7],r9# prepare to get chars ! 14884: # ! 14885: # SKIP TO SEMI-COLON ! 14886: # ! 14887: cmp03: movzbl (r9)+,r8 # get char ! 14888: incl scnpt # advance offset ! 14889: cmpl r8,$ch$sm # skip if semi-colon found ! 14890: beqlu cmp04 ! 14891: cmpl scnpt,scnil # loop if more chars ! 14892: blssu cmp03 ! 14893: clrl r9 # clear garbage xr value ! 14894: jmp cmp09 # end of image ! 14895: #page ! 14896: # ! 14897: # CMPIL (CONTINUED) ! 14898: # ! 14899: # HERE WITH IMAGE AVAILABLE TO SCAN. NOTE THAT IF THE INPUT ! 14900: # STRING IS NULL, THEN EVERYTHING IS OK SINCE NULL IS ! 14901: # ACTUALLY ASSEMBLED AS A WORD OF BLANKS. ! 14902: # ! 14903: cmp04: movl r$cim,r9 # point to current image ! 14904: movl scnpt,r7 # load current offset ! 14905: movl r7,r6 # copy for label scan ! 14906: movab cfp$f(r9)[r7],r9# point to first character ! 14907: movzbl (r9)+,r8 # load first character ! 14908: cmpl r8,$ch$sm # no label if semicolon ! 14909: bnequ 0f ! 14910: jmp cmp12 ! 14911: 0: ! 14912: cmpl r8,$ch$as # loop back if comment card ! 14913: bnequ 0f ! 14914: jmp cmpce ! 14915: 0: ! 14916: cmpl r8,$ch$mn # jump if control card ! 14917: bnequ 0f ! 14918: jmp cmp32 ! 14919: 0: ! 14920: movl r$cim,r$cmp # about to destroy r$cim ! 14921: movl $cmlab,r10 # point to label work string ! 14922: movl r10,r$cim # scane is to scan work string ! 14923: movab cfp$f(r10),r10 # point to first character position ! 14924: movb r8,(r10)+ # store char just loaded ! 14925: movl $ch$sm,r8 # get a semicolon ! 14926: movb r8,(r10) # store after first char ! 14927: #csc r10 # finished character storing ! 14928: clrl r10 # clear pointer ! 14929: clrl scnpt # start at first character ! 14930: movl scnil,-(sp) # preserve image length ! 14931: movl $num02,scnil # read 2 chars at most ! 14932: jsb scane # scan first char for type ! 14933: movl (sp)+,scnil # restore image length ! 14934: movl r10,r8 # note return code ! 14935: movl r$cmp,r10 # get old r$cim ! 14936: movl r10,r$cim # put it back ! 14937: movl r7,scnpt # reinstate offset ! 14938: tstl scnbl # blank seen - cant be label ! 14939: beqlu 0f ! 14940: jmp cmp12 ! 14941: 0: ! 14942: movl r10,r9 # point to current image ! 14943: movab cfp$f(r9)[r7],r9# point to first char again ! 14944: cmpl r8,$t$var # ok if letter ! 14945: beqlu cmp06 ! 14946: cmpl r8,$t$con # ok if digit ! 14947: beqlu cmp06 ! 14948: # ! 14949: # DROP IN OR JUMP FROM ERROR SECTION IF SCANE FAILED ! 14950: # ! 14951: cmple: movl r$cmp,r$cim # point to bad line ! 14952: jmp er_214 # bad label or misplaced continuation line ! 14953: # ! 14954: # LOOP TO SCAN LABEL ! 14955: # ! 14956: cmp05: cmpl r8,$ch$sm # skip if semicolon ! 14957: beqlu cmp07 ! 14958: incl r6 # bump offset ! 14959: cmpl r6,scnil # jump if end of image (label end) ! 14960: beqlu cmp07 ! 14961: #page ! 14962: # ! 14963: # CMPIL (CONTINUED) ! 14964: # ! 14965: # ENTER LOOP AT THIS POINT ! 14966: # ! 14967: cmp06: movzbl (r9)+,r8 # else load next character ! 14968: cmpl r8,$ch$ht # jump if horizontal tab ! 14969: beqlu cmp07 ! 14970: cmpl r8,$ch$bl # loop back if non-blank ! 14971: bnequ cmp05 ! 14972: # ! 14973: # HERE AFTER SCANNING OUT LABEL ! 14974: # ! 14975: cmp07: movl r6,scnpt # save updated scan offset ! 14976: subl2 r7,r6 # get length of label ! 14977: bnequ 0f # skip if label length zero ! 14978: jmp cmp12 ! 14979: 0: ! 14980: clrl r9 # clear garbage xr value ! 14981: jsb sbstr # build scblk for label name ! 14982: jsb gtnvr # locate/contruct vrblk ! 14983: .long invalid$ # dummy (impossible) error return ! 14984: movl r9,4*cmlbl(sp) # store label pointer ! 14985: tstl 4*vrlen(r9) # jump if not system label ! 14986: bnequ cmp11 ! 14987: cmpl 4*vrsvp(r9),$v$end # jump if not end label ! 14988: bnequ cmp11 ! 14989: # ! 14990: # HERE FOR END LABEL SCANNED OUT ! 14991: # ! 14992: addl2 $stgnd,stage # adjust stage appropriately ! 14993: jsb scane # scan out next element ! 14994: cmpl r10,$t$smc # jump if end of image ! 14995: bnequ 0f ! 14996: jmp cmp10 ! 14997: 0: ! 14998: cmpl r10,$t$var # else error if not variable ! 14999: bnequ cmp08 ! 15000: # ! 15001: # HERE CHECK FOR VALID INITIAL TRANSFER ! 15002: # ! 15003: cmpl 4*vrlbl(r9),$stndl # jump if not defined (error) ! 15004: beqlu cmp08 ! 15005: movl 4*vrlbl(r9),4*cmtra(sp) # else set initial entry pointer ! 15006: jsb scane # scan next element ! 15007: cmpl r10,$t$smc # jump if ok (end of image) ! 15008: bnequ 0f ! 15009: jmp cmp10 ! 15010: 0: ! 15011: # ! 15012: # HERE FOR BAD TRANSFER LABEL ! 15013: # ! 15014: cmp08: jmp er_215 # syntax error. undefined or erroneous entry label ! 15015: # ! 15016: # HERE FOR END OF INPUT (NO END LABEL DETECTED) ! 15017: # ! 15018: cmp09: addl2 $stgnd,stage # adjust stage appropriately ! 15019: cmpl stage,$stgxe # jump if code call (ok) ! 15020: bnequ 0f ! 15021: jmp cmp10 ! 15022: 0: ! 15023: jmp er_216 # syntax error. missing end line ! 15024: # ! 15025: # HERE AFTER PROCESSING END LINE (MERGE HERE ON END ERROR) ! 15026: # ! 15027: cmp10: movl $ostp$,r6 # set stop call pointer ! 15028: jsb cdwrd # generate as statement call ! 15029: jmp cmpse # jump to generate as failure ! 15030: #page ! 15031: # ! 15032: # CMPIL (CONTINUED) ! 15033: # ! 15034: # HERE AFTER PROCESSING LABEL OTHER THAN END ! 15035: # ! 15036: cmp11: cmpl stage,$stgic # jump if code call - redef. ok ! 15037: beqlu 0f ! 15038: jmp cmp12 ! 15039: 0: ! 15040: cmpl 4*vrlbl(r9),$stndl # else check for redefinition ! 15041: bnequ 0f ! 15042: jmp cmp12 ! 15043: 0: ! 15044: clrl 4*cmlbl(sp) # leave first label decln undisturbed ! 15045: jmp er_217 # syntax error. duplicate label ! 15046: # ! 15047: # HERE AFTER DEALING WITH LABEL ! 15048: # ! 15049: cmp12: clrl r7 # set flag for statement body ! 15050: jsb expan # get tree for statement body ! 15051: movl r9,4*cmstm(sp) # store for later use ! 15052: clrl 4*cmsgo(sp) # clear success goto pointer ! 15053: clrl 4*cmfgo(sp) # clear failure goto pointer ! 15054: clrl 4*cmcgo(sp) # clear conditional goto flag ! 15055: jsb scane # scan next element ! 15056: cmpl r10,$t$col # jump it not colon (no goto) ! 15057: beqlu 0f ! 15058: jmp cmp18 ! 15059: 0: ! 15060: # ! 15061: # LOOP TO PROCESS GOTO FIELDS ! 15062: # ! 15063: cmp13: movl sp,scngo # set goto flag ! 15064: jsb scane # scan next element ! 15065: cmpl r10,$t$smc # jump if no fields left ! 15066: bnequ 0f ! 15067: jmp cmp31 ! 15068: 0: ! 15069: cmpl r10,$t$sgo # jump if s for success goto ! 15070: beqlu cmp14 ! 15071: cmpl r10,$t$fgo # jump if f for failure goto ! 15072: beqlu cmp16 ! 15073: # ! 15074: # HERE FOR UNCONDITIONAL GOTO (I.E. NOT F OR S) ! 15075: # ! 15076: movl sp,scnrs # set to rescan element not f,s ! 15077: jsb scngf # scan out goto field ! 15078: tstl 4*cmfgo(sp) # error if fgoto already ! 15079: bnequ cmp17 ! 15080: movl r9,4*cmfgo(sp) # else set as fgoto ! 15081: jmp cmp15 # merge with sgoto circuit ! 15082: # ! 15083: # HERE FOR SUCCESS GOTO ! 15084: # ! 15085: cmp14: jsb scngf # scan success goto field ! 15086: movl $num01,4*cmcgo(sp) # set conditional goto flag ! 15087: # ! 15088: # UNCONTIONAL GOTO MERGES HERE ! 15089: # ! 15090: cmp15: tstl 4*cmsgo(sp) # error if sgoto already given ! 15091: bnequ cmp17 ! 15092: movl r9,4*cmsgo(sp) # else set sgoto ! 15093: jmp cmp13 # loop back for next goto field ! 15094: # ! 15095: # HERE FOR FAILURE GOTO ! 15096: # ! 15097: cmp16: jsb scngf # scan goto field ! 15098: movl $num01,4*cmcgo(sp) # set conditonal goto flag ! 15099: tstl 4*cmfgo(sp) # error if fgoto already given ! 15100: bnequ cmp17 ! 15101: movl r9,4*cmfgo(sp) # else store fgoto pointer ! 15102: jmp cmp13 # loop back for next field ! 15103: #page ! 15104: # ! 15105: # CMPIL (CONTINUED) ! 15106: # ! 15107: # HERE FOR DUPLICATED GOTO FIELD ! 15108: # ! 15109: cmp17: jmp er_218 # syntax error. duplicated goto field ! 15110: # ! 15111: # HERE TO GENERATE CODE ! 15112: # ! 15113: cmp18: clrl scnse # stop positional error flags ! 15114: movl 4*cmstm(sp),r9 # load tree ptr for statement body ! 15115: clrl r7 # collectable value for wb for cdgvl ! 15116: clrl r8 # reset constant flag for cdgvl ! 15117: jsb expap # test for pattern match ! 15118: .long cmp19 # jump if not pattern match ! 15119: movl $opms$,4*cmopn(r9) # else set pattern match pointer ! 15120: movl $c$pmt,4*cmtyp(r9) ! 15121: # ! 15122: # HERE AFTER DEALING WITH SPECIAL PATTERN MATCH CASE ! 15123: # ! 15124: cmp19: jsb cdgvl # generate code for body of statement ! 15125: movl 4*cmsgo(sp),r9 # load sgoto pointer ! 15126: movl r9,r6 # copy it ! 15127: tstl r9 # jump if no success goto ! 15128: beqlu cmp21 ! 15129: clrl 4*cmsoc(sp) # clear success offset fillin ptr ! 15130: cmpl r9,state # jump if complex goto ! 15131: bgequ cmp20 ! 15132: # ! 15133: # HERE FOR SIMPLE SUCCESS GOTO (LABEL) ! 15134: # ! 15135: addl2 $4*vrtra,r6 # point to vrtra field as required ! 15136: jsb cdwrd # generate success goto ! 15137: jmp cmp22 # jump to deal with fgoto ! 15138: # ! 15139: # HERE FOR COMPLEX SUCCESS GOTO ! 15140: # ! 15141: cmp20: cmpl r9,4*cmfgo(sp) # no code if same as fgoto ! 15142: beqlu cmp22 ! 15143: clrl r7 # else set ok value for cdgvl in wb ! 15144: jsb cdgcg # generate code for success goto ! 15145: jmp cmp22 # jump to deal with fgoto ! 15146: # ! 15147: # HERE FOR NO SUCCESS GOTO ! 15148: # ! 15149: cmp21: movl cwcof,4*cmsoc(sp)# set success fill in offset ! 15150: movl $ocer$,r6 # point to compile error call ! 15151: jsb cdwrd # generate as temporary value ! 15152: #page ! 15153: # ! 15154: # CMPIL (CONTINUED) ! 15155: # ! 15156: # HERE TO DEAL WITH FAILURE GOTO ! 15157: # ! 15158: cmp22: movl 4*cmfgo(sp),r9 # load failure goto pointer ! 15159: movl r9,r6 # copy it ! 15160: clrl 4*cmffc(sp) # set no fill in required yet ! 15161: tstl r9 # jump if no failure goto given ! 15162: beqlu cmp23 ! 15163: addl2 $4*vrtra,r6 # point to vrtra field in case ! 15164: cmpl r9,state # jump to gen if simple fgoto ! 15165: blequ cmpse ! 15166: # ! 15167: # HERE FOR COMPLEX FAILURE GOTO ! 15168: # ! 15169: movl cwcof,r7 # save offset to o$gof call ! 15170: movl $ogof$,r6 # point to failure goto call ! 15171: jsb cdwrd # generate ! 15172: movl $ofif$,r6 # point to fail in fail word ! 15173: jsb cdwrd # generate ! 15174: jsb cdgcg # generate code for failure goto ! 15175: movl r7,r6 # copy offset to o$gof for cdfal ! 15176: movl $b$cdc,r7 # set complex case cdtyp ! 15177: jmp cmp25 # jump to build cdblk ! 15178: # ! 15179: # HERE IF NO FAILURE GOTO GIVEN ! 15180: # ! 15181: cmp23: movl $ounf$,r6 # load unexpected failure call in cas ! 15182: movl cswfl,r8 # get -nofail flag ! 15183: bisl2 4*cmcgo(sp),r8 # check if conditional goto ! 15184: beqlu cmpse # jump if -nofail and no cond. goto ! 15185: movl sp,4*cmffc(sp) # else set fill in flag ! 15186: movl $ocer$,r6 # and set compile error for temporary ! 15187: # ! 15188: # MERGE HERE WITH CDFAL VALUE IN WA, SIMPLE CDBLK ! 15189: # ALSO SPECIAL ENTRY AFTER STATEMENT ERROR ! 15190: # ! 15191: cmpse: movl $b$cds,r7 # set cdtyp for simple case ! 15192: #page ! 15193: # ! 15194: # CMPIL (CONTINUED) ! 15195: # ! 15196: # MERGE HERE TO BUILD CDBLK ! 15197: # ! 15198: # (WA) CDFAL VALUE TO BE GENERATED ! 15199: # (WB) CDTYP VALUE TO BE GENERATED ! 15200: # ! 15201: # AT THIS STAGE, WE CHOP OFF AN APPROPRIATE CHUNK OF THE ! 15202: # CURRENT CCBLK AND CONVERT IT INTO A CDBLK. THE REMAINDER ! 15203: # OF THE CCBLK IS REFORMATTED TO BE THE NEW CCBLK. ! 15204: # ! 15205: cmp25: movl r$ccb,r9 # point to ccblk ! 15206: movl 4*cmlbl(sp),r10 # get possible label pointer ! 15207: beqlu cmp26 # skip if no label ! 15208: clrl 4*cmlbl(sp) # clear flag for next statement ! 15209: movl r9,4*vrlbl(r10) # put cdblk ptr in vrblk label field ! 15210: # ! 15211: # MERGE AFTER DOING LABEL ! 15212: # ! 15213: cmp26: movl r7,(r9) # set type word for new cdblk ! 15214: movl r6,4*cdfal(r9) # set failure word ! 15215: movl r9,r10 # copy pointer to ccblk ! 15216: movl 4*ccuse(r9),r7 # load length gen (= new cdlen) ! 15217: movl 4*cclen(r9),r8 # load total ccblk length ! 15218: addl2 r7,r10 # point past cdblk ! 15219: subl2 r7,r8 # get length left for chop off ! 15220: movl $b$cct,(r10) # set type code for new ccblk at end ! 15221: movl $4*cccod,4*ccuse(r10) # set initial code offset ! 15222: movl $4*cccod,cwcof # reinitialise cwcof ! 15223: movl r8,4*cclen(r10) # set new length ! 15224: movl r10,r$ccb # set new ccblk pointer ! 15225: movl cmpsn,4*cdstm(r9)# set statement number ! 15226: incl cmpsn # bump statement number ! 15227: # ! 15228: # SET POINTERS IN PREVIOUS CODE BLOCK AS REQUIRED ! 15229: # ! 15230: movl 4*cmpcd(sp),r10 # load ptr to previous cdblk ! 15231: tstl 4*cmffp(sp) # jump if no failure fill in required ! 15232: beqlu cmp27 ! 15233: movl r9,4*cdfal(r10) # else set failure ptr in previous ! 15234: # ! 15235: # HERE TO DEAL WITH SUCCESS FORWARD POINTER ! 15236: # ! 15237: cmp27: movl 4*cmsop(sp),r6 # load success offset ! 15238: beqlu cmp28 # jump if no fill in required ! 15239: addl2 r6,r10 # else point to fill in location ! 15240: movl r9,(r10) # store forward pointer ! 15241: clrl r10 # clear garbage xl value ! 15242: #page ! 15243: # ! 15244: # CMPIL (CONTINUED) ! 15245: # ! 15246: # NOW SET FILL IN POINTERS FOR THIS STATEMENT ! 15247: # ! 15248: cmp28: movl 4*cmffc(sp),4*cmffp(sp) # copy failure fill in flag ! 15249: movl 4*cmsoc(sp),4*cmsop(sp) # copy success fill in offset ! 15250: movl r9,4*cmpcd(sp) # save ptr to this cdblk ! 15251: tstl 4*cmtra(sp) # jump if initial entry already set ! 15252: bnequ cmp29 ! 15253: movl r9,4*cmtra(sp) # else set ptr here as default ! 15254: # ! 15255: # HERE AFTER COMPILING ONE STATEMENT ! 15256: # ! 15257: cmp29: cmpl stage,$stgce # jump if not end line just done ! 15258: bgequ 0f ! 15259: jmp cmp01 ! 15260: 0: ! 15261: tstl cswls # skip if -nolist ! 15262: beqlu cmp30 ! 15263: jsb listr # list last line ! 15264: # ! 15265: # RETURN ! 15266: # ! 15267: cmp30: movl 4*cmtra(sp),r9 # load initial entry cdblk pointer ! 15268: addl2 $4*cmnen,sp # pop work locations off stack ! 15269: rsb # and return to cmpil caller ! 15270: # ! 15271: # HERE AT END OF GOTO FIELD ! 15272: # ! 15273: cmp31: movl 4*cmfgo(sp),r7 # get fail goto ! 15274: bisl2 4*cmsgo(sp),r7 # or in success goto ! 15275: beqlu 0f # ok if non-null field ! 15276: jmp cmp18 ! 15277: 0: ! 15278: jmp er_219 # syntax error. empty goto field ! 15279: # ! 15280: # CONTROL CARD FOUND ! 15281: # ! 15282: cmp32: incl r7 # point past ch$mn ! 15283: jsb cncrd # process control card ! 15284: clrl scnse # clear start of element loc. ! 15285: jmp cmpce # loop for next statement ! 15286: #enp # end procedure cmpil ! 15287: #page ! 15288: # ! 15289: # CNCRD -- CONTROL CARD PROCESSOR ! 15290: # ! 15291: # CALLED TO DEAL WITH CONTROL CARDS ! 15292: # ! 15293: # R$CIM POINTS TO CURRENT IMAGE ! 15294: # (WB) OFFSET TO 1ST CHAR OF CONTROL CARD ! 15295: # JSR CNCRD CALL TO PROCESS CONTROL CARDS ! 15296: # (XL,XR,WA,WB,WC,IA) DESTROYED ! 15297: # ! 15298: cncrd: #prc # entry point ! 15299: movl r7,scnpt # offset for control card scan ! 15300: movl $ccnoc,r6 # number of chars for comparison ! 15301: movab 3+(4*0)(r6),r6 # convert to word count ! 15302: ashl $-2,r6,r6 ! 15303: movl r6,cnswc # save word count ! 15304: # ! 15305: # LOOP HERE IF MORE THAN ONE CONTROL CARD ! 15306: # ! 15307: cnc01: cmpl scnpt,scnil # return if end of image ! 15308: blssu 0f ! 15309: jmp cnc09 ! 15310: 0: ! 15311: movl r$cim,r9 # point to image ! 15312: movl scnpt,r11 # [get in scratch register] ! 15313: movab cfp$f(r9)[r11],r9# char ptr for first char ! 15314: movzbl (r9)+,r6 # get first char ! 15315: bicl2 $ch$bl,r6 # fold to upper case ! 15316: cmpl r6,$ch$li # special case of -inxxx ! 15317: bnequ 0f ! 15318: jmp cnc07 ! 15319: 0: ! 15320: movl sp,scncc # set flag for scane ! 15321: jsb scane # scan card name ! 15322: clrl scncc # clear scane flag ! 15323: tstl r10 # fail unless control card name ! 15324: beqlu 0f ! 15325: jmp cnc06 ! 15326: 0: ! 15327: movl $ccnoc,r6 # no. of chars to be compared ! 15328: cmpl 4*sclen(r9),r6 # fail if too few chars ! 15329: bgequ 0f ! 15330: jmp cnc06 ! 15331: 0: ! 15332: movl r9,r10 # point to control card name ! 15333: clrl r7 # zero offset for substring ! 15334: jsb sbstr # extract substring for comparison ! 15335: movl 4*sclen(r9),r6 # reload length ! 15336: jsb flstg # fold to upper case ! 15337: movl r9,cnscc # keep control card substring ptr ! 15338: movl $ccnms,r9 # point to list of standard names ! 15339: clrl r7 # initialise name offset ! 15340: movl $cc$nc,r8 # number of standard names ! 15341: # ! 15342: # TRY TO MATCH NAME ! 15343: # ! 15344: cnc02: movl cnscc,r10 # point to name ! 15345: movl cnswc,r6 # counter for inner loop ! 15346: jmp cnc04 # jump into loop ! 15347: # ! 15348: # INNER LOOP TO MATCH CARD NAME CHARS ! 15349: # ! 15350: cnc03: addl2 $4,r9 # bump standard names ptr ! 15351: addl2 $4,r10 # bump name pointer ! 15352: # ! 15353: # HERE TO INITIATE THE LOOP ! 15354: # ! 15355: cnc04: cmpl 4*schar(r10),(r9)# comp. up to cfp$c chars at once ! 15356: bnequ cnc05 ! 15357: sobgtr r6,cnc03 # loop if more words to compare ! 15358: #page ! 15359: # ! 15360: # CNCRD (CONTINUED) ! 15361: # ! 15362: # MATCHED - BRANCH ON CARD OFFSET ! 15363: # ! 15364: movl r7,r10 # get name offset ! 15365: casel r10,$0,$cc$nc # switch ! 15366: 5: ! 15367: .word cnc37-5b # -case ! 15368: .word cnc10-5b # -double ! 15369: .word cnc11-5b # -dump ! 15370: .word cnc12-5b # -eject ! 15371: .word cnc13-5b # -errors ! 15372: .word cnc14-5b # -execute ! 15373: .word cnc15-5b # -fail ! 15374: .word cnc16-5b # -list ! 15375: .word cnc17-5b # -noerrors ! 15376: .word cnc18-5b # -noexecute ! 15377: .word cnc19-5b # -nofail ! 15378: .word cnc20-5b # -nolist ! 15379: .word cnc21-5b # -noopt ! 15380: .word cnc22-5b # -noprint ! 15381: .word cnc24-5b # -optimise ! 15382: .word cnc25-5b # -print ! 15383: .word cnc27-5b # -single ! 15384: .word cnc28-5b # -space ! 15385: .word cnc31-5b # -stitle ! 15386: .word cnc32-5b # -title ! 15387: .word cnc36-5b # -trace ! 15388: #esw # end switch ! 15389: # ! 15390: # NOT MATCHED YET. ALIGN STD NAMES PTR AND TRY AGAIN ! 15391: # ! 15392: cnc05: addl2 $4,r9 # bump standard names ptr ! 15393: sobgtr r6,cnc05 # loop ! 15394: incl r7 # bump names offset ! 15395: sobgtr r8,cnc02 # continue if more names ! 15396: # ! 15397: # INVALID CONTROL CARD NAME ! 15398: # ! 15399: cnc06: jmp er_247 # invalid control card ! 15400: # ! 15401: # SPECIAL PROCESSING FOR -INXXX ! 15402: # ! 15403: cnc07: movzbl (r9),r6 # get next char ! 15404: bicl2 $ch$bl,r6 # fold to upper case ! 15405: cmpl r6,$ch$ln # fail if not letter n ! 15406: beqlu 0f ! 15407: jmp cnc06 ! 15408: 0: ! 15409: addl2 $num02,scnpt # bump offset past -in ! 15410: jsb scane # scan integer after -in ! 15411: movl r9,-(sp) # stack scanned item ! 15412: jsb gtsmi # check if integer ! 15413: .long cnc06 # fail if not integer ! 15414: .long cnc06 # fail if negative or large ! 15415: movl r9,cswin # keep integer ! 15416: #page ! 15417: # ! 15418: # CNCRD (CONTINUED) ! 15419: # ! 15420: # CHECK FOR MORE CONTROL CARDS BEFORE RETURNING ! 15421: # ! 15422: cnc08: movl scnpt,r6 # preserve in case xeq time compile ! 15423: jsb scane # look for comma ! 15424: cmpl r10,$t$cma # loop if comma found ! 15425: bnequ 0f ! 15426: jmp cnc01 ! 15427: 0: ! 15428: movl r6,scnpt # restore scnpt in case xeq time ! 15429: # ! 15430: # RETURN POINT ! 15431: # ! 15432: cnc09: rsb # return ! 15433: # ! 15434: # -DOUBLE ! 15435: # ! 15436: cnc10: movl sp,cswdb # set switch ! 15437: jmp cnc08 # merge ! 15438: # ! 15439: # -DUMP ! 15440: # THIS IS USED FOR SYSTEM DEBUGGING . IT HAS THE EFFECT OF ! 15441: # PRODUCING A CORE DUMP AT COMPILATION TIME ! 15442: # ! 15443: cnc11: jsb sysdm # call dumper ! 15444: jmp cnc09 # finished ! 15445: # ! 15446: # -EJECT ! 15447: # ! 15448: cnc12: tstl cswls # return if -nolist ! 15449: bnequ 0f ! 15450: jmp cnc09 ! 15451: 0: ! 15452: jsb prtps # eject ! 15453: jsb listt # list title ! 15454: jmp cnc09 # finished ! 15455: # ! 15456: # -ERRORS ! 15457: # ! 15458: cnc13: clrl cswer # clear switch ! 15459: jmp cnc08 # merge ! 15460: # ! 15461: # -EXECUTE ! 15462: # ! 15463: cnc14: clrl cswex # clear switch ! 15464: jmp cnc08 # merge ! 15465: # ! 15466: # -FAIL ! 15467: # ! 15468: cnc15: movl sp,cswfl # set switch ! 15469: jmp cnc08 # merge ! 15470: # ! 15471: # -LIST ! 15472: # ! 15473: cnc16: movl sp,cswls # set switch ! 15474: cmpl stage,$stgic # done if compile time ! 15475: bnequ 0f; jmp cnc08; 0: ! 15476: # ! 15477: # LIST CODE LINE IF EXECUTE TIME COMPILE ! 15478: # ! 15479: clrl lstpf # permit listing ! 15480: jsb listr # list line ! 15481: jmp cnc08 # merge ! 15482: #page ! 15483: # ! 15484: # CNCRD (CONTINUED) ! 15485: # ! 15486: # -NOERRORS ! 15487: # ! 15488: cnc17: movl sp,cswer # set switch ! 15489: jmp cnc08 # merge ! 15490: # ! 15491: # -NOEXECUTE ! 15492: # ! 15493: cnc18: movl sp,cswex # set switch ! 15494: jmp cnc08 # merge ! 15495: # ! 15496: # -NOFAIL ! 15497: # ! 15498: cnc19: clrl cswfl # clear switch ! 15499: jmp cnc08 # merge ! 15500: # ! 15501: # -NOLIST ! 15502: # ! 15503: cnc20: clrl cswls # clear switch ! 15504: jmp cnc08 # merge ! 15505: # ! 15506: # -NOOPTIMISE ! 15507: # ! 15508: cnc21: movl sp,cswno # set switch ! 15509: jmp cnc08 # merge ! 15510: # ! 15511: # -NOPRINT ! 15512: # ! 15513: cnc22: clrl cswpr # clear switch ! 15514: jmp cnc08 # merge ! 15515: # ! 15516: # -OPTIMISE ! 15517: # ! 15518: cnc24: clrl cswno # clear switch ! 15519: jmp cnc08 # merge ! 15520: # ! 15521: # -PRINT ! 15522: # ! 15523: cnc25: movl sp,cswpr # set switch ! 15524: jmp cnc08 # merge ! 15525: #page ! 15526: # ! 15527: # CNCRD (CONTINUED) ! 15528: # ! 15529: # -SINGLE ! 15530: # ! 15531: cnc27: clrl cswdb # clear switch ! 15532: jmp cnc08 # merge ! 15533: # ! 15534: # -SPACE ! 15535: # ! 15536: cnc28: tstl cswls # return if -nolist ! 15537: bnequ 0f ! 15538: jmp cnc09 ! 15539: 0: ! 15540: jsb scane # scan integer after -space ! 15541: movl $num01,r8 # 1 space in case ! 15542: cmpl r9,$t$smc # jump if no integer ! 15543: beqlu cnc29 ! 15544: movl r9,-(sp) # stack it ! 15545: jsb gtsmi # check integer ! 15546: .long cnc06 # fail if not integer ! 15547: .long cnc06 # fail if negative or large ! 15548: tstl r8 # jump if non zero ! 15549: bnequ cnc29 ! 15550: movl $num01,r8 # else 1 space ! 15551: # ! 15552: # MERGE WITH COUNT OF LINES TO SKIP ! 15553: # ! 15554: cnc29: addl2 r8,lstlc # bump line count ! 15555: # convert to loop counter ! 15556: cmpl lstlc,lstnp # jump if fits on page ! 15557: blssu cnc30 ! 15558: jsb prtps # eject ! 15559: jsb listt # list title ! 15560: jmp cnc09 # merge ! 15561: # ! 15562: # SKIP LINES ! 15563: # ! 15564: cnc30: jsb prtnl # print a blank ! 15565: sobgtr r8,cnc30 # loop ! 15566: jmp cnc09 # merge ! 15567: #page ! 15568: # ! 15569: # CNCRD (CONTINUED) ! 15570: # ! 15571: # -STITL ! 15572: # ! 15573: cnc31: movl $r$stl,cnr$t # ptr to r$stl ! 15574: jmp cnc33 # merge ! 15575: # ! 15576: # -TITLE ! 15577: # ! 15578: cnc32: movl $nulls,r$stl # clear subtitle ! 15579: movl $r$ttl,cnr$t # ptr to r$ttl ! 15580: # ! 15581: # COMMON PROCESSING FOR -TITLE, -STITL ! 15582: # ! 15583: cnc33: movl $nulls,r9 # null in case needed ! 15584: movl sp,cnttl # set flag for next listr call ! 15585: movl $ccofs,r7 # offset to title/subtitle ! 15586: movl scnil,r6 # input image length ! 15587: cmpl r6,r7 # jump if no chars left ! 15588: blequ cnc34 ! 15589: subl2 r7,r6 # no of chars to extract ! 15590: movl r$cim,r10 # point to image ! 15591: jsb sbstr # get title/subtitle ! 15592: # ! 15593: # STORE TITLE/SUBTITLE ! 15594: # ! 15595: cnc34: movl cnr$t,r10 # point to storage location ! 15596: movl r9,(r10) # store title/subtitle ! 15597: cmpl r10,$r$stl # return if stitl ! 15598: bnequ 0f ! 15599: jmp cnc09 ! 15600: 0: ! 15601: tstl precl # return if extended listing ! 15602: beqlu 0f ! 15603: jmp cnc09 ! 15604: 0: ! 15605: tstl prich # return if regular printer ! 15606: bnequ 0f ! 15607: jmp cnc09 ! 15608: 0: ! 15609: movl 4*sclen(r9),r10 # get length of title ! 15610: movl r10,r6 # copy it ! 15611: tstl r10 # jump if null ! 15612: beqlu cnc35 ! 15613: addl2 $num10,r10 # increment ! 15614: cmpl r10,prlen # use default lstp0 val if too long ! 15615: blssu 0f ! 15616: jmp cnc09 ! 15617: 0: ! 15618: addl2 $num04,r6 # point just past title ! 15619: # ! 15620: # STORE OFFSET TO PAGE NN MESSAGE FOR SHORT TITLE ! 15621: # ! 15622: cnc35: movl r6,lstpo # store offset ! 15623: jmp cnc09 # return ! 15624: # ! 15625: # -TRACE ! 15626: # PROVIDED FOR SYSTEM DEBUGGING. TOGGLES THE SYSTEM LABEL ! 15627: # TRACE SWITCH AT COMPILE TIME ! 15628: # ! 15629: cnc36: jsb systt # toggle switch ! 15630: jmp cnc08 # merge ! 15631: # ! 15632: # -CASE ! 15633: # SETS VALUE OF KVCAS SO THAT NAMES ARE FOLDED OR NOT ! 15634: # DURING COMPILATION. ! 15635: # ! 15636: cnc37: jsb scane # scan integer after -case ! 15637: clrl r8 # get 0 in case none there ! 15638: cmpl r10,$t$smc # skip if no integer ! 15639: beqlu cnc38 ! 15640: movl r9,-(sp) # stack it ! 15641: jsb gtsmi # check integer ! 15642: .long cnc06 # fail if not integer ! 15643: .long cnc06 # fail if negative or too large ! 15644: cnc38: movl r8,kvcas # store new case value ! 15645: jmp cnc09 # merge ! 15646: #enp # end procedure cncrd ! 15647: #page ! 15648: # ! 15649: # DFFNC -- DEFINE FUNCTION ! 15650: # ! 15651: # DFFNC IS CALLED WHENEVER A NEW FUNCTION IS ASSIGNED TO ! 15652: # A VARIABLE. IT DEALS WITH EXTERNAL FUNCTION USE COUNTS. ! 15653: # ! 15654: # (XR) POINTER TO VRBLK ! 15655: # (XL) POINTER TO NEW FUNCTION BLOCK ! 15656: # JSR DFFNC CALL TO DEFINE FUNCTION ! 15657: # (WA,WB) DESTROYED ! 15658: # ! 15659: dffnc: #prc # entry point ! 15660: cmpl (r10),$b$efc # skip if new function not external ! 15661: bnequ dffn1 ! 15662: incl 4*efuse(r10) # else increment its use count ! 15663: # ! 15664: # HERE AFTER DEALING WITH NEW FUNCTION USE COUNT ! 15665: # ! 15666: dffn1: movl r9,r6 # save vrblk pointer ! 15667: movl 4*vrfnc(r9),r9 # load old function pointer ! 15668: cmpl (r9),$b$efc # jump if old function not external ! 15669: bnequ dffn2 ! 15670: movl 4*efuse(r9),r7 # else get use count ! 15671: decl r7 # decrement ! 15672: movl r7,4*efuse(r9) # store decremented value ! 15673: tstl r7 # jump if use count still non-zero ! 15674: bnequ dffn2 ! 15675: jsb sysul # else call system unload function ! 15676: # ! 15677: # HERE AFTER DEALING WITH OLD FUNCTION USE COUNT ! 15678: # ! 15679: dffn2: movl r6,r9 # restore vrblk pointer ! 15680: movl r10,r6 # copy function block ptr ! 15681: cmpl r9,$r$yyy # skip checks if opsyn op definition ! 15682: blssu dffn3 ! 15683: tstl 4*vrlen(r9) # jump if not system variable ! 15684: bnequ dffn3 ! 15685: # ! 15686: # FOR SYSTEM VARIABLE, CHECK FOR ILLEGAL REDEFINITION ! 15687: # ! 15688: movl 4*vrsvp(r9),r10 # point to svblk ! 15689: movl 4*svbit(r10),r7 # load bit indicators ! 15690: mcoml btfnc,r11 # is it a system function ! 15691: bicl2 r11,r7 ! 15692: beqlu dffn3 # redef ok if not ! 15693: jmp er_248 # attempted redefinition of system function ! 15694: # ! 15695: # HERE IF REDEFINITION IS PERMITTED ! 15696: # ! 15697: dffn3: movl r6,4*vrfnc(r9) # store new function pointer ! 15698: movl r6,r10 # restore function block pointer ! 15699: rsb # return to dffnc caller ! 15700: #enp # end procedure dffnc ! 15701: #page ! 15702: # ! 15703: # DTACH -- DETACH I/O ASSOCIATED NAMES ! 15704: # ! 15705: # DETACHES TRBLKS FROM I/O ASSOCIATED VARIABLES, REMOVES ! 15706: # ENTRY FROM IOCHN CHAIN ATTACHED TO FILEARG1 VRBLK AND MAY ! 15707: # REMOVE VRBLK ACCESS AND STORE TRAPS. ! 15708: # INPUT, OUTPUT, TERMINAL ARE HANDLED SPECIALLY. ! 15709: # ! 15710: # (XL) I/O ASSOC. VBL NAME BASE PTR ! 15711: # (WA) OFFSET TO NAME ! 15712: # JSR DTACH CALL FOR DETACH OPERATION ! 15713: # (XL,XR,WA,WB,WC) DESTROYED ! 15714: # ! 15715: dtach: #prc # entry point ! 15716: movl r10,dtcnb # store name base (gbcol not called) ! 15717: addl2 r6,r10 # point to name location ! 15718: movl r10,dtcnm # store it ! 15719: # ! 15720: # LOOP TO SEARCH FOR I/O TRBLK ! 15721: # ! 15722: dtch1: movl r10,r9 # copy name pointer ! 15723: # ! 15724: # CONTINUE AFTER BLOCK DELETION ! 15725: # ! 15726: dtch2: movl (r10),r10 # point to next value ! 15727: cmpl (r10),$b$trt # jump at chain end ! 15728: bnequ dtch6 ! 15729: movl 4*trtyp(r10),r6 # get trap block type ! 15730: cmpl r6,$trtin # jump if input ! 15731: beqlu dtch3 ! 15732: cmpl r6,$trtou # jump if output ! 15733: beqlu dtch3 ! 15734: addl2 $4*trnxt,r10 # point to next link ! 15735: jmp dtch1 # loop ! 15736: # ! 15737: # DELETE AN OLD ASSOCIATION ! 15738: # ! 15739: dtch3: movl 4*trval(r10),(r9)# delete trblk ! 15740: movl r10,r6 # dump xl ... ! 15741: movl r9,r7 # ... and xr ! 15742: movl 4*trtrf(r10),r10# point to trtrf trap block ! 15743: beqlu dtch5 # jump if no iochn ! 15744: cmpl (r10),$b$trt # jump if input, output, terminal ! 15745: bnequ dtch5 ! 15746: # ! 15747: # LOOP TO SEARCH IOCHN CHAIN FOR NAME PTR ! 15748: # ! 15749: dtch4: movl r10,r9 # remember link ptr ! 15750: movl 4*trtrf(r10),r10# point to next link ! 15751: beqlu dtch5 # jump if end of chain ! 15752: movl 4*ionmb(r10),r8 # get name base ! 15753: addl2 4*ionmo(r10),r8 # add offset ! 15754: cmpl r8,dtcnm # loop if no match ! 15755: bnequ dtch4 ! 15756: movl 4*trtrf(r10),4*trtrf(r9) # remove name from chain ! 15757: #page ! 15758: # ! 15759: # DTACH (CONTINUED) ! 15760: # ! 15761: # PREPARE TO RESUME I/O TRBLK SCAN ! 15762: # ! 15763: dtch5: movl r6,r10 # recover xl ... ! 15764: movl r7,r9 # ... and xr ! 15765: addl2 $4*trval,r10 # point to value field ! 15766: jmp dtch2 # continue ! 15767: # ! 15768: # EXIT POINT ! 15769: # ! 15770: dtch6: movl dtcnb,r9 # possible vrblk ptr ! 15771: jsb setvr # reset vrblk if necessary ! 15772: rsb # return ! 15773: #enp # end procedure dtach ! 15774: #page ! 15775: # ! 15776: # DTYPE -- GET DATATYPE NAME ! 15777: # ! 15778: # (XR) OBJECT WHOSE DATATYPE IS REQUIRED ! 15779: # JSR DTYPE CALL TO GET DATATYPE ! 15780: # (XR) RESULT DATATYPE ! 15781: # ! 15782: dtype: #prc # entry point ! 15783: cmpl (r9),$b$pdt # jump if prog.defined ! 15784: beqlu dtyp1 ! 15785: movl (r9),r9 # load type word ! 15786: movzwl -2(r9),r9 # get entry point id (block code) ! 15787: moval 0[r9],r9 # convert to byte offset ! 15788: movl l^scnmt(r9),r9 # load table entry ! 15789: rsb # exit to dtype caller ! 15790: # ! 15791: # HERE IF PROGRAM DEFINED ! 15792: # ! 15793: dtyp1: movl 4*pddfp(r9),r9 # point to dfblk ! 15794: movl 4*dfnam(r9),r9 # get datatype name from dfblk ! 15795: rsb # return to dtype caller ! 15796: #enp # end procedure dtype ! 15797: #page ! 15798: # ! 15799: # DUMPR -- PRINT DUMP OF STORAGE ! 15800: # ! 15801: # (XR) DUMP ARGUMENT (SEE BELOW) ! 15802: # JSR DUMPR CALL TO PRINT DUMP ! 15803: # (XR,XL) DESTROYED ! 15804: # (WA,WB,WC,RA) DESTROYED ! 15805: # ! 15806: # THE DUMP ARGUMENT HAS THE FOLLOWING SIGNIFICANCE ! 15807: # ! 15808: # DMARG = 0 NO DUMP PRINTED ! 15809: # DMARG = 1 PARTIAL DUMP (NAT VARS, KEYWORDS) ! 15810: # DMARG EQ 2 FULL DUMP (INCL ARRAYS ETC.) ! 15811: # DMARG GE 3 CORE DUMP ! 15812: # ! 15813: # SINCE DUMPR SCRAMBLES STORE, IT IS NOT PERMISSIBLE TO ! 15814: # COLLECT IN MID-DUMP. HENCE A COLLECT IS DONE INITIALLY ! 15815: # AND THEN IF STORE RUNS OUT AN ERROR MESSAGE IS PRODUCED. ! 15816: # ! 15817: dumpr: #prc # entry point ! 15818: tstl r9 # skip dump if argument is zero ! 15819: bnequ 0f ! 15820: jmp dmp28 ! 15821: 0: ! 15822: cmpl r9,$num02 # jump if core dump required ! 15823: blequ 0f ! 15824: jmp dmp29 ! 15825: 0: ! 15826: clrl r10 # clear xl ! 15827: clrl r7 # zero move offset ! 15828: movl r9,dmarg # save dump argument ! 15829: jsb gbcol # collect garbage ! 15830: jsb prtpg # eject printer ! 15831: movl $dmhdv,r9 # point to heading for variables ! 15832: jsb prtst # print it ! 15833: jsb prtnl # terminate print line ! 15834: jsb prtnl # and print a blank line ! 15835: # ! 15836: # FIRST ALL NATURAL VARIABLE BLOCKS (VRBLK) WHOSE VALUES ! 15837: # ARE NON-NULL ARE LINKED IN LEXICAL ORDER USING DMVCH AS ! 15838: # THE CHAIN HEAD AND CHAINING THROUGH THE VRGET FIELDS. ! 15839: # NOTE THAT THIS SCRAMBLES STORE IF THE PROCESS IS ! 15840: # INTERRUPTED BEFORE COMPLETION E.G. BY EXCEEDING TIME OR ! 15841: # PRINT LIMITS. SINCE THE SUBSEQUENT CORE DUMPS AND ! 15842: # FAILURES IF EXECUTION IS RESUMED ARE VERY CONFUSING, THE ! 15843: # EXECUTION TIME ERROR ROUTINE CHECKS FOR THIS EVENT AND ! 15844: # ATTEMPTS AN UNSCRAMBLE. SIMILAR PRECAUTIONS SHOULD BE ! 15845: # OBSERVED IF TRANSLATE TIME DUMPING IS IMPLEMENTED. ! 15846: # ! 15847: clrl dmvch # set null chain to start ! 15848: movl hshtb,r6 # point to hash table ! 15849: # ! 15850: # LOOP THROUGH HEADERS IN HASH TABLE ! 15851: # ! 15852: dmp00: movl r6,r9 # copy hash bucket pointer ! 15853: addl2 $4,r6 # bump pointer ! 15854: subl2 $4*vrnxt,r9 # set offset to merge ! 15855: # ! 15856: # LOOP THROUGH VRBLKS ON ONE CHAIN ! 15857: # ! 15858: dmp01: movl 4*vrnxt(r9),r9 # point to next vrblk on chain ! 15859: bnequ 0f # jump if end of this hash chain ! 15860: jmp dmp09 ! 15861: 0: ! 15862: movl r9,r10 # else copy vrblk pointer ! 15863: #page ! 15864: # ! 15865: # DUMPR (CONTINUED) ! 15866: # ! 15867: # LOOP TO FIND VALUE AND SKIP IF NULL ! 15868: # ! 15869: dmp02: movl 4*vrval(r10),r10# load value ! 15870: cmpl r10,$nulls # loop for next vrblk if null value ! 15871: beqlu dmp01 ! 15872: cmpl (r10),$b$trt # loop back if value is trapped ! 15873: beqlu dmp02 ! 15874: # ! 15875: # NON-NULL VALUE, PREPARE TO SEARCH CHAIN ! 15876: # ! 15877: movl r9,r8 # save vrblk pointer ! 15878: addl2 $4*vrsof,r9 # adjust ptr to be like scblk ptr ! 15879: tstl 4*sclen(r9) # jump if non-system variable ! 15880: bnequ dmp03 ! 15881: movl 4*vrsvo(r9),r9 # else load ptr to name in svblk ! 15882: # ! 15883: # HERE WITH NAME POINTER FOR NEW BLOCK IN XR ! 15884: # ! 15885: dmp03: movl r9,r7 # save pointer to chars ! 15886: movl r6,dmpsv # save hash bucket pointer ! 15887: movl $dmvch,r6 # point to chain head ! 15888: # ! 15889: # LOOP TO SEARCH CHAIN FOR CORRECT INSERTION POINT ! 15890: # ! 15891: dmp04: movl r6,dmpch # save chain pointer ! 15892: movl r6,r10 # copy it ! 15893: movl (r10),r9 # load pointer to next entry ! 15894: bnequ 0f # jump if end of chain to insert ! 15895: jmp dmp08 ! 15896: 0: ! 15897: addl2 $4*vrsof,r9 # else get name ptr for chained vrblk ! 15898: tstl 4*sclen(r9) # jump if not system variable ! 15899: bnequ dmp05 ! 15900: movl 4*vrsvo(r9),r9 # else point to name in svblk ! 15901: # ! 15902: # HERE PREPARE TO COMPARE THE NAMES ! 15903: # ! 15904: # (WA) SCRATCH ! 15905: # (WB) POINTER TO STRING OF ENTERING VRBLK ! 15906: # (WC) POINTER TO ENTERING VRBLK ! 15907: # (XR) POINTER TO STRING OF CURRENT BLOCK ! 15908: # (XL) SCRATCH ! 15909: # ! 15910: dmp05: movl r7,r10 # point to entering vrblk string ! 15911: movl 4*sclen(r10),r6 # load its length ! 15912: movab cfp$f(r10),r10 # point to chars of entering string ! 15913: cmpl r6,4*sclen(r9) # jump if entering length high ! 15914: bgequ dmp06 ! 15915: movab cfp$f(r9),r9 # else point to chars of old string ! 15916: jsb sbcmc # compare, insert if new is llt old ! 15917: .long dmp08 ! 15918: .long dmp07 ! 15919: jmp dmp08 # or if leq (we had shorter length) ! 15920: # ! 15921: # HERE WHEN NEW LENGTH IS LONGER THAN OLD LENGTH ! 15922: # ! 15923: dmp06: movl 4*sclen(r9),r6 # load shorter length ! 15924: movab cfp$f(r9),r9 # point to chars of old string ! 15925: jsb sbcmc # compare, insert if new one low ! 15926: .long dmp08 ! 15927: .long dmp07 ! 15928: #page ! 15929: # ! 15930: # DUMPR (CONTINUED) ! 15931: # ! 15932: # HERE WE MOVE OUT ON THE CHAIN ! 15933: # ! 15934: dmp07: movl dmpch,r10 # copy chain pointer ! 15935: movl (r10),r6 # move to next entry on chain ! 15936: jmp dmp04 # loop back ! 15937: # ! 15938: # HERE AFTER LOCATING THE PROPER INSERTION POINT ! 15939: # ! 15940: dmp08: movl dmpch,r10 # copy chain pointer ! 15941: movl dmpsv,r6 # restore hash bucket pointer ! 15942: movl r8,r9 # restore vrblk pointer ! 15943: movl (r10),4*vrget(r9)# link vrblk to rest of chain ! 15944: movl r9,(r10) # link vrblk into current chain loc ! 15945: jmp dmp01 # loop back for next vrblk ! 15946: # ! 15947: # HERE AFTER PROCESSING ALL VRBLKS ON ONE CHAIN ! 15948: # ! 15949: dmp09: cmpl r6,hshte # loop back if more buckets to go ! 15950: beqlu 0f ! 15951: jmp dmp00 ! 15952: 0: ! 15953: # ! 15954: # LOOP TO GENERATE DUMP OF NATURAL VARIABLE VALUES ! 15955: # ! 15956: dmp10: movl dmvch,r9 # load pointer to next entry on chain ! 15957: beqlu dmp11 # jump if end of chain ! 15958: movl (r9),dmvch # else update chain ptr to next entry ! 15959: jsb setvr # restore vrget field ! 15960: movl r9,r10 # copy vrblk pointer (name base) ! 15961: movl $4*vrval,r6 # set offset for vrblk name ! 15962: jsb prtnv # print name = value ! 15963: jmp dmp10 # loop back till all printed ! 15964: # ! 15965: # PREPARE TO PRINT KEYWORDS ! 15966: # ! 15967: dmp11: jsb prtnl # print blank line ! 15968: jsb prtnl # and another ! 15969: movl $dmhdk,r9 # point to keyword heading ! 15970: jsb prtst # print heading ! 15971: jsb prtnl # end line ! 15972: jsb prtnl # print one blank line ! 15973: movl $vdmkw,r10 # point to list of keyword svblk ptrs ! 15974: #page ! 15975: # ! 15976: # DUMPR (CONTINUED) ! 15977: # ! 15978: # LOOP TO DUMP KEYWORD VALUES ! 15979: # ! 15980: dmp12: movl (r10)+,r9 # load next svblk ptr from table ! 15981: beqlu dmp13 # jump if end of list ! 15982: movl $ch$am,r6 # load ampersand ! 15983: jsb prtch # print ampersand ! 15984: jsb prtst # print keyword name ! 15985: movl 4*svlen(r9),r6 # load name length from svblk ! 15986: movab 3+(4*svchs)(r6),r6 # get length of name ! 15987: bicl2 $3,r6 ! 15988: addl2 r6,r9 # point to svknm field ! 15989: movl (r9),dmpkn # store in dummy kvblk ! 15990: movl $tmbeb,r9 # point to blank-equal-blank ! 15991: jsb prtst # print it ! 15992: movl r10,dmpsv # save table pointer ! 15993: movl $dmpkb,r10 # point to dummy kvblk ! 15994: movl $4*kvvar,r6 # set zero offset ! 15995: jsb acess # get keyword value ! 15996: .long invalid$ # failure is impossible ! 15997: jsb prtvl # print keyword value ! 15998: jsb prtnl # terminate print line ! 15999: movl dmpsv,r10 # restore table pointer ! 16000: jmp dmp12 # loop back till all printed ! 16001: # ! 16002: # HERE AFTER COMPLETING PARTIAL DUMP ! 16003: # ! 16004: dmp13: cmpl dmarg,$num01 # exit if partial dump complete ! 16005: bnequ 0f ! 16006: jmp dmp27 ! 16007: 0: ! 16008: movl dnamb,r9 # else point to first dynamic block ! 16009: # ! 16010: # LOOP THROUGH BLOCKS IN DYNAMIC STORAGE ! 16011: # ! 16012: dmp14: cmpl r9,dnamp # jump if end of used region ! 16013: bnequ 0f ! 16014: jmp dmp27 ! 16015: 0: ! 16016: movl (r9),r6 # else load first word of block ! 16017: cmpl r6,$b$vct # jump if vector ! 16018: beqlu dmp16 ! 16019: cmpl r6,$b$art # jump if array ! 16020: beqlu dmp17 ! 16021: cmpl r6,$b$pdt # jump if program defined ! 16022: beqlu dmp18 ! 16023: cmpl r6,$b$tbt # jump if table ! 16024: beqlu dmp19 ! 16025: cmpl r6,$b$bct # jump if buffer ! 16026: bnequ 0f ! 16027: jmp dmp30 ! 16028: 0: ! 16029: # ! 16030: # MERGE HERE TO MOVE TO NEXT BLOCK ! 16031: # ! 16032: dmp15: jsb blkln # get length of block ! 16033: addl2 r6,r9 # point past this block ! 16034: jmp dmp14 # loop back for next block ! 16035: #page ! 16036: # ! 16037: # DUMPR (CONTINUED) ! 16038: # ! 16039: # HERE FOR VECTOR ! 16040: # ! 16041: dmp16: movl $4*vcvls,r7 # set offset to first value ! 16042: jmp dmp19 # jump to merge ! 16043: # ! 16044: # HERE FOR ARRAY ! 16045: # ! 16046: dmp17: movl 4*arofs(r9),r7 # set offset to arpro field ! 16047: addl2 $4,r7 # bump to get offset to values ! 16048: jmp dmp19 # jump to merge ! 16049: # ! 16050: # HERE FOR PROGRAM DEFINED ! 16051: # ! 16052: dmp18: movl $4*pdfld,r7 # point to values, merge ! 16053: # ! 16054: # HERE FOR TABLE (OTHERS MERGE) ! 16055: # ! 16056: dmp19: tstl 4*idval(r9) # ignore block if zero id value ! 16057: bnequ 0f ! 16058: jmp dmp15 ! 16059: 0: ! 16060: jsb blkln # else get block length ! 16061: movl r9,r10 # copy block pointer ! 16062: movl r6,dmpsv # save length ! 16063: movl r7,r6 # copy offset to first value ! 16064: jsb prtnl # print blank line ! 16065: movl r6,dmpsa # preserve offset ! 16066: jsb prtvl # print block value (for title) ! 16067: movl dmpsa,r6 # recover offset ! 16068: jsb prtnl # end print line ! 16069: cmpl (r9),$b$tbt # jump if table ! 16070: beqlu dmp22 ! 16071: subl2 $4,r6 # point before first word ! 16072: # ! 16073: # LOOP TO PRINT CONTENTS OF ARRAY, VECTOR, OR PROGRAM DEF ! 16074: # ! 16075: dmp20: movl r10,r9 # copy block pointer ! 16076: addl2 $4,r6 # bump offset ! 16077: addl2 r6,r9 # point to next value ! 16078: cmpl r6,dmpsv # exit if end (xr past block) ! 16079: bnequ 0f ! 16080: jmp dmp14 ! 16081: 0: ! 16082: subl2 $4*vrval,r9 # subtract offset to merge into loop ! 16083: # ! 16084: # LOOP TO FIND VALUE AND IGNORE NULLS ! 16085: # ! 16086: dmp21: movl 4*vrval(r9),r9 # load next value ! 16087: cmpl r9,$nulls # loop back if null value ! 16088: beqlu dmp20 ! 16089: cmpl (r9),$b$trt # loop back if trapped ! 16090: beqlu dmp21 ! 16091: jsb prtnv # else print name = value ! 16092: jmp dmp20 # loop back for next field ! 16093: #page ! 16094: # ! 16095: # DUMPR (CONTINUED) ! 16096: # ! 16097: # HERE TO DUMP A TABLE ! 16098: # ! 16099: dmp22: movl $4*tbbuk,r8 # set offset to first bucket ! 16100: movl $4*teval,r6 # set name offset for all teblks ! 16101: # ! 16102: # LOOP THROUGH TABLE BUCKETS ! 16103: # ! 16104: dmp23: movl r10,-(sp) # save tbblk pointer ! 16105: addl2 r8,r10 # point to next bucket header ! 16106: addl2 $4,r8 # bump bucket offset ! 16107: subl2 $4*tenxt,r10 # subtract offset to merge into loop ! 16108: # ! 16109: # LOOP TO PROCESS TEBLKS ON ONE CHAIN ! 16110: # ! 16111: dmp24: movl 4*tenxt(r10),r10# point to next teblk ! 16112: cmpl r10,(sp) # jump if end of chain ! 16113: beqlu dmp26 ! 16114: movl r10,r9 # else copy teblk pointer ! 16115: # ! 16116: # LOOP TO FIND VALUE AND IGNORE IF NULL ! 16117: # ! 16118: dmp25: movl 4*teval(r9),r9 # load next value ! 16119: cmpl r9,$nulls # ignore if null value ! 16120: beqlu dmp24 ! 16121: cmpl (r9),$b$trt # loop back if trapped ! 16122: beqlu dmp25 ! 16123: movl r8,dmpsv # else save offset pointer ! 16124: jsb prtnv # print name = value ! 16125: movl dmpsv,r8 # reload offset ! 16126: jmp dmp24 # loop back for next teblk ! 16127: # ! 16128: # HERE TO MOVE TO NEXT HASH CHAIN ! 16129: # ! 16130: dmp26: movl (sp)+,r10 # restore tbblk pointer ! 16131: cmpl r8,4*tblen(r10) # loop back if more buckets to go ! 16132: bnequ dmp23 ! 16133: movl r10,r9 # else copy table pointer ! 16134: addl2 r8,r9 # point to following block ! 16135: jmp dmp14 # loop back to process next block ! 16136: # ! 16137: # HERE AFTER COMPLETING DUMP ! 16138: # ! 16139: dmp27: jsb prtpg # eject printer ! 16140: # ! 16141: # MERGE HERE IF NO DUMP GIVEN (DMARG=0) ! 16142: # ! 16143: dmp28: rsb # return to dump caller ! 16144: # ! 16145: # CALL SYSTEM CORE DUMP ROUTINE ! 16146: # ! 16147: dmp29: jsb sysdm # call it ! 16148: jmp dmp28 # return ! 16149: #page ! 16150: # ! 16151: # DUMPR (CONTINUED) ! 16152: # ! 16153: # HERE TO DUMP BUFFER BLOCK ! 16154: # ! 16155: dmp30: jsb prtnl # print blank line ! 16156: jsb prtvl # print value id for title ! 16157: jsb prtnl # force new line ! 16158: movl $ch$dq,r6 # load double quote ! 16159: jsb prtch # print it ! 16160: movl 4*bclen(r9),r8 # load defined length ! 16161: beqlu dmp32 # skip characters if none ! 16162: # load count for loop ! 16163: movl r9,r7 # save bcblk ptr ! 16164: movl 4*bcbuf(r9),r9 # point to bfblk ! 16165: movab cfp$f(r9),r9 # get set to load characters ! 16166: # ! 16167: # LOOP HERE STUFFING CHARACTERS IN OUTPUT STREAM ! 16168: # ! 16169: dmp31: movzbl (r9)+,r6 # get next character ! 16170: jsb prtch # stuff it ! 16171: sobgtr r8,dmp31 # branch for next one ! 16172: movl r7,r9 # restore bcblk pointer ! 16173: # ! 16174: # MERGE TO STUFF CLOSING QUOTE MARK ! 16175: # ! 16176: dmp32: movl $ch$dq,r6 # stuff quote ! 16177: jsb prtch # print it ! 16178: jsb prtnl # print new line ! 16179: movl (r9),r6 # get first wd for blkln ! 16180: jmp dmp15 # merge to get next block ! 16181: #enp # end procedure dumpr ! 16182: #page ! 16183: # ! 16184: # ERMSG -- PRINT ERROR CODE AND ERROR MESSAGE ! 16185: # ! 16186: # KVERT ERROR CODE ! 16187: # JSR ERMSG CALL TO PRINT MESSAGE ! 16188: # (XR,XL,WA,WB,WC,IA) DESTROYED ! 16189: # ! 16190: ermsg: #prc # entry point ! 16191: jsb prtis # print error ptr or blank line ! 16192: movl kvert,r6 # load error code ! 16193: movl $ermms,r9 # point to error message /error/ ! 16194: jsb prtst # print it ! 16195: jsb ertex # get error message text ! 16196: addl2 $thsnd,r6 # bump error code for print ! 16197: movl r6,r5 # fail code in int acc ! 16198: jsb prtin # print code (now have error1xxx) ! 16199: movl prbuf,r10 # point to print buffer ! 16200: movl $num05,r11 # [get in scratch register] ! 16201: movab cfp$f(r10)[r11],r10 # point to the 1 ! 16202: movl $ch$bl,r6 # load a blank ! 16203: movb r6,(r10) # store blank over 1 (error xxx) ! 16204: #csc r10 # complete store characters ! 16205: clrl r10 # clear garbage pointer in xl ! 16206: movl r9,r6 # keep error text ! 16207: movl $ermns,r9 # point to / -- / ! 16208: jsb prtst # print it ! 16209: movl r6,r9 # get error text again ! 16210: jsb prtst # print error message text ! 16211: jsb prtis # print line ! 16212: jsb prtis # print blank line ! 16213: rsb # return to ermsg caller ! 16214: #enp # end procedure ermsg ! 16215: #page ! 16216: # ! 16217: # ERTEX -- GET ERROR MESSAGE TEXT ! 16218: # ! 16219: # (WA) ERROR CODE ! 16220: # JSR ERTEX CALL TO GET ERROR TEXT ! 16221: # (XR) PTR TO ERROR TEXT IN DYNAMIC ! 16222: # (R$ETX) COPY OF PTR TO ERROR TEXT ! 16223: # (XL,WC,IA) DESTROYED ! 16224: # ! 16225: ertex: #prc # entry point ! 16226: movl r6,ertwa # save wa ! 16227: movl r7,ertwb # save wb ! 16228: jsb sysem # get failure message text ! 16229: movl r9,r10 # copy pointer to it ! 16230: movl 4*sclen(r9),r6 # get length of string ! 16231: beqlu ert02 # jump if null ! 16232: clrl r7 # offset of zero ! 16233: jsb sbstr # copy into dynamic store ! 16234: movl r9,r$etx # store for relocation ! 16235: # ! 16236: # RETURN ! 16237: # ! 16238: ert01: movl ertwb,r7 # restore wb ! 16239: movl ertwa,r6 # restore wa ! 16240: rsb # return to caller ! 16241: # ! 16242: # RETURN ERRTEXT CONTENTS INSTEAD OF NULL ! 16243: # ! 16244: ert02: movl r$etx,r9 # get errtext ! 16245: jmp ert01 # return ! 16246: #enp ! 16247: #page ! 16248: # ! 16249: # EVALI -- EVALUATE INTEGER ARGUMENT ! 16250: # ! 16251: # EVALI IS USED BY PATTERN PRIMITIVES LEN,TAB,RTAB,POS,RPOS ! 16252: # WHEN THEIR ARGUMENT IS AN EXPRESSION VALUE. ! 16253: # ! 16254: # (XR) NODE POINTER ! 16255: # (WB) CURSOR ! 16256: # JSR EVALI CALL TO EVALUATE INTEGER ! 16257: # PPM LOC TRANSFER LOC FOR NON-INTEGER ARG ! 16258: # PPM LOC TRANSFER LOC FOR OUT OF RANGE ARG ! 16259: # PPM LOC TRANSFER LOC FOR EVALUATION FAILURE ! 16260: # PPM LOC TRANSFER LOC FOR SUCCESSFUL EVAL ! 16261: # (THE NORMAL RETURN IS NEVER TAKEN) ! 16262: # (XR) PTR TO NODE WITH INTEGER ARGUMENT ! 16263: # (WC,XL,RA) DESTROYED ! 16264: # ! 16265: # ON RETURN, THE NODE POINTED TO HAS THE INTEGER ARGUMENT ! 16266: # IN PARM1 AND THE PROPER SUCCESSOR POINTER IN PTHEN. ! 16267: # THIS ALLOWS MERGING WITH THE NORMAL (INTEGER ARG) CASE. ! 16268: # ! 16269: evali: #prc # entry point (recursive) ! 16270: jsb evalp # evaluate expression ! 16271: .long evli1 # jump on failure ! 16272: movl r10,-(sp) # stack result for gtsmi ! 16273: movl 4*pthen(r9),r10 # load successor pointer ! 16274: jsb gtsmi # convert arg to small integer ! 16275: .long evli2 # jump if not integer ! 16276: .long evli3 # jump if out of range ! 16277: movl r9,evliv # store result in special dummy node ! 16278: movl r10,evlis # store successor pointer ! 16279: movl $evlin,r9 # point to dummy node with result ! 16280: addl3 $4*3,(sp)+,r11 # take successful exit ! 16281: jmp *(r11)+ ! 16282: # ! 16283: # HERE IF EVALUATION FAILS ! 16284: # ! 16285: evli1: addl3 $4*2,(sp)+,r11 # take failure return ! 16286: jmp *(r11)+ ! 16287: # ! 16288: # HERE IF ARGUMENT IS NOT INTEGER ! 16289: # ! 16290: evli2: movl (sp)+,r11 # take non-integer error exit ! 16291: jmp *(r11)+ ! 16292: # ! 16293: # HERE IF ARGUMENT IS OUT OF RANGE ! 16294: # ! 16295: evli3: addl3 $4*1,(sp)+,r11 # take out-of-range error exit ! 16296: jmp *(r11)+ ! 16297: #enp # end procedure evali ! 16298: #page ! 16299: # ! 16300: # EVALP -- EVALUATE EXPRESSION DURING PATTERN MATCH ! 16301: # ! 16302: # EVALP IS USED TO EVALUATE AN EXPRESSION (BY VALUE) DURING ! 16303: # A PATTERN MATCH. THE EFFECT IS LIKE EVALX, BUT PATTERN ! 16304: # VARIABLES ARE STACKED AND RESTORED IF NECESSARY. ! 16305: # ! 16306: # EVALP ALSO DIFFERS FROM EVALX IN THAT IF THE RESULT IS ! 16307: # AN EXPRESSION IT IS REEVALUATED. THIS OCCURS REPEATEDLY. ! 16308: # ! 16309: # (XR) NODE POINTER ! 16310: # (WB) PATTERN MATCH CURSOR ! 16311: # JSR EVALP CALL TO EVALUATE EXPRESSION ! 16312: # PPM LOC TRANSFER LOC IF EVALUATION FAILS ! 16313: # (XL) RESULT ! 16314: # (WA) FIRST WORD OF RESULT BLOCK ! 16315: # (XR,WB) DESTROYED (FAILURE CASE ONLY) ! 16316: # (WC,RA) DESTROYED ! 16317: # ! 16318: # THE EXPRESSION POINTER IS STORED IN PARM1 OF THE NODE ! 16319: # ! 16320: # CONTROL RETURNS TO FAILP ON FAILURE OF EVALUATION ! 16321: # ! 16322: evalp: #prc # entry point (recursive) ! 16323: movl 4*parm1(r9),r10 # load expression pointer ! 16324: cmpl (r10),$b$exl # jump if exblk case ! 16325: beqlu evlp1 ! 16326: # ! 16327: # HERE FOR CASE OF SEBLK ! 16328: # ! 16329: # WE CAN GIVE A FAST RETURN IF THE VALUE OF THE VRBLK IS ! 16330: # NOT AN EXPRESSION AND IS NOT TRAPPED. ! 16331: # ! 16332: movl 4*sevar(r10),r10# load vrblk pointer ! 16333: movl 4*vrval(r10),r10# load value of vrblk ! 16334: movl (r10),r6 # load first word of value ! 16335: cmpl r6,$b$t$$ # jump if not seblk, trblk or exblk ! 16336: bgequ evlp3 ! 16337: # ! 16338: # HERE FOR EXBLK OR SEBLK WITH EXPR VALUE OR TRAPPED VALUE ! 16339: # ! 16340: evlp1: movl r9,-(sp) # stack node pointer ! 16341: movl r7,-(sp) # stack cursor ! 16342: movl r$pms,-(sp) # stack subject string pointer ! 16343: movl pmssl,-(sp) # stack subject string length ! 16344: movl pmdfl,-(sp) # stack dot flag ! 16345: movl pmhbs,-(sp) # stack history stack base pointer ! 16346: movl 4*parm1(r9),r9 # load expression pointer ! 16347: #page ! 16348: # ! 16349: # EVALP (CONTINUED) ! 16350: # ! 16351: # LOOP BACK HERE TO REEVALUATE EXPRESSION RESULT ! 16352: # ! 16353: evlp2: clrl r7 # set flag for by value ! 16354: jsb evalx # evaluate expression ! 16355: .long evlp4 # jump on failure ! 16356: movl (r9),r6 # else load first word of value ! 16357: cmpl r6,$b$e$$ # loop back to reevaluate expression ! 16358: blequ evlp2 ! 16359: # ! 16360: # HERE TO RESTORE PATTERN VALUES AFTER SUCCESSFUL EVAL ! 16361: # ! 16362: movl r9,r10 # copy result pointer ! 16363: movl (sp)+,pmhbs # restore history stack base pointer ! 16364: movl (sp)+,pmdfl # restore dot flag ! 16365: movl (sp)+,pmssl # restore subject string length ! 16366: movl (sp)+,r$pms # restore subject string pointer ! 16367: movl (sp)+,r7 # restore cursor ! 16368: movl (sp)+,r9 # restore node pointer ! 16369: # ! 16370: # COMMON EXIT POINT ! 16371: # ! 16372: evlp3: addl2 $4*1,(sp) # return to evalp caller ! 16373: rsb ! 16374: # ! 16375: # HERE FOR FAILURE DURING EVALUATION ! 16376: # ! 16377: evlp4: movl (sp)+,pmhbs # restore history stack base pointer ! 16378: movl (sp)+,pmdfl # restore dot flag ! 16379: movl (sp)+,pmssl # restore subject string length ! 16380: movl (sp)+,r$pms # restore subject string pointer ! 16381: addl2 $4*num02,sp # remove node ptr, cursor ! 16382: movl (sp)+,r11 # take failure exit ! 16383: jmp *(r11)+ ! 16384: #enp # end procedure evalp ! 16385: #page ! 16386: # ! 16387: # EVALS -- EVALUATE STRING ARGUMENT ! 16388: # ! 16389: # EVALS IS USED BY SPAN, ANY, NOTANY, BREAK, BREAKX WHEN ! 16390: # THEY ARE PASSED AN EXPRESSION ARGUMENT. ! 16391: # ! 16392: # (XR) NODE POINTER ! 16393: # (WB) CURSOR ! 16394: # JSR EVALS CALL TO EVALUATE STRING ! 16395: # PPM LOC TRANSFER LOC FOR NON-STRING ARG ! 16396: # PPM LOC TRANSFER LOC FOR EVALUATION FAILURE ! 16397: # PPM LOC TRANSFER LOC FOR SUCCESSFUL EVAL ! 16398: # (THE NORMAL RETURN IS NEVER TAKEN) ! 16399: # (XR) PTR TO NODE WITH PARMS SET ! 16400: # (XL,WC,RA) DESTROYED ! 16401: # ! 16402: # ON RETURN, THE NODE POINTED TO HAS A CHARACTER TABLE ! 16403: # POINTER IN PARM1 AND A BIT MASK IN PARM2. THE PROPER ! 16404: # SUCCESSOR IS STORED IN PTHEN OF THIS NODE. THUS IT IS ! 16405: # OK FOR MERGING WITH THE NORMAL (MULTI-CHAR STRING) CASE. ! 16406: # ! 16407: evals: #prc # entry point (recursive) ! 16408: jsb evalp # evaluate expression ! 16409: .long evls1 # jump if evaluation fails ! 16410: movl 4*pthen(r9),-(sp)# save successor pointer ! 16411: movl r7,-(sp) # save cursor ! 16412: movl r10,-(sp) # stack result ptr for patst ! 16413: clrl r7 # dummy pcode for one char string ! 16414: clrl r8 # dummy pcode for expression arg ! 16415: movl $p$brk,r10 # appropriate pcode for our use ! 16416: jsb patst # call routine to build node ! 16417: .long evls2 # jump if not string ! 16418: movl (sp)+,r7 # restore cursor ! 16419: movl (sp)+,4*pthen(r9)# store successor pointer ! 16420: addl3 $4*2,(sp)+,r11 # take success return ! 16421: jmp *(r11)+ ! 16422: # ! 16423: # HERE IF EVALUATION FAILS ! 16424: # ! 16425: evls1: addl3 $4*1,(sp)+,r11 # take failure return ! 16426: jmp *(r11)+ ! 16427: # ! 16428: # HERE IF ARGUMENT IS NOT STRING ! 16429: # ! 16430: evls2: addl2 $4*num02,sp # pop successor and cursor ! 16431: movl (sp)+,r11 # take non-string error exit ! 16432: jmp *(r11)+ ! 16433: #enp # end procedure evals ! 16434: #page ! 16435: # ! 16436: # EVALX -- EVALUATE EXPRESSION ! 16437: # ! 16438: # EVALX IS CALLED TO EVALUATE AN EXPRESSION ! 16439: # ! 16440: # (XR) POINTER TO EXBLK OR SEBLK ! 16441: # (WB) 0 IF BY VALUE, 1 IF BY NAME ! 16442: # JSR EVALX CALL TO EVALUATE EXPRESSION ! 16443: # PPM LOC TRANSFER LOC IF EVALUATION FAILS ! 16444: # (XR) RESULT IF CALLED BY VALUE ! 16445: # (XL,WA) RESULT NAME BASE,OFFSET IF BY NAME ! 16446: # (XR) DESTROYED (NAME CASE ONLY) ! 16447: # (XL,WA) DESTROYED (VALUE CASE ONLY) ! 16448: # (WB,WC,RA) DESTROYED ! 16449: # ! 16450: evalx: #prc # entry point, recursive ! 16451: cmpl (r9),$b$exl # jump if exblk case ! 16452: beqlu evlx2 ! 16453: # ! 16454: # HERE FOR SEBLK ! 16455: # ! 16456: movl 4*sevar(r9),r10 # load vrblk pointer (name base) ! 16457: movl $4*vrval,r6 # set name offset ! 16458: tstl r7 # jump if called by name ! 16459: beqlu 0f ! 16460: jmp evlx1 ! 16461: 0: ! 16462: jsb acess # call routine to access value ! 16463: .long evlx9 # jump if failure on access ! 16464: # ! 16465: # MERGE HERE TO EXIT FOR SEBLK CASE ! 16466: # ! 16467: evlx1: addl2 $4*1,(sp) # return to evalx caller ! 16468: rsb ! 16469: #page ! 16470: # ! 16471: # EVALX (CONTINUED) ! 16472: # ! 16473: # HERE FOR FULL EXPRESSION (EXBLK) CASE ! 16474: # ! 16475: # IF AN ERROR OCCURS IN THE EXPRESSION CODE AT EXECUTION ! 16476: # TIME, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL ! 16477: # WITHOUT RETURNING TO THIS ROUTINE. ! 16478: # THE FOLLOWING ENTRIES ARE MADE ON THE STACK BEFORE ! 16479: # GIVING CONTROL TO THE EXPRESSION CODE ! 16480: # ! 16481: # EVALX RETURN POINT ! 16482: # SAVED VALUE OF R$COD ! 16483: # CODE POINTER (-R$COD) ! 16484: # SAVED VALUE OF FLPTR ! 16485: # 0 IF BY VALUE, 1 IF BY NAME ! 16486: # FLPTR --------------- *EXFLC, FAIL OFFSET IN EXBLK ! 16487: # ! 16488: evlx2: movl r3,r8 # get code pointer ! 16489: movl r$cod,r6 # load code block pointer ! 16490: subl2 r6,r8 # get code pointer as offset ! 16491: movl r6,-(sp) # stack old code block pointer ! 16492: movl r8,-(sp) # stack relative code offset ! 16493: movl flptr,-(sp) # stack old failure pointer ! 16494: movl r7,-(sp) # stack name/value indicator ! 16495: movl $4*exflc,-(sp) # stack new fail offset ! 16496: movl flptr,gtcef # keep in case of error ! 16497: movl r$cod,r$gtc # keep code block pointer similarly ! 16498: movl sp,flptr # set new failure pointer ! 16499: movl r9,r$cod # set new code block pointer ! 16500: movl kvstn,4*exstm(r9)# remember stmnt number ! 16501: addl2 $4*excod,r9 # point to first code word ! 16502: movl r9,r3 # set code pointer ! 16503: cmpl stage,$stgxt # jump if not execution time ! 16504: beqlu 0f ! 16505: jmp exits ! 16506: 0: ! 16507: movl $stgee,stage # evaluating expression ! 16508: jmp exits # jump to execute first code word ! 16509: #page ! 16510: # ! 16511: # EVALX (CONTINUED) ! 16512: # ! 16513: # COME HERE IF SUCCESSFUL RETURN BY VALUE (SEE O$RVL) ! 16514: # ! 16515: evlx3: movl (sp)+,r9 # load value ! 16516: tstl 4*1(sp) # jump if called by value ! 16517: beqlu evlx5 ! 16518: jmp er_249 # expression evaluated by name returned value ! 16519: # ! 16520: # HERE FOR EXPRESSION RETURNING BY NAME (SEE O$RNM) ! 16521: # ! 16522: evlx4: movl (sp)+,r6 # load name offset ! 16523: movl (sp)+,r10 # load name base ! 16524: tstl 4*1(sp) # jump if called by name ! 16525: bnequ evlx5 ! 16526: jsb acess # else access value first ! 16527: .long evlx6 # jump if failure during access ! 16528: # ! 16529: # HERE AFTER LOADING CORRECT RESULT INTO XR OR XL,WA ! 16530: # ! 16531: evlx5: clrl r7 # note successful ! 16532: jmp evlx7 # merge ! 16533: # ! 16534: # HERE FOR FAILURE IN EXPRESSION EVALUATION (SEE O$FEX) ! 16535: # ! 16536: evlx6: movl sp,r7 # note unsuccessful ! 16537: # ! 16538: # RESTORE ENVIRONMENT ! 16539: # ! 16540: evlx7: cmpl stage,$stgee # skip if was not previously xt ! 16541: bnequ evlx8 ! 16542: movl $stgxt,stage # execute time ! 16543: # ! 16544: # MERGE WITH STAGE SET UP ! 16545: # ! 16546: evlx8: addl2 $4*num02,sp # pop name/value indicator, *exfal ! 16547: movl (sp)+,flptr # restore old failure pointer ! 16548: movl (sp)+,r8 # load code offset ! 16549: addl2 (sp),r8 # make code pointer absolute ! 16550: movl (sp)+,r$cod # restore old code block pointer ! 16551: movl r8,r3 # restore old code pointer ! 16552: tstl r7 # jump for successful return ! 16553: bnequ 0f ! 16554: jmp evlx1 ! 16555: 0: ! 16556: # ! 16557: # MERGE HERE FOR FAILURE IN SEBLK CASE ! 16558: # ! 16559: evlx9: movl (sp)+,r11 # take failure exit ! 16560: jmp *(r11)+ ! 16561: #enp # end of procedure evalx ! 16562: #page ! 16563: # ! 16564: # EXBLD -- BUILD EXBLK ! 16565: # ! 16566: # EXBLD IS USED TO BUILD AN EXPRESSION BLOCK FROM THE ! 16567: # CODE COMPILED MOST RECENTLY IN THE CURRENT CCBLK. ! 16568: # ! 16569: # (XL) OFFSET IN CCBLK TO START OF CODE ! 16570: # (WB) INTEGER IN RANGE 0 LE N LE MXLEN ! 16571: # JSR EXBLD CALL TO BUILD EXBLK ! 16572: # (XR) PTR TO CONSTRUCTED EXBLK ! 16573: # (WA,WB,XL) DESTROYED ! 16574: # ! 16575: exbld: #prc # entry point ! 16576: movl r10,r6 # copy offset to start of code ! 16577: subl2 $4*excod,r6 # calc reduction in offset in exblk ! 16578: movl r6,-(sp) # stack for later ! 16579: movl cwcof,r6 # load final offset ! 16580: subl2 r10,r6 # compute length of code ! 16581: addl2 $4*exsi$,r6 # add space for standard fields ! 16582: jsb alloc # allocate space for exblk ! 16583: movl r9,-(sp) # save pointer to exblk ! 16584: movl $b$exl,4*extyp(r9) # store type word ! 16585: clrl 4*exstm(r9) # zeroise stmnt number field ! 16586: movl r6,4*exlen(r9) # store length ! 16587: movl $ofex$,4*exflc(r9) # store failure word ! 16588: addl2 $4*exsi$,r9 # set xr for sysmw ! 16589: movl r10,cwcof # reset offset to start of code ! 16590: addl2 r$ccb,r10 # point to start of code ! 16591: subl2 $4*exsi$,r6 # length of code to move ! 16592: movl r6,-(sp) # stack length of code ! 16593: jsb sbmvw # move code to exblk ! 16594: movl (sp)+,r6 # get length of code ! 16595: ashl $-2,r6,r6 # convert byte count to word count ! 16596: # prepare counter for loop ! 16597: movl (sp),r10 # copy exblk ptr, dont unstack ! 16598: addl2 $4*excod,r10 # point to code itself ! 16599: movl 4*1(sp),r7 # get reduction in offset ! 16600: # ! 16601: # THIS LOOP SEARCHES FOR NEGATION AND SELECTION CODE SO ! 16602: # THAT THE OFFSETS COMPUTED WHILST CODE WAS IN CODE BLOCK ! 16603: # CAN BE TRANSFORMED TO REDUCED VALUES APPLICABLE IN AN ! 16604: # EXBLK. ! 16605: # ! 16606: exbl1: movl (r10)+,r9 # get next code word ! 16607: cmpl r9,$osla$ # jump if selection found ! 16608: beqlu exbl3 ! 16609: cmpl r9,$onta$ # jump if negation found ! 16610: beqlu exbl3 ! 16611: sobgtr r6,exbl1 # loop to end of code ! 16612: # ! 16613: # NO SELECTION FOUND OR MERGE TO EXIT ON TERMINATION ! 16614: # ! 16615: exbl2: movl (sp)+,r9 # pop exblk ptr into xr ! 16616: movl (sp)+,r10 # pop reduction constant ! 16617: rsb # return to caller ! 16618: #page ! 16619: # ! 16620: # EXBLD (CONTINUED) ! 16621: # ! 16622: # SELECTION OR NEGATION FOUND ! 16623: # REDUCE THE OFFSETS AS NEEDED. OFFSETS OCCUR IN WORDS ! 16624: # FOLLOWING CODE WORDS - ! 16625: # =ONTA$, =OSLA$, =OSLB$, =OSLC$ ! 16626: # ! 16627: exbl3: subl2 r7,(r10)+ # adjust offset ! 16628: sobgtr r6,exbl4 # decrement count ! 16629: # ! 16630: exbl4: sobgtr r6,exbl5 # decrement count ! 16631: # ! 16632: # CONTINUE SEARCH FOR MORE OFFSETS ! 16633: # ! 16634: exbl5: movl (r10)+,r9 # get next code word ! 16635: cmpl r9,$osla$ # jump if offset found ! 16636: beqlu exbl3 ! 16637: cmpl r9,$oslb$ # jump if offset found ! 16638: beqlu exbl3 ! 16639: cmpl r9,$oslc$ # jump if offset found ! 16640: beqlu exbl3 ! 16641: cmpl r9,$onta$ # jump if offset found ! 16642: beqlu exbl3 ! 16643: sobgtr r6,exbl5 # loop ! 16644: jmp exbl2 # merge to return ! 16645: #enp # end procedure exbld ! 16646: #page ! 16647: # ! 16648: # EXPAN -- ANALYZE EXPRESSION ! 16649: # ! 16650: # THE EXPRESSION ANALYZER (EXPAN) PROCEDURE IS USED TO SCAN ! 16651: # AN EXPRESSION AND CONVERT IT INTO A TREE REPRESENTATION. ! 16652: # SEE DESCRIPTIONS OF CMBLK, CUBLK, CBBLK IN THE STRUCTURES ! 16653: # SECTION FOR DETAILED FORMAT OF TREE BLOCKS. ! 16654: # ! 16655: # THE ANALYZER USES A SIMPLE PRECEDENCE SCHEME IN WHICH ! 16656: # OPERANDS AND OPERATORS ARE PLACED ON A SINGLE STACK ! 16657: # AND CONDENSATIONS ARE MADE WHEN LOW PRECEDENCE OPERATORS ! 16658: # ARE STACKED AFTER A HIGHER PRECEDENCE OPERATOR. A GLOBAL ! 16659: # VARIABLE (IN WB) KEEPS TRACK OF THE LEVEL AS FOLLOWS. ! 16660: # ! 16661: # 0 SCANNING OUTER LEVEL OF STATEMENT OR EXPRESSION ! 16662: # 1 SCANNING OUTER LEVEL OF NORMAL GOTO ! 16663: # 2 SCANNING OUTER LEVEL OF DIRECT GOTO ! 16664: # 3 SCANNING INSIDE ARRAY BRACKETS ! 16665: # 4 SCANNING INSIDE GROUPING PARENTHESES ! 16666: # 5 SCANNING INSIDE FUNCTION PARENTHESES ! 16667: # ! 16668: # THIS VARIABLE IS SAVED ON THE STACK ON ENCOUNTERING A ! 16669: # GROUPING AND RESTORED AT THE END OF THE GROUPING. ! 16670: # ! 16671: # ANOTHER GLOBAL VARIABLE (IN WC) COUNTS THE NUMBER OF ! 16672: # ITEMS AT ONE GROUPING LEVEL AND IS INCREMENTED FOR EACH ! 16673: # COMMA ENCOUNTERED. IT IS STACKED WITH THE LEVEL INDICATOR ! 16674: # ! 16675: # THE SCAN IS CONTROLLED BY A THREE STATE FINITE MACHINE. ! 16676: # A GLOBAL VARIABLE STORED IN WA IS THE CURRENT STATE. ! 16677: # ! 16678: # WA=0 NOTHING SCANNED AT THIS LEVEL ! 16679: # WA=1 OPERAND EXPECTED ! 16680: # WA=2 OPERATOR EXPECTED ! 16681: # ! 16682: # (WB) CALL TYPE (SEE BELOW) ! 16683: # JSR EXPAN CALL TO ANALYZE EXPRESSION ! 16684: # (XR) POINTER TO RESULTING TREE ! 16685: # (XL,WA,WB,WC,RA) DESTROYED ! 16686: # ! 16687: # THE ENTRY VALUE OF WB INDICATES THE CALL TYPE AS FOLLOWS. ! 16688: # ! 16689: # 0 SCANNING EITHER THE MAIN BODY OF A STATEMENT OR THE ! 16690: # TEXT OF AN EXPRESSION (FROM EVAL CALL). VALID ! 16691: # TERMINATORS ARE COLON, SEMICOLON. THE RESCAN FLAG IS ! 16692: # SET TO RETURN THE TERMINATOR ON THE NEXT SCANE CALL. ! 16693: # ! 16694: # 1 SCANNING A NORMAL GOTO. THE ONLY VALID ! 16695: # TERMINATOR IS A RIGHT PAREN. ! 16696: # ! 16697: # 2 SCANNING A DIRECT GOTO. THE ONLY VALID ! 16698: # TERMINATOR IS A RIGHT BRACKET. ! 16699: #page ! 16700: # ! 16701: # EXPAN (CONTINUED) ! 16702: # ! 16703: # ENTRY POINT ! 16704: # ! 16705: expan: #prc # entry point ! 16706: clrl -(sp) # set top of stack indicator ! 16707: clrl r6 # set initial state to zero ! 16708: clrl r8 # zero counter value ! 16709: # ! 16710: # LOOP HERE FOR SUCCESSIVE ENTRIES ! 16711: # ! 16712: exp01: jsb scane # scan next element ! 16713: addl2 r6,r10 # add state to syntax code ! 16714: casel r10,$0,$t$nes # switch on element type/state ! 16715: 5: ! 16716: .word exp27-5b # unop, s=0 ! 16717: .word exp27-5b # unop, s=1 ! 16718: .word exp04-5b # unop, s=2 ! 16719: .word exp06-5b # left paren, s=0 ! 16720: .word exp06-5b # left paren, s=1 ! 16721: .word exp04-5b # left paren, s=2 ! 16722: .word exp08-5b # left brkt, s=0 ! 16723: .word exp08-5b # left brkt, s=1 ! 16724: .word exp09-5b # left brkt, s=2 ! 16725: .word exp02-5b # comma, s=0 ! 16726: .word exp05-5b # comma, s=1 ! 16727: .word exp11-5b # comma, s=2 ! 16728: .word exp10-5b # function, s=0 ! 16729: .word exp10-5b # function, s=1 ! 16730: .word exp04-5b # function, s=2 ! 16731: .word exp03-5b # variable, s=0 ! 16732: .word exp03-5b # variable, state one ! 16733: .word exp04-5b # variable, s=2 ! 16734: .word exp03-5b # constant, s=0 ! 16735: .word exp03-5b # constant, s=1 ! 16736: .word exp04-5b # constant, s=2 ! 16737: .word exp05-5b # binop, s=0 ! 16738: .word exp05-5b # binop, s=1 ! 16739: .word exp26-5b # binop, s=2 ! 16740: .word exp02-5b # right paren, s=0 ! 16741: .word exp05-5b # right paren, s=1 ! 16742: .word exp12-5b # right paren, s=2 ! 16743: .word exp02-5b # right brkt, s=0 ! 16744: .word exp05-5b # right brkt, s=1 ! 16745: .word exp18-5b # right brkt, s=2 ! 16746: .word exp02-5b # colon, s=0 ! 16747: .word exp05-5b # colon, s=1 ! 16748: .word exp19-5b # colon, s=2 ! 16749: .word exp02-5b # semicolon, s=0 ! 16750: .word exp05-5b # semicolon, s=1 ! 16751: .word exp19-5b # semicolon, s=2 ! 16752: #esw # end switch on element type/state ! 16753: #page ! 16754: # ! 16755: # EXPAN (CONTINUED) ! 16756: # ! 16757: # HERE FOR RBR,RPR,COL,SMC,CMA IN STATE 0 ! 16758: # ! 16759: # SET TO RESCAN THE TERMINATOR ENCOUNTERED AND CREATE ! 16760: # A NULL CONSTANT (CASE OF OMITTED NULL) ! 16761: # ! 16762: exp02: movl sp,scnrs # set to rescan element ! 16763: movl $nulls,r9 # point to null, merge ! 16764: # ! 16765: # HERE FOR VAR OR CON IN STATES 0,1 ! 16766: # ! 16767: # STACK THE VARIABLE/CONSTANT AND SET STATE=2 ! 16768: # ! 16769: exp03: movl r9,-(sp) # stack pointer to operand ! 16770: movl $num02,r6 # set state 2 ! 16771: jmp exp01 # jump for next element ! 16772: # ! 16773: # HERE FOR VAR,CON,LPR,FNC,UOP IN STATE 2 ! 16774: # ! 16775: # WE RESCAN THE ELEMENT AND CREATE A CONCATENATION OPERATOR ! 16776: # THIS IS THE CASE OF THE BLANK CONCATENATION OPERATOR. ! 16777: # ! 16778: exp04: movl sp,scnrs # set to rescan element ! 16779: movl $opdvc,r9 # point to concat operator dv ! 16780: tstl r7 # ok if at top level ! 16781: beqlu exp4a ! 16782: movl $opdvp,r9 # else point to unmistakable concat. ! 16783: # ! 16784: # MERGE HERE WHEN XR SET UP WITH PROPER CONCATENATION DVBLK ! 16785: # ! 16786: exp4a: tstl scnbl # merge bop if blanks, else error ! 16787: beqlu 0f ! 16788: jmp exp26 ! 16789: 0: ! 16790: decl scnse # adjust start of element location ! 16791: jmp er_220 # syntax error. missing operator ! 16792: # ! 16793: # HERE FOR CMA,RPR,RBR,COL,SMC,BOP(S=1) BOP(S=0) ! 16794: # ! 16795: # THIS IS AN ERRONOUS CONTRUCTION ! 16796: # ! 16797: exp05: decl scnse # adjust start of element location ! 16798: jmp er_221 # syntax error. missing operand ! 16799: # ! 16800: # HERE FOR LPR (S=0,1) ! 16801: # ! 16802: exp06: movl $num04,r10 # set new level indicator ! 16803: clrl r9 # set zero value for cmopn ! 16804: #page ! 16805: # ! 16806: # EXPAN (CONTINUED) ! 16807: # ! 16808: # MERGE HERE TO STORE OLD LEVEL ON STACK AND START NEW ONE ! 16809: # ! 16810: exp07: movl r9,-(sp) # stack cmopn value ! 16811: movl r8,-(sp) # stack old counter ! 16812: movl r7,-(sp) # stack old level indicator ! 16813: jsb sbchk # check for stack overflow ! 16814: clrl r6 # set new state to zero ! 16815: movl r10,r7 # set new level indicator ! 16816: movl $num01,r8 # initialize new counter ! 16817: jmp exp01 # jump to scan next element ! 16818: # ! 16819: # HERE FOR LBR (S=0,1) ! 16820: # ! 16821: # THIS IS AN ILLEGAL USE OF LEFT BRACKET ! 16822: # ! 16823: exp08: jmp er_222 # syntax error. invalid use of left bracket ! 16824: # ! 16825: # HERE FOR LBR (S=2) ! 16826: # ! 16827: # SET NEW LEVEL AND START TO SCAN SUBSCRIPTS ! 16828: # ! 16829: exp09: movl (sp)+,r9 # load array ptr for cmopn ! 16830: movl $num03,r10 # set new level indicator ! 16831: jmp exp07 # jump to stack old and start new ! 16832: # ! 16833: # HERE FOR FNC (S=0,1) ! 16834: # ! 16835: # STACK OLD LEVEL AND START TO SCAN ARGUMENTS ! 16836: # ! 16837: exp10: movl $num05,r10 # set new lev indic (xr=vrblk=cmopn) ! 16838: jmp exp07 # jump to stack old and start new ! 16839: # ! 16840: # HERE FOR CMA (S=2) ! 16841: # ! 16842: # INCREMENT ARGUMENT COUNT AND CONTINUE ! 16843: # ! 16844: exp11: incl r8 # increment counter ! 16845: jsb expdm # dump operators at this level ! 16846: clrl -(sp) # set new level for parameter ! 16847: clrl r6 # set new state ! 16848: cmpl r7,$num02 # loop back unless outer level ! 16849: blequ 0f ! 16850: jmp exp01 ! 16851: 0: ! 16852: jmp er_223 # syntax error. invalid use of comma ! 16853: #page ! 16854: # ! 16855: # EXPAN (CONTINUED) ! 16856: # ! 16857: # HERE FOR RPR (S=2) ! 16858: # ! 16859: # AT OUTER LEVEL IN A NORMAL GOTO THIS IS A TERMINATOR ! 16860: # OTHERWISE IT MUST TERMINATE A FUNCTION OR GROUPING ! 16861: # ! 16862: exp12: cmpl r7,$num01 # end of normal goto ! 16863: bnequ 0f ! 16864: jmp exp20 ! 16865: 0: ! 16866: cmpl r7,$num05 # end of function arguments ! 16867: beqlu exp13 ! 16868: cmpl r7,$num04 # end of grouping / selection ! 16869: beqlu exp14 ! 16870: jmp er_224 # syntax error. unbalanced right parenthesis ! 16871: # ! 16872: # HERE AT END OF FUNCTION ARGUMENTS ! 16873: # ! 16874: exp13: movl $c$fnc,r10 # set cmtyp value for function ! 16875: jmp exp15 # jump to build cmblk ! 16876: # ! 16877: # HERE FOR END OF GROUPING ! 16878: # ! 16879: exp14: cmpl r8,$num01 # jump if end of grouping ! 16880: beqlu exp17 ! 16881: movl $c$sel,r10 # else set cmtyp for selection ! 16882: # ! 16883: # MERGE HERE TO BUILD CMBLK FOR LEVEL JUST SCANNED AND ! 16884: # TO POP UP TO THE PREVIOUS SCAN LEVEL BEFORE CONTINUING. ! 16885: # ! 16886: exp15: jsb expdm # dump operators at this level ! 16887: movl r8,r6 # copy count ! 16888: addl2 $cmvls,r6 # add for standard fields at start ! 16889: moval 0[r6],r6 # convert length to bytes ! 16890: jsb alloc # allocate space for cmblk ! 16891: movl $b$cmt,(r9) # store type code for cmblk ! 16892: movl r10,4*cmtyp(r9) # store cmblk node type indicator ! 16893: movl r6,4*cmlen(r9) # store length ! 16894: addl2 r6,r9 # point past end of block ! 16895: # set loop counter ! 16896: # ! 16897: # LOOP TO MOVE REMAINING WORDS TO CMBLK ! 16898: # ! 16899: exp16: movl (sp)+,-(r9) # move one operand ptr from stack ! 16900: movl (sp)+,r7 # pop to old level indicator ! 16901: sobgtr r8,exp16 # loop till all moved ! 16902: #page ! 16903: # ! 16904: # EXPAN (CONTINUED) ! 16905: # ! 16906: # COMPLETE CMBLK AND STACK POINTER TO IT ON STACK ! 16907: # ! 16908: subl2 $4*cmvls,r9 # point back to start of block ! 16909: movl (sp)+,r8 # restore old counter ! 16910: movl (sp),4*cmopn(r9)# store operand ptr in cmblk ! 16911: movl r9,(sp) # stack cmblk pointer ! 16912: movl $num02,r6 # set new state ! 16913: jmp exp01 # back for next element ! 16914: # ! 16915: # HERE AT END OF A PARENTHESIZED EXPRESSION ! 16916: # ! 16917: exp17: jsb expdm # dump operators at this level ! 16918: movl (sp)+,r9 # restore xr ! 16919: movl (sp)+,r7 # restore outer level ! 16920: movl (sp)+,r8 # restore outer count ! 16921: movl r9,(sp) # store opnd over unused cmopn val ! 16922: movl $num02,r6 # set new state ! 16923: jmp exp01 # back for next ele8ent ! 16924: # ! 16925: # HERE FOR RBR (S=2) ! 16926: # ! 16927: # AT OUTER LEVEL IN A DIRECT GOTO, THIS IS A TERMINATOR. ! 16928: # OTHERWISE IT MUST TERMINATE A SUBSCRIPT LIST. ! 16929: # ! 16930: exp18: movl $c$arr,r10 # set cmtyp for array reference ! 16931: cmpl r7,$num03 # jump to build cmblk if end arrayref ! 16932: beqlu exp15 ! 16933: cmpl r7,$num02 # jump if end of direct goto ! 16934: bnequ 0f ! 16935: jmp exp20 ! 16936: 0: ! 16937: jmp er_225 # syntax error. unbalanced right bracket ! 16938: #page ! 16939: # ! 16940: # EXPAN (CONTINUED) ! 16941: # ! 16942: # HERE FOR COL,SMC (S=2) ! 16943: # ! 16944: # ERROR UNLESS TERMINATING STATEMENT BODY AT OUTER LEVEL ! 16945: # ! 16946: exp19: movl sp,scnrs # rescan terminator ! 16947: movl r7,r10 # copy level indicator ! 16948: casel r10,$0,$6 # switch on level indicator ! 16949: 5: ! 16950: .word exp20-5b # normal outer level ! 16951: .word exp22-5b # fail if normal goto ! 16952: .word exp23-5b # fail if direct goto ! 16953: .word exp24-5b # fail array brackets ! 16954: .word exp21-5b # fail if in grouping ! 16955: .word exp21-5b # fail function args ! 16956: #esw # end switch on level ! 16957: # ! 16958: # HERE AT NORMAL END OF EXPRESSION ! 16959: # ! 16960: exp20: jsb expdm # dump remaining operators ! 16961: movl (sp)+,r9 # load tree pointer ! 16962: addl2 $4,sp # pop off bottom of stack marker ! 16963: rsb # return to expan caller ! 16964: # ! 16965: # MISSING RIGHT PAREN ! 16966: # ! 16967: exp21: jmp er_226 # syntax error. missing right paren ! 16968: # ! 16969: # MISSING RIGHT PAREN IN GOTO FIELD ! 16970: # ! 16971: exp22: jmp er_227 # syntax error. right paren missing from goto ! 16972: # ! 16973: # MISSING BRACKET IN GOTO ! 16974: # ! 16975: exp23: jmp er_228 # syntax error. right bracket missing from goto ! 16976: # ! 16977: # MISSING ARRAY BRACKET ! 16978: # ! 16979: exp24: jmp er_229 # syntax error. missing right array bracket ! 16980: #page ! 16981: # ! 16982: # EXPAN (CONTINUED) ! 16983: # ! 16984: # LOOP HERE WHEN AN OPERATOR CAUSES AN OPERATOR DUMP ! 16985: # ! 16986: exp25: movl r9,expsv ! 16987: jsb expop # pop one operator ! 16988: movl expsv,r9 # restore op dv pointer and merge ! 16989: # ! 16990: # HERE FOR BOP (S=2) ! 16991: # ! 16992: # REMOVE OPERATORS (CONDENSE) FROM STACK UNTIL NO MORE ! 16993: # LEFT AT THIS LEVEL OR TOP ONE HAS LOWER PRECEDENCE. ! 16994: # LOOP HERE TILL THIS CONDITION IS MET. ! 16995: # ! 16996: exp26: movl 4*1(sp),r10 # load operator dvptr from stack ! 16997: cmpl r10,$num05 # jump if bottom of stack level ! 16998: blequ exp27 ! 16999: cmpl 4*dvrpr(r9),4*dvlpr(r10) # else pop if new prec is lo ! 17000: blssu exp25 ! 17001: # ! 17002: # HERE FOR UOP (S=0,1) ! 17003: # ! 17004: # BINARY OPERATOR MERGES AFTER PRECEDENCE CHECK ! 17005: # ! 17006: # THE OPERATOR DV IS STORED ON THE STACK AND THE SCAN ! 17007: # CONTINUES AFTER SETTING THE SCAN STATE TO ONE. ! 17008: # ! 17009: exp27: movl r9,-(sp) # stack operator dvptr on stack ! 17010: jsb sbchk # check for stack overflow ! 17011: movl $num01,r6 # set new state ! 17012: cmpl r9,$opdvs # back for next element unless = ! 17013: beqlu 0f ! 17014: jmp exp01 ! 17015: 0: ! 17016: # ! 17017: # HERE FOR SPECIAL CASE OF BINARY =. THE SYNTAX ALLOWS A ! 17018: # NULL RIGHT ARGUMENT FOR THIS OPERATOR TO BE LEFT ! 17019: # OUT. ACCORDINGLY WE RESET TO STATE ZERO TO GET PROPER ! 17020: # ACTION ON A TERMINATOR (SUPPLY A NULL CONSTANT). ! 17021: # ! 17022: clrl r6 # set state zero ! 17023: jmp exp01 # jump for next element ! 17024: #enp # end procedure expan ! 17025: #page ! 17026: # ! 17027: # EXPAP -- TEST FOR PATTERN MATCH TREE ! 17028: # ! 17029: # EXPAP IS PASSED AN EXPRESSION TREE TO DETERMINE IF IT ! 17030: # IS A PATTERN MATCH. THE FOLLOWING ARE RECOGIZED AS ! 17031: # MATCHES IN THE CONTEXT OF THIS CALL. ! 17032: # ! 17033: # 1) AN EXPLICIT USE OF BINARY QUESTION MARK ! 17034: # 2) A CONCATENATION ! 17035: # 3) AN ALTERNATION WHOSE LEFT OPERAND IS A CONCATENATION ! 17036: # ! 17037: # (XR) PTR TO EXPAN TREE ! 17038: # JSR EXPAP CALL TO TEST FOR PATTERN MATCH ! 17039: # PPM LOC TRANSFER LOC IF NOT A PATTERN MATCH ! 17040: # (WA) DESTROYED ! 17041: # (XR) UNCHANGED (IF NOT MATCH) ! 17042: # (XR) PTR TO BINARY OPERATOR BLK IF MATCH ! 17043: # ! 17044: expap: #prc # entry point ! 17045: movl r10,-(sp) # save xl ! 17046: cmpl (r9),$b$cmt # no match if not complex ! 17047: bnequ expp2 ! 17048: movl 4*cmtyp(r9),r6 # else load type code ! 17049: cmpl r6,$c$cnc # concatenation is a match ! 17050: beqlu expp1 ! 17051: cmpl r6,$c$pmt # binary question mark is a match ! 17052: beqlu expp1 ! 17053: cmpl r6,$c$alt # else not match unless alternation ! 17054: bnequ expp2 ! 17055: # ! 17056: # HERE FOR ALTERNATION. CHANGE (A B) / C TO A QM (B / C) ! 17057: # ! 17058: movl 4*cmlop(r9),r10 # load left operand pointer ! 17059: cmpl (r10),$b$cmt # not match if left opnd not complex ! 17060: bnequ expp2 ! 17061: cmpl 4*cmtyp(r10),$c$cnc # not match if left op not conc ! 17062: bnequ expp2 ! 17063: movl 4*cmrop(r10),4*cmlop(r9) # xr points to (b / c) ! 17064: movl r9,4*cmrop(r10) # set xl opnds to a, (b / c) ! 17065: movl r10,r9 # point to this altered node ! 17066: # ! 17067: # EXIT HERE FOR PATTERN MATCH ! 17068: # ! 17069: expp1: movl (sp)+,r10 # restore entry xl ! 17070: addl2 $4*1,(sp) # give pattern match return ! 17071: rsb ! 17072: # ! 17073: # EXIT HERE IF NOT PATTERN MATCH ! 17074: # ! 17075: expp2: movl (sp)+,r10 # restore entry xl ! 17076: movl (sp)+,r11 # give non-match return ! 17077: jmp *(r11)+ ! 17078: #enp # end procedure expap ! 17079: #page ! 17080: # ! 17081: # EXPDM -- DUMP OPERATORS AT CURRENT LEVEL (FOR EXPAN) ! 17082: # ! 17083: # EXPDM USES EXPOP TO CONDENSE ALL OPERATORS AT THIS SYNTAX ! 17084: # LEVEL. THE STACK BOTTOM IS RECOGNIZED FROM THE LEVEL ! 17085: # VALUE WHICH IS SAVED ON THE TOP OF THE STACK. ! 17086: # ! 17087: # JSR EXPDM CALL TO DUMP OPERATORS ! 17088: # (XS) POPPED AS REQUIRED ! 17089: # (XR,WA) DESTROYED ! 17090: # ! 17091: .data 1 ! 17092: expdm_s: .long 0 ! 17093: .text 0 ! 17094: expdm: movl (sp)+,expdm_s # entry point ! 17095: movl r10,r$exs # save xl value ! 17096: # ! 17097: # LOOP TO DUMP OPERATORS ! 17098: # ! 17099: exdm1: cmpl 4*1(sp),$num05 # jump if stack bottom (saved level ! 17100: blequ exdm2 ! 17101: jsb expop # else pop one operator ! 17102: jmp exdm1 # and loop back ! 17103: # ! 17104: # HERE AFTER POPPING ALL OPERATORS ! 17105: # ! 17106: exdm2: movl r$exs,r10 # restore xl ! 17107: clrl r$exs # release save location ! 17108: jmp *expdm_s # return to expdm caller ! 17109: #enp # end procedure expdm ! 17110: #page ! 17111: # ! 17112: # EXPOP-- POP OPERATOR (FOR EXPAN) ! 17113: # ! 17114: # EXPOP IS USED BY THE EXPAN ROUTINE TO CONDENSE ONE ! 17115: # OPERATOR FROM THE TOP OF THE SYNTAX STACK. AN APPROPRIATE ! 17116: # CMBLK IS BUILT FOR THE OPERATOR (UNARY OR BINARY) AND A ! 17117: # POINTER TO THIS CMBLK IS STACKED. ! 17118: # ! 17119: # EXPOP IS ALSO USED BY SCNGF (GOTO FIELD SCAN) PROCEDURE ! 17120: # ! 17121: # JSR EXPOP CALL TO POP OPERATOR ! 17122: # (XS) POPPED APPROPRIATELY ! 17123: # (XR,XL,WA) DESTROYED ! 17124: # ! 17125: .data 1 ! 17126: expop_s: .long 0 ! 17127: .text 0 ! 17128: expop: movl (sp)+,expop_s # entry point ! 17129: movl 4*1(sp),r9 # load operator dv pointer ! 17130: cmpl 4*dvlpr(r9),$lluno # jump if unary ! 17131: beqlu expo2 ! 17132: # ! 17133: # HERE FOR BINARY OPERATOR ! 17134: # ! 17135: movl $4*cmbs$,r6 # set size of binary operator cmblk ! 17136: jsb alloc # allocate space for cmblk ! 17137: movl (sp)+,4*cmrop(r9)# pop and store right operand ptr ! 17138: movl (sp)+,r10 # pop and load operator dv ptr ! 17139: movl (sp),4*cmlop(r9)# store left operand pointer ! 17140: # ! 17141: # COMMON EXIT POINT ! 17142: # ! 17143: expo1: movl $b$cmt,(r9) # store type code for cmblk ! 17144: movl 4*dvtyp(r10),4*cmtyp(r9) # store cmblk node type code ! 17145: movl r10,4*cmopn(r9) # store dvptr (=ptr to dac o$xxx) ! 17146: movl r6,4*cmlen(r9) # store cmblk length ! 17147: movl r9,(sp) # store resulting node ptr on stack ! 17148: jmp *expop_s # return to expop caller ! 17149: # ! 17150: # HERE FOR UNARY OPERATOR ! 17151: # ! 17152: expo2: movl $4*cmus$,r6 # set size of unary operator cmblk ! 17153: jsb alloc # allocate space for cmblk ! 17154: movl (sp)+,4*cmrop(r9)# pop and store operand pointer ! 17155: movl (sp),r10 # load operator dv pointer ! 17156: jmp expo1 # merge back to exit ! 17157: #enp # end procedure expop ! 17158: #page ! 17159: # ! 17160: # FLSTG -- FOLD STRING TO UPPER CASE ! 17161: # ! 17162: # FLSTG FOLDS A CHARACTER STRING CONTAINING LOWER CASE ! 17163: # CHARACCTERS TO ONE CONTAINING UPPER CASE CHARACTERS. ! 17164: # FOLDING IS ONLY DONE IF &CASE (KVCAS) IS NOT ZERO. ! 17165: # ! 17166: # (XR) STRING ARGUMENT ! 17167: # (WA) LENGTH OF STRING ! 17168: # JSR FLSTG CALL TO FOLD STRING ! 17169: # (XR) RESULT STRING (POSSIBLY ORIGINAL) ! 17170: # (WC) DESTROYED ! 17171: # ! 17172: flstg: #prc # entry point ! 17173: tstl kvcas # skip if &case is 0 ! 17174: beqlu fst99 ! 17175: movl r10,-(sp) # save xl across call ! 17176: movl r9,-(sp) # save original scblk ptr ! 17177: jsb alocs # allocate new string block ! 17178: movl (sp),r10 # point to original scblk ! 17179: movl r9,-(sp) # save pointer to new scblk ! 17180: movab cfp$f(r10),r10 # point to original chars ! 17181: movab cfp$f(r9),r9 # point to new chars ! 17182: clrl -(sp) # init did fold flag ! 17183: # load loop counter ! 17184: fst01: movzbl (r10)+,r6 # load character ! 17185: cmpl $ch$$a,r6 # skip if less than lc a ! 17186: bgtru fst02 ! 17187: cmpl r6,$ch$$$ # skip if greater than lc z ! 17188: bgtru fst02 ! 17189: bicl2 $ch$bl,r6 # fold character to upper case ! 17190: movl sp,(sp) # set did fold character flag ! 17191: fst02: movb r6,(r9)+ # store (possibly folded) character ! 17192: sobgtr r8,fst01 # loop thru entire string ! 17193: #csc r9 # complete store characters ! 17194: tstl (sp)+ # skip if folding done ! 17195: bnequ fst10 ! 17196: movl (sp)+,dnamp # do not need new scblk ! 17197: movl (sp)+,r9 # return original scblk ! 17198: jmp fst20 # merge below ! 17199: fst10: movl (sp)+,r9 # return new scblk ! 17200: addl2 $4,sp # throw away original scblk pointer ! 17201: fst20: movl 4*sclen(r9),r6 # reload string length ! 17202: movl (sp)+,r10 # restore xl ! 17203: fst99: rsb # return ! 17204: #enp ! 17205: #page ! 17206: # ! 17207: # GBCOL -- PERFORM GARBAGE COLLECTION ! 17208: # ! 17209: # GBCOL PERFORMS A GARBAGE COLLECTION ON THE DYNAMIC REGION ! 17210: # ALL BLOCKS WHICH ARE NO LONGER IN USE ARE ELIMINATED ! 17211: # BY MOVING BLOCKS WHICH ARE IN USE DOWN AND RESETTING ! 17212: # DNAMP, THE POINTER TO THE NEXT AVAILABLE LOCATION. ! 17213: # ! 17214: # (WB) MOVE OFFSET (SEE BELOW) ! 17215: # JSR GBCOL CALL TO COLLECT GARBAGE ! 17216: # (XR) DESTROYED ! 17217: # ! 17218: # THE FOLLOWING CONDITIONS MUST BE MET AT THE TIME WHEN ! 17219: # GBCOL IS CALLED. ! 17220: # ! 17221: # 1) ALL POINTERS TO BLOCKS IN THE DYNAMIC AREA MUST BE ! 17222: # ACCESSIBLE TO THE GARBAGE COLLECTOR. THIS MEANS ! 17223: # THAT THEY MUST OCCUR IN ONE OF THE FOLLOWING. ! 17224: # ! 17225: # A) MAIN STACK, WITH CURRENT TOP ! 17226: # ELEMENT BEING INDICATED BY XS ! 17227: # ! 17228: # B) IN RELOCATABLE FIELDS OF VRBLKS. ! 17229: # ! 17230: # C) IN REGISTER XL AT THE TIME OF CALL ! 17231: # ! 17232: # E) IN THE SPECIAL REGION OF WORKING ! 17233: # STORAGE WHERE NAMES BEGIN WITH R$. ! 17234: # ! 17235: # 2) ALL POINTERS MUST POINT TO THE START OF BLOCKS WITH ! 17236: # THE SOLE EXCEPTION OF THE CONTENTS OF THE CODE ! 17237: # POINTER REGISTER WHICH POINTS INTO THE R$COD BLOCK. ! 17238: # ! 17239: # 3) NO LOCATION WHICH APPEARS TO CONTAIN A POINTER ! 17240: # INTO THE DYNAMIC REGION MAY OCCUR UNLESS IT IS IN ! 17241: # FACT A POINTER TO THE START OF THE BLOCK. HOWEVER ! 17242: # POINTERS OUTSIDE THIS AREA MAY OCCUR AND WILL ! 17243: # NOT BE CHANGED BY THE GARBAGE COLLECTOR. ! 17244: # IT IS ESPECIALLY IMPORTANT TO MAKE SURE THAT XL ! 17245: # DOES NOT CONTAIN A GARBAGE VALUE FROM SOME PROCESS ! 17246: # CARRIED OUT BEFORE THE CALL TO THE COLLECTOR. ! 17247: # ! 17248: # GBCOL HAS THE CAPABILITY OF MOVING THE FINAL COMPACTED ! 17249: # RESULT UP IN MEMORY (WITH ADDRESSES ADJUSTED ACCORDINGLY) ! 17250: # THIS IS USED TO ADD SPACE TO THE STATIC REGION. THE ! 17251: # ENTRY VALUE OF WB IS THE NUMBER OF BYTES TO MOVE UP. ! 17252: # THE CALLER MUST GUARANTEE THAT THERE IS ENOUGH ROOM. ! 17253: # FURTHERMORE THE VALUE IN WB IF IT IS NON-ZERO, MUST BE AT ! 17254: # LEAST 256 SO THAT THE MWB INSTRUCTION CONDITIONS ARE MET. ! 17255: #page ! 17256: # ! 17257: # GBCOL (CONTINUED) ! 17258: # ! 17259: # THE ALGORITHM, WHICH IS A MODIFICATION OF THE LISP-2 ! 17260: # GARBAGE COLLECTOR DEVISED BY R.DEWAR AND K.BELCHER ! 17261: # TAKES THREE PASSES AS FOLLOWS. ! 17262: # ! 17263: # 1) ALL POINTERS IN MEMORY ARE SCANNED AND BLOCKS IN USE ! 17264: # DETERMINED FROM THIS SCAN. NOTE THAT THIS PROCEDURE ! 17265: # IS RECURSIVE AND USES THE MAIN STACK FOR LINKAGE. ! 17266: # THE MARKING PROCESS IS THUS SIMILAR TO THAT USED IN ! 17267: # A STANDARD LISP COLLECTOR. HOWEVER THE METHOD OF ! 17268: # ACTUALLY MARKING THE BLOCKS IS DIFFERENT. ! 17269: # ! 17270: # THE FIRST FIELD OF A BLOCK NORMALLY CONTAINS A ! 17271: # CODE ENTRY POINT POINTER. SUCH AN ENTRY POINTER ! 17272: # CAN BE DISTINGUISHED FROM THE ADDRESS OF ANY POINTER ! 17273: # TO BE PROCESSED BY THE COLLECTOR. DURING GARBAGE ! 17274: # COLLECTION, THIS WORD IS USED TO BUILD A BACK CHAIN ! 17275: # OF POINTERS THROUGH FIELDS WHICH POINT TO THE BLOCK. ! 17276: # THE END OF THE CHAIN IS MARKED BY THE OCCURENCE ! 17277: # OF THE WORD WHICH USED TO BE IN THE FIRST WORD OF ! 17278: # THE BLOCK. THIS BACKCHAIN SERVES BOTH AS A MARK ! 17279: # INDICATING THAT THE BLOCK IS IN USE AND AS A LIST OF ! 17280: # REFERENCES FOR THE RELOCATION PHASE. ! 17281: # ! 17282: # 2) STORAGE IS SCANNED SEQUENTIALLY TO DISCOVER WHICH ! 17283: # BLOCKS ARE CURRENTLY IN USE AS INDICATED BY THE ! 17284: # PRESENCE OF A BACKCHAIN. TWO POINTERS ARE MAINTAINED ! 17285: # ONE SCANS THROUGH LOOKING AT EACH BLOCK. THE OTHER ! 17286: # IS INCREMENTED ONLY FOR BLOCKS FOUND TO BE IN USE. ! 17287: # IN THIS WAY, THE EVENTUAL LOCATION OF EACH BLOCK CAN ! 17288: # BE DETERMINED WITHOUT ACTUALLY MOVING ANY BLOCKS. ! 17289: # AS EACH BLOCK WHICH IS IN USE IS PROCESSED, THE BACK ! 17290: # CHAIN IS USED TO RESET ALL POINTERS WHICH POINT TO ! 17291: # THIS BLOCK TO CONTAIN ITS NEW ADDRESS, I.E. THE ! 17292: # ADDRESS IT WILL OCCUPY AFTER THE BLOCKS ARE MOVED. ! 17293: # THE FIRST WORD OF THE BLOCK, TAKEN FROM THE END OF ! 17294: # THE CHAIN IS RESTORED AT THIS POINT. ! 17295: # ! 17296: # DURING PASS 2, THE COLLECTOR BUILDS BLOCKS WHICH ! 17297: # DESCRIBE THE REGIONS OF STORAGE WHICH ARE TO BE ! 17298: # MOVED IN THE THIRD PASS. THERE IS ONE DESCRIPTOR FOR ! 17299: # EACH CONTIGUOUS SET OF GOOD BLOCKS. THE DESCRIPTOR ! 17300: # IS BUILT JUST BEHIND THE BLOCK TO BE MOVED AND ! 17301: # CONTAINS A POINTER TO THE NEXT BLOCK AND THE NUMBER ! 17302: # OF WORDS TO BE MOVED. ! 17303: # ! 17304: # 3) IN THE THIRD AND FINAL PASS, THE MOVE DESCRIPTOR ! 17305: # BLOCKS BUILT IN PASS TWO ARE USED TO ACTUALLY MOVE ! 17306: # THE BLOCKS DOWN TO THE BOTTOM OF THE DYNAMIC REGION. ! 17307: # THE COLLECTION IS THEN COMPLETE AND THE NEXT ! 17308: # AVAILABLE LOCATION POINTER IS RESET. ! 17309: #page ! 17310: # ! 17311: # GBCOL (CONTINUED) ! 17312: # ! 17313: gbcol: #prc # entry point ! 17314: tstl dmvch # fail if in mid-dump ! 17315: beqlu 0f ! 17316: jmp gbc14 ! 17317: 0: ! 17318: movl sp,gbcfl # note gbcol entered ! 17319: movl r6,gbsva # save entry wa ! 17320: movl r7,gbsvb # save entry wb ! 17321: movl r8,gbsvc # save entry wc ! 17322: movl r10,-(sp) # save entry xl ! 17323: movl r3,r6 # get code pointer value ! 17324: subl2 r$cod,r6 # make relative ! 17325: movl r6,r3 # and restore ! 17326: # ! 17327: # PROCESS STACK ENTRIES ! 17328: # ! 17329: movl sp,r9 # point to stack front ! 17330: movl stbas,r10 # point past end of stack ! 17331: cmpl r10,r9 # ok if d-stack ! 17332: bgequ gbc00 ! 17333: movl r10,r9 # reverse if ... ! 17334: movl sp,r10 # ... u-stack ! 17335: # ! 17336: # PROCESS THE STACK ! 17337: # ! 17338: gbc00: jsb gbcpf # process pointers on stack ! 17339: # ! 17340: # PROCESS SPECIAL WORK LOCATIONS ! 17341: # ! 17342: movl $r$aaa,r9 # point to start of relocatable locs ! 17343: movl $r$yyy,r10 # point past end of relocatable locs ! 17344: jsb gbcpf # process work fields ! 17345: # ! 17346: # PREPARE TO PROCESS VARIABLE BLOCKS ! 17347: # ! 17348: movl hshtb,r6 # point to first hash slot pointer ! 17349: # ! 17350: # LOOP THROUGH HASH SLOTS ! 17351: # ! 17352: gbc01: movl r6,r10 # point to next slot ! 17353: addl2 $4,r6 # bump bucket pointer ! 17354: movl r6,gbcnm # save bucket pointer ! 17355: #page ! 17356: # ! 17357: # GBCOL (CONTINUED) ! 17358: # ! 17359: # LOOP THROUGH VARIABLES ON ONE HASH CHAIN ! 17360: # ! 17361: gbc02: movl (r10),r9 # load ptr to next vrblk ! 17362: beqlu gbc03 # jump if end of chain ! 17363: movl r9,r10 # else copy vrblk pointer ! 17364: addl2 $4*vrval,r9 # point to first reloc fld ! 17365: addl2 $4*vrnxt,r10 # point past last (and to link ptr) ! 17366: jsb gbcpf # process reloc fields in vrblk ! 17367: jmp gbc02 # loop back for next block ! 17368: # ! 17369: # HERE AT END OF ONE HASH CHAIN ! 17370: # ! 17371: gbc03: movl gbcnm,r6 # restore bucket pointer ! 17372: cmpl r6,hshte # loop back if more buckets to go ! 17373: bnequ gbc01 ! 17374: #page ! 17375: # ! 17376: # GBCOL (CONTINUED) ! 17377: # ! 17378: # NOW WE ARE READY TO START PASS TWO. REGISTERS ARE USED ! 17379: # AS FOLLOWS IN PASS TWO. ! 17380: # ! 17381: # (XR) SCANS THROUGH ALL BLOCKS ! 17382: # (WC) POINTER TO EVENTUAL LOCATION ! 17383: # ! 17384: # THE MOVE DESCRIPTION BLOCKS BUILT IN THIS PASS HAVE ! 17385: # THE FOLLOWING FORMAT. ! 17386: # ! 17387: # WORD 1 POINTER TO NEXT MOVE BLOCK, ! 17388: # ZERO IF END OF CHAIN OF BLOCKS ! 17389: # ! 17390: # WORD 2 LENGTH OF BLOCKS TO BE MOVED IN ! 17391: # BYTES. SET TO THE ADDRESS OF THE ! 17392: # FIRST BYTE WHILE ACTUALLY SCANNING ! 17393: # THE BLOCKS. ! 17394: # ! 17395: # THE FIRST ENTRY ON THIS CHAIN IS A SPECIAL ENTRY ! 17396: # CONSISTING OF THE TWO WORDS GBCNM AND GBCNS. AFTER ! 17397: # BUILDING THE CHAIN OF MOVE DESCRIPTORS, GBCNM POINTS TO ! 17398: # THE FIRST REAL MOVE BLOCK, AND GBCNS IS THE LENGTH OF ! 17399: # BLOCKS IN USE AT THE START OF STORAGE WHICH NEED NOT ! 17400: # BE MOVED SINCE THEY ARE IN THE CORRECT POSITION. ! 17401: # ! 17402: gbc04: movl dnamb,r9 # point to first block ! 17403: movl r9,r8 # set as first eventual location ! 17404: addl2 gbsvb,r8 # add offset for eventual move up ! 17405: clrl gbcnm # clear initial forward pointer ! 17406: movl $gbcnm,gbclm # initialize ptr to last move block ! 17407: movl r9,gbcns # initialize first address ! 17408: # ! 17409: # LOOP THROUGH A SERIES OF BLOCKS IN USE ! 17410: # ! 17411: gbc05: cmpl r9,dnamp # jump if end of used region ! 17412: beqlu gbc07 ! 17413: movl (r9),r6 # else get first word ! 17414: cmpl r6,$p$yyy # skip if not entry ptr (in use) ! 17415: bgequ gbc06 ! 17416: cmpl r6,$b$aaa # jump if entry pointer (unused) ! 17417: bgequ gbc07 ! 17418: # ! 17419: # HERE FOR BLOCK IN USE, LOOP TO RELOCATE REFERENCES ! 17420: # ! 17421: gbc06: movl r6,r10 # copy pointer ! 17422: movl (r10),r6 # load forward pointer ! 17423: movl r8,(r10) # relocate reference ! 17424: cmpl r6,$p$yyy # loop back if not end of chain ! 17425: bgequ gbc06 ! 17426: cmpl r6,$b$aaa # loop back if not end of chain ! 17427: blequ gbc06 ! 17428: #page ! 17429: # ! 17430: # GBCOL (CONTINUED) ! 17431: # ! 17432: # AT END OF CHAIN, RESTORE FIRST WORD AND BUMP PAST ! 17433: # ! 17434: movl r6,(r9) # restore first word ! 17435: jsb blkln # get length of this block ! 17436: addl2 r6,r9 # bump actual pointer ! 17437: addl2 r6,r8 # bump eventual pointer ! 17438: jmp gbc05 # loop back for next block ! 17439: # ! 17440: # HERE AT END OF A SERIES OF BLOCKS IN USE ! 17441: # ! 17442: gbc07: movl r9,r6 # copy pointer past last block ! 17443: movl gbclm,r10 # point to previous move block ! 17444: subl2 4*1(r10),r6 # subtract starting address ! 17445: movl r6,4*1(r10) # store length of block to be moved ! 17446: # ! 17447: # LOOP THROUGH A SERIES OF BLOCKS NOT IN USE ! 17448: # ! 17449: gbc08: cmpl r9,dnamp # jump if end of used region ! 17450: beqlu gbc10 ! 17451: movl (r9),r6 # else load first word of next block ! 17452: cmpl r6,$p$yyy # jump if in use ! 17453: bgequ gbc09 ! 17454: cmpl r6,$b$aaa # jump if in use ! 17455: blequ gbc09 ! 17456: jsb blkln # else get length of next block ! 17457: addl2 r6,r9 # push pointer ! 17458: jmp gbc08 # and loop back ! 17459: # ! 17460: # HERE FOR A BLOCK IN USE AFTER PROCESSING A SERIES OF ! 17461: # BLOCKS WHICH WERE NOT IN USE, BUILD NEW MOVE BLOCK. ! 17462: # ! 17463: gbc09: subl2 $4*num02,r9 # point 2 words behind for move block ! 17464: movl gbclm,r10 # point to previous move block ! 17465: movl r9,(r10) # set forward ptr in previous block ! 17466: clrl (r9) # zero forward ptr of new block ! 17467: movl r9,gbclm # remember address of this block ! 17468: movl r9,r10 # copy ptr to move block ! 17469: addl2 $4*num02,r9 # point back to block in use ! 17470: movl r9,4*1(r10) # store starting address ! 17471: jmp gbc06 # jump to process block in use ! 17472: #page ! 17473: # ! 17474: # GBCOL (CONTINUED) ! 17475: # ! 17476: # HERE FOR PASS THREE -- ACTUALLY MOVE THE BLOCKS DOWN ! 17477: # ! 17478: # (XL) POINTER TO OLD LOCATION ! 17479: # (XR) POINTER TO NEW LOCATION ! 17480: # ! 17481: gbc10: movl dnamb,r9 # point to start of storage ! 17482: addl2 gbcns,r9 # bump past unmoved blocks at start ! 17483: # ! 17484: # LOOP THROUGH MOVE DESCRIPTORS ! 17485: # ! 17486: gbc11: movl gbcnm,r10 # point to next move block ! 17487: beqlu gbc12 # jump if end of chain ! 17488: movl (r10)+,gbcnm # move pointer down chain ! 17489: movl (r10)+,r6 # get length to move ! 17490: jsb sbmvw # perform move ! 17491: jmp gbc11 # loop back ! 17492: # ! 17493: # NOW TEST FOR MOVE UP ! 17494: # ! 17495: gbc12: movl r9,dnamp # set next available loc ptr ! 17496: movl gbsvb,r7 # reload move offset ! 17497: beqlu gbc13 # jump if no move required ! 17498: movl r9,r10 # else copy old top of core ! 17499: addl2 r7,r9 # point to new top of core ! 17500: movl r9,dnamp # save new top of core pointer ! 17501: movl r10,r6 # copy old top ! 17502: subl2 dnamb,r6 # minus old bottom = length ! 17503: addl2 r7,dnamb # bump bottom to get new value ! 17504: jsb sbmwb # perform move (backwards) ! 17505: # ! 17506: # MERGE HERE TO EXIT ! 17507: # ! 17508: gbc13: movl gbsva,r6 # restore wa ! 17509: movl r3,r8 # get code pointer ! 17510: addl2 r$cod,r8 # make absolute again ! 17511: movl r8,r3 # and replace absolute value ! 17512: movl gbsvc,r8 # restore wc ! 17513: movl (sp)+,r10 # restore entry xl ! 17514: incl gbcnt # increment count of collections ! 17515: clrl r9 # clear garbage value in xr ! 17516: clrl gbcfl # note exit from gbcol ! 17517: rsb # exit to gbcol caller ! 17518: # ! 17519: # GARBAGE COLLECTION NOT ALLOWED WHILST DUMPING ! 17520: # ! 17521: gbc14: incl errft # fatal error ! 17522: jmp er_250 # insufficient memory to complete dump ! 17523: #enp # end procedure gbcol ! 17524: #page ! 17525: # ! 17526: # GBCPF -- PROCESS FIELDS FOR GARBAGE COLLECTOR ! 17527: # ! 17528: # THIS PROCEDURE IS USED BY THE GARBAGE COLLECTOR TO ! 17529: # PROCESS FIELDS IN PASS ONE. SEE GBCOL FOR FULL DETAILS. ! 17530: # ! 17531: # (XR) PTR TO FIRST LOCATION TO PROCESS ! 17532: # (XL) PTR PAST LAST LOCATION TO PROCESS ! 17533: # JSR GBCPF CALL TO PROCESS FIELDS ! 17534: # (XR,WA,WB,WC,IA) DESTROYED ! 17535: # ! 17536: # NOTE THAT ALTHOUGH THIS PROCEDURE USES A RECURSIVE ! 17537: # APPROACH, IT CONTROLS ITS OWN STACK AND IS NOT RECURSIVE. ! 17538: # ! 17539: gbcpf: #prc # entry point ! 17540: clrl -(sp) # set zero to mark bottom of stack ! 17541: movl r10,-(sp) # save end pointer ! 17542: # ! 17543: # MERGE HERE TO GO DOWN A LEVEL AND START A NEW LOOP ! 17544: # ! 17545: # 1(XS) NEXT LVL FIELD PTR (0 AT OUTER LVL) ! 17546: # 0(XS) PTR PAST LAST FIELD TO PROCESS ! 17547: # (XR) PTR TO FIRST FIELD TO PROCESS ! 17548: # ! 17549: # LOOP TO PROCESS SUCCESSIVE FIELDS ! 17550: # ! 17551: gpf01: movl (r9),r10 # load field contents ! 17552: movl r9,r8 # save field pointer ! 17553: cmpl r10,dnamb # jump if not ptr into dynamic area ! 17554: blssu gpf02 ! 17555: cmpl r10,dnamp # jump if not ptr into dynamic area ! 17556: bgequ gpf02 ! 17557: # ! 17558: # HERE WE HAVE A PTR TO A BLOCK IN THE DYNAMIC AREA. ! 17559: # LINK THIS FIELD ONTO THE REFERENCE BACKCHAIN. ! 17560: # ! 17561: movl (r10),r6 # load ptr to chain (or entry ptr) ! 17562: movl r9,(r10) # set this field as new head of chain ! 17563: movl r6,(r9) # set forward pointer ! 17564: # ! 17565: # NOW SEE IF THIS BLOCK HAS BEEN PROCESSED BEFORE ! 17566: # ! 17567: cmpl r6,$p$yyy # jump if already processed ! 17568: bgequ gpf02 ! 17569: cmpl r6,$b$aaa # jump if not already processed ! 17570: bgequ gpf03 ! 17571: # ! 17572: # HERE TO MOVE TO NEXT FIELD ! 17573: # ! 17574: gpf02: movl r8,r9 # restore field pointer ! 17575: addl2 $4,r9 # bump to next field ! 17576: cmpl r9,(sp) # loop back if more to go ! 17577: bnequ gpf01 ! 17578: #page ! 17579: # ! 17580: # GBCPF (CONTINUED) ! 17581: # ! 17582: # HERE WE POP UP A LEVEL AFTER FINISHING A BLOCK ! 17583: # ! 17584: movl (sp)+,r10 # restore pointer past end ! 17585: movl (sp)+,r8 # restore block pointer ! 17586: bnequ gpf02 # continue loop unless outer levl ! 17587: rsb # return to caller if outer level ! 17588: # ! 17589: # HERE TO PROCESS AN ACTIVE BLOCK WHICH HAS NOT BEEN DONE ! 17590: # ! 17591: gpf03: movl r10,r9 # copy block pointer ! 17592: movl r6,r10 # copy first word of block ! 17593: movzwl -2(r10),r10 # load entry point id (bl$xx) ! 17594: # ! 17595: # BLOCK TYPE SWITCH. NOTE THAT BLOCKS WITH NO RELOCATABLE ! 17596: # FIELDS JUST RETURN TO GPF02 HERE TO CONTINE TO NEXT FLD. ! 17597: # ! 17598: casel r10,$0,$bl$$$ # switch on block type ! 17599: 5: ! 17600: .word gpf06-5b # arblk ! 17601: .word gpf18-5b # bcblk ! 17602: .word gpf08-5b # cdblk ! 17603: .word gpf17-5b # exblk ! 17604: .word gpf02-5b # icblk ! 17605: .word gpf10-5b # nmblk ! 17606: .word gpf10-5b # p0blk ! 17607: .word gpf12-5b # p1blk ! 17608: .word gpf12-5b # p2blk ! 17609: .word gpf02-5b # rcblk ! 17610: .word gpf02-5b # scblk ! 17611: .word gpf02-5b # seblk ! 17612: .word gpf08-5b # tbblk ! 17613: .word gpf08-5b # vcblk ! 17614: .word gpf02-5b # xnblk ! 17615: .word gpf09-5b # xrblk ! 17616: .word gpf13-5b # pdblk ! 17617: .word gpf16-5b # trblk ! 17618: .word gpf02-5b # bfblk ! 17619: .word gpf07-5b # ccblk ! 17620: .word gpf04-5b # cmblk ! 17621: .word gpf02-5b # ctblk ! 17622: .word gpf02-5b # dfblk ! 17623: .word gpf02-5b # efblk ! 17624: .word gpf10-5b # evblk ! 17625: .word gpf11-5b # ffblk ! 17626: .word gpf02-5b # kvblk ! 17627: .word gpf14-5b # pfblk ! 17628: .word gpf15-5b # teblk ! 17629: #esw # end of jump table ! 17630: #page ! 17631: # ! 17632: # GBCPF (CONTINUED) ! 17633: # ! 17634: # CMBLK ! 17635: # ! 17636: gpf04: movl 4*cmlen(r9),r6 # load length ! 17637: movl $4*cmtyp,r7 # set offset ! 17638: # ! 17639: # HERE TO PUSH DOWN TO NEW LEVEL ! 17640: # ! 17641: # (WC) FIELD PTR AT PREVIOUS LEVEL ! 17642: # (XR) PTR TO NEW BLOCK ! 17643: # (WA) LENGTH (RELOC FLDS + FLDS AT START) ! 17644: # (WB) OFFSET TO FIRST RELOC FIELD ! 17645: # ! 17646: gpf05: addl2 r9,r6 # point past last reloc field ! 17647: addl2 r7,r9 # point to first reloc field ! 17648: movl r8,-(sp) # stack old field pointer ! 17649: movl r6,-(sp) # stack new limit pointer ! 17650: jsb sbchk # check for stack overflow ! 17651: jmp gpf01 # if ok, back to process ! 17652: # ! 17653: # ARBLK ! 17654: # ! 17655: gpf06: movl 4*arlen(r9),r6 # load length ! 17656: movl 4*arofs(r9),r7 # set offset to 1st reloc fld (arpro) ! 17657: jmp gpf05 # all set ! 17658: # ! 17659: # CCBLK ! 17660: # ! 17661: gpf07: movl 4*ccuse(r9),r6 # set length in use ! 17662: movl $4*ccuse,r7 # 1st word (make sure at least one) ! 17663: jmp gpf05 # all set ! 17664: #page ! 17665: # ! 17666: # GBCPF (CONTINUED) ! 17667: # ! 17668: # CDBLK, TBBLK, VCBLK ! 17669: # ! 17670: gpf08: movl 4*offs2(r9),r6 # load length ! 17671: movl $4*offs3,r7 # set offset ! 17672: jmp gpf05 # jump back ! 17673: # ! 17674: # XRBLK ! 17675: # ! 17676: gpf09: movl 4*xrlen(r9),r6 # load length ! 17677: movl $4*xrptr,r7 # set offset ! 17678: jmp gpf05 # jump back ! 17679: # ! 17680: # EVBLK, NMBLK, P0BLK ! 17681: # ! 17682: gpf10: movl $4*offs2,r6 # point past second field ! 17683: movl $4*offs1,r7 # offset is one (only reloc fld is 2) ! 17684: jmp gpf05 # all set ! 17685: # ! 17686: # FFBLK ! 17687: # ! 17688: gpf11: movl $4*ffofs,r6 # set length ! 17689: movl $4*ffnxt,r7 # set offset ! 17690: jmp gpf05 # all set ! 17691: # ! 17692: # P1BLK, P2BLK ! 17693: # ! 17694: gpf12: movl $4*parm2,r6 # length (parm2 is non-relocatable) ! 17695: movl $4*pthen,r7 # set offset ! 17696: jmp gpf05 # all set ! 17697: #page ! 17698: # ! 17699: # GBCPF (CONTINUED) ! 17700: # ! 17701: # PDBLK ! 17702: # ! 17703: gpf13: movl 4*pddfp(r9),r10 # load ptr to dfblk ! 17704: movl 4*dfpdl(r10),r6 # get pdblk length ! 17705: movl $4*pdfld,r7 # set offset ! 17706: jmp gpf05 # all set ! 17707: # ! 17708: # PFBLK ! 17709: # ! 17710: gpf14: movl $4*pfarg,r6 # length past last reloc ! 17711: movl $4*pfcod,r7 # offset to first reloc ! 17712: jmp gpf05 # all set ! 17713: # ! 17714: # TEBLK ! 17715: # ! 17716: gpf15: movl $4*tesi$,r6 # set length ! 17717: movl $4*tesub,r7 # and offset ! 17718: jmp gpf05 # all set ! 17719: # ! 17720: # TRBLK ! 17721: # ! 17722: gpf16: movl $4*trsi$,r6 # set length ! 17723: movl $4*trval,r7 # and offset ! 17724: jmp gpf05 # all set ! 17725: # ! 17726: # EXBLK ! 17727: # ! 17728: gpf17: movl 4*exlen(r9),r6 # load length ! 17729: movl $4*exflc,r7 # set offset ! 17730: jmp gpf05 # jump back ! 17731: # ! 17732: # BCBLK ! 17733: # ! 17734: gpf18: movl $4*bcsi$,r6 # set length ! 17735: movl $4*bcbuf,r7 # and offset ! 17736: jmp gpf05 # all set ! 17737: #enp # end procedure gbcpf ! 17738: #page ! 17739: # ! 17740: # GTARR -- GET ARRAY ! 17741: # ! 17742: # GTARR IS PASSED AN OBJECT AND RETURNS AN ARRAY IF POSSIBL ! 17743: # ! 17744: # (XR) VALUE TO BE CONVERTED ! 17745: # JSR GTARR CALL TO GET ARRAY ! 17746: # PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE ! 17747: # (XR) RESULTING ARRAY ! 17748: # (XL,WA,WB,WC) DESTROYED ! 17749: # ! 17750: gtarr: #prc # entry point ! 17751: movl (r9),r6 # load type word ! 17752: cmpl r6,$b$art # exit if already an array ! 17753: bnequ 0f ! 17754: jmp gtar8 ! 17755: 0: ! 17756: cmpl r6,$b$vct # exit if already an array ! 17757: bnequ 0f ! 17758: jmp gtar8 ! 17759: 0: ! 17760: cmpl r6,$b$tbt # else fail if not a table (sgd02) ! 17761: beqlu 0f ! 17762: jmp gta9a ! 17763: 0: ! 17764: # ! 17765: # HERE WE CONVERT A TABLE TO AN ARRAY ! 17766: # ! 17767: movl r9,-(sp) # replace tbblk pointer on stack ! 17768: clrl r9 # signal first pass ! 17769: clrl r7 # zero non-null element count ! 17770: # ! 17771: # THE FOLLOWING CODE IS EXECUTED TWICE. ON THE FIRST PASS, ! 17772: # SIGNALLED BY XR=0, THE NUMBER OF NON-NULL ELEMENTS IN ! 17773: # THE TABLE IS COUNTED IN WB. IN THE SECOND PASS, WHERE ! 17774: # XR IS A POINTER INTO THE ARBLK, THE NAME AND VALUE ARE ! 17775: # ENTERED INTO THE CURRENT ARBLK LOCATION. ! 17776: # ! 17777: gtar1: movl (sp),r10 # point to table ! 17778: addl2 4*tblen(r10),r10# point past last bucket ! 17779: subl2 $4*tbbuk,r10 # set first bucket offset ! 17780: movl r10,r6 # copy adjusted pointer ! 17781: # ! 17782: # LOOP THROUGH BUCKETS IN TABLE BLOCK ! 17783: # NEXT THREE LINES OF CODE RELY ON TENXT HAVING A VALUE ! 17784: # 1 LESS THAN TBBUK. ! 17785: # ! 17786: gtar2: movl r6,r10 # copy bucket pointer ! 17787: subl2 $4,r6 # decrement bucket pointer ! 17788: # ! 17789: # LOOP THROUGH TEBLKS ON ONE BUCKET CHAIN ! 17790: # ! 17791: gtar3: movl 4*tenxt(r10),r10# point to next teblk ! 17792: cmpl r10,(sp) # jump if chain end (tbblk ptr) ! 17793: beqlu gtar6 ! 17794: movl r10,cnvtp # else save teblk pointer ! 17795: # ! 17796: # LOOP TO FIND VALUE DOWN TRBLK CHAIN ! 17797: # ! 17798: gtar4: movl 4*teval(r10),r10# load value ! 17799: cmpl (r10),$b$trt # loop till value found ! 17800: beqlu gtar4 ! 17801: movl r10,r8 # copy value ! 17802: movl cnvtp,r10 # restore teblk pointer ! 17803: #page ! 17804: # ! 17805: # GTARR (CONTINUED) ! 17806: # ! 17807: # NOW CHECK FOR NULL AND TEST CASES ! 17808: # ! 17809: cmpl r8,$nulls # loop back to ignore null value ! 17810: beqlu gtar3 ! 17811: tstl r9 # jump if second pass ! 17812: bnequ gtar5 ! 17813: incl r7 # for the first pass, bump count ! 17814: jmp gtar3 # and loop back for next teblk ! 17815: # ! 17816: # HERE IN SECOND PASS ! 17817: # ! 17818: gtar5: movl 4*tesub(r10),(r9)+ # store subscript name ! 17819: movl r8,(r9)+ # store value in arblk ! 17820: jmp gtar3 # loop back for next teblk ! 17821: # ! 17822: # HERE AFTER SCANNING TEBLKS ON ONE CHAIN ! 17823: # ! 17824: gtar6: cmpl r6,(sp) # loop back if more buckets to go ! 17825: bnequ gtar2 ! 17826: tstl r9 # else jump if second pass ! 17827: bnequ gtar7 ! 17828: # ! 17829: # HERE AFTER COUNTING NON-NULL ELEMENTS ! 17830: # ! 17831: tstl r7 # fail if no non-null elements ! 17832: bnequ 0f ! 17833: jmp gtar9 ! 17834: 0: ! 17835: movl r7,r6 # else copy count ! 17836: addl2 r7,r6 # double (two words/element) ! 17837: addl2 $arvl2,r6 # add space for standard fields ! 17838: moval 0[r6],r6 # convert length to bytes ! 17839: cmpl r6,mxlen # fail if too long for array ! 17840: blssu 0f ! 17841: jmp gtar9 ! 17842: 0: ! 17843: jsb alloc # else allocate space for arblk ! 17844: movl $b$art,(r9) # store type word ! 17845: clrl 4*idval(r9) # zero id for the moment ! 17846: movl r6,4*arlen(r9) # store length ! 17847: movl $num02,4*arndm(r9) # set dimensions = 2 ! 17848: movl intv1,r5 # get integer one ! 17849: movl r5,4*arlbd(r9) # store as lbd 1 ! 17850: movl r5,4*arlb2(r9) # store as lbd 2 ! 17851: movl intv2,r5 # load integer two ! 17852: movl r5,4*ardm2(r9) # store as dim 2 ! 17853: movl r7,r5 # get element count as integer ! 17854: movl r5,4*ardim(r9) # store as dim 1 ! 17855: clrl 4*arpr2(r9) # zero prototype field for now ! 17856: movl $4*arpr2,4*arofs(r9) # set offset field (signal pass 2) ! 17857: movl r9,r7 # save arblk pointer ! 17858: addl2 $4*arvl2,r9 # point to first element location ! 17859: jmp gtar1 # jump back to fill in elements ! 17860: #page ! 17861: # ! 17862: # GTARR (CONTINUED) ! 17863: # ! 17864: # HERE AFTER FILLING IN ELEMENT VALUES ! 17865: # ! 17866: gtar7: movl r7,r9 # restore arblk pointer ! 17867: movl r7,(sp) # store as result ! 17868: # ! 17869: # NOW WE NEED THE ARRAY PROTOTYPE WHICH IS OF THE FORM NN,2 ! 17870: # THIS IS OBTAINED BY BUILDING THE STRING FOR NN02 AND ! 17871: # CHANGING THE ZERO TO A COMMA BEFORE STORING IT. ! 17872: # ! 17873: movl 4*ardim(r9),r5 # get number of elements (nn) ! 17874: mull2 intvh,r5 # multiply by 100 ! 17875: addl2 intv2,r5 # add 2 (nn02) ! 17876: jsb icbld # build integer ! 17877: movl r9,-(sp) # store ptr for gtstg ! 17878: jsb gtstg # convert to string ! 17879: .long invalid$ # convert fail is impossible ! 17880: movl r9,r10 # copy string pointer ! 17881: movl (sp)+,r9 # reload arblk pointer ! 17882: movl r10,4*arpr2(r9) # store prototype ptr (nn02) ! 17883: subl2 $num02,r6 # adjust length to point to zero ! 17884: movab cfp$f(r10)[r6],r10 # point to zero ! 17885: movl $ch$cm,r7 # load a comma ! 17886: movb r7,(r10) # store a comma over the zero ! 17887: #csc r10 # complete store characters ! 17888: # ! 17889: # NORMAL RETURN ! 17890: # ! 17891: gtar8: addl2 $4*1,(sp) # return to caller ! 17892: rsb ! 17893: # ! 17894: # NON-CONVERSION RETURN ! 17895: # ! 17896: gtar9: movl (sp)+,r9 # restore stack for conv err (sgd02) ! 17897: # ! 17898: # MERGE TO TAKE CONVERT ERROR WHEN STACK ADJUSTED OK ! 17899: # ! 17900: gta9a: movl (sp)+,r11 # return ! 17901: jmp *(r11)+ ! 17902: #enp # procedure gtarr ! 17903: #page ! 17904: # ! 17905: # GTCOD -- CONVERT TO CODE ! 17906: # ! 17907: # (XR) OBJECT TO BE CONVERTED ! 17908: # JSR GTCOD CALL TO CONVERT TO CODE ! 17909: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 17910: # (XR) POINTER TO RESULTING CDBLK ! 17911: # (XL,WA,WB,WC,RA) DESTROYED ! 17912: # ! 17913: # IF A SPITBOL ERROR OCCURS DURING COMPILATION OR PRE- ! 17914: # EVALUATION, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL ! 17915: # WITHOUT RETURNING TO THIS ROUTINE. ! 17916: # ! 17917: gtcod: #prc # entry point ! 17918: cmpl (r9),$b$cds # jump if already code ! 17919: beqlu gtcd1 ! 17920: cmpl (r9),$b$cdc # jump if already code ! 17921: beqlu gtcd1 ! 17922: # ! 17923: # HERE WE MUST GENERATE A CDBLK BY COMPILATION ! 17924: # ! 17925: movl r9,-(sp) # stack argument for gtstg ! 17926: jsb gtstg # convert argument to string ! 17927: .long gtcd2 # jump if non-convertible ! 17928: movl flptr,gtcef # save fail ptr in case of error ! 17929: movl r$cod,r$gtc # also save code ptr ! 17930: movl r9,r$cim # else set image pointer ! 17931: movl r6,scnil # set image length ! 17932: clrl scnpt # set scan pointer ! 17933: movl $stgxc,stage # set stage for execute compile ! 17934: movl cmpsn,lstsn # in case listr called ! 17935: jsb cmpil # compile string ! 17936: movl $stgxt,stage # reset stage for execute time ! 17937: clrl r$cim # clear image ! 17938: # ! 17939: # MERGE HERE IF NO CONVERT REQUIRED ! 17940: # ! 17941: gtcd1: addl2 $4*1,(sp) # give normal gtcod return ! 17942: rsb ! 17943: # ! 17944: # HERE IF UNCONVERTIBLE ! 17945: # ! 17946: gtcd2: movl (sp)+,r11 # give error return ! 17947: jmp *(r11)+ ! 17948: #enp # end procedure gtcod ! 17949: #page ! 17950: # ! 17951: # GTEXP -- CONVERT TO EXPRESSION ! 17952: # ! 17953: # (XR) INPUT VALUE TO BE CONVERTED ! 17954: # JSR GTEXP CALL TO CONVERT TO EXPRESSION ! 17955: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 17956: # (XR) POINTER TO RESULT EXBLK OR SEBLK ! 17957: # (XL,WA,WB,WC,RA) DESTROYED ! 17958: # ! 17959: # IF A SPITBOL ERROR OCCURS DURING COMPILATION OR PRE- ! 17960: # EVALUATION, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL ! 17961: # WITHOUT RETURNING TO THIS ROUTINE. ! 17962: # ! 17963: gtexp: #prc # entry point ! 17964: cmpl (r9),$b$e$$ # jump if already an expression ! 17965: bgtru 0f ! 17966: jmp gtex1 ! 17967: 0: ! 17968: movl r9,-(sp) # store argument for gtstg ! 17969: jsb gtstg # convert argument to string ! 17970: .long gtex2 # jump if unconvertible ! 17971: # ! 17972: # CHECK THE LAST CHARACTER OF THE STRING FOR COLON OR ! 17973: # SEMICOLON. THESE CHARACTERS CAN LEGITIMATELY END AN ! 17974: # EXPRESSION IN OPEN CODE, SO EXPAN WILL NOT DETECT THEM ! 17975: # AS ERRORS, BUT THEY ARE INVALID AS TERMINATORS FOR A ! 17976: # STRING THAT IS BEING CONVERTED TO EXPRESSION FORM. ! 17977: # ! 17978: movl r9,r10 # copy input string pointer (reg06) ! 17979: movab cfp$f(r10)[r6],r10 # point one past the string end (reg06) ! 17980: movzbl -(r10),r10 # fetch the last character (reg06) ! 17981: cmpl r10,$ch$cl # error if it is a semicolon (reg06) ! 17982: beqlu gtex2 ! 17983: cmpl r10,$ch$sm # or if it is a colon (reg06) ! 17984: beqlu gtex2 ! 17985: # ! 17986: # HERE WE CONVERT A STRING BY COMPILATION ! 17987: # ! 17988: movl r9,r$cim # set input image pointer ! 17989: clrl scnpt # set scan pointer ! 17990: movl r6,scnil # set input image length ! 17991: clrl r7 # set code for normal scan ! 17992: movl flptr,gtcef # save fail ptr in case of error ! 17993: movl r$cod,r$gtc # also save code ptr ! 17994: movl $stgev,stage # adjust stage for compile ! 17995: movl $t$uok,scntp # indicate unary operator acceptable ! 17996: jsb expan # build tree for expression ! 17997: clrl scnrs # reset rescan flag ! 17998: cmpl scnpt,scnil # error if not end of image ! 17999: bnequ gtex2 ! 18000: clrl r7 # set ok value for cdgex call ! 18001: movl r9,r10 # copy tree pointer ! 18002: jsb cdgex # build expression block ! 18003: clrl r$cim # clear pointer ! 18004: movl $stgxt,stage # restore stage for execute time ! 18005: # ! 18006: # MERGE HERE IF NO CONVERSION REQUIRED ! 18007: # ! 18008: gtex1: addl2 $4*1,(sp) # return to gtexp caller ! 18009: rsb ! 18010: # ! 18011: # HERE IF UNCONVERTIBLE ! 18012: # ! 18013: gtex2: movl (sp)+,r11 # take error exit ! 18014: jmp *(r11)+ ! 18015: #enp # end procedure gtexp ! 18016: #page ! 18017: # ! 18018: # GTINT -- GET INTEGER VALUE ! 18019: # ! 18020: # GTINT IS PASSED AN OBJECT AND RETURNS AN INTEGER AFTER ! 18021: # PERFORMING ANY NECESSARY CONVERSIONS. ! 18022: # ! 18023: # (XR) VALUE TO BE CONVERTED ! 18024: # JSR GTINT CALL TO CONVERT TO INTEGER ! 18025: # PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE ! 18026: # (XR) RESULTING INTEGER ! 18027: # (WC,RA) DESTROYED ! 18028: # (WA,WB) DESTROYED (ONLY ON CONVERSION ERR) ! 18029: # (XR) UNCHANGED (ON CONVERT ERROR) ! 18030: # ! 18031: gtint: #prc # entry point ! 18032: cmpl (r9),$b$icl # jump if already an integer ! 18033: beqlu gtin2 ! 18034: movl r6,gtina # else save wa ! 18035: movl r7,gtinb # save wb ! 18036: jsb gtnum # convert to numeric ! 18037: .long gtin3 # jump if unconvertible ! 18038: cmpl r6,$b$icl # jump if integer ! 18039: beqlu gtin1 ! 18040: # ! 18041: # HERE WE CONVERT A REAL TO INTEGER ! 18042: # ! 18043: movf 4*rcval(r9),r2 # load real value ! 18044: cvtfl r2,r5 # convert to integer (err if ovflow) ! 18045: bvs gtin3 ! 18046: jsb icbld # if ok build icblk ! 18047: # ! 18048: # HERE AFTER SUCCESSFUL CONVERSION TO INTEGER ! 18049: # ! 18050: gtin1: movl gtina,r6 # restore wa ! 18051: movl gtinb,r7 # restore wb ! 18052: # ! 18053: # COMMON EXIT POINT ! 18054: # ! 18055: gtin2: addl2 $4*1,(sp) # return to gtint caller ! 18056: rsb ! 18057: # ! 18058: # HERE ON CONVERSION ERROR ! 18059: # ! 18060: gtin3: movl (sp)+,r11 # take convert error exit ! 18061: jmp *(r11)+ ! 18062: #enp # end procedure gtint ! 18063: #page ! 18064: # ! 18065: # GTNUM -- GET NUMERIC VALUE ! 18066: # ! 18067: # GTNUM IS GIVEN AN OBJECT AND RETURNS EITHER AN INTEGER ! 18068: # OR A REAL, PERFORMING ANY NECESSARY CONVERSIONS. ! 18069: # ! 18070: # (XR) OBJECT TO BE CONVERTED ! 18071: # JSR GTNUM CALL TO CONVERT TO NUMERIC ! 18072: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 18073: # (XR) POINTER TO RESULT (INT OR REAL) ! 18074: # (WA) FIRST WORD OF RESULT BLOCK ! 18075: # (WB,WC,RA) DESTROYED ! 18076: # (XR) UNCHANGED (ON CONVERT ERROR) ! 18077: # ! 18078: gtnum: #prc # entry point ! 18079: movl (r9),r6 # load first word of block ! 18080: cmpl r6,$b$icl # jump if integer (no conversion) ! 18081: bnequ 0f ! 18082: jmp gtn34 ! 18083: 0: ! 18084: cmpl r6,$b$rcl # jump if real (no conversion) ! 18085: bnequ 0f ! 18086: jmp gtn34 ! 18087: 0: ! 18088: # ! 18089: # AT THIS POINT THE ONLY POSSIBILITY IS TO CONVERT A STRING ! 18090: # TO AN INTEGER OR REAL AS APPROPRIATE. ! 18091: # ! 18092: movl r9,-(sp) # stack argument in case convert err ! 18093: movl r9,-(sp) # stack argument for gtstg ! 18094: jsb gtstg # convert argument to string ! 18095: .long gtn36 # jump if unconvertible ! 18096: # ! 18097: # INITIALIZE NUMERIC CONVERSION ! 18098: # ! 18099: movl intv0,r5 # initialize integer result to zero ! 18100: tstl r6 # jump to exit with zero if null ! 18101: bnequ 0f ! 18102: jmp gtn32 ! 18103: 0: ! 18104: # set bct counter for following loops ! 18105: clrl gtnnf # tentatively indicate result + ! 18106: movl r5,gtnex # initialise exponent to zero ! 18107: clrl gtnsc # zero scale in case real ! 18108: clrl gtndf # reset flag for dec point found ! 18109: clrl gtnrd # reset flag for digits found ! 18110: movf reav0,r2 # zero real accum in case real ! 18111: movab cfp$f(r9),r9 # point to argument characters ! 18112: # ! 18113: # MERGE BACK HERE AFTER IGNORING LEADING BLANK ! 18114: # ! 18115: gtn01: movzbl (r9)+,r7 # load first character ! 18116: cmpl r7,$ch$d0 # jump if not digit ! 18117: blssu gtn02 ! 18118: cmpl r7,$ch$d9 # jump if first char is a digit ! 18119: blequ gtn06 ! 18120: #page ! 18121: # ! 18122: # GTNUM (CONTINUED) ! 18123: # ! 18124: # HERE IF FIRST DIGIT IS NON-DIGIT ! 18125: # ! 18126: gtn02: cmpl r7,$ch$bl # jump if non-blank ! 18127: bnequ gtn03 ! 18128: gtna2: sobgtr r6,gtn01 # else decr count and loop back ! 18129: jmp gtn07 # jump to return zero if all blanks ! 18130: # ! 18131: # HERE FOR FIRST CHARACTER NON-BLANK, NON-DIGIT ! 18132: # ! 18133: gtn03: cmpl r7,$ch$pl # jump if plus sign ! 18134: beqlu gtn04 ! 18135: cmpl r7,$ch$ht # horizontal tab equiv to blank ! 18136: beqlu gtna2 ! 18137: cmpl r7,$ch$mn # jump if not minus (may be real) ! 18138: beqlu 0f ! 18139: jmp gtn12 ! 18140: 0: ! 18141: movl sp,gtnnf # if minus sign, set negative flag ! 18142: # ! 18143: # MERGE HERE AFTER PROCESSING SIGN ! 18144: # ! 18145: gtn04: sobgtr r6,gtn05 # jump if chars left ! 18146: jmp gtn36 # else error ! 18147: # ! 18148: # LOOP TO FETCH CHARACTERS OF AN INTEGER ! 18149: # ! 18150: gtn05: movzbl (r9)+,r7 # load next character ! 18151: cmpl r7,$ch$d0 # jump if not a digit ! 18152: blssu gtn08 ! 18153: cmpl r7,$ch$d9 # jump if not a digit ! 18154: bgtru gtn08 ! 18155: # ! 18156: # MERGE HERE FOR FIRST DIGIT ! 18157: # ! 18158: gtn06: movl r5,gtnsi # save current value ! 18159: mull2 $10,r5 # current*10-(new dig) jump if ovflow ! 18160: bvc 0f ! 18161: jmp gtn35 ! 18162: 0: bicl2 $0xfffffff0,r7 ! 18163: subl2 r7,r5 ! 18164: bvc 1f ! 18165: jmp gtn35 ! 18166: 1: ! 18167: movl sp,gtnrd # set digit read flag ! 18168: sobgtr r6,gtn05 # else loop back if more chars ! 18169: # ! 18170: # HERE TO EXIT WITH CONVERTED INTEGER VALUE ! 18171: # ! 18172: gtn07: tstl gtnnf # jump if negative (all set) ! 18173: beqlu 0f ! 18174: jmp gtn32 ! 18175: 0: ! 18176: mnegl r5,r5 # else negate ! 18177: bvs 0f ! 18178: jmp gtn32 ! 18179: 0: ! 18180: jmp gtn36 # else signal error ! 18181: #page ! 18182: # ! 18183: # GTNUM (CONTINUED) ! 18184: # ! 18185: # HERE FOR A NON-DIGIT CHARACTER WHILE ATTEMPTING TO ! 18186: # CONVERT AN INTEGER, CHECK FOR TRAILING BLANKS OR REAL. ! 18187: # ! 18188: gtn08: cmpl r7,$ch$bl # jump if a blank ! 18189: beqlu gtna9 ! 18190: cmpl r7,$ch$ht # jump if horizontal tab ! 18191: beqlu gtna9 ! 18192: cvtlf r5,r2 # else convert integer to real ! 18193: mnegf r2,r2 # negate to get positive value ! 18194: jmp gtn12 # jump to try for real ! 18195: # ! 18196: # HERE WE SCAN OUT BLANKS TO END OF STRING ! 18197: # ! 18198: gtn09: movzbl (r9)+,r7 # get next char ! 18199: cmpl r7,$ch$ht # jump if horizontal tab ! 18200: beqlu gtna9 ! 18201: cmpl r7,$ch$bl # error if non-blank ! 18202: beqlu 0f ! 18203: jmp gtn36 ! 18204: 0: ! 18205: gtna9: sobgtr r6,gtn09 # loop back if more chars to check ! 18206: jmp gtn07 # return integer if all blanks ! 18207: # ! 18208: # LOOP TO COLLECT MANTISSA OF REAL ! 18209: # ! 18210: gtn10: movzbl (r9)+,r7 # load next character ! 18211: cmpl r7,$ch$d0 # jump if non-numeric ! 18212: bgequ 0f ! 18213: jmp gtn12 ! 18214: 0: ! 18215: cmpl r7,$ch$d9 # jump if non-numeric ! 18216: blequ 0f ! 18217: jmp gtn12 ! 18218: 0: ! 18219: # ! 18220: # MERGE HERE TO COLLECT FIRST REAL DIGIT ! 18221: # ! 18222: gtn11: subl2 $ch$d0,r7 # convert digit to number ! 18223: mulf2 reavt,r2 # multiply real by 10.0 ! 18224: bvc 0f ! 18225: jmp gtn36 ! 18226: 0: ! 18227: movf r2,gtnsr # save result ! 18228: movl r7,r5 # get new digit as integer ! 18229: cvtlf r5,r2 # convert new digit to real ! 18230: addf2 gtnsr,r2 # add to get new total ! 18231: addl2 gtndf,gtnsc # increment scale if after dec point ! 18232: movl sp,gtnrd # set digit found flag ! 18233: sobgtr r6,gtn10 # loop back if more chars ! 18234: jmp gtn22 # else jump to scale ! 18235: #page ! 18236: # ! 18237: # GTNUM (CONTINUED) ! 18238: # ! 18239: # HERE IF NON-DIGIT FOUND WHILE COLLECTING A REAL ! 18240: # ! 18241: gtn12: cmpl r7,$ch$dt # jump if not dec point ! 18242: bnequ gtn13 ! 18243: tstl gtndf # if dec point, error if one already ! 18244: beqlu 0f ! 18245: jmp gtn36 ! 18246: 0: ! 18247: movl $num01,gtndf # else set flag for dec point ! 18248: sobgtr r6,gtn10 # loop back if more chars ! 18249: jmp gtn22 # else jump to scale ! 18250: # ! 18251: # HERE IF NOT DECIMAL POINT ! 18252: # ! 18253: gtn13: cmpl r7,$ch$le # jump if e for exponent ! 18254: beqlu gtn15 ! 18255: cmpl r7,$ch$ld # jump if d for exponent ! 18256: beqlu gtn15 ! 18257: cmpl r7,$ch$$e # jump if e for exponent ! 18258: beqlu gtn15 ! 18259: cmpl r7,$ch$$d # jump if d for exponent ! 18260: beqlu gtn15 ! 18261: # ! 18262: # HERE CHECK FOR TRAILING BLANKS ! 18263: # ! 18264: gtn14: cmpl r7,$ch$bl # jump if blank ! 18265: beqlu gtnb4 ! 18266: cmpl r7,$ch$ht # jump if horizontal tab ! 18267: beqlu gtnb4 ! 18268: jmp gtn36 # error if non-blank ! 18269: # ! 18270: gtnb4: movzbl (r9)+,r7 # get next character ! 18271: sobgtr r6,gtn14 # loop back to check if more ! 18272: jmp gtn22 # else jump to scale ! 18273: # ! 18274: # HERE TO READ AND PROCESS AN EXPONENT ! 18275: # ! 18276: gtn15: clrl gtnes # set exponent sign positive ! 18277: movl intv0,r5 # initialize exponent to zero ! 18278: movl sp,gtndf # reset no dec point indication ! 18279: sobgtr r6,gtn16 # jump skipping past e or d ! 18280: jmp gtn36 # error if null exponent ! 18281: # ! 18282: # CHECK FOR EXPONENT SIGN ! 18283: # ! 18284: gtn16: movzbl (r9)+,r7 # load first exponent character ! 18285: cmpl r7,$ch$pl # jump if plus sign ! 18286: beqlu gtn17 ! 18287: cmpl r7,$ch$mn # else jump if not minus sign ! 18288: bnequ gtn19 ! 18289: movl sp,gtnes # set sign negative if minus sign ! 18290: # ! 18291: # MERGE HERE AFTER PROCESSING EXPONENT SIGN ! 18292: # ! 18293: gtn17: sobgtr r6,gtn18 # jump if chars left ! 18294: jmp gtn36 # else error ! 18295: # ! 18296: # LOOP TO CONVERT EXPONENT DIGITS ! 18297: # ! 18298: gtn18: movzbl (r9)+,r7 # load next character ! 18299: #page ! 18300: # ! 18301: # GTNUM (CONTINUED) ! 18302: # ! 18303: # MERGE HERE FOR FIRST EXPONENT DIGIT ! 18304: # ! 18305: gtn19: cmpl r7,$ch$d0 # jump if not digit ! 18306: blssu gtn20 ! 18307: cmpl r7,$ch$d9 # jump if not digit ! 18308: bgtru gtn20 ! 18309: mull2 $10,r5 # else current*10, subtract new digit ! 18310: bvc 0f ! 18311: jmp gtn36 ! 18312: 0: bicl2 $0xfffffff0,r7 ! 18313: subl2 r7,r5 ! 18314: bvc 1f ! 18315: jmp gtn36 ! 18316: 1: ! 18317: sobgtr r6,gtn18 # loop back if more chars ! 18318: jmp gtn21 # jump if exponent field is exhausted ! 18319: # ! 18320: # HERE TO CHECK FOR TRAILING BLANKS AFTER EXPONENT ! 18321: # ! 18322: gtn20: cmpl r7,$ch$bl # jump if blank ! 18323: beqlu gtnc0 ! 18324: cmpl r7,$ch$ht # jump if horizontal tab ! 18325: beqlu gtnc0 ! 18326: jmp gtn36 # error if non-blank ! 18327: # ! 18328: gtnc0: movzbl (r9)+,r7 # get next character ! 18329: sobgtr r6,gtn20 # loop back till all blanks scanned ! 18330: # ! 18331: # MERGE HERE AFTER COLLECTING EXPONENT ! 18332: # ! 18333: gtn21: movl r5,gtnex # save collected exponent ! 18334: tstl gtnes # jump if it was negative ! 18335: bnequ gtn22 ! 18336: mnegl r5,r5 # else complement ! 18337: bvc 0f ! 18338: jmp gtn36 ! 18339: 0: ! 18340: movl r5,gtnex # and store positive exponent ! 18341: # ! 18342: # MERGE HERE WITH EXPONENT (0 IF NONE GIVEN) ! 18343: # ! 18344: gtn22: tstl gtnrd # error if not digits collected ! 18345: bnequ 0f ! 18346: jmp gtn36 ! 18347: 0: ! 18348: tstl gtndf # error if no exponent or dec point ! 18349: bnequ 0f ! 18350: jmp gtn36 ! 18351: 0: ! 18352: movl gtnsc,r5 # else load scale as integer ! 18353: subl2 gtnex,r5 # subtract exponent ! 18354: bvc 0f ! 18355: jmp gtn36 ! 18356: 0: ! 18357: tstl r5 # jump if we must scale up ! 18358: blss gtn26 ! 18359: # ! 18360: # HERE WE HAVE A NEGATIVE EXPONENT, SO SCALE DOWN ! 18361: # ! 18362: movl r5,r6 # load scale factor, err if ovflow ! 18363: bgeq 0f ! 18364: jmp gtn36 ! 18365: 0: ! 18366: # ! 18367: # LOOP TO SCALE DOWN IN STEPS OF 10**10 ! 18368: # ! 18369: gtn23: cmpl r6,$num10 # jump if 10 or less to go ! 18370: blequ gtn24 ! 18371: divf2 reatt,r2 # else divide by 10**10 ! 18372: subl2 $num10,r6 # decrement scale ! 18373: jmp gtn23 # and loop back ! 18374: #page ! 18375: # ! 18376: # GTNUM (CONTINUED) ! 18377: # ! 18378: # HERE SCALE REST OF WAY FROM POWERS OF TEN TABLE ! 18379: # ! 18380: gtn24: tstl r6 # jump if scaled ! 18381: beqlu gtn30 ! 18382: movl $cfp$r,r7 # else get indexing factor ! 18383: movl $reav1,r9 # point to powers of ten table ! 18384: moval 0[r6],r6 # convert remaining scale to byte ofs ! 18385: # ! 18386: # LOOP TO POINT TO POWERS OF TEN TABLE ENTRY ! 18387: # ! 18388: gtn25: addl2 r6,r9 # bump pointer ! 18389: sobgtr r7,gtn25 # once for each value word ! 18390: divf2 (r9),r2 # scale down as required ! 18391: jmp gtn30 # and jump ! 18392: # ! 18393: # COME HERE TO SCALE RESULT UP (POSITIVE EXPONENT) ! 18394: # ! 18395: gtn26: mnegl r5,r5 # get absolute value of exponent ! 18396: bvc 0f ! 18397: jmp gtn36 ! 18398: 0: ! 18399: movl r5,r6 # acquire scale, error if ovflow ! 18400: bgeq 0f ! 18401: jmp gtn36 ! 18402: 0: ! 18403: # ! 18404: # LOOP TO SCALE UP IN STEPS OF 10**10 ! 18405: # ! 18406: gtn27: cmpl r6,$num10 # jump if 10 or less to go ! 18407: blequ gtn28 ! 18408: mulf2 reatt,r2 # else multiply by 10**10 ! 18409: bvc 0f ! 18410: jmp gtn36 ! 18411: 0: ! 18412: subl2 $num10,r6 # else decrement scale ! 18413: jmp gtn27 # and loop back ! 18414: # ! 18415: # HERE TO SCALE UP REST OF WAY WITH TABLE ! 18416: # ! 18417: gtn28: tstl r6 # jump if scaled ! 18418: beqlu gtn30 ! 18419: movl $cfp$r,r7 # else get indexing factor ! 18420: movl $reav1,r9 # point to powers of ten table ! 18421: moval 0[r6],r6 # convert remaining scale to byte ofs ! 18422: # ! 18423: # LOOP TO POINT TO PROPER ENTRY IN POWERS OF TEN TABLE ! 18424: # ! 18425: gtn29: addl2 r6,r9 # bump pointer ! 18426: sobgtr r7,gtn29 # once for each word in value ! 18427: mulf2 (r9),r2 # scale up ! 18428: bvc 0f ! 18429: jmp gtn36 ! 18430: 0: ! 18431: #page ! 18432: # ! 18433: # GTNUM (CONTINUED) ! 18434: # ! 18435: # HERE WITH REAL VALUE SCALED AND READY EXCEPT FOR SIGN ! 18436: # ! 18437: gtn30: tstl gtnnf # jump if positive ! 18438: beqlu gtn31 ! 18439: mnegf r2,r2 # else negate ! 18440: # ! 18441: # HERE WITH PROPERLY SIGNED REAL VALUE IN (RA) ! 18442: # ! 18443: gtn31: jsb rcbld # build real block ! 18444: jmp gtn33 # merge to exit ! 18445: # ! 18446: # HERE WITH PROPERLY SIGNED INTEGER VALUE IN (IA) ! 18447: # ! 18448: gtn32: jsb icbld # build icblk ! 18449: # ! 18450: # REAL MERGES HERE ! 18451: # ! 18452: gtn33: movl (r9),r6 # load first word of result block ! 18453: addl2 $4,sp # pop argument off stack ! 18454: # ! 18455: # COMMON EXIT POINT ! 18456: # ! 18457: gtn34: addl2 $4*1,(sp) # return to gtnum caller ! 18458: rsb ! 18459: # ! 18460: # COME HERE IF OVERFLOW OCCURS DURING COLLECTION OF INTEGER ! 18461: # ! 18462: gtn35: movl gtnsi,r5 # reload integer so far ! 18463: cvtlf r5,r2 # convert to real ! 18464: mnegf r2,r2 # make value positive ! 18465: jmp gtn11 # merge with real circuit ! 18466: # ! 18467: # HERE FOR UNCONVERTIBLE TO STRING OR CONVERSION ERROR ! 18468: # ! 18469: gtn36: movl (sp)+,r9 # reload original argument ! 18470: movl (sp)+,r11 # take convert-error exit ! 18471: jmp *(r11)+ ! 18472: #enp # end procedure gtnum ! 18473: #page ! 18474: # ! 18475: # GTNVR -- CONVERT TO NATURAL VARIABLE ! 18476: # ! 18477: # GTNVR LOCATES A VARIABLE BLOCK (VRBLK) GIVEN EITHER AN ! 18478: # APPROPRIATE NAME (NMBLK) OR A NON-NULL STRING (SCBLK). ! 18479: # ! 18480: # (XR) ARGUMENT ! 18481: # JSR GTNVR CALL TO CONVERT TO NATURAL VARIABLE ! 18482: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 18483: # (XR) POINTER TO VRBLK ! 18484: # (WA,WB) DESTROYED (CONVERSION ERROR ONLY) ! 18485: # (WC) DESTROYED ! 18486: # ! 18487: gtnvr: #prc # entry point ! 18488: cmpl (r9),$b$nml # jump if not name ! 18489: bnequ gnv02 ! 18490: movl 4*nmbas(r9),r9 # else load name base if name ! 18491: cmpl r9,state # skip if vrblk (in static region) ! 18492: bgtru 0f ! 18493: jmp gnv07 ! 18494: 0: ! 18495: # ! 18496: # COMMON ERROR EXIT ! 18497: # ! 18498: gnv01: movl (sp)+,r11 # take convert-error exit ! 18499: jmp *(r11)+ ! 18500: # ! 18501: # HERE IF NOT NAME ! 18502: # ! 18503: gnv02: movl r6,gnvsa # save wa ! 18504: movl r7,gnvsb # save wb ! 18505: movl r9,-(sp) # stack argument for gtstg ! 18506: jsb gtstg # convert argument to string ! 18507: .long gnv01 # jump if conversion error ! 18508: tstl r6 # null string is an error ! 18509: beqlu gnv01 ! 18510: jsb flstg # fold lower case to upper case ! 18511: movl r10,-(sp) # save xl ! 18512: movl r9,-(sp) # stack string ptr for later ! 18513: movl r9,r7 # copy string pointer ! 18514: addl2 $4*schar,r7 # point to characters of string ! 18515: movl r7,gnvst # save pointer to characters ! 18516: movl r6,r7 # copy length ! 18517: movab 3+(4*0)(r7),r7 # get number of words in name ! 18518: ashl $-2,r7,r7 ! 18519: movl r7,gnvnw # save for later ! 18520: jsb hashs # compute hash index for string ! 18521: ashq $-32,r4,r4 # compute hash offset by taking mod ! 18522: ediv hshnb,r4,r11,r5 ! 18523: movl r5,r8 # get as offset ! 18524: moval 0[r8],r8 # convert offset to bytes ! 18525: addl2 hshtb,r8 # point to proper hash chain ! 18526: subl2 $4*vrnxt,r8 # subtract offset to merge into loop ! 18527: #page ! 18528: # ! 18529: # GTNVR (CONTINUED) ! 18530: # ! 18531: # LOOP TO SEARCH HASH CHAIN ! 18532: # ! 18533: gnv03: movl r8,r10 # copy hash chain pointer ! 18534: movl 4*vrnxt(r10),r10# point to next vrblk on chain ! 18535: beqlu gnv08 # jump if end of chain ! 18536: movl r10,r8 # save pointer to this vrblk ! 18537: tstl 4*vrlen(r10) # jump if not system variable ! 18538: bnequ gnv04 ! 18539: movl 4*vrsvp(r10),r10# else point to svblk ! 18540: subl2 $4*vrsof,r10 # adjust offset for merge ! 18541: # ! 18542: # MERGE HERE WITH STRING PTR (LIKE VRBLK) IN XL ! 18543: # ! 18544: gnv04: cmpl r6,4*vrlen(r10) # back for next vrblk if lengths ne ! 18545: bnequ gnv03 ! 18546: addl2 $4*vrchs,r10 # else point to chars of chain entry ! 18547: movl gnvnw,r7 # get word counter to control loop ! 18548: movl gnvst,r9 # point to chars of new name ! 18549: # ! 18550: # LOOP TO COMPARE CHARACTERS OF THE TWO NAMES ! 18551: # ! 18552: gnv05: cmpl (r9),(r10) # jump if no match for next vrblk ! 18553: bnequ gnv03 ! 18554: addl2 $4,r9 # bump new name pointer ! 18555: addl2 $4,r10 # bump vrblk in chain name pointer ! 18556: sobgtr r7,gnv05 # else loop till all compared ! 18557: movl r8,r9 # we have found a match, get vrblk ! 18558: # ! 18559: # EXIT POINT AFTER FINDING VRBLK OR BUILDING NEW ONE ! 18560: # ! 18561: gnv06: movl gnvsa,r6 # restore wa ! 18562: movl gnvsb,r7 # restore wb ! 18563: addl2 $4,sp # pop string pointer ! 18564: movl (sp)+,r10 # restore xl ! 18565: # ! 18566: # COMMON EXIT POINT ! 18567: # ! 18568: gnv07: addl2 $4*1,(sp) # return to gtnvr caller ! 18569: rsb ! 18570: # ! 18571: # NOT FOUND, PREPARE TO SEARCH SYSTEM VARIABLE TABLE ! 18572: # ! 18573: gnv08: clrl r9 # clear garbage xr pointer ! 18574: movl r8,gnvhe # save ptr to end of hash chain ! 18575: cmpl r6,$num09 # cannot be system var if length gt 9 ! 18576: bgtru gnv14 ! 18577: movl r6,r10 # else copy length ! 18578: moval 0[r10],r10 # convert to byte offset ! 18579: movl l^vsrch(r10),r10# point to first svblk of this length ! 18580: #page ! 18581: # ! 18582: # GTNVR (CONTINUED) ! 18583: # ! 18584: # LOOP TO SEARCH ENTRIES IN STANDARD VARIABLE TABLE ! 18585: # ! 18586: gnv09: movl r10,gnvsp # save table pointer ! 18587: movl (r10)+,r8 # load svbit bit string ! 18588: movl (r10)+,r7 # load length from table entry ! 18589: cmpl r6,r7 # jump if end of right length entires ! 18590: bnequ gnv14 ! 18591: movl gnvnw,r7 # get word counter to control loop ! 18592: movl gnvst,r9 # point to chars of new name ! 18593: # ! 18594: # LOOP TO CHECK FOR MATCHING NAMES ! 18595: # ! 18596: gnv10: cmpl (r9),(r10) # jump if name mismatch ! 18597: bnequ gnv11 ! 18598: addl2 $4,r9 # else bump new name pointer ! 18599: addl2 $4,r10 # bump svblk pointer ! 18600: sobgtr r7,gnv10 # else loop until all checked ! 18601: # ! 18602: # HERE WE HAVE A MATCH IN THE STANDARD VARIABLE TABLE ! 18603: # ! 18604: clrl r8 # set vrlen value zero ! 18605: movl $4*vrsi$,r6 # set standard size ! 18606: jmp gnv15 # jump to build vrblk ! 18607: # ! 18608: # HERE IF NO MATCH WITH TABLE ENTRY IN SVBLKS TABLE ! 18609: # ! 18610: gnv11: addl2 $4,r10 # bump past word of chars ! 18611: sobgtr r7,gnv11 # loop back if more to go ! 18612: ashl $-svnbt,r8,r8 # remove uninteresting bits ! 18613: # ! 18614: # LOOP TO BUMP TABLE PTR FOR EACH FLAGGED WORD ! 18615: # ! 18616: gnv12: movl bits1,r7 # load bit to test ! 18617: mcoml r8,r11 # test for word present ! 18618: bicl2 r11,r7 ! 18619: beqlu gnv13 # jump if not present ! 18620: addl2 $4,r10 # else bump table pointer ! 18621: # ! 18622: # HERE AFTER DEALING WITH ONE WORD (ONE BIT) ! 18623: # ! 18624: gnv13: ashl $-1,r8,r8 # remove bit already processed ! 18625: tstl r8 # loop back if more bits to test ! 18626: bnequ gnv12 ! 18627: jmp gnv09 # else loop back for next svblk ! 18628: # ! 18629: # HERE IF NOT SYSTEM VARIABLE ! 18630: # ! 18631: gnv14: movl r6,r8 # copy vrlen value ! 18632: movl $vrchs,r6 # load standard size -chars ! 18633: addl2 gnvnw,r6 # adjust for chars of name ! 18634: moval 0[r6],r6 # convert length to bytes ! 18635: #page ! 18636: # ! 18637: # GTNVR (CONTINUED) ! 18638: # ! 18639: # MERGE HERE TO BUILD VRBLK ! 18640: # ! 18641: gnv15: jsb alost # allocate space for vrblk (static) ! 18642: movl r9,r7 # save vrblk pointer ! 18643: movl $stnvr,r10 # point to model variable block ! 18644: movl $4*vrlen,r6 # set length of standard fields ! 18645: jsb sbmvw # set initial fields of new block ! 18646: movl gnvhe,r10 # load pointer to end of hash chain ! 18647: movl r7,4*vrnxt(r10) # add new block to end of chain ! 18648: movl r8,(r9)+ # set vrlen field, bump ptr ! 18649: movl gnvnw,r6 # get length in words ! 18650: moval 0[r6],r6 # convert to length in bytes ! 18651: tstl r8 # jump if system variable ! 18652: beqlu gnv16 ! 18653: # ! 18654: # HERE FOR NON-SYSTEM VARIABLE -- SET CHARS OF NAME ! 18655: # ! 18656: movl (sp),r10 # point back to string name ! 18657: addl2 $4*schar,r10 # point to chars of name ! 18658: jsb sbmvw # move characters into place ! 18659: movl r7,r9 # restore vrblk pointer ! 18660: jmp gnv06 # jump back to exit ! 18661: # ! 18662: # HERE FOR SYSTEM VARIABLE CASE TO FILL IN FIELDS WHERE ! 18663: # NECESSARY FROM THE FIELDS PRESENT IN THE SVBLK. ! 18664: # ! 18665: gnv16: movl gnvsp,r10 # load pointer to svblk ! 18666: movl r10,(r9) # set svblk ptr in vrblk ! 18667: movl r7,r9 # restore vrblk pointer ! 18668: movl 4*svbit(r10),r7 # load bit indicators ! 18669: addl2 $4*svchs,r10 # point to characters of name ! 18670: addl2 r6,r10 # point past characters ! 18671: # ! 18672: # SKIP PAST KEYWORD NUMBER (SVKNM) IF PRESENT ! 18673: # ! 18674: movl btknm,r8 # load test bit ! 18675: mcoml r7,r11 # and to test ! 18676: bicl2 r11,r8 ! 18677: beqlu gnv17 # jump if no keyword number ! 18678: addl2 $4,r10 # else bump pointer ! 18679: #page ! 18680: # ! 18681: # GTNVR (CONTINUED) ! 18682: # ! 18683: # HERE TEST FOR FUNCTION (SVFNC AND SVNAR) ! 18684: # ! 18685: gnv17: movl btfnc,r8 # get test bit ! 18686: mcoml r7,r11 # and to test ! 18687: bicl2 r11,r8 ! 18688: beqlu gnv18 # skip if no system function ! 18689: movl r10,4*vrfnc(r9) # else point vrfnc to svfnc field ! 18690: addl2 $4*num02,r10 # and bump past svfnc, svnar fields ! 18691: # ! 18692: # NOW TEST FOR LABEL (SVLBL) ! 18693: # ! 18694: gnv18: movl btlbl,r8 # get test bit ! 18695: mcoml r7,r11 # and to test ! 18696: bicl2 r11,r8 ! 18697: beqlu gnv19 # jump if bit is off (no system labl) ! 18698: movl r10,4*vrlbl(r9) # else point vrlbl to svlbl field ! 18699: addl2 $4,r10 # bump past svlbl field ! 18700: # ! 18701: # NOW TEST FOR VALUE (SVVAL) ! 18702: # ! 18703: gnv19: movl btval,r8 # load test bit ! 18704: mcoml r7,r11 # and to test ! 18705: bicl2 r11,r8 ! 18706: bnequ 0f # all done if no value ! 18707: jmp gnv06 ! 18708: 0: ! 18709: movl (r10),4*vrval(r9)# else set initial value ! 18710: movl $b$vre,4*vrsto(r9) # set error store access ! 18711: jmp gnv06 # merge back to exit to caller ! 18712: #enp # end procedure gtnvr ! 18713: #page ! 18714: # ! 18715: # GTPAT -- GET PATTERN ! 18716: # ! 18717: # GTPAT IS PASSED AN OBJECT IN (XR) AND RETURNS A ! 18718: # PATTERN AFTER PERFORMING ANY NECESSARY CONVERSIONS ! 18719: # ! 18720: # (XR) INPUT ARGUMENT ! 18721: # JSR GTPAT CALL TO CONVERT TO PATTERN ! 18722: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 18723: # (XR) RESULTING PATTERN ! 18724: # (WA) DESTROYED ! 18725: # (WB) DESTROYED (ONLY ON CONVERT ERROR) ! 18726: # (XR) UNCHANGED (ONLY ON CONVERT ERROR) ! 18727: # ! 18728: gtpat: #prc # entry point ! 18729: cmpl (r9),$p$aaa # jump if pattern already ! 18730: bgequ gtpt5 ! 18731: # ! 18732: # HERE IF NOT PATTERN, TRY FOR STRING ! 18733: # ! 18734: movl r7,gtpsb # save wb ! 18735: movl r9,-(sp) # stack argument for gtstg ! 18736: jsb gtstg # convert argument to string ! 18737: .long gtpt2 # jump if impossible ! 18738: # ! 18739: # HERE WE HAVE A STRING ! 18740: # ! 18741: tstl r6 # jump if non-null ! 18742: bnequ gtpt1 ! 18743: # ! 18744: # HERE FOR NULL STRING. GENERATE POINTER TO NULL PATTERN. ! 18745: # ! 18746: movl $ndnth,r9 # point to nothen node ! 18747: jmp gtpt4 # jump to exit ! 18748: #page ! 18749: # ! 18750: # GTPAT (CONTINUED) ! 18751: # ! 18752: # HERE FOR NON-NULL STRING ! 18753: # ! 18754: gtpt1: movl $p$str,r7 # load pcode for multi-char string ! 18755: cmpl r6,$num01 # jump if multi-char string ! 18756: bnequ gtpt3 ! 18757: # ! 18758: # HERE FOR ONE CHARACTER STRING, SHARE ONE CHARACTER ANY ! 18759: # ! 18760: movab cfp$f(r9),r9 # point to character ! 18761: movzbl (r9),r6 # load character ! 18762: movl r6,r9 # set as parm1 ! 18763: movl $p$ans,r7 # point to pcode for 1-char any ! 18764: jmp gtpt3 # jump to build node ! 18765: # ! 18766: # HERE IF ARGUMENT IS NOT CONVERTIBLE TO STRING ! 18767: # ! 18768: gtpt2: movl $p$exa,r7 # set pcode for expression in case ! 18769: cmpl (r9),$b$e$$ # jump to build node if expression ! 18770: blequ gtpt3 ! 18771: # ! 18772: # HERE WE HAVE AN ERROR (CONVERSION IMPOSSIBLE) ! 18773: # ! 18774: movl (sp)+,r11 # take convert error exit ! 18775: jmp *(r11)+ ! 18776: # ! 18777: # MERGE HERE TO BUILD NODE FOR STRING OR EXPRESSION ! 18778: # ! 18779: gtpt3: jsb pbild # call routine to build pattern node ! 18780: # ! 18781: # COMMON EXIT AFTER SUCCESSFUL CONVERSION ! 18782: # ! 18783: gtpt4: movl gtpsb,r7 # restore wb ! 18784: # ! 18785: # MERGE HERE TO EXIT OF NO CONVERSION REQUIRED ! 18786: # ! 18787: gtpt5: addl2 $4*1,(sp) # return to gtpat caller ! 18788: rsb ! 18789: #enp # end procedure gtpat ! 18790: #page ! 18791: # ! 18792: # GTREA -- GET REAL VALUE ! 18793: # ! 18794: # GTREA IS PASSED AN OBJECT AND RETURNS A REAL VALUE ! 18795: # PERFORMING ANY NECESSARY CONVERSIONS. ! 18796: # ! 18797: # (XR) OBJECT TO BE CONVERTED ! 18798: # JSR GTREA CALL TO CONVERT OBJECT TO REAL ! 18799: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 18800: # (XR) POINTER TO RESULTING REAL ! 18801: # (WA,WB,WC,RA) DESTROYED ! 18802: # (XR) UNCHANGED (CONVERT ERROR ONLY) ! 18803: # ! 18804: gtrea: #prc # entry point ! 18805: movl (r9),r6 # get first word of block ! 18806: cmpl r6,$b$rcl # jump if real ! 18807: beqlu gtre2 ! 18808: jsb gtnum # else convert argument to numeric ! 18809: .long gtre3 # jump if unconvertible ! 18810: cmpl r6,$b$rcl # jump if real was returned ! 18811: beqlu gtre2 ! 18812: # ! 18813: # HERE FOR CASE OF AN INTEGER TO CONVERT TO REAL ! 18814: # ! 18815: gtre1: movl 4*icval(r9),r5 # load integer ! 18816: cvtlf r5,r2 # convert to real ! 18817: jsb rcbld # build rcblk ! 18818: # ! 18819: # EXIT WITH REAL ! 18820: # ! 18821: gtre2: addl2 $4*1,(sp) # return to gtrea caller ! 18822: rsb ! 18823: # ! 18824: # HERE ON CONVERSION ERROR ! 18825: # ! 18826: gtre3: movl (sp)+,r11 # take convert error exit ! 18827: jmp *(r11)+ ! 18828: #enp # end procedure gtrea ! 18829: #page ! 18830: # ! 18831: # GTSMI -- GET SMALL INTEGER ! 18832: # ! 18833: # GTSMI IS PASSED A SNOBOL OBJECT AND RETURNS AN ADDRESS ! 18834: # INTEGER IN THE RANGE (0 LE N LE DNAMB). SUCH A VALUE CAN ! 18835: # ONLY BE DERIVED FROM AN INTEGER IN THE APPROPRIATE RANGE. ! 18836: # SMALL INTEGERS NEVER APPEAR AS SNOBOL VALUES. HOWEVER, ! 18837: # THEY ARE USED INTERNALLY FOR A VARIETY OF PURPOSES. ! 18838: # ! 18839: # -(XS) ARGUMENT TO CONVERT (ON STACK) ! 18840: # JSR GTSMI CALL TO CONVERT TO SMALL INTEGER ! 18841: # PPM LOC TRANSFER LOC FOR NOT INTEGER ! 18842: # PPM LOC TRANSFER LOC FOR LT 0, GT DNAMB ! 18843: # (XR,WC) RESULTING SMALL INT (TWO COPIES) ! 18844: # (XS) POPPED ! 18845: # (RA) DESTROYED ! 18846: # (WA,WB) DESTROYED (ON CONVERT ERROR ONLY) ! 18847: # (XR) INPUT ARG (CONVERT ERROR ONLY) ! 18848: # ! 18849: .data 1 ! 18850: gtsmi_s: .long 0 ! 18851: .text 0 ! 18852: gtsmi: movl (sp)+,gtsmi_s # entry point ! 18853: movl (sp)+,r9 # load argument ! 18854: cmpl (r9),$b$icl # skip if already an integer ! 18855: beqlu gtsm1 ! 18856: # ! 18857: # HERE IF NOT AN INTEGER ! 18858: # ! 18859: jsb gtint # convert argument to integer ! 18860: .long gtsm2 # jump if convert is impossible ! 18861: # ! 18862: # MERGE HERE WITH INTEGER ! 18863: # ! 18864: gtsm1: movl 4*icval(r9),r5 # load integer value ! 18865: movl r5,r8 # move as one word, jump if ovflow ! 18866: bgeq 0f ! 18867: jmp gtsm3 ! 18868: 0: ! 18869: cmpl r8,mxlen # or if too small ! 18870: bgtru gtsm3 ! 18871: movl r8,r9 # copy result to xr ! 18872: addl3 $4*2,gtsmi_s,r11 # return to gtsmi caller ! 18873: jmp (r11) ! 18874: # ! 18875: # HERE IF UNCONVERTIBLE TO INTEGER ! 18876: # ! 18877: gtsm2: movl gtsmi_s,r11 # take non-integer error exit ! 18878: jmp *(r11)+ ! 18879: # ! 18880: # HERE IF OUT OF RANGE ! 18881: # ! 18882: gtsm3: addl3 $4*1,gtsmi_s,r11 # take out-of-range error exit ! 18883: jmp *(r11)+ ! 18884: #enp # end procedure gtsmi ! 18885: #page ! 18886: # ! 18887: # GTSTG -- GET STRING ! 18888: # ! 18889: # GTSTG IS PASSED AN OBJECT AND RETURNS A STRING WITH ! 18890: # ANY NECESSARY CONVERSIONS PERFORMED. ! 18891: # ! 18892: # -(XS) INPUT ARGUMENT (ON STACK) ! 18893: # JSR GTSTG CALL TO CONVERT TO STRING ! 18894: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE ! 18895: # (XR) POINTER TO RESULTING STRING ! 18896: # (WA) LENGTH OF STRING IN CHARACTERS ! 18897: # (XS) POPPED ! 18898: # (RA) DESTROYED ! 18899: # (XR) INPUT ARG (CONVERT ERROR ONLY) ! 18900: # ! 18901: .data 1 ! 18902: gtstg_s: .long 0 ! 18903: .text 0 ! 18904: gtstg: movl (sp)+,gtstg_s # entry point ! 18905: movl (sp)+,r9 # load argument, pop stack ! 18906: cmpl (r9),$b$scl # jump if already a string ! 18907: bnequ 0f ! 18908: jmp gts30 ! 18909: 0: ! 18910: # ! 18911: # HERE IF NOT A STRING ALREADY ! 18912: # ! 18913: gts01: movl r9,-(sp) # restack argument in case error ! 18914: movl r10,-(sp) # save xl ! 18915: movl r7,gtsvb # save wb ! 18916: movl r8,gtsvc # save wc ! 18917: movl (r9),r6 # load first word of block ! 18918: cmpl r6,$b$icl # jump to convert integer ! 18919: beqlu gts05 ! 18920: cmpl r6,$b$rcl # jump to convert real ! 18921: bnequ 0f ! 18922: jmp gts10 ! 18923: 0: ! 18924: cmpl r6,$b$nml # jump to convert name ! 18925: beqlu gts03 ! 18926: cmpl r6,$b$bct # jump to convert buffer ! 18927: bnequ 0f ! 18928: jmp gts32 ! 18929: 0: ! 18930: # ! 18931: # HERE ON CONVERSION ERROR ! 18932: # ! 18933: gts02: movl (sp)+,r10 # restore xl ! 18934: movl (sp)+,r9 # reload input argument ! 18935: movl gtstg_s,r11 # take convert error exit ! 18936: jmp *(r11)+ ! 18937: #page ! 18938: # ! 18939: # GTSTG (CONTINUED) ! 18940: # ! 18941: # HERE TO CONVERT A NAME (ONLY POSSIBLE IF NATURAL VAR) ! 18942: # ! 18943: gts03: movl 4*nmbas(r9),r10 # load name base ! 18944: cmpl r10,state # error if not natural var (static) ! 18945: bgequ gts02 ! 18946: addl2 $4*vrsof,r10 # else point to possible string name ! 18947: movl 4*sclen(r10),r6 # load length ! 18948: bnequ gts04 # jump if not system variable ! 18949: movl 4*vrsvo(r10),r10# else point to svblk ! 18950: movl 4*svlen(r10),r6 # and load name length ! 18951: # ! 18952: # MERGE HERE WITH STRING IN XR, LENGTH IN WA ! 18953: # ! 18954: gts04: clrl r7 # set offset to zero ! 18955: jsb sbstr # use sbstr to copy string ! 18956: jmp gts29 # jump to exit ! 18957: # ! 18958: # COME HERE TO CONVERT AN INTEGER ! 18959: # ! 18960: gts05: movl 4*icval(r9),r5 # load integer value ! 18961: movl $num01,gtssf # set sign flag negative ! 18962: tstl r5 # skip if integer is negative ! 18963: blss gts06 ! 18964: mnegl r5,r5 # else negate integer ! 18965: clrl gtssf # and reset negative flag ! 18966: #page ! 18967: # ! 18968: # GTSTG (CONTINUED) ! 18969: # ! 18970: # HERE WITH SIGN FLAG SET AND SIGN FORCED NEGATIVE AS ! 18971: # REQUIRED BY THE CVD INSTRUCTION. ! 18972: # ! 18973: gts06: movl gtswk,r9 # point to result work area ! 18974: movl $nstmx,r7 # initialize counter to max length ! 18975: movab cfp$f(r9)[r7],r9# prepare to store (right-left) ! 18976: # ! 18977: # LOOP TO CONVERT DIGITS INTO WORK AREA ! 18978: # ! 18979: gts07: ashq $-32,r4,r4 # convert one digit into wa ! 18980: ediv $10,r4,r5,r6 ! 18981: mnegl r6,r6 ! 18982: bisb2 $0x30,r6 ! 18983: movb r6,-(r9) # store in work area ! 18984: decl r7 # decrement counter ! 18985: tstl r5 # loop if more digits to go ! 18986: bneq gts07 ! 18987: #csc r9 # complete store characters ! 18988: # ! 18989: # MERGE HERE AFTER CONVERTING INTEGER OR REAL INTO WORK ! 18990: # AREA. WB IS SET TO NSTMX - (NUMBER OF CHARS IN RESULT). ! 18991: # ! 18992: gts08: movl $nstmx,r6 # get max number of characters ! 18993: subl2 r7,r6 # compute length of result ! 18994: movl r6,r10 # remember length for move later on ! 18995: addl2 gtssf,r6 # add one for negative sign if needed ! 18996: jsb alocs # allocate string for result ! 18997: movl r9,r8 # save result pointer for the moment ! 18998: movab cfp$f(r9),r9 # point to chars of result block ! 18999: tstl gtssf # skip if positive ! 19000: beqlu gts09 ! 19001: movl $ch$mn,r6 # else load negative sign ! 19002: movb r6,(r9)+ # and store it ! 19003: #csc r9 # complete store characters ! 19004: # ! 19005: # HERE AFTER DEALING WITH SIGN ! 19006: # ! 19007: gts09: movl r10,r6 # recall length to move ! 19008: movl gtswk,r10 # point to result work area ! 19009: movab cfp$f(r10)[r7],r10 # point to first result character ! 19010: jsb sbmvc # move chars to result string ! 19011: movl r8,r9 # restore result pointer ! 19012: jmp gts29 # jump to exit ! 19013: #page ! 19014: # ! 19015: # GTSTG (CONTINUED) ! 19016: # ! 19017: # HERE TO CONVERT A REAL ! 19018: # ! 19019: gts10: movf 4*rcval(r9),r2 # load real ! 19020: clrl gtssf # reset negative flag ! 19021: tstf r2 # skip if zero ! 19022: bneq 0f ! 19023: jmp gts31 ! 19024: 0: ! 19025: tstf r2 # jump if real is positive ! 19026: bgeq gts11 ! 19027: movl $num01,gtssf # else set negative flag ! 19028: mnegf r2,r2 # and get absolute value of real ! 19029: # ! 19030: # NOW SCALE THE REAL TO THE RANGE (0.1 LE X LT 1.0) ! 19031: # ! 19032: gts11: movl intv0,r5 # initialize exponent to zero ! 19033: # ! 19034: # LOOP TO SCALE UP IN STEPS OF 10**10 ! 19035: # ! 19036: gts12: movf r2,gtsrs # save real value ! 19037: subf2 reap1,r2 # subtract 0.1 to compare ! 19038: tstf r2 # jump if scale up not required ! 19039: bgeq gts13 ! 19040: movf gtsrs,r2 # else reload value ! 19041: mulf2 reatt,r2 # multiply by 10**10 ! 19042: subl2 intvt,r5 # decrement exponent by 10 ! 19043: jmp gts12 # loop back to test again ! 19044: # ! 19045: # TEST FOR SCALE DOWN REQUIRED ! 19046: # ! 19047: gts13: movf gtsrs,r2 # reload value ! 19048: subf2 reav1,r2 # subtract 1.0 ! 19049: tstf r2 # jump if no scale down required ! 19050: blss gts17 ! 19051: movf gtsrs,r2 # else reload value ! 19052: # ! 19053: # LOOP TO SCALE DOWN IN STEPS OF 10**10 ! 19054: # ! 19055: gts14: subf2 reatt,r2 # subtract 10**10 to compare ! 19056: tstf r2 # jump if large step not required ! 19057: blss gts15 ! 19058: movf gtsrs,r2 # else restore value ! 19059: divf2 reatt,r2 # divide by 10**10 ! 19060: movf r2,gtsrs # store new value ! 19061: addl2 intvt,r5 # increment exponent by 10 ! 19062: jmp gts14 # loop back ! 19063: #page ! 19064: # ! 19065: # GTSTG (CONTINUED) ! 19066: # ! 19067: # AT THIS POINT WE HAVE (1.0 LE X LT 10**10) ! 19068: # COMPLETE SCALING WITH POWERS OF TEN TABLE ! 19069: # ! 19070: gts15: movl $reav1,r9 # point to powers of ten table ! 19071: # ! 19072: # LOOP TO LOCATE CORRECT ENTRY IN TABLE ! 19073: # ! 19074: gts16: movf gtsrs,r2 # reload value ! 19075: addl2 intv1,r5 # increment exponent ! 19076: addl2 $4*cfp$r,r9 # point to next entry in table ! 19077: subf2 (r9),r2 # subtract it to compare ! 19078: tstf r2 # loop till we find a larger entry ! 19079: bgeq gts16 ! 19080: movf gtsrs,r2 # then reload the value ! 19081: divf2 (r9),r2 # and complete scaling ! 19082: movf r2,gtsrs # store value ! 19083: # ! 19084: # WE ARE NOW SCALED, SO ROUND BY ADDING 0.5 * 10**(-CFP$S) ! 19085: # ! 19086: gts17: movf gtsrs,r2 # get value again ! 19087: addf2 gtsrn,r2 # add rounding factor ! 19088: movf r2,gtsrs # store result ! 19089: # ! 19090: # THE ROUNDING OPERATION MAY HAVE PUSHED US UP PAST ! 19091: # 1.0 AGAIN, SO CHECK ONE MORE TIME. ! 19092: # ! 19093: subf2 reav1,r2 # subtract 1.0 to compare ! 19094: tstf r2 # skip if ok ! 19095: blss gts18 ! 19096: addl2 intv1,r5 # else increment exponent ! 19097: movf gtsrs,r2 # reload value ! 19098: divf2 reavt,r2 # divide by 10.0 to rescale ! 19099: jmp gts19 # jump to merge ! 19100: # ! 19101: # HERE IF ROUNDING DID NOT MUCK UP SCALING ! 19102: # ! 19103: gts18: movf gtsrs,r2 # reload rounded value ! 19104: #page ! 19105: # ! 19106: # GTSTG (CONTINUED) ! 19107: # ! 19108: # NOW WE HAVE COMPLETED THE SCALING AS FOLLOWS ! 19109: # ! 19110: # (IA) SIGNED EXPONENT ! 19111: # (RA) SCALED REAL (ABSOLUTE VALUE) ! 19112: # ! 19113: # IF THE EXPONENT IS NEGATIVE OR GREATER THAN CFP$S, THEN ! 19114: # WE CONVERT THE NUMBER IN THE FORM. ! 19115: # ! 19116: # (NEG SIGN) 0 . (CPF$S DIGITS) E (EXP SIGN) (EXP DIGITS) ! 19117: # ! 19118: # IF THE EXPONENT IS POSITIVE AND LESS THAN OR EQUAL TO ! 19119: # CFP$S, THE NUMBER IS CONVERTED IN THE FORM. ! 19120: # ! 19121: # (NEG SIGN) (EXPONENT DIGITS) . (CFP$S-EXPONENT DIGITS) ! 19122: # ! 19123: # IN BOTH CASES, THE FORMATS OBTAINED FROM THE ABOVE ! 19124: # RULES ARE MODIFIED BY DELETING TRAILING ZEROS AFTER THE ! 19125: # DECIMAL POINT. THERE ARE NO LEADING ZEROS IN THE EXPONENT ! 19126: # AND THE EXPONENT SIGN IS ALWAYS PRESENT. ! 19127: # ! 19128: gts19: movl $cfp$s,r10 # set num dec digits = cfp$s ! 19129: movl $ch$mn,gtses # set exponent sign negative ! 19130: tstl r5 # all set if exponent is negative ! 19131: blss gts21 ! 19132: movl r5,r6 # else fetch exponent ! 19133: cmpl r6,$cfp$s # skip if we can use special format ! 19134: blequ gts20 ! 19135: movl r6,r5 # else restore exponent ! 19136: mnegl r5,r5 # set negative for cvd ! 19137: movl $ch$pl,gtses # set plus sign for exponent sign ! 19138: jmp gts21 # jump to generate exponent ! 19139: # ! 19140: # HERE IF WE CAN USE THE FORMAT WITHOUT AN EXPONENT ! 19141: # ! 19142: gts20: subl2 r6,r10 # compute digits after decimal point ! 19143: movl intv0,r5 # reset exponent to zero ! 19144: #page ! 19145: # ! 19146: # GTSTG (CONTINUED) ! 19147: # ! 19148: # MERGE HERE AS FOLLOWS ! 19149: # ! 19150: # (IA) EXPONENT ABSOLUTE VALUE ! 19151: # GTSES CHARACTER FOR EXPONENT SIGN ! 19152: # (RA) POSITIVE FRACTION ! 19153: # (XL) NUMBER OF DIGITS AFTER DEC POINT ! 19154: # ! 19155: gts21: movl gtswk,r9 # point to work area ! 19156: movl $nstmx,r7 # set character ctr to max length ! 19157: movab cfp$f(r9)[r7],r9# prepare to store (right to left) ! 19158: tstl r5 # skip exponent if it is zero ! 19159: beql gts23 ! 19160: # ! 19161: # LOOP TO GENERATE DIGITS OF EXPONENT ! 19162: # ! 19163: gts22: ashq $-32,r4,r4 # convert a digit into wa ! 19164: ediv $10,r4,r5,r6 ! 19165: mnegl r6,r6 ! 19166: bisb2 $0x30,r6 ! 19167: movb r6,-(r9) # store in work area ! 19168: decl r7 # decrement counter ! 19169: tstl r5 # loop back if more digits to go ! 19170: bneq gts22 ! 19171: # ! 19172: # HERE GENERATE EXPONENT SIGN AND E ! 19173: # ! 19174: movl gtses,r6 # load exponent sign ! 19175: movb r6,-(r9) # store in work area ! 19176: movl $ch$le,r6 # get character letter e ! 19177: movb r6,-(r9) # store in work area ! 19178: subl2 $num02,r7 # decrement counter for sign and e ! 19179: # ! 19180: # HERE TO GENERATE THE FRACTION ! 19181: # ! 19182: gts23: mulf2 gtssc,r2 # convert real to integer (10**cfp$s) ! 19183: cvtfl r2,r5 # get integer (overflow impossible) ! 19184: mnegl r5,r5 # negate as required by cvd ! 19185: # ! 19186: # LOOP TO SUPPRESS TRAILING ZEROS ! 19187: # ! 19188: gts24: tstl r10 # jump if no digits left to do ! 19189: beqlu gts27 ! 19190: ashq $-32,r4,r4 # else convert one digit ! 19191: ediv $10,r4,r5,r6 ! 19192: mnegl r6,r6 ! 19193: bisb2 $0x30,r6 ! 19194: cmpl r6,$ch$d0 # jump if not a zero ! 19195: bnequ gts26 ! 19196: decl r10 # decrement counter ! 19197: jmp gts24 # loop back for next digit ! 19198: #page ! 19199: # ! 19200: # GTSTG (CONTINUED) ! 19201: # ! 19202: # LOOP TO GENERATE DIGITS AFTER DECIMAL POINT ! 19203: # ! 19204: gts25: ashq $-32,r4,r4 # convert a digit into wa ! 19205: ediv $10,r4,r5,r6 ! 19206: mnegl r6,r6 ! 19207: bisb2 $0x30,r6 ! 19208: # ! 19209: # MERGE HERE FIRST TIME ! 19210: # ! 19211: gts26: movb r6,-(r9) # store digit ! 19212: decl r7 # decrement counter ! 19213: decl r10 # decrement counter ! 19214: bnequ gts25 # loop back if more to go ! 19215: # ! 19216: # HERE GENERATE THE DECIMAL POINT ! 19217: # ! 19218: gts27: movl $ch$dt,r6 # load decimal point ! 19219: movb r6,-(r9) # store in work area ! 19220: decl r7 # decrement counter ! 19221: # ! 19222: # HERE GENERATE THE DIGITS BEFORE THE DECIMAL POINT ! 19223: # ! 19224: gts28: ashq $-32,r4,r4 # convert a digit into wa ! 19225: ediv $10,r4,r5,r6 ! 19226: mnegl r6,r6 ! 19227: bisb2 $0x30,r6 ! 19228: movb r6,-(r9) # store in work area ! 19229: decl r7 # decrement counter ! 19230: tstl r5 # loop back if more to go ! 19231: bneq gts28 ! 19232: #csc r9 # complete store characters ! 19233: jmp gts08 # else jump back to exit ! 19234: # ! 19235: # EXIT POINT AFTER SUCCESSFUL CONVERSION ! 19236: # ! 19237: gts29: movl (sp)+,r10 # restore xl ! 19238: addl2 $4,sp # pop argument ! 19239: movl gtsvb,r7 # restore wb ! 19240: movl gtsvc,r8 # restore wc ! 19241: # ! 19242: # MERGE HERE IF NO CONVERSION REQUIRED ! 19243: # ! 19244: gts30: movl 4*sclen(r9),r6 # load string length ! 19245: addl3 $4*1,gtstg_s,r11 # return to caller ! 19246: jmp (r11) ! 19247: # ! 19248: # HERE TO RETURN STRING FOR REAL ZERO ! 19249: # ! 19250: gts31: movl $scre0,r10 # point to string ! 19251: movl $num02,r6 # 2 chars ! 19252: clrl r7 # zero offset ! 19253: jsb sbstr # copy string ! 19254: jmp gts29 # return ! 19255: #page ! 19256: # ! 19257: # HERE TO CONVERT A BUFFER BLOCK ! 19258: # ! 19259: gts32: movl r9,r10 # copy arg ptr ! 19260: movl 4*bclen(r10),r6 # get size to allocate ! 19261: beqlu gts33 # if null then return null ! 19262: jsb alocs # allocate string frame ! 19263: movl r9,r7 # save string ptr ! 19264: movl 4*sclen(r9),r6 # get length to move ! 19265: movab 3+(4*0)(r6),r6 # get as multiple of word size ! 19266: bicl2 $3,r6 ! 19267: movl 4*bcbuf(r10),r10# point to bfblk ! 19268: addl2 $4*scsi$,r9 # point to start of character area ! 19269: addl2 $4*bfsi$,r10 # point to start of buffer chars ! 19270: jsb sbmvw # copy words ! 19271: movl r7,r9 # restore scblk ptr ! 19272: jmp gts29 # exit with scblk ! 19273: # ! 19274: # HERE WHEN NULL BUFFER IS BEING CONVERTED ! 19275: # ! 19276: gts33: movl $nulls,r9 # point to null ! 19277: jmp gts29 # exit with null ! 19278: #enp # end procedure gtstg ! 19279: #page ! 19280: # ! 19281: # GTVAR -- GET VARIABLE FOR I/O/TRACE ASSOCIATION ! 19282: # ! 19283: # GTVAR IS USED TO POINT TO AN ACTUAL VARIABLE LOCATION ! 19284: # FOR THE DETACH,INPUT,OUTPUT,TRACE,STOPTR SYSTEM FUNCTIONS ! 19285: # ! 19286: # (XR) ARGUMENT TO FUNCTION ! 19287: # JSR GTVAR CALL TO LOCATE VARIABLE POINTER ! 19288: # PPM LOC TRANSFER LOC IF NOT OK VARIABLE ! 19289: # (XL,WA) NAME BASE,OFFSET OF VARIABLE ! 19290: # (XR,RA) DESTROYED ! 19291: # (WB,WC) DESTROYED (CONVERT ERROR ONLY) ! 19292: # (XR) INPUT ARG (CONVERT ERROR ONLY) ! 19293: # ! 19294: gtvar: #prc # entry point ! 19295: cmpl (r9),$b$nml # jump if not a name ! 19296: bnequ gtvr2 ! 19297: movl 4*nmofs(r9),r6 # else load name offset ! 19298: movl 4*nmbas(r9),r10 # load name base ! 19299: cmpl (r10),$b$evt # error if expression variable ! 19300: beqlu gtvr1 ! 19301: cmpl (r10),$b$kvt # all ok if not keyword variable ! 19302: bnequ gtvr3 ! 19303: # ! 19304: # HERE ON CONVERSION ERROR ! 19305: # ! 19306: gtvr1: movl (sp)+,r11 # take convert error exit ! 19307: jmp *(r11)+ ! 19308: # ! 19309: # HERE IF NOT A NAME, TRY CONVERT TO NATURAL VARIABLE ! 19310: # ! 19311: gtvr2: movl r8,gtvrc # save wc ! 19312: jsb gtnvr # locate vrblk if possible ! 19313: .long gtvr1 # jump if convert error ! 19314: movl r9,r10 # else copy vrblk name base ! 19315: movl $4*vrval,r6 # and set offset ! 19316: movl gtvrc,r8 # restore wc ! 19317: # ! 19318: # HERE FOR NAME OBTAINED ! 19319: # ! 19320: gtvr3: cmpl r10,state # all ok if not natural variable ! 19321: bgequ gtvr4 ! 19322: cmpl 4*vrsto(r10),$b$vre # error if protected variable ! 19323: beqlu gtvr1 ! 19324: # ! 19325: # COMMON EXIT POINT ! 19326: # ! 19327: gtvr4: addl2 $4*1,(sp) # return to caller ! 19328: rsb ! 19329: #enp # end procedure gtvar ! 19330: #page ! 19331: # ! 19332: # HASHS -- COMPUTE HASH INDEX FOR STRING ! 19333: # ! 19334: # HASHS IS USED TO CONVERT A STRING TO A UNIQUE INTEGER ! 19335: # VALUE. THE RESULTING HASH VALUE IS A POSITIVE INTEGER ! 19336: # IN THE RANGE 0 TO CFP$M ! 19337: # ! 19338: # (XR) STRING TO BE HASHED ! 19339: # JSR HASHS CALL TO HASH STRING ! 19340: # (IA) HASH VALUE ! 19341: # (XR,WB,WC) DESTROYED ! 19342: # ! 19343: # THE HASH FUNCTION USED IS AS FOLLOWS. ! 19344: # ! 19345: # START WITH THE LENGTH OF THE STRING (SGD07) ! 19346: # ! 19347: # TAKE THE FIRST E$HNW WORDS OF THE CHARACTERS FROM ! 19348: # THE STRING OR ALL THE WORDS IF FEWER THAN E$HNW. ! 19349: # ! 19350: # COMPUTE THE EXCLUSIVE OR OF ALL THESE WORDS TREATING ! 19351: # THEM AS ONE WORD BIT STRING VALUES. ! 19352: # ! 19353: # MOVE THE RESULT AS AN INTEGER WITH THE MTI INSTRUCTION. ! 19354: # ! 19355: hashs: #prc # entry point ! 19356: movl 4*sclen(r9),r8 # load string length in characters ! 19357: movl r8,r7 # initialize with length ! 19358: tstl r8 # jump if null string ! 19359: beqlu hshs3 ! 19360: movab 3+(4*0)(r8),r8 # else get number of words of chars ! 19361: ashl $-2,r8,r8 ! 19362: addl2 $4*schar,r9 # point to characters of string ! 19363: cmpl r8,$e$hnw # use whole string if short ! 19364: blequ hshs1 ! 19365: movl $e$hnw,r8 # else set to involve first e$hnw wds ! 19366: # ! 19367: # HERE WITH COUNT OF WORDS TO CHECK IN WC ! 19368: # ! 19369: hshs1: # set counter to control loop ! 19370: # ! 19371: # LOOP TO COMPUTE EXCLUSIVE OR ! 19372: # ! 19373: hshs2: xorl2 (r9)+,r7 # exclusive or next word of chars ! 19374: sobgtr r8,hshs2 # loop till all processed ! 19375: # ! 19376: # MERGE HERE WITH EXCLUSIVE OR IN WB ! 19377: # ! 19378: hshs3: #zgb r7 # zeroise undefined bits ! 19379: mcoml bitsm,r11 # ensure in range 0 to cfp$m ! 19380: bicl2 r11,r7 ! 19381: movl r7,r5 # move result as integer ! 19382: clrl r9 # clear garbage value in xr ! 19383: rsb # return to hashs caller ! 19384: #enp # end procedure hashs ! 19385: #page ! 19386: # ! 19387: # ICBLD -- BUILD INTEGER BLOCK ! 19388: # ! 19389: # (IA) INTEGER VALUE FOR ICBLK ! 19390: # JSR ICBLD CALL TO BUILD INTEGER BLOCK ! 19391: # (XR) POINTER TO RESULT ICBLK ! 19392: # (WA) DESTROYED ! 19393: # ! 19394: icbld: #prc # entry point ! 19395: movl r5,r9 # copy small integers ! 19396: bgeq 0f ! 19397: jmp icbl1 ! 19398: 0: ! 19399: cmpl r9,$num02 # jump if 0,1 or 2 ! 19400: blequ icbl3 ! 19401: # ! 19402: # CONSTRUCT ICBLK ! 19403: # ! 19404: icbl1: movl dnamp,r9 # load pointer to next available loc ! 19405: addl2 $4*icsi$,r9 # point past new icblk ! 19406: cmpl r9,dname # jump if there is room ! 19407: blequ icbl2 ! 19408: movl $4*icsi$,r6 # else load length of icblk ! 19409: jsb alloc # use standard allocator to get block ! 19410: addl2 r6,r9 # point past block to merge ! 19411: # ! 19412: # MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED ! 19413: # ! 19414: icbl2: movl r9,dnamp # set new pointer ! 19415: subl2 $4*icsi$,r9 # point back to start of block ! 19416: movl $b$icl,(r9) # store type word ! 19417: movl r5,4*icval(r9) # store integer value in icblk ! 19418: rsb # return to icbld caller ! 19419: # ! 19420: # OPTIMISE BY NOT BUILDING ICBLKS FOR SMALL INTEGERS ! 19421: # ! 19422: icbl3: moval 0[r9],r9 # convert integer to offset ! 19423: movl l^intab(r9),r9 # point to pre-built icblk ! 19424: rsb # return ! 19425: #enp # end procedure icbld ! 19426: #page ! 19427: # ! 19428: # IDENT -- COMPARE TWO VALUES ! 19429: # ! 19430: # IDENT COMPARES TWO VALUES IN THE SENSE OF THE IDENT ! 19431: # DIFFER FUNCTIONS AVAILABLE AT THE SNOBOL LEVEL. ! 19432: # ! 19433: # (XR) FIRST ARGUMENT ! 19434: # (XL) SECOND ARGUMENT ! 19435: # JSR IDENT CALL TO COMPARE ARGUMENTS ! 19436: # PPM LOC TRANSFER LOC IF IDENT ! 19437: # (NORMAL RETURN IF DIFFER) ! 19438: # (XR,XL,WC,RA) DESTROYED ! 19439: # ! 19440: ident: #prc # entry point ! 19441: cmpl r9,r10 # jump if same pointer (ident) ! 19442: bnequ 0f ! 19443: jmp iden7 ! 19444: 0: ! 19445: movl (r9),r8 # else load arg 1 type word ! 19446: cmpl r8,(r10) # differ if arg 2 type word differ ! 19447: bnequ iden1 ! 19448: cmpl r8,$b$scl # jump if strings ! 19449: beqlu iden2 ! 19450: cmpl r8,$b$icl # jump if integers ! 19451: beqlu iden4 ! 19452: cmpl r8,$b$rcl # jump if reals ! 19453: beqlu iden5 ! 19454: cmpl r8,$b$nml # jump if names ! 19455: beqlu iden6 ! 19456: # ! 19457: # FOR ALL OTHER DATATYPES, MUST BE DIFFER IF XR NE XL ! 19458: # ! 19459: # MERGE HERE FOR DIFFER ! 19460: # ! 19461: iden1: addl2 $4*1,(sp) # take differ exit ! 19462: rsb ! 19463: # ! 19464: # HERE FOR STRINGS, IDENT ONLY IF LENGTHS AND CHARS SAME ! 19465: # ! 19466: iden2: movl 4*sclen(r9),r8 # load arg 1 length ! 19467: cmpl r8,4*sclen(r10) # differ if lengths differ ! 19468: bnequ iden1 ! 19469: movab 3+(4*0)(r8),r8 # get number of words in strings ! 19470: ashl $-2,r8,r8 ! 19471: addl2 $4*schar,r9 # point to chars of arg 1 ! 19472: addl2 $4*schar,r10 # point to chars of arg 2 ! 19473: # set loop counter ! 19474: # ! 19475: # LOOP TO COMPARE CHARACTERS. NOTE THAT WA CANNOT BE ZERO ! 19476: # SINCE ALL NULL STRINGS POINT TO NULLS AND GIVE XL=XR. ! 19477: # ! 19478: iden3: cmpl (r9),(r10) # differ if chars do not match ! 19479: bnequ iden8 ! 19480: addl2 $4,r9 # else bump arg one pointer ! 19481: addl2 $4,r10 # bump arg two pointer ! 19482: sobgtr r8,iden3 # loop back till all checked ! 19483: #page ! 19484: # ! 19485: # IDENT (CONTINUED) ! 19486: # ! 19487: # HERE TO EXIT FOR CASE OF TWO IDENT STRINGS ! 19488: # ! 19489: clrl r10 # clear garbage value in xl ! 19490: clrl r9 # clear garbage value in xr ! 19491: movl (sp)+,r11 # take ident exit ! 19492: jmp *(r11)+ ! 19493: # ! 19494: # HERE FOR INTEGERS, IDENT IF SAME VALUES ! 19495: # ! 19496: iden4: movl 4*icval(r9),r5 # load arg 1 ! 19497: subl2 4*icval(r10),r5 # subtract arg 2 to compare ! 19498: bvs iden1 ! 19499: tstl r5 # differ if result is not zero ! 19500: bneq iden1 ! 19501: movl (sp)+,r11 # take ident exit ! 19502: jmp *(r11)+ ! 19503: # ! 19504: # HERE FOR REALS, IDENT IF SAME VALUES ! 19505: # ! 19506: iden5: movf 4*rcval(r9),r2 # load arg 1 ! 19507: subf2 4*rcval(r10),r2 # subtract arg 2 to compare ! 19508: bvs iden1 ! 19509: tstf r2 # differ if result is not zero ! 19510: bneq iden1 ! 19511: movl (sp)+,r11 # take ident exit ! 19512: jmp *(r11)+ ! 19513: # ! 19514: # HERE FOR NAMES, IDENT IF BASES AND OFFSETS SAME ! 19515: # ! 19516: iden6: cmpl 4*nmofs(r9),4*nmofs(r10) # differ if different offset ! 19517: bnequ iden1 ! 19518: cmpl 4*nmbas(r9),4*nmbas(r10) # differ if different base ! 19519: bnequ iden1 ! 19520: # ! 19521: # MERGE HERE TO SIGNAL IDENT FOR IDENTICAL POINTERS ! 19522: # ! 19523: iden7: movl (sp)+,r11 # take ident exit ! 19524: jmp *(r11)+ ! 19525: # ! 19526: # HERE FOR DIFFER STRINGS ! 19527: # ! 19528: iden8: clrl r9 # clear garbage ptr in xr ! 19529: clrl r10 # clear garbage ptr in xl ! 19530: addl2 $4*1,(sp) # return to caller (differ) ! 19531: rsb ! 19532: #enp # end procedure ident ! 19533: #page ! 19534: # ! 19535: # INOUT - USED TO INITIALISE INPUT AND OUTPUT VARIABLES ! 19536: # ! 19537: # (XL) POINTER TO VBL NAME STRING ! 19538: # (WB) TRBLK TYPE ! 19539: # JSR INOUT CALL TO PERFORM INITIALISATION ! 19540: # (XL) VRBLK PTR ! 19541: # (XR) TRBLK PTR ! 19542: # (WA,WC) DESTROYED ! 19543: # ! 19544: # NOTE THAT TRTER (= TRTRF) FIELD OF STANDARD I/O VARIABLES ! 19545: # POINTS TO CORRESPONDING SVBLK NOT TO A TRBLK AS IS THE ! 19546: # CASE FOR ORDINARY VARIABLES. ! 19547: # ! 19548: inout: #prc # entry point ! 19549: movl r7,-(sp) # stack trblk type ! 19550: movl 4*sclen(r10),r6 # get name length ! 19551: clrl r7 # point to start of name ! 19552: jsb sbstr # build a proper scblk ! 19553: jsb gtnvr # build vrblk ! 19554: .long invalid$ # no error return ! 19555: movl r9,r8 # save vrblk pointer ! 19556: movl (sp)+,r7 # get trter field ! 19557: clrl r10 # zero trfpt ! 19558: jsb trbld # build trblk ! 19559: movl r8,r10 # recall vrblk pointer ! 19560: movl 4*vrsvp(r10),4*trter(r9) # store svblk pointer ! 19561: movl r9,4*vrval(r10) # store trblk ptr in vrblk ! 19562: movl $b$vra,4*vrget(r10) # set trapped access ! 19563: movl $b$vrv,4*vrsto(r10) # set trapped store ! 19564: rsb # return to caller ! 19565: #enp # end procedure inout ! 19566: #page ! 19567: # ! 19568: # INSBF -- INSERT STRING IN BUFFER ! 19569: # ! 19570: # THIS ROUTINE WILL REPLACE A SECTION OF A BUFFER WITH THE ! 19571: # CONTENTS OF A GIVEN STRING. IF THE LENGTH OF THE ! 19572: # SECTION TO BE REPLACED IS DIFFERENT THAN THE LENGTH OF ! 19573: # THE GIVEN STRING, AND THE REPLACEMENT IS NOT AN APPEND, ! 19574: # THEN THE UPPER SECTION OF THE BUFFER IS SHIFTED UP OR ! 19575: # DOWN TO CREATE THE PROPER SPACE FOR THE INSERT. ! 19576: # ! 19577: # (XR) POINTER TO BFBLK ! 19578: # (XL) OBJECT WHICH IS STRING CONVERTABLE ! 19579: # (WA) OFFSET OF START OF INSERT IN (XR) ! 19580: # (WB) LENGTH OF SECTION IN (XR) REPLACED ! 19581: # JSR INSBF CALL TO INSERT CHARACTERS IN BUFFER ! 19582: # PPM LOC THREAD IF (XR) NOT CONVERTABLE ! 19583: # PPM LOC THREAD IF INSERT NOT POSSIBLE ! 19584: # ! 19585: # THE SECOND ALTERNATE EXIT IS TAKEN IF THE INSERT WOULD ! 19586: # OVERFLOW THE BUFFER, OR IF THE INSERT IS OUT PAST THE ! 19587: # DEFINED END OF THE BUFFER AS GIVEN. ! 19588: # ! 19589: insbf: #prc # entry point ! 19590: movl r6,inssa # save entry wa ! 19591: movl r7,inssb # save entry wb ! 19592: movl r8,inssc # save entry wc ! 19593: addl2 r7,r6 # add to get offset past replace part ! 19594: movl r6,insab # save wa+wb ! 19595: movl 4*bclen(r9),r8 # get current defined length ! 19596: cmpl inssa,r8 # fail if start offset too big ! 19597: blequ 0f ! 19598: jmp ins07 ! 19599: 0: ! 19600: cmpl r6,r8 # fail if final offset too big ! 19601: blequ 0f ! 19602: jmp ins07 ! 19603: 0: ! 19604: movl r10,-(sp) # save entry xl ! 19605: movl r9,-(sp) # save bcblk ptr ! 19606: movl r10,-(sp) # stack again for gtstg ! 19607: jsb gtstg # call to convert to string ! 19608: .long ins05 # take string convert err exit ! 19609: movl r9,r10 # save string ptr ! 19610: movl (sp),r9 # restore bcblk ptr ! 19611: addl2 r8,r6 # add buffer len to string len ! 19612: subl2 inssb,r6 # bias out component being replaced ! 19613: movl 4*bcbuf(r9),r9 # point to bfblk ! 19614: cmpl r6,4*bfalc(r9) # fail if result exceeds allocation ! 19615: blequ 0f ! 19616: jmp ins06 ! 19617: 0: ! 19618: movl (sp),r9 # restore bcblk ptr ! 19619: movl r8,r6 # get buffer length ! 19620: subl2 insab,r6 # subtract to get shift length ! 19621: addl2 4*sclen(r10),r8 # add length of new ! 19622: subl2 inssb,r8 # subtract old to get total new len ! 19623: movl 4*bclen(r9),r7 # get old bclen ! 19624: movl r8,4*bclen(r9) # stuff new length ! 19625: tstl r6 # skip shift if nothing to do ! 19626: bnequ 0f ! 19627: jmp ins04 ! 19628: 0: ! 19629: cmpl inssb,4*sclen(r10) # skip shift if lengths match ! 19630: bnequ 0f ! 19631: jmp ins04 ! 19632: 0: ! 19633: movl 4*bcbuf(r9),r9 # point to bfblk ! 19634: movl r10,-(sp) # save scblk ptr ! 19635: cmpl inssb,4*sclen(r10) # brn if shft is for more room ! 19636: blequ ins01 ! 19637: #page ! 19638: # ! 19639: # INSBF (CONTINUED) ! 19640: # ! 19641: # WE ARE SHIFTING THE UPPER SEGMENT DOWN TO COMPACT ! 19642: # THE BUFFER. (THE STRING LENGTH IS SMALLER THAN THE ! 19643: # SEGMENT BEING REPLACED.) REGISTERS ARE SET AS: ! 19644: # ! 19645: # (WA) MOVE (SHIFT DOWN) LENGTH ! 19646: # (WB) OLD BCLEN ! 19647: # (WC) NEW BCLEN ! 19648: # (XR) BFBLK PTR ! 19649: # (XL),(XS) SCBLK PTR ! 19650: # ! 19651: movl inssa,r7 # get offset to insert ! 19652: addl2 4*sclen(r10),r7 # add insert length to get dest off ! 19653: movl r9,r10 # make copy ! 19654: movl insab,r11 # [get in scratch register] ! 19655: movab cfp$f(r10)[r11],r10 # prepare source for move ! 19656: movab cfp$f(r9)[r7],r9# prepare destination reg for move ! 19657: jsb sbmvc # move em out ! 19658: jmp ins02 # branch to pad ! 19659: # ! 19660: # WE ARE SHIFTING THE UPPER SEGMENT UP TO EXPAND ! 19661: # THE BUFFER. (THE STRING LENGTH IS LARGER THAN THE ! 19662: # SEGMENT BEING REPLACED.) ! 19663: # ! 19664: ins01: movl r9,r10 # copy bfblk ptr ! 19665: movab cfp$f(r10)[r7],r10 # set source reg for move backwards ! 19666: movab cfp$f(r9)[r8],r9# set destination ptr for move ! 19667: jsb sbmcb # move backwards (possible overlap) ! 19668: # ! 19669: # MERGE HERE AFTER MOVE TO ADJUST PADDING AT NEW BUFFER END ! 19670: # ! 19671: ins02: movl (sp)+,r10 # restore scblk ptr ! 19672: movl r8,r6 # copy new buffer end ! 19673: movab 3+(4*0)(r6),r6 # round out ! 19674: bicl2 $3,r6 ! 19675: subl2 r8,r6 # subtract to get remainder ! 19676: bnequ 0f # no pad if already even boundary ! 19677: jmp ins04 ! 19678: 0: ! 19679: movl (sp),r9 # get bcblk ptr ! 19680: movl 4*bcbuf(r9),r9 # get bfblk ptr ! 19681: movab cfp$f(r9)[r8],r9# prepare to pad ! 19682: clrl r7 # clear wb ! 19683: # load loop count ! 19684: # ! 19685: # LOOP HERE TO STUFF PAD CHARACTERS ! 19686: # ! 19687: ins03: movb r7,(r9)+ # stuff zero pad ! 19688: sobgtr r6,ins03 # branch for more ! 19689: #page ! 19690: # ! 19691: # INSBF (CONTINUED) ! 19692: # ! 19693: # MERGE HERE WHEN PADDING OK. NOW COPY IN THE INSERT ! 19694: # STRING TO THE HOLE. ! 19695: # ! 19696: ins04: movl (sp),r9 # get bcblk ptr ! 19697: movl 4*bcbuf(r9),r9 # get bfblk ptr ! 19698: movl 4*sclen(r10),r6 # get move length ! 19699: movab cfp$f(r10),r10 # prepare to copy from first char ! 19700: movl inssa,r11 # [get in scratch register] ! 19701: movab cfp$f(r9)[r11],r9# prepare to store in hole ! 19702: jsb sbmvc # copy the characters ! 19703: movl (sp)+,r9 # restore entry xr ! 19704: movl (sp)+,r10 # restore entry xl ! 19705: movl inssa,r6 # restore entry wa ! 19706: movl inssb,r7 # restore entry wb ! 19707: movl inssc,r8 # restore entry wc ! 19708: addl2 $4*2,(sp) # return to caller ! 19709: rsb ! 19710: # ! 19711: # HERE TO TAKE STRING CONVERT ERROR EXIT ! 19712: # ! 19713: ins05: movl (sp)+,r9 # restore entry xr ! 19714: movl (sp)+,r10 # restore entry xl ! 19715: movl inssa,r6 # restore entry wa ! 19716: movl inssb,r7 # restore entry wb ! 19717: movl inssc,r8 # restore entry wc ! 19718: movl (sp)+,r11 # alternate exit ! 19719: jmp *(r11)+ ! 19720: # ! 19721: # HERE FOR INVALID OFFSET OR LENGTH ! 19722: # ! 19723: ins06: movl (sp)+,r9 # restore entry xr ! 19724: movl (sp)+,r10 # restore entry xl ! 19725: # ! 19726: # MERGE FOR LENGTH FAILURE EXIT WITH STACK SET ! 19727: # ! 19728: ins07: movl inssa,r6 # restore entry wa ! 19729: movl inssb,r7 # restore entry wb ! 19730: movl inssc,r8 # restore entry wc ! 19731: addl3 $4*1,(sp)+,r11 # alternate exit ! 19732: jmp *(r11)+ ! 19733: #enp # end procedure insbf ! 19734: #page ! 19735: # ! 19736: # IOFCB -- GET INPUT/OUTPUT FCBLK POINTER ! 19737: # ! 19738: # USED BY ENDFILE, EJECT AND REWIND TO FIND THE FCBLK ! 19739: # (IF ANY) CORRESPONDING TO THEIR ARGUMENT. ! 19740: # ! 19741: # -(XS) ARGUMENT ! 19742: # JSR IOFCB CALL TO FIND FCBLK ! 19743: # PPM LOC ARG IS AN UNSUITABLE NAME ! 19744: # PPM LOC ARG IS NULL STRING ! 19745: # (XS) POPPED ! 19746: # (XL) PTR TO FILEARG1 VRBLK ! 19747: # (XR) ARGUMENT ! 19748: # (WA) FCBLK PTR OR 0 ! 19749: # (WB) DESTROYED ! 19750: # ! 19751: .data 1 ! 19752: iofcb_s: .long 0 ! 19753: .text 0 ! 19754: iofcb: movl (sp)+,iofcb_s # entry point ! 19755: jsb gtstg # get arg as string ! 19756: .long iofc2 # fail ! 19757: movl r9,r10 # copy string ptr ! 19758: jsb gtnvr # get as natural variable ! 19759: .long iofc3 # fail if null ! 19760: movl r10,r7 # copy string pointer again ! 19761: movl r9,r10 # copy vrblk ptr for return ! 19762: clrl r6 # in case no trblk found ! 19763: # ! 19764: # LOOP TO FIND FILE ARG1 TRBLK ! 19765: # ! 19766: iofc1: movl 4*vrval(r9),r9 # get possible trblk ptr ! 19767: cmpl (r9),$b$trt # fail if end of chain ! 19768: bnequ iofc2 ! 19769: cmpl 4*trtyp(r9),$trtfc # loop if not file arg trblk ! 19770: bnequ iofc1 ! 19771: movl 4*trfpt(r9),r6 # get fcblk ptr ! 19772: movl r7,r9 # copy arg ! 19773: addl3 $4*2,iofcb_s,r11 # return ! 19774: jmp (r11) ! 19775: # ! 19776: # FAIL RETURN ! 19777: # ! 19778: iofc2: movl iofcb_s,r11 # fail ! 19779: jmp *(r11)+ ! 19780: # ! 19781: # NULL ARG ! 19782: # ! 19783: iofc3: addl3 $4*1,iofcb_s,r11 # null arg return ! 19784: jmp *(r11)+ ! 19785: #enp # end procedure iofcb ! 19786: #page ! 19787: # ! 19788: # IOPPF -- PROCESS FILEARG2 FOR IOPUT ! 19789: # ! 19790: # (R$XSC) FILEARG2 PTR ! 19791: # JSR IOPPF CALL TO PROCESS FILEARG2 ! 19792: # (XL) FILEARG1 PTR ! 19793: # (XR) FILE ARG2 PTR ! 19794: # -(XS)..-(XS) FIELDS EXTRACTED FROM FILEARG2 ! 19795: # (WC) NO. OF FIELDS EXTRACTED ! 19796: # (WB) INPUT/OUTPUT FLAG ! 19797: # (WA) FCBLK PTR OR 0 ! 19798: # ! 19799: .data 1 ! 19800: ioppf_s: .long 0 ! 19801: .text 0 ! 19802: ioppf: movl (sp)+,ioppf_s # entry point ! 19803: clrl r7 # to count fields extracted ! 19804: # ! 19805: # LOOP TO EXTRACT FIELDS ! 19806: # ! 19807: iopp1: movl $iodel,r10 # get delimiter ! 19808: movl r10,r8 # copy it ! 19809: jsb xscan # get next field ! 19810: movl r9,-(sp) # stack it ! 19811: incl r7 # increment count ! 19812: tstl r6 # loop ! 19813: bnequ iopp1 ! 19814: movl r7,r8 # count of fields ! 19815: movl ioptt,r7 # i/o marker ! 19816: movl r$iof,r6 # fcblk ptr or 0 ! 19817: movl r$io2,r9 # file arg2 ptr ! 19818: movl r$io1,r10 # filearg1 ! 19819: jmp *ioppf_s # return ! 19820: #enp # end procedure ioppf ! 19821: #page ! 19822: # ! 19823: # IOPUT -- ROUTINE USED BY INPUT AND OUTPUT ! 19824: # ! 19825: # IOPUT SETS UP INPUT/OUTPUT ASSOCIATIONS. IT BUILDS ! 19826: # SUCH TRACE AND FILE CONTROL BLOCKS AS ARE NECESSARY AND ! 19827: # CALLS SYSFC,SYSIO TO PERFORM CHECKS ON THE ! 19828: # ARGUMENTS AND TO OPEN THE FILES. ! 19829: # ! 19830: # +-----------+ +---------------+ +-----------+ ! 19831: # +-.I I I I------.I =B$XRT I ! 19832: # I +-----------+ +---------------+ +-----------+ ! 19833: # I / / (R$FCB) I *4 I ! 19834: # I / / +-----------+ ! 19835: # I +-----------+ +---------------+ I I- ! 19836: # I I NAME +--.I =B$TRT I +-----------+ ! 19837: # I / / +---------------+ I I ! 19838: # I (FIRST ARG) I =TRTIN/=TRTOU I +-----------+ ! 19839: # I +---------------+ I ! 19840: # I I VALUE I I ! 19841: # I +---------------+ I ! 19842: # I I(TRTRF) 0 OR I--+ I ! 19843: # I +---------------+ I I ! 19844: # I I(TRFPT) 0 OR I----+ I ! 19845: # I +---------------+ I I I ! 19846: # I (I/O TRBLK) I I I ! 19847: # I +-----------+ I I I ! 19848: # I I I I I I ! 19849: # I +-----------+ I I I ! 19850: # I I I I I I ! 19851: # I +-----------+ +---------------+ I I I ! 19852: # I I +--.I =B$TRT I.-+ I I ! 19853: # I +-----------+ +---------------+ I I ! 19854: # I / / I =TRTFC I I I ! 19855: # I / / +---------------+ I I ! 19856: # I (FILEARG1 I VALUE I I I ! 19857: # I VRBLK) +---------------+ I I ! 19858: # I I(TRTRF) 0 OR I--+ I . ! 19859: # I +---------------+ I . +-----------+ ! 19860: # I I(TRFPT) 0 OR I------./ FCBLK / ! 19861: # I +---------------+ I +-----------+ ! 19862: # I (TRTRF) I ! 19863: # I I ! 19864: # I I ! 19865: # I +---------------+ I ! 19866: # I I =B$XRT I.-+ ! 19867: # I +---------------+ ! 19868: # I I *5 I ! 19869: # I +---------------+ ! 19870: # +------------------I I ! 19871: # +---------------+ +-----------+ ! 19872: # I(TRTRF) O OR I------.I =B$XRT I ! 19873: # +---------------+ +-----------+ ! 19874: # I NAME OFFSET I I ETC I ! 19875: # +---------------+ ! 19876: # (IOCHN - CHAIN OF NAME POINTERS) ! 19877: #page ! 19878: # ! 19879: # IOPUT (CONTINUED) ! 19880: # ! 19881: # NO ADDITIONAL TRAP BLOCKS ARE USED FOR STANDARD INPUT/OUT ! 19882: # FILES. OTHERWISE AN I/O TRAP BLOCK IS ATTACHED TO SECOND ! 19883: # ARG (FILEARG1) VRBLK. SEE DIAGRAM ABOVE FOR DETAILS OF ! 19884: # THE STRUCTURE BUILT. ! 19885: # ! 19886: # -(XS) 1ST ARG (VBL TO BE ASSOCIATED) ! 19887: # -(XS) 2ND ARG (FILE ARG1) ! 19888: # -(XS) 3RD ARG (FILE ARG2) ! 19889: # (WB) 0 FOR INPUT, 3 FOR OUTPUT ASSOC. ! 19890: # JSR IOPUT CALL FOR INPUT/OUTPUT ASSOCIATION ! 19891: # PPM LOC 3RD ARG NOT A STRING ! 19892: # PPM LOC 2ND ARG NOT A SUITABLE NAME ! 19893: # PPM LOC 1ST ARG NOT A SUITABLE NAME ! 19894: # PPM LOC INAPPROPRIATE FILE SPEC FOR I/O ! 19895: # PPM LOC I/O FILE DOES NOT EXIST ! 19896: # PPM LOC I/O FILE CANNOT BE READ/WRITTEN ! 19897: # (XS) POPPED ! 19898: # (XL,XR,WA,WB,WC) DESTROYED ! 19899: # ! 19900: .data 1 ! 19901: ioput_s: .long 0 ! 19902: .text 0 ! 19903: ioput: movl (sp)+,ioput_s # entry point ! 19904: clrl r$iot # in case no trtrf block used ! 19905: clrl r$iof # in case no fcblk alocated ! 19906: movl r7,ioptt # store i/o trace type ! 19907: jsb xscni # prepare to scan filearg2 ! 19908: .long iop13 # fail ! 19909: .long iopa0 # null file arg2 ! 19910: # ! 19911: iopa0: movl r9,r$io2 # keep file arg2 ! 19912: movl r6,r10 # copy length ! 19913: jsb gtstg # convert filearg1 to string ! 19914: .long iop14 # fail ! 19915: movl r9,r$io1 # keep filearg1 ptr ! 19916: jsb gtnvr # convert to natural variable ! 19917: .long iop00 # jump if null ! 19918: jmp iop04 # jump to process non-null args ! 19919: # ! 19920: # NULL FILEARG1 ! 19921: # ! 19922: iop00: tstl r10 # skip if both args null ! 19923: bnequ 0f ! 19924: jmp iop01 ! 19925: 0: ! 19926: jsb ioppf # process filearg2 ! 19927: jsb sysfc # call for filearg2 check ! 19928: .long iop16 # fail ! 19929: jmp iop11 # complete file association ! 19930: #page ! 19931: # ! 19932: # IOPUT (CONTINUED) ! 19933: # ! 19934: # HERE WITH 0 OR FCBLK PTR IN (XL) ! 19935: # ! 19936: iop01: movl ioptt,r7 # get trace type ! 19937: movl r$iot,r9 # get 0 or trtrf ptr ! 19938: jsb trbld # build trblk ! 19939: movl r9,r8 # copy trblk pointer ! 19940: movl (sp)+,r9 # get variable from stack ! 19941: jsb gtvar # point to variable ! 19942: .long iop15 # fail ! 19943: movl r10,r$ion # save name pointer ! 19944: movl r10,r9 # copy name pointer ! 19945: addl2 r6,r9 # point to variable ! 19946: subl2 $4*vrval,r9 # subtract offset,merge into loop ! 19947: # ! 19948: # LOOP TO END OF TRBLK CHAIN IF ANY ! 19949: # ! 19950: iop02: movl r9,r10 # copy blk ptr ! 19951: movl 4*vrval(r9),r9 # load ptr to next trblk ! 19952: cmpl (r9),$b$trt # jump if not trapped ! 19953: bnequ iop03 ! 19954: cmpl 4*trtyp(r9),ioptt# loop if not same assocn ! 19955: bnequ iop02 ! 19956: movl 4*trnxt(r9),r9 # get value and delete old trblk ! 19957: # ! 19958: # IOPUT (CONTINUED) ! 19959: # ! 19960: # STORE NEW ASSOCIATION ! 19961: # ! 19962: iop03: movl r8,4*vrval(r10) # link to this trblk ! 19963: movl r8,r10 # copy pointer ! 19964: movl r9,4*trnxt(r10) # store value in trblk ! 19965: movl r$ion,r9 # restore possible vrblk pointer ! 19966: movl r6,r7 # keep offset to name ! 19967: jsb setvr # if vrblk, set vrget,vrsto ! 19968: movl r$iot,r9 # get 0 or trtrf ptr ! 19969: beqlu 0f # jump if trtrf block exists ! 19970: jmp iop19 ! 19971: 0: ! 19972: addl3 $4*6,ioput_s,r11 # return to caller ! 19973: jmp (r11) ! 19974: # ! 19975: # NON STANDARD FILE ! 19976: # SEE IF AN FCBLK HAS ALREADY BEEN ALLOCATED. ! 19977: # ! 19978: iop04: clrl r6 # in case no fcblk found ! 19979: #page ! 19980: # ! 19981: # IOPUT (CONTINUED) ! 19982: # ! 19983: # SEARCH POSSIBLE TRBLK CHAIN TO PICK UP THE FCBLK ! 19984: # ! 19985: iop05: movl r9,r7 # remember blk ptr ! 19986: movl 4*vrval(r9),r9 # chain along ! 19987: cmpl (r9),$b$trt # jump if end of trblk chain ! 19988: bnequ iop06 ! 19989: cmpl 4*trtyp(r9),$trtfc # loop if more to go ! 19990: bnequ iop05 ! 19991: movl r9,r$iot # point to file arg1 trblk ! 19992: movl 4*trfpt(r9),r6 # get fcblk ptr from trblk ! 19993: # ! 19994: # WA = 0 OR FCBLK PTR ! 19995: # WB = PTR TO PRECEDING BLK TO WHICH ANY TRTRF BLOCK ! 19996: # FOR FILE ARG1 MUST BE CHAINED. ! 19997: # ! 19998: iop06: movl r6,r$iof # keep possible fcblk ptr ! 19999: movl r7,r$iop # keep preceding blk ptr ! 20000: jsb ioppf # process filearg2 ! 20001: jsb sysfc # see if fcblk required ! 20002: .long iop16 # fail ! 20003: tstl r6 # skip if no new fcblk wanted ! 20004: bnequ 0f ! 20005: jmp iop12 ! 20006: 0: ! 20007: cmpl r8,$num02 # jump if fcblk in dynamic ! 20008: blssu iop6a ! 20009: jsb alost # get it in static ! 20010: jmp iop6b # skip ! 20011: # ! 20012: # OBTAIN FCBLK IN DYNAMIC ! 20013: # ! 20014: iop6a: jsb alloc # get space for fcblk ! 20015: # ! 20016: # MERGE ! 20017: # ! 20018: iop6b: movl r9,r10 # point to fcblk ! 20019: movl r6,r7 # copy its length ! 20020: ashl $-2,r7,r7 # get count as words (sgd apr80) ! 20021: # loop counter ! 20022: # ! 20023: # CLEAR FCBLK ! 20024: # ! 20025: iop07: clrl (r9)+ # clear a word ! 20026: sobgtr r7,iop07 # loop ! 20027: cmpl r8,$num02 # skip if in static - dont set fields ! 20028: bnequ 0f ! 20029: jmp iop09 ! 20030: 0: ! 20031: movl $b$xnt,(r10) # store xnblk code in case ! 20032: movl r6,4*1(r10) # store length ! 20033: tstl r8 # jump if xnblk wanted ! 20034: beqlu 0f ! 20035: jmp iop09 ! 20036: 0: ! 20037: movl $b$xrt,(r10) # xrblk code requested ! 20038: # ! 20039: #page ! 20040: # IOPUT (CONTINUED) ! 20041: # ! 20042: # COMPLETE FCBLK INITIALISATION ! 20043: # ! 20044: iop09: movl r$iot,r9 # get possible trblk ptr ! 20045: movl r10,r$iof # store fcblk ptr ! 20046: tstl r9 # jump if trblk already found ! 20047: bnequ iop10 ! 20048: # ! 20049: # A NEW TRBLK IS NEEDED ! 20050: # ! 20051: movl $trtfc,r7 # trtyp for fcblk trap blk ! 20052: jsb trbld # make the block ! 20053: movl r9,r$iot # copy trtrf ptr ! 20054: movl r$iop,r10 # point to preceding blk ! 20055: movl 4*vrval(r10),4*vrval(r9) # copy value field to trblk ! 20056: movl r9,4*vrval(r10) # link new trblk into chain ! 20057: movl r10,r9 # point to predecessor blk ! 20058: jsb setvr # set trace intercepts ! 20059: movl 4*vrval(r9),r9 # recover trblk ptr ! 20060: # ! 20061: # XR IS PTR TO TRBLK, XL IS FCBLK PTR OR 0 ! 20062: # ! 20063: iop10: movl r$iof,4*trfpt(r9)# store fcblk ptr ! 20064: # ! 20065: # CALL SYSIO TO COMPLETE FILE ACCESSING ! 20066: # ! 20067: iop11: movl r$iof,r6 # copy fcblk ptr or 0 ! 20068: movl ioptt,r7 # get input/output flag ! 20069: movl r$io2,r9 # get file arg2 ! 20070: movl r$io1,r10 # get file arg1 ! 20071: jsb sysio # associate to the file ! 20072: .long iop17 # fail ! 20073: .long iop18 # fail ! 20074: tstl r$iot # not std input if non-null trtrf blk ! 20075: beqlu 0f ! 20076: jmp iop01 ! 20077: 0: ! 20078: tstl ioptt # jump if output ! 20079: beqlu 0f ! 20080: jmp iop01 ! 20081: 0: ! 20082: tstl r8 # no change to standard read length ! 20083: bnequ 0f ! 20084: jmp iop01 ! 20085: 0: ! 20086: movl r8,cswin # store new read length for std file ! 20087: jmp iop01 # merge to finish the task ! 20088: # ! 20089: # SYSFC MAY HAVE RETURNED A POINTER TO A PRIVATE FCBLK ! 20090: # ! 20091: iop12: tstl r10 # jump if private fcblk ! 20092: beqlu 0f ! 20093: jmp iop09 ! 20094: 0: ! 20095: jmp iop11 # finish the association ! 20096: # ! 20097: # FAILURE RETURNS ! 20098: # ! 20099: iop13: movl ioput_s,r11 # 3rd arg not a string ! 20100: jmp *(r11)+ ! 20101: iop14: addl3 $4*1,ioput_s,r11 # 2nd arg unsuitable ! 20102: jmp *(r11)+ ! 20103: iop15: addl3 $4*2,ioput_s,r11 # 1st arg unsuitable ! 20104: jmp *(r11)+ ! 20105: iop16: addl3 $4*3,ioput_s,r11 # file spec wrong ! 20106: jmp *(r11)+ ! 20107: iop17: addl3 $4*4,ioput_s,r11 # i/o file does not exist ! 20108: jmp *(r11)+ ! 20109: iop18: addl3 $4*5,ioput_s,r11 # i/o file cannot be read/written ! 20110: jmp *(r11)+ ! 20111: #page ! 20112: # ! 20113: # IOPUT (CONTINUED) ! 20114: # ! 20115: # ADD TO IOCHN CHAIN OF ASSSOCIATED VARIABLES UNLESS ALREAD ! 20116: # PRESENT. ! 20117: # ! 20118: iop19: movl r$ion,r8 # wc = name base, wb = name offset ! 20119: # ! 20120: # SEARCH LOOP ! 20121: # ! 20122: iop20: movl 4*trtrf(r9),r9 # next link of chain ! 20123: beqlu iop21 # not found ! 20124: cmpl r8,4*ionmb(r9) # no match ! 20125: bnequ iop20 ! 20126: cmpl r7,4*ionmo(r9) # exit if matched ! 20127: beqlu iop22 ! 20128: jmp iop20 # loop ! 20129: # ! 20130: # NOT FOUND ! 20131: # ! 20132: iop21: movl $4*num05,r6 # space needed ! 20133: jsb alloc # get it ! 20134: movl $b$xrt,(r9) # store xrblk code ! 20135: movl r6,4*1(r9) # store length ! 20136: movl r8,4*ionmb(r9) # store name base ! 20137: movl r7,4*ionmo(r9) # store name offset ! 20138: movl r$iot,r10 # point to trtrf blk ! 20139: movl 4*trtrf(r10),r6 # get ptr field contents ! 20140: movl r9,4*trtrf(r10) # store ptr to new block ! 20141: movl r6,4*trtrf(r9) # complete the linking ! 20142: # ! 20143: # INSERT FCBLK ON FCBLK CHAIN FOR SYSEJ, SYSXI ! 20144: # ! 20145: iop22: tstl r$iof # skip if no fcblk ! 20146: beqlu iop25 ! 20147: movl r$fcb,r10 # ptr to head of existing chain ! 20148: # ! 20149: # SEE IF FCBLK ALREADY ON CHAIN ! 20150: # ! 20151: iop23: tstl r10 # not on if end of chain ! 20152: beqlu iop24 ! 20153: cmpl 4*3(r10),r$iof # dont duplicate if find it ! 20154: beqlu iop25 ! 20155: movl 4*2(r10),r10 # get next link ! 20156: jmp iop23 # loop ! 20157: # ! 20158: # NOT FOUND SO ADD AN ENTRY FOR THIS FCBLK ! 20159: # ! 20160: iop24: movl $4*num04,r6 # space needed ! 20161: jsb alloc # get it ! 20162: movl $b$xrt,(r9) # store block code ! 20163: movl r6,4*1(r9) # store length ! 20164: movl r$fcb,4*2(r9) # store previous link in this node ! 20165: movl r$iof,4*3(r9) # store fcblk ptr ! 20166: movl r9,r$fcb # insert node into fcblk chain ! 20167: # ! 20168: # RETURN ! 20169: # ! 20170: iop25: addl3 $4*6,ioput_s,r11 # return to caller ! 20171: jmp (r11) ! 20172: #enp # end procedure ioput ! 20173: #page ! 20174: # ! 20175: # KTREX -- EXECUTE KEYWORD TRACE ! 20176: # ! 20177: # KTREX IS USED TO EXECUTE A POSSIBLE KEYWORD TRACE. IT ! 20178: # INCLUDES THE TEST ON TRACE AND TESTS FOR TRACE ACTIVE. ! 20179: # ! 20180: # (XL) PTR TO TRBLK (OR 0 IF UNTRACED) ! 20181: # JSR KTREX CALL TO EXECUTE KEYWORD TRACE ! 20182: # (XL,WA,WB,WC) DESTROYED ! 20183: # (RA) DESTROYED ! 20184: # ! 20185: ktrex: #prc # entry point (recursive) ! 20186: tstl r10 # immediate exit if keyword untraced ! 20187: beqlu ktrx3 ! 20188: tstl kvtra # immediate exit if trace = 0 ! 20189: beqlu ktrx3 ! 20190: decl kvtra # else decrement trace ! 20191: movl r9,-(sp) # save xr ! 20192: movl r10,r9 # copy trblk pointer ! 20193: movl 4*trkvr(r9),r10 # load vrblk pointer (nmbas) ! 20194: movl $4*vrval,r6 # set name offset ! 20195: tstl 4*trfnc(r9) # jump if print trace ! 20196: beqlu ktrx1 ! 20197: jsb trxeq # else execute full trace ! 20198: jmp ktrx2 # and jump to exit ! 20199: # ! 20200: # HERE FOR PRINT TRACE ! 20201: # ! 20202: ktrx1: movl r10,-(sp) # stack vrblk ptr for kwnam ! 20203: movl r6,-(sp) # stack offset for kwnam ! 20204: jsb prtsn # print statement number ! 20205: movl $ch$am,r6 # load ampersand ! 20206: jsb prtch # print ampersand ! 20207: jsb prtnm # print keyword name ! 20208: movl $tmbeb,r9 # point to blank-equal-blank ! 20209: jsb prtst # print blank-equal-blank ! 20210: jsb kwnam # get keyword pseudo-variable name ! 20211: movl r9,dnamp # reset ptr to delete kvblk ! 20212: jsb acess # get keyword value ! 20213: .long invalid$ # failure is impossible ! 20214: jsb prtvl # print keyword value ! 20215: jsb prtnl # terminate print line ! 20216: # ! 20217: # HERE TO EXIT AFTER COMPLETING TRACE ! 20218: # ! 20219: ktrx2: movl (sp)+,r9 # restore entry xr ! 20220: # ! 20221: # MERGE HERE TO EXIT IF NO TRACE REQUIRED ! 20222: # ! 20223: ktrx3: rsb # return to ktrex caller ! 20224: #enp # end procedure ktrex ! 20225: #page ! 20226: # ! 20227: # KWNAM -- GET PSEUDO-VARIABLE NAME FOR KEYWORD ! 20228: # ! 20229: # 1(XS) NAME BASE FOR VRBLK ! 20230: # 0(XS) OFFSET (SHOULD BE *VRVAL) ! 20231: # JSR KWNAM CALL TO GET PSEUDO-VARIABLE NAME ! 20232: # (XS) POPPED TWICE ! 20233: # (XL,WA) RESULTING PSEUDO-VARIABLE NAME ! 20234: # (XR,WA,WB) DESTROYED ! 20235: # ! 20236: .data 1 ! 20237: kwnam_s: .long 0 ! 20238: .text 0 ! 20239: kwnam: movl (sp)+,kwnam_s # entry point ! 20240: addl2 $4,sp # ignore name offset ! 20241: movl (sp)+,r9 # load name base ! 20242: cmpl r9,state # jump if not natural variable name ! 20243: bgequ kwnm1 ! 20244: tstl 4*vrlen(r9) # error if not system variable ! 20245: bnequ kwnm1 ! 20246: movl 4*vrsvp(r9),r9 # else point to svblk ! 20247: movl 4*svbit(r9),r6 # load bit mask ! 20248: mcoml btknm,r11 # and with keyword bit ! 20249: bicl2 r11,r6 ! 20250: beqlu kwnm1 # error if no keyword association ! 20251: movl 4*svlen(r9),r6 # else load name length in characters ! 20252: movab 3+(4*svchs)(r6),r6 # compute offset to field we want ! 20253: bicl2 $3,r6 ! 20254: addl2 r6,r9 # point to svknm field ! 20255: movl (r9),r7 # load svknm value ! 20256: movl $4*kvsi$,r6 # set size of kvblk ! 20257: jsb alloc # allocate kvblk ! 20258: movl $b$kvt,(r9) # store type word ! 20259: movl r7,4*kvnum(r9) # store keyword number ! 20260: movl $trbkv,4*kvvar(r9) # set dummy trblk pointer ! 20261: movl r9,r10 # copy kvblk pointer ! 20262: movl $4*kvvar,r6 # set proper offset ! 20263: jmp *kwnam_s # return to kvnam caller ! 20264: # ! 20265: # HERE IF NOT KEYWORD NAME ! 20266: # ! 20267: kwnm1: jmp er_251 # keyword operand is not name of defined keyword ! 20268: #enp # end procedure kwnam ! 20269: #page ! 20270: # ! 20271: # LCOMP-- COMPARE TWO STRINGS LEXICALLY ! 20272: # ! 20273: # 1(XS) FIRST ARGUMENT ! 20274: # 0(XS) SECOND ARGUMENT ! 20275: # JSR LCOMP CALL TO COMPARE ARUMENTS ! 20276: # PPM LOC TRANSFER LOC FOR ARG1 NOT STRING ! 20277: # PPM LOC TRANSFER LOC FOR ARG2 NOT STRING ! 20278: # PPM LOC TRANSFER LOC IF ARG1 LLT ARG2 ! 20279: # PPM LOC TRANSFER LOC IF ARG1 LEQ ARG2 ! 20280: # PPM LOC TRANSFER LOC IF ARG1 LGT ARG2 ! 20281: # (THE NORMAL RETURN IS NEVER TAKEN) ! 20282: # (XS) POPPED TWICE ! 20283: # (XR,XL) DESTROYED ! 20284: # (WA,WB,WC,RA) DESTROYED ! 20285: # ! 20286: .data 1 ! 20287: lcomp_s: .long 0 ! 20288: .text 0 ! 20289: lcomp: movl (sp)+,lcomp_s # entry point ! 20290: jsb gtstg # convert second arg to string ! 20291: .long lcmp6 # jump if second arg not string ! 20292: movl r9,r10 # else save pointer ! 20293: movl r6,r7 # and length ! 20294: jsb gtstg # convert first argument to string ! 20295: .long lcmp5 # jump if not string ! 20296: movl r6,r8 # save arg 1 length ! 20297: movab cfp$f(r9),r9 # point to chars of arg 1 ! 20298: movab cfp$f(r10),r10 # point to chars of arg 2 ! 20299: cmpl r6,r7 # jump if arg 1 length is smaller ! 20300: blequ lcmp1 ! 20301: movl r7,r6 # else set arg 2 length as smaller ! 20302: # ! 20303: # HERE WITH SMALLER LENGTH IN (WA) ! 20304: # ! 20305: lcmp1: jsb sbcmc # compare strings, jump if unequal ! 20306: .long lcmp4 ! 20307: .long lcmp3 ! 20308: cmpl r7,r8 # if equal, jump if lengths unequal ! 20309: bnequ lcmp2 ! 20310: addl3 $4*3,lcomp_s,r11 # else identical strings, leq exit ! 20311: jmp *(r11)+ ! 20312: #page ! 20313: # ! 20314: # LCOMP (CONTINUED) ! 20315: # ! 20316: # HERE IF INITIAL STRINGS IDENTICAL, BUT LENGTHS UNEQUAL ! 20317: # ! 20318: lcmp2: cmpl r8,r7 # jump if arg 1 length gt arg 2 leng ! 20319: bgequ lcmp4 ! 20320: # ! 20321: # HERE IF FIRST ARG LLT SECOND ARG ! 20322: # ! 20323: lcmp3: addl3 $4*2,lcomp_s,r11 # take llt exit ! 20324: jmp *(r11)+ ! 20325: # ! 20326: # HERE IF FIRST ARG LGT SECOND ARG ! 20327: # ! 20328: lcmp4: addl3 $4*4,lcomp_s,r11 # take lgt exit ! 20329: jmp *(r11)+ ! 20330: # ! 20331: # HERE IF FIRST ARG IS NOT A STRING ! 20332: # ! 20333: lcmp5: movl lcomp_s,r11 # take bad first arg exit ! 20334: jmp *(r11)+ ! 20335: # ! 20336: # HERE FOR SECOND ARG NOT A STRING ! 20337: # ! 20338: lcmp6: addl3 $4*1,lcomp_s,r11 # take bad second arg error exit ! 20339: jmp *(r11)+ ! 20340: #enp # end procedure lcomp ! 20341: #page ! 20342: # ! 20343: # LISTR -- LIST SOURCE LINE ! 20344: # ! 20345: # LISTR IS USED TO LIST A SOURCE LINE DURING THE INITIAL ! 20346: # COMPILATION. IT IS CALLED FROM SCANE AND SCANL. ! 20347: # ! 20348: # JSR LISTR CALL TO LIST LINE ! 20349: # (XR,XL,WA,WB,WC) DESTROYED ! 20350: # ! 20351: # GLOBAL LOCATIONS USED BY LISTR ! 20352: # ! 20353: # ERLST IF LISTING ON ACCOUNT OF AN ERROR ! 20354: # ! 20355: # LSTLC COUNT LINES ON CURRENT PAGE ! 20356: # ! 20357: # LSTNP MAX NUMBER OF LINES/PAGE ! 20358: # ! 20359: # LSTPF SET NON-ZERO IF THE CURRENT SOURCE ! 20360: # LINE HAS BEEN LISTED, ELSE ZERO. ! 20361: # ! 20362: # LSTPG COMPILER LISTING PAGE NUMBER ! 20363: # ! 20364: # LSTSN SET IF STMNT NUM TO BE LISTED ! 20365: # ! 20366: # R$CIM POINTER TO CURRENT INPUT LINE. ! 20367: # ! 20368: # R$TTL TITLE FOR SOURCE LISTING ! 20369: # ! 20370: # R$STL PTR TO SUB-TITLE STRING ! 20371: # ! 20372: # ENTRY POINT ! 20373: # ! 20374: listr: #prc # entry point ! 20375: tstl cnttl # jump if -title or -stitl ! 20376: beqlu 0f ! 20377: jmp list5 ! 20378: 0: ! 20379: tstl lstpf # immediate exit if already listed ! 20380: beqlu 0f ! 20381: jmp list4 ! 20382: 0: ! 20383: cmpl lstlc,lstnp # jump if no room ! 20384: blssu 0f ! 20385: jmp list6 ! 20386: 0: ! 20387: # ! 20388: # HERE AFTER PRINTING TITLE (IF NEEDED) ! 20389: # ! 20390: list0: movl r$cim,r9 # load pointer to current image ! 20391: movab cfp$f(r9),r9 # point to characters ! 20392: movzbl (r9),r6 # load first character ! 20393: movl lstsn,r9 # load statement number ! 20394: beqlu list2 # jump if no statement number ! 20395: movl r9,r5 # else get stmnt number as integer ! 20396: cmpl stage,$stgic # skip if execute time ! 20397: bnequ list1 ! 20398: cmpl r6,$ch$as # no stmnt number list if comment ! 20399: beqlu list2 ! 20400: cmpl r6,$ch$mn # no stmnt no. if control card ! 20401: beqlu list2 ! 20402: # ! 20403: # PRINT STATEMENT NUMBER ! 20404: # ! 20405: list1: jsb prtin # else print statement number ! 20406: clrl lstsn # and clear for next time in ! 20407: #page ! 20408: # ! 20409: # LISTR (CONTINUED) ! 20410: # ! 20411: # MERGE HERE AFTER PRINTING STATEMENT NUMBER (IF REQUIRED) ! 20412: # ! 20413: list2: movl $stnpd,profs # point past statement number ! 20414: movl r$cim,r9 # load pointer to current image ! 20415: jsb prtst # print it ! 20416: incl lstlc # bump line counter ! 20417: tstl erlst # jump if error copy to int.ch. ! 20418: bnequ list3 ! 20419: jsb prtnl # terminate line ! 20420: tstl cswdb # jump if -single mode ! 20421: beqlu list3 ! 20422: jsb prtnl # else add a blank line ! 20423: incl lstlc # and bump line counter ! 20424: # ! 20425: # HERE AFTER PRINTING SOURCE IMAGE ! 20426: # ! 20427: list3: movl sp,lstpf # set flag for line printed ! 20428: # ! 20429: # MERGE HERE TO EXIT ! 20430: # ! 20431: list4: rsb # return to listr caller ! 20432: # ! 20433: # PRINT TITLE AFTER -TITLE OR -STITL CARD ! 20434: # ! 20435: list5: clrl cnttl # clear flag ! 20436: # ! 20437: # EJECT TO NEW PAGE AND LIST TITLE ! 20438: # ! 20439: list6: jsb prtps # eject ! 20440: tstl prich # skip if listing to regular printer ! 20441: beqlu list7 ! 20442: cmpl r$ttl,$nulls # terminal listing omits null title ! 20443: bnequ 0f ! 20444: jmp list0 ! 20445: 0: ! 20446: # ! 20447: # LIST TITLE ! 20448: # ! 20449: list7: jsb listt # list title ! 20450: jmp list0 # merge ! 20451: #enp # end procedure listr ! 20452: #page ! 20453: # ! 20454: # LISTT -- LIST TITLE AND SUBTITLE ! 20455: # ! 20456: # USED DURING COMPILATION TO PRINT PAGE HEADING ! 20457: # ! 20458: # JSR LISTT CALL TO LIST TITLE ! 20459: # (XR,WA) DESTROYED ! 20460: # ! 20461: listt: #prc # entry point ! 20462: movl r$ttl,r9 # point to source listing title ! 20463: jsb prtst # print title ! 20464: movl lstpo,profs # set offset ! 20465: movl $lstms,r9 # set page message ! 20466: jsb prtst # print page message ! 20467: incl lstpg # bump page number ! 20468: movl lstpg,r5 # load page number as integer ! 20469: jsb prtin # print page number ! 20470: jsb prtnl # terminate title line ! 20471: addl2 $num02,lstlc # count title line and blank line ! 20472: # ! 20473: # PRINT SUB-TITLE (IF ANY) ! 20474: # ! 20475: movl r$stl,r9 # load pointer to sub-title ! 20476: beqlu lstt1 # jump if no sub-title ! 20477: jsb prtst # else print sub-title ! 20478: jsb prtnl # terminate line ! 20479: incl lstlc # bump line count ! 20480: # ! 20481: # RETURN POINT ! 20482: # ! 20483: lstt1: jsb prtnl # print a blank line ! 20484: rsb # return to caller ! 20485: #enp # end procedure listt ! 20486: #page ! 20487: # ! 20488: # NEXTS -- ACQUIRE NEXT SOURCE IMAGE ! 20489: # ! 20490: # NEXTS IS USED TO ACQUIRE THE NEXT SOURCE IMAGE AT COMPILE ! 20491: # TIME. IT ASSUMES THAT A PRIOR CALL TO READR HAS INPUT ! 20492: # A LINE IMAGE (SEE PROCEDURE READR). BEFORE THE CURRENT ! 20493: # IMAGE IS FINALLY LOST IT MAY BE LISTED HERE. ! 20494: # ! 20495: # JSR NEXTS CALL TO ACQUIRE NEXT INPUT LINE ! 20496: # (XR,XL,WA,WB,WC) DESTROYED ! 20497: # ! 20498: # GLOBAL VALUES AFFECTED ! 20499: # ! 20500: # R$CNI ON INPUT, NEXT IMAGE. ON ! 20501: # EXIT RESET TO ZERO ! 20502: # ! 20503: # R$CIM ON EXIT, SET TO POINT TO IMAGE ! 20504: # ! 20505: # SCNIL INPUT IMAGE LENGTH ON EXIT ! 20506: # ! 20507: # SCNSE RESET TO ZERO ON EXIT ! 20508: # ! 20509: # LSTPF SET ON EXIT IF LINE IS LISTED ! 20510: # ! 20511: nexts: #prc # entry point ! 20512: tstl cswls # jump if -nolist ! 20513: beqlu nxts2 ! 20514: movl r$cim,r9 # point to image ! 20515: beqlu nxts2 # jump if no image ! 20516: movab cfp$f(r9),r9 # get char ptr ! 20517: movzbl (r9),r6 # get first char ! 20518: cmpl r6,$ch$mn # jump if not ctrl card ! 20519: bnequ nxts1 ! 20520: tstl cswpr # jump if -noprint ! 20521: beqlu nxts2 ! 20522: # ! 20523: # HERE TO CALL LISTER ! 20524: # ! 20525: nxts1: jsb listr # list line ! 20526: # ! 20527: # HERE AFTER POSSIBLE LISTING ! 20528: # ! 20529: nxts2: movl r$cni,r9 # point to next image ! 20530: movl r9,r$cim # set as next image ! 20531: clrl r$cni # clear next image pointer ! 20532: movl 4*sclen(r9),r6 # get input image length ! 20533: movl cswin,r7 # get max allowable length ! 20534: cmpl r6,r7 # skip if not too long ! 20535: blequ nxts3 ! 20536: movl r7,r6 # else truncate ! 20537: # ! 20538: # HERE WITH LENGTH IN (WA) ! 20539: # ! 20540: nxts3: movl r6,scnil # use as record length ! 20541: clrl scnse # reset scnse ! 20542: clrl lstpf # set line not listed yet ! 20543: rsb # return to nexts caller ! 20544: #enp # end procedure nexts ! 20545: #page ! 20546: # ! 20547: # PATIN -- PATTERN CONSTRUCTION FOR LEN,POS,RPOS,TAB,RTAB ! 20548: # ! 20549: # THESE PATTERN TYPES ALL GENERATE A SIMILAR NODE TYPE. SO ! 20550: # THE CONSTRUCTION CODE IS SHARED. SEE FUNCTIONS SECTION ! 20551: # FOR ACTUAL ENTRY POINTS FOR THESE FIVE FUNCTIONS. ! 20552: # ! 20553: # (WA) PCODE FOR EXPRESSION ARG CASE ! 20554: # (WB) PCODE FOR INTEGER ARG CASE ! 20555: # JSR PATIN CALL TO BUILD PATTERN NODE ! 20556: # PPM LOC TRANSFER LOC FOR NOT INTEGER OR EXP ! 20557: # PPM LOC TRANSFER LOC FOR INT OUT OF RANGE ! 20558: # (XR) POINTER TO CONSTRUCTED NODE ! 20559: # (XL,WA,WB,WC,IA) DESTROYED ! 20560: # ! 20561: .data 1 ! 20562: patin_s: .long 0 ! 20563: .text 0 ! 20564: patin: movl (sp)+,patin_s # entry point ! 20565: movl r6,r10 # preserve expression arg pcode ! 20566: jsb gtsmi # try to convert arg as small integer ! 20567: .long ptin2 # jump if not integer ! 20568: .long ptin3 # jump if out of range ! 20569: # ! 20570: # COMMON SUCCESSFUL EXIT POINT ! 20571: # ! 20572: ptin1: jsb pbild # build pattern node ! 20573: addl3 $4*2,patin_s,r11 # return to caller ! 20574: jmp (r11) ! 20575: # ! 20576: # HERE IF ARGUMENT IS NOT AN INTEGER ! 20577: # ! 20578: ptin2: movl r10,r7 # copy expr arg case pcode ! 20579: cmpl (r9),$b$e$$ # all ok if expression arg ! 20580: blequ ptin1 ! 20581: movl patin_s,r11 # else take error exit for wrong type ! 20582: jmp *(r11)+ ! 20583: # ! 20584: # HERE FOR ERROR OF OUT OF RANGE INTEGER ARGUMENT ! 20585: # ! 20586: ptin3: addl3 $4*1,patin_s,r11 # take out-of-range error exit ! 20587: jmp *(r11)+ ! 20588: #enp # end procedure patin ! 20589: #page ! 20590: # ! 20591: # PATST -- PATTERN CONSTRUCTION FOR ANY,NOTANY, ! 20592: # BREAK,SPAN AND BREAKX PATTERN FUNCTIONS. ! 20593: # ! 20594: # THESE PATTERN FUNCTIONS BUILD SIMILAR TYPES OF NODES AND ! 20595: # THE CONSTRUCTION CODE IS SHARED. SEE FUNCTIONS SECTION ! 20596: # FOR ACTUAL ENTRY POINTS FOR THESE FIVE PATTERN FUNCTIONS. ! 20597: # ! 20598: # 0(XS) STRING ARGUMENT ! 20599: # (WB) PCODE FOR ONE CHAR ARGUMENT ! 20600: # (XL) PCODE FOR MULTI-CHAR ARGUMENT ! 20601: # (WC) PCODE FOR EXPRESSION ARGUMENT ! 20602: # JSR PATST CALL TO BUILD NODE ! 20603: # PPM LOC TRANSFER LOC IF NOT STRING OR EXPR ! 20604: # (XS) POPPED PAST STRING ARGUMENT ! 20605: # (XR) POINTER TO CONSTRUCTED NODE ! 20606: # (XL) DESTROYED ! 20607: # (WA,WB,WC,RA) DESTROYED ! 20608: # ! 20609: # NOTE THAT THERE IS A SPECIAL CALL TO PATST IN THE EVALS ! 20610: # PROCEDURE WITH A SLIGHTLY DIFFERENT FORM. SEE EVALS ! 20611: # FOR DETAILS OF THE FORM OF THIS CALL. ! 20612: # ! 20613: .data 1 ! 20614: patst_s: .long 0 ! 20615: .text 0 ! 20616: patst: movl (sp)+,patst_s # entry point ! 20617: jsb gtstg # convert argument as string ! 20618: .long pats7 # jump if not string ! 20619: cmpl r6,$num01 # jump if not one char string ! 20620: bnequ pats2 ! 20621: # ! 20622: # HERE FOR ONE CHAR STRING CASE ! 20623: # ! 20624: tstl r7 # treat as multi-char if evals call ! 20625: beqlu pats2 ! 20626: movab cfp$f(r9),r9 # point to character ! 20627: movzbl (r9),r9 # load character ! 20628: # ! 20629: # COMMON EXIT POINT AFTER SUCCESSFUL CONSTRUCTION ! 20630: # ! 20631: pats1: jsb pbild # call routine to build node ! 20632: addl3 $4*1,patst_s,r11 # return to patst caller ! 20633: jmp (r11) ! 20634: #page ! 20635: # ! 20636: # PATST (CONTINUED) ! 20637: # ! 20638: # HERE FOR MULTI-CHARACTER STRING CASE ! 20639: # ! 20640: pats2: movl r10,-(sp) # save multi-char pcode ! 20641: movl r9,-(sp) # save string pointer ! 20642: movl ctmsk,r8 # load current mask bit ! 20643: ashl $1,r8,r8 # shift to next position ! 20644: tstl r8 # skip if position left in this tbl ! 20645: bnequ pats4 ! 20646: # ! 20647: # HERE WE MUST ALLOCATE A NEW CHARACTER TABLE ! 20648: # ! 20649: movl $4*ctsi$,r6 # set size of ctblk ! 20650: jsb alloc # allocate ctblk ! 20651: movl r9,r$ctp # store ptr to new ctblk ! 20652: movl $b$ctt,(r9)+ # store type code, bump ptr ! 20653: movl $cfp$a,r7 # set number of words to clear ! 20654: movl bits0,r8 # load all zero bits ! 20655: # ! 20656: # LOOP TO CLEAR ALL BITS IN TABLE TO ZEROS ! 20657: # ! 20658: pats3: movl r8,(r9)+ # move word of zero bits ! 20659: sobgtr r7,pats3 # loop till all cleared ! 20660: movl bits1,r8 # set initial bit position ! 20661: # ! 20662: # MERGE HERE WITH BIT POSITION AVAILABLE ! 20663: # ! 20664: pats4: movl r8,ctmsk # save parm2 (new bit position) ! 20665: movl (sp)+,r10 # restore pointer to argument string ! 20666: movl 4*sclen(r10),r7 # load string length ! 20667: beqlu pats6 # jump if null string case ! 20668: # else set loop counter ! 20669: movab cfp$f(r10),r10 # point to characters in argument ! 20670: #page ! 20671: # ! 20672: # PATST (CONTINUED) ! 20673: # ! 20674: # LOOP TO SET BITS IN COLUMN OF TABLE ! 20675: # ! 20676: pats5: movzbl (r10)+,r6 # load next character ! 20677: moval 0[r6],r6 # convert to byte offset ! 20678: movl r$ctp,r9 # point to ctblk ! 20679: addl2 r6,r9 # point to ctblk entry ! 20680: movl r8,r6 # copy bit mask ! 20681: bisl2 4*ctchs(r9),r6 # or in bits already set ! 20682: movl r6,4*ctchs(r9) # store resulting bit string ! 20683: sobgtr r7,pats5 # loop till all bits set ! 20684: # ! 20685: # COMPLETE PROCESSING FOR MUTI-CHAR STRING CASE ! 20686: # ! 20687: pats6: movl r$ctp,r9 # load ctblk ptr as parm1 for pbild ! 20688: clrl r10 # clear garbage ptr in xl ! 20689: movl (sp)+,r7 # load pcode for multi-char str case ! 20690: jmp pats1 # back to exit (wc=bitstring=parm2) ! 20691: # ! 20692: # HERE IF ARGUMENT IS NOT A STRING ! 20693: # ! 20694: # NOTE THAT THE CALL FROM EVALS CANNOT PASS AN EXPRESSION ! 20695: # SINCE EVALP ALWAYS REEVALUATES EXPRESSIONS. ! 20696: # ! 20697: pats7: movl r8,r7 # set pcode for expression argument ! 20698: cmpl (r9),$b$e$$ # jump to exit if expression arg ! 20699: bgtru 0f ! 20700: jmp pats1 ! 20701: 0: ! 20702: movl patst_s,r11 # else take wrong type error exit ! 20703: jmp *(r11)+ ! 20704: #enp # end procedure patst ! 20705: #page ! 20706: # ! 20707: # PBILD -- BUILD PATTERN NODE ! 20708: # ! 20709: # (XR) PARM1 (ONLY IF REQUIRED) ! 20710: # (WB) PCODE FOR NODE ! 20711: # (WC) PARM2 (ONLY IF REQUIRED) ! 20712: # JSR PBILD CALL TO BUILD NODE ! 20713: # (XR) POINTER TO CONSTRUCTED NODE ! 20714: # (WA) DESTROYED ! 20715: # ! 20716: pbild: #prc # entry point ! 20717: movl r9,-(sp) # stack possible parm1 ! 20718: movl r7,r9 # copy pcode ! 20719: movzwl -2(r9),r9 # load entry point id (bl$px) ! 20720: cmpl r9,$bl$p1 # jump if one parameter ! 20721: beqlu pbld1 ! 20722: cmpl r9,$bl$p0 # jump if no parameters ! 20723: beqlu pbld3 ! 20724: # ! 20725: # HERE FOR TWO PARAMETER CASE ! 20726: # ! 20727: movl $4*pcsi$,r6 # set size of p2blk ! 20728: jsb alloc # allocate block ! 20729: movl r8,4*parm2(r9) # store second parameter ! 20730: jmp pbld2 # merge with one parm case ! 20731: # ! 20732: # HERE FOR ONE PARAMETER CASE ! 20733: # ! 20734: pbld1: movl $4*pbsi$,r6 # set size of p1blk ! 20735: jsb alloc # allocate node ! 20736: # ! 20737: # MERGE HERE FROM TWO PARM CASE ! 20738: # ! 20739: pbld2: movl (sp),4*parm1(r9)# store first parameter ! 20740: jmp pbld4 # merge with no parameter case ! 20741: # ! 20742: # HERE FOR CASE OF NO PARAMETERS ! 20743: # ! 20744: pbld3: movl $4*pasi$,r6 # set size of p0blk ! 20745: jsb alloc # allocate node ! 20746: # ! 20747: # MERGE HERE FROM OTHER CASES ! 20748: # ! 20749: pbld4: movl r7,(r9) # store pcode ! 20750: addl2 $4,sp # pop first parameter ! 20751: movl $ndnth,4*pthen(r9) # set nothen successor pointer ! 20752: rsb # return to pbild caller ! 20753: #enp # end procedure pbild ! 20754: #page ! 20755: # ! 20756: # PCONC -- CONCATENATE TWO PATTERNS ! 20757: # ! 20758: # (XL) PTR TO RIGHT PATTERN ! 20759: # (XR) PTR TO LEFT PATTERN ! 20760: # JSR PCONC CALL TO CONCATENATE PATTERNS ! 20761: # (XR) PTR TO CONCATENATED PATTERN ! 20762: # (XL,WA,WB,WC) DESTROYED ! 20763: # ! 20764: # ! 20765: # TO CONCATENATE TWO PATTERNS, ALL SUCCESSORS IN THE LEFT ! 20766: # PATTERN WHICH POINT TO THE NOTHEN NODE MUST BE CHANGED TO ! 20767: # POINT TO THE RIGHT PATTERN. HOWEVER, THIS MODIFICATION ! 20768: # MUST BE PERFORMED ON A COPY OF THE LEFT ARGUMENT RATHER ! 20769: # THAN THE LEFT ARGUMENT ITSELF, SINCE THE LEFT ARGUMENT ! 20770: # MAY BE POINTED TO BY SOME OTHER VARIABLE VALUE. ! 20771: # ! 20772: # ACCORDINGLY, IT IS NECESSARY TO COPY THE LEFT ARGUMENT. ! 20773: # THIS IS NOT A TRIVIAL PROCESS SINCE WE MUST AVOID COPYING ! 20774: # NODES MORE THAN ONCE AND THE PATTERN IS A GRAPH STRUCTURE ! 20775: # THE FOLLOWING ALGORITHM IS EMPLOYED. ! 20776: # ! 20777: # THE STACK IS USED TO STORE A LIST OF NODES WHICH ! 20778: # HAVE ALREADY BEEN COPIED. THE FORMAT OF THE ENTRIES ON ! 20779: # THIS LIST CONSISTS OF A TWO WORD BLOCK. THE FIRST WORD ! 20780: # IS THE OLD ADDRESS AND THE SECOND WORD IS THE ADDRESS ! 20781: # OF THE COPY. THIS LIST IS SEARCHED BY THE PCOPY ! 20782: # ROUTINE TO AVOID MAKING DUPLICATE COPIES. A TRICK IS ! 20783: # USED TO ACCOMPLISH THE CONCATENATION AT THE SAME TIME. ! 20784: # A SPECIAL ENTRY IS MADE TO START WITH ON THE STACK. THIS ! 20785: # ENTRY RECORDS THAT THE NOTHEN NODE HAS BEEN COPIED ! 20786: # ALREADY AND THE ADDRESS OF ITS COPY IS THE RIGHT PATTERN. ! 20787: # THIS AUTOMATICALLY PERFORMS THE CORRECT REPLACEMENTS. ! 20788: # ! 20789: pconc: #prc # entry point ! 20790: clrl -(sp) # make room for one entry at bottom ! 20791: movl sp,r8 # store pointer to start of list ! 20792: movl $ndnth,-(sp) # stack nothen node as old node ! 20793: movl r10,-(sp) # store right arg as copy of nothen ! 20794: movl sp,r10 # initialize pointer to stack entries ! 20795: jsb pcopy # copy first node of left arg ! 20796: movl r6,4*2(r10) # store as result under list ! 20797: #page ! 20798: # ! 20799: # PCONC (CONTINUED) ! 20800: # ! 20801: # THE FOLLOWING LOOP SCANS ENTRIES IN THE LIST AND MAKES ! 20802: # SURE THAT THEIR SUCCESSORS HAVE BEEN COPIED. ! 20803: # ! 20804: pcnc1: cmpl r10,sp # jump if all entries processed ! 20805: beqlu pcnc2 ! 20806: movl -(r10),r9 # else load next old address ! 20807: movl 4*pthen(r9),r9 # load pointer to successor ! 20808: jsb pcopy # copy successor node ! 20809: movl -(r10),r9 # load pointer to new node (copy) ! 20810: movl r6,4*pthen(r9) # store ptr to new successor ! 20811: # ! 20812: # NOW CHECK FOR SPECIAL CASE OF ALTERNATION NODE WHERE ! 20813: # PARM1 POINTS TO A NODE AND MUST BE COPIED LIKE PTHEN. ! 20814: # ! 20815: cmpl (r9),$p$alt # loop back if not ! 20816: bnequ pcnc1 ! 20817: movl 4*parm1(r9),r9 # else load pointer to alternative ! 20818: jsb pcopy # copy it ! 20819: movl (r10),r9 # restore ptr to new node ! 20820: movl r6,4*parm1(r9) # store ptr to copied alternative ! 20821: jmp pcnc1 # loop back for next entry ! 20822: # ! 20823: # HERE AT END OF COPY PROCESS ! 20824: # ! 20825: pcnc2: movl r8,sp # restore stack pointer ! 20826: movl (sp)+,r9 # load pointer to copy ! 20827: rsb # return to pconc caller ! 20828: #enp # end procedure pconc ! 20829: #page ! 20830: # ! 20831: # PCOPY -- COPY A PATTERN NODE ! 20832: # ! 20833: # PCOPY IS CALLED FROM THE PCONC PROCEDURE TO COPY A SINGLE ! 20834: # PATTERN NODE. THE COPY IS ONLY CARRIED OUT IF THE NODE ! 20835: # HAS NOT BEEN COPIED ALREADY. ! 20836: # ! 20837: # (XR) POINTER TO NODE TO BE COPIED ! 20838: # (XT) PTR TO CURRENT LOC IN COPY LIST ! 20839: # (WC) POINTER TO LIST OF COPIED NODES ! 20840: # JSR PCOPY CALL TO COPY A NODE ! 20841: # (WA) POINTER TO COPY ! 20842: # (WB,XR) DESTROYED ! 20843: # ! 20844: .data 1 ! 20845: pcopy_s: .long 0 ! 20846: .text 0 ! 20847: pcopy: movl (sp)+,pcopy_s # entry point ! 20848: movl r10,r7 # save xt ! 20849: movl r8,r10 # point to start of list ! 20850: # ! 20851: # LOOP TO SEARCH LIST OF NODES COPIED ALREADY ! 20852: # ! 20853: pcop1: subl2 $4,r10 # point to next entry on list ! 20854: cmpl r9,(r10) # jump if match ! 20855: beqlu pcop2 ! 20856: subl2 $4,r10 # else skip over copied address ! 20857: cmpl r10,sp # loop back if more to test ! 20858: bnequ pcop1 ! 20859: # ! 20860: # HERE IF NOT IN LIST, PERFORM COPY ! 20861: # ! 20862: movl (r9),r6 # load first word of block ! 20863: jsb blkln # get length of block ! 20864: movl r9,r10 # save pointer to old node ! 20865: jsb alloc # allocate space for copy ! 20866: movl r10,-(sp) # store old address on list ! 20867: movl r9,-(sp) # store new address on list ! 20868: jsb sbchk # check for stack overflow ! 20869: jsb sbmvw # move words from old block to copy ! 20870: movl (sp),r6 # load pointer to copy ! 20871: jmp pcop3 # jump to exit ! 20872: # ! 20873: # HERE IF WE FIND ENTRY IN LIST ! 20874: # ! 20875: pcop2: movl -(r10),r6 # load address of copy from list ! 20876: # ! 20877: # COMMON EXIT POINT ! 20878: # ! 20879: pcop3: movl r7,r10 # restore xt ! 20880: jmp *pcopy_s # return to pcopy caller ! 20881: #enp # end procedure pcopy ! 20882: #page ! 20883: # ! 20884: # PRFLR -- PRINT PROFILE ! 20885: # PRFLR IS CALLED TO PRINT THE CONTENTS OF THE PROFILE ! 20886: # TABLE IN A FAIRLY READABLE TABULAR FORMAT. ! 20887: # ! 20888: # JSR PRFLR CALL TO PRINT PROFILE ! 20889: # (WA,IA) DESTROYED ! 20890: # ! 20891: prflr: #prc ! 20892: tstl pfdmp # no printing if no profiling done ! 20893: bnequ 0f ! 20894: jmp prfl4 ! 20895: 0: ! 20896: movl r9,-(sp) # preserve entry xr ! 20897: movl r7,pfsvw # and also wb ! 20898: jsb prtpg # eject ! 20899: movl $pfms1,r9 # load msg /program profile/ ! 20900: jsb prtst # and print it ! 20901: jsb prtnl # followed by newline ! 20902: jsb prtnl # and another ! 20903: movl $pfms2,r9 # point to first hdr ! 20904: jsb prtst # print it ! 20905: jsb prtnl # new line ! 20906: movl $pfms3,r9 # second hdr ! 20907: jsb prtst # print it ! 20908: jsb prtnl # new line ! 20909: jsb prtnl # and another blank line ! 20910: clrl r7 # initial stmt count ! 20911: movl pftbl,r9 # point to table origin ! 20912: addl2 $4*num02,r9 # bias past xnblk header (sgd07) ! 20913: # ! 20914: # LOOP HERE TO PRINT SUCCESSIVE ENTRIES ! 20915: # ! 20916: prfl1: incl r7 # bump stmt nr ! 20917: movl (r9),r5 # load nr of executions ! 20918: beql prfl3 # no printing if zero ! 20919: movl $pfpd1,profs # point where to print ! 20920: jsb prtin # and print it ! 20921: clrl profs # back to start of line ! 20922: movl r7,r5 # load stmt nr ! 20923: jsb prtin # print it there ! 20924: movl $pfpd2,profs # and pad past count ! 20925: movl 4*cfp$i(r9),r5 # load total exec time ! 20926: jsb prtin # print that too ! 20927: movl 4*cfp$i(r9),r5 # reload time ! 20928: mull2 intth,r5 # convert to microsec ! 20929: bvs prfl2 ! 20930: divl2 (r9),r5 # divide by executions ! 20931: movl $pfpd3,profs # pad last print ! 20932: jsb prtin # and print mcsec/execn ! 20933: # ! 20934: # MERGE AFTER PRINTING TIME ! 20935: # ! 20936: prfl2: jsb prtnl # thats another line ! 20937: # ! 20938: # HERE TO GO TO NEXT ENTRY ! 20939: # ! 20940: prfl3: addl2 $4*pf$i2,r9 # bump index ptr (sgd07) ! 20941: cmpl r7,pfnte # loop if more stmts ! 20942: blssu prfl1 ! 20943: movl (sp)+,r9 # restore callers xr ! 20944: movl pfsvw,r7 # and wb too ! 20945: # ! 20946: # HERE TO EXIT ! 20947: # ! 20948: prfl4: rsb # return ! 20949: #enp # end of prflr ! 20950: #page ! 20951: # ! 20952: # PRFLU -- UPDATE AN ENTRY IN THE PROFILE TABLE ! 20953: # ! 20954: # ON ENTRY, KVSTN CONTAINS NR OF STMT TO PROFILE ! 20955: # ! 20956: # JSR PRFLU CALL TO UPDATE ENTRY ! 20957: # (IA) DESTROYED ! 20958: # ! 20959: prflu: #prc ! 20960: tstl pffnc # skip if just entered function ! 20961: beqlu 0f ! 20962: jmp pflu4 ! 20963: 0: ! 20964: movl r9,-(sp) # preserve entry xr ! 20965: movl r6,pfsvw # save wa (sgd07) ! 20966: tstl pftbl # branch if table allocated ! 20967: bnequ pflu2 ! 20968: # ! 20969: # HERE IF SPACE FOR PROFILE TABLE NOT YET ALLOCATED. ! 20970: # CALCULATE SIZE NEEDED, ALLOCATE A STATIC XNBLK, AND ! 20971: # INITIALIZE IT ALL TO ZERO. ! 20972: # THE TIME TAKEN FOR THIS WILL BE ATTRIBUTED TO THE CURRENT ! 20973: # STATEMENT (ASSIGNMENT TO KEYWD PROFILE), BUT SINCE THE ! 20974: # TIMING FOR THIS STATEMENT IS UP THE POLE ANYWAY, THIS ! 20975: # DOESNT REALLY MATTER... ! 20976: # ! 20977: subl2 $num01,pfnte # adjust for extra count (sgd07) ! 20978: movl pfi2a,r5 # convrt entry size to int ! 20979: movl r5,pfste # and store safely for later ! 20980: movl pfnte,r5 # load table length as integer ! 20981: mull2 pfste,r5 # multiply by entry size ! 20982: movl r5,r6 # get back address-style ! 20983: addl2 $num02,r6 # add on 2 word overhead ! 20984: moval 0[r6],r6 # convert the whole lot to bytes ! 20985: jsb alost # gimme the space ! 20986: movl r9,pftbl # save block pointer ! 20987: movl $b$xnt,(r9)+ # put block type and ... ! 20988: movl r6,(r9)+ # ... length into header ! 20989: movl r5,r6 # get back nr of wds in data area ! 20990: # load the counter ! 20991: # ! 20992: # LOOP HERE TO ZERO THE BLOCK DATA ! 20993: # ! 20994: pflu1: clrl (r9)+ # blank a word ! 20995: sobgtr r6,pflu1 # and alllllll the rest ! 20996: # ! 20997: # END OF ALLOCATION. MERGE BACK INTO ROUTINE ! 20998: # ! 20999: pflu2: movl kvstn,r5 # load nr of stmt just ended ! 21000: subl2 intv1,r5 # make into index offset ! 21001: mull2 pfste,r5 # make offset of table entry ! 21002: movl r5,r6 # convert to address ! 21003: moval 0[r6],r6 # get as baus ! 21004: addl2 $4*num02,r6 # offset includes table header ! 21005: movl pftbl,r9 # get table start ! 21006: cmpl r6,4*num01(r9) # if out of table, skip it ! 21007: bgequ pflu3 ! 21008: addl2 r6,r9 # else point to entry ! 21009: movl (r9),r5 # get nr of executions so far ! 21010: addl2 intv1,r5 # nudge up one ! 21011: movl r5,(r9) # and put back ! 21012: jsb systm # get time now ! 21013: movl r5,pfetm # stash ending time ! 21014: subl2 pfstm,r5 # subtract start time ! 21015: addl2 4*cfp$i(r9),r5 # add cumulative time so far ! 21016: movl r5,4*cfp$i(r9) # and put back new total ! 21017: movl pfetm,r5 # load end time of this stmt ... ! 21018: movl r5,pfstm # ... which is start time of next ! 21019: # ! 21020: # MERGE HERE TO EXIT ! 21021: # ! 21022: pflu3: movl (sp)+,r9 # restore callers xr ! 21023: movl pfsvw,r6 # restore saved reg ! 21024: rsb # and return ! 21025: # ! 21026: # HERE IF PROFILE IS SUPPRESSED BECAUSE A PROGRAM DEFINED ! 21027: # FUNCTION IS ABOUT TO BE ENTERED, AND SO THE CURRENT STMT ! 21028: # HAS NOT YET FINISHED ! 21029: # ! 21030: pflu4: clrl pffnc # reset the condition flag ! 21031: rsb # and immediate return ! 21032: #enp # end of procedure prflu ! 21033: #page ! 21034: # ! 21035: # PRPAR - PROCESS PRINT PARAMETERS ! 21036: # ! 21037: # (WC) IF NONZERO ASSOCIATE TERMINAL ONLY ! 21038: # JSR PRPAR CALL TO PROCESS PRINT PARAMETERS ! 21039: # (XL,XR,WA,WB,WC) DESTROYED ! 21040: # ! 21041: # SINCE MEMORY ALLOCATION IS UNDECIDED ON INITIAL CALL, ! 21042: # TERMINAL CANNOT BE ASSOCIATED. THE ENTRY WITH WC NON-ZERO ! 21043: # IS PROVIDED SO A LATER CALL CAN BE MADE TO COMPLETE THIS. ! 21044: # ! 21045: prpar: #prc # entry point ! 21046: tstl r8 # jump to associate terminal ! 21047: beqlu 0f ! 21048: jmp prpa7 ! 21049: 0: ! 21050: jsb syspp # get print parameters ! 21051: tstl r7 # jump if lines/page specified ! 21052: bnequ prpa1 ! 21053: movl $cfp$m,r7 # else use a large value ! 21054: ashl $-1,r7,r7 # but not too large ! 21055: # ! 21056: # STORE LINE COUNT/PAGE ! 21057: # ! 21058: prpa1: movl r7,lstnp # store number of lines/page ! 21059: movl r7,lstlc # pretend page is full initially ! 21060: clrl lstpg # clear page number ! 21061: movl prlen,r7 # get prior length if any ! 21062: beqlu prpa2 # skip if no length ! 21063: cmpl r6,r7 # skip storing if too big ! 21064: bgtru prpa3 ! 21065: # ! 21066: # STORE PRINT BUFFER LENGTH ! 21067: # ! 21068: prpa2: movl r6,prlen # store value ! 21069: # ! 21070: # PROCESS BITS OPTIONS ! 21071: # ! 21072: prpa3: movl bits3,r7 # bit 3 mask ! 21073: mcoml r8,r11 # get -nolist bit ! 21074: bicl2 r11,r7 ! 21075: beqlu prpa4 # skip if clear ! 21076: clrl cswls # set -nolist ! 21077: # ! 21078: # CHECK IF FAIL REPORTS GOTO INTERACTIVE CHANNEL ! 21079: # ! 21080: prpa4: movl bits1,r7 # bit 1 mask ! 21081: mcoml r8,r11 # get bit ! 21082: bicl2 r11,r7 ! 21083: movl r7,erich # store int. chan. error flag ! 21084: movl bits2,r7 # bit 2 mask ! 21085: mcoml r8,r11 # get bit ! 21086: bicl2 r11,r7 ! 21087: movl r7,prich # flag for std printer on int. chan. ! 21088: movl bits4,r7 # bit 4 mask ! 21089: mcoml r8,r11 # get bit ! 21090: bicl2 r11,r7 ! 21091: movl r7,cpsts # flag for compile stats suppressn. ! 21092: movl bits5,r7 # bit 5 mask ! 21093: mcoml r8,r11 # get bit ! 21094: bicl2 r11,r7 ! 21095: movl r7,exsts # flag for exec stats suppression ! 21096: #page ! 21097: # ! 21098: # PRPAR (CONTINUED) ! 21099: # ! 21100: movl bits6,r7 # bit 6 mask ! 21101: mcoml r8,r11 # get bit ! 21102: bicl2 r11,r7 ! 21103: movl r7,precl # extended/compact listing flag ! 21104: subl2 $num08,r6 # point 8 chars from line end ! 21105: tstl r7 # jump if not extended ! 21106: beqlu prpa5 ! 21107: movl r6,lstpo # store for listing page headings ! 21108: # ! 21109: # CONTINUE OPTION PROCESSING ! 21110: # ! 21111: prpa5: movl bits7,r7 # bit 7 mask ! 21112: mcoml r8,r11 # get bit 7 ! 21113: bicl2 r11,r7 ! 21114: movl r7,cswex # set -noexecute if non-zero ! 21115: movl bit10,r7 # bit 10 mask ! 21116: mcoml r8,r11 # get bit 10 ! 21117: bicl2 r11,r7 ! 21118: movl r7,headp # pretend printed to omit headers ! 21119: movl bits9,r7 # bit 9 mask ! 21120: mcoml r8,r11 # get bit 9 ! 21121: bicl2 r11,r7 ! 21122: movl r7,prsto # keep it as std listing option ! 21123: tstl r7 # skip if clear ! 21124: beqlu prpa6 ! 21125: movl prlen,r6 # get print buffer length ! 21126: subl2 $num08,r6 # point 8 chars from line end ! 21127: movl r6,lstpo # store page offset ! 21128: # ! 21129: # CHECK FOR TERMINAL ! 21130: # ! 21131: prpa6: mcoml bits8,r11 # see if terminal to be activated ! 21132: bicl2 r11,r8 ! 21133: beqlu 0f # jump if terminal required ! 21134: jmp prpa7 ! 21135: 0: ! 21136: tstl initr # jump if no terminal to detach ! 21137: beqlu prpa8 ! 21138: movl $v$ter,r10 # ptr to /terminal/ ! 21139: jsb gtnvr # get vrblk pointer ! 21140: .long invalid$ # cant fail ! 21141: movl $nulls,4*vrval(r9) # clear value of terminal ! 21142: jsb setvr # remove association ! 21143: jmp prpa8 # return ! 21144: # ! 21145: # ASSOCIATE TERMINAL ! 21146: # ! 21147: prpa7: movl sp,initr # note terminal associated ! 21148: tstl dnamb # cant if memory not organised ! 21149: beqlu prpa8 ! 21150: movl $v$ter,r10 # point to terminal string ! 21151: movl $trtou,r7 # output trace type ! 21152: jsb inout # attach output trblk to vrblk ! 21153: movl r9,-(sp) # stack trblk ptr ! 21154: movl $v$ter,r10 # point to terminal string ! 21155: movl $trtin,r7 # input trace type ! 21156: jsb inout # attach input trace blk ! 21157: movl (sp)+,4*vrval(r9)# add output trblk to chain ! 21158: # ! 21159: # RETURN POINT ! 21160: # ! 21161: prpa8: rsb # return ! 21162: #enp # end procedure prpar ! 21163: #page ! 21164: # ! 21165: # PRTCH -- PRINT A CHARACTER ! 21166: # ! 21167: # PRTCH IS USED TO PRINT A SINGLE CHARACTER ! 21168: # ! 21169: # (WA) CHARACTER TO BE PRINTED ! 21170: # JSR PRTCH CALL TO PRINT CHARACTER ! 21171: # ! 21172: prtch: #prc # entry point ! 21173: movl r9,-(sp) # save xr ! 21174: cmpl profs,prlen # jump if room in buffer ! 21175: bnequ prch1 ! 21176: jsb prtnl # else print this line ! 21177: # ! 21178: # HERE AFTER MAKING SURE WE HAVE ROOM ! 21179: # ! 21180: prch1: movl prbuf,r9 # point to print buffer ! 21181: movl profs,r11 # [get in scratch register] ! 21182: movab cfp$f(r9)[r11],r9# point to next character location ! 21183: movb r6,(r9) # store new character ! 21184: #csc r9 # complete store characters ! 21185: incl profs # bump pointer ! 21186: movl (sp)+,r9 # restore entry xr ! 21187: rsb # return to prtch caller ! 21188: #enp # end procedure prtch ! 21189: #page ! 21190: # ! 21191: # PRTIC -- PRINT TO INTERACTIVE CHANNEL ! 21192: # ! 21193: # PRTIC IS CALLED TO PRINT THE CONTENTS OF THE STANDARD ! 21194: # PRINT BUFFER TO THE INTERACTIVE CHANNEL. IT IS ONLY ! 21195: # CALLED AFTER PRTST HAS SET UP THE STRING FOR PRINTING. ! 21196: # IT DOES NOT CLEAR THE BUFFER. ! 21197: # ! 21198: # JSR PRTIC CALL FOR PRINT ! 21199: # (WA,WB) DESTROYED ! 21200: # ! 21201: prtic: #prc # entry point ! 21202: movl r9,-(sp) # save xr ! 21203: movl prbuf,r9 # point to buffer ! 21204: movl profs,r6 # no of chars ! 21205: jsb syspi # print ! 21206: .long prtc2 # fail return ! 21207: # ! 21208: # RETURN ! 21209: # ! 21210: prtc1: movl (sp)+,r9 # restore xr ! 21211: rsb # return ! 21212: # ! 21213: # ERROR OCCURED ! 21214: # ! 21215: prtc2: clrl erich # prevent looping ! 21216: jmp er_252 # error on printing to interactive channel ! 21217: jmp prtc1 # return ! 21218: #enp # procedure prtic ! 21219: #page ! 21220: # ! 21221: # PRTIS -- PRINT TO INTERACTIVE AND STANDARD PRINTER ! 21222: # ! 21223: # PRTIS PUTS A LINE FROM THE PRINT BUFFER ONTO THE ! 21224: # INTERACTIVE CHANNEL (IF ANY) AND THE STANDARD PRINTER. ! 21225: # IT ALWAYS PRINTS TO THE STANDARD PRINTER BUT DOES ! 21226: # NOT DUPLICATE LINES IF THE STANDARD PRINTER IS ! 21227: # INTERACTIVE. IT CLEARS DOWN THE PRINT BUFFER. ! 21228: # ! 21229: # JSR PRTIS CALL FOR PRINTING ! 21230: # (WA,WB) DESTROYED ! 21231: # ! 21232: prtis: #prc # entry point ! 21233: tstl prich # jump if standard printer is int.ch. ! 21234: bnequ prts1 ! 21235: tstl erich # skip if not doing int. error reps. ! 21236: beqlu prts1 ! 21237: jsb prtic # print to interactive channel ! 21238: # ! 21239: # MERGE AND EXIT ! 21240: # ! 21241: prts1: jsb prtnl # print to standard printer ! 21242: rsb # return ! 21243: #enp # end procedure prtis ! 21244: #page ! 21245: # ! 21246: # PRTIN -- PRINT AN INTEGER ! 21247: # ! 21248: # PRTIN PRINTS THE INTEGER VALUE WHICH IS IN THE INTEGER ! 21249: # ACCUMULATOR. BLOCKS BUILT IN DYNAMIC STORAGE ! 21250: # DURING THIS PROCESS ARE IMMEDIATELY DELETED. ! 21251: # ! 21252: # (IA) INTEGER VALUE TO BE PRINTED ! 21253: # JSR PRTIN CALL TO PRINT INTEGER ! 21254: # (IA,RA) DESTROYED ! 21255: # ! 21256: prtin: #prc # entry point ! 21257: movl r9,-(sp) # save xr ! 21258: jsb icbld # build integer block ! 21259: cmpl r9,dnamb # jump if icblk below dynamic ! 21260: blequ prti1 ! 21261: cmpl r9,dnamp # jump if above dynamic ! 21262: bgequ prti1 ! 21263: movl r9,dnamp # immediately delete it ! 21264: # ! 21265: # DELETE ICBLK FROM DYNAMIC STORE ! 21266: # ! 21267: prti1: movl r9,-(sp) # stack ptr for gtstg ! 21268: jsb gtstg # convert to string ! 21269: .long invalid$ # convert error is impossible ! 21270: movl r9,dnamp # reset pointer to delete scblk ! 21271: jsb prtst # print integer string ! 21272: movl (sp)+,r9 # restore entry xr ! 21273: rsb # return to prtin caller ! 21274: #enp # end procedure prtin ! 21275: #page ! 21276: # ! 21277: # PRTMI -- PRINT MESSAGE AND INTEGER ! 21278: # ! 21279: # PRTMI IS USED TO PRINT MESSAGES TOGETHER WITH AN INTEGER ! 21280: # VALUE STARTING IN COLUMN 15 (USED BY THE ROUTINES AT ! 21281: # THE END OF COMPILATION). ! 21282: # ! 21283: # JSR PRTMI CALL TO PRINT MESSAGE AND INTEGER ! 21284: # ! 21285: prtmi: #prc # entry point ! 21286: jsb prtst # print string message ! 21287: movl $prtmf,profs # set offset to col 15 ! 21288: jsb prtin # print integer ! 21289: jsb prtnl # print line ! 21290: rsb # return to prtmi caller ! 21291: #enp # end procedure prtmi ! 21292: #page ! 21293: # ! 21294: # PRTMX -- AS PRTMI WITH EXTRA COPY TO INTERACTIVE CHAN. ! 21295: # ! 21296: # JSR PRTMX CALL FOR PRINTING ! 21297: # (WA,WB) DESTROYED ! 21298: # ! 21299: prtmx: #prc # entry point ! 21300: jsb prtst # print string message ! 21301: movl $prtmf,profs # set ptr to column 15 ! 21302: jsb prtin # print integer ! 21303: jsb prtis # print line ! 21304: rsb # return ! 21305: #enp # end procedure prtmx ! 21306: #page ! 21307: # ! 21308: # PRTNL -- PRINT NEW LINE (END PRINT LINE) ! 21309: # ! 21310: # PRTNL PRINTS THE CONTENTS OF THE PRINT BUFFER, RESETS ! 21311: # THE BUFFER TO ALL BLANKS AND RESETS THE PRINT POINTER. ! 21312: # ! 21313: # JSR PRTNL CALL TO PRINT LINE ! 21314: # ! 21315: prtnl: #prc # entry point ! 21316: tstl headp # were headers printed ! 21317: bnequ prnl0 ! 21318: jsb prtps # no - print them ! 21319: # ! 21320: # CALL SYSPR ! 21321: # ! 21322: prnl0: movl r9,-(sp) # save entry xr ! 21323: movl r6,prtsa # save wa ! 21324: movl r7,prtsb # save wb ! 21325: movl prbuf,r9 # load pointer to buffer ! 21326: movl profs,r6 # load number of chars in buffer ! 21327: jsb syspr # call system print routine ! 21328: .long prnl2 # jump if failed ! 21329: movl prlnw,r6 # load length of buffer in words ! 21330: addl2 $4*schar,r9 # point to chars of buffer ! 21331: movl nullw,r7 # get word of blanks ! 21332: # ! 21333: # LOOP TO BLANK BUFFER ! 21334: # ! 21335: prnl1: movl r7,(r9)+ # store word of blanks, bump ptr ! 21336: sobgtr r6,prnl1 # loop till all blanked ! 21337: # ! 21338: # EXIT POINT ! 21339: # ! 21340: movl prtsb,r7 # restore wb ! 21341: movl prtsa,r6 # restore wa ! 21342: movl (sp)+,r9 # restore entry xr ! 21343: clrl profs # reset print buffer pointer ! 21344: rsb # return to prtnl caller ! 21345: # ! 21346: # FILE FULL OR NO OUTPUT FILE FOR LOAD MODULE ! 21347: # ! 21348: prnl2: tstl prtef # jump if not first time ! 21349: bnequ prnl3 ! 21350: movl sp,prtef # mark first occurrence ! 21351: jmp er_253 # print limit exceeded on standard output channel ! 21352: # ! 21353: # STOP AT ONCE ! 21354: # ! 21355: prnl3: movl $nini8,r7 # ending code ! 21356: movl kvstn,r6 # statement number ! 21357: jsb sysej # stop ! 21358: #enp # end procedure prtnl ! 21359: #page ! 21360: # ! 21361: # PRTNM -- PRINT VARIABLE NAME ! 21362: # ! 21363: # PRTNM IS USED TO PRINT A CHARACTER REPRESENTATION OF THE ! 21364: # NAME OF A VARIABLE (NOT A VALUE OF DATATYPE NAME) ! 21365: # NAMES OF PSEUDO-VARIABLES MAY NOT BE PASSED TO PRTNM. ! 21366: # ! 21367: # (XL) NAME BASE ! 21368: # (WA) NAME OFFSET ! 21369: # JSR PRTNM CALL TO PRINT NAME ! 21370: # (WB,WC,RA) DESTROYED ! 21371: # ! 21372: prtnm: #prc # entry point (recursive, see prtvl) ! 21373: movl r6,-(sp) # save wa (offset is collectable) ! 21374: movl r9,-(sp) # save entry xr ! 21375: movl r10,-(sp) # save name base ! 21376: cmpl r10,state # jump if not natural variable ! 21377: bgequ prn02 ! 21378: # ! 21379: # HERE FOR NATURAL VARIABLE NAME, RECOGNIZED BY THE FACT ! 21380: # THAT THE NAME BASE POINTS INTO THE STATIC AREA. ! 21381: # ! 21382: movl r10,r9 # point to vrblk ! 21383: jsb prtvn # print name of variable ! 21384: # ! 21385: # COMMON EXIT POINT ! 21386: # ! 21387: prn01: movl (sp)+,r10 # restore name base ! 21388: movl (sp)+,r9 # restore entry value of xr ! 21389: movl (sp)+,r6 # restore wa ! 21390: rsb # return to prtnm caller ! 21391: # ! 21392: # HERE FOR CASE OF NON-NATURAL VARIABLE ! 21393: # ! 21394: prn02: movl r6,r7 # copy name offset ! 21395: cmpl (r10),$b$pdt # jump if array or table ! 21396: bnequ prn03 ! 21397: # ! 21398: # FOR PROGRAM DEFINED DATATYPE, PRT FLD NAME, LEFT PAREN ! 21399: # ! 21400: movl 4*pddfp(r10),r9 # load pointer to dfblk ! 21401: addl2 r6,r9 # add name offset ! 21402: movl 4*pdfof(r9),r9 # load vrblk pointer for field ! 21403: jsb prtvn # print field name ! 21404: movl $ch$pp,r6 # load left paren ! 21405: jsb prtch # print character ! 21406: #page ! 21407: # ! 21408: # PRTNM (CONTINUED) ! 21409: # ! 21410: # NOW WE PRINT AN IDENTIFYING NAME FOR THE OBJECT IF ONE ! 21411: # CAN BE FOUND. THE FOLLOWING CODE SEARCHES FOR A NATURAL ! 21412: # VARIABLE WHICH CONTAINS THIS OBJECT AS VALUE. IF SUCH A ! 21413: # VARIABLE IS FOUND, ITS NAME IS PRINTED, ELSE THE VALUE ! 21414: # OF THE OBJECT (AS PRINTED BY PRTVL) IS USED INSTEAD. ! 21415: # ! 21416: # FIRST WE POINT TO THE PARENT TBBLK IF THIS IS THE CASE OF ! 21417: # A TABLE ELEMENT. TO DO THIS, CHASE DOWN THE TRNXT CHAIN. ! 21418: # ! 21419: prn03: cmpl (r10),$b$tet # jump if we got there (or not te) ! 21420: bnequ prn04 ! 21421: movl 4*tenxt(r10),r10# else move out on chain ! 21422: jmp prn03 # and loop back ! 21423: # ! 21424: # NOW WE ARE READY FOR THE SEARCH. TO SPEED THINGS UP IN ! 21425: # THE CASE OF CALLS FROM DUMP WHERE THE SAME NAME BASE ! 21426: # WILL OCCUR REPEATEDLY WHILE DUMPING AN ARRAY OR TABLE, ! 21427: # WE REMEMBER THE LAST VRBLK POINTER FOUND IN PRNMV. SO ! 21428: # FIRST CHECK TO SEE IF WE HAVE THIS ONE AGAIN. ! 21429: # ! 21430: prn04: movl prnmv,r9 # point to vrblk we found last time ! 21431: movl hshtb,r6 # point to hash table in case not ! 21432: jmp prn07 # jump into search for special check ! 21433: # ! 21434: # LOOP THROUGH HASH SLOTS ! 21435: # ! 21436: prn05: movl r6,r9 # copy slot pointer ! 21437: addl2 $4,r6 # bump slot pointer ! 21438: subl2 $4*vrnxt,r9 # introduce standard vrblk offset ! 21439: # ! 21440: # LOOP THROUGH VRBLKS ON ONE HASH CHAIN ! 21441: # ! 21442: prn06: movl 4*vrnxt(r9),r9 # point to next vrblk on hash chain ! 21443: # ! 21444: # MERGE HERE FIRST TIME TO CHECK BLOCK WE FOUND LAST TIME ! 21445: # ! 21446: prn07: movl r9,r8 # copy vrblk pointer ! 21447: beqlu prn09 # jump if chain end (or prnmv zero) ! 21448: #page ! 21449: # ! 21450: # PRTNM (CONTINUED) ! 21451: # ! 21452: # LOOP TO FIND VALUE (CHASE DOWN POSSIBLE TRBLK CHAIN) ! 21453: # ! 21454: prn08: movl 4*vrval(r9),r9 # load value ! 21455: cmpl (r9),$b$trt # loop if that was a trblk ! 21456: beqlu prn08 ! 21457: # ! 21458: # NOW WE HAVE THE VALUE, IS THIS THE BLOCK WE WANT ! 21459: # ! 21460: cmpl r9,r10 # jump if this matches the name base ! 21461: beqlu prn10 ! 21462: movl r8,r9 # else point back to that vrblk ! 21463: jmp prn06 # and loop back ! 21464: # ! 21465: # HERE TO MOVE TO NEXT HASH SLOT ! 21466: # ! 21467: prn09: cmpl r6,hshte # loop back if more to go ! 21468: blssu prn05 ! 21469: movl r10,r9 # else not found, copy value pointer ! 21470: jsb prtvl # print value ! 21471: jmp prn11 # and merge ahead ! 21472: # ! 21473: # HERE WHEN WE FIND A MATCHING ENTRY ! 21474: # ! 21475: prn10: movl r8,r9 # copy vrblk pointer ! 21476: movl r9,prnmv # save for next time in ! 21477: jsb prtvn # print variable name ! 21478: # ! 21479: # MERGE HERE IF NO ENTRY FOUND ! 21480: # ! 21481: prn11: movl (r10),r8 # load first word of name base ! 21482: cmpl r8,$b$pdt # jump if not program defined ! 21483: bnequ prn13 ! 21484: # ! 21485: # FOR PROGRAM DEFINED DATATYPE, ADD RIGHT PAREN AND EXIT ! 21486: # ! 21487: movl $ch$rp,r6 # load right paren, merge ! 21488: # ! 21489: # MERGE HERE TO PRINT FINAL RIGHT PAREN OR BRACKET ! 21490: # ! 21491: prn12: jsb prtch # print final character ! 21492: movl r7,r6 # restore name offset ! 21493: jmp prn01 # merge back to exit ! 21494: #page ! 21495: # ! 21496: # PRTNM (CONTINUED) ! 21497: # ! 21498: # HERE FOR ARRAY OR TABLE ! 21499: # ! 21500: prn13: movl $ch$bb,r6 # load left bracket ! 21501: jsb prtch # and print it ! 21502: movl (sp),r10 # restore block pointer ! 21503: movl (r10),r8 # load type word again ! 21504: cmpl r8,$b$tet # jump if not table ! 21505: bnequ prn15 ! 21506: # ! 21507: # HERE FOR TABLE, PRINT SUBSCRIPT VALUE ! 21508: # ! 21509: movl 4*tesub(r10),r9 # load subscript value ! 21510: movl r7,r10 # save name offset ! 21511: jsb prtvl # print subscript value ! 21512: movl r10,r7 # restore name offset ! 21513: # ! 21514: # MERGE HERE FROM ARRAY CASE TO PRINT RIGHT BRACKET ! 21515: # ! 21516: prn14: movl $ch$rb,r6 # load right bracket ! 21517: jmp prn12 # merge back to print it ! 21518: # ! 21519: # HERE FOR ARRAY OR VECTOR, TO PRINT SUBSCRIPT(S) ! 21520: # ! 21521: prn15: movl r7,r6 # copy name offset ! 21522: ashl $-2,r6,r6 # convert to words ! 21523: cmpl r8,$b$art # jump if arblk ! 21524: beqlu prn16 ! 21525: # ! 21526: # HERE FOR VECTOR ! 21527: # ! 21528: subl2 $vcvlb,r6 # adjust for standard fields ! 21529: movl r6,r5 # move to integer accum ! 21530: jsb prtin # print linear subscript ! 21531: jmp prn14 # merge back for right bracket ! 21532: #page ! 21533: # ! 21534: # PRTNM (CONTINUED) ! 21535: # ! 21536: # HERE FOR ARRAY. FIRST CALCULATE ABSOLUTE SUBSCRIPT ! 21537: # OFFSETS BY SUCCESSIVE DIVISIONS BY THE DIMENSION VALUES. ! 21538: # THIS MUST BE DONE RIGHT TO LEFT SINCE THE ELEMENTS ARE ! 21539: # STORED ROW-WISE. THE SUBSCRIPTS ARE STACKED AS INTEGERS. ! 21540: # ! 21541: prn16: movl 4*arofs(r10),r8 # load length of bounds info ! 21542: addl2 $4,r8 # adjust for arpro field ! 21543: ashl $-2,r8,r8 # convert to words ! 21544: subl2 r8,r6 # get linear zero-origin subscript ! 21545: movl r6,r5 # get integer value ! 21546: movl 4*arndm(r10),r6 # set num of dimensions as loop count ! 21547: addl2 4*arofs(r10),r10# point past bounds information ! 21548: subl2 $4*arlbd,r10 # set ok offset for proper ptr later ! 21549: # ! 21550: # LOOP TO STACK SUBSCRIPT OFFSETS ! 21551: # ! 21552: prn17: subl2 $4*ardms,r10 # point to next set of bounds ! 21553: movl r5,prnsi # save current offset ! 21554: ashq $-32,r4,r4 # get remainder on dividing by dimens ! 21555: ediv 4*ardim(r10),r4,r11,r5 ! 21556: movl r5,-(sp) # store on stack (one word) ! 21557: movl prnsi,r5 # reload argument ! 21558: divl2 4*ardim(r10),r5 # divide to get quotient ! 21559: sobgtr r6,prn17 # loop till all stacked ! 21560: clrl r9 # set offset to first set of bounds ! 21561: movl 4*arndm(r10),r7 # load count of dims to control loop ! 21562: jmp prn19 # jump into print loop ! 21563: # ! 21564: # LOOP TO PRINT SUBSCRIPTS FROM STACK ADJUSTING BY ADDING ! 21565: # THE APPROPRIATE LOW BOUND VALUE FROM THE ARBLK ! 21566: # ! 21567: prn18: movl $ch$cm,r6 # load a comma ! 21568: jsb prtch # print it ! 21569: # ! 21570: # MERGE HERE FIRST TIME IN (NO COMMA REQUIRED) ! 21571: # ! 21572: prn19: movl (sp)+,r5 # load subscript offset as integer ! 21573: addl2 r9,r10 # point to current lbd ! 21574: addl2 4*arlbd(r10),r5 # add lbd to get signed subscript ! 21575: subl2 r9,r10 # point back to start of arblk ! 21576: jsb prtin # print subscript ! 21577: addl2 $4*ardms,r9 # bump offset to next bounds ! 21578: sobgtr r7,prn18 # loop back till all printed ! 21579: jmp prn14 # merge back to print right bracket ! 21580: #enp # end procedure prtnm ! 21581: #page ! 21582: # ! 21583: # PRTNV -- PRINT NAME VALUE ! 21584: # ! 21585: # PRTNV IS USED BY THE TRACE AND DUMP ROUTINES TO PRINT ! 21586: # A LINE OF THE FORM ! 21587: # ! 21588: # NAME = VALUE ! 21589: # ! 21590: # NOTE THAT THE NAME INVOLVED CAN NEVER BE A PSEUDO-VAR ! 21591: # ! 21592: # (XL) NAME BASE ! 21593: # (WA) NAME OFFSET ! 21594: # JSR PRTNV CALL TO PRINT NAME = VALUE ! 21595: # (WB,WC,RA) DESTROYED ! 21596: # ! 21597: prtnv: #prc # entry point ! 21598: jsb prtnm # print argument name ! 21599: movl r9,-(sp) # save entry xr ! 21600: movl r6,-(sp) # save name offset (collectable) ! 21601: movl $tmbeb,r9 # point to blank equal blank ! 21602: jsb prtst # print it ! 21603: movl r10,r9 # copy name base ! 21604: addl2 r6,r9 # point to value ! 21605: movl (r9),r9 # load value pointer ! 21606: jsb prtvl # print value ! 21607: jsb prtnl # terminate line ! 21608: movl (sp)+,r6 # restore name offset ! 21609: movl (sp)+,r9 # restore entry xr ! 21610: rsb # return to caller ! 21611: #enp # end procedure prtnv ! 21612: #page ! 21613: # ! 21614: # PRTPG -- PRINT A PAGE THROW ! 21615: # ! 21616: # PRINTS A PAGE THROW OR A FEW BLANK LINES ON THE STANDARD ! 21617: # LISTING CHANNEL DEPENDING ON THE LISTING OPTIONS CHOSEN. ! 21618: # ! 21619: # JSR PRTPG CALL FOR PAGE EJECT ! 21620: # ! 21621: prtpg: #prc # entry point ! 21622: cmpl stage,$stgxt # jump if execution time ! 21623: beqlu prp01 ! 21624: tstl lstlc # return if top of page already ! 21625: bnequ 0f ! 21626: jmp prp06 ! 21627: 0: ! 21628: clrl lstlc # clear line count ! 21629: # ! 21630: # CHECK TYPE OF LISTING ! 21631: # ! 21632: prp01: movl r9,-(sp) # preserve xr ! 21633: tstl prstd # eject if flag set ! 21634: bnequ prp02 ! 21635: tstl prich # jump if interactive listing channel ! 21636: bnequ prp03 ! 21637: tstl precl # jump if compact listing ! 21638: beqlu prp03 ! 21639: # ! 21640: # PERFORM AN EJECT ! 21641: # ! 21642: prp02: jsb sysep # eject ! 21643: jmp prp04 # merge ! 21644: # ! 21645: # COMPACT OR INTERACTIVE CHANNEL LISTING. CANT PRINT ! 21646: # BLANKS UNTIL CHECK MADE FOR HEADERS PRINTED AND FLAG SET. ! 21647: # ! 21648: # ! 21649: prp03: movl headp,r9 # remember headp ! 21650: movl sp,headp # set to avoid repeated prtpg calls ! 21651: jsb prtnl # print blank line ! 21652: jsb prtnl # print blank line ! 21653: jsb prtnl # print blank line ! 21654: movl $num03,lstlc # count blank lines ! 21655: movl r9,headp # restore header flag ! 21656: #page ! 21657: # ! 21658: # PRPTG (CONTINUED) ! 21659: # ! 21660: # PRINT THE HEADING ! 21661: # ! 21662: prp04: tstl headp # jump if header listed ! 21663: bnequ prp05 ! 21664: movl sp,headp # mark headers printed ! 21665: movl r10,-(sp) # keep xl ! 21666: movl $headr,r9 # point to listing header ! 21667: jsb prtst # place it ! 21668: jsb sysid # get system identification ! 21669: jsb prtst # append extra chars ! 21670: jsb prtnl # print it ! 21671: movl r10,r9 # extra header line ! 21672: jsb prtst # place it ! 21673: jsb prtnl # print it ! 21674: jsb prtnl # print a blank ! 21675: jsb prtnl # and another ! 21676: addl2 $num04,lstlc # four header lines printed ! 21677: movl (sp)+,r10 # restore xl ! 21678: # ! 21679: # MERGE IF HEADER NOT PRINTED ! 21680: # ! 21681: prp05: movl (sp)+,r9 # restore xr ! 21682: # ! 21683: # RETURN ! 21684: # ! 21685: prp06: rsb # return ! 21686: #enp # end procedure prtpg ! 21687: #page ! 21688: # ! 21689: # PRTPS - PRINT PAGE WITH TEST FOR STANDARD LISTING OPTION ! 21690: # ! 21691: # IF THE STANDARD LISTING OPTION IS SELECTED, INSIST THAT ! 21692: # AN EJECT BE DONE ! 21693: # ! 21694: # JSR PRTPS CALL FOR EJECT ! 21695: # ! 21696: prtps: #prc # entry point ! 21697: movl prsto,prstd # copy option flag ! 21698: jsb prtpg # print page ! 21699: clrl prstd # clear flag ! 21700: rsb # return ! 21701: #enp # end procedure prtps ! 21702: #page ! 21703: # ! 21704: # PRTSN -- PRINT STATEMENT NUMBER ! 21705: # ! 21706: # PRTSN IS USED TO INITIATE A PRINT TRACE LINE BY PRINTING ! 21707: # ASTERISKS AND THE CURRENT STATEMENT NUMBER. THE ACTUAL ! 21708: # FORMAT OF THE OUTPUT GENERATED IS. ! 21709: # ! 21710: # ***NNNNN**** III.....IIII ! 21711: # ! 21712: # NNNNN IS THE STATEMENT NUMBER WITH LEADING ZEROS REPLACED ! 21713: # BY ASTERISKS (E.G. *******9****) ! 21714: # ! 21715: # III...III REPRESENTS A VARIABLE LENGTH OUTPUT CONSISTING ! 21716: # OF A NUMBER OF LETTER I CHARACTERS EQUAL TO FNCLEVEL. ! 21717: # ! 21718: # JSR PRTSN CALL TO PRINT STATEMENT NUMBER ! 21719: # (WC) DESTROYED ! 21720: # ! 21721: prtsn: #prc # entry point ! 21722: movl r9,-(sp) # save entry xr ! 21723: movl r6,prsna # save entry wa ! 21724: movl $tmasb,r9 # point to asterisks ! 21725: jsb prtst # print asterisks ! 21726: movl $num04,profs # point into middle of asterisks ! 21727: movl kvstn,r5 # load statement number as integer ! 21728: jsb prtin # print integer statement number ! 21729: movl $prsnf,profs # point past asterisks plus blank ! 21730: movl kvfnc,r9 # get fnclevel ! 21731: movl $ch$li,r6 # set letter i ! 21732: # ! 21733: # LOOP TO GENERATE LETTER I FNCLEVEL TIMES ! 21734: # ! 21735: prsn1: tstl r9 # jump if all set ! 21736: beqlu prsn2 ! 21737: jsb prtch # else print an i ! 21738: decl r9 # decrement counter ! 21739: jmp prsn1 # loop back ! 21740: # ! 21741: # MERRE WITH ALL LETTER I CHARACTERS GENERATED ! 21742: # ! 21743: prsn2: movl $ch$bl,r6 # get blank ! 21744: jsb prtch # print blank ! 21745: movl prsna,r6 # restore entry wa ! 21746: movl (sp)+,r9 # restore entry xr ! 21747: rsb # return to prtsn caller ! 21748: #enp # end procedure prtsn ! 21749: #page ! 21750: # ! 21751: # PRTST -- PRINT STRING ! 21752: # ! 21753: # PRTST PLACES A STRING OF CHARACTERS IN THE PRINT BUFFER ! 21754: # ! 21755: # SEE PRTNL FOR GLOBAL LOCATIONS USED ! 21756: # ! 21757: # NOTE THAT THE FIRST WORD OF THE BLOCK (NORMALLY B$SCL) ! 21758: # IS NOT USED AND NEED NOT BE SET CORRECTLY (SEE PRTVN) ! 21759: # ! 21760: # (XR) STRING TO BE PRINTED ! 21761: # JSR PRTST CALL TO PRINT STRING ! 21762: # (PROFS) UPDATED PAST CHARS PLACED ! 21763: # ! 21764: prtst: #prc # entry point ! 21765: tstl headp # were headers printed ! 21766: bnequ prst0 ! 21767: jsb prtps # no - print them ! 21768: # ! 21769: # CALL SYSPR ! 21770: # ! 21771: prst0: movl r6,prsva # save wa ! 21772: movl r7,prsvb # save wb ! 21773: clrl r7 # set chars printed count to zero ! 21774: # ! 21775: # LOOP TO PRINT SUCCESSIVE LINES FOR LONG STRING ! 21776: # ! 21777: prst1: movl 4*sclen(r9),r6 # load string length ! 21778: subl2 r7,r6 # subtract count of chars already out ! 21779: bnequ 0f # jump to exit if none left ! 21780: jmp prst4 ! 21781: 0: ! 21782: movl r10,-(sp) # else stack entry xl ! 21783: movl r9,-(sp) # save argument ! 21784: movl r9,r10 # copy for eventual move ! 21785: movl prlen,r9 # load print buffer length ! 21786: subl2 profs,r9 # get chars left in print buffer ! 21787: bnequ prst2 # skip if room left on this line ! 21788: jsb prtnl # else print this line ! 21789: movl prlen,r9 # and set full width available ! 21790: #page ! 21791: # ! 21792: # PRTST (CONTINUED) ! 21793: # ! 21794: # HERE WITH CHARS TO PRINT AND SOME ROOM IN BUFFER ! 21795: # ! 21796: prst2: cmpl r6,r9 # jump if room for rest of string ! 21797: blequ prst3 ! 21798: movl r9,r6 # else set to fill line ! 21799: # ! 21800: # MERGE HERE WITH CHARACTER COUNT IN WA ! 21801: # ! 21802: prst3: movl prbuf,r9 # point to print buffer ! 21803: movab cfp$f(r10)[r7],r10 # point to location in string ! 21804: movl profs,r11 # [get in scratch register] ! 21805: movab cfp$f(r9)[r11],r9# point to location in buffer ! 21806: addl2 r6,r7 # bump string chars count ! 21807: addl2 r6,profs # bump buffer pointer ! 21808: movl r7,prsvc # preserve char counter ! 21809: jsb sbmvc # move characters to buffer ! 21810: movl prsvc,r7 # recover char counter ! 21811: movl (sp)+,r9 # restore argument pointer ! 21812: movl (sp)+,r10 # restore entry xl ! 21813: jmp prst1 # loop back to test for more ! 21814: # ! 21815: # HERE TO EXIT AFTER PRINTING STRING ! 21816: # ! 21817: prst4: movl prsvb,r7 # restore entry wb ! 21818: movl prsva,r6 # restore entry wa ! 21819: rsb # return to prtst caller ! 21820: #enp # end procedure prtst ! 21821: #page ! 21822: # ! 21823: # PRTTR -- PRINT TO TERMINAL ! 21824: # ! 21825: # CALLED TO PRINT CONTENTS OF STANDARD PRINT BUFFER TO ! 21826: # ONLINE TERMINAL. CLEARS BUFFER DOWN AND RESETS PROFS. ! 21827: # ! 21828: # JSR PRTTR CALL FOR PRINT ! 21829: # (WA,WB) DESTROYED ! 21830: # ! 21831: prttr: #prc # entry point ! 21832: movl r9,-(sp) # save xr ! 21833: jsb prtic # print buffer contents ! 21834: movl prbuf,r9 # point to print bfr to clear it ! 21835: movl prlnw,r6 # get buffer length ! 21836: addl2 $4*schar,r9 # point past scblk header ! 21837: movl nullw,r7 # get blanks ! 21838: # ! 21839: # LOOP TO CLEAR BUFFER ! 21840: # ! 21841: prtt1: movl r7,(r9)+ # clear a word ! 21842: sobgtr r6,prtt1 # loop ! 21843: clrl profs # reset profs ! 21844: movl (sp)+,r9 # restore xr ! 21845: rsb # return ! 21846: #enp # end procedure prttr ! 21847: #page ! 21848: # ! 21849: # PRTVL -- PRINT A VALUE ! 21850: # ! 21851: # PRTVL PLACES AN APPROPRIATE CHARACTER REPRESENTATION OF ! 21852: # A DATA VALUE IN THE PRINT BUFFER FOR DUMP/TRACE USE. ! 21853: # ! 21854: # (XR) VALUE TO BE PRINTED ! 21855: # JSR PRTVL CALL TO PRINT VALUE ! 21856: # (WA,WB,WC,RA) DESTROYED ! 21857: # ! 21858: prtvl: #prc # entry point, recursive ! 21859: movl r10,-(sp) # save entry xl ! 21860: movl r9,-(sp) # save argument ! 21861: jsb sbchk # check for stack overflow ! 21862: # ! 21863: # LOOP BACK HERE AFTER FINDING A TRAP BLOCK (TRBLK) ! 21864: # ! 21865: prv01: movl 4*idval(r9),prvsi# copy idval (if any) ! 21866: movl (r9),r10 # load first word of block ! 21867: movzwl -2(r10),r10 # load entry point id ! 21868: casel r10,$0,$bl$$t # switch on block type ! 21869: 5: ! 21870: .word prv05-5b # arblk ! 21871: .word prv15-5b # bcblk ! 21872: .word prv02-5b ! 21873: .word prv02-5b ! 21874: .word prv08-5b # icblk ! 21875: .word prv09-5b # nmblk ! 21876: .word prv02-5b ! 21877: .word prv02-5b ! 21878: .word prv02-5b ! 21879: .word prv08-5b # rcblk ! 21880: .word prv11-5b # scblk ! 21881: .word prv12-5b # seblk ! 21882: .word prv13-5b # tbblk ! 21883: .word prv13-5b # vcblk ! 21884: .word prv02-5b ! 21885: .word prv02-5b ! 21886: .word prv10-5b # pdblk ! 21887: .word prv04-5b # trblk ! 21888: #esw # end of switch on block type ! 21889: # ! 21890: # HERE FOR BLOCKS FOR WHICH WE JUST PRINT DATATYPE NAME ! 21891: # ! 21892: prv02: jsb dtype # get datatype name ! 21893: jsb prtst # print datatype name ! 21894: # ! 21895: # COMMON EXIT POINT ! 21896: # ! 21897: prv03: movl (sp)+,r9 # reload argument ! 21898: movl (sp)+,r10 # restore xl ! 21899: rsb # return to prtvl caller ! 21900: # ! 21901: # HERE FOR TRBLK ! 21902: # ! 21903: prv04: movl 4*trval(r9),r9 # load real value ! 21904: jmp prv01 # and loop back ! 21905: #page ! 21906: # ! 21907: # PRTVL (CONTINUED) ! 21908: # ! 21909: # HERE FOR ARRAY (ARBLK) ! 21910: # ! 21911: # PRINT ARRAY ( PROTOTYPE ) BLANK NUMBER IDVAL ! 21912: # ! 21913: prv05: movl r9,r10 # preserve argument ! 21914: movl $scarr,r9 # point to datatype name (array) ! 21915: jsb prtst # print it ! 21916: movl $ch$pp,r6 # load left paren ! 21917: jsb prtch # print left paren ! 21918: addl2 4*arofs(r10),r10# point to prototype ! 21919: movl (r10),r9 # load prototype ! 21920: jsb prtst # print prototype ! 21921: # ! 21922: # VCBLK, TBBLK, BCBLK MERGE HERE FOR ) BLANK NUMBER IDVAL ! 21923: # ! 21924: prv06: movl $ch$rp,r6 # load right paren ! 21925: jsb prtch # print right paren ! 21926: # ! 21927: # PDBLK MERGES HERE TO PRINT BLANK NUMBER IDVAL ! 21928: # ! 21929: prv07: movl $ch$bl,r6 # load blank ! 21930: jsb prtch # print it ! 21931: movl $ch$nm,r6 # load number sign ! 21932: jsb prtch # print it ! 21933: movl prvsi,r5 # get idval ! 21934: jsb prtin # print id number ! 21935: jmp prv03 # back to exit ! 21936: # ! 21937: # HERE FOR INTEGER (ICBLK), REAL (RCBLK) ! 21938: # ! 21939: # PRINT CHARACTER REPRESENTATION OF VALUE ! 21940: # ! 21941: prv08: movl r9,-(sp) # stack argument for gtstg ! 21942: jsb gtstg # convert to string ! 21943: .long invalid$ # error return is impossible ! 21944: jsb prtst # print the string ! 21945: movl r9,dnamp # delete garbage string from storage ! 21946: jmp prv03 # back to exit ! 21947: #page ! 21948: # ! 21949: # PRTVL (CONTINUED) ! 21950: # ! 21951: # NAME (NMBLK) ! 21952: # ! 21953: # FOR PSEUDO-VARIABLE, JUST PRINT DATATYPE NAME (NAME) ! 21954: # FOR ALL OTHER NAMES, PRINT DOT FOLLOWED BY NAME REP ! 21955: # ! 21956: prv09: movl 4*nmbas(r9),r10 # load name base ! 21957: movl (r10),r6 # load first word of block ! 21958: cmpl r6,$b$kvt # just print name if keyword ! 21959: bnequ 0f ! 21960: jmp prv02 ! 21961: 0: ! 21962: cmpl r6,$b$evt # just print name if expression var ! 21963: bnequ 0f ! 21964: jmp prv02 ! 21965: 0: ! 21966: movl $ch$dt,r6 # else get dot ! 21967: jsb prtch # and print it ! 21968: movl 4*nmofs(r9),r6 # load name offset ! 21969: jsb prtnm # print name ! 21970: jmp prv03 # back to exit ! 21971: # ! 21972: # PROGRAM DATATYPE (PDBLK) ! 21973: # ! 21974: # PRINT DATATYPE NAME CH$BL CH$NM IDVAL ! 21975: # ! 21976: prv10: jsb dtype # get datatype name ! 21977: jsb prtst # print datatype name ! 21978: jmp prv07 # merge back to print id ! 21979: # ! 21980: # HERE FOR STRING (SCBLK) ! 21981: # ! 21982: # PRINT QUOTE STRING-CHARACTERS QUOTE ! 21983: # ! 21984: prv11: movl $ch$sq,r6 # load single quote ! 21985: jsb prtch # print quote ! 21986: jsb prtst # print string value ! 21987: jsb prtch # print another quote ! 21988: jmp prv03 # back to exit ! 21989: #page ! 21990: # ! 21991: # PRTVL (CONTINUED) ! 21992: # ! 21993: # HERE FOR SIMPLE EXPRESSION (SEBLK) ! 21994: # ! 21995: # PRINT ASTERISK VARIABLE-NAME ! 21996: # ! 21997: prv12: movl $ch$as,r6 # load asterisk ! 21998: jsb prtch # print asterisk ! 21999: movl 4*sevar(r9),r9 # load variable pointer ! 22000: jsb prtvn # print variable name ! 22001: jmp prv03 # jump back to exit ! 22002: # ! 22003: # HERE FOR TABLE (TBBLK) AND ARRAY (VCBLK) ! 22004: # ! 22005: # PRINT DATATYPE ( PROTOTYPE ) BLANK NUMBER IDVAL ! 22006: # ! 22007: prv13: movl r9,r10 # preserve argument ! 22008: jsb dtype # get datatype name ! 22009: jsb prtst # print datatype name ! 22010: movl $ch$pp,r6 # load left paren ! 22011: jsb prtch # print left paren ! 22012: movl 4*tblen(r10),r6 # load length of block (=vclen) ! 22013: ashl $-2,r6,r6 # convert to word count ! 22014: subl2 $tbsi$,r6 # allow for standard fields ! 22015: cmpl (r10),$b$tbt # jump if table ! 22016: beqlu prv14 ! 22017: addl2 $vctbd,r6 # for vcblk, adjust size ! 22018: # ! 22019: # PRINT PROTOTYPE ! 22020: # ! 22021: prv14: movl r6,r5 # move as integer ! 22022: jsb prtin # print integer prototype ! 22023: jmp prv06 # merge back for rest ! 22024: #page ! 22025: # ! 22026: # PRTVL (CONTINUED) ! 22027: # ! 22028: # HERE FOR BUFFER (BCBLK) ! 22029: # ! 22030: prv15: movl r9,r10 # preserve argument ! 22031: movl $scbuf,r9 # point to datatype name (buffer) ! 22032: jsb prtst # print it ! 22033: movl $ch$pp,r6 # load left paren ! 22034: jsb prtch # print left paren ! 22035: movl 4*bcbuf(r10),r9 # point to bfblk ! 22036: movl 4*bfalc(r9),r5 # load allocation size ! 22037: jsb prtin # print it ! 22038: movl $ch$cm,r6 # load comma ! 22039: jsb prtch # print it ! 22040: movl 4*bclen(r10),r5 # load defined length ! 22041: jsb prtin # print it ! 22042: jmp prv06 # merge to finish up ! 22043: #enp # end procedure prtvl ! 22044: #page ! 22045: # ! 22046: # PRTVN -- PRINT NATURAL VARIABLE NAME ! 22047: # ! 22048: # PRTVN PRINTS THE NAME OF A NATURAL VARIABLE ! 22049: # ! 22050: # (XR) POINTER TO VRBLK ! 22051: # JSR PRTVN CALL TO PRINT VARIABLE NAME ! 22052: # ! 22053: prtvn: #prc # entry point ! 22054: movl r9,-(sp) # stack vrblk pointer ! 22055: addl2 $4*vrsof,r9 # point to possible string name ! 22056: tstl 4*sclen(r9) # jump if not system variable ! 22057: bnequ prvn1 ! 22058: movl 4*vrsvo(r9),r9 # point to svblk with name ! 22059: # ! 22060: # MERGE HERE WITH DUMMY SCBLK POINTER IN XR ! 22061: # ! 22062: prvn1: jsb prtst # print string name of variable ! 22063: movl (sp)+,r9 # restore vrblk pointer ! 22064: rsb # return to prtvn caller ! 22065: #enp # end procedure prtvn ! 22066: #page ! 22067: # ! 22068: # RCBLD -- BUILD A REAL BLOCK ! 22069: # ! 22070: # (RA) REAL VALUE FOR RCBLK ! 22071: # JSR RCBLD CALL TO BUILD REAL BLOCK ! 22072: # (XR) POINTER TO RESULT RCBLK ! 22073: # (WA) DESTROYED ! 22074: # ! 22075: rcbld: #prc # entry point ! 22076: movl dnamp,r9 # load pointer to next available loc ! 22077: addl2 $4*rcsi$,r9 # point past new rcblk ! 22078: cmpl r9,dname # jump if there is room ! 22079: blequ rcbl1 ! 22080: movl $4*rcsi$,r6 # else load rcblk length ! 22081: jsb alloc # use standard allocator to get block ! 22082: addl2 r6,r9 # point past block to merge ! 22083: # ! 22084: # MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED ! 22085: # ! 22086: rcbl1: movl r9,dnamp # set new pointer ! 22087: subl2 $4*rcsi$,r9 # point back to start of block ! 22088: movl $b$rcl,(r9) # store type word ! 22089: movf r2,4*rcval(r9) # store real value in rcblk ! 22090: rsb # return to rcbld caller ! 22091: #enp # end procedure rcbld ! 22092: #page ! 22093: # ! 22094: # READR -- READ NEXT SOURCE IMAGE AT COMPILE TIME ! 22095: # ! 22096: # READR IS USED TO READ THE NEXT SOURCE IMAGE. TO PROCESS ! 22097: # CONTINUATION CARDS PROPERLY, THE COMPILER MUST READ ONE ! 22098: # LINE AHEAD. THUS READR DOES NOT DESTROY THE CURRENT IMAGE ! 22099: # SEE ALSO THE NEXTS ROUTINE WHICH ACTUALLY GETS THE IMAGE. ! 22100: # ! 22101: # JSR READR CALL TO READ NEXT IMAGE ! 22102: # (XR) PTR TO NEXT IMAGE (0 IF NONE) ! 22103: # (R$CNI) COPY OF POINTER ! 22104: # (WA,WB,WC,XL) DESTROYED ! 22105: # ! 22106: readr: #prc # entry point ! 22107: movl r$cni,r9 # get ptr to next image ! 22108: bnequ read3 # exit if already read ! 22109: cmpl stage,$stgic # exit if not initial compile ! 22110: bnequ read3 ! 22111: movl cswin,r6 # max read length ! 22112: jsb alocs # allocate buffer ! 22113: jsb sysrd # read input image ! 22114: .long read4 # jump if end of file ! 22115: movl sp,r7 # set trimr to perform trim ! 22116: cmpl 4*sclen(r9),cswin# use smaller of string lnth .. ! 22117: blequ read1 ! 22118: movl cswin,4*sclen(r9)# ... and xxx of -inxxx ! 22119: # ! 22120: # PERFORM THE TRIM ! 22121: # ! 22122: read1: jsb trimr # trim trailing blanks ! 22123: # ! 22124: # MERGE HERE AFTER READ ! 22125: # ! 22126: read2: movl r9,r$cni # store copy of pointer ! 22127: # ! 22128: # MERGE HERE IF NO READ ATTEMPTED ! 22129: # ! 22130: read3: rsb # return to readr caller ! 22131: # ! 22132: # HERE ON END OF FILE ! 22133: # ! 22134: read4: movl r9,dnamp # pop unused scblk ! 22135: clrl r9 # zero ptr as result ! 22136: jmp read2 # merge ! 22137: #enp # end procedure readr ! 22138: #page ! 22139: # ! 22140: # SBSTR -- BUILD A SUBSTRING ! 22141: # ! 22142: # (XL) PTR TO SCBLK/BFBLK WITH CHARS ! 22143: # (WA) NUMBER OF CHARS IN SUBSTRING ! 22144: # (WB) OFFSET TO FIRST CHAR IN SCBLK ! 22145: # JSR SBSTR CALL TO BUILD SUBSTRING ! 22146: # (XR) PTR TO NEW SCBLK WITH SUBSTRING ! 22147: # (XL) ZERO ! 22148: # (WA,WB,WC,XL,IA) DESTROYED ! 22149: # ! 22150: # NOTE THAT SBSTR IS CALLED WITH A DUMMY STRING POINTER ! 22151: # (POINTING INTO A VRBLK OR SVBLK) TO COPY THE NAME OF A ! 22152: # VARIABLE AS A STANDARD STRING VALUE. ! 22153: # ! 22154: sbstr: #prc # entry point ! 22155: tstl r6 # jump if null substring ! 22156: beqlu sbst2 ! 22157: jsb alocs # else allocate scblk ! 22158: movl r8,r6 # move number of characters ! 22159: movl r9,r8 # save ptr to new scblk ! 22160: movab cfp$f(r10)[r7],r10 # prepare to load chars from old blk ! 22161: movab cfp$f(r9),r9 # prepare to store chars in new blk ! 22162: jsb sbmvc # move characters to new string ! 22163: movl r8,r9 # then restore scblk pointer ! 22164: # ! 22165: # RETURN POINT ! 22166: # ! 22167: sbst1: clrl r10 # clear garbage pointer in xl ! 22168: rsb # return to sbstr caller ! 22169: # ! 22170: # HERE FOR NULL SUBSTRING ! 22171: # ! 22172: sbst2: movl $nulls,r9 # set null string as result ! 22173: jmp sbst1 # return ! 22174: #enp # end procedure sbstr ! 22175: #page ! 22176: # ! 22177: # SCANE -- SCAN AN ELEMENT ! 22178: # ! 22179: # SCANE IS CALLED AT COMPILE TIME (BY EXPAN ,CMPIL,CNCRD) ! 22180: # TO SCAN ONE ELEMENT FROM THE INPUT IMAGE. ! 22181: # ! 22182: # (SCNCC) NON-ZERO IF CALLED FROM CNCRD ! 22183: # JSR SCANE CALL TO SCAN ELEMENT ! 22184: # (XR) RESULT POINTER (SEE BELOW) ! 22185: # (XL) SYNTAX TYPE CODE (T$XXX) ! 22186: # ! 22187: # THE FOLLOWING GLOBAL LOCATIONS ARE USED. ! 22188: # ! 22189: # R$CIM POINTER TO STRING BLOCK (SCBLK) ! 22190: # FOR CURRENT INPUT IMAGE. ! 22191: # ! 22192: # R$CNI POINTER TO NEXT INPUT IMAGE STRING ! 22193: # POINTER (ZERO IF NONE). ! 22194: # ! 22195: # R$SCP SAVE POINTER (EXIT XR) FROM LAST ! 22196: # CALL IN CASE RESCAN IS SET. ! 22197: # ! 22198: # SCNBL THIS LOCATION IS SET NON-ZERO ON ! 22199: # EXIT IF SCANE SCANNED PAST BLANKS ! 22200: # BEFORE LOCATING THE CURRENT ELEMENT ! 22201: # THE END OF A LINE COUNTS AS BLANKS. ! 22202: # ! 22203: # SCNCC CNCRD SETS THIS NON-ZERO TO SCAN ! 22204: # CONTROL CARD NAMES AND CLEARS IT ! 22205: # ON RETURN ! 22206: # ! 22207: # SCNIL LENGTH OF CURRENT INPUT IMAGE ! 22208: # ! 22209: # SCNGO IF SET NON-ZERO ON ENTRY, F AND S ! 22210: # ARE RETURNED AS SEPARATE SYNTAX ! 22211: # TYPES (NOT LETTERS) (GOTO PRO- ! 22212: # CESSING). SCNGO IS RESET ON EXIT. ! 22213: # ! 22214: # SCNPT OFFSET TO CURRENT LOC IN R$CIM ! 22215: # ! 22216: # SCNRS IF SET NON-ZERO ON ENTRY, SCANE ! 22217: # RETURNS THE SAME RESULT AS ON THE ! 22218: # LAST CALL (RESCAN). SCNRS IS RESET ! 22219: # ON EXIT FROM ANY CALL TO SCANE. ! 22220: # ! 22221: # SCNTP SAVE SYNTAX TYPE FROM LAST ! 22222: # CALL (IN CASE RESCAN IS SET). ! 22223: #page ! 22224: # ! 22225: # SCANE (CONTINUED) ! 22226: # ! 22227: # ! 22228: # ! 22229: # ELEMENT SCANNED XL XR ! 22230: # --------------- -- -- ! 22231: # ! 22232: # CONTROL CARD NAME 0 POINTER TO SCBLK FOR NAME ! 22233: # ! 22234: # UNARY OPERATOR T$UOP PTR TO OPERATOR DVBLK ! 22235: # ! 22236: # LEFT PAREN T$LPR T$LPR ! 22237: # ! 22238: # LEFT BRACKET T$LBR T$LBR ! 22239: # ! 22240: # COMMA T$CMA T$CMA ! 22241: # ! 22242: # FUNCTION CALL T$FNC PTR TO FUNCTION VRBLK ! 22243: # ! 22244: # VARIABLE T$VAR PTR TO VRBLK ! 22245: # ! 22246: # STRING CONSTANT T$CON PTR TO SCBLK ! 22247: # ! 22248: # INTEGER CONSTANT T$CON PTR TO ICBLK ! 22249: # ! 22250: # REAL CONSTANT T$CON PTR TO RCBLK ! 22251: # ! 22252: # BINARY OPERATOR T$BOP PTR TO OPERATOR DVBLK ! 22253: # ! 22254: # RIGHT PAREN T$RPR T$RPR ! 22255: # ! 22256: # RIGHT BRACKET T$RBR T$RBR ! 22257: # ! 22258: # COLON T$COL T$COL ! 22259: # ! 22260: # SEMI-COLON T$SMC T$SMC ! 22261: # ! 22262: # F (SCNGO NE 0) T$FGO T$FGO ! 22263: # ! 22264: # S (SCNGO NE 0) T$SGO T$SGO ! 22265: #page ! 22266: # ! 22267: # SCANE (CONTINUED) ! 22268: # ! 22269: # ENTRY POINT ! 22270: # ! 22271: scane: #prc # entry point ! 22272: clrl scnbl # reset blanks flag ! 22273: movl r6,scnsa # save wa ! 22274: movl r7,scnsb # save wb ! 22275: movl r8,scnsc # save wc ! 22276: tstl scnrs # jump if no rescan ! 22277: beqlu scn03 ! 22278: # ! 22279: # HERE FOR RESCAN REQUEST ! 22280: # ! 22281: movl scntp,r10 # set previous returned scan type ! 22282: movl r$scp,r9 # set previous returned pointer ! 22283: clrl scnrs # reset rescan switch ! 22284: jmp scn13 # jump to exit ! 22285: # ! 22286: # COME HERE TO READ NEW IMAGE TO TEST FOR CONTINUATION ! 22287: # ! 22288: scn01: jsb readr # read next image ! 22289: movl $4*dvubs,r7 # set wb for not reading name ! 22290: tstl r9 # treat as semi-colon if none ! 22291: bnequ 0f ! 22292: jmp scn30 ! 22293: 0: ! 22294: movab cfp$f(r9),r9 # else point to first character ! 22295: movzbl (r9),r8 # load first character ! 22296: cmpl r8,$ch$dt # jump if dot for continuation ! 22297: beqlu scn02 ! 22298: cmpl r8,$ch$pl # else treat as semicolon unless plus ! 22299: beqlu 0f ! 22300: jmp scn30 ! 22301: 0: ! 22302: # ! 22303: # HERE FOR CONTINUATION LINE ! 22304: # ! 22305: scn02: jsb nexts # acquire next source image ! 22306: movl $num01,scnpt # set scan pointer past continuation ! 22307: movl sp,scnbl # set blanks flag ! 22308: #page ! 22309: # ! 22310: # SCANE (CONTINUED) ! 22311: # ! 22312: # MERGE HERE TO SCAN NEXT ELEMENT ON CURRENT LINE ! 22313: # ! 22314: scn03: movl scnpt,r6 # load current offset ! 22315: cmpl r6,scnil # check continuation if end ! 22316: bnequ 0f ! 22317: jmp scn01 ! 22318: 0: ! 22319: movl r$cim,r10 # point to current line ! 22320: movab cfp$f(r10)[r6],r10 # point to current character ! 22321: movl r6,scnse # set start of element location ! 22322: movl $opdvs,r8 # point to operator dv list ! 22323: movl $4*dvubs,r7 # set constant for operator circuit ! 22324: jmp scn06 # start scanning ! 22325: # ! 22326: # LOOP HERE TO IGNORE LEADING BLANKS AND TABS ! 22327: # ! 22328: scn05: tstl r7 # jump if trailing ! 22329: bnequ 0f ! 22330: jmp scn10 ! 22331: 0: ! 22332: incl scnse # increment start of element ! 22333: cmpl r6,scnil # jump if end of image ! 22334: bnequ 0f ! 22335: jmp scn01 ! 22336: 0: ! 22337: movl sp,scnbl # note blanks seen ! 22338: # ! 22339: # THE FOLLOWING JUMP IS USED REPEATEDLY FOR SCANNING OUT ! 22340: # THE CHARACTERS OF A NUMERIC CONSTANT OR VARIABLE NAME. ! 22341: # THE REGISTERS ARE USED AS FOLLOWS. ! 22342: # ! 22343: # (XR) SCRATCH ! 22344: # (XL) PTR TO NEXT CHARACTER ! 22345: # (WA) CURRENT SCAN OFFSET ! 22346: # (WB) *DVUBS (0 IF SCANNING NAME,CONST) ! 22347: # (WC) =OPDVS (0 IF SCANNING CONSTANT) ! 22348: # ! 22349: scn06: movzbl (r10)+,r9 # get next character ! 22350: incl r6 # bump scan offset ! 22351: movl r6,scnpt # store offset past char scanned ! 22352: cmpl $cfp$u,r9 # quick check for other char ! 22353: bgtru 0f ! 22354: jmp scn07 ! 22355: 0: ! 22356: casel r9,$0,$cfp$u # switch on scanned character ! 22357: 5: ! 22358: # ! 22359: # SWITCH TABLE FOR SWITCH ON CHARACTER ! 22360: # ! 22361: #page ! 22362: # ! 22363: # SCANE (CONTINUED) ! 22364: # ! 22365: #page ! 22366: # ! 22367: # SCANE (CONTINUED) ! 22368: # ! 22369: .word scn07-5b ! 22370: .word scn07-5b ! 22371: .word scn07-5b ! 22372: .word scn07-5b ! 22373: .word scn07-5b ! 22374: .word scn07-5b ! 22375: .word scn07-5b ! 22376: .word scn07-5b ! 22377: .word scn07-5b ! 22378: .word scn05-5b # horizontal tab ! 22379: .word scn07-5b ! 22380: .word scn07-5b ! 22381: .word scn07-5b ! 22382: .word scn07-5b ! 22383: .word scn07-5b ! 22384: .word scn07-5b ! 22385: .word scn07-5b ! 22386: .word scn07-5b ! 22387: .word scn07-5b ! 22388: .word scn07-5b ! 22389: .word scn07-5b ! 22390: .word scn07-5b ! 22391: .word scn07-5b ! 22392: .word scn07-5b ! 22393: .word scn07-5b ! 22394: .word scn07-5b ! 22395: .word scn07-5b ! 22396: .word scn07-5b ! 22397: .word scn07-5b ! 22398: .word scn07-5b ! 22399: .word scn07-5b ! 22400: .word scn07-5b ! 22401: .word scn05-5b # blank ! 22402: .word scn37-5b # exclamation mark ! 22403: .word scn17-5b # double quote ! 22404: .word scn41-5b # number sign ! 22405: .word scn36-5b # dollar ! 22406: .word scn38-5b # percent ! 22407: .word scn44-5b # ampersand ! 22408: .word scn16-5b # single quote ! 22409: .word scn25-5b # left paren ! 22410: .word scn26-5b # right paren ! 22411: .word scn49-5b # asterisk ! 22412: .word scn33-5b # plus ! 22413: .word scn31-5b # comma ! 22414: .word scn34-5b # minus ! 22415: .word scn32-5b # dot ! 22416: .word scn40-5b # slash ! 22417: .word scn08-5b # digit 0 ! 22418: .word scn08-5b # digit 1 ! 22419: .word scn08-5b # digit 2 ! 22420: .word scn08-5b # digit 3 ! 22421: .word scn08-5b # digit 4 ! 22422: .word scn08-5b # digit 5 ! 22423: .word scn08-5b # digit 6 ! 22424: .word scn08-5b # digit 7 ! 22425: .word scn08-5b # digit 8 ! 22426: .word scn08-5b # digit 9 ! 22427: .word scn29-5b # colon ! 22428: .word scn30-5b # semi-colon ! 22429: .word scn28-5b # left bracket ! 22430: .word scn46-5b # equal ! 22431: .word scn27-5b # right bracket ! 22432: .word scn45-5b # question mark ! 22433: .word scn42-5b # at ! 22434: .word scn09-5b # letter a ! 22435: .word scn09-5b # letter b ! 22436: .word scn09-5b # letter c ! 22437: .word scn09-5b # letter d ! 22438: .word scn09-5b # letter e ! 22439: .word scn20-5b # letter f ! 22440: .word scn09-5b # letter g ! 22441: .word scn09-5b # letter h ! 22442: .word scn09-5b # letter i ! 22443: .word scn09-5b # letter j ! 22444: .word scn09-5b # letter k ! 22445: .word scn09-5b # letter l ! 22446: .word scn09-5b # letter m ! 22447: .word scn09-5b # letter n ! 22448: .word scn09-5b # letter o ! 22449: .word scn09-5b # letter p ! 22450: .word scn09-5b # letter q ! 22451: .word scn09-5b # letter r ! 22452: .word scn21-5b # letter s ! 22453: .word scn09-5b # letter t ! 22454: .word scn09-5b # letter u ! 22455: .word scn09-5b # letter v ! 22456: .word scn09-5b # letter w ! 22457: .word scn09-5b # letter x ! 22458: .word scn09-5b # letter y ! 22459: .word scn09-5b # letter z ! 22460: .word scn28-5b # left bracket ! 22461: .word scn07-5b ! 22462: .word scn27-5b # right bracket ! 22463: .word scn07-5b ! 22464: .word scn24-5b # underline ! 22465: .word scn07-5b ! 22466: .word scn09-5b # shifted a ! 22467: .word scn09-5b # shifted b ! 22468: .word scn09-5b # shifted c ! 22469: .word scn09-5b # shifted d ! 22470: .word scn09-5b # shifted e ! 22471: .word scn20-5b # shifted f ! 22472: .word scn09-5b # shifted g ! 22473: .word scn09-5b # shifted h ! 22474: .word scn09-5b # shifted i ! 22475: .word scn09-5b # shifted j ! 22476: .word scn09-5b # shifted k ! 22477: .word scn09-5b # shifted l ! 22478: .word scn09-5b # shifted m ! 22479: .word scn09-5b # shifted n ! 22480: .word scn09-5b # shifted o ! 22481: .word scn09-5b # shifted p ! 22482: .word scn09-5b # shifted q ! 22483: .word scn09-5b # shifted r ! 22484: .word scn21-5b # shifted s ! 22485: .word scn09-5b # shifted t ! 22486: .word scn09-5b # shifted u ! 22487: .word scn09-5b # shifted v ! 22488: .word scn09-5b # shifted w ! 22489: .word scn09-5b # shifted x ! 22490: .word scn09-5b # shifted y ! 22491: .word scn09-5b # shifted z ! 22492: .word scn07-5b ! 22493: .word scn43-5b # vertical bar ! 22494: .word scn07-5b ! 22495: .word scn35-5b # not ! 22496: .word scn07-5b ! 22497: #esw # end switch on character ! 22498: # ! 22499: # HERE FOR ILLEGAL CHARACTER (UNDERLINE MERGES) ! 22500: # ! 22501: scn07: tstl r7 # jump if scanning name or constant ! 22502: bnequ 0f ! 22503: jmp scn10 ! 22504: 0: ! 22505: jmp er_230 # syntax error. illegal character ! 22506: #page ! 22507: # ! 22508: # SCANE (CONTINUED) ! 22509: # ! 22510: # HERE FOR DIGITS 0-9 ! 22511: # ! 22512: scn08: tstl r7 # keep scanning if name/constant ! 22513: bnequ 0f ! 22514: jmp scn09 ! 22515: 0: ! 22516: clrl r8 # else set flag for scanning constant ! 22517: # ! 22518: # HERE FOR LETTER. LOOP HERE WHEN SCANNING NAME/CONSTANT ! 22519: # ! 22520: scn09: cmpl r6,scnil # jump if end of image ! 22521: beqlu scn11 ! 22522: clrl r7 # set flag for scanning name/const ! 22523: jmp scn06 # merge back to continue scan ! 22524: # ! 22525: # COME HERE FOR DELIMITER ENDING NAME OR CONSTANT ! 22526: # ! 22527: scn10: decl r6 # reset offset to point to delimiter ! 22528: # ! 22529: # COME HERE AFTER FINISHING SCAN OF NAME OR CONSTANT ! 22530: # ! 22531: scn11: movl r6,scnpt # store updated scan offset ! 22532: movl scnse,r7 # point to start of element ! 22533: subl2 r7,r6 # get number of characters ! 22534: movl r$cim,r10 # point to line image ! 22535: tstl r8 # jump if name ! 22536: bnequ scn15 ! 22537: # ! 22538: # HERE AFTER SCANNING OUT NUMERIC CONSTANT ! 22539: # ! 22540: jsb sbstr # get string for constant ! 22541: movl r9,dnamp # delete from storage (not needed) ! 22542: jsb gtnum # convert to numeric ! 22543: .long scn14 # jump if conversion failure ! 22544: # ! 22545: # MERGE HERE TO EXIT WITH CONSTANT ! 22546: # ! 22547: scn12: movl $t$con,r10 # set result type of constant ! 22548: #page ! 22549: # ! 22550: # SCANE (CONTINUED) ! 22551: # ! 22552: # COMMON EXIT POINT (XR,XL) SET ! 22553: # ! 22554: scn13: movl scnsa,r6 # restore wa ! 22555: movl scnsb,r7 # restore wb ! 22556: movl scnsc,r8 # restore wc ! 22557: movl r9,r$scp # save xr in case rescan ! 22558: movl r10,scntp # save xl in case rescan ! 22559: clrl scngo # reset possible goto flag ! 22560: rsb # return to scane caller ! 22561: # ! 22562: # HERE IF CONVERSION ERROR ON NUMERIC ITEM ! 22563: # ! 22564: scn14: jmp er_231 # syntax error. invalid numeric item ! 22565: # ! 22566: # HERE AFTER SCANNING OUT VARIABLE NAME ! 22567: # ! 22568: scn15: jsb sbstr # build string name of variable ! 22569: tstl scncc # return if cncrd call ! 22570: beqlu 0f ! 22571: jmp scn13 ! 22572: 0: ! 22573: jsb gtnvr # locate/build vrblk ! 22574: .long invalid$ # dummy (unused) error return ! 22575: movl $t$var,r10 # set type as variable ! 22576: jmp scn13 # back to exit ! 22577: # ! 22578: # HERE FOR SINGLE QUOTE (START OF STRING CONSTANT) ! 22579: # ! 22580: scn16: tstl r7 # terminator if scanning name or cnst ! 22581: bnequ 0f ! 22582: jmp scn10 ! 22583: 0: ! 22584: movl $ch$sq,r7 # set terminator as single quote ! 22585: jmp scn18 # merge ! 22586: # ! 22587: # HERE FOR DOUBLE QUOTE (START OF STRING CONSTANT) ! 22588: # ! 22589: scn17: tstl r7 # terminator if scanning name or cnst ! 22590: bnequ 0f ! 22591: jmp scn10 ! 22592: 0: ! 22593: movl $ch$dq,r7 # set double quote terminator, merge ! 22594: # ! 22595: # LOOP TO SCAN OUT STRING CONSTANT ! 22596: # ! 22597: scn18: cmpl r6,scnil # error if end of image ! 22598: beqlu scn19 ! 22599: movzbl (r10)+,r8 # else load next character ! 22600: incl r6 # bump offset ! 22601: cmpl r8,r7 # loop back if not terminator ! 22602: bnequ scn18 ! 22603: #page ! 22604: # ! 22605: # SCANE (CONTINUED) ! 22606: # ! 22607: # HERE AFTER SCANNING OUT STRING CONSTANT ! 22608: # ! 22609: movl scnpt,r7 # point to first character ! 22610: movl r6,scnpt # save offset past final quote ! 22611: decl r6 # point back past last character ! 22612: subl2 r7,r6 # get number of characters ! 22613: movl r$cim,r10 # point to input image ! 22614: jsb sbstr # build substring value ! 22615: jmp scn12 # back to exit with constant result ! 22616: # ! 22617: # HERE IF NO MATCHING QUOTE FOUND ! 22618: # ! 22619: scn19: movl r6,scnpt # set updated scan pointer ! 22620: jmp er_232 # syntax error. unmatched string quote ! 22621: # ! 22622: # HERE FOR F (POSSIBLE FAILURE GOTO) ! 22623: # ! 22624: scn20: movl $t$fgo,r9 # set return code for fail goto ! 22625: jmp scn22 # jump to merge ! 22626: # ! 22627: # HERE FOR S (POSSIBLE SUCCESS GOTO) ! 22628: # ! 22629: scn21: movl $t$sgo,r9 # set success goto as return code ! 22630: # ! 22631: # SPECIAL GOTO CASES MERGE HERE ! 22632: # ! 22633: scn22: tstl scngo # treat as normal letter if not goto ! 22634: bnequ 0f ! 22635: jmp scn09 ! 22636: 0: ! 22637: # ! 22638: # MERGE HERE FOR SPECIAL CHARACTER EXIT ! 22639: # ! 22640: scn23: tstl r7 # jump if end of name/constant ! 22641: bnequ 0f ! 22642: jmp scn10 ! 22643: 0: ! 22644: movl r9,r10 # else copy code ! 22645: jmp scn13 # and jump to exit ! 22646: # ! 22647: # HERE FOR UNDERLINE ! 22648: # ! 22649: scn24: tstl r7 # part of name if scanning name ! 22650: bnequ 0f ! 22651: jmp scn09 ! 22652: 0: ! 22653: jmp scn07 # else illegal ! 22654: #page ! 22655: # ! 22656: # SCANE (CONTINUED) ! 22657: # ! 22658: # HERE FOR LEFT PAREN ! 22659: # ! 22660: scn25: movl $t$lpr,r9 # set left paren return code ! 22661: tstl r7 # return left paren unless name ! 22662: bnequ scn23 ! 22663: tstl r8 # delimiter if scanning constant ! 22664: bnequ 0f ! 22665: jmp scn10 ! 22666: 0: ! 22667: # ! 22668: # HERE FOR LEFT PAREN AFTER NAME (FUNCTION CALL) ! 22669: # ! 22670: movl scnse,r7 # point to start of name ! 22671: movl r6,scnpt # set pointer past left paren ! 22672: decl r6 # point back past last char of name ! 22673: subl2 r7,r6 # get name length ! 22674: movl r$cim,r10 # point to input image ! 22675: jsb sbstr # get string name for function ! 22676: jsb gtnvr # locate/build vrblk ! 22677: .long invalid$ # dummy (unused) error return ! 22678: movl $t$fnc,r10 # set code for function call ! 22679: jmp scn13 # back to exit ! 22680: # ! 22681: # PROCESSING FOR SPECIAL CHARACTERS ! 22682: # ! 22683: scn26: movl $t$rpr,r9 # right paren, set code ! 22684: jmp scn23 # take special character exit ! 22685: # ! 22686: scn27: movl $t$rbr,r9 # right bracket, set code ! 22687: jmp scn23 # take special character exit ! 22688: # ! 22689: scn28: movl $t$lbr,r9 # left bracket, set code ! 22690: jmp scn23 # take special character exit ! 22691: # ! 22692: scn29: movl $t$col,r9 # colon, set code ! 22693: jmp scn23 # take special character exit ! 22694: # ! 22695: scn30: movl $t$smc,r9 # semi-colon, set code ! 22696: jmp scn23 # take special character exit ! 22697: # ! 22698: scn31: movl $t$cma,r9 # comma, set code ! 22699: jmp scn23 # take special character exit ! 22700: #page ! 22701: # ! 22702: # SCANE (CONTINUED) ! 22703: # ! 22704: # HERE FOR OPERATORS. ON ENTRY, WC POINTS TO THE TABLE OF ! 22705: # OPERATOR DOPE VECTORS AND WB IS THE INCREMENT TO STEP ! 22706: # TO THE NEXT PAIR (BINARY/UNARY) OF DOPE VECTORS IN THE ! 22707: # LIST. ON REACHING SCN46, THE POINTER HAS BEEN ADJUSTED TO ! 22708: # POINT TO THE APPROPRIATE PAIR OF DOPE VECTORS. ! 22709: # THE FIRST THREE ENTRIES ARE SPECIAL SINCE THEY CAN OCCUR ! 22710: # AS PART OF A VARIABLE NAME (.) OR CONSTANT (.+-). ! 22711: # ! 22712: scn32: tstl r7 # dot can be part of name or constant ! 22713: bnequ 0f ! 22714: jmp scn09 ! 22715: 0: ! 22716: addl2 r7,r8 # else bump pointer ! 22717: # ! 22718: scn33: tstl r8 # plus can be part of constant ! 22719: bnequ 0f ! 22720: jmp scn09 ! 22721: 0: ! 22722: tstl r7 # plus cannot be part of name ! 22723: bnequ 0f ! 22724: jmp scn48 ! 22725: 0: ! 22726: addl2 r7,r8 # else bump pointer ! 22727: # ! 22728: scn34: tstl r8 # minus can be part of constant ! 22729: bnequ 0f ! 22730: jmp scn09 ! 22731: 0: ! 22732: tstl r7 # minus cannot be part of name ! 22733: bnequ 0f ! 22734: jmp scn48 ! 22735: 0: ! 22736: addl2 r7,r8 # else bump pointer ! 22737: # ! 22738: scn35: addl2 r7,r8 # not ! 22739: scn36: addl2 r7,r8 # dollar ! 22740: scn37: addl2 r7,r8 # exclamation ! 22741: scn38: addl2 r7,r8 # percent ! 22742: scn39: addl2 r7,r8 # asterisk ! 22743: scn40: addl2 r7,r8 # slash ! 22744: scn41: addl2 r7,r8 # number sign ! 22745: scn42: addl2 r7,r8 # at sign ! 22746: scn43: addl2 r7,r8 # vertical bar ! 22747: scn44: addl2 r7,r8 # ampersand ! 22748: scn45: addl2 r7,r8 # question mark ! 22749: # ! 22750: # ALL OPERATORS COME HERE (EQUAL MERGES DIRECTLY) ! 22751: # (WC) POINTS TO THE BINARY/UNARY PAIR OF OPERATOR DVBLKS. ! 22752: # ! 22753: scn46: tstl r7 # operator terminates name/constant ! 22754: bnequ 0f ! 22755: jmp scn10 ! 22756: 0: ! 22757: movl r8,r9 # else copy dv pointer ! 22758: movzbl (r10),r8 # load next character ! 22759: movl $t$bop,r10 # set binary op in case ! 22760: cmpl r6,scnil # should be binary if image end ! 22761: beqlu scn47 ! 22762: cmpl r8,$ch$bl # should be binary if followed by blk ! 22763: beqlu scn47 ! 22764: cmpl r8,$ch$ht # jump if horizontal tab ! 22765: beqlu scn47 ! 22766: cmpl r8,$ch$sm # semicolon can immediately follow = ! 22767: beqlu scn47 ! 22768: # ! 22769: # HERE FOR UNARY OPERATOR ! 22770: # ! 22771: addl2 $4*dvbs$,r9 # point to dv for unary op ! 22772: movl $t$uop,r10 # set type for unary operator ! 22773: cmpl scntp,$t$uok # ok unary if ok preceding element ! 22774: bgtru 0f ! 22775: jmp scn13 ! 22776: 0: ! 22777: #page ! 22778: # ! 22779: # SCANE (CONTINUED) ! 22780: # ! 22781: # MERGE HERE TO REQUIRE PRECEDING BLANKS ! 22782: # ! 22783: scn47: tstl scnbl # all ok if preceding blanks, exit ! 22784: beqlu 0f ! 22785: jmp scn13 ! 22786: 0: ! 22787: # ! 22788: # FAIL OPERATOR IN THIS POSITION ! 22789: # ! 22790: scn48: jmp er_233 # syntax error. invalid use of operator ! 22791: # ! 22792: # HERE FOR ASTERISK, COULD BE ** SUBSTITUTE FOR EXCLAMATION ! 22793: # ! 22794: scn49: tstl r7 # end of name if scanning name ! 22795: bnequ 0f ! 22796: jmp scn10 ! 22797: 0: ! 22798: cmpl r6,scnil # not ** if * at image end ! 22799: beqlu scn39 ! 22800: movl r6,r9 # else save offset past first * ! 22801: movl r6,scnof # save another copy ! 22802: movzbl (r10)+,r6 # load next character ! 22803: cmpl r6,$ch$as # not ** if next char not * ! 22804: bnequ scn50 ! 22805: incl r9 # else step offset past second * ! 22806: cmpl r9,scnil # ok exclam if end of image ! 22807: beqlu scn51 ! 22808: movzbl (r10),r6 # else load next character ! 22809: cmpl r6,$ch$bl # exclamation if blank ! 22810: beqlu scn51 ! 22811: cmpl r6,$ch$ht # exclamation if horizontal tab ! 22812: beqlu scn51 ! 22813: # ! 22814: # UNARY * ! 22815: # ! 22816: scn50: movl scnof,r6 # recover stored offset ! 22817: movl r$cim,r10 # point to line again ! 22818: movab cfp$f(r10)[r6],r10 # point to current char ! 22819: jmp scn39 # merge with unary * ! 22820: # ! 22821: # HERE FOR ** AS SUBSTITUTE FOR EXCLAMATION ! 22822: # ! 22823: scn51: movl r9,scnpt # save scan pointer past 2nd * ! 22824: movl r9,r6 # copy scan pointer ! 22825: jmp scn37 # merge with exclamation ! 22826: #enp # end procedure scane ! 22827: #page ! 22828: # ! 22829: # SCNGF -- SCAN GOTO FIELD ! 22830: # ! 22831: # SCNGF IS CALLED FROM CMPIL TO SCAN AND ANALYZE A GOTO ! 22832: # FIELD INCLUDING THE SURROUNDING BRACKETS OR PARENTHESES. ! 22833: # FOR A NORMAL GOTO, THE RESULT RETURNED IS EITHER A VRBLK ! 22834: # POINTER FOR A SIMPLE LABEL OPERAND, OR A POINTER TO AN ! 22835: # EXPRESSION TREE WITH A SPECIAL OUTER UNARY OPERATOR ! 22836: # (O$GOC). FOR A DIRECT GOTO, THE RESULT RETURNED IS A ! 22837: # POINTER TO AN EXPRESSION TREE WITH THE SPECIAL OUTER ! 22838: # UNARY OPERATOR O$GOD. ! 22839: # ! 22840: # JSR SCNGF CALL TO SCAN GOTO FIELD ! 22841: # (XR) RESULT (SEE ABOVE) ! 22842: # (XL,WA,WB,WC) DESTROYED ! 22843: # ! 22844: scngf: #prc # entry point ! 22845: jsb scane # scan initial element ! 22846: cmpl r10,$t$lpr # skip if left paren (normal goto) ! 22847: beqlu scng1 ! 22848: cmpl r10,$t$lbr # skip if left bracket (direct goto) ! 22849: beqlu scng2 ! 22850: jmp er_234 # syntax error. goto field incorrect ! 22851: # ! 22852: # HERE FOR LEFT PAREN (NORMAL GOTO) ! 22853: # ! 22854: scng1: movl $num01,r7 # set expan flag for normal goto ! 22855: jsb expan # analyze goto field ! 22856: movl $opdvn,r6 # point to opdv for complex goto ! 22857: cmpl r9,statb # jump if not in static (sgd15) ! 22858: blequ scng3 ! 22859: cmpl r9,state # jump to exit if simple label name ! 22860: blequ scng4 ! 22861: jmp scng3 # complex goto - merge ! 22862: # ! 22863: # HERE FOR LEFT BRACKET (DIRECT GOTO) ! 22864: # ! 22865: scng2: movl $num02,r7 # set expan flag for direct goto ! 22866: jsb expan # scan goto field ! 22867: movl $opdvd,r6 # set opdv pointer for direct goto ! 22868: #page ! 22869: # ! 22870: # SCNGF (CONTINUED) ! 22871: # ! 22872: # MERGE HERE TO BUILD OUTER UNARY OPERATOR BLOCK ! 22873: # ! 22874: scng3: movl r6,-(sp) # stack operator dv pointer ! 22875: movl r9,-(sp) # stack pointer to expression tree ! 22876: jsb expop # pop operator off ! 22877: movl (sp)+,r9 # reload new expression tree pointer ! 22878: # ! 22879: # COMMON EXIT POINT ! 22880: # ! 22881: scng4: rsb # return to caller ! 22882: #enp # end procedure scngf ! 22883: #page ! 22884: # ! 22885: # SETVR -- SET VRGET,VRSTO FIELDS OF VRBLK ! 22886: # ! 22887: # SETVR SETS THE PROPER VALUES IN THE VRGET AND VRSTO ! 22888: # FIELDS OF A VRBLK. IT IS CALLED WHENEVER TRBLKS ARE ! 22889: # ADDED OR SUBTRACTED (TRACE,STOPTR,INPUT,OUTPUT,DETACH) ! 22890: # ! 22891: # (XR) POINTER TO VRBLK ! 22892: # JSR SETVR CALL TO SET FIELDS ! 22893: # (XL,WA) DESTROYED ! 22894: # ! 22895: # NOTE THAT SETVR IGNORES THE CALL IF XR DOES NOT POINT ! 22896: # INTO THE STATIC REGION (I.E. IS SOME OTHER NAME BASE) ! 22897: # ! 22898: setvr: #prc # entry point ! 22899: cmpl r9,state # exit if not natural variable ! 22900: bgequ setv1 ! 22901: # ! 22902: # HERE IF WE HAVE A VRBLK ! 22903: # ! 22904: movl r9,r10 # copy vrblk pointer ! 22905: movl $b$vrl,4*vrget(r9) # store normal get value ! 22906: cmpl 4*vrsto(r9),$b$vre # skip if protected variable ! 22907: beqlu setv1 ! 22908: movl $b$vrs,4*vrsto(r9) # store normal store value ! 22909: movl 4*vrval(r10),r10# point to next entry on chain ! 22910: cmpl (r10),$b$trt # jump if end of trblk chain ! 22911: bnequ setv1 ! 22912: movl $b$vra,4*vrget(r9) # store trapped routine address ! 22913: movl $b$vrv,4*vrsto(r9) # set trapped routine address ! 22914: # ! 22915: # MERGE HERE TO EXIT TO CALLER ! 22916: # ! 22917: setv1: rsb # return to setvr caller ! 22918: #enp # end procedure setvr ! 22919: #page ! 22920: # ! 22921: # SORTA -- SORT ARRAY ! 22922: # ! 22923: # ROUTINE TO SORT AN ARRAY OR TABLE ON SAME BASIS AS IN ! 22924: # SITBOL. A TABLE IS CONVERTED TO AN ARRAY, LEAVING TWO ! 22925: # DIMENSIONAL ARRAYS AND VECTORS AS CASES TO BE CONSIDERED. ! 22926: # WHOLE ROWS OF ARRAYS ARE PERMUTED ACCORDING TO THE ! 22927: # ORDERING OF THE KEYS THEY CONTAIN, AND THE STRIDE ! 22928: # REFERRED TO, IS THE THE LENGTH OF A ROW. IT IS ONE ! 22929: # FOR A VECTOR. ! 22930: # THE SORT USED IS HEAPSORT, FUNDAMENTALS OF DATA STRUCTURE ! 22931: # HOROWITZ AND SAHNI, PITMAN 1977, PAGE 347. ! 22932: # IT IS AN ORDER N*LOG(N) ALGORITHM. IN ORDER ! 22933: # TO MAKE IT STABLE, COMPARANDS MAY NOT COMPARE EQUAL. THIS ! 22934: # IS ACHIEVED BY SORTING A COPY ARRAY (REFERRED TO AS THE ! 22935: # SORT ARRAY) CONTAINING AT ITS HIGH ADDRESS END, BYTE ! 22936: # OFFSETS TO THE ROWS TO BE SORTED HELD IN THE ORIGINAL ! 22937: # ARRAY (REFERRED TO AS THE KEY ARRAY). SORTC, THE ! 22938: # COMPARISON ROUTINE, ACCESSES THE KEYS THROUGH THESE ! 22939: # OFFSETS AND IN THE CASE OF EQUALITY, RESOLVES IT BY ! 22940: # COMPARING THE OFFSETS THEMSELVES. THE SORT PERMUTES THE ! 22941: # OFFSETS WHICH ARE THEN USED IN A FINAL OPERATION TO COPY ! 22942: # THE ACTUAL ITEMS INTO THE NEW ARRAY IN SORTED ORDER. ! 22943: # REFERENCES TO ZEROTH ITEM ARE TO NOTIONAL ITEM ! 22944: # PRECEDING FIRST ACTUAL ITEM. ! 22945: # REVERSE SORTING FOR RSORT IS DONE BY HAVING THE LESS THAN ! 22946: # TEST FOR KEYS EFFECTIVELY BE REPLACED BY A ! 22947: # GREATER THAN TEST. ! 22948: # ! 22949: # 1(XS) FIRST ARG - ARRAY OR TABLE ! 22950: # 0(XS) 2ND ARG - INDEX OR PDTYPE NAME ! 22951: # (WA) 0 , NON-ZERO FOR SORT , RSORT ! 22952: # JSR SORTA CALL TO SORT ARRAY ! 22953: # (XR) SORTED ARRAY ! 22954: # (XL,WA,WB,WC) DESTROYED ! 22955: #page ! 22956: # ! 22957: # SORTA (CONTINUED) ! 22958: # ! 22959: .data 1 ! 22960: sorta_s: .long 0 ! 22961: .text 0 ! 22962: sorta: movl (sp)+,sorta_s # entry point ! 22963: movl r6,srtsr # sort/rsort indicator ! 22964: movl $4*num01,srtst # default stride of 1 ! 22965: clrl srtof # default zero offset to sort key ! 22966: movl $nulls,srtdf # clear datatype field name ! 22967: movl (sp)+,r$sxr # unstack argument 2 ! 22968: movl (sp)+,r9 # get first argument ! 22969: jsb gtarr # convert to array ! 22970: .long srt16 # fail ! 22971: movl r9,-(sp) # stack ptr to resulting key array ! 22972: movl r9,-(sp) # another copy for copyb ! 22973: jsb copyb # get copy array for sorting into ! 22974: .long invalid$ # cant fail ! 22975: movl r9,-(sp) # stack pointer to sort array ! 22976: movl r$sxr,r9 # get second arg ! 22977: movl 4*1(sp),r10 # get ptr to key array ! 22978: cmpl (r10),$b$vct # jump if arblk ! 22979: bnequ srt02 ! 22980: cmpl r9,$nulls # jump if null second arg ! 22981: beqlu srt01 ! 22982: jsb gtnvr # get vrblk ptr for it ! 22983: .long er_257 # erroneous 2nd arg in sort/rsort of vector ! 22984: movl r9,srtdf # store datatype field name vrblk ! 22985: # ! 22986: # COMPUTE N AND OFFSET TO ITEM A(0) IN VECTOR CASE ! 22987: # ! 22988: srt01: movl $4*vclen,r8 # offset to a(0) ! 22989: movl $4*vcvls,r7 # offset to first item ! 22990: movl 4*vclen(r10),r6 # get block length ! 22991: subl2 $4*vcsi$,r6 # get no. of entries, n (in bytes) ! 22992: jmp srt04 # merge ! 22993: # ! 22994: # HERE FOR ARRAY ! 22995: # ! 22996: srt02: movl 4*ardim(r10),r5 # get possible dimension ! 22997: movl r5,r6 # convert to short integer ! 22998: moval 0[r6],r6 # further convert to baus ! 22999: movl $4*arvls,r7 # offset to first value if one ! 23000: movl $4*arpro,r8 # offset before values if one dim. ! 23001: cmpl 4*arndm(r10),$num01 # jump in fact if one dim. ! 23002: bnequ 0f ! 23003: jmp srt04 ! 23004: 0: ! 23005: cmpl 4*arndm(r10),$num02 # fail unless two dimens ! 23006: beqlu 0f ! 23007: jmp srt16 ! 23008: 0: ! 23009: movl 4*arlb2(r10),r5 # get lower bound 2 as default ! 23010: cmpl r9,$nulls # jump if default second arg ! 23011: beqlu srt03 ! 23012: jsb gtint # convert to integer ! 23013: .long srt17 # fail ! 23014: movl 4*icval(r9),r5 # get actual integer value ! 23015: #page ! 23016: # ! 23017: # SORTA (CONTINUED) ! 23018: # ! 23019: # HERE WITH SORT COLUMN INDEX IN IA IN ARRAY CASE ! 23020: # ! 23021: srt03: subl2 4*arlb2(r10),r5 # subtract low bound ! 23022: bvc 0f ! 23023: jmp srt17 ! 23024: 0: ! 23025: tstl r5 # fail if below low bound ! 23026: bgeq 0f ! 23027: jmp srt17 ! 23028: 0: ! 23029: subl2 4*ardm2(r10),r5 # check against dimension ! 23030: blss 0f # fail if too large ! 23031: jmp srt17 ! 23032: 0: ! 23033: addl2 4*ardm2(r10),r5 # restore value ! 23034: movl r5,r6 # get as small integer ! 23035: moval 0[r6],r6 # offset within row to key ! 23036: movl r6,srtof # keep offset ! 23037: movl 4*ardm2(r10),r5 # second dimension is row length ! 23038: movl r5,r6 # convert to short integer ! 23039: movl r6,r9 # copy row length ! 23040: moval 0[r6],r6 # convert to bytes ! 23041: movl r6,srtst # store as stride ! 23042: movl 4*ardim(r10),r5 # get number of rows ! 23043: movl r5,r6 # as a short integer ! 23044: moval 0[r6],r6 # convert n to baus ! 23045: movl 4*arlen(r10),r8 # offset past array end ! 23046: subl2 r6,r8 # adjust, giving space for n offsets ! 23047: subl2 $4,r8 # point to a(0) ! 23048: movl 4*arofs(r10),r7 # offset to word before first item ! 23049: addl2 $4,r7 # offset to first item ! 23050: # ! 23051: # SEPARATE PRE-PROCESSING FOR ARRAYS AND VECTORS DONE. ! 23052: # TO SIMPLIFY LATER KEY COMPARISONS, REMOVAL OF ANY TRBLK ! 23053: # TRAP BLOCKS FROM ENTRIES IN KEY ARRAY IS EFFECTED. ! 23054: # ! 23055: # (XL) = 1(XS) = POINTER TO KEY ARRAY ! 23056: # (XS) = POINTER TO SORT ARRAY ! 23057: # WA = NUMBER OF ITEMS, N (CONVERTED TO BYTES). ! 23058: # WB = OFFSET TO FIRST ITEM OF ARRAYS. ! 23059: # WC = OFFSET TO A(0) ! 23060: # ! 23061: srt04: cmpl r6,$4*num01 # return if only a single item ! 23062: bgtru 0f ! 23063: jmp srt15 ! 23064: 0: ! 23065: movl r6,srtsn # store number of items (in baus) ! 23066: movl r8,srtso # store offset to a(0) ! 23067: movl 4*arlen(r10),r8 # length of array or vec (=vclen) ! 23068: addl2 r10,r8 # point past end of array or vector ! 23069: movl r7,srtsf # store offset to first row ! 23070: addl2 r7,r10 # point to first item in key array ! 23071: # ! 23072: # LOOP THROUGH ARRAY ! 23073: # ! 23074: srt05: movl (r10),r9 # get an entry ! 23075: # ! 23076: # HUNT ALONG TRBLK CHAIN ! 23077: # ! 23078: srt06: cmpl (r9),$b$trt # jump out if not trblk ! 23079: bnequ srt07 ! 23080: movl 4*trval(r9),r9 # get value field ! 23081: jmp srt06 # loop ! 23082: #page ! 23083: # ! 23084: # SORTA (CONTINUED) ! 23085: # ! 23086: # XR IS VALUE FROM END OF CHAIN ! 23087: # ! 23088: srt07: movl r9,(r10)+ # store as array entry ! 23089: cmpl r10,r8 # loop if not done ! 23090: blssu srt05 ! 23091: movl (sp),r10 # get adrs of sort array ! 23092: movl srtsf,r9 # initial offset to first key ! 23093: movl srtst,r7 # get stride ! 23094: addl2 srtso,r10 # offset to a(0) ! 23095: addl2 $4,r10 # point to a(1) ! 23096: movl srtsn,r8 # get n ! 23097: ashl $-2,r8,r8 # convert from bytes ! 23098: movl r8,srtnr # store as row count ! 23099: # loop counter ! 23100: # ! 23101: # STORE KEY OFFSETS AT TOP OF SORT ARRAY ! 23102: # ! 23103: srt08: movl r9,(r10)+ # store an offset ! 23104: addl2 r7,r9 # bump offset by stride ! 23105: sobgtr r8,srt08 # loop through rows ! 23106: # ! 23107: # PERFORM THE SORT ON OFFSETS IN SORT ARRAY. ! 23108: # ! 23109: # (SRTSN) NUMBER OF ITEMS TO SORT, N (BYTES) ! 23110: # (SRTSO) OFFSET TO A(0) ! 23111: # ! 23112: srt09: movl srtsn,r6 # get n ! 23113: movl srtnr,r8 # get number of rows ! 23114: ashl $-1,r8,r8 # i = n / 2 (wc=i, index into array) ! 23115: moval 0[r8],r8 # convert back to bytes ! 23116: # ! 23117: # LOOP TO FORM INITIAL HEAP ! 23118: # ! 23119: srt10: jsb sorth # sorth(i,n) ! 23120: subl2 $4,r8 # i = i - 1 ! 23121: bnequ srt10 # loop if i gt 0 ! 23122: movl r6,r8 # i = n ! 23123: # ! 23124: # SORTING LOOP. AT THIS POINT, A(1) IS THE LARGEST ! 23125: # ITEM, SINCE ALGORITHM INITIALISES IT AS, AND THEN MAINTAI ! 23126: # IT AS, ROOT OF TREE. ! 23127: # ! 23128: srt11: subl2 $4,r8 # i = i - 1 (n - 1 initially) ! 23129: beqlu srt12 # jump if done ! 23130: movl (sp),r9 # get sort array address ! 23131: addl2 srtso,r9 # point to a(0) ! 23132: movl r9,r10 # a(0) address ! 23133: addl2 r8,r10 # a(i) address ! 23134: movl 4*1(r10),r7 # copy a(i+1) ! 23135: movl 4*1(r9),4*1(r10)# move a(1) to a(i+1) ! 23136: movl r7,4*1(r9) # complete exchange of a(1), a(i+1) ! 23137: movl r8,r6 # n = i for sorth ! 23138: movl $4*num01,r8 # i = 1 for sorth ! 23139: jsb sorth # sorth(1,n) ! 23140: movl r6,r8 # restore wc ! 23141: jmp srt11 # loop ! 23142: #page ! 23143: # ! 23144: # SORTA (CONTINUED) ! 23145: # ! 23146: # OFFSETS HAVE BEEN PERMUTED INTO REQUIRED ORDER BY SORT. ! 23147: # COPY ARRAY ELEMENTS OVER THEM. ! 23148: # ! 23149: srt12: movl (sp),r10 # base adrs of key array ! 23150: movl r10,r8 # copy it ! 23151: addl2 srtso,r8 # offset of a(0) ! 23152: addl2 srtsf,r10 # adrs of first row of sort array ! 23153: movl srtst,r7 # get stride ! 23154: ashl $-2,r7,r7 # convert to words ! 23155: # ! 23156: # COPYING LOOP FOR SUCCESSIVE ITEMS. SORTED OFFSETS ARE ! 23157: # HELD AT END OF SORT ARRAY. ! 23158: # ! 23159: srt13: addl2 $4,r8 # adrs of next of sorted offsets ! 23160: movl r8,r9 # copy it for access ! 23161: movl (r9),r9 # get offset ! 23162: addl2 4*1(sp),r9 # add key array base adrs ! 23163: movl r7,r6 # get count of words in row ! 23164: # ! 23165: # COPY A COMPLETE ROW ! 23166: # ! 23167: srt14: movl (r9)+,(r10)+ # move a word ! 23168: sobgtr r6,srt14 # loop ! 23169: decl srtnr # decrement row count ! 23170: bnequ srt13 # repeat till all rows done ! 23171: # ! 23172: # RETURN POINT ! 23173: # ! 23174: srt15: movl (sp)+,r9 # pop result array ptr ! 23175: addl2 $4,sp # pop key array ptr ! 23176: clrl r$sxl # clear junk ! 23177: clrl r$sxr # clear junk ! 23178: jmp *sorta_s # return ! 23179: # ! 23180: # ERROR POINT ! 23181: # ! 23182: srt16: jmp er_256 # sort/rsort 1st arg not suitable array or table ! 23183: srt17: jmp er_258 # sort/rsort 2nd arg out of range or non-integer ! 23184: #enp # end procudure sorta ! 23185: #page ! 23186: # ! 23187: # SORTC -- COMPARE SORT KEYS ! 23188: # ! 23189: # COMPARE TWO SORT KEYS GIVEN THEIR OFFSETS. IF ! 23190: # EQUAL, COMPARE KEY OFFSETS TO GIVE STABLE SORT. ! 23191: # NOTE THAT IF SRTSR IS NON-ZERO (REQUEST FOR REVERSE ! 23192: # SORT), THE QUOTED RETURNS ARE INVERTED. ! 23193: # FOR OBJECTS OF DIFFERING DATATYPES, THE ENTRY POINT ! 23194: # IDENTIFICATIONS ARE COMPARED. ! 23195: # ! 23196: # (XL) BASE ADRS FOR KEYS ! 23197: # (WA) OFFSET TO KEY 1 ITEM ! 23198: # (WB) OFFSET TO KEY 2 ITEM ! 23199: # (SRTSR) ZERO/NON-ZERO FOR SORT/RSORT ! 23200: # (SRTOF) OFFSET WITHIN ROW TO COMPARANDS ! 23201: # JSR SORTC CALL TO COMPARE KEYS ! 23202: # PPM LOC KEY1 LESS THAN KEY2 ! 23203: # NORMAL RETURN, KEY1 GT THAN KEY2 ! 23204: # (XL,XR,WA,WB) DESTROYED ! 23205: # ! 23206: sortc: #prc # entry point ! 23207: movl r6,srts1 # save offset 1 ! 23208: movl r7,srts2 # save offset 2 ! 23209: movl r8,srtsc # save wc ! 23210: addl2 srtof,r10 # add offset to comparand field ! 23211: movl r10,r9 # copy base + offset ! 23212: addl2 r6,r10 # add key1 offset ! 23213: addl2 r7,r9 # add key2 offset ! 23214: movl (r10),r10 # get key1 ! 23215: movl (r9),r9 # get key2 ! 23216: cmpl srtdf,$nulls # jump if datatype field name used ! 23217: beqlu 0f ! 23218: jmp src11 ! 23219: 0: ! 23220: #page ! 23221: # ! 23222: # SORTC (CONTINUED) ! 23223: # ! 23224: # MERGE AFTER DEALING WITH FIELD NAME. TRY FOR STRINGS. ! 23225: # ! 23226: src01: movl (r10),r8 # get type code ! 23227: cmpl r8,(r9) # skip if not same datatype ! 23228: bnequ src02 ! 23229: cmpl r8,$b$scl # jump if both strings ! 23230: beqlu src09 ! 23231: # ! 23232: # NOW TRY FOR NUMERIC ! 23233: # ! 23234: src02: movl r10,r$sxl # keep arg1 ! 23235: movl r9,r$sxr # keep arg2 ! 23236: movl r10,-(sp) # stack ! 23237: movl r9,-(sp) # args ! 23238: jsb acomp # compare objects ! 23239: .long src10 # not numeric ! 23240: .long src10 # not numeric ! 23241: .long src03 # key1 less ! 23242: .long src08 # keys equal ! 23243: .long src05 # key1 greater ! 23244: # ! 23245: # RETURN IF KEY1 SMALLER (SORT), GREATER (RSORT) ! 23246: # ! 23247: src03: tstl srtsr # jump if rsort ! 23248: bnequ src06 ! 23249: # ! 23250: src04: movl srtsc,r8 # restore wc ! 23251: movl (sp)+,r11 # return ! 23252: jmp *(r11)+ ! 23253: # ! 23254: # RETURN IF KEY1 GREATER (SORT), SMALLER (RSORT) ! 23255: # ! 23256: src05: tstl srtsr # jump if rsort ! 23257: bnequ src04 ! 23258: # ! 23259: src06: movl srtsc,r8 # restore wc ! 23260: addl2 $4*1,(sp) # return ! 23261: rsb ! 23262: # ! 23263: # KEYS ARE OF SAME DATATYPE ! 23264: # ! 23265: src07: cmpl r10,r9 # item first created is less ! 23266: blssu src03 ! 23267: cmpl r10,r9 # addresses rise in order of creation ! 23268: bgtru src05 ! 23269: # ! 23270: # DROP THROUGH OR MERGE FOR IDENTICAL OR EQUAL OBJECTS ! 23271: # ! 23272: src08: cmpl srts1,srts2 # test offsets or key addrss instead ! 23273: blssu src04 ! 23274: jmp src06 # offset 1 greater ! 23275: #page ! 23276: # ! 23277: # SORTC (CONTINUED) ! 23278: # ! 23279: # STRINGS ! 23280: # ! 23281: src09: movl r10,-(sp) # stack ! 23282: movl r9,-(sp) # args ! 23283: jsb lcomp # compare objects ! 23284: .long invalid$ # cant ! 23285: .long invalid$ # fail ! 23286: .long src03 # key1 less ! 23287: .long src08 # keys equal ! 23288: .long src05 # key1 greater ! 23289: # ! 23290: # ARITHMETIC COMPARISON FAILED - RECOVER ARGS ! 23291: # ! 23292: src10: movl r$sxl,r10 # get arg1 ! 23293: movl r$sxr,r9 # get arg2 ! 23294: movl (r10),r8 # get type of key1 ! 23295: cmpl r8,(r9) # jump if keys of same type ! 23296: beqlu src07 ! 23297: movl r8,r10 # get block type word ! 23298: movl (r9),r9 # get block type word ! 23299: movzwl -2(r10),r10 # entry point id for key1 ! 23300: movzwl -2(r9),r9 # entry point id for key2 ! 23301: cmpl r10,r9 # jump if key1 gt key2 ! 23302: bgtru src05 ! 23303: jmp src03 # key1 lt key2 ! 23304: # ! 23305: # DATATYPE FIELD NAME USED ! 23306: # ! 23307: src11: jsb sortf # call routine to find field 1 ! 23308: movl r10,-(sp) # stack item pointer ! 23309: movl r9,r10 # get key2 ! 23310: jsb sortf # find field 2 ! 23311: movl r10,r9 # place as key2 ! 23312: movl (sp)+,r10 # recover key1 ! 23313: jmp src01 # merge ! 23314: #enp # procedure sortc ! 23315: #page ! 23316: # ! 23317: # SORTF -- FIND FIELD FOR SORTC ! 23318: # ! 23319: # ROUTINE USED BY SORTC TO OBTAIN ITEM CORRESPONDING ! 23320: # TO A GIVEN FIELD NAME, IF THIS EXISTS, IN A PROGRAMMER ! 23321: # DEFINED OBJECT PASSED AS ARGUMENT. ! 23322: # IF SUCH A MATCH OCCURS, RECORD IS KEPT OF DATATYPE ! 23323: # NAME, FIELD NAME AND OFFSET TO FIELD IN ORDER TO ! 23324: # SHORT-CIRCUIT LATER SEARCHES ON SAME TYPE. NOTE THAT ! 23325: # DFBLKS ARE STORED IN STATIC AND HENCE CANNOT BE MOVED. ! 23326: # ! 23327: # (SRTDF) VRBLK POINTER OF FIELD NAME ! 23328: # (XL) POSSIBLE PDBLK POINTER ! 23329: # JSR SORTF CALL TO SEARCH FOR FIELD NAME ! 23330: # (XL) ITEM FOUND OR ORIGINAL PDBLK PTR ! 23331: # (WC) DESTROYED ! 23332: # ! 23333: sortf: #prc # entry point ! 23334: cmpl (r10),$b$pdt # return if not pdblk ! 23335: bnequ srtf3 ! 23336: movl r9,-(sp) # keep xr ! 23337: movl srtfd,r9 # get possible former dfblk ptr ! 23338: beqlu srtf4 # jump if not ! 23339: cmpl r9,4*pddfp(r10) # jump if not right datatype ! 23340: bnequ srtf4 ! 23341: cmpl srtdf,srtff # jump if not right field name ! 23342: bnequ srtf4 ! 23343: addl2 srtfo,r10 # add offset to required field ! 23344: # ! 23345: # HERE WITH XL POINTING TO FOUND FIELD ! 23346: # ! 23347: srtf1: movl (r10),r10 # get item from field ! 23348: # ! 23349: # RETURN POINT ! 23350: # ! 23351: srtf2: movl (sp)+,r9 # restore xr ! 23352: # ! 23353: srtf3: rsb # return ! 23354: #page ! 23355: # ! 23356: # SORTF (CONTINUED) ! 23357: # ! 23358: # CONDUCT A SEARCH ! 23359: # ! 23360: srtf4: movl r10,r9 # copy original pointer ! 23361: movl 4*pddfp(r9),r9 # point to dfblk ! 23362: movl r9,srtfd # keep a copy ! 23363: movl 4*fargs(r9),r8 # get number of fields ! 23364: moval 0[r8],r8 # convert to bytes ! 23365: addl2 4*dflen(r9),r9 # point past last field ! 23366: # ! 23367: # LOOP TO FIND NAME IN PDFBLK ! 23368: # ! 23369: srtf5: subl2 $4,r8 # count down ! 23370: subl2 $4,r9 # point in front ! 23371: cmpl (r9),srtdf # skip out if found ! 23372: beqlu srtf6 ! 23373: tstl r8 # loop ! 23374: bnequ srtf5 ! 23375: jmp srtf2 # return - not found ! 23376: # ! 23377: # FOUND ! 23378: # ! 23379: srtf6: movl (r9),srtff # keep field name ptr ! 23380: addl2 $4*pdfld,r8 # add offset to first field ! 23381: movl r8,srtfo # store as field offset ! 23382: addl2 r8,r10 # point to field ! 23383: jmp srtf1 # return ! 23384: #enp # procedure sortf ! 23385: #page ! 23386: # ! 23387: # SORTH -- HEAP ROUTINE FOR SORTA ! 23388: # ! 23389: # THIS ROUTINE CONSTRUCTS A HEAP FROM ELEMENTS OF ARRAY, A. ! 23390: # IN THIS APPLICATION, THE ELEMENTS ARE OFFSETS TO KEYS IN ! 23391: # A KEY ARRAY. ! 23392: # ! 23393: # (XS) POINTER TO SORT ARRAY BASE ! 23394: # 1(XS) POINTER TO KEY ARRAY BASE ! 23395: # (WA) MAX ARRAY INDEX, N (IN BYTES) ! 23396: # (WC) OFFSET J IN A TO ROOT (IN *1 TO *N) ! 23397: # JSR SORTH CALL SORTH(J,N) TO MAKE HEAP ! 23398: # (XL,XR,WB) DESTROYED ! 23399: # ! 23400: .data 1 ! 23401: sorth_s: .long 0 ! 23402: .text 0 ! 23403: sorth: movl (sp)+,sorth_s # entry point ! 23404: movl r6,srtsn # save n ! 23405: movl r8,srtwc # keep wc ! 23406: movl (sp),r10 # sort array base adrs ! 23407: addl2 srtso,r10 # add offset to a(0) ! 23408: addl2 r8,r10 # point to a(j) ! 23409: movl (r10),srtrt # get offset to root ! 23410: addl2 r8,r8 # double j - cant exceed n ! 23411: # ! 23412: # LOOP TO MOVE DOWN TREE USING DOUBLED INDEX J ! 23413: # ! 23414: srh01: cmpl r8,srtsn # done if j gt n ! 23415: blequ 0f; jmp srh03; 0: ! 23416: cmpl r8,srtsn # skip if j equals n ! 23417: beqlu srh02 ! 23418: movl (sp),r9 # sort array base adrs ! 23419: movl 4*1(sp),r10 # key array base adrs ! 23420: addl2 srtso,r9 # point to a(0) ! 23421: addl2 r8,r9 # adrs of a(j) ! 23422: movl 4*1(r9),r6 # get a(j+1) ! 23423: movl (r9),r7 # get a(j) ! 23424: # ! 23425: # COMPARE SONS. (WA) RIGHT SON, (WB) LEFT SON ! 23426: # ! 23427: jsb sortc # compare keys - lt(a(j+1),a(j)) ! 23428: .long srh02 # a(j+1) lt a(j) ! 23429: addl2 $4,r8 # point to greater son, a(j+1) ! 23430: #page ! 23431: # ! 23432: # SORTH (CONTINUED) ! 23433: # ! 23434: # COMPARE ROOT WITH GREATER SON ! 23435: # ! 23436: srh02: movl 4*1(sp),r10 # key array base adrs ! 23437: movl (sp),r9 # get sort array address ! 23438: addl2 srtso,r9 # adrs of a(0) ! 23439: movl r9,r7 # copy this adrs ! 23440: addl2 r8,r9 # adrs of greater son, a(j) ! 23441: movl (r9),r6 # get a(j) ! 23442: movl r7,r9 # point back to a(0) ! 23443: movl srtrt,r7 # get root ! 23444: jsb sortc # compare them - lt(a(j),root) ! 23445: .long srh03 # father exceeds sons - done ! 23446: movl (sp),r9 # get sort array adrs ! 23447: addl2 srtso,r9 # point to a(0) ! 23448: movl r9,r10 # copy it ! 23449: movl r8,r6 # copy j ! 23450: ashl $-2,r8,r8 # convert to words ! 23451: ashl $-1,r8,r8 # get j/2 ! 23452: moval 0[r8],r8 # convert back to bytes ! 23453: addl2 r6,r10 # point to a(j) ! 23454: addl2 r8,r9 # adrs of a(j/2) ! 23455: movl (r10),(r9) # a(j/2) = a(j) ! 23456: movl r6,r8 # recover j ! 23457: addl2 r8,r8 # j = j*2. done if too big ! 23458: bvc 0f ! 23459: jmp srh03 ! 23460: 0: ! 23461: jmp srh01 # loop ! 23462: # ! 23463: # FINISH BY COPYING ROOT OFFSET BACK INTO ARRAY ! 23464: # ! 23465: srh03: ashl $-2,r8,r8 # convert to words ! 23466: ashl $-1,r8,r8 # j = j/2 ! 23467: moval 0[r8],r8 # convert back to bytes ! 23468: movl (sp),r9 # sort array adrs ! 23469: addl2 srtso,r9 # adrs of a(0) ! 23470: addl2 r8,r9 # adrs of a(j/2) ! 23471: movl srtrt,(r9) # a(j/2) = root ! 23472: movl srtsn,r6 # restore wa ! 23473: movl srtwc,r8 # restore wc ! 23474: jmp *sorth_s # return ! 23475: #enp # end procedure sorth ! 23476: #page ! 23477: #page ! 23478: # ! 23479: # TFIND -- LOCATE TABLE ELEMENT ! 23480: # ! 23481: # (XR) SUBSCRIPT VALUE FOR ELEMENT ! 23482: # (XL) POINTER TO TABLE ! 23483: # (WB) ZERO BY VALUE, NON-ZERO BY NAME ! 23484: # JSR TFIND CALL TO LOCATE ELEMENT ! 23485: # PPM LOC TRANSFER LOCATION IF ACCESS FAILS ! 23486: # (XR) ELEMENT VALUE (IF BY VALUE) ! 23487: # (XR) DESTROYED (IF BY NAME) ! 23488: # (XL,WA) TEBLK NAME (IF BY NAME) ! 23489: # (XL,WA) DESTROYED (IF BY VALUE) ! 23490: # (WC,RA) DESTROYED ! 23491: # ! 23492: # NOTE THAT IF A CALL BY VALUE SPECIFIES A NON-EXISTENT ! 23493: # SUBSCRIPT, NULL IS RETURNED WITHOUT BUILDING A NEW TEBLK. ! 23494: # ! 23495: tfind: #prc # entry point ! 23496: movl r7,-(sp) # save name/value indicator ! 23497: movl r9,-(sp) # save subscript value ! 23498: movl r10,-(sp) # save table pointer ! 23499: movl 4*tblen(r10),r6 # load length of tbblk ! 23500: ashl $-2,r6,r6 # convert to word count ! 23501: subl2 $tbbuk,r6 # get number of buckets ! 23502: movl r6,r5 # convert to integer value ! 23503: movl r5,tfnsi # save for later ! 23504: movl (r9),r10 # load first word of subscript ! 23505: movzwl -2(r10),r10 # load block entry id (bl$xx) ! 23506: casel r10,$0,$bl$$d # switch on block type ! 23507: 5: ! 23508: .word tfn00-5b ! 23509: .word tfn00-5b ! 23510: .word tfn00-5b ! 23511: .word tfn00-5b ! 23512: .word tfn02-5b # jump if integer ! 23513: .word tfn04-5b # jump if name ! 23514: .word tfn03-5b # jump if pattern ! 23515: .word tfn03-5b # jump if pattern ! 23516: .word tfn03-5b # jump if pattern ! 23517: .word tfn02-5b # real ! 23518: .word tfn05-5b # jump if string ! 23519: .word tfn00-5b ! 23520: .word tfn00-5b ! 23521: .word tfn00-5b ! 23522: .word tfn00-5b ! 23523: .word tfn00-5b ! 23524: .word tfn00-5b ! 23525: #esw # end switch on block type ! 23526: # ! 23527: # HERE FOR BLOCKS FOR WHICH WE USE THE SECOND WORD OF THE ! 23528: # BLOCK AS THE HASH SOURCE (SEE BLOCK FORMATS FOR DETAILS). ! 23529: # ! 23530: tfn00: movl 4*1(r9),r6 # load second word ! 23531: # ! 23532: # MERGE HERE WITH ONE WORD HASH SOURCE IN WA ! 23533: # ! 23534: tfn01: movl r6,r5 # convert to integer ! 23535: jmp tfn06 # jump to merge ! 23536: #page ! 23537: # ! 23538: # TFIND (CONTINUED) ! 23539: # ! 23540: # HERE FOR INTEGER OR REAL ! 23541: # ! 23542: tfn02: movl 4*1(r9),r5 # load value as hash source ! 23543: bgeq tfn06 # ok if positive or zero ! 23544: mnegl r5,r5 # make positive ! 23545: bvs tfn06 ! 23546: jmp tfn06 # merge ! 23547: # ! 23548: # FOR PATTERN, USE FIRST WORD (PCODE) AS SOURCE ! 23549: # ! 23550: tfn03: movl (r9),r6 # load first word as hash source ! 23551: jmp tfn01 # merge back ! 23552: # ! 23553: # FOR NAME, USE OFFSET AS HASH SOURCE ! 23554: # ! 23555: tfn04: movl 4*nmofs(r9),r6 # load offset as hash source ! 23556: jmp tfn01 # merge back ! 23557: # ! 23558: # HERE FOR STRING ! 23559: # ! 23560: tfn05: jsb hashs # call routine to compute hash ! 23561: # ! 23562: # MERGE HERE WITH HASH SOURCE IN (IA) ! 23563: # ! 23564: tfn06: ashq $-32,r4,r4 # compute hash index by remaindering ! 23565: ediv tfnsi,r4,r11,r5 ! 23566: movl r5,r8 # get as one word integer ! 23567: moval 0[r8],r8 # convert to byte offset ! 23568: movl (sp),r10 # get table ptr again ! 23569: addl2 r8,r10 # point to proper bucket ! 23570: movl 4*tbbuk(r10),r9 # load first teblk pointer ! 23571: cmpl r9,(sp) # jump if no teblks on chain ! 23572: beqlu tfn10 ! 23573: # ! 23574: # LOOP THROUGH TEBLKS ON HASH CHAIN ! 23575: # ! 23576: tfn07: movl r9,r7 # save teblk pointer ! 23577: movl 4*tesub(r9),r9 # load subscript value ! 23578: movl 4*1(sp),r10 # load input argument subscript val ! 23579: jsb ident # compare them ! 23580: .long tfn08 # jump if equal (ident) ! 23581: # ! 23582: # HERE IF NO MATCH WITH THAT TEBLK ! 23583: # ! 23584: movl r7,r10 # restore teblk pointer ! 23585: movl 4*tenxt(r10),r9 # point to next teblk on chain ! 23586: cmpl r9,(sp) # jump if there is one ! 23587: bnequ tfn07 ! 23588: # ! 23589: # HERE IF NO MATCH WITH ANY TEBLK ON CHAIN ! 23590: # ! 23591: movl $4*tenxt,r8 # set offset to link field (xl base) ! 23592: jmp tfn11 # jump to merge ! 23593: #page ! 23594: # ! 23595: # TFIND (CONTINUED) ! 23596: # ! 23597: # HERE WE HAVE FOUND A MATCHING ELEMENT ! 23598: # ! 23599: tfn08: movl r7,r10 # restore teblk pointer ! 23600: movl $4*teval,r6 # set teblk name offset ! 23601: movl 4*2(sp),r7 # restore name/value indicator ! 23602: bnequ tfn09 # jump if called by name ! 23603: jsb acess # else get value ! 23604: .long tfn12 # jump if reference fails ! 23605: clrl r7 # restore name/value indicator ! 23606: # ! 23607: # COMMON EXIT FOR ENTRY FOUND ! 23608: # ! 23609: tfn09: addl2 $4*num03,sp # pop stack entries ! 23610: addl2 $4*1,(sp) # return to tfind caller ! 23611: rsb ! 23612: # ! 23613: # HERE IF NO TEBLKS ON THE HASH CHAIN ! 23614: # ! 23615: tfn10: addl2 $4*tbbuk,r8 # get offset to bucket ptr ! 23616: movl (sp),r10 # set tbblk ptr as base ! 23617: # ! 23618: # MERGE HERE WITH (XL,WC) BASE,OFFSET OF FINAL LINK ! 23619: # ! 23620: tfn11: movl (sp),r9 # tbblk pointer ! 23621: movl 4*tbinv(r9),r9 # load default value in case ! 23622: movl 4*2(sp),r7 # load name/value indicator ! 23623: beqlu tfn09 # exit with default if value call ! 23624: # ! 23625: # HERE WE MUST BUILD A NEW TEBLK ! 23626: # ! 23627: movl $4*tesi$,r6 # set size of teblk ! 23628: jsb alloc # allocate teblk ! 23629: addl2 r8,r10 # point to hash link ! 23630: movl r9,(r10) # link new teblk at end of chain ! 23631: movl $b$tet,(r9) # store type word ! 23632: movl $nulls,4*teval(r9) # set null as initial value ! 23633: movl (sp)+,4*tenxt(r9)# set tbblk ptr to mark end of chain ! 23634: movl (sp)+,4*tesub(r9)# store subscript value ! 23635: addl2 $4,sp # pop past name/value indicator ! 23636: movl r9,r10 # copy teblk pointer (name base) ! 23637: movl $4*teval,r6 # set offset ! 23638: addl2 $4*1,(sp) # return to caller with new teblk ! 23639: rsb ! 23640: # ! 23641: # ACESS FAIL RETURN ! 23642: # ! 23643: tfn12: movl (sp)+,r11 # alternative return ! 23644: jmp *(r11)+ ! 23645: #enp # end procedure tfind ! 23646: #page ! 23647: # ! 23648: # TRACE -- SET/RESET A TRACE ASSOCIATION ! 23649: # ! 23650: # THIS PROCEDURE IS SHARED BY TRACE AND STOPTR TO ! 23651: # EITHER INITIATE OR STOP A TRACE RESPECTIVELY. ! 23652: # ! 23653: # (XL) TRBLK PTR (TRACE) OR ZERO (STOPTR) ! 23654: # 1(XS) FIRST ARGUMENT (NAME) ! 23655: # 0(XS) SECOND ARGUMENT (TRACE TYPE) ! 23656: # JSR TRACE CALL TO SET/RESET TRACE ! 23657: # PPM LOC TRANSFER LOC IF 1ST ARG IS BAD NAME ! 23658: # PPM LOC TRANSFER LOC IF 2ND ARG IS BAD TYPE ! 23659: # (XS) POPPED ! 23660: # (XL,XR,WA,WB,WC,IA) DESTROYED ! 23661: # ! 23662: .data 1 ! 23663: trace_s: .long 0 ! 23664: .text 0 ! 23665: trace: movl (sp)+,trace_s # entry point ! 23666: jsb gtstg # get trace type string ! 23667: .long trc15 # jump if not string ! 23668: movab cfp$f(r9),r9 # else point to string ! 23669: movzbl (r9),r6 # load first character ! 23670: bicl2 $ch$bl,r6 # fold to upper case ! 23671: movl (sp),r9 # load name argument ! 23672: movl r10,(sp) # stack trblk ptr or zero ! 23673: movl $trtac,r8 # set trtyp for access trace ! 23674: cmpl r6,$ch$la # jump if a (access) ! 23675: bnequ 0f ! 23676: jmp trc10 ! 23677: 0: ! 23678: movl $trtvl,r8 # set trtyp for value trace ! 23679: cmpl r6,$ch$lv # jump if v (value) ! 23680: bnequ 0f ! 23681: jmp trc10 ! 23682: 0: ! 23683: tstl r6 # jump if blank (value) ! 23684: bnequ 0f ! 23685: jmp trc10 ! 23686: 0: ! 23687: # ! 23688: # HERE FOR L,K,F,C,R ! 23689: # ! 23690: cmpl r6,$ch$lf # jump if f (function) ! 23691: beqlu trc01 ! 23692: cmpl r6,$ch$lr # jump if r (return) ! 23693: beqlu trc01 ! 23694: cmpl r6,$ch$ll # jump if l (label) ! 23695: beqlu trc03 ! 23696: cmpl r6,$ch$lk # jump if k (keyword) ! 23697: bnequ 0f ! 23698: jmp trc06 ! 23699: 0: ! 23700: cmpl r6,$ch$lc # else error if not c (call) ! 23701: beqlu 0f ! 23702: jmp trc15 ! 23703: 0: ! 23704: # ! 23705: # HERE FOR F,C,R ! 23706: # ! 23707: trc01: jsb gtnvr # point to vrblk for name ! 23708: .long trc16 # jump if bad name ! 23709: addl2 $4,sp # pop stack ! 23710: movl 4*vrfnc(r9),r9 # point to function block ! 23711: cmpl (r9),$b$pfc # error if not program function ! 23712: beqlu 0f ! 23713: jmp trc17 ! 23714: 0: ! 23715: cmpl r6,$ch$lr # jump if r (return) ! 23716: beqlu trc02 ! 23717: #page ! 23718: # ! 23719: # TRACE (CONTINUED) ! 23720: # ! 23721: # HERE FOR F,C TO SET/RESET CALL TRACE ! 23722: # ! 23723: movl r10,4*pfctr(r9) # set/reset call trace ! 23724: cmpl r6,$ch$lc # exit with null if c (call) ! 23725: bnequ 0f ! 23726: jmp exnul ! 23727: 0: ! 23728: # ! 23729: # HERE FOR F,R TO SET/RESET RETURN TRACE ! 23730: # ! 23731: trc02: movl r10,4*pfrtr(r9) # set/reset return trace ! 23732: addl3 $4*2,trace_s,r11 # return ! 23733: jmp (r11) ! 23734: # ! 23735: # HERE FOR L TO SET/RESET LABEL TRACE ! 23736: # ! 23737: trc03: jsb gtnvr # point to vrblk ! 23738: .long trc16 # jump if bad name ! 23739: movl 4*vrlbl(r9),r10 # load label pointer ! 23740: cmpl (r10),$b$trt # jump if no old trace ! 23741: bnequ trc04 ! 23742: movl 4*trlbl(r10),r10# else delete old trace association ! 23743: # ! 23744: # HERE WITH OLD LABEL TRACE ASSOCIATION DELETED ! 23745: # ! 23746: trc04: cmpl r10,$stndl # error if undefined label ! 23747: bnequ 0f ! 23748: jmp trc16 ! 23749: 0: ! 23750: movl (sp)+,r7 # get trblk ptr again ! 23751: beqlu trc05 # jump if stoptr case ! 23752: movl r7,4*vrlbl(r9) # else set new trblk pointer ! 23753: movl $b$vrt,4*vrtra(r9) # set label trace routine address ! 23754: movl r7,r9 # copy trblk pointer ! 23755: movl r10,4*trlbl(r9) # store real label in trblk ! 23756: addl3 $4*2,trace_s,r11 # return ! 23757: jmp (r11) ! 23758: # ! 23759: # HERE FOR STOPTR CASE FOR LABEL ! 23760: # ! 23761: trc05: movl r10,4*vrlbl(r9) # store label ptr back in vrblk ! 23762: movl $b$vrg,4*vrtra(r9) # store normal transfer address ! 23763: addl3 $4*2,trace_s,r11 # return ! 23764: jmp (r11) ! 23765: #page ! 23766: # ! 23767: # TRACE (CONTINUED) ! 23768: # ! 23769: # HERE FOR K (KEYWORD) ! 23770: # ! 23771: trc06: jsb gtnvr # point to vrblk ! 23772: .long trc16 # error if not natural var ! 23773: tstl 4*vrlen(r9) # error if not system var ! 23774: beqlu 0f ! 23775: jmp trc16 ! 23776: 0: ! 23777: addl2 $4,sp # pop stack ! 23778: tstl r10 # jump if stoptr case ! 23779: beqlu trc07 ! 23780: movl r9,4*trkvr(r10) # store vrblk ptr in trblk for ktrex ! 23781: # ! 23782: # MERGE HERE WITH TRBLK SET UP IN WB (OR ZERO) ! 23783: # ! 23784: trc07: movl 4*vrsvp(r9),r9 # point to svblk ! 23785: cmpl r9,$v$ert # jump if errtype ! 23786: beqlu trc08 ! 23787: cmpl r9,$v$stc # jump if stcount ! 23788: beqlu trc09 ! 23789: cmpl r9,$v$fnc # else error if not fnclevel ! 23790: beqlu 0f ! 23791: jmp trc17 ! 23792: 0: ! 23793: # ! 23794: # FNCLEVEL ! 23795: # ! 23796: movl r10,r$fnc # set/reset fnclevel trace ! 23797: addl3 $4*2,trace_s,r11 # return ! 23798: jmp (r11) ! 23799: # ! 23800: # ERRTYPE ! 23801: # ! 23802: trc08: movl r10,r$ert # set/reset errtype trace ! 23803: addl3 $4*2,trace_s,r11 # return ! 23804: jmp (r11) ! 23805: # ! 23806: # STCOUNT ! 23807: # ! 23808: trc09: movl r10,r$stc # set/reset stcount trace ! 23809: addl3 $4*2,trace_s,r11 # return ! 23810: jmp (r11) ! 23811: #page ! 23812: # ! 23813: # TRACE (CONTINUED) ! 23814: # ! 23815: # A,V MERGE HERE WITH TRTYP VALUE IN WC ! 23816: # ! 23817: trc10: jsb gtvar # locate variable ! 23818: .long trc16 # error if not appropriate name ! 23819: movl (sp)+,r7 # get new trblk ptr again ! 23820: addl2 r10,r6 # point to variable location ! 23821: movl r6,r9 # copy variable pointer ! 23822: # ! 23823: # LOOP TO SEARCH TRBLK CHAIN ! 23824: # ! 23825: trc11: movl (r9),r10 # point to next entry ! 23826: cmpl (r10),$b$trt # jump if not trblk ! 23827: bnequ trc13 ! 23828: cmpl r8,4*trtyp(r10) # jump if too far out on chain ! 23829: blssu trc13 ! 23830: cmpl r8,4*trtyp(r10) # jump if this matches our type ! 23831: beqlu trc12 ! 23832: addl2 $4*trnxt,r10 # else point to link field ! 23833: movl r10,r9 # copy pointer ! 23834: jmp trc11 # and loop back ! 23835: # ! 23836: # HERE TO DELETE AN OLD TRBLK OF THE TYPE WE WERE GIVEN ! 23837: # ! 23838: trc12: movl 4*trnxt(r10),r10# get ptr to next block or value ! 23839: movl r10,(r9) # store to delete this trblk ! 23840: # ! 23841: # HERE AFTER DELETING ANY OLD ASSOCIATION OF THIS TYPE ! 23842: # ! 23843: trc13: tstl r7 # jump if stoptr case ! 23844: beqlu trc14 ! 23845: movl r7,(r9) # else link new trblk in ! 23846: movl r7,r9 # copy trblk pointer ! 23847: movl r10,4*trnxt(r9) # store forward pointer ! 23848: movl r8,4*trtyp(r9) # store appropriate trap type code ! 23849: # ! 23850: # HERE TO MAKE SURE VRGET,VRSTO ARE SET PROPERLY ! 23851: # ! 23852: trc14: movl r6,r9 # recall possible vrblk pointer ! 23853: subl2 $4*vrval,r9 # point back to vrblk ! 23854: jsb setvr # set fields if vrblk ! 23855: addl3 $4*2,trace_s,r11 # return ! 23856: jmp (r11) ! 23857: # ! 23858: # HERE FOR BAD TRACE TYPE ! 23859: # ! 23860: trc15: addl3 $4*1,trace_s,r11 # take bad trace type error exit ! 23861: jmp *(r11)+ ! 23862: # ! 23863: # POP STACK BEFORE FAILING ! 23864: # ! 23865: trc16: addl2 $4,sp # pop stack ! 23866: # ! 23867: # HERE FOR BAD NAME ARGUMENT ! 23868: # ! 23869: trc17: movl trace_s,r11 # take bad name error exit ! 23870: jmp *(r11)+ ! 23871: #enp # end procedure trace ! 23872: #page ! 23873: # ! 23874: # TRBLD -- BUILD TRBLK ! 23875: # ! 23876: # TRBLK IS USED BY THE INPUT, OUTPUT AND TRACE FUNCTIONS ! 23877: # TO CONSTRUCT A TRBLK (TRAP BLOCK) ! 23878: # ! 23879: # (XR) TRTAG OR TRTER ! 23880: # (XL) TRFNC OR TRFPT ! 23881: # (WB) TRTYP ! 23882: # JSR TRBLD CALL TO BUILD TRBLK ! 23883: # (XR) POINTER TO TRBLK ! 23884: # (WA) DESTROYED ! 23885: # ! 23886: trbld: #prc # entry point ! 23887: movl r9,-(sp) # stack trtag (or trfnm) ! 23888: movl $4*trsi$,r6 # set size of trblk ! 23889: jsb alloc # allocate trblk ! 23890: movl $b$trt,(r9) # store first word ! 23891: movl r10,4*trfnc(r9) # store trfnc (or trfpt) ! 23892: movl (sp)+,4*trtag(r9)# store trtag (or trfnm) ! 23893: movl r7,4*trtyp(r9) # store type ! 23894: movl $nulls,4*trval(r9) # for now, a null value ! 23895: rsb # return to caller ! 23896: #enp # end procedure trbld ! 23897: #page ! 23898: # ! 23899: # TRIMR -- TRIM TRAILING BLANKS ! 23900: # ! 23901: # TRIMR IS PASSED A POINTER TO AN SCBLK WHICH MUST BE THE ! 23902: # LAST BLOCK IN DYNAMIC STORAGE. TRAILING BLANKS ARE ! 23903: # TRIMMED OFF AND THE DYNAMIC STORAGE POINTER RESET TO ! 23904: # THE END OF THE (POSSIBLY) SHORTENED BLOCK. ! 23905: # ! 23906: # (WB) NON-ZERO TO TRIM TRAILING BLANKS ! 23907: # (XR) POINTER TO STRING TO TRIM ! 23908: # JSR TRIMR CALL TO TRIM STRING ! 23909: # (XR) POINTER TO TRIMMED STRING ! 23910: # (XL,WA,WB,WC) DESTROYED ! 23911: # ! 23912: # THE CALL WITH WB ZERO STILL PERFORMS THE END ZERO PAD ! 23913: # AND DNAMP READJUSTMENT. IT IS USED FROM ACESS IF KVTRM=0. ! 23914: # ! 23915: trimr: #prc # entry point ! 23916: movl r9,r10 # copy string pointer ! 23917: movl 4*sclen(r9),r6 # load string length ! 23918: beqlu trim2 # jump if null input ! 23919: movab cfp$f(r10)[r6],r10 # else point past last character ! 23920: tstl r7 # jump if no trim ! 23921: beqlu trim3 ! 23922: movl $ch$bl,r8 # load blank character ! 23923: # ! 23924: # LOOP THROUGH CHARACTERS FROM RIGHT TO LEFT ! 23925: # ! 23926: trim0: movzbl -(r10),r7 # load next character ! 23927: cmpl r7,$ch$ht # jump if horizontal tab ! 23928: beqlu trim1 ! 23929: cmpl r7,r8 # jump if non-blank found ! 23930: bnequ trim3 ! 23931: trim1: decl r6 # else decrement character count ! 23932: bnequ trim0 # loop back if more to check ! 23933: # ! 23934: # HERE IF RESULT IS NULL (NULL OR ALL-BLANK INPUT) ! 23935: # ! 23936: trim2: movl r9,dnamp # wipe out input string block ! 23937: movl $nulls,r9 # load null result ! 23938: jmp trim5 # merge to exit ! 23939: #page ! 23940: # ! 23941: # TRIMR (CONTINUED) ! 23942: # ! 23943: # HERE WITH NON-BLANK FOUND (MERGE FOR NO TRIM) ! 23944: # ! 23945: trim3: movl r6,4*sclen(r9) # set new length ! 23946: movl r9,r10 # copy string pointer ! 23947: movab cfp$f(r10)[r6],r10 # ready for storing blanks ! 23948: movab 3+(4*schar)(r6),r6 # get length of block in bytes ! 23949: bicl2 $3,r6 ! 23950: addl2 r9,r6 # point past new block ! 23951: movl r6,dnamp # set new top of storage pointer ! 23952: movl $cfp$c,r6 # get count of chars in word ! 23953: clrl r8 # set blank char ! 23954: # ! 23955: # LOOP TO ZERO PAD LAST WORD OF CHARACTERS ! 23956: # ! 23957: trim4: movb r8,(r10)+ # store zero character ! 23958: sobgtr r6,trim4 # loop back till all stored ! 23959: #csc r10 # complete store characters ! 23960: # ! 23961: # COMMON EXIT POINT ! 23962: # ! 23963: trim5: clrl r10 # clear garbage xl pointer ! 23964: rsb # return to caller ! 23965: #enp # end procedure trimr ! 23966: #page ! 23967: # ! 23968: # TRXEQ -- EXECUTE FUNCTION TYPE TRACE ! 23969: # ! 23970: # TRXEQ IS USED TO EXECUTE A TRACE WHEN A FOURTH ARGUMENT ! 23971: # HAS BEEN SUPPLIED. TRACE HAS ALREADY BEEN DECREMENTED. ! 23972: # ! 23973: # (XR) POINTER TO TRBLK ! 23974: # (XL,WA) NAME BASE,OFFSET FOR VARIABLE ! 23975: # JSR TRXEQ CALL TO EXECUTE TRACE ! 23976: # (WB,WC,RA) DESTROYED ! 23977: # ! 23978: # THE FOLLOWING STACK ENTRIES ARE MADE BEFORE PASSING ! 23979: # CONTROL TO THE TRACE FUNCTION USING THE CFUNC ROUTINE. ! 23980: # ! 23981: # TRXEQ RETURN POINT WORD(S) ! 23982: # SAVED VALUE OF TRACE KEYWORD ! 23983: # TRBLK POINTER ! 23984: # NAME BASE ! 23985: # NAME OFFSET ! 23986: # SAVED VALUE OF R$COD ! 23987: # SAVED CODE PTR (-R$COD) ! 23988: # SAVED VALUE OF FLPTR ! 23989: # FLPTR --------------- ZERO (DUMMY FAIL OFFSET) ! 23990: # NMBLK FOR VARIABLE NAME ! 23991: # XS ------------------ TRACE TAG ! 23992: # ! 23993: # R$COD AND THE CODE PTR ARE SET TO DUMMY VALUES WHICH ! 23994: # CAUSE CONTROL TO RETURN TO THE TRXEQ PROCEDURE ON SUCCESS ! 23995: # OR FAILURE (TRXEQ IGNORES A FAILURE CONDITION). ! 23996: # ! 23997: trxeq: #prc # entry point (recursive) ! 23998: movl r$cod,r8 # load code block pointer ! 23999: movl r3,r7 # get current code pointer ! 24000: subl2 r8,r7 # make code pointer into offset ! 24001: movl kvtra,-(sp) # stack trace keyword value ! 24002: movl r9,-(sp) # stack trblk pointer ! 24003: movl r10,-(sp) # stack name base ! 24004: movl r6,-(sp) # stack name offset ! 24005: movl r8,-(sp) # stack code block pointer ! 24006: movl r7,-(sp) # stack code pointer offset ! 24007: movl flptr,-(sp) # stack old failure pointer ! 24008: clrl -(sp) # set dummy fail offset ! 24009: movl sp,flptr # set new failure pointer ! 24010: clrl kvtra # reset trace keyword to zero ! 24011: movl $trxdc,r8 # load new (dummy) code blk pointer ! 24012: movl r8,r$cod # set as code block pointer ! 24013: movl r8,r3 # and new code pointer ! 24014: #page ! 24015: # ! 24016: # TRXEQ (CONTINUED) ! 24017: # ! 24018: # NOW PREPARE ARGUMENTS FOR FUNCTION ! 24019: # ! 24020: movl r6,r7 # save name offset ! 24021: movl $4*nmsi$,r6 # load nmblk size ! 24022: jsb alloc # allocate space for nmblk ! 24023: movl $b$nml,(r9) # set type word ! 24024: movl r10,4*nmbas(r9) # store name base ! 24025: movl r7,4*nmofs(r9) # store name offset ! 24026: movl 4*6(sp),r10 # reload pointer to trblk ! 24027: movl r9,-(sp) # stack nmblk pointer (1st argument) ! 24028: movl 4*trtag(r10),-(sp) # stack trace tag (2nd argument) ! 24029: movl 4*trfnc(r10),r10# load trace function pointer ! 24030: movl $num02,r6 # set number of arguments to two ! 24031: jmp cfunc # jump to call function ! 24032: # ! 24033: # SEE O$TXR FOR DETAILS OF RETURN TO THIS POINT ! 24034: # ! 24035: trxq1: movl flptr,sp # point back to our stack entries ! 24036: addl2 $4,sp # pop off garbage fail offset ! 24037: movl (sp)+,flptr # restore old failure pointer ! 24038: movl (sp)+,r7 # reload code offset ! 24039: movl (sp)+,r8 # load old code base pointer ! 24040: movl r8,r9 # copy cdblk pointer ! 24041: movl 4*cdstm(r9),kvstn# restore stmnt no ! 24042: movl (sp)+,r6 # reload name offset ! 24043: movl (sp)+,r10 # reload name base ! 24044: movl (sp)+,r9 # reload trblk pointer ! 24045: movl (sp)+,kvtra # restore trace keyword value ! 24046: addl2 r8,r7 # recompute absolute code pointer ! 24047: movl r7,r3 # restore code pointer ! 24048: movl r8,r$cod # and code block pointer ! 24049: rsb # return to trxeq caller ! 24050: #enp # end procedure trxeq ! 24051: #page ! 24052: # ! 24053: # XSCAN -- EXECUTION FUNCTION ARGUMENT SCAN ! 24054: # ! 24055: # XSCAN SCANS OUT ONE TOKEN IN A PROTOTYPE ARGUMENT IN ! 24056: # ARRAY,CLEAR,DATA,DEFINE,LOAD FUNCTION CALLS. XSCAN ! 24057: # CALLS MUST BE PRECEDED BY A CALL TO THE INITIALIZATION ! 24058: # PROCEDURE XSCNI. THE FOLLOWING VARIABLES ARE USED. ! 24059: # ! 24060: # R$XSC POINTER TO SCBLK FOR FUNCTION ARG ! 24061: # XSOFS OFFSET (NUM CHARS SCANNED SO FAR) ! 24062: # ! 24063: # (WC) DELIMITER ONE (CH$XX) ! 24064: # (XL) DELIMITER TWO (CH$XX) ! 24065: # JSR XSCAN CALL TO SCAN NEXT ITEM ! 24066: # (XR) POINTER TO SCBLK FOR TOKEN SCANNED ! 24067: # (WA) COMPLETION CODE (SEE BELOW) ! 24068: # (WC,XL) DESTROYED ! 24069: # ! 24070: # THE SCAN STARTS FROM THE CURRENT POSITION AND CONTINUES ! 24071: # UNTIL ONE OF THE FOLLOWING THREE CONDITIONS OCCURS. ! 24072: # ! 24073: # 1) DELIMITER ONE IS ENCOUNTERED (WA SET TO 1) ! 24074: # ! 24075: # 2) DELIMITER TWO ENCOUNTERED (WA SET TO 2) ! 24076: # ! 24077: # 3) END OF STRING ENCOUNTERED (WA SET TO 0) ! 24078: # ! 24079: # THE RESULT IS A STRING CONTAINING ALL CHARACTERS SCANNED ! 24080: # UP TO BUT NOT INCLUDING ANY DELIMITER CHARACTER. ! 24081: # THE POINTER IS LEFT POINTING PAST THE DELIMITER. ! 24082: # ! 24083: # IF ONLY ONE DELIMITER IS TO BE DETECTED, DELIMITER ONE ! 24084: # AND DELIMITER TWO SHOULD BE SET TO THE SAME VALUE. ! 24085: # ! 24086: # IN THE CASE WHERE THE END OF STRING IS ENCOUNTERED, THE ! 24087: # STRING INCLUDES ALL THE CHARACTERS TO THE END OF THE ! 24088: # STRING. NO FURTHER CALLS CAN BE MADE TO XSCAN UNTIL ! 24089: # XSCNI IS CALLED TO INITIALIZE A NEW ARGUMENT SCAN ! 24090: #page ! 24091: # ! 24092: # XSCAN (CONTINUED) ! 24093: # ! 24094: xscan: #prc # entry point ! 24095: movl r7,xscwb # preserve wb ! 24096: movl r$xsc,r9 # point to argument string ! 24097: movl 4*sclen(r9),r6 # load string length ! 24098: movl xsofs,r7 # load current offset ! 24099: subl2 r7,r6 # get number of remaining characters ! 24100: beqlu xscn2 # jump if no characters left ! 24101: movab cfp$f(r9)[r7],r9# point to current character ! 24102: # ! 24103: # LOOP TO SEARCH FOR DELIMITER ! 24104: # ! 24105: xscn1: movzbl (r9)+,r7 # load next character ! 24106: cmpl r7,r8 # jump if delimiter one found ! 24107: beqlu xscn3 ! 24108: cmpl r7,r10 # jump if delimiter two found ! 24109: beqlu xscn4 ! 24110: decl r6 # decrement count of chars left ! 24111: bnequ xscn1 # loop back if more chars to go ! 24112: # ! 24113: # HERE FOR RUNOUT ! 24114: # ! 24115: xscn2: movl r$xsc,r10 # point to string block ! 24116: movl 4*sclen(r10),r6 # get string length ! 24117: movl xsofs,r7 # load offset ! 24118: subl2 r7,r6 # get substring length ! 24119: clrl r$xsc # clear string ptr for collector ! 24120: clrl xscrt # set zero (runout) return code ! 24121: jmp xscn6 # jump to exit ! 24122: #page ! 24123: # ! 24124: # XSCAN (CONTINUED) ! 24125: # ! 24126: # HERE IF DELIMITER ONE FOUND ! 24127: # ! 24128: xscn3: movl $num01,xscrt # set return code ! 24129: jmp xscn5 # jump to merge ! 24130: # ! 24131: # HERE IF DELIMITER TWO FOUND ! 24132: # ! 24133: xscn4: movl $num02,xscrt # set return code ! 24134: # ! 24135: # MERGE HERE AFTER DETECTING A DELIMITER ! 24136: # ! 24137: xscn5: movl r$xsc,r10 # reload pointer to string ! 24138: movl 4*sclen(r10),r8 # get original length of string ! 24139: subl2 r6,r8 # minus chars left = chars scanned ! 24140: movl r8,r6 # move to reg for sbstr ! 24141: movl xsofs,r7 # set offset ! 24142: subl2 r7,r6 # compute length for sbstr ! 24143: incl r8 # adjust new cursor past delimiter ! 24144: movl r8,xsofs # store new offset ! 24145: # ! 24146: # COMMON EXIT POINT ! 24147: # ! 24148: xscn6: clrl r9 # clear garbage character ptr in xr ! 24149: jsb sbstr # build sub-string ! 24150: movl xscrt,r6 # load return code ! 24151: movl xscwb,r7 # restore wb ! 24152: rsb # return to xscan caller ! 24153: #enp # end procedure xscan ! 24154: #page ! 24155: # ! 24156: # XSCNI -- EXECUTION FUNCTION ARGUMENT SCAN ! 24157: # ! 24158: # XSCNI INITIALIZES THE SCAN USED FOR PROTOTYPE ARGUMENTS ! 24159: # IN THE CLEAR, DEFINE, LOAD, DATA, ARRAY FUNCTIONS. SEE ! 24160: # XSCAN FOR THE PROCEDURE WHICH IS USED AFTER THIS CALL. ! 24161: # ! 24162: # -(XS) ARGUMENT TO BE SCANNED (ON STACK) ! 24163: # JSR XSCNI CALL TO SCAN ARGUMENT ! 24164: # PPM LOC TRANSFER LOC IF ARG IS NOT STRING ! 24165: # PPM LOC TRANSFER LOC IF ARGUMENT IS NULL ! 24166: # (XS) POPPED ! 24167: # (XR,R$XSC) ARGUMENT (SCBLK PTR) ! 24168: # (WA) ARGUMENT LENGTH ! 24169: # (IA,RA) DESTROYED ! 24170: # ! 24171: .data 1 ! 24172: xscni_s: .long 0 ! 24173: .text 0 ! 24174: xscni: movl (sp)+,xscni_s # entry point ! 24175: jsb gtstg # fetch argument as string ! 24176: .long xsci1 # jump if not convertible ! 24177: movl r9,r$xsc # else store scblk ptr for xscan ! 24178: clrl xsofs # set offset to zero ! 24179: tstl r6 # jump if null string ! 24180: beqlu xsci2 ! 24181: addl3 $4*2,xscni_s,r11 # return to xscni caller ! 24182: jmp (r11) ! 24183: # ! 24184: # HERE IF ARGUMENT IS NOT A STRING ! 24185: # ! 24186: xsci1: movl xscni_s,r11 # take not-string error exit ! 24187: jmp *(r11)+ ! 24188: # ! 24189: # HERE FOR NULL STRING ! 24190: # ! 24191: xsci2: addl3 $4*1,xscni_s,r11 # take null-string error exit ! 24192: jmp *(r11)+ ! 24193: #enp # end procedure xscni ! 24194: #title s p i t b o l -- utility routines ! 24195: # ! 24196: # THE FOLLOWING SECTION CONTAINS UTILITY ROUTINES USED FOR ! 24197: # VARIOUS PURPOSES THROUGHOUT THE SYSTEM. THESE DIFFER ! 24198: # FROM THE PROCEDURES IN THE UTILITY PROCEDURES SECTION IN ! 24199: # THEY ARE NOT IN PROCEDURE FORM AND THEY DO NOT RETURN ! 24200: # TO THEIR CALLERS. THEY ARE ACCESSED WITH A BRANCH TYPE ! 24201: # INSTRUCTION AFTER SETTING THE REGISTERS TO APPROPRIATE ! 24202: # PARAMETER VALUES. ! 24203: # ! 24204: # THE REGISTER VALUES REQUIRED FOR EACH ROUTINE ARE ! 24205: # DOCUMENTED AT THE START OF EACH ROUTINE. REGISTERS NOT ! 24206: # MENTIONED MAY CONTAIN ANY VALUES EXCEPT THAT XR,XL ! 24207: # CAN ONLY CONTAIN PROPER COLLECTABLE POINTERS. ! 24208: # ! 24209: # SOME OF THESE ROUTINES WILL TOLERATE GARBAGE POINTERS ! 24210: # IN XL,XR ON ENTRY. THIS IS ALWAYS DOCUMENTED AND IN ! 24211: # EACH CASE, THE ROUTINE CLEARS THESE GARBAGE VALUES BEFORE ! 24212: # EXITING AFTER COMPLETING ITS TASK. ! 24213: # ! 24214: # THE ROUTINES HAVE NAMES CONSISTING OF FIVE LETTERS ! 24215: # AND ARE ASSEMBLED IN ALPHABETICAL ORDER. ! 24216: #page ! 24217: # ARREF -- ARRAY REFERENCE ! 24218: # ! 24219: # (XL) MAY BE NON-COLLECTABLE ! 24220: # (XR) NUMBER OF SUBSCRIPTS ! 24221: # (WB) SET ZERO/NONZERO FOR VALUE/NAME ! 24222: # THE VALUE IN WB MUST BE COLLECTABLE ! 24223: # STACK SUBSCRIPTS AND ARRAY OPERAND ! 24224: # BRN ARREF JUMP TO CALL FUNCTION ! 24225: # ! 24226: # ARREF CONTINUES BY EXECUTING THE NEXT CODE WORD WITH ! 24227: # THE RESULT NAME OR VALUE PLACED ON TOP OF THE STACK. ! 24228: # TO DEAL WITH THE PROBLEM OF ACCESSING SUBSCRIPTS IN THE ! 24229: # ORDER OF STACKING, XL IS USED AS A SUBSCRIPT POINTER ! 24230: # WORKING BELOW THE STACK POINTER. ! 24231: # ! 24232: arref: #rtn ! 24233: movl r9,r6 # copy number of subscripts ! 24234: movl sp,r10 # point to stack front ! 24235: moval 0[r9],r9 # convert to byte offset ! 24236: addl2 r9,r10 # point to array operand on stack ! 24237: addl2 $4,r10 # final value for stack popping ! 24238: movl r10,arfxs # keep for later ! 24239: movl -(r10),r9 # load array operand pointer ! 24240: movl r9,r$arf # keep array pointer ! 24241: movl r10,r9 # save pointer to subscripts ! 24242: movl r$arf,r10 # point xl to possible vcblk or tbblk ! 24243: movl (r10),r8 # load first word ! 24244: cmpl r8,$b$art # jump if arblk ! 24245: beqlu arf01 ! 24246: cmpl r8,$b$vct # jump if vcblk ! 24247: bnequ 0f ! 24248: jmp arf07 ! 24249: 0: ! 24250: cmpl r8,$b$tbt # jump if tbblk ! 24251: bnequ 0f ! 24252: jmp arf10 ! 24253: 0: ! 24254: jmp er_235 # subscripted operand is not table or array ! 24255: # ! 24256: # HERE FOR ARRAY (ARBLK) ! 24257: # ! 24258: arf01: cmpl r6,4*arndm(r10) # jump if wrong number of dims ! 24259: beqlu 0f ! 24260: jmp arf09 ! 24261: 0: ! 24262: movl intv0,r5 # get initial subscript of zero ! 24263: movl r9,r10 # point before subscripts ! 24264: clrl r6 # initial offset to bounds ! 24265: jmp arf03 # jump into loop ! 24266: # ! 24267: # LOOP TO COMPUTE SUBSCRIPTS BY MULTIPLICATIONS ! 24268: # ! 24269: arf02: mull2 4*ardm2(r9),r5 # multiply total by next dimension ! 24270: # ! 24271: # MERGE HERE FIRST TIME ! 24272: # ! 24273: arf03: movl -(r10),r9 # load next subscript ! 24274: movl r5,arfsi # save current subscript ! 24275: movl 4*icval(r9),r5 # load integer value in case ! 24276: cmpl (r9),$b$icl # jump if it was an integer ! 24277: beqlu arf04 ! 24278: #page ! 24279: # ! 24280: # ARREF (CONTINUED) ! 24281: # ! 24282: # ! 24283: jsb gtint # convert to integer ! 24284: .long arf12 # jump if not integer ! 24285: movl 4*icval(r9),r5 # if ok, load integer value ! 24286: # ! 24287: # HERE WITH INTEGER SUBSCRIPT IN (IA) ! 24288: # ! 24289: arf04: movl r$arf,r9 # point to array ! 24290: addl2 r6,r9 # offset to next bounds ! 24291: subl2 4*arlbd(r9),r5 # subtract low bound to compare ! 24292: bvc 0f ! 24293: jmp arf13 ! 24294: 0: ! 24295: tstl r5 # out of range fail if too small ! 24296: bgeq 0f ! 24297: jmp arf13 ! 24298: 0: ! 24299: subl2 4*ardim(r9),r5 # subtract dimension ! 24300: blss 0f # out of range fail if too large ! 24301: jmp arf13 ! 24302: 0: ! 24303: addl2 4*ardim(r9),r5 # else restore subscript offset ! 24304: addl2 arfsi,r5 # add to current total ! 24305: addl2 $4*ardms,r6 # point to next bounds ! 24306: cmpl r10,sp # loop back if more to go ! 24307: bnequ arf02 ! 24308: # ! 24309: # HERE WITH INTEGER SUBSCRIPT COMPUTED ! 24310: # ! 24311: movl r5,r6 # get as one word integer ! 24312: moval 0[r6],r6 # convert to offset ! 24313: movl r$arf,r10 # point to arblk ! 24314: addl2 4*arofs(r10),r6 # add offset past bounds ! 24315: addl2 $4,r6 # adjust for arpro field ! 24316: tstl r7 # exit with name if name call ! 24317: bnequ arf08 ! 24318: # ! 24319: # MERGE HERE TO GET VALUE FOR VALUE CALL ! 24320: # ! 24321: arf05: jsb acess # get value ! 24322: .long arf13 # fail if acess fails ! 24323: # ! 24324: # RETURN VALUE ! 24325: # ! 24326: arf06: movl arfxs,sp # pop stack entries ! 24327: clrl r$arf # finished with array pointer ! 24328: jmp exixr # exit with value in xr ! 24329: #page ! 24330: # ! 24331: # ARREF (CONTINUED) ! 24332: # ! 24333: # HERE FOR VECTOR ! 24334: # ! 24335: arf07: cmpl r6,$num01 # error if more than 1 subscript ! 24336: beqlu 0f ! 24337: jmp arf09 ! 24338: 0: ! 24339: movl (sp),r9 # else load subscript ! 24340: jsb gtint # convert to integer ! 24341: .long arf12 # error if not integer ! 24342: movl 4*icval(r9),r5 # else load integer value ! 24343: subl2 intv1,r5 # subtract for ones offset ! 24344: movl r5,r6 # get subscript as one word ! 24345: bgeq 0f ! 24346: jmp arf13 ! 24347: 0: ! 24348: addl2 $vcvls,r6 # add offset for standard fields ! 24349: moval 0[r6],r6 # convert offset to bytes ! 24350: cmpl r6,4*vclen(r10) # fail if out of range subscript ! 24351: blssu 0f ! 24352: jmp arf13 ! 24353: 0: ! 24354: tstl r7 # back to get value if value call ! 24355: beqlu arf05 ! 24356: # ! 24357: # RETURN NAME ! 24358: # ! 24359: arf08: movl arfxs,sp # pop stack entries ! 24360: clrl r$arf # finished with array pointer ! 24361: jmp exnam # else exit with name ! 24362: # ! 24363: # HERE IF SUBSCRIPT COUNT IS WRONG ! 24364: # ! 24365: arf09: jmp er_236 # array referenced with wrong number of subscripts ! 24366: # ! 24367: # TABLE ! 24368: # ! 24369: arf10: cmpl r6,$num01 # error if more than 1 subscript ! 24370: bnequ arf11 ! 24371: movl (sp),r9 # else load subscript ! 24372: jsb tfind # call table search routine ! 24373: .long arf13 # fail if failed ! 24374: tstl r7 # exit with name if name call ! 24375: bnequ arf08 ! 24376: jmp arf06 # else exit with value ! 24377: # ! 24378: # HERE FOR BAD TABLE REFERENCE ! 24379: # ! 24380: arf11: jmp er_237 # table referenced with more than one subscript ! 24381: # ! 24382: # HERE FOR BAD SUBSCRIPT ! 24383: # ! 24384: arf12: jmp er_238 # array subscript is not integer ! 24385: # ! 24386: # HERE TO SIGNAL FAILURE ! 24387: # ! 24388: arf13: clrl r$arf # finished with array pointer ! 24389: jmp exfal # fail ! 24390: #page ! 24391: # ! 24392: # CFUNC -- CALL A FUNCTION ! 24393: # ! 24394: # CFUNC IS USED TO CALL A SNOBOL LEVEL FUNCTION. IT IS ! 24395: # USED BY THE APPLY FUNCTION (S$APP), THE FUNCTION ! 24396: # TRACE ROUTINE (TRXEQ) AND THE MAIN FUNCTION CALL ENTRY ! 24397: # (O$FNC, O$FNS). IN THE LATTER CASES, CFUNC IS USED ONLY ! 24398: # IF THE NUMBER OF ARGUMENTS IS INCORRECT. ! 24399: # ! 24400: # (XL) POINTER TO FUNCTION BLOCK ! 24401: # (WA) ACTUAL NUMBER OF ARGUMENTS ! 24402: # (XS) POINTS TO STACKED ARGUMENTS ! 24403: # BRN CFUNC JUMP TO CALL FUNCTION ! 24404: # ! 24405: # CFUNC CONTINUES BY EXECUTING THE FUNCTION ! 24406: # ! 24407: cfunc: #rtn ! 24408: cmpl r6,4*fargs(r10) # jump if too few arguments ! 24409: blssu cfnc1 ! 24410: cmpl r6,4*fargs(r10) # jump if correct number of args ! 24411: beqlu cfnc3 ! 24412: # ! 24413: # HERE IF TOO MANY ARGUMENTS SUPPLIED, POP THEM OFF ! 24414: # ! 24415: movl r6,r7 # copy actual number ! 24416: subl2 4*fargs(r10),r7 # get number of extra args ! 24417: moval 0[r7],r7 # convert to bytes ! 24418: addl2 r7,sp # pop off unwanted arguments ! 24419: jmp cfnc3 # jump to go off to function ! 24420: # ! 24421: # HERE IF TOO FEW ARGUMENTS ! 24422: # ! 24423: cfnc1: movl 4*fargs(r10),r7 # load required number of arguments ! 24424: cmpl r7,$nini9 # jump if case of var num of args ! 24425: beqlu cfnc3 ! 24426: subl2 r6,r7 # calculate number missing ! 24427: # set counter to control loop ! 24428: # ! 24429: # LOOP TO SUPPLY EXTRA NULL ARGUMENTS ! 24430: # ! 24431: cfnc2: movl $nulls,-(sp) # stack a null argument ! 24432: sobgtr r7,cfnc2 # loop till proper number stacked ! 24433: # ! 24434: # MERGE HERE TO JUMP TO FUNCTION ! 24435: # ! 24436: cfnc3: movl (r10),r11 # jump through fcode field ! 24437: jmp (r11) ! 24438: #page ! 24439: # ! 24440: # EXFAL -- EXIT SIGNALLING SNOBOL FAILURE ! 24441: # ! 24442: # (XL,XR) MAY BE NON-COLLECTABLE ! 24443: # BRN EXFAL JUMP TO FAIL ! 24444: # ! 24445: # EXFAL CONTINUES BY EXECUTING THE APPROPRIATE FAIL GOTO ! 24446: # ! 24447: exfal: #rtn ! 24448: movl flptr,sp # pop stack ! 24449: movl (sp),r9 # load failure offset ! 24450: addl2 r$cod,r9 # point to failure code location ! 24451: movl r9,r3 # set code pointer ! 24452: jmp exits # do next code word ! 24453: #page ! 24454: # ! 24455: # EXINT -- EXIT WITH INTEGER RESULT ! 24456: # ! 24457: # (XL,XR) MAY BE NONCOLLECTABLE ! 24458: # (IA) INTEGER VALUE ! 24459: # BRN EXINT JUMP TO EXIT WITH INTEGER ! 24460: # ! 24461: # EXINT CONTINUES BY EXECUTING THE NEXT CODE WORD ! 24462: # WHICH IT DOES BY FALLING THROUGH TO EXIXR ! 24463: # ! 24464: exint: #rtn ! 24465: jsb icbld # build icblk ! 24466: #page ! 24467: # EXIXR -- EXIT WITH RESULT IN (XR) ! 24468: # ! 24469: # (XR) RESULT ! 24470: # (XL) MAY BE NON-COLLECTABLE ! 24471: # BRN EXIXR JUMP TO EXIT WITH RESULT IN (XR) ! 24472: # ! 24473: # EXIXR CONTINUES BY EXECUTING THE NEXT CODE WORD ! 24474: # WHICH IT DOES BY FALLING THROUGH TO EXITS. ! 24475: exixr: #rtn ! 24476: # ! 24477: movl r9,-(sp) # stack result ! 24478: # ! 24479: # ! 24480: # EXITS -- EXIT WITH RESULT IF ANY STACKED ! 24481: # ! 24482: # (XR,XL) MAY BE NON-COLLECTABLE ! 24483: # ! 24484: # BRN EXITS ENTER EXITS ROUTINE ! 24485: # ! 24486: exits: #rtn ! 24487: movl (r3)+,r9 # load next code word ! 24488: movl (r9),r10 # load entry address ! 24489: movl r10,r11 # jump to execute next code word ! 24490: jmp (r11) ! 24491: #page ! 24492: # ! 24493: # EXNAM -- EXIT WITH NAME IN (XL,WA) ! 24494: # ! 24495: # (XL) NAME BASE ! 24496: # (WA) NAME OFFSET ! 24497: # (XR) MAY BE NON-COLLECTABLE ! 24498: # BRN EXNAM JUMP TO EXIT WITH NAME IN (XL,WA) ! 24499: # ! 24500: # EXNAM CONTINUES BY EXECUTING THE NEXT CODE WORD ! 24501: # ! 24502: exnam: #rtn ! 24503: movl r10,-(sp) # stack name base ! 24504: movl r6,-(sp) # stack name offset ! 24505: jmp exits # do next code word ! 24506: #page ! 24507: # ! 24508: # EXNUL -- EXIT WITH NULL RESULT ! 24509: # ! 24510: # (XL,XR) MAY BE NON-COLLECTABLE ! 24511: # BRN EXNUL JUMP TO EXIT WITH NULL VALUE ! 24512: # ! 24513: # EXNUL CONTINUES BY EXECUTING THE NEXT CODE WORD ! 24514: # ! 24515: exnul: #rtn ! 24516: movl $nulls,-(sp) # stack null value ! 24517: jmp exits # do next code word ! 24518: #page ! 24519: # ! 24520: # EXREA -- EXIT WITH REAL RESULT ! 24521: # ! 24522: # (XL,XR) MAY BE NON-COLLECTABLE ! 24523: # (RA) REAL VALUE ! 24524: # BRN EXREA JUMP TO EXIT WITH REAL VALUE ! 24525: # ! 24526: # EXREA CONTINUES BY EXECUTING THE NEXT CODE WORD ! 24527: # ! 24528: exrea: #rtn ! 24529: jsb rcbld # build rcblk ! 24530: jmp exixr # jump to exit with result in xr ! 24531: #page ! 24532: # ! 24533: # EXSID -- EXIT SETTING ID FIELD ! 24534: # ! 24535: # EXSID IS USED TO EXIT AFTER BUILDING ANY OF THE FOLLOWING ! 24536: # BLOCKS (ARBLK, TBBLK, PDBLK, VCBLK). IT SETS THE IDVAL. ! 24537: # ! 24538: # (XR) PTR TO BLOCK WITH IDVAL FIELD ! 24539: # (XL) MAY BE NON-COLLECTABLE ! 24540: # BRN EXSID JUMP TO EXIT AFTER SETTING ID FIELD ! 24541: # ! 24542: # EXSID CONTINUES BY EXECUTING THE NEXT CODE WORD ! 24543: # ! 24544: exsid: #rtn ! 24545: movl curid,r6 # load current id value ! 24546: cmpl r6,$cfp$m # jump if no overflow ! 24547: bnequ exsi1 ! 24548: clrl r6 # else reset for wraparound ! 24549: # ! 24550: # HERE WITH OLD IDVAL IN WA ! 24551: # ! 24552: exsi1: incl r6 # bump id value ! 24553: movl r6,curid # store for next time ! 24554: movl r6,4*idval(r9) # store id value ! 24555: jmp exixr # exit with result in (xr) ! 24556: #page ! 24557: # ! 24558: # EXVNM -- EXIT WITH NAME OF VARIABLE ! 24559: # ! 24560: # EXVNM EXITS AFTER STACKING A VALUE WHICH IS A NMBLK ! 24561: # REFERENCING THE NAME OF A GIVEN NATURAL VARIABLE. ! 24562: # ! 24563: # (XR) VRBLK POINTER ! 24564: # (XL) MAY BE NON-COLLECTABLE ! 24565: # BRN EXVNM EXIT WITH VRBLK POINTER IN XR ! 24566: # ! 24567: exvnm: #rtn ! 24568: movl r9,r10 # copy name base pointer ! 24569: movl $4*nmsi$,r6 # set size of nmblk ! 24570: jsb alloc # allocate nmblk ! 24571: movl $b$nml,(r9) # store type word ! 24572: movl r10,4*nmbas(r9) # store name base ! 24573: movl $4*vrval,4*nmofs(r9) # store name offset ! 24574: jmp exixr # exit with result in xr ! 24575: #page ! 24576: # ! 24577: # FLPOP -- FAIL AND POP IN PATTERN MATCHING ! 24578: # ! 24579: # FLPOP POPS THE NODE AND CURSOR ON THE STACK AND THEN ! 24580: # DROPS THROUGH INTO FAILP TO CAUSE PATTERN FAILURE ! 24581: # ! 24582: # (XL,XR) MAY BE NON-COLLECTABLE ! 24583: # BRN FLPOP JUMP TO FAIL AND POP STACK ! 24584: # ! 24585: flpop: #rtn ! 24586: addl2 $4*num02,sp # pop two entries off stack ! 24587: #page ! 24588: # ! 24589: # FAILP -- FAILURE IN MATCHING PATTERN NODE ! 24590: # ! 24591: # FAILP IS USED AFTER FAILING TO MATCH A PATTERN NODE. ! 24592: # SEE PATTERN MATCH ROUTINES FOR DETAILS OF USE. ! 24593: # ! 24594: # (XL,XR) MAY BE NON-COLLECTABLE ! 24595: # BRN FAILP SIGNAL FAILURE TO MATCH ! 24596: # ! 24597: # FAILP CONTINUES BY MATCHING AN ALTERNATIVE FROM THE STACK ! 24598: # ! 24599: failp: #rtn ! 24600: movl (sp)+,r9 # load alternative node pointer ! 24601: movl (sp)+,r7 # restore old cursor ! 24602: movl (r9),r10 # load pcode entry pointer ! 24603: movl r10,r11 # jump to execute code for node ! 24604: jmp (r11) ! 24605: #page ! 24606: # ! 24607: # INDIR -- COMPUTE INDIRECT REFERENCE ! 24608: # ! 24609: # (WB) NONZERO/ZERO FOR BY NAME/VALUE ! 24610: # BRN INDIR JUMP TO GET INDIRECT REF ON STACK ! 24611: # ! 24612: # INDIR CONTINUES BY EXECUTING THE NEXT CODE WORD ! 24613: # ! 24614: indir: #rtn ! 24615: movl (sp)+,r9 # load argument ! 24616: cmpl (r9),$b$nml # jump if a name ! 24617: beqlu indr2 ! 24618: jsb gtnvr # else convert to variable ! 24619: .long er_239 # indirection operand is not name ! 24620: tstl r7 # skip if by value ! 24621: beqlu indr1 ! 24622: movl r9,-(sp) # else stack vrblk ptr ! 24623: movl $4*vrval,-(sp) # stack name offset ! 24624: jmp exits # exit with result on stack ! 24625: # ! 24626: # HERE TO GET VALUE OF NATURAL VARIABLE ! 24627: # ! 24628: indr1: movl (r9),r11 # jump through vrget field of vrblk ! 24629: jmp (r11) ! 24630: # ! 24631: # HERE IF OPERAND IS A NAME ! 24632: # ! 24633: indr2: movl 4*nmbas(r9),r10 # load name base ! 24634: movl 4*nmofs(r9),r6 # load name offset ! 24635: tstl r7 # exit if called by name ! 24636: beqlu 0f ! 24637: jmp exnam ! 24638: 0: ! 24639: jsb acess # else get value first ! 24640: .long exfal # fail if access fails ! 24641: jmp exixr # else return with value in xr ! 24642: #page ! 24643: # ! 24644: # MATCH -- INITIATE PATTERN MATCH ! 24645: # ! 24646: # (WB) MATCH TYPE CODE ! 24647: # BRN MATCH JUMP TO INITIATE PATTERN MATCH ! 24648: # ! 24649: # MATCH CONTINUES BY EXECUTING THE PATTERN MATCH. SEE ! 24650: # PATTERN MATCH ROUTINES (P$XXX) FOR FULL DETAILS. ! 24651: # ! 24652: match: #rtn ! 24653: movl (sp)+,r9 # load pattern operand ! 24654: jsb gtpat # convert to pattern ! 24655: .long er_240 # pattern match right operand is not pattern ! 24656: movl r9,r10 # if ok, save pattern pointer ! 24657: tstl r7 # jump if not match by name ! 24658: bnequ mtch1 ! 24659: movl (sp),r6 # else load name offset ! 24660: movl r10,-(sp) # save pattern pointer ! 24661: movl 4*2(sp),r10 # load name base ! 24662: jsb acess # access subject value ! 24663: .long exfal # fail if access fails ! 24664: movl (sp),r10 # restore pattern pointer ! 24665: movl r9,(sp) # stack subject string val for merge ! 24666: clrl r7 # restore type code ! 24667: # ! 24668: # MERGE HERE WITH SUBJECT VALUE ON STACK ! 24669: # ! 24670: mtch1: movl (sp),r9 # load subject value ! 24671: clrl r$pmb # assume not a buffer ! 24672: cmpl (r9),$b$bct # branch if not ! 24673: bnequ mtcha ! 24674: addl2 $4,sp # else pop value ! 24675: movl r9,r$pmb # save pointer ! 24676: movl 4*bclen(r9),r6 # get defined length ! 24677: movl 4*bcbuf(r9),r9 # point to bfblk ! 24678: jmp mtchb ! 24679: # ! 24680: # HERE IF NOT BUFFER TO CONVERT TO STRING ! 24681: # ! 24682: mtcha: jsb gtstg # not buffer - convert to string ! 24683: .long er_241 # pattern match left operand is not string ! 24684: # ! 24685: # MERGE WITH BUFFER OR STRING ! 24686: # ! 24687: mtchb: movl r9,r$pms # if ok, store subject string pointer ! 24688: movl r6,pmssl # and length ! 24689: movl r7,-(sp) # stack match type code ! 24690: clrl -(sp) # stack initial cursor (zero) ! 24691: clrl r7 # set initial cursor ! 24692: movl sp,pmhbs # set history stack base ptr ! 24693: clrl pmdfl # reset pattern assignment flag ! 24694: movl r10,r9 # set initial node pointer ! 24695: tstl kvanc # jump if anchored ! 24696: bnequ mtch2 ! 24697: # ! 24698: # HERE FOR UNANCHORED ! 24699: # ! 24700: movl r9,-(sp) # stack initial node pointer ! 24701: movl $nduna,-(sp) # stack pointer to anchor move node ! 24702: movl (r9),r11 # start match of first node ! 24703: jmp (r11) ! 24704: # ! 24705: # HERE IN ANCHORED MODE ! 24706: # ! 24707: mtch2: clrl -(sp) # dummy cursor value ! 24708: movl $ndabo,-(sp) # stack pointer to abort node ! 24709: movl (r9),r11 # start match of first node ! 24710: jmp (r11) ! 24711: #page ! 24712: # ! 24713: # RETRN -- RETURN FROM FUNCTION ! 24714: # ! 24715: # (WA) STRING POINTER FOR RETURN TYPE ! 24716: # BRN RETRN JUMP TO RETURN FROM (SNOBOL) FUNC ! 24717: # ! 24718: # RETRN CONTINUES BY EXECUTING THE CODE AT THE RETURN POINT ! 24719: # THE STACK IS CLEANED OF ANY GARBAGE LEFT BY OTHER ! 24720: # ROUTINES WHICH MAY HAVE ALTERED FLPTR SINCE FUNCTION ! 24721: # ENTRY BY USING FLPRT, RESERVED FOR USE ONLY BY ! 24722: # FUNCTION CALL AND RETURN. ! 24723: # ! 24724: retrn: #rtn ! 24725: tstl kvfnc # jump if not level zero ! 24726: bnequ rtn01 ! 24727: jmp er_242 # function return from level zero ! 24728: # ! 24729: # HERE IF NOT LEVEL ZERO RETURN ! 24730: # ! 24731: rtn01: movl flprt,sp # pop stack ! 24732: addl2 $4,sp # remove failure offset ! 24733: movl (sp)+,r9 # pop pfblk pointer ! 24734: movl (sp)+,flptr # pop failure pointer ! 24735: movl (sp)+,flprt # pop old flprt ! 24736: movl (sp)+,r7 # pop code pointer offset ! 24737: movl (sp)+,r8 # pop old code block pointer ! 24738: addl2 r8,r7 # make old code pointer absolute ! 24739: movl r7,r3 # restore old code pointer ! 24740: movl r8,r$cod # restore old code block pointer ! 24741: decl kvfnc # decrement function level ! 24742: movl kvtra,r7 # load trace ! 24743: addl2 kvftr,r7 # add ftrace ! 24744: bnequ 0f # jump if no tracing possible ! 24745: jmp rtn06 ! 24746: 0: ! 24747: # ! 24748: # HERE IF THERE MAY BE A TRACE ! 24749: # ! 24750: movl r6,-(sp) # save function return type ! 24751: movl r9,-(sp) # save pfblk pointer ! 24752: movl r6,kvrtn # set rtntype for trace function ! 24753: movl r$fnc,r10 # load fnclevel trblk ptr (if any) ! 24754: jsb ktrex # execute possible fnclevel trace ! 24755: movl 4*pfvbl(r9),r10 # load vrblk ptr (sgd13) ! 24756: tstl kvtra # jump if trace is off ! 24757: beqlu rtn02 ! 24758: movl 4*pfrtr(r9),r9 # else load return trace trblk ptr ! 24759: beqlu rtn02 # jump if not return traced ! 24760: decl kvtra # else decrement trace count ! 24761: tstl 4*trfnc(r9) # jump if print trace ! 24762: beqlu rtn03 ! 24763: movl $4*vrval,r6 # else set name offset ! 24764: movl 4*1(sp),kvrtn # make sure rtntype is set right ! 24765: jsb trxeq # execute full trace ! 24766: #page ! 24767: # ! 24768: # RETRN (CONTINUED) ! 24769: # ! 24770: # HERE TO TEST FOR FTRACE ! 24771: # ! 24772: rtn02: tstl kvftr # jump if ftrace is off ! 24773: beqlu rtn05 ! 24774: decl kvftr # else decrement ftrace ! 24775: # ! 24776: # HERE FOR PRINT TRACE OF FUNCTION RETURN ! 24777: # ! 24778: rtn03: jsb prtsn # print statement number ! 24779: movl 4*1(sp),r9 # load return type ! 24780: jsb prtst # print it ! 24781: movl $ch$bl,r6 # load blank ! 24782: jsb prtch # print it ! 24783: movl (sp),r10 # load pfblk ptr ! 24784: movl 4*pfvbl(r10),r10# load function vrblk ptr ! 24785: movl $4*vrval,r6 # set vrblk name offset ! 24786: cmpl r9,$scfrt # jump if not freturn case ! 24787: bnequ rtn04 ! 24788: # ! 24789: # FOR FRETURN, JUST PRINT FUNCTION NAME ! 24790: # ! 24791: jsb prtnm # print name ! 24792: jsb prtnl # terminate print line ! 24793: jmp rtn05 # merge ! 24794: # ! 24795: # HERE FOR RETURN OR NRETURN, PRINT FUNCTION NAME = VALUE ! 24796: # ! 24797: rtn04: jsb prtnv # print name = value ! 24798: # ! 24799: # HERE AFTER COMPLETING TRACE ! 24800: # ! 24801: rtn05: movl (sp)+,r9 # pop pfblk pointer ! 24802: movl (sp)+,r6 # pop return type string ! 24803: # ! 24804: # MERGE HERE IF NO TRACE REQUIRED ! 24805: # ! 24806: rtn06: movl r6,kvrtn # set rtntype keyword ! 24807: movl 4*pfvbl(r9),r10 # load pointer to fn vrblk ! 24808: #page ! 24809: # RETRN (CONTINUED) ! 24810: # ! 24811: # GET VALUE OF FUNCTION ! 24812: # ! 24813: rtn07: movl r10,rtnbp # save block pointer ! 24814: movl 4*vrval(r10),r10# load value ! 24815: cmpl (r10),$b$trt # loop back if trapped ! 24816: beqlu rtn07 ! 24817: movl r10,rtnfv # else save function result value ! 24818: movl (sp)+,rtnsv # save original function value ! 24819: movl (sp)+,r10 # pop saved pointer ! 24820: beqlu rtn7c # no action if none ! 24821: tstl kvpfl # jump if no profiling ! 24822: beqlu rtn7c ! 24823: jsb prflu # else profile last func stmt ! 24824: cmpl kvpfl,$num02 # branch on value of profile keywd ! 24825: beqlu rtn7a ! 24826: # ! 24827: # HERE IF &PROFILE = 1. START TIME MUST BE FRIGGED TO ! 24828: # APPEAR EARLIER THAN IT ACTUALLY IS, BY AMOUNT USED BEFORE ! 24829: # THE CALL. ! 24830: # ! 24831: movl pfstm,r5 # load current time ! 24832: subl2 4*icval(r10),r5 # frig by subtracting saved amount ! 24833: jmp rtn7b # and merge ! 24834: # ! 24835: # HERE IF &PROFILE = 2 ! 24836: # ! 24837: rtn7a: movl 4*icval(r10),r5 # load saved time ! 24838: # ! 24839: # BOTH PROFILE TYPES MERGE HERE ! 24840: # ! 24841: rtn7b: movl r5,pfstm # store back correct start time ! 24842: # ! 24843: # MERGE HERE IF NO PROFILING ! 24844: # ! 24845: rtn7c: movl 4*fargs(r9),r7 # get number of args ! 24846: addl2 4*pfnlo(r9),r7 # add number of locals ! 24847: beqlu rtn10 # jump if no args/locals ! 24848: # else set loop counter ! 24849: addl2 4*pflen(r9),r9 # and point to end of pfblk ! 24850: # ! 24851: # LOOP TO RESTORE FUNCTIONS AND LOCALS ! 24852: # ! 24853: rtn08: movl -(r9),r10 # load next vrblk pointer ! 24854: # ! 24855: # LOOP TO FIND VALUE BLOCK ! 24856: # ! 24857: rtn09: movl r10,r6 # save block pointer ! 24858: movl 4*vrval(r10),r10# load pointer to next value ! 24859: cmpl (r10),$b$trt # loop back if trapped ! 24860: beqlu rtn09 ! 24861: movl r6,r10 # else restore last block pointer ! 24862: movl (sp)+,4*vrval(r10) # restore old variable value ! 24863: sobgtr r7,rtn08 # loop till all processed ! 24864: # ! 24865: # NOW RESTORE FUNCTION VALUE AND EXIT ! 24866: # ! 24867: rtn10: movl rtnbp,r10 # restore ptr to last function block ! 24868: movl rtnsv,4*vrval(r10) # restore old function value ! 24869: movl rtnfv,r9 # reload function result ! 24870: movl r$cod,r10 # point to new code block ! 24871: movl kvstn,kvlst # set lastno from stno ! 24872: movl 4*cdstm(r10),kvstn # reset proper stno value ! 24873: movl kvrtn,r6 # load return type ! 24874: cmpl r6,$scrtn # exit with result in xr if return ! 24875: bnequ 0f ! 24876: jmp exixr ! 24877: 0: ! 24878: cmpl r6,$scfrt # fail if freturn ! 24879: bnequ 0f ! 24880: jmp exfal ! 24881: 0: ! 24882: #page ! 24883: # ! 24884: # RETRN (CONTINUED) ! 24885: # ! 24886: # HERE FOR NRETURN ! 24887: # ! 24888: cmpl (r9),$b$nml # jump if is a name ! 24889: beqlu rtn11 ! 24890: jsb gtnvr # else try convert to variable name ! 24891: .long er_243 # function result in nreturn is not name ! 24892: movl r9,r10 # if ok, copy vrblk (name base) ptr ! 24893: movl $4*vrval,r6 # set name offset ! 24894: jmp rtn12 # and merge ! 24895: # ! 24896: # HERE IF RETURNED RESULT IS A NAME ! 24897: # ! 24898: rtn11: movl 4*nmbas(r9),r10 # load name base ! 24899: movl 4*nmofs(r9),r6 # load name offset ! 24900: # ! 24901: # MERGE HERE WITH RETURNED NAME IN (XL,WA) ! 24902: # ! 24903: rtn12: movl r10,r9 # preserve xl ! 24904: movl (r3)+,r7 # load next word ! 24905: movl r9,r10 # restore xl ! 24906: cmpl r7,$ofne$ # exit if called by name ! 24907: bnequ 0f ! 24908: jmp exnam ! 24909: 0: ! 24910: movl r7,-(sp) # else save code word ! 24911: jsb acess # get value ! 24912: .long exfal # fail if access fails ! 24913: movl r9,r10 # if ok, copy result ! 24914: movl (sp),r9 # reload next code word ! 24915: movl r10,(sp) # store result on stack ! 24916: movl (r9),r10 # load routine address ! 24917: movl r10,r11 # jump to execute next code word ! 24918: jmp (r11) ! 24919: #page ! 24920: # ! 24921: # STCOV -- SIGNAL STATEMENT COUNTER OVERFLOW ! 24922: # ! 24923: # BRN STCOV JUMP TO SIGNAL STATEMENT COUNT OFLO ! 24924: # ! 24925: # PERMIT UP TO 10 MORE STATEMENTS TO BE OBEYED SO THAT ! 24926: # SETEXIT TRAP CAN REGAIN CONTROL. ! 24927: # STCOV CONTINUES BY ISSUING THE ERROR MESSAGE ! 24928: # ! 24929: stcov: #rtn ! 24930: incl errft # fatal error ! 24931: movl intvt,r5 # get 10 ! 24932: addl2 kvstl,r5 # add to former limit ! 24933: movl r5,kvstl # store as new stlimit ! 24934: movl intvt,r5 # get 10 ! 24935: movl r5,kvstc # set as new count ! 24936: jmp er_244 # statement count exceeds value of stlimit keyword ! 24937: #page ! 24938: # ! 24939: # STMGO -- START EXECUTION OF NEW STATEMENT ! 24940: # ! 24941: # (XR) POINTER TO CDBLK FOR NEW STATEMENT ! 24942: # BRN STMGO JUMP TO EXECUTE NEW STATEMENT ! 24943: # ! 24944: # STMGO CONTINUES BY EXECUTING THE NEXT STATEMENT ! 24945: # ! 24946: stmgo: #rtn ! 24947: movl r9,r$cod # set new code block pointer ! 24948: tstl kvpfl # skip if no profiling ! 24949: beqlu stgo1 ! 24950: jsb prflu # else profile the statement ! 24951: stgo1: movl kvstn,kvlst # set lastno ! 24952: movl 4*cdstm(r9),kvstn# set stno ! 24953: addl2 $4*cdcod,r9 # point to first code word ! 24954: movl r9,r3 # set code pointer ! 24955: movl kvstc,r5 # get stmt count ! 24956: bgeq 0f # omit counting if negative ! 24957: jmp exits ! 24958: 0: ! 24959: tstl r5 # fail if stlimit reached ! 24960: beql stcov ! 24961: subl2 intv1,r5 # decrement ! 24962: movl r5,kvstc # replace it ! 24963: tstl r$stc # exit if no stcount trace ! 24964: bnequ 0f ! 24965: jmp exits ! 24966: 0: ! 24967: # ! 24968: # HERE FOR STCOUNT TRACE ! 24969: # ! 24970: clrl r9 # clear garbage value in xr ! 24971: movl r$stc,r10 # load pointer to stcount trblk ! 24972: jsb ktrex # execute keyword trace ! 24973: jmp exits # and then exit for next code word ! 24974: #page ! 24975: # ! 24976: # STOPR -- TERMINATE RUN ! 24977: # ! 24978: # (XR) POINTS TO ENDING MESSAGE ! 24979: # BRN STOPR JUMP TO TERMINATE RUN ! 24980: # ! 24981: # TERMINATE RUN AND PRINT STATISTICS. ON ENTRY XR POINTS ! 24982: # TO ENDING MESSAGE OR IS ZERO IF MESSAGE PRINTED ALREADY. ! 24983: # ! 24984: stopr: #rtn ! 24985: tstl r9 # skip if sysax already called (reg04) ! 24986: beqlu stpra ! 24987: jsb sysax # call after execution proc ! 24988: stpra: addl2 rsmem,dname # use the reserve memory ! 24989: cmpl r9,$endms # skip if not normal end message ! 24990: bnequ stpr0 ! 24991: tstl exsts # skip if exec stats suppressed ! 24992: beqlu 0f ! 24993: jmp stpr3 ! 24994: 0: ! 24995: clrl erich # clear errors to int.ch. flag ! 24996: # ! 24997: # LOOK TO SEE IF AN ENDING MESSAGE IS SUPPLIED ! 24998: # ! 24999: stpr0: jsb prtpg # eject printer ! 25000: tstl r9 # skip if no message ! 25001: beqlu stpr1 ! 25002: jsb prtst # print message ! 25003: # ! 25004: # MERGE HERE IF NO MESSAGE TO PRINT ! 25005: # ! 25006: stpr1: jsb prtis # print blank line ! 25007: movl kvstn,r5 # get statement number ! 25008: movl $stpm1,r9 # point to message /in statement xxx/ ! 25009: jsb prtmx # print it ! 25010: jsb systm # get current time ! 25011: subl2 timsx,r5 # minus start time = elapsed exec tim ! 25012: movl r5,stpti # save for later ! 25013: movl $stpm3,r9 # point to msg /execution time msec / ! 25014: jsb prtmx # print it ! 25015: movl kvstl,r5 # get statement limit ! 25016: blss stpr2 # skip if negative ! 25017: subl2 kvstc,r5 # minus counter = count ! 25018: movl r5,stpsi # save ! 25019: movl $stpm2,r9 # point to message /stmts executed/ ! 25020: jsb prtmx # print it ! 25021: movl stpti,r5 # reload elapsed time ! 25022: mull2 intth,r5 # *1000 (microsecs) ! 25023: bvs stpr2 ! 25024: divl2 stpsi,r5 # divide by statement count ! 25025: bvs stpr2 ! 25026: movl $stpm4,r9 # point to msg (mcsec per statement / ! 25027: jsb prtmx # print it ! 25028: #page ! 25029: # ! 25030: # STOPR (CONTINUED) ! 25031: # ! 25032: # MERGE TO SKIP MESSAGE (OVERFLOW OR NEGATIVE STLIMIT) ! 25033: # ! 25034: stpr2: movl gbcnt,r5 # load count of collections ! 25035: movl $stpm5,r9 # point to message /regenerations / ! 25036: jsb prtmx # print it ! 25037: jsb prtis # one more blank for luck ! 25038: # ! 25039: # CHECK IF DUMP REQUESTED ! 25040: # ! 25041: stpr3: jsb prflr # print profile if wanted ! 25042: # ! 25043: movl kvdmp,r9 # load dump keyword ! 25044: jsb dumpr # execute dump if requested ! 25045: movl r$fcb,r10 # get fcblk chain head ! 25046: movl kvabe,r6 # load abend value ! 25047: movl kvcod,r7 # load code value ! 25048: jsb sysej # exit to system ! 25049: #page ! 25050: # ! 25051: # SUCCP -- SIGNAL SUCCESSFUL MATCH OF A PATTERN NODE ! 25052: # ! 25053: # SEE PATTERN MATCH ROUTINES FOR DETAILS ! 25054: # ! 25055: # (XR) CURRENT NODE ! 25056: # (WB) CURRENT CURSOR ! 25057: # (XL) MAY BE NON-COLLECTABLE ! 25058: # BRN SUCCP SIGNAL SUCCESSFUL PATTERN MATCH ! 25059: # ! 25060: # SUCCP CONTINUES BY MATCHING THE SUCCESSOR NODE ! 25061: # ! 25062: succp: #rtn ! 25063: movl 4*pthen(r9),r9 # load successor node ! 25064: movl (r9),r10 # load node code entry address ! 25065: movl r10,r11 # jump to match successor node ! 25066: jmp (r11) ! 25067: #page ! 25068: # ! 25069: # SYSAB -- PRINT /ABNORMAL END/ AND TERMINATE ! 25070: # ! 25071: sysab: #rtn ! 25072: movl $endab,r9 # point to message ! 25073: movl $num01,kvabe # set abend flag ! 25074: jsb prtnl # skip to new line ! 25075: jmp stopr # jump to pack up ! 25076: #page ! 25077: # ! 25078: # SYSTU -- PRINT /TIME UP/ AND TERMINATE ! 25079: # ! 25080: systu: #rtn ! 25081: movl $endtu,r9 # point to message ! 25082: movl strtu,r6 # get chars /tu/ ! 25083: movl r6,kvcod # put in kvcod ! 25084: movl timup,r6 # check state of timeup switch ! 25085: movl sp,timup # set switch ! 25086: tstl r6 # stop run if already set ! 25087: beqlu 0f ! 25088: jmp stopr ! 25089: 0: ! 25090: jmp er_245 # translation/execution time expired ! 25091: #title s p i t b o l -- stack overflow section ! 25092: # ! 25093: # CONTROL COMES HERE IF THE MAIN STACK OVERFLOWS ! 25094: # ! 25095: er_001: movzwl $1,r6 ! 25096: jmp error ! 25097: er_002: movzwl $2,r6 ! 25098: jmp error ! 25099: er_003: movzwl $3,r6 ! 25100: jmp error ! 25101: er_004: movzwl $4,r6 ! 25102: jmp error ! 25103: er_005: movzwl $5,r6 ! 25104: jmp error ! 25105: er_006: movzwl $6,r6 ! 25106: jmp error ! 25107: er_007: movzwl $7,r6 ! 25108: jmp error ! 25109: er_008: movzwl $8,r6 ! 25110: jmp error ! 25111: er_009: movzwl $9,r6 ! 25112: jmp error ! 25113: er_010: movzwl $10,r6 ! 25114: jmp error ! 25115: er_011: movzwl $11,r6 ! 25116: jmp error ! 25117: er_012: movzwl $12,r6 ! 25118: jmp error ! 25119: er_013: movzwl $13,r6 ! 25120: jmp error ! 25121: er_014: movzwl $14,r6 ! 25122: jmp error ! 25123: er_015: movzwl $15,r6 ! 25124: jmp error ! 25125: er_016: movzwl $16,r6 ! 25126: jmp error ! 25127: er_017: movzwl $17,r6 ! 25128: jmp error ! 25129: er_018: movzwl $18,r6 ! 25130: jmp error ! 25131: er_019: movzwl $19,r6 ! 25132: jmp error ! 25133: er_020: movzwl $20,r6 ! 25134: jmp error ! 25135: er_021: movzwl $21,r6 ! 25136: jmp error ! 25137: er_022: movzwl $22,r6 ! 25138: jmp error ! 25139: er_023: movzwl $23,r6 ! 25140: jmp error ! 25141: er_024: movzwl $24,r6 ! 25142: jmp error ! 25143: er_025: movzwl $25,r6 ! 25144: jmp error ! 25145: er_026: movzwl $26,r6 ! 25146: jmp error ! 25147: er_027: movzwl $27,r6 ! 25148: jmp error ! 25149: er_028: movzwl $28,r6 ! 25150: jmp error ! 25151: er_029: movzwl $29,r6 ! 25152: jmp error ! 25153: er_030: movzwl $30,r6 ! 25154: jmp error ! 25155: er_031: movzwl $31,r6 ! 25156: jmp error ! 25157: er_032: movzwl $32,r6 ! 25158: jmp error ! 25159: er_033: movzwl $33,r6 ! 25160: jmp error ! 25161: er_034: movzwl $34,r6 ! 25162: jmp error ! 25163: er_035: movzwl $35,r6 ! 25164: jmp error ! 25165: er_036: movzwl $36,r6 ! 25166: jmp error ! 25167: er_037: movzwl $37,r6 ! 25168: jmp error ! 25169: er_038: movzwl $38,r6 ! 25170: jmp error ! 25171: er_039: movzwl $39,r6 ! 25172: jmp error ! 25173: er_040: movzwl $40,r6 ! 25174: jmp error ! 25175: er_041: movzwl $41,r6 ! 25176: jmp error ! 25177: er_042: movzwl $42,r6 ! 25178: jmp error ! 25179: er_043: movzwl $43,r6 ! 25180: jmp error ! 25181: er_044: movzwl $44,r6 ! 25182: jmp error ! 25183: er_045: movzwl $45,r6 ! 25184: jmp error ! 25185: er_046: movzwl $46,r6 ! 25186: jmp error ! 25187: er_047: movzwl $47,r6 ! 25188: jmp error ! 25189: er_048: movzwl $48,r6 ! 25190: jmp error ! 25191: er_049: movzwl $49,r6 ! 25192: jmp error ! 25193: er_050: movzwl $50,r6 ! 25194: jmp error ! 25195: er_051: movzwl $51,r6 ! 25196: jmp error ! 25197: er_052: movzwl $52,r6 ! 25198: jmp error ! 25199: er_053: movzwl $53,r6 ! 25200: jmp error ! 25201: er_054: movzwl $54,r6 ! 25202: jmp error ! 25203: er_055: movzwl $55,r6 ! 25204: jmp error ! 25205: er_056: movzwl $56,r6 ! 25206: jmp error ! 25207: er_057: movzwl $57,r6 ! 25208: jmp error ! 25209: er_058: movzwl $58,r6 ! 25210: jmp error ! 25211: er_059: movzwl $59,r6 ! 25212: jmp error ! 25213: er_060: movzwl $60,r6 ! 25214: jmp error ! 25215: er_061: movzwl $61,r6 ! 25216: jmp error ! 25217: er_062: movzwl $62,r6 ! 25218: jmp error ! 25219: er_063: movzwl $63,r6 ! 25220: jmp error ! 25221: er_064: movzwl $64,r6 ! 25222: jmp error ! 25223: er_065: movzwl $65,r6 ! 25224: jmp error ! 25225: er_066: movzwl $66,r6 ! 25226: jmp error ! 25227: er_067: movzwl $67,r6 ! 25228: jmp error ! 25229: er_068: movzwl $68,r6 ! 25230: jmp error ! 25231: er_069: movzwl $69,r6 ! 25232: jmp error ! 25233: er_070: movzwl $70,r6 ! 25234: jmp error ! 25235: er_071: movzwl $71,r6 ! 25236: jmp error ! 25237: er_072: movzwl $72,r6 ! 25238: jmp error ! 25239: er_073: movzwl $73,r6 ! 25240: jmp error ! 25241: er_074: movzwl $74,r6 ! 25242: jmp error ! 25243: er_075: movzwl $75,r6 ! 25244: jmp error ! 25245: er_076: movzwl $76,r6 ! 25246: jmp error ! 25247: er_077: movzwl $77,r6 ! 25248: jmp error ! 25249: er_078: movzwl $78,r6 ! 25250: jmp error ! 25251: er_079: movzwl $79,r6 ! 25252: jmp error ! 25253: er_080: movzwl $80,r6 ! 25254: jmp error ! 25255: er_081: movzwl $81,r6 ! 25256: jmp error ! 25257: er_082: movzwl $82,r6 ! 25258: jmp error ! 25259: er_083: movzwl $83,r6 ! 25260: jmp error ! 25261: er_084: movzwl $84,r6 ! 25262: jmp error ! 25263: er_085: movzwl $85,r6 ! 25264: jmp error ! 25265: er_086: movzwl $86,r6 ! 25266: jmp error ! 25267: er_087: movzwl $87,r6 ! 25268: jmp error ! 25269: er_088: movzwl $88,r6 ! 25270: jmp error ! 25271: er_089: movzwl $89,r6 ! 25272: jmp error ! 25273: er_090: movzwl $90,r6 ! 25274: jmp error ! 25275: er_091: movzwl $91,r6 ! 25276: jmp error ! 25277: er_092: movzwl $92,r6 ! 25278: jmp error ! 25279: er_093: movzwl $93,r6 ! 25280: jmp error ! 25281: er_094: movzwl $94,r6 ! 25282: jmp error ! 25283: er_095: movzwl $95,r6 ! 25284: jmp error ! 25285: er_096: movzwl $96,r6 ! 25286: jmp error ! 25287: er_097: movzwl $97,r6 ! 25288: jmp error ! 25289: er_098: movzwl $98,r6 ! 25290: jmp error ! 25291: er_099: movzwl $99,r6 ! 25292: jmp error ! 25293: er_100: movzwl $100,r6 ! 25294: jmp error ! 25295: er_101: movzwl $101,r6 ! 25296: jmp error ! 25297: er_102: movzwl $102,r6 ! 25298: jmp error ! 25299: er_103: movzwl $103,r6 ! 25300: jmp error ! 25301: er_104: movzwl $104,r6 ! 25302: jmp error ! 25303: er_105: movzwl $105,r6 ! 25304: jmp error ! 25305: er_106: movzwl $106,r6 ! 25306: jmp error ! 25307: er_107: movzwl $107,r6 ! 25308: jmp error ! 25309: er_108: movzwl $108,r6 ! 25310: jmp error ! 25311: er_109: movzwl $109,r6 ! 25312: jmp error ! 25313: er_110: movzwl $110,r6 ! 25314: jmp error ! 25315: er_111: movzwl $111,r6 ! 25316: jmp error ! 25317: er_112: movzwl $112,r6 ! 25318: jmp error ! 25319: er_113: movzwl $113,r6 ! 25320: jmp error ! 25321: er_114: movzwl $114,r6 ! 25322: jmp error ! 25323: er_115: movzwl $115,r6 ! 25324: jmp error ! 25325: er_116: movzwl $116,r6 ! 25326: jmp error ! 25327: er_117: movzwl $117,r6 ! 25328: jmp error ! 25329: er_118: movzwl $118,r6 ! 25330: jmp error ! 25331: er_119: movzwl $119,r6 ! 25332: jmp error ! 25333: er_120: movzwl $120,r6 ! 25334: jmp error ! 25335: er_121: movzwl $121,r6 ! 25336: jmp error ! 25337: er_122: movzwl $122,r6 ! 25338: jmp error ! 25339: er_123: movzwl $123,r6 ! 25340: jmp error ! 25341: er_124: movzwl $124,r6 ! 25342: jmp error ! 25343: er_125: movzwl $125,r6 ! 25344: jmp error ! 25345: er_126: movzwl $126,r6 ! 25346: jmp error ! 25347: er_127: movzwl $127,r6 ! 25348: jmp error ! 25349: er_128: movzwl $128,r6 ! 25350: jmp error ! 25351: er_129: movzwl $129,r6 ! 25352: jmp error ! 25353: er_130: movzwl $130,r6 ! 25354: jmp error ! 25355: er_131: movzwl $131,r6 ! 25356: jmp error ! 25357: er_132: movzwl $132,r6 ! 25358: jmp error ! 25359: er_133: movzwl $133,r6 ! 25360: jmp error ! 25361: er_134: movzwl $134,r6 ! 25362: jmp error ! 25363: er_135: movzwl $135,r6 ! 25364: jmp error ! 25365: er_136: movzwl $136,r6 ! 25366: jmp error ! 25367: er_137: movzwl $137,r6 ! 25368: jmp error ! 25369: er_138: movzwl $138,r6 ! 25370: jmp error ! 25371: er_139: movzwl $139,r6 ! 25372: jmp error ! 25373: er_140: movzwl $140,r6 ! 25374: jmp error ! 25375: er_141: movzwl $141,r6 ! 25376: jmp error ! 25377: er_142: movzwl $142,r6 ! 25378: jmp error ! 25379: er_143: movzwl $143,r6 ! 25380: jmp error ! 25381: er_144: movzwl $144,r6 ! 25382: jmp error ! 25383: er_145: movzwl $145,r6 ! 25384: jmp error ! 25385: er_146: movzwl $146,r6 ! 25386: jmp error ! 25387: er_147: movzwl $147,r6 ! 25388: jmp error ! 25389: er_148: movzwl $148,r6 ! 25390: jmp error ! 25391: er_149: movzwl $149,r6 ! 25392: jmp error ! 25393: er_150: movzwl $150,r6 ! 25394: jmp error ! 25395: er_151: movzwl $151,r6 ! 25396: jmp error ! 25397: er_152: movzwl $152,r6 ! 25398: jmp error ! 25399: er_153: movzwl $153,r6 ! 25400: jmp error ! 25401: er_154: movzwl $154,r6 ! 25402: jmp error ! 25403: er_155: movzwl $155,r6 ! 25404: jmp error ! 25405: er_156: movzwl $156,r6 ! 25406: jmp error ! 25407: er_157: movzwl $157,r6 ! 25408: jmp error ! 25409: er_158: movzwl $158,r6 ! 25410: jmp error ! 25411: er_159: movzwl $159,r6 ! 25412: jmp error ! 25413: er_160: movzwl $160,r6 ! 25414: jmp error ! 25415: er_161: movzwl $161,r6 ! 25416: jmp error ! 25417: er_162: movzwl $162,r6 ! 25418: jmp error ! 25419: er_163: movzwl $163,r6 ! 25420: jmp error ! 25421: er_164: movzwl $164,r6 ! 25422: jmp error ! 25423: er_165: movzwl $165,r6 ! 25424: jmp error ! 25425: er_166: movzwl $166,r6 ! 25426: jmp error ! 25427: er_167: movzwl $167,r6 ! 25428: jmp error ! 25429: er_168: movzwl $168,r6 ! 25430: jmp error ! 25431: er_169: movzwl $169,r6 ! 25432: jmp error ! 25433: er_170: movzwl $170,r6 ! 25434: jmp error ! 25435: er_171: movzwl $171,r6 ! 25436: jmp error ! 25437: er_172: movzwl $172,r6 ! 25438: jmp error ! 25439: er_173: movzwl $173,r6 ! 25440: jmp error ! 25441: er_174: movzwl $174,r6 ! 25442: jmp error ! 25443: er_175: movzwl $175,r6 ! 25444: jmp error ! 25445: er_176: movzwl $176,r6 ! 25446: jmp error ! 25447: er_177: movzwl $177,r6 ! 25448: jmp error ! 25449: er_178: movzwl $178,r6 ! 25450: jmp error ! 25451: er_179: movzwl $179,r6 ! 25452: jmp error ! 25453: er_180: movzwl $180,r6 ! 25454: jmp error ! 25455: er_181: movzwl $181,r6 ! 25456: jmp error ! 25457: er_182: movzwl $182,r6 ! 25458: jmp error ! 25459: er_183: movzwl $183,r6 ! 25460: jmp error ! 25461: er_184: movzwl $184,r6 ! 25462: jmp error ! 25463: er_185: movzwl $185,r6 ! 25464: jmp error ! 25465: er_186: movzwl $186,r6 ! 25466: jmp error ! 25467: er_187: movzwl $187,r6 ! 25468: jmp error ! 25469: er_188: movzwl $188,r6 ! 25470: jmp error ! 25471: er_189: movzwl $189,r6 ! 25472: jmp error ! 25473: er_190: movzwl $190,r6 ! 25474: jmp error ! 25475: er_191: movzwl $191,r6 ! 25476: jmp error ! 25477: er_192: movzwl $192,r6 ! 25478: jmp error ! 25479: er_193: movzwl $193,r6 ! 25480: jmp error ! 25481: er_194: movzwl $194,r6 ! 25482: jmp error ! 25483: er_195: movzwl $195,r6 ! 25484: jmp error ! 25485: er_196: movzwl $196,r6 ! 25486: jmp error ! 25487: er_197: movzwl $197,r6 ! 25488: jmp error ! 25489: er_198: movzwl $198,r6 ! 25490: jmp error ! 25491: er_199: movzwl $199,r6 ! 25492: jmp error ! 25493: er_200: movzwl $200,r6 ! 25494: jmp error ! 25495: er_201: movzwl $201,r6 ! 25496: jmp error ! 25497: er_202: movzwl $202,r6 ! 25498: jmp error ! 25499: er_203: movzwl $203,r6 ! 25500: jmp error ! 25501: er_204: movzwl $204,r6 ! 25502: jmp error ! 25503: er_205: movzwl $205,r6 ! 25504: jmp error ! 25505: er_206: movzwl $206,r6 ! 25506: jmp error ! 25507: er_207: movzwl $207,r6 ! 25508: jmp error ! 25509: er_208: movzwl $208,r6 ! 25510: jmp error ! 25511: er_209: movzwl $209,r6 ! 25512: jmp error ! 25513: er_210: movzwl $210,r6 ! 25514: jmp error ! 25515: er_211: movzwl $211,r6 ! 25516: jmp error ! 25517: er_212: movzwl $212,r6 ! 25518: jmp error ! 25519: er_213: movzwl $213,r6 ! 25520: jmp error ! 25521: er_214: movzwl $214,r6 ! 25522: jmp error ! 25523: er_215: movzwl $215,r6 ! 25524: jmp error ! 25525: er_216: movzwl $216,r6 ! 25526: jmp error ! 25527: er_217: movzwl $217,r6 ! 25528: jmp error ! 25529: er_218: movzwl $218,r6 ! 25530: jmp error ! 25531: er_219: movzwl $219,r6 ! 25532: jmp error ! 25533: er_220: movzwl $220,r6 ! 25534: jmp error ! 25535: er_221: movzwl $221,r6 ! 25536: jmp error ! 25537: er_222: movzwl $222,r6 ! 25538: jmp error ! 25539: er_223: movzwl $223,r6 ! 25540: jmp error ! 25541: er_224: movzwl $224,r6 ! 25542: jmp error ! 25543: er_225: movzwl $225,r6 ! 25544: jmp error ! 25545: er_226: movzwl $226,r6 ! 25546: jmp error ! 25547: er_227: movzwl $227,r6 ! 25548: jmp error ! 25549: er_228: movzwl $228,r6 ! 25550: jmp error ! 25551: er_229: movzwl $229,r6 ! 25552: jmp error ! 25553: er_230: movzwl $230,r6 ! 25554: jmp error ! 25555: er_231: movzwl $231,r6 ! 25556: jmp error ! 25557: er_232: movzwl $232,r6 ! 25558: jmp error ! 25559: er_233: movzwl $233,r6 ! 25560: jmp error ! 25561: er_234: movzwl $234,r6 ! 25562: jmp error ! 25563: er_235: movzwl $235,r6 ! 25564: jmp error ! 25565: er_236: movzwl $236,r6 ! 25566: jmp error ! 25567: er_237: movzwl $237,r6 ! 25568: jmp error ! 25569: er_238: movzwl $238,r6 ! 25570: jmp error ! 25571: er_239: movzwl $239,r6 ! 25572: jmp error ! 25573: er_240: movzwl $240,r6 ! 25574: jmp error ! 25575: er_241: movzwl $241,r6 ! 25576: jmp error ! 25577: er_242: movzwl $242,r6 ! 25578: jmp error ! 25579: er_243: movzwl $243,r6 ! 25580: jmp error ! 25581: er_244: movzwl $244,r6 ! 25582: jmp error ! 25583: er_245: movzwl $245,r6 ! 25584: jmp error ! 25585: er_246: movzwl $246,r6 ! 25586: jmp error ! 25587: er_247: movzwl $247,r6 ! 25588: jmp error ! 25589: er_248: movzwl $248,r6 ! 25590: jmp error ! 25591: er_249: movzwl $249,r6 ! 25592: jmp error ! 25593: er_250: movzwl $250,r6 ! 25594: jmp error ! 25595: er_251: movzwl $251,r6 ! 25596: jmp error ! 25597: er_252: movzwl $252,r6 ! 25598: jmp error ! 25599: er_253: movzwl $253,r6 ! 25600: jmp error ! 25601: er_254: movzwl $254,r6 ! 25602: jmp error ! 25603: er_255: movzwl $255,r6 ! 25604: jmp error ! 25605: er_256: movzwl $256,r6 ! 25606: jmp error ! 25607: er_257: movzwl $257,r6 ! 25608: jmp error ! 25609: er_258: movzwl $258,r6 ! 25610: jmp error ! 25611: er_259: movzwl $259,r6 ! 25612: jmp error ! 25613: er_260: movzwl $260,r6 ! 25614: jmp error ! 25615: er_261: movzwl $261,r6 ! 25616: jmp error ! 25617: er_262: movzwl $262,r6 ! 25618: jmp error ! 25619: er_263: movzwl $263,r6 ! 25620: jmp error ! 25621: er_264: movzwl $264,r6 ! 25622: jmp error ! 25623: er_265: movzwl $265,r6 ! 25624: jmp error ! 25625: er_266: movzwl $266,r6 ! 25626: jmp error ! 25627: er_267: movzwl $267,r6 ! 25628: jmp error ! 25629: er_268: movzwl $268,r6 ! 25630: jmp error ! 25631: er_269: movzwl $269,r6 ! 25632: jmp error ! 25633: er_270: movzwl $270,r6 ! 25634: jmp error ! 25635: er_271: movzwl $271,r6 ! 25636: jmp error ! 25637: er_272: movzwl $272,r6 ! 25638: jmp error ! 25639: er_273: movzwl $273,r6 ! 25640: jmp error ! 25641: er_274: movzwl $274,r6 ! 25642: jmp error ! 25643: er_275: movzwl $275,r6 ! 25644: jmp error ! 25645: er_276: movzwl $276,r6 ! 25646: jmp error ! 25647: er_277: movzwl $277,r6 ! 25648: jmp error ! 25649: er_278: movzwl $278,r6 ! 25650: jmp error ! 25651: er_279: movzwl $279,r6 ! 25652: jmp error ! 25653: er_280: movzwl $280,r6 ! 25654: jmp error ! 25655: er_281: movzwl $281,r6 ! 25656: jmp error ! 25657: er_282: movzwl $282,r6 ! 25658: jmp error ! 25659: er_283: movzwl $283,r6 ! 25660: jmp error ! 25661: er_284: movzwl $284,r6 ! 25662: jmp error ! 25663: er_285: movzwl $285,r6 ! 25664: jmp error ! 25665: er_286: movzwl $286,r6 ! 25666: jmp error ! 25667: er_287: movzwl $287,r6 ! 25668: jmp error ! 25669: er_288: movzwl $288,r6 ! 25670: jmp error ! 25671: er_289: movzwl $289,r6 ! 25672: jmp error ! 25673: er_290: movzwl $290,r6 ! 25674: jmp error ! 25675: er_291: movzwl $291,r6 ! 25676: jmp error ! 25677: er_292: movzwl $292,r6 ! 25678: jmp error ! 25679: er_293: movzwl $293,r6 ! 25680: jmp error ! 25681: er_294: movzwl $294,r6 ! 25682: jmp error ! 25683: er_295: movzwl $295,r6 ! 25684: jmp error ! 25685: er_296: movzwl $296,r6 ! 25686: jmp error ! 25687: er_297: movzwl $297,r6 ! 25688: jmp error ! 25689: .globl sec05 ! 25690: sec05: ! 25691: #sec # start of stack overflow section ! 25692: # ! 25693: incl errft # fatal error ! 25694: movl flptr,sp # pop stack to avoid more fails ! 25695: tstl gbcfl # jump if garbage collecting ! 25696: bnequ stak1 ! 25697: jmp er_246 # stack overflow ! 25698: # ! 25699: # NO CHANCE OF RECOVERY IN MID GARBAGE COLLECTION ! 25700: # ! 25701: stak1: movl $endso,r9 # point to message ! 25702: clrl kvdmp # memory is undumpable ! 25703: jmp stopr # give up ! 25704: #title s p i t b o l -- error section ! 25705: # ! 25706: # THIS SECTION OF CODE IS ENTERED WHENEVER A PROCEDURE ! 25707: # RETURN VIA AN ERR PARAMETER OR AN ERB OPCODE IS OBEYED. ! 25708: # ! 25709: # (WA) IS THE ERROR CODE ! 25710: # ! 25711: # THE GLOBAL VARIABLE STAGE INDICATES THE POINT AT WHICH ! 25712: # THE ERROR OCCURED AS FOLLOWS. ! 25713: # ! 25714: # STAGE=STGIC ERROR DURING INITIAL COMPILE ! 25715: # ! 25716: # STAGE=STGXC ERROR DURING COMPILE AT EXECUTE ! 25717: # TIME (CODE, CONVERT FUNCTION CALLS) ! 25718: # ! 25719: # STAGE=STGEV ERROR DURING COMPILATION OF ! 25720: # EXPRESSION AT EXECUTION TIME ! 25721: # (EVAL, CONVERT FUNCTION CALL). ! 25722: # ! 25723: # STAGE=STGXT ERROR AT EXECUTE TIME. COMPILER ! 25724: # NOT ACTIVE. ! 25725: # ! 25726: # STAGE=STGCE ERROR DURING INITIAL COMPILE AFTER ! 25727: # SCANNING OUT THE END LINE. ! 25728: # ! 25729: # STAGE=STGXE ERROR DURING COMPILE AT EXECUTE ! 25730: # TIME AFTER SCANNING END LINE. ! 25731: # ! 25732: # STAGE=STGEE ERROR DURING EXPRESSION EVALUATION ! 25733: # ! 25734: #sec # start of error section ! 25735: # ! 25736: error: cmpl r$cim,$cmlab # jump if error in scanning label ! 25737: bnequ 0f ! 25738: jmp cmple ! 25739: 0: ! 25740: movl r6,kvert # save error code ! 25741: clrl scnrs # reset rescan switch for scane ! 25742: clrl scngo # reset goto switch for scane ! 25743: movl stage,r9 # load current stage ! 25744: casel r9,$0,$stgno # jump to appropriate error circuit ! 25745: 5: ! 25746: .word err01-5b # initial compile ! 25747: .word err04-5b # execute time compile ! 25748: .word err04-5b # eval compiling expr. ! 25749: .word err05-5b # execute time ! 25750: .word err01-5b # compile - after end ! 25751: .word err04-5b # xeq compile-past end ! 25752: .word err04-5b # eval evaluating expr ! 25753: #esw # end switch on error type ! 25754: #page ! 25755: # ! 25756: # ERROR DURING INITIAL COMPILE ! 25757: # ! 25758: # THE ERROR MESSAGE IS PRINTED AS PART OF THE COMPILER ! 25759: # OUTPUT. THIS PRINTOUT INCLUDES THE OFFENDING LINE (IF NOT ! 25760: # PRINTED ALREADY) AND AN ERROR FLAG UNDER THE APPROPRIATE ! 25761: # COLUMN AS INDICATED BY SCNSE UNLESS SCNSE IS SET TO ZERO. ! 25762: # ! 25763: # AFTER PRINTING THE MESSAGE, THE GENERATED CODE IS ! 25764: # MODIFIED TO AN ERROR CALL AND CONTROL IS RETURNED TO ! 25765: # THE CMPIL PROCEDURE AFTER RESETTING THE STACK POINTER. ! 25766: # ! 25767: # IF THE ERROR OCCURS AFTER THE END LINE, CONTROL RETURNS ! 25768: # IN A SLIGHTLY DIFFERENT MANNER TO ENSURE PROPER CLEANUP. ! 25769: # ! 25770: err01: movl cmpxs,sp # reset stack pointer ! 25771: #ssl cmpss # restore s-r stack ptr for cmpil ! 25772: tstl errsp # jump if error suppress flag set ! 25773: beqlu 0f ! 25774: jmp err03 ! 25775: 0: ! 25776: movl erich,erlst # set flag for listr ! 25777: jsb listr # list line ! 25778: jsb prtis # terminate listing ! 25779: clrl erlst # clear listr flag ! 25780: movl scnse,r6 # load scan element offset ! 25781: beqlu err02 # skip if not set ! 25782: movl r6,r7 # loop counter ! 25783: incl r6 # increase for ch$ex ! 25784: jsb alocs # string block for error flag ! 25785: movl r9,r6 # remember string ptr ! 25786: movab cfp$f(r9),r9 # ready for character storing ! 25787: movl r$cim,r10 # point to bad statement ! 25788: movab cfp$f(r10),r10 # ready to get chars ! 25789: # ! 25790: # LOOP TO REPLACE ALL CHARS BUT TABS BY BLANKS ! 25791: # ! 25792: erra1: movzbl (r10)+,r8 # get next char ! 25793: cmpl r8,$ch$ht # skip if tab ! 25794: beqlu erra2 ! 25795: movl $ch$bl,r8 # get a blank ! 25796: #page ! 25797: # ! 25798: # MERGE TO STORE BLANK OR TAB IN ERROR LINE ! 25799: # ! 25800: erra2: movb r8,(r9)+ # store char ! 25801: sobgtr r7,erra1 # loop ! 25802: movl $ch$ex,r10 # exclamation mark ! 25803: movb r10,(r9) # store at end of error line ! 25804: #csc r9 # end of sch loop ! 25805: movl $stnpd,profs # allow for statement number ! 25806: movl r6,r9 # point to error line ! 25807: jsb prtst # print error line ! 25808: # ! 25809: # HERE AFTER PLACING ERROR FLAG AS REQUIRED ! 25810: # ! 25811: err02: jsb ermsg # generate flag and error message ! 25812: addl2 $num03,lstlc # bump page ctr for blank, error, blk ! 25813: clrl r9 # in case of fatal error ! 25814: cmpl errft,$num03 # pack up if several fatals ! 25815: blssu 0f ! 25816: jmp stopr ! 25817: 0: ! 25818: # ! 25819: # COUNT ERROR, INHIBIT EXECUTION IF REQUIRED ! 25820: # ! 25821: incl cmerc # bump error count ! 25822: addl2 cswer,noxeq # inhibit xeq if -noerrors ! 25823: cmpl stage,$stgic # special return if after end line ! 25824: beqlu 0f ! 25825: jmp cmp10 ! 25826: 0: ! 25827: #page ! 25828: # ! 25829: # LOOP TO SCAN TO END OF STATEMENT ! 25830: # ! 25831: err03: movl r$cim,r9 # point to start of image ! 25832: movab cfp$f(r9),r9 # point to first char ! 25833: movzbl (r9),r9 # get first char ! 25834: cmpl r9,$ch$mn # jump if error in control card ! 25835: bnequ 0f ! 25836: jmp cmpce ! 25837: 0: ! 25838: clrl scnrs # clear rescan flag ! 25839: movl sp,errsp # set error suppress flag ! 25840: jsb scane # scan next element ! 25841: cmpl r10,$t$smc # loop back if not statement end ! 25842: beqlu 0f ! 25843: jmp err03 ! 25844: 0: ! 25845: clrl errsp # clear error suppress flag ! 25846: # ! 25847: # GENERATE ERROR CALL IN CODE AND RETURN TO CMPIL ! 25848: # ! 25849: movl $4*cdcod,cwcof # reset offset in ccblk ! 25850: movl $ocer$,r6 # load compile error call ! 25851: jsb cdwrd # generate it ! 25852: movl cwcof,4*cmsoc(sp)# set success fill in offset ! 25853: movl sp,4*cmffc(sp) # set failure fill in flag ! 25854: jsb cdwrd # generate succ. fill in word ! 25855: jmp cmpse # merge to generate error as cdfal ! 25856: # ! 25857: # ERROR DURING EXECUTE TIME COMPILE OR EXPRESSION EVALUATIO ! 25858: # ! 25859: # EXECUTE TIME COMPILATION IS INITIATED THROUGH GTCOD OR ! 25860: # GTEXP WHICH ARE CALLED BY COMPILE, CODE OR EVAL. ! 25861: # BEFORE CAUSING STATEMENT FAILURE THROUGH EXFAL IT IS ! 25862: # HELPFUL TO SET KEYWORD ERRTEXT AND FOR GENERALITY ! 25863: # THESE ERRORS MAY BE HANDLED BY THE SETEXIT MECHANISM. ! 25864: # ! 25865: err04: clrl r$ccb # forget garbage code block ! 25866: #ssl iniss # restore main prog s-r stack ptr ! 25867: jsb ertex # get fail message text ! 25868: subl2 $4,sp # ensure stack ok on loop start ! 25869: # ! 25870: # POP STACK UNTIL FIND FLPTR FOR MOST DEEPLY NESTED PROG. ! 25871: # DEFINED FUNCTION CALL OR CALL OF EVAL / CODE. ! 25872: # ! 25873: erra4: addl2 $4,sp # pop stack ! 25874: cmpl sp,flprt # jump if prog defined fn call found ! 25875: beqlu errc4 ! 25876: cmpl sp,gtcef # loop if not eval or code call yet ! 25877: bnequ erra4 ! 25878: movl $stgxt,stage # re-set stage for execute ! 25879: movl r$gtc,r$cod # recover code ptr ! 25880: movl sp,flptr # restore fail pointer ! 25881: clrl r$cim # forget possible image ! 25882: # ! 25883: # TEST ERRLIMIT ! 25884: # ! 25885: errb4: tstl kverl # jump if errlimit non-zero ! 25886: bnequ err07 ! 25887: jmp exfal # fail ! 25888: # ! 25889: # RETURN FROM PROG. DEFINED FUNCTION IS OUTSTANDING ! 25890: # ! 25891: errc4: movl flptr,sp # restore stack from flptr ! 25892: jmp errb4 # merge ! 25893: #page ! 25894: # ! 25895: # ERROR AT EXECUTE TIME. ! 25896: # ! 25897: # THE ACTION TAKEN ON AN ERROR IS AS FOLLOWS. ! 25898: # ! 25899: # IF ERRLIMIT KEYWORD IS ZERO, AN ABORT IS SIGNALLED, ! 25900: # SEE CODING FOR SYSTEM LABEL ABORT AT L$ABO. ! 25901: # ! 25902: # OTHERWISE, ERRLIMIT IS DECREMENTED AND AN ERRTYPE TRACE ! 25903: # GENERATED IF REQUIRED. CONTROL RETURNS EITHER VIA A JUMP ! 25904: # TO CONTINUE (TO TAKE THE FAILURE EXIT) OR A SPECIFIED ! 25905: # SETEXIT TRAP IS EXECUTED AND CONTROL PASSES TO THE TRAP. ! 25906: # IF 3 OR MORE FATAL ERRORS OCCUR AN ABORT IS SIGNALLED ! 25907: # REGARDLESS OF ERRLIMIT AND SETEXIT - LOOPING IS ALL TOO ! 25908: # PROBABLE OTHERWISE. FATAL ERRORS INCLUDE STACK OVERFLOW ! 25909: # AND EXCEEDING STLIMIT. ! 25910: # ! 25911: err05: #ssl iniss # restore main prog s-r stack ptr ! 25912: tstl dmvch # jump if in mid-dump ! 25913: bnequ err08 ! 25914: # ! 25915: # MERGE HERE FROM ERR08 ! 25916: # ! 25917: err06: tstl kverl # abort if errlimit is zero ! 25918: bnequ 0f ! 25919: jmp labo1 ! 25920: 0: ! 25921: jsb ertex # get fail message text ! 25922: # ! 25923: # MERGE FROM ERR04 ! 25924: # ! 25925: err07: cmpl errft,$num03 # abort if too many fatal errors ! 25926: blssu 0f ! 25927: jmp labo1 ! 25928: 0: ! 25929: decl kverl # decrement errlimit ! 25930: movl r$ert,r10 # load errtype trace pointer ! 25931: jsb ktrex # generate errtype trace if required ! 25932: movl r$cod,r$cnt # set cdblk ptr for continuation ! 25933: movl flptr,r9 # set ptr to failure offset ! 25934: movl (r9),stxof # save failure offset for continue ! 25935: movl r$sxc,r9 # load setexit cdblk pointer ! 25936: bnequ 0f # continue if no setexit trap ! 25937: jmp lcnt1 ! 25938: 0: ! 25939: clrl r$sxc # else reset trap ! 25940: movl $nulls,stxvr # reset setexit arg to null ! 25941: movl (r9),r10 # load ptr to code block routine ! 25942: movl r10,r11 # execute first trap statement ! 25943: jmp (r11) ! 25944: # ! 25945: # INTERRUPTED PARTLY THROUGH A DUMP WHILST STORE IS IN A ! 25946: # MESS SO DO A TIDY UP OPERATION. SEE DUMPR FOR DETAILS. ! 25947: # ! 25948: err08: movl dmvch,r9 # chain head for affected vrblks ! 25949: beqlu err06 # done if zero ! 25950: movl (r9),dmvch # set next link as chain head ! 25951: jsb setvr # restore vrget field ! 25952: jmp err08 # loop through chain ! 25953: #title s p i t b o l -- here endeth the code ! 25954: # ! 25955: # END OF ASSEMBLY ! 25956: # ! 25957: #end # end macro-spitbol assembly
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.