![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to spitv35.min CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / spitbol|
Return to spitv35.min CVS log | Up to [Research Unix] / researchv10no / cmd / spitbol |
1.1 root 1: TTL S P I T B O L - REVISION HISTORY
2: EJC
3: * R E V I S I O N H I S T O R Y
4: * -------------------------------
5: *
6: *
7: * VERSION 3.5B (FEB 81... - SGD PATCHES)
8: * -----------------------------------
9: *
10: * SGD03 - ADDITION OF .CNCI AND SYSCI (INT->STRING
11: * SYSTEM ROUTINE OPTION)
12: * SGD04 - (06-MAY-1981) MODIFIED INILN TO 132
13: * SGD05 - (13-MAY-1981) INSERTED MISSING WTB AFTER SYSMM
14: * CALLS
15: * SGD06 - (25-MAY-1981) MERGED IN PROFILER PATCHES
16: * (NOT MARKED)
17: * SGD07 - (25-MAY-1981) MUCHO PATCHES TO PROFILER (MARKED,
18: * BUT BEST JUST TO EXTRACT ENMASSE)
19: * SGD08 - (25-MAY-1981) USE STRING LENGTH IN HASHS
20: * SGD09 - (25-MAY-1981) FIXED SERIOUS PARSER PROBLEM
21: * RELATING TO (X Y) ON LINE BEING VIEWED AS PATTERN
22: * MATCH. FIXED BY ADDITION OF NEW CMTYP VALUE
23: * C$CNP (CONCATENATION - NOT PATTERN MATCH)
24: * SGD10 - (01-AUG-1981) FIXED EXIT(N) RESPECIFICATION CODE
25: * TO PROPERLY OBSERVE HEADER SEMANTICS ON RETURN.
26: * SGD11 - (07-AUG-1981) BYPASS PRTPG CALL AT INITIALIZATION
27: * FOLLOWING COMPILATION IF NO OUTPUT GENERATED.
28: * THIS PREVENTS OUTPUT FILES CONSISTING OF THE
29: * HEADERS AND A FEW BLANK LINES WHEN THERE IS NO
30: * SOURCE LISTING AND NO COMPILATION STATS.
31: * ALSO FIX TIMSX INITIALIZATION IN SAME CODE.
32: * SGD12 - (17-AUG-1981) B$EFC CODE DID NOT CHECK FOR
33: * UNCONVERTED RESULT RETURNING NULL STRING. FIXED.
34: * SGDBF - ( NOV-1981) ADDED BUFFER TYPE AND SYMBOL CNBF
35: * SGD13 - (03-MAR-1982) LOAD PFVBL FIELD IN RETRN FOR
36: * RETURN TRACING. THIS WAS CAUSING BUG ON RETURN
37: * TRACES THAT TRIED TO ACCESS THE VARIABLE NAME
38: * SGD14 - ADDED CHAR FUNCTION. CHAR(N) RETURNS NTH
39: * CHARACTER OF HOST MACHINE CHARACTER SET.
40: * NOT CONDITIONALIZED OR MARKED.
41: * SGD15 - FIXED PROBLEM RELATING TO COMPILATION OF GOTO
42: * FIELDS CONTAINING SMALL INTEGERS (IN CONST SEC).
43: *
44: * REG01 - (XX-AUG-82)
45: * ADDED CFP$U TO EASE TRANSLATION ON SMALLER
46: * SYSTEMS - CONDITIONAL .CUCF
47: * ADDED LOWER CASE SUPPORT - CONDITIONAL .CULC
48: * ADDED SET I/O FUNCTION - CONDITIONAL .CUST
49: *
50: * REG02 - (XX-SEP-82)
51: * CHANGED INILN AND AND INILS TO 258
52: *
53: * REG03 - (XX-OCT-82)
54: * CONDITIONALIZED THE PAGE EJECT AFTER CALL TO SYSBX
55: * AND ADDED ANOTHER BEFORE CALL TO SYSBX, SO THAT,
56: * IF DESIRED BY THE IMPLEMENTOR, STANDARD OUTPUT
57: * WILL REFLECT ASSIGNMENTS MADE BY EXECUTING PROGRAM
58: * ONLY. CONDITIONAL .CUEJ CONTROLS - IF DEFINED
59: * EJECT IS BEFORE CALL TO SYSBX.
60: *
61: * REG04 - (XX-NOV-82)
62: * FIXED DIFFICULTIES WITH LISTINGS DURING EXECUTION
63: * WHEN NO LISTING GENERATED DURING COMPILATION.
64: *
65: * -LIST TO CODE() CAUSED BOMB. FIX IS TO RESET
66: * R$TTL AND R$STL TO NULLS NOT 0 AFTER COMPILATION.
67: * (LISTR AND LISTT EXPECT NULLS)
68: *
69: * WHEN LISTING AND STATISTICS ROUTED TO DIFFERENT
70: * FILE THAN EXECUTION OUTPUT, ERROR MESSAGE IS SENT
71: * TO EXECUTION OUTPUT (AND GETS SEPARATED FROM
72: * ... IN STATEMENT ... MSG). LABO1 CALLS SYSAX AND
73: * STOPR DOES NOT CALL SYSAX IF ENTERED FROM LABO1.
74: *
75: * REG05 - (XX-NOV-82)
76: * PREVENT CLEAR() FROM CLOBBERING PROTECTED VARIABLES
77: * AT LABEL SCLR5.
78: *
79: * REG06 - (XX-NOV-82)
80: * FIXED GTEXP FROM ACCEPTING TRAILING SEMICOLON OR
81: * COLON. NOT LEGAL WAY TO END AN EXPRESSION.
82: *
83: * VERSION 3.5A (OCT 79 - SGD PATCHES)
84: * -----------------------------------
85: *
86: * SGD01 - PATCH IN ASIGN TO FIX MULTIPLE TRAP BLOCK PROBLEM
87: * (ASG10+2)
88: * SGD02 - PATCH IN GTARR TO FIX NULL CONVERT (GTAR9+0)
89: *
90: TTL S P I T B O L -- BASIC INFORMATION
91: EJC
92: *
93: * GENERAL STRUCTURE
94: * -----------------
95: *
96: * THIS PROGRAM IS A TRANSLATOR FOR A VERSION OF THE SNOBOL4
97: * PROGRAMMING LANGUAGE. LANGUAGE DETAILS ARE CONTAINED IN
98: * THE MANUAL MACRO SPITBOL BY DEWAR AND MCCANN, TECHNICAL
99: * REPORT 90, UNIVERSITY OF LEEDS 1976. THE LANGUAGE
100: * IS IDENTICAL TO THAT IMPLEMENTED BY THE BTL TRANSLATOR
101: * (R. E. GRISWOLD ET AL.) WITH THE FOLLOWING EXCEPTIONS.
102: *
103: * 1) REDEFINITION OF STANDARD SYSTEM FUNCTIONS AND
104: * OPERATORS IS NOT PERMITTED.
105: *
106: * 2) THE VALUE FUNCTION IS NOT PROVIDED.
107: *
108: * 3) ACCESS TRACING IS PROVIDED IN ADDITION TO THE
109: * OTHER STANDARD TRACE MODES.
110: *
111: * 4) THE KEYWORD STFCOUNT IS NOT PROVIDED.
112: *
113: * 5) THE KEYWORD FULLSCAN IS NOT PROVIDED AND ALL PATTERN
114: * MATCHING TAKES PLACE IN FULLSCAN MODE (I.E. WITH NO
115: * HEURISTICS APPLIED).
116: *
117: * 6) A SERIES OF EXPRESSIONS SEPARATED BY COMMAS MAY
118: * BE GROUPED WITHIN PARENTHESES TO PROVIDE A SELECTION
119: * CAPABILITY. THE SEMANTICS ARE THAT THE SELECTION
120: * ASSUMES THE VALUE OF THE FIRST EXPRESSION WITHIN IT
121: * WHICH SUCCEEDS AS THEY ARE EVALUATED FROM THE LEFT.
122: * IF NO EXPRESSION SUCCEEDS THE ENTIRE STATEMENT FAILS
123: *
124: * 7) AN EXPLICIT PATTERN MATCHING OPERATOR IS PROVIDED.
125: * THIS IS THE BINARY QUERY (SEE GIMPEL SIGPLAN OCT 74)
126: *
127: * 8) THE ASSIGNMENT OPERATOR IS INTRODUCED AS IN THE
128: * GIMPEL REFERENCE.
129: *
130: * 9) THE EXIT FUNCTION IS PROVIDED FOR GENERATING LOAD
131: * MODULES - CF. GIMPELS SITBOL.
132: *
133: *
134: * THE METHOD USED IN THIS PROGRAM IS TO TRANSLATE THE
135: * SOURCE CODE INTO AN INTERNAL PSEUDO-CODE (SEE FOLLOWING
136: * SECTION). AN INTERPRETOR IS THEN USED TO EXECUTE THIS
137: * GENERATED PSEUDO-CODE. THE NATURE OF THE SNOBOL4 LANGUAGE
138: * IS SUCH THAT THE LATTER TASK IS MUCH MORE COMPLEX THAN
139: * THE ACTUAL TRANSLATION PHASE. ACCORDINGLY, NEARLY ALL THE
140: * CODE IN THE PROGRAM SECTION IS CONCERNED WITH THE ACTUAL
141: * EXECUTION OF THE SNOBOL4 PROGRAM.
142: EJC
143: *
144: * INTERPRETIVE CODE FORMAT
145: * ------------------------
146: *
147: * THE INTERPRETIVE PSEUDO-CODE CONSISTS OF A SERIES OF
148: * ADDRESS POINTERS. THE EXACT FORMAT OF THE CODE IS
149: * DESCRIBED IN CONNECTION WITH THE CDBLK FORMAT. THE
150: * PURPOSE OF THIS SECTION IS TO GIVE GENERAL INSIGHT INTO
151: * THE INTERPRETIVE APPROACH INVOLVED.
152: *
153: * THE BASIC FORM OF THE CODE IS RELATED TO REVERSE POLISH.
154: * IN OTHER WORDS, THE OPERANDS PRECEDE THE OPERATORS WHICH
155: * ARE ZERO ADDRESS OPERATORS. THERE ARE SOME EXCEPTIONS TO
156: * THESE RULES, NOTABLY THE UNARY NOT OPERATOR AND THE
157: * SELECTION CONSTRUCTION WHICH CLEARLY REQUIRE ADVANCE
158: * KNOWLEDGE OF THE OPERATOR INVOLVED.
159: *
160: * THE OPERANDS ARE MOVED TO THE TOP OF THE MAIN STACK AND
161: * THE OPERATORS ARE APPLIED TO THE TOP STACK ENTRIES. LIKE
162: * OTHER VERSIONS OF SPITBOL, THIS PROCESSOR DEPENDS ON
163: * KNOWING WHETHER OPERANDS ARE REQUIRED BY NAME OR BY VALUE
164: * AND MOVES THE APPROPRIATE OBJECT TO THE STACK. THUS NO
165: * NAME/VALUE CHECKS ARE INCLUDED IN THE OPERATOR CIRCUITS.
166: *
167: * THE ACTUAL POINTERS IN THE CODE POINT TO A BLOCK WHOSE
168: * FIRST WORD IS THE ADDRESS OF THE INTERPRETOR ROUTINE
169: * TO BE EXECUTED FOR THE CODE WORD.
170: *
171: * IN THE CASE OF OPERATORS, THE POINTER IS TO A WORD WHICH
172: * CONTAINS THE ADDRESS OF THE OPERATOR TO BE EXECUTED. IN
173: * THE CASE OF OPERANDS SUCH AS CONSTANTS, THE POINTER IS TO
174: * THE OPERAND ITSELF. ACCORDINGLY, ALL OPERANDS CONTAIN
175: * A FIELD WHICH POINTS TO THE ROUTINE TO LOAD THE VALUE OF
176: * THE OPERAND ONTO THE STACK. IN THE CASE OF A VARIABLE,
177: * THERE ARE THREE SUCH POINTERS. ONE TO LOAD THE VALUE,
178: * ONE TO STORE THE VALUE AND A THIRD TO JUMP TO THE LABEL.
179: *
180: * THE HANDLING OF FAILURE RETURNS DESERVES SPECIAL COMMENT.
181: * THE LOCATION FLPTR CONTAINS THE POINTER TO THE LOCATION
182: * ON THE MAIN STACK WHICH CONTAINS THE FAILURE RETURN
183: * WHICH IS IN THE FORM OF A BYTE OFFSET IN THE CURRENT
184: * CODE BLOCK (CDBLK OR EXBLK). WHEN A FAILURE OCCURS, THE
185: * STACK IS POPPED AS INDICATED BY THE SETTING OF FLPTR AND
186: * CONTROL IS PASSED TO THE APPROPRIATE LOCATION IN THE
187: * CURRENT CODE BLOCK WITH THE STACK POINTER POINTING TO THE
188: * FAILURE OFFSET ON THE STACK AND FLPTR UNCHANGED.
189: EJC
190: *
191: * INTERNAL DATA REPRESENTATIONS
192: * -----------------------------
193: *
194: * REPRESENTATION OF VALUES
195: *
196: * A VALUE IS REPRESENTED BY A POINTER TO A BLOCK WHICH
197: * DESCRIBES THE TYPE AND PARTICULARS OF THE DATA VALUE.
198: * IN GENERAL, A VARIABLE IS A LOCATION CONTAINING SUCH A
199: * POINTER (ALTHOUGH IN THE CASE OF TRACE ASSOCIATIONS THIS
200: * IS MODIFIED, SEE DESCRIPTION OF TRBLK).
201: *
202: * THE FOLLOWING IS A LIST OF POSSIBLE DATATYPES SHOWING THE
203: * TYPE OF BLOCK USED TO HOLD THE VALUE. THE DETAILS OF
204: * EACH BLOCK FORMAT ARE GIVEN LATER.
205: *
206: * DATATYPE BLOCK TYPE
207: * -------- ----------
208: *
209: *
210: * ARRAY ARBLK OR VCBLK
211: *
212: * CODE CDBLK
213: *
214: * EXPRESSION EXBLK OR SEBLK
215: *
216: * INTEGER ICBLK
217: *
218: * NAME NMBLK
219: *
220: * PATTERN P0BLK OR P1BLK OR P2BLK
221: *
222: * REAL RCBLK
223: *
224: * STRING SCBLK
225: *
226: * TABLE TBBLK
227: *
228: * PROGRAM DATATYPE PDBLK
229: EJC
230: *
231: * REPRESENTATION OF VARIABLES
232: * ---------------------------
233: *
234: * DURING THE COURSE OF EVALUATING EXPRESSIONS, IT IS
235: * NECESSARY TO GENERATE NAMES OF VARIABLES (FOR EXAMPLE
236: * ON THE LEFT SIDE OF A BINARY EQUALS OPERATOR). THESE ARE
237: * NOT TO BE CONFUSED WITH OBJECTS OF DATATYPE NAME WHICH
238: * ARE IN FACT VALUES.
239: *
240: * FROM A LOGICAL POINT OF VIEW, SUCH NAMES COULD BE SIMPLY
241: * REPRESENTED BY A POINTER TO THE APPROPRIATE VALUE CELL.
242: * HOWEVER IN THE CASE OF ARRAYS AND PROGRAM DEFINED
243: * DATATYPES, THIS WOULD VIOLATE THE RULE THAT THERE MUST BE
244: * NO POINTERS INTO THE MIDDLE OF A BLOCK IN DYNAMIC STORE.
245: * ACCORDINGLY, A NAME IS ALWAYS REPRESENTED BY A BASE AND
246: * OFFSET. THE BASE POINTS TO THE START OF THE BLOCK
247: * CONTAINING THE VARIABLE VALUE AND THE OFFSET IS THE
248: * OFFSET WITHIN THIS BLOCK IN BYTES. THUS THE ADDRESS
249: * OF THE ACTUAL VARIABLE IS DETERMINED BY ADDING THE BASE
250: * AND OFFSET VALUES.
251: *
252: * THE FOLLOWING ARE THE INSTANCES OF VARIABLES REPRESENTED
253: * IN THIS MANNER.
254: *
255: * 1) NATURAL VARIABLE BASE IS PTR TO VRBLK
256: * OFFSET IS *VRVAL
257: *
258: * 2) TABLE ELEMENT BASE IS PTR TO TEBLK
259: * OFFSET IS *TEVAL
260: *
261: * 3) ARRAY ELEMENT BASE IS PTR TO ARBLK
262: * OFFSET IS OFFSET TO ELEMENT
263: *
264: * 4) VECTOR ELEMENT BASE IS PTR TO VCBLK
265: * OFFSET IS OFFSET TO ELEMENT
266: *
267: * 5) PROG DEF DTP BASE IS PTR TO PDBLK
268: * OFFSET IS OFFSET TO FIELD VALUE
269: *
270: * IN ADDITION THERE ARE TWO CASES OF OBJECTS WHICH ARE
271: * LIKE VARIABLES BUT CANNOT BE HANDLED IN THIS MANNER.
272: * THESE ARE CALLED PSEUDO-VARIABLES AND ARE REPRESENTED
273: * WITH A SPECIAL BASE POINTER AS FOLLOWS=
274: *
275: * EXPRESSION VARIABLE PTR TO EVBLK (SEE EVBLK)
276: *
277: * KEYWORD VARIABLE PTR TO KVBLK (SEE KVBLK)
278: *
279: * PSEUDO-VARIABLES ARE HANDLED AS SPECIAL CASES BY THE
280: * ACCESS PROCEDURE (ACESS) AND THE ASSIGNMENT PROCEDURE
281: * (ASIGN). SEE THESE TWO PROCEDURES FOR DETAILS.
282: EJC
283: *
284: * ORGANIZATION OF DATA AREA
285: * -------------------------
286: *
287: *
288: * THE DATA AREA IS DIVIDED INTO TWO REGIONS.
289: *
290: * STATIC AREA
291: *
292: * THE STATIC AREA BUILDS UP FROM THE BOTTOM AND CONTAINS
293: * DATA AREAS WHICH ARE ALLOCATED DYNAMICALLY BUT ARE NEVER
294: * DELETED OR MOVED AROUND. THE MACRO-PROGRAM ITSELF
295: * USES THE STATIC AREA FOR THE FOLLOWING.
296: *
297: * 1) ALL VARIABLE BLOCKS (VRBLK).
298: *
299: * 2) THE HASH TABLE FOR VARIABLE BLOCKS.
300: *
301: * 3) MISCELLANEOUS BUFFERS AND WORK AREAS (SEE PROGRAM
302: * INITIALIZATION SECTION).
303: *
304: * IN ADDITION, THE SYSTEM PROCEDURES MAY USE THIS AREA FOR
305: * INPUT/OUTPUT BUFFERS, EXTERNAL FUNCTIONS ETC. SPACE IN
306: * THE STATIC REGION IS ALLOCATED BY CALLING PROCEDURE ALOST
307: *
308: * THE FOLLOWING GLOBAL VARIABLES DEFINE THE CURRENT
309: * LOCATION AND SIZE OF THE STATIC AREA.
310: *
311: * STATB ADDRESS OF START OF STATIC AREA
312: * STATE ADDRESS+1 OF LAST WORD IN AREA.
313: *
314: * THE MINIMUM SIZE OF STATIC IS GIVEN APPROXIMATELY BY
315: * 12 + *E$HNB + *E$STS + SPACE FOR ALPHABET STRING
316: * AND STANDARD PRINT BUFFER.
317: EJC
318: *
319: * DYNAMIC AREA
320: *
321: * THE DYNAMIC AREA IS BUILT UPWARDS IN MEMORY AFTER THE
322: * STATIC REGION. DATA IN THIS AREA MUST ALL BE IN STANDARD
323: * BLOCK FORMATS SO THAT IT CAN BE PROCESSED BY THE GARBAGE
324: * COLLECTOR (PROCEDURE GBCOL). GBCOL COMPACTS BLOCKS DOWN
325: * IN THIS REGION AS REQUIRED BY SPACE EXHAUSTION AND CAN
326: * ALSO MOVE ALL BLOCKS UP TO ALLOW FOR EXPANSION OF THE
327: * STATIC REGION.
328: * WITH THE EXCEPTION OF TABLES AND ARRAYS, NO SPITBOL
329: * OBJECT ONCE BUILT IN DYNAMIC MEMORY IS EVER SUBSEQUENTLY
330: * MODIFIED. OBSERVING THIS RULE NECESSITATES A COPYING
331: * ACTION DURING STRING AND PATTERN CONCATENATION.
332: *
333: * GARBAGE COLLECTION IS FUNDAMENTAL TO THE ALLOCATION OF
334: * SPACE FOR VALUES. SPITBOL USES A VERY EFFICIENT GARBAGE
335: * COLLECTOR WHICH INSISTS THAT POINTERS INTO DYNAMIC STORE
336: * SHOULD BE IDENTIFIABLE WITHOUT USE OF BIT TABLES,
337: * MARKER BITS ETC. TO SATISFY THIS REQUIREMENT, DYNAMIC
338: * MEMORY MUST NOT START AT TOO LOW AN ADDRESS AND LENGTHS
339: * OF ARRAYS, TABLES, STRINGS, CODE AND EXPRESSION BLOCKS
340: * MAY NOT EXCEED THE NUMERICAL VALUE OF THE LOWEST DYNAMIC
341: * ADDRESS. TO AVOID EITHER PENALIZING USERS WITH MODEST
342: * REQUIREMENTS OR RESTRICTING THOSE WITH GREATER NEEDS ON
343: * HOST SYSTEMS WHERE DYNAMIC MEMORY IS ALLOCATED IN LOW
344: * ADDRESSES, THE MINIMUM DYNAMIC ADDRESS MAY BE SPECIFIED
345: * SUFFICIENTLY HIGH TO PERMIT ARBITRARILY LARGE SPITBOL
346: * OBJECTS TO BE CREATED ( WITH THE POSSIBILITY IN EXTREME
347: * CASES OF WASTING LARGE AMOUNTS OF MEMORY BELOW THE
348: * START ADDRESS). THIS MINIMUM VALUE IS MADE AVAILABLE
349: * IN VARIABLE MXLEN BY A SYSTEM ROUTINE, SYSMX.
350: * ALTERNATIVELY SYSMX MAY INDICATE THAT A
351: * DEFAULT MAY BE USED IN WHICH DYNAMIC IS PLACED
352: * AT THE LOWEST POSSIBLE ADDRESS FOLLOWING STATIC.
353: *
354: * THE FOLLOWING GLOBAL WORK CELLS DEFINE THE LOCATION AND
355: * LENGTH OF THE DYNAMIC AREA.
356: *
357: * DNAMB START OF DYNAMIC AREA
358: * DNAMP NEXT AVAILABLE LOCATION
359: * DNAME LAST AVAILABLE LOCATION + 1
360: *
361: * DNAMB IS ALWAYS HIGHER THAN STATE SINCE THE ALOST
362: * PROCEDURE MAINTAINS SOME EXPANSION SPACE ABOVE STATE.
363: * *** DNAMB MUST NEVER BE PERMITTED TO HAVE A VALUE LESS
364: * THAN THAT IN MXLEN ***
365: *
366: * SPACE IN THE DYNAMIC REGION IS ALLOCATED BY THE ALLOC
367: * PROCEDURE. THE DYNAMIC REGION MAY BE USED BY SYSTEM
368: * PROCEDURES PROVIDED THAT ALL THE RULES ARE OBEYED.
369: EJC
370: *
371: * REGISTER USAGE
372: * --------------
373: *
374: * (CP) CODE POINTER REGISTER. USED TO
375: * HOLD A POINTER TO THE CURRENT
376: * LOCATION IN THE INTERPRETIVE PSEUDO
377: * CODE (I.E. PTR INTO A CDBLK).
378: *
379: * (XL,XR) GENERAL INDEX REGISTERS. USUALLY
380: * USED TO HOLD POINTERS TO BLOCKS IN
381: * DYNAMIC STORAGE. AN IMPORTANT
382: * RESTRICTION IS THAT THE VALUE IN
383: * XL MUST BE COLLECTABLE FOR
384: * A GARBAGE COLLECT CALL. A VALUE
385: * IS COLLECTABLE IF IT EITHER POINTS
386: * OUTSIDE THE DYNAMIC AREA, OR IF IT
387: * POINTS TO THE START OF A BLOCK IN
388: * THE DYNAMIC AREA.
389: *
390: * (XS) STACK POINTER. USED TO POINT TO
391: * THE STACK FRONT. THE STACK MAY
392: * BUILD UP OR DOWN AND IS USED
393: * TO STACK SUBROUTINE RETURN POINTS
394: * AND OTHER RECURSIVELY SAVED DATA.
395: *
396: * (XT) AN ALTERNATIVE NAME FOR XL DURING
397: * ITS USE IN ACCESSING STACKED ITEMS.
398: *
399: * (WA,WB,WC) GENERAL WORK REGISTERS. CANNOT BE
400: * USED FOR INDEXING, BUT MAY HOLD
401: * VARIOUS TYPES OF DATA.
402: *
403: * (IA) USED FOR ALL SIGNED INTEGER
404: * ARITHMETIC, BOTH THAT USED BY THE
405: * TRANSLATOR AND THAT ARISING FROM
406: * USE OF SNOBOL4 ARITHMETIC OPERATORS
407: *
408: * (RA) REAL ACCUMULATOR. USED FOR ALL
409: * FLOATING POINT ARITHMETIC.
410: EJC
411: *
412: * SPITBOL CONDITIONAL ASSEMBLY SYMBOLS
413: * ------------------------------------
414: *
415: * IN THE SPITBOL TRANSLATOR, THE FOLLOWING CONDITIONAL
416: * ASSEMBLY SYMBOLS ARE REFERRED TO. TO INCORPORATE THE
417: * FEATURES REFERRED TO, THE MINIMAL SOURCE SHOULD BE
418: * PREFACED BY SUITABLE CONDITIONAL ASSEMBLY SYMBOL
419: * DEFINITIONS.
420: * IN ALL CASES IT IS PERMISSIBLE TO DEFAULT THE DEFINITIONS
421: * IN WHICH CASE THE ADDITIONAL FEATURES WILL BE OMITTED
422: * FROM THE TARGET CODE.
423: *
424: * .CASL DEFINE TO INCLUDE 26 SHIFTED LETTRS
425: * .CAHT DEFINE TO INCLUDE HORIZONTAL TAB
426: * .CAVT DEFINE TO INCLUDE VERTICAL TAB
427: * .CIOD IF DEFINED, DEFAULT DELIMITER IS
428: * NOT USED IN PROCESSING 3RD ARG OF
429: * INPUT() AND OUTPUT()
430: * .CNBT DEFINE TO OMIT BATCH INITIALISATION
431: * .CNCI DEFINE TO ENABLE SYSCI ROUTINE
432: * .CNEX DEFINE TO OMIT EXIT() CODE.
433: * .CNLD DEFINE TO OMIT LOAD() CODE.
434: * .CNPF DEFINE TO OMIT PROFILE STUFF
435: * .CNRA DEFINE TO OMIT ALL REAL ARITHMETIC
436: * .CNSR DEFINE TO OMIT SORT, RSORT
437: * .CSAX DEFINE IF SYSAX IS TO BE CALLED
438: * .CSN6 DEFINE TO PAD STMT NOS TO 6 CHARS
439: * .CSN8 DEFINE TO PAD STMT NOS TO 8 CHARS
440: * .CUCF DEFINE TO INCLUDE CFP$U
441: * .CULC DEFINE TO INCLUDE &CASE (LC NAMES)
442: * .CUST DEFINE TO INCLUDE SET() CODE
443: .DEF .CASL
444: .DEF .CAHT
445: .DEF .CIOD
446: .DEF .CSAX
447: .DEF .CSN8
448: .DEF .CUCF
449: .DEF .CUEJ
450: .DEF .CULC
451: .DEF .CUST
452: TTL S P I T B O L -- PROCEDURES SECTION
453: *
454: * THIS SECTION STARTS WITH DESCRIPTIONS OF THE OPERATING
455: * SYSTEM DEPENDENT PROCEDURES WHICH ARE USED BY THE SPITBOL
456: * TRANSLATOR. ALL SUCH PROCEDURES HAVE FIVE LETTER NAMES
457: * BEGINNING WITH SYS. THEY ARE LISTED IN ALPHABETICAL
458: * ORDER.
459: * ALL PROCEDURES HAVE A SPECIFICATION CONSISTING OF A
460: * MODEL CALL, PRECEDED BY A POSSIBLY EMPTY LIST OF REGISTER
461: * CONTENTS GIVING PARAMETERS AVAILABLE TO THE PROCEDURE AND
462: * FOLLOWED BY A POSSIBLY EMPTY LIST OF REGISTER CONTENTS
463: * REQUIRED ON RETURN FROM THE CALL OR WHICH MAY HAVE HAD
464: * THEIR CONTENTS DESTROYED. ONLY THOSE REGISTERS EXPLICITLY
465: * MENTIONED IN THE LIST AFTER THE CALL MAY HAVE THEIR
466: * VALUES CHANGED.
467: * THE SEGMENT OF CODE PROVIDING THE EXTERNAL PROCEDURES IS
468: * CONVENIENTLY REFERRED TO AS OSINT (OPERATING SYSTEM
469: * INTERFACE). THE SYSXX PROCEDURES IT CONTAINS PROVIDE
470: * FACILITIES NOT USUALLY AVAILABLE AS PRIMITIVES IN
471: * ASSEMBLY LANGUAGES. FOR PARTICULAR TARGET MACHINES,
472: * IMPLEMENTORS MAY CHOOSE FOR SOME MINIMAL OPCODES WHICH
473: * DO NOT HAVE REASONABLY DIRECT TRANSLATIONS, TO USE CALLS
474: * OF ADDITIONAL PROCEDURES WHICH THEY PROVIDE IN OSINT.
475: * E.G. MWB OR TRC MIGHT BE TRANSLATED AS JSR SYSMB,
476: * JSR SYSTC IN SOME IMPLEMENTATIONS.
477: *
478: * IN THE DESCRIPTIONS, REFERENCE IS MADE TO --BLK
479: * FORMATS (-- = A PAIR OF LETTERS). SEE THE SPITBOL
480: * DEFINITIONS SECTION FOR DETAILED DESCRIPTIONS OF ALL
481: * SUCH BLOCK FORMATS EXCEPT FCBLK FOR WHICH SYSFC SHOULD
482: * BE CONSULTED.
483: *
484: * SECTION 0 CONTAINS INP,INR SPECIFICATIONS OF INTERNAL
485: * PROCEDURES,ROUTINES. THIS GIVES A SINGLE PASS TRANSLATOR
486: * INFORMATION MAKING IT EASY TO GENERATE ALTERNATIVE CALLS
487: * IN THE TRANSLATION OF JSR-S FOR PROCEDURES OF DIFFERENT
488: * TYPES IF THIS PROVES NECESSARY.
489: *
490: SEC START OF PROCEDURES SECTION
491: .IF .CSAX
492: EJC
493: *
494: * SYSAX -- AFTER EXECUTION
495: *
496: SYSAX EXP DEFINE EXTERNAL ENTRY POINT
497: *
498: * IF THE CONDITIONAL ASSEMBLY SYMBOL .CSAX IS DEFINED,
499: * THIS ROUTINE IS CALLED IMMEDIATELY AFTER EXECUTION AND
500: * BEFORE PRINTING OF EXECUTION STATISTICS OR DUMP OUTPUT.
501: * PURPOSE OF CALL IS FOR IMPLEMENTOR TO DETERMINE AND
502: * IF THE CALL IS NOT REQUIRED IT WILL BE OMITTED IF .CSAX
503: * IS UNDEFINED. IN THIS CASE SYSAX NEED NOT BE CODED.
504: *
505: * JSR SYSAX CALL AFTER EXECUTION
506: .ELSE
507: .FI
508: EJC
509: *
510: * SYSBX -- BEFORE EXECUTION
511: *
512: SYSBX EXP DEFINE EXTERNAL ENTRY POINT
513: *
514: * CALLED AFTER INITIAL SPITBOL COMPILATION AND BEFORE
515: * COMMENCING EXECUTION IN CASE OSINT NEEDS
516: * TO ASSIGN FILES OR PERFORM OTHER NECESSARY SERVICES.
517: * OSINT MAY ALSO CHOOSE TO SEND A MESSAGE TO ONLINE
518: * TERMINAL (IF ANY) INDICATING THAT EXECUTION IS STARTING.
519: *
520: * JSR SYSBX CALL BEFORE EXECUTION STARTS
521: EJC
522: .IF .CNCI
523: *
524: * SYSCI -- CONVERT INTEGER
525: *
526: SYSCI EXP
527: *
528: * SYSCI IS AN OPTIONAL OSINT ROUTINE THAT CAUSES SPITBOL TO
529: * CALL SYSCI TO CONVERT INTEGER VALUES TO STRINGS, RATHER
530: * THAN USING SPITBOL'S OWN INTERNAL CONVERSION CODE. THIS
531: * CODE MAY BE LESS EFFICIENT ON MACHINES WITH HARDWARE
532: * CONVERSION INSTRUCTIONS AND IN SUCH CASES, IT MAY BE AN
533: * ADVANTAGE TO INCLUDE SYSCI. THE SYMBOL .CNCI MUST BE
534: * DEFINED IF THIS ROUTINE IS TO BE USED.
535: *
536: * THE RULES FOR CONVERTING INTEGERS TO STRINGS ARE THAT
537: * POSITIVE VALUES ARE REPRESENTED WITHOUT ANY SIGN, AND
538: * THERE ARE NEVER ANY LEADING BLANKS OR ZEROS, EXCEPT IN
539: * THE CASE OF ZERO ITSELF WHICH IS REPRESENTED AS A SINGLE
540: * ZERO DIGIT. NEGATIVE NUMBERS ARE REPRESENTED WITH A
541: * PRECEEDING MINUS SIGN. THERE ARE NEVER ANY TRAILING
542: * BLANKS, AND CONVERSION CANNOT FAIL.
543: *
544: * (IA) VALUE TO BE CONVERTED
545: * JSR SYSCI CALL TO CONVERT INTEGER VALUE
546: * (XL) POINTER TO PSEUDO-SCBLK WITH STRING
547: EJC
548: .FI
549: *
550: * SYSDC -- DATE CHECK
551: *
552: SYSDC EXP DEFINE EXTERNAL ENTRY POINT
553: *
554: * SYSDC IS CALLED TO CHECK THAT THE EXPIRY DATE FOR A TRIAL
555: * VERSION OF SPITBOL IS UNEXPIRED.
556: *
557: * JSR SYSDC CALL TO CHECK DATE
558: * RETURN ONLY IF DATE IS OK
559: EJC
560: *
561: * SYSDM -- DUMP CORE
562: *
563: SYSDM EXP DEFINE EXTERNAL ENTRY POINT
564: *
565: * SYSDM IS CALLED BY A SPITBOL PROGRAM CALL OF DUMP(N) WITH
566: * N GE 3. ITS PURPOSE IS TO PROVIDE A CORE DUMP.
567: * N COULD HOLD AN ENCODING OF THE START ADRS FOR DUMP AND
568: * AMOUNT TO BE DUMPED E.G. N = 256*A + S , S = START ADRS
569: * IN KILOWORDS, A = KILOWORDS TO DUMP
570: *
571: * (XR) PARAMETER N OF CALL DUMP(N)
572: * JSR SYSDM CALL TO ENTER ROUTINE
573: EJC
574: *
575: * SYSDT -- GET CURRENT DATE
576: *
577: SYSDT EXP DEFINE EXTERNAL ENTRY POINT
578: *
579: * SYSDT IS USED TO OBTAIN THE CURRENT DATE. THE DATE IS
580: * RETURNED AS A CHARACTER STRING IN ANY FORMAT APPROPRIATE
581: * TO THE OPERATING SYSTEM IN USE. IT MAY ALSO CONTAIN THE
582: * CURRENT TIME OF DAY. SYSDT IS USED TO IMPLEMENT THE
583: * SNOBOL4 FUNCTION DATE.
584: *
585: * JSR SYSDT CALL TO GET DATE
586: * (XL) POINTER TO BLOCK CONTAINING DATE
587: *
588: * THE FORMAT OF THE BLOCK IS LIKE AN SCBLK EXCEPT THAT
589: * THE FIRST WORD NEED NOT BE SET. THE RESULT IS COPIED
590: * INTO SPITBOL DYNAMIC MEMORY ON RETURN.
591: EJC
592: *
593: * SYSEF -- EJECT FILE
594: *
595: SYSEF EXP DEFINE EXTERNAL ENTRY POINT
596: *
597: * SYSEF IS USED TO WRITE A PAGE EJECT TO A NAMED FILE. IT
598: * MAY ONLY BE USED FOR FILES WHERE THIS CONCEPT MAKES
599: * SENSE. NOTE THAT SYSEF IS NOT NORMALLY USED FOR THE
600: * STANDARD OUTPUT FILE (SEE SYSEP).
601: *
602: * (WA) PTR TO FCBLK OR ZERO
603: * (XR) EJECT ARGUMENT (SCBLK PTR)
604: * JSR SYSEF CALL TO EJECT FILE
605: * PPM LOC RETURN HERE IF FILE DOES NOT EXIST
606: * PPM LOC RETURN HERE IF INAPPROPRIATE FILE
607: * PPM LOC RETURN HERE IF I/O ERROR
608: EJC
609: *
610: * SYSEJ -- END OF JOB
611: *
612: SYSEJ EXP DEFINE EXTERNAL ENTRY POINT
613: *
614: * SYSEJ IS CALLED ONCE AT THE END OF EXECUTION TO
615: * TERMINATE THE RUN. THE SIGNIFICANCE OF THE ABEND AND
616: * CODE VALUES IS SYSTEM DEPENDENT. IN GENERAL, THE CODE
617: * VALUE SHOULD BE MADE AVAILABLE FOR TESTING, AND THE
618: * ABEND VALUE SHOULD CAUSE SOME POST-MORTEM ACTION SUCH AS
619: * A DUMP. NOTE THAT SYSEJ DOES NOT RETURN TO ITS CALLER.
620: * SEE SYSXI FOR DETAILS OF FCBLK CHAIN
621: *
622: * (WA) VALUE OF ABEND KEYWORD
623: * (WB) VALUE OF CODE KEYWORD
624: * (XL) O OR PTR TO HEAD OF FCBLK CHAIN
625: * JSR SYSEJ CALL TO END JOB
626: *
627: * THE FOLLOWING SPECIAL VALUES ARE USED AS CODES IN (WB)
628: * 999 EXECUTION SUPPRESSED
629: * 998 STANDARD OUTPUT FILE FULL OR UNAVAILABLE IN A SYSXI
630: * LOAD MODULE. IN THESE CASES (WA) CONTAINS THE NUMBER
631: * OF THE STATEMENT CAUSING PREMATURE TERMINATION.
632: EJC
633: *
634: * SYSEM -- GET ERROR MESSAGE TEXT
635: *
636: SYSEM EXP DEFINE EXTERNAL ENTRY POINT
637: *
638: * SYSEM IS USED TO OBTAIN THE TEXT OF ERR, ERB CALLS IN THE
639: * SOURCE PROGRAM GIVEN THE ERROR CODE NUMBER. IT IS ALLOWED
640: * TO RETURN A NULL STRING IF THIS FACILITY IS UNAVAILABLE.
641: *
642: * (WA) ERROR CODE NUMBER
643: * JSR SYSEM CALL TO GET TEXT
644: * (XR) TEXT OF MESSAGE
645: *
646: * THE RETURNED VALUE IS A POINTER TO A BLOCK IN SCBLK
647: * FORMAT EXCEPT THAT THE FIRST WORD NEED NOT BE SET. THE
648: * STRING IS COPIED INTO DYNAMIC MEMORY ON RETURN.
649: * IF THE NULL STRING IS RETURNED EITHER BECAUSE SYSEM DOES
650: * NOT PROVIDE ERROR MESSAGE TEXTS OR BECAUSE WA IS OUT OF
651: * RANGE, SPITBOL WILL PRINT THE STRING STORED IN ERRTEXT
652: * KEYWORD.
653: EJC
654: *
655: * SYSEN -- ENDFILE
656: *
657: SYSEN EXP DEFINE EXTERNAL ENTRY POINT
658: *
659: * SYSEN IS USED TO IMPLEMENT THE SNOBOL4 FUNCTION ENDFILE.
660: * THE MEANING IS SYSTEM DEPENDENT. IN GENERAL, ENDFILE
661: * IMPLIES THAT NO FURTHER I/O OPERATIONS WILL BE PERFORMED,
662: * BUT DOES NOT GUARANTEE THIS TO BE THE CASE. THE FILE
663: * SHOULD BE CLOSED AFTER THE CALL, A SUBSEQUENT READ
664: * OR WRITE MAY REOPEN THE FILE AT THE START OR IT MAY BE
665: * NECESSARY TO REOPEN THE FILE VIA SYSIO.
666: *
667: * (WA) PTR TO FCBLK OR ZERO
668: * (XR) ENDFILE ARGUMENT (SCBLK PTR)
669: * JSR SYSEN CALL TO ENDFILE
670: * PPM LOC RETURN HERE IF FILE DOES NOT EXIST
671: * PPM LOC RETURN HERE IF ENDFILE NOT ALLOWED
672: * PPM LOC RETURN HERE IF I/O ERROR
673: * (WA,WB) DESTROYED
674: *
675: * THE SECOND ERROR RETURN IS USED FOR FILES FOR WHICH
676: * ENDFILE IS NOT PERMITTED. FOR EXAMPLE, IT MAY BE EXPECTED
677: * THAT THE STANDARD INPUT AND OUTPUT FILES ARE IN THIS
678: * CATEGORY.
679: EJC
680: *
681: * SYSEP -- EJECT PRINTER PAGE
682: *
683: SYSEP EXP DEFINE EXTERNAL ENTRY POINT
684: *
685: * SYSEP IS CALLED TO PERFORM A PAGE EJECT ON THE STANDARD
686: * PRINTER OUTPUT FILE (CORRESPONDING TO SYSPR OUTPUT).
687: *
688: * JSR SYSEP CALL TO EJECT PRINTER OUTPUT
689: EJC
690: *
691: * SYSEX -- CALL EXTERNAL FUNCTION
692: *
693: SYSEX EXP DEFINE EXTERNAL ENTRY POINT
694: *
695: * SYSEX IS CALLED TO PASS CONTROL TO AN EXTERNAL FUNCTION
696: * PREVIOUSLY LOADED WITH A CALL TO SYSLD.
697: *
698: * (XS) POINTER TO ARGUMENTS ON STACK
699: * (XL) POINTER TO CONTROL BLOCK (EFBLK)
700: * (WA) NUMBER OF ARGUMENTS ON STACK
701: * JSR SYSEX CALL TO PASS CONTROL TO FUNCTION
702: * PPM LOC RETURN HERE IF FUNCTION CALL FAILS
703: * (XS) POPPED PAST ARGUMENTS
704: * (XR) RESULT RETURNED
705: *
706: * THE ARGUMENTS ARE STORED ON THE STACK WITH
707: * THE LAST ARGUMENT AT 0(XS). ON RETURN, XS
708: * IS POPPED PAST THE ARGUMENTS.
709: *
710: * THE FORM OF THE ARGUMENTS AS PASSED IS THAT USED IN THE
711: * SPITBOL TRANSLATOR (SEE DEFINITIONS AND DATA STRUCTURES
712: * SECTION). THE CONTROL BLOCK FORMAT IS ALSO DESCRIBED
713: * (UNDER EFBLK) IN THIS SECTION.
714: *
715: * THERE ARE TWO WAYS OF RETURNING A RESULT.
716: *
717: * 1) RETURN A POINTER TO A BLOCK IN DYNAMIC STORAGE. THIS
718: * BLOCK MUST BE IN EXACTLY CORRECT FORMAT, INCLUDING
719: * THE FIRST WORD. ONLY FUNCTIONS WRITTEN WITH INTIMATE
720: * KNOWLEDGE OF THE SYSTEM WILL RETURN IN THIS WAY.
721: *
722: * 2) STRING, INTEGER AND REAL RESULTS MAY BE RETURNED BY
723: * POINTING TO A PSEUDO-BLOCK OUTSIDE DYNAMIC MEMORY.
724: * THIS BLOCK IS IN ICBLK, RCBLK OR SCBLK FORMAT EXCEPT
725: * THAT THE FIRST WORD WILL BE OVERWRITTEN
726: * BY A TYPE WORD ON RETURN AND SO NEED NOT
727: * BE CORRECTLY SET. SUCH A RESULT IS
728: * COPIED INTO MAIN STORAGE BEFORE PROCEEDING.
729: * UNCONVERTED RESULTS MAY SIMILARLY BE RETURNED IN A
730: * PSEUDO-BLOCK WHICH IS IN CORRECT FORMAT INCLUDING
731: * TYPE WORD RECOGNISABLE BY GARBAGE COLLECTOR SINCE
732: * BLOCK IS COPIED INTO DYNAMIC MEMORY.
733: EJC
734: *
735: * SYSFC -- FILE CONTROL BLOCK ROUTINE
736: *
737: SYSFC EXP DEFINE EXTERNAL ENTRY POINT
738: *
739: * SEE ALSO SYSIO
740: * INPUT AND OUTPUT HAVE 3 ARGUMENTS REFERRED TO AS SHOWN
741: * INPUT(VARIABLE NAME,FILE ARG1,FILE ARG2)
742: * OUTPUT(VARIABLE NAME,FILE ARG1,FILE ARG2)
743: * FILE ARG1 MAY BE AN INTEGER OR STRING USED TO IDENTIFY
744: * AN I/O CHANNEL. IT IS CONVERTED TO A STRING FOR CHECKING.
745: * THE EXACT SIGNIFICANCE OF FILE ARG2
746: * IS NOT RIGOROUSLY PRESCRIBED BUT TO IMPROVE PORTABILITY,
747: * THE SCHEME DESCRIBED IN THE SPITBOL USER MANUAL
748: * SHOULD BE ADOPTED WHEN POSSIBLE. THE PREFERRED FORM IS
749: * A STRING $F$,R$R$,C$C$,I$I$,...,Z$Z$ WHERE
750: * $F$ IS AN OPTIONAL FILE NAME WHICH IS PLACED FIRST.
751: * REMAINING ITEMS MAY BE OMITTED OR INCLUDED IN ANY ORDER.
752: * $R$ IS MAXIMUM RECORD LENGTH
753: * $C$ IS A CARRIAGE CONTROL CHARACTER OR CHARACTER STRING
754: * $I$ IS SOME FORM OF CHANNEL IDENTIFICATION USED IN THE
755: * ABSENCE OF $F$ TO ASSOCIATE THE VARIABLE
756: * WITH A FILE ALLOCATED DYNAMICALLY BY JCL COMMANDS AT
757: * SPITBOL LOAD TIME.
758: * ,...,Z$Z$ ARE ADDITIONAL FIELDS.
759: * IF , (COMMA) CANNOT BE USED AS A DELIMITER, .CIOD
760: * SHOULD BE DEFINED TO INTRODUCE BY CONDITIONAL ASSEMBLY
761: * ANOTHER DELIMITER (SEE
762: * IODEL EQU *
763: * EARLY IN DEFINITIONS SECTION).
764: * SYSFC IS CALLED WHEN A VARIABLE IS INPUT OR OUTPUT
765: * ASSOCIATED TO CHECK FILE ARG1 AND FILE ARG2 AND
766: * TO REPORT WHETHER AN FCBLK (FILE CONTROL
767: * BLOCK) IS NECESSARY AND IF SO WHAT SIZE IT SHOULD BE.
768: * THIS MAKES IT POSSIBLE FOR SPITBOL RATHER THAN OSINT TO
769: * ALLOCATE SUCH A BLOCK IN DYNAMIC MEMORY IF REQUIRED
770: * OR ALTERNATIVELY IN STATIC MEMORY.
771: * THE SIGNIFICANCE OF AN FCBLK , IF ONE IS REQUESTED, IS
772: * ENTIRELY UP TO THE SYSTEM INTERFACE. THE ONLY RESTRICTION
773: * IS THAT IF THE FCBLK SHOULD APPEAR TO LIE IN DYNAMIC
774: * MEMORY , POINTERS TO IT SHOULD BE PROPER POINTERS TO
775: * THE START OF A RECOGNISABLE AND GARBAGE COLLECTABLE
776: * BLOCK (THIS CONDITION WILL BE MET IF SYSFC REQUESTS
777: * SPITBOL TO PROVIDE AN FCBLK).
778: * AN OPTION IS PROVIDED FOR OSINT TO RETURN A POINTER IN
779: * XL TO AN FCBLK WHICH IT PRIVATELY ALLOCATED. THIS PTR
780: * WILL BE MADE AVAILABLE WHEN I/O OCCURS LATER.
781: * PRIVATE FCBLKS MAY HAVE ARBITRARY CONTENTS AND SPITBOL
782: * STORES NOTHING IN THEM.
783: EJC
784: * THE REQUESTED SIZE FOR AN FCBLK IN DYNAMIC MEMORY
785: * SHOULD ALLOW A 2 WORD OVERHEAD FOR BLOCK TYPE AND
786: * LENGTH FIELDS. INFORMATION SUBSEQUENTLY STORED IN THE
787: * REMAINING WORDS MAY BE ARBITRARY IF AN XNBLK (EXTERNAL
788: * NON-RELOCATABLE BLOCK) IS REQUESTED. IF THE REQUEST IS
789: * FOR AN XRBLK (EXTERNAL RELOCATABLE BLOCK) THE
790: * CONTENTS OF WORDS SHOULD BE COLLECTABLE (I.E. ANY
791: * APPARENT POINTERS INTO DYNAMIC SHOULD BE GENUINE BLOCK
792: * POINTERS). THESE RESTRICTIONS DO NOT APPLY IF AN FCBLK
793: * IS ALLOCATED OUTSIDE DYNAMIC OR IS NOT ALLOCATED AT ALL.
794: * IF AN FCBLK IS REQUESTED, ITS FIELDS WILL BE INITIALISED
795: * TO ZERO BEFORE ENTRY TO SYSIO WITH THE EXCEPTION OF
796: * WORDS 0 AND 1 IN WHICH THE BLOCK TYPE AND LENGTH
797: * FIELDS ARE PLACED FOR FCBLKS IN DYNAMIC MEMORY ONLY.
798: * FOR THE POSSIBLE USE OF SYSEJ AND SYSXI, IF FCBLKS
799: * ARE USED, A CHAIN IS BUILT SO THAT THEY MAY ALL BE
800: * FOUND - SEE SYSXI FOR DETAILS.
801: * IF BOTH FILE ARG1 AND FILE ARG2 ARE NULL, CALLS OF SYSFC
802: * AND SYSIO ARE OMITTED.
803: * IF FILE ARG1 IS NULL (STANDARD INPUT/OUTPUT FILE), SYSFC
804: * IS CALLED TO CHECK NON-NULL FILE ARG2 BUT ANY REQUEST
805: * FOR AN FCBLK WILL BE IGNORED, SINCE SPITBOL HANDLES THE
806: * STANDARD FILES SPECIALLY AND CANNOT READILY KEEP FCBLK
807: * POINTERS FOR THEM.
808: * FILEARG1 IS TYPE CHECKED BY SPITBOL SO FURTHER CHECKING
809: * MAY BE UNNECCESSARY IN MANY IMPLEMENTATIONS.
810: * FILE ARG2 IS PASSED SO THAT SYSFC MAY ANALYSE AND
811: * CHECK IT. HOWEVER TO ASSIST IN THIS, SPITBOL ALSO PASSES
812: * ON THE STACK THE COMPONENTS OF THIS ARGUMENT WITH
813: * FILE NAME, $F$ (OTHERWISE NULL) EXTRACTED AND STACKED
814: * FIRST.
815: * THE OTHER FIELDS, IF ANY, ARE EXTRACTED AS SUBSTRINGS,
816: * POINTERS TO THEM ARE STACKED AND A COUNT OF ALL ITEMS
817: * STACKED IS PLACED IN WC. IF AN FCBLK WAS EARLIER
818: * ALLOCATED AND POINTED TO VIA FILE ARG1, SYSFC IS ALSO
819: * PASSED A POINTER TO THIS FCBLK.
820: *
821: * (XL) FILE ARG1 SCBLK PTR (2ND ARG)
822: * (XR) FILEARG2 (3RD ARG) OR NULL
823: * -(XS)...-(XS) SCBLKS FOR $F$,$R$,$C$,...
824: * (WC) NO. OF STACKED SCBLKS ABOVE
825: * (WA) EXISTING FILE ARG1 FCBLK PTR OR 0
826: * (WB) 0/3 FOR INPUT/OUTPUT ASSOCN
827: * JSR SYSFC CALL TO CHECK NEED FOR FCBLK
828: * PPM LOC INVALID FILE ARGUMENT
829: * (XS) POPPED (WC) TIMES
830: * (WA NON ZERO) BYTE SIZE OF REQUESTED FCBLK
831: * (WA=0,XL NON ZERO) PRIVATE FCBLK PTR IN XL
832: * (WA=XL=0) NO FCBLK WANTED, NO PRIVATE FCBLK
833: * (WC) 0/1/2 REQUEST ALLOC OF XRBLK/XNBLK
834: * /STATIC BLOCK FOR USE AS FCBLK
835: * (WB) DESTROYED
836: EJC
837: *
838: * SYSHS -- GIVE ACCESS TO HOST COMPUTER FEATURES
839: *
840: SYSHS EXP DEFINE EXTERNAL ENTRY POINT
841: *
842: * PROVIDES MEANS FOR IMPLEMENTING SPECIAL FEATURES
843: * ON DIFFERENT HOST COMPUTERS. THE ONLY DEFINED ENTRY IS
844: * THAT WHERE ALL ARGUMENTS ARE NULL IN WHICH CASE SYSHS
845: * RETURNS AN SCBLK CONTAINING NAME OF COMPUTER,
846: * NAME OF OPERATING SYSTEM AND NAME OF SITE SEPARATED BY
847: * COLONS. THE SCBLK NEED NOT HAVE A CORRECT FIRST FIELD
848: * AS THIS IS SUPPLIED ON COPYING STRING TO DYNAMIC MEMORY.
849: * SPITBOL DOES NO ARGUMENT CHECKING BUT DOES PROVIDE A
850: * SINGLE ERROR RETURN FOR ARGUMENTS CHECKED AS ERRONEOUS
851: * BY OSINT. IT ALSO PROVIDES A SINGLE EXECUTION ERROR
852: * RETURN. IF THESE ARE INADEQUATE, USE MAY BE MADE OF THE
853: * MINIMAL ERROR SECTION DIRECT AS DESCRIBED IN MINIMAL
854: * DOCUMENTATION, SECTION 10.
855: * SEVERAL NON-ERROR RETURNS ARE PROVIDED. THE FIRST
856: * CORRESPONDS TO THE DEFINED ENTRY OR, FOR IMPLEMENTATION
857: * DEFINED ENTRIES, ANY STRING MAY BE RETURNED. THE OTHERS
858: * PERMIT RESPECTIVELY, RETURN A NULL RESULT, RETURN WITH A
859: * RESULT TO BE STACKED WHICH IS POINTED AT BY XR, AND A
860: * RETURN CAUSING SPITBOL STATEMENT FAILURE. IF A RETURNED
861: * RESULT IS IN DYNAMIC MEMORY IT MUST OBEY GARBAGE
862: * COLLECTOR RULES. THE ONLY RESULTS COPIED ON RETURN
863: * ARE STRINGS RETURNED VIA PPM LOC3 RETURN.
864: *
865: * (WA) ARGUMENT 1
866: * (XL) ARGUMENT 2
867: * (XR) ARGUMENT 3
868: * JSR SYSHS CALL TO GET HOST INFORMATION
869: * PPM LOC1 ERRONEOUS ARG
870: * PPM LOC2 EXECUTION ERROR
871: * PPM LOC3 SCBLK PTR IN XL OR 0 IF UNAVAILABLE
872: * PPM LOC4 RETURN A NULL RESULT
873: * PPM LOC5 RETURN RESULT IN XR
874: * PPM LOC6 CAUSE STATEMENT FAILURE
875: EJC
876: *
877: * SYSID -- RETURN SYSTEM IDENTIFICATION
878: *
879: SYSID EXP DEFINE EXTERNAL ENTRY POINT
880: *
881: * THIS ROUTINE SHOULD RETURN STRINGS TO HEAD THE STANDARD
882: * PRINTER OUTPUT. THE FIRST STRING WILL BE APPENDED TO
883: * A HEADING LINE OF THE FORM
884: * MACRO SPITBOL VERSION V.V
885: * SUPPLIED BY SPITBOL ITSELF. V.V ARE DIGITS GIVING THE
886: * MAJOR VERSION NUMBER AND GENERALLY AT LEAST A MINOR
887: * VERSION NUMBER RELATING TO OSINT SHOULD BE SUPPLIED TO
888: * GIVE SAY
889: * MACRO SPITBOL VERSION V.V(M.M)
890: * THE SECOND STRING SHOULD IDENTIFY AT LEAST THE MACHINE
891: * AND OPERATING SYSTEM. PREFERABLY IT SHOULD INCLUDE
892: * THE DATE AND TIME OF THE RUN.
893: * OPTIONALLY THE STRINGS MAY INCLUDE SITE NAME OF THE
894: * THE IMPLEMENTOR AND/OR MACHINE ON WHICH RUN TAKES PLACE,
895: * UNIQUE SITE OR COPY NUMBER AND OTHER INFORMATION AS
896: * APPROPRIATE WITHOUT MAKING IT SO LONG AS TO BE A
897: * NUISANCE TO USERS.
898: * THE FIRST WORDS OF THE SCBLKS POINTED AT NEED NOT BE
899: * CORRECTLY SET.
900: *
901: * JSR SYSID CALL FOR SYSTEM IDENTIFICATION
902: * (XR) SCBLK PTR FOR ADDITION TO HEADER
903: * (XL) PTR TO SECOND HEADER SCBLK
904: EJC
905: *
906: * SYSIL -- GET INPUT RECORD LENGTH
907: *
908: SYSIL EXP DEFINE EXTERNAL ENTRY POINT
909: *
910: * SYSIL IS USED TO GET THE LENGTH OF THE NEXT INPUT RECORD
911: * FROM A FILE PREVIOUSLY INPUT ASSOCIATED WITH A SYSIO
912: * CALL. THE LENGTH RETURNED IS USED TO ESTABLISH A BUFFER
913: * FOR A SUBSEQUENT SYSIN CALL.
914: *
915: * (WA) PTR TO FCBLK OR ZERO
916: * JSR SYSIL CALL TO GET RECORD LENGTH
917: * (WA) LENGTH OR ZERO IF FILE CLOSED
918: *
919: * NO HARM IS DONE IF THE VALUE RETURNED IS TOO LONG SINCE
920: * UNUSED SPACE WILL BE RECLAIMED AFTER THE SYSIN CALL.
921: *
922: * NOTE THAT IT IS THE SYSIL CALL (NOT THE SYSIO CALL) WHICH
923: * CAUSES THE FILE TO BE OPENED AS REQUIRED FOR THE FIRST
924: * RECORD INPUT FROM THE FILE.
925: EJC
926: *
927: * SYSIN -- READ INPUT RECORD
928: *
929: SYSIN EXP DEFINE EXTERNAL ENTRY POINT
930: *
931: * SYSIN IS USED TO READ A RECORD FROM THE FILE WHICH WAS
932: * REFERENCED IN A PRIOR CALL TO SYSIL (I.E. THESE CALLS
933: * ALWAYS OCCUR IN PAIRS). THE BUFFER PROVIDED IS AN
934: * SCBLK FOR A STRING OF LENGTH SET FROM THE SYSIL CALL.
935: * IF THE ACTUAL LENGTH READ IS LESS THAN THIS, THE LENGTH
936: * FIELD OF THE SCBLK MUST BE MODIFIED BEFORE RETURNING
937: * UNLESS BUFFER IS RIGHT PADDED WITH ZEROES.
938: * IT IS ALSO PERMISSIBLE TO TAKE ANY OF THE ALTERNATIVE
939: * RETURNS AFTER SCBLK LENGTH HAS BEEN MODIFIED.
940: *
941: * (WA) PTR TO FCBLK OR ZERO
942: * (XR) POINTER TO BUFFER (SCBLK PTR)
943: * JSR SYSIN CALL TO READ RECORD
944: * PPM LOC ENDFILE OR NO I/P FILE AFTER SYSXI
945: * PPM LOC RETURN HERE IF I/O ERROR
946: * PPM LOC RETURN HERE IF RECORD FORMAT ERROR
947: * (WA,WB,WC) DESTROYED
948: EJC
949: *
950: * SYSIO -- INPUT/OUTPUT FILE ASSOCIATION
951: *
952: SYSIO EXP DEFINE EXTERNAL ENTRY POINT
953: *
954: * SEE ALSO SYSFC.
955: * SYSIO IS CALLED IN RESPONSE TO A SNOBOL4 INPUT OR OUTPUT
956: * FUNCTION CALL EXCEPT WHEN FILE ARG1 AND FILE ARG2
957: * ARE BOTH NULL.
958: * ITS CALL ALWAYS FOLLOWS IMMEDIATELY AFTER A CALL
959: * OF SYSFC. IF SYSFC REQUESTED ALLOCATION
960: * OF AN FCBLK, ITS ADDRESS WILL BE IN WA.
961: * FOR INPUT FILES, NON-ZERO VALUES OF $R$ SHOULD BE
962: * COPIED TO WC FOR USE IN ALLOCATING INPUT BUFFERS. IF $R$
963: * IS DEFAULTED OR NOT IMPLEMENTED, WC SHOULD BE ZEROISED.
964: * ONCE A FILE HAS BEEN OPENED, SUBSEQUENT INPUT(),OUTPUT()
965: * CALLS IN WHICH THE SECOND ARGUMENT IS IDENTICAL WITH THAT
966: * IN A PREVIOUS CALL, MERELY ASSOCIATE THE ADDITIONAL
967: * VARIABLE NAME (FIRST ARGUMENT) TO THE FILE AND DO NOT
968: * RESULT IN RE-OPENING THE FILE.
969: * IN SUBSEQUENT ASSOCIATED ACCESSES TO THE FILE A POINTER
970: * TO ANY FCBLK ALLOCATED WILL BE MADE AVAILABLE.
971: *
972: * (XL) FILE ARG1 SCBLK PTR (2ND ARG)
973: * (XR) FILE ARG2 SCBLK PTR (3RD ARG)
974: * (WA) FCBLK PTR (0 IF NONE)
975: * (WB) 0 FOR INPUT, 3 FOR OUTPUT
976: * JSR SYSIO CALL TO ASSOCIATE FILE
977: * PPM LOC RETURN HERE IF FILE DOES NOT EXIST
978: * PPM LOC RETURN IF INPUT/OUTPUT NOT ALLOWED
979: * (XL) FCBLK POINTER (0 IF NONE)
980: * (WC) 0 (FOR DEFAULT) OR MAX RECORD LNGTH
981: * (WA,WB) DESTROYED
982: *
983: * THE SECOND ERROR RETURN IS USED IF THE FILE NAMED EXISTS
984: * BUT INPUT/OUTPUT FROM THE FILE IS NOT ALLOWED. FOR
985: * EXAMPLE, THE STANDARD OUTPUT FILE MAY BE IN THIS CATEGORY
986: * AS REGARDS INPUT ASSOCIATION.
987: EJC
988: *
989: * SYSLD -- LOAD EXTERNAL FUNCTION
990: *
991: SYSLD EXP DEFINE EXTERNAL ENTRY POINT
992: *
993: * SYSLD IS CALLED IN RESPONSE TO THE USE OF THE SNOBOL4
994: * LOAD FUNCTION. THE NAMED FUNCTION IS LOADED (WHATEVER
995: * THIS MEANS), AND A POINTER IS RETURNED. THE POINTER WILL
996: * BE USED ON SUBSEQUENT CALLS TO THE FUNCTION (SEE SYSEX).
997: *
998: * (XR) POINTER TO FUNCTION NAME (SCBLK)
999: * (XL) POINTER TO LIBRARY NAME (SCBLK)
1000: * JSR SYSLD CALL TO LOAD FUNCTION
1001: * PPM LOC RETURN HERE IF FUNC DOES NOT EXIST
1002: * PPM LOC RETURN HERE IF I/O ERROR
1003: * (XR) POINTER TO LOADED CODE
1004: *
1005: * THE SIGNIFICANCE OF THE POINTER RETURNED IS UP TO THE
1006: * SYSTEM INTERFACE ROUTINE. THE ONLY RESTRICTION IS THAT
1007: * IF THE POINTER IS WITHIN DYNAMIC STORAGE, IT MUST BE
1008: * A PROPER BLOCK POINTER.
1009: EJC
1010: *
1011: * SYSMM -- GET MORE MEMORY
1012: *
1013: SYSMM EXP DEFINE EXTERNAL ENTRY POINT
1014: *
1015: * SYSMM IS CALLED IN AN ATTEMPT TO ALLOCATE MORE DYNAMIC
1016: * MEMORY. THIS MEMORY MUST BE ALLOCATED CONTIGUOUSLY WITH
1017: * THE CURRENT DYNAMIC DATA AREA.
1018: *
1019: * THE AMOUNT ALLOCATED IS UP TO THE SYSTEM TO DECIDE. ANY
1020: * VALUE IS ACCEPTABLE INCLUDING ZERO IF ALLOCATION IS
1021: * IMPOSSIBLE.
1022: *
1023: * JSR SYSMM CALL TO GET MORE MEMORY
1024: * (XR) NUMBER OF ADDITIONAL WORDS OBTAINED
1025: EJC
1026: *
1027: * SYSMX -- SUPPLY MXLEN
1028: *
1029: SYSMX EXP DEFINE EXTERNAL ENTRY POINT
1030: *
1031: * BECAUSE OF THE METHOD OF GARBAGE COLLECTION, NO SPITBOL
1032: * OBJECT IS ALLOWED TO OCCUPY MORE BYTES OF MEMORY THAN
1033: * THE INTEGER GIVING THE LOWEST ADDRESS OF DYNAMIC
1034: * (GARBAGE COLLECTABLE) MEMORY. MXLEN IS THE NAME USED TO
1035: * REFER TO THIS MAXIMUM LENGTH OF AN OBJECT AND FOR MOST
1036: * USERS OF MOST IMPLEMENTATIONS, PROVIDED DYNAMIC MEMORY
1037: * STARTS AT AN ADDRESS OF AT LEAST A FEW THOUSAND WORDS,
1038: * THERE IS NO PROBLEM.
1039: * IF THE DEFAULT STARTING ADDRESS IS LESS THAN SAY 10000 OR
1040: * 20000, THEN A LOAD TIME OPTION SHOULD BE PROVIDED WHERE A
1041: * USER CAN REQUEST THAT HE BE ABLE TO CREATE LARGER
1042: * OBJECTS. THIS ROUTINE INFORMS SPITBOL OF THIS REQUEST IF
1043: * ANY. THE VALUE RETURNED IS EITHER AN INTEGER
1044: * REPRESENTING THE DESIRED VALUE OF MXLEN (AND HENCE THE
1045: * MINIMUM DYNAMIC STORE ADDRESS WHICH MAY RESULT IN
1046: * NON-USE OF SOME STORE) OR ZERO IF A DEFAULT IS ACCEPTABLE
1047: * IN WHICH MXLEN IS SET TO THE LOWEST ADDRESS ALLOCATED
1048: * TO DYNAMIC STORE BEFORE COMPILATION STARTS.
1049: * IF A NON-ZERO VALUE IS RETURNED, THIS IS USED FOR KEYWORD
1050: * MAXLNGTH. OTHERWISE THE INITIAL LOW ADDRESS OF DYNAMIC
1051: * MEMORY IS USED FOR THIS KEYWORD.
1052: *
1053: * JSR SYSMX CALL TO GET MXLEN
1054: * (WA) EITHER MXLEN OR 0 FOR DEFAULT
1055: EJC
1056: *
1057: * SYSOU -- OUTPUT RECORD
1058: *
1059: SYSOU EXP DEFINE EXTERNAL ENTRY POINT
1060: *
1061: * SYSOU IS USED TO WRITE A RECORD TO A FILE PREVIOUSLY
1062: * ASSOCIATED WITH A SYSIO CALL.
1063: *
1064: * (WA) PTR TO FCBLK OR ZERO
1065: * (XR) RECORD TO BE WRITTEN (SCBLK)
1066: * JSR SYSOU CALL TO OUTPUT RECORD
1067: * PPM LOC FILE FULL OR NO FILE AFTER SYSXI
1068: * PPM LOC RETURN HERE IF I/O ERROR
1069: * (WA,WB,WC) DESTROYED
1070: *
1071: * NOTE THAT IT IS THE SYSOU CALL (NOT THE SYSIO CALL) WHICH
1072: * CAUSES THE FILE TO BE OPENED AS REQUIRED FOR THE FIRST
1073: * RECORD OUTPUT TO THE FILE.
1074: EJC
1075: *
1076: * SYSPI -- PRINT ON INTERACTIVE CHANNEL
1077: *
1078: SYSPI EXP DEFINE EXTERNAL ENTRY POINT
1079: *
1080: * IF SPITBOL IS RUN FROM AN ONLINE TERMINAL, OSINT CAN
1081: * REQUEST THAT MESSAGES SUCH AS COPIES OF COMPILATION
1082: * ERRORS BE SENT TO THE TERMINAL (SEE SYSPP). IF RELEVANT
1083: * REPLY WAS MADE BY SYSPP THEN SYSPI IS CALLED TO SEND SUCH
1084: * MESSAGES TO THE INTERACTIVE CHANNEL.
1085: * SYSPI IS ALSO USED FOR SENDING OUTPUT TO THE TERMINAL
1086: * THROUGH THE SPECIAL VARIABLE NAME, TERMINAL.
1087: *
1088: * (XR) PTR TO LINE BUFFER (SCBLK)
1089: * (WA) LINE LENGTH
1090: * JSR SYSPI CALL TO PRINT LINE
1091: * PPM LOC FAILURE RETURN
1092: * (WA,WB) DESTROYED
1093: EJC
1094: *
1095: * SYSPP -- OBTAIN PRINT PARAMETERS
1096: *
1097: SYSPP EXP DEFINE EXTERNAL ENTRY POINT
1098: *
1099: * SYSPP IS CALLED ONCE DURING COMPILATION TO OBTAIN
1100: * PARAMETERS REQUIRED FOR CORRECT PRINTED OUTPUT FORMAT
1101: * AND TO SELECT OTHER OPTIONS. IT MAY ALSO BE CALLED AGAIN
1102: * AFTER SYSXI WHEN A LOAD MODULE IS RESUMED. IN THIS
1103: * CASE THE VALUE RETURNED IN WA MAY BE LESS THAN OR EQUAL
1104: * TO THAT RETURNED IN INITIAL CALL BUT MAY NOT BE
1105: * GREATER.
1106: * THE INFORMATION RETURNED IS -
1107: * 1. LINE LENGTH IN CHARS FOR STANDARD PRINT FILE
1108: * 2. NO OF LINES/PAGE. 0 IS PREFERABLE FOR A NON-PAGED
1109: * DEVICE (E.G. ONLINE TERMINAL) IN WHICH CASE LISTING
1110: * PAGE THROWS ARE SUPPRESSED AND PAGE HEADERS
1111: * RESULTING FROM -TITLE,-STITL LINES ARE KEPT SHORT.
1112: * 3. AN INITIAL -NOLIST OPTION TO SUPPRESS LISTING UNLESS
1113: * THE PROGRAM CONTAINS AN EXPLICIT -LIST.
1114: * 4. OPTIONS TO SUPPRESS LISTING OF COMPILATION AND/OR
1115: * EXECUTION STATS (USEFUL FOR ESTABLISHED PROGRAMS) -
1116: * COMBINED WITH 3. GIVES POSSIBILITY OF LISTING
1117: * FILE NEVER BEING OPENED.
1118: * 5. OPTION TO HAVE COPIES OF ERRORS SENT TO AN
1119: * INTERACTIVE CHANNEL IN ADDITION TO STANDARD PRINTER.
1120: * 6. OPTION TO KEEP PAGE HEADERS SHORT (E.G. IF LISTING
1121: * TO AN ONLINE TERMINAL).
1122: * 7. AN OPTION TO CHOOSE EXTENDED OR COMPACT LISTING
1123: * FORMAT. IN THE FORMER A PAGE EJECT AND IN THE LATTER
1124: * A FEW LINE FEEDS PRECEDE THE PRINTING OF EACH
1125: * OF-- LISTING, COMPILATION STATISTICS, EXECUTION
1126: * OUTPUT AND EXECUTION STATISTICS.
1127: * 8. AN OPTION TO SUPPRESS EXECUTION AS THOUGH A
1128: * -NOEXECUTE CARD WERE SUPPLIED.
1129: * 9. AN OPTION TO REQUEST THAT NAME /TERMINAL/ BE PRE-
1130: * ASSOCIATED TO AN ONLINE TERMINAL VIA SYSPI AND SYSRI
1131: * 10. AN INTERMEDIATE (STANDARD) LISTING OPTION REQUIRING
1132: * THAT PAGE EJECTS OCCUR IN SOURCE LISTINGS. REDUNDANT
1133: * IF EXTENDED OPTION CHOSEN BUT PARTIALLY EXTENDS
1134: * COMPACT OPTION.
1135: * 11. OPTION TO SUPPRESS SYSID IDENTIFICATION.
1136: *
1137: * JSR SYSPP CALL TO GET PRINT PARAMETERS
1138: * (WA) PRINT LINE LENGTH IN CHARS
1139: * (WB) NUMBER OF LINES/PAGE
1140: * (WC) BITS VALUE ...JIHGFEDCBA WHERE
1141: * A = 1 TO SEND ERROR COPY TO INT.CH.
1142: * B = 1 MEANS STD PRINTER IS INT. CH.
1143: * C = 1 FOR -NOLIST OPTION
1144: * D = 1 TO SUPPRESS COMPILN. STATS
1145: * E = 1 TO SUPPRESS EXECN. STATS
1146: * F = 1/0 FOR EXTNDED/COMPACT LISTING
1147: * G = 1 FOR -NOEXECUTE
1148: * H = 1 PRE-ASSOCIATE /TERMINAL/
1149: * I = 1 FOR STANDARD LISTING OPTION.
1150: * J = 1 SUPPRESSES LISTING HEADER
1151: EJC
1152: *
1153: * SYSPR -- PRINT LINE ON STANDARD OUTPUT FILE
1154: *
1155: SYSPR EXP DEFINE EXTERNAL ENTRY POINT
1156: *
1157: * SYSPR IS USED TO PRINT A SINGLE LINE ON THE STANDARD
1158: * OUTPUT FILE.
1159: *
1160: * (XR) POINTER TO LINE BUFFER (SCBLK)
1161: * (WA) LINE LENGTH
1162: * JSR SYSPR CALL TO PRINT LINE
1163: * PPM LOC TOO MUCH O/P OR NO FILE AFTER SYSXI
1164: * (WA,WB) DESTROYED
1165: *
1166: * THE BUFFER POINTED TO IS THE LENGTH OBTAINED FROM THE
1167: * SYSPP CALL AND IS FILLED OUT WITH TRAILING BLANKS. THE
1168: * VALUE IN WA IS THE ACTUAL LINE LENGTH WHICH MAY BE LESS
1169: * THAN THE MAXIMUM LINE LENGTH POSSIBLE. THERE IS NO SPACE
1170: * CONTROL ASSOCIATED WITH THE LINE, ALL LINES ARE PRINTED
1171: * SINGLE SPACED. NOTE THAT NULL LINES (WA=0) ARE POSSIBLE
1172: * IN WHICH CASE A BLANK LINE IS TO BE PRINTED.
1173: *
1174: * THE ERROR EXIT IS USED FOR SYSTEMS WHICH LIMIT THE AMOUNT
1175: * OF PRINTED OUTPUT. IF POSSIBLE, PRINTING SHOULD BE
1176: * PERMITTED AFTER THIS CONDITION HAS BEEN SIGNALLED ONCE TO
1177: * ALLOW FOR DUMP AND OTHER DIAGNOSTIC INFORMATION.
1178: * ASSUMING THIS TO BE POSSIBLE, SPITBOL MAY MAKE MORE SYSPR
1179: * CALLS. IF THE ERROR RETURN OCCURS ANOTHER TIME, EXECUTION
1180: * IS TERMINATED BY A CALL OF SYSEJ WITH ENDING CODE 998.
1181: EJC
1182: *
1183: * SYSRD -- READ RECORD FROM STANDARD INPUT FILE
1184: *
1185: SYSRD EXP DEFINE EXTERNAL ENTRY POINT
1186: *
1187: * SYSRD IS USED TO READ A RECORD FROM THE STANDARD INPUT
1188: * FILE. THE BUFFER PROVIDED IS AN SCBLK FOR A STRING THE
1189: * LENGTH OF WHICH IN CHARACTERS IS GIVEN IN WC, THIS
1190: * CORRESPONDING TO THE MAXIMUM LENGTH OF STRING WHICH
1191: * SPITBOL IS PREPARED TO RECEIVE. AT COMPILE TIME IT
1192: * CORRESPONDS TO XXX IN THE MOST RECENT -INXXX CARD
1193: * (DEFAULT 72) AND AT EXECUTION TIME TO THE MOST RECENT
1194: * ,R$R$ (RECORD LENGTH) IN THE THIRD ARG OF AN INPUT()
1195: * STATEMENT FOR THE STANDARD INPUT FILE (DEFAULT 80).
1196: * IF FEWER THAN (WC) CHARACTERS ARE READ, THE LENGTH
1197: * FIELD OF THE SCBLK MUST BE ADJUSTED BEFORE RETURNING
1198: * UNLESS THE BUFFER IS RIGHT PADDED WITH ZEROES.
1199: * IT IS ALSO PERMISSIBLE TO TAKE THE ALTERNATIVE RETURN
1200: * AFTER SUCH AN ADJUSTMENT HAS BEEN MADE.
1201: * SPITBOL MAY CONTINUE TO MAKE CALLS AFTER AN ENDFILE
1202: * RETURN SO THIS ROUTINE SHOULD BE PREPARED TO MAKE
1203: * REPEATED ENDFILE RETURNS.
1204: *
1205: * (XR) POINTER TO BUFFER (SCBLK PTR)
1206: * (WC) LENGTH OF BUFFER IN CHARACTERS
1207: * JSR SYSRD CALL TO READ LINE
1208: * PPM LOC ENDFILE OR NO I/P FILE AFTER SYSXI
1209: * (WA,WB,WC) DESTROYED
1210: EJC
1211: *
1212: * SYSRI -- READ RECORD FROM INTERACTIVE CHANNEL
1213: *
1214: SYSRI EXP DEFINE EXTERNAL ENTRY POINT
1215: *
1216: * READS A RECORD FROM ONLINE TERMINAL FOR SPITBOL VARIABLE,
1217: * TERMINAL. IF ONLINE TERMINAL IS UNAVAILABLE THEN CODE THE
1218: * ENDFILE RETURN ONLY.
1219: * THE BUFFER PROVIDED IS OF LENGTH 120 CHARACTERS. SYSRI
1220: * SHOULD REPLACE THE COUNT IN THE SECOND WORD OF THE SCBLK
1221: * BY THE ACTUAL CHARACTER COUNT UNLESS BUFFER IS RIGHT
1222: * PADDED WITH ZEROES.
1223: * IT IS ALSO PERMISSIBLE TO TAKE THE ALTERNATIVE
1224: * RETURN AFTER ADJUSTING THE COUNT.
1225: * THE END OF FILE RETURN MAY BE USED IF THIS MAKES
1226: * SENSE ON THE TARGET MACHINE (E.G. IF THERE IS AN
1227: * EOF CHARACTER.)
1228: *
1229: * (XR) PTR TO 120 CHAR BUFFER (SCBLK PTR)
1230: * JSR SYSRI CALL TO READ LINE FROM TERMINAL
1231: * PPM LOC END OF FILE RETURN
1232: * (WA,WB,WC) MAY BE DESTROYED
1233: EJC
1234: *
1235: * SYSRW -- REWIND FILE
1236: *
1237: SYSRW EXP DEFINE EXTERNAL ENTRY POINT
1238: *
1239: * SYSRW IS USED TO REWIND A FILE I.E. REPOSITION THE FILE
1240: * AT THE START BEFORE THE FIRST RECORD. THE FILE SHOULD BE
1241: * CLOSED AND THE NEXT READ OR WRITE CALL WILL OPEN THE
1242: * FILE AT THE START.
1243: *
1244: * (WA) PTR TO FCBLK OR ZERO
1245: * (XR) REWIND ARG (SCBLK PTR)
1246: * JSR SYSRW CALL TO REWIND FILE
1247: * PPM LOC RETURN HERE IF FILE DOES NOT EXIST
1248: * PPM LOC RETURN HERE IF REWIND NOT ALLOWED
1249: * PPM LOC RETURN HERE IF I/O ERROR
1250: EJC
1251: .IF .CUST
1252: *
1253: * SYSST -- SET FILE POINTER
1254: *
1255: SYSST EXP DEFINE EXTERNAL ENTRY POINT
1256: *
1257: * SYSST IS CALLED TO CHANGE THE POSITION OF A FILE
1258: * POINTER. THIS IS ACCOMPLISHED IN A SYSTEM DEPENDENT
1259: * MANNER, AND THUS THE 2ND AND 3RD ARGUMENTS ARE PASSED
1260: * UNCONVERTED.
1261: *
1262: * (WA) FCBLK POINTER
1263: * (WB) 2ND ARGUMENT
1264: * (WC) 3RD ARGUMENT
1265: * JSR SYSST CALL TO SET FILE POINTER
1266: * PPM LOC RETURN HERE IF INVALID 2ND ARG
1267: * PPM LOC RETURN HERE IF INVALID 3RD ARG
1268: * PPM LOC RETURN HERE IF FILE DOES NOT EXIST
1269: * PPM LOC RETURN HERE IF SET NOT ALLOWED
1270: * PPM LOC RETURN HERE IF I/O ERROR
1271: *
1272: EJC
1273: .FI
1274: *
1275: * SYSTM -- GET EXECUTION TIME SO FAR
1276: *
1277: SYSTM EXP DEFINE EXTERNAL ENTRY POINT
1278: *
1279: * SYSTM IS USED TO OBTAIN THE AMOUNT OF EXECUTION TIME
1280: * USED SO FAR SINCE SPITBOL WAS GIVEN CONTROL. THE UNITS
1281: * ARE DESCRIBED AS MILLISECONDS IN THE SPITBOL OUTPUT, BUT
1282: * THE EXACT MEANING IS SYSTEM DEPENDENT. WHERE APPROPRIATE,
1283: * THIS VALUE SHOULD RELATE TO PROCESSOR RATHER THAN CLOCK
1284: * TIMING VALUES.
1285: *
1286: * JSR SYSTM CALL TO GET TIMER VALUE
1287: * (IA) TIME SO FAR IN MILLISECONDS
1288: EJC
1289: *
1290: * SYSTT -- TRACE TOGGLE
1291: *
1292: SYSTT EXP DEFINE EXTERNAL ENTRY POINT
1293: *
1294: * CALLED BY SPITBOL FUNCTION TRACE() WITH NO ARGS TO
1295: * TOGGLE THE SYSTEM TRACE SWITCH. THIS PERMITS TRACING OF
1296: * LABELS IN SPITBOL CODE TO BE TURNED ON OR OFF.
1297: *
1298: * JSR SYSTT CALL TO TOGGLE TRACE SWITCH
1299: EJC
1300: *
1301: * SYSUL -- UNLOAD EXTERNAL FUNCTION
1302: *
1303: SYSUL EXP DEFINE EXTERNAL ENTRY POINT
1304: *
1305: * SYSUL IS USED TO UNLOAD A FUNCTION PREVIOUSLY
1306: * LOADED WITH A CALL TO SYSLD.
1307: *
1308: * (XR) PTR TO CONTROL BLOCK (EFBLK)
1309: * JSR SYSUL CALL TO UNLOAD FUNCTION
1310: *
1311: * THE FUNCTION CANNOT BE CALLED FOLLOWING A SYSUL CALL
1312: * UNTIL ANOTHER SYSLD CALL IS MADE FOR THE SAME FUNCTION.
1313: *
1314: * THE EFBLK CONTAINS THE FUNCTION CODE POINTER AND ALSO A
1315: * POINTER TO THE VRBLK CONTAINING THE FUNCTION NAME (SEE
1316: * DEFINITIONS AND DATA STRUCTURES SECTION).
1317: .IF .CNEX
1318: .ELSE
1319: EJC
1320: *
1321: * SYSXI -- EXIT TO PRODUCE LOAD MODULE
1322: *
1323: SYSXI EXP DEFINE EXTERNAL ENTRY POINT
1324: *
1325: * WHEN SYSXI IS CALLED, XL CONTAINS EITHER A STRING POINTER
1326: * OR ZERO. IN THE FORMER CASE, THE STRING GIVES THE
1327: * CHARACTER NAME OF A PROGRAM. THE INTENTION IS THAT
1328: * SPITBOL EXECUTION SHOULD BE TERMINATED FORTHWITH AND
1329: * THE NAMED PROGRAM LOADED AND EXECUTED. THIS TYPE OF CHAIN
1330: * EXECUTION IS VERY SYSTEM DEPENDENT AND IMPLEMENTORS MAY
1331: * CHOOSE TO OMIT IT OR FIND IT IMPOSSIBLE TO PROVIDE.
1332: * IF (XL) IS ZERO,IA CONTAINS ONE OF THE FOLLOWING INTEGERS
1333: *
1334: * -1, -2, -3
1335: * CREATE IF POSSIBLE A LOAD MODULE CONTAINING ONLY THE
1336: * IMPURE AREA OF MEMORY WHICH NEEDS TO BE LOADED WITH
1337: * A COMPATIBLE PURE SEGMENT FOR SUBSEQUENT EXECUTIONS.
1338: * VERSION NUMBERS TO CHECK COMPATIBILITY SHOULD BE
1339: * KEPT IN BOTH SEGMENTS AND CHECKED ON LOADING.
1340: * TO ASSIST WITH THIS CHECK, (XR) ON ENTRY IS A
1341: * POINTER TO AN SCBLK CONTAINING THE SPITBOL MAJOR
1342: * VERSION NUMBER V.V (SEE SYSID).
1343: *
1344: * 0 IF POSSIBLE, RETURN CONTROL TO JOB CONTROL
1345: * COMMAND LEVEL. THE EFFECT IF AVAILABLE WILL BE
1346: * SYSTEM DEPENDENT.
1347: *
1348: * +1, +2, +3
1349: * CREATE IF POSSIBLE A LOAD MODULE FROM ALL OF
1350: * MEMORY. IT SHOULD BE POSSIBLE TO LOAD AND EXECUTE
1351: * THIS MODULE DIRECTLY.
1352: *
1353: * IN THE CASE OF SAVED LOAD MODULES, THE STATUS OF OPEN
1354: * FILES IS NOT PRESERVED AND IMPLEMENTORS MAY CHOOSE TO
1355: * OFFER MEANS OF ATTACHING FILES BEFORE EXECUTION OF LOAD
1356: * MODULES STARTS OR LEAVE IT TO THE USER TO INCLUDE
1357: * SUITABLE INPUT(), OUTPUT() CALLS IN HIS PROGRAM.
1358: * SYSXI SHOULD MAKE A NOTE THAT NO I/O CHANNELS,
1359: * INCLUDING STANDARD FILES, HAVE FILES ATTACHED SO THAT
1360: * CALLS OF SYSIN, SYSOU, SYSPR, SYSRD SHOULD FAIL UNLESS
1361: * NEW ASSOCIATIONS ARE MADE FOR THE LOAD MODULE.
1362: * AT LEAST IN THE CASE OF THE STANDARD OUTPUT FILE, IT IS
1363: * RECOMMENDED THAT EITHER THE USER BE REQUIRED TO ATTACH
1364: * A FILE OR THAT A DEFAULT FILE IS ATTACHED, SINCE THE
1365: * PROBLEM OF ERROR MESSAGES GENERATED BY THE LOAD MODULE
1366: * IS OTHERWISE SEVERE. AS A LAST RESORT, IF SPITBOL
1367: * ATTEMPTS TO WRITE TO THE STANDARD OUTPUT FILE AND GETS A
1368: * REPLY INDICATING THAT SUCH OUPUT IS UNACCEPTABLE IT STOPS
1369: * BY USING AN ENTRY TO SYSEJ WITH ENDING CODE 998.
1370: * AS DESCRIBED BELOW, PASSING OF SOME ARGUMENTS MAKES IT
1371: * CLEAR THAT LOAD MODULE WILL USE A STANDARD OUTPUT FILE.
1372: *
1373: * IF USE IS MADE OF FCBLKS FOR I/O ASSOCIATION, SPITBOL
1374: * BUILDS A CHAIN SO THAT THOSE IN USE MAY BE FOUND IN SYSXI
1375: * AND SYSEJ. THE NODES ARE 4 WORDS LONG. THIRD WORD
1376: * CONTAINS LINK TO NEXT NODE OR 0, FOURTH WORD CONTAINS
1377: * FCBLK POINTER.
1378: EJC
1379: *
1380: * SYSXI (CONTINUED)
1381: *
1382: * (XL) ZERO OR SCBLK PTR
1383: * (XR) PTR TO V.V SCBLK
1384: * (IA) SIGNED INTEGER ARGUMENT
1385: * (WB) 0 OR PTR TO HEAD OF FCBLK CHAIN
1386: * JSR SYSXI CALL TO EXIT
1387: * PPM LOC REQUESTED ACTION NOT POSSIBLE
1388: * PPM LOC ACTION CAUSED IRRECOVERABLE ERROR
1389: * (REGISTERS) SHOULD BE PRESERVED OVER CALL
1390: *
1391: * LOADING AND RUNNING THE LOAD MODULE OR RETURNING FROM
1392: * JCL COMMAND LEVEL CAUSES EXECUTION TO RESUME AT THE POINT
1393: * AFTER THE ERROR RETURNS WHICH FOLLOW THE CALL OF SYSXI.
1394: * THE VALUE PASSED AS EXIT ARGUMENT IS USED TO INDICATE
1395: * OPTIONS REQUIRED ON RESUMPTION OF LOAD MODULE.
1396: * +1 OR -1 REQUIRE THAT ON RESUMPTION, SYSID AND SYSPP BE
1397: * CALLED AND A HEADING PRINTED ON THE STANDARD OUTPUT FILE.
1398: * +2 OR -2 INDICATE THAT SYSPP WILL BE CALLED BUT NOT SYSID
1399: * AND NO HEADING WILL BE PUT ON STANDARD OUTPUT FILE.
1400: * ABOVE OPTIONS HAVE THE OBVIOUS IMPLICATION THAT A
1401: * STANDARD O/P FILE MUST BE PROVIDED FOR THE LOAD MODULE.
1402: * +3 OR -3 INDICATE CALLS OF NEITHER SYSID NOR SYSPP
1403: * AND NO HEADING WILL BE PLACED ON STANDARD OUTPUT FILE.
1404: * NO RETURN FROM SYSXI IS POSSIBLE IF ANOTHER PROGRAM
1405: * IS LOADED AND ENTERED.
1406: .FI
1407: EJC
1408: *
1409: * INTRODUCE THE INTERNAL PROCEDURES.
1410: *
1411: ACESS INP R,1
1412: ACOMP INP N,5
1413: ALLOC INP E,0
1414: .IF .CNBF
1415: .ELSE
1416: ALOBF INP E,0
1417: .FI
1418: ALOCS INP E,0
1419: ALOST INP E,0
1420: APNDB INP E,2
1421: .IF .CNRA
1422: ARITH INP N,2
1423: .ELSE
1424: ARITH INP N,3
1425: .FI
1426: ASIGN INP R,1
1427: ASINP INP R,1
1428: BLKLN INP E,0
1429: CDGCG INP E,0
1430: CDGEX INP R,0
1431: CDGNM INP R,0
1432: CDGVL INP R,0
1433: CDWRD INP E,0
1434: CMGEN INP R,0
1435: CMPIL INP E,0
1436: CNCRD INP E,0
1437: COPYB INP N,1
1438: DFFNC INP E,0
1439: DTACH INP E,0
1440: DTYPE INP E,0
1441: DUMPR INP E,0
1442: ERMSG INP E,0
1443: ERTEX INP E,0
1444: EVALI INP R,4
1445: EVALP INP R,1
1446: EVALS INP R,3
1447: EVALX INP R,1
1448: EXBLD INP E,0
1449: EXPAN INP E,0
1450: EXPAP INP E,1
1451: EXPDM INP N,0
1452: EXPOP INP N,0
1453: .IF .CULC
1454: FLSTG INP R,0
1455: .FI
1456: GBCOL INP E,0
1457: GBCPF INP E,0
1458: GTARR INP E,1
1459: EJC
1460: GTCOD INP E,1
1461: GTEXP INP E,1
1462: GTINT INP E,1
1463: GTNUM INP E,1
1464: GTNVR INP E,1
1465: GTPAT INP E,1
1466: .IF .CNRA
1467: .ELSE
1468: GTREA INP E,1
1469: .FI
1470: GTSMI INP N,2
1471: GTSTG INP N,1
1472: GTVAR INP E,1
1473: HASHS INP E,0
1474: ICBLD INP E,0
1475: IDENT INP E,1
1476: INOUT INP E,0
1477: .IF .CNBF
1478: .ELSE
1479: INSBF INP E,2
1480: .FI
1481: IOFCB INP N,2
1482: IOPPF INP N,0
1483: IOPUT INP N,6
1484: KTREX INP R,0
1485: KWNAM INP N,0
1486: LCOMP INP N,5
1487: LISTR INP E,0
1488: LISTT INP E,0
1489: NEXTS INP E,0
1490: PATIN INP N,2
1491: PATST INP N,1
1492: PBILD INP E,0
1493: PCONC INP E,0
1494: PCOPY INP N,0
1495: .IF .CNPF
1496: .ELSE
1497: PRFLR INP E,0
1498: PRFLU INP E,0
1499: .FI
1500: PRPAR INP E,0
1501: PRTCH INP E,0
1502: PRTIC INP E,0
1503: PRTIS INP E,0
1504: PRTIN INP E,0
1505: PRTMI INP E,0
1506: PRTMX INP E,0
1507: PRTNL INP R,0
1508: PRTNM INP R,0
1509: PRTNV INP E,0
1510: PRTPG INP E,0
1511: PRTPS INP E,0
1512: PRTSN INP E,0
1513: PRTST INP R,0
1514: EJC
1515: PRTTR INP E,0
1516: PRTVL INP R,0
1517: PRTVN INP E,0
1518: .IF .CNRA
1519: .ELSE
1520: RCBLD INP E,0
1521: .FI
1522: READR INP E,0
1523: SBSTR INP E,0
1524: SCANE INP E,0
1525: SCNGF INP E,0
1526: SETVR INP E,0
1527: .IF .CNSR
1528: .ELSE
1529: SORTA INP N,0
1530: SORTC INP E,1
1531: SORTF INP E,0
1532: SORTH INP E,0
1533: .FI
1534: TFIND INP E,1
1535: TRACE INP N,2
1536: TRBLD INP E,0
1537: TRIMR INP E,0
1538: TRXEQ INP R,0
1539: XSCAN INP E,0
1540: XSCNI INP N,2
1541: *
1542: * INTRODUCE THE INTERNAL ROUTINES
1543: *
1544: ARREF INR
1545: CFUNC INR
1546: EXFAL INR
1547: EXINT INR
1548: EXITS INR
1549: EXIXR INR
1550: EXNAM INR
1551: EXNUL INR
1552: .IF .CNRA
1553: .ELSE
1554: EXREA INR
1555: .FI
1556: EXSID INR
1557: EXVNM INR
1558: FAILP INR
1559: FLPOP INR
1560: INDIR INR
1561: MATCH INR
1562: RETRN INR
1563: STCOV INR
1564: STMGO INR
1565: STOPR INR
1566: SUCCP INR
1567: SYSAB INR
1568: SYSTU INR
1569: TTL S P I T B O L -- DEFINITIONS AND DATA STRUCTURES
1570: SEC START OF DEFINITIONS SECTION
1571: *
1572: * DEFINITIONS OF MACHINE PARAMETERS
1573: *
1574: * THE MINIMAL TRANSLATOR SHOULD SUPPLY APPROPRIATE VALUES
1575: * FOR THE PARTICULAR TARGET MACHINE FOR ALL THE
1576: * EQU *
1577: * DEFINITIONS GIVEN AT THE START OF THIS SECTION.
1578: *
1579: CFP$A EQU * NUMBER OF CHARACTERS IN ALPHABET
1580: *
1581: CFP$B EQU * BYTES/WORD ADDRESSING FACTOR
1582: *
1583: CFP$C EQU * NUMBER OF CHARACTERS PER WORD
1584: *
1585: CFP$F EQU * OFFSET IN BYTES TO CHARS IN
1586: * SCBLK. SEE SCBLK FORMAT.
1587: *
1588: CFP$I EQU * NUMBER OF WORDS IN INTEGER CONSTANT
1589: *
1590: CFP$M EQU * MAX POSITIVE INTEGER IN ONE WORD
1591: *
1592: CFP$N EQU * NUMBER OF BITS IN ONE WORD
1593: *
1594: * THE FOLLOWING DEFINITIONS REQUIRE THE SUPPLY OF EITHER
1595: * A SINGLE PARAMETER IF REAL ARITHMETIC IS OMITTED OR
1596: * THREE PARAMETERS IF REAL ARITHMETIC IS INCLUDED.
1597: *
1598: .IF .CNRA
1599: NSTMX EQU * NO. OF DECIMAL DIGITS IN CFP$M
1600: .ELSE
1601: *
1602: CFP$R EQU * NUMBER OF WORDS IN REAL CONSTANT
1603: *
1604: CFP$S EQU * NUMBER OF SIG DIGS FOR REAL OUTPUT
1605: *
1606: CFP$X EQU * MAX DIGITS IN REAL EXPONENT
1607: *
1608: MXDGS EQU CFP$S+CFP$X MAX DIGITS IN REAL NUMBER
1609: *
1610: NSTMX EQU MXDGS+5 MAX SPACE FOR REAL (FOR +0.E+)
1611: .FI
1612: .IF .CUCF
1613: *
1614: * THE FOLLOWING DEFINITION FOR CFP$U SUPPLIES A REALISTIC
1615: * UPPER BOUND ON THE SIZE OF THE ALPHABET. CFP$U IS USED
1616: * TO SAVE SPACE IN THE SCANE BSW-IFF-ESW TABLE AND TO EASE
1617: * TRANSLATION STORAGE REQUIREMENTS.
1618: *
1619: CFP$U EQU * REALISTIC UPPER BOUND ON ALPHABET
1620: .FI
1621: EJC
1622: *
1623: * ENVIRONMENT PARAMETERS
1624: *
1625: * THE SPITBOL PROGRAM IS ESSENTIALLY INDEPENDENT OF
1626: * THE DEFINITIONS OF THESE PARAMETERS. HOWEVER, THE
1627: * EFFICIENCY OF THE SYSTEM MAY BE AFFECTED. CONSEQUENTLY,
1628: * THESE PARAMETERS MAY REQUIRE TUNING FOR A GIVEN VERSION
1629: * THE VALUES GIVEN IN COMMENTS HAVE BEEN SUCCESSFULLY USED.
1630: *
1631: * E$SRS IS THE NUMBER OF WORDS TO RESERVE AT THE END OF
1632: * STORAGE FOR END OF RUN PROCESSING. IT SHOULD BE
1633: * SET AS SMALL AS POSSIBLE WITHOUT CAUSING MEMORY OVERFLOW
1634: * IN CRITICAL SITUATIONS (E.G. MEMORY OVERFLOW TERMINATION)
1635: * AND SHOULD THUS RESERVE SUFFICIENT SPACE AT LEAST FOR
1636: * AN SCBLK CONTAINING SAY 30 CHARACTERS.
1637: *
1638: E$SRS EQU * 30 WORDS
1639: *
1640: * E$STS IS THE NUMBER OF WORDS GRABBED IN A CHUNK WHEN
1641: * STORAGE IS ALLOCATED IN THE STATIC REGION. THE MINIMUM
1642: * PERMITTED VALUE IS 256/CFP$B. LARGER VALUES WILL LEAD
1643: * TO INCREASED EFFICIENCY AT THE COST OF WASTING MEMORY.
1644: *
1645: E$STS EQU * 500 WORDS
1646: *
1647: * E$CBS IS THE SIZE OF CODE BLOCK ALLOCATED INITIALLY AND
1648: * THE EXPANSION INCREMENT IF OVERFLOW OCCURS. IF THIS VALUE
1649: * IS TOO SMALL OR TOO LARGE, EXCESSIVE GARBAGE COLLECTIONS
1650: * WILL OCCUR DURING COMPILATION AND MEMORY MAY BE LOST
1651: * IN THE CASE OF A TOO LARGE VALUE.
1652: *
1653: E$CBS EQU * 500 WORDS
1654: *
1655: * E$HNB IS THE NUMBER OF BUCKET HEADERS IN THE VARIABLE
1656: * HASH TABLE. IT SHOULD ALWAYS BE ODD. LARGER VALUES WILL
1657: * SPEED UP COMPILATION AND INDIRECT REFERENCES AT THE
1658: * EXPENSE OF ADDITIONAL STORAGE FOR THE HASH TABLE ITSELF.
1659: *
1660: E$HNB EQU * 127 BUCKET HEADERS
1661: *
1662: * E$HNW IS THE MAXIMUM NUMBER OF WORDS OF A STRING
1663: * NAME WHICH PARTICIPATE IN THE STRING HASH ALGORITHM.
1664: * LARGER VALUES GIVE A BETTER HASH AT THE EXPENSE OF TAKING
1665: * LONGER TO COMPUTE THE HASH. THERE IS SOME OPTIMAL VALUE.
1666: *
1667: E$HNW EQU * 6 WORDS
1668: *
1669: * E$FSP . IF THE AMOUNT OF FREE SPACE LEFT AFTER A GARBAGE
1670: * COLLECTION IS SMALL COMPARED TO THE TOTAL AMOUNT OF SPACE
1671: * IN USE GARBAGE COLLECTOR THRASHING IS LIKELY TO OCCUR AS
1672: * THIS SPACE IS USED UP. E$FSP IS A MEASURE OF THE
1673: * MINIMUM PERCENTAGE OF DYNAMIC MEMORY LEFT AS FREE SPACE
1674: * BEFORE THE SYSTEM ROUTINE SYSMM IS CALLED TO TRY TO
1675: * OBTAIN MORE MEMORY.
1676: *
1677: E$FSP EQU * 15 PERCENT
1678: EJC
1679: *
1680: * DEFINITIONS OF CODES FOR LETTERS
1681: *
1682: CH$LA EQU * LETTER A
1683: CH$LB EQU * LETTER B
1684: CH$LC EQU * LETTER C
1685: CH$LD EQU * LETTER D
1686: CH$LE EQU * LETTER E
1687: CH$LF EQU * LETTER F
1688: CH$LG EQU * LETTER G
1689: CH$LH EQU * LETTER H
1690: CH$LI EQU * LETTER I
1691: CH$LJ EQU * LETTER J
1692: CH$LK EQU * LETTER K
1693: CH$LL EQU * LETTER L
1694: CH$LM EQU * LETTER M
1695: CH$LN EQU * LETTER N
1696: CH$LO EQU * LETTER O
1697: CH$LP EQU * LETTER P
1698: CH$LQ EQU * LETTER Q
1699: CH$LR EQU * LETTER R
1700: CH$LS EQU * LETTER S
1701: CH$LT EQU * LETTER T
1702: CH$LU EQU * LETTER U
1703: CH$LV EQU * LETTER V
1704: CH$LW EQU * LETTER W
1705: CH$LX EQU * LETTER X
1706: CH$LY EQU * LETTER Y
1707: CH$L$ EQU * LETTER Z
1708: *
1709: * DEFINITIONS OF CODES FOR DIGITS
1710: *
1711: CH$D0 EQU * DIGIT 0
1712: CH$D1 EQU * DIGIT 1
1713: CH$D2 EQU * DIGIT 2
1714: CH$D3 EQU * DIGIT 3
1715: CH$D4 EQU * DIGIT 4
1716: CH$D5 EQU * DIGIT 5
1717: CH$D6 EQU * DIGIT 6
1718: CH$D7 EQU * DIGIT 7
1719: CH$D8 EQU * DIGIT 8
1720: CH$D9 EQU * DIGIT 9
1721: EJC
1722: *
1723: * DEFINITIONS OF CODES FOR SPECIAL CHARACTERS
1724: *
1725: * THE NAMES OF THESE CHARACTERS ARE RELATED TO THEIR
1726: * ORIGINAL REPRESENTATION IN THE EBCDIC SET CORRESPONDING
1727: * TO THE DESCRIPTION IN STANDARD SNOBOL4 MANUALS AND TEXTS.
1728: *
1729: CH$AM EQU * KEYWORD OPERATOR (AMPERSAND)
1730: CH$AS EQU * MULTIPLICATION SYMBOL (ASTERISK)
1731: CH$AT EQU * CURSOR POSITION OPERATOR (AT)
1732: CH$BB EQU * LEFT ARRAY BRACKET (LESS THAN)
1733: CH$BL EQU * BLANK
1734: CH$BR EQU * ALTERNATION OPERATOR (VERTICAL BAR)
1735: CH$CL EQU * GOTO SYMBOL (COLON)
1736: CH$CM EQU * COMMA
1737: CH$DL EQU * INDIRECTION OPERATOR (DOLLAR)
1738: CH$DT EQU * NAME OPERATOR (DOT)
1739: CH$DQ EQU * DOUBLE QUOTE
1740: CH$EQ EQU * EQUAL SIGN
1741: CH$EX EQU * EXPONENTIATION OPERATOR (EXCLM)
1742: CH$MN EQU * MINUS SIGN
1743: CH$NM EQU * NUMBER SIGN
1744: CH$NT EQU * NEGATION OPERATOR (NOT)
1745: CH$PC EQU * PERCENT
1746: CH$PL EQU * PLUS SIGN
1747: CH$PP EQU * LEFT PARENTHESIS
1748: CH$RB EQU * RIGHT ARRAY BRACKET (GRTR THAN)
1749: CH$RP EQU * RIGHT PARENTHESIS
1750: CH$QU EQU * INTERROGATION OPERATOR (QUESTION)
1751: CH$SL EQU * SLASH
1752: CH$SM EQU * SEMICOLON
1753: CH$SQ EQU * SINGLE QUOTE
1754: CH$UN EQU * SPECIAL IDENTIFIER CHAR (UNDERLINE)
1755: CH$OB EQU * OPENING BRACKET
1756: CH$CB EQU * CLOSING BRACKET
1757: EJC
1758: *
1759: * REMAINING CHARS ARE OPTIONAL ADDITIONS TO THE STANDARDS.
1760: .IF .CAHT
1761: *
1762: * TAB CHARACTERS - SYNTACTICALLY EQUIVALENT TO BLANK
1763: *
1764: CH$HT EQU * HORIZONTAL TAB
1765: .FI
1766: .IF .CAVT
1767: CH$VT EQU * VERTICAL TAB
1768: .FI
1769: .IF .CASL
1770: *
1771: * LOWER CASE OR SHIFTED CASE ALPHABETIC CHARS
1772: *
1773: CH$$A EQU * SHIFTED A
1774: CH$$B EQU * SHIFTED B
1775: CH$$C EQU * SHIFTED C
1776: CH$$D EQU * SHIFTED D
1777: CH$$E EQU * SHIFTED E
1778: CH$$F EQU * SHIFTED F
1779: CH$$G EQU * SHIFTED G
1780: CH$$H EQU * SHIFTED H
1781: CH$$I EQU * SHIFTED I
1782: CH$$J EQU * SHIFTED J
1783: CH$$K EQU * SHIFTED K
1784: CH$$L EQU * SHIFTED L
1785: CH$$M EQU * SHIFTED M
1786: CH$$N EQU * SHIFTED N
1787: CH$$O EQU * SHIFTED O
1788: CH$$P EQU * SHIFTED P
1789: CH$$Q EQU * SHIFTED Q
1790: CH$$R EQU * SHIFTED R
1791: CH$$S EQU * SHIFTED S
1792: CH$$T EQU * SHIFTED T
1793: CH$$U EQU * SHIFTED U
1794: CH$$V EQU * SHIFTED V
1795: CH$$W EQU * SHIFTED W
1796: CH$$X EQU * SHIFTED X
1797: CH$$Y EQU * SHIFTED Y
1798: CH$$$ EQU * SHIFTED Z
1799: .FI
1800: * IF A DELIMITER OTHER THAN CH$CM MUST BE USED IN
1801: * THE THIRD ARGUMENT OF INPUT(),OUTPUT() THEN .CIOD SHOULD
1802: * BE DEFINED AND A PARAMETER SUPPLIED FOR IODEL.
1803: *
1804: .IF .CIOD
1805: IODEL EQU *
1806: .ELSE
1807: IODEL EQU CH$CM
1808: .FI
1809: EJC
1810: *
1811: * DATA BLOCK FORMATS AND DEFINITIONS
1812: *
1813: * THE FOLLOWING SECTIONS DESCRIBE THE DETAILED FORMAT OF
1814: * ALL POSSIBLE DATA BLOCKS IN STATIC AND DYNAMIC MEMORY.
1815: *
1816: * EVERY BLOCK HAS A NAME OF THE FORM XXBLK WHERE XX IS A
1817: * UNIQUE TWO CHARACTER IDENTIFIER. THE FIRST WORD OF EVERY
1818: * BLOCK MUST CONTAIN A POINTER TO A PROGRAM LOCATION IN THE
1819: * INTERPRETOR WHICH IS IMMEDIATELY PRECEDED BY AN ADDRESS
1820: * CONSTANT CONTAINING THE VALUE BL$XX WHERE XX IS THE BLOCK
1821: * IDENTIFIER. THIS PROVIDES A UNIFORM MECHANISM FOR
1822: * DISTINGUISHING BETWEEN THE VARIOUS BLOCK TYPES.
1823: *
1824: * IN SOME CASES, THE CONTENTS OF THE FIRST WORD IS CONSTANT
1825: * FOR A GIVEN BLOCK TYPE AND MERELY SERVES AS A POINTER
1826: * TO THE IDENTIFYING ADDRESS CONSTANT. HOWEVER, IN OTHER
1827: * CASES THERE ARE SEVERAL POSSIBILITIES FOR THE FIRST
1828: * WORD IN WHICH CASE EACH OF THE SEVERAL PROGRAM ENTRY
1829: * POINTS MUST BE PRECEDED BY THE APPROPRIATE CONSTANT.
1830: *
1831: * IN EACH BLOCK, SOME OF THE FIELDS ARE RELOCATABLE. THIS
1832: * MEANS THAT THEY MAY CONTAIN A POINTER TO ANOTHER BLOCK
1833: * IN THE DYNAMIC AREA. (TO BE MORE PRECISE, IF THEY CONTAIN
1834: * A POINTER WITHIN THE DYNAMIC AREA, THEN IT IS A POINTER
1835: * TO A BLOCK). SUCH FIELDS MUST BE MODIFIED BY THE GARBAGE
1836: * COLLECTOR (PROCEDURE GBCOL) WHENEVER BLOCKS ARE COMPACTED
1837: * IN THE DYNAMIC REGION. THE GARBAGE COLLECTOR (ACTUALLY
1838: * PROCEDURE GBCPF) REQUIRES THAT ALL SUCH RELOCATABLE
1839: * FIELDS IN A BLOCK MUST BE CONTIGUOUS.
1840: EJC
1841: *
1842: * THE DESCRIPTION FORMAT USES THE FOLLOWING SCHEME.
1843: *
1844: * 1) BLOCK TITLE AND TWO CHARACTER IDENTIFIER
1845: *
1846: * 2) DESCRIPTION OF BASIC USE OF BLOCK AND INDICATION
1847: * OF CIRCUMSTANCES UNDER WHICH IT IS CONSTRUCTED.
1848: *
1849: * 3) PICTURE OF THE BLOCK FORMAT. IN THESE PICTURES LOW
1850: * MEMORY ADDRESSES ARE AT THE TOP OF THE PAGE. FIXED
1851: * LENGTH FIELDS ARE SURROUNDED BY I (LETTER I). FIELDS
1852: * WHICH ARE FIXED LENGTH BUT WHOSE LENGTH IS DEPENDENT
1853: * ON A CONFIGURATION PARAMETER ARE SURROUNDED BY *
1854: * (ASTERISK). VARIABLE LENGTH FIELDS ARE SURROUNDED
1855: * BY / (SLASH).
1856: *
1857: * 4) DEFINITION OF SYMBOLIC OFFSETS TO FIELDS IN
1858: * BLOCK AND OF THE SIZE OF THE BLOCK IF FIXED LENGTH
1859: * OR OF THE SIZE OF THE FIXED LENGTH FIELDS IF THE
1860: * BLOCK IS VARIABLE LENGTH.
1861: * NOTE THAT SOME ROUTINES SUCH AS GBCPF ASSUME
1862: * CERTAIN OFFSETS ARE EQUAL. THE DEFINITIONS
1863: * GIVEN HERE ENFORCE THIS. MAKE CHANGES TO
1864: * THEM ONLY WITH DUE CARE.
1865: *
1866: * DEFINITIONS OF COMMON OFFSETS
1867: *
1868: OFFS1 EQU 1
1869: OFFS2 EQU 2
1870: OFFS3 EQU 3
1871: *
1872: * 5) DETAILED COMMENTS ON THE SIGNIFICANCE AND FORMATS
1873: * OF THE VARIOUS FIELDS.
1874: *
1875: * THE ORDER IS ALPHABETICAL BY IDENTIFICATION CODE.
1876: EJC
1877: *
1878: * DEFINITIONS OF BLOCK CODES
1879: *
1880: * THIS TABLE PROVIDES A UNIQUE IDENTIFICATION CODE FOR
1881: * EACH SEPARATE BLOCK TYPE. THE FIRST WORD OF A BLOCK IN
1882: * THE DYNAMIC AREA ALWAYS CONTAINS THE ADDRESS OF A PROGRAM
1883: * ENTRY POINT. THE BLOCK CODE IS USED AS THE ENTRY POINT ID
1884: * THE ORDER OF THESE CODES DICTATES THE ORDER OF THE TABLE
1885: * USED BY THE DATATYPE FUNCTION (SCNMT IN THE CONSTANT SEC)
1886: *
1887: * BLOCK CODES FOR ACCESSIBLE DATATYPES
1888: *
1889: BL$AR EQU 0 ARBLK ARRAY
1890: .IF .CNBF
1891: BL$CD EQU BL$AR+1 CDBLK CODE
1892: .ELSE
1893: BL$BC EQU BL$AR+1 BCBLK BUFFER
1894: BL$CD EQU BL$BC+1 CDBLK CODE
1895: .FI
1896: BL$EX EQU BL$CD+1 EXBLK EXPRESSION
1897: BL$IC EQU BL$EX+1 ICBLK INTEGER
1898: BL$NM EQU BL$IC+1 NMBLK NAME
1899: BL$P0 EQU BL$NM+1 P0BLK PATTERN
1900: BL$P1 EQU BL$P0+1 P1BLK PATTERN
1901: BL$P2 EQU BL$P1+1 P2BLK PATTERN
1902: .IF .CNRA
1903: BL$SC EQU BL$P2+1 SCBLK STRING
1904: .ELSE
1905: BL$RC EQU BL$P2+1 RCBLK REAL
1906: BL$SC EQU BL$RC+1 SCBLK STRING
1907: .FI
1908: BL$SE EQU BL$SC+1 SEBLK EXPRESSION
1909: BL$TB EQU BL$SE+1 TBBLK TABLE
1910: BL$VC EQU BL$TB+1 VCBLK ARRAY
1911: BL$XN EQU BL$VC+1 XNBLK EXTERNAL
1912: BL$XR EQU BL$XN+1 XRBLK EXTERNAL
1913: BL$PD EQU BL$XR+1 PDBLK PROGRAM DEFINED DATATYPE
1914: *
1915: BL$$D EQU BL$PD+1 NUMBER OF BLOCK CODES FOR DATA
1916: *
1917: * OTHER BLOCK CODES
1918: *
1919: BL$TR EQU BL$PD+1 TRBLK
1920: .IF .CNBF
1921: BL$CC EQU BL$TR+1 CCBLK
1922: .ELSE
1923: BL$BF EQU BL$TR+1 BFBLK
1924: BL$CC EQU BL$BF+1 CCBLK
1925: .FI
1926: BL$CM EQU BL$CC+1 CMBLK
1927: BL$CT EQU BL$CM+1 CTBLK
1928: BL$DF EQU BL$CT+1 DFBLK
1929: BL$EF EQU BL$DF+1 EFBLK
1930: BL$EV EQU BL$EF+1 EVBLK
1931: BL$FF EQU BL$EV+1 FFBLK
1932: BL$KV EQU BL$FF+1 KVBLK
1933: BL$PF EQU BL$KV+1 PFBLK
1934: BL$TE EQU BL$PF+1 TEBLK
1935: *
1936: BL$$I EQU 0 DEFAULT IDENTIFICATION CODE
1937: BL$$T EQU BL$TR+1 CODE FOR DATA OR TRACE BLOCK
1938: BL$$$ EQU BL$TE+1 NUMBER OF BLOCK CODES
1939: EJC
1940: *
1941: * FIELD REFERENCES
1942: *
1943: * REFERENCES TO THE FIELDS OF DATA BLOCKS ARE SYMBOLIC
1944: * (I.E. USE THE SYMBOLIC OFFSETS) WITH THE FOLLOWING
1945: * EXCEPTIONS.
1946: *
1947: * 1) REFERENCES TO THE FIRST WORD ARE USUALLY NOT
1948: * SYMBOLIC SINCE THEY USE THE (X) OPERAND FORMAT.
1949: *
1950: * 2) THE CODE WHICH CONSTRUCTS A BLOCK IS OFTEN NOT
1951: * SYMBOLIC AND SHOULD BE CHANGED IF THE CORRESPONDING
1952: * BLOCK FORMAT IS MODIFIED.
1953: *
1954: * 3) THE PLC AND PSC INSTRUCTIONS IMPLY AN OFFSET
1955: * CORRESPONDING TO THE DEFINITION OF CFP$F.
1956: *
1957: * 4) THERE ARE NON-SYMBOLIC REFERENCES (EASILY CHANGED)
1958: * IN THE GARBAGE COLLECTOR (PROCEDURES GBCPF, BLKLN).
1959: *
1960: * 5) THE FIELDS IDVAL, FARGS APPEAR IN SEVERAL BLOCKS
1961: * AND ANY CHANGES MUST BE MADE IN PARALLEL TO ALL
1962: * BLOCKS CONTAINING THE FIELDS. THE ACTUAL REFERENCES
1963: * TO THESE FIELDS ARE SYMBOLIC WITH THE ABOVE
1964: * LISTED EXCEPTIONS.
1965: *
1966: * 6) SEVERAL SPOTS IN THE CODE ASSUME THAT THE
1967: * DEFINITIONS OF THE FIELDS VRVAL, TEVAL, TRNXT ARE
1968: * THE SAME (THESE ARE SECTIONS OF CODE WHICH SEARCH
1969: * OUT ALONG A TRBLK CHAIN FROM A VARIABLE).
1970: *
1971: * 7) REFERENCES TO THE FIELDS OF AN ARRAY BLOCK IN THE
1972: * ARRAY REFERENCE ROUTINE ARREF ARE NON-SYMBOLIC.
1973: *
1974: * APART FROM THE EXCEPTIONS LISTED, REFERENCES ARE SYMBOLIC
1975: * AS FAR AS POSSIBLE AND MODIFYING THE ORDER OR NUMBER
1976: * OF FIELDS WILL NOT REQUIRE CHANGES.
1977: EJC
1978: *
1979: * COMMON FIELDS FOR FUNCTION BLOCKS
1980: *
1981: * BLOCKS WHICH REPRESENT CALLABLE FUNCTIONS HAVE TWO
1982: * COMMON FIELDS AT THE START OF THE BLOCK AS FOLLOWS.
1983: *
1984: * +------------------------------------+
1985: * I FCODE I
1986: * +------------------------------------+
1987: * I FARGS I
1988: * +------------------------------------+
1989: * / /
1990: * / REST OF FUNCTION BLOCK /
1991: * / /
1992: * +------------------------------------+
1993: *
1994: FCODE EQU 0 POINTER TO CODE FOR FUNCTION
1995: FARGS EQU 1 NUMBER OF ARGUMENTS
1996: *
1997: * FCODE IS A POINTER TO THE LOCATION IN THE INTERPRETOR
1998: * PROGRAM WHICH PROCESSES THIS TYPE OF FUNCTION CALL.
1999: *
2000: * FARGS IS THE EXPECTED NUMBER OF ARGUMENTS. THE ACTUAL
2001: * NUMBER OF ARGUMENTS IS ADJUSTED TO THIS AMOUNT BY
2002: * DELETING EXTRA ARGUMENTS OR SUPPLYING TRAILING NULLS
2003: * FOR MISSING ONES BEFORE TRANSFERRING THOUGH FCODE.
2004: * A VALUE OF 999 MAY BE USED IN THIS FIELD TO INDICATE A
2005: * VARIABLE NUMBER OF ARGUMENTS (SEE SVBLK FIELD SVNAR).
2006: *
2007: * THE BLOCK TYPES WHICH FOLLOW THIS SCHEME ARE.
2008: *
2009: * FFBLK FIELD FUNCTION
2010: * DFBLK DATATYPE FUNCTION
2011: * PFBLK PROGRAM DEFINED FUNCTION
2012: * EFBLK EXTERNAL LOADED FUNCTION
2013: EJC
2014: *
2015: * IDENTIFICATION FIELD
2016: *
2017: *
2018: * ID FIELD
2019: *
2020: * CERTAIN PROGRAM ACCESSIBLE OBJECTS (THOSE WHICH CONTAIN
2021: * OTHER DATA VALUES AND CAN BE COPIED) ARE GIVEN A UNIQUE
2022: * IDENTIFICATION NUMBER (SEE EXSID). THIS ID VALUE IS AN
2023: * ADDRESS INTEGER VALUE WHICH IS ALWAYS STORED IN WORD TWO.
2024: *
2025: IDVAL EQU 1 ID VALUE FIELD
2026: *
2027: * THE BLOCKS CONTAINING AN IDVAL FIELD ARE.
2028: *
2029: * ARBLK ARRAY
2030: .IF .CNBF
2031: .ELSE
2032: * BCBLK BUFFER CONTROL BLOCK
2033: .FI
2034: * PDBLK PROGRAM DEFINED DATATYPE
2035: * TBBLK TABLE
2036: * VCBLK VECTOR BLOCK (ARRAY)
2037: *
2038: * NOTE THAT A ZERO IDVAL MEANS THAT THE BLOCK IS ONLY
2039: * HALF BUILT AND SHOULD NOT BE DUMPED (SEE DUMPR).
2040: EJC
2041: *
2042: * ARRAY BLOCK (ARBLK)
2043: *
2044: * AN ARRAY BLOCK REPRESENTS AN ARRAY VALUE OTHER THAN ONE
2045: * WITH ONE DIMENSION WHOSE LOWER BOUND IS ONE (SEE VCBLK).
2046: * AN ARBLK IS BUILT WITH A CALL TO THE FUNCTIONS CONVERT
2047: * (S$CNV) OR ARRAY (S$ARR).
2048: *
2049: * +------------------------------------+
2050: * I ARTYP I
2051: * +------------------------------------+
2052: * I IDVAL I
2053: * +------------------------------------+
2054: * I ARLEN I
2055: * +------------------------------------+
2056: * I AROFS I
2057: * +------------------------------------+
2058: * I ARNDM I
2059: * +------------------------------------+
2060: * * ARLBD *
2061: * +------------------------------------+
2062: * * ARDIM *
2063: * +------------------------------------+
2064: * * *
2065: * * ABOVE 2 FLDS REPEATED FOR EACH DIM *
2066: * * *
2067: * +------------------------------------+
2068: * I ARPRO I
2069: * +------------------------------------+
2070: * / /
2071: * / ARVLS /
2072: * / /
2073: * +------------------------------------+
2074: EJC
2075: *
2076: * ARRAY BLOCK (CONTINUED)
2077: *
2078: ARTYP EQU 0 POINTER TO DUMMY ROUTINE B$ART
2079: ARLEN EQU IDVAL+1 LENGTH OF ARBLK IN BYTES
2080: AROFS EQU ARLEN+1 OFFSET IN ARBLK TO ARPRO FIELD
2081: ARNDM EQU AROFS+1 NUMBER OF DIMENSIONS
2082: ARLBD EQU ARNDM+1 LOW BOUND (FIRST SUBSCRIPT)
2083: ARDIM EQU ARLBD+CFP$I DIMENSION (FIRST SUBSCRIPT)
2084: ARLB2 EQU ARDIM+CFP$I LOW BOUND (SECOND SUBSCRIPT)
2085: ARDM2 EQU ARLB2+CFP$I DIMENSION (SECOND SUBSCRIPT)
2086: ARPRO EQU ARDIM+CFP$I ARRAY PROTOTYPE (ONE DIMENSION)
2087: ARVLS EQU ARPRO+1 START OF VALUES (ONE DIMENSION)
2088: ARPR2 EQU ARDM2+CFP$I ARRAY PROTOTYPE (TWO DIMENSIONS)
2089: ARVL2 EQU ARPR2+1 START OF VALUES (TWO DIMENSIONS)
2090: ARSI$ EQU ARLBD NUMBER OF STANDARD FIELDS IN BLOCK
2091: ARDMS EQU ARLB2-ARLBD SIZE OF INFO FOR ONE SET OF BOUNDS
2092: *
2093: * THE BOUNDS AND DIMENSION FIELDS ARE SIGNED INTEGER
2094: * VALUES AND EACH OCCUPY CFP$I WORDS IN THE ARBLK.
2095: *
2096: * THE LENGTH OF AN ARBLK IN BYTES MAY NOT EXCEED MXLEN.
2097: * THIS IS REQUIRED TO KEEP NAME OFFSETS GARBAGE COLLECTABLE
2098: *
2099: * THE ACTUAL VALUES ARE ARRANGED IN ROW-WISE ORDER AND
2100: * CAN CONTAIN A DATA POINTER OR A POINTER TO A TRBLK.
2101: .IF .CNBF
2102: .ELSE
2103: *
2104: * BUFFER CONTROL BLOCK (BCBLK)
2105: *
2106: * A BCBLK IS BUILT FOR EVERY BFBLK.
2107: *
2108: * +------------------------------------+
2109: * I BCTYP I
2110: * +------------------------------------+
2111: * I IDVAL I
2112: * +------------------------------------+
2113: * I BCLEN I
2114: * +------------------------------------+
2115: * I BCBUF I
2116: * +------------------------------------+
2117: *
2118: BCTYP EQU 0 PTR TO DUMMY ROUTINE B$BCT
2119: BCLEN EQU IDVAL+1 DEFINED BUFFER LENGTH
2120: BCBUF EQU BCLEN+1 PTR TO BFBLK
2121: BCSI$ EQU BCBUF+1 SIZE OF BCBLK
2122: *
2123: * A BCBLK IS AN INDIRECT CONTROL HEADER FOR BFBLK.
2124: * THE REASON FOR NOT STORING THIS DATA DIRECTLY
2125: * IN THE RELATED BFBLK IS SO THAT THE BFBLK CAN
2126: * MAINTAIN THE SAME SKELETAL STRUCTURE AS AN SCBLK
2127: * THUS FACILITATING TRANSPARENT STRING OPERATIONS
2128: * (FOR THE MOST PART). SPECIFICALLY, CFP$F IS THE
2129: * SAME FOR A BFBLK AS FOR AN SCBLK. BY CONVENTION,
2130: * WHEREEVER A BUFFER VALUE IS EMPLOYED, THE BCBLK
2131: * IS POINTED TO.
2132: *
2133: * THE CORRESPONDING BFBLK IS POINTED TO BY THE
2134: * BCBUF POINTER IN THE BCBLK.
2135: *
2136: * BCLEN IS THE CURRENT DEFINED SIZE OF THE CHARACTER
2137: * ARRAY IN THE BFBLK. CHARACTERS FOLLOWING THE OFFSET
2138: * OF BCLEN ARE UNDEFINED.
2139: *
2140: EJC
2141: *
2142: * STRING BUFFER BLOCK (BFBLK)
2143: *
2144: * A BFBLK IS BUILT BY A CALL TO BUFFER(...)
2145: *
2146: * +------------------------------------+
2147: * I BFTYP I
2148: * +------------------------------------+
2149: * I BFALC I
2150: * +------------------------------------+
2151: * / /
2152: * / BFCHR /
2153: * / /
2154: * +------------------------------------+
2155: *
2156: BFTYP EQU 0 PTR TO DUMMY ROUTINE B$BFT
2157: BFALC EQU BFTYP+1 ALLOCATED SIZE OF BUFFER
2158: BFCHR EQU BFALC+1 CHARACTERS OF STRING
2159: BFSI$ EQU BFCHR SIZE OF STANDARD FIELDS IN BFBLK
2160: *
2161: * THE CHARACTERS IN THE BUFFER ARE STORED LEFT JUSTIFIED.
2162: * THE FINAL WORD OF DEFINED CHARACTERS IS ALWAYS ZERO
2163: * (CHARACTER) PADDED. ANY TRAILING ALLOCATION PAST THE
2164: * WORD CONTAINING THE LAST CHARACTER CONTAINS
2165: * UNPREDICTABLE CONTENTS AND IS NEVER REFERENCED.
2166: *
2167: * NOTE THAT THE OFFSET TO THE CHARACTERS OF THE STRING
2168: * IS GIVEN BY CFP$F, AS WITH AN SCBLK. HOWEVER, THE
2169: * OFFSET WHICH IS OCCUPIED BY THE LENGTH FOR AN SCBLK
2170: * IS THE TOTAL CHAR SPACE FOR BFBLKS, AND ROUTINES WHICH
2171: * DEAL WITH BOTH MUST ACCOUNT FOR THIS DIFFERENCE.
2172: *
2173: * THE VALUE OF BFALC MAY NOT EXCEED MXLEN. THE VALUE OF
2174: * BCLEN IS ALWAYS LESS THAN OR EQUAL TO BFALC.
2175: *
2176: .FI
2177: EJC
2178: *
2179: * CODE CONSTRUCTION BLOCK (CCBLK)
2180: *
2181: * AT ANY ONE MOMENT THERE IS AT MOST ONE CCBLK INTO
2182: * WHICH THE COMPILER IS CURRENTLY STORING CODE (CDWRD).
2183: *
2184: * +------------------------------------+
2185: * I CCTYP I
2186: * +------------------------------------+
2187: * I CCLEN I
2188: * +------------------------------------+
2189: * I CCUSE I
2190: * +------------------------------------+
2191: * / /
2192: * / CCCOD /
2193: * / /
2194: * +------------------------------------+
2195: *
2196: CCTYP EQU 0 POINTER TO DUMMY ROUTINE B$CCT
2197: CCLEN EQU CCTYP+1 LENGTH OF CCBLK IN BYTES
2198: CCUSE EQU CCLEN+1 OFFSET PAST LAST USED WORD (BYTES)
2199: CCCOD EQU CCUSE+1 START OF GENERATED CODE IN BLOCK
2200: *
2201: * THE REASON THAT THE CCBLK IS A SEPARATE BLOCK TYPE FROM
2202: * THE USUAL CDBLK IS THAT THE GARBAGE COLLECTOR MUST
2203: * ONLY PROCESS THOSE FIELDS WHICH HAVE BEEN SET (SEE GBCPF)
2204: EJC
2205: *
2206: * CODE BLOCK (CDBLK)
2207: *
2208: * A CODE BLOCK IS BUILT FOR EACH STATEMENT COMPILED DURING
2209: * THE INITIAL COMPILATION OR BY SUBSEQUENT CALLS TO CODE.
2210: *
2211: * +------------------------------------+
2212: * I CDJMP I
2213: * +------------------------------------+
2214: * I CDSTM I
2215: * +------------------------------------+
2216: * I CDLEN I
2217: * +------------------------------------+
2218: * I CDFAL I
2219: * +------------------------------------+
2220: * / /
2221: * / CDCOD /
2222: * / /
2223: * +------------------------------------+
2224: *
2225: CDJMP EQU 0 PTR TO ROUTINE TO EXECUTE STATEMENT
2226: CDSTM EQU CDJMP+1 STATEMENT NUMBER
2227: CDLEN EQU OFFS2 LENGTH OF CDBLK IN BYTES
2228: CDFAL EQU OFFS3 FAILURE EXIT (SEE BELOW)
2229: CDCOD EQU CDFAL+1 EXECUTABLE PSEUDO-CODE
2230: CDSI$ EQU CDCOD NUMBER OF STANDARD FIELDS IN CDBLK
2231: *
2232: * CDSTM IS THE STATEMENT NUMBER OF THE CURRENT STATEMENT.
2233: *
2234: * CDJMP, CDFAL ARE SET AS FOLLOWS.
2235: *
2236: * 1) IF THE FAILURE EXIT IS THE NEXT STATEMENT
2237: *
2238: * CDJMP = B$CDS
2239: * CDFAL = PTR TO CDBLK FOR NEXT STATEMENT
2240: *
2241: * 2) IF THE FAILURE EXIT IS A SIMPLE LABEL NAME
2242: *
2243: * CDJMP = B$CDS
2244: * CDFAL IS A PTR TO THE VRTRA FIELD OF THE VRBLK
2245: *
2246: * 3) IF THERE IS NO FAILURE EXIT (-NOFAIL MODE)
2247: *
2248: * CDJMP = B$CDS
2249: * CDFAL = O$UNF
2250: *
2251: * 4) IF THE FAILURE EXIT IS COMPLEX OR DIRECT
2252: *
2253: * CDJMP = B$CDC
2254: * CDFAL IS THE OFFSET TO THE O$GOF WORD
2255: EJC
2256: *
2257: * CODE BLOCK (CONTINUED)
2258: *
2259: * CDCOD IS THE START OF THE ACTUAL CODE. FIRST WE DESCRIBE
2260: * THE CODE GENERATED FOR AN EXPRESSION. IN AN EXPRESSION,
2261: * ELEMENTS ARE FETCHED BY NAME OR BY VALUE. FOR EXAMPLE,
2262: * THE BINARY EQUAL OPERATOR FETCHES ITS LEFT ARGUMENT
2263: * BY NAME AND ITS RIGHT ARGUMENT BY VALUE. THESE TWO
2264: * CASES GENERATE QUITE DIFFERENT CODE AND ARE DESCRIBED
2265: * SEPARATELY. FIRST WE CONSIDER THE CODE BY VALUE CASE.
2266: *
2267: * GENERATION OF CODE BY VALUE FOR EXPRESSIONS ELEMENTS.
2268: *
2269: * EXPRESSION POINTER TO EXBLK OR SEBLK
2270: *
2271: * INTEGER CONSTANT POINTER TO ICBLK
2272: *
2273: * NULL CONSTANT POINTER TO NULLS
2274: *
2275: * PATTERN (RESULTING FROM PREEVALUATION)
2276: * =O$LPT
2277: * POINTER TO P0BLK,P1BLK OR P2BLK
2278: *
2279: * REAL CONSTANT POINTER TO RCBLK
2280: *
2281: * STRING CONSTANT POINTER TO SCBLK
2282: *
2283: * VARIABLE POINTER TO VRGET FIELD OF VRBLK
2284: *
2285: * ADDITION VALUE CODE FOR LEFT OPERAND
2286: * VALUE CODE FOR RIGHT OPERAND
2287: * =O$ADD
2288: *
2289: * AFFIRMATION VALUE CODE FOR OPERAND
2290: * =O$AFF
2291: *
2292: * ALTERNATION VALUE CODE FOR LEFT OPERAND
2293: * VALUE CODE FOR RIGHT OPERAND
2294: * =O$ALT
2295: *
2296: * ARRAY REFERENCE (CASE OF ONE SUBSCRIPT)
2297: * VALUE CODE FOR ARRAY OPERAND
2298: * VALUE CODE FOR SUBSCRIPT OPERAND
2299: * =O$AOV
2300: *
2301: * (CASE OF MORE THAN ONE SUBSCRIPT)
2302: * VALUE CODE FOR ARRAY OPERAND
2303: * VALUE CODE FOR FIRST SUBSCRIPT
2304: * VALUE CODE FOR SECOND SUBSCRIPT
2305: * ...
2306: * VALUE CODE FOR LAST SUBSCRIPT
2307: * =O$AMV
2308: * NUMBER OF SUBSCRIPTS
2309: EJC
2310: *
2311: * CODE BLOCK (CONTINUED)
2312: *
2313: * ASSIGNMENT (TO NATURAL VARIABLE)
2314: * VALUE CODE FOR RIGHT OPERAND
2315: * POINTER TO VRSTO FIELD OF VRBLK
2316: *
2317: * (TO ANY OTHER VARIABLE)
2318: * NAME CODE FOR LEFT OPERAND
2319: * VALUE CODE FOR RIGHT OPERAND
2320: * =O$ASS
2321: *
2322: * COMPILE ERROR =O$CER
2323: *
2324: *
2325: * COMPLEMENTATION VALUE CODE FOR OPERAND
2326: * =O$COM
2327: *
2328: * CONCATENATION (CASE OF PRED FUNC LEFT OPERAND)
2329: * VALUE CODE FOR LEFT OPERAND
2330: * =O$POP
2331: * VALUE CODE FOR RIGHT OPERAND
2332: *
2333: * (ALL OTHER CASES)
2334: * VALUE CODE FOR LEFT OPERAND
2335: * VALUE CODE FOR RIGHT OPERAND
2336: * =O$CNC
2337: *
2338: * CURSOR ASSIGNMENT NAME CODE FOR OPERAND
2339: * =O$CAS
2340: *
2341: * DIVISION VALUE CODE FOR LEFT OPERAND
2342: * VALUE CODE FOR RIGHT OPERAND
2343: * =O$DVD
2344: *
2345: * EXPONENTIATION VALUE CODE FOR LEFT OPERAND
2346: * VALUE CODE FOR RIGHT OPERAND
2347: * =O$EXP
2348: *
2349: * FUNCTION CALL (CASE OF CALL TO SYSTEM FUNCTION)
2350: * VALUE CODE FOR FIRST ARGUMENT
2351: * VALUE CODE FOR SECOND ARGUMENT
2352: * ...
2353: * VALUE CODE FOR LAST ARGUMENT
2354: * POINTER TO SVFNC FIELD OF SVBLK
2355: *
2356: EJC
2357: *
2358: * CODE BLOCK (CONTINUED)
2359: *
2360: * FUNCTION CALL (CASE OF NON-SYSTEM FUNCTION 1 ARG)
2361: * VALUE CODE FOR ARGUMENT
2362: * =O$FNS
2363: * POINTER TO VRBLK FOR FUNCTION
2364: *
2365: * (NON-SYSTEM FUNCTION, GT 1 ARG)
2366: * VALUE CODE FOR FIRST ARGUMENT
2367: * VALUE CODE FOR SECOND ARGUMENT
2368: * ...
2369: * VALUE CODE FOR LAST ARGUMENT
2370: * =O$FNC
2371: * NUMBER OF ARGUMENTS
2372: * POINTER TO VRBLK FOR FUNCTION
2373: *
2374: * IMMEDIATE ASSIGNMENT VALUE CODE FOR LEFT OPERAND
2375: * NAME CODE FOR RIGHT OPERAND
2376: * =O$IMA
2377: *
2378: * INDIRECTION VALUE CODE FOR OPERAND
2379: * =O$INV
2380: *
2381: * INTERROGATION VALUE CODE FOR OPERAND
2382: * =O$INT
2383: *
2384: * KEYWORD REFERENCE NAME CODE FOR OPERAND
2385: * =O$KWV
2386: *
2387: * MULTIPLICATION VALUE CODE FOR LEFT OPERAND
2388: * VALUE CODE FOR RIGHT OPERAND
2389: * =O$MLT
2390: *
2391: * NAME REFERENCE (NATURAL VARIABLE CASE)
2392: * POINTER TO NMBLK FOR NAME
2393: *
2394: * (ALL OTHER CASES)
2395: * NAME CODE FOR OPERAND
2396: * =O$NAM
2397: *
2398: * NEGATION =O$NTA
2399: * CDBLK OFFSET OF O$NTC WORD
2400: * VALUE CODE FOR OPERAND
2401: * =O$NTB
2402: * =O$NTC
2403: EJC
2404: *
2405: * CODE BLOCK (CONTINUED)
2406: *
2407: * PATTERN ASSIGNMENT VALUE CODE FOR LEFT OPERAND
2408: * NAME CODE FOR RIGHT OPERAND
2409: * =O$PAS
2410: *
2411: * PATTERN MATCH VALUE CODE FOR LEFT OPERAND
2412: * VALUE CODE FOR RIGHT OPERAND
2413: * =O$PMV
2414: *
2415: * PATTERN REPLACEMENT NAME CODE FOR SUBJECT
2416: * VALUE CODE FOR PATTERN
2417: * =O$PMN
2418: * VALUE CODE FOR REPLACEMENT
2419: * =O$RPL
2420: *
2421: * SELECTION (FOR FIRST ALTERNATIVE)
2422: * =O$SLA
2423: * CDBLK OFFSET TO NEXT O$SLC WORD
2424: * VALUE CODE FOR FIRST ALTERNATIVE
2425: * =O$SLB
2426: * CDBLK OFFSET PAST ALTERNATIVES
2427: *
2428: * (FOR SUBSEQUENT ALTERNATIVES)
2429: * =O$SLC
2430: * CDBLK OFFSET TO NEXT O$SLC,O$SLD
2431: * VALUE CODE FOR ALTERNATIVE
2432: * =O$SLB
2433: * OFFSET IN CDBLK PAST ALTERNATIVES
2434: *
2435: * (FOR LAST ALTERNATIVE)
2436: * =O$SLD
2437: * VALUE CODE FOR LAST ALTERNATIVE
2438: *
2439: * SUBTRACTION VALUE CODE FOR LEFT OPERAND
2440: * VALUE CODE FOR RIGHT OPERAND
2441: * =O$SUB
2442: EJC
2443: *
2444: * CODE BLOCK (CONTINUED)
2445: *
2446: * GENERATION OF CODE BY NAME FOR EXPRESSION ELEMENTS.
2447: *
2448: * VARIABLE =O$LVN
2449: * POINTER TO VRBLK
2450: *
2451: * EXPRESSION (CASE OF *NATURAL VARIABLE)
2452: * =O$LVN
2453: * POINTER TO VRBLK
2454: *
2455: * (ALL OTHER CASES)
2456: * =O$LEX
2457: * POINTER TO EXBLK
2458: *
2459: *
2460: * ARRAY REFERENCE (CASE OF ONE SUBSCRIPT)
2461: * VALUE CODE FOR ARRAY OPERAND
2462: * VALUE CODE FOR SUBSCRIPT OPERAND
2463: * =O$AON
2464: *
2465: * (CASE OF MORE THAN ONE SUBSCRIPT)
2466: * VALUE CODE FOR ARRAY OPERAND
2467: * VALUE CODE FOR FIRST SUBSCRIPT
2468: * VALUE CODE FOR SECOND SUBSCRIPT
2469: * ...
2470: * VALUE CODE FOR LAST SUBSCRIPT
2471: * =O$AMN
2472: * NUMBER OF SUBSCRIPTS
2473: *
2474: * COMPILE ERROR =O$CER
2475: *
2476: * FUNCTION CALL (SAME CODE AS FOR VALUE CALL)
2477: * =O$FNE
2478: *
2479: * INDIRECTION VALUE CODE FOR OPERAND
2480: * =O$INN
2481: *
2482: * KEYWORD REFERENCE NAME CODE FOR OPERAND
2483: * =O$KWN
2484: *
2485: * ANY OTHER OPERAND IS AN ERROR IN A NAME POSITION
2486: *
2487: * NOTE THAT IN THIS DESCRIPTION, =O$XXX REFERS TO THE
2488: * GENERATION OF A WORD CONTAINING THE ADDRESS OF ANOTHER
2489: * WORD WHICH CONTAINS THE ENTRY POINT ADDRESS O$XXX.
2490: EJC
2491: *
2492: * CODE BLOCK (CONTINUED)
2493: *
2494: * NOW WE CONSIDER THE OVERALL STRUCTURE OF THE CODE BLOCK
2495: * FOR A STATEMENT WITH POSSIBLE GOTO FIELDS.
2496: *
2497: * FIRST COMES THE CODE FOR THE STATEMENT BODY.
2498: * THE STATEMENT BODY IS AN EXPRESSION TO BE EVALUATED
2499: * BY VALUE ALTHOUGH THE VALUE IS NOT ACTUALLY REQUIRED.
2500: * NORMAL VALUE CODE IS GENERATED FOR THE BODY OF THE
2501: * STATEMENT EXCEPT IN THE CASE OF A PATTERN MATCH BY
2502: * VALUE, IN WHICH CASE THE FOLLOWING IS GENERATED.
2503: *
2504: * VALUE CODE FOR LEFT OPERAND
2505: * VALUE CODE FOR RIGHT OPERAND
2506: * =O$PMS
2507: *
2508: * NEXT WE HAVE THE CODE FOR THE SUCCESS GOTO. THERE ARE
2509: * SEVERAL CASES AS FOLLOWS.
2510: *
2511: * 1) NO SUCCESS GOTO PTR TO CDBLK FOR NEXT STATEMENT
2512: *
2513: * 2) SIMPLE LABEL PTR TO VRTRA FIELD OF VRBLK
2514: *
2515: * 3) COMPLEX GOTO (CODE BY NAME FOR GOTO OPERAND)
2516: * =O$GOC
2517: *
2518: * 4) DIRECT GOTO (CODE BY VALUE FOR GOTO OPERAND)
2519: * =O$GOD
2520: *
2521: * FOLLOWING THIS WE GENERATE CODE FOR THE FAILURE GOTO IF
2522: * IT IS DIRECT OR IF IT IS COMPLEX, SIMPLE FAILURE GOTOS
2523: * HAVING BEEN HANDLED BY AN APPROPRIATE SETTING OF THE
2524: * CDFAL FIELD OF THE CDBLK. THE GENERATED CODE IS ONE
2525: * OF THE FOLLOWING.
2526: *
2527: * 1) COMPLEX FGOTO =O$FIF
2528: * =O$GOF
2529: * NAME CODE FOR GOTO OPERAND
2530: * =O$GOC
2531: *
2532: * 2) DIRECT FGOTO =O$FIF
2533: * =O$GOF
2534: * VALUE CODE FOR GOTO OPERAND
2535: * =O$GOD
2536: *
2537: * AN OPTIMIZATION OCCURS IF THE SUCCESS AND FAILURE GOTOS
2538: * ARE IDENTICAL AND EITHER COMPLEX OR DIRECT. IN THIS CASE,
2539: * NO CODE IS GENERATED FOR THE SUCCESS GOTO AND CONTROL
2540: * IS ALLOWED TO FALL INTO THE FAILURE GOTO ON SUCCESS.
2541: EJC
2542: *
2543: * COMPILER BLOCK (CMBLK)
2544: *
2545: * A COMPILER BLOCK (CMBLK) IS BUILT BY EXPAN TO REPRESENT
2546: * ONE NODE OF A TREE STRUCTURED EXPRESSION REPRESENTATION.
2547: *
2548: * +------------------------------------+
2549: * I CMIDN I
2550: * +------------------------------------+
2551: * I CMLEN I
2552: * +------------------------------------+
2553: * I CMTYP I
2554: * +------------------------------------+
2555: * I CMOPN I
2556: * +------------------------------------+
2557: * / CMVLS OR CMROP /
2558: * / /
2559: * / CMLOP /
2560: * / /
2561: * +------------------------------------+
2562: *
2563: CMIDN EQU 0 POINTER TO DUMMY ROUTINE B$CMT
2564: CMLEN EQU CMIDN+1 LENGTH OF CMBLK IN BYTES
2565: CMTYP EQU CMLEN+1 TYPE (C$XXX, SEE LIST BELOW)
2566: CMOPN EQU CMTYP+1 OPERAND POINTER (SEE BELOW)
2567: CMVLS EQU CMOPN+1 OPERAND VALUE POINTERS (SEE BELOW)
2568: CMROP EQU CMVLS RIGHT (ONLY) OPERATOR OPERAND
2569: CMLOP EQU CMVLS+1 LEFT OPERATOR OPERAND
2570: CMSI$ EQU CMVLS NUMBER OF STANDARD FIELDS IN CMBLK
2571: CMUS$ EQU CMSI$+1 SIZE OF UNARY OPERATOR CMBLK
2572: CMBS$ EQU CMSI$+2 SIZE OF BINARY OPERATOR CMBLK
2573: CMAR1 EQU CMVLS+1 ARRAY SUBSCRIPT POINTERS
2574: *
2575: * THE CMOPN AND CMVLS FIELDS ARE SET AS FOLLOWS
2576: *
2577: * ARRAY REFERENCE CMOPN = PTR TO ARRAY OPERAND
2578: * CMVLS = PTRS TO SUBSCRIPT OPERANDS
2579: *
2580: * FUNCTION CALL CMOPN = PTR TO VRBLK FOR FUNCTION
2581: * CMVLS = PTRS TO ARGUMENT OPERANDS
2582: *
2583: * SELECTION CMOPN = ZERO
2584: * CMVLS = PTRS TO ALTERNATE OPERANDS
2585: *
2586: * UNARY OPERATOR CMOPN = PTR TO OPERATOR DVBLK
2587: * CMROP = PTR TO OPERAND
2588: *
2589: * BINARY OPERATOR CMOPN = PTR TO OPERATOR DVBLK
2590: * CMROP = PTR TO RIGHT OPERAND
2591: * CMLOP = PTR TO LEFT OPERAND
2592: EJC
2593: *
2594: * CMTYP IS SET TO INDICATE THE TYPE OF EXPRESSION ELEMENT
2595: * AS SHOWN BY THE FOLLOWING TABLE OF DEFINITIONS.
2596: *
2597: C$ARR EQU 0 ARRAY REFERENCE
2598: C$FNC EQU C$ARR+1 FUNCTION CALL
2599: C$DEF EQU C$FNC+1 DEFERRED EXPRESSION (UNARY *)
2600: C$IND EQU C$DEF+1 INDIRECTION (UNARY $)
2601: C$KEY EQU C$IND+1 KEYWORD REFERENCE (UNARY AMPERSAND)
2602: C$UBO EQU C$KEY+1 UNDEFINED BINARY OPERATOR
2603: C$UUO EQU C$UBO+1 UNDEFINED UNARY OPERATOR
2604: C$UO$ EQU C$UUO+1 TEST VALUE (=C$UUO+1=C$UBO+2)
2605: C$$NM EQU C$UUO+1 NUMBER OF CODES FOR NAME OPERANDS
2606: *
2607: * THE REMAINING TYPES INDICATE EXPRESSION ELEMENTS WHICH
2608: * CAN ONLY BE EVALUATED BY VALUE (NOT BY NAME).
2609: *
2610: C$BVL EQU C$UUO+1 BINARY OP WITH VALUE OPERANDS
2611: C$UVL EQU C$BVL+1 UNARY OPERATOR WITH VALUE OPERAND
2612: C$ALT EQU C$UVL+1 ALTERNATION (BINARY BAR)
2613: C$CNC EQU C$ALT+1 CONCATENATION
2614: C$CNP EQU C$CNC+1 CONCATENATION, NOT PATTERN MATCH
2615: C$UNM EQU C$CNP+1 UNARY OP WITH NAME OPERAND
2616: C$BVN EQU C$UNM+1 BINARY OP (OPERANDS BY VALUE, NAME)
2617: C$ASS EQU C$BVN+1 ASSIGNMENT
2618: C$INT EQU C$ASS+1 INTERROGATION
2619: C$NEG EQU C$INT+1 NEGATION (UNARY NOT)
2620: C$SEL EQU C$NEG+1 SELECTION
2621: C$PMT EQU C$SEL+1 PATTERN MATCH
2622: *
2623: C$PR$ EQU C$BVN LAST PREEVALUABLE CODE
2624: C$$NV EQU C$PMT+1 NUMBER OF DIFFERENT CMBLK TYPES
2625: EJC
2626: *
2627: * CHARACTER TABLE BLOCK (CTBLK)
2628: *
2629: * A CHARACTER TABLE BLOCK IS USED TO HOLD LOGICAL CHARACTER
2630: * TABLES FOR USE WITH ANY,NOTANY,SPAN,BREAK,BREAKX
2631: * PATTERNS. EACH CHARACTER TABLE CAN BE USED TO STORE
2632: * CFP$N DISTINCT TABLES AS BIT COLUMNS. A BIT COLUMN
2633: * ALLOCATED FOR EACH ARGUMENT OF MORE THAN ONE CHARACTER
2634: * IN LENGTH TO ONE OF THE ABOVE LISTED PATTERN PRIMITIVES.
2635: *
2636: * +------------------------------------+
2637: * I CTTYP I
2638: * +------------------------------------+
2639: * * *
2640: * * *
2641: * * CTCHS *
2642: * * *
2643: * * *
2644: * +------------------------------------+
2645: *
2646: CTTYP EQU 0 POINTER TO DUMMY ROUTINE B$CTT
2647: CTCHS EQU CTTYP+1 START OF CHARACTER TABLE WORDS
2648: CTSI$ EQU CTCHS+CFP$A NUMBER OF WORDS IN CTBLK
2649: *
2650: * CTCHS IS CFP$A WORDS LONG AND CONSISTS OF A ONE WORD
2651: * BIT STRING VALUE FOR EACH POSSIBLE CHARACTER IN THE
2652: * INTERNAL ALPHABET. EACH OF THE CFP$N POSSIBLE BITS IN
2653: * A BITSTRING IS USED TO FORM A COLUMN OF BIT INDICATORS.
2654: * A BIT IS SET ON IF THE CHARACTER IS IN THE TABLE AND OFF
2655: * IF THE CHARACTER IS NOT PRESENT.
2656: EJC
2657: *
2658: * DATATYPE FUNCTION BLOCK (DFBLK)
2659: *
2660: * A DATATYPE FUNCTION IS USED TO CONTROL THE CONSTRUCTION
2661: * OF A PROGRAM DEFINED DATATYPE OBJECT. A CALL TO THE
2662: * SYSTEM FUNCTION DATA BUILDS A DFBLK FOR THE DATATYPE NAME
2663: *
2664: * NOTE THAT THESE BLOCKS ARE BUILT IN STATIC BECAUSE PDBLK
2665: * LENGTH IS GOT FROM DFLEN FIELD. IF DFBLK WAS IN DYNAMIC
2666: * STORE THIS WOULD CAUSE TROUBLE DURING PASS TWO OF GARBAGE
2667: * COLLECTION. SCBLK REFERRED TO BY DFNAM FIELD IS ALSO PUT
2668: * IN STATIC SO THAT THERE ARE NO RELOC. FIELDS. THIS CUTS
2669: * GARBAGE COLLECTION TASK APPRECIABLY FOR PDBLKS WHICH ARE
2670: * LIKELY TO BE PRESENT IN LARGE NUMBERS.
2671: *
2672: * +------------------------------------+
2673: * I FCODE I
2674: * +------------------------------------+
2675: * I FARGS I
2676: * +------------------------------------+
2677: * I DFLEN I
2678: * +------------------------------------+
2679: * I DFPDL I
2680: * +------------------------------------+
2681: * I DFNAM I
2682: * +------------------------------------+
2683: * / /
2684: * / DFFLD /
2685: * / /
2686: * +------------------------------------+
2687: *
2688: DFLEN EQU FARGS+1 LENGTH OF DFBLK IN BYTES
2689: DFPDL EQU DFLEN+1 LENGTH OF CORRESPONDING PDBLK
2690: DFNAM EQU DFPDL+1 POINTER TO SCBLK FOR DATATYPE NAME
2691: DFFLD EQU DFNAM+1 START OF VRBLK PTRS FOR FIELD NAMES
2692: DFFLB EQU DFFLD-1 OFFSET BEHIND DFFLD FOR FIELD FUNC
2693: DFSI$ EQU DFFLD NUMBER OF STANDARD FIELDS IN DFBLK
2694: *
2695: * THE FCODE FIELD POINTS TO THE ROUTINE B$DFC
2696: *
2697: * FARGS (THE NUMBER OF ARGUMENTS) IS THE NUMBER OF FIELDS.
2698: EJC
2699: *
2700: * DOPE VECTOR BLOCK (DVBLK)
2701: *
2702: * A DOPE VECTOR IS ASSEMBLED FOR EACH POSSIBLE OPERATOR IN
2703: * THE SNOBOL4 LANGUAGE AS PART OF THE CONSTANT SECTION.
2704: *
2705: * +------------------------------------+
2706: * I DVOPN I
2707: * +------------------------------------+
2708: * I DVTYP I
2709: * +------------------------------------+
2710: * I DVLPR I
2711: * +------------------------------------+
2712: * I DVRPR I
2713: * +------------------------------------+
2714: *
2715: DVOPN EQU 0 ENTRY ADDRESS (PTR TO O$XXX)
2716: DVTYP EQU DVOPN+1 TYPE CODE (C$XXX, SEE CMBLK)
2717: DVLPR EQU DVTYP+1 LEFT PRECEDENCE (LLXXX, SEE BELOW)
2718: DVRPR EQU DVLPR+1 RIGHT PRECEDENCE (RRXXX, SEE BELOW)
2719: DVUS$ EQU DVLPR+1 SIZE OF UNARY OPERATOR DV
2720: DVBS$ EQU DVRPR+1 SIZE OF BINARY OPERATOR DV
2721: DVUBS EQU DVUS$+DVBS$ SIZE OF UNOP + BINOP (SEE SCANE)
2722: *
2723: * THE CONTENTS OF THE DVTYP FIELD IS COPIED INTO THE CMTYP
2724: * FIELD OF THE CMBLK FOR THE OPERATOR IF IT IS USED.
2725: *
2726: * THE CMOPN FIELD OF AN OPERATOR CMBLK POINTS TO THE DVBLK
2727: * ITSELF, PROVIDING THE REQUIRED ENTRY ADDRESS POINTER PTR.
2728: *
2729: * FOR NORMALLY UNDEFINED OPERATORS, THE DVOPN (AND CMOPN)
2730: * FIELDS CONTAIN A WORD OFFSET FROM R$UBA OF THE FUNCTION
2731: * BLOCK POINTER FOR THE OPERATOR (INSTEAD OF O$XXX PTR).
2732: * FOR CERTAIN SPECIAL OPERATORS, THE DVOPN FIELD IS NOT
2733: * REQUIRED AT ALL AND IS ASSEMBLED AS ZERO.
2734: *
2735: * THE LEFT PRECEDENCE IS USED IN COMPARING AN OPERATOR TO
2736: * THE LEFT OF SOME OTHER OPERATOR. IT THEREFORE GOVERNS THE
2737: * PRECEDENCE OF THE OPERATOR TOWARDS ITS RIGHT OPERAND.
2738: *
2739: * THE RIGHT PRECEDENCE IS USED IN COMPARING AN OPERATOR TO
2740: * THE RIGHT OF SOME OTHER OPERATOR. IT THEREFORE GOVERNS
2741: * THE PRECEDENCE OF THE OPERATOR TOWARDS ITS LEFT OPERAND.
2742: *
2743: * HIGHER PRECEDENCE VALUES CORRESPOND TO A TIGHTER BINDING
2744: * CAPABILITY. THUS WE HAVE THE LEFT PRECEDENCE LOWER
2745: * (HIGHER) THAN THE RIGHT PRECEDENCE FOR RIGHT (LEFT)
2746: * ASSOCIATIVE BINARY OPERATORS.
2747: *
2748: * THE LEFT PRECEDENCE OF UNARY OPERATORS IS SET TO AN
2749: * ARBITRARY HIGH VALUE. THE RIGHT VALUE IS NOT REQUIRED AND
2750: * CONSEQUENTLY THE DVRPR FIELD IS OMITTED FOR UNARY OPS.
2751: EJC
2752: *
2753: * TABLE OF OPERATOR PRECEDENCE VALUES
2754: *
2755: RRASS EQU 10 RIGHT EQUAL
2756: LLASS EQU 00 LEFT EQUAL
2757: RRPMT EQU 20 RIGHT QUESTION MARK
2758: LLPMT EQU 30 LEFT QUESTION MARK
2759: RRAMP EQU 40 RIGHT AMPERSAND
2760: LLAMP EQU 50 LEFT AMPERSAND
2761: RRALT EQU 70 RIGHT VERTICAL BAR
2762: LLALT EQU 60 LEFT VERTICAL BAR
2763: RRCNC EQU 90 RIGHT BLANK
2764: LLCNC EQU 80 LEFT BLANK
2765: RRATS EQU 110 RIGHT AT
2766: LLATS EQU 100 LEFT AT
2767: RRPLM EQU 120 RIGHT PLUS, MINUS
2768: LLPLM EQU 130 LEFT PLUS, MINUS
2769: RRNUM EQU 140 RIGHT NUMBER
2770: LLNUM EQU 150 LEFT NUMBER
2771: RRDVD EQU 160 RIGHT SLASH
2772: LLDVD EQU 170 LEFT SLASH
2773: RRMLT EQU 180 RIGHT ASTERISK
2774: LLMLT EQU 190 LEFT ASTERISK
2775: RRPCT EQU 200 RIGHT PERCENT
2776: LLPCT EQU 210 LEFT PERCENT
2777: RREXP EQU 230 RIGHT EXCLAMATION
2778: LLEXP EQU 220 LEFT EXCLAMATION
2779: RRDLD EQU 240 RIGHT DOLLAR, DOT
2780: LLDLD EQU 250 LEFT DOLLAR, DOT
2781: RRNOT EQU 270 RIGHT NOT
2782: LLNOT EQU 260 LEFT NOT
2783: LLUNO EQU 999 LEFT ALL UNARY OPERATORS
2784: *
2785: * PRECEDENCES ARE THE SAME AS IN BTL SNOBOL4 WITH THE
2786: * FOLLOWING EXCEPTIONS.
2787: *
2788: * 1) BINARY QUESTION MARK IS LOWERED AND MADE LEFT ASSOC-
2789: * IATIVE TO REFLECT ITS NEW USE FOR PATTERN MATCHING.
2790: *
2791: * 2) ALTERNATION AND CONCATENATION ARE MADE RIGHT
2792: * ASSOCIATIVE FOR GREATER EFFICIENCY IN PATTERN
2793: * CONSTRUCTION AND MATCHING RESPECTIVELY. THIS CHANGE
2794: * IS TRANSPARENT TO THE SNOBOL4 PROGRAMMER.
2795: *
2796: * 3) THE EQUAL SIGN HAS BEEN ADDED AS A LOW PRECEDENCE
2797: * OPERATOR WHICH IS RIGHT ASSOCIATIVE TO REFLECT ITS
2798: * MORE GENERAL USAGE IN THIS VERSION OF SNOBOL4.
2799: EJC
2800: *
2801: * EXTERNAL FUNCTION BLOCK (EFBLK)
2802: *
2803: * AN EXTERNAL FUNCTION BLOCK IS USED TO CONTROL THE CALLING
2804: * OF AN EXTERNAL FUNCTION. IT IS BUILT BY A CALL TO LOAD.
2805: *
2806: * +------------------------------------+
2807: * I FCODE I
2808: * +------------------------------------+
2809: * I FARGS I
2810: * +------------------------------------+
2811: * I EFLEN I
2812: * +------------------------------------+
2813: * I EFUSE I
2814: * +------------------------------------+
2815: * I EFCOD I
2816: * +------------------------------------+
2817: * I EFVAR I
2818: * +------------------------------------+
2819: * I EFRSL I
2820: * +------------------------------------+
2821: * / /
2822: * / EFTAR /
2823: * / /
2824: * +------------------------------------+
2825: *
2826: EFLEN EQU FARGS+1 LENGTH OF EFBLK IN BYTES
2827: EFUSE EQU EFLEN+1 USE COUNT (FOR OPSYN)
2828: EFCOD EQU EFUSE+1 PTR TO CODE (FROM SYSLD)
2829: EFVAR EQU EFCOD+1 PTR TO ASSOCIATED VRBLK
2830: EFRSL EQU EFVAR+1 RESULT TYPE (SEE BELOW)
2831: EFTAR EQU EFRSL+1 ARGUMENT TYPES (SEE BELOW)
2832: EFSI$ EQU EFTAR NUMBER OF STANDARD FIELDS IN EFBLK
2833: *
2834: * THE FCODE FIELD POINTS TO THE ROUTINE B$EFC.
2835: *
2836: * EFUSE IS USED TO KEEP TRACK OF MULTIPLE USE WHEN OPSYN
2837: * IS EMPLOYED. THE FUNCTION IS AUTOMATICALLY UNLOADED
2838: * WHEN THERE ARE NO MORE REFERENCES TO THE FUNCTION.
2839: *
2840: * EFRSL AND EFTAR ARE TYPE CODES AS FOLLOWS.
2841: *
2842: * 0 TYPE IS UNCONVERTED
2843: * 1 TYPE IS STRING
2844: * 2 TYPE IS INTEGER
2845: * 3 TYPE IS REAL
2846: EJC
2847: *
2848: * EXPRESSION VARIABLE BLOCK (EVBLK)
2849: *
2850: * IN THIS VERSION OF SPITBOL, AN EXPRESSION CAN BE USED IN
2851: * ANY POSITION WHICH WOULD NORMALLY EXPECT A NAME (FOR
2852: * EXAMPLE ON THE LEFT SIDE OF EQUALS OR AS THE RIGHT
2853: * ARGUMENT OF BINARY DOT). THIS CORRESPONDS TO THE CREATION
2854: * OF A PSEUDO-VARIABLE WHICH IS REPRESENTED BY A POINTER TO
2855: * AN EXPRESSION VARIABLE BLOCK AS FOLLOWS.
2856: *
2857: * +------------------------------------+
2858: * I EVTYP I
2859: * +------------------------------------+
2860: * I EVEXP I
2861: * +------------------------------------+
2862: * I EVVAR I
2863: * +------------------------------------+
2864: *
2865: EVTYP EQU 0 POINTER TO DUMMY ROUTINE B$EVT
2866: EVEXP EQU EVTYP+1 POINTER TO EXBLK FOR EXPRESSION
2867: EVVAR EQU EVEXP+1 POINTER TO TRBEV DUMMY TRBLK
2868: EVSI$ EQU EVVAR+1 SIZE OF EVBLK
2869: *
2870: * THE NAME OF AN EXPRESSION VARIABLE IS REPRESENTED BY A
2871: * BASE POINTER TO THE EVBLK AND AN OFFSET OF EVVAR. THIS
2872: * VALUE APPEARS TO BE TRAPPED BY THE DUMMY TRBEV BLOCK.
2873: *
2874: * NOTE THAT THERE IS NO NEED TO ALLOW FOR THE CASE OF AN
2875: * EXPRESSION VARIABLE WHICH REFERENCES AN SEBLK SINCE A
2876: * VARIABLE WHICH IS OF THE FORM *VAR IS EQUIVALENT TO VAR.
2877: EJC
2878: *
2879: * EXPRESSION BLOCK (EXBLK)
2880: *
2881: * AN EXPRESSION BLOCK IS BUILT FOR EACH EXPRESSION
2882: * REFERENCED IN A PROGRAM OR CREATED BY EVAL OR CONVERT
2883: * DURING EXECUTION OF A PROGRAM.
2884: *
2885: * +------------------------------------+
2886: * I EXTYP I
2887: * +------------------------------------+
2888: * I EXSTM I
2889: * +------------------------------------+
2890: * I EXLEN I
2891: * +------------------------------------+
2892: * I EXFLC I
2893: * +------------------------------------+
2894: * / /
2895: * / EXCOD /
2896: * / /
2897: * +------------------------------------+
2898: *
2899: EXTYP EQU 0 PTR TO ROUTINE B$EXL TO LOAD EXPR
2900: EXSTM EQU CDSTM STORES STMNT NO. DURING EVALUATION
2901: EXLEN EQU EXSTM+1 LENGTH OF EXBLK IN BYTES
2902: EXFLC EQU EXLEN+1 FAILURE CODE (=O$FEX)
2903: EXCOD EQU EXFLC+1 PSEUDO-CODE FOR EXPRESSION
2904: EXSI$ EQU EXCOD NUMBER OF STANDARD FIELDS IN EXBLK
2905: *
2906: * THERE ARE TWO CASES FOR EXCOD DEPENDING ON WHETHER THE
2907: * EXPRESSION CAN BE EVALUATED BY NAME (SEE DESCRIPTION
2908: * OF CDBLK FOR DETAILS OF CODE FOR EXPRESSIONS).
2909: *
2910: * IF THE EXPRESSION CAN BE EVALUATED BY NAME WE HAVE.
2911: *
2912: * (CODE FOR EXPR BY NAME)
2913: * =O$RNM
2914: *
2915: * IF THE EXPRESSION CAN ONLY BE EVALUATED BY VALUE.
2916: *
2917: * (CODE FOR EXPR BY VALUE)
2918: * =O$RVL
2919: EJC
2920: *
2921: * FIELD FUNCTION BLOCK (FFBLK)
2922: *
2923: * A FIELD FUNCTION BLOCK IS USED TO CONTROL THE SELECTION
2924: * OF A FIELD FROM A PROGRAM DEFINED DATATYPE BLOCK.
2925: * A CALL TO DATA CREATES AN FFBLK FOR EACH FIELD.
2926: *
2927: * +------------------------------------+
2928: * I FCODE I
2929: * +------------------------------------+
2930: * I FARGS I
2931: * +------------------------------------+
2932: * I FFDFP I
2933: * +------------------------------------+
2934: * I FFNXT I
2935: * +------------------------------------+
2936: * I FFOFS I
2937: * +------------------------------------+
2938: *
2939: FFDFP EQU FARGS+1 POINTER TO ASSOCIATED DFBLK
2940: FFNXT EQU FFDFP+1 PTR TO NEXT FFBLK ON CHAIN OR ZERO
2941: FFOFS EQU FFNXT+1 OFFSET (BYTES) TO FIELD IN PDBLK
2942: FFSI$ EQU FFOFS+1 SIZE OF FFBLK IN WORDS
2943: *
2944: * THE FCODE FIELD POINTS TO THE ROUTINE B$FFC.
2945: *
2946: * FARGS ALWAYS CONTAINS ONE.
2947: *
2948: * FFDFP IS USED TO VERIFY THAT THE CORRECT PROGRAM DEFINED
2949: * DATATYPE IS BEING ACCESSED BY THIS CALL.
2950: * FFDFP IS NON-RELOC. BECAUSE DFBLK IS IN STATIC
2951: *
2952: * FFOFS IS USED TO SELECT THE APPROPRIATE FIELD. NOTE THAT
2953: * IT IS AN ACTUAL OFFSET (NOT A FIELD NUMBER)
2954: *
2955: * FFNXT IS USED TO POINT TO THE NEXT FFBLK OF THE SAME NAME
2956: * IN THE CASE WHERE THERE ARE SEVERAL FIELDS OF THE SAME
2957: * NAME FOR DIFFERENT DATATYPES. ZERO MARKS THE END OF CHAIN
2958: EJC
2959: *
2960: * INTEGER CONSTANT BLOCK (ICBLK)
2961: *
2962: * AN ICBLK IS CREATED FOR EVERY INTEGER REFERENCED OR
2963: * CREATED BY A PROGRAM. NOTE HOWEVER THAT CERTAIN INTERNAL
2964: * INTEGER VALUES ARE STORED AS ADDRESSES (E.G. THE LENGTH
2965: * FIELD IN A STRING CONSTANT BLOCK)
2966: *
2967: * +------------------------------------+
2968: * I ICGET I
2969: * +------------------------------------+
2970: * * ICVAL *
2971: * +------------------------------------+
2972: *
2973: ICGET EQU 0 PTR TO ROUTINE B$ICL TO LOAD INT
2974: ICVAL EQU ICGET+1 INTEGER VALUE
2975: ICSI$ EQU ICVAL+CFP$I SIZE OF ICBLK
2976: *
2977: * THE LENGTH OF THE ICVAL FIELD IS CFP$I.
2978: EJC
2979: *
2980: * KEYWORD VARIABLE BLOCK (KVBLK)
2981: *
2982: * A KVBLK IS USED TO REPRESENT A KEYWORD PSEUDO-VARIABLE.
2983: * A KVBLK IS BUILT FOR EACH KEYWORD REFERENCE (KWNAM).
2984: *
2985: * +------------------------------------+
2986: * I KVTYP I
2987: * +------------------------------------+
2988: * I KVVAR I
2989: * +------------------------------------+
2990: * I KVNUM I
2991: * +------------------------------------+
2992: *
2993: KVTYP EQU 0 POINTER TO DUMMY ROUTINE B$KVT
2994: KVVAR EQU KVTYP+1 POINTER TO DUMMY BLOCK TRBKV
2995: KVNUM EQU KVVAR+1 KEYWORD NUMBER
2996: KVSI$ EQU KVNUM+1 SIZE OF KVBLK
2997: *
2998: * THE NAME OF A KEYWORD VARIABLE IS REPRESENTED BY A
2999: * BASE POINTER TO THE KVBLK AND AN OFFSET OF KVVAR. THE
3000: * VALUE APPEARS TO BE TRAPPED BY THE POINTER TO TRBKV.
3001: EJC
3002: *
3003: * NAME BLOCK (NMBLK)
3004: *
3005: * A NAME BLOCK IS USED WHEREVER A NAME MUST BE STORED AS
3006: * A VALUE FOLLOWING USE OF THE UNARY DOT OPERATOR.
3007: *
3008: * +------------------------------------+
3009: * I NMTYP I
3010: * +------------------------------------+
3011: * I NMBAS I
3012: * +------------------------------------+
3013: * I NMOFS I
3014: * +------------------------------------+
3015: *
3016: NMTYP EQU 0 PTR TO ROUTINE B$NML TO LOAD NAME
3017: NMBAS EQU NMTYP+1 BASE POINTER FOR VARIABLE
3018: NMOFS EQU NMBAS+1 OFFSET FOR VARIABLE
3019: NMSI$ EQU NMOFS+1 SIZE OF NMBLK
3020: *
3021: * THE ACTUAL FIELD REPRESENTING THE CONTENTS OF THE NAME
3022: * IS FOUND NMOFS BYTES PAST THE ADDRESS IN NMBAS.
3023: *
3024: * THE NAME IS SPLIT INTO BASE AND OFFSET FORM TO AVOID
3025: * CREATION OF A POINTER INTO THE MIDDLE OF A BLOCK WHICH
3026: * COULD NOT BE HANDLED PROPERLY BY THE GARBAGE COLLECTOR.
3027: *
3028: * A NAME MAY BE BUILT FOR ANY VARIABLE (SEE SECTION ON
3029: * REPRESENTATIONS OF VARIABLES) THIS INCLUDES THE
3030: * CASES OF PSEUDO-VARIABLES.
3031: EJC
3032: *
3033: * PATTERN BLOCK, NO PARAMETERS (P0BLK)
3034: *
3035: * A P0BLK IS USED TO REPRESENT PATTERN NODES WHICH DO
3036: * NOT REQUIRE THE USE OF ANY PARAMETER VALUES.
3037: *
3038: * +------------------------------------+
3039: * I PCODE I
3040: * +------------------------------------+
3041: * I PTHEN I
3042: * +------------------------------------+
3043: *
3044: PCODE EQU 0 PTR TO MATCH ROUTINE (P$XXX)
3045: PTHEN EQU PCODE+1 POINTER TO SUBSEQUENT NODE
3046: PASI$ EQU PTHEN+1 SIZE OF P0BLK
3047: *
3048: * PTHEN POINTS TO THE PATTERN BLOCK FOR THE SUBSEQUENT
3049: * NODE TO BE MATCHED. THIS IS A POINTER TO THE PATTERN
3050: * BLOCK NDNTH IF THERE IS NO SUBSEQUENT (END OF PATTERN)
3051: *
3052: * PCODE IS A POINTER TO THE MATCH ROUTINE FOR THE NODE.
3053: EJC
3054: *
3055: * PATTERN BLOCK (ONE PARAMETER)
3056: *
3057: * A P1BLK IS USED TO REPRESENT PATTERN NODES WHICH
3058: * REQUIRE ONE PARAMETER VALUE.
3059: *
3060: * +------------------------------------+
3061: * I PCODE I
3062: * +------------------------------------+
3063: * I PTHEN I
3064: * +------------------------------------+
3065: * I PARM1 I
3066: * +------------------------------------+
3067: *
3068: PARM1 EQU PTHEN+1 FIRST PARAMETER VALUE
3069: PBSI$ EQU PARM1+1 SIZE OF P1BLK IN WORDS
3070: *
3071: * SEE P0BLK FOR DEFINITIONS OF PCODE, PTHEN
3072: *
3073: * PARM1 CONTAINS A PARAMETER VALUE USED IN MATCHING THE
3074: * NODE. FOR EXAMPLE, IN A LEN PATTERN, IT IS THE INTEGER
3075: * ARGUMENT TO LEN. THE DETAILS OF THE USE OF THE PARAMETER
3076: * FIELD ARE INCLUDED IN THE DESCRIPTION OF THE INDIVIDUAL
3077: * MATCH ROUTINES. PARM1 IS ALWAYS AN ADDRESS POINTER WHICH
3078: * IS PROCESSED BY THE GARBAGE COLLECTOR.
3079: EJC
3080: *
3081: * PATTERN BLOCK (TWO PARAMETERS)
3082: *
3083: * A P2BLK IS USED TO REPRESENT PATTERN NODES WHICH
3084: * REQUIRE TWO PARAMETER VALUES.
3085: *
3086: * +------------------------------------+
3087: * I PCODE I
3088: * +------------------------------------+
3089: * I PTHEN I
3090: * +------------------------------------+
3091: * I PARM1 I
3092: * +------------------------------------+
3093: * I PARM2 I
3094: * +------------------------------------+
3095: *
3096: PARM2 EQU PARM1+1 SECOND PARAMETER VALUE
3097: PCSI$ EQU PARM2+1 SIZE OF P2BLK IN WORDS
3098: *
3099: * SEE P1BLK FOR DEFINITIONS OF PCODE, PTHEN, PARM1
3100: *
3101: * PARM2 IS A PARAMETER WHICH PERFORMS THE SAME SORT OF
3102: * FUNCTION AS PARM1 (SEE DESCRIPTION OF P1BLK).
3103: *
3104: * PARM2 IS A NON-RELOCATABLE FIELD AND IS NOT
3105: * PROCESSED BY THE GARBAGE COLLECTOR. ACCORDINGLY, IT MAY
3106: * NOT CONTAIN A POINTER TO A BLOCK IN DYNAMIC MEMORY.
3107: EJC
3108: *
3109: * PROGRAM-DEFINED DATATYPE BLOCK
3110: *
3111: * A PDBLK REPRESENTS THE DATA ITEM FORMED BY A CALL TO A
3112: * DATATYPE FUNCTION AS DEFINED BY THE SYSTEM FUNCTION DATA.
3113: *
3114: * +------------------------------------+
3115: * I PDTYP I
3116: * +------------------------------------+
3117: * I IDVAL I
3118: * +------------------------------------+
3119: * I PDDFP I
3120: * +------------------------------------+
3121: * / /
3122: * / PDFLD /
3123: * / /
3124: * +------------------------------------+
3125: *
3126: PDTYP EQU 0 PTR TO DUMMY ROUTINE B$PDT
3127: PDDFP EQU IDVAL+1 PTR TO ASSOCIATED DFBLK
3128: PDFLD EQU PDDFP+1 START OF FIELD VALUE POINTERS
3129: PDFOF EQU DFFLD-PDFLD DIFFERENCE IN OFFSET TO FIELD PTRS
3130: PDSI$ EQU PDFLD SIZE OF STANDARD FIELDS IN PDBLK
3131: PDDFS EQU DFSI$-PDSI$ DIFFERENCE IN DFBLK, PDBLK SIZES
3132: *
3133: * THE PDDFP POINTER MAY BE USED TO DETERMINE THE DATATYPE
3134: * AND THE NAMES OF THE FIELDS IF REQUIRED. THE DFBLK ALSO
3135: * CONTAINS THE LENGTH OF THE PDBLK IN BYTES (FIELD DFPDL).
3136: * PDDFP IS NON-RELOC. BECAUSE DFBLK IS IN STATIC
3137: *
3138: * PDFLD VALUES ARE STORED IN ORDER FROM LEFT TO RIGHT.
3139: * THEY CONTAIN VALUES OR POINTERS TO TRBLK CHAINS.
3140: EJC
3141: *
3142: * PROGRAM DEFINED FUNCTION BLOCK (PFBLK)
3143: *
3144: * A PFBLK IS CREATED FOR EACH CALL TO THE DEFINE FUNCTION
3145: * AND A POINTER TO THE PFBLK PLACED IN THE PROPER VRBLK.
3146: *
3147: * +------------------------------------+
3148: * I FCODE I
3149: * +------------------------------------+
3150: * I FARGS I
3151: * +------------------------------------+
3152: * I PFLEN I
3153: * +------------------------------------+
3154: * I PFVBL I
3155: * +------------------------------------+
3156: * I PFNLO I
3157: * +------------------------------------+
3158: * I PFCOD I
3159: * +------------------------------------+
3160: * I PFCTR I
3161: * +------------------------------------+
3162: * I PFRTR I
3163: * +------------------------------------+
3164: * / /
3165: * / PFARG /
3166: * / /
3167: * +------------------------------------+
3168: *
3169: PFLEN EQU FARGS+1 LENGTH OF PFBLK IN BYTES
3170: PFVBL EQU PFLEN+1 POINTER TO VRBLK FOR FUNCTION NAME
3171: PFNLO EQU PFVBL+1 NUMBER OF LOCALS
3172: PFCOD EQU PFNLO+1 PTR TO CDBLK FOR FIRST STATEMENT
3173: PFCTR EQU PFCOD+1 TRBLK PTR IF CALL TRACED ELSE 0
3174: PFRTR EQU PFCTR+1 TRBLK PTR IF RETURN TRACED ELSE 0
3175: PFARG EQU PFRTR+1 VRBLK PTRS FOR ARGUMENTS AND LOCALS
3176: PFAGB EQU PFARG-1 OFFSET BEHIND PFARG FOR ARG, LOCAL
3177: PFSI$ EQU PFARG NUMBER OF STANDARD FIELDS IN PFBLK
3178: *
3179: * THE FCODE FIELD POINTS TO THE ROUTINE B$PFC.
3180: *
3181: * PFARG IS STORED IN THE FOLLOWING ORDER.
3182: *
3183: * ARGUMENTS (LEFT TO RIGHT)
3184: * LOCALS (LEFT TO RIGHT)
3185: .IF .CNRA
3186: .ELSE
3187: EJC
3188: *
3189: * REAL CONSTANT BLOCK (RCBLK)
3190: *
3191: * AN RCBLK IS CREATED FOR EVERY REAL REFERENCED OR
3192: * CREATED BY A PROGRAM.
3193: *
3194: * +------------------------------------+
3195: * I RCGET I
3196: * +------------------------------------+
3197: * * RCVAL *
3198: * +------------------------------------+
3199: *
3200: RCGET EQU 0 PTR TO ROUTINE B$RCL TO LOAD REAL
3201: RCVAL EQU RCGET+1 REAL VALUE
3202: RCSI$ EQU RCVAL+CFP$R SIZE OF RCBLK
3203: *
3204: * THE LENGTH OF THE RCVAL FIELD IS CFP$R.
3205: .FI
3206: EJC
3207: *
3208: * STRING CONSTANT BLOCK (SCBLK)
3209: *
3210: * AN SCBLK IS BUILT FOR EVERY STRING REFERENCED OR CREATED
3211: * BY A PROGRAM.
3212: *
3213: * +------------------------------------+
3214: * I SCGET I
3215: * +------------------------------------+
3216: * I SCLEN I
3217: * +------------------------------------+
3218: * / /
3219: * / SCHAR /
3220: * / /
3221: * +------------------------------------+
3222: *
3223: SCGET EQU 0 PTR TO ROUTINE B$SCL TO LOAD STRING
3224: SCLEN EQU SCGET+1 LENGTH OF STRING IN CHARACTERS
3225: SCHAR EQU SCLEN+1 CHARACTERS OF STRING
3226: SCSI$ EQU SCHAR SIZE OF STANDARD FIELDS IN SCBLK
3227: *
3228: * THE CHARACTERS OF THE STRING ARE STORED LEFT JUSTIFIED.
3229: * THE FINAL WORD IS PADDED ON THE RIGHT WITH ZEROS.
3230: * (I.E. THE CHARACTER WHOSE INTERNAL CODE IS ZERO).
3231: *
3232: * THE VALUE OF SCLEN MAY NOT EXCEED MXLEN. THIS ENSURES
3233: * THAT CHARACTER OFFSETS (E.G. THE PATTERN MATCH CURSOR)
3234: * CAN BE CORRECTLY PROCESSED BY THE GARBAGE COLLECTOR.
3235: *
3236: * NOTE THAT THE OFFSET TO THE CHARACTERS OF THE STRING
3237: * IS GIVEN IN BYTES BY CFP$F AND THAT THIS VALUE IS
3238: * AUTOMATICALLY ALLOWED FOR IN PLC, PSC.
3239: * NOTE THAT FOR A SPITBOL SCBLK, THE VALUE OF CFP$F
3240: * IS GIVEN BY CFP$B*SCHAR.
3241: EJC
3242: *
3243: * SIMPLE EXPRESSION BLOCK (SEBLK)
3244: *
3245: * AN SEBLK IS USED TO REPRESENT AN EXPRESSION OF THE FORM
3246: * *(NATURAL VARIABLE). ALL OTHER EXPRESSIONS ARE EXBLKS.
3247: *
3248: * +------------------------------------+
3249: * I SETYP I
3250: * +------------------------------------+
3251: * I SEVAR I
3252: * +------------------------------------+
3253: *
3254: SETYP EQU 0 PTR TO ROUTINE B$SEL TO LOAD EXPR
3255: SEVAR EQU SETYP+1 PTR TO VRBLK FOR VARIABLE
3256: SESI$ EQU SEVAR+1 LENGTH OF SEBLK IN WORDS
3257: EJC
3258: *
3259: * STANDARD VARIABLE BLOCK (SVBLK)
3260: *
3261: * AN SVBLK IS ASSEMBLED IN THE CONSTANT SECTION FOR EACH
3262: * VARIABLE WHICH SATISFIES ONE OF THE FOLLOWING CONDITIONS.
3263: *
3264: * 1) IT IS THE NAME OF A SYSTEM FUNCTION
3265: * 2) IT HAS AN INITIAL VALUE
3266: * 3) IT HAS A KEYWORD ASSOCIATION
3267: * 4) IT HAS A STANDARD I/O ASSOCIATION
3268: * 6) IT HAS A STANDARD LABEL ASSOCIATION
3269: *
3270: * IF VRBLKS ARE CONSTRUCTED FOR ANY OF THESE VARIABLES,
3271: * THEN THE VRSVP FIELD POINTS TO THE SVBLK (SEE VRBLK)
3272: *
3273: * +------------------------------------+
3274: * I SVBIT I
3275: * +------------------------------------+
3276: * I SVLEN I
3277: * +------------------------------------+
3278: * I SVCHS I
3279: * +------------------------------------+
3280: * I SVKNM I
3281: * +------------------------------------+
3282: * I SVFNC I
3283: * +------------------------------------+
3284: * I SVNAR I
3285: * +------------------------------------+
3286: * I SVLBL I
3287: * +------------------------------------+
3288: * I SVVAL I
3289: * +------------------------------------+
3290: EJC
3291: *
3292: * STANDARD VARIABLE BLOCK (CONTINUED)
3293: *
3294: SVBIT EQU 0 BIT STRING INDICATING ATTRIBUTES
3295: SVLEN EQU 1 (=SCLEN) LENGTH OF NAME IN CHARS
3296: SVCHS EQU 2 (=SCHAR) CHARACTERS OF NAME
3297: SVSI$ EQU 2 NUMBER OF STANDARD FIELDS IN SVBLK
3298: SVPRE EQU 1 SET IF PREEVALUATION PERMITTED
3299: SVFFC EQU SVPRE+SVPRE SET ON IF FAST CALL PERMITTED
3300: SVCKW EQU SVFFC+SVFFC SET ON IF KEYWORD VALUE CONSTANT
3301: SVPRD EQU SVCKW+SVCKW SET ON IF PREDICATE FUNCTION
3302: SVNBT EQU 4 NUMBER OF BITS TO RIGHT OF SVKNM
3303: SVKNM EQU SVPRD+SVPRD SET ON IF KEYWORD ASSOCIATION
3304: SVFNC EQU SVKNM+SVKNM SET ON IF SYSTEM FUNCTION
3305: SVNAR EQU SVFNC+SVFNC SET ON IF SYSTEM FUNCTION
3306: SVLBL EQU SVNAR+SVNAR SET ON IF SYSTEM LABEL
3307: SVVAL EQU SVLBL+SVLBL SET ON IF PREDEFINED VALUE
3308: *
3309: * NOTE THAT THE LAST FIVE BITS CORRESPOND IN ORDER
3310: * TO THE FIELDS WHICH ARE PRESENT (SEE PROCEDURE GTNVR).
3311: *
3312: * THE FOLLOWING DEFINITIONS ARE USED IN THE SVBLK TABLE
3313: *
3314: SVFNF EQU SVFNC+SVNAR FUNCTION WITH NO FAST CALL
3315: SVFNN EQU SVFNF+SVFFC FUNCTION WITH FAST CALL, NO PREEVAL
3316: SVFNP EQU SVFNN+SVPRE FUNCTION ALLOWING PREEVALUATION
3317: SVFPR EQU SVFNN+SVPRD PREDICATE FUNCTION
3318: SVFNK EQU SVFNN+SVKNM NO PREEVAL FUNC + KEYWORD
3319: SVKWV EQU SVKNM+SVVAL KEYWORD + VALUE
3320: SVKWC EQU SVCKW+SVKNM KEYWORD WITH CONSTANT VALUE
3321: SVKVC EQU SVKWV+SVCKW CONSTANT KEYWORD + VALUE
3322: SVKVL EQU SVKVC+SVLBL CONSTANT KEYWORD + VALUE + LABEL
3323: SVFPK EQU SVFNP+SVKVC PREEVAL FCN + CONST KEYWD + VAL
3324: *
3325: * THE SVPRE BIT ALLOWS THE COMPILER TO PREEVALUATE A CALL
3326: * TO THE ASSOCIATED SYSTEM FUNCTION IF ALL THE ARGUMENTS
3327: * ARE THEMSELVES CONSTANTS. FUNCTIONS IN THIS CATEGORY
3328: * MUST HAVE NO SIDE EFFECTS AND MUST NEVER CAUSE FAILURE.
3329: * THE CALL MAY GENERATE AN ERROR CONDITION.
3330: *
3331: * THE SVFFC BIT ALLOWS THE COMPILER TO GENERATE THE SPECIAL
3332: * FAST CALL AFTER ADJUSTING THE NUMBER OF ARGUMENTS. ONLY
3333: * THE ITEM AND APPLY FUNCTIONS FALL OUTSIDE THIS CATEGORY.
3334: *
3335: * THE SVCKW BIT IS SET IF THE ASSOCIATED KEYWORD VALUE IS
3336: * A CONSTANT, THUS ALLOWING PREEVALUATION FOR A VALUE CALL.
3337: *
3338: * THE SVPRD BIT IS SET ON FOR ALL PREDICATE FUNCTIONS TO
3339: * ENABLE THE SPECIAL CONCATENATION CODE OPTIMIZATION.
3340: EJC
3341: *
3342: * SVBLK (CONTINUED)
3343: *
3344: * SVKNM KEYWORD NUMBER
3345: *
3346: * SVKNM IS PRESENT ONLY FOR A STANDARD KEYWORD ASSOC.
3347: * IT CONTAINS A KEYWORD NUMBER AS DEFINED BY THE
3348: * KEYWORD NUMBER TABLE GIVEN LATER ON.
3349: *
3350: * SVFNC SYSTEM FUNCTION POINTER
3351: *
3352: * SVFNC IS PRESENT ONLY FOR A SYSTEM FUNCTION ASSOC.
3353: * IT IS A POINTER TO THE ACTUAL CODE FOR THE SYSTEM
3354: * FUNCTION. THE GENERATED CODE FOR A FAST CALL IS A
3355: * POINTER TO THE SVFNC FIELD OF THE SVBLK FOR THE
3356: * FUNCTION. THE VRFNC FIELD OF THE VRBLK POINTS TO
3357: * THIS SAME FIELD, IN WHICH CASE, IT SERVES AS THE
3358: * FCODE FIELD FOR THE FUNCTION CALL.
3359: *
3360: * SVNAR NUMBER OF FUNCTION ARGUMENTS
3361: *
3362: * SVNAR IS PRESENT ONLY FOR A SYSTEM FUNCTION ASSOC.
3363: * IT IS THE NUMBER OF ARGUMENTS REQUIRED FOR A CALL
3364: * TO THE SYSTEM FUNCTION. THE COMPILER USES THIS
3365: * VALUE TO ADJUST THE NUMBER OF ARGUMENTS IN A FAST
3366: * CALL AND IN THE CASE OF A FUNCTION CALLED THROUGH
3367: * THE VRFNC FIELD OF THE VRBLK, THE SVNAR FIELD
3368: * SERVES AS THE FARGS FIELD FOR O$FNC. A SPECIAL
3369: * CASE OCCURS IF THIS VALUE IS SET TO 999. THIS IS
3370: * USED TO INDICATE THAT THE FUNCTION HAS A VARIABLE
3371: * NUMBER OF ARGUMENTS AND CAUSES O$FNC TO PASS CONTROL
3372: * WITHOUT ADJUSTING THE ARGUMENT COUNT. THE ONLY
3373: * PREDEFINED FUNCTIONS USING THIS ARE APPLY AND ITEM.
3374: *
3375: * SVLBL SYSTEM LABEL POINTER
3376: *
3377: * SVLBL IS PRESENT ONLY FOR A STANDARD LABEL ASSOC.
3378: * IT IS A POINTER TO A SYSTEM LABEL ROUTINE (L$XXX).
3379: * THE VRLBL FIELD OF THE CORRESPONDING VRBLK POINTS TO
3380: * THE SVLBL FIELD OF THE SVBLK.
3381: *
3382: * SVVAL SYSTEM VALUE POINTER
3383: *
3384: * SVVAL IS PRESENT ONLY FOR A STANDARD VALUE.
3385: * IT IS A POINTER TO THE PATTERN NODE (NDXXX) WHICH
3386: * IS THE STANDARD INITIAL VALUE OF THE VARIABLE.
3387: * THIS VALUE IS COPIED TO THE VRVAL FIELD OF THE VRBLK
3388: EJC
3389: *
3390: * SVBLK (CONTINUED)
3391: *
3392: * KEYWORD NUMBER TABLE
3393: *
3394: * THE FOLLOWING TABLE GIVES SYMBOLIC NAMES FOR KEYWORD
3395: * NUMBERS. THESE VALUES ARE STORED IN THE SVKNM FIELD OF
3396: * SVBLKS AND IN THE KVNUM FIELD OF KVBLKS. SEE ALSO
3397: * PROCEDURES ASIGN, ACESS AND KWNAM.
3398: *
3399: * UNPROTECTED KEYWORDS WITH ONE WORD INTEGER VALUES
3400: *
3401: K$ABE EQU 0 ABEND
3402: K$ANC EQU K$ABE+CFP$B ANCHOR
3403: .IF .CULC
3404: K$CAS EQU K$ANC+CFP$B CASE
3405: K$COD EQU K$CAS+CFP$B CODE
3406: .ELSE
3407: K$COD EQU K$ANC+CFP$B CODE
3408: .FI
3409: K$DMP EQU K$COD+CFP$B DUMP
3410: K$ERL EQU K$DMP+CFP$B ERRLIMIT
3411: K$ERT EQU K$ERL+CFP$B ERRTYPE
3412: K$FTR EQU K$ERT+CFP$B FTRACE
3413: K$INP EQU K$FTR+CFP$B INPUT
3414: K$MXL EQU K$INP+CFP$B MAXLENGTH
3415: K$OUP EQU K$MXL+CFP$B OUTPUT
3416: .IF .CNPF
3417: K$TRA EQU K$OUP+CFP$B TRACE
3418: .ELSE
3419: K$PFL EQU K$OUP+CFP$B PROFILE
3420: K$TRA EQU K$PFL+CFP$B TRACE
3421: .FI
3422: K$TRM EQU K$TRA+CFP$B TRIM
3423: *
3424: * PROTECTED KEYWORDS WITH ONE WORD INTEGER VALUES
3425: *
3426: K$FNC EQU K$TRM+CFP$B FNCLEVEL
3427: K$LST EQU K$FNC+CFP$B LASTNO
3428: K$STN EQU K$LST+CFP$B STNO
3429: *
3430: * KEYWORDS WITH CONSTANT PATTERN VALUES
3431: *
3432: K$ABO EQU K$STN+CFP$B ABORT
3433: K$ARB EQU K$ABO+PASI$ ARB
3434: K$BAL EQU K$ARB+PASI$ BAL
3435: K$FAL EQU K$BAL+PASI$ FAIL
3436: K$FEN EQU K$FAL+PASI$ FENCE
3437: K$REM EQU K$FEN+PASI$ REM
3438: K$SUC EQU K$REM+PASI$ SUCCEED
3439: EJC
3440: *
3441: * KEYWORD NUMBER TABLE (CONTINUED)
3442: *
3443: * SPECIAL KEYWORDS
3444: *
3445: K$ALP EQU K$SUC+1 ALPHABET
3446: K$RTN EQU K$ALP+1 RTNTYPE
3447: K$STC EQU K$RTN+1 STCOUNT
3448: K$ETX EQU K$STC+1 ERRTEXT
3449: K$STL EQU K$ETX+1 STLIMIT
3450: *
3451: * RELATIVE OFFSETS OF SPECIAL KEYWORDS
3452: *
3453: K$$AL EQU K$ALP-K$ALP ALPHABET
3454: K$$RT EQU K$RTN-K$ALP RTNTYPE
3455: K$$SC EQU K$STC-K$ALP STCOUNT
3456: K$$ET EQU K$ETX-K$ALP ERRTEXT
3457: K$$SL EQU K$STL-K$ALP STLIMIT
3458: *
3459: * SYMBOLS USED IN ASIGN AND ACESS PROCEDURES
3460: *
3461: K$P$$ EQU K$FNC FIRST PROTECTED KEYWORD
3462: K$V$$ EQU K$ABO FIRST KEYWORD WITH CONSTANT VALUE
3463: K$S$$ EQU K$ALP FIRST KEYWORD WITH SPECIAL ACESS
3464: EJC
3465: *
3466: * FORMAT OF A TABLE BLOCK (TBBLK)
3467: *
3468: * A TABLE BLOCK IS USED TO REPRESENT A TABLE VALUE.
3469: * IT IS BUILT BY A CALL TO THE TABLE OR CONVERT FUNCTIONS.
3470: *
3471: * +------------------------------------+
3472: * I TBTYP I
3473: * +------------------------------------+
3474: * I IDVAL I
3475: * +------------------------------------+
3476: * I TBLEN I
3477: * +------------------------------------+
3478: * +------------------------------------+
3479: * I TBINV I
3480: * +------------------------------------+
3481: * / /
3482: * / TBBUK /
3483: * / /
3484: * +------------------------------------+
3485: *
3486: TBTYP EQU 0 POINTER TO DUMMY ROUTINE B$TBT
3487: TBLEN EQU OFFS2 LENGTH OF TBBLK IN BYTES
3488: TBINV EQU OFFS3 DEFAULT INITIAL LOOKUP VALUE
3489: TBBUK EQU TBINV+1 START OF HASH BUCKET POINTERS
3490: TBSI$ EQU TBBUK SIZE OF STANDARD FIELDS IN TBBLK
3491: TBNBK EQU 11 DEFAULT NO. OF BUCKETS
3492: *
3493: * THE TABLE BLOCK IS A HASH TABLE WHICH POINTS TO CHAINS
3494: * OF TABLE ELEMENT BLOCKS REPRESENTING THE ELEMENTS
3495: * IN THE TABLE WHICH HASH INTO THE SAME BUCKET.
3496: *
3497: * TBBUK ENTRIES EITHER POINT TO THE FIRST TEBLK ON THE
3498: * CHAIN OR THEY POINT TO THE TBBLK ITSELF TO INDICATE THE
3499: * END OF THE CHAIN.
3500: EJC
3501: *
3502: * TABLE ELEMENT BLOCK (TEBLK)
3503: *
3504: * A TABLE ELEMENT IS USED TO REPRESENT A SINGLE ENTRY IN
3505: * A TABLE (SEE DESCRIPTION OF TBBLK FORMAT FOR HASH TABLE)
3506: *
3507: * +------------------------------------+
3508: * I TETYP I
3509: * +------------------------------------+
3510: * I TESUB I
3511: * +------------------------------------+
3512: * I TEVAL I
3513: * +------------------------------------+
3514: * I TENXT I
3515: * +------------------------------------+
3516: *
3517: TETYP EQU 0 POINTER TO DUMMY ROUTINE B$TET
3518: TESUB EQU TETYP+1 SUBSCRIPT VALUE
3519: TEVAL EQU TESUB+1 (=VRVAL) TABLE ELEMENT VALUE
3520: TENXT EQU TEVAL+1 LINK TO NEXT TEBLK
3521: * SEE S$CNV WHERE RELATION IS ASSUMED WITH TENXT AND TBBUK
3522: TESI$ EQU TENXT+1 SIZE OF TEBLK IN WORDS
3523: *
3524: * TENXT POINTS TO THE NEXT TEBLK ON THE HASH CHAIN FROM THE
3525: * TBBUK CHAIN FOR THIS HASH INDEX. AT THE END OF THE CHAIN,
3526: * TENXT POINTS BACK TO THE START OF THE TBBLK.
3527: *
3528: * TEVAL CONTAINS A DATA POINTER OR A TRBLK POINTER.
3529: *
3530: * TESUB CONTAINS A DATA POINTER.
3531: EJC
3532: *
3533: * TRAP BLOCK (TRBLK)
3534: *
3535: * A TRAP BLOCK IS USED TO REPRESENT A TRACE OR INPUT OR
3536: * OUTPUT ASSOCIATION IN RESPONSE TO A CALL TO THE TRACE
3537: * INPUT OR OUTPUT SYSTEM FUNCTIONS. SEE BELOW FOR DETAILS
3538: *
3539: * +------------------------------------+
3540: * I TRIDN I
3541: * +------------------------------------+
3542: * I TRTYP I
3543: * +------------------------------------+
3544: * I TRVAL OR TRLBL OR TRNXT OR TRKVR I
3545: * +------------------------------------+
3546: * I TRTAG OR TRTER OR TRTRF I
3547: * +------------------------------------+
3548: * I TRFNC OR TRFPT I
3549: * +------------------------------------+
3550: *
3551: TRIDN EQU 0 POINTER TO DUMMY ROUTINE B$TRT
3552: TRTYP EQU TRIDN+1 TRAP TYPE CODE
3553: TRVAL EQU TRTYP+1 VALUE OF TRAPPED VARIABLE (=VRVAL)
3554: TRNXT EQU TRVAL PTR TO NEXT TRBLK ON TRBLK CHAIN
3555: TRLBL EQU TRVAL PTR TO ACTUAL LABEL (TRACED LABEL)
3556: TRKVR EQU TRVAL VRBLK POINTER FOR KEYWORD TRACE
3557: TRTAG EQU TRVAL+1 TRACE TAG
3558: TRTER EQU TRTAG PTR TO TERMINAL VRBLK OR NULL
3559: TRTRF EQU TRTAG PTR TO TRBLK HOLDING FCBLK PTR
3560: TRFNC EQU TRTAG+1 TRACE FUNCTION VRBLK (ZERO IF NONE)
3561: TRFPT EQU TRFNC FCBLK PTR FOR SYSIO
3562: TRSI$ EQU TRFNC+1 NUMBER OF WORDS IN TRBLK
3563: *
3564: TRTIN EQU 0 TRACE TYPE FOR INPUT ASSOCIATION
3565: TRTAC EQU TRTIN+1 TRACE TYPE FOR ACCESS TRACE
3566: TRTVL EQU TRTAC+1 TRACE TYPE FOR VALUE TRACE
3567: TRTOU EQU TRTVL+1 TRACE TYPE FOR OUTPUT ASSOCIATION
3568: TRTFC EQU TRTOU+1 TRACE TYPE FOR FCBLK IDENTIFICATION
3569: EJC
3570: *
3571: * TRAP BLOCK (CONTINUED)
3572: *
3573: * VARIABLE INPUT ASSOCIATION
3574: *
3575: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
3576: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
3577: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
3578: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
3579: *
3580: * TRTYP IS SET TO TRTIN
3581: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
3582: * TRTER IS A POINTER TO SVBLK IF ASSOCIATION IS
3583: * FOR INPUT, TERMINAL, ELSE IT IS NULL.
3584: * TRTRF POINTS TO THE TRAP BLOCK WHICH IN TURN POINTS
3585: * TO AN FCBLK USED FOR I/O ASSOCIATION.
3586: * TRFPT IS THE FCBLK PTR RETURNED BY SYSIO.
3587: *
3588: * VARIABLE ACCESS TRACE ASSOCIATION
3589: *
3590: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
3591: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
3592: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
3593: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
3594: *
3595: * TRTYP IS SET TO TRTAC
3596: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
3597: * TRTAG IS THE TRACE TAG (0 IF NONE)
3598: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3599: *
3600: * VARIABLE VALUE TRACE ASSOCIATION
3601: *
3602: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
3603: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
3604: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
3605: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
3606: *
3607: * TRTYP IS SET TO TRTVL
3608: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
3609: * TRTAG IS THE TRACE TAG (0 IF NONE)
3610: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3611: EJC
3612: * TRAP BLOCK (CONTINUED)
3613: *
3614: * VARIABLE OUTPUT ASSOCIATION
3615: *
3616: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
3617: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
3618: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
3619: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
3620: *
3621: * TRTYP IS SET TO TRTOU
3622: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
3623: * TRTER IS A POINTER TO SVBLK IF ASSOCIATION IS
3624: * FOR OUTPUT, TERMINAL, ELSE IT IS NULL.
3625: * TRTRF POINTS TO THE TRAP BLOCK WHICH IN TURN POINTS
3626: * TO AN FCBLK USED FOR I/O ASSOCIATION.
3627: * TRFPT IS THE FCBLK PTR RETURNED BY SYSIO.
3628: *
3629: * FUNCTION CALL TRACE
3630: *
3631: * THE PFCTR FIELD OF THE CORRESPONDING PFBLK IS SET
3632: * TO POINT TO A TRBLK.
3633: *
3634: * TRTYP IS SET TO TRTIN
3635: * TRNXT IS ZERO
3636: * TRTAG IS THE TRACE TAG (0 IF NONE)
3637: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3638: *
3639: * FUNCTION RETURN TRACE
3640: *
3641: * THE PFRTR FIELD OF THE CORRESPONDING PFBLK IS SET
3642: * TO POINT TO A TRBLK
3643: *
3644: * TRTYP IS SET TO TRTIN
3645: * TRNXT IS ZERO
3646: * TRTAG IS THE TRACE TAG (0 IF NONE)
3647: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3648: *
3649: * LABEL TRACE
3650: *
3651: * THE VRLBL OF THE VRBLK FOR THE LABEL IS
3652: * CHANGED TO POINT TO A TRBLK AND THE VRTRA FIELD IS
3653: * SET TO B$VRT TO ACTIVATE THE CHECK.
3654: *
3655: * TRTYP IS SET TO TRTIN
3656: * TRLBL POINTS TO THE ACTUAL LABEL (CDBLK) VALUE
3657: * TRTAG IS THE TRACE TAG (0 IF NONE)
3658: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3659: EJC
3660: *
3661: * TRAP BLOCK (CONTINUED)
3662: *
3663: * KEYWORD TRACE
3664: *
3665: * KEYWORDS WHICH CAN BE TRACED POSSESS A UNIQUE
3666: * LOCATION WHICH IS ZERO IF THERE IS NO TRACE AND
3667: * POINTS TO A TRBLK IF THERE IS A TRACE. THE LOCATIONS
3668: * ARE AS FOLLOWS.
3669: *
3670: * R$ERT ERRTYPE
3671: * R$FNC FNCLEVEL
3672: * R$STC STCOUNT
3673: *
3674: * THE FORMAT OF THE TRBLK IS AS FOLLOWS.
3675: *
3676: * TRTYP IS SET TO TRTIN
3677: * TRKVR IS A POINTER TO THE VRBLK FOR THE KEYWORD
3678: * TRTAG IS THE TRACE TAG (0 IF NONE)
3679: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3680: *
3681: * INPUT/OUTPUT FILE ARG1 TRAP BLOCK
3682: *
3683: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
3684: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE OF
3685: * A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
3686: * CONTAIN =B$VRA AND =B$VRV. THIS TRAP BLOCK IS USED
3687: * TO HOLD A POINTER TO THE FCBLK WHICH AN
3688: * IMPLEMENTATION MAY REQUEST TO HOLD INFORMATION
3689: * ABOUT A FILE.
3690: *
3691: * TRTYP IS SET TO TRTFC
3692: * TRNEXT POINTS TO NEXT TRBLK OR TRVAL IS VARIABLE VAL
3693: * TRFNM IS 0
3694: * TRFPT IS THE FCBLK POINTER.
3695: *
3696: * NOTE THAT WHEN MULTIPLE TRAPS ARE SET ON A VARIABLE
3697: * THE ORDER IS IN ASCENDING VALUE OF TRTYP FIELD.
3698: *
3699: * INPUT ASSOCIATION (IF PRESENT)
3700: * ACCESS TRACE (IF PRESENT)
3701: * VALUE TRACE (IF PRESENT)
3702: * OUTPUT ASSOCIATION (IF PRESENT)
3703: *
3704: * THE ACTUAL VALUE OF THE VARIABLE IS STORED IN THE TRVAL
3705: * FIELD OF THE LAST TRBLK ON THE CHAIN.
3706: *
3707: * THIS IMPLEMENTATION DOES NOT PERMIT TRACE OR I/O
3708: * ASSOCIATIONS TO ANY OF THE PSEUDO-VARIABLES.
3709: EJC
3710: *
3711: * VECTOR BLOCK (VCBLK)
3712: *
3713: * A VCBLK IS USED TO REPRESENT AN ARRAY VALUE WHICH HAS
3714: * ONE DIMENSION WHOSE LOWER BOUND IS ONE. ALL OTHER ARRAYS
3715: * ARE REPRESENTED BY ARBLKS. A VCBLK IS CREATED BY THE
3716: * SYSTEM FUNCTION ARRAY (S$ARR) WHEN PASSED AN INTEGER ARG.
3717: *
3718: * +------------------------------------+
3719: * I VCTYP I
3720: * +------------------------------------+
3721: * I IDVAL I
3722: * +------------------------------------+
3723: * I VCLEN I
3724: * +------------------------------------+
3725: * I VCVLS I
3726: * +------------------------------------+
3727: *
3728: VCTYP EQU 0 POINTER TO DUMMY ROUTINE B$VCT
3729: VCLEN EQU OFFS2 LENGTH OF VCBLK IN BYTES
3730: VCVLS EQU OFFS3 START OF VECTOR VALUES
3731: VCSI$ EQU VCVLS SIZE OF STANDARD FIELDS IN VCBLK
3732: VCVLB EQU VCVLS-1 OFFSET ONE WORD BEHIND VCVLS
3733: VCTBD EQU TBSI$-VCSI$ DIFFERENCE IN SIZES - SEE PRTVL
3734: *
3735: * VCVLS ARE EITHER DATA POINTERS OR TRBLK POINTERS
3736: *
3737: * THE DIMENSION CAN BE DEDUCED FROM VCLEN.
3738: EJC
3739: *
3740: * VARIABLE BLOCK (VRBLK)
3741: *
3742: * A VARIABLE BLOCK IS BUILT IN THE STATIC MEMORY AREA
3743: * FOR EVERY VARIABLE REFERENCED OR CREATED BY A PROGRAM.
3744: *
3745: * NOTE THAT SINCE THESE BLOCKS ONLY OCCUR IN THE STATIC
3746: * REGION, IT IS PERMISSIBLE TO POINT TO ANY WORD IN
3747: * THE BLOCK AND THIS IS USED TO PROVIDE THREE DISTINCT
3748: * ACCESS POINTS FROM THE GENERATED CODE AS FOLLOWS.
3749: *
3750: * 1) POINT TO VRGET (FIRST WORD OF VRBLK) TO LOAD THE
3751: * VALUE OF THE VARIABLE ONTO THE MAIN STACK.
3752: *
3753: * 2) POINT TO VRSTO (SECOND WORD OF VRBLK) TO STORE THE
3754: * TOP STACK ELEMENT AS THE VALUE OF THE VARIABLE.
3755: *
3756: * 3) POINT TO VRTRA (FOURTH WORD OF VRBLK) TO JUMP TO
3757: * THE LABEL ASSOCIATED WITH THE VARIABLE NAME.
3758: *
3759: * +------------------------------------+
3760: * I VRGET I
3761: * +------------------------------------+
3762: * I VRSTO I
3763: * +------------------------------------+
3764: * I VRVAL I
3765: * +------------------------------------+
3766: * I VRTRA I
3767: * +------------------------------------+
3768: * I VRLBL I
3769: * +------------------------------------+
3770: * I VRFNC I
3771: * +------------------------------------+
3772: * I VRNXT I
3773: * +------------------------------------+
3774: * I VRLEN I
3775: * +------------------------------------+
3776: * / /
3777: * / VRCHS = VRSVP /
3778: * / /
3779: * +------------------------------------+
3780: EJC
3781: *
3782: * VARIABLE BLOCK (CONTINUED)
3783: *
3784: VRGET EQU 0 POINTER TO ROUTINE TO LOAD VALUE
3785: VRSTO EQU VRGET+1 POINTER TO ROUTINE TO STORE VALUE
3786: VRVAL EQU VRSTO+1 VARIABLE VALUE
3787: VRVLO EQU VRVAL-VRSTO OFFSET TO VALUE FROM STORE FIELD
3788: VRTRA EQU VRVAL+1 POINTER TO ROUTINE TO JUMP TO LABEL
3789: VRLBL EQU VRTRA+1 POINTER TO CODE FOR LABEL
3790: VRLBO EQU VRLBL-VRTRA OFFSET TO LABEL FROM TRANSFER FIELD
3791: VRFNC EQU VRLBL+1 POINTER TO FUNCTION BLOCK
3792: VRNXT EQU VRFNC+1 POINTER TO NEXT VRBLK ON HASH CHAIN
3793: VRLEN EQU VRNXT+1 LENGTH OF NAME (OR ZERO)
3794: VRCHS EQU VRLEN+1 CHARACTERS OF NAME (VRLEN GT 0)
3795: VRSVP EQU VRLEN+1 PTR TO SVBLK (VRLEN EQ 0)
3796: VRSI$ EQU VRCHS+1 NUMBER OF STANDARD FIELDS IN VRBLK
3797: VRSOF EQU VRLEN-SCLEN OFFSET TO DUMMY SCBLK FOR NAME
3798: VRSVO EQU VRSVP-VRSOF PSEUDO-OFFSET TO VRSVP FIELD
3799: *
3800: * VRGET = B$VRL IF NOT INPUT ASSOCIATED OR ACCESS TRACED
3801: * VRGET = B$VRA IF INPUT ASSOCIATED OR ACCESS TRACED
3802: *
3803: * VRSTO = B$VRS IF NOT OUTPUT ASSOCIATED OR VALUE TRACED
3804: * VRSTO = B$VRV IF OUTPUT ASSOCIATED OR VALUE TRACED
3805: * VRSTO = B$VRE IF VALUE IS PROTECTED PATTERN VALUE
3806: *
3807: * VRVAL POINTS TO THE APPROPRIATE VALUE UNLESS THE
3808: * VARIABLE IS I/O/TRACE ASSOCIATED IN WHICH CASE, VRVAL
3809: * POINTS TO AN APPROPRIATE TRBLK (TRAP BLOCK) CHAIN.
3810: *
3811: * VRTRA = B$VRG IF THE LABEL IS NOT TRACED
3812: * VRTRA = B$VRT IF THE LABEL IS TRACED
3813: *
3814: * VRLBL POINTS TO A CDBLK IF THERE IS A LABEL
3815: * VRLBL POINTS TO THE SVBLK SVLBL FIELD FOR A SYSTEM LABEL
3816: * VRLBL POINTS TO STNDL FOR AN UNDEFINED LABEL
3817: * VRLBL POINTS TO A TRBLK IF THE LABEL IS TRACED
3818: *
3819: * VRFNC POINTS TO A FFBLK FOR A FIELD FUNCTION
3820: * VRFNC POINTS TO A DFBLK FOR A DATATYPE FUNCTION
3821: * VRFNC POINTS TO A PFBLK FOR A PROGRAM DEFINED FUNCTION
3822: * VRFNC POINTS TO A EFBLK FOR AN EXTERNAL LOADED FUNCTION
3823: * VRFNC POINTS TO SVFNC (SVBLK) FOR A SYSTEM FUNCTION
3824: * VRFNC POINTS TO STNDF IF THE FUNCTION IS UNDEFINED
3825: *
3826: * VRNXT POINTS TO THE NEXT VRBLK ON THIS CHAIN UNLESS
3827: * THIS IS THE END OF THE CHAIN IN WHICH CASE IT IS ZERO.
3828: *
3829: * VRLEN IS THE NAME LENGTH FOR A NON-SYSTEM VARIABLE.
3830: * VRLEN IS ZERO FOR A SYSTEM VARIABLE.
3831: *
3832: * VRCHS IS THE NAME (LJRZ) IF VRLEN IS NON-ZERO.
3833: * VRSVP IS A PTR TO THE SVBLK IF VRLEN IS ZERO.
3834: EJC
3835: *
3836: * FORMAT OF A NON-RELOCATABLE EXTERNAL BLOCK (XNBLK)
3837: *
3838: * AN XNBLK IS A BLOCK REPRESENTING AN UNKNOWN (EXTERNAL)
3839: * DATA VALUE. THE BLOCK CONTAINS NO POINTERS TO OTHER
3840: * RELOCATABLE BLOCKS. AN XNBLK IS USED BY EXTERNAL FUNCTION
3841: * PROCESSING OR POSSIBLY FOR SYSTEM I/O ROUTINES ETC.
3842: * THE MACRO-SYSTEM ITSELF DOES NOT USE XNBLKS.
3843: * THIS TYPE OF BLOCK MAY BE USED AS A FILE CONTROL BLOCK.
3844: * SEE SYSFC,SYSIN,SYSOU,S$INP,S$OUP FOR DETAILS.
3845: *
3846: * +------------------------------------+
3847: * I XNTYP I
3848: * +------------------------------------+
3849: * I XNLEN I
3850: * +------------------------------------+
3851: * / /
3852: * / XNDTA /
3853: * / /
3854: * +------------------------------------+
3855: *
3856: XNTYP EQU 0 POINTER TO DUMMY ROUTINE B$XNT
3857: XNLEN EQU XNTYP+1 LENGTH OF XNBLK IN BYTES
3858: XNDTA EQU XNLEN+1 DATA WORDS
3859: XNSI$ EQU XNDTA SIZE OF STANDARD FIELDS IN XNBLK
3860: *
3861: * NOTE THAT THE TERM NON-RELOCATABLE REFERS TO THE CONTENTS
3862: * AND NOT THE BLOCK ITSELF. AN XNBLK CAN BE MOVED AROUND IF
3863: * IT IS BUILT IN THE DYNAMIC MEMORY AREA.
3864: EJC
3865: *
3866: * RELOCATABLE EXTERNAL BLOCK (XRBLK)
3867: *
3868: * AN XRBLK IS A BLOCK REPRESENTING AN UNKNOWN (EXTERNAL)
3869: * DATA VALUE. THE DATA AREA IN THIS BLOCK CONSISTS ONLY
3870: * OF ADDRESS VALUES AND ANY ADDRESSES POINTING INTO THE
3871: * DYNAMIC MEMORY AREA MUST POINT TO THE START OF OTHER
3872: * DATA BLOCKS. SEE ALSO DESCRIPTION OF XNBLK.
3873: * THIS TYPE OF BLOCK MAY BE USED AS A FILE CONTROL BLOCK.
3874: * SEE SYSFC,SYSIN,SYSOU,S$INP,S$OUP FOR DETAILS.
3875: *
3876: * +------------------------------------+
3877: * I XRTYP I
3878: * +------------------------------------+
3879: * I XRLEN I
3880: * +------------------------------------+
3881: * / /
3882: * / XRPTR /
3883: * / /
3884: * +------------------------------------+
3885: *
3886: XRTYP EQU 0 POINTER TO DUMMY ROUTINE B$XRT
3887: XRLEN EQU XRTYP+1 LENGTH OF XRBLK IN BYTES
3888: XRPTR EQU XRLEN+1 START OF ADDRESS POINTERS
3889: XRSI$ EQU XRPTR SIZE OF STANDARD FIELDS IN XRBLK
3890: EJC
3891: *
3892: * S$CNV (CONVERT) FUNCTION SWITCH CONSTANTS. THE VALUES
3893: * ARE TIED TO THE ORDER OF THE ENTRIES IN THE SVCTB TABLE
3894: * AND HENCE TO THE BRANCH TABLE IN S$CNV.
3895: *
3896: CNVST EQU 8 MAX STANDARD TYPE CODE FOR CONVERT
3897: .IF .CNRA
3898: CNVRT EQU CNVST NO REALS - SAME AS STANDARD TYPES
3899: .ELSE
3900: CNVRT EQU CNVST+1 CONVERT CODE FOR REALS
3901: .FI
3902: .IF .CNBF
3903: CNVBT EQU CNVRT NO BUFFERS - SAME AS REAL CODE
3904: .ELSE
3905: CNVBT EQU CNVRT+1 CONVERT CODE FOR BUFFER
3906: .FI
3907: CNVTT EQU CNVBT+1 BSW CODE FOR CONVERT
3908: *
3909: * INPUT IMAGE LENGTH
3910: *
3911: INILN EQU 132 DEFAULT IMAGE LENGTH FOR COMPILER
3912: INILS EQU 80 IMAGE LENGTH IF -SEQU IN EFFECT
3913: *
3914: IONMB EQU 2 NAME BASE USED FOR IOCHN IN SYSIO
3915: IONMO EQU 4 NAME OFFSET USED FOR IOCHN IN SYSIO
3916: *
3917: * IN GENERAL, MEANINGFUL MNEMONICS SHOULD BE USED FOR
3918: * OFFSETS. HOWEVER FOR SMALL INTEGERS USED OFTEN IN
3919: * LITERALS THE FOLLOWING GENERAL DEFINITIONS ARE PROVIDED.
3920: *
3921: NUM01 EQU 1
3922: NUM02 EQU 2
3923: NUM03 EQU 3
3924: NUM04 EQU 4
3925: NUM05 EQU 5
3926: NUM06 EQU 6
3927: NUM07 EQU 7
3928: NUM08 EQU 8
3929: NUM09 EQU 9
3930: NUM10 EQU 10
3931: NINI8 EQU 998
3932: NINI9 EQU 999
3933: THSND EQU 1000
3934: EJC
3935: *
3936: * NUMBERS OF UNDEFINED SPITBOL OPERATORS
3937: *
3938: OPBUN EQU 5 NO. OF BINARY UNDEFINED OPS
3939: OPUUN EQU 6 NO OF UNARY UNDEFINED OPS
3940: *
3941: * OFFSETS USED IN PRTSN, PRTMI AND ACESS
3942: *
3943: PRSNF EQU 13 OFFSET USED IN PRTSN
3944: PRTMF EQU 15 OFFSET TO COL 15 (PRTMI)
3945: RILEN EQU 120 BUFFER LENGTH FOR SYSRI
3946: *
3947: * CODES FOR STAGES OF PROCESSING
3948: *
3949: STGIC EQU 0 INITIAL COMPILE
3950: STGXC EQU STGIC+1 EXECUTION COMPILE (CODE)
3951: STGEV EQU STGXC+1 EXPRESSION EVAL DURING EXECUTION
3952: STGXT EQU STGEV+1 EXECUTION TIME
3953: STGCE EQU STGXT+1 INITIAL COMPILE AFTER END LINE
3954: STGXE EQU STGCE+1 EXEC. COMPILE AFTER END LINE
3955: STGND EQU STGCE-STGIC DIFFERENCE IN STAGE AFTER END
3956: STGEE EQU STGXE+1 EVAL EVALUATING EXPRESSION
3957: STGNO EQU STGEE+1 NUMBER OF CODES
3958: EJC
3959: *
3960: *
3961: * STATEMENT NUMBER PAD COUNT FOR LISTR
3962: *
3963: .DEF .CSN5
3964: .IF .CSN6
3965: STNPD EQU 6 STATEMENT NO. PAD COUNT
3966: .UNDEF .CSN5
3967: .FI
3968: .IF .CSN8
3969: STNPD EQU 8 STATEMENT NO. PAD COUNT
3970: .UNDEF .CSN5
3971: .FI
3972: .IF .CSN5
3973: STNPD EQU 5 STATEMENT NO. PAD COUNT
3974: .FI
3975: *
3976: * SYNTAX TYPE CODES
3977: *
3978: * THESE CODES ARE RETURNED FROM THE SCANE PROCEDURE.
3979: *
3980: * THEY ARE SPACED 3 APART FOR THE BENEFIT OF EXPAN.
3981: *
3982: T$UOP EQU 0 UNARY OPERATOR
3983: T$LPR EQU T$UOP+3 LEFT PAREN
3984: T$LBR EQU T$LPR+3 LEFT BRACKET
3985: T$CMA EQU T$LBR+3 COMMA
3986: T$FNC EQU T$CMA+3 FUNCTION CALL
3987: T$VAR EQU T$FNC+3 VARIABLE
3988: T$CON EQU T$VAR+3 CONSTANT
3989: T$BOP EQU T$CON+3 BINARY OPERATOR
3990: T$RPR EQU T$BOP+3 RIGHT PAREN
3991: T$RBR EQU T$RPR+3 RIGHT BRACKET
3992: T$COL EQU T$RBR+3 COLON
3993: T$SMC EQU T$COL+3 SEMI-COLON
3994: *
3995: * THE FOLLOWING DEFINITIONS ARE USED ONLY IN THE GOTO FIELD
3996: *
3997: T$FGO EQU T$SMC+1 FAILURE GOTO
3998: T$SGO EQU T$FGO+1 SUCCESS GOTO
3999: *
4000: * THE ABOVE CODES ARE GROUPED SO THAT CODES FOR ELEMENTS
4001: * WHICH CAN LEGITIMATELY IMMEDIATELY PRECEDE A UNARY
4002: * OPERATOR COME FIRST TO FACILITATE OPERATOR SYNTAX CHECK.
4003: *
4004: T$UOK EQU T$FNC LAST CODE OK BEFORE UNARY OPERATOR
4005: EJC
4006: *
4007: * DEFINITIONS OF VALUES FOR EXPAN JUMP TABLE
4008: *
4009: T$UO0 EQU T$UOP+0 UNARY OPERATOR, STATE ZERO
4010: T$UO1 EQU T$UOP+1 UNARY OPERATOR, STATE ONE
4011: T$UO2 EQU T$UOP+2 UNARY OPERATOR, STATE TWO
4012: T$LP0 EQU T$LPR+0 LEFT PAREN, STATE ZERO
4013: T$LP1 EQU T$LPR+1 LEFT PAREN, STATE ONE
4014: T$LP2 EQU T$LPR+2 LEFT PAREN, STATE TWO
4015: T$LB0 EQU T$LBR+0 LEFT BRACKET, STATE ZERO
4016: T$LB1 EQU T$LBR+1 LEFT BRACKET, STATE ONE
4017: T$LB2 EQU T$LBR+2 LEFT BRACKET, STATE TWO
4018: T$CM0 EQU T$CMA+0 COMMA, STATE ZERO
4019: T$CM1 EQU T$CMA+1 COMMA, STATE ONE
4020: T$CM2 EQU T$CMA+2 COMMA, STATE TWO
4021: T$FN0 EQU T$FNC+0 FUNCTION CALL, STATE ZERO
4022: T$FN1 EQU T$FNC+1 FUNCTION CALL, STATE ONE
4023: T$FN2 EQU T$FNC+2 FUNCTION CALL, STATE TWO
4024: T$VA0 EQU T$VAR+0 VARIABLE, STATE ZERO
4025: T$VA1 EQU T$VAR+1 VARIABLE, STATE ONE
4026: T$VA2 EQU T$VAR+2 VARIABLE, STATE TWO
4027: T$CO0 EQU T$CON+0 CONSTANT, STATE ZERO
4028: T$CO1 EQU T$CON+1 CONSTANT, STATE ONE
4029: T$CO2 EQU T$CON+2 CONSTANT, STATE TWO
4030: T$BO0 EQU T$BOP+0 BINARY OPERATOR, STATE ZERO
4031: T$BO1 EQU T$BOP+1 BINARY OPERATOR, STATE ONE
4032: T$BO2 EQU T$BOP+2 BINARY OPERATOR, STATE TWO
4033: T$RP0 EQU T$RPR+0 RIGHT PAREN, STATE ZERO
4034: T$RP1 EQU T$RPR+1 RIGHT PAREN, STATE ONE
4035: T$RP2 EQU T$RPR+2 RIGHT PAREN, STATE TWO
4036: T$RB0 EQU T$RBR+0 RIGHT BRACKET, STATE ZERO
4037: T$RB1 EQU T$RBR+1 RIGHT BRACKET, STATE ONE
4038: T$RB2 EQU T$RBR+2 RIGHT BRACKET, STATE TWO
4039: T$CL0 EQU T$COL+0 COLON, STATE ZERO
4040: T$CL1 EQU T$COL+1 COLON, STATE ONE
4041: T$CL2 EQU T$COL+2 COLON, STATE TWO
4042: T$SM0 EQU T$SMC+0 SEMICOLON, STATE ZERO
4043: T$SM1 EQU T$SMC+1 SEMICOLON, STATE ONE
4044: T$SM2 EQU T$SMC+2 SEMICOLON, STATE TWO
4045: *
4046: T$NES EQU T$SM2+1 NUMBER OF ENTRIES IN BRANCH TABLE
4047: EJC
4048: *
4049: * DEFINITION OF OFFSETS USED IN CONTROL CARD PROCESSING
4050: *
4051: .IF .CULC
4052: CC$CA EQU 0 -CASE
4053: CC$DO EQU CC$CA+1 -DOUBLE
4054: .ELSE
4055: CC$DO EQU 0 -DOUBLE
4056: .FI
4057: CC$DU EQU CC$DO+1 -DUMP
4058: CC$EJ EQU CC$DU+1 -EJECT
4059: CC$ER EQU CC$EJ+1 -ERRORS
4060: CC$EX EQU CC$ER+1 -EXECUTE
4061: CC$FA EQU CC$EX+1 -FAIL
4062: CC$LI EQU CC$FA+1 -LIST
4063: CC$NR EQU CC$LI+1 -NOERRORS
4064: CC$NX EQU CC$NR+1 -NOEXECUTE
4065: CC$NF EQU CC$NX+1 -NOFAIL
4066: CC$NL EQU CC$NF+1 -NOLIST
4067: CC$NO EQU CC$NL+1 -NOOPT
4068: CC$NP EQU CC$NO+1 -NOPRINT
4069: CC$OP EQU CC$NP+1 -OPTIMISE
4070: CC$PR EQU CC$OP+1 -PRINT
4071: CC$SI EQU CC$PR+1 -SINGLE
4072: CC$SP EQU CC$SI+1 -SPACE
4073: CC$ST EQU CC$SP+1 -STITL
4074: CC$TI EQU CC$ST+1 -TITLE
4075: CC$TR EQU CC$TI+1 -TRACE
4076: CC$NC EQU CC$TR+1 NUMBER OF CONTROL CARDS
4077: CCNOC EQU 4 NO. OF CHARS INCLUDED IN MATCH
4078: CCOFS EQU 7 OFFSET TO START OF TITLE/SUBTITLE
4079: EJC
4080: *
4081: * DEFINITIONS OF STACK OFFSETS USED IN CMPIL PROCEDURE
4082: *
4083: * SEE DESCRIPTION AT START OF CMPIL PROCEDURE FOR DETAILS
4084: * OF USE OF THESE LOCATIONS ON THE STACK.
4085: *
4086: CMSTM EQU 0 TREE FOR STATEMENT BODY
4087: CMSGO EQU CMSTM+1 TREE FOR SUCCESS GOTO
4088: CMFGO EQU CMSGO+1 TREE FOR FAIL GOTO
4089: CMCGO EQU CMFGO+1 CONDITIONAL GOTO FLAG
4090: CMPCD EQU CMCGO+1 PREVIOUS CDBLK POINTER
4091: CMFFP EQU CMPCD+1 FAILURE FILL IN FLAG FOR PREVIOUS
4092: CMFFC EQU CMFFP+1 FAILURE FILL IN FLAG FOR CURRENT
4093: CMSOP EQU CMFFC+1 SUCCESS FILL IN OFFSET FOR PREVIOUS
4094: CMSOC EQU CMSOP+1 SUCCESS FILL IN OFFSET FOR CURRENT
4095: CMLBL EQU CMSOC+1 PTR TO VRBLK FOR CURRENT LABEL
4096: CMTRA EQU CMLBL+1 PTR TO ENTRY CDBLK
4097: *
4098: CMNEN EQU CMTRA+1 COUNT OF STACK ENTRIES FOR CMPIL
4099: .IF .CNPF
4100: .ELSE
4101: *
4102: * A FEW CONSTANTS USED BY THE PROFILER
4103: PFPD1 EQU 8 PAD POSITIONS ...
4104: PFPD2 EQU 20 ... FOR PROFILE ...
4105: PFPD3 EQU 32 ... PRINTOUT
4106: PF$I2 EQU CFP$I+CFP$I SIZE OF TABLE ENTRY (2 INTS)
4107: .FI
4108: *
4109: TTL S P I T B O L -- CONSTANT SECTION
4110: *
4111: * THIS SECTION CONSISTS ENTIRELY OF ASSEMBLED CONSTANTS.
4112: *
4113: * ALL LABEL NAMES ARE FIVE LETTERS. THE ORDER IS
4114: * APPROXIMATELY ALPHABETICAL, BUT IN SOME CASES (ALWAYS
4115: * DOCUMENTED), CONSTANTS MUST BE PLACED IN SOME SPECIAL
4116: * ORDER WHICH MUST NOT BE DISTURBED.
4117: *
4118: * IT MUST ALSO BE REMEMBERED THAT THERE IS A REQUIREMENT
4119: * FOR NO FORWARD REFERENCES WHICH ALSO DISTURBS THE
4120: * ALPHABETICAL ORDER IN SOME CASES.
4121: *
4122: SEC START OF CONSTANT SECTION
4123: *
4124: * FREE STORE PERCENTAGE (USED BY ALLOC)
4125: *
4126: ALFSP DAC E$FSP FREE STORE PERCENTAGE
4127: *
4128: * BIT CONSTANTS FOR GENERAL USE
4129: *
4130: BITS0 DBC 0 ALL ZERO BITS
4131: BITS1 DBC 1 ONE BIT IN LOW ORDER POSITION
4132: BITS2 DBC 2 BIT IN POSITION 2
4133: BITS3 DBC 4 BIT IN POSITION 3
4134: BITS4 DBC 8 BIT IN POSITION 4
4135: BITS5 DBC 16 BIT IN POSITION 5
4136: BITS6 DBC 32 BIT IN POSITION 6
4137: BITS7 DBC 64 BIT IN POSITION 7
4138: BITS8 DBC 128 BIT IN POSITION 8
4139: BITS9 DBC 256 BIT IN POSITION 9
4140: BIT10 DBC 512 BIT IN POSITION 10
4141: BITSM DBC CFP$M MASK FOR MAX INTEGER
4142: *
4143: * BIT CONSTANTS FOR SVBLK (SVBIT FIELD) TESTS
4144: *
4145: BTFNC DBC SVFNC BIT TO TEST FOR FUNCTION
4146: BTKNM DBC SVKNM BIT TO TEST FOR KEYWORD NUMBER
4147: BTLBL DBC SVLBL BIT TO TEST FOR LABEL
4148: BTFFC DBC SVFFC BIT TO TEST FOR FAST CALL
4149: BTCKW DBC SVCKW BIT TO TEST FOR CONSTANT KEYWORD
4150: BTPRD DBC SVPRD BIT TO TEST FOR PREDICATE FUNCTION
4151: BTPRE DBC SVPRE BIT TO TEST FOR PREEVALUATION
4152: BTVAL DBC SVVAL BIT TO TEST FOR VALUE
4153: EJC
4154: *
4155: * LIST OF NAMES USED FOR CONTROL CARD PROCESSING
4156: *
4157: .IF .CULC
4158: CCNMS DTC /CASE/
4159: DTC /DOUB/
4160: .ELSE
4161: CCNMS DTC /DOUB/
4162: .FI
4163: DTC /DUMP/
4164: DTC /EJEC/
4165: DTC /ERRO/
4166: DTC /EXEC/
4167: DTC /FAIL/
4168: DTC /LIST/
4169: DTC /NOER/
4170: DTC /NOEX/
4171: DTC /NOFA/
4172: DTC /NOLI/
4173: DTC /NOOP/
4174: DTC /NOPR/
4175: DTC /OPTI/
4176: DTC /PRIN/
4177: DTC /SING/
4178: DTC /SPAC/
4179: DTC /STIT/
4180: DTC /TITL/
4181: DTC /TRAC/
4182: *
4183: * HEADER MESSAGES FOR DUMPR PROCEDURE (SCBLK FORMAT)
4184: *
4185: DMHDK DAC B$SCL DUMP OF KEYWORD VALUES
4186: DAC 22
4187: DTC /DUMP OF KEYWORD VALUES/
4188: *
4189: DMHDV DAC B$SCL DUMP OF NATURAL VARIABLES
4190: DAC 25
4191: DTC /DUMP OF NATURAL VARIABLES/
4192: EJC
4193: *
4194: * MESSAGE TEXT FOR COMPILATION STATISTICS
4195: *
4196: ENCM1 DAC B$SCL
4197: DAC 10
4198: DTC /STORE USED/
4199: *
4200: ENCM2 DAC B$SCL
4201: DAC 10
4202: DTC /STORE LEFT/
4203: *
4204: ENCM3 DAC B$SCL
4205: DAC 11
4206: DTC /COMP ERRORS/
4207: *
4208: ENCM4 DAC B$SCL
4209: DAC 14
4210: DTC /COMP TIME-MSEC/
4211: *
4212: ENCM5 DAC B$SCL EXECUTION SUPPRESSED
4213: DAC 20
4214: DTC /EXECUTION SUPPRESSED/
4215: *
4216: * STRING CONSTANT FOR ABNORMAL END
4217: *
4218: ENDAB DAC B$SCL
4219: DAC 12
4220: DTC /ABNORMAL END/
4221: EJC
4222: *
4223: * MEMORY OVERFLOW DURING INITIALISATION
4224: *
4225: ENDMO DAC B$SCL
4226: ENDML DAC 15
4227: DTC /MEMORY OVERFLOW/
4228: *
4229: * STRING CONSTANT FOR MESSAGE ISSUED BY L$END
4230: *
4231: ENDMS DAC B$SCL
4232: DAC 10
4233: DTC /NORMAL END/
4234: *
4235: * FAIL MESSAGE FOR STACK FAIL SECTION
4236: *
4237: ENDSO DAC B$SCL STACK OVERFLOW IN GARBAGE COLLECTOR
4238: DAC 36
4239: DTC /STACK OVERFLOW IN GARBAGE COLLECTION/
4240: *
4241: * STRING CONSTANT FOR TIME UP
4242: *
4243: ENDTU DAC B$SCL
4244: DAC 15
4245: DTC /ERROR - TIME UP/
4246: EJC
4247: *
4248: * STRING CONSTANT FOR ERROR MESSAGE (ERROR SECTION)
4249: *
4250: ERMMS DAC B$SCL ERROR
4251: DAC 5
4252: DTC /ERROR/
4253: *
4254: ERMNS DAC B$SCL STRING / -- /
4255: DAC 4
4256: DTC / -- /
4257: *
4258: * STRING CONSTANT FOR PAGE NUMBERING
4259: *
4260: LSTMS DAC B$SCL PAGE
4261: DAC 5
4262: DTC /PAGE /
4263: *
4264: * LISTING HEADER MESSAGE
4265: *
4266: HEADR DAC B$SCL
4267: DAC 25
4268: DTC /MACRO SPITBOL VERSION 3.5/
4269: *
4270: HEADV DAC B$SCL FOR EXIT() VERSION NO. CHECK
4271: DAC 3
4272: DTC /3.5/
4273: *
4274: * INTEGER CONSTANTS FOR GENERAL USE
4275: * ICBLD OPTIMISATION USES THE FIRST THREE.
4276: *
4277: INT$R DAC B$ICL
4278: INTV0 DIC +0 0
4279: INTON DAC B$ICL
4280: INTV1 DIC +1 1
4281: INTTW DAC B$ICL
4282: INTV2 DIC +2 2
4283: INTVT DIC +10 10
4284: INTVH DIC +100 100
4285: INTTH DIC +1000 1000
4286: *
4287: * TABLE USED IN ICBLD OPTIMISATION
4288: *
4289: INTAB DAC INT$R POINTER TO 0
4290: DAC INTON POINTER TO 1
4291: DAC INTTW POINTER TO 2
4292: EJC
4293: *
4294: * SPECIAL PATTERN NODES. THE FOLLOWING PATTERN NODES
4295: * CONSIST SIMPLY OF A PCODE POINTER, SEE MATCH ROUTINES
4296: * (P$XXX) FOR FULL DETAILS OF THEIR USE AND FORMAT).
4297: *
4298: NDABB DAC P$ABB ARBNO
4299: NDABD DAC P$ABD ARBNO
4300: NDARC DAC P$ARC ARB
4301: NDEXB DAC P$EXB EXPRESSION
4302: NDFNB DAC P$FNB FENCE()
4303: NDFND DAC P$FND FENCE()
4304: NDEXC DAC P$EXC EXPRESSION
4305: NDIMB DAC P$IMB IMMEDIATE ASSIGNMENT
4306: NDIMD DAC P$IMD IMMEDIATE ASSIGNMENT
4307: NDNTH DAC P$NTH PATTERN END (NULL PATTERN)
4308: NDPAB DAC P$PAB PATTERN ASSIGNMENT
4309: NDPAD DAC P$PAD PATTERN ASSIGNMENT
4310: NDUNA DAC P$UNA ANCHOR POINT MOVEMENT
4311: *
4312: * KEYWORD CONSTANT PATTERN NODES. THE FOLLOWING NODES ARE
4313: * USED AS THE VALUES OF PATTERN KEYWORDS AND THE INITIAL
4314: * VALUES OF THE CORRESPONDING NATURAL VARIABLES. ALL
4315: * NODES ARE IN P0BLK FORMAT AND THE ORDER IS TIED TO THE
4316: * DEFINITIONS OF CORRESPONDING K$XXX SYMBOLS.
4317: *
4318: NDABO DAC P$ABO ABORT
4319: DAC NDNTH
4320: NDARB DAC P$ARB ARB
4321: DAC NDNTH
4322: NDBAL DAC P$BAL BAL
4323: DAC NDNTH
4324: NDFAL DAC P$FAL FAIL
4325: DAC NDNTH
4326: NDFEN DAC P$FEN FENCE
4327: DAC NDNTH
4328: NDREM DAC P$REM REM
4329: DAC NDNTH
4330: NDSUC DAC P$SUC SUCCEED
4331: DAC NDNTH
4332: *
4333: * NULL STRING. ALL NULL VALUES POINT TO THIS STRING. THE
4334: * SVCHS FIELD CONTAINS A BLANK TO PROVIDE FOR EASY DEFAULT
4335: * PROCESSING IN TRACE, STOPTR, LPAD AND RPAD.
4336: * NULLW CONTAINS 10 BLANKS WHICH ENSURES AN ALL BLANK WORD
4337: * BUT FOR VERY EXCEPTIONAL MACHINES.
4338: *
4339: NULLS DAC B$SCL NULL STRING VALUE
4340: DAC 0 SCLEN = 0
4341: NULLW DTC / /
4342: EJC
4343: *
4344: * OPERATOR DOPE VECTORS (SEE DVBLK FORMAT)
4345: *
4346: OPDVC DAC O$CNC CONCATENATION
4347: DAC C$CNC
4348: DAC LLCNC
4349: DAC RRCNC
4350: *
4351: * OPDVS IS USED WHEN SCANNING BELOW THE TOP LEVEL TO
4352: * INSURE THAT THE CONCATENATION WILL NOT BE LATER
4353: * MISTAKEN FOR PATTERN MATCHING
4354: *
4355: OPDVP DAC O$CNC CONCATENATION - NOT PATTERN MATCH
4356: DAC C$CNP
4357: DAC LLCNC
4358: DAC RRCNC
4359: *
4360: * NOTE THAT THE ORDER OF THE REMAINING ENTRIES IS TIED TO
4361: * THE ORDER OF THE CODING IN THE SCANE PROCEDURE.
4362: *
4363: OPDVS DAC O$ASS ASSIGNMENT
4364: DAC C$ASS
4365: DAC LLASS
4366: DAC RRASS
4367: *
4368: DAC 6 UNARY EQUAL
4369: DAC C$UUO
4370: DAC LLUNO
4371: *
4372: DAC O$PMV PATTERN MATCH
4373: DAC C$PMT
4374: DAC LLPMT
4375: DAC RRPMT
4376: *
4377: DAC O$INT INTERROGATION
4378: DAC C$UVL
4379: DAC LLUNO
4380: *
4381: DAC 1 BINARY AMPERSAND
4382: DAC C$UBO
4383: DAC LLAMP
4384: DAC RRAMP
4385: *
4386: DAC O$KWV KEYWORD REFERENCE
4387: DAC C$KEY
4388: DAC LLUNO
4389: *
4390: DAC O$ALT ALTERNATION
4391: DAC C$ALT
4392: DAC LLALT
4393: DAC RRALT
4394: EJC
4395: *
4396: * OPERATOR DOPE VECTORS (CONTINUED)
4397: *
4398: DAC 5 UNARY VERTICAL BAR
4399: DAC C$UUO
4400: DAC LLUNO
4401: *
4402: DAC 0 BINARY AT
4403: DAC C$UBO
4404: DAC LLATS
4405: DAC RRATS
4406: *
4407: DAC O$CAS CURSOR ASSIGNMENT
4408: DAC C$UNM
4409: DAC LLUNO
4410: *
4411: DAC 2 BINARY NUMBER SIGN
4412: DAC C$UBO
4413: DAC LLNUM
4414: DAC RRNUM
4415: *
4416: DAC 7 UNARY NUMBER SIGN
4417: DAC C$UUO
4418: DAC LLUNO
4419: *
4420: DAC O$DVD DIVISION
4421: DAC C$BVL
4422: DAC LLDVD
4423: DAC RRDVD
4424: *
4425: DAC 9 UNARY SLASH
4426: DAC C$UUO
4427: DAC LLUNO
4428: *
4429: DAC O$MLT MULTIPLICATION
4430: DAC C$BVL
4431: DAC LLMLT
4432: DAC RRMLT
4433: EJC
4434: *
4435: * OPERATOR DOPE VECTORS (CONTINUED)
4436: *
4437: DAC 0 DEFERRED EXPRESSION
4438: DAC C$DEF
4439: DAC LLUNO
4440: *
4441: DAC 3 BINARY PERCENT
4442: DAC C$UBO
4443: DAC LLPCT
4444: DAC RRPCT
4445: *
4446: DAC 8 UNARY PERCENT
4447: DAC C$UUO
4448: DAC LLUNO
4449: *
4450: DAC O$EXP EXPONENTIATION
4451: DAC C$BVL
4452: DAC LLEXP
4453: DAC RREXP
4454: *
4455: DAC 10 UNARY EXCLAMATION
4456: DAC C$UUO
4457: DAC LLUNO
4458: *
4459: DAC O$IMA IMMEDIATE ASSIGNMENT
4460: DAC C$BVN
4461: DAC LLDLD
4462: DAC RRDLD
4463: *
4464: DAC O$INV INDIRECTION
4465: DAC C$IND
4466: DAC LLUNO
4467: *
4468: DAC 4 BINARY NOT
4469: DAC C$UBO
4470: DAC LLNOT
4471: DAC RRNOT
4472: *
4473: DAC 0 NEGATION
4474: DAC C$NEG
4475: DAC LLUNO
4476: EJC
4477: *
4478: * OPERATOR DOPE VECTORS (CONTINUED)
4479: *
4480: DAC O$SUB SUBTRACTION
4481: DAC C$BVL
4482: DAC LLPLM
4483: DAC RRPLM
4484: *
4485: DAC O$COM COMPLEMENTATION
4486: DAC C$UVL
4487: DAC LLUNO
4488: *
4489: DAC O$ADD ADDITION
4490: DAC C$BVL
4491: DAC LLPLM
4492: DAC RRPLM
4493: *
4494: DAC O$AFF AFFIRMATION
4495: DAC C$UVL
4496: DAC LLUNO
4497: *
4498: DAC O$PAS PATTERN ASSIGNMENT
4499: DAC C$BVN
4500: DAC LLDLD
4501: DAC RRDLD
4502: *
4503: DAC O$NAM NAME REFERENCE
4504: DAC C$UNM
4505: DAC LLUNO
4506: *
4507: * SPECIAL DVS FOR GOTO OPERATORS (SEE PROCEDURE SCNGF)
4508: *
4509: OPDVD DAC O$GOD DIRECT GOTO
4510: DAC C$UVL
4511: DAC LLUNO
4512: *
4513: OPDVN DAC O$GOC COMPLEX NORMAL GOTO
4514: DAC C$UNM
4515: DAC LLUNO
4516: EJC
4517: *
4518: * OPERATOR ENTRY ADDRESS POINTERS, USED IN CODE
4519: *
4520: OAMN$ DAC O$AMN ARRAY REF (MULTI-SUBS BY VALUE)
4521: OAMV$ DAC O$AMV ARRAY REF (MULTI-SUBS BY VALUE)
4522: OAON$ DAC O$AON ARRAY REF (ONE SUB BY NAME)
4523: OAOV$ DAC O$AOV ARRAY REF (ONE SUB BY VALUE)
4524: OCER$ DAC O$CER COMPILATION ERROR
4525: OFEX$ DAC O$FEX FAILURE IN EXPRESSION EVALUATION
4526: OFIF$ DAC O$FIF FAILURE DURING GOTO EVALUATION
4527: OFNC$ DAC O$FNC FUNCTION CALL (MORE THAN ONE ARG)
4528: OFNE$ DAC O$FNE FUNCTION NAME ERROR
4529: OFNS$ DAC O$FNS FUNCTION CALL (SINGLE ARGUMENT)
4530: OGOF$ DAC O$GOF SET GOTO FAILURE TRAP
4531: OINN$ DAC O$INN INDIRECTION BY NAME
4532: OKWN$ DAC O$KWN KEYWORD REFERENCE BY NAME
4533: OLEX$ DAC O$LEX LOAD EXPRESSION BY NAME
4534: OLPT$ DAC O$LPT LOAD PATTERN
4535: OLVN$ DAC O$LVN LOAD VARIABLE NAME
4536: ONTA$ DAC O$NTA NEGATION, FIRST ENTRY
4537: ONTB$ DAC O$NTB NEGATION, SECOND ENTRY
4538: ONTC$ DAC O$NTC NEGATION, THIRD ENTRY
4539: OPMN$ DAC O$PMN PATTERN MATCH BY NAME
4540: OPMS$ DAC O$PMS PATTERN MATCH (STATEMENT)
4541: OPOP$ DAC O$POP POP TOP STACK ITEM
4542: ORNM$ DAC O$RNM RETURN NAME FROM EXPRESSION
4543: ORPL$ DAC O$RPL PATTERN REPLACEMENT
4544: ORVL$ DAC O$RVL RETURN VALUE FROM EXPRESSION
4545: OSLA$ DAC O$SLA SELECTION, FIRST ENTRY
4546: OSLB$ DAC O$SLB SELECTION, SECOND ENTRY
4547: OSLC$ DAC O$SLC SELECTION, THIRD ENTRY
4548: OSLD$ DAC O$SLD SELECTION, FOURTH ENTRY
4549: OSTP$ DAC O$STP STOP EXECUTION
4550: OUNF$ DAC O$UNF UNEXPECTED FAILURE
4551: EJC
4552: *
4553: * TABLE OF NAMES OF UNDEFINED BINARY OPERATORS FOR OPSYN
4554: *
4555: OPSNB DAC CH$AT AT
4556: DAC CH$AM AMPERSAND
4557: DAC CH$NM NUMBER
4558: DAC CH$PC PERCENT
4559: DAC CH$NT NOT
4560: *
4561: * TABLE OF NAMES OF UNDEFINED UNARY OPERATORS FOR OPSYN
4562: *
4563: OPNSU DAC CH$BR VERTICAL BAR
4564: DAC CH$EQ EQUAL
4565: DAC CH$NM NUMBER
4566: DAC CH$PC PERCENT
4567: DAC CH$SL SLASH
4568: DAC CH$EX EXCLAMATION
4569: .IF .CNPF
4570: .ELSE
4571: *
4572: * ADDRESS CONST CONTAINING PROFILE TABLE ENTRY SIZE
4573: *
4574: PFI2A DAC PF$I2
4575: *
4576: * PROFILER MESSAGE STRINGS
4577: *
4578: PFMS1 DAC B$SCL
4579: DAC 15
4580: DTC /PROGRAM PROFILE/
4581: PFMS2 DAC B$SCL
4582: DAC 42
4583: DTC /STMT NUMBER OF -- EXECUTION TIME --/
4584: PFMS3 DAC B$SCL
4585: DAC 47
4586: DTC /NUMBER EXECUTIONS TOTAL(MSEC) PER EXCN(MCSEC)/
4587: .FI
4588: *
4589: .IF .CNRA
4590: .ELSE
4591: *
4592: * REAL CONSTANTS FOR GENERAL USE. NOTE THAT THE CONSTANTS
4593: * STARTING AT REAV1 FORM A POWERS OF TEN TABLE (GTSTG)
4594: *
4595: REAV0 DRC +0.0 0.0
4596: REAP1 DRC +0.1 0.1
4597: REAP5 DRC +0.5 0.5
4598: REAV1 DRC +1.0 10**0
4599: REAVT DRC +1.0E+1 10**1
4600: DRC +1.0E+2 10**2
4601: DRC +1.0E+3 10**3
4602: DRC +1.0E+4 10**4
4603: DRC +1.0E+5 10**5
4604: DRC +1.0E+6 10**6
4605: DRC +1.0E+7 10**7
4606: DRC +1.0E+8 10**8
4607: DRC +1.0E+9 10**9
4608: REATT DRC +1.0E+10 10**10
4609: .FI
4610: EJC
4611: *
4612: * STRING CONSTANTS (SCBLK FORMAT) FOR DTYPE PROCEDURE
4613: *
4614: SCARR DAC B$SCL ARRAY
4615: DAC 5
4616: DTC /ARRAY/
4617: *
4618: SCBUF DAC B$SCL BUFFER
4619: DAC 6
4620: DTC /BUFFER/
4621: *
4622: SCCOD DAC B$SCL CODE
4623: DAC 4
4624: DTC /CODE/
4625: *
4626: SCEXP DAC B$SCL EXPRESSION
4627: DAC 10
4628: DTC /EXPRESSION/
4629: *
4630: SCEXT DAC B$SCL EXTERNAL
4631: DAC 8
4632: DTC /EXTERNAL/
4633: *
4634: SCINT DAC B$SCL INTEGER
4635: DAC 7
4636: DTC /INTEGER/
4637: *
4638: SCNAM DAC B$SCL NAME
4639: DAC 4
4640: DTC /NAME/
4641: *
4642: SCNUM DAC B$SCL NUMERIC
4643: DAC 7
4644: DTC /NUMERIC/
4645: *
4646: SCPAT DAC B$SCL PATTERN
4647: DAC 7
4648: DTC /PATTERN/
4649: .IF .CNRA
4650: .ELSE
4651: *
4652: SCREA DAC B$SCL REAL
4653: DAC 4
4654: DTC /REAL/
4655: .FI
4656: *
4657: SCSTR DAC B$SCL STRING
4658: DAC 6
4659: DTC /STRING/
4660: *
4661: SCTAB DAC B$SCL TABLE
4662: DAC 5
4663: DTC /TABLE/
4664: EJC
4665: *
4666: * STRING CONSTANTS (SCBLK FORMAT) FOR KVRTN (SEE RETRN)
4667: *
4668: SCFRT DAC B$SCL FRETURN
4669: DAC 7
4670: DTC /FRETURN/
4671: *
4672: SCNRT DAC B$SCL NRETURN
4673: DAC 7
4674: DTC /NRETURN/
4675: *
4676: SCRTN DAC B$SCL RETURN
4677: DAC 6
4678: DTC /RETURN/
4679: *
4680: * DATATYPE NAME TABLE FOR DTYPE PROCEDURE. THE ORDER OF
4681: * THESE ENTRIES IS TIED TO THE B$XXX DEFINITIONS FOR BLOCKS
4682: *
4683: SCNMT DAC SCARR ARBLK ARRAY
4684: .IF .CNBF
4685: .ELSE
4686: DAC SCBUF BFBLK BUFFER
4687: .FI
4688: DAC SCCOD CDBLK CODE
4689: DAC SCEXP EXBLK EXPRESSION
4690: DAC SCINT ICBLK INTEGER
4691: DAC SCNAM NMBLK NAME
4692: DAC SCPAT P0BLK PATTERN
4693: DAC SCPAT P1BLK PATTERN
4694: DAC SCPAT P2BLK PATTERN
4695: .IF .CNRA
4696: .ELSE
4697: DAC SCREA RCBLK REAL
4698: .FI
4699: DAC SCSTR SCBLK STRING
4700: DAC SCEXP SEBLK EXPRESSION
4701: DAC SCTAB TBBLK TABLE
4702: DAC SCARR VCBLK ARRAY
4703: DAC SCEXT XNBLK EXTERNAL
4704: DAC SCEXT XRBLK EXTERNAL
4705: *
4706: .IF .CNRA
4707: .ELSE
4708: * STRING CONSTANT FOR REAL ZERO
4709: *
4710: SCRE0 DAC B$SCL
4711: DAC 2
4712: DTC /0./
4713: .FI
4714: EJC
4715: *
4716: * USED TO RE-INITIALISE KVSTL
4717: *
4718: STLIM DIC +50000 DEFAULT STATEMENT LIMIT
4719: *
4720: * DUMMY FUNCTION BLOCK USED FOR UNDEFINED FUNCTIONS
4721: *
4722: STNDF DAC O$FUN PTR TO UNDEFINED FUNCTION ERR CALL
4723: DAC 0 DUMMY FARGS COUNT FOR CALL CIRCUIT
4724: *
4725: * DUMMY CODE BLOCK USED FOR UNDEFINED LABELS
4726: *
4727: STNDL DAC L$UND CODE PTR POINTS TO UNDEFINED LBL
4728: *
4729: * DUMMY OPERATOR BLOCK USED FOR UNDEFINED OPERATORS
4730: *
4731: STNDO DAC O$OUN PTR TO UNDEFINED OPERATOR ERR CALL
4732: DAC 0 DUMMY FARGS COUNT FOR CALL CIRCUIT
4733: *
4734: * STANDARD VARIABLE BLOCK. THIS BLOCK IS USED TO INITIALIZE
4735: * THE FIRST SEVEN FIELDS OF A NEWLY CONSTRUCTED VRBLK.
4736: * ITS FORMAT IS TIED TO THE VRBLK DEFINITIONS (SEE GTNVR).
4737: *
4738: STNVR DAC B$VRL VRGET
4739: DAC B$VRS VRSTO
4740: DAC NULLS VRVAL
4741: DAC B$VRG VRTRA
4742: DAC STNDL VRLBL
4743: DAC STNDF VRFNC
4744: DAC 0 VRNXT
4745: EJC
4746: *
4747: * MESSAGES USED IN END OF RUN PROCESSING (STOPR)
4748: *
4749: STPM1 DAC B$SCL IN STATEMENT
4750: DAC 12
4751: DTC /IN STATEMENT/
4752: *
4753: STPM2 DAC B$SCL
4754: DAC 14
4755: DTC /STMTS EXECUTED/
4756: *
4757: STPM3 DAC B$SCL
4758: DAC 13
4759: DTC /RUN TIME-MSEC/
4760: *
4761: STPM4 DAC B$SCL
4762: DAC 12
4763: DTC $MCSEC / STMT$
4764: *
4765: STPM5 DAC B$SCL
4766: DAC 13
4767: DTC /REGENERATIONS/
4768: *
4769: * CHARS FOR /TU/ ENDING CODE
4770: *
4771: STRTU DTC /TU/
4772: *
4773: * TABLE USED BY CONVERT FUNCTION TO CHECK DATATYPE NAME
4774: * THE ENTRIES ARE ORDERED TO CORRESPOND TO BRANCH TABLE
4775: * IN S$CNV
4776: *
4777: SVCTB DAC SCSTR STRING
4778: DAC SCINT INTEGER
4779: DAC SCNAM NAME
4780: DAC SCPAT PATTERN
4781: DAC SCARR ARRAY
4782: DAC SCTAB TABLE
4783: DAC SCEXP EXPRESSION
4784: DAC SCCOD CODE
4785: DAC SCNUM NUMERIC
4786: .IF .CNRA
4787: .ELSE
4788: DAC SCREA REAL
4789: .FI
4790: .IF .CNBF
4791: .ELSE
4792: DAC SCBUF BUFFER
4793: .FI
4794: DAC 0 ZERO MARKS END OF LIST
4795: EJC
4796: *
4797: * MESSAGES (SCBLK FORMAT) USED BY TRACE PROCEDURES
4798: *
4799: *
4800: TMASB DAC B$SCL ASTERISKS FOR TRACE STATEMENT NO
4801: DAC 13
4802: DTC /************ /
4803:
4804: *
4805: TMBEB DAC B$SCL BLANK-EQUAL-BLANK
4806: DAC 3
4807: DTC / = /
4808: *
4809: * DUMMY TRBLK FOR EXPRESSION VARIABLE
4810: *
4811: TRBEV DAC B$TRT DUMMY TRBLK
4812: *
4813: * DUMMY TRBLK FOR KEYWORD VARIABLE
4814: *
4815: TRBKV DAC B$TRT DUMMY TRBLK
4816: *
4817: * DUMMY CODE BLOCK TO RETURN CONTROL TO TRXEQ PROCEDURE
4818: *
4819: TRXDR DAC O$TXR BLOCK POINTS TO RETURN ROUTINE
4820: TRXDC DAC TRXDR POINTER TO BLOCK
4821: EJC
4822: *
4823: * STANDARD VARIABLE BLOCKS
4824: *
4825: * SEE SVBLK FORMAT FOR FULL DETAILS OF THE FORMAT. THE
4826: * VRBLKS ARE ORDERED BY LENGTH AND WITHIN EACH LENGTH THE
4827: * ORDER IS ALPHABETICAL BY NAME OF THE VARIABLE.
4828: *
4829: V$EQF DBC SVFPR EQ
4830: DAC 2
4831: DTC /EQ/
4832: DAC S$EQF
4833: DAC 2
4834: *
4835: V$GEF DBC SVFPR GE
4836: DAC 2
4837: DTC /GE/
4838: DAC S$GEF
4839: DAC 2
4840: *
4841: V$GTF DBC SVFPR GT
4842: DAC 2
4843: DTC /GT/
4844: DAC S$GTF
4845: DAC 2
4846: *
4847: V$LEF DBC SVFPR LE
4848: DAC 2
4849: DTC /LE/
4850: DAC S$LEF
4851: DAC 2
4852: *
4853: V$LTF DBC SVFPR LT
4854: DAC 2
4855: DTC /LT/
4856: DAC S$LTF
4857: DAC 2
4858: *
4859: V$NEF DBC SVFPR NE
4860: DAC 2
4861: DTC /NE/
4862: DAC S$NEF
4863: DAC 2
4864: *
4865: V$ANY DBC SVFNP ANY
4866: DAC 3
4867: DTC /ANY/
4868: DAC S$ANY
4869: DAC 1
4870: *
4871: V$ARB DBC SVKVC ARB
4872: DAC 3
4873: DTC /ARB/
4874: DAC K$ARB
4875: DAC NDARB
4876: EJC
4877: *
4878: * STANDARD VARIABLE BLOCKS (CONTINUED)
4879: *
4880: V$ARG DBC SVFNN ARG
4881: DAC 3
4882: DTC /ARG/
4883: DAC S$ARG
4884: DAC 2
4885: *
4886: V$BAL DBC SVKVC BAL
4887: DAC 3
4888: DTC /BAL/
4889: DAC K$BAL
4890: DAC NDBAL
4891: *
4892: V$END DBC SVLBL END
4893: DAC 3
4894: DTC /END/
4895: DAC L$END
4896: *
4897: V$LEN DBC SVFNP LEN
4898: DAC 3
4899: DTC /LEN/
4900: DAC S$LEN
4901: DAC 1
4902: *
4903: V$LEQ DBC SVFPR LEQ
4904: DAC 3
4905: DTC /LEQ/
4906: DAC S$LEQ
4907: DAC 2
4908: *
4909: V$LGE DBC SVFPR LGE
4910: DAC 3
4911: DTC /LGE/
4912: DAC S$LGE
4913: DAC 2
4914: *
4915: V$LGT DBC SVFPR LGT
4916: DAC 3
4917: DTC /LGT/
4918: DAC S$LGT
4919: DAC 2
4920: *
4921: V$LLE DBC SVFPR LLE
4922: DAC 3
4923: DTC /LLE/
4924: DAC S$LLE
4925: DAC 2
4926: EJC
4927: *
4928: * STANDARD VARIABLE BLOCKS (CONTINUED)
4929: *
4930: V$LLT DBC SVFPR LLT
4931: DAC 3
4932: DTC /LLT/
4933: DAC S$LLT
4934: DAC 2
4935: *
4936: V$LNE DBC SVFPR LNE
4937: DAC 3
4938: DTC /LNE/
4939: DAC S$LNE
4940: DAC 2
4941: *
4942: V$POS DBC SVFNP POS
4943: DAC 3
4944: DTC /POS/
4945: DAC S$POS
4946: DAC 1
4947: *
4948: V$REM DBC SVKVC REM
4949: DAC 3
4950: DTC /REM/
4951: DAC K$REM
4952: DAC NDREM
4953: .IF .CUST
4954: *
4955: V$SET DBC SVFNN SET
4956: DAC 3
4957: DTC /SET/
4958: DAC S$SET
4959: DAC 3
4960: .FI
4961: *
4962: V$TAB DBC SVFNP TAB
4963: DAC 3
4964: DTC /TAB/
4965: DAC S$TAB
4966: DAC 1
4967: .IF .CULC
4968: *
4969: V$CAS DBC SVKNM CASE
4970: DAC 4
4971: DTC /CASE/
4972: DAC K$CAS
4973: .FI
4974: *
4975: V$CHR DBC SVFNP CHAR
4976: DAC 4
4977: DTC /CHAR/
4978: DAC S$CHR
4979: DAC 1
4980: *
4981: V$COD DBC SVFNK CODE
4982: DAC 4
4983: DTC /CODE/
4984: DAC K$COD
4985: DAC S$COD
4986: DAC 1
4987: *
4988: V$COP DBC SVFNN COPY
4989: DAC 4
4990: DTC /COPY/
4991: DAC S$COP
4992: DAC 1
4993: EJC
4994: *
4995: * STANDARD VARIABLE BLOCKS (CONTINUED)
4996: *
4997: V$DAT DBC SVFNN DATA
4998: DAC 4
4999: DTC /DATA/
5000: DAC S$DAT
5001: DAC 1
5002: *
5003: V$DTE DBC SVFNN DATE
5004: DAC 4
5005: DTC /DATE/
5006: DAC S$DTE
5007: DAC 0
5008: *
5009: V$DMP DBC SVFNK DUMP
5010: DAC 4
5011: DTC /DUMP/
5012: DAC K$DMP
5013: DAC S$DMP
5014: DAC 1
5015: *
5016: V$DUP DBC SVFNN DUPL
5017: DAC 4
5018: DTC /DUPL/
5019: DAC S$DUP
5020: DAC 2
5021: *
5022: V$EVL DBC SVFNN EVAL
5023: DAC 4
5024: DTC /EVAL/
5025: DAC S$EVL
5026: DAC 1
5027: .IF .CNEX
5028: .ELSE
5029: *
5030: V$EXT DBC SVFNN EXIT
5031: DAC 4
5032: DTC /EXIT/
5033: DAC S$EXT
5034: DAC 1
5035: .FI
5036: *
5037: V$FAL DBC SVKVC FAIL
5038: DAC 4
5039: DTC /FAIL/
5040: DAC K$FAL
5041: DAC NDFAL
5042: *
5043: V$HST DBC SVFNN HOST
5044: DAC 4
5045: DTC /HOST/
5046: DAC S$HST
5047: DAC 3
5048: EJC
5049: *
5050: * STANDARD VARIABLE BLOCKS (CONTINUED)
5051: *
5052: V$ITM DBC SVFNF ITEM
5053: DAC 4
5054: DTC /ITEM/
5055: DAC S$ITM
5056: DAC 999
5057: .IF .CNLD
5058: .ELSE
5059: *
5060: V$LOD DBC SVFNN LOAD
5061: DAC 4
5062: DTC /LOAD/
5063: DAC S$LOD
5064: DAC 2
5065: .FI
5066: *
5067: V$LPD DBC SVFNP LPAD
5068: DAC 4
5069: DTC /LPAD/
5070: DAC S$LPD
5071: DAC 3
5072: *
5073: V$RPD DBC SVFNP RPAD
5074: DAC 4
5075: DTC /RPAD/
5076: DAC S$RPD
5077: DAC 3
5078: *
5079: V$RPS DBC SVFNP RPOS
5080: DAC 4
5081: DTC /RPOS/
5082: DAC S$RPS
5083: DAC 1
5084: *
5085: V$RTB DBC SVFNP RTAB
5086: DAC 4
5087: DTC /RTAB/
5088: DAC S$RTB
5089: DAC 1
5090: *
5091: V$SI$ DBC SVFNP SIZE
5092: DAC 4
5093: DTC /SIZE/
5094: DAC S$SI$
5095: DAC 1
5096: *
5097: .IF .CNSR
5098: .ELSE
5099: *
5100: V$SRT DBC SVFNN SORT
5101: DAC 4
5102: DTC /SORT/
5103: DAC S$SRT
5104: DAC 2
5105: .FI
5106: V$SPN DBC SVFNP SPAN
5107: DAC 4
5108: DTC /SPAN/
5109: DAC S$SPN
5110: DAC 1
5111: EJC
5112: *
5113: * STANDARD VARIABLE BLOCKS (CONTINUED)
5114: *
5115: V$STN DBC SVKNM STNO
5116: DAC 4
5117: DTC /STNO/
5118: DAC K$STN
5119: *
5120: V$TIM DBC SVFNN TIME
5121: DAC 4
5122: DTC /TIME/
5123: DAC S$TIM
5124: DAC 0
5125: *
5126: V$TRM DBC SVFNK TRIM
5127: DAC 4
5128: DTC /TRIM/
5129: DAC K$TRM
5130: DAC S$TRM
5131: DAC 1
5132: *
5133: V$ABE DBC SVKNM ABEND
5134: DAC 5
5135: DTC /ABEND/
5136: DAC K$ABE
5137: *
5138: V$ABO DBC SVKVL ABORT
5139: DAC 5
5140: DTC /ABORT/
5141: DAC K$ABO
5142: DAC L$ABO
5143: DAC NDABO
5144: *
5145: V$APP DBC SVFNF APPLY
5146: DAC 5
5147: DTC /APPLY/
5148: DAC S$APP
5149: DAC 999
5150: *
5151: V$ABN DBC SVFNP ARBNO
5152: DAC 5
5153: DTC /ARBNO/
5154: DAC S$ABN
5155: DAC 1
5156: *
5157: V$ARR DBC SVFNN ARRAY
5158: DAC 5
5159: DTC /ARRAY/
5160: DAC S$ARR
5161: DAC 2
5162: EJC
5163: *
5164: * STANDARD VARIABLE BLOCKS (CONTINUED)
5165: *
5166: V$BRK DBC SVFNP BREAK
5167: DAC 5
5168: DTC /BREAK/
5169: DAC S$BRK
5170: DAC 1
5171: *
5172: V$CLR DBC SVFNN CLEAR
5173: DAC 5
5174: DTC /CLEAR/
5175: DAC S$CLR
5176: DAC 1
5177: *
5178: V$EJC DBC SVFNN EJECT
5179: DAC 5
5180: DTC /EJECT/
5181: DAC S$EJC
5182: DAC 1
5183: *
5184: V$FEN DBC SVFPK FENCE
5185: DAC 5
5186: DTC /FENCE/
5187: DAC K$FEN
5188: DAC S$FNC
5189: DAC 1
5190: DAC NDFEN
5191: *
5192: V$FLD DBC SVFNN FIELD
5193: DAC 5
5194: DTC /FIELD/
5195: DAC S$FLD
5196: DAC 2
5197: *
5198: V$IDN DBC SVFPR IDENT
5199: DAC 5
5200: DTC /IDENT/
5201: DAC S$IDN
5202: DAC 2
5203: *
5204: V$INP DBC SVFNK INPUT
5205: DAC 5
5206: DTC /INPUT/
5207: DAC K$INP
5208: DAC S$INP
5209: DAC 3
5210: *
5211: V$LOC DBC SVFNN LOCAL
5212: DAC 5
5213: DTC /LOCAL/
5214: DAC S$LOC
5215: DAC 2
5216: EJC
5217: *
5218: * STANDARD VARIABLE BLOCKS (CONTINUED)
5219: *
5220: V$OPS DBC SVFNN OPSYN
5221: DAC 5
5222: DTC /OPSYN/
5223: DAC S$OPS
5224: DAC 3
5225: *
5226: V$RMD DBC SVFNP REMDR
5227: DAC 5
5228: DTC /REMDR/
5229: DAC S$RMD
5230: DAC 2
5231: .IF .CNSR
5232: .ELSE
5233: *
5234: V$RSR DBC SVFNN RSORT
5235: DAC 5
5236: DTC /RSORT/
5237: DAC S$RSR
5238: DAC 2
5239: .FI
5240: *
5241: V$TBL DBC SVFNN TABLE
5242: DAC 5
5243: DTC /TABLE/
5244: DAC S$TBL
5245: DAC 3
5246: *
5247: V$TRA DBC SVFNK TRACE
5248: DAC 5
5249: DTC /TRACE/
5250: DAC K$TRA
5251: DAC S$TRA
5252: DAC 4
5253: *
5254: V$ANC DBC SVKNM ANCHOR
5255: DAC 6
5256: DTC /ANCHOR/
5257: DAC K$ANC
5258: .IF .CNBF
5259: .ELSE
5260: *
5261: V$APN DBC SVFNN
5262: DAC 6
5263: DTC /APPEND/
5264: DAC S$APN
5265: DAC 2
5266: .FI
5267: *
5268: V$BKX DBC SVFNP BREAKX
5269: DAC 6
5270: DTC /BREAKX/
5271: DAC S$BKX
5272: DAC 1
5273: *
5274: .IF .CNBF
5275: .ELSE
5276: V$BUF DBC SVFNN BUFFER
5277: DAC 6
5278: DTC /BUFFER/
5279: DAC S$BUF
5280: DAC 2
5281: .FI
5282: *
5283: V$DEF DBC SVFNN DEFINE
5284: DAC 6
5285: DTC /DEFINE/
5286: DAC S$DEF
5287: DAC 2
5288: *
5289: V$DET DBC SVFNN DETACH
5290: DAC 6
5291: DTC /DETACH/
5292: DAC S$DET
5293: DAC 1
5294: EJC
5295: *
5296: * STANDARD VARIABLE BLOCKS (CONTINUED)
5297: *
5298: V$DIF DBC SVFPR DIFFER
5299: DAC 6
5300: DTC /DIFFER/
5301: DAC S$DIF
5302: DAC 2
5303: *
5304: V$FTR DBC SVKNM FTRACE
5305: DAC 6
5306: DTC /FTRACE/
5307: DAC K$FTR
5308: *
5309: .IF .CNBF
5310: .ELSE
5311: V$INS DBC SVFNN INSERT
5312: DAC 6
5313: DTC /INSERT/
5314: DAC S$INS
5315: DAC 4
5316: *
5317: .FI
5318: V$LST DBC SVKNM LASTNO
5319: DAC 6
5320: DTC /LASTNO/
5321: DAC K$LST
5322: *
5323: V$NAY DBC SVFNP NOTANY
5324: DAC 6
5325: DTC /NOTANY/
5326: DAC S$NAY
5327: DAC 1
5328: *
5329: V$OUP DBC SVFNK OUTPUT
5330: DAC 6
5331: DTC /OUTPUT/
5332: DAC K$OUP
5333: DAC S$OUP
5334: DAC 3
5335: *
5336: V$RET DBC SVLBL RETURN
5337: DAC 6
5338: DTC /RETURN/
5339: DAC L$RTN
5340: *
5341: V$REW DBC SVFNN REWIND
5342: DAC 6
5343: DTC /REWIND/
5344: DAC S$REW
5345: DAC 1
5346: *
5347: V$STT DBC SVFNN STOPTR
5348: DAC 6
5349: DTC /STOPTR/
5350: DAC S$STT
5351: DAC 2
5352: EJC
5353: *
5354: * STANDARD VARIABLE BLOCKS (CONTINUED)
5355: *
5356: V$SUB DBC SVFNN SUBSTR
5357: DAC 6
5358: DTC /SUBSTR/
5359: DAC S$SUB
5360: DAC 3
5361: *
5362: V$UNL DBC SVFNN UNLOAD
5363: DAC 6
5364: DTC /UNLOAD/
5365: DAC S$UNL
5366: DAC 1
5367: *
5368: V$COL DBC SVFNN COLLECT
5369: DAC 7
5370: DTC /COLLECT/
5371: DAC S$COL
5372: DAC 1
5373: *
5374: V$CNV DBC SVFNN CONVERT
5375: DAC 7
5376: DTC /CONVERT/
5377: DAC S$CNV
5378: DAC 2
5379: *
5380: V$ENF DBC SVFNN ENDFILE
5381: DAC 7
5382: DTC /ENDFILE/
5383: DAC S$ENF
5384: DAC 1
5385: *
5386: V$ETX DBC SVKNM ERRTEXT
5387: DAC 7
5388: DTC /ERRTEXT/
5389: DAC K$ETX
5390: *
5391: V$ERT DBC SVKNM ERRTYPE
5392: DAC 7
5393: DTC /ERRTYPE/
5394: DAC K$ERT
5395: *
5396: V$FRT DBC SVLBL FRETURN
5397: DAC 7
5398: DTC /FRETURN/
5399: DAC L$FRT
5400: *
5401: V$INT DBC SVFPR INTEGER
5402: DAC 7
5403: DTC /INTEGER/
5404: DAC S$INT
5405: DAC 1
5406: *
5407: V$NRT DBC SVLBL NRETURN
5408: DAC 7
5409: DTC /NRETURN/
5410: DAC L$NRT
5411: EJC
5412: *
5413: * STANDARD VARIABLE BLOCKS (CONTINUED)
5414: *
5415: .IF .CNPF
5416: .ELSE
5417: *
5418: V$PFL DBC SVKNM PROFILE
5419: DAC 7
5420: DTC /PROFILE/
5421: DAC K$PFL
5422: .FI
5423: *
5424: V$RPL DBC SVFNP REPLACE
5425: DAC 7
5426: DTC /REPLACE/
5427: DAC S$RPL
5428: DAC 3
5429: *
5430: V$RVS DBC SVFNP REVERSE
5431: DAC 7
5432: DTC /REVERSE/
5433: DAC S$RVS
5434: DAC 1
5435: *
5436: V$RTN DBC SVKNM RTNTYPE
5437: DAC 7
5438: DTC /RTNTYPE/
5439: DAC K$RTN
5440: *
5441: V$STX DBC SVFNN SETEXIT
5442: DAC 7
5443: DTC /SETEXIT/
5444: DAC S$STX
5445: DAC 1
5446: *
5447: V$STC DBC SVKNM STCOUNT
5448: DAC 7
5449: DTC /STCOUNT/
5450: DAC K$STC
5451: *
5452: V$STL DBC SVKNM STLIMIT
5453: DAC 7
5454: DTC /STLIMIT/
5455: DAC K$STL
5456: *
5457: V$SUC DBC SVKVC SUCCEED
5458: DAC 7
5459: DTC /SUCCEED/
5460: DAC K$SUC
5461: DAC NDSUC
5462: *
5463: V$ALP DBC SVKWC ALPHABET
5464: DAC 8
5465: DTC /ALPHABET/
5466: DAC K$ALP
5467: *
5468: V$CNT DBC SVLBL CONTINUE
5469: DAC 8
5470: DTC /CONTINUE/
5471: DAC L$CNT
5472: EJC
5473: *
5474: * STANDARD VARIABLE BLOCKS (CONTINUED)
5475: *
5476: V$DTP DBC SVFNP DATATYPE
5477: DAC 8
5478: DTC /DATATYPE/
5479: DAC S$DTP
5480: DAC 1
5481: *
5482: V$ERL DBC SVKNM ERRLIMIT
5483: DAC 8
5484: DTC /ERRLIMIT/
5485: DAC K$ERL
5486: *
5487: V$FNC DBC SVKNM FNCLEVEL
5488: DAC 8
5489: DTC /FNCLEVEL/
5490: DAC K$FNC
5491: *
5492: V$MXL DBC SVKNM MAXLNGTH
5493: DAC 8
5494: DTC /MAXLNGTH/
5495: DAC K$MXL
5496: *
5497: V$TER DBC 0 TERMINAL
5498: DAC 8
5499: DTC /TERMINAL/
5500: DAC 0
5501: *
5502: V$PRO DBC SVFNN PROTOTYPE
5503: DAC 9
5504: DTC /PROTOTYPE/
5505: DAC S$PRO
5506: DAC 1
5507: *
5508: DBC 0 DUMMY ENTRY TO END LIST
5509: DAC 10 LENGTH GT 9 (PROTOTYPE)
5510: EJC
5511: *
5512: * LIST OF SVBLK POINTERS FOR KEYWORDS TO BE DUMPED. THE
5513: * LIST IS IN THE ORDER WHICH APPEARS ON THE DUMP OUTPUT.
5514: *
5515: VDMKW DAC V$ANC ANCHOR
5516: .IF .CULC
5517: DAC V$CAS CCASE
5518: .FI
5519: DAC V$COD CODE
5520: DAC V$DMP DUMP
5521: DAC V$ERL ERRLIMIT
5522: DAC V$ETX ERRTEXT
5523: DAC V$ERT ERRTYPE
5524: DAC V$FNC FNCLEVEL
5525: DAC V$FTR FTRACE
5526: DAC V$INP INPUT
5527: DAC V$LST LASTNO
5528: DAC V$MXL MAXLENGTH
5529: DAC V$OUP OUTPUT
5530: .IF .CNPF
5531: .ELSE
5532: DAC V$PFL PROFILE
5533: .FI
5534: DAC V$RTN RTNTYPE
5535: DAC V$STC STCOUNT
5536: DAC V$STL STLIMIT
5537: DAC V$STN STNO
5538: DAC V$TRA TRACE
5539: DAC V$TRM TRIM
5540: DAC 0 END OF LIST
5541: *
5542: * TABLE USED BY GTNVR TO SEARCH SVBLK LISTS
5543: *
5544: VSRCH DAC 0 DUMMY ENTRY TO GET PROPER INDEXING
5545: DAC V$EQF START OF 1 CHAR VARIABLES (NONE)
5546: DAC V$EQF START OF 2 CHAR VARIABLES
5547: DAC V$ANY START OF 3 CHAR VARIABLES
5548: .IF .CULC
5549: DAC V$CAS START OF 4 CHAR VARIABLES
5550: .ELSE
5551: DAC V$CHR START OF 4 CHAR VARIABLES
5552: .FI
5553: DAC V$ABE START OF 5 CHAR VARIABLES
5554: DAC V$ANC START OF 6 CHAR VARIABLES
5555: DAC V$COL START OF 7 CHAR VARIABLES
5556: DAC V$ALP START OF 8 CHAR VARIABLES
5557: DAC V$PRO START OF 9 CHAR VARIABLES
5558: TTL S P I T B O L -- WORKING STORAGE SECTION
5559: *
5560: * THE WORKING STORAGE SECTION CONTAINS AREAS WHICH ARE
5561: * CHANGED DURING EXECUTION OF THE PROGRAM. THE VALUE
5562: * ASSEMBLED IS THE INITIAL VALUE BEFORE EXECUTION STARTS.
5563: *
5564: * ALL THESE AREAS ARE FIXED LENGTH AREAS. VARIABLE LENGTH
5565: * DATA IS STORED IN THE STATIC OR DYNAMIC REGIONS OF THE
5566: * ALLOCATED DATA AREAS.
5567: *
5568: * THE VALUES IN THIS AREA ARE DESCRIBED EITHER AS WORK
5569: * AREAS OR AS GLOBAL VALUES. A WORK AREA IS USED IN AN
5570: * EPHEMERAL MANNER AND THE VALUE IS NOT SAVED FROM ONE
5571: * ENTRY INTO A ROUTINE TO ANOTHER. A GLOBAL VALUE IS A
5572: * LESS TEMPORARY LOCATION WHOSE VALUE IS SAVED FROM ONE
5573: * CALL TO ANOTHER.
5574: *
5575: * A GENERAL PART OF THE APPROACH IN THIS PROGRAM IS NOT
5576: * TO OVERLAP WORK AREAS BETWEEN PROCEDURES EVEN THOUGH A
5577: * SMALL AMOUNT OF SPACE COULD BE SAVED. SUCH OVERLAP IS
5578: * CONSIDERED A SOURCE OF PROGRAM ERRORS AND DECREASES THE
5579: * INFORMATION LEFT BEHIND AFTER A SYSTEM CRASH OF ANY KIND.
5580: *
5581: * THE NAMES OF THESE LOCATIONS ARE LABELS WITH FIVE LETTER
5582: * (A-Y,$) NAMES. AS FAR AS POSSIBLE THE ORDER IS KEPT
5583: * ALPHABETICAL BY THESE NAMES BUT IN SOME CASES THERE
5584: * ARE SLIGHT DEPARTURES CAUSED BY OTHER ORDER REQUIREMENTS.
5585: *
5586: * UNLESS OTHERWISE DOCUMENTED, THE ORDER OF WORK AREAS
5587: * DOES NOT AFFECT THE EXECUTION OF THE SPITBOL PROGRAM.
5588: *
5589: SEC START OF WORKING STORAGE SECTION
5590: EJC
5591: *
5592: * THIS AREA IS NOT CLEARED BY INITIAL CODE
5593: *
5594: CMLAB DAC B$SCL STRING USED TO CHECK LABEL LEGALITY
5595: DAC 2
5596: DTC / /
5597: *
5598: * LABEL TO MARK START OF WORK AREA
5599: *
5600: AAAAA DAC 0
5601: *
5602: * WORK AREAS FOR ALLOC PROCEDURE
5603: *
5604: ALDYN DAC 0 AMOUNT OF DYNAMIC STORE
5605: ALFSF DIC +0 FACTOR IN FREE STORE PCNTAGE CHECK
5606: ALLIA DIC +0 DUMP IA
5607: ALLSV DAC 0 SAVE WB IN ALLOC
5608: *
5609: * WORK AREAS FOR ALOST PROCEDURE
5610: *
5611: ALSTA DAC 0 SAVE WA IN ALOST
5612: *
5613: * SAVE AREAS FOR ARRAY FUNCTION (S$ARR)
5614: *
5615: ARCDM DAC 0 COUNT DIMENSIONS
5616: ARNEL DIC +0 COUNT ELEMENTS
5617: ARPTR DAC 0 OFFSET PTR INTO ARBLK
5618: ARSVL DIC +0 SAVE INTEGER LOW BOUND
5619: EJC
5620: * WORK AREAS FOR ARREF ROUTINE
5621: *
5622: ARFSI DIC +0 SAVE CURRENT EVOLVING SUBSCRIPT
5623: ARFXS DAC 0 SAVE BASE STACK POINTER
5624: *
5625: * WORK AREAS FOR B$EFC BLOCK ROUTINE
5626: *
5627: BEFOF DAC 0 SAVE OFFSET PTR INTO EFBLK
5628: *
5629: * WORK AREAS FOR B$PFC BLOCK ROUTINE
5630: *
5631: BPFPF DAC 0 SAVE PFBLK POINTER
5632: BPFSV DAC 0 SAVE OLD FUNCTION VALUE
5633: BPFXT DAC 0 POINTER TO STACKED ARGUMENTS
5634: *
5635: * SAVE AREAS FOR COLLECT FUNCTION (S$COL)
5636: *
5637: CLSVI DIC +0 SAVE INTEGER ARGUMENT
5638: *
5639: * GLOBAL VALUES FOR CMPIL PROCEDURE
5640: *
5641: CMERC DAC 0 COUNT OF INITIAL COMPILE ERRORS
5642: CMPXS DAC 0 SAVE STACK PTR IN CASE OF ERRORS
5643: CMPSN DAC 1 NUMBER OF NEXT STATEMENT TO COMPILE
5644: CMPSS DAC 0 SAVE SUBROUTINE STACK PTR
5645: *
5646: * WORK AREA FOR CNCRD
5647: *
5648: CNSCC DAC 0 POINTER TO CONTROL CARD STRING
5649: CNSWC DAC 0 WORD COUNT
5650: CNR$T DAC 0 POINTER TO R$TTL OR R$STL
5651: CNTTL DAC 0 FLAG FOR -TITLE, -STITL
5652: *
5653: * WORK AREAS FOR CONVERT FUNCTION (S$CNV)
5654: *
5655: CNVTP DAC 0 SAVE PTR INTO SCVTB
5656: *
5657: * FLAG FOR SUPPRESSION OF COMPILATION STATISTICS.
5658: *
5659: CPSTS DAC 0 SUPPRESS COMP. STATS IF NON ZERO
5660: *
5661: * GLOBAL VALUES FOR CONTROL CARD SWITCHES
5662: *
5663: CSWDB DAC 0 0/1 FOR -SINGLE/-DOUBLE
5664: CSWER DAC 0 0/1 FOR -ERRORS/-NOERRORS
5665: CSWEX DAC 0 0/1 FOR -EXECUTE/-NOEXECUTE
5666: CSWFL DAC 1 0/1 FOR -NOFAIL/-FAIL
5667: CSWIN DAC INILN XXX FOR -INXXX
5668: CSWLS DAC 1 0/1 FOR -NOLIST/-LIST
5669: CSWNO DAC 0 0/1 FOR -OPTIMISE/-NOOPT
5670: CSWPR DAC 0 0/1 FOR -NOPRINT/-PRINT
5671: *
5672: * GLOBAL LOCATION USED BY PATST PROCEDURE
5673: *
5674: CTMSK DBC 0 LAST BIT POSITION USED IN R$CTP
5675: CURID DAC 0 CURRENT ID VALUE
5676: EJC
5677: *
5678: * GLOBAL VALUE FOR CDWRD PROCEDURE
5679: *
5680: CWCOF DAC 0 NEXT WORD OFFSET IN CURRENT CCBLK
5681: *
5682: * WORK AREAS FOR DATA FUNCTION (S$DAT)
5683: *
5684: DATDV DAC 0 SAVE VRBLK PTR FOR DATATYPE NAME
5685: DATXS DAC 0 SAVE INITIAL STACK POINTER
5686: *
5687: * WORK AREAS FOR DEFINE FUNCTION (S$DEF)
5688: *
5689: DEFLB DAC 0 SAVE VRBLK PTR FOR LABEL
5690: DEFNA DAC 0 COUNT FUNCTION ARGUMENTS
5691: DEFVR DAC 0 SAVE VRBLK PTR FOR FUNCTION NAME
5692: DEFXS DAC 0 SAVE INITIAL STACK POINTER
5693: *
5694: * WORK AREAS FOR DUMPR PROCEDURE
5695: *
5696: DMARG DAC 0 DUMP ARGUMENT
5697: DMPKB DAC B$KVT DUMMY KVBLK FOR USE IN DUMPR
5698: DMPKT DAC TRBKV KVVAR TRBLK POINTER
5699: DMPKN DAC 0 KEYWORD NUMBER (MUST FOLLOW DMPKB)
5700: DMPSA DAC 0 PRESERVE WA OVER PRTVL CALL
5701: DMPSV DAC 0 GENERAL SCRATCH SAVE
5702: DMVCH DAC 0 CHAIN POINTER FOR VARIABLE BLOCKS
5703: DMPCH DAC 0 SAVE SORTED VRBLK CHAIN POINTER
5704: *
5705: * GLOBAL LOCATIONS FOR DYNAMIC STORAGE POINTERS
5706: *
5707: DNAMB DAC 0 START OF DYNAMIC AREA
5708: DNAMP DAC 0 NEXT AVAILABLE LOC IN DYNAMIC AREA
5709: DNAME DAC 0 END OF AVAILABLE DYNAMIC AREA
5710: *
5711: * WORK AREA FOR DTACH
5712: *
5713: DTCNB DAC 0 NAME BASE
5714: DTCNM DAC 0 NAME PTR
5715: *
5716: * WORK AREAS FOR DUPL FUNCTION (S$DUP)
5717: *
5718: DUPSI DIC +0 STORE INTEGER STRING LENGTH
5719: *
5720: * WORK AREA FOR ENDFILE (S$ENF)
5721: *
5722: ENFCH DAC 0 FOR IOCHN CHAIN HEAD
5723: *
5724: * WORK AREA FOR ERROR PROCESSING.
5725: *
5726: ERICH DAC 0 COPY ERROR REPORTS TO INT.CHAN IF 1
5727: ERLST DAC 0 FOR LISTR WHEN ERRORS GO TO INT.CH.
5728: ERRFT DAC 0 FATAL ERROR FLAG
5729: ERRSP DAC 0 ERROR SUPPRESSION FLAG
5730: EJC
5731: *
5732: * DUMP AREA FOR ERTEX
5733: *
5734: ERTWA DAC 0 SAVE WA
5735: ERTWB DAC 0 SAVE WB
5736: *
5737: * GLOBAL VALUES FOR EVALI
5738: *
5739: EVLIN DAC P$LEN DUMMY PATTERN BLOCK PCODE
5740: EVLIS DAC 0 POINTER TO SUBSEQUENT NODE
5741: EVLIV DAC 0 VALUE OF PARAMETER
5742: * WORK AREA FOR EXPAN
5743: *
5744: EXPSV DAC 0 SAVE OP DOPE VECTOR POINTER
5745: *
5746: * FLAG FOR SUPPRESSION OF EXECUTION STATS
5747: *
5748: EXSTS DAC 0 SUPPRESS EXEC STATS IF SET
5749: *
5750: * GLOBAL VALUES FOR EXFAL AND RETURN
5751: *
5752: FLPRT DAC 0 LOCATION OF FAIL OFFSET FOR RETURN
5753: FLPTR DAC 0 LOCATION OF FAILURE OFFSET ON STACK
5754: *
5755: * WORK AREAS FOR GBCOL PROCEDURE
5756: *
5757: GBCFL DAC 0 GARBAGE COLLECTOR ACTIVE FLAG
5758: GBCLM DAC 0 POINTER TO LAST MOVE BLOCK (PASS 3)
5759: GBCNM DAC 0 DUMMY FIRST MOVE BLOCK
5760: GBCNS DAC 0 REST OF DUMMY BLOCK (FOLLOWS GBCNM)
5761: GBSVA DAC 0 SAVE WA
5762: GBSVB DAC 0 SAVE WB
5763: GBSVC DAC 0 SAVE WC
5764: *
5765: * GLOBAL LOCATION TO COUNT GARBAGE COLLECTIONS (GBCOL)
5766: *
5767: GBCNT DAC 0 COUNT OF GARBAGE COLLECTIONS
5768: *
5769: * WORK AREAS FOR GTNVR PROCEDURE
5770: *
5771: GNVHE DAC 0 PTR TO END OF HASH CHAIN
5772: GNVNW DAC 0 NUMBER OF WORDS IN STRING NAME
5773: GNVSA DAC 0 SAVE WA
5774: GNVSB DAC 0 SAVE WB
5775: GNVSP DAC 0 POINTER INTO VSRCH TABLE
5776: GNVST DAC 0 POINTER TO CHARS OF STRING
5777: *
5778: * GLOBAL VALUE FOR GTCOD AND GTEXP
5779: *
5780: GTCEF DAC 0 SAVE FAIL PTR IN CASE OF ERROR
5781: *
5782: * WORK AREAS FOR GTINT
5783: *
5784: GTINA DAC 0 SAVE WA
5785: GTINB DAC 0 SAVE WB
5786: EJC
5787: *
5788: * WORK AREAS FOR GTNUM PROCEDURE
5789: *
5790: GTNNF DAC 0 ZERO/NONZERO FOR RESULT +/-
5791: GTNSI DIC +0 GENERAL INTEGER SAVE
5792: .IF .CNRA
5793: .ELSE
5794: GTNDF DAC 0 0/1 FOR DEC POINT SO FAR NO/YES
5795: GTNES DAC 0 ZERO/NONZERO EXPONENT +/-
5796: GTNEX DIC +0 REAL EXPONENT
5797: GTNSC DAC 0 SCALE (PLACES AFTER POINT)
5798: GTNSR DRC +0.0 GENERAL REAL SAVE
5799: GTNRD DAC 0 FLAG FOR OK REAL NUMBER
5800: .FI
5801: *
5802: * WORK AREAS FOR GTPAT PROCEDURE
5803: *
5804: GTPSB DAC 0 SAVE WB
5805: *
5806: * WORK AREAS FOR GTSTG PROCEDURE
5807: *
5808: GTSSF DAC 0 0/1 FOR RESULT +/-
5809: GTSVC DAC 0 SAVE WC
5810: GTSVB DAC 0 SAVE WB
5811: GTSWK DAC 0 PTR TO WORK AREA FOR GTSTG
5812: .IF .CNRA
5813: .ELSE
5814: GTSES DAC 0 CHAR + OR - FOR EXPONENT +/-
5815: GTSRS DRC +0.0 GENERAL REAL SAVE
5816: *
5817: * GLOBAL LOCATIONS (CONSTANTS) FOR GTSTG PROCEDURE
5818: *
5819: GTSRN DRC +0.0 ROUNDING FACTOR 0.5*10**-CFP$S
5820: GTSSC DRC +0.0 SCALING VALUE 10**CFP$S
5821: .FI
5822: *
5823: * WORK AREAS FOR GTVAR PROCEDURE
5824: *
5825: GTVRC DAC 0 SAVE WC
5826: *
5827: * FLAG FOR HEADER PRINTING
5828: *
5829: HEADP DAC 0 HEADER PRINTED FLAG
5830: *
5831: * GLOBAL VALUES FOR VARIABLE HASH TABLE
5832: *
5833: HSHNB DIC +0 NUMBER OF HASH BUCKETS
5834: HSHTB DAC 0 POINTER TO START OF VRBLK HASH TABL
5835: HSHTE DAC 0 POINTER PAST END OF VRBLK HASH TABL
5836: *
5837: * WORK AREA FOR INIT
5838: *
5839: INISS DAC 0 SAVE SUBROUTINE STACK PTR
5840: INITR DAC 0 SAVE TERMINAL FLAG
5841: .IF .CNBF
5842: .ELSE
5843: *
5844: * SAVE AREA FOR INSBF
5845: *
5846: INSAB DAC 0 ENTRY WA + ENTRY WB
5847: INSSA DAC 0 SAVE ENTRY WA
5848: INSSB DAC 0 SAVE ENTRY WB
5849: INSSC DAC 0 SAVE ENTRY WC
5850: .FI
5851: *
5852: * WORK AREAS FOR IOPUT
5853: *
5854: IOPTT DAC 0 TYPE OF ASSOCIATION
5855: EJC
5856: *
5857: * GLOBAL VALUES FOR KEYWORD VALUES WHICH ARE STORED AS ONE
5858: * WORD INTEGERS. THESE VALUES MUST BE ASSEMBLED IN THE
5859: * FOLLOWING ORDER (AS DICTATED BY K$XXX DEFINITION VALUES).
5860: *
5861: KVABE DAC 0 ABEND
5862: KVANC DAC 0 ANCHOR
5863: .IF .CULC
5864: KVCAS DAC 0 CASE
5865: .FI
5866: KVCOD DAC 0 CODE
5867: KVDMP DAC 0 DUMP
5868: KVERL DAC 0 ERRLIMIT
5869: KVERT DAC 0 ERRTYPE
5870: KVFTR DAC 0 FTRACE
5871: KVINP DAC 1 INPUT
5872: KVMXL DAC 5000 MAXLENGTH
5873: KVOUP DAC 1 OUTPUT
5874: .IF .CNPF
5875: .ELSE
5876: KVPFL DAC 0 PROFILE
5877: .FI
5878: KVTRA DAC 0 TRACE
5879: KVTRM DAC 0 TRIM
5880: KVFNC DAC 0 FNCLEVEL
5881: KVLST DAC 0 LASTNO
5882: KVSTN DAC 0 STNO
5883: *
5884: * GLOBAL VALUES FOR OTHER KEYWORDS
5885: *
5886: KVALP DAC 0 ALPHABET
5887: KVRTN DAC NULLS RTNTYPE (SCBLK POINTER)
5888: KVSTL DIC +50000 STLIMIT
5889: KVSTC DIC +50000 STCOUNT (COUNTS DOWN FROM STLIMIT)
5890: .IF .CNLD
5891: .ELSE
5892: *
5893: * WORK AREAS FOR LOAD FUNCTION
5894: *
5895: LODFN DAC 0 POINTER TO VRBLK FOR FUNC NAME
5896: LODNA DAC 0 COUNT NUMBER OF ARGUMENTS
5897: .FI
5898: *
5899: * GLOBAL VALUES FOR LISTR PROCEDURE
5900: *
5901: LSTLC DAC 0 COUNT LINES ON SOURCE LIST PAGE
5902: LSTNP DAC 0 MAX NUMBER OF LINES ON PAGE
5903: LSTPF DAC 1 SET NONZERO IF CURRENT IMAGE LISTED
5904: LSTPG DAC 0 CURRENT SOURCE LIST PAGE NUMBER
5905: LSTPO DAC 0 OFFSET TO PAGE NNN MESSAGE
5906: LSTSN DAC 0 REMEMBER LAST STMNUM LISTED
5907: *
5908: * MAXIMUM SIZE OF SPITBOL OBJECTS
5909: *
5910: MXLEN DAC 0 INITIALISED BY SYSMX CALL
5911: *
5912: * EXECUTION CONTROL VARIABLE
5913: *
5914: NOXEQ DAC 0 SET NON-ZERO TO INHIBIT EXECUTION
5915: .IF .CNPF
5916: .ELSE
5917: *
5918: * PROFILER GLOBAL VALUES AND WORK LOCATIONS
5919: *
5920: PFDMP DAC 0 SET NON-0 IF &PROFILE SET NON-0
5921: PFFNC DAC 0 SET NON-0 IF FUNCT JUST ENTERED
5922: PFSTM DIC +0 TO STORE STARTING TIME OF STMT
5923: PFETM DIC +0 TO STORE ENDING TIME OF STMT
5924: PFSVW DAC 0 TO SAVE A W-REG
5925: PFTBL DAC 0 GETS ADRS OF (IMAG) TABLE BASE
5926: PFNTE DAC 0 NR OF TABLE ENTRIES
5927: PFSTE DIC +0 GETS INT REP OF TABLE ENTRY SIZE
5928: .FI
5929: *
5930: EJC
5931: *
5932: * GLOBAL VALUES USED IN PATTERN MATCH ROUTINES
5933: *
5934: PMDFL DAC 0 PATTERN ASSIGNMENT FLAG
5935: PMHBS DAC 0 HISTORY STACK BASE POINTER
5936: PMSSL DAC 0 LENGTH OF SUBJECT STRING IN CHARS
5937: *
5938: * FLAGS USED FOR STANDARD FILE LISTING OPTIONS
5939: *
5940: PRICH DAC 0 PRINTER ON INTERACTIVE CHANNEL
5941: PRSTD DAC 0 TESTED BY PRTPG
5942: PRSTO DAC 0 STANDARD LISTING OPTION FLAG
5943: *
5944: * GLOBAL VALUE FOR PRTNM PROCEDURE
5945: *
5946: PRNMV DAC 0 VRBLK PTR FROM LAST NAME SEARCH
5947: *
5948: * WORK AREAS FOR PRTNM PROCEDURE
5949: *
5950: PRNSI DIC +0 SCRATCH INTEGER LOC
5951: *
5952: * WORK AREAS FOR PRTSN PROCEDURE
5953: *
5954: PRSNA DAC 0 SAVE WA
5955: *
5956: * GLOBAL VALUES FOR PRINT PROCEDURES
5957: *
5958: PRBUF DAC 0 PTR TO PRINT BFR IN STATIC
5959: PRECL DAC 0 EXTENDED/COMPACT LISTING FLAG
5960: PRLEN DAC 0 LENGTH OF PRINT BUFFER IN CHARS
5961: PRLNW DAC 0 LENGTH OF PRINT BUFFER IN WORDS
5962: PROFS DAC 0 OFFSET TO NEXT LOCATION IN PRBUF
5963: PRTEF DAC 0 ENDFILE FLAG
5964: *
5965: * WORK AREAS FOR PRTST PROCEDURE
5966: *
5967: PRSVA DAC 0 SAVE WA
5968: PRSVB DAC 0 SAVE WB
5969: PRSVC DAC 0 SAVE CHAR COUNTER
5970: *
5971: * WORK AREA FOR PRTNL
5972: *
5973: PRTSA DAC 0 SAVE WA
5974: PRTSB DAC 0 SAVE WB
5975: *
5976: * WORK AREA FOR PRTVL
5977: *
5978: PRVSI DAC 0 SAVE IDVAL
5979: *
5980: * WORK AREAS FOR PATTERN MATCH ROUTINES
5981: *
5982: PSAVE DAC 0 TEMPORARY SAVE FOR CURRENT NODE PTR
5983: PSAVC DAC 0 SAVE CURSOR IN P$SPN, P$STR
5984: EJC
5985: *
5986: * AMOUNT OF MEMORY RESERVED FOR END OF EXECUTION
5987: *
5988: RSMEM DAC 0 RESERVE MEMORY
5989: *
5990: * WORK AREAS FOR RETRN ROUTINE
5991: *
5992: RTNBP DAC 0 TO SAVE A BLOCK POINTER
5993: RTNFV DAC 0 NEW FUNCTION VALUE (RESULT)
5994: RTNSV DAC 0 OLD FUNCTION VALUE (SAVED VALUE)
5995: *
5996: * RELOCATABLE GLOBAL VALUES
5997: *
5998: * ALL THE POINTERS IN THIS SECTION CAN POINT TO BLOCKS IN
5999: * THE DYNAMIC STORAGE AREA AND MUST BE RELOCATED BY THE
6000: * GARBAGE COLLECTOR. THEY ARE IDENTIFIED BY R$XXX NAMES.
6001: *
6002: R$AAA DAC 0 START OF RELOCATABLE VALUES
6003: R$ARF DAC 0 ARRAY BLOCK POINTER FOR ARREF
6004: R$CCB DAC 0 PTR TO CCBLK BEING BUILT (CDWRD)
6005: R$CIM DAC 0 PTR TO CURRENT COMPILER INPUT STR
6006: R$CMP DAC 0 COPY OF R$CIM USED IN CMPIL
6007: R$CNI DAC 0 PTR TO NEXT COMPILER INPUT STRING
6008: R$CNT DAC 0 CDBLK POINTER FOR SETEXIT CONTINUE
6009: R$COD DAC 0 POINTER TO CURRENT CDBLK OR EXBLK
6010: R$CTP DAC 0 PTR TO CURRENT CTBLK FOR PATST
6011: R$ERT DAC 0 TRBLK POINTER FOR ERRTYPE TRACE
6012: R$ETX DAC NULLS POINTER TO ERRTEXT STRING
6013: R$EXS DAC 0 = SAVE XL IN EXPDM
6014: R$FCB DAC 0 FCBLK CHAIN HEAD
6015: R$FNC DAC 0 TRBLK POINTER FOR FNCLEVEL TRACE
6016: R$GTC DAC 0 KEEP CODE PTR FOR GTCOD,GTEXP
6017: R$IO1 DAC 0 FILE ARG1 FOR IOPUT
6018: R$IO2 DAC 0 FILE ARG2 FOR IOPUT
6019: R$IOF DAC 0 FCBLK PTR OR 0
6020: R$ION DAC 0 NAME BASE PTR
6021: R$IOP DAC 0 PREDECESSOR BLOCK PTR FOR IOPUT
6022: R$IOT DAC 0 TRBLK PTR FOR IOPUT
6023: .IF .CNBF
6024: .ELSE
6025: R$PMB DAC 0 BUFFER PTR IN PATTERN MATCH
6026: .FI
6027: R$PMS DAC 0 SUBJECT STRING PTR IN PATTERN MATCH
6028: R$RA2 DAC 0 REPLACE SECOND ARGUMENT LAST TIME
6029: R$RA3 DAC 0 REPLACE THIRD ARGUMENT LAST TIME
6030: R$RPT DAC 0 PTR TO CTBLK REPLACE TABLE LAST USD
6031: R$SCP DAC 0 SAVE POINTER FROM LAST SCANE CALL
6032: R$SXL DAC 0 PRESERVE XL IN SORTC
6033: R$SXR DAC 0 PRESERVE XR IN SORTA/SORTC
6034: R$STC DAC 0 TRBLK POINTER FOR STCOUNT TRACE
6035: R$STL DAC 0 SOURCE LISTING SUB-TITLE
6036: R$SXC DAC 0 CODE (CDBLK) PTR FOR SETEXIT TRAP
6037: R$TTL DAC NULLS SOURCE LISTING TITLE
6038: R$XSC DAC 0 STRING POINTER FOR XSCAN
6039: EJC
6040: *
6041: * THE REMAINING POINTERS IN THIS LIST ARE USED TO POINT
6042: * TO FUNCTION BLOCKS FOR NORMALLY UNDEFINED OPERATORS.
6043: *
6044: R$UBA DAC STNDO BINARY AT
6045: R$UBM DAC STNDO BINARY AMPERSAND
6046: R$UBN DAC STNDO BINARY NUMBER SIGN
6047: R$UBP DAC STNDO BINARY PERCENT
6048: R$UBT DAC STNDO BINARY NOT
6049: R$UUB DAC STNDO UNARY VERTICAL BAR
6050: R$UUE DAC STNDO UNARY EQUAL
6051: R$UUN DAC STNDO UNARY NUMBER SIGN
6052: R$UUP DAC STNDO UNARY PERCENT
6053: R$UUS DAC STNDO UNARY SLASH
6054: R$UUX DAC STNDO UNARY EXCLAMATION
6055: R$YYY DAC 0 LAST RELOCATABLE LOCATION
6056: *
6057: * WORK AREAS FOR SUBSTR FUNCTION (S$SUB)
6058: *
6059: SBSSV DAC 0 SAVE THIRD ARGUMENT
6060: *
6061: * GLOBAL LOCATIONS USED IN SCAN PROCEDURE
6062: *
6063: SCNBL DAC 0 SET NON-ZERO IF SCANNED PAST BLANKS
6064: SCNCC DAC 0 NON-ZERO TO SCAN CONTROL CARD NAME
6065: SCNGO DAC 0 SET NON-ZERO TO SCAN GOTO FIELD
6066: SCNIL DAC 0 LENGTH OF CURRENT INPUT IMAGE
6067: SCNPT DAC 0 POINTER TO NEXT LOCATION IN R$CIM
6068: SCNRS DAC 0 SET NON-ZERO TO SIGNAL RESCAN
6069: SCNTP DAC 0 SAVE SYNTAX TYPE FROM LAST CALL
6070: *
6071: * WORK AREAS FOR SCAN PROCEDURE
6072: *
6073: SCNSA DAC 0 SAVE WA
6074: SCNSB DAC 0 SAVE WB
6075: SCNSC DAC 0 SAVE WC
6076: SCNSE DAC 0 START OF CURRENT ELEMENT
6077: SCNOF DAC 0 SAVE OFFSET
6078: .IF .CNSR
6079: .ELSE
6080: EJC
6081: *
6082: * WORK AREA USED BY SORTA, SORTC, SORTF, SORTH
6083: *
6084: SRTDF DAC 0 DATATYPE FIELD NAME
6085: SRTFD DAC 0 FOUND DFBLK ADDRESS
6086: SRTFF DAC 0 FOUND FIELD NAME
6087: SRTFO DAC 0 OFFSET TO FIELD NAME
6088: SRTNR DAC 0 NUMBER OF ROWS
6089: SRTOF DAC 0 OFFSET WITHIN ROW TO SORT KEY
6090: SRTRT DAC 0 ROOT OFFSET
6091: SRTS1 DAC 0 SAVE OFFSET 1
6092: SRTS2 DAC 0 SAVE OFFSET 2
6093: SRTSC DAC 0 SAVE WC
6094: SRTSF DAC 0 SORT ARRAY FIRST ROW OFFSET
6095: SRTSN DAC 0 SAVE N
6096: SRTSO DAC 0 OFFSET TO A(0)
6097: SRTSR DAC 0 0 , NON-ZERO FOR SORT, RSORT
6098: SRTST DAC 0 STRIDE FROM ONE ROW TO NEXT
6099: SRTWC DAC 0 DUMP WC
6100: .FI
6101: *
6102: * GLOBAL VALUE FOR INDICATING STAGE (SEE ERROR SECTION)
6103: *
6104: STAGE DAC 0 INITIAL VALUE = INITIAL COMPILE
6105: *
6106: * GLOBAL VALUES DEFINING EXTENT OF STATIC AREA (ALOST)
6107: *
6108: STATB DAC 0 START OF STATIC AREA
6109: STATE DAC 0 END OF STATIC AREA
6110: EJC
6111: *
6112: * GLOBAL STACK POINTER
6113: *
6114: STBAS DAC 0 POINTER PAST STACK BASE
6115: *
6116: * WORK AREAS FOR STOPR ROUTINE
6117: *
6118: STPSI DIC +0 SAVE VALUE OF STCOUNT
6119: STPTI DIC +0 SAVE TIME ELAPSED
6120: *
6121: * GLOBAL VALUES FOR SETEXIT FUNCTION (S$STX)
6122: *
6123: STXOF DAC 0 FAILURE OFFSET
6124: STXVR DAC NULLS VRBLK POINTER OR NULL
6125: *
6126: * WORK AREAS FOR TFIND PROCEDURE
6127: *
6128: TFNSI DIC +0 NUMBER OF HEADERS
6129: *
6130: * GLOBAL VALUE FOR TIME KEEPING
6131: *
6132: TIMSX DIC +0 TIME AT START OF EXECUTION
6133: TIMUP DAC 0 SET WHEN TIME UP OCCURS
6134: *
6135: * WORK AREAS FOR XSCAN PROCEDURE
6136: *
6137: XSCRT DAC 0 SAVE RETURN CODE
6138: XSCWB DAC 0 SAVE REGISTER WB
6139: *
6140: * GLOBAL VALUES FOR XSCAN AND XSCNI PROCEDURES
6141: *
6142: XSOFS DAC 0 OFFSET TO CURRENT LOCATION IN R$XSC
6143: *
6144: * LABEL TO MARK END OF WORK AREA
6145: *
6146: YYYYY DAC 0
6147: TTL S P I T B O L -- INITIALIZATION
6148: *
6149: * INITIALISATION
6150: * THE FOLLOWING SECTION RECEIVES CONTROL FROM THE SYSTEM
6151: * AT THE START OF A RUN WITH THE REGISTERS SET AS FOLLOWS.
6152: *
6153: * (XS) POINTS PAST STACK BASE
6154: * (XR) POINTS TO FIRST WORD OF DATA AREA
6155: * (XL) POINTS TO LAST WORD OF DATA AREA
6156: *
6157: SEC START OF PROGRAM SECTION
6158: JSR SYSTM INITIALISE TIMER
6159: .IF .CNBT
6160: STI TIMSX STORE TIME
6161: MOV XR,STATB START ADDRESS OF STATIC
6162: .ELSE
6163: *
6164: * INITIALISE WORK AREA (ESSENTIAL FOR BATCHED RUNS)
6165: *
6166: MOV XR,WB PRESERVE XR
6167: MOV =YYYYY,WA POINT TO END OF WORK AREA
6168: SUB =AAAAA,WA GET LENGTH OF WORK AREA
6169: BTW WA CONVERT TO WORDS
6170: LCT WA,WA COUNT FOR LOOP
6171: MOV =AAAAA,XR SET UP INDEX REGISTER
6172: *
6173: * CLEAR WORK SPACE
6174: *
6175: INI01 ZER (XR)+ CLEAR A WORD
6176: BCT WA,INI01 LOOP TILL DONE
6177: MOV =STNDO,WA UNDEFINED OPERATORS POINTER
6178: MOV =R$YYY,WC POINT TO TABLE END
6179: SUB =R$UBA,WC LENGTH OF UNDEF. OPERATORS TABLE
6180: BTW WC CONVERT TO WORDS
6181: LCT WC,WC LOOP COUNTER
6182: MOV =R$UBA,XR SET UP XR
6183: *
6184: * SET CORRECT VALUE INTO UNDEFINED OPERATORS TABLE
6185: *
6186: INI02 MOV WA,(XR)+ STORE VALUE
6187: BCT WC,INI02 LOOP TILL ALL DONE
6188: MOV =NUM01,WA GET A 1
6189: MOV WA,CMPSN STATEMENT NO
6190: MOV WA,CSWFL NOFAIL
6191: MOV WA,CSWLS LIST
6192: MOV WA,KVINP INPUT
6193: MOV WA,KVOUP OUTPUT
6194: MOV WA,LSTPF NOTHING FOR LISTR YET
6195: MOV =INILN,WA INPUT IMAGE LENGTH
6196: MOV WA,CSWIN -IN72
6197: MOV =B$KVT,DMPKB DUMP
6198: MOV =TRBKV,DMPKT DUMP
6199: MOV =P$LEN,EVLIN EVAL
6200: EJC
6201: MOV =NULLS,WA GET NULLSTRING POINTER
6202: MOV WA,KVRTN RETURN
6203: MOV WA,R$ETX ERRTEXT
6204: MOV WA,R$TTL TITLE FOR LISTING
6205: MOV WA,STXVR SETEXIT
6206: STI TIMSX STORE TIME IN CORRECT PLACE
6207: LDI STLIM GET DEFAULT STLIMIT
6208: STI KVSTL STATEMENT LIMIT
6209: STI KVSTC STATEMENT COUNT
6210: MOV WB,STATB STORE START ADRS OF STATIC
6211: .FI
6212: MOV *E$SRS,RSMEM RESERVE MEMORY
6213: MOV XS,STBAS STORE STACK BASE
6214: SSS INISS SAVE S-R STACK PTR
6215: *
6216: * NOW CONVERT FREE STORE PERCENTAGE TO A SUITABLE FACTOR
6217: * FOR EASY TESTING IN ALLOC ROUTINE.
6218: *
6219: LDI INTVH GET 100
6220: DVI ALFSP FORM 100 / ALFSP
6221: STI ALFSF STORE THE FACTOR
6222: .IF .CNRA
6223: .ELSE
6224: *
6225: * INITIALIZE VALUES FOR REAL CONVERSION ROUTINE
6226: *
6227: LCT WB,=CFP$S LOAD COUNTER FOR SIGNIFICANT DIGITS
6228: LDR REAV1 LOAD 1.0
6229: *
6230: * LOOP TO COMPUTE 10**(MAX NUMBER SIGNIFICANT DIGITS)
6231: *
6232: INI03 MLR REAVT * 10.0
6233: BCT WB,INI03 LOOP TILL DONE
6234: STR GTSSC STORE 10**(MAX SIG DIGITS)
6235: LDR REAP5 LOAD 0.5
6236: DVR GTSSC COMPUTE 0.5*10**(MAX SIG DIGITS)
6237: STR GTSRN STORE AS ROUNDING BIAS
6238: .FI
6239: ZER WC SET TO READ PARAMETERS
6240: JSR PRPAR READ THEM
6241: EJC
6242: *
6243: * NOW COMPUTE STARTING ADDRESS FOR DYNAMIC STORE AND IF
6244: * NECESSARY REQUEST MORE MEMORY.
6245: *
6246: SUB *E$SRS,XL ALLOW FOR RESERVE MEMORY
6247: MOV PRLEN,WA GET PRINT BUFFER LENGTH
6248: ADD =CFP$A,WA ADD NO. OF CHARS IN ALPHABET
6249: ADD =NSTMX,WA ADD CHARS FOR GTSTG BFR
6250: CTB WA,8 CONVERT TO BYTES, ALLOWING A MARGIN
6251: MOV STATB,XR POINT TO STATIC BASE
6252: ADD WA,XR INCREMENT FOR ABOVE BUFFERS
6253: ADD *E$HNB,XR INCREMENT FOR HASH TABLE
6254: ADD *E$STS,XR BUMP FOR INITIAL STATIC BLOCK
6255: JSR SYSMX GET MXLEN
6256: MOV WA,KVMXL PROVISIONALLY STORE AS MAXLNGTH
6257: MOV WA,MXLEN AND AS MXLEN
6258: BGT XR,WA,INI06 SKIP IF STATIC HI EXCEEDS MXLEN
6259: MOV WA,XR USE MXLEN INSTEAD
6260: ICA XR MAKE BIGGER THAN MXLEN
6261: *
6262: * HERE TO STORE VALUES WHICH MARK INITIAL DIVISION
6263: * OF DATA AREA INTO STATIC AND DYNAMIC
6264: *
6265: INI06 MOV XR,DNAMB DYNAMIC BASE ADRS
6266: MOV XR,DNAMP DYNAMIC PTR
6267: BNZ WA,INI07 SKIP IF NON-ZERO MXLEN
6268: DCA XR POINT A WORD IN FRONT
6269: MOV XR,KVMXL USE AS MAXLNGTH
6270: MOV XR,MXLEN AND AS MXLEN
6271: EJC
6272: *
6273: * LOOP HERE IF NECESSARY TILL ENOUGH MEMORY OBTAINED
6274: * SO THAT DNAME IS ABOVE DNAMB
6275: *
6276: INI07 MOV XL,DNAME STORE DYNAMIC END ADDRESS
6277: BLT DNAMB,XL,INI09 SKIP IF HIGH ENOUGH
6278: JSR SYSMM REQUEST MORE MEMORY
6279: WTB XR GET AS BAUS (SGD05)
6280: ADD XR,XL BUMP BY AMOUNT OBTAINED
6281: BNZ XR,INI07 TRY AGAIN
6282: MOV =ENDMO,XR POINT TO FAILURE MESSAGE
6283: MOV ENDML,WA MESSAGE LENGTH
6284: JSR SYSPR PRINT IT (PRTST NOT YET USABLE)
6285: PPM SHOULD NOT FAIL
6286: JSR SYSEJ PACK UP (STOPR NOT YET USABLE)
6287: *
6288: * INITIALISE PRINT BUFFER WITH BLANK WORDS
6289: *
6290: INI09 MOV PRLEN,WC NO. OF CHARS IN PRINT BFR
6291: MOV STATB,XR POINT TO STATIC AGAIN
6292: MOV XR,PRBUF PRINT BFR IS PUT AT STATIC START
6293: MOV =B$SCL,(XR)+ STORE STRING TYPE CODE
6294: MOV WC,(XR)+ AND STRING LENGTH
6295: CTW WC,0 GET NUMBER OF WORDS IN BUFFER
6296: MOV WC,PRLNW STORE FOR BUFFER CLEAR
6297: LCT WC,WC WORDS TO CLEAR
6298: *
6299: * LOOP TO CLEAR BUFFER
6300: *
6301: INI10 MOV NULLW,(XR)+ STORE BLANK
6302: BCT WC,INI10 LOOP
6303: *
6304: * INITIALIZE NUMBER OF HASH HEADERS
6305: *
6306: MOV =E$HNB,WA GET NUMBER OF HASH HEADERS
6307: MTI WA CONVERT TO INTEGER
6308: STI HSHNB STORE FOR USE BY GTNVR PROCEDURE
6309: LCT WA,WA COUNTER FOR CLEARING HASH TABLE
6310: MOV XR,HSHTB POINTER TO HASH TABLE
6311: *
6312: * LOOP TO CLEAR HASH TABLE
6313: *
6314: INI11 ZER (XR)+ BLANK A WORD
6315: BCT WA,INI11 LOOP
6316: MOV XR,HSHTE END OF HASH TABLE ADRS IS KEPT
6317: *
6318: * ALLOCATE WORK AREA FOR GTSTG CONVERSION PROCEDURE
6319: *
6320: MOV =NSTMX,WA GET MAX NUM CHARS IN OUTPUT NUMBER
6321: CTB WA,SCSI$ NO OF BYTES NEEDED
6322: MOV XR,GTSWK STORE BFR ADRS
6323: ADD WA,XR BUMP FOR WORK BFR
6324: EJC
6325: *
6326: * BUILD ALPHABET STRING FOR ALPHABET KEYWORD AND REPLACE
6327: *
6328: MOV XR,KVALP SAVE ALPHABET POINTER
6329: MOV =B$SCL,(XR) STRING BLK TYPE
6330: MOV =CFP$A,WC NO OF CHARS IN ALPHABET
6331: MOV WC,SCLEN(XR) STORE AS STRING LENGTH
6332: MOV WC,WB COPY CHAR COUNT
6333: CTB WB,SCSI$ NO. OF BYTES NEEDED
6334: ADD XR,WB CURRENT END ADDRESS FOR STATIC
6335: MOV WB,STATE STORE STATIC END ADRS
6336: LCT WC,WC LOOP COUNTER
6337: PSC XR POINT TO CHARS OF STRING
6338: ZER WB SET INITIAL CHARACTER VALUE
6339: *
6340: * LOOP TO ENTER CHARACTER CODES IN ORDER
6341: *
6342: INI12 SCH WB,(XR)+ STORE NEXT CODE
6343: ICV WB BUMP CODE VALUE
6344: BCT WC,INI12 LOOP TILL ALL STORED
6345: CSC XR COMPLETE STORE CHARACTERS
6346: *
6347: * INITIALIZE VARIABLE BLOCKS FOR INPUT AND OUTPUT
6348: *
6349: MOV =V$INP,XL POINT TO STRING /INPUT/
6350: MOV =TRTIN,WB TRBLK TYPE FOR INPUT
6351: JSR INOUT PERFORM INPUT ASSOCIATION
6352: MOV =V$OUP,XL POINT TO STRING /OUTPUT/
6353: MOV =TRTOU,WB TRBLK TYPE FOR OUTPUT
6354: JSR INOUT PERFORM OUTPUT ASSOCIATION
6355: MOV INITR,WC TERMINAL FLAG
6356: BZE WC,INI13 SKIP IF NO TERMINAL
6357: JSR PRPAR ASSOCIATE TERMINAL
6358: EJC
6359: *
6360: * CHECK FOR EXPIRY DATE
6361: *
6362: INI13 JSR SYSDC CALL DATE CHECK
6363: MOV XS,FLPTR IN CASE STACK OVERFLOWS IN COMPILER
6364: *
6365: * NOW COMPILE SOURCE INPUT CODE
6366: *
6367: JSR CMPIL CALL COMPILER
6368: MOV XR,R$COD SET PTR TO FIRST CODE BLOCK
6369: MOV =NULLS,R$TTL FORGET TITLE (REG04)
6370: MOV =NULLS,R$STL FORGET SUB-TITLE (REG04)
6371: ZER R$CIM FORGET COMPILER INPUT IMAGE
6372: ZER XL CLEAR DUD VALUE
6373: ZER WB DONT SHIFT DYNAMIC STORE UP
6374: JSR GBCOL CLEAR GARBAGE LEFT FROM COMPILE
6375: BNZ CPSTS,INIX0 SKIP IF NO LISTING OF COMP STATS
6376: JSR PRTPG EJECT PAGE
6377: *
6378: * PRINT COMPILE STATISTICS
6379: *
6380: MOV DNAMP,WA NEXT AVAILABLE LOC
6381: SUB STATB,WA MINUS START
6382: BTW WA CONVERT TO WORDS
6383: MTI WA CONVERT TO INTEGER
6384: MOV =ENCM1,XR POINT TO /MEMORY USED (WORDS)/
6385: JSR PRTMI PRINT MESSAGE
6386: MOV DNAME,WA END OF MEMORY
6387: SUB DNAMP,WA MINUS NEXT AVAILABLE LOC
6388: BTW WA CONVERT TO WORDS
6389: MTI WA CONVERT TO INTEGER
6390: MOV =ENCM2,XR POINT TO /MEMORY AVAILABLE (WORDS)/
6391: JSR PRTMI PRINT LINE
6392: MTI CMERC GET COUNT OF ERRORS AS INTEGER
6393: MOV =ENCM3,XR POINT TO /COMPILE ERRORS/
6394: JSR PRTMI PRINT IT
6395: MTI GBCNT GARBAGE COLLECTION COUNT
6396: SBI INTV1 ADJUST FOR UNAVOIDABLE COLLECT
6397: MOV =STPM5,XR POINT TO /STORAGE REGENERATIONS/
6398: JSR PRTMI PRINT GBCOL COUNT
6399: JSR SYSTM GET TIME
6400: SBI TIMSX GET COMPILATION TIME
6401: MOV =ENCM4,XR POINT TO COMPILATION TIME (MSEC)/
6402: JSR PRTMI PRINT MESSAGE
6403: ADD =NUM05,LSTLC BUMP LINE COUNT
6404: .IF .CUEJ
6405: BZE HEADP,INIX0 NO EJECT IF NOTHING PRINTED (SDG11)
6406: JSR PRTPG EJECT PRINTER
6407: .FI
6408: EJC
6409: *
6410: * PREPARE NOW TO START EXECUTION
6411: *
6412: * SET DEFAULT INPUT RECORD LENGTH
6413: *
6414: INIX0 BGT CSWIN,=INILN,INIX1 SKIP IF NOT DEFAULT -IN72 USED
6415: MOV =INILS,CSWIN ELSE USE DEFAULT RECORD LENGTH
6416: *
6417: * RESET TIMER
6418: *
6419: INIX1 JSR SYSTM GET TIME AGAIN
6420: STI TIMSX STORE FOR END RUN PROCESSING
6421: ADD CSWEX,NOXEQ ADD -NOEXECUTE FLAG
6422: BNZ NOXEQ,INIX2 JUMP IF EXECUTION SUPPRESSED
6423: ZER GBCNT INITIALISE COLLECT COUNT
6424: JSR SYSBX CALL BEFORE STARTING EXECUTION
6425: .IF .CUEJ
6426: .ELSE
6427: BZE HEADP,INIY0 NO EJECT IF NOTHING PRINTED (SGD11)
6428: JSR PRTPG EJECT PRINTER
6429: .FI
6430: *
6431: * MERGE WHEN LISTING FILE SET FOR EXECUTION
6432: *
6433: INIY0 MNZ HEADP MARK HEADERS OUT REGARDLESS
6434: ZER -(XS) SET FAILURE LOCATION ON STACK
6435: MOV XS,FLPTR SAVE PTR TO FAILURE OFFSET WORD
6436: MOV R$COD,XR LOAD PTR TO ENTRY CODE BLOCK
6437: MOV =STGXT,STAGE SET STAGE FOR EXECUTE TIME
6438: .IF .CNPF
6439: .ELSE
6440: MOV CMPSN,PFNTE COPY STMTS COMPILED COUNT IN CASE
6441: JSR SYSTM TIME YET AGAIN
6442: STI PFSTM
6443: .FI
6444: BRI (XR) START XEQ WITH FIRST STATEMENT
6445: *
6446: * HERE IF EXECUTION IS SUPPRESSED
6447: *
6448: INIX2 JSR PRTNL PRINT A BLANK LINE
6449: MOV =ENCM5,XR POINT TO /EXECUTION SUPPRESSED/
6450: JSR PRTST PRINT STRING
6451: JSR PRTNL OUTPUT LINE
6452: ZER WA SET ABEND VALUE TO ZERO
6453: MOV =NINI9,WB SET SPECIAL CODE VALUE
6454: JSR SYSEJ END OF JOB, EXIT TO SYSTEM
6455: TTL S P I T B O L -- SNOBOL4 OPERATOR ROUTINES
6456: *
6457: * THIS SECTION INCLUDES ALL ROUTINES WHICH CAN BE ACCESSED
6458: * DIRECTLY FROM THE GENERATED CODE EXCEPT SYSTEM FUNCTIONS.
6459: *
6460: * ALL ROUTINES IN THIS SECTION START WITH A LABEL OF THE
6461: * FORM O$XXX WHERE XXX IS THREE LETTERS. THE GENERATED CODE
6462: * CONTAINS A POINTER TO THE APPROPRIATE ENTRY LABEL.
6463: *
6464: * SINCE THE GENERAL FORM OF THE GENERATED CODE CONSISTS OF
6465: * POINTERS TO BLOCKS WHOSE FIRST WORD IS THE ADDRESS OF THE
6466: * ACTUAL ENTRY POINT LABEL (O$XXX).
6467: *
6468: * THESE ROUTINES ARE IN ALPHABETICAL ORDER BY THEIR
6469: * ENTRY LABEL NAMES (I.E. BY THE XXX OF THE O$XXX NAME)
6470: *
6471: * THESE ROUTINES RECEIVE CONTROL AS FOLLOWS
6472: *
6473: * (CP) POINTER TO NEXT CODE WORD
6474: * (XS) CURRENT STACK POINTER
6475: EJC
6476: *
6477: * BINARY PLUS (ADDITION)
6478: *
6479: O$ADD ENT ENTRY POINT
6480: JSR ARITH FETCH ARITHMETIC OPERANDS
6481: ERR 001,ADDITION LEFT OPERAND IS NOT NUMERIC
6482: ERR 002,ADDITION RIGHT OPERAND IS NOT NUMERIC
6483: .IF .CNRA
6484: .ELSE
6485: PPM OADD1 JUMP IF REAL OPERANDS
6486: .FI
6487: *
6488: * HERE TO ADD TWO INTEGERS
6489: *
6490: ADI ICVAL(XL) ADD RIGHT OPERAND TO LEFT
6491: INO EXINT RETURN INTEGER IF NO OVERFLOW
6492: ERB 003,ADDITION CAUSED INTEGER OVERFLOW
6493: .IF .CNRA
6494: .ELSE
6495: *
6496: * HERE TO ADD TWO REALS
6497: *
6498: OADD1 ADR RCVAL(XL) ADD RIGHT OPERAND TO LEFT
6499: RNO EXREA RETURN REAL IF NO OVERFLOW
6500: ERB 261,ADDITION CAUSED REAL OVERFLOW
6501: .FI
6502: EJC
6503: *
6504: * UNARY PLUS (AFFIRMATION)
6505: *
6506: O$AFF ENT ENTRY POINT
6507: MOV (XS)+,XR LOAD OPERAND
6508: JSR GTNUM CONVERT TO NUMERIC
6509: ERR 004,AFFIRMATION OPERAND IS NOT NUMERIC
6510: BRN EXIXR RETURN IF CONVERTED TO NUMERIC
6511: EJC
6512: *
6513: * BINARY BAR (ALTERNATION)
6514: *
6515: O$ALT ENT ENTRY POINT
6516: MOV (XS)+,XR LOAD RIGHT OPERAND
6517: JSR GTPAT CONVERT TO PATTERN
6518: ERR 005,ALTERNATION RIGHT OPERAND IS NOT PATTERN
6519: *
6520: * MERGE HERE FROM SPECIAL (LEFT ALTERNATION) CASE
6521: *
6522: OALT1 MOV =P$ALT,WB SET PCODE FOR ALTERNATIVE NODE
6523: JSR PBILD BUILD ALTERNATIVE NODE
6524: MOV XR,XL SAVE ADDRESS OF ALTERNATIVE NODE
6525: MOV (XS)+,XR LOAD LEFT OPERAND
6526: JSR GTPAT CONVERT TO PATTERN
6527: ERR 006,ALTERNATION LEFT OPERAND IS NOT PATTERN
6528: BEQ XR,=P$ALT,OALT2 JUMP IF LEFT ARG IS ALTERNATION
6529: MOV XR,PTHEN(XL) SET LEFT OPERAND AS SUCCESSOR
6530: MOV XL,XR MOVE RESULT TO PROPER REGISTER
6531: BRN EXIXR JUMP FOR NEXT CODE WORD
6532: *
6533: * COME HERE IF LEFT ARGUMENT IS ITSELF AN ALTERNATION
6534: *
6535: * THE RESULT IS MORE EFFICIENT IF WE MAKE THE REPLACEMENT
6536: *
6537: * (A / B) / C = A / (B / C)
6538: *
6539: OALT2 MOV PARM1(XR),PTHEN(XL) BUILD THE (B / C) NODE
6540: MOV PTHEN(XR),-(XS) SET A AS NEW LEFT ARG
6541: MOV XL,XR SET (B / C) AS NEW RIGHT ARG
6542: BRN OALT1 MERGE BACK TO BUILD A / (B / C)
6543: EJC
6544: *
6545: * ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY NAME)
6546: *
6547: O$AMN ENT ENTRY POINT
6548: LCW XR LOAD NUMBER OF SUBSCRIPTS
6549: MOV XR,WB SET FLAG FOR BY NAME
6550: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE
6551: EJC
6552: *
6553: * ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY VALUE)
6554: *
6555: O$AMV ENT ENTRY POINT
6556: LCW XR LOAD NUMBER OF SUBSCRIPTS
6557: ZER WB SET FLAG FOR BY VALUE
6558: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE
6559: EJC
6560: *
6561: * ARRAY REFERENCE (ONE SUBSCRIPT, BY NAME)
6562: *
6563: O$AON ENT ENTRY POINT
6564: MOV (XS),XR LOAD SUBSCRIPT VALUE
6565: MOV 1(XS),XL LOAD ARRAY VALUE
6566: MOV (XL),WA LOAD FIRST WORD OF ARRAY OPERAND
6567: BEQ WA,=B$VCT,OAON2 JUMP IF VECTOR REFERENCE
6568: BEQ WA,=B$TBT,OAON3 JUMP IF TABLE REFERENCE
6569: *
6570: * HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE
6571: *
6572: OAON1 MOV =NUM01,XR SET NUMBER OF SUBSCRIPTS TO ONE
6573: MOV XR,WB SET FLAG FOR BY NAME
6574: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE
6575: *
6576: * HERE IF WE HAVE A VECTOR REFERENCE
6577: *
6578: OAON2 BNE (XR),=B$ICL,OAON1 USE LONG ROUTINE IF NOT INTEGER
6579: LDI ICVAL(XR) LOAD INTEGER SUBSCRIPT VALUE
6580: MFI WA,EXFAL COPY AS ADDRESS INT, FAIL IF OVFLO
6581: BZE WA,EXFAL FAIL IF ZERO
6582: ADD =VCVLB,WA COMPUTE OFFSET IN WORDS
6583: WTB WA CONVERT TO BYTES
6584: MOV WA,(XS) COMPLETE NAME ON STACK
6585: BLT WA,VCLEN(XL),EXITS EXIT IF SUBSCRIPT NOT TOO LARGE
6586: BRN EXFAL ELSE FAIL
6587: *
6588: * HERE FOR TABLE REFERENCE
6589: *
6590: OAON3 MNZ WB SET FLAG FOR NAME REFERENCE
6591: JSR TFIND LOCATE/CREATE TABLE ELEMENT
6592: PPM EXFAL FAIL IF ACCESS FAILS
6593: MOV XL,1(XS) STORE NAME BASE ON STACK
6594: MOV WA,(XS) STORE NAME OFFSET ON STACK
6595: BRN EXITS EXIT WITH RESULT ON STACK
6596: EJC
6597: *
6598: * ARRAY REFERENCE (ONE SUBSCRIPT, BY VALUE)
6599: *
6600: O$AOV ENT ENTRY POINT
6601: MOV (XS)+,XR LOAD SUBSCRIPT VALUE
6602: MOV (XS)+,XL LOAD ARRAY VALUE
6603: MOV (XL),WA LOAD FIRST WORD OF ARRAY OPERAND
6604: BEQ WA,=B$VCT,OAOV2 JUMP IF VECTOR REFERENCE
6605: BEQ WA,=B$TBT,OAOV3 JUMP IF TABLE REFERENCE
6606: *
6607: * HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE
6608: *
6609: OAOV1 MOV XL,-(XS) RESTACK ARRAY VALUE
6610: MOV XR,-(XS) RESTACK SUBSCRIPT
6611: MOV =NUM01,XR SET NUMBER OF SUBSCRIPTS TO ONE
6612: ZER WB SET FLAG FOR VALUE CALL
6613: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE
6614: *
6615: * HERE IF WE HAVE A VECTOR REFERENCE
6616: *
6617: OAOV2 BNE (XR),=B$ICL,OAOV1 USE LONG ROUTINE IF NOT INTEGER
6618: LDI ICVAL(XR) LOAD INTEGER SUBSCRIPT VALUE
6619: MFI WA,EXFAL MOVE AS ONE WORD INT, FAIL IF OVFLO
6620: BZE WA,EXFAL FAIL IF ZERO
6621: ADD =VCVLB,WA COMPUTE OFFSET IN WORDS
6622: WTB WA CONVERT TO BYTES
6623: BGE WA,VCLEN(XL),EXFAL FAIL IF SUBSCRIPT TOO LARGE
6624: JSR ACESS ACCESS VALUE
6625: PPM EXFAL FAIL IF ACCESS FAILS
6626: BRN EXIXR ELSE RETURN VALUE TO CALLER
6627: *
6628: * HERE FOR TABLE REFERENCE BY VALUE
6629: *
6630: OAOV3 ZER WB SET FLAG FOR VALUE REFERENCE
6631: JSR TFIND CALL TABLE SEARCH ROUTINE
6632: PPM EXFAL FAIL IF ACCESS FAILS
6633: BRN EXIXR EXIT WITH RESULT IN XR
6634: EJC
6635: *
6636: * ASSIGNMENT
6637: *
6638: O$ASS ENT ENTRY POINT
6639: *
6640: * O$RPL (PATTERN REPLACEMENT) MERGES HERE
6641: *
6642: OASS0 MOV (XS)+,WB LOAD VALUE TO BE ASSIGNED
6643: MOV (XS)+,WA LOAD NAME OFFSET
6644: MOV (XS),XL LOAD NAME BASE
6645: MOV WB,(XS) STORE ASSIGNED VALUE AS RESULT
6646: JSR ASIGN PERFORM ASSIGNMENT
6647: PPM EXFAL FAIL IF ASSIGNMENT FAILS
6648: BRN EXITS EXIT WITH RESULT ON STACK
6649: EJC
6650: *
6651: * COMPILATION ERROR
6652: *
6653: O$CER ENT ENTRY POINT
6654: ERB 007,COMPILATION ERROR ENCOUNTERED DURING EXECUTION
6655: EJC
6656: *
6657: * UNARY AT (CURSOR ASSIGNMENT)
6658: *
6659: O$CAS ENT ENTRY POINT
6660: MOV (XS)+,WC LOAD NAME OFFSET (PARM2)
6661: MOV (XS)+,XR LOAD NAME BASE (PARM1)
6662: MOV =P$CAS,WB SET PCODE FOR CURSOR ASSIGNMENT
6663: JSR PBILD BUILD NODE
6664: BRN EXIXR JUMP FOR NEXT CODE WORD
6665: EJC
6666: *
6667: * CONCATENATION
6668: *
6669: O$CNC ENT ENTRY POINT
6670: MOV (XS),XR LOAD RIGHT ARGUMENT
6671: BEQ XR,=NULLS,OCNC3 JUMP IF RIGHT ARG IS NULL
6672: MOV 1(XS),XL LOAD LEFT ARGUMENT
6673: BEQ XL,=NULLS,OCNC4 JUMP IF LEFT ARGUMENT IS NULL
6674: MOV =B$SCL,WA GET CONSTANT TO TEST FOR STRING
6675: BNE WA,(XL),OCNC2 JUMP IF LEFT ARG NOT A STRING
6676: BNE WA,(XR),OCNC2 JUMP IF RIGHT ARG NOT A STRING
6677: *
6678: * MERGE HERE TO CONCATENATE TWO STRINGS
6679: *
6680: OCNC1 MOV SCLEN(XL),WA LOAD LEFT ARGUMENT LENGTH
6681: ADD SCLEN(XR),WA COMPUTE RESULT LENGTH
6682: JSR ALOCS ALLOCATE SCBLK FOR RESULT
6683: MOV XR,1(XS) STORE RESULT PTR OVER LEFT ARGUMENT
6684: PSC XR PREPARE TO STORE CHARS OF RESULT
6685: MOV SCLEN(XL),WA GET NUMBER OF CHARS IN LEFT ARG
6686: PLC XL PREPARE TO LOAD LEFT ARG CHARS
6687: MVC MOVE CHARACTERS OF LEFT ARGUMENT
6688: MOV (XS)+,XL LOAD RIGHT ARG POINTER, POP STACK
6689: MOV SCLEN(XL),WA LOAD NUMBER OF CHARS IN RIGHT ARG
6690: PLC XL PREPARE TO LOAD RIGHT ARG CHARS
6691: MVC MOVE CHARACTERS OF RIGHT ARGUMENT
6692: BRN EXITS EXIT WITH RESULT ON STACK
6693: *
6694: * COME HERE IF ARGUMENTS ARE NOT BOTH STRINGS
6695: *
6696: OCNC2 JSR GTSTG CONVERT RIGHT ARG TO STRING
6697: PPM OCNC5 JUMP IF RIGHT ARG IS NOT STRING
6698: MOV XR,XL SAVE RIGHT ARG PTR
6699: JSR GTSTG CONVERT LEFT ARG TO STRING
6700: PPM OCNC6 JUMP IF LEFT ARG IS NOT A STRING
6701: MOV XR,-(XS) STACK LEFT ARGUMENT
6702: MOV XL,-(XS) STACK RIGHT ARGUMENT
6703: MOV XR,XL MOVE LEFT ARG TO PROPER REG
6704: MOV (XS),XR MOVE RIGHT ARG TO PROPER REG
6705: BRN OCNC1 MERGE BACK TO CONCATENATE STRINGS
6706: EJC
6707: *
6708: * CONCATENATION (CONTINUED)
6709: *
6710: * COME HERE FOR NULL RIGHT ARGUMENT
6711: *
6712: OCNC3 ICA XS REMOVE RIGHT ARG FROM STACK
6713: BRN EXITS RETURN WITH LEFT ARGUMENT ON STACK
6714: *
6715: * HERE FOR NULL LEFT ARGUMENT
6716: *
6717: OCNC4 ICA XS UNSTACK ONE ARGUMENT
6718: MOV XR,(XS) STORE RIGHT ARGUMENT
6719: BRN EXITS EXIT WITH RESULT ON STACK
6720: *
6721: * HERE IF RIGHT ARGUMENT IS NOT A STRING
6722: *
6723: OCNC5 MOV XR,XL MOVE RIGHT ARGUMENT PTR
6724: MOV (XS)+,XR LOAD LEFT ARG POINTER
6725: *
6726: * MERGE HERE WHEN LEFT ARGUMENT IS NOT A STRING
6727: *
6728: OCNC6 JSR GTPAT CONVERT LEFT ARG TO PATTERN
6729: ERR 008,CONCATENATION LEFT OPND IS NOT STRING OR PATTERN
6730: MOV XR,-(XS) SAVE RESULT ON STACK
6731: MOV XL,XR POINT TO RIGHT OPERAND
6732: JSR GTPAT CONVERT TO PATTERN
6733: ERR 009,CONCATENATION RIGHT OPD IS NOT STRING OR PATTERN
6734: MOV XR,XL MOVE FOR PCONC
6735: MOV (XS)+,XR RELOAD LEFT OPERAND PTR
6736: JSR PCONC CONCATENATE PATTERNS
6737: BRN EXIXR EXIT WITH RESULT IN XR
6738: EJC
6739: *
6740: * COMPLEMENTATION
6741: *
6742: O$COM ENT ENTRY POINT
6743: MOV (XS)+,XR LOAD OPERAND
6744: MOV (XR),WA LOAD TYPE WORD
6745: *
6746: * MERGE BACK HERE AFTER CONVERSION
6747: *
6748: OCOM1 BEQ WA,=B$ICL,OCOM2 JUMP IF INTEGER
6749: .IF .CNRA
6750: .ELSE
6751: BEQ WA,=B$RCL,OCOM3 JUMP IF REAL
6752: .FI
6753: JSR GTNUM ELSE CONVERT TO NUMERIC
6754: ERR 010,COMPLEMENTATION OPERAND IS NOT NUMERIC
6755: BRN OCOM1 BACK TO CHECK CASES
6756: *
6757: * HERE TO COMPLEMENT INTEGER
6758: *
6759: OCOM2 LDI ICVAL(XR) LOAD INTEGER VALUE
6760: NGI NEGATE
6761: INO EXINT RETURN INTEGER IF NO OVERFLOW
6762: ERB 011,COMPLEMENTATION CAUSED INTEGER OVERFLOW
6763: .IF .CNRA
6764: .ELSE
6765: *
6766: * HERE TO COMPLEMENT REAL
6767: *
6768: OCOM3 LDR RCVAL(XR) LOAD REAL VALUE
6769: NGR NEGATE
6770: BRN EXREA RETURN REAL RESULT
6771: .FI
6772: EJC
6773: *
6774: * BINARY SLASH (DIVISION)
6775: *
6776: O$DVD ENT ENTRY POINT
6777: JSR ARITH FETCH ARITHMETIC OPERANDS
6778: ERR 012,DIVISION LEFT OPERAND IS NOT NUMERIC
6779: ERR 013,DIVISION RIGHT OPERAND IS NOT NUMERIC
6780: .IF .CNRA
6781: .ELSE
6782: PPM ODVD2 JUMP IF REAL OPERANDS
6783: .FI
6784: *
6785: * HERE TO DIVIDE TWO INTEGERS
6786: *
6787: DVI ICVAL(XL) DIVIDE LEFT OPERAND BY RIGHT
6788: INO EXINT RESULT OK IF NO OVERFLOW
6789: ERB 014,DIVISION CAUSED INTEGER OVERFLOW
6790: .IF .CNRA
6791: .ELSE
6792: *
6793: * HERE TO DIVIDE TWO REALS
6794: *
6795: ODVD2 DVR RCVAL(XL) DIVIDE LEFT OPERAND BY RIGHT
6796: RNO EXREA RETURN REAL IF NO OVERFLOW
6797: ERB 262,DIVISION CAUSED REAL OVERFLOW
6798: .FI
6799: EJC
6800: *
6801: * EXPONENTIATION
6802: *
6803: O$EXP ENT ENTRY POINT
6804: MOV (XS)+,XR LOAD EXPONENT
6805: JSR GTNUM CONVERT TO NUMBER
6806: ERR 015,EXPONENTIATION RIGHT OPERAND IS NOT NUMERIC
6807: .IF .CNRA
6808: .ELSE
6809: BNE WA,=B$ICL,OEXP7 JUMP IF REAL
6810: .FI
6811: MOV XR,XL MOVE EXPONENT
6812: MOV (XS)+,XR LOAD BASE
6813: JSR GTNUM CONVERT TO NUMERIC
6814: ERR 016,EXPONENTIATION LEFT OPERAND IS NOT NUMERIC
6815: LDI ICVAL(XL) LOAD EXPONENT
6816: ILT OEXP8 ERROR IF NEGATIVE EXPONENT
6817: .IF .CNRA
6818: .ELSE
6819: BEQ WA,=B$RCL,OEXP3 JUMP IF BASE IS REAL
6820: .FI
6821: *
6822: * HERE TO EXPONENTIATE AN INTEGER
6823: *
6824: MFI WA,OEXP2 CONVERT EXPONENT TO 1 WORD INTEGER
6825: LCT WA,WA SET LOOP COUNTER
6826: LDI INTV1 LOAD INITIAL VALUE OF 1
6827: BNZ WA,OEXP1 JUMP IF NON-ZERO EXPONENT
6828: INE EXINT GIVE ZERO AS RESULT FOR NONZERO**0
6829: BRN OEXP4 ELSE ERROR OF 0**0
6830: *
6831: * LOOP TO PERFORM EXPONENTIATION
6832: *
6833: OEXP1 MLI ICVAL(XR) MULTIPLY BY BASE
6834: IOV OEXP2 JUMP IF OVERFLOW
6835: BCT WA,OEXP1 LOOP BACK TILL COMPUTATION COMPLETE
6836: BRN EXINT THEN RETURN INTEGER RESULT
6837: *
6838: * HERE IF INTEGER OVERFLOW
6839: *
6840: OEXP2 ERB 017,EXPONENTIATION CAUSED INTEGER OVERFLOW
6841: EJC
6842: *
6843: * EXPONENTIATION (CONTINUED)
6844: .IF .CNRA
6845: .ELSE
6846: *
6847: * HERE TO EXPONENTIATE A REAL
6848: *
6849: OEXP3 MFI WA,OEXP6 CONVERT EXPONENT TO ONE WORD
6850: LCT WA,WA SET LOOP COUNTER
6851: LDR REAV1 LOAD 1.0 AS INITIAL VALUE
6852: BNZ WA,OEXP5 JUMP IF NON-ZERO EXPONENT
6853: RNE EXREA RETURN 1.0 IF NONZERO**ZERO
6854: .FI
6855: *
6856: * HERE FOR ERROR OF 0**0 OR 0.0**0
6857: *
6858: OEXP4 ERB 018,EXPONENTIATION RESULT IS UNDEFINED
6859: .IF .CNRA
6860: .ELSE
6861: *
6862: * LOOP TO PERFORM EXPONENTIATION
6863: *
6864: OEXP5 MLR RCVAL(XR) MULTIPLY BY BASE
6865: ROV OEXP6 JUMP IF OVERFLOW
6866: BCT WA,OEXP5 LOOP TILL COMPUTATION COMPLETE
6867: BRN EXREA THEN RETURN REAL RESULT
6868: *
6869: * HERE IF REAL OVERFLOW
6870: *
6871: OEXP6 ERB 266,EXPONENTIATION CAUSED REAL OVERFLOW
6872: *
6873: * HERE IF REAL EXPONENT
6874: *
6875: OEXP7 ERB 267,EXPONENTIATION RIGHT OPERAND IS REAL NOT INTEGER
6876: .FI
6877: *
6878: * HERE FOR NEGATIVE EXPONENT
6879: *
6880: OEXP8 ERB 019,EXPONENTIATION RIGHT OPERAND IS NEGATIVE
6881: EJC
6882: *
6883: * FAILURE IN EXPRESSION EVALUATION
6884: *
6885: * THIS ENTRY POINT IS USED IF THE EVALUATION OF AN
6886: * EXPRESSION, INITIATED BY THE EVALX PROCEDURE, FAILS.
6887: * CONTROL IS RETURNED TO AN APPROPRIATE POINT IN EVALX.
6888: *
6889: O$FEX ENT ENTRY POINT
6890: BRN EVLX6 JUMP TO FAILURE LOC IN EVALX
6891: EJC
6892: *
6893: * FAILURE DURING EVALUATION OF A COMPLEX OR DIRECT GOTO
6894: *
6895: O$FIF ENT ENTRY POINT
6896: ERB 020,GOTO EVALUATION FAILURE
6897: EJC
6898: *
6899: * FUNCTION CALL (MORE THAN ONE ARGUMENT)
6900: *
6901: O$FNC ENT ENTRY POINT
6902: LCW WA LOAD NUMBER OF ARGUMENTS
6903: LCW XR LOAD FUNCTION VRBLK POINTER
6904: MOV VRFNC(XR),XL LOAD FUNCTION POINTER
6905: BNE WA,FARGS(XL),CFUNC USE CENTRAL ROUTINE IF WRONG NUM
6906: BRI (XL) JUMP TO FUNCTION IF ARG COUNT OK
6907: EJC
6908: *
6909: * FUNCTION NAME ERROR
6910: *
6911: O$FNE ENT ENTRY POINT
6912: LCW WA GET NEXT CODE WORD
6913: BNE WA,=ORNM$,OFNE1 FAIL IF NOT EVALUATING EXPRESSION
6914: BZE 2(XS),EVLX3 OK IF EXPR. WAS WANTED BY VALUE
6915: *
6916: * HERE FOR ERROR
6917: *
6918: OFNE1 ERB 021,FUNCTION CALLED BY NAME RETURNED A VALUE
6919: EJC
6920: *
6921: * FUNCTION CALL (SINGLE ARGUMENT)
6922: *
6923: O$FNS ENT ENTRY POINT
6924: LCW XR LOAD FUNCTION VRBLK POINTER
6925: MOV =NUM01,WA SET NUMBER OF ARGUMENTS TO ONE
6926: MOV VRFNC(XR),XL LOAD FUNCTION POINTER
6927: BNE WA,FARGS(XL),CFUNC USE CENTRAL ROUTINE IF WRONG NUM
6928: BRI (XL) JUMP TO FUNCTION IF ARG COUNT OK
6929: EJC
6930: * CALL TO UNDEFINED FUNCTION
6931: *
6932: O$FUN ENT ENTRY POINT
6933: ERB 022,UNDEFINED FUNCTION CALLED
6934: EJC
6935: *
6936: * EXECUTE COMPLEX GOTO
6937: *
6938: O$GOC ENT ENTRY POINT
6939: MOV 1(XS),XR LOAD NAME BASE POINTER
6940: BHI XR,STATE,OGOC1 JUMP IF NOT NATURAL VARIABLE
6941: ADD *VRTRA,XR ELSE POINT TO VRTRA FIELD
6942: BRI (XR) AND JUMP THROUGH IT
6943: *
6944: * HERE IF GOTO OPERAND IS NOT NATURAL VARIABLE
6945: *
6946: OGOC1 ERB 023,GOTO OPERAND IS NOT A NATURAL VARIABLE
6947: EJC
6948: *
6949: * EXECUTE DIRECT GOTO
6950: *
6951: O$GOD ENT ENTRY POINT
6952: MOV (XS),XR LOAD OPERAND
6953: MOV (XR),WA LOAD FIRST WORD
6954: BEQ WA,=B$CDS,BCDS0 JUMP IF CODE BLOCK TO CODE ROUTINE
6955: BEQ WA,=B$CDC,BCDC0 JUMP IF CODE BLOCK TO CODE ROUTINE
6956: ERB 024,GOTO OPERAND IN DIRECT GOTO IS NOT CODE
6957: EJC
6958: *
6959: * SET GOTO FAILURE TRAP
6960: *
6961: * THIS ROUTINE IS EXECUTED AT THE START OF A COMPLEX OR
6962: * DIRECT FAILURE GOTO TO TRAP A SUBSEQUENT FAIL (SEE EXFAL)
6963: *
6964: O$GOF ENT ENTRY POINT
6965: MOV FLPTR,XR POINT TO FAIL OFFSET ON STACK
6966: ICA (XR) POINT FAILURE TO O$FIF WORD
6967: ICP POINT TO NEXT CODE WORD
6968: BRN EXITS EXIT TO CONTINUE
6969: EJC
6970: *
6971: * BINARY DOLLAR (IMMEDIATE ASSIGNMENT)
6972: *
6973: * THE PATTERN BUILT BY BINARY DOLLAR IS A COMPOUND PATTERN.
6974: * SEE DESCRIPTION AT START OF PATTERN MATCH SECTION FOR
6975: * DETAILS OF THE STRUCTURE WHICH IS CONSTRUCTED.
6976: *
6977: O$IMA ENT ENTRY POINT
6978: MOV =P$IMC,WB SET PCODE FOR LAST NODE
6979: MOV (XS)+,WC POP NAME OFFSET (PARM2)
6980: MOV (XS)+,XR POP NAME BASE (PARM1)
6981: JSR PBILD BUILD P$IMC NODE
6982: MOV XR,XL SAVE PTR TO NODE
6983: MOV (XS),XR LOAD LEFT ARGUMENT
6984: JSR GTPAT CONVERT TO PATTERN
6985: ERR 025,IMMEDIATE ASSIGNMENT LEFT OPERAND IS NOT PATTERN
6986: MOV XR,(XS) SAVE PTR TO LEFT OPERAND PATTERN
6987: MOV =P$IMA,WB SET PCODE FOR FIRST NODE
6988: JSR PBILD BUILD P$IMA NODE
6989: MOV (XS)+,PTHEN(XR) SET LEFT OPERAND AS P$IMA SUCCESSOR
6990: JSR PCONC CONCATENATE TO FORM FINAL PATTERN
6991: BRN EXIXR ALL DONE
6992: EJC
6993: *
6994: * INDIRECTION (BY NAME)
6995: *
6996: O$INN ENT ENTRY POINT
6997: MNZ WB SET FLAG FOR RESULT BY NAME
6998: BRN INDIR JUMP TO COMMON ROUTINE
6999: EJC
7000: *
7001: * INTERROGATION
7002: *
7003: O$INT ENT ENTRY POINT
7004: MOV =NULLS,(XS) REPLACE OPERAND WITH NULL
7005: BRN EXITS EXIT FOR NEXT CODE WORD
7006: EJC
7007: *
7008: * INDIRECTION (BY VALUE)
7009: *
7010: O$INV ENT ENTRY POINT
7011: ZER WB SET FLAG FOR BY VALUE
7012: BRN INDIR JUMP TO COMMON ROUTINE
7013: EJC
7014: *
7015: * KEYWORD REFERENCE (BY NAME)
7016: *
7017: O$KWN ENT ENTRY POINT
7018: JSR KWNAM GET KEYWORD NAME
7019: BRN EXNAM EXIT WITH RESULT NAME
7020: EJC
7021: *
7022: * KEYWORD REFERENCE (BY VALUE)
7023: *
7024: O$KWV ENT ENTRY POINT
7025: JSR KWNAM GET KEYWORD NAME
7026: MOV XR,DNAMP DELETE KVBLK
7027: JSR ACESS ACCESS VALUE
7028: PPM EXNUL DUMMY (UNUSED) FAILURE RETURN
7029: BRN EXIXR JUMP WITH VALUE IN XR
7030: EJC
7031: *
7032: * LOAD EXPRESSION BY NAME
7033: *
7034: O$LEX ENT ENTRY POINT
7035: MOV *EVSI$,WA SET SIZE OF EVBLK
7036: JSR ALLOC ALLOCATE SPACE FOR EVBLK
7037: MOV =B$EVT,(XR) SET TYPE WORD
7038: MOV =TRBEV,EVVAR(XR) SET DUMMY TRBLK POINTER
7039: LCW WA LOAD EXBLK POINTER
7040: MOV WA,EVEXP(XR) SET EXBLK POINTER
7041: MOV XR,XL MOVE NAME BASE TO PROPER REG
7042: MOV *EVVAR,WA SET NAME OFFSET = ZERO
7043: BRN EXNAM EXIT WITH NAME IN (XL,WA)
7044: EJC
7045: *
7046: * LOAD PATTERN VALUE
7047: *
7048: O$LPT ENT ENTRY POINT
7049: LCW XR LOAD PATTERN POINTER
7050: BRN EXIXR STACK PTR AND OBEY NEXT CODE WORD
7051: EJC
7052: *
7053: * LOAD VARIABLE NAME
7054: *
7055: O$LVN ENT ENTRY POINT
7056: LCW WA LOAD VRBLK POINTER
7057: MOV WA,-(XS) STACK VRBLK PTR (NAME BASE)
7058: MOV *VRVAL,-(XS) STACK NAME OFFSET
7059: BRN EXITS EXIT WITH RESULT ON STACK
7060: EJC
7061: *
7062: * BINARY ASTERISK (MULTIPLICATION)
7063: *
7064: O$MLT ENT ENTRY POINT
7065: JSR ARITH FETCH ARITHMETIC OPERANDS
7066: ERR 026,MULTIPLICATION LEFT OPERAND IS NOT NUMERIC
7067: ERR 027,MULTIPLICATION RIGHT OPERAND IS NOT NUMERIC
7068: .IF .CNRA
7069: .ELSE
7070: PPM OMLT1 JUMP IF REAL OPERANDS
7071: .FI
7072: *
7073: * HERE TO MULTIPLY TWO INTEGERS
7074: *
7075: MLI ICVAL(XL) MULTIPLY LEFT OPERAND BY RIGHT
7076: INO EXINT RETURN INTEGER IF NO OVERFLOW
7077: ERB 028,MULTIPLICATION CAUSED INTEGER OVERFLOW
7078: .IF .CNRA
7079: .ELSE
7080: *
7081: * HERE TO MULTIPLY TWO REALS
7082: *
7083: OMLT1 MLR RCVAL(XL) MULTIPLY LEFT OPERAND BY RIGHT
7084: RNO EXREA RETURN REAL IF NO OVERFLOW
7085: ERB 263,MULTIPLICATION CAUSED REAL OVERFLOW
7086: .FI
7087: EJC
7088: *
7089: * NAME REFERENCE
7090: *
7091: O$NAM ENT ENTRY POINT
7092: MOV *NMSI$,WA SET LENGTH OF NMBLK
7093: JSR ALLOC ALLOCATE NMBLK
7094: MOV =B$NML,(XR) SET NAME BLOCK CODE
7095: MOV (XS)+,NMOFS(XR) SET NAME OFFSET FROM OPERAND
7096: MOV (XS)+,NMBAS(XR) SET NAME BASE FROM OPERAND
7097: BRN EXIXR EXIT WITH RESULT IN XR
7098: EJC
7099: *
7100: * NEGATION
7101: *
7102: * INITIAL ENTRY
7103: *
7104: O$NTA ENT ENTRY POINT
7105: LCW WA LOAD NEW FAILURE OFFSET
7106: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER
7107: MOV WA,-(XS) STACK NEW FAILURE OFFSET
7108: MOV XS,FLPTR SET NEW FAILURE POINTER
7109: BRN EXITS JUMP TO CONTINUE EXECUTION
7110: *
7111: * ENTRY AFTER SUCCESSFUL EVALUATION OF OPERAND
7112: *
7113: O$NTB ENT ENTRY POINT
7114: MOV 2(XS),FLPTR RESTORE OLD FAILURE POINTER
7115: BRN EXFAL AND FAIL
7116: *
7117: * ENTRY FOR FAILURE DURING OPERAND EVALUATION
7118: *
7119: O$NTC ENT ENTRY POINT
7120: ICA XS POP FAILURE OFFSET
7121: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER
7122: BRN EXNUL EXIT GIVING NULL RESULT
7123: EJC
7124: *
7125: * USE OF UNDEFINED OPERATOR
7126: *
7127: O$OUN ENT ENTRY POINT
7128: ERB 029,UNDEFINED OPERATOR REFERENCED
7129: EJC
7130: *
7131: * BINARY DOT (PATTERN ASSIGNMENT)
7132: *
7133: * THE PATTERN BUILT BY BINARY DOT IS A COMPOUND PATTERN.
7134: * SEE DESCRIPTION AT START OF PATTERN MATCH SECTION FOR
7135: * DETAILS OF THE STRUCTURE WHICH IS CONSTRUCTED.
7136: *
7137: O$PAS ENT ENTRY POINT
7138: MOV =P$PAC,WB LOAD PCODE FOR P$PAC NODE
7139: MOV (XS)+,WC LOAD NAME OFFSET (PARM2)
7140: MOV (XS)+,XR LOAD NAME BASE (PARM1)
7141: JSR PBILD BUILD P$PAC NODE
7142: MOV XR,XL SAVE PTR TO NODE
7143: MOV (XS),XR LOAD LEFT OPERAND
7144: JSR GTPAT CONVERT TO PATTERN
7145: ERR 030,PATTERN ASSIGNMENT LEFT OPERAND IS NOT PATTERN
7146: MOV XR,(XS) SAVE PTR TO LEFT OPERAND PATTERN
7147: MOV =P$PAA,WB SET PCODE FOR P$PAA NODE
7148: JSR PBILD BUILD P$PAA NODE
7149: MOV (XS)+,PTHEN(XR) SET LEFT OPERAND AS P$PAA SUCCESSOR
7150: JSR PCONC CONCATENATE TO FORM FINAL PATTERN
7151: BRN EXIXR JUMP FOR NEXT CODE WORD
7152: EJC
7153: *
7154: * PATTERN MATCH (BY NAME, FOR REPLACEMENT)
7155: *
7156: O$PMN ENT ENTRY POINT
7157: ZER WB SET TYPE CODE FOR MATCH BY NAME
7158: BRN MATCH JUMP TO ROUTINE TO START MATCH
7159: EJC
7160: *
7161: * PATTERN MATCH (STATEMENT)
7162: *
7163: * O$PMS IS USED IN PLACE OF O$PMV WHEN THE PATTERN MATCH
7164: * OCCURS AT THE OUTER (STATEMENT) LEVEL SINCE IN THIS
7165: * CASE THE SUBSTRING VALUE NEED NOT BE CONSTRUCTED.
7166: *
7167: O$PMS ENT ENTRY POINT
7168: MOV =NUM02,WB SET FLAG FOR STATEMENT TO MATCH
7169: BRN MATCH JUMP TO ROUTINE TO START MATCH
7170: EJC
7171: *
7172: * PATTERN MATCH (BY VALUE)
7173: *
7174: O$PMV ENT ENTRY POINT
7175: MOV =NUM01,WB SET TYPE CODE FOR VALUE MATCH
7176: BRN MATCH JUMP TO ROUTINE TO START MATCH
7177: EJC
7178: *
7179: * POP TOP ITEM ON STACK
7180: *
7181: O$POP ENT ENTRY POINT
7182: ICA XS POP TOP STACK ENTRY
7183: BRN EXITS OBEY NEXT CODE WORD
7184: EJC
7185: *
7186: * TERMINATE EXECUTION (CODE COMPILED FOR END STATEMENT)
7187: *
7188: O$STP ENT ENTRY POINT
7189: BRN LEND0 JUMP TO END CIRCUIT
7190: EJC
7191: *
7192: * RETURN NAME FROM EXPRESSION
7193: * THIS ENTRY POINTS IS USED IF THE EVALUATION OF AN
7194: * EXPRESSION, INITIATED BY THE EVALX PROCEDURE, RETURNS
7195: * A NAME. CONTROL IS RETURNED TO THE PROPER POINT IN EVALX.
7196: *
7197: O$RNM ENT ENTRY POINT
7198: BRN EVLX4 RETURN TO EVALX PROCEDURE
7199: EJC
7200: *
7201: * PATTERN REPLACEMENT
7202: *
7203: * WHEN THIS ROUTINE GETS CONTROL, THE FOLLOWING STACK
7204: * ENTRIES HAVE BEEN MADE (SEE END OF MATCH ROUTINE P$NTH)
7205: *
7206: * SUBJECT NAME BASE
7207: * SUBJECT NAME OFFSET
7208: * INITIAL CURSOR VALUE
7209: * FINAL CURSOR VALUE
7210: * SUBJECT POINTER
7211: * (XS) ---------------- REPLACEMENT VALUE
7212: *
7213: O$RPL ENT ENTRY POINT
7214: JSR GTSTG CONVERT REPLACEMENT VAL TO STRING
7215: ERR 031,PATTERN REPLACEMENT RIGHT OPERAND IS NOT STRING
7216: *
7217: * GET RESULT LENGTH AND ALLOCATE RESULT SCBLK
7218: *
7219: MOV (XS),XL LOAD SUBJECT STRING POINTER
7220: .IF .CNBF
7221: .ELSE
7222: BEQ (XL),=B$BCT,ORPL4 BRANCH IF BUFFER ASSIGNMENT
7223: .FI
7224: ADD SCLEN(XL),WA ADD SUBJECT STRING LENGTH
7225: ADD 2(XS),WA ADD STARTING CURSOR
7226: SUB 1(XS),WA MINUS FINAL CURSOR = TOTAL LENGTH
7227: BZE WA,ORPL3 JUMP IF RESULT IS NULL
7228: MOV XR,-(XS) RESTACK REPLACEMENT STRING
7229: JSR ALOCS ALLOCATE SCBLK FOR RESULT
7230: MOV 3(XS),WA GET INITIAL CURSOR (PART 1 LEN)
7231: MOV XR,3(XS) STACK RESULT POINTER
7232: PSC XR POINT TO CHARACTERS OF RESULT
7233: *
7234: * MOVE PART 1 (START OF SUBJECT) TO RESULT
7235: *
7236: BZE WA,ORPL1 JUMP IF FIRST PART IS NULL
7237: MOV 1(XS),XL ELSE POINT TO SUBJECT STRING
7238: PLC XL POINT TO SUBJECT STRING CHARS
7239: MVC MOVE FIRST PART TO RESULT
7240: EJC
7241: * PATTERN REPLACEMENT (CONTINUED)
7242: *
7243: * NOW MOVE IN REPLACEMENT VALUE
7244: *
7245: ORPL1 MOV (XS)+,XL LOAD REPLACEMENT STRING, POP
7246: MOV SCLEN(XL),WA LOAD LENGTH
7247: BZE WA,ORPL2 JUMP IF NULL REPLACEMENT
7248: PLC XL ELSE POINT TO CHARS OF REPLACEMENT
7249: MVC MOVE IN CHARS (PART 2)
7250: *
7251: * NOW MOVE IN REMAINDER OF STRING (PART 3)
7252: *
7253: ORPL2 MOV (XS)+,XL LOAD SUBJECT STRING POINTER, POP
7254: MOV (XS)+,WC LOAD FINAL CURSOR, POP
7255: MOV SCLEN(XL),WA LOAD SUBJECT STRING LENGTH
7256: SUB WC,WA MINUS FINAL CURSOR = PART 3 LENGTH
7257: BZE WA,OASS0 JUMP TO ASSIGN IF PART 3 IS NULL
7258: PLC XL,WC ELSE POINT TO LAST PART OF STRING
7259: MVC MOVE PART 3 TO RESULT
7260: BRN OASS0 JUMP TO PERFORM ASSIGNMENT
7261: *
7262: * HERE IF RESULT IS NULL
7263: *
7264: ORPL3 ADD *NUM02,XS POP SUBJECT STR PTR, FINAL CURSOR
7265: MOV =NULLS,(XS) SET NULL RESULT
7266: BRN OASS0 JUMP TO ASSIGN NULL VALUE
7267: .IF .CNBF
7268: .ELSE
7269: *
7270: * HERE FOR BUFFER SUBSTRING ASSIGNMENT
7271: *
7272: ORPL4 MOV XR,XL COPY SCBLK REPLACEMENT PTR
7273: MOV (XS)+,XR UNSTACK BCBLK PTR
7274: MOV (XS)+,WB GET FINAL CURSOR VALUE
7275: MOV (XS)+,WA GET INITIAL CURSOR
7276: SUB WA,WB GET LENGTH IN WB
7277: ADD *NUM02,XS GET RID OF NAME BASE/OFFSET
7278: JSR INSBF INSERT SUBSTRING
7279: PPM CONVERT FAIL IMPOSSIBLE
7280: PPM EXFAL FAIL IF INSERT FAILS
7281: BRN EXNUL ELSE NULL RESULT
7282: .FI
7283: EJC
7284: *
7285: * RETURN VALUE FROM EXPRESSION
7286: *
7287: * THIS ENTRY POINTS IS USED IF THE EVALUATION OF AN
7288: * EXPRESSION, INITIATED BY THE EVALX PROCEDURE, RETURNS
7289: * A VALUE. CONTROL IS RETURNED TO THE PROPER POINT IN EVALX
7290: *
7291: O$RVL ENT ENTRY POINT
7292: BRN EVLX3 RETURN TO EVALX PROCEDURE
7293: EJC
7294: *
7295: * SELECTION
7296: *
7297: * INITIAL ENTRY
7298: *
7299: O$SLA ENT ENTRY POINT
7300: LCW WA LOAD NEW FAILURE OFFSET
7301: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER
7302: MOV WA,-(XS) STACK NEW FAILURE OFFSET
7303: MOV XS,FLPTR SET NEW FAILURE POINTER
7304: BRN EXITS JUMP TO EXECUTE FIRST ALTERNATIVE
7305: *
7306: * ENTRY AFTER SUCCESSFUL EVALUATION OF ALTERNATIVE
7307: *
7308: O$SLB ENT ENTRY POINT
7309: MOV (XS)+,XR LOAD RESULT
7310: ICA XS POP FAIL OFFSET
7311: MOV (XS),FLPTR RESTORE OLD FAILURE POINTER
7312: MOV XR,(XS) RESTACK RESULT
7313: LCW WA LOAD NEW CODE OFFSET
7314: ADD R$COD,WA POINT TO ABSOLUTE CODE LOCATION
7315: LCP WA SET NEW CODE POINTER
7316: BRN EXITS JUMP TO CONTINUE PAST SELECTION
7317: *
7318: * ENTRY AT START OF SUBSEQUENT ALTERNATIVES
7319: *
7320: O$SLC ENT ENTRY POINT
7321: LCW WA LOAD NEW FAIL OFFSET
7322: MOV WA,(XS) STORE NEW FAIL OFFSET
7323: BRN EXITS JUMP TO EXECUTE NEXT ALTERNATIVE
7324: *
7325: * ENTRY AT START OF LAST ALTERNATIVE
7326: *
7327: O$SLD ENT ENTRY POINT
7328: ICA XS POP FAILURE OFFSET
7329: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER
7330: BRN EXITS JUMP TO EXECUTE LAST ALTERNATIVE
7331: EJC
7332: *
7333: * BINARY MINUS (SUBTRACTION)
7334: *
7335: O$SUB ENT ENTRY POINT
7336: JSR ARITH FETCH ARITHMETIC OPERANDS
7337: ERR 032,SUBTRACTION LEFT OPERAND IS NOT NUMERIC
7338: ERR 033,SUBTRACTION RIGHT OPERAND IS NOT NUMERIC
7339: .IF .CNRA
7340: .ELSE
7341: PPM OSUB1 JUMP IF REAL OPERANDS
7342: .FI
7343: *
7344: * HERE TO SUBTRACT TWO INTEGERS
7345: *
7346: SBI ICVAL(XL) SUBTRACT RIGHT OPERAND FROM LEFT
7347: INO EXINT RETURN INTEGER IF NO OVERFLOW
7348: ERB 034,SUBTRACTION CAUSED INTEGER OVERFLOW
7349: .IF .CNRA
7350: .ELSE
7351: *
7352: * HERE TO SUBTRACT TWO REALS
7353: *
7354: OSUB1 SBR RCVAL(XL) SUBTRACT RIGHT OPERAND FROM LEFT
7355: RNO EXREA RETURN REAL IF NO OVERFLOW
7356: ERB 264,SUBTRACTION CAUSED REAL OVERFLOW
7357: .FI
7358: EJC
7359: *
7360: * DUMMY OPERATOR TO RETURN CONTROL TO TRXEQ PROCEDURE
7361: *
7362: O$TXR ENT ENTRY POINT
7363: BRN TRXQ1 JUMP INTO TRXEQ PROCEDURE
7364: EJC
7365: *
7366: * UNEXPECTED FAILURE
7367: *
7368: * NOTE THAT IF A SETEXIT TRAP IS OPERATING THEN
7369: * TRANSFER TO SYSTEM LABEL CONTINUE
7370: * WILL RESULT IN LOOPING HERE. DIFFICULT TO AVOID EXCEPT
7371: * WITH A CONSIDERABLE OVERHEAD WHICH IS NOT WORTHWHILE OR
7372: * ELSE BY A TECHNIQUE SUCH AS SETTING KVERL TO ZERO.
7373: *
7374: O$UNF ENT ENTRY POINT
7375: ERB 035,UNEXPECTED FAILURE IN -NOFAIL MODE
7376: TTL S P I T B O L -- SNOBOL4 BUILTIN LABEL ROUTINES
7377: *
7378: * THE FOLLOWING SECTION CONTAINS THE ROUTINES FOR LABELS
7379: * WHICH HAVE A PREDEFINED MEANING IN SNOBOL4.
7380: *
7381: * CONTROL IS PASSED DIRECTLY TO THE LABEL NAME ENTRY POINT.
7382: *
7383: * ENTRY NAMES ARE OF THE FORM L$XXX WHERE XXX IS THE THREE
7384: * LETTER VARIABLE NAME IDENTIFIER.
7385: *
7386: * ENTRIES ARE IN ALPHABETICAL ORDER
7387: EJC
7388: *
7389: * ABORT
7390: *
7391: L$ABO ENT ENTRY POINT
7392: *
7393: * MERGE HERE IF EXECUTION TERMINATES IN ERROR
7394: *
7395: LABO1 MOV KVERT,WA LOAD ERROR CODE
7396: BZE WA,LABO2 JUMP IF NO ERROR HAS OCCURED
7397: .IF .CSAX
7398: JSR SYSAX CALL AFTER EXECUTION PROC (REG04)
7399: .ELSE
7400: .FI
7401: JSR PRTPG ELSE EJECT PRINTER
7402: JSR ERMSG PRINT ERROR MESSAGE
7403: ZER XR INDICATE NO MESSAGE TO PRINT
7404: BRN STOPR JUMP TO ROUTINE TO STOP RUN
7405: *
7406: * HERE IF NO ERROR HAD OCCURED
7407: *
7408: LABO2 ERB 036,GOTO ABORT WITH NO PRECEDING ERROR
7409: EJC
7410: *
7411: * CONTINUE
7412: *
7413: L$CNT ENT ENTRY POINT
7414: *
7415: * MERGE HERE AFTER EXECUTION ERROR
7416: *
7417: LCNT1 MOV R$CNT,XR LOAD CONTINUATION CODE BLOCK PTR
7418: BZE XR,LCNT2 JUMP IF NO PREVIOUS ERROR
7419: ZER R$CNT CLEAR FLAG
7420: MOV XR,R$COD ELSE STORE AS NEW CODE BLOCK PTR
7421: ADD STXOF,XR ADD FAILURE OFFSET
7422: LCP XR LOAD CODE POINTER
7423: MOV FLPTR,XS RESET STACK POINTER
7424: BRN EXITS JUMP TO TAKE INDICATED FAILURE
7425: *
7426: * HERE IF NO PREVIOUS ERROR
7427: *
7428: LCNT2 ERB 037,GOTO CONTINUE WITH NO PRECEDING ERROR
7429: EJC
7430: *
7431: * END
7432: *
7433: L$END ENT ENTRY POINT
7434: *
7435: * MERGE HERE FROM END CODE CIRCUIT
7436: *
7437: LEND0 MOV =ENDMS,XR POINT TO MESSAGE /NORMAL TERM../
7438: BRN STOPR JUMP TO ROUTINE TO STOP RUN
7439: EJC
7440: *
7441: * FRETURN
7442: *
7443: L$FRT ENT ENTRY POINT
7444: MOV =SCFRT,WA POINT TO STRING /FRETURN/
7445: BRN RETRN JUMP TO COMMON RETURN ROUTINE
7446: EJC
7447: *
7448: * NRETURN
7449: *
7450: L$NRT ENT ENTRY POINT
7451: MOV =SCNRT,WA POINT TO STRING /NRETURN/
7452: BRN RETRN JUMP TO COMMON RETURN ROUTINE
7453: EJC
7454: *
7455: * RETURN
7456: *
7457: L$RTN ENT ENTRY POINT
7458: MOV =SCRTN,WA POINT TO STRING /RETURN/
7459: BRN RETRN JUMP TO COMMON RETURN ROUTINE
7460: EJC
7461: *
7462: * UNDEFINED LABEL
7463: *
7464: L$UND ENT ENTRY POINT
7465: ERB 038,GOTO UNDEFINED LABEL
7466: TTL S P I T B O L -- BLOCK ACTION ROUTINES
7467: *
7468: * THE FIRST WORD OF EVERY BLOCK IN DYNAMIC STORAGE AND THE
7469: * VRGET, VRSTO AND VRTRA FIELDS OF A VRBLK CONTAIN A
7470: * POINTER TO AN ENTRY POINT IN THE PROGRAM. ALL SUCH ENTRY
7471: * POINTS ARE IN THE FOLLOWING SECTION EXCEPT THOSE FOR
7472: * PATTERN BLOCKS WHICH ARE IN THE PATTERN MATCHING SEGMENT
7473: * LATER ON (LABELS OF THE FORM P$XXX), AND DOPE VECTORS
7474: * (D$XXX) WHICH ARE IN THE DOPE VECTOR SECTION FOLLOWING
7475: * THE PATTERN ROUTINES (DOPE VECTORS ARE USED FOR CMBLKS).
7476: *
7477: * THE ENTRY POINTS IN THIS SECTION HAVE LABELS OF THE
7478: * FORM B$XXY WHERE XX IS THE TWO CHARACTER BLOCK TYPE FOR
7479: * THE CORRESPONDING BLOCK AND Y IS ANY LETTER.
7480: *
7481: * IN SOME CASES, THE POINTERS SERVE NO OTHER PURPOSE THAN
7482: * TO IDENTIFY THE BLOCK TYPE. IN THIS CASE THE ROUTINE
7483: * IS NEVER EXECUTED AND THUS NO CODE IS ASSEMBLED.
7484: *
7485: * FOR EACH OF THESE ENTRY POINTS CORRESPONDING TO A BLOCK
7486: * AN ENTRY POINT IDENTIFICATION IS ASSEMBLED (BL$XX).
7487: *
7488: * THE EXACT ENTRY CONDITIONS DEPEND ON THE MANNER IN
7489: * WHICH THE ROUTINE IS ACCESSED AND ARE DOCUMENTED WITH
7490: * THE INDIVIDUAL ROUTINES AS REQUIRED.
7491: *
7492: * THE ORDER OF THESE ROUTINES IS ALPHABETICAL WITH THE
7493: * FOLLOWING EXCEPTIONS.
7494: *
7495: * THE ROUTINES FOR SEBLK AND EXBLK ENTRIES OCCUR FIRST SO
7496: * THAT EXPRESSIONS CAN BE QUICKLY IDENTIFIED FROM THE FACT
7497: * THAT THEIR ROUTINES LIE BEFORE THE SYMBOL B$E$$.
7498: *
7499: * THESE ARE IMMEDIATELY FOLLOWED BY THE ROUTINE FOR A TRBLK
7500: * SO THAT THE TEST AGAINST THE SYMBOL B$T$$ CHECKS FOR
7501: * TRAPPED VALUES OR EXPRESSION VALUES (SEE PROCEDURE EVALP)
7502: *
7503: * THE PATTERN ROUTINES LIE AFTER THIS SECTION SO THAT
7504: * PATTERNS ARE IDENTIFIED WITH ROUTINES STARTING AT OR
7505: * AFTER THE INITIAL INSTRUCTION IN THESE ROUTINES (P$AAA).
7506: *
7507: * THE SYMBOL B$AAA DEFINES THE FIRST LOCATION FOR BLOCK
7508: * ROUTINES AND THE SYMBOL P$YYY (AT THE END OF THE PATTERN
7509: * MATCH ROUTINES SECTION) DEFINES THE LAST SUCH ENTRY POINT
7510: *
7511: B$AAA ENT BL$$I ENTRY POINT OF FIRST BLOCK ROUTINE
7512: EJC
7513: *
7514: * EXBLK
7515: *
7516: * THE ROUTINE FOR AN EXBLK LOADS THE EXPRESSION ONTO
7517: * THE STACK AS A VALUE.
7518: *
7519: * (XR) POINTER TO EXBLK
7520: *
7521: B$EXL ENT BL$EX ENTRY POINT (EXBLK)
7522: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
7523: EJC
7524: *
7525: * SEBLK
7526: *
7527: * THE ROUTINE FOR SEBLK IS ACCESSED FROM THE GENERATED
7528: * CODE TO LOAD THE EXPRESSION VALUE ONTO THE STACK.
7529: *
7530: B$SEL ENT BL$SE ENTRY POINT (SEBLK)
7531: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
7532: *
7533: * DEFINE SYMBOL WHICH MARKS END OF ENTRIES FOR EXPRESSIONS
7534: *
7535: B$E$$ ENT BL$$I ENTRY POINT
7536: EJC
7537: *
7538: * TRBLK
7539: *
7540: * THE ROUTINE FOR A TRBLK IS NEVER EXECUTED
7541: *
7542: B$TRT ENT BL$TR ENTRY POINT (TRBLK)
7543: *
7544: * DEFINE SYMBOL MARKING END OF TRAP AND EXPRESSION BLOCKS
7545: *
7546: B$T$$ ENT BL$$I END OF TRBLK,SEBLK,EXBLK ENTRIES
7547: EJC
7548: *
7549: * ARBLK
7550: *
7551: * THE ROUTINE FOR ARBLK IS NEVER EXECUTED
7552: *
7553: B$ART ENT BL$AR ENTRY POINT (ARBLK)
7554: EJC
7555: .IF .CNBF
7556: .ELSE
7557: *
7558: * BCBLK
7559: *
7560: * THE ROUTINE FOR A BCBLK IS NEVER EXECUTED
7561: *
7562: * (XR) POINTER TO BCBLK
7563: *
7564: B$BCT ENT BL$BC ENTRY POINT (BCBLK)
7565: EJC
7566: *
7567: * BFBLK
7568: *
7569: * THE ROUTINE FOR A BFBLK IS NEVER EXECUTED
7570: *
7571: * (XR) POINTER TO BFBLK
7572: *
7573: B$BFT ENT BL$BF ENTRY POINT (BFBLK)
7574: EJC
7575: .FI
7576: *
7577: * CCBLK
7578: *
7579: * THE ROUTINE FOR CCBLK IS NEVER ENTERED
7580: *
7581: B$CCT ENT BL$CC ENTRY POINT (CCBLK)
7582: EJC
7583: *
7584: * CDBLK
7585: *
7586: * THE CDBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE.
7587: * THERE ARE TWO CASES DEPENDING ON THE FORM OF CDFAL.
7588: *
7589: * ENTRY FOR COMPLEX FAILURE CODE AT CDFAL
7590: *
7591: * (XR) POINTER TO CDBLK
7592: *
7593: B$CDC ENT BL$CD ENTRY POINT (CDBLK)
7594: BCDC0 MOV FLPTR,XS POP GARBAGE OFF STACK
7595: MOV CDFAL(XR),(XS) SET FAILURE OFFSET
7596: BRN STMGO ENTER STMT
7597: EJC
7598: *
7599: * CDBLK (CONTINUED)
7600: *
7601: * ENTRY FOR SIMPLE FAILURE CODE AT CDFAL
7602: *
7603: * (XR) POINTER TO CDBLK
7604: *
7605: B$CDS ENT BL$CD ENTRY POINT (CDBLK)
7606: BCDS0 MOV FLPTR,XS POP GARBAGE OFF STACK
7607: MOV *CDFAL,(XS) SET FAILURE OFFSET
7608: BRN STMGO ENTER STMT
7609: EJC
7610: *
7611: * CMBLK
7612: *
7613: * THE ROUTINE FOR A CMBLK IS NEVER EXECUTED
7614: *
7615: B$CMT ENT BL$CM ENTRY POINT (CMBLK)
7616: EJC
7617: *
7618: * CTBLK
7619: *
7620: * THE ROUTINE FOR A CTBLK IS NEVER EXECUTED
7621: *
7622: B$CTT ENT BL$CT ENTRY POINT (CTBLK)
7623: EJC
7624: *
7625: * DFBLK
7626: *
7627: * THE ROUTINE FOR A DFBLK IS ACCESSED FROM THE O$FNC ENTRY
7628: * TO CALL A DATATYPE FUNCTION AND BUILD A PDBLK.
7629: *
7630: * (XL) POINTER TO DFBLK
7631: *
7632: B$DFC ENT BL$DF ENTRY POINT
7633: MOV DFPDL(XL),WA LOAD LENGTH OF PDBLK
7634: JSR ALLOC ALLOCATE PDBLK
7635: MOV =B$PDT,(XR) STORE TYPE WORD
7636: MOV XL,PDDFP(XR) STORE DFBLK POINTER
7637: MOV XR,WC SAVE POINTER TO PDBLK
7638: ADD WA,XR POINT PAST PDBLK
7639: LCT WA,FARGS(XL) SET TO COUNT FIELDS
7640: *
7641: * LOOP TO ACQUIRE FIELD VALUES FROM STACK
7642: *
7643: BDFC1 MOV (XS)+,-(XR) MOVE A FIELD VALUE
7644: BCT WA,BDFC1 LOOP TILL ALL MOVED
7645: MOV WC,XR RECALL POINTER TO PDBLK
7646: BRN EXSID EXIT SETTING ID FIELD
7647: EJC
7648: *
7649: * EFBLK
7650: *
7651: * THE ROUTINE FOR AN EFBLK IS PASSED CONTROL FORM THE O$FNC
7652: * ENTRY TO CALL AN EXTERNAL FUNCTION.
7653: *
7654: * (XL) POINTER TO EFBLK
7655: *
7656: B$EFC ENT BL$EF ENTRY POINT (EFBLK)
7657: .IF .CNLD
7658: .ELSE
7659: MOV FARGS(XL),WC LOAD NUMBER OF ARGUMENTS
7660: WTB WC CONVERT TO OFFSET
7661: MOV XL,-(XS) SAVE POINTER TO EFBLK
7662: MOV XS,XT COPY POINTER TO ARGUMENTS
7663: *
7664: * LOOP TO CONVERT ARGUMENTS
7665: *
7666: BEFC1 ICA XT POINT TO NEXT ENTRY
7667: MOV (XS),XR LOAD POINTER TO EFBLK
7668: DCA WC DECREMENT EFTAR OFFSET
7669: ADD WC,XR POINT TO NEXT EFTAR ENTRY
7670: MOV EFTAR(XR),XR LOAD EFTAR ENTRY
7671: .IF .CNRA
7672: BSW XR,3 SWITCH ON TYPE
7673: .ELSE
7674: BSW XR,4 SWITCH ON TYPE
7675: .FI
7676: IFF 0,BEFC7 NO CONVERSION NEEDED
7677: IFF 1,BEFC2 STRING
7678: IFF 2,BEFC3 INTEGER
7679: .IF .CNRA
7680: .ELSE
7681: IFF 3,BEFC4 REAL
7682: .FI
7683: ESW END OF SWITCH ON TYPE
7684: *
7685: * HERE TO CONVERT TO STRING
7686: *
7687: BEFC2 MOV (XT),-(XS) STACK ARG PTR
7688: JSR GTSTG CONVERT ARGUMENT TO STRING
7689: ERR 039,EXTERNAL FUNCTION ARGUMENT IS NOT STRING
7690: BRN BEFC6 JUMP TO MERGE
7691: EJC
7692: *
7693: * EFBLK (CONTINUED)
7694: *
7695: * HERE TO CONVERT AN INTEGER
7696: *
7697: BEFC3 MOV (XT),XR LOAD NEXT ARGUMENT
7698: MOV WC,BEFOF SAVE OFFSET
7699: JSR GTINT CONVERT TO INTEGER
7700: ERR 040,EXTERNAL FUNCTION ARGUMENT IS NOT INTEGER
7701: .IF .CNRA
7702: .ELSE
7703: BRN BEFC5 MERGE WITH REAL CASE
7704: *
7705: * HERE TO CONVERT A REAL
7706: *
7707: BEFC4 MOV (XT),XR LOAD NEXT ARGUMENT
7708: MOV WC,BEFOF SAVE OFFSET
7709: JSR GTREA CONVERT TO REAL
7710: ERR 265,EXTERNAL FUNCTION ARGUMENT IS NOT REAL
7711: .FI
7712: *
7713: * INTEGER CASE MERGES HERE
7714: *
7715: BEFC5 MOV BEFOF,WC RESTORE OFFSET
7716: *
7717: * STRING MERGES HERE
7718: *
7719: BEFC6 MOV XR,(XT) STORE CONVERTED RESULT
7720: *
7721: * NO CONVERSION MERGES HERE
7722: *
7723: BEFC7 BNZ WC,BEFC1 LOOP BACK IF MORE TO GO
7724: *
7725: * HERE AFTER CONVERTING ALL THE ARGUMENTS
7726: *
7727: MOV (XS)+,XL RESTORE EFBLK POINTER
7728: MOV FARGS(XL),WA GET NUMBER OF ARGS
7729: JSR SYSEX CALL ROUTINE TO CALL EXTERNAL FNC
7730: PPM EXFAL FAIL IF FAILURE
7731: EJC
7732: *
7733: * EFBLK (CONTINUED)
7734: *
7735: * RETURN HERE WITH RESULT IN XR
7736: *
7737: * FIRST DEFEND AGAINST NON-STANDARD NULL STRING RETURNED
7738: *
7739: MOV EFRSL(XL),WB GET RESULT TYPE ID
7740: BNZ WB,BEFA8 BRANCH IF NOT UNCONVERTED
7741: BNE (XR),=B$SCL,BEFC8 JUMP IF NOT A STRING
7742: BZE SCLEN(XR),EXNUL RETURN NULL IF NULL
7743: *
7744: * HERE IF CONVERTED RESULT TO CHECK FOR NULL STRING
7745: *
7746: BEFA8 BNE WB,=NUM01,BEFC8 JUMP IF NOT A STRING
7747: BZE SCLEN(XR),EXNUL RETURN NULL IF NULL
7748: *
7749: * RETURN IF RESULT IS IN DYNAMIC STORAGE
7750: *
7751: BEFC8 BLT XR,DNAMB,BEFC9 JUMP IF NOT IN DYNAMIC STORAGE
7752: BLE XR,DNAMP,EXIXR RETURN RESULT IF ALREADY DYNAMIC
7753: *
7754: * HERE WE COPY A RESULT INTO THE DYNAMIC REGION
7755: *
7756: BEFC9 MOV (XR),WA GET POSSIBLE TYPE WORD
7757: BZE WB,BEF11 JUMP IF UNCONVERTED RESULT
7758: MOV =B$SCL,WA STRING
7759: BEQ WB,=NUM01,BEF10 YES JUMP
7760: MOV =B$ICL,WA INTEGER
7761: BEQ WB,=NUM02,BEF10 YES JUMP
7762: .IF .CNRA
7763: .ELSE
7764: MOV =B$RCL,WA REAL
7765: .FI
7766: *
7767: * STORE TYPE WORD IN RESULT
7768: *
7769: BEF10 MOV WA,(XR) STORED BEFORE COPYING TO DYNAMIC
7770: *
7771: * MERGE FOR UNCONVERTED RESULT
7772: *
7773: BEF11 JSR BLKLN GET LENGTH OF BLOCK
7774: MOV XR,XL COPY ADDRESS OF OLD BLOCK
7775: JSR ALLOC ALLOCATE DYNAMIC BLOCK SAME SIZE
7776: MOV XR,-(XS) SET POINTER TO NEW BLOCK AS RESULT
7777: MVW COPY OLD BLOCK TO DYNAMIC BLOCK
7778: BRN EXITS EXIT WITH RESULT ON STACK
7779: .FI
7780: EJC
7781: *
7782: * EVBLK
7783: *
7784: * THE ROUTINE FOR AN EVBLK IS NEVER EXECUTED
7785: *
7786: B$EVT ENT BL$EV ENTRY POINT (EVBLK)
7787: EJC
7788: *
7789: * FFBLK
7790: *
7791: * THE ROUTINE FOR AN FFBLK IS EXECUTED FROM THE O$FNC ENTRY
7792: * TO CALL A FIELD FUNCTION AND EXTRACT A FIELD VALUE/NAME.
7793: *
7794: * (XL) POINTER TO FFBLK
7795: *
7796: B$FFC ENT BL$FF ENTRY POINT (FFBLK)
7797: MOV XL,XR COPY FFBLK POINTER
7798: LCW WC LOAD NEXT CODE WORD
7799: MOV (XS),XL LOAD PDBLK POINTER
7800: BNE (XL),=B$PDT,BFFC2 JUMP IF NOT PDBLK AT ALL
7801: MOV PDDFP(XL),WA LOAD DFBLK POINTER FROM PDBLK
7802: *
7803: * LOOP TO FIND CORRECT FFBLK FOR THIS PDBLK
7804: *
7805: BFFC1 BEQ WA,FFDFP(XR),BFFC3 JUMP IF THIS IS THE CORRECT FFBLK
7806: MOV FFNXT(XR),XR ELSE LINK TO NEXT FFBLK ON CHAIN
7807: BNZ XR,BFFC1 LOOP BACK IF ANOTHER ENTRY TO CHECK
7808: *
7809: * HERE FOR BAD ARGUMENT
7810: *
7811: BFFC2 ERB 041,FIELD FUNCTION ARGUMENT IS WRONG DATATYPE
7812: EJC
7813: *
7814: * FFBLK (CONTINUED)
7815: *
7816: * HERE AFTER LOCATING CORRECT FFBLK
7817: *
7818: BFFC3 MOV FFOFS(XR),WA LOAD FIELD OFFSET
7819: BEQ WC,=OFNE$,BFFC5 JUMP IF CALLED BY NAME
7820: ADD WA,XL ELSE POINT TO VALUE FIELD
7821: MOV (XL),XR LOAD VALUE
7822: BNE (XR),=B$TRT,BFFC4 JUMP IF NOT TRAPPED
7823: SUB WA,XL ELSE RESTORE NAME BASE,OFFSET
7824: MOV WC,(XS) SAVE NEXT CODE WORD OVER PDBLK PTR
7825: JSR ACESS ACCESS VALUE
7826: PPM EXFAL FAIL IF ACCESS FAILS
7827: MOV (XS),WC RESTORE NEXT CODE WORD
7828: *
7829: * HERE AFTER GETTING VALUE IN (XR)
7830: *
7831: BFFC4 MOV XR,(XS) STORE VALUE ON STACK (OVER PDBLK)
7832: MOV WC,XR COPY NEXT CODE WORD
7833: MOV (XR),XL LOAD ENTRY ADDRESS
7834: BRI XL JUMP TO ROUTINE FOR NEXT CODE WORD
7835: *
7836: * HERE IF CALLED BY NAME
7837: *
7838: BFFC5 MOV WA,-(XS) STORE NAME OFFSET (BASE IS SET)
7839: BRN EXITS EXIT WITH NAME ON STACK
7840: EJC
7841: *
7842: * ICBLK
7843: *
7844: * THE ROUTINE FOR ICBLK IS EXECUTED FROM THE GENERATED
7845: * CODE TO LOAD AN INTEGER VALUE ONTO THE STACK.
7846: *
7847: * (XR) POINTER TO ICBLK
7848: *
7849: B$ICL ENT BL$IC ENTRY POINT (ICBLK)
7850: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
7851: EJC
7852: *
7853: * KVBLK
7854: *
7855: * THE ROUTINE FOR A KVBLK IS NEVER EXECUTED.
7856: *
7857: B$KVT ENT BL$KV ENTRY POINT (KVBLK)
7858: EJC
7859: *
7860: * NMBLK
7861: *
7862: * THE ROUTINE FOR A NMBLK IS EXECUTED FROM THE GENERATED
7863: * CODE FOR THE CASE OF LOADING A NAME ONTO THE STACK
7864: * WHERE THE NAME IS THAT OF A NATURAL VARIABLE WHICH CAN
7865: * BE PREEVALUATED AT COMPILE TIME.
7866: *
7867: * (XR) POINTER TO NMBLK
7868: *
7869: B$NML ENT BL$NM ENTRY POINT (NMBLK)
7870: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
7871: EJC
7872: *
7873: * PDBLK
7874: *
7875: * THE ROUTINE FOR A PDBLK IS NEVER EXECUTED
7876: *
7877: B$PDT ENT BL$PD ENTRY POINT (PDBLK)
7878: EJC
7879: *
7880: * PFBLK
7881: *
7882: * THE ROUTINE FOR A PFBLK IS EXECUTED FROM THE ENTRY O$FNC
7883: * TO CALL A PROGRAM DEFINED FUNCTION.
7884: *
7885: * (XL) POINTER TO PFBLK
7886: *
7887: * THE FOLLOWING STACK ENTRIES ARE MADE BEFORE PASSING
7888: * CONTROL TO THE PROGRAM DEFINED FUNCTION.
7889: *
7890: * SAVED VALUE OF FIRST ARGUMENT
7891: * .
7892: * SAVED VALUE OF LAST ARGUMENT
7893: * SAVED VALUE OF FIRST LOCAL
7894: * .
7895: * SAVED VALUE OF LAST LOCAL
7896: * SAVED VALUE OF FUNCTION NAME
7897: * SAVED CODE BLOCK PTR (R$COD)
7898: * SAVED CODE POINTER (-R$COD)
7899: * SAVED VALUE OF FLPRT
7900: * SAVED VALUE OF FLPTR
7901: * POINTER TO PFBLK
7902: * FLPTR --------------- ZERO (TO BE OVERWRITTEN WITH OFFS)
7903: *
7904: B$PFC ENT BL$PF ENTRY POINT (PFBLK)
7905: MOV XL,BPFPF SAVE PFBLK PTR (NEED NOT BE RELOC)
7906: MOV XL,XR COPY FOR THE MOMENT
7907: MOV PFVBL(XR),XL POINT TO VRBLK FOR FUNCTION
7908: *
7909: * LOOP TO FIND OLD VALUE OF FUNCTION
7910: *
7911: BPF01 MOV XL,WB SAVE POINTER
7912: MOV VRVAL(XL),XL LOAD VALUE
7913: BEQ (XL),=B$TRT,BPF01 LOOP IF TRBLK
7914: *
7915: * SET VALUE TO NULL AND SAVE OLD FUNCTION VALUE
7916: *
7917: MOV XL,BPFSV SAVE OLD VALUE
7918: MOV WB,XL POINT BACK TO BLOCK WITH VALUE
7919: MOV =NULLS,VRVAL(XL) SET VALUE TO NULL
7920: MOV FARGS(XR),WA LOAD NUMBER OF ARGUMENTS
7921: ADD *PFARG,XR POINT TO PFARG ENTRIES
7922: BZE WA,BPF04 JUMP IF NO ARGUMENTS
7923: MOV XS,XT PTR TO LAST ARG
7924: WTB WA CONVERT NO. OF ARGS TO BYTES OFFSET
7925: ADD WA,XT POINT BEFORE FIRST ARG
7926: MOV XT,BPFXT REMEMBER ARG POINTER
7927: EJC
7928: *
7929: * PFBLK (CONTINUED)
7930: *
7931: * LOOP TO SAVE OLD ARGUMENT VALUES AND SET NEW ONES
7932: *
7933: BPF02 MOV (XR)+,XL LOAD VRBLK PTR FOR NEXT ARGUMENT
7934: *
7935: * LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE
7936: *
7937: BPF03 MOV XL,WC SAVE POINTER
7938: MOV VRVAL(XL),XL LOAD NEXT VALUE
7939: BEQ (XL),=B$TRT,BPF03 LOOP BACK IF TRBLK
7940: *
7941: * SAVE OLD VALUE AND GET NEW VALUE
7942: *
7943: MOV XL,WA KEEP OLD VALUE
7944: MOV BPFXT,XT POINT BEFORE NEXT STACKED ARG
7945: MOV -(XT),WB LOAD ARGUMENT (NEW VALUE)
7946: MOV WA,(XT) SAVE OLD VALUE
7947: MOV XT,BPFXT KEEP ARG PTR FOR NEXT TIME
7948: MOV WC,XL POINT BACK TO BLOCK WITH VALUE
7949: MOV WB,VRVAL(XL) SET NEW VALUE
7950: BNE XS,BPFXT,BPF02 LOOP IF NOT ALL DONE
7951: *
7952: * NOW PROCESS LOCALS
7953: *
7954: BPF04 MOV BPFPF,XL RESTORE PFBLK POINTER
7955: MOV PFNLO(XL),WA LOAD NUMBER OF LOCALS
7956: BZE WA,BPF07 JUMP IF NO LOCALS
7957: MOV =NULLS,WB GET NULL CONSTANT
7958: LCT WA,WA SET LOCAL COUNTER
7959: *
7960: * LOOP TO PROCESS LOCALS
7961: *
7962: BPF05 MOV (XR)+,XL LOAD VRBLK PTR FOR NEXT LOCAL
7963: *
7964: * LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE
7965: *
7966: BPF06 MOV XL,WC SAVE POINTER
7967: MOV VRVAL(XL),XL LOAD NEXT VALUE
7968: BEQ (XL),=B$TRT,BPF06 LOOP BACK IF TRBLK
7969: *
7970: * SAVE OLD VALUE AND SET NULL AS NEW VALUE
7971: *
7972: MOV XL,-(XS) STACK OLD VALUE
7973: MOV WC,XL POINT BACK TO BLOCK WITH VALUE
7974: MOV WB,VRVAL(XL) SET NULL AS NEW VALUE
7975: BCT WA,BPF05 LOOP TILL ALL LOCALS PROCESSED
7976: EJC
7977: *
7978: * PFBLK (CONTINUED)
7979: *
7980: * HERE AFTER PROCESSING ARGUMENTS AND LOCALS
7981: *
7982: .IF .CNPF
7983: BPF07 MOV R$COD,WA LOAD OLD CODE BLOCK POINTER
7984: .ELSE
7985: BPF07 ZER XR ZERO REG XR IN CASE
7986: BZE KVPFL,BPF7C SKIP IF PROFILING IS OFF
7987: BEQ KVPFL,=NUM02,BPF7A BRANCH ON TYPE OF PROFILE
7988: *
7989: * HERE IF &PROFILE = 1
7990: *
7991: JSR SYSTM GET CURRENT TIME
7992: STI PFETM SAVE FOR A SEC
7993: SBI PFSTM FIND TIME USED BY CALLER
7994: JSR ICBLD BUILD INTO AN ICBLK
7995: LDI PFETM RELOAD CURRENT TIME
7996: BRN BPF7B MERGE
7997: *
7998: * HERE IF &PROFILE = 2
7999: *
8000: BPF7A LDI PFSTM GET START TIME OF CALLING STMT
8001: JSR ICBLD ASSEMBLE AN ICBLK ROUND IT
8002: JSR SYSTM GET NOW TIME
8003: *
8004: * BOTH TYPES OF PROFILE MERGE HERE
8005: *
8006: BPF7B STI PFSTM SET START TIME OF 1ST FUNC STMT
8007: MNZ PFFNC FLAG FUNCTION ENTRY
8008: *
8009: * NO PROFILING MERGES HERE
8010: *
8011: BPF7C MOV XR,-(XS) STACK ICBLK PTR (OR ZERO)
8012: MOV R$COD,WA LOAD OLD CODE BLOCK POINTER
8013: .FI
8014: SCP WB GET CODE POINTER
8015: SUB WA,WB MAKE CODE POINTER INTO OFFSET
8016: MOV BPFPF,XL RECALL PFBLK POINTER
8017: MOV BPFSV,-(XS) STACK OLD VALUE OF FUNCTION NAME
8018: MOV WA,-(XS) STACK CODE BLOCK POINTER
8019: MOV WB,-(XS) STACK CODE OFFSET
8020: MOV FLPRT,-(XS) STACK OLD FLPRT
8021: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER
8022: MOV XL,-(XS) STACK POINTER TO PFBLK
8023: ZER -(XS) DUMMY ZERO ENTRY FOR FAIL RETURN
8024: CHK CHECK FOR STACK OVERFLOW
8025: MOV XS,FLPTR SET NEW FAIL RETURN VALUE
8026: MOV XS,FLPRT SET NEW FLPRT
8027: MOV KVTRA,WA LOAD TRACE VALUE
8028: ADD KVFTR,WA ADD FTRACE VALUE
8029: BNZ WA,BPF09 JUMP IF TRACING POSSIBLE
8030: ICV KVFNC ELSE BUMP FNCLEVEL
8031: *
8032: * HERE TO ACTUALLY JUMP TO FUNCTION
8033: *
8034: BPF08 MOV PFCOD(XL),XR POINT TO CODE
8035: BRI (XR) OFF TO EXECUTE FUNCTION
8036: *
8037: * HERE IF TRACING IS POSSIBLE
8038: *
8039: BPF09 MOV PFCTR(XL),XR LOAD POSSIBLE CALL TRACE TRBLK
8040: MOV PFVBL(XL),XL LOAD VRBLK POINTER FOR FUNCTION
8041: MOV *VRVAL,WA SET NAME OFFSET FOR VARIABLE
8042: BZE KVTRA,BPF10 JUMP IF TRACE MODE IS OFF
8043: BZE XR,BPF10 OR IF THERE IS NO CALL TRACE
8044: *
8045: * HERE IF CALL TRACED
8046: *
8047: DCV KVTRA DECREMENT TRACE COUNT
8048: BZE TRFNC(XR),BPF11 JUMP IF PRINT TRACE
8049: JSR TRXEQ EXECUTE FUNCTION TYPE TRACE
8050: EJC
8051: *
8052: * PFBLK (CONTINUED)
8053: *
8054: * HERE TO TEST FOR FTRACE TRACE
8055: *
8056: BPF10 BZE KVFTR,BPF16 JUMP IF FTRACE IS OFF
8057: DCV KVFTR ELSE DECREMENT FTRACE
8058: *
8059: * HERE FOR PRINT TRACE
8060: *
8061: BPF11 JSR PRTSN PRINT STATEMENT NUMBER
8062: JSR PRTNM PRINT FUNCTION NAME
8063: MOV =CH$PP,WA LOAD LEFT PAREN
8064: JSR PRTCH PRINT LEFT PAREN
8065: MOV 1(XS),XL RECOVER PFBLK POINTER
8066: BZE FARGS(XL),BPF15 SKIP IF NO ARGUMENTS
8067: ZER WB ELSE SET ARGUMENT COUNTER
8068: BRN BPF13 JUMP INTO LOOP
8069: *
8070: * LOOP TO PRINT ARGUMENT VALUES
8071: *
8072: BPF12 MOV =CH$CM,WA LOAD COMMA
8073: JSR PRTCH PRINT TO SEPARATE FROM LAST ARG
8074: *
8075: * MERGE HERE FIRST TIME (NO COMMA REQUIRED)
8076: *
8077: BPF13 MOV WB,(XS) SAVE ARG CTR (OVER FAILOFFS IS OK)
8078: WTB WB CONVERT TO BYTE OFFSET
8079: ADD WB,XL POINT TO NEXT ARGUMENT POINTER
8080: MOV PFARG(XL),XR LOAD NEXT ARGUMENT VRBLK PTR
8081: SUB WB,XL RESTORE PFBLK POINTER
8082: MOV VRVAL(XR),XR LOAD NEXT VALUE
8083: JSR PRTVL PRINT ARGUMENT VALUE
8084: EJC
8085: *
8086: * HERE AFTER DEALING WITH ONE ARGUMENT
8087: *
8088: MOV (XS),WB RESTORE ARGUMENT COUNTER
8089: ICV WB INCREMENT ARGUMENT COUNTER
8090: BLT WB,FARGS(XL),BPF12 LOOP IF MORE TO PRINT
8091: *
8092: * MERGE HERE IN NO ARGS CASE TO PRINT PAREN
8093: *
8094: BPF15 MOV =CH$RP,WA LOAD RIGHT PAREN
8095: JSR PRTCH PRINT TO TERMINATE OUTPUT
8096: JSR PRTNL TERMINATE PRINT LINE
8097: *
8098: * MERGE HERE TO EXIT WITH TEST FOR FNCLEVEL TRACE
8099: *
8100: BPF16 ICV KVFNC INCREMENT FNCLEVEL
8101: MOV R$FNC,XL LOAD PTR TO POSSIBLE TRBLK
8102: JSR KTREX CALL KEYWORD TRACE ROUTINE
8103: *
8104: * CALL FUNCTION AFTER TRACE TESTS COMPLETE
8105: *
8106: MOV 1(XS),XL RESTORE PFBLK POINTER
8107: BRN BPF08 JUMP BACK TO EXECUTE FUNCTION
8108: .IF .CNRA
8109: .ELSE
8110: EJC
8111: *
8112: * RCBLK
8113: *
8114: * THE ROUTINE FOR AN RCBLK IS EXECUTED FROM THE GENERATED
8115: * CODE TO LOAD A REAL VALUE ONTO THE STACK.
8116: *
8117: * (XR) POINTER TO RCBLK
8118: *
8119: B$RCL ENT BL$RC ENTRY POINT (RCBLK)
8120: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
8121: .FI
8122: EJC
8123: *
8124: * SCBLK
8125: *
8126: * THE ROUTINE FOR AN SCBLK IS EXECUTED FROM THE GENERATED
8127: * CODE TO LOAD A STRING VALUE ONTO THE STACK.
8128: *
8129: * (XR) POINTER TO SCBLK
8130: *
8131: B$SCL ENT BL$SC ENTRY POINT (SCBLK)
8132: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
8133: EJC
8134: *
8135: * TBBLK
8136: *
8137: * THE ROUTINE FOR A TBBLK IS NEVER EXECUTED
8138: *
8139: B$TBT ENT BL$TB ENTRY POINT (TBBLK)
8140: EJC
8141: *
8142: * TEBLK
8143: *
8144: * THE ROUTINE FOR A TEBLK IS NEVER EXECUTED
8145: *
8146: B$TET ENT BL$TE ENTRY POINT (TEBLK)
8147: EJC
8148: *
8149: * VCBLK
8150: *
8151: * THE ROUTINE FOR A VCBLK IS NEVER EXECUTED
8152: *
8153: B$VCT ENT BL$VC ENTRY POINT (VCBLK)
8154: EJC
8155: *
8156: * VRBLK
8157: *
8158: * THE VRBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE.
8159: * THERE ARE SIX ENTRIES FOR VRBLK COVERING VARIOUS CASES
8160: *
8161: B$VR$ ENT BL$$I MARK START OF VRBLK ENTRY POINTS
8162: *
8163: * ENTRY FOR VRGET (TRAPPED CASE). THIS ROUTINE IS CALLED
8164: * FROM THE GENERATED CODE TO LOAD THE VALUE OF A VARIABLE.
8165: * THIS ENTRY POINT IS USED IF AN ACCESS TRACE OR INPUT
8166: * ASSOCIATION IS CURRENTLY ACTIVE.
8167: *
8168: * (XR) POINTER TO VRGET FIELD OF VRBLK
8169: *
8170: B$VRA ENT BL$$I ENTRY POINT
8171: MOV XR,XL COPY NAME BASE (VRGET = 0)
8172: MOV *VRVAL,WA SET NAME OFFSET
8173: JSR ACESS ACCESS VALUE
8174: PPM EXFAL FAIL IF ACCESS FAILS
8175: BRN EXIXR ELSE EXIT WITH RESULT IN XR
8176: EJC
8177: *
8178: * VRBLK (CONTINUED)
8179: *
8180: * ENTRY FOR VRSTO (ERROR CASE. THIS ROUTINE IS CALLED FROM
8181: * THE EXECUTED CODE FOR AN ATTEMPT TO MODIFY THE VALUE
8182: * OF A PROTECTED (PATTERN VALUED) NATURAL VARIABLE.
8183: *
8184: B$VRE ENT ENTRY POINT
8185: ERB 042,ATTEMPT TO CHANGE VALUE OF PROTECTED VARIABLE
8186: EJC
8187: *
8188: * VRBLK (CONTINUED)
8189: *
8190: * ENTRY FOR VRTRA (UNTRAPPED CASE). THIS ROUTINE IS CALLED
8191: * FROM THE EXECUTED CODE TO TRANSFER TO A LABEL.
8192: *
8193: * (XR) POINTER TO VRTRA FIELD OF VRBLK
8194: *
8195: B$VRG ENT ENTRY POINT
8196: MOV VRLBO(XR),XR LOAD CODE POINTER
8197: MOV (XR),XL LOAD ENTRY ADDRESS
8198: BRI XL JUMP TO ROUTINE FOR NEXT CODE WORD
8199: EJC
8200: *
8201: * VRBLK (CONTINUED)
8202: *
8203: * ENTRY FOR VRGET (UNTRAPPED CASE). THIS ROUTINE IS CALLED
8204: * FROM THE GENERATED CODE TO LOAD THE VALUE OF A VARIABLE.
8205: *
8206: * (XR) POINTS TO VRGET FIELD OF VRBLK
8207: *
8208: B$VRL ENT ENTRY POINT
8209: MOV VRVAL(XR),-(XS) LOAD VALUE ONTO STACK (VRGET = 0)
8210: BRN EXITS OBEY NEXT CODE WORD
8211: EJC
8212: *
8213: * VRBLK (CONTINUED)
8214: *
8215: * ENTRY FOR VRSTO (UNTRAPPED CASE). THIS ROUTINE IS CALLED
8216: * FROM THE GENERATED CODE TO STORE THE VALUE OF A VARIABLE.
8217: *
8218: * (XR) POINTER TO VRSTO FIELD OF VRBLK
8219: *
8220: B$VRS ENT ENTRY POINT
8221: MOV (XS),VRVLO(XR) STORE VALUE, LEAVE ON STACK
8222: BRN EXITS OBEY NEXT CODE WORD
8223: EJC
8224: *
8225: * VRBLK (CONTINUED)
8226: *
8227: * VRTRA (TRAPPED CASE). THIS ROUTINE IS CALLED FROM THE
8228: * GENERATED CODE TO TRANSFER TO A LABEL WHEN A LABEL
8229: * TRACE IS CURRENTLY ACTIVE.
8230: *
8231: B$VRT ENT ENTRY POINT
8232: SUB *VRTRA,XR POINT BACK TO START OF VRBLK
8233: MOV XR,XL COPY VRBLK POINTER
8234: MOV *VRVAL,WA SET NAME OFFSET
8235: MOV VRLBL(XL),XR LOAD POINTER TO TRBLK
8236: BZE KVTRA,BVRT2 JUMP IF TRACE IS OFF
8237: DCV KVTRA ELSE DECREMENT TRACE COUNT
8238: BZE TRFNC(XR),BVRT1 JUMP IF PRINT TRACE CASE
8239: JSR TRXEQ ELSE EXECUTE FULL TRACE
8240: BRN BVRT2 MERGE TO JUMP TO LABEL
8241: *
8242: * HERE FOR PRINT TRACE -- PRINT COLON ( LABEL NAME )
8243: *
8244: BVRT1 JSR PRTSN PRINT STATEMENT NUMBER
8245: MOV XL,XR COPY VRBLK POINTER
8246: MOV =CH$CL,WA COLON
8247: JSR PRTCH PRINT IT
8248: MOV =CH$PP,WA LEFT PAREN
8249: JSR PRTCH PRINT IT
8250: JSR PRTVN PRINT LABEL NAME
8251: MOV =CH$RP,WA RIGHT PAREN
8252: JSR PRTCH PRINT IT
8253: JSR PRTNL TERMINATE LINE
8254: MOV VRLBL(XL),XR POINT BACK TO TRBLK
8255: *
8256: * MERGE HERE TO JUMP TO LABEL
8257: *
8258: BVRT2 MOV TRLBL(XR),XR LOAD POINTER TO ACTUAL CODE
8259: BRI (XR) EXECUTE STATEMENT AT LABEL
8260: EJC
8261: *
8262: * VRBLK (CONTINUED)
8263: *
8264: * ENTRY FOR VRSTO (TRAPPED CASE). THIS ROUTINE IS CALLED
8265: * FROM THE GENERATED CODE TO STORE THE VALUE OF A VARIABLE.
8266: * THIS ENTRY IS USED WHEN A VALUE TRACE OR OUTPUT
8267: * ASSOCIATION IS CURRENTLY ACTIVE.
8268: *
8269: * (XR) POINTER TO VRSTO FIELD OF VRBLK
8270: *
8271: B$VRV ENT ENTRY POINT
8272: MOV (XS),WB LOAD VALUE (LEAVE COPY ON STACK)
8273: SUB *VRSTO,XR POINT TO VRBLK
8274: MOV XR,XL COPY VRBLK POINTER
8275: MOV *VRVAL,WA SET OFFSET
8276: JSR ASIGN CALL ASSIGNMENT ROUTINE
8277: PPM EXFAL FAIL IF ASSIGNMENT FAILS
8278: BRN EXITS ELSE RETURN WITH RESULT ON STACK
8279: EJC
8280: *
8281: * XNBLK
8282: *
8283: * THE ROUTINE FOR AN XNBLK IS NEVER EXECUTED
8284: *
8285: B$XNT ENT BL$XN ENTRY POINT (XNBLK)
8286: EJC
8287: *
8288: * XRBLK
8289: *
8290: * THE ROUTINE FOR AN XRBLK IS NEVER EXECUTED
8291: *
8292: B$XRT ENT BL$XR ENTRY POINT (XRBLK)
8293: *
8294: * MARK ENTRY ADDRESS PAST LAST BLOCK ACTION ROUTINE
8295: *
8296: B$YYY ENT BL$$I LAST BLOCK ROUTINE ENTRY POINT
8297: TTL S P I T B O L -- PATTERN MATCHING ROUTINES
8298: *
8299: * THE FOLLOWING SECTION CONSISTS OF THE PATTERN MATCHING
8300: * ROUTINES. ALL PATTERN NODES CONTAIN A POINTER (PCODE)
8301: * TO ONE OF THE ROUTINES IN THIS SECTION (P$XXX).
8302: *
8303: * NOTE THAT THIS SECTION FOLLOWS THE B$XXX ROUTINES TO
8304: * ENABLE A FAST TEST FOR THE PATTERN DATATYPE.
8305: *
8306: P$AAA ENT BL$$I ENTRY TO MARK FIRST PATTERN
8307: *
8308: *
8309: * THE ENTRY CONDITIONS TO THE MATCH ROUTINE ARE AS FOLLOWS
8310: * (SEE O$PMN, O$PMV, O$PMS AND PROCEDURE MATCH).
8311: *
8312: * STACK CONTENTS.
8313: *
8314: * NAME BASE (O$PMN ONLY)
8315: * NAME OFFSET (O$PMN ONLY)
8316: * TYPE (0-O$PMN, 1-O$PMV, 2-O$PMS)
8317: * PMHBS --------------- INITIAL CURSOR (ZERO)
8318: * INITIAL NODE POINTER
8319: * XS ------------------ =NDABO (ANCHORED), =NDUNA (UNANCH)
8320: *
8321: * REGISTER VALUES.
8322: *
8323: * (XS) SET AS SHOWN IN STACK DIAGRAM
8324: * (XR) POINTER TO INITIAL PATTERN NODE
8325: * (WB) INITIAL CURSOR (ZERO)
8326: *
8327: * GLOBAL PATTERN VALUES
8328: *
8329: * R$PMS POINTER TO SUBJECT STRING SCBLK
8330: * PMSSL LENGTH OF SUBJECT STRING IN CHARS
8331: * PMDFL DOT FLAG, INITIALLY ZERO
8332: * PMHBS SET AS SHOWN IN STACK DIAGRAM
8333: *
8334: * CONTROL IS PASSED BY BRANCHING THROUGH THE PCODE
8335: * FIELD OF THE INITIAL PATTERN NODE (BRI (XR)).
8336: EJC
8337: *
8338: * DESCRIPTION OF ALGORITHM
8339: *
8340: * A PATTERN STRUCTURE IS REPRESENTED AS A LINKED GRAPH
8341: * OF NODES WITH THE FOLLOWING STRUCTURE.
8342: *
8343: * +------------------------------------+
8344: * I PCODE I
8345: * +------------------------------------+
8346: * I PTHEN I
8347: * +------------------------------------+
8348: * I PARM1 I
8349: * +------------------------------------+
8350: * I PARM2 I
8351: * +------------------------------------+
8352: *
8353: * PCODE IS A POINTER TO THE ROUTINE WHICH WILL PERFORM
8354: * THE MATCH OF THIS PARTICULAR NODE TYPE.
8355: *
8356: * PTHEN IS A POINTER TO THE SUCCESSOR NODE. I.E. THE NODE
8357: * TO BE MATCHED IF THE ATTEMPT TO MATCH THIS NODE SUCCEEDS.
8358: * IF THIS IS THE LAST NODE OF THE PATTERN PTHEN POINTS
8359: * TO THE DUMMY NODE NDNTH WHICH INITIATES PATTERN EXIT.
8360: *
8361: * PARM1, PARM2 ARE PARAMETERS WHOSE USE VARIES WITH THE
8362: * PARTICULAR NODE. THEY ARE ONLY PRESENT IF REQUIRED.
8363: *
8364: * ALTERNATIVES ARE HANDLED WITH THE SPECIAL ALTERNATIVE
8365: * NODE WHOSE PARAMETER POINTS TO THE NODE TO BE MATCHED
8366: * IF THERE IS A FAILURE ON THE SUCCESSOR PATH.
8367: *
8368: * THE FOLLOWING EXAMPLE ILLUSTRATES THE MANNER IN WHICH
8369: * THE STRUCTURE IS BUILT UP. THE PATTERN IS
8370: *
8371: * (A / B / C) (D / E) WHERE / IS ALTERNATION
8372: *
8373: * IN THE DIAGRAM, THE NODE MARKED + REPRESENTS AN
8374: * ALTERNATIVE NODE AND THE DOTTED LINE FROM A + NODE
8375: * REPRESENTS THE PARAMETER POINTER TO THE ALTERNATIVE.
8376: *
8377: * +---+ +---+ +---+ +---+
8378: * I + I-----I A I-----I + I-----I D I-----
8379: * +---+ +---+ I +---+ +---+
8380: * . I .
8381: * . I .
8382: * +---+ +---+ I +---+
8383: * I + I-----I B I--I I E I-----
8384: * +---+ +---+ I +---+
8385: * . I
8386: * . I
8387: * +---+ I
8388: * I C I------------I
8389: * +---+
8390: EJC
8391: *
8392: * DURING THE MATCH, THE REGISTERS ARE USED AS FOLLOWS.
8393: *
8394: * (XR) POINTS TO THE CURRENT NODE
8395: * (XL) SCRATCH
8396: * (XS) MAIN STACK POINTER
8397: * (WB) CURSOR (NUMBER OF CHARS MATCHED)
8398: * (WA,WC) SCRATCH
8399: *
8400: * TO KEEP TRACK OF ALTERNATIVES, THE MAIN STACK IS USED AS
8401: * A HISTORY STACK AND CONTAINS TWO WORD ENTRIES.
8402: *
8403: * WORD 1 SAVED CURSOR VALUE
8404: * WORD 2 NODE TO MATCH ON FAILURE
8405: *
8406: * WHEN A FAILURE OCCURS, THE MOST RECENT ENTRY ON THIS
8407: * STACK IS POPPED OFF TO RESTORE THE CURSOR AND POINT
8408: * TO THE NODE TO BE MATCHED AS AN ALTERNATIVE. THE ENTRY
8409: * AT THE BOTTOM OF THE STACK POINTS TO THE FOLLOWING
8410: * SPECIAL NODES DEPENDING ON THE SCAN MODE.
8411: *
8412: * ANCHORED MODE THE BOTTOM ENTRY POINTS TO THE
8413: * SPECIAL NODE NDABO WHICH CAUSES AN
8414: * ABORT. THE CURSOR VALUE STORED
8415: * WITH THIS ENTRY IS ALWAYS ZERO.
8416: *
8417: * UNANCHORED MODE THE BOTTOM ENTRY POINTS TO THE
8418: * SPECIAL NODE NDUNA WHICH MOVES THE
8419: * ANCHOR POINT AND RESTARTS THE MATCH
8420: * THE CURSOR SAVED WITH THIS ENTRY
8421: * IS THE NUMBER OF CHARACTERS WHICH
8422: * LIE BEFORE THE INITIAL ANCHOR POINT
8423: * (I.E. THE NUMBER OF ANCHOR MOVES).
8424: * THIS ENTRY IS THREE WORDS LONG AND
8425: * ALSO CONTAINS THE INITIAL PATTERN.
8426: *
8427: * ENTRIES ARE MADE ON THIS HISTORY STACK BY ALTERNATIVE
8428: * NODES AND BY SOME SPECIAL COMPOUD PATTERNS AS DESCRIBED
8429: * LATER ON. THE FOLLOWING GLOBAL LOCATIONS ARE USED DURING
8430: * PATTERN MATCHING.
8431: *
8432: * R$PMS POINTER TO SUBJECT STRING
8433: * PMSSL LENGTH OF SUBJECT STRING
8434: * PMDFL FLAG SET NON-ZERO FOR DOT PATTERNS
8435: * PMHBS BASE PTR FOR CURRENT HISTORY STACK
8436: *
8437: * THE FOLLOWING EXIT POINTS ARE AVAILABLE TO MATCH ROUTINES
8438: *
8439: * SUCCP SUCCESS IN MATCHING CURRENT NODE
8440: * FAILP FAILURE IN MATCHING CURRENT NODE
8441: EJC
8442: *
8443: * COMPOUND PATTERNS
8444: *
8445: * SOME PATTERNS HAVE IMPLICIT ALTERNATIVES AND THEIR
8446: * REPRESENTATION IN THE PATTERN STRUCTURE CONSISTS OF A
8447: * LINKED SET OF NODES AS INDICATED BY THESE DIAGRAMS.
8448: *
8449: * AS BEFORE, THE + REPRESENTS AN ALTERNATIVE NODE AND
8450: * THE DOTTED LINE FROM A + NODE IS THE PARAMETER POINTER
8451: * TO THE ALTERNATIVE PATTERN.
8452: *
8453: * ARB
8454: * ---
8455: *
8456: * +---+ THIS NODE (P$ARB) MATCHES NULL
8457: * I B I----- AND STACKS CURSOR, SUCCESSOR PTR,
8458: * +---+ CURSOR (COPY) AND A PTR TO NDARC.
8459: *
8460: *
8461: *
8462: *
8463: * BAL
8464: * ---
8465: *
8466: * +---+ THE P$BAL NODE SCANS A BALANCED
8467: * I B I----- STRING AND THEN STACKS A POINTER
8468: * +---+ TO ITSELF ON THE HISTORY STACK.
8469: EJC
8470: *
8471: * COMPOUND PATTERN STRUCTURES (CONTINUED)
8472: *
8473: *
8474: * ARBNO
8475: * -----
8476: *
8477: * +---+ THIS ALTERNATIVE NODE MATCHES NULL
8478: * +----I + I----- THE FIRST TIME AND STACKS A POINTER
8479: * I +---+ TO THE ARGUMENT PATTERN X.
8480: * I .
8481: * I .
8482: * I +---+ NODE (P$ABA) TO STACK CURSOR
8483: * I I A I AND HISTORY STACK BASE PTR.
8484: * I +---+
8485: * I I
8486: * I I
8487: * I +---+ THIS IS THE ARGUMENT PATTERN. AS
8488: * I I X I INDICATED, THE SUCCESSOR OF THE
8489: * I +---+ PATTERN IS THE P$ABC NODE
8490: * I I
8491: * I I
8492: * I +---+ THIS NODE (P$ABC) POPS PMHBS,
8493: * +----I C I STACKS OLD PMHBS AND PTR TO NDABD
8494: * +---+ (UNLESS OPTIMISATION HAS OCCURRED)
8495: *
8496: * STRUCTURE AND EXECUTION OF THIS PATTERN RESEMBLE THOSE OF
8497: * RECURSIVE PATTERN MATCHING AND IMMEDIATE ASSIGNMENT.
8498: * THE ALTERNATIVE NODE AT THE HEAD OF THE STRUCTURE MATCHES
8499: * NULL INITIALLY BUT ON SUBSEQUENT FAILURE ENSURES ATTEMPT
8500: * TO MATCH THE ARGUMENT. BEFORE THE ARGUMENT IS MATCHED
8501: * P$ABA STACKS THE CURSOR,PMHBS AND A PTR TO P$ABB. IF
8502: * THE ARGUMENT CANT BE MATCHED , P$ABB REMOVES THIS SPECIAL
8503: * STACK ENTRY AND FAILS.
8504: * IF ARGUMENT IS MATCHED , P$ABC RESTORES THE OUTER PMHBS
8505: * VALUE (SAVED BY P$ABA) . THEN IF THE ARGUMENT HAS LEFT
8506: * ALTERNATIVES ON STACK IT STACKS THE INNER VALUE OF PMHBS
8507: * AND A PTR TO NDABD. IF ARGUMENT LEFT NOTHING ON THE STACK
8508: * IT OPTIMISES BY REMOVING ITEMS STACKED BY P$ABA. FINALLY
8509: * A CHECK IS MADE THAT ARGUMENT MATCHED MORE THAN THE NULL
8510: * STRING (CHECK IS INTENDED TO PREVENT USELESS LOOPING).
8511: * IF SO THE SUCCESSOR IS AGAIN THE ALTERNATIVE NODE AT THE
8512: * HEAD OF THE STRUCTURE , ENSURING A POSSIBLE EXTRA ATTEMPT
8513: * TO MATCH THE ARG IF NECESSARY. IF NOT , THE SUCCESSOR TO
8514: * ALTERNATIVE IS TAKEN SO AS TO TERMINATE THE LOOP. P$ABD
8515: * RESTORES INNER PMHBS PTR AND FAILS , THUS TRYING TO MATCH
8516: * ALTERNATIVES LEFT BY THE ARBNO ARGUMENT.
8517: EJC
8518: *
8519: * COMPOUND PATTERN STRUCTURES (CONTINUED)
8520: *
8521: * BREAKX
8522: * ------
8523: *
8524: * +---+ THIS NODE IS A BREAK NODE FOR
8525: * +----I B I THE ARGUMENT TO BREAKX, IDENTICAL
8526: * I +---+ TO AN ORDINARY BREAK NODE.
8527: * I I
8528: * I I
8529: * I +---+ THIS ALTERNATIVE NODE STACKS A
8530: * I I + I----- POINTER TO THE BREAKX NODE TO
8531: * I +---+ ALLOW FOR SUBSEQUENT FAILURE
8532: * I .
8533: * I .
8534: * I +---+ THIS IS THE BREAKX NODE ITSELF. IT
8535: * +----I X I MATCHES ONE CHARACTER AND THEN
8536: * +---+ PROCEEDS BACK TO THE BREAK NODE.
8537: *
8538: *
8539: *
8540: *
8541: * FENCE
8542: * -----
8543: *
8544: * +---+ THE FENCE NODE MATCHES NULL AND
8545: * I F I----- STACKS A POINTER TO NODE NDABO TO
8546: * +---+ ABORT ON A SUBSEQUENT REMATCH
8547: *
8548: *
8549: *
8550: *
8551: * SUCCEED
8552: * -------
8553: *
8554: * +---+ THE NODE FOR SUCCEED MATCHES NULL
8555: * I S I----- AND STACKS A POINTER TO ITSELF
8556: * +---+ TO REPEAT THE MATCH ON A FAILURE.
8557: EJC
8558: *
8559: * COMPOUND PATTERNS (CONTINUED)
8560: *
8561: * BINARY DOT (PATTERN ASSIGNMENT)
8562: * -------------------------------
8563: *
8564: * +---+ THIS NODE (P$PAA) SAVES THE CURRENT
8565: * I A I CURSOR AND A POINTER TO THE
8566: * +---+ SPECIAL NODE NDPAB ON THE STACK.
8567: * I
8568: * I
8569: * +---+ THIS IS THE STRUCTURE FOR THE
8570: * I X I PATTERN LEFT ARGUMENT OF THE
8571: * +---+ PATTERN ASSIGNMENT CALL.
8572: * I
8573: * I
8574: * +---+ THIS NODE (P$PAC) SAVES THE CURSOR,
8575: * I C I----- A PTR TO ITSELF, THE CURSOR (COPY)
8576: * +---+ AND A PTR TO NDPAD ON THE STACK.
8577: *
8578: *
8579: * THE FUNCTION OF THE MATCH ROUTINE FOR NDPAB (P$PAB)
8580: * IS SIMPLY TO UNSTACK ITSELF AND FAIL BACK ONTO THE STACK.
8581: *
8582: * THE MATCH ROUTINE FOR P$PAC ALSO SETS THE GLOBAL PATTERN
8583: * FLAG PMDFL NON-ZERO TO INDICATE THAT PATTERN ASSIGNMENTS
8584: * MAY HAVE OCCURED IN THE PATTERN MATCH
8585: *
8586: * IF PMDFL IS SET AT THE END OF THE MATCH (SEE P$NTH), THE
8587: * HISTORY STACK IS SCANNED FOR MATCHING NDPAB-NDPAD PAIRS
8588: * AND THE CORRESPONDING PATTERN ASSIGNMENTS ARE EXECUTED.
8589: *
8590: * THE FUNCTION OF THE MATCH ROUTINE FOR NDPAD (P$PAD)
8591: * IS SIMPLY TO REMOVE ITS ENTRY FROM THE STACK AND FAIL.
8592: * THIS INCLUDES REMOVING THE SPECIAL NODE POINTER STORED
8593: * IN ADDITION TO THE STANDARD TWO ENTRIES ON THE STACK.
8594: EJC
8595: *
8596: * COMPOUNT PATTERN STRUCTURES (CONTINUED)
8597: *
8598: * FENCE (FUNCTION)
8599: * ----------------
8600: *
8601: * +---+ THIS NODE (P$FNA) SAVES THE
8602: * I A I CURRENT HISTORY STACK AND A
8603: * +---+ POINTER TO NDFNB ON THE STACK.
8604: * I
8605: * I
8606: * +---+ THIS IS THE PATTERN STRUCTURE
8607: * I X I GIVEN AS THE ARGUMENT TO THE
8608: * +---+ FENCE FUNCTION.
8609: * I
8610: * I
8611: * +---+ THIS NODE P$FNC RESTORES THE OUTER
8612: * I C I HISTORY STACK PTR SAVED IN P$FNA,
8613: * +---+ AND STACKS THE INNER STACK BASE
8614: * PTR AND A POINTER TO NDFND ON THE
8615: * STACK.
8616: *
8617: * NDFNB (F$FNB) SIMPLY IS THE FAILURE EXIT FOR PATTERN
8618: * ARGUMENT FAILURE, AND IT POPS ITSELF AND FAILS ONTO THE
8619: * STACK.
8620: *
8621: * THE MATCH ROUTINE P$FNC ALLOWS FOR AN OPTIMIZATION WHEN
8622: * THE FENCE PATTERN LEAVES NO ALTERNATIVES. IN THIS CASE,
8623: * THE NDFNB ENTRY IS POPPED, AND THE MATCH CONTINUES.
8624: *
8625: * NDFND (P$FND) IS ENTERED WHEN THE PATTERN FAILS AFTER
8626: * GOING THROUGH A NON-OPTIMIZED P$FNC, AND IT POPS THE
8627: * STACK BACK PAST THE INNTER STACK BASE CREATED BY P$FNA
8628: EJC
8629: *
8630: * COMPOUND PATTERNS (CONTINUED)
8631: *
8632: * EXPRESSION PATTERNS (RECURSIVE PATTERN MATCHES)
8633: * -----------------------------------------------
8634: *
8635: * INITIAL ENTRY FOR A PATTERN NODE IS TO THE ROUTINE P$EXA.
8636: * IF THE EVALUATED RESULT OF THE EXPRESSION IS ITSELF A
8637: * PATTERN, THEN THE FOLLOWING STEPS ARE TAKEN TO ARRANGE
8638: * FOR PROPER RECURSIVE PROCESSING.
8639: *
8640: * 1) A POINTER TO THE CURRENT NODE (THE P$EXA NODE) IS
8641: * STORED ON THE HISTORY STACK WITH A DUMMY CURSOR.
8642: *
8643: * 2) A SPECIAL HISTORY STACK ENTRY IS MADE IN WHICH THE
8644: * NODE POINTER POINTS TO NDEXB, AND THE CURSOR VALUE
8645: * IS THE SAVED VALUE OF PMHBS ON ENTRY TO THIS NODE.
8646: * THE MATCH ROUTINE FOR NDEXB (P$EXB) RESTORES PMHBS
8647: * FROM THIS CURSOR ENTRY, POPS OFF THE P$EXA NODE
8648: * POINTER AND FAILS.
8649: *
8650: * 3) THE RESULTING HISTORY STACK POINTER IS SAVED IN
8651: * PMHBS TO ESTABLISH A NEW LEVEL OF HISTORY STACK.
8652: *
8653: * AFTER MATCHING A PATTERN, THE END OF MATCH ROUTINE GETS
8654: * CONTROL (P$NTH). THIS ROUTINE PROCEEDS AS FOLLOWS.
8655: *
8656: * 1) LOAD THE CURRENT VALUE OF PMHBS AND RECOGNIZE THE
8657: * OUTER LEVEL CASE BY THE FACT THAT THE ASSOCIATED
8658: * CURSOR IN THIS CASE IS THE PATTERN MATCH TYPE CODE
8659: * WHICH IS LESS THAN 3. TERMINATE THE MATCH IN THIS
8660: * CASE AND CONTINUE EXECUTION OF THE PROGRAM.
8661: *
8662: * 2) OTHERWISE MAKE A SPECIAL HISTORY STACK ENTRY IN
8663: * WHICH THE NODE POINTER POINTS TO THE SPECIAL NODE
8664: * NDEXC AND THE CURSOR IS THE CURRENT VALUE OF PMHBS.
8665: * THE MATCH ROUTINE FOR NDEXC (P$EXC) RESETS PMHBS TO
8666: * THIS (INNER) VALUE AND AND THEN FAILS.
8667: *
8668: * 3) USING THE HISTORY STACK ENTRY MADE ON STARTING THE
8669: * EXPRESSION (ACCESSIBLE WITH THE CURRENT VALUE OF
8670: * PMHBS), RESTORE THE P$EXA NODE POINTER AND THE OLD
8671: * PMHBS SETTING. TAKE THE SUCCESSOR AND CONTINUE.
8672: *
8673: * AN OPTIMIZATION IS POSSIBLE IF THE EXPRESSION PATTERN
8674: * MAKES NO ENTRIES ON THE HISTORY STACK. IN THIS CASE,
8675: * INSTEAD OF BUILDING THE P$EXC NODE IN STEP 2, IT IS MORE
8676: * EFFICIENT TO SIMPLY POP OFF THE P$EXB ENTRY AND ITS
8677: * ASSOCIATED NODE POINTER. THE EFFECT IS THE SAME.
8678: EJC
8679: *
8680: * COMPOUND PATTERNS (CONTINUED)
8681: *
8682: * BINARY DOLLAR (IMMEDIATE ASSIGNMENT)
8683: * ------------------------------------
8684: *
8685: * +---+ THIS NODE (P$IMA) STACKS THE CURSOR
8686: * I A I PMHBS AND A PTR TO NDIMB AND RESETS
8687: * +---+ THE STACK PTR PMHBS.
8688: * I
8689: * I
8690: * +---+ THIS IS THE LEFT STRUCTURE FOR THE
8691: * I X I PATTERN LEFT ARGUMENT OF THE
8692: * +---+ IMMEDIATE ASSIGNMENT CALL.
8693: * I
8694: * I
8695: * +---+ THIS NODE (P$IMC) PERFORMS THE
8696: * I C I----- ASSIGNMENT, POPS PMHBS AND STACKS
8697: * +---+ THE OLD PMHBS AND A PTR TO NDIMD.
8698: *
8699: *
8700: * THE STRUCTURE AND EXECUTION OF THIS PATTERN ARE SIMILAR
8701: * TO THOSE OF THE RECURSIVE EXPRESSION PATTERN MATCHING.
8702: *
8703: * THE MATCH ROUTINE FOR NDIMB (P$IMB) RESTORES THE OUTER
8704: * LEVEL VALUE OF PMHBS, UNSTACKS THE SAVED CURSOR AND FAILS
8705: *
8706: * THE MATCH ROUTINE P$IMC USES THE CURRENT VALUE OF PMHBS
8707: * TO LOCATE THE P$IMB ENTRY. THIS ENTRY IS USED TO MAKE
8708: * THE ASSIGNMENT AND RESTORE THE OUTER LEVEL VALUE OF
8709: * PMHBS. FINALLY, THE INNER LEVEL VALUE OF PMHBS AND A
8710: * POINTER TO THE SPECIAL NODE NDIMD ARE STACKED.
8711: *
8712: * THE MATCH ROUTINE FOR NDIMD (P$IMD) RESTORES THE INNER
8713: * LEVEL VALUE OF PMHBS AND FAILS BACK INTO THE STACK.
8714: *
8715: * AN OPTIMIZATION OCCURS IF THE INNER PATTERN MAKES NO
8716: * ENTRIES ON THE HISTORY STACK. IN THIS CASE, P$IMC POPS
8717: * THE P$IMB ENTRY INSTEAD OF MAKING A P$IMD ENTRY.
8718: EJC
8719: *
8720: * ARBNO
8721: *
8722: * SEE COMPOUND PATTERNS SECTION FOR STUCTURE AND
8723: * ALGORITHM FOR MATCHING THIS NODE TYPE.
8724: *
8725: * NO PARAMETERS
8726: *
8727: P$ABA ENT BL$P0 P0BLK
8728: MOV WB,-(XS) STACK CURSOR
8729: MOV XR,-(XS) STACK DUMMY NODE PTR
8730: MOV PMHBS,-(XS) STACK OLD STACK BASE PTR
8731: MOV =NDABB,-(XS) STACK PTR TO NODE NDABB
8732: MOV XS,PMHBS STORE NEW STACK BASE PTR
8733: BRN SUCCP SUCCEED
8734: EJC
8735: *
8736: * ARBNO (REMOVE P$ABA SPECIAL STACK ENTRY)
8737: *
8738: * NO PARAMETERS (DUMMY PATTERN)
8739: *
8740: P$ABB ENT ENTRY POINT
8741: MOV WB,PMHBS RESTORE HISTORY STACK BASE PTR
8742: BRN FLPOP FAIL AND POP DUMMY NODE PTR
8743: EJC
8744: *
8745: * ARBNO (CHECK IF ARG MATCHED NULL STRING)
8746: *
8747: * NO PARAMETERS (DUMMY PATTERN)
8748: *
8749: P$ABC ENT BL$P0 P0BLK
8750: MOV PMHBS,XT KEEP P$ABB STACK BASE
8751: MOV 3(XT),WA LOAD INITIAL CURSOR
8752: MOV 1(XT),PMHBS RESTORE OUTER STACK BASE PTR
8753: BEQ XT,XS,PABC1 JUMP IF NO HISTORY STACK ENTRIES
8754: MOV XT,-(XS) ELSE SAVE INNER PMHBS ENTRY
8755: MOV =NDABD,-(XS) STACK PTR TO SPECIAL NODE NDABD
8756: BRN PABC2 MERGE
8757: *
8758: * OPTIMISE CASE OF NO EXTRA ENTRIES ON STACK FROM ARBNO ARG
8759: *
8760: PABC1 ADD *NUM04,XS REMOVE NDABB ENTRY AND CURSOR
8761: *
8762: * MERGE TO CHECK FOR MATCHING OF NULL STRING
8763: *
8764: PABC2 BNE WA,WB,SUCCP ALLOW FURTHER ATTEMPT IF NON-NULL
8765: MOV PTHEN(XR),XR BYPASS ALTERNATIVE NODE SO AS TO ..
8766: BRN SUCCP ... REFUSE FURTHER MATCH ATTEMPTS
8767: EJC
8768: *
8769: * ARBNO (TRY FOR ALTERNATIVES IN ARBNO ARGUMENT)
8770: *
8771: * NO PARAMETERS (DUMMY PATTERN)
8772: *
8773: P$ABD ENT ENTRY POINT
8774: MOV WB,PMHBS RESTORE INNER STACK BASE PTR
8775: BRN FAILP AND FAIL
8776: EJC
8777: *
8778: * ABORT
8779: *
8780: * NO PARAMETERS
8781: *
8782: P$ABO ENT BL$P0 P0BLK
8783: BRN EXFAL SIGNAL STATEMENT FAILURE
8784: EJC
8785: *
8786: * ALTERNATION
8787: *
8788: * PARM1 ALTERNATIVE NODE
8789: *
8790: P$ALT ENT BL$P1 P1BLK
8791: MOV WB,-(XS) STACK CURSOR
8792: MOV PARM1(XR),-(XS) STACK POINTER TO ALTERNATIVE
8793: CHK CHECK FOR STACK OVERFLOW
8794: BRN SUCCP IF ALL OK, THEN SUCCEED
8795: EJC
8796: *
8797: * ANY (ONE CHARACTER ARGUMENT) (1-CHAR STRING ALSO)
8798: *
8799: * PARM1 CHARACTER ARGUMENT
8800: *
8801: P$ANS ENT BL$P1 P1BLK
8802: BEQ WB,PMSSL,FAILP FAIL IF NO CHARS LEFT
8803: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
8804: PLC XL,WB POINT TO CURRENT CHARACTER
8805: LCH WA,(XL) LOAD CURRENT CHARACTER
8806: BNE WA,PARM1(XR),FAILP FAIL IF NO MATCH
8807: ICV WB ELSE BUMP CURSOR
8808: BRN SUCCP AND SUCCEED
8809: EJC
8810: *
8811: * ANY (MULTI-CHARACTER ARGUMENT CASE)
8812: *
8813: * PARM1 POINTER TO CTBLK
8814: * PARM2 BIT MASK TO SELECT BIT IN CTBLK
8815: *
8816: P$ANY ENT BL$P2 P2BLK
8817: *
8818: * EXPRESSION ARGUMENT CASE MERGES HERE
8819: *
8820: PANY1 BEQ WB,PMSSL,FAILP FAIL IF NO CHARACTERS LEFT
8821: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
8822: PLC XL,WB GET CHAR PTR TO CURRENT CHARACTER
8823: LCH WA,(XL) LOAD CURRENT CHARACTER
8824: MOV PARM1(XR),XL POINT TO CTBLK
8825: WTB WA CHANGE TO BYTE OFFSET
8826: ADD WA,XL POINT TO ENTRY IN CTBLK
8827: MOV CTCHS(XL),WA LOAD WORD FROM CTBLK
8828: ANB PARM2(XR),WA AND WITH SELECTED BIT
8829: ZRB WA,FAILP FAIL IF NO MATCH
8830: ICV WB ELSE BUMP CURSOR
8831: BRN SUCCP AND SUCCEED
8832: EJC
8833: *
8834: * ANY (EXPRESSION ARGUMENT)
8835: *
8836: * PARM1 EXPRESSION POINTER
8837: *
8838: P$AYD ENT BL$P1 P1BLK
8839: JSR EVALS EVALUATE STRING ARGUMENT
8840: ERR 043,ANY EVALUATED ARGUMENT IS NOT STRING
8841: PPM FAILP FAIL IF EVALUATION FAILURE
8842: PPM PANY1 MERGE MULTI-CHAR CASE IF OK
8843: EJC
8844: *
8845: * P$ARB INITIAL ARB MATCH
8846: *
8847: * NO PARAMETERS
8848: *
8849: * THE P$ARB NODE IS PART OF A COMPOUND PATTERN STRUCTURE
8850: * FOR AN ARB PATTERN (SEE DESCRIPTION OF COMPOUND PATTERNS)
8851: *
8852: P$ARB ENT BL$P0 P0BLK
8853: MOV PTHEN(XR),XR LOAD SUCCESSOR POINTER
8854: MOV WB,-(XS) STACK DUMMY CURSOR
8855: MOV XR,-(XS) STACK SUCCESSOR POINTER
8856: MOV WB,-(XS) STACK CURSOR
8857: MOV =NDARC,-(XS) STACK PTR TO SPECIAL NODE NDARC
8858: BRI (XR) EXECUTE NEXT NODE MATCHING NULL
8859: EJC
8860: *
8861: * P$ARC EXTEND ARB MATCH
8862: *
8863: * NO PARAMETERS (DUMMY PATTERN)
8864: *
8865: P$ARC ENT ENTRY POINT
8866: BEQ WB,PMSSL,FLPOP FAIL AND POP STACK TO SUCCESSOR
8867: ICV WB ELSE BUMP CURSOR
8868: MOV WB,-(XS) STACK UPDATED CURSOR
8869: MOV XR,-(XS) RESTACK POINTER TO NDARC NODE
8870: MOV 2(XS),XR LOAD SUCCESSOR POINTER
8871: BRI (XR) OFF TO REEXECUTE SUCCESSOR NODE
8872: EJC
8873: *
8874: * BAL
8875: *
8876: * NO PARAMETERS
8877: *
8878: * THE P$BAL NODE IS PART OF THE COMPOUND STRUCTURE BUILT
8879: * FOR BAL (SEE SECTION ON COMPOUND PATTERNS).
8880: *
8881: P$BAL ENT BL$P0 P0BLK
8882: ZER WC ZERO PARENTHESES LEVEL COUNTER
8883: MOV R$PMS,XL POINT TO SUBJECT STRING
8884: PLC XL,WB POINT TO CURRENT CHARACTER
8885: BRN PBAL2 JUMP INTO SCAN LOOP
8886: *
8887: * LOOP TO SCAN OUT CHARACTERS
8888: *
8889: PBAL1 LCH WA,(XL)+ LOAD NEXT CHARACTER, BUMP POINTER
8890: ICV WB PUSH CURSOR FOR CHARACTER
8891: BEQ WA,=CH$PP,PBAL3 JUMP IF LEFT PAREN
8892: BEQ WA,=CH$RP,PBAL4 JUMP IF RIGHT PAREN
8893: BZE WC,PBAL5 ELSE SUCCEED IF AT OUTER LEVEL
8894: *
8895: * HERE AFTER PROCESSING ONE CHARACTER
8896: *
8897: PBAL2 BNE WB,PMSSL,PBAL1 LOOP BACK UNLESS END OF STRING
8898: BRN FAILP IN WHICH CASE, FAIL
8899: *
8900: * HERE ON LEFT PAREN
8901: *
8902: PBAL3 ICV WC BUMP PAREN LEVEL
8903: BRN PBAL2 LOOP BACK TO CHECK END OF STRING
8904: *
8905: * HERE FOR RIGHT PAREN
8906: *
8907: PBAL4 BZE WC,FAILP FAIL IF NO MATCHING LEFT PAREN
8908: DCV WC ELSE DECREMENT LEVEL COUNTER
8909: BNZ WC,PBAL2 LOOP BACK IF NOT AT OUTER LEVEL
8910: *
8911: * HERE AFTER SUCCESSFULLY SCANNING A BALANCED STRING
8912: *
8913: PBAL5 MOV WB,-(XS) STACK CURSOR
8914: MOV XR,-(XS) STACK PTR TO BAL NODE FOR EXTEND
8915: BRN SUCCP AND SUCCEED
8916: EJC
8917: *
8918: * BREAK (EXPRESSION ARGUMENT)
8919: *
8920: * PARM1 EXPRESSION POINTER
8921: *
8922: P$BKD ENT BL$P1 P1BLK
8923: JSR EVALS EVALUATE STRING EXPRESSION
8924: ERR 044,BREAK EVALUATED ARGUMENT IS NOT STRING
8925: PPM FAILP FAIL IF EVALUATION FAILS
8926: PPM PBRK1 MERGE WITH MULTI-CHAR CASE IF OK
8927: EJC
8928: *
8929: * BREAK (ONE CHARACTER ARGUMENT)
8930: *
8931: * PARM1 CHARACTER ARGUMENT
8932: *
8933: P$BKS ENT BL$P1 P1BLK
8934: MOV PMSSL,WC GET SUBJECT STRING LENGTH
8935: SUB WB,WC GET NUMBER OF CHARACTERS LEFT
8936: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT
8937: LCT WC,WC SET COUNTER FOR CHARS LEFT
8938: MOV R$PMS,XL POINT TO SUBJECT STRING
8939: PLC XL,WB POINT TO CURRENT CHARACTER
8940: *
8941: * LOOP TO SCAN TILL BREAK CHARACTER FOUND
8942: *
8943: PBKS1 LCH WA,(XL)+ LOAD NEXT CHAR, BUMP POINTER
8944: BEQ WA,PARM1(XR),SUCCP SUCCEED IF BREAK CHARACTER FOUND
8945: ICV WB ELSE PUSH CURSOR
8946: BCT WC,PBKS1 LOOP BACK IF MORE TO GO
8947: BRN FAILP FAIL IF END OF STRING, NO BREAK CHR
8948: EJC
8949: *
8950: * BREAK (MULTI-CHARACTER ARGUMENT)
8951: *
8952: * PARM1 POINTER TO CTBLK
8953: * PARM2 BIT MASK TO SELECT BIT COLUMN
8954: *
8955: P$BRK ENT BL$P2 P2BLK
8956: *
8957: * EXPRESSION ARGUMENT MERGES HERE
8958: *
8959: PBRK1 MOV PMSSL,WC LOAD SUBJECT STRING LENGTH
8960: SUB WB,WC GET NUMBER OF CHARACTERS LEFT
8961: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT
8962: LCT WC,WC SET COUNTER FOR CHARACTERS LEFT
8963: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
8964: PLC XL,WB POINT TO CURRENT CHARACTER
8965: MOV XR,PSAVE SAVE NODE POINTER
8966: *
8967: * LOOP TO SEARCH FOR BREAK CHARACTER
8968: *
8969: PBRK2 LCH WA,(XL)+ LOAD NEXT CHAR, BUMP POINTER
8970: MOV PARM1(XR),XR LOAD POINTER TO CTBLK
8971: WTB WA CONVERT TO BYTE OFFSET
8972: ADD WA,XR POINT TO CTBLK ENTRY
8973: MOV CTCHS(XR),WA LOAD CTBLK WORD
8974: MOV PSAVE,XR RESTORE NODE POINTER
8975: ANB PARM2(XR),WA AND WITH SELECTED BIT
8976: NZB WA,SUCCP SUCCEED IF BREAK CHARACTER FOUND
8977: ICV WB ELSE PUSH CURSOR
8978: BCT WC,PBRK2 LOOP BACK UNLESS END OF STRING
8979: BRN FAILP FAIL IF END OF STRING, NO BREAK CHR
8980: EJC
8981: *
8982: * BREAKX (EXTENSION)
8983: *
8984: * THIS IS THE ENTRY WHICH CAUSES AN EXTENSION OF A BREAKX
8985: * MATCH WHEN FAILURE OCCURS. SEE SECTION ON COMPOUND
8986: * PATTERNS FOR FULL DETAILS OF BREAKX MATCHING.
8987: *
8988: * NO PARAMETERS
8989: *
8990: P$BKX ENT BL$P0 P0BLK
8991: ICV WB STEP CURSOR PAST PREVIOUS BREAK CHR
8992: BRN SUCCP SUCCEED TO REMATCH BREAK
8993: EJC
8994: *
8995: * BREAKX (EXPRESSION ARGUMENT)
8996: *
8997: * SEE SECTION ON COMPOUND PATTERNS FOR FULL STRUCTURE OF
8998: * BREAKX PATTERN. THE ACTUAL CHARACTER MATCHING USES A
8999: * BREAK NODE. HOWEVER, THE ENTRY FOR THE EXPRESSION
9000: * ARGUMENT CASE IS SEPARATED TO GET PROPER ERROR MESSAGES.
9001: *
9002: * PARM1 EXPRESSION POINTER
9003: *
9004: P$BXD ENT BL$P1 P1BLK
9005: JSR EVALS EVALUATE STRING ARGUMENT
9006: ERR 045,BREAKX EVALUATED ARGUMENT IS NOT STRING
9007: PPM FAILP FAIL IF EVALUATION FAILS
9008: PPM PBRK1 MERGE WITH BREAK IF ALL OK
9009: EJC
9010: *
9011: * CURSOR ASSIGNMENT
9012: *
9013: * PARM1 NAME BASE
9014: * PARM2 NAME OFFSET
9015: *
9016: P$CAS ENT BL$P2 P2BLK
9017: MOV XR,-(XS) SAVE NODE POINTER
9018: MOV WB,-(XS) SAVE CURSOR
9019: MOV PARM1(XR),XL LOAD NAME BASE
9020: MTI WB LOAD CURSOR AS INTEGER
9021: MOV PARM2(XR),WB LOAD NAME OFFSET
9022: JSR ICBLD GET ICBLK FOR CURSOR VALUE
9023: MOV WB,WA MOVE NAME OFFSET
9024: MOV XR,WB MOVE VALUE TO ASSIGN
9025: JSR ASINP PERFORM ASSIGNMENT
9026: PPM FLPOP FAIL ON ASSIGNMENT FAILURE
9027: MOV (XS)+,WB ELSE RESTORE CURSOR
9028: MOV (XS)+,XR RESTORE NODE POINTER
9029: BRN SUCCP AND SUCCEED MATCHING NULL
9030: EJC
9031: *
9032: * EXPRESSION NODE (P$EXA, INITIAL ENTRY)
9033: *
9034: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9035: * ALGORITHMS FOR HANDLING EXPRESSION NODES.
9036: *
9037: * PARM1 EXPRESSION POINTER
9038: *
9039: P$EXA ENT BL$P1 P1BLK
9040: JSR EVALP EVALUATE EXPRESSION
9041: PPM FAILP FAIL IF EVALUATION FAILS
9042: BLO WA,=P$AAA,PEXA1 JUMP IF RESULT IS NOT A PATTERN
9043: *
9044: * HERE IF RESULT OF EXPRESSION IS A PATTERN
9045: *
9046: MOV WB,-(XS) STACK DUMMY CURSOR
9047: MOV XR,-(XS) STACK PTR TO P$EXA NODE
9048: MOV PMHBS,-(XS) STACK HISTORY STACK BASE PTR
9049: MOV =NDEXB,-(XS) STACK PTR TO SPECIAL NODE NDEXB
9050: MOV XS,PMHBS STORE NEW STACK BASE POINTER
9051: MOV XL,XR COPY NODE POINTER
9052: BRI (XR) MATCH FIRST NODE IN EXPRESSION PAT
9053: *
9054: * HERE IF RESULT OF EXPRESSION IS NOT A PATTERN
9055: *
9056: PEXA1 BEQ WA,=B$SCL,PEXA2 JUMP IF IT IS ALREADY A STRING
9057: MOV XL,-(XS) ELSE STACK RESULT
9058: MOV XR,XL SAVE NODE POINTER
9059: JSR GTSTG CONVERT RESULT TO STRING
9060: ERR 046,EXPRESSION DOES NOT EVALUATE TO PATTERN
9061: MOV XR,WC COPY STRING POINTER
9062: MOV XL,XR RESTORE NODE POINTER
9063: MOV WC,XL COPY STRING POINTER AGAIN
9064: *
9065: * MERGE HERE WITH STRING POINTER IN XL
9066: *
9067: PEXA2 BZE SCLEN(XL),SUCCP JUST SUCCEED IF NULL STRING
9068: BRN PSTR1 ELSE MERGE WITH STRING CIRCUIT
9069: EJC
9070: *
9071: * EXPRESSION NODE (P$EXB, REMOVE NDEXB ENTRY)
9072: *
9073: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9074: * ALGORITHMS FOR HANDLING EXPRESSION NODES.
9075: *
9076: * NO PARAMETERS (DUMMY PATTERN)
9077: *
9078: P$EXB ENT ENTRY POINT
9079: MOV WB,PMHBS RESTORE OUTER LEVEL STACK POINTER
9080: BRN FLPOP FAIL AND POP P$EXA NODE PTR
9081: EJC
9082: *
9083: * EXPRESSION NODE (P$EXC, REMOVE NDEXC ENTRY)
9084: *
9085: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9086: * ALGORITHMS FOR HANDLING EXPRESSION NODES.
9087: *
9088: * NO PARAMETERS (DUMMY PATTERN)
9089: *
9090: P$EXC ENT ENTRY POINT
9091: MOV WB,PMHBS RESTORE INNER STACK BASE POINTER
9092: BRN FAILP AND FAIL INTO EXPR PATTERN ALTERNVS
9093: EJC
9094: *
9095: * FAIL
9096: *
9097: * NO PARAMETERS
9098: *
9099: P$FAL ENT BL$P0 P0BLK
9100: BRN FAILP JUST SIGNAL FAILURE
9101: EJC
9102: *
9103: * FENCE
9104: *
9105: * SEE COMPOUND PATTERNS SECTION FOR THE STRUCTURE AND
9106: * ALGORITHM FOR MATCHING THIS NODE TYPE.
9107: *
9108: * NO PARAMETERS
9109: *
9110: P$FEN ENT BL$P0 P0BLK
9111: MOV WB,-(XS) STACK DUMMY CURSOR
9112: MOV =NDABO,-(XS) STACK PTR TO ABORT NODE
9113: BRN SUCCP AND SUCCEED MATCHING NULL
9114: EJC
9115: *
9116: * FENCE (FUNCTION)
9117: *
9118: * SEE COMPOUND PATTERNS COMMENTS AT START OF THIS SECTION
9119: * FOR DETAILS OF SCHEME
9120: *
9121: * NO PARAMETERS
9122: *
9123: P$FNA ENT BL$P0 P0BLK
9124: MOV PMHBS,-(XS) STACK CURRENT HISTORY STACK BASE
9125: MOV =NDFNB,-(XS) STACK INDIR PTR TO P$FNB (FAILURE)
9126: MOV XS,PMHBS BEGIN NEW HISTORY STACK
9127: BRN SUCCP SUCCEED
9128: EJC
9129: *
9130: * FENCE (FUNCTION) (RESET HISTORY STACK AND FAIL)
9131: *
9132: * NO PARAMETERS (DUMMY PATTERN)
9133: *
9134: P$FNB ENT BL$P0 P0BLK
9135: MOV WB,PMHBS RESTORE OUTER PMHBS STACK BASE
9136: BRN FAILP ...AND FAIL
9137: EJC
9138: *
9139: * FENCE (FUNCTION) (MAKE FENCE TRAP ENTRY ON STACK)
9140: *
9141: * NO PARAMETERS (DUMMY PATTERN)
9142: *
9143: P$FNC ENT BL$P0 P0BLK
9144: MOV PMHBS,XT GET INNER STACK BASE PTR
9145: MOV NUM01(XT),PMHBS RESTORE OUTER STACK BASE
9146: BEQ XT,XS,PFNC1 OPTIMIZE IF NO ALTERNATIVES
9147: MOV XT,-(XS) ELSE STACK INNER STACK BASE
9148: MOV =NDFND,-(XS) STACK PTR TO NDFND
9149: BRN SUCCP SUCCEED
9150: *
9151: * HERE WHEN FENCE FUNCTION LEFT NOTHING ON THE STACK
9152: *
9153: PFNC1 ADD *NUM02,XS POP OFF P$FNB ENTRY
9154: BRN SUCCP SUCCEED
9155: EJC
9156: *
9157: * FENCE (FUNCTION) (SKIP PAST ALTERNATIVES ON FAILURE)
9158: *
9159: * NO PARAMETERS (DUMMY PATTERN)
9160: *
9161: P$FND ENT BL$P0 P0BLK
9162: MOV WB,XS POP STACK TO FENCE() HISTORY BASE
9163: BRN FLPOP POP BASE ENTRY AND FAIL
9164: EJC
9165: *
9166: * IMMEDIATE ASSIGNMENT (INITIAL ENTRY, SAVE CURRENT CURSOR)
9167: *
9168: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
9169: * STRUCTURE AND ALGORITHM FOR MATCHING THIS NODE TYPE.
9170: *
9171: * NO PARAMETERS
9172: *
9173: P$IMA ENT BL$P0 P0BLK
9174: MOV WB,-(XS) STACK CURSOR
9175: MOV XR,-(XS) STACK DUMMY NODE POINTER
9176: MOV PMHBS,-(XS) STACK OLD STACK BASE POINTER
9177: MOV =NDIMB,-(XS) STACK PTR TO SPECIAL NODE NDIMB
9178: MOV XS,PMHBS STORE NEW STACK BASE POINTER
9179: BRN SUCCP AND SUCCEED
9180: EJC
9181: *
9182: * IMMEDIATE ASSIGNMENT (REMOVE CURSOR MARK ENTRY)
9183: *
9184: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
9185: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE.
9186: *
9187: * NO PARAMETERS (DUMMY PATTERN)
9188: *
9189: P$IMB ENT ENTRY POINT
9190: MOV WB,PMHBS RESTORE HISTORY STACK BASE PTR
9191: BRN FLPOP FAIL AND POP DUMMY NODE PTR
9192: EJC
9193: *
9194: * IMMEDIATE ASSIGNMENT (PERFORM ACTUAL ASSIGNMENT)
9195: *
9196: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
9197: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE.
9198: *
9199: * PARM1 NAME BASE OF VARIABLE
9200: * PARM2 NAME OFFSET OF VARIABLE
9201: *
9202: P$IMC ENT BL$P2 P2BLK
9203: MOV PMHBS,XT LOAD POINTER TO P$IMB ENTRY
9204: MOV WB,WA COPY FINAL CURSOR
9205: MOV 3(XT),WB LOAD INITIAL CURSOR
9206: MOV 1(XT),PMHBS RESTORE OUTER STACK BASE POINTER
9207: BEQ XT,XS,PIMC1 JUMP IF NO HISTORY STACK ENTRIES
9208: MOV XT,-(XS) ELSE SAVE INNER PMHBS POINTER
9209: MOV =NDIMD,-(XS) AND A PTR TO SPECIAL NODE NDIMD
9210: BRN PIMC2 MERGE
9211: *
9212: * HERE IF NO ENTRIES MADE ON HISTORY STACK
9213: *
9214: PIMC1 ADD *NUM04,XS REMOVE NDIMB ENTRY AND CURSOR
9215: *
9216: * MERGE HERE TO PERFORM ASSIGNMENT
9217: *
9218: PIMC2 MOV WA,-(XS) SAVE CURRENT (FINAL) CURSOR
9219: MOV XR,-(XS) SAVE CURRENT NODE POINTER
9220: MOV R$PMS,XL POINT TO SUBJECT STRING
9221: SUB WB,WA COMPUTE SUBSTRING LENGTH
9222: JSR SBSTR BUILD SUBSTRING
9223: MOV XR,WB MOVE RESULT
9224: MOV (XS),XR RELOAD NODE POINTER
9225: MOV PARM1(XR),XL LOAD NAME BASE
9226: MOV PARM2(XR),WA LOAD NAME OFFSET
9227: JSR ASINP PERFORM ASSIGNMENT
9228: PPM FLPOP FAIL IF ASSIGNMENT FAILS
9229: MOV (XS)+,XR ELSE RESTORE NODE POINTER
9230: MOV (XS)+,WB RESTORE CURSOR
9231: BRN SUCCP AND SUCCEED
9232: EJC
9233: *
9234: * IMMEDIATE ASSIGNMENT (REMOVE NDIMD ENTRY ON FAILURE)
9235: *
9236: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
9237: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE.
9238: *
9239: * NO PARAMETERS (DUMMY PATTERN)
9240: *
9241: P$IMD ENT ENTRY POINT
9242: MOV WB,PMHBS RESTORE INNER STACK BASE POINTER
9243: BRN FAILP AND FAIL
9244: EJC
9245: *
9246: * LEN (INTEGER ARGUMENT)
9247: *
9248: * PARM1 INTEGER ARGUMENT
9249: *
9250: P$LEN ENT BL$P1 P1BLK
9251: *
9252: * EXPRESSION ARGUMENT CASE MERGES HERE
9253: *
9254: PLEN1 ADD PARM1(XR),WB PUSH CURSOR INDICATED AMOUNT
9255: BLE WB,PMSSL,SUCCP SUCCEED IF NOT OFF END
9256: BRN FAILP ELSE FAIL
9257: EJC
9258: *
9259: * LEN (EXPRESSION ARGUMENT)
9260: *
9261: * PARM1 EXPRESSION POINTER
9262: *
9263: P$LND ENT BL$P1 P1BLK
9264: JSR EVALI EVALUATE INTEGER ARGUMENT
9265: ERR 047,LEN EVALUATED ARGUMENT IS NOT INTEGER
9266: ERR 048,LEN EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
9267: PPM FAILP FAIL IF EVALUATION FAILS
9268: PPM PLEN1 MERGE WITH NORMAL CIRCUIT IF OK
9269: EJC
9270: *
9271: * NOTANY (EXPRESSION ARGUMENT)
9272: *
9273: * PARM1 EXPRESSION POINTER
9274: *
9275: P$NAD ENT BL$P1 P1BLK
9276: JSR EVALS EVALUATE STRING ARGUMENT
9277: ERR 049,NOTANY EVALUATED ARGUMENT IS NOT STRING
9278: PPM FAILP FAIL IF EVALUATION FAILS
9279: PPM PNAY1 MERGE WITH MULTI-CHAR CASE IF OK
9280: EJC
9281: *
9282: * NOTANY (ONE CHARACTER ARGUMENT)
9283: *
9284: * PARM1 CHARACTER ARGUMENT
9285: *
9286: P$NAS ENT BL$P1 ENTRY POINT
9287: BEQ WB,PMSSL,FAILP FAIL IF NO CHARS LEFT
9288: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
9289: PLC XL,WB POINT TO CURRENT CHARACTER IN STRIN
9290: LCH WA,(XL) LOAD CURRENT CHARACTER
9291: BEQ WA,PARM1(XR),FAILP FAIL IF MATCH
9292: ICV WB ELSE BUMP CURSOR
9293: BRN SUCCP AND SUCCEED
9294: EJC
9295: *
9296: * NOTANY (MULTI-CHARACTER STRING ARGUMENT)
9297: *
9298: * PARM1 POINTER TO CTBLK
9299: * PARM2 BIT MASK TO SELECT BIT COLUMN
9300: *
9301: P$NAY ENT BL$P2 P2BLK
9302: *
9303: * EXPRESSION ARGUMENT CASE MERGES HERE
9304: *
9305: PNAY1 BEQ WB,PMSSL,FAILP FAIL IF NO CHARACTERS LEFT
9306: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
9307: PLC XL,WB POINT TO CURRENT CHARACTER
9308: LCH WA,(XL) LOAD CURRENT CHARACTER
9309: WTB WA CONVERT TO BYTE OFFSET
9310: MOV PARM1(XR),XL LOAD POINTER TO CTBLK
9311: ADD WA,XL POINT TO ENTRY IN CTBLK
9312: MOV CTCHS(XL),WA LOAD ENTRY FROM CTBLK
9313: ANB PARM2(XR),WA AND WITH SELECTED BIT
9314: NZB WA,FAILP FAIL IF CHARACTER IS MATCHED
9315: ICV WB ELSE BUMP CURSOR
9316: BRN SUCCP AND SUCCEED
9317: EJC
9318: *
9319: * END OF PATTERN MATCH
9320: *
9321: * THIS ROUTINE IS ENTERED ON SUCCESSFUL COMPLETION.
9322: * SEE DESCRIPTION OF EXPRESSION PATTERNS IN COMPOUND
9323: * PATTERN SECTION FOR HANDLING OF RECURSION IN MATCHING.
9324: *
9325: * NO PARAMETERS (DUMMY PATTERN)
9326: *
9327: P$NTH ENT ENTRY POINT
9328: MOV PMHBS,XT LOAD POINTER TO BASE OF STACK
9329: MOV 1(XT),WA LOAD SAVED PMHBS (OR PATTERN TYPE)
9330: BLE WA,=NUM02,PNTH2 JUMP IF OUTER LEVEL (PATTERN TYPE)
9331: *
9332: * HERE WE ARE AT THE END OF MATCHING AN EXPRESSION PATTERN
9333: *
9334: MOV WA,PMHBS RESTORE OUTER STACK BASE POINTER
9335: MOV 2(XT),XR RESTORE POINTER TO P$EXA NODE
9336: BEQ XT,XS,PNTH1 JUMP IF NO HISTORY STACK ENTRIES
9337: MOV XT,-(XS) ELSE STACK INNER STACK BASE PTR
9338: MOV =NDEXC,-(XS) STACK PTR TO SPECIAL NODE NDEXC
9339: BRN SUCCP AND SUCCEED
9340: *
9341: * HERE IF NO HISTORY STACK ENTRIES DURING PATTERN
9342: *
9343: PNTH1 ADD *NUM04,XS REMOVE P$EXB ENTRY AND NODE PTR
9344: BRN SUCCP AND SUCCEED
9345: *
9346: * HERE IF END OF MATCH AT OUTER LEVEL
9347: *
9348: PNTH2 MOV WB,PMSSL SAVE FINAL CURSOR IN SAFE PLACE
9349: BZE PMDFL,PNTH6 JUMP IF NO PATTERN ASSIGNMENTS
9350: EJC
9351: *
9352: * END OF PATTERN MATCH (CONTINUED)
9353: *
9354: * NOW WE MUST PERFORM PATTERN ASSIGNMENTS. THIS IS DONE BY
9355: * SCANNING THE HISTORY STACK FOR MATCHING NDPAB-NDPAD PAIRS
9356: *
9357: PNTH3 DCA XT POINT PAST CURSOR ENTRY
9358: MOV -(XT),WA LOAD NODE POINTER
9359: BEQ WA,=NDPAD,PNTH4 JUMP IF NDPAD ENTRY
9360: BNE WA,=NDPAB,PNTH5 JUMP IF NOT NDPAB ENTRY
9361: *
9362: * HERE FOR NDPAB ENTRY, STACK INITIAL CURSOR
9363: * NOTE THAT THERE MUST BE MORE ENTRIES ON THE STACK.
9364: *
9365: MOV 1(XT),-(XS) STACK INITIAL CURSOR
9366: CHK CHECK FOR STACK OVERFLOW
9367: BRN PNTH3 LOOP BACK IF OK
9368: *
9369: * HERE FOR NDPAD ENTRY. THE STARTING CURSOR FROM THE
9370: * MATCHING NDPAD ENTRY IS NOW THE TOP STACK ENTRY.
9371: *
9372: PNTH4 MOV 1(XT),WA LOAD FINAL CURSOR
9373: MOV (XS),WB LOAD INITIAL CURSOR FROM STACK
9374: MOV XT,(XS) SAVE HISTORY STACK SCAN PTR
9375: SUB WB,WA COMPUTE LENGTH OF STRING
9376: *
9377: * BUILD SUBSTRING AND PERFORM ASSIGNMENT
9378: *
9379: MOV R$PMS,XL POINT TO SUBJECT STRING
9380: JSR SBSTR CONSTRUCT SUBSTRING
9381: MOV XR,WB COPY SUBSTRING POINTER
9382: MOV (XS),XT RELOAD HISTORY STACK SCAN PTR
9383: MOV 2(XT),XL LOAD POINTER TO P$PAC NODE WITH NAM
9384: MOV PARM2(XL),WA LOAD NAME OFFSET
9385: MOV PARM1(XL),XL LOAD NAME BASE
9386: JSR ASINP PERFORM ASSIGNMENT
9387: PPM EXFAL MATCH FAILS IF NAME EVAL FAILS
9388: MOV (XS)+,XT ELSE RESTORE HISTORY STACK PTR
9389: EJC
9390: *
9391: * END OF PATTERN MATCH (CONTINUED)
9392: *
9393: * HERE CHECK FOR END OF ENTRIES
9394: *
9395: PNTH5 BNE XT,XS,PNTH3 LOOP IF MORE ENTRIES TO SCAN
9396: *
9397: * HERE AFTER DEALING WITH PATTERN ASSIGNMENTS
9398: *
9399: PNTH6 MOV PMHBS,XS WIPE OUT HISTORY STACK
9400: MOV (XS)+,WB LOAD INITIAL CURSOR
9401: MOV (XS)+,WC LOAD MATCH TYPE CODE
9402: MOV PMSSL,WA LOAD FINAL CURSOR VALUE
9403: MOV R$PMS,XL POINT TO SUBJECT STRING
9404: ZER R$PMS CLEAR SUBJECT STRING PTR FOR GBCOL
9405: BZE WC,PNTH7 JUMP IF CALL BY NAME
9406: BEQ WC,=NUM02,EXITS EXIT IF STATEMENT LEVEL CALL
9407: *
9408: * HERE WE HAVE A CALL BY VALUE, BUILD SUBSTRING
9409: *
9410: SUB WB,WA COMPUTE LENGTH OF STRING
9411: JSR SBSTR BUILD SUBSTRING
9412: BRN EXIXR AND EXIT WITH SUBSTRING VALUE
9413: *
9414: * HERE FOR CALL BY NAME, MAKE STACK ENTRIES FOR O$RPL
9415: *
9416: PNTH7 MOV WB,-(XS) STACK INITIAL CURSOR
9417: MOV WA,-(XS) STACK FINAL CURSOR
9418: .IF .CNBF
9419: .ELSE
9420: BZE R$PMB,PNTH8 SKIP IF SUBJECT NOT BUFFER
9421: MOV R$PMB,XL ELSE GET PTR TO BCBLK INSTEAD
9422: .FI
9423: *
9424: * HERE WITH XL POINTING TO SCBLK OR BCBLK
9425: *
9426: PNTH8 MOV XL,-(XS) STACK SUBJECT POINTER
9427: BRN EXITS EXIT WITH SPECIAL ENTRY ON STACK
9428: EJC
9429: *
9430: * POS (INTEGER ARGUMENT)
9431: *
9432: * PARM1 INTEGER ARGUMENT
9433: *
9434: P$POS ENT BL$P1 P1BLK
9435: *
9436: * EXPRESSION ARGUMENT CASE MERGES HERE
9437: *
9438: PPOS1 BEQ WB,PARM1(XR),SUCCP SUCCEED IF AT RIGHT LOCATION
9439: BRN FAILP ELSE FAIL
9440: EJC
9441: *
9442: * POS (EXPRESSION ARGUMENT)
9443: *
9444: * PARM1 EXPRESSION POINTER
9445: *
9446: P$PSD ENT BL$P1 P1BLK
9447: JSR EVALI EVALUATE INTEGER ARGUMENT
9448: ERR 050,POS EVALUATED ARGUMENT IS NOT INTEGER
9449: ERR 051,POS EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
9450: PPM FAILP FAIL IF EVALUATION FAILS
9451: PPM PPOS1 MERGE WITH NORMAL CASE IF OK
9452: EJC
9453: *
9454: * PATTERN ASSIGNMENT (INITIAL ENTRY, SAVE CURSOR)
9455: *
9456: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9457: * ALGORITHMS FOR MATCHING THIS NODE TYPE.
9458: *
9459: * NO PARAMETERS
9460: *
9461: P$PAA ENT BL$P0 P0BLK
9462: MOV WB,-(XS) STACK INITIAL CURSOR
9463: MOV =NDPAB,-(XS) STACK PTR TO NDPAB SPECIAL NODE
9464: BRN SUCCP AND SUCCEED MATCHING NULL
9465: EJC
9466: *
9467: * PATTERN ASSIGNMENT (REMOVE SAVED CURSOR)
9468: *
9469: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9470: * ALGORITHMS FOR MATCHING THIS NODE TYPE.
9471: *
9472: * NO PARAMETERS (DUMMY PATTERN)
9473: *
9474: P$PAB ENT ENTRY POINT
9475: BRN FAILP JUST FAIL (ENTRY IS ALREADY POPPED)
9476: EJC
9477: *
9478: * PATTERN ASSIGNMENT (END OF MATCH, MAKE ASSIGN ENTRY)
9479: *
9480: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9481: * ALGORITHMS FOR MATCHING THIS NODE TYPE.
9482: *
9483: * PARM1 NAME BASE OF VARIABLE
9484: * PARM2 NAME OFFSET OF VARIABLE
9485: *
9486: P$PAC ENT BL$P2 P2BLK
9487: MOV WB,-(XS) STACK DUMMY CURSOR VALUE
9488: MOV XR,-(XS) STACK POINTER TO P$PAC NODE
9489: MOV WB,-(XS) STACK FINAL CURSOR
9490: MOV =NDPAD,-(XS) STACK PTR TO SPECIAL NDPAD NODE
9491: MNZ PMDFL SET DOT FLAG NON-ZERO
9492: BRN SUCCP AND SUCCEED
9493: EJC
9494: *
9495: * PATTERN ASSIGNMENT (REMOVE ASSIGN ENTRY)
9496: *
9497: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9498: * ALGORITHMS FOR MATCHING THIS NODE TYPE.
9499: *
9500: * NO PARAMETERS (DUMMY NODE)
9501: *
9502: P$PAD ENT ENTRY POINT
9503: BRN FLPOP FAIL AND REMOVE P$PAC NODE
9504: EJC
9505: *
9506: * REM
9507: *
9508: * NO PARAMETERS
9509: *
9510: P$REM ENT BL$P0 P0BLK
9511: MOV PMSSL,WB POINT CURSOR TO END OF STRING
9512: BRN SUCCP AND SUCCEED
9513: EJC
9514: *
9515: * RPOS (EXPRESSION ARGUMENT)
9516: *
9517: * PARM1 EXPRESSION POINTER
9518: *
9519: P$RPD ENT BL$P1 P1BLK
9520: JSR EVALI EVALUATE INTEGER ARGUMENT
9521: ERR 052,RPOS EVALUATED ARGUMENT IS NOT INTEGER
9522: ERR 053,RPOS EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
9523: PPM FAILP FAIL IF EVALUATION FAILS
9524: PPM PRPS1 MERGE WITH NORMAL CASE IF OK
9525: EJC
9526: *
9527: * RPOS (INTEGER ARGUMENT)
9528: *
9529: * PARM1 INTEGER ARGUMENT
9530: *
9531: P$RPS ENT BL$P1 P1BLK
9532: *
9533: * EXPRESSION ARGUMENT CASE MERGES HERE
9534: *
9535: PRPS1 MOV PMSSL,WC GET LENGTH OF STRING
9536: SUB WB,WC GET NUMBER OF CHARACTERS REMAINING
9537: BEQ WC,PARM1(XR),SUCCP SUCCEED IF AT RIGHT LOCATION
9538: BRN FAILP ELSE FAIL
9539: EJC
9540: *
9541: * RTAB (INTEGER ARGUMENT)
9542: *
9543: * PARM1 INTEGER ARGUMENT
9544: *
9545: P$RTB ENT BL$P1 P1BLK
9546: *
9547: * EXPRESSION ARGUMENT CASE MERGES HERE
9548: *
9549: PRTB1 MOV WB,WC SAVE INITIAL CURSOR
9550: MOV PMSSL,WB POINT TO END OF STRING
9551: BLT WB,PARM1(XR),FAILP FAIL IF STRING NOT LONG ENOUGH
9552: SUB PARM1(XR),WB ELSE SET NEW CURSOR
9553: BGE WB,WC,SUCCP AND SUCCEED IF NOT TOO FAR ALREADY
9554: BRN FAILP IN WHICH CASE, FAIL
9555: EJC
9556: *
9557: * RTAB (EXPRESSION ARGUMENT)
9558: *
9559: * PARM1 EXPRESSION POINTER
9560: *
9561: P$RTD ENT BL$P1 P1BLK
9562: JSR EVALI EVALUATE INTEGER ARGUMENT
9563: ERR 054,RTAB EVALUATED ARGUMENT IS NOT INTEGER
9564: ERR 055,RTAB EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
9565: PPM FAILP FAIL IF EVALUATION FAILS
9566: PPM PRTB1 MERGE WITH NORMAL CASE IF SUCCESS
9567: EJC
9568: *
9569: * SPAN (EXPRESSION ARGUMENT)
9570: *
9571: * PARM1 EXPRESSION POINTER
9572: *
9573: P$SPD ENT BL$P1 P1BLK
9574: JSR EVALS EVALUATE STRING ARGUMENT
9575: ERR 056,SPAN EVALUATED ARGUMENT IS NOT STRING
9576: PPM FAILP FAIL IF EVALUATION FAILS
9577: PPM PSPN1 MERGE WITH MULTI-CHAR CASE IF OK
9578: EJC
9579: *
9580: * SPAN (MULTI-CHARACTER ARGUMENT CASE)
9581: *
9582: * PARM1 POINTER TO CTBLK
9583: * PARM2 BIT MASK TO SELECT BIT COLUMN
9584: *
9585: P$SPN ENT BL$P2 P2BLK
9586: *
9587: * EXPRESSION ARGUMENT CASE MERGES HERE
9588: *
9589: PSPN1 MOV PMSSL,WC COPY SUBJECT STRING LENGTH
9590: SUB WB,WC CALCULATE NUMBER OF CHARACTERS LEFT
9591: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT
9592: MOV R$PMS,XL POINT TO SUBJECT STRING
9593: PLC XL,WB POINT TO CURRENT CHARACTER
9594: MOV WB,PSAVC SAVE INITIAL CURSOR
9595: MOV XR,PSAVE SAVE NODE POINTER
9596: LCT WC,WC SET COUNTER FOR CHARS LEFT
9597: *
9598: * LOOP TO SCAN MATCHING CHARACTERS
9599: *
9600: PSPN2 LCH WA,(XL)+ LOAD NEXT CHARACTER, BUMP POINTER
9601: WTB WA CONVERT TO BYTE OFFSET
9602: MOV PARM1(XR),XR POINT TO CTBLK
9603: ADD WA,XR POINT TO CTBLK ENTRY
9604: MOV CTCHS(XR),WA LOAD CTBLK ENTRY
9605: MOV PSAVE,XR RESTORE NODE POINTER
9606: ANB PARM2(XR),WA AND WITH SELECTED BIT
9607: ZRB WA,PSPN3 JUMP IF NO MATCH
9608: ICV WB ELSE PUSH CURSOR
9609: BCT WC,PSPN2 LOOP BACK UNLESS END OF STRING
9610: *
9611: * HERE AFTER SCANNING MATCHING CHARACTERS
9612: *
9613: PSPN3 BNE WB,PSAVC,SUCCP SUCCEED IF CHARS MATCHED
9614: BRN FAILP ELSE FAIL IF NULL STRING MATCHED
9615: EJC
9616: *
9617: * SPAN (ONE CHARACTER ARGUMENT)
9618: *
9619: * PARM1 CHARACTER ARGUMENT
9620: *
9621: P$SPS ENT BL$P1 P1BLK
9622: MOV PMSSL,WC GET SUBJECT STRING LENGTH
9623: SUB WB,WC CALCULATE NUMBER OF CHARACTERS LEFT
9624: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT
9625: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
9626: PLC XL,WB POINT TO CURRENT CHARACTER
9627: MOV WB,PSAVC SAVE INITIAL CURSOR
9628: LCT WC,WC SET COUNTER FOR CHARACTERS LEFT
9629: *
9630: * LOOP TO SCAN MATCHING CHARACTERS
9631: *
9632: PSPS1 LCH WA,(XL)+ LOAD NEXT CHARACTER, BUMP POINTER
9633: BNE WA,PARM1(XR),PSPS2 JUMP IF NO MATCH
9634: ICV WB ELSE PUSH CURSOR
9635: BCT WC,PSPS1 AND LOOP UNLESS END OF STRING
9636: *
9637: * HERE AFTER SCANNING MATCHING CHARACTERS
9638: *
9639: PSPS2 BNE WB,PSAVC,SUCCP SUCCEED IF CHARS MATCHED
9640: BRN FAILP FAIL IF NULL STRING MATCHED
9641: EJC
9642: *
9643: * MULTI-CHARACTER STRING
9644: *
9645: * NOTE THAT ONE CHARACTER STRINGS USE THE CIRCUIT FOR
9646: * ONE CHARACTER ANY ARGUMENTS (P$AN1).
9647: *
9648: * PARM1 POINTER TO SCBLK FOR STRING ARG
9649: *
9650: P$STR ENT BL$P1 P1BLK
9651: MOV PARM1(XR),XL GET POINTER TO STRING
9652: *
9653: * MERGE HERE AFTER EVALUATING EXPRESSION WITH STRING VALUE
9654: *
9655: PSTR1 MOV XR,PSAVE SAVE NODE POINTER
9656: MOV R$PMS,XR LOAD SUBJECT STRING POINTER
9657: PLC XR,WB POINT TO CURRENT CHARACTER
9658: ADD SCLEN(XL),WB COMPUTE NEW CURSOR POSITION
9659: BGT WB,PMSSL,FAILP FAIL IF PAST END OF STRING
9660: MOV WB,PSAVC SAVE UPDATED CURSOR
9661: MOV SCLEN(XL),WA GET NUMBER OF CHARS TO COMPARE
9662: PLC XL POINT TO CHARS OF TEST STRING
9663: CMC FAILP,FAILP COMPARE, FAIL IF NOT EQUAL
9664: MOV PSAVE,XR IF ALL MATCHED, RESTORE NODE PTR
9665: MOV PSAVC,WB RESTORE UPDATED CURSOR
9666: BRN SUCCP AND SUCCEED
9667: EJC
9668: *
9669: * SUCCEED
9670: *
9671: * SEE SECTION ON COMPOUND PATTERNS FOR DETAILS OF THE
9672: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE
9673: *
9674: * NO PARAMETERS
9675: *
9676: P$SUC ENT BL$P0 P0BLK
9677: MOV WB,-(XS) STACK CURSOR
9678: MOV XR,-(XS) STACK POINTER TO THIS NODE
9679: BRN SUCCP SUCCEED MATCHING NULL
9680: EJC
9681: *
9682: * TAB (INTEGER ARGUMENT)
9683: *
9684: * PARM1 INTEGER ARGUMENT
9685: *
9686: P$TAB ENT BL$P1 P1BLK
9687: *
9688: * EXPRESSION ARGUMENT CASE MERGES HERE
9689: *
9690: PTAB1 BGT WB,PARM1(XR),FAILP FAIL IF TOO FAR ALREADY
9691: MOV PARM1(XR),WB ELSE SET NEW CURSOR POSITION
9692: BLE WB,PMSSL,SUCCP SUCCEED IF NOT OFF END
9693: BRN FAILP ELSE FAIL
9694: EJC
9695: *
9696: * TAB (EXPRESSION ARGUMENT)
9697: *
9698: * PARM1 EXPRESSION POINTER
9699: *
9700: P$TBD ENT BL$P1 P1BLK
9701: JSR EVALI EVALUATE INTEGER ARGUMENT
9702: ERR 057,TAB EVALUATED ARGUMENT IS NOT INTEGER
9703: ERR 058,TAB EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
9704: PPM FAILP FAIL IF EVALUATION FAILS
9705: PPM PTAB1 MERGE WITH NORMAL CASE IF OK
9706: EJC
9707: *
9708: * ANCHOR MOVEMENT
9709: *
9710: * NO PARAMETERS (DUMMY NODE)
9711: *
9712: P$UNA ENT ENTRY POINT
9713: MOV WB,XR COPY INITIAL PATTERN NODE POINTER
9714: MOV (XS),WB GET INITIAL CURSOR
9715: BEQ WB,PMSSL,EXFAL MATCH FAILS IF AT END OF STRING
9716: ICV WB ELSE INCREMENT CURSOR
9717: MOV WB,(XS) STORE INCREMENTED CURSOR
9718: MOV XR,-(XS) RESTACK INITIAL NODE PTR
9719: MOV =NDUNA,-(XS) RESTACK UNANCHORED NODE
9720: BRI (XR) REMATCH FIRST NODE
9721: EJC
9722: *
9723: * END OF PATTERN MATCH ROUTINES
9724: *
9725: * THE FOLLOWING ENTRY POINT MARKS THE END OF THE PATTERN
9726: * MATCHING ROUTINES AND ALSO THE END OF THE ENTRY POINTS
9727: * REFERENCED FROM THE FIRST WORD OF BLOCKS IN DYNAMIC STORE
9728: *
9729: P$YYY ENT BL$$I MARK LAST ENTRY IN PATTERN SECTION
9730: TTL S P I T B O L -- PREDEFINED SNOBOL4 FUNCTIONS
9731: *
9732: * THE FOLLOWING SECTION CONTAINS CODING FOR FUNCTIONS
9733: * WHICH ARE PREDEFINED AND AVAILABLE AT THE SNOBOL LEVEL.
9734: *
9735: * THESE ROUTINES RECEIVE CONTROL DIRECTLY FROM THE CODE OR
9736: * INDIRECTLY THROUGH THE O$FNC, O$FNS OR CFUNC ROUTINES.
9737: * IN BOTH CASES THE CONDITIONS ON ENTRY ARE AS FOLLOWS
9738: *
9739: * THE ARGUMENTS ARE ON THE STACK. THE NUMBER OF ARGUMENTS
9740: * HAS BEEN ADJUSTED TO CORRESPOND TO THE SVBLK SVNAR FIELD.
9741: *
9742: * IN CERTAIN FUNCTIONS THE DIRECT CALL IS NOT PERMITTED
9743: * AND IN THESE INSTANCES WE ALSO HAVE.
9744: *
9745: * (WA) ACTUAL NUMBER OF ARGUMENTS IN CALL
9746: *
9747: * CONTROL RETURNS BY PLACING THE FUNCTION RESULT VALUE ON
9748: * ON THE STACK AND CONTINUING EXECUTION WITH THE NEXT
9749: * WORD FROM THE GENERATED CODE.
9750: *
9751: * THE NAMES OF THE ENTRY POINTS OF THESE FUNCTIONS ARE OF
9752: * THE FORM S$XXX WHERE XXX IS THE THREE LETTER CODE FOR
9753: * THE SYSTEM VARIABLE NAME. THE FUNCTIONS ARE IN ORDER
9754: * ALPHABETICALLY BY THEIR ENTRY NAMES.
9755: EJC
9756: *
9757: * ANY
9758: *
9759: S$ANY ENT ENTRY POINT
9760: MOV =P$ANS,WB SET PCODE FOR SINGLE CHAR CASE
9761: MOV =P$ANY,XL PCODE FOR MULTI-CHAR CASE
9762: MOV =P$AYD,WC PCODE FOR EXPRESSION CASE
9763: JSR PATST CALL COMMON ROUTINE TO BUILD NODE
9764: ERR 059,ANY ARGUMENT IS NOT STRING OR EXPRESSION
9765: BRN EXIXR JUMP FOR NEXT CODE WORD
9766: EJC
9767: .IF .CNBF
9768: .ELSE
9769: *
9770: * APPEND
9771: *
9772: S$APN ENT ENTRY POINT
9773: MOV (XS)+,XL GET APPEND ARGUMENT
9774: MOV (XS)+,XR GET BCBLK
9775: BEQ (XR),=B$BCT,SAPN1 OK IF FIRST ARG IS BCBLK
9776: ERB 275,APPEND FIRST ARGUMENT IS NOT BUFFER
9777: *
9778: * HERE TO DO THE APPEND
9779: *
9780: SAPN1 JSR APNDB DO THE APPEND
9781: ERR 276,APPEND SECOND ARGUMENT IS NOT STRING
9782: PPM EXFAL NO ROOM - FAIL
9783: BRN EXNUL EXIT WITH NULL RESULT
9784: EJC
9785: .FI
9786: *
9787: * APPLY
9788: *
9789: * APPLY DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT
9790: * WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED.
9791: *
9792: S$APP ENT ENTRY POINT
9793: BZE WA,SAPP3 JUMP IF NO ARGUMENTS
9794: DCV WA ELSE GET APPLIED FUNC ARG COUNT
9795: MOV WA,WB COPY
9796: WTB WB CONVERT TO BYTES
9797: MOV XS,XT COPY STACK POINTER
9798: ADD WB,XT POINT TO FUNCTION ARGUMENT ON STACK
9799: MOV (XT),XR LOAD FUNCTION PTR (APPLY 1ST ARG)
9800: BZE WA,SAPP2 JUMP IF NO ARGS FOR APPLIED FUNC
9801: LCT WB,WA ELSE SET COUNTER FOR LOOP
9802: *
9803: * LOOP TO MOVE ARGUMENTS UP ON STACK
9804: *
9805: SAPP1 DCA XT POINT TO NEXT ARGUMENT
9806: MOV (XT),1(XT) MOVE ARGUMENT UP
9807: BCT WB,SAPP1 LOOP TILL ALL MOVED
9808: *
9809: * MERGE HERE TO CALL FUNCTION (WA = NUMBER OF ARGUMENTS)
9810: *
9811: SAPP2 ICA XS ADJUST STACK PTR FOR APPLY 1ST ARG
9812: JSR GTNVR GET VARIABLE BLOCK ADDR FOR FUNC
9813: PPM SAPP3 JUMP IF NOT NATURAL VARIABLE
9814: MOV VRFNC(XR),XL ELSE POINT TO FUNCTION BLOCK
9815: BRN CFUNC GO CALL APPLIED FUNCTION
9816: *
9817: * HERE FOR INVALID FIRST ARGUMENT
9818: *
9819: SAPP3 ERB 060,APPLY FIRST ARG IS NOT NATURAL VARIABLE NAME
9820: EJC
9821: *
9822: * ARBNO
9823: *
9824: * ARBNO BUILDS A COMPOUND PATTERN. SEE DESCRIPTION AT
9825: * START OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED.
9826: *
9827: S$ABN ENT ENTRY POINT
9828: ZER XR SET PARM1 = 0 FOR THE MOMENT
9829: MOV =P$ALT,WB SET PCODE FOR ALTERNATIVE NODE
9830: JSR PBILD BUILD ALTERNATIVE NODE
9831: MOV XR,XL SAVE PTR TO ALTERNATIVE PATTERN
9832: MOV =P$ABC,WB PCODE FOR P$ABC
9833: ZER XR P0BLK
9834: JSR PBILD BUILD P$ABC NODE
9835: MOV XL,PTHEN(XR) PUT ALTERNATIVE NODE AS SUCCESSOR
9836: MOV XL,WA REMEMBER ALTERNATIVE NODE POINTER
9837: MOV XR,XL COPY P$ABC NODE PTR
9838: MOV (XS),XR LOAD ARBNO ARGUMENT
9839: MOV WA,(XS) STACK ALTERNATIVE NODE POINTER
9840: JSR GTPAT GET ARBNO ARGUMENT AS PATTERN
9841: ERR 061,ARBNO ARGUMENT IS NOT PATTERN
9842: JSR PCONC CONCAT ARG WITH P$ABC NODE
9843: MOV XR,XL REMEMBER PTR TO CONCD PATTERNS
9844: MOV =P$ABA,WB PCODE FOR P$ABA
9845: ZER XR P0BLK
9846: JSR PBILD BUILD P$ABA NODE
9847: MOV XL,PTHEN(XR) CONCATENATE NODES
9848: MOV (XS),XL RECALL PTR TO ALTERNATIVE NODE
9849: MOV XR,PARM1(XL) POINT ALTERNATIVE BACK TO ARGUMENT
9850: BRN EXITS JUMP FOR NEXT CODE WORD
9851: EJC
9852: *
9853: * ARG
9854: *
9855: S$ARG ENT ENTRY POINT
9856: JSR GTSMI GET SECOND ARG AS SMALL INTEGER
9857: ERR 062,ARG SECOND ARGUMENT IS NOT INTEGER
9858: PPM EXFAL FAIL IF OUT OF RANGE OR NEGATIVE
9859: MOV XR,WA SAVE ARGUMENT NUMBER
9860: MOV (XS)+,XR LOAD FIRST ARGUMENT
9861: JSR GTNVR LOCATE VRBLK
9862: PPM SARG1 JUMP IF NOT NATURAL VARIABLE
9863: MOV VRFNC(XR),XR ELSE LOAD FUNCTION BLOCK POINTER
9864: BNE (XR),=B$PFC,SARG1 JUMP IF NOT PROGRAM DEFINED
9865: BZE WA,EXFAL FAIL IF ARG NUMBER IS ZERO
9866: BGT WA,FARGS(XR),EXFAL FAIL IF ARG NUMBER IS TOO LARGE
9867: WTB WA ELSE CONVERT TO BYTE OFFSET
9868: ADD WA,XR POINT TO ARGUMENT SELECTED
9869: MOV PFAGB(XR),XR LOAD ARGUMENT VRBLK POINTER
9870: BRN EXVNM EXIT TO BUILD NMBLK
9871: *
9872: * HERE IF 1ST ARGUMENT IS BAD
9873: *
9874: SARG1 ERB 063,ARG FIRST ARGUMENT IS NOT PROGRAM FUNCTION NAME
9875: EJC
9876: *
9877: * ARRAY
9878: *
9879: S$ARR ENT ENTRY POINT
9880: MOV (XS)+,XL LOAD INITIAL ELEMENT VALUE
9881: MOV (XS)+,XR LOAD FIRST ARGUMENT
9882: JSR GTINT CONVERT FIRST ARG TO INTEGER
9883: PPM SAR02 JUMP IF NOT INTEGER
9884: *
9885: * HERE FOR INTEGER FIRST ARGUMENT, BUILD VCBLK
9886: *
9887: LDI ICVAL(XR) LOAD INTEGER VALUE
9888: ILE SAR10 JUMP IF ZERO OR NEG (BAD DIMENSION)
9889: MFI WA,SAR11 ELSE CONVERT TO ONE WORD, TEST OVFL
9890: LCT WB,WA COPY ELEMENTS FOR LOOP LATER ON
9891: ADD =VCSI$,WA ADD SPACE FOR STANDARD FIELDS
9892: WTB WA CONVERT LENGTH TO BYTES
9893: BGE WA,MXLEN,SAR11 FAIL IF TOO LARGE
9894: JSR ALLOC ALLOCATE SPACE FOR VCBLK
9895: MOV =B$VCT,(XR) STORE TYPE WORD
9896: MOV WA,VCLEN(XR) SET LENGTH
9897: MOV XL,WC COPY DEFAULT VALUE
9898: MOV XR,XL COPY VCBLK POINTER
9899: ADD *VCVLS,XL POINT TO FIRST ELEMENT VALUE
9900: *
9901: * LOOP TO SET VECTOR ELEMENTS TO DEFAULT VALUE
9902: *
9903: SAR01 MOV WC,(XL)+ STORE ONE VALUE
9904: BCT WB,SAR01 LOOP TILL ALL STORED
9905: BRN EXSID EXIT SETTING IDVAL
9906: EJC
9907: *
9908: * ARRAY (CONTINUED)
9909: *
9910: * HERE IF FIRST ARGUMENT IS NOT AN INTEGER
9911: *
9912: SAR02 MOV XR,-(XS) REPLACE ARGUMENT ON STACK
9913: JSR XSCNI INITIALIZE SCAN OF FIRST ARGUMENT
9914: ERR 064,ARRAY FIRST ARGUMENT IS NOT INTEGER OR STRING
9915: PPM EXNUL DUMMY (UNUSED) NULL STRING EXIT
9916: MOV R$XSC,-(XS) SAVE PROTOTYPE POINTER
9917: MOV XL,-(XS) SAVE DEFAULT VALUE
9918: ZER ARCDM ZERO COUNT OF DIMENSIONS
9919: ZER ARPTR ZERO OFFSET TO INDICATE PASS ONE
9920: LDI INTV1 LOAD INTEGER ONE
9921: STI ARNEL INITIALIZE ELEMENT COUNT
9922: *
9923: * THE FOLLOWING CODE IS EXECUTED TWICE. THE FIRST TIME
9924: * (ARPTR EQ 0), IT IS USED TO COUNT THE NUMBER OF ELEMENTS
9925: * AND NUMBER OF DIMENSIONS. THE SECOND TIME (ARPTR GT 0) IS
9926: * USED TO ACTUALLY FILL IN THE DIM,LBD FIELDS OF THE ARBLK.
9927: *
9928: SAR03 LDI INTV1 LOAD ONE AS DEFAULT LOW BOUND
9929: STI ARSVL SAVE AS LOW BOUND
9930: MOV =CH$CL,WC SET DELIMITER ONE = COLON
9931: MOV =CH$CM,XL SET DELIMITER TWO = COMMA
9932: JSR XSCAN SCAN NEXT BOUND
9933: BNE WA,=NUM01,SAR04 JUMP IF NOT COLON
9934: *
9935: * HERE WE HAVE A COLON ENDING A LOW BOUND
9936: *
9937: JSR GTINT CONVERT LOW BOUND
9938: ERR 065,ARRAY FIRST ARGUMENT LOWER BOUND IS NOT INTEGER
9939: LDI ICVAL(XR) LOAD VALUE OF LOW BOUND
9940: STI ARSVL STORE LOW BOUND VALUE
9941: MOV =CH$CM,WC SET DELIMITER ONE = COMMA
9942: MOV WC,XL AND DELIMITER TWO = COMMA
9943: JSR XSCAN SCAN HIGH BOUND
9944: EJC
9945: *
9946: * ARRAY (CONTINUED)
9947: *
9948: * MERGE HERE TO PROCESS UPPER BOUND
9949: *
9950: SAR04 JSR GTINT CONVERT HIGH BOUND TO INTEGER
9951: ERR 066,ARRAY FIRST ARGUMENT UPPER BOUND IS NOT INTEGER
9952: LDI ICVAL(XR) GET HIGH BOUND
9953: SBI ARSVL SUBTRACT LOWER BOUND
9954: IOV SAR10 BAD DIMENSION IF OVERFLOW
9955: ILT SAR10 BAD DIMENSION IF NEGATIVE
9956: ADI INTV1 ADD 1 TO GET DIMENSION
9957: IOV SAR10 BAD DIMENSION IF OVERFLOW
9958: MOV ARPTR,XL LOAD OFFSET (ALSO PASS INDICATOR)
9959: BZE XL,SAR05 JUMP IF FIRST PASS
9960: *
9961: * HERE IN SECOND PASS TO STORE LBD AND DIM IN ARBLK
9962: *
9963: ADD (XS),XL POINT TO CURRENT LOCATION IN ARBLK
9964: STI CFP$I(XL) STORE DIMENSION
9965: LDI ARSVL LOAD LOW BOUND
9966: STI (XL) STORE LOW BOUND
9967: ADD *ARDMS,ARPTR BUMP OFFSET TO NEXT BOUNDS
9968: BRN SAR06 JUMP TO CHECK FOR END OF BOUNDS
9969: *
9970: * HERE IN PASS 1
9971: *
9972: SAR05 ICV ARCDM BUMP DIMENSION COUNT
9973: MLI ARNEL MULTIPLY DIMENSION BY COUNT SO FAR
9974: IOV SAR11 TOO LARGE IF OVERFLOW
9975: STI ARNEL ELSE STORE UPDATED ELEMENT COUNT
9976: *
9977: * MERGE HERE AFTER PROCESSING ONE SET OF BOUNDS
9978: *
9979: SAR06 BNZ WA,SAR03 LOOP BACK UNLESS END OF BOUNDS
9980: BNZ ARPTR,SAR09 JUMP IF END OF PASS 2
9981: EJC
9982: *
9983: * ARRAY (CONTINUED)
9984: *
9985: * HERE AT END OF PASS ONE, BUILD ARBLK
9986: *
9987: LDI ARNEL GET NUMBER OF ELEMENTS
9988: MFI WB,SAR11 GET AS ADDR INTEGER, TEST OVFLO
9989: WTB WB ELSE CONVERT TO LENGTH IN BYTES
9990: MOV *ARSI$,WA SET SIZE OF STANDARD FIELDS
9991: LCT WC,ARCDM SET DIMENSION COUNT TO CONTROL LOOP
9992: *
9993: * LOOP TO ALLOW SPACE FOR DIMENSIONS
9994: *
9995: SAR07 ADD *ARDMS,WA ALLOW SPACE FOR ONE SET OF BOUNDS
9996: BCT WC,SAR07 LOOP BACK TILL ALL ACCOUNTED FOR
9997: MOV WA,XL SAVE SIZE (=AROFS)
9998: *
9999: * NOW ALLOCATE SPACE FOR ARBLK
10000: *
10001: ADD WB,WA ADD SPACE FOR ELEMENTS
10002: ICA WA ALLOW FOR ARPRO PROTOTYPE FIELD
10003: BGE WA,MXLEN,SAR11 FAIL IF TOO LARGE
10004: JSR ALLOC ELSE ALLOCATE ARBLK
10005: MOV (XS),WB LOAD DEFAULT VALUE
10006: MOV XR,(XS) SAVE ARBLK POINTER
10007: MOV WA,WC SAVE LENGTH IN BYTES
10008: BTW WA CONVERT LENGTH BACK TO WORDS
10009: LCT WA,WA SET COUNTER TO CONTROL LOOP
10010: *
10011: * LOOP TO CLEAR ENTIRE ARBLK TO DEFAULT VALUE
10012: *
10013: SAR08 MOV WB,(XR)+ SET ONE WORD
10014: BCT WA,SAR08 LOOP TILL ALL SET
10015: EJC
10016: *
10017: * ARRAY (CONTINUED)
10018: *
10019: * NOW SET INITIAL FIELDS OF ARBLK
10020: *
10021: MOV (XS)+,XR RELOAD ARBLK POINTER
10022: MOV (XS),WB LOAD PROTOTYPE
10023: MOV =B$ART,(XR) SET TYPE WORD
10024: MOV WC,ARLEN(XR) STORE LENGTH IN BYTES
10025: ZER IDVAL(XR) ZERO ID TILL WE GET IT BUILT
10026: MOV XL,AROFS(XR) SET PROTOTYPE FIELD PTR
10027: MOV ARCDM,ARNDM(XR) SET NUMBER OF DIMENSIONS
10028: MOV XR,WC SAVE ARBLK POINTER
10029: ADD XL,XR POINT TO PROTOTYPE FIELD
10030: MOV WB,(XR) STORE PROTOTYPE PTR IN ARBLK
10031: MOV *ARLBD,ARPTR SET OFFSET FOR PASS 2 BOUNDS SCAN
10032: MOV WB,R$XSC RESET STRING POINTER FOR XSCAN
10033: MOV WC,(XS) STORE ARBLK POINTER ON STACK
10034: ZER XSOFS RESET OFFSET PTR TO START OF STRING
10035: BRN SAR03 JUMP BACK TO RESCAN BOUNDS
10036: *
10037: * HERE AFTER FILLING IN BOUNDS INFORMATION (END PASS TWO)
10038: *
10039: SAR09 MOV (XS)+,XR RELOAD POINTER TO ARBLK
10040: BRN EXSID EXIT SETTING IDVAL
10041: *
10042: * HERE FOR BAD DIMENSION
10043: *
10044: SAR10 ERB 067,ARRAY DIMENSION IS ZERO,NEGATIVE OR OUT OF RANGE
10045: *
10046: * HERE IF ARRAY IS TOO LARGE
10047: *
10048: SAR11 ERB 068,ARRAY SIZE EXCEEDS MAXIMUM PERMITTED
10049: EJC
10050: .IF .CNBF
10051: .ELSE
10052: *
10053: * BUFFER
10054: *
10055: S$BUF ENT ENTRY POINT
10056: MOV (XS)+,XL GET INITIAL VALUE
10057: MOV (XS)+,XR GET REQUESTED ALLOCATION
10058: JSR GTINT CONVERT TO INTEGER
10059: ERR 269,BUFFER FIRST ARGUMENT IS NOT INTEGER
10060: LDI ICVAL(XR) GET VALUE
10061: ILE SBF01 BRANCH IF NEGATIVE OR ZERO
10062: MFI WA,SBF02 MOVE WITH OVERFLOW CHECK
10063: JSR ALOBF ALLOCATE THE BUFFER
10064: JSR APNDB COPY IT IN
10065: ERR 270,BUFFER SECOND ARGUMENT IS NOT STRING OR BUFFER
10066: ERR 271,BUFFER INITIAL VALUE TOO BIG FOR ALLOCATION
10067: BRN EXSID EXIT SETTING IDVAL
10068: *
10069: * HERE FOR INVALID ALLOCATION SIZE
10070: *
10071: SBF01 ERB 272,BUFFER FIRST ARGUMENT IS NOT POSITIVE
10072: *
10073: * HERE FOR ALLOCATION SIZE INTEGER OVERFLOW
10074: *
10075: SBF02 ERB 273,BUFFER SIZE IS TOO BIG
10076: EJC
10077: .FI
10078: *
10079: * BREAK
10080: *
10081: S$BRK ENT ENTRY POINT
10082: MOV =P$BKS,WB SET PCODE FOR SINGLE CHAR CASE
10083: MOV =P$BRK,XL PCODE FOR MULTI-CHAR CASE
10084: MOV =P$BKD,WC PCODE FOR EXPRESSION CASE
10085: JSR PATST CALL COMMON ROUTINE TO BUILD NODE
10086: ERR 069,BREAK ARGUMENT IS NOT STRING OR EXPRESSION
10087: BRN EXIXR JUMP FOR NEXT CODE WORD
10088: EJC
10089: *
10090: * BREAKX
10091: *
10092: * BREAKX IS A COMPOUND PATTERN. SEE DESCRIPTION AT START
10093: * OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED.
10094: *
10095: S$BKX ENT ENTRY POINT
10096: MOV =P$BKS,WB PCODE FOR SINGLE CHAR ARGUMENT
10097: MOV =P$BRK,XL PCODE FOR MULTI-CHAR ARGUMENT
10098: MOV =P$BXD,WC PCODE FOR EXPRESSION CASE
10099: JSR PATST CALL COMMON ROUTINE TO BUILD NODE
10100: ERR 070,BREAKX ARGUMENT IS NOT STRING OR EXPRESSION
10101: *
10102: * NOW HOOK BREAKX NODE ON AT FRONT END
10103: *
10104: MOV XR,-(XS) SAVE PTR TO BREAK NODE
10105: MOV =P$BKX,WB SET PCODE FOR BREAKX NODE
10106: JSR PBILD BUILD IT
10107: MOV (XS),PTHEN(XR) SET BREAK NODE AS SUCCESSOR
10108: MOV =P$ALT,WB SET PCODE FOR ALTERNATION NODE
10109: JSR PBILD BUILD (PARM1=ALT=BREAKX NODE)
10110: MOV XR,WA SAVE PTR TO ALTERNATION NODE
10111: MOV (XS),XR POINT TO BREAK NODE
10112: MOV WA,PTHEN(XR) SET ALTERNATE NODE AS SUCCESSOR
10113: BRN EXITS EXIT WITH RESULT ON STACK
10114: EJC
10115: *
10116: * CHAR
10117: *
10118: S$CHR ENT ENTRY POINT
10119: JSR GTSMI CONVERT ARG TO INTEGER
10120: ERR 281,CHAR ARGUMENT NOT INTEGER
10121: PPM SCHR1 TOO BIG ERROR EXIT
10122: BGE WC,=CFP$A,SCHR1 SEE IF OUT OF RANGE OF HOST SET
10123: MOV =NUM01,WA IF NOT SET SCBLK ALLOCATION
10124: MOV WC,WB SAVE CHAR CODE
10125: JSR ALOCS ALLOCATE 1 BAU SCBLK
10126: MOV XR,XL COPY SCBLK POINTER
10127: PSC XL GET SET TO STUFF CHAR
10128: SCH WB,(XL)+ STUFF IT
10129: ZER XL CLEAR SLOP IN XL
10130: BRN EXIXR EXIT WITH SCBLK POINTER
10131: *
10132: * HERE IF CHAR ARGUMENT IS OUT OF RANGE
10133: *
10134: SCHR1 ERB 282,CHAR ARGUMENT NOT IN RANGE
10135: EJC
10136: *
10137: * CLEAR
10138: *
10139: S$CLR ENT ENTRY POINT
10140: JSR XSCNI INITIALIZE TO SCAN ARGUMENT
10141: ERR 071,CLEAR ARGUMENT IS NOT STRING
10142: PPM SCLR2 JUMP IF NULL
10143: *
10144: * LOOP TO SCAN OUT NAMES IN FIRST ARGUMENT. VARIABLES IN
10145: * THE LIST ARE FALGGED BY SETTING VRGET OF VRBLK TO ZERO.
10146: *
10147: SCLR1 MOV =CH$CM,WC SET DELIMITER ONE = COMMA
10148: MOV WC,XL DELIMITER TWO = COMMA
10149: JSR XSCAN SCAN NEXT VARIABLE NAME
10150: JSR GTNVR LOCATE VRBLK
10151: ERR 072,CLEAR ARGUMENT HAS NULL VARIABLE NAME
10152: ZER VRGET(XR) ELSE FLAG BY ZEROING VRGET FIELD
10153: BNZ WA,SCLR1 LOOP BACK IF STOPPED BY COMMA
10154: *
10155: * HERE AFTER FLAGGING VARIABLES IN ARGUMENT LIST
10156: *
10157: SCLR2 MOV HSHTB,WB POINT TO START OF HASH TABLE
10158: *
10159: * LOOP THROUGH SLOTS IN HASH TABLE
10160: *
10161: SCLR3 BEQ WB,HSHTE,EXNUL EXIT RETURNING NULL IF NONE LEFT
10162: MOV WB,XR ELSE COPY SLOT POINTER
10163: ICA WB BUMP SLOT POINTER
10164: SUB *VRNXT,XR SET OFFSET TO MERGE INTO LOOP
10165: *
10166: * LOOP THROUGH VRBLKS ON ONE HASH CHAIN
10167: *
10168: SCLR4 MOV VRNXT(XR),XR POINT TO NEXT VRBLK ON CHAIN
10169: BZE XR,SCLR3 JUMP FOR NEXT BUCKET IF CHAIN END
10170: BNZ VRGET(XR),SCLR5 JUMP IF NOT FLAGGED
10171: EJC
10172: *
10173: * CLEAR (CONTINUED)
10174: *
10175: * HERE FOR FLAGGED VARIABLE, DO NOT SET VALUE TO NULL
10176: *
10177: JSR SETVR FOR FLAGGED VAR, RESTORE VRGET
10178: BRN SCLR4 AND LOOP BACK FOR NEXT VRBLK
10179: *
10180: * HERE TO SET VALUE OF A VARIABLE TO NULL
10181: * PRROTECTED VARIABLES (ARB, ETC) ARE EXEMPT
10182: *
10183: SCLR5 BEQ VRSTO(XR),=B$VRE,SCLR4 CHECK FOR PROTECTED VARIABLE (REG05)
10184: MOV XR,XL COPY VRBLK POINTER (REG05)
10185: *
10186: * LOOP TO LOCATE VALUE AT END OF POSSIBLE TRBLK CHAIN
10187: *
10188: SCLR6 MOV XL,WA SAVE BLOCK POINTER
10189: MOV VRVAL(XL),XL LOAD NEXT VALUE FIELD
10190: BEQ (XL),=B$TRT,SCLR6 LOOP BACK IF TRAPPED
10191: *
10192: * NOW STORE THE NULL VALUE
10193: *
10194: MOV WA,XL RESTORE BLOCK POINTER
10195: MOV =NULLS,VRVAL(XL) STORE NULL CONSTANT VALUE
10196: BRN SCLR4 LOOP BACK FOR NEXT VRBLK
10197: EJC
10198: *
10199: * CODE
10200: *
10201: S$COD ENT ENTRY POINT
10202: MOV (XS)+,XR LOAD ARGUMENT
10203: JSR GTCOD CONVERT TO CODE
10204: PPM EXFAL FAIL IF CONVERSION IS IMPOSSIBLE
10205: BRN EXIXR ELSE RETURN CODE AS RESULT
10206: EJC
10207: *
10208: * COLLECT
10209: *
10210: S$COL ENT ENTRY POINT
10211: MOV (XS)+,XR LOAD ARGUMENT
10212: JSR GTINT CONVERT TO INTEGER
10213: ERR 073,COLLECT ARGUMENT IS NOT INTEGER
10214: LDI ICVAL(XR) LOAD COLLECT ARGUMENT
10215: STI CLSVI SAVE COLLECT ARGUMENT
10216: ZER WB SET NO MOVE UP
10217: JSR GBCOL PERFORM GARBAGE COLLECTION
10218: MOV DNAME,WA POINT TO END OF MEMORY
10219: SUB DNAMP,WA SUBTRACT NEXT LOCATION
10220: BTW WA CONVERT BYTES TO WORDS
10221: MTI WA CONVERT WORDS AVAILABLE AS INTEGER
10222: SBI CLSVI SUBTRACT ARGUMENT
10223: IOV EXFAL FAIL IF OVERFLOW
10224: ILT EXFAL FAIL IF NOT ENOUGH
10225: ADI CLSVI ELSE RECOMPUTE AVAILABLE
10226: BRN EXINT AND EXIT WITH INTEGER RESULT
10227: EJC
10228: *
10229: * CONVERT
10230: *
10231: S$CNV ENT ENTRY POINT
10232: JSR GTSTG CONVERT SECOND ARGUMENT TO STRING
10233: ERR 074,CONVERT SECOND ARGUMENT IS NOT STRING
10234: .IF .CULC
10235: JSR FLSTG FOLD LOWER CASE TO UPPER CASE
10236: .FI
10237: MOV (XS),XL LOAD FIRST ARGUMENT
10238: BNE (XL),=B$PDT,SCV01 JUMP IF NOT PROGRAM DEFINED
10239: *
10240: * HERE FOR PROGRAM DEFINED DATATYPE
10241: *
10242: MOV PDDFP(XL),XL POINT TO DFBLK
10243: MOV DFNAM(XL),XL LOAD DATATYPE NAME
10244: JSR IDENT COMPARE WITH SECOND ARG
10245: PPM EXITS EXIT IF IDENT WITH ARG AS RESULT
10246: BRN EXFAL ELSE FAIL
10247: *
10248: * HERE IF NOT PROGRAM DEFINED DATATYPE
10249: *
10250: SCV01 MOV XR,-(XS) SAVE STRING ARGUMENT
10251: MOV =SVCTB,XL POINT TO TABLE OF NAMES TO COMPARE
10252: ZER WB INITIALIZE COUNTER
10253: MOV WA,WC SAVE LENGTH OF ARGUMENT STRING
10254: *
10255: * LOOP THROUGH TABLE ENTRIES
10256: *
10257: SCV02 MOV (XL)+,XR LOAD NEXT TABLE ENTRY, BUMP POINTER
10258: BZE XR,EXFAL FAIL IF ZERO MARKING END OF LIST
10259: BNE WC,SCLEN(XR),SCV05 JUMP IF WRONG LENGTH
10260: MOV XL,CNVTP ELSE STORE TABLE POINTER
10261: PLC XR POINT TO CHARS OF TABLE ENTRY
10262: MOV (XS),XL LOAD POINTER TO STRING ARGUMENT
10263: PLC XL POINT TO CHARS OF STRING ARG
10264: MOV WC,WA SET NUMBER OF CHARS TO COMPARE
10265: CMC SCV04,SCV04 COMPARE, JUMP IF NO MATCH
10266: EJC
10267: *
10268: * CONVERT (CONTINUED)
10269: *
10270: * HERE WE HAVE A MATCH
10271: *
10272: SCV03 MOV WB,XL COPY ENTRY NUMBER
10273: ICA XS POP STRING ARG OFF STACK
10274: MOV (XS)+,XR LOAD FIRST ARGUMENT
10275: BSW XL,CNVTT JUMP TO APPROPRIATE ROUTINE
10276: IFF 0,SCV06 STRING
10277: IFF 1,SCV07 INTEGER
10278: IFF 2,SCV09 NAME
10279: IFF 3,SCV10 PATTERN
10280: IFF 4,SCV11 ARRAY
10281: IFF 5,SCV19 TABLE
10282: IFF 6,SCV25 EXPRESSION
10283: IFF 7,SCV26 CODE
10284: IFF 8,SCV27 NUMERIC
10285: .IF .CNRA
10286: .ELSE
10287: IFF CNVRT,SCV08 REAL
10288: .FI
10289: .IF .CNBF
10290: .ELSE
10291: IFF CNVBT,SCV28 BUFFER
10292: .FI
10293: ESW END OF SWITCH TABLE
10294: *
10295: * HERE IF NO MATCH WITH TABLE ENTRY
10296: *
10297: SCV04 MOV CNVTP,XL RESTORE TABLE POINTER, MERGE
10298: *
10299: * MERGE HERE IF LENGTHS DID NOT MATCH
10300: *
10301: SCV05 ICV WB BUMP ENTRY NUMBER
10302: BRN SCV02 LOOP BACK TO CHECK NEXT ENTRY
10303: *
10304: * HERE TO CONVERT TO STRING
10305: *
10306: SCV06 MOV XR,-(XS) REPLACE STRING ARGUMENT ON STACK
10307: JSR GTSTG CONVERT TO STRING
10308: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
10309: BRN EXIXR ELSE RETURN STRING
10310: EJC
10311: *
10312: * CONVERT (CONTINUED)
10313: *
10314: * HERE TO CONVERT TO INTEGER
10315: *
10316: SCV07 JSR GTINT CONVERT TO INTEGER
10317: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
10318: BRN EXIXR ELSE RETURN INTEGER
10319: .IF .CNRA
10320: .ELSE
10321: *
10322: * HERE TO CONVERT TO REAL
10323: *
10324: SCV08 JSR GTREA CONVERT TO REAL
10325: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
10326: BRN EXIXR ELSE RETURN REAL
10327: .FI
10328: *
10329: * HERE TO CONVERT TO NAME
10330: *
10331: SCV09 BEQ (XR),=B$NML,EXIXR RETURN IF ALREADY A NAME
10332: JSR GTNVR ELSE TRY STRING TO NAME CONVERT
10333: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
10334: BRN EXVNM ELSE EXIT BUILDING NMBLK FOR VRBLK
10335: *
10336: * HERE TO CONVERT TO PATTERN
10337: *
10338: SCV10 JSR GTPAT CONVERT TO PATTERN
10339: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
10340: BRN EXIXR ELSE RETURN PATTERN
10341: *
10342: * CONVERT TO ARRAY
10343: *
10344: SCV11 JSR GTARR GET AN ARRAY
10345: PPM EXFAL FAIL IF NOT CONVERTIBLE
10346: BRN EXSID EXIT SETTING ID FIELD
10347: *
10348: * CONVERT TO TABLE
10349: *
10350: SCV19 MOV (XR),WA LOAD FIRST WORD OF BLOCK
10351: MOV XR,-(XS) REPLACE ARBLK POINTER ON STACK
10352: BEQ WA,=B$TBT,EXITS RETURN ARG IF ALREADY A TABLE
10353: BNE WA,=B$ART,EXFAL ELSE FAIL IF NOT AN ARRAY
10354: EJC
10355: *
10356: * CONVERT (CONTINUED)
10357: *
10358: * HERE TO CONVERT AN ARRAY TO TABLE
10359: *
10360: BNE ARNDM(XR),=NUM02,EXFAL FAIL IF NOT 2-DIM ARRAY
10361: LDI ARDM2(XR) LOAD DIM 2
10362: SBI INTV2 SUBTRACT 2 TO COMPARE
10363: INE EXFAL FAIL IF DIM2 NOT 2
10364: *
10365: * HERE WE HAVE AN ARBLK OF THE RIGHT SHAPE
10366: *
10367: LDI ARDIM(XR) LOAD DIM 1 (NUMBER OF ELEMENTS)
10368: MFI WA GET AS ONE WORD INTEGER
10369: LCT WB,WA COPY TO CONTROL LOOP
10370: ADD =TBSI$,WA ADD SPACE FOR STANDARD FIELDS
10371: WTB WA CONVERT LENGTH TO BYTES
10372: JSR ALLOC ALLOCATE SPACE FOR TBBLK
10373: MOV XR,WC COPY TBBLK POINTER
10374: MOV XR,-(XS) SAVE TBBLK POINTER
10375: MOV =B$TBT,(XR)+ STORE TYPE WORD
10376: ZER (XR)+ STORE ZERO FOR IDVAL FOR NOW
10377: MOV WA,(XR)+ STORE LENGTH
10378: MOV =NULLS,(XR)+ NULL INITIAL LOOKUP VALUE
10379: *
10380: * LOOP TO INITIALIZE BUCKET PTRS TO POINT TO TABLE
10381: *
10382: SCV20 MOV WC,(XR)+ SET BUCKET PTR TO POINT TO TBBLK
10383: BCT WB,SCV20 LOOP TILL ALL INITIALIZED
10384: MOV *ARVL2,WB SET OFFSET TO FIRST ARBLK ELEMENT
10385: *
10386: * LOOP TO COPY ELEMENTS FROM ARRAY TO TABLE
10387: *
10388: SCV21 MOV 1(XS),XL POINT TO ARBLK
10389: BEQ WB,ARLEN(XL),SCV24 JUMP IF ALL MOVED
10390: ADD WB,XL ELSE POINT TO CURRENT LOCATION
10391: ADD *NUM02,WB BUMP OFFSET
10392: MOV (XL),XR LOAD SUBSCRIPT NAME
10393: DCA XL ADJUST PTR TO MERGE (TRVAL=1+1)
10394: EJC
10395: *
10396: * CONVERT (CONTINUED)
10397: *
10398: * LOOP TO CHASE DOWN TRBLK CHAIN FOR VALUE
10399: *
10400: SCV22 MOV TRVAL(XL),XL POINT TO NEXT VALUE
10401: BEQ (XL),=B$TRT,SCV22 LOOP BACK IF TRAPPED
10402: *
10403: * HERE WITH NAME IN XR, VALUE IN XL
10404: *
10405: SCV23 MOV XL,-(XS) STACK VALUE
10406: MOV 1(XS),XL LOAD TBBLK POINTER
10407: JSR TFIND BUILD TEBLK (NOTE WB GT 0 BY NAME)
10408: PPM EXFAL FAIL IF ACESS FAILS
10409: MOV (XS)+,TEVAL(XL) STORE VALUE IN TEBLK
10410: BRN SCV21 LOOP BACK FOR NEXT ELEMENT
10411: *
10412: * HERE AFTER MOVING ALL ELEMENTS TO TBBLK
10413: *
10414: SCV24 MOV (XS)+,XR LOAD TBBLK POINTER
10415: ICA XS POP ARBLK POINTER
10416: BRN EXSID EXIT SETTING IDVAL
10417: *
10418: * CONVERT TO EXPRESSION
10419: *
10420: SCV25 JSR GTEXP CONVERT TO EXPRESSION
10421: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
10422: BRN EXIXR ELSE RETURN EXPRESSION
10423: *
10424: * CONVERT TO CODE
10425: *
10426: SCV26 JSR GTCOD CONVERT TO CODE
10427: PPM EXFAL FAIL IF CONVERSION IS NOT POSSIBLE
10428: BRN EXIXR ELSE RETURN CODE
10429: *
10430: * CONVERT TO NUMERIC
10431: *
10432: SCV27 JSR GTNUM CONVERT TO NUMERIC
10433: PPM EXFAL FAIL IF UNCONVERTIBLE
10434: BRN EXIXR RETURN NUMBER
10435: EJC
10436: .IF .CNBF
10437: .ELSE
10438: *
10439: * CONVERT TO BUFFER
10440: *
10441: SCV28 MOV XR,-(XS) STACK STRING FOR PROCEDURE
10442: JSR GTSTG CONVERT TO STRING
10443: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
10444: MOV XR,XL SAVE STRING POINTER
10445: JSR ALOBF ALLOCATE BUFFER OF SAME SIZE
10446: JSR APNDB COPY IN THE STRING
10447: PPM ALREADY STRING - CANT FAIL TO CNV
10448: PPM MUST BE ENOUGH ROOM
10449: BRN EXSID EXIT SETTING IDVAL FIELD
10450: EJC
10451: .FI
10452: *
10453: * COPY
10454: *
10455: S$COP ENT ENTRY POINT
10456: JSR COPYB COPY THE BLOCK
10457: PPM EXITS RETURN IF NO IDVAL FIELD
10458: BRN EXSID EXIT SETTING ID VALUE
10459: EJC
10460: *
10461: * DATA
10462: *
10463: S$DAT ENT ENTRY POINT
10464: JSR XSCNI PREPARE TO SCAN ARGUMENT
10465: ERR 075,DATA ARGUMENT IS NOT STRING
10466: ERR 076,DATA ARGUMENT IS NULL
10467: *
10468: * SCAN OUT DATATYPE NAME
10469: *
10470: MOV =CH$PP,WC DELIMITER ONE = LEFT PAREN
10471: MOV WC,XL DELIMITER TWO = LEFT PAREN
10472: JSR XSCAN SCAN DATATYPE NAME
10473: BNZ WA,SDAT1 SKIP IF LEFT PAREN FOUND
10474: ERB 077,DATA ARGUMENT IS MISSING A LEFT PAREN
10475: *
10476: * HERE AFTER SCANNING DATATYPE NAME
10477: *
10478: .IF .CULC
10479: SDAT1 MOV SCLEN(XR),WA GET LENGTH
10480: JSR FLSTG FOLD LOWER CASE TO UPPER CASE
10481: MOV XR,XL SAVE NAME PTR
10482: .ELSE
10483: SDAT1 MOV XR,XL SAVE NAME PTR
10484: .FI
10485: MOV SCLEN(XR),WA GET LENGTH
10486: CTB WA,SCSI$ COMPUTE SPACE NEEDED
10487: JSR ALOST REQUEST STATIC STORE FOR NAME
10488: MOV XR,-(XS) SAVE DATATYPE NAME
10489: MVW COPY NAME TO STATIC
10490: MOV (XS),XR GET NAME PTR
10491: ZER XL SCRUB DUD REGISTER
10492: JSR GTNVR LOCATE VRBLK FOR DATATYPE NAME
10493: ERR 078,DATA ARGUMENT HAS NULL DATATYPE NAME
10494: MOV XR,DATDV SAVE VRBLK POINTER FOR DATATYPE
10495: MOV XS,DATXS STORE STARTING STACK VALUE
10496: ZER WB ZERO COUNT OF FIELD NAMES
10497: *
10498: * LOOP TO SCAN FIELD NAMES AND STACK VRBLK POINTERS
10499: *
10500: SDAT2 MOV =CH$RP,WC DELIMITER ONE = RIGHT PAREN
10501: MOV =CH$CM,XL DELIMITER TWO = COMMA
10502: JSR XSCAN SCAN NEXT FIELD NAME
10503: BNZ WA,SDAT3 JUMP IF DELIMITER FOUND
10504: ERB 079,DATA ARGUMENT IS MISSING A RIGHT PAREN
10505: *
10506: * HERE AFTER SCANNING OUT ONE FIELD NAME
10507: *
10508: SDAT3 JSR GTNVR LOCATE VRBLK FOR FIELD NAME
10509: ERR 080,DATA ARGUMENT HAS NULL FIELD NAME
10510: MOV XR,-(XS) STACK VRBLK POINTER
10511: ICV WB INCREMENT COUNTER
10512: BEQ WA,=NUM02,SDAT2 LOOP BACK IF STOPPED BY COMMA
10513: EJC
10514: *
10515: * DATA (CONTINUED)
10516: *
10517: * NOW BUILD THE DFBLK
10518: *
10519: MOV =DFSI$,WA SET SIZE OF DFBLK STANDARD FIELDS
10520: ADD WB,WA ADD NUMBER OF FIELDS
10521: WTB WA CONVERT LENGTH TO BYTES
10522: MOV WB,WC PRESERVE NO. OF FIELDS
10523: JSR ALOST ALLOCATE SPACE FOR DFBLK
10524: MOV WC,WB GET NO OF FIELDS
10525: MOV DATXS,XT POINT TO START OF STACK
10526: MOV (XT),WC LOAD DATATYPE NAME
10527: MOV XR,(XT) SAVE DFBLK POINTER ON STACK
10528: MOV =B$DFC,(XR)+ STORE TYPE WORD
10529: MOV WB,(XR)+ STORE NUMBER OF FIELDS (FARGS)
10530: MOV WA,(XR)+ STORE LENGTH (DFLEN)
10531: SUB *PDDFS,WA COMPUTE PDBLK LENGTH (FOR DFPDL)
10532: MOV WA,(XR)+ STORE PDBLK LENGTH (DFPDL)
10533: MOV WC,(XR)+ STORE DATATYPE NAME (DFNAM)
10534: LCT WC,WB COPY NUMBER OF FIELDS
10535: *
10536: * LOOP TO MOVE FIELD NAME VRBLK POINTERS TO DFBLK
10537: *
10538: SDAT4 MOV -(XT),(XR)+ MOVE ONE FIELD NAME VRBLK POINTER
10539: BCT WC,SDAT4 LOOP TILL ALL MOVED
10540: *
10541: * NOW DEFINE THE DATATYPE FUNCTION
10542: *
10543: MOV WA,WC COPY LENGTH OF PDBLK FOR LATER LOOP
10544: MOV DATDV,XR POINT TO VRBLK
10545: MOV DATXS,XT POINT BACK ON STACK
10546: MOV (XT),XL LOAD DFBLK POINTER
10547: JSR DFFNC DEFINE FUNCTION
10548: EJC
10549: *
10550: * DATA (CONTINUED)
10551: *
10552: * LOOP TO BUILD FFBLKS
10553: *
10554: *
10555: * NOTICE THAT THE FFBLKS ARE CONSTRUCTED IN REVERSE ORDER
10556: * SO THAT THE REQUIRED OFFSETS CAN BE OBTAINED FROM
10557: * SUCCESSIVE DECREMENTATION OF THE PDBLK LENGTH (IN WC).
10558: *
10559: SDAT5 MOV *FFSI$,WA SET LENGTH OF FFBLK
10560: JSR ALLOC ALLOCATE SPACE FOR FFBLK
10561: MOV =B$FFC,(XR) SET TYPE WORD
10562: MOV =NUM01,FARGS(XR) STORE FARGS (ALWAYS ONE)
10563: MOV DATXS,XT POINT BACK ON STACK
10564: MOV (XT),FFDFP(XR) COPY DFBLK PTR TO FFBLK
10565: DCA WC DECREMENT OLD DFPDL TO GET NEXT OFS
10566: MOV WC,FFOFS(XR) SET OFFSET TO THIS FIELD
10567: ZER FFNXT(XR) TENTATIVELY SET ZERO FORWARD PTR
10568: MOV XR,XL COPY FFBLK POINTER FOR DFFNC
10569: MOV (XS),XR LOAD VRBLK POINTER FOR FIELD
10570: MOV VRFNC(XR),XR LOAD CURRENT FUNCTION POINTER
10571: BNE (XR),=B$FFC,SDAT6 SKIP IF NOT CURRENTLY A FIELD FUNC
10572: *
10573: * HERE WE MUST CHAIN AN OLD FFBLK PTR TO PRESERVE IT IN THE
10574: * CASE OF MULTIPLE FIELD FUNCTIONS WITH THE SAME NAME
10575: *
10576: MOV XR,FFNXT(XL) LINK NEW FFBLK TO PREVIOUS CHAIN
10577: *
10578: * MERGE HERE TO DEFINE FIELD FUNCTION
10579: *
10580: SDAT6 MOV (XS)+,XR LOAD VRBLK POINTER
10581: JSR DFFNC DEFINE FIELD FUNCTION
10582: BNE XS,DATXS,SDAT5 LOOP BACK TILL ALL DONE
10583: ICA XS POP DFBLK POINTER
10584: BRN EXNUL RETURN WITH NULL RESULT
10585: EJC
10586: *
10587: * DATATYPE
10588: *
10589: S$DTP ENT ENTRY POINT
10590: MOV (XS)+,XR LOAD ARGUMENT
10591: JSR DTYPE GET DATATYPE
10592: BRN EXIXR AND RETURN IT AS RESULT
10593: EJC
10594: *
10595: * DATE
10596: *
10597: S$DTE ENT ENTRY POINT
10598: JSR SYSDT CALL SYSTEM DATE ROUTINE
10599: MOV 1(XL),WA LOAD LENGTH FOR SBSTR
10600: BZE WA,EXNUL RETURN NULL IF LENGTH IS ZERO
10601: ZER WB SET ZERO OFFSET
10602: JSR SBSTR USE SBSTR TO BUILD SCBLK
10603: BRN EXIXR RETURN DATE STRING
10604: EJC
10605: *
10606: * DEFINE
10607: *
10608: S$DEF ENT ENTRY POINT
10609: MOV (XS)+,XR LOAD SECOND ARGUMENT
10610: ZER DEFLB ZERO LABEL POINTER IN CASE NULL
10611: BEQ XR,=NULLS,SDF01 JUMP IF NULL SECOND ARGUMENT
10612: JSR GTNVR ELSE FIND VRBLK FOR LABEL
10613: PPM SDF13 JUMP IF NOT A VARIABLE NAME
10614: MOV XR,DEFLB ELSE SET SPECIFIED ENTRY
10615: *
10616: * SCAN FUNCTION NAME
10617: *
10618: SDF01 JSR XSCNI PREPARE TO SCAN FIRST ARGUMENT
10619: ERR 081,DEFINE FIRST ARGUMENT IS NOT STRING
10620: ERR 082,DEFINE FIRST ARGUMENT IS NULL
10621: MOV =CH$PP,WC DELIMITER ONE = LEFT PAREN
10622: MOV WC,XL DELIMITER TWO = LEFT PAREN
10623: JSR XSCAN SCAN OUT FUNCTION NAME
10624: BNZ WA,SDF02 JUMP IF LEFT PAREN FOUND
10625: ERB 083,DEFINE FIRST ARGUMENT IS MISSING A LEFT PAREN
10626: *
10627: * HERE AFTER SCANNING OUT FUNCTION NAME
10628: *
10629: SDF02 JSR GTNVR GET VARIABLE NAME
10630: ERR 084,DEFINE FIRST ARGUMENT HAS NULL FUNCTION NAME
10631: MOV XR,DEFVR SAVE VRBLK POINTER FOR FUNCTION NAM
10632: ZER WB ZERO COUNT OF ARGUMENTS
10633: MOV XS,DEFXS SAVE INITIAL STACK POINTER
10634: BNZ DEFLB,SDF03 JUMP IF SECOND ARGUMENT GIVEN
10635: MOV XR,DEFLB ELSE DEFAULT IS FUNCTION NAME
10636: *
10637: * LOOP TO SCAN ARGUMENT NAMES AND STACK VRBLK POINTERS
10638: *
10639: SDF03 MOV =CH$RP,WC DELIMITER ONE = RIGHT PAREN
10640: MOV =CH$CM,XL DELIMITER TWO = COMMA
10641: JSR XSCAN SCAN OUT NEXT ARGUMENT NAME
10642: BNZ WA,SDF04 SKIP IF DELIMITER FOUND
10643: ERB 085,NULL ARG NAME OR MISSING ) IN DEFINE FIRST ARG.
10644: EJC
10645: *
10646: * DEFINE (CONTINUED)
10647: *
10648: * HERE AFTER SCANNING AN ARGUMENT NAME
10649: *
10650: SDF04 BNE XR,=NULLS,SDF05 SKIP IF NON-NULL
10651: BZE WB,SDF06 IGNORE NULL IF CASE OF NO ARGUMENTS
10652: *
10653: * HERE AFTER DEALING WITH THE CASE OF NO ARGUMENTS
10654: *
10655: SDF05 JSR GTNVR GET VRBLK POINTER
10656: PPM SDF03 LOOP BACK TO IGNORE NULL NAME
10657: MOV XR,-(XS) STACK ARGUMENT VRBLK POINTER
10658: ICV WB INCREMENT COUNTER
10659: BEQ WA,=NUM02,SDF03 LOOP BACK IF STOPPED BY A COMMA
10660: *
10661: * HERE AFTER SCANNING OUT FUNCTION ARGUMENT NAMES
10662: *
10663: SDF06 MOV WB,DEFNA SAVE NUMBER OF ARGUMENTS
10664: ZER WB ZERO COUNT OF LOCALS
10665: *
10666: * LOOP TO SCAN LOCAL NAMES AND STACK VRBLK POINTERS
10667: *
10668: SDF07 MOV =CH$CM,WC SET DELIMITER ONE = COMMA
10669: MOV WC,XL SET DELIMITER TWO = COMMA
10670: JSR XSCAN SCAN OUT NEXT LOCAL NAME
10671: BNE XR,=NULLS,SDF08 SKIP IF NON-NULL
10672: BZE WB,SDF09 IGNORE NULL IF CASE OF NO LOCALS
10673: *
10674: * HERE AFTER SCANNING OUT A LOCAL NAME
10675: *
10676: SDF08 JSR GTNVR GET VRBLK POINTER
10677: PPM SDF07 LOOP BACK TO IGNORE NULL NAME
10678: ICV WB IF OK, INCREMENT COUNT
10679: MOV XR,-(XS) STACK VRBLK POINTER
10680: BNZ WA,SDF07 LOOP BACK IF STOPPED BY A COMMA
10681: EJC
10682: *
10683: * DEFINE (CONTINUED)
10684: *
10685: * HERE AFTER SCANNING LOCALS, BUILD PFBLK
10686: *
10687: SDF09 MOV WB,WA COPY COUNT OF LOCALS
10688: ADD DEFNA,WA ADD NUMBER OF ARGUMENTS
10689: MOV WA,WC SET SUM ARGS+LOCALS AS LOOP COUNT
10690: ADD =PFSI$,WA ADD SPACE FOR STANDARD FIELDS
10691: WTB WA CONVERT LENGTH TO BYTES
10692: JSR ALLOC ALLOCATE SPACE FOR PFBLK
10693: MOV XR,XL SAVE POINTER TO PFBLK
10694: MOV =B$PFC,(XR)+ STORE FIRST WORD
10695: MOV DEFNA,(XR)+ STORE NUMBER OF ARGUMENTS
10696: MOV WA,(XR)+ STORE LENGTH (PFLEN)
10697: MOV DEFVR,(XR)+ STORE VRBLK PTR FOR FUNCTION NAME
10698: MOV WB,(XR)+ STORE NUMBER OF LOCALS
10699: ZER (XR)+ DEAL WITH LABEL LATER
10700: ZER (XR)+ ZERO PFCTR
10701: ZER (XR)+ ZERO PFRTR
10702: BZE WC,SDF11 SKIP IF NO ARGS OR LOCALS
10703: MOV XL,WA KEEP PFBLK POINTER
10704: MOV DEFXS,XT POINT BEFORE ARGUMENTS
10705: LCT WC,WC GET COUNT OF ARGS+LOCALS FOR LOOP
10706: *
10707: * LOOP TO MOVE LOCALS AND ARGS TO PFBLK
10708: *
10709: SDF10 MOV -(XT),(XR)+ STORE ONE ENTRY AND BUMP POINTERS
10710: BCT WC,SDF10 LOOP TILL ALL STORED
10711: MOV WA,XL RECOVER PFBLK POINTER
10712: EJC
10713: *
10714: * DEFINE (CONTINUED)
10715: *
10716: * NOW DEAL WITH LABEL
10717: *
10718: SDF11 MOV DEFXS,XS POP STACK
10719: MOV DEFLB,XR POINT TO VRBLK FOR LABEL
10720: MOV VRLBL(XR),XR LOAD LABEL POINTER
10721: BNE (XR),=B$TRT,SDF12 SKIP IF NOT TRAPPED
10722: MOV TRLBL(XR),XR ELSE POINT TO REAL LABEL
10723: *
10724: * HERE AFTER LOCATING REAL LABEL POINTER
10725: *
10726: SDF12 BEQ XR,=STNDL,SDF13 JUMP IF LABEL IS NOT DEFINED
10727: MOV XR,PFCOD(XL) ELSE STORE LABEL POINTER
10728: MOV DEFVR,XR POINT BACK TO VRBLK FOR FUNCTION
10729: JSR DFFNC DEFINE FUNCTION
10730: BRN EXNUL AND EXIT RETURNING NULL
10731: *
10732: * HERE FOR ERRONEOUS LABEL
10733: *
10734: SDF13 ERB 086,DEFINE FUNCTION ENTRY POINT IS NOT DEFINED LABEL
10735: EJC
10736: *
10737: * DETACH
10738: *
10739: S$DET ENT ENTRY POINT
10740: MOV (XS)+,XR LOAD ARGUMENT
10741: JSR GTVAR LOCATE VARIABLE
10742: ERR 087,DETACH ARGUMENT IS NOT APPROPRIATE NAME
10743: JSR DTACH DETACH I/O ASSOCIATION FROM NAME
10744: BRN EXNUL RETURN NULL RESULT
10745: EJC
10746: *
10747: * DIFFER
10748: *
10749: S$DIF ENT ENTRY POINT
10750: MOV (XS)+,XR LOAD SECOND ARGUMENT
10751: MOV (XS)+,XL LOAD FIRST ARGUMENT
10752: JSR IDENT CALL IDENT COMPARISON ROUTINE
10753: PPM EXFAL FAIL IF IDENT
10754: BRN EXNUL RETURN NULL IF DIFFER
10755: EJC
10756: *
10757: * DUMP
10758: *
10759: S$DMP ENT ENTRY POINT
10760: JSR GTSMI LOAD DUMP ARG AS SMALL INTEGER
10761: ERR 088,DUMP ARGUMENT IS NOT INTEGER
10762: ERR 089,DUMP ARGUMENT IS NEGATIVE OR TOO LARGE
10763: JSR DUMPR ELSE CALL DUMP ROUTINE
10764: BRN EXNUL AND RETURN NULL AS RESULT
10765: EJC
10766: *
10767: * DUPL
10768: *
10769: S$DUP ENT ENTRY POINT
10770: JSR GTSMI GET SECOND ARGUMENT AS SMALL INTEGE
10771: ERR 090,DUPL SECOND ARGUMENT IS NOT INTEGER
10772: PPM SDUP7 JUMP IF NEGATIVE OT TOO BIG
10773: MOV XR,WB SAVE DUPLICATION FACTOR
10774: JSR GTSTG GET FIRST ARG AS STRING
10775: PPM SDUP4 JUMP IF NOT A STRING
10776: *
10777: * HERE FOR CASE OF DUPLICATION OF A STRING
10778: *
10779: MTI WA ACQUIRE LENGTH AS INTEGER
10780: STI DUPSI SAVE FOR THE MOMENT
10781: MTI WB GET DUPLICATION FACTOR AS INTEGER
10782: MLI DUPSI FORM PRODUCT
10783: IOV SDUP3 JUMP IF OVERFLOW
10784: IEQ EXNUL RETURN NULL IF RESULT LENGTH = 0
10785: MFI WA,SDUP3 GET AS ADDR INTEGER, CHECK OVFLO
10786: *
10787: * MERGE HERE WITH RESULT LENGTH IN WA
10788: *
10789: SDUP1 MOV XR,XL SAVE STRING POINTER
10790: JSR ALOCS ALLOCATE SPACE FOR STRING
10791: MOV XR,-(XS) SAVE AS RESULT POINTER
10792: MOV XL,WC SAVE POINTER TO ARGUMENT STRING
10793: PSC XR PREPARE TO STORE CHARS OF RESULT
10794: LCT WB,WB SET COUNTER TO CONTROL LOOP
10795: *
10796: * LOOP THROUGH DUPLICATIONS
10797: *
10798: SDUP2 MOV WC,XL POINT BACK TO ARGUMENT STRING
10799: MOV SCLEN(XL),WA GET NUMBER OF CHARACTERS
10800: PLC XL POINT TO CHARS IN ARGUMENT STRING
10801: MVC MOVE CHARACTERS TO RESULT STRING
10802: BCT WB,SDUP2 LOOP TILL ALL DUPLICATIONS DONE
10803: BRN EXITS THEN EXIT FOR NEXT CODE WORD
10804: EJC
10805: *
10806: * DUPL (CONTINUED)
10807: *
10808: * HERE IF TOO LARGE, SET MAX LENGTH AND LET ALOCS CATCH IT
10809: *
10810: SDUP3 MOV DNAME,WA SET IMPOSSIBLE LENGTH FOR ALOCS
10811: BRN SDUP1 MERGE BACK
10812: *
10813: * HERE IF NOT A STRING
10814: *
10815: SDUP4 JSR GTPAT CONVERT ARGUMENT TO PATTERN
10816: ERR 091,DUPL FIRST ARGUMENT IS NOT STRING OR PATTERN
10817: *
10818: * HERE TO DUPLICATE A PATTERN ARGUMENT
10819: *
10820: MOV XR,-(XS) STORE PATTERN ON STACK
10821: MOV =NDNTH,XR START OFF WITH NULL PATTERN
10822: BZE WB,SDUP6 NULL PATTERN IS RESULT IF DUPFAC=0
10823: MOV WB,-(XS) PRESERVE LOOP COUNT
10824: *
10825: * LOOP TO DUPLICATE BY SUCCESSIVE CONCATENATION
10826: *
10827: SDUP5 MOV XR,XL COPY CURRENT VALUE AS RIGHT ARGUMNT
10828: MOV 1(XS),XR GET A NEW COPY OF LEFT
10829: JSR PCONC CONCATENATE
10830: DCV (XS) COUNT DOWN
10831: BNZ (XS),SDUP5 LOOP
10832: ICA XS POP LOOP COUNT
10833: *
10834: * HERE TO EXIT AFTER CONSTRUCTING PATTERN
10835: *
10836: SDUP6 MOV XR,(XS) STORE RESULT ON STACK
10837: BRN EXITS EXIT WITH RESULT ON STACK
10838: *
10839: * FAIL IF SECOND ARG IS OUT OF RANGE
10840: *
10841: SDUP7 ICA XS POP FIRST ARGUMENT
10842: BRN EXFAL FAIL
10843: EJC
10844: *
10845: * EJECT
10846: *
10847: S$EJC ENT ENTRY POINT
10848: JSR IOFCB CALL FCBLK ROUTINE
10849: ERR 092,EJECT ARGUMENT IS NOT A SUITABLE NAME
10850: PPM SEJC1 NULL ARGUMENT
10851: JSR SYSEF CALL EJECT FILE FUNCTION
10852: ERR 093,EJECT FILE DOES NOT EXIST
10853: ERR 094,EJECT FILE DOES NOT PERMIT PAGE EJECT
10854: ERR 095,EJECT CAUSED NON-RECOVERABLE OUTPUT ERROR
10855: BRN EXNUL RETURN NULL AS RESULT
10856: *
10857: * HERE TO EJECT STANDARD OUTPUT FILE
10858: *
10859: SEJC1 JSR SYSEP CALL ROUTINE TO EJECT PRINTER
10860: BRN EXNUL EXIT WITH NULL RESULT
10861: EJC
10862: *
10863: * ENDFILE
10864: *
10865: S$ENF ENT ENTRY POINT
10866: JSR IOFCB CALL FCBLK ROUTINE
10867: ERR 096,ENDFILE ARGUMENT IS NOT A SUITABLE NAME
10868: ERR 097,ENDFILE ARGUMENT IS NULL
10869: JSR SYSEN CALL ENDFILE ROUTINE
10870: ERR 098,ENDFILE FILE DOES NOT EXIST
10871: ERR 099,ENDFILE FILE DOES NOT PERMIT ENDFILE
10872: ERR 100,ENDFILE CAUSED NON-RECOVERABLE OUTPUT ERROR
10873: MOV XL,WB REMEMBER VRBLK PTR FROM IOFCB CALL
10874: *
10875: * LOOP TO FIND TRTRF BLOCK
10876: *
10877: SENF1 MOV XL,XR COPY POINTER
10878: MOV TRVAL(XR),XR CHAIN ALONG
10879: BNE (XR),=B$TRT,EXNUL SKIP OUT IF CHAIN END
10880: BNE TRTYP(XR),=TRTFC,SENF1 LOOP IF NOT FOUND
10881: MOV TRVAL(XR),TRVAL(XL) REMOVE TRTRF
10882: MOV TRTRF(XR),ENFCH POINT TO HEAD OF IOCHN
10883: MOV TRFPT(XR),WC POINT TO FCBLK
10884: MOV WB,XR FILEARG1 VRBLK FROM IOFCB
10885: JSR SETVR RESET IT
10886: MOV =R$FCB,XL PTR TO HEAD OF FCBLK CHAIN
10887: SUB *NUM02,XL ADJUST READY TO ENTER LOOP
10888: *
10889: * FIND FCBLK
10890: *
10891: SENF2 MOV XL,XR COPY PTR
10892: MOV 2(XL),XL GET NEXT LINK
10893: BZE XL,SENF4 STOP IF CHAIN END
10894: BEQ 3(XL),WC,SENF3 JUMP IF FCBLK FOUND
10895: BRN SENF2 LOOP
10896: *
10897: * REMOVE FCBLK
10898: *
10899: SENF3 MOV 2(XL),2(XR) DELETE FCBLK FROM CHAIN
10900: *
10901: * LOOP WHICH DETACHES ALL VBLS ON IOCHN CHAIN
10902: *
10903: SENF4 MOV ENFCH,XL GET CHAIN HEAD
10904: BZE XL,EXNUL FINISHED IF CHAIN END
10905: MOV TRTRF(XL),ENFCH CHAIN ALONG
10906: MOV IONMO(XL),WA NAME OFFSET
10907: MOV IONMB(XL),XL NAME BASE
10908: JSR DTACH DETACH NAME
10909: BRN SENF4 LOOP TILL DONE
10910: EJC
10911: *
10912: * EQ
10913: *
10914: S$EQF ENT ENTRY POINT
10915: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
10916: ERR 101,EQ FIRST ARGUMENT IS NOT NUMERIC
10917: ERR 102,EQ SECOND ARGUMENT IS NOT NUMERIC
10918: PPM EXFAL FAIL IF LT
10919: PPM EXNUL RETURN NULL IF EQ
10920: PPM EXFAL FAIL IF GT
10921: EJC
10922: *
10923: * EVAL
10924: *
10925: S$EVL ENT ENTRY POINT
10926: MOV (XS)+,XR LOAD ARGUMENT
10927: JSR GTEXP CONVERT TO EXPRESSION
10928: ERR 103,EVAL ARGUMENT IS NOT EXPRESSION
10929: LCW WC LOAD NEXT CODE WORD
10930: BNE WC,=OFNE$,SEVL1 JUMP IF CALLED BY VALUE
10931: SCP XL COPY CODE POINTER
10932: MOV (XL),WA GET NEXT CODE WORD
10933: BNE WA,=ORNM$,SEVL2 BY NAME UNLESS EXPRESSION
10934: BNZ 1(XS),SEVL2 JUMP IF BY NAME
10935: *
10936: * HERE IF CALLED BY VALUE
10937: *
10938: SEVL1 ZER WB SET FLAG FOR BY VALUE
10939: MOV WC,-(XS) SAVE CODE WORD
10940: JSR EVALX EVALUATE EXPRESSION BY VALUE
10941: PPM EXFAL FAIL IF EVALUATION FAILS
10942: MOV XR,XL COPY RESULT
10943: MOV (XS),XR RELOAD NEXT CODE WORD
10944: MOV XL,(XS) STACK RESULT
10945: BRI (XR) JUMP TO EXECUTE NEXT CODE WORD
10946: *
10947: * HERE IF CALLED BY NAME
10948: *
10949: SEVL2 MOV =NUM01,WB SET FLAG FOR BY NAME
10950: JSR EVALX EVALUATE EXPRESSION BY NAME
10951: PPM EXFAL FAIL IF EVALUATION FAILS
10952: BRN EXNAM EXIT WITH NAME
10953: .IF .CNEX
10954: .ELSE
10955: EJC
10956: *
10957: * EXIT
10958: *
10959: S$EXT ENT ENTRY POINT
10960: ZER WB CLEAR AMOUNT OF STATIC SHIFT
10961: JSR GBCOL COMPACT MEMORY BY COLLECTING
10962: JSR GTSTG CONVERT ARG TO STRING
10963: ERR 104,EXIT ARGUMENT IS NOT SUITABLE INTEGER OR STRING
10964: MOV XR,XL COPY STRING PTR
10965: JSR GTINT CHECK IT IS INTEGER
10966: PPM SEXT1 SKIP IF UNCONVERTIBLE
10967: ZER XL NOTE IT IS INTEGER
10968: LDI ICVAL(XR) GET INTEGER ARG
10969: MOV R$FCB,WB GET FCBLK CHAIN HEADER
10970: *
10971: * MERGE TO CALL OSINT EXIT ROUTINE
10972: *
10973: SEXT1 MOV =HEADV,XR POINT TO V.V STRING
10974: JSR SYSXI CALL EXTERNAL ROUTINE
10975: ERR 105,EXIT ACTION NOT AVAILABLE IN THIS IMPLEMENTATION
10976: ERR 106,EXIT ACTION CAUSED IRRECOVERABLE ERROR
10977: IEQ EXNUL RETURN IF ARGUMENT 0
10978: ZER GBCNT RESUMING EXECUTION SO RESET
10979: IGT SEXT2 SKIP IF POSITIVE
10980: NGI MAKE POSITIVE
10981: *
10982: * CHECK FOR OPTION RESPECIFICATION
10983: *
10984: SEXT2 MFI WC GET VALUE IN WORK REG
10985: BEQ WC,=NUM03,SEXT3 SKIP IF WAS 3
10986: MOV WC,-(XS) SAVE VALUE
10987: ZER WC SET TO READ OPTIONS
10988: JSR PRPAR READ SYSPP OPTIONS
10989: MOV (XS)+,WC RESTORE VALUE
10990: *
10991: * DEAL WITH HEADER OPTION (FIDDLED BY PRPAR)
10992: *
10993: SEXT3 MNZ HEADP ASSUME NO HEADERS
10994: BNE WC,=NUM01,SEXT4 SKIP IF NOT 1
10995: ZER HEADP REQUEST HEADER PRINTING
10996: *
10997: * ALMOST READY TO RESUME RUNNING
10998: *
10999: SEXT4 JSR SYSTM GET EXECUTION TIME START (SGD11)
11000: STI TIMSX SAVE AS INITIAL TIME
11001: LDI KVSTC RESET TO ENSURE ...
11002: STI KVSTL ... CORRECT EXECUTION STATS
11003: BRN EXNUL RESUME EXECUTION
11004: .FI
11005: EJC
11006: *
11007: * FIELD
11008: *
11009: S$FLD ENT ENTRY POINT
11010: JSR GTSMI GET SECOND ARGUMENT (FIELD NUMBER)
11011: ERR 107,FIELD SECOND ARGUMENT IS NOT INTEGER
11012: PPM EXFAL FAIL IF OUT OF RANGE
11013: MOV XR,WB ELSE SAVE INTEGER VALUE
11014: MOV (XS)+,XR LOAD FIRST ARGUMENT
11015: JSR GTNVR POINT TO VRBLK
11016: PPM SFLD1 JUMP (ERROR) IF NOT VARIABLE NAME
11017: MOV VRFNC(XR),XR ELSE POINT TO FUNCTION BLOCK
11018: BNE (XR),=B$DFC,SFLD1 ERROR IF NOT DATATYPE FUNCTION
11019: *
11020: * HERE IF FIRST ARGUMENT IS A DATATYPE FUNCTION NAME
11021: *
11022: BZE WB,EXFAL FAIL IF ARGUMENT NUMBER IS ZERO
11023: BGT WB,FARGS(XR),EXFAL FAIL IF TOO LARGE
11024: WTB WB ELSE CONVERT TO BYTE OFFSET
11025: ADD WB,XR POINT TO FIELD NAME
11026: MOV DFFLB(XR),XR LOAD VRBLK POINTER
11027: BRN EXVNM EXIT TO BUILD NMBLK
11028: *
11029: * HERE FOR BAD FIRST ARGUMENT
11030: *
11031: SFLD1 ERB 108,FIELD FIRST ARGUMENT IS NOT DATATYPE NAME
11032: EJC
11033: *
11034: * FENCE
11035: *
11036: S$FNC ENT ENTRY POINT
11037: MOV =P$FNC,WB SET PCODE FOR P$FNC
11038: ZER XR P0BLK
11039: JSR PBILD BUILD P$FNC NODE
11040: MOV XR,XL SAVE POINTER TO IT
11041: MOV (XS)+,XR GET ARGUMENT
11042: JSR GTPAT CONVERT TO PATTERN
11043: ERR 259,FENCE ARGUMENT IS NOT PATTERN
11044: JSR PCONC CONCATENATE TO P$FNC NODE
11045: MOV XR,XL SAVE PTR TO CONCATENATED PATTERN
11046: MOV =P$FNA,WB SET FOR P$FNA PCODE
11047: ZER XR P0BLK
11048: JSR PBILD CONSTRUCT P$FNA NODE
11049: MOV XL,PTHEN(XR) SET PATTERN AS PTHEN
11050: MOV XR,-(XS) SET AS RESULT
11051: BRN EXITS DO NEXT CODE WORD
11052: EJC
11053: *
11054: * GE
11055: *
11056: S$GEF ENT ENTRY POINT
11057: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
11058: ERR 109,GE FIRST ARGUMENT IS NOT NUMERIC
11059: ERR 110,GE SECOND ARGUMENT IS NOT NUMERIC
11060: PPM EXFAL FAIL IF LT
11061: PPM EXNUL RETURN NULL IF EQ
11062: PPM EXNUL RETURN NULL IF GT
11063: EJC
11064: *
11065: * GT
11066: *
11067: S$GTF ENT ENTRY POINT
11068: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
11069: ERR 111,GT FIRST ARGUMENT IS NOT NUMERIC
11070: ERR 112,GT SECOND ARGUMENT IS NOT NUMERIC
11071: PPM EXFAL FAIL IF LT
11072: PPM EXFAL FAIL IF EQ
11073: PPM EXNUL RETURN NULL IF GT
11074: EJC
11075: *
11076: * HOST
11077: *
11078: S$HST ENT ENTRY POINT
11079: MOV (XS)+,XR GET THIRD ARG
11080: MOV (XS)+,XL GET SECOND ARG
11081: MOV (XS)+,WA GET FIRST ARG
11082: JSR SYSHS ENTER SYSHS ROUTINE
11083: ERR 254,ERRONEOUS ARGUMENT FOR HOST
11084: ERR 255,ERROR DURING EXECUTION OF HOST
11085: PPM SHST1 STORE HOST STRING
11086: PPM EXNUL RETURN NULL RESULT
11087: PPM EXIXR RETURN XR
11088: PPM EXFAL FAIL RETURN
11089: *
11090: * RETURN HOST STRING
11091: *
11092: SHST1 BZE XL,EXNUL NULL STRING IF SYSHS UNCOOPERATIVE
11093: MOV SCLEN(XL),WA LENGTH
11094: ZER WB ZERO OFFSET
11095: JSR SBSTR BUILD COPY OF STRING
11096: MOV XR,-(XS) STACK THE RESULT
11097: BRN EXITS RETURN RESULT ON STACK
11098: EJC
11099: *
11100: * IDENT
11101: *
11102: S$IDN ENT ENTRY POINT
11103: MOV (XS)+,XR LOAD SECOND ARGUMENT
11104: MOV (XS)+,XL LOAD FIRST ARGUMENT
11105: JSR IDENT CALL IDENT COMPARISON ROUTINE
11106: PPM EXNUL RETURN NULL IF IDENT
11107: BRN EXFAL FAIL IF DIFFER
11108: EJC
11109: *
11110: * INPUT
11111: *
11112: S$INP ENT ENTRY POINT
11113: ZER WB INPUT FLAG
11114: JSR IOPUT CALL INPUT/OUTPUT ASSOC. ROUTINE
11115: ERR 113,INPUT THIRD ARGUMENT IS NOT A STRING
11116: ERR 114,INAPPROPRIATE SECOND ARGUMENT FOR INPUT
11117: ERR 115,INAPPROPRIATE FIRST ARGUMENT FOR INPUT
11118: ERR 116,INAPPROPRIATE FILE SPECIFICATION FOR INPUT
11119: PPM EXFAL FAIL IF FILE DOES NOT EXIST
11120: ERR 117,INPUT FILE CANNOT BE READ
11121: BRN EXNUL RETURN NULL STRING
11122: EJC
11123: .IF .CNBF
11124: .ELSE
11125: *
11126: * INSERT
11127: *
11128: S$INS ENT ENTRY POINT
11129: MOV (XS)+,XL GET STRING ARG
11130: JSR GTSMI GET REPLACE LENGTH
11131: ERR 277,INSERT THIRD ARGUMENT NOT INTEGER
11132: PPM EXFAL FAIL IF OUT OF RANGE
11133: MOV WC,WB COPY TO PROPER REG
11134: JSR GTSMI GET REPLACE POSITION
11135: ERR 278,INSERT SECOND ARGUMENT NOT INTEGER
11136: PPM EXFAL FAIL IF OUT OF RANGE
11137: BZE WC,EXFAL FAIL IF ZERO
11138: DCV WC DECREMENT TO GET OFFSET
11139: MOV WC,WA PUT IN PROPER REGISTER
11140: MOV (XS)+,XR GET BUFFER
11141: BEQ (XR),=B$BCT,SINS1 PRESS ON IF TYPE OK
11142: ERB 279,INSERT FIRST ARGUMENT NOT BUFFER
11143: *
11144: * HERE WHEN EVERYTHING LOADED UP
11145: *
11146: SINS1 JSR INSBF CALL TO INSERT
11147: ERR 280,INSERT FOURTH ARGUMENT NOT A STRING
11148: PPM EXFAL FAIL IF OUT OF RANGE
11149: BRN EXNUL ELSE OK - EXIT WITH NULL
11150: EJC
11151: .FI
11152: *
11153: * INTEGER
11154: *
11155: S$INT ENT ENTRY POINT
11156: MOV (XS)+,XR LOAD ARGUMENT
11157: JSR GTNUM CONVERT TO NUMERIC
11158: PPM EXFAL FAIL IF NON-NUMERIC
11159: BEQ WA,=B$ICL,EXNUL RETURN NULL IF INTEGER
11160: BRN EXFAL FAIL IF REAL
11161: EJC
11162: *
11163: * ITEM
11164: *
11165: * ITEM DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT
11166: * WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED.
11167: *
11168: S$ITM ENT ENTRY POINT
11169: *
11170: * DEAL WITH CASE OF NO ARGS
11171: *
11172: BNZ WA,SITM1 JUMP IF AT LEAST ONE ARG
11173: MOV =NULLS,-(XS) ELSE SUPPLY GARBAGE NULL ARG
11174: MOV =NUM01,WA AND FIX ARGUMENT COUNT
11175: *
11176: * CHECK FOR NAME/VALUE CASES
11177: *
11178: SITM1 SCP XR GET CURRENT CODE POINTER
11179: MOV (XR),XL LOAD NEXT CODE WORD
11180: DCV WA GET NUMBER OF SUBSCRIPTS
11181: MOV WA,XR COPY FOR ARREF
11182: BEQ XL,=OFNE$,SITM2 JUMP IF CALLED BY NAME
11183: *
11184: * HERE IF CALLED BY VALUE
11185: *
11186: ZER WB SET CODE FOR CALL BY VALUE
11187: BRN ARREF OFF TO ARRAY REFERENCE ROUTINE
11188: *
11189: * HERE FOR CALL BY NAME
11190: *
11191: SITM2 MNZ WB SET CODE FOR CALL BY NAME
11192: LCW WA LOAD AND IGNORE OFNE$ CALL
11193: BRN ARREF OFF TO ARRAY REFERENCE ROUTINE
11194: EJC
11195: *
11196: * LE
11197: *
11198: S$LEF ENT ENTRY POINT
11199: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
11200: ERR 118,LE FIRST ARGUMENT IS NOT NUMERIC
11201: ERR 119,LE SECOND ARGUMENT IS NOT NUMERIC
11202: PPM EXNUL RETURN NULL IF LT
11203: PPM EXNUL RETURN NULL IF EQ
11204: PPM EXFAL FAIL IF GT
11205: EJC
11206: *
11207: * LEN
11208: *
11209: S$LEN ENT ENTRY POINT
11210: MOV =P$LEN,WB SET PCODE FOR INTEGER ARG CASE
11211: MOV =P$LND,WA SET PCODE FOR EXPR ARG CASE
11212: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE
11213: ERR 120,LEN ARGUMENT IS NOT INTEGER OR EXPRESSION
11214: ERR 121,LEN ARGUMENT IS NEGATIVE OR TOO LARGE
11215: BRN EXIXR RETURN PATTERN NODE
11216: EJC
11217: *
11218: * LEQ
11219: *
11220: S$LEQ ENT ENTRY POINT
11221: JSR LCOMP CALL STRING COMPARISON ROUTINE
11222: ERR 122,LEQ FIRST ARGUMENT IS NOT STRING
11223: ERR 123,LEQ SECOND ARGUMENT IS NOT STRING
11224: PPM EXFAL FAIL IF LLT
11225: PPM EXNUL RETURN NULL IF LEQ
11226: PPM EXFAL FAIL IF LGT
11227: EJC
11228: *
11229: * LGE
11230: *
11231: S$LGE ENT ENTRY POINT
11232: JSR LCOMP CALL STRING COMPARISON ROUTINE
11233: ERR 124,LGE FIRST ARGUMENT IS NOT STRING
11234: ERR 125,LGE SECOND ARGUMENT IS NOT STRING
11235: PPM EXFAL FAIL IF LLT
11236: PPM EXNUL RETURN NULL IF LEQ
11237: PPM EXNUL RETURN NULL IF LGT
11238: EJC
11239: *
11240: * LGT
11241: *
11242: S$LGT ENT ENTRY POINT
11243: JSR LCOMP CALL STRING COMPARISON ROUTINE
11244: ERR 126,LGT FIRST ARGUMENT IS NOT STRING
11245: ERR 127,LGT SECOND ARGUMENT IS NOT STRING
11246: PPM EXFAL FAIL IF LLT
11247: PPM EXFAL FAIL IF LEQ
11248: PPM EXNUL RETURN NULL IF LGT
11249: EJC
11250: *
11251: * LLE
11252: *
11253: S$LLE ENT ENTRY POINT
11254: JSR LCOMP CALL STRING COMPARISON ROUTINE
11255: ERR 128,LLE FIRST ARGUMENT IS NOT STRING
11256: ERR 129,LLE SECOND ARGUMENT IS NOT STRING
11257: PPM EXNUL RETURN NULL IF LLT
11258: PPM EXNUL RETURN NULL IF LEQ
11259: PPM EXFAL FAIL IF LGT
11260: EJC
11261: *
11262: * LLT
11263: *
11264: S$LLT ENT ENTRY POINT
11265: JSR LCOMP CALL STRING COMPARISON ROUTINE
11266: ERR 130,LLT FIRST ARGUMENT IS NOT STRING
11267: ERR 131,LLT SECOND ARGUMENT IS NOT STRING
11268: PPM EXNUL RETURN NULL IF LLT
11269: PPM EXFAL FAIL IF LEQ
11270: PPM EXFAL FAIL IF LGT
11271: EJC
11272: *
11273: * LNE
11274: *
11275: S$LNE ENT ENTRY POINT
11276: JSR LCOMP CALL STRING COMPARISON ROUTINE
11277: ERR 132,LNE FIRST ARGUMENT IS NOT STRING
11278: ERR 133,LNE SECOND ARGUMENT IS NOT STRING
11279: PPM EXNUL RETURN NULL IF LLT
11280: PPM EXFAL FAIL IF LEQ
11281: PPM EXNUL RETURN NULL IF LGT
11282: EJC
11283: *
11284: * LOCAL
11285: *
11286: S$LOC ENT ENTRY POINT
11287: JSR GTSMI GET SECOND ARGUMENT (LOCAL NUMBER)
11288: ERR 134,LOCAL SECOND ARGUMENT IS NOT INTEGER
11289: PPM EXFAL FAIL IF OUT OF RANGE
11290: MOV XR,WB SAVE LOCAL NUMBER
11291: MOV (XS)+,XR LOAD FIRST ARGUMENT
11292: JSR GTNVR POINT TO VRBLK
11293: PPM SLOC1 JUMP IF NOT VARIABLE NAME
11294: MOV VRFNC(XR),XR ELSE LOAD FUNCTION POINTER
11295: BNE (XR),=B$PFC,SLOC1 JUMP IF NOT PROGRAM DEFINED
11296: *
11297: * HERE IF WE HAVE A PROGRAM DEFINED FUNCTION NAME
11298: *
11299: BZE WB,EXFAL FAIL IF SECOND ARG IS ZERO
11300: BGT WB,PFNLO(XR),EXFAL OR TOO LARGE
11301: ADD FARGS(XR),WB ELSE ADJUST OFFSET TO INCLUDE ARGS
11302: WTB WB CONVERT TO BYTES
11303: ADD WB,XR POINT TO LOCAL POINTER
11304: MOV PFAGB(XR),XR LOAD VRBLK POINTER
11305: BRN EXVNM EXIT BUILDING NMBLK
11306: *
11307: * HERE IF FIRST ARGUMENT IS NO GOOD
11308: *
11309: SLOC1 ERB 135,LOCAL FIRST ARG IS NOT A PROGRAM FUNCTION NAME
11310: .IF .CNLD
11311: .ELSE
11312: EJC
11313: *
11314: * LOAD
11315: *
11316: S$LOD ENT ENTRY POINT
11317: JSR GTSTG LOAD LIBRARY NAME
11318: ERR 136,LOAD SECOND ARGUMENT IS NOT STRING
11319: MOV XR,XL SAVE LIBRARY NAME
11320: JSR XSCNI PREPARE TO SCAN FIRST ARGUMENT
11321: ERR 137,LOAD FIRST ARGUMENT IS NOT STRING
11322: ERR 138,LOAD FIRST ARGUMENT IS NULL
11323: MOV XL,-(XS) STACK LIBRARY NAME
11324: MOV =CH$PP,WC SET DELIMITER ONE = LEFT PAREN
11325: MOV WC,XL SET DELIMITER TWO = LEFT PAREN
11326: JSR XSCAN SCAN FUNCTION NAME
11327: MOV XR,-(XS) SAVE PTR TO FUNCTION NAME
11328: BNZ WA,SLOD1 JUMP IF LEFT PAREN FOUND
11329: ERB 139,LOAD FIRST ARGUMENT IS MISSING A LEFT PAREN
11330: *
11331: * HERE AFTER SUCCESSFULLY SCANNING FUNCTION NAME
11332: *
11333: SLOD1 JSR GTNVR LOCATE VRBLK
11334: ERR 140,LOAD FIRST ARGUMENT HAS NULL FUNCTION NAME
11335: MOV XR,LODFN SAVE VRBLK POINTER
11336: ZER LODNA ZERO COUNT OF ARGUMENTS
11337: *
11338: * LOOP TO SCAN ARGUMENT DATATYPE NAMES
11339: *
11340: SLOD2 MOV =CH$RP,WC DELIMITER ONE IS RIGHT PAREN
11341: MOV =CH$CM,XL DELIMITER TWO IS COMMA
11342: JSR XSCAN SCAN NEXT ARGUMENT NAME
11343: ICV LODNA BUMP ARGUMENT COUNT
11344: BNZ WA,SLOD3 JUMP IF OK DELIMITER WAS FOUND
11345: ERB 141,LOAD FIRST ARGUMENT IS MISSING A RIGHT PAREN
11346: EJC
11347: *
11348: * LOAD (CONTINUED)
11349: *
11350: * COME HERE TO ANALYZE THE DATATYPE POINTER IN (XR). THIS
11351: * CODE IS USED BOTH FOR ARGUMENTS (WA=1,2) AND FOR THE
11352: * RESULT DATATYPE (WITH WA SET TO ZERO).
11353: *
11354: SLOD3 MOV XR,-(XS) STACK DATATYPE NAME POINTER
11355: MOV =NUM01,WB SET STRING CODE IN CASE
11356: MOV =SCSTR,XL POINT TO /STRING/
11357: JSR IDENT CHECK FOR MATCH
11358: PPM SLOD4 JUMP IF MATCH
11359: MOV (XS),XR ELSE RELOAD NAME
11360: ADD WB,WB SET CODE FOR INTEGER (2)
11361: MOV =SCINT,XL POINT TO /INTEGER/
11362: JSR IDENT CHECK FOR MATCH
11363: PPM SLOD4 JUMP IF MATCH
11364: .IF .CNRA
11365: .ELSE
11366: MOV (XS),XR ELSE RELOAD STRING POINTER
11367: ICV WB SET CODE FOR REAL (3)
11368: MOV =SCREA,XL POINT TO /REAL/
11369: JSR IDENT CHECK FOR MATCH
11370: PPM SLOD4 JUMP IF MATCH
11371: .FI
11372: ZER WB ELSE GET CODE FOR NO CONVERT
11373: *
11374: * MERGE HERE WITH PROPER DATATYPE CODE IN WB
11375: *
11376: SLOD4 MOV WB,(XS) STORE CODE ON STACK
11377: BEQ WA,=NUM02,SLOD2 LOOP BACK IF ARG STOPPED BY COMMA
11378: BZE WA,SLOD5 JUMP IF THAT WAS THE RESULT TYPE
11379: *
11380: * HERE WE SCAN OUT THE RESULT TYPE (ARG STOPPED BY ) )
11381: *
11382: MOV MXLEN,WC SET DUMMY (IMPOSSIBLE) DELIMITER 1
11383: MOV WC,XL AND DELIMITER TWO
11384: JSR XSCAN SCAN RESULT NAME
11385: ZER WA SET CODE FOR PROCESSING RESULT
11386: BRN SLOD3 JUMP BACK TO PROCESS RESULT NAME
11387: EJC
11388: *
11389: * LOAD (CONTINUED)
11390: *
11391: * HERE AFTER PROCESSING ALL ARGS AND RESULT
11392: *
11393: SLOD5 MOV LODNA,WA GET NUMBER OF ARGUMENTS
11394: MOV WA,WC COPY FOR LATER
11395: WTB WA CONVERT LENGTH TO BYTES
11396: ADD *EFSI$,WA ADD SPACE FOR STANDARD FIELDS
11397: JSR ALLOC ALLOCATE EFBLK
11398: MOV =B$EFC,(XR) SET TYPE WORD
11399: MOV WC,FARGS(XR) SET NUMBER OF ARGUMENTS
11400: ZER EFUSE(XR) SET USE COUNT (DFFNC WILL SET TO 1)
11401: ZER EFCOD(XR) ZERO CODE POINTER FOR NOW
11402: MOV (XS)+,EFRSL(XR) STORE RESULT TYPE CODE
11403: MOV LODFN,EFVAR(XR) STORE FUNCTION VRBLK POINTER
11404: MOV WA,EFLEN(XR) STORE EFBLK LENGTH
11405: MOV XR,WB SAVE EFBLK POINTER
11406: ADD WA,XR POINT PAST END OF EFBLK
11407: LCT WC,WC SET NUMBER OF ARGUMENTS FOR LOOP
11408: *
11409: * LOOP TO SET ARGUMENT TYPE CODES FROM STACK
11410: *
11411: SLOD6 MOV (XS)+,-(XR) STORE ONE TYPE CODE FROM STACK
11412: BCT WC,SLOD6 LOOP TILL ALL STORED
11413: *
11414: * NOW LOAD THE EXTERNAL FUNCTION AND PERFORM DEFINITION
11415: *
11416: MOV (XS)+,XR LOAD FUNCTION STRING NAME
11417: MOV (XS),XL LOAD LIBRARY NAME
11418: MOV WB,(XS) STORE EFBLK POINTER
11419: JSR SYSLD CALL FUNCTION TO LOAD EXTERNAL FUNC
11420: ERR 142,LOAD FUNCTION DOES NOT EXIST
11421: ERR 143,LOAD FUNCTION CAUSED INPUT ERROR DURING LOAD
11422: MOV (XS)+,XL RECALL EFBLK POINTER
11423: MOV XR,EFCOD(XL) STORE CODE POINTER
11424: MOV LODFN,XR POINT TO VRBLK FOR FUNCTION
11425: JSR DFFNC PERFORM FUNCTION DEFINITION
11426: BRN EXNUL RETURN NULL RESULT
11427: .FI
11428: EJC
11429: *
11430: * LPAD
11431: *
11432: S$LPD ENT ENTRY POINT
11433: JSR GTSTG GET PAD CHARACTER
11434: ERR 144,LPAD THIRD ARGUMENT NOT A STRING
11435: PLC XR POINT TO CHARACTER (NULL IS BLANK)
11436: LCH WB,(XR) LOAD PAD CHARACTER
11437: JSR GTSMI GET PAD LENGTH
11438: ERR 145,LPAD SECOND ARGUMENT IS NOT INTEGER
11439: PPM SLPD3 SKIP IF NEGATIVE OR LARGE
11440: *
11441: * MERGE TO CHECK FIRST ARG
11442: *
11443: SLPD1 JSR GTSTG GET FIRST ARGUMENT (STRING TO PAD)
11444: ERR 146,LPAD FIRST ARGUMENT IS NOT STRING
11445: BGE WA,WC,EXIXR RETURN 1ST ARG IF TOO LONG TO PAD
11446: MOV XR,XL ELSE MOVE PTR TO STRING TO PAD
11447: *
11448: * NOW WE ARE READY FOR THE PAD
11449: *
11450: * (XL) POINTER TO STRING TO PAD
11451: * (WB) PAD CHARACTER
11452: * (WC) LENGTH TO PAD STRING TO
11453: *
11454: MOV WC,WA COPY LENGTH
11455: JSR ALOCS ALLOCATE SCBLK FOR NEW STRING
11456: MOV XR,-(XS) SAVE AS RESULT
11457: MOV SCLEN(XL),WA LOAD LENGTH OF ARGUMENT
11458: SUB WA,WC CALCULATE NUMBER OF PAD CHARACTERS
11459: PSC XR POINT TO CHARS IN RESULT STRING
11460: LCT WC,WC SET COUNTER FOR PAD LOOP
11461: *
11462: * LOOP TO PERFORM PAD
11463: *
11464: SLPD2 SCH WB,(XR)+ STORE PAD CHARACTER, BUMP PTR
11465: BCT WC,SLPD2 LOOP TILL ALL PAD CHARS STORED
11466: CSC XR COMPLETE STORE CHARACTERS
11467: *
11468: * NOW COPY STRING
11469: *
11470: BZE WA,EXITS EXIT IF NULL STRING
11471: PLC XL ELSE POINT TO CHARS IN ARGUMENT
11472: MVC MOVE CHARACTERS TO RESULT STRING
11473: BRN EXITS JUMP FOR NEXT CODE WORD
11474: *
11475: * HERE IF 2ND ARG IS NEGATIVE OR LARGE
11476: *
11477: SLPD3 ZER WC ZERO PAD COUNT
11478: BRN SLPD1 MERGE
11479: EJC
11480: *
11481: * LT
11482: *
11483: S$LTF ENT ENTRY POINT
11484: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
11485: ERR 147,LT FIRST ARGUMENT IS NOT NUMERIC
11486: ERR 148,LT SECOND ARGUMENT IS NOT NUMERIC
11487: PPM EXNUL RETURN NULL IF LT
11488: PPM EXFAL FAIL IF EQ
11489: PPM EXFAL FAIL IF GT
11490: EJC
11491: *
11492: * NE
11493: *
11494: S$NEF ENT ENTRY POINT
11495: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
11496: ERR 149,NE FIRST ARGUMENT IS NOT NUMERIC
11497: ERR 150,NE SECOND ARGUMENT IS NOT NUMERIC
11498: PPM EXNUL RETURN NULL IF LT
11499: PPM EXFAL FAIL IF EQ
11500: PPM EXNUL RETURN NULL IF GT
11501: EJC
11502: *
11503: * NOTANY
11504: *
11505: S$NAY ENT ENTRY POINT
11506: MOV =P$NAS,WB SET PCODE FOR SINGLE CHAR ARG
11507: MOV =P$NAY,XL PCODE FOR MULTI-CHAR ARG
11508: MOV =P$NAD,WC SET PCODE FOR EXPR ARG
11509: JSR PATST CALL COMMON ROUTINE TO BUILD NODE
11510: ERR 151,NOTANY ARGUMENT IS NOT STRING OR EXPRESSION
11511: BRN EXIXR JUMP FOR NEXT CODE WORD
11512: EJC
11513: *
11514: * OPSYN
11515: *
11516: S$OPS ENT ENTRY POINT
11517: JSR GTSMI LOAD THIRD ARGUMENT
11518: ERR 152,OPSYN THIRD ARGUMENT IS NOT INTEGER
11519: ERR 153,OPSYN THIRD ARGUMENT IS NEGATIVE OR TOO LARGE
11520: MOV WC,WB IF OK, SAVE THIRD ARGUMNET
11521: MOV (XS)+,XR LOAD SECOND ARGUMENT
11522: JSR GTNVR LOCATE VARIABLE BLOCK
11523: ERR 154,OPSYN SECOND ARG IS NOT NATURAL VARIABLE NAME
11524: MOV VRFNC(XR),XL IF OK, LOAD FUNCTION BLOCK POINTER
11525: BNZ WB,SOPS2 JUMP IF OPERATOR OPSYN CASE
11526: *
11527: * HERE FOR FUNCTION OPSYN (THIRD ARG ZERO)
11528: *
11529: MOV (XS)+,XR LOAD FIRST ARGUMENT
11530: JSR GTNVR GET VRBLK POINTER
11531: ERR 155,OPSYN FIRST ARG IS NOT NATURAL VARIABLE NAME
11532: *
11533: * MERGE HERE TO PERFORM FUNCTION DEFINITION
11534: *
11535: SOPS1 JSR DFFNC CALL FUNCTION DEFINER
11536: BRN EXNUL EXIT WITH NULL RESULT
11537: *
11538: * HERE FOR OPERATOR OPSYN (THIRD ARG NON-ZERO)
11539: *
11540: SOPS2 JSR GTSTG GET OPERATOR NAME
11541: PPM SOPS5 JUMP IF NOT STRING
11542: BNE WA,=NUM01,SOPS5 ERROR IF NOT ONE CHAR LONG
11543: PLC XR ELSE POINT TO CHARACTER
11544: LCH WC,(XR) LOAD CHARACTER NAME
11545: EJC
11546: *
11547: * OPSYN (CONTINUED)
11548: *
11549: * NOW SET TO SEARCH FOR MATCHING UNARY OR BINARY OPERATOR
11550: * NAME AS APPROPRIATE. NOTE THAT THERE ARE =OPBUN UNDEFINED
11551: * BINARY OPERATORS AND =OPUUN UNDEFINED UNARY OPERATORS.
11552: *
11553: MOV =R$UUB,WA POINT TO UNOP POINTERS IN CASE
11554: MOV =OPNSU,XR POINT TO NAMES OF UNARY OPERATORS
11555: ADD =OPBUN,WB ADD NO. OF UNDEFINED BINARY OPS
11556: BEQ WB,=OPUUN,SOPS3 JUMP IF UNOP (THIRD ARG WAS 1)
11557: MOV =R$UBA,WA ELSE POINT TO BINARY OPERATOR PTRS
11558: MOV =OPSNB,XR POINT TO NAMES OF BINARY OPERATORS
11559: MOV =OPBUN,WB SET NUMBER OF UNDEFINED BINOPS
11560: *
11561: * MERGE HERE TO CHECK LIST (WB = NUMBER TO CHECK)
11562: *
11563: SOPS3 LCT WB,WB SET COUNTER TO CONTROL LOOP
11564: *
11565: * LOOP TO SEARCH FOR NAME MATCH
11566: *
11567: SOPS4 BEQ WC,(XR),SOPS6 JUMP IF NAMES MATCH
11568: ICA WA ELSE PUSH POINTER TO FUNCTION PTR
11569: ICA XR BUMP POINTER
11570: BCT WB,SOPS4 LOOP BACK TILL ALL CHECKED
11571: *
11572: * HERE IF BAD OPERATOR NAME
11573: *
11574: SOPS5 ERB 156,OPSYN FIRST ARG IS NOT CORRECT OPERATOR NAME
11575: *
11576: * COME HERE ON FINDING A MATCH IN THE OPERATOR NAME TABLE
11577: *
11578: SOPS6 MOV WA,XR COPY POINTER TO FUNCTION BLOCK PTR
11579: SUB *VRFNC,XR MAKE IT LOOK LIKE DUMMY VRBLK
11580: BRN SOPS1 MERGE BACK TO DEFINE OPERATOR
11581: EJC
11582: *
11583: * OUTPUT
11584: *
11585: S$OUP ENT ENTRY POINT
11586: MOV =NUM03,WB OUTPUT FLAG
11587: JSR IOPUT CALL INPUT/OUTPUT ASSOC. ROUTINE
11588: ERR 157,OUTPUT THIRD ARGUMENT IS NOT A STRING
11589: ERR 158,INAPPROPRIATE SECOND ARGUMENT FOR OUTPUT
11590: ERR 159,INAPPROPRIATE FIRST ARGUMENT FOR OUTPUT
11591: ERR 160,INAPPROPRIATE FILE SPECIFICATION FOR OUTPUT
11592: PPM EXFAL FAIL IF FILE DOES NOT EXIST
11593: ERR 161,OUTPUT FILE CANNOT BE WRITTEN TO
11594: BRN EXNUL RETURN NULL STRING
11595: EJC
11596: *
11597: * POS
11598: *
11599: S$POS ENT ENTRY POINT
11600: MOV =P$POS,WB SET PCODE FOR INTEGER ARG CASE
11601: MOV =P$PSD,WA SET PCODE FOR EXPRESSION ARG CASE
11602: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE
11603: ERR 162,POS ARGUMENT IS NOT INTEGER OR EXPRESSION
11604: ERR 163,POS ARGUMENT IS NEGATIVE OR TOO LARGE
11605: BRN EXIXR RETURN PATTERN NODE
11606: EJC
11607: *
11608: * PROTOTYPE
11609: *
11610: S$PRO ENT ENTRY POINT
11611: MOV (XS)+,XR LOAD ARGUMENT
11612: MOV TBLEN(XR),WB LENGTH IF TABLE, VECTOR (=VCLEN)
11613: BTW WB CONVERT TO WORDS
11614: MOV (XR),WA LOAD TYPE WORD OF ARGUMENT BLOCK
11615: BEQ WA,=B$ART,SPRO4 JUMP IF ARRAY
11616: BEQ WA,=B$TBT,SPRO1 JUMP IF TABLE
11617: BEQ WA,=B$VCT,SPRO3 JUMP IF VECTOR
11618: BEQ WA,=B$BCT,SPR05 JUMP IF BUFFER
11619: ERB 164,PROTOTYPE ARGUMENT IS NOT VALID OBJECT
11620: *
11621: * HERE FOR TABLE
11622: *
11623: SPRO1 SUB =TBSI$,WB SUBTRACT STANDARD FIELDS
11624: *
11625: * MERGE FOR VECTOR
11626: *
11627: SPRO2 MTI WB CONVERT TO INTEGER
11628: BRN EXINT EXIT WITH INTEGER RESULT
11629: *
11630: * HERE FOR VECTOR
11631: *
11632: SPRO3 SUB =VCSI$,WB SUBTRACT STANDARD FIELDS
11633: BRN SPRO2 MERGE
11634: *
11635: * HERE FOR ARRAY
11636: *
11637: SPRO4 ADD AROFS(XR),XR POINT TO PROTOTYPE FIELD
11638: MOV (XR),XR LOAD PROTOTYPE
11639: BRN EXIXR RETURN PROTOTYPE AS RESULT
11640: .IF .CNBF
11641: .ELSE
11642: *
11643: * HERE FOR BUFFER
11644: *
11645: SPR05 MOV BCBUF(XR),XR POINT TO BFBLK
11646: MTI BFALC(XR) LOAD ALLOCATED LENGTH
11647: BRN EXINT EXIT WITH INTEGER ALLOCATION
11648: .FI
11649: EJC
11650: *
11651: * REMDR
11652: *
11653: S$RMD ENT ENTRY POINT
11654: ZER WB SET POSITIVE FLAG
11655: MOV (XS),XR LOAD SECOND ARGUMENT
11656: JSR GTINT CONVERT TO INTEGER
11657: ERR 165,REMDR SECOND ARGUMENT IS NOT INTEGER
11658: JSR ARITH CONVERT ARGS
11659: PPM SRM01 FIRST ARG NOT INTEGER
11660: PPM SECOND ARG CHECKED ABOVE
11661: .IF .CNRA
11662: .ELSE
11663: PPM SRM01 FIRST ARG REAL
11664: .FI
11665: LDI ICVAL(XR) LOAD LEFT ARGUMENT VALUE
11666: RMI ICVAL(XL) GET REMAINDER
11667: INO EXINT JUMP IF NO OVERFLOW
11668: ERB 167,REMDR CAUSED INTEGER OVERFLOW
11669: *
11670: * FAIL FIRST ARGUMENT
11671: *
11672: SRM01 ERB 166,REMDR FIRST ARGUMENT IS NOT INTEGER
11673: EJC
11674: *
11675: * REPLACE
11676: *
11677: * THE ACTUAL REPLACE OPERATION USES AN SCBLK WHOSE CFP$A
11678: * CHARS CONTAIN THE TRANSLATED VERSIONS OF ALL THE CHARS.
11679: * THE TABLE POINTER IS REMEMBERED FROM CALL TO CALL AND
11680: * THE TABLE IS ONLY BUILT WHEN THE ARGUMENTS CHANGE.
11681: *
11682: S$RPL ENT ENTRY POINT
11683: JSR GTSTG LOAD THIRD ARGUMENT AS STRING
11684: ERR 168,REPLACE THIRD ARGUMENT IS NOT STRING
11685: MOV XR,XL SAVE THIRD ARG PTR
11686: JSR GTSTG GET SECOND ARGUMENT
11687: ERR 169,REPLACE SECOND ARGUMENT IS NOT STRING
11688: *
11689: * CHECK TO SEE IF THIS IS THE SAME TABLE AS LAST TIME
11690: *
11691: BNE XR,R$RA2,SRPL1 JUMP IF 2ND ARGUMENT DIFFERENT
11692: BEQ XL,R$RA3,SRPL4 JUMP IF ARGS SAME AS LAST TIME
11693: *
11694: * HERE WE BUILD A NEW REPLACE TABLE (NOTE WA = 2ND ARG LEN)
11695: *
11696: SRPL1 MOV SCLEN(XL),WB LOAD 3RD ARGUMENT LENGTH
11697: BNE WA,WB,SRPL5 JUMP IF ARGUMENTS NOT SAME LENGTH
11698: BZE WB,SRPL5 JUMP IF NULL 2ND ARGUMENT
11699: MOV XL,R$RA3 SAVE THIRD ARG FOR NEXT TIME IN
11700: MOV XR,R$RA2 SAVE SECOND ARG FOR NEXT TIME IN
11701: MOV KVALP,XL POINT TO ALPHABET STRING
11702: MOV SCLEN(XL),WA LOAD ALPHABET SCBLK LENGTH
11703: MOV R$RPT,XR POINT TO CURRENT TABLE (IF ANY)
11704: BNZ XR,SRPL2 JUMP IF WE ALREADY HAVE A TABLE
11705: *
11706: * HERE WE ALLOCATE A NEW TABLE
11707: *
11708: JSR ALOCS ALLOCATE NEW TABLE
11709: MOV WC,WA KEEP SCBLK LENGTH
11710: MOV XR,R$RPT SAVE TABLE POINTER FOR NEXT TIME
11711: *
11712: * MERGE HERE WITH POINTER TO NEW TABLE BLOCK IN (XR)
11713: *
11714: SRPL2 CTB WA,SCSI$ COMPUTE LENGTH OF SCBLK
11715: MVW COPY TO GET INITIAL TABLE VALUES
11716: EJC
11717: *
11718: * REPLACE (CONTINUED)
11719: *
11720: * NOW WE MUST PLUG SELECTED ENTRIES AS REQUIRED. NOTE THAT
11721: * WE ARE SHORT OF INDEX REGISTERS FOR THE FOLLOWING LOOP.
11722: * HENCE THE NEED TO REPEATEDLY RE-INITIALISE CHAR PTR XL
11723: *
11724: MOV R$RA2,XL POINT TO SECOND ARGUMENT
11725: LCT WB,WB NUMBER OF CHARS TO PLUG
11726: ZER WC ZERO CHAR OFFSET
11727: MOV R$RA3,XR POINT TO 3RD ARG
11728: PLC XR GET CHAR PTR FOR 3RD ARG
11729: *
11730: * LOOP TO PLUG CHARS
11731: *
11732: SRPL3 MOV R$RA2,XL POINT TO 2ND ARG
11733: PLC XL,WC POINT TO NEXT CHAR
11734: ICV WC INCREMENT OFFSET
11735: LCH WA,(XL) GET NEXT CHAR
11736: MOV R$RPT,XL POINT TO TRANSLATE TABLE
11737: PSC XL,WA CONVERT CHAR TO OFFSET INTO TABLE
11738: LCH WA,(XR)+ GET TRANSLATED CHAR
11739: SCH WA,(XL) STORE IN TABLE
11740: CSC XL COMPLETE STORE CHARACTERS
11741: BCT WB,SRPL3 LOOP TILL DONE
11742: EJC
11743: *
11744: * REPLACE (CONTINUED)
11745: *
11746: * HERE TO PERFORM TRANSLATE
11747: *
11748: SRPL4 JSR GTSTG GET FIRST ARGUMENT
11749: ERR 170,REPLACE FIRST ARGUMENT IS NOT STRING
11750: BZE WA,EXNUL RETURN NULL IF NULL ARGUMENT
11751: MOV XR,XL COPY POINTER
11752: MOV WA,WC SAVE LENGTH
11753: CTB WA,SCHAR GET SCBLK LENGTH
11754: JSR ALLOC ALLOCATE SPACE FOR COPY
11755: MOV XR,WB SAVE ADDRESS OF COPY
11756: MVW MOVE SCBLK CONTENTS TO COPY
11757: MOV R$RPT,XR POINT TO REPLACE TABLE
11758: PLC XR POINT TO CHARS OF TABLE
11759: MOV WB,XL POINT TO STRING TO TRANSLATE
11760: PLC XL POINT TO CHARS OF STRING
11761: MOV WC,WA SET NUMBER OF CHARS TO TRANSLATE
11762: TRC PERFORM TRANSLATION
11763: MOV WB,-(XS) STACK NEW STRING AS RESULT
11764: BRN EXITS RETURN WITH RESULT ON STACK
11765: *
11766: * ERROR POINT
11767: *
11768: SRPL5 ERB 171,NULL OR UNEQUALLY LONG 2ND, 3RD ARGS TO REPLACE
11769: EJC
11770: *
11771: * REWIND
11772: *
11773: S$REW ENT ENTRY POINT
11774: JSR IOFCB CALL FCBLK ROUTINE
11775: ERR 172,REWIND ARGUMENT IS NOT A SUITABLE NAME
11776: ERR 173,REWIND ARGUMENT IS NULL
11777: JSR SYSRW CALL SYSTEM REWIND FUNCTION
11778: ERR 174,REWIND FILE DOES NOT EXIST
11779: ERR 175,REWIND FILE DOES NOT PERMIT REWIND
11780: ERR 176,REWIND CAUSED NON-RECOVERABLE ERROR
11781: BRN EXNUL EXIT WITH NULL RESULT IF NO ERROR
11782: EJC
11783: *
11784: * REVERSE
11785: *
11786: S$RVS ENT ENTRY POINT
11787: JSR GTSTG LOAD STRING ARGUMENT
11788: ERR 177,REVERSE ARGUMENT IS NOT STRING
11789: BZE WA,EXIXR RETURN ARGUMENT IF NULL
11790: MOV XR,XL ELSE SAVE POINTER TO STRING ARG
11791: JSR ALOCS ALLOCATE SPACE FOR NEW SCBLK
11792: MOV XR,-(XS) STORE SCBLK PTR ON STACK AS RESULT
11793: PSC XR PREPARE TO STORE IN NEW SCBLK
11794: PLC XL,WC POINT PAST LAST CHAR IN ARGUMENT
11795: LCT WC,WC SET LOOP COUNTER
11796: *
11797: * LOOP TO MOVE CHARS IN REVERSE ORDER
11798: *
11799: SRVS1 LCH WB,-(XL) LOAD NEXT CHAR FROM ARGUMENT
11800: SCH WB,(XR)+ STORE IN RESULT
11801: BCT WC,SRVS1 LOOP TILL ALL MOVED
11802: CSC XR COMPLETE STORE CHARACTERS
11803: BRN EXITS AND THEN JUMP FOR NEXT CODE WORD
11804: EJC
11805: *
11806: * RPAD
11807: *
11808: S$RPD ENT ENTRY POINT
11809: JSR GTSTG GET PAD CHARACTER
11810: ERR 178,RPAD THIRD ARGUMENT IS NOT STRING
11811: PLC XR POINT TO CHARACTER (NULL IS BLANK)
11812: LCH WB,(XR) LOAD PAD CHARACTER
11813: JSR GTSMI GET PAD LENGTH
11814: ERR 179,RPAD SECOND ARGUMENT IS NOT INTEGER
11815: PPM SRPD3 SKIP IF NEGATIVE OR LARGE
11816: *
11817: * MERGE TO CHECK FIRST ARG.
11818: *
11819: SRPD1 JSR GTSTG GET FIRST ARGUMENT (STRING TO PAD)
11820: ERR 180,RPAD FIRST ARGUMENT IS NOT STRING
11821: BGE WA,WC,EXIXR RETURN 1ST ARG IF TOO LONG TO PAD
11822: MOV XR,XL ELSE MOVE PTR TO STRING TO PAD
11823: *
11824: * NOW WE ARE READY FOR THE PAD
11825: *
11826: * (XL) POINTER TO STRING TO PAD
11827: * (WB) PAD CHARACTER
11828: * (WC) LENGTH TO PAD STRING TO
11829: *
11830: MOV WC,WA COPY LENGTH
11831: JSR ALOCS ALLOCATE SCBLK FOR NEW STRING
11832: MOV XR,-(XS) SAVE AS RESULT
11833: MOV SCLEN(XL),WA LOAD LENGTH OF ARGUMENT
11834: SUB WA,WC CALCULATE NUMBER OF PAD CHARACTERS
11835: PSC XR POINT TO CHARS IN RESULT STRING
11836: LCT WC,WC SET COUNTER FOR PAD LOOP
11837: *
11838: * COPY ARGUMENT STRING
11839: *
11840: BZE WA,SRPD2 JUMP IF ARGUMENT IS NULL
11841: PLC XL ELSE POINT TO ARGUMENT CHARS
11842: MVC MOVE CHARACTERS TO RESULT STRING
11843: *
11844: * LOOP TO SUPPLY PAD CHARACTERS
11845: *
11846: SRPD2 SCH WB,(XR)+ STORE PAD CHARACTER, BUMP PTR
11847: BCT WC,SRPD2 LOOP TILL ALL PAD CHARS STORED
11848: CSC XR COMPLETE CHARACTER STORING
11849: BRN EXITS AND EXIT FOR NEXT WORD
11850: *
11851: * HERE IF 2ND ARG IS NEGATIVE OR LARGE
11852: *
11853: SRPD3 ZER WC ZERO PAD COUNT
11854: BRN SRPD1 MERGE
11855: EJC
11856: *
11857: * RTAB
11858: *
11859: S$RTB ENT ENTRY POINT
11860: MOV =P$RTB,WB SET PCODE FOR INTEGER ARG CASE
11861: MOV =P$RTD,WA SET PCODE FOR EXPRESSION ARG CASE
11862: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE
11863: ERR 181,RTAB ARGUMENT IS NOT INTEGER OR EXPRESSION
11864: ERR 182,RTAB ARGUMENT IS NEGATIVE OR TOO LARGE
11865: BRN EXIXR RETURN PATTERN NODE
11866: EJC
11867: .IF .CUST
11868: *
11869: * SET
11870: *
11871: S$SET ENT ENTRY POINT
11872: MOV (XS)+,R$IO2 SAVE THIRD ARG
11873: MOV (XS)+,R$IO1 SAVE SECOND ARG
11874: JSR IOFCB CALL FCBLK ROUTINE
11875: ERR 291,SET FIRST ARGUMENT IS NOT A SUITABLE NAME
11876: ERR 292,SET FIRST ARGUMENT IS NULL
11877: MOV R$IO1,WB LOAD SECOND ARG
11878: MOV R$IO2,WC LOAD THIRD ARG
11879: JSR SYSST CALL SYSTEM SET ROUTINE
11880: ERR 293,INAPPROPRIATE SECOND ARGUMENT TO SET
11881: ERR 294,INAPPROPRIATE THIRD ARGUMENT TO SET
11882: ERR 295,SET FILE DOES NOT EXIST
11883: ERR 296,SET FILE DOES NOT PERMIT SETTING FILE POINTER
11884: ERR 297,SET CAUSED NON-RECOVERABLE I/O ERROR
11885: BRN EXNUL OTHERWISEW RETURN NULL
11886: EJC
11887: .FI
11888: *
11889: * TAB
11890: *
11891: S$TAB ENT ENTRY POINT
11892: MOV =P$TAB,WB SET PCODE FOR INTEGER ARG CASE
11893: MOV =P$TBD,WA SET PCODE FOR EXPRESSION ARG CASE
11894: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE
11895: ERR 183,TAB ARGUMENT IS NOT INTEGER OR EXPRESSION
11896: ERR 184,TAB ARGUMENT IS NEGATIVE OR TOO LARGE
11897: BRN EXIXR RETURN PATTERN NODE
11898: EJC
11899: *
11900: * RPOS
11901: *
11902: S$RPS ENT ENTRY POINT
11903: MOV =P$RPS,WB SET PCODE FOR INTEGER ARG CASE
11904: MOV =P$RPD,WA SET PCODE FOR EXPRESSION ARG CASE
11905: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE
11906: ERR 185,RPOS ARGUMENT IS NOT INTEGER OR EXPRESSION
11907: ERR 186,RPOS ARGUMENT IS NEGATIVE OR TOO LARGE
11908: BRN EXIXR RETURN PATTERN NODE
11909: .IF .CNSR
11910: .ELSE
11911: EJC
11912: *
11913: * RSORT
11914: *
11915: S$RSR ENT ENTRY POINT
11916: MNZ WA MARK AS RSORT
11917: JSR SORTA CALL SORT ROUTINE
11918: BRN EXSID RETURN, SETTING IDVAL
11919: .FI
11920: EJC
11921: *
11922: * SETEXIT
11923: *
11924: S$STX ENT ENTRY POINT
11925: MOV (XS)+,XR LOAD ARGUMENT
11926: MOV STXVR,WA LOAD OLD VRBLK POINTER
11927: ZER XL LOAD ZERO IN CASE NULL ARG
11928: BEQ XR,=NULLS,SSTX1 JUMP IF NULL ARGUMENT (RESET CALL)
11929: JSR GTNVR ELSE GET SPECIFIED VRBLK
11930: PPM SSTX2 JUMP IF NOT NATURAL VARIABLE
11931: MOV VRLBL(XR),XL ELSE LOAD LABEL
11932: BEQ XL,=STNDL,SSTX2 JUMP IF LABEL IS NOT DEFINED
11933: BNE (XL),=B$TRT,SSTX1 JUMP IF NOT TRAPPED
11934: MOV TRLBL(XL),XL ELSE LOAD PTR TO REAL LABEL CODE
11935: *
11936: * HERE TO SET/RESET SETEXIT TRAP
11937: *
11938: SSTX1 MOV XR,STXVR STORE NEW VRBLK POINTER (OR NULL)
11939: MOV XL,R$SXC STORE NEW CODE PTR (OR ZERO)
11940: BEQ WA,=NULLS,EXNUL RETURN NULL IF NULL RESULT
11941: MOV WA,XR ELSE COPY VRBLK POINTER
11942: BRN EXVNM AND RETURN BUILDING NMBLK
11943: *
11944: * HERE IF BAD ARGUMENT
11945: *
11946: SSTX2 ERB 187,SETEXIT ARGUMENT IS NOT LABEL NAME OR NULL
11947: .IF .CNSR
11948: .ELSE
11949: EJC
11950: *
11951: * SORT
11952: *
11953: S$SRT ENT ENTRY POINT
11954: ZER WA MARK AS SORT
11955: JSR SORTA CALL SORT ROUTINE
11956: BRN EXSID RETURN, SETTING IDVAL
11957: .FI
11958: EJC
11959: *
11960: * SPAN
11961: *
11962: S$SPN ENT ENTRY POINT
11963: MOV =P$SPS,WB SET PCODE FOR SINGLE CHAR ARG
11964: MOV =P$SPN,XL SET PCODE FOR MULTI-CHAR ARG
11965: MOV =P$SPD,WC SET PCODE FOR EXPRESSION ARG
11966: JSR PATST CALL COMMON ROUTINE TO BUILD NODE
11967: ERR 188,SPAN ARGUMENT IS NOT STRING OR EXPRESSION
11968: BRN EXIXR JUMP FOR NEXT CODE WORD
11969: EJC
11970: *
11971: * SIZE
11972: *
11973: S$SI$ ENT ENTRY POINT
11974: .IF .CNBF
11975: .ELSE
11976: MOV (XS),XR LOAD ARGUMENT
11977: BNE (XR),=B$BCT,SSI$1 BRANCH IF NOT BUFFER
11978: ICA XS ELSE POP ARGUMENT
11979: MTI BCLEN(XR) LOAD DEFINED LENGTH
11980: BRN EXINT EXIT WITH INTEGER
11981: .FI
11982: *
11983: * HERE IF NOT BUFFER
11984: *
11985: SSI$1 JSR GTSTG LOAD STRING ARGUMENT
11986: ERR 189,SIZE ARGUMENT IS NOT STRING
11987: MTI WA LOAD LENGTH AS INTEGER
11988: BRN EXINT EXIT WITH INTEGER RESULT
11989: EJC
11990: *
11991: * STOPTR
11992: *
11993: S$STT ENT ENTRY POINT
11994: ZER XL INDICATE STOPTR CASE
11995: JSR TRACE CALL TRACE PROCEDURE
11996: ERR 190,STOPTR FIRST ARGUMENT IS NOT APPROPRIATE NAME
11997: ERR 191,STOPTR SECOND ARGUMENT IS NOT TRACE TYPE
11998: BRN EXNUL RETURN NULL
11999: EJC
12000: *
12001: * SUBSTR
12002: *
12003: S$SUB ENT ENTRY POINT
12004: JSR GTSMI LOAD THIRD ARGUMENT
12005: ERR 192,SUBSTR THIRD ARGUMENT IS NOT INTEGER
12006: PPM EXFAL JUMP IF NEGATIVE OR TOO LARGE
12007: MOV XR,SBSSV SAVE THIRD ARGUMENT
12008: JSR GTSMI LOAD SECOND ARGUMENT
12009: ERR 193,SUBSTR SECOND ARGUMENT IS NOT INTEGER
12010: PPM EXFAL JUMP IF OUT OF RANGE
12011: MOV XR,WB SAVE SECOND ARGUMENT
12012: BZE WB,EXFAL JUMP IF SECOND ARGUMENT ZERO
12013: DCV WB ELSE DECREMENT FOR ONES ORIGIN
12014: .IF .CNBF
12015: .ELSE
12016: MOV (XS),XL GET FIRST ARG PTR
12017: BNE (XL),=B$BCT,SSUBA BRANCH IF NOT BUFFER
12018: MOV BCBUF(XL),XR GET BFBLK PTR
12019: MOV BCLEN(XL),WA GET LENGTH
12020: BRN SSUBB MERGE
12021: *
12022: * HERE IF NOT BUFFER TO GET STRING
12023: *
12024: .FI
12025: SSUBA JSR GTSTG LOAD FIRST ARGUMENT
12026: ERR 194,SUBSTR FIRST ARGUMENT IS NOT STRING
12027: *
12028: * MERGE WITH BFBLK OR SCBLK PTR IN XR. WA HAS LENGTH
12029: *
12030: SSUBB MOV SBSSV,WC RELOAD THIRD ARGUMENT
12031: BNZ WC,SSUB1 SKIP IF THIRD ARG GIVEN
12032: MOV WA,WC ELSE GET STRING LENGTH
12033: BGT WB,WC,EXFAL FAIL IF IMPROPER
12034: SUB WB,WC REDUCE BY OFFSET TO START
12035: *
12036: * MERGE
12037: *
12038: SSUB1 MOV WA,XL SAVE STRING LENGTH
12039: MOV WC,WA SET LENGTH OF SUBSTRING
12040: ADD WB,WC ADD 2ND ARG TO 3RD ARG
12041: BGT WC,XL,EXFAL JUMP IF IMPROPER SUBSTRING
12042: MOV XR,XL COPY POINTER TO FIRST ARG
12043: JSR SBSTR BUILD SUBSTRING
12044: BRN EXIXR AND JUMP FOR NEXT CODE WORD
12045: EJC
12046: *
12047: * TABLE
12048: *
12049: S$TBL ENT ENTRY POINT
12050: MOV (XS)+,XL GET INITIAL LOOKUP VALUE
12051: ICA XS POP SECOND ARGUMENT
12052: JSR GTSMI LOAD ARGUMENT
12053: ERR 195,TABLE ARGUMENT IS NOT INTEGER
12054: ERR 196,TABLE ARGUMENT IS OUT OF RANGE
12055: BNZ WC,STBL1 JUMP IF NON-ZERO
12056: MOV =TBNBK,WC ELSE SUPPLY DEFAULT VALUE
12057: *
12058: * MERGE HERE WITH NUMBER OF HEADERS IN WA
12059: *
12060: STBL1 MOV WC,WA COPY NUMBER OF HEADERS
12061: ADD =TBSI$,WA ADJUST FOR STANDARD FIELDS
12062: WTB WA CONVERT LENGTH TO BYTES
12063: JSR ALLOC ALLOCATE SPACE FOR TBBLK
12064: MOV XR,WB COPY POINTER TO TBBLK
12065: MOV =B$TBT,(XR)+ STORE TYPE WORD
12066: ZER (XR)+ ZERO ID FOR THE MOMENT
12067: MOV WA,(XR)+ STORE LENGTH (TBLEN)
12068: MOV XL,(XR)+ STORE INITIAL LOOKUP VALUE
12069: LCT WC,WC SET LOOP COUNTER (NUM HEADERS)
12070: *
12071: * LOOP TO INITIALIZE ALL BUCKET POINTERS
12072: *
12073: STBL2 MOV WB,(XR)+ STORE TBBLK PTR IN BUCKET HEADER
12074: BCT WC,STBL2 LOOP TILL ALL STORED
12075: MOV WB,XR RECALL POINTER TO TBBLK
12076: BRN EXSID EXIT SETTING IDVAL
12077: EJC
12078: *
12079: * TIME
12080: *
12081: S$TIM ENT ENTRY POINT
12082: JSR SYSTM GET TIMER VALUE
12083: SBI TIMSX SUBTRACT STARTING TIME
12084: BRN EXINT EXIT WITH INTEGER VALUE
12085: EJC
12086: *
12087: * TRACE
12088: *
12089: S$TRA ENT ENTRY POINT
12090: BEQ 3(XS),=NULLS,STR03 JUMP IF FIRST ARGUMENT IS NULL
12091: MOV (XS)+,XR LOAD FOURTH ARGUMENT
12092: ZER XL TENTATIVELY SET ZERO POINTER
12093: BEQ XR,=NULLS,STR02 JUMP IF 4TH ARGUMENT IS NULL
12094: JSR GTNVR ELSE POINT TO VRBLK
12095: PPM STR01 JUMP IF NOT VARIABLE NAME
12096: MOV VRFNC(XR),XL ELSE LOAD FUNCTION POINTER
12097: BNE XL,=STNDF,STR02 JUMP IF FUNCTION IS DEFINED
12098: *
12099: * HERE FOR BAD FOURTH ARGUMENT
12100: *
12101: STR01 ERB 197,TRACE FOURTH ARG IS NOT FUNCTION NAME OR NULL
12102: *
12103: * HERE WITH FUNCTION POINTER IN XL
12104: *
12105: STR02 MOV (XS)+,XR LOAD THIRD ARGUMENT (TAG)
12106: ZER WB SET ZERO AS TRTYP VALUE FOR NOW
12107: JSR TRBLD BUILD TRBLK FOR TRACE CALL
12108: MOV XR,XL MOVE TRBLK POINTER FOR TRACE
12109: JSR TRACE CALL TRACE PROCEDURE
12110: ERR 198,TRACE FIRST ARGUMENT IS NOT APPROPRIATE NAME
12111: ERR 199,TRACE SECOND ARGUMENT IS NOT TRACE TYPE
12112: BRN EXNUL RETURN NULL
12113: *
12114: * HERE TO CALL SYSTEM TRACE TOGGLE ROUTINE
12115: *
12116: STR03 JSR SYSTT CALL IT
12117: ADD *NUM04,XS POP TRACE ARGUMENTS
12118: BRN EXNUL RETURN
12119: EJC
12120: *
12121: * TRIM
12122: *
12123: S$TRM ENT ENTRY POINT
12124: JSR GTSTG LOAD ARGUMENT AS STRING
12125: ERR 200,TRIM ARGUMENT IS NOT STRING
12126: BZE WA,EXNUL RETURN NULL IF ARGUMENT IS NULL
12127: MOV XR,XL COPY STRING POINTER
12128: CTB WA,SCHAR GET BLOCK LENGTH
12129: JSR ALLOC ALLOCATE COPY SAME SIZE
12130: MOV XR,WB SAVE POINTER TO COPY
12131: MVW COPY OLD STRING BLOCK TO NEW
12132: MOV WB,XR RESTORE PTR TO NEW BLOCK
12133: JSR TRIMR TRIM BLANKS (WB IS NON-ZERO)
12134: BRN EXIXR EXIT WITH RESULT IN XR
12135: EJC
12136: *
12137: * UNLOAD
12138: *
12139: S$UNL ENT ENTRY POINT
12140: MOV (XS)+,XR LOAD ARGUMENT
12141: JSR GTNVR POINT TO VRBLK
12142: ERR 201,UNLOAD ARGUMENT IS NOT NATURAL VARIABLE NAME
12143: MOV =STNDF,XL GET PTR TO UNDEFINED FUNCTION
12144: JSR DFFNC UNDEFINE NAMED FUNCTION
12145: BRN EXNUL RETURN NULL AS RESULT
12146: TTL S P I T B O L -- UTILITY PROCEDURES
12147: *
12148: * THE FOLLOWING SECTION CONTAINS PROCEDURES WHICH ARE
12149: * USED FOR VARIOUS PURPOSES THROUGHOUT THE SYSTEM.
12150: *
12151: * EACH PROCEDURE IS PRECEDED BY A DESCRIPTION OF THE
12152: * CALLING SEQUENCE. USUALLY THE ARGUMENTS ARE IN REGISTERS
12153: * BUT ARGUMENTS CAN ALSO OCCUR ON THE STACK AND AS
12154: * PARAMETERS ASSEMBLED AFTER THE JSR INSTRUCTION.
12155: *
12156: * THE FOLLOWING CONSIDERATIONS APPLY TO THESE DESCRIPTIONS.
12157: *
12158: * 1) THE STACK POINTER (XS) IS NOT CHANGED UNLESS THE
12159: * CHANGE IS EXPLICITLY DOCUMENTED IN THE CALL.
12160: *
12161: * 2) REGISTERS WHOSE ENTRY VALUES ARE NOT MENTIONED
12162: * MAY CONTAIN ANY VALUE EXCEPT THAT XL,XR MAY ONLY
12163: * CONTAIN PROPER (COLLECTABLE) POINTER VALUES.
12164: * THIS CONDITION ON XR MEANS THAT THE CALLED ROUTINE
12165: * MAY IF IT CHOOSES PRESERVE XR BY STACKING.
12166: *
12167: * 3) REGISTERS NOT MENTIONED ON EXIT CONTAIN THE SAME
12168: * VALUES AS THEY DID ON ENTRY EXCEPT THAT VALUES IN
12169: * XR,XL MAY HAVE BEEN RELOCATED BY THE COLLECTOR.
12170: *
12171: * 4) REGISTERS WHICH ARE DESTROYED ON EXIT MAY CONTAIN
12172: * ANY VALUE EXCEPT THAT VALUES IN XL,XR ARE PROPER
12173: * (COLLECTABLE) POINTERS.
12174: *
12175: * 5) THE CODE POINTER REGISTER POINTS TO THE CURRENT
12176: * CODE LOCATION ON ENTRY AND IS UNCHANGED ON EXIT.
12177: *
12178: * IN THE ABOVE DESCRIPTION, A COLLECTABLE POINTER IS ONE
12179: * WHICH EITHER POINTS OUTSIDE THE DYNAMIC REGION OR
12180: * POINTS TO THE START OF A BLOCK IN THE DYNAMIC REGION.
12181: *
12182: * IN THOSE CASES WHERE THE CALLING SEQUENCE CONTAINS
12183: * PARAMETERS WHICH ARE USED AS ALTERNATE RETURN POINTS,
12184: * THESE PARAMETERS MAY BE REPLACED BY ERROR CODES
12185: * ASSEMBLED WITH THE ERR INSTRUCTION. THIS WILL RESULT
12186: * IN THE POSTING OF THE ERROR IF THE RETURN IS TAKEN.
12187: *
12188: * THE PROCEDURES ALL HAVE NAMES CONSISTING OF FIVE LETTERS
12189: * AND ARE IN ALPHABETICAL ORDER BY THEIR NAMES.
12190: EJC
12191: *
12192: * ACESS - ACCESS VARIABLE VALUE WITH TRACE/INPUT CHECKS
12193: *
12194: * ACESS LOADS THE VALUE OF A VARIABLE. TRACE AND INPUT
12195: * ASSOCIATIONS ARE TESTED FOR AND EXECUTED AS REQUIRED.
12196: * ACESS ALSO HANDLES THE SPECIAL CASES OF PSEUDO-VARIABLES.
12197: *
12198: * (XL) VARIABLE NAME BASE
12199: * (WA) VARIABLE NAME OFFSET
12200: * JSR ACESS CALL TO ACCESS VALUE
12201: * PPM LOC TRANSFER LOC IF ACCESS FAILURE
12202: * (XR) VARIABLE VALUE
12203: * (WA,WB,WC) DESTROYED
12204: * (XL,RA) DESTROYED
12205: *
12206: * FAILURE CAN OCCUR IF AN INPUT ASSOCIATION CAUSES AN END
12207: * OF FILE CONDITION OR IF THE EVALUATION OF AN EXPRESSION
12208: * ASSOCIATED WITH AN EXPRESSION VARIABLE FAILS.
12209: *
12210: ACESS PRC R,1 ENTRY POINT (RECURSIVE)
12211: MOV XL,XR COPY NAME BASE
12212: ADD WA,XR POINT TO VARIABLE LOCATION
12213: MOV (XR),XR LOAD VARIABLE VALUE
12214: *
12215: * LOOP HERE TO CHECK FOR SUCCESSIVE TRBLKS
12216: *
12217: ACS02 BNE (XR),=B$TRT,ACS18 JUMP IF NOT TRAPPED
12218: *
12219: * HERE IF TRAPPED
12220: *
12221: BEQ XR,=TRBKV,ACS12 JUMP IF KEYWORD VARIABLE
12222: BNE XR,=TRBEV,ACS05 JUMP IF NOT EXPRESSION VARIABLE
12223: *
12224: * HERE FOR EXPRESSION VARIABLE, EVALUATE VARIABLE
12225: *
12226: MOV EVEXP(XL),XR LOAD EXPRESSION POINTER
12227: ZER WB EVALUATE BY VALUE
12228: JSR EVALX EVALUATE EXPRESSION
12229: PPM ACS04 JUMP IF EVALUATION FAILURE
12230: BRN ACS02 CHECK VALUE FOR MORE TRBLKS
12231: EJC
12232: *
12233: * ACESS (CONTINUED)
12234: *
12235: * HERE ON READING END OF FILE
12236: *
12237: ACS03 ADD *NUM03,XS POP TRBLK PTR, NAME BASE AND OFFSET
12238: MOV XR,DNAMP POP UNUSED SCBLK
12239: *
12240: * MERGE HERE WHEN EVALUATION OF EXPRESSION FAILS
12241: *
12242: ACS04 EXI 1 TAKE ALTERNATE (FAILURE) RETURN
12243: *
12244: * HERE IF NOT KEYWORD OR EXPRESSION VARIABLE
12245: *
12246: ACS05 MOV TRTYP(XR),WB LOAD TRAP TYPE CODE
12247: BNZ WB,ACS10 JUMP IF NOT INPUT ASSOCIATION
12248: BZE KVINP,ACS09 IGNORE INPUT ASSOC IF INPUT IS OFF
12249: *
12250: * HERE FOR INPUT ASSOCIATION
12251: *
12252: MOV XL,-(XS) STACK NAME BASE
12253: MOV WA,-(XS) STACK NAME OFFSET
12254: MOV XR,-(XS) STACK TRBLK POINTER
12255: MOV TRFPT(XR),XL GET FILE CTRL BLK PTR OR ZERO
12256: BNZ XL,ACS06 JUMP IF NOT STANDARD INPUT FILE
12257: BEQ TRTER(XR),=V$TER,ACS21 JUMP IF TERMINAL
12258: *
12259: * HERE TO READ FROM STANDARD INPUT FILE
12260: *
12261: MOV CSWIN,WA LENGTH FOR READ BUFFER
12262: JSR ALOCS BUILD STRING OF APPROPRIATE LENGTH
12263: JSR SYSRD READ NEXT STANDARD INPUT IMAGE
12264: PPM ACS03 JUMP TO FAIL EXIT IF END OF FILE
12265: BRN ACS07 ELSE MERGE WITH OTHER FILE CASE
12266: *
12267: * HERE FOR INPUT FROM OTHER THAN STANDARD INPUT FILE
12268: *
12269: ACS06 MOV XL,WA FCBLK PTR
12270: JSR SYSIL GET INPUT RECORD MAX LENGTH (TO WA)
12271: JSR ALOCS ALLOCATE STRING OF CORRECT SIZE
12272: MOV XL,WA FCBLK PTR
12273: JSR SYSIN CALL SYSTEM INPUT ROUTINE
12274: PPM ACS03 JUMP TO FAIL EXIT IF END OF FILE
12275: PPM ACS22 ERROR
12276: PPM ACS23 ERROR
12277: EJC
12278: *
12279: * ACESS (CONTINUED)
12280: *
12281: * MERGE HERE AFTER OBTAINING INPUT RECORD
12282: *
12283: ACS07 MOV KVTRM,WB LOAD TRIM INDICATOR
12284: JSR TRIMR TRIM RECORD AS REQUIRED
12285: MOV XR,WB COPY RESULT POINTER
12286: MOV (XS),XR RELOAD POINTER TO TRBLK
12287: *
12288: * LOOP TO CHASE TO END OF TRBLK CHAIN AND STORE VALUE
12289: *
12290: ACS08 MOV XR,XL SAVE POINTER TO THIS TRBLK
12291: MOV TRNXT(XR),XR LOAD FORWARD POINTER
12292: BEQ (XR),=B$TRT,ACS08 LOOP IF THIS IS ANOTHER TRBLK
12293: MOV WB,TRNXT(XL) ELSE STORE RESULT AT END OF CHAIN
12294: MOV (XS)+,XR RESTORE INITIAL TRBLK POINTER
12295: MOV (XS)+,WA RESTORE NAME OFFSET
12296: MOV (XS)+,XL RESTORE NAME BASE POINTER
12297: *
12298: * COME HERE TO MOVE TO NEXT TRBLK
12299: *
12300: ACS09 MOV TRNXT(XR),XR LOAD FORWARD PTR TO NEXT VALUE
12301: BRN ACS02 BACK TO CHECK IF TRAPPED
12302: *
12303: * HERE TO CHECK FOR ACCESS TRACE TRBLK
12304: *
12305: ACS10 BNE WB,=TRTAC,ACS09 LOOP BACK IF NOT ACCESS TRACE
12306: BZE KVTRA,ACS09 IGNORE ACCESS TRACE IF TRACE OFF
12307: DCV KVTRA ELSE DECREMENT TRACE COUNT
12308: BZE TRFNC(XR),ACS11 JUMP IF PRINT TRACE
12309: EJC
12310: *
12311: * ACESS (CONTINUED)
12312: *
12313: * HERE FOR FULL FUNCTION TRACE
12314: *
12315: JSR TRXEQ CALL ROUTINE TO EXECUTE TRACE
12316: BRN ACS09 JUMP FOR NEXT TRBLK
12317: *
12318: * HERE FOR CASE OF PRINT TRACE
12319: *
12320: ACS11 JSR PRTSN PRINT STATEMENT NUMBER
12321: JSR PRTNV PRINT NAME = VALUE
12322: BRN ACS09 JUMP BACK FOR NEXT TRBLK
12323: *
12324: * HERE FOR KEYWORD VARIABLE
12325: *
12326: ACS12 MOV KVNUM(XL),XR LOAD KEYWORD NUMBER
12327: BGE XR,=K$V$$,ACS14 JUMP IF NOT ONE WORD VALUE
12328: MTI KVABE(XR) ELSE LOAD VALUE AS INTEGER
12329: *
12330: * COMMON EXIT WITH KEYWORD VALUE AS INTEGER IN (IA)
12331: *
12332: ACS13 JSR ICBLD BUILD ICBLK
12333: BRN ACS18 JUMP TO EXIT
12334: *
12335: * HERE IF NOT ONE WORD KEYWORD VALUE
12336: *
12337: ACS14 BGE XR,=K$S$$,ACS15 JUMP IF SPECIAL CASE
12338: SUB =K$V$$,XR ELSE GET OFFSET
12339: ADD =NDABO,XR POINT TO PATTERN VALUE
12340: BRN ACS18 JUMP TO EXIT
12341: *
12342: * HERE IF SPECIAL KEYWORD CASE
12343: *
12344: ACS15 MOV KVRTN,XL LOAD RTNTYPE IN CASE
12345: LDI KVSTL LOAD STLIMIT IN CASE
12346: SUB =K$S$$,XR GET CASE NUMBER
12347: BSW XR,5 SWITCH ON KEYWORD NUMBER
12348: IFF K$$AL,ACS16 JUMP IF ALPHABET
12349: IFF K$$RT,ACS17 RTNTYPE
12350: IFF K$$SC,ACS19 STCOUNT
12351: IFF K$$SL,ACS13 STLIMIT
12352: IFF K$$ET,ACS20 ERRTEXT
12353: ESW END SWITCH ON KEYWORD NUMBER
12354: EJC
12355: *
12356: * ACESS (CONTINUED)
12357: *
12358: * ALPHABET
12359: *
12360: ACS16 MOV KVALP,XL LOAD POINTER TO ALPHABET STRING
12361: *
12362: * RTNTYPE MERGES HERE
12363: *
12364: ACS17 MOV XL,XR COPY STRING PTR TO PROPER REG
12365: *
12366: * COMMON RETURN POINT
12367: *
12368: ACS18 EXI RETURN TO ACESS CALLER
12369: *
12370: * HERE FOR STCOUNT (IA HAS STLIMIT)
12371: *
12372: ACS19 SBI KVSTC STCOUNT = LIMIT - LEFT
12373: BRN ACS13 MERGE BACK WITH INTEGER RESULT
12374: *
12375: * ERRTEXT
12376: *
12377: ACS20 MOV R$ETX,XR GET ERRTEXT STRING
12378: BRN ACS18 MERGE WITH RESULT
12379: *
12380: * HERE TO READ A RECORD FROM TERMINAL
12381: *
12382: ACS21 MOV =RILEN,WA BUFFER LENGTH
12383: JSR ALOCS ALLOCATE BUFFER
12384: JSR SYSRI READ RECORD
12385: PPM ACS03 ENDFILE
12386: BRN ACS07 MERGE WITH RECORD READ
12387: *
12388: * ERROR RETURNS
12389: *
12390: ACS22 MOV XR,DNAMP POP UNUSED SCBLK
12391: ERB 202,INPUT FROM FILE CAUSED NON-RECOVERABLE ERROR
12392: *
12393: ACS23 MOV XR,DNAMP POP UNUSED SCBLK
12394: ERB 203,INPUT FILE RECORD HAS INCORRECT FORMAT
12395: ENP END PROCEDURE ACESS
12396: EJC
12397: *
12398: * ACOMP -- COMPARE TWO ARITHMETIC VALUES
12399: *
12400: * 1(XS) FIRST ARGUMENT
12401: * 0(XS) SECOND ARGUMENT
12402: * JSR ACOMP CALL TO COMPARE VALUES
12403: * PPM LOC TRANSFER LOC IF ARG1 IS NON-NUMERIC
12404: * PPM LOC TRANSFER LOC IF ARG2 IS NON-NUMERIC
12405: * PPM LOC TRANSFER LOC FOR ARG1 LT ARG2
12406: * PPM LOC TRANSFER LOC FOR ARG1 EQ ARG2
12407: * PPM LOC TRANSFER LOC FOR ARG1 GT ARG2
12408: * (NORMAL RETURN IS NEVER GIVEN)
12409: * (WA,WB,WC,IA,RA) DESTROYED
12410: * (XL,XR) DESTROYED
12411: *
12412: ACOMP PRC N,5 ENTRY POINT
12413: JSR ARITH LOAD ARITHMETIC OPERANDS
12414: PPM ACMP7 JUMP IF FIRST ARG NON-NUMERIC
12415: PPM ACMP8 JUMP IF SECOND ARG NON-NUMERIC
12416: .IF .CNRA
12417: .ELSE
12418: PPM ACMP4 JUMP IF REAL ARGUMENTS
12419: .FI
12420: *
12421: * HERE FOR INTEGER ARGUMENTS
12422: *
12423: SBI ICVAL(XL) SUBTRACT TO COMPARE
12424: IOV ACMP3 JUMP IF OVERFLOW
12425: ILT ACMP5 ELSE JUMP IF ARG1 LT ARG2
12426: IEQ ACMP2 JUMP IF ARG1 EQ ARG2
12427: *
12428: * HERE IF ARG1 GT ARG2
12429: *
12430: ACMP1 EXI 5 TAKE GT EXIT
12431: *
12432: * HERE IF ARG1 EQ ARG2
12433: *
12434: ACMP2 EXI 4 TAKE EQ EXIT
12435: EJC
12436: *
12437: * ACOMP (CONTINUED)
12438: *
12439: * HERE FOR INTEGER OVERFLOW ON SUBTRACT
12440: *
12441: ACMP3 LDI ICVAL(XL) LOAD SECOND ARGUMENT
12442: ILT ACMP1 GT IF NEGATIVE
12443: BRN ACMP5 ELSE LT
12444: .IF .CNRA
12445: .ELSE
12446: *
12447: * HERE FOR REAL OPERANDS
12448: *
12449: ACMP4 SBR RCVAL(XL) SUBTRACT TO COMPARE
12450: ROV ACMP6 JUMP IF OVERFLOW
12451: RGT ACMP1 ELSE JUMP IF ARG1 GT
12452: REQ ACMP2 JUMP IF ARG1 EQ ARG2
12453: .FI
12454: *
12455: * HERE IF ARG1 LT ARG2
12456: *
12457: ACMP5 EXI 3 TAKE LT EXIT
12458: .IF .CNRA
12459: .ELSE
12460: *
12461: * HERE IF OVERFLOW ON REAL SUBTRACTION
12462: *
12463: ACMP6 LDR RCVAL(XL) RELOAD ARG2
12464: RLT ACMP1 GT IF NEGATIVE
12465: BRN ACMP5 ELSE LT
12466: .FI
12467: *
12468: * HERE IF ARG1 NON-NUMERIC
12469: *
12470: ACMP7 EXI 1 TAKE ERROR EXIT
12471: *
12472: * HERE IF ARG2 NON-NUMERIC
12473: *
12474: ACMP8 EXI 2 TAKE ERROR EXIT
12475: ENP END PROCEDURE ACOMP
12476: EJC
12477: *
12478: * ALLOC ALLOCATE BLOCK OF DYNAMIC STORAGE
12479: *
12480: * (WA) LENGTH REQUIRED IN BYTES
12481: * JSR ALLOC CALL TO ALLOCATE BLOCK
12482: * (XR) POINTER TO ALLOCATED BLOCK
12483: *
12484: * A POSSIBLE ALTERNATIVE TO AOV .. AND FOLLOWING STMT IS -
12485: * MOV DNAME,XR . SUB WA,XR . BLO XR,DNAMP,ALOC2 .
12486: * MOV DNAMP,XR . ADD WA,XR
12487: *
12488: ALLOC PRC E,0 ENTRY POINT
12489: *
12490: * COMMON EXIT POINT
12491: *
12492: ALOC1 MOV DNAMP,XR POINT TO NEXT AVAILABLE LOC
12493: AOV WA,XR,ALOC2 POINT PAST ALLOCATED BLOCK
12494: BGT XR,DNAME,ALOC2 JUMP IF NOT ENOUGH ROOM
12495: MOV XR,DNAMP STORE NEW POINTER
12496: SUB WA,XR POINT BACK TO START OF ALLOCATED BK
12497: EXI RETURN TO CALLER
12498: *
12499: * HERE IF INSUFFICIENT ROOM, TRY A GARBAGE COLLECTION
12500: *
12501: ALOC2 MOV WB,ALLSV SAVE WB
12502: ZER WB SET NO UPWARD MOVE FOR GBCOL
12503: JSR GBCOL GARBAGE COLLECT
12504: *
12505: * SEE IF ROOM AFTER GBCOL OR SYSMM CALL
12506: *
12507: ALOC3 MOV DNAMP,XR POINT TO FIRST AVAILABLE LOC
12508: AOV WA,XR,ALC3A POINT PAST NEW BLOCK
12509: BLO XR,DNAME,ALOC4 JUMP IF THERE IS ROOM NOW
12510: *
12511: * FAILED AGAIN, SEE IF WE CAN GET MORE CORE
12512: *
12513: ALC3A JSR SYSMM TRY TO GET MORE MEMORY
12514: WTB XR CONVERT TO BAUS (SGD05)
12515: ADD XR,DNAME BUMP PTR BY AMOUNT OBTAINED
12516: BNZ XR,ALOC3 JUMP IF GOT MORE CORE
12517: ADD RSMEM,DNAME GET THE RESERVE MEMORY
12518: ZER RSMEM ONLY PERMISSIBLE ONCE
12519: ICV ERRFT FATAL ERROR
12520: ERB 204,MEMORY OVERFLOW
12521: EJC
12522: *
12523: * HERE AFTER SUCCESSFUL GARBAGE COLLECTION
12524: *
12525: ALOC4 STI ALLIA SAVE IA
12526: MOV DNAME,WB GET DYNAMIC END ADRS
12527: SUB DNAMP,WB COMPUTE FREE STORE
12528: BTW WB CONVERT BYTES TO WORDS
12529: MTI WB PUT FREE STORE IN IA
12530: MLI ALFSF MULTIPLY BY FREE STORE FACTOR
12531: IOV ALOC5 JUMP IF OVERFLOWED
12532: MOV DNAME,WB DYNAMIC END ADRS
12533: SUB DNAMB,WB COMPUTE TOTAL AMOUNT OF DYNAMIC
12534: BTW WB CONVERT TO WORDS
12535: MOV WB,ALDYN STORE IT
12536: SBI ALDYN SUBTRACT FROM SCALED UP FREE STORE
12537: IGT ALOC5 JUMP IF SUFFICIENT FREE STORE
12538: JSR SYSMM TRY TO GET MORE STORE
12539: WTB XR CONVERT TO BAUS (SGD05)
12540: ADD XR,DNAME ADJUST DYNAMIC END ADRS
12541: *
12542: * MERGE TO RESTORE IA AND WB
12543: *
12544: ALOC5 LDI ALLIA RECOVER IA
12545: MOV ALLSV,WB RESTORE WB
12546: BRN ALOC1 JUMP BACK TO EXIT
12547: ENP END PROCEDURE ALLOC
12548: EJC
12549: .IF .CNBF
12550: .ELSE
12551: *
12552: * ALOBF -- ALLOCATE BUFFER
12553: *
12554: * THIS ROUTINES ALLOCATES A NEW BUFFER. AS THE BFBLK
12555: * AND BCBLK COME IN PAIRS, BOTH ARE ALLOCATED HERE,
12556: * AND XR POINTS TO THE BCBLK ON RETURN. THE BFBLK
12557: * AND BCBLK ARE SET TO THE NULL BUFFER, AND THE IDVAL
12558: * IS ZERO ON RETURN.
12559: *
12560: * (WA) BUFFER SIZE IN CHARACTERS
12561: * JSR ALOBF CALL TO CREATE BUFFER
12562: * (XR) BCBLK PTR
12563: * (WA,WB) DESTROYED
12564: *
12565: ALOBF PRC E,0 ENTRY POINT
12566: MOV WA,WB HANG ONTO ALLOCATION SIZE
12567: CTB WA,BFSI$ GET TOTAL BLOCK SIZE
12568: BGE WA,MXLEN,ALB01 CHECK FOR MAXLEN EXCEEDED
12569: ADD *BCSI$,WA ADD IN ALLOCATION FOR BCBLK
12570: JSR ALLOC ALLOCATE FRAME
12571: MOV =B$BCT,(XR) SET TYPE
12572: ZER IDVAL(XR) NO ID YET
12573: ZER BCLEN(XR) NO DEFINED LENGTH
12574: MOV XL,WA SAVE XL
12575: MOV XR,XL COPY BCBLK PTR
12576: ADD *BCSI$,XL BIAS PAST PARTIALLY BUILT BCBLK
12577: MOV =B$BFT,(XL) SET BFBLK TYPE WORD
12578: MOV WB,BFALC(XL) SET ALLOCATED SIZE
12579: MOV XL,BCBUF(XR) SET POINTER IN BCBLK
12580: ZER BFCHR(XL) CLEAR FIRST WORD (NULL PAD)
12581: MOV WA,XL RESTORE ENTRY XL
12582: EXI RETURN TO CALLER
12583: *
12584: * HERE FOR MXLEN EXCEEDED
12585: *
12586: ALB01 ERB 274,REQUESTED BUFFER ALLOCATION EXCEEDS MXLEN
12587: ENP END PROCEDURE ALOBF
12588: EJC
12589: .FI
12590: *
12591: * ALOCS -- ALLOCATE STRING BLOCK
12592: *
12593: * ALOCS IS USED TO BUILD A FRAME FOR A STRING BLOCK INTO
12594: * WHICH THE ACTUAL CHARACTERS ARE PLACED BY THE CALLER.
12595: * ALL STRINGS ARE CREATED WITH A CALL TO ALOCS (THE
12596: * EXCEPTIONS OCCUR IN TRIMR AND S$RPL PROCEDURES).
12597: *
12598: * (WA) LENGTH OF STRING TO BE ALLOCATED
12599: * JSR ALOCS CALL TO ALLOCATE SCBLK
12600: * (XR) POINTER TO RESULTING SCBLK
12601: * (WA) DESTROYED
12602: * (WC) CHARACTER COUNT (ENTRY VALUE OF WA)
12603: *
12604: * THE RESULTING SCBLK HAS THE TYPE WORD AND THE LENGTH
12605: * FILLED IN AND THE LAST WORD IS CLEARED TO ZERO CHARACTERS
12606: * TO ENSURE CORRECT RIGHT PADDING OF THE FINAL WORD.
12607: *
12608: ALOCS PRC E,0 ENTRY POINT
12609: BGT WA,KVMXL,ALCS2 JUMP IF LENGTH EXCEEEDS MAXLENGTH
12610: MOV WA,WC ELSE COPY LENGTH
12611: CTB WA,SCSI$ COMPUTE LENGTH OF SCBLK IN BYTES
12612: MOV DNAMP,XR POINT TO NEXT AVAILABLE LOCATION
12613: AOV WA,XR,ALCS0 POINT PAST BLOCK
12614: BLO XR,DNAME,ALCS1 JUMP IF THERE IS ROOM
12615: *
12616: * INSUFFICIENT MEMORY
12617: *
12618: ALCS0 ZER XR ELSE CLEAR GARBAGE XR VALUE
12619: JSR ALLOC AND USE STANDARD ALLOCATOR
12620: ADD WA,XR POINT PAST END OF BLOCK TO MERGE
12621: *
12622: * MERGE HERE WITH XR POINTING BEYOND NEW BLOCK
12623: *
12624: ALCS1 MOV XR,DNAMP SET UPDATED STORAGE POINTER
12625: ZER -(XR) STORE ZERO CHARS IN LAST WORD
12626: DCA WA DECREMENT LENGTH
12627: SUB WA,XR POINT BACK TO START OF BLOCK
12628: MOV =B$SCL,(XR) SET TYPE WORD
12629: MOV WC,SCLEN(XR) STORE LENGTH IN CHARS
12630: EXI RETURN TO ALOCS CALLER
12631: *
12632: * COME HERE IF STRING IS TOO LONG
12633: *
12634: ALCS2 ERB 205,STRING LENGTH EXCEEDS VALUE OF MAXLNGTH KEYWORD
12635: ENP END PROCEDURE ALOCS
12636: EJC
12637: *
12638: * ALOST -- ALLOCATE SPACE IN STATIC REGION
12639: *
12640: * (WA) LENGTH REQUIRED IN BYTES
12641: * JSR ALOST CALL TO ALLOCATE SPACE
12642: * (XR) POINTER TO ALLOCATED BLOCK
12643: * (WB) DESTROYED
12644: *
12645: * NOTE THAT THE CODING ENSURES THAT THE RESULTING VALUE
12646: * OF STATE IS ALWAYS LESS THAN DNAMB. THIS FACT IS USED
12647: * IN TESTING A VARIABLE NAME FOR BEING IN THE STATIC REGION
12648: *
12649: ALOST PRC E,0 ENTRY POINT
12650: *
12651: * MERGE BACK HERE AFTER ALLOCATING NEW CHUNK
12652: *
12653: ALST1 MOV STATE,XR POINT TO CURRENT END OF AREA
12654: AOV WA,XR,ALST2 POINT BEYOND PROPOSED BLOCK
12655: BGE XR,DNAMB,ALST2 JUMP IF OVERLAP WITH DYNAMIC AREA
12656: MOV XR,STATE ELSE STORE NEW POINTER
12657: SUB WA,XR POINT BACK TO START OF BLOCK
12658: EXI RETURN TO ALOST CALLER
12659: *
12660: * HERE IF NO ROOM, PREPARE TO MOVE DYNAMIC STORAGE UP
12661: *
12662: ALST2 MOV WA,ALSTA SAVE WA
12663: BGE WA,*E$STS,ALST3 SKIP IF REQUESTED CHUNK IS LARGE
12664: MOV *E$STS,WA ELSE SET TO GET LARGE ENOUGH CHUNK
12665: *
12666: * HERE WITH AMOUNT TO MOVE UP IN WA
12667: *
12668: ALST3 JSR ALLOC ALLOCATE BLOCK TO ENSURE ROOM
12669: MOV XR,DNAMP AND DELETE IT
12670: MOV WA,WB COPY MOVE UP AMOUNT
12671: JSR GBCOL CALL GBCOL TO MOVE DYNAMIC AREA UP
12672: MOV ALSTA,WA RESTORE WA
12673: BRN ALST1 LOOP BACK TO TRY AGAIN
12674: ENP END PROCEDURE ALOST
12675: EJC
12676: .IF .CNBF
12677: .ELSE
12678: *
12679: * APNDB -- APPEND STRING TO BUFFER
12680: *
12681: * THIS ROUTINE IS USED BY BUFFER HANDLING ROUTINES TO
12682: * APPEND DATA TO AN EXISTING BFBLK.
12683: *
12684: * (XR) EXISTING BCBLK TO BE APPENDED
12685: * (XL) CONVERTABLE TO STRING
12686: * JSR APNDB CALL TO APPEND TO BUFFER
12687: * PPM LOC THREAD IF (XL) CANT BE CONVERTED
12688: * PPM LOC IF NOT ENOUGH ROOM
12689: * (WA,WB) DESTROYED
12690: *
12691: * IF MORE CHARACTERS ARE SPECIFIED THAN CAN BE INSERTED,
12692: * THEN NO ACTION IS TAKEN AND THE SECOND RETURN IS TAKEN.
12693: *
12694: APNDB PRC E,2 ENTRY POINT
12695: MOV BCLEN(XR),WA LOAD OFFSET TO INSERT
12696: ZER WB REPLACE SECTION IS NULL
12697: JSR INSBF CALL TO INSERT AT END
12698: PPM APN01 CONVERT ERROR
12699: PPM APN02 NO ROOM
12700: EXI RETURN TO CALLER
12701: *
12702: * HERE TO TAKE CONVERT FAILURE EXIT
12703: *
12704: APN01 EXI 1 RETURN TO CALLER ALTERNATE
12705: *
12706: * HERE FOR NO FIT EXIT
12707: *
12708: APN02 EXI 2 ALTERNATE EXIT TO CALLER
12709: ENP END PROCEDURE APNDB
12710: EJC
12711: .FI
12712: *
12713: * ARITH -- FETCH ARITHMETIC OPERANDS
12714: *
12715: * ARITH IS USED BY FUNCTIONS AND OPERATORS WHICH EXPECT
12716: * TWO NUMERIC ARGUMENTS (OPERANDS) WHICH MUST BOTH BE
12717: * INTEGER OR BOTH BE REAL. ARITH FETCHES TWO ARGUMENTS FROM
12718: * THE STACK AND PERFORMS ANY NECESSARY CONVERSIONS.
12719: *
12720: * 1(XS) FIRST ARGUMENT (LEFT OPERAND)
12721: * 0(XS) SECOND ARGUMENT (RIGHT OPERAND)
12722: * JSR ARITH CALL TO FETCH NUMERIC ARGUMENTS
12723: * PPM LOC TRANSFER LOC FOR OPND 1 NON-NUMERIC
12724: * PPM LOC TRANSFER LOC FOR OPND 2 NON-NUMERIC
12725: .IF .CNRA
12726: .ELSE
12727: * PPM LOC TRANSFER LOC FOR REAL OPERANDS
12728: .FI
12729: *
12730: * FOR INTEGER ARGS, CONTROL RETURNS PAST THE PARAMETERS
12731: *
12732: * (IA) LEFT OPERAND VALUE
12733: * (XR) PTR TO ICBLK FOR LEFT OPERAND
12734: * (XL) PTR TO ICBLK FOR RIGHT OPERAND
12735: * (XS) POPPED TWICE
12736: * (WA,WB,RA) DESTROYED
12737: .IF .CNRA
12738: .ELSE
12739: *
12740: * FOR REAL ARGUMENTS, CONTROL RETURNS TO THE LOCATION
12741: * SPECIFIED BY THE THIRD PARAMETER.
12742: *
12743: * (RA) LEFT OPERAND VALUE
12744: * (XR) PTR TO RCBLK FOR LEFT OPERAND
12745: * (XL) PTR TO RCBLK FOR RIGHT OPERAND
12746: * (WA,WB,WC) DESTROYED
12747: * (XS) POPPED TWICE
12748: .FI
12749: EJC
12750: *
12751: * ARITH (CONTINUED)
12752: *
12753: * ENTRY POINT
12754: *
12755: .IF .CNRA
12756: ARITH PRC N,2 ENTRY POINT
12757: .ELSE
12758: ARITH PRC N,3 ENTRY POINT
12759: .FI
12760: MOV (XS)+,XL LOAD RIGHT OPERAND
12761: MOV (XS)+,XR LOAD LEFT OPERAND
12762: MOV (XL),WA GET RIGHT OPERAND TYPE WORD
12763: BEQ WA,=B$ICL,ARTH1 JUMP IF INTEGER
12764: .IF .CNRA
12765: .ELSE
12766: BEQ WA,=B$RCL,ARTH4 JUMP IF REAL
12767: .FI
12768: MOV XR,-(XS) ELSE REPLACE LEFT ARG ON STACK
12769: MOV XL,XR COPY LEFT ARG POINTER
12770: JSR GTNUM CONVERT TO NUMERIC
12771: PPM ARTH6 JUMP IF UNCONVERTIBLE
12772: MOV XR,XL ELSE COPY CONVERTED RESULT
12773: MOV (XL),WA GET RIGHT OPERAND TYPE WORD
12774: MOV (XS)+,XR RELOAD LEFT ARGUMENT
12775: .IF .CNRA
12776: .ELSE
12777: BEQ WA,=B$RCL,ARTH4 JUMP IF RIGHT ARG IS REAL
12778: .FI
12779: *
12780: * HERE IF RIGHT ARG IS AN INTEGER
12781: *
12782: ARTH1 BNE (XR),=B$ICL,ARTH3 JUMP IF LEFT ARG NOT INTEGER
12783: *
12784: * EXIT FOR INTEGER CASE
12785: *
12786: ARTH2 LDI ICVAL(XR) LOAD LEFT OPERAND VALUE
12787: EXI RETURN TO ARITH CALLER
12788: *
12789: * HERE FOR RIGHT OPERAND INTEGER, LEFT OPERAND NOT
12790: *
12791: ARTH3 JSR GTNUM CONVERT LEFT ARG TO NUMERIC
12792: PPM ARTH7 JUMP IF NOT CONVERTIBLE
12793: BEQ WA,=B$ICL,ARTH2 JUMP BACK IF INTEGER-INTEGER
12794: .IF .CNRA
12795: .ELSE
12796: *
12797: * HERE WE MUST CONVERT REAL-INTEGER TO REAL-REAL
12798: *
12799: MOV XR,-(XS) PUT LEFT ARG BACK ON STACK
12800: LDI ICVAL(XL) LOAD RIGHT ARGUMENT VALUE
12801: ITR CONVERT TO REAL
12802: JSR RCBLD GET REAL BLOCK FOR RIGHT ARG, MERGE
12803: MOV XR,XL COPY RIGHT ARG PTR
12804: MOV (XS)+,XR LOAD LEFT ARGUMENT
12805: BRN ARTH5 MERGE FOR REAL-REAL CASE
12806: EJC
12807: *
12808: * ARITH (CONTINUED)
12809: *
12810: * HERE IF RIGHT ARGUMENT IS REAL
12811: *
12812: ARTH4 BEQ (XR),=B$RCL,ARTH5 JUMP IF LEFT ARG REAL
12813: JSR GTREA ELSE CONVERT TO REAL
12814: PPM ARTH7 ERROR IF UNCONVERTIBLE
12815: *
12816: * HERE FOR REAL-REAL
12817: *
12818: ARTH5 LDR RCVAL(XR) LOAD LEFT OPERAND VALUE
12819: EXI 3 TAKE REAL-REAL EXIT
12820: .FI
12821: *
12822: * HERE FOR ERROR CONVERTING RIGHT ARGUMENT
12823: *
12824: ARTH6 ICA XS POP UNWANTED LEFT ARG
12825: EXI 2 TAKE APPROPRIATE ERROR EXIT
12826: *
12827: * HERE FOR ERROR CONVERTING LEFT OPERAND
12828: *
12829: ARTH7 EXI 1 TAKE APPROPRIATE ERROR RETURN
12830: ENP END PROCEDURE ARITH
12831: EJC
12832: *
12833: * ASIGN -- PERFORM ASSIGNMENT
12834: *
12835: * ASIGN PERFORMS THE ASSIGNMENT OF A VALUE TO A VARIABLE
12836: * WITH APPROPRIATE CHECKS FOR OUTPUT ASSOCIATIONS AND
12837: * VALUE TRACE ASSOCIATIONS WHICH ARE EXECUTED AS REQUIRED.
12838: * ASIGN ALSO HANDLES THE SPECIAL CASES OF ASSIGNMENT TO
12839: * PATTERN AND EXPRESSION VARIABLES.
12840: *
12841: * (WB) VALUE TO BE ASSIGNED
12842: * (XL) BASE POINTER FOR VARIABLE
12843: * (WA) OFFSET FOR VARIABLE
12844: * JSR ASIGN CALL TO ASSIGN VALUE TO VARIABLE
12845: * PPM LOC TRANSFER LOC FOR FAILURE
12846: * (XR,XL,WA,WB,WC) DESTROYED
12847: * (RA) DESTROYED
12848: *
12849: * FAILURE OCCURS IF THE EVALUATION OF AN EXPRESSION
12850: * ASSOCIATED WITH AN EXPRESSION VARIABLE FAILS.
12851: *
12852: ASIGN PRC R,1 ENTRY POINT (RECURSIVE)
12853: *
12854: * MERGE BACK HERE TO ASSIGN RESULT TO EXPRESSION VARIABLE.
12855: *
12856: ASG01 ADD WA,XL POINT TO VARIABLE VALUE
12857: MOV (XL),XR LOAD VARIABLE VALUE
12858: BEQ (XR),=B$TRT,ASG02 JUMP IF TRAPPED
12859: MOV WB,(XL) ELSE PERFORM ASSIGNMENT
12860: ZER XL CLEAR GARBAGE VALUE IN XL
12861: EXI AND RETURN TO ASIGN CALLER
12862: *
12863: * HERE IF VALUE IS TRAPPED
12864: *
12865: ASG02 SUB WA,XL RESTORE NAME BASE
12866: BEQ XR,=TRBKV,ASG14 JUMP IF KEYWORD VARIABLE
12867: BNE XR,=TRBEV,ASG04 JUMP IF NOT EXPRESSION VARIABLE
12868: *
12869: * HERE FOR ASSIGNMENT TO EXPRESSION VARIABLE
12870: *
12871: MOV EVEXP(XL),XR POINT TO EXPRESSION
12872: MOV WB,-(XS) STORE VALUE TO ASSIGN ON STACK
12873: MOV =NUM01,WB SET FOR EVALUATION BY NAME
12874: JSR EVALX EVALUATE EXPRESSION BY NAME
12875: PPM ASG03 JUMP IF EVALUATION FAILS
12876: MOV (XS)+,WB ELSE RELOAD VALUE TO ASSIGN
12877: BRN ASG01 LOOP BACK TO PERFORM ASSIGNMENT
12878: EJC
12879: *
12880: * ASIGN (CONTINUED)
12881: *
12882: * HERE FOR FAILURE DURING EXPRESSION EVALUATION
12883: *
12884: ASG03 ICA XS REMOVE STACKED VALUE ENTRY
12885: EXI 1 TAKE FAILURE EXIT
12886: *
12887: * HERE IF NOT KEYWORD OR EXPRESSION VARIABLE
12888: *
12889: ASG04 MOV XR,-(XS) SAVE PTR TO FIRST TRBLK
12890: *
12891: * LOOP TO CHASE DOWN TRBLK CHAIN AND ASSIGN VALUE AT END
12892: *
12893: ASG05 MOV XR,WC SAVE PTR TO THIS TRBLK
12894: MOV TRNXT(XR),XR POINT TO NEXT TRBLK
12895: BEQ (XR),=B$TRT,ASG05 LOOP BACK IF ANOTHER TRBLK
12896: MOV WC,XR ELSE POINT BACK TO LAST TRBLK
12897: MOV WB,TRVAL(XR) STORE VALUE AT END OF CHAIN
12898: MOV (XS)+,XR RESTORE PTR TO FIRST TRBLK
12899: *
12900: * LOOP TO PROCESS TRBLK ENTRIES ON CHAIN
12901: *
12902: ASG06 MOV TRTYP(XR),WB LOAD TYPE CODE OF TRBLK
12903: BEQ WB,=TRTVL,ASG08 JUMP IF VALUE TRACE
12904: BEQ WB,=TRTOU,ASG10 JUMP IF OUTPUT ASSOCIATION
12905: *
12906: * HERE TO MOVE TO NEXT TRBLK ON CHAIN
12907: *
12908: ASG07 MOV TRNXT(XR),XR POINT TO NEXT TRBLK ON CHAIN
12909: BEQ (XR),=B$TRT,ASG06 LOOP BACK IF ANOTHER TRBLK
12910: EXI ELSE END OF CHAIN, RETURN TO CALLER
12911: *
12912: * HERE TO PROCESS VALUE TRACE
12913: *
12914: ASG08 BZE KVTRA,ASG07 IGNORE VALUE TRACE IF TRACE OFF
12915: DCV KVTRA ELSE DECREMENT TRACE COUNT
12916: BZE TRFNC(XR),ASG09 JUMP IF PRINT TRACE
12917: JSR TRXEQ ELSE EXECUTE FUNCTION TRACE
12918: BRN ASG07 AND LOOP BACK
12919: EJC
12920: *
12921: * ASIGN (CONTINUED)
12922: *
12923: * HERE FOR PRINT TRACE
12924: *
12925: ASG09 JSR PRTSN PRINT STATEMENT NUMBER
12926: JSR PRTNV PRINT NAME = VALUE
12927: BRN ASG07 LOOP BACK FOR NEXT TRBLK
12928: *
12929: * HERE FOR OUTPUT ASSOCIATION
12930: *
12931: ASG10 BZE KVOUP,ASG07 IGNORE OUTPUT ASSOC IF OUTPUT OFF
12932: MOV XR,XL ELSE COPY TRBLK POINTER
12933: MOV TRVAL(WC),-(XS) STACK VALUE TO OUTPUT (SGD01)
12934: JSR GTSTG CONVERT TO STRING
12935: PPM ASG12 GET DATATYPE NAME IF UNCONVERTIBLE
12936: *
12937: * MERGE WITH STRING FOR OUTPUT
12938: *
12939: ASG11 MOV TRFPT(XL),WA FCBLK PTR
12940: BZE WA,ASG13 JUMP IF STANDARD OUTPUT FILE
12941: *
12942: * HERE FOR OUTPUT TO NON-STANDARD OUTPUT FILE
12943: *
12944: JSR SYSOU CALL SYSTEM OUTPUT ROUTINE
12945: ERR 206,OUTPUT CAUSED FILE OVERFLOW
12946: ERR 207,OUTPUT CAUSED NON-RECOVERABLE ERROR
12947: EXI ELSE ALL DONE, RETURN TO CALLER
12948: *
12949: * IF NOT PRINTABLE, GET DATATYPE NAME INSTEAD
12950: *
12951: ASG12 JSR DTYPE CALL DATATYPE ROUTINE
12952: BRN ASG11 MERGE
12953: *
12954: * HERE TO PRINT A STRING ON THE PRINTER
12955: *
12956: ASG13 JSR PRTST PRINT STRING VALUE
12957: BEQ TRTER(XL),=V$TER,ASG20 JUMP IF TERMINAL OUTPUT
12958: JSR PRTNL END OF LINE
12959: EXI RETURN TO CALLER
12960: EJC
12961: *
12962: * ASIGN (CONTINUED)
12963: *
12964: * HERE FOR KEYWORD ASSIGNMENT
12965: *
12966: ASG14 MOV KVNUM(XL),XL LOAD KEYWORD NUMBER
12967: BEQ XL,=K$ETX,ASG19 JUMP IF ERRTEXT
12968: MOV WB,XR COPY VALUE TO BE ASSIGNED
12969: JSR GTINT CONVERT TO INTEGER
12970: ERR 208,KEYWORD VALUE ASSIGNED IS NOT INTEGER
12971: LDI ICVAL(XR) ELSE LOAD VALUE
12972: BEQ XL,=K$STL,ASG16 JUMP IF SPECIAL CASE OF STLIMIT
12973: MFI WA,ASG18 ELSE GET ADDR INTEGER, TEST OVFLOW
12974: BGE WA,MXLEN,ASG18 FAIL IF TOO LARGE
12975: BEQ XL,=K$ERT,ASG17 JUMP IF SPECIAL CASE OF ERRTYPE
12976: .IF .CNPF
12977: .ELSE
12978: BEQ XL,=K$PFL,ASG21 JUMP IF SPECIAL CASE OF PROFILE
12979: .FI
12980: BLT XL,=K$P$$,ASG15 JUMP UNLESS PROTECTED
12981: ERB 209,KEYWORD IN ASSIGNMENT IS PROTECTED
12982: *
12983: * HERE TO DO ASSIGNMENT IF NOT PROTECTED
12984: *
12985: ASG15 MOV WA,KVABE(XL) STORE NEW VALUE
12986: EXI RETURN TO ASIGN CALLER
12987: *
12988: * HERE FOR SPECIAL CASE OF STLIMIT
12989: *
12990: * SINCE STCOUNT IS MAINTAINED AS (STLIMIT-STCOUNT)
12991: * IT IS ALSO NECESSARY TO MODIFY STCOUNT APPROPRIATELY.
12992: *
12993: ASG16 SBI KVSTL SUBTRACT OLD LIMIT
12994: ADI KVSTC ADD OLD COUNTER
12995: STI KVSTC STORE NEW COUNTER VALUE
12996: LDI ICVAL(XR) RELOAD NEW LIMIT VALUE
12997: STI KVSTL STORE NEW LIMIT VALUE
12998: EXI RETURN TO ASIGN CALLER
12999: *
13000: * HERE FOR SPECIAL CASE OF ERRTYPE
13001: *
13002: ASG17 BLE WA,=NINI9,ERROR OK TO SIGNAL IF IN RANGE
13003: *
13004: * HERE IF VALUE ASSIGNED IS OUT OF RANGE
13005: *
13006: ASG18 ERB 210,KEYWORD VALUE ASSIGNED IS NEGATIVE OR TOO LARGE
13007: *
13008: * HERE FOR SPECIAL CASE OF ERRTEXT
13009: *
13010: ASG19 MOV WB,-(XS) STACK VALUE
13011: JSR GTSTG CONVERT TO STRING
13012: ERR 211,VALUE ASSIGNED TO KEYWORD ERRTEXT NOT A STRING
13013: MOV XR,R$ETX MAKE ASSIGNMENT
13014: EXI RETURN TO CALLER
13015: *
13016: * PRINT STRING TO TERMINAL
13017: *
13018: ASG20 JSR PRTTR PRINT
13019: EXI RETURN
13020: *
13021: .IF .CNPF
13022: .ELSE
13023: * HERE FOR KEYWORD PROFILE
13024: *
13025: ASG21 BGT WA,=NUM02,ASG18 MOAN IF NOT 0,1, OR 2
13026: BZE WA,ASG15 JUST ASSIGN IF ZERO
13027: BZE PFDMP,ASG22 BRANCH IF FIRST ASSIGNMENT
13028: BEQ WA,PFDMP,ASG23 ALSO IF SAME VALUE AS BEFORE
13029: ERB 268,INCONSISTENT VALUE ASSIGNED TO KEYWORD PROFILE
13030: *
13031: ASG22 MOV WA,PFDMP NOTE VALUE ON FIRST ASSIGNMENT
13032: ASG23 JSR SYSTM GET THE TIME
13033: STI PFSTM FUDGE SOME KIND OF START TIME
13034: BRN ASG15 AND GO ASSIGN
13035: .FI
13036: ENP END PROCEDURE ASIGN
13037: EJC
13038: *
13039: * ASINP -- ASSIGN DURING PATTERN MATCH
13040: *
13041: * ASINP IS LIKE ASIGN AND HAS A SIMILAR CALLING SEQUENCE
13042: * AND EFFECT. THE DIFFERENCE IS THAT THE GLOBAL PATTERN
13043: * VARIABLES ARE SAVED AND RESTORED IF REQUIRED.
13044: *
13045: * (XL) BASE POINTER FOR VARIABLE
13046: * (WA) OFFSET FOR VARIABLE
13047: * (WB) VALUE TO BE ASSIGNED
13048: * JSR ASINP CALL TO ASSIGN VALUE TO VARIABLE
13049: * PPM LOC TRANSFER LOC IF FAILURE
13050: * (XR,XL) DESTROYED
13051: * (WA,WB,WC,RA) DESTROYED
13052: *
13053: ASINP PRC R,1 ENTRY POINT, RECURSIVE
13054: ADD WA,XL POINT TO VARIABLE
13055: MOV (XL),XR LOAD CURRENT CONTENTS
13056: BEQ (XR),=B$TRT,ASNP1 JUMP IF TRAPPED
13057: MOV WB,(XL) ELSE PERFORM ASSIGNMENT
13058: ZER XL CLEAR GARBAGE VALUE IN XL
13059: EXI RETURN TO ASINP CALLER
13060: *
13061: * HERE IF VARIABLE IS TRAPPED
13062: *
13063: ASNP1 SUB WA,XL RESTORE BASE POINTER
13064: MOV PMSSL,-(XS) STACK SUBJECT STRING LENGTH
13065: MOV PMHBS,-(XS) STACK HISTORY STACK BASE PTR
13066: MOV R$PMS,-(XS) STACK SUBJECT STRING POINTER
13067: MOV PMDFL,-(XS) STACK DOT FLAG
13068: JSR ASIGN CALL FULL-BLOWN ASSIGNMENT ROUTINE
13069: PPM ASNP2 JUMP IF FAILURE
13070: MOV (XS)+,PMDFL RESTORE DOT FLAG
13071: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER
13072: MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER
13073: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH
13074: EXI RETURN TO ASINP CALLER
13075: *
13076: * HERE IF FAILURE IN ASIGN CALL
13077: *
13078: ASNP2 MOV (XS)+,PMDFL RESTORE DOT FLAG
13079: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER
13080: MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER
13081: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH
13082: EXI 1 TAKE FAILURE EXIT
13083: ENP END PROCEDURE ASINP
13084: EJC
13085: *
13086: * BLKLN -- DETERMINE LENGTH OF BLOCK
13087: *
13088: * BLKLN DETERMINES THE LENGTH OF A BLOCK IN DYNAMIC STORE.
13089: *
13090: * (WA) FIRST WORD OF BLOCK
13091: * (XR) POINTER TO BLOCK
13092: * JSR BLKLN CALL TO GET BLOCK LENGTH
13093: * (WA) LENGTH OF BLOCK IN BYTES
13094: * (XL) DESTROYED
13095: *
13096: * BLKLN IS USED BY THE GARBAGE COLLECTOR AND IS NOT
13097: * PERMITTED TO CALL GBCOL DIRECTLY OR INDIRECTLY.
13098: *
13099: * THE FIRST WORD STORED IN THE BLOCK (I.E. AT XR) MAY
13100: * BE ANYTHING, BUT THE CONTENTS OF WA MUST BE CORRECT.
13101: *
13102: BLKLN PRC E,0 ENTRY POINT
13103: MOV WA,XL COPY FIRST WORD
13104: LEI XL GET ENTRY ID (BL$XX)
13105: BSW XL,BL$$$,BLN00 SWITCH ON BLOCK TYPE
13106: IFF BL$AR,BLN01 ARBLK
13107: .IF .CNBF
13108: .ELSE
13109: IFF BL$BC,BLN04 BCBLK
13110: IFF BL$BF,BLN11 BFBLK
13111: .FI
13112: IFF BL$CD,BLN01 CDBLK
13113: IFF BL$DF,BLN01 DFBLK
13114: IFF BL$EF,BLN01 EFBLK
13115: IFF BL$EX,BLN01 EXBLK
13116: IFF BL$PF,BLN01 PFBLK
13117: IFF BL$TB,BLN01 TBBLK
13118: IFF BL$VC,BLN01 VCBLK
13119: IFF BL$EV,BLN03 EVBLK
13120: IFF BL$KV,BLN03 KVBLK
13121: IFF BL$P0,BLN02 P0BLK
13122: IFF BL$SE,BLN02 SEBLK
13123: IFF BL$NM,BLN03 NMBLK
13124: IFF BL$P1,BLN03 P1BLK
13125: IFF BL$P2,BLN04 P2BLK
13126: IFF BL$TE,BLN04 TEBLK
13127: IFF BL$FF,BLN05 FFBLK
13128: IFF BL$TR,BLN05 TRBLK
13129: IFF BL$CT,BLN06 CTBLK
13130: IFF BL$IC,BLN07 ICBLK
13131: IFF BL$PD,BLN08 PDBLK
13132: .IF .CNRA
13133: .ELSE
13134: IFF BL$RC,BLN09 RCBLK
13135: .FI
13136: IFF BL$SC,BLN10 SCBLK
13137: ESW END OF JUMP TABLE ON BLOCK TYPE
13138: EJC
13139: *
13140: * BLKLN (CONTINUED)
13141: *
13142: * HERE FOR BLOCKS WITH LENGTH IN SECOND WORD
13143: *
13144: BLN00 MOV 1(XR),WA LOAD LENGTH
13145: EXI RETURN TO BLKLN CALLER
13146: *
13147: * HERE FOR LENGTH IN THIRD WORD (AR,CD,DF,EF,EX,PF,TB,VC)
13148: *
13149: BLN01 MOV 2(XR),WA LOAD LENGTH FROM THIRD WORD
13150: EXI RETURN TO BLKLN CALLER
13151: *
13152: * HERE FOR TWO WORD BLOCKS (P0,SE)
13153: *
13154: BLN02 MOV *NUM02,WA LOAD LENGTH (TWO WORDS)
13155: EXI RETURN TO BLKLN CALLER
13156: *
13157: * HERE FOR THREE WORD BLOCKS (NM,P1,EV,KV)
13158: *
13159: BLN03 MOV *NUM03,WA LOAD LENGTH (THREE WORDS)
13160: EXI RETURN TO BLKLN CALLER
13161: *
13162: * HERE FOR FOUR WORD BLOCKS (P2,TE,BC)
13163: *
13164: BLN04 MOV *NUM04,WA LOAD LENGTH (FOUR WORDS)
13165: EXI RETURN TO BLKLN CALLER
13166: *
13167: * HERE FOR FIVE WORD BLOCKS (FF,TR)
13168: *
13169: BLN05 MOV *NUM05,WA LOAD LENGTH
13170: EXI RETURN TO BLKLN CALLER
13171: EJC
13172: *
13173: * BLKLN (CONTINUED)
13174: *
13175: * HERE FOR CTBLK
13176: *
13177: BLN06 MOV *CTSI$,WA SET SIZE OF CTBLK
13178: EXI RETURN TO BLKLN CALLER
13179: *
13180: * HERE FOR ICBLK
13181: *
13182: BLN07 MOV *ICSI$,WA SET SIZE OF ICBLK
13183: EXI RETURN TO BLKLN CALLER
13184: *
13185: * HERE FOR PDBLK
13186: *
13187: BLN08 MOV PDDFP(XR),XL POINT TO DFBLK
13188: MOV DFPDL(XL),WA LOAD PDBLK LENGTH FROM DFBLK
13189: EXI RETURN TO BLKLN CALLER
13190: .IF .CNRA
13191: .ELSE
13192: *
13193: * HERE FOR RCBLK
13194: *
13195: BLN09 MOV *RCSI$,WA SET SIZE OF RCBLK
13196: EXI RETURN TO BLKLN CALLER
13197: .FI
13198: *
13199: * HERE FOR SCBLK
13200: *
13201: BLN10 MOV SCLEN(XR),WA LOAD LENGTH IN CHARACTERS
13202: CTB WA,SCSI$ CALCULATE LENGTH IN BYTES
13203: EXI RETURN TO BLKLN CALLER
13204: .IF .CNBF
13205: .ELSE
13206: *
13207: * HERE FOR BFBLK
13208: *
13209: BLN11 MOV BFALC(XR),WA GET ALLOCATION IN BYTES
13210: CTB WA,BFSI$ CALCULATE LENGTH IN BYTES
13211: EXI RETURN TO BLKLN CALLER
13212: .FI
13213: ENP END PROCEDURE BLKLN
13214: EJC
13215: *
13216: * COPYB -- COPY A BLOCK
13217: *
13218: * (XS) BLOCK TO BE COPIED
13219: * JSR COPYB CALL TO COPY BLOCK
13220: * PPM LOC RETURN IF BLOCK HAS NO IDVAL FIELD
13221: * NORMAL RETURN IF IDVAL FIELD
13222: * (XR) COPY OF BLOCK
13223: * (XS) POPPED
13224: * (XL,WA,WB,WC) DESTROYED
13225: *
13226: COPYB PRC N,1 ENTRY POINT
13227: MOV (XS),XR LOAD ARGUMENT
13228: BEQ XR,=NULLS,COP10 RETURN ARGUMENT IF IT IS NULL
13229: MOV (XR),WA ELSE LOAD TYPE WORD
13230: MOV WA,WB COPY TYPE WORD
13231: JSR BLKLN GET LENGTH OF ARGUMENT BLOCK
13232: MOV XR,XL COPY POINTER
13233: JSR ALLOC ALLOCATE BLOCK OF SAME SIZE
13234: MOV XR,(XS) STORE POINTER TO COPY
13235: MVW COPY CONTENTS OF OLD BLOCK TO NEW
13236: MOV (XS),XR RELOAD POINTER TO START OF COPY
13237: BEQ WB,=B$TBT,COP05 JUMP IF TABLE
13238: BEQ WB,=B$VCT,COP01 JUMP IF VECTOR
13239: BEQ WB,=B$PDT,COP01 JUMP IF PROGRAM DEFINED
13240: .IF .CNBF
13241: .ELSE
13242: BEQ WB,=B$BCT,COP11 JUMP IF BUFFER
13243: .FI
13244: BNE WB,=B$ART,COP10 RETURN COPY IF NOT ARRAY
13245: *
13246: * HERE FOR ARRAY (ARBLK)
13247: *
13248: ADD AROFS(XR),XR POINT TO PROTOTYPE FIELD
13249: BRN COP02 JUMP TO MERGE
13250: *
13251: * HERE FOR VECTOR, PROGRAM DEFINED
13252: *
13253: COP01 ADD *PDFLD,XR POINT TO PDFLD = VCVLS
13254: *
13255: * MERGE HERE FOR ARBLK, VCBLK, PDBLK TO DELETE TRAP
13256: * BLOCKS FROM ALL VALUE FIELDS (THE COPY IS UNTRAPPED)
13257: *
13258: COP02 MOV (XR),XL LOAD NEXT POINTER
13259: *
13260: * LOOP TO GET VALUE AT END OF TRBLK CHAIN
13261: *
13262: COP03 BNE (XL),=B$TRT,COP04 JUMP IF NOT TRAPPED
13263: MOV TRVAL(XL),XL ELSE POINT TO NEXT VALUE
13264: BRN COP03 AND LOOP BACK
13265: EJC
13266: *
13267: * COPYB (CONTINUED)
13268: *
13269: * HERE WITH UNTRAPPED VALUE IN XL
13270: *
13271: COP04 MOV XL,(XR)+ STORE REAL VALUE, BUMP POINTER
13272: BNE XR,DNAMP,COP02 LOOP BACK IF MORE TO GO
13273: BRN COP09 ELSE JUMP TO EXIT
13274: *
13275: * HERE TO COPY A TABLE
13276: *
13277: COP05 ZER IDVAL(XR) ZERO ID TO STOP DUMP BLOWING UP
13278: MOV *TESI$,WA SET SIZE OF TEBLK
13279: MOV *TBBUK,WC SET INITIAL OFFSET
13280: *
13281: * LOOP THROUGH BUCKETS IN TABLE
13282: *
13283: COP06 MOV (XS),XR LOAD TABLE POINTER
13284: BEQ WC,TBLEN(XR),COP09 JUMP TO EXIT IF ALL DONE
13285: ADD WC,XR ELSE POINT TO NEXT BUCKET HEADER
13286: ICA WC BUMP OFFSET
13287: SUB *TENXT,XR SUBTRACT LINK OFFSET TO MERGE
13288: *
13289: * LOOP THROUGH TEBLKS ON ONE CHAIN
13290: *
13291: COP07 MOV TENXT(XR),XL LOAD POINTER TO NEXT TEBLK
13292: MOV (XS),TENXT(XR) SET END OF CHAIN POINTER IN CASE
13293: BEQ (XL),=B$TBT,COP06 BACK FOR NEXT BUCKET IF CHAIN END
13294: MOV XR,-(XS) ELSE STACK PTR TO PREVIOUS BLOCK
13295: MOV *TESI$,WA SET SIZE OF TEBLK
13296: JSR ALLOC ALLOCATE NEW TEBLK
13297: MOV XR,WB SAVE PTR TO NEW TEBLK
13298: MVW COPY OLD TEBLK TO NEW TEBLK
13299: MOV WB,XR RESTORE POINTER TO NEW TEBLK
13300: MOV (XS)+,XL RESTORE POINTER TO PREVIOUS BLOCK
13301: MOV XR,TENXT(XL) LINK NEW BLOCK TO PREVIOUS
13302: MOV XR,XL COPY POINTER TO NEW BLOCK
13303: *
13304: * LOOP TO SET REAL VALUE AFTER REMOVING TRAP CHAIN
13305: *
13306: COP08 MOV TEVAL(XL),XL LOAD VALUE
13307: BEQ (XL),=B$TRT,COP08 LOOP BACK IF TRAPPED
13308: MOV XL,TEVAL(XR) STORE UNTRAPPED VALUE IN TEBLK
13309: BRN COP07 BACK FOR NEXT TEBLK
13310: *
13311: * COMMON EXIT POINT
13312: *
13313: COP09 MOV (XS)+,XR LOAD POINTER TO BLOCK
13314: EXI RETURN
13315: *
13316: * ALTERNATIVE RETURN
13317: *
13318: COP10 EXI 1 RETURN
13319: EJC
13320: .IF .CNBF
13321: .ELSE
13322: *
13323: * HERE TO COPY BUFFER
13324: *
13325: COP11 MOV BCBUF(XR),XL GET BFBLK PTR
13326: MOV BFALC(XL),WA GET ALLOCATION
13327: CTB WA,BFSI$ SET TOTAL SIZE
13328: MOV XR,XL SAVE BCBLK PTR
13329: JSR ALLOC ALLOCATE BFBLK
13330: MOV BCBUF(XL),WB GET OLD BFBLK
13331: MOV XR,BCBUF(XL) SET POINTER TO NEW BFBLK
13332: MOV WB,XL POINT TO OLD BFBLK
13333: MVW COPY BFBLK TOO
13334: ZER XL CLEAR RUBBISH PTR
13335: BRN COP09 BRANCH TO EXIT
13336: .FI
13337: ENP END PROCEDURE COPYB
13338: *
13339: * CDGCG -- GENERATE CODE FOR COMPLEX GOTO
13340: *
13341: * USED BY CMPIL TO PROCESS COMPLEX GOTO TREE
13342: *
13343: * (WB) MUST BE COLLECTABLE
13344: * (XR) EXPRESSION POINTER
13345: * JSR CDGCG CALL TO GENERATE COMPLEX GOTO
13346: * (XL,XR,WA) DESTROYED
13347: *
13348: CDGCG PRC E,0 ENTRY POINT
13349: MOV CMOPN(XR),XL GET UNARY GOTO OPERATOR
13350: MOV CMROP(XR),XR POINT TO GOTO OPERAND
13351: BEQ XL,=OPDVD,CDGC2 JUMP IF DIRECT GOTO
13352: JSR CDGNM GENERATE OPND BY NAME IF NOT DIRECT
13353: *
13354: * RETURN POINT
13355: *
13356: CDGC1 MOV XL,WA GOTO OPERATOR
13357: JSR CDWRD GENERATE IT
13358: EXI RETURN TO CALLER
13359: *
13360: * DIRECT GOTO
13361: *
13362: CDGC2 JSR CDGVL GENERATE OPERAND BY VALUE
13363: BRN CDGC1 MERGE TO RETURN
13364: ENP END PROCEDURE CDGCG
13365: EJC
13366: *
13367: * CDGEX -- BUILD EXPRESSION BLOCK
13368: *
13369: * CDGEX IS PASSED A POINTER TO AN EXPRESSION TREE (SEE
13370: * EXPAN) AND RETURNS AN EXPRESSION (SEBLK OR EXBLK).
13371: *
13372: * (WC) SOME COLLECTABLE VALUE
13373: * (WB) INTEGER IN RANGE 0 LE X LE MXLEN
13374: * (XL) PTR TO EXPRESSION TREE
13375: * JSR CDGEX CALL TO BUILD EXPRESSION
13376: * (XR) PTR TO SEBLK OR EXBLK
13377: * (XL,WA,WB) DESTROYED
13378: *
13379: CDGEX PRC R,0 ENTRY POINT, RECURSIVE
13380: BLO (XL),=B$VR$,CDGX1 JUMP IF NOT VARIABLE
13381: *
13382: * HERE FOR NATURAL VARIABLE, BUILD SEBLK
13383: *
13384: MOV *SESI$,WA SET SIZE OF SEBLK
13385: JSR ALLOC ALLOCATE SPACE FOR SEBLK
13386: MOV =B$SEL,(XR) SET TYPE WORD
13387: MOV XL,SEVAR(XR) STORE VRBLK POINTER
13388: EXI RETURN TO CDGEX CALLER
13389: *
13390: * HERE IF NOT VARIABLE, BUILD EXBLK
13391: *
13392: CDGX1 MOV XL,XR COPY TREE POINTER
13393: MOV WC,-(XS) SAVE WC
13394: MOV CWCOF,XL SAVE CURRENT OFFSET
13395: MOV (XR),WA GET TYPE WORD
13396: BNE WA,=B$CMT,CDGX2 CALL BY VALUE IF NOT CMBLK
13397: BGE CMTYP(XR),=C$$NM,CDGX2 JUMP IF CMBLK ONLY BY VALUE
13398: EJC
13399: *
13400: * CDGEX (CONTINUED)
13401: *
13402: * HERE IF EXPRESSION CAN BE EVALUATED BY NAME
13403: *
13404: JSR CDGNM GENERATE CODE BY NAME
13405: MOV =ORNM$,WA LOAD RETURN BY NAME WORD
13406: BRN CDGX3 MERGE WITH VALUE CASE
13407: *
13408: * HERE IF EXPRESSION CAN ONLY BE EVALUATED BY VALUE
13409: *
13410: CDGX2 JSR CDGVL GENERATE CODE BY VALUE
13411: MOV =ORVL$,WA LOAD RETURN BY VALUE WORD
13412: *
13413: * MERGE HERE TO CONSTRUCT EXBLK
13414: *
13415: CDGX3 JSR CDWRD GENERATE RETURN WORD
13416: JSR EXBLD BUILD EXBLK
13417: MOV (XS)+,WC RESTORE WC
13418: EXI RETURN TO CDGEX CALLER
13419: ENP END PROCEDURE CDGEX
13420: EJC
13421: *
13422: * CDGNM -- GENERATE CODE BY NAME
13423: *
13424: * CDGNM IS CALLED DURING THE COMPILATION PROCESS TO
13425: * GENERATE CODE BY NAME FOR AN EXPRESSION. SEE CDBLK
13426: * DESCRIPTION FOR DETAILS OF CODE GENERATED. THE INPUT
13427: * TO CDGNM IS AN EXPRESSION TREE AS GENERATED BY EXPAN.
13428: *
13429: * CDGNM IS A RECURSIVE PROCEDURE WHICH PROCEEDS BY MAKING
13430: * RECURSIVE CALLS TO GENERATE CODE FOR OPERANDS.
13431: *
13432: * (WB) INTEGER IN RANGE 0 LE N LE DNAMB
13433: * (XR) PTR TO TREE GENERATED BY EXPAN
13434: * (WC) CONSTANT FLAG (SEE BELOW)
13435: * JSR CDGNM CALL TO GENERATE CODE BY NAME
13436: * (XR,WA) DESTROYED
13437: * (WC) SET NON-ZERO IF NON-CONSTANT
13438: *
13439: * WC IS SET TO A NON-ZERO (COLLECTABLE) VALUE IF THE
13440: * EXPRESSION FOR WHICH CODE IS GENERATED CANNOT BE
13441: * EVALUATED AT COMPILE TIME, OTHERWISE WC IS UNCHANGED.
13442: *
13443: * THE CODE IS GENERATED IN THE CURRENT CCBLK (SEE CDWRD).
13444: *
13445: CDGNM PRC R,0 ENTRY POINT, RECURSIVE
13446: MOV XL,-(XS) SAVE ENTRY XL
13447: MOV WB,-(XS) SAVE ENTRY WB
13448: CHK CHECK FOR STACK OVERFLOW
13449: MOV (XR),WA LOAD TYPE WORD
13450: BEQ WA,=B$CMT,CGN04 JUMP IF CMBLK
13451: BHI WA,=B$VR$,CGN02 JUMP IF SIMPLE VARIABLE
13452: *
13453: * MERGE HERE FOR OPERAND YIELDING VALUE (E.G. CONSTANT)
13454: *
13455: CGN01 ERB 212,SYNTAX ERROR. VALUE USED WHERE NAME IS REQUIRED
13456: *
13457: * HERE FOR NATURAL VARIABLE REFERENCE
13458: *
13459: CGN02 MOV =OLVN$,WA LOAD VARIABLE LOAD CALL
13460: JSR CDWRD GENERATE IT
13461: MOV XR,WA COPY VRBLK POINTER
13462: JSR CDWRD GENERATE VRBLK POINTER
13463: EJC
13464: *
13465: * CDGNM (CONTINUED)
13466: *
13467: * HERE TO EXIT WITH WC SET CORRECTLY
13468: *
13469: CGN03 MOV (XS)+,WB RESTORE ENTRY WB
13470: MOV (XS)+,XL RESTORE ENTRY XL
13471: EXI RETURN TO CDGNM CALLER
13472: *
13473: * HERE FOR CMBLK
13474: *
13475: CGN04 MOV XR,XL COPY CMBLK POINTER
13476: MOV CMTYP(XR),XR LOAD CMBLK TYPE
13477: BGE XR,=C$$NM,CGN01 ERROR IF NOT NAME OPERAND
13478: BSW XR,C$$NM ELSE SWITCH ON TYPE
13479: IFF C$ARR,CGN05 ARRAY REFERENCE
13480: IFF C$FNC,CGN08 FUNCTION CALL
13481: IFF C$DEF,CGN09 DEFERRED EXPRESSION
13482: IFF C$IND,CGN10 INDIRECT REFERENCE
13483: IFF C$KEY,CGN11 KEYWORD REFERENCE
13484: IFF C$UBO,CGN08 UNDEFINED BINARY OP
13485: IFF C$UUO,CGN08 UNDEFINED UNARY OP
13486: ESW END SWITCH ON CMBLK TYPE
13487: *
13488: * HERE TO GENERATE CODE FOR ARRAY REFERENCE
13489: *
13490: CGN05 MOV *CMOPN,WB POINT TO ARRAY OPERAND
13491: *
13492: * LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS
13493: *
13494: CGN06 JSR CMGEN GENERATE CODE FOR NEXT OPERAND
13495: MOV CMLEN(XL),WC LOAD LENGTH OF CMBLK
13496: BLT WB,WC,CGN06 LOOP TILL ALL GENERATED
13497: *
13498: * GENERATE APPROPRIATE ARRAY CALL
13499: *
13500: MOV =OAON$,WA LOAD ONE-SUBSCRIPT CASE CALL
13501: BEQ WC,*CMAR1,CGN07 JUMP TO EXIT IF ONE SUBSCRIPT CASE
13502: MOV =OAMN$,WA ELSE LOAD MULTI-SUBSCRIPT CASE CALL
13503: JSR CDWRD GENERATE CALL
13504: MOV WC,WA COPY CMBLK LENGTH
13505: BTW WA CONVERT TO WORDS
13506: SUB =CMVLS,WA CALCULATE NUMBER OF SUBSCRIPTS
13507: EJC
13508: *
13509: * CDGNM (CONTINUED)
13510: *
13511: * HERE TO EXIT GENERATING WORD (NON-CONSTANT)
13512: *
13513: CGN07 MNZ WC SET RESULT NON-CONSTANT
13514: JSR CDWRD GENERATE WORD
13515: BRN CGN03 BACK TO EXIT
13516: *
13517: * HERE TO GENERATE CODE FOR FUNCTIONS AND UNDEFINED OPRS
13518: *
13519: CGN08 MOV XL,XR COPY CMBLK POINTER
13520: JSR CDGVL GEN CODE BY VALUE FOR CALL
13521: MOV =OFNE$,WA GET EXTRA CALL FOR BY NAME
13522: BRN CGN07 BACK TO GENERATE AND EXIT
13523: *
13524: * HERE TO GENERATE CODE FOR DEFERED EXPRESSION
13525: *
13526: CGN09 MOV CMROP(XL),XR CHECK IF VARIABLE
13527: BHI (XR),=B$VR$,CGN02 TREAT *VARIABLE AS SIMPLE VAR
13528: MOV XR,XL COPY PTR TO EXPRESSION TREE
13529: JSR CDGEX ELSE BUILD EXBLK
13530: MOV =OLEX$,WA SET CALL TO LOAD EXPR BY NAME
13531: JSR CDWRD GENERATE IT
13532: MOV XR,WA COPY EXBLK POINTER
13533: JSR CDWRD GENERATE EXBLK POINTER
13534: BRN CGN03 BACK TO EXIT
13535: *
13536: * HERE TO GENERATE CODE FOR INDIRECT REFERENCE
13537: *
13538: CGN10 MOV CMROP(XL),XR GET OPERAND
13539: JSR CDGVL GENERATE CODE BY VALUE FOR IT
13540: MOV =OINN$,WA LOAD CALL FOR INDIRECT BY NAME
13541: BRN CGN12 MERGE
13542: *
13543: * HERE TO GENERATE CODE FOR KEYWORD REFERENCE
13544: *
13545: CGN11 MOV CMROP(XL),XR GET OPERAND
13546: JSR CDGNM GENERATE CODE BY NAME FOR IT
13547: MOV =OKWN$,WA LOAD CALL FOR KEYWORD BY NAME
13548: *
13549: * KEYWORD, INDIRECT MERGE HERE
13550: *
13551: CGN12 JSR CDWRD GENERATE CODE FOR OPERATOR
13552: BRN CGN03 EXIT
13553: ENP END PROCEDURE CDGNM
13554: EJC
13555: *
13556: * CDGVL -- GENERATE CODE BY VALUE
13557: *
13558: * CDGVL IS CALLED DURING THE COMPILATION PROCESS TO
13559: * GENERATE CODE BY VALUE FOR AN EXPRESSION. SEE CDBLK
13560: * DESCRIPTION FOR DETAILS OF THE CODE GENERATED. THE INPUT
13561: * TO CDGVL IS AN EXPRESSION TREE AS GENERATED BY EXPAN.
13562: *
13563: * CDGVL IS A RECURSIVE PROCEDURE WHICH PROCEEDS BY MAKING
13564: * RECURSIVE CALLS TO GENERATE CODE FOR OPERANDS.
13565: *
13566: * (WB) INTEGER IN RANGE 0 LE N LE DNAMB
13567: * (XR) PTR TO TREE GENERATED BY EXPAN
13568: * (WC) CONSTANT FLAG (SEE BELOW)
13569: * JSR CDGVL CALL TO GENERATE CODE BY VALUE
13570: * (XR,WA) DESTROYED
13571: * (WC) SET NON-ZERO IF NON-CONSTANT
13572: *
13573: * WC IS SET TO A NON-ZERO (COLLECTABLE) VALUE IF THE
13574: * EXPRESSION FOR WHICH CODE IS GENERATED CANNOT BE
13575: * EVALUATED AT COMPILE TIME, OTHERWISE WC IS UNCHANGED.
13576: *
13577: * IF WC IS NON-ZERO ON ENTRY, THEN PREEVALUATION IS NOT
13578: * ALLOWED REGARDLESS OF THE NATURE OF THE OPERAND.
13579: *
13580: * THE CODE IS GENERATED IN THE CURRENT CCBLK (SEE CDWRD).
13581: *
13582: CDGVL PRC R,0 ENTRY POINT, RECURSIVE
13583: MOV (XR),WA LOAD TYPE WORD
13584: BEQ WA,=B$CMT,CGV01 JUMP IF CMBLK
13585: BLT WA,=B$VRA,CGV00 JUMP IF ICBLK, RCBLK, SCBLK
13586: BNZ VRLEN(XR),CGVL0 JUMP IF NOT SYSTEM VARIABLE
13587: MOV XR,-(XS) STACK XR
13588: MOV VRSVP(XR),XR POINT TO SVBLK
13589: MOV SVBIT(XR),WA GET SVBLK PROPERTY BITS
13590: MOV (XS)+,XR RECOVER XR
13591: ANB BTCKW,WA CHECK IF CONSTANT KEYWORD
13592: NZB WA,CGV00 JUMP IF CONSTANT KEYWORD
13593: *
13594: * HERE FOR VARIABLE VALUE REFERENCE
13595: *
13596: CGVL0 MNZ WC INDICATE NON-CONSTANT VALUE
13597: *
13598: * MERGE HERE FOR SIMPLE CONSTANT (ICBLK,RCBLK,SCBLK)
13599: * AND FOR VARIABLES CORRESPONDING TO CONSTANT KEYWORDS.
13600: *
13601: CGV00 MOV XR,WA COPY PTR TO VAR OR CONSTANT
13602: JSR CDWRD GENERATE AS CODE WORD
13603: EXI RETURN TO CALLER
13604: EJC
13605: *
13606: * CDGVL (CONTINUED)
13607: *
13608: * HERE FOR TREE NODE (CMBLK)
13609: *
13610: CGV01 MOV WB,-(XS) SAVE ENTRY WB
13611: MOV XL,-(XS) SAVE ENTRY XL
13612: MOV WC,-(XS) SAVE ENTRY CONSTANT FLAG
13613: MOV CWCOF,-(XS) SAVE INITIAL CODE OFFSET
13614: CHK CHECK FOR STACK OVERFLOW
13615: *
13616: * PREPARE TO GENERATE CODE FOR CMBLK. WC IS SET TO THE
13617: * VALUE OF CSWNO (ZERO IF -OPTIMISE, 1 IF -NOOPT) TO
13618: * START WITH AND IS RESET NON-ZERO FOR ANY NON-CONSTANT
13619: * CODE GENERATED. IF IT IS STILL ZERO AFTER GENERATING ALL
13620: * THE CMBLK CODE, THEN ITS VALUE IS COMPUTED AS THE RESULT.
13621: *
13622: MOV XR,XL COPY CMBLK POINTER
13623: MOV CMTYP(XR),XR LOAD CMBLK TYPE
13624: MOV CSWNO,WC RESET CONSTANT FLAG
13625: BLE XR,=C$PR$,CGV02 JUMP IF NOT PREDICATE VALUE
13626: MNZ WC ELSE FORCE NON-CONSTANT CASE
13627: *
13628: * HERE WITH WC SET APPROPRIATELY
13629: *
13630: CGV02 BSW XR,C$$NV SWITCH TO APPROPRIATE GENERATOR
13631: IFF C$ARR,CGV03 ARRAY REFERENCE
13632: IFF C$FNC,CGV05 FUNCTION CALL
13633: IFF C$DEF,CGV14 DEFERRED EXPRESSION
13634: IFF C$SEL,CGV15 SELECTION
13635: IFF C$IND,CGV31 INDIRECT REFERENCE
13636: IFF C$KEY,CGV27 KEYWORD REFERENCE
13637: IFF C$UBO,CGV29 UNDEFINED BINOP
13638: IFF C$UUO,CGV30 UNDEFINED UNOP
13639: IFF C$BVL,CGV18 BINOPS WITH VAL OPDS
13640: IFF C$ALT,CGV18 ALTERNATION
13641: IFF C$UVL,CGV19 UNOPS WITH VALU OPND
13642: IFF C$ASS,CGV21 ASSIGNMENT
13643: IFF C$CNC,CGV24 CONCATENATION
13644: IFF C$CNP,CGV24 CONCATENATION (NOT PATTERN MATCH)
13645: IFF C$UNM,CGV27 UNOPS WITH NAME OPND
13646: IFF C$BVN,CGV26 BINARY $ AND .
13647: IFF C$INT,CGV31 INTERROGATION
13648: IFF C$NEG,CGV28 NEGATION
13649: IFF C$PMT,CGV18 PATTERN MATCH
13650: ESW END SWITCH ON CMBLK TYPE
13651: EJC
13652: *
13653: * CDGVL (CONTINUED)
13654: *
13655: * HERE TO GENERATE CODE FOR ARRAY REFERENCE
13656: *
13657: CGV03 MOV *CMOPN,WB SET OFFSET TO ARRAY OPERAND
13658: *
13659: * LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS
13660: *
13661: CGV04 JSR CMGEN GEN VALUE CODE FOR NEXT OPERAND
13662: MOV CMLEN(XL),WC LOAD CMBLK LENGTH
13663: BLT WB,WC,CGV04 LOOP BACK IF MORE TO GO
13664: *
13665: * GENERATE CALL TO APPROPRIATE ARRAY REFERENCE ROUTINE
13666: *
13667: MOV =OAOV$,WA SET ONE SUBSCRIPT CALL IN CASE
13668: BEQ WC,*CMAR1,CGV32 JUMP TO EXIT IF 1-SUB CASE
13669: MOV =OAMV$,WA ELSE SET CALL FOR MULTI-SUBSCRIPTS
13670: JSR CDWRD GENERATE CALL
13671: MOV WC,WA COPY LENGTH OF CMBLK
13672: SUB *CMVLS,WA SUBTRACT STANDARD LENGTH
13673: BTW WA GET NUMBER OF WORDS
13674: BRN CGV32 JUMP TO GENERATE SUBSCRIPT COUNT
13675: *
13676: * HERE TO GENERATE CODE FOR FUNCTION CALL
13677: *
13678: CGV05 MOV *CMVLS,WB SET OFFSET TO FIRST ARGUMENT
13679: *
13680: * LOOP TO GENERATE CODE FOR ARGUMENTS
13681: *
13682: CGV06 BEQ WB,CMLEN(XL),CGV07 JUMP IF ALL GENERATED
13683: JSR CMGEN ELSE GEN VALUE CODE FOR NEXT ARG
13684: BRN CGV06 BACK TO GENERATE NEXT ARGUMENT
13685: *
13686: * HERE TO GENERATE ACTUAL FUNCTION CALL
13687: *
13688: CGV07 SUB *CMVLS,WB GET NUMBER OF ARG PTRS (BYTES)
13689: BTW WB CONVERT BYTES TO WORDS
13690: MOV CMOPN(XL),XR LOAD FUNCTION VRBLK POINTER
13691: BNZ VRLEN(XR),CGV12 JUMP IF NOT SYSTEM FUNCTION
13692: MOV VRSVP(XR),XL LOAD SVBLK PTR IF SYSTEM VAR
13693: MOV SVBIT(XL),WA LOAD BIT MASK
13694: ANB BTFFC,WA TEST FOR FAST FUNCTION CALL ALLOWED
13695: ZRB WA,CGV12 JUMP IF NOT
13696: EJC
13697: *
13698: * CDGVL (CONTINUED)
13699: *
13700: * HERE IF FAST FUNCTION CALL IS ALLOWED
13701: *
13702: MOV SVBIT(XL),WA RELOAD BIT INDICATORS
13703: ANB BTPRE,WA TEST FOR PREEVALUATION OK
13704: NZB WA,CGV08 JUMP IF PREEVALUATION PERMITTED
13705: MNZ WC ELSE SET RESULT NON-CONSTANT
13706: *
13707: * TEST FOR CORRECT NUMBER OF ARGS FOR FAST CALL
13708: *
13709: CGV08 MOV VRFNC(XR),XL LOAD PTR TO SVFNC FIELD
13710: MOV FARGS(XL),WA LOAD SVNAR FIELD VALUE
13711: BEQ WA,WB,CGV11 JUMP IF ARGUMENT COUNT IS CORRECT
13712: BHI WA,WB,CGV09 JUMP IF TOO FEW ARGUMENTS GIVEN
13713: *
13714: * HERE IF TOO MANY ARGUMENTS, PREPARE TO GENERATE O$POPS
13715: *
13716: SUB WA,WB GET NUMBER OF EXTRA ARGS
13717: LCT WB,WB SET AS COUNT TO CONTROL LOOP
13718: MOV =OPOP$,WA SET POP CALL
13719: BRN CGV10 JUMP TO COMMON LOOP
13720: *
13721: * HERE IF TOO FEW ARGUMENTS, PREPARE TO GENERATE NULLS
13722: *
13723: CGV09 SUB WB,WA GET NUMBER OF MISSING ARGUMENTS
13724: LCT WB,WA LOAD AS COUNT TO CONTROL LOOP
13725: MOV =NULLS,WA LOAD PTR TO NULL CONSTANT
13726: *
13727: * LOOP TO GENERATE CALLS TO FIX ARGUMENT COUNT
13728: *
13729: CGV10 JSR CDWRD GENERATE ONE CALL
13730: BCT WB,CGV10 LOOP TILL ALL GENERATED
13731: *
13732: * HERE AFTER ADJUSTING ARG COUNT AS REQUIRED
13733: *
13734: CGV11 MOV XL,WA COPY POINTER TO SVFNC FIELD
13735: BRN CGV36 JUMP TO GENERATE CALL
13736: EJC
13737: *
13738: * CDGVL (CONTINUED)
13739: *
13740: * COME HERE IF FAST CALL IS NOT PERMITTED
13741: *
13742: CGV12 MOV =OFNS$,WA SET ONE ARG CALL IN CASE
13743: BEQ WB,=NUM01,CGV13 JUMP IF ONE ARG CASE
13744: MOV =OFNC$,WA ELSE LOAD CALL FOR MORE THAN 1 ARG
13745: JSR CDWRD GENERATE IT
13746: MOV WB,WA COPY ARGUMENT COUNT
13747: *
13748: * ONE ARG CASE MERGES HERE
13749: *
13750: CGV13 JSR CDWRD GENERATE =O$FNS OR ARG COUNT
13751: MOV XR,WA COPY VRBLK POINTER
13752: BRN CGV32 JUMP TO GENERATE VRBLK PTR
13753: *
13754: * HERE FOR DEFERRED EXPRESSION
13755: *
13756: CGV14 MOV CMROP(XL),XL POINT TO EXPRESSION TREE
13757: JSR CDGEX BUILD EXBLK OR SEBLK
13758: MOV XR,WA COPY BLOCK PTR
13759: JSR CDWRD GENERATE PTR TO EXBLK OR SEBLK
13760: BRN CGV34 JUMP TO EXIT, CONSTANT TEST
13761: *
13762: * HERE TO GENERATE CODE FOR SELECTION
13763: *
13764: CGV15 ZER -(XS) ZERO PTR TO CHAIN OF FORWARD JUMPS
13765: ZER -(XS) ZERO PTR TO PREV O$SLC FORWARD PTR
13766: MOV *CMVLS,WB POINT TO FIRST ALTERNATIVE
13767: MOV =OSLA$,WA SET INITIAL CODE WORD
13768: *
13769: * 0(XS) IS THE OFFSET TO THE PREVIOUS WORD
13770: * WHICH REQUIRES FILLING IN WITH AN
13771: * OFFSET TO THE FOLLOWING O$SLC,O$SLD
13772: *
13773: * 1(XS) IS THE HEAD OF A CHAIN OF OFFSET
13774: * POINTERS INDICATING THOSE LOCATIONS
13775: * TO BE FILLED WITH OFFSETS PAST
13776: * THE END OF ALL THE ALTERNATIVES
13777: *
13778: CGV16 JSR CDWRD GENERATE O$SLC (O$SLA FIRST TIME)
13779: MOV CWCOF,(XS) SET CURRENT LOC AS PTR TO FILL IN
13780: JSR CDWRD GENERATE GARBAGE WORD THERE FOR NOW
13781: JSR CMGEN GEN VALUE CODE FOR ALTERNATIVE
13782: MOV =OSLB$,WA LOAD O$SLB POINTER
13783: JSR CDWRD GENERATE O$SLB CALL
13784: MOV 1(XS),WA LOAD OLD CHAIN PTR
13785: MOV CWCOF,1(XS) SET CURRENT LOC AS NEW CHAIN HEAD
13786: JSR CDWRD GENERATE FORWARD CHAIN LINK
13787: EJC
13788: *
13789: * CDGVL (CONTINUED)
13790: *
13791: * NOW TO FILL IN THE SKIP OFFSET TO O$SLC,O$SLD
13792: *
13793: MOV (XS),XR LOAD OFFSET TO WORD TO PLUG
13794: ADD R$CCB,XR POINT TO ACTUAL LOCATION TO PLUG
13795: MOV CWCOF,(XR) PLUG PROPER OFFSET IN
13796: MOV =OSLC$,WA LOAD O$SLC PTR FOR NEXT ALTERNATIVE
13797: MOV WB,XR COPY OFFSET (DESTROY GARBAGE XR)
13798: ICA XR BUMP EXTRA TIME FOR TEST
13799: BLT XR,CMLEN(XL),CGV16 LOOP BACK IF NOT LAST ALTERNATIVE
13800: *
13801: * HERE TO GENERATE CODE FOR LAST ALTERNATIVE
13802: *
13803: MOV =OSLD$,WA GET HEADER CALL
13804: JSR CDWRD GENERATE O$SLD CALL
13805: JSR CMGEN GENERATE CODE FOR LAST ALTERNATIVE
13806: ICA XS POP OFFSET PTR
13807: MOV (XS)+,XR LOAD CHAIN PTR
13808: *
13809: * LOOP TO PLUG OFFSETS PAST STRUCTURE
13810: *
13811: CGV17 ADD R$CCB,XR MAKE NEXT PTR ABSOLUTE
13812: MOV (XR),WA LOAD FORWARD PTR
13813: MOV CWCOF,(XR) PLUG REQUIRED OFFSET
13814: MOV WA,XR COPY FORWARD PTR
13815: BNZ WA,CGV17 LOOP BACK IF MORE TO GO
13816: BRN CGV33 ELSE JUMP TO EXIT (NOT CONSTANT)
13817: *
13818: * HERE FOR BINARY OPS WITH VALUE OPERANDS
13819: *
13820: CGV18 MOV CMLOP(XL),XR LOAD LEFT OPERAND POINTER
13821: JSR CDGVL GEN VALUE CODE FOR LEFT OPERAND
13822: *
13823: * HERE FOR UNARY OPS WITH VALUE OPERAND (BINOPS MERGE)
13824: *
13825: CGV19 MOV CMROP(XL),XR LOAD RIGHT (ONLY) OPERAND PTR
13826: JSR CDGVL GEN CODE BY VALUE
13827: EJC
13828: *
13829: * CDGVL (CONTINUED)
13830: *
13831: * MERGE HERE TO GENERATE OPERATOR CALL FROM CMOPN FIELD
13832: *
13833: CGV20 MOV CMOPN(XL),WA LOAD OPERATOR CALL POINTER
13834: BRN CGV36 JUMP TO GENERATE IT WITH CONS TEST
13835: *
13836: * HERE FOR ASSIGNMENT
13837: *
13838: CGV21 MOV CMLOP(XL),XR LOAD LEFT OPERAND POINTER
13839: BLO (XR),=B$VR$,CGV22 JUMP IF NOT VARIABLE
13840: *
13841: * HERE FOR ASSIGNMENT TO SIMPLE VARIABLE
13842: *
13843: MOV CMROP(XL),XR LOAD RIGHT OPERAND PTR
13844: JSR CDGVL GENERATE CODE BY VALUE
13845: MOV CMLOP(XL),WA RELOAD LEFT OPERAND VRBLK PTR
13846: ADD *VRSTO,WA POINT TO VRSTO FIELD
13847: BRN CGV32 JUMP TO GENERATE STORE PTR
13848: *
13849: * HERE IF NOT SIMPLE VARIABLE ASSIGNMENT
13850: *
13851: CGV22 JSR EXPAP TEST FOR PATTERN MATCH ON LEFT SIDE
13852: PPM CGV23 JUMP IF NOT PATTERN MATCH
13853: *
13854: * HERE FOR PATTERN REPLACEMENT
13855: *
13856: MOV CMROP(XR),CMLOP(XL) SAVE PATTERN PTR IN SAFE PLACE
13857: MOV CMLOP(XR),XR LOAD SUBJECT PTR
13858: JSR CDGNM GEN CODE BY NAME FOR SUBJECT
13859: MOV CMLOP(XL),XR LOAD PATTERN PTR
13860: JSR CDGVL GEN CODE BY VALUE FOR PATTERN
13861: MOV =OPMN$,WA LOAD MATCH BY NAME CALL
13862: JSR CDWRD GENERATE IT
13863: MOV CMROP(XL),XR LOAD REPLACEMENT VALUE PTR
13864: JSR CDGVL GEN CODE BY VALUE
13865: MOV =ORPL$,WA LOAD REPLACE CALL
13866: BRN CGV32 JUMP TO GEN AND EXIT (NOT CONSTANT)
13867: *
13868: * HERE FOR ASSIGNMENT TO COMPLEX VARIABLE
13869: *
13870: CGV23 MNZ WC INHIBIT PRE-EVALUATION
13871: JSR CDGNM GEN CODE BY NAME FOR LEFT SIDE
13872: BRN CGV31 MERGE WITH UNOP CIRCUIT
13873: EJC
13874: *
13875: * CDGVL (CONTINUED)
13876: *
13877: * HERE FOR CONCATENATION
13878: *
13879: CGV24 MOV CMLOP(XL),XR LOAD LEFT OPERAND PTR
13880: BNE (XR),=B$CMT,CGV18 ORDINARY BINOP IF NOT CMBLK
13881: MOV CMTYP(XR),WB LOAD CMBLK TYPE CODE
13882: BEQ WB,=C$INT,CGV25 SPECIAL CASE IF INTERROGATION
13883: BEQ WB,=C$NEG,CGV25 OR NEGATION
13884: BNE WB,=C$FNC,CGV18 ELSE ORDINARY BINOP IF NOT FUNCTION
13885: MOV CMOPN(XR),XR ELSE LOAD FUNCTION VRBLK PTR
13886: BNZ VRLEN(XR),CGV18 ORDINARY BINOP IF NOT SYSTEM VAR
13887: MOV VRSVP(XR),XR ELSE POINT TO SVBLK
13888: MOV SVBIT(XR),WA LOAD BIT INDICATORS
13889: ANB BTPRD,WA TEST FOR PREDICATE FUNCTION
13890: ZRB WA,CGV18 ORDINARY BINOP IF NOT
13891: *
13892: * HERE IF LEFT ARG OF CONCATENATION IS PREDICATE FUNCTION
13893: *
13894: CGV25 MOV CMLOP(XL),XR RELOAD LEFT ARG
13895: JSR CDGVL GEN CODE BY VALUE
13896: MOV =OPOP$,WA LOAD POP CALL
13897: JSR CDWRD GENERATE IT
13898: MOV CMROP(XL),XR LOAD RIGHT OPERAND
13899: JSR CDGVL GEN CODE BY VALUE AS RESULT CODE
13900: BRN CGV33 EXIT (NOT CONSTANT)
13901: *
13902: * HERE TO GENERATE CODE FOR PATTERN, IMMEDIATE ASSIGNMENT
13903: *
13904: CGV26 MOV CMLOP(XL),XR LOAD LEFT OPERAND
13905: JSR CDGVL GEN CODE BY VALUE, MERGE
13906: *
13907: * HERE FOR UNOPS WITH ARG BY NAME (BINARY $ . MERGE)
13908: *
13909: CGV27 MOV CMROP(XL),XR LOAD RIGHT OPERAND PTR
13910: JSR CDGNM GEN CODE BY NAME FOR RIGHT ARG
13911: MOV CMOPN(XL),XR GET OPERATOR CODE WORD
13912: BNE (XR),=O$KWV,CGV20 GEN CALL UNLESS KEYWORD VALUE
13913: EJC
13914: *
13915: * CDGVL (CONTINUED)
13916: *
13917: * HERE FOR KEYWORD BY VALUE. THIS IS CONSTANT ONLY IF
13918: * THE OPERAND IS ONE OF THE SPECIAL SYSTEM VARIABLES WITH
13919: * THE SVCKW BIT SET TO INDICATE A CONSTANT KEYWORD VALUE.
13920: * NOTE THAT THE ONLY CONSTANT OPERAND BY NAME IS A VARIABLE
13921: *
13922: BNZ WC,CGV20 GEN CALL IF NON-CONSTANT (NOT VAR)
13923: MNZ WC ELSE SET NON-CONSTANT IN CASE
13924: MOV CMROP(XL),XR LOAD PTR TO OPERAND VRBLK
13925: BNZ VRLEN(XR),CGV20 GEN (NON-CONSTANT) IF NOT SYS VAR
13926: MOV VRSVP(XR),XR ELSE LOAD PTR TO SVBLK
13927: MOV SVBIT(XR),WA LOAD BIT MASK
13928: ANB BTCKW,WA TEST FOR CONSTANT KEYWORD
13929: ZRB WA,CGV20 GO GEN IF NOT CONSTANT
13930: ZER WC ELSE SET RESULT CONSTANT
13931: BRN CGV20 AND JUMP BACK TO GENERATE CALL
13932: *
13933: * HERE TO GENERATE CODE FOR NEGATION
13934: *
13935: CGV28 MOV =ONTA$,WA GET INITIAL WORD
13936: JSR CDWRD GENERATE IT
13937: MOV CWCOF,WB SAVE NEXT OFFSET
13938: JSR CDWRD GENERATE GUNK WORD FOR NOW
13939: MOV CMROP(XL),XR LOAD RIGHT OPERAND PTR
13940: JSR CDGVL GEN CODE BY VALUE
13941: MOV =ONTB$,WA LOAD END OF EVALUATION CALL
13942: JSR CDWRD GENERATE IT
13943: MOV WB,XR COPY OFFSET TO WORD TO PLUG
13944: ADD R$CCB,XR POINT TO ACTUAL WORD TO PLUG
13945: MOV CWCOF,(XR) PLUG WORD WITH CURRENT OFFSET
13946: MOV =ONTC$,WA LOAD FINAL CALL
13947: BRN CGV32 JUMP TO GENERATE IT (NOT CONSTANT)
13948: *
13949: * HERE TO GENERATE CODE FOR UNDEFINED BINARY OPERATOR
13950: *
13951: CGV29 MOV CMLOP(XL),XR LOAD LEFT OPERAND PTR
13952: JSR CDGVL GENERATE CODE BY VALUE
13953: EJC
13954: *
13955: * CDGVL (CONTINUED)
13956: *
13957: * HERE TO GENERATE CODE FOR UNDEFINED UNARY OPERATOR
13958: *
13959: CGV30 MOV =C$UO$,WB SET UNOP CODE + 1
13960: SUB CMTYP(XL),WB SET NUMBER OF ARGS (1 OR 2)
13961: *
13962: * MERGE HERE FOR UNDEFINED OPERATORS
13963: *
13964: MOV CMROP(XL),XR LOAD RIGHT (ONLY) OPERAND POINTER
13965: JSR CDGVL GEN VALUE CODE FOR RIGHT OPERAND
13966: MOV CMOPN(XL),XR LOAD POINTER TO OPERATOR DV
13967: MOV DVOPN(XR),XR LOAD POINTER OFFSET
13968: WTB XR CONVERT WORD OFFSET TO BYTES
13969: ADD =R$UBA,XR POINT TO PROPER FUNCTION PTR
13970: SUB *VRFNC,XR SET STANDARD FUNCTION OFFSET
13971: BRN CGV12 MERGE WITH FUNCTION CALL CIRCUIT
13972: *
13973: * HERE TO GENERATE CODE FOR INTERROGATION, INDIRECTION
13974: *
13975: CGV31 MNZ WC SET NON CONSTANT
13976: BRN CGV19 MERGE
13977: *
13978: * HERE TO EXIT GENERATING A WORD, RESULT NOT CONSTANT
13979: *
13980: CGV32 JSR CDWRD GENERATE WORD, MERGE
13981: *
13982: * HERE TO EXIT WITH NO WORD GENERATED, NOT CONSTANT
13983: *
13984: CGV33 MNZ WC INDICATE RESULT IS NOT CONSTANT
13985: *
13986: * COMMON EXIT POINT
13987: *
13988: CGV34 ICA XS POP INITIAL CODE OFFSET
13989: MOV (XS)+,WA RESTORE OLD CONSTANT FLAG
13990: MOV (XS)+,XL RESTORE ENTRY XL
13991: MOV (XS)+,WB RESTORE ENTRY WB
13992: BNZ WC,CGV35 JUMP IF NOT CONSTANT
13993: MOV WA,WC ELSE RESTORE ENTRY CONSTANT FLAG
13994: *
13995: * HERE TO RETURN AFTER DEALING WITH WC SETTING
13996: *
13997: CGV35 EXI RETURN TO CDGVL CALLER
13998: *
13999: * EXIT HERE TO GENERATE WORD AND TEST FOR CONSTANT
14000: *
14001: CGV36 JSR CDWRD GENERATE WORD
14002: BNZ WC,CGV34 JUMP TO EXIT IF NOT CONSTANT
14003: EJC
14004: *
14005: * CDGVL (CONTINUED)
14006: *
14007: * HERE TO PREEVALUATE CONSTANT SUB-EXPRESSION
14008: *
14009: MOV =ORVL$,WA LOAD CALL TO RETURN VALUE
14010: JSR CDWRD GENERATE IT
14011: MOV (XS),XL LOAD INITIAL CODE OFFSET
14012: JSR EXBLD BUILD EXBLK FOR EXPRESSION
14013: ZER WB SET TO EVALUATE BY VALUE
14014: JSR EVALX EVALUATE EXPRESSION
14015: PPM SHOULD NOT FAIL
14016: MOV (XR),WA LOAD TYPE WORD OF RESULT
14017: BLO WA,=P$AAA,CGV37 JUMP IF NOT PATTERN
14018: MOV =OLPT$,WA ELSE LOAD SPECIAL PATTERN LOAD CALL
14019: JSR CDWRD GENERATE IT
14020: *
14021: * MERGE HERE TO GENERATE POINTER TO RESULTING CONSTANT
14022: *
14023: CGV37 MOV XR,WA COPY CONSTANT POINTER
14024: JSR CDWRD GENERATE PTR
14025: ZER WC SET RESULT CONSTANT
14026: BRN CGV34 JUMP BACK TO EXIT
14027: ENP END PROCEDURE CDGVL
14028: EJC
14029: *
14030: * CDWRD -- GENERATE ONE WORD OF CODE
14031: *
14032: * CDWRD WRITES ONE WORD INTO THE CURRENT CODE BLOCK UNDER
14033: * CONSTRUCTION. A NEW, LARGER, BLOCK IS ALLOCATED IF THERE
14034: * IS INSUFFICIENT ROOM IN THE CURRENT BLOCK. CDWRD ENSURES
14035: * THAT THERE ARE AT LEAST THREE WORDS LEFT IN THE BLOCK
14036: * AFTER ENTERING THE NEW WORD. THIS GUARANTEES THAT ANY
14037: * EXTRA SPACE AT THE END CAN BE SPLIT OFF AS A CCBLK.
14038: *
14039: * (WA) WORD TO BE GENERATED
14040: * JSR CDWRD CALL TO GENERATE WORD
14041: *
14042: CDWRD PRC E,0 ENTRY POINT
14043: MOV XR,-(XS) SAVE ENTRY XR
14044: MOV WA,-(XS) SAVE CODE WORD TO BE GENERATED
14045: *
14046: * MERGE BACK HERE AFTER ALLOCATING LARGER BLOCK
14047: *
14048: CDWD1 MOV R$CCB,XR LOAD PTR TO CCBLK BEING BUILT
14049: BNZ XR,CDWD2 JUMP IF BLOCK ALLOCATED
14050: *
14051: * HERE WE ALLOCATE AN ENTIRELY FRESH BLOCK
14052: *
14053: MOV *E$CBS,WA LOAD INITIAL LENGTH
14054: JSR ALLOC ALLOCATE CCBLK
14055: MOV =B$CCT,(XR) STORE TYPE WORD
14056: MOV *CCCOD,CWCOF SET INITIAL OFFSET
14057: MOV WA,CCLEN(XR) STORE BLOCK LENGTH
14058: MOV XR,R$CCB STORE PTR TO NEW BLOCK
14059: *
14060: * HERE WE HAVE A BLOCK WE CAN USE
14061: *
14062: CDWD2 MOV CWCOF,WA LOAD CURRENT OFFSET
14063: ADD *NUM04,WA ADJUST FOR TEST (FOUR WORDS)
14064: BLO WA,CCLEN(XR),CDWD4 JUMP IF ROOM IN THIS BLOCK
14065: *
14066: * HERE IF NO ROOM IN CURRENT BLOCK
14067: *
14068: BGE WA,MXLEN,CDWD5 JUMP IF ALREADY AT MAX SIZE
14069: ADD *E$CBS,WA ELSE GET NEW SIZE
14070: MOV XL,-(XS) SAVE ENTRY XL
14071: MOV XR,XL COPY POINTER
14072: BLT WA,MXLEN,CDWD3 JUMP IF NOT TOO LARGE
14073: MOV MXLEN,WA ELSE RESET TO MAX ALLOWED SIZE
14074: EJC
14075: *
14076: * CDWRD (CONTINUED)
14077: *
14078: * HERE WITH NEW BLOCK SIZE IN WA
14079: *
14080: CDWD3 JSR ALLOC ALLOCATE NEW BLOCK
14081: MOV XR,R$CCB STORE POINTER TO NEW BLOCK
14082: MOV =B$CCT,(XR)+ STORE TYPE WORD IN NEW BLOCK
14083: MOV WA,(XR)+ STORE BLOCK LENGTH
14084: ADD *CCUSE,XL POINT TO CCUSE,CCCOD FIELDS IN OLD
14085: MOV (XL),WA LOAD CCUSE VALUE
14086: MVW COPY USEFUL WORDS FROM OLD BLOCK
14087: MOV (XS)+,XL RESTORE XL
14088: BRN CDWD1 MERGE BACK TO TRY AGAIN
14089: *
14090: * HERE WITH ROOM IN CURRENT BLOCK
14091: *
14092: CDWD4 MOV CWCOF,WA LOAD CURRENT OFFSET
14093: ICA WA GET NEW OFFSET
14094: MOV WA,CWCOF STORE NEW OFFSET
14095: MOV WA,CCUSE(XR) STORE IN CCBLK FOR GBCOL
14096: DCA WA RESTORE PTR TO THIS WORD
14097: ADD WA,XR POINT TO CURRENT ENTRY
14098: MOV (XS)+,WA RELOAD WORD TO GENERATE
14099: MOV WA,(XR) STORE WORD IN BLOCK
14100: MOV (XS)+,XR RESTORE ENTRY XR
14101: EXI RETURN TO CALLER
14102: *
14103: * HERE IF COMPILED CODE IS TOO LONG FOR CDBLK
14104: *
14105: CDWD5 ERB 213,SYNTAX ERROR. STATEMENT IS TOO COMPLICATED.
14106: ENP END PROCEDURE CDWRD
14107: EJC
14108: *
14109: * CMGEN -- GENERATE CODE FOR CMBLK PTR
14110: *
14111: * CMGEN IS A SUBSIDIARY PROCEDURE USED TO GENERATE VALUE
14112: * CODE FOR A CMBLK PTR FROM THE MAIN CODE GENERATORS.
14113: *
14114: * (XL) CMBLK POINTER
14115: * (WB) OFFSET TO POINTER IN CMBLK
14116: * JSR CMGEN CALL TO GENERATE CODE
14117: * (XR,WA) DESTROYED
14118: * (WB) BUMPED BY ONE WORD
14119: *
14120: CMGEN PRC R,0 ENTRY POINT, RECURSIVE
14121: MOV XL,XR COPY CMBLK POINTER
14122: ADD WB,XR POINT TO CMBLK POINTER
14123: MOV (XR),XR LOAD CMBLK POINTER
14124: JSR CDGVL GENERATE CODE BY VALUE
14125: ICA WB BUMP OFFSET
14126: EXI RETURN TO CALLER
14127: ENP END PROCEDURE CMGEN
14128: EJC
14129: *
14130: * CMPIL (COMPILE SOURCE CODE)
14131: *
14132: * CMPIL IS USED TO CONVERT SNOBOL4 SOURCE CODE TO INTERNAL
14133: * FORM (SEE CDBLK FORMAT). IT IS USED BOTH FOR THE INITIAL
14134: * COMPILE AND AT RUN TIME BY THE CODE AND CONVERT FUNCTIONS
14135: * THIS PROCEDURE HAS CONTROL FOR THE ENTIRE DURATION OF
14136: * INITIAL COMPILATION. AN ERROR IN ANY PROCEDURE CALLED
14137: * DURING COMPILATION WILL LEAD FIRST TO THE ERROR SECTION
14138: * AND ULTIMATELY BACK HERE FOR RESUMED COMPILATION. THE
14139: * RE-ENTRY POINTS AFTER AN ERROR ARE SPECIALLY LABELLED -
14140: *
14141: * CMPCE RESUME AFTER CONTROL CARD ERROR
14142: * CMPLE RESUME AFTER LABEL ERROR
14143: * CMPSE RESUME AFTER STATEMENT ERROR
14144: *
14145: * JSR CMPIL CALL TO COMPILE CODE
14146: * (XR) PTR TO CDBLK FOR ENTRY STATEMENT
14147: * (XL,WA,WB,WC,RA) DESTROYED
14148: *
14149: * THE FOLLOWING GLOBAL VARIABLES ARE REFERENCED
14150: *
14151: * CMPSN NUMBER OF NEXT STATEMENT
14152: * TO BE COMPILED.
14153: *
14154: * CSWXX CONTROL CARD SWITCH VALUES ARE
14155: * CHANGED WHEN RELEVANT CONTROL
14156: * CARDS ARE MET.
14157: *
14158: * CWCOF OFFSET TO NEXT WORD IN CODE BLOCK
14159: * BEING BUILT (SEE CDWRD).
14160: *
14161: * LSTSN NUMBER OF STATEMENT MOST RECENTLY
14162: * COMPILED (INITIALLY SET TO ZERO).
14163: *
14164: * R$CIM CURRENT (INITIAL) COMPILER IMAGE
14165: * (ZERO FOR INITIAL COMPILE CALL)
14166: *
14167: * R$CNI USED TO POINT TO FOLLOWING IMAGE.
14168: * (SEE READR PROCEDURE).
14169: *
14170: * SCNGO GOTO SWITCH FOR SCANE PROCEDURE
14171: *
14172: * SCNIL LENGTH OF CURRENT IMAGE EXCLUDING
14173: * CHARACTERS REMOVED BY -INPUT.
14174: *
14175: * SCNPT CURRENT SCAN OFFSET, SEE SCANE.
14176: *
14177: * SCNRS RESCAN SWITCH FOR SCANE PROCEDURE.
14178: *
14179: * SCNSE OFFSET (IN R$CIM) OF MOST RECENTLY
14180: * SCANNED ELEMENT. SET ZERO IF NOT
14181: * CURRENTLY SCANNING ITEMS
14182: EJC
14183: *
14184: * CMPIL (CONTINUED)
14185: *
14186: * STAGE STGIC INITIAL COMPILE IN PROGRESS
14187: * STGXC CODE/CONVERT COMPILE
14188: * STGEV BUILDING EXBLK FOR EVAL
14189: * STGXT EXECUTE TIME (OUTSIDE COMPILE)
14190: * STGCE INITIAL COMPILE AFTER END LINE
14191: * STGXE EXECUTE COMPILE AFTER END LINE
14192: *
14193: * CMPIL ALSO USES A FIXED NUMBER OF LOCATIONS ON THE
14194: * MAIN STACK AS FOLLOWS. (THE DEFINITIONS OF THE ACTUAL
14195: * OFFSETS ARE IN THE DEFINITIONS SECTION).
14196: *
14197: * CMSTM(XS) POINTER TO EXPAN TREE FOR BODY OF
14198: * STATEMENT (SEE EXPAN PROCEDURE).
14199: *
14200: * CMSGO(XS) POINTER TO TREE REPRESENTATION OF
14201: * SUCCESS GOTO (SEE PROCEDURE SCNGO)9
14202: * ZERO IF NO SUCCESS GOTO IS GIVEN
14203: *
14204: * CMFGO(XS) LIKE CMSGO FOR FAILURE GOTO.
14205: *
14206: * CMCGO(XS) SET NON-ZERO ONLY IF THERE IS A
14207: * CONDITIONAL GOTO. USED FOR -FAIL,
14208: * -NOFAIL CODE GENERATION.
14209: *
14210: * CMPCD(XS) POINTER TO CDBLK FOR PREVIOUS
14211: * STATEMENT. ZERO FOR 1ST STATEMENT.
14212: *
14213: * CMFFP(XS) SET NON-ZERO IF CDFAL IN PREVIOUS
14214: * CDBLK NEEDS FILLING WITH FORWARD
14215: * POINTER, ELSE SET TO ZERO.
14216: *
14217: * CMFFC(XS) SAME AS CMFFP FOR CURRENT CDBLK
14218: *
14219: * CMSOP(XS) OFFSET TO WORD IN PREVIOUS CDBLK
14220: * TO BE FILLED IN WITH FORWARD PTR
14221: * TO NEXT CDBLK FOR SUCCESS GOTO.
14222: * ZERO IF NO FILL IN IS REQUIRED.
14223: *
14224: * CMSOC(XS) SAME AS CMSOP FOR CURRENT CDBLK.
14225: *
14226: * CMLBL(XS) POINTER TO VRBLK FOR LABEL OF
14227: * CURRENT STATEMENT. ZERO IF NO LABEL
14228: *
14229: * CMTRA(XS) POINTER TO CDBLK FOR ENTRY STMNT.
14230: EJC
14231: *
14232: * CMPIL (CONTINUED)
14233: *
14234: * ENTRY POINT
14235: *
14236: CMPIL PRC E,0 ENTRY POINT
14237: LCT WB,=CMNEN SET NUMBER OF STACK WORK LOCATIONS
14238: *
14239: * LOOP TO INITIALIZE STACK WORKING LOCATIONS
14240: *
14241: CMP00 ZER -(XS) STORE A ZERO, MAKE ONE ENTRY
14242: BCT WB,CMP00 LOOP BACK UNTIL ALL SET
14243: MOV XS,CMPXS SAVE STACK POINTER FOR ERROR SEC
14244: SSS CMPSS SAVE S-R STACK POINTER IF ANY
14245: *
14246: * LOOP THROUGH STATEMENTS
14247: *
14248: CMP01 MOV SCNPT,WB SET SCAN POINTER OFFSET
14249: MOV WB,SCNSE SET START OF ELEMENT LOCATION
14250: MOV =OCER$,WA POINT TO COMPILE ERROR CALL
14251: JSR CDWRD GENERATE AS TEMPORARY CDFAL
14252: BLT WB,SCNIL,CMP04 JUMP IF CHARS LEFT ON THIS IMAGE
14253: *
14254: * LOOP HERE AFTER COMMENT OR CONTROL CARD
14255: * ALSO SPECIAL ENTRY AFTER CONTROL CARD ERROR
14256: *
14257: CMPCE ZER XR CLEAR POSSIBLE GARBAGE XR VALUE
14258: BNE STAGE,=STGIC,CMP02 SKIP UNLESS INITIAL COMPILE
14259: JSR READR READ NEXT INPUT IMAGE
14260: BZE XR,CMP09 JUMP IF NO INPUT AVAILABLE
14261: JSR NEXTS ACQUIRE NEXT SOURCE IMAGE
14262: MOV CMPSN,LSTSN STORE STMT NO FOR USE BY LISTR
14263: ZER SCNPT RESET SCAN POINTER
14264: BRN CMP04 GO PROCESS IMAGE
14265: *
14266: * FOR EXECUTE TIME COMPILE, PERMIT EMBEDDED CONTROL CARDS
14267: * AND COMMENTS (BY SKIPPING TO NEXT SEMI-COLON)
14268: *
14269: CMP02 MOV R$CIM,XR GET CURRENT IMAGE
14270: MOV SCNPT,WB GET CURRENT OFFSET
14271: PLC XR,WB PREPARE TO GET CHARS
14272: *
14273: * SKIP TO SEMI-COLON
14274: *
14275: CMP03 LCH WC,(XR)+ GET CHAR
14276: ICV SCNPT ADVANCE OFFSET
14277: BEQ WC,=CH$SM,CMP04 SKIP IF SEMI-COLON FOUND
14278: BLT SCNPT,SCNIL,CMP03 LOOP IF MORE CHARS
14279: ZER XR CLEAR GARBAGE XR VALUE
14280: BRN CMP09 END OF IMAGE
14281: EJC
14282: *
14283: * CMPIL (CONTINUED)
14284: *
14285: * HERE WITH IMAGE AVAILABLE TO SCAN. NOTE THAT IF THE INPUT
14286: * STRING IS NULL, THEN EVERYTHING IS OK SINCE NULL IS
14287: * ACTUALLY ASSEMBLED AS A WORD OF BLANKS.
14288: *
14289: CMP04 MOV R$CIM,XR POINT TO CURRENT IMAGE
14290: MOV SCNPT,WB LOAD CURRENT OFFSET
14291: MOV WB,WA COPY FOR LABEL SCAN
14292: PLC XR,WB POINT TO FIRST CHARACTER
14293: LCH WC,(XR)+ LOAD FIRST CHARACTER
14294: BEQ WC,=CH$SM,CMP12 NO LABEL IF SEMICOLON
14295: BEQ WC,=CH$AS,CMPCE LOOP BACK IF COMMENT CARD
14296: BEQ WC,=CH$MN,CMP32 JUMP IF CONTROL CARD
14297: MOV R$CIM,R$CMP ABOUT TO DESTROY R$CIM
14298: MOV =CMLAB,XL POINT TO LABEL WORK STRING
14299: MOV XL,R$CIM SCANE IS TO SCAN WORK STRING
14300: PSC XL POINT TO FIRST CHARACTER POSITION
14301: SCH WC,(XL)+ STORE CHAR JUST LOADED
14302: MOV =CH$SM,WC GET A SEMICOLON
14303: SCH WC,(XL) STORE AFTER FIRST CHAR
14304: CSC XL FINISHED CHARACTER STORING
14305: ZER XL CLEAR POINTER
14306: ZER SCNPT START AT FIRST CHARACTER
14307: MOV SCNIL,-(XS) PRESERVE IMAGE LENGTH
14308: MOV =NUM02,SCNIL READ 2 CHARS AT MOST
14309: JSR SCANE SCAN FIRST CHAR FOR TYPE
14310: MOV (XS)+,SCNIL RESTORE IMAGE LENGTH
14311: MOV XL,WC NOTE RETURN CODE
14312: MOV R$CMP,XL GET OLD R$CIM
14313: MOV XL,R$CIM PUT IT BACK
14314: MOV WB,SCNPT REINSTATE OFFSET
14315: BNZ SCNBL,CMP12 BLANK SEEN - CANT BE LABEL
14316: MOV XL,XR POINT TO CURRENT IMAGE
14317: PLC XR,WB POINT TO FIRST CHAR AGAIN
14318: BEQ WC,=T$VAR,CMP06 OK IF LETTER
14319: BEQ WC,=T$CON,CMP06 OK IF DIGIT
14320: *
14321: * DROP IN OR JUMP FROM ERROR SECTION IF SCANE FAILED
14322: *
14323: CMPLE MOV R$CMP,R$CIM POINT TO BAD LINE
14324: ERB 214,BAD LABEL OR MISPLACED CONTINUATION LINE
14325: *
14326: * LOOP TO SCAN LABEL
14327: *
14328: CMP05 BEQ WC,=CH$SM,CMP07 SKIP IF SEMICOLON
14329: ICV WA BUMP OFFSET
14330: BEQ WA,SCNIL,CMP07 JUMP IF END OF IMAGE (LABEL END)
14331: EJC
14332: *
14333: * CMPIL (CONTINUED)
14334: *
14335: * ENTER LOOP AT THIS POINT
14336: *
14337: CMP06 LCH WC,(XR)+ ELSE LOAD NEXT CHARACTER
14338: .IF .CAHT
14339: BEQ WC,=CH$HT,CMP07 JUMP IF HORIZONTAL TAB
14340: .FI
14341: .IF .CAVT
14342: BEQ WC,=CH$VT,CMP07 JUMP IF VERTICAL TAB
14343: .FI
14344: BNE WC,=CH$BL,CMP05 LOOP BACK IF NON-BLANK
14345: *
14346: * HERE AFTER SCANNING OUT LABEL
14347: *
14348: CMP07 MOV WA,SCNPT SAVE UPDATED SCAN OFFSET
14349: SUB WB,WA GET LENGTH OF LABEL
14350: BZE WA,CMP12 SKIP IF LABEL LENGTH ZERO
14351: ZER XR CLEAR GARBAGE XR VALUE
14352: JSR SBSTR BUILD SCBLK FOR LABEL NAME
14353: JSR GTNVR LOCATE/CONTRUCT VRBLK
14354: PPM DUMMY (IMPOSSIBLE) ERROR RETURN
14355: MOV XR,CMLBL(XS) STORE LABEL POINTER
14356: BNZ VRLEN(XR),CMP11 JUMP IF NOT SYSTEM LABEL
14357: BNE VRSVP(XR),=V$END,CMP11 JUMP IF NOT END LABEL
14358: *
14359: * HERE FOR END LABEL SCANNED OUT
14360: *
14361: ADD =STGND,STAGE ADJUST STAGE APPROPRIATELY
14362: JSR SCANE SCAN OUT NEXT ELEMENT
14363: BEQ XL,=T$SMC,CMP10 JUMP IF END OF IMAGE
14364: BNE XL,=T$VAR,CMP08 ELSE ERROR IF NOT VARIABLE
14365: *
14366: * HERE CHECK FOR VALID INITIAL TRANSFER
14367: *
14368: BEQ VRLBL(XR),=STNDL,CMP08 JUMP IF NOT DEFINED (ERROR)
14369: MOV VRLBL(XR),CMTRA(XS) ELSE SET INITIAL ENTRY POINTER
14370: JSR SCANE SCAN NEXT ELEMENT
14371: BEQ XL,=T$SMC,CMP10 JUMP IF OK (END OF IMAGE)
14372: *
14373: * HERE FOR BAD TRANSFER LABEL
14374: *
14375: CMP08 ERB 215,SYNTAX ERROR. UNDEFINED OR ERRONEOUS ENTRY LABEL
14376: *
14377: * HERE FOR END OF INPUT (NO END LABEL DETECTED)
14378: *
14379: CMP09 ADD =STGND,STAGE ADJUST STAGE APPROPRIATELY
14380: BEQ STAGE,=STGXE,CMP10 JUMP IF CODE CALL (OK)
14381: ERB 216,SYNTAX ERROR. MISSING END LINE
14382: *
14383: * HERE AFTER PROCESSING END LINE (MERGE HERE ON END ERROR)
14384: *
14385: CMP10 MOV =OSTP$,WA SET STOP CALL POINTER
14386: JSR CDWRD GENERATE AS STATEMENT CALL
14387: BRN CMPSE JUMP TO GENERATE AS FAILURE
14388: EJC
14389: *
14390: * CMPIL (CONTINUED)
14391: *
14392: * HERE AFTER PROCESSING LABEL OTHER THAN END
14393: *
14394: CMP11 BNE STAGE,=STGIC,CMP12 JUMP IF CODE CALL - REDEF. OK
14395: BEQ VRLBL(XR),=STNDL,CMP12 ELSE CHECK FOR REDEFINITION
14396: ZER CMLBL(XS) LEAVE FIRST LABEL DECLN UNDISTURBED
14397: ERB 217,SYNTAX ERROR. DUPLICATE LABEL
14398: *
14399: * HERE AFTER DEALING WITH LABEL
14400: *
14401: CMP12 ZER WB SET FLAG FOR STATEMENT BODY
14402: JSR EXPAN GET TREE FOR STATEMENT BODY
14403: MOV XR,CMSTM(XS) STORE FOR LATER USE
14404: ZER CMSGO(XS) CLEAR SUCCESS GOTO POINTER
14405: ZER CMFGO(XS) CLEAR FAILURE GOTO POINTER
14406: ZER CMCGO(XS) CLEAR CONDITIONAL GOTO FLAG
14407: JSR SCANE SCAN NEXT ELEMENT
14408: BNE XL,=T$COL,CMP18 JUMP IT NOT COLON (NO GOTO)
14409: *
14410: * LOOP TO PROCESS GOTO FIELDS
14411: *
14412: CMP13 MNZ SCNGO SET GOTO FLAG
14413: JSR SCANE SCAN NEXT ELEMENT
14414: BEQ XL,=T$SMC,CMP31 JUMP IF NO FIELDS LEFT
14415: BEQ XL,=T$SGO,CMP14 JUMP IF S FOR SUCCESS GOTO
14416: BEQ XL,=T$FGO,CMP16 JUMP IF F FOR FAILURE GOTO
14417: *
14418: * HERE FOR UNCONDITIONAL GOTO (I.E. NOT F OR S)
14419: *
14420: MNZ SCNRS SET TO RESCAN ELEMENT NOT F,S
14421: JSR SCNGF SCAN OUT GOTO FIELD
14422: BNZ CMFGO(XS),CMP17 ERROR IF FGOTO ALREADY
14423: MOV XR,CMFGO(XS) ELSE SET AS FGOTO
14424: BRN CMP15 MERGE WITH SGOTO CIRCUIT
14425: *
14426: * HERE FOR SUCCESS GOTO
14427: *
14428: CMP14 JSR SCNGF SCAN SUCCESS GOTO FIELD
14429: MOV =NUM01,CMCGO(XS) SET CONDITIONAL GOTO FLAG
14430: *
14431: * UNCONTIONAL GOTO MERGES HERE
14432: *
14433: CMP15 BNZ CMSGO(XS),CMP17 ERROR IF SGOTO ALREADY GIVEN
14434: MOV XR,CMSGO(XS) ELSE SET SGOTO
14435: BRN CMP13 LOOP BACK FOR NEXT GOTO FIELD
14436: *
14437: * HERE FOR FAILURE GOTO
14438: *
14439: CMP16 JSR SCNGF SCAN GOTO FIELD
14440: MOV =NUM01,CMCGO(XS) SET CONDITONAL GOTO FLAG
14441: BNZ CMFGO(XS),CMP17 ERROR IF FGOTO ALREADY GIVEN
14442: MOV XR,CMFGO(XS) ELSE STORE FGOTO POINTER
14443: BRN CMP13 LOOP BACK FOR NEXT FIELD
14444: EJC
14445: *
14446: * CMPIL (CONTINUED)
14447: *
14448: * HERE FOR DUPLICATED GOTO FIELD
14449: *
14450: CMP17 ERB 218,SYNTAX ERROR. DUPLICATED GOTO FIELD
14451: *
14452: * HERE TO GENERATE CODE
14453: *
14454: CMP18 ZER SCNSE STOP POSITIONAL ERROR FLAGS
14455: MOV CMSTM(XS),XR LOAD TREE PTR FOR STATEMENT BODY
14456: ZER WB COLLECTABLE VALUE FOR WB FOR CDGVL
14457: ZER WC RESET CONSTANT FLAG FOR CDGVL
14458: JSR EXPAP TEST FOR PATTERN MATCH
14459: PPM CMP19 JUMP IF NOT PATTERN MATCH
14460: MOV =OPMS$,CMOPN(XR) ELSE SET PATTERN MATCH POINTER
14461: MOV =C$PMT,CMTYP(XR)
14462: *
14463: * HERE AFTER DEALING WITH SPECIAL PATTERN MATCH CASE
14464: *
14465: CMP19 JSR CDGVL GENERATE CODE FOR BODY OF STATEMENT
14466: MOV CMSGO(XS),XR LOAD SGOTO POINTER
14467: MOV XR,WA COPY IT
14468: BZE XR,CMP21 JUMP IF NO SUCCESS GOTO
14469: ZER CMSOC(XS) CLEAR SUCCESS OFFSET FILLIN PTR
14470: BHI XR,STATE,CMP20 JUMP IF COMPLEX GOTO
14471: *
14472: * HERE FOR SIMPLE SUCCESS GOTO (LABEL)
14473: *
14474: ADD *VRTRA,WA POINT TO VRTRA FIELD AS REQUIRED
14475: JSR CDWRD GENERATE SUCCESS GOTO
14476: BRN CMP22 JUMP TO DEAL WITH FGOTO
14477: *
14478: * HERE FOR COMPLEX SUCCESS GOTO
14479: *
14480: CMP20 BEQ XR,CMFGO(XS),CMP22 NO CODE IF SAME AS FGOTO
14481: ZER WB ELSE SET OK VALUE FOR CDGVL IN WB
14482: JSR CDGCG GENERATE CODE FOR SUCCESS GOTO
14483: BRN CMP22 JUMP TO DEAL WITH FGOTO
14484: *
14485: * HERE FOR NO SUCCESS GOTO
14486: *
14487: CMP21 MOV CWCOF,CMSOC(XS) SET SUCCESS FILL IN OFFSET
14488: MOV =OCER$,WA POINT TO COMPILE ERROR CALL
14489: JSR CDWRD GENERATE AS TEMPORARY VALUE
14490: EJC
14491: *
14492: * CMPIL (CONTINUED)
14493: *
14494: * HERE TO DEAL WITH FAILURE GOTO
14495: *
14496: CMP22 MOV CMFGO(XS),XR LOAD FAILURE GOTO POINTER
14497: MOV XR,WA COPY IT
14498: ZER CMFFC(XS) SET NO FILL IN REQUIRED YET
14499: BZE XR,CMP23 JUMP IF NO FAILURE GOTO GIVEN
14500: ADD *VRTRA,WA POINT TO VRTRA FIELD IN CASE
14501: BLO XR,STATE,CMPSE JUMP TO GEN IF SIMPLE FGOTO
14502: *
14503: * HERE FOR COMPLEX FAILURE GOTO
14504: *
14505: MOV CWCOF,WB SAVE OFFSET TO O$GOF CALL
14506: MOV =OGOF$,WA POINT TO FAILURE GOTO CALL
14507: JSR CDWRD GENERATE
14508: MOV =OFIF$,WA POINT TO FAIL IN FAIL WORD
14509: JSR CDWRD GENERATE
14510: JSR CDGCG GENERATE CODE FOR FAILURE GOTO
14511: MOV WB,WA COPY OFFSET TO O$GOF FOR CDFAL
14512: MOV =B$CDC,WB SET COMPLEX CASE CDTYP
14513: BRN CMP25 JUMP TO BUILD CDBLK
14514: *
14515: * HERE IF NO FAILURE GOTO GIVEN
14516: *
14517: CMP23 MOV =OUNF$,WA LOAD UNEXPECTED FAILURE CALL IN CAS
14518: MOV CSWFL,WC GET -NOFAIL FLAG
14519: ORB CMCGO(XS),WC CHECK IF CONDITIONAL GOTO
14520: ZRB WC,CMPSE JUMP IF -NOFAIL AND NO COND. GOTO
14521: MNZ CMFFC(XS) ELSE SET FILL IN FLAG
14522: MOV =OCER$,WA AND SET COMPILE ERROR FOR TEMPORARY
14523: *
14524: * MERGE HERE WITH CDFAL VALUE IN WA, SIMPLE CDBLK
14525: * ALSO SPECIAL ENTRY AFTER STATEMENT ERROR
14526: *
14527: CMPSE MOV =B$CDS,WB SET CDTYP FOR SIMPLE CASE
14528: EJC
14529: *
14530: * CMPIL (CONTINUED)
14531: *
14532: * MERGE HERE TO BUILD CDBLK
14533: *
14534: * (WA) CDFAL VALUE TO BE GENERATED
14535: * (WB) CDTYP VALUE TO BE GENERATED
14536: *
14537: * AT THIS STAGE, WE CHOP OFF AN APPROPRIATE CHUNK OF THE
14538: * CURRENT CCBLK AND CONVERT IT INTO A CDBLK. THE REMAINDER
14539: * OF THE CCBLK IS REFORMATTED TO BE THE NEW CCBLK.
14540: *
14541: CMP25 MOV R$CCB,XR POINT TO CCBLK
14542: MOV CMLBL(XS),XL GET POSSIBLE LABEL POINTER
14543: BZE XL,CMP26 SKIP IF NO LABEL
14544: ZER CMLBL(XS) CLEAR FLAG FOR NEXT STATEMENT
14545: MOV XR,VRLBL(XL) PUT CDBLK PTR IN VRBLK LABEL FIELD
14546: *
14547: * MERGE AFTER DOING LABEL
14548: *
14549: CMP26 MOV WB,(XR) SET TYPE WORD FOR NEW CDBLK
14550: MOV WA,CDFAL(XR) SET FAILURE WORD
14551: MOV XR,XL COPY POINTER TO CCBLK
14552: MOV CCUSE(XR),WB LOAD LENGTH GEN (= NEW CDLEN)
14553: MOV CCLEN(XR),WC LOAD TOTAL CCBLK LENGTH
14554: ADD WB,XL POINT PAST CDBLK
14555: SUB WB,WC GET LENGTH LEFT FOR CHOP OFF
14556: MOV =B$CCT,(XL) SET TYPE CODE FOR NEW CCBLK AT END
14557: MOV *CCCOD,CCUSE(XL) SET INITIAL CODE OFFSET
14558: MOV *CCCOD,CWCOF REINITIALISE CWCOF
14559: MOV WC,CCLEN(XL) SET NEW LENGTH
14560: MOV XL,R$CCB SET NEW CCBLK POINTER
14561: MOV CMPSN,CDSTM(XR) SET STATEMENT NUMBER
14562: ICV CMPSN BUMP STATEMENT NUMBER
14563: *
14564: * SET POINTERS IN PREVIOUS CODE BLOCK AS REQUIRED
14565: *
14566: MOV CMPCD(XS),XL LOAD PTR TO PREVIOUS CDBLK
14567: BZE CMFFP(XS),CMP27 JUMP IF NO FAILURE FILL IN REQUIRED
14568: MOV XR,CDFAL(XL) ELSE SET FAILURE PTR IN PREVIOUS
14569: *
14570: * HERE TO DEAL WITH SUCCESS FORWARD POINTER
14571: *
14572: CMP27 MOV CMSOP(XS),WA LOAD SUCCESS OFFSET
14573: BZE WA,CMP28 JUMP IF NO FILL IN REQUIRED
14574: ADD WA,XL ELSE POINT TO FILL IN LOCATION
14575: MOV XR,(XL) STORE FORWARD POINTER
14576: ZER XL CLEAR GARBAGE XL VALUE
14577: EJC
14578: *
14579: * CMPIL (CONTINUED)
14580: *
14581: * NOW SET FILL IN POINTERS FOR THIS STATEMENT
14582: *
14583: CMP28 MOV CMFFC(XS),CMFFP(XS) COPY FAILURE FILL IN FLAG
14584: MOV CMSOC(XS),CMSOP(XS) COPY SUCCESS FILL IN OFFSET
14585: MOV XR,CMPCD(XS) SAVE PTR TO THIS CDBLK
14586: BNZ CMTRA(XS),CMP29 JUMP IF INITIAL ENTRY ALREADY SET
14587: MOV XR,CMTRA(XS) ELSE SET PTR HERE AS DEFAULT
14588: *
14589: * HERE AFTER COMPILING ONE STATEMENT
14590: *
14591: CMP29 BLT STAGE,=STGCE,CMP01 JUMP IF NOT END LINE JUST DONE
14592: BZE CSWLS,CMP30 SKIP IF -NOLIST
14593: JSR LISTR LIST LAST LINE
14594: *
14595: * RETURN
14596: *
14597: CMP30 MOV CMTRA(XS),XR LOAD INITIAL ENTRY CDBLK POINTER
14598: ADD *CMNEN,XS POP WORK LOCATIONS OFF STACK
14599: EXI AND RETURN TO CMPIL CALLER
14600: *
14601: * HERE AT END OF GOTO FIELD
14602: *
14603: CMP31 MOV CMFGO(XS),WB GET FAIL GOTO
14604: ORB CMSGO(XS),WB OR IN SUCCESS GOTO
14605: BNZ WB,CMP18 OK IF NON-NULL FIELD
14606: ERB 219,SYNTAX ERROR. EMPTY GOTO FIELD
14607: *
14608: * CONTROL CARD FOUND
14609: *
14610: CMP32 ICV WB POINT PAST CH$MN
14611: JSR CNCRD PROCESS CONTROL CARD
14612: ZER SCNSE CLEAR START OF ELEMENT LOC.
14613: BRN CMPCE LOOP FOR NEXT STATEMENT
14614: ENP END PROCEDURE CMPIL
14615: EJC
14616: *
14617: * CNCRD -- CONTROL CARD PROCESSOR
14618: *
14619: * CALLED TO DEAL WITH CONTROL CARDS
14620: *
14621: * R$CIM POINTS TO CURRENT IMAGE
14622: * (WB) OFFSET TO 1ST CHAR OF CONTROL CARD
14623: * JSR CNCRD CALL TO PROCESS CONTROL CARDS
14624: * (XL,XR,WA,WB,WC,IA) DESTROYED
14625: *
14626: CNCRD PRC E,0 ENTRY POINT
14627: MOV WB,SCNPT OFFSET FOR CONTROL CARD SCAN
14628: MOV =CCNOC,WA NUMBER OF CHARS FOR COMPARISON
14629: CTW WA,0 CONVERT TO WORD COUNT
14630: MOV WA,CNSWC SAVE WORD COUNT
14631: *
14632: * LOOP HERE IF MORE THAN ONE CONTROL CARD
14633: *
14634: CNC01 BGE SCNPT,SCNIL,CNC09 RETURN IF END OF IMAGE
14635: MOV R$CIM,XR POINT TO IMAGE
14636: PLC XR,SCNPT CHAR PTR FOR FIRST CHAR
14637: LCH WA,(XR)+ GET FIRST CHAR
14638: .IF .CULC
14639: FLC WA FOLD TO UPPER CASE
14640: .FI
14641: BEQ WA,=CH$LI,CNC07 SPECIAL CASE OF -INXXX
14642: MNZ SCNCC SET FLAG FOR SCANE
14643: JSR SCANE SCAN CARD NAME
14644: ZER SCNCC CLEAR SCANE FLAG
14645: BNZ XL,CNC06 FAIL UNLESS CONTROL CARD NAME
14646: MOV =CCNOC,WA NO. OF CHARS TO BE COMPARED
14647: BLT SCLEN(XR),WA,CNC06 FAIL IF TOO FEW CHARS
14648: MOV XR,XL POINT TO CONTROL CARD NAME
14649: ZER WB ZERO OFFSET FOR SUBSTRING
14650: JSR SBSTR EXTRACT SUBSTRING FOR COMPARISON
14651: .IF .CULC
14652: MOV SCLEN(XR),WA RELOAD LENGTH
14653: JSR FLSTG FOLD TO UPPER CASE
14654: .FI
14655: MOV XR,CNSCC KEEP CONTROL CARD SUBSTRING PTR
14656: MOV =CCNMS,XR POINT TO LIST OF STANDARD NAMES
14657: ZER WB INITIALISE NAME OFFSET
14658: LCT WC,=CC$NC NUMBER OF STANDARD NAMES
14659: *
14660: * TRY TO MATCH NAME
14661: *
14662: CNC02 MOV CNSCC,XL POINT TO NAME
14663: LCT WA,CNSWC COUNTER FOR INNER LOOP
14664: BRN CNC04 JUMP INTO LOOP
14665: *
14666: * INNER LOOP TO MATCH CARD NAME CHARS
14667: *
14668: CNC03 ICA XR BUMP STANDARD NAMES PTR
14669: ICA XL BUMP NAME POINTER
14670: *
14671: * HERE TO INITIATE THE LOOP
14672: *
14673: CNC04 CNE SCHAR(XL),(XR),CNC05 COMP. UP TO CFP$C CHARS AT ONCE
14674: BCT WA,CNC03 LOOP IF MORE WORDS TO COMPARE
14675: EJC
14676: *
14677: * CNCRD (CONTINUED)
14678: *
14679: * MATCHED - BRANCH ON CARD OFFSET
14680: *
14681: MOV WB,XL GET NAME OFFSET
14682: BSW XL,CC$NC SWITCH
14683: .IF .CULC
14684: IFF CC$CA,CNC37 -CASE
14685: .FI
14686: IFF CC$DO,CNC10 -DOUBLE
14687: IFF CC$DU,CNC11 -DUMP
14688: IFF CC$EJ,CNC12 -EJECT
14689: IFF CC$ER,CNC13 -ERRORS
14690: IFF CC$EX,CNC14 -EXECUTE
14691: IFF CC$FA,CNC15 -FAIL
14692: IFF CC$LI,CNC16 -LIST
14693: IFF CC$NR,CNC17 -NOERRORS
14694: IFF CC$NX,CNC18 -NOEXECUTE
14695: IFF CC$NF,CNC19 -NOFAIL
14696: IFF CC$NL,CNC20 -NOLIST
14697: IFF CC$NO,CNC21 -NOOPT
14698: IFF CC$NP,CNC22 -NOPRINT
14699: IFF CC$OP,CNC24 -OPTIMISE
14700: IFF CC$PR,CNC25 -PRINT
14701: IFF CC$SI,CNC27 -SINGLE
14702: IFF CC$SP,CNC28 -SPACE
14703: IFF CC$ST,CNC31 -STITLE
14704: IFF CC$TI,CNC32 -TITLE
14705: IFF CC$TR,CNC36 -TRACE
14706: ESW END SWITCH
14707: *
14708: * NOT MATCHED YET. ALIGN STD NAMES PTR AND TRY AGAIN
14709: *
14710: CNC05 ICA XR BUMP STANDARD NAMES PTR
14711: BCT WA,CNC05 LOOP
14712: ICV WB BUMP NAMES OFFSET
14713: BCT WC,CNC02 CONTINUE IF MORE NAMES
14714: *
14715: * INVALID CONTROL CARD NAME
14716: *
14717: CNC06 ERB 247,INVALID CONTROL CARD
14718: *
14719: * SPECIAL PROCESSING FOR -INXXX
14720: *
14721: CNC07 LCH WA,(XR) GET NEXT CHAR
14722: .IF .CULC
14723: FLC WA FOLD TO UPPER CASE
14724: .FI
14725: BNE WA,=CH$LN,CNC06 FAIL IF NOT LETTER N
14726: ADD =NUM02,SCNPT BUMP OFFSET PAST -IN
14727: JSR SCANE SCAN INTEGER AFTER -IN
14728: MOV XR,-(XS) STACK SCANNED ITEM
14729: JSR GTSMI CHECK IF INTEGER
14730: PPM CNC06 FAIL IF NOT INTEGER
14731: PPM CNC06 FAIL IF NEGATIVE OR LARGE
14732: MOV XR,CSWIN KEEP INTEGER
14733: EJC
14734: *
14735: * CNCRD (CONTINUED)
14736: *
14737: * CHECK FOR MORE CONTROL CARDS BEFORE RETURNING
14738: *
14739: CNC08 MOV SCNPT,WA PRESERVE IN CASE XEQ TIME COMPILE
14740: JSR SCANE LOOK FOR COMMA
14741: BEQ XL,=T$CMA,CNC01 LOOP IF COMMA FOUND
14742: MOV WA,SCNPT RESTORE SCNPT IN CASE XEQ TIME
14743: *
14744: * RETURN POINT
14745: *
14746: CNC09 EXI RETURN
14747: *
14748: * -DOUBLE
14749: *
14750: CNC10 MNZ CSWDB SET SWITCH
14751: BRN CNC08 MERGE
14752: *
14753: * -DUMP
14754: * THIS IS USED FOR SYSTEM DEBUGGING . IT HAS THE EFFECT OF
14755: * PRODUCING A CORE DUMP AT COMPILATION TIME
14756: *
14757: CNC11 JSR SYSDM CALL DUMPER
14758: BRN CNC09 FINISHED
14759: *
14760: * -EJECT
14761: *
14762: CNC12 BZE CSWLS,CNC09 RETURN IF -NOLIST
14763: JSR PRTPS EJECT
14764: JSR LISTT LIST TITLE
14765: BRN CNC09 FINISHED
14766: *
14767: * -ERRORS
14768: *
14769: CNC13 ZER CSWER CLEAR SWITCH
14770: BRN CNC08 MERGE
14771: *
14772: * -EXECUTE
14773: *
14774: CNC14 ZER CSWEX CLEAR SWITCH
14775: BRN CNC08 MERGE
14776: *
14777: * -FAIL
14778: *
14779: CNC15 MNZ CSWFL SET SWITCH
14780: BRN CNC08 MERGE
14781: *
14782: * -LIST
14783: *
14784: CNC16 MNZ CSWLS SET SWITCH
14785: BEQ STAGE,=STGIC,CNC08 DONE IF COMPILE TIME
14786: *
14787: * LIST CODE LINE IF EXECUTE TIME COMPILE
14788: *
14789: ZER LSTPF PERMIT LISTING
14790: JSR LISTR LIST LINE
14791: BRN CNC08 MERGE
14792: EJC
14793: *
14794: * CNCRD (CONTINUED)
14795: *
14796: * -NOERRORS
14797: *
14798: CNC17 MNZ CSWER SET SWITCH
14799: BRN CNC08 MERGE
14800: *
14801: * -NOEXECUTE
14802: *
14803: CNC18 MNZ CSWEX SET SWITCH
14804: BRN CNC08 MERGE
14805: *
14806: * -NOFAIL
14807: *
14808: CNC19 ZER CSWFL CLEAR SWITCH
14809: BRN CNC08 MERGE
14810: *
14811: * -NOLIST
14812: *
14813: CNC20 ZER CSWLS CLEAR SWITCH
14814: BRN CNC08 MERGE
14815: *
14816: * -NOOPTIMISE
14817: *
14818: CNC21 MNZ CSWNO SET SWITCH
14819: BRN CNC08 MERGE
14820: *
14821: * -NOPRINT
14822: *
14823: CNC22 ZER CSWPR CLEAR SWITCH
14824: BRN CNC08 MERGE
14825: *
14826: * -OPTIMISE
14827: *
14828: CNC24 ZER CSWNO CLEAR SWITCH
14829: BRN CNC08 MERGE
14830: *
14831: * -PRINT
14832: *
14833: CNC25 MNZ CSWPR SET SWITCH
14834: BRN CNC08 MERGE
14835: EJC
14836: *
14837: * CNCRD (CONTINUED)
14838: *
14839: * -SINGLE
14840: *
14841: CNC27 ZER CSWDB CLEAR SWITCH
14842: BRN CNC08 MERGE
14843: *
14844: * -SPACE
14845: *
14846: CNC28 BZE CSWLS,CNC09 RETURN IF -NOLIST
14847: JSR SCANE SCAN INTEGER AFTER -SPACE
14848: MOV =NUM01,WC 1 SPACE IN CASE
14849: BEQ XR,=T$SMC,CNC29 JUMP IF NO INTEGER
14850: MOV XR,-(XS) STACK IT
14851: JSR GTSMI CHECK INTEGER
14852: PPM CNC06 FAIL IF NOT INTEGER
14853: PPM CNC06 FAIL IF NEGATIVE OR LARGE
14854: BNZ WC,CNC29 JUMP IF NON ZERO
14855: MOV =NUM01,WC ELSE 1 SPACE
14856: *
14857: * MERGE WITH COUNT OF LINES TO SKIP
14858: *
14859: CNC29 ADD WC,LSTLC BUMP LINE COUNT
14860: LCT WC,WC CONVERT TO LOOP COUNTER
14861: BLT LSTLC,LSTNP,CNC30 JUMP IF FITS ON PAGE
14862: JSR PRTPS EJECT
14863: JSR LISTT LIST TITLE
14864: BRN CNC09 MERGE
14865: *
14866: * SKIP LINES
14867: *
14868: CNC30 JSR PRTNL PRINT A BLANK
14869: BCT WC,CNC30 LOOP
14870: BRN CNC09 MERGE
14871: EJC
14872: *
14873: * CNCRD (CONTINUED)
14874: *
14875: * -STITL
14876: *
14877: CNC31 MOV =R$STL,CNR$T PTR TO R$STL
14878: BRN CNC33 MERGE
14879: *
14880: * -TITLE
14881: *
14882: CNC32 MOV =NULLS,R$STL CLEAR SUBTITLE
14883: MOV =R$TTL,CNR$T PTR TO R$TTL
14884: *
14885: * COMMON PROCESSING FOR -TITLE, -STITL
14886: *
14887: CNC33 MOV =NULLS,XR NULL IN CASE NEEDED
14888: MNZ CNTTL SET FLAG FOR NEXT LISTR CALL
14889: MOV =CCOFS,WB OFFSET TO TITLE/SUBTITLE
14890: MOV SCNIL,WA INPUT IMAGE LENGTH
14891: BLO WA,WB,CNC34 JUMP IF NO CHARS LEFT
14892: SUB WB,WA NO OF CHARS TO EXTRACT
14893: MOV R$CIM,XL POINT TO IMAGE
14894: JSR SBSTR GET TITLE/SUBTITLE
14895: *
14896: * STORE TITLE/SUBTITLE
14897: *
14898: CNC34 MOV CNR$T,XL POINT TO STORAGE LOCATION
14899: MOV XR,(XL) STORE TITLE/SUBTITLE
14900: BEQ XL,=R$STL,CNC09 RETURN IF STITL
14901: BNZ PRECL,CNC09 RETURN IF EXTENDED LISTING
14902: BZE PRICH,CNC09 RETURN IF REGULAR PRINTER
14903: MOV SCLEN(XR),XL GET LENGTH OF TITLE
14904: MOV XL,WA COPY IT
14905: BZE XL,CNC35 JUMP IF NULL
14906: ADD =NUM10,XL INCREMENT
14907: BHI XL,PRLEN,CNC09 USE DEFAULT LSTP0 VAL IF TOO LONG
14908: ADD =NUM04,WA POINT JUST PAST TITLE
14909: *
14910: * STORE OFFSET TO PAGE NN MESSAGE FOR SHORT TITLE
14911: *
14912: CNC35 MOV WA,LSTPO STORE OFFSET
14913: BRN CNC09 RETURN
14914: *
14915: * -TRACE
14916: * PROVIDED FOR SYSTEM DEBUGGING. TOGGLES THE SYSTEM LABEL
14917: * TRACE SWITCH AT COMPILE TIME
14918: *
14919: CNC36 JSR SYSTT TOGGLE SWITCH
14920: BRN CNC08 MERGE
14921: .IF .CULC
14922: *
14923: * -CASE
14924: * SETS VALUE OF KVCAS SO THAT NAMES ARE FOLDED OR NOT
14925: * DURING COMPILATION.
14926: *
14927: CNC37 JSR SCANE SCAN INTEGER AFTER -CASE
14928: ZER WC GET 0 IN CASE NONE THERE
14929: BEQ XL,=T$SMC,CNC38 SKIP IF NO INTEGER
14930: MOV XR,-(XS) STACK IT
14931: JSR GTSMI CHECK INTEGER
14932: PPM CNC06 FAIL IF NOT INTEGER
14933: PPM CNC06 FAIL IF NEGATIVE OR TOO LARGE
14934: CNC38 MOV WC,KVCAS STORE NEW CASE VALUE
14935: BRN CNC09 MERGE
14936: .FI
14937: ENP END PROCEDURE CNCRD
14938: EJC
14939: *
14940: * DFFNC -- DEFINE FUNCTION
14941: *
14942: * DFFNC IS CALLED WHENEVER A NEW FUNCTION IS ASSIGNED TO
14943: * A VARIABLE. IT DEALS WITH EXTERNAL FUNCTION USE COUNTS.
14944: *
14945: * (XR) POINTER TO VRBLK
14946: * (XL) POINTER TO NEW FUNCTION BLOCK
14947: * JSR DFFNC CALL TO DEFINE FUNCTION
14948: * (WA,WB) DESTROYED
14949: *
14950: DFFNC PRC E,0 ENTRY POINT
14951: BNE (XL),=B$EFC,DFFN1 SKIP IF NEW FUNCTION NOT EXTERNAL
14952: ICV EFUSE(XL) ELSE INCREMENT ITS USE COUNT
14953: *
14954: * HERE AFTER DEALING WITH NEW FUNCTION USE COUNT
14955: *
14956: DFFN1 MOV XR,WA SAVE VRBLK POINTER
14957: .IF .CNLD
14958: .ELSE
14959: MOV VRFNC(XR),XR LOAD OLD FUNCTION POINTER
14960: BNE (XR),=B$EFC,DFFN2 JUMP IF OLD FUNCTION NOT EXTERNAL
14961: MOV EFUSE(XR),WB ELSE GET USE COUNT
14962: DCV WB DECREMENT
14963: MOV WB,EFUSE(XR) STORE DECREMENTED VALUE
14964: BNZ WB,DFFN2 JUMP IF USE COUNT STILL NON-ZERO
14965: JSR SYSUL ELSE CALL SYSTEM UNLOAD FUNCTION
14966: .FI
14967: *
14968: * HERE AFTER DEALING WITH OLD FUNCTION USE COUNT
14969: *
14970: DFFN2 MOV WA,XR RESTORE VRBLK POINTER
14971: MOV XL,WA COPY FUNCTION BLOCK PTR
14972: BLT XR,=R$YYY,DFFN3 SKIP CHECKS IF OPSYN OP DEFINITION
14973: BNZ VRLEN(XR),DFFN3 JUMP IF NOT SYSTEM VARIABLE
14974: *
14975: * FOR SYSTEM VARIABLE, CHECK FOR ILLEGAL REDEFINITION
14976: *
14977: MOV VRSVP(XR),XL POINT TO SVBLK
14978: MOV SVBIT(XL),WB LOAD BIT INDICATORS
14979: ANB BTFNC,WB IS IT A SYSTEM FUNCTION
14980: ZRB WB,DFFN3 REDEF OK IF NOT
14981: ERB 248,ATTEMPTED REDEFINITION OF SYSTEM FUNCTION
14982: *
14983: * HERE IF REDEFINITION IS PERMITTED
14984: *
14985: DFFN3 MOV WA,VRFNC(XR) STORE NEW FUNCTION POINTER
14986: MOV WA,XL RESTORE FUNCTION BLOCK POINTER
14987: EXI RETURN TO DFFNC CALLER
14988: ENP END PROCEDURE DFFNC
14989: EJC
14990: *
14991: * DTACH -- DETACH I/O ASSOCIATED NAMES
14992: *
14993: * DETACHES TRBLKS FROM I/O ASSOCIATED VARIABLES, REMOVES
14994: * ENTRY FROM IOCHN CHAIN ATTACHED TO FILEARG1 VRBLK AND MAY
14995: * REMOVE VRBLK ACCESS AND STORE TRAPS.
14996: * INPUT, OUTPUT, TERMINAL ARE HANDLED SPECIALLY.
14997: *
14998: * (XL) I/O ASSOC. VBL NAME BASE PTR
14999: * (WA) OFFSET TO NAME
15000: * JSR DTACH CALL FOR DETACH OPERATION
15001: * (XL,XR,WA,WB,WC) DESTROYED
15002: *
15003: DTACH PRC E,0 ENTRY POINT
15004: MOV XL,DTCNB STORE NAME BASE (GBCOL NOT CALLED)
15005: ADD WA,XL POINT TO NAME LOCATION
15006: MOV XL,DTCNM STORE IT
15007: *
15008: * LOOP TO SEARCH FOR I/O TRBLK
15009: *
15010: DTCH1 MOV XL,XR COPY NAME POINTER
15011: *
15012: * CONTINUE AFTER BLOCK DELETION
15013: *
15014: DTCH2 MOV (XL),XL POINT TO NEXT VALUE
15015: BNE (XL),=B$TRT,DTCH6 JUMP AT CHAIN END
15016: MOV TRTYP(XL),WA GET TRAP BLOCK TYPE
15017: BEQ WA,=TRTIN,DTCH3 JUMP IF INPUT
15018: BEQ WA,=TRTOU,DTCH3 JUMP IF OUTPUT
15019: ADD *TRNXT,XL POINT TO NEXT LINK
15020: BRN DTCH1 LOOP
15021: *
15022: * DELETE AN OLD ASSOCIATION
15023: *
15024: DTCH3 MOV TRVAL(XL),(XR) DELETE TRBLK
15025: MOV XL,WA DUMP XL ...
15026: MOV XR,WB ... AND XR
15027: MOV TRTRF(XL),XL POINT TO TRTRF TRAP BLOCK
15028: BZE XL,DTCH5 JUMP IF NO IOCHN
15029: BNE (XL),=B$TRT,DTCH5 JUMP IF INPUT, OUTPUT, TERMINAL
15030: *
15031: * LOOP TO SEARCH IOCHN CHAIN FOR NAME PTR
15032: *
15033: DTCH4 MOV XL,XR REMEMBER LINK PTR
15034: MOV TRTRF(XL),XL POINT TO NEXT LINK
15035: BZE XL,DTCH5 JUMP IF END OF CHAIN
15036: MOV IONMB(XL),WC GET NAME BASE
15037: ADD IONMO(XL),WC ADD OFFSET
15038: BNE WC,DTCNM,DTCH4 LOOP IF NO MATCH
15039: MOV TRTRF(XL),TRTRF(XR) REMOVE NAME FROM CHAIN
15040: EJC
15041: *
15042: * DTACH (CONTINUED)
15043: *
15044: * PREPARE TO RESUME I/O TRBLK SCAN
15045: *
15046: DTCH5 MOV WA,XL RECOVER XL ...
15047: MOV WB,XR ... AND XR
15048: ADD *TRVAL,XL POINT TO VALUE FIELD
15049: BRN DTCH2 CONTINUE
15050: *
15051: * EXIT POINT
15052: *
15053: DTCH6 MOV DTCNB,XR POSSIBLE VRBLK PTR
15054: JSR SETVR RESET VRBLK IF NECESSARY
15055: EXI RETURN
15056: ENP END PROCEDURE DTACH
15057: EJC
15058: *
15059: * DTYPE -- GET DATATYPE NAME
15060: *
15061: * (XR) OBJECT WHOSE DATATYPE IS REQUIRED
15062: * JSR DTYPE CALL TO GET DATATYPE
15063: * (XR) RESULT DATATYPE
15064: *
15065: DTYPE PRC E,0 ENTRY POINT
15066: BEQ (XR),=B$PDT,DTYP1 JUMP IF PROG.DEFINED
15067: MOV (XR),XR LOAD TYPE WORD
15068: LEI XR GET ENTRY POINT ID (BLOCK CODE)
15069: WTB XR CONVERT TO BYTE OFFSET
15070: MOV SCNMT(XR),XR LOAD TABLE ENTRY
15071: EXI EXIT TO DTYPE CALLER
15072: *
15073: * HERE IF PROGRAM DEFINED
15074: *
15075: DTYP1 MOV PDDFP(XR),XR POINT TO DFBLK
15076: MOV DFNAM(XR),XR GET DATATYPE NAME FROM DFBLK
15077: EXI RETURN TO DTYPE CALLER
15078: ENP END PROCEDURE DTYPE
15079: EJC
15080: *
15081: * DUMPR -- PRINT DUMP OF STORAGE
15082: *
15083: * (XR) DUMP ARGUMENT (SEE BELOW)
15084: * JSR DUMPR CALL TO PRINT DUMP
15085: * (XR,XL) DESTROYED
15086: * (WA,WB,WC,RA) DESTROYED
15087: *
15088: * THE DUMP ARGUMENT HAS THE FOLLOWING SIGNIFICANCE
15089: *
15090: * DMARG = 0 NO DUMP PRINTED
15091: * DMARG = 1 PARTIAL DUMP (NAT VARS, KEYWORDS)
15092: * DMARG EQ 2 FULL DUMP (INCL ARRAYS ETC.)
15093: * DMARG GE 3 CORE DUMP
15094: *
15095: * SINCE DUMPR SCRAMBLES STORE, IT IS NOT PERMISSIBLE TO
15096: * COLLECT IN MID-DUMP. HENCE A COLLECT IS DONE INITIALLY
15097: * AND THEN IF STORE RUNS OUT AN ERROR MESSAGE IS PRODUCED.
15098: *
15099: DUMPR PRC E,0 ENTRY POINT
15100: BZE XR,DMP28 SKIP DUMP IF ARGUMENT IS ZERO
15101: BGT XR,=NUM02,DMP29 JUMP IF CORE DUMP REQUIRED
15102: ZER XL CLEAR XL
15103: ZER WB ZERO MOVE OFFSET
15104: MOV XR,DMARG SAVE DUMP ARGUMENT
15105: JSR GBCOL COLLECT GARBAGE
15106: JSR PRTPG EJECT PRINTER
15107: MOV =DMHDV,XR POINT TO HEADING FOR VARIABLES
15108: JSR PRTST PRINT IT
15109: JSR PRTNL TERMINATE PRINT LINE
15110: JSR PRTNL AND PRINT A BLANK LINE
15111: *
15112: * FIRST ALL NATURAL VARIABLE BLOCKS (VRBLK) WHOSE VALUES
15113: * ARE NON-NULL ARE LINKED IN LEXICAL ORDER USING DMVCH AS
15114: * THE CHAIN HEAD AND CHAINING THROUGH THE VRGET FIELDS.
15115: * NOTE THAT THIS SCRAMBLES STORE IF THE PROCESS IS
15116: * INTERRUPTED BEFORE COMPLETION E.G. BY EXCEEDING TIME OR
15117: * PRINT LIMITS. SINCE THE SUBSEQUENT CORE DUMPS AND
15118: * FAILURES IF EXECUTION IS RESUMED ARE VERY CONFUSING, THE
15119: * EXECUTION TIME ERROR ROUTINE CHECKS FOR THIS EVENT AND
15120: * ATTEMPTS AN UNSCRAMBLE. SIMILAR PRECAUTIONS SHOULD BE
15121: * OBSERVED IF TRANSLATE TIME DUMPING IS IMPLEMENTED.
15122: *
15123: ZER DMVCH SET NULL CHAIN TO START
15124: MOV HSHTB,WA POINT TO HASH TABLE
15125: *
15126: * LOOP THROUGH HEADERS IN HASH TABLE
15127: *
15128: DMP00 MOV WA,XR COPY HASH BUCKET POINTER
15129: ICA WA BUMP POINTER
15130: SUB *VRNXT,XR SET OFFSET TO MERGE
15131: *
15132: * LOOP THROUGH VRBLKS ON ONE CHAIN
15133: *
15134: DMP01 MOV VRNXT(XR),XR POINT TO NEXT VRBLK ON CHAIN
15135: BZE XR,DMP09 JUMP IF END OF THIS HASH CHAIN
15136: MOV XR,XL ELSE COPY VRBLK POINTER
15137: EJC
15138: *
15139: * DUMPR (CONTINUED)
15140: *
15141: * LOOP TO FIND VALUE AND SKIP IF NULL
15142: *
15143: DMP02 MOV VRVAL(XL),XL LOAD VALUE
15144: BEQ XL,=NULLS,DMP01 LOOP FOR NEXT VRBLK IF NULL VALUE
15145: BEQ (XL),=B$TRT,DMP02 LOOP BACK IF VALUE IS TRAPPED
15146: *
15147: * NON-NULL VALUE, PREPARE TO SEARCH CHAIN
15148: *
15149: MOV XR,WC SAVE VRBLK POINTER
15150: ADD *VRSOF,XR ADJUST PTR TO BE LIKE SCBLK PTR
15151: BNZ SCLEN(XR),DMP03 JUMP IF NON-SYSTEM VARIABLE
15152: MOV VRSVO(XR),XR ELSE LOAD PTR TO NAME IN SVBLK
15153: *
15154: * HERE WITH NAME POINTER FOR NEW BLOCK IN XR
15155: *
15156: DMP03 MOV XR,WB SAVE POINTER TO CHARS
15157: MOV WA,DMPSV SAVE HASH BUCKET POINTER
15158: MOV =DMVCH,WA POINT TO CHAIN HEAD
15159: *
15160: * LOOP TO SEARCH CHAIN FOR CORRECT INSERTION POINT
15161: *
15162: DMP04 MOV WA,DMPCH SAVE CHAIN POINTER
15163: MOV WA,XL COPY IT
15164: MOV (XL),XR LOAD POINTER TO NEXT ENTRY
15165: BZE XR,DMP08 JUMP IF END OF CHAIN TO INSERT
15166: ADD *VRSOF,XR ELSE GET NAME PTR FOR CHAINED VRBLK
15167: BNZ SCLEN(XR),DMP05 JUMP IF NOT SYSTEM VARIABLE
15168: MOV VRSVO(XR),XR ELSE POINT TO NAME IN SVBLK
15169: *
15170: * HERE PREPARE TO COMPARE THE NAMES
15171: *
15172: * (WA) SCRATCH
15173: * (WB) POINTER TO STRING OF ENTERING VRBLK
15174: * (WC) POINTER TO ENTERING VRBLK
15175: * (XR) POINTER TO STRING OF CURRENT BLOCK
15176: * (XL) SCRATCH
15177: *
15178: DMP05 MOV WB,XL POINT TO ENTERING VRBLK STRING
15179: MOV SCLEN(XL),WA LOAD ITS LENGTH
15180: PLC XL POINT TO CHARS OF ENTERING STRING
15181: BHI WA,SCLEN(XR),DMP06 JUMP IF ENTERING LENGTH HIGH
15182: PLC XR ELSE POINT TO CHARS OF OLD STRING
15183: CMC DMP08,DMP07 COMPARE, INSERT IF NEW IS LLT OLD
15184: BRN DMP08 OR IF LEQ (WE HAD SHORTER LENGTH)
15185: *
15186: * HERE WHEN NEW LENGTH IS LONGER THAN OLD LENGTH
15187: *
15188: DMP06 MOV SCLEN(XR),WA LOAD SHORTER LENGTH
15189: PLC XR POINT TO CHARS OF OLD STRING
15190: CMC DMP08,DMP07 COMPARE, INSERT IF NEW ONE LOW
15191: EJC
15192: *
15193: * DUMPR (CONTINUED)
15194: *
15195: * HERE WE MOVE OUT ON THE CHAIN
15196: *
15197: DMP07 MOV DMPCH,XL COPY CHAIN POINTER
15198: MOV (XL),WA MOVE TO NEXT ENTRY ON CHAIN
15199: BRN DMP04 LOOP BACK
15200: *
15201: * HERE AFTER LOCATING THE PROPER INSERTION POINT
15202: *
15203: DMP08 MOV DMPCH,XL COPY CHAIN POINTER
15204: MOV DMPSV,WA RESTORE HASH BUCKET POINTER
15205: MOV WC,XR RESTORE VRBLK POINTER
15206: MOV (XL),VRGET(XR) LINK VRBLK TO REST OF CHAIN
15207: MOV XR,(XL) LINK VRBLK INTO CURRENT CHAIN LOC
15208: BRN DMP01 LOOP BACK FOR NEXT VRBLK
15209: *
15210: * HERE AFTER PROCESSING ALL VRBLKS ON ONE CHAIN
15211: *
15212: DMP09 BNE WA,HSHTE,DMP00 LOOP BACK IF MORE BUCKETS TO GO
15213: *
15214: * LOOP TO GENERATE DUMP OF NATURAL VARIABLE VALUES
15215: *
15216: DMP10 MOV DMVCH,XR LOAD POINTER TO NEXT ENTRY ON CHAIN
15217: BZE XR,DMP11 JUMP IF END OF CHAIN
15218: MOV (XR),DMVCH ELSE UPDATE CHAIN PTR TO NEXT ENTRY
15219: JSR SETVR RESTORE VRGET FIELD
15220: MOV XR,XL COPY VRBLK POINTER (NAME BASE)
15221: MOV *VRVAL,WA SET OFFSET FOR VRBLK NAME
15222: JSR PRTNV PRINT NAME = VALUE
15223: BRN DMP10 LOOP BACK TILL ALL PRINTED
15224: *
15225: * PREPARE TO PRINT KEYWORDS
15226: *
15227: DMP11 JSR PRTNL PRINT BLANK LINE
15228: JSR PRTNL AND ANOTHER
15229: MOV =DMHDK,XR POINT TO KEYWORD HEADING
15230: JSR PRTST PRINT HEADING
15231: JSR PRTNL END LINE
15232: JSR PRTNL PRINT ONE BLANK LINE
15233: MOV =VDMKW,XL POINT TO LIST OF KEYWORD SVBLK PTRS
15234: EJC
15235: *
15236: * DUMPR (CONTINUED)
15237: *
15238: * LOOP TO DUMP KEYWORD VALUES
15239: *
15240: DMP12 MOV (XL)+,XR LOAD NEXT SVBLK PTR FROM TABLE
15241: BZE XR,DMP13 JUMP IF END OF LIST
15242: MOV =CH$AM,WA LOAD AMPERSAND
15243: JSR PRTCH PRINT AMPERSAND
15244: JSR PRTST PRINT KEYWORD NAME
15245: MOV SVLEN(XR),WA LOAD NAME LENGTH FROM SVBLK
15246: CTB WA,SVCHS GET LENGTH OF NAME
15247: ADD WA,XR POINT TO SVKNM FIELD
15248: MOV (XR),DMPKN STORE IN DUMMY KVBLK
15249: MOV =TMBEB,XR POINT TO BLANK-EQUAL-BLANK
15250: JSR PRTST PRINT IT
15251: MOV XL,DMPSV SAVE TABLE POINTER
15252: MOV =DMPKB,XL POINT TO DUMMY KVBLK
15253: MOV *KVVAR,WA SET ZERO OFFSET
15254: JSR ACESS GET KEYWORD VALUE
15255: PPM FAILURE IS IMPOSSIBLE
15256: JSR PRTVL PRINT KEYWORD VALUE
15257: JSR PRTNL TERMINATE PRINT LINE
15258: MOV DMPSV,XL RESTORE TABLE POINTER
15259: BRN DMP12 LOOP BACK TILL ALL PRINTED
15260: *
15261: * HERE AFTER COMPLETING PARTIAL DUMP
15262: *
15263: DMP13 BEQ DMARG,=NUM01,DMP27 EXIT IF PARTIAL DUMP COMPLETE
15264: MOV DNAMB,XR ELSE POINT TO FIRST DYNAMIC BLOCK
15265: *
15266: * LOOP THROUGH BLOCKS IN DYNAMIC STORAGE
15267: *
15268: DMP14 BEQ XR,DNAMP,DMP27 JUMP IF END OF USED REGION
15269: MOV (XR),WA ELSE LOAD FIRST WORD OF BLOCK
15270: BEQ WA,=B$VCT,DMP16 JUMP IF VECTOR
15271: BEQ WA,=B$ART,DMP17 JUMP IF ARRAY
15272: BEQ WA,=B$PDT,DMP18 JUMP IF PROGRAM DEFINED
15273: BEQ WA,=B$TBT,DMP19 JUMP IF TABLE
15274: .IF .CNBF
15275: .ELSE
15276: BEQ WA,=B$BCT,DMP30 JUMP IF BUFFER
15277: .FI
15278: *
15279: * MERGE HERE TO MOVE TO NEXT BLOCK
15280: *
15281: DMP15 JSR BLKLN GET LENGTH OF BLOCK
15282: ADD WA,XR POINT PAST THIS BLOCK
15283: BRN DMP14 LOOP BACK FOR NEXT BLOCK
15284: EJC
15285: *
15286: * DUMPR (CONTINUED)
15287: *
15288: * HERE FOR VECTOR
15289: *
15290: DMP16 MOV *VCVLS,WB SET OFFSET TO FIRST VALUE
15291: BRN DMP19 JUMP TO MERGE
15292: *
15293: * HERE FOR ARRAY
15294: *
15295: DMP17 MOV AROFS(XR),WB SET OFFSET TO ARPRO FIELD
15296: ICA WB BUMP TO GET OFFSET TO VALUES
15297: BRN DMP19 JUMP TO MERGE
15298: *
15299: * HERE FOR PROGRAM DEFINED
15300: *
15301: DMP18 MOV *PDFLD,WB POINT TO VALUES, MERGE
15302: *
15303: * HERE FOR TABLE (OTHERS MERGE)
15304: *
15305: DMP19 BZE IDVAL(XR),DMP15 IGNORE BLOCK IF ZERO ID VALUE
15306: JSR BLKLN ELSE GET BLOCK LENGTH
15307: MOV XR,XL COPY BLOCK POINTER
15308: MOV WA,DMPSV SAVE LENGTH
15309: MOV WB,WA COPY OFFSET TO FIRST VALUE
15310: JSR PRTNL PRINT BLANK LINE
15311: MOV WA,DMPSA PRESERVE OFFSET
15312: JSR PRTVL PRINT BLOCK VALUE (FOR TITLE)
15313: MOV DMPSA,WA RECOVER OFFSET
15314: JSR PRTNL END PRINT LINE
15315: BEQ (XR),=B$TBT,DMP22 JUMP IF TABLE
15316: DCA WA POINT BEFORE FIRST WORD
15317: *
15318: * LOOP TO PRINT CONTENTS OF ARRAY, VECTOR, OR PROGRAM DEF
15319: *
15320: DMP20 MOV XL,XR COPY BLOCK POINTER
15321: ICA WA BUMP OFFSET
15322: ADD WA,XR POINT TO NEXT VALUE
15323: BEQ WA,DMPSV,DMP14 EXIT IF END (XR PAST BLOCK)
15324: SUB *VRVAL,XR SUBTRACT OFFSET TO MERGE INTO LOOP
15325: *
15326: * LOOP TO FIND VALUE AND IGNORE NULLS
15327: *
15328: DMP21 MOV VRVAL(XR),XR LOAD NEXT VALUE
15329: BEQ XR,=NULLS,DMP20 LOOP BACK IF NULL VALUE
15330: BEQ (XR),=B$TRT,DMP21 LOOP BACK IF TRAPPED
15331: JSR PRTNV ELSE PRINT NAME = VALUE
15332: BRN DMP20 LOOP BACK FOR NEXT FIELD
15333: EJC
15334: *
15335: * DUMPR (CONTINUED)
15336: *
15337: * HERE TO DUMP A TABLE
15338: *
15339: DMP22 MOV *TBBUK,WC SET OFFSET TO FIRST BUCKET
15340: MOV *TEVAL,WA SET NAME OFFSET FOR ALL TEBLKS
15341: *
15342: * LOOP THROUGH TABLE BUCKETS
15343: *
15344: DMP23 MOV XL,-(XS) SAVE TBBLK POINTER
15345: ADD WC,XL POINT TO NEXT BUCKET HEADER
15346: ICA WC BUMP BUCKET OFFSET
15347: SUB *TENXT,XL SUBTRACT OFFSET TO MERGE INTO LOOP
15348: *
15349: * LOOP TO PROCESS TEBLKS ON ONE CHAIN
15350: *
15351: DMP24 MOV TENXT(XL),XL POINT TO NEXT TEBLK
15352: BEQ XL,(XS),DMP26 JUMP IF END OF CHAIN
15353: MOV XL,XR ELSE COPY TEBLK POINTER
15354: *
15355: * LOOP TO FIND VALUE AND IGNORE IF NULL
15356: *
15357: DMP25 MOV TEVAL(XR),XR LOAD NEXT VALUE
15358: BEQ XR,=NULLS,DMP24 IGNORE IF NULL VALUE
15359: BEQ (XR),=B$TRT,DMP25 LOOP BACK IF TRAPPED
15360: MOV WC,DMPSV ELSE SAVE OFFSET POINTER
15361: JSR PRTNV PRINT NAME = VALUE
15362: MOV DMPSV,WC RELOAD OFFSET
15363: BRN DMP24 LOOP BACK FOR NEXT TEBLK
15364: *
15365: * HERE TO MOVE TO NEXT HASH CHAIN
15366: *
15367: DMP26 MOV (XS)+,XL RESTORE TBBLK POINTER
15368: BNE WC,TBLEN(XL),DMP23 LOOP BACK IF MORE BUCKETS TO GO
15369: MOV XL,XR ELSE COPY TABLE POINTER
15370: ADD WC,XR POINT TO FOLLOWING BLOCK
15371: BRN DMP14 LOOP BACK TO PROCESS NEXT BLOCK
15372: *
15373: * HERE AFTER COMPLETING DUMP
15374: *
15375: DMP27 JSR PRTPG EJECT PRINTER
15376: *
15377: * MERGE HERE IF NO DUMP GIVEN (DMARG=0)
15378: *
15379: DMP28 EXI RETURN TO DUMP CALLER
15380: *
15381: * CALL SYSTEM CORE DUMP ROUTINE
15382: *
15383: DMP29 JSR SYSDM CALL IT
15384: BRN DMP28 RETURN
15385: .IF .CNBF
15386: .ELSE
15387: EJC
15388: *
15389: * DUMPR (CONTINUED)
15390: *
15391: * HERE TO DUMP BUFFER BLOCK
15392: *
15393: DMP30 JSR PRTNL PRINT BLANK LINE
15394: JSR PRTVL PRINT VALUE ID FOR TITLE
15395: JSR PRTNL FORCE NEW LINE
15396: MOV =CH$DQ,WA LOAD DOUBLE QUOTE
15397: JSR PRTCH PRINT IT
15398: MOV BCLEN(XR),WC LOAD DEFINED LENGTH
15399: BZE WC,DMP32 SKIP CHARACTERS IF NONE
15400: LCT WC,WC LOAD COUNT FOR LOOP
15401: MOV XR,WB SAVE BCBLK PTR
15402: MOV BCBUF(XR),XR POINT TO BFBLK
15403: PLC XR GET SET TO LOAD CHARACTERS
15404: *
15405: * LOOP HERE STUFFING CHARACTERS IN OUTPUT STREAM
15406: *
15407: DMP31 LCH WA,(XR)+ GET NEXT CHARACTER
15408: JSR PRTCH STUFF IT
15409: BCT WC,DMP31 BRANCH FOR NEXT ONE
15410: MOV WB,XR RESTORE BCBLK POINTER
15411: *
15412: * MERGE TO STUFF CLOSING QUOTE MARK
15413: *
15414: DMP32 MOV =CH$DQ,WA STUFF QUOTE
15415: JSR PRTCH PRINT IT
15416: JSR PRTNL PRINT NEW LINE
15417: MOV (XR),WA GET FIRST WD FOR BLKLN
15418: BRN DMP15 MERGE TO GET NEXT BLOCK
15419: .FI
15420: ENP END PROCEDURE DUMPR
15421: EJC
15422: *
15423: * ERMSG -- PRINT ERROR CODE AND ERROR MESSAGE
15424: *
15425: * KVERT ERROR CODE
15426: * JSR ERMSG CALL TO PRINT MESSAGE
15427: * (XR,XL,WA,WB,WC,IA) DESTROYED
15428: *
15429: ERMSG PRC E,0 ENTRY POINT
15430: JSR PRTIS PRINT ERROR PTR OR BLANK LINE
15431: MOV KVERT,WA LOAD ERROR CODE
15432: MOV =ERMMS,XR POINT TO ERROR MESSAGE /ERROR/
15433: JSR PRTST PRINT IT
15434: JSR ERTEX GET ERROR MESSAGE TEXT
15435: ADD =THSND,WA BUMP ERROR CODE FOR PRINT
15436: MTI WA FAIL CODE IN INT ACC
15437: JSR PRTIN PRINT CODE (NOW HAVE ERROR1XXX)
15438: MOV PRBUF,XL POINT TO PRINT BUFFER
15439: PSC XL,=NUM05 POINT TO THE 1
15440: MOV =CH$BL,WA LOAD A BLANK
15441: SCH WA,(XL) STORE BLANK OVER 1 (ERROR XXX)
15442: CSC XL COMPLETE STORE CHARACTERS
15443: ZER XL CLEAR GARBAGE POINTER IN XL
15444: MOV XR,WA KEEP ERROR TEXT
15445: MOV =ERMNS,XR POINT TO / -- /
15446: JSR PRTST PRINT IT
15447: MOV WA,XR GET ERROR TEXT AGAIN
15448: JSR PRTST PRINT ERROR MESSAGE TEXT
15449: JSR PRTIS PRINT LINE
15450: JSR PRTIS PRINT BLANK LINE
15451: EXI RETURN TO ERMSG CALLER
15452: ENP END PROCEDURE ERMSG
15453: EJC
15454: *
15455: * ERTEX -- GET ERROR MESSAGE TEXT
15456: *
15457: * (WA) ERROR CODE
15458: * JSR ERTEX CALL TO GET ERROR TEXT
15459: * (XR) PTR TO ERROR TEXT IN DYNAMIC
15460: * (R$ETX) COPY OF PTR TO ERROR TEXT
15461: * (XL,WC,IA) DESTROYED
15462: *
15463: ERTEX PRC E,0 ENTRY POINT
15464: MOV WA,ERTWA SAVE WA
15465: MOV WB,ERTWB SAVE WB
15466: JSR SYSEM GET FAILURE MESSAGE TEXT
15467: MOV XR,XL COPY POINTER TO IT
15468: MOV SCLEN(XR),WA GET LENGTH OF STRING
15469: BZE WA,ERT02 JUMP IF NULL
15470: ZER WB OFFSET OF ZERO
15471: JSR SBSTR COPY INTO DYNAMIC STORE
15472: MOV XR,R$ETX STORE FOR RELOCATION
15473: *
15474: * RETURN
15475: *
15476: ERT01 MOV ERTWB,WB RESTORE WB
15477: MOV ERTWA,WA RESTORE WA
15478: EXI RETURN TO CALLER
15479: *
15480: * RETURN ERRTEXT CONTENTS INSTEAD OF NULL
15481: *
15482: ERT02 MOV R$ETX,XR GET ERRTEXT
15483: BRN ERT01 RETURN
15484: ENP
15485: EJC
15486: *
15487: * EVALI -- EVALUATE INTEGER ARGUMENT
15488: *
15489: * EVALI IS USED BY PATTERN PRIMITIVES LEN,TAB,RTAB,POS,RPOS
15490: * WHEN THEIR ARGUMENT IS AN EXPRESSION VALUE.
15491: *
15492: * (XR) NODE POINTER
15493: * (WB) CURSOR
15494: * JSR EVALI CALL TO EVALUATE INTEGER
15495: * PPM LOC TRANSFER LOC FOR NON-INTEGER ARG
15496: * PPM LOC TRANSFER LOC FOR OUT OF RANGE ARG
15497: * PPM LOC TRANSFER LOC FOR EVALUATION FAILURE
15498: * PPM LOC TRANSFER LOC FOR SUCCESSFUL EVAL
15499: * (THE NORMAL RETURN IS NEVER TAKEN)
15500: * (XR) PTR TO NODE WITH INTEGER ARGUMENT
15501: * (WC,XL,RA) DESTROYED
15502: *
15503: * ON RETURN, THE NODE POINTED TO HAS THE INTEGER ARGUMENT
15504: * IN PARM1 AND THE PROPER SUCCESSOR POINTER IN PTHEN.
15505: * THIS ALLOWS MERGING WITH THE NORMAL (INTEGER ARG) CASE.
15506: *
15507: EVALI PRC R,4 ENTRY POINT (RECURSIVE)
15508: JSR EVALP EVALUATE EXPRESSION
15509: PPM EVLI1 JUMP ON FAILURE
15510: MOV XL,-(XS) STACK RESULT FOR GTSMI
15511: MOV PTHEN(XR),XL LOAD SUCCESSOR POINTER
15512: JSR GTSMI CONVERT ARG TO SMALL INTEGER
15513: PPM EVLI2 JUMP IF NOT INTEGER
15514: PPM EVLI3 JUMP IF OUT OF RANGE
15515: MOV XR,EVLIV STORE RESULT IN SPECIAL DUMMY NODE
15516: MOV XL,EVLIS STORE SUCCESSOR POINTER
15517: MOV =EVLIN,XR POINT TO DUMMY NODE WITH RESULT
15518: EXI 4 TAKE SUCCESSFUL EXIT
15519: *
15520: * HERE IF EVALUATION FAILS
15521: *
15522: EVLI1 EXI 3 TAKE FAILURE RETURN
15523: *
15524: * HERE IF ARGUMENT IS NOT INTEGER
15525: *
15526: EVLI2 EXI 1 TAKE NON-INTEGER ERROR EXIT
15527: *
15528: * HERE IF ARGUMENT IS OUT OF RANGE
15529: *
15530: EVLI3 EXI 2 TAKE OUT-OF-RANGE ERROR EXIT
15531: ENP END PROCEDURE EVALI
15532: EJC
15533: *
15534: * EVALP -- EVALUATE EXPRESSION DURING PATTERN MATCH
15535: *
15536: * EVALP IS USED TO EVALUATE AN EXPRESSION (BY VALUE) DURING
15537: * A PATTERN MATCH. THE EFFECT IS LIKE EVALX, BUT PATTERN
15538: * VARIABLES ARE STACKED AND RESTORED IF NECESSARY.
15539: *
15540: * EVALP ALSO DIFFERS FROM EVALX IN THAT IF THE RESULT IS
15541: * AN EXPRESSION IT IS REEVALUATED. THIS OCCURS REPEATEDLY.
15542: *
15543: * (XR) NODE POINTER
15544: * (WB) PATTERN MATCH CURSOR
15545: * JSR EVALP CALL TO EVALUATE EXPRESSION
15546: * PPM LOC TRANSFER LOC IF EVALUATION FAILS
15547: * (XL) RESULT
15548: * (WA) FIRST WORD OF RESULT BLOCK
15549: * (XR,WB) DESTROYED (FAILURE CASE ONLY)
15550: * (WC,RA) DESTROYED
15551: *
15552: * THE EXPRESSION POINTER IS STORED IN PARM1 OF THE NODE
15553: *
15554: * CONTROL RETURNS TO FAILP ON FAILURE OF EVALUATION
15555: *
15556: EVALP PRC R,1 ENTRY POINT (RECURSIVE)
15557: MOV PARM1(XR),XL LOAD EXPRESSION POINTER
15558: BEQ (XL),=B$EXL,EVLP1 JUMP IF EXBLK CASE
15559: *
15560: * HERE FOR CASE OF SEBLK
15561: *
15562: * WE CAN GIVE A FAST RETURN IF THE VALUE OF THE VRBLK IS
15563: * NOT AN EXPRESSION AND IS NOT TRAPPED.
15564: *
15565: MOV SEVAR(XL),XL LOAD VRBLK POINTER
15566: MOV VRVAL(XL),XL LOAD VALUE OF VRBLK
15567: MOV (XL),WA LOAD FIRST WORD OF VALUE
15568: BHI WA,=B$T$$,EVLP3 JUMP IF NOT SEBLK, TRBLK OR EXBLK
15569: *
15570: * HERE FOR EXBLK OR SEBLK WITH EXPR VALUE OR TRAPPED VALUE
15571: *
15572: EVLP1 MOV XR,-(XS) STACK NODE POINTER
15573: MOV WB,-(XS) STACK CURSOR
15574: MOV R$PMS,-(XS) STACK SUBJECT STRING POINTER
15575: MOV PMSSL,-(XS) STACK SUBJECT STRING LENGTH
15576: MOV PMDFL,-(XS) STACK DOT FLAG
15577: MOV PMHBS,-(XS) STACK HISTORY STACK BASE POINTER
15578: MOV PARM1(XR),XR LOAD EXPRESSION POINTER
15579: EJC
15580: *
15581: * EVALP (CONTINUED)
15582: *
15583: * LOOP BACK HERE TO REEVALUATE EXPRESSION RESULT
15584: *
15585: EVLP2 ZER WB SET FLAG FOR BY VALUE
15586: JSR EVALX EVALUATE EXPRESSION
15587: PPM EVLP4 JUMP ON FAILURE
15588: MOV (XR),WA ELSE LOAD FIRST WORD OF VALUE
15589: BLO WA,=B$E$$,EVLP2 LOOP BACK TO REEVALUATE EXPRESSION
15590: *
15591: * HERE TO RESTORE PATTERN VALUES AFTER SUCCESSFUL EVAL
15592: *
15593: MOV XR,XL COPY RESULT POINTER
15594: MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER
15595: MOV (XS)+,PMDFL RESTORE DOT FLAG
15596: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH
15597: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER
15598: MOV (XS)+,WB RESTORE CURSOR
15599: MOV (XS)+,XR RESTORE NODE POINTER
15600: *
15601: * COMMON EXIT POINT
15602: *
15603: EVLP3 EXI RETURN TO EVALP CALLER
15604: *
15605: * HERE FOR FAILURE DURING EVALUATION
15606: *
15607: EVLP4 MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER
15608: MOV (XS)+,PMDFL RESTORE DOT FLAG
15609: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH
15610: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER
15611: ADD *NUM02,XS REMOVE NODE PTR, CURSOR
15612: EXI 1 TAKE FAILURE EXIT
15613: ENP END PROCEDURE EVALP
15614: EJC
15615: *
15616: * EVALS -- EVALUATE STRING ARGUMENT
15617: *
15618: * EVALS IS USED BY SPAN, ANY, NOTANY, BREAK, BREAKX WHEN
15619: * THEY ARE PASSED AN EXPRESSION ARGUMENT.
15620: *
15621: * (XR) NODE POINTER
15622: * (WB) CURSOR
15623: * JSR EVALS CALL TO EVALUATE STRING
15624: * PPM LOC TRANSFER LOC FOR NON-STRING ARG
15625: * PPM LOC TRANSFER LOC FOR EVALUATION FAILURE
15626: * PPM LOC TRANSFER LOC FOR SUCCESSFUL EVAL
15627: * (THE NORMAL RETURN IS NEVER TAKEN)
15628: * (XR) PTR TO NODE WITH PARMS SET
15629: * (XL,WC,RA) DESTROYED
15630: *
15631: * ON RETURN, THE NODE POINTED TO HAS A CHARACTER TABLE
15632: * POINTER IN PARM1 AND A BIT MASK IN PARM2. THE PROPER
15633: * SUCCESSOR IS STORED IN PTHEN OF THIS NODE. THUS IT IS
15634: * OK FOR MERGING WITH THE NORMAL (MULTI-CHAR STRING) CASE.
15635: *
15636: EVALS PRC R,3 ENTRY POINT (RECURSIVE)
15637: JSR EVALP EVALUATE EXPRESSION
15638: PPM EVLS1 JUMP IF EVALUATION FAILS
15639: MOV PTHEN(XR),-(XS) SAVE SUCCESSOR POINTER
15640: MOV WB,-(XS) SAVE CURSOR
15641: MOV XL,-(XS) STACK RESULT PTR FOR PATST
15642: ZER WB DUMMY PCODE FOR ONE CHAR STRING
15643: ZER WC DUMMY PCODE FOR EXPRESSION ARG
15644: MOV =P$BRK,XL APPROPRIATE PCODE FOR OUR USE
15645: JSR PATST CALL ROUTINE TO BUILD NODE
15646: PPM EVLS2 JUMP IF NOT STRING
15647: MOV (XS)+,WB RESTORE CURSOR
15648: MOV (XS)+,PTHEN(XR) STORE SUCCESSOR POINTER
15649: EXI 3 TAKE SUCCESS RETURN
15650: *
15651: * HERE IF EVALUATION FAILS
15652: *
15653: EVLS1 EXI 2 TAKE FAILURE RETURN
15654: *
15655: * HERE IF ARGUMENT IS NOT STRING
15656: *
15657: EVLS2 ADD *NUM02,XS POP SUCCESSOR AND CURSOR
15658: EXI 1 TAKE NON-STRING ERROR EXIT
15659: ENP END PROCEDURE EVALS
15660: EJC
15661: *
15662: * EVALX -- EVALUATE EXPRESSION
15663: *
15664: * EVALX IS CALLED TO EVALUATE AN EXPRESSION
15665: *
15666: * (XR) POINTER TO EXBLK OR SEBLK
15667: * (WB) 0 IF BY VALUE, 1 IF BY NAME
15668: * JSR EVALX CALL TO EVALUATE EXPRESSION
15669: * PPM LOC TRANSFER LOC IF EVALUATION FAILS
15670: * (XR) RESULT IF CALLED BY VALUE
15671: * (XL,WA) RESULT NAME BASE,OFFSET IF BY NAME
15672: * (XR) DESTROYED (NAME CASE ONLY)
15673: * (XL,WA) DESTROYED (VALUE CASE ONLY)
15674: * (WB,WC,RA) DESTROYED
15675: *
15676: EVALX PRC R,1 ENTRY POINT, RECURSIVE
15677: BEQ (XR),=B$EXL,EVLX2 JUMP IF EXBLK CASE
15678: *
15679: * HERE FOR SEBLK
15680: *
15681: MOV SEVAR(XR),XL LOAD VRBLK POINTER (NAME BASE)
15682: MOV *VRVAL,WA SET NAME OFFSET
15683: BNZ WB,EVLX1 JUMP IF CALLED BY NAME
15684: JSR ACESS CALL ROUTINE TO ACCESS VALUE
15685: PPM EVLX9 JUMP IF FAILURE ON ACCESS
15686: *
15687: * MERGE HERE TO EXIT FOR SEBLK CASE
15688: *
15689: EVLX1 EXI RETURN TO EVALX CALLER
15690: EJC
15691: *
15692: * EVALX (CONTINUED)
15693: *
15694: * HERE FOR FULL EXPRESSION (EXBLK) CASE
15695: *
15696: * IF AN ERROR OCCURS IN THE EXPRESSION CODE AT EXECUTION
15697: * TIME, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL
15698: * WITHOUT RETURNING TO THIS ROUTINE.
15699: * THE FOLLOWING ENTRIES ARE MADE ON THE STACK BEFORE
15700: * GIVING CONTROL TO THE EXPRESSION CODE
15701: *
15702: * EVALX RETURN POINT
15703: * SAVED VALUE OF R$COD
15704: * CODE POINTER (-R$COD)
15705: * SAVED VALUE OF FLPTR
15706: * 0 IF BY VALUE, 1 IF BY NAME
15707: * FLPTR --------------- *EXFLC, FAIL OFFSET IN EXBLK
15708: *
15709: EVLX2 SCP WC GET CODE POINTER
15710: MOV R$COD,WA LOAD CODE BLOCK POINTER
15711: SUB WA,WC GET CODE POINTER AS OFFSET
15712: MOV WA,-(XS) STACK OLD CODE BLOCK POINTER
15713: MOV WC,-(XS) STACK RELATIVE CODE OFFSET
15714: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER
15715: MOV WB,-(XS) STACK NAME/VALUE INDICATOR
15716: MOV *EXFLC,-(XS) STACK NEW FAIL OFFSET
15717: MOV FLPTR,GTCEF KEEP IN CASE OF ERROR
15718: MOV R$COD,R$GTC KEEP CODE BLOCK POINTER SIMILARLY
15719: MOV XS,FLPTR SET NEW FAILURE POINTER
15720: MOV XR,R$COD SET NEW CODE BLOCK POINTER
15721: MOV KVSTN,EXSTM(XR) REMEMBER STMNT NUMBER
15722: ADD *EXCOD,XR POINT TO FIRST CODE WORD
15723: LCP XR SET CODE POINTER
15724: BNE STAGE,=STGXT,EXITS JUMP IF NOT EXECUTION TIME
15725: MOV =STGEE,STAGE EVALUATING EXPRESSION
15726: BRN EXITS JUMP TO EXECUTE FIRST CODE WORD
15727: EJC
15728: *
15729: * EVALX (CONTINUED)
15730: *
15731: * COME HERE IF SUCCESSFUL RETURN BY VALUE (SEE O$RVL)
15732: *
15733: EVLX3 MOV (XS)+,XR LOAD VALUE
15734: BZE 1(XS),EVLX5 JUMP IF CALLED BY VALUE
15735: ERB 249,EXPRESSION EVALUATED BY NAME RETURNED VALUE
15736: *
15737: * HERE FOR EXPRESSION RETURNING BY NAME (SEE O$RNM)
15738: *
15739: EVLX4 MOV (XS)+,WA LOAD NAME OFFSET
15740: MOV (XS)+,XL LOAD NAME BASE
15741: BNZ 1(XS),EVLX5 JUMP IF CALLED BY NAME
15742: JSR ACESS ELSE ACCESS VALUE FIRST
15743: PPM EVLX6 JUMP IF FAILURE DURING ACCESS
15744: *
15745: * HERE AFTER LOADING CORRECT RESULT INTO XR OR XL,WA
15746: *
15747: EVLX5 ZER WB NOTE SUCCESSFUL
15748: BRN EVLX7 MERGE
15749: *
15750: * HERE FOR FAILURE IN EXPRESSION EVALUATION (SEE O$FEX)
15751: *
15752: EVLX6 MNZ WB NOTE UNSUCCESSFUL
15753: *
15754: * RESTORE ENVIRONMENT
15755: *
15756: EVLX7 BNE STAGE,=STGEE,EVLX8 SKIP IF WAS NOT PREVIOUSLY XT
15757: MOV =STGXT,STAGE EXECUTE TIME
15758: *
15759: * MERGE WITH STAGE SET UP
15760: *
15761: EVLX8 ADD *NUM02,XS POP NAME/VALUE INDICATOR, *EXFAL
15762: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER
15763: MOV (XS)+,WC LOAD CODE OFFSET
15764: ADD (XS),WC MAKE CODE POINTER ABSOLUTE
15765: MOV (XS)+,R$COD RESTORE OLD CODE BLOCK POINTER
15766: LCP WC RESTORE OLD CODE POINTER
15767: BZE WB,EVLX1 JUMP FOR SUCCESSFUL RETURN
15768: *
15769: * MERGE HERE FOR FAILURE IN SEBLK CASE
15770: *
15771: EVLX9 EXI 1 TAKE FAILURE EXIT
15772: ENP END OF PROCEDURE EVALX
15773: EJC
15774: *
15775: * EXBLD -- BUILD EXBLK
15776: *
15777: * EXBLD IS USED TO BUILD AN EXPRESSION BLOCK FROM THE
15778: * CODE COMPILED MOST RECENTLY IN THE CURRENT CCBLK.
15779: *
15780: * (XL) OFFSET IN CCBLK TO START OF CODE
15781: * (WB) INTEGER IN RANGE 0 LE N LE MXLEN
15782: * JSR EXBLD CALL TO BUILD EXBLK
15783: * (XR) PTR TO CONSTRUCTED EXBLK
15784: * (WA,WB,XL) DESTROYED
15785: *
15786: EXBLD PRC E,0 ENTRY POINT
15787: MOV XL,WA COPY OFFSET TO START OF CODE
15788: SUB *EXCOD,WA CALC REDUCTION IN OFFSET IN EXBLK
15789: MOV WA,-(XS) STACK FOR LATER
15790: MOV CWCOF,WA LOAD FINAL OFFSET
15791: SUB XL,WA COMPUTE LENGTH OF CODE
15792: ADD *EXSI$,WA ADD SPACE FOR STANDARD FIELDS
15793: JSR ALLOC ALLOCATE SPACE FOR EXBLK
15794: MOV XR,-(XS) SAVE POINTER TO EXBLK
15795: MOV =B$EXL,EXTYP(XR) STORE TYPE WORD
15796: ZER EXSTM(XR) ZEROISE STMNT NUMBER FIELD
15797: MOV WA,EXLEN(XR) STORE LENGTH
15798: MOV =OFEX$,EXFLC(XR) STORE FAILURE WORD
15799: ADD *EXSI$,XR SET XR FOR SYSMW
15800: MOV XL,CWCOF RESET OFFSET TO START OF CODE
15801: ADD R$CCB,XL POINT TO START OF CODE
15802: SUB *EXSI$,WA LENGTH OF CODE TO MOVE
15803: MOV WA,-(XS) STACK LENGTH OF CODE
15804: MVW MOVE CODE TO EXBLK
15805: MOV (XS)+,WA GET LENGTH OF CODE
15806: BTW WA CONVERT BYTE COUNT TO WORD COUNT
15807: LCT WA,WA PREPARE COUNTER FOR LOOP
15808: MOV (XS),XL COPY EXBLK PTR, DONT UNSTACK
15809: ADD *EXCOD,XL POINT TO CODE ITSELF
15810: MOV 1(XS),WB GET REDUCTION IN OFFSET
15811: *
15812: * THIS LOOP SEARCHES FOR NEGATION AND SELECTION CODE SO
15813: * THAT THE OFFSETS COMPUTED WHILST CODE WAS IN CODE BLOCK
15814: * CAN BE TRANSFORMED TO REDUCED VALUES APPLICABLE IN AN
15815: * EXBLK.
15816: *
15817: EXBL1 MOV (XL)+,XR GET NEXT CODE WORD
15818: BEQ XR,=OSLA$,EXBL3 JUMP IF SELECTION FOUND
15819: BEQ XR,=ONTA$,EXBL3 JUMP IF NEGATION FOUND
15820: BCT WA,EXBL1 LOOP TO END OF CODE
15821: *
15822: * NO SELECTION FOUND OR MERGE TO EXIT ON TERMINATION
15823: *
15824: EXBL2 MOV (XS)+,XR POP EXBLK PTR INTO XR
15825: MOV (XS)+,XL POP REDUCTION CONSTANT
15826: EXI RETURN TO CALLER
15827: EJC
15828: *
15829: * EXBLD (CONTINUED)
15830: *
15831: * SELECTION OR NEGATION FOUND
15832: * REDUCE THE OFFSETS AS NEEDED. OFFSETS OCCUR IN WORDS
15833: * FOLLOWING CODE WORDS -
15834: * =ONTA$, =OSLA$, =OSLB$, =OSLC$
15835: *
15836: EXBL3 SUB WB,(XL)+ ADJUST OFFSET
15837: BCT WA,EXBL4 DECREMENT COUNT
15838: *
15839: EXBL4 BCT WA,EXBL5 DECREMENT COUNT
15840: *
15841: * CONTINUE SEARCH FOR MORE OFFSETS
15842: *
15843: EXBL5 MOV (XL)+,XR GET NEXT CODE WORD
15844: BEQ XR,=OSLA$,EXBL3 JUMP IF OFFSET FOUND
15845: BEQ XR,=OSLB$,EXBL3 JUMP IF OFFSET FOUND
15846: BEQ XR,=OSLC$,EXBL3 JUMP IF OFFSET FOUND
15847: BEQ XR,=ONTA$,EXBL3 JUMP IF OFFSET FOUND
15848: BCT WA,EXBL5 LOOP
15849: BRN EXBL2 MERGE TO RETURN
15850: ENP END PROCEDURE EXBLD
15851: EJC
15852: *
15853: * EXPAN -- ANALYZE EXPRESSION
15854: *
15855: * THE EXPRESSION ANALYZER (EXPAN) PROCEDURE IS USED TO SCAN
15856: * AN EXPRESSION AND CONVERT IT INTO A TREE REPRESENTATION.
15857: * SEE DESCRIPTIONS OF CMBLK, CUBLK, CBBLK IN THE STRUCTURES
15858: * SECTION FOR DETAILED FORMAT OF TREE BLOCKS.
15859: *
15860: * THE ANALYZER USES A SIMPLE PRECEDENCE SCHEME IN WHICH
15861: * OPERANDS AND OPERATORS ARE PLACED ON A SINGLE STACK
15862: * AND CONDENSATIONS ARE MADE WHEN LOW PRECEDENCE OPERATORS
15863: * ARE STACKED AFTER A HIGHER PRECEDENCE OPERATOR. A GLOBAL
15864: * VARIABLE (IN WB) KEEPS TRACK OF THE LEVEL AS FOLLOWS.
15865: *
15866: * 0 SCANNING OUTER LEVEL OF STATEMENT OR EXPRESSION
15867: * 1 SCANNING OUTER LEVEL OF NORMAL GOTO
15868: * 2 SCANNING OUTER LEVEL OF DIRECT GOTO
15869: * 3 SCANNING INSIDE ARRAY BRACKETS
15870: * 4 SCANNING INSIDE GROUPING PARENTHESES
15871: * 5 SCANNING INSIDE FUNCTION PARENTHESES
15872: *
15873: * THIS VARIABLE IS SAVED ON THE STACK ON ENCOUNTERING A
15874: * GROUPING AND RESTORED AT THE END OF THE GROUPING.
15875: *
15876: * ANOTHER GLOBAL VARIABLE (IN WC) COUNTS THE NUMBER OF
15877: * ITEMS AT ONE GROUPING LEVEL AND IS INCREMENTED FOR EACH
15878: * COMMA ENCOUNTERED. IT IS STACKED WITH THE LEVEL INDICATOR
15879: *
15880: * THE SCAN IS CONTROLLED BY A THREE STATE FINITE MACHINE.
15881: * A GLOBAL VARIABLE STORED IN WA IS THE CURRENT STATE.
15882: *
15883: * WA=0 NOTHING SCANNED AT THIS LEVEL
15884: * WA=1 OPERAND EXPECTED
15885: * WA=2 OPERATOR EXPECTED
15886: *
15887: * (WB) CALL TYPE (SEE BELOW)
15888: * JSR EXPAN CALL TO ANALYZE EXPRESSION
15889: * (XR) POINTER TO RESULTING TREE
15890: * (XL,WA,WB,WC,RA) DESTROYED
15891: *
15892: * THE ENTRY VALUE OF WB INDICATES THE CALL TYPE AS FOLLOWS.
15893: *
15894: * 0 SCANNING EITHER THE MAIN BODY OF A STATEMENT OR THE
15895: * TEXT OF AN EXPRESSION (FROM EVAL CALL). VALID
15896: * TERMINATORS ARE COLON, SEMICOLON. THE RESCAN FLAG IS
15897: * SET TO RETURN THE TERMINATOR ON THE NEXT SCANE CALL.
15898: *
15899: * 1 SCANNING A NORMAL GOTO. THE ONLY VALID
15900: * TERMINATOR IS A RIGHT PAREN.
15901: *
15902: * 2 SCANNING A DIRECT GOTO. THE ONLY VALID
15903: * TERMINATOR IS A RIGHT BRACKET.
15904: EJC
15905: *
15906: * EXPAN (CONTINUED)
15907: *
15908: * ENTRY POINT
15909: *
15910: EXPAN PRC E,0 ENTRY POINT
15911: ZER -(XS) SET TOP OF STACK INDICATOR
15912: ZER WA SET INITIAL STATE TO ZERO
15913: ZER WC ZERO COUNTER VALUE
15914: *
15915: * LOOP HERE FOR SUCCESSIVE ENTRIES
15916: *
15917: EXP01 JSR SCANE SCAN NEXT ELEMENT
15918: ADD WA,XL ADD STATE TO SYNTAX CODE
15919: BSW XL,T$NES SWITCH ON ELEMENT TYPE/STATE
15920: IFF T$VA0,EXP03 VARIABLE, S=0
15921: IFF T$VA1,EXP03 VARIABLE, STATE ONE
15922: IFF T$VA2,EXP04 VARIABLE, S=2
15923: IFF T$CO0,EXP03 CONSTANT, S=0
15924: IFF T$CO1,EXP03 CONSTANT, S=1
15925: IFF T$CO2,EXP04 CONSTANT, S=2
15926: IFF T$LP0,EXP06 LEFT PAREN, S=0
15927: IFF T$LP1,EXP06 LEFT PAREN, S=1
15928: IFF T$LP2,EXP04 LEFT PAREN, S=2
15929: IFF T$FN0,EXP10 FUNCTION, S=0
15930: IFF T$FN1,EXP10 FUNCTION, S=1
15931: IFF T$FN2,EXP04 FUNCTION, S=2
15932: IFF T$RP0,EXP02 RIGHT PAREN, S=0
15933: IFF T$RP1,EXP05 RIGHT PAREN, S=1
15934: IFF T$RP2,EXP12 RIGHT PAREN, S=2
15935: IFF T$LB0,EXP08 LEFT BRKT, S=0
15936: IFF T$LB1,EXP08 LEFT BRKT, S=1
15937: IFF T$LB2,EXP09 LEFT BRKT, S=2
15938: IFF T$RB0,EXP02 RIGHT BRKT, S=0
15939: IFF T$RB1,EXP05 RIGHT BRKT, S=1
15940: IFF T$RB2,EXP18 RIGHT BRKT, S=2
15941: IFF T$UO0,EXP27 UNOP, S=0
15942: IFF T$UO1,EXP27 UNOP, S=1
15943: IFF T$UO2,EXP04 UNOP, S=2
15944: IFF T$BO0,EXP05 BINOP, S=0
15945: IFF T$BO1,EXP05 BINOP, S=1
15946: IFF T$BO2,EXP26 BINOP, S=2
15947: IFF T$CM0,EXP02 COMMA, S=0
15948: IFF T$CM1,EXP05 COMMA, S=1
15949: IFF T$CM2,EXP11 COMMA, S=2
15950: IFF T$CL0,EXP02 COLON, S=0
15951: IFF T$CL1,EXP05 COLON, S=1
15952: IFF T$CL2,EXP19 COLON, S=2
15953: IFF T$SM0,EXP02 SEMICOLON, S=0
15954: IFF T$SM1,EXP05 SEMICOLON, S=1
15955: IFF T$SM2,EXP19 SEMICOLON, S=2
15956: ESW END SWITCH ON ELEMENT TYPE/STATE
15957: EJC
15958: *
15959: * EXPAN (CONTINUED)
15960: *
15961: * HERE FOR RBR,RPR,COL,SMC,CMA IN STATE 0
15962: *
15963: * SET TO RESCAN THE TERMINATOR ENCOUNTERED AND CREATE
15964: * A NULL CONSTANT (CASE OF OMITTED NULL)
15965: *
15966: EXP02 MNZ SCNRS SET TO RESCAN ELEMENT
15967: MOV =NULLS,XR POINT TO NULL, MERGE
15968: *
15969: * HERE FOR VAR OR CON IN STATES 0,1
15970: *
15971: * STACK THE VARIABLE/CONSTANT AND SET STATE=2
15972: *
15973: EXP03 MOV XR,-(XS) STACK POINTER TO OPERAND
15974: MOV =NUM02,WA SET STATE 2
15975: BRN EXP01 JUMP FOR NEXT ELEMENT
15976: *
15977: * HERE FOR VAR,CON,LPR,FNC,UOP IN STATE 2
15978: *
15979: * WE RESCAN THE ELEMENT AND CREATE A CONCATENATION OPERATOR
15980: * THIS IS THE CASE OF THE BLANK CONCATENATION OPERATOR.
15981: *
15982: EXP04 MNZ SCNRS SET TO RESCAN ELEMENT
15983: MOV =OPDVC,XR POINT TO CONCAT OPERATOR DV
15984: BZE WB,EXP4A OK IF AT TOP LEVEL
15985: MOV =OPDVP,XR ELSE POINT TO UNMISTAKABLE CONCAT.
15986: *
15987: * MERGE HERE WHEN XR SET UP WITH PROPER CONCATENATION DVBLK
15988: *
15989: EXP4A BNZ SCNBL,EXP26 MERGE BOP IF BLANKS, ELSE ERROR
15990: DCV SCNSE ADJUST START OF ELEMENT LOCATION
15991: ERB 220,SYNTAX ERROR. MISSING OPERATOR
15992: *
15993: * HERE FOR CMA,RPR,RBR,COL,SMC,BOP(S=1) BOP(S=0)
15994: *
15995: * THIS IS AN ERRONOUS CONTRUCTION
15996: *
15997: EXP05 DCV SCNSE ADJUST START OF ELEMENT LOCATION
15998: ERB 221,SYNTAX ERROR. MISSING OPERAND
15999: *
16000: * HERE FOR LPR (S=0,1)
16001: *
16002: EXP06 MOV =NUM04,XL SET NEW LEVEL INDICATOR
16003: ZER XR SET ZERO VALUE FOR CMOPN
16004: EJC
16005: *
16006: * EXPAN (CONTINUED)
16007: *
16008: * MERGE HERE TO STORE OLD LEVEL ON STACK AND START NEW ONE
16009: *
16010: EXP07 MOV XR,-(XS) STACK CMOPN VALUE
16011: MOV WC,-(XS) STACK OLD COUNTER
16012: MOV WB,-(XS) STACK OLD LEVEL INDICATOR
16013: CHK CHECK FOR STACK OVERFLOW
16014: ZER WA SET NEW STATE TO ZERO
16015: MOV XL,WB SET NEW LEVEL INDICATOR
16016: MOV =NUM01,WC INITIALIZE NEW COUNTER
16017: BRN EXP01 JUMP TO SCAN NEXT ELEMENT
16018: *
16019: * HERE FOR LBR (S=0,1)
16020: *
16021: * THIS IS AN ILLEGAL USE OF LEFT BRACKET
16022: *
16023: EXP08 ERB 222,SYNTAX ERROR. INVALID USE OF LEFT BRACKET
16024: *
16025: * HERE FOR LBR (S=2)
16026: *
16027: * SET NEW LEVEL AND START TO SCAN SUBSCRIPTS
16028: *
16029: EXP09 MOV (XS)+,XR LOAD ARRAY PTR FOR CMOPN
16030: MOV =NUM03,XL SET NEW LEVEL INDICATOR
16031: BRN EXP07 JUMP TO STACK OLD AND START NEW
16032: *
16033: * HERE FOR FNC (S=0,1)
16034: *
16035: * STACK OLD LEVEL AND START TO SCAN ARGUMENTS
16036: *
16037: EXP10 MOV =NUM05,XL SET NEW LEV INDIC (XR=VRBLK=CMOPN)
16038: BRN EXP07 JUMP TO STACK OLD AND START NEW
16039: *
16040: * HERE FOR CMA (S=2)
16041: *
16042: * INCREMENT ARGUMENT COUNT AND CONTINUE
16043: *
16044: EXP11 ICV WC INCREMENT COUNTER
16045: JSR EXPDM DUMP OPERATORS AT THIS LEVEL
16046: ZER -(XS) SET NEW LEVEL FOR PARAMETER
16047: ZER WA SET NEW STATE
16048: BGT WB,=NUM02,EXP01 LOOP BACK UNLESS OUTER LEVEL
16049: ERB 223,SYNTAX ERROR. INVALID USE OF COMMA
16050: EJC
16051: *
16052: * EXPAN (CONTINUED)
16053: *
16054: * HERE FOR RPR (S=2)
16055: *
16056: * AT OUTER LEVEL IN A NORMAL GOTO THIS IS A TERMINATOR
16057: * OTHERWISE IT MUST TERMINATE A FUNCTION OR GROUPING
16058: *
16059: EXP12 BEQ WB,=NUM01,EXP20 END OF NORMAL GOTO
16060: BEQ WB,=NUM05,EXP13 END OF FUNCTION ARGUMENTS
16061: BEQ WB,=NUM04,EXP14 END OF GROUPING / SELECTION
16062: ERB 224,SYNTAX ERROR. UNBALANCED RIGHT PARENTHESIS
16063: *
16064: * HERE AT END OF FUNCTION ARGUMENTS
16065: *
16066: EXP13 MOV =C$FNC,XL SET CMTYP VALUE FOR FUNCTION
16067: BRN EXP15 JUMP TO BUILD CMBLK
16068: *
16069: * HERE FOR END OF GROUPING
16070: *
16071: EXP14 BEQ WC,=NUM01,EXP17 JUMP IF END OF GROUPING
16072: MOV =C$SEL,XL ELSE SET CMTYP FOR SELECTION
16073: *
16074: * MERGE HERE TO BUILD CMBLK FOR LEVEL JUST SCANNED AND
16075: * TO POP UP TO THE PREVIOUS SCAN LEVEL BEFORE CONTINUING.
16076: *
16077: EXP15 JSR EXPDM DUMP OPERATORS AT THIS LEVEL
16078: MOV WC,WA COPY COUNT
16079: ADD =CMVLS,WA ADD FOR STANDARD FIELDS AT START
16080: WTB WA CONVERT LENGTH TO BYTES
16081: JSR ALLOC ALLOCATE SPACE FOR CMBLK
16082: MOV =B$CMT,(XR) STORE TYPE CODE FOR CMBLK
16083: MOV XL,CMTYP(XR) STORE CMBLK NODE TYPE INDICATOR
16084: MOV WA,CMLEN(XR) STORE LENGTH
16085: ADD WA,XR POINT PAST END OF BLOCK
16086: LCT WC,WC SET LOOP COUNTER
16087: *
16088: * LOOP TO MOVE REMAINING WORDS TO CMBLK
16089: *
16090: EXP16 MOV (XS)+,-(XR) MOVE ONE OPERAND PTR FROM STACK
16091: MOV (XS)+,WB POP TO OLD LEVEL INDICATOR
16092: BCT WC,EXP16 LOOP TILL ALL MOVED
16093: EJC
16094: *
16095: * EXPAN (CONTINUED)
16096: *
16097: * COMPLETE CMBLK AND STACK POINTER TO IT ON STACK
16098: *
16099: SUB *CMVLS,XR POINT BACK TO START OF BLOCK
16100: MOV (XS)+,WC RESTORE OLD COUNTER
16101: MOV (XS),CMOPN(XR) STORE OPERAND PTR IN CMBLK
16102: MOV XR,(XS) STACK CMBLK POINTER
16103: MOV =NUM02,WA SET NEW STATE
16104: BRN EXP01 BACK FOR NEXT ELEMENT
16105: *
16106: * HERE AT END OF A PARENTHESIZED EXPRESSION
16107: *
16108: EXP17 JSR EXPDM DUMP OPERATORS AT THIS LEVEL
16109: MOV (XS)+,XR RESTORE XR
16110: MOV (XS)+,WB RESTORE OUTER LEVEL
16111: MOV (XS)+,WC RESTORE OUTER COUNT
16112: MOV XR,(XS) STORE OPND OVER UNUSED CMOPN VAL
16113: MOV =NUM02,WA SET NEW STATE
16114: BRN EXP01 BACK FOR NEXT ELE8ENT
16115: *
16116: * HERE FOR RBR (S=2)
16117: *
16118: * AT OUTER LEVEL IN A DIRECT GOTO, THIS IS A TERMINATOR.
16119: * OTHERWISE IT MUST TERMINATE A SUBSCRIPT LIST.
16120: *
16121: EXP18 MOV =C$ARR,XL SET CMTYP FOR ARRAY REFERENCE
16122: BEQ WB,=NUM03,EXP15 JUMP TO BUILD CMBLK IF END ARRAYREF
16123: BEQ WB,=NUM02,EXP20 JUMP IF END OF DIRECT GOTO
16124: ERB 225,SYNTAX ERROR. UNBALANCED RIGHT BRACKET
16125: EJC
16126: *
16127: * EXPAN (CONTINUED)
16128: *
16129: * HERE FOR COL,SMC (S=2)
16130: *
16131: * ERROR UNLESS TERMINATING STATEMENT BODY AT OUTER LEVEL
16132: *
16133: EXP19 MNZ SCNRS RESCAN TERMINATOR
16134: MOV WB,XL COPY LEVEL INDICATOR
16135: BSW XL,6 SWITCH ON LEVEL INDICATOR
16136: IFF 0,EXP20 NORMAL OUTER LEVEL
16137: IFF 1,EXP22 FAIL IF NORMAL GOTO
16138: IFF 2,EXP23 FAIL IF DIRECT GOTO
16139: IFF 3,EXP24 FAIL ARRAY BRACKETS
16140: IFF 4,EXP21 FAIL IF IN GROUPING
16141: IFF 5,EXP21 FAIL FUNCTION ARGS
16142: ESW END SWITCH ON LEVEL
16143: *
16144: * HERE AT NORMAL END OF EXPRESSION
16145: *
16146: EXP20 JSR EXPDM DUMP REMAINING OPERATORS
16147: MOV (XS)+,XR LOAD TREE POINTER
16148: ICA XS POP OFF BOTTOM OF STACK MARKER
16149: EXI RETURN TO EXPAN CALLER
16150: *
16151: * MISSING RIGHT PAREN
16152: *
16153: EXP21 ERB 226,SYNTAX ERROR. MISSING RIGHT PAREN
16154: *
16155: * MISSING RIGHT PAREN IN GOTO FIELD
16156: *
16157: EXP22 ERB 227,SYNTAX ERROR. RIGHT PAREN MISSING FROM GOTO
16158: *
16159: * MISSING BRACKET IN GOTO
16160: *
16161: EXP23 ERB 228,SYNTAX ERROR. RIGHT BRACKET MISSING FROM GOTO
16162: *
16163: * MISSING ARRAY BRACKET
16164: *
16165: EXP24 ERB 229,SYNTAX ERROR. MISSING RIGHT ARRAY BRACKET
16166: EJC
16167: *
16168: * EXPAN (CONTINUED)
16169: *
16170: * LOOP HERE WHEN AN OPERATOR CAUSES AN OPERATOR DUMP
16171: *
16172: EXP25 MOV XR,EXPSV
16173: JSR EXPOP POP ONE OPERATOR
16174: MOV EXPSV,XR RESTORE OP DV POINTER AND MERGE
16175: *
16176: * HERE FOR BOP (S=2)
16177: *
16178: * REMOVE OPERATORS (CONDENSE) FROM STACK UNTIL NO MORE
16179: * LEFT AT THIS LEVEL OR TOP ONE HAS LOWER PRECEDENCE.
16180: * LOOP HERE TILL THIS CONDITION IS MET.
16181: *
16182: EXP26 MOV 1(XS),XL LOAD OPERATOR DVPTR FROM STACK
16183: BLE XL,=NUM05,EXP27 JUMP IF BOTTOM OF STACK LEVEL
16184: BLT DVRPR(XR),DVLPR(XL),EXP25 ELSE POP IF NEW PREC IS LO
16185: *
16186: * HERE FOR UOP (S=0,1)
16187: *
16188: * BINARY OPERATOR MERGES AFTER PRECEDENCE CHECK
16189: *
16190: * THE OPERATOR DV IS STORED ON THE STACK AND THE SCAN
16191: * CONTINUES AFTER SETTING THE SCAN STATE TO ONE.
16192: *
16193: EXP27 MOV XR,-(XS) STACK OPERATOR DVPTR ON STACK
16194: CHK CHECK FOR STACK OVERFLOW
16195: MOV =NUM01,WA SET NEW STATE
16196: BNE XR,=OPDVS,EXP01 BACK FOR NEXT ELEMENT UNLESS =
16197: *
16198: * HERE FOR SPECIAL CASE OF BINARY =. THE SYNTAX ALLOWS A
16199: * NULL RIGHT ARGUMENT FOR THIS OPERATOR TO BE LEFT
16200: * OUT. ACCORDINGLY WE RESET TO STATE ZERO TO GET PROPER
16201: * ACTION ON A TERMINATOR (SUPPLY A NULL CONSTANT).
16202: *
16203: ZER WA SET STATE ZERO
16204: BRN EXP01 JUMP FOR NEXT ELEMENT
16205: ENP END PROCEDURE EXPAN
16206: EJC
16207: *
16208: * EXPAP -- TEST FOR PATTERN MATCH TREE
16209: *
16210: * EXPAP IS PASSED AN EXPRESSION TREE TO DETERMINE IF IT
16211: * IS A PATTERN MATCH. THE FOLLOWING ARE RECOGIZED AS
16212: * MATCHES IN THE CONTEXT OF THIS CALL.
16213: *
16214: * 1) AN EXPLICIT USE OF BINARY QUESTION MARK
16215: * 2) A CONCATENATION
16216: * 3) AN ALTERNATION WHOSE LEFT OPERAND IS A CONCATENATION
16217: *
16218: * (XR) PTR TO EXPAN TREE
16219: * JSR EXPAP CALL TO TEST FOR PATTERN MATCH
16220: * PPM LOC TRANSFER LOC IF NOT A PATTERN MATCH
16221: * (WA) DESTROYED
16222: * (XR) UNCHANGED (IF NOT MATCH)
16223: * (XR) PTR TO BINARY OPERATOR BLK IF MATCH
16224: *
16225: EXPAP PRC E,1 ENTRY POINT
16226: MOV XL,-(XS) SAVE XL
16227: BNE (XR),=B$CMT,EXPP2 NO MATCH IF NOT COMPLEX
16228: MOV CMTYP(XR),WA ELSE LOAD TYPE CODE
16229: BEQ WA,=C$CNC,EXPP1 CONCATENATION IS A MATCH
16230: BEQ WA,=C$PMT,EXPP1 BINARY QUESTION MARK IS A MATCH
16231: BNE WA,=C$ALT,EXPP2 ELSE NOT MATCH UNLESS ALTERNATION
16232: *
16233: * HERE FOR ALTERNATION. CHANGE (A B) / C TO A QM (B / C)
16234: *
16235: MOV CMLOP(XR),XL LOAD LEFT OPERAND POINTER
16236: BNE (XL),=B$CMT,EXPP2 NOT MATCH IF LEFT OPND NOT COMPLEX
16237: BNE CMTYP(XL),=C$CNC,EXPP2 NOT MATCH IF LEFT OP NOT CONC
16238: MOV CMROP(XL),CMLOP(XR) XR POINTS TO (B / C)
16239: MOV XR,CMROP(XL) SET XL OPNDS TO A, (B / C)
16240: MOV XL,XR POINT TO THIS ALTERED NODE
16241: *
16242: * EXIT HERE FOR PATTERN MATCH
16243: *
16244: EXPP1 MOV (XS)+,XL RESTORE ENTRY XL
16245: EXI GIVE PATTERN MATCH RETURN
16246: *
16247: * EXIT HERE IF NOT PATTERN MATCH
16248: *
16249: EXPP2 MOV (XS)+,XL RESTORE ENTRY XL
16250: EXI 1 GIVE NON-MATCH RETURN
16251: ENP END PROCEDURE EXPAP
16252: EJC
16253: *
16254: * EXPDM -- DUMP OPERATORS AT CURRENT LEVEL (FOR EXPAN)
16255: *
16256: * EXPDM USES EXPOP TO CONDENSE ALL OPERATORS AT THIS SYNTAX
16257: * LEVEL. THE STACK BOTTOM IS RECOGNIZED FROM THE LEVEL
16258: * VALUE WHICH IS SAVED ON THE TOP OF THE STACK.
16259: *
16260: * JSR EXPDM CALL TO DUMP OPERATORS
16261: * (XS) POPPED AS REQUIRED
16262: * (XR,WA) DESTROYED
16263: *
16264: EXPDM PRC N,0 ENTRY POINT
16265: MOV XL,R$EXS SAVE XL VALUE
16266: *
16267: * LOOP TO DUMP OPERATORS
16268: *
16269: EXDM1 BLE 1(XS),=NUM05,EXDM2 JUMP IF STACK BOTTOM (SAVED LEVEL
16270: JSR EXPOP ELSE POP ONE OPERATOR
16271: BRN EXDM1 AND LOOP BACK
16272: *
16273: * HERE AFTER POPPING ALL OPERATORS
16274: *
16275: EXDM2 MOV R$EXS,XL RESTORE XL
16276: ZER R$EXS RELEASE SAVE LOCATION
16277: EXI RETURN TO EXPDM CALLER
16278: ENP END PROCEDURE EXPDM
16279: EJC
16280: *
16281: * EXPOP-- POP OPERATOR (FOR EXPAN)
16282: *
16283: * EXPOP IS USED BY THE EXPAN ROUTINE TO CONDENSE ONE
16284: * OPERATOR FROM THE TOP OF THE SYNTAX STACK. AN APPROPRIATE
16285: * CMBLK IS BUILT FOR THE OPERATOR (UNARY OR BINARY) AND A
16286: * POINTER TO THIS CMBLK IS STACKED.
16287: *
16288: * EXPOP IS ALSO USED BY SCNGF (GOTO FIELD SCAN) PROCEDURE
16289: *
16290: * JSR EXPOP CALL TO POP OPERATOR
16291: * (XS) POPPED APPROPRIATELY
16292: * (XR,XL,WA) DESTROYED
16293: *
16294: EXPOP PRC N,0 ENTRY POINT
16295: MOV 1(XS),XR LOAD OPERATOR DV POINTER
16296: BEQ DVLPR(XR),=LLUNO,EXPO2 JUMP IF UNARY
16297: *
16298: * HERE FOR BINARY OPERATOR
16299: *
16300: MOV *CMBS$,WA SET SIZE OF BINARY OPERATOR CMBLK
16301: JSR ALLOC ALLOCATE SPACE FOR CMBLK
16302: MOV (XS)+,CMROP(XR) POP AND STORE RIGHT OPERAND PTR
16303: MOV (XS)+,XL POP AND LOAD OPERATOR DV PTR
16304: MOV (XS),CMLOP(XR) STORE LEFT OPERAND POINTER
16305: *
16306: * COMMON EXIT POINT
16307: *
16308: EXPO1 MOV =B$CMT,(XR) STORE TYPE CODE FOR CMBLK
16309: MOV DVTYP(XL),CMTYP(XR) STORE CMBLK NODE TYPE CODE
16310: MOV XL,CMOPN(XR) STORE DVPTR (=PTR TO DAC O$XXX)
16311: MOV WA,CMLEN(XR) STORE CMBLK LENGTH
16312: MOV XR,(XS) STORE RESULTING NODE PTR ON STACK
16313: EXI RETURN TO EXPOP CALLER
16314: *
16315: * HERE FOR UNARY OPERATOR
16316: *
16317: EXPO2 MOV *CMUS$,WA SET SIZE OF UNARY OPERATOR CMBLK
16318: JSR ALLOC ALLOCATE SPACE FOR CMBLK
16319: MOV (XS)+,CMROP(XR) POP AND STORE OPERAND POINTER
16320: MOV (XS),XL LOAD OPERATOR DV POINTER
16321: BRN EXPO1 MERGE BACK TO EXIT
16322: ENP END PROCEDURE EXPOP
16323: EJC
16324: .IF .CULC
16325: *
16326: * FLSTG -- FOLD STRING TO UPPER CASE
16327: *
16328: * FLSTG FOLDS A CHARACTER STRING CONTAINING LOWER CASE
16329: * CHARACCTERS TO ONE CONTAINING UPPER CASE CHARACTERS.
16330: * FOLDING IS ONLY DONE IF &CASE (KVCAS) IS NOT ZERO.
16331: *
16332: * (XR) STRING ARGUMENT
16333: * (WA) LENGTH OF STRING
16334: * JSR FLSTG CALL TO FOLD STRING
16335: * (XR) RESULT STRING (POSSIBLY ORIGINAL)
16336: * (WC) DESTROYED
16337: *
16338: FLSTG PRC R,0 ENTRY POINT
16339: BZE KVCAS,FST99 SKIP IF &CASE IS 0
16340: MOV XL,-(XS) SAVE XL ACROSS CALL
16341: MOV XR,-(XS) SAVE ORIGINAL SCBLK PTR
16342: JSR ALOCS ALLOCATE NEW STRING BLOCK
16343: MOV (XS),XL POINT TO ORIGINAL SCBLK
16344: MOV XR,-(XS) SAVE POINTER TO NEW SCBLK
16345: PLC XL POINT TO ORIGINAL CHARS
16346: PLC XR POINT TO NEW CHARS
16347: ZER -(XS) INIT DID FOLD FLAG
16348: LCT WC,WC LOAD LOOP COUNTER
16349: FST01 LCH WA,(XL)+ LOAD CHARACTER
16350: BGT =CH$$A,WA,FST02 SKIP IF LESS THAN LC A
16351: BGT WA,=CH$$$,FST02 SKIP IF GREATER THAN LC Z
16352: FLC WA FOLD CHARACTER TO UPPER CASE
16353: MNZ (XS) SET DID FOLD CHARACTER FLAG
16354: FST02 SCH WA,(XR)+ STORE (POSSIBLY FOLDED) CHARACTER
16355: BCT WC,FST01 LOOP THRU ENTIRE STRING
16356: CSC XR COMPLETE STORE CHARACTERS
16357: BNZ (XS)+,FST10 SKIP IF FOLDING DONE
16358: MOV (XS)+,DNAMP DO NOT NEED NEW SCBLK
16359: MOV (XS)+,XR RETURN ORIGINAL SCBLK
16360: BRN FST20 MERGE BELOW
16361: FST10 MOV (XS)+,XR RETURN NEW SCBLK
16362: ICA XS THROW AWAY ORIGINAL SCBLK POINTER
16363: FST20 MOV SCLEN(XR),WA RELOAD STRING LENGTH
16364: MOV (XS)+,XL RESTORE XL
16365: FST99 EXI RETURN
16366: ENP
16367: EJC
16368: .FI
16369: *
16370: * GBCOL -- PERFORM GARBAGE COLLECTION
16371: *
16372: * GBCOL PERFORMS A GARBAGE COLLECTION ON THE DYNAMIC REGION
16373: * ALL BLOCKS WHICH ARE NO LONGER IN USE ARE ELIMINATED
16374: * BY MOVING BLOCKS WHICH ARE IN USE DOWN AND RESETTING
16375: * DNAMP, THE POINTER TO THE NEXT AVAILABLE LOCATION.
16376: *
16377: * (WB) MOVE OFFSET (SEE BELOW)
16378: * JSR GBCOL CALL TO COLLECT GARBAGE
16379: * (XR) DESTROYED
16380: *
16381: * THE FOLLOWING CONDITIONS MUST BE MET AT THE TIME WHEN
16382: * GBCOL IS CALLED.
16383: *
16384: * 1) ALL POINTERS TO BLOCKS IN THE DYNAMIC AREA MUST BE
16385: * ACCESSIBLE TO THE GARBAGE COLLECTOR. THIS MEANS
16386: * THAT THEY MUST OCCUR IN ONE OF THE FOLLOWING.
16387: *
16388: * A) MAIN STACK, WITH CURRENT TOP
16389: * ELEMENT BEING INDICATED BY XS
16390: *
16391: * B) IN RELOCATABLE FIELDS OF VRBLKS.
16392: *
16393: * C) IN REGISTER XL AT THE TIME OF CALL
16394: *
16395: * E) IN THE SPECIAL REGION OF WORKING
16396: * STORAGE WHERE NAMES BEGIN WITH R$.
16397: *
16398: * 2) ALL POINTERS MUST POINT TO THE START OF BLOCKS WITH
16399: * THE SOLE EXCEPTION OF THE CONTENTS OF THE CODE
16400: * POINTER REGISTER WHICH POINTS INTO THE R$COD BLOCK.
16401: *
16402: * 3) NO LOCATION WHICH APPEARS TO CONTAIN A POINTER
16403: * INTO THE DYNAMIC REGION MAY OCCUR UNLESS IT IS IN
16404: * FACT A POINTER TO THE START OF THE BLOCK. HOWEVER
16405: * POINTERS OUTSIDE THIS AREA MAY OCCUR AND WILL
16406: * NOT BE CHANGED BY THE GARBAGE COLLECTOR.
16407: * IT IS ESPECIALLY IMPORTANT TO MAKE SURE THAT XL
16408: * DOES NOT CONTAIN A GARBAGE VALUE FROM SOME PROCESS
16409: * CARRIED OUT BEFORE THE CALL TO THE COLLECTOR.
16410: *
16411: * GBCOL HAS THE CAPABILITY OF MOVING THE FINAL COMPACTED
16412: * RESULT UP IN MEMORY (WITH ADDRESSES ADJUSTED ACCORDINGLY)
16413: * THIS IS USED TO ADD SPACE TO THE STATIC REGION. THE
16414: * ENTRY VALUE OF WB IS THE NUMBER OF BYTES TO MOVE UP.
16415: * THE CALLER MUST GUARANTEE THAT THERE IS ENOUGH ROOM.
16416: * FURTHERMORE THE VALUE IN WB IF IT IS NON-ZERO, MUST BE AT
16417: * LEAST 256 SO THAT THE MWB INSTRUCTION CONDITIONS ARE MET.
16418: EJC
16419: *
16420: * GBCOL (CONTINUED)
16421: *
16422: * THE ALGORITHM, WHICH IS A MODIFICATION OF THE LISP-2
16423: * GARBAGE COLLECTOR DEVISED BY R.DEWAR AND K.BELCHER
16424: * TAKES THREE PASSES AS FOLLOWS.
16425: *
16426: * 1) ALL POINTERS IN MEMORY ARE SCANNED AND BLOCKS IN USE
16427: * DETERMINED FROM THIS SCAN. NOTE THAT THIS PROCEDURE
16428: * IS RECURSIVE AND USES THE MAIN STACK FOR LINKAGE.
16429: * THE MARKING PROCESS IS THUS SIMILAR TO THAT USED IN
16430: * A STANDARD LISP COLLECTOR. HOWEVER THE METHOD OF
16431: * ACTUALLY MARKING THE BLOCKS IS DIFFERENT.
16432: *
16433: * THE FIRST FIELD OF A BLOCK NORMALLY CONTAINS A
16434: * CODE ENTRY POINT POINTER. SUCH AN ENTRY POINTER
16435: * CAN BE DISTINGUISHED FROM THE ADDRESS OF ANY POINTER
16436: * TO BE PROCESSED BY THE COLLECTOR. DURING GARBAGE
16437: * COLLECTION, THIS WORD IS USED TO BUILD A BACK CHAIN
16438: * OF POINTERS THROUGH FIELDS WHICH POINT TO THE BLOCK.
16439: * THE END OF THE CHAIN IS MARKED BY THE OCCURENCE
16440: * OF THE WORD WHICH USED TO BE IN THE FIRST WORD OF
16441: * THE BLOCK. THIS BACKCHAIN SERVES BOTH AS A MARK
16442: * INDICATING THAT THE BLOCK IS IN USE AND AS A LIST OF
16443: * REFERENCES FOR THE RELOCATION PHASE.
16444: *
16445: * 2) STORAGE IS SCANNED SEQUENTIALLY TO DISCOVER WHICH
16446: * BLOCKS ARE CURRENTLY IN USE AS INDICATED BY THE
16447: * PRESENCE OF A BACKCHAIN. TWO POINTERS ARE MAINTAINED
16448: * ONE SCANS THROUGH LOOKING AT EACH BLOCK. THE OTHER
16449: * IS INCREMENTED ONLY FOR BLOCKS FOUND TO BE IN USE.
16450: * IN THIS WAY, THE EVENTUAL LOCATION OF EACH BLOCK CAN
16451: * BE DETERMINED WITHOUT ACTUALLY MOVING ANY BLOCKS.
16452: * AS EACH BLOCK WHICH IS IN USE IS PROCESSED, THE BACK
16453: * CHAIN IS USED TO RESET ALL POINTERS WHICH POINT TO
16454: * THIS BLOCK TO CONTAIN ITS NEW ADDRESS, I.E. THE
16455: * ADDRESS IT WILL OCCUPY AFTER THE BLOCKS ARE MOVED.
16456: * THE FIRST WORD OF THE BLOCK, TAKEN FROM THE END OF
16457: * THE CHAIN IS RESTORED AT THIS POINT.
16458: *
16459: * DURING PASS 2, THE COLLECTOR BUILDS BLOCKS WHICH
16460: * DESCRIBE THE REGIONS OF STORAGE WHICH ARE TO BE
16461: * MOVED IN THE THIRD PASS. THERE IS ONE DESCRIPTOR FOR
16462: * EACH CONTIGUOUS SET OF GOOD BLOCKS. THE DESCRIPTOR
16463: * IS BUILT JUST BEHIND THE BLOCK TO BE MOVED AND
16464: * CONTAINS A POINTER TO THE NEXT BLOCK AND THE NUMBER
16465: * OF WORDS TO BE MOVED.
16466: *
16467: * 3) IN THE THIRD AND FINAL PASS, THE MOVE DESCRIPTOR
16468: * BLOCKS BUILT IN PASS TWO ARE USED TO ACTUALLY MOVE
16469: * THE BLOCKS DOWN TO THE BOTTOM OF THE DYNAMIC REGION.
16470: * THE COLLECTION IS THEN COMPLETE AND THE NEXT
16471: * AVAILABLE LOCATION POINTER IS RESET.
16472: EJC
16473: *
16474: * GBCOL (CONTINUED)
16475: *
16476: GBCOL PRC E,0 ENTRY POINT
16477: BNZ DMVCH,GBC14 FAIL IF IN MID-DUMP
16478: MNZ GBCFL NOTE GBCOL ENTERED
16479: MOV WA,GBSVA SAVE ENTRY WA
16480: MOV WB,GBSVB SAVE ENTRY WB
16481: MOV WC,GBSVC SAVE ENTRY WC
16482: MOV XL,-(XS) SAVE ENTRY XL
16483: SCP WA GET CODE POINTER VALUE
16484: SUB R$COD,WA MAKE RELATIVE
16485: LCP WA AND RESTORE
16486: *
16487: * PROCESS STACK ENTRIES
16488: *
16489: MOV XS,XR POINT TO STACK FRONT
16490: MOV STBAS,XL POINT PAST END OF STACK
16491: BGE XL,XR,GBC00 OK IF D-STACK
16492: MOV XL,XR REVERSE IF ...
16493: MOV XS,XL ... U-STACK
16494: *
16495: * PROCESS THE STACK
16496: *
16497: GBC00 JSR GBCPF PROCESS POINTERS ON STACK
16498: *
16499: * PROCESS SPECIAL WORK LOCATIONS
16500: *
16501: MOV =R$AAA,XR POINT TO START OF RELOCATABLE LOCS
16502: MOV =R$YYY,XL POINT PAST END OF RELOCATABLE LOCS
16503: JSR GBCPF PROCESS WORK FIELDS
16504: *
16505: * PREPARE TO PROCESS VARIABLE BLOCKS
16506: *
16507: MOV HSHTB,WA POINT TO FIRST HASH SLOT POINTER
16508: *
16509: * LOOP THROUGH HASH SLOTS
16510: *
16511: GBC01 MOV WA,XL POINT TO NEXT SLOT
16512: ICA WA BUMP BUCKET POINTER
16513: MOV WA,GBCNM SAVE BUCKET POINTER
16514: EJC
16515: *
16516: * GBCOL (CONTINUED)
16517: *
16518: * LOOP THROUGH VARIABLES ON ONE HASH CHAIN
16519: *
16520: GBC02 MOV (XL),XR LOAD PTR TO NEXT VRBLK
16521: BZE XR,GBC03 JUMP IF END OF CHAIN
16522: MOV XR,XL ELSE COPY VRBLK POINTER
16523: ADD *VRVAL,XR POINT TO FIRST RELOC FLD
16524: ADD *VRNXT,XL POINT PAST LAST (AND TO LINK PTR)
16525: JSR GBCPF PROCESS RELOC FIELDS IN VRBLK
16526: BRN GBC02 LOOP BACK FOR NEXT BLOCK
16527: *
16528: * HERE AT END OF ONE HASH CHAIN
16529: *
16530: GBC03 MOV GBCNM,WA RESTORE BUCKET POINTER
16531: BNE WA,HSHTE,GBC01 LOOP BACK IF MORE BUCKETS TO GO
16532: EJC
16533: *
16534: * GBCOL (CONTINUED)
16535: *
16536: * NOW WE ARE READY TO START PASS TWO. REGISTERS ARE USED
16537: * AS FOLLOWS IN PASS TWO.
16538: *
16539: * (XR) SCANS THROUGH ALL BLOCKS
16540: * (WC) POINTER TO EVENTUAL LOCATION
16541: *
16542: * THE MOVE DESCRIPTION BLOCKS BUILT IN THIS PASS HAVE
16543: * THE FOLLOWING FORMAT.
16544: *
16545: * WORD 1 POINTER TO NEXT MOVE BLOCK,
16546: * ZERO IF END OF CHAIN OF BLOCKS
16547: *
16548: * WORD 2 LENGTH OF BLOCKS TO BE MOVED IN
16549: * BYTES. SET TO THE ADDRESS OF THE
16550: * FIRST BYTE WHILE ACTUALLY SCANNING
16551: * THE BLOCKS.
16552: *
16553: * THE FIRST ENTRY ON THIS CHAIN IS A SPECIAL ENTRY
16554: * CONSISTING OF THE TWO WORDS GBCNM AND GBCNS. AFTER
16555: * BUILDING THE CHAIN OF MOVE DESCRIPTORS, GBCNM POINTS TO
16556: * THE FIRST REAL MOVE BLOCK, AND GBCNS IS THE LENGTH OF
16557: * BLOCKS IN USE AT THE START OF STORAGE WHICH NEED NOT
16558: * BE MOVED SINCE THEY ARE IN THE CORRECT POSITION.
16559: *
16560: GBC04 MOV DNAMB,XR POINT TO FIRST BLOCK
16561: MOV XR,WC SET AS FIRST EVENTUAL LOCATION
16562: ADD GBSVB,WC ADD OFFSET FOR EVENTUAL MOVE UP
16563: ZER GBCNM CLEAR INITIAL FORWARD POINTER
16564: MOV =GBCNM,GBCLM INITIALIZE PTR TO LAST MOVE BLOCK
16565: MOV XR,GBCNS INITIALIZE FIRST ADDRESS
16566: *
16567: * LOOP THROUGH A SERIES OF BLOCKS IN USE
16568: *
16569: GBC05 BEQ XR,DNAMP,GBC07 JUMP IF END OF USED REGION
16570: MOV (XR),WA ELSE GET FIRST WORD
16571: BHI WA,=P$YYY,GBC06 SKIP IF NOT ENTRY PTR (IN USE)
16572: BHI WA,=B$AAA,GBC07 JUMP IF ENTRY POINTER (UNUSED)
16573: *
16574: * HERE FOR BLOCK IN USE, LOOP TO RELOCATE REFERENCES
16575: *
16576: GBC06 MOV WA,XL COPY POINTER
16577: MOV (XL),WA LOAD FORWARD POINTER
16578: MOV WC,(XL) RELOCATE REFERENCE
16579: BHI WA,=P$YYY,GBC06 LOOP BACK IF NOT END OF CHAIN
16580: BLO WA,=B$AAA,GBC06 LOOP BACK IF NOT END OF CHAIN
16581: EJC
16582: *
16583: * GBCOL (CONTINUED)
16584: *
16585: * AT END OF CHAIN, RESTORE FIRST WORD AND BUMP PAST
16586: *
16587: MOV WA,(XR) RESTORE FIRST WORD
16588: JSR BLKLN GET LENGTH OF THIS BLOCK
16589: ADD WA,XR BUMP ACTUAL POINTER
16590: ADD WA,WC BUMP EVENTUAL POINTER
16591: BRN GBC05 LOOP BACK FOR NEXT BLOCK
16592: *
16593: * HERE AT END OF A SERIES OF BLOCKS IN USE
16594: *
16595: GBC07 MOV XR,WA COPY POINTER PAST LAST BLOCK
16596: MOV GBCLM,XL POINT TO PREVIOUS MOVE BLOCK
16597: SUB 1(XL),WA SUBTRACT STARTING ADDRESS
16598: MOV WA,1(XL) STORE LENGTH OF BLOCK TO BE MOVED
16599: *
16600: * LOOP THROUGH A SERIES OF BLOCKS NOT IN USE
16601: *
16602: GBC08 BEQ XR,DNAMP,GBC10 JUMP IF END OF USED REGION
16603: MOV (XR),WA ELSE LOAD FIRST WORD OF NEXT BLOCK
16604: BHI WA,=P$YYY,GBC09 JUMP IF IN USE
16605: BLO WA,=B$AAA,GBC09 JUMP IF IN USE
16606: JSR BLKLN ELSE GET LENGTH OF NEXT BLOCK
16607: ADD WA,XR PUSH POINTER
16608: BRN GBC08 AND LOOP BACK
16609: *
16610: * HERE FOR A BLOCK IN USE AFTER PROCESSING A SERIES OF
16611: * BLOCKS WHICH WERE NOT IN USE, BUILD NEW MOVE BLOCK.
16612: *
16613: GBC09 SUB *NUM02,XR POINT 2 WORDS BEHIND FOR MOVE BLOCK
16614: MOV GBCLM,XL POINT TO PREVIOUS MOVE BLOCK
16615: MOV XR,(XL) SET FORWARD PTR IN PREVIOUS BLOCK
16616: ZER (XR) ZERO FORWARD PTR OF NEW BLOCK
16617: MOV XR,GBCLM REMEMBER ADDRESS OF THIS BLOCK
16618: MOV XR,XL COPY PTR TO MOVE BLOCK
16619: ADD *NUM02,XR POINT BACK TO BLOCK IN USE
16620: MOV XR,1(XL) STORE STARTING ADDRESS
16621: BRN GBC06 JUMP TO PROCESS BLOCK IN USE
16622: EJC
16623: *
16624: * GBCOL (CONTINUED)
16625: *
16626: * HERE FOR PASS THREE -- ACTUALLY MOVE THE BLOCKS DOWN
16627: *
16628: * (XL) POINTER TO OLD LOCATION
16629: * (XR) POINTER TO NEW LOCATION
16630: *
16631: GBC10 MOV DNAMB,XR POINT TO START OF STORAGE
16632: ADD GBCNS,XR BUMP PAST UNMOVED BLOCKS AT START
16633: *
16634: * LOOP THROUGH MOVE DESCRIPTORS
16635: *
16636: GBC11 MOV GBCNM,XL POINT TO NEXT MOVE BLOCK
16637: BZE XL,GBC12 JUMP IF END OF CHAIN
16638: MOV (XL)+,GBCNM MOVE POINTER DOWN CHAIN
16639: MOV (XL)+,WA GET LENGTH TO MOVE
16640: MVW PERFORM MOVE
16641: BRN GBC11 LOOP BACK
16642: *
16643: * NOW TEST FOR MOVE UP
16644: *
16645: GBC12 MOV XR,DNAMP SET NEXT AVAILABLE LOC PTR
16646: MOV GBSVB,WB RELOAD MOVE OFFSET
16647: BZE WB,GBC13 JUMP IF NO MOVE REQUIRED
16648: MOV XR,XL ELSE COPY OLD TOP OF CORE
16649: ADD WB,XR POINT TO NEW TOP OF CORE
16650: MOV XR,DNAMP SAVE NEW TOP OF CORE POINTER
16651: MOV XL,WA COPY OLD TOP
16652: SUB DNAMB,WA MINUS OLD BOTTOM = LENGTH
16653: ADD WB,DNAMB BUMP BOTTOM TO GET NEW VALUE
16654: MWB PERFORM MOVE (BACKWARDS)
16655: *
16656: * MERGE HERE TO EXIT
16657: *
16658: GBC13 MOV GBSVA,WA RESTORE WA
16659: SCP WC GET CODE POINTER
16660: ADD R$COD,WC MAKE ABSOLUTE AGAIN
16661: LCP WC AND REPLACE ABSOLUTE VALUE
16662: MOV GBSVC,WC RESTORE WC
16663: MOV (XS)+,XL RESTORE ENTRY XL
16664: ICV GBCNT INCREMENT COUNT OF COLLECTIONS
16665: ZER XR CLEAR GARBAGE VALUE IN XR
16666: ZER GBCFL NOTE EXIT FROM GBCOL
16667: EXI EXIT TO GBCOL CALLER
16668: *
16669: * GARBAGE COLLECTION NOT ALLOWED WHILST DUMPING
16670: *
16671: GBC14 ICV ERRFT FATAL ERROR
16672: ERB 250,INSUFFICIENT MEMORY TO COMPLETE DUMP
16673: ENP END PROCEDURE GBCOL
16674: EJC
16675: *
16676: * GBCPF -- PROCESS FIELDS FOR GARBAGE COLLECTOR
16677: *
16678: * THIS PROCEDURE IS USED BY THE GARBAGE COLLECTOR TO
16679: * PROCESS FIELDS IN PASS ONE. SEE GBCOL FOR FULL DETAILS.
16680: *
16681: * (XR) PTR TO FIRST LOCATION TO PROCESS
16682: * (XL) PTR PAST LAST LOCATION TO PROCESS
16683: * JSR GBCPF CALL TO PROCESS FIELDS
16684: * (XR,WA,WB,WC,IA) DESTROYED
16685: *
16686: * NOTE THAT ALTHOUGH THIS PROCEDURE USES A RECURSIVE
16687: * APPROACH, IT CONTROLS ITS OWN STACK AND IS NOT RECURSIVE.
16688: *
16689: GBCPF PRC E,0 ENTRY POINT
16690: ZER -(XS) SET ZERO TO MARK BOTTOM OF STACK
16691: MOV XL,-(XS) SAVE END POINTER
16692: *
16693: * MERGE HERE TO GO DOWN A LEVEL AND START A NEW LOOP
16694: *
16695: * 1(XS) NEXT LVL FIELD PTR (0 AT OUTER LVL)
16696: * 0(XS) PTR PAST LAST FIELD TO PROCESS
16697: * (XR) PTR TO FIRST FIELD TO PROCESS
16698: *
16699: * LOOP TO PROCESS SUCCESSIVE FIELDS
16700: *
16701: GPF01 MOV (XR),XL LOAD FIELD CONTENTS
16702: MOV XR,WC SAVE FIELD POINTER
16703: BLT XL,DNAMB,GPF02 JUMP IF NOT PTR INTO DYNAMIC AREA
16704: BGE XL,DNAMP,GPF02 JUMP IF NOT PTR INTO DYNAMIC AREA
16705: *
16706: * HERE WE HAVE A PTR TO A BLOCK IN THE DYNAMIC AREA.
16707: * LINK THIS FIELD ONTO THE REFERENCE BACKCHAIN.
16708: *
16709: MOV (XL),WA LOAD PTR TO CHAIN (OR ENTRY PTR)
16710: MOV XR,(XL) SET THIS FIELD AS NEW HEAD OF CHAIN
16711: MOV WA,(XR) SET FORWARD POINTER
16712: *
16713: * NOW SEE IF THIS BLOCK HAS BEEN PROCESSED BEFORE
16714: *
16715: BHI WA,=P$YYY,GPF02 JUMP IF ALREADY PROCESSED
16716: BHI WA,=B$AAA,GPF03 JUMP IF NOT ALREADY PROCESSED
16717: *
16718: * HERE TO MOVE TO NEXT FIELD
16719: *
16720: GPF02 MOV WC,XR RESTORE FIELD POINTER
16721: ICA XR BUMP TO NEXT FIELD
16722: BNE XR,(XS),GPF01 LOOP BACK IF MORE TO GO
16723: EJC
16724: *
16725: * GBCPF (CONTINUED)
16726: *
16727: * HERE WE POP UP A LEVEL AFTER FINISHING A BLOCK
16728: *
16729: MOV (XS)+,XL RESTORE POINTER PAST END
16730: MOV (XS)+,WC RESTORE BLOCK POINTER
16731: BNZ WC,GPF02 CONTINUE LOOP UNLESS OUTER LEVL
16732: EXI RETURN TO CALLER IF OUTER LEVEL
16733: *
16734: * HERE TO PROCESS AN ACTIVE BLOCK WHICH HAS NOT BEEN DONE
16735: *
16736: GPF03 MOV XL,XR COPY BLOCK POINTER
16737: MOV WA,XL COPY FIRST WORD OF BLOCK
16738: LEI XL LOAD ENTRY POINT ID (BL$XX)
16739: *
16740: * BLOCK TYPE SWITCH. NOTE THAT BLOCKS WITH NO RELOCATABLE
16741: * FIELDS JUST RETURN TO GPF02 HERE TO CONTINE TO NEXT FLD.
16742: *
16743: BSW XL,BL$$$ SWITCH ON BLOCK TYPE
16744: IFF BL$AR,GPF06 ARBLK
16745: .IF .CNBF
16746: .ELSE
16747: IFF BL$BC,GPF18 BCBLK
16748: IFF BL$BF,GPF02 BFBLK
16749: .FI
16750: IFF BL$CC,GPF07 CCBLK
16751: IFF BL$CD,GPF08 CDBLK
16752: IFF BL$CM,GPF04 CMBLK
16753: IFF BL$DF,GPF02 DFBLK
16754: IFF BL$EV,GPF10 EVBLK
16755: IFF BL$EX,GPF17 EXBLK
16756: IFF BL$FF,GPF11 FFBLK
16757: IFF BL$NM,GPF10 NMBLK
16758: IFF BL$P0,GPF10 P0BLK
16759: IFF BL$P1,GPF12 P1BLK
16760: IFF BL$P2,GPF12 P2BLK
16761: IFF BL$PD,GPF13 PDBLK
16762: IFF BL$PF,GPF14 PFBLK
16763: IFF BL$TB,GPF08 TBBLK
16764: IFF BL$TE,GPF15 TEBLK
16765: IFF BL$TR,GPF16 TRBLK
16766: IFF BL$VC,GPF08 VCBLK
16767: IFF BL$XR,GPF09 XRBLK
16768: IFF BL$CT,GPF02 CTBLK
16769: IFF BL$EF,GPF02 EFBLK
16770: IFF BL$IC,GPF02 ICBLK
16771: IFF BL$KV,GPF02 KVBLK
16772: .IF .CNRA
16773: .ELSE
16774: IFF BL$RC,GPF02 RCBLK
16775: .FI
16776: IFF BL$SC,GPF02 SCBLK
16777: IFF BL$SE,GPF02 SEBLK
16778: IFF BL$XN,GPF02 XNBLK
16779: ESW END OF JUMP TABLE
16780: EJC
16781: *
16782: * GBCPF (CONTINUED)
16783: *
16784: * CMBLK
16785: *
16786: GPF04 MOV CMLEN(XR),WA LOAD LENGTH
16787: MOV *CMTYP,WB SET OFFSET
16788: *
16789: * HERE TO PUSH DOWN TO NEW LEVEL
16790: *
16791: * (WC) FIELD PTR AT PREVIOUS LEVEL
16792: * (XR) PTR TO NEW BLOCK
16793: * (WA) LENGTH (RELOC FLDS + FLDS AT START)
16794: * (WB) OFFSET TO FIRST RELOC FIELD
16795: *
16796: GPF05 ADD XR,WA POINT PAST LAST RELOC FIELD
16797: ADD WB,XR POINT TO FIRST RELOC FIELD
16798: MOV WC,-(XS) STACK OLD FIELD POINTER
16799: MOV WA,-(XS) STACK NEW LIMIT POINTER
16800: CHK CHECK FOR STACK OVERFLOW
16801: BRN GPF01 IF OK, BACK TO PROCESS
16802: *
16803: * ARBLK
16804: *
16805: GPF06 MOV ARLEN(XR),WA LOAD LENGTH
16806: MOV AROFS(XR),WB SET OFFSET TO 1ST RELOC FLD (ARPRO)
16807: BRN GPF05 ALL SET
16808: *
16809: * CCBLK
16810: *
16811: GPF07 MOV CCUSE(XR),WA SET LENGTH IN USE
16812: MOV *CCUSE,WB 1ST WORD (MAKE SURE AT LEAST ONE)
16813: BRN GPF05 ALL SET
16814: EJC
16815: *
16816: * GBCPF (CONTINUED)
16817: *
16818: * CDBLK, TBBLK, VCBLK
16819: *
16820: GPF08 MOV OFFS2(XR),WA LOAD LENGTH
16821: MOV *OFFS3,WB SET OFFSET
16822: BRN GPF05 JUMP BACK
16823: *
16824: * XRBLK
16825: *
16826: GPF09 MOV XRLEN(XR),WA LOAD LENGTH
16827: MOV *XRPTR,WB SET OFFSET
16828: BRN GPF05 JUMP BACK
16829: *
16830: * EVBLK, NMBLK, P0BLK
16831: *
16832: GPF10 MOV *OFFS2,WA POINT PAST SECOND FIELD
16833: MOV *OFFS1,WB OFFSET IS ONE (ONLY RELOC FLD IS 2)
16834: BRN GPF05 ALL SET
16835: *
16836: * FFBLK
16837: *
16838: GPF11 MOV *FFOFS,WA SET LENGTH
16839: MOV *FFNXT,WB SET OFFSET
16840: BRN GPF05 ALL SET
16841: *
16842: * P1BLK, P2BLK
16843: *
16844: GPF12 MOV *PARM2,WA LENGTH (PARM2 IS NON-RELOCATABLE)
16845: MOV *PTHEN,WB SET OFFSET
16846: BRN GPF05 ALL SET
16847: EJC
16848: *
16849: * GBCPF (CONTINUED)
16850: *
16851: * PDBLK
16852: *
16853: GPF13 MOV PDDFP(XR),XL LOAD PTR TO DFBLK
16854: MOV DFPDL(XL),WA GET PDBLK LENGTH
16855: MOV *PDFLD,WB SET OFFSET
16856: BRN GPF05 ALL SET
16857: *
16858: * PFBLK
16859: *
16860: GPF14 MOV *PFARG,WA LENGTH PAST LAST RELOC
16861: MOV *PFCOD,WB OFFSET TO FIRST RELOC
16862: BRN GPF05 ALL SET
16863: *
16864: * TEBLK
16865: *
16866: GPF15 MOV *TESI$,WA SET LENGTH
16867: MOV *TESUB,WB AND OFFSET
16868: BRN GPF05 ALL SET
16869: *
16870: * TRBLK
16871: *
16872: GPF16 MOV *TRSI$,WA SET LENGTH
16873: MOV *TRVAL,WB AND OFFSET
16874: BRN GPF05 ALL SET
16875: *
16876: * EXBLK
16877: *
16878: GPF17 MOV EXLEN(XR),WA LOAD LENGTH
16879: MOV *EXFLC,WB SET OFFSET
16880: BRN GPF05 JUMP BACK
16881: .IF .CNBF
16882: .ELSE
16883: *
16884: * BCBLK
16885: *
16886: GPF18 MOV *BCSI$,WA SET LENGTH
16887: MOV *BCBUF,WB AND OFFSET
16888: BRN GPF05 ALL SET
16889: .FI
16890: ENP END PROCEDURE GBCPF
16891: EJC
16892: *
16893: * GTARR -- GET ARRAY
16894: *
16895: * GTARR IS PASSED AN OBJECT AND RETURNS AN ARRAY IF POSSIBL
16896: *
16897: * (XR) VALUE TO BE CONVERTED
16898: * JSR GTARR CALL TO GET ARRAY
16899: * PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE
16900: * (XR) RESULTING ARRAY
16901: * (XL,WA,WB,WC) DESTROYED
16902: *
16903: GTARR PRC E,1 ENTRY POINT
16904: MOV (XR),WA LOAD TYPE WORD
16905: BEQ WA,=B$ART,GTAR8 EXIT IF ALREADY AN ARRAY
16906: BEQ WA,=B$VCT,GTAR8 EXIT IF ALREADY AN ARRAY
16907: BNE WA,=B$TBT,GTA9A ELSE FAIL IF NOT A TABLE (SGD02)
16908: *
16909: * HERE WE CONVERT A TABLE TO AN ARRAY
16910: *
16911: MOV XR,-(XS) REPLACE TBBLK POINTER ON STACK
16912: ZER XR SIGNAL FIRST PASS
16913: ZER WB ZERO NON-NULL ELEMENT COUNT
16914: *
16915: * THE FOLLOWING CODE IS EXECUTED TWICE. ON THE FIRST PASS,
16916: * SIGNALLED BY XR=0, THE NUMBER OF NON-NULL ELEMENTS IN
16917: * THE TABLE IS COUNTED IN WB. IN THE SECOND PASS, WHERE
16918: * XR IS A POINTER INTO THE ARBLK, THE NAME AND VALUE ARE
16919: * ENTERED INTO THE CURRENT ARBLK LOCATION.
16920: *
16921: GTAR1 MOV (XS),XL POINT TO TABLE
16922: ADD TBLEN(XL),XL POINT PAST LAST BUCKET
16923: SUB *TBBUK,XL SET FIRST BUCKET OFFSET
16924: MOV XL,WA COPY ADJUSTED POINTER
16925: *
16926: * LOOP THROUGH BUCKETS IN TABLE BLOCK
16927: * NEXT THREE LINES OF CODE RELY ON TENXT HAVING A VALUE
16928: * 1 LESS THAN TBBUK.
16929: *
16930: GTAR2 MOV WA,XL COPY BUCKET POINTER
16931: DCA WA DECREMENT BUCKET POINTER
16932: *
16933: * LOOP THROUGH TEBLKS ON ONE BUCKET CHAIN
16934: *
16935: GTAR3 MOV TENXT(XL),XL POINT TO NEXT TEBLK
16936: BEQ XL,(XS),GTAR6 JUMP IF CHAIN END (TBBLK PTR)
16937: MOV XL,CNVTP ELSE SAVE TEBLK POINTER
16938: *
16939: * LOOP TO FIND VALUE DOWN TRBLK CHAIN
16940: *
16941: GTAR4 MOV TEVAL(XL),XL LOAD VALUE
16942: BEQ (XL),=B$TRT,GTAR4 LOOP TILL VALUE FOUND
16943: MOV XL,WC COPY VALUE
16944: MOV CNVTP,XL RESTORE TEBLK POINTER
16945: EJC
16946: *
16947: * GTARR (CONTINUED)
16948: *
16949: * NOW CHECK FOR NULL AND TEST CASES
16950: *
16951: BEQ WC,=NULLS,GTAR3 LOOP BACK TO IGNORE NULL VALUE
16952: BNZ XR,GTAR5 JUMP IF SECOND PASS
16953: ICV WB FOR THE FIRST PASS, BUMP COUNT
16954: BRN GTAR3 AND LOOP BACK FOR NEXT TEBLK
16955: *
16956: * HERE IN SECOND PASS
16957: *
16958: GTAR5 MOV TESUB(XL),(XR)+ STORE SUBSCRIPT NAME
16959: MOV WC,(XR)+ STORE VALUE IN ARBLK
16960: BRN GTAR3 LOOP BACK FOR NEXT TEBLK
16961: *
16962: * HERE AFTER SCANNING TEBLKS ON ONE CHAIN
16963: *
16964: GTAR6 BNE WA,(XS),GTAR2 LOOP BACK IF MORE BUCKETS TO GO
16965: BNZ XR,GTAR7 ELSE JUMP IF SECOND PASS
16966: *
16967: * HERE AFTER COUNTING NON-NULL ELEMENTS
16968: *
16969: BZE WB,GTAR9 FAIL IF NO NON-NULL ELEMENTS
16970: MOV WB,WA ELSE COPY COUNT
16971: ADD WB,WA DOUBLE (TWO WORDS/ELEMENT)
16972: ADD =ARVL2,WA ADD SPACE FOR STANDARD FIELDS
16973: WTB WA CONVERT LENGTH TO BYTES
16974: BGE WA,MXLEN,GTAR9 FAIL IF TOO LONG FOR ARRAY
16975: JSR ALLOC ELSE ALLOCATE SPACE FOR ARBLK
16976: MOV =B$ART,(XR) STORE TYPE WORD
16977: ZER IDVAL(XR) ZERO ID FOR THE MOMENT
16978: MOV WA,ARLEN(XR) STORE LENGTH
16979: MOV =NUM02,ARNDM(XR) SET DIMENSIONS = 2
16980: LDI INTV1 GET INTEGER ONE
16981: STI ARLBD(XR) STORE AS LBD 1
16982: STI ARLB2(XR) STORE AS LBD 2
16983: LDI INTV2 LOAD INTEGER TWO
16984: STI ARDM2(XR) STORE AS DIM 2
16985: MTI WB GET ELEMENT COUNT AS INTEGER
16986: STI ARDIM(XR) STORE AS DIM 1
16987: ZER ARPR2(XR) ZERO PROTOTYPE FIELD FOR NOW
16988: MOV *ARPR2,AROFS(XR) SET OFFSET FIELD (SIGNAL PASS 2)
16989: MOV XR,WB SAVE ARBLK POINTER
16990: ADD *ARVL2,XR POINT TO FIRST ELEMENT LOCATION
16991: BRN GTAR1 JUMP BACK TO FILL IN ELEMENTS
16992: EJC
16993: *
16994: * GTARR (CONTINUED)
16995: *
16996: * HERE AFTER FILLING IN ELEMENT VALUES
16997: *
16998: GTAR7 MOV WB,XR RESTORE ARBLK POINTER
16999: MOV WB,(XS) STORE AS RESULT
17000: *
17001: * NOW WE NEED THE ARRAY PROTOTYPE WHICH IS OF THE FORM NN,2
17002: * THIS IS OBTAINED BY BUILDING THE STRING FOR NN02 AND
17003: * CHANGING THE ZERO TO A COMMA BEFORE STORING IT.
17004: *
17005: LDI ARDIM(XR) GET NUMBER OF ELEMENTS (NN)
17006: MLI INTVH MULTIPLY BY 100
17007: ADI INTV2 ADD 2 (NN02)
17008: JSR ICBLD BUILD INTEGER
17009: MOV XR,-(XS) STORE PTR FOR GTSTG
17010: JSR GTSTG CONVERT TO STRING
17011: PPM CONVERT FAIL IS IMPOSSIBLE
17012: MOV XR,XL COPY STRING POINTER
17013: MOV (XS)+,XR RELOAD ARBLK POINTER
17014: MOV XL,ARPR2(XR) STORE PROTOTYPE PTR (NN02)
17015: SUB =NUM02,WA ADJUST LENGTH TO POINT TO ZERO
17016: PSC XL,WA POINT TO ZERO
17017: MOV =CH$CM,WB LOAD A COMMA
17018: SCH WB,(XL) STORE A COMMA OVER THE ZERO
17019: CSC XL COMPLETE STORE CHARACTERS
17020: *
17021: * NORMAL RETURN
17022: *
17023: GTAR8 EXI RETURN TO CALLER
17024: *
17025: * NON-CONVERSION RETURN
17026: *
17027: GTAR9 MOV (XS)+,XR RESTORE STACK FOR CONV ERR (SGD02)
17028: *
17029: * MERGE TO TAKE CONVERT ERROR WHEN STACK ADJUSTED OK
17030: *
17031: GTA9A EXI 1 RETURN
17032: ENP PROCEDURE GTARR
17033: EJC
17034: *
17035: * GTCOD -- CONVERT TO CODE
17036: *
17037: * (XR) OBJECT TO BE CONVERTED
17038: * JSR GTCOD CALL TO CONVERT TO CODE
17039: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
17040: * (XR) POINTER TO RESULTING CDBLK
17041: * (XL,WA,WB,WC,RA) DESTROYED
17042: *
17043: * IF A SPITBOL ERROR OCCURS DURING COMPILATION OR PRE-
17044: * EVALUATION, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL
17045: * WITHOUT RETURNING TO THIS ROUTINE.
17046: *
17047: GTCOD PRC E,1 ENTRY POINT
17048: BEQ (XR),=B$CDS,GTCD1 JUMP IF ALREADY CODE
17049: BEQ (XR),=B$CDC,GTCD1 JUMP IF ALREADY CODE
17050: *
17051: * HERE WE MUST GENERATE A CDBLK BY COMPILATION
17052: *
17053: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG
17054: JSR GTSTG CONVERT ARGUMENT TO STRING
17055: PPM GTCD2 JUMP IF NON-CONVERTIBLE
17056: MOV FLPTR,GTCEF SAVE FAIL PTR IN CASE OF ERROR
17057: MOV R$COD,R$GTC ALSO SAVE CODE PTR
17058: MOV XR,R$CIM ELSE SET IMAGE POINTER
17059: MOV WA,SCNIL SET IMAGE LENGTH
17060: ZER SCNPT SET SCAN POINTER
17061: MOV =STGXC,STAGE SET STAGE FOR EXECUTE COMPILE
17062: MOV CMPSN,LSTSN IN CASE LISTR CALLED
17063: JSR CMPIL COMPILE STRING
17064: MOV =STGXT,STAGE RESET STAGE FOR EXECUTE TIME
17065: ZER R$CIM CLEAR IMAGE
17066: *
17067: * MERGE HERE IF NO CONVERT REQUIRED
17068: *
17069: GTCD1 EXI GIVE NORMAL GTCOD RETURN
17070: *
17071: * HERE IF UNCONVERTIBLE
17072: *
17073: GTCD2 EXI 1 GIVE ERROR RETURN
17074: ENP END PROCEDURE GTCOD
17075: EJC
17076: *
17077: * GTEXP -- CONVERT TO EXPRESSION
17078: *
17079: * (XR) INPUT VALUE TO BE CONVERTED
17080: * JSR GTEXP CALL TO CONVERT TO EXPRESSION
17081: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
17082: * (XR) POINTER TO RESULT EXBLK OR SEBLK
17083: * (XL,WA,WB,WC,RA) DESTROYED
17084: *
17085: * IF A SPITBOL ERROR OCCURS DURING COMPILATION OR PRE-
17086: * EVALUATION, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL
17087: * WITHOUT RETURNING TO THIS ROUTINE.
17088: *
17089: GTEXP PRC E,1 ENTRY POINT
17090: BLO (XR),=B$E$$,GTEX1 JUMP IF ALREADY AN EXPRESSION
17091: MOV XR,-(XS) STORE ARGUMENT FOR GTSTG
17092: JSR GTSTG CONVERT ARGUMENT TO STRING
17093: PPM GTEX2 JUMP IF UNCONVERTIBLE
17094: *
17095: * CHECK THE LAST CHARACTER OF THE STRING FOR COLON OR
17096: * SEMICOLON. THESE CHARACTERS CAN LEGITIMATELY END AN
17097: * EXPRESSION IN OPEN CODE, SO EXPAN WILL NOT DETECT THEM
17098: * AS ERRORS, BUT THEY ARE INVALID AS TERMINATORS FOR A
17099: * STRING THAT IS BEING CONVERTED TO EXPRESSION FORM.
17100: *
17101: MOV XR,XL COPY INPUT STRING POINTER (REG06)
17102: PLC XL,WA POINT ONE PAST THE STRING END (REG06)
17103: LCH XL,-(XL) FETCH THE LAST CHARACTER (REG06)
17104: BEQ XL,=CH$CL,GTEX2 ERROR IF IT IS A SEMICOLON (REG06)
17105: BEQ XL,=CH$SM,GTEX2 OR IF IT IS A COLON (REG06)
17106: *
17107: * HERE WE CONVERT A STRING BY COMPILATION
17108: *
17109: MOV XR,R$CIM SET INPUT IMAGE POINTER
17110: ZER SCNPT SET SCAN POINTER
17111: MOV WA,SCNIL SET INPUT IMAGE LENGTH
17112: ZER WB SET CODE FOR NORMAL SCAN
17113: MOV FLPTR,GTCEF SAVE FAIL PTR IN CASE OF ERROR
17114: MOV R$COD,R$GTC ALSO SAVE CODE PTR
17115: MOV =STGEV,STAGE ADJUST STAGE FOR COMPILE
17116: MOV =T$UOK,SCNTP INDICATE UNARY OPERATOR ACCEPTABLE
17117: JSR EXPAN BUILD TREE FOR EXPRESSION
17118: ZER SCNRS RESET RESCAN FLAG
17119: BNE SCNPT,SCNIL,GTEX2 ERROR IF NOT END OF IMAGE
17120: ZER WB SET OK VALUE FOR CDGEX CALL
17121: MOV XR,XL COPY TREE POINTER
17122: JSR CDGEX BUILD EXPRESSION BLOCK
17123: ZER R$CIM CLEAR POINTER
17124: MOV =STGXT,STAGE RESTORE STAGE FOR EXECUTE TIME
17125: *
17126: * MERGE HERE IF NO CONVERSION REQUIRED
17127: *
17128: GTEX1 EXI RETURN TO GTEXP CALLER
17129: *
17130: * HERE IF UNCONVERTIBLE
17131: *
17132: GTEX2 EXI 1 TAKE ERROR EXIT
17133: ENP END PROCEDURE GTEXP
17134: EJC
17135: *
17136: * GTINT -- GET INTEGER VALUE
17137: *
17138: * GTINT IS PASSED AN OBJECT AND RETURNS AN INTEGER AFTER
17139: * PERFORMING ANY NECESSARY CONVERSIONS.
17140: *
17141: * (XR) VALUE TO BE CONVERTED
17142: * JSR GTINT CALL TO CONVERT TO INTEGER
17143: * PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE
17144: * (XR) RESULTING INTEGER
17145: * (WC,RA) DESTROYED
17146: * (WA,WB) DESTROYED (ONLY ON CONVERSION ERR)
17147: * (XR) UNCHANGED (ON CONVERT ERROR)
17148: *
17149: GTINT PRC E,1 ENTRY POINT
17150: BEQ (XR),=B$ICL,GTIN2 JUMP IF ALREADY AN INTEGER
17151: MOV WA,GTINA ELSE SAVE WA
17152: MOV WB,GTINB SAVE WB
17153: JSR GTNUM CONVERT TO NUMERIC
17154: PPM GTIN3 JUMP IF UNCONVERTIBLE
17155: .IF .CNRA
17156: .ELSE
17157: BEQ WA,=B$ICL,GTIN1 JUMP IF INTEGER
17158: *
17159: * HERE WE CONVERT A REAL TO INTEGER
17160: *
17161: LDR RCVAL(XR) LOAD REAL VALUE
17162: RTI GTIN3 CONVERT TO INTEGER (ERR IF OVFLOW)
17163: JSR ICBLD IF OK BUILD ICBLK
17164: .FI
17165: *
17166: * HERE AFTER SUCCESSFUL CONVERSION TO INTEGER
17167: *
17168: GTIN1 MOV GTINA,WA RESTORE WA
17169: MOV GTINB,WB RESTORE WB
17170: *
17171: * COMMON EXIT POINT
17172: *
17173: GTIN2 EXI RETURN TO GTINT CALLER
17174: *
17175: * HERE ON CONVERSION ERROR
17176: *
17177: GTIN3 EXI 1 TAKE CONVERT ERROR EXIT
17178: ENP END PROCEDURE GTINT
17179: EJC
17180: *
17181: * GTNUM -- GET NUMERIC VALUE
17182: *
17183: * GTNUM IS GIVEN AN OBJECT AND RETURNS EITHER AN INTEGER
17184: * OR A REAL, PERFORMING ANY NECESSARY CONVERSIONS.
17185: *
17186: * (XR) OBJECT TO BE CONVERTED
17187: * JSR GTNUM CALL TO CONVERT TO NUMERIC
17188: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
17189: * (XR) POINTER TO RESULT (INT OR REAL)
17190: * (WA) FIRST WORD OF RESULT BLOCK
17191: * (WB,WC,RA) DESTROYED
17192: * (XR) UNCHANGED (ON CONVERT ERROR)
17193: *
17194: GTNUM PRC E,1 ENTRY POINT
17195: MOV (XR),WA LOAD FIRST WORD OF BLOCK
17196: BEQ WA,=B$ICL,GTN34 JUMP IF INTEGER (NO CONVERSION)
17197: .IF .CNRA
17198: .ELSE
17199: BEQ WA,=B$RCL,GTN34 JUMP IF REAL (NO CONVERSION)
17200: .FI
17201: *
17202: * AT THIS POINT THE ONLY POSSIBILITY IS TO CONVERT A STRING
17203: * TO AN INTEGER OR REAL AS APPROPRIATE.
17204: *
17205: MOV XR,-(XS) STACK ARGUMENT IN CASE CONVERT ERR
17206: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG
17207: JSR GTSTG CONVERT ARGUMENT TO STRING
17208: PPM GTN36 JUMP IF UNCONVERTIBLE
17209: *
17210: * INITIALIZE NUMERIC CONVERSION
17211: *
17212: LDI INTV0 INITIALIZE INTEGER RESULT TO ZERO
17213: BZE WA,GTN32 JUMP TO EXIT WITH ZERO IF NULL
17214: LCT WA,WA SET BCT COUNTER FOR FOLLOWING LOOPS
17215: ZER GTNNF TENTATIVELY INDICATE RESULT +
17216: .IF .CNRA
17217: .ELSE
17218: STI GTNEX INITIALISE EXPONENT TO ZERO
17219: ZER GTNSC ZERO SCALE IN CASE REAL
17220: ZER GTNDF RESET FLAG FOR DEC POINT FOUND
17221: ZER GTNRD RESET FLAG FOR DIGITS FOUND
17222: LDR REAV0 ZERO REAL ACCUM IN CASE REAL
17223: .FI
17224: PLC XR POINT TO ARGUMENT CHARACTERS
17225: *
17226: * MERGE BACK HERE AFTER IGNORING LEADING BLANK
17227: *
17228: GTN01 LCH WB,(XR)+ LOAD FIRST CHARACTER
17229: BLT WB,=CH$D0,GTN02 JUMP IF NOT DIGIT
17230: BLE WB,=CH$D9,GTN06 JUMP IF FIRST CHAR IS A DIGIT
17231: EJC
17232: *
17233: * GTNUM (CONTINUED)
17234: *
17235: * HERE IF FIRST DIGIT IS NON-DIGIT
17236: *
17237: GTN02 BNE WB,=CH$BL,GTN03 JUMP IF NON-BLANK
17238: GTNA2 BCT WA,GTN01 ELSE DECR COUNT AND LOOP BACK
17239: BRN GTN07 JUMP TO RETURN ZERO IF ALL BLANKS
17240: *
17241: * HERE FOR FIRST CHARACTER NON-BLANK, NON-DIGIT
17242: *
17243: GTN03 BEQ WB,=CH$PL,GTN04 JUMP IF PLUS SIGN
17244: .IF .CAHT
17245: BEQ WB,=CH$HT,GTNA2 HORIZONTAL TAB EQUIV TO BLANK
17246: .FI
17247: .IF .CAVT
17248: BEQ WB,=CH$VT,GTNA2 VERTICAL TAB EQUIV TO BLANK
17249: .FI
17250: .IF .CNRA
17251: BNE WB,=CH$MN,GTN36 ELSE FAIL
17252: .ELSE
17253: BNE WB,=CH$MN,GTN12 JUMP IF NOT MINUS (MAY BE REAL)
17254: .FI
17255: MNZ GTNNF IF MINUS SIGN, SET NEGATIVE FLAG
17256: *
17257: * MERGE HERE AFTER PROCESSING SIGN
17258: *
17259: GTN04 BCT WA,GTN05 JUMP IF CHARS LEFT
17260: BRN GTN36 ELSE ERROR
17261: *
17262: * LOOP TO FETCH CHARACTERS OF AN INTEGER
17263: *
17264: GTN05 LCH WB,(XR)+ LOAD NEXT CHARACTER
17265: BLT WB,=CH$D0,GTN08 JUMP IF NOT A DIGIT
17266: BGT WB,=CH$D9,GTN08 JUMP IF NOT A DIGIT
17267: *
17268: * MERGE HERE FOR FIRST DIGIT
17269: *
17270: GTN06 STI GTNSI SAVE CURRENT VALUE
17271: .IF .CNRA
17272: CVM GTN36 CURRENT*10-(NEW DIG) JUMP IF OVFLOW
17273: .ELSE
17274: CVM GTN35 CURRENT*10-(NEW DIG) JUMP IF OVFLOW
17275: MNZ GTNRD SET DIGIT READ FLAG
17276: .FI
17277: BCT WA,GTN05 ELSE LOOP BACK IF MORE CHARS
17278: *
17279: * HERE TO EXIT WITH CONVERTED INTEGER VALUE
17280: *
17281: GTN07 BNZ GTNNF,GTN32 JUMP IF NEGATIVE (ALL SET)
17282: NGI ELSE NEGATE
17283: INO GTN32 JUMP IF NO OVERFLOW
17284: BRN GTN36 ELSE SIGNAL ERROR
17285: EJC
17286: *
17287: * GTNUM (CONTINUED)
17288: *
17289: * HERE FOR A NON-DIGIT CHARACTER WHILE ATTEMPTING TO
17290: * CONVERT AN INTEGER, CHECK FOR TRAILING BLANKS OR REAL.
17291: *
17292: GTN08 BEQ WB,=CH$BL,GTNA9 JUMP IF A BLANK
17293: .IF .CAHT
17294: BEQ WB,=CH$HT,GTNA9 JUMP IF HORIZONTAL TAB
17295: .FI
17296: .IF .CAVT
17297: BEQ WB,=CH$VT,GTNA9 JUMP IF VERTICAL TAB
17298: .FI
17299: .IF .CNRA
17300: BRN GTN36 ERROR
17301: .ELSE
17302: ITR ELSE CONVERT INTEGER TO REAL
17303: NGR NEGATE TO GET POSITIVE VALUE
17304: BRN GTN12 JUMP TO TRY FOR REAL
17305: .FI
17306: *
17307: * HERE WE SCAN OUT BLANKS TO END OF STRING
17308: *
17309: GTN09 LCH WB,(XR)+ GET NEXT CHAR
17310: .IF .CAHT
17311: BEQ WB,=CH$HT,GTNA9 JUMP IF HORIZONTAL TAB
17312: .FI
17313: .IF .CAVT
17314: BEQ WB,=CH$VT,GTNA9 JUMP IF VERTICAL TAB
17315: .FI
17316: BNE WB,=CH$BL,GTN36 ERROR IF NON-BLANK
17317: GTNA9 BCT WA,GTN09 LOOP BACK IF MORE CHARS TO CHECK
17318: BRN GTN07 RETURN INTEGER IF ALL BLANKS
17319: .IF .CNRA
17320: .ELSE
17321: *
17322: * LOOP TO COLLECT MANTISSA OF REAL
17323: *
17324: GTN10 LCH WB,(XR)+ LOAD NEXT CHARACTER
17325: BLT WB,=CH$D0,GTN12 JUMP IF NON-NUMERIC
17326: BGT WB,=CH$D9,GTN12 JUMP IF NON-NUMERIC
17327: *
17328: * MERGE HERE TO COLLECT FIRST REAL DIGIT
17329: *
17330: GTN11 SUB =CH$D0,WB CONVERT DIGIT TO NUMBER
17331: MLR REAVT MULTIPLY REAL BY 10.0
17332: ROV GTN36 CONVERT ERROR IF OVERFLOW
17333: STR GTNSR SAVE RESULT
17334: MTI WB GET NEW DIGIT AS INTEGER
17335: ITR CONVERT NEW DIGIT TO REAL
17336: ADR GTNSR ADD TO GET NEW TOTAL
17337: ADD GTNDF,GTNSC INCREMENT SCALE IF AFTER DEC POINT
17338: MNZ GTNRD SET DIGIT FOUND FLAG
17339: BCT WA,GTN10 LOOP BACK IF MORE CHARS
17340: BRN GTN22 ELSE JUMP TO SCALE
17341: EJC
17342: *
17343: * GTNUM (CONTINUED)
17344: *
17345: * HERE IF NON-DIGIT FOUND WHILE COLLECTING A REAL
17346: *
17347: GTN12 BNE WB,=CH$DT,GTN13 JUMP IF NOT DEC POINT
17348: BNZ GTNDF,GTN36 IF DEC POINT, ERROR IF ONE ALREADY
17349: MOV =NUM01,GTNDF ELSE SET FLAG FOR DEC POINT
17350: BCT WA,GTN10 LOOP BACK IF MORE CHARS
17351: BRN GTN22 ELSE JUMP TO SCALE
17352: *
17353: * HERE IF NOT DECIMAL POINT
17354: *
17355: GTN13 BEQ WB,=CH$LE,GTN15 JUMP IF E FOR EXPONENT
17356: BEQ WB,=CH$LD,GTN15 JUMP IF D FOR EXPONENT
17357: .IF .CULC
17358: BEQ WB,=CH$$E,GTN15 JUMP IF E FOR EXPONENT
17359: BEQ WB,=CH$$D,GTN15 JUMP IF D FOR EXPONENT
17360: .FI
17361: *
17362: * HERE CHECK FOR TRAILING BLANKS
17363: *
17364: GTN14 BEQ WB,=CH$BL,GTNB4 JUMP IF BLANK
17365: .IF .CAHT
17366: BEQ WB,=CH$HT,GTNB4 JUMP IF HORIZONTAL TAB
17367: .FI
17368: .IF .CAVT
17369: BEQ WB,=CH$VT,GTNB4 JUMP IF VERTICAL TAB
17370: .FI
17371: BRN GTN36 ERROR IF NON-BLANK
17372: *
17373: GTNB4 LCH WB,(XR)+ GET NEXT CHARACTER
17374: BCT WA,GTN14 LOOP BACK TO CHECK IF MORE
17375: BRN GTN22 ELSE JUMP TO SCALE
17376: *
17377: * HERE TO READ AND PROCESS AN EXPONENT
17378: *
17379: GTN15 ZER GTNES SET EXPONENT SIGN POSITIVE
17380: LDI INTV0 INITIALIZE EXPONENT TO ZERO
17381: MNZ GTNDF RESET NO DEC POINT INDICATION
17382: BCT WA,GTN16 JUMP SKIPPING PAST E OR D
17383: BRN GTN36 ERROR IF NULL EXPONENT
17384: *
17385: * CHECK FOR EXPONENT SIGN
17386: *
17387: GTN16 LCH WB,(XR)+ LOAD FIRST EXPONENT CHARACTER
17388: BEQ WB,=CH$PL,GTN17 JUMP IF PLUS SIGN
17389: BNE WB,=CH$MN,GTN19 ELSE JUMP IF NOT MINUS SIGN
17390: MNZ GTNES SET SIGN NEGATIVE IF MINUS SIGN
17391: *
17392: * MERGE HERE AFTER PROCESSING EXPONENT SIGN
17393: *
17394: GTN17 BCT WA,GTN18 JUMP IF CHARS LEFT
17395: BRN GTN36 ELSE ERROR
17396: *
17397: * LOOP TO CONVERT EXPONENT DIGITS
17398: *
17399: GTN18 LCH WB,(XR)+ LOAD NEXT CHARACTER
17400: EJC
17401: *
17402: * GTNUM (CONTINUED)
17403: *
17404: * MERGE HERE FOR FIRST EXPONENT DIGIT
17405: *
17406: GTN19 BLT WB,=CH$D0,GTN20 JUMP IF NOT DIGIT
17407: BGT WB,=CH$D9,GTN20 JUMP IF NOT DIGIT
17408: CVM GTN36 ELSE CURRENT*10, SUBTRACT NEW DIGIT
17409: BCT WA,GTN18 LOOP BACK IF MORE CHARS
17410: BRN GTN21 JUMP IF EXPONENT FIELD IS EXHAUSTED
17411: *
17412: * HERE TO CHECK FOR TRAILING BLANKS AFTER EXPONENT
17413: *
17414: GTN20 BEQ WB,=CH$BL,GTNC0 JUMP IF BLANK
17415: .IF .CAHT
17416: BEQ WB,=CH$HT,GTNC0 JUMP IF HORIZONTAL TAB
17417: .FI
17418: .IF .CAVT
17419: BEQ WC,=CH$VT,GTNC0 JUMP IF VERTICAL TAB
17420: .FI
17421: BRN GTN36 ERROR IF NON-BLANK
17422: *
17423: GTNC0 LCH WB,(XR)+ GET NEXT CHARACTER
17424: BCT WA,GTN20 LOOP BACK TILL ALL BLANKS SCANNED
17425: *
17426: * MERGE HERE AFTER COLLECTING EXPONENT
17427: *
17428: GTN21 STI GTNEX SAVE COLLECTED EXPONENT
17429: BNZ GTNES,GTN22 JUMP IF IT WAS NEGATIVE
17430: NGI ELSE COMPLEMENT
17431: IOV GTN36 ERROR IF OVERFLOW
17432: STI GTNEX AND STORE POSITIVE EXPONENT
17433: *
17434: * MERGE HERE WITH EXPONENT (0 IF NONE GIVEN)
17435: *
17436: GTN22 BZE GTNRD,GTN36 ERROR IF NOT DIGITS COLLECTED
17437: BZE GTNDF,GTN36 ERROR IF NO EXPONENT OR DEC POINT
17438: MTI GTNSC ELSE LOAD SCALE AS INTEGER
17439: SBI GTNEX SUBTRACT EXPONENT
17440: IOV GTN36 ERROR IF OVERFLOW
17441: ILT GTN26 JUMP IF WE MUST SCALE UP
17442: *
17443: * HERE WE HAVE A NEGATIVE EXPONENT, SO SCALE DOWN
17444: *
17445: MFI WA,GTN36 LOAD SCALE FACTOR, ERR IF OVFLOW
17446: *
17447: * LOOP TO SCALE DOWN IN STEPS OF 10**10
17448: *
17449: GTN23 BLE WA,=NUM10,GTN24 JUMP IF 10 OR LESS TO GO
17450: DVR REATT ELSE DIVIDE BY 10**10
17451: SUB =NUM10,WA DECREMENT SCALE
17452: BRN GTN23 AND LOOP BACK
17453: EJC
17454: *
17455: * GTNUM (CONTINUED)
17456: *
17457: * HERE SCALE REST OF WAY FROM POWERS OF TEN TABLE
17458: *
17459: GTN24 BZE WA,GTN30 JUMP IF SCALED
17460: LCT WB,=CFP$R ELSE GET INDEXING FACTOR
17461: MOV =REAV1,XR POINT TO POWERS OF TEN TABLE
17462: WTB WA CONVERT REMAINING SCALE TO BYTE OFS
17463: *
17464: * LOOP TO POINT TO POWERS OF TEN TABLE ENTRY
17465: *
17466: GTN25 ADD WA,XR BUMP POINTER
17467: BCT WB,GTN25 ONCE FOR EACH VALUE WORD
17468: DVR (XR) SCALE DOWN AS REQUIRED
17469: BRN GTN30 AND JUMP
17470: *
17471: * COME HERE TO SCALE RESULT UP (POSITIVE EXPONENT)
17472: *
17473: GTN26 NGI GET ABSOLUTE VALUE OF EXPONENT
17474: IOV GTN36 ERROR IF OVERFLOW
17475: MFI WA,GTN36 ACQUIRE SCALE, ERROR IF OVFLOW
17476: *
17477: * LOOP TO SCALE UP IN STEPS OF 10**10
17478: *
17479: GTN27 BLE WA,=NUM10,GTN28 JUMP IF 10 OR LESS TO GO
17480: MLR REATT ELSE MULTIPLY BY 10**10
17481: ROV GTN36 ERROR IF OVERFLOW
17482: SUB =NUM10,WA ELSE DECREMENT SCALE
17483: BRN GTN27 AND LOOP BACK
17484: *
17485: * HERE TO SCALE UP REST OF WAY WITH TABLE
17486: *
17487: GTN28 BZE WA,GTN30 JUMP IF SCALED
17488: LCT WB,=CFP$R ELSE GET INDEXING FACTOR
17489: MOV =REAV1,XR POINT TO POWERS OF TEN TABLE
17490: WTB WA CONVERT REMAINING SCALE TO BYTE OFS
17491: *
17492: * LOOP TO POINT TO PROPER ENTRY IN POWERS OF TEN TABLE
17493: *
17494: GTN29 ADD WA,XR BUMP POINTER
17495: BCT WB,GTN29 ONCE FOR EACH WORD IN VALUE
17496: MLR (XR) SCALE UP
17497: ROV GTN36 ERROR IF OVERFLOW
17498: EJC
17499: *
17500: * GTNUM (CONTINUED)
17501: *
17502: * HERE WITH REAL VALUE SCALED AND READY EXCEPT FOR SIGN
17503: *
17504: GTN30 BZE GTNNF,GTN31 JUMP IF POSITIVE
17505: NGR ELSE NEGATE
17506: *
17507: * HERE WITH PROPERLY SIGNED REAL VALUE IN (RA)
17508: *
17509: GTN31 JSR RCBLD BUILD REAL BLOCK
17510: BRN GTN33 MERGE TO EXIT
17511: .FI
17512: *
17513: * HERE WITH PROPERLY SIGNED INTEGER VALUE IN (IA)
17514: *
17515: GTN32 JSR ICBLD BUILD ICBLK
17516: *
17517: * REAL MERGES HERE
17518: *
17519: GTN33 MOV (XR),WA LOAD FIRST WORD OF RESULT BLOCK
17520: ICA XS POP ARGUMENT OFF STACK
17521: *
17522: * COMMON EXIT POINT
17523: *
17524: GTN34 EXI RETURN TO GTNUM CALLER
17525: .IF .CNRA
17526: .ELSE
17527: *
17528: * COME HERE IF OVERFLOW OCCURS DURING COLLECTION OF INTEGER
17529: *
17530: GTN35 LDI GTNSI RELOAD INTEGER SO FAR
17531: ITR CONVERT TO REAL
17532: NGR MAKE VALUE POSITIVE
17533: BRN GTN11 MERGE WITH REAL CIRCUIT
17534: .FI
17535: *
17536: * HERE FOR UNCONVERTIBLE TO STRING OR CONVERSION ERROR
17537: *
17538: GTN36 MOV (XS)+,XR RELOAD ORIGINAL ARGUMENT
17539: EXI 1 TAKE CONVERT-ERROR EXIT
17540: ENP END PROCEDURE GTNUM
17541: EJC
17542: *
17543: * GTNVR -- CONVERT TO NATURAL VARIABLE
17544: *
17545: * GTNVR LOCATES A VARIABLE BLOCK (VRBLK) GIVEN EITHER AN
17546: * APPROPRIATE NAME (NMBLK) OR A NON-NULL STRING (SCBLK).
17547: *
17548: * (XR) ARGUMENT
17549: * JSR GTNVR CALL TO CONVERT TO NATURAL VARIABLE
17550: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
17551: * (XR) POINTER TO VRBLK
17552: * (WA,WB) DESTROYED (CONVERSION ERROR ONLY)
17553: * (WC) DESTROYED
17554: *
17555: GTNVR PRC E,1 ENTRY POINT
17556: BNE (XR),=B$NML,GNV02 JUMP IF NOT NAME
17557: MOV NMBAS(XR),XR ELSE LOAD NAME BASE IF NAME
17558: BLO XR,STATE,GNV07 SKIP IF VRBLK (IN STATIC REGION)
17559: *
17560: * COMMON ERROR EXIT
17561: *
17562: GNV01 EXI 1 TAKE CONVERT-ERROR EXIT
17563: *
17564: * HERE IF NOT NAME
17565: *
17566: GNV02 MOV WA,GNVSA SAVE WA
17567: MOV WB,GNVSB SAVE WB
17568: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG
17569: JSR GTSTG CONVERT ARGUMENT TO STRING
17570: PPM GNV01 JUMP IF CONVERSION ERROR
17571: BZE WA,GNV01 NULL STRING IS AN ERROR
17572: .IF .CULC
17573: JSR FLSTG FOLD LOWER CASE TO UPPER CASE
17574: .FI
17575: MOV XL,-(XS) SAVE XL
17576: MOV XR,-(XS) STACK STRING PTR FOR LATER
17577: MOV XR,WB COPY STRING POINTER
17578: ADD *SCHAR,WB POINT TO CHARACTERS OF STRING
17579: MOV WB,GNVST SAVE POINTER TO CHARACTERS
17580: MOV WA,WB COPY LENGTH
17581: CTW WB,0 GET NUMBER OF WORDS IN NAME
17582: MOV WB,GNVNW SAVE FOR LATER
17583: JSR HASHS COMPUTE HASH INDEX FOR STRING
17584: RMI HSHNB COMPUTE HASH OFFSET BY TAKING MOD
17585: MFI WC GET AS OFFSET
17586: WTB WC CONVERT OFFSET TO BYTES
17587: ADD HSHTB,WC POINT TO PROPER HASH CHAIN
17588: SUB *VRNXT,WC SUBTRACT OFFSET TO MERGE INTO LOOP
17589: EJC
17590: *
17591: * GTNVR (CONTINUED)
17592: *
17593: * LOOP TO SEARCH HASH CHAIN
17594: *
17595: GNV03 MOV WC,XL COPY HASH CHAIN POINTER
17596: MOV VRNXT(XL),XL POINT TO NEXT VRBLK ON CHAIN
17597: BZE XL,GNV08 JUMP IF END OF CHAIN
17598: MOV XL,WC SAVE POINTER TO THIS VRBLK
17599: BNZ VRLEN(XL),GNV04 JUMP IF NOT SYSTEM VARIABLE
17600: MOV VRSVP(XL),XL ELSE POINT TO SVBLK
17601: SUB *VRSOF,XL ADJUST OFFSET FOR MERGE
17602: *
17603: * MERGE HERE WITH STRING PTR (LIKE VRBLK) IN XL
17604: *
17605: GNV04 BNE WA,VRLEN(XL),GNV03 BACK FOR NEXT VRBLK IF LENGTHS NE
17606: ADD *VRCHS,XL ELSE POINT TO CHARS OF CHAIN ENTRY
17607: LCT WB,GNVNW GET WORD COUNTER TO CONTROL LOOP
17608: MOV GNVST,XR POINT TO CHARS OF NEW NAME
17609: *
17610: * LOOP TO COMPARE CHARACTERS OF THE TWO NAMES
17611: *
17612: GNV05 CNE (XR),(XL),GNV03 JUMP IF NO MATCH FOR NEXT VRBLK
17613: ICA XR BUMP NEW NAME POINTER
17614: ICA XL BUMP VRBLK IN CHAIN NAME POINTER
17615: BCT WB,GNV05 ELSE LOOP TILL ALL COMPARED
17616: MOV WC,XR WE HAVE FOUND A MATCH, GET VRBLK
17617: *
17618: * EXIT POINT AFTER FINDING VRBLK OR BUILDING NEW ONE
17619: *
17620: GNV06 MOV GNVSA,WA RESTORE WA
17621: MOV GNVSB,WB RESTORE WB
17622: ICA XS POP STRING POINTER
17623: MOV (XS)+,XL RESTORE XL
17624: *
17625: * COMMON EXIT POINT
17626: *
17627: GNV07 EXI RETURN TO GTNVR CALLER
17628: *
17629: * NOT FOUND, PREPARE TO SEARCH SYSTEM VARIABLE TABLE
17630: *
17631: GNV08 ZER XR CLEAR GARBAGE XR POINTER
17632: MOV WC,GNVHE SAVE PTR TO END OF HASH CHAIN
17633: BGT WA,=NUM09,GNV14 CANNOT BE SYSTEM VAR IF LENGTH GT 9
17634: MOV WA,XL ELSE COPY LENGTH
17635: WTB XL CONVERT TO BYTE OFFSET
17636: MOV VSRCH(XL),XL POINT TO FIRST SVBLK OF THIS LENGTH
17637: EJC
17638: *
17639: * GTNVR (CONTINUED)
17640: *
17641: * LOOP TO SEARCH ENTRIES IN STANDARD VARIABLE TABLE
17642: *
17643: GNV09 MOV XL,GNVSP SAVE TABLE POINTER
17644: MOV (XL)+,WC LOAD SVBIT BIT STRING
17645: MOV (XL)+,WB LOAD LENGTH FROM TABLE ENTRY
17646: BNE WA,WB,GNV14 JUMP IF END OF RIGHT LENGTH ENTIRES
17647: LCT WB,GNVNW GET WORD COUNTER TO CONTROL LOOP
17648: MOV GNVST,XR POINT TO CHARS OF NEW NAME
17649: *
17650: * LOOP TO CHECK FOR MATCHING NAMES
17651: *
17652: GNV10 CNE (XR),(XL),GNV11 JUMP IF NAME MISMATCH
17653: ICA XR ELSE BUMP NEW NAME POINTER
17654: ICA XL BUMP SVBLK POINTER
17655: BCT WB,GNV10 ELSE LOOP UNTIL ALL CHECKED
17656: *
17657: * HERE WE HAVE A MATCH IN THE STANDARD VARIABLE TABLE
17658: *
17659: ZER WC SET VRLEN VALUE ZERO
17660: MOV *VRSI$,WA SET STANDARD SIZE
17661: BRN GNV15 JUMP TO BUILD VRBLK
17662: *
17663: * HERE IF NO MATCH WITH TABLE ENTRY IN SVBLKS TABLE
17664: *
17665: GNV11 ICA XL BUMP PAST WORD OF CHARS
17666: BCT WB,GNV11 LOOP BACK IF MORE TO GO
17667: RSH WC,SVNBT REMOVE UNINTERESTING BITS
17668: *
17669: * LOOP TO BUMP TABLE PTR FOR EACH FLAGGED WORD
17670: *
17671: GNV12 MOV BITS1,WB LOAD BIT TO TEST
17672: ANB WC,WB TEST FOR WORD PRESENT
17673: ZRB WB,GNV13 JUMP IF NOT PRESENT
17674: ICA XL ELSE BUMP TABLE POINTER
17675: *
17676: * HERE AFTER DEALING WITH ONE WORD (ONE BIT)
17677: *
17678: GNV13 RSH WC,1 REMOVE BIT ALREADY PROCESSED
17679: NZB WC,GNV12 LOOP BACK IF MORE BITS TO TEST
17680: BRN GNV09 ELSE LOOP BACK FOR NEXT SVBLK
17681: *
17682: * HERE IF NOT SYSTEM VARIABLE
17683: *
17684: GNV14 MOV WA,WC COPY VRLEN VALUE
17685: MOV =VRCHS,WA LOAD STANDARD SIZE -CHARS
17686: ADD GNVNW,WA ADJUST FOR CHARS OF NAME
17687: WTB WA CONVERT LENGTH TO BYTES
17688: EJC
17689: *
17690: * GTNVR (CONTINUED)
17691: *
17692: * MERGE HERE TO BUILD VRBLK
17693: *
17694: GNV15 JSR ALOST ALLOCATE SPACE FOR VRBLK (STATIC)
17695: MOV XR,WB SAVE VRBLK POINTER
17696: MOV =STNVR,XL POINT TO MODEL VARIABLE BLOCK
17697: MOV *VRLEN,WA SET LENGTH OF STANDARD FIELDS
17698: MVW SET INITIAL FIELDS OF NEW BLOCK
17699: MOV GNVHE,XL LOAD POINTER TO END OF HASH CHAIN
17700: MOV WB,VRNXT(XL) ADD NEW BLOCK TO END OF CHAIN
17701: MOV WC,(XR)+ SET VRLEN FIELD, BUMP PTR
17702: MOV GNVNW,WA GET LENGTH IN WORDS
17703: WTB WA CONVERT TO LENGTH IN BYTES
17704: BZE WC,GNV16 JUMP IF SYSTEM VARIABLE
17705: *
17706: * HERE FOR NON-SYSTEM VARIABLE -- SET CHARS OF NAME
17707: *
17708: MOV (XS),XL POINT BACK TO STRING NAME
17709: ADD *SCHAR,XL POINT TO CHARS OF NAME
17710: MVW MOVE CHARACTERS INTO PLACE
17711: MOV WB,XR RESTORE VRBLK POINTER
17712: BRN GNV06 JUMP BACK TO EXIT
17713: *
17714: * HERE FOR SYSTEM VARIABLE CASE TO FILL IN FIELDS WHERE
17715: * NECESSARY FROM THE FIELDS PRESENT IN THE SVBLK.
17716: *
17717: GNV16 MOV GNVSP,XL LOAD POINTER TO SVBLK
17718: MOV XL,(XR) SET SVBLK PTR IN VRBLK
17719: MOV WB,XR RESTORE VRBLK POINTER
17720: MOV SVBIT(XL),WB LOAD BIT INDICATORS
17721: ADD *SVCHS,XL POINT TO CHARACTERS OF NAME
17722: ADD WA,XL POINT PAST CHARACTERS
17723: *
17724: * SKIP PAST KEYWORD NUMBER (SVKNM) IF PRESENT
17725: *
17726: MOV BTKNM,WC LOAD TEST BIT
17727: ANB WB,WC AND TO TEST
17728: ZRB WC,GNV17 JUMP IF NO KEYWORD NUMBER
17729: ICA XL ELSE BUMP POINTER
17730: EJC
17731: *
17732: * GTNVR (CONTINUED)
17733: *
17734: * HERE TEST FOR FUNCTION (SVFNC AND SVNAR)
17735: *
17736: GNV17 MOV BTFNC,WC GET TEST BIT
17737: ANB WB,WC AND TO TEST
17738: ZRB WC,GNV18 SKIP IF NO SYSTEM FUNCTION
17739: MOV XL,VRFNC(XR) ELSE POINT VRFNC TO SVFNC FIELD
17740: ADD *NUM02,XL AND BUMP PAST SVFNC, SVNAR FIELDS
17741: *
17742: * NOW TEST FOR LABEL (SVLBL)
17743: *
17744: GNV18 MOV BTLBL,WC GET TEST BIT
17745: ANB WB,WC AND TO TEST
17746: ZRB WC,GNV19 JUMP IF BIT IS OFF (NO SYSTEM LABL)
17747: MOV XL,VRLBL(XR) ELSE POINT VRLBL TO SVLBL FIELD
17748: ICA XL BUMP PAST SVLBL FIELD
17749: *
17750: * NOW TEST FOR VALUE (SVVAL)
17751: *
17752: GNV19 MOV BTVAL,WC LOAD TEST BIT
17753: ANB WB,WC AND TO TEST
17754: ZRB WC,GNV06 ALL DONE IF NO VALUE
17755: MOV (XL),VRVAL(XR) ELSE SET INITIAL VALUE
17756: MOV =B$VRE,VRSTO(XR) SET ERROR STORE ACCESS
17757: BRN GNV06 MERGE BACK TO EXIT TO CALLER
17758: ENP END PROCEDURE GTNVR
17759: EJC
17760: *
17761: * GTPAT -- GET PATTERN
17762: *
17763: * GTPAT IS PASSED AN OBJECT IN (XR) AND RETURNS A
17764: * PATTERN AFTER PERFORMING ANY NECESSARY CONVERSIONS
17765: *
17766: * (XR) INPUT ARGUMENT
17767: * JSR GTPAT CALL TO CONVERT TO PATTERN
17768: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
17769: * (XR) RESULTING PATTERN
17770: * (WA) DESTROYED
17771: * (WB) DESTROYED (ONLY ON CONVERT ERROR)
17772: * (XR) UNCHANGED (ONLY ON CONVERT ERROR)
17773: *
17774: GTPAT PRC E,1 ENTRY POINT
17775: BHI (XR),=P$AAA,GTPT5 JUMP IF PATTERN ALREADY
17776: *
17777: * HERE IF NOT PATTERN, TRY FOR STRING
17778: *
17779: MOV WB,GTPSB SAVE WB
17780: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG
17781: JSR GTSTG CONVERT ARGUMENT TO STRING
17782: PPM GTPT2 JUMP IF IMPOSSIBLE
17783: *
17784: * HERE WE HAVE A STRING
17785: *
17786: BNZ WA,GTPT1 JUMP IF NON-NULL
17787: *
17788: * HERE FOR NULL STRING. GENERATE POINTER TO NULL PATTERN.
17789: *
17790: MOV =NDNTH,XR POINT TO NOTHEN NODE
17791: BRN GTPT4 JUMP TO EXIT
17792: EJC
17793: *
17794: * GTPAT (CONTINUED)
17795: *
17796: * HERE FOR NON-NULL STRING
17797: *
17798: GTPT1 MOV =P$STR,WB LOAD PCODE FOR MULTI-CHAR STRING
17799: BNE WA,=NUM01,GTPT3 JUMP IF MULTI-CHAR STRING
17800: *
17801: * HERE FOR ONE CHARACTER STRING, SHARE ONE CHARACTER ANY
17802: *
17803: PLC XR POINT TO CHARACTER
17804: LCH WA,(XR) LOAD CHARACTER
17805: MOV WA,XR SET AS PARM1
17806: MOV =P$ANS,WB POINT TO PCODE FOR 1-CHAR ANY
17807: BRN GTPT3 JUMP TO BUILD NODE
17808: *
17809: * HERE IF ARGUMENT IS NOT CONVERTIBLE TO STRING
17810: *
17811: GTPT2 MOV =P$EXA,WB SET PCODE FOR EXPRESSION IN CASE
17812: BLO (XR),=B$E$$,GTPT3 JUMP TO BUILD NODE IF EXPRESSION
17813: *
17814: * HERE WE HAVE AN ERROR (CONVERSION IMPOSSIBLE)
17815: *
17816: EXI 1 TAKE CONVERT ERROR EXIT
17817: *
17818: * MERGE HERE TO BUILD NODE FOR STRING OR EXPRESSION
17819: *
17820: GTPT3 JSR PBILD CALL ROUTINE TO BUILD PATTERN NODE
17821: *
17822: * COMMON EXIT AFTER SUCCESSFUL CONVERSION
17823: *
17824: GTPT4 MOV GTPSB,WB RESTORE WB
17825: *
17826: * MERGE HERE TO EXIT OF NO CONVERSION REQUIRED
17827: *
17828: GTPT5 EXI RETURN TO GTPAT CALLER
17829: ENP END PROCEDURE GTPAT
17830: .IF .CNRA
17831: .ELSE
17832: EJC
17833: *
17834: * GTREA -- GET REAL VALUE
17835: *
17836: * GTREA IS PASSED AN OBJECT AND RETURNS A REAL VALUE
17837: * PERFORMING ANY NECESSARY CONVERSIONS.
17838: *
17839: * (XR) OBJECT TO BE CONVERTED
17840: * JSR GTREA CALL TO CONVERT OBJECT TO REAL
17841: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
17842: * (XR) POINTER TO RESULTING REAL
17843: * (WA,WB,WC,RA) DESTROYED
17844: * (XR) UNCHANGED (CONVERT ERROR ONLY)
17845: *
17846: GTREA PRC E,1 ENTRY POINT
17847: MOV (XR),WA GET FIRST WORD OF BLOCK
17848: BEQ WA,=B$RCL,GTRE2 JUMP IF REAL
17849: JSR GTNUM ELSE CONVERT ARGUMENT TO NUMERIC
17850: PPM GTRE3 JUMP IF UNCONVERTIBLE
17851: BEQ WA,=B$RCL,GTRE2 JUMP IF REAL WAS RETURNED
17852: *
17853: * HERE FOR CASE OF AN INTEGER TO CONVERT TO REAL
17854: *
17855: GTRE1 LDI ICVAL(XR) LOAD INTEGER
17856: ITR CONVERT TO REAL
17857: JSR RCBLD BUILD RCBLK
17858: *
17859: * EXIT WITH REAL
17860: *
17861: GTRE2 EXI RETURN TO GTREA CALLER
17862: *
17863: * HERE ON CONVERSION ERROR
17864: *
17865: GTRE3 EXI 1 TAKE CONVERT ERROR EXIT
17866: ENP END PROCEDURE GTREA
17867: .FI
17868: EJC
17869: *
17870: * GTSMI -- GET SMALL INTEGER
17871: *
17872: * GTSMI IS PASSED A SNOBOL OBJECT AND RETURNS AN ADDRESS
17873: * INTEGER IN THE RANGE (0 LE N LE DNAMB). SUCH A VALUE CAN
17874: * ONLY BE DERIVED FROM AN INTEGER IN THE APPROPRIATE RANGE.
17875: * SMALL INTEGERS NEVER APPEAR AS SNOBOL VALUES. HOWEVER,
17876: * THEY ARE USED INTERNALLY FOR A VARIETY OF PURPOSES.
17877: *
17878: * -(XS) ARGUMENT TO CONVERT (ON STACK)
17879: * JSR GTSMI CALL TO CONVERT TO SMALL INTEGER
17880: * PPM LOC TRANSFER LOC FOR NOT INTEGER
17881: * PPM LOC TRANSFER LOC FOR LT 0, GT DNAMB
17882: * (XR,WC) RESULTING SMALL INT (TWO COPIES)
17883: * (XS) POPPED
17884: * (RA) DESTROYED
17885: * (WA,WB) DESTROYED (ON CONVERT ERROR ONLY)
17886: * (XR) INPUT ARG (CONVERT ERROR ONLY)
17887: *
17888: GTSMI PRC N,2 ENTRY POINT
17889: MOV (XS)+,XR LOAD ARGUMENT
17890: BEQ (XR),=B$ICL,GTSM1 SKIP IF ALREADY AN INTEGER
17891: *
17892: * HERE IF NOT AN INTEGER
17893: *
17894: JSR GTINT CONVERT ARGUMENT TO INTEGER
17895: PPM GTSM2 JUMP IF CONVERT IS IMPOSSIBLE
17896: *
17897: * MERGE HERE WITH INTEGER
17898: *
17899: GTSM1 LDI ICVAL(XR) LOAD INTEGER VALUE
17900: MFI WC,GTSM3 MOVE AS ONE WORD, JUMP IF OVFLOW
17901: BGT WC,MXLEN,GTSM3 OR IF TOO SMALL
17902: MOV WC,XR COPY RESULT TO XR
17903: EXI RETURN TO GTSMI CALLER
17904: *
17905: * HERE IF UNCONVERTIBLE TO INTEGER
17906: *
17907: GTSM2 EXI 1 TAKE NON-INTEGER ERROR EXIT
17908: *
17909: * HERE IF OUT OF RANGE
17910: *
17911: GTSM3 EXI 2 TAKE OUT-OF-RANGE ERROR EXIT
17912: ENP END PROCEDURE GTSMI
17913: EJC
17914: *
17915: * GTSTG -- GET STRING
17916: *
17917: * GTSTG IS PASSED AN OBJECT AND RETURNS A STRING WITH
17918: * ANY NECESSARY CONVERSIONS PERFORMED.
17919: *
17920: * -(XS) INPUT ARGUMENT (ON STACK)
17921: * JSR GTSTG CALL TO CONVERT TO STRING
17922: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
17923: * (XR) POINTER TO RESULTING STRING
17924: * (WA) LENGTH OF STRING IN CHARACTERS
17925: * (XS) POPPED
17926: * (RA) DESTROYED
17927: * (XR) INPUT ARG (CONVERT ERROR ONLY)
17928: *
17929: GTSTG PRC N,1 ENTRY POINT
17930: MOV (XS)+,XR LOAD ARGUMENT, POP STACK
17931: BEQ (XR),=B$SCL,GTS30 JUMP IF ALREADY A STRING
17932: *
17933: * HERE IF NOT A STRING ALREADY
17934: *
17935: GTS01 MOV XR,-(XS) RESTACK ARGUMENT IN CASE ERROR
17936: MOV XL,-(XS) SAVE XL
17937: MOV WB,GTSVB SAVE WB
17938: MOV WC,GTSVC SAVE WC
17939: MOV (XR),WA LOAD FIRST WORD OF BLOCK
17940: BEQ WA,=B$ICL,GTS05 JUMP TO CONVERT INTEGER
17941: .IF .CNRA
17942: .ELSE
17943: BEQ WA,=B$RCL,GTS10 JUMP TO CONVERT REAL
17944: .FI
17945: BEQ WA,=B$NML,GTS03 JUMP TO CONVERT NAME
17946: .IF .CNBF
17947: .ELSE
17948: BEQ WA,=B$BCT,GTS32 JUMP TO CONVERT BUFFER
17949: .FI
17950: *
17951: * HERE ON CONVERSION ERROR
17952: *
17953: GTS02 MOV (XS)+,XL RESTORE XL
17954: MOV (XS)+,XR RELOAD INPUT ARGUMENT
17955: EXI 1 TAKE CONVERT ERROR EXIT
17956: EJC
17957: *
17958: * GTSTG (CONTINUED)
17959: *
17960: * HERE TO CONVERT A NAME (ONLY POSSIBLE IF NATURAL VAR)
17961: *
17962: GTS03 MOV NMBAS(XR),XL LOAD NAME BASE
17963: BHI XL,STATE,GTS02 ERROR IF NOT NATURAL VAR (STATIC)
17964: ADD *VRSOF,XL ELSE POINT TO POSSIBLE STRING NAME
17965: MOV SCLEN(XL),WA LOAD LENGTH
17966: BNZ WA,GTS04 JUMP IF NOT SYSTEM VARIABLE
17967: MOV VRSVO(XL),XL ELSE POINT TO SVBLK
17968: MOV SVLEN(XL),WA AND LOAD NAME LENGTH
17969: *
17970: * MERGE HERE WITH STRING IN XR, LENGTH IN WA
17971: *
17972: GTS04 ZER WB SET OFFSET TO ZERO
17973: JSR SBSTR USE SBSTR TO COPY STRING
17974: BRN GTS29 JUMP TO EXIT
17975: *
17976: * COME HERE TO CONVERT AN INTEGER
17977: *
17978: GTS05 LDI ICVAL(XR) LOAD INTEGER VALUE
17979: .IF .CNCI
17980: JSR SYSCI CONVERT INTEGER
17981: MOV SCLEN(XL),WA GET LENGTH
17982: ZER WB ZERO OFFSET FOR SBSTR
17983: JSR SBSTR COPY IN RESULT FROM SYSCI
17984: BRN GTS29 EXIT
17985: .ELSE
17986: MOV =NUM01,GTSSF SET SIGN FLAG NEGATIVE
17987: ILT GTS06 SKIP IF INTEGER IS NEGATIVE
17988: NGI ELSE NEGATE INTEGER
17989: ZER GTSSF AND RESET NEGATIVE FLAG
17990: EJC
17991: *
17992: * GTSTG (CONTINUED)
17993: *
17994: * HERE WITH SIGN FLAG SET AND SIGN FORCED NEGATIVE AS
17995: * REQUIRED BY THE CVD INSTRUCTION.
17996: *
17997: GTS06 MOV GTSWK,XR POINT TO RESULT WORK AREA
17998: MOV =NSTMX,WB INITIALIZE COUNTER TO MAX LENGTH
17999: PSC XR,WB PREPARE TO STORE (RIGHT-LEFT)
18000: *
18001: * LOOP TO CONVERT DIGITS INTO WORK AREA
18002: *
18003: GTS07 CVD CONVERT ONE DIGIT INTO WA
18004: SCH WA,-(XR) STORE IN WORK AREA
18005: DCV WB DECREMENT COUNTER
18006: INE GTS07 LOOP IF MORE DIGITS TO GO
18007: CSC XR COMPLETE STORE CHARACTERS
18008: .FI
18009: *
18010: * MERGE HERE AFTER CONVERTING INTEGER OR REAL INTO WORK
18011: * AREA. WB IS SET TO NSTMX - (NUMBER OF CHARS IN RESULT).
18012: *
18013: GTS08 MOV =NSTMX,WA GET MAX NUMBER OF CHARACTERS
18014: SUB WB,WA COMPUTE LENGTH OF RESULT
18015: MOV WA,XL REMEMBER LENGTH FOR MOVE LATER ON
18016: ADD GTSSF,WA ADD ONE FOR NEGATIVE SIGN IF NEEDED
18017: JSR ALOCS ALLOCATE STRING FOR RESULT
18018: MOV XR,WC SAVE RESULT POINTER FOR THE MOMENT
18019: PSC XR POINT TO CHARS OF RESULT BLOCK
18020: BZE GTSSF,GTS09 SKIP IF POSITIVE
18021: MOV =CH$MN,WA ELSE LOAD NEGATIVE SIGN
18022: SCH WA,(XR)+ AND STORE IT
18023: CSC XR COMPLETE STORE CHARACTERS
18024: *
18025: * HERE AFTER DEALING WITH SIGN
18026: *
18027: GTS09 MOV XL,WA RECALL LENGTH TO MOVE
18028: MOV GTSWK,XL POINT TO RESULT WORK AREA
18029: PLC XL,WB POINT TO FIRST RESULT CHARACTER
18030: MVC MOVE CHARS TO RESULT STRING
18031: MOV WC,XR RESTORE RESULT POINTER
18032: .IF .CNRA
18033: .ELSE
18034: BRN GTS29 JUMP TO EXIT
18035: EJC
18036: *
18037: * GTSTG (CONTINUED)
18038: *
18039: * HERE TO CONVERT A REAL
18040: *
18041: GTS10 LDR RCVAL(XR) LOAD REAL
18042: ZER GTSSF RESET NEGATIVE FLAG
18043: REQ GTS31 SKIP IF ZERO
18044: RGE GTS11 JUMP IF REAL IS POSITIVE
18045: MOV =NUM01,GTSSF ELSE SET NEGATIVE FLAG
18046: NGR AND GET ABSOLUTE VALUE OF REAL
18047: *
18048: * NOW SCALE THE REAL TO THE RANGE (0.1 LE X LT 1.0)
18049: *
18050: GTS11 LDI INTV0 INITIALIZE EXPONENT TO ZERO
18051: *
18052: * LOOP TO SCALE UP IN STEPS OF 10**10
18053: *
18054: GTS12 STR GTSRS SAVE REAL VALUE
18055: SBR REAP1 SUBTRACT 0.1 TO COMPARE
18056: RGE GTS13 JUMP IF SCALE UP NOT REQUIRED
18057: LDR GTSRS ELSE RELOAD VALUE
18058: MLR REATT MULTIPLY BY 10**10
18059: SBI INTVT DECREMENT EXPONENT BY 10
18060: BRN GTS12 LOOP BACK TO TEST AGAIN
18061: *
18062: * TEST FOR SCALE DOWN REQUIRED
18063: *
18064: GTS13 LDR GTSRS RELOAD VALUE
18065: SBR REAV1 SUBTRACT 1.0
18066: RLT GTS17 JUMP IF NO SCALE DOWN REQUIRED
18067: LDR GTSRS ELSE RELOAD VALUE
18068: *
18069: * LOOP TO SCALE DOWN IN STEPS OF 10**10
18070: *
18071: GTS14 SBR REATT SUBTRACT 10**10 TO COMPARE
18072: RLT GTS15 JUMP IF LARGE STEP NOT REQUIRED
18073: LDR GTSRS ELSE RESTORE VALUE
18074: DVR REATT DIVIDE BY 10**10
18075: STR GTSRS STORE NEW VALUE
18076: ADI INTVT INCREMENT EXPONENT BY 10
18077: BRN GTS14 LOOP BACK
18078: EJC
18079: *
18080: * GTSTG (CONTINUED)
18081: *
18082: * AT THIS POINT WE HAVE (1.0 LE X LT 10**10)
18083: * COMPLETE SCALING WITH POWERS OF TEN TABLE
18084: *
18085: GTS15 MOV =REAV1,XR POINT TO POWERS OF TEN TABLE
18086: *
18087: * LOOP TO LOCATE CORRECT ENTRY IN TABLE
18088: *
18089: GTS16 LDR GTSRS RELOAD VALUE
18090: ADI INTV1 INCREMENT EXPONENT
18091: ADD *CFP$R,XR POINT TO NEXT ENTRY IN TABLE
18092: SBR (XR) SUBTRACT IT TO COMPARE
18093: RGE GTS16 LOOP TILL WE FIND A LARGER ENTRY
18094: LDR GTSRS THEN RELOAD THE VALUE
18095: DVR (XR) AND COMPLETE SCALING
18096: STR GTSRS STORE VALUE
18097: *
18098: * WE ARE NOW SCALED, SO ROUND BY ADDING 0.5 * 10**(-CFP$S)
18099: *
18100: GTS17 LDR GTSRS GET VALUE AGAIN
18101: ADR GTSRN ADD ROUNDING FACTOR
18102: STR GTSRS STORE RESULT
18103: *
18104: * THE ROUNDING OPERATION MAY HAVE PUSHED US UP PAST
18105: * 1.0 AGAIN, SO CHECK ONE MORE TIME.
18106: *
18107: SBR REAV1 SUBTRACT 1.0 TO COMPARE
18108: RLT GTS18 SKIP IF OK
18109: ADI INTV1 ELSE INCREMENT EXPONENT
18110: LDR GTSRS RELOAD VALUE
18111: DVR REAVT DIVIDE BY 10.0 TO RESCALE
18112: BRN GTS19 JUMP TO MERGE
18113: *
18114: * HERE IF ROUNDING DID NOT MUCK UP SCALING
18115: *
18116: GTS18 LDR GTSRS RELOAD ROUNDED VALUE
18117: EJC
18118: *
18119: * GTSTG (CONTINUED)
18120: *
18121: * NOW WE HAVE COMPLETED THE SCALING AS FOLLOWS
18122: *
18123: * (IA) SIGNED EXPONENT
18124: * (RA) SCALED REAL (ABSOLUTE VALUE)
18125: *
18126: * IF THE EXPONENT IS NEGATIVE OR GREATER THAN CFP$S, THEN
18127: * WE CONVERT THE NUMBER IN THE FORM.
18128: *
18129: * (NEG SIGN) 0 . (CPF$S DIGITS) E (EXP SIGN) (EXP DIGITS)
18130: *
18131: * IF THE EXPONENT IS POSITIVE AND LESS THAN OR EQUAL TO
18132: * CFP$S, THE NUMBER IS CONVERTED IN THE FORM.
18133: *
18134: * (NEG SIGN) (EXPONENT DIGITS) . (CFP$S-EXPONENT DIGITS)
18135: *
18136: * IN BOTH CASES, THE FORMATS OBTAINED FROM THE ABOVE
18137: * RULES ARE MODIFIED BY DELETING TRAILING ZEROS AFTER THE
18138: * DECIMAL POINT. THERE ARE NO LEADING ZEROS IN THE EXPONENT
18139: * AND THE EXPONENT SIGN IS ALWAYS PRESENT.
18140: *
18141: GTS19 MOV =CFP$S,XL SET NUM DEC DIGITS = CFP$S
18142: MOV =CH$MN,GTSES SET EXPONENT SIGN NEGATIVE
18143: ILT GTS21 ALL SET IF EXPONENT IS NEGATIVE
18144: MFI WA ELSE FETCH EXPONENT
18145: BLE WA,=CFP$S,GTS20 SKIP IF WE CAN USE SPECIAL FORMAT
18146: MTI WA ELSE RESTORE EXPONENT
18147: NGI SET NEGATIVE FOR CVD
18148: MOV =CH$PL,GTSES SET PLUS SIGN FOR EXPONENT SIGN
18149: BRN GTS21 JUMP TO GENERATE EXPONENT
18150: *
18151: * HERE IF WE CAN USE THE FORMAT WITHOUT AN EXPONENT
18152: *
18153: GTS20 SUB WA,XL COMPUTE DIGITS AFTER DECIMAL POINT
18154: LDI INTV0 RESET EXPONENT TO ZERO
18155: EJC
18156: *
18157: * GTSTG (CONTINUED)
18158: *
18159: * MERGE HERE AS FOLLOWS
18160: *
18161: * (IA) EXPONENT ABSOLUTE VALUE
18162: * GTSES CHARACTER FOR EXPONENT SIGN
18163: * (RA) POSITIVE FRACTION
18164: * (XL) NUMBER OF DIGITS AFTER DEC POINT
18165: *
18166: GTS21 MOV GTSWK,XR POINT TO WORK AREA
18167: MOV =NSTMX,WB SET CHARACTER CTR TO MAX LENGTH
18168: PSC XR,WB PREPARE TO STORE (RIGHT TO LEFT)
18169: IEQ GTS23 SKIP EXPONENT IF IT IS ZERO
18170: *
18171: * LOOP TO GENERATE DIGITS OF EXPONENT
18172: *
18173: GTS22 CVD CONVERT A DIGIT INTO WA
18174: SCH WA,-(XR) STORE IN WORK AREA
18175: DCV WB DECREMENT COUNTER
18176: INE GTS22 LOOP BACK IF MORE DIGITS TO GO
18177: *
18178: * HERE GENERATE EXPONENT SIGN AND E
18179: *
18180: MOV GTSES,WA LOAD EXPONENT SIGN
18181: SCH WA,-(XR) STORE IN WORK AREA
18182: MOV =CH$LE,WA GET CHARACTER LETTER E
18183: SCH WA,-(XR) STORE IN WORK AREA
18184: SUB =NUM02,WB DECREMENT COUNTER FOR SIGN AND E
18185: *
18186: * HERE TO GENERATE THE FRACTION
18187: *
18188: GTS23 MLR GTSSC CONVERT REAL TO INTEGER (10**CFP$S)
18189: RTI GET INTEGER (OVERFLOW IMPOSSIBLE)
18190: NGI NEGATE AS REQUIRED BY CVD
18191: *
18192: * LOOP TO SUPPRESS TRAILING ZEROS
18193: *
18194: GTS24 BZE XL,GTS27 JUMP IF NO DIGITS LEFT TO DO
18195: CVD ELSE CONVERT ONE DIGIT
18196: BNE WA,=CH$D0,GTS26 JUMP IF NOT A ZERO
18197: DCV XL DECREMENT COUNTER
18198: BRN GTS24 LOOP BACK FOR NEXT DIGIT
18199: EJC
18200: *
18201: * GTSTG (CONTINUED)
18202: *
18203: * LOOP TO GENERATE DIGITS AFTER DECIMAL POINT
18204: *
18205: GTS25 CVD CONVERT A DIGIT INTO WA
18206: *
18207: * MERGE HERE FIRST TIME
18208: *
18209: GTS26 SCH WA,-(XR) STORE DIGIT
18210: DCV WB DECREMENT COUNTER
18211: DCV XL DECREMENT COUNTER
18212: BNZ XL,GTS25 LOOP BACK IF MORE TO GO
18213: *
18214: * HERE GENERATE THE DECIMAL POINT
18215: *
18216: GTS27 MOV =CH$DT,WA LOAD DECIMAL POINT
18217: SCH WA,-(XR) STORE IN WORK AREA
18218: DCV WB DECREMENT COUNTER
18219: *
18220: * HERE GENERATE THE DIGITS BEFORE THE DECIMAL POINT
18221: *
18222: GTS28 CVD CONVERT A DIGIT INTO WA
18223: SCH WA,-(XR) STORE IN WORK AREA
18224: DCV WB DECREMENT COUNTER
18225: INE GTS28 LOOP BACK IF MORE TO GO
18226: CSC XR COMPLETE STORE CHARACTERS
18227: BRN GTS08 ELSE JUMP BACK TO EXIT
18228: .FI
18229: *
18230: * EXIT POINT AFTER SUCCESSFUL CONVERSION
18231: *
18232: GTS29 MOV (XS)+,XL RESTORE XL
18233: ICA XS POP ARGUMENT
18234: MOV GTSVB,WB RESTORE WB
18235: MOV GTSVC,WC RESTORE WC
18236: *
18237: * MERGE HERE IF NO CONVERSION REQUIRED
18238: *
18239: GTS30 MOV SCLEN(XR),WA LOAD STRING LENGTH
18240: EXI RETURN TO CALLER
18241: .IF .CNRA
18242: .ELSE
18243: *
18244: * HERE TO RETURN STRING FOR REAL ZERO
18245: *
18246: GTS31 MOV =SCRE0,XL POINT TO STRING
18247: MOV =NUM02,WA 2 CHARS
18248: ZER WB ZERO OFFSET
18249: JSR SBSTR COPY STRING
18250: BRN GTS29 RETURN
18251: .FI
18252: .IF .CNBF
18253: .ELSE
18254: EJC
18255: *
18256: * HERE TO CONVERT A BUFFER BLOCK
18257: *
18258: GTS32 MOV XR,XL COPY ARG PTR
18259: MOV BCLEN(XL),WA GET SIZE TO ALLOCATE
18260: BZE WA,GTS33 IF NULL THEN RETURN NULL
18261: JSR ALOCS ALLOCATE STRING FRAME
18262: MOV XR,WB SAVE STRING PTR
18263: MOV SCLEN(XR),WA GET LENGTH TO MOVE
18264: CTB WA,0 GET AS MULTIPLE OF WORD SIZE
18265: MOV BCBUF(XL),XL POINT TO BFBLK
18266: ADD *SCSI$,XR POINT TO START OF CHARACTER AREA
18267: ADD *BFSI$,XL POINT TO START OF BUFFER CHARS
18268: MVW COPY WORDS
18269: MOV WB,XR RESTORE SCBLK PTR
18270: BRN GTS29 EXIT WITH SCBLK
18271: *
18272: * HERE WHEN NULL BUFFER IS BEING CONVERTED
18273: *
18274: GTS33 MOV =NULLS,XR POINT TO NULL
18275: BRN GTS29 EXIT WITH NULL
18276: .FI
18277: ENP END PROCEDURE GTSTG
18278: EJC
18279: *
18280: * GTVAR -- GET VARIABLE FOR I/O/TRACE ASSOCIATION
18281: *
18282: * GTVAR IS USED TO POINT TO AN ACTUAL VARIABLE LOCATION
18283: * FOR THE DETACH,INPUT,OUTPUT,TRACE,STOPTR SYSTEM FUNCTIONS
18284: *
18285: * (XR) ARGUMENT TO FUNCTION
18286: * JSR GTVAR CALL TO LOCATE VARIABLE POINTER
18287: * PPM LOC TRANSFER LOC IF NOT OK VARIABLE
18288: * (XL,WA) NAME BASE,OFFSET OF VARIABLE
18289: * (XR,RA) DESTROYED
18290: * (WB,WC) DESTROYED (CONVERT ERROR ONLY)
18291: * (XR) INPUT ARG (CONVERT ERROR ONLY)
18292: *
18293: GTVAR PRC E,1 ENTRY POINT
18294: BNE (XR),=B$NML,GTVR2 JUMP IF NOT A NAME
18295: MOV NMOFS(XR),WA ELSE LOAD NAME OFFSET
18296: MOV NMBAS(XR),XL LOAD NAME BASE
18297: BEQ (XL),=B$EVT,GTVR1 ERROR IF EXPRESSION VARIABLE
18298: BNE (XL),=B$KVT,GTVR3 ALL OK IF NOT KEYWORD VARIABLE
18299: *
18300: * HERE ON CONVERSION ERROR
18301: *
18302: GTVR1 EXI 1 TAKE CONVERT ERROR EXIT
18303: *
18304: * HERE IF NOT A NAME, TRY CONVERT TO NATURAL VARIABLE
18305: *
18306: GTVR2 MOV WC,GTVRC SAVE WC
18307: JSR GTNVR LOCATE VRBLK IF POSSIBLE
18308: PPM GTVR1 JUMP IF CONVERT ERROR
18309: MOV XR,XL ELSE COPY VRBLK NAME BASE
18310: MOV *VRVAL,WA AND SET OFFSET
18311: MOV GTVRC,WC RESTORE WC
18312: *
18313: * HERE FOR NAME OBTAINED
18314: *
18315: GTVR3 BHI XL,STATE,GTVR4 ALL OK IF NOT NATURAL VARIABLE
18316: BEQ VRSTO(XL),=B$VRE,GTVR1 ERROR IF PROTECTED VARIABLE
18317: *
18318: * COMMON EXIT POINT
18319: *
18320: GTVR4 EXI RETURN TO CALLER
18321: ENP END PROCEDURE GTVAR
18322: EJC
18323: *
18324: * HASHS -- COMPUTE HASH INDEX FOR STRING
18325: *
18326: * HASHS IS USED TO CONVERT A STRING TO A UNIQUE INTEGER
18327: * VALUE. THE RESULTING HASH VALUE IS A POSITIVE INTEGER
18328: * IN THE RANGE 0 TO CFP$M
18329: *
18330: * (XR) STRING TO BE HASHED
18331: * JSR HASHS CALL TO HASH STRING
18332: * (IA) HASH VALUE
18333: * (XR,WB,WC) DESTROYED
18334: *
18335: * THE HASH FUNCTION USED IS AS FOLLOWS.
18336: *
18337: * START WITH THE LENGTH OF THE STRING (SGD07)
18338: *
18339: * TAKE THE FIRST E$HNW WORDS OF THE CHARACTERS FROM
18340: * THE STRING OR ALL THE WORDS IF FEWER THAN E$HNW.
18341: *
18342: * COMPUTE THE EXCLUSIVE OR OF ALL THESE WORDS TREATING
18343: * THEM AS ONE WORD BIT STRING VALUES.
18344: *
18345: * MOVE THE RESULT AS AN INTEGER WITH THE MTI INSTRUCTION.
18346: *
18347: HASHS PRC E,0 ENTRY POINT
18348: MOV SCLEN(XR),WC LOAD STRING LENGTH IN CHARACTERS
18349: MOV WC,WB INITIALIZE WITH LENGTH
18350: BZE WC,HSHS3 JUMP IF NULL STRING
18351: CTW WC,0 ELSE GET NUMBER OF WORDS OF CHARS
18352: ADD *SCHAR,XR POINT TO CHARACTERS OF STRING
18353: BLO WC,=E$HNW,HSHS1 USE WHOLE STRING IF SHORT
18354: MOV =E$HNW,WC ELSE SET TO INVOLVE FIRST E$HNW WDS
18355: *
18356: * HERE WITH COUNT OF WORDS TO CHECK IN WC
18357: *
18358: HSHS1 LCT WC,WC SET COUNTER TO CONTROL LOOP
18359: *
18360: * LOOP TO COMPUTE EXCLUSIVE OR
18361: *
18362: HSHS2 XOB (XR)+,WB EXCLUSIVE OR NEXT WORD OF CHARS
18363: BCT WC,HSHS2 LOOP TILL ALL PROCESSED
18364: *
18365: * MERGE HERE WITH EXCLUSIVE OR IN WB
18366: *
18367: HSHS3 ZGB WB ZEROISE UNDEFINED BITS
18368: ANB BITSM,WB ENSURE IN RANGE 0 TO CFP$M
18369: MTI WB MOVE RESULT AS INTEGER
18370: ZER XR CLEAR GARBAGE VALUE IN XR
18371: EXI RETURN TO HASHS CALLER
18372: ENP END PROCEDURE HASHS
18373: EJC
18374: *
18375: * ICBLD -- BUILD INTEGER BLOCK
18376: *
18377: * (IA) INTEGER VALUE FOR ICBLK
18378: * JSR ICBLD CALL TO BUILD INTEGER BLOCK
18379: * (XR) POINTER TO RESULT ICBLK
18380: * (WA) DESTROYED
18381: *
18382: ICBLD PRC E,0 ENTRY POINT
18383: MFI XR,ICBL1 COPY SMALL INTEGERS
18384: BLE XR,=NUM02,ICBL3 JUMP IF 0,1 OR 2
18385: *
18386: * CONSTRUCT ICBLK
18387: *
18388: ICBL1 MOV DNAMP,XR LOAD POINTER TO NEXT AVAILABLE LOC
18389: ADD *ICSI$,XR POINT PAST NEW ICBLK
18390: BLO XR,DNAME,ICBL2 JUMP IF THERE IS ROOM
18391: MOV *ICSI$,WA ELSE LOAD LENGTH OF ICBLK
18392: JSR ALLOC USE STANDARD ALLOCATOR TO GET BLOCK
18393: ADD WA,XR POINT PAST BLOCK TO MERGE
18394: *
18395: * MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED
18396: *
18397: ICBL2 MOV XR,DNAMP SET NEW POINTER
18398: SUB *ICSI$,XR POINT BACK TO START OF BLOCK
18399: MOV =B$ICL,(XR) STORE TYPE WORD
18400: STI ICVAL(XR) STORE INTEGER VALUE IN ICBLK
18401: EXI RETURN TO ICBLD CALLER
18402: *
18403: * OPTIMISE BY NOT BUILDING ICBLKS FOR SMALL INTEGERS
18404: *
18405: ICBL3 WTB XR CONVERT INTEGER TO OFFSET
18406: MOV INTAB(XR),XR POINT TO PRE-BUILT ICBLK
18407: EXI RETURN
18408: ENP END PROCEDURE ICBLD
18409: EJC
18410: *
18411: * IDENT -- COMPARE TWO VALUES
18412: *
18413: * IDENT COMPARES TWO VALUES IN THE SENSE OF THE IDENT
18414: * DIFFER FUNCTIONS AVAILABLE AT THE SNOBOL LEVEL.
18415: *
18416: * (XR) FIRST ARGUMENT
18417: * (XL) SECOND ARGUMENT
18418: * JSR IDENT CALL TO COMPARE ARGUMENTS
18419: * PPM LOC TRANSFER LOC IF IDENT
18420: * (NORMAL RETURN IF DIFFER)
18421: * (XR,XL,WC,RA) DESTROYED
18422: *
18423: IDENT PRC E,1 ENTRY POINT
18424: BEQ XR,XL,IDEN7 JUMP IF SAME POINTER (IDENT)
18425: MOV (XR),WC ELSE LOAD ARG 1 TYPE WORD
18426: BNE WC,(XL),IDEN1 DIFFER IF ARG 2 TYPE WORD DIFFER
18427: BEQ WC,=B$SCL,IDEN2 JUMP IF STRINGS
18428: BEQ WC,=B$ICL,IDEN4 JUMP IF INTEGERS
18429: .IF .CNRA
18430: .ELSE
18431: BEQ WC,=B$RCL,IDEN5 JUMP IF REALS
18432: .FI
18433: BEQ WC,=B$NML,IDEN6 JUMP IF NAMES
18434: *
18435: * FOR ALL OTHER DATATYPES, MUST BE DIFFER IF XR NE XL
18436: *
18437: * MERGE HERE FOR DIFFER
18438: *
18439: IDEN1 EXI TAKE DIFFER EXIT
18440: *
18441: * HERE FOR STRINGS, IDENT ONLY IF LENGTHS AND CHARS SAME
18442: *
18443: IDEN2 MOV SCLEN(XR),WC LOAD ARG 1 LENGTH
18444: BNE WC,SCLEN(XL),IDEN1 DIFFER IF LENGTHS DIFFER
18445: CTW WC,0 GET NUMBER OF WORDS IN STRINGS
18446: ADD *SCHAR,XR POINT TO CHARS OF ARG 1
18447: ADD *SCHAR,XL POINT TO CHARS OF ARG 2
18448: LCT WC,WC SET LOOP COUNTER
18449: *
18450: * LOOP TO COMPARE CHARACTERS. NOTE THAT WA CANNOT BE ZERO
18451: * SINCE ALL NULL STRINGS POINT TO NULLS AND GIVE XL=XR.
18452: *
18453: IDEN3 CNE (XR),(XL),IDEN8 DIFFER IF CHARS DO NOT MATCH
18454: ICA XR ELSE BUMP ARG ONE POINTER
18455: ICA XL BUMP ARG TWO POINTER
18456: BCT WC,IDEN3 LOOP BACK TILL ALL CHECKED
18457: EJC
18458: *
18459: * IDENT (CONTINUED)
18460: *
18461: * HERE TO EXIT FOR CASE OF TWO IDENT STRINGS
18462: *
18463: ZER XL CLEAR GARBAGE VALUE IN XL
18464: ZER XR CLEAR GARBAGE VALUE IN XR
18465: EXI 1 TAKE IDENT EXIT
18466: *
18467: * HERE FOR INTEGERS, IDENT IF SAME VALUES
18468: *
18469: IDEN4 LDI ICVAL(XR) LOAD ARG 1
18470: SBI ICVAL(XL) SUBTRACT ARG 2 TO COMPARE
18471: IOV IDEN1 DIFFER IF OVERFLOW
18472: INE IDEN1 DIFFER IF RESULT IS NOT ZERO
18473: EXI 1 TAKE IDENT EXIT
18474: .IF .CNRA
18475: .ELSE
18476: *
18477: * HERE FOR REALS, IDENT IF SAME VALUES
18478: *
18479: IDEN5 LDR RCVAL(XR) LOAD ARG 1
18480: SBR RCVAL(XL) SUBTRACT ARG 2 TO COMPARE
18481: ROV IDEN1 DIFFER IF OVERFLOW
18482: RNE IDEN1 DIFFER IF RESULT IS NOT ZERO
18483: EXI 1 TAKE IDENT EXIT
18484: .FI
18485: *
18486: * HERE FOR NAMES, IDENT IF BASES AND OFFSETS SAME
18487: *
18488: IDEN6 BNE NMOFS(XR),NMOFS(XL),IDEN1 DIFFER IF DIFFERENT OFFSET
18489: BNE NMBAS(XR),NMBAS(XL),IDEN1 DIFFER IF DIFFERENT BASE
18490: *
18491: * MERGE HERE TO SIGNAL IDENT FOR IDENTICAL POINTERS
18492: *
18493: IDEN7 EXI 1 TAKE IDENT EXIT
18494: *
18495: * HERE FOR DIFFER STRINGS
18496: *
18497: IDEN8 ZER XR CLEAR GARBAGE PTR IN XR
18498: ZER XL CLEAR GARBAGE PTR IN XL
18499: EXI RETURN TO CALLER (DIFFER)
18500: ENP END PROCEDURE IDENT
18501: EJC
18502: *
18503: * INOUT - USED TO INITIALISE INPUT AND OUTPUT VARIABLES
18504: *
18505: * (XL) POINTER TO VBL NAME STRING
18506: * (WB) TRBLK TYPE
18507: * JSR INOUT CALL TO PERFORM INITIALISATION
18508: * (XL) VRBLK PTR
18509: * (XR) TRBLK PTR
18510: * (WA,WC) DESTROYED
18511: *
18512: * NOTE THAT TRTER (= TRTRF) FIELD OF STANDARD I/O VARIABLES
18513: * POINTS TO CORRESPONDING SVBLK NOT TO A TRBLK AS IS THE
18514: * CASE FOR ORDINARY VARIABLES.
18515: *
18516: INOUT PRC E,0 ENTRY POINT
18517: MOV WB,-(XS) STACK TRBLK TYPE
18518: MOV SCLEN(XL),WA GET NAME LENGTH
18519: ZER WB POINT TO START OF NAME
18520: JSR SBSTR BUILD A PROPER SCBLK
18521: JSR GTNVR BUILD VRBLK
18522: PPM NO ERROR RETURN
18523: MOV XR,WC SAVE VRBLK POINTER
18524: MOV (XS)+,WB GET TRTER FIELD
18525: ZER XL ZERO TRFPT
18526: JSR TRBLD BUILD TRBLK
18527: MOV WC,XL RECALL VRBLK POINTER
18528: MOV VRSVP(XL),TRTER(XR) STORE SVBLK POINTER
18529: MOV XR,VRVAL(XL) STORE TRBLK PTR IN VRBLK
18530: MOV =B$VRA,VRGET(XL) SET TRAPPED ACCESS
18531: MOV =B$VRV,VRSTO(XL) SET TRAPPED STORE
18532: EXI RETURN TO CALLER
18533: ENP END PROCEDURE INOUT
18534: EJC
18535: .IF .CNBF
18536: .ELSE
18537: *
18538: * INSBF -- INSERT STRING IN BUFFER
18539: *
18540: * THIS ROUTINE WILL REPLACE A SECTION OF A BUFFER WITH THE
18541: * CONTENTS OF A GIVEN STRING. IF THE LENGTH OF THE
18542: * SECTION TO BE REPLACED IS DIFFERENT THAN THE LENGTH OF
18543: * THE GIVEN STRING, AND THE REPLACEMENT IS NOT AN APPEND,
18544: * THEN THE UPPER SECTION OF THE BUFFER IS SHIFTED UP OR
18545: * DOWN TO CREATE THE PROPER SPACE FOR THE INSERT.
18546: *
18547: * (XR) POINTER TO BFBLK
18548: * (XL) OBJECT WHICH IS STRING CONVERTABLE
18549: * (WA) OFFSET OF START OF INSERT IN (XR)
18550: * (WB) LENGTH OF SECTION IN (XR) REPLACED
18551: * JSR INSBF CALL TO INSERT CHARACTERS IN BUFFER
18552: * PPM LOC THREAD IF (XR) NOT CONVERTABLE
18553: * PPM LOC THREAD IF INSERT NOT POSSIBLE
18554: *
18555: * THE SECOND ALTERNATE EXIT IS TAKEN IF THE INSERT WOULD
18556: * OVERFLOW THE BUFFER, OR IF THE INSERT IS OUT PAST THE
18557: * DEFINED END OF THE BUFFER AS GIVEN.
18558: *
18559: INSBF PRC E,2 ENTRY POINT
18560: MOV WA,INSSA SAVE ENTRY WA
18561: MOV WB,INSSB SAVE ENTRY WB
18562: MOV WC,INSSC SAVE ENTRY WC
18563: ADD WB,WA ADD TO GET OFFSET PAST REPLACE PART
18564: MOV WA,INSAB SAVE WA+WB
18565: MOV BCLEN(XR),WC GET CURRENT DEFINED LENGTH
18566: BGT INSSA,WC,INS07 FAIL IF START OFFSET TOO BIG
18567: BGT WA,WC,INS07 FAIL IF FINAL OFFSET TOO BIG
18568: MOV XL,-(XS) SAVE ENTRY XL
18569: MOV XR,-(XS) SAVE BCBLK PTR
18570: MOV XL,-(XS) STACK AGAIN FOR GTSTG
18571: JSR GTSTG CALL TO CONVERT TO STRING
18572: PPM INS05 TAKE STRING CONVERT ERR EXIT
18573: MOV XR,XL SAVE STRING PTR
18574: MOV (XS),XR RESTORE BCBLK PTR
18575: ADD WC,WA ADD BUFFER LEN TO STRING LEN
18576: SUB INSSB,WA BIAS OUT COMPONENT BEING REPLACED
18577: MOV BCBUF(XR),XR POINT TO BFBLK
18578: BGT WA,BFALC(XR),INS06 FAIL IF RESULT EXCEEDS ALLOCATION
18579: MOV (XS),XR RESTORE BCBLK PTR
18580: MOV WC,WA GET BUFFER LENGTH
18581: SUB INSAB,WA SUBTRACT TO GET SHIFT LENGTH
18582: ADD SCLEN(XL),WC ADD LENGTH OF NEW
18583: SUB INSSB,WC SUBTRACT OLD TO GET TOTAL NEW LEN
18584: MOV BCLEN(XR),WB GET OLD BCLEN
18585: MOV WC,BCLEN(XR) STUFF NEW LENGTH
18586: BZE WA,INS04 SKIP SHIFT IF NOTHING TO DO
18587: BEQ INSSB,SCLEN(XL),INS04 SKIP SHIFT IF LENGTHS MATCH
18588: MOV BCBUF(XR),XR POINT TO BFBLK
18589: MOV XL,-(XS) SAVE SCBLK PTR
18590: BLO INSSB,SCLEN(XL),INS01 BRN IF SHFT IS FOR MORE ROOM
18591: EJC
18592: *
18593: * INSBF (CONTINUED)
18594: *
18595: * WE ARE SHIFTING THE UPPER SEGMENT DOWN TO COMPACT
18596: * THE BUFFER. (THE STRING LENGTH IS SMALLER THAN THE
18597: * SEGMENT BEING REPLACED.) REGISTERS ARE SET AS:
18598: *
18599: * (WA) MOVE (SHIFT DOWN) LENGTH
18600: * (WB) OLD BCLEN
18601: * (WC) NEW BCLEN
18602: * (XR) BFBLK PTR
18603: * (XL),(XS) SCBLK PTR
18604: *
18605: MOV INSSA,WB GET OFFSET TO INSERT
18606: ADD SCLEN(XL),WB ADD INSERT LENGTH TO GET DEST OFF
18607: MOV XR,XL MAKE COPY
18608: PLC XL,INSAB PREPARE SOURCE FOR MOVE
18609: PSC XR,WB PREPARE DESTINATION REG FOR MOVE
18610: MVC MOVE EM OUT
18611: BRN INS02 BRANCH TO PAD
18612: *
18613: * WE ARE SHIFTING THE UPPER SEGMENT UP TO EXPAND
18614: * THE BUFFER. (THE STRING LENGTH IS LARGER THAN THE
18615: * SEGMENT BEING REPLACED.)
18616: *
18617: INS01 MOV XR,XL COPY BFBLK PTR
18618: PLC XL,WB SET SOURCE REG FOR MOVE BACKWARDS
18619: PSC XR,WC SET DESTINATION PTR FOR MOVE
18620: MCB MOVE BACKWARDS (POSSIBLE OVERLAP)
18621: *
18622: * MERGE HERE AFTER MOVE TO ADJUST PADDING AT NEW BUFFER END
18623: *
18624: INS02 MOV (XS)+,XL RESTORE SCBLK PTR
18625: MOV WC,WA COPY NEW BUFFER END
18626: CTB WA,0 ROUND OUT
18627: SUB WC,WA SUBTRACT TO GET REMAINDER
18628: BZE WA,INS04 NO PAD IF ALREADY EVEN BOUNDARY
18629: MOV (XS),XR GET BCBLK PTR
18630: MOV BCBUF(XR),XR GET BFBLK PTR
18631: PSC XR,WC PREPARE TO PAD
18632: ZER WB CLEAR WB
18633: LCT WA,WA LOAD LOOP COUNT
18634: *
18635: * LOOP HERE TO STUFF PAD CHARACTERS
18636: *
18637: INS03 SCH WB,(XR)+ STUFF ZERO PAD
18638: BCT WA,INS03 BRANCH FOR MORE
18639: EJC
18640: *
18641: * INSBF (CONTINUED)
18642: *
18643: * MERGE HERE WHEN PADDING OK. NOW COPY IN THE INSERT
18644: * STRING TO THE HOLE.
18645: *
18646: INS04 MOV (XS),XR GET BCBLK PTR
18647: MOV BCBUF(XR),XR GET BFBLK PTR
18648: MOV SCLEN(XL),WA GET MOVE LENGTH
18649: PLC XL PREPARE TO COPY FROM FIRST CHAR
18650: PSC XR,INSSA PREPARE TO STORE IN HOLE
18651: MVC COPY THE CHARACTERS
18652: MOV (XS)+,XR RESTORE ENTRY XR
18653: MOV (XS)+,XL RESTORE ENTRY XL
18654: MOV INSSA,WA RESTORE ENTRY WA
18655: MOV INSSB,WB RESTORE ENTRY WB
18656: MOV INSSC,WC RESTORE ENTRY WC
18657: EXI RETURN TO CALLER
18658: *
18659: * HERE TO TAKE STRING CONVERT ERROR EXIT
18660: *
18661: INS05 MOV (XS)+,XR RESTORE ENTRY XR
18662: MOV (XS)+,XL RESTORE ENTRY XL
18663: MOV INSSA,WA RESTORE ENTRY WA
18664: MOV INSSB,WB RESTORE ENTRY WB
18665: MOV INSSC,WC RESTORE ENTRY WC
18666: EXI 1 ALTERNATE EXIT
18667: *
18668: * HERE FOR INVALID OFFSET OR LENGTH
18669: *
18670: INS06 MOV (XS)+,XR RESTORE ENTRY XR
18671: MOV (XS)+,XL RESTORE ENTRY XL
18672: *
18673: * MERGE FOR LENGTH FAILURE EXIT WITH STACK SET
18674: *
18675: INS07 MOV INSSA,WA RESTORE ENTRY WA
18676: MOV INSSB,WB RESTORE ENTRY WB
18677: MOV INSSC,WC RESTORE ENTRY WC
18678: EXI 2 ALTERNATE EXIT
18679: ENP END PROCEDURE INSBF
18680: EJC
18681: .FI
18682: *
18683: * IOFCB -- GET INPUT/OUTPUT FCBLK POINTER
18684: *
18685: * USED BY ENDFILE, EJECT AND REWIND TO FIND THE FCBLK
18686: * (IF ANY) CORRESPONDING TO THEIR ARGUMENT.
18687: *
18688: * -(XS) ARGUMENT
18689: * JSR IOFCB CALL TO FIND FCBLK
18690: * PPM LOC ARG IS AN UNSUITABLE NAME
18691: * PPM LOC ARG IS NULL STRING
18692: * (XS) POPPED
18693: * (XL) PTR TO FILEARG1 VRBLK
18694: * (XR) ARGUMENT
18695: * (WA) FCBLK PTR OR 0
18696: * (WB) DESTROYED
18697: *
18698: IOFCB PRC N,2 ENTRY POINT
18699: JSR GTSTG GET ARG AS STRING
18700: PPM IOFC2 FAIL
18701: MOV XR,XL COPY STRING PTR
18702: JSR GTNVR GET AS NATURAL VARIABLE
18703: PPM IOFC3 FAIL IF NULL
18704: MOV XL,WB COPY STRING POINTER AGAIN
18705: MOV XR,XL COPY VRBLK PTR FOR RETURN
18706: ZER WA IN CASE NO TRBLK FOUND
18707: *
18708: * LOOP TO FIND FILE ARG1 TRBLK
18709: *
18710: IOFC1 MOV VRVAL(XR),XR GET POSSIBLE TRBLK PTR
18711: BNE (XR),=B$TRT,IOFC2 FAIL IF END OF CHAIN
18712: BNE TRTYP(XR),=TRTFC,IOFC1 LOOP IF NOT FILE ARG TRBLK
18713: MOV TRFPT(XR),WA GET FCBLK PTR
18714: MOV WB,XR COPY ARG
18715: EXI RETURN
18716: *
18717: * FAIL RETURN
18718: *
18719: IOFC2 EXI 1 FAIL
18720: *
18721: * NULL ARG
18722: *
18723: IOFC3 EXI 2 NULL ARG RETURN
18724: ENP END PROCEDURE IOFCB
18725: EJC
18726: *
18727: * IOPPF -- PROCESS FILEARG2 FOR IOPUT
18728: *
18729: * (R$XSC) FILEARG2 PTR
18730: * JSR IOPPF CALL TO PROCESS FILEARG2
18731: * (XL) FILEARG1 PTR
18732: * (XR) FILE ARG2 PTR
18733: * -(XS)..-(XS) FIELDS EXTRACTED FROM FILEARG2
18734: * (WC) NO. OF FIELDS EXTRACTED
18735: * (WB) INPUT/OUTPUT FLAG
18736: * (WA) FCBLK PTR OR 0
18737: *
18738: IOPPF PRC N,0 ENTRY POINT
18739: ZER WB TO COUNT FIELDS EXTRACTED
18740: *
18741: * LOOP TO EXTRACT FIELDS
18742: *
18743: IOPP1 MOV =IODEL,XL GET DELIMITER
18744: MOV XL,WC COPY IT
18745: JSR XSCAN GET NEXT FIELD
18746: MOV XR,-(XS) STACK IT
18747: ICV WB INCREMENT COUNT
18748: BNZ WA,IOPP1 LOOP
18749: MOV WB,WC COUNT OF FIELDS
18750: MOV IOPTT,WB I/O MARKER
18751: MOV R$IOF,WA FCBLK PTR OR 0
18752: MOV R$IO2,XR FILE ARG2 PTR
18753: MOV R$IO1,XL FILEARG1
18754: EXI RETURN
18755: ENP END PROCEDURE IOPPF
18756: EJC
18757: *
18758: * IOPUT -- ROUTINE USED BY INPUT AND OUTPUT
18759: *
18760: * IOPUT SETS UP INPUT/OUTPUT ASSOCIATIONS. IT BUILDS
18761: * SUCH TRACE AND FILE CONTROL BLOCKS AS ARE NECESSARY AND
18762: * CALLS SYSFC,SYSIO TO PERFORM CHECKS ON THE
18763: * ARGUMENTS AND TO OPEN THE FILES.
18764: *
18765: * +-----------+ +---------------+ +-----------+
18766: * +-.I I I I------.I =B$XRT I
18767: * I +-----------+ +---------------+ +-----------+
18768: * I / / (R$FCB) I *4 I
18769: * I / / +-----------+
18770: * I +-----------+ +---------------+ I I-
18771: * I I NAME +--.I =B$TRT I +-----------+
18772: * I / / +---------------+ I I
18773: * I (FIRST ARG) I =TRTIN/=TRTOU I +-----------+
18774: * I +---------------+ I
18775: * I I VALUE I I
18776: * I +---------------+ I
18777: * I I(TRTRF) 0 OR I--+ I
18778: * I +---------------+ I I
18779: * I I(TRFPT) 0 OR I----+ I
18780: * I +---------------+ I I I
18781: * I (I/O TRBLK) I I I
18782: * I +-----------+ I I I
18783: * I I I I I I
18784: * I +-----------+ I I I
18785: * I I I I I I
18786: * I +-----------+ +---------------+ I I I
18787: * I I +--.I =B$TRT I.-+ I I
18788: * I +-----------+ +---------------+ I I
18789: * I / / I =TRTFC I I I
18790: * I / / +---------------+ I I
18791: * I (FILEARG1 I VALUE I I I
18792: * I VRBLK) +---------------+ I I
18793: * I I(TRTRF) 0 OR I--+ I .
18794: * I +---------------+ I . +-----------+
18795: * I I(TRFPT) 0 OR I------./ FCBLK /
18796: * I +---------------+ I +-----------+
18797: * I (TRTRF) I
18798: * I I
18799: * I I
18800: * I +---------------+ I
18801: * I I =B$XRT I.-+
18802: * I +---------------+
18803: * I I *5 I
18804: * I +---------------+
18805: * +------------------I I
18806: * +---------------+ +-----------+
18807: * I(TRTRF) O OR I------.I =B$XRT I
18808: * +---------------+ +-----------+
18809: * I NAME OFFSET I I ETC I
18810: * +---------------+
18811: * (IOCHN - CHAIN OF NAME POINTERS)
18812: EJC
18813: *
18814: * IOPUT (CONTINUED)
18815: *
18816: * NO ADDITIONAL TRAP BLOCKS ARE USED FOR STANDARD INPUT/OUT
18817: * FILES. OTHERWISE AN I/O TRAP BLOCK IS ATTACHED TO SECOND
18818: * ARG (FILEARG1) VRBLK. SEE DIAGRAM ABOVE FOR DETAILS OF
18819: * THE STRUCTURE BUILT.
18820: *
18821: * -(XS) 1ST ARG (VBL TO BE ASSOCIATED)
18822: * -(XS) 2ND ARG (FILE ARG1)
18823: * -(XS) 3RD ARG (FILE ARG2)
18824: * (WB) 0 FOR INPUT, 3 FOR OUTPUT ASSOC.
18825: * JSR IOPUT CALL FOR INPUT/OUTPUT ASSOCIATION
18826: * PPM LOC 3RD ARG NOT A STRING
18827: * PPM LOC 2ND ARG NOT A SUITABLE NAME
18828: * PPM LOC 1ST ARG NOT A SUITABLE NAME
18829: * PPM LOC INAPPROPRIATE FILE SPEC FOR I/O
18830: * PPM LOC I/O FILE DOES NOT EXIST
18831: * PPM LOC I/O FILE CANNOT BE READ/WRITTEN
18832: * (XS) POPPED
18833: * (XL,XR,WA,WB,WC) DESTROYED
18834: *
18835: IOPUT PRC N,6 ENTRY POINT
18836: ZER R$IOT IN CASE NO TRTRF BLOCK USED
18837: ZER R$IOF IN CASE NO FCBLK ALOCATED
18838: MOV WB,IOPTT STORE I/O TRACE TYPE
18839: JSR XSCNI PREPARE TO SCAN FILEARG2
18840: PPM IOP13 FAIL
18841: PPM IOPA0 NULL FILE ARG2
18842: *
18843: IOPA0 MOV XR,R$IO2 KEEP FILE ARG2
18844: MOV WA,XL COPY LENGTH
18845: JSR GTSTG CONVERT FILEARG1 TO STRING
18846: PPM IOP14 FAIL
18847: MOV XR,R$IO1 KEEP FILEARG1 PTR
18848: JSR GTNVR CONVERT TO NATURAL VARIABLE
18849: PPM IOP00 JUMP IF NULL
18850: BRN IOP04 JUMP TO PROCESS NON-NULL ARGS
18851: *
18852: * NULL FILEARG1
18853: *
18854: IOP00 BZE XL,IOP01 SKIP IF BOTH ARGS NULL
18855: JSR IOPPF PROCESS FILEARG2
18856: JSR SYSFC CALL FOR FILEARG2 CHECK
18857: PPM IOP16 FAIL
18858: BRN IOP11 COMPLETE FILE ASSOCIATION
18859: EJC
18860: *
18861: * IOPUT (CONTINUED)
18862: *
18863: * HERE WITH 0 OR FCBLK PTR IN (XL)
18864: *
18865: IOP01 MOV IOPTT,WB GET TRACE TYPE
18866: MOV R$IOT,XR GET 0 OR TRTRF PTR
18867: JSR TRBLD BUILD TRBLK
18868: MOV XR,WC COPY TRBLK POINTER
18869: MOV (XS)+,XR GET VARIABLE FROM STACK
18870: JSR GTVAR POINT TO VARIABLE
18871: PPM IOP15 FAIL
18872: MOV XL,R$ION SAVE NAME POINTER
18873: MOV XL,XR COPY NAME POINTER
18874: ADD WA,XR POINT TO VARIABLE
18875: SUB *VRVAL,XR SUBTRACT OFFSET,MERGE INTO LOOP
18876: *
18877: * LOOP TO END OF TRBLK CHAIN IF ANY
18878: *
18879: IOP02 MOV XR,XL COPY BLK PTR
18880: MOV VRVAL(XR),XR LOAD PTR TO NEXT TRBLK
18881: BNE (XR),=B$TRT,IOP03 JUMP IF NOT TRAPPED
18882: BNE TRTYP(XR),IOPTT,IOP02 LOOP IF NOT SAME ASSOCN
18883: MOV TRNXT(XR),XR GET VALUE AND DELETE OLD TRBLK
18884: *
18885: * IOPUT (CONTINUED)
18886: *
18887: * STORE NEW ASSOCIATION
18888: *
18889: IOP03 MOV WC,VRVAL(XL) LINK TO THIS TRBLK
18890: MOV WC,XL COPY POINTER
18891: MOV XR,TRNXT(XL) STORE VALUE IN TRBLK
18892: MOV R$ION,XR RESTORE POSSIBLE VRBLK POINTER
18893: MOV WA,WB KEEP OFFSET TO NAME
18894: JSR SETVR IF VRBLK, SET VRGET,VRSTO
18895: MOV R$IOT,XR GET 0 OR TRTRF PTR
18896: BNZ XR,IOP19 JUMP IF TRTRF BLOCK EXISTS
18897: EXI RETURN TO CALLER
18898: *
18899: * NON STANDARD FILE
18900: * SEE IF AN FCBLK HAS ALREADY BEEN ALLOCATED.
18901: *
18902: IOP04 ZER WA IN CASE NO FCBLK FOUND
18903: EJC
18904: *
18905: * IOPUT (CONTINUED)
18906: *
18907: * SEARCH POSSIBLE TRBLK CHAIN TO PICK UP THE FCBLK
18908: *
18909: IOP05 MOV XR,WB REMEMBER BLK PTR
18910: MOV VRVAL(XR),XR CHAIN ALONG
18911: BNE (XR),=B$TRT,IOP06 JUMP IF END OF TRBLK CHAIN
18912: BNE TRTYP(XR),=TRTFC,IOP05 LOOP IF MORE TO GO
18913: MOV XR,R$IOT POINT TO FILE ARG1 TRBLK
18914: MOV TRFPT(XR),WA GET FCBLK PTR FROM TRBLK
18915: *
18916: * WA = 0 OR FCBLK PTR
18917: * WB = PTR TO PRECEDING BLK TO WHICH ANY TRTRF BLOCK
18918: * FOR FILE ARG1 MUST BE CHAINED.
18919: *
18920: IOP06 MOV WA,R$IOF KEEP POSSIBLE FCBLK PTR
18921: MOV WB,R$IOP KEEP PRECEDING BLK PTR
18922: JSR IOPPF PROCESS FILEARG2
18923: JSR SYSFC SEE IF FCBLK REQUIRED
18924: PPM IOP16 FAIL
18925: BZE WA,IOP12 SKIP IF NO NEW FCBLK WANTED
18926: BLT WC,=NUM02,IOP6A JUMP IF FCBLK IN DYNAMIC
18927: JSR ALOST GET IT IN STATIC
18928: BRN IOP6B SKIP
18929: *
18930: * OBTAIN FCBLK IN DYNAMIC
18931: *
18932: IOP6A JSR ALLOC GET SPACE FOR FCBLK
18933: *
18934: * MERGE
18935: *
18936: IOP6B MOV XR,XL POINT TO FCBLK
18937: MOV WA,WB COPY ITS LENGTH
18938: BTW WB GET COUNT AS WORDS (SGD APR80)
18939: LCT WB,WB LOOP COUNTER
18940: *
18941: * CLEAR FCBLK
18942: *
18943: IOP07 ZER (XR)+ CLEAR A WORD
18944: BCT WB,IOP07 LOOP
18945: BEQ WC,=NUM02,IOP09 SKIP IF IN STATIC - DONT SET FIELDS
18946: MOV =B$XNT,(XL) STORE XNBLK CODE IN CASE
18947: MOV WA,1(XL) STORE LENGTH
18948: BNZ WC,IOP09 JUMP IF XNBLK WANTED
18949: MOV =B$XRT,(XL) XRBLK CODE REQUESTED
18950: *
18951: EJC
18952: * IOPUT (CONTINUED)
18953: *
18954: * COMPLETE FCBLK INITIALISATION
18955: *
18956: IOP09 MOV R$IOT,XR GET POSSIBLE TRBLK PTR
18957: MOV XL,R$IOF STORE FCBLK PTR
18958: BNZ XR,IOP10 JUMP IF TRBLK ALREADY FOUND
18959: *
18960: * A NEW TRBLK IS NEEDED
18961: *
18962: MOV =TRTFC,WB TRTYP FOR FCBLK TRAP BLK
18963: JSR TRBLD MAKE THE BLOCK
18964: MOV XR,R$IOT COPY TRTRF PTR
18965: MOV R$IOP,XL POINT TO PRECEDING BLK
18966: MOV VRVAL(XL),VRVAL(XR) COPY VALUE FIELD TO TRBLK
18967: MOV XR,VRVAL(XL) LINK NEW TRBLK INTO CHAIN
18968: MOV XL,XR POINT TO PREDECESSOR BLK
18969: JSR SETVR SET TRACE INTERCEPTS
18970: MOV VRVAL(XR),XR RECOVER TRBLK PTR
18971: *
18972: * XR IS PTR TO TRBLK, XL IS FCBLK PTR OR 0
18973: *
18974: IOP10 MOV R$IOF,TRFPT(XR) STORE FCBLK PTR
18975: *
18976: * CALL SYSIO TO COMPLETE FILE ACCESSING
18977: *
18978: IOP11 MOV R$IOF,WA COPY FCBLK PTR OR 0
18979: MOV IOPTT,WB GET INPUT/OUTPUT FLAG
18980: MOV R$IO2,XR GET FILE ARG2
18981: MOV R$IO1,XL GET FILE ARG1
18982: JSR SYSIO ASSOCIATE TO THE FILE
18983: PPM IOP17 FAIL
18984: PPM IOP18 FAIL
18985: BNZ R$IOT,IOP01 NOT STD INPUT IF NON-NULL TRTRF BLK
18986: BNZ IOPTT,IOP01 JUMP IF OUTPUT
18987: BZE WC,IOP01 NO CHANGE TO STANDARD READ LENGTH
18988: MOV WC,CSWIN STORE NEW READ LENGTH FOR STD FILE
18989: BRN IOP01 MERGE TO FINISH THE TASK
18990: *
18991: * SYSFC MAY HAVE RETURNED A POINTER TO A PRIVATE FCBLK
18992: *
18993: IOP12 BNZ XL,IOP09 JUMP IF PRIVATE FCBLK
18994: BRN IOP11 FINISH THE ASSOCIATION
18995: *
18996: * FAILURE RETURNS
18997: *
18998: IOP13 EXI 1 3RD ARG NOT A STRING
18999: IOP14 EXI 2 2ND ARG UNSUITABLE
19000: IOP15 EXI 3 1ST ARG UNSUITABLE
19001: IOP16 EXI 4 FILE SPEC WRONG
19002: IOP17 EXI 5 I/O FILE DOES NOT EXIST
19003: IOP18 EXI 6 I/O FILE CANNOT BE READ/WRITTEN
19004: EJC
19005: *
19006: * IOPUT (CONTINUED)
19007: *
19008: * ADD TO IOCHN CHAIN OF ASSSOCIATED VARIABLES UNLESS ALREAD
19009: * PRESENT.
19010: *
19011: IOP19 MOV R$ION,WC WC = NAME BASE, WB = NAME OFFSET
19012: *
19013: * SEARCH LOOP
19014: *
19015: IOP20 MOV TRTRF(XR),XR NEXT LINK OF CHAIN
19016: BZE XR,IOP21 NOT FOUND
19017: BNE WC,IONMB(XR),IOP20 NO MATCH
19018: BEQ WB,IONMO(XR),IOP22 EXIT IF MATCHED
19019: BRN IOP20 LOOP
19020: *
19021: * NOT FOUND
19022: *
19023: IOP21 MOV *NUM05,WA SPACE NEEDED
19024: JSR ALLOC GET IT
19025: MOV =B$XRT,(XR) STORE XRBLK CODE
19026: MOV WA,1(XR) STORE LENGTH
19027: MOV WC,IONMB(XR) STORE NAME BASE
19028: MOV WB,IONMO(XR) STORE NAME OFFSET
19029: MOV R$IOT,XL POINT TO TRTRF BLK
19030: MOV TRTRF(XL),WA GET PTR FIELD CONTENTS
19031: MOV XR,TRTRF(XL) STORE PTR TO NEW BLOCK
19032: MOV WA,TRTRF(XR) COMPLETE THE LINKING
19033: *
19034: * INSERT FCBLK ON FCBLK CHAIN FOR SYSEJ, SYSXI
19035: *
19036: IOP22 BZE R$IOF,IOP25 SKIP IF NO FCBLK
19037: MOV R$FCB,XL PTR TO HEAD OF EXISTING CHAIN
19038: *
19039: * SEE IF FCBLK ALREADY ON CHAIN
19040: *
19041: IOP23 BZE XL,IOP24 NOT ON IF END OF CHAIN
19042: BEQ 3(XL),R$IOF,IOP25 DONT DUPLICATE IF FIND IT
19043: MOV 2(XL),XL GET NEXT LINK
19044: BRN IOP23 LOOP
19045: *
19046: * NOT FOUND SO ADD AN ENTRY FOR THIS FCBLK
19047: *
19048: IOP24 MOV *NUM04,WA SPACE NEEDED
19049: JSR ALLOC GET IT
19050: MOV =B$XRT,(XR) STORE BLOCK CODE
19051: MOV WA,1(XR) STORE LENGTH
19052: MOV R$FCB,2(XR) STORE PREVIOUS LINK IN THIS NODE
19053: MOV R$IOF,3(XR) STORE FCBLK PTR
19054: MOV XR,R$FCB INSERT NODE INTO FCBLK CHAIN
19055: *
19056: * RETURN
19057: *
19058: IOP25 EXI RETURN TO CALLER
19059: ENP END PROCEDURE IOPUT
19060: EJC
19061: *
19062: * KTREX -- EXECUTE KEYWORD TRACE
19063: *
19064: * KTREX IS USED TO EXECUTE A POSSIBLE KEYWORD TRACE. IT
19065: * INCLUDES THE TEST ON TRACE AND TESTS FOR TRACE ACTIVE.
19066: *
19067: * (XL) PTR TO TRBLK (OR 0 IF UNTRACED)
19068: * JSR KTREX CALL TO EXECUTE KEYWORD TRACE
19069: * (XL,WA,WB,WC) DESTROYED
19070: * (RA) DESTROYED
19071: *
19072: KTREX PRC R,0 ENTRY POINT (RECURSIVE)
19073: BZE XL,KTRX3 IMMEDIATE EXIT IF KEYWORD UNTRACED
19074: BZE KVTRA,KTRX3 IMMEDIATE EXIT IF TRACE = 0
19075: DCV KVTRA ELSE DECREMENT TRACE
19076: MOV XR,-(XS) SAVE XR
19077: MOV XL,XR COPY TRBLK POINTER
19078: MOV TRKVR(XR),XL LOAD VRBLK POINTER (NMBAS)
19079: MOV *VRVAL,WA SET NAME OFFSET
19080: BZE TRFNC(XR),KTRX1 JUMP IF PRINT TRACE
19081: JSR TRXEQ ELSE EXECUTE FULL TRACE
19082: BRN KTRX2 AND JUMP TO EXIT
19083: *
19084: * HERE FOR PRINT TRACE
19085: *
19086: KTRX1 MOV XL,-(XS) STACK VRBLK PTR FOR KWNAM
19087: MOV WA,-(XS) STACK OFFSET FOR KWNAM
19088: JSR PRTSN PRINT STATEMENT NUMBER
19089: MOV =CH$AM,WA LOAD AMPERSAND
19090: JSR PRTCH PRINT AMPERSAND
19091: JSR PRTNM PRINT KEYWORD NAME
19092: MOV =TMBEB,XR POINT TO BLANK-EQUAL-BLANK
19093: JSR PRTST PRINT BLANK-EQUAL-BLANK
19094: JSR KWNAM GET KEYWORD PSEUDO-VARIABLE NAME
19095: MOV XR,DNAMP RESET PTR TO DELETE KVBLK
19096: JSR ACESS GET KEYWORD VALUE
19097: PPM FAILURE IS IMPOSSIBLE
19098: JSR PRTVL PRINT KEYWORD VALUE
19099: JSR PRTNL TERMINATE PRINT LINE
19100: *
19101: * HERE TO EXIT AFTER COMPLETING TRACE
19102: *
19103: KTRX2 MOV (XS)+,XR RESTORE ENTRY XR
19104: *
19105: * MERGE HERE TO EXIT IF NO TRACE REQUIRED
19106: *
19107: KTRX3 EXI RETURN TO KTREX CALLER
19108: ENP END PROCEDURE KTREX
19109: EJC
19110: *
19111: * KWNAM -- GET PSEUDO-VARIABLE NAME FOR KEYWORD
19112: *
19113: * 1(XS) NAME BASE FOR VRBLK
19114: * 0(XS) OFFSET (SHOULD BE *VRVAL)
19115: * JSR KWNAM CALL TO GET PSEUDO-VARIABLE NAME
19116: * (XS) POPPED TWICE
19117: * (XL,WA) RESULTING PSEUDO-VARIABLE NAME
19118: * (XR,WA,WB) DESTROYED
19119: *
19120: KWNAM PRC N,0 ENTRY POINT
19121: ICA XS IGNORE NAME OFFSET
19122: MOV (XS)+,XR LOAD NAME BASE
19123: BGE XR,STATE,KWNM1 JUMP IF NOT NATURAL VARIABLE NAME
19124: BNZ VRLEN(XR),KWNM1 ERROR IF NOT SYSTEM VARIABLE
19125: MOV VRSVP(XR),XR ELSE POINT TO SVBLK
19126: MOV SVBIT(XR),WA LOAD BIT MASK
19127: ANB BTKNM,WA AND WITH KEYWORD BIT
19128: ZRB WA,KWNM1 ERROR IF NO KEYWORD ASSOCIATION
19129: MOV SVLEN(XR),WA ELSE LOAD NAME LENGTH IN CHARACTERS
19130: CTB WA,SVCHS COMPUTE OFFSET TO FIELD WE WANT
19131: ADD WA,XR POINT TO SVKNM FIELD
19132: MOV (XR),WB LOAD SVKNM VALUE
19133: MOV *KVSI$,WA SET SIZE OF KVBLK
19134: JSR ALLOC ALLOCATE KVBLK
19135: MOV =B$KVT,(XR) STORE TYPE WORD
19136: MOV WB,KVNUM(XR) STORE KEYWORD NUMBER
19137: MOV =TRBKV,KVVAR(XR) SET DUMMY TRBLK POINTER
19138: MOV XR,XL COPY KVBLK POINTER
19139: MOV *KVVAR,WA SET PROPER OFFSET
19140: EXI RETURN TO KVNAM CALLER
19141: *
19142: * HERE IF NOT KEYWORD NAME
19143: *
19144: KWNM1 ERB 251,KEYWORD OPERAND IS NOT NAME OF DEFINED KEYWORD
19145: ENP END PROCEDURE KWNAM
19146: EJC
19147: *
19148: * LCOMP-- COMPARE TWO STRINGS LEXICALLY
19149: *
19150: * 1(XS) FIRST ARGUMENT
19151: * 0(XS) SECOND ARGUMENT
19152: * JSR LCOMP CALL TO COMPARE ARUMENTS
19153: * PPM LOC TRANSFER LOC FOR ARG1 NOT STRING
19154: * PPM LOC TRANSFER LOC FOR ARG2 NOT STRING
19155: * PPM LOC TRANSFER LOC IF ARG1 LLT ARG2
19156: * PPM LOC TRANSFER LOC IF ARG1 LEQ ARG2
19157: * PPM LOC TRANSFER LOC IF ARG1 LGT ARG2
19158: * (THE NORMAL RETURN IS NEVER TAKEN)
19159: * (XS) POPPED TWICE
19160: * (XR,XL) DESTROYED
19161: * (WA,WB,WC,RA) DESTROYED
19162: *
19163: LCOMP PRC N,5 ENTRY POINT
19164: JSR GTSTG CONVERT SECOND ARG TO STRING
19165: PPM LCMP6 JUMP IF SECOND ARG NOT STRING
19166: MOV XR,XL ELSE SAVE POINTER
19167: MOV WA,WB AND LENGTH
19168: JSR GTSTG CONVERT FIRST ARGUMENT TO STRING
19169: PPM LCMP5 JUMP IF NOT STRING
19170: MOV WA,WC SAVE ARG 1 LENGTH
19171: PLC XR POINT TO CHARS OF ARG 1
19172: PLC XL POINT TO CHARS OF ARG 2
19173: BLO WA,WB,LCMP1 JUMP IF ARG 1 LENGTH IS SMALLER
19174: MOV WB,WA ELSE SET ARG 2 LENGTH AS SMALLER
19175: *
19176: * HERE WITH SMALLER LENGTH IN (WA)
19177: *
19178: LCMP1 CMC LCMP4,LCMP3 COMPARE STRINGS, JUMP IF UNEQUAL
19179: BNE WB,WC,LCMP2 IF EQUAL, JUMP IF LENGTHS UNEQUAL
19180: EXI 4 ELSE IDENTICAL STRINGS, LEQ EXIT
19181: EJC
19182: *
19183: * LCOMP (CONTINUED)
19184: *
19185: * HERE IF INITIAL STRINGS IDENTICAL, BUT LENGTHS UNEQUAL
19186: *
19187: LCMP2 BHI WC,WB,LCMP4 JUMP IF ARG 1 LENGTH GT ARG 2 LENG
19188: *
19189: * HERE IF FIRST ARG LLT SECOND ARG
19190: *
19191: LCMP3 EXI 3 TAKE LLT EXIT
19192: *
19193: * HERE IF FIRST ARG LGT SECOND ARG
19194: *
19195: LCMP4 EXI 5 TAKE LGT EXIT
19196: *
19197: * HERE IF FIRST ARG IS NOT A STRING
19198: *
19199: LCMP5 EXI 1 TAKE BAD FIRST ARG EXIT
19200: *
19201: * HERE FOR SECOND ARG NOT A STRING
19202: *
19203: LCMP6 EXI 2 TAKE BAD SECOND ARG ERROR EXIT
19204: ENP END PROCEDURE LCOMP
19205: EJC
19206: *
19207: * LISTR -- LIST SOURCE LINE
19208: *
19209: * LISTR IS USED TO LIST A SOURCE LINE DURING THE INITIAL
19210: * COMPILATION. IT IS CALLED FROM SCANE AND SCANL.
19211: *
19212: * JSR LISTR CALL TO LIST LINE
19213: * (XR,XL,WA,WB,WC) DESTROYED
19214: *
19215: * GLOBAL LOCATIONS USED BY LISTR
19216: *
19217: * ERLST IF LISTING ON ACCOUNT OF AN ERROR
19218: *
19219: * LSTLC COUNT LINES ON CURRENT PAGE
19220: *
19221: * LSTNP MAX NUMBER OF LINES/PAGE
19222: *
19223: * LSTPF SET NON-ZERO IF THE CURRENT SOURCE
19224: * LINE HAS BEEN LISTED, ELSE ZERO.
19225: *
19226: * LSTPG COMPILER LISTING PAGE NUMBER
19227: *
19228: * LSTSN SET IF STMNT NUM TO BE LISTED
19229: *
19230: * R$CIM POINTER TO CURRENT INPUT LINE.
19231: *
19232: * R$TTL TITLE FOR SOURCE LISTING
19233: *
19234: * R$STL PTR TO SUB-TITLE STRING
19235: *
19236: * ENTRY POINT
19237: *
19238: LISTR PRC E,0 ENTRY POINT
19239: BNZ CNTTL,LIST5 JUMP IF -TITLE OR -STITL
19240: BNZ LSTPF,LIST4 IMMEDIATE EXIT IF ALREADY LISTED
19241: BGE LSTLC,LSTNP,LIST6 JUMP IF NO ROOM
19242: *
19243: * HERE AFTER PRINTING TITLE (IF NEEDED)
19244: *
19245: LIST0 MOV R$CIM,XR LOAD POINTER TO CURRENT IMAGE
19246: PLC XR POINT TO CHARACTERS
19247: LCH WA,(XR) LOAD FIRST CHARACTER
19248: MOV LSTSN,XR LOAD STATEMENT NUMBER
19249: BZE XR,LIST2 JUMP IF NO STATEMENT NUMBER
19250: MTI XR ELSE GET STMNT NUMBER AS INTEGER
19251: BNE STAGE,=STGIC,LIST1 SKIP IF EXECUTE TIME
19252: BEQ WA,=CH$AS,LIST2 NO STMNT NUMBER LIST IF COMMENT
19253: BEQ WA,=CH$MN,LIST2 NO STMNT NO. IF CONTROL CARD
19254: *
19255: * PRINT STATEMENT NUMBER
19256: *
19257: LIST1 JSR PRTIN ELSE PRINT STATEMENT NUMBER
19258: ZER LSTSN AND CLEAR FOR NEXT TIME IN
19259: EJC
19260: *
19261: * LISTR (CONTINUED)
19262: *
19263: * MERGE HERE AFTER PRINTING STATEMENT NUMBER (IF REQUIRED)
19264: *
19265: LIST2 MOV =STNPD,PROFS POINT PAST STATEMENT NUMBER
19266: MOV R$CIM,XR LOAD POINTER TO CURRENT IMAGE
19267: JSR PRTST PRINT IT
19268: ICV LSTLC BUMP LINE COUNTER
19269: BNZ ERLST,LIST3 JUMP IF ERROR COPY TO INT.CH.
19270: JSR PRTNL TERMINATE LINE
19271: BZE CSWDB,LIST3 JUMP IF -SINGLE MODE
19272: JSR PRTNL ELSE ADD A BLANK LINE
19273: ICV LSTLC AND BUMP LINE COUNTER
19274: *
19275: * HERE AFTER PRINTING SOURCE IMAGE
19276: *
19277: LIST3 MNZ LSTPF SET FLAG FOR LINE PRINTED
19278: *
19279: * MERGE HERE TO EXIT
19280: *
19281: LIST4 EXI RETURN TO LISTR CALLER
19282: *
19283: * PRINT TITLE AFTER -TITLE OR -STITL CARD
19284: *
19285: LIST5 ZER CNTTL CLEAR FLAG
19286: *
19287: * EJECT TO NEW PAGE AND LIST TITLE
19288: *
19289: LIST6 JSR PRTPS EJECT
19290: BZE PRICH,LIST7 SKIP IF LISTING TO REGULAR PRINTER
19291: BEQ R$TTL,=NULLS,LIST0 TERMINAL LISTING OMITS NULL TITLE
19292: *
19293: * LIST TITLE
19294: *
19295: LIST7 JSR LISTT LIST TITLE
19296: BRN LIST0 MERGE
19297: ENP END PROCEDURE LISTR
19298: EJC
19299: *
19300: * LISTT -- LIST TITLE AND SUBTITLE
19301: *
19302: * USED DURING COMPILATION TO PRINT PAGE HEADING
19303: *
19304: * JSR LISTT CALL TO LIST TITLE
19305: * (XR,WA) DESTROYED
19306: *
19307: LISTT PRC E,0 ENTRY POINT
19308: MOV R$TTL,XR POINT TO SOURCE LISTING TITLE
19309: JSR PRTST PRINT TITLE
19310: MOV LSTPO,PROFS SET OFFSET
19311: MOV =LSTMS,XR SET PAGE MESSAGE
19312: JSR PRTST PRINT PAGE MESSAGE
19313: ICV LSTPG BUMP PAGE NUMBER
19314: MTI LSTPG LOAD PAGE NUMBER AS INTEGER
19315: JSR PRTIN PRINT PAGE NUMBER
19316: JSR PRTNL TERMINATE TITLE LINE
19317: ADD =NUM02,LSTLC COUNT TITLE LINE AND BLANK LINE
19318: *
19319: * PRINT SUB-TITLE (IF ANY)
19320: *
19321: MOV R$STL,XR LOAD POINTER TO SUB-TITLE
19322: BZE XR,LSTT1 JUMP IF NO SUB-TITLE
19323: JSR PRTST ELSE PRINT SUB-TITLE
19324: JSR PRTNL TERMINATE LINE
19325: ICV LSTLC BUMP LINE COUNT
19326: *
19327: * RETURN POINT
19328: *
19329: LSTT1 JSR PRTNL PRINT A BLANK LINE
19330: EXI RETURN TO CALLER
19331: ENP END PROCEDURE LISTT
19332: EJC
19333: *
19334: * NEXTS -- ACQUIRE NEXT SOURCE IMAGE
19335: *
19336: * NEXTS IS USED TO ACQUIRE THE NEXT SOURCE IMAGE AT COMPILE
19337: * TIME. IT ASSUMES THAT A PRIOR CALL TO READR HAS INPUT
19338: * A LINE IMAGE (SEE PROCEDURE READR). BEFORE THE CURRENT
19339: * IMAGE IS FINALLY LOST IT MAY BE LISTED HERE.
19340: *
19341: * JSR NEXTS CALL TO ACQUIRE NEXT INPUT LINE
19342: * (XR,XL,WA,WB,WC) DESTROYED
19343: *
19344: * GLOBAL VALUES AFFECTED
19345: *
19346: * R$CNI ON INPUT, NEXT IMAGE. ON
19347: * EXIT RESET TO ZERO
19348: *
19349: * R$CIM ON EXIT, SET TO POINT TO IMAGE
19350: *
19351: * SCNIL INPUT IMAGE LENGTH ON EXIT
19352: *
19353: * SCNSE RESET TO ZERO ON EXIT
19354: *
19355: * LSTPF SET ON EXIT IF LINE IS LISTED
19356: *
19357: NEXTS PRC E,0 ENTRY POINT
19358: BZE CSWLS,NXTS2 JUMP IF -NOLIST
19359: MOV R$CIM,XR POINT TO IMAGE
19360: BZE XR,NXTS2 JUMP IF NO IMAGE
19361: PLC XR GET CHAR PTR
19362: LCH WA,(XR) GET FIRST CHAR
19363: BNE WA,=CH$MN,NXTS1 JUMP IF NOT CTRL CARD
19364: BZE CSWPR,NXTS2 JUMP IF -NOPRINT
19365: *
19366: * HERE TO CALL LISTER
19367: *
19368: NXTS1 JSR LISTR LIST LINE
19369: *
19370: * HERE AFTER POSSIBLE LISTING
19371: *
19372: NXTS2 MOV R$CNI,XR POINT TO NEXT IMAGE
19373: MOV XR,R$CIM SET AS NEXT IMAGE
19374: ZER R$CNI CLEAR NEXT IMAGE POINTER
19375: MOV SCLEN(XR),WA GET INPUT IMAGE LENGTH
19376: MOV CSWIN,WB GET MAX ALLOWABLE LENGTH
19377: BLO WA,WB,NXTS3 SKIP IF NOT TOO LONG
19378: MOV WB,WA ELSE TRUNCATE
19379: *
19380: * HERE WITH LENGTH IN (WA)
19381: *
19382: NXTS3 MOV WA,SCNIL USE AS RECORD LENGTH
19383: ZER SCNSE RESET SCNSE
19384: ZER LSTPF SET LINE NOT LISTED YET
19385: EXI RETURN TO NEXTS CALLER
19386: ENP END PROCEDURE NEXTS
19387: EJC
19388: *
19389: * PATIN -- PATTERN CONSTRUCTION FOR LEN,POS,RPOS,TAB,RTAB
19390: *
19391: * THESE PATTERN TYPES ALL GENERATE A SIMILAR NODE TYPE. SO
19392: * THE CONSTRUCTION CODE IS SHARED. SEE FUNCTIONS SECTION
19393: * FOR ACTUAL ENTRY POINTS FOR THESE FIVE FUNCTIONS.
19394: *
19395: * (WA) PCODE FOR EXPRESSION ARG CASE
19396: * (WB) PCODE FOR INTEGER ARG CASE
19397: * JSR PATIN CALL TO BUILD PATTERN NODE
19398: * PPM LOC TRANSFER LOC FOR NOT INTEGER OR EXP
19399: * PPM LOC TRANSFER LOC FOR INT OUT OF RANGE
19400: * (XR) POINTER TO CONSTRUCTED NODE
19401: * (XL,WA,WB,WC,IA) DESTROYED
19402: *
19403: PATIN PRC N,2 ENTRY POINT
19404: MOV WA,XL PRESERVE EXPRESSION ARG PCODE
19405: JSR GTSMI TRY TO CONVERT ARG AS SMALL INTEGER
19406: PPM PTIN2 JUMP IF NOT INTEGER
19407: PPM PTIN3 JUMP IF OUT OF RANGE
19408: *
19409: * COMMON SUCCESSFUL EXIT POINT
19410: *
19411: PTIN1 JSR PBILD BUILD PATTERN NODE
19412: EXI RETURN TO CALLER
19413: *
19414: * HERE IF ARGUMENT IS NOT AN INTEGER
19415: *
19416: PTIN2 MOV XL,WB COPY EXPR ARG CASE PCODE
19417: BLO (XR),=B$E$$,PTIN1 ALL OK IF EXPRESSION ARG
19418: EXI 1 ELSE TAKE ERROR EXIT FOR WRONG TYPE
19419: *
19420: * HERE FOR ERROR OF OUT OF RANGE INTEGER ARGUMENT
19421: *
19422: PTIN3 EXI 2 TAKE OUT-OF-RANGE ERROR EXIT
19423: ENP END PROCEDURE PATIN
19424: EJC
19425: *
19426: * PATST -- PATTERN CONSTRUCTION FOR ANY,NOTANY,
19427: * BREAK,SPAN AND BREAKX PATTERN FUNCTIONS.
19428: *
19429: * THESE PATTERN FUNCTIONS BUILD SIMILAR TYPES OF NODES AND
19430: * THE CONSTRUCTION CODE IS SHARED. SEE FUNCTIONS SECTION
19431: * FOR ACTUAL ENTRY POINTS FOR THESE FIVE PATTERN FUNCTIONS.
19432: *
19433: * 0(XS) STRING ARGUMENT
19434: * (WB) PCODE FOR ONE CHAR ARGUMENT
19435: * (XL) PCODE FOR MULTI-CHAR ARGUMENT
19436: * (WC) PCODE FOR EXPRESSION ARGUMENT
19437: * JSR PATST CALL TO BUILD NODE
19438: * PPM LOC TRANSFER LOC IF NOT STRING OR EXPR
19439: * (XS) POPPED PAST STRING ARGUMENT
19440: * (XR) POINTER TO CONSTRUCTED NODE
19441: * (XL) DESTROYED
19442: * (WA,WB,WC,RA) DESTROYED
19443: *
19444: * NOTE THAT THERE IS A SPECIAL CALL TO PATST IN THE EVALS
19445: * PROCEDURE WITH A SLIGHTLY DIFFERENT FORM. SEE EVALS
19446: * FOR DETAILS OF THE FORM OF THIS CALL.
19447: *
19448: PATST PRC N,1 ENTRY POINT
19449: JSR GTSTG CONVERT ARGUMENT AS STRING
19450: PPM PATS7 JUMP IF NOT STRING
19451: BNE WA,=NUM01,PATS2 JUMP IF NOT ONE CHAR STRING
19452: *
19453: * HERE FOR ONE CHAR STRING CASE
19454: *
19455: BZE WB,PATS2 TREAT AS MULTI-CHAR IF EVALS CALL
19456: PLC XR POINT TO CHARACTER
19457: LCH XR,(XR) LOAD CHARACTER
19458: *
19459: * COMMON EXIT POINT AFTER SUCCESSFUL CONSTRUCTION
19460: *
19461: PATS1 JSR PBILD CALL ROUTINE TO BUILD NODE
19462: EXI RETURN TO PATST CALLER
19463: EJC
19464: *
19465: * PATST (CONTINUED)
19466: *
19467: * HERE FOR MULTI-CHARACTER STRING CASE
19468: *
19469: PATS2 MOV XL,-(XS) SAVE MULTI-CHAR PCODE
19470: MOV XR,-(XS) SAVE STRING POINTER
19471: MOV CTMSK,WC LOAD CURRENT MASK BIT
19472: LSH WC,1 SHIFT TO NEXT POSITION
19473: NZB WC,PATS4 SKIP IF POSITION LEFT IN THIS TBL
19474: *
19475: * HERE WE MUST ALLOCATE A NEW CHARACTER TABLE
19476: *
19477: MOV *CTSI$,WA SET SIZE OF CTBLK
19478: JSR ALLOC ALLOCATE CTBLK
19479: MOV XR,R$CTP STORE PTR TO NEW CTBLK
19480: MOV =B$CTT,(XR)+ STORE TYPE CODE, BUMP PTR
19481: LCT WB,=CFP$A SET NUMBER OF WORDS TO CLEAR
19482: MOV BITS0,WC LOAD ALL ZERO BITS
19483: *
19484: * LOOP TO CLEAR ALL BITS IN TABLE TO ZEROS
19485: *
19486: PATS3 MOV WC,(XR)+ MOVE WORD OF ZERO BITS
19487: BCT WB,PATS3 LOOP TILL ALL CLEARED
19488: MOV BITS1,WC SET INITIAL BIT POSITION
19489: *
19490: * MERGE HERE WITH BIT POSITION AVAILABLE
19491: *
19492: PATS4 MOV WC,CTMSK SAVE PARM2 (NEW BIT POSITION)
19493: MOV (XS)+,XL RESTORE POINTER TO ARGUMENT STRING
19494: MOV SCLEN(XL),WB LOAD STRING LENGTH
19495: BZE WB,PATS6 JUMP IF NULL STRING CASE
19496: LCT WB,WB ELSE SET LOOP COUNTER
19497: PLC XL POINT TO CHARACTERS IN ARGUMENT
19498: EJC
19499: *
19500: * PATST (CONTINUED)
19501: *
19502: * LOOP TO SET BITS IN COLUMN OF TABLE
19503: *
19504: PATS5 LCH WA,(XL)+ LOAD NEXT CHARACTER
19505: WTB WA CONVERT TO BYTE OFFSET
19506: MOV R$CTP,XR POINT TO CTBLK
19507: ADD WA,XR POINT TO CTBLK ENTRY
19508: MOV WC,WA COPY BIT MASK
19509: ORB CTCHS(XR),WA OR IN BITS ALREADY SET
19510: MOV WA,CTCHS(XR) STORE RESULTING BIT STRING
19511: BCT WB,PATS5 LOOP TILL ALL BITS SET
19512: *
19513: * COMPLETE PROCESSING FOR MUTI-CHAR STRING CASE
19514: *
19515: PATS6 MOV R$CTP,XR LOAD CTBLK PTR AS PARM1 FOR PBILD
19516: ZER XL CLEAR GARBAGE PTR IN XL
19517: MOV (XS)+,WB LOAD PCODE FOR MULTI-CHAR STR CASE
19518: BRN PATS1 BACK TO EXIT (WC=BITSTRING=PARM2)
19519: *
19520: * HERE IF ARGUMENT IS NOT A STRING
19521: *
19522: * NOTE THAT THE CALL FROM EVALS CANNOT PASS AN EXPRESSION
19523: * SINCE EVALP ALWAYS REEVALUATES EXPRESSIONS.
19524: *
19525: PATS7 MOV WC,WB SET PCODE FOR EXPRESSION ARGUMENT
19526: BLO (XR),=B$E$$,PATS1 JUMP TO EXIT IF EXPRESSION ARG
19527: EXI 1 ELSE TAKE WRONG TYPE ERROR EXIT
19528: ENP END PROCEDURE PATST
19529: EJC
19530: *
19531: * PBILD -- BUILD PATTERN NODE
19532: *
19533: * (XR) PARM1 (ONLY IF REQUIRED)
19534: * (WB) PCODE FOR NODE
19535: * (WC) PARM2 (ONLY IF REQUIRED)
19536: * JSR PBILD CALL TO BUILD NODE
19537: * (XR) POINTER TO CONSTRUCTED NODE
19538: * (WA) DESTROYED
19539: *
19540: PBILD PRC E,0 ENTRY POINT
19541: MOV XR,-(XS) STACK POSSIBLE PARM1
19542: MOV WB,XR COPY PCODE
19543: LEI XR LOAD ENTRY POINT ID (BL$PX)
19544: BEQ XR,=BL$P1,PBLD1 JUMP IF ONE PARAMETER
19545: BEQ XR,=BL$P0,PBLD3 JUMP IF NO PARAMETERS
19546: *
19547: * HERE FOR TWO PARAMETER CASE
19548: *
19549: MOV *PCSI$,WA SET SIZE OF P2BLK
19550: JSR ALLOC ALLOCATE BLOCK
19551: MOV WC,PARM2(XR) STORE SECOND PARAMETER
19552: BRN PBLD2 MERGE WITH ONE PARM CASE
19553: *
19554: * HERE FOR ONE PARAMETER CASE
19555: *
19556: PBLD1 MOV *PBSI$,WA SET SIZE OF P1BLK
19557: JSR ALLOC ALLOCATE NODE
19558: *
19559: * MERGE HERE FROM TWO PARM CASE
19560: *
19561: PBLD2 MOV (XS),PARM1(XR) STORE FIRST PARAMETER
19562: BRN PBLD4 MERGE WITH NO PARAMETER CASE
19563: *
19564: * HERE FOR CASE OF NO PARAMETERS
19565: *
19566: PBLD3 MOV *PASI$,WA SET SIZE OF P0BLK
19567: JSR ALLOC ALLOCATE NODE
19568: *
19569: * MERGE HERE FROM OTHER CASES
19570: *
19571: PBLD4 MOV WB,(XR) STORE PCODE
19572: ICA XS POP FIRST PARAMETER
19573: MOV =NDNTH,PTHEN(XR) SET NOTHEN SUCCESSOR POINTER
19574: EXI RETURN TO PBILD CALLER
19575: ENP END PROCEDURE PBILD
19576: EJC
19577: *
19578: * PCONC -- CONCATENATE TWO PATTERNS
19579: *
19580: * (XL) PTR TO RIGHT PATTERN
19581: * (XR) PTR TO LEFT PATTERN
19582: * JSR PCONC CALL TO CONCATENATE PATTERNS
19583: * (XR) PTR TO CONCATENATED PATTERN
19584: * (XL,WA,WB,WC) DESTROYED
19585: *
19586: *
19587: * TO CONCATENATE TWO PATTERNS, ALL SUCCESSORS IN THE LEFT
19588: * PATTERN WHICH POINT TO THE NOTHEN NODE MUST BE CHANGED TO
19589: * POINT TO THE RIGHT PATTERN. HOWEVER, THIS MODIFICATION
19590: * MUST BE PERFORMED ON A COPY OF THE LEFT ARGUMENT RATHER
19591: * THAN THE LEFT ARGUMENT ITSELF, SINCE THE LEFT ARGUMENT
19592: * MAY BE POINTED TO BY SOME OTHER VARIABLE VALUE.
19593: *
19594: * ACCORDINGLY, IT IS NECESSARY TO COPY THE LEFT ARGUMENT.
19595: * THIS IS NOT A TRIVIAL PROCESS SINCE WE MUST AVOID COPYING
19596: * NODES MORE THAN ONCE AND THE PATTERN IS A GRAPH STRUCTURE
19597: * THE FOLLOWING ALGORITHM IS EMPLOYED.
19598: *
19599: * THE STACK IS USED TO STORE A LIST OF NODES WHICH
19600: * HAVE ALREADY BEEN COPIED. THE FORMAT OF THE ENTRIES ON
19601: * THIS LIST CONSISTS OF A TWO WORD BLOCK. THE FIRST WORD
19602: * IS THE OLD ADDRESS AND THE SECOND WORD IS THE ADDRESS
19603: * OF THE COPY. THIS LIST IS SEARCHED BY THE PCOPY
19604: * ROUTINE TO AVOID MAKING DUPLICATE COPIES. A TRICK IS
19605: * USED TO ACCOMPLISH THE CONCATENATION AT THE SAME TIME.
19606: * A SPECIAL ENTRY IS MADE TO START WITH ON THE STACK. THIS
19607: * ENTRY RECORDS THAT THE NOTHEN NODE HAS BEEN COPIED
19608: * ALREADY AND THE ADDRESS OF ITS COPY IS THE RIGHT PATTERN.
19609: * THIS AUTOMATICALLY PERFORMS THE CORRECT REPLACEMENTS.
19610: *
19611: PCONC PRC E,0 ENTRY POINT
19612: ZER -(XS) MAKE ROOM FOR ONE ENTRY AT BOTTOM
19613: MOV XS,WC STORE POINTER TO START OF LIST
19614: MOV =NDNTH,-(XS) STACK NOTHEN NODE AS OLD NODE
19615: MOV XL,-(XS) STORE RIGHT ARG AS COPY OF NOTHEN
19616: MOV XS,XT INITIALIZE POINTER TO STACK ENTRIES
19617: JSR PCOPY COPY FIRST NODE OF LEFT ARG
19618: MOV WA,2(XT) STORE AS RESULT UNDER LIST
19619: EJC
19620: *
19621: * PCONC (CONTINUED)
19622: *
19623: * THE FOLLOWING LOOP SCANS ENTRIES IN THE LIST AND MAKES
19624: * SURE THAT THEIR SUCCESSORS HAVE BEEN COPIED.
19625: *
19626: PCNC1 BEQ XT,XS,PCNC2 JUMP IF ALL ENTRIES PROCESSED
19627: MOV -(XT),XR ELSE LOAD NEXT OLD ADDRESS
19628: MOV PTHEN(XR),XR LOAD POINTER TO SUCCESSOR
19629: JSR PCOPY COPY SUCCESSOR NODE
19630: MOV -(XT),XR LOAD POINTER TO NEW NODE (COPY)
19631: MOV WA,PTHEN(XR) STORE PTR TO NEW SUCCESSOR
19632: *
19633: * NOW CHECK FOR SPECIAL CASE OF ALTERNATION NODE WHERE
19634: * PARM1 POINTS TO A NODE AND MUST BE COPIED LIKE PTHEN.
19635: *
19636: BNE (XR),=P$ALT,PCNC1 LOOP BACK IF NOT
19637: MOV PARM1(XR),XR ELSE LOAD POINTER TO ALTERNATIVE
19638: JSR PCOPY COPY IT
19639: MOV (XT),XR RESTORE PTR TO NEW NODE
19640: MOV WA,PARM1(XR) STORE PTR TO COPIED ALTERNATIVE
19641: BRN PCNC1 LOOP BACK FOR NEXT ENTRY
19642: *
19643: * HERE AT END OF COPY PROCESS
19644: *
19645: PCNC2 MOV WC,XS RESTORE STACK POINTER
19646: MOV (XS)+,XR LOAD POINTER TO COPY
19647: EXI RETURN TO PCONC CALLER
19648: ENP END PROCEDURE PCONC
19649: EJC
19650: *
19651: * PCOPY -- COPY A PATTERN NODE
19652: *
19653: * PCOPY IS CALLED FROM THE PCONC PROCEDURE TO COPY A SINGLE
19654: * PATTERN NODE. THE COPY IS ONLY CARRIED OUT IF THE NODE
19655: * HAS NOT BEEN COPIED ALREADY.
19656: *
19657: * (XR) POINTER TO NODE TO BE COPIED
19658: * (XT) PTR TO CURRENT LOC IN COPY LIST
19659: * (WC) POINTER TO LIST OF COPIED NODES
19660: * JSR PCOPY CALL TO COPY A NODE
19661: * (WA) POINTER TO COPY
19662: * (WB,XR) DESTROYED
19663: *
19664: PCOPY PRC N,0 ENTRY POINT
19665: MOV XT,WB SAVE XT
19666: MOV WC,XT POINT TO START OF LIST
19667: *
19668: * LOOP TO SEARCH LIST OF NODES COPIED ALREADY
19669: *
19670: PCOP1 DCA XT POINT TO NEXT ENTRY ON LIST
19671: BEQ XR,(XT),PCOP2 JUMP IF MATCH
19672: DCA XT ELSE SKIP OVER COPIED ADDRESS
19673: BNE XT,XS,PCOP1 LOOP BACK IF MORE TO TEST
19674: *
19675: * HERE IF NOT IN LIST, PERFORM COPY
19676: *
19677: MOV (XR),WA LOAD FIRST WORD OF BLOCK
19678: JSR BLKLN GET LENGTH OF BLOCK
19679: MOV XR,XL SAVE POINTER TO OLD NODE
19680: JSR ALLOC ALLOCATE SPACE FOR COPY
19681: MOV XL,-(XS) STORE OLD ADDRESS ON LIST
19682: MOV XR,-(XS) STORE NEW ADDRESS ON LIST
19683: CHK CHECK FOR STACK OVERFLOW
19684: MVW MOVE WORDS FROM OLD BLOCK TO COPY
19685: MOV (XS),WA LOAD POINTER TO COPY
19686: BRN PCOP3 JUMP TO EXIT
19687: *
19688: * HERE IF WE FIND ENTRY IN LIST
19689: *
19690: PCOP2 MOV -(XT),WA LOAD ADDRESS OF COPY FROM LIST
19691: *
19692: * COMMON EXIT POINT
19693: *
19694: PCOP3 MOV WB,XT RESTORE XT
19695: EXI RETURN TO PCOPY CALLER
19696: ENP END PROCEDURE PCOPY
19697: EJC
19698: .IF .CNPF
19699: .ELSE
19700: *
19701: * PRFLR -- PRINT PROFILE
19702: * PRFLR IS CALLED TO PRINT THE CONTENTS OF THE PROFILE
19703: * TABLE IN A FAIRLY READABLE TABULAR FORMAT.
19704: *
19705: * JSR PRFLR CALL TO PRINT PROFILE
19706: * (WA,IA) DESTROYED
19707: *
19708: PRFLR PRC E,0
19709: BZE PFDMP,PRFL4 NO PRINTING IF NO PROFILING DONE
19710: MOV XR,-(XS) PRESERVE ENTRY XR
19711: MOV WB,PFSVW AND ALSO WB
19712: JSR PRTPG EJECT
19713: MOV =PFMS1,XR LOAD MSG /PROGRAM PROFILE/
19714: JSR PRTST AND PRINT IT
19715: JSR PRTNL FOLLOWED BY NEWLINE
19716: JSR PRTNL AND ANOTHER
19717: MOV =PFMS2,XR POINT TO FIRST HDR
19718: JSR PRTST PRINT IT
19719: JSR PRTNL NEW LINE
19720: MOV =PFMS3,XR SECOND HDR
19721: JSR PRTST PRINT IT
19722: JSR PRTNL NEW LINE
19723: JSR PRTNL AND ANOTHER BLANK LINE
19724: ZER WB INITIAL STMT COUNT
19725: MOV PFTBL,XR POINT TO TABLE ORIGIN
19726: ADD *NUM02,XR BIAS PAST XNBLK HEADER (SGD07)
19727: *
19728: * LOOP HERE TO PRINT SUCCESSIVE ENTRIES
19729: *
19730: PRFL1 ICV WB BUMP STMT NR
19731: LDI (XR) LOAD NR OF EXECUTIONS
19732: IEQ PRFL3 NO PRINTING IF ZERO
19733: MOV =PFPD1,PROFS POINT WHERE TO PRINT
19734: JSR PRTIN AND PRINT IT
19735: ZER PROFS BACK TO START OF LINE
19736: MTI WB LOAD STMT NR
19737: JSR PRTIN PRINT IT THERE
19738: MOV =PFPD2,PROFS AND PAD PAST COUNT
19739: LDI CFP$I(XR) LOAD TOTAL EXEC TIME
19740: JSR PRTIN PRINT THAT TOO
19741: LDI CFP$I(XR) RELOAD TIME
19742: MLI INTTH CONVERT TO MICROSEC
19743: IOV PRFL2 OMIT NEXT BIT IF OVERFLOW
19744: DVI (XR) DIVIDE BY EXECUTIONS
19745: MOV =PFPD3,PROFS PAD LAST PRINT
19746: JSR PRTIN AND PRINT MCSEC/EXECN
19747: *
19748: * MERGE AFTER PRINTING TIME
19749: *
19750: PRFL2 JSR PRTNL THATS ANOTHER LINE
19751: *
19752: * HERE TO GO TO NEXT ENTRY
19753: *
19754: PRFL3 ADD *PF$I2,XR BUMP INDEX PTR (SGD07)
19755: BLT WB,PFNTE,PRFL1 LOOP IF MORE STMTS
19756: MOV (XS)+,XR RESTORE CALLERS XR
19757: MOV PFSVW,WB AND WB TOO
19758: *
19759: * HERE TO EXIT
19760: *
19761: PRFL4 EXI RETURN
19762: ENP END OF PRFLR
19763: EJC
19764: *
19765: * PRFLU -- UPDATE AN ENTRY IN THE PROFILE TABLE
19766: *
19767: * ON ENTRY, KVSTN CONTAINS NR OF STMT TO PROFILE
19768: *
19769: * JSR PRFLU CALL TO UPDATE ENTRY
19770: * (IA) DESTROYED
19771: *
19772: PRFLU PRC E,0
19773: BNZ PFFNC,PFLU4 SKIP IF JUST ENTERED FUNCTION
19774: MOV XR,-(XS) PRESERVE ENTRY XR
19775: MOV WA,PFSVW SAVE WA (SGD07)
19776: BNZ PFTBL,PFLU2 BRANCH IF TABLE ALLOCATED
19777: *
19778: * HERE IF SPACE FOR PROFILE TABLE NOT YET ALLOCATED.
19779: * CALCULATE SIZE NEEDED, ALLOCATE A STATIC XNBLK, AND
19780: * INITIALIZE IT ALL TO ZERO.
19781: * THE TIME TAKEN FOR THIS WILL BE ATTRIBUTED TO THE CURRENT
19782: * STATEMENT (ASSIGNMENT TO KEYWD PROFILE), BUT SINCE THE
19783: * TIMING FOR THIS STATEMENT IS UP THE POLE ANYWAY, THIS
19784: * DOESNT REALLY MATTER...
19785: *
19786: SUB =NUM01,PFNTE ADJUST FOR EXTRA COUNT (SGD07)
19787: MTI PFI2A CONVRT ENTRY SIZE TO INT
19788: STI PFSTE AND STORE SAFELY FOR LATER
19789: MTI PFNTE LOAD TABLE LENGTH AS INTEGER
19790: MLI PFSTE MULTIPLY BY ENTRY SIZE
19791: MFI WA GET BACK ADDRESS-STYLE
19792: ADD =NUM02,WA ADD ON 2 WORD OVERHEAD
19793: WTB WA CONVERT THE WHOLE LOT TO BYTES
19794: JSR ALOST GIMME THE SPACE
19795: MOV XR,PFTBL SAVE BLOCK POINTER
19796: MOV =B$XNT,(XR)+ PUT BLOCK TYPE AND ...
19797: MOV WA,(XR)+ ... LENGTH INTO HEADER
19798: MFI WA GET BACK NR OF WDS IN DATA AREA
19799: LCT WA,WA LOAD THE COUNTER
19800: *
19801: * LOOP HERE TO ZERO THE BLOCK DATA
19802: *
19803: PFLU1 ZER (XR)+ BLANK A WORD
19804: BCT WA,PFLU1 AND ALLLLLLL THE REST
19805: *
19806: * END OF ALLOCATION. MERGE BACK INTO ROUTINE
19807: *
19808: PFLU2 MTI KVSTN LOAD NR OF STMT JUST ENDED
19809: SBI INTV1 MAKE INTO INDEX OFFSET
19810: MLI PFSTE MAKE OFFSET OF TABLE ENTRY
19811: MFI WA CONVERT TO ADDRESS
19812: WTB WA GET AS BAUS
19813: ADD *NUM02,WA OFFSET INCLUDES TABLE HEADER
19814: MOV PFTBL,XR GET TABLE START
19815: BGE WA,NUM01(XR),PFLU3 IF OUT OF TABLE, SKIP IT
19816: ADD WA,XR ELSE POINT TO ENTRY
19817: LDI (XR) GET NR OF EXECUTIONS SO FAR
19818: ADI INTV1 NUDGE UP ONE
19819: STI (XR) AND PUT BACK
19820: JSR SYSTM GET TIME NOW
19821: STI PFETM STASH ENDING TIME
19822: SBI PFSTM SUBTRACT START TIME
19823: ADI CFP$I(XR) ADD CUMULATIVE TIME SO FAR
19824: STI CFP$I(XR) AND PUT BACK NEW TOTAL
19825: LDI PFETM LOAD END TIME OF THIS STMT ...
19826: STI PFSTM ... WHICH IS START TIME OF NEXT
19827: *
19828: * MERGE HERE TO EXIT
19829: *
19830: PFLU3 MOV (XS)+,XR RESTORE CALLERS XR
19831: MOV PFSVW,WA RESTORE SAVED REG
19832: EXI AND RETURN
19833: *
19834: * HERE IF PROFILE IS SUPPRESSED BECAUSE A PROGRAM DEFINED
19835: * FUNCTION IS ABOUT TO BE ENTERED, AND SO THE CURRENT STMT
19836: * HAS NOT YET FINISHED
19837: *
19838: PFLU4 ZER PFFNC RESET THE CONDITION FLAG
19839: EXI AND IMMEDIATE RETURN
19840: ENP END OF PROCEDURE PRFLU
19841: EJC
19842: .FI
19843: *
19844: * PRPAR - PROCESS PRINT PARAMETERS
19845: *
19846: * (WC) IF NONZERO ASSOCIATE TERMINAL ONLY
19847: * JSR PRPAR CALL TO PROCESS PRINT PARAMETERS
19848: * (XL,XR,WA,WB,WC) DESTROYED
19849: *
19850: * SINCE MEMORY ALLOCATION IS UNDECIDED ON INITIAL CALL,
19851: * TERMINAL CANNOT BE ASSOCIATED. THE ENTRY WITH WC NON-ZERO
19852: * IS PROVIDED SO A LATER CALL CAN BE MADE TO COMPLETE THIS.
19853: *
19854: PRPAR PRC E,0 ENTRY POINT
19855: BNZ WC,PRPA7 JUMP TO ASSOCIATE TERMINAL
19856: JSR SYSPP GET PRINT PARAMETERS
19857: BNZ WB,PRPA1 JUMP IF LINES/PAGE SPECIFIED
19858: MOV =CFP$M,WB ELSE USE A LARGE VALUE
19859: RSH WB,1 BUT NOT TOO LARGE
19860: *
19861: * STORE LINE COUNT/PAGE
19862: *
19863: PRPA1 MOV WB,LSTNP STORE NUMBER OF LINES/PAGE
19864: MOV WB,LSTLC PRETEND PAGE IS FULL INITIALLY
19865: ZER LSTPG CLEAR PAGE NUMBER
19866: MOV PRLEN,WB GET PRIOR LENGTH IF ANY
19867: BZE WB,PRPA2 SKIP IF NO LENGTH
19868: BGT WA,WB,PRPA3 SKIP STORING IF TOO BIG
19869: *
19870: * STORE PRINT BUFFER LENGTH
19871: *
19872: PRPA2 MOV WA,PRLEN STORE VALUE
19873: *
19874: * PROCESS BITS OPTIONS
19875: *
19876: PRPA3 MOV BITS3,WB BIT 3 MASK
19877: ANB WC,WB GET -NOLIST BIT
19878: ZRB WB,PRPA4 SKIP IF CLEAR
19879: ZER CSWLS SET -NOLIST
19880: *
19881: * CHECK IF FAIL REPORTS GOTO INTERACTIVE CHANNEL
19882: *
19883: PRPA4 MOV BITS1,WB BIT 1 MASK
19884: ANB WC,WB GET BIT
19885: MOV WB,ERICH STORE INT. CHAN. ERROR FLAG
19886: MOV BITS2,WB BIT 2 MASK
19887: ANB WC,WB GET BIT
19888: MOV WB,PRICH FLAG FOR STD PRINTER ON INT. CHAN.
19889: MOV BITS4,WB BIT 4 MASK
19890: ANB WC,WB GET BIT
19891: MOV WB,CPSTS FLAG FOR COMPILE STATS SUPPRESSN.
19892: MOV BITS5,WB BIT 5 MASK
19893: ANB WC,WB GET BIT
19894: MOV WB,EXSTS FLAG FOR EXEC STATS SUPPRESSION
19895: EJC
19896: *
19897: * PRPAR (CONTINUED)
19898: *
19899: MOV BITS6,WB BIT 6 MASK
19900: ANB WC,WB GET BIT
19901: MOV WB,PRECL EXTENDED/COMPACT LISTING FLAG
19902: SUB =NUM08,WA POINT 8 CHARS FROM LINE END
19903: ZRB WB,PRPA5 JUMP IF NOT EXTENDED
19904: MOV WA,LSTPO STORE FOR LISTING PAGE HEADINGS
19905: *
19906: * CONTINUE OPTION PROCESSING
19907: *
19908: PRPA5 MOV BITS7,WB BIT 7 MASK
19909: ANB WC,WB GET BIT 7
19910: MOV WB,CSWEX SET -NOEXECUTE IF NON-ZERO
19911: MOV BIT10,WB BIT 10 MASK
19912: ANB WC,WB GET BIT 10
19913: MOV WB,HEADP PRETEND PRINTED TO OMIT HEADERS
19914: MOV BITS9,WB BIT 9 MASK
19915: ANB WC,WB GET BIT 9
19916: MOV WB,PRSTO KEEP IT AS STD LISTING OPTION
19917: ZRB WB,PRPA6 SKIP IF CLEAR
19918: MOV PRLEN,WA GET PRINT BUFFER LENGTH
19919: SUB =NUM08,WA POINT 8 CHARS FROM LINE END
19920: MOV WA,LSTPO STORE PAGE OFFSET
19921: *
19922: * CHECK FOR TERMINAL
19923: *
19924: PRPA6 ANB BITS8,WC SEE IF TERMINAL TO BE ACTIVATED
19925: BNZ WC,PRPA7 JUMP IF TERMINAL REQUIRED
19926: BZE INITR,PRPA8 JUMP IF NO TERMINAL TO DETACH
19927: MOV =V$TER,XL PTR TO /TERMINAL/
19928: JSR GTNVR GET VRBLK POINTER
19929: PPM CANT FAIL
19930: MOV =NULLS,VRVAL(XR) CLEAR VALUE OF TERMINAL
19931: JSR SETVR REMOVE ASSOCIATION
19932: BRN PRPA8 RETURN
19933: *
19934: * ASSOCIATE TERMINAL
19935: *
19936: PRPA7 MNZ INITR NOTE TERMINAL ASSOCIATED
19937: BZE DNAMB,PRPA8 CANT IF MEMORY NOT ORGANISED
19938: MOV =V$TER,XL POINT TO TERMINAL STRING
19939: MOV =TRTOU,WB OUTPUT TRACE TYPE
19940: JSR INOUT ATTACH OUTPUT TRBLK TO VRBLK
19941: MOV XR,-(XS) STACK TRBLK PTR
19942: MOV =V$TER,XL POINT TO TERMINAL STRING
19943: MOV =TRTIN,WB INPUT TRACE TYPE
19944: JSR INOUT ATTACH INPUT TRACE BLK
19945: MOV (XS)+,VRVAL(XR) ADD OUTPUT TRBLK TO CHAIN
19946: *
19947: * RETURN POINT
19948: *
19949: PRPA8 EXI RETURN
19950: ENP END PROCEDURE PRPAR
19951: EJC
19952: *
19953: * PRTCH -- PRINT A CHARACTER
19954: *
19955: * PRTCH IS USED TO PRINT A SINGLE CHARACTER
19956: *
19957: * (WA) CHARACTER TO BE PRINTED
19958: * JSR PRTCH CALL TO PRINT CHARACTER
19959: *
19960: PRTCH PRC E,0 ENTRY POINT
19961: MOV XR,-(XS) SAVE XR
19962: BNE PROFS,PRLEN,PRCH1 JUMP IF ROOM IN BUFFER
19963: JSR PRTNL ELSE PRINT THIS LINE
19964: *
19965: * HERE AFTER MAKING SURE WE HAVE ROOM
19966: *
19967: PRCH1 MOV PRBUF,XR POINT TO PRINT BUFFER
19968: PSC XR,PROFS POINT TO NEXT CHARACTER LOCATION
19969: SCH WA,(XR) STORE NEW CHARACTER
19970: CSC XR COMPLETE STORE CHARACTERS
19971: ICV PROFS BUMP POINTER
19972: MOV (XS)+,XR RESTORE ENTRY XR
19973: EXI RETURN TO PRTCH CALLER
19974: ENP END PROCEDURE PRTCH
19975: EJC
19976: *
19977: * PRTIC -- PRINT TO INTERACTIVE CHANNEL
19978: *
19979: * PRTIC IS CALLED TO PRINT THE CONTENTS OF THE STANDARD
19980: * PRINT BUFFER TO THE INTERACTIVE CHANNEL. IT IS ONLY
19981: * CALLED AFTER PRTST HAS SET UP THE STRING FOR PRINTING.
19982: * IT DOES NOT CLEAR THE BUFFER.
19983: *
19984: * JSR PRTIC CALL FOR PRINT
19985: * (WA,WB) DESTROYED
19986: *
19987: PRTIC PRC E,0 ENTRY POINT
19988: MOV XR,-(XS) SAVE XR
19989: MOV PRBUF,XR POINT TO BUFFER
19990: MOV PROFS,WA NO OF CHARS
19991: JSR SYSPI PRINT
19992: PPM PRTC2 FAIL RETURN
19993: *
19994: * RETURN
19995: *
19996: PRTC1 MOV (XS)+,XR RESTORE XR
19997: EXI RETURN
19998: *
19999: * ERROR OCCURED
20000: *
20001: PRTC2 ZER ERICH PREVENT LOOPING
20002: ERB 252,ERROR ON PRINTING TO INTERACTIVE CHANNEL
20003: BRN PRTC1 RETURN
20004: ENP PROCEDURE PRTIC
20005: EJC
20006: *
20007: * PRTIS -- PRINT TO INTERACTIVE AND STANDARD PRINTER
20008: *
20009: * PRTIS PUTS A LINE FROM THE PRINT BUFFER ONTO THE
20010: * INTERACTIVE CHANNEL (IF ANY) AND THE STANDARD PRINTER.
20011: * IT ALWAYS PRINTS TO THE STANDARD PRINTER BUT DOES
20012: * NOT DUPLICATE LINES IF THE STANDARD PRINTER IS
20013: * INTERACTIVE. IT CLEARS DOWN THE PRINT BUFFER.
20014: *
20015: * JSR PRTIS CALL FOR PRINTING
20016: * (WA,WB) DESTROYED
20017: *
20018: PRTIS PRC E,0 ENTRY POINT
20019: BNZ PRICH,PRTS1 JUMP IF STANDARD PRINTER IS INT.CH.
20020: BZE ERICH,PRTS1 SKIP IF NOT DOING INT. ERROR REPS.
20021: JSR PRTIC PRINT TO INTERACTIVE CHANNEL
20022: *
20023: * MERGE AND EXIT
20024: *
20025: PRTS1 JSR PRTNL PRINT TO STANDARD PRINTER
20026: EXI RETURN
20027: ENP END PROCEDURE PRTIS
20028: EJC
20029: *
20030: * PRTIN -- PRINT AN INTEGER
20031: *
20032: * PRTIN PRINTS THE INTEGER VALUE WHICH IS IN THE INTEGER
20033: * ACCUMULATOR. BLOCKS BUILT IN DYNAMIC STORAGE
20034: * DURING THIS PROCESS ARE IMMEDIATELY DELETED.
20035: *
20036: * (IA) INTEGER VALUE TO BE PRINTED
20037: * JSR PRTIN CALL TO PRINT INTEGER
20038: * (IA,RA) DESTROYED
20039: *
20040: PRTIN PRC E,0 ENTRY POINT
20041: MOV XR,-(XS) SAVE XR
20042: JSR ICBLD BUILD INTEGER BLOCK
20043: BLO XR,DNAMB,PRTI1 JUMP IF ICBLK BELOW DYNAMIC
20044: BHI XR,DNAMP,PRTI1 JUMP IF ABOVE DYNAMIC
20045: MOV XR,DNAMP IMMEDIATELY DELETE IT
20046: *
20047: * DELETE ICBLK FROM DYNAMIC STORE
20048: *
20049: PRTI1 MOV XR,-(XS) STACK PTR FOR GTSTG
20050: JSR GTSTG CONVERT TO STRING
20051: PPM CONVERT ERROR IS IMPOSSIBLE
20052: MOV XR,DNAMP RESET POINTER TO DELETE SCBLK
20053: JSR PRTST PRINT INTEGER STRING
20054: MOV (XS)+,XR RESTORE ENTRY XR
20055: EXI RETURN TO PRTIN CALLER
20056: ENP END PROCEDURE PRTIN
20057: EJC
20058: *
20059: * PRTMI -- PRINT MESSAGE AND INTEGER
20060: *
20061: * PRTMI IS USED TO PRINT MESSAGES TOGETHER WITH AN INTEGER
20062: * VALUE STARTING IN COLUMN 15 (USED BY THE ROUTINES AT
20063: * THE END OF COMPILATION).
20064: *
20065: * JSR PRTMI CALL TO PRINT MESSAGE AND INTEGER
20066: *
20067: PRTMI PRC E,0 ENTRY POINT
20068: JSR PRTST PRINT STRING MESSAGE
20069: MOV =PRTMF,PROFS SET OFFSET TO COL 15
20070: JSR PRTIN PRINT INTEGER
20071: JSR PRTNL PRINT LINE
20072: EXI RETURN TO PRTMI CALLER
20073: ENP END PROCEDURE PRTMI
20074: EJC
20075: *
20076: * PRTMX -- AS PRTMI WITH EXTRA COPY TO INTERACTIVE CHAN.
20077: *
20078: * JSR PRTMX CALL FOR PRINTING
20079: * (WA,WB) DESTROYED
20080: *
20081: PRTMX PRC E,0 ENTRY POINT
20082: JSR PRTST PRINT STRING MESSAGE
20083: MOV =PRTMF,PROFS SET PTR TO COLUMN 15
20084: JSR PRTIN PRINT INTEGER
20085: JSR PRTIS PRINT LINE
20086: EXI RETURN
20087: ENP END PROCEDURE PRTMX
20088: EJC
20089: *
20090: * PRTNL -- PRINT NEW LINE (END PRINT LINE)
20091: *
20092: * PRTNL PRINTS THE CONTENTS OF THE PRINT BUFFER, RESETS
20093: * THE BUFFER TO ALL BLANKS AND RESETS THE PRINT POINTER.
20094: *
20095: * JSR PRTNL CALL TO PRINT LINE
20096: *
20097: PRTNL PRC R,0 ENTRY POINT
20098: BNZ HEADP,PRNL0 WERE HEADERS PRINTED
20099: JSR PRTPS NO - PRINT THEM
20100: *
20101: * CALL SYSPR
20102: *
20103: PRNL0 MOV XR,-(XS) SAVE ENTRY XR
20104: MOV WA,PRTSA SAVE WA
20105: MOV WB,PRTSB SAVE WB
20106: MOV PRBUF,XR LOAD POINTER TO BUFFER
20107: MOV PROFS,WA LOAD NUMBER OF CHARS IN BUFFER
20108: JSR SYSPR CALL SYSTEM PRINT ROUTINE
20109: PPM PRNL2 JUMP IF FAILED
20110: LCT WA,PRLNW LOAD LENGTH OF BUFFER IN WORDS
20111: ADD *SCHAR,XR POINT TO CHARS OF BUFFER
20112: MOV NULLW,WB GET WORD OF BLANKS
20113: *
20114: * LOOP TO BLANK BUFFER
20115: *
20116: PRNL1 MOV WB,(XR)+ STORE WORD OF BLANKS, BUMP PTR
20117: BCT WA,PRNL1 LOOP TILL ALL BLANKED
20118: *
20119: * EXIT POINT
20120: *
20121: MOV PRTSB,WB RESTORE WB
20122: MOV PRTSA,WA RESTORE WA
20123: MOV (XS)+,XR RESTORE ENTRY XR
20124: ZER PROFS RESET PRINT BUFFER POINTER
20125: EXI RETURN TO PRTNL CALLER
20126: *
20127: * FILE FULL OR NO OUTPUT FILE FOR LOAD MODULE
20128: *
20129: PRNL2 BNZ PRTEF,PRNL3 JUMP IF NOT FIRST TIME
20130: MNZ PRTEF MARK FIRST OCCURRENCE
20131: ERB 253,PRINT LIMIT EXCEEDED ON STANDARD OUTPUT CHANNEL
20132: *
20133: * STOP AT ONCE
20134: *
20135: PRNL3 MOV =NINI8,WB ENDING CODE
20136: MOV KVSTN,WA STATEMENT NUMBER
20137: JSR SYSEJ STOP
20138: ENP END PROCEDURE PRTNL
20139: EJC
20140: *
20141: * PRTNM -- PRINT VARIABLE NAME
20142: *
20143: * PRTNM IS USED TO PRINT A CHARACTER REPRESENTATION OF THE
20144: * NAME OF A VARIABLE (NOT A VALUE OF DATATYPE NAME)
20145: * NAMES OF PSEUDO-VARIABLES MAY NOT BE PASSED TO PRTNM.
20146: *
20147: * (XL) NAME BASE
20148: * (WA) NAME OFFSET
20149: * JSR PRTNM CALL TO PRINT NAME
20150: * (WB,WC,RA) DESTROYED
20151: *
20152: PRTNM PRC R,0 ENTRY POINT (RECURSIVE, SEE PRTVL)
20153: MOV WA,-(XS) SAVE WA (OFFSET IS COLLECTABLE)
20154: MOV XR,-(XS) SAVE ENTRY XR
20155: MOV XL,-(XS) SAVE NAME BASE
20156: BHI XL,STATE,PRN02 JUMP IF NOT NATURAL VARIABLE
20157: *
20158: * HERE FOR NATURAL VARIABLE NAME, RECOGNIZED BY THE FACT
20159: * THAT THE NAME BASE POINTS INTO THE STATIC AREA.
20160: *
20161: MOV XL,XR POINT TO VRBLK
20162: JSR PRTVN PRINT NAME OF VARIABLE
20163: *
20164: * COMMON EXIT POINT
20165: *
20166: PRN01 MOV (XS)+,XL RESTORE NAME BASE
20167: MOV (XS)+,XR RESTORE ENTRY VALUE OF XR
20168: MOV (XS)+,WA RESTORE WA
20169: EXI RETURN TO PRTNM CALLER
20170: *
20171: * HERE FOR CASE OF NON-NATURAL VARIABLE
20172: *
20173: PRN02 MOV WA,WB COPY NAME OFFSET
20174: BNE (XL),=B$PDT,PRN03 JUMP IF ARRAY OR TABLE
20175: *
20176: * FOR PROGRAM DEFINED DATATYPE, PRT FLD NAME, LEFT PAREN
20177: *
20178: MOV PDDFP(XL),XR LOAD POINTER TO DFBLK
20179: ADD WA,XR ADD NAME OFFSET
20180: MOV PDFOF(XR),XR LOAD VRBLK POINTER FOR FIELD
20181: JSR PRTVN PRINT FIELD NAME
20182: MOV =CH$PP,WA LOAD LEFT PAREN
20183: JSR PRTCH PRINT CHARACTER
20184: EJC
20185: *
20186: * PRTNM (CONTINUED)
20187: *
20188: * NOW WE PRINT AN IDENTIFYING NAME FOR THE OBJECT IF ONE
20189: * CAN BE FOUND. THE FOLLOWING CODE SEARCHES FOR A NATURAL
20190: * VARIABLE WHICH CONTAINS THIS OBJECT AS VALUE. IF SUCH A
20191: * VARIABLE IS FOUND, ITS NAME IS PRINTED, ELSE THE VALUE
20192: * OF THE OBJECT (AS PRINTED BY PRTVL) IS USED INSTEAD.
20193: *
20194: * FIRST WE POINT TO THE PARENT TBBLK IF THIS IS THE CASE OF
20195: * A TABLE ELEMENT. TO DO THIS, CHASE DOWN THE TRNXT CHAIN.
20196: *
20197: PRN03 BNE (XL),=B$TET,PRN04 JUMP IF WE GOT THERE (OR NOT TE)
20198: MOV TENXT(XL),XL ELSE MOVE OUT ON CHAIN
20199: BRN PRN03 AND LOOP BACK
20200: *
20201: * NOW WE ARE READY FOR THE SEARCH. TO SPEED THINGS UP IN
20202: * THE CASE OF CALLS FROM DUMP WHERE THE SAME NAME BASE
20203: * WILL OCCUR REPEATEDLY WHILE DUMPING AN ARRAY OR TABLE,
20204: * WE REMEMBER THE LAST VRBLK POINTER FOUND IN PRNMV. SO
20205: * FIRST CHECK TO SEE IF WE HAVE THIS ONE AGAIN.
20206: *
20207: PRN04 MOV PRNMV,XR POINT TO VRBLK WE FOUND LAST TIME
20208: MOV HSHTB,WA POINT TO HASH TABLE IN CASE NOT
20209: BRN PRN07 JUMP INTO SEARCH FOR SPECIAL CHECK
20210: *
20211: * LOOP THROUGH HASH SLOTS
20212: *
20213: PRN05 MOV WA,XR COPY SLOT POINTER
20214: ICA WA BUMP SLOT POINTER
20215: SUB *VRNXT,XR INTRODUCE STANDARD VRBLK OFFSET
20216: *
20217: * LOOP THROUGH VRBLKS ON ONE HASH CHAIN
20218: *
20219: PRN06 MOV VRNXT(XR),XR POINT TO NEXT VRBLK ON HASH CHAIN
20220: *
20221: * MERGE HERE FIRST TIME TO CHECK BLOCK WE FOUND LAST TIME
20222: *
20223: PRN07 MOV XR,WC COPY VRBLK POINTER
20224: BZE WC,PRN09 JUMP IF CHAIN END (OR PRNMV ZERO)
20225: EJC
20226: *
20227: * PRTNM (CONTINUED)
20228: *
20229: * LOOP TO FIND VALUE (CHASE DOWN POSSIBLE TRBLK CHAIN)
20230: *
20231: PRN08 MOV VRVAL(XR),XR LOAD VALUE
20232: BEQ (XR),=B$TRT,PRN08 LOOP IF THAT WAS A TRBLK
20233: *
20234: * NOW WE HAVE THE VALUE, IS THIS THE BLOCK WE WANT
20235: *
20236: BEQ XR,XL,PRN10 JUMP IF THIS MATCHES THE NAME BASE
20237: MOV WC,XR ELSE POINT BACK TO THAT VRBLK
20238: BRN PRN06 AND LOOP BACK
20239: *
20240: * HERE TO MOVE TO NEXT HASH SLOT
20241: *
20242: PRN09 BLT WA,HSHTE,PRN05 LOOP BACK IF MORE TO GO
20243: MOV XL,XR ELSE NOT FOUND, COPY VALUE POINTER
20244: JSR PRTVL PRINT VALUE
20245: BRN PRN11 AND MERGE AHEAD
20246: *
20247: * HERE WHEN WE FIND A MATCHING ENTRY
20248: *
20249: PRN10 MOV WC,XR COPY VRBLK POINTER
20250: MOV XR,PRNMV SAVE FOR NEXT TIME IN
20251: JSR PRTVN PRINT VARIABLE NAME
20252: *
20253: * MERGE HERE IF NO ENTRY FOUND
20254: *
20255: PRN11 MOV (XL),WC LOAD FIRST WORD OF NAME BASE
20256: BNE WC,=B$PDT,PRN13 JUMP IF NOT PROGRAM DEFINED
20257: *
20258: * FOR PROGRAM DEFINED DATATYPE, ADD RIGHT PAREN AND EXIT
20259: *
20260: MOV =CH$RP,WA LOAD RIGHT PAREN, MERGE
20261: *
20262: * MERGE HERE TO PRINT FINAL RIGHT PAREN OR BRACKET
20263: *
20264: PRN12 JSR PRTCH PRINT FINAL CHARACTER
20265: MOV WB,WA RESTORE NAME OFFSET
20266: BRN PRN01 MERGE BACK TO EXIT
20267: EJC
20268: *
20269: * PRTNM (CONTINUED)
20270: *
20271: * HERE FOR ARRAY OR TABLE
20272: *
20273: PRN13 MOV =CH$BB,WA LOAD LEFT BRACKET
20274: JSR PRTCH AND PRINT IT
20275: MOV (XS),XL RESTORE BLOCK POINTER
20276: MOV (XL),WC LOAD TYPE WORD AGAIN
20277: BNE WC,=B$TET,PRN15 JUMP IF NOT TABLE
20278: *
20279: * HERE FOR TABLE, PRINT SUBSCRIPT VALUE
20280: *
20281: MOV TESUB(XL),XR LOAD SUBSCRIPT VALUE
20282: MOV WB,XL SAVE NAME OFFSET
20283: JSR PRTVL PRINT SUBSCRIPT VALUE
20284: MOV XL,WB RESTORE NAME OFFSET
20285: *
20286: * MERGE HERE FROM ARRAY CASE TO PRINT RIGHT BRACKET
20287: *
20288: PRN14 MOV =CH$RB,WA LOAD RIGHT BRACKET
20289: BRN PRN12 MERGE BACK TO PRINT IT
20290: *
20291: * HERE FOR ARRAY OR VECTOR, TO PRINT SUBSCRIPT(S)
20292: *
20293: PRN15 MOV WB,WA COPY NAME OFFSET
20294: BTW WA CONVERT TO WORDS
20295: BEQ WC,=B$ART,PRN16 JUMP IF ARBLK
20296: *
20297: * HERE FOR VECTOR
20298: *
20299: SUB =VCVLB,WA ADJUST FOR STANDARD FIELDS
20300: MTI WA MOVE TO INTEGER ACCUM
20301: JSR PRTIN PRINT LINEAR SUBSCRIPT
20302: BRN PRN14 MERGE BACK FOR RIGHT BRACKET
20303: EJC
20304: *
20305: * PRTNM (CONTINUED)
20306: *
20307: * HERE FOR ARRAY. FIRST CALCULATE ABSOLUTE SUBSCRIPT
20308: * OFFSETS BY SUCCESSIVE DIVISIONS BY THE DIMENSION VALUES.
20309: * THIS MUST BE DONE RIGHT TO LEFT SINCE THE ELEMENTS ARE
20310: * STORED ROW-WISE. THE SUBSCRIPTS ARE STACKED AS INTEGERS.
20311: *
20312: PRN16 MOV AROFS(XL),WC LOAD LENGTH OF BOUNDS INFO
20313: ICA WC ADJUST FOR ARPRO FIELD
20314: BTW WC CONVERT TO WORDS
20315: SUB WC,WA GET LINEAR ZERO-ORIGIN SUBSCRIPT
20316: MTI WA GET INTEGER VALUE
20317: LCT WA,ARNDM(XL) SET NUM OF DIMENSIONS AS LOOP COUNT
20318: ADD AROFS(XL),XL POINT PAST BOUNDS INFORMATION
20319: SUB *ARLBD,XL SET OK OFFSET FOR PROPER PTR LATER
20320: *
20321: * LOOP TO STACK SUBSCRIPT OFFSETS
20322: *
20323: PRN17 SUB *ARDMS,XL POINT TO NEXT SET OF BOUNDS
20324: STI PRNSI SAVE CURRENT OFFSET
20325: RMI ARDIM(XL) GET REMAINDER ON DIVIDING BY DIMENS
20326: MFI -(XS) STORE ON STACK (ONE WORD)
20327: LDI PRNSI RELOAD ARGUMENT
20328: DVI ARDIM(XL) DIVIDE TO GET QUOTIENT
20329: BCT WA,PRN17 LOOP TILL ALL STACKED
20330: ZER XR SET OFFSET TO FIRST SET OF BOUNDS
20331: LCT WB,ARNDM(XL) LOAD COUNT OF DIMS TO CONTROL LOOP
20332: BRN PRN19 JUMP INTO PRINT LOOP
20333: *
20334: * LOOP TO PRINT SUBSCRIPTS FROM STACK ADJUSTING BY ADDING
20335: * THE APPROPRIATE LOW BOUND VALUE FROM THE ARBLK
20336: *
20337: PRN18 MOV =CH$CM,WA LOAD A COMMA
20338: JSR PRTCH PRINT IT
20339: *
20340: * MERGE HERE FIRST TIME IN (NO COMMA REQUIRED)
20341: *
20342: PRN19 MTI (XS)+ LOAD SUBSCRIPT OFFSET AS INTEGER
20343: ADD XR,XL POINT TO CURRENT LBD
20344: ADI ARLBD(XL) ADD LBD TO GET SIGNED SUBSCRIPT
20345: SUB XR,XL POINT BACK TO START OF ARBLK
20346: JSR PRTIN PRINT SUBSCRIPT
20347: ADD *ARDMS,XR BUMP OFFSET TO NEXT BOUNDS
20348: BCT WB,PRN18 LOOP BACK TILL ALL PRINTED
20349: BRN PRN14 MERGE BACK TO PRINT RIGHT BRACKET
20350: ENP END PROCEDURE PRTNM
20351: EJC
20352: *
20353: * PRTNV -- PRINT NAME VALUE
20354: *
20355: * PRTNV IS USED BY THE TRACE AND DUMP ROUTINES TO PRINT
20356: * A LINE OF THE FORM
20357: *
20358: * NAME = VALUE
20359: *
20360: * NOTE THAT THE NAME INVOLVED CAN NEVER BE A PSEUDO-VAR
20361: *
20362: * (XL) NAME BASE
20363: * (WA) NAME OFFSET
20364: * JSR PRTNV CALL TO PRINT NAME = VALUE
20365: * (WB,WC,RA) DESTROYED
20366: *
20367: PRTNV PRC E,0 ENTRY POINT
20368: JSR PRTNM PRINT ARGUMENT NAME
20369: MOV XR,-(XS) SAVE ENTRY XR
20370: MOV WA,-(XS) SAVE NAME OFFSET (COLLECTABLE)
20371: MOV =TMBEB,XR POINT TO BLANK EQUAL BLANK
20372: JSR PRTST PRINT IT
20373: MOV XL,XR COPY NAME BASE
20374: ADD WA,XR POINT TO VALUE
20375: MOV (XR),XR LOAD VALUE POINTER
20376: JSR PRTVL PRINT VALUE
20377: JSR PRTNL TERMINATE LINE
20378: MOV (XS)+,WA RESTORE NAME OFFSET
20379: MOV (XS)+,XR RESTORE ENTRY XR
20380: EXI RETURN TO CALLER
20381: ENP END PROCEDURE PRTNV
20382: EJC
20383: *
20384: * PRTPG -- PRINT A PAGE THROW
20385: *
20386: * PRINTS A PAGE THROW OR A FEW BLANK LINES ON THE STANDARD
20387: * LISTING CHANNEL DEPENDING ON THE LISTING OPTIONS CHOSEN.
20388: *
20389: * JSR PRTPG CALL FOR PAGE EJECT
20390: *
20391: PRTPG PRC E,0 ENTRY POINT
20392: BEQ STAGE,=STGXT,PRP01 JUMP IF EXECUTION TIME
20393: BZE LSTLC,PRP06 RETURN IF TOP OF PAGE ALREADY
20394: ZER LSTLC CLEAR LINE COUNT
20395: *
20396: * CHECK TYPE OF LISTING
20397: *
20398: PRP01 MOV XR,-(XS) PRESERVE XR
20399: BNZ PRSTD,PRP02 EJECT IF FLAG SET
20400: BNZ PRICH,PRP03 JUMP IF INTERACTIVE LISTING CHANNEL
20401: BZE PRECL,PRP03 JUMP IF COMPACT LISTING
20402: *
20403: * PERFORM AN EJECT
20404: *
20405: PRP02 JSR SYSEP EJECT
20406: BRN PRP04 MERGE
20407: *
20408: * COMPACT OR INTERACTIVE CHANNEL LISTING. CANT PRINT
20409: * BLANKS UNTIL CHECK MADE FOR HEADERS PRINTED AND FLAG SET.
20410: *
20411: *
20412: PRP03 MOV HEADP,XR REMEMBER HEADP
20413: MNZ HEADP SET TO AVOID REPEATED PRTPG CALLS
20414: JSR PRTNL PRINT BLANK LINE
20415: JSR PRTNL PRINT BLANK LINE
20416: JSR PRTNL PRINT BLANK LINE
20417: MOV =NUM03,LSTLC COUNT BLANK LINES
20418: MOV XR,HEADP RESTORE HEADER FLAG
20419: EJC
20420: *
20421: * PRPTG (CONTINUED)
20422: *
20423: * PRINT THE HEADING
20424: *
20425: PRP04 BNZ HEADP,PRP05 JUMP IF HEADER LISTED
20426: MNZ HEADP MARK HEADERS PRINTED
20427: MOV XL,-(XS) KEEP XL
20428: MOV =HEADR,XR POINT TO LISTING HEADER
20429: JSR PRTST PLACE IT
20430: JSR SYSID GET SYSTEM IDENTIFICATION
20431: JSR PRTST APPEND EXTRA CHARS
20432: JSR PRTNL PRINT IT
20433: MOV XL,XR EXTRA HEADER LINE
20434: JSR PRTST PLACE IT
20435: JSR PRTNL PRINT IT
20436: JSR PRTNL PRINT A BLANK
20437: JSR PRTNL AND ANOTHER
20438: ADD =NUM04,LSTLC FOUR HEADER LINES PRINTED
20439: MOV (XS)+,XL RESTORE XL
20440: *
20441: * MERGE IF HEADER NOT PRINTED
20442: *
20443: PRP05 MOV (XS)+,XR RESTORE XR
20444: *
20445: * RETURN
20446: *
20447: PRP06 EXI RETURN
20448: ENP END PROCEDURE PRTPG
20449: EJC
20450: *
20451: * PRTPS - PRINT PAGE WITH TEST FOR STANDARD LISTING OPTION
20452: *
20453: * IF THE STANDARD LISTING OPTION IS SELECTED, INSIST THAT
20454: * AN EJECT BE DONE
20455: *
20456: * JSR PRTPS CALL FOR EJECT
20457: *
20458: PRTPS PRC E,0 ENTRY POINT
20459: MOV PRSTO,PRSTD COPY OPTION FLAG
20460: JSR PRTPG PRINT PAGE
20461: ZER PRSTD CLEAR FLAG
20462: EXI RETURN
20463: ENP END PROCEDURE PRTPS
20464: EJC
20465: *
20466: * PRTSN -- PRINT STATEMENT NUMBER
20467: *
20468: * PRTSN IS USED TO INITIATE A PRINT TRACE LINE BY PRINTING
20469: * ASTERISKS AND THE CURRENT STATEMENT NUMBER. THE ACTUAL
20470: * FORMAT OF THE OUTPUT GENERATED IS.
20471: *
20472: * ***NNNNN**** III.....IIII
20473: *
20474: * NNNNN IS THE STATEMENT NUMBER WITH LEADING ZEROS REPLACED
20475: * BY ASTERISKS (E.G. *******9****)
20476: *
20477: * III...III REPRESENTS A VARIABLE LENGTH OUTPUT CONSISTING
20478: * OF A NUMBER OF LETTER I CHARACTERS EQUAL TO FNCLEVEL.
20479: *
20480: * JSR PRTSN CALL TO PRINT STATEMENT NUMBER
20481: * (WC) DESTROYED
20482: *
20483: PRTSN PRC E,0 ENTRY POINT
20484: MOV XR,-(XS) SAVE ENTRY XR
20485: MOV WA,PRSNA SAVE ENTRY WA
20486: MOV =TMASB,XR POINT TO ASTERISKS
20487: JSR PRTST PRINT ASTERISKS
20488: MOV =NUM04,PROFS POINT INTO MIDDLE OF ASTERISKS
20489: MTI KVSTN LOAD STATEMENT NUMBER AS INTEGER
20490: JSR PRTIN PRINT INTEGER STATEMENT NUMBER
20491: MOV =PRSNF,PROFS POINT PAST ASTERISKS PLUS BLANK
20492: MOV KVFNC,XR GET FNCLEVEL
20493: MOV =CH$LI,WA SET LETTER I
20494: *
20495: * LOOP TO GENERATE LETTER I FNCLEVEL TIMES
20496: *
20497: PRSN1 BZE XR,PRSN2 JUMP IF ALL SET
20498: JSR PRTCH ELSE PRINT AN I
20499: DCV XR DECREMENT COUNTER
20500: BRN PRSN1 LOOP BACK
20501: *
20502: * MERRE WITH ALL LETTER I CHARACTERS GENERATED
20503: *
20504: PRSN2 MOV =CH$BL,WA GET BLANK
20505: JSR PRTCH PRINT BLANK
20506: MOV PRSNA,WA RESTORE ENTRY WA
20507: MOV (XS)+,XR RESTORE ENTRY XR
20508: EXI RETURN TO PRTSN CALLER
20509: ENP END PROCEDURE PRTSN
20510: EJC
20511: *
20512: * PRTST -- PRINT STRING
20513: *
20514: * PRTST PLACES A STRING OF CHARACTERS IN THE PRINT BUFFER
20515: *
20516: * SEE PRTNL FOR GLOBAL LOCATIONS USED
20517: *
20518: * NOTE THAT THE FIRST WORD OF THE BLOCK (NORMALLY B$SCL)
20519: * IS NOT USED AND NEED NOT BE SET CORRECTLY (SEE PRTVN)
20520: *
20521: * (XR) STRING TO BE PRINTED
20522: * JSR PRTST CALL TO PRINT STRING
20523: * (PROFS) UPDATED PAST CHARS PLACED
20524: *
20525: PRTST PRC R,0 ENTRY POINT
20526: BNZ HEADP,PRST0 WERE HEADERS PRINTED
20527: JSR PRTPS NO - PRINT THEM
20528: *
20529: * CALL SYSPR
20530: *
20531: PRST0 MOV WA,PRSVA SAVE WA
20532: MOV WB,PRSVB SAVE WB
20533: ZER WB SET CHARS PRINTED COUNT TO ZERO
20534: *
20535: * LOOP TO PRINT SUCCESSIVE LINES FOR LONG STRING
20536: *
20537: PRST1 MOV SCLEN(XR),WA LOAD STRING LENGTH
20538: SUB WB,WA SUBTRACT COUNT OF CHARS ALREADY OUT
20539: BZE WA,PRST4 JUMP TO EXIT IF NONE LEFT
20540: MOV XL,-(XS) ELSE STACK ENTRY XL
20541: MOV XR,-(XS) SAVE ARGUMENT
20542: MOV XR,XL COPY FOR EVENTUAL MOVE
20543: MOV PRLEN,XR LOAD PRINT BUFFER LENGTH
20544: SUB PROFS,XR GET CHARS LEFT IN PRINT BUFFER
20545: BNZ XR,PRST2 SKIP IF ROOM LEFT ON THIS LINE
20546: JSR PRTNL ELSE PRINT THIS LINE
20547: MOV PRLEN,XR AND SET FULL WIDTH AVAILABLE
20548: EJC
20549: *
20550: * PRTST (CONTINUED)
20551: *
20552: * HERE WITH CHARS TO PRINT AND SOME ROOM IN BUFFER
20553: *
20554: PRST2 BLO WA,XR,PRST3 JUMP IF ROOM FOR REST OF STRING
20555: MOV XR,WA ELSE SET TO FILL LINE
20556: *
20557: * MERGE HERE WITH CHARACTER COUNT IN WA
20558: *
20559: PRST3 MOV PRBUF,XR POINT TO PRINT BUFFER
20560: PLC XL,WB POINT TO LOCATION IN STRING
20561: PSC XR,PROFS POINT TO LOCATION IN BUFFER
20562: ADD WA,WB BUMP STRING CHARS COUNT
20563: ADD WA,PROFS BUMP BUFFER POINTER
20564: MOV WB,PRSVC PRESERVE CHAR COUNTER
20565: MVC MOVE CHARACTERS TO BUFFER
20566: MOV PRSVC,WB RECOVER CHAR COUNTER
20567: MOV (XS)+,XR RESTORE ARGUMENT POINTER
20568: MOV (XS)+,XL RESTORE ENTRY XL
20569: BRN PRST1 LOOP BACK TO TEST FOR MORE
20570: *
20571: * HERE TO EXIT AFTER PRINTING STRING
20572: *
20573: PRST4 MOV PRSVB,WB RESTORE ENTRY WB
20574: MOV PRSVA,WA RESTORE ENTRY WA
20575: EXI RETURN TO PRTST CALLER
20576: ENP END PROCEDURE PRTST
20577: EJC
20578: *
20579: * PRTTR -- PRINT TO TERMINAL
20580: *
20581: * CALLED TO PRINT CONTENTS OF STANDARD PRINT BUFFER TO
20582: * ONLINE TERMINAL. CLEARS BUFFER DOWN AND RESETS PROFS.
20583: *
20584: * JSR PRTTR CALL FOR PRINT
20585: * (WA,WB) DESTROYED
20586: *
20587: PRTTR PRC E,0 ENTRY POINT
20588: MOV XR,-(XS) SAVE XR
20589: JSR PRTIC PRINT BUFFER CONTENTS
20590: MOV PRBUF,XR POINT TO PRINT BFR TO CLEAR IT
20591: LCT WA,PRLNW GET BUFFER LENGTH
20592: ADD *SCHAR,XR POINT PAST SCBLK HEADER
20593: MOV NULLW,WB GET BLANKS
20594: *
20595: * LOOP TO CLEAR BUFFER
20596: *
20597: PRTT1 MOV WB,(XR)+ CLEAR A WORD
20598: BCT WA,PRTT1 LOOP
20599: ZER PROFS RESET PROFS
20600: MOV (XS)+,XR RESTORE XR
20601: EXI RETURN
20602: ENP END PROCEDURE PRTTR
20603: EJC
20604: *
20605: * PRTVL -- PRINT A VALUE
20606: *
20607: * PRTVL PLACES AN APPROPRIATE CHARACTER REPRESENTATION OF
20608: * A DATA VALUE IN THE PRINT BUFFER FOR DUMP/TRACE USE.
20609: *
20610: * (XR) VALUE TO BE PRINTED
20611: * JSR PRTVL CALL TO PRINT VALUE
20612: * (WA,WB,WC,RA) DESTROYED
20613: *
20614: PRTVL PRC R,0 ENTRY POINT, RECURSIVE
20615: MOV XL,-(XS) SAVE ENTRY XL
20616: MOV XR,-(XS) SAVE ARGUMENT
20617: CHK CHECK FOR STACK OVERFLOW
20618: *
20619: * LOOP BACK HERE AFTER FINDING A TRAP BLOCK (TRBLK)
20620: *
20621: PRV01 MOV IDVAL(XR),PRVSI COPY IDVAL (IF ANY)
20622: MOV (XR),XL LOAD FIRST WORD OF BLOCK
20623: LEI XL LOAD ENTRY POINT ID
20624: BSW XL,BL$$T,PRV02 SWITCH ON BLOCK TYPE
20625: IFF BL$TR,PRV04 TRBLK
20626: IFF BL$AR,PRV05 ARBLK
20627: IFF BL$IC,PRV08 ICBLK
20628: IFF BL$NM,PRV09 NMBLK
20629: IFF BL$PD,PRV10 PDBLK
20630: .IF .CNRA
20631: .ELSE
20632: IFF BL$RC,PRV08 RCBLK
20633: .FI
20634: IFF BL$SC,PRV11 SCBLK
20635: IFF BL$SE,PRV12 SEBLK
20636: IFF BL$TB,PRV13 TBBLK
20637: IFF BL$VC,PRV13 VCBLK
20638: .IF .CNBF
20639: .ELSE
20640: IFF BL$BC,PRV15 BCBLK
20641: .FI
20642: ESW END OF SWITCH ON BLOCK TYPE
20643: *
20644: * HERE FOR BLOCKS FOR WHICH WE JUST PRINT DATATYPE NAME
20645: *
20646: PRV02 JSR DTYPE GET DATATYPE NAME
20647: JSR PRTST PRINT DATATYPE NAME
20648: *
20649: * COMMON EXIT POINT
20650: *
20651: PRV03 MOV (XS)+,XR RELOAD ARGUMENT
20652: MOV (XS)+,XL RESTORE XL
20653: EXI RETURN TO PRTVL CALLER
20654: *
20655: * HERE FOR TRBLK
20656: *
20657: PRV04 MOV TRVAL(XR),XR LOAD REAL VALUE
20658: BRN PRV01 AND LOOP BACK
20659: EJC
20660: *
20661: * PRTVL (CONTINUED)
20662: *
20663: * HERE FOR ARRAY (ARBLK)
20664: *
20665: * PRINT ARRAY ( PROTOTYPE ) BLANK NUMBER IDVAL
20666: *
20667: PRV05 MOV XR,XL PRESERVE ARGUMENT
20668: MOV =SCARR,XR POINT TO DATATYPE NAME (ARRAY)
20669: JSR PRTST PRINT IT
20670: MOV =CH$PP,WA LOAD LEFT PAREN
20671: JSR PRTCH PRINT LEFT PAREN
20672: ADD AROFS(XL),XL POINT TO PROTOTYPE
20673: MOV (XL),XR LOAD PROTOTYPE
20674: JSR PRTST PRINT PROTOTYPE
20675: *
20676: * VCBLK, TBBLK, BCBLK MERGE HERE FOR ) BLANK NUMBER IDVAL
20677: *
20678: PRV06 MOV =CH$RP,WA LOAD RIGHT PAREN
20679: JSR PRTCH PRINT RIGHT PAREN
20680: *
20681: * PDBLK MERGES HERE TO PRINT BLANK NUMBER IDVAL
20682: *
20683: PRV07 MOV =CH$BL,WA LOAD BLANK
20684: JSR PRTCH PRINT IT
20685: MOV =CH$NM,WA LOAD NUMBER SIGN
20686: JSR PRTCH PRINT IT
20687: MTI PRVSI GET IDVAL
20688: JSR PRTIN PRINT ID NUMBER
20689: BRN PRV03 BACK TO EXIT
20690: *
20691: * HERE FOR INTEGER (ICBLK), REAL (RCBLK)
20692: *
20693: * PRINT CHARACTER REPRESENTATION OF VALUE
20694: *
20695: PRV08 MOV XR,-(XS) STACK ARGUMENT FOR GTSTG
20696: JSR GTSTG CONVERT TO STRING
20697: PPM ERROR RETURN IS IMPOSSIBLE
20698: JSR PRTST PRINT THE STRING
20699: MOV XR,DNAMP DELETE GARBAGE STRING FROM STORAGE
20700: BRN PRV03 BACK TO EXIT
20701: EJC
20702: *
20703: * PRTVL (CONTINUED)
20704: *
20705: * NAME (NMBLK)
20706: *
20707: * FOR PSEUDO-VARIABLE, JUST PRINT DATATYPE NAME (NAME)
20708: * FOR ALL OTHER NAMES, PRINT DOT FOLLOWED BY NAME REP
20709: *
20710: PRV09 MOV NMBAS(XR),XL LOAD NAME BASE
20711: MOV (XL),WA LOAD FIRST WORD OF BLOCK
20712: BEQ WA,=B$KVT,PRV02 JUST PRINT NAME IF KEYWORD
20713: BEQ WA,=B$EVT,PRV02 JUST PRINT NAME IF EXPRESSION VAR
20714: MOV =CH$DT,WA ELSE GET DOT
20715: JSR PRTCH AND PRINT IT
20716: MOV NMOFS(XR),WA LOAD NAME OFFSET
20717: JSR PRTNM PRINT NAME
20718: BRN PRV03 BACK TO EXIT
20719: *
20720: * PROGRAM DATATYPE (PDBLK)
20721: *
20722: * PRINT DATATYPE NAME CH$BL CH$NM IDVAL
20723: *
20724: PRV10 JSR DTYPE GET DATATYPE NAME
20725: JSR PRTST PRINT DATATYPE NAME
20726: BRN PRV07 MERGE BACK TO PRINT ID
20727: *
20728: * HERE FOR STRING (SCBLK)
20729: *
20730: * PRINT QUOTE STRING-CHARACTERS QUOTE
20731: *
20732: PRV11 MOV =CH$SQ,WA LOAD SINGLE QUOTE
20733: JSR PRTCH PRINT QUOTE
20734: JSR PRTST PRINT STRING VALUE
20735: JSR PRTCH PRINT ANOTHER QUOTE
20736: BRN PRV03 BACK TO EXIT
20737: EJC
20738: *
20739: * PRTVL (CONTINUED)
20740: *
20741: * HERE FOR SIMPLE EXPRESSION (SEBLK)
20742: *
20743: * PRINT ASTERISK VARIABLE-NAME
20744: *
20745: PRV12 MOV =CH$AS,WA LOAD ASTERISK
20746: JSR PRTCH PRINT ASTERISK
20747: MOV SEVAR(XR),XR LOAD VARIABLE POINTER
20748: JSR PRTVN PRINT VARIABLE NAME
20749: BRN PRV03 JUMP BACK TO EXIT
20750: *
20751: * HERE FOR TABLE (TBBLK) AND ARRAY (VCBLK)
20752: *
20753: * PRINT DATATYPE ( PROTOTYPE ) BLANK NUMBER IDVAL
20754: *
20755: PRV13 MOV XR,XL PRESERVE ARGUMENT
20756: JSR DTYPE GET DATATYPE NAME
20757: JSR PRTST PRINT DATATYPE NAME
20758: MOV =CH$PP,WA LOAD LEFT PAREN
20759: JSR PRTCH PRINT LEFT PAREN
20760: MOV TBLEN(XL),WA LOAD LENGTH OF BLOCK (=VCLEN)
20761: BTW WA CONVERT TO WORD COUNT
20762: SUB =TBSI$,WA ALLOW FOR STANDARD FIELDS
20763: BEQ (XL),=B$TBT,PRV14 JUMP IF TABLE
20764: ADD =VCTBD,WA FOR VCBLK, ADJUST SIZE
20765: *
20766: * PRINT PROTOTYPE
20767: *
20768: PRV14 MTI WA MOVE AS INTEGER
20769: JSR PRTIN PRINT INTEGER PROTOTYPE
20770: BRN PRV06 MERGE BACK FOR REST
20771: .IF .CNBF
20772: .ELSE
20773: EJC
20774: *
20775: * PRTVL (CONTINUED)
20776: *
20777: * HERE FOR BUFFER (BCBLK)
20778: *
20779: PRV15 MOV XR,XL PRESERVE ARGUMENT
20780: MOV =SCBUF,XR POINT TO DATATYPE NAME (BUFFER)
20781: JSR PRTST PRINT IT
20782: MOV =CH$PP,WA LOAD LEFT PAREN
20783: JSR PRTCH PRINT LEFT PAREN
20784: MOV BCBUF(XL),XR POINT TO BFBLK
20785: MTI BFALC(XR) LOAD ALLOCATION SIZE
20786: JSR PRTIN PRINT IT
20787: MOV =CH$CM,WA LOAD COMMA
20788: JSR PRTCH PRINT IT
20789: MTI BCLEN(XL) LOAD DEFINED LENGTH
20790: JSR PRTIN PRINT IT
20791: BRN PRV06 MERGE TO FINISH UP
20792: .FI
20793: ENP END PROCEDURE PRTVL
20794: EJC
20795: *
20796: * PRTVN -- PRINT NATURAL VARIABLE NAME
20797: *
20798: * PRTVN PRINTS THE NAME OF A NATURAL VARIABLE
20799: *
20800: * (XR) POINTER TO VRBLK
20801: * JSR PRTVN CALL TO PRINT VARIABLE NAME
20802: *
20803: PRTVN PRC E,0 ENTRY POINT
20804: MOV XR,-(XS) STACK VRBLK POINTER
20805: ADD *VRSOF,XR POINT TO POSSIBLE STRING NAME
20806: BNZ SCLEN(XR),PRVN1 JUMP IF NOT SYSTEM VARIABLE
20807: MOV VRSVO(XR),XR POINT TO SVBLK WITH NAME
20808: *
20809: * MERGE HERE WITH DUMMY SCBLK POINTER IN XR
20810: *
20811: PRVN1 JSR PRTST PRINT STRING NAME OF VARIABLE
20812: MOV (XS)+,XR RESTORE VRBLK POINTER
20813: EXI RETURN TO PRTVN CALLER
20814: ENP END PROCEDURE PRTVN
20815: .IF .CNRA
20816: .ELSE
20817: EJC
20818: *
20819: * RCBLD -- BUILD A REAL BLOCK
20820: *
20821: * (RA) REAL VALUE FOR RCBLK
20822: * JSR RCBLD CALL TO BUILD REAL BLOCK
20823: * (XR) POINTER TO RESULT RCBLK
20824: * (WA) DESTROYED
20825: *
20826: RCBLD PRC E,0 ENTRY POINT
20827: MOV DNAMP,XR LOAD POINTER TO NEXT AVAILABLE LOC
20828: ADD *RCSI$,XR POINT PAST NEW RCBLK
20829: BLO XR,DNAME,RCBL1 JUMP IF THERE IS ROOM
20830: MOV *RCSI$,WA ELSE LOAD RCBLK LENGTH
20831: JSR ALLOC USE STANDARD ALLOCATOR TO GET BLOCK
20832: ADD WA,XR POINT PAST BLOCK TO MERGE
20833: *
20834: * MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED
20835: *
20836: RCBL1 MOV XR,DNAMP SET NEW POINTER
20837: SUB *RCSI$,XR POINT BACK TO START OF BLOCK
20838: MOV =B$RCL,(XR) STORE TYPE WORD
20839: STR RCVAL(XR) STORE REAL VALUE IN RCBLK
20840: EXI RETURN TO RCBLD CALLER
20841: ENP END PROCEDURE RCBLD
20842: .FI
20843: EJC
20844: *
20845: * READR -- READ NEXT SOURCE IMAGE AT COMPILE TIME
20846: *
20847: * READR IS USED TO READ THE NEXT SOURCE IMAGE. TO PROCESS
20848: * CONTINUATION CARDS PROPERLY, THE COMPILER MUST READ ONE
20849: * LINE AHEAD. THUS READR DOES NOT DESTROY THE CURRENT IMAGE
20850: * SEE ALSO THE NEXTS ROUTINE WHICH ACTUALLY GETS THE IMAGE.
20851: *
20852: * JSR READR CALL TO READ NEXT IMAGE
20853: * (XR) PTR TO NEXT IMAGE (0 IF NONE)
20854: * (R$CNI) COPY OF POINTER
20855: * (WA,WB,WC,XL) DESTROYED
20856: *
20857: READR PRC E,0 ENTRY POINT
20858: MOV R$CNI,XR GET PTR TO NEXT IMAGE
20859: BNZ XR,READ3 EXIT IF ALREADY READ
20860: BNE STAGE,=STGIC,READ3 EXIT IF NOT INITIAL COMPILE
20861: MOV CSWIN,WA MAX READ LENGTH
20862: JSR ALOCS ALLOCATE BUFFER
20863: JSR SYSRD READ INPUT IMAGE
20864: PPM READ4 JUMP IF END OF FILE
20865: MNZ WB SET TRIMR TO PERFORM TRIM
20866: BLE SCLEN(XR),CSWIN,READ1 USE SMALLER OF STRING LNTH ..
20867: MOV CSWIN,SCLEN(XR) ... AND XXX OF -INXXX
20868: *
20869: * PERFORM THE TRIM
20870: *
20871: READ1 JSR TRIMR TRIM TRAILING BLANKS
20872: *
20873: * MERGE HERE AFTER READ
20874: *
20875: READ2 MOV XR,R$CNI STORE COPY OF POINTER
20876: *
20877: * MERGE HERE IF NO READ ATTEMPTED
20878: *
20879: READ3 EXI RETURN TO READR CALLER
20880: *
20881: * HERE ON END OF FILE
20882: *
20883: READ4 MOV XR,DNAMP POP UNUSED SCBLK
20884: ZER XR ZERO PTR AS RESULT
20885: BRN READ2 MERGE
20886: ENP END PROCEDURE READR
20887: EJC
20888: *
20889: * SBSTR -- BUILD A SUBSTRING
20890: *
20891: * (XL) PTR TO SCBLK/BFBLK WITH CHARS
20892: * (WA) NUMBER OF CHARS IN SUBSTRING
20893: * (WB) OFFSET TO FIRST CHAR IN SCBLK
20894: * JSR SBSTR CALL TO BUILD SUBSTRING
20895: * (XR) PTR TO NEW SCBLK WITH SUBSTRING
20896: * (XL) ZERO
20897: * (WA,WB,WC,XL,IA) DESTROYED
20898: *
20899: * NOTE THAT SBSTR IS CALLED WITH A DUMMY STRING POINTER
20900: * (POINTING INTO A VRBLK OR SVBLK) TO COPY THE NAME OF A
20901: * VARIABLE AS A STANDARD STRING VALUE.
20902: *
20903: SBSTR PRC E,0 ENTRY POINT
20904: BZE WA,SBST2 JUMP IF NULL SUBSTRING
20905: JSR ALOCS ELSE ALLOCATE SCBLK
20906: MOV WC,WA MOVE NUMBER OF CHARACTERS
20907: MOV XR,WC SAVE PTR TO NEW SCBLK
20908: PLC XL,WB PREPARE TO LOAD CHARS FROM OLD BLK
20909: PSC XR PREPARE TO STORE CHARS IN NEW BLK
20910: MVC MOVE CHARACTERS TO NEW STRING
20911: MOV WC,XR THEN RESTORE SCBLK POINTER
20912: *
20913: * RETURN POINT
20914: *
20915: SBST1 ZER XL CLEAR GARBAGE POINTER IN XL
20916: EXI RETURN TO SBSTR CALLER
20917: *
20918: * HERE FOR NULL SUBSTRING
20919: *
20920: SBST2 MOV =NULLS,XR SET NULL STRING AS RESULT
20921: BRN SBST1 RETURN
20922: ENP END PROCEDURE SBSTR
20923: EJC
20924: *
20925: * SCANE -- SCAN AN ELEMENT
20926: *
20927: * SCANE IS CALLED AT COMPILE TIME (BY EXPAN ,CMPIL,CNCRD)
20928: * TO SCAN ONE ELEMENT FROM THE INPUT IMAGE.
20929: *
20930: * (SCNCC) NON-ZERO IF CALLED FROM CNCRD
20931: * JSR SCANE CALL TO SCAN ELEMENT
20932: * (XR) RESULT POINTER (SEE BELOW)
20933: * (XL) SYNTAX TYPE CODE (T$XXX)
20934: *
20935: * THE FOLLOWING GLOBAL LOCATIONS ARE USED.
20936: *
20937: * R$CIM POINTER TO STRING BLOCK (SCBLK)
20938: * FOR CURRENT INPUT IMAGE.
20939: *
20940: * R$CNI POINTER TO NEXT INPUT IMAGE STRING
20941: * POINTER (ZERO IF NONE).
20942: *
20943: * R$SCP SAVE POINTER (EXIT XR) FROM LAST
20944: * CALL IN CASE RESCAN IS SET.
20945: *
20946: * SCNBL THIS LOCATION IS SET NON-ZERO ON
20947: * EXIT IF SCANE SCANNED PAST BLANKS
20948: * BEFORE LOCATING THE CURRENT ELEMENT
20949: * THE END OF A LINE COUNTS AS BLANKS.
20950: *
20951: * SCNCC CNCRD SETS THIS NON-ZERO TO SCAN
20952: * CONTROL CARD NAMES AND CLEARS IT
20953: * ON RETURN
20954: *
20955: * SCNIL LENGTH OF CURRENT INPUT IMAGE
20956: *
20957: * SCNGO IF SET NON-ZERO ON ENTRY, F AND S
20958: * ARE RETURNED AS SEPARATE SYNTAX
20959: * TYPES (NOT LETTERS) (GOTO PRO-
20960: * CESSING). SCNGO IS RESET ON EXIT.
20961: *
20962: * SCNPT OFFSET TO CURRENT LOC IN R$CIM
20963: *
20964: * SCNRS IF SET NON-ZERO ON ENTRY, SCANE
20965: * RETURNS THE SAME RESULT AS ON THE
20966: * LAST CALL (RESCAN). SCNRS IS RESET
20967: * ON EXIT FROM ANY CALL TO SCANE.
20968: *
20969: * SCNTP SAVE SYNTAX TYPE FROM LAST
20970: * CALL (IN CASE RESCAN IS SET).
20971: EJC
20972: *
20973: * SCANE (CONTINUED)
20974: *
20975: *
20976: *
20977: * ELEMENT SCANNED XL XR
20978: * --------------- -- --
20979: *
20980: * CONTROL CARD NAME 0 POINTER TO SCBLK FOR NAME
20981: *
20982: * UNARY OPERATOR T$UOP PTR TO OPERATOR DVBLK
20983: *
20984: * LEFT PAREN T$LPR T$LPR
20985: *
20986: * LEFT BRACKET T$LBR T$LBR
20987: *
20988: * COMMA T$CMA T$CMA
20989: *
20990: * FUNCTION CALL T$FNC PTR TO FUNCTION VRBLK
20991: *
20992: * VARIABLE T$VAR PTR TO VRBLK
20993: *
20994: * STRING CONSTANT T$CON PTR TO SCBLK
20995: *
20996: * INTEGER CONSTANT T$CON PTR TO ICBLK
20997: *
20998: .IF .CNRA
20999: .ELSE
21000: * REAL CONSTANT T$CON PTR TO RCBLK
21001: *
21002: .FI
21003: * BINARY OPERATOR T$BOP PTR TO OPERATOR DVBLK
21004: *
21005: * RIGHT PAREN T$RPR T$RPR
21006: *
21007: * RIGHT BRACKET T$RBR T$RBR
21008: *
21009: * COLON T$COL T$COL
21010: *
21011: * SEMI-COLON T$SMC T$SMC
21012: *
21013: * F (SCNGO NE 0) T$FGO T$FGO
21014: *
21015: * S (SCNGO NE 0) T$SGO T$SGO
21016: EJC
21017: *
21018: * SCANE (CONTINUED)
21019: *
21020: * ENTRY POINT
21021: *
21022: SCANE PRC E,0 ENTRY POINT
21023: ZER SCNBL RESET BLANKS FLAG
21024: MOV WA,SCNSA SAVE WA
21025: MOV WB,SCNSB SAVE WB
21026: MOV WC,SCNSC SAVE WC
21027: BZE SCNRS,SCN03 JUMP IF NO RESCAN
21028: *
21029: * HERE FOR RESCAN REQUEST
21030: *
21031: MOV SCNTP,XL SET PREVIOUS RETURNED SCAN TYPE
21032: MOV R$SCP,XR SET PREVIOUS RETURNED POINTER
21033: ZER SCNRS RESET RESCAN SWITCH
21034: BRN SCN13 JUMP TO EXIT
21035: *
21036: * COME HERE TO READ NEW IMAGE TO TEST FOR CONTINUATION
21037: *
21038: SCN01 JSR READR READ NEXT IMAGE
21039: MOV *DVUBS,WB SET WB FOR NOT READING NAME
21040: BZE XR,SCN30 TREAT AS SEMI-COLON IF NONE
21041: PLC XR ELSE POINT TO FIRST CHARACTER
21042: LCH WC,(XR) LOAD FIRST CHARACTER
21043: BEQ WC,=CH$DT,SCN02 JUMP IF DOT FOR CONTINUATION
21044: BNE WC,=CH$PL,SCN30 ELSE TREAT AS SEMICOLON UNLESS PLUS
21045: *
21046: * HERE FOR CONTINUATION LINE
21047: *
21048: SCN02 JSR NEXTS ACQUIRE NEXT SOURCE IMAGE
21049: MOV =NUM01,SCNPT SET SCAN POINTER PAST CONTINUATION
21050: MNZ SCNBL SET BLANKS FLAG
21051: EJC
21052: *
21053: * SCANE (CONTINUED)
21054: *
21055: * MERGE HERE TO SCAN NEXT ELEMENT ON CURRENT LINE
21056: *
21057: SCN03 MOV SCNPT,WA LOAD CURRENT OFFSET
21058: BEQ WA,SCNIL,SCN01 CHECK CONTINUATION IF END
21059: MOV R$CIM,XL POINT TO CURRENT LINE
21060: PLC XL,WA POINT TO CURRENT CHARACTER
21061: MOV WA,SCNSE SET START OF ELEMENT LOCATION
21062: MOV =OPDVS,WC POINT TO OPERATOR DV LIST
21063: MOV *DVUBS,WB SET CONSTANT FOR OPERATOR CIRCUIT
21064: BRN SCN06 START SCANNING
21065: *
21066: * LOOP HERE TO IGNORE LEADING BLANKS AND TABS
21067: *
21068: SCN05 BZE WB,SCN10 JUMP IF TRAILING
21069: ICV SCNSE INCREMENT START OF ELEMENT
21070: BEQ WA,SCNIL,SCN01 JUMP IF END OF IMAGE
21071: MNZ SCNBL NOTE BLANKS SEEN
21072: *
21073: * THE FOLLOWING JUMP IS USED REPEATEDLY FOR SCANNING OUT
21074: * THE CHARACTERS OF A NUMERIC CONSTANT OR VARIABLE NAME.
21075: * THE REGISTERS ARE USED AS FOLLOWS.
21076: *
21077: * (XR) SCRATCH
21078: * (XL) PTR TO NEXT CHARACTER
21079: * (WA) CURRENT SCAN OFFSET
21080: * (WB) *DVUBS (0 IF SCANNING NAME,CONST)
21081: * (WC) =OPDVS (0 IF SCANNING CONSTANT)
21082: *
21083: SCN06 LCH XR,(XL)+ GET NEXT CHARACTER
21084: ICV WA BUMP SCAN OFFSET
21085: MOV WA,SCNPT STORE OFFSET PAST CHAR SCANNED
21086: .IF .CUCF
21087: BLO =CFP$U,XR,SCN07 QUICK CHECK FOR OTHER CHAR
21088: BSW XR,CFP$U,SCN07 SWITCH ON SCANNED CHARACTER
21089: .ELSE
21090: BSW XR,CFP$A,SCN07 SWITCH ON SCANNED CHARACTER
21091: .FI
21092: *
21093: * SWITCH TABLE FOR SWITCH ON CHARACTER
21094: *
21095: IFF CH$BL,SCN05 BLANK
21096: .IF .CAHT
21097: IFF CH$HT,SCN05 HORIZONTAL TAB
21098: .FI
21099: .IF .CAVT
21100: IFF CH$VT,SCN05 VERTICAL TAB
21101: .FI
21102: IFF CH$D0,SCN08 DIGIT 0
21103: IFF CH$D1,SCN08 DIGIT 1
21104: IFF CH$D2,SCN08 DIGIT 2
21105: IFF CH$D3,SCN08 DIGIT 3
21106: IFF CH$D4,SCN08 DIGIT 4
21107: IFF CH$D5,SCN08 DIGIT 5
21108: IFF CH$D6,SCN08 DIGIT 6
21109: IFF CH$D7,SCN08 DIGIT 7
21110: IFF CH$D8,SCN08 DIGIT 8
21111: IFF CH$D9,SCN08 DIGIT 9
21112: EJC
21113: *
21114: * SCANE (CONTINUED)
21115: *
21116: IFF CH$LA,SCN09 LETTER A
21117: IFF CH$LB,SCN09 LETTER B
21118: IFF CH$LC,SCN09 LETTER C
21119: IFF CH$LD,SCN09 LETTER D
21120: IFF CH$LE,SCN09 LETTER E
21121: IFF CH$LG,SCN09 LETTER G
21122: IFF CH$LH,SCN09 LETTER H
21123: IFF CH$LI,SCN09 LETTER I
21124: IFF CH$LJ,SCN09 LETTER J
21125: IFF CH$LK,SCN09 LETTER K
21126: IFF CH$LL,SCN09 LETTER L
21127: IFF CH$LM,SCN09 LETTER M
21128: IFF CH$LN,SCN09 LETTER N
21129: IFF CH$LO,SCN09 LETTER O
21130: IFF CH$LP,SCN09 LETTER P
21131: IFF CH$LQ,SCN09 LETTER Q
21132: IFF CH$LR,SCN09 LETTER R
21133: IFF CH$LT,SCN09 LETTER T
21134: IFF CH$LU,SCN09 LETTER U
21135: IFF CH$LV,SCN09 LETTER V
21136: IFF CH$LW,SCN09 LETTER W
21137: IFF CH$LX,SCN09 LETTER X
21138: IFF CH$LY,SCN09 LETTER Y
21139: IFF CH$L$,SCN09 LETTER Z
21140: .IF .CASL
21141: IFF CH$$A,SCN09 SHIFTED A
21142: IFF CH$$B,SCN09 SHIFTED B
21143: IFF CH$$C,SCN09 SHIFTED C
21144: IFF CH$$D,SCN09 SHIFTED D
21145: IFF CH$$E,SCN09 SHIFTED E
21146: IFF CH$$F,SCN20 SHIFTED F
21147: IFF CH$$G,SCN09 SHIFTED G
21148: IFF CH$$H,SCN09 SHIFTED H
21149: IFF CH$$I,SCN09 SHIFTED I
21150: IFF CH$$J,SCN09 SHIFTED J
21151: IFF CH$$K,SCN09 SHIFTED K
21152: IFF CH$$L,SCN09 SHIFTED L
21153: IFF CH$$M,SCN09 SHIFTED M
21154: IFF CH$$N,SCN09 SHIFTED N
21155: IFF CH$$O,SCN09 SHIFTED O
21156: IFF CH$$P,SCN09 SHIFTED P
21157: IFF CH$$Q,SCN09 SHIFTED Q
21158: IFF CH$$R,SCN09 SHIFTED R
21159: IFF CH$$S,SCN21 SHIFTED S
21160: IFF CH$$T,SCN09 SHIFTED T
21161: IFF CH$$U,SCN09 SHIFTED U
21162: IFF CH$$V,SCN09 SHIFTED V
21163: IFF CH$$W,SCN09 SHIFTED W
21164: IFF CH$$X,SCN09 SHIFTED X
21165: IFF CH$$Y,SCN09 SHIFTED Y
21166: IFF CH$$$,SCN09 SHIFTED Z
21167: .FI
21168: EJC
21169: *
21170: * SCANE (CONTINUED)
21171: *
21172: IFF CH$SQ,SCN16 SINGLE QUOTE
21173: IFF CH$DQ,SCN17 DOUBLE QUOTE
21174: IFF CH$LF,SCN20 LETTER F
21175: IFF CH$LS,SCN21 LETTER S
21176: IFF CH$UN,SCN24 UNDERLINE
21177: IFF CH$PP,SCN25 LEFT PAREN
21178: IFF CH$RP,SCN26 RIGHT PAREN
21179: IFF CH$RB,SCN27 RIGHT BRACKET
21180: IFF CH$BB,SCN28 LEFT BRACKET
21181: IFF CH$CB,SCN27 RIGHT BRACKET
21182: IFF CH$OB,SCN28 LEFT BRACKET
21183: IFF CH$CL,SCN29 COLON
21184: IFF CH$SM,SCN30 SEMI-COLON
21185: IFF CH$CM,SCN31 COMMA
21186: IFF CH$DT,SCN32 DOT
21187: IFF CH$PL,SCN33 PLUS
21188: IFF CH$MN,SCN34 MINUS
21189: IFF CH$NT,SCN35 NOT
21190: IFF CH$DL,SCN36 DOLLAR
21191: IFF CH$EX,SCN37 EXCLAMATION MARK
21192: IFF CH$PC,SCN38 PERCENT
21193: IFF CH$SL,SCN40 SLASH
21194: IFF CH$NM,SCN41 NUMBER SIGN
21195: IFF CH$AT,SCN42 AT
21196: IFF CH$BR,SCN43 VERTICAL BAR
21197: IFF CH$AM,SCN44 AMPERSAND
21198: IFF CH$QU,SCN45 QUESTION MARK
21199: IFF CH$EQ,SCN46 EQUAL
21200: IFF CH$AS,SCN49 ASTERISK
21201: ESW END SWITCH ON CHARACTER
21202: *
21203: * HERE FOR ILLEGAL CHARACTER (UNDERLINE MERGES)
21204: *
21205: SCN07 BZE WB,SCN10 JUMP IF SCANNING NAME OR CONSTANT
21206: ERB 230,SYNTAX ERROR. ILLEGAL CHARACTER
21207: EJC
21208: *
21209: * SCANE (CONTINUED)
21210: *
21211: * HERE FOR DIGITS 0-9
21212: *
21213: SCN08 BZE WB,SCN09 KEEP SCANNING IF NAME/CONSTANT
21214: ZER WC ELSE SET FLAG FOR SCANNING CONSTANT
21215: *
21216: * HERE FOR LETTER. LOOP HERE WHEN SCANNING NAME/CONSTANT
21217: *
21218: SCN09 BEQ WA,SCNIL,SCN11 JUMP IF END OF IMAGE
21219: ZER WB SET FLAG FOR SCANNING NAME/CONST
21220: BRN SCN06 MERGE BACK TO CONTINUE SCAN
21221: *
21222: * COME HERE FOR DELIMITER ENDING NAME OR CONSTANT
21223: *
21224: SCN10 DCV WA RESET OFFSET TO POINT TO DELIMITER
21225: *
21226: * COME HERE AFTER FINISHING SCAN OF NAME OR CONSTANT
21227: *
21228: SCN11 MOV WA,SCNPT STORE UPDATED SCAN OFFSET
21229: MOV SCNSE,WB POINT TO START OF ELEMENT
21230: SUB WB,WA GET NUMBER OF CHARACTERS
21231: MOV R$CIM,XL POINT TO LINE IMAGE
21232: BNZ WC,SCN15 JUMP IF NAME
21233: *
21234: * HERE AFTER SCANNING OUT NUMERIC CONSTANT
21235: *
21236: JSR SBSTR GET STRING FOR CONSTANT
21237: MOV XR,DNAMP DELETE FROM STORAGE (NOT NEEDED)
21238: JSR GTNUM CONVERT TO NUMERIC
21239: PPM SCN14 JUMP IF CONVERSION FAILURE
21240: *
21241: * MERGE HERE TO EXIT WITH CONSTANT
21242: *
21243: SCN12 MOV =T$CON,XL SET RESULT TYPE OF CONSTANT
21244: EJC
21245: *
21246: * SCANE (CONTINUED)
21247: *
21248: * COMMON EXIT POINT (XR,XL) SET
21249: *
21250: SCN13 MOV SCNSA,WA RESTORE WA
21251: MOV SCNSB,WB RESTORE WB
21252: MOV SCNSC,WC RESTORE WC
21253: MOV XR,R$SCP SAVE XR IN CASE RESCAN
21254: MOV XL,SCNTP SAVE XL IN CASE RESCAN
21255: ZER SCNGO RESET POSSIBLE GOTO FLAG
21256: EXI RETURN TO SCANE CALLER
21257: *
21258: * HERE IF CONVERSION ERROR ON NUMERIC ITEM
21259: *
21260: SCN14 ERB 231,SYNTAX ERROR. INVALID NUMERIC ITEM
21261: *
21262: * HERE AFTER SCANNING OUT VARIABLE NAME
21263: *
21264: SCN15 JSR SBSTR BUILD STRING NAME OF VARIABLE
21265: BNZ SCNCC,SCN13 RETURN IF CNCRD CALL
21266: JSR GTNVR LOCATE/BUILD VRBLK
21267: PPM DUMMY (UNUSED) ERROR RETURN
21268: MOV =T$VAR,XL SET TYPE AS VARIABLE
21269: BRN SCN13 BACK TO EXIT
21270: *
21271: * HERE FOR SINGLE QUOTE (START OF STRING CONSTANT)
21272: *
21273: SCN16 BZE WB,SCN10 TERMINATOR IF SCANNING NAME OR CNST
21274: MOV =CH$SQ,WB SET TERMINATOR AS SINGLE QUOTE
21275: BRN SCN18 MERGE
21276: *
21277: * HERE FOR DOUBLE QUOTE (START OF STRING CONSTANT)
21278: *
21279: SCN17 BZE WB,SCN10 TERMINATOR IF SCANNING NAME OR CNST
21280: MOV =CH$DQ,WB SET DOUBLE QUOTE TERMINATOR, MERGE
21281: *
21282: * LOOP TO SCAN OUT STRING CONSTANT
21283: *
21284: SCN18 BEQ WA,SCNIL,SCN19 ERROR IF END OF IMAGE
21285: LCH WC,(XL)+ ELSE LOAD NEXT CHARACTER
21286: ICV WA BUMP OFFSET
21287: BNE WC,WB,SCN18 LOOP BACK IF NOT TERMINATOR
21288: EJC
21289: *
21290: * SCANE (CONTINUED)
21291: *
21292: * HERE AFTER SCANNING OUT STRING CONSTANT
21293: *
21294: MOV SCNPT,WB POINT TO FIRST CHARACTER
21295: MOV WA,SCNPT SAVE OFFSET PAST FINAL QUOTE
21296: DCV WA POINT BACK PAST LAST CHARACTER
21297: SUB WB,WA GET NUMBER OF CHARACTERS
21298: MOV R$CIM,XL POINT TO INPUT IMAGE
21299: JSR SBSTR BUILD SUBSTRING VALUE
21300: BRN SCN12 BACK TO EXIT WITH CONSTANT RESULT
21301: *
21302: * HERE IF NO MATCHING QUOTE FOUND
21303: *
21304: SCN19 MOV WA,SCNPT SET UPDATED SCAN POINTER
21305: ERB 232,SYNTAX ERROR. UNMATCHED STRING QUOTE
21306: *
21307: * HERE FOR F (POSSIBLE FAILURE GOTO)
21308: *
21309: SCN20 MOV =T$FGO,XR SET RETURN CODE FOR FAIL GOTO
21310: BRN SCN22 JUMP TO MERGE
21311: *
21312: * HERE FOR S (POSSIBLE SUCCESS GOTO)
21313: *
21314: SCN21 MOV =T$SGO,XR SET SUCCESS GOTO AS RETURN CODE
21315: *
21316: * SPECIAL GOTO CASES MERGE HERE
21317: *
21318: SCN22 BZE SCNGO,SCN09 TREAT AS NORMAL LETTER IF NOT GOTO
21319: *
21320: * MERGE HERE FOR SPECIAL CHARACTER EXIT
21321: *
21322: SCN23 BZE WB,SCN10 JUMP IF END OF NAME/CONSTANT
21323: MOV XR,XL ELSE COPY CODE
21324: BRN SCN13 AND JUMP TO EXIT
21325: *
21326: * HERE FOR UNDERLINE
21327: *
21328: SCN24 BZE WB,SCN09 PART OF NAME IF SCANNING NAME
21329: BRN SCN07 ELSE ILLEGAL
21330: EJC
21331: *
21332: * SCANE (CONTINUED)
21333: *
21334: * HERE FOR LEFT PAREN
21335: *
21336: SCN25 MOV =T$LPR,XR SET LEFT PAREN RETURN CODE
21337: BNZ WB,SCN23 RETURN LEFT PAREN UNLESS NAME
21338: BZE WC,SCN10 DELIMITER IF SCANNING CONSTANT
21339: *
21340: * HERE FOR LEFT PAREN AFTER NAME (FUNCTION CALL)
21341: *
21342: MOV SCNSE,WB POINT TO START OF NAME
21343: MOV WA,SCNPT SET POINTER PAST LEFT PAREN
21344: DCV WA POINT BACK PAST LAST CHAR OF NAME
21345: SUB WB,WA GET NAME LENGTH
21346: MOV R$CIM,XL POINT TO INPUT IMAGE
21347: JSR SBSTR GET STRING NAME FOR FUNCTION
21348: JSR GTNVR LOCATE/BUILD VRBLK
21349: PPM DUMMY (UNUSED) ERROR RETURN
21350: MOV =T$FNC,XL SET CODE FOR FUNCTION CALL
21351: BRN SCN13 BACK TO EXIT
21352: *
21353: * PROCESSING FOR SPECIAL CHARACTERS
21354: *
21355: SCN26 MOV =T$RPR,XR RIGHT PAREN, SET CODE
21356: BRN SCN23 TAKE SPECIAL CHARACTER EXIT
21357: *
21358: SCN27 MOV =T$RBR,XR RIGHT BRACKET, SET CODE
21359: BRN SCN23 TAKE SPECIAL CHARACTER EXIT
21360: *
21361: SCN28 MOV =T$LBR,XR LEFT BRACKET, SET CODE
21362: BRN SCN23 TAKE SPECIAL CHARACTER EXIT
21363: *
21364: SCN29 MOV =T$COL,XR COLON, SET CODE
21365: BRN SCN23 TAKE SPECIAL CHARACTER EXIT
21366: *
21367: SCN30 MOV =T$SMC,XR SEMI-COLON, SET CODE
21368: BRN SCN23 TAKE SPECIAL CHARACTER EXIT
21369: *
21370: SCN31 MOV =T$CMA,XR COMMA, SET CODE
21371: BRN SCN23 TAKE SPECIAL CHARACTER EXIT
21372: EJC
21373: *
21374: * SCANE (CONTINUED)
21375: *
21376: * HERE FOR OPERATORS. ON ENTRY, WC POINTS TO THE TABLE OF
21377: * OPERATOR DOPE VECTORS AND WB IS THE INCREMENT TO STEP
21378: * TO THE NEXT PAIR (BINARY/UNARY) OF DOPE VECTORS IN THE
21379: * LIST. ON REACHING SCN46, THE POINTER HAS BEEN ADJUSTED TO
21380: * POINT TO THE APPROPRIATE PAIR OF DOPE VECTORS.
21381: * THE FIRST THREE ENTRIES ARE SPECIAL SINCE THEY CAN OCCUR
21382: * AS PART OF A VARIABLE NAME (.) OR CONSTANT (.+-).
21383: *
21384: SCN32 BZE WB,SCN09 DOT CAN BE PART OF NAME OR CONSTANT
21385: ADD WB,WC ELSE BUMP POINTER
21386: *
21387: SCN33 BZE WC,SCN09 PLUS CAN BE PART OF CONSTANT
21388: BZE WB,SCN48 PLUS CANNOT BE PART OF NAME
21389: ADD WB,WC ELSE BUMP POINTER
21390: *
21391: SCN34 BZE WC,SCN09 MINUS CAN BE PART OF CONSTANT
21392: BZE WB,SCN48 MINUS CANNOT BE PART OF NAME
21393: ADD WB,WC ELSE BUMP POINTER
21394: *
21395: SCN35 ADD WB,WC NOT
21396: SCN36 ADD WB,WC DOLLAR
21397: SCN37 ADD WB,WC EXCLAMATION
21398: SCN38 ADD WB,WC PERCENT
21399: SCN39 ADD WB,WC ASTERISK
21400: SCN40 ADD WB,WC SLASH
21401: SCN41 ADD WB,WC NUMBER SIGN
21402: SCN42 ADD WB,WC AT SIGN
21403: SCN43 ADD WB,WC VERTICAL BAR
21404: SCN44 ADD WB,WC AMPERSAND
21405: SCN45 ADD WB,WC QUESTION MARK
21406: *
21407: * ALL OPERATORS COME HERE (EQUAL MERGES DIRECTLY)
21408: * (WC) POINTS TO THE BINARY/UNARY PAIR OF OPERATOR DVBLKS.
21409: *
21410: SCN46 BZE WB,SCN10 OPERATOR TERMINATES NAME/CONSTANT
21411: MOV WC,XR ELSE COPY DV POINTER
21412: LCH WC,(XL) LOAD NEXT CHARACTER
21413: MOV =T$BOP,XL SET BINARY OP IN CASE
21414: BEQ WA,SCNIL,SCN47 SHOULD BE BINARY IF IMAGE END
21415: BEQ WC,=CH$BL,SCN47 SHOULD BE BINARY IF FOLLOWED BY BLK
21416: .IF .CAHT
21417: BEQ WC,=CH$HT,SCN47 JUMP IF HORIZONTAL TAB
21418: .FI
21419: .IF .CAVT
21420: BEQ WC,=CH$VT,SCN47 JUMP IF VERTICAL TAB
21421: .FI
21422: BEQ WC,=CH$SM,SCN47 SEMICOLON CAN IMMEDIATELY FOLLOW =
21423: *
21424: * HERE FOR UNARY OPERATOR
21425: *
21426: ADD *DVBS$,XR POINT TO DV FOR UNARY OP
21427: MOV =T$UOP,XL SET TYPE FOR UNARY OPERATOR
21428: BLE SCNTP,=T$UOK,SCN13 OK UNARY IF OK PRECEDING ELEMENT
21429: EJC
21430: *
21431: * SCANE (CONTINUED)
21432: *
21433: * MERGE HERE TO REQUIRE PRECEDING BLANKS
21434: *
21435: SCN47 BNZ SCNBL,SCN13 ALL OK IF PRECEDING BLANKS, EXIT
21436: *
21437: * FAIL OPERATOR IN THIS POSITION
21438: *
21439: SCN48 ERB 233,SYNTAX ERROR. INVALID USE OF OPERATOR
21440: *
21441: * HERE FOR ASTERISK, COULD BE ** SUBSTITUTE FOR EXCLAMATION
21442: *
21443: SCN49 BZE WB,SCN10 END OF NAME IF SCANNING NAME
21444: BEQ WA,SCNIL,SCN39 NOT ** IF * AT IMAGE END
21445: MOV WA,XR ELSE SAVE OFFSET PAST FIRST *
21446: MOV WA,SCNOF SAVE ANOTHER COPY
21447: LCH WA,(XL)+ LOAD NEXT CHARACTER
21448: BNE WA,=CH$AS,SCN50 NOT ** IF NEXT CHAR NOT *
21449: ICV XR ELSE STEP OFFSET PAST SECOND *
21450: BEQ XR,SCNIL,SCN51 OK EXCLAM IF END OF IMAGE
21451: LCH WA,(XL) ELSE LOAD NEXT CHARACTER
21452: BEQ WA,=CH$BL,SCN51 EXCLAMATION IF BLANK
21453: .IF .CAHT
21454: BEQ WA,=CH$HT,SCN51 EXCLAMATION IF HORIZONTAL TAB
21455: .FI
21456: .IF .CAVT
21457: BEQ WA,=CH$VT,SCN51 EXCLAMATION IF VERTICAL TAB
21458: .FI
21459: *
21460: * UNARY *
21461: *
21462: SCN50 MOV SCNOF,WA RECOVER STORED OFFSET
21463: MOV R$CIM,XL POINT TO LINE AGAIN
21464: PLC XL,WA POINT TO CURRENT CHAR
21465: BRN SCN39 MERGE WITH UNARY *
21466: *
21467: * HERE FOR ** AS SUBSTITUTE FOR EXCLAMATION
21468: *
21469: SCN51 MOV XR,SCNPT SAVE SCAN POINTER PAST 2ND *
21470: MOV XR,WA COPY SCAN POINTER
21471: BRN SCN37 MERGE WITH EXCLAMATION
21472: ENP END PROCEDURE SCANE
21473: EJC
21474: *
21475: * SCNGF -- SCAN GOTO FIELD
21476: *
21477: * SCNGF IS CALLED FROM CMPIL TO SCAN AND ANALYZE A GOTO
21478: * FIELD INCLUDING THE SURROUNDING BRACKETS OR PARENTHESES.
21479: * FOR A NORMAL GOTO, THE RESULT RETURNED IS EITHER A VRBLK
21480: * POINTER FOR A SIMPLE LABEL OPERAND, OR A POINTER TO AN
21481: * EXPRESSION TREE WITH A SPECIAL OUTER UNARY OPERATOR
21482: * (O$GOC). FOR A DIRECT GOTO, THE RESULT RETURNED IS A
21483: * POINTER TO AN EXPRESSION TREE WITH THE SPECIAL OUTER
21484: * UNARY OPERATOR O$GOD.
21485: *
21486: * JSR SCNGF CALL TO SCAN GOTO FIELD
21487: * (XR) RESULT (SEE ABOVE)
21488: * (XL,WA,WB,WC) DESTROYED
21489: *
21490: SCNGF PRC E,0 ENTRY POINT
21491: JSR SCANE SCAN INITIAL ELEMENT
21492: BEQ XL,=T$LPR,SCNG1 SKIP IF LEFT PAREN (NORMAL GOTO)
21493: BEQ XL,=T$LBR,SCNG2 SKIP IF LEFT BRACKET (DIRECT GOTO)
21494: ERB 234,SYNTAX ERROR. GOTO FIELD INCORRECT
21495: *
21496: * HERE FOR LEFT PAREN (NORMAL GOTO)
21497: *
21498: SCNG1 MOV =NUM01,WB SET EXPAN FLAG FOR NORMAL GOTO
21499: JSR EXPAN ANALYZE GOTO FIELD
21500: MOV =OPDVN,WA POINT TO OPDV FOR COMPLEX GOTO
21501: BLE XR,STATB,SCNG3 JUMP IF NOT IN STATIC (SGD15)
21502: BLO XR,STATE,SCNG4 JUMP TO EXIT IF SIMPLE LABEL NAME
21503: BRN SCNG3 COMPLEX GOTO - MERGE
21504: *
21505: * HERE FOR LEFT BRACKET (DIRECT GOTO)
21506: *
21507: SCNG2 MOV =NUM02,WB SET EXPAN FLAG FOR DIRECT GOTO
21508: JSR EXPAN SCAN GOTO FIELD
21509: MOV =OPDVD,WA SET OPDV POINTER FOR DIRECT GOTO
21510: EJC
21511: *
21512: * SCNGF (CONTINUED)
21513: *
21514: * MERGE HERE TO BUILD OUTER UNARY OPERATOR BLOCK
21515: *
21516: SCNG3 MOV WA,-(XS) STACK OPERATOR DV POINTER
21517: MOV XR,-(XS) STACK POINTER TO EXPRESSION TREE
21518: JSR EXPOP POP OPERATOR OFF
21519: MOV (XS)+,XR RELOAD NEW EXPRESSION TREE POINTER
21520: *
21521: * COMMON EXIT POINT
21522: *
21523: SCNG4 EXI RETURN TO CALLER
21524: ENP END PROCEDURE SCNGF
21525: EJC
21526: *
21527: * SETVR -- SET VRGET,VRSTO FIELDS OF VRBLK
21528: *
21529: * SETVR SETS THE PROPER VALUES IN THE VRGET AND VRSTO
21530: * FIELDS OF A VRBLK. IT IS CALLED WHENEVER TRBLKS ARE
21531: * ADDED OR SUBTRACTED (TRACE,STOPTR,INPUT,OUTPUT,DETACH)
21532: *
21533: * (XR) POINTER TO VRBLK
21534: * JSR SETVR CALL TO SET FIELDS
21535: * (XL,WA) DESTROYED
21536: *
21537: * NOTE THAT SETVR IGNORES THE CALL IF XR DOES NOT POINT
21538: * INTO THE STATIC REGION (I.E. IS SOME OTHER NAME BASE)
21539: *
21540: SETVR PRC E,0 ENTRY POINT
21541: BHI XR,STATE,SETV1 EXIT IF NOT NATURAL VARIABLE
21542: *
21543: * HERE IF WE HAVE A VRBLK
21544: *
21545: MOV XR,XL COPY VRBLK POINTER
21546: MOV =B$VRL,VRGET(XR) STORE NORMAL GET VALUE
21547: BEQ VRSTO(XR),=B$VRE,SETV1 SKIP IF PROTECTED VARIABLE
21548: MOV =B$VRS,VRSTO(XR) STORE NORMAL STORE VALUE
21549: MOV VRVAL(XL),XL POINT TO NEXT ENTRY ON CHAIN
21550: BNE (XL),=B$TRT,SETV1 JUMP IF END OF TRBLK CHAIN
21551: MOV =B$VRA,VRGET(XR) STORE TRAPPED ROUTINE ADDRESS
21552: MOV =B$VRV,VRSTO(XR) SET TRAPPED ROUTINE ADDRESS
21553: *
21554: * MERGE HERE TO EXIT TO CALLER
21555: *
21556: SETV1 EXI RETURN TO SETVR CALLER
21557: ENP END PROCEDURE SETVR
21558: .IF .CNSR
21559: .ELSE
21560: EJC
21561: *
21562: * SORTA -- SORT ARRAY
21563: *
21564: * ROUTINE TO SORT AN ARRAY OR TABLE ON SAME BASIS AS IN
21565: * SITBOL. A TABLE IS CONVERTED TO AN ARRAY, LEAVING TWO
21566: * DIMENSIONAL ARRAYS AND VECTORS AS CASES TO BE CONSIDERED.
21567: * WHOLE ROWS OF ARRAYS ARE PERMUTED ACCORDING TO THE
21568: * ORDERING OF THE KEYS THEY CONTAIN, AND THE STRIDE
21569: * REFERRED TO, IS THE THE LENGTH OF A ROW. IT IS ONE
21570: * FOR A VECTOR.
21571: * THE SORT USED IS HEAPSORT, FUNDAMENTALS OF DATA STRUCTURE
21572: * HOROWITZ AND SAHNI, PITMAN 1977, PAGE 347.
21573: * IT IS AN ORDER N*LOG(N) ALGORITHM. IN ORDER
21574: * TO MAKE IT STABLE, COMPARANDS MAY NOT COMPARE EQUAL. THIS
21575: * IS ACHIEVED BY SORTING A COPY ARRAY (REFERRED TO AS THE
21576: * SORT ARRAY) CONTAINING AT ITS HIGH ADDRESS END, BYTE
21577: * OFFSETS TO THE ROWS TO BE SORTED HELD IN THE ORIGINAL
21578: * ARRAY (REFERRED TO AS THE KEY ARRAY). SORTC, THE
21579: * COMPARISON ROUTINE, ACCESSES THE KEYS THROUGH THESE
21580: * OFFSETS AND IN THE CASE OF EQUALITY, RESOLVES IT BY
21581: * COMPARING THE OFFSETS THEMSELVES. THE SORT PERMUTES THE
21582: * OFFSETS WHICH ARE THEN USED IN A FINAL OPERATION TO COPY
21583: * THE ACTUAL ITEMS INTO THE NEW ARRAY IN SORTED ORDER.
21584: * REFERENCES TO ZEROTH ITEM ARE TO NOTIONAL ITEM
21585: * PRECEDING FIRST ACTUAL ITEM.
21586: * REVERSE SORTING FOR RSORT IS DONE BY HAVING THE LESS THAN
21587: * TEST FOR KEYS EFFECTIVELY BE REPLACED BY A
21588: * GREATER THAN TEST.
21589: *
21590: * 1(XS) FIRST ARG - ARRAY OR TABLE
21591: * 0(XS) 2ND ARG - INDEX OR PDTYPE NAME
21592: * (WA) 0 , NON-ZERO FOR SORT , RSORT
21593: * JSR SORTA CALL TO SORT ARRAY
21594: * (XR) SORTED ARRAY
21595: * (XL,WA,WB,WC) DESTROYED
21596: EJC
21597: *
21598: * SORTA (CONTINUED)
21599: *
21600: SORTA PRC N,0 ENTRY POINT
21601: MOV WA,SRTSR SORT/RSORT INDICATOR
21602: MOV *NUM01,SRTST DEFAULT STRIDE OF 1
21603: ZER SRTOF DEFAULT ZERO OFFSET TO SORT KEY
21604: MOV =NULLS,SRTDF CLEAR DATATYPE FIELD NAME
21605: MOV (XS)+,R$SXR UNSTACK ARGUMENT 2
21606: MOV (XS)+,XR GET FIRST ARGUMENT
21607: JSR GTARR CONVERT TO ARRAY
21608: PPM SRT16 FAIL
21609: MOV XR,-(XS) STACK PTR TO RESULTING KEY ARRAY
21610: MOV XR,-(XS) ANOTHER COPY FOR COPYB
21611: JSR COPYB GET COPY ARRAY FOR SORTING INTO
21612: PPM CANT FAIL
21613: MOV XR,-(XS) STACK POINTER TO SORT ARRAY
21614: MOV R$SXR,XR GET SECOND ARG
21615: MOV 1(XS),XL GET PTR TO KEY ARRAY
21616: BNE (XL),=B$VCT,SRT02 JUMP IF ARBLK
21617: BEQ XR,=NULLS,SRT01 JUMP IF NULL SECOND ARG
21618: JSR GTNVR GET VRBLK PTR FOR IT
21619: ERR 257,ERRONEOUS 2ND ARG IN SORT/RSORT OF VECTOR
21620: MOV XR,SRTDF STORE DATATYPE FIELD NAME VRBLK
21621: *
21622: * COMPUTE N AND OFFSET TO ITEM A(0) IN VECTOR CASE
21623: *
21624: SRT01 MOV *VCLEN,WC OFFSET TO A(0)
21625: MOV *VCVLS,WB OFFSET TO FIRST ITEM
21626: MOV VCLEN(XL),WA GET BLOCK LENGTH
21627: SUB *VCSI$,WA GET NO. OF ENTRIES, N (IN BYTES)
21628: BRN SRT04 MERGE
21629: *
21630: * HERE FOR ARRAY
21631: *
21632: SRT02 LDI ARDIM(XL) GET POSSIBLE DIMENSION
21633: MFI WA CONVERT TO SHORT INTEGER
21634: WTB WA FURTHER CONVERT TO BAUS
21635: MOV *ARVLS,WB OFFSET TO FIRST VALUE IF ONE
21636: MOV *ARPRO,WC OFFSET BEFORE VALUES IF ONE DIM.
21637: BEQ ARNDM(XL),=NUM01,SRT04 JUMP IN FACT IF ONE DIM.
21638: BNE ARNDM(XL),=NUM02,SRT16 FAIL UNLESS TWO DIMENS
21639: LDI ARLB2(XL) GET LOWER BOUND 2 AS DEFAULT
21640: BEQ XR,=NULLS,SRT03 JUMP IF DEFAULT SECOND ARG
21641: JSR GTINT CONVERT TO INTEGER
21642: PPM SRT17 FAIL
21643: LDI ICVAL(XR) GET ACTUAL INTEGER VALUE
21644: EJC
21645: *
21646: * SORTA (CONTINUED)
21647: *
21648: * HERE WITH SORT COLUMN INDEX IN IA IN ARRAY CASE
21649: *
21650: SRT03 SBI ARLB2(XL) SUBTRACT LOW BOUND
21651: IOV SRT17 FAIL IF OVERFLOW
21652: ILT SRT17 FAIL IF BELOW LOW BOUND
21653: SBI ARDM2(XL) CHECK AGAINST DIMENSION
21654: IGE SRT17 FAIL IF TOO LARGE
21655: ADI ARDM2(XL) RESTORE VALUE
21656: MFI WA GET AS SMALL INTEGER
21657: WTB WA OFFSET WITHIN ROW TO KEY
21658: MOV WA,SRTOF KEEP OFFSET
21659: LDI ARDM2(XL) SECOND DIMENSION IS ROW LENGTH
21660: MFI WA CONVERT TO SHORT INTEGER
21661: MOV WA,XR COPY ROW LENGTH
21662: WTB WA CONVERT TO BYTES
21663: MOV WA,SRTST STORE AS STRIDE
21664: LDI ARDIM(XL) GET NUMBER OF ROWS
21665: MFI WA AS A SHORT INTEGER
21666: WTB WA CONVERT N TO BAUS
21667: MOV ARLEN(XL),WC OFFSET PAST ARRAY END
21668: SUB WA,WC ADJUST, GIVING SPACE FOR N OFFSETS
21669: DCA WC POINT TO A(0)
21670: MOV AROFS(XL),WB OFFSET TO WORD BEFORE FIRST ITEM
21671: ICA WB OFFSET TO FIRST ITEM
21672: *
21673: * SEPARATE PRE-PROCESSING FOR ARRAYS AND VECTORS DONE.
21674: * TO SIMPLIFY LATER KEY COMPARISONS, REMOVAL OF ANY TRBLK
21675: * TRAP BLOCKS FROM ENTRIES IN KEY ARRAY IS EFFECTED.
21676: *
21677: * (XL) = 1(XS) = POINTER TO KEY ARRAY
21678: * (XS) = POINTER TO SORT ARRAY
21679: * WA = NUMBER OF ITEMS, N (CONVERTED TO BYTES).
21680: * WB = OFFSET TO FIRST ITEM OF ARRAYS.
21681: * WC = OFFSET TO A(0)
21682: *
21683: SRT04 BLE WA,*NUM01,SRT15 RETURN IF ONLY A SINGLE ITEM
21684: MOV WA,SRTSN STORE NUMBER OF ITEMS (IN BAUS)
21685: MOV WC,SRTSO STORE OFFSET TO A(0)
21686: MOV ARLEN(XL),WC LENGTH OF ARRAY OR VEC (=VCLEN)
21687: ADD XL,WC POINT PAST END OF ARRAY OR VECTOR
21688: MOV WB,SRTSF STORE OFFSET TO FIRST ROW
21689: ADD WB,XL POINT TO FIRST ITEM IN KEY ARRAY
21690: *
21691: * LOOP THROUGH ARRAY
21692: *
21693: SRT05 MOV (XL),XR GET AN ENTRY
21694: *
21695: * HUNT ALONG TRBLK CHAIN
21696: *
21697: SRT06 BNE (XR),=B$TRT,SRT07 JUMP OUT IF NOT TRBLK
21698: MOV TRVAL(XR),XR GET VALUE FIELD
21699: BRN SRT06 LOOP
21700: EJC
21701: *
21702: * SORTA (CONTINUED)
21703: *
21704: * XR IS VALUE FROM END OF CHAIN
21705: *
21706: SRT07 MOV XR,(XL)+ STORE AS ARRAY ENTRY
21707: BLT XL,WC,SRT05 LOOP IF NOT DONE
21708: MOV (XS),XL GET ADRS OF SORT ARRAY
21709: MOV SRTSF,XR INITIAL OFFSET TO FIRST KEY
21710: MOV SRTST,WB GET STRIDE
21711: ADD SRTSO,XL OFFSET TO A(0)
21712: ICA XL POINT TO A(1)
21713: MOV SRTSN,WC GET N
21714: BTW WC CONVERT FROM BYTES
21715: MOV WC,SRTNR STORE AS ROW COUNT
21716: LCT WC,WC LOOP COUNTER
21717: *
21718: * STORE KEY OFFSETS AT TOP OF SORT ARRAY
21719: *
21720: SRT08 MOV XR,(XL)+ STORE AN OFFSET
21721: ADD WB,XR BUMP OFFSET BY STRIDE
21722: BCT WC,SRT08 LOOP THROUGH ROWS
21723: *
21724: * PERFORM THE SORT ON OFFSETS IN SORT ARRAY.
21725: *
21726: * (SRTSN) NUMBER OF ITEMS TO SORT, N (BYTES)
21727: * (SRTSO) OFFSET TO A(0)
21728: *
21729: SRT09 MOV SRTSN,WA GET N
21730: MOV SRTNR,WC GET NUMBER OF ROWS
21731: RSH WC,1 I = N / 2 (WC=I, INDEX INTO ARRAY)
21732: WTB WC CONVERT BACK TO BYTES
21733: *
21734: * LOOP TO FORM INITIAL HEAP
21735: *
21736: SRT10 JSR SORTH SORTH(I,N)
21737: DCA WC I = I - 1
21738: BNZ WC,SRT10 LOOP IF I GT 0
21739: MOV WA,WC I = N
21740: *
21741: * SORTING LOOP. AT THIS POINT, A(1) IS THE LARGEST
21742: * ITEM, SINCE ALGORITHM INITIALISES IT AS, AND THEN MAINTAI
21743: * IT AS, ROOT OF TREE.
21744: *
21745: SRT11 DCA WC I = I - 1 (N - 1 INITIALLY)
21746: BZE WC,SRT12 JUMP IF DONE
21747: MOV (XS),XR GET SORT ARRAY ADDRESS
21748: ADD SRTSO,XR POINT TO A(0)
21749: MOV XR,XL A(0) ADDRESS
21750: ADD WC,XL A(I) ADDRESS
21751: MOV 1(XL),WB COPY A(I+1)
21752: MOV 1(XR),1(XL) MOVE A(1) TO A(I+1)
21753: MOV WB,1(XR) COMPLETE EXCHANGE OF A(1), A(I+1)
21754: MOV WC,WA N = I FOR SORTH
21755: MOV *NUM01,WC I = 1 FOR SORTH
21756: JSR SORTH SORTH(1,N)
21757: MOV WA,WC RESTORE WC
21758: BRN SRT11 LOOP
21759: EJC
21760: *
21761: * SORTA (CONTINUED)
21762: *
21763: * OFFSETS HAVE BEEN PERMUTED INTO REQUIRED ORDER BY SORT.
21764: * COPY ARRAY ELEMENTS OVER THEM.
21765: *
21766: SRT12 MOV (XS),XL BASE ADRS OF KEY ARRAY
21767: MOV XL,WC COPY IT
21768: ADD SRTSO,WC OFFSET OF A(0)
21769: ADD SRTSF,XL ADRS OF FIRST ROW OF SORT ARRAY
21770: MOV SRTST,WB GET STRIDE
21771: BTW WB CONVERT TO WORDS
21772: *
21773: * COPYING LOOP FOR SUCCESSIVE ITEMS. SORTED OFFSETS ARE
21774: * HELD AT END OF SORT ARRAY.
21775: *
21776: SRT13 ICA WC ADRS OF NEXT OF SORTED OFFSETS
21777: MOV WC,XR COPY IT FOR ACCESS
21778: MOV (XR),XR GET OFFSET
21779: ADD 1(XS),XR ADD KEY ARRAY BASE ADRS
21780: LCT WA,WB GET COUNT OF WORDS IN ROW
21781: *
21782: * COPY A COMPLETE ROW
21783: *
21784: SRT14 MOV (XR)+,(XL)+ MOVE A WORD
21785: BCT WA,SRT14 LOOP
21786: DCV SRTNR DECREMENT ROW COUNT
21787: BNZ SRTNR,SRT13 REPEAT TILL ALL ROWS DONE
21788: *
21789: * RETURN POINT
21790: *
21791: SRT15 MOV (XS)+,XR POP RESULT ARRAY PTR
21792: ICA XS POP KEY ARRAY PTR
21793: ZER R$SXL CLEAR JUNK
21794: ZER R$SXR CLEAR JUNK
21795: EXI RETURN
21796: *
21797: * ERROR POINT
21798: *
21799: SRT16 ERB 256,SORT/RSORT 1ST ARG NOT SUITABLE ARRAY OR TABLE
21800: SRT17 ERB 258,SORT/RSORT 2ND ARG OUT OF RANGE OR NON-INTEGER
21801: ENP END PROCUDURE SORTA
21802: EJC
21803: *
21804: * SORTC -- COMPARE SORT KEYS
21805: *
21806: * COMPARE TWO SORT KEYS GIVEN THEIR OFFSETS. IF
21807: * EQUAL, COMPARE KEY OFFSETS TO GIVE STABLE SORT.
21808: * NOTE THAT IF SRTSR IS NON-ZERO (REQUEST FOR REVERSE
21809: * SORT), THE QUOTED RETURNS ARE INVERTED.
21810: * FOR OBJECTS OF DIFFERING DATATYPES, THE ENTRY POINT
21811: * IDENTIFICATIONS ARE COMPARED.
21812: *
21813: * (XL) BASE ADRS FOR KEYS
21814: * (WA) OFFSET TO KEY 1 ITEM
21815: * (WB) OFFSET TO KEY 2 ITEM
21816: * (SRTSR) ZERO/NON-ZERO FOR SORT/RSORT
21817: * (SRTOF) OFFSET WITHIN ROW TO COMPARANDS
21818: * JSR SORTC CALL TO COMPARE KEYS
21819: * PPM LOC KEY1 LESS THAN KEY2
21820: * NORMAL RETURN, KEY1 GT THAN KEY2
21821: * (XL,XR,WA,WB) DESTROYED
21822: *
21823: SORTC PRC E,1 ENTRY POINT
21824: MOV WA,SRTS1 SAVE OFFSET 1
21825: MOV WB,SRTS2 SAVE OFFSET 2
21826: MOV WC,SRTSC SAVE WC
21827: ADD SRTOF,XL ADD OFFSET TO COMPARAND FIELD
21828: MOV XL,XR COPY BASE + OFFSET
21829: ADD WA,XL ADD KEY1 OFFSET
21830: ADD WB,XR ADD KEY2 OFFSET
21831: MOV (XL),XL GET KEY1
21832: MOV (XR),XR GET KEY2
21833: BNE SRTDF,=NULLS,SRC11 JUMP IF DATATYPE FIELD NAME USED
21834: EJC
21835: *
21836: * SORTC (CONTINUED)
21837: *
21838: * MERGE AFTER DEALING WITH FIELD NAME. TRY FOR STRINGS.
21839: *
21840: SRC01 MOV (XL),WC GET TYPE CODE
21841: BNE WC,(XR),SRC02 SKIP IF NOT SAME DATATYPE
21842: BEQ WC,=B$SCL,SRC09 JUMP IF BOTH STRINGS
21843: *
21844: * NOW TRY FOR NUMERIC
21845: *
21846: SRC02 MOV XL,R$SXL KEEP ARG1
21847: MOV XR,R$SXR KEEP ARG2
21848: MOV XL,-(XS) STACK
21849: MOV XR,-(XS) ARGS
21850: JSR ACOMP COMPARE OBJECTS
21851: PPM SRC10 NOT NUMERIC
21852: PPM SRC10 NOT NUMERIC
21853: PPM SRC03 KEY1 LESS
21854: PPM SRC08 KEYS EQUAL
21855: PPM SRC05 KEY1 GREATER
21856: *
21857: * RETURN IF KEY1 SMALLER (SORT), GREATER (RSORT)
21858: *
21859: SRC03 BNZ SRTSR,SRC06 JUMP IF RSORT
21860: *
21861: SRC04 MOV SRTSC,WC RESTORE WC
21862: EXI 1 RETURN
21863: *
21864: * RETURN IF KEY1 GREATER (SORT), SMALLER (RSORT)
21865: *
21866: SRC05 BNZ SRTSR,SRC04 JUMP IF RSORT
21867: *
21868: SRC06 MOV SRTSC,WC RESTORE WC
21869: EXI RETURN
21870: *
21871: * KEYS ARE OF SAME DATATYPE
21872: *
21873: SRC07 BLT XL,XR,SRC03 ITEM FIRST CREATED IS LESS
21874: BGT XL,XR,SRC05 ADDRESSES RISE IN ORDER OF CREATION
21875: *
21876: * DROP THROUGH OR MERGE FOR IDENTICAL OR EQUAL OBJECTS
21877: *
21878: SRC08 BLT SRTS1,SRTS2,SRC04 TEST OFFSETS OR KEY ADDRSS INSTEAD
21879: BRN SRC06 OFFSET 1 GREATER
21880: EJC
21881: *
21882: * SORTC (CONTINUED)
21883: *
21884: * STRINGS
21885: *
21886: SRC09 MOV XL,-(XS) STACK
21887: MOV XR,-(XS) ARGS
21888: JSR LCOMP COMPARE OBJECTS
21889: PPM CANT
21890: PPM FAIL
21891: PPM SRC03 KEY1 LESS
21892: PPM SRC08 KEYS EQUAL
21893: PPM SRC05 KEY1 GREATER
21894: *
21895: * ARITHMETIC COMPARISON FAILED - RECOVER ARGS
21896: *
21897: SRC10 MOV R$SXL,XL GET ARG1
21898: MOV R$SXR,XR GET ARG2
21899: MOV (XL),WC GET TYPE OF KEY1
21900: BEQ WC,(XR),SRC07 JUMP IF KEYS OF SAME TYPE
21901: MOV WC,XL GET BLOCK TYPE WORD
21902: MOV (XR),XR GET BLOCK TYPE WORD
21903: LEI XL ENTRY POINT ID FOR KEY1
21904: LEI XR ENTRY POINT ID FOR KEY2
21905: BGT XL,XR,SRC05 JUMP IF KEY1 GT KEY2
21906: BRN SRC03 KEY1 LT KEY2
21907: *
21908: * DATATYPE FIELD NAME USED
21909: *
21910: SRC11 JSR SORTF CALL ROUTINE TO FIND FIELD 1
21911: MOV XL,-(XS) STACK ITEM POINTER
21912: MOV XR,XL GET KEY2
21913: JSR SORTF FIND FIELD 2
21914: MOV XL,XR PLACE AS KEY2
21915: MOV (XS)+,XL RECOVER KEY1
21916: BRN SRC01 MERGE
21917: ENP PROCEDURE SORTC
21918: EJC
21919: *
21920: * SORTF -- FIND FIELD FOR SORTC
21921: *
21922: * ROUTINE USED BY SORTC TO OBTAIN ITEM CORRESPONDING
21923: * TO A GIVEN FIELD NAME, IF THIS EXISTS, IN A PROGRAMMER
21924: * DEFINED OBJECT PASSED AS ARGUMENT.
21925: * IF SUCH A MATCH OCCURS, RECORD IS KEPT OF DATATYPE
21926: * NAME, FIELD NAME AND OFFSET TO FIELD IN ORDER TO
21927: * SHORT-CIRCUIT LATER SEARCHES ON SAME TYPE. NOTE THAT
21928: * DFBLKS ARE STORED IN STATIC AND HENCE CANNOT BE MOVED.
21929: *
21930: * (SRTDF) VRBLK POINTER OF FIELD NAME
21931: * (XL) POSSIBLE PDBLK POINTER
21932: * JSR SORTF CALL TO SEARCH FOR FIELD NAME
21933: * (XL) ITEM FOUND OR ORIGINAL PDBLK PTR
21934: * (WC) DESTROYED
21935: *
21936: SORTF PRC E,0 ENTRY POINT
21937: BNE (XL),=B$PDT,SRTF3 RETURN IF NOT PDBLK
21938: MOV XR,-(XS) KEEP XR
21939: MOV SRTFD,XR GET POSSIBLE FORMER DFBLK PTR
21940: BZE XR,SRTF4 JUMP IF NOT
21941: BNE XR,PDDFP(XL),SRTF4 JUMP IF NOT RIGHT DATATYPE
21942: BNE SRTDF,SRTFF,SRTF4 JUMP IF NOT RIGHT FIELD NAME
21943: ADD SRTFO,XL ADD OFFSET TO REQUIRED FIELD
21944: *
21945: * HERE WITH XL POINTING TO FOUND FIELD
21946: *
21947: SRTF1 MOV (XL),XL GET ITEM FROM FIELD
21948: *
21949: * RETURN POINT
21950: *
21951: SRTF2 MOV (XS)+,XR RESTORE XR
21952: *
21953: SRTF3 EXI RETURN
21954: EJC
21955: *
21956: * SORTF (CONTINUED)
21957: *
21958: * CONDUCT A SEARCH
21959: *
21960: SRTF4 MOV XL,XR COPY ORIGINAL POINTER
21961: MOV PDDFP(XR),XR POINT TO DFBLK
21962: MOV XR,SRTFD KEEP A COPY
21963: MOV FARGS(XR),WC GET NUMBER OF FIELDS
21964: WTB WC CONVERT TO BYTES
21965: ADD DFLEN(XR),XR POINT PAST LAST FIELD
21966: *
21967: * LOOP TO FIND NAME IN PDFBLK
21968: *
21969: SRTF5 DCA WC COUNT DOWN
21970: DCA XR POINT IN FRONT
21971: BEQ (XR),SRTDF,SRTF6 SKIP OUT IF FOUND
21972: BNZ WC,SRTF5 LOOP
21973: BRN SRTF2 RETURN - NOT FOUND
21974: *
21975: * FOUND
21976: *
21977: SRTF6 MOV (XR),SRTFF KEEP FIELD NAME PTR
21978: ADD *PDFLD,WC ADD OFFSET TO FIRST FIELD
21979: MOV WC,SRTFO STORE AS FIELD OFFSET
21980: ADD WC,XL POINT TO FIELD
21981: BRN SRTF1 RETURN
21982: ENP PROCEDURE SORTF
21983: EJC
21984: *
21985: * SORTH -- HEAP ROUTINE FOR SORTA
21986: *
21987: * THIS ROUTINE CONSTRUCTS A HEAP FROM ELEMENTS OF ARRAY, A.
21988: * IN THIS APPLICATION, THE ELEMENTS ARE OFFSETS TO KEYS IN
21989: * A KEY ARRAY.
21990: *
21991: * (XS) POINTER TO SORT ARRAY BASE
21992: * 1(XS) POINTER TO KEY ARRAY BASE
21993: * (WA) MAX ARRAY INDEX, N (IN BYTES)
21994: * (WC) OFFSET J IN A TO ROOT (IN *1 TO *N)
21995: * JSR SORTH CALL SORTH(J,N) TO MAKE HEAP
21996: * (XL,XR,WB) DESTROYED
21997: *
21998: SORTH PRC N,0 ENTRY POINT
21999: MOV WA,SRTSN SAVE N
22000: MOV WC,SRTWC KEEP WC
22001: MOV (XS),XL SORT ARRAY BASE ADRS
22002: ADD SRTSO,XL ADD OFFSET TO A(0)
22003: ADD WC,XL POINT TO A(J)
22004: MOV (XL),SRTRT GET OFFSET TO ROOT
22005: ADD WC,WC DOUBLE J - CANT EXCEED N
22006: *
22007: * LOOP TO MOVE DOWN TREE USING DOUBLED INDEX J
22008: *
22009: SRH01 BGT WC,SRTSN,SRH03 DONE IF J GT N
22010: BEQ WC,SRTSN,SRH02 SKIP IF J EQUALS N
22011: MOV (XS),XR SORT ARRAY BASE ADRS
22012: MOV 1(XS),XL KEY ARRAY BASE ADRS
22013: ADD SRTSO,XR POINT TO A(0)
22014: ADD WC,XR ADRS OF A(J)
22015: MOV 1(XR),WA GET A(J+1)
22016: MOV (XR),WB GET A(J)
22017: *
22018: * COMPARE SONS. (WA) RIGHT SON, (WB) LEFT SON
22019: *
22020: JSR SORTC COMPARE KEYS - LT(A(J+1),A(J))
22021: PPM SRH02 A(J+1) LT A(J)
22022: ICA WC POINT TO GREATER SON, A(J+1)
22023: EJC
22024: *
22025: * SORTH (CONTINUED)
22026: *
22027: * COMPARE ROOT WITH GREATER SON
22028: *
22029: SRH02 MOV 1(XS),XL KEY ARRAY BASE ADRS
22030: MOV (XS),XR GET SORT ARRAY ADDRESS
22031: ADD SRTSO,XR ADRS OF A(0)
22032: MOV XR,WB COPY THIS ADRS
22033: ADD WC,XR ADRS OF GREATER SON, A(J)
22034: MOV (XR),WA GET A(J)
22035: MOV WB,XR POINT BACK TO A(0)
22036: MOV SRTRT,WB GET ROOT
22037: JSR SORTC COMPARE THEM - LT(A(J),ROOT)
22038: PPM SRH03 FATHER EXCEEDS SONS - DONE
22039: MOV (XS),XR GET SORT ARRAY ADRS
22040: ADD SRTSO,XR POINT TO A(0)
22041: MOV XR,XL COPY IT
22042: MOV WC,WA COPY J
22043: BTW WC CONVERT TO WORDS
22044: RSH WC,1 GET J/2
22045: WTB WC CONVERT BACK TO BYTES
22046: ADD WA,XL POINT TO A(J)
22047: ADD WC,XR ADRS OF A(J/2)
22048: MOV (XL),(XR) A(J/2) = A(J)
22049: MOV WA,WC RECOVER J
22050: AOV WC,WC,SRH03 J = J*2. DONE IF TOO BIG
22051: BRN SRH01 LOOP
22052: *
22053: * FINISH BY COPYING ROOT OFFSET BACK INTO ARRAY
22054: *
22055: SRH03 BTW WC CONVERT TO WORDS
22056: RSH WC,1 J = J/2
22057: WTB WC CONVERT BACK TO BYTES
22058: MOV (XS),XR SORT ARRAY ADRS
22059: ADD SRTSO,XR ADRS OF A(0)
22060: ADD WC,XR ADRS OF A(J/2)
22061: MOV SRTRT,(XR) A(J/2) = ROOT
22062: MOV SRTSN,WA RESTORE WA
22063: MOV SRTWC,WC RESTORE WC
22064: EXI RETURN
22065: ENP END PROCEDURE SORTH
22066: EJC
22067: .FI
22068: EJC
22069: *
22070: * TFIND -- LOCATE TABLE ELEMENT
22071: *
22072: * (XR) SUBSCRIPT VALUE FOR ELEMENT
22073: * (XL) POINTER TO TABLE
22074: * (WB) ZERO BY VALUE, NON-ZERO BY NAME
22075: * JSR TFIND CALL TO LOCATE ELEMENT
22076: * PPM LOC TRANSFER LOCATION IF ACCESS FAILS
22077: * (XR) ELEMENT VALUE (IF BY VALUE)
22078: * (XR) DESTROYED (IF BY NAME)
22079: * (XL,WA) TEBLK NAME (IF BY NAME)
22080: * (XL,WA) DESTROYED (IF BY VALUE)
22081: * (WC,RA) DESTROYED
22082: *
22083: * NOTE THAT IF A CALL BY VALUE SPECIFIES A NON-EXISTENT
22084: * SUBSCRIPT, NULL IS RETURNED WITHOUT BUILDING A NEW TEBLK.
22085: *
22086: TFIND PRC E,1 ENTRY POINT
22087: MOV WB,-(XS) SAVE NAME/VALUE INDICATOR
22088: MOV XR,-(XS) SAVE SUBSCRIPT VALUE
22089: MOV XL,-(XS) SAVE TABLE POINTER
22090: MOV TBLEN(XL),WA LOAD LENGTH OF TBBLK
22091: BTW WA CONVERT TO WORD COUNT
22092: SUB =TBBUK,WA GET NUMBER OF BUCKETS
22093: MTI WA CONVERT TO INTEGER VALUE
22094: STI TFNSI SAVE FOR LATER
22095: MOV (XR),XL LOAD FIRST WORD OF SUBSCRIPT
22096: LEI XL LOAD BLOCK ENTRY ID (BL$XX)
22097: BSW XL,BL$$D,TFN00 SWITCH ON BLOCK TYPE
22098: IFF BL$IC,TFN02 JUMP IF INTEGER
22099: .IF .CNRA
22100: .ELSE
22101: IFF BL$RC,TFN02 REAL
22102: .FI
22103: IFF BL$P0,TFN03 JUMP IF PATTERN
22104: IFF BL$P1,TFN03 JUMP IF PATTERN
22105: IFF BL$P2,TFN03 JUMP IF PATTERN
22106: IFF BL$NM,TFN04 JUMP IF NAME
22107: IFF BL$SC,TFN05 JUMP IF STRING
22108: ESW END SWITCH ON BLOCK TYPE
22109: *
22110: * HERE FOR BLOCKS FOR WHICH WE USE THE SECOND WORD OF THE
22111: * BLOCK AS THE HASH SOURCE (SEE BLOCK FORMATS FOR DETAILS).
22112: *
22113: TFN00 MOV 1(XR),WA LOAD SECOND WORD
22114: *
22115: * MERGE HERE WITH ONE WORD HASH SOURCE IN WA
22116: *
22117: TFN01 MTI WA CONVERT TO INTEGER
22118: BRN TFN06 JUMP TO MERGE
22119: EJC
22120: *
22121: * TFIND (CONTINUED)
22122: *
22123: * HERE FOR INTEGER OR REAL
22124: *
22125: TFN02 LDI 1(XR) LOAD VALUE AS HASH SOURCE
22126: IGE TFN06 OK IF POSITIVE OR ZERO
22127: NGI MAKE POSITIVE
22128: IOV TFN06 CLEAR POSSIBLE OVERFLOW
22129: BRN TFN06 MERGE
22130: *
22131: * FOR PATTERN, USE FIRST WORD (PCODE) AS SOURCE
22132: *
22133: TFN03 MOV (XR),WA LOAD FIRST WORD AS HASH SOURCE
22134: BRN TFN01 MERGE BACK
22135: *
22136: * FOR NAME, USE OFFSET AS HASH SOURCE
22137: *
22138: TFN04 MOV NMOFS(XR),WA LOAD OFFSET AS HASH SOURCE
22139: BRN TFN01 MERGE BACK
22140: *
22141: * HERE FOR STRING
22142: *
22143: TFN05 JSR HASHS CALL ROUTINE TO COMPUTE HASH
22144: *
22145: * MERGE HERE WITH HASH SOURCE IN (IA)
22146: *
22147: TFN06 RMI TFNSI COMPUTE HASH INDEX BY REMAINDERING
22148: MFI WC GET AS ONE WORD INTEGER
22149: WTB WC CONVERT TO BYTE OFFSET
22150: MOV (XS),XL GET TABLE PTR AGAIN
22151: ADD WC,XL POINT TO PROPER BUCKET
22152: MOV TBBUK(XL),XR LOAD FIRST TEBLK POINTER
22153: BEQ XR,(XS),TFN10 JUMP IF NO TEBLKS ON CHAIN
22154: *
22155: * LOOP THROUGH TEBLKS ON HASH CHAIN
22156: *
22157: TFN07 MOV XR,WB SAVE TEBLK POINTER
22158: MOV TESUB(XR),XR LOAD SUBSCRIPT VALUE
22159: MOV 1(XS),XL LOAD INPUT ARGUMENT SUBSCRIPT VAL
22160: JSR IDENT COMPARE THEM
22161: PPM TFN08 JUMP IF EQUAL (IDENT)
22162: *
22163: * HERE IF NO MATCH WITH THAT TEBLK
22164: *
22165: MOV WB,XL RESTORE TEBLK POINTER
22166: MOV TENXT(XL),XR POINT TO NEXT TEBLK ON CHAIN
22167: BNE XR,(XS),TFN07 JUMP IF THERE IS ONE
22168: *
22169: * HERE IF NO MATCH WITH ANY TEBLK ON CHAIN
22170: *
22171: MOV *TENXT,WC SET OFFSET TO LINK FIELD (XL BASE)
22172: BRN TFN11 JUMP TO MERGE
22173: EJC
22174: *
22175: * TFIND (CONTINUED)
22176: *
22177: * HERE WE HAVE FOUND A MATCHING ELEMENT
22178: *
22179: TFN08 MOV WB,XL RESTORE TEBLK POINTER
22180: MOV *TEVAL,WA SET TEBLK NAME OFFSET
22181: MOV 2(XS),WB RESTORE NAME/VALUE INDICATOR
22182: BNZ WB,TFN09 JUMP IF CALLED BY NAME
22183: JSR ACESS ELSE GET VALUE
22184: PPM TFN12 JUMP IF REFERENCE FAILS
22185: ZER WB RESTORE NAME/VALUE INDICATOR
22186: *
22187: * COMMON EXIT FOR ENTRY FOUND
22188: *
22189: TFN09 ADD *NUM03,XS POP STACK ENTRIES
22190: EXI RETURN TO TFIND CALLER
22191: *
22192: * HERE IF NO TEBLKS ON THE HASH CHAIN
22193: *
22194: TFN10 ADD *TBBUK,WC GET OFFSET TO BUCKET PTR
22195: MOV (XS),XL SET TBBLK PTR AS BASE
22196: *
22197: * MERGE HERE WITH (XL,WC) BASE,OFFSET OF FINAL LINK
22198: *
22199: TFN11 MOV (XS),XR TBBLK POINTER
22200: MOV TBINV(XR),XR LOAD DEFAULT VALUE IN CASE
22201: MOV 2(XS),WB LOAD NAME/VALUE INDICATOR
22202: BZE WB,TFN09 EXIT WITH DEFAULT IF VALUE CALL
22203: *
22204: * HERE WE MUST BUILD A NEW TEBLK
22205: *
22206: MOV *TESI$,WA SET SIZE OF TEBLK
22207: JSR ALLOC ALLOCATE TEBLK
22208: ADD WC,XL POINT TO HASH LINK
22209: MOV XR,(XL) LINK NEW TEBLK AT END OF CHAIN
22210: MOV =B$TET,(XR) STORE TYPE WORD
22211: MOV =NULLS,TEVAL(XR) SET NULL AS INITIAL VALUE
22212: MOV (XS)+,TENXT(XR) SET TBBLK PTR TO MARK END OF CHAIN
22213: MOV (XS)+,TESUB(XR) STORE SUBSCRIPT VALUE
22214: ICA XS POP PAST NAME/VALUE INDICATOR
22215: MOV XR,XL COPY TEBLK POINTER (NAME BASE)
22216: MOV *TEVAL,WA SET OFFSET
22217: EXI RETURN TO CALLER WITH NEW TEBLK
22218: *
22219: * ACESS FAIL RETURN
22220: *
22221: TFN12 EXI 1 ALTERNATIVE RETURN
22222: ENP END PROCEDURE TFIND
22223: EJC
22224: *
22225: * TRACE -- SET/RESET A TRACE ASSOCIATION
22226: *
22227: * THIS PROCEDURE IS SHARED BY TRACE AND STOPTR TO
22228: * EITHER INITIATE OR STOP A TRACE RESPECTIVELY.
22229: *
22230: * (XL) TRBLK PTR (TRACE) OR ZERO (STOPTR)
22231: * 1(XS) FIRST ARGUMENT (NAME)
22232: * 0(XS) SECOND ARGUMENT (TRACE TYPE)
22233: * JSR TRACE CALL TO SET/RESET TRACE
22234: * PPM LOC TRANSFER LOC IF 1ST ARG IS BAD NAME
22235: * PPM LOC TRANSFER LOC IF 2ND ARG IS BAD TYPE
22236: * (XS) POPPED
22237: * (XL,XR,WA,WB,WC,IA) DESTROYED
22238: *
22239: TRACE PRC N,2 ENTRY POINT
22240: JSR GTSTG GET TRACE TYPE STRING
22241: PPM TRC15 JUMP IF NOT STRING
22242: PLC XR ELSE POINT TO STRING
22243: LCH WA,(XR) LOAD FIRST CHARACTER
22244: .IF .CULC
22245: FLC WA FOLD TO UPPER CASE
22246: .FI
22247: MOV (XS),XR LOAD NAME ARGUMENT
22248: MOV XL,(XS) STACK TRBLK PTR OR ZERO
22249: MOV =TRTAC,WC SET TRTYP FOR ACCESS TRACE
22250: BEQ WA,=CH$LA,TRC10 JUMP IF A (ACCESS)
22251: MOV =TRTVL,WC SET TRTYP FOR VALUE TRACE
22252: BEQ WA,=CH$LV,TRC10 JUMP IF V (VALUE)
22253: .IF .CULC
22254: BZE WA,TRC10 JUMP IF BLANK (VALUE)
22255: .ELSE
22256: BEQ WA,=CH$BL,TRC10 JUMP IF BLANK (VALUE)
22257: .FI
22258: *
22259: * HERE FOR L,K,F,C,R
22260: *
22261: BEQ WA,=CH$LF,TRC01 JUMP IF F (FUNCTION)
22262: BEQ WA,=CH$LR,TRC01 JUMP IF R (RETURN)
22263: BEQ WA,=CH$LL,TRC03 JUMP IF L (LABEL)
22264: BEQ WA,=CH$LK,TRC06 JUMP IF K (KEYWORD)
22265: BNE WA,=CH$LC,TRC15 ELSE ERROR IF NOT C (CALL)
22266: *
22267: * HERE FOR F,C,R
22268: *
22269: TRC01 JSR GTNVR POINT TO VRBLK FOR NAME
22270: PPM TRC16 JUMP IF BAD NAME
22271: ICA XS POP STACK
22272: MOV VRFNC(XR),XR POINT TO FUNCTION BLOCK
22273: BNE (XR),=B$PFC,TRC17 ERROR IF NOT PROGRAM FUNCTION
22274: BEQ WA,=CH$LR,TRC02 JUMP IF R (RETURN)
22275: EJC
22276: *
22277: * TRACE (CONTINUED)
22278: *
22279: * HERE FOR F,C TO SET/RESET CALL TRACE
22280: *
22281: MOV XL,PFCTR(XR) SET/RESET CALL TRACE
22282: BEQ WA,=CH$LC,EXNUL EXIT WITH NULL IF C (CALL)
22283: *
22284: * HERE FOR F,R TO SET/RESET RETURN TRACE
22285: *
22286: TRC02 MOV XL,PFRTR(XR) SET/RESET RETURN TRACE
22287: EXI RETURN
22288: *
22289: * HERE FOR L TO SET/RESET LABEL TRACE
22290: *
22291: TRC03 JSR GTNVR POINT TO VRBLK
22292: PPM TRC16 JUMP IF BAD NAME
22293: MOV VRLBL(XR),XL LOAD LABEL POINTER
22294: BNE (XL),=B$TRT,TRC04 JUMP IF NO OLD TRACE
22295: MOV TRLBL(XL),XL ELSE DELETE OLD TRACE ASSOCIATION
22296: *
22297: * HERE WITH OLD LABEL TRACE ASSOCIATION DELETED
22298: *
22299: TRC04 BEQ XL,=STNDL,TRC16 ERROR IF UNDEFINED LABEL
22300: MOV (XS)+,WB GET TRBLK PTR AGAIN
22301: BZE WB,TRC05 JUMP IF STOPTR CASE
22302: MOV WB,VRLBL(XR) ELSE SET NEW TRBLK POINTER
22303: MOV =B$VRT,VRTRA(XR) SET LABEL TRACE ROUTINE ADDRESS
22304: MOV WB,XR COPY TRBLK POINTER
22305: MOV XL,TRLBL(XR) STORE REAL LABEL IN TRBLK
22306: EXI RETURN
22307: *
22308: * HERE FOR STOPTR CASE FOR LABEL
22309: *
22310: TRC05 MOV XL,VRLBL(XR) STORE LABEL PTR BACK IN VRBLK
22311: MOV =B$VRG,VRTRA(XR) STORE NORMAL TRANSFER ADDRESS
22312: EXI RETURN
22313: EJC
22314: *
22315: * TRACE (CONTINUED)
22316: *
22317: * HERE FOR K (KEYWORD)
22318: *
22319: TRC06 JSR GTNVR POINT TO VRBLK
22320: PPM TRC16 ERROR IF NOT NATURAL VAR
22321: BNZ VRLEN(XR),TRC16 ERROR IF NOT SYSTEM VAR
22322: ICA XS POP STACK
22323: BZE XL,TRC07 JUMP IF STOPTR CASE
22324: MOV XR,TRKVR(XL) STORE VRBLK PTR IN TRBLK FOR KTREX
22325: *
22326: * MERGE HERE WITH TRBLK SET UP IN WB (OR ZERO)
22327: *
22328: TRC07 MOV VRSVP(XR),XR POINT TO SVBLK
22329: BEQ XR,=V$ERT,TRC08 JUMP IF ERRTYPE
22330: BEQ XR,=V$STC,TRC09 JUMP IF STCOUNT
22331: BNE XR,=V$FNC,TRC17 ELSE ERROR IF NOT FNCLEVEL
22332: *
22333: * FNCLEVEL
22334: *
22335: MOV XL,R$FNC SET/RESET FNCLEVEL TRACE
22336: EXI RETURN
22337: *
22338: * ERRTYPE
22339: *
22340: TRC08 MOV XL,R$ERT SET/RESET ERRTYPE TRACE
22341: EXI RETURN
22342: *
22343: * STCOUNT
22344: *
22345: TRC09 MOV XL,R$STC SET/RESET STCOUNT TRACE
22346: EXI RETURN
22347: EJC
22348: *
22349: * TRACE (CONTINUED)
22350: *
22351: * A,V MERGE HERE WITH TRTYP VALUE IN WC
22352: *
22353: TRC10 JSR GTVAR LOCATE VARIABLE
22354: PPM TRC16 ERROR IF NOT APPROPRIATE NAME
22355: MOV (XS)+,WB GET NEW TRBLK PTR AGAIN
22356: ADD XL,WA POINT TO VARIABLE LOCATION
22357: MOV WA,XR COPY VARIABLE POINTER
22358: *
22359: * LOOP TO SEARCH TRBLK CHAIN
22360: *
22361: TRC11 MOV (XR),XL POINT TO NEXT ENTRY
22362: BNE (XL),=B$TRT,TRC13 JUMP IF NOT TRBLK
22363: BLT WC,TRTYP(XL),TRC13 JUMP IF TOO FAR OUT ON CHAIN
22364: BEQ WC,TRTYP(XL),TRC12 JUMP IF THIS MATCHES OUR TYPE
22365: ADD *TRNXT,XL ELSE POINT TO LINK FIELD
22366: MOV XL,XR COPY POINTER
22367: BRN TRC11 AND LOOP BACK
22368: *
22369: * HERE TO DELETE AN OLD TRBLK OF THE TYPE WE WERE GIVEN
22370: *
22371: TRC12 MOV TRNXT(XL),XL GET PTR TO NEXT BLOCK OR VALUE
22372: MOV XL,(XR) STORE TO DELETE THIS TRBLK
22373: *
22374: * HERE AFTER DELETING ANY OLD ASSOCIATION OF THIS TYPE
22375: *
22376: TRC13 BZE WB,TRC14 JUMP IF STOPTR CASE
22377: MOV WB,(XR) ELSE LINK NEW TRBLK IN
22378: MOV WB,XR COPY TRBLK POINTER
22379: MOV XL,TRNXT(XR) STORE FORWARD POINTER
22380: MOV WC,TRTYP(XR) STORE APPROPRIATE TRAP TYPE CODE
22381: *
22382: * HERE TO MAKE SURE VRGET,VRSTO ARE SET PROPERLY
22383: *
22384: TRC14 MOV WA,XR RECALL POSSIBLE VRBLK POINTER
22385: SUB *VRVAL,XR POINT BACK TO VRBLK
22386: JSR SETVR SET FIELDS IF VRBLK
22387: EXI RETURN
22388: *
22389: * HERE FOR BAD TRACE TYPE
22390: *
22391: TRC15 EXI 2 TAKE BAD TRACE TYPE ERROR EXIT
22392: *
22393: * POP STACK BEFORE FAILING
22394: *
22395: TRC16 ICA XS POP STACK
22396: *
22397: * HERE FOR BAD NAME ARGUMENT
22398: *
22399: TRC17 EXI 1 TAKE BAD NAME ERROR EXIT
22400: ENP END PROCEDURE TRACE
22401: EJC
22402: *
22403: * TRBLD -- BUILD TRBLK
22404: *
22405: * TRBLK IS USED BY THE INPUT, OUTPUT AND TRACE FUNCTIONS
22406: * TO CONSTRUCT A TRBLK (TRAP BLOCK)
22407: *
22408: * (XR) TRTAG OR TRTER
22409: * (XL) TRFNC OR TRFPT
22410: * (WB) TRTYP
22411: * JSR TRBLD CALL TO BUILD TRBLK
22412: * (XR) POINTER TO TRBLK
22413: * (WA) DESTROYED
22414: *
22415: TRBLD PRC E,0 ENTRY POINT
22416: MOV XR,-(XS) STACK TRTAG (OR TRFNM)
22417: MOV *TRSI$,WA SET SIZE OF TRBLK
22418: JSR ALLOC ALLOCATE TRBLK
22419: MOV =B$TRT,(XR) STORE FIRST WORD
22420: MOV XL,TRFNC(XR) STORE TRFNC (OR TRFPT)
22421: MOV (XS)+,TRTAG(XR) STORE TRTAG (OR TRFNM)
22422: MOV WB,TRTYP(XR) STORE TYPE
22423: MOV =NULLS,TRVAL(XR) FOR NOW, A NULL VALUE
22424: EXI RETURN TO CALLER
22425: ENP END PROCEDURE TRBLD
22426: EJC
22427: *
22428: * TRIMR -- TRIM TRAILING BLANKS
22429: *
22430: * TRIMR IS PASSED A POINTER TO AN SCBLK WHICH MUST BE THE
22431: * LAST BLOCK IN DYNAMIC STORAGE. TRAILING BLANKS ARE
22432: * TRIMMED OFF AND THE DYNAMIC STORAGE POINTER RESET TO
22433: * THE END OF THE (POSSIBLY) SHORTENED BLOCK.
22434: *
22435: * (WB) NON-ZERO TO TRIM TRAILING BLANKS
22436: * (XR) POINTER TO STRING TO TRIM
22437: * JSR TRIMR CALL TO TRIM STRING
22438: * (XR) POINTER TO TRIMMED STRING
22439: * (XL,WA,WB,WC) DESTROYED
22440: *
22441: * THE CALL WITH WB ZERO STILL PERFORMS THE END ZERO PAD
22442: * AND DNAMP READJUSTMENT. IT IS USED FROM ACESS IF KVTRM=0.
22443: *
22444: TRIMR PRC E,0 ENTRY POINT
22445: MOV XR,XL COPY STRING POINTER
22446: MOV SCLEN(XR),WA LOAD STRING LENGTH
22447: BZE WA,TRIM2 JUMP IF NULL INPUT
22448: PLC XL,WA ELSE POINT PAST LAST CHARACTER
22449: BZE WB,TRIM3 JUMP IF NO TRIM
22450: MOV =CH$BL,WC LOAD BLANK CHARACTER
22451: *
22452: * LOOP THROUGH CHARACTERS FROM RIGHT TO LEFT
22453: *
22454: TRIM0 LCH WB,-(XL) LOAD NEXT CHARACTER
22455: .IF .CAHT
22456: BEQ WB,=CH$HT,TRIM1 JUMP IF HORIZONTAL TAB
22457: .FI
22458: BNE WB,WC,TRIM3 JUMP IF NON-BLANK FOUND
22459: TRIM1 DCV WA ELSE DECREMENT CHARACTER COUNT
22460: BNZ WA,TRIM0 LOOP BACK IF MORE TO CHECK
22461: *
22462: * HERE IF RESULT IS NULL (NULL OR ALL-BLANK INPUT)
22463: *
22464: TRIM2 MOV XR,DNAMP WIPE OUT INPUT STRING BLOCK
22465: MOV =NULLS,XR LOAD NULL RESULT
22466: BRN TRIM5 MERGE TO EXIT
22467: EJC
22468: *
22469: * TRIMR (CONTINUED)
22470: *
22471: * HERE WITH NON-BLANK FOUND (MERGE FOR NO TRIM)
22472: *
22473: TRIM3 MOV WA,SCLEN(XR) SET NEW LENGTH
22474: MOV XR,XL COPY STRING POINTER
22475: PSC XL,WA READY FOR STORING BLANKS
22476: CTB WA,SCHAR GET LENGTH OF BLOCK IN BYTES
22477: ADD XR,WA POINT PAST NEW BLOCK
22478: MOV WA,DNAMP SET NEW TOP OF STORAGE POINTER
22479: LCT WA,=CFP$C GET COUNT OF CHARS IN WORD
22480: ZER WC SET BLANK CHAR
22481: *
22482: * LOOP TO ZERO PAD LAST WORD OF CHARACTERS
22483: *
22484: TRIM4 SCH WC,(XL)+ STORE ZERO CHARACTER
22485: BCT WA,TRIM4 LOOP BACK TILL ALL STORED
22486: CSC XL COMPLETE STORE CHARACTERS
22487: *
22488: * COMMON EXIT POINT
22489: *
22490: TRIM5 ZER XL CLEAR GARBAGE XL POINTER
22491: EXI RETURN TO CALLER
22492: ENP END PROCEDURE TRIMR
22493: EJC
22494: *
22495: * TRXEQ -- EXECUTE FUNCTION TYPE TRACE
22496: *
22497: * TRXEQ IS USED TO EXECUTE A TRACE WHEN A FOURTH ARGUMENT
22498: * HAS BEEN SUPPLIED. TRACE HAS ALREADY BEEN DECREMENTED.
22499: *
22500: * (XR) POINTER TO TRBLK
22501: * (XL,WA) NAME BASE,OFFSET FOR VARIABLE
22502: * JSR TRXEQ CALL TO EXECUTE TRACE
22503: * (WB,WC,RA) DESTROYED
22504: *
22505: * THE FOLLOWING STACK ENTRIES ARE MADE BEFORE PASSING
22506: * CONTROL TO THE TRACE FUNCTION USING THE CFUNC ROUTINE.
22507: *
22508: * TRXEQ RETURN POINT WORD(S)
22509: * SAVED VALUE OF TRACE KEYWORD
22510: * TRBLK POINTER
22511: * NAME BASE
22512: * NAME OFFSET
22513: * SAVED VALUE OF R$COD
22514: * SAVED CODE PTR (-R$COD)
22515: * SAVED VALUE OF FLPTR
22516: * FLPTR --------------- ZERO (DUMMY FAIL OFFSET)
22517: * NMBLK FOR VARIABLE NAME
22518: * XS ------------------ TRACE TAG
22519: *
22520: * R$COD AND THE CODE PTR ARE SET TO DUMMY VALUES WHICH
22521: * CAUSE CONTROL TO RETURN TO THE TRXEQ PROCEDURE ON SUCCESS
22522: * OR FAILURE (TRXEQ IGNORES A FAILURE CONDITION).
22523: *
22524: TRXEQ PRC R,0 ENTRY POINT (RECURSIVE)
22525: MOV R$COD,WC LOAD CODE BLOCK POINTER
22526: SCP WB GET CURRENT CODE POINTER
22527: SUB WC,WB MAKE CODE POINTER INTO OFFSET
22528: MOV KVTRA,-(XS) STACK TRACE KEYWORD VALUE
22529: MOV XR,-(XS) STACK TRBLK POINTER
22530: MOV XL,-(XS) STACK NAME BASE
22531: MOV WA,-(XS) STACK NAME OFFSET
22532: MOV WC,-(XS) STACK CODE BLOCK POINTER
22533: MOV WB,-(XS) STACK CODE POINTER OFFSET
22534: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER
22535: ZER -(XS) SET DUMMY FAIL OFFSET
22536: MOV XS,FLPTR SET NEW FAILURE POINTER
22537: ZER KVTRA RESET TRACE KEYWORD TO ZERO
22538: MOV =TRXDC,WC LOAD NEW (DUMMY) CODE BLK POINTER
22539: MOV WC,R$COD SET AS CODE BLOCK POINTER
22540: LCP WC AND NEW CODE POINTER
22541: EJC
22542: *
22543: * TRXEQ (CONTINUED)
22544: *
22545: * NOW PREPARE ARGUMENTS FOR FUNCTION
22546: *
22547: MOV WA,WB SAVE NAME OFFSET
22548: MOV *NMSI$,WA LOAD NMBLK SIZE
22549: JSR ALLOC ALLOCATE SPACE FOR NMBLK
22550: MOV =B$NML,(XR) SET TYPE WORD
22551: MOV XL,NMBAS(XR) STORE NAME BASE
22552: MOV WB,NMOFS(XR) STORE NAME OFFSET
22553: MOV 6(XS),XL RELOAD POINTER TO TRBLK
22554: MOV XR,-(XS) STACK NMBLK POINTER (1ST ARGUMENT)
22555: MOV TRTAG(XL),-(XS) STACK TRACE TAG (2ND ARGUMENT)
22556: MOV TRFNC(XL),XL LOAD TRACE FUNCTION POINTER
22557: MOV =NUM02,WA SET NUMBER OF ARGUMENTS TO TWO
22558: BRN CFUNC JUMP TO CALL FUNCTION
22559: *
22560: * SEE O$TXR FOR DETAILS OF RETURN TO THIS POINT
22561: *
22562: TRXQ1 MOV FLPTR,XS POINT BACK TO OUR STACK ENTRIES
22563: ICA XS POP OFF GARBAGE FAIL OFFSET
22564: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER
22565: MOV (XS)+,WB RELOAD CODE OFFSET
22566: MOV (XS)+,WC LOAD OLD CODE BASE POINTER
22567: MOV WC,XR COPY CDBLK POINTER
22568: MOV CDSTM(XR),KVSTN RESTORE STMNT NO
22569: MOV (XS)+,WA RELOAD NAME OFFSET
22570: MOV (XS)+,XL RELOAD NAME BASE
22571: MOV (XS)+,XR RELOAD TRBLK POINTER
22572: MOV (XS)+,KVTRA RESTORE TRACE KEYWORD VALUE
22573: ADD WC,WB RECOMPUTE ABSOLUTE CODE POINTER
22574: LCP WB RESTORE CODE POINTER
22575: MOV WC,R$COD AND CODE BLOCK POINTER
22576: EXI RETURN TO TRXEQ CALLER
22577: ENP END PROCEDURE TRXEQ
22578: EJC
22579: *
22580: * XSCAN -- EXECUTION FUNCTION ARGUMENT SCAN
22581: *
22582: * XSCAN SCANS OUT ONE TOKEN IN A PROTOTYPE ARGUMENT IN
22583: * ARRAY,CLEAR,DATA,DEFINE,LOAD FUNCTION CALLS. XSCAN
22584: * CALLS MUST BE PRECEDED BY A CALL TO THE INITIALIZATION
22585: * PROCEDURE XSCNI. THE FOLLOWING VARIABLES ARE USED.
22586: *
22587: * R$XSC POINTER TO SCBLK FOR FUNCTION ARG
22588: * XSOFS OFFSET (NUM CHARS SCANNED SO FAR)
22589: *
22590: * (WC) DELIMITER ONE (CH$XX)
22591: * (XL) DELIMITER TWO (CH$XX)
22592: * JSR XSCAN CALL TO SCAN NEXT ITEM
22593: * (XR) POINTER TO SCBLK FOR TOKEN SCANNED
22594: * (WA) COMPLETION CODE (SEE BELOW)
22595: * (WC,XL) DESTROYED
22596: *
22597: * THE SCAN STARTS FROM THE CURRENT POSITION AND CONTINUES
22598: * UNTIL ONE OF THE FOLLOWING THREE CONDITIONS OCCURS.
22599: *
22600: * 1) DELIMITER ONE IS ENCOUNTERED (WA SET TO 1)
22601: *
22602: * 2) DELIMITER TWO ENCOUNTERED (WA SET TO 2)
22603: *
22604: * 3) END OF STRING ENCOUNTERED (WA SET TO 0)
22605: *
22606: * THE RESULT IS A STRING CONTAINING ALL CHARACTERS SCANNED
22607: * UP TO BUT NOT INCLUDING ANY DELIMITER CHARACTER.
22608: * THE POINTER IS LEFT POINTING PAST THE DELIMITER.
22609: *
22610: * IF ONLY ONE DELIMITER IS TO BE DETECTED, DELIMITER ONE
22611: * AND DELIMITER TWO SHOULD BE SET TO THE SAME VALUE.
22612: *
22613: * IN THE CASE WHERE THE END OF STRING IS ENCOUNTERED, THE
22614: * STRING INCLUDES ALL THE CHARACTERS TO THE END OF THE
22615: * STRING. NO FURTHER CALLS CAN BE MADE TO XSCAN UNTIL
22616: * XSCNI IS CALLED TO INITIALIZE A NEW ARGUMENT SCAN
22617: EJC
22618: *
22619: * XSCAN (CONTINUED)
22620: *
22621: XSCAN PRC E,0 ENTRY POINT
22622: MOV WB,XSCWB PRESERVE WB
22623: MOV R$XSC,XR POINT TO ARGUMENT STRING
22624: MOV SCLEN(XR),WA LOAD STRING LENGTH
22625: MOV XSOFS,WB LOAD CURRENT OFFSET
22626: SUB WB,WA GET NUMBER OF REMAINING CHARACTERS
22627: BZE WA,XSCN2 JUMP IF NO CHARACTERS LEFT
22628: PLC XR,WB POINT TO CURRENT CHARACTER
22629: *
22630: * LOOP TO SEARCH FOR DELIMITER
22631: *
22632: XSCN1 LCH WB,(XR)+ LOAD NEXT CHARACTER
22633: BEQ WB,WC,XSCN3 JUMP IF DELIMITER ONE FOUND
22634: BEQ WB,XL,XSCN4 JUMP IF DELIMITER TWO FOUND
22635: DCV WA DECREMENT COUNT OF CHARS LEFT
22636: BNZ WA,XSCN1 LOOP BACK IF MORE CHARS TO GO
22637: *
22638: * HERE FOR RUNOUT
22639: *
22640: XSCN2 MOV R$XSC,XL POINT TO STRING BLOCK
22641: MOV SCLEN(XL),WA GET STRING LENGTH
22642: MOV XSOFS,WB LOAD OFFSET
22643: SUB WB,WA GET SUBSTRING LENGTH
22644: ZER R$XSC CLEAR STRING PTR FOR COLLECTOR
22645: ZER XSCRT SET ZERO (RUNOUT) RETURN CODE
22646: BRN XSCN6 JUMP TO EXIT
22647: EJC
22648: *
22649: * XSCAN (CONTINUED)
22650: *
22651: * HERE IF DELIMITER ONE FOUND
22652: *
22653: XSCN3 MOV =NUM01,XSCRT SET RETURN CODE
22654: BRN XSCN5 JUMP TO MERGE
22655: *
22656: * HERE IF DELIMITER TWO FOUND
22657: *
22658: XSCN4 MOV =NUM02,XSCRT SET RETURN CODE
22659: *
22660: * MERGE HERE AFTER DETECTING A DELIMITER
22661: *
22662: XSCN5 MOV R$XSC,XL RELOAD POINTER TO STRING
22663: MOV SCLEN(XL),WC GET ORIGINAL LENGTH OF STRING
22664: SUB WA,WC MINUS CHARS LEFT = CHARS SCANNED
22665: MOV WC,WA MOVE TO REG FOR SBSTR
22666: MOV XSOFS,WB SET OFFSET
22667: SUB WB,WA COMPUTE LENGTH FOR SBSTR
22668: ICV WC ADJUST NEW CURSOR PAST DELIMITER
22669: MOV WC,XSOFS STORE NEW OFFSET
22670: *
22671: * COMMON EXIT POINT
22672: *
22673: XSCN6 ZER XR CLEAR GARBAGE CHARACTER PTR IN XR
22674: JSR SBSTR BUILD SUB-STRING
22675: MOV XSCRT,WA LOAD RETURN CODE
22676: MOV XSCWB,WB RESTORE WB
22677: EXI RETURN TO XSCAN CALLER
22678: ENP END PROCEDURE XSCAN
22679: EJC
22680: *
22681: * XSCNI -- EXECUTION FUNCTION ARGUMENT SCAN
22682: *
22683: * XSCNI INITIALIZES THE SCAN USED FOR PROTOTYPE ARGUMENTS
22684: * IN THE CLEAR, DEFINE, LOAD, DATA, ARRAY FUNCTIONS. SEE
22685: * XSCAN FOR THE PROCEDURE WHICH IS USED AFTER THIS CALL.
22686: *
22687: * -(XS) ARGUMENT TO BE SCANNED (ON STACK)
22688: * JSR XSCNI CALL TO SCAN ARGUMENT
22689: * PPM LOC TRANSFER LOC IF ARG IS NOT STRING
22690: * PPM LOC TRANSFER LOC IF ARGUMENT IS NULL
22691: * (XS) POPPED
22692: * (XR,R$XSC) ARGUMENT (SCBLK PTR)
22693: * (WA) ARGUMENT LENGTH
22694: * (IA,RA) DESTROYED
22695: *
22696: XSCNI PRC N,2 ENTRY POINT
22697: JSR GTSTG FETCH ARGUMENT AS STRING
22698: PPM XSCI1 JUMP IF NOT CONVERTIBLE
22699: MOV XR,R$XSC ELSE STORE SCBLK PTR FOR XSCAN
22700: ZER XSOFS SET OFFSET TO ZERO
22701: BZE WA,XSCI2 JUMP IF NULL STRING
22702: EXI RETURN TO XSCNI CALLER
22703: *
22704: * HERE IF ARGUMENT IS NOT A STRING
22705: *
22706: XSCI1 EXI 1 TAKE NOT-STRING ERROR EXIT
22707: *
22708: * HERE FOR NULL STRING
22709: *
22710: XSCI2 EXI 2 TAKE NULL-STRING ERROR EXIT
22711: ENP END PROCEDURE XSCNI
22712: TTL S P I T B O L -- UTILITY ROUTINES
22713: *
22714: * THE FOLLOWING SECTION CONTAINS UTILITY ROUTINES USED FOR
22715: * VARIOUS PURPOSES THROUGHOUT THE SYSTEM. THESE DIFFER
22716: * FROM THE PROCEDURES IN THE UTILITY PROCEDURES SECTION IN
22717: * THEY ARE NOT IN PROCEDURE FORM AND THEY DO NOT RETURN
22718: * TO THEIR CALLERS. THEY ARE ACCESSED WITH A BRANCH TYPE
22719: * INSTRUCTION AFTER SETTING THE REGISTERS TO APPROPRIATE
22720: * PARAMETER VALUES.
22721: *
22722: * THE REGISTER VALUES REQUIRED FOR EACH ROUTINE ARE
22723: * DOCUMENTED AT THE START OF EACH ROUTINE. REGISTERS NOT
22724: * MENTIONED MAY CONTAIN ANY VALUES EXCEPT THAT XR,XL
22725: * CAN ONLY CONTAIN PROPER COLLECTABLE POINTERS.
22726: *
22727: * SOME OF THESE ROUTINES WILL TOLERATE GARBAGE POINTERS
22728: * IN XL,XR ON ENTRY. THIS IS ALWAYS DOCUMENTED AND IN
22729: * EACH CASE, THE ROUTINE CLEARS THESE GARBAGE VALUES BEFORE
22730: * EXITING AFTER COMPLETING ITS TASK.
22731: *
22732: * THE ROUTINES HAVE NAMES CONSISTING OF FIVE LETTERS
22733: * AND ARE ASSEMBLED IN ALPHABETICAL ORDER.
22734: EJC
22735: * ARREF -- ARRAY REFERENCE
22736: *
22737: * (XL) MAY BE NON-COLLECTABLE
22738: * (XR) NUMBER OF SUBSCRIPTS
22739: * (WB) SET ZERO/NONZERO FOR VALUE/NAME
22740: * THE VALUE IN WB MUST BE COLLECTABLE
22741: * STACK SUBSCRIPTS AND ARRAY OPERAND
22742: * BRN ARREF JUMP TO CALL FUNCTION
22743: *
22744: * ARREF CONTINUES BY EXECUTING THE NEXT CODE WORD WITH
22745: * THE RESULT NAME OR VALUE PLACED ON TOP OF THE STACK.
22746: * TO DEAL WITH THE PROBLEM OF ACCESSING SUBSCRIPTS IN THE
22747: * ORDER OF STACKING, XL IS USED AS A SUBSCRIPT POINTER
22748: * WORKING BELOW THE STACK POINTER.
22749: *
22750: ARREF RTN
22751: MOV XR,WA COPY NUMBER OF SUBSCRIPTS
22752: MOV XS,XT POINT TO STACK FRONT
22753: WTB XR CONVERT TO BYTE OFFSET
22754: ADD XR,XT POINT TO ARRAY OPERAND ON STACK
22755: ICA XT FINAL VALUE FOR STACK POPPING
22756: MOV XT,ARFXS KEEP FOR LATER
22757: MOV -(XT),XR LOAD ARRAY OPERAND POINTER
22758: MOV XR,R$ARF KEEP ARRAY POINTER
22759: MOV XT,XR SAVE POINTER TO SUBSCRIPTS
22760: MOV R$ARF,XL POINT XL TO POSSIBLE VCBLK OR TBBLK
22761: MOV (XL),WC LOAD FIRST WORD
22762: BEQ WC,=B$ART,ARF01 JUMP IF ARBLK
22763: BEQ WC,=B$VCT,ARF07 JUMP IF VCBLK
22764: BEQ WC,=B$TBT,ARF10 JUMP IF TBBLK
22765: ERB 235,SUBSCRIPTED OPERAND IS NOT TABLE OR ARRAY
22766: *
22767: * HERE FOR ARRAY (ARBLK)
22768: *
22769: ARF01 BNE WA,ARNDM(XL),ARF09 JUMP IF WRONG NUMBER OF DIMS
22770: LDI INTV0 GET INITIAL SUBSCRIPT OF ZERO
22771: MOV XR,XT POINT BEFORE SUBSCRIPTS
22772: ZER WA INITIAL OFFSET TO BOUNDS
22773: BRN ARF03 JUMP INTO LOOP
22774: *
22775: * LOOP TO COMPUTE SUBSCRIPTS BY MULTIPLICATIONS
22776: *
22777: ARF02 MLI ARDM2(XR) MULTIPLY TOTAL BY NEXT DIMENSION
22778: *
22779: * MERGE HERE FIRST TIME
22780: *
22781: ARF03 MOV -(XT),XR LOAD NEXT SUBSCRIPT
22782: STI ARFSI SAVE CURRENT SUBSCRIPT
22783: LDI ICVAL(XR) LOAD INTEGER VALUE IN CASE
22784: BEQ (XR),=B$ICL,ARF04 JUMP IF IT WAS AN INTEGER
22785: EJC
22786: *
22787: * ARREF (CONTINUED)
22788: *
22789: *
22790: JSR GTINT CONVERT TO INTEGER
22791: PPM ARF12 JUMP IF NOT INTEGER
22792: LDI ICVAL(XR) IF OK, LOAD INTEGER VALUE
22793: *
22794: * HERE WITH INTEGER SUBSCRIPT IN (IA)
22795: *
22796: ARF04 MOV R$ARF,XR POINT TO ARRAY
22797: ADD WA,XR OFFSET TO NEXT BOUNDS
22798: SBI ARLBD(XR) SUBTRACT LOW BOUND TO COMPARE
22799: IOV ARF13 OUT OF RANGE FAIL IF OVERFLOW
22800: ILT ARF13 OUT OF RANGE FAIL IF TOO SMALL
22801: SBI ARDIM(XR) SUBTRACT DIMENSION
22802: IGE ARF13 OUT OF RANGE FAIL IF TOO LARGE
22803: ADI ARDIM(XR) ELSE RESTORE SUBSCRIPT OFFSET
22804: ADI ARFSI ADD TO CURRENT TOTAL
22805: ADD *ARDMS,WA POINT TO NEXT BOUNDS
22806: BNE XT,XS,ARF02 LOOP BACK IF MORE TO GO
22807: *
22808: * HERE WITH INTEGER SUBSCRIPT COMPUTED
22809: *
22810: MFI WA GET AS ONE WORD INTEGER
22811: WTB WA CONVERT TO OFFSET
22812: MOV R$ARF,XL POINT TO ARBLK
22813: ADD AROFS(XL),WA ADD OFFSET PAST BOUNDS
22814: ICA WA ADJUST FOR ARPRO FIELD
22815: BNZ WB,ARF08 EXIT WITH NAME IF NAME CALL
22816: *
22817: * MERGE HERE TO GET VALUE FOR VALUE CALL
22818: *
22819: ARF05 JSR ACESS GET VALUE
22820: PPM ARF13 FAIL IF ACESS FAILS
22821: *
22822: * RETURN VALUE
22823: *
22824: ARF06 MOV ARFXS,XS POP STACK ENTRIES
22825: ZER R$ARF FINISHED WITH ARRAY POINTER
22826: BRN EXIXR EXIT WITH VALUE IN XR
22827: EJC
22828: *
22829: * ARREF (CONTINUED)
22830: *
22831: * HERE FOR VECTOR
22832: *
22833: ARF07 BNE WA,=NUM01,ARF09 ERROR IF MORE THAN 1 SUBSCRIPT
22834: MOV (XS),XR ELSE LOAD SUBSCRIPT
22835: JSR GTINT CONVERT TO INTEGER
22836: PPM ARF12 ERROR IF NOT INTEGER
22837: LDI ICVAL(XR) ELSE LOAD INTEGER VALUE
22838: SBI INTV1 SUBTRACT FOR ONES OFFSET
22839: MFI WA,ARF13 GET SUBSCRIPT AS ONE WORD
22840: ADD =VCVLS,WA ADD OFFSET FOR STANDARD FIELDS
22841: WTB WA CONVERT OFFSET TO BYTES
22842: BGE WA,VCLEN(XL),ARF13 FAIL IF OUT OF RANGE SUBSCRIPT
22843: BZE WB,ARF05 BACK TO GET VALUE IF VALUE CALL
22844: *
22845: * RETURN NAME
22846: *
22847: ARF08 MOV ARFXS,XS POP STACK ENTRIES
22848: ZER R$ARF FINISHED WITH ARRAY POINTER
22849: BRN EXNAM ELSE EXIT WITH NAME
22850: *
22851: * HERE IF SUBSCRIPT COUNT IS WRONG
22852: *
22853: ARF09 ERB 236,ARRAY REFERENCED WITH WRONG NUMBER OF SUBSCRIPTS
22854: *
22855: * TABLE
22856: *
22857: ARF10 BNE WA,=NUM01,ARF11 ERROR IF MORE THAN 1 SUBSCRIPT
22858: MOV (XS),XR ELSE LOAD SUBSCRIPT
22859: JSR TFIND CALL TABLE SEARCH ROUTINE
22860: PPM ARF13 FAIL IF FAILED
22861: BNZ WB,ARF08 EXIT WITH NAME IF NAME CALL
22862: BRN ARF06 ELSE EXIT WITH VALUE
22863: *
22864: * HERE FOR BAD TABLE REFERENCE
22865: *
22866: ARF11 ERB 237,TABLE REFERENCED WITH MORE THAN ONE SUBSCRIPT
22867: *
22868: * HERE FOR BAD SUBSCRIPT
22869: *
22870: ARF12 ERB 238,ARRAY SUBSCRIPT IS NOT INTEGER
22871: *
22872: * HERE TO SIGNAL FAILURE
22873: *
22874: ARF13 ZER R$ARF FINISHED WITH ARRAY POINTER
22875: BRN EXFAL FAIL
22876: EJC
22877: *
22878: * CFUNC -- CALL A FUNCTION
22879: *
22880: * CFUNC IS USED TO CALL A SNOBOL LEVEL FUNCTION. IT IS
22881: * USED BY THE APPLY FUNCTION (S$APP), THE FUNCTION
22882: * TRACE ROUTINE (TRXEQ) AND THE MAIN FUNCTION CALL ENTRY
22883: * (O$FNC, O$FNS). IN THE LATTER CASES, CFUNC IS USED ONLY
22884: * IF THE NUMBER OF ARGUMENTS IS INCORRECT.
22885: *
22886: * (XL) POINTER TO FUNCTION BLOCK
22887: * (WA) ACTUAL NUMBER OF ARGUMENTS
22888: * (XS) POINTS TO STACKED ARGUMENTS
22889: * BRN CFUNC JUMP TO CALL FUNCTION
22890: *
22891: * CFUNC CONTINUES BY EXECUTING THE FUNCTION
22892: *
22893: CFUNC RTN
22894: BLT WA,FARGS(XL),CFNC1 JUMP IF TOO FEW ARGUMENTS
22895: BEQ WA,FARGS(XL),CFNC3 JUMP IF CORRECT NUMBER OF ARGS
22896: *
22897: * HERE IF TOO MANY ARGUMENTS SUPPLIED, POP THEM OFF
22898: *
22899: MOV WA,WB COPY ACTUAL NUMBER
22900: SUB FARGS(XL),WB GET NUMBER OF EXTRA ARGS
22901: WTB WB CONVERT TO BYTES
22902: ADD WB,XS POP OFF UNWANTED ARGUMENTS
22903: BRN CFNC3 JUMP TO GO OFF TO FUNCTION
22904: *
22905: * HERE IF TOO FEW ARGUMENTS
22906: *
22907: CFNC1 MOV FARGS(XL),WB LOAD REQUIRED NUMBER OF ARGUMENTS
22908: BEQ WB,=NINI9,CFNC3 JUMP IF CASE OF VAR NUM OF ARGS
22909: SUB WA,WB CALCULATE NUMBER MISSING
22910: LCT WB,WB SET COUNTER TO CONTROL LOOP
22911: *
22912: * LOOP TO SUPPLY EXTRA NULL ARGUMENTS
22913: *
22914: CFNC2 MOV =NULLS,-(XS) STACK A NULL ARGUMENT
22915: BCT WB,CFNC2 LOOP TILL PROPER NUMBER STACKED
22916: *
22917: * MERGE HERE TO JUMP TO FUNCTION
22918: *
22919: CFNC3 BRI (XL) JUMP THROUGH FCODE FIELD
22920: EJC
22921: *
22922: * EXFAL -- EXIT SIGNALLING SNOBOL FAILURE
22923: *
22924: * (XL,XR) MAY BE NON-COLLECTABLE
22925: * BRN EXFAL JUMP TO FAIL
22926: *
22927: * EXFAL CONTINUES BY EXECUTING THE APPROPRIATE FAIL GOTO
22928: *
22929: EXFAL RTN
22930: MOV FLPTR,XS POP STACK
22931: MOV (XS),XR LOAD FAILURE OFFSET
22932: ADD R$COD,XR POINT TO FAILURE CODE LOCATION
22933: LCP XR SET CODE POINTER
22934: BRN EXITS DO NEXT CODE WORD
22935: EJC
22936: *
22937: * EXINT -- EXIT WITH INTEGER RESULT
22938: *
22939: * (XL,XR) MAY BE NONCOLLECTABLE
22940: * (IA) INTEGER VALUE
22941: * BRN EXINT JUMP TO EXIT WITH INTEGER
22942: *
22943: * EXINT CONTINUES BY EXECUTING THE NEXT CODE WORD
22944: * WHICH IT DOES BY FALLING THROUGH TO EXIXR
22945: *
22946: EXINT RTN
22947: JSR ICBLD BUILD ICBLK
22948: EJC
22949: * EXIXR -- EXIT WITH RESULT IN (XR)
22950: *
22951: * (XR) RESULT
22952: * (XL) MAY BE NON-COLLECTABLE
22953: * BRN EXIXR JUMP TO EXIT WITH RESULT IN (XR)
22954: *
22955: * EXIXR CONTINUES BY EXECUTING THE NEXT CODE WORD
22956: * WHICH IT DOES BY FALLING THROUGH TO EXITS.
22957: EXIXR RTN
22958: *
22959: MOV XR,-(XS) STACK RESULT
22960: *
22961: *
22962: * EXITS -- EXIT WITH RESULT IF ANY STACKED
22963: *
22964: * (XR,XL) MAY BE NON-COLLECTABLE
22965: *
22966: * BRN EXITS ENTER EXITS ROUTINE
22967: *
22968: EXITS RTN
22969: LCW XR LOAD NEXT CODE WORD
22970: MOV (XR),XL LOAD ENTRY ADDRESS
22971: BRI XL JUMP TO EXECUTE NEXT CODE WORD
22972: EJC
22973: *
22974: * EXNAM -- EXIT WITH NAME IN (XL,WA)
22975: *
22976: * (XL) NAME BASE
22977: * (WA) NAME OFFSET
22978: * (XR) MAY BE NON-COLLECTABLE
22979: * BRN EXNAM JUMP TO EXIT WITH NAME IN (XL,WA)
22980: *
22981: * EXNAM CONTINUES BY EXECUTING THE NEXT CODE WORD
22982: *
22983: EXNAM RTN
22984: MOV XL,-(XS) STACK NAME BASE
22985: MOV WA,-(XS) STACK NAME OFFSET
22986: BRN EXITS DO NEXT CODE WORD
22987: EJC
22988: *
22989: * EXNUL -- EXIT WITH NULL RESULT
22990: *
22991: * (XL,XR) MAY BE NON-COLLECTABLE
22992: * BRN EXNUL JUMP TO EXIT WITH NULL VALUE
22993: *
22994: * EXNUL CONTINUES BY EXECUTING THE NEXT CODE WORD
22995: *
22996: EXNUL RTN
22997: MOV =NULLS,-(XS) STACK NULL VALUE
22998: BRN EXITS DO NEXT CODE WORD
22999: EJC
23000: .IF .CNRA
23001: .ELSE
23002: *
23003: * EXREA -- EXIT WITH REAL RESULT
23004: *
23005: * (XL,XR) MAY BE NON-COLLECTABLE
23006: * (RA) REAL VALUE
23007: * BRN EXREA JUMP TO EXIT WITH REAL VALUE
23008: *
23009: * EXREA CONTINUES BY EXECUTING THE NEXT CODE WORD
23010: *
23011: EXREA RTN
23012: JSR RCBLD BUILD RCBLK
23013: BRN EXIXR JUMP TO EXIT WITH RESULT IN XR
23014: .FI
23015: EJC
23016: *
23017: * EXSID -- EXIT SETTING ID FIELD
23018: *
23019: * EXSID IS USED TO EXIT AFTER BUILDING ANY OF THE FOLLOWING
23020: * BLOCKS (ARBLK, TBBLK, PDBLK, VCBLK). IT SETS THE IDVAL.
23021: *
23022: * (XR) PTR TO BLOCK WITH IDVAL FIELD
23023: * (XL) MAY BE NON-COLLECTABLE
23024: * BRN EXSID JUMP TO EXIT AFTER SETTING ID FIELD
23025: *
23026: * EXSID CONTINUES BY EXECUTING THE NEXT CODE WORD
23027: *
23028: EXSID RTN
23029: MOV CURID,WA LOAD CURRENT ID VALUE
23030: BNE WA,=CFP$M,EXSI1 JUMP IF NO OVERFLOW
23031: ZER WA ELSE RESET FOR WRAPAROUND
23032: *
23033: * HERE WITH OLD IDVAL IN WA
23034: *
23035: EXSI1 ICV WA BUMP ID VALUE
23036: MOV WA,CURID STORE FOR NEXT TIME
23037: MOV WA,IDVAL(XR) STORE ID VALUE
23038: BRN EXIXR EXIT WITH RESULT IN (XR)
23039: EJC
23040: *
23041: * EXVNM -- EXIT WITH NAME OF VARIABLE
23042: *
23043: * EXVNM EXITS AFTER STACKING A VALUE WHICH IS A NMBLK
23044: * REFERENCING THE NAME OF A GIVEN NATURAL VARIABLE.
23045: *
23046: * (XR) VRBLK POINTER
23047: * (XL) MAY BE NON-COLLECTABLE
23048: * BRN EXVNM EXIT WITH VRBLK POINTER IN XR
23049: *
23050: EXVNM RTN
23051: MOV XR,XL COPY NAME BASE POINTER
23052: MOV *NMSI$,WA SET SIZE OF NMBLK
23053: JSR ALLOC ALLOCATE NMBLK
23054: MOV =B$NML,(XR) STORE TYPE WORD
23055: MOV XL,NMBAS(XR) STORE NAME BASE
23056: MOV *VRVAL,NMOFS(XR) STORE NAME OFFSET
23057: BRN EXIXR EXIT WITH RESULT IN XR
23058: EJC
23059: *
23060: * FLPOP -- FAIL AND POP IN PATTERN MATCHING
23061: *
23062: * FLPOP POPS THE NODE AND CURSOR ON THE STACK AND THEN
23063: * DROPS THROUGH INTO FAILP TO CAUSE PATTERN FAILURE
23064: *
23065: * (XL,XR) MAY BE NON-COLLECTABLE
23066: * BRN FLPOP JUMP TO FAIL AND POP STACK
23067: *
23068: FLPOP RTN
23069: ADD *NUM02,XS POP TWO ENTRIES OFF STACK
23070: EJC
23071: *
23072: * FAILP -- FAILURE IN MATCHING PATTERN NODE
23073: *
23074: * FAILP IS USED AFTER FAILING TO MATCH A PATTERN NODE.
23075: * SEE PATTERN MATCH ROUTINES FOR DETAILS OF USE.
23076: *
23077: * (XL,XR) MAY BE NON-COLLECTABLE
23078: * BRN FAILP SIGNAL FAILURE TO MATCH
23079: *
23080: * FAILP CONTINUES BY MATCHING AN ALTERNATIVE FROM THE STACK
23081: *
23082: FAILP RTN
23083: MOV (XS)+,XR LOAD ALTERNATIVE NODE POINTER
23084: MOV (XS)+,WB RESTORE OLD CURSOR
23085: MOV (XR),XL LOAD PCODE ENTRY POINTER
23086: BRI XL JUMP TO EXECUTE CODE FOR NODE
23087: EJC
23088: *
23089: * INDIR -- COMPUTE INDIRECT REFERENCE
23090: *
23091: * (WB) NONZERO/ZERO FOR BY NAME/VALUE
23092: * BRN INDIR JUMP TO GET INDIRECT REF ON STACK
23093: *
23094: * INDIR CONTINUES BY EXECUTING THE NEXT CODE WORD
23095: *
23096: INDIR RTN
23097: MOV (XS)+,XR LOAD ARGUMENT
23098: BEQ (XR),=B$NML,INDR2 JUMP IF A NAME
23099: JSR GTNVR ELSE CONVERT TO VARIABLE
23100: ERR 239,INDIRECTION OPERAND IS NOT NAME
23101: BZE WB,INDR1 SKIP IF BY VALUE
23102: MOV XR,-(XS) ELSE STACK VRBLK PTR
23103: MOV *VRVAL,-(XS) STACK NAME OFFSET
23104: BRN EXITS EXIT WITH RESULT ON STACK
23105: *
23106: * HERE TO GET VALUE OF NATURAL VARIABLE
23107: *
23108: INDR1 BRI (XR) JUMP THROUGH VRGET FIELD OF VRBLK
23109: *
23110: * HERE IF OPERAND IS A NAME
23111: *
23112: INDR2 MOV NMBAS(XR),XL LOAD NAME BASE
23113: MOV NMOFS(XR),WA LOAD NAME OFFSET
23114: BNZ WB,EXNAM EXIT IF CALLED BY NAME
23115: JSR ACESS ELSE GET VALUE FIRST
23116: PPM EXFAL FAIL IF ACCESS FAILS
23117: BRN EXIXR ELSE RETURN WITH VALUE IN XR
23118: EJC
23119: *
23120: * MATCH -- INITIATE PATTERN MATCH
23121: *
23122: * (WB) MATCH TYPE CODE
23123: * BRN MATCH JUMP TO INITIATE PATTERN MATCH
23124: *
23125: * MATCH CONTINUES BY EXECUTING THE PATTERN MATCH. SEE
23126: * PATTERN MATCH ROUTINES (P$XXX) FOR FULL DETAILS.
23127: *
23128: MATCH RTN
23129: MOV (XS)+,XR LOAD PATTERN OPERAND
23130: JSR GTPAT CONVERT TO PATTERN
23131: ERR 240,PATTERN MATCH RIGHT OPERAND IS NOT PATTERN
23132: MOV XR,XL IF OK, SAVE PATTERN POINTER
23133: BNZ WB,MTCH1 JUMP IF NOT MATCH BY NAME
23134: MOV (XS),WA ELSE LOAD NAME OFFSET
23135: MOV XL,-(XS) SAVE PATTERN POINTER
23136: MOV 2(XS),XL LOAD NAME BASE
23137: JSR ACESS ACCESS SUBJECT VALUE
23138: PPM EXFAL FAIL IF ACCESS FAILS
23139: MOV (XS),XL RESTORE PATTERN POINTER
23140: MOV XR,(XS) STACK SUBJECT STRING VAL FOR MERGE
23141: ZER WB RESTORE TYPE CODE
23142: *
23143: * MERGE HERE WITH SUBJECT VALUE ON STACK
23144: *
23145: .IF .CNBF
23146: MTCH1 JSR GTSTG CONVERT SUBJECT TO STRING
23147: .ELSE
23148: MTCH1 MOV (XS),XR LOAD SUBJECT VALUE
23149: ZER R$PMB ASSUME NOT A BUFFER
23150: BNE (XR),=B$BCT,MTCHA BRANCH IF NOT
23151: ICA XS ELSE POP VALUE
23152: MOV XR,R$PMB SAVE POINTER
23153: MOV BCLEN(XR),WA GET DEFINED LENGTH
23154: MOV BCBUF(XR),XR POINT TO BFBLK
23155: BRN MTCHB
23156: *
23157: * HERE IF NOT BUFFER TO CONVERT TO STRING
23158: *
23159: MTCHA JSR GTSTG NOT BUFFER - CONVERT TO STRING
23160: .FI
23161: ERR 241,PATTERN MATCH LEFT OPERAND IS NOT STRING
23162: *
23163: * MERGE WITH BUFFER OR STRING
23164: *
23165: MTCHB MOV XR,R$PMS IF OK, STORE SUBJECT STRING POINTER
23166: MOV WA,PMSSL AND LENGTH
23167: MOV WB,-(XS) STACK MATCH TYPE CODE
23168: ZER -(XS) STACK INITIAL CURSOR (ZERO)
23169: ZER WB SET INITIAL CURSOR
23170: MOV XS,PMHBS SET HISTORY STACK BASE PTR
23171: ZER PMDFL RESET PATTERN ASSIGNMENT FLAG
23172: MOV XL,XR SET INITIAL NODE POINTER
23173: BNZ KVANC,MTCH2 JUMP IF ANCHORED
23174: *
23175: * HERE FOR UNANCHORED
23176: *
23177: MOV XR,-(XS) STACK INITIAL NODE POINTER
23178: MOV =NDUNA,-(XS) STACK POINTER TO ANCHOR MOVE NODE
23179: BRI (XR) START MATCH OF FIRST NODE
23180: *
23181: * HERE IN ANCHORED MODE
23182: *
23183: MTCH2 ZER -(XS) DUMMY CURSOR VALUE
23184: MOV =NDABO,-(XS) STACK POINTER TO ABORT NODE
23185: BRI (XR) START MATCH OF FIRST NODE
23186: EJC
23187: *
23188: * RETRN -- RETURN FROM FUNCTION
23189: *
23190: * (WA) STRING POINTER FOR RETURN TYPE
23191: * BRN RETRN JUMP TO RETURN FROM (SNOBOL) FUNC
23192: *
23193: * RETRN CONTINUES BY EXECUTING THE CODE AT THE RETURN POINT
23194: * THE STACK IS CLEANED OF ANY GARBAGE LEFT BY OTHER
23195: * ROUTINES WHICH MAY HAVE ALTERED FLPTR SINCE FUNCTION
23196: * ENTRY BY USING FLPRT, RESERVED FOR USE ONLY BY
23197: * FUNCTION CALL AND RETURN.
23198: *
23199: RETRN RTN
23200: BNZ KVFNC,RTN01 JUMP IF NOT LEVEL ZERO
23201: ERB 242,FUNCTION RETURN FROM LEVEL ZERO
23202: *
23203: * HERE IF NOT LEVEL ZERO RETURN
23204: *
23205: RTN01 MOV FLPRT,XS POP STACK
23206: ICA XS REMOVE FAILURE OFFSET
23207: MOV (XS)+,XR POP PFBLK POINTER
23208: MOV (XS)+,FLPTR POP FAILURE POINTER
23209: MOV (XS)+,FLPRT POP OLD FLPRT
23210: MOV (XS)+,WB POP CODE POINTER OFFSET
23211: MOV (XS)+,WC POP OLD CODE BLOCK POINTER
23212: ADD WC,WB MAKE OLD CODE POINTER ABSOLUTE
23213: LCP WB RESTORE OLD CODE POINTER
23214: MOV WC,R$COD RESTORE OLD CODE BLOCK POINTER
23215: DCV KVFNC DECREMENT FUNCTION LEVEL
23216: MOV KVTRA,WB LOAD TRACE
23217: ADD KVFTR,WB ADD FTRACE
23218: BZE WB,RTN06 JUMP IF NO TRACING POSSIBLE
23219: *
23220: * HERE IF THERE MAY BE A TRACE
23221: *
23222: MOV WA,-(XS) SAVE FUNCTION RETURN TYPE
23223: MOV XR,-(XS) SAVE PFBLK POINTER
23224: MOV WA,KVRTN SET RTNTYPE FOR TRACE FUNCTION
23225: MOV R$FNC,XL LOAD FNCLEVEL TRBLK PTR (IF ANY)
23226: JSR KTREX EXECUTE POSSIBLE FNCLEVEL TRACE
23227: MOV PFVBL(XR),XL LOAD VRBLK PTR (SGD13)
23228: BZE KVTRA,RTN02 JUMP IF TRACE IS OFF
23229: MOV PFRTR(XR),XR ELSE LOAD RETURN TRACE TRBLK PTR
23230: BZE XR,RTN02 JUMP IF NOT RETURN TRACED
23231: DCV KVTRA ELSE DECREMENT TRACE COUNT
23232: BZE TRFNC(XR),RTN03 JUMP IF PRINT TRACE
23233: MOV *VRVAL,WA ELSE SET NAME OFFSET
23234: MOV 1(XS),KVRTN MAKE SURE RTNTYPE IS SET RIGHT
23235: JSR TRXEQ EXECUTE FULL TRACE
23236: EJC
23237: *
23238: * RETRN (CONTINUED)
23239: *
23240: * HERE TO TEST FOR FTRACE
23241: *
23242: RTN02 BZE KVFTR,RTN05 JUMP IF FTRACE IS OFF
23243: DCV KVFTR ELSE DECREMENT FTRACE
23244: *
23245: * HERE FOR PRINT TRACE OF FUNCTION RETURN
23246: *
23247: RTN03 JSR PRTSN PRINT STATEMENT NUMBER
23248: MOV 1(XS),XR LOAD RETURN TYPE
23249: JSR PRTST PRINT IT
23250: MOV =CH$BL,WA LOAD BLANK
23251: JSR PRTCH PRINT IT
23252: MOV 0(XS),XL LOAD PFBLK PTR
23253: MOV PFVBL(XL),XL LOAD FUNCTION VRBLK PTR
23254: MOV *VRVAL,WA SET VRBLK NAME OFFSET
23255: BNE XR,=SCFRT,RTN04 JUMP IF NOT FRETURN CASE
23256: *
23257: * FOR FRETURN, JUST PRINT FUNCTION NAME
23258: *
23259: JSR PRTNM PRINT NAME
23260: JSR PRTNL TERMINATE PRINT LINE
23261: BRN RTN05 MERGE
23262: *
23263: * HERE FOR RETURN OR NRETURN, PRINT FUNCTION NAME = VALUE
23264: *
23265: RTN04 JSR PRTNV PRINT NAME = VALUE
23266: *
23267: * HERE AFTER COMPLETING TRACE
23268: *
23269: RTN05 MOV (XS)+,XR POP PFBLK POINTER
23270: MOV (XS)+,WA POP RETURN TYPE STRING
23271: *
23272: * MERGE HERE IF NO TRACE REQUIRED
23273: *
23274: RTN06 MOV WA,KVRTN SET RTNTYPE KEYWORD
23275: MOV PFVBL(XR),XL LOAD POINTER TO FN VRBLK
23276: EJC
23277: * RETRN (CONTINUED)
23278: *
23279: * GET VALUE OF FUNCTION
23280: *
23281: RTN07 MOV XL,RTNBP SAVE BLOCK POINTER
23282: MOV VRVAL(XL),XL LOAD VALUE
23283: BEQ (XL),=B$TRT,RTN07 LOOP BACK IF TRAPPED
23284: MOV XL,RTNFV ELSE SAVE FUNCTION RESULT VALUE
23285: MOV (XS)+,RTNSV SAVE ORIGINAL FUNCTION VALUE
23286: .IF .CNPF
23287: MOV FARGS(XR),WB GET NUMBER OF ARGUMENTS
23288: .ELSE
23289: MOV (XS)+,XL POP SAVED POINTER
23290: BZE XL,RTN7C NO ACTION IF NONE
23291: BZE KVPFL,RTN7C JUMP IF NO PROFILING
23292: JSR PRFLU ELSE PROFILE LAST FUNC STMT
23293: BEQ KVPFL,=NUM02,RTN7A BRANCH ON VALUE OF PROFILE KEYWD
23294: *
23295: * HERE IF &PROFILE = 1. START TIME MUST BE FRIGGED TO
23296: * APPEAR EARLIER THAN IT ACTUALLY IS, BY AMOUNT USED BEFORE
23297: * THE CALL.
23298: *
23299: LDI PFSTM LOAD CURRENT TIME
23300: SBI ICVAL(XL) FRIG BY SUBTRACTING SAVED AMOUNT
23301: BRN RTN7B AND MERGE
23302: *
23303: * HERE IF &PROFILE = 2
23304: *
23305: RTN7A LDI ICVAL(XL) LOAD SAVED TIME
23306: *
23307: * BOTH PROFILE TYPES MERGE HERE
23308: *
23309: RTN7B STI PFSTM STORE BACK CORRECT START TIME
23310: *
23311: * MERGE HERE IF NO PROFILING
23312: *
23313: RTN7C MOV FARGS(XR),WB GET NUMBER OF ARGS
23314: .FI
23315: ADD PFNLO(XR),WB ADD NUMBER OF LOCALS
23316: BZE WB,RTN10 JUMP IF NO ARGS/LOCALS
23317: LCT WB,WB ELSE SET LOOP COUNTER
23318: ADD PFLEN(XR),XR AND POINT TO END OF PFBLK
23319: *
23320: * LOOP TO RESTORE FUNCTIONS AND LOCALS
23321: *
23322: RTN08 MOV -(XR),XL LOAD NEXT VRBLK POINTER
23323: *
23324: * LOOP TO FIND VALUE BLOCK
23325: *
23326: RTN09 MOV XL,WA SAVE BLOCK POINTER
23327: MOV VRVAL(XL),XL LOAD POINTER TO NEXT VALUE
23328: BEQ (XL),=B$TRT,RTN09 LOOP BACK IF TRAPPED
23329: MOV WA,XL ELSE RESTORE LAST BLOCK POINTER
23330: MOV (XS)+,VRVAL(XL) RESTORE OLD VARIABLE VALUE
23331: BCT WB,RTN08 LOOP TILL ALL PROCESSED
23332: *
23333: * NOW RESTORE FUNCTION VALUE AND EXIT
23334: *
23335: RTN10 MOV RTNBP,XL RESTORE PTR TO LAST FUNCTION BLOCK
23336: MOV RTNSV,VRVAL(XL) RESTORE OLD FUNCTION VALUE
23337: MOV RTNFV,XR RELOAD FUNCTION RESULT
23338: MOV R$COD,XL POINT TO NEW CODE BLOCK
23339: MOV KVSTN,KVLST SET LASTNO FROM STNO
23340: MOV CDSTM(XL),KVSTN RESET PROPER STNO VALUE
23341: MOV KVRTN,WA LOAD RETURN TYPE
23342: BEQ WA,=SCRTN,EXIXR EXIT WITH RESULT IN XR IF RETURN
23343: BEQ WA,=SCFRT,EXFAL FAIL IF FRETURN
23344: EJC
23345: *
23346: * RETRN (CONTINUED)
23347: *
23348: * HERE FOR NRETURN
23349: *
23350: BEQ (XR),=B$NML,RTN11 JUMP IF IS A NAME
23351: JSR GTNVR ELSE TRY CONVERT TO VARIABLE NAME
23352: ERR 243,FUNCTION RESULT IN NRETURN IS NOT NAME
23353: MOV XR,XL IF OK, COPY VRBLK (NAME BASE) PTR
23354: MOV *VRVAL,WA SET NAME OFFSET
23355: BRN RTN12 AND MERGE
23356: *
23357: * HERE IF RETURNED RESULT IS A NAME
23358: *
23359: RTN11 MOV NMBAS(XR),XL LOAD NAME BASE
23360: MOV NMOFS(XR),WA LOAD NAME OFFSET
23361: *
23362: * MERGE HERE WITH RETURNED NAME IN (XL,WA)
23363: *
23364: RTN12 MOV XL,XR PRESERVE XL
23365: LCW WB LOAD NEXT WORD
23366: MOV XR,XL RESTORE XL
23367: BEQ WB,=OFNE$,EXNAM EXIT IF CALLED BY NAME
23368: MOV WB,-(XS) ELSE SAVE CODE WORD
23369: JSR ACESS GET VALUE
23370: PPM EXFAL FAIL IF ACCESS FAILS
23371: MOV XR,XL IF OK, COPY RESULT
23372: MOV (XS),XR RELOAD NEXT CODE WORD
23373: MOV XL,(XS) STORE RESULT ON STACK
23374: MOV (XR),XL LOAD ROUTINE ADDRESS
23375: BRI XL JUMP TO EXECUTE NEXT CODE WORD
23376: EJC
23377: *
23378: * STCOV -- SIGNAL STATEMENT COUNTER OVERFLOW
23379: *
23380: * BRN STCOV JUMP TO SIGNAL STATEMENT COUNT OFLO
23381: *
23382: * PERMIT UP TO 10 MORE STATEMENTS TO BE OBEYED SO THAT
23383: * SETEXIT TRAP CAN REGAIN CONTROL.
23384: * STCOV CONTINUES BY ISSUING THE ERROR MESSAGE
23385: *
23386: STCOV RTN
23387: ICV ERRFT FATAL ERROR
23388: LDI INTVT GET 10
23389: ADI KVSTL ADD TO FORMER LIMIT
23390: STI KVSTL STORE AS NEW STLIMIT
23391: LDI INTVT GET 10
23392: STI KVSTC SET AS NEW COUNT
23393: ERB 244,STATEMENT COUNT EXCEEDS VALUE OF STLIMIT KEYWORD
23394: EJC
23395: *
23396: * STMGO -- START EXECUTION OF NEW STATEMENT
23397: *
23398: * (XR) POINTER TO CDBLK FOR NEW STATEMENT
23399: * BRN STMGO JUMP TO EXECUTE NEW STATEMENT
23400: *
23401: * STMGO CONTINUES BY EXECUTING THE NEXT STATEMENT
23402: *
23403: STMGO RTN
23404: MOV XR,R$COD SET NEW CODE BLOCK POINTER
23405: .IF .CNPF
23406: MOV KVSTN,KVLST SET LASTNO
23407: .ELSE
23408: BZE KVPFL,STGO1 SKIP IF NO PROFILING
23409: JSR PRFLU ELSE PROFILE THE STATEMENT
23410: STGO1 MOV KVSTN,KVLST SET LASTNO
23411: .FI
23412: MOV CDSTM(XR),KVSTN SET STNO
23413: ADD *CDCOD,XR POINT TO FIRST CODE WORD
23414: LCP XR SET CODE POINTER
23415: LDI KVSTC GET STMT COUNT
23416: ILT EXITS OMIT COUNTING IF NEGATIVE
23417: IEQ STCOV FAIL IF STLIMIT REACHED
23418: SBI INTV1 DECREMENT
23419: STI KVSTC REPLACE IT
23420: BZE R$STC,EXITS EXIT IF NO STCOUNT TRACE
23421: *
23422: * HERE FOR STCOUNT TRACE
23423: *
23424: ZER XR CLEAR GARBAGE VALUE IN XR
23425: MOV R$STC,XL LOAD POINTER TO STCOUNT TRBLK
23426: JSR KTREX EXECUTE KEYWORD TRACE
23427: BRN EXITS AND THEN EXIT FOR NEXT CODE WORD
23428: EJC
23429: *
23430: * STOPR -- TERMINATE RUN
23431: *
23432: * (XR) POINTS TO ENDING MESSAGE
23433: * BRN STOPR JUMP TO TERMINATE RUN
23434: *
23435: * TERMINATE RUN AND PRINT STATISTICS. ON ENTRY XR POINTS
23436: * TO ENDING MESSAGE OR IS ZERO IF MESSAGE PRINTED ALREADY.
23437: *
23438: STOPR RTN
23439: .IF .CSAX
23440: BZE XR,STPRA SKIP IF SYSAX ALREADY CALLED (REG04)
23441: JSR SYSAX CALL AFTER EXECUTION PROC
23442: STPRA ADD RSMEM,DNAME USE THE RESERVE MEMORY
23443: .ELSE
23444: ADD RSMEM,DNAME USE THE RESERVE MEMORY
23445: .FI
23446: BNE XR,=ENDMS,STPR0 SKIP IF NOT NORMAL END MESSAGE
23447: BNZ EXSTS,STPR3 SKIP IF EXEC STATS SUPPRESSED
23448: ZER ERICH CLEAR ERRORS TO INT.CH. FLAG
23449: *
23450: * LOOK TO SEE IF AN ENDING MESSAGE IS SUPPLIED
23451: *
23452: STPR0 JSR PRTPG EJECT PRINTER
23453: BZE XR,STPR1 SKIP IF NO MESSAGE
23454: JSR PRTST PRINT MESSAGE
23455: *
23456: * MERGE HERE IF NO MESSAGE TO PRINT
23457: *
23458: STPR1 JSR PRTIS PRINT BLANK LINE
23459: MTI KVSTN GET STATEMENT NUMBER
23460: MOV =STPM1,XR POINT TO MESSAGE /IN STATEMENT XXX/
23461: JSR PRTMX PRINT IT
23462: JSR SYSTM GET CURRENT TIME
23463: SBI TIMSX MINUS START TIME = ELAPSED EXEC TIM
23464: STI STPTI SAVE FOR LATER
23465: MOV =STPM3,XR POINT TO MSG /EXECUTION TIME MSEC /
23466: JSR PRTMX PRINT IT
23467: LDI KVSTL GET STATEMENT LIMIT
23468: ILT STPR2 SKIP IF NEGATIVE
23469: SBI KVSTC MINUS COUNTER = COUNT
23470: STI STPSI SAVE
23471: MOV =STPM2,XR POINT TO MESSAGE /STMTS EXECUTED/
23472: JSR PRTMX PRINT IT
23473: LDI STPTI RELOAD ELAPSED TIME
23474: MLI INTTH *1000 (MICROSECS)
23475: IOV STPR2 JUMP IF WE CANNOT COMPUTE
23476: DVI STPSI DIVIDE BY STATEMENT COUNT
23477: IOV STPR2 JUMP IF OVERFLOW
23478: MOV =STPM4,XR POINT TO MSG (MCSEC PER STATEMENT /
23479: JSR PRTMX PRINT IT
23480: EJC
23481: *
23482: * STOPR (CONTINUED)
23483: *
23484: * MERGE TO SKIP MESSAGE (OVERFLOW OR NEGATIVE STLIMIT)
23485: *
23486: STPR2 MTI GBCNT LOAD COUNT OF COLLECTIONS
23487: MOV =STPM5,XR POINT TO MESSAGE /REGENERATIONS /
23488: JSR PRTMX PRINT IT
23489: JSR PRTIS ONE MORE BLANK FOR LUCK
23490: *
23491: * CHECK IF DUMP REQUESTED
23492: *
23493: .IF .CNPF
23494: STPR3 MOV KVDMP,XR LOAD DUMP KEYWORD
23495: .ELSE
23496: STPR3 JSR PRFLR PRINT PROFILE IF WANTED
23497: *
23498: MOV KVDMP,XR LOAD DUMP KEYWORD
23499: .FI
23500: JSR DUMPR EXECUTE DUMP IF REQUESTED
23501: MOV R$FCB,XL GET FCBLK CHAIN HEAD
23502: MOV KVABE,WA LOAD ABEND VALUE
23503: MOV KVCOD,WB LOAD CODE VALUE
23504: JSR SYSEJ EXIT TO SYSTEM
23505: EJC
23506: *
23507: * SUCCP -- SIGNAL SUCCESSFUL MATCH OF A PATTERN NODE
23508: *
23509: * SEE PATTERN MATCH ROUTINES FOR DETAILS
23510: *
23511: * (XR) CURRENT NODE
23512: * (WB) CURRENT CURSOR
23513: * (XL) MAY BE NON-COLLECTABLE
23514: * BRN SUCCP SIGNAL SUCCESSFUL PATTERN MATCH
23515: *
23516: * SUCCP CONTINUES BY MATCHING THE SUCCESSOR NODE
23517: *
23518: SUCCP RTN
23519: MOV PTHEN(XR),XR LOAD SUCCESSOR NODE
23520: MOV (XR),XL LOAD NODE CODE ENTRY ADDRESS
23521: BRI XL JUMP TO MATCH SUCCESSOR NODE
23522: EJC
23523: *
23524: * SYSAB -- PRINT /ABNORMAL END/ AND TERMINATE
23525: *
23526: SYSAB RTN
23527: MOV =ENDAB,XR POINT TO MESSAGE
23528: MOV =NUM01,KVABE SET ABEND FLAG
23529: JSR PRTNL SKIP TO NEW LINE
23530: BRN STOPR JUMP TO PACK UP
23531: EJC
23532: *
23533: * SYSTU -- PRINT /TIME UP/ AND TERMINATE
23534: *
23535: SYSTU RTN
23536: MOV =ENDTU,XR POINT TO MESSAGE
23537: MOV STRTU,WA GET CHARS /TU/
23538: MOV WA,KVCOD PUT IN KVCOD
23539: MOV TIMUP,WA CHECK STATE OF TIMEUP SWITCH
23540: MNZ TIMUP SET SWITCH
23541: BNZ WA,STOPR STOP RUN IF ALREADY SET
23542: ERB 245,TRANSLATION/EXECUTION TIME EXPIRED
23543: TTL S P I T B O L -- STACK OVERFLOW SECTION
23544: *
23545: * CONTROL COMES HERE IF THE MAIN STACK OVERFLOWS
23546: *
23547: SEC START OF STACK OVERFLOW SECTION
23548: *
23549: ICV ERRFT FATAL ERROR
23550: MOV FLPTR,XS POP STACK TO AVOID MORE FAILS
23551: BNZ GBCFL,STAK1 JUMP IF GARBAGE COLLECTING
23552: ERB 246,STACK OVERFLOW
23553: *
23554: * NO CHANCE OF RECOVERY IN MID GARBAGE COLLECTION
23555: *
23556: STAK1 MOV =ENDSO,XR POINT TO MESSAGE
23557: ZER KVDMP MEMORY IS UNDUMPABLE
23558: BRN STOPR GIVE UP
23559: TTL S P I T B O L -- ERROR SECTION
23560: *
23561: * THIS SECTION OF CODE IS ENTERED WHENEVER A PROCEDURE
23562: * RETURN VIA AN ERR PARAMETER OR AN ERB OPCODE IS OBEYED.
23563: *
23564: * (WA) IS THE ERROR CODE
23565: *
23566: * THE GLOBAL VARIABLE STAGE INDICATES THE POINT AT WHICH
23567: * THE ERROR OCCURED AS FOLLOWS.
23568: *
23569: * STAGE=STGIC ERROR DURING INITIAL COMPILE
23570: *
23571: * STAGE=STGXC ERROR DURING COMPILE AT EXECUTE
23572: * TIME (CODE, CONVERT FUNCTION CALLS)
23573: *
23574: * STAGE=STGEV ERROR DURING COMPILATION OF
23575: * EXPRESSION AT EXECUTION TIME
23576: * (EVAL, CONVERT FUNCTION CALL).
23577: *
23578: * STAGE=STGXT ERROR AT EXECUTE TIME. COMPILER
23579: * NOT ACTIVE.
23580: *
23581: * STAGE=STGCE ERROR DURING INITIAL COMPILE AFTER
23582: * SCANNING OUT THE END LINE.
23583: *
23584: * STAGE=STGXE ERROR DURING COMPILE AT EXECUTE
23585: * TIME AFTER SCANNING END LINE.
23586: *
23587: * STAGE=STGEE ERROR DURING EXPRESSION EVALUATION
23588: *
23589: SEC START OF ERROR SECTION
23590: *
23591: ERROR BEQ R$CIM,=CMLAB,CMPLE JUMP IF ERROR IN SCANNING LABEL
23592: MOV WA,KVERT SAVE ERROR CODE
23593: ZER SCNRS RESET RESCAN SWITCH FOR SCANE
23594: ZER SCNGO RESET GOTO SWITCH FOR SCANE
23595: MOV STAGE,XR LOAD CURRENT STAGE
23596: BSW XR,STGNO JUMP TO APPROPRIATE ERROR CIRCUIT
23597: IFF STGIC,ERR01 INITIAL COMPILE
23598: IFF STGXC,ERR04 EXECUTE TIME COMPILE
23599: IFF STGEV,ERR04 EVAL COMPILING EXPR.
23600: IFF STGEE,ERR04 EVAL EVALUATING EXPR
23601: IFF STGXT,ERR05 EXECUTE TIME
23602: IFF STGCE,ERR01 COMPILE - AFTER END
23603: IFF STGXE,ERR04 XEQ COMPILE-PAST END
23604: ESW END SWITCH ON ERROR TYPE
23605: EJC
23606: *
23607: * ERROR DURING INITIAL COMPILE
23608: *
23609: * THE ERROR MESSAGE IS PRINTED AS PART OF THE COMPILER
23610: * OUTPUT. THIS PRINTOUT INCLUDES THE OFFENDING LINE (IF NOT
23611: * PRINTED ALREADY) AND AN ERROR FLAG UNDER THE APPROPRIATE
23612: * COLUMN AS INDICATED BY SCNSE UNLESS SCNSE IS SET TO ZERO.
23613: *
23614: * AFTER PRINTING THE MESSAGE, THE GENERATED CODE IS
23615: * MODIFIED TO AN ERROR CALL AND CONTROL IS RETURNED TO
23616: * THE CMPIL PROCEDURE AFTER RESETTING THE STACK POINTER.
23617: *
23618: * IF THE ERROR OCCURS AFTER THE END LINE, CONTROL RETURNS
23619: * IN A SLIGHTLY DIFFERENT MANNER TO ENSURE PROPER CLEANUP.
23620: *
23621: ERR01 MOV CMPXS,XS RESET STACK POINTER
23622: SSL CMPSS RESTORE S-R STACK PTR FOR CMPIL
23623: BNZ ERRSP,ERR03 JUMP IF ERROR SUPPRESS FLAG SET
23624: MOV ERICH,ERLST SET FLAG FOR LISTR
23625: JSR LISTR LIST LINE
23626: JSR PRTIS TERMINATE LISTING
23627: ZER ERLST CLEAR LISTR FLAG
23628: MOV SCNSE,WA LOAD SCAN ELEMENT OFFSET
23629: BZE WA,ERR02 SKIP IF NOT SET
23630: .IF .CAHT
23631: LCT WB,WA LOOP COUNTER
23632: ICV WA INCREASE FOR CH$EX
23633: JSR ALOCS STRING BLOCK FOR ERROR FLAG
23634: MOV XR,WA REMEMBER STRING PTR
23635: PSC XR READY FOR CHARACTER STORING
23636: MOV R$CIM,XL POINT TO BAD STATEMENT
23637: PLC XL READY TO GET CHARS
23638: *
23639: * LOOP TO REPLACE ALL CHARS BUT TABS BY BLANKS
23640: *
23641: ERRA1 LCH WC,(XL)+ GET NEXT CHAR
23642: BEQ WC,=CH$HT,ERRA2 SKIP IF TAB
23643: MOV =CH$BL,WC GET A BLANK
23644: EJC
23645: *
23646: * MERGE TO STORE BLANK OR TAB IN ERROR LINE
23647: *
23648: ERRA2 SCH WC,(XR)+ STORE CHAR
23649: BCT WB,ERRA1 LOOP
23650: MOV =CH$EX,XL EXCLAMATION MARK
23651: SCH XL,(XR) STORE AT END OF ERROR LINE
23652: CSC XR END OF SCH LOOP
23653: MOV =STNPD,PROFS ALLOW FOR STATEMENT NUMBER
23654: MOV WA,XR POINT TO ERROR LINE
23655: JSR PRTST PRINT ERROR LINE
23656: .ELSE
23657: MTI PRLEN GET PRINT BUFFER LENGTH
23658: MFI GTNSI STORE AS SIGNED INTEGER
23659: ADD =STNPD,WA ADJUST FOR STATEMENT NUMBER
23660: MTI WA COPY TO INTEGER ACCUMULATOR
23661: RMI GTNSI REMAINDER MODULO PRINT BFR LENGTH
23662: STI PROFS USE AS CHARACTER OFFSET
23663: MOV =CH$EX,WA GET EXCLAMATION MARK
23664: JSR PRTCH GENERATE UNDER BAD COLUMN
23665: .FI
23666: *
23667: * HERE AFTER PLACING ERROR FLAG AS REQUIRED
23668: *
23669: ERR02 JSR ERMSG GENERATE FLAG AND ERROR MESSAGE
23670: ADD =NUM03,LSTLC BUMP PAGE CTR FOR BLANK, ERROR, BLK
23671: ZER XR IN CASE OF FATAL ERROR
23672: BHI ERRFT,=NUM03,STOPR PACK UP IF SEVERAL FATALS
23673: *
23674: * COUNT ERROR, INHIBIT EXECUTION IF REQUIRED
23675: *
23676: ICV CMERC BUMP ERROR COUNT
23677: ADD CSWER,NOXEQ INHIBIT XEQ IF -NOERRORS
23678: BNE STAGE,=STGIC,CMP10 SPECIAL RETURN IF AFTER END LINE
23679: EJC
23680: *
23681: * LOOP TO SCAN TO END OF STATEMENT
23682: *
23683: ERR03 MOV R$CIM,XR POINT TO START OF IMAGE
23684: PLC XR POINT TO FIRST CHAR
23685: LCH XR,(XR) GET FIRST CHAR
23686: BEQ XR,=CH$MN,CMPCE JUMP IF ERROR IN CONTROL CARD
23687: ZER SCNRS CLEAR RESCAN FLAG
23688: MNZ ERRSP SET ERROR SUPPRESS FLAG
23689: JSR SCANE SCAN NEXT ELEMENT
23690: BNE XL,=T$SMC,ERR03 LOOP BACK IF NOT STATEMENT END
23691: ZER ERRSP CLEAR ERROR SUPPRESS FLAG
23692: *
23693: * GENERATE ERROR CALL IN CODE AND RETURN TO CMPIL
23694: *
23695: MOV *CDCOD,CWCOF RESET OFFSET IN CCBLK
23696: MOV =OCER$,WA LOAD COMPILE ERROR CALL
23697: JSR CDWRD GENERATE IT
23698: MOV CWCOF,CMSOC(XS) SET SUCCESS FILL IN OFFSET
23699: MNZ CMFFC(XS) SET FAILURE FILL IN FLAG
23700: JSR CDWRD GENERATE SUCC. FILL IN WORD
23701: BRN CMPSE MERGE TO GENERATE ERROR AS CDFAL
23702: *
23703: * ERROR DURING EXECUTE TIME COMPILE OR EXPRESSION EVALUATIO
23704: *
23705: * EXECUTE TIME COMPILATION IS INITIATED THROUGH GTCOD OR
23706: * GTEXP WHICH ARE CALLED BY COMPILE, CODE OR EVAL.
23707: * BEFORE CAUSING STATEMENT FAILURE THROUGH EXFAL IT IS
23708: * HELPFUL TO SET KEYWORD ERRTEXT AND FOR GENERALITY
23709: * THESE ERRORS MAY BE HANDLED BY THE SETEXIT MECHANISM.
23710: *
23711: ERR04 ZER R$CCB FORGET GARBAGE CODE BLOCK
23712: SSL INISS RESTORE MAIN PROG S-R STACK PTR
23713: JSR ERTEX GET FAIL MESSAGE TEXT
23714: DCA XS ENSURE STACK OK ON LOOP START
23715: *
23716: * POP STACK UNTIL FIND FLPTR FOR MOST DEEPLY NESTED PROG.
23717: * DEFINED FUNCTION CALL OR CALL OF EVAL / CODE.
23718: *
23719: ERRA4 ICA XS POP STACK
23720: BEQ XS,FLPRT,ERRC4 JUMP IF PROG DEFINED FN CALL FOUND
23721: BNE XS,GTCEF,ERRA4 LOOP IF NOT EVAL OR CODE CALL YET
23722: MOV =STGXT,STAGE RE-SET STAGE FOR EXECUTE
23723: MOV R$GTC,R$COD RECOVER CODE PTR
23724: MOV XS,FLPTR RESTORE FAIL POINTER
23725: ZER R$CIM FORGET POSSIBLE IMAGE
23726: *
23727: * TEST ERRLIMIT
23728: *
23729: ERRB4 BNZ KVERL,ERR07 JUMP IF ERRLIMIT NON-ZERO
23730: BRN EXFAL FAIL
23731: *
23732: * RETURN FROM PROG. DEFINED FUNCTION IS OUTSTANDING
23733: *
23734: ERRC4 MOV FLPTR,XS RESTORE STACK FROM FLPTR
23735: BRN ERRB4 MERGE
23736: EJC
23737: *
23738: * ERROR AT EXECUTE TIME.
23739: *
23740: * THE ACTION TAKEN ON AN ERROR IS AS FOLLOWS.
23741: *
23742: * IF ERRLIMIT KEYWORD IS ZERO, AN ABORT IS SIGNALLED,
23743: * SEE CODING FOR SYSTEM LABEL ABORT AT L$ABO.
23744: *
23745: * OTHERWISE, ERRLIMIT IS DECREMENTED AND AN ERRTYPE TRACE
23746: * GENERATED IF REQUIRED. CONTROL RETURNS EITHER VIA A JUMP
23747: * TO CONTINUE (TO TAKE THE FAILURE EXIT) OR A SPECIFIED
23748: * SETEXIT TRAP IS EXECUTED AND CONTROL PASSES TO THE TRAP.
23749: * IF 3 OR MORE FATAL ERRORS OCCUR AN ABORT IS SIGNALLED
23750: * REGARDLESS OF ERRLIMIT AND SETEXIT - LOOPING IS ALL TOO
23751: * PROBABLE OTHERWISE. FATAL ERRORS INCLUDE STACK OVERFLOW
23752: * AND EXCEEDING STLIMIT.
23753: *
23754: ERR05 SSL INISS RESTORE MAIN PROG S-R STACK PTR
23755: BNZ DMVCH,ERR08 JUMP IF IN MID-DUMP
23756: *
23757: * MERGE HERE FROM ERR08
23758: *
23759: ERR06 BZE KVERL,LABO1 ABORT IF ERRLIMIT IS ZERO
23760: JSR ERTEX GET FAIL MESSAGE TEXT
23761: *
23762: * MERGE FROM ERR04
23763: *
23764: ERR07 BGE ERRFT,=NUM03,LABO1 ABORT IF TOO MANY FATAL ERRORS
23765: DCV KVERL DECREMENT ERRLIMIT
23766: MOV R$ERT,XL LOAD ERRTYPE TRACE POINTER
23767: JSR KTREX GENERATE ERRTYPE TRACE IF REQUIRED
23768: MOV R$COD,R$CNT SET CDBLK PTR FOR CONTINUATION
23769: MOV FLPTR,XR SET PTR TO FAILURE OFFSET
23770: MOV (XR),STXOF SAVE FAILURE OFFSET FOR CONTINUE
23771: MOV R$SXC,XR LOAD SETEXIT CDBLK POINTER
23772: BZE XR,LCNT1 CONTINUE IF NO SETEXIT TRAP
23773: ZER R$SXC ELSE RESET TRAP
23774: MOV =NULLS,STXVR RESET SETEXIT ARG TO NULL
23775: MOV (XR),XL LOAD PTR TO CODE BLOCK ROUTINE
23776: BRI XL EXECUTE FIRST TRAP STATEMENT
23777: *
23778: * INTERRUPTED PARTLY THROUGH A DUMP WHILST STORE IS IN A
23779: * MESS SO DO A TIDY UP OPERATION. SEE DUMPR FOR DETAILS.
23780: *
23781: ERR08 MOV DMVCH,XR CHAIN HEAD FOR AFFECTED VRBLKS
23782: BZE XR,ERR06 DONE IF ZERO
23783: MOV (XR),DMVCH SET NEXT LINK AS CHAIN HEAD
23784: JSR SETVR RESTORE VRGET FIELD
23785: BRN ERR08 LOOP THROUGH CHAIN
23786: TTL S P I T B O L -- HERE ENDETH THE CODE
23787: *
23788: * END OF ASSEMBLY
23789: *
23790: END END MACRO-SPITBOL ASSEMBLY
23791:
23792:
23793:
23794:
23795:
23796:
23797:
23798:
23799:
23800:
23801:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.