![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to spitv35.ppmin CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / spitbol|
Return to spitv35.ppmin CVS log | Up to [Research Unix] / researchv10no / cmd / spitbol |
1.1 root 1: TTL S P I T B O L - REVISION HISTORY
2: EJC
3: * R E V I S I O N H I S T O R Y
4: * -------------------------------
5: *
6: *
7: * VERSION 3.5B (FEB 81... - SGD PATCHES)
8: * -----------------------------------
9: *
10: * SGD03 - ADDITION OF .CNCI AND SYSCI (INT->STRING
11: * SYSTEM ROUTINE OPTION)
12: * SGD04 - (06-MAY-1981) MODIFIED INILN TO 132
13: * SGD05 - (13-MAY-1981) INSERTED MISSING WTB AFTER SYSMM
14: * CALLS
15: * SGD06 - (25-MAY-1981) MERGED IN PROFILER PATCHES
16: * (NOT MARKED)
17: * SGD07 - (25-MAY-1981) MUCHO PATCHES TO PROFILER (MARKED,
18: * BUT BEST JUST TO EXTRACT ENMASSE)
19: * SGD08 - (25-MAY-1981) USE STRING LENGTH IN HASHS
20: * SGD09 - (25-MAY-1981) FIXED SERIOUS PARSER PROBLEM
21: * RELATING TO (X Y) ON LINE BEING VIEWED AS PATTERN
22: * MATCH. FIXED BY ADDITION OF NEW CMTYP VALUE
23: * C$CNP (CONCATENATION - NOT PATTERN MATCH)
24: * SGD10 - (01-AUG-1981) FIXED EXIT(N) RESPECIFICATION CODE
25: * TO PROPERLY OBSERVE HEADER SEMANTICS ON RETURN.
26: * SGD11 - (07-AUG-1981) BYPASS PRTPG CALL AT INITIALIZATION
27: * FOLLOWING COMPILATION IF NO OUTPUT GENERATED.
28: * THIS PREVENTS OUTPUT FILES CONSISTING OF THE
29: * HEADERS AND A FEW BLANK LINES WHEN THERE IS NO
30: * SOURCE LISTING AND NO COMPILATION STATS.
31: * ALSO FIX TIMSX INITIALIZATION IN SAME CODE.
32: * SGD12 - (17-AUG-1981) B$EFC CODE DID NOT CHECK FOR
33: * UNCONVERTED RESULT RETURNING NULL STRING. FIXED.
34: * SGDBF - ( NOV-1981) ADDED BUFFER TYPE AND SYMBOL CNBF
35: * SGD13 - (03-MAR-1982) LOAD PFVBL FIELD IN RETRN FOR
36: * RETURN TRACING. THIS WAS CAUSING BUG ON RETURN
37: * TRACES THAT TRIED TO ACCESS THE VARIABLE NAME
38: * SGD14 - ADDED CHAR FUNCTION. CHAR(N) RETURNS NTH
39: * CHARACTER OF HOST MACHINE CHARACTER SET.
40: * NOT CONDITIONALIZED OR MARKED.
41: * SGD15 - FIXED PROBLEM RELATING TO COMPILATION OF GOTO
42: * FIELDS CONTAINING SMALL INTEGERS (IN CONST SEC).
43: *
44: * REG01 - (XX-AUG-82)
45: * ADDED CFP$U TO EASE TRANSLATION ON SMALLER
46: * SYSTEMS - CONDITIONAL .CUCF
47: * ADDED LOWER CASE SUPPORT - CONDITIONAL .CULC
48: * ADDED SET I/O FUNCTION - CONDITIONAL .CUST
49: *
50: * REG02 - (XX-SEP-82)
51: * CHANGED INILN AND AND INILS TO 258
52: *
53: * REG03 - (XX-OCT-82)
54: * CONDITIONALIZED THE PAGE EJECT AFTER CALL TO SYSBX
55: * AND ADDED ANOTHER BEFORE CALL TO SYSBX, SO THAT,
56: * IF DESIRED BY THE IMPLEMENTOR, STANDARD OUTPUT
57: * WILL REFLECT ASSIGNMENTS MADE BY EXECUTING PROGRAM
58: * ONLY. CONDITIONAL .CUEJ CONTROLS - IF DEFINED
59: * EJECT IS BEFORE CALL TO SYSBX.
60: *
61: * REG04 - (XX-NOV-82)
62: * FIXED DIFFICULTIES WITH LISTINGS DURING EXECUTION
63: * WHEN NO LISTING GENERATED DURING COMPILATION.
64: *
65: * -LIST TO CODE() CAUSED BOMB. FIX IS TO RESET
66: * R$TTL AND R$STL TO NULLS NOT 0 AFTER COMPILATION.
67: * (LISTR AND LISTT EXPECT NULLS)
68: *
69: * WHEN LISTING AND STATISTICS ROUTED TO DIFFERENT
70: * FILE THAN EXECUTION OUTPUT, ERROR MESSAGE IS SENT
71: * TO EXECUTION OUTPUT (AND GETS SEPARATED FROM
72: * ... IN STATEMENT ... MSG). LABO1 CALLS SYSAX AND
73: * STOPR DOES NOT CALL SYSAX IF ENTERED FROM LABO1.
74: *
75: * REG05 - (XX-NOV-82)
76: * PREVENT CLEAR() FROM CLOBBERING PROTECTED VARIABLES
77: * AT LABEL SCLR5.
78: *
79: * REG06 - (XX-NOV-82)
80: * FIXED GTEXP FROM ACCEPTING TRAILING SEMICOLON OR
81: * COLON. NOT LEGAL WAY TO END AN EXPRESSION.
82: *
83: * VERSION 3.5A (OCT 79 - SGD PATCHES)
84: * -----------------------------------
85: *
86: * SGD01 - PATCH IN ASIGN TO FIX MULTIPLE TRAP BLOCK PROBLEM
87: * (ASG10+2)
88: * SGD02 - PATCH IN GTARR TO FIX NULL CONVERT (GTAR9+0)
89: *
90: TTL S P I T B O L -- BASIC INFORMATION
91: EJC
92: *
93: * GENERAL STRUCTURE
94: * -----------------
95: *
96: * THIS PROGRAM IS A TRANSLATOR FOR A VERSION OF THE SNOBOL4
97: * PROGRAMMING LANGUAGE. LANGUAGE DETAILS ARE CONTAINED IN
98: * THE MANUAL MACRO SPITBOL BY DEWAR AND MCCANN, TECHNICAL
99: * REPORT 90, UNIVERSITY OF LEEDS 1976. THE LANGUAGE
100: * IS IDENTICAL TO THAT IMPLEMENTED BY THE BTL TRANSLATOR
101: * (R. E. GRISWOLD ET AL.) WITH THE FOLLOWING EXCEPTIONS.
102: *
103: * 1) REDEFINITION OF STANDARD SYSTEM FUNCTIONS AND
104: * OPERATORS IS NOT PERMITTED.
105: *
106: * 2) THE VALUE FUNCTION IS NOT PROVIDED.
107: *
108: * 3) ACCESS TRACING IS PROVIDED IN ADDITION TO THE
109: * OTHER STANDARD TRACE MODES.
110: *
111: * 4) THE KEYWORD STFCOUNT IS NOT PROVIDED.
112: *
113: * 5) THE KEYWORD FULLSCAN IS NOT PROVIDED AND ALL PATTERN
114: * MATCHING TAKES PLACE IN FULLSCAN MODE (I.E. WITH NO
115: * HEURISTICS APPLIED).
116: *
117: * 6) A SERIES OF EXPRESSIONS SEPARATED BY COMMAS MAY
118: * BE GROUPED WITHIN PARENTHESES TO PROVIDE A SELECTION
119: * CAPABILITY. THE SEMANTICS ARE THAT THE SELECTION
120: * ASSUMES THE VALUE OF THE FIRST EXPRESSION WITHIN IT
121: * WHICH SUCCEEDS AS THEY ARE EVALUATED FROM THE LEFT.
122: * IF NO EXPRESSION SUCCEEDS THE ENTIRE STATEMENT FAILS
123: *
124: * 7) AN EXPLICIT PATTERN MATCHING OPERATOR IS PROVIDED.
125: * THIS IS THE BINARY QUERY (SEE GIMPEL SIGPLAN OCT 74)
126: *
127: * 8) THE ASSIGNMENT OPERATOR IS INTRODUCED AS IN THE
128: * GIMPEL REFERENCE.
129: *
130: * 9) THE EXIT FUNCTION IS PROVIDED FOR GENERATING LOAD
131: * MODULES - CF. GIMPELS SITBOL.
132: *
133: *
134: * THE METHOD USED IN THIS PROGRAM IS TO TRANSLATE THE
135: * SOURCE CODE INTO AN INTERNAL PSEUDO-CODE (SEE FOLLOWING
136: * SECTION). AN INTERPRETOR IS THEN USED TO EXECUTE THIS
137: * GENERATED PSEUDO-CODE. THE NATURE OF THE SNOBOL4 LANGUAGE
138: * IS SUCH THAT THE LATTER TASK IS MUCH MORE COMPLEX THAN
139: * THE ACTUAL TRANSLATION PHASE. ACCORDINGLY, NEARLY ALL THE
140: * CODE IN THE PROGRAM SECTION IS CONCERNED WITH THE ACTUAL
141: * EXECUTION OF THE SNOBOL4 PROGRAM.
142: EJC
143: *
144: * INTERPRETIVE CODE FORMAT
145: * ------------------------
146: *
147: * THE INTERPRETIVE PSEUDO-CODE CONSISTS OF A SERIES OF
148: * ADDRESS POINTERS. THE EXACT FORMAT OF THE CODE IS
149: * DESCRIBED IN CONNECTION WITH THE CDBLK FORMAT. THE
150: * PURPOSE OF THIS SECTION IS TO GIVE GENERAL INSIGHT INTO
151: * THE INTERPRETIVE APPROACH INVOLVED.
152: *
153: * THE BASIC FORM OF THE CODE IS RELATED TO REVERSE POLISH.
154: * IN OTHER WORDS, THE OPERANDS PRECEDE THE OPERATORS WHICH
155: * ARE ZERO ADDRESS OPERATORS. THERE ARE SOME EXCEPTIONS TO
156: * THESE RULES, NOTABLY THE UNARY NOT OPERATOR AND THE
157: * SELECTION CONSTRUCTION WHICH CLEARLY REQUIRE ADVANCE
158: * KNOWLEDGE OF THE OPERATOR INVOLVED.
159: *
160: * THE OPERANDS ARE MOVED TO THE TOP OF THE MAIN STACK AND
161: * THE OPERATORS ARE APPLIED TO THE TOP STACK ENTRIES. LIKE
162: * OTHER VERSIONS OF SPITBOL, THIS PROCESSOR DEPENDS ON
163: * KNOWING WHETHER OPERANDS ARE REQUIRED BY NAME OR BY VALUE
164: * AND MOVES THE APPROPRIATE OBJECT TO THE STACK. THUS NO
165: * NAME/VALUE CHECKS ARE INCLUDED IN THE OPERATOR CIRCUITS.
166: *
167: * THE ACTUAL POINTERS IN THE CODE POINT TO A BLOCK WHOSE
168: * FIRST WORD IS THE ADDRESS OF THE INTERPRETOR ROUTINE
169: * TO BE EXECUTED FOR THE CODE WORD.
170: *
171: * IN THE CASE OF OPERATORS, THE POINTER IS TO A WORD WHICH
172: * CONTAINS THE ADDRESS OF THE OPERATOR TO BE EXECUTED. IN
173: * THE CASE OF OPERANDS SUCH AS CONSTANTS, THE POINTER IS TO
174: * THE OPERAND ITSELF. ACCORDINGLY, ALL OPERANDS CONTAIN
175: * A FIELD WHICH POINTS TO THE ROUTINE TO LOAD THE VALUE OF
176: * THE OPERAND ONTO THE STACK. IN THE CASE OF A VARIABLE,
177: * THERE ARE THREE SUCH POINTERS. ONE TO LOAD THE VALUE,
178: * ONE TO STORE THE VALUE AND A THIRD TO JUMP TO THE LABEL.
179: *
180: * THE HANDLING OF FAILURE RETURNS DESERVES SPECIAL COMMENT.
181: * THE LOCATION FLPTR CONTAINS THE POINTER TO THE LOCATION
182: * ON THE MAIN STACK WHICH CONTAINS THE FAILURE RETURN
183: * WHICH IS IN THE FORM OF A BYTE OFFSET IN THE CURRENT
184: * CODE BLOCK (CDBLK OR EXBLK). WHEN A FAILURE OCCURS, THE
185: * STACK IS POPPED AS INDICATED BY THE SETTING OF FLPTR AND
186: * CONTROL IS PASSED TO THE APPROPRIATE LOCATION IN THE
187: * CURRENT CODE BLOCK WITH THE STACK POINTER POINTING TO THE
188: * FAILURE OFFSET ON THE STACK AND FLPTR UNCHANGED.
189: EJC
190: *
191: * INTERNAL DATA REPRESENTATIONS
192: * -----------------------------
193: *
194: * REPRESENTATION OF VALUES
195: *
196: * A VALUE IS REPRESENTED BY A POINTER TO A BLOCK WHICH
197: * DESCRIBES THE TYPE AND PARTICULARS OF THE DATA VALUE.
198: * IN GENERAL, A VARIABLE IS A LOCATION CONTAINING SUCH A
199: * POINTER (ALTHOUGH IN THE CASE OF TRACE ASSOCIATIONS THIS
200: * IS MODIFIED, SEE DESCRIPTION OF TRBLK).
201: *
202: * THE FOLLOWING IS A LIST OF POSSIBLE DATATYPES SHOWING THE
203: * TYPE OF BLOCK USED TO HOLD THE VALUE. THE DETAILS OF
204: * EACH BLOCK FORMAT ARE GIVEN LATER.
205: *
206: * DATATYPE BLOCK TYPE
207: * -------- ----------
208: *
209: *
210: * ARRAY ARBLK OR VCBLK
211: *
212: * CODE CDBLK
213: *
214: * EXPRESSION EXBLK OR SEBLK
215: *
216: * INTEGER ICBLK
217: *
218: * NAME NMBLK
219: *
220: * PATTERN P0BLK OR P1BLK OR P2BLK
221: *
222: * REAL RCBLK
223: *
224: * STRING SCBLK
225: *
226: * TABLE TBBLK
227: *
228: * PROGRAM DATATYPE PDBLK
229: EJC
230: *
231: * REPRESENTATION OF VARIABLES
232: * ---------------------------
233: *
234: * DURING THE COURSE OF EVALUATING EXPRESSIONS, IT IS
235: * NECESSARY TO GENERATE NAMES OF VARIABLES (FOR EXAMPLE
236: * ON THE LEFT SIDE OF A BINARY EQUALS OPERATOR). THESE ARE
237: * NOT TO BE CONFUSED WITH OBJECTS OF DATATYPE NAME WHICH
238: * ARE IN FACT VALUES.
239: *
240: * FROM A LOGICAL POINT OF VIEW, SUCH NAMES COULD BE SIMPLY
241: * REPRESENTED BY A POINTER TO THE APPROPRIATE VALUE CELL.
242: * HOWEVER IN THE CASE OF ARRAYS AND PROGRAM DEFINED
243: * DATATYPES, THIS WOULD VIOLATE THE RULE THAT THERE MUST BE
244: * NO POINTERS INTO THE MIDDLE OF A BLOCK IN DYNAMIC STORE.
245: * ACCORDINGLY, A NAME IS ALWAYS REPRESENTED BY A BASE AND
246: * OFFSET. THE BASE POINTS TO THE START OF THE BLOCK
247: * CONTAINING THE VARIABLE VALUE AND THE OFFSET IS THE
248: * OFFSET WITHIN THIS BLOCK IN BYTES. THUS THE ADDRESS
249: * OF THE ACTUAL VARIABLE IS DETERMINED BY ADDING THE BASE
250: * AND OFFSET VALUES.
251: *
252: * THE FOLLOWING ARE THE INSTANCES OF VARIABLES REPRESENTED
253: * IN THIS MANNER.
254: *
255: * 1) NATURAL VARIABLE BASE IS PTR TO VRBLK
256: * OFFSET IS *VRVAL
257: *
258: * 2) TABLE ELEMENT BASE IS PTR TO TEBLK
259: * OFFSET IS *TEVAL
260: *
261: * 3) ARRAY ELEMENT BASE IS PTR TO ARBLK
262: * OFFSET IS OFFSET TO ELEMENT
263: *
264: * 4) VECTOR ELEMENT BASE IS PTR TO VCBLK
265: * OFFSET IS OFFSET TO ELEMENT
266: *
267: * 5) PROG DEF DTP BASE IS PTR TO PDBLK
268: * OFFSET IS OFFSET TO FIELD VALUE
269: *
270: * IN ADDITION THERE ARE TWO CASES OF OBJECTS WHICH ARE
271: * LIKE VARIABLES BUT CANNOT BE HANDLED IN THIS MANNER.
272: * THESE ARE CALLED PSEUDO-VARIABLES AND ARE REPRESENTED
273: * WITH A SPECIAL BASE POINTER AS FOLLOWS=
274: *
275: * EXPRESSION VARIABLE PTR TO EVBLK (SEE EVBLK)
276: *
277: * KEYWORD VARIABLE PTR TO KVBLK (SEE KVBLK)
278: *
279: * PSEUDO-VARIABLES ARE HANDLED AS SPECIAL CASES BY THE
280: * ACCESS PROCEDURE (ACESS) AND THE ASSIGNMENT PROCEDURE
281: * (ASIGN). SEE THESE TWO PROCEDURES FOR DETAILS.
282: EJC
283: *
284: * ORGANIZATION OF DATA AREA
285: * -------------------------
286: *
287: *
288: * THE DATA AREA IS DIVIDED INTO TWO REGIONS.
289: *
290: * STATIC AREA
291: *
292: * THE STATIC AREA BUILDS UP FROM THE BOTTOM AND CONTAINS
293: * DATA AREAS WHICH ARE ALLOCATED DYNAMICALLY BUT ARE NEVER
294: * DELETED OR MOVED AROUND. THE MACRO-PROGRAM ITSELF
295: * USES THE STATIC AREA FOR THE FOLLOWING.
296: *
297: * 1) ALL VARIABLE BLOCKS (VRBLK).
298: *
299: * 2) THE HASH TABLE FOR VARIABLE BLOCKS.
300: *
301: * 3) MISCELLANEOUS BUFFERS AND WORK AREAS (SEE PROGRAM
302: * INITIALIZATION SECTION).
303: *
304: * IN ADDITION, THE SYSTEM PROCEDURES MAY USE THIS AREA FOR
305: * INPUT/OUTPUT BUFFERS, EXTERNAL FUNCTIONS ETC. SPACE IN
306: * THE STATIC REGION IS ALLOCATED BY CALLING PROCEDURE ALOST
307: *
308: * THE FOLLOWING GLOBAL VARIABLES DEFINE THE CURRENT
309: * LOCATION AND SIZE OF THE STATIC AREA.
310: *
311: * STATB ADDRESS OF START OF STATIC AREA
312: * STATE ADDRESS+1 OF LAST WORD IN AREA.
313: *
314: * THE MINIMUM SIZE OF STATIC IS GIVEN APPROXIMATELY BY
315: * 12 + *E$HNB + *E$STS + SPACE FOR ALPHABET STRING
316: * AND STANDARD PRINT BUFFER.
317: EJC
318: *
319: * DYNAMIC AREA
320: *
321: * THE DYNAMIC AREA IS BUILT UPWARDS IN MEMORY AFTER THE
322: * STATIC REGION. DATA IN THIS AREA MUST ALL BE IN STANDARD
323: * BLOCK FORMATS SO THAT IT CAN BE PROCESSED BY THE GARBAGE
324: * COLLECTOR (PROCEDURE GBCOL). GBCOL COMPACTS BLOCKS DOWN
325: * IN THIS REGION AS REQUIRED BY SPACE EXHAUSTION AND CAN
326: * ALSO MOVE ALL BLOCKS UP TO ALLOW FOR EXPANSION OF THE
327: * STATIC REGION.
328: * WITH THE EXCEPTION OF TABLES AND ARRAYS, NO SPITBOL
329: * OBJECT ONCE BUILT IN DYNAMIC MEMORY IS EVER SUBSEQUENTLY
330: * MODIFIED. OBSERVING THIS RULE NECESSITATES A COPYING
331: * ACTION DURING STRING AND PATTERN CONCATENATION.
332: *
333: * GARBAGE COLLECTION IS FUNDAMENTAL TO THE ALLOCATION OF
334: * SPACE FOR VALUES. SPITBOL USES A VERY EFFICIENT GARBAGE
335: * COLLECTOR WHICH INSISTS THAT POINTERS INTO DYNAMIC STORE
336: * SHOULD BE IDENTIFIABLE WITHOUT USE OF BIT TABLES,
337: * MARKER BITS ETC. TO SATISFY THIS REQUIREMENT, DYNAMIC
338: * MEMORY MUST NOT START AT TOO LOW AN ADDRESS AND LENGTHS
339: * OF ARRAYS, TABLES, STRINGS, CODE AND EXPRESSION BLOCKS
340: * MAY NOT EXCEED THE NUMERICAL VALUE OF THE LOWEST DYNAMIC
341: * ADDRESS. TO AVOID EITHER PENALIZING USERS WITH MODEST
342: * REQUIREMENTS OR RESTRICTING THOSE WITH GREATER NEEDS ON
343: * HOST SYSTEMS WHERE DYNAMIC MEMORY IS ALLOCATED IN LOW
344: * ADDRESSES, THE MINIMUM DYNAMIC ADDRESS MAY BE SPECIFIED
345: * SUFFICIENTLY HIGH TO PERMIT ARBITRARILY LARGE SPITBOL
346: * OBJECTS TO BE CREATED ( WITH THE POSSIBILITY IN EXTREME
347: * CASES OF WASTING LARGE AMOUNTS OF MEMORY BELOW THE
348: * START ADDRESS). THIS MINIMUM VALUE IS MADE AVAILABLE
349: * IN VARIABLE MXLEN BY A SYSTEM ROUTINE, SYSMX.
350: * ALTERNATIVELY SYSMX MAY INDICATE THAT A
351: * DEFAULT MAY BE USED IN WHICH DYNAMIC IS PLACED
352: * AT THE LOWEST POSSIBLE ADDRESS FOLLOWING STATIC.
353: *
354: * THE FOLLOWING GLOBAL WORK CELLS DEFINE THE LOCATION AND
355: * LENGTH OF THE DYNAMIC AREA.
356: *
357: * DNAMB START OF DYNAMIC AREA
358: * DNAMP NEXT AVAILABLE LOCATION
359: * DNAME LAST AVAILABLE LOCATION + 1
360: *
361: * DNAMB IS ALWAYS HIGHER THAN STATE SINCE THE ALOST
362: * PROCEDURE MAINTAINS SOME EXPANSION SPACE ABOVE STATE.
363: * *** DNAMB MUST NEVER BE PERMITTED TO HAVE A VALUE LESS
364: * THAN THAT IN MXLEN ***
365: *
366: * SPACE IN THE DYNAMIC REGION IS ALLOCATED BY THE ALLOC
367: * PROCEDURE. THE DYNAMIC REGION MAY BE USED BY SYSTEM
368: * PROCEDURES PROVIDED THAT ALL THE RULES ARE OBEYED.
369: EJC
370: *
371: * REGISTER USAGE
372: * --------------
373: *
374: * (CP) CODE POINTER REGISTER. USED TO
375: * HOLD A POINTER TO THE CURRENT
376: * LOCATION IN THE INTERPRETIVE PSEUDO
377: * CODE (I.E. PTR INTO A CDBLK).
378: *
379: * (XL,XR) GENERAL INDEX REGISTERS. USUALLY
380: * USED TO HOLD POINTERS TO BLOCKS IN
381: * DYNAMIC STORAGE. AN IMPORTANT
382: * RESTRICTION IS THAT THE VALUE IN
383: * XL MUST BE COLLECTABLE FOR
384: * A GARBAGE COLLECT CALL. A VALUE
385: * IS COLLECTABLE IF IT EITHER POINTS
386: * OUTSIDE THE DYNAMIC AREA, OR IF IT
387: * POINTS TO THE START OF A BLOCK IN
388: * THE DYNAMIC AREA.
389: *
390: * (XS) STACK POINTER. USED TO POINT TO
391: * THE STACK FRONT. THE STACK MAY
392: * BUILD UP OR DOWN AND IS USED
393: * TO STACK SUBROUTINE RETURN POINTS
394: * AND OTHER RECURSIVELY SAVED DATA.
395: *
396: * (XT) AN ALTERNATIVE NAME FOR XL DURING
397: * ITS USE IN ACCESSING STACKED ITEMS.
398: *
399: * (WA,WB,WC) GENERAL WORK REGISTERS. CANNOT BE
400: * USED FOR INDEXING, BUT MAY HOLD
401: * VARIOUS TYPES OF DATA.
402: *
403: * (IA) USED FOR ALL SIGNED INTEGER
404: * ARITHMETIC, BOTH THAT USED BY THE
405: * TRANSLATOR AND THAT ARISING FROM
406: * USE OF SNOBOL4 ARITHMETIC OPERATORS
407: *
408: * (RA) REAL ACCUMULATOR. USED FOR ALL
409: * FLOATING POINT ARITHMETIC.
410: EJC
411: *
412: * SPITBOL CONDITIONAL ASSEMBLY SYMBOLS
413: * ------------------------------------
414: *
415: * IN THE SPITBOL TRANSLATOR, THE FOLLOWING CONDITIONAL
416: * ASSEMBLY SYMBOLS ARE REFERRED TO. TO INCORPORATE THE
417: * FEATURES REFERRED TO, THE MINIMAL SOURCE SHOULD BE
418: * PREFACED BY SUITABLE CONDITIONAL ASSEMBLY SYMBOL
419: * DEFINITIONS.
420: * IN ALL CASES IT IS PERMISSIBLE TO DEFAULT THE DEFINITIONS
421: * IN WHICH CASE THE ADDITIONAL FEATURES WILL BE OMITTED
422: * FROM THE TARGET CODE.
423: *
424: * .CASL DEFINE TO INCLUDE 26 SHIFTED LETTRS
425: * .CAHT DEFINE TO INCLUDE HORIZONTAL TAB
426: * .CAVT DEFINE TO INCLUDE VERTICAL TAB
427: * .CIOD IF DEFINED, DEFAULT DELIMITER IS
428: * NOT USED IN PROCESSING 3RD ARG OF
429: * INPUT() AND OUTPUT()
430: * .CNBT DEFINE TO OMIT BATCH INITIALISATION
431: * .CNCI DEFINE TO ENABLE SYSCI ROUTINE
432: * .CNEX DEFINE TO OMIT EXIT() CODE.
433: * .CNLD DEFINE TO OMIT LOAD() CODE.
434: * .CNPF DEFINE TO OMIT PROFILE STUFF
435: * .CNRA DEFINE TO OMIT ALL REAL ARITHMETIC
436: * .CNSR DEFINE TO OMIT SORT, RSORT
437: * .CSAX DEFINE IF SYSAX IS TO BE CALLED
438: * .CSN6 DEFINE TO PAD STMT NOS TO 6 CHARS
439: * .CSN8 DEFINE TO PAD STMT NOS TO 8 CHARS
440: * .CUCF DEFINE TO INCLUDE CFP$U
441: * .CULC DEFINE TO INCLUDE &CASE (LC NAMES)
442: * .CUST DEFINE TO INCLUDE SET() CODE
443: TTL S P I T B O L -- PROCEDURES SECTION
444: *
445: * THIS SECTION STARTS WITH DESCRIPTIONS OF THE OPERATING
446: * SYSTEM DEPENDENT PROCEDURES WHICH ARE USED BY THE SPITBOL
447: * TRANSLATOR. ALL SUCH PROCEDURES HAVE FIVE LETTER NAMES
448: * BEGINNING WITH SYS. THEY ARE LISTED IN ALPHABETICAL
449: * ORDER.
450: * ALL PROCEDURES HAVE A SPECIFICATION CONSISTING OF A
451: * MODEL CALL, PRECEDED BY A POSSIBLY EMPTY LIST OF REGISTER
452: * CONTENTS GIVING PARAMETERS AVAILABLE TO THE PROCEDURE AND
453: * FOLLOWED BY A POSSIBLY EMPTY LIST OF REGISTER CONTENTS
454: * REQUIRED ON RETURN FROM THE CALL OR WHICH MAY HAVE HAD
455: * THEIR CONTENTS DESTROYED. ONLY THOSE REGISTERS EXPLICITLY
456: * MENTIONED IN THE LIST AFTER THE CALL MAY HAVE THEIR
457: * VALUES CHANGED.
458: * THE SEGMENT OF CODE PROVIDING THE EXTERNAL PROCEDURES IS
459: * CONVENIENTLY REFERRED TO AS OSINT (OPERATING SYSTEM
460: * INTERFACE). THE SYSXX PROCEDURES IT CONTAINS PROVIDE
461: * FACILITIES NOT USUALLY AVAILABLE AS PRIMITIVES IN
462: * ASSEMBLY LANGUAGES. FOR PARTICULAR TARGET MACHINES,
463: * IMPLEMENTORS MAY CHOOSE FOR SOME MINIMAL OPCODES WHICH
464: * DO NOT HAVE REASONABLY DIRECT TRANSLATIONS, TO USE CALLS
465: * OF ADDITIONAL PROCEDURES WHICH THEY PROVIDE IN OSINT.
466: * E.G. MWB OR TRC MIGHT BE TRANSLATED AS JSR SYSMB,
467: * JSR SYSTC IN SOME IMPLEMENTATIONS.
468: *
469: * IN THE DESCRIPTIONS, REFERENCE IS MADE TO --BLK
470: * FORMATS (-- = A PAIR OF LETTERS). SEE THE SPITBOL
471: * DEFINITIONS SECTION FOR DETAILED DESCRIPTIONS OF ALL
472: * SUCH BLOCK FORMATS EXCEPT FCBLK FOR WHICH SYSFC SHOULD
473: * BE CONSULTED.
474: *
475: * SECTION 0 CONTAINS INP,INR SPECIFICATIONS OF INTERNAL
476: * PROCEDURES,ROUTINES. THIS GIVES A SINGLE PASS TRANSLATOR
477: * INFORMATION MAKING IT EASY TO GENERATE ALTERNATIVE CALLS
478: * IN THE TRANSLATION OF JSR-S FOR PROCEDURES OF DIFFERENT
479: * TYPES IF THIS PROVES NECESSARY.
480: *
481: SEC START OF PROCEDURES SECTION
482: EJC
483: *
484: * SYSAX -- AFTER EXECUTION
485: *
486: SYSAX EXP DEFINE EXTERNAL ENTRY POINT
487: *
488: * IF THE CONDITIONAL ASSEMBLY SYMBOL .CSAX IS DEFINED,
489: * THIS ROUTINE IS CALLED IMMEDIATELY AFTER EXECUTION AND
490: * BEFORE PRINTING OF EXECUTION STATISTICS OR DUMP OUTPUT.
491: * PURPOSE OF CALL IS FOR IMPLEMENTOR TO DETERMINE AND
492: * IF THE CALL IS NOT REQUIRED IT WILL BE OMITTED IF .CSAX
493: * IS UNDEFINED. IN THIS CASE SYSAX NEED NOT BE CODED.
494: *
495: * JSR SYSAX CALL AFTER EXECUTION
496: EJC
497: *
498: * SYSBX -- BEFORE EXECUTION
499: *
500: SYSBX EXP DEFINE EXTERNAL ENTRY POINT
501: *
502: * CALLED AFTER INITIAL SPITBOL COMPILATION AND BEFORE
503: * COMMENCING EXECUTION IN CASE OSINT NEEDS
504: * TO ASSIGN FILES OR PERFORM OTHER NECESSARY SERVICES.
505: * OSINT MAY ALSO CHOOSE TO SEND A MESSAGE TO ONLINE
506: * TERMINAL (IF ANY) INDICATING THAT EXECUTION IS STARTING.
507: *
508: * JSR SYSBX CALL BEFORE EXECUTION STARTS
509: EJC
510: *
511: * SYSDC -- DATE CHECK
512: *
513: SYSDC EXP DEFINE EXTERNAL ENTRY POINT
514: *
515: * SYSDC IS CALLED TO CHECK THAT THE EXPIRY DATE FOR A TRIAL
516: * VERSION OF SPITBOL IS UNEXPIRED.
517: *
518: * JSR SYSDC CALL TO CHECK DATE
519: * RETURN ONLY IF DATE IS OK
520: EJC
521: *
522: * SYSDM -- DUMP CORE
523: *
524: SYSDM EXP DEFINE EXTERNAL ENTRY POINT
525: *
526: * SYSDM IS CALLED BY A SPITBOL PROGRAM CALL OF DUMP(N) WITH
527: * N GE 3. ITS PURPOSE IS TO PROVIDE A CORE DUMP.
528: * N COULD HOLD AN ENCODING OF THE START ADRS FOR DUMP AND
529: * AMOUNT TO BE DUMPED E.G. N = 256*A + S , S = START ADRS
530: * IN KILOWORDS, A = KILOWORDS TO DUMP
531: *
532: * (XR) PARAMETER N OF CALL DUMP(N)
533: * JSR SYSDM CALL TO ENTER ROUTINE
534: EJC
535: *
536: * SYSDT -- GET CURRENT DATE
537: *
538: SYSDT EXP DEFINE EXTERNAL ENTRY POINT
539: *
540: * SYSDT IS USED TO OBTAIN THE CURRENT DATE. THE DATE IS
541: * RETURNED AS A CHARACTER STRING IN ANY FORMAT APPROPRIATE
542: * TO THE OPERATING SYSTEM IN USE. IT MAY ALSO CONTAIN THE
543: * CURRENT TIME OF DAY. SYSDT IS USED TO IMPLEMENT THE
544: * SNOBOL4 FUNCTION DATE.
545: *
546: * JSR SYSDT CALL TO GET DATE
547: * (XL) POINTER TO BLOCK CONTAINING DATE
548: *
549: * THE FORMAT OF THE BLOCK IS LIKE AN SCBLK EXCEPT THAT
550: * THE FIRST WORD NEED NOT BE SET. THE RESULT IS COPIED
551: * INTO SPITBOL DYNAMIC MEMORY ON RETURN.
552: EJC
553: *
554: * SYSEF -- EJECT FILE
555: *
556: SYSEF EXP DEFINE EXTERNAL ENTRY POINT
557: *
558: * SYSEF IS USED TO WRITE A PAGE EJECT TO A NAMED FILE. IT
559: * MAY ONLY BE USED FOR FILES WHERE THIS CONCEPT MAKES
560: * SENSE. NOTE THAT SYSEF IS NOT NORMALLY USED FOR THE
561: * STANDARD OUTPUT FILE (SEE SYSEP).
562: *
563: * (WA) PTR TO FCBLK OR ZERO
564: * (XR) EJECT ARGUMENT (SCBLK PTR)
565: * JSR SYSEF CALL TO EJECT FILE
566: * PPM LOC RETURN HERE IF FILE DOES NOT EXIST
567: * PPM LOC RETURN HERE IF INAPPROPRIATE FILE
568: * PPM LOC RETURN HERE IF I/O ERROR
569: EJC
570: *
571: * SYSEJ -- END OF JOB
572: *
573: SYSEJ EXP DEFINE EXTERNAL ENTRY POINT
574: *
575: * SYSEJ IS CALLED ONCE AT THE END OF EXECUTION TO
576: * TERMINATE THE RUN. THE SIGNIFICANCE OF THE ABEND AND
577: * CODE VALUES IS SYSTEM DEPENDENT. IN GENERAL, THE CODE
578: * VALUE SHOULD BE MADE AVAILABLE FOR TESTING, AND THE
579: * ABEND VALUE SHOULD CAUSE SOME POST-MORTEM ACTION SUCH AS
580: * A DUMP. NOTE THAT SYSEJ DOES NOT RETURN TO ITS CALLER.
581: * SEE SYSXI FOR DETAILS OF FCBLK CHAIN
582: *
583: * (WA) VALUE OF ABEND KEYWORD
584: * (WB) VALUE OF CODE KEYWORD
585: * (XL) O OR PTR TO HEAD OF FCBLK CHAIN
586: * JSR SYSEJ CALL TO END JOB
587: *
588: * THE FOLLOWING SPECIAL VALUES ARE USED AS CODES IN (WB)
589: * 999 EXECUTION SUPPRESSED
590: * 998 STANDARD OUTPUT FILE FULL OR UNAVAILABLE IN A SYSXI
591: * LOAD MODULE. IN THESE CASES (WA) CONTAINS THE NUMBER
592: * OF THE STATEMENT CAUSING PREMATURE TERMINATION.
593: EJC
594: *
595: * SYSEM -- GET ERROR MESSAGE TEXT
596: *
597: SYSEM EXP DEFINE EXTERNAL ENTRY POINT
598: *
599: * SYSEM IS USED TO OBTAIN THE TEXT OF ERR, ERB CALLS IN THE
600: * SOURCE PROGRAM GIVEN THE ERROR CODE NUMBER. IT IS ALLOWED
601: * TO RETURN A NULL STRING IF THIS FACILITY IS UNAVAILABLE.
602: *
603: * (WA) ERROR CODE NUMBER
604: * JSR SYSEM CALL TO GET TEXT
605: * (XR) TEXT OF MESSAGE
606: *
607: * THE RETURNED VALUE IS A POINTER TO A BLOCK IN SCBLK
608: * FORMAT EXCEPT THAT THE FIRST WORD NEED NOT BE SET. THE
609: * STRING IS COPIED INTO DYNAMIC MEMORY ON RETURN.
610: * IF THE NULL STRING IS RETURNED EITHER BECAUSE SYSEM DOES
611: * NOT PROVIDE ERROR MESSAGE TEXTS OR BECAUSE WA IS OUT OF
612: * RANGE, SPITBOL WILL PRINT THE STRING STORED IN ERRTEXT
613: * KEYWORD.
614: EJC
615: *
616: * SYSEN -- ENDFILE
617: *
618: SYSEN EXP DEFINE EXTERNAL ENTRY POINT
619: *
620: * SYSEN IS USED TO IMPLEMENT THE SNOBOL4 FUNCTION ENDFILE.
621: * THE MEANING IS SYSTEM DEPENDENT. IN GENERAL, ENDFILE
622: * IMPLIES THAT NO FURTHER I/O OPERATIONS WILL BE PERFORMED,
623: * BUT DOES NOT GUARANTEE THIS TO BE THE CASE. THE FILE
624: * SHOULD BE CLOSED AFTER THE CALL, A SUBSEQUENT READ
625: * OR WRITE MAY REOPEN THE FILE AT THE START OR IT MAY BE
626: * NECESSARY TO REOPEN THE FILE VIA SYSIO.
627: *
628: * (WA) PTR TO FCBLK OR ZERO
629: * (XR) ENDFILE ARGUMENT (SCBLK PTR)
630: * JSR SYSEN CALL TO ENDFILE
631: * PPM LOC RETURN HERE IF FILE DOES NOT EXIST
632: * PPM LOC RETURN HERE IF ENDFILE NOT ALLOWED
633: * PPM LOC RETURN HERE IF I/O ERROR
634: * (WA,WB) DESTROYED
635: *
636: * THE SECOND ERROR RETURN IS USED FOR FILES FOR WHICH
637: * ENDFILE IS NOT PERMITTED. FOR EXAMPLE, IT MAY BE EXPECTED
638: * THAT THE STANDARD INPUT AND OUTPUT FILES ARE IN THIS
639: * CATEGORY.
640: EJC
641: *
642: * SYSEP -- EJECT PRINTER PAGE
643: *
644: SYSEP EXP DEFINE EXTERNAL ENTRY POINT
645: *
646: * SYSEP IS CALLED TO PERFORM A PAGE EJECT ON THE STANDARD
647: * PRINTER OUTPUT FILE (CORRESPONDING TO SYSPR OUTPUT).
648: *
649: * JSR SYSEP CALL TO EJECT PRINTER OUTPUT
650: EJC
651: *
652: * SYSEX -- CALL EXTERNAL FUNCTION
653: *
654: SYSEX EXP DEFINE EXTERNAL ENTRY POINT
655: *
656: * SYSEX IS CALLED TO PASS CONTROL TO AN EXTERNAL FUNCTION
657: * PREVIOUSLY LOADED WITH A CALL TO SYSLD.
658: *
659: * (XS) POINTER TO ARGUMENTS ON STACK
660: * (XL) POINTER TO CONTROL BLOCK (EFBLK)
661: * (WA) NUMBER OF ARGUMENTS ON STACK
662: * JSR SYSEX CALL TO PASS CONTROL TO FUNCTION
663: * PPM LOC RETURN HERE IF FUNCTION CALL FAILS
664: * (XS) POPPED PAST ARGUMENTS
665: * (XR) RESULT RETURNED
666: *
667: * THE ARGUMENTS ARE STORED ON THE STACK WITH
668: * THE LAST ARGUMENT AT 0(XS). ON RETURN, XS
669: * IS POPPED PAST THE ARGUMENTS.
670: *
671: * THE FORM OF THE ARGUMENTS AS PASSED IS THAT USED IN THE
672: * SPITBOL TRANSLATOR (SEE DEFINITIONS AND DATA STRUCTURES
673: * SECTION). THE CONTROL BLOCK FORMAT IS ALSO DESCRIBED
674: * (UNDER EFBLK) IN THIS SECTION.
675: *
676: * THERE ARE TWO WAYS OF RETURNING A RESULT.
677: *
678: * 1) RETURN A POINTER TO A BLOCK IN DYNAMIC STORAGE. THIS
679: * BLOCK MUST BE IN EXACTLY CORRECT FORMAT, INCLUDING
680: * THE FIRST WORD. ONLY FUNCTIONS WRITTEN WITH INTIMATE
681: * KNOWLEDGE OF THE SYSTEM WILL RETURN IN THIS WAY.
682: *
683: * 2) STRING, INTEGER AND REAL RESULTS MAY BE RETURNED BY
684: * POINTING TO A PSEUDO-BLOCK OUTSIDE DYNAMIC MEMORY.
685: * THIS BLOCK IS IN ICBLK, RCBLK OR SCBLK FORMAT EXCEPT
686: * THAT THE FIRST WORD WILL BE OVERWRITTEN
687: * BY A TYPE WORD ON RETURN AND SO NEED NOT
688: * BE CORRECTLY SET. SUCH A RESULT IS
689: * COPIED INTO MAIN STORAGE BEFORE PROCEEDING.
690: * UNCONVERTED RESULTS MAY SIMILARLY BE RETURNED IN A
691: * PSEUDO-BLOCK WHICH IS IN CORRECT FORMAT INCLUDING
692: * TYPE WORD RECOGNISABLE BY GARBAGE COLLECTOR SINCE
693: * BLOCK IS COPIED INTO DYNAMIC MEMORY.
694: EJC
695: *
696: * SYSFC -- FILE CONTROL BLOCK ROUTINE
697: *
698: SYSFC EXP DEFINE EXTERNAL ENTRY POINT
699: *
700: * SEE ALSO SYSIO
701: * INPUT AND OUTPUT HAVE 3 ARGUMENTS REFERRED TO AS SHOWN
702: * INPUT(VARIABLE NAME,FILE ARG1,FILE ARG2)
703: * OUTPUT(VARIABLE NAME,FILE ARG1,FILE ARG2)
704: * FILE ARG1 MAY BE AN INTEGER OR STRING USED TO IDENTIFY
705: * AN I/O CHANNEL. IT IS CONVERTED TO A STRING FOR CHECKING.
706: * THE EXACT SIGNIFICANCE OF FILE ARG2
707: * IS NOT RIGOROUSLY PRESCRIBED BUT TO IMPROVE PORTABILITY,
708: * THE SCHEME DESCRIBED IN THE SPITBOL USER MANUAL
709: * SHOULD BE ADOPTED WHEN POSSIBLE. THE PREFERRED FORM IS
710: * A STRING $F$,R$R$,C$C$,I$I$,...,Z$Z$ WHERE
711: * $F$ IS AN OPTIONAL FILE NAME WHICH IS PLACED FIRST.
712: * REMAINING ITEMS MAY BE OMITTED OR INCLUDED IN ANY ORDER.
713: * $R$ IS MAXIMUM RECORD LENGTH
714: * $C$ IS A CARRIAGE CONTROL CHARACTER OR CHARACTER STRING
715: * $I$ IS SOME FORM OF CHANNEL IDENTIFICATION USED IN THE
716: * ABSENCE OF $F$ TO ASSOCIATE THE VARIABLE
717: * WITH A FILE ALLOCATED DYNAMICALLY BY JCL COMMANDS AT
718: * SPITBOL LOAD TIME.
719: * ,...,Z$Z$ ARE ADDITIONAL FIELDS.
720: * IF , (COMMA) CANNOT BE USED AS A DELIMITER, .CIOD
721: * SHOULD BE DEFINED TO INTRODUCE BY CONDITIONAL ASSEMBLY
722: * ANOTHER DELIMITER (SEE
723: * IODEL EQU *
724: * EARLY IN DEFINITIONS SECTION).
725: * SYSFC IS CALLED WHEN A VARIABLE IS INPUT OR OUTPUT
726: * ASSOCIATED TO CHECK FILE ARG1 AND FILE ARG2 AND
727: * TO REPORT WHETHER AN FCBLK (FILE CONTROL
728: * BLOCK) IS NECESSARY AND IF SO WHAT SIZE IT SHOULD BE.
729: * THIS MAKES IT POSSIBLE FOR SPITBOL RATHER THAN OSINT TO
730: * ALLOCATE SUCH A BLOCK IN DYNAMIC MEMORY IF REQUIRED
731: * OR ALTERNATIVELY IN STATIC MEMORY.
732: * THE SIGNIFICANCE OF AN FCBLK , IF ONE IS REQUESTED, IS
733: * ENTIRELY UP TO THE SYSTEM INTERFACE. THE ONLY RESTRICTION
734: * IS THAT IF THE FCBLK SHOULD APPEAR TO LIE IN DYNAMIC
735: * MEMORY , POINTERS TO IT SHOULD BE PROPER POINTERS TO
736: * THE START OF A RECOGNISABLE AND GARBAGE COLLECTABLE
737: * BLOCK (THIS CONDITION WILL BE MET IF SYSFC REQUESTS
738: * SPITBOL TO PROVIDE AN FCBLK).
739: * AN OPTION IS PROVIDED FOR OSINT TO RETURN A POINTER IN
740: * XL TO AN FCBLK WHICH IT PRIVATELY ALLOCATED. THIS PTR
741: * WILL BE MADE AVAILABLE WHEN I/O OCCURS LATER.
742: * PRIVATE FCBLKS MAY HAVE ARBITRARY CONTENTS AND SPITBOL
743: * STORES NOTHING IN THEM.
744: EJC
745: * THE REQUESTED SIZE FOR AN FCBLK IN DYNAMIC MEMORY
746: * SHOULD ALLOW A 2 WORD OVERHEAD FOR BLOCK TYPE AND
747: * LENGTH FIELDS. INFORMATION SUBSEQUENTLY STORED IN THE
748: * REMAINING WORDS MAY BE ARBITRARY IF AN XNBLK (EXTERNAL
749: * NON-RELOCATABLE BLOCK) IS REQUESTED. IF THE REQUEST IS
750: * FOR AN XRBLK (EXTERNAL RELOCATABLE BLOCK) THE
751: * CONTENTS OF WORDS SHOULD BE COLLECTABLE (I.E. ANY
752: * APPARENT POINTERS INTO DYNAMIC SHOULD BE GENUINE BLOCK
753: * POINTERS). THESE RESTRICTIONS DO NOT APPLY IF AN FCBLK
754: * IS ALLOCATED OUTSIDE DYNAMIC OR IS NOT ALLOCATED AT ALL.
755: * IF AN FCBLK IS REQUESTED, ITS FIELDS WILL BE INITIALISED
756: * TO ZERO BEFORE ENTRY TO SYSIO WITH THE EXCEPTION OF
757: * WORDS 0 AND 1 IN WHICH THE BLOCK TYPE AND LENGTH
758: * FIELDS ARE PLACED FOR FCBLKS IN DYNAMIC MEMORY ONLY.
759: * FOR THE POSSIBLE USE OF SYSEJ AND SYSXI, IF FCBLKS
760: * ARE USED, A CHAIN IS BUILT SO THAT THEY MAY ALL BE
761: * FOUND - SEE SYSXI FOR DETAILS.
762: * IF BOTH FILE ARG1 AND FILE ARG2 ARE NULL, CALLS OF SYSFC
763: * AND SYSIO ARE OMITTED.
764: * IF FILE ARG1 IS NULL (STANDARD INPUT/OUTPUT FILE), SYSFC
765: * IS CALLED TO CHECK NON-NULL FILE ARG2 BUT ANY REQUEST
766: * FOR AN FCBLK WILL BE IGNORED, SINCE SPITBOL HANDLES THE
767: * STANDARD FILES SPECIALLY AND CANNOT READILY KEEP FCBLK
768: * POINTERS FOR THEM.
769: * FILEARG1 IS TYPE CHECKED BY SPITBOL SO FURTHER CHECKING
770: * MAY BE UNNECCESSARY IN MANY IMPLEMENTATIONS.
771: * FILE ARG2 IS PASSED SO THAT SYSFC MAY ANALYSE AND
772: * CHECK IT. HOWEVER TO ASSIST IN THIS, SPITBOL ALSO PASSES
773: * ON THE STACK THE COMPONENTS OF THIS ARGUMENT WITH
774: * FILE NAME, $F$ (OTHERWISE NULL) EXTRACTED AND STACKED
775: * FIRST.
776: * THE OTHER FIELDS, IF ANY, ARE EXTRACTED AS SUBSTRINGS,
777: * POINTERS TO THEM ARE STACKED AND A COUNT OF ALL ITEMS
778: * STACKED IS PLACED IN WC. IF AN FCBLK WAS EARLIER
779: * ALLOCATED AND POINTED TO VIA FILE ARG1, SYSFC IS ALSO
780: * PASSED A POINTER TO THIS FCBLK.
781: *
782: * (XL) FILE ARG1 SCBLK PTR (2ND ARG)
783: * (XR) FILEARG2 (3RD ARG) OR NULL
784: * -(XS)...-(XS) SCBLKS FOR $F$,$R$,$C$,...
785: * (WC) NO. OF STACKED SCBLKS ABOVE
786: * (WA) EXISTING FILE ARG1 FCBLK PTR OR 0
787: * (WB) 0/3 FOR INPUT/OUTPUT ASSOCN
788: * JSR SYSFC CALL TO CHECK NEED FOR FCBLK
789: * PPM LOC INVALID FILE ARGUMENT
790: * (XS) POPPED (WC) TIMES
791: * (WA NON ZERO) BYTE SIZE OF REQUESTED FCBLK
792: * (WA=0,XL NON ZERO) PRIVATE FCBLK PTR IN XL
793: * (WA=XL=0) NO FCBLK WANTED, NO PRIVATE FCBLK
794: * (WC) 0/1/2 REQUEST ALLOC OF XRBLK/XNBLK
795: * /STATIC BLOCK FOR USE AS FCBLK
796: * (WB) DESTROYED
797: EJC
798: *
799: * SYSHS -- GIVE ACCESS TO HOST COMPUTER FEATURES
800: *
801: SYSHS EXP DEFINE EXTERNAL ENTRY POINT
802: *
803: * PROVIDES MEANS FOR IMPLEMENTING SPECIAL FEATURES
804: * ON DIFFERENT HOST COMPUTERS. THE ONLY DEFINED ENTRY IS
805: * THAT WHERE ALL ARGUMENTS ARE NULL IN WHICH CASE SYSHS
806: * RETURNS AN SCBLK CONTAINING NAME OF COMPUTER,
807: * NAME OF OPERATING SYSTEM AND NAME OF SITE SEPARATED BY
808: * COLONS. THE SCBLK NEED NOT HAVE A CORRECT FIRST FIELD
809: * AS THIS IS SUPPLIED ON COPYING STRING TO DYNAMIC MEMORY.
810: * SPITBOL DOES NO ARGUMENT CHECKING BUT DOES PROVIDE A
811: * SINGLE ERROR RETURN FOR ARGUMENTS CHECKED AS ERRONEOUS
812: * BY OSINT. IT ALSO PROVIDES A SINGLE EXECUTION ERROR
813: * RETURN. IF THESE ARE INADEQUATE, USE MAY BE MADE OF THE
814: * MINIMAL ERROR SECTION DIRECT AS DESCRIBED IN MINIMAL
815: * DOCUMENTATION, SECTION 10.
816: * SEVERAL NON-ERROR RETURNS ARE PROVIDED. THE FIRST
817: * CORRESPONDS TO THE DEFINED ENTRY OR, FOR IMPLEMENTATION
818: * DEFINED ENTRIES, ANY STRING MAY BE RETURNED. THE OTHERS
819: * PERMIT RESPECTIVELY, RETURN A NULL RESULT, RETURN WITH A
820: * RESULT TO BE STACKED WHICH IS POINTED AT BY XR, AND A
821: * RETURN CAUSING SPITBOL STATEMENT FAILURE. IF A RETURNED
822: * RESULT IS IN DYNAMIC MEMORY IT MUST OBEY GARBAGE
823: * COLLECTOR RULES. THE ONLY RESULTS COPIED ON RETURN
824: * ARE STRINGS RETURNED VIA PPM LOC3 RETURN.
825: *
826: * (WA) ARGUMENT 1
827: * (XL) ARGUMENT 2
828: * (XR) ARGUMENT 3
829: * JSR SYSHS CALL TO GET HOST INFORMATION
830: * PPM LOC1 ERRONEOUS ARG
831: * PPM LOC2 EXECUTION ERROR
832: * PPM LOC3 SCBLK PTR IN XL OR 0 IF UNAVAILABLE
833: * PPM LOC4 RETURN A NULL RESULT
834: * PPM LOC5 RETURN RESULT IN XR
835: * PPM LOC6 CAUSE STATEMENT FAILURE
836: EJC
837: *
838: * SYSID -- RETURN SYSTEM IDENTIFICATION
839: *
840: SYSID EXP DEFINE EXTERNAL ENTRY POINT
841: *
842: * THIS ROUTINE SHOULD RETURN STRINGS TO HEAD THE STANDARD
843: * PRINTER OUTPUT. THE FIRST STRING WILL BE APPENDED TO
844: * A HEADING LINE OF THE FORM
845: * MACRO SPITBOL VERSION V.V
846: * SUPPLIED BY SPITBOL ITSELF. V.V ARE DIGITS GIVING THE
847: * MAJOR VERSION NUMBER AND GENERALLY AT LEAST A MINOR
848: * VERSION NUMBER RELATING TO OSINT SHOULD BE SUPPLIED TO
849: * GIVE SAY
850: * MACRO SPITBOL VERSION V.V(M.M)
851: * THE SECOND STRING SHOULD IDENTIFY AT LEAST THE MACHINE
852: * AND OPERATING SYSTEM. PREFERABLY IT SHOULD INCLUDE
853: * THE DATE AND TIME OF THE RUN.
854: * OPTIONALLY THE STRINGS MAY INCLUDE SITE NAME OF THE
855: * THE IMPLEMENTOR AND/OR MACHINE ON WHICH RUN TAKES PLACE,
856: * UNIQUE SITE OR COPY NUMBER AND OTHER INFORMATION AS
857: * APPROPRIATE WITHOUT MAKING IT SO LONG AS TO BE A
858: * NUISANCE TO USERS.
859: * THE FIRST WORDS OF THE SCBLKS POINTED AT NEED NOT BE
860: * CORRECTLY SET.
861: *
862: * JSR SYSID CALL FOR SYSTEM IDENTIFICATION
863: * (XR) SCBLK PTR FOR ADDITION TO HEADER
864: * (XL) PTR TO SECOND HEADER SCBLK
865: EJC
866: *
867: * SYSIL -- GET INPUT RECORD LENGTH
868: *
869: SYSIL EXP DEFINE EXTERNAL ENTRY POINT
870: *
871: * SYSIL IS USED TO GET THE LENGTH OF THE NEXT INPUT RECORD
872: * FROM A FILE PREVIOUSLY INPUT ASSOCIATED WITH A SYSIO
873: * CALL. THE LENGTH RETURNED IS USED TO ESTABLISH A BUFFER
874: * FOR A SUBSEQUENT SYSIN CALL.
875: *
876: * (WA) PTR TO FCBLK OR ZERO
877: * JSR SYSIL CALL TO GET RECORD LENGTH
878: * (WA) LENGTH OR ZERO IF FILE CLOSED
879: *
880: * NO HARM IS DONE IF THE VALUE RETURNED IS TOO LONG SINCE
881: * UNUSED SPACE WILL BE RECLAIMED AFTER THE SYSIN CALL.
882: *
883: * NOTE THAT IT IS THE SYSIL CALL (NOT THE SYSIO CALL) WHICH
884: * CAUSES THE FILE TO BE OPENED AS REQUIRED FOR THE FIRST
885: * RECORD INPUT FROM THE FILE.
886: EJC
887: *
888: * SYSIN -- READ INPUT RECORD
889: *
890: SYSIN EXP DEFINE EXTERNAL ENTRY POINT
891: *
892: * SYSIN IS USED TO READ A RECORD FROM THE FILE WHICH WAS
893: * REFERENCED IN A PRIOR CALL TO SYSIL (I.E. THESE CALLS
894: * ALWAYS OCCUR IN PAIRS). THE BUFFER PROVIDED IS AN
895: * SCBLK FOR A STRING OF LENGTH SET FROM THE SYSIL CALL.
896: * IF THE ACTUAL LENGTH READ IS LESS THAN THIS, THE LENGTH
897: * FIELD OF THE SCBLK MUST BE MODIFIED BEFORE RETURNING
898: * UNLESS BUFFER IS RIGHT PADDED WITH ZEROES.
899: * IT IS ALSO PERMISSIBLE TO TAKE ANY OF THE ALTERNATIVE
900: * RETURNS AFTER SCBLK LENGTH HAS BEEN MODIFIED.
901: *
902: * (WA) PTR TO FCBLK OR ZERO
903: * (XR) POINTER TO BUFFER (SCBLK PTR)
904: * JSR SYSIN CALL TO READ RECORD
905: * PPM LOC ENDFILE OR NO I/P FILE AFTER SYSXI
906: * PPM LOC RETURN HERE IF I/O ERROR
907: * PPM LOC RETURN HERE IF RECORD FORMAT ERROR
908: * (WA,WB,WC) DESTROYED
909: EJC
910: *
911: * SYSIO -- INPUT/OUTPUT FILE ASSOCIATION
912: *
913: SYSIO EXP DEFINE EXTERNAL ENTRY POINT
914: *
915: * SEE ALSO SYSFC.
916: * SYSIO IS CALLED IN RESPONSE TO A SNOBOL4 INPUT OR OUTPUT
917: * FUNCTION CALL EXCEPT WHEN FILE ARG1 AND FILE ARG2
918: * ARE BOTH NULL.
919: * ITS CALL ALWAYS FOLLOWS IMMEDIATELY AFTER A CALL
920: * OF SYSFC. IF SYSFC REQUESTED ALLOCATION
921: * OF AN FCBLK, ITS ADDRESS WILL BE IN WA.
922: * FOR INPUT FILES, NON-ZERO VALUES OF $R$ SHOULD BE
923: * COPIED TO WC FOR USE IN ALLOCATING INPUT BUFFERS. IF $R$
924: * IS DEFAULTED OR NOT IMPLEMENTED, WC SHOULD BE ZEROISED.
925: * ONCE A FILE HAS BEEN OPENED, SUBSEQUENT INPUT(),OUTPUT()
926: * CALLS IN WHICH THE SECOND ARGUMENT IS IDENTICAL WITH THAT
927: * IN A PREVIOUS CALL, MERELY ASSOCIATE THE ADDITIONAL
928: * VARIABLE NAME (FIRST ARGUMENT) TO THE FILE AND DO NOT
929: * RESULT IN RE-OPENING THE FILE.
930: * IN SUBSEQUENT ASSOCIATED ACCESSES TO THE FILE A POINTER
931: * TO ANY FCBLK ALLOCATED WILL BE MADE AVAILABLE.
932: *
933: * (XL) FILE ARG1 SCBLK PTR (2ND ARG)
934: * (XR) FILE ARG2 SCBLK PTR (3RD ARG)
935: * (WA) FCBLK PTR (0 IF NONE)
936: * (WB) 0 FOR INPUT, 3 FOR OUTPUT
937: * JSR SYSIO CALL TO ASSOCIATE FILE
938: * PPM LOC RETURN HERE IF FILE DOES NOT EXIST
939: * PPM LOC RETURN IF INPUT/OUTPUT NOT ALLOWED
940: * (XL) FCBLK POINTER (0 IF NONE)
941: * (WC) 0 (FOR DEFAULT) OR MAX RECORD LNGTH
942: * (WA,WB) DESTROYED
943: *
944: * THE SECOND ERROR RETURN IS USED IF THE FILE NAMED EXISTS
945: * BUT INPUT/OUTPUT FROM THE FILE IS NOT ALLOWED. FOR
946: * EXAMPLE, THE STANDARD OUTPUT FILE MAY BE IN THIS CATEGORY
947: * AS REGARDS INPUT ASSOCIATION.
948: EJC
949: *
950: * SYSLD -- LOAD EXTERNAL FUNCTION
951: *
952: SYSLD EXP DEFINE EXTERNAL ENTRY POINT
953: *
954: * SYSLD IS CALLED IN RESPONSE TO THE USE OF THE SNOBOL4
955: * LOAD FUNCTION. THE NAMED FUNCTION IS LOADED (WHATEVER
956: * THIS MEANS), AND A POINTER IS RETURNED. THE POINTER WILL
957: * BE USED ON SUBSEQUENT CALLS TO THE FUNCTION (SEE SYSEX).
958: *
959: * (XR) POINTER TO FUNCTION NAME (SCBLK)
960: * (XL) POINTER TO LIBRARY NAME (SCBLK)
961: * JSR SYSLD CALL TO LOAD FUNCTION
962: * PPM LOC RETURN HERE IF FUNC DOES NOT EXIST
963: * PPM LOC RETURN HERE IF I/O ERROR
964: * (XR) POINTER TO LOADED CODE
965: *
966: * THE SIGNIFICANCE OF THE POINTER RETURNED IS UP TO THE
967: * SYSTEM INTERFACE ROUTINE. THE ONLY RESTRICTION IS THAT
968: * IF THE POINTER IS WITHIN DYNAMIC STORAGE, IT MUST BE
969: * A PROPER BLOCK POINTER.
970: EJC
971: *
972: * SYSMM -- GET MORE MEMORY
973: *
974: SYSMM EXP DEFINE EXTERNAL ENTRY POINT
975: *
976: * SYSMM IS CALLED IN AN ATTEMPT TO ALLOCATE MORE DYNAMIC
977: * MEMORY. THIS MEMORY MUST BE ALLOCATED CONTIGUOUSLY WITH
978: * THE CURRENT DYNAMIC DATA AREA.
979: *
980: * THE AMOUNT ALLOCATED IS UP TO THE SYSTEM TO DECIDE. ANY
981: * VALUE IS ACCEPTABLE INCLUDING ZERO IF ALLOCATION IS
982: * IMPOSSIBLE.
983: *
984: * JSR SYSMM CALL TO GET MORE MEMORY
985: * (XR) NUMBER OF ADDITIONAL WORDS OBTAINED
986: EJC
987: *
988: * SYSMX -- SUPPLY MXLEN
989: *
990: SYSMX EXP DEFINE EXTERNAL ENTRY POINT
991: *
992: * BECAUSE OF THE METHOD OF GARBAGE COLLECTION, NO SPITBOL
993: * OBJECT IS ALLOWED TO OCCUPY MORE BYTES OF MEMORY THAN
994: * THE INTEGER GIVING THE LOWEST ADDRESS OF DYNAMIC
995: * (GARBAGE COLLECTABLE) MEMORY. MXLEN IS THE NAME USED TO
996: * REFER TO THIS MAXIMUM LENGTH OF AN OBJECT AND FOR MOST
997: * USERS OF MOST IMPLEMENTATIONS, PROVIDED DYNAMIC MEMORY
998: * STARTS AT AN ADDRESS OF AT LEAST A FEW THOUSAND WORDS,
999: * THERE IS NO PROBLEM.
1000: * IF THE DEFAULT STARTING ADDRESS IS LESS THAN SAY 10000 OR
1001: * 20000, THEN A LOAD TIME OPTION SHOULD BE PROVIDED WHERE A
1002: * USER CAN REQUEST THAT HE BE ABLE TO CREATE LARGER
1003: * OBJECTS. THIS ROUTINE INFORMS SPITBOL OF THIS REQUEST IF
1004: * ANY. THE VALUE RETURNED IS EITHER AN INTEGER
1005: * REPRESENTING THE DESIRED VALUE OF MXLEN (AND HENCE THE
1006: * MINIMUM DYNAMIC STORE ADDRESS WHICH MAY RESULT IN
1007: * NON-USE OF SOME STORE) OR ZERO IF A DEFAULT IS ACCEPTABLE
1008: * IN WHICH MXLEN IS SET TO THE LOWEST ADDRESS ALLOCATED
1009: * TO DYNAMIC STORE BEFORE COMPILATION STARTS.
1010: * IF A NON-ZERO VALUE IS RETURNED, THIS IS USED FOR KEYWORD
1011: * MAXLNGTH. OTHERWISE THE INITIAL LOW ADDRESS OF DYNAMIC
1012: * MEMORY IS USED FOR THIS KEYWORD.
1013: *
1014: * JSR SYSMX CALL TO GET MXLEN
1015: * (WA) EITHER MXLEN OR 0 FOR DEFAULT
1016: EJC
1017: *
1018: * SYSOU -- OUTPUT RECORD
1019: *
1020: SYSOU EXP DEFINE EXTERNAL ENTRY POINT
1021: *
1022: * SYSOU IS USED TO WRITE A RECORD TO A FILE PREVIOUSLY
1023: * ASSOCIATED WITH A SYSIO CALL.
1024: *
1025: * (WA) PTR TO FCBLK OR ZERO
1026: * (XR) RECORD TO BE WRITTEN (SCBLK)
1027: * JSR SYSOU CALL TO OUTPUT RECORD
1028: * PPM LOC FILE FULL OR NO FILE AFTER SYSXI
1029: * PPM LOC RETURN HERE IF I/O ERROR
1030: * (WA,WB,WC) DESTROYED
1031: *
1032: * NOTE THAT IT IS THE SYSOU CALL (NOT THE SYSIO CALL) WHICH
1033: * CAUSES THE FILE TO BE OPENED AS REQUIRED FOR THE FIRST
1034: * RECORD OUTPUT TO THE FILE.
1035: EJC
1036: *
1037: * SYSPI -- PRINT ON INTERACTIVE CHANNEL
1038: *
1039: SYSPI EXP DEFINE EXTERNAL ENTRY POINT
1040: *
1041: * IF SPITBOL IS RUN FROM AN ONLINE TERMINAL, OSINT CAN
1042: * REQUEST THAT MESSAGES SUCH AS COPIES OF COMPILATION
1043: * ERRORS BE SENT TO THE TERMINAL (SEE SYSPP). IF RELEVANT
1044: * REPLY WAS MADE BY SYSPP THEN SYSPI IS CALLED TO SEND SUCH
1045: * MESSAGES TO THE INTERACTIVE CHANNEL.
1046: * SYSPI IS ALSO USED FOR SENDING OUTPUT TO THE TERMINAL
1047: * THROUGH THE SPECIAL VARIABLE NAME, TERMINAL.
1048: *
1049: * (XR) PTR TO LINE BUFFER (SCBLK)
1050: * (WA) LINE LENGTH
1051: * JSR SYSPI CALL TO PRINT LINE
1052: * PPM LOC FAILURE RETURN
1053: * (WA,WB) DESTROYED
1054: EJC
1055: *
1056: * SYSPP -- OBTAIN PRINT PARAMETERS
1057: *
1058: SYSPP EXP DEFINE EXTERNAL ENTRY POINT
1059: *
1060: * SYSPP IS CALLED ONCE DURING COMPILATION TO OBTAIN
1061: * PARAMETERS REQUIRED FOR CORRECT PRINTED OUTPUT FORMAT
1062: * AND TO SELECT OTHER OPTIONS. IT MAY ALSO BE CALLED AGAIN
1063: * AFTER SYSXI WHEN A LOAD MODULE IS RESUMED. IN THIS
1064: * CASE THE VALUE RETURNED IN WA MAY BE LESS THAN OR EQUAL
1065: * TO THAT RETURNED IN INITIAL CALL BUT MAY NOT BE
1066: * GREATER.
1067: * THE INFORMATION RETURNED IS -
1068: * 1. LINE LENGTH IN CHARS FOR STANDARD PRINT FILE
1069: * 2. NO OF LINES/PAGE. 0 IS PREFERABLE FOR A NON-PAGED
1070: * DEVICE (E.G. ONLINE TERMINAL) IN WHICH CASE LISTING
1071: * PAGE THROWS ARE SUPPRESSED AND PAGE HEADERS
1072: * RESULTING FROM -TITLE,-STITL LINES ARE KEPT SHORT.
1073: * 3. AN INITIAL -NOLIST OPTION TO SUPPRESS LISTING UNLESS
1074: * THE PROGRAM CONTAINS AN EXPLICIT -LIST.
1075: * 4. OPTIONS TO SUPPRESS LISTING OF COMPILATION AND/OR
1076: * EXECUTION STATS (USEFUL FOR ESTABLISHED PROGRAMS) -
1077: * COMBINED WITH 3. GIVES POSSIBILITY OF LISTING
1078: * FILE NEVER BEING OPENED.
1079: * 5. OPTION TO HAVE COPIES OF ERRORS SENT TO AN
1080: * INTERACTIVE CHANNEL IN ADDITION TO STANDARD PRINTER.
1081: * 6. OPTION TO KEEP PAGE HEADERS SHORT (E.G. IF LISTING
1082: * TO AN ONLINE TERMINAL).
1083: * 7. AN OPTION TO CHOOSE EXTENDED OR COMPACT LISTING
1084: * FORMAT. IN THE FORMER A PAGE EJECT AND IN THE LATTER
1085: * A FEW LINE FEEDS PRECEDE THE PRINTING OF EACH
1086: * OF-- LISTING, COMPILATION STATISTICS, EXECUTION
1087: * OUTPUT AND EXECUTION STATISTICS.
1088: * 8. AN OPTION TO SUPPRESS EXECUTION AS THOUGH A
1089: * -NOEXECUTE CARD WERE SUPPLIED.
1090: * 9. AN OPTION TO REQUEST THAT NAME /TERMINAL/ BE PRE-
1091: * ASSOCIATED TO AN ONLINE TERMINAL VIA SYSPI AND SYSRI
1092: * 10. AN INTERMEDIATE (STANDARD) LISTING OPTION REQUIRING
1093: * THAT PAGE EJECTS OCCUR IN SOURCE LISTINGS. REDUNDANT
1094: * IF EXTENDED OPTION CHOSEN BUT PARTIALLY EXTENDS
1095: * COMPACT OPTION.
1096: * 11. OPTION TO SUPPRESS SYSID IDENTIFICATION.
1097: *
1098: * JSR SYSPP CALL TO GET PRINT PARAMETERS
1099: * (WA) PRINT LINE LENGTH IN CHARS
1100: * (WB) NUMBER OF LINES/PAGE
1101: * (WC) BITS VALUE ...JIHGFEDCBA WHERE
1102: * A = 1 TO SEND ERROR COPY TO INT.CH.
1103: * B = 1 MEANS STD PRINTER IS INT. CH.
1104: * C = 1 FOR -NOLIST OPTION
1105: * D = 1 TO SUPPRESS COMPILN. STATS
1106: * E = 1 TO SUPPRESS EXECN. STATS
1107: * F = 1/0 FOR EXTNDED/COMPACT LISTING
1108: * G = 1 FOR -NOEXECUTE
1109: * H = 1 PRE-ASSOCIATE /TERMINAL/
1110: * I = 1 FOR STANDARD LISTING OPTION.
1111: * J = 1 SUPPRESSES LISTING HEADER
1112: EJC
1113: *
1114: * SYSPR -- PRINT LINE ON STANDARD OUTPUT FILE
1115: *
1116: SYSPR EXP DEFINE EXTERNAL ENTRY POINT
1117: *
1118: * SYSPR IS USED TO PRINT A SINGLE LINE ON THE STANDARD
1119: * OUTPUT FILE.
1120: *
1121: * (XR) POINTER TO LINE BUFFER (SCBLK)
1122: * (WA) LINE LENGTH
1123: * JSR SYSPR CALL TO PRINT LINE
1124: * PPM LOC TOO MUCH O/P OR NO FILE AFTER SYSXI
1125: * (WA,WB) DESTROYED
1126: *
1127: * THE BUFFER POINTED TO IS THE LENGTH OBTAINED FROM THE
1128: * SYSPP CALL AND IS FILLED OUT WITH TRAILING BLANKS. THE
1129: * VALUE IN WA IS THE ACTUAL LINE LENGTH WHICH MAY BE LESS
1130: * THAN THE MAXIMUM LINE LENGTH POSSIBLE. THERE IS NO SPACE
1131: * CONTROL ASSOCIATED WITH THE LINE, ALL LINES ARE PRINTED
1132: * SINGLE SPACED. NOTE THAT NULL LINES (WA=0) ARE POSSIBLE
1133: * IN WHICH CASE A BLANK LINE IS TO BE PRINTED.
1134: *
1135: * THE ERROR EXIT IS USED FOR SYSTEMS WHICH LIMIT THE AMOUNT
1136: * OF PRINTED OUTPUT. IF POSSIBLE, PRINTING SHOULD BE
1137: * PERMITTED AFTER THIS CONDITION HAS BEEN SIGNALLED ONCE TO
1138: * ALLOW FOR DUMP AND OTHER DIAGNOSTIC INFORMATION.
1139: * ASSUMING THIS TO BE POSSIBLE, SPITBOL MAY MAKE MORE SYSPR
1140: * CALLS. IF THE ERROR RETURN OCCURS ANOTHER TIME, EXECUTION
1141: * IS TERMINATED BY A CALL OF SYSEJ WITH ENDING CODE 998.
1142: EJC
1143: *
1144: * SYSRD -- READ RECORD FROM STANDARD INPUT FILE
1145: *
1146: SYSRD EXP DEFINE EXTERNAL ENTRY POINT
1147: *
1148: * SYSRD IS USED TO READ A RECORD FROM THE STANDARD INPUT
1149: * FILE. THE BUFFER PROVIDED IS AN SCBLK FOR A STRING THE
1150: * LENGTH OF WHICH IN CHARACTERS IS GIVEN IN WC, THIS
1151: * CORRESPONDING TO THE MAXIMUM LENGTH OF STRING WHICH
1152: * SPITBOL IS PREPARED TO RECEIVE. AT COMPILE TIME IT
1153: * CORRESPONDS TO XXX IN THE MOST RECENT -INXXX CARD
1154: * (DEFAULT 72) AND AT EXECUTION TIME TO THE MOST RECENT
1155: * ,R$R$ (RECORD LENGTH) IN THE THIRD ARG OF AN INPUT()
1156: * STATEMENT FOR THE STANDARD INPUT FILE (DEFAULT 80).
1157: * IF FEWER THAN (WC) CHARACTERS ARE READ, THE LENGTH
1158: * FIELD OF THE SCBLK MUST BE ADJUSTED BEFORE RETURNING
1159: * UNLESS THE BUFFER IS RIGHT PADDED WITH ZEROES.
1160: * IT IS ALSO PERMISSIBLE TO TAKE THE ALTERNATIVE RETURN
1161: * AFTER SUCH AN ADJUSTMENT HAS BEEN MADE.
1162: * SPITBOL MAY CONTINUE TO MAKE CALLS AFTER AN ENDFILE
1163: * RETURN SO THIS ROUTINE SHOULD BE PREPARED TO MAKE
1164: * REPEATED ENDFILE RETURNS.
1165: *
1166: * (XR) POINTER TO BUFFER (SCBLK PTR)
1167: * (WC) LENGTH OF BUFFER IN CHARACTERS
1168: * JSR SYSRD CALL TO READ LINE
1169: * PPM LOC ENDFILE OR NO I/P FILE AFTER SYSXI
1170: * (WA,WB,WC) DESTROYED
1171: EJC
1172: *
1173: * SYSRI -- READ RECORD FROM INTERACTIVE CHANNEL
1174: *
1175: SYSRI EXP DEFINE EXTERNAL ENTRY POINT
1176: *
1177: * READS A RECORD FROM ONLINE TERMINAL FOR SPITBOL VARIABLE,
1178: * TERMINAL. IF ONLINE TERMINAL IS UNAVAILABLE THEN CODE THE
1179: * ENDFILE RETURN ONLY.
1180: * THE BUFFER PROVIDED IS OF LENGTH 120 CHARACTERS. SYSRI
1181: * SHOULD REPLACE THE COUNT IN THE SECOND WORD OF THE SCBLK
1182: * BY THE ACTUAL CHARACTER COUNT UNLESS BUFFER IS RIGHT
1183: * PADDED WITH ZEROES.
1184: * IT IS ALSO PERMISSIBLE TO TAKE THE ALTERNATIVE
1185: * RETURN AFTER ADJUSTING THE COUNT.
1186: * THE END OF FILE RETURN MAY BE USED IF THIS MAKES
1187: * SENSE ON THE TARGET MACHINE (E.G. IF THERE IS AN
1188: * EOF CHARACTER.)
1189: *
1190: * (XR) PTR TO 120 CHAR BUFFER (SCBLK PTR)
1191: * JSR SYSRI CALL TO READ LINE FROM TERMINAL
1192: * PPM LOC END OF FILE RETURN
1193: * (WA,WB,WC) MAY BE DESTROYED
1194: EJC
1195: *
1196: * SYSRW -- REWIND FILE
1197: *
1198: SYSRW EXP DEFINE EXTERNAL ENTRY POINT
1199: *
1200: * SYSRW IS USED TO REWIND A FILE I.E. REPOSITION THE FILE
1201: * AT THE START BEFORE THE FIRST RECORD. THE FILE SHOULD BE
1202: * CLOSED AND THE NEXT READ OR WRITE CALL WILL OPEN THE
1203: * FILE AT THE START.
1204: *
1205: * (WA) PTR TO FCBLK OR ZERO
1206: * (XR) REWIND ARG (SCBLK PTR)
1207: * JSR SYSRW CALL TO REWIND FILE
1208: * PPM LOC RETURN HERE IF FILE DOES NOT EXIST
1209: * PPM LOC RETURN HERE IF REWIND NOT ALLOWED
1210: * PPM LOC RETURN HERE IF I/O ERROR
1211: EJC
1212: *
1213: * SYSST -- SET FILE POINTER
1214: *
1215: SYSST EXP DEFINE EXTERNAL ENTRY POINT
1216: *
1217: * SYSST IS CALLED TO CHANGE THE POSITION OF A FILE
1218: * POINTER. THIS IS ACCOMPLISHED IN A SYSTEM DEPENDENT
1219: * MANNER, AND THUS THE 2ND AND 3RD ARGUMENTS ARE PASSED
1220: * UNCONVERTED.
1221: *
1222: * (WA) FCBLK POINTER
1223: * (WB) 2ND ARGUMENT
1224: * (WC) 3RD ARGUMENT
1225: * JSR SYSST CALL TO SET FILE POINTER
1226: * PPM LOC RETURN HERE IF INVALID 2ND ARG
1227: * PPM LOC RETURN HERE IF INVALID 3RD ARG
1228: * PPM LOC RETURN HERE IF FILE DOES NOT EXIST
1229: * PPM LOC RETURN HERE IF SET NOT ALLOWED
1230: * PPM LOC RETURN HERE IF I/O ERROR
1231: *
1232: EJC
1233: *
1234: * SYSTM -- GET EXECUTION TIME SO FAR
1235: *
1236: SYSTM EXP DEFINE EXTERNAL ENTRY POINT
1237: *
1238: * SYSTM IS USED TO OBTAIN THE AMOUNT OF EXECUTION TIME
1239: * USED SO FAR SINCE SPITBOL WAS GIVEN CONTROL. THE UNITS
1240: * ARE DESCRIBED AS MILLISECONDS IN THE SPITBOL OUTPUT, BUT
1241: * THE EXACT MEANING IS SYSTEM DEPENDENT. WHERE APPROPRIATE,
1242: * THIS VALUE SHOULD RELATE TO PROCESSOR RATHER THAN CLOCK
1243: * TIMING VALUES.
1244: *
1245: * JSR SYSTM CALL TO GET TIMER VALUE
1246: * (IA) TIME SO FAR IN MILLISECONDS
1247: EJC
1248: *
1249: * SYSTT -- TRACE TOGGLE
1250: *
1251: SYSTT EXP DEFINE EXTERNAL ENTRY POINT
1252: *
1253: * CALLED BY SPITBOL FUNCTION TRACE() WITH NO ARGS TO
1254: * TOGGLE THE SYSTEM TRACE SWITCH. THIS PERMITS TRACING OF
1255: * LABELS IN SPITBOL CODE TO BE TURNED ON OR OFF.
1256: *
1257: * JSR SYSTT CALL TO TOGGLE TRACE SWITCH
1258: EJC
1259: *
1260: * SYSUL -- UNLOAD EXTERNAL FUNCTION
1261: *
1262: SYSUL EXP DEFINE EXTERNAL ENTRY POINT
1263: *
1264: * SYSUL IS USED TO UNLOAD A FUNCTION PREVIOUSLY
1265: * LOADED WITH A CALL TO SYSLD.
1266: *
1267: * (XR) PTR TO CONTROL BLOCK (EFBLK)
1268: * JSR SYSUL CALL TO UNLOAD FUNCTION
1269: *
1270: * THE FUNCTION CANNOT BE CALLED FOLLOWING A SYSUL CALL
1271: * UNTIL ANOTHER SYSLD CALL IS MADE FOR THE SAME FUNCTION.
1272: *
1273: * THE EFBLK CONTAINS THE FUNCTION CODE POINTER AND ALSO A
1274: * POINTER TO THE VRBLK CONTAINING THE FUNCTION NAME (SEE
1275: * DEFINITIONS AND DATA STRUCTURES SECTION).
1276: EJC
1277: *
1278: * SYSXI -- EXIT TO PRODUCE LOAD MODULE
1279: *
1280: SYSXI EXP DEFINE EXTERNAL ENTRY POINT
1281: *
1282: * WHEN SYSXI IS CALLED, XL CONTAINS EITHER A STRING POINTER
1283: * OR ZERO. IN THE FORMER CASE, THE STRING GIVES THE
1284: * CHARACTER NAME OF A PROGRAM. THE INTENTION IS THAT
1285: * SPITBOL EXECUTION SHOULD BE TERMINATED FORTHWITH AND
1286: * THE NAMED PROGRAM LOADED AND EXECUTED. THIS TYPE OF CHAIN
1287: * EXECUTION IS VERY SYSTEM DEPENDENT AND IMPLEMENTORS MAY
1288: * CHOOSE TO OMIT IT OR FIND IT IMPOSSIBLE TO PROVIDE.
1289: * IF (XL) IS ZERO,IA CONTAINS ONE OF THE FOLLOWING INTEGERS
1290: *
1291: * -1, -2, -3
1292: * CREATE IF POSSIBLE A LOAD MODULE CONTAINING ONLY THE
1293: * IMPURE AREA OF MEMORY WHICH NEEDS TO BE LOADED WITH
1294: * A COMPATIBLE PURE SEGMENT FOR SUBSEQUENT EXECUTIONS.
1295: * VERSION NUMBERS TO CHECK COMPATIBILITY SHOULD BE
1296: * KEPT IN BOTH SEGMENTS AND CHECKED ON LOADING.
1297: * TO ASSIST WITH THIS CHECK, (XR) ON ENTRY IS A
1298: * POINTER TO AN SCBLK CONTAINING THE SPITBOL MAJOR
1299: * VERSION NUMBER V.V (SEE SYSID).
1300: *
1301: * 0 IF POSSIBLE, RETURN CONTROL TO JOB CONTROL
1302: * COMMAND LEVEL. THE EFFECT IF AVAILABLE WILL BE
1303: * SYSTEM DEPENDENT.
1304: *
1305: * +1, +2, +3
1306: * CREATE IF POSSIBLE A LOAD MODULE FROM ALL OF
1307: * MEMORY. IT SHOULD BE POSSIBLE TO LOAD AND EXECUTE
1308: * THIS MODULE DIRECTLY.
1309: *
1310: * IN THE CASE OF SAVED LOAD MODULES, THE STATUS OF OPEN
1311: * FILES IS NOT PRESERVED AND IMPLEMENTORS MAY CHOOSE TO
1312: * OFFER MEANS OF ATTACHING FILES BEFORE EXECUTION OF LOAD
1313: * MODULES STARTS OR LEAVE IT TO THE USER TO INCLUDE
1314: * SUITABLE INPUT(), OUTPUT() CALLS IN HIS PROGRAM.
1315: * SYSXI SHOULD MAKE A NOTE THAT NO I/O CHANNELS,
1316: * INCLUDING STANDARD FILES, HAVE FILES ATTACHED SO THAT
1317: * CALLS OF SYSIN, SYSOU, SYSPR, SYSRD SHOULD FAIL UNLESS
1318: * NEW ASSOCIATIONS ARE MADE FOR THE LOAD MODULE.
1319: * AT LEAST IN THE CASE OF THE STANDARD OUTPUT FILE, IT IS
1320: * RECOMMENDED THAT EITHER THE USER BE REQUIRED TO ATTACH
1321: * A FILE OR THAT A DEFAULT FILE IS ATTACHED, SINCE THE
1322: * PROBLEM OF ERROR MESSAGES GENERATED BY THE LOAD MODULE
1323: * IS OTHERWISE SEVERE. AS A LAST RESORT, IF SPITBOL
1324: * ATTEMPTS TO WRITE TO THE STANDARD OUTPUT FILE AND GETS A
1325: * REPLY INDICATING THAT SUCH OUPUT IS UNACCEPTABLE IT STOPS
1326: * BY USING AN ENTRY TO SYSEJ WITH ENDING CODE 998.
1327: * AS DESCRIBED BELOW, PASSING OF SOME ARGUMENTS MAKES IT
1328: * CLEAR THAT LOAD MODULE WILL USE A STANDARD OUTPUT FILE.
1329: *
1330: * IF USE IS MADE OF FCBLKS FOR I/O ASSOCIATION, SPITBOL
1331: * BUILDS A CHAIN SO THAT THOSE IN USE MAY BE FOUND IN SYSXI
1332: * AND SYSEJ. THE NODES ARE 4 WORDS LONG. THIRD WORD
1333: * CONTAINS LINK TO NEXT NODE OR 0, FOURTH WORD CONTAINS
1334: * FCBLK POINTER.
1335: EJC
1336: *
1337: * SYSXI (CONTINUED)
1338: *
1339: * (XL) ZERO OR SCBLK PTR
1340: * (XR) PTR TO V.V SCBLK
1341: * (IA) SIGNED INTEGER ARGUMENT
1342: * (WB) 0 OR PTR TO HEAD OF FCBLK CHAIN
1343: * JSR SYSXI CALL TO EXIT
1344: * PPM LOC REQUESTED ACTION NOT POSSIBLE
1345: * PPM LOC ACTION CAUSED IRRECOVERABLE ERROR
1346: * (REGISTERS) SHOULD BE PRESERVED OVER CALL
1347: *
1348: * LOADING AND RUNNING THE LOAD MODULE OR RETURNING FROM
1349: * JCL COMMAND LEVEL CAUSES EXECUTION TO RESUME AT THE POINT
1350: * AFTER THE ERROR RETURNS WHICH FOLLOW THE CALL OF SYSXI.
1351: * THE VALUE PASSED AS EXIT ARGUMENT IS USED TO INDICATE
1352: * OPTIONS REQUIRED ON RESUMPTION OF LOAD MODULE.
1353: * +1 OR -1 REQUIRE THAT ON RESUMPTION, SYSID AND SYSPP BE
1354: * CALLED AND A HEADING PRINTED ON THE STANDARD OUTPUT FILE.
1355: * +2 OR -2 INDICATE THAT SYSPP WILL BE CALLED BUT NOT SYSID
1356: * AND NO HEADING WILL BE PUT ON STANDARD OUTPUT FILE.
1357: * ABOVE OPTIONS HAVE THE OBVIOUS IMPLICATION THAT A
1358: * STANDARD O/P FILE MUST BE PROVIDED FOR THE LOAD MODULE.
1359: * +3 OR -3 INDICATE CALLS OF NEITHER SYSID NOR SYSPP
1360: * AND NO HEADING WILL BE PLACED ON STANDARD OUTPUT FILE.
1361: * NO RETURN FROM SYSXI IS POSSIBLE IF ANOTHER PROGRAM
1362: * IS LOADED AND ENTERED.
1363: EJC
1364: *
1365: * INTRODUCE THE INTERNAL PROCEDURES.
1366: *
1367: ACESS INP R,1
1368: ACOMP INP N,5
1369: ALLOC INP E,0
1370: ALOBF INP E,0
1371: ALOCS INP E,0
1372: ALOST INP E,0
1373: APNDB INP E,2
1374: ARITH INP N,3
1375: ASIGN INP R,1
1376: ASINP INP R,1
1377: BLKLN INP E,0
1378: CDGCG INP E,0
1379: CDGEX INP R,0
1380: CDGNM INP R,0
1381: CDGVL INP R,0
1382: CDWRD INP E,0
1383: CMGEN INP R,0
1384: CMPIL INP E,0
1385: CNCRD INP E,0
1386: COPYB INP N,1
1387: DFFNC INP E,0
1388: DTACH INP E,0
1389: DTYPE INP E,0
1390: DUMPR INP E,0
1391: ERMSG INP E,0
1392: ERTEX INP E,0
1393: EVALI INP R,4
1394: EVALP INP R,1
1395: EVALS INP R,3
1396: EVALX INP R,1
1397: EXBLD INP E,0
1398: EXPAN INP E,0
1399: EXPAP INP E,1
1400: EXPDM INP N,0
1401: EXPOP INP N,0
1402: FLSTG INP R,0
1403: GBCOL INP E,0
1404: GBCPF INP E,0
1405: GTARR INP E,1
1406: EJC
1407: GTCOD INP E,1
1408: GTEXP INP E,1
1409: GTINT INP E,1
1410: GTNUM INP E,1
1411: GTNVR INP E,1
1412: GTPAT INP E,1
1413: GTREA INP E,1
1414: GTSMI INP N,2
1415: GTSTG INP N,1
1416: GTVAR INP E,1
1417: HASHS INP E,0
1418: ICBLD INP E,0
1419: IDENT INP E,1
1420: INOUT INP E,0
1421: INSBF INP E,2
1422: IOFCB INP N,2
1423: IOPPF INP N,0
1424: IOPUT INP N,6
1425: KTREX INP R,0
1426: KWNAM INP N,0
1427: LCOMP INP N,5
1428: LISTR INP E,0
1429: LISTT INP E,0
1430: NEXTS INP E,0
1431: PATIN INP N,2
1432: PATST INP N,1
1433: PBILD INP E,0
1434: PCONC INP E,0
1435: PCOPY INP N,0
1436: PRFLR INP E,0
1437: PRFLU INP E,0
1438: PRPAR INP E,0
1439: PRTCH INP E,0
1440: PRTIC INP E,0
1441: PRTIS INP E,0
1442: PRTIN INP E,0
1443: PRTMI INP E,0
1444: PRTMX INP E,0
1445: PRTNL INP R,0
1446: PRTNM INP R,0
1447: PRTNV INP E,0
1448: PRTPG INP E,0
1449: PRTPS INP E,0
1450: PRTSN INP E,0
1451: PRTST INP R,0
1452: EJC
1453: PRTTR INP E,0
1454: PRTVL INP R,0
1455: PRTVN INP E,0
1456: RCBLD INP E,0
1457: READR INP E,0
1458: SBSTR INP E,0
1459: SCANE INP E,0
1460: SCNGF INP E,0
1461: SETVR INP E,0
1462: SORTA INP N,0
1463: SORTC INP E,1
1464: SORTF INP E,0
1465: SORTH INP E,0
1466: TFIND INP E,1
1467: TRACE INP N,2
1468: TRBLD INP E,0
1469: TRIMR INP E,0
1470: TRXEQ INP R,0
1471: XSCAN INP E,0
1472: XSCNI INP N,2
1473: *
1474: * INTRODUCE THE INTERNAL ROUTINES
1475: *
1476: ARREF INR
1477: CFUNC INR
1478: EXFAL INR
1479: EXINT INR
1480: EXITS INR
1481: EXIXR INR
1482: EXNAM INR
1483: EXNUL INR
1484: EXREA INR
1485: EXSID INR
1486: EXVNM INR
1487: FAILP INR
1488: FLPOP INR
1489: INDIR INR
1490: MATCH INR
1491: RETRN INR
1492: STCOV INR
1493: STMGO INR
1494: STOPR INR
1495: SUCCP INR
1496: SYSAB INR
1497: SYSTU INR
1498: TTL S P I T B O L -- DEFINITIONS AND DATA STRUCTURES
1499: SEC START OF DEFINITIONS SECTION
1500: *
1501: * DEFINITIONS OF MACHINE PARAMETERS
1502: *
1503: * THE MINIMAL TRANSLATOR SHOULD SUPPLY APPROPRIATE VALUES
1504: * FOR THE PARTICULAR TARGET MACHINE FOR ALL THE
1505: * EQU *
1506: * DEFINITIONS GIVEN AT THE START OF THIS SECTION.
1507: *
1508: CFP$A EQU * NUMBER OF CHARACTERS IN ALPHABET
1509: *
1510: CFP$B EQU * BYTES/WORD ADDRESSING FACTOR
1511: *
1512: CFP$C EQU * NUMBER OF CHARACTERS PER WORD
1513: *
1514: CFP$F EQU * OFFSET IN BYTES TO CHARS IN
1515: * SCBLK. SEE SCBLK FORMAT.
1516: *
1517: CFP$I EQU * NUMBER OF WORDS IN INTEGER CONSTANT
1518: *
1519: CFP$M EQU * MAX POSITIVE INTEGER IN ONE WORD
1520: *
1521: CFP$N EQU * NUMBER OF BITS IN ONE WORD
1522: *
1523: * THE FOLLOWING DEFINITIONS REQUIRE THE SUPPLY OF EITHER
1524: * A SINGLE PARAMETER IF REAL ARITHMETIC IS OMITTED OR
1525: * THREE PARAMETERS IF REAL ARITHMETIC IS INCLUDED.
1526: *
1527: *
1528: CFP$R EQU * NUMBER OF WORDS IN REAL CONSTANT
1529: *
1530: CFP$S EQU * NUMBER OF SIG DIGS FOR REAL OUTPUT
1531: *
1532: CFP$X EQU * MAX DIGITS IN REAL EXPONENT
1533: *
1534: MXDGS EQU CFP$S+CFP$X MAX DIGITS IN REAL NUMBER
1535: *
1536: NSTMX EQU MXDGS+5 MAX SPACE FOR REAL (FOR +0.E+)
1537: *
1538: * THE FOLLOWING DEFINITION FOR CFP$U SUPPLIES A REALISTIC
1539: * UPPER BOUND ON THE SIZE OF THE ALPHABET. CFP$U IS USED
1540: * TO SAVE SPACE IN THE SCANE BSW-IFF-ESW TABLE AND TO EASE
1541: * TRANSLATION STORAGE REQUIREMENTS.
1542: *
1543: CFP$U EQU * REALISTIC UPPER BOUND ON ALPHABET
1544: EJC
1545: *
1546: * ENVIRONMENT PARAMETERS
1547: *
1548: * THE SPITBOL PROGRAM IS ESSENTIALLY INDEPENDENT OF
1549: * THE DEFINITIONS OF THESE PARAMETERS. HOWEVER, THE
1550: * EFFICIENCY OF THE SYSTEM MAY BE AFFECTED. CONSEQUENTLY,
1551: * THESE PARAMETERS MAY REQUIRE TUNING FOR A GIVEN VERSION
1552: * THE VALUES GIVEN IN COMMENTS HAVE BEEN SUCCESSFULLY USED.
1553: *
1554: * E$SRS IS THE NUMBER OF WORDS TO RESERVE AT THE END OF
1555: * STORAGE FOR END OF RUN PROCESSING. IT SHOULD BE
1556: * SET AS SMALL AS POSSIBLE WITHOUT CAUSING MEMORY OVERFLOW
1557: * IN CRITICAL SITUATIONS (E.G. MEMORY OVERFLOW TERMINATION)
1558: * AND SHOULD THUS RESERVE SUFFICIENT SPACE AT LEAST FOR
1559: * AN SCBLK CONTAINING SAY 30 CHARACTERS.
1560: *
1561: E$SRS EQU * 30 WORDS
1562: *
1563: * E$STS IS THE NUMBER OF WORDS GRABBED IN A CHUNK WHEN
1564: * STORAGE IS ALLOCATED IN THE STATIC REGION. THE MINIMUM
1565: * PERMITTED VALUE IS 256/CFP$B. LARGER VALUES WILL LEAD
1566: * TO INCREASED EFFICIENCY AT THE COST OF WASTING MEMORY.
1567: *
1568: E$STS EQU * 500 WORDS
1569: *
1570: * E$CBS IS THE SIZE OF CODE BLOCK ALLOCATED INITIALLY AND
1571: * THE EXPANSION INCREMENT IF OVERFLOW OCCURS. IF THIS VALUE
1572: * IS TOO SMALL OR TOO LARGE, EXCESSIVE GARBAGE COLLECTIONS
1573: * WILL OCCUR DURING COMPILATION AND MEMORY MAY BE LOST
1574: * IN THE CASE OF A TOO LARGE VALUE.
1575: *
1576: E$CBS EQU * 500 WORDS
1577: *
1578: * E$HNB IS THE NUMBER OF BUCKET HEADERS IN THE VARIABLE
1579: * HASH TABLE. IT SHOULD ALWAYS BE ODD. LARGER VALUES WILL
1580: * SPEED UP COMPILATION AND INDIRECT REFERENCES AT THE
1581: * EXPENSE OF ADDITIONAL STORAGE FOR THE HASH TABLE ITSELF.
1582: *
1583: E$HNB EQU * 127 BUCKET HEADERS
1584: *
1585: * E$HNW IS THE MAXIMUM NUMBER OF WORDS OF A STRING
1586: * NAME WHICH PARTICIPATE IN THE STRING HASH ALGORITHM.
1587: * LARGER VALUES GIVE A BETTER HASH AT THE EXPENSE OF TAKING
1588: * LONGER TO COMPUTE THE HASH. THERE IS SOME OPTIMAL VALUE.
1589: *
1590: E$HNW EQU * 6 WORDS
1591: *
1592: * E$FSP . IF THE AMOUNT OF FREE SPACE LEFT AFTER A GARBAGE
1593: * COLLECTION IS SMALL COMPARED TO THE TOTAL AMOUNT OF SPACE
1594: * IN USE GARBAGE COLLECTOR THRASHING IS LIKELY TO OCCUR AS
1595: * THIS SPACE IS USED UP. E$FSP IS A MEASURE OF THE
1596: * MINIMUM PERCENTAGE OF DYNAMIC MEMORY LEFT AS FREE SPACE
1597: * BEFORE THE SYSTEM ROUTINE SYSMM IS CALLED TO TRY TO
1598: * OBTAIN MORE MEMORY.
1599: *
1600: E$FSP EQU * 15 PERCENT
1601: EJC
1602: *
1603: * DEFINITIONS OF CODES FOR LETTERS
1604: *
1605: CH$LA EQU * LETTER A
1606: CH$LB EQU * LETTER B
1607: CH$LC EQU * LETTER C
1608: CH$LD EQU * LETTER D
1609: CH$LE EQU * LETTER E
1610: CH$LF EQU * LETTER F
1611: CH$LG EQU * LETTER G
1612: CH$LH EQU * LETTER H
1613: CH$LI EQU * LETTER I
1614: CH$LJ EQU * LETTER J
1615: CH$LK EQU * LETTER K
1616: CH$LL EQU * LETTER L
1617: CH$LM EQU * LETTER M
1618: CH$LN EQU * LETTER N
1619: CH$LO EQU * LETTER O
1620: CH$LP EQU * LETTER P
1621: CH$LQ EQU * LETTER Q
1622: CH$LR EQU * LETTER R
1623: CH$LS EQU * LETTER S
1624: CH$LT EQU * LETTER T
1625: CH$LU EQU * LETTER U
1626: CH$LV EQU * LETTER V
1627: CH$LW EQU * LETTER W
1628: CH$LX EQU * LETTER X
1629: CH$LY EQU * LETTER Y
1630: CH$L$ EQU * LETTER Z
1631: *
1632: * DEFINITIONS OF CODES FOR DIGITS
1633: *
1634: CH$D0 EQU * DIGIT 0
1635: CH$D1 EQU * DIGIT 1
1636: CH$D2 EQU * DIGIT 2
1637: CH$D3 EQU * DIGIT 3
1638: CH$D4 EQU * DIGIT 4
1639: CH$D5 EQU * DIGIT 5
1640: CH$D6 EQU * DIGIT 6
1641: CH$D7 EQU * DIGIT 7
1642: CH$D8 EQU * DIGIT 8
1643: CH$D9 EQU * DIGIT 9
1644: EJC
1645: *
1646: * DEFINITIONS OF CODES FOR SPECIAL CHARACTERS
1647: *
1648: * THE NAMES OF THESE CHARACTERS ARE RELATED TO THEIR
1649: * ORIGINAL REPRESENTATION IN THE EBCDIC SET CORRESPONDING
1650: * TO THE DESCRIPTION IN STANDARD SNOBOL4 MANUALS AND TEXTS.
1651: *
1652: CH$AM EQU * KEYWORD OPERATOR (AMPERSAND)
1653: CH$AS EQU * MULTIPLICATION SYMBOL (ASTERISK)
1654: CH$AT EQU * CURSOR POSITION OPERATOR (AT)
1655: CH$BB EQU * LEFT ARRAY BRACKET (LESS THAN)
1656: CH$BL EQU * BLANK
1657: CH$BR EQU * ALTERNATION OPERATOR (VERTICAL BAR)
1658: CH$CL EQU * GOTO SYMBOL (COLON)
1659: CH$CM EQU * COMMA
1660: CH$DL EQU * INDIRECTION OPERATOR (DOLLAR)
1661: CH$DT EQU * NAME OPERATOR (DOT)
1662: CH$DQ EQU * DOUBLE QUOTE
1663: CH$EQ EQU * EQUAL SIGN
1664: CH$EX EQU * EXPONENTIATION OPERATOR (EXCLM)
1665: CH$MN EQU * MINUS SIGN
1666: CH$NM EQU * NUMBER SIGN
1667: CH$NT EQU * NEGATION OPERATOR (NOT)
1668: CH$PC EQU * PERCENT
1669: CH$PL EQU * PLUS SIGN
1670: CH$PP EQU * LEFT PARENTHESIS
1671: CH$RB EQU * RIGHT ARRAY BRACKET (GRTR THAN)
1672: CH$RP EQU * RIGHT PARENTHESIS
1673: CH$QU EQU * INTERROGATION OPERATOR (QUESTION)
1674: CH$SL EQU * SLASH
1675: CH$SM EQU * SEMICOLON
1676: CH$SQ EQU * SINGLE QUOTE
1677: CH$UN EQU * SPECIAL IDENTIFIER CHAR (UNDERLINE)
1678: CH$OB EQU * OPENING BRACKET
1679: CH$CB EQU * CLOSING BRACKET
1680: EJC
1681: *
1682: * REMAINING CHARS ARE OPTIONAL ADDITIONS TO THE STANDARDS.
1683: *
1684: * TAB CHARACTERS - SYNTACTICALLY EQUIVALENT TO BLANK
1685: *
1686: CH$HT EQU * HORIZONTAL TAB
1687: *
1688: * LOWER CASE OR SHIFTED CASE ALPHABETIC CHARS
1689: *
1690: CH$$A EQU * SHIFTED A
1691: CH$$B EQU * SHIFTED B
1692: CH$$C EQU * SHIFTED C
1693: CH$$D EQU * SHIFTED D
1694: CH$$E EQU * SHIFTED E
1695: CH$$F EQU * SHIFTED F
1696: CH$$G EQU * SHIFTED G
1697: CH$$H EQU * SHIFTED H
1698: CH$$I EQU * SHIFTED I
1699: CH$$J EQU * SHIFTED J
1700: CH$$K EQU * SHIFTED K
1701: CH$$L EQU * SHIFTED L
1702: CH$$M EQU * SHIFTED M
1703: CH$$N EQU * SHIFTED N
1704: CH$$O EQU * SHIFTED O
1705: CH$$P EQU * SHIFTED P
1706: CH$$Q EQU * SHIFTED Q
1707: CH$$R EQU * SHIFTED R
1708: CH$$S EQU * SHIFTED S
1709: CH$$T EQU * SHIFTED T
1710: CH$$U EQU * SHIFTED U
1711: CH$$V EQU * SHIFTED V
1712: CH$$W EQU * SHIFTED W
1713: CH$$X EQU * SHIFTED X
1714: CH$$Y EQU * SHIFTED Y
1715: CH$$$ EQU * SHIFTED Z
1716: * IF A DELIMITER OTHER THAN CH$CM MUST BE USED IN
1717: * THE THIRD ARGUMENT OF INPUT(),OUTPUT() THEN .CIOD SHOULD
1718: * BE DEFINED AND A PARAMETER SUPPLIED FOR IODEL.
1719: *
1720: IODEL EQU *
1721: EJC
1722: *
1723: * DATA BLOCK FORMATS AND DEFINITIONS
1724: *
1725: * THE FOLLOWING SECTIONS DESCRIBE THE DETAILED FORMAT OF
1726: * ALL POSSIBLE DATA BLOCKS IN STATIC AND DYNAMIC MEMORY.
1727: *
1728: * EVERY BLOCK HAS A NAME OF THE FORM XXBLK WHERE XX IS A
1729: * UNIQUE TWO CHARACTER IDENTIFIER. THE FIRST WORD OF EVERY
1730: * BLOCK MUST CONTAIN A POINTER TO A PROGRAM LOCATION IN THE
1731: * INTERPRETOR WHICH IS IMMEDIATELY PRECEDED BY AN ADDRESS
1732: * CONSTANT CONTAINING THE VALUE BL$XX WHERE XX IS THE BLOCK
1733: * IDENTIFIER. THIS PROVIDES A UNIFORM MECHANISM FOR
1734: * DISTINGUISHING BETWEEN THE VARIOUS BLOCK TYPES.
1735: *
1736: * IN SOME CASES, THE CONTENTS OF THE FIRST WORD IS CONSTANT
1737: * FOR A GIVEN BLOCK TYPE AND MERELY SERVES AS A POINTER
1738: * TO THE IDENTIFYING ADDRESS CONSTANT. HOWEVER, IN OTHER
1739: * CASES THERE ARE SEVERAL POSSIBILITIES FOR THE FIRST
1740: * WORD IN WHICH CASE EACH OF THE SEVERAL PROGRAM ENTRY
1741: * POINTS MUST BE PRECEDED BY THE APPROPRIATE CONSTANT.
1742: *
1743: * IN EACH BLOCK, SOME OF THE FIELDS ARE RELOCATABLE. THIS
1744: * MEANS THAT THEY MAY CONTAIN A POINTER TO ANOTHER BLOCK
1745: * IN THE DYNAMIC AREA. (TO BE MORE PRECISE, IF THEY CONTAIN
1746: * A POINTER WITHIN THE DYNAMIC AREA, THEN IT IS A POINTER
1747: * TO A BLOCK). SUCH FIELDS MUST BE MODIFIED BY THE GARBAGE
1748: * COLLECTOR (PROCEDURE GBCOL) WHENEVER BLOCKS ARE COMPACTED
1749: * IN THE DYNAMIC REGION. THE GARBAGE COLLECTOR (ACTUALLY
1750: * PROCEDURE GBCPF) REQUIRES THAT ALL SUCH RELOCATABLE
1751: * FIELDS IN A BLOCK MUST BE CONTIGUOUS.
1752: EJC
1753: *
1754: * THE DESCRIPTION FORMAT USES THE FOLLOWING SCHEME.
1755: *
1756: * 1) BLOCK TITLE AND TWO CHARACTER IDENTIFIER
1757: *
1758: * 2) DESCRIPTION OF BASIC USE OF BLOCK AND INDICATION
1759: * OF CIRCUMSTANCES UNDER WHICH IT IS CONSTRUCTED.
1760: *
1761: * 3) PICTURE OF THE BLOCK FORMAT. IN THESE PICTURES LOW
1762: * MEMORY ADDRESSES ARE AT THE TOP OF THE PAGE. FIXED
1763: * LENGTH FIELDS ARE SURROUNDED BY I (LETTER I). FIELDS
1764: * WHICH ARE FIXED LENGTH BUT WHOSE LENGTH IS DEPENDENT
1765: * ON A CONFIGURATION PARAMETER ARE SURROUNDED BY *
1766: * (ASTERISK). VARIABLE LENGTH FIELDS ARE SURROUNDED
1767: * BY / (SLASH).
1768: *
1769: * 4) DEFINITION OF SYMBOLIC OFFSETS TO FIELDS IN
1770: * BLOCK AND OF THE SIZE OF THE BLOCK IF FIXED LENGTH
1771: * OR OF THE SIZE OF THE FIXED LENGTH FIELDS IF THE
1772: * BLOCK IS VARIABLE LENGTH.
1773: * NOTE THAT SOME ROUTINES SUCH AS GBCPF ASSUME
1774: * CERTAIN OFFSETS ARE EQUAL. THE DEFINITIONS
1775: * GIVEN HERE ENFORCE THIS. MAKE CHANGES TO
1776: * THEM ONLY WITH DUE CARE.
1777: *
1778: * DEFINITIONS OF COMMON OFFSETS
1779: *
1780: OFFS1 EQU 1
1781: OFFS2 EQU 2
1782: OFFS3 EQU 3
1783: *
1784: * 5) DETAILED COMMENTS ON THE SIGNIFICANCE AND FORMATS
1785: * OF THE VARIOUS FIELDS.
1786: *
1787: * THE ORDER IS ALPHABETICAL BY IDENTIFICATION CODE.
1788: EJC
1789: *
1790: * DEFINITIONS OF BLOCK CODES
1791: *
1792: * THIS TABLE PROVIDES A UNIQUE IDENTIFICATION CODE FOR
1793: * EACH SEPARATE BLOCK TYPE. THE FIRST WORD OF A BLOCK IN
1794: * THE DYNAMIC AREA ALWAYS CONTAINS THE ADDRESS OF A PROGRAM
1795: * ENTRY POINT. THE BLOCK CODE IS USED AS THE ENTRY POINT ID
1796: * THE ORDER OF THESE CODES DICTATES THE ORDER OF THE TABLE
1797: * USED BY THE DATATYPE FUNCTION (SCNMT IN THE CONSTANT SEC)
1798: *
1799: * BLOCK CODES FOR ACCESSIBLE DATATYPES
1800: *
1801: BL$AR EQU 0 ARBLK ARRAY
1802: BL$BC EQU BL$AR+1 BCBLK BUFFER
1803: BL$CD EQU BL$BC+1 CDBLK CODE
1804: BL$EX EQU BL$CD+1 EXBLK EXPRESSION
1805: BL$IC EQU BL$EX+1 ICBLK INTEGER
1806: BL$NM EQU BL$IC+1 NMBLK NAME
1807: BL$P0 EQU BL$NM+1 P0BLK PATTERN
1808: BL$P1 EQU BL$P0+1 P1BLK PATTERN
1809: BL$P2 EQU BL$P1+1 P2BLK PATTERN
1810: BL$RC EQU BL$P2+1 RCBLK REAL
1811: BL$SC EQU BL$RC+1 SCBLK STRING
1812: BL$SE EQU BL$SC+1 SEBLK EXPRESSION
1813: BL$TB EQU BL$SE+1 TBBLK TABLE
1814: BL$VC EQU BL$TB+1 VCBLK ARRAY
1815: BL$XN EQU BL$VC+1 XNBLK EXTERNAL
1816: BL$XR EQU BL$XN+1 XRBLK EXTERNAL
1817: BL$PD EQU BL$XR+1 PDBLK PROGRAM DEFINED DATATYPE
1818: *
1819: BL$$D EQU BL$PD+1 NUMBER OF BLOCK CODES FOR DATA
1820: *
1821: * OTHER BLOCK CODES
1822: *
1823: BL$TR EQU BL$PD+1 TRBLK
1824: BL$BF EQU BL$TR+1 BFBLK
1825: BL$CC EQU BL$BF+1 CCBLK
1826: BL$CM EQU BL$CC+1 CMBLK
1827: BL$CT EQU BL$CM+1 CTBLK
1828: BL$DF EQU BL$CT+1 DFBLK
1829: BL$EF EQU BL$DF+1 EFBLK
1830: BL$EV EQU BL$EF+1 EVBLK
1831: BL$FF EQU BL$EV+1 FFBLK
1832: BL$KV EQU BL$FF+1 KVBLK
1833: BL$PF EQU BL$KV+1 PFBLK
1834: BL$TE EQU BL$PF+1 TEBLK
1835: *
1836: BL$$I EQU 0 DEFAULT IDENTIFICATION CODE
1837: BL$$T EQU BL$TR+1 CODE FOR DATA OR TRACE BLOCK
1838: BL$$$ EQU BL$TE+1 NUMBER OF BLOCK CODES
1839: EJC
1840: *
1841: * FIELD REFERENCES
1842: *
1843: * REFERENCES TO THE FIELDS OF DATA BLOCKS ARE SYMBOLIC
1844: * (I.E. USE THE SYMBOLIC OFFSETS) WITH THE FOLLOWING
1845: * EXCEPTIONS.
1846: *
1847: * 1) REFERENCES TO THE FIRST WORD ARE USUALLY NOT
1848: * SYMBOLIC SINCE THEY USE THE (X) OPERAND FORMAT.
1849: *
1850: * 2) THE CODE WHICH CONSTRUCTS A BLOCK IS OFTEN NOT
1851: * SYMBOLIC AND SHOULD BE CHANGED IF THE CORRESPONDING
1852: * BLOCK FORMAT IS MODIFIED.
1853: *
1854: * 3) THE PLC AND PSC INSTRUCTIONS IMPLY AN OFFSET
1855: * CORRESPONDING TO THE DEFINITION OF CFP$F.
1856: *
1857: * 4) THERE ARE NON-SYMBOLIC REFERENCES (EASILY CHANGED)
1858: * IN THE GARBAGE COLLECTOR (PROCEDURES GBCPF, BLKLN).
1859: *
1860: * 5) THE FIELDS IDVAL, FARGS APPEAR IN SEVERAL BLOCKS
1861: * AND ANY CHANGES MUST BE MADE IN PARALLEL TO ALL
1862: * BLOCKS CONTAINING THE FIELDS. THE ACTUAL REFERENCES
1863: * TO THESE FIELDS ARE SYMBOLIC WITH THE ABOVE
1864: * LISTED EXCEPTIONS.
1865: *
1866: * 6) SEVERAL SPOTS IN THE CODE ASSUME THAT THE
1867: * DEFINITIONS OF THE FIELDS VRVAL, TEVAL, TRNXT ARE
1868: * THE SAME (THESE ARE SECTIONS OF CODE WHICH SEARCH
1869: * OUT ALONG A TRBLK CHAIN FROM A VARIABLE).
1870: *
1871: * 7) REFERENCES TO THE FIELDS OF AN ARRAY BLOCK IN THE
1872: * ARRAY REFERENCE ROUTINE ARREF ARE NON-SYMBOLIC.
1873: *
1874: * APART FROM THE EXCEPTIONS LISTED, REFERENCES ARE SYMBOLIC
1875: * AS FAR AS POSSIBLE AND MODIFYING THE ORDER OR NUMBER
1876: * OF FIELDS WILL NOT REQUIRE CHANGES.
1877: EJC
1878: *
1879: * COMMON FIELDS FOR FUNCTION BLOCKS
1880: *
1881: * BLOCKS WHICH REPRESENT CALLABLE FUNCTIONS HAVE TWO
1882: * COMMON FIELDS AT THE START OF THE BLOCK AS FOLLOWS.
1883: *
1884: * +------------------------------------+
1885: * I FCODE I
1886: * +------------------------------------+
1887: * I FARGS I
1888: * +------------------------------------+
1889: * / /
1890: * / REST OF FUNCTION BLOCK /
1891: * / /
1892: * +------------------------------------+
1893: *
1894: FCODE EQU 0 POINTER TO CODE FOR FUNCTION
1895: FARGS EQU 1 NUMBER OF ARGUMENTS
1896: *
1897: * FCODE IS A POINTER TO THE LOCATION IN THE INTERPRETOR
1898: * PROGRAM WHICH PROCESSES THIS TYPE OF FUNCTION CALL.
1899: *
1900: * FARGS IS THE EXPECTED NUMBER OF ARGUMENTS. THE ACTUAL
1901: * NUMBER OF ARGUMENTS IS ADJUSTED TO THIS AMOUNT BY
1902: * DELETING EXTRA ARGUMENTS OR SUPPLYING TRAILING NULLS
1903: * FOR MISSING ONES BEFORE TRANSFERRING THOUGH FCODE.
1904: * A VALUE OF 999 MAY BE USED IN THIS FIELD TO INDICATE A
1905: * VARIABLE NUMBER OF ARGUMENTS (SEE SVBLK FIELD SVNAR).
1906: *
1907: * THE BLOCK TYPES WHICH FOLLOW THIS SCHEME ARE.
1908: *
1909: * FFBLK FIELD FUNCTION
1910: * DFBLK DATATYPE FUNCTION
1911: * PFBLK PROGRAM DEFINED FUNCTION
1912: * EFBLK EXTERNAL LOADED FUNCTION
1913: EJC
1914: *
1915: * IDENTIFICATION FIELD
1916: *
1917: *
1918: * ID FIELD
1919: *
1920: * CERTAIN PROGRAM ACCESSIBLE OBJECTS (THOSE WHICH CONTAIN
1921: * OTHER DATA VALUES AND CAN BE COPIED) ARE GIVEN A UNIQUE
1922: * IDENTIFICATION NUMBER (SEE EXSID). THIS ID VALUE IS AN
1923: * ADDRESS INTEGER VALUE WHICH IS ALWAYS STORED IN WORD TWO.
1924: *
1925: IDVAL EQU 1 ID VALUE FIELD
1926: *
1927: * THE BLOCKS CONTAINING AN IDVAL FIELD ARE.
1928: *
1929: * ARBLK ARRAY
1930: * BCBLK BUFFER CONTROL BLOCK
1931: * PDBLK PROGRAM DEFINED DATATYPE
1932: * TBBLK TABLE
1933: * VCBLK VECTOR BLOCK (ARRAY)
1934: *
1935: * NOTE THAT A ZERO IDVAL MEANS THAT THE BLOCK IS ONLY
1936: * HALF BUILT AND SHOULD NOT BE DUMPED (SEE DUMPR).
1937: EJC
1938: *
1939: * ARRAY BLOCK (ARBLK)
1940: *
1941: * AN ARRAY BLOCK REPRESENTS AN ARRAY VALUE OTHER THAN ONE
1942: * WITH ONE DIMENSION WHOSE LOWER BOUND IS ONE (SEE VCBLK).
1943: * AN ARBLK IS BUILT WITH A CALL TO THE FUNCTIONS CONVERT
1944: * (S$CNV) OR ARRAY (S$ARR).
1945: *
1946: * +------------------------------------+
1947: * I ARTYP I
1948: * +------------------------------------+
1949: * I IDVAL I
1950: * +------------------------------------+
1951: * I ARLEN I
1952: * +------------------------------------+
1953: * I AROFS I
1954: * +------------------------------------+
1955: * I ARNDM I
1956: * +------------------------------------+
1957: * * ARLBD *
1958: * +------------------------------------+
1959: * * ARDIM *
1960: * +------------------------------------+
1961: * * *
1962: * * ABOVE 2 FLDS REPEATED FOR EACH DIM *
1963: * * *
1964: * +------------------------------------+
1965: * I ARPRO I
1966: * +------------------------------------+
1967: * / /
1968: * / ARVLS /
1969: * / /
1970: * +------------------------------------+
1971: EJC
1972: *
1973: * ARRAY BLOCK (CONTINUED)
1974: *
1975: ARTYP EQU 0 POINTER TO DUMMY ROUTINE B$ART
1976: ARLEN EQU IDVAL+1 LENGTH OF ARBLK IN BYTES
1977: AROFS EQU ARLEN+1 OFFSET IN ARBLK TO ARPRO FIELD
1978: ARNDM EQU AROFS+1 NUMBER OF DIMENSIONS
1979: ARLBD EQU ARNDM+1 LOW BOUND (FIRST SUBSCRIPT)
1980: ARDIM EQU ARLBD+CFP$I DIMENSION (FIRST SUBSCRIPT)
1981: ARLB2 EQU ARDIM+CFP$I LOW BOUND (SECOND SUBSCRIPT)
1982: ARDM2 EQU ARLB2+CFP$I DIMENSION (SECOND SUBSCRIPT)
1983: ARPRO EQU ARDIM+CFP$I ARRAY PROTOTYPE (ONE DIMENSION)
1984: ARVLS EQU ARPRO+1 START OF VALUES (ONE DIMENSION)
1985: ARPR2 EQU ARDM2+CFP$I ARRAY PROTOTYPE (TWO DIMENSIONS)
1986: ARVL2 EQU ARPR2+1 START OF VALUES (TWO DIMENSIONS)
1987: ARSI$ EQU ARLBD NUMBER OF STANDARD FIELDS IN BLOCK
1988: ARDMS EQU ARLB2-ARLBD SIZE OF INFO FOR ONE SET OF BOUNDS
1989: *
1990: * THE BOUNDS AND DIMENSION FIELDS ARE SIGNED INTEGER
1991: * VALUES AND EACH OCCUPY CFP$I WORDS IN THE ARBLK.
1992: *
1993: * THE LENGTH OF AN ARBLK IN BYTES MAY NOT EXCEED MXLEN.
1994: * THIS IS REQUIRED TO KEEP NAME OFFSETS GARBAGE COLLECTABLE
1995: *
1996: * THE ACTUAL VALUES ARE ARRANGED IN ROW-WISE ORDER AND
1997: * CAN CONTAIN A DATA POINTER OR A POINTER TO A TRBLK.
1998: *
1999: * BUFFER CONTROL BLOCK (BCBLK)
2000: *
2001: * A BCBLK IS BUILT FOR EVERY BFBLK.
2002: *
2003: * +------------------------------------+
2004: * I BCTYP I
2005: * +------------------------------------+
2006: * I IDVAL I
2007: * +------------------------------------+
2008: * I BCLEN I
2009: * +------------------------------------+
2010: * I BCBUF I
2011: * +------------------------------------+
2012: *
2013: BCTYP EQU 0 PTR TO DUMMY ROUTINE B$BCT
2014: BCLEN EQU IDVAL+1 DEFINED BUFFER LENGTH
2015: BCBUF EQU BCLEN+1 PTR TO BFBLK
2016: BCSI$ EQU BCBUF+1 SIZE OF BCBLK
2017: *
2018: * A BCBLK IS AN INDIRECT CONTROL HEADER FOR BFBLK.
2019: * THE REASON FOR NOT STORING THIS DATA DIRECTLY
2020: * IN THE RELATED BFBLK IS SO THAT THE BFBLK CAN
2021: * MAINTAIN THE SAME SKELETAL STRUCTURE AS AN SCBLK
2022: * THUS FACILITATING TRANSPARENT STRING OPERATIONS
2023: * (FOR THE MOST PART). SPECIFICALLY, CFP$F IS THE
2024: * SAME FOR A BFBLK AS FOR AN SCBLK. BY CONVENTION,
2025: * WHEREEVER A BUFFER VALUE IS EMPLOYED, THE BCBLK
2026: * IS POINTED TO.
2027: *
2028: * THE CORRESPONDING BFBLK IS POINTED TO BY THE
2029: * BCBUF POINTER IN THE BCBLK.
2030: *
2031: * BCLEN IS THE CURRENT DEFINED SIZE OF THE CHARACTER
2032: * ARRAY IN THE BFBLK. CHARACTERS FOLLOWING THE OFFSET
2033: * OF BCLEN ARE UNDEFINED.
2034: *
2035: EJC
2036: *
2037: * STRING BUFFER BLOCK (BFBLK)
2038: *
2039: * A BFBLK IS BUILT BY A CALL TO BUFFER(...)
2040: *
2041: * +------------------------------------+
2042: * I BFTYP I
2043: * +------------------------------------+
2044: * I BFALC I
2045: * +------------------------------------+
2046: * / /
2047: * / BFCHR /
2048: * / /
2049: * +------------------------------------+
2050: *
2051: BFTYP EQU 0 PTR TO DUMMY ROUTINE B$BFT
2052: BFALC EQU BFTYP+1 ALLOCATED SIZE OF BUFFER
2053: BFCHR EQU BFALC+1 CHARACTERS OF STRING
2054: BFSI$ EQU BFCHR SIZE OF STANDARD FIELDS IN BFBLK
2055: *
2056: * THE CHARACTERS IN THE BUFFER ARE STORED LEFT JUSTIFIED.
2057: * THE FINAL WORD OF DEFINED CHARACTERS IS ALWAYS ZERO
2058: * (CHARACTER) PADDED. ANY TRAILING ALLOCATION PAST THE
2059: * WORD CONTAINING THE LAST CHARACTER CONTAINS
2060: * UNPREDICTABLE CONTENTS AND IS NEVER REFERENCED.
2061: *
2062: * NOTE THAT THE OFFSET TO THE CHARACTERS OF THE STRING
2063: * IS GIVEN BY CFP$F, AS WITH AN SCBLK. HOWEVER, THE
2064: * OFFSET WHICH IS OCCUPIED BY THE LENGTH FOR AN SCBLK
2065: * IS THE TOTAL CHAR SPACE FOR BFBLKS, AND ROUTINES WHICH
2066: * DEAL WITH BOTH MUST ACCOUNT FOR THIS DIFFERENCE.
2067: *
2068: * THE VALUE OF BFALC MAY NOT EXCEED MXLEN. THE VALUE OF
2069: * BCLEN IS ALWAYS LESS THAN OR EQUAL TO BFALC.
2070: *
2071: EJC
2072: *
2073: * CODE CONSTRUCTION BLOCK (CCBLK)
2074: *
2075: * AT ANY ONE MOMENT THERE IS AT MOST ONE CCBLK INTO
2076: * WHICH THE COMPILER IS CURRENTLY STORING CODE (CDWRD).
2077: *
2078: * +------------------------------------+
2079: * I CCTYP I
2080: * +------------------------------------+
2081: * I CCLEN I
2082: * +------------------------------------+
2083: * I CCUSE I
2084: * +------------------------------------+
2085: * / /
2086: * / CCCOD /
2087: * / /
2088: * +------------------------------------+
2089: *
2090: CCTYP EQU 0 POINTER TO DUMMY ROUTINE B$CCT
2091: CCLEN EQU CCTYP+1 LENGTH OF CCBLK IN BYTES
2092: CCUSE EQU CCLEN+1 OFFSET PAST LAST USED WORD (BYTES)
2093: CCCOD EQU CCUSE+1 START OF GENERATED CODE IN BLOCK
2094: *
2095: * THE REASON THAT THE CCBLK IS A SEPARATE BLOCK TYPE FROM
2096: * THE USUAL CDBLK IS THAT THE GARBAGE COLLECTOR MUST
2097: * ONLY PROCESS THOSE FIELDS WHICH HAVE BEEN SET (SEE GBCPF)
2098: EJC
2099: *
2100: * CODE BLOCK (CDBLK)
2101: *
2102: * A CODE BLOCK IS BUILT FOR EACH STATEMENT COMPILED DURING
2103: * THE INITIAL COMPILATION OR BY SUBSEQUENT CALLS TO CODE.
2104: *
2105: * +------------------------------------+
2106: * I CDJMP I
2107: * +------------------------------------+
2108: * I CDSTM I
2109: * +------------------------------------+
2110: * I CDLEN I
2111: * +------------------------------------+
2112: * I CDFAL I
2113: * +------------------------------------+
2114: * / /
2115: * / CDCOD /
2116: * / /
2117: * +------------------------------------+
2118: *
2119: CDJMP EQU 0 PTR TO ROUTINE TO EXECUTE STATEMENT
2120: CDSTM EQU CDJMP+1 STATEMENT NUMBER
2121: CDLEN EQU OFFS2 LENGTH OF CDBLK IN BYTES
2122: CDFAL EQU OFFS3 FAILURE EXIT (SEE BELOW)
2123: CDCOD EQU CDFAL+1 EXECUTABLE PSEUDO-CODE
2124: CDSI$ EQU CDCOD NUMBER OF STANDARD FIELDS IN CDBLK
2125: *
2126: * CDSTM IS THE STATEMENT NUMBER OF THE CURRENT STATEMENT.
2127: *
2128: * CDJMP, CDFAL ARE SET AS FOLLOWS.
2129: *
2130: * 1) IF THE FAILURE EXIT IS THE NEXT STATEMENT
2131: *
2132: * CDJMP = B$CDS
2133: * CDFAL = PTR TO CDBLK FOR NEXT STATEMENT
2134: *
2135: * 2) IF THE FAILURE EXIT IS A SIMPLE LABEL NAME
2136: *
2137: * CDJMP = B$CDS
2138: * CDFAL IS A PTR TO THE VRTRA FIELD OF THE VRBLK
2139: *
2140: * 3) IF THERE IS NO FAILURE EXIT (-NOFAIL MODE)
2141: *
2142: * CDJMP = B$CDS
2143: * CDFAL = O$UNF
2144: *
2145: * 4) IF THE FAILURE EXIT IS COMPLEX OR DIRECT
2146: *
2147: * CDJMP = B$CDC
2148: * CDFAL IS THE OFFSET TO THE O$GOF WORD
2149: EJC
2150: *
2151: * CODE BLOCK (CONTINUED)
2152: *
2153: * CDCOD IS THE START OF THE ACTUAL CODE. FIRST WE DESCRIBE
2154: * THE CODE GENERATED FOR AN EXPRESSION. IN AN EXPRESSION,
2155: * ELEMENTS ARE FETCHED BY NAME OR BY VALUE. FOR EXAMPLE,
2156: * THE BINARY EQUAL OPERATOR FETCHES ITS LEFT ARGUMENT
2157: * BY NAME AND ITS RIGHT ARGUMENT BY VALUE. THESE TWO
2158: * CASES GENERATE QUITE DIFFERENT CODE AND ARE DESCRIBED
2159: * SEPARATELY. FIRST WE CONSIDER THE CODE BY VALUE CASE.
2160: *
2161: * GENERATION OF CODE BY VALUE FOR EXPRESSIONS ELEMENTS.
2162: *
2163: * EXPRESSION POINTER TO EXBLK OR SEBLK
2164: *
2165: * INTEGER CONSTANT POINTER TO ICBLK
2166: *
2167: * NULL CONSTANT POINTER TO NULLS
2168: *
2169: * PATTERN (RESULTING FROM PREEVALUATION)
2170: * =O$LPT
2171: * POINTER TO P0BLK,P1BLK OR P2BLK
2172: *
2173: * REAL CONSTANT POINTER TO RCBLK
2174: *
2175: * STRING CONSTANT POINTER TO SCBLK
2176: *
2177: * VARIABLE POINTER TO VRGET FIELD OF VRBLK
2178: *
2179: * ADDITION VALUE CODE FOR LEFT OPERAND
2180: * VALUE CODE FOR RIGHT OPERAND
2181: * =O$ADD
2182: *
2183: * AFFIRMATION VALUE CODE FOR OPERAND
2184: * =O$AFF
2185: *
2186: * ALTERNATION VALUE CODE FOR LEFT OPERAND
2187: * VALUE CODE FOR RIGHT OPERAND
2188: * =O$ALT
2189: *
2190: * ARRAY REFERENCE (CASE OF ONE SUBSCRIPT)
2191: * VALUE CODE FOR ARRAY OPERAND
2192: * VALUE CODE FOR SUBSCRIPT OPERAND
2193: * =O$AOV
2194: *
2195: * (CASE OF MORE THAN ONE SUBSCRIPT)
2196: * VALUE CODE FOR ARRAY OPERAND
2197: * VALUE CODE FOR FIRST SUBSCRIPT
2198: * VALUE CODE FOR SECOND SUBSCRIPT
2199: * ...
2200: * VALUE CODE FOR LAST SUBSCRIPT
2201: * =O$AMV
2202: * NUMBER OF SUBSCRIPTS
2203: EJC
2204: *
2205: * CODE BLOCK (CONTINUED)
2206: *
2207: * ASSIGNMENT (TO NATURAL VARIABLE)
2208: * VALUE CODE FOR RIGHT OPERAND
2209: * POINTER TO VRSTO FIELD OF VRBLK
2210: *
2211: * (TO ANY OTHER VARIABLE)
2212: * NAME CODE FOR LEFT OPERAND
2213: * VALUE CODE FOR RIGHT OPERAND
2214: * =O$ASS
2215: *
2216: * COMPILE ERROR =O$CER
2217: *
2218: *
2219: * COMPLEMENTATION VALUE CODE FOR OPERAND
2220: * =O$COM
2221: *
2222: * CONCATENATION (CASE OF PRED FUNC LEFT OPERAND)
2223: * VALUE CODE FOR LEFT OPERAND
2224: * =O$POP
2225: * VALUE CODE FOR RIGHT OPERAND
2226: *
2227: * (ALL OTHER CASES)
2228: * VALUE CODE FOR LEFT OPERAND
2229: * VALUE CODE FOR RIGHT OPERAND
2230: * =O$CNC
2231: *
2232: * CURSOR ASSIGNMENT NAME CODE FOR OPERAND
2233: * =O$CAS
2234: *
2235: * DIVISION VALUE CODE FOR LEFT OPERAND
2236: * VALUE CODE FOR RIGHT OPERAND
2237: * =O$DVD
2238: *
2239: * EXPONENTIATION VALUE CODE FOR LEFT OPERAND
2240: * VALUE CODE FOR RIGHT OPERAND
2241: * =O$EXP
2242: *
2243: * FUNCTION CALL (CASE OF CALL TO SYSTEM FUNCTION)
2244: * VALUE CODE FOR FIRST ARGUMENT
2245: * VALUE CODE FOR SECOND ARGUMENT
2246: * ...
2247: * VALUE CODE FOR LAST ARGUMENT
2248: * POINTER TO SVFNC FIELD OF SVBLK
2249: *
2250: EJC
2251: *
2252: * CODE BLOCK (CONTINUED)
2253: *
2254: * FUNCTION CALL (CASE OF NON-SYSTEM FUNCTION 1 ARG)
2255: * VALUE CODE FOR ARGUMENT
2256: * =O$FNS
2257: * POINTER TO VRBLK FOR FUNCTION
2258: *
2259: * (NON-SYSTEM FUNCTION, GT 1 ARG)
2260: * VALUE CODE FOR FIRST ARGUMENT
2261: * VALUE CODE FOR SECOND ARGUMENT
2262: * ...
2263: * VALUE CODE FOR LAST ARGUMENT
2264: * =O$FNC
2265: * NUMBER OF ARGUMENTS
2266: * POINTER TO VRBLK FOR FUNCTION
2267: *
2268: * IMMEDIATE ASSIGNMENT VALUE CODE FOR LEFT OPERAND
2269: * NAME CODE FOR RIGHT OPERAND
2270: * =O$IMA
2271: *
2272: * INDIRECTION VALUE CODE FOR OPERAND
2273: * =O$INV
2274: *
2275: * INTERROGATION VALUE CODE FOR OPERAND
2276: * =O$INT
2277: *
2278: * KEYWORD REFERENCE NAME CODE FOR OPERAND
2279: * =O$KWV
2280: *
2281: * MULTIPLICATION VALUE CODE FOR LEFT OPERAND
2282: * VALUE CODE FOR RIGHT OPERAND
2283: * =O$MLT
2284: *
2285: * NAME REFERENCE (NATURAL VARIABLE CASE)
2286: * POINTER TO NMBLK FOR NAME
2287: *
2288: * (ALL OTHER CASES)
2289: * NAME CODE FOR OPERAND
2290: * =O$NAM
2291: *
2292: * NEGATION =O$NTA
2293: * CDBLK OFFSET OF O$NTC WORD
2294: * VALUE CODE FOR OPERAND
2295: * =O$NTB
2296: * =O$NTC
2297: EJC
2298: *
2299: * CODE BLOCK (CONTINUED)
2300: *
2301: * PATTERN ASSIGNMENT VALUE CODE FOR LEFT OPERAND
2302: * NAME CODE FOR RIGHT OPERAND
2303: * =O$PAS
2304: *
2305: * PATTERN MATCH VALUE CODE FOR LEFT OPERAND
2306: * VALUE CODE FOR RIGHT OPERAND
2307: * =O$PMV
2308: *
2309: * PATTERN REPLACEMENT NAME CODE FOR SUBJECT
2310: * VALUE CODE FOR PATTERN
2311: * =O$PMN
2312: * VALUE CODE FOR REPLACEMENT
2313: * =O$RPL
2314: *
2315: * SELECTION (FOR FIRST ALTERNATIVE)
2316: * =O$SLA
2317: * CDBLK OFFSET TO NEXT O$SLC WORD
2318: * VALUE CODE FOR FIRST ALTERNATIVE
2319: * =O$SLB
2320: * CDBLK OFFSET PAST ALTERNATIVES
2321: *
2322: * (FOR SUBSEQUENT ALTERNATIVES)
2323: * =O$SLC
2324: * CDBLK OFFSET TO NEXT O$SLC,O$SLD
2325: * VALUE CODE FOR ALTERNATIVE
2326: * =O$SLB
2327: * OFFSET IN CDBLK PAST ALTERNATIVES
2328: *
2329: * (FOR LAST ALTERNATIVE)
2330: * =O$SLD
2331: * VALUE CODE FOR LAST ALTERNATIVE
2332: *
2333: * SUBTRACTION VALUE CODE FOR LEFT OPERAND
2334: * VALUE CODE FOR RIGHT OPERAND
2335: * =O$SUB
2336: EJC
2337: *
2338: * CODE BLOCK (CONTINUED)
2339: *
2340: * GENERATION OF CODE BY NAME FOR EXPRESSION ELEMENTS.
2341: *
2342: * VARIABLE =O$LVN
2343: * POINTER TO VRBLK
2344: *
2345: * EXPRESSION (CASE OF *NATURAL VARIABLE)
2346: * =O$LVN
2347: * POINTER TO VRBLK
2348: *
2349: * (ALL OTHER CASES)
2350: * =O$LEX
2351: * POINTER TO EXBLK
2352: *
2353: *
2354: * ARRAY REFERENCE (CASE OF ONE SUBSCRIPT)
2355: * VALUE CODE FOR ARRAY OPERAND
2356: * VALUE CODE FOR SUBSCRIPT OPERAND
2357: * =O$AON
2358: *
2359: * (CASE OF MORE THAN ONE SUBSCRIPT)
2360: * VALUE CODE FOR ARRAY OPERAND
2361: * VALUE CODE FOR FIRST SUBSCRIPT
2362: * VALUE CODE FOR SECOND SUBSCRIPT
2363: * ...
2364: * VALUE CODE FOR LAST SUBSCRIPT
2365: * =O$AMN
2366: * NUMBER OF SUBSCRIPTS
2367: *
2368: * COMPILE ERROR =O$CER
2369: *
2370: * FUNCTION CALL (SAME CODE AS FOR VALUE CALL)
2371: * =O$FNE
2372: *
2373: * INDIRECTION VALUE CODE FOR OPERAND
2374: * =O$INN
2375: *
2376: * KEYWORD REFERENCE NAME CODE FOR OPERAND
2377: * =O$KWN
2378: *
2379: * ANY OTHER OPERAND IS AN ERROR IN A NAME POSITION
2380: *
2381: * NOTE THAT IN THIS DESCRIPTION, =O$XXX REFERS TO THE
2382: * GENERATION OF A WORD CONTAINING THE ADDRESS OF ANOTHER
2383: * WORD WHICH CONTAINS THE ENTRY POINT ADDRESS O$XXX.
2384: EJC
2385: *
2386: * CODE BLOCK (CONTINUED)
2387: *
2388: * NOW WE CONSIDER THE OVERALL STRUCTURE OF THE CODE BLOCK
2389: * FOR A STATEMENT WITH POSSIBLE GOTO FIELDS.
2390: *
2391: * FIRST COMES THE CODE FOR THE STATEMENT BODY.
2392: * THE STATEMENT BODY IS AN EXPRESSION TO BE EVALUATED
2393: * BY VALUE ALTHOUGH THE VALUE IS NOT ACTUALLY REQUIRED.
2394: * NORMAL VALUE CODE IS GENERATED FOR THE BODY OF THE
2395: * STATEMENT EXCEPT IN THE CASE OF A PATTERN MATCH BY
2396: * VALUE, IN WHICH CASE THE FOLLOWING IS GENERATED.
2397: *
2398: * VALUE CODE FOR LEFT OPERAND
2399: * VALUE CODE FOR RIGHT OPERAND
2400: * =O$PMS
2401: *
2402: * NEXT WE HAVE THE CODE FOR THE SUCCESS GOTO. THERE ARE
2403: * SEVERAL CASES AS FOLLOWS.
2404: *
2405: * 1) NO SUCCESS GOTO PTR TO CDBLK FOR NEXT STATEMENT
2406: *
2407: * 2) SIMPLE LABEL PTR TO VRTRA FIELD OF VRBLK
2408: *
2409: * 3) COMPLEX GOTO (CODE BY NAME FOR GOTO OPERAND)
2410: * =O$GOC
2411: *
2412: * 4) DIRECT GOTO (CODE BY VALUE FOR GOTO OPERAND)
2413: * =O$GOD
2414: *
2415: * FOLLOWING THIS WE GENERATE CODE FOR THE FAILURE GOTO IF
2416: * IT IS DIRECT OR IF IT IS COMPLEX, SIMPLE FAILURE GOTOS
2417: * HAVING BEEN HANDLED BY AN APPROPRIATE SETTING OF THE
2418: * CDFAL FIELD OF THE CDBLK. THE GENERATED CODE IS ONE
2419: * OF THE FOLLOWING.
2420: *
2421: * 1) COMPLEX FGOTO =O$FIF
2422: * =O$GOF
2423: * NAME CODE FOR GOTO OPERAND
2424: * =O$GOC
2425: *
2426: * 2) DIRECT FGOTO =O$FIF
2427: * =O$GOF
2428: * VALUE CODE FOR GOTO OPERAND
2429: * =O$GOD
2430: *
2431: * AN OPTIMIZATION OCCURS IF THE SUCCESS AND FAILURE GOTOS
2432: * ARE IDENTICAL AND EITHER COMPLEX OR DIRECT. IN THIS CASE,
2433: * NO CODE IS GENERATED FOR THE SUCCESS GOTO AND CONTROL
2434: * IS ALLOWED TO FALL INTO THE FAILURE GOTO ON SUCCESS.
2435: EJC
2436: *
2437: * COMPILER BLOCK (CMBLK)
2438: *
2439: * A COMPILER BLOCK (CMBLK) IS BUILT BY EXPAN TO REPRESENT
2440: * ONE NODE OF A TREE STRUCTURED EXPRESSION REPRESENTATION.
2441: *
2442: * +------------------------------------+
2443: * I CMIDN I
2444: * +------------------------------------+
2445: * I CMLEN I
2446: * +------------------------------------+
2447: * I CMTYP I
2448: * +------------------------------------+
2449: * I CMOPN I
2450: * +------------------------------------+
2451: * / CMVLS OR CMROP /
2452: * / /
2453: * / CMLOP /
2454: * / /
2455: * +------------------------------------+
2456: *
2457: CMIDN EQU 0 POINTER TO DUMMY ROUTINE B$CMT
2458: CMLEN EQU CMIDN+1 LENGTH OF CMBLK IN BYTES
2459: CMTYP EQU CMLEN+1 TYPE (C$XXX, SEE LIST BELOW)
2460: CMOPN EQU CMTYP+1 OPERAND POINTER (SEE BELOW)
2461: CMVLS EQU CMOPN+1 OPERAND VALUE POINTERS (SEE BELOW)
2462: CMROP EQU CMVLS RIGHT (ONLY) OPERATOR OPERAND
2463: CMLOP EQU CMVLS+1 LEFT OPERATOR OPERAND
2464: CMSI$ EQU CMVLS NUMBER OF STANDARD FIELDS IN CMBLK
2465: CMUS$ EQU CMSI$+1 SIZE OF UNARY OPERATOR CMBLK
2466: CMBS$ EQU CMSI$+2 SIZE OF BINARY OPERATOR CMBLK
2467: CMAR1 EQU CMVLS+1 ARRAY SUBSCRIPT POINTERS
2468: *
2469: * THE CMOPN AND CMVLS FIELDS ARE SET AS FOLLOWS
2470: *
2471: * ARRAY REFERENCE CMOPN = PTR TO ARRAY OPERAND
2472: * CMVLS = PTRS TO SUBSCRIPT OPERANDS
2473: *
2474: * FUNCTION CALL CMOPN = PTR TO VRBLK FOR FUNCTION
2475: * CMVLS = PTRS TO ARGUMENT OPERANDS
2476: *
2477: * SELECTION CMOPN = ZERO
2478: * CMVLS = PTRS TO ALTERNATE OPERANDS
2479: *
2480: * UNARY OPERATOR CMOPN = PTR TO OPERATOR DVBLK
2481: * CMROP = PTR TO OPERAND
2482: *
2483: * BINARY OPERATOR CMOPN = PTR TO OPERATOR DVBLK
2484: * CMROP = PTR TO RIGHT OPERAND
2485: * CMLOP = PTR TO LEFT OPERAND
2486: EJC
2487: *
2488: * CMTYP IS SET TO INDICATE THE TYPE OF EXPRESSION ELEMENT
2489: * AS SHOWN BY THE FOLLOWING TABLE OF DEFINITIONS.
2490: *
2491: C$ARR EQU 0 ARRAY REFERENCE
2492: C$FNC EQU C$ARR+1 FUNCTION CALL
2493: C$DEF EQU C$FNC+1 DEFERRED EXPRESSION (UNARY *)
2494: C$IND EQU C$DEF+1 INDIRECTION (UNARY $)
2495: C$KEY EQU C$IND+1 KEYWORD REFERENCE (UNARY AMPERSAND)
2496: C$UBO EQU C$KEY+1 UNDEFINED BINARY OPERATOR
2497: C$UUO EQU C$UBO+1 UNDEFINED UNARY OPERATOR
2498: C$UO$ EQU C$UUO+1 TEST VALUE (=C$UUO+1=C$UBO+2)
2499: C$$NM EQU C$UUO+1 NUMBER OF CODES FOR NAME OPERANDS
2500: *
2501: * THE REMAINING TYPES INDICATE EXPRESSION ELEMENTS WHICH
2502: * CAN ONLY BE EVALUATED BY VALUE (NOT BY NAME).
2503: *
2504: C$BVL EQU C$UUO+1 BINARY OP WITH VALUE OPERANDS
2505: C$UVL EQU C$BVL+1 UNARY OPERATOR WITH VALUE OPERAND
2506: C$ALT EQU C$UVL+1 ALTERNATION (BINARY BAR)
2507: C$CNC EQU C$ALT+1 CONCATENATION
2508: C$CNP EQU C$CNC+1 CONCATENATION, NOT PATTERN MATCH
2509: C$UNM EQU C$CNP+1 UNARY OP WITH NAME OPERAND
2510: C$BVN EQU C$UNM+1 BINARY OP (OPERANDS BY VALUE, NAME)
2511: C$ASS EQU C$BVN+1 ASSIGNMENT
2512: C$INT EQU C$ASS+1 INTERROGATION
2513: C$NEG EQU C$INT+1 NEGATION (UNARY NOT)
2514: C$SEL EQU C$NEG+1 SELECTION
2515: C$PMT EQU C$SEL+1 PATTERN MATCH
2516: *
2517: C$PR$ EQU C$BVN LAST PREEVALUABLE CODE
2518: C$$NV EQU C$PMT+1 NUMBER OF DIFFERENT CMBLK TYPES
2519: EJC
2520: *
2521: * CHARACTER TABLE BLOCK (CTBLK)
2522: *
2523: * A CHARACTER TABLE BLOCK IS USED TO HOLD LOGICAL CHARACTER
2524: * TABLES FOR USE WITH ANY,NOTANY,SPAN,BREAK,BREAKX
2525: * PATTERNS. EACH CHARACTER TABLE CAN BE USED TO STORE
2526: * CFP$N DISTINCT TABLES AS BIT COLUMNS. A BIT COLUMN
2527: * ALLOCATED FOR EACH ARGUMENT OF MORE THAN ONE CHARACTER
2528: * IN LENGTH TO ONE OF THE ABOVE LISTED PATTERN PRIMITIVES.
2529: *
2530: * +------------------------------------+
2531: * I CTTYP I
2532: * +------------------------------------+
2533: * * *
2534: * * *
2535: * * CTCHS *
2536: * * *
2537: * * *
2538: * +------------------------------------+
2539: *
2540: CTTYP EQU 0 POINTER TO DUMMY ROUTINE B$CTT
2541: CTCHS EQU CTTYP+1 START OF CHARACTER TABLE WORDS
2542: CTSI$ EQU CTCHS+CFP$A NUMBER OF WORDS IN CTBLK
2543: *
2544: * CTCHS IS CFP$A WORDS LONG AND CONSISTS OF A ONE WORD
2545: * BIT STRING VALUE FOR EACH POSSIBLE CHARACTER IN THE
2546: * INTERNAL ALPHABET. EACH OF THE CFP$N POSSIBLE BITS IN
2547: * A BITSTRING IS USED TO FORM A COLUMN OF BIT INDICATORS.
2548: * A BIT IS SET ON IF THE CHARACTER IS IN THE TABLE AND OFF
2549: * IF THE CHARACTER IS NOT PRESENT.
2550: EJC
2551: *
2552: * DATATYPE FUNCTION BLOCK (DFBLK)
2553: *
2554: * A DATATYPE FUNCTION IS USED TO CONTROL THE CONSTRUCTION
2555: * OF A PROGRAM DEFINED DATATYPE OBJECT. A CALL TO THE
2556: * SYSTEM FUNCTION DATA BUILDS A DFBLK FOR THE DATATYPE NAME
2557: *
2558: * NOTE THAT THESE BLOCKS ARE BUILT IN STATIC BECAUSE PDBLK
2559: * LENGTH IS GOT FROM DFLEN FIELD. IF DFBLK WAS IN DYNAMIC
2560: * STORE THIS WOULD CAUSE TROUBLE DURING PASS TWO OF GARBAGE
2561: * COLLECTION. SCBLK REFERRED TO BY DFNAM FIELD IS ALSO PUT
2562: * IN STATIC SO THAT THERE ARE NO RELOC. FIELDS. THIS CUTS
2563: * GARBAGE COLLECTION TASK APPRECIABLY FOR PDBLKS WHICH ARE
2564: * LIKELY TO BE PRESENT IN LARGE NUMBERS.
2565: *
2566: * +------------------------------------+
2567: * I FCODE I
2568: * +------------------------------------+
2569: * I FARGS I
2570: * +------------------------------------+
2571: * I DFLEN I
2572: * +------------------------------------+
2573: * I DFPDL I
2574: * +------------------------------------+
2575: * I DFNAM I
2576: * +------------------------------------+
2577: * / /
2578: * / DFFLD /
2579: * / /
2580: * +------------------------------------+
2581: *
2582: DFLEN EQU FARGS+1 LENGTH OF DFBLK IN BYTES
2583: DFPDL EQU DFLEN+1 LENGTH OF CORRESPONDING PDBLK
2584: DFNAM EQU DFPDL+1 POINTER TO SCBLK FOR DATATYPE NAME
2585: DFFLD EQU DFNAM+1 START OF VRBLK PTRS FOR FIELD NAMES
2586: DFFLB EQU DFFLD-1 OFFSET BEHIND DFFLD FOR FIELD FUNC
2587: DFSI$ EQU DFFLD NUMBER OF STANDARD FIELDS IN DFBLK
2588: *
2589: * THE FCODE FIELD POINTS TO THE ROUTINE B$DFC
2590: *
2591: * FARGS (THE NUMBER OF ARGUMENTS) IS THE NUMBER OF FIELDS.
2592: EJC
2593: *
2594: * DOPE VECTOR BLOCK (DVBLK)
2595: *
2596: * A DOPE VECTOR IS ASSEMBLED FOR EACH POSSIBLE OPERATOR IN
2597: * THE SNOBOL4 LANGUAGE AS PART OF THE CONSTANT SECTION.
2598: *
2599: * +------------------------------------+
2600: * I DVOPN I
2601: * +------------------------------------+
2602: * I DVTYP I
2603: * +------------------------------------+
2604: * I DVLPR I
2605: * +------------------------------------+
2606: * I DVRPR I
2607: * +------------------------------------+
2608: *
2609: DVOPN EQU 0 ENTRY ADDRESS (PTR TO O$XXX)
2610: DVTYP EQU DVOPN+1 TYPE CODE (C$XXX, SEE CMBLK)
2611: DVLPR EQU DVTYP+1 LEFT PRECEDENCE (LLXXX, SEE BELOW)
2612: DVRPR EQU DVLPR+1 RIGHT PRECEDENCE (RRXXX, SEE BELOW)
2613: DVUS$ EQU DVLPR+1 SIZE OF UNARY OPERATOR DV
2614: DVBS$ EQU DVRPR+1 SIZE OF BINARY OPERATOR DV
2615: DVUBS EQU DVUS$+DVBS$ SIZE OF UNOP + BINOP (SEE SCANE)
2616: *
2617: * THE CONTENTS OF THE DVTYP FIELD IS COPIED INTO THE CMTYP
2618: * FIELD OF THE CMBLK FOR THE OPERATOR IF IT IS USED.
2619: *
2620: * THE CMOPN FIELD OF AN OPERATOR CMBLK POINTS TO THE DVBLK
2621: * ITSELF, PROVIDING THE REQUIRED ENTRY ADDRESS POINTER PTR.
2622: *
2623: * FOR NORMALLY UNDEFINED OPERATORS, THE DVOPN (AND CMOPN)
2624: * FIELDS CONTAIN A WORD OFFSET FROM R$UBA OF THE FUNCTION
2625: * BLOCK POINTER FOR THE OPERATOR (INSTEAD OF O$XXX PTR).
2626: * FOR CERTAIN SPECIAL OPERATORS, THE DVOPN FIELD IS NOT
2627: * REQUIRED AT ALL AND IS ASSEMBLED AS ZERO.
2628: *
2629: * THE LEFT PRECEDENCE IS USED IN COMPARING AN OPERATOR TO
2630: * THE LEFT OF SOME OTHER OPERATOR. IT THEREFORE GOVERNS THE
2631: * PRECEDENCE OF THE OPERATOR TOWARDS ITS RIGHT OPERAND.
2632: *
2633: * THE RIGHT PRECEDENCE IS USED IN COMPARING AN OPERATOR TO
2634: * THE RIGHT OF SOME OTHER OPERATOR. IT THEREFORE GOVERNS
2635: * THE PRECEDENCE OF THE OPERATOR TOWARDS ITS LEFT OPERAND.
2636: *
2637: * HIGHER PRECEDENCE VALUES CORRESPOND TO A TIGHTER BINDING
2638: * CAPABILITY. THUS WE HAVE THE LEFT PRECEDENCE LOWER
2639: * (HIGHER) THAN THE RIGHT PRECEDENCE FOR RIGHT (LEFT)
2640: * ASSOCIATIVE BINARY OPERATORS.
2641: *
2642: * THE LEFT PRECEDENCE OF UNARY OPERATORS IS SET TO AN
2643: * ARBITRARY HIGH VALUE. THE RIGHT VALUE IS NOT REQUIRED AND
2644: * CONSEQUENTLY THE DVRPR FIELD IS OMITTED FOR UNARY OPS.
2645: EJC
2646: *
2647: * TABLE OF OPERATOR PRECEDENCE VALUES
2648: *
2649: RRASS EQU 10 RIGHT EQUAL
2650: LLASS EQU 00 LEFT EQUAL
2651: RRPMT EQU 20 RIGHT QUESTION MARK
2652: LLPMT EQU 30 LEFT QUESTION MARK
2653: RRAMP EQU 40 RIGHT AMPERSAND
2654: LLAMP EQU 50 LEFT AMPERSAND
2655: RRALT EQU 70 RIGHT VERTICAL BAR
2656: LLALT EQU 60 LEFT VERTICAL BAR
2657: RRCNC EQU 90 RIGHT BLANK
2658: LLCNC EQU 80 LEFT BLANK
2659: RRATS EQU 110 RIGHT AT
2660: LLATS EQU 100 LEFT AT
2661: RRPLM EQU 120 RIGHT PLUS, MINUS
2662: LLPLM EQU 130 LEFT PLUS, MINUS
2663: RRNUM EQU 140 RIGHT NUMBER
2664: LLNUM EQU 150 LEFT NUMBER
2665: RRDVD EQU 160 RIGHT SLASH
2666: LLDVD EQU 170 LEFT SLASH
2667: RRMLT EQU 180 RIGHT ASTERISK
2668: LLMLT EQU 190 LEFT ASTERISK
2669: RRPCT EQU 200 RIGHT PERCENT
2670: LLPCT EQU 210 LEFT PERCENT
2671: RREXP EQU 230 RIGHT EXCLAMATION
2672: LLEXP EQU 220 LEFT EXCLAMATION
2673: RRDLD EQU 240 RIGHT DOLLAR, DOT
2674: LLDLD EQU 250 LEFT DOLLAR, DOT
2675: RRNOT EQU 270 RIGHT NOT
2676: LLNOT EQU 260 LEFT NOT
2677: LLUNO EQU 999 LEFT ALL UNARY OPERATORS
2678: *
2679: * PRECEDENCES ARE THE SAME AS IN BTL SNOBOL4 WITH THE
2680: * FOLLOWING EXCEPTIONS.
2681: *
2682: * 1) BINARY QUESTION MARK IS LOWERED AND MADE LEFT ASSOC-
2683: * IATIVE TO REFLECT ITS NEW USE FOR PATTERN MATCHING.
2684: *
2685: * 2) ALTERNATION AND CONCATENATION ARE MADE RIGHT
2686: * ASSOCIATIVE FOR GREATER EFFICIENCY IN PATTERN
2687: * CONSTRUCTION AND MATCHING RESPECTIVELY. THIS CHANGE
2688: * IS TRANSPARENT TO THE SNOBOL4 PROGRAMMER.
2689: *
2690: * 3) THE EQUAL SIGN HAS BEEN ADDED AS A LOW PRECEDENCE
2691: * OPERATOR WHICH IS RIGHT ASSOCIATIVE TO REFLECT ITS
2692: * MORE GENERAL USAGE IN THIS VERSION OF SNOBOL4.
2693: EJC
2694: *
2695: * EXTERNAL FUNCTION BLOCK (EFBLK)
2696: *
2697: * AN EXTERNAL FUNCTION BLOCK IS USED TO CONTROL THE CALLING
2698: * OF AN EXTERNAL FUNCTION. IT IS BUILT BY A CALL TO LOAD.
2699: *
2700: * +------------------------------------+
2701: * I FCODE I
2702: * +------------------------------------+
2703: * I FARGS I
2704: * +------------------------------------+
2705: * I EFLEN I
2706: * +------------------------------------+
2707: * I EFUSE I
2708: * +------------------------------------+
2709: * I EFCOD I
2710: * +------------------------------------+
2711: * I EFVAR I
2712: * +------------------------------------+
2713: * I EFRSL I
2714: * +------------------------------------+
2715: * / /
2716: * / EFTAR /
2717: * / /
2718: * +------------------------------------+
2719: *
2720: EFLEN EQU FARGS+1 LENGTH OF EFBLK IN BYTES
2721: EFUSE EQU EFLEN+1 USE COUNT (FOR OPSYN)
2722: EFCOD EQU EFUSE+1 PTR TO CODE (FROM SYSLD)
2723: EFVAR EQU EFCOD+1 PTR TO ASSOCIATED VRBLK
2724: EFRSL EQU EFVAR+1 RESULT TYPE (SEE BELOW)
2725: EFTAR EQU EFRSL+1 ARGUMENT TYPES (SEE BELOW)
2726: EFSI$ EQU EFTAR NUMBER OF STANDARD FIELDS IN EFBLK
2727: *
2728: * THE FCODE FIELD POINTS TO THE ROUTINE B$EFC.
2729: *
2730: * EFUSE IS USED TO KEEP TRACK OF MULTIPLE USE WHEN OPSYN
2731: * IS EMPLOYED. THE FUNCTION IS AUTOMATICALLY UNLOADED
2732: * WHEN THERE ARE NO MORE REFERENCES TO THE FUNCTION.
2733: *
2734: * EFRSL AND EFTAR ARE TYPE CODES AS FOLLOWS.
2735: *
2736: * 0 TYPE IS UNCONVERTED
2737: * 1 TYPE IS STRING
2738: * 2 TYPE IS INTEGER
2739: * 3 TYPE IS REAL
2740: EJC
2741: *
2742: * EXPRESSION VARIABLE BLOCK (EVBLK)
2743: *
2744: * IN THIS VERSION OF SPITBOL, AN EXPRESSION CAN BE USED IN
2745: * ANY POSITION WHICH WOULD NORMALLY EXPECT A NAME (FOR
2746: * EXAMPLE ON THE LEFT SIDE OF EQUALS OR AS THE RIGHT
2747: * ARGUMENT OF BINARY DOT). THIS CORRESPONDS TO THE CREATION
2748: * OF A PSEUDO-VARIABLE WHICH IS REPRESENTED BY A POINTER TO
2749: * AN EXPRESSION VARIABLE BLOCK AS FOLLOWS.
2750: *
2751: * +------------------------------------+
2752: * I EVTYP I
2753: * +------------------------------------+
2754: * I EVEXP I
2755: * +------------------------------------+
2756: * I EVVAR I
2757: * +------------------------------------+
2758: *
2759: EVTYP EQU 0 POINTER TO DUMMY ROUTINE B$EVT
2760: EVEXP EQU EVTYP+1 POINTER TO EXBLK FOR EXPRESSION
2761: EVVAR EQU EVEXP+1 POINTER TO TRBEV DUMMY TRBLK
2762: EVSI$ EQU EVVAR+1 SIZE OF EVBLK
2763: *
2764: * THE NAME OF AN EXPRESSION VARIABLE IS REPRESENTED BY A
2765: * BASE POINTER TO THE EVBLK AND AN OFFSET OF EVVAR. THIS
2766: * VALUE APPEARS TO BE TRAPPED BY THE DUMMY TRBEV BLOCK.
2767: *
2768: * NOTE THAT THERE IS NO NEED TO ALLOW FOR THE CASE OF AN
2769: * EXPRESSION VARIABLE WHICH REFERENCES AN SEBLK SINCE A
2770: * VARIABLE WHICH IS OF THE FORM *VAR IS EQUIVALENT TO VAR.
2771: EJC
2772: *
2773: * EXPRESSION BLOCK (EXBLK)
2774: *
2775: * AN EXPRESSION BLOCK IS BUILT FOR EACH EXPRESSION
2776: * REFERENCED IN A PROGRAM OR CREATED BY EVAL OR CONVERT
2777: * DURING EXECUTION OF A PROGRAM.
2778: *
2779: * +------------------------------------+
2780: * I EXTYP I
2781: * +------------------------------------+
2782: * I EXSTM I
2783: * +------------------------------------+
2784: * I EXLEN I
2785: * +------------------------------------+
2786: * I EXFLC I
2787: * +------------------------------------+
2788: * / /
2789: * / EXCOD /
2790: * / /
2791: * +------------------------------------+
2792: *
2793: EXTYP EQU 0 PTR TO ROUTINE B$EXL TO LOAD EXPR
2794: EXSTM EQU CDSTM STORES STMNT NO. DURING EVALUATION
2795: EXLEN EQU EXSTM+1 LENGTH OF EXBLK IN BYTES
2796: EXFLC EQU EXLEN+1 FAILURE CODE (=O$FEX)
2797: EXCOD EQU EXFLC+1 PSEUDO-CODE FOR EXPRESSION
2798: EXSI$ EQU EXCOD NUMBER OF STANDARD FIELDS IN EXBLK
2799: *
2800: * THERE ARE TWO CASES FOR EXCOD DEPENDING ON WHETHER THE
2801: * EXPRESSION CAN BE EVALUATED BY NAME (SEE DESCRIPTION
2802: * OF CDBLK FOR DETAILS OF CODE FOR EXPRESSIONS).
2803: *
2804: * IF THE EXPRESSION CAN BE EVALUATED BY NAME WE HAVE.
2805: *
2806: * (CODE FOR EXPR BY NAME)
2807: * =O$RNM
2808: *
2809: * IF THE EXPRESSION CAN ONLY BE EVALUATED BY VALUE.
2810: *
2811: * (CODE FOR EXPR BY VALUE)
2812: * =O$RVL
2813: EJC
2814: *
2815: * FIELD FUNCTION BLOCK (FFBLK)
2816: *
2817: * A FIELD FUNCTION BLOCK IS USED TO CONTROL THE SELECTION
2818: * OF A FIELD FROM A PROGRAM DEFINED DATATYPE BLOCK.
2819: * A CALL TO DATA CREATES AN FFBLK FOR EACH FIELD.
2820: *
2821: * +------------------------------------+
2822: * I FCODE I
2823: * +------------------------------------+
2824: * I FARGS I
2825: * +------------------------------------+
2826: * I FFDFP I
2827: * +------------------------------------+
2828: * I FFNXT I
2829: * +------------------------------------+
2830: * I FFOFS I
2831: * +------------------------------------+
2832: *
2833: FFDFP EQU FARGS+1 POINTER TO ASSOCIATED DFBLK
2834: FFNXT EQU FFDFP+1 PTR TO NEXT FFBLK ON CHAIN OR ZERO
2835: FFOFS EQU FFNXT+1 OFFSET (BYTES) TO FIELD IN PDBLK
2836: FFSI$ EQU FFOFS+1 SIZE OF FFBLK IN WORDS
2837: *
2838: * THE FCODE FIELD POINTS TO THE ROUTINE B$FFC.
2839: *
2840: * FARGS ALWAYS CONTAINS ONE.
2841: *
2842: * FFDFP IS USED TO VERIFY THAT THE CORRECT PROGRAM DEFINED
2843: * DATATYPE IS BEING ACCESSED BY THIS CALL.
2844: * FFDFP IS NON-RELOC. BECAUSE DFBLK IS IN STATIC
2845: *
2846: * FFOFS IS USED TO SELECT THE APPROPRIATE FIELD. NOTE THAT
2847: * IT IS AN ACTUAL OFFSET (NOT A FIELD NUMBER)
2848: *
2849: * FFNXT IS USED TO POINT TO THE NEXT FFBLK OF THE SAME NAME
2850: * IN THE CASE WHERE THERE ARE SEVERAL FIELDS OF THE SAME
2851: * NAME FOR DIFFERENT DATATYPES. ZERO MARKS THE END OF CHAIN
2852: EJC
2853: *
2854: * INTEGER CONSTANT BLOCK (ICBLK)
2855: *
2856: * AN ICBLK IS CREATED FOR EVERY INTEGER REFERENCED OR
2857: * CREATED BY A PROGRAM. NOTE HOWEVER THAT CERTAIN INTERNAL
2858: * INTEGER VALUES ARE STORED AS ADDRESSES (E.G. THE LENGTH
2859: * FIELD IN A STRING CONSTANT BLOCK)
2860: *
2861: * +------------------------------------+
2862: * I ICGET I
2863: * +------------------------------------+
2864: * * ICVAL *
2865: * +------------------------------------+
2866: *
2867: ICGET EQU 0 PTR TO ROUTINE B$ICL TO LOAD INT
2868: ICVAL EQU ICGET+1 INTEGER VALUE
2869: ICSI$ EQU ICVAL+CFP$I SIZE OF ICBLK
2870: *
2871: * THE LENGTH OF THE ICVAL FIELD IS CFP$I.
2872: EJC
2873: *
2874: * KEYWORD VARIABLE BLOCK (KVBLK)
2875: *
2876: * A KVBLK IS USED TO REPRESENT A KEYWORD PSEUDO-VARIABLE.
2877: * A KVBLK IS BUILT FOR EACH KEYWORD REFERENCE (KWNAM).
2878: *
2879: * +------------------------------------+
2880: * I KVTYP I
2881: * +------------------------------------+
2882: * I KVVAR I
2883: * +------------------------------------+
2884: * I KVNUM I
2885: * +------------------------------------+
2886: *
2887: KVTYP EQU 0 POINTER TO DUMMY ROUTINE B$KVT
2888: KVVAR EQU KVTYP+1 POINTER TO DUMMY BLOCK TRBKV
2889: KVNUM EQU KVVAR+1 KEYWORD NUMBER
2890: KVSI$ EQU KVNUM+1 SIZE OF KVBLK
2891: *
2892: * THE NAME OF A KEYWORD VARIABLE IS REPRESENTED BY A
2893: * BASE POINTER TO THE KVBLK AND AN OFFSET OF KVVAR. THE
2894: * VALUE APPEARS TO BE TRAPPED BY THE POINTER TO TRBKV.
2895: EJC
2896: *
2897: * NAME BLOCK (NMBLK)
2898: *
2899: * A NAME BLOCK IS USED WHEREVER A NAME MUST BE STORED AS
2900: * A VALUE FOLLOWING USE OF THE UNARY DOT OPERATOR.
2901: *
2902: * +------------------------------------+
2903: * I NMTYP I
2904: * +------------------------------------+
2905: * I NMBAS I
2906: * +------------------------------------+
2907: * I NMOFS I
2908: * +------------------------------------+
2909: *
2910: NMTYP EQU 0 PTR TO ROUTINE B$NML TO LOAD NAME
2911: NMBAS EQU NMTYP+1 BASE POINTER FOR VARIABLE
2912: NMOFS EQU NMBAS+1 OFFSET FOR VARIABLE
2913: NMSI$ EQU NMOFS+1 SIZE OF NMBLK
2914: *
2915: * THE ACTUAL FIELD REPRESENTING THE CONTENTS OF THE NAME
2916: * IS FOUND NMOFS BYTES PAST THE ADDRESS IN NMBAS.
2917: *
2918: * THE NAME IS SPLIT INTO BASE AND OFFSET FORM TO AVOID
2919: * CREATION OF A POINTER INTO THE MIDDLE OF A BLOCK WHICH
2920: * COULD NOT BE HANDLED PROPERLY BY THE GARBAGE COLLECTOR.
2921: *
2922: * A NAME MAY BE BUILT FOR ANY VARIABLE (SEE SECTION ON
2923: * REPRESENTATIONS OF VARIABLES) THIS INCLUDES THE
2924: * CASES OF PSEUDO-VARIABLES.
2925: EJC
2926: *
2927: * PATTERN BLOCK, NO PARAMETERS (P0BLK)
2928: *
2929: * A P0BLK IS USED TO REPRESENT PATTERN NODES WHICH DO
2930: * NOT REQUIRE THE USE OF ANY PARAMETER VALUES.
2931: *
2932: * +------------------------------------+
2933: * I PCODE I
2934: * +------------------------------------+
2935: * I PTHEN I
2936: * +------------------------------------+
2937: *
2938: PCODE EQU 0 PTR TO MATCH ROUTINE (P$XXX)
2939: PTHEN EQU PCODE+1 POINTER TO SUBSEQUENT NODE
2940: PASI$ EQU PTHEN+1 SIZE OF P0BLK
2941: *
2942: * PTHEN POINTS TO THE PATTERN BLOCK FOR THE SUBSEQUENT
2943: * NODE TO BE MATCHED. THIS IS A POINTER TO THE PATTERN
2944: * BLOCK NDNTH IF THERE IS NO SUBSEQUENT (END OF PATTERN)
2945: *
2946: * PCODE IS A POINTER TO THE MATCH ROUTINE FOR THE NODE.
2947: EJC
2948: *
2949: * PATTERN BLOCK (ONE PARAMETER)
2950: *
2951: * A P1BLK IS USED TO REPRESENT PATTERN NODES WHICH
2952: * REQUIRE ONE PARAMETER VALUE.
2953: *
2954: * +------------------------------------+
2955: * I PCODE I
2956: * +------------------------------------+
2957: * I PTHEN I
2958: * +------------------------------------+
2959: * I PARM1 I
2960: * +------------------------------------+
2961: *
2962: PARM1 EQU PTHEN+1 FIRST PARAMETER VALUE
2963: PBSI$ EQU PARM1+1 SIZE OF P1BLK IN WORDS
2964: *
2965: * SEE P0BLK FOR DEFINITIONS OF PCODE, PTHEN
2966: *
2967: * PARM1 CONTAINS A PARAMETER VALUE USED IN MATCHING THE
2968: * NODE. FOR EXAMPLE, IN A LEN PATTERN, IT IS THE INTEGER
2969: * ARGUMENT TO LEN. THE DETAILS OF THE USE OF THE PARAMETER
2970: * FIELD ARE INCLUDED IN THE DESCRIPTION OF THE INDIVIDUAL
2971: * MATCH ROUTINES. PARM1 IS ALWAYS AN ADDRESS POINTER WHICH
2972: * IS PROCESSED BY THE GARBAGE COLLECTOR.
2973: EJC
2974: *
2975: * PATTERN BLOCK (TWO PARAMETERS)
2976: *
2977: * A P2BLK IS USED TO REPRESENT PATTERN NODES WHICH
2978: * REQUIRE TWO PARAMETER VALUES.
2979: *
2980: * +------------------------------------+
2981: * I PCODE I
2982: * +------------------------------------+
2983: * I PTHEN I
2984: * +------------------------------------+
2985: * I PARM1 I
2986: * +------------------------------------+
2987: * I PARM2 I
2988: * +------------------------------------+
2989: *
2990: PARM2 EQU PARM1+1 SECOND PARAMETER VALUE
2991: PCSI$ EQU PARM2+1 SIZE OF P2BLK IN WORDS
2992: *
2993: * SEE P1BLK FOR DEFINITIONS OF PCODE, PTHEN, PARM1
2994: *
2995: * PARM2 IS A PARAMETER WHICH PERFORMS THE SAME SORT OF
2996: * FUNCTION AS PARM1 (SEE DESCRIPTION OF P1BLK).
2997: *
2998: * PARM2 IS A NON-RELOCATABLE FIELD AND IS NOT
2999: * PROCESSED BY THE GARBAGE COLLECTOR. ACCORDINGLY, IT MAY
3000: * NOT CONTAIN A POINTER TO A BLOCK IN DYNAMIC MEMORY.
3001: EJC
3002: *
3003: * PROGRAM-DEFINED DATATYPE BLOCK
3004: *
3005: * A PDBLK REPRESENTS THE DATA ITEM FORMED BY A CALL TO A
3006: * DATATYPE FUNCTION AS DEFINED BY THE SYSTEM FUNCTION DATA.
3007: *
3008: * +------------------------------------+
3009: * I PDTYP I
3010: * +------------------------------------+
3011: * I IDVAL I
3012: * +------------------------------------+
3013: * I PDDFP I
3014: * +------------------------------------+
3015: * / /
3016: * / PDFLD /
3017: * / /
3018: * +------------------------------------+
3019: *
3020: PDTYP EQU 0 PTR TO DUMMY ROUTINE B$PDT
3021: PDDFP EQU IDVAL+1 PTR TO ASSOCIATED DFBLK
3022: PDFLD EQU PDDFP+1 START OF FIELD VALUE POINTERS
3023: PDFOF EQU DFFLD-PDFLD DIFFERENCE IN OFFSET TO FIELD PTRS
3024: PDSI$ EQU PDFLD SIZE OF STANDARD FIELDS IN PDBLK
3025: PDDFS EQU DFSI$-PDSI$ DIFFERENCE IN DFBLK, PDBLK SIZES
3026: *
3027: * THE PDDFP POINTER MAY BE USED TO DETERMINE THE DATATYPE
3028: * AND THE NAMES OF THE FIELDS IF REQUIRED. THE DFBLK ALSO
3029: * CONTAINS THE LENGTH OF THE PDBLK IN BYTES (FIELD DFPDL).
3030: * PDDFP IS NON-RELOC. BECAUSE DFBLK IS IN STATIC
3031: *
3032: * PDFLD VALUES ARE STORED IN ORDER FROM LEFT TO RIGHT.
3033: * THEY CONTAIN VALUES OR POINTERS TO TRBLK CHAINS.
3034: EJC
3035: *
3036: * PROGRAM DEFINED FUNCTION BLOCK (PFBLK)
3037: *
3038: * A PFBLK IS CREATED FOR EACH CALL TO THE DEFINE FUNCTION
3039: * AND A POINTER TO THE PFBLK PLACED IN THE PROPER VRBLK.
3040: *
3041: * +------------------------------------+
3042: * I FCODE I
3043: * +------------------------------------+
3044: * I FARGS I
3045: * +------------------------------------+
3046: * I PFLEN I
3047: * +------------------------------------+
3048: * I PFVBL I
3049: * +------------------------------------+
3050: * I PFNLO I
3051: * +------------------------------------+
3052: * I PFCOD I
3053: * +------------------------------------+
3054: * I PFCTR I
3055: * +------------------------------------+
3056: * I PFRTR I
3057: * +------------------------------------+
3058: * / /
3059: * / PFARG /
3060: * / /
3061: * +------------------------------------+
3062: *
3063: PFLEN EQU FARGS+1 LENGTH OF PFBLK IN BYTES
3064: PFVBL EQU PFLEN+1 POINTER TO VRBLK FOR FUNCTION NAME
3065: PFNLO EQU PFVBL+1 NUMBER OF LOCALS
3066: PFCOD EQU PFNLO+1 PTR TO CDBLK FOR FIRST STATEMENT
3067: PFCTR EQU PFCOD+1 TRBLK PTR IF CALL TRACED ELSE 0
3068: PFRTR EQU PFCTR+1 TRBLK PTR IF RETURN TRACED ELSE 0
3069: PFARG EQU PFRTR+1 VRBLK PTRS FOR ARGUMENTS AND LOCALS
3070: PFAGB EQU PFARG-1 OFFSET BEHIND PFARG FOR ARG, LOCAL
3071: PFSI$ EQU PFARG NUMBER OF STANDARD FIELDS IN PFBLK
3072: *
3073: * THE FCODE FIELD POINTS TO THE ROUTINE B$PFC.
3074: *
3075: * PFARG IS STORED IN THE FOLLOWING ORDER.
3076: *
3077: * ARGUMENTS (LEFT TO RIGHT)
3078: * LOCALS (LEFT TO RIGHT)
3079: EJC
3080: *
3081: * REAL CONSTANT BLOCK (RCBLK)
3082: *
3083: * AN RCBLK IS CREATED FOR EVERY REAL REFERENCED OR
3084: * CREATED BY A PROGRAM.
3085: *
3086: * +------------------------------------+
3087: * I RCGET I
3088: * +------------------------------------+
3089: * * RCVAL *
3090: * +------------------------------------+
3091: *
3092: RCGET EQU 0 PTR TO ROUTINE B$RCL TO LOAD REAL
3093: RCVAL EQU RCGET+1 REAL VALUE
3094: RCSI$ EQU RCVAL+CFP$R SIZE OF RCBLK
3095: *
3096: * THE LENGTH OF THE RCVAL FIELD IS CFP$R.
3097: EJC
3098: *
3099: * STRING CONSTANT BLOCK (SCBLK)
3100: *
3101: * AN SCBLK IS BUILT FOR EVERY STRING REFERENCED OR CREATED
3102: * BY A PROGRAM.
3103: *
3104: * +------------------------------------+
3105: * I SCGET I
3106: * +------------------------------------+
3107: * I SCLEN I
3108: * +------------------------------------+
3109: * / /
3110: * / SCHAR /
3111: * / /
3112: * +------------------------------------+
3113: *
3114: SCGET EQU 0 PTR TO ROUTINE B$SCL TO LOAD STRING
3115: SCLEN EQU SCGET+1 LENGTH OF STRING IN CHARACTERS
3116: SCHAR EQU SCLEN+1 CHARACTERS OF STRING
3117: SCSI$ EQU SCHAR SIZE OF STANDARD FIELDS IN SCBLK
3118: *
3119: * THE CHARACTERS OF THE STRING ARE STORED LEFT JUSTIFIED.
3120: * THE FINAL WORD IS PADDED ON THE RIGHT WITH ZEROS.
3121: * (I.E. THE CHARACTER WHOSE INTERNAL CODE IS ZERO).
3122: *
3123: * THE VALUE OF SCLEN MAY NOT EXCEED MXLEN. THIS ENSURES
3124: * THAT CHARACTER OFFSETS (E.G. THE PATTERN MATCH CURSOR)
3125: * CAN BE CORRECTLY PROCESSED BY THE GARBAGE COLLECTOR.
3126: *
3127: * NOTE THAT THE OFFSET TO THE CHARACTERS OF THE STRING
3128: * IS GIVEN IN BYTES BY CFP$F AND THAT THIS VALUE IS
3129: * AUTOMATICALLY ALLOWED FOR IN PLC, PSC.
3130: * NOTE THAT FOR A SPITBOL SCBLK, THE VALUE OF CFP$F
3131: * IS GIVEN BY CFP$B*SCHAR.
3132: EJC
3133: *
3134: * SIMPLE EXPRESSION BLOCK (SEBLK)
3135: *
3136: * AN SEBLK IS USED TO REPRESENT AN EXPRESSION OF THE FORM
3137: * *(NATURAL VARIABLE). ALL OTHER EXPRESSIONS ARE EXBLKS.
3138: *
3139: * +------------------------------------+
3140: * I SETYP I
3141: * +------------------------------------+
3142: * I SEVAR I
3143: * +------------------------------------+
3144: *
3145: SETYP EQU 0 PTR TO ROUTINE B$SEL TO LOAD EXPR
3146: SEVAR EQU SETYP+1 PTR TO VRBLK FOR VARIABLE
3147: SESI$ EQU SEVAR+1 LENGTH OF SEBLK IN WORDS
3148: EJC
3149: *
3150: * STANDARD VARIABLE BLOCK (SVBLK)
3151: *
3152: * AN SVBLK IS ASSEMBLED IN THE CONSTANT SECTION FOR EACH
3153: * VARIABLE WHICH SATISFIES ONE OF THE FOLLOWING CONDITIONS.
3154: *
3155: * 1) IT IS THE NAME OF A SYSTEM FUNCTION
3156: * 2) IT HAS AN INITIAL VALUE
3157: * 3) IT HAS A KEYWORD ASSOCIATION
3158: * 4) IT HAS A STANDARD I/O ASSOCIATION
3159: * 6) IT HAS A STANDARD LABEL ASSOCIATION
3160: *
3161: * IF VRBLKS ARE CONSTRUCTED FOR ANY OF THESE VARIABLES,
3162: * THEN THE VRSVP FIELD POINTS TO THE SVBLK (SEE VRBLK)
3163: *
3164: * +------------------------------------+
3165: * I SVBIT I
3166: * +------------------------------------+
3167: * I SVLEN I
3168: * +------------------------------------+
3169: * I SVCHS I
3170: * +------------------------------------+
3171: * I SVKNM I
3172: * +------------------------------------+
3173: * I SVFNC I
3174: * +------------------------------------+
3175: * I SVNAR I
3176: * +------------------------------------+
3177: * I SVLBL I
3178: * +------------------------------------+
3179: * I SVVAL I
3180: * +------------------------------------+
3181: EJC
3182: *
3183: * STANDARD VARIABLE BLOCK (CONTINUED)
3184: *
3185: SVBIT EQU 0 BIT STRING INDICATING ATTRIBUTES
3186: SVLEN EQU 1 (=SCLEN) LENGTH OF NAME IN CHARS
3187: SVCHS EQU 2 (=SCHAR) CHARACTERS OF NAME
3188: SVSI$ EQU 2 NUMBER OF STANDARD FIELDS IN SVBLK
3189: SVPRE EQU 1 SET IF PREEVALUATION PERMITTED
3190: SVFFC EQU SVPRE+SVPRE SET ON IF FAST CALL PERMITTED
3191: SVCKW EQU SVFFC+SVFFC SET ON IF KEYWORD VALUE CONSTANT
3192: SVPRD EQU SVCKW+SVCKW SET ON IF PREDICATE FUNCTION
3193: SVNBT EQU 4 NUMBER OF BITS TO RIGHT OF SVKNM
3194: SVKNM EQU SVPRD+SVPRD SET ON IF KEYWORD ASSOCIATION
3195: SVFNC EQU SVKNM+SVKNM SET ON IF SYSTEM FUNCTION
3196: SVNAR EQU SVFNC+SVFNC SET ON IF SYSTEM FUNCTION
3197: SVLBL EQU SVNAR+SVNAR SET ON IF SYSTEM LABEL
3198: SVVAL EQU SVLBL+SVLBL SET ON IF PREDEFINED VALUE
3199: *
3200: * NOTE THAT THE LAST FIVE BITS CORRESPOND IN ORDER
3201: * TO THE FIELDS WHICH ARE PRESENT (SEE PROCEDURE GTNVR).
3202: *
3203: * THE FOLLOWING DEFINITIONS ARE USED IN THE SVBLK TABLE
3204: *
3205: SVFNF EQU SVFNC+SVNAR FUNCTION WITH NO FAST CALL
3206: SVFNN EQU SVFNF+SVFFC FUNCTION WITH FAST CALL, NO PREEVAL
3207: SVFNP EQU SVFNN+SVPRE FUNCTION ALLOWING PREEVALUATION
3208: SVFPR EQU SVFNN+SVPRD PREDICATE FUNCTION
3209: SVFNK EQU SVFNN+SVKNM NO PREEVAL FUNC + KEYWORD
3210: SVKWV EQU SVKNM+SVVAL KEYWORD + VALUE
3211: SVKWC EQU SVCKW+SVKNM KEYWORD WITH CONSTANT VALUE
3212: SVKVC EQU SVKWV+SVCKW CONSTANT KEYWORD + VALUE
3213: SVKVL EQU SVKVC+SVLBL CONSTANT KEYWORD + VALUE + LABEL
3214: SVFPK EQU SVFNP+SVKVC PREEVAL FCN + CONST KEYWD + VAL
3215: *
3216: * THE SVPRE BIT ALLOWS THE COMPILER TO PREEVALUATE A CALL
3217: * TO THE ASSOCIATED SYSTEM FUNCTION IF ALL THE ARGUMENTS
3218: * ARE THEMSELVES CONSTANTS. FUNCTIONS IN THIS CATEGORY
3219: * MUST HAVE NO SIDE EFFECTS AND MUST NEVER CAUSE FAILURE.
3220: * THE CALL MAY GENERATE AN ERROR CONDITION.
3221: *
3222: * THE SVFFC BIT ALLOWS THE COMPILER TO GENERATE THE SPECIAL
3223: * FAST CALL AFTER ADJUSTING THE NUMBER OF ARGUMENTS. ONLY
3224: * THE ITEM AND APPLY FUNCTIONS FALL OUTSIDE THIS CATEGORY.
3225: *
3226: * THE SVCKW BIT IS SET IF THE ASSOCIATED KEYWORD VALUE IS
3227: * A CONSTANT, THUS ALLOWING PREEVALUATION FOR A VALUE CALL.
3228: *
3229: * THE SVPRD BIT IS SET ON FOR ALL PREDICATE FUNCTIONS TO
3230: * ENABLE THE SPECIAL CONCATENATION CODE OPTIMIZATION.
3231: EJC
3232: *
3233: * SVBLK (CONTINUED)
3234: *
3235: * SVKNM KEYWORD NUMBER
3236: *
3237: * SVKNM IS PRESENT ONLY FOR A STANDARD KEYWORD ASSOC.
3238: * IT CONTAINS A KEYWORD NUMBER AS DEFINED BY THE
3239: * KEYWORD NUMBER TABLE GIVEN LATER ON.
3240: *
3241: * SVFNC SYSTEM FUNCTION POINTER
3242: *
3243: * SVFNC IS PRESENT ONLY FOR A SYSTEM FUNCTION ASSOC.
3244: * IT IS A POINTER TO THE ACTUAL CODE FOR THE SYSTEM
3245: * FUNCTION. THE GENERATED CODE FOR A FAST CALL IS A
3246: * POINTER TO THE SVFNC FIELD OF THE SVBLK FOR THE
3247: * FUNCTION. THE VRFNC FIELD OF THE VRBLK POINTS TO
3248: * THIS SAME FIELD, IN WHICH CASE, IT SERVES AS THE
3249: * FCODE FIELD FOR THE FUNCTION CALL.
3250: *
3251: * SVNAR NUMBER OF FUNCTION ARGUMENTS
3252: *
3253: * SVNAR IS PRESENT ONLY FOR A SYSTEM FUNCTION ASSOC.
3254: * IT IS THE NUMBER OF ARGUMENTS REQUIRED FOR A CALL
3255: * TO THE SYSTEM FUNCTION. THE COMPILER USES THIS
3256: * VALUE TO ADJUST THE NUMBER OF ARGUMENTS IN A FAST
3257: * CALL AND IN THE CASE OF A FUNCTION CALLED THROUGH
3258: * THE VRFNC FIELD OF THE VRBLK, THE SVNAR FIELD
3259: * SERVES AS THE FARGS FIELD FOR O$FNC. A SPECIAL
3260: * CASE OCCURS IF THIS VALUE IS SET TO 999. THIS IS
3261: * USED TO INDICATE THAT THE FUNCTION HAS A VARIABLE
3262: * NUMBER OF ARGUMENTS AND CAUSES O$FNC TO PASS CONTROL
3263: * WITHOUT ADJUSTING THE ARGUMENT COUNT. THE ONLY
3264: * PREDEFINED FUNCTIONS USING THIS ARE APPLY AND ITEM.
3265: *
3266: * SVLBL SYSTEM LABEL POINTER
3267: *
3268: * SVLBL IS PRESENT ONLY FOR A STANDARD LABEL ASSOC.
3269: * IT IS A POINTER TO A SYSTEM LABEL ROUTINE (L$XXX).
3270: * THE VRLBL FIELD OF THE CORRESPONDING VRBLK POINTS TO
3271: * THE SVLBL FIELD OF THE SVBLK.
3272: *
3273: * SVVAL SYSTEM VALUE POINTER
3274: *
3275: * SVVAL IS PRESENT ONLY FOR A STANDARD VALUE.
3276: * IT IS A POINTER TO THE PATTERN NODE (NDXXX) WHICH
3277: * IS THE STANDARD INITIAL VALUE OF THE VARIABLE.
3278: * THIS VALUE IS COPIED TO THE VRVAL FIELD OF THE VRBLK
3279: EJC
3280: *
3281: * SVBLK (CONTINUED)
3282: *
3283: * KEYWORD NUMBER TABLE
3284: *
3285: * THE FOLLOWING TABLE GIVES SYMBOLIC NAMES FOR KEYWORD
3286: * NUMBERS. THESE VALUES ARE STORED IN THE SVKNM FIELD OF
3287: * SVBLKS AND IN THE KVNUM FIELD OF KVBLKS. SEE ALSO
3288: * PROCEDURES ASIGN, ACESS AND KWNAM.
3289: *
3290: * UNPROTECTED KEYWORDS WITH ONE WORD INTEGER VALUES
3291: *
3292: K$ABE EQU 0 ABEND
3293: K$ANC EQU K$ABE+CFP$B ANCHOR
3294: K$CAS EQU K$ANC+CFP$B CASE
3295: K$COD EQU K$CAS+CFP$B CODE
3296: K$DMP EQU K$COD+CFP$B DUMP
3297: K$ERL EQU K$DMP+CFP$B ERRLIMIT
3298: K$ERT EQU K$ERL+CFP$B ERRTYPE
3299: K$FTR EQU K$ERT+CFP$B FTRACE
3300: K$INP EQU K$FTR+CFP$B INPUT
3301: K$MXL EQU K$INP+CFP$B MAXLENGTH
3302: K$OUP EQU K$MXL+CFP$B OUTPUT
3303: K$PFL EQU K$OUP+CFP$B PROFILE
3304: K$TRA EQU K$PFL+CFP$B TRACE
3305: K$TRM EQU K$TRA+CFP$B TRIM
3306: *
3307: * PROTECTED KEYWORDS WITH ONE WORD INTEGER VALUES
3308: *
3309: K$FNC EQU K$TRM+CFP$B FNCLEVEL
3310: K$LST EQU K$FNC+CFP$B LASTNO
3311: K$STN EQU K$LST+CFP$B STNO
3312: *
3313: * KEYWORDS WITH CONSTANT PATTERN VALUES
3314: *
3315: K$ABO EQU K$STN+CFP$B ABORT
3316: K$ARB EQU K$ABO+PASI$ ARB
3317: K$BAL EQU K$ARB+PASI$ BAL
3318: K$FAL EQU K$BAL+PASI$ FAIL
3319: K$FEN EQU K$FAL+PASI$ FENCE
3320: K$REM EQU K$FEN+PASI$ REM
3321: K$SUC EQU K$REM+PASI$ SUCCEED
3322: EJC
3323: *
3324: * KEYWORD NUMBER TABLE (CONTINUED)
3325: *
3326: * SPECIAL KEYWORDS
3327: *
3328: K$ALP EQU K$SUC+1 ALPHABET
3329: K$RTN EQU K$ALP+1 RTNTYPE
3330: K$STC EQU K$RTN+1 STCOUNT
3331: K$ETX EQU K$STC+1 ERRTEXT
3332: K$STL EQU K$ETX+1 STLIMIT
3333: *
3334: * RELATIVE OFFSETS OF SPECIAL KEYWORDS
3335: *
3336: K$$AL EQU K$ALP-K$ALP ALPHABET
3337: K$$RT EQU K$RTN-K$ALP RTNTYPE
3338: K$$SC EQU K$STC-K$ALP STCOUNT
3339: K$$ET EQU K$ETX-K$ALP ERRTEXT
3340: K$$SL EQU K$STL-K$ALP STLIMIT
3341: *
3342: * SYMBOLS USED IN ASIGN AND ACESS PROCEDURES
3343: *
3344: K$P$$ EQU K$FNC FIRST PROTECTED KEYWORD
3345: K$V$$ EQU K$ABO FIRST KEYWORD WITH CONSTANT VALUE
3346: K$S$$ EQU K$ALP FIRST KEYWORD WITH SPECIAL ACESS
3347: EJC
3348: *
3349: * FORMAT OF A TABLE BLOCK (TBBLK)
3350: *
3351: * A TABLE BLOCK IS USED TO REPRESENT A TABLE VALUE.
3352: * IT IS BUILT BY A CALL TO THE TABLE OR CONVERT FUNCTIONS.
3353: *
3354: * +------------------------------------+
3355: * I TBTYP I
3356: * +------------------------------------+
3357: * I IDVAL I
3358: * +------------------------------------+
3359: * I TBLEN I
3360: * +------------------------------------+
3361: * +------------------------------------+
3362: * I TBINV I
3363: * +------------------------------------+
3364: * / /
3365: * / TBBUK /
3366: * / /
3367: * +------------------------------------+
3368: *
3369: TBTYP EQU 0 POINTER TO DUMMY ROUTINE B$TBT
3370: TBLEN EQU OFFS2 LENGTH OF TBBLK IN BYTES
3371: TBINV EQU OFFS3 DEFAULT INITIAL LOOKUP VALUE
3372: TBBUK EQU TBINV+1 START OF HASH BUCKET POINTERS
3373: TBSI$ EQU TBBUK SIZE OF STANDARD FIELDS IN TBBLK
3374: TBNBK EQU 11 DEFAULT NO. OF BUCKETS
3375: *
3376: * THE TABLE BLOCK IS A HASH TABLE WHICH POINTS TO CHAINS
3377: * OF TABLE ELEMENT BLOCKS REPRESENTING THE ELEMENTS
3378: * IN THE TABLE WHICH HASH INTO THE SAME BUCKET.
3379: *
3380: * TBBUK ENTRIES EITHER POINT TO THE FIRST TEBLK ON THE
3381: * CHAIN OR THEY POINT TO THE TBBLK ITSELF TO INDICATE THE
3382: * END OF THE CHAIN.
3383: EJC
3384: *
3385: * TABLE ELEMENT BLOCK (TEBLK)
3386: *
3387: * A TABLE ELEMENT IS USED TO REPRESENT A SINGLE ENTRY IN
3388: * A TABLE (SEE DESCRIPTION OF TBBLK FORMAT FOR HASH TABLE)
3389: *
3390: * +------------------------------------+
3391: * I TETYP I
3392: * +------------------------------------+
3393: * I TESUB I
3394: * +------------------------------------+
3395: * I TEVAL I
3396: * +------------------------------------+
3397: * I TENXT I
3398: * +------------------------------------+
3399: *
3400: TETYP EQU 0 POINTER TO DUMMY ROUTINE B$TET
3401: TESUB EQU TETYP+1 SUBSCRIPT VALUE
3402: TEVAL EQU TESUB+1 (=VRVAL) TABLE ELEMENT VALUE
3403: TENXT EQU TEVAL+1 LINK TO NEXT TEBLK
3404: * SEE S$CNV WHERE RELATION IS ASSUMED WITH TENXT AND TBBUK
3405: TESI$ EQU TENXT+1 SIZE OF TEBLK IN WORDS
3406: *
3407: * TENXT POINTS TO THE NEXT TEBLK ON THE HASH CHAIN FROM THE
3408: * TBBUK CHAIN FOR THIS HASH INDEX. AT THE END OF THE CHAIN,
3409: * TENXT POINTS BACK TO THE START OF THE TBBLK.
3410: *
3411: * TEVAL CONTAINS A DATA POINTER OR A TRBLK POINTER.
3412: *
3413: * TESUB CONTAINS A DATA POINTER.
3414: EJC
3415: *
3416: * TRAP BLOCK (TRBLK)
3417: *
3418: * A TRAP BLOCK IS USED TO REPRESENT A TRACE OR INPUT OR
3419: * OUTPUT ASSOCIATION IN RESPONSE TO A CALL TO THE TRACE
3420: * INPUT OR OUTPUT SYSTEM FUNCTIONS. SEE BELOW FOR DETAILS
3421: *
3422: * +------------------------------------+
3423: * I TRIDN I
3424: * +------------------------------------+
3425: * I TRTYP I
3426: * +------------------------------------+
3427: * I TRVAL OR TRLBL OR TRNXT OR TRKVR I
3428: * +------------------------------------+
3429: * I TRTAG OR TRTER OR TRTRF I
3430: * +------------------------------------+
3431: * I TRFNC OR TRFPT I
3432: * +------------------------------------+
3433: *
3434: TRIDN EQU 0 POINTER TO DUMMY ROUTINE B$TRT
3435: TRTYP EQU TRIDN+1 TRAP TYPE CODE
3436: TRVAL EQU TRTYP+1 VALUE OF TRAPPED VARIABLE (=VRVAL)
3437: TRNXT EQU TRVAL PTR TO NEXT TRBLK ON TRBLK CHAIN
3438: TRLBL EQU TRVAL PTR TO ACTUAL LABEL (TRACED LABEL)
3439: TRKVR EQU TRVAL VRBLK POINTER FOR KEYWORD TRACE
3440: TRTAG EQU TRVAL+1 TRACE TAG
3441: TRTER EQU TRTAG PTR TO TERMINAL VRBLK OR NULL
3442: TRTRF EQU TRTAG PTR TO TRBLK HOLDING FCBLK PTR
3443: TRFNC EQU TRTAG+1 TRACE FUNCTION VRBLK (ZERO IF NONE)
3444: TRFPT EQU TRFNC FCBLK PTR FOR SYSIO
3445: TRSI$ EQU TRFNC+1 NUMBER OF WORDS IN TRBLK
3446: *
3447: TRTIN EQU 0 TRACE TYPE FOR INPUT ASSOCIATION
3448: TRTAC EQU TRTIN+1 TRACE TYPE FOR ACCESS TRACE
3449: TRTVL EQU TRTAC+1 TRACE TYPE FOR VALUE TRACE
3450: TRTOU EQU TRTVL+1 TRACE TYPE FOR OUTPUT ASSOCIATION
3451: TRTFC EQU TRTOU+1 TRACE TYPE FOR FCBLK IDENTIFICATION
3452: EJC
3453: *
3454: * TRAP BLOCK (CONTINUED)
3455: *
3456: * VARIABLE INPUT ASSOCIATION
3457: *
3458: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
3459: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
3460: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
3461: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
3462: *
3463: * TRTYP IS SET TO TRTIN
3464: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
3465: * TRTER IS A POINTER TO SVBLK IF ASSOCIATION IS
3466: * FOR INPUT, TERMINAL, ELSE IT IS NULL.
3467: * TRTRF POINTS TO THE TRAP BLOCK WHICH IN TURN POINTS
3468: * TO AN FCBLK USED FOR I/O ASSOCIATION.
3469: * TRFPT IS THE FCBLK PTR RETURNED BY SYSIO.
3470: *
3471: * VARIABLE ACCESS TRACE ASSOCIATION
3472: *
3473: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
3474: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
3475: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
3476: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
3477: *
3478: * TRTYP IS SET TO TRTAC
3479: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
3480: * TRTAG IS THE TRACE TAG (0 IF NONE)
3481: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3482: *
3483: * VARIABLE VALUE TRACE ASSOCIATION
3484: *
3485: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
3486: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
3487: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
3488: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
3489: *
3490: * TRTYP IS SET TO TRTVL
3491: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
3492: * TRTAG IS THE TRACE TAG (0 IF NONE)
3493: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3494: EJC
3495: * TRAP BLOCK (CONTINUED)
3496: *
3497: * VARIABLE OUTPUT ASSOCIATION
3498: *
3499: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
3500: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
3501: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
3502: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
3503: *
3504: * TRTYP IS SET TO TRTOU
3505: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
3506: * TRTER IS A POINTER TO SVBLK IF ASSOCIATION IS
3507: * FOR OUTPUT, TERMINAL, ELSE IT IS NULL.
3508: * TRTRF POINTS TO THE TRAP BLOCK WHICH IN TURN POINTS
3509: * TO AN FCBLK USED FOR I/O ASSOCIATION.
3510: * TRFPT IS THE FCBLK PTR RETURNED BY SYSIO.
3511: *
3512: * FUNCTION CALL TRACE
3513: *
3514: * THE PFCTR FIELD OF THE CORRESPONDING PFBLK IS SET
3515: * TO POINT TO A TRBLK.
3516: *
3517: * TRTYP IS SET TO TRTIN
3518: * TRNXT IS ZERO
3519: * TRTAG IS THE TRACE TAG (0 IF NONE)
3520: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3521: *
3522: * FUNCTION RETURN TRACE
3523: *
3524: * THE PFRTR FIELD OF THE CORRESPONDING PFBLK IS SET
3525: * TO POINT TO A TRBLK
3526: *
3527: * TRTYP IS SET TO TRTIN
3528: * TRNXT IS ZERO
3529: * TRTAG IS THE TRACE TAG (0 IF NONE)
3530: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3531: *
3532: * LABEL TRACE
3533: *
3534: * THE VRLBL OF THE VRBLK FOR THE LABEL IS
3535: * CHANGED TO POINT TO A TRBLK AND THE VRTRA FIELD IS
3536: * SET TO B$VRT TO ACTIVATE THE CHECK.
3537: *
3538: * TRTYP IS SET TO TRTIN
3539: * TRLBL POINTS TO THE ACTUAL LABEL (CDBLK) VALUE
3540: * TRTAG IS THE TRACE TAG (0 IF NONE)
3541: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3542: EJC
3543: *
3544: * TRAP BLOCK (CONTINUED)
3545: *
3546: * KEYWORD TRACE
3547: *
3548: * KEYWORDS WHICH CAN BE TRACED POSSESS A UNIQUE
3549: * LOCATION WHICH IS ZERO IF THERE IS NO TRACE AND
3550: * POINTS TO A TRBLK IF THERE IS A TRACE. THE LOCATIONS
3551: * ARE AS FOLLOWS.
3552: *
3553: * R$ERT ERRTYPE
3554: * R$FNC FNCLEVEL
3555: * R$STC STCOUNT
3556: *
3557: * THE FORMAT OF THE TRBLK IS AS FOLLOWS.
3558: *
3559: * TRTYP IS SET TO TRTIN
3560: * TRKVR IS A POINTER TO THE VRBLK FOR THE KEYWORD
3561: * TRTAG IS THE TRACE TAG (0 IF NONE)
3562: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3563: *
3564: * INPUT/OUTPUT FILE ARG1 TRAP BLOCK
3565: *
3566: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
3567: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE OF
3568: * A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
3569: * CONTAIN =B$VRA AND =B$VRV. THIS TRAP BLOCK IS USED
3570: * TO HOLD A POINTER TO THE FCBLK WHICH AN
3571: * IMPLEMENTATION MAY REQUEST TO HOLD INFORMATION
3572: * ABOUT A FILE.
3573: *
3574: * TRTYP IS SET TO TRTFC
3575: * TRNEXT POINTS TO NEXT TRBLK OR TRVAL IS VARIABLE VAL
3576: * TRFNM IS 0
3577: * TRFPT IS THE FCBLK POINTER.
3578: *
3579: * NOTE THAT WHEN MULTIPLE TRAPS ARE SET ON A VARIABLE
3580: * THE ORDER IS IN ASCENDING VALUE OF TRTYP FIELD.
3581: *
3582: * INPUT ASSOCIATION (IF PRESENT)
3583: * ACCESS TRACE (IF PRESENT)
3584: * VALUE TRACE (IF PRESENT)
3585: * OUTPUT ASSOCIATION (IF PRESENT)
3586: *
3587: * THE ACTUAL VALUE OF THE VARIABLE IS STORED IN THE TRVAL
3588: * FIELD OF THE LAST TRBLK ON THE CHAIN.
3589: *
3590: * THIS IMPLEMENTATION DOES NOT PERMIT TRACE OR I/O
3591: * ASSOCIATIONS TO ANY OF THE PSEUDO-VARIABLES.
3592: EJC
3593: *
3594: * VECTOR BLOCK (VCBLK)
3595: *
3596: * A VCBLK IS USED TO REPRESENT AN ARRAY VALUE WHICH HAS
3597: * ONE DIMENSION WHOSE LOWER BOUND IS ONE. ALL OTHER ARRAYS
3598: * ARE REPRESENTED BY ARBLKS. A VCBLK IS CREATED BY THE
3599: * SYSTEM FUNCTION ARRAY (S$ARR) WHEN PASSED AN INTEGER ARG.
3600: *
3601: * +------------------------------------+
3602: * I VCTYP I
3603: * +------------------------------------+
3604: * I IDVAL I
3605: * +------------------------------------+
3606: * I VCLEN I
3607: * +------------------------------------+
3608: * I VCVLS I
3609: * +------------------------------------+
3610: *
3611: VCTYP EQU 0 POINTER TO DUMMY ROUTINE B$VCT
3612: VCLEN EQU OFFS2 LENGTH OF VCBLK IN BYTES
3613: VCVLS EQU OFFS3 START OF VECTOR VALUES
3614: VCSI$ EQU VCVLS SIZE OF STANDARD FIELDS IN VCBLK
3615: VCVLB EQU VCVLS-1 OFFSET ONE WORD BEHIND VCVLS
3616: VCTBD EQU TBSI$-VCSI$ DIFFERENCE IN SIZES - SEE PRTVL
3617: *
3618: * VCVLS ARE EITHER DATA POINTERS OR TRBLK POINTERS
3619: *
3620: * THE DIMENSION CAN BE DEDUCED FROM VCLEN.
3621: EJC
3622: *
3623: * VARIABLE BLOCK (VRBLK)
3624: *
3625: * A VARIABLE BLOCK IS BUILT IN THE STATIC MEMORY AREA
3626: * FOR EVERY VARIABLE REFERENCED OR CREATED BY A PROGRAM.
3627: *
3628: * NOTE THAT SINCE THESE BLOCKS ONLY OCCUR IN THE STATIC
3629: * REGION, IT IS PERMISSIBLE TO POINT TO ANY WORD IN
3630: * THE BLOCK AND THIS IS USED TO PROVIDE THREE DISTINCT
3631: * ACCESS POINTS FROM THE GENERATED CODE AS FOLLOWS.
3632: *
3633: * 1) POINT TO VRGET (FIRST WORD OF VRBLK) TO LOAD THE
3634: * VALUE OF THE VARIABLE ONTO THE MAIN STACK.
3635: *
3636: * 2) POINT TO VRSTO (SECOND WORD OF VRBLK) TO STORE THE
3637: * TOP STACK ELEMENT AS THE VALUE OF THE VARIABLE.
3638: *
3639: * 3) POINT TO VRTRA (FOURTH WORD OF VRBLK) TO JUMP TO
3640: * THE LABEL ASSOCIATED WITH THE VARIABLE NAME.
3641: *
3642: * +------------------------------------+
3643: * I VRGET I
3644: * +------------------------------------+
3645: * I VRSTO I
3646: * +------------------------------------+
3647: * I VRVAL I
3648: * +------------------------------------+
3649: * I VRTRA I
3650: * +------------------------------------+
3651: * I VRLBL I
3652: * +------------------------------------+
3653: * I VRFNC I
3654: * +------------------------------------+
3655: * I VRNXT I
3656: * +------------------------------------+
3657: * I VRLEN I
3658: * +------------------------------------+
3659: * / /
3660: * / VRCHS = VRSVP /
3661: * / /
3662: * +------------------------------------+
3663: EJC
3664: *
3665: * VARIABLE BLOCK (CONTINUED)
3666: *
3667: VRGET EQU 0 POINTER TO ROUTINE TO LOAD VALUE
3668: VRSTO EQU VRGET+1 POINTER TO ROUTINE TO STORE VALUE
3669: VRVAL EQU VRSTO+1 VARIABLE VALUE
3670: VRVLO EQU VRVAL-VRSTO OFFSET TO VALUE FROM STORE FIELD
3671: VRTRA EQU VRVAL+1 POINTER TO ROUTINE TO JUMP TO LABEL
3672: VRLBL EQU VRTRA+1 POINTER TO CODE FOR LABEL
3673: VRLBO EQU VRLBL-VRTRA OFFSET TO LABEL FROM TRANSFER FIELD
3674: VRFNC EQU VRLBL+1 POINTER TO FUNCTION BLOCK
3675: VRNXT EQU VRFNC+1 POINTER TO NEXT VRBLK ON HASH CHAIN
3676: VRLEN EQU VRNXT+1 LENGTH OF NAME (OR ZERO)
3677: VRCHS EQU VRLEN+1 CHARACTERS OF NAME (VRLEN GT 0)
3678: VRSVP EQU VRLEN+1 PTR TO SVBLK (VRLEN EQ 0)
3679: VRSI$ EQU VRCHS+1 NUMBER OF STANDARD FIELDS IN VRBLK
3680: VRSOF EQU VRLEN-SCLEN OFFSET TO DUMMY SCBLK FOR NAME
3681: VRSVO EQU VRSVP-VRSOF PSEUDO-OFFSET TO VRSVP FIELD
3682: *
3683: * VRGET = B$VRL IF NOT INPUT ASSOCIATED OR ACCESS TRACED
3684: * VRGET = B$VRA IF INPUT ASSOCIATED OR ACCESS TRACED
3685: *
3686: * VRSTO = B$VRS IF NOT OUTPUT ASSOCIATED OR VALUE TRACED
3687: * VRSTO = B$VRV IF OUTPUT ASSOCIATED OR VALUE TRACED
3688: * VRSTO = B$VRE IF VALUE IS PROTECTED PATTERN VALUE
3689: *
3690: * VRVAL POINTS TO THE APPROPRIATE VALUE UNLESS THE
3691: * VARIABLE IS I/O/TRACE ASSOCIATED IN WHICH CASE, VRVAL
3692: * POINTS TO AN APPROPRIATE TRBLK (TRAP BLOCK) CHAIN.
3693: *
3694: * VRTRA = B$VRG IF THE LABEL IS NOT TRACED
3695: * VRTRA = B$VRT IF THE LABEL IS TRACED
3696: *
3697: * VRLBL POINTS TO A CDBLK IF THERE IS A LABEL
3698: * VRLBL POINTS TO THE SVBLK SVLBL FIELD FOR A SYSTEM LABEL
3699: * VRLBL POINTS TO STNDL FOR AN UNDEFINED LABEL
3700: * VRLBL POINTS TO A TRBLK IF THE LABEL IS TRACED
3701: *
3702: * VRFNC POINTS TO A FFBLK FOR A FIELD FUNCTION
3703: * VRFNC POINTS TO A DFBLK FOR A DATATYPE FUNCTION
3704: * VRFNC POINTS TO A PFBLK FOR A PROGRAM DEFINED FUNCTION
3705: * VRFNC POINTS TO A EFBLK FOR AN EXTERNAL LOADED FUNCTION
3706: * VRFNC POINTS TO SVFNC (SVBLK) FOR A SYSTEM FUNCTION
3707: * VRFNC POINTS TO STNDF IF THE FUNCTION IS UNDEFINED
3708: *
3709: * VRNXT POINTS TO THE NEXT VRBLK ON THIS CHAIN UNLESS
3710: * THIS IS THE END OF THE CHAIN IN WHICH CASE IT IS ZERO.
3711: *
3712: * VRLEN IS THE NAME LENGTH FOR A NON-SYSTEM VARIABLE.
3713: * VRLEN IS ZERO FOR A SYSTEM VARIABLE.
3714: *
3715: * VRCHS IS THE NAME (LJRZ) IF VRLEN IS NON-ZERO.
3716: * VRSVP IS A PTR TO THE SVBLK IF VRLEN IS ZERO.
3717: EJC
3718: *
3719: * FORMAT OF A NON-RELOCATABLE EXTERNAL BLOCK (XNBLK)
3720: *
3721: * AN XNBLK IS A BLOCK REPRESENTING AN UNKNOWN (EXTERNAL)
3722: * DATA VALUE. THE BLOCK CONTAINS NO POINTERS TO OTHER
3723: * RELOCATABLE BLOCKS. AN XNBLK IS USED BY EXTERNAL FUNCTION
3724: * PROCESSING OR POSSIBLY FOR SYSTEM I/O ROUTINES ETC.
3725: * THE MACRO-SYSTEM ITSELF DOES NOT USE XNBLKS.
3726: * THIS TYPE OF BLOCK MAY BE USED AS A FILE CONTROL BLOCK.
3727: * SEE SYSFC,SYSIN,SYSOU,S$INP,S$OUP FOR DETAILS.
3728: *
3729: * +------------------------------------+
3730: * I XNTYP I
3731: * +------------------------------------+
3732: * I XNLEN I
3733: * +------------------------------------+
3734: * / /
3735: * / XNDTA /
3736: * / /
3737: * +------------------------------------+
3738: *
3739: XNTYP EQU 0 POINTER TO DUMMY ROUTINE B$XNT
3740: XNLEN EQU XNTYP+1 LENGTH OF XNBLK IN BYTES
3741: XNDTA EQU XNLEN+1 DATA WORDS
3742: XNSI$ EQU XNDTA SIZE OF STANDARD FIELDS IN XNBLK
3743: *
3744: * NOTE THAT THE TERM NON-RELOCATABLE REFERS TO THE CONTENTS
3745: * AND NOT THE BLOCK ITSELF. AN XNBLK CAN BE MOVED AROUND IF
3746: * IT IS BUILT IN THE DYNAMIC MEMORY AREA.
3747: EJC
3748: *
3749: * RELOCATABLE EXTERNAL BLOCK (XRBLK)
3750: *
3751: * AN XRBLK IS A BLOCK REPRESENTING AN UNKNOWN (EXTERNAL)
3752: * DATA VALUE. THE DATA AREA IN THIS BLOCK CONSISTS ONLY
3753: * OF ADDRESS VALUES AND ANY ADDRESSES POINTING INTO THE
3754: * DYNAMIC MEMORY AREA MUST POINT TO THE START OF OTHER
3755: * DATA BLOCKS. SEE ALSO DESCRIPTION OF XNBLK.
3756: * THIS TYPE OF BLOCK MAY BE USED AS A FILE CONTROL BLOCK.
3757: * SEE SYSFC,SYSIN,SYSOU,S$INP,S$OUP FOR DETAILS.
3758: *
3759: * +------------------------------------+
3760: * I XRTYP I
3761: * +------------------------------------+
3762: * I XRLEN I
3763: * +------------------------------------+
3764: * / /
3765: * / XRPTR /
3766: * / /
3767: * +------------------------------------+
3768: *
3769: XRTYP EQU 0 POINTER TO DUMMY ROUTINE B$XRT
3770: XRLEN EQU XRTYP+1 LENGTH OF XRBLK IN BYTES
3771: XRPTR EQU XRLEN+1 START OF ADDRESS POINTERS
3772: XRSI$ EQU XRPTR SIZE OF STANDARD FIELDS IN XRBLK
3773: EJC
3774: *
3775: * S$CNV (CONVERT) FUNCTION SWITCH CONSTANTS. THE VALUES
3776: * ARE TIED TO THE ORDER OF THE ENTRIES IN THE SVCTB TABLE
3777: * AND HENCE TO THE BRANCH TABLE IN S$CNV.
3778: *
3779: CNVST EQU 8 MAX STANDARD TYPE CODE FOR CONVERT
3780: CNVRT EQU CNVST+1 CONVERT CODE FOR REALS
3781: CNVBT EQU CNVRT+1 CONVERT CODE FOR BUFFER
3782: CNVTT EQU CNVBT+1 BSW CODE FOR CONVERT
3783: *
3784: * INPUT IMAGE LENGTH
3785: *
3786: INILN EQU 132 DEFAULT IMAGE LENGTH FOR COMPILER
3787: INILS EQU 80 IMAGE LENGTH IF -SEQU IN EFFECT
3788: *
3789: IONMB EQU 2 NAME BASE USED FOR IOCHN IN SYSIO
3790: IONMO EQU 4 NAME OFFSET USED FOR IOCHN IN SYSIO
3791: *
3792: * IN GENERAL, MEANINGFUL MNEMONICS SHOULD BE USED FOR
3793: * OFFSETS. HOWEVER FOR SMALL INTEGERS USED OFTEN IN
3794: * LITERALS THE FOLLOWING GENERAL DEFINITIONS ARE PROVIDED.
3795: *
3796: NUM01 EQU 1
3797: NUM02 EQU 2
3798: NUM03 EQU 3
3799: NUM04 EQU 4
3800: NUM05 EQU 5
3801: NUM06 EQU 6
3802: NUM07 EQU 7
3803: NUM08 EQU 8
3804: NUM09 EQU 9
3805: NUM10 EQU 10
3806: NINI8 EQU 998
3807: NINI9 EQU 999
3808: THSND EQU 1000
3809: EJC
3810: *
3811: * NUMBERS OF UNDEFINED SPITBOL OPERATORS
3812: *
3813: OPBUN EQU 5 NO. OF BINARY UNDEFINED OPS
3814: OPUUN EQU 6 NO OF UNARY UNDEFINED OPS
3815: *
3816: * OFFSETS USED IN PRTSN, PRTMI AND ACESS
3817: *
3818: PRSNF EQU 13 OFFSET USED IN PRTSN
3819: PRTMF EQU 15 OFFSET TO COL 15 (PRTMI)
3820: RILEN EQU 120 BUFFER LENGTH FOR SYSRI
3821: *
3822: * CODES FOR STAGES OF PROCESSING
3823: *
3824: STGIC EQU 0 INITIAL COMPILE
3825: STGXC EQU STGIC+1 EXECUTION COMPILE (CODE)
3826: STGEV EQU STGXC+1 EXPRESSION EVAL DURING EXECUTION
3827: STGXT EQU STGEV+1 EXECUTION TIME
3828: STGCE EQU STGXT+1 INITIAL COMPILE AFTER END LINE
3829: STGXE EQU STGCE+1 EXEC. COMPILE AFTER END LINE
3830: STGND EQU STGCE-STGIC DIFFERENCE IN STAGE AFTER END
3831: STGEE EQU STGXE+1 EVAL EVALUATING EXPRESSION
3832: STGNO EQU STGEE+1 NUMBER OF CODES
3833: EJC
3834: *
3835: *
3836: * STATEMENT NUMBER PAD COUNT FOR LISTR
3837: *
3838: STNPD EQU 8 STATEMENT NO. PAD COUNT
3839: *
3840: * SYNTAX TYPE CODES
3841: *
3842: * THESE CODES ARE RETURNED FROM THE SCANE PROCEDURE.
3843: *
3844: * THEY ARE SPACED 3 APART FOR THE BENEFIT OF EXPAN.
3845: *
3846: T$UOP EQU 0 UNARY OPERATOR
3847: T$LPR EQU T$UOP+3 LEFT PAREN
3848: T$LBR EQU T$LPR+3 LEFT BRACKET
3849: T$CMA EQU T$LBR+3 COMMA
3850: T$FNC EQU T$CMA+3 FUNCTION CALL
3851: T$VAR EQU T$FNC+3 VARIABLE
3852: T$CON EQU T$VAR+3 CONSTANT
3853: T$BOP EQU T$CON+3 BINARY OPERATOR
3854: T$RPR EQU T$BOP+3 RIGHT PAREN
3855: T$RBR EQU T$RPR+3 RIGHT BRACKET
3856: T$COL EQU T$RBR+3 COLON
3857: T$SMC EQU T$COL+3 SEMI-COLON
3858: *
3859: * THE FOLLOWING DEFINITIONS ARE USED ONLY IN THE GOTO FIELD
3860: *
3861: T$FGO EQU T$SMC+1 FAILURE GOTO
3862: T$SGO EQU T$FGO+1 SUCCESS GOTO
3863: *
3864: * THE ABOVE CODES ARE GROUPED SO THAT CODES FOR ELEMENTS
3865: * WHICH CAN LEGITIMATELY IMMEDIATELY PRECEDE A UNARY
3866: * OPERATOR COME FIRST TO FACILITATE OPERATOR SYNTAX CHECK.
3867: *
3868: T$UOK EQU T$FNC LAST CODE OK BEFORE UNARY OPERATOR
3869: EJC
3870: *
3871: * DEFINITIONS OF VALUES FOR EXPAN JUMP TABLE
3872: *
3873: T$UO0 EQU T$UOP+0 UNARY OPERATOR, STATE ZERO
3874: T$UO1 EQU T$UOP+1 UNARY OPERATOR, STATE ONE
3875: T$UO2 EQU T$UOP+2 UNARY OPERATOR, STATE TWO
3876: T$LP0 EQU T$LPR+0 LEFT PAREN, STATE ZERO
3877: T$LP1 EQU T$LPR+1 LEFT PAREN, STATE ONE
3878: T$LP2 EQU T$LPR+2 LEFT PAREN, STATE TWO
3879: T$LB0 EQU T$LBR+0 LEFT BRACKET, STATE ZERO
3880: T$LB1 EQU T$LBR+1 LEFT BRACKET, STATE ONE
3881: T$LB2 EQU T$LBR+2 LEFT BRACKET, STATE TWO
3882: T$CM0 EQU T$CMA+0 COMMA, STATE ZERO
3883: T$CM1 EQU T$CMA+1 COMMA, STATE ONE
3884: T$CM2 EQU T$CMA+2 COMMA, STATE TWO
3885: T$FN0 EQU T$FNC+0 FUNCTION CALL, STATE ZERO
3886: T$FN1 EQU T$FNC+1 FUNCTION CALL, STATE ONE
3887: T$FN2 EQU T$FNC+2 FUNCTION CALL, STATE TWO
3888: T$VA0 EQU T$VAR+0 VARIABLE, STATE ZERO
3889: T$VA1 EQU T$VAR+1 VARIABLE, STATE ONE
3890: T$VA2 EQU T$VAR+2 VARIABLE, STATE TWO
3891: T$CO0 EQU T$CON+0 CONSTANT, STATE ZERO
3892: T$CO1 EQU T$CON+1 CONSTANT, STATE ONE
3893: T$CO2 EQU T$CON+2 CONSTANT, STATE TWO
3894: T$BO0 EQU T$BOP+0 BINARY OPERATOR, STATE ZERO
3895: T$BO1 EQU T$BOP+1 BINARY OPERATOR, STATE ONE
3896: T$BO2 EQU T$BOP+2 BINARY OPERATOR, STATE TWO
3897: T$RP0 EQU T$RPR+0 RIGHT PAREN, STATE ZERO
3898: T$RP1 EQU T$RPR+1 RIGHT PAREN, STATE ONE
3899: T$RP2 EQU T$RPR+2 RIGHT PAREN, STATE TWO
3900: T$RB0 EQU T$RBR+0 RIGHT BRACKET, STATE ZERO
3901: T$RB1 EQU T$RBR+1 RIGHT BRACKET, STATE ONE
3902: T$RB2 EQU T$RBR+2 RIGHT BRACKET, STATE TWO
3903: T$CL0 EQU T$COL+0 COLON, STATE ZERO
3904: T$CL1 EQU T$COL+1 COLON, STATE ONE
3905: T$CL2 EQU T$COL+2 COLON, STATE TWO
3906: T$SM0 EQU T$SMC+0 SEMICOLON, STATE ZERO
3907: T$SM1 EQU T$SMC+1 SEMICOLON, STATE ONE
3908: T$SM2 EQU T$SMC+2 SEMICOLON, STATE TWO
3909: *
3910: T$NES EQU T$SM2+1 NUMBER OF ENTRIES IN BRANCH TABLE
3911: EJC
3912: *
3913: * DEFINITION OF OFFSETS USED IN CONTROL CARD PROCESSING
3914: *
3915: CC$CA EQU 0 -CASE
3916: CC$DO EQU CC$CA+1 -DOUBLE
3917: CC$DU EQU CC$DO+1 -DUMP
3918: CC$EJ EQU CC$DU+1 -EJECT
3919: CC$ER EQU CC$EJ+1 -ERRORS
3920: CC$EX EQU CC$ER+1 -EXECUTE
3921: CC$FA EQU CC$EX+1 -FAIL
3922: CC$LI EQU CC$FA+1 -LIST
3923: CC$NR EQU CC$LI+1 -NOERRORS
3924: CC$NX EQU CC$NR+1 -NOEXECUTE
3925: CC$NF EQU CC$NX+1 -NOFAIL
3926: CC$NL EQU CC$NF+1 -NOLIST
3927: CC$NO EQU CC$NL+1 -NOOPT
3928: CC$NP EQU CC$NO+1 -NOPRINT
3929: CC$OP EQU CC$NP+1 -OPTIMISE
3930: CC$PR EQU CC$OP+1 -PRINT
3931: CC$SI EQU CC$PR+1 -SINGLE
3932: CC$SP EQU CC$SI+1 -SPACE
3933: CC$ST EQU CC$SP+1 -STITL
3934: CC$TI EQU CC$ST+1 -TITLE
3935: CC$TR EQU CC$TI+1 -TRACE
3936: CC$NC EQU CC$TR+1 NUMBER OF CONTROL CARDS
3937: CCNOC EQU 4 NO. OF CHARS INCLUDED IN MATCH
3938: CCOFS EQU 7 OFFSET TO START OF TITLE/SUBTITLE
3939: EJC
3940: *
3941: * DEFINITIONS OF STACK OFFSETS USED IN CMPIL PROCEDURE
3942: *
3943: * SEE DESCRIPTION AT START OF CMPIL PROCEDURE FOR DETAILS
3944: * OF USE OF THESE LOCATIONS ON THE STACK.
3945: *
3946: CMSTM EQU 0 TREE FOR STATEMENT BODY
3947: CMSGO EQU CMSTM+1 TREE FOR SUCCESS GOTO
3948: CMFGO EQU CMSGO+1 TREE FOR FAIL GOTO
3949: CMCGO EQU CMFGO+1 CONDITIONAL GOTO FLAG
3950: CMPCD EQU CMCGO+1 PREVIOUS CDBLK POINTER
3951: CMFFP EQU CMPCD+1 FAILURE FILL IN FLAG FOR PREVIOUS
3952: CMFFC EQU CMFFP+1 FAILURE FILL IN FLAG FOR CURRENT
3953: CMSOP EQU CMFFC+1 SUCCESS FILL IN OFFSET FOR PREVIOUS
3954: CMSOC EQU CMSOP+1 SUCCESS FILL IN OFFSET FOR CURRENT
3955: CMLBL EQU CMSOC+1 PTR TO VRBLK FOR CURRENT LABEL
3956: CMTRA EQU CMLBL+1 PTR TO ENTRY CDBLK
3957: *
3958: CMNEN EQU CMTRA+1 COUNT OF STACK ENTRIES FOR CMPIL
3959: *
3960: * A FEW CONSTANTS USED BY THE PROFILER
3961: PFPD1 EQU 8 PAD POSITIONS ...
3962: PFPD2 EQU 20 ... FOR PROFILE ...
3963: PFPD3 EQU 32 ... PRINTOUT
3964: PF$I2 EQU CFP$I+CFP$I SIZE OF TABLE ENTRY (2 INTS)
3965: *
3966: TTL S P I T B O L -- CONSTANT SECTION
3967: *
3968: * THIS SECTION CONSISTS ENTIRELY OF ASSEMBLED CONSTANTS.
3969: *
3970: * ALL LABEL NAMES ARE FIVE LETTERS. THE ORDER IS
3971: * APPROXIMATELY ALPHABETICAL, BUT IN SOME CASES (ALWAYS
3972: * DOCUMENTED), CONSTANTS MUST BE PLACED IN SOME SPECIAL
3973: * ORDER WHICH MUST NOT BE DISTURBED.
3974: *
3975: * IT MUST ALSO BE REMEMBERED THAT THERE IS A REQUIREMENT
3976: * FOR NO FORWARD REFERENCES WHICH ALSO DISTURBS THE
3977: * ALPHABETICAL ORDER IN SOME CASES.
3978: *
3979: SEC START OF CONSTANT SECTION
3980: *
3981: * FREE STORE PERCENTAGE (USED BY ALLOC)
3982: *
3983: ALFSP DAC E$FSP FREE STORE PERCENTAGE
3984: *
3985: * BIT CONSTANTS FOR GENERAL USE
3986: *
3987: BITS0 DBC 0 ALL ZERO BITS
3988: BITS1 DBC 1 ONE BIT IN LOW ORDER POSITION
3989: BITS2 DBC 2 BIT IN POSITION 2
3990: BITS3 DBC 4 BIT IN POSITION 3
3991: BITS4 DBC 8 BIT IN POSITION 4
3992: BITS5 DBC 16 BIT IN POSITION 5
3993: BITS6 DBC 32 BIT IN POSITION 6
3994: BITS7 DBC 64 BIT IN POSITION 7
3995: BITS8 DBC 128 BIT IN POSITION 8
3996: BITS9 DBC 256 BIT IN POSITION 9
3997: BIT10 DBC 512 BIT IN POSITION 10
3998: BITSM DBC CFP$M MASK FOR MAX INTEGER
3999: *
4000: * BIT CONSTANTS FOR SVBLK (SVBIT FIELD) TESTS
4001: *
4002: BTFNC DBC SVFNC BIT TO TEST FOR FUNCTION
4003: BTKNM DBC SVKNM BIT TO TEST FOR KEYWORD NUMBER
4004: BTLBL DBC SVLBL BIT TO TEST FOR LABEL
4005: BTFFC DBC SVFFC BIT TO TEST FOR FAST CALL
4006: BTCKW DBC SVCKW BIT TO TEST FOR CONSTANT KEYWORD
4007: BTPRD DBC SVPRD BIT TO TEST FOR PREDICATE FUNCTION
4008: BTPRE DBC SVPRE BIT TO TEST FOR PREEVALUATION
4009: BTVAL DBC SVVAL BIT TO TEST FOR VALUE
4010: EJC
4011: *
4012: * LIST OF NAMES USED FOR CONTROL CARD PROCESSING
4013: *
4014: CCNMS DTC /CASE/
4015: DTC /DOUB/
4016: DTC /DUMP/
4017: DTC /EJEC/
4018: DTC /ERRO/
4019: DTC /EXEC/
4020: DTC /FAIL/
4021: DTC /LIST/
4022: DTC /NOER/
4023: DTC /NOEX/
4024: DTC /NOFA/
4025: DTC /NOLI/
4026: DTC /NOOP/
4027: DTC /NOPR/
4028: DTC /OPTI/
4029: DTC /PRIN/
4030: DTC /SING/
4031: DTC /SPAC/
4032: DTC /STIT/
4033: DTC /TITL/
4034: DTC /TRAC/
4035: *
4036: * HEADER MESSAGES FOR DUMPR PROCEDURE (SCBLK FORMAT)
4037: *
4038: DMHDK DAC B$SCL DUMP OF KEYWORD VALUES
4039: DAC 22
4040: DTC /DUMP OF KEYWORD VALUES/
4041: *
4042: DMHDV DAC B$SCL DUMP OF NATURAL VARIABLES
4043: DAC 25
4044: DTC /DUMP OF NATURAL VARIABLES/
4045: EJC
4046: *
4047: * MESSAGE TEXT FOR COMPILATION STATISTICS
4048: *
4049: ENCM1 DAC B$SCL
4050: DAC 10
4051: DTC /STORE USED/
4052: *
4053: ENCM2 DAC B$SCL
4054: DAC 10
4055: DTC /STORE LEFT/
4056: *
4057: ENCM3 DAC B$SCL
4058: DAC 11
4059: DTC /COMP ERRORS/
4060: *
4061: ENCM4 DAC B$SCL
4062: DAC 14
4063: DTC /COMP TIME-MSEC/
4064: *
4065: ENCM5 DAC B$SCL EXECUTION SUPPRESSED
4066: DAC 20
4067: DTC /EXECUTION SUPPRESSED/
4068: *
4069: * STRING CONSTANT FOR ABNORMAL END
4070: *
4071: ENDAB DAC B$SCL
4072: DAC 12
4073: DTC /ABNORMAL END/
4074: EJC
4075: *
4076: * MEMORY OVERFLOW DURING INITIALISATION
4077: *
4078: ENDMO DAC B$SCL
4079: ENDML DAC 15
4080: DTC /MEMORY OVERFLOW/
4081: *
4082: * STRING CONSTANT FOR MESSAGE ISSUED BY L$END
4083: *
4084: ENDMS DAC B$SCL
4085: DAC 10
4086: DTC /NORMAL END/
4087: *
4088: * FAIL MESSAGE FOR STACK FAIL SECTION
4089: *
4090: ENDSO DAC B$SCL STACK OVERFLOW IN GARBAGE COLLECTOR
4091: DAC 36
4092: DTC /STACK OVERFLOW IN GARBAGE COLLECTION/
4093: *
4094: * STRING CONSTANT FOR TIME UP
4095: *
4096: ENDTU DAC B$SCL
4097: DAC 15
4098: DTC /ERROR - TIME UP/
4099: EJC
4100: *
4101: * STRING CONSTANT FOR ERROR MESSAGE (ERROR SECTION)
4102: *
4103: ERMMS DAC B$SCL ERROR
4104: DAC 5
4105: DTC /ERROR/
4106: *
4107: ERMNS DAC B$SCL STRING / -- /
4108: DAC 4
4109: DTC / -- /
4110: *
4111: * STRING CONSTANT FOR PAGE NUMBERING
4112: *
4113: LSTMS DAC B$SCL PAGE
4114: DAC 5
4115: DTC /PAGE /
4116: *
4117: * LISTING HEADER MESSAGE
4118: *
4119: HEADR DAC B$SCL
4120: DAC 25
4121: DTC /MACRO SPITBOL VERSION 3.5/
4122: *
4123: HEADV DAC B$SCL FOR EXIT() VERSION NO. CHECK
4124: DAC 3
4125: DTC /3.5/
4126: *
4127: * INTEGER CONSTANTS FOR GENERAL USE
4128: * ICBLD OPTIMISATION USES THE FIRST THREE.
4129: *
4130: INT$R DAC B$ICL
4131: INTV0 DIC +0 0
4132: INTON DAC B$ICL
4133: INTV1 DIC +1 1
4134: INTTW DAC B$ICL
4135: INTV2 DIC +2 2
4136: INTVT DIC +10 10
4137: INTVH DIC +100 100
4138: INTTH DIC +1000 1000
4139: *
4140: * TABLE USED IN ICBLD OPTIMISATION
4141: *
4142: INTAB DAC INT$R POINTER TO 0
4143: DAC INTON POINTER TO 1
4144: DAC INTTW POINTER TO 2
4145: EJC
4146: *
4147: * SPECIAL PATTERN NODES. THE FOLLOWING PATTERN NODES
4148: * CONSIST SIMPLY OF A PCODE POINTER, SEE MATCH ROUTINES
4149: * (P$XXX) FOR FULL DETAILS OF THEIR USE AND FORMAT).
4150: *
4151: NDABB DAC P$ABB ARBNO
4152: NDABD DAC P$ABD ARBNO
4153: NDARC DAC P$ARC ARB
4154: NDEXB DAC P$EXB EXPRESSION
4155: NDFNB DAC P$FNB FENCE()
4156: NDFND DAC P$FND FENCE()
4157: NDEXC DAC P$EXC EXPRESSION
4158: NDIMB DAC P$IMB IMMEDIATE ASSIGNMENT
4159: NDIMD DAC P$IMD IMMEDIATE ASSIGNMENT
4160: NDNTH DAC P$NTH PATTERN END (NULL PATTERN)
4161: NDPAB DAC P$PAB PATTERN ASSIGNMENT
4162: NDPAD DAC P$PAD PATTERN ASSIGNMENT
4163: NDUNA DAC P$UNA ANCHOR POINT MOVEMENT
4164: *
4165: * KEYWORD CONSTANT PATTERN NODES. THE FOLLOWING NODES ARE
4166: * USED AS THE VALUES OF PATTERN KEYWORDS AND THE INITIAL
4167: * VALUES OF THE CORRESPONDING NATURAL VARIABLES. ALL
4168: * NODES ARE IN P0BLK FORMAT AND THE ORDER IS TIED TO THE
4169: * DEFINITIONS OF CORRESPONDING K$XXX SYMBOLS.
4170: *
4171: NDABO DAC P$ABO ABORT
4172: DAC NDNTH
4173: NDARB DAC P$ARB ARB
4174: DAC NDNTH
4175: NDBAL DAC P$BAL BAL
4176: DAC NDNTH
4177: NDFAL DAC P$FAL FAIL
4178: DAC NDNTH
4179: NDFEN DAC P$FEN FENCE
4180: DAC NDNTH
4181: NDREM DAC P$REM REM
4182: DAC NDNTH
4183: NDSUC DAC P$SUC SUCCEED
4184: DAC NDNTH
4185: *
4186: * NULL STRING. ALL NULL VALUES POINT TO THIS STRING. THE
4187: * SVCHS FIELD CONTAINS A BLANK TO PROVIDE FOR EASY DEFAULT
4188: * PROCESSING IN TRACE, STOPTR, LPAD AND RPAD.
4189: * NULLW CONTAINS 10 BLANKS WHICH ENSURES AN ALL BLANK WORD
4190: * BUT FOR VERY EXCEPTIONAL MACHINES.
4191: *
4192: NULLS DAC B$SCL NULL STRING VALUE
4193: DAC 0 SCLEN = 0
4194: NULLW DTC / /
4195: EJC
4196: *
4197: * OPERATOR DOPE VECTORS (SEE DVBLK FORMAT)
4198: *
4199: OPDVC DAC O$CNC CONCATENATION
4200: DAC C$CNC
4201: DAC LLCNC
4202: DAC RRCNC
4203: *
4204: * OPDVS IS USED WHEN SCANNING BELOW THE TOP LEVEL TO
4205: * INSURE THAT THE CONCATENATION WILL NOT BE LATER
4206: * MISTAKEN FOR PATTERN MATCHING
4207: *
4208: OPDVP DAC O$CNC CONCATENATION - NOT PATTERN MATCH
4209: DAC C$CNP
4210: DAC LLCNC
4211: DAC RRCNC
4212: *
4213: * NOTE THAT THE ORDER OF THE REMAINING ENTRIES IS TIED TO
4214: * THE ORDER OF THE CODING IN THE SCANE PROCEDURE.
4215: *
4216: OPDVS DAC O$ASS ASSIGNMENT
4217: DAC C$ASS
4218: DAC LLASS
4219: DAC RRASS
4220: *
4221: DAC 6 UNARY EQUAL
4222: DAC C$UUO
4223: DAC LLUNO
4224: *
4225: DAC O$PMV PATTERN MATCH
4226: DAC C$PMT
4227: DAC LLPMT
4228: DAC RRPMT
4229: *
4230: DAC O$INT INTERROGATION
4231: DAC C$UVL
4232: DAC LLUNO
4233: *
4234: DAC 1 BINARY AMPERSAND
4235: DAC C$UBO
4236: DAC LLAMP
4237: DAC RRAMP
4238: *
4239: DAC O$KWV KEYWORD REFERENCE
4240: DAC C$KEY
4241: DAC LLUNO
4242: *
4243: DAC O$ALT ALTERNATION
4244: DAC C$ALT
4245: DAC LLALT
4246: DAC RRALT
4247: EJC
4248: *
4249: * OPERATOR DOPE VECTORS (CONTINUED)
4250: *
4251: DAC 5 UNARY VERTICAL BAR
4252: DAC C$UUO
4253: DAC LLUNO
4254: *
4255: DAC 0 BINARY AT
4256: DAC C$UBO
4257: DAC LLATS
4258: DAC RRATS
4259: *
4260: DAC O$CAS CURSOR ASSIGNMENT
4261: DAC C$UNM
4262: DAC LLUNO
4263: *
4264: DAC 2 BINARY NUMBER SIGN
4265: DAC C$UBO
4266: DAC LLNUM
4267: DAC RRNUM
4268: *
4269: DAC 7 UNARY NUMBER SIGN
4270: DAC C$UUO
4271: DAC LLUNO
4272: *
4273: DAC O$DVD DIVISION
4274: DAC C$BVL
4275: DAC LLDVD
4276: DAC RRDVD
4277: *
4278: DAC 9 UNARY SLASH
4279: DAC C$UUO
4280: DAC LLUNO
4281: *
4282: DAC O$MLT MULTIPLICATION
4283: DAC C$BVL
4284: DAC LLMLT
4285: DAC RRMLT
4286: EJC
4287: *
4288: * OPERATOR DOPE VECTORS (CONTINUED)
4289: *
4290: DAC 0 DEFERRED EXPRESSION
4291: DAC C$DEF
4292: DAC LLUNO
4293: *
4294: DAC 3 BINARY PERCENT
4295: DAC C$UBO
4296: DAC LLPCT
4297: DAC RRPCT
4298: *
4299: DAC 8 UNARY PERCENT
4300: DAC C$UUO
4301: DAC LLUNO
4302: *
4303: DAC O$EXP EXPONENTIATION
4304: DAC C$BVL
4305: DAC LLEXP
4306: DAC RREXP
4307: *
4308: DAC 10 UNARY EXCLAMATION
4309: DAC C$UUO
4310: DAC LLUNO
4311: *
4312: DAC O$IMA IMMEDIATE ASSIGNMENT
4313: DAC C$BVN
4314: DAC LLDLD
4315: DAC RRDLD
4316: *
4317: DAC O$INV INDIRECTION
4318: DAC C$IND
4319: DAC LLUNO
4320: *
4321: DAC 4 BINARY NOT
4322: DAC C$UBO
4323: DAC LLNOT
4324: DAC RRNOT
4325: *
4326: DAC 0 NEGATION
4327: DAC C$NEG
4328: DAC LLUNO
4329: EJC
4330: *
4331: * OPERATOR DOPE VECTORS (CONTINUED)
4332: *
4333: DAC O$SUB SUBTRACTION
4334: DAC C$BVL
4335: DAC LLPLM
4336: DAC RRPLM
4337: *
4338: DAC O$COM COMPLEMENTATION
4339: DAC C$UVL
4340: DAC LLUNO
4341: *
4342: DAC O$ADD ADDITION
4343: DAC C$BVL
4344: DAC LLPLM
4345: DAC RRPLM
4346: *
4347: DAC O$AFF AFFIRMATION
4348: DAC C$UVL
4349: DAC LLUNO
4350: *
4351: DAC O$PAS PATTERN ASSIGNMENT
4352: DAC C$BVN
4353: DAC LLDLD
4354: DAC RRDLD
4355: *
4356: DAC O$NAM NAME REFERENCE
4357: DAC C$UNM
4358: DAC LLUNO
4359: *
4360: * SPECIAL DVS FOR GOTO OPERATORS (SEE PROCEDURE SCNGF)
4361: *
4362: OPDVD DAC O$GOD DIRECT GOTO
4363: DAC C$UVL
4364: DAC LLUNO
4365: *
4366: OPDVN DAC O$GOC COMPLEX NORMAL GOTO
4367: DAC C$UNM
4368: DAC LLUNO
4369: EJC
4370: *
4371: * OPERATOR ENTRY ADDRESS POINTERS, USED IN CODE
4372: *
4373: OAMN$ DAC O$AMN ARRAY REF (MULTI-SUBS BY VALUE)
4374: OAMV$ DAC O$AMV ARRAY REF (MULTI-SUBS BY VALUE)
4375: OAON$ DAC O$AON ARRAY REF (ONE SUB BY NAME)
4376: OAOV$ DAC O$AOV ARRAY REF (ONE SUB BY VALUE)
4377: OCER$ DAC O$CER COMPILATION ERROR
4378: OFEX$ DAC O$FEX FAILURE IN EXPRESSION EVALUATION
4379: OFIF$ DAC O$FIF FAILURE DURING GOTO EVALUATION
4380: OFNC$ DAC O$FNC FUNCTION CALL (MORE THAN ONE ARG)
4381: OFNE$ DAC O$FNE FUNCTION NAME ERROR
4382: OFNS$ DAC O$FNS FUNCTION CALL (SINGLE ARGUMENT)
4383: OGOF$ DAC O$GOF SET GOTO FAILURE TRAP
4384: OINN$ DAC O$INN INDIRECTION BY NAME
4385: OKWN$ DAC O$KWN KEYWORD REFERENCE BY NAME
4386: OLEX$ DAC O$LEX LOAD EXPRESSION BY NAME
4387: OLPT$ DAC O$LPT LOAD PATTERN
4388: OLVN$ DAC O$LVN LOAD VARIABLE NAME
4389: ONTA$ DAC O$NTA NEGATION, FIRST ENTRY
4390: ONTB$ DAC O$NTB NEGATION, SECOND ENTRY
4391: ONTC$ DAC O$NTC NEGATION, THIRD ENTRY
4392: OPMN$ DAC O$PMN PATTERN MATCH BY NAME
4393: OPMS$ DAC O$PMS PATTERN MATCH (STATEMENT)
4394: OPOP$ DAC O$POP POP TOP STACK ITEM
4395: ORNM$ DAC O$RNM RETURN NAME FROM EXPRESSION
4396: ORPL$ DAC O$RPL PATTERN REPLACEMENT
4397: ORVL$ DAC O$RVL RETURN VALUE FROM EXPRESSION
4398: OSLA$ DAC O$SLA SELECTION, FIRST ENTRY
4399: OSLB$ DAC O$SLB SELECTION, SECOND ENTRY
4400: OSLC$ DAC O$SLC SELECTION, THIRD ENTRY
4401: OSLD$ DAC O$SLD SELECTION, FOURTH ENTRY
4402: OSTP$ DAC O$STP STOP EXECUTION
4403: OUNF$ DAC O$UNF UNEXPECTED FAILURE
4404: EJC
4405: *
4406: * TABLE OF NAMES OF UNDEFINED BINARY OPERATORS FOR OPSYN
4407: *
4408: OPSNB DAC CH$AT AT
4409: DAC CH$AM AMPERSAND
4410: DAC CH$NM NUMBER
4411: DAC CH$PC PERCENT
4412: DAC CH$NT NOT
4413: *
4414: * TABLE OF NAMES OF UNDEFINED UNARY OPERATORS FOR OPSYN
4415: *
4416: OPNSU DAC CH$BR VERTICAL BAR
4417: DAC CH$EQ EQUAL
4418: DAC CH$NM NUMBER
4419: DAC CH$PC PERCENT
4420: DAC CH$SL SLASH
4421: DAC CH$EX EXCLAMATION
4422: *
4423: * ADDRESS CONST CONTAINING PROFILE TABLE ENTRY SIZE
4424: *
4425: PFI2A DAC PF$I2
4426: *
4427: * PROFILER MESSAGE STRINGS
4428: *
4429: PFMS1 DAC B$SCL
4430: DAC 15
4431: DTC /PROGRAM PROFILE/
4432: PFMS2 DAC B$SCL
4433: DAC 42
4434: DTC /STMT NUMBER OF -- EXECUTION TIME --/
4435: PFMS3 DAC B$SCL
4436: DAC 47
4437: DTC /NUMBER EXECUTIONS TOTAL(MSEC) PER EXCN(MCSEC)/
4438: *
4439: *
4440: * REAL CONSTANTS FOR GENERAL USE. NOTE THAT THE CONSTANTS
4441: * STARTING AT REAV1 FORM A POWERS OF TEN TABLE (GTSTG)
4442: *
4443: REAV0 DRC +0.0 0.0
4444: REAP1 DRC +0.1 0.1
4445: REAP5 DRC +0.5 0.5
4446: REAV1 DRC +1.0 10**0
4447: REAVT DRC +1.0E+1 10**1
4448: DRC +1.0E+2 10**2
4449: DRC +1.0E+3 10**3
4450: DRC +1.0E+4 10**4
4451: DRC +1.0E+5 10**5
4452: DRC +1.0E+6 10**6
4453: DRC +1.0E+7 10**7
4454: DRC +1.0E+8 10**8
4455: DRC +1.0E+9 10**9
4456: REATT DRC +1.0E+10 10**10
4457: EJC
4458: *
4459: * STRING CONSTANTS (SCBLK FORMAT) FOR DTYPE PROCEDURE
4460: *
4461: SCARR DAC B$SCL ARRAY
4462: DAC 5
4463: DTC /ARRAY/
4464: *
4465: SCBUF DAC B$SCL BUFFER
4466: DAC 6
4467: DTC /BUFFER/
4468: *
4469: SCCOD DAC B$SCL CODE
4470: DAC 4
4471: DTC /CODE/
4472: *
4473: SCEXP DAC B$SCL EXPRESSION
4474: DAC 10
4475: DTC /EXPRESSION/
4476: *
4477: SCEXT DAC B$SCL EXTERNAL
4478: DAC 8
4479: DTC /EXTERNAL/
4480: *
4481: SCINT DAC B$SCL INTEGER
4482: DAC 7
4483: DTC /INTEGER/
4484: *
4485: SCNAM DAC B$SCL NAME
4486: DAC 4
4487: DTC /NAME/
4488: *
4489: SCNUM DAC B$SCL NUMERIC
4490: DAC 7
4491: DTC /NUMERIC/
4492: *
4493: SCPAT DAC B$SCL PATTERN
4494: DAC 7
4495: DTC /PATTERN/
4496: *
4497: SCREA DAC B$SCL REAL
4498: DAC 4
4499: DTC /REAL/
4500: *
4501: SCSTR DAC B$SCL STRING
4502: DAC 6
4503: DTC /STRING/
4504: *
4505: SCTAB DAC B$SCL TABLE
4506: DAC 5
4507: DTC /TABLE/
4508: EJC
4509: *
4510: * STRING CONSTANTS (SCBLK FORMAT) FOR KVRTN (SEE RETRN)
4511: *
4512: SCFRT DAC B$SCL FRETURN
4513: DAC 7
4514: DTC /FRETURN/
4515: *
4516: SCNRT DAC B$SCL NRETURN
4517: DAC 7
4518: DTC /NRETURN/
4519: *
4520: SCRTN DAC B$SCL RETURN
4521: DAC 6
4522: DTC /RETURN/
4523: *
4524: * DATATYPE NAME TABLE FOR DTYPE PROCEDURE. THE ORDER OF
4525: * THESE ENTRIES IS TIED TO THE B$XXX DEFINITIONS FOR BLOCKS
4526: *
4527: SCNMT DAC SCARR ARBLK ARRAY
4528: DAC SCBUF BFBLK BUFFER
4529: DAC SCCOD CDBLK CODE
4530: DAC SCEXP EXBLK EXPRESSION
4531: DAC SCINT ICBLK INTEGER
4532: DAC SCNAM NMBLK NAME
4533: DAC SCPAT P0BLK PATTERN
4534: DAC SCPAT P1BLK PATTERN
4535: DAC SCPAT P2BLK PATTERN
4536: DAC SCREA RCBLK REAL
4537: DAC SCSTR SCBLK STRING
4538: DAC SCEXP SEBLK EXPRESSION
4539: DAC SCTAB TBBLK TABLE
4540: DAC SCARR VCBLK ARRAY
4541: DAC SCEXT XNBLK EXTERNAL
4542: DAC SCEXT XRBLK EXTERNAL
4543: *
4544: * STRING CONSTANT FOR REAL ZERO
4545: *
4546: SCRE0 DAC B$SCL
4547: DAC 2
4548: DTC /0./
4549: EJC
4550: *
4551: * USED TO RE-INITIALISE KVSTL
4552: *
4553: STLIM DIC +50000 DEFAULT STATEMENT LIMIT
4554: *
4555: * DUMMY FUNCTION BLOCK USED FOR UNDEFINED FUNCTIONS
4556: *
4557: STNDF DAC O$FUN PTR TO UNDEFINED FUNCTION ERR CALL
4558: DAC 0 DUMMY FARGS COUNT FOR CALL CIRCUIT
4559: *
4560: * DUMMY CODE BLOCK USED FOR UNDEFINED LABELS
4561: *
4562: STNDL DAC L$UND CODE PTR POINTS TO UNDEFINED LBL
4563: *
4564: * DUMMY OPERATOR BLOCK USED FOR UNDEFINED OPERATORS
4565: *
4566: STNDO DAC O$OUN PTR TO UNDEFINED OPERATOR ERR CALL
4567: DAC 0 DUMMY FARGS COUNT FOR CALL CIRCUIT
4568: *
4569: * STANDARD VARIABLE BLOCK. THIS BLOCK IS USED TO INITIALIZE
4570: * THE FIRST SEVEN FIELDS OF A NEWLY CONSTRUCTED VRBLK.
4571: * ITS FORMAT IS TIED TO THE VRBLK DEFINITIONS (SEE GTNVR).
4572: *
4573: STNVR DAC B$VRL VRGET
4574: DAC B$VRS VRSTO
4575: DAC NULLS VRVAL
4576: DAC B$VRG VRTRA
4577: DAC STNDL VRLBL
4578: DAC STNDF VRFNC
4579: DAC 0 VRNXT
4580: EJC
4581: *
4582: * MESSAGES USED IN END OF RUN PROCESSING (STOPR)
4583: *
4584: STPM1 DAC B$SCL IN STATEMENT
4585: DAC 12
4586: DTC /IN STATEMENT/
4587: *
4588: STPM2 DAC B$SCL
4589: DAC 14
4590: DTC /STMTS EXECUTED/
4591: *
4592: STPM3 DAC B$SCL
4593: DAC 13
4594: DTC /RUN TIME-MSEC/
4595: *
4596: STPM4 DAC B$SCL
4597: DAC 12
4598: DTC $MCSEC / STMT$
4599: *
4600: STPM5 DAC B$SCL
4601: DAC 13
4602: DTC /REGENERATIONS/
4603: *
4604: * CHARS FOR /TU/ ENDING CODE
4605: *
4606: STRTU DTC /TU/
4607: *
4608: * TABLE USED BY CONVERT FUNCTION TO CHECK DATATYPE NAME
4609: * THE ENTRIES ARE ORDERED TO CORRESPOND TO BRANCH TABLE
4610: * IN S$CNV
4611: *
4612: SVCTB DAC SCSTR STRING
4613: DAC SCINT INTEGER
4614: DAC SCNAM NAME
4615: DAC SCPAT PATTERN
4616: DAC SCARR ARRAY
4617: DAC SCTAB TABLE
4618: DAC SCEXP EXPRESSION
4619: DAC SCCOD CODE
4620: DAC SCNUM NUMERIC
4621: DAC SCREA REAL
4622: DAC SCBUF BUFFER
4623: DAC 0 ZERO MARKS END OF LIST
4624: EJC
4625: *
4626: * MESSAGES (SCBLK FORMAT) USED BY TRACE PROCEDURES
4627: *
4628: *
4629: TMASB DAC B$SCL ASTERISKS FOR TRACE STATEMENT NO
4630: DAC 13
4631: DTC /************ /
4632:
4633: *
4634: TMBEB DAC B$SCL BLANK-EQUAL-BLANK
4635: DAC 3
4636: DTC / = /
4637: *
4638: * DUMMY TRBLK FOR EXPRESSION VARIABLE
4639: *
4640: TRBEV DAC B$TRT DUMMY TRBLK
4641: *
4642: * DUMMY TRBLK FOR KEYWORD VARIABLE
4643: *
4644: TRBKV DAC B$TRT DUMMY TRBLK
4645: *
4646: * DUMMY CODE BLOCK TO RETURN CONTROL TO TRXEQ PROCEDURE
4647: *
4648: TRXDR DAC O$TXR BLOCK POINTS TO RETURN ROUTINE
4649: TRXDC DAC TRXDR POINTER TO BLOCK
4650: EJC
4651: *
4652: * STANDARD VARIABLE BLOCKS
4653: *
4654: * SEE SVBLK FORMAT FOR FULL DETAILS OF THE FORMAT. THE
4655: * VRBLKS ARE ORDERED BY LENGTH AND WITHIN EACH LENGTH THE
4656: * ORDER IS ALPHABETICAL BY NAME OF THE VARIABLE.
4657: *
4658: V$EQF DBC SVFPR EQ
4659: DAC 2
4660: DTC /EQ/
4661: DAC S$EQF
4662: DAC 2
4663: *
4664: V$GEF DBC SVFPR GE
4665: DAC 2
4666: DTC /GE/
4667: DAC S$GEF
4668: DAC 2
4669: *
4670: V$GTF DBC SVFPR GT
4671: DAC 2
4672: DTC /GT/
4673: DAC S$GTF
4674: DAC 2
4675: *
4676: V$LEF DBC SVFPR LE
4677: DAC 2
4678: DTC /LE/
4679: DAC S$LEF
4680: DAC 2
4681: *
4682: V$LTF DBC SVFPR LT
4683: DAC 2
4684: DTC /LT/
4685: DAC S$LTF
4686: DAC 2
4687: *
4688: V$NEF DBC SVFPR NE
4689: DAC 2
4690: DTC /NE/
4691: DAC S$NEF
4692: DAC 2
4693: *
4694: V$ANY DBC SVFNP ANY
4695: DAC 3
4696: DTC /ANY/
4697: DAC S$ANY
4698: DAC 1
4699: *
4700: V$ARB DBC SVKVC ARB
4701: DAC 3
4702: DTC /ARB/
4703: DAC K$ARB
4704: DAC NDARB
4705: EJC
4706: *
4707: * STANDARD VARIABLE BLOCKS (CONTINUED)
4708: *
4709: V$ARG DBC SVFNN ARG
4710: DAC 3
4711: DTC /ARG/
4712: DAC S$ARG
4713: DAC 2
4714: *
4715: V$BAL DBC SVKVC BAL
4716: DAC 3
4717: DTC /BAL/
4718: DAC K$BAL
4719: DAC NDBAL
4720: *
4721: V$END DBC SVLBL END
4722: DAC 3
4723: DTC /END/
4724: DAC L$END
4725: *
4726: V$LEN DBC SVFNP LEN
4727: DAC 3
4728: DTC /LEN/
4729: DAC S$LEN
4730: DAC 1
4731: *
4732: V$LEQ DBC SVFPR LEQ
4733: DAC 3
4734: DTC /LEQ/
4735: DAC S$LEQ
4736: DAC 2
4737: *
4738: V$LGE DBC SVFPR LGE
4739: DAC 3
4740: DTC /LGE/
4741: DAC S$LGE
4742: DAC 2
4743: *
4744: V$LGT DBC SVFPR LGT
4745: DAC 3
4746: DTC /LGT/
4747: DAC S$LGT
4748: DAC 2
4749: *
4750: V$LLE DBC SVFPR LLE
4751: DAC 3
4752: DTC /LLE/
4753: DAC S$LLE
4754: DAC 2
4755: EJC
4756: *
4757: * STANDARD VARIABLE BLOCKS (CONTINUED)
4758: *
4759: V$LLT DBC SVFPR LLT
4760: DAC 3
4761: DTC /LLT/
4762: DAC S$LLT
4763: DAC 2
4764: *
4765: V$LNE DBC SVFPR LNE
4766: DAC 3
4767: DTC /LNE/
4768: DAC S$LNE
4769: DAC 2
4770: *
4771: V$POS DBC SVFNP POS
4772: DAC 3
4773: DTC /POS/
4774: DAC S$POS
4775: DAC 1
4776: *
4777: V$REM DBC SVKVC REM
4778: DAC 3
4779: DTC /REM/
4780: DAC K$REM
4781: DAC NDREM
4782: *
4783: V$SET DBC SVFNN SET
4784: DAC 3
4785: DTC /SET/
4786: DAC S$SET
4787: DAC 3
4788: *
4789: V$TAB DBC SVFNP TAB
4790: DAC 3
4791: DTC /TAB/
4792: DAC S$TAB
4793: DAC 1
4794: *
4795: V$CAS DBC SVKNM CASE
4796: DAC 4
4797: DTC /CASE/
4798: DAC K$CAS
4799: *
4800: V$CHR DBC SVFNP CHAR
4801: DAC 4
4802: DTC /CHAR/
4803: DAC S$CHR
4804: DAC 1
4805: *
4806: V$COD DBC SVFNK CODE
4807: DAC 4
4808: DTC /CODE/
4809: DAC K$COD
4810: DAC S$COD
4811: DAC 1
4812: *
4813: V$COP DBC SVFNN COPY
4814: DAC 4
4815: DTC /COPY/
4816: DAC S$COP
4817: DAC 1
4818: EJC
4819: *
4820: * STANDARD VARIABLE BLOCKS (CONTINUED)
4821: *
4822: V$DAT DBC SVFNN DATA
4823: DAC 4
4824: DTC /DATA/
4825: DAC S$DAT
4826: DAC 1
4827: *
4828: V$DTE DBC SVFNN DATE
4829: DAC 4
4830: DTC /DATE/
4831: DAC S$DTE
4832: DAC 0
4833: *
4834: V$DMP DBC SVFNK DUMP
4835: DAC 4
4836: DTC /DUMP/
4837: DAC K$DMP
4838: DAC S$DMP
4839: DAC 1
4840: *
4841: V$DUP DBC SVFNN DUPL
4842: DAC 4
4843: DTC /DUPL/
4844: DAC S$DUP
4845: DAC 2
4846: *
4847: V$EVL DBC SVFNN EVAL
4848: DAC 4
4849: DTC /EVAL/
4850: DAC S$EVL
4851: DAC 1
4852: *
4853: V$EXT DBC SVFNN EXIT
4854: DAC 4
4855: DTC /EXIT/
4856: DAC S$EXT
4857: DAC 1
4858: *
4859: V$FAL DBC SVKVC FAIL
4860: DAC 4
4861: DTC /FAIL/
4862: DAC K$FAL
4863: DAC NDFAL
4864: *
4865: V$HST DBC SVFNN HOST
4866: DAC 4
4867: DTC /HOST/
4868: DAC S$HST
4869: DAC 3
4870: EJC
4871: *
4872: * STANDARD VARIABLE BLOCKS (CONTINUED)
4873: *
4874: V$ITM DBC SVFNF ITEM
4875: DAC 4
4876: DTC /ITEM/
4877: DAC S$ITM
4878: DAC 999
4879: *
4880: V$LOD DBC SVFNN LOAD
4881: DAC 4
4882: DTC /LOAD/
4883: DAC S$LOD
4884: DAC 2
4885: *
4886: V$LPD DBC SVFNP LPAD
4887: DAC 4
4888: DTC /LPAD/
4889: DAC S$LPD
4890: DAC 3
4891: *
4892: V$RPD DBC SVFNP RPAD
4893: DAC 4
4894: DTC /RPAD/
4895: DAC S$RPD
4896: DAC 3
4897: *
4898: V$RPS DBC SVFNP RPOS
4899: DAC 4
4900: DTC /RPOS/
4901: DAC S$RPS
4902: DAC 1
4903: *
4904: V$RTB DBC SVFNP RTAB
4905: DAC 4
4906: DTC /RTAB/
4907: DAC S$RTB
4908: DAC 1
4909: *
4910: V$SI$ DBC SVFNP SIZE
4911: DAC 4
4912: DTC /SIZE/
4913: DAC S$SI$
4914: DAC 1
4915: *
4916: *
4917: V$SRT DBC SVFNN SORT
4918: DAC 4
4919: DTC /SORT/
4920: DAC S$SRT
4921: DAC 2
4922: V$SPN DBC SVFNP SPAN
4923: DAC 4
4924: DTC /SPAN/
4925: DAC S$SPN
4926: DAC 1
4927: EJC
4928: *
4929: * STANDARD VARIABLE BLOCKS (CONTINUED)
4930: *
4931: V$STN DBC SVKNM STNO
4932: DAC 4
4933: DTC /STNO/
4934: DAC K$STN
4935: *
4936: V$TIM DBC SVFNN TIME
4937: DAC 4
4938: DTC /TIME/
4939: DAC S$TIM
4940: DAC 0
4941: *
4942: V$TRM DBC SVFNK TRIM
4943: DAC 4
4944: DTC /TRIM/
4945: DAC K$TRM
4946: DAC S$TRM
4947: DAC 1
4948: *
4949: V$ABE DBC SVKNM ABEND
4950: DAC 5
4951: DTC /ABEND/
4952: DAC K$ABE
4953: *
4954: V$ABO DBC SVKVL ABORT
4955: DAC 5
4956: DTC /ABORT/
4957: DAC K$ABO
4958: DAC L$ABO
4959: DAC NDABO
4960: *
4961: V$APP DBC SVFNF APPLY
4962: DAC 5
4963: DTC /APPLY/
4964: DAC S$APP
4965: DAC 999
4966: *
4967: V$ABN DBC SVFNP ARBNO
4968: DAC 5
4969: DTC /ARBNO/
4970: DAC S$ABN
4971: DAC 1
4972: *
4973: V$ARR DBC SVFNN ARRAY
4974: DAC 5
4975: DTC /ARRAY/
4976: DAC S$ARR
4977: DAC 2
4978: EJC
4979: *
4980: * STANDARD VARIABLE BLOCKS (CONTINUED)
4981: *
4982: V$BRK DBC SVFNP BREAK
4983: DAC 5
4984: DTC /BREAK/
4985: DAC S$BRK
4986: DAC 1
4987: *
4988: V$CLR DBC SVFNN CLEAR
4989: DAC 5
4990: DTC /CLEAR/
4991: DAC S$CLR
4992: DAC 1
4993: *
4994: V$EJC DBC SVFNN EJECT
4995: DAC 5
4996: DTC /EJECT/
4997: DAC S$EJC
4998: DAC 1
4999: *
5000: V$FEN DBC SVFPK FENCE
5001: DAC 5
5002: DTC /FENCE/
5003: DAC K$FEN
5004: DAC S$FNC
5005: DAC 1
5006: DAC NDFEN
5007: *
5008: V$FLD DBC SVFNN FIELD
5009: DAC 5
5010: DTC /FIELD/
5011: DAC S$FLD
5012: DAC 2
5013: *
5014: V$IDN DBC SVFPR IDENT
5015: DAC 5
5016: DTC /IDENT/
5017: DAC S$IDN
5018: DAC 2
5019: *
5020: V$INP DBC SVFNK INPUT
5021: DAC 5
5022: DTC /INPUT/
5023: DAC K$INP
5024: DAC S$INP
5025: DAC 3
5026: *
5027: V$LOC DBC SVFNN LOCAL
5028: DAC 5
5029: DTC /LOCAL/
5030: DAC S$LOC
5031: DAC 2
5032: EJC
5033: *
5034: * STANDARD VARIABLE BLOCKS (CONTINUED)
5035: *
5036: V$OPS DBC SVFNN OPSYN
5037: DAC 5
5038: DTC /OPSYN/
5039: DAC S$OPS
5040: DAC 3
5041: *
5042: V$RMD DBC SVFNP REMDR
5043: DAC 5
5044: DTC /REMDR/
5045: DAC S$RMD
5046: DAC 2
5047: *
5048: V$RSR DBC SVFNN RSORT
5049: DAC 5
5050: DTC /RSORT/
5051: DAC S$RSR
5052: DAC 2
5053: *
5054: V$TBL DBC SVFNN TABLE
5055: DAC 5
5056: DTC /TABLE/
5057: DAC S$TBL
5058: DAC 3
5059: *
5060: V$TRA DBC SVFNK TRACE
5061: DAC 5
5062: DTC /TRACE/
5063: DAC K$TRA
5064: DAC S$TRA
5065: DAC 4
5066: *
5067: V$ANC DBC SVKNM ANCHOR
5068: DAC 6
5069: DTC /ANCHOR/
5070: DAC K$ANC
5071: *
5072: V$APN DBC SVFNN
5073: DAC 6
5074: DTC /APPEND/
5075: DAC S$APN
5076: DAC 2
5077: *
5078: V$BKX DBC SVFNP BREAKX
5079: DAC 6
5080: DTC /BREAKX/
5081: DAC S$BKX
5082: DAC 1
5083: *
5084: V$BUF DBC SVFNN BUFFER
5085: DAC 6
5086: DTC /BUFFER/
5087: DAC S$BUF
5088: DAC 2
5089: *
5090: V$DEF DBC SVFNN DEFINE
5091: DAC 6
5092: DTC /DEFINE/
5093: DAC S$DEF
5094: DAC 2
5095: *
5096: V$DET DBC SVFNN DETACH
5097: DAC 6
5098: DTC /DETACH/
5099: DAC S$DET
5100: DAC 1
5101: EJC
5102: *
5103: * STANDARD VARIABLE BLOCKS (CONTINUED)
5104: *
5105: V$DIF DBC SVFPR DIFFER
5106: DAC 6
5107: DTC /DIFFER/
5108: DAC S$DIF
5109: DAC 2
5110: *
5111: V$FTR DBC SVKNM FTRACE
5112: DAC 6
5113: DTC /FTRACE/
5114: DAC K$FTR
5115: *
5116: V$INS DBC SVFNN INSERT
5117: DAC 6
5118: DTC /INSERT/
5119: DAC S$INS
5120: DAC 4
5121: *
5122: V$LST DBC SVKNM LASTNO
5123: DAC 6
5124: DTC /LASTNO/
5125: DAC K$LST
5126: *
5127: V$NAY DBC SVFNP NOTANY
5128: DAC 6
5129: DTC /NOTANY/
5130: DAC S$NAY
5131: DAC 1
5132: *
5133: V$OUP DBC SVFNK OUTPUT
5134: DAC 6
5135: DTC /OUTPUT/
5136: DAC K$OUP
5137: DAC S$OUP
5138: DAC 3
5139: *
5140: V$RET DBC SVLBL RETURN
5141: DAC 6
5142: DTC /RETURN/
5143: DAC L$RTN
5144: *
5145: V$REW DBC SVFNN REWIND
5146: DAC 6
5147: DTC /REWIND/
5148: DAC S$REW
5149: DAC 1
5150: *
5151: V$STT DBC SVFNN STOPTR
5152: DAC 6
5153: DTC /STOPTR/
5154: DAC S$STT
5155: DAC 2
5156: EJC
5157: *
5158: * STANDARD VARIABLE BLOCKS (CONTINUED)
5159: *
5160: V$SUB DBC SVFNN SUBSTR
5161: DAC 6
5162: DTC /SUBSTR/
5163: DAC S$SUB
5164: DAC 3
5165: *
5166: V$UNL DBC SVFNN UNLOAD
5167: DAC 6
5168: DTC /UNLOAD/
5169: DAC S$UNL
5170: DAC 1
5171: *
5172: V$COL DBC SVFNN COLLECT
5173: DAC 7
5174: DTC /COLLECT/
5175: DAC S$COL
5176: DAC 1
5177: *
5178: V$CNV DBC SVFNN CONVERT
5179: DAC 7
5180: DTC /CONVERT/
5181: DAC S$CNV
5182: DAC 2
5183: *
5184: V$ENF DBC SVFNN ENDFILE
5185: DAC 7
5186: DTC /ENDFILE/
5187: DAC S$ENF
5188: DAC 1
5189: *
5190: V$ETX DBC SVKNM ERRTEXT
5191: DAC 7
5192: DTC /ERRTEXT/
5193: DAC K$ETX
5194: *
5195: V$ERT DBC SVKNM ERRTYPE
5196: DAC 7
5197: DTC /ERRTYPE/
5198: DAC K$ERT
5199: *
5200: V$FRT DBC SVLBL FRETURN
5201: DAC 7
5202: DTC /FRETURN/
5203: DAC L$FRT
5204: *
5205: V$INT DBC SVFPR INTEGER
5206: DAC 7
5207: DTC /INTEGER/
5208: DAC S$INT
5209: DAC 1
5210: *
5211: V$NRT DBC SVLBL NRETURN
5212: DAC 7
5213: DTC /NRETURN/
5214: DAC L$NRT
5215: EJC
5216: *
5217: * STANDARD VARIABLE BLOCKS (CONTINUED)
5218: *
5219: *
5220: V$PFL DBC SVKNM PROFILE
5221: DAC 7
5222: DTC /PROFILE/
5223: DAC K$PFL
5224: *
5225: V$RPL DBC SVFNP REPLACE
5226: DAC 7
5227: DTC /REPLACE/
5228: DAC S$RPL
5229: DAC 3
5230: *
5231: V$RVS DBC SVFNP REVERSE
5232: DAC 7
5233: DTC /REVERSE/
5234: DAC S$RVS
5235: DAC 1
5236: *
5237: V$RTN DBC SVKNM RTNTYPE
5238: DAC 7
5239: DTC /RTNTYPE/
5240: DAC K$RTN
5241: *
5242: V$STX DBC SVFNN SETEXIT
5243: DAC 7
5244: DTC /SETEXIT/
5245: DAC S$STX
5246: DAC 1
5247: *
5248: V$STC DBC SVKNM STCOUNT
5249: DAC 7
5250: DTC /STCOUNT/
5251: DAC K$STC
5252: *
5253: V$STL DBC SVKNM STLIMIT
5254: DAC 7
5255: DTC /STLIMIT/
5256: DAC K$STL
5257: *
5258: V$SUC DBC SVKVC SUCCEED
5259: DAC 7
5260: DTC /SUCCEED/
5261: DAC K$SUC
5262: DAC NDSUC
5263: *
5264: V$ALP DBC SVKWC ALPHABET
5265: DAC 8
5266: DTC /ALPHABET/
5267: DAC K$ALP
5268: *
5269: V$CNT DBC SVLBL CONTINUE
5270: DAC 8
5271: DTC /CONTINUE/
5272: DAC L$CNT
5273: EJC
5274: *
5275: * STANDARD VARIABLE BLOCKS (CONTINUED)
5276: *
5277: V$DTP DBC SVFNP DATATYPE
5278: DAC 8
5279: DTC /DATATYPE/
5280: DAC S$DTP
5281: DAC 1
5282: *
5283: V$ERL DBC SVKNM ERRLIMIT
5284: DAC 8
5285: DTC /ERRLIMIT/
5286: DAC K$ERL
5287: *
5288: V$FNC DBC SVKNM FNCLEVEL
5289: DAC 8
5290: DTC /FNCLEVEL/
5291: DAC K$FNC
5292: *
5293: V$MXL DBC SVKNM MAXLNGTH
5294: DAC 8
5295: DTC /MAXLNGTH/
5296: DAC K$MXL
5297: *
5298: V$TER DBC 0 TERMINAL
5299: DAC 8
5300: DTC /TERMINAL/
5301: DAC 0
5302: *
5303: V$PRO DBC SVFNN PROTOTYPE
5304: DAC 9
5305: DTC /PROTOTYPE/
5306: DAC S$PRO
5307: DAC 1
5308: *
5309: DBC 0 DUMMY ENTRY TO END LIST
5310: DAC 10 LENGTH GT 9 (PROTOTYPE)
5311: EJC
5312: *
5313: * LIST OF SVBLK POINTERS FOR KEYWORDS TO BE DUMPED. THE
5314: * LIST IS IN THE ORDER WHICH APPEARS ON THE DUMP OUTPUT.
5315: *
5316: VDMKW DAC V$ANC ANCHOR
5317: DAC V$CAS CCASE
5318: DAC V$COD CODE
5319: DAC V$DMP DUMP
5320: DAC V$ERL ERRLIMIT
5321: DAC V$ETX ERRTEXT
5322: DAC V$ERT ERRTYPE
5323: DAC V$FNC FNCLEVEL
5324: DAC V$FTR FTRACE
5325: DAC V$INP INPUT
5326: DAC V$LST LASTNO
5327: DAC V$MXL MAXLENGTH
5328: DAC V$OUP OUTPUT
5329: DAC V$PFL PROFILE
5330: DAC V$RTN RTNTYPE
5331: DAC V$STC STCOUNT
5332: DAC V$STL STLIMIT
5333: DAC V$STN STNO
5334: DAC V$TRA TRACE
5335: DAC V$TRM TRIM
5336: DAC 0 END OF LIST
5337: *
5338: * TABLE USED BY GTNVR TO SEARCH SVBLK LISTS
5339: *
5340: VSRCH DAC 0 DUMMY ENTRY TO GET PROPER INDEXING
5341: DAC V$EQF START OF 1 CHAR VARIABLES (NONE)
5342: DAC V$EQF START OF 2 CHAR VARIABLES
5343: DAC V$ANY START OF 3 CHAR VARIABLES
5344: DAC V$CAS START OF 4 CHAR VARIABLES
5345: DAC V$ABE START OF 5 CHAR VARIABLES
5346: DAC V$ANC START OF 6 CHAR VARIABLES
5347: DAC V$COL START OF 7 CHAR VARIABLES
5348: DAC V$ALP START OF 8 CHAR VARIABLES
5349: DAC V$PRO START OF 9 CHAR VARIABLES
5350: TTL S P I T B O L -- WORKING STORAGE SECTION
5351: *
5352: * THE WORKING STORAGE SECTION CONTAINS AREAS WHICH ARE
5353: * CHANGED DURING EXECUTION OF THE PROGRAM. THE VALUE
5354: * ASSEMBLED IS THE INITIAL VALUE BEFORE EXECUTION STARTS.
5355: *
5356: * ALL THESE AREAS ARE FIXED LENGTH AREAS. VARIABLE LENGTH
5357: * DATA IS STORED IN THE STATIC OR DYNAMIC REGIONS OF THE
5358: * ALLOCATED DATA AREAS.
5359: *
5360: * THE VALUES IN THIS AREA ARE DESCRIBED EITHER AS WORK
5361: * AREAS OR AS GLOBAL VALUES. A WORK AREA IS USED IN AN
5362: * EPHEMERAL MANNER AND THE VALUE IS NOT SAVED FROM ONE
5363: * ENTRY INTO A ROUTINE TO ANOTHER. A GLOBAL VALUE IS A
5364: * LESS TEMPORARY LOCATION WHOSE VALUE IS SAVED FROM ONE
5365: * CALL TO ANOTHER.
5366: *
5367: * A GENERAL PART OF THE APPROACH IN THIS PROGRAM IS NOT
5368: * TO OVERLAP WORK AREAS BETWEEN PROCEDURES EVEN THOUGH A
5369: * SMALL AMOUNT OF SPACE COULD BE SAVED. SUCH OVERLAP IS
5370: * CONSIDERED A SOURCE OF PROGRAM ERRORS AND DECREASES THE
5371: * INFORMATION LEFT BEHIND AFTER A SYSTEM CRASH OF ANY KIND.
5372: *
5373: * THE NAMES OF THESE LOCATIONS ARE LABELS WITH FIVE LETTER
5374: * (A-Y,$) NAMES. AS FAR AS POSSIBLE THE ORDER IS KEPT
5375: * ALPHABETICAL BY THESE NAMES BUT IN SOME CASES THERE
5376: * ARE SLIGHT DEPARTURES CAUSED BY OTHER ORDER REQUIREMENTS.
5377: *
5378: * UNLESS OTHERWISE DOCUMENTED, THE ORDER OF WORK AREAS
5379: * DOES NOT AFFECT THE EXECUTION OF THE SPITBOL PROGRAM.
5380: *
5381: SEC START OF WORKING STORAGE SECTION
5382: EJC
5383: *
5384: * THIS AREA IS NOT CLEARED BY INITIAL CODE
5385: *
5386: CMLAB DAC B$SCL STRING USED TO CHECK LABEL LEGALITY
5387: DAC 2
5388: DTC / /
5389: *
5390: * LABEL TO MARK START OF WORK AREA
5391: *
5392: AAAAA DAC 0
5393: *
5394: * WORK AREAS FOR ALLOC PROCEDURE
5395: *
5396: ALDYN DAC 0 AMOUNT OF DYNAMIC STORE
5397: ALFSF DIC +0 FACTOR IN FREE STORE PCNTAGE CHECK
5398: ALLIA DIC +0 DUMP IA
5399: ALLSV DAC 0 SAVE WB IN ALLOC
5400: *
5401: * WORK AREAS FOR ALOST PROCEDURE
5402: *
5403: ALSTA DAC 0 SAVE WA IN ALOST
5404: *
5405: * SAVE AREAS FOR ARRAY FUNCTION (S$ARR)
5406: *
5407: ARCDM DAC 0 COUNT DIMENSIONS
5408: ARNEL DIC +0 COUNT ELEMENTS
5409: ARPTR DAC 0 OFFSET PTR INTO ARBLK
5410: ARSVL DIC +0 SAVE INTEGER LOW BOUND
5411: EJC
5412: * WORK AREAS FOR ARREF ROUTINE
5413: *
5414: ARFSI DIC +0 SAVE CURRENT EVOLVING SUBSCRIPT
5415: ARFXS DAC 0 SAVE BASE STACK POINTER
5416: *
5417: * WORK AREAS FOR B$EFC BLOCK ROUTINE
5418: *
5419: BEFOF DAC 0 SAVE OFFSET PTR INTO EFBLK
5420: *
5421: * WORK AREAS FOR B$PFC BLOCK ROUTINE
5422: *
5423: BPFPF DAC 0 SAVE PFBLK POINTER
5424: BPFSV DAC 0 SAVE OLD FUNCTION VALUE
5425: BPFXT DAC 0 POINTER TO STACKED ARGUMENTS
5426: *
5427: * SAVE AREAS FOR COLLECT FUNCTION (S$COL)
5428: *
5429: CLSVI DIC +0 SAVE INTEGER ARGUMENT
5430: *
5431: * GLOBAL VALUES FOR CMPIL PROCEDURE
5432: *
5433: CMERC DAC 0 COUNT OF INITIAL COMPILE ERRORS
5434: CMPXS DAC 0 SAVE STACK PTR IN CASE OF ERRORS
5435: CMPSN DAC 1 NUMBER OF NEXT STATEMENT TO COMPILE
5436: CMPSS DAC 0 SAVE SUBROUTINE STACK PTR
5437: *
5438: * WORK AREA FOR CNCRD
5439: *
5440: CNSCC DAC 0 POINTER TO CONTROL CARD STRING
5441: CNSWC DAC 0 WORD COUNT
5442: CNR$T DAC 0 POINTER TO R$TTL OR R$STL
5443: CNTTL DAC 0 FLAG FOR -TITLE, -STITL
5444: *
5445: * WORK AREAS FOR CONVERT FUNCTION (S$CNV)
5446: *
5447: CNVTP DAC 0 SAVE PTR INTO SCVTB
5448: *
5449: * FLAG FOR SUPPRESSION OF COMPILATION STATISTICS.
5450: *
5451: CPSTS DAC 0 SUPPRESS COMP. STATS IF NON ZERO
5452: *
5453: * GLOBAL VALUES FOR CONTROL CARD SWITCHES
5454: *
5455: CSWDB DAC 0 0/1 FOR -SINGLE/-DOUBLE
5456: CSWER DAC 0 0/1 FOR -ERRORS/-NOERRORS
5457: CSWEX DAC 0 0/1 FOR -EXECUTE/-NOEXECUTE
5458: CSWFL DAC 1 0/1 FOR -NOFAIL/-FAIL
5459: CSWIN DAC INILN XXX FOR -INXXX
5460: CSWLS DAC 1 0/1 FOR -NOLIST/-LIST
5461: CSWNO DAC 0 0/1 FOR -OPTIMISE/-NOOPT
5462: CSWPR DAC 0 0/1 FOR -NOPRINT/-PRINT
5463: *
5464: * GLOBAL LOCATION USED BY PATST PROCEDURE
5465: *
5466: CTMSK DBC 0 LAST BIT POSITION USED IN R$CTP
5467: CURID DAC 0 CURRENT ID VALUE
5468: EJC
5469: *
5470: * GLOBAL VALUE FOR CDWRD PROCEDURE
5471: *
5472: CWCOF DAC 0 NEXT WORD OFFSET IN CURRENT CCBLK
5473: *
5474: * WORK AREAS FOR DATA FUNCTION (S$DAT)
5475: *
5476: DATDV DAC 0 SAVE VRBLK PTR FOR DATATYPE NAME
5477: DATXS DAC 0 SAVE INITIAL STACK POINTER
5478: *
5479: * WORK AREAS FOR DEFINE FUNCTION (S$DEF)
5480: *
5481: DEFLB DAC 0 SAVE VRBLK PTR FOR LABEL
5482: DEFNA DAC 0 COUNT FUNCTION ARGUMENTS
5483: DEFVR DAC 0 SAVE VRBLK PTR FOR FUNCTION NAME
5484: DEFXS DAC 0 SAVE INITIAL STACK POINTER
5485: *
5486: * WORK AREAS FOR DUMPR PROCEDURE
5487: *
5488: DMARG DAC 0 DUMP ARGUMENT
5489: DMPKB DAC B$KVT DUMMY KVBLK FOR USE IN DUMPR
5490: DMPKT DAC TRBKV KVVAR TRBLK POINTER
5491: DMPKN DAC 0 KEYWORD NUMBER (MUST FOLLOW DMPKB)
5492: DMPSA DAC 0 PRESERVE WA OVER PRTVL CALL
5493: DMPSV DAC 0 GENERAL SCRATCH SAVE
5494: DMVCH DAC 0 CHAIN POINTER FOR VARIABLE BLOCKS
5495: DMPCH DAC 0 SAVE SORTED VRBLK CHAIN POINTER
5496: *
5497: * GLOBAL LOCATIONS FOR DYNAMIC STORAGE POINTERS
5498: *
5499: DNAMB DAC 0 START OF DYNAMIC AREA
5500: DNAMP DAC 0 NEXT AVAILABLE LOC IN DYNAMIC AREA
5501: DNAME DAC 0 END OF AVAILABLE DYNAMIC AREA
5502: *
5503: * WORK AREA FOR DTACH
5504: *
5505: DTCNB DAC 0 NAME BASE
5506: DTCNM DAC 0 NAME PTR
5507: *
5508: * WORK AREAS FOR DUPL FUNCTION (S$DUP)
5509: *
5510: DUPSI DIC +0 STORE INTEGER STRING LENGTH
5511: *
5512: * WORK AREA FOR ENDFILE (S$ENF)
5513: *
5514: ENFCH DAC 0 FOR IOCHN CHAIN HEAD
5515: *
5516: * WORK AREA FOR ERROR PROCESSING.
5517: *
5518: ERICH DAC 0 COPY ERROR REPORTS TO INT.CHAN IF 1
5519: ERLST DAC 0 FOR LISTR WHEN ERRORS GO TO INT.CH.
5520: ERRFT DAC 0 FATAL ERROR FLAG
5521: ERRSP DAC 0 ERROR SUPPRESSION FLAG
5522: EJC
5523: *
5524: * DUMP AREA FOR ERTEX
5525: *
5526: ERTWA DAC 0 SAVE WA
5527: ERTWB DAC 0 SAVE WB
5528: *
5529: * GLOBAL VALUES FOR EVALI
5530: *
5531: EVLIN DAC P$LEN DUMMY PATTERN BLOCK PCODE
5532: EVLIS DAC 0 POINTER TO SUBSEQUENT NODE
5533: EVLIV DAC 0 VALUE OF PARAMETER
5534: * WORK AREA FOR EXPAN
5535: *
5536: EXPSV DAC 0 SAVE OP DOPE VECTOR POINTER
5537: *
5538: * FLAG FOR SUPPRESSION OF EXECUTION STATS
5539: *
5540: EXSTS DAC 0 SUPPRESS EXEC STATS IF SET
5541: *
5542: * GLOBAL VALUES FOR EXFAL AND RETURN
5543: *
5544: FLPRT DAC 0 LOCATION OF FAIL OFFSET FOR RETURN
5545: FLPTR DAC 0 LOCATION OF FAILURE OFFSET ON STACK
5546: *
5547: * WORK AREAS FOR GBCOL PROCEDURE
5548: *
5549: GBCFL DAC 0 GARBAGE COLLECTOR ACTIVE FLAG
5550: GBCLM DAC 0 POINTER TO LAST MOVE BLOCK (PASS 3)
5551: GBCNM DAC 0 DUMMY FIRST MOVE BLOCK
5552: GBCNS DAC 0 REST OF DUMMY BLOCK (FOLLOWS GBCNM)
5553: GBSVA DAC 0 SAVE WA
5554: GBSVB DAC 0 SAVE WB
5555: GBSVC DAC 0 SAVE WC
5556: *
5557: * GLOBAL LOCATION TO COUNT GARBAGE COLLECTIONS (GBCOL)
5558: *
5559: GBCNT DAC 0 COUNT OF GARBAGE COLLECTIONS
5560: *
5561: * WORK AREAS FOR GTNVR PROCEDURE
5562: *
5563: GNVHE DAC 0 PTR TO END OF HASH CHAIN
5564: GNVNW DAC 0 NUMBER OF WORDS IN STRING NAME
5565: GNVSA DAC 0 SAVE WA
5566: GNVSB DAC 0 SAVE WB
5567: GNVSP DAC 0 POINTER INTO VSRCH TABLE
5568: GNVST DAC 0 POINTER TO CHARS OF STRING
5569: *
5570: * GLOBAL VALUE FOR GTCOD AND GTEXP
5571: *
5572: GTCEF DAC 0 SAVE FAIL PTR IN CASE OF ERROR
5573: *
5574: * WORK AREAS FOR GTINT
5575: *
5576: GTINA DAC 0 SAVE WA
5577: GTINB DAC 0 SAVE WB
5578: EJC
5579: *
5580: * WORK AREAS FOR GTNUM PROCEDURE
5581: *
5582: GTNNF DAC 0 ZERO/NONZERO FOR RESULT +/-
5583: GTNSI DIC +0 GENERAL INTEGER SAVE
5584: GTNDF DAC 0 0/1 FOR DEC POINT SO FAR NO/YES
5585: GTNES DAC 0 ZERO/NONZERO EXPONENT +/-
5586: GTNEX DIC +0 REAL EXPONENT
5587: GTNSC DAC 0 SCALE (PLACES AFTER POINT)
5588: GTNSR DRC +0.0 GENERAL REAL SAVE
5589: GTNRD DAC 0 FLAG FOR OK REAL NUMBER
5590: *
5591: * WORK AREAS FOR GTPAT PROCEDURE
5592: *
5593: GTPSB DAC 0 SAVE WB
5594: *
5595: * WORK AREAS FOR GTSTG PROCEDURE
5596: *
5597: GTSSF DAC 0 0/1 FOR RESULT +/-
5598: GTSVC DAC 0 SAVE WC
5599: GTSVB DAC 0 SAVE WB
5600: GTSWK DAC 0 PTR TO WORK AREA FOR GTSTG
5601: GTSES DAC 0 CHAR + OR - FOR EXPONENT +/-
5602: GTSRS DRC +0.0 GENERAL REAL SAVE
5603: *
5604: * GLOBAL LOCATIONS (CONSTANTS) FOR GTSTG PROCEDURE
5605: *
5606: GTSRN DRC +0.0 ROUNDING FACTOR 0.5*10**-CFP$S
5607: GTSSC DRC +0.0 SCALING VALUE 10**CFP$S
5608: *
5609: * WORK AREAS FOR GTVAR PROCEDURE
5610: *
5611: GTVRC DAC 0 SAVE WC
5612: *
5613: * FLAG FOR HEADER PRINTING
5614: *
5615: HEADP DAC 0 HEADER PRINTED FLAG
5616: *
5617: * GLOBAL VALUES FOR VARIABLE HASH TABLE
5618: *
5619: HSHNB DIC +0 NUMBER OF HASH BUCKETS
5620: HSHTB DAC 0 POINTER TO START OF VRBLK HASH TABL
5621: HSHTE DAC 0 POINTER PAST END OF VRBLK HASH TABL
5622: *
5623: * WORK AREA FOR INIT
5624: *
5625: INISS DAC 0 SAVE SUBROUTINE STACK PTR
5626: INITR DAC 0 SAVE TERMINAL FLAG
5627: *
5628: * SAVE AREA FOR INSBF
5629: *
5630: INSAB DAC 0 ENTRY WA + ENTRY WB
5631: INSSA DAC 0 SAVE ENTRY WA
5632: INSSB DAC 0 SAVE ENTRY WB
5633: INSSC DAC 0 SAVE ENTRY WC
5634: *
5635: * WORK AREAS FOR IOPUT
5636: *
5637: IOPTT DAC 0 TYPE OF ASSOCIATION
5638: EJC
5639: *
5640: * GLOBAL VALUES FOR KEYWORD VALUES WHICH ARE STORED AS ONE
5641: * WORD INTEGERS. THESE VALUES MUST BE ASSEMBLED IN THE
5642: * FOLLOWING ORDER (AS DICTATED BY K$XXX DEFINITION VALUES).
5643: *
5644: KVABE DAC 0 ABEND
5645: KVANC DAC 0 ANCHOR
5646: KVCAS DAC 0 CASE
5647: KVCOD DAC 0 CODE
5648: KVDMP DAC 0 DUMP
5649: KVERL DAC 0 ERRLIMIT
5650: KVERT DAC 0 ERRTYPE
5651: KVFTR DAC 0 FTRACE
5652: KVINP DAC 1 INPUT
5653: KVMXL DAC 5000 MAXLENGTH
5654: KVOUP DAC 1 OUTPUT
5655: KVPFL DAC 0 PROFILE
5656: KVTRA DAC 0 TRACE
5657: KVTRM DAC 0 TRIM
5658: KVFNC DAC 0 FNCLEVEL
5659: KVLST DAC 0 LASTNO
5660: KVSTN DAC 0 STNO
5661: *
5662: * GLOBAL VALUES FOR OTHER KEYWORDS
5663: *
5664: KVALP DAC 0 ALPHABET
5665: KVRTN DAC NULLS RTNTYPE (SCBLK POINTER)
5666: KVSTL DIC +50000 STLIMIT
5667: KVSTC DIC +50000 STCOUNT (COUNTS DOWN FROM STLIMIT)
5668: *
5669: * WORK AREAS FOR LOAD FUNCTION
5670: *
5671: LODFN DAC 0 POINTER TO VRBLK FOR FUNC NAME
5672: LODNA DAC 0 COUNT NUMBER OF ARGUMENTS
5673: *
5674: * GLOBAL VALUES FOR LISTR PROCEDURE
5675: *
5676: LSTLC DAC 0 COUNT LINES ON SOURCE LIST PAGE
5677: LSTNP DAC 0 MAX NUMBER OF LINES ON PAGE
5678: LSTPF DAC 1 SET NONZERO IF CURRENT IMAGE LISTED
5679: LSTPG DAC 0 CURRENT SOURCE LIST PAGE NUMBER
5680: LSTPO DAC 0 OFFSET TO PAGE NNN MESSAGE
5681: LSTSN DAC 0 REMEMBER LAST STMNUM LISTED
5682: *
5683: * MAXIMUM SIZE OF SPITBOL OBJECTS
5684: *
5685: MXLEN DAC 0 INITIALISED BY SYSMX CALL
5686: *
5687: * EXECUTION CONTROL VARIABLE
5688: *
5689: NOXEQ DAC 0 SET NON-ZERO TO INHIBIT EXECUTION
5690: *
5691: * PROFILER GLOBAL VALUES AND WORK LOCATIONS
5692: *
5693: PFDMP DAC 0 SET NON-0 IF &PROFILE SET NON-0
5694: PFFNC DAC 0 SET NON-0 IF FUNCT JUST ENTERED
5695: PFSTM DIC +0 TO STORE STARTING TIME OF STMT
5696: PFETM DIC +0 TO STORE ENDING TIME OF STMT
5697: PFSVW DAC 0 TO SAVE A W-REG
5698: PFTBL DAC 0 GETS ADRS OF (IMAG) TABLE BASE
5699: PFNTE DAC 0 NR OF TABLE ENTRIES
5700: PFSTE DIC +0 GETS INT REP OF TABLE ENTRY SIZE
5701: *
5702: EJC
5703: *
5704: * GLOBAL VALUES USED IN PATTERN MATCH ROUTINES
5705: *
5706: PMDFL DAC 0 PATTERN ASSIGNMENT FLAG
5707: PMHBS DAC 0 HISTORY STACK BASE POINTER
5708: PMSSL DAC 0 LENGTH OF SUBJECT STRING IN CHARS
5709: *
5710: * FLAGS USED FOR STANDARD FILE LISTING OPTIONS
5711: *
5712: PRICH DAC 0 PRINTER ON INTERACTIVE CHANNEL
5713: PRSTD DAC 0 TESTED BY PRTPG
5714: PRSTO DAC 0 STANDARD LISTING OPTION FLAG
5715: *
5716: * GLOBAL VALUE FOR PRTNM PROCEDURE
5717: *
5718: PRNMV DAC 0 VRBLK PTR FROM LAST NAME SEARCH
5719: *
5720: * WORK AREAS FOR PRTNM PROCEDURE
5721: *
5722: PRNSI DIC +0 SCRATCH INTEGER LOC
5723: *
5724: * WORK AREAS FOR PRTSN PROCEDURE
5725: *
5726: PRSNA DAC 0 SAVE WA
5727: *
5728: * GLOBAL VALUES FOR PRINT PROCEDURES
5729: *
5730: PRBUF DAC 0 PTR TO PRINT BFR IN STATIC
5731: PRECL DAC 0 EXTENDED/COMPACT LISTING FLAG
5732: PRLEN DAC 0 LENGTH OF PRINT BUFFER IN CHARS
5733: PRLNW DAC 0 LENGTH OF PRINT BUFFER IN WORDS
5734: PROFS DAC 0 OFFSET TO NEXT LOCATION IN PRBUF
5735: PRTEF DAC 0 ENDFILE FLAG
5736: *
5737: * WORK AREAS FOR PRTST PROCEDURE
5738: *
5739: PRSVA DAC 0 SAVE WA
5740: PRSVB DAC 0 SAVE WB
5741: PRSVC DAC 0 SAVE CHAR COUNTER
5742: *
5743: * WORK AREA FOR PRTNL
5744: *
5745: PRTSA DAC 0 SAVE WA
5746: PRTSB DAC 0 SAVE WB
5747: *
5748: * WORK AREA FOR PRTVL
5749: *
5750: PRVSI DAC 0 SAVE IDVAL
5751: *
5752: * WORK AREAS FOR PATTERN MATCH ROUTINES
5753: *
5754: PSAVE DAC 0 TEMPORARY SAVE FOR CURRENT NODE PTR
5755: PSAVC DAC 0 SAVE CURSOR IN P$SPN, P$STR
5756: EJC
5757: *
5758: * AMOUNT OF MEMORY RESERVED FOR END OF EXECUTION
5759: *
5760: RSMEM DAC 0 RESERVE MEMORY
5761: *
5762: * WORK AREAS FOR RETRN ROUTINE
5763: *
5764: RTNBP DAC 0 TO SAVE A BLOCK POINTER
5765: RTNFV DAC 0 NEW FUNCTION VALUE (RESULT)
5766: RTNSV DAC 0 OLD FUNCTION VALUE (SAVED VALUE)
5767: *
5768: * RELOCATABLE GLOBAL VALUES
5769: *
5770: * ALL THE POINTERS IN THIS SECTION CAN POINT TO BLOCKS IN
5771: * THE DYNAMIC STORAGE AREA AND MUST BE RELOCATED BY THE
5772: * GARBAGE COLLECTOR. THEY ARE IDENTIFIED BY R$XXX NAMES.
5773: *
5774: R$AAA DAC 0 START OF RELOCATABLE VALUES
5775: R$ARF DAC 0 ARRAY BLOCK POINTER FOR ARREF
5776: R$CCB DAC 0 PTR TO CCBLK BEING BUILT (CDWRD)
5777: R$CIM DAC 0 PTR TO CURRENT COMPILER INPUT STR
5778: R$CMP DAC 0 COPY OF R$CIM USED IN CMPIL
5779: R$CNI DAC 0 PTR TO NEXT COMPILER INPUT STRING
5780: R$CNT DAC 0 CDBLK POINTER FOR SETEXIT CONTINUE
5781: R$COD DAC 0 POINTER TO CURRENT CDBLK OR EXBLK
5782: R$CTP DAC 0 PTR TO CURRENT CTBLK FOR PATST
5783: R$ERT DAC 0 TRBLK POINTER FOR ERRTYPE TRACE
5784: R$ETX DAC NULLS POINTER TO ERRTEXT STRING
5785: R$EXS DAC 0 = SAVE XL IN EXPDM
5786: R$FCB DAC 0 FCBLK CHAIN HEAD
5787: R$FNC DAC 0 TRBLK POINTER FOR FNCLEVEL TRACE
5788: R$GTC DAC 0 KEEP CODE PTR FOR GTCOD,GTEXP
5789: R$IO1 DAC 0 FILE ARG1 FOR IOPUT
5790: R$IO2 DAC 0 FILE ARG2 FOR IOPUT
5791: R$IOF DAC 0 FCBLK PTR OR 0
5792: R$ION DAC 0 NAME BASE PTR
5793: R$IOP DAC 0 PREDECESSOR BLOCK PTR FOR IOPUT
5794: R$IOT DAC 0 TRBLK PTR FOR IOPUT
5795: R$PMB DAC 0 BUFFER PTR IN PATTERN MATCH
5796: R$PMS DAC 0 SUBJECT STRING PTR IN PATTERN MATCH
5797: R$RA2 DAC 0 REPLACE SECOND ARGUMENT LAST TIME
5798: R$RA3 DAC 0 REPLACE THIRD ARGUMENT LAST TIME
5799: R$RPT DAC 0 PTR TO CTBLK REPLACE TABLE LAST USD
5800: R$SCP DAC 0 SAVE POINTER FROM LAST SCANE CALL
5801: R$SXL DAC 0 PRESERVE XL IN SORTC
5802: R$SXR DAC 0 PRESERVE XR IN SORTA/SORTC
5803: R$STC DAC 0 TRBLK POINTER FOR STCOUNT TRACE
5804: R$STL DAC 0 SOURCE LISTING SUB-TITLE
5805: R$SXC DAC 0 CODE (CDBLK) PTR FOR SETEXIT TRAP
5806: R$TTL DAC NULLS SOURCE LISTING TITLE
5807: R$XSC DAC 0 STRING POINTER FOR XSCAN
5808: EJC
5809: *
5810: * THE REMAINING POINTERS IN THIS LIST ARE USED TO POINT
5811: * TO FUNCTION BLOCKS FOR NORMALLY UNDEFINED OPERATORS.
5812: *
5813: R$UBA DAC STNDO BINARY AT
5814: R$UBM DAC STNDO BINARY AMPERSAND
5815: R$UBN DAC STNDO BINARY NUMBER SIGN
5816: R$UBP DAC STNDO BINARY PERCENT
5817: R$UBT DAC STNDO BINARY NOT
5818: R$UUB DAC STNDO UNARY VERTICAL BAR
5819: R$UUE DAC STNDO UNARY EQUAL
5820: R$UUN DAC STNDO UNARY NUMBER SIGN
5821: R$UUP DAC STNDO UNARY PERCENT
5822: R$UUS DAC STNDO UNARY SLASH
5823: R$UUX DAC STNDO UNARY EXCLAMATION
5824: R$YYY DAC 0 LAST RELOCATABLE LOCATION
5825: *
5826: * WORK AREAS FOR SUBSTR FUNCTION (S$SUB)
5827: *
5828: SBSSV DAC 0 SAVE THIRD ARGUMENT
5829: *
5830: * GLOBAL LOCATIONS USED IN SCAN PROCEDURE
5831: *
5832: SCNBL DAC 0 SET NON-ZERO IF SCANNED PAST BLANKS
5833: SCNCC DAC 0 NON-ZERO TO SCAN CONTROL CARD NAME
5834: SCNGO DAC 0 SET NON-ZERO TO SCAN GOTO FIELD
5835: SCNIL DAC 0 LENGTH OF CURRENT INPUT IMAGE
5836: SCNPT DAC 0 POINTER TO NEXT LOCATION IN R$CIM
5837: SCNRS DAC 0 SET NON-ZERO TO SIGNAL RESCAN
5838: SCNTP DAC 0 SAVE SYNTAX TYPE FROM LAST CALL
5839: *
5840: * WORK AREAS FOR SCAN PROCEDURE
5841: *
5842: SCNSA DAC 0 SAVE WA
5843: SCNSB DAC 0 SAVE WB
5844: SCNSC DAC 0 SAVE WC
5845: SCNSE DAC 0 START OF CURRENT ELEMENT
5846: SCNOF DAC 0 SAVE OFFSET
5847: EJC
5848: *
5849: * WORK AREA USED BY SORTA, SORTC, SORTF, SORTH
5850: *
5851: SRTDF DAC 0 DATATYPE FIELD NAME
5852: SRTFD DAC 0 FOUND DFBLK ADDRESS
5853: SRTFF DAC 0 FOUND FIELD NAME
5854: SRTFO DAC 0 OFFSET TO FIELD NAME
5855: SRTNR DAC 0 NUMBER OF ROWS
5856: SRTOF DAC 0 OFFSET WITHIN ROW TO SORT KEY
5857: SRTRT DAC 0 ROOT OFFSET
5858: SRTS1 DAC 0 SAVE OFFSET 1
5859: SRTS2 DAC 0 SAVE OFFSET 2
5860: SRTSC DAC 0 SAVE WC
5861: SRTSF DAC 0 SORT ARRAY FIRST ROW OFFSET
5862: SRTSN DAC 0 SAVE N
5863: SRTSO DAC 0 OFFSET TO A(0)
5864: SRTSR DAC 0 0 , NON-ZERO FOR SORT, RSORT
5865: SRTST DAC 0 STRIDE FROM ONE ROW TO NEXT
5866: SRTWC DAC 0 DUMP WC
5867: *
5868: * GLOBAL VALUE FOR INDICATING STAGE (SEE ERROR SECTION)
5869: *
5870: STAGE DAC 0 INITIAL VALUE = INITIAL COMPILE
5871: *
5872: * GLOBAL VALUES DEFINING EXTENT OF STATIC AREA (ALOST)
5873: *
5874: STATB DAC 0 START OF STATIC AREA
5875: STATE DAC 0 END OF STATIC AREA
5876: EJC
5877: *
5878: * GLOBAL STACK POINTER
5879: *
5880: STBAS DAC 0 POINTER PAST STACK BASE
5881: *
5882: * WORK AREAS FOR STOPR ROUTINE
5883: *
5884: STPSI DIC +0 SAVE VALUE OF STCOUNT
5885: STPTI DIC +0 SAVE TIME ELAPSED
5886: *
5887: * GLOBAL VALUES FOR SETEXIT FUNCTION (S$STX)
5888: *
5889: STXOF DAC 0 FAILURE OFFSET
5890: STXVR DAC NULLS VRBLK POINTER OR NULL
5891: *
5892: * WORK AREAS FOR TFIND PROCEDURE
5893: *
5894: TFNSI DIC +0 NUMBER OF HEADERS
5895: *
5896: * GLOBAL VALUE FOR TIME KEEPING
5897: *
5898: TIMSX DIC +0 TIME AT START OF EXECUTION
5899: TIMUP DAC 0 SET WHEN TIME UP OCCURS
5900: *
5901: * WORK AREAS FOR XSCAN PROCEDURE
5902: *
5903: XSCRT DAC 0 SAVE RETURN CODE
5904: XSCWB DAC 0 SAVE REGISTER WB
5905: *
5906: * GLOBAL VALUES FOR XSCAN AND XSCNI PROCEDURES
5907: *
5908: XSOFS DAC 0 OFFSET TO CURRENT LOCATION IN R$XSC
5909: *
5910: * LABEL TO MARK END OF WORK AREA
5911: *
5912: YYYYY DAC 0
5913: TTL S P I T B O L -- INITIALIZATION
5914: *
5915: * INITIALISATION
5916: * THE FOLLOWING SECTION RECEIVES CONTROL FROM THE SYSTEM
5917: * AT THE START OF A RUN WITH THE REGISTERS SET AS FOLLOWS.
5918: *
5919: * (XS) POINTS PAST STACK BASE
5920: * (XR) POINTS TO FIRST WORD OF DATA AREA
5921: * (XL) POINTS TO LAST WORD OF DATA AREA
5922: *
5923: SEC START OF PROGRAM SECTION
5924: JSR SYSTM INITIALISE TIMER
5925: *
5926: * INITIALISE WORK AREA (ESSENTIAL FOR BATCHED RUNS)
5927: *
5928: MOV XR,WB PRESERVE XR
5929: MOV =YYYYY,WA POINT TO END OF WORK AREA
5930: SUB =AAAAA,WA GET LENGTH OF WORK AREA
5931: BTW WA CONVERT TO WORDS
5932: LCT WA,WA COUNT FOR LOOP
5933: MOV =AAAAA,XR SET UP INDEX REGISTER
5934: *
5935: * CLEAR WORK SPACE
5936: *
5937: INI01 ZER (XR)+ CLEAR A WORD
5938: BCT WA,INI01 LOOP TILL DONE
5939: MOV =STNDO,WA UNDEFINED OPERATORS POINTER
5940: MOV =R$YYY,WC POINT TO TABLE END
5941: SUB =R$UBA,WC LENGTH OF UNDEF. OPERATORS TABLE
5942: BTW WC CONVERT TO WORDS
5943: LCT WC,WC LOOP COUNTER
5944: MOV =R$UBA,XR SET UP XR
5945: *
5946: * SET CORRECT VALUE INTO UNDEFINED OPERATORS TABLE
5947: *
5948: INI02 MOV WA,(XR)+ STORE VALUE
5949: BCT WC,INI02 LOOP TILL ALL DONE
5950: MOV =NUM01,WA GET A 1
5951: MOV WA,CMPSN STATEMENT NO
5952: MOV WA,CSWFL NOFAIL
5953: MOV WA,CSWLS LIST
5954: MOV WA,KVINP INPUT
5955: MOV WA,KVOUP OUTPUT
5956: MOV WA,LSTPF NOTHING FOR LISTR YET
5957: MOV =INILN,WA INPUT IMAGE LENGTH
5958: MOV WA,CSWIN -IN72
5959: MOV =B$KVT,DMPKB DUMP
5960: MOV =TRBKV,DMPKT DUMP
5961: MOV =P$LEN,EVLIN EVAL
5962: EJC
5963: MOV =NULLS,WA GET NULLSTRING POINTER
5964: MOV WA,KVRTN RETURN
5965: MOV WA,R$ETX ERRTEXT
5966: MOV WA,R$TTL TITLE FOR LISTING
5967: MOV WA,STXVR SETEXIT
5968: STI TIMSX STORE TIME IN CORRECT PLACE
5969: LDI STLIM GET DEFAULT STLIMIT
5970: STI KVSTL STATEMENT LIMIT
5971: STI KVSTC STATEMENT COUNT
5972: MOV WB,STATB STORE START ADRS OF STATIC
5973: MOV *E$SRS,RSMEM RESERVE MEMORY
5974: MOV XS,STBAS STORE STACK BASE
5975: SSS INISS SAVE S-R STACK PTR
5976: *
5977: * NOW CONVERT FREE STORE PERCENTAGE TO A SUITABLE FACTOR
5978: * FOR EASY TESTING IN ALLOC ROUTINE.
5979: *
5980: LDI INTVH GET 100
5981: DVI ALFSP FORM 100 / ALFSP
5982: STI ALFSF STORE THE FACTOR
5983: *
5984: * INITIALIZE VALUES FOR REAL CONVERSION ROUTINE
5985: *
5986: LCT WB,=CFP$S LOAD COUNTER FOR SIGNIFICANT DIGITS
5987: LDR REAV1 LOAD 1.0
5988: *
5989: * LOOP TO COMPUTE 10**(MAX NUMBER SIGNIFICANT DIGITS)
5990: *
5991: INI03 MLR REAVT * 10.0
5992: BCT WB,INI03 LOOP TILL DONE
5993: STR GTSSC STORE 10**(MAX SIG DIGITS)
5994: LDR REAP5 LOAD 0.5
5995: DVR GTSSC COMPUTE 0.5*10**(MAX SIG DIGITS)
5996: STR GTSRN STORE AS ROUNDING BIAS
5997: ZER WC SET TO READ PARAMETERS
5998: JSR PRPAR READ THEM
5999: EJC
6000: *
6001: * NOW COMPUTE STARTING ADDRESS FOR DYNAMIC STORE AND IF
6002: * NECESSARY REQUEST MORE MEMORY.
6003: *
6004: SUB *E$SRS,XL ALLOW FOR RESERVE MEMORY
6005: MOV PRLEN,WA GET PRINT BUFFER LENGTH
6006: ADD =CFP$A,WA ADD NO. OF CHARS IN ALPHABET
6007: ADD =NSTMX,WA ADD CHARS FOR GTSTG BFR
6008: CTB WA,8 CONVERT TO BYTES, ALLOWING A MARGIN
6009: MOV STATB,XR POINT TO STATIC BASE
6010: ADD WA,XR INCREMENT FOR ABOVE BUFFERS
6011: ADD *E$HNB,XR INCREMENT FOR HASH TABLE
6012: ADD *E$STS,XR BUMP FOR INITIAL STATIC BLOCK
6013: JSR SYSMX GET MXLEN
6014: MOV WA,KVMXL PROVISIONALLY STORE AS MAXLNGTH
6015: MOV WA,MXLEN AND AS MXLEN
6016: BGT XR,WA,INI06 SKIP IF STATIC HI EXCEEDS MXLEN
6017: MOV WA,XR USE MXLEN INSTEAD
6018: ICA XR MAKE BIGGER THAN MXLEN
6019: *
6020: * HERE TO STORE VALUES WHICH MARK INITIAL DIVISION
6021: * OF DATA AREA INTO STATIC AND DYNAMIC
6022: *
6023: INI06 MOV XR,DNAMB DYNAMIC BASE ADRS
6024: MOV XR,DNAMP DYNAMIC PTR
6025: BNZ WA,INI07 SKIP IF NON-ZERO MXLEN
6026: DCA XR POINT A WORD IN FRONT
6027: MOV XR,KVMXL USE AS MAXLNGTH
6028: MOV XR,MXLEN AND AS MXLEN
6029: EJC
6030: *
6031: * LOOP HERE IF NECESSARY TILL ENOUGH MEMORY OBTAINED
6032: * SO THAT DNAME IS ABOVE DNAMB
6033: *
6034: INI07 MOV XL,DNAME STORE DYNAMIC END ADDRESS
6035: BLT DNAMB,XL,INI09 SKIP IF HIGH ENOUGH
6036: JSR SYSMM REQUEST MORE MEMORY
6037: WTB XR GET AS BAUS (SGD05)
6038: ADD XR,XL BUMP BY AMOUNT OBTAINED
6039: BNZ XR,INI07 TRY AGAIN
6040: MOV =ENDMO,XR POINT TO FAILURE MESSAGE
6041: MOV ENDML,WA MESSAGE LENGTH
6042: JSR SYSPR PRINT IT (PRTST NOT YET USABLE)
6043: PPM SHOULD NOT FAIL
6044: JSR SYSEJ PACK UP (STOPR NOT YET USABLE)
6045: *
6046: * INITIALISE PRINT BUFFER WITH BLANK WORDS
6047: *
6048: INI09 MOV PRLEN,WC NO. OF CHARS IN PRINT BFR
6049: MOV STATB,XR POINT TO STATIC AGAIN
6050: MOV XR,PRBUF PRINT BFR IS PUT AT STATIC START
6051: MOV =B$SCL,(XR)+ STORE STRING TYPE CODE
6052: MOV WC,(XR)+ AND STRING LENGTH
6053: CTW WC,0 GET NUMBER OF WORDS IN BUFFER
6054: MOV WC,PRLNW STORE FOR BUFFER CLEAR
6055: LCT WC,WC WORDS TO CLEAR
6056: *
6057: * LOOP TO CLEAR BUFFER
6058: *
6059: INI10 MOV NULLW,(XR)+ STORE BLANK
6060: BCT WC,INI10 LOOP
6061: *
6062: * INITIALIZE NUMBER OF HASH HEADERS
6063: *
6064: MOV =E$HNB,WA GET NUMBER OF HASH HEADERS
6065: MTI WA CONVERT TO INTEGER
6066: STI HSHNB STORE FOR USE BY GTNVR PROCEDURE
6067: LCT WA,WA COUNTER FOR CLEARING HASH TABLE
6068: MOV XR,HSHTB POINTER TO HASH TABLE
6069: *
6070: * LOOP TO CLEAR HASH TABLE
6071: *
6072: INI11 ZER (XR)+ BLANK A WORD
6073: BCT WA,INI11 LOOP
6074: MOV XR,HSHTE END OF HASH TABLE ADRS IS KEPT
6075: *
6076: * ALLOCATE WORK AREA FOR GTSTG CONVERSION PROCEDURE
6077: *
6078: MOV =NSTMX,WA GET MAX NUM CHARS IN OUTPUT NUMBER
6079: CTB WA,SCSI$ NO OF BYTES NEEDED
6080: MOV XR,GTSWK STORE BFR ADRS
6081: ADD WA,XR BUMP FOR WORK BFR
6082: EJC
6083: *
6084: * BUILD ALPHABET STRING FOR ALPHABET KEYWORD AND REPLACE
6085: *
6086: MOV XR,KVALP SAVE ALPHABET POINTER
6087: MOV =B$SCL,(XR) STRING BLK TYPE
6088: MOV =CFP$A,WC NO OF CHARS IN ALPHABET
6089: MOV WC,SCLEN(XR) STORE AS STRING LENGTH
6090: MOV WC,WB COPY CHAR COUNT
6091: CTB WB,SCSI$ NO. OF BYTES NEEDED
6092: ADD XR,WB CURRENT END ADDRESS FOR STATIC
6093: MOV WB,STATE STORE STATIC END ADRS
6094: LCT WC,WC LOOP COUNTER
6095: PSC XR POINT TO CHARS OF STRING
6096: ZER WB SET INITIAL CHARACTER VALUE
6097: *
6098: * LOOP TO ENTER CHARACTER CODES IN ORDER
6099: *
6100: INI12 SCH WB,(XR)+ STORE NEXT CODE
6101: ICV WB BUMP CODE VALUE
6102: BCT WC,INI12 LOOP TILL ALL STORED
6103: CSC XR COMPLETE STORE CHARACTERS
6104: *
6105: * INITIALIZE VARIABLE BLOCKS FOR INPUT AND OUTPUT
6106: *
6107: MOV =V$INP,XL POINT TO STRING /INPUT/
6108: MOV =TRTIN,WB TRBLK TYPE FOR INPUT
6109: JSR INOUT PERFORM INPUT ASSOCIATION
6110: MOV =V$OUP,XL POINT TO STRING /OUTPUT/
6111: MOV =TRTOU,WB TRBLK TYPE FOR OUTPUT
6112: JSR INOUT PERFORM OUTPUT ASSOCIATION
6113: MOV INITR,WC TERMINAL FLAG
6114: BZE WC,INI13 SKIP IF NO TERMINAL
6115: JSR PRPAR ASSOCIATE TERMINAL
6116: EJC
6117: *
6118: * CHECK FOR EXPIRY DATE
6119: *
6120: INI13 JSR SYSDC CALL DATE CHECK
6121: MOV XS,FLPTR IN CASE STACK OVERFLOWS IN COMPILER
6122: *
6123: * NOW COMPILE SOURCE INPUT CODE
6124: *
6125: JSR CMPIL CALL COMPILER
6126: MOV XR,R$COD SET PTR TO FIRST CODE BLOCK
6127: MOV =NULLS,R$TTL FORGET TITLE (REG04)
6128: MOV =NULLS,R$STL FORGET SUB-TITLE (REG04)
6129: ZER R$CIM FORGET COMPILER INPUT IMAGE
6130: ZER XL CLEAR DUD VALUE
6131: ZER WB DONT SHIFT DYNAMIC STORE UP
6132: JSR GBCOL CLEAR GARBAGE LEFT FROM COMPILE
6133: BNZ CPSTS,INIX0 SKIP IF NO LISTING OF COMP STATS
6134: JSR PRTPG EJECT PAGE
6135: *
6136: * PRINT COMPILE STATISTICS
6137: *
6138: MOV DNAMP,WA NEXT AVAILABLE LOC
6139: SUB STATB,WA MINUS START
6140: BTW WA CONVERT TO WORDS
6141: MTI WA CONVERT TO INTEGER
6142: MOV =ENCM1,XR POINT TO /MEMORY USED (WORDS)/
6143: JSR PRTMI PRINT MESSAGE
6144: MOV DNAME,WA END OF MEMORY
6145: SUB DNAMP,WA MINUS NEXT AVAILABLE LOC
6146: BTW WA CONVERT TO WORDS
6147: MTI WA CONVERT TO INTEGER
6148: MOV =ENCM2,XR POINT TO /MEMORY AVAILABLE (WORDS)/
6149: JSR PRTMI PRINT LINE
6150: MTI CMERC GET COUNT OF ERRORS AS INTEGER
6151: MOV =ENCM3,XR POINT TO /COMPILE ERRORS/
6152: JSR PRTMI PRINT IT
6153: MTI GBCNT GARBAGE COLLECTION COUNT
6154: SBI INTV1 ADJUST FOR UNAVOIDABLE COLLECT
6155: MOV =STPM5,XR POINT TO /STORAGE REGENERATIONS/
6156: JSR PRTMI PRINT GBCOL COUNT
6157: JSR SYSTM GET TIME
6158: SBI TIMSX GET COMPILATION TIME
6159: MOV =ENCM4,XR POINT TO COMPILATION TIME (MSEC)/
6160: JSR PRTMI PRINT MESSAGE
6161: ADD =NUM05,LSTLC BUMP LINE COUNT
6162: BZE HEADP,INIX0 NO EJECT IF NOTHING PRINTED (SDG11)
6163: JSR PRTPG EJECT PRINTER
6164: EJC
6165: *
6166: * PREPARE NOW TO START EXECUTION
6167: *
6168: * SET DEFAULT INPUT RECORD LENGTH
6169: *
6170: INIX0 BGT CSWIN,=INILN,INIX1 SKIP IF NOT DEFAULT -IN72 USED
6171: MOV =INILS,CSWIN ELSE USE DEFAULT RECORD LENGTH
6172: *
6173: * RESET TIMER
6174: *
6175: INIX1 JSR SYSTM GET TIME AGAIN
6176: STI TIMSX STORE FOR END RUN PROCESSING
6177: ADD CSWEX,NOXEQ ADD -NOEXECUTE FLAG
6178: BNZ NOXEQ,INIX2 JUMP IF EXECUTION SUPPRESSED
6179: ZER GBCNT INITIALISE COLLECT COUNT
6180: JSR SYSBX CALL BEFORE STARTING EXECUTION
6181: *
6182: * MERGE WHEN LISTING FILE SET FOR EXECUTION
6183: *
6184: INIY0 MNZ HEADP MARK HEADERS OUT REGARDLESS
6185: ZER -(XS) SET FAILURE LOCATION ON STACK
6186: MOV XS,FLPTR SAVE PTR TO FAILURE OFFSET WORD
6187: MOV R$COD,XR LOAD PTR TO ENTRY CODE BLOCK
6188: MOV =STGXT,STAGE SET STAGE FOR EXECUTE TIME
6189: MOV CMPSN,PFNTE COPY STMTS COMPILED COUNT IN CASE
6190: JSR SYSTM TIME YET AGAIN
6191: STI PFSTM
6192: BRI (XR) START XEQ WITH FIRST STATEMENT
6193: *
6194: * HERE IF EXECUTION IS SUPPRESSED
6195: *
6196: INIX2 JSR PRTNL PRINT A BLANK LINE
6197: MOV =ENCM5,XR POINT TO /EXECUTION SUPPRESSED/
6198: JSR PRTST PRINT STRING
6199: JSR PRTNL OUTPUT LINE
6200: ZER WA SET ABEND VALUE TO ZERO
6201: MOV =NINI9,WB SET SPECIAL CODE VALUE
6202: JSR SYSEJ END OF JOB, EXIT TO SYSTEM
6203: TTL S P I T B O L -- SNOBOL4 OPERATOR ROUTINES
6204: *
6205: * THIS SECTION INCLUDES ALL ROUTINES WHICH CAN BE ACCESSED
6206: * DIRECTLY FROM THE GENERATED CODE EXCEPT SYSTEM FUNCTIONS.
6207: *
6208: * ALL ROUTINES IN THIS SECTION START WITH A LABEL OF THE
6209: * FORM O$XXX WHERE XXX IS THREE LETTERS. THE GENERATED CODE
6210: * CONTAINS A POINTER TO THE APPROPRIATE ENTRY LABEL.
6211: *
6212: * SINCE THE GENERAL FORM OF THE GENERATED CODE CONSISTS OF
6213: * POINTERS TO BLOCKS WHOSE FIRST WORD IS THE ADDRESS OF THE
6214: * ACTUAL ENTRY POINT LABEL (O$XXX).
6215: *
6216: * THESE ROUTINES ARE IN ALPHABETICAL ORDER BY THEIR
6217: * ENTRY LABEL NAMES (I.E. BY THE XXX OF THE O$XXX NAME)
6218: *
6219: * THESE ROUTINES RECEIVE CONTROL AS FOLLOWS
6220: *
6221: * (CP) POINTER TO NEXT CODE WORD
6222: * (XS) CURRENT STACK POINTER
6223: EJC
6224: *
6225: * BINARY PLUS (ADDITION)
6226: *
6227: O$ADD ENT ENTRY POINT
6228: JSR ARITH FETCH ARITHMETIC OPERANDS
6229: ERR 001,ADDITION LEFT OPERAND IS NOT NUMERIC
6230: ERR 002,ADDITION RIGHT OPERAND IS NOT NUMERIC
6231: PPM OADD1 JUMP IF REAL OPERANDS
6232: *
6233: * HERE TO ADD TWO INTEGERS
6234: *
6235: ADI ICVAL(XL) ADD RIGHT OPERAND TO LEFT
6236: INO EXINT RETURN INTEGER IF NO OVERFLOW
6237: ERB 003,ADDITION CAUSED INTEGER OVERFLOW
6238: *
6239: * HERE TO ADD TWO REALS
6240: *
6241: OADD1 ADR RCVAL(XL) ADD RIGHT OPERAND TO LEFT
6242: RNO EXREA RETURN REAL IF NO OVERFLOW
6243: ERB 261,ADDITION CAUSED REAL OVERFLOW
6244: EJC
6245: *
6246: * UNARY PLUS (AFFIRMATION)
6247: *
6248: O$AFF ENT ENTRY POINT
6249: MOV (XS)+,XR LOAD OPERAND
6250: JSR GTNUM CONVERT TO NUMERIC
6251: ERR 004,AFFIRMATION OPERAND IS NOT NUMERIC
6252: BRN EXIXR RETURN IF CONVERTED TO NUMERIC
6253: EJC
6254: *
6255: * BINARY BAR (ALTERNATION)
6256: *
6257: O$ALT ENT ENTRY POINT
6258: MOV (XS)+,XR LOAD RIGHT OPERAND
6259: JSR GTPAT CONVERT TO PATTERN
6260: ERR 005,ALTERNATION RIGHT OPERAND IS NOT PATTERN
6261: *
6262: * MERGE HERE FROM SPECIAL (LEFT ALTERNATION) CASE
6263: *
6264: OALT1 MOV =P$ALT,WB SET PCODE FOR ALTERNATIVE NODE
6265: JSR PBILD BUILD ALTERNATIVE NODE
6266: MOV XR,XL SAVE ADDRESS OF ALTERNATIVE NODE
6267: MOV (XS)+,XR LOAD LEFT OPERAND
6268: JSR GTPAT CONVERT TO PATTERN
6269: ERR 006,ALTERNATION LEFT OPERAND IS NOT PATTERN
6270: BEQ XR,=P$ALT,OALT2 JUMP IF LEFT ARG IS ALTERNATION
6271: MOV XR,PTHEN(XL) SET LEFT OPERAND AS SUCCESSOR
6272: MOV XL,XR MOVE RESULT TO PROPER REGISTER
6273: BRN EXIXR JUMP FOR NEXT CODE WORD
6274: *
6275: * COME HERE IF LEFT ARGUMENT IS ITSELF AN ALTERNATION
6276: *
6277: * THE RESULT IS MORE EFFICIENT IF WE MAKE THE REPLACEMENT
6278: *
6279: * (A / B) / C = A / (B / C)
6280: *
6281: OALT2 MOV PARM1(XR),PTHEN(XL) BUILD THE (B / C) NODE
6282: MOV PTHEN(XR),-(XS) SET A AS NEW LEFT ARG
6283: MOV XL,XR SET (B / C) AS NEW RIGHT ARG
6284: BRN OALT1 MERGE BACK TO BUILD A / (B / C)
6285: EJC
6286: *
6287: * ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY NAME)
6288: *
6289: O$AMN ENT ENTRY POINT
6290: LCW XR LOAD NUMBER OF SUBSCRIPTS
6291: MOV XR,WB SET FLAG FOR BY NAME
6292: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE
6293: EJC
6294: *
6295: * ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY VALUE)
6296: *
6297: O$AMV ENT ENTRY POINT
6298: LCW XR LOAD NUMBER OF SUBSCRIPTS
6299: ZER WB SET FLAG FOR BY VALUE
6300: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE
6301: EJC
6302: *
6303: * ARRAY REFERENCE (ONE SUBSCRIPT, BY NAME)
6304: *
6305: O$AON ENT ENTRY POINT
6306: MOV (XS),XR LOAD SUBSCRIPT VALUE
6307: MOV 1(XS),XL LOAD ARRAY VALUE
6308: MOV (XL),WA LOAD FIRST WORD OF ARRAY OPERAND
6309: BEQ WA,=B$VCT,OAON2 JUMP IF VECTOR REFERENCE
6310: BEQ WA,=B$TBT,OAON3 JUMP IF TABLE REFERENCE
6311: *
6312: * HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE
6313: *
6314: OAON1 MOV =NUM01,XR SET NUMBER OF SUBSCRIPTS TO ONE
6315: MOV XR,WB SET FLAG FOR BY NAME
6316: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE
6317: *
6318: * HERE IF WE HAVE A VECTOR REFERENCE
6319: *
6320: OAON2 BNE (XR),=B$ICL,OAON1 USE LONG ROUTINE IF NOT INTEGER
6321: LDI ICVAL(XR) LOAD INTEGER SUBSCRIPT VALUE
6322: MFI WA,EXFAL COPY AS ADDRESS INT, FAIL IF OVFLO
6323: BZE WA,EXFAL FAIL IF ZERO
6324: ADD =VCVLB,WA COMPUTE OFFSET IN WORDS
6325: WTB WA CONVERT TO BYTES
6326: MOV WA,(XS) COMPLETE NAME ON STACK
6327: BLT WA,VCLEN(XL),EXITS EXIT IF SUBSCRIPT NOT TOO LARGE
6328: BRN EXFAL ELSE FAIL
6329: *
6330: * HERE FOR TABLE REFERENCE
6331: *
6332: OAON3 MNZ WB SET FLAG FOR NAME REFERENCE
6333: JSR TFIND LOCATE/CREATE TABLE ELEMENT
6334: PPM EXFAL FAIL IF ACCESS FAILS
6335: MOV XL,1(XS) STORE NAME BASE ON STACK
6336: MOV WA,(XS) STORE NAME OFFSET ON STACK
6337: BRN EXITS EXIT WITH RESULT ON STACK
6338: EJC
6339: *
6340: * ARRAY REFERENCE (ONE SUBSCRIPT, BY VALUE)
6341: *
6342: O$AOV ENT ENTRY POINT
6343: MOV (XS)+,XR LOAD SUBSCRIPT VALUE
6344: MOV (XS)+,XL LOAD ARRAY VALUE
6345: MOV (XL),WA LOAD FIRST WORD OF ARRAY OPERAND
6346: BEQ WA,=B$VCT,OAOV2 JUMP IF VECTOR REFERENCE
6347: BEQ WA,=B$TBT,OAOV3 JUMP IF TABLE REFERENCE
6348: *
6349: * HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE
6350: *
6351: OAOV1 MOV XL,-(XS) RESTACK ARRAY VALUE
6352: MOV XR,-(XS) RESTACK SUBSCRIPT
6353: MOV =NUM01,XR SET NUMBER OF SUBSCRIPTS TO ONE
6354: ZER WB SET FLAG FOR VALUE CALL
6355: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE
6356: *
6357: * HERE IF WE HAVE A VECTOR REFERENCE
6358: *
6359: OAOV2 BNE (XR),=B$ICL,OAOV1 USE LONG ROUTINE IF NOT INTEGER
6360: LDI ICVAL(XR) LOAD INTEGER SUBSCRIPT VALUE
6361: MFI WA,EXFAL MOVE AS ONE WORD INT, FAIL IF OVFLO
6362: BZE WA,EXFAL FAIL IF ZERO
6363: ADD =VCVLB,WA COMPUTE OFFSET IN WORDS
6364: WTB WA CONVERT TO BYTES
6365: BGE WA,VCLEN(XL),EXFAL FAIL IF SUBSCRIPT TOO LARGE
6366: JSR ACESS ACCESS VALUE
6367: PPM EXFAL FAIL IF ACCESS FAILS
6368: BRN EXIXR ELSE RETURN VALUE TO CALLER
6369: *
6370: * HERE FOR TABLE REFERENCE BY VALUE
6371: *
6372: OAOV3 ZER WB SET FLAG FOR VALUE REFERENCE
6373: JSR TFIND CALL TABLE SEARCH ROUTINE
6374: PPM EXFAL FAIL IF ACCESS FAILS
6375: BRN EXIXR EXIT WITH RESULT IN XR
6376: EJC
6377: *
6378: * ASSIGNMENT
6379: *
6380: O$ASS ENT ENTRY POINT
6381: *
6382: * O$RPL (PATTERN REPLACEMENT) MERGES HERE
6383: *
6384: OASS0 MOV (XS)+,WB LOAD VALUE TO BE ASSIGNED
6385: MOV (XS)+,WA LOAD NAME OFFSET
6386: MOV (XS),XL LOAD NAME BASE
6387: MOV WB,(XS) STORE ASSIGNED VALUE AS RESULT
6388: JSR ASIGN PERFORM ASSIGNMENT
6389: PPM EXFAL FAIL IF ASSIGNMENT FAILS
6390: BRN EXITS EXIT WITH RESULT ON STACK
6391: EJC
6392: *
6393: * COMPILATION ERROR
6394: *
6395: O$CER ENT ENTRY POINT
6396: ERB 007,COMPILATION ERROR ENCOUNTERED DURING EXECUTION
6397: EJC
6398: *
6399: * UNARY AT (CURSOR ASSIGNMENT)
6400: *
6401: O$CAS ENT ENTRY POINT
6402: MOV (XS)+,WC LOAD NAME OFFSET (PARM2)
6403: MOV (XS)+,XR LOAD NAME BASE (PARM1)
6404: MOV =P$CAS,WB SET PCODE FOR CURSOR ASSIGNMENT
6405: JSR PBILD BUILD NODE
6406: BRN EXIXR JUMP FOR NEXT CODE WORD
6407: EJC
6408: *
6409: * CONCATENATION
6410: *
6411: O$CNC ENT ENTRY POINT
6412: MOV (XS),XR LOAD RIGHT ARGUMENT
6413: BEQ XR,=NULLS,OCNC3 JUMP IF RIGHT ARG IS NULL
6414: MOV 1(XS),XL LOAD LEFT ARGUMENT
6415: BEQ XL,=NULLS,OCNC4 JUMP IF LEFT ARGUMENT IS NULL
6416: MOV =B$SCL,WA GET CONSTANT TO TEST FOR STRING
6417: BNE WA,(XL),OCNC2 JUMP IF LEFT ARG NOT A STRING
6418: BNE WA,(XR),OCNC2 JUMP IF RIGHT ARG NOT A STRING
6419: *
6420: * MERGE HERE TO CONCATENATE TWO STRINGS
6421: *
6422: OCNC1 MOV SCLEN(XL),WA LOAD LEFT ARGUMENT LENGTH
6423: ADD SCLEN(XR),WA COMPUTE RESULT LENGTH
6424: JSR ALOCS ALLOCATE SCBLK FOR RESULT
6425: MOV XR,1(XS) STORE RESULT PTR OVER LEFT ARGUMENT
6426: PSC XR PREPARE TO STORE CHARS OF RESULT
6427: MOV SCLEN(XL),WA GET NUMBER OF CHARS IN LEFT ARG
6428: PLC XL PREPARE TO LOAD LEFT ARG CHARS
6429: MVC MOVE CHARACTERS OF LEFT ARGUMENT
6430: MOV (XS)+,XL LOAD RIGHT ARG POINTER, POP STACK
6431: MOV SCLEN(XL),WA LOAD NUMBER OF CHARS IN RIGHT ARG
6432: PLC XL PREPARE TO LOAD RIGHT ARG CHARS
6433: MVC MOVE CHARACTERS OF RIGHT ARGUMENT
6434: BRN EXITS EXIT WITH RESULT ON STACK
6435: *
6436: * COME HERE IF ARGUMENTS ARE NOT BOTH STRINGS
6437: *
6438: OCNC2 JSR GTSTG CONVERT RIGHT ARG TO STRING
6439: PPM OCNC5 JUMP IF RIGHT ARG IS NOT STRING
6440: MOV XR,XL SAVE RIGHT ARG PTR
6441: JSR GTSTG CONVERT LEFT ARG TO STRING
6442: PPM OCNC6 JUMP IF LEFT ARG IS NOT A STRING
6443: MOV XR,-(XS) STACK LEFT ARGUMENT
6444: MOV XL,-(XS) STACK RIGHT ARGUMENT
6445: MOV XR,XL MOVE LEFT ARG TO PROPER REG
6446: MOV (XS),XR MOVE RIGHT ARG TO PROPER REG
6447: BRN OCNC1 MERGE BACK TO CONCATENATE STRINGS
6448: EJC
6449: *
6450: * CONCATENATION (CONTINUED)
6451: *
6452: * COME HERE FOR NULL RIGHT ARGUMENT
6453: *
6454: OCNC3 ICA XS REMOVE RIGHT ARG FROM STACK
6455: BRN EXITS RETURN WITH LEFT ARGUMENT ON STACK
6456: *
6457: * HERE FOR NULL LEFT ARGUMENT
6458: *
6459: OCNC4 ICA XS UNSTACK ONE ARGUMENT
6460: MOV XR,(XS) STORE RIGHT ARGUMENT
6461: BRN EXITS EXIT WITH RESULT ON STACK
6462: *
6463: * HERE IF RIGHT ARGUMENT IS NOT A STRING
6464: *
6465: OCNC5 MOV XR,XL MOVE RIGHT ARGUMENT PTR
6466: MOV (XS)+,XR LOAD LEFT ARG POINTER
6467: *
6468: * MERGE HERE WHEN LEFT ARGUMENT IS NOT A STRING
6469: *
6470: OCNC6 JSR GTPAT CONVERT LEFT ARG TO PATTERN
6471: ERR 008,CONCATENATION LEFT OPND IS NOT STRING OR PATTERN
6472: MOV XR,-(XS) SAVE RESULT ON STACK
6473: MOV XL,XR POINT TO RIGHT OPERAND
6474: JSR GTPAT CONVERT TO PATTERN
6475: ERR 009,CONCATENATION RIGHT OPD IS NOT STRING OR PATTERN
6476: MOV XR,XL MOVE FOR PCONC
6477: MOV (XS)+,XR RELOAD LEFT OPERAND PTR
6478: JSR PCONC CONCATENATE PATTERNS
6479: BRN EXIXR EXIT WITH RESULT IN XR
6480: EJC
6481: *
6482: * COMPLEMENTATION
6483: *
6484: O$COM ENT ENTRY POINT
6485: MOV (XS)+,XR LOAD OPERAND
6486: MOV (XR),WA LOAD TYPE WORD
6487: *
6488: * MERGE BACK HERE AFTER CONVERSION
6489: *
6490: OCOM1 BEQ WA,=B$ICL,OCOM2 JUMP IF INTEGER
6491: BEQ WA,=B$RCL,OCOM3 JUMP IF REAL
6492: JSR GTNUM ELSE CONVERT TO NUMERIC
6493: ERR 010,COMPLEMENTATION OPERAND IS NOT NUMERIC
6494: BRN OCOM1 BACK TO CHECK CASES
6495: *
6496: * HERE TO COMPLEMENT INTEGER
6497: *
6498: OCOM2 LDI ICVAL(XR) LOAD INTEGER VALUE
6499: NGI NEGATE
6500: INO EXINT RETURN INTEGER IF NO OVERFLOW
6501: ERB 011,COMPLEMENTATION CAUSED INTEGER OVERFLOW
6502: *
6503: * HERE TO COMPLEMENT REAL
6504: *
6505: OCOM3 LDR RCVAL(XR) LOAD REAL VALUE
6506: NGR NEGATE
6507: BRN EXREA RETURN REAL RESULT
6508: EJC
6509: *
6510: * BINARY SLASH (DIVISION)
6511: *
6512: O$DVD ENT ENTRY POINT
6513: JSR ARITH FETCH ARITHMETIC OPERANDS
6514: ERR 012,DIVISION LEFT OPERAND IS NOT NUMERIC
6515: ERR 013,DIVISION RIGHT OPERAND IS NOT NUMERIC
6516: PPM ODVD2 JUMP IF REAL OPERANDS
6517: *
6518: * HERE TO DIVIDE TWO INTEGERS
6519: *
6520: DVI ICVAL(XL) DIVIDE LEFT OPERAND BY RIGHT
6521: INO EXINT RESULT OK IF NO OVERFLOW
6522: ERB 014,DIVISION CAUSED INTEGER OVERFLOW
6523: *
6524: * HERE TO DIVIDE TWO REALS
6525: *
6526: ODVD2 DVR RCVAL(XL) DIVIDE LEFT OPERAND BY RIGHT
6527: RNO EXREA RETURN REAL IF NO OVERFLOW
6528: ERB 262,DIVISION CAUSED REAL OVERFLOW
6529: EJC
6530: *
6531: * EXPONENTIATION
6532: *
6533: O$EXP ENT ENTRY POINT
6534: MOV (XS)+,XR LOAD EXPONENT
6535: JSR GTNUM CONVERT TO NUMBER
6536: ERR 015,EXPONENTIATION RIGHT OPERAND IS NOT NUMERIC
6537: BNE WA,=B$ICL,OEXP7 JUMP IF REAL
6538: MOV XR,XL MOVE EXPONENT
6539: MOV (XS)+,XR LOAD BASE
6540: JSR GTNUM CONVERT TO NUMERIC
6541: ERR 016,EXPONENTIATION LEFT OPERAND IS NOT NUMERIC
6542: LDI ICVAL(XL) LOAD EXPONENT
6543: ILT OEXP8 ERROR IF NEGATIVE EXPONENT
6544: BEQ WA,=B$RCL,OEXP3 JUMP IF BASE IS REAL
6545: *
6546: * HERE TO EXPONENTIATE AN INTEGER
6547: *
6548: MFI WA,OEXP2 CONVERT EXPONENT TO 1 WORD INTEGER
6549: LCT WA,WA SET LOOP COUNTER
6550: LDI INTV1 LOAD INITIAL VALUE OF 1
6551: BNZ WA,OEXP1 JUMP IF NON-ZERO EXPONENT
6552: INE EXINT GIVE ZERO AS RESULT FOR NONZERO**0
6553: BRN OEXP4 ELSE ERROR OF 0**0
6554: *
6555: * LOOP TO PERFORM EXPONENTIATION
6556: *
6557: OEXP1 MLI ICVAL(XR) MULTIPLY BY BASE
6558: IOV OEXP2 JUMP IF OVERFLOW
6559: BCT WA,OEXP1 LOOP BACK TILL COMPUTATION COMPLETE
6560: BRN EXINT THEN RETURN INTEGER RESULT
6561: *
6562: * HERE IF INTEGER OVERFLOW
6563: *
6564: OEXP2 ERB 017,EXPONENTIATION CAUSED INTEGER OVERFLOW
6565: EJC
6566: *
6567: * EXPONENTIATION (CONTINUED)
6568: *
6569: * HERE TO EXPONENTIATE A REAL
6570: *
6571: OEXP3 MFI WA,OEXP6 CONVERT EXPONENT TO ONE WORD
6572: LCT WA,WA SET LOOP COUNTER
6573: LDR REAV1 LOAD 1.0 AS INITIAL VALUE
6574: BNZ WA,OEXP5 JUMP IF NON-ZERO EXPONENT
6575: RNE EXREA RETURN 1.0 IF NONZERO**ZERO
6576: *
6577: * HERE FOR ERROR OF 0**0 OR 0.0**0
6578: *
6579: OEXP4 ERB 018,EXPONENTIATION RESULT IS UNDEFINED
6580: *
6581: * LOOP TO PERFORM EXPONENTIATION
6582: *
6583: OEXP5 MLR RCVAL(XR) MULTIPLY BY BASE
6584: ROV OEXP6 JUMP IF OVERFLOW
6585: BCT WA,OEXP5 LOOP TILL COMPUTATION COMPLETE
6586: BRN EXREA THEN RETURN REAL RESULT
6587: *
6588: * HERE IF REAL OVERFLOW
6589: *
6590: OEXP6 ERB 266,EXPONENTIATION CAUSED REAL OVERFLOW
6591: *
6592: * HERE IF REAL EXPONENT
6593: *
6594: OEXP7 ERB 267,EXPONENTIATION RIGHT OPERAND IS REAL NOT INTEGER
6595: *
6596: * HERE FOR NEGATIVE EXPONENT
6597: *
6598: OEXP8 ERB 019,EXPONENTIATION RIGHT OPERAND IS NEGATIVE
6599: EJC
6600: *
6601: * FAILURE IN EXPRESSION EVALUATION
6602: *
6603: * THIS ENTRY POINT IS USED IF THE EVALUATION OF AN
6604: * EXPRESSION, INITIATED BY THE EVALX PROCEDURE, FAILS.
6605: * CONTROL IS RETURNED TO AN APPROPRIATE POINT IN EVALX.
6606: *
6607: O$FEX ENT ENTRY POINT
6608: BRN EVLX6 JUMP TO FAILURE LOC IN EVALX
6609: EJC
6610: *
6611: * FAILURE DURING EVALUATION OF A COMPLEX OR DIRECT GOTO
6612: *
6613: O$FIF ENT ENTRY POINT
6614: ERB 020,GOTO EVALUATION FAILURE
6615: EJC
6616: *
6617: * FUNCTION CALL (MORE THAN ONE ARGUMENT)
6618: *
6619: O$FNC ENT ENTRY POINT
6620: LCW WA LOAD NUMBER OF ARGUMENTS
6621: LCW XR LOAD FUNCTION VRBLK POINTER
6622: MOV VRFNC(XR),XL LOAD FUNCTION POINTER
6623: BNE WA,FARGS(XL),CFUNC USE CENTRAL ROUTINE IF WRONG NUM
6624: BRI (XL) JUMP TO FUNCTION IF ARG COUNT OK
6625: EJC
6626: *
6627: * FUNCTION NAME ERROR
6628: *
6629: O$FNE ENT ENTRY POINT
6630: LCW WA GET NEXT CODE WORD
6631: BNE WA,=ORNM$,OFNE1 FAIL IF NOT EVALUATING EXPRESSION
6632: BZE 2(XS),EVLX3 OK IF EXPR. WAS WANTED BY VALUE
6633: *
6634: * HERE FOR ERROR
6635: *
6636: OFNE1 ERB 021,FUNCTION CALLED BY NAME RETURNED A VALUE
6637: EJC
6638: *
6639: * FUNCTION CALL (SINGLE ARGUMENT)
6640: *
6641: O$FNS ENT ENTRY POINT
6642: LCW XR LOAD FUNCTION VRBLK POINTER
6643: MOV =NUM01,WA SET NUMBER OF ARGUMENTS TO ONE
6644: MOV VRFNC(XR),XL LOAD FUNCTION POINTER
6645: BNE WA,FARGS(XL),CFUNC USE CENTRAL ROUTINE IF WRONG NUM
6646: BRI (XL) JUMP TO FUNCTION IF ARG COUNT OK
6647: EJC
6648: * CALL TO UNDEFINED FUNCTION
6649: *
6650: O$FUN ENT ENTRY POINT
6651: ERB 022,UNDEFINED FUNCTION CALLED
6652: EJC
6653: *
6654: * EXECUTE COMPLEX GOTO
6655: *
6656: O$GOC ENT ENTRY POINT
6657: MOV 1(XS),XR LOAD NAME BASE POINTER
6658: BHI XR,STATE,OGOC1 JUMP IF NOT NATURAL VARIABLE
6659: ADD *VRTRA,XR ELSE POINT TO VRTRA FIELD
6660: BRI (XR) AND JUMP THROUGH IT
6661: *
6662: * HERE IF GOTO OPERAND IS NOT NATURAL VARIABLE
6663: *
6664: OGOC1 ERB 023,GOTO OPERAND IS NOT A NATURAL VARIABLE
6665: EJC
6666: *
6667: * EXECUTE DIRECT GOTO
6668: *
6669: O$GOD ENT ENTRY POINT
6670: MOV (XS),XR LOAD OPERAND
6671: MOV (XR),WA LOAD FIRST WORD
6672: BEQ WA,=B$CDS,BCDS0 JUMP IF CODE BLOCK TO CODE ROUTINE
6673: BEQ WA,=B$CDC,BCDC0 JUMP IF CODE BLOCK TO CODE ROUTINE
6674: ERB 024,GOTO OPERAND IN DIRECT GOTO IS NOT CODE
6675: EJC
6676: *
6677: * SET GOTO FAILURE TRAP
6678: *
6679: * THIS ROUTINE IS EXECUTED AT THE START OF A COMPLEX OR
6680: * DIRECT FAILURE GOTO TO TRAP A SUBSEQUENT FAIL (SEE EXFAL)
6681: *
6682: O$GOF ENT ENTRY POINT
6683: MOV FLPTR,XR POINT TO FAIL OFFSET ON STACK
6684: ICA (XR) POINT FAILURE TO O$FIF WORD
6685: ICP POINT TO NEXT CODE WORD
6686: BRN EXITS EXIT TO CONTINUE
6687: EJC
6688: *
6689: * BINARY DOLLAR (IMMEDIATE ASSIGNMENT)
6690: *
6691: * THE PATTERN BUILT BY BINARY DOLLAR IS A COMPOUND PATTERN.
6692: * SEE DESCRIPTION AT START OF PATTERN MATCH SECTION FOR
6693: * DETAILS OF THE STRUCTURE WHICH IS CONSTRUCTED.
6694: *
6695: O$IMA ENT ENTRY POINT
6696: MOV =P$IMC,WB SET PCODE FOR LAST NODE
6697: MOV (XS)+,WC POP NAME OFFSET (PARM2)
6698: MOV (XS)+,XR POP NAME BASE (PARM1)
6699: JSR PBILD BUILD P$IMC NODE
6700: MOV XR,XL SAVE PTR TO NODE
6701: MOV (XS),XR LOAD LEFT ARGUMENT
6702: JSR GTPAT CONVERT TO PATTERN
6703: ERR 025,IMMEDIATE ASSIGNMENT LEFT OPERAND IS NOT PATTERN
6704: MOV XR,(XS) SAVE PTR TO LEFT OPERAND PATTERN
6705: MOV =P$IMA,WB SET PCODE FOR FIRST NODE
6706: JSR PBILD BUILD P$IMA NODE
6707: MOV (XS)+,PTHEN(XR) SET LEFT OPERAND AS P$IMA SUCCESSOR
6708: JSR PCONC CONCATENATE TO FORM FINAL PATTERN
6709: BRN EXIXR ALL DONE
6710: EJC
6711: *
6712: * INDIRECTION (BY NAME)
6713: *
6714: O$INN ENT ENTRY POINT
6715: MNZ WB SET FLAG FOR RESULT BY NAME
6716: BRN INDIR JUMP TO COMMON ROUTINE
6717: EJC
6718: *
6719: * INTERROGATION
6720: *
6721: O$INT ENT ENTRY POINT
6722: MOV =NULLS,(XS) REPLACE OPERAND WITH NULL
6723: BRN EXITS EXIT FOR NEXT CODE WORD
6724: EJC
6725: *
6726: * INDIRECTION (BY VALUE)
6727: *
6728: O$INV ENT ENTRY POINT
6729: ZER WB SET FLAG FOR BY VALUE
6730: BRN INDIR JUMP TO COMMON ROUTINE
6731: EJC
6732: *
6733: * KEYWORD REFERENCE (BY NAME)
6734: *
6735: O$KWN ENT ENTRY POINT
6736: JSR KWNAM GET KEYWORD NAME
6737: BRN EXNAM EXIT WITH RESULT NAME
6738: EJC
6739: *
6740: * KEYWORD REFERENCE (BY VALUE)
6741: *
6742: O$KWV ENT ENTRY POINT
6743: JSR KWNAM GET KEYWORD NAME
6744: MOV XR,DNAMP DELETE KVBLK
6745: JSR ACESS ACCESS VALUE
6746: PPM EXNUL DUMMY (UNUSED) FAILURE RETURN
6747: BRN EXIXR JUMP WITH VALUE IN XR
6748: EJC
6749: *
6750: * LOAD EXPRESSION BY NAME
6751: *
6752: O$LEX ENT ENTRY POINT
6753: MOV *EVSI$,WA SET SIZE OF EVBLK
6754: JSR ALLOC ALLOCATE SPACE FOR EVBLK
6755: MOV =B$EVT,(XR) SET TYPE WORD
6756: MOV =TRBEV,EVVAR(XR) SET DUMMY TRBLK POINTER
6757: LCW WA LOAD EXBLK POINTER
6758: MOV WA,EVEXP(XR) SET EXBLK POINTER
6759: MOV XR,XL MOVE NAME BASE TO PROPER REG
6760: MOV *EVVAR,WA SET NAME OFFSET = ZERO
6761: BRN EXNAM EXIT WITH NAME IN (XL,WA)
6762: EJC
6763: *
6764: * LOAD PATTERN VALUE
6765: *
6766: O$LPT ENT ENTRY POINT
6767: LCW XR LOAD PATTERN POINTER
6768: BRN EXIXR STACK PTR AND OBEY NEXT CODE WORD
6769: EJC
6770: *
6771: * LOAD VARIABLE NAME
6772: *
6773: O$LVN ENT ENTRY POINT
6774: LCW WA LOAD VRBLK POINTER
6775: MOV WA,-(XS) STACK VRBLK PTR (NAME BASE)
6776: MOV *VRVAL,-(XS) STACK NAME OFFSET
6777: BRN EXITS EXIT WITH RESULT ON STACK
6778: EJC
6779: *
6780: * BINARY ASTERISK (MULTIPLICATION)
6781: *
6782: O$MLT ENT ENTRY POINT
6783: JSR ARITH FETCH ARITHMETIC OPERANDS
6784: ERR 026,MULTIPLICATION LEFT OPERAND IS NOT NUMERIC
6785: ERR 027,MULTIPLICATION RIGHT OPERAND IS NOT NUMERIC
6786: PPM OMLT1 JUMP IF REAL OPERANDS
6787: *
6788: * HERE TO MULTIPLY TWO INTEGERS
6789: *
6790: MLI ICVAL(XL) MULTIPLY LEFT OPERAND BY RIGHT
6791: INO EXINT RETURN INTEGER IF NO OVERFLOW
6792: ERB 028,MULTIPLICATION CAUSED INTEGER OVERFLOW
6793: *
6794: * HERE TO MULTIPLY TWO REALS
6795: *
6796: OMLT1 MLR RCVAL(XL) MULTIPLY LEFT OPERAND BY RIGHT
6797: RNO EXREA RETURN REAL IF NO OVERFLOW
6798: ERB 263,MULTIPLICATION CAUSED REAL OVERFLOW
6799: EJC
6800: *
6801: * NAME REFERENCE
6802: *
6803: O$NAM ENT ENTRY POINT
6804: MOV *NMSI$,WA SET LENGTH OF NMBLK
6805: JSR ALLOC ALLOCATE NMBLK
6806: MOV =B$NML,(XR) SET NAME BLOCK CODE
6807: MOV (XS)+,NMOFS(XR) SET NAME OFFSET FROM OPERAND
6808: MOV (XS)+,NMBAS(XR) SET NAME BASE FROM OPERAND
6809: BRN EXIXR EXIT WITH RESULT IN XR
6810: EJC
6811: *
6812: * NEGATION
6813: *
6814: * INITIAL ENTRY
6815: *
6816: O$NTA ENT ENTRY POINT
6817: LCW WA LOAD NEW FAILURE OFFSET
6818: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER
6819: MOV WA,-(XS) STACK NEW FAILURE OFFSET
6820: MOV XS,FLPTR SET NEW FAILURE POINTER
6821: BRN EXITS JUMP TO CONTINUE EXECUTION
6822: *
6823: * ENTRY AFTER SUCCESSFUL EVALUATION OF OPERAND
6824: *
6825: O$NTB ENT ENTRY POINT
6826: MOV 2(XS),FLPTR RESTORE OLD FAILURE POINTER
6827: BRN EXFAL AND FAIL
6828: *
6829: * ENTRY FOR FAILURE DURING OPERAND EVALUATION
6830: *
6831: O$NTC ENT ENTRY POINT
6832: ICA XS POP FAILURE OFFSET
6833: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER
6834: BRN EXNUL EXIT GIVING NULL RESULT
6835: EJC
6836: *
6837: * USE OF UNDEFINED OPERATOR
6838: *
6839: O$OUN ENT ENTRY POINT
6840: ERB 029,UNDEFINED OPERATOR REFERENCED
6841: EJC
6842: *
6843: * BINARY DOT (PATTERN ASSIGNMENT)
6844: *
6845: * THE PATTERN BUILT BY BINARY DOT IS A COMPOUND PATTERN.
6846: * SEE DESCRIPTION AT START OF PATTERN MATCH SECTION FOR
6847: * DETAILS OF THE STRUCTURE WHICH IS CONSTRUCTED.
6848: *
6849: O$PAS ENT ENTRY POINT
6850: MOV =P$PAC,WB LOAD PCODE FOR P$PAC NODE
6851: MOV (XS)+,WC LOAD NAME OFFSET (PARM2)
6852: MOV (XS)+,XR LOAD NAME BASE (PARM1)
6853: JSR PBILD BUILD P$PAC NODE
6854: MOV XR,XL SAVE PTR TO NODE
6855: MOV (XS),XR LOAD LEFT OPERAND
6856: JSR GTPAT CONVERT TO PATTERN
6857: ERR 030,PATTERN ASSIGNMENT LEFT OPERAND IS NOT PATTERN
6858: MOV XR,(XS) SAVE PTR TO LEFT OPERAND PATTERN
6859: MOV =P$PAA,WB SET PCODE FOR P$PAA NODE
6860: JSR PBILD BUILD P$PAA NODE
6861: MOV (XS)+,PTHEN(XR) SET LEFT OPERAND AS P$PAA SUCCESSOR
6862: JSR PCONC CONCATENATE TO FORM FINAL PATTERN
6863: BRN EXIXR JUMP FOR NEXT CODE WORD
6864: EJC
6865: *
6866: * PATTERN MATCH (BY NAME, FOR REPLACEMENT)
6867: *
6868: O$PMN ENT ENTRY POINT
6869: ZER WB SET TYPE CODE FOR MATCH BY NAME
6870: BRN MATCH JUMP TO ROUTINE TO START MATCH
6871: EJC
6872: *
6873: * PATTERN MATCH (STATEMENT)
6874: *
6875: * O$PMS IS USED IN PLACE OF O$PMV WHEN THE PATTERN MATCH
6876: * OCCURS AT THE OUTER (STATEMENT) LEVEL SINCE IN THIS
6877: * CASE THE SUBSTRING VALUE NEED NOT BE CONSTRUCTED.
6878: *
6879: O$PMS ENT ENTRY POINT
6880: MOV =NUM02,WB SET FLAG FOR STATEMENT TO MATCH
6881: BRN MATCH JUMP TO ROUTINE TO START MATCH
6882: EJC
6883: *
6884: * PATTERN MATCH (BY VALUE)
6885: *
6886: O$PMV ENT ENTRY POINT
6887: MOV =NUM01,WB SET TYPE CODE FOR VALUE MATCH
6888: BRN MATCH JUMP TO ROUTINE TO START MATCH
6889: EJC
6890: *
6891: * POP TOP ITEM ON STACK
6892: *
6893: O$POP ENT ENTRY POINT
6894: ICA XS POP TOP STACK ENTRY
6895: BRN EXITS OBEY NEXT CODE WORD
6896: EJC
6897: *
6898: * TERMINATE EXECUTION (CODE COMPILED FOR END STATEMENT)
6899: *
6900: O$STP ENT ENTRY POINT
6901: BRN LEND0 JUMP TO END CIRCUIT
6902: EJC
6903: *
6904: * RETURN NAME FROM EXPRESSION
6905: * THIS ENTRY POINTS IS USED IF THE EVALUATION OF AN
6906: * EXPRESSION, INITIATED BY THE EVALX PROCEDURE, RETURNS
6907: * A NAME. CONTROL IS RETURNED TO THE PROPER POINT IN EVALX.
6908: *
6909: O$RNM ENT ENTRY POINT
6910: BRN EVLX4 RETURN TO EVALX PROCEDURE
6911: EJC
6912: *
6913: * PATTERN REPLACEMENT
6914: *
6915: * WHEN THIS ROUTINE GETS CONTROL, THE FOLLOWING STACK
6916: * ENTRIES HAVE BEEN MADE (SEE END OF MATCH ROUTINE P$NTH)
6917: *
6918: * SUBJECT NAME BASE
6919: * SUBJECT NAME OFFSET
6920: * INITIAL CURSOR VALUE
6921: * FINAL CURSOR VALUE
6922: * SUBJECT POINTER
6923: * (XS) ---------------- REPLACEMENT VALUE
6924: *
6925: O$RPL ENT ENTRY POINT
6926: JSR GTSTG CONVERT REPLACEMENT VAL TO STRING
6927: ERR 031,PATTERN REPLACEMENT RIGHT OPERAND IS NOT STRING
6928: *
6929: * GET RESULT LENGTH AND ALLOCATE RESULT SCBLK
6930: *
6931: MOV (XS),XL LOAD SUBJECT STRING POINTER
6932: BEQ (XL),=B$BCT,ORPL4 BRANCH IF BUFFER ASSIGNMENT
6933: ADD SCLEN(XL),WA ADD SUBJECT STRING LENGTH
6934: ADD 2(XS),WA ADD STARTING CURSOR
6935: SUB 1(XS),WA MINUS FINAL CURSOR = TOTAL LENGTH
6936: BZE WA,ORPL3 JUMP IF RESULT IS NULL
6937: MOV XR,-(XS) RESTACK REPLACEMENT STRING
6938: JSR ALOCS ALLOCATE SCBLK FOR RESULT
6939: MOV 3(XS),WA GET INITIAL CURSOR (PART 1 LEN)
6940: MOV XR,3(XS) STACK RESULT POINTER
6941: PSC XR POINT TO CHARACTERS OF RESULT
6942: *
6943: * MOVE PART 1 (START OF SUBJECT) TO RESULT
6944: *
6945: BZE WA,ORPL1 JUMP IF FIRST PART IS NULL
6946: MOV 1(XS),XL ELSE POINT TO SUBJECT STRING
6947: PLC XL POINT TO SUBJECT STRING CHARS
6948: MVC MOVE FIRST PART TO RESULT
6949: EJC
6950: * PATTERN REPLACEMENT (CONTINUED)
6951: *
6952: * NOW MOVE IN REPLACEMENT VALUE
6953: *
6954: ORPL1 MOV (XS)+,XL LOAD REPLACEMENT STRING, POP
6955: MOV SCLEN(XL),WA LOAD LENGTH
6956: BZE WA,ORPL2 JUMP IF NULL REPLACEMENT
6957: PLC XL ELSE POINT TO CHARS OF REPLACEMENT
6958: MVC MOVE IN CHARS (PART 2)
6959: *
6960: * NOW MOVE IN REMAINDER OF STRING (PART 3)
6961: *
6962: ORPL2 MOV (XS)+,XL LOAD SUBJECT STRING POINTER, POP
6963: MOV (XS)+,WC LOAD FINAL CURSOR, POP
6964: MOV SCLEN(XL),WA LOAD SUBJECT STRING LENGTH
6965: SUB WC,WA MINUS FINAL CURSOR = PART 3 LENGTH
6966: BZE WA,OASS0 JUMP TO ASSIGN IF PART 3 IS NULL
6967: PLC XL,WC ELSE POINT TO LAST PART OF STRING
6968: MVC MOVE PART 3 TO RESULT
6969: BRN OASS0 JUMP TO PERFORM ASSIGNMENT
6970: *
6971: * HERE IF RESULT IS NULL
6972: *
6973: ORPL3 ADD *NUM02,XS POP SUBJECT STR PTR, FINAL CURSOR
6974: MOV =NULLS,(XS) SET NULL RESULT
6975: BRN OASS0 JUMP TO ASSIGN NULL VALUE
6976: *
6977: * HERE FOR BUFFER SUBSTRING ASSIGNMENT
6978: *
6979: ORPL4 MOV XR,XL COPY SCBLK REPLACEMENT PTR
6980: MOV (XS)+,XR UNSTACK BCBLK PTR
6981: MOV (XS)+,WB GET FINAL CURSOR VALUE
6982: MOV (XS)+,WA GET INITIAL CURSOR
6983: SUB WA,WB GET LENGTH IN WB
6984: ADD *NUM02,XS GET RID OF NAME BASE/OFFSET
6985: JSR INSBF INSERT SUBSTRING
6986: PPM CONVERT FAIL IMPOSSIBLE
6987: PPM EXFAL FAIL IF INSERT FAILS
6988: BRN EXNUL ELSE NULL RESULT
6989: EJC
6990: *
6991: * RETURN VALUE FROM EXPRESSION
6992: *
6993: * THIS ENTRY POINTS IS USED IF THE EVALUATION OF AN
6994: * EXPRESSION, INITIATED BY THE EVALX PROCEDURE, RETURNS
6995: * A VALUE. CONTROL IS RETURNED TO THE PROPER POINT IN EVALX
6996: *
6997: O$RVL ENT ENTRY POINT
6998: BRN EVLX3 RETURN TO EVALX PROCEDURE
6999: EJC
7000: *
7001: * SELECTION
7002: *
7003: * INITIAL ENTRY
7004: *
7005: O$SLA ENT ENTRY POINT
7006: LCW WA LOAD NEW FAILURE OFFSET
7007: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER
7008: MOV WA,-(XS) STACK NEW FAILURE OFFSET
7009: MOV XS,FLPTR SET NEW FAILURE POINTER
7010: BRN EXITS JUMP TO EXECUTE FIRST ALTERNATIVE
7011: *
7012: * ENTRY AFTER SUCCESSFUL EVALUATION OF ALTERNATIVE
7013: *
7014: O$SLB ENT ENTRY POINT
7015: MOV (XS)+,XR LOAD RESULT
7016: ICA XS POP FAIL OFFSET
7017: MOV (XS),FLPTR RESTORE OLD FAILURE POINTER
7018: MOV XR,(XS) RESTACK RESULT
7019: LCW WA LOAD NEW CODE OFFSET
7020: ADD R$COD,WA POINT TO ABSOLUTE CODE LOCATION
7021: LCP WA SET NEW CODE POINTER
7022: BRN EXITS JUMP TO CONTINUE PAST SELECTION
7023: *
7024: * ENTRY AT START OF SUBSEQUENT ALTERNATIVES
7025: *
7026: O$SLC ENT ENTRY POINT
7027: LCW WA LOAD NEW FAIL OFFSET
7028: MOV WA,(XS) STORE NEW FAIL OFFSET
7029: BRN EXITS JUMP TO EXECUTE NEXT ALTERNATIVE
7030: *
7031: * ENTRY AT START OF LAST ALTERNATIVE
7032: *
7033: O$SLD ENT ENTRY POINT
7034: ICA XS POP FAILURE OFFSET
7035: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER
7036: BRN EXITS JUMP TO EXECUTE LAST ALTERNATIVE
7037: EJC
7038: *
7039: * BINARY MINUS (SUBTRACTION)
7040: *
7041: O$SUB ENT ENTRY POINT
7042: JSR ARITH FETCH ARITHMETIC OPERANDS
7043: ERR 032,SUBTRACTION LEFT OPERAND IS NOT NUMERIC
7044: ERR 033,SUBTRACTION RIGHT OPERAND IS NOT NUMERIC
7045: PPM OSUB1 JUMP IF REAL OPERANDS
7046: *
7047: * HERE TO SUBTRACT TWO INTEGERS
7048: *
7049: SBI ICVAL(XL) SUBTRACT RIGHT OPERAND FROM LEFT
7050: INO EXINT RETURN INTEGER IF NO OVERFLOW
7051: ERB 034,SUBTRACTION CAUSED INTEGER OVERFLOW
7052: *
7053: * HERE TO SUBTRACT TWO REALS
7054: *
7055: OSUB1 SBR RCVAL(XL) SUBTRACT RIGHT OPERAND FROM LEFT
7056: RNO EXREA RETURN REAL IF NO OVERFLOW
7057: ERB 264,SUBTRACTION CAUSED REAL OVERFLOW
7058: EJC
7059: *
7060: * DUMMY OPERATOR TO RETURN CONTROL TO TRXEQ PROCEDURE
7061: *
7062: O$TXR ENT ENTRY POINT
7063: BRN TRXQ1 JUMP INTO TRXEQ PROCEDURE
7064: EJC
7065: *
7066: * UNEXPECTED FAILURE
7067: *
7068: * NOTE THAT IF A SETEXIT TRAP IS OPERATING THEN
7069: * TRANSFER TO SYSTEM LABEL CONTINUE
7070: * WILL RESULT IN LOOPING HERE. DIFFICULT TO AVOID EXCEPT
7071: * WITH A CONSIDERABLE OVERHEAD WHICH IS NOT WORTHWHILE OR
7072: * ELSE BY A TECHNIQUE SUCH AS SETTING KVERL TO ZERO.
7073: *
7074: O$UNF ENT ENTRY POINT
7075: ERB 035,UNEXPECTED FAILURE IN -NOFAIL MODE
7076: TTL S P I T B O L -- SNOBOL4 BUILTIN LABEL ROUTINES
7077: *
7078: * THE FOLLOWING SECTION CONTAINS THE ROUTINES FOR LABELS
7079: * WHICH HAVE A PREDEFINED MEANING IN SNOBOL4.
7080: *
7081: * CONTROL IS PASSED DIRECTLY TO THE LABEL NAME ENTRY POINT.
7082: *
7083: * ENTRY NAMES ARE OF THE FORM L$XXX WHERE XXX IS THE THREE
7084: * LETTER VARIABLE NAME IDENTIFIER.
7085: *
7086: * ENTRIES ARE IN ALPHABETICAL ORDER
7087: EJC
7088: *
7089: * ABORT
7090: *
7091: L$ABO ENT ENTRY POINT
7092: *
7093: * MERGE HERE IF EXECUTION TERMINATES IN ERROR
7094: *
7095: LABO1 MOV KVERT,WA LOAD ERROR CODE
7096: BZE WA,LABO2 JUMP IF NO ERROR HAS OCCURED
7097: JSR SYSAX CALL AFTER EXECUTION PROC (REG04)
7098: JSR PRTPG ELSE EJECT PRINTER
7099: JSR ERMSG PRINT ERROR MESSAGE
7100: ZER XR INDICATE NO MESSAGE TO PRINT
7101: BRN STOPR JUMP TO ROUTINE TO STOP RUN
7102: *
7103: * HERE IF NO ERROR HAD OCCURED
7104: *
7105: LABO2 ERB 036,GOTO ABORT WITH NO PRECEDING ERROR
7106: EJC
7107: *
7108: * CONTINUE
7109: *
7110: L$CNT ENT ENTRY POINT
7111: *
7112: * MERGE HERE AFTER EXECUTION ERROR
7113: *
7114: LCNT1 MOV R$CNT,XR LOAD CONTINUATION CODE BLOCK PTR
7115: BZE XR,LCNT2 JUMP IF NO PREVIOUS ERROR
7116: ZER R$CNT CLEAR FLAG
7117: MOV XR,R$COD ELSE STORE AS NEW CODE BLOCK PTR
7118: ADD STXOF,XR ADD FAILURE OFFSET
7119: LCP XR LOAD CODE POINTER
7120: MOV FLPTR,XS RESET STACK POINTER
7121: BRN EXITS JUMP TO TAKE INDICATED FAILURE
7122: *
7123: * HERE IF NO PREVIOUS ERROR
7124: *
7125: LCNT2 ERB 037,GOTO CONTINUE WITH NO PRECEDING ERROR
7126: EJC
7127: *
7128: * END
7129: *
7130: L$END ENT ENTRY POINT
7131: *
7132: * MERGE HERE FROM END CODE CIRCUIT
7133: *
7134: LEND0 MOV =ENDMS,XR POINT TO MESSAGE /NORMAL TERM../
7135: BRN STOPR JUMP TO ROUTINE TO STOP RUN
7136: EJC
7137: *
7138: * FRETURN
7139: *
7140: L$FRT ENT ENTRY POINT
7141: MOV =SCFRT,WA POINT TO STRING /FRETURN/
7142: BRN RETRN JUMP TO COMMON RETURN ROUTINE
7143: EJC
7144: *
7145: * NRETURN
7146: *
7147: L$NRT ENT ENTRY POINT
7148: MOV =SCNRT,WA POINT TO STRING /NRETURN/
7149: BRN RETRN JUMP TO COMMON RETURN ROUTINE
7150: EJC
7151: *
7152: * RETURN
7153: *
7154: L$RTN ENT ENTRY POINT
7155: MOV =SCRTN,WA POINT TO STRING /RETURN/
7156: BRN RETRN JUMP TO COMMON RETURN ROUTINE
7157: EJC
7158: *
7159: * UNDEFINED LABEL
7160: *
7161: L$UND ENT ENTRY POINT
7162: ERB 038,GOTO UNDEFINED LABEL
7163: TTL S P I T B O L -- BLOCK ACTION ROUTINES
7164: *
7165: * THE FIRST WORD OF EVERY BLOCK IN DYNAMIC STORAGE AND THE
7166: * VRGET, VRSTO AND VRTRA FIELDS OF A VRBLK CONTAIN A
7167: * POINTER TO AN ENTRY POINT IN THE PROGRAM. ALL SUCH ENTRY
7168: * POINTS ARE IN THE FOLLOWING SECTION EXCEPT THOSE FOR
7169: * PATTERN BLOCKS WHICH ARE IN THE PATTERN MATCHING SEGMENT
7170: * LATER ON (LABELS OF THE FORM P$XXX), AND DOPE VECTORS
7171: * (D$XXX) WHICH ARE IN THE DOPE VECTOR SECTION FOLLOWING
7172: * THE PATTERN ROUTINES (DOPE VECTORS ARE USED FOR CMBLKS).
7173: *
7174: * THE ENTRY POINTS IN THIS SECTION HAVE LABELS OF THE
7175: * FORM B$XXY WHERE XX IS THE TWO CHARACTER BLOCK TYPE FOR
7176: * THE CORRESPONDING BLOCK AND Y IS ANY LETTER.
7177: *
7178: * IN SOME CASES, THE POINTERS SERVE NO OTHER PURPOSE THAN
7179: * TO IDENTIFY THE BLOCK TYPE. IN THIS CASE THE ROUTINE
7180: * IS NEVER EXECUTED AND THUS NO CODE IS ASSEMBLED.
7181: *
7182: * FOR EACH OF THESE ENTRY POINTS CORRESPONDING TO A BLOCK
7183: * AN ENTRY POINT IDENTIFICATION IS ASSEMBLED (BL$XX).
7184: *
7185: * THE EXACT ENTRY CONDITIONS DEPEND ON THE MANNER IN
7186: * WHICH THE ROUTINE IS ACCESSED AND ARE DOCUMENTED WITH
7187: * THE INDIVIDUAL ROUTINES AS REQUIRED.
7188: *
7189: * THE ORDER OF THESE ROUTINES IS ALPHABETICAL WITH THE
7190: * FOLLOWING EXCEPTIONS.
7191: *
7192: * THE ROUTINES FOR SEBLK AND EXBLK ENTRIES OCCUR FIRST SO
7193: * THAT EXPRESSIONS CAN BE QUICKLY IDENTIFIED FROM THE FACT
7194: * THAT THEIR ROUTINES LIE BEFORE THE SYMBOL B$E$$.
7195: *
7196: * THESE ARE IMMEDIATELY FOLLOWED BY THE ROUTINE FOR A TRBLK
7197: * SO THAT THE TEST AGAINST THE SYMBOL B$T$$ CHECKS FOR
7198: * TRAPPED VALUES OR EXPRESSION VALUES (SEE PROCEDURE EVALP)
7199: *
7200: * THE PATTERN ROUTINES LIE AFTER THIS SECTION SO THAT
7201: * PATTERNS ARE IDENTIFIED WITH ROUTINES STARTING AT OR
7202: * AFTER THE INITIAL INSTRUCTION IN THESE ROUTINES (P$AAA).
7203: *
7204: * THE SYMBOL B$AAA DEFINES THE FIRST LOCATION FOR BLOCK
7205: * ROUTINES AND THE SYMBOL P$YYY (AT THE END OF THE PATTERN
7206: * MATCH ROUTINES SECTION) DEFINES THE LAST SUCH ENTRY POINT
7207: *
7208: B$AAA ENT BL$$I ENTRY POINT OF FIRST BLOCK ROUTINE
7209: EJC
7210: *
7211: * EXBLK
7212: *
7213: * THE ROUTINE FOR AN EXBLK LOADS THE EXPRESSION ONTO
7214: * THE STACK AS A VALUE.
7215: *
7216: * (XR) POINTER TO EXBLK
7217: *
7218: B$EXL ENT BL$EX ENTRY POINT (EXBLK)
7219: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
7220: EJC
7221: *
7222: * SEBLK
7223: *
7224: * THE ROUTINE FOR SEBLK IS ACCESSED FROM THE GENERATED
7225: * CODE TO LOAD THE EXPRESSION VALUE ONTO THE STACK.
7226: *
7227: B$SEL ENT BL$SE ENTRY POINT (SEBLK)
7228: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
7229: *
7230: * DEFINE SYMBOL WHICH MARKS END OF ENTRIES FOR EXPRESSIONS
7231: *
7232: B$E$$ ENT BL$$I ENTRY POINT
7233: EJC
7234: *
7235: * TRBLK
7236: *
7237: * THE ROUTINE FOR A TRBLK IS NEVER EXECUTED
7238: *
7239: B$TRT ENT BL$TR ENTRY POINT (TRBLK)
7240: *
7241: * DEFINE SYMBOL MARKING END OF TRAP AND EXPRESSION BLOCKS
7242: *
7243: B$T$$ ENT BL$$I END OF TRBLK,SEBLK,EXBLK ENTRIES
7244: EJC
7245: *
7246: * ARBLK
7247: *
7248: * THE ROUTINE FOR ARBLK IS NEVER EXECUTED
7249: *
7250: B$ART ENT BL$AR ENTRY POINT (ARBLK)
7251: EJC
7252: *
7253: * BCBLK
7254: *
7255: * THE ROUTINE FOR A BCBLK IS NEVER EXECUTED
7256: *
7257: * (XR) POINTER TO BCBLK
7258: *
7259: B$BCT ENT BL$BC ENTRY POINT (BCBLK)
7260: EJC
7261: *
7262: * BFBLK
7263: *
7264: * THE ROUTINE FOR A BFBLK IS NEVER EXECUTED
7265: *
7266: * (XR) POINTER TO BFBLK
7267: *
7268: B$BFT ENT BL$BF ENTRY POINT (BFBLK)
7269: EJC
7270: *
7271: * CCBLK
7272: *
7273: * THE ROUTINE FOR CCBLK IS NEVER ENTERED
7274: *
7275: B$CCT ENT BL$CC ENTRY POINT (CCBLK)
7276: EJC
7277: *
7278: * CDBLK
7279: *
7280: * THE CDBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE.
7281: * THERE ARE TWO CASES DEPENDING ON THE FORM OF CDFAL.
7282: *
7283: * ENTRY FOR COMPLEX FAILURE CODE AT CDFAL
7284: *
7285: * (XR) POINTER TO CDBLK
7286: *
7287: B$CDC ENT BL$CD ENTRY POINT (CDBLK)
7288: BCDC0 MOV FLPTR,XS POP GARBAGE OFF STACK
7289: MOV CDFAL(XR),(XS) SET FAILURE OFFSET
7290: BRN STMGO ENTER STMT
7291: EJC
7292: *
7293: * CDBLK (CONTINUED)
7294: *
7295: * ENTRY FOR SIMPLE FAILURE CODE AT CDFAL
7296: *
7297: * (XR) POINTER TO CDBLK
7298: *
7299: B$CDS ENT BL$CD ENTRY POINT (CDBLK)
7300: BCDS0 MOV FLPTR,XS POP GARBAGE OFF STACK
7301: MOV *CDFAL,(XS) SET FAILURE OFFSET
7302: BRN STMGO ENTER STMT
7303: EJC
7304: *
7305: * CMBLK
7306: *
7307: * THE ROUTINE FOR A CMBLK IS NEVER EXECUTED
7308: *
7309: B$CMT ENT BL$CM ENTRY POINT (CMBLK)
7310: EJC
7311: *
7312: * CTBLK
7313: *
7314: * THE ROUTINE FOR A CTBLK IS NEVER EXECUTED
7315: *
7316: B$CTT ENT BL$CT ENTRY POINT (CTBLK)
7317: EJC
7318: *
7319: * DFBLK
7320: *
7321: * THE ROUTINE FOR A DFBLK IS ACCESSED FROM THE O$FNC ENTRY
7322: * TO CALL A DATATYPE FUNCTION AND BUILD A PDBLK.
7323: *
7324: * (XL) POINTER TO DFBLK
7325: *
7326: B$DFC ENT BL$DF ENTRY POINT
7327: MOV DFPDL(XL),WA LOAD LENGTH OF PDBLK
7328: JSR ALLOC ALLOCATE PDBLK
7329: MOV =B$PDT,(XR) STORE TYPE WORD
7330: MOV XL,PDDFP(XR) STORE DFBLK POINTER
7331: MOV XR,WC SAVE POINTER TO PDBLK
7332: ADD WA,XR POINT PAST PDBLK
7333: LCT WA,FARGS(XL) SET TO COUNT FIELDS
7334: *
7335: * LOOP TO ACQUIRE FIELD VALUES FROM STACK
7336: *
7337: BDFC1 MOV (XS)+,-(XR) MOVE A FIELD VALUE
7338: BCT WA,BDFC1 LOOP TILL ALL MOVED
7339: MOV WC,XR RECALL POINTER TO PDBLK
7340: BRN EXSID EXIT SETTING ID FIELD
7341: EJC
7342: *
7343: * EFBLK
7344: *
7345: * THE ROUTINE FOR AN EFBLK IS PASSED CONTROL FORM THE O$FNC
7346: * ENTRY TO CALL AN EXTERNAL FUNCTION.
7347: *
7348: * (XL) POINTER TO EFBLK
7349: *
7350: B$EFC ENT BL$EF ENTRY POINT (EFBLK)
7351: MOV FARGS(XL),WC LOAD NUMBER OF ARGUMENTS
7352: WTB WC CONVERT TO OFFSET
7353: MOV XL,-(XS) SAVE POINTER TO EFBLK
7354: MOV XS,XT COPY POINTER TO ARGUMENTS
7355: *
7356: * LOOP TO CONVERT ARGUMENTS
7357: *
7358: BEFC1 ICA XT POINT TO NEXT ENTRY
7359: MOV (XS),XR LOAD POINTER TO EFBLK
7360: DCA WC DECREMENT EFTAR OFFSET
7361: ADD WC,XR POINT TO NEXT EFTAR ENTRY
7362: MOV EFTAR(XR),XR LOAD EFTAR ENTRY
7363: BSW XR,4 SWITCH ON TYPE
7364: IFF 0,BEFC7 NO CONVERSION NEEDED
7365: IFF 1,BEFC2 STRING
7366: IFF 2,BEFC3 INTEGER
7367: IFF 3,BEFC4 REAL
7368: ESW END OF SWITCH ON TYPE
7369: *
7370: * HERE TO CONVERT TO STRING
7371: *
7372: BEFC2 MOV (XT),-(XS) STACK ARG PTR
7373: JSR GTSTG CONVERT ARGUMENT TO STRING
7374: ERR 039,EXTERNAL FUNCTION ARGUMENT IS NOT STRING
7375: BRN BEFC6 JUMP TO MERGE
7376: EJC
7377: *
7378: * EFBLK (CONTINUED)
7379: *
7380: * HERE TO CONVERT AN INTEGER
7381: *
7382: BEFC3 MOV (XT),XR LOAD NEXT ARGUMENT
7383: MOV WC,BEFOF SAVE OFFSET
7384: JSR GTINT CONVERT TO INTEGER
7385: ERR 040,EXTERNAL FUNCTION ARGUMENT IS NOT INTEGER
7386: BRN BEFC5 MERGE WITH REAL CASE
7387: *
7388: * HERE TO CONVERT A REAL
7389: *
7390: BEFC4 MOV (XT),XR LOAD NEXT ARGUMENT
7391: MOV WC,BEFOF SAVE OFFSET
7392: JSR GTREA CONVERT TO REAL
7393: ERR 265,EXTERNAL FUNCTION ARGUMENT IS NOT REAL
7394: *
7395: * INTEGER CASE MERGES HERE
7396: *
7397: BEFC5 MOV BEFOF,WC RESTORE OFFSET
7398: *
7399: * STRING MERGES HERE
7400: *
7401: BEFC6 MOV XR,(XT) STORE CONVERTED RESULT
7402: *
7403: * NO CONVERSION MERGES HERE
7404: *
7405: BEFC7 BNZ WC,BEFC1 LOOP BACK IF MORE TO GO
7406: *
7407: * HERE AFTER CONVERTING ALL THE ARGUMENTS
7408: *
7409: MOV (XS)+,XL RESTORE EFBLK POINTER
7410: MOV FARGS(XL),WA GET NUMBER OF ARGS
7411: JSR SYSEX CALL ROUTINE TO CALL EXTERNAL FNC
7412: PPM EXFAL FAIL IF FAILURE
7413: EJC
7414: *
7415: * EFBLK (CONTINUED)
7416: *
7417: * RETURN HERE WITH RESULT IN XR
7418: *
7419: * FIRST DEFEND AGAINST NON-STANDARD NULL STRING RETURNED
7420: *
7421: MOV EFRSL(XL),WB GET RESULT TYPE ID
7422: BNZ WB,BEFA8 BRANCH IF NOT UNCONVERTED
7423: BNE (XR),=B$SCL,BEFC8 JUMP IF NOT A STRING
7424: BZE SCLEN(XR),EXNUL RETURN NULL IF NULL
7425: *
7426: * HERE IF CONVERTED RESULT TO CHECK FOR NULL STRING
7427: *
7428: BEFA8 BNE WB,=NUM01,BEFC8 JUMP IF NOT A STRING
7429: BZE SCLEN(XR),EXNUL RETURN NULL IF NULL
7430: *
7431: * RETURN IF RESULT IS IN DYNAMIC STORAGE
7432: *
7433: BEFC8 BLT XR,DNAMB,BEFC9 JUMP IF NOT IN DYNAMIC STORAGE
7434: BLE XR,DNAMP,EXIXR RETURN RESULT IF ALREADY DYNAMIC
7435: *
7436: * HERE WE COPY A RESULT INTO THE DYNAMIC REGION
7437: *
7438: BEFC9 MOV (XR),WA GET POSSIBLE TYPE WORD
7439: BZE WB,BEF11 JUMP IF UNCONVERTED RESULT
7440: MOV =B$SCL,WA STRING
7441: BEQ WB,=NUM01,BEF10 YES JUMP
7442: MOV =B$ICL,WA INTEGER
7443: BEQ WB,=NUM02,BEF10 YES JUMP
7444: MOV =B$RCL,WA REAL
7445: *
7446: * STORE TYPE WORD IN RESULT
7447: *
7448: BEF10 MOV WA,(XR) STORED BEFORE COPYING TO DYNAMIC
7449: *
7450: * MERGE FOR UNCONVERTED RESULT
7451: *
7452: BEF11 JSR BLKLN GET LENGTH OF BLOCK
7453: MOV XR,XL COPY ADDRESS OF OLD BLOCK
7454: JSR ALLOC ALLOCATE DYNAMIC BLOCK SAME SIZE
7455: MOV XR,-(XS) SET POINTER TO NEW BLOCK AS RESULT
7456: MVW COPY OLD BLOCK TO DYNAMIC BLOCK
7457: BRN EXITS EXIT WITH RESULT ON STACK
7458: EJC
7459: *
7460: * EVBLK
7461: *
7462: * THE ROUTINE FOR AN EVBLK IS NEVER EXECUTED
7463: *
7464: B$EVT ENT BL$EV ENTRY POINT (EVBLK)
7465: EJC
7466: *
7467: * FFBLK
7468: *
7469: * THE ROUTINE FOR AN FFBLK IS EXECUTED FROM THE O$FNC ENTRY
7470: * TO CALL A FIELD FUNCTION AND EXTRACT A FIELD VALUE/NAME.
7471: *
7472: * (XL) POINTER TO FFBLK
7473: *
7474: B$FFC ENT BL$FF ENTRY POINT (FFBLK)
7475: MOV XL,XR COPY FFBLK POINTER
7476: LCW WC LOAD NEXT CODE WORD
7477: MOV (XS),XL LOAD PDBLK POINTER
7478: BNE (XL),=B$PDT,BFFC2 JUMP IF NOT PDBLK AT ALL
7479: MOV PDDFP(XL),WA LOAD DFBLK POINTER FROM PDBLK
7480: *
7481: * LOOP TO FIND CORRECT FFBLK FOR THIS PDBLK
7482: *
7483: BFFC1 BEQ WA,FFDFP(XR),BFFC3 JUMP IF THIS IS THE CORRECT FFBLK
7484: MOV FFNXT(XR),XR ELSE LINK TO NEXT FFBLK ON CHAIN
7485: BNZ XR,BFFC1 LOOP BACK IF ANOTHER ENTRY TO CHECK
7486: *
7487: * HERE FOR BAD ARGUMENT
7488: *
7489: BFFC2 ERB 041,FIELD FUNCTION ARGUMENT IS WRONG DATATYPE
7490: EJC
7491: *
7492: * FFBLK (CONTINUED)
7493: *
7494: * HERE AFTER LOCATING CORRECT FFBLK
7495: *
7496: BFFC3 MOV FFOFS(XR),WA LOAD FIELD OFFSET
7497: BEQ WC,=OFNE$,BFFC5 JUMP IF CALLED BY NAME
7498: ADD WA,XL ELSE POINT TO VALUE FIELD
7499: MOV (XL),XR LOAD VALUE
7500: BNE (XR),=B$TRT,BFFC4 JUMP IF NOT TRAPPED
7501: SUB WA,XL ELSE RESTORE NAME BASE,OFFSET
7502: MOV WC,(XS) SAVE NEXT CODE WORD OVER PDBLK PTR
7503: JSR ACESS ACCESS VALUE
7504: PPM EXFAL FAIL IF ACCESS FAILS
7505: MOV (XS),WC RESTORE NEXT CODE WORD
7506: *
7507: * HERE AFTER GETTING VALUE IN (XR)
7508: *
7509: BFFC4 MOV XR,(XS) STORE VALUE ON STACK (OVER PDBLK)
7510: MOV WC,XR COPY NEXT CODE WORD
7511: MOV (XR),XL LOAD ENTRY ADDRESS
7512: BRI XL JUMP TO ROUTINE FOR NEXT CODE WORD
7513: *
7514: * HERE IF CALLED BY NAME
7515: *
7516: BFFC5 MOV WA,-(XS) STORE NAME OFFSET (BASE IS SET)
7517: BRN EXITS EXIT WITH NAME ON STACK
7518: EJC
7519: *
7520: * ICBLK
7521: *
7522: * THE ROUTINE FOR ICBLK IS EXECUTED FROM THE GENERATED
7523: * CODE TO LOAD AN INTEGER VALUE ONTO THE STACK.
7524: *
7525: * (XR) POINTER TO ICBLK
7526: *
7527: B$ICL ENT BL$IC ENTRY POINT (ICBLK)
7528: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
7529: EJC
7530: *
7531: * KVBLK
7532: *
7533: * THE ROUTINE FOR A KVBLK IS NEVER EXECUTED.
7534: *
7535: B$KVT ENT BL$KV ENTRY POINT (KVBLK)
7536: EJC
7537: *
7538: * NMBLK
7539: *
7540: * THE ROUTINE FOR A NMBLK IS EXECUTED FROM THE GENERATED
7541: * CODE FOR THE CASE OF LOADING A NAME ONTO THE STACK
7542: * WHERE THE NAME IS THAT OF A NATURAL VARIABLE WHICH CAN
7543: * BE PREEVALUATED AT COMPILE TIME.
7544: *
7545: * (XR) POINTER TO NMBLK
7546: *
7547: B$NML ENT BL$NM ENTRY POINT (NMBLK)
7548: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
7549: EJC
7550: *
7551: * PDBLK
7552: *
7553: * THE ROUTINE FOR A PDBLK IS NEVER EXECUTED
7554: *
7555: B$PDT ENT BL$PD ENTRY POINT (PDBLK)
7556: EJC
7557: *
7558: * PFBLK
7559: *
7560: * THE ROUTINE FOR A PFBLK IS EXECUTED FROM THE ENTRY O$FNC
7561: * TO CALL A PROGRAM DEFINED FUNCTION.
7562: *
7563: * (XL) POINTER TO PFBLK
7564: *
7565: * THE FOLLOWING STACK ENTRIES ARE MADE BEFORE PASSING
7566: * CONTROL TO THE PROGRAM DEFINED FUNCTION.
7567: *
7568: * SAVED VALUE OF FIRST ARGUMENT
7569: * .
7570: * SAVED VALUE OF LAST ARGUMENT
7571: * SAVED VALUE OF FIRST LOCAL
7572: * .
7573: * SAVED VALUE OF LAST LOCAL
7574: * SAVED VALUE OF FUNCTION NAME
7575: * SAVED CODE BLOCK PTR (R$COD)
7576: * SAVED CODE POINTER (-R$COD)
7577: * SAVED VALUE OF FLPRT
7578: * SAVED VALUE OF FLPTR
7579: * POINTER TO PFBLK
7580: * FLPTR --------------- ZERO (TO BE OVERWRITTEN WITH OFFS)
7581: *
7582: B$PFC ENT BL$PF ENTRY POINT (PFBLK)
7583: MOV XL,BPFPF SAVE PFBLK PTR (NEED NOT BE RELOC)
7584: MOV XL,XR COPY FOR THE MOMENT
7585: MOV PFVBL(XR),XL POINT TO VRBLK FOR FUNCTION
7586: *
7587: * LOOP TO FIND OLD VALUE OF FUNCTION
7588: *
7589: BPF01 MOV XL,WB SAVE POINTER
7590: MOV VRVAL(XL),XL LOAD VALUE
7591: BEQ (XL),=B$TRT,BPF01 LOOP IF TRBLK
7592: *
7593: * SET VALUE TO NULL AND SAVE OLD FUNCTION VALUE
7594: *
7595: MOV XL,BPFSV SAVE OLD VALUE
7596: MOV WB,XL POINT BACK TO BLOCK WITH VALUE
7597: MOV =NULLS,VRVAL(XL) SET VALUE TO NULL
7598: MOV FARGS(XR),WA LOAD NUMBER OF ARGUMENTS
7599: ADD *PFARG,XR POINT TO PFARG ENTRIES
7600: BZE WA,BPF04 JUMP IF NO ARGUMENTS
7601: MOV XS,XT PTR TO LAST ARG
7602: WTB WA CONVERT NO. OF ARGS TO BYTES OFFSET
7603: ADD WA,XT POINT BEFORE FIRST ARG
7604: MOV XT,BPFXT REMEMBER ARG POINTER
7605: EJC
7606: *
7607: * PFBLK (CONTINUED)
7608: *
7609: * LOOP TO SAVE OLD ARGUMENT VALUES AND SET NEW ONES
7610: *
7611: BPF02 MOV (XR)+,XL LOAD VRBLK PTR FOR NEXT ARGUMENT
7612: *
7613: * LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE
7614: *
7615: BPF03 MOV XL,WC SAVE POINTER
7616: MOV VRVAL(XL),XL LOAD NEXT VALUE
7617: BEQ (XL),=B$TRT,BPF03 LOOP BACK IF TRBLK
7618: *
7619: * SAVE OLD VALUE AND GET NEW VALUE
7620: *
7621: MOV XL,WA KEEP OLD VALUE
7622: MOV BPFXT,XT POINT BEFORE NEXT STACKED ARG
7623: MOV -(XT),WB LOAD ARGUMENT (NEW VALUE)
7624: MOV WA,(XT) SAVE OLD VALUE
7625: MOV XT,BPFXT KEEP ARG PTR FOR NEXT TIME
7626: MOV WC,XL POINT BACK TO BLOCK WITH VALUE
7627: MOV WB,VRVAL(XL) SET NEW VALUE
7628: BNE XS,BPFXT,BPF02 LOOP IF NOT ALL DONE
7629: *
7630: * NOW PROCESS LOCALS
7631: *
7632: BPF04 MOV BPFPF,XL RESTORE PFBLK POINTER
7633: MOV PFNLO(XL),WA LOAD NUMBER OF LOCALS
7634: BZE WA,BPF07 JUMP IF NO LOCALS
7635: MOV =NULLS,WB GET NULL CONSTANT
7636: LCT WA,WA SET LOCAL COUNTER
7637: *
7638: * LOOP TO PROCESS LOCALS
7639: *
7640: BPF05 MOV (XR)+,XL LOAD VRBLK PTR FOR NEXT LOCAL
7641: *
7642: * LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE
7643: *
7644: BPF06 MOV XL,WC SAVE POINTER
7645: MOV VRVAL(XL),XL LOAD NEXT VALUE
7646: BEQ (XL),=B$TRT,BPF06 LOOP BACK IF TRBLK
7647: *
7648: * SAVE OLD VALUE AND SET NULL AS NEW VALUE
7649: *
7650: MOV XL,-(XS) STACK OLD VALUE
7651: MOV WC,XL POINT BACK TO BLOCK WITH VALUE
7652: MOV WB,VRVAL(XL) SET NULL AS NEW VALUE
7653: BCT WA,BPF05 LOOP TILL ALL LOCALS PROCESSED
7654: EJC
7655: *
7656: * PFBLK (CONTINUED)
7657: *
7658: * HERE AFTER PROCESSING ARGUMENTS AND LOCALS
7659: *
7660: BPF07 ZER XR ZERO REG XR IN CASE
7661: BZE KVPFL,BPF7C SKIP IF PROFILING IS OFF
7662: BEQ KVPFL,=NUM02,BPF7A BRANCH ON TYPE OF PROFILE
7663: *
7664: * HERE IF &PROFILE = 1
7665: *
7666: JSR SYSTM GET CURRENT TIME
7667: STI PFETM SAVE FOR A SEC
7668: SBI PFSTM FIND TIME USED BY CALLER
7669: JSR ICBLD BUILD INTO AN ICBLK
7670: LDI PFETM RELOAD CURRENT TIME
7671: BRN BPF7B MERGE
7672: *
7673: * HERE IF &PROFILE = 2
7674: *
7675: BPF7A LDI PFSTM GET START TIME OF CALLING STMT
7676: JSR ICBLD ASSEMBLE AN ICBLK ROUND IT
7677: JSR SYSTM GET NOW TIME
7678: *
7679: * BOTH TYPES OF PROFILE MERGE HERE
7680: *
7681: BPF7B STI PFSTM SET START TIME OF 1ST FUNC STMT
7682: MNZ PFFNC FLAG FUNCTION ENTRY
7683: *
7684: * NO PROFILING MERGES HERE
7685: *
7686: BPF7C MOV XR,-(XS) STACK ICBLK PTR (OR ZERO)
7687: MOV R$COD,WA LOAD OLD CODE BLOCK POINTER
7688: SCP WB GET CODE POINTER
7689: SUB WA,WB MAKE CODE POINTER INTO OFFSET
7690: MOV BPFPF,XL RECALL PFBLK POINTER
7691: MOV BPFSV,-(XS) STACK OLD VALUE OF FUNCTION NAME
7692: MOV WA,-(XS) STACK CODE BLOCK POINTER
7693: MOV WB,-(XS) STACK CODE OFFSET
7694: MOV FLPRT,-(XS) STACK OLD FLPRT
7695: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER
7696: MOV XL,-(XS) STACK POINTER TO PFBLK
7697: ZER -(XS) DUMMY ZERO ENTRY FOR FAIL RETURN
7698: CHK CHECK FOR STACK OVERFLOW
7699: MOV XS,FLPTR SET NEW FAIL RETURN VALUE
7700: MOV XS,FLPRT SET NEW FLPRT
7701: MOV KVTRA,WA LOAD TRACE VALUE
7702: ADD KVFTR,WA ADD FTRACE VALUE
7703: BNZ WA,BPF09 JUMP IF TRACING POSSIBLE
7704: ICV KVFNC ELSE BUMP FNCLEVEL
7705: *
7706: * HERE TO ACTUALLY JUMP TO FUNCTION
7707: *
7708: BPF08 MOV PFCOD(XL),XR POINT TO CODE
7709: BRI (XR) OFF TO EXECUTE FUNCTION
7710: *
7711: * HERE IF TRACING IS POSSIBLE
7712: *
7713: BPF09 MOV PFCTR(XL),XR LOAD POSSIBLE CALL TRACE TRBLK
7714: MOV PFVBL(XL),XL LOAD VRBLK POINTER FOR FUNCTION
7715: MOV *VRVAL,WA SET NAME OFFSET FOR VARIABLE
7716: BZE KVTRA,BPF10 JUMP IF TRACE MODE IS OFF
7717: BZE XR,BPF10 OR IF THERE IS NO CALL TRACE
7718: *
7719: * HERE IF CALL TRACED
7720: *
7721: DCV KVTRA DECREMENT TRACE COUNT
7722: BZE TRFNC(XR),BPF11 JUMP IF PRINT TRACE
7723: JSR TRXEQ EXECUTE FUNCTION TYPE TRACE
7724: EJC
7725: *
7726: * PFBLK (CONTINUED)
7727: *
7728: * HERE TO TEST FOR FTRACE TRACE
7729: *
7730: BPF10 BZE KVFTR,BPF16 JUMP IF FTRACE IS OFF
7731: DCV KVFTR ELSE DECREMENT FTRACE
7732: *
7733: * HERE FOR PRINT TRACE
7734: *
7735: BPF11 JSR PRTSN PRINT STATEMENT NUMBER
7736: JSR PRTNM PRINT FUNCTION NAME
7737: MOV =CH$PP,WA LOAD LEFT PAREN
7738: JSR PRTCH PRINT LEFT PAREN
7739: MOV 1(XS),XL RECOVER PFBLK POINTER
7740: BZE FARGS(XL),BPF15 SKIP IF NO ARGUMENTS
7741: ZER WB ELSE SET ARGUMENT COUNTER
7742: BRN BPF13 JUMP INTO LOOP
7743: *
7744: * LOOP TO PRINT ARGUMENT VALUES
7745: *
7746: BPF12 MOV =CH$CM,WA LOAD COMMA
7747: JSR PRTCH PRINT TO SEPARATE FROM LAST ARG
7748: *
7749: * MERGE HERE FIRST TIME (NO COMMA REQUIRED)
7750: *
7751: BPF13 MOV WB,(XS) SAVE ARG CTR (OVER FAILOFFS IS OK)
7752: WTB WB CONVERT TO BYTE OFFSET
7753: ADD WB,XL POINT TO NEXT ARGUMENT POINTER
7754: MOV PFARG(XL),XR LOAD NEXT ARGUMENT VRBLK PTR
7755: SUB WB,XL RESTORE PFBLK POINTER
7756: MOV VRVAL(XR),XR LOAD NEXT VALUE
7757: JSR PRTVL PRINT ARGUMENT VALUE
7758: EJC
7759: *
7760: * HERE AFTER DEALING WITH ONE ARGUMENT
7761: *
7762: MOV (XS),WB RESTORE ARGUMENT COUNTER
7763: ICV WB INCREMENT ARGUMENT COUNTER
7764: BLT WB,FARGS(XL),BPF12 LOOP IF MORE TO PRINT
7765: *
7766: * MERGE HERE IN NO ARGS CASE TO PRINT PAREN
7767: *
7768: BPF15 MOV =CH$RP,WA LOAD RIGHT PAREN
7769: JSR PRTCH PRINT TO TERMINATE OUTPUT
7770: JSR PRTNL TERMINATE PRINT LINE
7771: *
7772: * MERGE HERE TO EXIT WITH TEST FOR FNCLEVEL TRACE
7773: *
7774: BPF16 ICV KVFNC INCREMENT FNCLEVEL
7775: MOV R$FNC,XL LOAD PTR TO POSSIBLE TRBLK
7776: JSR KTREX CALL KEYWORD TRACE ROUTINE
7777: *
7778: * CALL FUNCTION AFTER TRACE TESTS COMPLETE
7779: *
7780: MOV 1(XS),XL RESTORE PFBLK POINTER
7781: BRN BPF08 JUMP BACK TO EXECUTE FUNCTION
7782: EJC
7783: *
7784: * RCBLK
7785: *
7786: * THE ROUTINE FOR AN RCBLK IS EXECUTED FROM THE GENERATED
7787: * CODE TO LOAD A REAL VALUE ONTO THE STACK.
7788: *
7789: * (XR) POINTER TO RCBLK
7790: *
7791: B$RCL ENT BL$RC ENTRY POINT (RCBLK)
7792: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
7793: EJC
7794: *
7795: * SCBLK
7796: *
7797: * THE ROUTINE FOR AN SCBLK IS EXECUTED FROM THE GENERATED
7798: * CODE TO LOAD A STRING VALUE ONTO THE STACK.
7799: *
7800: * (XR) POINTER TO SCBLK
7801: *
7802: B$SCL ENT BL$SC ENTRY POINT (SCBLK)
7803: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
7804: EJC
7805: *
7806: * TBBLK
7807: *
7808: * THE ROUTINE FOR A TBBLK IS NEVER EXECUTED
7809: *
7810: B$TBT ENT BL$TB ENTRY POINT (TBBLK)
7811: EJC
7812: *
7813: * TEBLK
7814: *
7815: * THE ROUTINE FOR A TEBLK IS NEVER EXECUTED
7816: *
7817: B$TET ENT BL$TE ENTRY POINT (TEBLK)
7818: EJC
7819: *
7820: * VCBLK
7821: *
7822: * THE ROUTINE FOR A VCBLK IS NEVER EXECUTED
7823: *
7824: B$VCT ENT BL$VC ENTRY POINT (VCBLK)
7825: EJC
7826: *
7827: * VRBLK
7828: *
7829: * THE VRBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE.
7830: * THERE ARE SIX ENTRIES FOR VRBLK COVERING VARIOUS CASES
7831: *
7832: B$VR$ ENT BL$$I MARK START OF VRBLK ENTRY POINTS
7833: *
7834: * ENTRY FOR VRGET (TRAPPED CASE). THIS ROUTINE IS CALLED
7835: * FROM THE GENERATED CODE TO LOAD THE VALUE OF A VARIABLE.
7836: * THIS ENTRY POINT IS USED IF AN ACCESS TRACE OR INPUT
7837: * ASSOCIATION IS CURRENTLY ACTIVE.
7838: *
7839: * (XR) POINTER TO VRGET FIELD OF VRBLK
7840: *
7841: B$VRA ENT BL$$I ENTRY POINT
7842: MOV XR,XL COPY NAME BASE (VRGET = 0)
7843: MOV *VRVAL,WA SET NAME OFFSET
7844: JSR ACESS ACCESS VALUE
7845: PPM EXFAL FAIL IF ACCESS FAILS
7846: BRN EXIXR ELSE EXIT WITH RESULT IN XR
7847: EJC
7848: *
7849: * VRBLK (CONTINUED)
7850: *
7851: * ENTRY FOR VRSTO (ERROR CASE. THIS ROUTINE IS CALLED FROM
7852: * THE EXECUTED CODE FOR AN ATTEMPT TO MODIFY THE VALUE
7853: * OF A PROTECTED (PATTERN VALUED) NATURAL VARIABLE.
7854: *
7855: B$VRE ENT ENTRY POINT
7856: ERB 042,ATTEMPT TO CHANGE VALUE OF PROTECTED VARIABLE
7857: EJC
7858: *
7859: * VRBLK (CONTINUED)
7860: *
7861: * ENTRY FOR VRTRA (UNTRAPPED CASE). THIS ROUTINE IS CALLED
7862: * FROM THE EXECUTED CODE TO TRANSFER TO A LABEL.
7863: *
7864: * (XR) POINTER TO VRTRA FIELD OF VRBLK
7865: *
7866: B$VRG ENT ENTRY POINT
7867: MOV VRLBO(XR),XR LOAD CODE POINTER
7868: MOV (XR),XL LOAD ENTRY ADDRESS
7869: BRI XL JUMP TO ROUTINE FOR NEXT CODE WORD
7870: EJC
7871: *
7872: * VRBLK (CONTINUED)
7873: *
7874: * ENTRY FOR VRGET (UNTRAPPED CASE). THIS ROUTINE IS CALLED
7875: * FROM THE GENERATED CODE TO LOAD THE VALUE OF A VARIABLE.
7876: *
7877: * (XR) POINTS TO VRGET FIELD OF VRBLK
7878: *
7879: B$VRL ENT ENTRY POINT
7880: MOV VRVAL(XR),-(XS) LOAD VALUE ONTO STACK (VRGET = 0)
7881: BRN EXITS OBEY NEXT CODE WORD
7882: EJC
7883: *
7884: * VRBLK (CONTINUED)
7885: *
7886: * ENTRY FOR VRSTO (UNTRAPPED CASE). THIS ROUTINE IS CALLED
7887: * FROM THE GENERATED CODE TO STORE THE VALUE OF A VARIABLE.
7888: *
7889: * (XR) POINTER TO VRSTO FIELD OF VRBLK
7890: *
7891: B$VRS ENT ENTRY POINT
7892: MOV (XS),VRVLO(XR) STORE VALUE, LEAVE ON STACK
7893: BRN EXITS OBEY NEXT CODE WORD
7894: EJC
7895: *
7896: * VRBLK (CONTINUED)
7897: *
7898: * VRTRA (TRAPPED CASE). THIS ROUTINE IS CALLED FROM THE
7899: * GENERATED CODE TO TRANSFER TO A LABEL WHEN A LABEL
7900: * TRACE IS CURRENTLY ACTIVE.
7901: *
7902: B$VRT ENT ENTRY POINT
7903: SUB *VRTRA,XR POINT BACK TO START OF VRBLK
7904: MOV XR,XL COPY VRBLK POINTER
7905: MOV *VRVAL,WA SET NAME OFFSET
7906: MOV VRLBL(XL),XR LOAD POINTER TO TRBLK
7907: BZE KVTRA,BVRT2 JUMP IF TRACE IS OFF
7908: DCV KVTRA ELSE DECREMENT TRACE COUNT
7909: BZE TRFNC(XR),BVRT1 JUMP IF PRINT TRACE CASE
7910: JSR TRXEQ ELSE EXECUTE FULL TRACE
7911: BRN BVRT2 MERGE TO JUMP TO LABEL
7912: *
7913: * HERE FOR PRINT TRACE -- PRINT COLON ( LABEL NAME )
7914: *
7915: BVRT1 JSR PRTSN PRINT STATEMENT NUMBER
7916: MOV XL,XR COPY VRBLK POINTER
7917: MOV =CH$CL,WA COLON
7918: JSR PRTCH PRINT IT
7919: MOV =CH$PP,WA LEFT PAREN
7920: JSR PRTCH PRINT IT
7921: JSR PRTVN PRINT LABEL NAME
7922: MOV =CH$RP,WA RIGHT PAREN
7923: JSR PRTCH PRINT IT
7924: JSR PRTNL TERMINATE LINE
7925: MOV VRLBL(XL),XR POINT BACK TO TRBLK
7926: *
7927: * MERGE HERE TO JUMP TO LABEL
7928: *
7929: BVRT2 MOV TRLBL(XR),XR LOAD POINTER TO ACTUAL CODE
7930: BRI (XR) EXECUTE STATEMENT AT LABEL
7931: EJC
7932: *
7933: * VRBLK (CONTINUED)
7934: *
7935: * ENTRY FOR VRSTO (TRAPPED CASE). THIS ROUTINE IS CALLED
7936: * FROM THE GENERATED CODE TO STORE THE VALUE OF A VARIABLE.
7937: * THIS ENTRY IS USED WHEN A VALUE TRACE OR OUTPUT
7938: * ASSOCIATION IS CURRENTLY ACTIVE.
7939: *
7940: * (XR) POINTER TO VRSTO FIELD OF VRBLK
7941: *
7942: B$VRV ENT ENTRY POINT
7943: MOV (XS),WB LOAD VALUE (LEAVE COPY ON STACK)
7944: SUB *VRSTO,XR POINT TO VRBLK
7945: MOV XR,XL COPY VRBLK POINTER
7946: MOV *VRVAL,WA SET OFFSET
7947: JSR ASIGN CALL ASSIGNMENT ROUTINE
7948: PPM EXFAL FAIL IF ASSIGNMENT FAILS
7949: BRN EXITS ELSE RETURN WITH RESULT ON STACK
7950: EJC
7951: *
7952: * XNBLK
7953: *
7954: * THE ROUTINE FOR AN XNBLK IS NEVER EXECUTED
7955: *
7956: B$XNT ENT BL$XN ENTRY POINT (XNBLK)
7957: EJC
7958: *
7959: * XRBLK
7960: *
7961: * THE ROUTINE FOR AN XRBLK IS NEVER EXECUTED
7962: *
7963: B$XRT ENT BL$XR ENTRY POINT (XRBLK)
7964: *
7965: * MARK ENTRY ADDRESS PAST LAST BLOCK ACTION ROUTINE
7966: *
7967: B$YYY ENT BL$$I LAST BLOCK ROUTINE ENTRY POINT
7968: TTL S P I T B O L -- PATTERN MATCHING ROUTINES
7969: *
7970: * THE FOLLOWING SECTION CONSISTS OF THE PATTERN MATCHING
7971: * ROUTINES. ALL PATTERN NODES CONTAIN A POINTER (PCODE)
7972: * TO ONE OF THE ROUTINES IN THIS SECTION (P$XXX).
7973: *
7974: * NOTE THAT THIS SECTION FOLLOWS THE B$XXX ROUTINES TO
7975: * ENABLE A FAST TEST FOR THE PATTERN DATATYPE.
7976: *
7977: P$AAA ENT BL$$I ENTRY TO MARK FIRST PATTERN
7978: *
7979: *
7980: * THE ENTRY CONDITIONS TO THE MATCH ROUTINE ARE AS FOLLOWS
7981: * (SEE O$PMN, O$PMV, O$PMS AND PROCEDURE MATCH).
7982: *
7983: * STACK CONTENTS.
7984: *
7985: * NAME BASE (O$PMN ONLY)
7986: * NAME OFFSET (O$PMN ONLY)
7987: * TYPE (0-O$PMN, 1-O$PMV, 2-O$PMS)
7988: * PMHBS --------------- INITIAL CURSOR (ZERO)
7989: * INITIAL NODE POINTER
7990: * XS ------------------ =NDABO (ANCHORED), =NDUNA (UNANCH)
7991: *
7992: * REGISTER VALUES.
7993: *
7994: * (XS) SET AS SHOWN IN STACK DIAGRAM
7995: * (XR) POINTER TO INITIAL PATTERN NODE
7996: * (WB) INITIAL CURSOR (ZERO)
7997: *
7998: * GLOBAL PATTERN VALUES
7999: *
8000: * R$PMS POINTER TO SUBJECT STRING SCBLK
8001: * PMSSL LENGTH OF SUBJECT STRING IN CHARS
8002: * PMDFL DOT FLAG, INITIALLY ZERO
8003: * PMHBS SET AS SHOWN IN STACK DIAGRAM
8004: *
8005: * CONTROL IS PASSED BY BRANCHING THROUGH THE PCODE
8006: * FIELD OF THE INITIAL PATTERN NODE (BRI (XR)).
8007: EJC
8008: *
8009: * DESCRIPTION OF ALGORITHM
8010: *
8011: * A PATTERN STRUCTURE IS REPRESENTED AS A LINKED GRAPH
8012: * OF NODES WITH THE FOLLOWING STRUCTURE.
8013: *
8014: * +------------------------------------+
8015: * I PCODE I
8016: * +------------------------------------+
8017: * I PTHEN I
8018: * +------------------------------------+
8019: * I PARM1 I
8020: * +------------------------------------+
8021: * I PARM2 I
8022: * +------------------------------------+
8023: *
8024: * PCODE IS A POINTER TO THE ROUTINE WHICH WILL PERFORM
8025: * THE MATCH OF THIS PARTICULAR NODE TYPE.
8026: *
8027: * PTHEN IS A POINTER TO THE SUCCESSOR NODE. I.E. THE NODE
8028: * TO BE MATCHED IF THE ATTEMPT TO MATCH THIS NODE SUCCEEDS.
8029: * IF THIS IS THE LAST NODE OF THE PATTERN PTHEN POINTS
8030: * TO THE DUMMY NODE NDNTH WHICH INITIATES PATTERN EXIT.
8031: *
8032: * PARM1, PARM2 ARE PARAMETERS WHOSE USE VARIES WITH THE
8033: * PARTICULAR NODE. THEY ARE ONLY PRESENT IF REQUIRED.
8034: *
8035: * ALTERNATIVES ARE HANDLED WITH THE SPECIAL ALTERNATIVE
8036: * NODE WHOSE PARAMETER POINTS TO THE NODE TO BE MATCHED
8037: * IF THERE IS A FAILURE ON THE SUCCESSOR PATH.
8038: *
8039: * THE FOLLOWING EXAMPLE ILLUSTRATES THE MANNER IN WHICH
8040: * THE STRUCTURE IS BUILT UP. THE PATTERN IS
8041: *
8042: * (A / B / C) (D / E) WHERE / IS ALTERNATION
8043: *
8044: * IN THE DIAGRAM, THE NODE MARKED + REPRESENTS AN
8045: * ALTERNATIVE NODE AND THE DOTTED LINE FROM A + NODE
8046: * REPRESENTS THE PARAMETER POINTER TO THE ALTERNATIVE.
8047: *
8048: * +---+ +---+ +---+ +---+
8049: * I + I-----I A I-----I + I-----I D I-----
8050: * +---+ +---+ I +---+ +---+
8051: * . I .
8052: * . I .
8053: * +---+ +---+ I +---+
8054: * I + I-----I B I--I I E I-----
8055: * +---+ +---+ I +---+
8056: * . I
8057: * . I
8058: * +---+ I
8059: * I C I------------I
8060: * +---+
8061: EJC
8062: *
8063: * DURING THE MATCH, THE REGISTERS ARE USED AS FOLLOWS.
8064: *
8065: * (XR) POINTS TO THE CURRENT NODE
8066: * (XL) SCRATCH
8067: * (XS) MAIN STACK POINTER
8068: * (WB) CURSOR (NUMBER OF CHARS MATCHED)
8069: * (WA,WC) SCRATCH
8070: *
8071: * TO KEEP TRACK OF ALTERNATIVES, THE MAIN STACK IS USED AS
8072: * A HISTORY STACK AND CONTAINS TWO WORD ENTRIES.
8073: *
8074: * WORD 1 SAVED CURSOR VALUE
8075: * WORD 2 NODE TO MATCH ON FAILURE
8076: *
8077: * WHEN A FAILURE OCCURS, THE MOST RECENT ENTRY ON THIS
8078: * STACK IS POPPED OFF TO RESTORE THE CURSOR AND POINT
8079: * TO THE NODE TO BE MATCHED AS AN ALTERNATIVE. THE ENTRY
8080: * AT THE BOTTOM OF THE STACK POINTS TO THE FOLLOWING
8081: * SPECIAL NODES DEPENDING ON THE SCAN MODE.
8082: *
8083: * ANCHORED MODE THE BOTTOM ENTRY POINTS TO THE
8084: * SPECIAL NODE NDABO WHICH CAUSES AN
8085: * ABORT. THE CURSOR VALUE STORED
8086: * WITH THIS ENTRY IS ALWAYS ZERO.
8087: *
8088: * UNANCHORED MODE THE BOTTOM ENTRY POINTS TO THE
8089: * SPECIAL NODE NDUNA WHICH MOVES THE
8090: * ANCHOR POINT AND RESTARTS THE MATCH
8091: * THE CURSOR SAVED WITH THIS ENTRY
8092: * IS THE NUMBER OF CHARACTERS WHICH
8093: * LIE BEFORE THE INITIAL ANCHOR POINT
8094: * (I.E. THE NUMBER OF ANCHOR MOVES).
8095: * THIS ENTRY IS THREE WORDS LONG AND
8096: * ALSO CONTAINS THE INITIAL PATTERN.
8097: *
8098: * ENTRIES ARE MADE ON THIS HISTORY STACK BY ALTERNATIVE
8099: * NODES AND BY SOME SPECIAL COMPOUD PATTERNS AS DESCRIBED
8100: * LATER ON. THE FOLLOWING GLOBAL LOCATIONS ARE USED DURING
8101: * PATTERN MATCHING.
8102: *
8103: * R$PMS POINTER TO SUBJECT STRING
8104: * PMSSL LENGTH OF SUBJECT STRING
8105: * PMDFL FLAG SET NON-ZERO FOR DOT PATTERNS
8106: * PMHBS BASE PTR FOR CURRENT HISTORY STACK
8107: *
8108: * THE FOLLOWING EXIT POINTS ARE AVAILABLE TO MATCH ROUTINES
8109: *
8110: * SUCCP SUCCESS IN MATCHING CURRENT NODE
8111: * FAILP FAILURE IN MATCHING CURRENT NODE
8112: EJC
8113: *
8114: * COMPOUND PATTERNS
8115: *
8116: * SOME PATTERNS HAVE IMPLICIT ALTERNATIVES AND THEIR
8117: * REPRESENTATION IN THE PATTERN STRUCTURE CONSISTS OF A
8118: * LINKED SET OF NODES AS INDICATED BY THESE DIAGRAMS.
8119: *
8120: * AS BEFORE, THE + REPRESENTS AN ALTERNATIVE NODE AND
8121: * THE DOTTED LINE FROM A + NODE IS THE PARAMETER POINTER
8122: * TO THE ALTERNATIVE PATTERN.
8123: *
8124: * ARB
8125: * ---
8126: *
8127: * +---+ THIS NODE (P$ARB) MATCHES NULL
8128: * I B I----- AND STACKS CURSOR, SUCCESSOR PTR,
8129: * +---+ CURSOR (COPY) AND A PTR TO NDARC.
8130: *
8131: *
8132: *
8133: *
8134: * BAL
8135: * ---
8136: *
8137: * +---+ THE P$BAL NODE SCANS A BALANCED
8138: * I B I----- STRING AND THEN STACKS A POINTER
8139: * +---+ TO ITSELF ON THE HISTORY STACK.
8140: EJC
8141: *
8142: * COMPOUND PATTERN STRUCTURES (CONTINUED)
8143: *
8144: *
8145: * ARBNO
8146: * -----
8147: *
8148: * +---+ THIS ALTERNATIVE NODE MATCHES NULL
8149: * +----I + I----- THE FIRST TIME AND STACKS A POINTER
8150: * I +---+ TO THE ARGUMENT PATTERN X.
8151: * I .
8152: * I .
8153: * I +---+ NODE (P$ABA) TO STACK CURSOR
8154: * I I A I AND HISTORY STACK BASE PTR.
8155: * I +---+
8156: * I I
8157: * I I
8158: * I +---+ THIS IS THE ARGUMENT PATTERN. AS
8159: * I I X I INDICATED, THE SUCCESSOR OF THE
8160: * I +---+ PATTERN IS THE P$ABC NODE
8161: * I I
8162: * I I
8163: * I +---+ THIS NODE (P$ABC) POPS PMHBS,
8164: * +----I C I STACKS OLD PMHBS AND PTR TO NDABD
8165: * +---+ (UNLESS OPTIMISATION HAS OCCURRED)
8166: *
8167: * STRUCTURE AND EXECUTION OF THIS PATTERN RESEMBLE THOSE OF
8168: * RECURSIVE PATTERN MATCHING AND IMMEDIATE ASSIGNMENT.
8169: * THE ALTERNATIVE NODE AT THE HEAD OF THE STRUCTURE MATCHES
8170: * NULL INITIALLY BUT ON SUBSEQUENT FAILURE ENSURES ATTEMPT
8171: * TO MATCH THE ARGUMENT. BEFORE THE ARGUMENT IS MATCHED
8172: * P$ABA STACKS THE CURSOR,PMHBS AND A PTR TO P$ABB. IF
8173: * THE ARGUMENT CANT BE MATCHED , P$ABB REMOVES THIS SPECIAL
8174: * STACK ENTRY AND FAILS.
8175: * IF ARGUMENT IS MATCHED , P$ABC RESTORES THE OUTER PMHBS
8176: * VALUE (SAVED BY P$ABA) . THEN IF THE ARGUMENT HAS LEFT
8177: * ALTERNATIVES ON STACK IT STACKS THE INNER VALUE OF PMHBS
8178: * AND A PTR TO NDABD. IF ARGUMENT LEFT NOTHING ON THE STACK
8179: * IT OPTIMISES BY REMOVING ITEMS STACKED BY P$ABA. FINALLY
8180: * A CHECK IS MADE THAT ARGUMENT MATCHED MORE THAN THE NULL
8181: * STRING (CHECK IS INTENDED TO PREVENT USELESS LOOPING).
8182: * IF SO THE SUCCESSOR IS AGAIN THE ALTERNATIVE NODE AT THE
8183: * HEAD OF THE STRUCTURE , ENSURING A POSSIBLE EXTRA ATTEMPT
8184: * TO MATCH THE ARG IF NECESSARY. IF NOT , THE SUCCESSOR TO
8185: * ALTERNATIVE IS TAKEN SO AS TO TERMINATE THE LOOP. P$ABD
8186: * RESTORES INNER PMHBS PTR AND FAILS , THUS TRYING TO MATCH
8187: * ALTERNATIVES LEFT BY THE ARBNO ARGUMENT.
8188: EJC
8189: *
8190: * COMPOUND PATTERN STRUCTURES (CONTINUED)
8191: *
8192: * BREAKX
8193: * ------
8194: *
8195: * +---+ THIS NODE IS A BREAK NODE FOR
8196: * +----I B I THE ARGUMENT TO BREAKX, IDENTICAL
8197: * I +---+ TO AN ORDINARY BREAK NODE.
8198: * I I
8199: * I I
8200: * I +---+ THIS ALTERNATIVE NODE STACKS A
8201: * I I + I----- POINTER TO THE BREAKX NODE TO
8202: * I +---+ ALLOW FOR SUBSEQUENT FAILURE
8203: * I .
8204: * I .
8205: * I +---+ THIS IS THE BREAKX NODE ITSELF. IT
8206: * +----I X I MATCHES ONE CHARACTER AND THEN
8207: * +---+ PROCEEDS BACK TO THE BREAK NODE.
8208: *
8209: *
8210: *
8211: *
8212: * FENCE
8213: * -----
8214: *
8215: * +---+ THE FENCE NODE MATCHES NULL AND
8216: * I F I----- STACKS A POINTER TO NODE NDABO TO
8217: * +---+ ABORT ON A SUBSEQUENT REMATCH
8218: *
8219: *
8220: *
8221: *
8222: * SUCCEED
8223: * -------
8224: *
8225: * +---+ THE NODE FOR SUCCEED MATCHES NULL
8226: * I S I----- AND STACKS A POINTER TO ITSELF
8227: * +---+ TO REPEAT THE MATCH ON A FAILURE.
8228: EJC
8229: *
8230: * COMPOUND PATTERNS (CONTINUED)
8231: *
8232: * BINARY DOT (PATTERN ASSIGNMENT)
8233: * -------------------------------
8234: *
8235: * +---+ THIS NODE (P$PAA) SAVES THE CURRENT
8236: * I A I CURSOR AND A POINTER TO THE
8237: * +---+ SPECIAL NODE NDPAB ON THE STACK.
8238: * I
8239: * I
8240: * +---+ THIS IS THE STRUCTURE FOR THE
8241: * I X I PATTERN LEFT ARGUMENT OF THE
8242: * +---+ PATTERN ASSIGNMENT CALL.
8243: * I
8244: * I
8245: * +---+ THIS NODE (P$PAC) SAVES THE CURSOR,
8246: * I C I----- A PTR TO ITSELF, THE CURSOR (COPY)
8247: * +---+ AND A PTR TO NDPAD ON THE STACK.
8248: *
8249: *
8250: * THE FUNCTION OF THE MATCH ROUTINE FOR NDPAB (P$PAB)
8251: * IS SIMPLY TO UNSTACK ITSELF AND FAIL BACK ONTO THE STACK.
8252: *
8253: * THE MATCH ROUTINE FOR P$PAC ALSO SETS THE GLOBAL PATTERN
8254: * FLAG PMDFL NON-ZERO TO INDICATE THAT PATTERN ASSIGNMENTS
8255: * MAY HAVE OCCURED IN THE PATTERN MATCH
8256: *
8257: * IF PMDFL IS SET AT THE END OF THE MATCH (SEE P$NTH), THE
8258: * HISTORY STACK IS SCANNED FOR MATCHING NDPAB-NDPAD PAIRS
8259: * AND THE CORRESPONDING PATTERN ASSIGNMENTS ARE EXECUTED.
8260: *
8261: * THE FUNCTION OF THE MATCH ROUTINE FOR NDPAD (P$PAD)
8262: * IS SIMPLY TO REMOVE ITS ENTRY FROM THE STACK AND FAIL.
8263: * THIS INCLUDES REMOVING THE SPECIAL NODE POINTER STORED
8264: * IN ADDITION TO THE STANDARD TWO ENTRIES ON THE STACK.
8265: EJC
8266: *
8267: * COMPOUNT PATTERN STRUCTURES (CONTINUED)
8268: *
8269: * FENCE (FUNCTION)
8270: * ----------------
8271: *
8272: * +---+ THIS NODE (P$FNA) SAVES THE
8273: * I A I CURRENT HISTORY STACK AND A
8274: * +---+ POINTER TO NDFNB ON THE STACK.
8275: * I
8276: * I
8277: * +---+ THIS IS THE PATTERN STRUCTURE
8278: * I X I GIVEN AS THE ARGUMENT TO THE
8279: * +---+ FENCE FUNCTION.
8280: * I
8281: * I
8282: * +---+ THIS NODE P$FNC RESTORES THE OUTER
8283: * I C I HISTORY STACK PTR SAVED IN P$FNA,
8284: * +---+ AND STACKS THE INNER STACK BASE
8285: * PTR AND A POINTER TO NDFND ON THE
8286: * STACK.
8287: *
8288: * NDFNB (F$FNB) SIMPLY IS THE FAILURE EXIT FOR PATTERN
8289: * ARGUMENT FAILURE, AND IT POPS ITSELF AND FAILS ONTO THE
8290: * STACK.
8291: *
8292: * THE MATCH ROUTINE P$FNC ALLOWS FOR AN OPTIMIZATION WHEN
8293: * THE FENCE PATTERN LEAVES NO ALTERNATIVES. IN THIS CASE,
8294: * THE NDFNB ENTRY IS POPPED, AND THE MATCH CONTINUES.
8295: *
8296: * NDFND (P$FND) IS ENTERED WHEN THE PATTERN FAILS AFTER
8297: * GOING THROUGH A NON-OPTIMIZED P$FNC, AND IT POPS THE
8298: * STACK BACK PAST THE INNTER STACK BASE CREATED BY P$FNA
8299: EJC
8300: *
8301: * COMPOUND PATTERNS (CONTINUED)
8302: *
8303: * EXPRESSION PATTERNS (RECURSIVE PATTERN MATCHES)
8304: * -----------------------------------------------
8305: *
8306: * INITIAL ENTRY FOR A PATTERN NODE IS TO THE ROUTINE P$EXA.
8307: * IF THE EVALUATED RESULT OF THE EXPRESSION IS ITSELF A
8308: * PATTERN, THEN THE FOLLOWING STEPS ARE TAKEN TO ARRANGE
8309: * FOR PROPER RECURSIVE PROCESSING.
8310: *
8311: * 1) A POINTER TO THE CURRENT NODE (THE P$EXA NODE) IS
8312: * STORED ON THE HISTORY STACK WITH A DUMMY CURSOR.
8313: *
8314: * 2) A SPECIAL HISTORY STACK ENTRY IS MADE IN WHICH THE
8315: * NODE POINTER POINTS TO NDEXB, AND THE CURSOR VALUE
8316: * IS THE SAVED VALUE OF PMHBS ON ENTRY TO THIS NODE.
8317: * THE MATCH ROUTINE FOR NDEXB (P$EXB) RESTORES PMHBS
8318: * FROM THIS CURSOR ENTRY, POPS OFF THE P$EXA NODE
8319: * POINTER AND FAILS.
8320: *
8321: * 3) THE RESULTING HISTORY STACK POINTER IS SAVED IN
8322: * PMHBS TO ESTABLISH A NEW LEVEL OF HISTORY STACK.
8323: *
8324: * AFTER MATCHING A PATTERN, THE END OF MATCH ROUTINE GETS
8325: * CONTROL (P$NTH). THIS ROUTINE PROCEEDS AS FOLLOWS.
8326: *
8327: * 1) LOAD THE CURRENT VALUE OF PMHBS AND RECOGNIZE THE
8328: * OUTER LEVEL CASE BY THE FACT THAT THE ASSOCIATED
8329: * CURSOR IN THIS CASE IS THE PATTERN MATCH TYPE CODE
8330: * WHICH IS LESS THAN 3. TERMINATE THE MATCH IN THIS
8331: * CASE AND CONTINUE EXECUTION OF THE PROGRAM.
8332: *
8333: * 2) OTHERWISE MAKE A SPECIAL HISTORY STACK ENTRY IN
8334: * WHICH THE NODE POINTER POINTS TO THE SPECIAL NODE
8335: * NDEXC AND THE CURSOR IS THE CURRENT VALUE OF PMHBS.
8336: * THE MATCH ROUTINE FOR NDEXC (P$EXC) RESETS PMHBS TO
8337: * THIS (INNER) VALUE AND AND THEN FAILS.
8338: *
8339: * 3) USING THE HISTORY STACK ENTRY MADE ON STARTING THE
8340: * EXPRESSION (ACCESSIBLE WITH THE CURRENT VALUE OF
8341: * PMHBS), RESTORE THE P$EXA NODE POINTER AND THE OLD
8342: * PMHBS SETTING. TAKE THE SUCCESSOR AND CONTINUE.
8343: *
8344: * AN OPTIMIZATION IS POSSIBLE IF THE EXPRESSION PATTERN
8345: * MAKES NO ENTRIES ON THE HISTORY STACK. IN THIS CASE,
8346: * INSTEAD OF BUILDING THE P$EXC NODE IN STEP 2, IT IS MORE
8347: * EFFICIENT TO SIMPLY POP OFF THE P$EXB ENTRY AND ITS
8348: * ASSOCIATED NODE POINTER. THE EFFECT IS THE SAME.
8349: EJC
8350: *
8351: * COMPOUND PATTERNS (CONTINUED)
8352: *
8353: * BINARY DOLLAR (IMMEDIATE ASSIGNMENT)
8354: * ------------------------------------
8355: *
8356: * +---+ THIS NODE (P$IMA) STACKS THE CURSOR
8357: * I A I PMHBS AND A PTR TO NDIMB AND RESETS
8358: * +---+ THE STACK PTR PMHBS.
8359: * I
8360: * I
8361: * +---+ THIS IS THE LEFT STRUCTURE FOR THE
8362: * I X I PATTERN LEFT ARGUMENT OF THE
8363: * +---+ IMMEDIATE ASSIGNMENT CALL.
8364: * I
8365: * I
8366: * +---+ THIS NODE (P$IMC) PERFORMS THE
8367: * I C I----- ASSIGNMENT, POPS PMHBS AND STACKS
8368: * +---+ THE OLD PMHBS AND A PTR TO NDIMD.
8369: *
8370: *
8371: * THE STRUCTURE AND EXECUTION OF THIS PATTERN ARE SIMILAR
8372: * TO THOSE OF THE RECURSIVE EXPRESSION PATTERN MATCHING.
8373: *
8374: * THE MATCH ROUTINE FOR NDIMB (P$IMB) RESTORES THE OUTER
8375: * LEVEL VALUE OF PMHBS, UNSTACKS THE SAVED CURSOR AND FAILS
8376: *
8377: * THE MATCH ROUTINE P$IMC USES THE CURRENT VALUE OF PMHBS
8378: * TO LOCATE THE P$IMB ENTRY. THIS ENTRY IS USED TO MAKE
8379: * THE ASSIGNMENT AND RESTORE THE OUTER LEVEL VALUE OF
8380: * PMHBS. FINALLY, THE INNER LEVEL VALUE OF PMHBS AND A
8381: * POINTER TO THE SPECIAL NODE NDIMD ARE STACKED.
8382: *
8383: * THE MATCH ROUTINE FOR NDIMD (P$IMD) RESTORES THE INNER
8384: * LEVEL VALUE OF PMHBS AND FAILS BACK INTO THE STACK.
8385: *
8386: * AN OPTIMIZATION OCCURS IF THE INNER PATTERN MAKES NO
8387: * ENTRIES ON THE HISTORY STACK. IN THIS CASE, P$IMC POPS
8388: * THE P$IMB ENTRY INSTEAD OF MAKING A P$IMD ENTRY.
8389: EJC
8390: *
8391: * ARBNO
8392: *
8393: * SEE COMPOUND PATTERNS SECTION FOR STUCTURE AND
8394: * ALGORITHM FOR MATCHING THIS NODE TYPE.
8395: *
8396: * NO PARAMETERS
8397: *
8398: P$ABA ENT BL$P0 P0BLK
8399: MOV WB,-(XS) STACK CURSOR
8400: MOV XR,-(XS) STACK DUMMY NODE PTR
8401: MOV PMHBS,-(XS) STACK OLD STACK BASE PTR
8402: MOV =NDABB,-(XS) STACK PTR TO NODE NDABB
8403: MOV XS,PMHBS STORE NEW STACK BASE PTR
8404: BRN SUCCP SUCCEED
8405: EJC
8406: *
8407: * ARBNO (REMOVE P$ABA SPECIAL STACK ENTRY)
8408: *
8409: * NO PARAMETERS (DUMMY PATTERN)
8410: *
8411: P$ABB ENT ENTRY POINT
8412: MOV WB,PMHBS RESTORE HISTORY STACK BASE PTR
8413: BRN FLPOP FAIL AND POP DUMMY NODE PTR
8414: EJC
8415: *
8416: * ARBNO (CHECK IF ARG MATCHED NULL STRING)
8417: *
8418: * NO PARAMETERS (DUMMY PATTERN)
8419: *
8420: P$ABC ENT BL$P0 P0BLK
8421: MOV PMHBS,XT KEEP P$ABB STACK BASE
8422: MOV 3(XT),WA LOAD INITIAL CURSOR
8423: MOV 1(XT),PMHBS RESTORE OUTER STACK BASE PTR
8424: BEQ XT,XS,PABC1 JUMP IF NO HISTORY STACK ENTRIES
8425: MOV XT,-(XS) ELSE SAVE INNER PMHBS ENTRY
8426: MOV =NDABD,-(XS) STACK PTR TO SPECIAL NODE NDABD
8427: BRN PABC2 MERGE
8428: *
8429: * OPTIMISE CASE OF NO EXTRA ENTRIES ON STACK FROM ARBNO ARG
8430: *
8431: PABC1 ADD *NUM04,XS REMOVE NDABB ENTRY AND CURSOR
8432: *
8433: * MERGE TO CHECK FOR MATCHING OF NULL STRING
8434: *
8435: PABC2 BNE WA,WB,SUCCP ALLOW FURTHER ATTEMPT IF NON-NULL
8436: MOV PTHEN(XR),XR BYPASS ALTERNATIVE NODE SO AS TO ..
8437: BRN SUCCP ... REFUSE FURTHER MATCH ATTEMPTS
8438: EJC
8439: *
8440: * ARBNO (TRY FOR ALTERNATIVES IN ARBNO ARGUMENT)
8441: *
8442: * NO PARAMETERS (DUMMY PATTERN)
8443: *
8444: P$ABD ENT ENTRY POINT
8445: MOV WB,PMHBS RESTORE INNER STACK BASE PTR
8446: BRN FAILP AND FAIL
8447: EJC
8448: *
8449: * ABORT
8450: *
8451: * NO PARAMETERS
8452: *
8453: P$ABO ENT BL$P0 P0BLK
8454: BRN EXFAL SIGNAL STATEMENT FAILURE
8455: EJC
8456: *
8457: * ALTERNATION
8458: *
8459: * PARM1 ALTERNATIVE NODE
8460: *
8461: P$ALT ENT BL$P1 P1BLK
8462: MOV WB,-(XS) STACK CURSOR
8463: MOV PARM1(XR),-(XS) STACK POINTER TO ALTERNATIVE
8464: CHK CHECK FOR STACK OVERFLOW
8465: BRN SUCCP IF ALL OK, THEN SUCCEED
8466: EJC
8467: *
8468: * ANY (ONE CHARACTER ARGUMENT) (1-CHAR STRING ALSO)
8469: *
8470: * PARM1 CHARACTER ARGUMENT
8471: *
8472: P$ANS ENT BL$P1 P1BLK
8473: BEQ WB,PMSSL,FAILP FAIL IF NO CHARS LEFT
8474: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
8475: PLC XL,WB POINT TO CURRENT CHARACTER
8476: LCH WA,(XL) LOAD CURRENT CHARACTER
8477: BNE WA,PARM1(XR),FAILP FAIL IF NO MATCH
8478: ICV WB ELSE BUMP CURSOR
8479: BRN SUCCP AND SUCCEED
8480: EJC
8481: *
8482: * ANY (MULTI-CHARACTER ARGUMENT CASE)
8483: *
8484: * PARM1 POINTER TO CTBLK
8485: * PARM2 BIT MASK TO SELECT BIT IN CTBLK
8486: *
8487: P$ANY ENT BL$P2 P2BLK
8488: *
8489: * EXPRESSION ARGUMENT CASE MERGES HERE
8490: *
8491: PANY1 BEQ WB,PMSSL,FAILP FAIL IF NO CHARACTERS LEFT
8492: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
8493: PLC XL,WB GET CHAR PTR TO CURRENT CHARACTER
8494: LCH WA,(XL) LOAD CURRENT CHARACTER
8495: MOV PARM1(XR),XL POINT TO CTBLK
8496: WTB WA CHANGE TO BYTE OFFSET
8497: ADD WA,XL POINT TO ENTRY IN CTBLK
8498: MOV CTCHS(XL),WA LOAD WORD FROM CTBLK
8499: ANB PARM2(XR),WA AND WITH SELECTED BIT
8500: ZRB WA,FAILP FAIL IF NO MATCH
8501: ICV WB ELSE BUMP CURSOR
8502: BRN SUCCP AND SUCCEED
8503: EJC
8504: *
8505: * ANY (EXPRESSION ARGUMENT)
8506: *
8507: * PARM1 EXPRESSION POINTER
8508: *
8509: P$AYD ENT BL$P1 P1BLK
8510: JSR EVALS EVALUATE STRING ARGUMENT
8511: ERR 043,ANY EVALUATED ARGUMENT IS NOT STRING
8512: PPM FAILP FAIL IF EVALUATION FAILURE
8513: PPM PANY1 MERGE MULTI-CHAR CASE IF OK
8514: EJC
8515: *
8516: * P$ARB INITIAL ARB MATCH
8517: *
8518: * NO PARAMETERS
8519: *
8520: * THE P$ARB NODE IS PART OF A COMPOUND PATTERN STRUCTURE
8521: * FOR AN ARB PATTERN (SEE DESCRIPTION OF COMPOUND PATTERNS)
8522: *
8523: P$ARB ENT BL$P0 P0BLK
8524: MOV PTHEN(XR),XR LOAD SUCCESSOR POINTER
8525: MOV WB,-(XS) STACK DUMMY CURSOR
8526: MOV XR,-(XS) STACK SUCCESSOR POINTER
8527: MOV WB,-(XS) STACK CURSOR
8528: MOV =NDARC,-(XS) STACK PTR TO SPECIAL NODE NDARC
8529: BRI (XR) EXECUTE NEXT NODE MATCHING NULL
8530: EJC
8531: *
8532: * P$ARC EXTEND ARB MATCH
8533: *
8534: * NO PARAMETERS (DUMMY PATTERN)
8535: *
8536: P$ARC ENT ENTRY POINT
8537: BEQ WB,PMSSL,FLPOP FAIL AND POP STACK TO SUCCESSOR
8538: ICV WB ELSE BUMP CURSOR
8539: MOV WB,-(XS) STACK UPDATED CURSOR
8540: MOV XR,-(XS) RESTACK POINTER TO NDARC NODE
8541: MOV 2(XS),XR LOAD SUCCESSOR POINTER
8542: BRI (XR) OFF TO REEXECUTE SUCCESSOR NODE
8543: EJC
8544: *
8545: * BAL
8546: *
8547: * NO PARAMETERS
8548: *
8549: * THE P$BAL NODE IS PART OF THE COMPOUND STRUCTURE BUILT
8550: * FOR BAL (SEE SECTION ON COMPOUND PATTERNS).
8551: *
8552: P$BAL ENT BL$P0 P0BLK
8553: ZER WC ZERO PARENTHESES LEVEL COUNTER
8554: MOV R$PMS,XL POINT TO SUBJECT STRING
8555: PLC XL,WB POINT TO CURRENT CHARACTER
8556: BRN PBAL2 JUMP INTO SCAN LOOP
8557: *
8558: * LOOP TO SCAN OUT CHARACTERS
8559: *
8560: PBAL1 LCH WA,(XL)+ LOAD NEXT CHARACTER, BUMP POINTER
8561: ICV WB PUSH CURSOR FOR CHARACTER
8562: BEQ WA,=CH$PP,PBAL3 JUMP IF LEFT PAREN
8563: BEQ WA,=CH$RP,PBAL4 JUMP IF RIGHT PAREN
8564: BZE WC,PBAL5 ELSE SUCCEED IF AT OUTER LEVEL
8565: *
8566: * HERE AFTER PROCESSING ONE CHARACTER
8567: *
8568: PBAL2 BNE WB,PMSSL,PBAL1 LOOP BACK UNLESS END OF STRING
8569: BRN FAILP IN WHICH CASE, FAIL
8570: *
8571: * HERE ON LEFT PAREN
8572: *
8573: PBAL3 ICV WC BUMP PAREN LEVEL
8574: BRN PBAL2 LOOP BACK TO CHECK END OF STRING
8575: *
8576: * HERE FOR RIGHT PAREN
8577: *
8578: PBAL4 BZE WC,FAILP FAIL IF NO MATCHING LEFT PAREN
8579: DCV WC ELSE DECREMENT LEVEL COUNTER
8580: BNZ WC,PBAL2 LOOP BACK IF NOT AT OUTER LEVEL
8581: *
8582: * HERE AFTER SUCCESSFULLY SCANNING A BALANCED STRING
8583: *
8584: PBAL5 MOV WB,-(XS) STACK CURSOR
8585: MOV XR,-(XS) STACK PTR TO BAL NODE FOR EXTEND
8586: BRN SUCCP AND SUCCEED
8587: EJC
8588: *
8589: * BREAK (EXPRESSION ARGUMENT)
8590: *
8591: * PARM1 EXPRESSION POINTER
8592: *
8593: P$BKD ENT BL$P1 P1BLK
8594: JSR EVALS EVALUATE STRING EXPRESSION
8595: ERR 044,BREAK EVALUATED ARGUMENT IS NOT STRING
8596: PPM FAILP FAIL IF EVALUATION FAILS
8597: PPM PBRK1 MERGE WITH MULTI-CHAR CASE IF OK
8598: EJC
8599: *
8600: * BREAK (ONE CHARACTER ARGUMENT)
8601: *
8602: * PARM1 CHARACTER ARGUMENT
8603: *
8604: P$BKS ENT BL$P1 P1BLK
8605: MOV PMSSL,WC GET SUBJECT STRING LENGTH
8606: SUB WB,WC GET NUMBER OF CHARACTERS LEFT
8607: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT
8608: LCT WC,WC SET COUNTER FOR CHARS LEFT
8609: MOV R$PMS,XL POINT TO SUBJECT STRING
8610: PLC XL,WB POINT TO CURRENT CHARACTER
8611: *
8612: * LOOP TO SCAN TILL BREAK CHARACTER FOUND
8613: *
8614: PBKS1 LCH WA,(XL)+ LOAD NEXT CHAR, BUMP POINTER
8615: BEQ WA,PARM1(XR),SUCCP SUCCEED IF BREAK CHARACTER FOUND
8616: ICV WB ELSE PUSH CURSOR
8617: BCT WC,PBKS1 LOOP BACK IF MORE TO GO
8618: BRN FAILP FAIL IF END OF STRING, NO BREAK CHR
8619: EJC
8620: *
8621: * BREAK (MULTI-CHARACTER ARGUMENT)
8622: *
8623: * PARM1 POINTER TO CTBLK
8624: * PARM2 BIT MASK TO SELECT BIT COLUMN
8625: *
8626: P$BRK ENT BL$P2 P2BLK
8627: *
8628: * EXPRESSION ARGUMENT MERGES HERE
8629: *
8630: PBRK1 MOV PMSSL,WC LOAD SUBJECT STRING LENGTH
8631: SUB WB,WC GET NUMBER OF CHARACTERS LEFT
8632: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT
8633: LCT WC,WC SET COUNTER FOR CHARACTERS LEFT
8634: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
8635: PLC XL,WB POINT TO CURRENT CHARACTER
8636: MOV XR,PSAVE SAVE NODE POINTER
8637: *
8638: * LOOP TO SEARCH FOR BREAK CHARACTER
8639: *
8640: PBRK2 LCH WA,(XL)+ LOAD NEXT CHAR, BUMP POINTER
8641: MOV PARM1(XR),XR LOAD POINTER TO CTBLK
8642: WTB WA CONVERT TO BYTE OFFSET
8643: ADD WA,XR POINT TO CTBLK ENTRY
8644: MOV CTCHS(XR),WA LOAD CTBLK WORD
8645: MOV PSAVE,XR RESTORE NODE POINTER
8646: ANB PARM2(XR),WA AND WITH SELECTED BIT
8647: NZB WA,SUCCP SUCCEED IF BREAK CHARACTER FOUND
8648: ICV WB ELSE PUSH CURSOR
8649: BCT WC,PBRK2 LOOP BACK UNLESS END OF STRING
8650: BRN FAILP FAIL IF END OF STRING, NO BREAK CHR
8651: EJC
8652: *
8653: * BREAKX (EXTENSION)
8654: *
8655: * THIS IS THE ENTRY WHICH CAUSES AN EXTENSION OF A BREAKX
8656: * MATCH WHEN FAILURE OCCURS. SEE SECTION ON COMPOUND
8657: * PATTERNS FOR FULL DETAILS OF BREAKX MATCHING.
8658: *
8659: * NO PARAMETERS
8660: *
8661: P$BKX ENT BL$P0 P0BLK
8662: ICV WB STEP CURSOR PAST PREVIOUS BREAK CHR
8663: BRN SUCCP SUCCEED TO REMATCH BREAK
8664: EJC
8665: *
8666: * BREAKX (EXPRESSION ARGUMENT)
8667: *
8668: * SEE SECTION ON COMPOUND PATTERNS FOR FULL STRUCTURE OF
8669: * BREAKX PATTERN. THE ACTUAL CHARACTER MATCHING USES A
8670: * BREAK NODE. HOWEVER, THE ENTRY FOR THE EXPRESSION
8671: * ARGUMENT CASE IS SEPARATED TO GET PROPER ERROR MESSAGES.
8672: *
8673: * PARM1 EXPRESSION POINTER
8674: *
8675: P$BXD ENT BL$P1 P1BLK
8676: JSR EVALS EVALUATE STRING ARGUMENT
8677: ERR 045,BREAKX EVALUATED ARGUMENT IS NOT STRING
8678: PPM FAILP FAIL IF EVALUATION FAILS
8679: PPM PBRK1 MERGE WITH BREAK IF ALL OK
8680: EJC
8681: *
8682: * CURSOR ASSIGNMENT
8683: *
8684: * PARM1 NAME BASE
8685: * PARM2 NAME OFFSET
8686: *
8687: P$CAS ENT BL$P2 P2BLK
8688: MOV XR,-(XS) SAVE NODE POINTER
8689: MOV WB,-(XS) SAVE CURSOR
8690: MOV PARM1(XR),XL LOAD NAME BASE
8691: MTI WB LOAD CURSOR AS INTEGER
8692: MOV PARM2(XR),WB LOAD NAME OFFSET
8693: JSR ICBLD GET ICBLK FOR CURSOR VALUE
8694: MOV WB,WA MOVE NAME OFFSET
8695: MOV XR,WB MOVE VALUE TO ASSIGN
8696: JSR ASINP PERFORM ASSIGNMENT
8697: PPM FLPOP FAIL ON ASSIGNMENT FAILURE
8698: MOV (XS)+,WB ELSE RESTORE CURSOR
8699: MOV (XS)+,XR RESTORE NODE POINTER
8700: BRN SUCCP AND SUCCEED MATCHING NULL
8701: EJC
8702: *
8703: * EXPRESSION NODE (P$EXA, INITIAL ENTRY)
8704: *
8705: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
8706: * ALGORITHMS FOR HANDLING EXPRESSION NODES.
8707: *
8708: * PARM1 EXPRESSION POINTER
8709: *
8710: P$EXA ENT BL$P1 P1BLK
8711: JSR EVALP EVALUATE EXPRESSION
8712: PPM FAILP FAIL IF EVALUATION FAILS
8713: BLO WA,=P$AAA,PEXA1 JUMP IF RESULT IS NOT A PATTERN
8714: *
8715: * HERE IF RESULT OF EXPRESSION IS A PATTERN
8716: *
8717: MOV WB,-(XS) STACK DUMMY CURSOR
8718: MOV XR,-(XS) STACK PTR TO P$EXA NODE
8719: MOV PMHBS,-(XS) STACK HISTORY STACK BASE PTR
8720: MOV =NDEXB,-(XS) STACK PTR TO SPECIAL NODE NDEXB
8721: MOV XS,PMHBS STORE NEW STACK BASE POINTER
8722: MOV XL,XR COPY NODE POINTER
8723: BRI (XR) MATCH FIRST NODE IN EXPRESSION PAT
8724: *
8725: * HERE IF RESULT OF EXPRESSION IS NOT A PATTERN
8726: *
8727: PEXA1 BEQ WA,=B$SCL,PEXA2 JUMP IF IT IS ALREADY A STRING
8728: MOV XL,-(XS) ELSE STACK RESULT
8729: MOV XR,XL SAVE NODE POINTER
8730: JSR GTSTG CONVERT RESULT TO STRING
8731: ERR 046,EXPRESSION DOES NOT EVALUATE TO PATTERN
8732: MOV XR,WC COPY STRING POINTER
8733: MOV XL,XR RESTORE NODE POINTER
8734: MOV WC,XL COPY STRING POINTER AGAIN
8735: *
8736: * MERGE HERE WITH STRING POINTER IN XL
8737: *
8738: PEXA2 BZE SCLEN(XL),SUCCP JUST SUCCEED IF NULL STRING
8739: BRN PSTR1 ELSE MERGE WITH STRING CIRCUIT
8740: EJC
8741: *
8742: * EXPRESSION NODE (P$EXB, REMOVE NDEXB ENTRY)
8743: *
8744: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
8745: * ALGORITHMS FOR HANDLING EXPRESSION NODES.
8746: *
8747: * NO PARAMETERS (DUMMY PATTERN)
8748: *
8749: P$EXB ENT ENTRY POINT
8750: MOV WB,PMHBS RESTORE OUTER LEVEL STACK POINTER
8751: BRN FLPOP FAIL AND POP P$EXA NODE PTR
8752: EJC
8753: *
8754: * EXPRESSION NODE (P$EXC, REMOVE NDEXC ENTRY)
8755: *
8756: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
8757: * ALGORITHMS FOR HANDLING EXPRESSION NODES.
8758: *
8759: * NO PARAMETERS (DUMMY PATTERN)
8760: *
8761: P$EXC ENT ENTRY POINT
8762: MOV WB,PMHBS RESTORE INNER STACK BASE POINTER
8763: BRN FAILP AND FAIL INTO EXPR PATTERN ALTERNVS
8764: EJC
8765: *
8766: * FAIL
8767: *
8768: * NO PARAMETERS
8769: *
8770: P$FAL ENT BL$P0 P0BLK
8771: BRN FAILP JUST SIGNAL FAILURE
8772: EJC
8773: *
8774: * FENCE
8775: *
8776: * SEE COMPOUND PATTERNS SECTION FOR THE STRUCTURE AND
8777: * ALGORITHM FOR MATCHING THIS NODE TYPE.
8778: *
8779: * NO PARAMETERS
8780: *
8781: P$FEN ENT BL$P0 P0BLK
8782: MOV WB,-(XS) STACK DUMMY CURSOR
8783: MOV =NDABO,-(XS) STACK PTR TO ABORT NODE
8784: BRN SUCCP AND SUCCEED MATCHING NULL
8785: EJC
8786: *
8787: * FENCE (FUNCTION)
8788: *
8789: * SEE COMPOUND PATTERNS COMMENTS AT START OF THIS SECTION
8790: * FOR DETAILS OF SCHEME
8791: *
8792: * NO PARAMETERS
8793: *
8794: P$FNA ENT BL$P0 P0BLK
8795: MOV PMHBS,-(XS) STACK CURRENT HISTORY STACK BASE
8796: MOV =NDFNB,-(XS) STACK INDIR PTR TO P$FNB (FAILURE)
8797: MOV XS,PMHBS BEGIN NEW HISTORY STACK
8798: BRN SUCCP SUCCEED
8799: EJC
8800: *
8801: * FENCE (FUNCTION) (RESET HISTORY STACK AND FAIL)
8802: *
8803: * NO PARAMETERS (DUMMY PATTERN)
8804: *
8805: P$FNB ENT BL$P0 P0BLK
8806: MOV WB,PMHBS RESTORE OUTER PMHBS STACK BASE
8807: BRN FAILP ...AND FAIL
8808: EJC
8809: *
8810: * FENCE (FUNCTION) (MAKE FENCE TRAP ENTRY ON STACK)
8811: *
8812: * NO PARAMETERS (DUMMY PATTERN)
8813: *
8814: P$FNC ENT BL$P0 P0BLK
8815: MOV PMHBS,XT GET INNER STACK BASE PTR
8816: MOV NUM01(XT),PMHBS RESTORE OUTER STACK BASE
8817: BEQ XT,XS,PFNC1 OPTIMIZE IF NO ALTERNATIVES
8818: MOV XT,-(XS) ELSE STACK INNER STACK BASE
8819: MOV =NDFND,-(XS) STACK PTR TO NDFND
8820: BRN SUCCP SUCCEED
8821: *
8822: * HERE WHEN FENCE FUNCTION LEFT NOTHING ON THE STACK
8823: *
8824: PFNC1 ADD *NUM02,XS POP OFF P$FNB ENTRY
8825: BRN SUCCP SUCCEED
8826: EJC
8827: *
8828: * FENCE (FUNCTION) (SKIP PAST ALTERNATIVES ON FAILURE)
8829: *
8830: * NO PARAMETERS (DUMMY PATTERN)
8831: *
8832: P$FND ENT BL$P0 P0BLK
8833: MOV WB,XS POP STACK TO FENCE() HISTORY BASE
8834: BRN FLPOP POP BASE ENTRY AND FAIL
8835: EJC
8836: *
8837: * IMMEDIATE ASSIGNMENT (INITIAL ENTRY, SAVE CURRENT CURSOR)
8838: *
8839: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
8840: * STRUCTURE AND ALGORITHM FOR MATCHING THIS NODE TYPE.
8841: *
8842: * NO PARAMETERS
8843: *
8844: P$IMA ENT BL$P0 P0BLK
8845: MOV WB,-(XS) STACK CURSOR
8846: MOV XR,-(XS) STACK DUMMY NODE POINTER
8847: MOV PMHBS,-(XS) STACK OLD STACK BASE POINTER
8848: MOV =NDIMB,-(XS) STACK PTR TO SPECIAL NODE NDIMB
8849: MOV XS,PMHBS STORE NEW STACK BASE POINTER
8850: BRN SUCCP AND SUCCEED
8851: EJC
8852: *
8853: * IMMEDIATE ASSIGNMENT (REMOVE CURSOR MARK ENTRY)
8854: *
8855: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
8856: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE.
8857: *
8858: * NO PARAMETERS (DUMMY PATTERN)
8859: *
8860: P$IMB ENT ENTRY POINT
8861: MOV WB,PMHBS RESTORE HISTORY STACK BASE PTR
8862: BRN FLPOP FAIL AND POP DUMMY NODE PTR
8863: EJC
8864: *
8865: * IMMEDIATE ASSIGNMENT (PERFORM ACTUAL ASSIGNMENT)
8866: *
8867: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
8868: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE.
8869: *
8870: * PARM1 NAME BASE OF VARIABLE
8871: * PARM2 NAME OFFSET OF VARIABLE
8872: *
8873: P$IMC ENT BL$P2 P2BLK
8874: MOV PMHBS,XT LOAD POINTER TO P$IMB ENTRY
8875: MOV WB,WA COPY FINAL CURSOR
8876: MOV 3(XT),WB LOAD INITIAL CURSOR
8877: MOV 1(XT),PMHBS RESTORE OUTER STACK BASE POINTER
8878: BEQ XT,XS,PIMC1 JUMP IF NO HISTORY STACK ENTRIES
8879: MOV XT,-(XS) ELSE SAVE INNER PMHBS POINTER
8880: MOV =NDIMD,-(XS) AND A PTR TO SPECIAL NODE NDIMD
8881: BRN PIMC2 MERGE
8882: *
8883: * HERE IF NO ENTRIES MADE ON HISTORY STACK
8884: *
8885: PIMC1 ADD *NUM04,XS REMOVE NDIMB ENTRY AND CURSOR
8886: *
8887: * MERGE HERE TO PERFORM ASSIGNMENT
8888: *
8889: PIMC2 MOV WA,-(XS) SAVE CURRENT (FINAL) CURSOR
8890: MOV XR,-(XS) SAVE CURRENT NODE POINTER
8891: MOV R$PMS,XL POINT TO SUBJECT STRING
8892: SUB WB,WA COMPUTE SUBSTRING LENGTH
8893: JSR SBSTR BUILD SUBSTRING
8894: MOV XR,WB MOVE RESULT
8895: MOV (XS),XR RELOAD NODE POINTER
8896: MOV PARM1(XR),XL LOAD NAME BASE
8897: MOV PARM2(XR),WA LOAD NAME OFFSET
8898: JSR ASINP PERFORM ASSIGNMENT
8899: PPM FLPOP FAIL IF ASSIGNMENT FAILS
8900: MOV (XS)+,XR ELSE RESTORE NODE POINTER
8901: MOV (XS)+,WB RESTORE CURSOR
8902: BRN SUCCP AND SUCCEED
8903: EJC
8904: *
8905: * IMMEDIATE ASSIGNMENT (REMOVE NDIMD ENTRY ON FAILURE)
8906: *
8907: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
8908: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE.
8909: *
8910: * NO PARAMETERS (DUMMY PATTERN)
8911: *
8912: P$IMD ENT ENTRY POINT
8913: MOV WB,PMHBS RESTORE INNER STACK BASE POINTER
8914: BRN FAILP AND FAIL
8915: EJC
8916: *
8917: * LEN (INTEGER ARGUMENT)
8918: *
8919: * PARM1 INTEGER ARGUMENT
8920: *
8921: P$LEN ENT BL$P1 P1BLK
8922: *
8923: * EXPRESSION ARGUMENT CASE MERGES HERE
8924: *
8925: PLEN1 ADD PARM1(XR),WB PUSH CURSOR INDICATED AMOUNT
8926: BLE WB,PMSSL,SUCCP SUCCEED IF NOT OFF END
8927: BRN FAILP ELSE FAIL
8928: EJC
8929: *
8930: * LEN (EXPRESSION ARGUMENT)
8931: *
8932: * PARM1 EXPRESSION POINTER
8933: *
8934: P$LND ENT BL$P1 P1BLK
8935: JSR EVALI EVALUATE INTEGER ARGUMENT
8936: ERR 047,LEN EVALUATED ARGUMENT IS NOT INTEGER
8937: ERR 048,LEN EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
8938: PPM FAILP FAIL IF EVALUATION FAILS
8939: PPM PLEN1 MERGE WITH NORMAL CIRCUIT IF OK
8940: EJC
8941: *
8942: * NOTANY (EXPRESSION ARGUMENT)
8943: *
8944: * PARM1 EXPRESSION POINTER
8945: *
8946: P$NAD ENT BL$P1 P1BLK
8947: JSR EVALS EVALUATE STRING ARGUMENT
8948: ERR 049,NOTANY EVALUATED ARGUMENT IS NOT STRING
8949: PPM FAILP FAIL IF EVALUATION FAILS
8950: PPM PNAY1 MERGE WITH MULTI-CHAR CASE IF OK
8951: EJC
8952: *
8953: * NOTANY (ONE CHARACTER ARGUMENT)
8954: *
8955: * PARM1 CHARACTER ARGUMENT
8956: *
8957: P$NAS ENT BL$P1 ENTRY POINT
8958: BEQ WB,PMSSL,FAILP FAIL IF NO CHARS LEFT
8959: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
8960: PLC XL,WB POINT TO CURRENT CHARACTER IN STRIN
8961: LCH WA,(XL) LOAD CURRENT CHARACTER
8962: BEQ WA,PARM1(XR),FAILP FAIL IF MATCH
8963: ICV WB ELSE BUMP CURSOR
8964: BRN SUCCP AND SUCCEED
8965: EJC
8966: *
8967: * NOTANY (MULTI-CHARACTER STRING ARGUMENT)
8968: *
8969: * PARM1 POINTER TO CTBLK
8970: * PARM2 BIT MASK TO SELECT BIT COLUMN
8971: *
8972: P$NAY ENT BL$P2 P2BLK
8973: *
8974: * EXPRESSION ARGUMENT CASE MERGES HERE
8975: *
8976: PNAY1 BEQ WB,PMSSL,FAILP FAIL IF NO CHARACTERS LEFT
8977: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
8978: PLC XL,WB POINT TO CURRENT CHARACTER
8979: LCH WA,(XL) LOAD CURRENT CHARACTER
8980: WTB WA CONVERT TO BYTE OFFSET
8981: MOV PARM1(XR),XL LOAD POINTER TO CTBLK
8982: ADD WA,XL POINT TO ENTRY IN CTBLK
8983: MOV CTCHS(XL),WA LOAD ENTRY FROM CTBLK
8984: ANB PARM2(XR),WA AND WITH SELECTED BIT
8985: NZB WA,FAILP FAIL IF CHARACTER IS MATCHED
8986: ICV WB ELSE BUMP CURSOR
8987: BRN SUCCP AND SUCCEED
8988: EJC
8989: *
8990: * END OF PATTERN MATCH
8991: *
8992: * THIS ROUTINE IS ENTERED ON SUCCESSFUL COMPLETION.
8993: * SEE DESCRIPTION OF EXPRESSION PATTERNS IN COMPOUND
8994: * PATTERN SECTION FOR HANDLING OF RECURSION IN MATCHING.
8995: *
8996: * NO PARAMETERS (DUMMY PATTERN)
8997: *
8998: P$NTH ENT ENTRY POINT
8999: MOV PMHBS,XT LOAD POINTER TO BASE OF STACK
9000: MOV 1(XT),WA LOAD SAVED PMHBS (OR PATTERN TYPE)
9001: BLE WA,=NUM02,PNTH2 JUMP IF OUTER LEVEL (PATTERN TYPE)
9002: *
9003: * HERE WE ARE AT THE END OF MATCHING AN EXPRESSION PATTERN
9004: *
9005: MOV WA,PMHBS RESTORE OUTER STACK BASE POINTER
9006: MOV 2(XT),XR RESTORE POINTER TO P$EXA NODE
9007: BEQ XT,XS,PNTH1 JUMP IF NO HISTORY STACK ENTRIES
9008: MOV XT,-(XS) ELSE STACK INNER STACK BASE PTR
9009: MOV =NDEXC,-(XS) STACK PTR TO SPECIAL NODE NDEXC
9010: BRN SUCCP AND SUCCEED
9011: *
9012: * HERE IF NO HISTORY STACK ENTRIES DURING PATTERN
9013: *
9014: PNTH1 ADD *NUM04,XS REMOVE P$EXB ENTRY AND NODE PTR
9015: BRN SUCCP AND SUCCEED
9016: *
9017: * HERE IF END OF MATCH AT OUTER LEVEL
9018: *
9019: PNTH2 MOV WB,PMSSL SAVE FINAL CURSOR IN SAFE PLACE
9020: BZE PMDFL,PNTH6 JUMP IF NO PATTERN ASSIGNMENTS
9021: EJC
9022: *
9023: * END OF PATTERN MATCH (CONTINUED)
9024: *
9025: * NOW WE MUST PERFORM PATTERN ASSIGNMENTS. THIS IS DONE BY
9026: * SCANNING THE HISTORY STACK FOR MATCHING NDPAB-NDPAD PAIRS
9027: *
9028: PNTH3 DCA XT POINT PAST CURSOR ENTRY
9029: MOV -(XT),WA LOAD NODE POINTER
9030: BEQ WA,=NDPAD,PNTH4 JUMP IF NDPAD ENTRY
9031: BNE WA,=NDPAB,PNTH5 JUMP IF NOT NDPAB ENTRY
9032: *
9033: * HERE FOR NDPAB ENTRY, STACK INITIAL CURSOR
9034: * NOTE THAT THERE MUST BE MORE ENTRIES ON THE STACK.
9035: *
9036: MOV 1(XT),-(XS) STACK INITIAL CURSOR
9037: CHK CHECK FOR STACK OVERFLOW
9038: BRN PNTH3 LOOP BACK IF OK
9039: *
9040: * HERE FOR NDPAD ENTRY. THE STARTING CURSOR FROM THE
9041: * MATCHING NDPAD ENTRY IS NOW THE TOP STACK ENTRY.
9042: *
9043: PNTH4 MOV 1(XT),WA LOAD FINAL CURSOR
9044: MOV (XS),WB LOAD INITIAL CURSOR FROM STACK
9045: MOV XT,(XS) SAVE HISTORY STACK SCAN PTR
9046: SUB WB,WA COMPUTE LENGTH OF STRING
9047: *
9048: * BUILD SUBSTRING AND PERFORM ASSIGNMENT
9049: *
9050: MOV R$PMS,XL POINT TO SUBJECT STRING
9051: JSR SBSTR CONSTRUCT SUBSTRING
9052: MOV XR,WB COPY SUBSTRING POINTER
9053: MOV (XS),XT RELOAD HISTORY STACK SCAN PTR
9054: MOV 2(XT),XL LOAD POINTER TO P$PAC NODE WITH NAM
9055: MOV PARM2(XL),WA LOAD NAME OFFSET
9056: MOV PARM1(XL),XL LOAD NAME BASE
9057: JSR ASINP PERFORM ASSIGNMENT
9058: PPM EXFAL MATCH FAILS IF NAME EVAL FAILS
9059: MOV (XS)+,XT ELSE RESTORE HISTORY STACK PTR
9060: EJC
9061: *
9062: * END OF PATTERN MATCH (CONTINUED)
9063: *
9064: * HERE CHECK FOR END OF ENTRIES
9065: *
9066: PNTH5 BNE XT,XS,PNTH3 LOOP IF MORE ENTRIES TO SCAN
9067: *
9068: * HERE AFTER DEALING WITH PATTERN ASSIGNMENTS
9069: *
9070: PNTH6 MOV PMHBS,XS WIPE OUT HISTORY STACK
9071: MOV (XS)+,WB LOAD INITIAL CURSOR
9072: MOV (XS)+,WC LOAD MATCH TYPE CODE
9073: MOV PMSSL,WA LOAD FINAL CURSOR VALUE
9074: MOV R$PMS,XL POINT TO SUBJECT STRING
9075: ZER R$PMS CLEAR SUBJECT STRING PTR FOR GBCOL
9076: BZE WC,PNTH7 JUMP IF CALL BY NAME
9077: BEQ WC,=NUM02,EXITS EXIT IF STATEMENT LEVEL CALL
9078: *
9079: * HERE WE HAVE A CALL BY VALUE, BUILD SUBSTRING
9080: *
9081: SUB WB,WA COMPUTE LENGTH OF STRING
9082: JSR SBSTR BUILD SUBSTRING
9083: BRN EXIXR AND EXIT WITH SUBSTRING VALUE
9084: *
9085: * HERE FOR CALL BY NAME, MAKE STACK ENTRIES FOR O$RPL
9086: *
9087: PNTH7 MOV WB,-(XS) STACK INITIAL CURSOR
9088: MOV WA,-(XS) STACK FINAL CURSOR
9089: BZE R$PMB,PNTH8 SKIP IF SUBJECT NOT BUFFER
9090: MOV R$PMB,XL ELSE GET PTR TO BCBLK INSTEAD
9091: *
9092: * HERE WITH XL POINTING TO SCBLK OR BCBLK
9093: *
9094: PNTH8 MOV XL,-(XS) STACK SUBJECT POINTER
9095: BRN EXITS EXIT WITH SPECIAL ENTRY ON STACK
9096: EJC
9097: *
9098: * POS (INTEGER ARGUMENT)
9099: *
9100: * PARM1 INTEGER ARGUMENT
9101: *
9102: P$POS ENT BL$P1 P1BLK
9103: *
9104: * EXPRESSION ARGUMENT CASE MERGES HERE
9105: *
9106: PPOS1 BEQ WB,PARM1(XR),SUCCP SUCCEED IF AT RIGHT LOCATION
9107: BRN FAILP ELSE FAIL
9108: EJC
9109: *
9110: * POS (EXPRESSION ARGUMENT)
9111: *
9112: * PARM1 EXPRESSION POINTER
9113: *
9114: P$PSD ENT BL$P1 P1BLK
9115: JSR EVALI EVALUATE INTEGER ARGUMENT
9116: ERR 050,POS EVALUATED ARGUMENT IS NOT INTEGER
9117: ERR 051,POS EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
9118: PPM FAILP FAIL IF EVALUATION FAILS
9119: PPM PPOS1 MERGE WITH NORMAL CASE IF OK
9120: EJC
9121: *
9122: * PATTERN ASSIGNMENT (INITIAL ENTRY, SAVE CURSOR)
9123: *
9124: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9125: * ALGORITHMS FOR MATCHING THIS NODE TYPE.
9126: *
9127: * NO PARAMETERS
9128: *
9129: P$PAA ENT BL$P0 P0BLK
9130: MOV WB,-(XS) STACK INITIAL CURSOR
9131: MOV =NDPAB,-(XS) STACK PTR TO NDPAB SPECIAL NODE
9132: BRN SUCCP AND SUCCEED MATCHING NULL
9133: EJC
9134: *
9135: * PATTERN ASSIGNMENT (REMOVE SAVED CURSOR)
9136: *
9137: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9138: * ALGORITHMS FOR MATCHING THIS NODE TYPE.
9139: *
9140: * NO PARAMETERS (DUMMY PATTERN)
9141: *
9142: P$PAB ENT ENTRY POINT
9143: BRN FAILP JUST FAIL (ENTRY IS ALREADY POPPED)
9144: EJC
9145: *
9146: * PATTERN ASSIGNMENT (END OF MATCH, MAKE ASSIGN ENTRY)
9147: *
9148: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9149: * ALGORITHMS FOR MATCHING THIS NODE TYPE.
9150: *
9151: * PARM1 NAME BASE OF VARIABLE
9152: * PARM2 NAME OFFSET OF VARIABLE
9153: *
9154: P$PAC ENT BL$P2 P2BLK
9155: MOV WB,-(XS) STACK DUMMY CURSOR VALUE
9156: MOV XR,-(XS) STACK POINTER TO P$PAC NODE
9157: MOV WB,-(XS) STACK FINAL CURSOR
9158: MOV =NDPAD,-(XS) STACK PTR TO SPECIAL NDPAD NODE
9159: MNZ PMDFL SET DOT FLAG NON-ZERO
9160: BRN SUCCP AND SUCCEED
9161: EJC
9162: *
9163: * PATTERN ASSIGNMENT (REMOVE ASSIGN ENTRY)
9164: *
9165: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9166: * ALGORITHMS FOR MATCHING THIS NODE TYPE.
9167: *
9168: * NO PARAMETERS (DUMMY NODE)
9169: *
9170: P$PAD ENT ENTRY POINT
9171: BRN FLPOP FAIL AND REMOVE P$PAC NODE
9172: EJC
9173: *
9174: * REM
9175: *
9176: * NO PARAMETERS
9177: *
9178: P$REM ENT BL$P0 P0BLK
9179: MOV PMSSL,WB POINT CURSOR TO END OF STRING
9180: BRN SUCCP AND SUCCEED
9181: EJC
9182: *
9183: * RPOS (EXPRESSION ARGUMENT)
9184: *
9185: * PARM1 EXPRESSION POINTER
9186: *
9187: P$RPD ENT BL$P1 P1BLK
9188: JSR EVALI EVALUATE INTEGER ARGUMENT
9189: ERR 052,RPOS EVALUATED ARGUMENT IS NOT INTEGER
9190: ERR 053,RPOS EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
9191: PPM FAILP FAIL IF EVALUATION FAILS
9192: PPM PRPS1 MERGE WITH NORMAL CASE IF OK
9193: EJC
9194: *
9195: * RPOS (INTEGER ARGUMENT)
9196: *
9197: * PARM1 INTEGER ARGUMENT
9198: *
9199: P$RPS ENT BL$P1 P1BLK
9200: *
9201: * EXPRESSION ARGUMENT CASE MERGES HERE
9202: *
9203: PRPS1 MOV PMSSL,WC GET LENGTH OF STRING
9204: SUB WB,WC GET NUMBER OF CHARACTERS REMAINING
9205: BEQ WC,PARM1(XR),SUCCP SUCCEED IF AT RIGHT LOCATION
9206: BRN FAILP ELSE FAIL
9207: EJC
9208: *
9209: * RTAB (INTEGER ARGUMENT)
9210: *
9211: * PARM1 INTEGER ARGUMENT
9212: *
9213: P$RTB ENT BL$P1 P1BLK
9214: *
9215: * EXPRESSION ARGUMENT CASE MERGES HERE
9216: *
9217: PRTB1 MOV WB,WC SAVE INITIAL CURSOR
9218: MOV PMSSL,WB POINT TO END OF STRING
9219: BLT WB,PARM1(XR),FAILP FAIL IF STRING NOT LONG ENOUGH
9220: SUB PARM1(XR),WB ELSE SET NEW CURSOR
9221: BGE WB,WC,SUCCP AND SUCCEED IF NOT TOO FAR ALREADY
9222: BRN FAILP IN WHICH CASE, FAIL
9223: EJC
9224: *
9225: * RTAB (EXPRESSION ARGUMENT)
9226: *
9227: * PARM1 EXPRESSION POINTER
9228: *
9229: P$RTD ENT BL$P1 P1BLK
9230: JSR EVALI EVALUATE INTEGER ARGUMENT
9231: ERR 054,RTAB EVALUATED ARGUMENT IS NOT INTEGER
9232: ERR 055,RTAB EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
9233: PPM FAILP FAIL IF EVALUATION FAILS
9234: PPM PRTB1 MERGE WITH NORMAL CASE IF SUCCESS
9235: EJC
9236: *
9237: * SPAN (EXPRESSION ARGUMENT)
9238: *
9239: * PARM1 EXPRESSION POINTER
9240: *
9241: P$SPD ENT BL$P1 P1BLK
9242: JSR EVALS EVALUATE STRING ARGUMENT
9243: ERR 056,SPAN EVALUATED ARGUMENT IS NOT STRING
9244: PPM FAILP FAIL IF EVALUATION FAILS
9245: PPM PSPN1 MERGE WITH MULTI-CHAR CASE IF OK
9246: EJC
9247: *
9248: * SPAN (MULTI-CHARACTER ARGUMENT CASE)
9249: *
9250: * PARM1 POINTER TO CTBLK
9251: * PARM2 BIT MASK TO SELECT BIT COLUMN
9252: *
9253: P$SPN ENT BL$P2 P2BLK
9254: *
9255: * EXPRESSION ARGUMENT CASE MERGES HERE
9256: *
9257: PSPN1 MOV PMSSL,WC COPY SUBJECT STRING LENGTH
9258: SUB WB,WC CALCULATE NUMBER OF CHARACTERS LEFT
9259: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT
9260: MOV R$PMS,XL POINT TO SUBJECT STRING
9261: PLC XL,WB POINT TO CURRENT CHARACTER
9262: MOV WB,PSAVC SAVE INITIAL CURSOR
9263: MOV XR,PSAVE SAVE NODE POINTER
9264: LCT WC,WC SET COUNTER FOR CHARS LEFT
9265: *
9266: * LOOP TO SCAN MATCHING CHARACTERS
9267: *
9268: PSPN2 LCH WA,(XL)+ LOAD NEXT CHARACTER, BUMP POINTER
9269: WTB WA CONVERT TO BYTE OFFSET
9270: MOV PARM1(XR),XR POINT TO CTBLK
9271: ADD WA,XR POINT TO CTBLK ENTRY
9272: MOV CTCHS(XR),WA LOAD CTBLK ENTRY
9273: MOV PSAVE,XR RESTORE NODE POINTER
9274: ANB PARM2(XR),WA AND WITH SELECTED BIT
9275: ZRB WA,PSPN3 JUMP IF NO MATCH
9276: ICV WB ELSE PUSH CURSOR
9277: BCT WC,PSPN2 LOOP BACK UNLESS END OF STRING
9278: *
9279: * HERE AFTER SCANNING MATCHING CHARACTERS
9280: *
9281: PSPN3 BNE WB,PSAVC,SUCCP SUCCEED IF CHARS MATCHED
9282: BRN FAILP ELSE FAIL IF NULL STRING MATCHED
9283: EJC
9284: *
9285: * SPAN (ONE CHARACTER ARGUMENT)
9286: *
9287: * PARM1 CHARACTER ARGUMENT
9288: *
9289: P$SPS ENT BL$P1 P1BLK
9290: MOV PMSSL,WC GET SUBJECT STRING LENGTH
9291: SUB WB,WC CALCULATE NUMBER OF CHARACTERS LEFT
9292: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT
9293: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
9294: PLC XL,WB POINT TO CURRENT CHARACTER
9295: MOV WB,PSAVC SAVE INITIAL CURSOR
9296: LCT WC,WC SET COUNTER FOR CHARACTERS LEFT
9297: *
9298: * LOOP TO SCAN MATCHING CHARACTERS
9299: *
9300: PSPS1 LCH WA,(XL)+ LOAD NEXT CHARACTER, BUMP POINTER
9301: BNE WA,PARM1(XR),PSPS2 JUMP IF NO MATCH
9302: ICV WB ELSE PUSH CURSOR
9303: BCT WC,PSPS1 AND LOOP UNLESS END OF STRING
9304: *
9305: * HERE AFTER SCANNING MATCHING CHARACTERS
9306: *
9307: PSPS2 BNE WB,PSAVC,SUCCP SUCCEED IF CHARS MATCHED
9308: BRN FAILP FAIL IF NULL STRING MATCHED
9309: EJC
9310: *
9311: * MULTI-CHARACTER STRING
9312: *
9313: * NOTE THAT ONE CHARACTER STRINGS USE THE CIRCUIT FOR
9314: * ONE CHARACTER ANY ARGUMENTS (P$AN1).
9315: *
9316: * PARM1 POINTER TO SCBLK FOR STRING ARG
9317: *
9318: P$STR ENT BL$P1 P1BLK
9319: MOV PARM1(XR),XL GET POINTER TO STRING
9320: *
9321: * MERGE HERE AFTER EVALUATING EXPRESSION WITH STRING VALUE
9322: *
9323: PSTR1 MOV XR,PSAVE SAVE NODE POINTER
9324: MOV R$PMS,XR LOAD SUBJECT STRING POINTER
9325: PLC XR,WB POINT TO CURRENT CHARACTER
9326: ADD SCLEN(XL),WB COMPUTE NEW CURSOR POSITION
9327: BGT WB,PMSSL,FAILP FAIL IF PAST END OF STRING
9328: MOV WB,PSAVC SAVE UPDATED CURSOR
9329: MOV SCLEN(XL),WA GET NUMBER OF CHARS TO COMPARE
9330: PLC XL POINT TO CHARS OF TEST STRING
9331: CMC FAILP,FAILP COMPARE, FAIL IF NOT EQUAL
9332: MOV PSAVE,XR IF ALL MATCHED, RESTORE NODE PTR
9333: MOV PSAVC,WB RESTORE UPDATED CURSOR
9334: BRN SUCCP AND SUCCEED
9335: EJC
9336: *
9337: * SUCCEED
9338: *
9339: * SEE SECTION ON COMPOUND PATTERNS FOR DETAILS OF THE
9340: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE
9341: *
9342: * NO PARAMETERS
9343: *
9344: P$SUC ENT BL$P0 P0BLK
9345: MOV WB,-(XS) STACK CURSOR
9346: MOV XR,-(XS) STACK POINTER TO THIS NODE
9347: BRN SUCCP SUCCEED MATCHING NULL
9348: EJC
9349: *
9350: * TAB (INTEGER ARGUMENT)
9351: *
9352: * PARM1 INTEGER ARGUMENT
9353: *
9354: P$TAB ENT BL$P1 P1BLK
9355: *
9356: * EXPRESSION ARGUMENT CASE MERGES HERE
9357: *
9358: PTAB1 BGT WB,PARM1(XR),FAILP FAIL IF TOO FAR ALREADY
9359: MOV PARM1(XR),WB ELSE SET NEW CURSOR POSITION
9360: BLE WB,PMSSL,SUCCP SUCCEED IF NOT OFF END
9361: BRN FAILP ELSE FAIL
9362: EJC
9363: *
9364: * TAB (EXPRESSION ARGUMENT)
9365: *
9366: * PARM1 EXPRESSION POINTER
9367: *
9368: P$TBD ENT BL$P1 P1BLK
9369: JSR EVALI EVALUATE INTEGER ARGUMENT
9370: ERR 057,TAB EVALUATED ARGUMENT IS NOT INTEGER
9371: ERR 058,TAB EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
9372: PPM FAILP FAIL IF EVALUATION FAILS
9373: PPM PTAB1 MERGE WITH NORMAL CASE IF OK
9374: EJC
9375: *
9376: * ANCHOR MOVEMENT
9377: *
9378: * NO PARAMETERS (DUMMY NODE)
9379: *
9380: P$UNA ENT ENTRY POINT
9381: MOV WB,XR COPY INITIAL PATTERN NODE POINTER
9382: MOV (XS),WB GET INITIAL CURSOR
9383: BEQ WB,PMSSL,EXFAL MATCH FAILS IF AT END OF STRING
9384: ICV WB ELSE INCREMENT CURSOR
9385: MOV WB,(XS) STORE INCREMENTED CURSOR
9386: MOV XR,-(XS) RESTACK INITIAL NODE PTR
9387: MOV =NDUNA,-(XS) RESTACK UNANCHORED NODE
9388: BRI (XR) REMATCH FIRST NODE
9389: EJC
9390: *
9391: * END OF PATTERN MATCH ROUTINES
9392: *
9393: * THE FOLLOWING ENTRY POINT MARKS THE END OF THE PATTERN
9394: * MATCHING ROUTINES AND ALSO THE END OF THE ENTRY POINTS
9395: * REFERENCED FROM THE FIRST WORD OF BLOCKS IN DYNAMIC STORE
9396: *
9397: P$YYY ENT BL$$I MARK LAST ENTRY IN PATTERN SECTION
9398: TTL S P I T B O L -- PREDEFINED SNOBOL4 FUNCTIONS
9399: *
9400: * THE FOLLOWING SECTION CONTAINS CODING FOR FUNCTIONS
9401: * WHICH ARE PREDEFINED AND AVAILABLE AT THE SNOBOL LEVEL.
9402: *
9403: * THESE ROUTINES RECEIVE CONTROL DIRECTLY FROM THE CODE OR
9404: * INDIRECTLY THROUGH THE O$FNC, O$FNS OR CFUNC ROUTINES.
9405: * IN BOTH CASES THE CONDITIONS ON ENTRY ARE AS FOLLOWS
9406: *
9407: * THE ARGUMENTS ARE ON THE STACK. THE NUMBER OF ARGUMENTS
9408: * HAS BEEN ADJUSTED TO CORRESPOND TO THE SVBLK SVNAR FIELD.
9409: *
9410: * IN CERTAIN FUNCTIONS THE DIRECT CALL IS NOT PERMITTED
9411: * AND IN THESE INSTANCES WE ALSO HAVE.
9412: *
9413: * (WA) ACTUAL NUMBER OF ARGUMENTS IN CALL
9414: *
9415: * CONTROL RETURNS BY PLACING THE FUNCTION RESULT VALUE ON
9416: * ON THE STACK AND CONTINUING EXECUTION WITH THE NEXT
9417: * WORD FROM THE GENERATED CODE.
9418: *
9419: * THE NAMES OF THE ENTRY POINTS OF THESE FUNCTIONS ARE OF
9420: * THE FORM S$XXX WHERE XXX IS THE THREE LETTER CODE FOR
9421: * THE SYSTEM VARIABLE NAME. THE FUNCTIONS ARE IN ORDER
9422: * ALPHABETICALLY BY THEIR ENTRY NAMES.
9423: EJC
9424: *
9425: * ANY
9426: *
9427: S$ANY ENT ENTRY POINT
9428: MOV =P$ANS,WB SET PCODE FOR SINGLE CHAR CASE
9429: MOV =P$ANY,XL PCODE FOR MULTI-CHAR CASE
9430: MOV =P$AYD,WC PCODE FOR EXPRESSION CASE
9431: JSR PATST CALL COMMON ROUTINE TO BUILD NODE
9432: ERR 059,ANY ARGUMENT IS NOT STRING OR EXPRESSION
9433: BRN EXIXR JUMP FOR NEXT CODE WORD
9434: EJC
9435: *
9436: * APPEND
9437: *
9438: S$APN ENT ENTRY POINT
9439: MOV (XS)+,XL GET APPEND ARGUMENT
9440: MOV (XS)+,XR GET BCBLK
9441: BEQ (XR),=B$BCT,SAPN1 OK IF FIRST ARG IS BCBLK
9442: ERB 275,APPEND FIRST ARGUMENT IS NOT BUFFER
9443: *
9444: * HERE TO DO THE APPEND
9445: *
9446: SAPN1 JSR APNDB DO THE APPEND
9447: ERR 276,APPEND SECOND ARGUMENT IS NOT STRING
9448: PPM EXFAL NO ROOM - FAIL
9449: BRN EXNUL EXIT WITH NULL RESULT
9450: EJC
9451: *
9452: * APPLY
9453: *
9454: * APPLY DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT
9455: * WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED.
9456: *
9457: S$APP ENT ENTRY POINT
9458: BZE WA,SAPP3 JUMP IF NO ARGUMENTS
9459: DCV WA ELSE GET APPLIED FUNC ARG COUNT
9460: MOV WA,WB COPY
9461: WTB WB CONVERT TO BYTES
9462: MOV XS,XT COPY STACK POINTER
9463: ADD WB,XT POINT TO FUNCTION ARGUMENT ON STACK
9464: MOV (XT),XR LOAD FUNCTION PTR (APPLY 1ST ARG)
9465: BZE WA,SAPP2 JUMP IF NO ARGS FOR APPLIED FUNC
9466: LCT WB,WA ELSE SET COUNTER FOR LOOP
9467: *
9468: * LOOP TO MOVE ARGUMENTS UP ON STACK
9469: *
9470: SAPP1 DCA XT POINT TO NEXT ARGUMENT
9471: MOV (XT),1(XT) MOVE ARGUMENT UP
9472: BCT WB,SAPP1 LOOP TILL ALL MOVED
9473: *
9474: * MERGE HERE TO CALL FUNCTION (WA = NUMBER OF ARGUMENTS)
9475: *
9476: SAPP2 ICA XS ADJUST STACK PTR FOR APPLY 1ST ARG
9477: JSR GTNVR GET VARIABLE BLOCK ADDR FOR FUNC
9478: PPM SAPP3 JUMP IF NOT NATURAL VARIABLE
9479: MOV VRFNC(XR),XL ELSE POINT TO FUNCTION BLOCK
9480: BRN CFUNC GO CALL APPLIED FUNCTION
9481: *
9482: * HERE FOR INVALID FIRST ARGUMENT
9483: *
9484: SAPP3 ERB 060,APPLY FIRST ARG IS NOT NATURAL VARIABLE NAME
9485: EJC
9486: *
9487: * ARBNO
9488: *
9489: * ARBNO BUILDS A COMPOUND PATTERN. SEE DESCRIPTION AT
9490: * START OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED.
9491: *
9492: S$ABN ENT ENTRY POINT
9493: ZER XR SET PARM1 = 0 FOR THE MOMENT
9494: MOV =P$ALT,WB SET PCODE FOR ALTERNATIVE NODE
9495: JSR PBILD BUILD ALTERNATIVE NODE
9496: MOV XR,XL SAVE PTR TO ALTERNATIVE PATTERN
9497: MOV =P$ABC,WB PCODE FOR P$ABC
9498: ZER XR P0BLK
9499: JSR PBILD BUILD P$ABC NODE
9500: MOV XL,PTHEN(XR) PUT ALTERNATIVE NODE AS SUCCESSOR
9501: MOV XL,WA REMEMBER ALTERNATIVE NODE POINTER
9502: MOV XR,XL COPY P$ABC NODE PTR
9503: MOV (XS),XR LOAD ARBNO ARGUMENT
9504: MOV WA,(XS) STACK ALTERNATIVE NODE POINTER
9505: JSR GTPAT GET ARBNO ARGUMENT AS PATTERN
9506: ERR 061,ARBNO ARGUMENT IS NOT PATTERN
9507: JSR PCONC CONCAT ARG WITH P$ABC NODE
9508: MOV XR,XL REMEMBER PTR TO CONCD PATTERNS
9509: MOV =P$ABA,WB PCODE FOR P$ABA
9510: ZER XR P0BLK
9511: JSR PBILD BUILD P$ABA NODE
9512: MOV XL,PTHEN(XR) CONCATENATE NODES
9513: MOV (XS),XL RECALL PTR TO ALTERNATIVE NODE
9514: MOV XR,PARM1(XL) POINT ALTERNATIVE BACK TO ARGUMENT
9515: BRN EXITS JUMP FOR NEXT CODE WORD
9516: EJC
9517: *
9518: * ARG
9519: *
9520: S$ARG ENT ENTRY POINT
9521: JSR GTSMI GET SECOND ARG AS SMALL INTEGER
9522: ERR 062,ARG SECOND ARGUMENT IS NOT INTEGER
9523: PPM EXFAL FAIL IF OUT OF RANGE OR NEGATIVE
9524: MOV XR,WA SAVE ARGUMENT NUMBER
9525: MOV (XS)+,XR LOAD FIRST ARGUMENT
9526: JSR GTNVR LOCATE VRBLK
9527: PPM SARG1 JUMP IF NOT NATURAL VARIABLE
9528: MOV VRFNC(XR),XR ELSE LOAD FUNCTION BLOCK POINTER
9529: BNE (XR),=B$PFC,SARG1 JUMP IF NOT PROGRAM DEFINED
9530: BZE WA,EXFAL FAIL IF ARG NUMBER IS ZERO
9531: BGT WA,FARGS(XR),EXFAL FAIL IF ARG NUMBER IS TOO LARGE
9532: WTB WA ELSE CONVERT TO BYTE OFFSET
9533: ADD WA,XR POINT TO ARGUMENT SELECTED
9534: MOV PFAGB(XR),XR LOAD ARGUMENT VRBLK POINTER
9535: BRN EXVNM EXIT TO BUILD NMBLK
9536: *
9537: * HERE IF 1ST ARGUMENT IS BAD
9538: *
9539: SARG1 ERB 063,ARG FIRST ARGUMENT IS NOT PROGRAM FUNCTION NAME
9540: EJC
9541: *
9542: * ARRAY
9543: *
9544: S$ARR ENT ENTRY POINT
9545: MOV (XS)+,XL LOAD INITIAL ELEMENT VALUE
9546: MOV (XS)+,XR LOAD FIRST ARGUMENT
9547: JSR GTINT CONVERT FIRST ARG TO INTEGER
9548: PPM SAR02 JUMP IF NOT INTEGER
9549: *
9550: * HERE FOR INTEGER FIRST ARGUMENT, BUILD VCBLK
9551: *
9552: LDI ICVAL(XR) LOAD INTEGER VALUE
9553: ILE SAR10 JUMP IF ZERO OR NEG (BAD DIMENSION)
9554: MFI WA,SAR11 ELSE CONVERT TO ONE WORD, TEST OVFL
9555: LCT WB,WA COPY ELEMENTS FOR LOOP LATER ON
9556: ADD =VCSI$,WA ADD SPACE FOR STANDARD FIELDS
9557: WTB WA CONVERT LENGTH TO BYTES
9558: BGE WA,MXLEN,SAR11 FAIL IF TOO LARGE
9559: JSR ALLOC ALLOCATE SPACE FOR VCBLK
9560: MOV =B$VCT,(XR) STORE TYPE WORD
9561: MOV WA,VCLEN(XR) SET LENGTH
9562: MOV XL,WC COPY DEFAULT VALUE
9563: MOV XR,XL COPY VCBLK POINTER
9564: ADD *VCVLS,XL POINT TO FIRST ELEMENT VALUE
9565: *
9566: * LOOP TO SET VECTOR ELEMENTS TO DEFAULT VALUE
9567: *
9568: SAR01 MOV WC,(XL)+ STORE ONE VALUE
9569: BCT WB,SAR01 LOOP TILL ALL STORED
9570: BRN EXSID EXIT SETTING IDVAL
9571: EJC
9572: *
9573: * ARRAY (CONTINUED)
9574: *
9575: * HERE IF FIRST ARGUMENT IS NOT AN INTEGER
9576: *
9577: SAR02 MOV XR,-(XS) REPLACE ARGUMENT ON STACK
9578: JSR XSCNI INITIALIZE SCAN OF FIRST ARGUMENT
9579: ERR 064,ARRAY FIRST ARGUMENT IS NOT INTEGER OR STRING
9580: PPM EXNUL DUMMY (UNUSED) NULL STRING EXIT
9581: MOV R$XSC,-(XS) SAVE PROTOTYPE POINTER
9582: MOV XL,-(XS) SAVE DEFAULT VALUE
9583: ZER ARCDM ZERO COUNT OF DIMENSIONS
9584: ZER ARPTR ZERO OFFSET TO INDICATE PASS ONE
9585: LDI INTV1 LOAD INTEGER ONE
9586: STI ARNEL INITIALIZE ELEMENT COUNT
9587: *
9588: * THE FOLLOWING CODE IS EXECUTED TWICE. THE FIRST TIME
9589: * (ARPTR EQ 0), IT IS USED TO COUNT THE NUMBER OF ELEMENTS
9590: * AND NUMBER OF DIMENSIONS. THE SECOND TIME (ARPTR GT 0) IS
9591: * USED TO ACTUALLY FILL IN THE DIM,LBD FIELDS OF THE ARBLK.
9592: *
9593: SAR03 LDI INTV1 LOAD ONE AS DEFAULT LOW BOUND
9594: STI ARSVL SAVE AS LOW BOUND
9595: MOV =CH$CL,WC SET DELIMITER ONE = COLON
9596: MOV =CH$CM,XL SET DELIMITER TWO = COMMA
9597: JSR XSCAN SCAN NEXT BOUND
9598: BNE WA,=NUM01,SAR04 JUMP IF NOT COLON
9599: *
9600: * HERE WE HAVE A COLON ENDING A LOW BOUND
9601: *
9602: JSR GTINT CONVERT LOW BOUND
9603: ERR 065,ARRAY FIRST ARGUMENT LOWER BOUND IS NOT INTEGER
9604: LDI ICVAL(XR) LOAD VALUE OF LOW BOUND
9605: STI ARSVL STORE LOW BOUND VALUE
9606: MOV =CH$CM,WC SET DELIMITER ONE = COMMA
9607: MOV WC,XL AND DELIMITER TWO = COMMA
9608: JSR XSCAN SCAN HIGH BOUND
9609: EJC
9610: *
9611: * ARRAY (CONTINUED)
9612: *
9613: * MERGE HERE TO PROCESS UPPER BOUND
9614: *
9615: SAR04 JSR GTINT CONVERT HIGH BOUND TO INTEGER
9616: ERR 066,ARRAY FIRST ARGUMENT UPPER BOUND IS NOT INTEGER
9617: LDI ICVAL(XR) GET HIGH BOUND
9618: SBI ARSVL SUBTRACT LOWER BOUND
9619: IOV SAR10 BAD DIMENSION IF OVERFLOW
9620: ILT SAR10 BAD DIMENSION IF NEGATIVE
9621: ADI INTV1 ADD 1 TO GET DIMENSION
9622: IOV SAR10 BAD DIMENSION IF OVERFLOW
9623: MOV ARPTR,XL LOAD OFFSET (ALSO PASS INDICATOR)
9624: BZE XL,SAR05 JUMP IF FIRST PASS
9625: *
9626: * HERE IN SECOND PASS TO STORE LBD AND DIM IN ARBLK
9627: *
9628: ADD (XS),XL POINT TO CURRENT LOCATION IN ARBLK
9629: STI CFP$I(XL) STORE DIMENSION
9630: LDI ARSVL LOAD LOW BOUND
9631: STI (XL) STORE LOW BOUND
9632: ADD *ARDMS,ARPTR BUMP OFFSET TO NEXT BOUNDS
9633: BRN SAR06 JUMP TO CHECK FOR END OF BOUNDS
9634: *
9635: * HERE IN PASS 1
9636: *
9637: SAR05 ICV ARCDM BUMP DIMENSION COUNT
9638: MLI ARNEL MULTIPLY DIMENSION BY COUNT SO FAR
9639: IOV SAR11 TOO LARGE IF OVERFLOW
9640: STI ARNEL ELSE STORE UPDATED ELEMENT COUNT
9641: *
9642: * MERGE HERE AFTER PROCESSING ONE SET OF BOUNDS
9643: *
9644: SAR06 BNZ WA,SAR03 LOOP BACK UNLESS END OF BOUNDS
9645: BNZ ARPTR,SAR09 JUMP IF END OF PASS 2
9646: EJC
9647: *
9648: * ARRAY (CONTINUED)
9649: *
9650: * HERE AT END OF PASS ONE, BUILD ARBLK
9651: *
9652: LDI ARNEL GET NUMBER OF ELEMENTS
9653: MFI WB,SAR11 GET AS ADDR INTEGER, TEST OVFLO
9654: WTB WB ELSE CONVERT TO LENGTH IN BYTES
9655: MOV *ARSI$,WA SET SIZE OF STANDARD FIELDS
9656: LCT WC,ARCDM SET DIMENSION COUNT TO CONTROL LOOP
9657: *
9658: * LOOP TO ALLOW SPACE FOR DIMENSIONS
9659: *
9660: SAR07 ADD *ARDMS,WA ALLOW SPACE FOR ONE SET OF BOUNDS
9661: BCT WC,SAR07 LOOP BACK TILL ALL ACCOUNTED FOR
9662: MOV WA,XL SAVE SIZE (=AROFS)
9663: *
9664: * NOW ALLOCATE SPACE FOR ARBLK
9665: *
9666: ADD WB,WA ADD SPACE FOR ELEMENTS
9667: ICA WA ALLOW FOR ARPRO PROTOTYPE FIELD
9668: BGE WA,MXLEN,SAR11 FAIL IF TOO LARGE
9669: JSR ALLOC ELSE ALLOCATE ARBLK
9670: MOV (XS),WB LOAD DEFAULT VALUE
9671: MOV XR,(XS) SAVE ARBLK POINTER
9672: MOV WA,WC SAVE LENGTH IN BYTES
9673: BTW WA CONVERT LENGTH BACK TO WORDS
9674: LCT WA,WA SET COUNTER TO CONTROL LOOP
9675: *
9676: * LOOP TO CLEAR ENTIRE ARBLK TO DEFAULT VALUE
9677: *
9678: SAR08 MOV WB,(XR)+ SET ONE WORD
9679: BCT WA,SAR08 LOOP TILL ALL SET
9680: EJC
9681: *
9682: * ARRAY (CONTINUED)
9683: *
9684: * NOW SET INITIAL FIELDS OF ARBLK
9685: *
9686: MOV (XS)+,XR RELOAD ARBLK POINTER
9687: MOV (XS),WB LOAD PROTOTYPE
9688: MOV =B$ART,(XR) SET TYPE WORD
9689: MOV WC,ARLEN(XR) STORE LENGTH IN BYTES
9690: ZER IDVAL(XR) ZERO ID TILL WE GET IT BUILT
9691: MOV XL,AROFS(XR) SET PROTOTYPE FIELD PTR
9692: MOV ARCDM,ARNDM(XR) SET NUMBER OF DIMENSIONS
9693: MOV XR,WC SAVE ARBLK POINTER
9694: ADD XL,XR POINT TO PROTOTYPE FIELD
9695: MOV WB,(XR) STORE PROTOTYPE PTR IN ARBLK
9696: MOV *ARLBD,ARPTR SET OFFSET FOR PASS 2 BOUNDS SCAN
9697: MOV WB,R$XSC RESET STRING POINTER FOR XSCAN
9698: MOV WC,(XS) STORE ARBLK POINTER ON STACK
9699: ZER XSOFS RESET OFFSET PTR TO START OF STRING
9700: BRN SAR03 JUMP BACK TO RESCAN BOUNDS
9701: *
9702: * HERE AFTER FILLING IN BOUNDS INFORMATION (END PASS TWO)
9703: *
9704: SAR09 MOV (XS)+,XR RELOAD POINTER TO ARBLK
9705: BRN EXSID EXIT SETTING IDVAL
9706: *
9707: * HERE FOR BAD DIMENSION
9708: *
9709: SAR10 ERB 067,ARRAY DIMENSION IS ZERO,NEGATIVE OR OUT OF RANGE
9710: *
9711: * HERE IF ARRAY IS TOO LARGE
9712: *
9713: SAR11 ERB 068,ARRAY SIZE EXCEEDS MAXIMUM PERMITTED
9714: EJC
9715: *
9716: * BUFFER
9717: *
9718: S$BUF ENT ENTRY POINT
9719: MOV (XS)+,XL GET INITIAL VALUE
9720: MOV (XS)+,XR GET REQUESTED ALLOCATION
9721: JSR GTINT CONVERT TO INTEGER
9722: ERR 269,BUFFER FIRST ARGUMENT IS NOT INTEGER
9723: LDI ICVAL(XR) GET VALUE
9724: ILE SBF01 BRANCH IF NEGATIVE OR ZERO
9725: MFI WA,SBF02 MOVE WITH OVERFLOW CHECK
9726: JSR ALOBF ALLOCATE THE BUFFER
9727: JSR APNDB COPY IT IN
9728: ERR 270,BUFFER SECOND ARGUMENT IS NOT STRING OR BUFFER
9729: ERR 271,BUFFER INITIAL VALUE TOO BIG FOR ALLOCATION
9730: BRN EXSID EXIT SETTING IDVAL
9731: *
9732: * HERE FOR INVALID ALLOCATION SIZE
9733: *
9734: SBF01 ERB 272,BUFFER FIRST ARGUMENT IS NOT POSITIVE
9735: *
9736: * HERE FOR ALLOCATION SIZE INTEGER OVERFLOW
9737: *
9738: SBF02 ERB 273,BUFFER SIZE IS TOO BIG
9739: EJC
9740: *
9741: * BREAK
9742: *
9743: S$BRK ENT ENTRY POINT
9744: MOV =P$BKS,WB SET PCODE FOR SINGLE CHAR CASE
9745: MOV =P$BRK,XL PCODE FOR MULTI-CHAR CASE
9746: MOV =P$BKD,WC PCODE FOR EXPRESSION CASE
9747: JSR PATST CALL COMMON ROUTINE TO BUILD NODE
9748: ERR 069,BREAK ARGUMENT IS NOT STRING OR EXPRESSION
9749: BRN EXIXR JUMP FOR NEXT CODE WORD
9750: EJC
9751: *
9752: * BREAKX
9753: *
9754: * BREAKX IS A COMPOUND PATTERN. SEE DESCRIPTION AT START
9755: * OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED.
9756: *
9757: S$BKX ENT ENTRY POINT
9758: MOV =P$BKS,WB PCODE FOR SINGLE CHAR ARGUMENT
9759: MOV =P$BRK,XL PCODE FOR MULTI-CHAR ARGUMENT
9760: MOV =P$BXD,WC PCODE FOR EXPRESSION CASE
9761: JSR PATST CALL COMMON ROUTINE TO BUILD NODE
9762: ERR 070,BREAKX ARGUMENT IS NOT STRING OR EXPRESSION
9763: *
9764: * NOW HOOK BREAKX NODE ON AT FRONT END
9765: *
9766: MOV XR,-(XS) SAVE PTR TO BREAK NODE
9767: MOV =P$BKX,WB SET PCODE FOR BREAKX NODE
9768: JSR PBILD BUILD IT
9769: MOV (XS),PTHEN(XR) SET BREAK NODE AS SUCCESSOR
9770: MOV =P$ALT,WB SET PCODE FOR ALTERNATION NODE
9771: JSR PBILD BUILD (PARM1=ALT=BREAKX NODE)
9772: MOV XR,WA SAVE PTR TO ALTERNATION NODE
9773: MOV (XS),XR POINT TO BREAK NODE
9774: MOV WA,PTHEN(XR) SET ALTERNATE NODE AS SUCCESSOR
9775: BRN EXITS EXIT WITH RESULT ON STACK
9776: EJC
9777: *
9778: * CHAR
9779: *
9780: S$CHR ENT ENTRY POINT
9781: JSR GTSMI CONVERT ARG TO INTEGER
9782: ERR 281,CHAR ARGUMENT NOT INTEGER
9783: PPM SCHR1 TOO BIG ERROR EXIT
9784: BGE WC,=CFP$A,SCHR1 SEE IF OUT OF RANGE OF HOST SET
9785: MOV =NUM01,WA IF NOT SET SCBLK ALLOCATION
9786: MOV WC,WB SAVE CHAR CODE
9787: JSR ALOCS ALLOCATE 1 BAU SCBLK
9788: MOV XR,XL COPY SCBLK POINTER
9789: PSC XL GET SET TO STUFF CHAR
9790: SCH WB,(XL)+ STUFF IT
9791: ZER XL CLEAR SLOP IN XL
9792: BRN EXIXR EXIT WITH SCBLK POINTER
9793: *
9794: * HERE IF CHAR ARGUMENT IS OUT OF RANGE
9795: *
9796: SCHR1 ERB 282,CHAR ARGUMENT NOT IN RANGE
9797: EJC
9798: *
9799: * CLEAR
9800: *
9801: S$CLR ENT ENTRY POINT
9802: JSR XSCNI INITIALIZE TO SCAN ARGUMENT
9803: ERR 071,CLEAR ARGUMENT IS NOT STRING
9804: PPM SCLR2 JUMP IF NULL
9805: *
9806: * LOOP TO SCAN OUT NAMES IN FIRST ARGUMENT. VARIABLES IN
9807: * THE LIST ARE FALGGED BY SETTING VRGET OF VRBLK TO ZERO.
9808: *
9809: SCLR1 MOV =CH$CM,WC SET DELIMITER ONE = COMMA
9810: MOV WC,XL DELIMITER TWO = COMMA
9811: JSR XSCAN SCAN NEXT VARIABLE NAME
9812: JSR GTNVR LOCATE VRBLK
9813: ERR 072,CLEAR ARGUMENT HAS NULL VARIABLE NAME
9814: ZER VRGET(XR) ELSE FLAG BY ZEROING VRGET FIELD
9815: BNZ WA,SCLR1 LOOP BACK IF STOPPED BY COMMA
9816: *
9817: * HERE AFTER FLAGGING VARIABLES IN ARGUMENT LIST
9818: *
9819: SCLR2 MOV HSHTB,WB POINT TO START OF HASH TABLE
9820: *
9821: * LOOP THROUGH SLOTS IN HASH TABLE
9822: *
9823: SCLR3 BEQ WB,HSHTE,EXNUL EXIT RETURNING NULL IF NONE LEFT
9824: MOV WB,XR ELSE COPY SLOT POINTER
9825: ICA WB BUMP SLOT POINTER
9826: SUB *VRNXT,XR SET OFFSET TO MERGE INTO LOOP
9827: *
9828: * LOOP THROUGH VRBLKS ON ONE HASH CHAIN
9829: *
9830: SCLR4 MOV VRNXT(XR),XR POINT TO NEXT VRBLK ON CHAIN
9831: BZE XR,SCLR3 JUMP FOR NEXT BUCKET IF CHAIN END
9832: BNZ VRGET(XR),SCLR5 JUMP IF NOT FLAGGED
9833: EJC
9834: *
9835: * CLEAR (CONTINUED)
9836: *
9837: * HERE FOR FLAGGED VARIABLE, DO NOT SET VALUE TO NULL
9838: *
9839: JSR SETVR FOR FLAGGED VAR, RESTORE VRGET
9840: BRN SCLR4 AND LOOP BACK FOR NEXT VRBLK
9841: *
9842: * HERE TO SET VALUE OF A VARIABLE TO NULL
9843: * PRROTECTED VARIABLES (ARB, ETC) ARE EXEMPT
9844: *
9845: SCLR5 BEQ VRSTO(XR),=B$VRE,SCLR4 CHECK FOR PROTECTED VARIABLE (REG05)
9846: MOV XR,XL COPY VRBLK POINTER (REG05)
9847: *
9848: * LOOP TO LOCATE VALUE AT END OF POSSIBLE TRBLK CHAIN
9849: *
9850: SCLR6 MOV XL,WA SAVE BLOCK POINTER
9851: MOV VRVAL(XL),XL LOAD NEXT VALUE FIELD
9852: BEQ (XL),=B$TRT,SCLR6 LOOP BACK IF TRAPPED
9853: *
9854: * NOW STORE THE NULL VALUE
9855: *
9856: MOV WA,XL RESTORE BLOCK POINTER
9857: MOV =NULLS,VRVAL(XL) STORE NULL CONSTANT VALUE
9858: BRN SCLR4 LOOP BACK FOR NEXT VRBLK
9859: EJC
9860: *
9861: * CODE
9862: *
9863: S$COD ENT ENTRY POINT
9864: MOV (XS)+,XR LOAD ARGUMENT
9865: JSR GTCOD CONVERT TO CODE
9866: PPM EXFAL FAIL IF CONVERSION IS IMPOSSIBLE
9867: BRN EXIXR ELSE RETURN CODE AS RESULT
9868: EJC
9869: *
9870: * COLLECT
9871: *
9872: S$COL ENT ENTRY POINT
9873: MOV (XS)+,XR LOAD ARGUMENT
9874: JSR GTINT CONVERT TO INTEGER
9875: ERR 073,COLLECT ARGUMENT IS NOT INTEGER
9876: LDI ICVAL(XR) LOAD COLLECT ARGUMENT
9877: STI CLSVI SAVE COLLECT ARGUMENT
9878: ZER WB SET NO MOVE UP
9879: JSR GBCOL PERFORM GARBAGE COLLECTION
9880: MOV DNAME,WA POINT TO END OF MEMORY
9881: SUB DNAMP,WA SUBTRACT NEXT LOCATION
9882: BTW WA CONVERT BYTES TO WORDS
9883: MTI WA CONVERT WORDS AVAILABLE AS INTEGER
9884: SBI CLSVI SUBTRACT ARGUMENT
9885: IOV EXFAL FAIL IF OVERFLOW
9886: ILT EXFAL FAIL IF NOT ENOUGH
9887: ADI CLSVI ELSE RECOMPUTE AVAILABLE
9888: BRN EXINT AND EXIT WITH INTEGER RESULT
9889: EJC
9890: *
9891: * CONVERT
9892: *
9893: S$CNV ENT ENTRY POINT
9894: JSR GTSTG CONVERT SECOND ARGUMENT TO STRING
9895: ERR 074,CONVERT SECOND ARGUMENT IS NOT STRING
9896: JSR FLSTG FOLD LOWER CASE TO UPPER CASE
9897: MOV (XS),XL LOAD FIRST ARGUMENT
9898: BNE (XL),=B$PDT,SCV01 JUMP IF NOT PROGRAM DEFINED
9899: *
9900: * HERE FOR PROGRAM DEFINED DATATYPE
9901: *
9902: MOV PDDFP(XL),XL POINT TO DFBLK
9903: MOV DFNAM(XL),XL LOAD DATATYPE NAME
9904: JSR IDENT COMPARE WITH SECOND ARG
9905: PPM EXITS EXIT IF IDENT WITH ARG AS RESULT
9906: BRN EXFAL ELSE FAIL
9907: *
9908: * HERE IF NOT PROGRAM DEFINED DATATYPE
9909: *
9910: SCV01 MOV XR,-(XS) SAVE STRING ARGUMENT
9911: MOV =SVCTB,XL POINT TO TABLE OF NAMES TO COMPARE
9912: ZER WB INITIALIZE COUNTER
9913: MOV WA,WC SAVE LENGTH OF ARGUMENT STRING
9914: *
9915: * LOOP THROUGH TABLE ENTRIES
9916: *
9917: SCV02 MOV (XL)+,XR LOAD NEXT TABLE ENTRY, BUMP POINTER
9918: BZE XR,EXFAL FAIL IF ZERO MARKING END OF LIST
9919: BNE WC,SCLEN(XR),SCV05 JUMP IF WRONG LENGTH
9920: MOV XL,CNVTP ELSE STORE TABLE POINTER
9921: PLC XR POINT TO CHARS OF TABLE ENTRY
9922: MOV (XS),XL LOAD POINTER TO STRING ARGUMENT
9923: PLC XL POINT TO CHARS OF STRING ARG
9924: MOV WC,WA SET NUMBER OF CHARS TO COMPARE
9925: CMC SCV04,SCV04 COMPARE, JUMP IF NO MATCH
9926: EJC
9927: *
9928: * CONVERT (CONTINUED)
9929: *
9930: * HERE WE HAVE A MATCH
9931: *
9932: SCV03 MOV WB,XL COPY ENTRY NUMBER
9933: ICA XS POP STRING ARG OFF STACK
9934: MOV (XS)+,XR LOAD FIRST ARGUMENT
9935: BSW XL,CNVTT JUMP TO APPROPRIATE ROUTINE
9936: IFF 0,SCV06 STRING
9937: IFF 1,SCV07 INTEGER
9938: IFF 2,SCV09 NAME
9939: IFF 3,SCV10 PATTERN
9940: IFF 4,SCV11 ARRAY
9941: IFF 5,SCV19 TABLE
9942: IFF 6,SCV25 EXPRESSION
9943: IFF 7,SCV26 CODE
9944: IFF 8,SCV27 NUMERIC
9945: IFF CNVRT,SCV08 REAL
9946: IFF CNVBT,SCV28 BUFFER
9947: ESW END OF SWITCH TABLE
9948: *
9949: * HERE IF NO MATCH WITH TABLE ENTRY
9950: *
9951: SCV04 MOV CNVTP,XL RESTORE TABLE POINTER, MERGE
9952: *
9953: * MERGE HERE IF LENGTHS DID NOT MATCH
9954: *
9955: SCV05 ICV WB BUMP ENTRY NUMBER
9956: BRN SCV02 LOOP BACK TO CHECK NEXT ENTRY
9957: *
9958: * HERE TO CONVERT TO STRING
9959: *
9960: SCV06 MOV XR,-(XS) REPLACE STRING ARGUMENT ON STACK
9961: JSR GTSTG CONVERT TO STRING
9962: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
9963: BRN EXIXR ELSE RETURN STRING
9964: EJC
9965: *
9966: * CONVERT (CONTINUED)
9967: *
9968: * HERE TO CONVERT TO INTEGER
9969: *
9970: SCV07 JSR GTINT CONVERT TO INTEGER
9971: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
9972: BRN EXIXR ELSE RETURN INTEGER
9973: *
9974: * HERE TO CONVERT TO REAL
9975: *
9976: SCV08 JSR GTREA CONVERT TO REAL
9977: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
9978: BRN EXIXR ELSE RETURN REAL
9979: *
9980: * HERE TO CONVERT TO NAME
9981: *
9982: SCV09 BEQ (XR),=B$NML,EXIXR RETURN IF ALREADY A NAME
9983: JSR GTNVR ELSE TRY STRING TO NAME CONVERT
9984: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
9985: BRN EXVNM ELSE EXIT BUILDING NMBLK FOR VRBLK
9986: *
9987: * HERE TO CONVERT TO PATTERN
9988: *
9989: SCV10 JSR GTPAT CONVERT TO PATTERN
9990: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
9991: BRN EXIXR ELSE RETURN PATTERN
9992: *
9993: * CONVERT TO ARRAY
9994: *
9995: SCV11 JSR GTARR GET AN ARRAY
9996: PPM EXFAL FAIL IF NOT CONVERTIBLE
9997: BRN EXSID EXIT SETTING ID FIELD
9998: *
9999: * CONVERT TO TABLE
10000: *
10001: SCV19 MOV (XR),WA LOAD FIRST WORD OF BLOCK
10002: MOV XR,-(XS) REPLACE ARBLK POINTER ON STACK
10003: BEQ WA,=B$TBT,EXITS RETURN ARG IF ALREADY A TABLE
10004: BNE WA,=B$ART,EXFAL ELSE FAIL IF NOT AN ARRAY
10005: EJC
10006: *
10007: * CONVERT (CONTINUED)
10008: *
10009: * HERE TO CONVERT AN ARRAY TO TABLE
10010: *
10011: BNE ARNDM(XR),=NUM02,EXFAL FAIL IF NOT 2-DIM ARRAY
10012: LDI ARDM2(XR) LOAD DIM 2
10013: SBI INTV2 SUBTRACT 2 TO COMPARE
10014: INE EXFAL FAIL IF DIM2 NOT 2
10015: *
10016: * HERE WE HAVE AN ARBLK OF THE RIGHT SHAPE
10017: *
10018: LDI ARDIM(XR) LOAD DIM 1 (NUMBER OF ELEMENTS)
10019: MFI WA GET AS ONE WORD INTEGER
10020: LCT WB,WA COPY TO CONTROL LOOP
10021: ADD =TBSI$,WA ADD SPACE FOR STANDARD FIELDS
10022: WTB WA CONVERT LENGTH TO BYTES
10023: JSR ALLOC ALLOCATE SPACE FOR TBBLK
10024: MOV XR,WC COPY TBBLK POINTER
10025: MOV XR,-(XS) SAVE TBBLK POINTER
10026: MOV =B$TBT,(XR)+ STORE TYPE WORD
10027: ZER (XR)+ STORE ZERO FOR IDVAL FOR NOW
10028: MOV WA,(XR)+ STORE LENGTH
10029: MOV =NULLS,(XR)+ NULL INITIAL LOOKUP VALUE
10030: *
10031: * LOOP TO INITIALIZE BUCKET PTRS TO POINT TO TABLE
10032: *
10033: SCV20 MOV WC,(XR)+ SET BUCKET PTR TO POINT TO TBBLK
10034: BCT WB,SCV20 LOOP TILL ALL INITIALIZED
10035: MOV *ARVL2,WB SET OFFSET TO FIRST ARBLK ELEMENT
10036: *
10037: * LOOP TO COPY ELEMENTS FROM ARRAY TO TABLE
10038: *
10039: SCV21 MOV 1(XS),XL POINT TO ARBLK
10040: BEQ WB,ARLEN(XL),SCV24 JUMP IF ALL MOVED
10041: ADD WB,XL ELSE POINT TO CURRENT LOCATION
10042: ADD *NUM02,WB BUMP OFFSET
10043: MOV (XL),XR LOAD SUBSCRIPT NAME
10044: DCA XL ADJUST PTR TO MERGE (TRVAL=1+1)
10045: EJC
10046: *
10047: * CONVERT (CONTINUED)
10048: *
10049: * LOOP TO CHASE DOWN TRBLK CHAIN FOR VALUE
10050: *
10051: SCV22 MOV TRVAL(XL),XL POINT TO NEXT VALUE
10052: BEQ (XL),=B$TRT,SCV22 LOOP BACK IF TRAPPED
10053: *
10054: * HERE WITH NAME IN XR, VALUE IN XL
10055: *
10056: SCV23 MOV XL,-(XS) STACK VALUE
10057: MOV 1(XS),XL LOAD TBBLK POINTER
10058: JSR TFIND BUILD TEBLK (NOTE WB GT 0 BY NAME)
10059: PPM EXFAL FAIL IF ACESS FAILS
10060: MOV (XS)+,TEVAL(XL) STORE VALUE IN TEBLK
10061: BRN SCV21 LOOP BACK FOR NEXT ELEMENT
10062: *
10063: * HERE AFTER MOVING ALL ELEMENTS TO TBBLK
10064: *
10065: SCV24 MOV (XS)+,XR LOAD TBBLK POINTER
10066: ICA XS POP ARBLK POINTER
10067: BRN EXSID EXIT SETTING IDVAL
10068: *
10069: * CONVERT TO EXPRESSION
10070: *
10071: SCV25 JSR GTEXP CONVERT TO EXPRESSION
10072: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
10073: BRN EXIXR ELSE RETURN EXPRESSION
10074: *
10075: * CONVERT TO CODE
10076: *
10077: SCV26 JSR GTCOD CONVERT TO CODE
10078: PPM EXFAL FAIL IF CONVERSION IS NOT POSSIBLE
10079: BRN EXIXR ELSE RETURN CODE
10080: *
10081: * CONVERT TO NUMERIC
10082: *
10083: SCV27 JSR GTNUM CONVERT TO NUMERIC
10084: PPM EXFAL FAIL IF UNCONVERTIBLE
10085: BRN EXIXR RETURN NUMBER
10086: EJC
10087: *
10088: * CONVERT TO BUFFER
10089: *
10090: SCV28 MOV XR,-(XS) STACK STRING FOR PROCEDURE
10091: JSR GTSTG CONVERT TO STRING
10092: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
10093: MOV XR,XL SAVE STRING POINTER
10094: JSR ALOBF ALLOCATE BUFFER OF SAME SIZE
10095: JSR APNDB COPY IN THE STRING
10096: PPM ALREADY STRING - CANT FAIL TO CNV
10097: PPM MUST BE ENOUGH ROOM
10098: BRN EXSID EXIT SETTING IDVAL FIELD
10099: EJC
10100: *
10101: * COPY
10102: *
10103: S$COP ENT ENTRY POINT
10104: JSR COPYB COPY THE BLOCK
10105: PPM EXITS RETURN IF NO IDVAL FIELD
10106: BRN EXSID EXIT SETTING ID VALUE
10107: EJC
10108: *
10109: * DATA
10110: *
10111: S$DAT ENT ENTRY POINT
10112: JSR XSCNI PREPARE TO SCAN ARGUMENT
10113: ERR 075,DATA ARGUMENT IS NOT STRING
10114: ERR 076,DATA ARGUMENT IS NULL
10115: *
10116: * SCAN OUT DATATYPE NAME
10117: *
10118: MOV =CH$PP,WC DELIMITER ONE = LEFT PAREN
10119: MOV WC,XL DELIMITER TWO = LEFT PAREN
10120: JSR XSCAN SCAN DATATYPE NAME
10121: BNZ WA,SDAT1 SKIP IF LEFT PAREN FOUND
10122: ERB 077,DATA ARGUMENT IS MISSING A LEFT PAREN
10123: *
10124: * HERE AFTER SCANNING DATATYPE NAME
10125: *
10126: SDAT1 MOV SCLEN(XR),WA GET LENGTH
10127: JSR FLSTG FOLD LOWER CASE TO UPPER CASE
10128: MOV XR,XL SAVE NAME PTR
10129: MOV SCLEN(XR),WA GET LENGTH
10130: CTB WA,SCSI$ COMPUTE SPACE NEEDED
10131: JSR ALOST REQUEST STATIC STORE FOR NAME
10132: MOV XR,-(XS) SAVE DATATYPE NAME
10133: MVW COPY NAME TO STATIC
10134: MOV (XS),XR GET NAME PTR
10135: ZER XL SCRUB DUD REGISTER
10136: JSR GTNVR LOCATE VRBLK FOR DATATYPE NAME
10137: ERR 078,DATA ARGUMENT HAS NULL DATATYPE NAME
10138: MOV XR,DATDV SAVE VRBLK POINTER FOR DATATYPE
10139: MOV XS,DATXS STORE STARTING STACK VALUE
10140: ZER WB ZERO COUNT OF FIELD NAMES
10141: *
10142: * LOOP TO SCAN FIELD NAMES AND STACK VRBLK POINTERS
10143: *
10144: SDAT2 MOV =CH$RP,WC DELIMITER ONE = RIGHT PAREN
10145: MOV =CH$CM,XL DELIMITER TWO = COMMA
10146: JSR XSCAN SCAN NEXT FIELD NAME
10147: BNZ WA,SDAT3 JUMP IF DELIMITER FOUND
10148: ERB 079,DATA ARGUMENT IS MISSING A RIGHT PAREN
10149: *
10150: * HERE AFTER SCANNING OUT ONE FIELD NAME
10151: *
10152: SDAT3 JSR GTNVR LOCATE VRBLK FOR FIELD NAME
10153: ERR 080,DATA ARGUMENT HAS NULL FIELD NAME
10154: MOV XR,-(XS) STACK VRBLK POINTER
10155: ICV WB INCREMENT COUNTER
10156: BEQ WA,=NUM02,SDAT2 LOOP BACK IF STOPPED BY COMMA
10157: EJC
10158: *
10159: * DATA (CONTINUED)
10160: *
10161: * NOW BUILD THE DFBLK
10162: *
10163: MOV =DFSI$,WA SET SIZE OF DFBLK STANDARD FIELDS
10164: ADD WB,WA ADD NUMBER OF FIELDS
10165: WTB WA CONVERT LENGTH TO BYTES
10166: MOV WB,WC PRESERVE NO. OF FIELDS
10167: JSR ALOST ALLOCATE SPACE FOR DFBLK
10168: MOV WC,WB GET NO OF FIELDS
10169: MOV DATXS,XT POINT TO START OF STACK
10170: MOV (XT),WC LOAD DATATYPE NAME
10171: MOV XR,(XT) SAVE DFBLK POINTER ON STACK
10172: MOV =B$DFC,(XR)+ STORE TYPE WORD
10173: MOV WB,(XR)+ STORE NUMBER OF FIELDS (FARGS)
10174: MOV WA,(XR)+ STORE LENGTH (DFLEN)
10175: SUB *PDDFS,WA COMPUTE PDBLK LENGTH (FOR DFPDL)
10176: MOV WA,(XR)+ STORE PDBLK LENGTH (DFPDL)
10177: MOV WC,(XR)+ STORE DATATYPE NAME (DFNAM)
10178: LCT WC,WB COPY NUMBER OF FIELDS
10179: *
10180: * LOOP TO MOVE FIELD NAME VRBLK POINTERS TO DFBLK
10181: *
10182: SDAT4 MOV -(XT),(XR)+ MOVE ONE FIELD NAME VRBLK POINTER
10183: BCT WC,SDAT4 LOOP TILL ALL MOVED
10184: *
10185: * NOW DEFINE THE DATATYPE FUNCTION
10186: *
10187: MOV WA,WC COPY LENGTH OF PDBLK FOR LATER LOOP
10188: MOV DATDV,XR POINT TO VRBLK
10189: MOV DATXS,XT POINT BACK ON STACK
10190: MOV (XT),XL LOAD DFBLK POINTER
10191: JSR DFFNC DEFINE FUNCTION
10192: EJC
10193: *
10194: * DATA (CONTINUED)
10195: *
10196: * LOOP TO BUILD FFBLKS
10197: *
10198: *
10199: * NOTICE THAT THE FFBLKS ARE CONSTRUCTED IN REVERSE ORDER
10200: * SO THAT THE REQUIRED OFFSETS CAN BE OBTAINED FROM
10201: * SUCCESSIVE DECREMENTATION OF THE PDBLK LENGTH (IN WC).
10202: *
10203: SDAT5 MOV *FFSI$,WA SET LENGTH OF FFBLK
10204: JSR ALLOC ALLOCATE SPACE FOR FFBLK
10205: MOV =B$FFC,(XR) SET TYPE WORD
10206: MOV =NUM01,FARGS(XR) STORE FARGS (ALWAYS ONE)
10207: MOV DATXS,XT POINT BACK ON STACK
10208: MOV (XT),FFDFP(XR) COPY DFBLK PTR TO FFBLK
10209: DCA WC DECREMENT OLD DFPDL TO GET NEXT OFS
10210: MOV WC,FFOFS(XR) SET OFFSET TO THIS FIELD
10211: ZER FFNXT(XR) TENTATIVELY SET ZERO FORWARD PTR
10212: MOV XR,XL COPY FFBLK POINTER FOR DFFNC
10213: MOV (XS),XR LOAD VRBLK POINTER FOR FIELD
10214: MOV VRFNC(XR),XR LOAD CURRENT FUNCTION POINTER
10215: BNE (XR),=B$FFC,SDAT6 SKIP IF NOT CURRENTLY A FIELD FUNC
10216: *
10217: * HERE WE MUST CHAIN AN OLD FFBLK PTR TO PRESERVE IT IN THE
10218: * CASE OF MULTIPLE FIELD FUNCTIONS WITH THE SAME NAME
10219: *
10220: MOV XR,FFNXT(XL) LINK NEW FFBLK TO PREVIOUS CHAIN
10221: *
10222: * MERGE HERE TO DEFINE FIELD FUNCTION
10223: *
10224: SDAT6 MOV (XS)+,XR LOAD VRBLK POINTER
10225: JSR DFFNC DEFINE FIELD FUNCTION
10226: BNE XS,DATXS,SDAT5 LOOP BACK TILL ALL DONE
10227: ICA XS POP DFBLK POINTER
10228: BRN EXNUL RETURN WITH NULL RESULT
10229: EJC
10230: *
10231: * DATATYPE
10232: *
10233: S$DTP ENT ENTRY POINT
10234: MOV (XS)+,XR LOAD ARGUMENT
10235: JSR DTYPE GET DATATYPE
10236: BRN EXIXR AND RETURN IT AS RESULT
10237: EJC
10238: *
10239: * DATE
10240: *
10241: S$DTE ENT ENTRY POINT
10242: JSR SYSDT CALL SYSTEM DATE ROUTINE
10243: MOV 1(XL),WA LOAD LENGTH FOR SBSTR
10244: BZE WA,EXNUL RETURN NULL IF LENGTH IS ZERO
10245: ZER WB SET ZERO OFFSET
10246: JSR SBSTR USE SBSTR TO BUILD SCBLK
10247: BRN EXIXR RETURN DATE STRING
10248: EJC
10249: *
10250: * DEFINE
10251: *
10252: S$DEF ENT ENTRY POINT
10253: MOV (XS)+,XR LOAD SECOND ARGUMENT
10254: ZER DEFLB ZERO LABEL POINTER IN CASE NULL
10255: BEQ XR,=NULLS,SDF01 JUMP IF NULL SECOND ARGUMENT
10256: JSR GTNVR ELSE FIND VRBLK FOR LABEL
10257: PPM SDF13 JUMP IF NOT A VARIABLE NAME
10258: MOV XR,DEFLB ELSE SET SPECIFIED ENTRY
10259: *
10260: * SCAN FUNCTION NAME
10261: *
10262: SDF01 JSR XSCNI PREPARE TO SCAN FIRST ARGUMENT
10263: ERR 081,DEFINE FIRST ARGUMENT IS NOT STRING
10264: ERR 082,DEFINE FIRST ARGUMENT IS NULL
10265: MOV =CH$PP,WC DELIMITER ONE = LEFT PAREN
10266: MOV WC,XL DELIMITER TWO = LEFT PAREN
10267: JSR XSCAN SCAN OUT FUNCTION NAME
10268: BNZ WA,SDF02 JUMP IF LEFT PAREN FOUND
10269: ERB 083,DEFINE FIRST ARGUMENT IS MISSING A LEFT PAREN
10270: *
10271: * HERE AFTER SCANNING OUT FUNCTION NAME
10272: *
10273: SDF02 JSR GTNVR GET VARIABLE NAME
10274: ERR 084,DEFINE FIRST ARGUMENT HAS NULL FUNCTION NAME
10275: MOV XR,DEFVR SAVE VRBLK POINTER FOR FUNCTION NAM
10276: ZER WB ZERO COUNT OF ARGUMENTS
10277: MOV XS,DEFXS SAVE INITIAL STACK POINTER
10278: BNZ DEFLB,SDF03 JUMP IF SECOND ARGUMENT GIVEN
10279: MOV XR,DEFLB ELSE DEFAULT IS FUNCTION NAME
10280: *
10281: * LOOP TO SCAN ARGUMENT NAMES AND STACK VRBLK POINTERS
10282: *
10283: SDF03 MOV =CH$RP,WC DELIMITER ONE = RIGHT PAREN
10284: MOV =CH$CM,XL DELIMITER TWO = COMMA
10285: JSR XSCAN SCAN OUT NEXT ARGUMENT NAME
10286: BNZ WA,SDF04 SKIP IF DELIMITER FOUND
10287: ERB 085,NULL ARG NAME OR MISSING ) IN DEFINE FIRST ARG.
10288: EJC
10289: *
10290: * DEFINE (CONTINUED)
10291: *
10292: * HERE AFTER SCANNING AN ARGUMENT NAME
10293: *
10294: SDF04 BNE XR,=NULLS,SDF05 SKIP IF NON-NULL
10295: BZE WB,SDF06 IGNORE NULL IF CASE OF NO ARGUMENTS
10296: *
10297: * HERE AFTER DEALING WITH THE CASE OF NO ARGUMENTS
10298: *
10299: SDF05 JSR GTNVR GET VRBLK POINTER
10300: PPM SDF03 LOOP BACK TO IGNORE NULL NAME
10301: MOV XR,-(XS) STACK ARGUMENT VRBLK POINTER
10302: ICV WB INCREMENT COUNTER
10303: BEQ WA,=NUM02,SDF03 LOOP BACK IF STOPPED BY A COMMA
10304: *
10305: * HERE AFTER SCANNING OUT FUNCTION ARGUMENT NAMES
10306: *
10307: SDF06 MOV WB,DEFNA SAVE NUMBER OF ARGUMENTS
10308: ZER WB ZERO COUNT OF LOCALS
10309: *
10310: * LOOP TO SCAN LOCAL NAMES AND STACK VRBLK POINTERS
10311: *
10312: SDF07 MOV =CH$CM,WC SET DELIMITER ONE = COMMA
10313: MOV WC,XL SET DELIMITER TWO = COMMA
10314: JSR XSCAN SCAN OUT NEXT LOCAL NAME
10315: BNE XR,=NULLS,SDF08 SKIP IF NON-NULL
10316: BZE WB,SDF09 IGNORE NULL IF CASE OF NO LOCALS
10317: *
10318: * HERE AFTER SCANNING OUT A LOCAL NAME
10319: *
10320: SDF08 JSR GTNVR GET VRBLK POINTER
10321: PPM SDF07 LOOP BACK TO IGNORE NULL NAME
10322: ICV WB IF OK, INCREMENT COUNT
10323: MOV XR,-(XS) STACK VRBLK POINTER
10324: BNZ WA,SDF07 LOOP BACK IF STOPPED BY A COMMA
10325: EJC
10326: *
10327: * DEFINE (CONTINUED)
10328: *
10329: * HERE AFTER SCANNING LOCALS, BUILD PFBLK
10330: *
10331: SDF09 MOV WB,WA COPY COUNT OF LOCALS
10332: ADD DEFNA,WA ADD NUMBER OF ARGUMENTS
10333: MOV WA,WC SET SUM ARGS+LOCALS AS LOOP COUNT
10334: ADD =PFSI$,WA ADD SPACE FOR STANDARD FIELDS
10335: WTB WA CONVERT LENGTH TO BYTES
10336: JSR ALLOC ALLOCATE SPACE FOR PFBLK
10337: MOV XR,XL SAVE POINTER TO PFBLK
10338: MOV =B$PFC,(XR)+ STORE FIRST WORD
10339: MOV DEFNA,(XR)+ STORE NUMBER OF ARGUMENTS
10340: MOV WA,(XR)+ STORE LENGTH (PFLEN)
10341: MOV DEFVR,(XR)+ STORE VRBLK PTR FOR FUNCTION NAME
10342: MOV WB,(XR)+ STORE NUMBER OF LOCALS
10343: ZER (XR)+ DEAL WITH LABEL LATER
10344: ZER (XR)+ ZERO PFCTR
10345: ZER (XR)+ ZERO PFRTR
10346: BZE WC,SDF11 SKIP IF NO ARGS OR LOCALS
10347: MOV XL,WA KEEP PFBLK POINTER
10348: MOV DEFXS,XT POINT BEFORE ARGUMENTS
10349: LCT WC,WC GET COUNT OF ARGS+LOCALS FOR LOOP
10350: *
10351: * LOOP TO MOVE LOCALS AND ARGS TO PFBLK
10352: *
10353: SDF10 MOV -(XT),(XR)+ STORE ONE ENTRY AND BUMP POINTERS
10354: BCT WC,SDF10 LOOP TILL ALL STORED
10355: MOV WA,XL RECOVER PFBLK POINTER
10356: EJC
10357: *
10358: * DEFINE (CONTINUED)
10359: *
10360: * NOW DEAL WITH LABEL
10361: *
10362: SDF11 MOV DEFXS,XS POP STACK
10363: MOV DEFLB,XR POINT TO VRBLK FOR LABEL
10364: MOV VRLBL(XR),XR LOAD LABEL POINTER
10365: BNE (XR),=B$TRT,SDF12 SKIP IF NOT TRAPPED
10366: MOV TRLBL(XR),XR ELSE POINT TO REAL LABEL
10367: *
10368: * HERE AFTER LOCATING REAL LABEL POINTER
10369: *
10370: SDF12 BEQ XR,=STNDL,SDF13 JUMP IF LABEL IS NOT DEFINED
10371: MOV XR,PFCOD(XL) ELSE STORE LABEL POINTER
10372: MOV DEFVR,XR POINT BACK TO VRBLK FOR FUNCTION
10373: JSR DFFNC DEFINE FUNCTION
10374: BRN EXNUL AND EXIT RETURNING NULL
10375: *
10376: * HERE FOR ERRONEOUS LABEL
10377: *
10378: SDF13 ERB 086,DEFINE FUNCTION ENTRY POINT IS NOT DEFINED LABEL
10379: EJC
10380: *
10381: * DETACH
10382: *
10383: S$DET ENT ENTRY POINT
10384: MOV (XS)+,XR LOAD ARGUMENT
10385: JSR GTVAR LOCATE VARIABLE
10386: ERR 087,DETACH ARGUMENT IS NOT APPROPRIATE NAME
10387: JSR DTACH DETACH I/O ASSOCIATION FROM NAME
10388: BRN EXNUL RETURN NULL RESULT
10389: EJC
10390: *
10391: * DIFFER
10392: *
10393: S$DIF ENT ENTRY POINT
10394: MOV (XS)+,XR LOAD SECOND ARGUMENT
10395: MOV (XS)+,XL LOAD FIRST ARGUMENT
10396: JSR IDENT CALL IDENT COMPARISON ROUTINE
10397: PPM EXFAL FAIL IF IDENT
10398: BRN EXNUL RETURN NULL IF DIFFER
10399: EJC
10400: *
10401: * DUMP
10402: *
10403: S$DMP ENT ENTRY POINT
10404: JSR GTSMI LOAD DUMP ARG AS SMALL INTEGER
10405: ERR 088,DUMP ARGUMENT IS NOT INTEGER
10406: ERR 089,DUMP ARGUMENT IS NEGATIVE OR TOO LARGE
10407: JSR DUMPR ELSE CALL DUMP ROUTINE
10408: BRN EXNUL AND RETURN NULL AS RESULT
10409: EJC
10410: *
10411: * DUPL
10412: *
10413: S$DUP ENT ENTRY POINT
10414: JSR GTSMI GET SECOND ARGUMENT AS SMALL INTEGE
10415: ERR 090,DUPL SECOND ARGUMENT IS NOT INTEGER
10416: PPM SDUP7 JUMP IF NEGATIVE OT TOO BIG
10417: MOV XR,WB SAVE DUPLICATION FACTOR
10418: JSR GTSTG GET FIRST ARG AS STRING
10419: PPM SDUP4 JUMP IF NOT A STRING
10420: *
10421: * HERE FOR CASE OF DUPLICATION OF A STRING
10422: *
10423: MTI WA ACQUIRE LENGTH AS INTEGER
10424: STI DUPSI SAVE FOR THE MOMENT
10425: MTI WB GET DUPLICATION FACTOR AS INTEGER
10426: MLI DUPSI FORM PRODUCT
10427: IOV SDUP3 JUMP IF OVERFLOW
10428: IEQ EXNUL RETURN NULL IF RESULT LENGTH = 0
10429: MFI WA,SDUP3 GET AS ADDR INTEGER, CHECK OVFLO
10430: *
10431: * MERGE HERE WITH RESULT LENGTH IN WA
10432: *
10433: SDUP1 MOV XR,XL SAVE STRING POINTER
10434: JSR ALOCS ALLOCATE SPACE FOR STRING
10435: MOV XR,-(XS) SAVE AS RESULT POINTER
10436: MOV XL,WC SAVE POINTER TO ARGUMENT STRING
10437: PSC XR PREPARE TO STORE CHARS OF RESULT
10438: LCT WB,WB SET COUNTER TO CONTROL LOOP
10439: *
10440: * LOOP THROUGH DUPLICATIONS
10441: *
10442: SDUP2 MOV WC,XL POINT BACK TO ARGUMENT STRING
10443: MOV SCLEN(XL),WA GET NUMBER OF CHARACTERS
10444: PLC XL POINT TO CHARS IN ARGUMENT STRING
10445: MVC MOVE CHARACTERS TO RESULT STRING
10446: BCT WB,SDUP2 LOOP TILL ALL DUPLICATIONS DONE
10447: BRN EXITS THEN EXIT FOR NEXT CODE WORD
10448: EJC
10449: *
10450: * DUPL (CONTINUED)
10451: *
10452: * HERE IF TOO LARGE, SET MAX LENGTH AND LET ALOCS CATCH IT
10453: *
10454: SDUP3 MOV DNAME,WA SET IMPOSSIBLE LENGTH FOR ALOCS
10455: BRN SDUP1 MERGE BACK
10456: *
10457: * HERE IF NOT A STRING
10458: *
10459: SDUP4 JSR GTPAT CONVERT ARGUMENT TO PATTERN
10460: ERR 091,DUPL FIRST ARGUMENT IS NOT STRING OR PATTERN
10461: *
10462: * HERE TO DUPLICATE A PATTERN ARGUMENT
10463: *
10464: MOV XR,-(XS) STORE PATTERN ON STACK
10465: MOV =NDNTH,XR START OFF WITH NULL PATTERN
10466: BZE WB,SDUP6 NULL PATTERN IS RESULT IF DUPFAC=0
10467: MOV WB,-(XS) PRESERVE LOOP COUNT
10468: *
10469: * LOOP TO DUPLICATE BY SUCCESSIVE CONCATENATION
10470: *
10471: SDUP5 MOV XR,XL COPY CURRENT VALUE AS RIGHT ARGUMNT
10472: MOV 1(XS),XR GET A NEW COPY OF LEFT
10473: JSR PCONC CONCATENATE
10474: DCV (XS) COUNT DOWN
10475: BNZ (XS),SDUP5 LOOP
10476: ICA XS POP LOOP COUNT
10477: *
10478: * HERE TO EXIT AFTER CONSTRUCTING PATTERN
10479: *
10480: SDUP6 MOV XR,(XS) STORE RESULT ON STACK
10481: BRN EXITS EXIT WITH RESULT ON STACK
10482: *
10483: * FAIL IF SECOND ARG IS OUT OF RANGE
10484: *
10485: SDUP7 ICA XS POP FIRST ARGUMENT
10486: BRN EXFAL FAIL
10487: EJC
10488: *
10489: * EJECT
10490: *
10491: S$EJC ENT ENTRY POINT
10492: JSR IOFCB CALL FCBLK ROUTINE
10493: ERR 092,EJECT ARGUMENT IS NOT A SUITABLE NAME
10494: PPM SEJC1 NULL ARGUMENT
10495: JSR SYSEF CALL EJECT FILE FUNCTION
10496: ERR 093,EJECT FILE DOES NOT EXIST
10497: ERR 094,EJECT FILE DOES NOT PERMIT PAGE EJECT
10498: ERR 095,EJECT CAUSED NON-RECOVERABLE OUTPUT ERROR
10499: BRN EXNUL RETURN NULL AS RESULT
10500: *
10501: * HERE TO EJECT STANDARD OUTPUT FILE
10502: *
10503: SEJC1 JSR SYSEP CALL ROUTINE TO EJECT PRINTER
10504: BRN EXNUL EXIT WITH NULL RESULT
10505: EJC
10506: *
10507: * ENDFILE
10508: *
10509: S$ENF ENT ENTRY POINT
10510: JSR IOFCB CALL FCBLK ROUTINE
10511: ERR 096,ENDFILE ARGUMENT IS NOT A SUITABLE NAME
10512: ERR 097,ENDFILE ARGUMENT IS NULL
10513: JSR SYSEN CALL ENDFILE ROUTINE
10514: ERR 098,ENDFILE FILE DOES NOT EXIST
10515: ERR 099,ENDFILE FILE DOES NOT PERMIT ENDFILE
10516: ERR 100,ENDFILE CAUSED NON-RECOVERABLE OUTPUT ERROR
10517: MOV XL,WB REMEMBER VRBLK PTR FROM IOFCB CALL
10518: *
10519: * LOOP TO FIND TRTRF BLOCK
10520: *
10521: SENF1 MOV XL,XR COPY POINTER
10522: MOV TRVAL(XR),XR CHAIN ALONG
10523: BNE (XR),=B$TRT,EXNUL SKIP OUT IF CHAIN END
10524: BNE TRTYP(XR),=TRTFC,SENF1 LOOP IF NOT FOUND
10525: MOV TRVAL(XR),TRVAL(XL) REMOVE TRTRF
10526: MOV TRTRF(XR),ENFCH POINT TO HEAD OF IOCHN
10527: MOV TRFPT(XR),WC POINT TO FCBLK
10528: MOV WB,XR FILEARG1 VRBLK FROM IOFCB
10529: JSR SETVR RESET IT
10530: MOV =R$FCB,XL PTR TO HEAD OF FCBLK CHAIN
10531: SUB *NUM02,XL ADJUST READY TO ENTER LOOP
10532: *
10533: * FIND FCBLK
10534: *
10535: SENF2 MOV XL,XR COPY PTR
10536: MOV 2(XL),XL GET NEXT LINK
10537: BZE XL,SENF4 STOP IF CHAIN END
10538: BEQ 3(XL),WC,SENF3 JUMP IF FCBLK FOUND
10539: BRN SENF2 LOOP
10540: *
10541: * REMOVE FCBLK
10542: *
10543: SENF3 MOV 2(XL),2(XR) DELETE FCBLK FROM CHAIN
10544: *
10545: * LOOP WHICH DETACHES ALL VBLS ON IOCHN CHAIN
10546: *
10547: SENF4 MOV ENFCH,XL GET CHAIN HEAD
10548: BZE XL,EXNUL FINISHED IF CHAIN END
10549: MOV TRTRF(XL),ENFCH CHAIN ALONG
10550: MOV IONMO(XL),WA NAME OFFSET
10551: MOV IONMB(XL),XL NAME BASE
10552: JSR DTACH DETACH NAME
10553: BRN SENF4 LOOP TILL DONE
10554: EJC
10555: *
10556: * EQ
10557: *
10558: S$EQF ENT ENTRY POINT
10559: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
10560: ERR 101,EQ FIRST ARGUMENT IS NOT NUMERIC
10561: ERR 102,EQ SECOND ARGUMENT IS NOT NUMERIC
10562: PPM EXFAL FAIL IF LT
10563: PPM EXNUL RETURN NULL IF EQ
10564: PPM EXFAL FAIL IF GT
10565: EJC
10566: *
10567: * EVAL
10568: *
10569: S$EVL ENT ENTRY POINT
10570: MOV (XS)+,XR LOAD ARGUMENT
10571: JSR GTEXP CONVERT TO EXPRESSION
10572: ERR 103,EVAL ARGUMENT IS NOT EXPRESSION
10573: LCW WC LOAD NEXT CODE WORD
10574: BNE WC,=OFNE$,SEVL1 JUMP IF CALLED BY VALUE
10575: SCP XL COPY CODE POINTER
10576: MOV (XL),WA GET NEXT CODE WORD
10577: BNE WA,=ORNM$,SEVL2 BY NAME UNLESS EXPRESSION
10578: BNZ 1(XS),SEVL2 JUMP IF BY NAME
10579: *
10580: * HERE IF CALLED BY VALUE
10581: *
10582: SEVL1 ZER WB SET FLAG FOR BY VALUE
10583: MOV WC,-(XS) SAVE CODE WORD
10584: JSR EVALX EVALUATE EXPRESSION BY VALUE
10585: PPM EXFAL FAIL IF EVALUATION FAILS
10586: MOV XR,XL COPY RESULT
10587: MOV (XS),XR RELOAD NEXT CODE WORD
10588: MOV XL,(XS) STACK RESULT
10589: BRI (XR) JUMP TO EXECUTE NEXT CODE WORD
10590: *
10591: * HERE IF CALLED BY NAME
10592: *
10593: SEVL2 MOV =NUM01,WB SET FLAG FOR BY NAME
10594: JSR EVALX EVALUATE EXPRESSION BY NAME
10595: PPM EXFAL FAIL IF EVALUATION FAILS
10596: BRN EXNAM EXIT WITH NAME
10597: EJC
10598: *
10599: * EXIT
10600: *
10601: S$EXT ENT ENTRY POINT
10602: ZER WB CLEAR AMOUNT OF STATIC SHIFT
10603: JSR GBCOL COMPACT MEMORY BY COLLECTING
10604: JSR GTSTG CONVERT ARG TO STRING
10605: ERR 104,EXIT ARGUMENT IS NOT SUITABLE INTEGER OR STRING
10606: MOV XR,XL COPY STRING PTR
10607: JSR GTINT CHECK IT IS INTEGER
10608: PPM SEXT1 SKIP IF UNCONVERTIBLE
10609: ZER XL NOTE IT IS INTEGER
10610: LDI ICVAL(XR) GET INTEGER ARG
10611: MOV R$FCB,WB GET FCBLK CHAIN HEADER
10612: *
10613: * MERGE TO CALL OSINT EXIT ROUTINE
10614: *
10615: SEXT1 MOV =HEADV,XR POINT TO V.V STRING
10616: JSR SYSXI CALL EXTERNAL ROUTINE
10617: ERR 105,EXIT ACTION NOT AVAILABLE IN THIS IMPLEMENTATION
10618: ERR 106,EXIT ACTION CAUSED IRRECOVERABLE ERROR
10619: IEQ EXNUL RETURN IF ARGUMENT 0
10620: ZER GBCNT RESUMING EXECUTION SO RESET
10621: IGT SEXT2 SKIP IF POSITIVE
10622: NGI MAKE POSITIVE
10623: *
10624: * CHECK FOR OPTION RESPECIFICATION
10625: *
10626: SEXT2 MFI WC GET VALUE IN WORK REG
10627: BEQ WC,=NUM03,SEXT3 SKIP IF WAS 3
10628: MOV WC,-(XS) SAVE VALUE
10629: ZER WC SET TO READ OPTIONS
10630: JSR PRPAR READ SYSPP OPTIONS
10631: MOV (XS)+,WC RESTORE VALUE
10632: *
10633: * DEAL WITH HEADER OPTION (FIDDLED BY PRPAR)
10634: *
10635: SEXT3 MNZ HEADP ASSUME NO HEADERS
10636: BNE WC,=NUM01,SEXT4 SKIP IF NOT 1
10637: ZER HEADP REQUEST HEADER PRINTING
10638: *
10639: * ALMOST READY TO RESUME RUNNING
10640: *
10641: SEXT4 JSR SYSTM GET EXECUTION TIME START (SGD11)
10642: STI TIMSX SAVE AS INITIAL TIME
10643: LDI KVSTC RESET TO ENSURE ...
10644: STI KVSTL ... CORRECT EXECUTION STATS
10645: BRN EXNUL RESUME EXECUTION
10646: EJC
10647: *
10648: * FIELD
10649: *
10650: S$FLD ENT ENTRY POINT
10651: JSR GTSMI GET SECOND ARGUMENT (FIELD NUMBER)
10652: ERR 107,FIELD SECOND ARGUMENT IS NOT INTEGER
10653: PPM EXFAL FAIL IF OUT OF RANGE
10654: MOV XR,WB ELSE SAVE INTEGER VALUE
10655: MOV (XS)+,XR LOAD FIRST ARGUMENT
10656: JSR GTNVR POINT TO VRBLK
10657: PPM SFLD1 JUMP (ERROR) IF NOT VARIABLE NAME
10658: MOV VRFNC(XR),XR ELSE POINT TO FUNCTION BLOCK
10659: BNE (XR),=B$DFC,SFLD1 ERROR IF NOT DATATYPE FUNCTION
10660: *
10661: * HERE IF FIRST ARGUMENT IS A DATATYPE FUNCTION NAME
10662: *
10663: BZE WB,EXFAL FAIL IF ARGUMENT NUMBER IS ZERO
10664: BGT WB,FARGS(XR),EXFAL FAIL IF TOO LARGE
10665: WTB WB ELSE CONVERT TO BYTE OFFSET
10666: ADD WB,XR POINT TO FIELD NAME
10667: MOV DFFLB(XR),XR LOAD VRBLK POINTER
10668: BRN EXVNM EXIT TO BUILD NMBLK
10669: *
10670: * HERE FOR BAD FIRST ARGUMENT
10671: *
10672: SFLD1 ERB 108,FIELD FIRST ARGUMENT IS NOT DATATYPE NAME
10673: EJC
10674: *
10675: * FENCE
10676: *
10677: S$FNC ENT ENTRY POINT
10678: MOV =P$FNC,WB SET PCODE FOR P$FNC
10679: ZER XR P0BLK
10680: JSR PBILD BUILD P$FNC NODE
10681: MOV XR,XL SAVE POINTER TO IT
10682: MOV (XS)+,XR GET ARGUMENT
10683: JSR GTPAT CONVERT TO PATTERN
10684: ERR 259,FENCE ARGUMENT IS NOT PATTERN
10685: JSR PCONC CONCATENATE TO P$FNC NODE
10686: MOV XR,XL SAVE PTR TO CONCATENATED PATTERN
10687: MOV =P$FNA,WB SET FOR P$FNA PCODE
10688: ZER XR P0BLK
10689: JSR PBILD CONSTRUCT P$FNA NODE
10690: MOV XL,PTHEN(XR) SET PATTERN AS PTHEN
10691: MOV XR,-(XS) SET AS RESULT
10692: BRN EXITS DO NEXT CODE WORD
10693: EJC
10694: *
10695: * GE
10696: *
10697: S$GEF ENT ENTRY POINT
10698: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
10699: ERR 109,GE FIRST ARGUMENT IS NOT NUMERIC
10700: ERR 110,GE SECOND ARGUMENT IS NOT NUMERIC
10701: PPM EXFAL FAIL IF LT
10702: PPM EXNUL RETURN NULL IF EQ
10703: PPM EXNUL RETURN NULL IF GT
10704: EJC
10705: *
10706: * GT
10707: *
10708: S$GTF ENT ENTRY POINT
10709: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
10710: ERR 111,GT FIRST ARGUMENT IS NOT NUMERIC
10711: ERR 112,GT SECOND ARGUMENT IS NOT NUMERIC
10712: PPM EXFAL FAIL IF LT
10713: PPM EXFAL FAIL IF EQ
10714: PPM EXNUL RETURN NULL IF GT
10715: EJC
10716: *
10717: * HOST
10718: *
10719: S$HST ENT ENTRY POINT
10720: MOV (XS)+,XR GET THIRD ARG
10721: MOV (XS)+,XL GET SECOND ARG
10722: MOV (XS)+,WA GET FIRST ARG
10723: JSR SYSHS ENTER SYSHS ROUTINE
10724: ERR 254,ERRONEOUS ARGUMENT FOR HOST
10725: ERR 255,ERROR DURING EXECUTION OF HOST
10726: PPM SHST1 STORE HOST STRING
10727: PPM EXNUL RETURN NULL RESULT
10728: PPM EXIXR RETURN XR
10729: PPM EXFAL FAIL RETURN
10730: *
10731: * RETURN HOST STRING
10732: *
10733: SHST1 BZE XL,EXNUL NULL STRING IF SYSHS UNCOOPERATIVE
10734: MOV SCLEN(XL),WA LENGTH
10735: ZER WB ZERO OFFSET
10736: JSR SBSTR BUILD COPY OF STRING
10737: MOV XR,-(XS) STACK THE RESULT
10738: BRN EXITS RETURN RESULT ON STACK
10739: EJC
10740: *
10741: * IDENT
10742: *
10743: S$IDN ENT ENTRY POINT
10744: MOV (XS)+,XR LOAD SECOND ARGUMENT
10745: MOV (XS)+,XL LOAD FIRST ARGUMENT
10746: JSR IDENT CALL IDENT COMPARISON ROUTINE
10747: PPM EXNUL RETURN NULL IF IDENT
10748: BRN EXFAL FAIL IF DIFFER
10749: EJC
10750: *
10751: * INPUT
10752: *
10753: S$INP ENT ENTRY POINT
10754: ZER WB INPUT FLAG
10755: JSR IOPUT CALL INPUT/OUTPUT ASSOC. ROUTINE
10756: ERR 113,INPUT THIRD ARGUMENT IS NOT A STRING
10757: ERR 114,INAPPROPRIATE SECOND ARGUMENT FOR INPUT
10758: ERR 115,INAPPROPRIATE FIRST ARGUMENT FOR INPUT
10759: ERR 116,INAPPROPRIATE FILE SPECIFICATION FOR INPUT
10760: PPM EXFAL FAIL IF FILE DOES NOT EXIST
10761: ERR 117,INPUT FILE CANNOT BE READ
10762: BRN EXNUL RETURN NULL STRING
10763: EJC
10764: *
10765: * INSERT
10766: *
10767: S$INS ENT ENTRY POINT
10768: MOV (XS)+,XL GET STRING ARG
10769: JSR GTSMI GET REPLACE LENGTH
10770: ERR 277,INSERT THIRD ARGUMENT NOT INTEGER
10771: PPM EXFAL FAIL IF OUT OF RANGE
10772: MOV WC,WB COPY TO PROPER REG
10773: JSR GTSMI GET REPLACE POSITION
10774: ERR 278,INSERT SECOND ARGUMENT NOT INTEGER
10775: PPM EXFAL FAIL IF OUT OF RANGE
10776: BZE WC,EXFAL FAIL IF ZERO
10777: DCV WC DECREMENT TO GET OFFSET
10778: MOV WC,WA PUT IN PROPER REGISTER
10779: MOV (XS)+,XR GET BUFFER
10780: BEQ (XR),=B$BCT,SINS1 PRESS ON IF TYPE OK
10781: ERB 279,INSERT FIRST ARGUMENT NOT BUFFER
10782: *
10783: * HERE WHEN EVERYTHING LOADED UP
10784: *
10785: SINS1 JSR INSBF CALL TO INSERT
10786: ERR 280,INSERT FOURTH ARGUMENT NOT A STRING
10787: PPM EXFAL FAIL IF OUT OF RANGE
10788: BRN EXNUL ELSE OK - EXIT WITH NULL
10789: EJC
10790: *
10791: * INTEGER
10792: *
10793: S$INT ENT ENTRY POINT
10794: MOV (XS)+,XR LOAD ARGUMENT
10795: JSR GTNUM CONVERT TO NUMERIC
10796: PPM EXFAL FAIL IF NON-NUMERIC
10797: BEQ WA,=B$ICL,EXNUL RETURN NULL IF INTEGER
10798: BRN EXFAL FAIL IF REAL
10799: EJC
10800: *
10801: * ITEM
10802: *
10803: * ITEM DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT
10804: * WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED.
10805: *
10806: S$ITM ENT ENTRY POINT
10807: *
10808: * DEAL WITH CASE OF NO ARGS
10809: *
10810: BNZ WA,SITM1 JUMP IF AT LEAST ONE ARG
10811: MOV =NULLS,-(XS) ELSE SUPPLY GARBAGE NULL ARG
10812: MOV =NUM01,WA AND FIX ARGUMENT COUNT
10813: *
10814: * CHECK FOR NAME/VALUE CASES
10815: *
10816: SITM1 SCP XR GET CURRENT CODE POINTER
10817: MOV (XR),XL LOAD NEXT CODE WORD
10818: DCV WA GET NUMBER OF SUBSCRIPTS
10819: MOV WA,XR COPY FOR ARREF
10820: BEQ XL,=OFNE$,SITM2 JUMP IF CALLED BY NAME
10821: *
10822: * HERE IF CALLED BY VALUE
10823: *
10824: ZER WB SET CODE FOR CALL BY VALUE
10825: BRN ARREF OFF TO ARRAY REFERENCE ROUTINE
10826: *
10827: * HERE FOR CALL BY NAME
10828: *
10829: SITM2 MNZ WB SET CODE FOR CALL BY NAME
10830: LCW WA LOAD AND IGNORE OFNE$ CALL
10831: BRN ARREF OFF TO ARRAY REFERENCE ROUTINE
10832: EJC
10833: *
10834: * LE
10835: *
10836: S$LEF ENT ENTRY POINT
10837: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
10838: ERR 118,LE FIRST ARGUMENT IS NOT NUMERIC
10839: ERR 119,LE SECOND ARGUMENT IS NOT NUMERIC
10840: PPM EXNUL RETURN NULL IF LT
10841: PPM EXNUL RETURN NULL IF EQ
10842: PPM EXFAL FAIL IF GT
10843: EJC
10844: *
10845: * LEN
10846: *
10847: S$LEN ENT ENTRY POINT
10848: MOV =P$LEN,WB SET PCODE FOR INTEGER ARG CASE
10849: MOV =P$LND,WA SET PCODE FOR EXPR ARG CASE
10850: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE
10851: ERR 120,LEN ARGUMENT IS NOT INTEGER OR EXPRESSION
10852: ERR 121,LEN ARGUMENT IS NEGATIVE OR TOO LARGE
10853: BRN EXIXR RETURN PATTERN NODE
10854: EJC
10855: *
10856: * LEQ
10857: *
10858: S$LEQ ENT ENTRY POINT
10859: JSR LCOMP CALL STRING COMPARISON ROUTINE
10860: ERR 122,LEQ FIRST ARGUMENT IS NOT STRING
10861: ERR 123,LEQ SECOND ARGUMENT IS NOT STRING
10862: PPM EXFAL FAIL IF LLT
10863: PPM EXNUL RETURN NULL IF LEQ
10864: PPM EXFAL FAIL IF LGT
10865: EJC
10866: *
10867: * LGE
10868: *
10869: S$LGE ENT ENTRY POINT
10870: JSR LCOMP CALL STRING COMPARISON ROUTINE
10871: ERR 124,LGE FIRST ARGUMENT IS NOT STRING
10872: ERR 125,LGE SECOND ARGUMENT IS NOT STRING
10873: PPM EXFAL FAIL IF LLT
10874: PPM EXNUL RETURN NULL IF LEQ
10875: PPM EXNUL RETURN NULL IF LGT
10876: EJC
10877: *
10878: * LGT
10879: *
10880: S$LGT ENT ENTRY POINT
10881: JSR LCOMP CALL STRING COMPARISON ROUTINE
10882: ERR 126,LGT FIRST ARGUMENT IS NOT STRING
10883: ERR 127,LGT SECOND ARGUMENT IS NOT STRING
10884: PPM EXFAL FAIL IF LLT
10885: PPM EXFAL FAIL IF LEQ
10886: PPM EXNUL RETURN NULL IF LGT
10887: EJC
10888: *
10889: * LLE
10890: *
10891: S$LLE ENT ENTRY POINT
10892: JSR LCOMP CALL STRING COMPARISON ROUTINE
10893: ERR 128,LLE FIRST ARGUMENT IS NOT STRING
10894: ERR 129,LLE SECOND ARGUMENT IS NOT STRING
10895: PPM EXNUL RETURN NULL IF LLT
10896: PPM EXNUL RETURN NULL IF LEQ
10897: PPM EXFAL FAIL IF LGT
10898: EJC
10899: *
10900: * LLT
10901: *
10902: S$LLT ENT ENTRY POINT
10903: JSR LCOMP CALL STRING COMPARISON ROUTINE
10904: ERR 130,LLT FIRST ARGUMENT IS NOT STRING
10905: ERR 131,LLT SECOND ARGUMENT IS NOT STRING
10906: PPM EXNUL RETURN NULL IF LLT
10907: PPM EXFAL FAIL IF LEQ
10908: PPM EXFAL FAIL IF LGT
10909: EJC
10910: *
10911: * LNE
10912: *
10913: S$LNE ENT ENTRY POINT
10914: JSR LCOMP CALL STRING COMPARISON ROUTINE
10915: ERR 132,LNE FIRST ARGUMENT IS NOT STRING
10916: ERR 133,LNE SECOND ARGUMENT IS NOT STRING
10917: PPM EXNUL RETURN NULL IF LLT
10918: PPM EXFAL FAIL IF LEQ
10919: PPM EXNUL RETURN NULL IF LGT
10920: EJC
10921: *
10922: * LOCAL
10923: *
10924: S$LOC ENT ENTRY POINT
10925: JSR GTSMI GET SECOND ARGUMENT (LOCAL NUMBER)
10926: ERR 134,LOCAL SECOND ARGUMENT IS NOT INTEGER
10927: PPM EXFAL FAIL IF OUT OF RANGE
10928: MOV XR,WB SAVE LOCAL NUMBER
10929: MOV (XS)+,XR LOAD FIRST ARGUMENT
10930: JSR GTNVR POINT TO VRBLK
10931: PPM SLOC1 JUMP IF NOT VARIABLE NAME
10932: MOV VRFNC(XR),XR ELSE LOAD FUNCTION POINTER
10933: BNE (XR),=B$PFC,SLOC1 JUMP IF NOT PROGRAM DEFINED
10934: *
10935: * HERE IF WE HAVE A PROGRAM DEFINED FUNCTION NAME
10936: *
10937: BZE WB,EXFAL FAIL IF SECOND ARG IS ZERO
10938: BGT WB,PFNLO(XR),EXFAL OR TOO LARGE
10939: ADD FARGS(XR),WB ELSE ADJUST OFFSET TO INCLUDE ARGS
10940: WTB WB CONVERT TO BYTES
10941: ADD WB,XR POINT TO LOCAL POINTER
10942: MOV PFAGB(XR),XR LOAD VRBLK POINTER
10943: BRN EXVNM EXIT BUILDING NMBLK
10944: *
10945: * HERE IF FIRST ARGUMENT IS NO GOOD
10946: *
10947: SLOC1 ERB 135,LOCAL FIRST ARG IS NOT A PROGRAM FUNCTION NAME
10948: EJC
10949: *
10950: * LOAD
10951: *
10952: S$LOD ENT ENTRY POINT
10953: JSR GTSTG LOAD LIBRARY NAME
10954: ERR 136,LOAD SECOND ARGUMENT IS NOT STRING
10955: MOV XR,XL SAVE LIBRARY NAME
10956: JSR XSCNI PREPARE TO SCAN FIRST ARGUMENT
10957: ERR 137,LOAD FIRST ARGUMENT IS NOT STRING
10958: ERR 138,LOAD FIRST ARGUMENT IS NULL
10959: MOV XL,-(XS) STACK LIBRARY NAME
10960: MOV =CH$PP,WC SET DELIMITER ONE = LEFT PAREN
10961: MOV WC,XL SET DELIMITER TWO = LEFT PAREN
10962: JSR XSCAN SCAN FUNCTION NAME
10963: MOV XR,-(XS) SAVE PTR TO FUNCTION NAME
10964: BNZ WA,SLOD1 JUMP IF LEFT PAREN FOUND
10965: ERB 139,LOAD FIRST ARGUMENT IS MISSING A LEFT PAREN
10966: *
10967: * HERE AFTER SUCCESSFULLY SCANNING FUNCTION NAME
10968: *
10969: SLOD1 JSR GTNVR LOCATE VRBLK
10970: ERR 140,LOAD FIRST ARGUMENT HAS NULL FUNCTION NAME
10971: MOV XR,LODFN SAVE VRBLK POINTER
10972: ZER LODNA ZERO COUNT OF ARGUMENTS
10973: *
10974: * LOOP TO SCAN ARGUMENT DATATYPE NAMES
10975: *
10976: SLOD2 MOV =CH$RP,WC DELIMITER ONE IS RIGHT PAREN
10977: MOV =CH$CM,XL DELIMITER TWO IS COMMA
10978: JSR XSCAN SCAN NEXT ARGUMENT NAME
10979: ICV LODNA BUMP ARGUMENT COUNT
10980: BNZ WA,SLOD3 JUMP IF OK DELIMITER WAS FOUND
10981: ERB 141,LOAD FIRST ARGUMENT IS MISSING A RIGHT PAREN
10982: EJC
10983: *
10984: * LOAD (CONTINUED)
10985: *
10986: * COME HERE TO ANALYZE THE DATATYPE POINTER IN (XR). THIS
10987: * CODE IS USED BOTH FOR ARGUMENTS (WA=1,2) AND FOR THE
10988: * RESULT DATATYPE (WITH WA SET TO ZERO).
10989: *
10990: SLOD3 MOV XR,-(XS) STACK DATATYPE NAME POINTER
10991: MOV =NUM01,WB SET STRING CODE IN CASE
10992: MOV =SCSTR,XL POINT TO /STRING/
10993: JSR IDENT CHECK FOR MATCH
10994: PPM SLOD4 JUMP IF MATCH
10995: MOV (XS),XR ELSE RELOAD NAME
10996: ADD WB,WB SET CODE FOR INTEGER (2)
10997: MOV =SCINT,XL POINT TO /INTEGER/
10998: JSR IDENT CHECK FOR MATCH
10999: PPM SLOD4 JUMP IF MATCH
11000: MOV (XS),XR ELSE RELOAD STRING POINTER
11001: ICV WB SET CODE FOR REAL (3)
11002: MOV =SCREA,XL POINT TO /REAL/
11003: JSR IDENT CHECK FOR MATCH
11004: PPM SLOD4 JUMP IF MATCH
11005: ZER WB ELSE GET CODE FOR NO CONVERT
11006: *
11007: * MERGE HERE WITH PROPER DATATYPE CODE IN WB
11008: *
11009: SLOD4 MOV WB,(XS) STORE CODE ON STACK
11010: BEQ WA,=NUM02,SLOD2 LOOP BACK IF ARG STOPPED BY COMMA
11011: BZE WA,SLOD5 JUMP IF THAT WAS THE RESULT TYPE
11012: *
11013: * HERE WE SCAN OUT THE RESULT TYPE (ARG STOPPED BY ) )
11014: *
11015: MOV MXLEN,WC SET DUMMY (IMPOSSIBLE) DELIMITER 1
11016: MOV WC,XL AND DELIMITER TWO
11017: JSR XSCAN SCAN RESULT NAME
11018: ZER WA SET CODE FOR PROCESSING RESULT
11019: BRN SLOD3 JUMP BACK TO PROCESS RESULT NAME
11020: EJC
11021: *
11022: * LOAD (CONTINUED)
11023: *
11024: * HERE AFTER PROCESSING ALL ARGS AND RESULT
11025: *
11026: SLOD5 MOV LODNA,WA GET NUMBER OF ARGUMENTS
11027: MOV WA,WC COPY FOR LATER
11028: WTB WA CONVERT LENGTH TO BYTES
11029: ADD *EFSI$,WA ADD SPACE FOR STANDARD FIELDS
11030: JSR ALLOC ALLOCATE EFBLK
11031: MOV =B$EFC,(XR) SET TYPE WORD
11032: MOV WC,FARGS(XR) SET NUMBER OF ARGUMENTS
11033: ZER EFUSE(XR) SET USE COUNT (DFFNC WILL SET TO 1)
11034: ZER EFCOD(XR) ZERO CODE POINTER FOR NOW
11035: MOV (XS)+,EFRSL(XR) STORE RESULT TYPE CODE
11036: MOV LODFN,EFVAR(XR) STORE FUNCTION VRBLK POINTER
11037: MOV WA,EFLEN(XR) STORE EFBLK LENGTH
11038: MOV XR,WB SAVE EFBLK POINTER
11039: ADD WA,XR POINT PAST END OF EFBLK
11040: LCT WC,WC SET NUMBER OF ARGUMENTS FOR LOOP
11041: *
11042: * LOOP TO SET ARGUMENT TYPE CODES FROM STACK
11043: *
11044: SLOD6 MOV (XS)+,-(XR) STORE ONE TYPE CODE FROM STACK
11045: BCT WC,SLOD6 LOOP TILL ALL STORED
11046: *
11047: * NOW LOAD THE EXTERNAL FUNCTION AND PERFORM DEFINITION
11048: *
11049: MOV (XS)+,XR LOAD FUNCTION STRING NAME
11050: MOV (XS),XL LOAD LIBRARY NAME
11051: MOV WB,(XS) STORE EFBLK POINTER
11052: JSR SYSLD CALL FUNCTION TO LOAD EXTERNAL FUNC
11053: ERR 142,LOAD FUNCTION DOES NOT EXIST
11054: ERR 143,LOAD FUNCTION CAUSED INPUT ERROR DURING LOAD
11055: MOV (XS)+,XL RECALL EFBLK POINTER
11056: MOV XR,EFCOD(XL) STORE CODE POINTER
11057: MOV LODFN,XR POINT TO VRBLK FOR FUNCTION
11058: JSR DFFNC PERFORM FUNCTION DEFINITION
11059: BRN EXNUL RETURN NULL RESULT
11060: EJC
11061: *
11062: * LPAD
11063: *
11064: S$LPD ENT ENTRY POINT
11065: JSR GTSTG GET PAD CHARACTER
11066: ERR 144,LPAD THIRD ARGUMENT NOT A STRING
11067: PLC XR POINT TO CHARACTER (NULL IS BLANK)
11068: LCH WB,(XR) LOAD PAD CHARACTER
11069: JSR GTSMI GET PAD LENGTH
11070: ERR 145,LPAD SECOND ARGUMENT IS NOT INTEGER
11071: PPM SLPD3 SKIP IF NEGATIVE OR LARGE
11072: *
11073: * MERGE TO CHECK FIRST ARG
11074: *
11075: SLPD1 JSR GTSTG GET FIRST ARGUMENT (STRING TO PAD)
11076: ERR 146,LPAD FIRST ARGUMENT IS NOT STRING
11077: BGE WA,WC,EXIXR RETURN 1ST ARG IF TOO LONG TO PAD
11078: MOV XR,XL ELSE MOVE PTR TO STRING TO PAD
11079: *
11080: * NOW WE ARE READY FOR THE PAD
11081: *
11082: * (XL) POINTER TO STRING TO PAD
11083: * (WB) PAD CHARACTER
11084: * (WC) LENGTH TO PAD STRING TO
11085: *
11086: MOV WC,WA COPY LENGTH
11087: JSR ALOCS ALLOCATE SCBLK FOR NEW STRING
11088: MOV XR,-(XS) SAVE AS RESULT
11089: MOV SCLEN(XL),WA LOAD LENGTH OF ARGUMENT
11090: SUB WA,WC CALCULATE NUMBER OF PAD CHARACTERS
11091: PSC XR POINT TO CHARS IN RESULT STRING
11092: LCT WC,WC SET COUNTER FOR PAD LOOP
11093: *
11094: * LOOP TO PERFORM PAD
11095: *
11096: SLPD2 SCH WB,(XR)+ STORE PAD CHARACTER, BUMP PTR
11097: BCT WC,SLPD2 LOOP TILL ALL PAD CHARS STORED
11098: CSC XR COMPLETE STORE CHARACTERS
11099: *
11100: * NOW COPY STRING
11101: *
11102: BZE WA,EXITS EXIT IF NULL STRING
11103: PLC XL ELSE POINT TO CHARS IN ARGUMENT
11104: MVC MOVE CHARACTERS TO RESULT STRING
11105: BRN EXITS JUMP FOR NEXT CODE WORD
11106: *
11107: * HERE IF 2ND ARG IS NEGATIVE OR LARGE
11108: *
11109: SLPD3 ZER WC ZERO PAD COUNT
11110: BRN SLPD1 MERGE
11111: EJC
11112: *
11113: * LT
11114: *
11115: S$LTF ENT ENTRY POINT
11116: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
11117: ERR 147,LT FIRST ARGUMENT IS NOT NUMERIC
11118: ERR 148,LT SECOND ARGUMENT IS NOT NUMERIC
11119: PPM EXNUL RETURN NULL IF LT
11120: PPM EXFAL FAIL IF EQ
11121: PPM EXFAL FAIL IF GT
11122: EJC
11123: *
11124: * NE
11125: *
11126: S$NEF ENT ENTRY POINT
11127: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
11128: ERR 149,NE FIRST ARGUMENT IS NOT NUMERIC
11129: ERR 150,NE SECOND ARGUMENT IS NOT NUMERIC
11130: PPM EXNUL RETURN NULL IF LT
11131: PPM EXFAL FAIL IF EQ
11132: PPM EXNUL RETURN NULL IF GT
11133: EJC
11134: *
11135: * NOTANY
11136: *
11137: S$NAY ENT ENTRY POINT
11138: MOV =P$NAS,WB SET PCODE FOR SINGLE CHAR ARG
11139: MOV =P$NAY,XL PCODE FOR MULTI-CHAR ARG
11140: MOV =P$NAD,WC SET PCODE FOR EXPR ARG
11141: JSR PATST CALL COMMON ROUTINE TO BUILD NODE
11142: ERR 151,NOTANY ARGUMENT IS NOT STRING OR EXPRESSION
11143: BRN EXIXR JUMP FOR NEXT CODE WORD
11144: EJC
11145: *
11146: * OPSYN
11147: *
11148: S$OPS ENT ENTRY POINT
11149: JSR GTSMI LOAD THIRD ARGUMENT
11150: ERR 152,OPSYN THIRD ARGUMENT IS NOT INTEGER
11151: ERR 153,OPSYN THIRD ARGUMENT IS NEGATIVE OR TOO LARGE
11152: MOV WC,WB IF OK, SAVE THIRD ARGUMNET
11153: MOV (XS)+,XR LOAD SECOND ARGUMENT
11154: JSR GTNVR LOCATE VARIABLE BLOCK
11155: ERR 154,OPSYN SECOND ARG IS NOT NATURAL VARIABLE NAME
11156: MOV VRFNC(XR),XL IF OK, LOAD FUNCTION BLOCK POINTER
11157: BNZ WB,SOPS2 JUMP IF OPERATOR OPSYN CASE
11158: *
11159: * HERE FOR FUNCTION OPSYN (THIRD ARG ZERO)
11160: *
11161: MOV (XS)+,XR LOAD FIRST ARGUMENT
11162: JSR GTNVR GET VRBLK POINTER
11163: ERR 155,OPSYN FIRST ARG IS NOT NATURAL VARIABLE NAME
11164: *
11165: * MERGE HERE TO PERFORM FUNCTION DEFINITION
11166: *
11167: SOPS1 JSR DFFNC CALL FUNCTION DEFINER
11168: BRN EXNUL EXIT WITH NULL RESULT
11169: *
11170: * HERE FOR OPERATOR OPSYN (THIRD ARG NON-ZERO)
11171: *
11172: SOPS2 JSR GTSTG GET OPERATOR NAME
11173: PPM SOPS5 JUMP IF NOT STRING
11174: BNE WA,=NUM01,SOPS5 ERROR IF NOT ONE CHAR LONG
11175: PLC XR ELSE POINT TO CHARACTER
11176: LCH WC,(XR) LOAD CHARACTER NAME
11177: EJC
11178: *
11179: * OPSYN (CONTINUED)
11180: *
11181: * NOW SET TO SEARCH FOR MATCHING UNARY OR BINARY OPERATOR
11182: * NAME AS APPROPRIATE. NOTE THAT THERE ARE =OPBUN UNDEFINED
11183: * BINARY OPERATORS AND =OPUUN UNDEFINED UNARY OPERATORS.
11184: *
11185: MOV =R$UUB,WA POINT TO UNOP POINTERS IN CASE
11186: MOV =OPNSU,XR POINT TO NAMES OF UNARY OPERATORS
11187: ADD =OPBUN,WB ADD NO. OF UNDEFINED BINARY OPS
11188: BEQ WB,=OPUUN,SOPS3 JUMP IF UNOP (THIRD ARG WAS 1)
11189: MOV =R$UBA,WA ELSE POINT TO BINARY OPERATOR PTRS
11190: MOV =OPSNB,XR POINT TO NAMES OF BINARY OPERATORS
11191: MOV =OPBUN,WB SET NUMBER OF UNDEFINED BINOPS
11192: *
11193: * MERGE HERE TO CHECK LIST (WB = NUMBER TO CHECK)
11194: *
11195: SOPS3 LCT WB,WB SET COUNTER TO CONTROL LOOP
11196: *
11197: * LOOP TO SEARCH FOR NAME MATCH
11198: *
11199: SOPS4 BEQ WC,(XR),SOPS6 JUMP IF NAMES MATCH
11200: ICA WA ELSE PUSH POINTER TO FUNCTION PTR
11201: ICA XR BUMP POINTER
11202: BCT WB,SOPS4 LOOP BACK TILL ALL CHECKED
11203: *
11204: * HERE IF BAD OPERATOR NAME
11205: *
11206: SOPS5 ERB 156,OPSYN FIRST ARG IS NOT CORRECT OPERATOR NAME
11207: *
11208: * COME HERE ON FINDING A MATCH IN THE OPERATOR NAME TABLE
11209: *
11210: SOPS6 MOV WA,XR COPY POINTER TO FUNCTION BLOCK PTR
11211: SUB *VRFNC,XR MAKE IT LOOK LIKE DUMMY VRBLK
11212: BRN SOPS1 MERGE BACK TO DEFINE OPERATOR
11213: EJC
11214: *
11215: * OUTPUT
11216: *
11217: S$OUP ENT ENTRY POINT
11218: MOV =NUM03,WB OUTPUT FLAG
11219: JSR IOPUT CALL INPUT/OUTPUT ASSOC. ROUTINE
11220: ERR 157,OUTPUT THIRD ARGUMENT IS NOT A STRING
11221: ERR 158,INAPPROPRIATE SECOND ARGUMENT FOR OUTPUT
11222: ERR 159,INAPPROPRIATE FIRST ARGUMENT FOR OUTPUT
11223: ERR 160,INAPPROPRIATE FILE SPECIFICATION FOR OUTPUT
11224: PPM EXFAL FAIL IF FILE DOES NOT EXIST
11225: ERR 161,OUTPUT FILE CANNOT BE WRITTEN TO
11226: BRN EXNUL RETURN NULL STRING
11227: EJC
11228: *
11229: * POS
11230: *
11231: S$POS ENT ENTRY POINT
11232: MOV =P$POS,WB SET PCODE FOR INTEGER ARG CASE
11233: MOV =P$PSD,WA SET PCODE FOR EXPRESSION ARG CASE
11234: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE
11235: ERR 162,POS ARGUMENT IS NOT INTEGER OR EXPRESSION
11236: ERR 163,POS ARGUMENT IS NEGATIVE OR TOO LARGE
11237: BRN EXIXR RETURN PATTERN NODE
11238: EJC
11239: *
11240: * PROTOTYPE
11241: *
11242: S$PRO ENT ENTRY POINT
11243: MOV (XS)+,XR LOAD ARGUMENT
11244: MOV TBLEN(XR),WB LENGTH IF TABLE, VECTOR (=VCLEN)
11245: BTW WB CONVERT TO WORDS
11246: MOV (XR),WA LOAD TYPE WORD OF ARGUMENT BLOCK
11247: BEQ WA,=B$ART,SPRO4 JUMP IF ARRAY
11248: BEQ WA,=B$TBT,SPRO1 JUMP IF TABLE
11249: BEQ WA,=B$VCT,SPRO3 JUMP IF VECTOR
11250: BEQ WA,=B$BCT,SPR05 JUMP IF BUFFER
11251: ERB 164,PROTOTYPE ARGUMENT IS NOT VALID OBJECT
11252: *
11253: * HERE FOR TABLE
11254: *
11255: SPRO1 SUB =TBSI$,WB SUBTRACT STANDARD FIELDS
11256: *
11257: * MERGE FOR VECTOR
11258: *
11259: SPRO2 MTI WB CONVERT TO INTEGER
11260: BRN EXINT EXIT WITH INTEGER RESULT
11261: *
11262: * HERE FOR VECTOR
11263: *
11264: SPRO3 SUB =VCSI$,WB SUBTRACT STANDARD FIELDS
11265: BRN SPRO2 MERGE
11266: *
11267: * HERE FOR ARRAY
11268: *
11269: SPRO4 ADD AROFS(XR),XR POINT TO PROTOTYPE FIELD
11270: MOV (XR),XR LOAD PROTOTYPE
11271: BRN EXIXR RETURN PROTOTYPE AS RESULT
11272: *
11273: * HERE FOR BUFFER
11274: *
11275: SPR05 MOV BCBUF(XR),XR POINT TO BFBLK
11276: MTI BFALC(XR) LOAD ALLOCATED LENGTH
11277: BRN EXINT EXIT WITH INTEGER ALLOCATION
11278: EJC
11279: *
11280: * REMDR
11281: *
11282: S$RMD ENT ENTRY POINT
11283: ZER WB SET POSITIVE FLAG
11284: MOV (XS),XR LOAD SECOND ARGUMENT
11285: JSR GTINT CONVERT TO INTEGER
11286: ERR 165,REMDR SECOND ARGUMENT IS NOT INTEGER
11287: JSR ARITH CONVERT ARGS
11288: PPM SRM01 FIRST ARG NOT INTEGER
11289: PPM SECOND ARG CHECKED ABOVE
11290: PPM SRM01 FIRST ARG REAL
11291: LDI ICVAL(XR) LOAD LEFT ARGUMENT VALUE
11292: RMI ICVAL(XL) GET REMAINDER
11293: INO EXINT JUMP IF NO OVERFLOW
11294: ERB 167,REMDR CAUSED INTEGER OVERFLOW
11295: *
11296: * FAIL FIRST ARGUMENT
11297: *
11298: SRM01 ERB 166,REMDR FIRST ARGUMENT IS NOT INTEGER
11299: EJC
11300: *
11301: * REPLACE
11302: *
11303: * THE ACTUAL REPLACE OPERATION USES AN SCBLK WHOSE CFP$A
11304: * CHARS CONTAIN THE TRANSLATED VERSIONS OF ALL THE CHARS.
11305: * THE TABLE POINTER IS REMEMBERED FROM CALL TO CALL AND
11306: * THE TABLE IS ONLY BUILT WHEN THE ARGUMENTS CHANGE.
11307: *
11308: S$RPL ENT ENTRY POINT
11309: JSR GTSTG LOAD THIRD ARGUMENT AS STRING
11310: ERR 168,REPLACE THIRD ARGUMENT IS NOT STRING
11311: MOV XR,XL SAVE THIRD ARG PTR
11312: JSR GTSTG GET SECOND ARGUMENT
11313: ERR 169,REPLACE SECOND ARGUMENT IS NOT STRING
11314: *
11315: * CHECK TO SEE IF THIS IS THE SAME TABLE AS LAST TIME
11316: *
11317: BNE XR,R$RA2,SRPL1 JUMP IF 2ND ARGUMENT DIFFERENT
11318: BEQ XL,R$RA3,SRPL4 JUMP IF ARGS SAME AS LAST TIME
11319: *
11320: * HERE WE BUILD A NEW REPLACE TABLE (NOTE WA = 2ND ARG LEN)
11321: *
11322: SRPL1 MOV SCLEN(XL),WB LOAD 3RD ARGUMENT LENGTH
11323: BNE WA,WB,SRPL5 JUMP IF ARGUMENTS NOT SAME LENGTH
11324: BZE WB,SRPL5 JUMP IF NULL 2ND ARGUMENT
11325: MOV XL,R$RA3 SAVE THIRD ARG FOR NEXT TIME IN
11326: MOV XR,R$RA2 SAVE SECOND ARG FOR NEXT TIME IN
11327: MOV KVALP,XL POINT TO ALPHABET STRING
11328: MOV SCLEN(XL),WA LOAD ALPHABET SCBLK LENGTH
11329: MOV R$RPT,XR POINT TO CURRENT TABLE (IF ANY)
11330: BNZ XR,SRPL2 JUMP IF WE ALREADY HAVE A TABLE
11331: *
11332: * HERE WE ALLOCATE A NEW TABLE
11333: *
11334: JSR ALOCS ALLOCATE NEW TABLE
11335: MOV WC,WA KEEP SCBLK LENGTH
11336: MOV XR,R$RPT SAVE TABLE POINTER FOR NEXT TIME
11337: *
11338: * MERGE HERE WITH POINTER TO NEW TABLE BLOCK IN (XR)
11339: *
11340: SRPL2 CTB WA,SCSI$ COMPUTE LENGTH OF SCBLK
11341: MVW COPY TO GET INITIAL TABLE VALUES
11342: EJC
11343: *
11344: * REPLACE (CONTINUED)
11345: *
11346: * NOW WE MUST PLUG SELECTED ENTRIES AS REQUIRED. NOTE THAT
11347: * WE ARE SHORT OF INDEX REGISTERS FOR THE FOLLOWING LOOP.
11348: * HENCE THE NEED TO REPEATEDLY RE-INITIALISE CHAR PTR XL
11349: *
11350: MOV R$RA2,XL POINT TO SECOND ARGUMENT
11351: LCT WB,WB NUMBER OF CHARS TO PLUG
11352: ZER WC ZERO CHAR OFFSET
11353: MOV R$RA3,XR POINT TO 3RD ARG
11354: PLC XR GET CHAR PTR FOR 3RD ARG
11355: *
11356: * LOOP TO PLUG CHARS
11357: *
11358: SRPL3 MOV R$RA2,XL POINT TO 2ND ARG
11359: PLC XL,WC POINT TO NEXT CHAR
11360: ICV WC INCREMENT OFFSET
11361: LCH WA,(XL) GET NEXT CHAR
11362: MOV R$RPT,XL POINT TO TRANSLATE TABLE
11363: PSC XL,WA CONVERT CHAR TO OFFSET INTO TABLE
11364: LCH WA,(XR)+ GET TRANSLATED CHAR
11365: SCH WA,(XL) STORE IN TABLE
11366: CSC XL COMPLETE STORE CHARACTERS
11367: BCT WB,SRPL3 LOOP TILL DONE
11368: EJC
11369: *
11370: * REPLACE (CONTINUED)
11371: *
11372: * HERE TO PERFORM TRANSLATE
11373: *
11374: SRPL4 JSR GTSTG GET FIRST ARGUMENT
11375: ERR 170,REPLACE FIRST ARGUMENT IS NOT STRING
11376: BZE WA,EXNUL RETURN NULL IF NULL ARGUMENT
11377: MOV XR,XL COPY POINTER
11378: MOV WA,WC SAVE LENGTH
11379: CTB WA,SCHAR GET SCBLK LENGTH
11380: JSR ALLOC ALLOCATE SPACE FOR COPY
11381: MOV XR,WB SAVE ADDRESS OF COPY
11382: MVW MOVE SCBLK CONTENTS TO COPY
11383: MOV R$RPT,XR POINT TO REPLACE TABLE
11384: PLC XR POINT TO CHARS OF TABLE
11385: MOV WB,XL POINT TO STRING TO TRANSLATE
11386: PLC XL POINT TO CHARS OF STRING
11387: MOV WC,WA SET NUMBER OF CHARS TO TRANSLATE
11388: TRC PERFORM TRANSLATION
11389: MOV WB,-(XS) STACK NEW STRING AS RESULT
11390: BRN EXITS RETURN WITH RESULT ON STACK
11391: *
11392: * ERROR POINT
11393: *
11394: SRPL5 ERB 171,NULL OR UNEQUALLY LONG 2ND, 3RD ARGS TO REPLACE
11395: EJC
11396: *
11397: * REWIND
11398: *
11399: S$REW ENT ENTRY POINT
11400: JSR IOFCB CALL FCBLK ROUTINE
11401: ERR 172,REWIND ARGUMENT IS NOT A SUITABLE NAME
11402: ERR 173,REWIND ARGUMENT IS NULL
11403: JSR SYSRW CALL SYSTEM REWIND FUNCTION
11404: ERR 174,REWIND FILE DOES NOT EXIST
11405: ERR 175,REWIND FILE DOES NOT PERMIT REWIND
11406: ERR 176,REWIND CAUSED NON-RECOVERABLE ERROR
11407: BRN EXNUL EXIT WITH NULL RESULT IF NO ERROR
11408: EJC
11409: *
11410: * REVERSE
11411: *
11412: S$RVS ENT ENTRY POINT
11413: JSR GTSTG LOAD STRING ARGUMENT
11414: ERR 177,REVERSE ARGUMENT IS NOT STRING
11415: BZE WA,EXIXR RETURN ARGUMENT IF NULL
11416: MOV XR,XL ELSE SAVE POINTER TO STRING ARG
11417: JSR ALOCS ALLOCATE SPACE FOR NEW SCBLK
11418: MOV XR,-(XS) STORE SCBLK PTR ON STACK AS RESULT
11419: PSC XR PREPARE TO STORE IN NEW SCBLK
11420: PLC XL,WC POINT PAST LAST CHAR IN ARGUMENT
11421: LCT WC,WC SET LOOP COUNTER
11422: *
11423: * LOOP TO MOVE CHARS IN REVERSE ORDER
11424: *
11425: SRVS1 LCH WB,-(XL) LOAD NEXT CHAR FROM ARGUMENT
11426: SCH WB,(XR)+ STORE IN RESULT
11427: BCT WC,SRVS1 LOOP TILL ALL MOVED
11428: CSC XR COMPLETE STORE CHARACTERS
11429: BRN EXITS AND THEN JUMP FOR NEXT CODE WORD
11430: EJC
11431: *
11432: * RPAD
11433: *
11434: S$RPD ENT ENTRY POINT
11435: JSR GTSTG GET PAD CHARACTER
11436: ERR 178,RPAD THIRD ARGUMENT IS NOT STRING
11437: PLC XR POINT TO CHARACTER (NULL IS BLANK)
11438: LCH WB,(XR) LOAD PAD CHARACTER
11439: JSR GTSMI GET PAD LENGTH
11440: ERR 179,RPAD SECOND ARGUMENT IS NOT INTEGER
11441: PPM SRPD3 SKIP IF NEGATIVE OR LARGE
11442: *
11443: * MERGE TO CHECK FIRST ARG.
11444: *
11445: SRPD1 JSR GTSTG GET FIRST ARGUMENT (STRING TO PAD)
11446: ERR 180,RPAD FIRST ARGUMENT IS NOT STRING
11447: BGE WA,WC,EXIXR RETURN 1ST ARG IF TOO LONG TO PAD
11448: MOV XR,XL ELSE MOVE PTR TO STRING TO PAD
11449: *
11450: * NOW WE ARE READY FOR THE PAD
11451: *
11452: * (XL) POINTER TO STRING TO PAD
11453: * (WB) PAD CHARACTER
11454: * (WC) LENGTH TO PAD STRING TO
11455: *
11456: MOV WC,WA COPY LENGTH
11457: JSR ALOCS ALLOCATE SCBLK FOR NEW STRING
11458: MOV XR,-(XS) SAVE AS RESULT
11459: MOV SCLEN(XL),WA LOAD LENGTH OF ARGUMENT
11460: SUB WA,WC CALCULATE NUMBER OF PAD CHARACTERS
11461: PSC XR POINT TO CHARS IN RESULT STRING
11462: LCT WC,WC SET COUNTER FOR PAD LOOP
11463: *
11464: * COPY ARGUMENT STRING
11465: *
11466: BZE WA,SRPD2 JUMP IF ARGUMENT IS NULL
11467: PLC XL ELSE POINT TO ARGUMENT CHARS
11468: MVC MOVE CHARACTERS TO RESULT STRING
11469: *
11470: * LOOP TO SUPPLY PAD CHARACTERS
11471: *
11472: SRPD2 SCH WB,(XR)+ STORE PAD CHARACTER, BUMP PTR
11473: BCT WC,SRPD2 LOOP TILL ALL PAD CHARS STORED
11474: CSC XR COMPLETE CHARACTER STORING
11475: BRN EXITS AND EXIT FOR NEXT WORD
11476: *
11477: * HERE IF 2ND ARG IS NEGATIVE OR LARGE
11478: *
11479: SRPD3 ZER WC ZERO PAD COUNT
11480: BRN SRPD1 MERGE
11481: EJC
11482: *
11483: * RTAB
11484: *
11485: S$RTB ENT ENTRY POINT
11486: MOV =P$RTB,WB SET PCODE FOR INTEGER ARG CASE
11487: MOV =P$RTD,WA SET PCODE FOR EXPRESSION ARG CASE
11488: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE
11489: ERR 181,RTAB ARGUMENT IS NOT INTEGER OR EXPRESSION
11490: ERR 182,RTAB ARGUMENT IS NEGATIVE OR TOO LARGE
11491: BRN EXIXR RETURN PATTERN NODE
11492: EJC
11493: *
11494: * SET
11495: *
11496: S$SET ENT ENTRY POINT
11497: MOV (XS)+,R$IO2 SAVE THIRD ARG
11498: MOV (XS)+,R$IO1 SAVE SECOND ARG
11499: JSR IOFCB CALL FCBLK ROUTINE
11500: ERR 291,SET FIRST ARGUMENT IS NOT A SUITABLE NAME
11501: ERR 292,SET FIRST ARGUMENT IS NULL
11502: MOV R$IO1,WB LOAD SECOND ARG
11503: MOV R$IO2,WC LOAD THIRD ARG
11504: JSR SYSST CALL SYSTEM SET ROUTINE
11505: ERR 293,INAPPROPRIATE SECOND ARGUMENT TO SET
11506: ERR 294,INAPPROPRIATE THIRD ARGUMENT TO SET
11507: ERR 295,SET FILE DOES NOT EXIST
11508: ERR 296,SET FILE DOES NOT PERMIT SETTING FILE POINTER
11509: ERR 297,SET CAUSED NON-RECOVERABLE I/O ERROR
11510: BRN EXNUL OTHERWISEW RETURN NULL
11511: EJC
11512: *
11513: * TAB
11514: *
11515: S$TAB ENT ENTRY POINT
11516: MOV =P$TAB,WB SET PCODE FOR INTEGER ARG CASE
11517: MOV =P$TBD,WA SET PCODE FOR EXPRESSION ARG CASE
11518: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE
11519: ERR 183,TAB ARGUMENT IS NOT INTEGER OR EXPRESSION
11520: ERR 184,TAB ARGUMENT IS NEGATIVE OR TOO LARGE
11521: BRN EXIXR RETURN PATTERN NODE
11522: EJC
11523: *
11524: * RPOS
11525: *
11526: S$RPS ENT ENTRY POINT
11527: MOV =P$RPS,WB SET PCODE FOR INTEGER ARG CASE
11528: MOV =P$RPD,WA SET PCODE FOR EXPRESSION ARG CASE
11529: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE
11530: ERR 185,RPOS ARGUMENT IS NOT INTEGER OR EXPRESSION
11531: ERR 186,RPOS ARGUMENT IS NEGATIVE OR TOO LARGE
11532: BRN EXIXR RETURN PATTERN NODE
11533: EJC
11534: *
11535: * RSORT
11536: *
11537: S$RSR ENT ENTRY POINT
11538: MNZ WA MARK AS RSORT
11539: JSR SORTA CALL SORT ROUTINE
11540: BRN EXSID RETURN, SETTING IDVAL
11541: EJC
11542: *
11543: * SETEXIT
11544: *
11545: S$STX ENT ENTRY POINT
11546: MOV (XS)+,XR LOAD ARGUMENT
11547: MOV STXVR,WA LOAD OLD VRBLK POINTER
11548: ZER XL LOAD ZERO IN CASE NULL ARG
11549: BEQ XR,=NULLS,SSTX1 JUMP IF NULL ARGUMENT (RESET CALL)
11550: JSR GTNVR ELSE GET SPECIFIED VRBLK
11551: PPM SSTX2 JUMP IF NOT NATURAL VARIABLE
11552: MOV VRLBL(XR),XL ELSE LOAD LABEL
11553: BEQ XL,=STNDL,SSTX2 JUMP IF LABEL IS NOT DEFINED
11554: BNE (XL),=B$TRT,SSTX1 JUMP IF NOT TRAPPED
11555: MOV TRLBL(XL),XL ELSE LOAD PTR TO REAL LABEL CODE
11556: *
11557: * HERE TO SET/RESET SETEXIT TRAP
11558: *
11559: SSTX1 MOV XR,STXVR STORE NEW VRBLK POINTER (OR NULL)
11560: MOV XL,R$SXC STORE NEW CODE PTR (OR ZERO)
11561: BEQ WA,=NULLS,EXNUL RETURN NULL IF NULL RESULT
11562: MOV WA,XR ELSE COPY VRBLK POINTER
11563: BRN EXVNM AND RETURN BUILDING NMBLK
11564: *
11565: * HERE IF BAD ARGUMENT
11566: *
11567: SSTX2 ERB 187,SETEXIT ARGUMENT IS NOT LABEL NAME OR NULL
11568: EJC
11569: *
11570: * SORT
11571: *
11572: S$SRT ENT ENTRY POINT
11573: ZER WA MARK AS SORT
11574: JSR SORTA CALL SORT ROUTINE
11575: BRN EXSID RETURN, SETTING IDVAL
11576: EJC
11577: *
11578: * SPAN
11579: *
11580: S$SPN ENT ENTRY POINT
11581: MOV =P$SPS,WB SET PCODE FOR SINGLE CHAR ARG
11582: MOV =P$SPN,XL SET PCODE FOR MULTI-CHAR ARG
11583: MOV =P$SPD,WC SET PCODE FOR EXPRESSION ARG
11584: JSR PATST CALL COMMON ROUTINE TO BUILD NODE
11585: ERR 188,SPAN ARGUMENT IS NOT STRING OR EXPRESSION
11586: BRN EXIXR JUMP FOR NEXT CODE WORD
11587: EJC
11588: *
11589: * SIZE
11590: *
11591: S$SI$ ENT ENTRY POINT
11592: MOV (XS),XR LOAD ARGUMENT
11593: BNE (XR),=B$BCT,SSI$1 BRANCH IF NOT BUFFER
11594: ICA XS ELSE POP ARGUMENT
11595: MTI BCLEN(XR) LOAD DEFINED LENGTH
11596: BRN EXINT EXIT WITH INTEGER
11597: *
11598: * HERE IF NOT BUFFER
11599: *
11600: SSI$1 JSR GTSTG LOAD STRING ARGUMENT
11601: ERR 189,SIZE ARGUMENT IS NOT STRING
11602: MTI WA LOAD LENGTH AS INTEGER
11603: BRN EXINT EXIT WITH INTEGER RESULT
11604: EJC
11605: *
11606: * STOPTR
11607: *
11608: S$STT ENT ENTRY POINT
11609: ZER XL INDICATE STOPTR CASE
11610: JSR TRACE CALL TRACE PROCEDURE
11611: ERR 190,STOPTR FIRST ARGUMENT IS NOT APPROPRIATE NAME
11612: ERR 191,STOPTR SECOND ARGUMENT IS NOT TRACE TYPE
11613: BRN EXNUL RETURN NULL
11614: EJC
11615: *
11616: * SUBSTR
11617: *
11618: S$SUB ENT ENTRY POINT
11619: JSR GTSMI LOAD THIRD ARGUMENT
11620: ERR 192,SUBSTR THIRD ARGUMENT IS NOT INTEGER
11621: PPM EXFAL JUMP IF NEGATIVE OR TOO LARGE
11622: MOV XR,SBSSV SAVE THIRD ARGUMENT
11623: JSR GTSMI LOAD SECOND ARGUMENT
11624: ERR 193,SUBSTR SECOND ARGUMENT IS NOT INTEGER
11625: PPM EXFAL JUMP IF OUT OF RANGE
11626: MOV XR,WB SAVE SECOND ARGUMENT
11627: BZE WB,EXFAL JUMP IF SECOND ARGUMENT ZERO
11628: DCV WB ELSE DECREMENT FOR ONES ORIGIN
11629: MOV (XS),XL GET FIRST ARG PTR
11630: BNE (XL),=B$BCT,SSUBA BRANCH IF NOT BUFFER
11631: MOV BCBUF(XL),XR GET BFBLK PTR
11632: MOV BCLEN(XL),WA GET LENGTH
11633: BRN SSUBB MERGE
11634: *
11635: * HERE IF NOT BUFFER TO GET STRING
11636: *
11637: SSUBA JSR GTSTG LOAD FIRST ARGUMENT
11638: ERR 194,SUBSTR FIRST ARGUMENT IS NOT STRING
11639: *
11640: * MERGE WITH BFBLK OR SCBLK PTR IN XR. WA HAS LENGTH
11641: *
11642: SSUBB MOV SBSSV,WC RELOAD THIRD ARGUMENT
11643: BNZ WC,SSUB1 SKIP IF THIRD ARG GIVEN
11644: MOV WA,WC ELSE GET STRING LENGTH
11645: BGT WB,WC,EXFAL FAIL IF IMPROPER
11646: SUB WB,WC REDUCE BY OFFSET TO START
11647: *
11648: * MERGE
11649: *
11650: SSUB1 MOV WA,XL SAVE STRING LENGTH
11651: MOV WC,WA SET LENGTH OF SUBSTRING
11652: ADD WB,WC ADD 2ND ARG TO 3RD ARG
11653: BGT WC,XL,EXFAL JUMP IF IMPROPER SUBSTRING
11654: MOV XR,XL COPY POINTER TO FIRST ARG
11655: JSR SBSTR BUILD SUBSTRING
11656: BRN EXIXR AND JUMP FOR NEXT CODE WORD
11657: EJC
11658: *
11659: * TABLE
11660: *
11661: S$TBL ENT ENTRY POINT
11662: MOV (XS)+,XL GET INITIAL LOOKUP VALUE
11663: ICA XS POP SECOND ARGUMENT
11664: JSR GTSMI LOAD ARGUMENT
11665: ERR 195,TABLE ARGUMENT IS NOT INTEGER
11666: ERR 196,TABLE ARGUMENT IS OUT OF RANGE
11667: BNZ WC,STBL1 JUMP IF NON-ZERO
11668: MOV =TBNBK,WC ELSE SUPPLY DEFAULT VALUE
11669: *
11670: * MERGE HERE WITH NUMBER OF HEADERS IN WA
11671: *
11672: STBL1 MOV WC,WA COPY NUMBER OF HEADERS
11673: ADD =TBSI$,WA ADJUST FOR STANDARD FIELDS
11674: WTB WA CONVERT LENGTH TO BYTES
11675: JSR ALLOC ALLOCATE SPACE FOR TBBLK
11676: MOV XR,WB COPY POINTER TO TBBLK
11677: MOV =B$TBT,(XR)+ STORE TYPE WORD
11678: ZER (XR)+ ZERO ID FOR THE MOMENT
11679: MOV WA,(XR)+ STORE LENGTH (TBLEN)
11680: MOV XL,(XR)+ STORE INITIAL LOOKUP VALUE
11681: LCT WC,WC SET LOOP COUNTER (NUM HEADERS)
11682: *
11683: * LOOP TO INITIALIZE ALL BUCKET POINTERS
11684: *
11685: STBL2 MOV WB,(XR)+ STORE TBBLK PTR IN BUCKET HEADER
11686: BCT WC,STBL2 LOOP TILL ALL STORED
11687: MOV WB,XR RECALL POINTER TO TBBLK
11688: BRN EXSID EXIT SETTING IDVAL
11689: EJC
11690: *
11691: * TIME
11692: *
11693: S$TIM ENT ENTRY POINT
11694: JSR SYSTM GET TIMER VALUE
11695: SBI TIMSX SUBTRACT STARTING TIME
11696: BRN EXINT EXIT WITH INTEGER VALUE
11697: EJC
11698: *
11699: * TRACE
11700: *
11701: S$TRA ENT ENTRY POINT
11702: BEQ 3(XS),=NULLS,STR03 JUMP IF FIRST ARGUMENT IS NULL
11703: MOV (XS)+,XR LOAD FOURTH ARGUMENT
11704: ZER XL TENTATIVELY SET ZERO POINTER
11705: BEQ XR,=NULLS,STR02 JUMP IF 4TH ARGUMENT IS NULL
11706: JSR GTNVR ELSE POINT TO VRBLK
11707: PPM STR01 JUMP IF NOT VARIABLE NAME
11708: MOV VRFNC(XR),XL ELSE LOAD FUNCTION POINTER
11709: BNE XL,=STNDF,STR02 JUMP IF FUNCTION IS DEFINED
11710: *
11711: * HERE FOR BAD FOURTH ARGUMENT
11712: *
11713: STR01 ERB 197,TRACE FOURTH ARG IS NOT FUNCTION NAME OR NULL
11714: *
11715: * HERE WITH FUNCTION POINTER IN XL
11716: *
11717: STR02 MOV (XS)+,XR LOAD THIRD ARGUMENT (TAG)
11718: ZER WB SET ZERO AS TRTYP VALUE FOR NOW
11719: JSR TRBLD BUILD TRBLK FOR TRACE CALL
11720: MOV XR,XL MOVE TRBLK POINTER FOR TRACE
11721: JSR TRACE CALL TRACE PROCEDURE
11722: ERR 198,TRACE FIRST ARGUMENT IS NOT APPROPRIATE NAME
11723: ERR 199,TRACE SECOND ARGUMENT IS NOT TRACE TYPE
11724: BRN EXNUL RETURN NULL
11725: *
11726: * HERE TO CALL SYSTEM TRACE TOGGLE ROUTINE
11727: *
11728: STR03 JSR SYSTT CALL IT
11729: ADD *NUM04,XS POP TRACE ARGUMENTS
11730: BRN EXNUL RETURN
11731: EJC
11732: *
11733: * TRIM
11734: *
11735: S$TRM ENT ENTRY POINT
11736: JSR GTSTG LOAD ARGUMENT AS STRING
11737: ERR 200,TRIM ARGUMENT IS NOT STRING
11738: BZE WA,EXNUL RETURN NULL IF ARGUMENT IS NULL
11739: MOV XR,XL COPY STRING POINTER
11740: CTB WA,SCHAR GET BLOCK LENGTH
11741: JSR ALLOC ALLOCATE COPY SAME SIZE
11742: MOV XR,WB SAVE POINTER TO COPY
11743: MVW COPY OLD STRING BLOCK TO NEW
11744: MOV WB,XR RESTORE PTR TO NEW BLOCK
11745: JSR TRIMR TRIM BLANKS (WB IS NON-ZERO)
11746: BRN EXIXR EXIT WITH RESULT IN XR
11747: EJC
11748: *
11749: * UNLOAD
11750: *
11751: S$UNL ENT ENTRY POINT
11752: MOV (XS)+,XR LOAD ARGUMENT
11753: JSR GTNVR POINT TO VRBLK
11754: ERR 201,UNLOAD ARGUMENT IS NOT NATURAL VARIABLE NAME
11755: MOV =STNDF,XL GET PTR TO UNDEFINED FUNCTION
11756: JSR DFFNC UNDEFINE NAMED FUNCTION
11757: BRN EXNUL RETURN NULL AS RESULT
11758: TTL S P I T B O L -- UTILITY PROCEDURES
11759: *
11760: * THE FOLLOWING SECTION CONTAINS PROCEDURES WHICH ARE
11761: * USED FOR VARIOUS PURPOSES THROUGHOUT THE SYSTEM.
11762: *
11763: * EACH PROCEDURE IS PRECEDED BY A DESCRIPTION OF THE
11764: * CALLING SEQUENCE. USUALLY THE ARGUMENTS ARE IN REGISTERS
11765: * BUT ARGUMENTS CAN ALSO OCCUR ON THE STACK AND AS
11766: * PARAMETERS ASSEMBLED AFTER THE JSR INSTRUCTION.
11767: *
11768: * THE FOLLOWING CONSIDERATIONS APPLY TO THESE DESCRIPTIONS.
11769: *
11770: * 1) THE STACK POINTER (XS) IS NOT CHANGED UNLESS THE
11771: * CHANGE IS EXPLICITLY DOCUMENTED IN THE CALL.
11772: *
11773: * 2) REGISTERS WHOSE ENTRY VALUES ARE NOT MENTIONED
11774: * MAY CONTAIN ANY VALUE EXCEPT THAT XL,XR MAY ONLY
11775: * CONTAIN PROPER (COLLECTABLE) POINTER VALUES.
11776: * THIS CONDITION ON XR MEANS THAT THE CALLED ROUTINE
11777: * MAY IF IT CHOOSES PRESERVE XR BY STACKING.
11778: *
11779: * 3) REGISTERS NOT MENTIONED ON EXIT CONTAIN THE SAME
11780: * VALUES AS THEY DID ON ENTRY EXCEPT THAT VALUES IN
11781: * XR,XL MAY HAVE BEEN RELOCATED BY THE COLLECTOR.
11782: *
11783: * 4) REGISTERS WHICH ARE DESTROYED ON EXIT MAY CONTAIN
11784: * ANY VALUE EXCEPT THAT VALUES IN XL,XR ARE PROPER
11785: * (COLLECTABLE) POINTERS.
11786: *
11787: * 5) THE CODE POINTER REGISTER POINTS TO THE CURRENT
11788: * CODE LOCATION ON ENTRY AND IS UNCHANGED ON EXIT.
11789: *
11790: * IN THE ABOVE DESCRIPTION, A COLLECTABLE POINTER IS ONE
11791: * WHICH EITHER POINTS OUTSIDE THE DYNAMIC REGION OR
11792: * POINTS TO THE START OF A BLOCK IN THE DYNAMIC REGION.
11793: *
11794: * IN THOSE CASES WHERE THE CALLING SEQUENCE CONTAINS
11795: * PARAMETERS WHICH ARE USED AS ALTERNATE RETURN POINTS,
11796: * THESE PARAMETERS MAY BE REPLACED BY ERROR CODES
11797: * ASSEMBLED WITH THE ERR INSTRUCTION. THIS WILL RESULT
11798: * IN THE POSTING OF THE ERROR IF THE RETURN IS TAKEN.
11799: *
11800: * THE PROCEDURES ALL HAVE NAMES CONSISTING OF FIVE LETTERS
11801: * AND ARE IN ALPHABETICAL ORDER BY THEIR NAMES.
11802: EJC
11803: *
11804: * ACESS - ACCESS VARIABLE VALUE WITH TRACE/INPUT CHECKS
11805: *
11806: * ACESS LOADS THE VALUE OF A VARIABLE. TRACE AND INPUT
11807: * ASSOCIATIONS ARE TESTED FOR AND EXECUTED AS REQUIRED.
11808: * ACESS ALSO HANDLES THE SPECIAL CASES OF PSEUDO-VARIABLES.
11809: *
11810: * (XL) VARIABLE NAME BASE
11811: * (WA) VARIABLE NAME OFFSET
11812: * JSR ACESS CALL TO ACCESS VALUE
11813: * PPM LOC TRANSFER LOC IF ACCESS FAILURE
11814: * (XR) VARIABLE VALUE
11815: * (WA,WB,WC) DESTROYED
11816: * (XL,RA) DESTROYED
11817: *
11818: * FAILURE CAN OCCUR IF AN INPUT ASSOCIATION CAUSES AN END
11819: * OF FILE CONDITION OR IF THE EVALUATION OF AN EXPRESSION
11820: * ASSOCIATED WITH AN EXPRESSION VARIABLE FAILS.
11821: *
11822: ACESS PRC R,1 ENTRY POINT (RECURSIVE)
11823: MOV XL,XR COPY NAME BASE
11824: ADD WA,XR POINT TO VARIABLE LOCATION
11825: MOV (XR),XR LOAD VARIABLE VALUE
11826: *
11827: * LOOP HERE TO CHECK FOR SUCCESSIVE TRBLKS
11828: *
11829: ACS02 BNE (XR),=B$TRT,ACS18 JUMP IF NOT TRAPPED
11830: *
11831: * HERE IF TRAPPED
11832: *
11833: BEQ XR,=TRBKV,ACS12 JUMP IF KEYWORD VARIABLE
11834: BNE XR,=TRBEV,ACS05 JUMP IF NOT EXPRESSION VARIABLE
11835: *
11836: * HERE FOR EXPRESSION VARIABLE, EVALUATE VARIABLE
11837: *
11838: MOV EVEXP(XL),XR LOAD EXPRESSION POINTER
11839: ZER WB EVALUATE BY VALUE
11840: JSR EVALX EVALUATE EXPRESSION
11841: PPM ACS04 JUMP IF EVALUATION FAILURE
11842: BRN ACS02 CHECK VALUE FOR MORE TRBLKS
11843: EJC
11844: *
11845: * ACESS (CONTINUED)
11846: *
11847: * HERE ON READING END OF FILE
11848: *
11849: ACS03 ADD *NUM03,XS POP TRBLK PTR, NAME BASE AND OFFSET
11850: MOV XR,DNAMP POP UNUSED SCBLK
11851: *
11852: * MERGE HERE WHEN EVALUATION OF EXPRESSION FAILS
11853: *
11854: ACS04 EXI 1 TAKE ALTERNATE (FAILURE) RETURN
11855: *
11856: * HERE IF NOT KEYWORD OR EXPRESSION VARIABLE
11857: *
11858: ACS05 MOV TRTYP(XR),WB LOAD TRAP TYPE CODE
11859: BNZ WB,ACS10 JUMP IF NOT INPUT ASSOCIATION
11860: BZE KVINP,ACS09 IGNORE INPUT ASSOC IF INPUT IS OFF
11861: *
11862: * HERE FOR INPUT ASSOCIATION
11863: *
11864: MOV XL,-(XS) STACK NAME BASE
11865: MOV WA,-(XS) STACK NAME OFFSET
11866: MOV XR,-(XS) STACK TRBLK POINTER
11867: MOV TRFPT(XR),XL GET FILE CTRL BLK PTR OR ZERO
11868: BNZ XL,ACS06 JUMP IF NOT STANDARD INPUT FILE
11869: BEQ TRTER(XR),=V$TER,ACS21 JUMP IF TERMINAL
11870: *
11871: * HERE TO READ FROM STANDARD INPUT FILE
11872: *
11873: MOV CSWIN,WA LENGTH FOR READ BUFFER
11874: JSR ALOCS BUILD STRING OF APPROPRIATE LENGTH
11875: JSR SYSRD READ NEXT STANDARD INPUT IMAGE
11876: PPM ACS03 JUMP TO FAIL EXIT IF END OF FILE
11877: BRN ACS07 ELSE MERGE WITH OTHER FILE CASE
11878: *
11879: * HERE FOR INPUT FROM OTHER THAN STANDARD INPUT FILE
11880: *
11881: ACS06 MOV XL,WA FCBLK PTR
11882: JSR SYSIL GET INPUT RECORD MAX LENGTH (TO WA)
11883: JSR ALOCS ALLOCATE STRING OF CORRECT SIZE
11884: MOV XL,WA FCBLK PTR
11885: JSR SYSIN CALL SYSTEM INPUT ROUTINE
11886: PPM ACS03 JUMP TO FAIL EXIT IF END OF FILE
11887: PPM ACS22 ERROR
11888: PPM ACS23 ERROR
11889: EJC
11890: *
11891: * ACESS (CONTINUED)
11892: *
11893: * MERGE HERE AFTER OBTAINING INPUT RECORD
11894: *
11895: ACS07 MOV KVTRM,WB LOAD TRIM INDICATOR
11896: JSR TRIMR TRIM RECORD AS REQUIRED
11897: MOV XR,WB COPY RESULT POINTER
11898: MOV (XS),XR RELOAD POINTER TO TRBLK
11899: *
11900: * LOOP TO CHASE TO END OF TRBLK CHAIN AND STORE VALUE
11901: *
11902: ACS08 MOV XR,XL SAVE POINTER TO THIS TRBLK
11903: MOV TRNXT(XR),XR LOAD FORWARD POINTER
11904: BEQ (XR),=B$TRT,ACS08 LOOP IF THIS IS ANOTHER TRBLK
11905: MOV WB,TRNXT(XL) ELSE STORE RESULT AT END OF CHAIN
11906: MOV (XS)+,XR RESTORE INITIAL TRBLK POINTER
11907: MOV (XS)+,WA RESTORE NAME OFFSET
11908: MOV (XS)+,XL RESTORE NAME BASE POINTER
11909: *
11910: * COME HERE TO MOVE TO NEXT TRBLK
11911: *
11912: ACS09 MOV TRNXT(XR),XR LOAD FORWARD PTR TO NEXT VALUE
11913: BRN ACS02 BACK TO CHECK IF TRAPPED
11914: *
11915: * HERE TO CHECK FOR ACCESS TRACE TRBLK
11916: *
11917: ACS10 BNE WB,=TRTAC,ACS09 LOOP BACK IF NOT ACCESS TRACE
11918: BZE KVTRA,ACS09 IGNORE ACCESS TRACE IF TRACE OFF
11919: DCV KVTRA ELSE DECREMENT TRACE COUNT
11920: BZE TRFNC(XR),ACS11 JUMP IF PRINT TRACE
11921: EJC
11922: *
11923: * ACESS (CONTINUED)
11924: *
11925: * HERE FOR FULL FUNCTION TRACE
11926: *
11927: JSR TRXEQ CALL ROUTINE TO EXECUTE TRACE
11928: BRN ACS09 JUMP FOR NEXT TRBLK
11929: *
11930: * HERE FOR CASE OF PRINT TRACE
11931: *
11932: ACS11 JSR PRTSN PRINT STATEMENT NUMBER
11933: JSR PRTNV PRINT NAME = VALUE
11934: BRN ACS09 JUMP BACK FOR NEXT TRBLK
11935: *
11936: * HERE FOR KEYWORD VARIABLE
11937: *
11938: ACS12 MOV KVNUM(XL),XR LOAD KEYWORD NUMBER
11939: BGE XR,=K$V$$,ACS14 JUMP IF NOT ONE WORD VALUE
11940: MTI KVABE(XR) ELSE LOAD VALUE AS INTEGER
11941: *
11942: * COMMON EXIT WITH KEYWORD VALUE AS INTEGER IN (IA)
11943: *
11944: ACS13 JSR ICBLD BUILD ICBLK
11945: BRN ACS18 JUMP TO EXIT
11946: *
11947: * HERE IF NOT ONE WORD KEYWORD VALUE
11948: *
11949: ACS14 BGE XR,=K$S$$,ACS15 JUMP IF SPECIAL CASE
11950: SUB =K$V$$,XR ELSE GET OFFSET
11951: ADD =NDABO,XR POINT TO PATTERN VALUE
11952: BRN ACS18 JUMP TO EXIT
11953: *
11954: * HERE IF SPECIAL KEYWORD CASE
11955: *
11956: ACS15 MOV KVRTN,XL LOAD RTNTYPE IN CASE
11957: LDI KVSTL LOAD STLIMIT IN CASE
11958: SUB =K$S$$,XR GET CASE NUMBER
11959: BSW XR,5 SWITCH ON KEYWORD NUMBER
11960: IFF K$$AL,ACS16 JUMP IF ALPHABET
11961: IFF K$$RT,ACS17 RTNTYPE
11962: IFF K$$SC,ACS19 STCOUNT
11963: IFF K$$SL,ACS13 STLIMIT
11964: IFF K$$ET,ACS20 ERRTEXT
11965: ESW END SWITCH ON KEYWORD NUMBER
11966: EJC
11967: *
11968: * ACESS (CONTINUED)
11969: *
11970: * ALPHABET
11971: *
11972: ACS16 MOV KVALP,XL LOAD POINTER TO ALPHABET STRING
11973: *
11974: * RTNTYPE MERGES HERE
11975: *
11976: ACS17 MOV XL,XR COPY STRING PTR TO PROPER REG
11977: *
11978: * COMMON RETURN POINT
11979: *
11980: ACS18 EXI RETURN TO ACESS CALLER
11981: *
11982: * HERE FOR STCOUNT (IA HAS STLIMIT)
11983: *
11984: ACS19 SBI KVSTC STCOUNT = LIMIT - LEFT
11985: BRN ACS13 MERGE BACK WITH INTEGER RESULT
11986: *
11987: * ERRTEXT
11988: *
11989: ACS20 MOV R$ETX,XR GET ERRTEXT STRING
11990: BRN ACS18 MERGE WITH RESULT
11991: *
11992: * HERE TO READ A RECORD FROM TERMINAL
11993: *
11994: ACS21 MOV =RILEN,WA BUFFER LENGTH
11995: JSR ALOCS ALLOCATE BUFFER
11996: JSR SYSRI READ RECORD
11997: PPM ACS03 ENDFILE
11998: BRN ACS07 MERGE WITH RECORD READ
11999: *
12000: * ERROR RETURNS
12001: *
12002: ACS22 MOV XR,DNAMP POP UNUSED SCBLK
12003: ERB 202,INPUT FROM FILE CAUSED NON-RECOVERABLE ERROR
12004: *
12005: ACS23 MOV XR,DNAMP POP UNUSED SCBLK
12006: ERB 203,INPUT FILE RECORD HAS INCORRECT FORMAT
12007: ENP END PROCEDURE ACESS
12008: EJC
12009: *
12010: * ACOMP -- COMPARE TWO ARITHMETIC VALUES
12011: *
12012: * 1(XS) FIRST ARGUMENT
12013: * 0(XS) SECOND ARGUMENT
12014: * JSR ACOMP CALL TO COMPARE VALUES
12015: * PPM LOC TRANSFER LOC IF ARG1 IS NON-NUMERIC
12016: * PPM LOC TRANSFER LOC IF ARG2 IS NON-NUMERIC
12017: * PPM LOC TRANSFER LOC FOR ARG1 LT ARG2
12018: * PPM LOC TRANSFER LOC FOR ARG1 EQ ARG2
12019: * PPM LOC TRANSFER LOC FOR ARG1 GT ARG2
12020: * (NORMAL RETURN IS NEVER GIVEN)
12021: * (WA,WB,WC,IA,RA) DESTROYED
12022: * (XL,XR) DESTROYED
12023: *
12024: ACOMP PRC N,5 ENTRY POINT
12025: JSR ARITH LOAD ARITHMETIC OPERANDS
12026: PPM ACMP7 JUMP IF FIRST ARG NON-NUMERIC
12027: PPM ACMP8 JUMP IF SECOND ARG NON-NUMERIC
12028: PPM ACMP4 JUMP IF REAL ARGUMENTS
12029: *
12030: * HERE FOR INTEGER ARGUMENTS
12031: *
12032: SBI ICVAL(XL) SUBTRACT TO COMPARE
12033: IOV ACMP3 JUMP IF OVERFLOW
12034: ILT ACMP5 ELSE JUMP IF ARG1 LT ARG2
12035: IEQ ACMP2 JUMP IF ARG1 EQ ARG2
12036: *
12037: * HERE IF ARG1 GT ARG2
12038: *
12039: ACMP1 EXI 5 TAKE GT EXIT
12040: *
12041: * HERE IF ARG1 EQ ARG2
12042: *
12043: ACMP2 EXI 4 TAKE EQ EXIT
12044: EJC
12045: *
12046: * ACOMP (CONTINUED)
12047: *
12048: * HERE FOR INTEGER OVERFLOW ON SUBTRACT
12049: *
12050: ACMP3 LDI ICVAL(XL) LOAD SECOND ARGUMENT
12051: ILT ACMP1 GT IF NEGATIVE
12052: BRN ACMP5 ELSE LT
12053: *
12054: * HERE FOR REAL OPERANDS
12055: *
12056: ACMP4 SBR RCVAL(XL) SUBTRACT TO COMPARE
12057: ROV ACMP6 JUMP IF OVERFLOW
12058: RGT ACMP1 ELSE JUMP IF ARG1 GT
12059: REQ ACMP2 JUMP IF ARG1 EQ ARG2
12060: *
12061: * HERE IF ARG1 LT ARG2
12062: *
12063: ACMP5 EXI 3 TAKE LT EXIT
12064: *
12065: * HERE IF OVERFLOW ON REAL SUBTRACTION
12066: *
12067: ACMP6 LDR RCVAL(XL) RELOAD ARG2
12068: RLT ACMP1 GT IF NEGATIVE
12069: BRN ACMP5 ELSE LT
12070: *
12071: * HERE IF ARG1 NON-NUMERIC
12072: *
12073: ACMP7 EXI 1 TAKE ERROR EXIT
12074: *
12075: * HERE IF ARG2 NON-NUMERIC
12076: *
12077: ACMP8 EXI 2 TAKE ERROR EXIT
12078: ENP END PROCEDURE ACOMP
12079: EJC
12080: *
12081: * ALLOC ALLOCATE BLOCK OF DYNAMIC STORAGE
12082: *
12083: * (WA) LENGTH REQUIRED IN BYTES
12084: * JSR ALLOC CALL TO ALLOCATE BLOCK
12085: * (XR) POINTER TO ALLOCATED BLOCK
12086: *
12087: * A POSSIBLE ALTERNATIVE TO AOV .. AND FOLLOWING STMT IS -
12088: * MOV DNAME,XR . SUB WA,XR . BLO XR,DNAMP,ALOC2 .
12089: * MOV DNAMP,XR . ADD WA,XR
12090: *
12091: ALLOC PRC E,0 ENTRY POINT
12092: *
12093: * COMMON EXIT POINT
12094: *
12095: ALOC1 MOV DNAMP,XR POINT TO NEXT AVAILABLE LOC
12096: AOV WA,XR,ALOC2 POINT PAST ALLOCATED BLOCK
12097: BGT XR,DNAME,ALOC2 JUMP IF NOT ENOUGH ROOM
12098: MOV XR,DNAMP STORE NEW POINTER
12099: SUB WA,XR POINT BACK TO START OF ALLOCATED BK
12100: EXI RETURN TO CALLER
12101: *
12102: * HERE IF INSUFFICIENT ROOM, TRY A GARBAGE COLLECTION
12103: *
12104: ALOC2 MOV WB,ALLSV SAVE WB
12105: ZER WB SET NO UPWARD MOVE FOR GBCOL
12106: JSR GBCOL GARBAGE COLLECT
12107: *
12108: * SEE IF ROOM AFTER GBCOL OR SYSMM CALL
12109: *
12110: ALOC3 MOV DNAMP,XR POINT TO FIRST AVAILABLE LOC
12111: AOV WA,XR,ALC3A POINT PAST NEW BLOCK
12112: BLO XR,DNAME,ALOC4 JUMP IF THERE IS ROOM NOW
12113: *
12114: * FAILED AGAIN, SEE IF WE CAN GET MORE CORE
12115: *
12116: ALC3A JSR SYSMM TRY TO GET MORE MEMORY
12117: WTB XR CONVERT TO BAUS (SGD05)
12118: ADD XR,DNAME BUMP PTR BY AMOUNT OBTAINED
12119: BNZ XR,ALOC3 JUMP IF GOT MORE CORE
12120: ADD RSMEM,DNAME GET THE RESERVE MEMORY
12121: ZER RSMEM ONLY PERMISSIBLE ONCE
12122: ICV ERRFT FATAL ERROR
12123: ERB 204,MEMORY OVERFLOW
12124: EJC
12125: *
12126: * HERE AFTER SUCCESSFUL GARBAGE COLLECTION
12127: *
12128: ALOC4 STI ALLIA SAVE IA
12129: MOV DNAME,WB GET DYNAMIC END ADRS
12130: SUB DNAMP,WB COMPUTE FREE STORE
12131: BTW WB CONVERT BYTES TO WORDS
12132: MTI WB PUT FREE STORE IN IA
12133: MLI ALFSF MULTIPLY BY FREE STORE FACTOR
12134: IOV ALOC5 JUMP IF OVERFLOWED
12135: MOV DNAME,WB DYNAMIC END ADRS
12136: SUB DNAMB,WB COMPUTE TOTAL AMOUNT OF DYNAMIC
12137: BTW WB CONVERT TO WORDS
12138: MOV WB,ALDYN STORE IT
12139: SBI ALDYN SUBTRACT FROM SCALED UP FREE STORE
12140: IGT ALOC5 JUMP IF SUFFICIENT FREE STORE
12141: JSR SYSMM TRY TO GET MORE STORE
12142: WTB XR CONVERT TO BAUS (SGD05)
12143: ADD XR,DNAME ADJUST DYNAMIC END ADRS
12144: *
12145: * MERGE TO RESTORE IA AND WB
12146: *
12147: ALOC5 LDI ALLIA RECOVER IA
12148: MOV ALLSV,WB RESTORE WB
12149: BRN ALOC1 JUMP BACK TO EXIT
12150: ENP END PROCEDURE ALLOC
12151: EJC
12152: *
12153: * ALOBF -- ALLOCATE BUFFER
12154: *
12155: * THIS ROUTINES ALLOCATES A NEW BUFFER. AS THE BFBLK
12156: * AND BCBLK COME IN PAIRS, BOTH ARE ALLOCATED HERE,
12157: * AND XR POINTS TO THE BCBLK ON RETURN. THE BFBLK
12158: * AND BCBLK ARE SET TO THE NULL BUFFER, AND THE IDVAL
12159: * IS ZERO ON RETURN.
12160: *
12161: * (WA) BUFFER SIZE IN CHARACTERS
12162: * JSR ALOBF CALL TO CREATE BUFFER
12163: * (XR) BCBLK PTR
12164: * (WA,WB) DESTROYED
12165: *
12166: ALOBF PRC E,0 ENTRY POINT
12167: MOV WA,WB HANG ONTO ALLOCATION SIZE
12168: CTB WA,BFSI$ GET TOTAL BLOCK SIZE
12169: BGE WA,MXLEN,ALB01 CHECK FOR MAXLEN EXCEEDED
12170: ADD *BCSI$,WA ADD IN ALLOCATION FOR BCBLK
12171: JSR ALLOC ALLOCATE FRAME
12172: MOV =B$BCT,(XR) SET TYPE
12173: ZER IDVAL(XR) NO ID YET
12174: ZER BCLEN(XR) NO DEFINED LENGTH
12175: MOV XL,WA SAVE XL
12176: MOV XR,XL COPY BCBLK PTR
12177: ADD *BCSI$,XL BIAS PAST PARTIALLY BUILT BCBLK
12178: MOV =B$BFT,(XL) SET BFBLK TYPE WORD
12179: MOV WB,BFALC(XL) SET ALLOCATED SIZE
12180: MOV XL,BCBUF(XR) SET POINTER IN BCBLK
12181: ZER BFCHR(XL) CLEAR FIRST WORD (NULL PAD)
12182: MOV WA,XL RESTORE ENTRY XL
12183: EXI RETURN TO CALLER
12184: *
12185: * HERE FOR MXLEN EXCEEDED
12186: *
12187: ALB01 ERB 274,REQUESTED BUFFER ALLOCATION EXCEEDS MXLEN
12188: ENP END PROCEDURE ALOBF
12189: EJC
12190: *
12191: * ALOCS -- ALLOCATE STRING BLOCK
12192: *
12193: * ALOCS IS USED TO BUILD A FRAME FOR A STRING BLOCK INTO
12194: * WHICH THE ACTUAL CHARACTERS ARE PLACED BY THE CALLER.
12195: * ALL STRINGS ARE CREATED WITH A CALL TO ALOCS (THE
12196: * EXCEPTIONS OCCUR IN TRIMR AND S$RPL PROCEDURES).
12197: *
12198: * (WA) LENGTH OF STRING TO BE ALLOCATED
12199: * JSR ALOCS CALL TO ALLOCATE SCBLK
12200: * (XR) POINTER TO RESULTING SCBLK
12201: * (WA) DESTROYED
12202: * (WC) CHARACTER COUNT (ENTRY VALUE OF WA)
12203: *
12204: * THE RESULTING SCBLK HAS THE TYPE WORD AND THE LENGTH
12205: * FILLED IN AND THE LAST WORD IS CLEARED TO ZERO CHARACTERS
12206: * TO ENSURE CORRECT RIGHT PADDING OF THE FINAL WORD.
12207: *
12208: ALOCS PRC E,0 ENTRY POINT
12209: BGT WA,KVMXL,ALCS2 JUMP IF LENGTH EXCEEEDS MAXLENGTH
12210: MOV WA,WC ELSE COPY LENGTH
12211: CTB WA,SCSI$ COMPUTE LENGTH OF SCBLK IN BYTES
12212: MOV DNAMP,XR POINT TO NEXT AVAILABLE LOCATION
12213: AOV WA,XR,ALCS0 POINT PAST BLOCK
12214: BLO XR,DNAME,ALCS1 JUMP IF THERE IS ROOM
12215: *
12216: * INSUFFICIENT MEMORY
12217: *
12218: ALCS0 ZER XR ELSE CLEAR GARBAGE XR VALUE
12219: JSR ALLOC AND USE STANDARD ALLOCATOR
12220: ADD WA,XR POINT PAST END OF BLOCK TO MERGE
12221: *
12222: * MERGE HERE WITH XR POINTING BEYOND NEW BLOCK
12223: *
12224: ALCS1 MOV XR,DNAMP SET UPDATED STORAGE POINTER
12225: ZER -(XR) STORE ZERO CHARS IN LAST WORD
12226: DCA WA DECREMENT LENGTH
12227: SUB WA,XR POINT BACK TO START OF BLOCK
12228: MOV =B$SCL,(XR) SET TYPE WORD
12229: MOV WC,SCLEN(XR) STORE LENGTH IN CHARS
12230: EXI RETURN TO ALOCS CALLER
12231: *
12232: * COME HERE IF STRING IS TOO LONG
12233: *
12234: ALCS2 ERB 205,STRING LENGTH EXCEEDS VALUE OF MAXLNGTH KEYWORD
12235: ENP END PROCEDURE ALOCS
12236: EJC
12237: *
12238: * ALOST -- ALLOCATE SPACE IN STATIC REGION
12239: *
12240: * (WA) LENGTH REQUIRED IN BYTES
12241: * JSR ALOST CALL TO ALLOCATE SPACE
12242: * (XR) POINTER TO ALLOCATED BLOCK
12243: * (WB) DESTROYED
12244: *
12245: * NOTE THAT THE CODING ENSURES THAT THE RESULTING VALUE
12246: * OF STATE IS ALWAYS LESS THAN DNAMB. THIS FACT IS USED
12247: * IN TESTING A VARIABLE NAME FOR BEING IN THE STATIC REGION
12248: *
12249: ALOST PRC E,0 ENTRY POINT
12250: *
12251: * MERGE BACK HERE AFTER ALLOCATING NEW CHUNK
12252: *
12253: ALST1 MOV STATE,XR POINT TO CURRENT END OF AREA
12254: AOV WA,XR,ALST2 POINT BEYOND PROPOSED BLOCK
12255: BGE XR,DNAMB,ALST2 JUMP IF OVERLAP WITH DYNAMIC AREA
12256: MOV XR,STATE ELSE STORE NEW POINTER
12257: SUB WA,XR POINT BACK TO START OF BLOCK
12258: EXI RETURN TO ALOST CALLER
12259: *
12260: * HERE IF NO ROOM, PREPARE TO MOVE DYNAMIC STORAGE UP
12261: *
12262: ALST2 MOV WA,ALSTA SAVE WA
12263: BGE WA,*E$STS,ALST3 SKIP IF REQUESTED CHUNK IS LARGE
12264: MOV *E$STS,WA ELSE SET TO GET LARGE ENOUGH CHUNK
12265: *
12266: * HERE WITH AMOUNT TO MOVE UP IN WA
12267: *
12268: ALST3 JSR ALLOC ALLOCATE BLOCK TO ENSURE ROOM
12269: MOV XR,DNAMP AND DELETE IT
12270: MOV WA,WB COPY MOVE UP AMOUNT
12271: JSR GBCOL CALL GBCOL TO MOVE DYNAMIC AREA UP
12272: MOV ALSTA,WA RESTORE WA
12273: BRN ALST1 LOOP BACK TO TRY AGAIN
12274: ENP END PROCEDURE ALOST
12275: EJC
12276: *
12277: * APNDB -- APPEND STRING TO BUFFER
12278: *
12279: * THIS ROUTINE IS USED BY BUFFER HANDLING ROUTINES TO
12280: * APPEND DATA TO AN EXISTING BFBLK.
12281: *
12282: * (XR) EXISTING BCBLK TO BE APPENDED
12283: * (XL) CONVERTABLE TO STRING
12284: * JSR APNDB CALL TO APPEND TO BUFFER
12285: * PPM LOC THREAD IF (XL) CANT BE CONVERTED
12286: * PPM LOC IF NOT ENOUGH ROOM
12287: * (WA,WB) DESTROYED
12288: *
12289: * IF MORE CHARACTERS ARE SPECIFIED THAN CAN BE INSERTED,
12290: * THEN NO ACTION IS TAKEN AND THE SECOND RETURN IS TAKEN.
12291: *
12292: APNDB PRC E,2 ENTRY POINT
12293: MOV BCLEN(XR),WA LOAD OFFSET TO INSERT
12294: ZER WB REPLACE SECTION IS NULL
12295: JSR INSBF CALL TO INSERT AT END
12296: PPM APN01 CONVERT ERROR
12297: PPM APN02 NO ROOM
12298: EXI RETURN TO CALLER
12299: *
12300: * HERE TO TAKE CONVERT FAILURE EXIT
12301: *
12302: APN01 EXI 1 RETURN TO CALLER ALTERNATE
12303: *
12304: * HERE FOR NO FIT EXIT
12305: *
12306: APN02 EXI 2 ALTERNATE EXIT TO CALLER
12307: ENP END PROCEDURE APNDB
12308: EJC
12309: *
12310: * ARITH -- FETCH ARITHMETIC OPERANDS
12311: *
12312: * ARITH IS USED BY FUNCTIONS AND OPERATORS WHICH EXPECT
12313: * TWO NUMERIC ARGUMENTS (OPERANDS) WHICH MUST BOTH BE
12314: * INTEGER OR BOTH BE REAL. ARITH FETCHES TWO ARGUMENTS FROM
12315: * THE STACK AND PERFORMS ANY NECESSARY CONVERSIONS.
12316: *
12317: * 1(XS) FIRST ARGUMENT (LEFT OPERAND)
12318: * 0(XS) SECOND ARGUMENT (RIGHT OPERAND)
12319: * JSR ARITH CALL TO FETCH NUMERIC ARGUMENTS
12320: * PPM LOC TRANSFER LOC FOR OPND 1 NON-NUMERIC
12321: * PPM LOC TRANSFER LOC FOR OPND 2 NON-NUMERIC
12322: * PPM LOC TRANSFER LOC FOR REAL OPERANDS
12323: *
12324: * FOR INTEGER ARGS, CONTROL RETURNS PAST THE PARAMETERS
12325: *
12326: * (IA) LEFT OPERAND VALUE
12327: * (XR) PTR TO ICBLK FOR LEFT OPERAND
12328: * (XL) PTR TO ICBLK FOR RIGHT OPERAND
12329: * (XS) POPPED TWICE
12330: * (WA,WB,RA) DESTROYED
12331: *
12332: * FOR REAL ARGUMENTS, CONTROL RETURNS TO THE LOCATION
12333: * SPECIFIED BY THE THIRD PARAMETER.
12334: *
12335: * (RA) LEFT OPERAND VALUE
12336: * (XR) PTR TO RCBLK FOR LEFT OPERAND
12337: * (XL) PTR TO RCBLK FOR RIGHT OPERAND
12338: * (WA,WB,WC) DESTROYED
12339: * (XS) POPPED TWICE
12340: EJC
12341: *
12342: * ARITH (CONTINUED)
12343: *
12344: * ENTRY POINT
12345: *
12346: ARITH PRC N,3 ENTRY POINT
12347: MOV (XS)+,XL LOAD RIGHT OPERAND
12348: MOV (XS)+,XR LOAD LEFT OPERAND
12349: MOV (XL),WA GET RIGHT OPERAND TYPE WORD
12350: BEQ WA,=B$ICL,ARTH1 JUMP IF INTEGER
12351: BEQ WA,=B$RCL,ARTH4 JUMP IF REAL
12352: MOV XR,-(XS) ELSE REPLACE LEFT ARG ON STACK
12353: MOV XL,XR COPY LEFT ARG POINTER
12354: JSR GTNUM CONVERT TO NUMERIC
12355: PPM ARTH6 JUMP IF UNCONVERTIBLE
12356: MOV XR,XL ELSE COPY CONVERTED RESULT
12357: MOV (XL),WA GET RIGHT OPERAND TYPE WORD
12358: MOV (XS)+,XR RELOAD LEFT ARGUMENT
12359: BEQ WA,=B$RCL,ARTH4 JUMP IF RIGHT ARG IS REAL
12360: *
12361: * HERE IF RIGHT ARG IS AN INTEGER
12362: *
12363: ARTH1 BNE (XR),=B$ICL,ARTH3 JUMP IF LEFT ARG NOT INTEGER
12364: *
12365: * EXIT FOR INTEGER CASE
12366: *
12367: ARTH2 LDI ICVAL(XR) LOAD LEFT OPERAND VALUE
12368: EXI RETURN TO ARITH CALLER
12369: *
12370: * HERE FOR RIGHT OPERAND INTEGER, LEFT OPERAND NOT
12371: *
12372: ARTH3 JSR GTNUM CONVERT LEFT ARG TO NUMERIC
12373: PPM ARTH7 JUMP IF NOT CONVERTIBLE
12374: BEQ WA,=B$ICL,ARTH2 JUMP BACK IF INTEGER-INTEGER
12375: *
12376: * HERE WE MUST CONVERT REAL-INTEGER TO REAL-REAL
12377: *
12378: MOV XR,-(XS) PUT LEFT ARG BACK ON STACK
12379: LDI ICVAL(XL) LOAD RIGHT ARGUMENT VALUE
12380: ITR CONVERT TO REAL
12381: JSR RCBLD GET REAL BLOCK FOR RIGHT ARG, MERGE
12382: MOV XR,XL COPY RIGHT ARG PTR
12383: MOV (XS)+,XR LOAD LEFT ARGUMENT
12384: BRN ARTH5 MERGE FOR REAL-REAL CASE
12385: EJC
12386: *
12387: * ARITH (CONTINUED)
12388: *
12389: * HERE IF RIGHT ARGUMENT IS REAL
12390: *
12391: ARTH4 BEQ (XR),=B$RCL,ARTH5 JUMP IF LEFT ARG REAL
12392: JSR GTREA ELSE CONVERT TO REAL
12393: PPM ARTH7 ERROR IF UNCONVERTIBLE
12394: *
12395: * HERE FOR REAL-REAL
12396: *
12397: ARTH5 LDR RCVAL(XR) LOAD LEFT OPERAND VALUE
12398: EXI 3 TAKE REAL-REAL EXIT
12399: *
12400: * HERE FOR ERROR CONVERTING RIGHT ARGUMENT
12401: *
12402: ARTH6 ICA XS POP UNWANTED LEFT ARG
12403: EXI 2 TAKE APPROPRIATE ERROR EXIT
12404: *
12405: * HERE FOR ERROR CONVERTING LEFT OPERAND
12406: *
12407: ARTH7 EXI 1 TAKE APPROPRIATE ERROR RETURN
12408: ENP END PROCEDURE ARITH
12409: EJC
12410: *
12411: * ASIGN -- PERFORM ASSIGNMENT
12412: *
12413: * ASIGN PERFORMS THE ASSIGNMENT OF A VALUE TO A VARIABLE
12414: * WITH APPROPRIATE CHECKS FOR OUTPUT ASSOCIATIONS AND
12415: * VALUE TRACE ASSOCIATIONS WHICH ARE EXECUTED AS REQUIRED.
12416: * ASIGN ALSO HANDLES THE SPECIAL CASES OF ASSIGNMENT TO
12417: * PATTERN AND EXPRESSION VARIABLES.
12418: *
12419: * (WB) VALUE TO BE ASSIGNED
12420: * (XL) BASE POINTER FOR VARIABLE
12421: * (WA) OFFSET FOR VARIABLE
12422: * JSR ASIGN CALL TO ASSIGN VALUE TO VARIABLE
12423: * PPM LOC TRANSFER LOC FOR FAILURE
12424: * (XR,XL,WA,WB,WC) DESTROYED
12425: * (RA) DESTROYED
12426: *
12427: * FAILURE OCCURS IF THE EVALUATION OF AN EXPRESSION
12428: * ASSOCIATED WITH AN EXPRESSION VARIABLE FAILS.
12429: *
12430: ASIGN PRC R,1 ENTRY POINT (RECURSIVE)
12431: *
12432: * MERGE BACK HERE TO ASSIGN RESULT TO EXPRESSION VARIABLE.
12433: *
12434: ASG01 ADD WA,XL POINT TO VARIABLE VALUE
12435: MOV (XL),XR LOAD VARIABLE VALUE
12436: BEQ (XR),=B$TRT,ASG02 JUMP IF TRAPPED
12437: MOV WB,(XL) ELSE PERFORM ASSIGNMENT
12438: ZER XL CLEAR GARBAGE VALUE IN XL
12439: EXI AND RETURN TO ASIGN CALLER
12440: *
12441: * HERE IF VALUE IS TRAPPED
12442: *
12443: ASG02 SUB WA,XL RESTORE NAME BASE
12444: BEQ XR,=TRBKV,ASG14 JUMP IF KEYWORD VARIABLE
12445: BNE XR,=TRBEV,ASG04 JUMP IF NOT EXPRESSION VARIABLE
12446: *
12447: * HERE FOR ASSIGNMENT TO EXPRESSION VARIABLE
12448: *
12449: MOV EVEXP(XL),XR POINT TO EXPRESSION
12450: MOV WB,-(XS) STORE VALUE TO ASSIGN ON STACK
12451: MOV =NUM01,WB SET FOR EVALUATION BY NAME
12452: JSR EVALX EVALUATE EXPRESSION BY NAME
12453: PPM ASG03 JUMP IF EVALUATION FAILS
12454: MOV (XS)+,WB ELSE RELOAD VALUE TO ASSIGN
12455: BRN ASG01 LOOP BACK TO PERFORM ASSIGNMENT
12456: EJC
12457: *
12458: * ASIGN (CONTINUED)
12459: *
12460: * HERE FOR FAILURE DURING EXPRESSION EVALUATION
12461: *
12462: ASG03 ICA XS REMOVE STACKED VALUE ENTRY
12463: EXI 1 TAKE FAILURE EXIT
12464: *
12465: * HERE IF NOT KEYWORD OR EXPRESSION VARIABLE
12466: *
12467: ASG04 MOV XR,-(XS) SAVE PTR TO FIRST TRBLK
12468: *
12469: * LOOP TO CHASE DOWN TRBLK CHAIN AND ASSIGN VALUE AT END
12470: *
12471: ASG05 MOV XR,WC SAVE PTR TO THIS TRBLK
12472: MOV TRNXT(XR),XR POINT TO NEXT TRBLK
12473: BEQ (XR),=B$TRT,ASG05 LOOP BACK IF ANOTHER TRBLK
12474: MOV WC,XR ELSE POINT BACK TO LAST TRBLK
12475: MOV WB,TRVAL(XR) STORE VALUE AT END OF CHAIN
12476: MOV (XS)+,XR RESTORE PTR TO FIRST TRBLK
12477: *
12478: * LOOP TO PROCESS TRBLK ENTRIES ON CHAIN
12479: *
12480: ASG06 MOV TRTYP(XR),WB LOAD TYPE CODE OF TRBLK
12481: BEQ WB,=TRTVL,ASG08 JUMP IF VALUE TRACE
12482: BEQ WB,=TRTOU,ASG10 JUMP IF OUTPUT ASSOCIATION
12483: *
12484: * HERE TO MOVE TO NEXT TRBLK ON CHAIN
12485: *
12486: ASG07 MOV TRNXT(XR),XR POINT TO NEXT TRBLK ON CHAIN
12487: BEQ (XR),=B$TRT,ASG06 LOOP BACK IF ANOTHER TRBLK
12488: EXI ELSE END OF CHAIN, RETURN TO CALLER
12489: *
12490: * HERE TO PROCESS VALUE TRACE
12491: *
12492: ASG08 BZE KVTRA,ASG07 IGNORE VALUE TRACE IF TRACE OFF
12493: DCV KVTRA ELSE DECREMENT TRACE COUNT
12494: BZE TRFNC(XR),ASG09 JUMP IF PRINT TRACE
12495: JSR TRXEQ ELSE EXECUTE FUNCTION TRACE
12496: BRN ASG07 AND LOOP BACK
12497: EJC
12498: *
12499: * ASIGN (CONTINUED)
12500: *
12501: * HERE FOR PRINT TRACE
12502: *
12503: ASG09 JSR PRTSN PRINT STATEMENT NUMBER
12504: JSR PRTNV PRINT NAME = VALUE
12505: BRN ASG07 LOOP BACK FOR NEXT TRBLK
12506: *
12507: * HERE FOR OUTPUT ASSOCIATION
12508: *
12509: ASG10 BZE KVOUP,ASG07 IGNORE OUTPUT ASSOC IF OUTPUT OFF
12510: MOV XR,XL ELSE COPY TRBLK POINTER
12511: MOV TRVAL(WC),-(XS) STACK VALUE TO OUTPUT (SGD01)
12512: JSR GTSTG CONVERT TO STRING
12513: PPM ASG12 GET DATATYPE NAME IF UNCONVERTIBLE
12514: *
12515: * MERGE WITH STRING FOR OUTPUT
12516: *
12517: ASG11 MOV TRFPT(XL),WA FCBLK PTR
12518: BZE WA,ASG13 JUMP IF STANDARD OUTPUT FILE
12519: *
12520: * HERE FOR OUTPUT TO NON-STANDARD OUTPUT FILE
12521: *
12522: JSR SYSOU CALL SYSTEM OUTPUT ROUTINE
12523: ERR 206,OUTPUT CAUSED FILE OVERFLOW
12524: ERR 207,OUTPUT CAUSED NON-RECOVERABLE ERROR
12525: EXI ELSE ALL DONE, RETURN TO CALLER
12526: *
12527: * IF NOT PRINTABLE, GET DATATYPE NAME INSTEAD
12528: *
12529: ASG12 JSR DTYPE CALL DATATYPE ROUTINE
12530: BRN ASG11 MERGE
12531: *
12532: * HERE TO PRINT A STRING ON THE PRINTER
12533: *
12534: ASG13 JSR PRTST PRINT STRING VALUE
12535: BEQ TRTER(XL),=V$TER,ASG20 JUMP IF TERMINAL OUTPUT
12536: JSR PRTNL END OF LINE
12537: EXI RETURN TO CALLER
12538: EJC
12539: *
12540: * ASIGN (CONTINUED)
12541: *
12542: * HERE FOR KEYWORD ASSIGNMENT
12543: *
12544: ASG14 MOV KVNUM(XL),XL LOAD KEYWORD NUMBER
12545: BEQ XL,=K$ETX,ASG19 JUMP IF ERRTEXT
12546: MOV WB,XR COPY VALUE TO BE ASSIGNED
12547: JSR GTINT CONVERT TO INTEGER
12548: ERR 208,KEYWORD VALUE ASSIGNED IS NOT INTEGER
12549: LDI ICVAL(XR) ELSE LOAD VALUE
12550: BEQ XL,=K$STL,ASG16 JUMP IF SPECIAL CASE OF STLIMIT
12551: MFI WA,ASG18 ELSE GET ADDR INTEGER, TEST OVFLOW
12552: BGE WA,MXLEN,ASG18 FAIL IF TOO LARGE
12553: BEQ XL,=K$ERT,ASG17 JUMP IF SPECIAL CASE OF ERRTYPE
12554: BEQ XL,=K$PFL,ASG21 JUMP IF SPECIAL CASE OF PROFILE
12555: BLT XL,=K$P$$,ASG15 JUMP UNLESS PROTECTED
12556: ERB 209,KEYWORD IN ASSIGNMENT IS PROTECTED
12557: *
12558: * HERE TO DO ASSIGNMENT IF NOT PROTECTED
12559: *
12560: ASG15 MOV WA,KVABE(XL) STORE NEW VALUE
12561: EXI RETURN TO ASIGN CALLER
12562: *
12563: * HERE FOR SPECIAL CASE OF STLIMIT
12564: *
12565: * SINCE STCOUNT IS MAINTAINED AS (STLIMIT-STCOUNT)
12566: * IT IS ALSO NECESSARY TO MODIFY STCOUNT APPROPRIATELY.
12567: *
12568: ASG16 SBI KVSTL SUBTRACT OLD LIMIT
12569: ADI KVSTC ADD OLD COUNTER
12570: STI KVSTC STORE NEW COUNTER VALUE
12571: LDI ICVAL(XR) RELOAD NEW LIMIT VALUE
12572: STI KVSTL STORE NEW LIMIT VALUE
12573: EXI RETURN TO ASIGN CALLER
12574: *
12575: * HERE FOR SPECIAL CASE OF ERRTYPE
12576: *
12577: ASG17 BLE WA,=NINI9,ERROR OK TO SIGNAL IF IN RANGE
12578: *
12579: * HERE IF VALUE ASSIGNED IS OUT OF RANGE
12580: *
12581: ASG18 ERB 210,KEYWORD VALUE ASSIGNED IS NEGATIVE OR TOO LARGE
12582: *
12583: * HERE FOR SPECIAL CASE OF ERRTEXT
12584: *
12585: ASG19 MOV WB,-(XS) STACK VALUE
12586: JSR GTSTG CONVERT TO STRING
12587: ERR 211,VALUE ASSIGNED TO KEYWORD ERRTEXT NOT A STRING
12588: MOV XR,R$ETX MAKE ASSIGNMENT
12589: EXI RETURN TO CALLER
12590: *
12591: * PRINT STRING TO TERMINAL
12592: *
12593: ASG20 JSR PRTTR PRINT
12594: EXI RETURN
12595: *
12596: * HERE FOR KEYWORD PROFILE
12597: *
12598: ASG21 BGT WA,=NUM02,ASG18 MOAN IF NOT 0,1, OR 2
12599: BZE WA,ASG15 JUST ASSIGN IF ZERO
12600: BZE PFDMP,ASG22 BRANCH IF FIRST ASSIGNMENT
12601: BEQ WA,PFDMP,ASG23 ALSO IF SAME VALUE AS BEFORE
12602: ERB 268,INCONSISTENT VALUE ASSIGNED TO KEYWORD PROFILE
12603: *
12604: ASG22 MOV WA,PFDMP NOTE VALUE ON FIRST ASSIGNMENT
12605: ASG23 JSR SYSTM GET THE TIME
12606: STI PFSTM FUDGE SOME KIND OF START TIME
12607: BRN ASG15 AND GO ASSIGN
12608: ENP END PROCEDURE ASIGN
12609: EJC
12610: *
12611: * ASINP -- ASSIGN DURING PATTERN MATCH
12612: *
12613: * ASINP IS LIKE ASIGN AND HAS A SIMILAR CALLING SEQUENCE
12614: * AND EFFECT. THE DIFFERENCE IS THAT THE GLOBAL PATTERN
12615: * VARIABLES ARE SAVED AND RESTORED IF REQUIRED.
12616: *
12617: * (XL) BASE POINTER FOR VARIABLE
12618: * (WA) OFFSET FOR VARIABLE
12619: * (WB) VALUE TO BE ASSIGNED
12620: * JSR ASINP CALL TO ASSIGN VALUE TO VARIABLE
12621: * PPM LOC TRANSFER LOC IF FAILURE
12622: * (XR,XL) DESTROYED
12623: * (WA,WB,WC,RA) DESTROYED
12624: *
12625: ASINP PRC R,1 ENTRY POINT, RECURSIVE
12626: ADD WA,XL POINT TO VARIABLE
12627: MOV (XL),XR LOAD CURRENT CONTENTS
12628: BEQ (XR),=B$TRT,ASNP1 JUMP IF TRAPPED
12629: MOV WB,(XL) ELSE PERFORM ASSIGNMENT
12630: ZER XL CLEAR GARBAGE VALUE IN XL
12631: EXI RETURN TO ASINP CALLER
12632: *
12633: * HERE IF VARIABLE IS TRAPPED
12634: *
12635: ASNP1 SUB WA,XL RESTORE BASE POINTER
12636: MOV PMSSL,-(XS) STACK SUBJECT STRING LENGTH
12637: MOV PMHBS,-(XS) STACK HISTORY STACK BASE PTR
12638: MOV R$PMS,-(XS) STACK SUBJECT STRING POINTER
12639: MOV PMDFL,-(XS) STACK DOT FLAG
12640: JSR ASIGN CALL FULL-BLOWN ASSIGNMENT ROUTINE
12641: PPM ASNP2 JUMP IF FAILURE
12642: MOV (XS)+,PMDFL RESTORE DOT FLAG
12643: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER
12644: MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER
12645: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH
12646: EXI RETURN TO ASINP CALLER
12647: *
12648: * HERE IF FAILURE IN ASIGN CALL
12649: *
12650: ASNP2 MOV (XS)+,PMDFL RESTORE DOT FLAG
12651: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER
12652: MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER
12653: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH
12654: EXI 1 TAKE FAILURE EXIT
12655: ENP END PROCEDURE ASINP
12656: EJC
12657: *
12658: * BLKLN -- DETERMINE LENGTH OF BLOCK
12659: *
12660: * BLKLN DETERMINES THE LENGTH OF A BLOCK IN DYNAMIC STORE.
12661: *
12662: * (WA) FIRST WORD OF BLOCK
12663: * (XR) POINTER TO BLOCK
12664: * JSR BLKLN CALL TO GET BLOCK LENGTH
12665: * (WA) LENGTH OF BLOCK IN BYTES
12666: * (XL) DESTROYED
12667: *
12668: * BLKLN IS USED BY THE GARBAGE COLLECTOR AND IS NOT
12669: * PERMITTED TO CALL GBCOL DIRECTLY OR INDIRECTLY.
12670: *
12671: * THE FIRST WORD STORED IN THE BLOCK (I.E. AT XR) MAY
12672: * BE ANYTHING, BUT THE CONTENTS OF WA MUST BE CORRECT.
12673: *
12674: BLKLN PRC E,0 ENTRY POINT
12675: MOV WA,XL COPY FIRST WORD
12676: LEI XL GET ENTRY ID (BL$XX)
12677: BSW XL,BL$$$,BLN00 SWITCH ON BLOCK TYPE
12678: IFF BL$AR,BLN01 ARBLK
12679: IFF BL$BC,BLN04 BCBLK
12680: IFF BL$BF,BLN11 BFBLK
12681: IFF BL$CD,BLN01 CDBLK
12682: IFF BL$DF,BLN01 DFBLK
12683: IFF BL$EF,BLN01 EFBLK
12684: IFF BL$EX,BLN01 EXBLK
12685: IFF BL$PF,BLN01 PFBLK
12686: IFF BL$TB,BLN01 TBBLK
12687: IFF BL$VC,BLN01 VCBLK
12688: IFF BL$EV,BLN03 EVBLK
12689: IFF BL$KV,BLN03 KVBLK
12690: IFF BL$P0,BLN02 P0BLK
12691: IFF BL$SE,BLN02 SEBLK
12692: IFF BL$NM,BLN03 NMBLK
12693: IFF BL$P1,BLN03 P1BLK
12694: IFF BL$P2,BLN04 P2BLK
12695: IFF BL$TE,BLN04 TEBLK
12696: IFF BL$FF,BLN05 FFBLK
12697: IFF BL$TR,BLN05 TRBLK
12698: IFF BL$CT,BLN06 CTBLK
12699: IFF BL$IC,BLN07 ICBLK
12700: IFF BL$PD,BLN08 PDBLK
12701: IFF BL$RC,BLN09 RCBLK
12702: IFF BL$SC,BLN10 SCBLK
12703: ESW END OF JUMP TABLE ON BLOCK TYPE
12704: EJC
12705: *
12706: * BLKLN (CONTINUED)
12707: *
12708: * HERE FOR BLOCKS WITH LENGTH IN SECOND WORD
12709: *
12710: BLN00 MOV 1(XR),WA LOAD LENGTH
12711: EXI RETURN TO BLKLN CALLER
12712: *
12713: * HERE FOR LENGTH IN THIRD WORD (AR,CD,DF,EF,EX,PF,TB,VC)
12714: *
12715: BLN01 MOV 2(XR),WA LOAD LENGTH FROM THIRD WORD
12716: EXI RETURN TO BLKLN CALLER
12717: *
12718: * HERE FOR TWO WORD BLOCKS (P0,SE)
12719: *
12720: BLN02 MOV *NUM02,WA LOAD LENGTH (TWO WORDS)
12721: EXI RETURN TO BLKLN CALLER
12722: *
12723: * HERE FOR THREE WORD BLOCKS (NM,P1,EV,KV)
12724: *
12725: BLN03 MOV *NUM03,WA LOAD LENGTH (THREE WORDS)
12726: EXI RETURN TO BLKLN CALLER
12727: *
12728: * HERE FOR FOUR WORD BLOCKS (P2,TE,BC)
12729: *
12730: BLN04 MOV *NUM04,WA LOAD LENGTH (FOUR WORDS)
12731: EXI RETURN TO BLKLN CALLER
12732: *
12733: * HERE FOR FIVE WORD BLOCKS (FF,TR)
12734: *
12735: BLN05 MOV *NUM05,WA LOAD LENGTH
12736: EXI RETURN TO BLKLN CALLER
12737: EJC
12738: *
12739: * BLKLN (CONTINUED)
12740: *
12741: * HERE FOR CTBLK
12742: *
12743: BLN06 MOV *CTSI$,WA SET SIZE OF CTBLK
12744: EXI RETURN TO BLKLN CALLER
12745: *
12746: * HERE FOR ICBLK
12747: *
12748: BLN07 MOV *ICSI$,WA SET SIZE OF ICBLK
12749: EXI RETURN TO BLKLN CALLER
12750: *
12751: * HERE FOR PDBLK
12752: *
12753: BLN08 MOV PDDFP(XR),XL POINT TO DFBLK
12754: MOV DFPDL(XL),WA LOAD PDBLK LENGTH FROM DFBLK
12755: EXI RETURN TO BLKLN CALLER
12756: *
12757: * HERE FOR RCBLK
12758: *
12759: BLN09 MOV *RCSI$,WA SET SIZE OF RCBLK
12760: EXI RETURN TO BLKLN CALLER
12761: *
12762: * HERE FOR SCBLK
12763: *
12764: BLN10 MOV SCLEN(XR),WA LOAD LENGTH IN CHARACTERS
12765: CTB WA,SCSI$ CALCULATE LENGTH IN BYTES
12766: EXI RETURN TO BLKLN CALLER
12767: *
12768: * HERE FOR BFBLK
12769: *
12770: BLN11 MOV BFALC(XR),WA GET ALLOCATION IN BYTES
12771: CTB WA,BFSI$ CALCULATE LENGTH IN BYTES
12772: EXI RETURN TO BLKLN CALLER
12773: ENP END PROCEDURE BLKLN
12774: EJC
12775: *
12776: * COPYB -- COPY A BLOCK
12777: *
12778: * (XS) BLOCK TO BE COPIED
12779: * JSR COPYB CALL TO COPY BLOCK
12780: * PPM LOC RETURN IF BLOCK HAS NO IDVAL FIELD
12781: * NORMAL RETURN IF IDVAL FIELD
12782: * (XR) COPY OF BLOCK
12783: * (XS) POPPED
12784: * (XL,WA,WB,WC) DESTROYED
12785: *
12786: COPYB PRC N,1 ENTRY POINT
12787: MOV (XS),XR LOAD ARGUMENT
12788: BEQ XR,=NULLS,COP10 RETURN ARGUMENT IF IT IS NULL
12789: MOV (XR),WA ELSE LOAD TYPE WORD
12790: MOV WA,WB COPY TYPE WORD
12791: JSR BLKLN GET LENGTH OF ARGUMENT BLOCK
12792: MOV XR,XL COPY POINTER
12793: JSR ALLOC ALLOCATE BLOCK OF SAME SIZE
12794: MOV XR,(XS) STORE POINTER TO COPY
12795: MVW COPY CONTENTS OF OLD BLOCK TO NEW
12796: MOV (XS),XR RELOAD POINTER TO START OF COPY
12797: BEQ WB,=B$TBT,COP05 JUMP IF TABLE
12798: BEQ WB,=B$VCT,COP01 JUMP IF VECTOR
12799: BEQ WB,=B$PDT,COP01 JUMP IF PROGRAM DEFINED
12800: BEQ WB,=B$BCT,COP11 JUMP IF BUFFER
12801: BNE WB,=B$ART,COP10 RETURN COPY IF NOT ARRAY
12802: *
12803: * HERE FOR ARRAY (ARBLK)
12804: *
12805: ADD AROFS(XR),XR POINT TO PROTOTYPE FIELD
12806: BRN COP02 JUMP TO MERGE
12807: *
12808: * HERE FOR VECTOR, PROGRAM DEFINED
12809: *
12810: COP01 ADD *PDFLD,XR POINT TO PDFLD = VCVLS
12811: *
12812: * MERGE HERE FOR ARBLK, VCBLK, PDBLK TO DELETE TRAP
12813: * BLOCKS FROM ALL VALUE FIELDS (THE COPY IS UNTRAPPED)
12814: *
12815: COP02 MOV (XR),XL LOAD NEXT POINTER
12816: *
12817: * LOOP TO GET VALUE AT END OF TRBLK CHAIN
12818: *
12819: COP03 BNE (XL),=B$TRT,COP04 JUMP IF NOT TRAPPED
12820: MOV TRVAL(XL),XL ELSE POINT TO NEXT VALUE
12821: BRN COP03 AND LOOP BACK
12822: EJC
12823: *
12824: * COPYB (CONTINUED)
12825: *
12826: * HERE WITH UNTRAPPED VALUE IN XL
12827: *
12828: COP04 MOV XL,(XR)+ STORE REAL VALUE, BUMP POINTER
12829: BNE XR,DNAMP,COP02 LOOP BACK IF MORE TO GO
12830: BRN COP09 ELSE JUMP TO EXIT
12831: *
12832: * HERE TO COPY A TABLE
12833: *
12834: COP05 ZER IDVAL(XR) ZERO ID TO STOP DUMP BLOWING UP
12835: MOV *TESI$,WA SET SIZE OF TEBLK
12836: MOV *TBBUK,WC SET INITIAL OFFSET
12837: *
12838: * LOOP THROUGH BUCKETS IN TABLE
12839: *
12840: COP06 MOV (XS),XR LOAD TABLE POINTER
12841: BEQ WC,TBLEN(XR),COP09 JUMP TO EXIT IF ALL DONE
12842: ADD WC,XR ELSE POINT TO NEXT BUCKET HEADER
12843: ICA WC BUMP OFFSET
12844: SUB *TENXT,XR SUBTRACT LINK OFFSET TO MERGE
12845: *
12846: * LOOP THROUGH TEBLKS ON ONE CHAIN
12847: *
12848: COP07 MOV TENXT(XR),XL LOAD POINTER TO NEXT TEBLK
12849: MOV (XS),TENXT(XR) SET END OF CHAIN POINTER IN CASE
12850: BEQ (XL),=B$TBT,COP06 BACK FOR NEXT BUCKET IF CHAIN END
12851: MOV XR,-(XS) ELSE STACK PTR TO PREVIOUS BLOCK
12852: MOV *TESI$,WA SET SIZE OF TEBLK
12853: JSR ALLOC ALLOCATE NEW TEBLK
12854: MOV XR,WB SAVE PTR TO NEW TEBLK
12855: MVW COPY OLD TEBLK TO NEW TEBLK
12856: MOV WB,XR RESTORE POINTER TO NEW TEBLK
12857: MOV (XS)+,XL RESTORE POINTER TO PREVIOUS BLOCK
12858: MOV XR,TENXT(XL) LINK NEW BLOCK TO PREVIOUS
12859: MOV XR,XL COPY POINTER TO NEW BLOCK
12860: *
12861: * LOOP TO SET REAL VALUE AFTER REMOVING TRAP CHAIN
12862: *
12863: COP08 MOV TEVAL(XL),XL LOAD VALUE
12864: BEQ (XL),=B$TRT,COP08 LOOP BACK IF TRAPPED
12865: MOV XL,TEVAL(XR) STORE UNTRAPPED VALUE IN TEBLK
12866: BRN COP07 BACK FOR NEXT TEBLK
12867: *
12868: * COMMON EXIT POINT
12869: *
12870: COP09 MOV (XS)+,XR LOAD POINTER TO BLOCK
12871: EXI RETURN
12872: *
12873: * ALTERNATIVE RETURN
12874: *
12875: COP10 EXI 1 RETURN
12876: EJC
12877: *
12878: * HERE TO COPY BUFFER
12879: *
12880: COP11 MOV BCBUF(XR),XL GET BFBLK PTR
12881: MOV BFALC(XL),WA GET ALLOCATION
12882: CTB WA,BFSI$ SET TOTAL SIZE
12883: MOV XR,XL SAVE BCBLK PTR
12884: JSR ALLOC ALLOCATE BFBLK
12885: MOV BCBUF(XL),WB GET OLD BFBLK
12886: MOV XR,BCBUF(XL) SET POINTER TO NEW BFBLK
12887: MOV WB,XL POINT TO OLD BFBLK
12888: MVW COPY BFBLK TOO
12889: ZER XL CLEAR RUBBISH PTR
12890: BRN COP09 BRANCH TO EXIT
12891: ENP END PROCEDURE COPYB
12892: *
12893: * CDGCG -- GENERATE CODE FOR COMPLEX GOTO
12894: *
12895: * USED BY CMPIL TO PROCESS COMPLEX GOTO TREE
12896: *
12897: * (WB) MUST BE COLLECTABLE
12898: * (XR) EXPRESSION POINTER
12899: * JSR CDGCG CALL TO GENERATE COMPLEX GOTO
12900: * (XL,XR,WA) DESTROYED
12901: *
12902: CDGCG PRC E,0 ENTRY POINT
12903: MOV CMOPN(XR),XL GET UNARY GOTO OPERATOR
12904: MOV CMROP(XR),XR POINT TO GOTO OPERAND
12905: BEQ XL,=OPDVD,CDGC2 JUMP IF DIRECT GOTO
12906: JSR CDGNM GENERATE OPND BY NAME IF NOT DIRECT
12907: *
12908: * RETURN POINT
12909: *
12910: CDGC1 MOV XL,WA GOTO OPERATOR
12911: JSR CDWRD GENERATE IT
12912: EXI RETURN TO CALLER
12913: *
12914: * DIRECT GOTO
12915: *
12916: CDGC2 JSR CDGVL GENERATE OPERAND BY VALUE
12917: BRN CDGC1 MERGE TO RETURN
12918: ENP END PROCEDURE CDGCG
12919: EJC
12920: *
12921: * CDGEX -- BUILD EXPRESSION BLOCK
12922: *
12923: * CDGEX IS PASSED A POINTER TO AN EXPRESSION TREE (SEE
12924: * EXPAN) AND RETURNS AN EXPRESSION (SEBLK OR EXBLK).
12925: *
12926: * (WC) SOME COLLECTABLE VALUE
12927: * (WB) INTEGER IN RANGE 0 LE X LE MXLEN
12928: * (XL) PTR TO EXPRESSION TREE
12929: * JSR CDGEX CALL TO BUILD EXPRESSION
12930: * (XR) PTR TO SEBLK OR EXBLK
12931: * (XL,WA,WB) DESTROYED
12932: *
12933: CDGEX PRC R,0 ENTRY POINT, RECURSIVE
12934: BLO (XL),=B$VR$,CDGX1 JUMP IF NOT VARIABLE
12935: *
12936: * HERE FOR NATURAL VARIABLE, BUILD SEBLK
12937: *
12938: MOV *SESI$,WA SET SIZE OF SEBLK
12939: JSR ALLOC ALLOCATE SPACE FOR SEBLK
12940: MOV =B$SEL,(XR) SET TYPE WORD
12941: MOV XL,SEVAR(XR) STORE VRBLK POINTER
12942: EXI RETURN TO CDGEX CALLER
12943: *
12944: * HERE IF NOT VARIABLE, BUILD EXBLK
12945: *
12946: CDGX1 MOV XL,XR COPY TREE POINTER
12947: MOV WC,-(XS) SAVE WC
12948: MOV CWCOF,XL SAVE CURRENT OFFSET
12949: MOV (XR),WA GET TYPE WORD
12950: BNE WA,=B$CMT,CDGX2 CALL BY VALUE IF NOT CMBLK
12951: BGE CMTYP(XR),=C$$NM,CDGX2 JUMP IF CMBLK ONLY BY VALUE
12952: EJC
12953: *
12954: * CDGEX (CONTINUED)
12955: *
12956: * HERE IF EXPRESSION CAN BE EVALUATED BY NAME
12957: *
12958: JSR CDGNM GENERATE CODE BY NAME
12959: MOV =ORNM$,WA LOAD RETURN BY NAME WORD
12960: BRN CDGX3 MERGE WITH VALUE CASE
12961: *
12962: * HERE IF EXPRESSION CAN ONLY BE EVALUATED BY VALUE
12963: *
12964: CDGX2 JSR CDGVL GENERATE CODE BY VALUE
12965: MOV =ORVL$,WA LOAD RETURN BY VALUE WORD
12966: *
12967: * MERGE HERE TO CONSTRUCT EXBLK
12968: *
12969: CDGX3 JSR CDWRD GENERATE RETURN WORD
12970: JSR EXBLD BUILD EXBLK
12971: MOV (XS)+,WC RESTORE WC
12972: EXI RETURN TO CDGEX CALLER
12973: ENP END PROCEDURE CDGEX
12974: EJC
12975: *
12976: * CDGNM -- GENERATE CODE BY NAME
12977: *
12978: * CDGNM IS CALLED DURING THE COMPILATION PROCESS TO
12979: * GENERATE CODE BY NAME FOR AN EXPRESSION. SEE CDBLK
12980: * DESCRIPTION FOR DETAILS OF CODE GENERATED. THE INPUT
12981: * TO CDGNM IS AN EXPRESSION TREE AS GENERATED BY EXPAN.
12982: *
12983: * CDGNM IS A RECURSIVE PROCEDURE WHICH PROCEEDS BY MAKING
12984: * RECURSIVE CALLS TO GENERATE CODE FOR OPERANDS.
12985: *
12986: * (WB) INTEGER IN RANGE 0 LE N LE DNAMB
12987: * (XR) PTR TO TREE GENERATED BY EXPAN
12988: * (WC) CONSTANT FLAG (SEE BELOW)
12989: * JSR CDGNM CALL TO GENERATE CODE BY NAME
12990: * (XR,WA) DESTROYED
12991: * (WC) SET NON-ZERO IF NON-CONSTANT
12992: *
12993: * WC IS SET TO A NON-ZERO (COLLECTABLE) VALUE IF THE
12994: * EXPRESSION FOR WHICH CODE IS GENERATED CANNOT BE
12995: * EVALUATED AT COMPILE TIME, OTHERWISE WC IS UNCHANGED.
12996: *
12997: * THE CODE IS GENERATED IN THE CURRENT CCBLK (SEE CDWRD).
12998: *
12999: CDGNM PRC R,0 ENTRY POINT, RECURSIVE
13000: MOV XL,-(XS) SAVE ENTRY XL
13001: MOV WB,-(XS) SAVE ENTRY WB
13002: CHK CHECK FOR STACK OVERFLOW
13003: MOV (XR),WA LOAD TYPE WORD
13004: BEQ WA,=B$CMT,CGN04 JUMP IF CMBLK
13005: BHI WA,=B$VR$,CGN02 JUMP IF SIMPLE VARIABLE
13006: *
13007: * MERGE HERE FOR OPERAND YIELDING VALUE (E.G. CONSTANT)
13008: *
13009: CGN01 ERB 212,SYNTAX ERROR. VALUE USED WHERE NAME IS REQUIRED
13010: *
13011: * HERE FOR NATURAL VARIABLE REFERENCE
13012: *
13013: CGN02 MOV =OLVN$,WA LOAD VARIABLE LOAD CALL
13014: JSR CDWRD GENERATE IT
13015: MOV XR,WA COPY VRBLK POINTER
13016: JSR CDWRD GENERATE VRBLK POINTER
13017: EJC
13018: *
13019: * CDGNM (CONTINUED)
13020: *
13021: * HERE TO EXIT WITH WC SET CORRECTLY
13022: *
13023: CGN03 MOV (XS)+,WB RESTORE ENTRY WB
13024: MOV (XS)+,XL RESTORE ENTRY XL
13025: EXI RETURN TO CDGNM CALLER
13026: *
13027: * HERE FOR CMBLK
13028: *
13029: CGN04 MOV XR,XL COPY CMBLK POINTER
13030: MOV CMTYP(XR),XR LOAD CMBLK TYPE
13031: BGE XR,=C$$NM,CGN01 ERROR IF NOT NAME OPERAND
13032: BSW XR,C$$NM ELSE SWITCH ON TYPE
13033: IFF C$ARR,CGN05 ARRAY REFERENCE
13034: IFF C$FNC,CGN08 FUNCTION CALL
13035: IFF C$DEF,CGN09 DEFERRED EXPRESSION
13036: IFF C$IND,CGN10 INDIRECT REFERENCE
13037: IFF C$KEY,CGN11 KEYWORD REFERENCE
13038: IFF C$UBO,CGN08 UNDEFINED BINARY OP
13039: IFF C$UUO,CGN08 UNDEFINED UNARY OP
13040: ESW END SWITCH ON CMBLK TYPE
13041: *
13042: * HERE TO GENERATE CODE FOR ARRAY REFERENCE
13043: *
13044: CGN05 MOV *CMOPN,WB POINT TO ARRAY OPERAND
13045: *
13046: * LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS
13047: *
13048: CGN06 JSR CMGEN GENERATE CODE FOR NEXT OPERAND
13049: MOV CMLEN(XL),WC LOAD LENGTH OF CMBLK
13050: BLT WB,WC,CGN06 LOOP TILL ALL GENERATED
13051: *
13052: * GENERATE APPROPRIATE ARRAY CALL
13053: *
13054: MOV =OAON$,WA LOAD ONE-SUBSCRIPT CASE CALL
13055: BEQ WC,*CMAR1,CGN07 JUMP TO EXIT IF ONE SUBSCRIPT CASE
13056: MOV =OAMN$,WA ELSE LOAD MULTI-SUBSCRIPT CASE CALL
13057: JSR CDWRD GENERATE CALL
13058: MOV WC,WA COPY CMBLK LENGTH
13059: BTW WA CONVERT TO WORDS
13060: SUB =CMVLS,WA CALCULATE NUMBER OF SUBSCRIPTS
13061: EJC
13062: *
13063: * CDGNM (CONTINUED)
13064: *
13065: * HERE TO EXIT GENERATING WORD (NON-CONSTANT)
13066: *
13067: CGN07 MNZ WC SET RESULT NON-CONSTANT
13068: JSR CDWRD GENERATE WORD
13069: BRN CGN03 BACK TO EXIT
13070: *
13071: * HERE TO GENERATE CODE FOR FUNCTIONS AND UNDEFINED OPRS
13072: *
13073: CGN08 MOV XL,XR COPY CMBLK POINTER
13074: JSR CDGVL GEN CODE BY VALUE FOR CALL
13075: MOV =OFNE$,WA GET EXTRA CALL FOR BY NAME
13076: BRN CGN07 BACK TO GENERATE AND EXIT
13077: *
13078: * HERE TO GENERATE CODE FOR DEFERED EXPRESSION
13079: *
13080: CGN09 MOV CMROP(XL),XR CHECK IF VARIABLE
13081: BHI (XR),=B$VR$,CGN02 TREAT *VARIABLE AS SIMPLE VAR
13082: MOV XR,XL COPY PTR TO EXPRESSION TREE
13083: JSR CDGEX ELSE BUILD EXBLK
13084: MOV =OLEX$,WA SET CALL TO LOAD EXPR BY NAME
13085: JSR CDWRD GENERATE IT
13086: MOV XR,WA COPY EXBLK POINTER
13087: JSR CDWRD GENERATE EXBLK POINTER
13088: BRN CGN03 BACK TO EXIT
13089: *
13090: * HERE TO GENERATE CODE FOR INDIRECT REFERENCE
13091: *
13092: CGN10 MOV CMROP(XL),XR GET OPERAND
13093: JSR CDGVL GENERATE CODE BY VALUE FOR IT
13094: MOV =OINN$,WA LOAD CALL FOR INDIRECT BY NAME
13095: BRN CGN12 MERGE
13096: *
13097: * HERE TO GENERATE CODE FOR KEYWORD REFERENCE
13098: *
13099: CGN11 MOV CMROP(XL),XR GET OPERAND
13100: JSR CDGNM GENERATE CODE BY NAME FOR IT
13101: MOV =OKWN$,WA LOAD CALL FOR KEYWORD BY NAME
13102: *
13103: * KEYWORD, INDIRECT MERGE HERE
13104: *
13105: CGN12 JSR CDWRD GENERATE CODE FOR OPERATOR
13106: BRN CGN03 EXIT
13107: ENP END PROCEDURE CDGNM
13108: EJC
13109: *
13110: * CDGVL -- GENERATE CODE BY VALUE
13111: *
13112: * CDGVL IS CALLED DURING THE COMPILATION PROCESS TO
13113: * GENERATE CODE BY VALUE FOR AN EXPRESSION. SEE CDBLK
13114: * DESCRIPTION FOR DETAILS OF THE CODE GENERATED. THE INPUT
13115: * TO CDGVL IS AN EXPRESSION TREE AS GENERATED BY EXPAN.
13116: *
13117: * CDGVL IS A RECURSIVE PROCEDURE WHICH PROCEEDS BY MAKING
13118: * RECURSIVE CALLS TO GENERATE CODE FOR OPERANDS.
13119: *
13120: * (WB) INTEGER IN RANGE 0 LE N LE DNAMB
13121: * (XR) PTR TO TREE GENERATED BY EXPAN
13122: * (WC) CONSTANT FLAG (SEE BELOW)
13123: * JSR CDGVL CALL TO GENERATE CODE BY VALUE
13124: * (XR,WA) DESTROYED
13125: * (WC) SET NON-ZERO IF NON-CONSTANT
13126: *
13127: * WC IS SET TO A NON-ZERO (COLLECTABLE) VALUE IF THE
13128: * EXPRESSION FOR WHICH CODE IS GENERATED CANNOT BE
13129: * EVALUATED AT COMPILE TIME, OTHERWISE WC IS UNCHANGED.
13130: *
13131: * IF WC IS NON-ZERO ON ENTRY, THEN PREEVALUATION IS NOT
13132: * ALLOWED REGARDLESS OF THE NATURE OF THE OPERAND.
13133: *
13134: * THE CODE IS GENERATED IN THE CURRENT CCBLK (SEE CDWRD).
13135: *
13136: CDGVL PRC R,0 ENTRY POINT, RECURSIVE
13137: MOV (XR),WA LOAD TYPE WORD
13138: BEQ WA,=B$CMT,CGV01 JUMP IF CMBLK
13139: BLT WA,=B$VRA,CGV00 JUMP IF ICBLK, RCBLK, SCBLK
13140: BNZ VRLEN(XR),CGVL0 JUMP IF NOT SYSTEM VARIABLE
13141: MOV XR,-(XS) STACK XR
13142: MOV VRSVP(XR),XR POINT TO SVBLK
13143: MOV SVBIT(XR),WA GET SVBLK PROPERTY BITS
13144: MOV (XS)+,XR RECOVER XR
13145: ANB BTCKW,WA CHECK IF CONSTANT KEYWORD
13146: NZB WA,CGV00 JUMP IF CONSTANT KEYWORD
13147: *
13148: * HERE FOR VARIABLE VALUE REFERENCE
13149: *
13150: CGVL0 MNZ WC INDICATE NON-CONSTANT VALUE
13151: *
13152: * MERGE HERE FOR SIMPLE CONSTANT (ICBLK,RCBLK,SCBLK)
13153: * AND FOR VARIABLES CORRESPONDING TO CONSTANT KEYWORDS.
13154: *
13155: CGV00 MOV XR,WA COPY PTR TO VAR OR CONSTANT
13156: JSR CDWRD GENERATE AS CODE WORD
13157: EXI RETURN TO CALLER
13158: EJC
13159: *
13160: * CDGVL (CONTINUED)
13161: *
13162: * HERE FOR TREE NODE (CMBLK)
13163: *
13164: CGV01 MOV WB,-(XS) SAVE ENTRY WB
13165: MOV XL,-(XS) SAVE ENTRY XL
13166: MOV WC,-(XS) SAVE ENTRY CONSTANT FLAG
13167: MOV CWCOF,-(XS) SAVE INITIAL CODE OFFSET
13168: CHK CHECK FOR STACK OVERFLOW
13169: *
13170: * PREPARE TO GENERATE CODE FOR CMBLK. WC IS SET TO THE
13171: * VALUE OF CSWNO (ZERO IF -OPTIMISE, 1 IF -NOOPT) TO
13172: * START WITH AND IS RESET NON-ZERO FOR ANY NON-CONSTANT
13173: * CODE GENERATED. IF IT IS STILL ZERO AFTER GENERATING ALL
13174: * THE CMBLK CODE, THEN ITS VALUE IS COMPUTED AS THE RESULT.
13175: *
13176: MOV XR,XL COPY CMBLK POINTER
13177: MOV CMTYP(XR),XR LOAD CMBLK TYPE
13178: MOV CSWNO,WC RESET CONSTANT FLAG
13179: BLE XR,=C$PR$,CGV02 JUMP IF NOT PREDICATE VALUE
13180: MNZ WC ELSE FORCE NON-CONSTANT CASE
13181: *
13182: * HERE WITH WC SET APPROPRIATELY
13183: *
13184: CGV02 BSW XR,C$$NV SWITCH TO APPROPRIATE GENERATOR
13185: IFF C$ARR,CGV03 ARRAY REFERENCE
13186: IFF C$FNC,CGV05 FUNCTION CALL
13187: IFF C$DEF,CGV14 DEFERRED EXPRESSION
13188: IFF C$SEL,CGV15 SELECTION
13189: IFF C$IND,CGV31 INDIRECT REFERENCE
13190: IFF C$KEY,CGV27 KEYWORD REFERENCE
13191: IFF C$UBO,CGV29 UNDEFINED BINOP
13192: IFF C$UUO,CGV30 UNDEFINED UNOP
13193: IFF C$BVL,CGV18 BINOPS WITH VAL OPDS
13194: IFF C$ALT,CGV18 ALTERNATION
13195: IFF C$UVL,CGV19 UNOPS WITH VALU OPND
13196: IFF C$ASS,CGV21 ASSIGNMENT
13197: IFF C$CNC,CGV24 CONCATENATION
13198: IFF C$CNP,CGV24 CONCATENATION (NOT PATTERN MATCH)
13199: IFF C$UNM,CGV27 UNOPS WITH NAME OPND
13200: IFF C$BVN,CGV26 BINARY $ AND .
13201: IFF C$INT,CGV31 INTERROGATION
13202: IFF C$NEG,CGV28 NEGATION
13203: IFF C$PMT,CGV18 PATTERN MATCH
13204: ESW END SWITCH ON CMBLK TYPE
13205: EJC
13206: *
13207: * CDGVL (CONTINUED)
13208: *
13209: * HERE TO GENERATE CODE FOR ARRAY REFERENCE
13210: *
13211: CGV03 MOV *CMOPN,WB SET OFFSET TO ARRAY OPERAND
13212: *
13213: * LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS
13214: *
13215: CGV04 JSR CMGEN GEN VALUE CODE FOR NEXT OPERAND
13216: MOV CMLEN(XL),WC LOAD CMBLK LENGTH
13217: BLT WB,WC,CGV04 LOOP BACK IF MORE TO GO
13218: *
13219: * GENERATE CALL TO APPROPRIATE ARRAY REFERENCE ROUTINE
13220: *
13221: MOV =OAOV$,WA SET ONE SUBSCRIPT CALL IN CASE
13222: BEQ WC,*CMAR1,CGV32 JUMP TO EXIT IF 1-SUB CASE
13223: MOV =OAMV$,WA ELSE SET CALL FOR MULTI-SUBSCRIPTS
13224: JSR CDWRD GENERATE CALL
13225: MOV WC,WA COPY LENGTH OF CMBLK
13226: SUB *CMVLS,WA SUBTRACT STANDARD LENGTH
13227: BTW WA GET NUMBER OF WORDS
13228: BRN CGV32 JUMP TO GENERATE SUBSCRIPT COUNT
13229: *
13230: * HERE TO GENERATE CODE FOR FUNCTION CALL
13231: *
13232: CGV05 MOV *CMVLS,WB SET OFFSET TO FIRST ARGUMENT
13233: *
13234: * LOOP TO GENERATE CODE FOR ARGUMENTS
13235: *
13236: CGV06 BEQ WB,CMLEN(XL),CGV07 JUMP IF ALL GENERATED
13237: JSR CMGEN ELSE GEN VALUE CODE FOR NEXT ARG
13238: BRN CGV06 BACK TO GENERATE NEXT ARGUMENT
13239: *
13240: * HERE TO GENERATE ACTUAL FUNCTION CALL
13241: *
13242: CGV07 SUB *CMVLS,WB GET NUMBER OF ARG PTRS (BYTES)
13243: BTW WB CONVERT BYTES TO WORDS
13244: MOV CMOPN(XL),XR LOAD FUNCTION VRBLK POINTER
13245: BNZ VRLEN(XR),CGV12 JUMP IF NOT SYSTEM FUNCTION
13246: MOV VRSVP(XR),XL LOAD SVBLK PTR IF SYSTEM VAR
13247: MOV SVBIT(XL),WA LOAD BIT MASK
13248: ANB BTFFC,WA TEST FOR FAST FUNCTION CALL ALLOWED
13249: ZRB WA,CGV12 JUMP IF NOT
13250: EJC
13251: *
13252: * CDGVL (CONTINUED)
13253: *
13254: * HERE IF FAST FUNCTION CALL IS ALLOWED
13255: *
13256: MOV SVBIT(XL),WA RELOAD BIT INDICATORS
13257: ANB BTPRE,WA TEST FOR PREEVALUATION OK
13258: NZB WA,CGV08 JUMP IF PREEVALUATION PERMITTED
13259: MNZ WC ELSE SET RESULT NON-CONSTANT
13260: *
13261: * TEST FOR CORRECT NUMBER OF ARGS FOR FAST CALL
13262: *
13263: CGV08 MOV VRFNC(XR),XL LOAD PTR TO SVFNC FIELD
13264: MOV FARGS(XL),WA LOAD SVNAR FIELD VALUE
13265: BEQ WA,WB,CGV11 JUMP IF ARGUMENT COUNT IS CORRECT
13266: BHI WA,WB,CGV09 JUMP IF TOO FEW ARGUMENTS GIVEN
13267: *
13268: * HERE IF TOO MANY ARGUMENTS, PREPARE TO GENERATE O$POPS
13269: *
13270: SUB WA,WB GET NUMBER OF EXTRA ARGS
13271: LCT WB,WB SET AS COUNT TO CONTROL LOOP
13272: MOV =OPOP$,WA SET POP CALL
13273: BRN CGV10 JUMP TO COMMON LOOP
13274: *
13275: * HERE IF TOO FEW ARGUMENTS, PREPARE TO GENERATE NULLS
13276: *
13277: CGV09 SUB WB,WA GET NUMBER OF MISSING ARGUMENTS
13278: LCT WB,WA LOAD AS COUNT TO CONTROL LOOP
13279: MOV =NULLS,WA LOAD PTR TO NULL CONSTANT
13280: *
13281: * LOOP TO GENERATE CALLS TO FIX ARGUMENT COUNT
13282: *
13283: CGV10 JSR CDWRD GENERATE ONE CALL
13284: BCT WB,CGV10 LOOP TILL ALL GENERATED
13285: *
13286: * HERE AFTER ADJUSTING ARG COUNT AS REQUIRED
13287: *
13288: CGV11 MOV XL,WA COPY POINTER TO SVFNC FIELD
13289: BRN CGV36 JUMP TO GENERATE CALL
13290: EJC
13291: *
13292: * CDGVL (CONTINUED)
13293: *
13294: * COME HERE IF FAST CALL IS NOT PERMITTED
13295: *
13296: CGV12 MOV =OFNS$,WA SET ONE ARG CALL IN CASE
13297: BEQ WB,=NUM01,CGV13 JUMP IF ONE ARG CASE
13298: MOV =OFNC$,WA ELSE LOAD CALL FOR MORE THAN 1 ARG
13299: JSR CDWRD GENERATE IT
13300: MOV WB,WA COPY ARGUMENT COUNT
13301: *
13302: * ONE ARG CASE MERGES HERE
13303: *
13304: CGV13 JSR CDWRD GENERATE =O$FNS OR ARG COUNT
13305: MOV XR,WA COPY VRBLK POINTER
13306: BRN CGV32 JUMP TO GENERATE VRBLK PTR
13307: *
13308: * HERE FOR DEFERRED EXPRESSION
13309: *
13310: CGV14 MOV CMROP(XL),XL POINT TO EXPRESSION TREE
13311: JSR CDGEX BUILD EXBLK OR SEBLK
13312: MOV XR,WA COPY BLOCK PTR
13313: JSR CDWRD GENERATE PTR TO EXBLK OR SEBLK
13314: BRN CGV34 JUMP TO EXIT, CONSTANT TEST
13315: *
13316: * HERE TO GENERATE CODE FOR SELECTION
13317: *
13318: CGV15 ZER -(XS) ZERO PTR TO CHAIN OF FORWARD JUMPS
13319: ZER -(XS) ZERO PTR TO PREV O$SLC FORWARD PTR
13320: MOV *CMVLS,WB POINT TO FIRST ALTERNATIVE
13321: MOV =OSLA$,WA SET INITIAL CODE WORD
13322: *
13323: * 0(XS) IS THE OFFSET TO THE PREVIOUS WORD
13324: * WHICH REQUIRES FILLING IN WITH AN
13325: * OFFSET TO THE FOLLOWING O$SLC,O$SLD
13326: *
13327: * 1(XS) IS THE HEAD OF A CHAIN OF OFFSET
13328: * POINTERS INDICATING THOSE LOCATIONS
13329: * TO BE FILLED WITH OFFSETS PAST
13330: * THE END OF ALL THE ALTERNATIVES
13331: *
13332: CGV16 JSR CDWRD GENERATE O$SLC (O$SLA FIRST TIME)
13333: MOV CWCOF,(XS) SET CURRENT LOC AS PTR TO FILL IN
13334: JSR CDWRD GENERATE GARBAGE WORD THERE FOR NOW
13335: JSR CMGEN GEN VALUE CODE FOR ALTERNATIVE
13336: MOV =OSLB$,WA LOAD O$SLB POINTER
13337: JSR CDWRD GENERATE O$SLB CALL
13338: MOV 1(XS),WA LOAD OLD CHAIN PTR
13339: MOV CWCOF,1(XS) SET CURRENT LOC AS NEW CHAIN HEAD
13340: JSR CDWRD GENERATE FORWARD CHAIN LINK
13341: EJC
13342: *
13343: * CDGVL (CONTINUED)
13344: *
13345: * NOW TO FILL IN THE SKIP OFFSET TO O$SLC,O$SLD
13346: *
13347: MOV (XS),XR LOAD OFFSET TO WORD TO PLUG
13348: ADD R$CCB,XR POINT TO ACTUAL LOCATION TO PLUG
13349: MOV CWCOF,(XR) PLUG PROPER OFFSET IN
13350: MOV =OSLC$,WA LOAD O$SLC PTR FOR NEXT ALTERNATIVE
13351: MOV WB,XR COPY OFFSET (DESTROY GARBAGE XR)
13352: ICA XR BUMP EXTRA TIME FOR TEST
13353: BLT XR,CMLEN(XL),CGV16 LOOP BACK IF NOT LAST ALTERNATIVE
13354: *
13355: * HERE TO GENERATE CODE FOR LAST ALTERNATIVE
13356: *
13357: MOV =OSLD$,WA GET HEADER CALL
13358: JSR CDWRD GENERATE O$SLD CALL
13359: JSR CMGEN GENERATE CODE FOR LAST ALTERNATIVE
13360: ICA XS POP OFFSET PTR
13361: MOV (XS)+,XR LOAD CHAIN PTR
13362: *
13363: * LOOP TO PLUG OFFSETS PAST STRUCTURE
13364: *
13365: CGV17 ADD R$CCB,XR MAKE NEXT PTR ABSOLUTE
13366: MOV (XR),WA LOAD FORWARD PTR
13367: MOV CWCOF,(XR) PLUG REQUIRED OFFSET
13368: MOV WA,XR COPY FORWARD PTR
13369: BNZ WA,CGV17 LOOP BACK IF MORE TO GO
13370: BRN CGV33 ELSE JUMP TO EXIT (NOT CONSTANT)
13371: *
13372: * HERE FOR BINARY OPS WITH VALUE OPERANDS
13373: *
13374: CGV18 MOV CMLOP(XL),XR LOAD LEFT OPERAND POINTER
13375: JSR CDGVL GEN VALUE CODE FOR LEFT OPERAND
13376: *
13377: * HERE FOR UNARY OPS WITH VALUE OPERAND (BINOPS MERGE)
13378: *
13379: CGV19 MOV CMROP(XL),XR LOAD RIGHT (ONLY) OPERAND PTR
13380: JSR CDGVL GEN CODE BY VALUE
13381: EJC
13382: *
13383: * CDGVL (CONTINUED)
13384: *
13385: * MERGE HERE TO GENERATE OPERATOR CALL FROM CMOPN FIELD
13386: *
13387: CGV20 MOV CMOPN(XL),WA LOAD OPERATOR CALL POINTER
13388: BRN CGV36 JUMP TO GENERATE IT WITH CONS TEST
13389: *
13390: * HERE FOR ASSIGNMENT
13391: *
13392: CGV21 MOV CMLOP(XL),XR LOAD LEFT OPERAND POINTER
13393: BLO (XR),=B$VR$,CGV22 JUMP IF NOT VARIABLE
13394: *
13395: * HERE FOR ASSIGNMENT TO SIMPLE VARIABLE
13396: *
13397: MOV CMROP(XL),XR LOAD RIGHT OPERAND PTR
13398: JSR CDGVL GENERATE CODE BY VALUE
13399: MOV CMLOP(XL),WA RELOAD LEFT OPERAND VRBLK PTR
13400: ADD *VRSTO,WA POINT TO VRSTO FIELD
13401: BRN CGV32 JUMP TO GENERATE STORE PTR
13402: *
13403: * HERE IF NOT SIMPLE VARIABLE ASSIGNMENT
13404: *
13405: CGV22 JSR EXPAP TEST FOR PATTERN MATCH ON LEFT SIDE
13406: PPM CGV23 JUMP IF NOT PATTERN MATCH
13407: *
13408: * HERE FOR PATTERN REPLACEMENT
13409: *
13410: MOV CMROP(XR),CMLOP(XL) SAVE PATTERN PTR IN SAFE PLACE
13411: MOV CMLOP(XR),XR LOAD SUBJECT PTR
13412: JSR CDGNM GEN CODE BY NAME FOR SUBJECT
13413: MOV CMLOP(XL),XR LOAD PATTERN PTR
13414: JSR CDGVL GEN CODE BY VALUE FOR PATTERN
13415: MOV =OPMN$,WA LOAD MATCH BY NAME CALL
13416: JSR CDWRD GENERATE IT
13417: MOV CMROP(XL),XR LOAD REPLACEMENT VALUE PTR
13418: JSR CDGVL GEN CODE BY VALUE
13419: MOV =ORPL$,WA LOAD REPLACE CALL
13420: BRN CGV32 JUMP TO GEN AND EXIT (NOT CONSTANT)
13421: *
13422: * HERE FOR ASSIGNMENT TO COMPLEX VARIABLE
13423: *
13424: CGV23 MNZ WC INHIBIT PRE-EVALUATION
13425: JSR CDGNM GEN CODE BY NAME FOR LEFT SIDE
13426: BRN CGV31 MERGE WITH UNOP CIRCUIT
13427: EJC
13428: *
13429: * CDGVL (CONTINUED)
13430: *
13431: * HERE FOR CONCATENATION
13432: *
13433: CGV24 MOV CMLOP(XL),XR LOAD LEFT OPERAND PTR
13434: BNE (XR),=B$CMT,CGV18 ORDINARY BINOP IF NOT CMBLK
13435: MOV CMTYP(XR),WB LOAD CMBLK TYPE CODE
13436: BEQ WB,=C$INT,CGV25 SPECIAL CASE IF INTERROGATION
13437: BEQ WB,=C$NEG,CGV25 OR NEGATION
13438: BNE WB,=C$FNC,CGV18 ELSE ORDINARY BINOP IF NOT FUNCTION
13439: MOV CMOPN(XR),XR ELSE LOAD FUNCTION VRBLK PTR
13440: BNZ VRLEN(XR),CGV18 ORDINARY BINOP IF NOT SYSTEM VAR
13441: MOV VRSVP(XR),XR ELSE POINT TO SVBLK
13442: MOV SVBIT(XR),WA LOAD BIT INDICATORS
13443: ANB BTPRD,WA TEST FOR PREDICATE FUNCTION
13444: ZRB WA,CGV18 ORDINARY BINOP IF NOT
13445: *
13446: * HERE IF LEFT ARG OF CONCATENATION IS PREDICATE FUNCTION
13447: *
13448: CGV25 MOV CMLOP(XL),XR RELOAD LEFT ARG
13449: JSR CDGVL GEN CODE BY VALUE
13450: MOV =OPOP$,WA LOAD POP CALL
13451: JSR CDWRD GENERATE IT
13452: MOV CMROP(XL),XR LOAD RIGHT OPERAND
13453: JSR CDGVL GEN CODE BY VALUE AS RESULT CODE
13454: BRN CGV33 EXIT (NOT CONSTANT)
13455: *
13456: * HERE TO GENERATE CODE FOR PATTERN, IMMEDIATE ASSIGNMENT
13457: *
13458: CGV26 MOV CMLOP(XL),XR LOAD LEFT OPERAND
13459: JSR CDGVL GEN CODE BY VALUE, MERGE
13460: *
13461: * HERE FOR UNOPS WITH ARG BY NAME (BINARY $ . MERGE)
13462: *
13463: CGV27 MOV CMROP(XL),XR LOAD RIGHT OPERAND PTR
13464: JSR CDGNM GEN CODE BY NAME FOR RIGHT ARG
13465: MOV CMOPN(XL),XR GET OPERATOR CODE WORD
13466: BNE (XR),=O$KWV,CGV20 GEN CALL UNLESS KEYWORD VALUE
13467: EJC
13468: *
13469: * CDGVL (CONTINUED)
13470: *
13471: * HERE FOR KEYWORD BY VALUE. THIS IS CONSTANT ONLY IF
13472: * THE OPERAND IS ONE OF THE SPECIAL SYSTEM VARIABLES WITH
13473: * THE SVCKW BIT SET TO INDICATE A CONSTANT KEYWORD VALUE.
13474: * NOTE THAT THE ONLY CONSTANT OPERAND BY NAME IS A VARIABLE
13475: *
13476: BNZ WC,CGV20 GEN CALL IF NON-CONSTANT (NOT VAR)
13477: MNZ WC ELSE SET NON-CONSTANT IN CASE
13478: MOV CMROP(XL),XR LOAD PTR TO OPERAND VRBLK
13479: BNZ VRLEN(XR),CGV20 GEN (NON-CONSTANT) IF NOT SYS VAR
13480: MOV VRSVP(XR),XR ELSE LOAD PTR TO SVBLK
13481: MOV SVBIT(XR),WA LOAD BIT MASK
13482: ANB BTCKW,WA TEST FOR CONSTANT KEYWORD
13483: ZRB WA,CGV20 GO GEN IF NOT CONSTANT
13484: ZER WC ELSE SET RESULT CONSTANT
13485: BRN CGV20 AND JUMP BACK TO GENERATE CALL
13486: *
13487: * HERE TO GENERATE CODE FOR NEGATION
13488: *
13489: CGV28 MOV =ONTA$,WA GET INITIAL WORD
13490: JSR CDWRD GENERATE IT
13491: MOV CWCOF,WB SAVE NEXT OFFSET
13492: JSR CDWRD GENERATE GUNK WORD FOR NOW
13493: MOV CMROP(XL),XR LOAD RIGHT OPERAND PTR
13494: JSR CDGVL GEN CODE BY VALUE
13495: MOV =ONTB$,WA LOAD END OF EVALUATION CALL
13496: JSR CDWRD GENERATE IT
13497: MOV WB,XR COPY OFFSET TO WORD TO PLUG
13498: ADD R$CCB,XR POINT TO ACTUAL WORD TO PLUG
13499: MOV CWCOF,(XR) PLUG WORD WITH CURRENT OFFSET
13500: MOV =ONTC$,WA LOAD FINAL CALL
13501: BRN CGV32 JUMP TO GENERATE IT (NOT CONSTANT)
13502: *
13503: * HERE TO GENERATE CODE FOR UNDEFINED BINARY OPERATOR
13504: *
13505: CGV29 MOV CMLOP(XL),XR LOAD LEFT OPERAND PTR
13506: JSR CDGVL GENERATE CODE BY VALUE
13507: EJC
13508: *
13509: * CDGVL (CONTINUED)
13510: *
13511: * HERE TO GENERATE CODE FOR UNDEFINED UNARY OPERATOR
13512: *
13513: CGV30 MOV =C$UO$,WB SET UNOP CODE + 1
13514: SUB CMTYP(XL),WB SET NUMBER OF ARGS (1 OR 2)
13515: *
13516: * MERGE HERE FOR UNDEFINED OPERATORS
13517: *
13518: MOV CMROP(XL),XR LOAD RIGHT (ONLY) OPERAND POINTER
13519: JSR CDGVL GEN VALUE CODE FOR RIGHT OPERAND
13520: MOV CMOPN(XL),XR LOAD POINTER TO OPERATOR DV
13521: MOV DVOPN(XR),XR LOAD POINTER OFFSET
13522: WTB XR CONVERT WORD OFFSET TO BYTES
13523: ADD =R$UBA,XR POINT TO PROPER FUNCTION PTR
13524: SUB *VRFNC,XR SET STANDARD FUNCTION OFFSET
13525: BRN CGV12 MERGE WITH FUNCTION CALL CIRCUIT
13526: *
13527: * HERE TO GENERATE CODE FOR INTERROGATION, INDIRECTION
13528: *
13529: CGV31 MNZ WC SET NON CONSTANT
13530: BRN CGV19 MERGE
13531: *
13532: * HERE TO EXIT GENERATING A WORD, RESULT NOT CONSTANT
13533: *
13534: CGV32 JSR CDWRD GENERATE WORD, MERGE
13535: *
13536: * HERE TO EXIT WITH NO WORD GENERATED, NOT CONSTANT
13537: *
13538: CGV33 MNZ WC INDICATE RESULT IS NOT CONSTANT
13539: *
13540: * COMMON EXIT POINT
13541: *
13542: CGV34 ICA XS POP INITIAL CODE OFFSET
13543: MOV (XS)+,WA RESTORE OLD CONSTANT FLAG
13544: MOV (XS)+,XL RESTORE ENTRY XL
13545: MOV (XS)+,WB RESTORE ENTRY WB
13546: BNZ WC,CGV35 JUMP IF NOT CONSTANT
13547: MOV WA,WC ELSE RESTORE ENTRY CONSTANT FLAG
13548: *
13549: * HERE TO RETURN AFTER DEALING WITH WC SETTING
13550: *
13551: CGV35 EXI RETURN TO CDGVL CALLER
13552: *
13553: * EXIT HERE TO GENERATE WORD AND TEST FOR CONSTANT
13554: *
13555: CGV36 JSR CDWRD GENERATE WORD
13556: BNZ WC,CGV34 JUMP TO EXIT IF NOT CONSTANT
13557: EJC
13558: *
13559: * CDGVL (CONTINUED)
13560: *
13561: * HERE TO PREEVALUATE CONSTANT SUB-EXPRESSION
13562: *
13563: MOV =ORVL$,WA LOAD CALL TO RETURN VALUE
13564: JSR CDWRD GENERATE IT
13565: MOV (XS),XL LOAD INITIAL CODE OFFSET
13566: JSR EXBLD BUILD EXBLK FOR EXPRESSION
13567: ZER WB SET TO EVALUATE BY VALUE
13568: JSR EVALX EVALUATE EXPRESSION
13569: PPM SHOULD NOT FAIL
13570: MOV (XR),WA LOAD TYPE WORD OF RESULT
13571: BLO WA,=P$AAA,CGV37 JUMP IF NOT PATTERN
13572: MOV =OLPT$,WA ELSE LOAD SPECIAL PATTERN LOAD CALL
13573: JSR CDWRD GENERATE IT
13574: *
13575: * MERGE HERE TO GENERATE POINTER TO RESULTING CONSTANT
13576: *
13577: CGV37 MOV XR,WA COPY CONSTANT POINTER
13578: JSR CDWRD GENERATE PTR
13579: ZER WC SET RESULT CONSTANT
13580: BRN CGV34 JUMP BACK TO EXIT
13581: ENP END PROCEDURE CDGVL
13582: EJC
13583: *
13584: * CDWRD -- GENERATE ONE WORD OF CODE
13585: *
13586: * CDWRD WRITES ONE WORD INTO THE CURRENT CODE BLOCK UNDER
13587: * CONSTRUCTION. A NEW, LARGER, BLOCK IS ALLOCATED IF THERE
13588: * IS INSUFFICIENT ROOM IN THE CURRENT BLOCK. CDWRD ENSURES
13589: * THAT THERE ARE AT LEAST THREE WORDS LEFT IN THE BLOCK
13590: * AFTER ENTERING THE NEW WORD. THIS GUARANTEES THAT ANY
13591: * EXTRA SPACE AT THE END CAN BE SPLIT OFF AS A CCBLK.
13592: *
13593: * (WA) WORD TO BE GENERATED
13594: * JSR CDWRD CALL TO GENERATE WORD
13595: *
13596: CDWRD PRC E,0 ENTRY POINT
13597: MOV XR,-(XS) SAVE ENTRY XR
13598: MOV WA,-(XS) SAVE CODE WORD TO BE GENERATED
13599: *
13600: * MERGE BACK HERE AFTER ALLOCATING LARGER BLOCK
13601: *
13602: CDWD1 MOV R$CCB,XR LOAD PTR TO CCBLK BEING BUILT
13603: BNZ XR,CDWD2 JUMP IF BLOCK ALLOCATED
13604: *
13605: * HERE WE ALLOCATE AN ENTIRELY FRESH BLOCK
13606: *
13607: MOV *E$CBS,WA LOAD INITIAL LENGTH
13608: JSR ALLOC ALLOCATE CCBLK
13609: MOV =B$CCT,(XR) STORE TYPE WORD
13610: MOV *CCCOD,CWCOF SET INITIAL OFFSET
13611: MOV WA,CCLEN(XR) STORE BLOCK LENGTH
13612: MOV XR,R$CCB STORE PTR TO NEW BLOCK
13613: *
13614: * HERE WE HAVE A BLOCK WE CAN USE
13615: *
13616: CDWD2 MOV CWCOF,WA LOAD CURRENT OFFSET
13617: ADD *NUM04,WA ADJUST FOR TEST (FOUR WORDS)
13618: BLO WA,CCLEN(XR),CDWD4 JUMP IF ROOM IN THIS BLOCK
13619: *
13620: * HERE IF NO ROOM IN CURRENT BLOCK
13621: *
13622: BGE WA,MXLEN,CDWD5 JUMP IF ALREADY AT MAX SIZE
13623: ADD *E$CBS,WA ELSE GET NEW SIZE
13624: MOV XL,-(XS) SAVE ENTRY XL
13625: MOV XR,XL COPY POINTER
13626: BLT WA,MXLEN,CDWD3 JUMP IF NOT TOO LARGE
13627: MOV MXLEN,WA ELSE RESET TO MAX ALLOWED SIZE
13628: EJC
13629: *
13630: * CDWRD (CONTINUED)
13631: *
13632: * HERE WITH NEW BLOCK SIZE IN WA
13633: *
13634: CDWD3 JSR ALLOC ALLOCATE NEW BLOCK
13635: MOV XR,R$CCB STORE POINTER TO NEW BLOCK
13636: MOV =B$CCT,(XR)+ STORE TYPE WORD IN NEW BLOCK
13637: MOV WA,(XR)+ STORE BLOCK LENGTH
13638: ADD *CCUSE,XL POINT TO CCUSE,CCCOD FIELDS IN OLD
13639: MOV (XL),WA LOAD CCUSE VALUE
13640: MVW COPY USEFUL WORDS FROM OLD BLOCK
13641: MOV (XS)+,XL RESTORE XL
13642: BRN CDWD1 MERGE BACK TO TRY AGAIN
13643: *
13644: * HERE WITH ROOM IN CURRENT BLOCK
13645: *
13646: CDWD4 MOV CWCOF,WA LOAD CURRENT OFFSET
13647: ICA WA GET NEW OFFSET
13648: MOV WA,CWCOF STORE NEW OFFSET
13649: MOV WA,CCUSE(XR) STORE IN CCBLK FOR GBCOL
13650: DCA WA RESTORE PTR TO THIS WORD
13651: ADD WA,XR POINT TO CURRENT ENTRY
13652: MOV (XS)+,WA RELOAD WORD TO GENERATE
13653: MOV WA,(XR) STORE WORD IN BLOCK
13654: MOV (XS)+,XR RESTORE ENTRY XR
13655: EXI RETURN TO CALLER
13656: *
13657: * HERE IF COMPILED CODE IS TOO LONG FOR CDBLK
13658: *
13659: CDWD5 ERB 213,SYNTAX ERROR. STATEMENT IS TOO COMPLICATED.
13660: ENP END PROCEDURE CDWRD
13661: EJC
13662: *
13663: * CMGEN -- GENERATE CODE FOR CMBLK PTR
13664: *
13665: * CMGEN IS A SUBSIDIARY PROCEDURE USED TO GENERATE VALUE
13666: * CODE FOR A CMBLK PTR FROM THE MAIN CODE GENERATORS.
13667: *
13668: * (XL) CMBLK POINTER
13669: * (WB) OFFSET TO POINTER IN CMBLK
13670: * JSR CMGEN CALL TO GENERATE CODE
13671: * (XR,WA) DESTROYED
13672: * (WB) BUMPED BY ONE WORD
13673: *
13674: CMGEN PRC R,0 ENTRY POINT, RECURSIVE
13675: MOV XL,XR COPY CMBLK POINTER
13676: ADD WB,XR POINT TO CMBLK POINTER
13677: MOV (XR),XR LOAD CMBLK POINTER
13678: JSR CDGVL GENERATE CODE BY VALUE
13679: ICA WB BUMP OFFSET
13680: EXI RETURN TO CALLER
13681: ENP END PROCEDURE CMGEN
13682: EJC
13683: *
13684: * CMPIL (COMPILE SOURCE CODE)
13685: *
13686: * CMPIL IS USED TO CONVERT SNOBOL4 SOURCE CODE TO INTERNAL
13687: * FORM (SEE CDBLK FORMAT). IT IS USED BOTH FOR THE INITIAL
13688: * COMPILE AND AT RUN TIME BY THE CODE AND CONVERT FUNCTIONS
13689: * THIS PROCEDURE HAS CONTROL FOR THE ENTIRE DURATION OF
13690: * INITIAL COMPILATION. AN ERROR IN ANY PROCEDURE CALLED
13691: * DURING COMPILATION WILL LEAD FIRST TO THE ERROR SECTION
13692: * AND ULTIMATELY BACK HERE FOR RESUMED COMPILATION. THE
13693: * RE-ENTRY POINTS AFTER AN ERROR ARE SPECIALLY LABELLED -
13694: *
13695: * CMPCE RESUME AFTER CONTROL CARD ERROR
13696: * CMPLE RESUME AFTER LABEL ERROR
13697: * CMPSE RESUME AFTER STATEMENT ERROR
13698: *
13699: * JSR CMPIL CALL TO COMPILE CODE
13700: * (XR) PTR TO CDBLK FOR ENTRY STATEMENT
13701: * (XL,WA,WB,WC,RA) DESTROYED
13702: *
13703: * THE FOLLOWING GLOBAL VARIABLES ARE REFERENCED
13704: *
13705: * CMPSN NUMBER OF NEXT STATEMENT
13706: * TO BE COMPILED.
13707: *
13708: * CSWXX CONTROL CARD SWITCH VALUES ARE
13709: * CHANGED WHEN RELEVANT CONTROL
13710: * CARDS ARE MET.
13711: *
13712: * CWCOF OFFSET TO NEXT WORD IN CODE BLOCK
13713: * BEING BUILT (SEE CDWRD).
13714: *
13715: * LSTSN NUMBER OF STATEMENT MOST RECENTLY
13716: * COMPILED (INITIALLY SET TO ZERO).
13717: *
13718: * R$CIM CURRENT (INITIAL) COMPILER IMAGE
13719: * (ZERO FOR INITIAL COMPILE CALL)
13720: *
13721: * R$CNI USED TO POINT TO FOLLOWING IMAGE.
13722: * (SEE READR PROCEDURE).
13723: *
13724: * SCNGO GOTO SWITCH FOR SCANE PROCEDURE
13725: *
13726: * SCNIL LENGTH OF CURRENT IMAGE EXCLUDING
13727: * CHARACTERS REMOVED BY -INPUT.
13728: *
13729: * SCNPT CURRENT SCAN OFFSET, SEE SCANE.
13730: *
13731: * SCNRS RESCAN SWITCH FOR SCANE PROCEDURE.
13732: *
13733: * SCNSE OFFSET (IN R$CIM) OF MOST RECENTLY
13734: * SCANNED ELEMENT. SET ZERO IF NOT
13735: * CURRENTLY SCANNING ITEMS
13736: EJC
13737: *
13738: * CMPIL (CONTINUED)
13739: *
13740: * STAGE STGIC INITIAL COMPILE IN PROGRESS
13741: * STGXC CODE/CONVERT COMPILE
13742: * STGEV BUILDING EXBLK FOR EVAL
13743: * STGXT EXECUTE TIME (OUTSIDE COMPILE)
13744: * STGCE INITIAL COMPILE AFTER END LINE
13745: * STGXE EXECUTE COMPILE AFTER END LINE
13746: *
13747: * CMPIL ALSO USES A FIXED NUMBER OF LOCATIONS ON THE
13748: * MAIN STACK AS FOLLOWS. (THE DEFINITIONS OF THE ACTUAL
13749: * OFFSETS ARE IN THE DEFINITIONS SECTION).
13750: *
13751: * CMSTM(XS) POINTER TO EXPAN TREE FOR BODY OF
13752: * STATEMENT (SEE EXPAN PROCEDURE).
13753: *
13754: * CMSGO(XS) POINTER TO TREE REPRESENTATION OF
13755: * SUCCESS GOTO (SEE PROCEDURE SCNGO)9
13756: * ZERO IF NO SUCCESS GOTO IS GIVEN
13757: *
13758: * CMFGO(XS) LIKE CMSGO FOR FAILURE GOTO.
13759: *
13760: * CMCGO(XS) SET NON-ZERO ONLY IF THERE IS A
13761: * CONDITIONAL GOTO. USED FOR -FAIL,
13762: * -NOFAIL CODE GENERATION.
13763: *
13764: * CMPCD(XS) POINTER TO CDBLK FOR PREVIOUS
13765: * STATEMENT. ZERO FOR 1ST STATEMENT.
13766: *
13767: * CMFFP(XS) SET NON-ZERO IF CDFAL IN PREVIOUS
13768: * CDBLK NEEDS FILLING WITH FORWARD
13769: * POINTER, ELSE SET TO ZERO.
13770: *
13771: * CMFFC(XS) SAME AS CMFFP FOR CURRENT CDBLK
13772: *
13773: * CMSOP(XS) OFFSET TO WORD IN PREVIOUS CDBLK
13774: * TO BE FILLED IN WITH FORWARD PTR
13775: * TO NEXT CDBLK FOR SUCCESS GOTO.
13776: * ZERO IF NO FILL IN IS REQUIRED.
13777: *
13778: * CMSOC(XS) SAME AS CMSOP FOR CURRENT CDBLK.
13779: *
13780: * CMLBL(XS) POINTER TO VRBLK FOR LABEL OF
13781: * CURRENT STATEMENT. ZERO IF NO LABEL
13782: *
13783: * CMTRA(XS) POINTER TO CDBLK FOR ENTRY STMNT.
13784: EJC
13785: *
13786: * CMPIL (CONTINUED)
13787: *
13788: * ENTRY POINT
13789: *
13790: CMPIL PRC E,0 ENTRY POINT
13791: LCT WB,=CMNEN SET NUMBER OF STACK WORK LOCATIONS
13792: *
13793: * LOOP TO INITIALIZE STACK WORKING LOCATIONS
13794: *
13795: CMP00 ZER -(XS) STORE A ZERO, MAKE ONE ENTRY
13796: BCT WB,CMP00 LOOP BACK UNTIL ALL SET
13797: MOV XS,CMPXS SAVE STACK POINTER FOR ERROR SEC
13798: SSS CMPSS SAVE S-R STACK POINTER IF ANY
13799: *
13800: * LOOP THROUGH STATEMENTS
13801: *
13802: CMP01 MOV SCNPT,WB SET SCAN POINTER OFFSET
13803: MOV WB,SCNSE SET START OF ELEMENT LOCATION
13804: MOV =OCER$,WA POINT TO COMPILE ERROR CALL
13805: JSR CDWRD GENERATE AS TEMPORARY CDFAL
13806: BLT WB,SCNIL,CMP04 JUMP IF CHARS LEFT ON THIS IMAGE
13807: *
13808: * LOOP HERE AFTER COMMENT OR CONTROL CARD
13809: * ALSO SPECIAL ENTRY AFTER CONTROL CARD ERROR
13810: *
13811: CMPCE ZER XR CLEAR POSSIBLE GARBAGE XR VALUE
13812: BNE STAGE,=STGIC,CMP02 SKIP UNLESS INITIAL COMPILE
13813: JSR READR READ NEXT INPUT IMAGE
13814: BZE XR,CMP09 JUMP IF NO INPUT AVAILABLE
13815: JSR NEXTS ACQUIRE NEXT SOURCE IMAGE
13816: MOV CMPSN,LSTSN STORE STMT NO FOR USE BY LISTR
13817: ZER SCNPT RESET SCAN POINTER
13818: BRN CMP04 GO PROCESS IMAGE
13819: *
13820: * FOR EXECUTE TIME COMPILE, PERMIT EMBEDDED CONTROL CARDS
13821: * AND COMMENTS (BY SKIPPING TO NEXT SEMI-COLON)
13822: *
13823: CMP02 MOV R$CIM,XR GET CURRENT IMAGE
13824: MOV SCNPT,WB GET CURRENT OFFSET
13825: PLC XR,WB PREPARE TO GET CHARS
13826: *
13827: * SKIP TO SEMI-COLON
13828: *
13829: CMP03 LCH WC,(XR)+ GET CHAR
13830: ICV SCNPT ADVANCE OFFSET
13831: BEQ WC,=CH$SM,CMP04 SKIP IF SEMI-COLON FOUND
13832: BLT SCNPT,SCNIL,CMP03 LOOP IF MORE CHARS
13833: ZER XR CLEAR GARBAGE XR VALUE
13834: BRN CMP09 END OF IMAGE
13835: EJC
13836: *
13837: * CMPIL (CONTINUED)
13838: *
13839: * HERE WITH IMAGE AVAILABLE TO SCAN. NOTE THAT IF THE INPUT
13840: * STRING IS NULL, THEN EVERYTHING IS OK SINCE NULL IS
13841: * ACTUALLY ASSEMBLED AS A WORD OF BLANKS.
13842: *
13843: CMP04 MOV R$CIM,XR POINT TO CURRENT IMAGE
13844: MOV SCNPT,WB LOAD CURRENT OFFSET
13845: MOV WB,WA COPY FOR LABEL SCAN
13846: PLC XR,WB POINT TO FIRST CHARACTER
13847: LCH WC,(XR)+ LOAD FIRST CHARACTER
13848: BEQ WC,=CH$SM,CMP12 NO LABEL IF SEMICOLON
13849: BEQ WC,=CH$AS,CMPCE LOOP BACK IF COMMENT CARD
13850: BEQ WC,=CH$MN,CMP32 JUMP IF CONTROL CARD
13851: MOV R$CIM,R$CMP ABOUT TO DESTROY R$CIM
13852: MOV =CMLAB,XL POINT TO LABEL WORK STRING
13853: MOV XL,R$CIM SCANE IS TO SCAN WORK STRING
13854: PSC XL POINT TO FIRST CHARACTER POSITION
13855: SCH WC,(XL)+ STORE CHAR JUST LOADED
13856: MOV =CH$SM,WC GET A SEMICOLON
13857: SCH WC,(XL) STORE AFTER FIRST CHAR
13858: CSC XL FINISHED CHARACTER STORING
13859: ZER XL CLEAR POINTER
13860: ZER SCNPT START AT FIRST CHARACTER
13861: MOV SCNIL,-(XS) PRESERVE IMAGE LENGTH
13862: MOV =NUM02,SCNIL READ 2 CHARS AT MOST
13863: JSR SCANE SCAN FIRST CHAR FOR TYPE
13864: MOV (XS)+,SCNIL RESTORE IMAGE LENGTH
13865: MOV XL,WC NOTE RETURN CODE
13866: MOV R$CMP,XL GET OLD R$CIM
13867: MOV XL,R$CIM PUT IT BACK
13868: MOV WB,SCNPT REINSTATE OFFSET
13869: BNZ SCNBL,CMP12 BLANK SEEN - CANT BE LABEL
13870: MOV XL,XR POINT TO CURRENT IMAGE
13871: PLC XR,WB POINT TO FIRST CHAR AGAIN
13872: BEQ WC,=T$VAR,CMP06 OK IF LETTER
13873: BEQ WC,=T$CON,CMP06 OK IF DIGIT
13874: *
13875: * DROP IN OR JUMP FROM ERROR SECTION IF SCANE FAILED
13876: *
13877: CMPLE MOV R$CMP,R$CIM POINT TO BAD LINE
13878: ERB 214,BAD LABEL OR MISPLACED CONTINUATION LINE
13879: *
13880: * LOOP TO SCAN LABEL
13881: *
13882: CMP05 BEQ WC,=CH$SM,CMP07 SKIP IF SEMICOLON
13883: ICV WA BUMP OFFSET
13884: BEQ WA,SCNIL,CMP07 JUMP IF END OF IMAGE (LABEL END)
13885: EJC
13886: *
13887: * CMPIL (CONTINUED)
13888: *
13889: * ENTER LOOP AT THIS POINT
13890: *
13891: CMP06 LCH WC,(XR)+ ELSE LOAD NEXT CHARACTER
13892: BEQ WC,=CH$HT,CMP07 JUMP IF HORIZONTAL TAB
13893: BNE WC,=CH$BL,CMP05 LOOP BACK IF NON-BLANK
13894: *
13895: * HERE AFTER SCANNING OUT LABEL
13896: *
13897: CMP07 MOV WA,SCNPT SAVE UPDATED SCAN OFFSET
13898: SUB WB,WA GET LENGTH OF LABEL
13899: BZE WA,CMP12 SKIP IF LABEL LENGTH ZERO
13900: ZER XR CLEAR GARBAGE XR VALUE
13901: JSR SBSTR BUILD SCBLK FOR LABEL NAME
13902: JSR GTNVR LOCATE/CONTRUCT VRBLK
13903: PPM DUMMY (IMPOSSIBLE) ERROR RETURN
13904: MOV XR,CMLBL(XS) STORE LABEL POINTER
13905: BNZ VRLEN(XR),CMP11 JUMP IF NOT SYSTEM LABEL
13906: BNE VRSVP(XR),=V$END,CMP11 JUMP IF NOT END LABEL
13907: *
13908: * HERE FOR END LABEL SCANNED OUT
13909: *
13910: ADD =STGND,STAGE ADJUST STAGE APPROPRIATELY
13911: JSR SCANE SCAN OUT NEXT ELEMENT
13912: BEQ XL,=T$SMC,CMP10 JUMP IF END OF IMAGE
13913: BNE XL,=T$VAR,CMP08 ELSE ERROR IF NOT VARIABLE
13914: *
13915: * HERE CHECK FOR VALID INITIAL TRANSFER
13916: *
13917: BEQ VRLBL(XR),=STNDL,CMP08 JUMP IF NOT DEFINED (ERROR)
13918: MOV VRLBL(XR),CMTRA(XS) ELSE SET INITIAL ENTRY POINTER
13919: JSR SCANE SCAN NEXT ELEMENT
13920: BEQ XL,=T$SMC,CMP10 JUMP IF OK (END OF IMAGE)
13921: *
13922: * HERE FOR BAD TRANSFER LABEL
13923: *
13924: CMP08 ERB 215,SYNTAX ERROR. UNDEFINED OR ERRONEOUS ENTRY LABEL
13925: *
13926: * HERE FOR END OF INPUT (NO END LABEL DETECTED)
13927: *
13928: CMP09 ADD =STGND,STAGE ADJUST STAGE APPROPRIATELY
13929: BEQ STAGE,=STGXE,CMP10 JUMP IF CODE CALL (OK)
13930: ERB 216,SYNTAX ERROR. MISSING END LINE
13931: *
13932: * HERE AFTER PROCESSING END LINE (MERGE HERE ON END ERROR)
13933: *
13934: CMP10 MOV =OSTP$,WA SET STOP CALL POINTER
13935: JSR CDWRD GENERATE AS STATEMENT CALL
13936: BRN CMPSE JUMP TO GENERATE AS FAILURE
13937: EJC
13938: *
13939: * CMPIL (CONTINUED)
13940: *
13941: * HERE AFTER PROCESSING LABEL OTHER THAN END
13942: *
13943: CMP11 BNE STAGE,=STGIC,CMP12 JUMP IF CODE CALL - REDEF. OK
13944: BEQ VRLBL(XR),=STNDL,CMP12 ELSE CHECK FOR REDEFINITION
13945: ZER CMLBL(XS) LEAVE FIRST LABEL DECLN UNDISTURBED
13946: ERB 217,SYNTAX ERROR. DUPLICATE LABEL
13947: *
13948: * HERE AFTER DEALING WITH LABEL
13949: *
13950: CMP12 ZER WB SET FLAG FOR STATEMENT BODY
13951: JSR EXPAN GET TREE FOR STATEMENT BODY
13952: MOV XR,CMSTM(XS) STORE FOR LATER USE
13953: ZER CMSGO(XS) CLEAR SUCCESS GOTO POINTER
13954: ZER CMFGO(XS) CLEAR FAILURE GOTO POINTER
13955: ZER CMCGO(XS) CLEAR CONDITIONAL GOTO FLAG
13956: JSR SCANE SCAN NEXT ELEMENT
13957: BNE XL,=T$COL,CMP18 JUMP IT NOT COLON (NO GOTO)
13958: *
13959: * LOOP TO PROCESS GOTO FIELDS
13960: *
13961: CMP13 MNZ SCNGO SET GOTO FLAG
13962: JSR SCANE SCAN NEXT ELEMENT
13963: BEQ XL,=T$SMC,CMP31 JUMP IF NO FIELDS LEFT
13964: BEQ XL,=T$SGO,CMP14 JUMP IF S FOR SUCCESS GOTO
13965: BEQ XL,=T$FGO,CMP16 JUMP IF F FOR FAILURE GOTO
13966: *
13967: * HERE FOR UNCONDITIONAL GOTO (I.E. NOT F OR S)
13968: *
13969: MNZ SCNRS SET TO RESCAN ELEMENT NOT F,S
13970: JSR SCNGF SCAN OUT GOTO FIELD
13971: BNZ CMFGO(XS),CMP17 ERROR IF FGOTO ALREADY
13972: MOV XR,CMFGO(XS) ELSE SET AS FGOTO
13973: BRN CMP15 MERGE WITH SGOTO CIRCUIT
13974: *
13975: * HERE FOR SUCCESS GOTO
13976: *
13977: CMP14 JSR SCNGF SCAN SUCCESS GOTO FIELD
13978: MOV =NUM01,CMCGO(XS) SET CONDITIONAL GOTO FLAG
13979: *
13980: * UNCONTIONAL GOTO MERGES HERE
13981: *
13982: CMP15 BNZ CMSGO(XS),CMP17 ERROR IF SGOTO ALREADY GIVEN
13983: MOV XR,CMSGO(XS) ELSE SET SGOTO
13984: BRN CMP13 LOOP BACK FOR NEXT GOTO FIELD
13985: *
13986: * HERE FOR FAILURE GOTO
13987: *
13988: CMP16 JSR SCNGF SCAN GOTO FIELD
13989: MOV =NUM01,CMCGO(XS) SET CONDITONAL GOTO FLAG
13990: BNZ CMFGO(XS),CMP17 ERROR IF FGOTO ALREADY GIVEN
13991: MOV XR,CMFGO(XS) ELSE STORE FGOTO POINTER
13992: BRN CMP13 LOOP BACK FOR NEXT FIELD
13993: EJC
13994: *
13995: * CMPIL (CONTINUED)
13996: *
13997: * HERE FOR DUPLICATED GOTO FIELD
13998: *
13999: CMP17 ERB 218,SYNTAX ERROR. DUPLICATED GOTO FIELD
14000: *
14001: * HERE TO GENERATE CODE
14002: *
14003: CMP18 ZER SCNSE STOP POSITIONAL ERROR FLAGS
14004: MOV CMSTM(XS),XR LOAD TREE PTR FOR STATEMENT BODY
14005: ZER WB COLLECTABLE VALUE FOR WB FOR CDGVL
14006: ZER WC RESET CONSTANT FLAG FOR CDGVL
14007: JSR EXPAP TEST FOR PATTERN MATCH
14008: PPM CMP19 JUMP IF NOT PATTERN MATCH
14009: MOV =OPMS$,CMOPN(XR) ELSE SET PATTERN MATCH POINTER
14010: MOV =C$PMT,CMTYP(XR)
14011: *
14012: * HERE AFTER DEALING WITH SPECIAL PATTERN MATCH CASE
14013: *
14014: CMP19 JSR CDGVL GENERATE CODE FOR BODY OF STATEMENT
14015: MOV CMSGO(XS),XR LOAD SGOTO POINTER
14016: MOV XR,WA COPY IT
14017: BZE XR,CMP21 JUMP IF NO SUCCESS GOTO
14018: ZER CMSOC(XS) CLEAR SUCCESS OFFSET FILLIN PTR
14019: BHI XR,STATE,CMP20 JUMP IF COMPLEX GOTO
14020: *
14021: * HERE FOR SIMPLE SUCCESS GOTO (LABEL)
14022: *
14023: ADD *VRTRA,WA POINT TO VRTRA FIELD AS REQUIRED
14024: JSR CDWRD GENERATE SUCCESS GOTO
14025: BRN CMP22 JUMP TO DEAL WITH FGOTO
14026: *
14027: * HERE FOR COMPLEX SUCCESS GOTO
14028: *
14029: CMP20 BEQ XR,CMFGO(XS),CMP22 NO CODE IF SAME AS FGOTO
14030: ZER WB ELSE SET OK VALUE FOR CDGVL IN WB
14031: JSR CDGCG GENERATE CODE FOR SUCCESS GOTO
14032: BRN CMP22 JUMP TO DEAL WITH FGOTO
14033: *
14034: * HERE FOR NO SUCCESS GOTO
14035: *
14036: CMP21 MOV CWCOF,CMSOC(XS) SET SUCCESS FILL IN OFFSET
14037: MOV =OCER$,WA POINT TO COMPILE ERROR CALL
14038: JSR CDWRD GENERATE AS TEMPORARY VALUE
14039: EJC
14040: *
14041: * CMPIL (CONTINUED)
14042: *
14043: * HERE TO DEAL WITH FAILURE GOTO
14044: *
14045: CMP22 MOV CMFGO(XS),XR LOAD FAILURE GOTO POINTER
14046: MOV XR,WA COPY IT
14047: ZER CMFFC(XS) SET NO FILL IN REQUIRED YET
14048: BZE XR,CMP23 JUMP IF NO FAILURE GOTO GIVEN
14049: ADD *VRTRA,WA POINT TO VRTRA FIELD IN CASE
14050: BLO XR,STATE,CMPSE JUMP TO GEN IF SIMPLE FGOTO
14051: *
14052: * HERE FOR COMPLEX FAILURE GOTO
14053: *
14054: MOV CWCOF,WB SAVE OFFSET TO O$GOF CALL
14055: MOV =OGOF$,WA POINT TO FAILURE GOTO CALL
14056: JSR CDWRD GENERATE
14057: MOV =OFIF$,WA POINT TO FAIL IN FAIL WORD
14058: JSR CDWRD GENERATE
14059: JSR CDGCG GENERATE CODE FOR FAILURE GOTO
14060: MOV WB,WA COPY OFFSET TO O$GOF FOR CDFAL
14061: MOV =B$CDC,WB SET COMPLEX CASE CDTYP
14062: BRN CMP25 JUMP TO BUILD CDBLK
14063: *
14064: * HERE IF NO FAILURE GOTO GIVEN
14065: *
14066: CMP23 MOV =OUNF$,WA LOAD UNEXPECTED FAILURE CALL IN CAS
14067: MOV CSWFL,WC GET -NOFAIL FLAG
14068: ORB CMCGO(XS),WC CHECK IF CONDITIONAL GOTO
14069: ZRB WC,CMPSE JUMP IF -NOFAIL AND NO COND. GOTO
14070: MNZ CMFFC(XS) ELSE SET FILL IN FLAG
14071: MOV =OCER$,WA AND SET COMPILE ERROR FOR TEMPORARY
14072: *
14073: * MERGE HERE WITH CDFAL VALUE IN WA, SIMPLE CDBLK
14074: * ALSO SPECIAL ENTRY AFTER STATEMENT ERROR
14075: *
14076: CMPSE MOV =B$CDS,WB SET CDTYP FOR SIMPLE CASE
14077: EJC
14078: *
14079: * CMPIL (CONTINUED)
14080: *
14081: * MERGE HERE TO BUILD CDBLK
14082: *
14083: * (WA) CDFAL VALUE TO BE GENERATED
14084: * (WB) CDTYP VALUE TO BE GENERATED
14085: *
14086: * AT THIS STAGE, WE CHOP OFF AN APPROPRIATE CHUNK OF THE
14087: * CURRENT CCBLK AND CONVERT IT INTO A CDBLK. THE REMAINDER
14088: * OF THE CCBLK IS REFORMATTED TO BE THE NEW CCBLK.
14089: *
14090: CMP25 MOV R$CCB,XR POINT TO CCBLK
14091: MOV CMLBL(XS),XL GET POSSIBLE LABEL POINTER
14092: BZE XL,CMP26 SKIP IF NO LABEL
14093: ZER CMLBL(XS) CLEAR FLAG FOR NEXT STATEMENT
14094: MOV XR,VRLBL(XL) PUT CDBLK PTR IN VRBLK LABEL FIELD
14095: *
14096: * MERGE AFTER DOING LABEL
14097: *
14098: CMP26 MOV WB,(XR) SET TYPE WORD FOR NEW CDBLK
14099: MOV WA,CDFAL(XR) SET FAILURE WORD
14100: MOV XR,XL COPY POINTER TO CCBLK
14101: MOV CCUSE(XR),WB LOAD LENGTH GEN (= NEW CDLEN)
14102: MOV CCLEN(XR),WC LOAD TOTAL CCBLK LENGTH
14103: ADD WB,XL POINT PAST CDBLK
14104: SUB WB,WC GET LENGTH LEFT FOR CHOP OFF
14105: MOV =B$CCT,(XL) SET TYPE CODE FOR NEW CCBLK AT END
14106: MOV *CCCOD,CCUSE(XL) SET INITIAL CODE OFFSET
14107: MOV *CCCOD,CWCOF REINITIALISE CWCOF
14108: MOV WC,CCLEN(XL) SET NEW LENGTH
14109: MOV XL,R$CCB SET NEW CCBLK POINTER
14110: MOV CMPSN,CDSTM(XR) SET STATEMENT NUMBER
14111: ICV CMPSN BUMP STATEMENT NUMBER
14112: *
14113: * SET POINTERS IN PREVIOUS CODE BLOCK AS REQUIRED
14114: *
14115: MOV CMPCD(XS),XL LOAD PTR TO PREVIOUS CDBLK
14116: BZE CMFFP(XS),CMP27 JUMP IF NO FAILURE FILL IN REQUIRED
14117: MOV XR,CDFAL(XL) ELSE SET FAILURE PTR IN PREVIOUS
14118: *
14119: * HERE TO DEAL WITH SUCCESS FORWARD POINTER
14120: *
14121: CMP27 MOV CMSOP(XS),WA LOAD SUCCESS OFFSET
14122: BZE WA,CMP28 JUMP IF NO FILL IN REQUIRED
14123: ADD WA,XL ELSE POINT TO FILL IN LOCATION
14124: MOV XR,(XL) STORE FORWARD POINTER
14125: ZER XL CLEAR GARBAGE XL VALUE
14126: EJC
14127: *
14128: * CMPIL (CONTINUED)
14129: *
14130: * NOW SET FILL IN POINTERS FOR THIS STATEMENT
14131: *
14132: CMP28 MOV CMFFC(XS),CMFFP(XS) COPY FAILURE FILL IN FLAG
14133: MOV CMSOC(XS),CMSOP(XS) COPY SUCCESS FILL IN OFFSET
14134: MOV XR,CMPCD(XS) SAVE PTR TO THIS CDBLK
14135: BNZ CMTRA(XS),CMP29 JUMP IF INITIAL ENTRY ALREADY SET
14136: MOV XR,CMTRA(XS) ELSE SET PTR HERE AS DEFAULT
14137: *
14138: * HERE AFTER COMPILING ONE STATEMENT
14139: *
14140: CMP29 BLT STAGE,=STGCE,CMP01 JUMP IF NOT END LINE JUST DONE
14141: BZE CSWLS,CMP30 SKIP IF -NOLIST
14142: JSR LISTR LIST LAST LINE
14143: *
14144: * RETURN
14145: *
14146: CMP30 MOV CMTRA(XS),XR LOAD INITIAL ENTRY CDBLK POINTER
14147: ADD *CMNEN,XS POP WORK LOCATIONS OFF STACK
14148: EXI AND RETURN TO CMPIL CALLER
14149: *
14150: * HERE AT END OF GOTO FIELD
14151: *
14152: CMP31 MOV CMFGO(XS),WB GET FAIL GOTO
14153: ORB CMSGO(XS),WB OR IN SUCCESS GOTO
14154: BNZ WB,CMP18 OK IF NON-NULL FIELD
14155: ERB 219,SYNTAX ERROR. EMPTY GOTO FIELD
14156: *
14157: * CONTROL CARD FOUND
14158: *
14159: CMP32 ICV WB POINT PAST CH$MN
14160: JSR CNCRD PROCESS CONTROL CARD
14161: ZER SCNSE CLEAR START OF ELEMENT LOC.
14162: BRN CMPCE LOOP FOR NEXT STATEMENT
14163: ENP END PROCEDURE CMPIL
14164: EJC
14165: *
14166: * CNCRD -- CONTROL CARD PROCESSOR
14167: *
14168: * CALLED TO DEAL WITH CONTROL CARDS
14169: *
14170: * R$CIM POINTS TO CURRENT IMAGE
14171: * (WB) OFFSET TO 1ST CHAR OF CONTROL CARD
14172: * JSR CNCRD CALL TO PROCESS CONTROL CARDS
14173: * (XL,XR,WA,WB,WC,IA) DESTROYED
14174: *
14175: CNCRD PRC E,0 ENTRY POINT
14176: MOV WB,SCNPT OFFSET FOR CONTROL CARD SCAN
14177: MOV =CCNOC,WA NUMBER OF CHARS FOR COMPARISON
14178: CTW WA,0 CONVERT TO WORD COUNT
14179: MOV WA,CNSWC SAVE WORD COUNT
14180: *
14181: * LOOP HERE IF MORE THAN ONE CONTROL CARD
14182: *
14183: CNC01 BGE SCNPT,SCNIL,CNC09 RETURN IF END OF IMAGE
14184: MOV R$CIM,XR POINT TO IMAGE
14185: PLC XR,SCNPT CHAR PTR FOR FIRST CHAR
14186: LCH WA,(XR)+ GET FIRST CHAR
14187: FLC WA FOLD TO UPPER CASE
14188: BEQ WA,=CH$LI,CNC07 SPECIAL CASE OF -INXXX
14189: MNZ SCNCC SET FLAG FOR SCANE
14190: JSR SCANE SCAN CARD NAME
14191: ZER SCNCC CLEAR SCANE FLAG
14192: BNZ XL,CNC06 FAIL UNLESS CONTROL CARD NAME
14193: MOV =CCNOC,WA NO. OF CHARS TO BE COMPARED
14194: BLT SCLEN(XR),WA,CNC06 FAIL IF TOO FEW CHARS
14195: MOV XR,XL POINT TO CONTROL CARD NAME
14196: ZER WB ZERO OFFSET FOR SUBSTRING
14197: JSR SBSTR EXTRACT SUBSTRING FOR COMPARISON
14198: MOV SCLEN(XR),WA RELOAD LENGTH
14199: JSR FLSTG FOLD TO UPPER CASE
14200: MOV XR,CNSCC KEEP CONTROL CARD SUBSTRING PTR
14201: MOV =CCNMS,XR POINT TO LIST OF STANDARD NAMES
14202: ZER WB INITIALISE NAME OFFSET
14203: LCT WC,=CC$NC NUMBER OF STANDARD NAMES
14204: *
14205: * TRY TO MATCH NAME
14206: *
14207: CNC02 MOV CNSCC,XL POINT TO NAME
14208: LCT WA,CNSWC COUNTER FOR INNER LOOP
14209: BRN CNC04 JUMP INTO LOOP
14210: *
14211: * INNER LOOP TO MATCH CARD NAME CHARS
14212: *
14213: CNC03 ICA XR BUMP STANDARD NAMES PTR
14214: ICA XL BUMP NAME POINTER
14215: *
14216: * HERE TO INITIATE THE LOOP
14217: *
14218: CNC04 CNE SCHAR(XL),(XR),CNC05 COMP. UP TO CFP$C CHARS AT ONCE
14219: BCT WA,CNC03 LOOP IF MORE WORDS TO COMPARE
14220: EJC
14221: *
14222: * CNCRD (CONTINUED)
14223: *
14224: * MATCHED - BRANCH ON CARD OFFSET
14225: *
14226: MOV WB,XL GET NAME OFFSET
14227: BSW XL,CC$NC SWITCH
14228: IFF CC$CA,CNC37 -CASE
14229: IFF CC$DO,CNC10 -DOUBLE
14230: IFF CC$DU,CNC11 -DUMP
14231: IFF CC$EJ,CNC12 -EJECT
14232: IFF CC$ER,CNC13 -ERRORS
14233: IFF CC$EX,CNC14 -EXECUTE
14234: IFF CC$FA,CNC15 -FAIL
14235: IFF CC$LI,CNC16 -LIST
14236: IFF CC$NR,CNC17 -NOERRORS
14237: IFF CC$NX,CNC18 -NOEXECUTE
14238: IFF CC$NF,CNC19 -NOFAIL
14239: IFF CC$NL,CNC20 -NOLIST
14240: IFF CC$NO,CNC21 -NOOPT
14241: IFF CC$NP,CNC22 -NOPRINT
14242: IFF CC$OP,CNC24 -OPTIMISE
14243: IFF CC$PR,CNC25 -PRINT
14244: IFF CC$SI,CNC27 -SINGLE
14245: IFF CC$SP,CNC28 -SPACE
14246: IFF CC$ST,CNC31 -STITLE
14247: IFF CC$TI,CNC32 -TITLE
14248: IFF CC$TR,CNC36 -TRACE
14249: ESW END SWITCH
14250: *
14251: * NOT MATCHED YET. ALIGN STD NAMES PTR AND TRY AGAIN
14252: *
14253: CNC05 ICA XR BUMP STANDARD NAMES PTR
14254: BCT WA,CNC05 LOOP
14255: ICV WB BUMP NAMES OFFSET
14256: BCT WC,CNC02 CONTINUE IF MORE NAMES
14257: *
14258: * INVALID CONTROL CARD NAME
14259: *
14260: CNC06 ERB 247,INVALID CONTROL CARD
14261: *
14262: * SPECIAL PROCESSING FOR -INXXX
14263: *
14264: CNC07 LCH WA,(XR) GET NEXT CHAR
14265: FLC WA FOLD TO UPPER CASE
14266: BNE WA,=CH$LN,CNC06 FAIL IF NOT LETTER N
14267: ADD =NUM02,SCNPT BUMP OFFSET PAST -IN
14268: JSR SCANE SCAN INTEGER AFTER -IN
14269: MOV XR,-(XS) STACK SCANNED ITEM
14270: JSR GTSMI CHECK IF INTEGER
14271: PPM CNC06 FAIL IF NOT INTEGER
14272: PPM CNC06 FAIL IF NEGATIVE OR LARGE
14273: MOV XR,CSWIN KEEP INTEGER
14274: EJC
14275: *
14276: * CNCRD (CONTINUED)
14277: *
14278: * CHECK FOR MORE CONTROL CARDS BEFORE RETURNING
14279: *
14280: CNC08 MOV SCNPT,WA PRESERVE IN CASE XEQ TIME COMPILE
14281: JSR SCANE LOOK FOR COMMA
14282: BEQ XL,=T$CMA,CNC01 LOOP IF COMMA FOUND
14283: MOV WA,SCNPT RESTORE SCNPT IN CASE XEQ TIME
14284: *
14285: * RETURN POINT
14286: *
14287: CNC09 EXI RETURN
14288: *
14289: * -DOUBLE
14290: *
14291: CNC10 MNZ CSWDB SET SWITCH
14292: BRN CNC08 MERGE
14293: *
14294: * -DUMP
14295: * THIS IS USED FOR SYSTEM DEBUGGING . IT HAS THE EFFECT OF
14296: * PRODUCING A CORE DUMP AT COMPILATION TIME
14297: *
14298: CNC11 JSR SYSDM CALL DUMPER
14299: BRN CNC09 FINISHED
14300: *
14301: * -EJECT
14302: *
14303: CNC12 BZE CSWLS,CNC09 RETURN IF -NOLIST
14304: JSR PRTPS EJECT
14305: JSR LISTT LIST TITLE
14306: BRN CNC09 FINISHED
14307: *
14308: * -ERRORS
14309: *
14310: CNC13 ZER CSWER CLEAR SWITCH
14311: BRN CNC08 MERGE
14312: *
14313: * -EXECUTE
14314: *
14315: CNC14 ZER CSWEX CLEAR SWITCH
14316: BRN CNC08 MERGE
14317: *
14318: * -FAIL
14319: *
14320: CNC15 MNZ CSWFL SET SWITCH
14321: BRN CNC08 MERGE
14322: *
14323: * -LIST
14324: *
14325: CNC16 MNZ CSWLS SET SWITCH
14326: BEQ STAGE,=STGIC,CNC08 DONE IF COMPILE TIME
14327: *
14328: * LIST CODE LINE IF EXECUTE TIME COMPILE
14329: *
14330: ZER LSTPF PERMIT LISTING
14331: JSR LISTR LIST LINE
14332: BRN CNC08 MERGE
14333: EJC
14334: *
14335: * CNCRD (CONTINUED)
14336: *
14337: * -NOERRORS
14338: *
14339: CNC17 MNZ CSWER SET SWITCH
14340: BRN CNC08 MERGE
14341: *
14342: * -NOEXECUTE
14343: *
14344: CNC18 MNZ CSWEX SET SWITCH
14345: BRN CNC08 MERGE
14346: *
14347: * -NOFAIL
14348: *
14349: CNC19 ZER CSWFL CLEAR SWITCH
14350: BRN CNC08 MERGE
14351: *
14352: * -NOLIST
14353: *
14354: CNC20 ZER CSWLS CLEAR SWITCH
14355: BRN CNC08 MERGE
14356: *
14357: * -NOOPTIMISE
14358: *
14359: CNC21 MNZ CSWNO SET SWITCH
14360: BRN CNC08 MERGE
14361: *
14362: * -NOPRINT
14363: *
14364: CNC22 ZER CSWPR CLEAR SWITCH
14365: BRN CNC08 MERGE
14366: *
14367: * -OPTIMISE
14368: *
14369: CNC24 ZER CSWNO CLEAR SWITCH
14370: BRN CNC08 MERGE
14371: *
14372: * -PRINT
14373: *
14374: CNC25 MNZ CSWPR SET SWITCH
14375: BRN CNC08 MERGE
14376: EJC
14377: *
14378: * CNCRD (CONTINUED)
14379: *
14380: * -SINGLE
14381: *
14382: CNC27 ZER CSWDB CLEAR SWITCH
14383: BRN CNC08 MERGE
14384: *
14385: * -SPACE
14386: *
14387: CNC28 BZE CSWLS,CNC09 RETURN IF -NOLIST
14388: JSR SCANE SCAN INTEGER AFTER -SPACE
14389: MOV =NUM01,WC 1 SPACE IN CASE
14390: BEQ XR,=T$SMC,CNC29 JUMP IF NO INTEGER
14391: MOV XR,-(XS) STACK IT
14392: JSR GTSMI CHECK INTEGER
14393: PPM CNC06 FAIL IF NOT INTEGER
14394: PPM CNC06 FAIL IF NEGATIVE OR LARGE
14395: BNZ WC,CNC29 JUMP IF NON ZERO
14396: MOV =NUM01,WC ELSE 1 SPACE
14397: *
14398: * MERGE WITH COUNT OF LINES TO SKIP
14399: *
14400: CNC29 ADD WC,LSTLC BUMP LINE COUNT
14401: LCT WC,WC CONVERT TO LOOP COUNTER
14402: BLT LSTLC,LSTNP,CNC30 JUMP IF FITS ON PAGE
14403: JSR PRTPS EJECT
14404: JSR LISTT LIST TITLE
14405: BRN CNC09 MERGE
14406: *
14407: * SKIP LINES
14408: *
14409: CNC30 JSR PRTNL PRINT A BLANK
14410: BCT WC,CNC30 LOOP
14411: BRN CNC09 MERGE
14412: EJC
14413: *
14414: * CNCRD (CONTINUED)
14415: *
14416: * -STITL
14417: *
14418: CNC31 MOV =R$STL,CNR$T PTR TO R$STL
14419: BRN CNC33 MERGE
14420: *
14421: * -TITLE
14422: *
14423: CNC32 MOV =NULLS,R$STL CLEAR SUBTITLE
14424: MOV =R$TTL,CNR$T PTR TO R$TTL
14425: *
14426: * COMMON PROCESSING FOR -TITLE, -STITL
14427: *
14428: CNC33 MOV =NULLS,XR NULL IN CASE NEEDED
14429: MNZ CNTTL SET FLAG FOR NEXT LISTR CALL
14430: MOV =CCOFS,WB OFFSET TO TITLE/SUBTITLE
14431: MOV SCNIL,WA INPUT IMAGE LENGTH
14432: BLO WA,WB,CNC34 JUMP IF NO CHARS LEFT
14433: SUB WB,WA NO OF CHARS TO EXTRACT
14434: MOV R$CIM,XL POINT TO IMAGE
14435: JSR SBSTR GET TITLE/SUBTITLE
14436: *
14437: * STORE TITLE/SUBTITLE
14438: *
14439: CNC34 MOV CNR$T,XL POINT TO STORAGE LOCATION
14440: MOV XR,(XL) STORE TITLE/SUBTITLE
14441: BEQ XL,=R$STL,CNC09 RETURN IF STITL
14442: BNZ PRECL,CNC09 RETURN IF EXTENDED LISTING
14443: BZE PRICH,CNC09 RETURN IF REGULAR PRINTER
14444: MOV SCLEN(XR),XL GET LENGTH OF TITLE
14445: MOV XL,WA COPY IT
14446: BZE XL,CNC35 JUMP IF NULL
14447: ADD =NUM10,XL INCREMENT
14448: BHI XL,PRLEN,CNC09 USE DEFAULT LSTP0 VAL IF TOO LONG
14449: ADD =NUM04,WA POINT JUST PAST TITLE
14450: *
14451: * STORE OFFSET TO PAGE NN MESSAGE FOR SHORT TITLE
14452: *
14453: CNC35 MOV WA,LSTPO STORE OFFSET
14454: BRN CNC09 RETURN
14455: *
14456: * -TRACE
14457: * PROVIDED FOR SYSTEM DEBUGGING. TOGGLES THE SYSTEM LABEL
14458: * TRACE SWITCH AT COMPILE TIME
14459: *
14460: CNC36 JSR SYSTT TOGGLE SWITCH
14461: BRN CNC08 MERGE
14462: *
14463: * -CASE
14464: * SETS VALUE OF KVCAS SO THAT NAMES ARE FOLDED OR NOT
14465: * DURING COMPILATION.
14466: *
14467: CNC37 JSR SCANE SCAN INTEGER AFTER -CASE
14468: ZER WC GET 0 IN CASE NONE THERE
14469: BEQ XL,=T$SMC,CNC38 SKIP IF NO INTEGER
14470: MOV XR,-(XS) STACK IT
14471: JSR GTSMI CHECK INTEGER
14472: PPM CNC06 FAIL IF NOT INTEGER
14473: PPM CNC06 FAIL IF NEGATIVE OR TOO LARGE
14474: CNC38 MOV WC,KVCAS STORE NEW CASE VALUE
14475: BRN CNC09 MERGE
14476: ENP END PROCEDURE CNCRD
14477: EJC
14478: *
14479: * DFFNC -- DEFINE FUNCTION
14480: *
14481: * DFFNC IS CALLED WHENEVER A NEW FUNCTION IS ASSIGNED TO
14482: * A VARIABLE. IT DEALS WITH EXTERNAL FUNCTION USE COUNTS.
14483: *
14484: * (XR) POINTER TO VRBLK
14485: * (XL) POINTER TO NEW FUNCTION BLOCK
14486: * JSR DFFNC CALL TO DEFINE FUNCTION
14487: * (WA,WB) DESTROYED
14488: *
14489: DFFNC PRC E,0 ENTRY POINT
14490: BNE (XL),=B$EFC,DFFN1 SKIP IF NEW FUNCTION NOT EXTERNAL
14491: ICV EFUSE(XL) ELSE INCREMENT ITS USE COUNT
14492: *
14493: * HERE AFTER DEALING WITH NEW FUNCTION USE COUNT
14494: *
14495: DFFN1 MOV XR,WA SAVE VRBLK POINTER
14496: MOV VRFNC(XR),XR LOAD OLD FUNCTION POINTER
14497: BNE (XR),=B$EFC,DFFN2 JUMP IF OLD FUNCTION NOT EXTERNAL
14498: MOV EFUSE(XR),WB ELSE GET USE COUNT
14499: DCV WB DECREMENT
14500: MOV WB,EFUSE(XR) STORE DECREMENTED VALUE
14501: BNZ WB,DFFN2 JUMP IF USE COUNT STILL NON-ZERO
14502: JSR SYSUL ELSE CALL SYSTEM UNLOAD FUNCTION
14503: *
14504: * HERE AFTER DEALING WITH OLD FUNCTION USE COUNT
14505: *
14506: DFFN2 MOV WA,XR RESTORE VRBLK POINTER
14507: MOV XL,WA COPY FUNCTION BLOCK PTR
14508: BLT XR,=R$YYY,DFFN3 SKIP CHECKS IF OPSYN OP DEFINITION
14509: BNZ VRLEN(XR),DFFN3 JUMP IF NOT SYSTEM VARIABLE
14510: *
14511: * FOR SYSTEM VARIABLE, CHECK FOR ILLEGAL REDEFINITION
14512: *
14513: MOV VRSVP(XR),XL POINT TO SVBLK
14514: MOV SVBIT(XL),WB LOAD BIT INDICATORS
14515: ANB BTFNC,WB IS IT A SYSTEM FUNCTION
14516: ZRB WB,DFFN3 REDEF OK IF NOT
14517: ERB 248,ATTEMPTED REDEFINITION OF SYSTEM FUNCTION
14518: *
14519: * HERE IF REDEFINITION IS PERMITTED
14520: *
14521: DFFN3 MOV WA,VRFNC(XR) STORE NEW FUNCTION POINTER
14522: MOV WA,XL RESTORE FUNCTION BLOCK POINTER
14523: EXI RETURN TO DFFNC CALLER
14524: ENP END PROCEDURE DFFNC
14525: EJC
14526: *
14527: * DTACH -- DETACH I/O ASSOCIATED NAMES
14528: *
14529: * DETACHES TRBLKS FROM I/O ASSOCIATED VARIABLES, REMOVES
14530: * ENTRY FROM IOCHN CHAIN ATTACHED TO FILEARG1 VRBLK AND MAY
14531: * REMOVE VRBLK ACCESS AND STORE TRAPS.
14532: * INPUT, OUTPUT, TERMINAL ARE HANDLED SPECIALLY.
14533: *
14534: * (XL) I/O ASSOC. VBL NAME BASE PTR
14535: * (WA) OFFSET TO NAME
14536: * JSR DTACH CALL FOR DETACH OPERATION
14537: * (XL,XR,WA,WB,WC) DESTROYED
14538: *
14539: DTACH PRC E,0 ENTRY POINT
14540: MOV XL,DTCNB STORE NAME BASE (GBCOL NOT CALLED)
14541: ADD WA,XL POINT TO NAME LOCATION
14542: MOV XL,DTCNM STORE IT
14543: *
14544: * LOOP TO SEARCH FOR I/O TRBLK
14545: *
14546: DTCH1 MOV XL,XR COPY NAME POINTER
14547: *
14548: * CONTINUE AFTER BLOCK DELETION
14549: *
14550: DTCH2 MOV (XL),XL POINT TO NEXT VALUE
14551: BNE (XL),=B$TRT,DTCH6 JUMP AT CHAIN END
14552: MOV TRTYP(XL),WA GET TRAP BLOCK TYPE
14553: BEQ WA,=TRTIN,DTCH3 JUMP IF INPUT
14554: BEQ WA,=TRTOU,DTCH3 JUMP IF OUTPUT
14555: ADD *TRNXT,XL POINT TO NEXT LINK
14556: BRN DTCH1 LOOP
14557: *
14558: * DELETE AN OLD ASSOCIATION
14559: *
14560: DTCH3 MOV TRVAL(XL),(XR) DELETE TRBLK
14561: MOV XL,WA DUMP XL ...
14562: MOV XR,WB ... AND XR
14563: MOV TRTRF(XL),XL POINT TO TRTRF TRAP BLOCK
14564: BZE XL,DTCH5 JUMP IF NO IOCHN
14565: BNE (XL),=B$TRT,DTCH5 JUMP IF INPUT, OUTPUT, TERMINAL
14566: *
14567: * LOOP TO SEARCH IOCHN CHAIN FOR NAME PTR
14568: *
14569: DTCH4 MOV XL,XR REMEMBER LINK PTR
14570: MOV TRTRF(XL),XL POINT TO NEXT LINK
14571: BZE XL,DTCH5 JUMP IF END OF CHAIN
14572: MOV IONMB(XL),WC GET NAME BASE
14573: ADD IONMO(XL),WC ADD OFFSET
14574: BNE WC,DTCNM,DTCH4 LOOP IF NO MATCH
14575: MOV TRTRF(XL),TRTRF(XR) REMOVE NAME FROM CHAIN
14576: EJC
14577: *
14578: * DTACH (CONTINUED)
14579: *
14580: * PREPARE TO RESUME I/O TRBLK SCAN
14581: *
14582: DTCH5 MOV WA,XL RECOVER XL ...
14583: MOV WB,XR ... AND XR
14584: ADD *TRVAL,XL POINT TO VALUE FIELD
14585: BRN DTCH2 CONTINUE
14586: *
14587: * EXIT POINT
14588: *
14589: DTCH6 MOV DTCNB,XR POSSIBLE VRBLK PTR
14590: JSR SETVR RESET VRBLK IF NECESSARY
14591: EXI RETURN
14592: ENP END PROCEDURE DTACH
14593: EJC
14594: *
14595: * DTYPE -- GET DATATYPE NAME
14596: *
14597: * (XR) OBJECT WHOSE DATATYPE IS REQUIRED
14598: * JSR DTYPE CALL TO GET DATATYPE
14599: * (XR) RESULT DATATYPE
14600: *
14601: DTYPE PRC E,0 ENTRY POINT
14602: BEQ (XR),=B$PDT,DTYP1 JUMP IF PROG.DEFINED
14603: MOV (XR),XR LOAD TYPE WORD
14604: LEI XR GET ENTRY POINT ID (BLOCK CODE)
14605: WTB XR CONVERT TO BYTE OFFSET
14606: MOV SCNMT(XR),XR LOAD TABLE ENTRY
14607: EXI EXIT TO DTYPE CALLER
14608: *
14609: * HERE IF PROGRAM DEFINED
14610: *
14611: DTYP1 MOV PDDFP(XR),XR POINT TO DFBLK
14612: MOV DFNAM(XR),XR GET DATATYPE NAME FROM DFBLK
14613: EXI RETURN TO DTYPE CALLER
14614: ENP END PROCEDURE DTYPE
14615: EJC
14616: *
14617: * DUMPR -- PRINT DUMP OF STORAGE
14618: *
14619: * (XR) DUMP ARGUMENT (SEE BELOW)
14620: * JSR DUMPR CALL TO PRINT DUMP
14621: * (XR,XL) DESTROYED
14622: * (WA,WB,WC,RA) DESTROYED
14623: *
14624: * THE DUMP ARGUMENT HAS THE FOLLOWING SIGNIFICANCE
14625: *
14626: * DMARG = 0 NO DUMP PRINTED
14627: * DMARG = 1 PARTIAL DUMP (NAT VARS, KEYWORDS)
14628: * DMARG EQ 2 FULL DUMP (INCL ARRAYS ETC.)
14629: * DMARG GE 3 CORE DUMP
14630: *
14631: * SINCE DUMPR SCRAMBLES STORE, IT IS NOT PERMISSIBLE TO
14632: * COLLECT IN MID-DUMP. HENCE A COLLECT IS DONE INITIALLY
14633: * AND THEN IF STORE RUNS OUT AN ERROR MESSAGE IS PRODUCED.
14634: *
14635: DUMPR PRC E,0 ENTRY POINT
14636: BZE XR,DMP28 SKIP DUMP IF ARGUMENT IS ZERO
14637: BGT XR,=NUM02,DMP29 JUMP IF CORE DUMP REQUIRED
14638: ZER XL CLEAR XL
14639: ZER WB ZERO MOVE OFFSET
14640: MOV XR,DMARG SAVE DUMP ARGUMENT
14641: JSR GBCOL COLLECT GARBAGE
14642: JSR PRTPG EJECT PRINTER
14643: MOV =DMHDV,XR POINT TO HEADING FOR VARIABLES
14644: JSR PRTST PRINT IT
14645: JSR PRTNL TERMINATE PRINT LINE
14646: JSR PRTNL AND PRINT A BLANK LINE
14647: *
14648: * FIRST ALL NATURAL VARIABLE BLOCKS (VRBLK) WHOSE VALUES
14649: * ARE NON-NULL ARE LINKED IN LEXICAL ORDER USING DMVCH AS
14650: * THE CHAIN HEAD AND CHAINING THROUGH THE VRGET FIELDS.
14651: * NOTE THAT THIS SCRAMBLES STORE IF THE PROCESS IS
14652: * INTERRUPTED BEFORE COMPLETION E.G. BY EXCEEDING TIME OR
14653: * PRINT LIMITS. SINCE THE SUBSEQUENT CORE DUMPS AND
14654: * FAILURES IF EXECUTION IS RESUMED ARE VERY CONFUSING, THE
14655: * EXECUTION TIME ERROR ROUTINE CHECKS FOR THIS EVENT AND
14656: * ATTEMPTS AN UNSCRAMBLE. SIMILAR PRECAUTIONS SHOULD BE
14657: * OBSERVED IF TRANSLATE TIME DUMPING IS IMPLEMENTED.
14658: *
14659: ZER DMVCH SET NULL CHAIN TO START
14660: MOV HSHTB,WA POINT TO HASH TABLE
14661: *
14662: * LOOP THROUGH HEADERS IN HASH TABLE
14663: *
14664: DMP00 MOV WA,XR COPY HASH BUCKET POINTER
14665: ICA WA BUMP POINTER
14666: SUB *VRNXT,XR SET OFFSET TO MERGE
14667: *
14668: * LOOP THROUGH VRBLKS ON ONE CHAIN
14669: *
14670: DMP01 MOV VRNXT(XR),XR POINT TO NEXT VRBLK ON CHAIN
14671: BZE XR,DMP09 JUMP IF END OF THIS HASH CHAIN
14672: MOV XR,XL ELSE COPY VRBLK POINTER
14673: EJC
14674: *
14675: * DUMPR (CONTINUED)
14676: *
14677: * LOOP TO FIND VALUE AND SKIP IF NULL
14678: *
14679: DMP02 MOV VRVAL(XL),XL LOAD VALUE
14680: BEQ XL,=NULLS,DMP01 LOOP FOR NEXT VRBLK IF NULL VALUE
14681: BEQ (XL),=B$TRT,DMP02 LOOP BACK IF VALUE IS TRAPPED
14682: *
14683: * NON-NULL VALUE, PREPARE TO SEARCH CHAIN
14684: *
14685: MOV XR,WC SAVE VRBLK POINTER
14686: ADD *VRSOF,XR ADJUST PTR TO BE LIKE SCBLK PTR
14687: BNZ SCLEN(XR),DMP03 JUMP IF NON-SYSTEM VARIABLE
14688: MOV VRSVO(XR),XR ELSE LOAD PTR TO NAME IN SVBLK
14689: *
14690: * HERE WITH NAME POINTER FOR NEW BLOCK IN XR
14691: *
14692: DMP03 MOV XR,WB SAVE POINTER TO CHARS
14693: MOV WA,DMPSV SAVE HASH BUCKET POINTER
14694: MOV =DMVCH,WA POINT TO CHAIN HEAD
14695: *
14696: * LOOP TO SEARCH CHAIN FOR CORRECT INSERTION POINT
14697: *
14698: DMP04 MOV WA,DMPCH SAVE CHAIN POINTER
14699: MOV WA,XL COPY IT
14700: MOV (XL),XR LOAD POINTER TO NEXT ENTRY
14701: BZE XR,DMP08 JUMP IF END OF CHAIN TO INSERT
14702: ADD *VRSOF,XR ELSE GET NAME PTR FOR CHAINED VRBLK
14703: BNZ SCLEN(XR),DMP05 JUMP IF NOT SYSTEM VARIABLE
14704: MOV VRSVO(XR),XR ELSE POINT TO NAME IN SVBLK
14705: *
14706: * HERE PREPARE TO COMPARE THE NAMES
14707: *
14708: * (WA) SCRATCH
14709: * (WB) POINTER TO STRING OF ENTERING VRBLK
14710: * (WC) POINTER TO ENTERING VRBLK
14711: * (XR) POINTER TO STRING OF CURRENT BLOCK
14712: * (XL) SCRATCH
14713: *
14714: DMP05 MOV WB,XL POINT TO ENTERING VRBLK STRING
14715: MOV SCLEN(XL),WA LOAD ITS LENGTH
14716: PLC XL POINT TO CHARS OF ENTERING STRING
14717: BHI WA,SCLEN(XR),DMP06 JUMP IF ENTERING LENGTH HIGH
14718: PLC XR ELSE POINT TO CHARS OF OLD STRING
14719: CMC DMP08,DMP07 COMPARE, INSERT IF NEW IS LLT OLD
14720: BRN DMP08 OR IF LEQ (WE HAD SHORTER LENGTH)
14721: *
14722: * HERE WHEN NEW LENGTH IS LONGER THAN OLD LENGTH
14723: *
14724: DMP06 MOV SCLEN(XR),WA LOAD SHORTER LENGTH
14725: PLC XR POINT TO CHARS OF OLD STRING
14726: CMC DMP08,DMP07 COMPARE, INSERT IF NEW ONE LOW
14727: EJC
14728: *
14729: * DUMPR (CONTINUED)
14730: *
14731: * HERE WE MOVE OUT ON THE CHAIN
14732: *
14733: DMP07 MOV DMPCH,XL COPY CHAIN POINTER
14734: MOV (XL),WA MOVE TO NEXT ENTRY ON CHAIN
14735: BRN DMP04 LOOP BACK
14736: *
14737: * HERE AFTER LOCATING THE PROPER INSERTION POINT
14738: *
14739: DMP08 MOV DMPCH,XL COPY CHAIN POINTER
14740: MOV DMPSV,WA RESTORE HASH BUCKET POINTER
14741: MOV WC,XR RESTORE VRBLK POINTER
14742: MOV (XL),VRGET(XR) LINK VRBLK TO REST OF CHAIN
14743: MOV XR,(XL) LINK VRBLK INTO CURRENT CHAIN LOC
14744: BRN DMP01 LOOP BACK FOR NEXT VRBLK
14745: *
14746: * HERE AFTER PROCESSING ALL VRBLKS ON ONE CHAIN
14747: *
14748: DMP09 BNE WA,HSHTE,DMP00 LOOP BACK IF MORE BUCKETS TO GO
14749: *
14750: * LOOP TO GENERATE DUMP OF NATURAL VARIABLE VALUES
14751: *
14752: DMP10 MOV DMVCH,XR LOAD POINTER TO NEXT ENTRY ON CHAIN
14753: BZE XR,DMP11 JUMP IF END OF CHAIN
14754: MOV (XR),DMVCH ELSE UPDATE CHAIN PTR TO NEXT ENTRY
14755: JSR SETVR RESTORE VRGET FIELD
14756: MOV XR,XL COPY VRBLK POINTER (NAME BASE)
14757: MOV *VRVAL,WA SET OFFSET FOR VRBLK NAME
14758: JSR PRTNV PRINT NAME = VALUE
14759: BRN DMP10 LOOP BACK TILL ALL PRINTED
14760: *
14761: * PREPARE TO PRINT KEYWORDS
14762: *
14763: DMP11 JSR PRTNL PRINT BLANK LINE
14764: JSR PRTNL AND ANOTHER
14765: MOV =DMHDK,XR POINT TO KEYWORD HEADING
14766: JSR PRTST PRINT HEADING
14767: JSR PRTNL END LINE
14768: JSR PRTNL PRINT ONE BLANK LINE
14769: MOV =VDMKW,XL POINT TO LIST OF KEYWORD SVBLK PTRS
14770: EJC
14771: *
14772: * DUMPR (CONTINUED)
14773: *
14774: * LOOP TO DUMP KEYWORD VALUES
14775: *
14776: DMP12 MOV (XL)+,XR LOAD NEXT SVBLK PTR FROM TABLE
14777: BZE XR,DMP13 JUMP IF END OF LIST
14778: MOV =CH$AM,WA LOAD AMPERSAND
14779: JSR PRTCH PRINT AMPERSAND
14780: JSR PRTST PRINT KEYWORD NAME
14781: MOV SVLEN(XR),WA LOAD NAME LENGTH FROM SVBLK
14782: CTB WA,SVCHS GET LENGTH OF NAME
14783: ADD WA,XR POINT TO SVKNM FIELD
14784: MOV (XR),DMPKN STORE IN DUMMY KVBLK
14785: MOV =TMBEB,XR POINT TO BLANK-EQUAL-BLANK
14786: JSR PRTST PRINT IT
14787: MOV XL,DMPSV SAVE TABLE POINTER
14788: MOV =DMPKB,XL POINT TO DUMMY KVBLK
14789: MOV *KVVAR,WA SET ZERO OFFSET
14790: JSR ACESS GET KEYWORD VALUE
14791: PPM FAILURE IS IMPOSSIBLE
14792: JSR PRTVL PRINT KEYWORD VALUE
14793: JSR PRTNL TERMINATE PRINT LINE
14794: MOV DMPSV,XL RESTORE TABLE POINTER
14795: BRN DMP12 LOOP BACK TILL ALL PRINTED
14796: *
14797: * HERE AFTER COMPLETING PARTIAL DUMP
14798: *
14799: DMP13 BEQ DMARG,=NUM01,DMP27 EXIT IF PARTIAL DUMP COMPLETE
14800: MOV DNAMB,XR ELSE POINT TO FIRST DYNAMIC BLOCK
14801: *
14802: * LOOP THROUGH BLOCKS IN DYNAMIC STORAGE
14803: *
14804: DMP14 BEQ XR,DNAMP,DMP27 JUMP IF END OF USED REGION
14805: MOV (XR),WA ELSE LOAD FIRST WORD OF BLOCK
14806: BEQ WA,=B$VCT,DMP16 JUMP IF VECTOR
14807: BEQ WA,=B$ART,DMP17 JUMP IF ARRAY
14808: BEQ WA,=B$PDT,DMP18 JUMP IF PROGRAM DEFINED
14809: BEQ WA,=B$TBT,DMP19 JUMP IF TABLE
14810: BEQ WA,=B$BCT,DMP30 JUMP IF BUFFER
14811: *
14812: * MERGE HERE TO MOVE TO NEXT BLOCK
14813: *
14814: DMP15 JSR BLKLN GET LENGTH OF BLOCK
14815: ADD WA,XR POINT PAST THIS BLOCK
14816: BRN DMP14 LOOP BACK FOR NEXT BLOCK
14817: EJC
14818: *
14819: * DUMPR (CONTINUED)
14820: *
14821: * HERE FOR VECTOR
14822: *
14823: DMP16 MOV *VCVLS,WB SET OFFSET TO FIRST VALUE
14824: BRN DMP19 JUMP TO MERGE
14825: *
14826: * HERE FOR ARRAY
14827: *
14828: DMP17 MOV AROFS(XR),WB SET OFFSET TO ARPRO FIELD
14829: ICA WB BUMP TO GET OFFSET TO VALUES
14830: BRN DMP19 JUMP TO MERGE
14831: *
14832: * HERE FOR PROGRAM DEFINED
14833: *
14834: DMP18 MOV *PDFLD,WB POINT TO VALUES, MERGE
14835: *
14836: * HERE FOR TABLE (OTHERS MERGE)
14837: *
14838: DMP19 BZE IDVAL(XR),DMP15 IGNORE BLOCK IF ZERO ID VALUE
14839: JSR BLKLN ELSE GET BLOCK LENGTH
14840: MOV XR,XL COPY BLOCK POINTER
14841: MOV WA,DMPSV SAVE LENGTH
14842: MOV WB,WA COPY OFFSET TO FIRST VALUE
14843: JSR PRTNL PRINT BLANK LINE
14844: MOV WA,DMPSA PRESERVE OFFSET
14845: JSR PRTVL PRINT BLOCK VALUE (FOR TITLE)
14846: MOV DMPSA,WA RECOVER OFFSET
14847: JSR PRTNL END PRINT LINE
14848: BEQ (XR),=B$TBT,DMP22 JUMP IF TABLE
14849: DCA WA POINT BEFORE FIRST WORD
14850: *
14851: * LOOP TO PRINT CONTENTS OF ARRAY, VECTOR, OR PROGRAM DEF
14852: *
14853: DMP20 MOV XL,XR COPY BLOCK POINTER
14854: ICA WA BUMP OFFSET
14855: ADD WA,XR POINT TO NEXT VALUE
14856: BEQ WA,DMPSV,DMP14 EXIT IF END (XR PAST BLOCK)
14857: SUB *VRVAL,XR SUBTRACT OFFSET TO MERGE INTO LOOP
14858: *
14859: * LOOP TO FIND VALUE AND IGNORE NULLS
14860: *
14861: DMP21 MOV VRVAL(XR),XR LOAD NEXT VALUE
14862: BEQ XR,=NULLS,DMP20 LOOP BACK IF NULL VALUE
14863: BEQ (XR),=B$TRT,DMP21 LOOP BACK IF TRAPPED
14864: JSR PRTNV ELSE PRINT NAME = VALUE
14865: BRN DMP20 LOOP BACK FOR NEXT FIELD
14866: EJC
14867: *
14868: * DUMPR (CONTINUED)
14869: *
14870: * HERE TO DUMP A TABLE
14871: *
14872: DMP22 MOV *TBBUK,WC SET OFFSET TO FIRST BUCKET
14873: MOV *TEVAL,WA SET NAME OFFSET FOR ALL TEBLKS
14874: *
14875: * LOOP THROUGH TABLE BUCKETS
14876: *
14877: DMP23 MOV XL,-(XS) SAVE TBBLK POINTER
14878: ADD WC,XL POINT TO NEXT BUCKET HEADER
14879: ICA WC BUMP BUCKET OFFSET
14880: SUB *TENXT,XL SUBTRACT OFFSET TO MERGE INTO LOOP
14881: *
14882: * LOOP TO PROCESS TEBLKS ON ONE CHAIN
14883: *
14884: DMP24 MOV TENXT(XL),XL POINT TO NEXT TEBLK
14885: BEQ XL,(XS),DMP26 JUMP IF END OF CHAIN
14886: MOV XL,XR ELSE COPY TEBLK POINTER
14887: *
14888: * LOOP TO FIND VALUE AND IGNORE IF NULL
14889: *
14890: DMP25 MOV TEVAL(XR),XR LOAD NEXT VALUE
14891: BEQ XR,=NULLS,DMP24 IGNORE IF NULL VALUE
14892: BEQ (XR),=B$TRT,DMP25 LOOP BACK IF TRAPPED
14893: MOV WC,DMPSV ELSE SAVE OFFSET POINTER
14894: JSR PRTNV PRINT NAME = VALUE
14895: MOV DMPSV,WC RELOAD OFFSET
14896: BRN DMP24 LOOP BACK FOR NEXT TEBLK
14897: *
14898: * HERE TO MOVE TO NEXT HASH CHAIN
14899: *
14900: DMP26 MOV (XS)+,XL RESTORE TBBLK POINTER
14901: BNE WC,TBLEN(XL),DMP23 LOOP BACK IF MORE BUCKETS TO GO
14902: MOV XL,XR ELSE COPY TABLE POINTER
14903: ADD WC,XR POINT TO FOLLOWING BLOCK
14904: BRN DMP14 LOOP BACK TO PROCESS NEXT BLOCK
14905: *
14906: * HERE AFTER COMPLETING DUMP
14907: *
14908: DMP27 JSR PRTPG EJECT PRINTER
14909: *
14910: * MERGE HERE IF NO DUMP GIVEN (DMARG=0)
14911: *
14912: DMP28 EXI RETURN TO DUMP CALLER
14913: *
14914: * CALL SYSTEM CORE DUMP ROUTINE
14915: *
14916: DMP29 JSR SYSDM CALL IT
14917: BRN DMP28 RETURN
14918: EJC
14919: *
14920: * DUMPR (CONTINUED)
14921: *
14922: * HERE TO DUMP BUFFER BLOCK
14923: *
14924: DMP30 JSR PRTNL PRINT BLANK LINE
14925: JSR PRTVL PRINT VALUE ID FOR TITLE
14926: JSR PRTNL FORCE NEW LINE
14927: MOV =CH$DQ,WA LOAD DOUBLE QUOTE
14928: JSR PRTCH PRINT IT
14929: MOV BCLEN(XR),WC LOAD DEFINED LENGTH
14930: BZE WC,DMP32 SKIP CHARACTERS IF NONE
14931: LCT WC,WC LOAD COUNT FOR LOOP
14932: MOV XR,WB SAVE BCBLK PTR
14933: MOV BCBUF(XR),XR POINT TO BFBLK
14934: PLC XR GET SET TO LOAD CHARACTERS
14935: *
14936: * LOOP HERE STUFFING CHARACTERS IN OUTPUT STREAM
14937: *
14938: DMP31 LCH WA,(XR)+ GET NEXT CHARACTER
14939: JSR PRTCH STUFF IT
14940: BCT WC,DMP31 BRANCH FOR NEXT ONE
14941: MOV WB,XR RESTORE BCBLK POINTER
14942: *
14943: * MERGE TO STUFF CLOSING QUOTE MARK
14944: *
14945: DMP32 MOV =CH$DQ,WA STUFF QUOTE
14946: JSR PRTCH PRINT IT
14947: JSR PRTNL PRINT NEW LINE
14948: MOV (XR),WA GET FIRST WD FOR BLKLN
14949: BRN DMP15 MERGE TO GET NEXT BLOCK
14950: ENP END PROCEDURE DUMPR
14951: EJC
14952: *
14953: * ERMSG -- PRINT ERROR CODE AND ERROR MESSAGE
14954: *
14955: * KVERT ERROR CODE
14956: * JSR ERMSG CALL TO PRINT MESSAGE
14957: * (XR,XL,WA,WB,WC,IA) DESTROYED
14958: *
14959: ERMSG PRC E,0 ENTRY POINT
14960: JSR PRTIS PRINT ERROR PTR OR BLANK LINE
14961: MOV KVERT,WA LOAD ERROR CODE
14962: MOV =ERMMS,XR POINT TO ERROR MESSAGE /ERROR/
14963: JSR PRTST PRINT IT
14964: JSR ERTEX GET ERROR MESSAGE TEXT
14965: ADD =THSND,WA BUMP ERROR CODE FOR PRINT
14966: MTI WA FAIL CODE IN INT ACC
14967: JSR PRTIN PRINT CODE (NOW HAVE ERROR1XXX)
14968: MOV PRBUF,XL POINT TO PRINT BUFFER
14969: PSC XL,=NUM05 POINT TO THE 1
14970: MOV =CH$BL,WA LOAD A BLANK
14971: SCH WA,(XL) STORE BLANK OVER 1 (ERROR XXX)
14972: CSC XL COMPLETE STORE CHARACTERS
14973: ZER XL CLEAR GARBAGE POINTER IN XL
14974: MOV XR,WA KEEP ERROR TEXT
14975: MOV =ERMNS,XR POINT TO / -- /
14976: JSR PRTST PRINT IT
14977: MOV WA,XR GET ERROR TEXT AGAIN
14978: JSR PRTST PRINT ERROR MESSAGE TEXT
14979: JSR PRTIS PRINT LINE
14980: JSR PRTIS PRINT BLANK LINE
14981: EXI RETURN TO ERMSG CALLER
14982: ENP END PROCEDURE ERMSG
14983: EJC
14984: *
14985: * ERTEX -- GET ERROR MESSAGE TEXT
14986: *
14987: * (WA) ERROR CODE
14988: * JSR ERTEX CALL TO GET ERROR TEXT
14989: * (XR) PTR TO ERROR TEXT IN DYNAMIC
14990: * (R$ETX) COPY OF PTR TO ERROR TEXT
14991: * (XL,WC,IA) DESTROYED
14992: *
14993: ERTEX PRC E,0 ENTRY POINT
14994: MOV WA,ERTWA SAVE WA
14995: MOV WB,ERTWB SAVE WB
14996: JSR SYSEM GET FAILURE MESSAGE TEXT
14997: MOV XR,XL COPY POINTER TO IT
14998: MOV SCLEN(XR),WA GET LENGTH OF STRING
14999: BZE WA,ERT02 JUMP IF NULL
15000: ZER WB OFFSET OF ZERO
15001: JSR SBSTR COPY INTO DYNAMIC STORE
15002: MOV XR,R$ETX STORE FOR RELOCATION
15003: *
15004: * RETURN
15005: *
15006: ERT01 MOV ERTWB,WB RESTORE WB
15007: MOV ERTWA,WA RESTORE WA
15008: EXI RETURN TO CALLER
15009: *
15010: * RETURN ERRTEXT CONTENTS INSTEAD OF NULL
15011: *
15012: ERT02 MOV R$ETX,XR GET ERRTEXT
15013: BRN ERT01 RETURN
15014: ENP
15015: EJC
15016: *
15017: * EVALI -- EVALUATE INTEGER ARGUMENT
15018: *
15019: * EVALI IS USED BY PATTERN PRIMITIVES LEN,TAB,RTAB,POS,RPOS
15020: * WHEN THEIR ARGUMENT IS AN EXPRESSION VALUE.
15021: *
15022: * (XR) NODE POINTER
15023: * (WB) CURSOR
15024: * JSR EVALI CALL TO EVALUATE INTEGER
15025: * PPM LOC TRANSFER LOC FOR NON-INTEGER ARG
15026: * PPM LOC TRANSFER LOC FOR OUT OF RANGE ARG
15027: * PPM LOC TRANSFER LOC FOR EVALUATION FAILURE
15028: * PPM LOC TRANSFER LOC FOR SUCCESSFUL EVAL
15029: * (THE NORMAL RETURN IS NEVER TAKEN)
15030: * (XR) PTR TO NODE WITH INTEGER ARGUMENT
15031: * (WC,XL,RA) DESTROYED
15032: *
15033: * ON RETURN, THE NODE POINTED TO HAS THE INTEGER ARGUMENT
15034: * IN PARM1 AND THE PROPER SUCCESSOR POINTER IN PTHEN.
15035: * THIS ALLOWS MERGING WITH THE NORMAL (INTEGER ARG) CASE.
15036: *
15037: EVALI PRC R,4 ENTRY POINT (RECURSIVE)
15038: JSR EVALP EVALUATE EXPRESSION
15039: PPM EVLI1 JUMP ON FAILURE
15040: MOV XL,-(XS) STACK RESULT FOR GTSMI
15041: MOV PTHEN(XR),XL LOAD SUCCESSOR POINTER
15042: JSR GTSMI CONVERT ARG TO SMALL INTEGER
15043: PPM EVLI2 JUMP IF NOT INTEGER
15044: PPM EVLI3 JUMP IF OUT OF RANGE
15045: MOV XR,EVLIV STORE RESULT IN SPECIAL DUMMY NODE
15046: MOV XL,EVLIS STORE SUCCESSOR POINTER
15047: MOV =EVLIN,XR POINT TO DUMMY NODE WITH RESULT
15048: EXI 4 TAKE SUCCESSFUL EXIT
15049: *
15050: * HERE IF EVALUATION FAILS
15051: *
15052: EVLI1 EXI 3 TAKE FAILURE RETURN
15053: *
15054: * HERE IF ARGUMENT IS NOT INTEGER
15055: *
15056: EVLI2 EXI 1 TAKE NON-INTEGER ERROR EXIT
15057: *
15058: * HERE IF ARGUMENT IS OUT OF RANGE
15059: *
15060: EVLI3 EXI 2 TAKE OUT-OF-RANGE ERROR EXIT
15061: ENP END PROCEDURE EVALI
15062: EJC
15063: *
15064: * EVALP -- EVALUATE EXPRESSION DURING PATTERN MATCH
15065: *
15066: * EVALP IS USED TO EVALUATE AN EXPRESSION (BY VALUE) DURING
15067: * A PATTERN MATCH. THE EFFECT IS LIKE EVALX, BUT PATTERN
15068: * VARIABLES ARE STACKED AND RESTORED IF NECESSARY.
15069: *
15070: * EVALP ALSO DIFFERS FROM EVALX IN THAT IF THE RESULT IS
15071: * AN EXPRESSION IT IS REEVALUATED. THIS OCCURS REPEATEDLY.
15072: *
15073: * (XR) NODE POINTER
15074: * (WB) PATTERN MATCH CURSOR
15075: * JSR EVALP CALL TO EVALUATE EXPRESSION
15076: * PPM LOC TRANSFER LOC IF EVALUATION FAILS
15077: * (XL) RESULT
15078: * (WA) FIRST WORD OF RESULT BLOCK
15079: * (XR,WB) DESTROYED (FAILURE CASE ONLY)
15080: * (WC,RA) DESTROYED
15081: *
15082: * THE EXPRESSION POINTER IS STORED IN PARM1 OF THE NODE
15083: *
15084: * CONTROL RETURNS TO FAILP ON FAILURE OF EVALUATION
15085: *
15086: EVALP PRC R,1 ENTRY POINT (RECURSIVE)
15087: MOV PARM1(XR),XL LOAD EXPRESSION POINTER
15088: BEQ (XL),=B$EXL,EVLP1 JUMP IF EXBLK CASE
15089: *
15090: * HERE FOR CASE OF SEBLK
15091: *
15092: * WE CAN GIVE A FAST RETURN IF THE VALUE OF THE VRBLK IS
15093: * NOT AN EXPRESSION AND IS NOT TRAPPED.
15094: *
15095: MOV SEVAR(XL),XL LOAD VRBLK POINTER
15096: MOV VRVAL(XL),XL LOAD VALUE OF VRBLK
15097: MOV (XL),WA LOAD FIRST WORD OF VALUE
15098: BHI WA,=B$T$$,EVLP3 JUMP IF NOT SEBLK, TRBLK OR EXBLK
15099: *
15100: * HERE FOR EXBLK OR SEBLK WITH EXPR VALUE OR TRAPPED VALUE
15101: *
15102: EVLP1 MOV XR,-(XS) STACK NODE POINTER
15103: MOV WB,-(XS) STACK CURSOR
15104: MOV R$PMS,-(XS) STACK SUBJECT STRING POINTER
15105: MOV PMSSL,-(XS) STACK SUBJECT STRING LENGTH
15106: MOV PMDFL,-(XS) STACK DOT FLAG
15107: MOV PMHBS,-(XS) STACK HISTORY STACK BASE POINTER
15108: MOV PARM1(XR),XR LOAD EXPRESSION POINTER
15109: EJC
15110: *
15111: * EVALP (CONTINUED)
15112: *
15113: * LOOP BACK HERE TO REEVALUATE EXPRESSION RESULT
15114: *
15115: EVLP2 ZER WB SET FLAG FOR BY VALUE
15116: JSR EVALX EVALUATE EXPRESSION
15117: PPM EVLP4 JUMP ON FAILURE
15118: MOV (XR),WA ELSE LOAD FIRST WORD OF VALUE
15119: BLO WA,=B$E$$,EVLP2 LOOP BACK TO REEVALUATE EXPRESSION
15120: *
15121: * HERE TO RESTORE PATTERN VALUES AFTER SUCCESSFUL EVAL
15122: *
15123: MOV XR,XL COPY RESULT POINTER
15124: MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER
15125: MOV (XS)+,PMDFL RESTORE DOT FLAG
15126: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH
15127: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER
15128: MOV (XS)+,WB RESTORE CURSOR
15129: MOV (XS)+,XR RESTORE NODE POINTER
15130: *
15131: * COMMON EXIT POINT
15132: *
15133: EVLP3 EXI RETURN TO EVALP CALLER
15134: *
15135: * HERE FOR FAILURE DURING EVALUATION
15136: *
15137: EVLP4 MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER
15138: MOV (XS)+,PMDFL RESTORE DOT FLAG
15139: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH
15140: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER
15141: ADD *NUM02,XS REMOVE NODE PTR, CURSOR
15142: EXI 1 TAKE FAILURE EXIT
15143: ENP END PROCEDURE EVALP
15144: EJC
15145: *
15146: * EVALS -- EVALUATE STRING ARGUMENT
15147: *
15148: * EVALS IS USED BY SPAN, ANY, NOTANY, BREAK, BREAKX WHEN
15149: * THEY ARE PASSED AN EXPRESSION ARGUMENT.
15150: *
15151: * (XR) NODE POINTER
15152: * (WB) CURSOR
15153: * JSR EVALS CALL TO EVALUATE STRING
15154: * PPM LOC TRANSFER LOC FOR NON-STRING ARG
15155: * PPM LOC TRANSFER LOC FOR EVALUATION FAILURE
15156: * PPM LOC TRANSFER LOC FOR SUCCESSFUL EVAL
15157: * (THE NORMAL RETURN IS NEVER TAKEN)
15158: * (XR) PTR TO NODE WITH PARMS SET
15159: * (XL,WC,RA) DESTROYED
15160: *
15161: * ON RETURN, THE NODE POINTED TO HAS A CHARACTER TABLE
15162: * POINTER IN PARM1 AND A BIT MASK IN PARM2. THE PROPER
15163: * SUCCESSOR IS STORED IN PTHEN OF THIS NODE. THUS IT IS
15164: * OK FOR MERGING WITH THE NORMAL (MULTI-CHAR STRING) CASE.
15165: *
15166: EVALS PRC R,3 ENTRY POINT (RECURSIVE)
15167: JSR EVALP EVALUATE EXPRESSION
15168: PPM EVLS1 JUMP IF EVALUATION FAILS
15169: MOV PTHEN(XR),-(XS) SAVE SUCCESSOR POINTER
15170: MOV WB,-(XS) SAVE CURSOR
15171: MOV XL,-(XS) STACK RESULT PTR FOR PATST
15172: ZER WB DUMMY PCODE FOR ONE CHAR STRING
15173: ZER WC DUMMY PCODE FOR EXPRESSION ARG
15174: MOV =P$BRK,XL APPROPRIATE PCODE FOR OUR USE
15175: JSR PATST CALL ROUTINE TO BUILD NODE
15176: PPM EVLS2 JUMP IF NOT STRING
15177: MOV (XS)+,WB RESTORE CURSOR
15178: MOV (XS)+,PTHEN(XR) STORE SUCCESSOR POINTER
15179: EXI 3 TAKE SUCCESS RETURN
15180: *
15181: * HERE IF EVALUATION FAILS
15182: *
15183: EVLS1 EXI 2 TAKE FAILURE RETURN
15184: *
15185: * HERE IF ARGUMENT IS NOT STRING
15186: *
15187: EVLS2 ADD *NUM02,XS POP SUCCESSOR AND CURSOR
15188: EXI 1 TAKE NON-STRING ERROR EXIT
15189: ENP END PROCEDURE EVALS
15190: EJC
15191: *
15192: * EVALX -- EVALUATE EXPRESSION
15193: *
15194: * EVALX IS CALLED TO EVALUATE AN EXPRESSION
15195: *
15196: * (XR) POINTER TO EXBLK OR SEBLK
15197: * (WB) 0 IF BY VALUE, 1 IF BY NAME
15198: * JSR EVALX CALL TO EVALUATE EXPRESSION
15199: * PPM LOC TRANSFER LOC IF EVALUATION FAILS
15200: * (XR) RESULT IF CALLED BY VALUE
15201: * (XL,WA) RESULT NAME BASE,OFFSET IF BY NAME
15202: * (XR) DESTROYED (NAME CASE ONLY)
15203: * (XL,WA) DESTROYED (VALUE CASE ONLY)
15204: * (WB,WC,RA) DESTROYED
15205: *
15206: EVALX PRC R,1 ENTRY POINT, RECURSIVE
15207: BEQ (XR),=B$EXL,EVLX2 JUMP IF EXBLK CASE
15208: *
15209: * HERE FOR SEBLK
15210: *
15211: MOV SEVAR(XR),XL LOAD VRBLK POINTER (NAME BASE)
15212: MOV *VRVAL,WA SET NAME OFFSET
15213: BNZ WB,EVLX1 JUMP IF CALLED BY NAME
15214: JSR ACESS CALL ROUTINE TO ACCESS VALUE
15215: PPM EVLX9 JUMP IF FAILURE ON ACCESS
15216: *
15217: * MERGE HERE TO EXIT FOR SEBLK CASE
15218: *
15219: EVLX1 EXI RETURN TO EVALX CALLER
15220: EJC
15221: *
15222: * EVALX (CONTINUED)
15223: *
15224: * HERE FOR FULL EXPRESSION (EXBLK) CASE
15225: *
15226: * IF AN ERROR OCCURS IN THE EXPRESSION CODE AT EXECUTION
15227: * TIME, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL
15228: * WITHOUT RETURNING TO THIS ROUTINE.
15229: * THE FOLLOWING ENTRIES ARE MADE ON THE STACK BEFORE
15230: * GIVING CONTROL TO THE EXPRESSION CODE
15231: *
15232: * EVALX RETURN POINT
15233: * SAVED VALUE OF R$COD
15234: * CODE POINTER (-R$COD)
15235: * SAVED VALUE OF FLPTR
15236: * 0 IF BY VALUE, 1 IF BY NAME
15237: * FLPTR --------------- *EXFLC, FAIL OFFSET IN EXBLK
15238: *
15239: EVLX2 SCP WC GET CODE POINTER
15240: MOV R$COD,WA LOAD CODE BLOCK POINTER
15241: SUB WA,WC GET CODE POINTER AS OFFSET
15242: MOV WA,-(XS) STACK OLD CODE BLOCK POINTER
15243: MOV WC,-(XS) STACK RELATIVE CODE OFFSET
15244: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER
15245: MOV WB,-(XS) STACK NAME/VALUE INDICATOR
15246: MOV *EXFLC,-(XS) STACK NEW FAIL OFFSET
15247: MOV FLPTR,GTCEF KEEP IN CASE OF ERROR
15248: MOV R$COD,R$GTC KEEP CODE BLOCK POINTER SIMILARLY
15249: MOV XS,FLPTR SET NEW FAILURE POINTER
15250: MOV XR,R$COD SET NEW CODE BLOCK POINTER
15251: MOV KVSTN,EXSTM(XR) REMEMBER STMNT NUMBER
15252: ADD *EXCOD,XR POINT TO FIRST CODE WORD
15253: LCP XR SET CODE POINTER
15254: BNE STAGE,=STGXT,EXITS JUMP IF NOT EXECUTION TIME
15255: MOV =STGEE,STAGE EVALUATING EXPRESSION
15256: BRN EXITS JUMP TO EXECUTE FIRST CODE WORD
15257: EJC
15258: *
15259: * EVALX (CONTINUED)
15260: *
15261: * COME HERE IF SUCCESSFUL RETURN BY VALUE (SEE O$RVL)
15262: *
15263: EVLX3 MOV (XS)+,XR LOAD VALUE
15264: BZE 1(XS),EVLX5 JUMP IF CALLED BY VALUE
15265: ERB 249,EXPRESSION EVALUATED BY NAME RETURNED VALUE
15266: *
15267: * HERE FOR EXPRESSION RETURNING BY NAME (SEE O$RNM)
15268: *
15269: EVLX4 MOV (XS)+,WA LOAD NAME OFFSET
15270: MOV (XS)+,XL LOAD NAME BASE
15271: BNZ 1(XS),EVLX5 JUMP IF CALLED BY NAME
15272: JSR ACESS ELSE ACCESS VALUE FIRST
15273: PPM EVLX6 JUMP IF FAILURE DURING ACCESS
15274: *
15275: * HERE AFTER LOADING CORRECT RESULT INTO XR OR XL,WA
15276: *
15277: EVLX5 ZER WB NOTE SUCCESSFUL
15278: BRN EVLX7 MERGE
15279: *
15280: * HERE FOR FAILURE IN EXPRESSION EVALUATION (SEE O$FEX)
15281: *
15282: EVLX6 MNZ WB NOTE UNSUCCESSFUL
15283: *
15284: * RESTORE ENVIRONMENT
15285: *
15286: EVLX7 BNE STAGE,=STGEE,EVLX8 SKIP IF WAS NOT PREVIOUSLY XT
15287: MOV =STGXT,STAGE EXECUTE TIME
15288: *
15289: * MERGE WITH STAGE SET UP
15290: *
15291: EVLX8 ADD *NUM02,XS POP NAME/VALUE INDICATOR, *EXFAL
15292: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER
15293: MOV (XS)+,WC LOAD CODE OFFSET
15294: ADD (XS),WC MAKE CODE POINTER ABSOLUTE
15295: MOV (XS)+,R$COD RESTORE OLD CODE BLOCK POINTER
15296: LCP WC RESTORE OLD CODE POINTER
15297: BZE WB,EVLX1 JUMP FOR SUCCESSFUL RETURN
15298: *
15299: * MERGE HERE FOR FAILURE IN SEBLK CASE
15300: *
15301: EVLX9 EXI 1 TAKE FAILURE EXIT
15302: ENP END OF PROCEDURE EVALX
15303: EJC
15304: *
15305: * EXBLD -- BUILD EXBLK
15306: *
15307: * EXBLD IS USED TO BUILD AN EXPRESSION BLOCK FROM THE
15308: * CODE COMPILED MOST RECENTLY IN THE CURRENT CCBLK.
15309: *
15310: * (XL) OFFSET IN CCBLK TO START OF CODE
15311: * (WB) INTEGER IN RANGE 0 LE N LE MXLEN
15312: * JSR EXBLD CALL TO BUILD EXBLK
15313: * (XR) PTR TO CONSTRUCTED EXBLK
15314: * (WA,WB,XL) DESTROYED
15315: *
15316: EXBLD PRC E,0 ENTRY POINT
15317: MOV XL,WA COPY OFFSET TO START OF CODE
15318: SUB *EXCOD,WA CALC REDUCTION IN OFFSET IN EXBLK
15319: MOV WA,-(XS) STACK FOR LATER
15320: MOV CWCOF,WA LOAD FINAL OFFSET
15321: SUB XL,WA COMPUTE LENGTH OF CODE
15322: ADD *EXSI$,WA ADD SPACE FOR STANDARD FIELDS
15323: JSR ALLOC ALLOCATE SPACE FOR EXBLK
15324: MOV XR,-(XS) SAVE POINTER TO EXBLK
15325: MOV =B$EXL,EXTYP(XR) STORE TYPE WORD
15326: ZER EXSTM(XR) ZEROISE STMNT NUMBER FIELD
15327: MOV WA,EXLEN(XR) STORE LENGTH
15328: MOV =OFEX$,EXFLC(XR) STORE FAILURE WORD
15329: ADD *EXSI$,XR SET XR FOR SYSMW
15330: MOV XL,CWCOF RESET OFFSET TO START OF CODE
15331: ADD R$CCB,XL POINT TO START OF CODE
15332: SUB *EXSI$,WA LENGTH OF CODE TO MOVE
15333: MOV WA,-(XS) STACK LENGTH OF CODE
15334: MVW MOVE CODE TO EXBLK
15335: MOV (XS)+,WA GET LENGTH OF CODE
15336: BTW WA CONVERT BYTE COUNT TO WORD COUNT
15337: LCT WA,WA PREPARE COUNTER FOR LOOP
15338: MOV (XS),XL COPY EXBLK PTR, DONT UNSTACK
15339: ADD *EXCOD,XL POINT TO CODE ITSELF
15340: MOV 1(XS),WB GET REDUCTION IN OFFSET
15341: *
15342: * THIS LOOP SEARCHES FOR NEGATION AND SELECTION CODE SO
15343: * THAT THE OFFSETS COMPUTED WHILST CODE WAS IN CODE BLOCK
15344: * CAN BE TRANSFORMED TO REDUCED VALUES APPLICABLE IN AN
15345: * EXBLK.
15346: *
15347: EXBL1 MOV (XL)+,XR GET NEXT CODE WORD
15348: BEQ XR,=OSLA$,EXBL3 JUMP IF SELECTION FOUND
15349: BEQ XR,=ONTA$,EXBL3 JUMP IF NEGATION FOUND
15350: BCT WA,EXBL1 LOOP TO END OF CODE
15351: *
15352: * NO SELECTION FOUND OR MERGE TO EXIT ON TERMINATION
15353: *
15354: EXBL2 MOV (XS)+,XR POP EXBLK PTR INTO XR
15355: MOV (XS)+,XL POP REDUCTION CONSTANT
15356: EXI RETURN TO CALLER
15357: EJC
15358: *
15359: * EXBLD (CONTINUED)
15360: *
15361: * SELECTION OR NEGATION FOUND
15362: * REDUCE THE OFFSETS AS NEEDED. OFFSETS OCCUR IN WORDS
15363: * FOLLOWING CODE WORDS -
15364: * =ONTA$, =OSLA$, =OSLB$, =OSLC$
15365: *
15366: EXBL3 SUB WB,(XL)+ ADJUST OFFSET
15367: BCT WA,EXBL4 DECREMENT COUNT
15368: *
15369: EXBL4 BCT WA,EXBL5 DECREMENT COUNT
15370: *
15371: * CONTINUE SEARCH FOR MORE OFFSETS
15372: *
15373: EXBL5 MOV (XL)+,XR GET NEXT CODE WORD
15374: BEQ XR,=OSLA$,EXBL3 JUMP IF OFFSET FOUND
15375: BEQ XR,=OSLB$,EXBL3 JUMP IF OFFSET FOUND
15376: BEQ XR,=OSLC$,EXBL3 JUMP IF OFFSET FOUND
15377: BEQ XR,=ONTA$,EXBL3 JUMP IF OFFSET FOUND
15378: BCT WA,EXBL5 LOOP
15379: BRN EXBL2 MERGE TO RETURN
15380: ENP END PROCEDURE EXBLD
15381: EJC
15382: *
15383: * EXPAN -- ANALYZE EXPRESSION
15384: *
15385: * THE EXPRESSION ANALYZER (EXPAN) PROCEDURE IS USED TO SCAN
15386: * AN EXPRESSION AND CONVERT IT INTO A TREE REPRESENTATION.
15387: * SEE DESCRIPTIONS OF CMBLK, CUBLK, CBBLK IN THE STRUCTURES
15388: * SECTION FOR DETAILED FORMAT OF TREE BLOCKS.
15389: *
15390: * THE ANALYZER USES A SIMPLE PRECEDENCE SCHEME IN WHICH
15391: * OPERANDS AND OPERATORS ARE PLACED ON A SINGLE STACK
15392: * AND CONDENSATIONS ARE MADE WHEN LOW PRECEDENCE OPERATORS
15393: * ARE STACKED AFTER A HIGHER PRECEDENCE OPERATOR. A GLOBAL
15394: * VARIABLE (IN WB) KEEPS TRACK OF THE LEVEL AS FOLLOWS.
15395: *
15396: * 0 SCANNING OUTER LEVEL OF STATEMENT OR EXPRESSION
15397: * 1 SCANNING OUTER LEVEL OF NORMAL GOTO
15398: * 2 SCANNING OUTER LEVEL OF DIRECT GOTO
15399: * 3 SCANNING INSIDE ARRAY BRACKETS
15400: * 4 SCANNING INSIDE GROUPING PARENTHESES
15401: * 5 SCANNING INSIDE FUNCTION PARENTHESES
15402: *
15403: * THIS VARIABLE IS SAVED ON THE STACK ON ENCOUNTERING A
15404: * GROUPING AND RESTORED AT THE END OF THE GROUPING.
15405: *
15406: * ANOTHER GLOBAL VARIABLE (IN WC) COUNTS THE NUMBER OF
15407: * ITEMS AT ONE GROUPING LEVEL AND IS INCREMENTED FOR EACH
15408: * COMMA ENCOUNTERED. IT IS STACKED WITH THE LEVEL INDICATOR
15409: *
15410: * THE SCAN IS CONTROLLED BY A THREE STATE FINITE MACHINE.
15411: * A GLOBAL VARIABLE STORED IN WA IS THE CURRENT STATE.
15412: *
15413: * WA=0 NOTHING SCANNED AT THIS LEVEL
15414: * WA=1 OPERAND EXPECTED
15415: * WA=2 OPERATOR EXPECTED
15416: *
15417: * (WB) CALL TYPE (SEE BELOW)
15418: * JSR EXPAN CALL TO ANALYZE EXPRESSION
15419: * (XR) POINTER TO RESULTING TREE
15420: * (XL,WA,WB,WC,RA) DESTROYED
15421: *
15422: * THE ENTRY VALUE OF WB INDICATES THE CALL TYPE AS FOLLOWS.
15423: *
15424: * 0 SCANNING EITHER THE MAIN BODY OF A STATEMENT OR THE
15425: * TEXT OF AN EXPRESSION (FROM EVAL CALL). VALID
15426: * TERMINATORS ARE COLON, SEMICOLON. THE RESCAN FLAG IS
15427: * SET TO RETURN THE TERMINATOR ON THE NEXT SCANE CALL.
15428: *
15429: * 1 SCANNING A NORMAL GOTO. THE ONLY VALID
15430: * TERMINATOR IS A RIGHT PAREN.
15431: *
15432: * 2 SCANNING A DIRECT GOTO. THE ONLY VALID
15433: * TERMINATOR IS A RIGHT BRACKET.
15434: EJC
15435: *
15436: * EXPAN (CONTINUED)
15437: *
15438: * ENTRY POINT
15439: *
15440: EXPAN PRC E,0 ENTRY POINT
15441: ZER -(XS) SET TOP OF STACK INDICATOR
15442: ZER WA SET INITIAL STATE TO ZERO
15443: ZER WC ZERO COUNTER VALUE
15444: *
15445: * LOOP HERE FOR SUCCESSIVE ENTRIES
15446: *
15447: EXP01 JSR SCANE SCAN NEXT ELEMENT
15448: ADD WA,XL ADD STATE TO SYNTAX CODE
15449: BSW XL,T$NES SWITCH ON ELEMENT TYPE/STATE
15450: IFF T$VA0,EXP03 VARIABLE, S=0
15451: IFF T$VA1,EXP03 VARIABLE, STATE ONE
15452: IFF T$VA2,EXP04 VARIABLE, S=2
15453: IFF T$CO0,EXP03 CONSTANT, S=0
15454: IFF T$CO1,EXP03 CONSTANT, S=1
15455: IFF T$CO2,EXP04 CONSTANT, S=2
15456: IFF T$LP0,EXP06 LEFT PAREN, S=0
15457: IFF T$LP1,EXP06 LEFT PAREN, S=1
15458: IFF T$LP2,EXP04 LEFT PAREN, S=2
15459: IFF T$FN0,EXP10 FUNCTION, S=0
15460: IFF T$FN1,EXP10 FUNCTION, S=1
15461: IFF T$FN2,EXP04 FUNCTION, S=2
15462: IFF T$RP0,EXP02 RIGHT PAREN, S=0
15463: IFF T$RP1,EXP05 RIGHT PAREN, S=1
15464: IFF T$RP2,EXP12 RIGHT PAREN, S=2
15465: IFF T$LB0,EXP08 LEFT BRKT, S=0
15466: IFF T$LB1,EXP08 LEFT BRKT, S=1
15467: IFF T$LB2,EXP09 LEFT BRKT, S=2
15468: IFF T$RB0,EXP02 RIGHT BRKT, S=0
15469: IFF T$RB1,EXP05 RIGHT BRKT, S=1
15470: IFF T$RB2,EXP18 RIGHT BRKT, S=2
15471: IFF T$UO0,EXP27 UNOP, S=0
15472: IFF T$UO1,EXP27 UNOP, S=1
15473: IFF T$UO2,EXP04 UNOP, S=2
15474: IFF T$BO0,EXP05 BINOP, S=0
15475: IFF T$BO1,EXP05 BINOP, S=1
15476: IFF T$BO2,EXP26 BINOP, S=2
15477: IFF T$CM0,EXP02 COMMA, S=0
15478: IFF T$CM1,EXP05 COMMA, S=1
15479: IFF T$CM2,EXP11 COMMA, S=2
15480: IFF T$CL0,EXP02 COLON, S=0
15481: IFF T$CL1,EXP05 COLON, S=1
15482: IFF T$CL2,EXP19 COLON, S=2
15483: IFF T$SM0,EXP02 SEMICOLON, S=0
15484: IFF T$SM1,EXP05 SEMICOLON, S=1
15485: IFF T$SM2,EXP19 SEMICOLON, S=2
15486: ESW END SWITCH ON ELEMENT TYPE/STATE
15487: EJC
15488: *
15489: * EXPAN (CONTINUED)
15490: *
15491: * HERE FOR RBR,RPR,COL,SMC,CMA IN STATE 0
15492: *
15493: * SET TO RESCAN THE TERMINATOR ENCOUNTERED AND CREATE
15494: * A NULL CONSTANT (CASE OF OMITTED NULL)
15495: *
15496: EXP02 MNZ SCNRS SET TO RESCAN ELEMENT
15497: MOV =NULLS,XR POINT TO NULL, MERGE
15498: *
15499: * HERE FOR VAR OR CON IN STATES 0,1
15500: *
15501: * STACK THE VARIABLE/CONSTANT AND SET STATE=2
15502: *
15503: EXP03 MOV XR,-(XS) STACK POINTER TO OPERAND
15504: MOV =NUM02,WA SET STATE 2
15505: BRN EXP01 JUMP FOR NEXT ELEMENT
15506: *
15507: * HERE FOR VAR,CON,LPR,FNC,UOP IN STATE 2
15508: *
15509: * WE RESCAN THE ELEMENT AND CREATE A CONCATENATION OPERATOR
15510: * THIS IS THE CASE OF THE BLANK CONCATENATION OPERATOR.
15511: *
15512: EXP04 MNZ SCNRS SET TO RESCAN ELEMENT
15513: MOV =OPDVC,XR POINT TO CONCAT OPERATOR DV
15514: BZE WB,EXP4A OK IF AT TOP LEVEL
15515: MOV =OPDVP,XR ELSE POINT TO UNMISTAKABLE CONCAT.
15516: *
15517: * MERGE HERE WHEN XR SET UP WITH PROPER CONCATENATION DVBLK
15518: *
15519: EXP4A BNZ SCNBL,EXP26 MERGE BOP IF BLANKS, ELSE ERROR
15520: DCV SCNSE ADJUST START OF ELEMENT LOCATION
15521: ERB 220,SYNTAX ERROR. MISSING OPERATOR
15522: *
15523: * HERE FOR CMA,RPR,RBR,COL,SMC,BOP(S=1) BOP(S=0)
15524: *
15525: * THIS IS AN ERRONOUS CONTRUCTION
15526: *
15527: EXP05 DCV SCNSE ADJUST START OF ELEMENT LOCATION
15528: ERB 221,SYNTAX ERROR. MISSING OPERAND
15529: *
15530: * HERE FOR LPR (S=0,1)
15531: *
15532: EXP06 MOV =NUM04,XL SET NEW LEVEL INDICATOR
15533: ZER XR SET ZERO VALUE FOR CMOPN
15534: EJC
15535: *
15536: * EXPAN (CONTINUED)
15537: *
15538: * MERGE HERE TO STORE OLD LEVEL ON STACK AND START NEW ONE
15539: *
15540: EXP07 MOV XR,-(XS) STACK CMOPN VALUE
15541: MOV WC,-(XS) STACK OLD COUNTER
15542: MOV WB,-(XS) STACK OLD LEVEL INDICATOR
15543: CHK CHECK FOR STACK OVERFLOW
15544: ZER WA SET NEW STATE TO ZERO
15545: MOV XL,WB SET NEW LEVEL INDICATOR
15546: MOV =NUM01,WC INITIALIZE NEW COUNTER
15547: BRN EXP01 JUMP TO SCAN NEXT ELEMENT
15548: *
15549: * HERE FOR LBR (S=0,1)
15550: *
15551: * THIS IS AN ILLEGAL USE OF LEFT BRACKET
15552: *
15553: EXP08 ERB 222,SYNTAX ERROR. INVALID USE OF LEFT BRACKET
15554: *
15555: * HERE FOR LBR (S=2)
15556: *
15557: * SET NEW LEVEL AND START TO SCAN SUBSCRIPTS
15558: *
15559: EXP09 MOV (XS)+,XR LOAD ARRAY PTR FOR CMOPN
15560: MOV =NUM03,XL SET NEW LEVEL INDICATOR
15561: BRN EXP07 JUMP TO STACK OLD AND START NEW
15562: *
15563: * HERE FOR FNC (S=0,1)
15564: *
15565: * STACK OLD LEVEL AND START TO SCAN ARGUMENTS
15566: *
15567: EXP10 MOV =NUM05,XL SET NEW LEV INDIC (XR=VRBLK=CMOPN)
15568: BRN EXP07 JUMP TO STACK OLD AND START NEW
15569: *
15570: * HERE FOR CMA (S=2)
15571: *
15572: * INCREMENT ARGUMENT COUNT AND CONTINUE
15573: *
15574: EXP11 ICV WC INCREMENT COUNTER
15575: JSR EXPDM DUMP OPERATORS AT THIS LEVEL
15576: ZER -(XS) SET NEW LEVEL FOR PARAMETER
15577: ZER WA SET NEW STATE
15578: BGT WB,=NUM02,EXP01 LOOP BACK UNLESS OUTER LEVEL
15579: ERB 223,SYNTAX ERROR. INVALID USE OF COMMA
15580: EJC
15581: *
15582: * EXPAN (CONTINUED)
15583: *
15584: * HERE FOR RPR (S=2)
15585: *
15586: * AT OUTER LEVEL IN A NORMAL GOTO THIS IS A TERMINATOR
15587: * OTHERWISE IT MUST TERMINATE A FUNCTION OR GROUPING
15588: *
15589: EXP12 BEQ WB,=NUM01,EXP20 END OF NORMAL GOTO
15590: BEQ WB,=NUM05,EXP13 END OF FUNCTION ARGUMENTS
15591: BEQ WB,=NUM04,EXP14 END OF GROUPING / SELECTION
15592: ERB 224,SYNTAX ERROR. UNBALANCED RIGHT PARENTHESIS
15593: *
15594: * HERE AT END OF FUNCTION ARGUMENTS
15595: *
15596: EXP13 MOV =C$FNC,XL SET CMTYP VALUE FOR FUNCTION
15597: BRN EXP15 JUMP TO BUILD CMBLK
15598: *
15599: * HERE FOR END OF GROUPING
15600: *
15601: EXP14 BEQ WC,=NUM01,EXP17 JUMP IF END OF GROUPING
15602: MOV =C$SEL,XL ELSE SET CMTYP FOR SELECTION
15603: *
15604: * MERGE HERE TO BUILD CMBLK FOR LEVEL JUST SCANNED AND
15605: * TO POP UP TO THE PREVIOUS SCAN LEVEL BEFORE CONTINUING.
15606: *
15607: EXP15 JSR EXPDM DUMP OPERATORS AT THIS LEVEL
15608: MOV WC,WA COPY COUNT
15609: ADD =CMVLS,WA ADD FOR STANDARD FIELDS AT START
15610: WTB WA CONVERT LENGTH TO BYTES
15611: JSR ALLOC ALLOCATE SPACE FOR CMBLK
15612: MOV =B$CMT,(XR) STORE TYPE CODE FOR CMBLK
15613: MOV XL,CMTYP(XR) STORE CMBLK NODE TYPE INDICATOR
15614: MOV WA,CMLEN(XR) STORE LENGTH
15615: ADD WA,XR POINT PAST END OF BLOCK
15616: LCT WC,WC SET LOOP COUNTER
15617: *
15618: * LOOP TO MOVE REMAINING WORDS TO CMBLK
15619: *
15620: EXP16 MOV (XS)+,-(XR) MOVE ONE OPERAND PTR FROM STACK
15621: MOV (XS)+,WB POP TO OLD LEVEL INDICATOR
15622: BCT WC,EXP16 LOOP TILL ALL MOVED
15623: EJC
15624: *
15625: * EXPAN (CONTINUED)
15626: *
15627: * COMPLETE CMBLK AND STACK POINTER TO IT ON STACK
15628: *
15629: SUB *CMVLS,XR POINT BACK TO START OF BLOCK
15630: MOV (XS)+,WC RESTORE OLD COUNTER
15631: MOV (XS),CMOPN(XR) STORE OPERAND PTR IN CMBLK
15632: MOV XR,(XS) STACK CMBLK POINTER
15633: MOV =NUM02,WA SET NEW STATE
15634: BRN EXP01 BACK FOR NEXT ELEMENT
15635: *
15636: * HERE AT END OF A PARENTHESIZED EXPRESSION
15637: *
15638: EXP17 JSR EXPDM DUMP OPERATORS AT THIS LEVEL
15639: MOV (XS)+,XR RESTORE XR
15640: MOV (XS)+,WB RESTORE OUTER LEVEL
15641: MOV (XS)+,WC RESTORE OUTER COUNT
15642: MOV XR,(XS) STORE OPND OVER UNUSED CMOPN VAL
15643: MOV =NUM02,WA SET NEW STATE
15644: BRN EXP01 BACK FOR NEXT ELE8ENT
15645: *
15646: * HERE FOR RBR (S=2)
15647: *
15648: * AT OUTER LEVEL IN A DIRECT GOTO, THIS IS A TERMINATOR.
15649: * OTHERWISE IT MUST TERMINATE A SUBSCRIPT LIST.
15650: *
15651: EXP18 MOV =C$ARR,XL SET CMTYP FOR ARRAY REFERENCE
15652: BEQ WB,=NUM03,EXP15 JUMP TO BUILD CMBLK IF END ARRAYREF
15653: BEQ WB,=NUM02,EXP20 JUMP IF END OF DIRECT GOTO
15654: ERB 225,SYNTAX ERROR. UNBALANCED RIGHT BRACKET
15655: EJC
15656: *
15657: * EXPAN (CONTINUED)
15658: *
15659: * HERE FOR COL,SMC (S=2)
15660: *
15661: * ERROR UNLESS TERMINATING STATEMENT BODY AT OUTER LEVEL
15662: *
15663: EXP19 MNZ SCNRS RESCAN TERMINATOR
15664: MOV WB,XL COPY LEVEL INDICATOR
15665: BSW XL,6 SWITCH ON LEVEL INDICATOR
15666: IFF 0,EXP20 NORMAL OUTER LEVEL
15667: IFF 1,EXP22 FAIL IF NORMAL GOTO
15668: IFF 2,EXP23 FAIL IF DIRECT GOTO
15669: IFF 3,EXP24 FAIL ARRAY BRACKETS
15670: IFF 4,EXP21 FAIL IF IN GROUPING
15671: IFF 5,EXP21 FAIL FUNCTION ARGS
15672: ESW END SWITCH ON LEVEL
15673: *
15674: * HERE AT NORMAL END OF EXPRESSION
15675: *
15676: EXP20 JSR EXPDM DUMP REMAINING OPERATORS
15677: MOV (XS)+,XR LOAD TREE POINTER
15678: ICA XS POP OFF BOTTOM OF STACK MARKER
15679: EXI RETURN TO EXPAN CALLER
15680: *
15681: * MISSING RIGHT PAREN
15682: *
15683: EXP21 ERB 226,SYNTAX ERROR. MISSING RIGHT PAREN
15684: *
15685: * MISSING RIGHT PAREN IN GOTO FIELD
15686: *
15687: EXP22 ERB 227,SYNTAX ERROR. RIGHT PAREN MISSING FROM GOTO
15688: *
15689: * MISSING BRACKET IN GOTO
15690: *
15691: EXP23 ERB 228,SYNTAX ERROR. RIGHT BRACKET MISSING FROM GOTO
15692: *
15693: * MISSING ARRAY BRACKET
15694: *
15695: EXP24 ERB 229,SYNTAX ERROR. MISSING RIGHT ARRAY BRACKET
15696: EJC
15697: *
15698: * EXPAN (CONTINUED)
15699: *
15700: * LOOP HERE WHEN AN OPERATOR CAUSES AN OPERATOR DUMP
15701: *
15702: EXP25 MOV XR,EXPSV
15703: JSR EXPOP POP ONE OPERATOR
15704: MOV EXPSV,XR RESTORE OP DV POINTER AND MERGE
15705: *
15706: * HERE FOR BOP (S=2)
15707: *
15708: * REMOVE OPERATORS (CONDENSE) FROM STACK UNTIL NO MORE
15709: * LEFT AT THIS LEVEL OR TOP ONE HAS LOWER PRECEDENCE.
15710: * LOOP HERE TILL THIS CONDITION IS MET.
15711: *
15712: EXP26 MOV 1(XS),XL LOAD OPERATOR DVPTR FROM STACK
15713: BLE XL,=NUM05,EXP27 JUMP IF BOTTOM OF STACK LEVEL
15714: BLT DVRPR(XR),DVLPR(XL),EXP25 ELSE POP IF NEW PREC IS LO
15715: *
15716: * HERE FOR UOP (S=0,1)
15717: *
15718: * BINARY OPERATOR MERGES AFTER PRECEDENCE CHECK
15719: *
15720: * THE OPERATOR DV IS STORED ON THE STACK AND THE SCAN
15721: * CONTINUES AFTER SETTING THE SCAN STATE TO ONE.
15722: *
15723: EXP27 MOV XR,-(XS) STACK OPERATOR DVPTR ON STACK
15724: CHK CHECK FOR STACK OVERFLOW
15725: MOV =NUM01,WA SET NEW STATE
15726: BNE XR,=OPDVS,EXP01 BACK FOR NEXT ELEMENT UNLESS =
15727: *
15728: * HERE FOR SPECIAL CASE OF BINARY =. THE SYNTAX ALLOWS A
15729: * NULL RIGHT ARGUMENT FOR THIS OPERATOR TO BE LEFT
15730: * OUT. ACCORDINGLY WE RESET TO STATE ZERO TO GET PROPER
15731: * ACTION ON A TERMINATOR (SUPPLY A NULL CONSTANT).
15732: *
15733: ZER WA SET STATE ZERO
15734: BRN EXP01 JUMP FOR NEXT ELEMENT
15735: ENP END PROCEDURE EXPAN
15736: EJC
15737: *
15738: * EXPAP -- TEST FOR PATTERN MATCH TREE
15739: *
15740: * EXPAP IS PASSED AN EXPRESSION TREE TO DETERMINE IF IT
15741: * IS A PATTERN MATCH. THE FOLLOWING ARE RECOGIZED AS
15742: * MATCHES IN THE CONTEXT OF THIS CALL.
15743: *
15744: * 1) AN EXPLICIT USE OF BINARY QUESTION MARK
15745: * 2) A CONCATENATION
15746: * 3) AN ALTERNATION WHOSE LEFT OPERAND IS A CONCATENATION
15747: *
15748: * (XR) PTR TO EXPAN TREE
15749: * JSR EXPAP CALL TO TEST FOR PATTERN MATCH
15750: * PPM LOC TRANSFER LOC IF NOT A PATTERN MATCH
15751: * (WA) DESTROYED
15752: * (XR) UNCHANGED (IF NOT MATCH)
15753: * (XR) PTR TO BINARY OPERATOR BLK IF MATCH
15754: *
15755: EXPAP PRC E,1 ENTRY POINT
15756: MOV XL,-(XS) SAVE XL
15757: BNE (XR),=B$CMT,EXPP2 NO MATCH IF NOT COMPLEX
15758: MOV CMTYP(XR),WA ELSE LOAD TYPE CODE
15759: BEQ WA,=C$CNC,EXPP1 CONCATENATION IS A MATCH
15760: BEQ WA,=C$PMT,EXPP1 BINARY QUESTION MARK IS A MATCH
15761: BNE WA,=C$ALT,EXPP2 ELSE NOT MATCH UNLESS ALTERNATION
15762: *
15763: * HERE FOR ALTERNATION. CHANGE (A B) / C TO A QM (B / C)
15764: *
15765: MOV CMLOP(XR),XL LOAD LEFT OPERAND POINTER
15766: BNE (XL),=B$CMT,EXPP2 NOT MATCH IF LEFT OPND NOT COMPLEX
15767: BNE CMTYP(XL),=C$CNC,EXPP2 NOT MATCH IF LEFT OP NOT CONC
15768: MOV CMROP(XL),CMLOP(XR) XR POINTS TO (B / C)
15769: MOV XR,CMROP(XL) SET XL OPNDS TO A, (B / C)
15770: MOV XL,XR POINT TO THIS ALTERED NODE
15771: *
15772: * EXIT HERE FOR PATTERN MATCH
15773: *
15774: EXPP1 MOV (XS)+,XL RESTORE ENTRY XL
15775: EXI GIVE PATTERN MATCH RETURN
15776: *
15777: * EXIT HERE IF NOT PATTERN MATCH
15778: *
15779: EXPP2 MOV (XS)+,XL RESTORE ENTRY XL
15780: EXI 1 GIVE NON-MATCH RETURN
15781: ENP END PROCEDURE EXPAP
15782: EJC
15783: *
15784: * EXPDM -- DUMP OPERATORS AT CURRENT LEVEL (FOR EXPAN)
15785: *
15786: * EXPDM USES EXPOP TO CONDENSE ALL OPERATORS AT THIS SYNTAX
15787: * LEVEL. THE STACK BOTTOM IS RECOGNIZED FROM THE LEVEL
15788: * VALUE WHICH IS SAVED ON THE TOP OF THE STACK.
15789: *
15790: * JSR EXPDM CALL TO DUMP OPERATORS
15791: * (XS) POPPED AS REQUIRED
15792: * (XR,WA) DESTROYED
15793: *
15794: EXPDM PRC N,0 ENTRY POINT
15795: MOV XL,R$EXS SAVE XL VALUE
15796: *
15797: * LOOP TO DUMP OPERATORS
15798: *
15799: EXDM1 BLE 1(XS),=NUM05,EXDM2 JUMP IF STACK BOTTOM (SAVED LEVEL
15800: JSR EXPOP ELSE POP ONE OPERATOR
15801: BRN EXDM1 AND LOOP BACK
15802: *
15803: * HERE AFTER POPPING ALL OPERATORS
15804: *
15805: EXDM2 MOV R$EXS,XL RESTORE XL
15806: ZER R$EXS RELEASE SAVE LOCATION
15807: EXI RETURN TO EXPDM CALLER
15808: ENP END PROCEDURE EXPDM
15809: EJC
15810: *
15811: * EXPOP-- POP OPERATOR (FOR EXPAN)
15812: *
15813: * EXPOP IS USED BY THE EXPAN ROUTINE TO CONDENSE ONE
15814: * OPERATOR FROM THE TOP OF THE SYNTAX STACK. AN APPROPRIATE
15815: * CMBLK IS BUILT FOR THE OPERATOR (UNARY OR BINARY) AND A
15816: * POINTER TO THIS CMBLK IS STACKED.
15817: *
15818: * EXPOP IS ALSO USED BY SCNGF (GOTO FIELD SCAN) PROCEDURE
15819: *
15820: * JSR EXPOP CALL TO POP OPERATOR
15821: * (XS) POPPED APPROPRIATELY
15822: * (XR,XL,WA) DESTROYED
15823: *
15824: EXPOP PRC N,0 ENTRY POINT
15825: MOV 1(XS),XR LOAD OPERATOR DV POINTER
15826: BEQ DVLPR(XR),=LLUNO,EXPO2 JUMP IF UNARY
15827: *
15828: * HERE FOR BINARY OPERATOR
15829: *
15830: MOV *CMBS$,WA SET SIZE OF BINARY OPERATOR CMBLK
15831: JSR ALLOC ALLOCATE SPACE FOR CMBLK
15832: MOV (XS)+,CMROP(XR) POP AND STORE RIGHT OPERAND PTR
15833: MOV (XS)+,XL POP AND LOAD OPERATOR DV PTR
15834: MOV (XS),CMLOP(XR) STORE LEFT OPERAND POINTER
15835: *
15836: * COMMON EXIT POINT
15837: *
15838: EXPO1 MOV =B$CMT,(XR) STORE TYPE CODE FOR CMBLK
15839: MOV DVTYP(XL),CMTYP(XR) STORE CMBLK NODE TYPE CODE
15840: MOV XL,CMOPN(XR) STORE DVPTR (=PTR TO DAC O$XXX)
15841: MOV WA,CMLEN(XR) STORE CMBLK LENGTH
15842: MOV XR,(XS) STORE RESULTING NODE PTR ON STACK
15843: EXI RETURN TO EXPOP CALLER
15844: *
15845: * HERE FOR UNARY OPERATOR
15846: *
15847: EXPO2 MOV *CMUS$,WA SET SIZE OF UNARY OPERATOR CMBLK
15848: JSR ALLOC ALLOCATE SPACE FOR CMBLK
15849: MOV (XS)+,CMROP(XR) POP AND STORE OPERAND POINTER
15850: MOV (XS),XL LOAD OPERATOR DV POINTER
15851: BRN EXPO1 MERGE BACK TO EXIT
15852: ENP END PROCEDURE EXPOP
15853: EJC
15854: *
15855: * FLSTG -- FOLD STRING TO UPPER CASE
15856: *
15857: * FLSTG FOLDS A CHARACTER STRING CONTAINING LOWER CASE
15858: * CHARACCTERS TO ONE CONTAINING UPPER CASE CHARACTERS.
15859: * FOLDING IS ONLY DONE IF &CASE (KVCAS) IS NOT ZERO.
15860: *
15861: * (XR) STRING ARGUMENT
15862: * (WA) LENGTH OF STRING
15863: * JSR FLSTG CALL TO FOLD STRING
15864: * (XR) RESULT STRING (POSSIBLY ORIGINAL)
15865: * (WC) DESTROYED
15866: *
15867: FLSTG PRC R,0 ENTRY POINT
15868: BZE KVCAS,FST99 SKIP IF &CASE IS 0
15869: MOV XL,-(XS) SAVE XL ACROSS CALL
15870: MOV XR,-(XS) SAVE ORIGINAL SCBLK PTR
15871: JSR ALOCS ALLOCATE NEW STRING BLOCK
15872: MOV (XS),XL POINT TO ORIGINAL SCBLK
15873: MOV XR,-(XS) SAVE POINTER TO NEW SCBLK
15874: PLC XL POINT TO ORIGINAL CHARS
15875: PLC XR POINT TO NEW CHARS
15876: ZER -(XS) INIT DID FOLD FLAG
15877: LCT WC,WC LOAD LOOP COUNTER
15878: FST01 LCH WA,(XL)+ LOAD CHARACTER
15879: BGT =CH$$A,WA,FST02 SKIP IF LESS THAN LC A
15880: BGT WA,=CH$$$,FST02 SKIP IF GREATER THAN LC Z
15881: FLC WA FOLD CHARACTER TO UPPER CASE
15882: MNZ (XS) SET DID FOLD CHARACTER FLAG
15883: FST02 SCH WA,(XR)+ STORE (POSSIBLY FOLDED) CHARACTER
15884: BCT WC,FST01 LOOP THRU ENTIRE STRING
15885: CSC XR COMPLETE STORE CHARACTERS
15886: BNZ (XS)+,FST10 SKIP IF FOLDING DONE
15887: MOV (XS)+,DNAMP DO NOT NEED NEW SCBLK
15888: MOV (XS)+,XR RETURN ORIGINAL SCBLK
15889: BRN FST20 MERGE BELOW
15890: FST10 MOV (XS)+,XR RETURN NEW SCBLK
15891: ICA XS THROW AWAY ORIGINAL SCBLK POINTER
15892: FST20 MOV SCLEN(XR),WA RELOAD STRING LENGTH
15893: MOV (XS)+,XL RESTORE XL
15894: FST99 EXI RETURN
15895: ENP
15896: EJC
15897: *
15898: * GBCOL -- PERFORM GARBAGE COLLECTION
15899: *
15900: * GBCOL PERFORMS A GARBAGE COLLECTION ON THE DYNAMIC REGION
15901: * ALL BLOCKS WHICH ARE NO LONGER IN USE ARE ELIMINATED
15902: * BY MOVING BLOCKS WHICH ARE IN USE DOWN AND RESETTING
15903: * DNAMP, THE POINTER TO THE NEXT AVAILABLE LOCATION.
15904: *
15905: * (WB) MOVE OFFSET (SEE BELOW)
15906: * JSR GBCOL CALL TO COLLECT GARBAGE
15907: * (XR) DESTROYED
15908: *
15909: * THE FOLLOWING CONDITIONS MUST BE MET AT THE TIME WHEN
15910: * GBCOL IS CALLED.
15911: *
15912: * 1) ALL POINTERS TO BLOCKS IN THE DYNAMIC AREA MUST BE
15913: * ACCESSIBLE TO THE GARBAGE COLLECTOR. THIS MEANS
15914: * THAT THEY MUST OCCUR IN ONE OF THE FOLLOWING.
15915: *
15916: * A) MAIN STACK, WITH CURRENT TOP
15917: * ELEMENT BEING INDICATED BY XS
15918: *
15919: * B) IN RELOCATABLE FIELDS OF VRBLKS.
15920: *
15921: * C) IN REGISTER XL AT THE TIME OF CALL
15922: *
15923: * E) IN THE SPECIAL REGION OF WORKING
15924: * STORAGE WHERE NAMES BEGIN WITH R$.
15925: *
15926: * 2) ALL POINTERS MUST POINT TO THE START OF BLOCKS WITH
15927: * THE SOLE EXCEPTION OF THE CONTENTS OF THE CODE
15928: * POINTER REGISTER WHICH POINTS INTO THE R$COD BLOCK.
15929: *
15930: * 3) NO LOCATION WHICH APPEARS TO CONTAIN A POINTER
15931: * INTO THE DYNAMIC REGION MAY OCCUR UNLESS IT IS IN
15932: * FACT A POINTER TO THE START OF THE BLOCK. HOWEVER
15933: * POINTERS OUTSIDE THIS AREA MAY OCCUR AND WILL
15934: * NOT BE CHANGED BY THE GARBAGE COLLECTOR.
15935: * IT IS ESPECIALLY IMPORTANT TO MAKE SURE THAT XL
15936: * DOES NOT CONTAIN A GARBAGE VALUE FROM SOME PROCESS
15937: * CARRIED OUT BEFORE THE CALL TO THE COLLECTOR.
15938: *
15939: * GBCOL HAS THE CAPABILITY OF MOVING THE FINAL COMPACTED
15940: * RESULT UP IN MEMORY (WITH ADDRESSES ADJUSTED ACCORDINGLY)
15941: * THIS IS USED TO ADD SPACE TO THE STATIC REGION. THE
15942: * ENTRY VALUE OF WB IS THE NUMBER OF BYTES TO MOVE UP.
15943: * THE CALLER MUST GUARANTEE THAT THERE IS ENOUGH ROOM.
15944: * FURTHERMORE THE VALUE IN WB IF IT IS NON-ZERO, MUST BE AT
15945: * LEAST 256 SO THAT THE MWB INSTRUCTION CONDITIONS ARE MET.
15946: EJC
15947: *
15948: * GBCOL (CONTINUED)
15949: *
15950: * THE ALGORITHM, WHICH IS A MODIFICATION OF THE LISP-2
15951: * GARBAGE COLLECTOR DEVISED BY R.DEWAR AND K.BELCHER
15952: * TAKES THREE PASSES AS FOLLOWS.
15953: *
15954: * 1) ALL POINTERS IN MEMORY ARE SCANNED AND BLOCKS IN USE
15955: * DETERMINED FROM THIS SCAN. NOTE THAT THIS PROCEDURE
15956: * IS RECURSIVE AND USES THE MAIN STACK FOR LINKAGE.
15957: * THE MARKING PROCESS IS THUS SIMILAR TO THAT USED IN
15958: * A STANDARD LISP COLLECTOR. HOWEVER THE METHOD OF
15959: * ACTUALLY MARKING THE BLOCKS IS DIFFERENT.
15960: *
15961: * THE FIRST FIELD OF A BLOCK NORMALLY CONTAINS A
15962: * CODE ENTRY POINT POINTER. SUCH AN ENTRY POINTER
15963: * CAN BE DISTINGUISHED FROM THE ADDRESS OF ANY POINTER
15964: * TO BE PROCESSED BY THE COLLECTOR. DURING GARBAGE
15965: * COLLECTION, THIS WORD IS USED TO BUILD A BACK CHAIN
15966: * OF POINTERS THROUGH FIELDS WHICH POINT TO THE BLOCK.
15967: * THE END OF THE CHAIN IS MARKED BY THE OCCURENCE
15968: * OF THE WORD WHICH USED TO BE IN THE FIRST WORD OF
15969: * THE BLOCK. THIS BACKCHAIN SERVES BOTH AS A MARK
15970: * INDICATING THAT THE BLOCK IS IN USE AND AS A LIST OF
15971: * REFERENCES FOR THE RELOCATION PHASE.
15972: *
15973: * 2) STORAGE IS SCANNED SEQUENTIALLY TO DISCOVER WHICH
15974: * BLOCKS ARE CURRENTLY IN USE AS INDICATED BY THE
15975: * PRESENCE OF A BACKCHAIN. TWO POINTERS ARE MAINTAINED
15976: * ONE SCANS THROUGH LOOKING AT EACH BLOCK. THE OTHER
15977: * IS INCREMENTED ONLY FOR BLOCKS FOUND TO BE IN USE.
15978: * IN THIS WAY, THE EVENTUAL LOCATION OF EACH BLOCK CAN
15979: * BE DETERMINED WITHOUT ACTUALLY MOVING ANY BLOCKS.
15980: * AS EACH BLOCK WHICH IS IN USE IS PROCESSED, THE BACK
15981: * CHAIN IS USED TO RESET ALL POINTERS WHICH POINT TO
15982: * THIS BLOCK TO CONTAIN ITS NEW ADDRESS, I.E. THE
15983: * ADDRESS IT WILL OCCUPY AFTER THE BLOCKS ARE MOVED.
15984: * THE FIRST WORD OF THE BLOCK, TAKEN FROM THE END OF
15985: * THE CHAIN IS RESTORED AT THIS POINT.
15986: *
15987: * DURING PASS 2, THE COLLECTOR BUILDS BLOCKS WHICH
15988: * DESCRIBE THE REGIONS OF STORAGE WHICH ARE TO BE
15989: * MOVED IN THE THIRD PASS. THERE IS ONE DESCRIPTOR FOR
15990: * EACH CONTIGUOUS SET OF GOOD BLOCKS. THE DESCRIPTOR
15991: * IS BUILT JUST BEHIND THE BLOCK TO BE MOVED AND
15992: * CONTAINS A POINTER TO THE NEXT BLOCK AND THE NUMBER
15993: * OF WORDS TO BE MOVED.
15994: *
15995: * 3) IN THE THIRD AND FINAL PASS, THE MOVE DESCRIPTOR
15996: * BLOCKS BUILT IN PASS TWO ARE USED TO ACTUALLY MOVE
15997: * THE BLOCKS DOWN TO THE BOTTOM OF THE DYNAMIC REGION.
15998: * THE COLLECTION IS THEN COMPLETE AND THE NEXT
15999: * AVAILABLE LOCATION POINTER IS RESET.
16000: EJC
16001: *
16002: * GBCOL (CONTINUED)
16003: *
16004: GBCOL PRC E,0 ENTRY POINT
16005: BNZ DMVCH,GBC14 FAIL IF IN MID-DUMP
16006: MNZ GBCFL NOTE GBCOL ENTERED
16007: MOV WA,GBSVA SAVE ENTRY WA
16008: MOV WB,GBSVB SAVE ENTRY WB
16009: MOV WC,GBSVC SAVE ENTRY WC
16010: MOV XL,-(XS) SAVE ENTRY XL
16011: SCP WA GET CODE POINTER VALUE
16012: SUB R$COD,WA MAKE RELATIVE
16013: LCP WA AND RESTORE
16014: *
16015: * PROCESS STACK ENTRIES
16016: *
16017: MOV XS,XR POINT TO STACK FRONT
16018: MOV STBAS,XL POINT PAST END OF STACK
16019: BGE XL,XR,GBC00 OK IF D-STACK
16020: MOV XL,XR REVERSE IF ...
16021: MOV XS,XL ... U-STACK
16022: *
16023: * PROCESS THE STACK
16024: *
16025: GBC00 JSR GBCPF PROCESS POINTERS ON STACK
16026: *
16027: * PROCESS SPECIAL WORK LOCATIONS
16028: *
16029: MOV =R$AAA,XR POINT TO START OF RELOCATABLE LOCS
16030: MOV =R$YYY,XL POINT PAST END OF RELOCATABLE LOCS
16031: JSR GBCPF PROCESS WORK FIELDS
16032: *
16033: * PREPARE TO PROCESS VARIABLE BLOCKS
16034: *
16035: MOV HSHTB,WA POINT TO FIRST HASH SLOT POINTER
16036: *
16037: * LOOP THROUGH HASH SLOTS
16038: *
16039: GBC01 MOV WA,XL POINT TO NEXT SLOT
16040: ICA WA BUMP BUCKET POINTER
16041: MOV WA,GBCNM SAVE BUCKET POINTER
16042: EJC
16043: *
16044: * GBCOL (CONTINUED)
16045: *
16046: * LOOP THROUGH VARIABLES ON ONE HASH CHAIN
16047: *
16048: GBC02 MOV (XL),XR LOAD PTR TO NEXT VRBLK
16049: BZE XR,GBC03 JUMP IF END OF CHAIN
16050: MOV XR,XL ELSE COPY VRBLK POINTER
16051: ADD *VRVAL,XR POINT TO FIRST RELOC FLD
16052: ADD *VRNXT,XL POINT PAST LAST (AND TO LINK PTR)
16053: JSR GBCPF PROCESS RELOC FIELDS IN VRBLK
16054: BRN GBC02 LOOP BACK FOR NEXT BLOCK
16055: *
16056: * HERE AT END OF ONE HASH CHAIN
16057: *
16058: GBC03 MOV GBCNM,WA RESTORE BUCKET POINTER
16059: BNE WA,HSHTE,GBC01 LOOP BACK IF MORE BUCKETS TO GO
16060: EJC
16061: *
16062: * GBCOL (CONTINUED)
16063: *
16064: * NOW WE ARE READY TO START PASS TWO. REGISTERS ARE USED
16065: * AS FOLLOWS IN PASS TWO.
16066: *
16067: * (XR) SCANS THROUGH ALL BLOCKS
16068: * (WC) POINTER TO EVENTUAL LOCATION
16069: *
16070: * THE MOVE DESCRIPTION BLOCKS BUILT IN THIS PASS HAVE
16071: * THE FOLLOWING FORMAT.
16072: *
16073: * WORD 1 POINTER TO NEXT MOVE BLOCK,
16074: * ZERO IF END OF CHAIN OF BLOCKS
16075: *
16076: * WORD 2 LENGTH OF BLOCKS TO BE MOVED IN
16077: * BYTES. SET TO THE ADDRESS OF THE
16078: * FIRST BYTE WHILE ACTUALLY SCANNING
16079: * THE BLOCKS.
16080: *
16081: * THE FIRST ENTRY ON THIS CHAIN IS A SPECIAL ENTRY
16082: * CONSISTING OF THE TWO WORDS GBCNM AND GBCNS. AFTER
16083: * BUILDING THE CHAIN OF MOVE DESCRIPTORS, GBCNM POINTS TO
16084: * THE FIRST REAL MOVE BLOCK, AND GBCNS IS THE LENGTH OF
16085: * BLOCKS IN USE AT THE START OF STORAGE WHICH NEED NOT
16086: * BE MOVED SINCE THEY ARE IN THE CORRECT POSITION.
16087: *
16088: GBC04 MOV DNAMB,XR POINT TO FIRST BLOCK
16089: MOV XR,WC SET AS FIRST EVENTUAL LOCATION
16090: ADD GBSVB,WC ADD OFFSET FOR EVENTUAL MOVE UP
16091: ZER GBCNM CLEAR INITIAL FORWARD POINTER
16092: MOV =GBCNM,GBCLM INITIALIZE PTR TO LAST MOVE BLOCK
16093: MOV XR,GBCNS INITIALIZE FIRST ADDRESS
16094: *
16095: * LOOP THROUGH A SERIES OF BLOCKS IN USE
16096: *
16097: GBC05 BEQ XR,DNAMP,GBC07 JUMP IF END OF USED REGION
16098: MOV (XR),WA ELSE GET FIRST WORD
16099: BHI WA,=P$YYY,GBC06 SKIP IF NOT ENTRY PTR (IN USE)
16100: BHI WA,=B$AAA,GBC07 JUMP IF ENTRY POINTER (UNUSED)
16101: *
16102: * HERE FOR BLOCK IN USE, LOOP TO RELOCATE REFERENCES
16103: *
16104: GBC06 MOV WA,XL COPY POINTER
16105: MOV (XL),WA LOAD FORWARD POINTER
16106: MOV WC,(XL) RELOCATE REFERENCE
16107: BHI WA,=P$YYY,GBC06 LOOP BACK IF NOT END OF CHAIN
16108: BLO WA,=B$AAA,GBC06 LOOP BACK IF NOT END OF CHAIN
16109: EJC
16110: *
16111: * GBCOL (CONTINUED)
16112: *
16113: * AT END OF CHAIN, RESTORE FIRST WORD AND BUMP PAST
16114: *
16115: MOV WA,(XR) RESTORE FIRST WORD
16116: JSR BLKLN GET LENGTH OF THIS BLOCK
16117: ADD WA,XR BUMP ACTUAL POINTER
16118: ADD WA,WC BUMP EVENTUAL POINTER
16119: BRN GBC05 LOOP BACK FOR NEXT BLOCK
16120: *
16121: * HERE AT END OF A SERIES OF BLOCKS IN USE
16122: *
16123: GBC07 MOV XR,WA COPY POINTER PAST LAST BLOCK
16124: MOV GBCLM,XL POINT TO PREVIOUS MOVE BLOCK
16125: SUB 1(XL),WA SUBTRACT STARTING ADDRESS
16126: MOV WA,1(XL) STORE LENGTH OF BLOCK TO BE MOVED
16127: *
16128: * LOOP THROUGH A SERIES OF BLOCKS NOT IN USE
16129: *
16130: GBC08 BEQ XR,DNAMP,GBC10 JUMP IF END OF USED REGION
16131: MOV (XR),WA ELSE LOAD FIRST WORD OF NEXT BLOCK
16132: BHI WA,=P$YYY,GBC09 JUMP IF IN USE
16133: BLO WA,=B$AAA,GBC09 JUMP IF IN USE
16134: JSR BLKLN ELSE GET LENGTH OF NEXT BLOCK
16135: ADD WA,XR PUSH POINTER
16136: BRN GBC08 AND LOOP BACK
16137: *
16138: * HERE FOR A BLOCK IN USE AFTER PROCESSING A SERIES OF
16139: * BLOCKS WHICH WERE NOT IN USE, BUILD NEW MOVE BLOCK.
16140: *
16141: GBC09 SUB *NUM02,XR POINT 2 WORDS BEHIND FOR MOVE BLOCK
16142: MOV GBCLM,XL POINT TO PREVIOUS MOVE BLOCK
16143: MOV XR,(XL) SET FORWARD PTR IN PREVIOUS BLOCK
16144: ZER (XR) ZERO FORWARD PTR OF NEW BLOCK
16145: MOV XR,GBCLM REMEMBER ADDRESS OF THIS BLOCK
16146: MOV XR,XL COPY PTR TO MOVE BLOCK
16147: ADD *NUM02,XR POINT BACK TO BLOCK IN USE
16148: MOV XR,1(XL) STORE STARTING ADDRESS
16149: BRN GBC06 JUMP TO PROCESS BLOCK IN USE
16150: EJC
16151: *
16152: * GBCOL (CONTINUED)
16153: *
16154: * HERE FOR PASS THREE -- ACTUALLY MOVE THE BLOCKS DOWN
16155: *
16156: * (XL) POINTER TO OLD LOCATION
16157: * (XR) POINTER TO NEW LOCATION
16158: *
16159: GBC10 MOV DNAMB,XR POINT TO START OF STORAGE
16160: ADD GBCNS,XR BUMP PAST UNMOVED BLOCKS AT START
16161: *
16162: * LOOP THROUGH MOVE DESCRIPTORS
16163: *
16164: GBC11 MOV GBCNM,XL POINT TO NEXT MOVE BLOCK
16165: BZE XL,GBC12 JUMP IF END OF CHAIN
16166: MOV (XL)+,GBCNM MOVE POINTER DOWN CHAIN
16167: MOV (XL)+,WA GET LENGTH TO MOVE
16168: MVW PERFORM MOVE
16169: BRN GBC11 LOOP BACK
16170: *
16171: * NOW TEST FOR MOVE UP
16172: *
16173: GBC12 MOV XR,DNAMP SET NEXT AVAILABLE LOC PTR
16174: MOV GBSVB,WB RELOAD MOVE OFFSET
16175: BZE WB,GBC13 JUMP IF NO MOVE REQUIRED
16176: MOV XR,XL ELSE COPY OLD TOP OF CORE
16177: ADD WB,XR POINT TO NEW TOP OF CORE
16178: MOV XR,DNAMP SAVE NEW TOP OF CORE POINTER
16179: MOV XL,WA COPY OLD TOP
16180: SUB DNAMB,WA MINUS OLD BOTTOM = LENGTH
16181: ADD WB,DNAMB BUMP BOTTOM TO GET NEW VALUE
16182: MWB PERFORM MOVE (BACKWARDS)
16183: *
16184: * MERGE HERE TO EXIT
16185: *
16186: GBC13 MOV GBSVA,WA RESTORE WA
16187: SCP WC GET CODE POINTER
16188: ADD R$COD,WC MAKE ABSOLUTE AGAIN
16189: LCP WC AND REPLACE ABSOLUTE VALUE
16190: MOV GBSVC,WC RESTORE WC
16191: MOV (XS)+,XL RESTORE ENTRY XL
16192: ICV GBCNT INCREMENT COUNT OF COLLECTIONS
16193: ZER XR CLEAR GARBAGE VALUE IN XR
16194: ZER GBCFL NOTE EXIT FROM GBCOL
16195: EXI EXIT TO GBCOL CALLER
16196: *
16197: * GARBAGE COLLECTION NOT ALLOWED WHILST DUMPING
16198: *
16199: GBC14 ICV ERRFT FATAL ERROR
16200: ERB 250,INSUFFICIENT MEMORY TO COMPLETE DUMP
16201: ENP END PROCEDURE GBCOL
16202: EJC
16203: *
16204: * GBCPF -- PROCESS FIELDS FOR GARBAGE COLLECTOR
16205: *
16206: * THIS PROCEDURE IS USED BY THE GARBAGE COLLECTOR TO
16207: * PROCESS FIELDS IN PASS ONE. SEE GBCOL FOR FULL DETAILS.
16208: *
16209: * (XR) PTR TO FIRST LOCATION TO PROCESS
16210: * (XL) PTR PAST LAST LOCATION TO PROCESS
16211: * JSR GBCPF CALL TO PROCESS FIELDS
16212: * (XR,WA,WB,WC,IA) DESTROYED
16213: *
16214: * NOTE THAT ALTHOUGH THIS PROCEDURE USES A RECURSIVE
16215: * APPROACH, IT CONTROLS ITS OWN STACK AND IS NOT RECURSIVE.
16216: *
16217: GBCPF PRC E,0 ENTRY POINT
16218: ZER -(XS) SET ZERO TO MARK BOTTOM OF STACK
16219: MOV XL,-(XS) SAVE END POINTER
16220: *
16221: * MERGE HERE TO GO DOWN A LEVEL AND START A NEW LOOP
16222: *
16223: * 1(XS) NEXT LVL FIELD PTR (0 AT OUTER LVL)
16224: * 0(XS) PTR PAST LAST FIELD TO PROCESS
16225: * (XR) PTR TO FIRST FIELD TO PROCESS
16226: *
16227: * LOOP TO PROCESS SUCCESSIVE FIELDS
16228: *
16229: GPF01 MOV (XR),XL LOAD FIELD CONTENTS
16230: MOV XR,WC SAVE FIELD POINTER
16231: BLT XL,DNAMB,GPF02 JUMP IF NOT PTR INTO DYNAMIC AREA
16232: BGE XL,DNAMP,GPF02 JUMP IF NOT PTR INTO DYNAMIC AREA
16233: *
16234: * HERE WE HAVE A PTR TO A BLOCK IN THE DYNAMIC AREA.
16235: * LINK THIS FIELD ONTO THE REFERENCE BACKCHAIN.
16236: *
16237: MOV (XL),WA LOAD PTR TO CHAIN (OR ENTRY PTR)
16238: MOV XR,(XL) SET THIS FIELD AS NEW HEAD OF CHAIN
16239: MOV WA,(XR) SET FORWARD POINTER
16240: *
16241: * NOW SEE IF THIS BLOCK HAS BEEN PROCESSED BEFORE
16242: *
16243: BHI WA,=P$YYY,GPF02 JUMP IF ALREADY PROCESSED
16244: BHI WA,=B$AAA,GPF03 JUMP IF NOT ALREADY PROCESSED
16245: *
16246: * HERE TO MOVE TO NEXT FIELD
16247: *
16248: GPF02 MOV WC,XR RESTORE FIELD POINTER
16249: ICA XR BUMP TO NEXT FIELD
16250: BNE XR,(XS),GPF01 LOOP BACK IF MORE TO GO
16251: EJC
16252: *
16253: * GBCPF (CONTINUED)
16254: *
16255: * HERE WE POP UP A LEVEL AFTER FINISHING A BLOCK
16256: *
16257: MOV (XS)+,XL RESTORE POINTER PAST END
16258: MOV (XS)+,WC RESTORE BLOCK POINTER
16259: BNZ WC,GPF02 CONTINUE LOOP UNLESS OUTER LEVL
16260: EXI RETURN TO CALLER IF OUTER LEVEL
16261: *
16262: * HERE TO PROCESS AN ACTIVE BLOCK WHICH HAS NOT BEEN DONE
16263: *
16264: GPF03 MOV XL,XR COPY BLOCK POINTER
16265: MOV WA,XL COPY FIRST WORD OF BLOCK
16266: LEI XL LOAD ENTRY POINT ID (BL$XX)
16267: *
16268: * BLOCK TYPE SWITCH. NOTE THAT BLOCKS WITH NO RELOCATABLE
16269: * FIELDS JUST RETURN TO GPF02 HERE TO CONTINE TO NEXT FLD.
16270: *
16271: BSW XL,BL$$$ SWITCH ON BLOCK TYPE
16272: IFF BL$AR,GPF06 ARBLK
16273: IFF BL$BC,GPF18 BCBLK
16274: IFF BL$BF,GPF02 BFBLK
16275: IFF BL$CC,GPF07 CCBLK
16276: IFF BL$CD,GPF08 CDBLK
16277: IFF BL$CM,GPF04 CMBLK
16278: IFF BL$DF,GPF02 DFBLK
16279: IFF BL$EV,GPF10 EVBLK
16280: IFF BL$EX,GPF17 EXBLK
16281: IFF BL$FF,GPF11 FFBLK
16282: IFF BL$NM,GPF10 NMBLK
16283: IFF BL$P0,GPF10 P0BLK
16284: IFF BL$P1,GPF12 P1BLK
16285: IFF BL$P2,GPF12 P2BLK
16286: IFF BL$PD,GPF13 PDBLK
16287: IFF BL$PF,GPF14 PFBLK
16288: IFF BL$TB,GPF08 TBBLK
16289: IFF BL$TE,GPF15 TEBLK
16290: IFF BL$TR,GPF16 TRBLK
16291: IFF BL$VC,GPF08 VCBLK
16292: IFF BL$XR,GPF09 XRBLK
16293: IFF BL$CT,GPF02 CTBLK
16294: IFF BL$EF,GPF02 EFBLK
16295: IFF BL$IC,GPF02 ICBLK
16296: IFF BL$KV,GPF02 KVBLK
16297: IFF BL$RC,GPF02 RCBLK
16298: IFF BL$SC,GPF02 SCBLK
16299: IFF BL$SE,GPF02 SEBLK
16300: IFF BL$XN,GPF02 XNBLK
16301: ESW END OF JUMP TABLE
16302: EJC
16303: *
16304: * GBCPF (CONTINUED)
16305: *
16306: * CMBLK
16307: *
16308: GPF04 MOV CMLEN(XR),WA LOAD LENGTH
16309: MOV *CMTYP,WB SET OFFSET
16310: *
16311: * HERE TO PUSH DOWN TO NEW LEVEL
16312: *
16313: * (WC) FIELD PTR AT PREVIOUS LEVEL
16314: * (XR) PTR TO NEW BLOCK
16315: * (WA) LENGTH (RELOC FLDS + FLDS AT START)
16316: * (WB) OFFSET TO FIRST RELOC FIELD
16317: *
16318: GPF05 ADD XR,WA POINT PAST LAST RELOC FIELD
16319: ADD WB,XR POINT TO FIRST RELOC FIELD
16320: MOV WC,-(XS) STACK OLD FIELD POINTER
16321: MOV WA,-(XS) STACK NEW LIMIT POINTER
16322: CHK CHECK FOR STACK OVERFLOW
16323: BRN GPF01 IF OK, BACK TO PROCESS
16324: *
16325: * ARBLK
16326: *
16327: GPF06 MOV ARLEN(XR),WA LOAD LENGTH
16328: MOV AROFS(XR),WB SET OFFSET TO 1ST RELOC FLD (ARPRO)
16329: BRN GPF05 ALL SET
16330: *
16331: * CCBLK
16332: *
16333: GPF07 MOV CCUSE(XR),WA SET LENGTH IN USE
16334: MOV *CCUSE,WB 1ST WORD (MAKE SURE AT LEAST ONE)
16335: BRN GPF05 ALL SET
16336: EJC
16337: *
16338: * GBCPF (CONTINUED)
16339: *
16340: * CDBLK, TBBLK, VCBLK
16341: *
16342: GPF08 MOV OFFS2(XR),WA LOAD LENGTH
16343: MOV *OFFS3,WB SET OFFSET
16344: BRN GPF05 JUMP BACK
16345: *
16346: * XRBLK
16347: *
16348: GPF09 MOV XRLEN(XR),WA LOAD LENGTH
16349: MOV *XRPTR,WB SET OFFSET
16350: BRN GPF05 JUMP BACK
16351: *
16352: * EVBLK, NMBLK, P0BLK
16353: *
16354: GPF10 MOV *OFFS2,WA POINT PAST SECOND FIELD
16355: MOV *OFFS1,WB OFFSET IS ONE (ONLY RELOC FLD IS 2)
16356: BRN GPF05 ALL SET
16357: *
16358: * FFBLK
16359: *
16360: GPF11 MOV *FFOFS,WA SET LENGTH
16361: MOV *FFNXT,WB SET OFFSET
16362: BRN GPF05 ALL SET
16363: *
16364: * P1BLK, P2BLK
16365: *
16366: GPF12 MOV *PARM2,WA LENGTH (PARM2 IS NON-RELOCATABLE)
16367: MOV *PTHEN,WB SET OFFSET
16368: BRN GPF05 ALL SET
16369: EJC
16370: *
16371: * GBCPF (CONTINUED)
16372: *
16373: * PDBLK
16374: *
16375: GPF13 MOV PDDFP(XR),XL LOAD PTR TO DFBLK
16376: MOV DFPDL(XL),WA GET PDBLK LENGTH
16377: MOV *PDFLD,WB SET OFFSET
16378: BRN GPF05 ALL SET
16379: *
16380: * PFBLK
16381: *
16382: GPF14 MOV *PFARG,WA LENGTH PAST LAST RELOC
16383: MOV *PFCOD,WB OFFSET TO FIRST RELOC
16384: BRN GPF05 ALL SET
16385: *
16386: * TEBLK
16387: *
16388: GPF15 MOV *TESI$,WA SET LENGTH
16389: MOV *TESUB,WB AND OFFSET
16390: BRN GPF05 ALL SET
16391: *
16392: * TRBLK
16393: *
16394: GPF16 MOV *TRSI$,WA SET LENGTH
16395: MOV *TRVAL,WB AND OFFSET
16396: BRN GPF05 ALL SET
16397: *
16398: * EXBLK
16399: *
16400: GPF17 MOV EXLEN(XR),WA LOAD LENGTH
16401: MOV *EXFLC,WB SET OFFSET
16402: BRN GPF05 JUMP BACK
16403: *
16404: * BCBLK
16405: *
16406: GPF18 MOV *BCSI$,WA SET LENGTH
16407: MOV *BCBUF,WB AND OFFSET
16408: BRN GPF05 ALL SET
16409: ENP END PROCEDURE GBCPF
16410: EJC
16411: *
16412: * GTARR -- GET ARRAY
16413: *
16414: * GTARR IS PASSED AN OBJECT AND RETURNS AN ARRAY IF POSSIBL
16415: *
16416: * (XR) VALUE TO BE CONVERTED
16417: * JSR GTARR CALL TO GET ARRAY
16418: * PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE
16419: * (XR) RESULTING ARRAY
16420: * (XL,WA,WB,WC) DESTROYED
16421: *
16422: GTARR PRC E,1 ENTRY POINT
16423: MOV (XR),WA LOAD TYPE WORD
16424: BEQ WA,=B$ART,GTAR8 EXIT IF ALREADY AN ARRAY
16425: BEQ WA,=B$VCT,GTAR8 EXIT IF ALREADY AN ARRAY
16426: BNE WA,=B$TBT,GTA9A ELSE FAIL IF NOT A TABLE (SGD02)
16427: *
16428: * HERE WE CONVERT A TABLE TO AN ARRAY
16429: *
16430: MOV XR,-(XS) REPLACE TBBLK POINTER ON STACK
16431: ZER XR SIGNAL FIRST PASS
16432: ZER WB ZERO NON-NULL ELEMENT COUNT
16433: *
16434: * THE FOLLOWING CODE IS EXECUTED TWICE. ON THE FIRST PASS,
16435: * SIGNALLED BY XR=0, THE NUMBER OF NON-NULL ELEMENTS IN
16436: * THE TABLE IS COUNTED IN WB. IN THE SECOND PASS, WHERE
16437: * XR IS A POINTER INTO THE ARBLK, THE NAME AND VALUE ARE
16438: * ENTERED INTO THE CURRENT ARBLK LOCATION.
16439: *
16440: GTAR1 MOV (XS),XL POINT TO TABLE
16441: ADD TBLEN(XL),XL POINT PAST LAST BUCKET
16442: SUB *TBBUK,XL SET FIRST BUCKET OFFSET
16443: MOV XL,WA COPY ADJUSTED POINTER
16444: *
16445: * LOOP THROUGH BUCKETS IN TABLE BLOCK
16446: * NEXT THREE LINES OF CODE RELY ON TENXT HAVING A VALUE
16447: * 1 LESS THAN TBBUK.
16448: *
16449: GTAR2 MOV WA,XL COPY BUCKET POINTER
16450: DCA WA DECREMENT BUCKET POINTER
16451: *
16452: * LOOP THROUGH TEBLKS ON ONE BUCKET CHAIN
16453: *
16454: GTAR3 MOV TENXT(XL),XL POINT TO NEXT TEBLK
16455: BEQ XL,(XS),GTAR6 JUMP IF CHAIN END (TBBLK PTR)
16456: MOV XL,CNVTP ELSE SAVE TEBLK POINTER
16457: *
16458: * LOOP TO FIND VALUE DOWN TRBLK CHAIN
16459: *
16460: GTAR4 MOV TEVAL(XL),XL LOAD VALUE
16461: BEQ (XL),=B$TRT,GTAR4 LOOP TILL VALUE FOUND
16462: MOV XL,WC COPY VALUE
16463: MOV CNVTP,XL RESTORE TEBLK POINTER
16464: EJC
16465: *
16466: * GTARR (CONTINUED)
16467: *
16468: * NOW CHECK FOR NULL AND TEST CASES
16469: *
16470: BEQ WC,=NULLS,GTAR3 LOOP BACK TO IGNORE NULL VALUE
16471: BNZ XR,GTAR5 JUMP IF SECOND PASS
16472: ICV WB FOR THE FIRST PASS, BUMP COUNT
16473: BRN GTAR3 AND LOOP BACK FOR NEXT TEBLK
16474: *
16475: * HERE IN SECOND PASS
16476: *
16477: GTAR5 MOV TESUB(XL),(XR)+ STORE SUBSCRIPT NAME
16478: MOV WC,(XR)+ STORE VALUE IN ARBLK
16479: BRN GTAR3 LOOP BACK FOR NEXT TEBLK
16480: *
16481: * HERE AFTER SCANNING TEBLKS ON ONE CHAIN
16482: *
16483: GTAR6 BNE WA,(XS),GTAR2 LOOP BACK IF MORE BUCKETS TO GO
16484: BNZ XR,GTAR7 ELSE JUMP IF SECOND PASS
16485: *
16486: * HERE AFTER COUNTING NON-NULL ELEMENTS
16487: *
16488: BZE WB,GTAR9 FAIL IF NO NON-NULL ELEMENTS
16489: MOV WB,WA ELSE COPY COUNT
16490: ADD WB,WA DOUBLE (TWO WORDS/ELEMENT)
16491: ADD =ARVL2,WA ADD SPACE FOR STANDARD FIELDS
16492: WTB WA CONVERT LENGTH TO BYTES
16493: BGE WA,MXLEN,GTAR9 FAIL IF TOO LONG FOR ARRAY
16494: JSR ALLOC ELSE ALLOCATE SPACE FOR ARBLK
16495: MOV =B$ART,(XR) STORE TYPE WORD
16496: ZER IDVAL(XR) ZERO ID FOR THE MOMENT
16497: MOV WA,ARLEN(XR) STORE LENGTH
16498: MOV =NUM02,ARNDM(XR) SET DIMENSIONS = 2
16499: LDI INTV1 GET INTEGER ONE
16500: STI ARLBD(XR) STORE AS LBD 1
16501: STI ARLB2(XR) STORE AS LBD 2
16502: LDI INTV2 LOAD INTEGER TWO
16503: STI ARDM2(XR) STORE AS DIM 2
16504: MTI WB GET ELEMENT COUNT AS INTEGER
16505: STI ARDIM(XR) STORE AS DIM 1
16506: ZER ARPR2(XR) ZERO PROTOTYPE FIELD FOR NOW
16507: MOV *ARPR2,AROFS(XR) SET OFFSET FIELD (SIGNAL PASS 2)
16508: MOV XR,WB SAVE ARBLK POINTER
16509: ADD *ARVL2,XR POINT TO FIRST ELEMENT LOCATION
16510: BRN GTAR1 JUMP BACK TO FILL IN ELEMENTS
16511: EJC
16512: *
16513: * GTARR (CONTINUED)
16514: *
16515: * HERE AFTER FILLING IN ELEMENT VALUES
16516: *
16517: GTAR7 MOV WB,XR RESTORE ARBLK POINTER
16518: MOV WB,(XS) STORE AS RESULT
16519: *
16520: * NOW WE NEED THE ARRAY PROTOTYPE WHICH IS OF THE FORM NN,2
16521: * THIS IS OBTAINED BY BUILDING THE STRING FOR NN02 AND
16522: * CHANGING THE ZERO TO A COMMA BEFORE STORING IT.
16523: *
16524: LDI ARDIM(XR) GET NUMBER OF ELEMENTS (NN)
16525: MLI INTVH MULTIPLY BY 100
16526: ADI INTV2 ADD 2 (NN02)
16527: JSR ICBLD BUILD INTEGER
16528: MOV XR,-(XS) STORE PTR FOR GTSTG
16529: JSR GTSTG CONVERT TO STRING
16530: PPM CONVERT FAIL IS IMPOSSIBLE
16531: MOV XR,XL COPY STRING POINTER
16532: MOV (XS)+,XR RELOAD ARBLK POINTER
16533: MOV XL,ARPR2(XR) STORE PROTOTYPE PTR (NN02)
16534: SUB =NUM02,WA ADJUST LENGTH TO POINT TO ZERO
16535: PSC XL,WA POINT TO ZERO
16536: MOV =CH$CM,WB LOAD A COMMA
16537: SCH WB,(XL) STORE A COMMA OVER THE ZERO
16538: CSC XL COMPLETE STORE CHARACTERS
16539: *
16540: * NORMAL RETURN
16541: *
16542: GTAR8 EXI RETURN TO CALLER
16543: *
16544: * NON-CONVERSION RETURN
16545: *
16546: GTAR9 MOV (XS)+,XR RESTORE STACK FOR CONV ERR (SGD02)
16547: *
16548: * MERGE TO TAKE CONVERT ERROR WHEN STACK ADJUSTED OK
16549: *
16550: GTA9A EXI 1 RETURN
16551: ENP PROCEDURE GTARR
16552: EJC
16553: *
16554: * GTCOD -- CONVERT TO CODE
16555: *
16556: * (XR) OBJECT TO BE CONVERTED
16557: * JSR GTCOD CALL TO CONVERT TO CODE
16558: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
16559: * (XR) POINTER TO RESULTING CDBLK
16560: * (XL,WA,WB,WC,RA) DESTROYED
16561: *
16562: * IF A SPITBOL ERROR OCCURS DURING COMPILATION OR PRE-
16563: * EVALUATION, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL
16564: * WITHOUT RETURNING TO THIS ROUTINE.
16565: *
16566: GTCOD PRC E,1 ENTRY POINT
16567: BEQ (XR),=B$CDS,GTCD1 JUMP IF ALREADY CODE
16568: BEQ (XR),=B$CDC,GTCD1 JUMP IF ALREADY CODE
16569: *
16570: * HERE WE MUST GENERATE A CDBLK BY COMPILATION
16571: *
16572: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG
16573: JSR GTSTG CONVERT ARGUMENT TO STRING
16574: PPM GTCD2 JUMP IF NON-CONVERTIBLE
16575: MOV FLPTR,GTCEF SAVE FAIL PTR IN CASE OF ERROR
16576: MOV R$COD,R$GTC ALSO SAVE CODE PTR
16577: MOV XR,R$CIM ELSE SET IMAGE POINTER
16578: MOV WA,SCNIL SET IMAGE LENGTH
16579: ZER SCNPT SET SCAN POINTER
16580: MOV =STGXC,STAGE SET STAGE FOR EXECUTE COMPILE
16581: MOV CMPSN,LSTSN IN CASE LISTR CALLED
16582: JSR CMPIL COMPILE STRING
16583: MOV =STGXT,STAGE RESET STAGE FOR EXECUTE TIME
16584: ZER R$CIM CLEAR IMAGE
16585: *
16586: * MERGE HERE IF NO CONVERT REQUIRED
16587: *
16588: GTCD1 EXI GIVE NORMAL GTCOD RETURN
16589: *
16590: * HERE IF UNCONVERTIBLE
16591: *
16592: GTCD2 EXI 1 GIVE ERROR RETURN
16593: ENP END PROCEDURE GTCOD
16594: EJC
16595: *
16596: * GTEXP -- CONVERT TO EXPRESSION
16597: *
16598: * (XR) INPUT VALUE TO BE CONVERTED
16599: * JSR GTEXP CALL TO CONVERT TO EXPRESSION
16600: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
16601: * (XR) POINTER TO RESULT EXBLK OR SEBLK
16602: * (XL,WA,WB,WC,RA) DESTROYED
16603: *
16604: * IF A SPITBOL ERROR OCCURS DURING COMPILATION OR PRE-
16605: * EVALUATION, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL
16606: * WITHOUT RETURNING TO THIS ROUTINE.
16607: *
16608: GTEXP PRC E,1 ENTRY POINT
16609: BLO (XR),=B$E$$,GTEX1 JUMP IF ALREADY AN EXPRESSION
16610: MOV XR,-(XS) STORE ARGUMENT FOR GTSTG
16611: JSR GTSTG CONVERT ARGUMENT TO STRING
16612: PPM GTEX2 JUMP IF UNCONVERTIBLE
16613: *
16614: * CHECK THE LAST CHARACTER OF THE STRING FOR COLON OR
16615: * SEMICOLON. THESE CHARACTERS CAN LEGITIMATELY END AN
16616: * EXPRESSION IN OPEN CODE, SO EXPAN WILL NOT DETECT THEM
16617: * AS ERRORS, BUT THEY ARE INVALID AS TERMINATORS FOR A
16618: * STRING THAT IS BEING CONVERTED TO EXPRESSION FORM.
16619: *
16620: MOV XR,XL COPY INPUT STRING POINTER (REG06)
16621: PLC XL,WA POINT ONE PAST THE STRING END (REG06)
16622: LCH XL,-(XL) FETCH THE LAST CHARACTER (REG06)
16623: BEQ XL,=CH$CL,GTEX2 ERROR IF IT IS A SEMICOLON (REG06)
16624: BEQ XL,=CH$SM,GTEX2 OR IF IT IS A COLON (REG06)
16625: *
16626: * HERE WE CONVERT A STRING BY COMPILATION
16627: *
16628: MOV XR,R$CIM SET INPUT IMAGE POINTER
16629: ZER SCNPT SET SCAN POINTER
16630: MOV WA,SCNIL SET INPUT IMAGE LENGTH
16631: ZER WB SET CODE FOR NORMAL SCAN
16632: MOV FLPTR,GTCEF SAVE FAIL PTR IN CASE OF ERROR
16633: MOV R$COD,R$GTC ALSO SAVE CODE PTR
16634: MOV =STGEV,STAGE ADJUST STAGE FOR COMPILE
16635: MOV =T$UOK,SCNTP INDICATE UNARY OPERATOR ACCEPTABLE
16636: JSR EXPAN BUILD TREE FOR EXPRESSION
16637: ZER SCNRS RESET RESCAN FLAG
16638: BNE SCNPT,SCNIL,GTEX2 ERROR IF NOT END OF IMAGE
16639: ZER WB SET OK VALUE FOR CDGEX CALL
16640: MOV XR,XL COPY TREE POINTER
16641: JSR CDGEX BUILD EXPRESSION BLOCK
16642: ZER R$CIM CLEAR POINTER
16643: MOV =STGXT,STAGE RESTORE STAGE FOR EXECUTE TIME
16644: *
16645: * MERGE HERE IF NO CONVERSION REQUIRED
16646: *
16647: GTEX1 EXI RETURN TO GTEXP CALLER
16648: *
16649: * HERE IF UNCONVERTIBLE
16650: *
16651: GTEX2 EXI 1 TAKE ERROR EXIT
16652: ENP END PROCEDURE GTEXP
16653: EJC
16654: *
16655: * GTINT -- GET INTEGER VALUE
16656: *
16657: * GTINT IS PASSED AN OBJECT AND RETURNS AN INTEGER AFTER
16658: * PERFORMING ANY NECESSARY CONVERSIONS.
16659: *
16660: * (XR) VALUE TO BE CONVERTED
16661: * JSR GTINT CALL TO CONVERT TO INTEGER
16662: * PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE
16663: * (XR) RESULTING INTEGER
16664: * (WC,RA) DESTROYED
16665: * (WA,WB) DESTROYED (ONLY ON CONVERSION ERR)
16666: * (XR) UNCHANGED (ON CONVERT ERROR)
16667: *
16668: GTINT PRC E,1 ENTRY POINT
16669: BEQ (XR),=B$ICL,GTIN2 JUMP IF ALREADY AN INTEGER
16670: MOV WA,GTINA ELSE SAVE WA
16671: MOV WB,GTINB SAVE WB
16672: JSR GTNUM CONVERT TO NUMERIC
16673: PPM GTIN3 JUMP IF UNCONVERTIBLE
16674: BEQ WA,=B$ICL,GTIN1 JUMP IF INTEGER
16675: *
16676: * HERE WE CONVERT A REAL TO INTEGER
16677: *
16678: LDR RCVAL(XR) LOAD REAL VALUE
16679: RTI GTIN3 CONVERT TO INTEGER (ERR IF OVFLOW)
16680: JSR ICBLD IF OK BUILD ICBLK
16681: *
16682: * HERE AFTER SUCCESSFUL CONVERSION TO INTEGER
16683: *
16684: GTIN1 MOV GTINA,WA RESTORE WA
16685: MOV GTINB,WB RESTORE WB
16686: *
16687: * COMMON EXIT POINT
16688: *
16689: GTIN2 EXI RETURN TO GTINT CALLER
16690: *
16691: * HERE ON CONVERSION ERROR
16692: *
16693: GTIN3 EXI 1 TAKE CONVERT ERROR EXIT
16694: ENP END PROCEDURE GTINT
16695: EJC
16696: *
16697: * GTNUM -- GET NUMERIC VALUE
16698: *
16699: * GTNUM IS GIVEN AN OBJECT AND RETURNS EITHER AN INTEGER
16700: * OR A REAL, PERFORMING ANY NECESSARY CONVERSIONS.
16701: *
16702: * (XR) OBJECT TO BE CONVERTED
16703: * JSR GTNUM CALL TO CONVERT TO NUMERIC
16704: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
16705: * (XR) POINTER TO RESULT (INT OR REAL)
16706: * (WA) FIRST WORD OF RESULT BLOCK
16707: * (WB,WC,RA) DESTROYED
16708: * (XR) UNCHANGED (ON CONVERT ERROR)
16709: *
16710: GTNUM PRC E,1 ENTRY POINT
16711: MOV (XR),WA LOAD FIRST WORD OF BLOCK
16712: BEQ WA,=B$ICL,GTN34 JUMP IF INTEGER (NO CONVERSION)
16713: BEQ WA,=B$RCL,GTN34 JUMP IF REAL (NO CONVERSION)
16714: *
16715: * AT THIS POINT THE ONLY POSSIBILITY IS TO CONVERT A STRING
16716: * TO AN INTEGER OR REAL AS APPROPRIATE.
16717: *
16718: MOV XR,-(XS) STACK ARGUMENT IN CASE CONVERT ERR
16719: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG
16720: JSR GTSTG CONVERT ARGUMENT TO STRING
16721: PPM GTN36 JUMP IF UNCONVERTIBLE
16722: *
16723: * INITIALIZE NUMERIC CONVERSION
16724: *
16725: LDI INTV0 INITIALIZE INTEGER RESULT TO ZERO
16726: BZE WA,GTN32 JUMP TO EXIT WITH ZERO IF NULL
16727: LCT WA,WA SET BCT COUNTER FOR FOLLOWING LOOPS
16728: ZER GTNNF TENTATIVELY INDICATE RESULT +
16729: STI GTNEX INITIALISE EXPONENT TO ZERO
16730: ZER GTNSC ZERO SCALE IN CASE REAL
16731: ZER GTNDF RESET FLAG FOR DEC POINT FOUND
16732: ZER GTNRD RESET FLAG FOR DIGITS FOUND
16733: LDR REAV0 ZERO REAL ACCUM IN CASE REAL
16734: PLC XR POINT TO ARGUMENT CHARACTERS
16735: *
16736: * MERGE BACK HERE AFTER IGNORING LEADING BLANK
16737: *
16738: GTN01 LCH WB,(XR)+ LOAD FIRST CHARACTER
16739: BLT WB,=CH$D0,GTN02 JUMP IF NOT DIGIT
16740: BLE WB,=CH$D9,GTN06 JUMP IF FIRST CHAR IS A DIGIT
16741: EJC
16742: *
16743: * GTNUM (CONTINUED)
16744: *
16745: * HERE IF FIRST DIGIT IS NON-DIGIT
16746: *
16747: GTN02 BNE WB,=CH$BL,GTN03 JUMP IF NON-BLANK
16748: GTNA2 BCT WA,GTN01 ELSE DECR COUNT AND LOOP BACK
16749: BRN GTN07 JUMP TO RETURN ZERO IF ALL BLANKS
16750: *
16751: * HERE FOR FIRST CHARACTER NON-BLANK, NON-DIGIT
16752: *
16753: GTN03 BEQ WB,=CH$PL,GTN04 JUMP IF PLUS SIGN
16754: BEQ WB,=CH$HT,GTNA2 HORIZONTAL TAB EQUIV TO BLANK
16755: BNE WB,=CH$MN,GTN12 JUMP IF NOT MINUS (MAY BE REAL)
16756: MNZ GTNNF IF MINUS SIGN, SET NEGATIVE FLAG
16757: *
16758: * MERGE HERE AFTER PROCESSING SIGN
16759: *
16760: GTN04 BCT WA,GTN05 JUMP IF CHARS LEFT
16761: BRN GTN36 ELSE ERROR
16762: *
16763: * LOOP TO FETCH CHARACTERS OF AN INTEGER
16764: *
16765: GTN05 LCH WB,(XR)+ LOAD NEXT CHARACTER
16766: BLT WB,=CH$D0,GTN08 JUMP IF NOT A DIGIT
16767: BGT WB,=CH$D9,GTN08 JUMP IF NOT A DIGIT
16768: *
16769: * MERGE HERE FOR FIRST DIGIT
16770: *
16771: GTN06 STI GTNSI SAVE CURRENT VALUE
16772: CVM GTN35 CURRENT*10-(NEW DIG) JUMP IF OVFLOW
16773: MNZ GTNRD SET DIGIT READ FLAG
16774: BCT WA,GTN05 ELSE LOOP BACK IF MORE CHARS
16775: *
16776: * HERE TO EXIT WITH CONVERTED INTEGER VALUE
16777: *
16778: GTN07 BNZ GTNNF,GTN32 JUMP IF NEGATIVE (ALL SET)
16779: NGI ELSE NEGATE
16780: INO GTN32 JUMP IF NO OVERFLOW
16781: BRN GTN36 ELSE SIGNAL ERROR
16782: EJC
16783: *
16784: * GTNUM (CONTINUED)
16785: *
16786: * HERE FOR A NON-DIGIT CHARACTER WHILE ATTEMPTING TO
16787: * CONVERT AN INTEGER, CHECK FOR TRAILING BLANKS OR REAL.
16788: *
16789: GTN08 BEQ WB,=CH$BL,GTNA9 JUMP IF A BLANK
16790: BEQ WB,=CH$HT,GTNA9 JUMP IF HORIZONTAL TAB
16791: ITR ELSE CONVERT INTEGER TO REAL
16792: NGR NEGATE TO GET POSITIVE VALUE
16793: BRN GTN12 JUMP TO TRY FOR REAL
16794: *
16795: * HERE WE SCAN OUT BLANKS TO END OF STRING
16796: *
16797: GTN09 LCH WB,(XR)+ GET NEXT CHAR
16798: BEQ WB,=CH$HT,GTNA9 JUMP IF HORIZONTAL TAB
16799: BNE WB,=CH$BL,GTN36 ERROR IF NON-BLANK
16800: GTNA9 BCT WA,GTN09 LOOP BACK IF MORE CHARS TO CHECK
16801: BRN GTN07 RETURN INTEGER IF ALL BLANKS
16802: *
16803: * LOOP TO COLLECT MANTISSA OF REAL
16804: *
16805: GTN10 LCH WB,(XR)+ LOAD NEXT CHARACTER
16806: BLT WB,=CH$D0,GTN12 JUMP IF NON-NUMERIC
16807: BGT WB,=CH$D9,GTN12 JUMP IF NON-NUMERIC
16808: *
16809: * MERGE HERE TO COLLECT FIRST REAL DIGIT
16810: *
16811: GTN11 SUB =CH$D0,WB CONVERT DIGIT TO NUMBER
16812: MLR REAVT MULTIPLY REAL BY 10.0
16813: ROV GTN36 CONVERT ERROR IF OVERFLOW
16814: STR GTNSR SAVE RESULT
16815: MTI WB GET NEW DIGIT AS INTEGER
16816: ITR CONVERT NEW DIGIT TO REAL
16817: ADR GTNSR ADD TO GET NEW TOTAL
16818: ADD GTNDF,GTNSC INCREMENT SCALE IF AFTER DEC POINT
16819: MNZ GTNRD SET DIGIT FOUND FLAG
16820: BCT WA,GTN10 LOOP BACK IF MORE CHARS
16821: BRN GTN22 ELSE JUMP TO SCALE
16822: EJC
16823: *
16824: * GTNUM (CONTINUED)
16825: *
16826: * HERE IF NON-DIGIT FOUND WHILE COLLECTING A REAL
16827: *
16828: GTN12 BNE WB,=CH$DT,GTN13 JUMP IF NOT DEC POINT
16829: BNZ GTNDF,GTN36 IF DEC POINT, ERROR IF ONE ALREADY
16830: MOV =NUM01,GTNDF ELSE SET FLAG FOR DEC POINT
16831: BCT WA,GTN10 LOOP BACK IF MORE CHARS
16832: BRN GTN22 ELSE JUMP TO SCALE
16833: *
16834: * HERE IF NOT DECIMAL POINT
16835: *
16836: GTN13 BEQ WB,=CH$LE,GTN15 JUMP IF E FOR EXPONENT
16837: BEQ WB,=CH$LD,GTN15 JUMP IF D FOR EXPONENT
16838: BEQ WB,=CH$$E,GTN15 JUMP IF E FOR EXPONENT
16839: BEQ WB,=CH$$D,GTN15 JUMP IF D FOR EXPONENT
16840: *
16841: * HERE CHECK FOR TRAILING BLANKS
16842: *
16843: GTN14 BEQ WB,=CH$BL,GTNB4 JUMP IF BLANK
16844: BEQ WB,=CH$HT,GTNB4 JUMP IF HORIZONTAL TAB
16845: BRN GTN36 ERROR IF NON-BLANK
16846: *
16847: GTNB4 LCH WB,(XR)+ GET NEXT CHARACTER
16848: BCT WA,GTN14 LOOP BACK TO CHECK IF MORE
16849: BRN GTN22 ELSE JUMP TO SCALE
16850: *
16851: * HERE TO READ AND PROCESS AN EXPONENT
16852: *
16853: GTN15 ZER GTNES SET EXPONENT SIGN POSITIVE
16854: LDI INTV0 INITIALIZE EXPONENT TO ZERO
16855: MNZ GTNDF RESET NO DEC POINT INDICATION
16856: BCT WA,GTN16 JUMP SKIPPING PAST E OR D
16857: BRN GTN36 ERROR IF NULL EXPONENT
16858: *
16859: * CHECK FOR EXPONENT SIGN
16860: *
16861: GTN16 LCH WB,(XR)+ LOAD FIRST EXPONENT CHARACTER
16862: BEQ WB,=CH$PL,GTN17 JUMP IF PLUS SIGN
16863: BNE WB,=CH$MN,GTN19 ELSE JUMP IF NOT MINUS SIGN
16864: MNZ GTNES SET SIGN NEGATIVE IF MINUS SIGN
16865: *
16866: * MERGE HERE AFTER PROCESSING EXPONENT SIGN
16867: *
16868: GTN17 BCT WA,GTN18 JUMP IF CHARS LEFT
16869: BRN GTN36 ELSE ERROR
16870: *
16871: * LOOP TO CONVERT EXPONENT DIGITS
16872: *
16873: GTN18 LCH WB,(XR)+ LOAD NEXT CHARACTER
16874: EJC
16875: *
16876: * GTNUM (CONTINUED)
16877: *
16878: * MERGE HERE FOR FIRST EXPONENT DIGIT
16879: *
16880: GTN19 BLT WB,=CH$D0,GTN20 JUMP IF NOT DIGIT
16881: BGT WB,=CH$D9,GTN20 JUMP IF NOT DIGIT
16882: CVM GTN36 ELSE CURRENT*10, SUBTRACT NEW DIGIT
16883: BCT WA,GTN18 LOOP BACK IF MORE CHARS
16884: BRN GTN21 JUMP IF EXPONENT FIELD IS EXHAUSTED
16885: *
16886: * HERE TO CHECK FOR TRAILING BLANKS AFTER EXPONENT
16887: *
16888: GTN20 BEQ WB,=CH$BL,GTNC0 JUMP IF BLANK
16889: BEQ WB,=CH$HT,GTNC0 JUMP IF HORIZONTAL TAB
16890: BRN GTN36 ERROR IF NON-BLANK
16891: *
16892: GTNC0 LCH WB,(XR)+ GET NEXT CHARACTER
16893: BCT WA,GTN20 LOOP BACK TILL ALL BLANKS SCANNED
16894: *
16895: * MERGE HERE AFTER COLLECTING EXPONENT
16896: *
16897: GTN21 STI GTNEX SAVE COLLECTED EXPONENT
16898: BNZ GTNES,GTN22 JUMP IF IT WAS NEGATIVE
16899: NGI ELSE COMPLEMENT
16900: IOV GTN36 ERROR IF OVERFLOW
16901: STI GTNEX AND STORE POSITIVE EXPONENT
16902: *
16903: * MERGE HERE WITH EXPONENT (0 IF NONE GIVEN)
16904: *
16905: GTN22 BZE GTNRD,GTN36 ERROR IF NOT DIGITS COLLECTED
16906: BZE GTNDF,GTN36 ERROR IF NO EXPONENT OR DEC POINT
16907: MTI GTNSC ELSE LOAD SCALE AS INTEGER
16908: SBI GTNEX SUBTRACT EXPONENT
16909: IOV GTN36 ERROR IF OVERFLOW
16910: ILT GTN26 JUMP IF WE MUST SCALE UP
16911: *
16912: * HERE WE HAVE A NEGATIVE EXPONENT, SO SCALE DOWN
16913: *
16914: MFI WA,GTN36 LOAD SCALE FACTOR, ERR IF OVFLOW
16915: *
16916: * LOOP TO SCALE DOWN IN STEPS OF 10**10
16917: *
16918: GTN23 BLE WA,=NUM10,GTN24 JUMP IF 10 OR LESS TO GO
16919: DVR REATT ELSE DIVIDE BY 10**10
16920: SUB =NUM10,WA DECREMENT SCALE
16921: BRN GTN23 AND LOOP BACK
16922: EJC
16923: *
16924: * GTNUM (CONTINUED)
16925: *
16926: * HERE SCALE REST OF WAY FROM POWERS OF TEN TABLE
16927: *
16928: GTN24 BZE WA,GTN30 JUMP IF SCALED
16929: LCT WB,=CFP$R ELSE GET INDEXING FACTOR
16930: MOV =REAV1,XR POINT TO POWERS OF TEN TABLE
16931: WTB WA CONVERT REMAINING SCALE TO BYTE OFS
16932: *
16933: * LOOP TO POINT TO POWERS OF TEN TABLE ENTRY
16934: *
16935: GTN25 ADD WA,XR BUMP POINTER
16936: BCT WB,GTN25 ONCE FOR EACH VALUE WORD
16937: DVR (XR) SCALE DOWN AS REQUIRED
16938: BRN GTN30 AND JUMP
16939: *
16940: * COME HERE TO SCALE RESULT UP (POSITIVE EXPONENT)
16941: *
16942: GTN26 NGI GET ABSOLUTE VALUE OF EXPONENT
16943: IOV GTN36 ERROR IF OVERFLOW
16944: MFI WA,GTN36 ACQUIRE SCALE, ERROR IF OVFLOW
16945: *
16946: * LOOP TO SCALE UP IN STEPS OF 10**10
16947: *
16948: GTN27 BLE WA,=NUM10,GTN28 JUMP IF 10 OR LESS TO GO
16949: MLR REATT ELSE MULTIPLY BY 10**10
16950: ROV GTN36 ERROR IF OVERFLOW
16951: SUB =NUM10,WA ELSE DECREMENT SCALE
16952: BRN GTN27 AND LOOP BACK
16953: *
16954: * HERE TO SCALE UP REST OF WAY WITH TABLE
16955: *
16956: GTN28 BZE WA,GTN30 JUMP IF SCALED
16957: LCT WB,=CFP$R ELSE GET INDEXING FACTOR
16958: MOV =REAV1,XR POINT TO POWERS OF TEN TABLE
16959: WTB WA CONVERT REMAINING SCALE TO BYTE OFS
16960: *
16961: * LOOP TO POINT TO PROPER ENTRY IN POWERS OF TEN TABLE
16962: *
16963: GTN29 ADD WA,XR BUMP POINTER
16964: BCT WB,GTN29 ONCE FOR EACH WORD IN VALUE
16965: MLR (XR) SCALE UP
16966: ROV GTN36 ERROR IF OVERFLOW
16967: EJC
16968: *
16969: * GTNUM (CONTINUED)
16970: *
16971: * HERE WITH REAL VALUE SCALED AND READY EXCEPT FOR SIGN
16972: *
16973: GTN30 BZE GTNNF,GTN31 JUMP IF POSITIVE
16974: NGR ELSE NEGATE
16975: *
16976: * HERE WITH PROPERLY SIGNED REAL VALUE IN (RA)
16977: *
16978: GTN31 JSR RCBLD BUILD REAL BLOCK
16979: BRN GTN33 MERGE TO EXIT
16980: *
16981: * HERE WITH PROPERLY SIGNED INTEGER VALUE IN (IA)
16982: *
16983: GTN32 JSR ICBLD BUILD ICBLK
16984: *
16985: * REAL MERGES HERE
16986: *
16987: GTN33 MOV (XR),WA LOAD FIRST WORD OF RESULT BLOCK
16988: ICA XS POP ARGUMENT OFF STACK
16989: *
16990: * COMMON EXIT POINT
16991: *
16992: GTN34 EXI RETURN TO GTNUM CALLER
16993: *
16994: * COME HERE IF OVERFLOW OCCURS DURING COLLECTION OF INTEGER
16995: *
16996: GTN35 LDI GTNSI RELOAD INTEGER SO FAR
16997: ITR CONVERT TO REAL
16998: NGR MAKE VALUE POSITIVE
16999: BRN GTN11 MERGE WITH REAL CIRCUIT
17000: *
17001: * HERE FOR UNCONVERTIBLE TO STRING OR CONVERSION ERROR
17002: *
17003: GTN36 MOV (XS)+,XR RELOAD ORIGINAL ARGUMENT
17004: EXI 1 TAKE CONVERT-ERROR EXIT
17005: ENP END PROCEDURE GTNUM
17006: EJC
17007: *
17008: * GTNVR -- CONVERT TO NATURAL VARIABLE
17009: *
17010: * GTNVR LOCATES A VARIABLE BLOCK (VRBLK) GIVEN EITHER AN
17011: * APPROPRIATE NAME (NMBLK) OR A NON-NULL STRING (SCBLK).
17012: *
17013: * (XR) ARGUMENT
17014: * JSR GTNVR CALL TO CONVERT TO NATURAL VARIABLE
17015: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
17016: * (XR) POINTER TO VRBLK
17017: * (WA,WB) DESTROYED (CONVERSION ERROR ONLY)
17018: * (WC) DESTROYED
17019: *
17020: GTNVR PRC E,1 ENTRY POINT
17021: BNE (XR),=B$NML,GNV02 JUMP IF NOT NAME
17022: MOV NMBAS(XR),XR ELSE LOAD NAME BASE IF NAME
17023: BLO XR,STATE,GNV07 SKIP IF VRBLK (IN STATIC REGION)
17024: *
17025: * COMMON ERROR EXIT
17026: *
17027: GNV01 EXI 1 TAKE CONVERT-ERROR EXIT
17028: *
17029: * HERE IF NOT NAME
17030: *
17031: GNV02 MOV WA,GNVSA SAVE WA
17032: MOV WB,GNVSB SAVE WB
17033: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG
17034: JSR GTSTG CONVERT ARGUMENT TO STRING
17035: PPM GNV01 JUMP IF CONVERSION ERROR
17036: BZE WA,GNV01 NULL STRING IS AN ERROR
17037: JSR FLSTG FOLD LOWER CASE TO UPPER CASE
17038: MOV XL,-(XS) SAVE XL
17039: MOV XR,-(XS) STACK STRING PTR FOR LATER
17040: MOV XR,WB COPY STRING POINTER
17041: ADD *SCHAR,WB POINT TO CHARACTERS OF STRING
17042: MOV WB,GNVST SAVE POINTER TO CHARACTERS
17043: MOV WA,WB COPY LENGTH
17044: CTW WB,0 GET NUMBER OF WORDS IN NAME
17045: MOV WB,GNVNW SAVE FOR LATER
17046: JSR HASHS COMPUTE HASH INDEX FOR STRING
17047: RMI HSHNB COMPUTE HASH OFFSET BY TAKING MOD
17048: MFI WC GET AS OFFSET
17049: WTB WC CONVERT OFFSET TO BYTES
17050: ADD HSHTB,WC POINT TO PROPER HASH CHAIN
17051: SUB *VRNXT,WC SUBTRACT OFFSET TO MERGE INTO LOOP
17052: EJC
17053: *
17054: * GTNVR (CONTINUED)
17055: *
17056: * LOOP TO SEARCH HASH CHAIN
17057: *
17058: GNV03 MOV WC,XL COPY HASH CHAIN POINTER
17059: MOV VRNXT(XL),XL POINT TO NEXT VRBLK ON CHAIN
17060: BZE XL,GNV08 JUMP IF END OF CHAIN
17061: MOV XL,WC SAVE POINTER TO THIS VRBLK
17062: BNZ VRLEN(XL),GNV04 JUMP IF NOT SYSTEM VARIABLE
17063: MOV VRSVP(XL),XL ELSE POINT TO SVBLK
17064: SUB *VRSOF,XL ADJUST OFFSET FOR MERGE
17065: *
17066: * MERGE HERE WITH STRING PTR (LIKE VRBLK) IN XL
17067: *
17068: GNV04 BNE WA,VRLEN(XL),GNV03 BACK FOR NEXT VRBLK IF LENGTHS NE
17069: ADD *VRCHS,XL ELSE POINT TO CHARS OF CHAIN ENTRY
17070: LCT WB,GNVNW GET WORD COUNTER TO CONTROL LOOP
17071: MOV GNVST,XR POINT TO CHARS OF NEW NAME
17072: *
17073: * LOOP TO COMPARE CHARACTERS OF THE TWO NAMES
17074: *
17075: GNV05 CNE (XR),(XL),GNV03 JUMP IF NO MATCH FOR NEXT VRBLK
17076: ICA XR BUMP NEW NAME POINTER
17077: ICA XL BUMP VRBLK IN CHAIN NAME POINTER
17078: BCT WB,GNV05 ELSE LOOP TILL ALL COMPARED
17079: MOV WC,XR WE HAVE FOUND A MATCH, GET VRBLK
17080: *
17081: * EXIT POINT AFTER FINDING VRBLK OR BUILDING NEW ONE
17082: *
17083: GNV06 MOV GNVSA,WA RESTORE WA
17084: MOV GNVSB,WB RESTORE WB
17085: ICA XS POP STRING POINTER
17086: MOV (XS)+,XL RESTORE XL
17087: *
17088: * COMMON EXIT POINT
17089: *
17090: GNV07 EXI RETURN TO GTNVR CALLER
17091: *
17092: * NOT FOUND, PREPARE TO SEARCH SYSTEM VARIABLE TABLE
17093: *
17094: GNV08 ZER XR CLEAR GARBAGE XR POINTER
17095: MOV WC,GNVHE SAVE PTR TO END OF HASH CHAIN
17096: BGT WA,=NUM09,GNV14 CANNOT BE SYSTEM VAR IF LENGTH GT 9
17097: MOV WA,XL ELSE COPY LENGTH
17098: WTB XL CONVERT TO BYTE OFFSET
17099: MOV VSRCH(XL),XL POINT TO FIRST SVBLK OF THIS LENGTH
17100: EJC
17101: *
17102: * GTNVR (CONTINUED)
17103: *
17104: * LOOP TO SEARCH ENTRIES IN STANDARD VARIABLE TABLE
17105: *
17106: GNV09 MOV XL,GNVSP SAVE TABLE POINTER
17107: MOV (XL)+,WC LOAD SVBIT BIT STRING
17108: MOV (XL)+,WB LOAD LENGTH FROM TABLE ENTRY
17109: BNE WA,WB,GNV14 JUMP IF END OF RIGHT LENGTH ENTIRES
17110: LCT WB,GNVNW GET WORD COUNTER TO CONTROL LOOP
17111: MOV GNVST,XR POINT TO CHARS OF NEW NAME
17112: *
17113: * LOOP TO CHECK FOR MATCHING NAMES
17114: *
17115: GNV10 CNE (XR),(XL),GNV11 JUMP IF NAME MISMATCH
17116: ICA XR ELSE BUMP NEW NAME POINTER
17117: ICA XL BUMP SVBLK POINTER
17118: BCT WB,GNV10 ELSE LOOP UNTIL ALL CHECKED
17119: *
17120: * HERE WE HAVE A MATCH IN THE STANDARD VARIABLE TABLE
17121: *
17122: ZER WC SET VRLEN VALUE ZERO
17123: MOV *VRSI$,WA SET STANDARD SIZE
17124: BRN GNV15 JUMP TO BUILD VRBLK
17125: *
17126: * HERE IF NO MATCH WITH TABLE ENTRY IN SVBLKS TABLE
17127: *
17128: GNV11 ICA XL BUMP PAST WORD OF CHARS
17129: BCT WB,GNV11 LOOP BACK IF MORE TO GO
17130: RSH WC,SVNBT REMOVE UNINTERESTING BITS
17131: *
17132: * LOOP TO BUMP TABLE PTR FOR EACH FLAGGED WORD
17133: *
17134: GNV12 MOV BITS1,WB LOAD BIT TO TEST
17135: ANB WC,WB TEST FOR WORD PRESENT
17136: ZRB WB,GNV13 JUMP IF NOT PRESENT
17137: ICA XL ELSE BUMP TABLE POINTER
17138: *
17139: * HERE AFTER DEALING WITH ONE WORD (ONE BIT)
17140: *
17141: GNV13 RSH WC,1 REMOVE BIT ALREADY PROCESSED
17142: NZB WC,GNV12 LOOP BACK IF MORE BITS TO TEST
17143: BRN GNV09 ELSE LOOP BACK FOR NEXT SVBLK
17144: *
17145: * HERE IF NOT SYSTEM VARIABLE
17146: *
17147: GNV14 MOV WA,WC COPY VRLEN VALUE
17148: MOV =VRCHS,WA LOAD STANDARD SIZE -CHARS
17149: ADD GNVNW,WA ADJUST FOR CHARS OF NAME
17150: WTB WA CONVERT LENGTH TO BYTES
17151: EJC
17152: *
17153: * GTNVR (CONTINUED)
17154: *
17155: * MERGE HERE TO BUILD VRBLK
17156: *
17157: GNV15 JSR ALOST ALLOCATE SPACE FOR VRBLK (STATIC)
17158: MOV XR,WB SAVE VRBLK POINTER
17159: MOV =STNVR,XL POINT TO MODEL VARIABLE BLOCK
17160: MOV *VRLEN,WA SET LENGTH OF STANDARD FIELDS
17161: MVW SET INITIAL FIELDS OF NEW BLOCK
17162: MOV GNVHE,XL LOAD POINTER TO END OF HASH CHAIN
17163: MOV WB,VRNXT(XL) ADD NEW BLOCK TO END OF CHAIN
17164: MOV WC,(XR)+ SET VRLEN FIELD, BUMP PTR
17165: MOV GNVNW,WA GET LENGTH IN WORDS
17166: WTB WA CONVERT TO LENGTH IN BYTES
17167: BZE WC,GNV16 JUMP IF SYSTEM VARIABLE
17168: *
17169: * HERE FOR NON-SYSTEM VARIABLE -- SET CHARS OF NAME
17170: *
17171: MOV (XS),XL POINT BACK TO STRING NAME
17172: ADD *SCHAR,XL POINT TO CHARS OF NAME
17173: MVW MOVE CHARACTERS INTO PLACE
17174: MOV WB,XR RESTORE VRBLK POINTER
17175: BRN GNV06 JUMP BACK TO EXIT
17176: *
17177: * HERE FOR SYSTEM VARIABLE CASE TO FILL IN FIELDS WHERE
17178: * NECESSARY FROM THE FIELDS PRESENT IN THE SVBLK.
17179: *
17180: GNV16 MOV GNVSP,XL LOAD POINTER TO SVBLK
17181: MOV XL,(XR) SET SVBLK PTR IN VRBLK
17182: MOV WB,XR RESTORE VRBLK POINTER
17183: MOV SVBIT(XL),WB LOAD BIT INDICATORS
17184: ADD *SVCHS,XL POINT TO CHARACTERS OF NAME
17185: ADD WA,XL POINT PAST CHARACTERS
17186: *
17187: * SKIP PAST KEYWORD NUMBER (SVKNM) IF PRESENT
17188: *
17189: MOV BTKNM,WC LOAD TEST BIT
17190: ANB WB,WC AND TO TEST
17191: ZRB WC,GNV17 JUMP IF NO KEYWORD NUMBER
17192: ICA XL ELSE BUMP POINTER
17193: EJC
17194: *
17195: * GTNVR (CONTINUED)
17196: *
17197: * HERE TEST FOR FUNCTION (SVFNC AND SVNAR)
17198: *
17199: GNV17 MOV BTFNC,WC GET TEST BIT
17200: ANB WB,WC AND TO TEST
17201: ZRB WC,GNV18 SKIP IF NO SYSTEM FUNCTION
17202: MOV XL,VRFNC(XR) ELSE POINT VRFNC TO SVFNC FIELD
17203: ADD *NUM02,XL AND BUMP PAST SVFNC, SVNAR FIELDS
17204: *
17205: * NOW TEST FOR LABEL (SVLBL)
17206: *
17207: GNV18 MOV BTLBL,WC GET TEST BIT
17208: ANB WB,WC AND TO TEST
17209: ZRB WC,GNV19 JUMP IF BIT IS OFF (NO SYSTEM LABL)
17210: MOV XL,VRLBL(XR) ELSE POINT VRLBL TO SVLBL FIELD
17211: ICA XL BUMP PAST SVLBL FIELD
17212: *
17213: * NOW TEST FOR VALUE (SVVAL)
17214: *
17215: GNV19 MOV BTVAL,WC LOAD TEST BIT
17216: ANB WB,WC AND TO TEST
17217: ZRB WC,GNV06 ALL DONE IF NO VALUE
17218: MOV (XL),VRVAL(XR) ELSE SET INITIAL VALUE
17219: MOV =B$VRE,VRSTO(XR) SET ERROR STORE ACCESS
17220: BRN GNV06 MERGE BACK TO EXIT TO CALLER
17221: ENP END PROCEDURE GTNVR
17222: EJC
17223: *
17224: * GTPAT -- GET PATTERN
17225: *
17226: * GTPAT IS PASSED AN OBJECT IN (XR) AND RETURNS A
17227: * PATTERN AFTER PERFORMING ANY NECESSARY CONVERSIONS
17228: *
17229: * (XR) INPUT ARGUMENT
17230: * JSR GTPAT CALL TO CONVERT TO PATTERN
17231: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
17232: * (XR) RESULTING PATTERN
17233: * (WA) DESTROYED
17234: * (WB) DESTROYED (ONLY ON CONVERT ERROR)
17235: * (XR) UNCHANGED (ONLY ON CONVERT ERROR)
17236: *
17237: GTPAT PRC E,1 ENTRY POINT
17238: BHI (XR),=P$AAA,GTPT5 JUMP IF PATTERN ALREADY
17239: *
17240: * HERE IF NOT PATTERN, TRY FOR STRING
17241: *
17242: MOV WB,GTPSB SAVE WB
17243: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG
17244: JSR GTSTG CONVERT ARGUMENT TO STRING
17245: PPM GTPT2 JUMP IF IMPOSSIBLE
17246: *
17247: * HERE WE HAVE A STRING
17248: *
17249: BNZ WA,GTPT1 JUMP IF NON-NULL
17250: *
17251: * HERE FOR NULL STRING. GENERATE POINTER TO NULL PATTERN.
17252: *
17253: MOV =NDNTH,XR POINT TO NOTHEN NODE
17254: BRN GTPT4 JUMP TO EXIT
17255: EJC
17256: *
17257: * GTPAT (CONTINUED)
17258: *
17259: * HERE FOR NON-NULL STRING
17260: *
17261: GTPT1 MOV =P$STR,WB LOAD PCODE FOR MULTI-CHAR STRING
17262: BNE WA,=NUM01,GTPT3 JUMP IF MULTI-CHAR STRING
17263: *
17264: * HERE FOR ONE CHARACTER STRING, SHARE ONE CHARACTER ANY
17265: *
17266: PLC XR POINT TO CHARACTER
17267: LCH WA,(XR) LOAD CHARACTER
17268: MOV WA,XR SET AS PARM1
17269: MOV =P$ANS,WB POINT TO PCODE FOR 1-CHAR ANY
17270: BRN GTPT3 JUMP TO BUILD NODE
17271: *
17272: * HERE IF ARGUMENT IS NOT CONVERTIBLE TO STRING
17273: *
17274: GTPT2 MOV =P$EXA,WB SET PCODE FOR EXPRESSION IN CASE
17275: BLO (XR),=B$E$$,GTPT3 JUMP TO BUILD NODE IF EXPRESSION
17276: *
17277: * HERE WE HAVE AN ERROR (CONVERSION IMPOSSIBLE)
17278: *
17279: EXI 1 TAKE CONVERT ERROR EXIT
17280: *
17281: * MERGE HERE TO BUILD NODE FOR STRING OR EXPRESSION
17282: *
17283: GTPT3 JSR PBILD CALL ROUTINE TO BUILD PATTERN NODE
17284: *
17285: * COMMON EXIT AFTER SUCCESSFUL CONVERSION
17286: *
17287: GTPT4 MOV GTPSB,WB RESTORE WB
17288: *
17289: * MERGE HERE TO EXIT OF NO CONVERSION REQUIRED
17290: *
17291: GTPT5 EXI RETURN TO GTPAT CALLER
17292: ENP END PROCEDURE GTPAT
17293: EJC
17294: *
17295: * GTREA -- GET REAL VALUE
17296: *
17297: * GTREA IS PASSED AN OBJECT AND RETURNS A REAL VALUE
17298: * PERFORMING ANY NECESSARY CONVERSIONS.
17299: *
17300: * (XR) OBJECT TO BE CONVERTED
17301: * JSR GTREA CALL TO CONVERT OBJECT TO REAL
17302: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
17303: * (XR) POINTER TO RESULTING REAL
17304: * (WA,WB,WC,RA) DESTROYED
17305: * (XR) UNCHANGED (CONVERT ERROR ONLY)
17306: *
17307: GTREA PRC E,1 ENTRY POINT
17308: MOV (XR),WA GET FIRST WORD OF BLOCK
17309: BEQ WA,=B$RCL,GTRE2 JUMP IF REAL
17310: JSR GTNUM ELSE CONVERT ARGUMENT TO NUMERIC
17311: PPM GTRE3 JUMP IF UNCONVERTIBLE
17312: BEQ WA,=B$RCL,GTRE2 JUMP IF REAL WAS RETURNED
17313: *
17314: * HERE FOR CASE OF AN INTEGER TO CONVERT TO REAL
17315: *
17316: GTRE1 LDI ICVAL(XR) LOAD INTEGER
17317: ITR CONVERT TO REAL
17318: JSR RCBLD BUILD RCBLK
17319: *
17320: * EXIT WITH REAL
17321: *
17322: GTRE2 EXI RETURN TO GTREA CALLER
17323: *
17324: * HERE ON CONVERSION ERROR
17325: *
17326: GTRE3 EXI 1 TAKE CONVERT ERROR EXIT
17327: ENP END PROCEDURE GTREA
17328: EJC
17329: *
17330: * GTSMI -- GET SMALL INTEGER
17331: *
17332: * GTSMI IS PASSED A SNOBOL OBJECT AND RETURNS AN ADDRESS
17333: * INTEGER IN THE RANGE (0 LE N LE DNAMB). SUCH A VALUE CAN
17334: * ONLY BE DERIVED FROM AN INTEGER IN THE APPROPRIATE RANGE.
17335: * SMALL INTEGERS NEVER APPEAR AS SNOBOL VALUES. HOWEVER,
17336: * THEY ARE USED INTERNALLY FOR A VARIETY OF PURPOSES.
17337: *
17338: * -(XS) ARGUMENT TO CONVERT (ON STACK)
17339: * JSR GTSMI CALL TO CONVERT TO SMALL INTEGER
17340: * PPM LOC TRANSFER LOC FOR NOT INTEGER
17341: * PPM LOC TRANSFER LOC FOR LT 0, GT DNAMB
17342: * (XR,WC) RESULTING SMALL INT (TWO COPIES)
17343: * (XS) POPPED
17344: * (RA) DESTROYED
17345: * (WA,WB) DESTROYED (ON CONVERT ERROR ONLY)
17346: * (XR) INPUT ARG (CONVERT ERROR ONLY)
17347: *
17348: GTSMI PRC N,2 ENTRY POINT
17349: MOV (XS)+,XR LOAD ARGUMENT
17350: BEQ (XR),=B$ICL,GTSM1 SKIP IF ALREADY AN INTEGER
17351: *
17352: * HERE IF NOT AN INTEGER
17353: *
17354: JSR GTINT CONVERT ARGUMENT TO INTEGER
17355: PPM GTSM2 JUMP IF CONVERT IS IMPOSSIBLE
17356: *
17357: * MERGE HERE WITH INTEGER
17358: *
17359: GTSM1 LDI ICVAL(XR) LOAD INTEGER VALUE
17360: MFI WC,GTSM3 MOVE AS ONE WORD, JUMP IF OVFLOW
17361: BGT WC,MXLEN,GTSM3 OR IF TOO SMALL
17362: MOV WC,XR COPY RESULT TO XR
17363: EXI RETURN TO GTSMI CALLER
17364: *
17365: * HERE IF UNCONVERTIBLE TO INTEGER
17366: *
17367: GTSM2 EXI 1 TAKE NON-INTEGER ERROR EXIT
17368: *
17369: * HERE IF OUT OF RANGE
17370: *
17371: GTSM3 EXI 2 TAKE OUT-OF-RANGE ERROR EXIT
17372: ENP END PROCEDURE GTSMI
17373: EJC
17374: *
17375: * GTSTG -- GET STRING
17376: *
17377: * GTSTG IS PASSED AN OBJECT AND RETURNS A STRING WITH
17378: * ANY NECESSARY CONVERSIONS PERFORMED.
17379: *
17380: * -(XS) INPUT ARGUMENT (ON STACK)
17381: * JSR GTSTG CALL TO CONVERT TO STRING
17382: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
17383: * (XR) POINTER TO RESULTING STRING
17384: * (WA) LENGTH OF STRING IN CHARACTERS
17385: * (XS) POPPED
17386: * (RA) DESTROYED
17387: * (XR) INPUT ARG (CONVERT ERROR ONLY)
17388: *
17389: GTSTG PRC N,1 ENTRY POINT
17390: MOV (XS)+,XR LOAD ARGUMENT, POP STACK
17391: BEQ (XR),=B$SCL,GTS30 JUMP IF ALREADY A STRING
17392: *
17393: * HERE IF NOT A STRING ALREADY
17394: *
17395: GTS01 MOV XR,-(XS) RESTACK ARGUMENT IN CASE ERROR
17396: MOV XL,-(XS) SAVE XL
17397: MOV WB,GTSVB SAVE WB
17398: MOV WC,GTSVC SAVE WC
17399: MOV (XR),WA LOAD FIRST WORD OF BLOCK
17400: BEQ WA,=B$ICL,GTS05 JUMP TO CONVERT INTEGER
17401: BEQ WA,=B$RCL,GTS10 JUMP TO CONVERT REAL
17402: BEQ WA,=B$NML,GTS03 JUMP TO CONVERT NAME
17403: BEQ WA,=B$BCT,GTS32 JUMP TO CONVERT BUFFER
17404: *
17405: * HERE ON CONVERSION ERROR
17406: *
17407: GTS02 MOV (XS)+,XL RESTORE XL
17408: MOV (XS)+,XR RELOAD INPUT ARGUMENT
17409: EXI 1 TAKE CONVERT ERROR EXIT
17410: EJC
17411: *
17412: * GTSTG (CONTINUED)
17413: *
17414: * HERE TO CONVERT A NAME (ONLY POSSIBLE IF NATURAL VAR)
17415: *
17416: GTS03 MOV NMBAS(XR),XL LOAD NAME BASE
17417: BHI XL,STATE,GTS02 ERROR IF NOT NATURAL VAR (STATIC)
17418: ADD *VRSOF,XL ELSE POINT TO POSSIBLE STRING NAME
17419: MOV SCLEN(XL),WA LOAD LENGTH
17420: BNZ WA,GTS04 JUMP IF NOT SYSTEM VARIABLE
17421: MOV VRSVO(XL),XL ELSE POINT TO SVBLK
17422: MOV SVLEN(XL),WA AND LOAD NAME LENGTH
17423: *
17424: * MERGE HERE WITH STRING IN XR, LENGTH IN WA
17425: *
17426: GTS04 ZER WB SET OFFSET TO ZERO
17427: JSR SBSTR USE SBSTR TO COPY STRING
17428: BRN GTS29 JUMP TO EXIT
17429: *
17430: * COME HERE TO CONVERT AN INTEGER
17431: *
17432: GTS05 LDI ICVAL(XR) LOAD INTEGER VALUE
17433: MOV =NUM01,GTSSF SET SIGN FLAG NEGATIVE
17434: ILT GTS06 SKIP IF INTEGER IS NEGATIVE
17435: NGI ELSE NEGATE INTEGER
17436: ZER GTSSF AND RESET NEGATIVE FLAG
17437: EJC
17438: *
17439: * GTSTG (CONTINUED)
17440: *
17441: * HERE WITH SIGN FLAG SET AND SIGN FORCED NEGATIVE AS
17442: * REQUIRED BY THE CVD INSTRUCTION.
17443: *
17444: GTS06 MOV GTSWK,XR POINT TO RESULT WORK AREA
17445: MOV =NSTMX,WB INITIALIZE COUNTER TO MAX LENGTH
17446: PSC XR,WB PREPARE TO STORE (RIGHT-LEFT)
17447: *
17448: * LOOP TO CONVERT DIGITS INTO WORK AREA
17449: *
17450: GTS07 CVD CONVERT ONE DIGIT INTO WA
17451: SCH WA,-(XR) STORE IN WORK AREA
17452: DCV WB DECREMENT COUNTER
17453: INE GTS07 LOOP IF MORE DIGITS TO GO
17454: CSC XR COMPLETE STORE CHARACTERS
17455: *
17456: * MERGE HERE AFTER CONVERTING INTEGER OR REAL INTO WORK
17457: * AREA. WB IS SET TO NSTMX - (NUMBER OF CHARS IN RESULT).
17458: *
17459: GTS08 MOV =NSTMX,WA GET MAX NUMBER OF CHARACTERS
17460: SUB WB,WA COMPUTE LENGTH OF RESULT
17461: MOV WA,XL REMEMBER LENGTH FOR MOVE LATER ON
17462: ADD GTSSF,WA ADD ONE FOR NEGATIVE SIGN IF NEEDED
17463: JSR ALOCS ALLOCATE STRING FOR RESULT
17464: MOV XR,WC SAVE RESULT POINTER FOR THE MOMENT
17465: PSC XR POINT TO CHARS OF RESULT BLOCK
17466: BZE GTSSF,GTS09 SKIP IF POSITIVE
17467: MOV =CH$MN,WA ELSE LOAD NEGATIVE SIGN
17468: SCH WA,(XR)+ AND STORE IT
17469: CSC XR COMPLETE STORE CHARACTERS
17470: *
17471: * HERE AFTER DEALING WITH SIGN
17472: *
17473: GTS09 MOV XL,WA RECALL LENGTH TO MOVE
17474: MOV GTSWK,XL POINT TO RESULT WORK AREA
17475: PLC XL,WB POINT TO FIRST RESULT CHARACTER
17476: MVC MOVE CHARS TO RESULT STRING
17477: MOV WC,XR RESTORE RESULT POINTER
17478: BRN GTS29 JUMP TO EXIT
17479: EJC
17480: *
17481: * GTSTG (CONTINUED)
17482: *
17483: * HERE TO CONVERT A REAL
17484: *
17485: GTS10 LDR RCVAL(XR) LOAD REAL
17486: ZER GTSSF RESET NEGATIVE FLAG
17487: REQ GTS31 SKIP IF ZERO
17488: RGE GTS11 JUMP IF REAL IS POSITIVE
17489: MOV =NUM01,GTSSF ELSE SET NEGATIVE FLAG
17490: NGR AND GET ABSOLUTE VALUE OF REAL
17491: *
17492: * NOW SCALE THE REAL TO THE RANGE (0.1 LE X LT 1.0)
17493: *
17494: GTS11 LDI INTV0 INITIALIZE EXPONENT TO ZERO
17495: *
17496: * LOOP TO SCALE UP IN STEPS OF 10**10
17497: *
17498: GTS12 STR GTSRS SAVE REAL VALUE
17499: SBR REAP1 SUBTRACT 0.1 TO COMPARE
17500: RGE GTS13 JUMP IF SCALE UP NOT REQUIRED
17501: LDR GTSRS ELSE RELOAD VALUE
17502: MLR REATT MULTIPLY BY 10**10
17503: SBI INTVT DECREMENT EXPONENT BY 10
17504: BRN GTS12 LOOP BACK TO TEST AGAIN
17505: *
17506: * TEST FOR SCALE DOWN REQUIRED
17507: *
17508: GTS13 LDR GTSRS RELOAD VALUE
17509: SBR REAV1 SUBTRACT 1.0
17510: RLT GTS17 JUMP IF NO SCALE DOWN REQUIRED
17511: LDR GTSRS ELSE RELOAD VALUE
17512: *
17513: * LOOP TO SCALE DOWN IN STEPS OF 10**10
17514: *
17515: GTS14 SBR REATT SUBTRACT 10**10 TO COMPARE
17516: RLT GTS15 JUMP IF LARGE STEP NOT REQUIRED
17517: LDR GTSRS ELSE RESTORE VALUE
17518: DVR REATT DIVIDE BY 10**10
17519: STR GTSRS STORE NEW VALUE
17520: ADI INTVT INCREMENT EXPONENT BY 10
17521: BRN GTS14 LOOP BACK
17522: EJC
17523: *
17524: * GTSTG (CONTINUED)
17525: *
17526: * AT THIS POINT WE HAVE (1.0 LE X LT 10**10)
17527: * COMPLETE SCALING WITH POWERS OF TEN TABLE
17528: *
17529: GTS15 MOV =REAV1,XR POINT TO POWERS OF TEN TABLE
17530: *
17531: * LOOP TO LOCATE CORRECT ENTRY IN TABLE
17532: *
17533: GTS16 LDR GTSRS RELOAD VALUE
17534: ADI INTV1 INCREMENT EXPONENT
17535: ADD *CFP$R,XR POINT TO NEXT ENTRY IN TABLE
17536: SBR (XR) SUBTRACT IT TO COMPARE
17537: RGE GTS16 LOOP TILL WE FIND A LARGER ENTRY
17538: LDR GTSRS THEN RELOAD THE VALUE
17539: DVR (XR) AND COMPLETE SCALING
17540: STR GTSRS STORE VALUE
17541: *
17542: * WE ARE NOW SCALED, SO ROUND BY ADDING 0.5 * 10**(-CFP$S)
17543: *
17544: GTS17 LDR GTSRS GET VALUE AGAIN
17545: ADR GTSRN ADD ROUNDING FACTOR
17546: STR GTSRS STORE RESULT
17547: *
17548: * THE ROUNDING OPERATION MAY HAVE PUSHED US UP PAST
17549: * 1.0 AGAIN, SO CHECK ONE MORE TIME.
17550: *
17551: SBR REAV1 SUBTRACT 1.0 TO COMPARE
17552: RLT GTS18 SKIP IF OK
17553: ADI INTV1 ELSE INCREMENT EXPONENT
17554: LDR GTSRS RELOAD VALUE
17555: DVR REAVT DIVIDE BY 10.0 TO RESCALE
17556: BRN GTS19 JUMP TO MERGE
17557: *
17558: * HERE IF ROUNDING DID NOT MUCK UP SCALING
17559: *
17560: GTS18 LDR GTSRS RELOAD ROUNDED VALUE
17561: EJC
17562: *
17563: * GTSTG (CONTINUED)
17564: *
17565: * NOW WE HAVE COMPLETED THE SCALING AS FOLLOWS
17566: *
17567: * (IA) SIGNED EXPONENT
17568: * (RA) SCALED REAL (ABSOLUTE VALUE)
17569: *
17570: * IF THE EXPONENT IS NEGATIVE OR GREATER THAN CFP$S, THEN
17571: * WE CONVERT THE NUMBER IN THE FORM.
17572: *
17573: * (NEG SIGN) 0 . (CPF$S DIGITS) E (EXP SIGN) (EXP DIGITS)
17574: *
17575: * IF THE EXPONENT IS POSITIVE AND LESS THAN OR EQUAL TO
17576: * CFP$S, THE NUMBER IS CONVERTED IN THE FORM.
17577: *
17578: * (NEG SIGN) (EXPONENT DIGITS) . (CFP$S-EXPONENT DIGITS)
17579: *
17580: * IN BOTH CASES, THE FORMATS OBTAINED FROM THE ABOVE
17581: * RULES ARE MODIFIED BY DELETING TRAILING ZEROS AFTER THE
17582: * DECIMAL POINT. THERE ARE NO LEADING ZEROS IN THE EXPONENT
17583: * AND THE EXPONENT SIGN IS ALWAYS PRESENT.
17584: *
17585: GTS19 MOV =CFP$S,XL SET NUM DEC DIGITS = CFP$S
17586: MOV =CH$MN,GTSES SET EXPONENT SIGN NEGATIVE
17587: ILT GTS21 ALL SET IF EXPONENT IS NEGATIVE
17588: MFI WA ELSE FETCH EXPONENT
17589: BLE WA,=CFP$S,GTS20 SKIP IF WE CAN USE SPECIAL FORMAT
17590: MTI WA ELSE RESTORE EXPONENT
17591: NGI SET NEGATIVE FOR CVD
17592: MOV =CH$PL,GTSES SET PLUS SIGN FOR EXPONENT SIGN
17593: BRN GTS21 JUMP TO GENERATE EXPONENT
17594: *
17595: * HERE IF WE CAN USE THE FORMAT WITHOUT AN EXPONENT
17596: *
17597: GTS20 SUB WA,XL COMPUTE DIGITS AFTER DECIMAL POINT
17598: LDI INTV0 RESET EXPONENT TO ZERO
17599: EJC
17600: *
17601: * GTSTG (CONTINUED)
17602: *
17603: * MERGE HERE AS FOLLOWS
17604: *
17605: * (IA) EXPONENT ABSOLUTE VALUE
17606: * GTSES CHARACTER FOR EXPONENT SIGN
17607: * (RA) POSITIVE FRACTION
17608: * (XL) NUMBER OF DIGITS AFTER DEC POINT
17609: *
17610: GTS21 MOV GTSWK,XR POINT TO WORK AREA
17611: MOV =NSTMX,WB SET CHARACTER CTR TO MAX LENGTH
17612: PSC XR,WB PREPARE TO STORE (RIGHT TO LEFT)
17613: IEQ GTS23 SKIP EXPONENT IF IT IS ZERO
17614: *
17615: * LOOP TO GENERATE DIGITS OF EXPONENT
17616: *
17617: GTS22 CVD CONVERT A DIGIT INTO WA
17618: SCH WA,-(XR) STORE IN WORK AREA
17619: DCV WB DECREMENT COUNTER
17620: INE GTS22 LOOP BACK IF MORE DIGITS TO GO
17621: *
17622: * HERE GENERATE EXPONENT SIGN AND E
17623: *
17624: MOV GTSES,WA LOAD EXPONENT SIGN
17625: SCH WA,-(XR) STORE IN WORK AREA
17626: MOV =CH$LE,WA GET CHARACTER LETTER E
17627: SCH WA,-(XR) STORE IN WORK AREA
17628: SUB =NUM02,WB DECREMENT COUNTER FOR SIGN AND E
17629: *
17630: * HERE TO GENERATE THE FRACTION
17631: *
17632: GTS23 MLR GTSSC CONVERT REAL TO INTEGER (10**CFP$S)
17633: RTI GET INTEGER (OVERFLOW IMPOSSIBLE)
17634: NGI NEGATE AS REQUIRED BY CVD
17635: *
17636: * LOOP TO SUPPRESS TRAILING ZEROS
17637: *
17638: GTS24 BZE XL,GTS27 JUMP IF NO DIGITS LEFT TO DO
17639: CVD ELSE CONVERT ONE DIGIT
17640: BNE WA,=CH$D0,GTS26 JUMP IF NOT A ZERO
17641: DCV XL DECREMENT COUNTER
17642: BRN GTS24 LOOP BACK FOR NEXT DIGIT
17643: EJC
17644: *
17645: * GTSTG (CONTINUED)
17646: *
17647: * LOOP TO GENERATE DIGITS AFTER DECIMAL POINT
17648: *
17649: GTS25 CVD CONVERT A DIGIT INTO WA
17650: *
17651: * MERGE HERE FIRST TIME
17652: *
17653: GTS26 SCH WA,-(XR) STORE DIGIT
17654: DCV WB DECREMENT COUNTER
17655: DCV XL DECREMENT COUNTER
17656: BNZ XL,GTS25 LOOP BACK IF MORE TO GO
17657: *
17658: * HERE GENERATE THE DECIMAL POINT
17659: *
17660: GTS27 MOV =CH$DT,WA LOAD DECIMAL POINT
17661: SCH WA,-(XR) STORE IN WORK AREA
17662: DCV WB DECREMENT COUNTER
17663: *
17664: * HERE GENERATE THE DIGITS BEFORE THE DECIMAL POINT
17665: *
17666: GTS28 CVD CONVERT A DIGIT INTO WA
17667: SCH WA,-(XR) STORE IN WORK AREA
17668: DCV WB DECREMENT COUNTER
17669: INE GTS28 LOOP BACK IF MORE TO GO
17670: CSC XR COMPLETE STORE CHARACTERS
17671: BRN GTS08 ELSE JUMP BACK TO EXIT
17672: *
17673: * EXIT POINT AFTER SUCCESSFUL CONVERSION
17674: *
17675: GTS29 MOV (XS)+,XL RESTORE XL
17676: ICA XS POP ARGUMENT
17677: MOV GTSVB,WB RESTORE WB
17678: MOV GTSVC,WC RESTORE WC
17679: *
17680: * MERGE HERE IF NO CONVERSION REQUIRED
17681: *
17682: GTS30 MOV SCLEN(XR),WA LOAD STRING LENGTH
17683: EXI RETURN TO CALLER
17684: *
17685: * HERE TO RETURN STRING FOR REAL ZERO
17686: *
17687: GTS31 MOV =SCRE0,XL POINT TO STRING
17688: MOV =NUM02,WA 2 CHARS
17689: ZER WB ZERO OFFSET
17690: JSR SBSTR COPY STRING
17691: BRN GTS29 RETURN
17692: EJC
17693: *
17694: * HERE TO CONVERT A BUFFER BLOCK
17695: *
17696: GTS32 MOV XR,XL COPY ARG PTR
17697: MOV BCLEN(XL),WA GET SIZE TO ALLOCATE
17698: BZE WA,GTS33 IF NULL THEN RETURN NULL
17699: JSR ALOCS ALLOCATE STRING FRAME
17700: MOV XR,WB SAVE STRING PTR
17701: MOV SCLEN(XR),WA GET LENGTH TO MOVE
17702: CTB WA,0 GET AS MULTIPLE OF WORD SIZE
17703: MOV BCBUF(XL),XL POINT TO BFBLK
17704: ADD *SCSI$,XR POINT TO START OF CHARACTER AREA
17705: ADD *BFSI$,XL POINT TO START OF BUFFER CHARS
17706: MVW COPY WORDS
17707: MOV WB,XR RESTORE SCBLK PTR
17708: BRN GTS29 EXIT WITH SCBLK
17709: *
17710: * HERE WHEN NULL BUFFER IS BEING CONVERTED
17711: *
17712: GTS33 MOV =NULLS,XR POINT TO NULL
17713: BRN GTS29 EXIT WITH NULL
17714: ENP END PROCEDURE GTSTG
17715: EJC
17716: *
17717: * GTVAR -- GET VARIABLE FOR I/O/TRACE ASSOCIATION
17718: *
17719: * GTVAR IS USED TO POINT TO AN ACTUAL VARIABLE LOCATION
17720: * FOR THE DETACH,INPUT,OUTPUT,TRACE,STOPTR SYSTEM FUNCTIONS
17721: *
17722: * (XR) ARGUMENT TO FUNCTION
17723: * JSR GTVAR CALL TO LOCATE VARIABLE POINTER
17724: * PPM LOC TRANSFER LOC IF NOT OK VARIABLE
17725: * (XL,WA) NAME BASE,OFFSET OF VARIABLE
17726: * (XR,RA) DESTROYED
17727: * (WB,WC) DESTROYED (CONVERT ERROR ONLY)
17728: * (XR) INPUT ARG (CONVERT ERROR ONLY)
17729: *
17730: GTVAR PRC E,1 ENTRY POINT
17731: BNE (XR),=B$NML,GTVR2 JUMP IF NOT A NAME
17732: MOV NMOFS(XR),WA ELSE LOAD NAME OFFSET
17733: MOV NMBAS(XR),XL LOAD NAME BASE
17734: BEQ (XL),=B$EVT,GTVR1 ERROR IF EXPRESSION VARIABLE
17735: BNE (XL),=B$KVT,GTVR3 ALL OK IF NOT KEYWORD VARIABLE
17736: *
17737: * HERE ON CONVERSION ERROR
17738: *
17739: GTVR1 EXI 1 TAKE CONVERT ERROR EXIT
17740: *
17741: * HERE IF NOT A NAME, TRY CONVERT TO NATURAL VARIABLE
17742: *
17743: GTVR2 MOV WC,GTVRC SAVE WC
17744: JSR GTNVR LOCATE VRBLK IF POSSIBLE
17745: PPM GTVR1 JUMP IF CONVERT ERROR
17746: MOV XR,XL ELSE COPY VRBLK NAME BASE
17747: MOV *VRVAL,WA AND SET OFFSET
17748: MOV GTVRC,WC RESTORE WC
17749: *
17750: * HERE FOR NAME OBTAINED
17751: *
17752: GTVR3 BHI XL,STATE,GTVR4 ALL OK IF NOT NATURAL VARIABLE
17753: BEQ VRSTO(XL),=B$VRE,GTVR1 ERROR IF PROTECTED VARIABLE
17754: *
17755: * COMMON EXIT POINT
17756: *
17757: GTVR4 EXI RETURN TO CALLER
17758: ENP END PROCEDURE GTVAR
17759: EJC
17760: *
17761: * HASHS -- COMPUTE HASH INDEX FOR STRING
17762: *
17763: * HASHS IS USED TO CONVERT A STRING TO A UNIQUE INTEGER
17764: * VALUE. THE RESULTING HASH VALUE IS A POSITIVE INTEGER
17765: * IN THE RANGE 0 TO CFP$M
17766: *
17767: * (XR) STRING TO BE HASHED
17768: * JSR HASHS CALL TO HASH STRING
17769: * (IA) HASH VALUE
17770: * (XR,WB,WC) DESTROYED
17771: *
17772: * THE HASH FUNCTION USED IS AS FOLLOWS.
17773: *
17774: * START WITH THE LENGTH OF THE STRING (SGD07)
17775: *
17776: * TAKE THE FIRST E$HNW WORDS OF THE CHARACTERS FROM
17777: * THE STRING OR ALL THE WORDS IF FEWER THAN E$HNW.
17778: *
17779: * COMPUTE THE EXCLUSIVE OR OF ALL THESE WORDS TREATING
17780: * THEM AS ONE WORD BIT STRING VALUES.
17781: *
17782: * MOVE THE RESULT AS AN INTEGER WITH THE MTI INSTRUCTION.
17783: *
17784: HASHS PRC E,0 ENTRY POINT
17785: MOV SCLEN(XR),WC LOAD STRING LENGTH IN CHARACTERS
17786: MOV WC,WB INITIALIZE WITH LENGTH
17787: BZE WC,HSHS3 JUMP IF NULL STRING
17788: CTW WC,0 ELSE GET NUMBER OF WORDS OF CHARS
17789: ADD *SCHAR,XR POINT TO CHARACTERS OF STRING
17790: BLO WC,=E$HNW,HSHS1 USE WHOLE STRING IF SHORT
17791: MOV =E$HNW,WC ELSE SET TO INVOLVE FIRST E$HNW WDS
17792: *
17793: * HERE WITH COUNT OF WORDS TO CHECK IN WC
17794: *
17795: HSHS1 LCT WC,WC SET COUNTER TO CONTROL LOOP
17796: *
17797: * LOOP TO COMPUTE EXCLUSIVE OR
17798: *
17799: HSHS2 XOB (XR)+,WB EXCLUSIVE OR NEXT WORD OF CHARS
17800: BCT WC,HSHS2 LOOP TILL ALL PROCESSED
17801: *
17802: * MERGE HERE WITH EXCLUSIVE OR IN WB
17803: *
17804: HSHS3 ZGB WB ZEROISE UNDEFINED BITS
17805: ANB BITSM,WB ENSURE IN RANGE 0 TO CFP$M
17806: MTI WB MOVE RESULT AS INTEGER
17807: ZER XR CLEAR GARBAGE VALUE IN XR
17808: EXI RETURN TO HASHS CALLER
17809: ENP END PROCEDURE HASHS
17810: EJC
17811: *
17812: * ICBLD -- BUILD INTEGER BLOCK
17813: *
17814: * (IA) INTEGER VALUE FOR ICBLK
17815: * JSR ICBLD CALL TO BUILD INTEGER BLOCK
17816: * (XR) POINTER TO RESULT ICBLK
17817: * (WA) DESTROYED
17818: *
17819: ICBLD PRC E,0 ENTRY POINT
17820: MFI XR,ICBL1 COPY SMALL INTEGERS
17821: BLE XR,=NUM02,ICBL3 JUMP IF 0,1 OR 2
17822: *
17823: * CONSTRUCT ICBLK
17824: *
17825: ICBL1 MOV DNAMP,XR LOAD POINTER TO NEXT AVAILABLE LOC
17826: ADD *ICSI$,XR POINT PAST NEW ICBLK
17827: BLO XR,DNAME,ICBL2 JUMP IF THERE IS ROOM
17828: MOV *ICSI$,WA ELSE LOAD LENGTH OF ICBLK
17829: JSR ALLOC USE STANDARD ALLOCATOR TO GET BLOCK
17830: ADD WA,XR POINT PAST BLOCK TO MERGE
17831: *
17832: * MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED
17833: *
17834: ICBL2 MOV XR,DNAMP SET NEW POINTER
17835: SUB *ICSI$,XR POINT BACK TO START OF BLOCK
17836: MOV =B$ICL,(XR) STORE TYPE WORD
17837: STI ICVAL(XR) STORE INTEGER VALUE IN ICBLK
17838: EXI RETURN TO ICBLD CALLER
17839: *
17840: * OPTIMISE BY NOT BUILDING ICBLKS FOR SMALL INTEGERS
17841: *
17842: ICBL3 WTB XR CONVERT INTEGER TO OFFSET
17843: MOV INTAB(XR),XR POINT TO PRE-BUILT ICBLK
17844: EXI RETURN
17845: ENP END PROCEDURE ICBLD
17846: EJC
17847: *
17848: * IDENT -- COMPARE TWO VALUES
17849: *
17850: * IDENT COMPARES TWO VALUES IN THE SENSE OF THE IDENT
17851: * DIFFER FUNCTIONS AVAILABLE AT THE SNOBOL LEVEL.
17852: *
17853: * (XR) FIRST ARGUMENT
17854: * (XL) SECOND ARGUMENT
17855: * JSR IDENT CALL TO COMPARE ARGUMENTS
17856: * PPM LOC TRANSFER LOC IF IDENT
17857: * (NORMAL RETURN IF DIFFER)
17858: * (XR,XL,WC,RA) DESTROYED
17859: *
17860: IDENT PRC E,1 ENTRY POINT
17861: BEQ XR,XL,IDEN7 JUMP IF SAME POINTER (IDENT)
17862: MOV (XR),WC ELSE LOAD ARG 1 TYPE WORD
17863: BNE WC,(XL),IDEN1 DIFFER IF ARG 2 TYPE WORD DIFFER
17864: BEQ WC,=B$SCL,IDEN2 JUMP IF STRINGS
17865: BEQ WC,=B$ICL,IDEN4 JUMP IF INTEGERS
17866: BEQ WC,=B$RCL,IDEN5 JUMP IF REALS
17867: BEQ WC,=B$NML,IDEN6 JUMP IF NAMES
17868: *
17869: * FOR ALL OTHER DATATYPES, MUST BE DIFFER IF XR NE XL
17870: *
17871: * MERGE HERE FOR DIFFER
17872: *
17873: IDEN1 EXI TAKE DIFFER EXIT
17874: *
17875: * HERE FOR STRINGS, IDENT ONLY IF LENGTHS AND CHARS SAME
17876: *
17877: IDEN2 MOV SCLEN(XR),WC LOAD ARG 1 LENGTH
17878: BNE WC,SCLEN(XL),IDEN1 DIFFER IF LENGTHS DIFFER
17879: CTW WC,0 GET NUMBER OF WORDS IN STRINGS
17880: ADD *SCHAR,XR POINT TO CHARS OF ARG 1
17881: ADD *SCHAR,XL POINT TO CHARS OF ARG 2
17882: LCT WC,WC SET LOOP COUNTER
17883: *
17884: * LOOP TO COMPARE CHARACTERS. NOTE THAT WA CANNOT BE ZERO
17885: * SINCE ALL NULL STRINGS POINT TO NULLS AND GIVE XL=XR.
17886: *
17887: IDEN3 CNE (XR),(XL),IDEN8 DIFFER IF CHARS DO NOT MATCH
17888: ICA XR ELSE BUMP ARG ONE POINTER
17889: ICA XL BUMP ARG TWO POINTER
17890: BCT WC,IDEN3 LOOP BACK TILL ALL CHECKED
17891: EJC
17892: *
17893: * IDENT (CONTINUED)
17894: *
17895: * HERE TO EXIT FOR CASE OF TWO IDENT STRINGS
17896: *
17897: ZER XL CLEAR GARBAGE VALUE IN XL
17898: ZER XR CLEAR GARBAGE VALUE IN XR
17899: EXI 1 TAKE IDENT EXIT
17900: *
17901: * HERE FOR INTEGERS, IDENT IF SAME VALUES
17902: *
17903: IDEN4 LDI ICVAL(XR) LOAD ARG 1
17904: SBI ICVAL(XL) SUBTRACT ARG 2 TO COMPARE
17905: IOV IDEN1 DIFFER IF OVERFLOW
17906: INE IDEN1 DIFFER IF RESULT IS NOT ZERO
17907: EXI 1 TAKE IDENT EXIT
17908: *
17909: * HERE FOR REALS, IDENT IF SAME VALUES
17910: *
17911: IDEN5 LDR RCVAL(XR) LOAD ARG 1
17912: SBR RCVAL(XL) SUBTRACT ARG 2 TO COMPARE
17913: ROV IDEN1 DIFFER IF OVERFLOW
17914: RNE IDEN1 DIFFER IF RESULT IS NOT ZERO
17915: EXI 1 TAKE IDENT EXIT
17916: *
17917: * HERE FOR NAMES, IDENT IF BASES AND OFFSETS SAME
17918: *
17919: IDEN6 BNE NMOFS(XR),NMOFS(XL),IDEN1 DIFFER IF DIFFERENT OFFSET
17920: BNE NMBAS(XR),NMBAS(XL),IDEN1 DIFFER IF DIFFERENT BASE
17921: *
17922: * MERGE HERE TO SIGNAL IDENT FOR IDENTICAL POINTERS
17923: *
17924: IDEN7 EXI 1 TAKE IDENT EXIT
17925: *
17926: * HERE FOR DIFFER STRINGS
17927: *
17928: IDEN8 ZER XR CLEAR GARBAGE PTR IN XR
17929: ZER XL CLEAR GARBAGE PTR IN XL
17930: EXI RETURN TO CALLER (DIFFER)
17931: ENP END PROCEDURE IDENT
17932: EJC
17933: *
17934: * INOUT - USED TO INITIALISE INPUT AND OUTPUT VARIABLES
17935: *
17936: * (XL) POINTER TO VBL NAME STRING
17937: * (WB) TRBLK TYPE
17938: * JSR INOUT CALL TO PERFORM INITIALISATION
17939: * (XL) VRBLK PTR
17940: * (XR) TRBLK PTR
17941: * (WA,WC) DESTROYED
17942: *
17943: * NOTE THAT TRTER (= TRTRF) FIELD OF STANDARD I/O VARIABLES
17944: * POINTS TO CORRESPONDING SVBLK NOT TO A TRBLK AS IS THE
17945: * CASE FOR ORDINARY VARIABLES.
17946: *
17947: INOUT PRC E,0 ENTRY POINT
17948: MOV WB,-(XS) STACK TRBLK TYPE
17949: MOV SCLEN(XL),WA GET NAME LENGTH
17950: ZER WB POINT TO START OF NAME
17951: JSR SBSTR BUILD A PROPER SCBLK
17952: JSR GTNVR BUILD VRBLK
17953: PPM NO ERROR RETURN
17954: MOV XR,WC SAVE VRBLK POINTER
17955: MOV (XS)+,WB GET TRTER FIELD
17956: ZER XL ZERO TRFPT
17957: JSR TRBLD BUILD TRBLK
17958: MOV WC,XL RECALL VRBLK POINTER
17959: MOV VRSVP(XL),TRTER(XR) STORE SVBLK POINTER
17960: MOV XR,VRVAL(XL) STORE TRBLK PTR IN VRBLK
17961: MOV =B$VRA,VRGET(XL) SET TRAPPED ACCESS
17962: MOV =B$VRV,VRSTO(XL) SET TRAPPED STORE
17963: EXI RETURN TO CALLER
17964: ENP END PROCEDURE INOUT
17965: EJC
17966: *
17967: * INSBF -- INSERT STRING IN BUFFER
17968: *
17969: * THIS ROUTINE WILL REPLACE A SECTION OF A BUFFER WITH THE
17970: * CONTENTS OF A GIVEN STRING. IF THE LENGTH OF THE
17971: * SECTION TO BE REPLACED IS DIFFERENT THAN THE LENGTH OF
17972: * THE GIVEN STRING, AND THE REPLACEMENT IS NOT AN APPEND,
17973: * THEN THE UPPER SECTION OF THE BUFFER IS SHIFTED UP OR
17974: * DOWN TO CREATE THE PROPER SPACE FOR THE INSERT.
17975: *
17976: * (XR) POINTER TO BFBLK
17977: * (XL) OBJECT WHICH IS STRING CONVERTABLE
17978: * (WA) OFFSET OF START OF INSERT IN (XR)
17979: * (WB) LENGTH OF SECTION IN (XR) REPLACED
17980: * JSR INSBF CALL TO INSERT CHARACTERS IN BUFFER
17981: * PPM LOC THREAD IF (XR) NOT CONVERTABLE
17982: * PPM LOC THREAD IF INSERT NOT POSSIBLE
17983: *
17984: * THE SECOND ALTERNATE EXIT IS TAKEN IF THE INSERT WOULD
17985: * OVERFLOW THE BUFFER, OR IF THE INSERT IS OUT PAST THE
17986: * DEFINED END OF THE BUFFER AS GIVEN.
17987: *
17988: INSBF PRC E,2 ENTRY POINT
17989: MOV WA,INSSA SAVE ENTRY WA
17990: MOV WB,INSSB SAVE ENTRY WB
17991: MOV WC,INSSC SAVE ENTRY WC
17992: ADD WB,WA ADD TO GET OFFSET PAST REPLACE PART
17993: MOV WA,INSAB SAVE WA+WB
17994: MOV BCLEN(XR),WC GET CURRENT DEFINED LENGTH
17995: BGT INSSA,WC,INS07 FAIL IF START OFFSET TOO BIG
17996: BGT WA,WC,INS07 FAIL IF FINAL OFFSET TOO BIG
17997: MOV XL,-(XS) SAVE ENTRY XL
17998: MOV XR,-(XS) SAVE BCBLK PTR
17999: MOV XL,-(XS) STACK AGAIN FOR GTSTG
18000: JSR GTSTG CALL TO CONVERT TO STRING
18001: PPM INS05 TAKE STRING CONVERT ERR EXIT
18002: MOV XR,XL SAVE STRING PTR
18003: MOV (XS),XR RESTORE BCBLK PTR
18004: ADD WC,WA ADD BUFFER LEN TO STRING LEN
18005: SUB INSSB,WA BIAS OUT COMPONENT BEING REPLACED
18006: MOV BCBUF(XR),XR POINT TO BFBLK
18007: BGT WA,BFALC(XR),INS06 FAIL IF RESULT EXCEEDS ALLOCATION
18008: MOV (XS),XR RESTORE BCBLK PTR
18009: MOV WC,WA GET BUFFER LENGTH
18010: SUB INSAB,WA SUBTRACT TO GET SHIFT LENGTH
18011: ADD SCLEN(XL),WC ADD LENGTH OF NEW
18012: SUB INSSB,WC SUBTRACT OLD TO GET TOTAL NEW LEN
18013: MOV BCLEN(XR),WB GET OLD BCLEN
18014: MOV WC,BCLEN(XR) STUFF NEW LENGTH
18015: BZE WA,INS04 SKIP SHIFT IF NOTHING TO DO
18016: BEQ INSSB,SCLEN(XL),INS04 SKIP SHIFT IF LENGTHS MATCH
18017: MOV BCBUF(XR),XR POINT TO BFBLK
18018: MOV XL,-(XS) SAVE SCBLK PTR
18019: BLO INSSB,SCLEN(XL),INS01 BRN IF SHFT IS FOR MORE ROOM
18020: EJC
18021: *
18022: * INSBF (CONTINUED)
18023: *
18024: * WE ARE SHIFTING THE UPPER SEGMENT DOWN TO COMPACT
18025: * THE BUFFER. (THE STRING LENGTH IS SMALLER THAN THE
18026: * SEGMENT BEING REPLACED.) REGISTERS ARE SET AS:
18027: *
18028: * (WA) MOVE (SHIFT DOWN) LENGTH
18029: * (WB) OLD BCLEN
18030: * (WC) NEW BCLEN
18031: * (XR) BFBLK PTR
18032: * (XL),(XS) SCBLK PTR
18033: *
18034: MOV INSSA,WB GET OFFSET TO INSERT
18035: ADD SCLEN(XL),WB ADD INSERT LENGTH TO GET DEST OFF
18036: MOV XR,XL MAKE COPY
18037: PLC XL,INSAB PREPARE SOURCE FOR MOVE
18038: PSC XR,WB PREPARE DESTINATION REG FOR MOVE
18039: MVC MOVE EM OUT
18040: BRN INS02 BRANCH TO PAD
18041: *
18042: * WE ARE SHIFTING THE UPPER SEGMENT UP TO EXPAND
18043: * THE BUFFER. (THE STRING LENGTH IS LARGER THAN THE
18044: * SEGMENT BEING REPLACED.)
18045: *
18046: INS01 MOV XR,XL COPY BFBLK PTR
18047: PLC XL,WB SET SOURCE REG FOR MOVE BACKWARDS
18048: PSC XR,WC SET DESTINATION PTR FOR MOVE
18049: MCB MOVE BACKWARDS (POSSIBLE OVERLAP)
18050: *
18051: * MERGE HERE AFTER MOVE TO ADJUST PADDING AT NEW BUFFER END
18052: *
18053: INS02 MOV (XS)+,XL RESTORE SCBLK PTR
18054: MOV WC,WA COPY NEW BUFFER END
18055: CTB WA,0 ROUND OUT
18056: SUB WC,WA SUBTRACT TO GET REMAINDER
18057: BZE WA,INS04 NO PAD IF ALREADY EVEN BOUNDARY
18058: MOV (XS),XR GET BCBLK PTR
18059: MOV BCBUF(XR),XR GET BFBLK PTR
18060: PSC XR,WC PREPARE TO PAD
18061: ZER WB CLEAR WB
18062: LCT WA,WA LOAD LOOP COUNT
18063: *
18064: * LOOP HERE TO STUFF PAD CHARACTERS
18065: *
18066: INS03 SCH WB,(XR)+ STUFF ZERO PAD
18067: BCT WA,INS03 BRANCH FOR MORE
18068: EJC
18069: *
18070: * INSBF (CONTINUED)
18071: *
18072: * MERGE HERE WHEN PADDING OK. NOW COPY IN THE INSERT
18073: * STRING TO THE HOLE.
18074: *
18075: INS04 MOV (XS),XR GET BCBLK PTR
18076: MOV BCBUF(XR),XR GET BFBLK PTR
18077: MOV SCLEN(XL),WA GET MOVE LENGTH
18078: PLC XL PREPARE TO COPY FROM FIRST CHAR
18079: PSC XR,INSSA PREPARE TO STORE IN HOLE
18080: MVC COPY THE CHARACTERS
18081: MOV (XS)+,XR RESTORE ENTRY XR
18082: MOV (XS)+,XL RESTORE ENTRY XL
18083: MOV INSSA,WA RESTORE ENTRY WA
18084: MOV INSSB,WB RESTORE ENTRY WB
18085: MOV INSSC,WC RESTORE ENTRY WC
18086: EXI RETURN TO CALLER
18087: *
18088: * HERE TO TAKE STRING CONVERT ERROR EXIT
18089: *
18090: INS05 MOV (XS)+,XR RESTORE ENTRY XR
18091: MOV (XS)+,XL RESTORE ENTRY XL
18092: MOV INSSA,WA RESTORE ENTRY WA
18093: MOV INSSB,WB RESTORE ENTRY WB
18094: MOV INSSC,WC RESTORE ENTRY WC
18095: EXI 1 ALTERNATE EXIT
18096: *
18097: * HERE FOR INVALID OFFSET OR LENGTH
18098: *
18099: INS06 MOV (XS)+,XR RESTORE ENTRY XR
18100: MOV (XS)+,XL RESTORE ENTRY XL
18101: *
18102: * MERGE FOR LENGTH FAILURE EXIT WITH STACK SET
18103: *
18104: INS07 MOV INSSA,WA RESTORE ENTRY WA
18105: MOV INSSB,WB RESTORE ENTRY WB
18106: MOV INSSC,WC RESTORE ENTRY WC
18107: EXI 2 ALTERNATE EXIT
18108: ENP END PROCEDURE INSBF
18109: EJC
18110: *
18111: * IOFCB -- GET INPUT/OUTPUT FCBLK POINTER
18112: *
18113: * USED BY ENDFILE, EJECT AND REWIND TO FIND THE FCBLK
18114: * (IF ANY) CORRESPONDING TO THEIR ARGUMENT.
18115: *
18116: * -(XS) ARGUMENT
18117: * JSR IOFCB CALL TO FIND FCBLK
18118: * PPM LOC ARG IS AN UNSUITABLE NAME
18119: * PPM LOC ARG IS NULL STRING
18120: * (XS) POPPED
18121: * (XL) PTR TO FILEARG1 VRBLK
18122: * (XR) ARGUMENT
18123: * (WA) FCBLK PTR OR 0
18124: * (WB) DESTROYED
18125: *
18126: IOFCB PRC N,2 ENTRY POINT
18127: JSR GTSTG GET ARG AS STRING
18128: PPM IOFC2 FAIL
18129: MOV XR,XL COPY STRING PTR
18130: JSR GTNVR GET AS NATURAL VARIABLE
18131: PPM IOFC3 FAIL IF NULL
18132: MOV XL,WB COPY STRING POINTER AGAIN
18133: MOV XR,XL COPY VRBLK PTR FOR RETURN
18134: ZER WA IN CASE NO TRBLK FOUND
18135: *
18136: * LOOP TO FIND FILE ARG1 TRBLK
18137: *
18138: IOFC1 MOV VRVAL(XR),XR GET POSSIBLE TRBLK PTR
18139: BNE (XR),=B$TRT,IOFC2 FAIL IF END OF CHAIN
18140: BNE TRTYP(XR),=TRTFC,IOFC1 LOOP IF NOT FILE ARG TRBLK
18141: MOV TRFPT(XR),WA GET FCBLK PTR
18142: MOV WB,XR COPY ARG
18143: EXI RETURN
18144: *
18145: * FAIL RETURN
18146: *
18147: IOFC2 EXI 1 FAIL
18148: *
18149: * NULL ARG
18150: *
18151: IOFC3 EXI 2 NULL ARG RETURN
18152: ENP END PROCEDURE IOFCB
18153: EJC
18154: *
18155: * IOPPF -- PROCESS FILEARG2 FOR IOPUT
18156: *
18157: * (R$XSC) FILEARG2 PTR
18158: * JSR IOPPF CALL TO PROCESS FILEARG2
18159: * (XL) FILEARG1 PTR
18160: * (XR) FILE ARG2 PTR
18161: * -(XS)..-(XS) FIELDS EXTRACTED FROM FILEARG2
18162: * (WC) NO. OF FIELDS EXTRACTED
18163: * (WB) INPUT/OUTPUT FLAG
18164: * (WA) FCBLK PTR OR 0
18165: *
18166: IOPPF PRC N,0 ENTRY POINT
18167: ZER WB TO COUNT FIELDS EXTRACTED
18168: *
18169: * LOOP TO EXTRACT FIELDS
18170: *
18171: IOPP1 MOV =IODEL,XL GET DELIMITER
18172: MOV XL,WC COPY IT
18173: JSR XSCAN GET NEXT FIELD
18174: MOV XR,-(XS) STACK IT
18175: ICV WB INCREMENT COUNT
18176: BNZ WA,IOPP1 LOOP
18177: MOV WB,WC COUNT OF FIELDS
18178: MOV IOPTT,WB I/O MARKER
18179: MOV R$IOF,WA FCBLK PTR OR 0
18180: MOV R$IO2,XR FILE ARG2 PTR
18181: MOV R$IO1,XL FILEARG1
18182: EXI RETURN
18183: ENP END PROCEDURE IOPPF
18184: EJC
18185: *
18186: * IOPUT -- ROUTINE USED BY INPUT AND OUTPUT
18187: *
18188: * IOPUT SETS UP INPUT/OUTPUT ASSOCIATIONS. IT BUILDS
18189: * SUCH TRACE AND FILE CONTROL BLOCKS AS ARE NECESSARY AND
18190: * CALLS SYSFC,SYSIO TO PERFORM CHECKS ON THE
18191: * ARGUMENTS AND TO OPEN THE FILES.
18192: *
18193: * +-----------+ +---------------+ +-----------+
18194: * +-.I I I I------.I =B$XRT I
18195: * I +-----------+ +---------------+ +-----------+
18196: * I / / (R$FCB) I *4 I
18197: * I / / +-----------+
18198: * I +-----------+ +---------------+ I I-
18199: * I I NAME +--.I =B$TRT I +-----------+
18200: * I / / +---------------+ I I
18201: * I (FIRST ARG) I =TRTIN/=TRTOU I +-----------+
18202: * I +---------------+ I
18203: * I I VALUE I I
18204: * I +---------------+ I
18205: * I I(TRTRF) 0 OR I--+ I
18206: * I +---------------+ I I
18207: * I I(TRFPT) 0 OR I----+ I
18208: * I +---------------+ I I I
18209: * I (I/O TRBLK) I I I
18210: * I +-----------+ I I I
18211: * I I I I I I
18212: * I +-----------+ I I I
18213: * I I I I I I
18214: * I +-----------+ +---------------+ I I I
18215: * I I +--.I =B$TRT I.-+ I I
18216: * I +-----------+ +---------------+ I I
18217: * I / / I =TRTFC I I I
18218: * I / / +---------------+ I I
18219: * I (FILEARG1 I VALUE I I I
18220: * I VRBLK) +---------------+ I I
18221: * I I(TRTRF) 0 OR I--+ I .
18222: * I +---------------+ I . +-----------+
18223: * I I(TRFPT) 0 OR I------./ FCBLK /
18224: * I +---------------+ I +-----------+
18225: * I (TRTRF) I
18226: * I I
18227: * I I
18228: * I +---------------+ I
18229: * I I =B$XRT I.-+
18230: * I +---------------+
18231: * I I *5 I
18232: * I +---------------+
18233: * +------------------I I
18234: * +---------------+ +-----------+
18235: * I(TRTRF) O OR I------.I =B$XRT I
18236: * +---------------+ +-----------+
18237: * I NAME OFFSET I I ETC I
18238: * +---------------+
18239: * (IOCHN - CHAIN OF NAME POINTERS)
18240: EJC
18241: *
18242: * IOPUT (CONTINUED)
18243: *
18244: * NO ADDITIONAL TRAP BLOCKS ARE USED FOR STANDARD INPUT/OUT
18245: * FILES. OTHERWISE AN I/O TRAP BLOCK IS ATTACHED TO SECOND
18246: * ARG (FILEARG1) VRBLK. SEE DIAGRAM ABOVE FOR DETAILS OF
18247: * THE STRUCTURE BUILT.
18248: *
18249: * -(XS) 1ST ARG (VBL TO BE ASSOCIATED)
18250: * -(XS) 2ND ARG (FILE ARG1)
18251: * -(XS) 3RD ARG (FILE ARG2)
18252: * (WB) 0 FOR INPUT, 3 FOR OUTPUT ASSOC.
18253: * JSR IOPUT CALL FOR INPUT/OUTPUT ASSOCIATION
18254: * PPM LOC 3RD ARG NOT A STRING
18255: * PPM LOC 2ND ARG NOT A SUITABLE NAME
18256: * PPM LOC 1ST ARG NOT A SUITABLE NAME
18257: * PPM LOC INAPPROPRIATE FILE SPEC FOR I/O
18258: * PPM LOC I/O FILE DOES NOT EXIST
18259: * PPM LOC I/O FILE CANNOT BE READ/WRITTEN
18260: * (XS) POPPED
18261: * (XL,XR,WA,WB,WC) DESTROYED
18262: *
18263: IOPUT PRC N,6 ENTRY POINT
18264: ZER R$IOT IN CASE NO TRTRF BLOCK USED
18265: ZER R$IOF IN CASE NO FCBLK ALOCATED
18266: MOV WB,IOPTT STORE I/O TRACE TYPE
18267: JSR XSCNI PREPARE TO SCAN FILEARG2
18268: PPM IOP13 FAIL
18269: PPM IOPA0 NULL FILE ARG2
18270: *
18271: IOPA0 MOV XR,R$IO2 KEEP FILE ARG2
18272: MOV WA,XL COPY LENGTH
18273: JSR GTSTG CONVERT FILEARG1 TO STRING
18274: PPM IOP14 FAIL
18275: MOV XR,R$IO1 KEEP FILEARG1 PTR
18276: JSR GTNVR CONVERT TO NATURAL VARIABLE
18277: PPM IOP00 JUMP IF NULL
18278: BRN IOP04 JUMP TO PROCESS NON-NULL ARGS
18279: *
18280: * NULL FILEARG1
18281: *
18282: IOP00 BZE XL,IOP01 SKIP IF BOTH ARGS NULL
18283: JSR IOPPF PROCESS FILEARG2
18284: JSR SYSFC CALL FOR FILEARG2 CHECK
18285: PPM IOP16 FAIL
18286: BRN IOP11 COMPLETE FILE ASSOCIATION
18287: EJC
18288: *
18289: * IOPUT (CONTINUED)
18290: *
18291: * HERE WITH 0 OR FCBLK PTR IN (XL)
18292: *
18293: IOP01 MOV IOPTT,WB GET TRACE TYPE
18294: MOV R$IOT,XR GET 0 OR TRTRF PTR
18295: JSR TRBLD BUILD TRBLK
18296: MOV XR,WC COPY TRBLK POINTER
18297: MOV (XS)+,XR GET VARIABLE FROM STACK
18298: JSR GTVAR POINT TO VARIABLE
18299: PPM IOP15 FAIL
18300: MOV XL,R$ION SAVE NAME POINTER
18301: MOV XL,XR COPY NAME POINTER
18302: ADD WA,XR POINT TO VARIABLE
18303: SUB *VRVAL,XR SUBTRACT OFFSET,MERGE INTO LOOP
18304: *
18305: * LOOP TO END OF TRBLK CHAIN IF ANY
18306: *
18307: IOP02 MOV XR,XL COPY BLK PTR
18308: MOV VRVAL(XR),XR LOAD PTR TO NEXT TRBLK
18309: BNE (XR),=B$TRT,IOP03 JUMP IF NOT TRAPPED
18310: BNE TRTYP(XR),IOPTT,IOP02 LOOP IF NOT SAME ASSOCN
18311: MOV TRNXT(XR),XR GET VALUE AND DELETE OLD TRBLK
18312: *
18313: * IOPUT (CONTINUED)
18314: *
18315: * STORE NEW ASSOCIATION
18316: *
18317: IOP03 MOV WC,VRVAL(XL) LINK TO THIS TRBLK
18318: MOV WC,XL COPY POINTER
18319: MOV XR,TRNXT(XL) STORE VALUE IN TRBLK
18320: MOV R$ION,XR RESTORE POSSIBLE VRBLK POINTER
18321: MOV WA,WB KEEP OFFSET TO NAME
18322: JSR SETVR IF VRBLK, SET VRGET,VRSTO
18323: MOV R$IOT,XR GET 0 OR TRTRF PTR
18324: BNZ XR,IOP19 JUMP IF TRTRF BLOCK EXISTS
18325: EXI RETURN TO CALLER
18326: *
18327: * NON STANDARD FILE
18328: * SEE IF AN FCBLK HAS ALREADY BEEN ALLOCATED.
18329: *
18330: IOP04 ZER WA IN CASE NO FCBLK FOUND
18331: EJC
18332: *
18333: * IOPUT (CONTINUED)
18334: *
18335: * SEARCH POSSIBLE TRBLK CHAIN TO PICK UP THE FCBLK
18336: *
18337: IOP05 MOV XR,WB REMEMBER BLK PTR
18338: MOV VRVAL(XR),XR CHAIN ALONG
18339: BNE (XR),=B$TRT,IOP06 JUMP IF END OF TRBLK CHAIN
18340: BNE TRTYP(XR),=TRTFC,IOP05 LOOP IF MORE TO GO
18341: MOV XR,R$IOT POINT TO FILE ARG1 TRBLK
18342: MOV TRFPT(XR),WA GET FCBLK PTR FROM TRBLK
18343: *
18344: * WA = 0 OR FCBLK PTR
18345: * WB = PTR TO PRECEDING BLK TO WHICH ANY TRTRF BLOCK
18346: * FOR FILE ARG1 MUST BE CHAINED.
18347: *
18348: IOP06 MOV WA,R$IOF KEEP POSSIBLE FCBLK PTR
18349: MOV WB,R$IOP KEEP PRECEDING BLK PTR
18350: JSR IOPPF PROCESS FILEARG2
18351: JSR SYSFC SEE IF FCBLK REQUIRED
18352: PPM IOP16 FAIL
18353: BZE WA,IOP12 SKIP IF NO NEW FCBLK WANTED
18354: BLT WC,=NUM02,IOP6A JUMP IF FCBLK IN DYNAMIC
18355: JSR ALOST GET IT IN STATIC
18356: BRN IOP6B SKIP
18357: *
18358: * OBTAIN FCBLK IN DYNAMIC
18359: *
18360: IOP6A JSR ALLOC GET SPACE FOR FCBLK
18361: *
18362: * MERGE
18363: *
18364: IOP6B MOV XR,XL POINT TO FCBLK
18365: MOV WA,WB COPY ITS LENGTH
18366: BTW WB GET COUNT AS WORDS (SGD APR80)
18367: LCT WB,WB LOOP COUNTER
18368: *
18369: * CLEAR FCBLK
18370: *
18371: IOP07 ZER (XR)+ CLEAR A WORD
18372: BCT WB,IOP07 LOOP
18373: BEQ WC,=NUM02,IOP09 SKIP IF IN STATIC - DONT SET FIELDS
18374: MOV =B$XNT,(XL) STORE XNBLK CODE IN CASE
18375: MOV WA,1(XL) STORE LENGTH
18376: BNZ WC,IOP09 JUMP IF XNBLK WANTED
18377: MOV =B$XRT,(XL) XRBLK CODE REQUESTED
18378: *
18379: EJC
18380: * IOPUT (CONTINUED)
18381: *
18382: * COMPLETE FCBLK INITIALISATION
18383: *
18384: IOP09 MOV R$IOT,XR GET POSSIBLE TRBLK PTR
18385: MOV XL,R$IOF STORE FCBLK PTR
18386: BNZ XR,IOP10 JUMP IF TRBLK ALREADY FOUND
18387: *
18388: * A NEW TRBLK IS NEEDED
18389: *
18390: MOV =TRTFC,WB TRTYP FOR FCBLK TRAP BLK
18391: JSR TRBLD MAKE THE BLOCK
18392: MOV XR,R$IOT COPY TRTRF PTR
18393: MOV R$IOP,XL POINT TO PRECEDING BLK
18394: MOV VRVAL(XL),VRVAL(XR) COPY VALUE FIELD TO TRBLK
18395: MOV XR,VRVAL(XL) LINK NEW TRBLK INTO CHAIN
18396: MOV XL,XR POINT TO PREDECESSOR BLK
18397: JSR SETVR SET TRACE INTERCEPTS
18398: MOV VRVAL(XR),XR RECOVER TRBLK PTR
18399: *
18400: * XR IS PTR TO TRBLK, XL IS FCBLK PTR OR 0
18401: *
18402: IOP10 MOV R$IOF,TRFPT(XR) STORE FCBLK PTR
18403: *
18404: * CALL SYSIO TO COMPLETE FILE ACCESSING
18405: *
18406: IOP11 MOV R$IOF,WA COPY FCBLK PTR OR 0
18407: MOV IOPTT,WB GET INPUT/OUTPUT FLAG
18408: MOV R$IO2,XR GET FILE ARG2
18409: MOV R$IO1,XL GET FILE ARG1
18410: JSR SYSIO ASSOCIATE TO THE FILE
18411: PPM IOP17 FAIL
18412: PPM IOP18 FAIL
18413: BNZ R$IOT,IOP01 NOT STD INPUT IF NON-NULL TRTRF BLK
18414: BNZ IOPTT,IOP01 JUMP IF OUTPUT
18415: BZE WC,IOP01 NO CHANGE TO STANDARD READ LENGTH
18416: MOV WC,CSWIN STORE NEW READ LENGTH FOR STD FILE
18417: BRN IOP01 MERGE TO FINISH THE TASK
18418: *
18419: * SYSFC MAY HAVE RETURNED A POINTER TO A PRIVATE FCBLK
18420: *
18421: IOP12 BNZ XL,IOP09 JUMP IF PRIVATE FCBLK
18422: BRN IOP11 FINISH THE ASSOCIATION
18423: *
18424: * FAILURE RETURNS
18425: *
18426: IOP13 EXI 1 3RD ARG NOT A STRING
18427: IOP14 EXI 2 2ND ARG UNSUITABLE
18428: IOP15 EXI 3 1ST ARG UNSUITABLE
18429: IOP16 EXI 4 FILE SPEC WRONG
18430: IOP17 EXI 5 I/O FILE DOES NOT EXIST
18431: IOP18 EXI 6 I/O FILE CANNOT BE READ/WRITTEN
18432: EJC
18433: *
18434: * IOPUT (CONTINUED)
18435: *
18436: * ADD TO IOCHN CHAIN OF ASSSOCIATED VARIABLES UNLESS ALREAD
18437: * PRESENT.
18438: *
18439: IOP19 MOV R$ION,WC WC = NAME BASE, WB = NAME OFFSET
18440: *
18441: * SEARCH LOOP
18442: *
18443: IOP20 MOV TRTRF(XR),XR NEXT LINK OF CHAIN
18444: BZE XR,IOP21 NOT FOUND
18445: BNE WC,IONMB(XR),IOP20 NO MATCH
18446: BEQ WB,IONMO(XR),IOP22 EXIT IF MATCHED
18447: BRN IOP20 LOOP
18448: *
18449: * NOT FOUND
18450: *
18451: IOP21 MOV *NUM05,WA SPACE NEEDED
18452: JSR ALLOC GET IT
18453: MOV =B$XRT,(XR) STORE XRBLK CODE
18454: MOV WA,1(XR) STORE LENGTH
18455: MOV WC,IONMB(XR) STORE NAME BASE
18456: MOV WB,IONMO(XR) STORE NAME OFFSET
18457: MOV R$IOT,XL POINT TO TRTRF BLK
18458: MOV TRTRF(XL),WA GET PTR FIELD CONTENTS
18459: MOV XR,TRTRF(XL) STORE PTR TO NEW BLOCK
18460: MOV WA,TRTRF(XR) COMPLETE THE LINKING
18461: *
18462: * INSERT FCBLK ON FCBLK CHAIN FOR SYSEJ, SYSXI
18463: *
18464: IOP22 BZE R$IOF,IOP25 SKIP IF NO FCBLK
18465: MOV R$FCB,XL PTR TO HEAD OF EXISTING CHAIN
18466: *
18467: * SEE IF FCBLK ALREADY ON CHAIN
18468: *
18469: IOP23 BZE XL,IOP24 NOT ON IF END OF CHAIN
18470: BEQ 3(XL),R$IOF,IOP25 DONT DUPLICATE IF FIND IT
18471: MOV 2(XL),XL GET NEXT LINK
18472: BRN IOP23 LOOP
18473: *
18474: * NOT FOUND SO ADD AN ENTRY FOR THIS FCBLK
18475: *
18476: IOP24 MOV *NUM04,WA SPACE NEEDED
18477: JSR ALLOC GET IT
18478: MOV =B$XRT,(XR) STORE BLOCK CODE
18479: MOV WA,1(XR) STORE LENGTH
18480: MOV R$FCB,2(XR) STORE PREVIOUS LINK IN THIS NODE
18481: MOV R$IOF,3(XR) STORE FCBLK PTR
18482: MOV XR,R$FCB INSERT NODE INTO FCBLK CHAIN
18483: *
18484: * RETURN
18485: *
18486: IOP25 EXI RETURN TO CALLER
18487: ENP END PROCEDURE IOPUT
18488: EJC
18489: *
18490: * KTREX -- EXECUTE KEYWORD TRACE
18491: *
18492: * KTREX IS USED TO EXECUTE A POSSIBLE KEYWORD TRACE. IT
18493: * INCLUDES THE TEST ON TRACE AND TESTS FOR TRACE ACTIVE.
18494: *
18495: * (XL) PTR TO TRBLK (OR 0 IF UNTRACED)
18496: * JSR KTREX CALL TO EXECUTE KEYWORD TRACE
18497: * (XL,WA,WB,WC) DESTROYED
18498: * (RA) DESTROYED
18499: *
18500: KTREX PRC R,0 ENTRY POINT (RECURSIVE)
18501: BZE XL,KTRX3 IMMEDIATE EXIT IF KEYWORD UNTRACED
18502: BZE KVTRA,KTRX3 IMMEDIATE EXIT IF TRACE = 0
18503: DCV KVTRA ELSE DECREMENT TRACE
18504: MOV XR,-(XS) SAVE XR
18505: MOV XL,XR COPY TRBLK POINTER
18506: MOV TRKVR(XR),XL LOAD VRBLK POINTER (NMBAS)
18507: MOV *VRVAL,WA SET NAME OFFSET
18508: BZE TRFNC(XR),KTRX1 JUMP IF PRINT TRACE
18509: JSR TRXEQ ELSE EXECUTE FULL TRACE
18510: BRN KTRX2 AND JUMP TO EXIT
18511: *
18512: * HERE FOR PRINT TRACE
18513: *
18514: KTRX1 MOV XL,-(XS) STACK VRBLK PTR FOR KWNAM
18515: MOV WA,-(XS) STACK OFFSET FOR KWNAM
18516: JSR PRTSN PRINT STATEMENT NUMBER
18517: MOV =CH$AM,WA LOAD AMPERSAND
18518: JSR PRTCH PRINT AMPERSAND
18519: JSR PRTNM PRINT KEYWORD NAME
18520: MOV =TMBEB,XR POINT TO BLANK-EQUAL-BLANK
18521: JSR PRTST PRINT BLANK-EQUAL-BLANK
18522: JSR KWNAM GET KEYWORD PSEUDO-VARIABLE NAME
18523: MOV XR,DNAMP RESET PTR TO DELETE KVBLK
18524: JSR ACESS GET KEYWORD VALUE
18525: PPM FAILURE IS IMPOSSIBLE
18526: JSR PRTVL PRINT KEYWORD VALUE
18527: JSR PRTNL TERMINATE PRINT LINE
18528: *
18529: * HERE TO EXIT AFTER COMPLETING TRACE
18530: *
18531: KTRX2 MOV (XS)+,XR RESTORE ENTRY XR
18532: *
18533: * MERGE HERE TO EXIT IF NO TRACE REQUIRED
18534: *
18535: KTRX3 EXI RETURN TO KTREX CALLER
18536: ENP END PROCEDURE KTREX
18537: EJC
18538: *
18539: * KWNAM -- GET PSEUDO-VARIABLE NAME FOR KEYWORD
18540: *
18541: * 1(XS) NAME BASE FOR VRBLK
18542: * 0(XS) OFFSET (SHOULD BE *VRVAL)
18543: * JSR KWNAM CALL TO GET PSEUDO-VARIABLE NAME
18544: * (XS) POPPED TWICE
18545: * (XL,WA) RESULTING PSEUDO-VARIABLE NAME
18546: * (XR,WA,WB) DESTROYED
18547: *
18548: KWNAM PRC N,0 ENTRY POINT
18549: ICA XS IGNORE NAME OFFSET
18550: MOV (XS)+,XR LOAD NAME BASE
18551: BGE XR,STATE,KWNM1 JUMP IF NOT NATURAL VARIABLE NAME
18552: BNZ VRLEN(XR),KWNM1 ERROR IF NOT SYSTEM VARIABLE
18553: MOV VRSVP(XR),XR ELSE POINT TO SVBLK
18554: MOV SVBIT(XR),WA LOAD BIT MASK
18555: ANB BTKNM,WA AND WITH KEYWORD BIT
18556: ZRB WA,KWNM1 ERROR IF NO KEYWORD ASSOCIATION
18557: MOV SVLEN(XR),WA ELSE LOAD NAME LENGTH IN CHARACTERS
18558: CTB WA,SVCHS COMPUTE OFFSET TO FIELD WE WANT
18559: ADD WA,XR POINT TO SVKNM FIELD
18560: MOV (XR),WB LOAD SVKNM VALUE
18561: MOV *KVSI$,WA SET SIZE OF KVBLK
18562: JSR ALLOC ALLOCATE KVBLK
18563: MOV =B$KVT,(XR) STORE TYPE WORD
18564: MOV WB,KVNUM(XR) STORE KEYWORD NUMBER
18565: MOV =TRBKV,KVVAR(XR) SET DUMMY TRBLK POINTER
18566: MOV XR,XL COPY KVBLK POINTER
18567: MOV *KVVAR,WA SET PROPER OFFSET
18568: EXI RETURN TO KVNAM CALLER
18569: *
18570: * HERE IF NOT KEYWORD NAME
18571: *
18572: KWNM1 ERB 251,KEYWORD OPERAND IS NOT NAME OF DEFINED KEYWORD
18573: ENP END PROCEDURE KWNAM
18574: EJC
18575: *
18576: * LCOMP-- COMPARE TWO STRINGS LEXICALLY
18577: *
18578: * 1(XS) FIRST ARGUMENT
18579: * 0(XS) SECOND ARGUMENT
18580: * JSR LCOMP CALL TO COMPARE ARUMENTS
18581: * PPM LOC TRANSFER LOC FOR ARG1 NOT STRING
18582: * PPM LOC TRANSFER LOC FOR ARG2 NOT STRING
18583: * PPM LOC TRANSFER LOC IF ARG1 LLT ARG2
18584: * PPM LOC TRANSFER LOC IF ARG1 LEQ ARG2
18585: * PPM LOC TRANSFER LOC IF ARG1 LGT ARG2
18586: * (THE NORMAL RETURN IS NEVER TAKEN)
18587: * (XS) POPPED TWICE
18588: * (XR,XL) DESTROYED
18589: * (WA,WB,WC,RA) DESTROYED
18590: *
18591: LCOMP PRC N,5 ENTRY POINT
18592: JSR GTSTG CONVERT SECOND ARG TO STRING
18593: PPM LCMP6 JUMP IF SECOND ARG NOT STRING
18594: MOV XR,XL ELSE SAVE POINTER
18595: MOV WA,WB AND LENGTH
18596: JSR GTSTG CONVERT FIRST ARGUMENT TO STRING
18597: PPM LCMP5 JUMP IF NOT STRING
18598: MOV WA,WC SAVE ARG 1 LENGTH
18599: PLC XR POINT TO CHARS OF ARG 1
18600: PLC XL POINT TO CHARS OF ARG 2
18601: BLO WA,WB,LCMP1 JUMP IF ARG 1 LENGTH IS SMALLER
18602: MOV WB,WA ELSE SET ARG 2 LENGTH AS SMALLER
18603: *
18604: * HERE WITH SMALLER LENGTH IN (WA)
18605: *
18606: LCMP1 CMC LCMP4,LCMP3 COMPARE STRINGS, JUMP IF UNEQUAL
18607: BNE WB,WC,LCMP2 IF EQUAL, JUMP IF LENGTHS UNEQUAL
18608: EXI 4 ELSE IDENTICAL STRINGS, LEQ EXIT
18609: EJC
18610: *
18611: * LCOMP (CONTINUED)
18612: *
18613: * HERE IF INITIAL STRINGS IDENTICAL, BUT LENGTHS UNEQUAL
18614: *
18615: LCMP2 BHI WC,WB,LCMP4 JUMP IF ARG 1 LENGTH GT ARG 2 LENG
18616: *
18617: * HERE IF FIRST ARG LLT SECOND ARG
18618: *
18619: LCMP3 EXI 3 TAKE LLT EXIT
18620: *
18621: * HERE IF FIRST ARG LGT SECOND ARG
18622: *
18623: LCMP4 EXI 5 TAKE LGT EXIT
18624: *
18625: * HERE IF FIRST ARG IS NOT A STRING
18626: *
18627: LCMP5 EXI 1 TAKE BAD FIRST ARG EXIT
18628: *
18629: * HERE FOR SECOND ARG NOT A STRING
18630: *
18631: LCMP6 EXI 2 TAKE BAD SECOND ARG ERROR EXIT
18632: ENP END PROCEDURE LCOMP
18633: EJC
18634: *
18635: * LISTR -- LIST SOURCE LINE
18636: *
18637: * LISTR IS USED TO LIST A SOURCE LINE DURING THE INITIAL
18638: * COMPILATION. IT IS CALLED FROM SCANE AND SCANL.
18639: *
18640: * JSR LISTR CALL TO LIST LINE
18641: * (XR,XL,WA,WB,WC) DESTROYED
18642: *
18643: * GLOBAL LOCATIONS USED BY LISTR
18644: *
18645: * ERLST IF LISTING ON ACCOUNT OF AN ERROR
18646: *
18647: * LSTLC COUNT LINES ON CURRENT PAGE
18648: *
18649: * LSTNP MAX NUMBER OF LINES/PAGE
18650: *
18651: * LSTPF SET NON-ZERO IF THE CURRENT SOURCE
18652: * LINE HAS BEEN LISTED, ELSE ZERO.
18653: *
18654: * LSTPG COMPILER LISTING PAGE NUMBER
18655: *
18656: * LSTSN SET IF STMNT NUM TO BE LISTED
18657: *
18658: * R$CIM POINTER TO CURRENT INPUT LINE.
18659: *
18660: * R$TTL TITLE FOR SOURCE LISTING
18661: *
18662: * R$STL PTR TO SUB-TITLE STRING
18663: *
18664: * ENTRY POINT
18665: *
18666: LISTR PRC E,0 ENTRY POINT
18667: BNZ CNTTL,LIST5 JUMP IF -TITLE OR -STITL
18668: BNZ LSTPF,LIST4 IMMEDIATE EXIT IF ALREADY LISTED
18669: BGE LSTLC,LSTNP,LIST6 JUMP IF NO ROOM
18670: *
18671: * HERE AFTER PRINTING TITLE (IF NEEDED)
18672: *
18673: LIST0 MOV R$CIM,XR LOAD POINTER TO CURRENT IMAGE
18674: PLC XR POINT TO CHARACTERS
18675: LCH WA,(XR) LOAD FIRST CHARACTER
18676: MOV LSTSN,XR LOAD STATEMENT NUMBER
18677: BZE XR,LIST2 JUMP IF NO STATEMENT NUMBER
18678: MTI XR ELSE GET STMNT NUMBER AS INTEGER
18679: BNE STAGE,=STGIC,LIST1 SKIP IF EXECUTE TIME
18680: BEQ WA,=CH$AS,LIST2 NO STMNT NUMBER LIST IF COMMENT
18681: BEQ WA,=CH$MN,LIST2 NO STMNT NO. IF CONTROL CARD
18682: *
18683: * PRINT STATEMENT NUMBER
18684: *
18685: LIST1 JSR PRTIN ELSE PRINT STATEMENT NUMBER
18686: ZER LSTSN AND CLEAR FOR NEXT TIME IN
18687: EJC
18688: *
18689: * LISTR (CONTINUED)
18690: *
18691: * MERGE HERE AFTER PRINTING STATEMENT NUMBER (IF REQUIRED)
18692: *
18693: LIST2 MOV =STNPD,PROFS POINT PAST STATEMENT NUMBER
18694: MOV R$CIM,XR LOAD POINTER TO CURRENT IMAGE
18695: JSR PRTST PRINT IT
18696: ICV LSTLC BUMP LINE COUNTER
18697: BNZ ERLST,LIST3 JUMP IF ERROR COPY TO INT.CH.
18698: JSR PRTNL TERMINATE LINE
18699: BZE CSWDB,LIST3 JUMP IF -SINGLE MODE
18700: JSR PRTNL ELSE ADD A BLANK LINE
18701: ICV LSTLC AND BUMP LINE COUNTER
18702: *
18703: * HERE AFTER PRINTING SOURCE IMAGE
18704: *
18705: LIST3 MNZ LSTPF SET FLAG FOR LINE PRINTED
18706: *
18707: * MERGE HERE TO EXIT
18708: *
18709: LIST4 EXI RETURN TO LISTR CALLER
18710: *
18711: * PRINT TITLE AFTER -TITLE OR -STITL CARD
18712: *
18713: LIST5 ZER CNTTL CLEAR FLAG
18714: *
18715: * EJECT TO NEW PAGE AND LIST TITLE
18716: *
18717: LIST6 JSR PRTPS EJECT
18718: BZE PRICH,LIST7 SKIP IF LISTING TO REGULAR PRINTER
18719: BEQ R$TTL,=NULLS,LIST0 TERMINAL LISTING OMITS NULL TITLE
18720: *
18721: * LIST TITLE
18722: *
18723: LIST7 JSR LISTT LIST TITLE
18724: BRN LIST0 MERGE
18725: ENP END PROCEDURE LISTR
18726: EJC
18727: *
18728: * LISTT -- LIST TITLE AND SUBTITLE
18729: *
18730: * USED DURING COMPILATION TO PRINT PAGE HEADING
18731: *
18732: * JSR LISTT CALL TO LIST TITLE
18733: * (XR,WA) DESTROYED
18734: *
18735: LISTT PRC E,0 ENTRY POINT
18736: MOV R$TTL,XR POINT TO SOURCE LISTING TITLE
18737: JSR PRTST PRINT TITLE
18738: MOV LSTPO,PROFS SET OFFSET
18739: MOV =LSTMS,XR SET PAGE MESSAGE
18740: JSR PRTST PRINT PAGE MESSAGE
18741: ICV LSTPG BUMP PAGE NUMBER
18742: MTI LSTPG LOAD PAGE NUMBER AS INTEGER
18743: JSR PRTIN PRINT PAGE NUMBER
18744: JSR PRTNL TERMINATE TITLE LINE
18745: ADD =NUM02,LSTLC COUNT TITLE LINE AND BLANK LINE
18746: *
18747: * PRINT SUB-TITLE (IF ANY)
18748: *
18749: MOV R$STL,XR LOAD POINTER TO SUB-TITLE
18750: BZE XR,LSTT1 JUMP IF NO SUB-TITLE
18751: JSR PRTST ELSE PRINT SUB-TITLE
18752: JSR PRTNL TERMINATE LINE
18753: ICV LSTLC BUMP LINE COUNT
18754: *
18755: * RETURN POINT
18756: *
18757: LSTT1 JSR PRTNL PRINT A BLANK LINE
18758: EXI RETURN TO CALLER
18759: ENP END PROCEDURE LISTT
18760: EJC
18761: *
18762: * NEXTS -- ACQUIRE NEXT SOURCE IMAGE
18763: *
18764: * NEXTS IS USED TO ACQUIRE THE NEXT SOURCE IMAGE AT COMPILE
18765: * TIME. IT ASSUMES THAT A PRIOR CALL TO READR HAS INPUT
18766: * A LINE IMAGE (SEE PROCEDURE READR). BEFORE THE CURRENT
18767: * IMAGE IS FINALLY LOST IT MAY BE LISTED HERE.
18768: *
18769: * JSR NEXTS CALL TO ACQUIRE NEXT INPUT LINE
18770: * (XR,XL,WA,WB,WC) DESTROYED
18771: *
18772: * GLOBAL VALUES AFFECTED
18773: *
18774: * R$CNI ON INPUT, NEXT IMAGE. ON
18775: * EXIT RESET TO ZERO
18776: *
18777: * R$CIM ON EXIT, SET TO POINT TO IMAGE
18778: *
18779: * SCNIL INPUT IMAGE LENGTH ON EXIT
18780: *
18781: * SCNSE RESET TO ZERO ON EXIT
18782: *
18783: * LSTPF SET ON EXIT IF LINE IS LISTED
18784: *
18785: NEXTS PRC E,0 ENTRY POINT
18786: BZE CSWLS,NXTS2 JUMP IF -NOLIST
18787: MOV R$CIM,XR POINT TO IMAGE
18788: BZE XR,NXTS2 JUMP IF NO IMAGE
18789: PLC XR GET CHAR PTR
18790: LCH WA,(XR) GET FIRST CHAR
18791: BNE WA,=CH$MN,NXTS1 JUMP IF NOT CTRL CARD
18792: BZE CSWPR,NXTS2 JUMP IF -NOPRINT
18793: *
18794: * HERE TO CALL LISTER
18795: *
18796: NXTS1 JSR LISTR LIST LINE
18797: *
18798: * HERE AFTER POSSIBLE LISTING
18799: *
18800: NXTS2 MOV R$CNI,XR POINT TO NEXT IMAGE
18801: MOV XR,R$CIM SET AS NEXT IMAGE
18802: ZER R$CNI CLEAR NEXT IMAGE POINTER
18803: MOV SCLEN(XR),WA GET INPUT IMAGE LENGTH
18804: MOV CSWIN,WB GET MAX ALLOWABLE LENGTH
18805: BLO WA,WB,NXTS3 SKIP IF NOT TOO LONG
18806: MOV WB,WA ELSE TRUNCATE
18807: *
18808: * HERE WITH LENGTH IN (WA)
18809: *
18810: NXTS3 MOV WA,SCNIL USE AS RECORD LENGTH
18811: ZER SCNSE RESET SCNSE
18812: ZER LSTPF SET LINE NOT LISTED YET
18813: EXI RETURN TO NEXTS CALLER
18814: ENP END PROCEDURE NEXTS
18815: EJC
18816: *
18817: * PATIN -- PATTERN CONSTRUCTION FOR LEN,POS,RPOS,TAB,RTAB
18818: *
18819: * THESE PATTERN TYPES ALL GENERATE A SIMILAR NODE TYPE. SO
18820: * THE CONSTRUCTION CODE IS SHARED. SEE FUNCTIONS SECTION
18821: * FOR ACTUAL ENTRY POINTS FOR THESE FIVE FUNCTIONS.
18822: *
18823: * (WA) PCODE FOR EXPRESSION ARG CASE
18824: * (WB) PCODE FOR INTEGER ARG CASE
18825: * JSR PATIN CALL TO BUILD PATTERN NODE
18826: * PPM LOC TRANSFER LOC FOR NOT INTEGER OR EXP
18827: * PPM LOC TRANSFER LOC FOR INT OUT OF RANGE
18828: * (XR) POINTER TO CONSTRUCTED NODE
18829: * (XL,WA,WB,WC,IA) DESTROYED
18830: *
18831: PATIN PRC N,2 ENTRY POINT
18832: MOV WA,XL PRESERVE EXPRESSION ARG PCODE
18833: JSR GTSMI TRY TO CONVERT ARG AS SMALL INTEGER
18834: PPM PTIN2 JUMP IF NOT INTEGER
18835: PPM PTIN3 JUMP IF OUT OF RANGE
18836: *
18837: * COMMON SUCCESSFUL EXIT POINT
18838: *
18839: PTIN1 JSR PBILD BUILD PATTERN NODE
18840: EXI RETURN TO CALLER
18841: *
18842: * HERE IF ARGUMENT IS NOT AN INTEGER
18843: *
18844: PTIN2 MOV XL,WB COPY EXPR ARG CASE PCODE
18845: BLO (XR),=B$E$$,PTIN1 ALL OK IF EXPRESSION ARG
18846: EXI 1 ELSE TAKE ERROR EXIT FOR WRONG TYPE
18847: *
18848: * HERE FOR ERROR OF OUT OF RANGE INTEGER ARGUMENT
18849: *
18850: PTIN3 EXI 2 TAKE OUT-OF-RANGE ERROR EXIT
18851: ENP END PROCEDURE PATIN
18852: EJC
18853: *
18854: * PATST -- PATTERN CONSTRUCTION FOR ANY,NOTANY,
18855: * BREAK,SPAN AND BREAKX PATTERN FUNCTIONS.
18856: *
18857: * THESE PATTERN FUNCTIONS BUILD SIMILAR TYPES OF NODES AND
18858: * THE CONSTRUCTION CODE IS SHARED. SEE FUNCTIONS SECTION
18859: * FOR ACTUAL ENTRY POINTS FOR THESE FIVE PATTERN FUNCTIONS.
18860: *
18861: * 0(XS) STRING ARGUMENT
18862: * (WB) PCODE FOR ONE CHAR ARGUMENT
18863: * (XL) PCODE FOR MULTI-CHAR ARGUMENT
18864: * (WC) PCODE FOR EXPRESSION ARGUMENT
18865: * JSR PATST CALL TO BUILD NODE
18866: * PPM LOC TRANSFER LOC IF NOT STRING OR EXPR
18867: * (XS) POPPED PAST STRING ARGUMENT
18868: * (XR) POINTER TO CONSTRUCTED NODE
18869: * (XL) DESTROYED
18870: * (WA,WB,WC,RA) DESTROYED
18871: *
18872: * NOTE THAT THERE IS A SPECIAL CALL TO PATST IN THE EVALS
18873: * PROCEDURE WITH A SLIGHTLY DIFFERENT FORM. SEE EVALS
18874: * FOR DETAILS OF THE FORM OF THIS CALL.
18875: *
18876: PATST PRC N,1 ENTRY POINT
18877: JSR GTSTG CONVERT ARGUMENT AS STRING
18878: PPM PATS7 JUMP IF NOT STRING
18879: BNE WA,=NUM01,PATS2 JUMP IF NOT ONE CHAR STRING
18880: *
18881: * HERE FOR ONE CHAR STRING CASE
18882: *
18883: BZE WB,PATS2 TREAT AS MULTI-CHAR IF EVALS CALL
18884: PLC XR POINT TO CHARACTER
18885: LCH XR,(XR) LOAD CHARACTER
18886: *
18887: * COMMON EXIT POINT AFTER SUCCESSFUL CONSTRUCTION
18888: *
18889: PATS1 JSR PBILD CALL ROUTINE TO BUILD NODE
18890: EXI RETURN TO PATST CALLER
18891: EJC
18892: *
18893: * PATST (CONTINUED)
18894: *
18895: * HERE FOR MULTI-CHARACTER STRING CASE
18896: *
18897: PATS2 MOV XL,-(XS) SAVE MULTI-CHAR PCODE
18898: MOV XR,-(XS) SAVE STRING POINTER
18899: MOV CTMSK,WC LOAD CURRENT MASK BIT
18900: LSH WC,1 SHIFT TO NEXT POSITION
18901: NZB WC,PATS4 SKIP IF POSITION LEFT IN THIS TBL
18902: *
18903: * HERE WE MUST ALLOCATE A NEW CHARACTER TABLE
18904: *
18905: MOV *CTSI$,WA SET SIZE OF CTBLK
18906: JSR ALLOC ALLOCATE CTBLK
18907: MOV XR,R$CTP STORE PTR TO NEW CTBLK
18908: MOV =B$CTT,(XR)+ STORE TYPE CODE, BUMP PTR
18909: LCT WB,=CFP$A SET NUMBER OF WORDS TO CLEAR
18910: MOV BITS0,WC LOAD ALL ZERO BITS
18911: *
18912: * LOOP TO CLEAR ALL BITS IN TABLE TO ZEROS
18913: *
18914: PATS3 MOV WC,(XR)+ MOVE WORD OF ZERO BITS
18915: BCT WB,PATS3 LOOP TILL ALL CLEARED
18916: MOV BITS1,WC SET INITIAL BIT POSITION
18917: *
18918: * MERGE HERE WITH BIT POSITION AVAILABLE
18919: *
18920: PATS4 MOV WC,CTMSK SAVE PARM2 (NEW BIT POSITION)
18921: MOV (XS)+,XL RESTORE POINTER TO ARGUMENT STRING
18922: MOV SCLEN(XL),WB LOAD STRING LENGTH
18923: BZE WB,PATS6 JUMP IF NULL STRING CASE
18924: LCT WB,WB ELSE SET LOOP COUNTER
18925: PLC XL POINT TO CHARACTERS IN ARGUMENT
18926: EJC
18927: *
18928: * PATST (CONTINUED)
18929: *
18930: * LOOP TO SET BITS IN COLUMN OF TABLE
18931: *
18932: PATS5 LCH WA,(XL)+ LOAD NEXT CHARACTER
18933: WTB WA CONVERT TO BYTE OFFSET
18934: MOV R$CTP,XR POINT TO CTBLK
18935: ADD WA,XR POINT TO CTBLK ENTRY
18936: MOV WC,WA COPY BIT MASK
18937: ORB CTCHS(XR),WA OR IN BITS ALREADY SET
18938: MOV WA,CTCHS(XR) STORE RESULTING BIT STRING
18939: BCT WB,PATS5 LOOP TILL ALL BITS SET
18940: *
18941: * COMPLETE PROCESSING FOR MUTI-CHAR STRING CASE
18942: *
18943: PATS6 MOV R$CTP,XR LOAD CTBLK PTR AS PARM1 FOR PBILD
18944: ZER XL CLEAR GARBAGE PTR IN XL
18945: MOV (XS)+,WB LOAD PCODE FOR MULTI-CHAR STR CASE
18946: BRN PATS1 BACK TO EXIT (WC=BITSTRING=PARM2)
18947: *
18948: * HERE IF ARGUMENT IS NOT A STRING
18949: *
18950: * NOTE THAT THE CALL FROM EVALS CANNOT PASS AN EXPRESSION
18951: * SINCE EVALP ALWAYS REEVALUATES EXPRESSIONS.
18952: *
18953: PATS7 MOV WC,WB SET PCODE FOR EXPRESSION ARGUMENT
18954: BLO (XR),=B$E$$,PATS1 JUMP TO EXIT IF EXPRESSION ARG
18955: EXI 1 ELSE TAKE WRONG TYPE ERROR EXIT
18956: ENP END PROCEDURE PATST
18957: EJC
18958: *
18959: * PBILD -- BUILD PATTERN NODE
18960: *
18961: * (XR) PARM1 (ONLY IF REQUIRED)
18962: * (WB) PCODE FOR NODE
18963: * (WC) PARM2 (ONLY IF REQUIRED)
18964: * JSR PBILD CALL TO BUILD NODE
18965: * (XR) POINTER TO CONSTRUCTED NODE
18966: * (WA) DESTROYED
18967: *
18968: PBILD PRC E,0 ENTRY POINT
18969: MOV XR,-(XS) STACK POSSIBLE PARM1
18970: MOV WB,XR COPY PCODE
18971: LEI XR LOAD ENTRY POINT ID (BL$PX)
18972: BEQ XR,=BL$P1,PBLD1 JUMP IF ONE PARAMETER
18973: BEQ XR,=BL$P0,PBLD3 JUMP IF NO PARAMETERS
18974: *
18975: * HERE FOR TWO PARAMETER CASE
18976: *
18977: MOV *PCSI$,WA SET SIZE OF P2BLK
18978: JSR ALLOC ALLOCATE BLOCK
18979: MOV WC,PARM2(XR) STORE SECOND PARAMETER
18980: BRN PBLD2 MERGE WITH ONE PARM CASE
18981: *
18982: * HERE FOR ONE PARAMETER CASE
18983: *
18984: PBLD1 MOV *PBSI$,WA SET SIZE OF P1BLK
18985: JSR ALLOC ALLOCATE NODE
18986: *
18987: * MERGE HERE FROM TWO PARM CASE
18988: *
18989: PBLD2 MOV (XS),PARM1(XR) STORE FIRST PARAMETER
18990: BRN PBLD4 MERGE WITH NO PARAMETER CASE
18991: *
18992: * HERE FOR CASE OF NO PARAMETERS
18993: *
18994: PBLD3 MOV *PASI$,WA SET SIZE OF P0BLK
18995: JSR ALLOC ALLOCATE NODE
18996: *
18997: * MERGE HERE FROM OTHER CASES
18998: *
18999: PBLD4 MOV WB,(XR) STORE PCODE
19000: ICA XS POP FIRST PARAMETER
19001: MOV =NDNTH,PTHEN(XR) SET NOTHEN SUCCESSOR POINTER
19002: EXI RETURN TO PBILD CALLER
19003: ENP END PROCEDURE PBILD
19004: EJC
19005: *
19006: * PCONC -- CONCATENATE TWO PATTERNS
19007: *
19008: * (XL) PTR TO RIGHT PATTERN
19009: * (XR) PTR TO LEFT PATTERN
19010: * JSR PCONC CALL TO CONCATENATE PATTERNS
19011: * (XR) PTR TO CONCATENATED PATTERN
19012: * (XL,WA,WB,WC) DESTROYED
19013: *
19014: *
19015: * TO CONCATENATE TWO PATTERNS, ALL SUCCESSORS IN THE LEFT
19016: * PATTERN WHICH POINT TO THE NOTHEN NODE MUST BE CHANGED TO
19017: * POINT TO THE RIGHT PATTERN. HOWEVER, THIS MODIFICATION
19018: * MUST BE PERFORMED ON A COPY OF THE LEFT ARGUMENT RATHER
19019: * THAN THE LEFT ARGUMENT ITSELF, SINCE THE LEFT ARGUMENT
19020: * MAY BE POINTED TO BY SOME OTHER VARIABLE VALUE.
19021: *
19022: * ACCORDINGLY, IT IS NECESSARY TO COPY THE LEFT ARGUMENT.
19023: * THIS IS NOT A TRIVIAL PROCESS SINCE WE MUST AVOID COPYING
19024: * NODES MORE THAN ONCE AND THE PATTERN IS A GRAPH STRUCTURE
19025: * THE FOLLOWING ALGORITHM IS EMPLOYED.
19026: *
19027: * THE STACK IS USED TO STORE A LIST OF NODES WHICH
19028: * HAVE ALREADY BEEN COPIED. THE FORMAT OF THE ENTRIES ON
19029: * THIS LIST CONSISTS OF A TWO WORD BLOCK. THE FIRST WORD
19030: * IS THE OLD ADDRESS AND THE SECOND WORD IS THE ADDRESS
19031: * OF THE COPY. THIS LIST IS SEARCHED BY THE PCOPY
19032: * ROUTINE TO AVOID MAKING DUPLICATE COPIES. A TRICK IS
19033: * USED TO ACCOMPLISH THE CONCATENATION AT THE SAME TIME.
19034: * A SPECIAL ENTRY IS MADE TO START WITH ON THE STACK. THIS
19035: * ENTRY RECORDS THAT THE NOTHEN NODE HAS BEEN COPIED
19036: * ALREADY AND THE ADDRESS OF ITS COPY IS THE RIGHT PATTERN.
19037: * THIS AUTOMATICALLY PERFORMS THE CORRECT REPLACEMENTS.
19038: *
19039: PCONC PRC E,0 ENTRY POINT
19040: ZER -(XS) MAKE ROOM FOR ONE ENTRY AT BOTTOM
19041: MOV XS,WC STORE POINTER TO START OF LIST
19042: MOV =NDNTH,-(XS) STACK NOTHEN NODE AS OLD NODE
19043: MOV XL,-(XS) STORE RIGHT ARG AS COPY OF NOTHEN
19044: MOV XS,XT INITIALIZE POINTER TO STACK ENTRIES
19045: JSR PCOPY COPY FIRST NODE OF LEFT ARG
19046: MOV WA,2(XT) STORE AS RESULT UNDER LIST
19047: EJC
19048: *
19049: * PCONC (CONTINUED)
19050: *
19051: * THE FOLLOWING LOOP SCANS ENTRIES IN THE LIST AND MAKES
19052: * SURE THAT THEIR SUCCESSORS HAVE BEEN COPIED.
19053: *
19054: PCNC1 BEQ XT,XS,PCNC2 JUMP IF ALL ENTRIES PROCESSED
19055: MOV -(XT),XR ELSE LOAD NEXT OLD ADDRESS
19056: MOV PTHEN(XR),XR LOAD POINTER TO SUCCESSOR
19057: JSR PCOPY COPY SUCCESSOR NODE
19058: MOV -(XT),XR LOAD POINTER TO NEW NODE (COPY)
19059: MOV WA,PTHEN(XR) STORE PTR TO NEW SUCCESSOR
19060: *
19061: * NOW CHECK FOR SPECIAL CASE OF ALTERNATION NODE WHERE
19062: * PARM1 POINTS TO A NODE AND MUST BE COPIED LIKE PTHEN.
19063: *
19064: BNE (XR),=P$ALT,PCNC1 LOOP BACK IF NOT
19065: MOV PARM1(XR),XR ELSE LOAD POINTER TO ALTERNATIVE
19066: JSR PCOPY COPY IT
19067: MOV (XT),XR RESTORE PTR TO NEW NODE
19068: MOV WA,PARM1(XR) STORE PTR TO COPIED ALTERNATIVE
19069: BRN PCNC1 LOOP BACK FOR NEXT ENTRY
19070: *
19071: * HERE AT END OF COPY PROCESS
19072: *
19073: PCNC2 MOV WC,XS RESTORE STACK POINTER
19074: MOV (XS)+,XR LOAD POINTER TO COPY
19075: EXI RETURN TO PCONC CALLER
19076: ENP END PROCEDURE PCONC
19077: EJC
19078: *
19079: * PCOPY -- COPY A PATTERN NODE
19080: *
19081: * PCOPY IS CALLED FROM THE PCONC PROCEDURE TO COPY A SINGLE
19082: * PATTERN NODE. THE COPY IS ONLY CARRIED OUT IF THE NODE
19083: * HAS NOT BEEN COPIED ALREADY.
19084: *
19085: * (XR) POINTER TO NODE TO BE COPIED
19086: * (XT) PTR TO CURRENT LOC IN COPY LIST
19087: * (WC) POINTER TO LIST OF COPIED NODES
19088: * JSR PCOPY CALL TO COPY A NODE
19089: * (WA) POINTER TO COPY
19090: * (WB,XR) DESTROYED
19091: *
19092: PCOPY PRC N,0 ENTRY POINT
19093: MOV XT,WB SAVE XT
19094: MOV WC,XT POINT TO START OF LIST
19095: *
19096: * LOOP TO SEARCH LIST OF NODES COPIED ALREADY
19097: *
19098: PCOP1 DCA XT POINT TO NEXT ENTRY ON LIST
19099: BEQ XR,(XT),PCOP2 JUMP IF MATCH
19100: DCA XT ELSE SKIP OVER COPIED ADDRESS
19101: BNE XT,XS,PCOP1 LOOP BACK IF MORE TO TEST
19102: *
19103: * HERE IF NOT IN LIST, PERFORM COPY
19104: *
19105: MOV (XR),WA LOAD FIRST WORD OF BLOCK
19106: JSR BLKLN GET LENGTH OF BLOCK
19107: MOV XR,XL SAVE POINTER TO OLD NODE
19108: JSR ALLOC ALLOCATE SPACE FOR COPY
19109: MOV XL,-(XS) STORE OLD ADDRESS ON LIST
19110: MOV XR,-(XS) STORE NEW ADDRESS ON LIST
19111: CHK CHECK FOR STACK OVERFLOW
19112: MVW MOVE WORDS FROM OLD BLOCK TO COPY
19113: MOV (XS),WA LOAD POINTER TO COPY
19114: BRN PCOP3 JUMP TO EXIT
19115: *
19116: * HERE IF WE FIND ENTRY IN LIST
19117: *
19118: PCOP2 MOV -(XT),WA LOAD ADDRESS OF COPY FROM LIST
19119: *
19120: * COMMON EXIT POINT
19121: *
19122: PCOP3 MOV WB,XT RESTORE XT
19123: EXI RETURN TO PCOPY CALLER
19124: ENP END PROCEDURE PCOPY
19125: EJC
19126: *
19127: * PRFLR -- PRINT PROFILE
19128: * PRFLR IS CALLED TO PRINT THE CONTENTS OF THE PROFILE
19129: * TABLE IN A FAIRLY READABLE TABULAR FORMAT.
19130: *
19131: * JSR PRFLR CALL TO PRINT PROFILE
19132: * (WA,IA) DESTROYED
19133: *
19134: PRFLR PRC E,0
19135: BZE PFDMP,PRFL4 NO PRINTING IF NO PROFILING DONE
19136: MOV XR,-(XS) PRESERVE ENTRY XR
19137: MOV WB,PFSVW AND ALSO WB
19138: JSR PRTPG EJECT
19139: MOV =PFMS1,XR LOAD MSG /PROGRAM PROFILE/
19140: JSR PRTST AND PRINT IT
19141: JSR PRTNL FOLLOWED BY NEWLINE
19142: JSR PRTNL AND ANOTHER
19143: MOV =PFMS2,XR POINT TO FIRST HDR
19144: JSR PRTST PRINT IT
19145: JSR PRTNL NEW LINE
19146: MOV =PFMS3,XR SECOND HDR
19147: JSR PRTST PRINT IT
19148: JSR PRTNL NEW LINE
19149: JSR PRTNL AND ANOTHER BLANK LINE
19150: ZER WB INITIAL STMT COUNT
19151: MOV PFTBL,XR POINT TO TABLE ORIGIN
19152: ADD *NUM02,XR BIAS PAST XNBLK HEADER (SGD07)
19153: *
19154: * LOOP HERE TO PRINT SUCCESSIVE ENTRIES
19155: *
19156: PRFL1 ICV WB BUMP STMT NR
19157: LDI (XR) LOAD NR OF EXECUTIONS
19158: IEQ PRFL3 NO PRINTING IF ZERO
19159: MOV =PFPD1,PROFS POINT WHERE TO PRINT
19160: JSR PRTIN AND PRINT IT
19161: ZER PROFS BACK TO START OF LINE
19162: MTI WB LOAD STMT NR
19163: JSR PRTIN PRINT IT THERE
19164: MOV =PFPD2,PROFS AND PAD PAST COUNT
19165: LDI CFP$I(XR) LOAD TOTAL EXEC TIME
19166: JSR PRTIN PRINT THAT TOO
19167: LDI CFP$I(XR) RELOAD TIME
19168: MLI INTTH CONVERT TO MICROSEC
19169: IOV PRFL2 OMIT NEXT BIT IF OVERFLOW
19170: DVI (XR) DIVIDE BY EXECUTIONS
19171: MOV =PFPD3,PROFS PAD LAST PRINT
19172: JSR PRTIN AND PRINT MCSEC/EXECN
19173: *
19174: * MERGE AFTER PRINTING TIME
19175: *
19176: PRFL2 JSR PRTNL THATS ANOTHER LINE
19177: *
19178: * HERE TO GO TO NEXT ENTRY
19179: *
19180: PRFL3 ADD *PF$I2,XR BUMP INDEX PTR (SGD07)
19181: BLT WB,PFNTE,PRFL1 LOOP IF MORE STMTS
19182: MOV (XS)+,XR RESTORE CALLERS XR
19183: MOV PFSVW,WB AND WB TOO
19184: *
19185: * HERE TO EXIT
19186: *
19187: PRFL4 EXI RETURN
19188: ENP END OF PRFLR
19189: EJC
19190: *
19191: * PRFLU -- UPDATE AN ENTRY IN THE PROFILE TABLE
19192: *
19193: * ON ENTRY, KVSTN CONTAINS NR OF STMT TO PROFILE
19194: *
19195: * JSR PRFLU CALL TO UPDATE ENTRY
19196: * (IA) DESTROYED
19197: *
19198: PRFLU PRC E,0
19199: BNZ PFFNC,PFLU4 SKIP IF JUST ENTERED FUNCTION
19200: MOV XR,-(XS) PRESERVE ENTRY XR
19201: MOV WA,PFSVW SAVE WA (SGD07)
19202: BNZ PFTBL,PFLU2 BRANCH IF TABLE ALLOCATED
19203: *
19204: * HERE IF SPACE FOR PROFILE TABLE NOT YET ALLOCATED.
19205: * CALCULATE SIZE NEEDED, ALLOCATE A STATIC XNBLK, AND
19206: * INITIALIZE IT ALL TO ZERO.
19207: * THE TIME TAKEN FOR THIS WILL BE ATTRIBUTED TO THE CURRENT
19208: * STATEMENT (ASSIGNMENT TO KEYWD PROFILE), BUT SINCE THE
19209: * TIMING FOR THIS STATEMENT IS UP THE POLE ANYWAY, THIS
19210: * DOESNT REALLY MATTER...
19211: *
19212: SUB =NUM01,PFNTE ADJUST FOR EXTRA COUNT (SGD07)
19213: MTI PFI2A CONVRT ENTRY SIZE TO INT
19214: STI PFSTE AND STORE SAFELY FOR LATER
19215: MTI PFNTE LOAD TABLE LENGTH AS INTEGER
19216: MLI PFSTE MULTIPLY BY ENTRY SIZE
19217: MFI WA GET BACK ADDRESS-STYLE
19218: ADD =NUM02,WA ADD ON 2 WORD OVERHEAD
19219: WTB WA CONVERT THE WHOLE LOT TO BYTES
19220: JSR ALOST GIMME THE SPACE
19221: MOV XR,PFTBL SAVE BLOCK POINTER
19222: MOV =B$XNT,(XR)+ PUT BLOCK TYPE AND ...
19223: MOV WA,(XR)+ ... LENGTH INTO HEADER
19224: MFI WA GET BACK NR OF WDS IN DATA AREA
19225: LCT WA,WA LOAD THE COUNTER
19226: *
19227: * LOOP HERE TO ZERO THE BLOCK DATA
19228: *
19229: PFLU1 ZER (XR)+ BLANK A WORD
19230: BCT WA,PFLU1 AND ALLLLLLL THE REST
19231: *
19232: * END OF ALLOCATION. MERGE BACK INTO ROUTINE
19233: *
19234: PFLU2 MTI KVSTN LOAD NR OF STMT JUST ENDED
19235: SBI INTV1 MAKE INTO INDEX OFFSET
19236: MLI PFSTE MAKE OFFSET OF TABLE ENTRY
19237: MFI WA CONVERT TO ADDRESS
19238: WTB WA GET AS BAUS
19239: ADD *NUM02,WA OFFSET INCLUDES TABLE HEADER
19240: MOV PFTBL,XR GET TABLE START
19241: BGE WA,NUM01(XR),PFLU3 IF OUT OF TABLE, SKIP IT
19242: ADD WA,XR ELSE POINT TO ENTRY
19243: LDI (XR) GET NR OF EXECUTIONS SO FAR
19244: ADI INTV1 NUDGE UP ONE
19245: STI (XR) AND PUT BACK
19246: JSR SYSTM GET TIME NOW
19247: STI PFETM STASH ENDING TIME
19248: SBI PFSTM SUBTRACT START TIME
19249: ADI CFP$I(XR) ADD CUMULATIVE TIME SO FAR
19250: STI CFP$I(XR) AND PUT BACK NEW TOTAL
19251: LDI PFETM LOAD END TIME OF THIS STMT ...
19252: STI PFSTM ... WHICH IS START TIME OF NEXT
19253: *
19254: * MERGE HERE TO EXIT
19255: *
19256: PFLU3 MOV (XS)+,XR RESTORE CALLERS XR
19257: MOV PFSVW,WA RESTORE SAVED REG
19258: EXI AND RETURN
19259: *
19260: * HERE IF PROFILE IS SUPPRESSED BECAUSE A PROGRAM DEFINED
19261: * FUNCTION IS ABOUT TO BE ENTERED, AND SO THE CURRENT STMT
19262: * HAS NOT YET FINISHED
19263: *
19264: PFLU4 ZER PFFNC RESET THE CONDITION FLAG
19265: EXI AND IMMEDIATE RETURN
19266: ENP END OF PROCEDURE PRFLU
19267: EJC
19268: *
19269: * PRPAR - PROCESS PRINT PARAMETERS
19270: *
19271: * (WC) IF NONZERO ASSOCIATE TERMINAL ONLY
19272: * JSR PRPAR CALL TO PROCESS PRINT PARAMETERS
19273: * (XL,XR,WA,WB,WC) DESTROYED
19274: *
19275: * SINCE MEMORY ALLOCATION IS UNDECIDED ON INITIAL CALL,
19276: * TERMINAL CANNOT BE ASSOCIATED. THE ENTRY WITH WC NON-ZERO
19277: * IS PROVIDED SO A LATER CALL CAN BE MADE TO COMPLETE THIS.
19278: *
19279: PRPAR PRC E,0 ENTRY POINT
19280: BNZ WC,PRPA7 JUMP TO ASSOCIATE TERMINAL
19281: JSR SYSPP GET PRINT PARAMETERS
19282: BNZ WB,PRPA1 JUMP IF LINES/PAGE SPECIFIED
19283: MOV =CFP$M,WB ELSE USE A LARGE VALUE
19284: RSH WB,1 BUT NOT TOO LARGE
19285: *
19286: * STORE LINE COUNT/PAGE
19287: *
19288: PRPA1 MOV WB,LSTNP STORE NUMBER OF LINES/PAGE
19289: MOV WB,LSTLC PRETEND PAGE IS FULL INITIALLY
19290: ZER LSTPG CLEAR PAGE NUMBER
19291: MOV PRLEN,WB GET PRIOR LENGTH IF ANY
19292: BZE WB,PRPA2 SKIP IF NO LENGTH
19293: BGT WA,WB,PRPA3 SKIP STORING IF TOO BIG
19294: *
19295: * STORE PRINT BUFFER LENGTH
19296: *
19297: PRPA2 MOV WA,PRLEN STORE VALUE
19298: *
19299: * PROCESS BITS OPTIONS
19300: *
19301: PRPA3 MOV BITS3,WB BIT 3 MASK
19302: ANB WC,WB GET -NOLIST BIT
19303: ZRB WB,PRPA4 SKIP IF CLEAR
19304: ZER CSWLS SET -NOLIST
19305: *
19306: * CHECK IF FAIL REPORTS GOTO INTERACTIVE CHANNEL
19307: *
19308: PRPA4 MOV BITS1,WB BIT 1 MASK
19309: ANB WC,WB GET BIT
19310: MOV WB,ERICH STORE INT. CHAN. ERROR FLAG
19311: MOV BITS2,WB BIT 2 MASK
19312: ANB WC,WB GET BIT
19313: MOV WB,PRICH FLAG FOR STD PRINTER ON INT. CHAN.
19314: MOV BITS4,WB BIT 4 MASK
19315: ANB WC,WB GET BIT
19316: MOV WB,CPSTS FLAG FOR COMPILE STATS SUPPRESSN.
19317: MOV BITS5,WB BIT 5 MASK
19318: ANB WC,WB GET BIT
19319: MOV WB,EXSTS FLAG FOR EXEC STATS SUPPRESSION
19320: EJC
19321: *
19322: * PRPAR (CONTINUED)
19323: *
19324: MOV BITS6,WB BIT 6 MASK
19325: ANB WC,WB GET BIT
19326: MOV WB,PRECL EXTENDED/COMPACT LISTING FLAG
19327: SUB =NUM08,WA POINT 8 CHARS FROM LINE END
19328: ZRB WB,PRPA5 JUMP IF NOT EXTENDED
19329: MOV WA,LSTPO STORE FOR LISTING PAGE HEADINGS
19330: *
19331: * CONTINUE OPTION PROCESSING
19332: *
19333: PRPA5 MOV BITS7,WB BIT 7 MASK
19334: ANB WC,WB GET BIT 7
19335: MOV WB,CSWEX SET -NOEXECUTE IF NON-ZERO
19336: MOV BIT10,WB BIT 10 MASK
19337: ANB WC,WB GET BIT 10
19338: MOV WB,HEADP PRETEND PRINTED TO OMIT HEADERS
19339: MOV BITS9,WB BIT 9 MASK
19340: ANB WC,WB GET BIT 9
19341: MOV WB,PRSTO KEEP IT AS STD LISTING OPTION
19342: ZRB WB,PRPA6 SKIP IF CLEAR
19343: MOV PRLEN,WA GET PRINT BUFFER LENGTH
19344: SUB =NUM08,WA POINT 8 CHARS FROM LINE END
19345: MOV WA,LSTPO STORE PAGE OFFSET
19346: *
19347: * CHECK FOR TERMINAL
19348: *
19349: PRPA6 ANB BITS8,WC SEE IF TERMINAL TO BE ACTIVATED
19350: BNZ WC,PRPA7 JUMP IF TERMINAL REQUIRED
19351: BZE INITR,PRPA8 JUMP IF NO TERMINAL TO DETACH
19352: MOV =V$TER,XL PTR TO /TERMINAL/
19353: JSR GTNVR GET VRBLK POINTER
19354: PPM CANT FAIL
19355: MOV =NULLS,VRVAL(XR) CLEAR VALUE OF TERMINAL
19356: JSR SETVR REMOVE ASSOCIATION
19357: BRN PRPA8 RETURN
19358: *
19359: * ASSOCIATE TERMINAL
19360: *
19361: PRPA7 MNZ INITR NOTE TERMINAL ASSOCIATED
19362: BZE DNAMB,PRPA8 CANT IF MEMORY NOT ORGANISED
19363: MOV =V$TER,XL POINT TO TERMINAL STRING
19364: MOV =TRTOU,WB OUTPUT TRACE TYPE
19365: JSR INOUT ATTACH OUTPUT TRBLK TO VRBLK
19366: MOV XR,-(XS) STACK TRBLK PTR
19367: MOV =V$TER,XL POINT TO TERMINAL STRING
19368: MOV =TRTIN,WB INPUT TRACE TYPE
19369: JSR INOUT ATTACH INPUT TRACE BLK
19370: MOV (XS)+,VRVAL(XR) ADD OUTPUT TRBLK TO CHAIN
19371: *
19372: * RETURN POINT
19373: *
19374: PRPA8 EXI RETURN
19375: ENP END PROCEDURE PRPAR
19376: EJC
19377: *
19378: * PRTCH -- PRINT A CHARACTER
19379: *
19380: * PRTCH IS USED TO PRINT A SINGLE CHARACTER
19381: *
19382: * (WA) CHARACTER TO BE PRINTED
19383: * JSR PRTCH CALL TO PRINT CHARACTER
19384: *
19385: PRTCH PRC E,0 ENTRY POINT
19386: MOV XR,-(XS) SAVE XR
19387: BNE PROFS,PRLEN,PRCH1 JUMP IF ROOM IN BUFFER
19388: JSR PRTNL ELSE PRINT THIS LINE
19389: *
19390: * HERE AFTER MAKING SURE WE HAVE ROOM
19391: *
19392: PRCH1 MOV PRBUF,XR POINT TO PRINT BUFFER
19393: PSC XR,PROFS POINT TO NEXT CHARACTER LOCATION
19394: SCH WA,(XR) STORE NEW CHARACTER
19395: CSC XR COMPLETE STORE CHARACTERS
19396: ICV PROFS BUMP POINTER
19397: MOV (XS)+,XR RESTORE ENTRY XR
19398: EXI RETURN TO PRTCH CALLER
19399: ENP END PROCEDURE PRTCH
19400: EJC
19401: *
19402: * PRTIC -- PRINT TO INTERACTIVE CHANNEL
19403: *
19404: * PRTIC IS CALLED TO PRINT THE CONTENTS OF THE STANDARD
19405: * PRINT BUFFER TO THE INTERACTIVE CHANNEL. IT IS ONLY
19406: * CALLED AFTER PRTST HAS SET UP THE STRING FOR PRINTING.
19407: * IT DOES NOT CLEAR THE BUFFER.
19408: *
19409: * JSR PRTIC CALL FOR PRINT
19410: * (WA,WB) DESTROYED
19411: *
19412: PRTIC PRC E,0 ENTRY POINT
19413: MOV XR,-(XS) SAVE XR
19414: MOV PRBUF,XR POINT TO BUFFER
19415: MOV PROFS,WA NO OF CHARS
19416: JSR SYSPI PRINT
19417: PPM PRTC2 FAIL RETURN
19418: *
19419: * RETURN
19420: *
19421: PRTC1 MOV (XS)+,XR RESTORE XR
19422: EXI RETURN
19423: *
19424: * ERROR OCCURED
19425: *
19426: PRTC2 ZER ERICH PREVENT LOOPING
19427: ERB 252,ERROR ON PRINTING TO INTERACTIVE CHANNEL
19428: BRN PRTC1 RETURN
19429: ENP PROCEDURE PRTIC
19430: EJC
19431: *
19432: * PRTIS -- PRINT TO INTERACTIVE AND STANDARD PRINTER
19433: *
19434: * PRTIS PUTS A LINE FROM THE PRINT BUFFER ONTO THE
19435: * INTERACTIVE CHANNEL (IF ANY) AND THE STANDARD PRINTER.
19436: * IT ALWAYS PRINTS TO THE STANDARD PRINTER BUT DOES
19437: * NOT DUPLICATE LINES IF THE STANDARD PRINTER IS
19438: * INTERACTIVE. IT CLEARS DOWN THE PRINT BUFFER.
19439: *
19440: * JSR PRTIS CALL FOR PRINTING
19441: * (WA,WB) DESTROYED
19442: *
19443: PRTIS PRC E,0 ENTRY POINT
19444: BNZ PRICH,PRTS1 JUMP IF STANDARD PRINTER IS INT.CH.
19445: BZE ERICH,PRTS1 SKIP IF NOT DOING INT. ERROR REPS.
19446: JSR PRTIC PRINT TO INTERACTIVE CHANNEL
19447: *
19448: * MERGE AND EXIT
19449: *
19450: PRTS1 JSR PRTNL PRINT TO STANDARD PRINTER
19451: EXI RETURN
19452: ENP END PROCEDURE PRTIS
19453: EJC
19454: *
19455: * PRTIN -- PRINT AN INTEGER
19456: *
19457: * PRTIN PRINTS THE INTEGER VALUE WHICH IS IN THE INTEGER
19458: * ACCUMULATOR. BLOCKS BUILT IN DYNAMIC STORAGE
19459: * DURING THIS PROCESS ARE IMMEDIATELY DELETED.
19460: *
19461: * (IA) INTEGER VALUE TO BE PRINTED
19462: * JSR PRTIN CALL TO PRINT INTEGER
19463: * (IA,RA) DESTROYED
19464: *
19465: PRTIN PRC E,0 ENTRY POINT
19466: MOV XR,-(XS) SAVE XR
19467: JSR ICBLD BUILD INTEGER BLOCK
19468: BLO XR,DNAMB,PRTI1 JUMP IF ICBLK BELOW DYNAMIC
19469: BHI XR,DNAMP,PRTI1 JUMP IF ABOVE DYNAMIC
19470: MOV XR,DNAMP IMMEDIATELY DELETE IT
19471: *
19472: * DELETE ICBLK FROM DYNAMIC STORE
19473: *
19474: PRTI1 MOV XR,-(XS) STACK PTR FOR GTSTG
19475: JSR GTSTG CONVERT TO STRING
19476: PPM CONVERT ERROR IS IMPOSSIBLE
19477: MOV XR,DNAMP RESET POINTER TO DELETE SCBLK
19478: JSR PRTST PRINT INTEGER STRING
19479: MOV (XS)+,XR RESTORE ENTRY XR
19480: EXI RETURN TO PRTIN CALLER
19481: ENP END PROCEDURE PRTIN
19482: EJC
19483: *
19484: * PRTMI -- PRINT MESSAGE AND INTEGER
19485: *
19486: * PRTMI IS USED TO PRINT MESSAGES TOGETHER WITH AN INTEGER
19487: * VALUE STARTING IN COLUMN 15 (USED BY THE ROUTINES AT
19488: * THE END OF COMPILATION).
19489: *
19490: * JSR PRTMI CALL TO PRINT MESSAGE AND INTEGER
19491: *
19492: PRTMI PRC E,0 ENTRY POINT
19493: JSR PRTST PRINT STRING MESSAGE
19494: MOV =PRTMF,PROFS SET OFFSET TO COL 15
19495: JSR PRTIN PRINT INTEGER
19496: JSR PRTNL PRINT LINE
19497: EXI RETURN TO PRTMI CALLER
19498: ENP END PROCEDURE PRTMI
19499: EJC
19500: *
19501: * PRTMX -- AS PRTMI WITH EXTRA COPY TO INTERACTIVE CHAN.
19502: *
19503: * JSR PRTMX CALL FOR PRINTING
19504: * (WA,WB) DESTROYED
19505: *
19506: PRTMX PRC E,0 ENTRY POINT
19507: JSR PRTST PRINT STRING MESSAGE
19508: MOV =PRTMF,PROFS SET PTR TO COLUMN 15
19509: JSR PRTIN PRINT INTEGER
19510: JSR PRTIS PRINT LINE
19511: EXI RETURN
19512: ENP END PROCEDURE PRTMX
19513: EJC
19514: *
19515: * PRTNL -- PRINT NEW LINE (END PRINT LINE)
19516: *
19517: * PRTNL PRINTS THE CONTENTS OF THE PRINT BUFFER, RESETS
19518: * THE BUFFER TO ALL BLANKS AND RESETS THE PRINT POINTER.
19519: *
19520: * JSR PRTNL CALL TO PRINT LINE
19521: *
19522: PRTNL PRC R,0 ENTRY POINT
19523: BNZ HEADP,PRNL0 WERE HEADERS PRINTED
19524: JSR PRTPS NO - PRINT THEM
19525: *
19526: * CALL SYSPR
19527: *
19528: PRNL0 MOV XR,-(XS) SAVE ENTRY XR
19529: MOV WA,PRTSA SAVE WA
19530: MOV WB,PRTSB SAVE WB
19531: MOV PRBUF,XR LOAD POINTER TO BUFFER
19532: MOV PROFS,WA LOAD NUMBER OF CHARS IN BUFFER
19533: JSR SYSPR CALL SYSTEM PRINT ROUTINE
19534: PPM PRNL2 JUMP IF FAILED
19535: LCT WA,PRLNW LOAD LENGTH OF BUFFER IN WORDS
19536: ADD *SCHAR,XR POINT TO CHARS OF BUFFER
19537: MOV NULLW,WB GET WORD OF BLANKS
19538: *
19539: * LOOP TO BLANK BUFFER
19540: *
19541: PRNL1 MOV WB,(XR)+ STORE WORD OF BLANKS, BUMP PTR
19542: BCT WA,PRNL1 LOOP TILL ALL BLANKED
19543: *
19544: * EXIT POINT
19545: *
19546: MOV PRTSB,WB RESTORE WB
19547: MOV PRTSA,WA RESTORE WA
19548: MOV (XS)+,XR RESTORE ENTRY XR
19549: ZER PROFS RESET PRINT BUFFER POINTER
19550: EXI RETURN TO PRTNL CALLER
19551: *
19552: * FILE FULL OR NO OUTPUT FILE FOR LOAD MODULE
19553: *
19554: PRNL2 BNZ PRTEF,PRNL3 JUMP IF NOT FIRST TIME
19555: MNZ PRTEF MARK FIRST OCCURRENCE
19556: ERB 253,PRINT LIMIT EXCEEDED ON STANDARD OUTPUT CHANNEL
19557: *
19558: * STOP AT ONCE
19559: *
19560: PRNL3 MOV =NINI8,WB ENDING CODE
19561: MOV KVSTN,WA STATEMENT NUMBER
19562: JSR SYSEJ STOP
19563: ENP END PROCEDURE PRTNL
19564: EJC
19565: *
19566: * PRTNM -- PRINT VARIABLE NAME
19567: *
19568: * PRTNM IS USED TO PRINT A CHARACTER REPRESENTATION OF THE
19569: * NAME OF A VARIABLE (NOT A VALUE OF DATATYPE NAME)
19570: * NAMES OF PSEUDO-VARIABLES MAY NOT BE PASSED TO PRTNM.
19571: *
19572: * (XL) NAME BASE
19573: * (WA) NAME OFFSET
19574: * JSR PRTNM CALL TO PRINT NAME
19575: * (WB,WC,RA) DESTROYED
19576: *
19577: PRTNM PRC R,0 ENTRY POINT (RECURSIVE, SEE PRTVL)
19578: MOV WA,-(XS) SAVE WA (OFFSET IS COLLECTABLE)
19579: MOV XR,-(XS) SAVE ENTRY XR
19580: MOV XL,-(XS) SAVE NAME BASE
19581: BHI XL,STATE,PRN02 JUMP IF NOT NATURAL VARIABLE
19582: *
19583: * HERE FOR NATURAL VARIABLE NAME, RECOGNIZED BY THE FACT
19584: * THAT THE NAME BASE POINTS INTO THE STATIC AREA.
19585: *
19586: MOV XL,XR POINT TO VRBLK
19587: JSR PRTVN PRINT NAME OF VARIABLE
19588: *
19589: * COMMON EXIT POINT
19590: *
19591: PRN01 MOV (XS)+,XL RESTORE NAME BASE
19592: MOV (XS)+,XR RESTORE ENTRY VALUE OF XR
19593: MOV (XS)+,WA RESTORE WA
19594: EXI RETURN TO PRTNM CALLER
19595: *
19596: * HERE FOR CASE OF NON-NATURAL VARIABLE
19597: *
19598: PRN02 MOV WA,WB COPY NAME OFFSET
19599: BNE (XL),=B$PDT,PRN03 JUMP IF ARRAY OR TABLE
19600: *
19601: * FOR PROGRAM DEFINED DATATYPE, PRT FLD NAME, LEFT PAREN
19602: *
19603: MOV PDDFP(XL),XR LOAD POINTER TO DFBLK
19604: ADD WA,XR ADD NAME OFFSET
19605: MOV PDFOF(XR),XR LOAD VRBLK POINTER FOR FIELD
19606: JSR PRTVN PRINT FIELD NAME
19607: MOV =CH$PP,WA LOAD LEFT PAREN
19608: JSR PRTCH PRINT CHARACTER
19609: EJC
19610: *
19611: * PRTNM (CONTINUED)
19612: *
19613: * NOW WE PRINT AN IDENTIFYING NAME FOR THE OBJECT IF ONE
19614: * CAN BE FOUND. THE FOLLOWING CODE SEARCHES FOR A NATURAL
19615: * VARIABLE WHICH CONTAINS THIS OBJECT AS VALUE. IF SUCH A
19616: * VARIABLE IS FOUND, ITS NAME IS PRINTED, ELSE THE VALUE
19617: * OF THE OBJECT (AS PRINTED BY PRTVL) IS USED INSTEAD.
19618: *
19619: * FIRST WE POINT TO THE PARENT TBBLK IF THIS IS THE CASE OF
19620: * A TABLE ELEMENT. TO DO THIS, CHASE DOWN THE TRNXT CHAIN.
19621: *
19622: PRN03 BNE (XL),=B$TET,PRN04 JUMP IF WE GOT THERE (OR NOT TE)
19623: MOV TENXT(XL),XL ELSE MOVE OUT ON CHAIN
19624: BRN PRN03 AND LOOP BACK
19625: *
19626: * NOW WE ARE READY FOR THE SEARCH. TO SPEED THINGS UP IN
19627: * THE CASE OF CALLS FROM DUMP WHERE THE SAME NAME BASE
19628: * WILL OCCUR REPEATEDLY WHILE DUMPING AN ARRAY OR TABLE,
19629: * WE REMEMBER THE LAST VRBLK POINTER FOUND IN PRNMV. SO
19630: * FIRST CHECK TO SEE IF WE HAVE THIS ONE AGAIN.
19631: *
19632: PRN04 MOV PRNMV,XR POINT TO VRBLK WE FOUND LAST TIME
19633: MOV HSHTB,WA POINT TO HASH TABLE IN CASE NOT
19634: BRN PRN07 JUMP INTO SEARCH FOR SPECIAL CHECK
19635: *
19636: * LOOP THROUGH HASH SLOTS
19637: *
19638: PRN05 MOV WA,XR COPY SLOT POINTER
19639: ICA WA BUMP SLOT POINTER
19640: SUB *VRNXT,XR INTRODUCE STANDARD VRBLK OFFSET
19641: *
19642: * LOOP THROUGH VRBLKS ON ONE HASH CHAIN
19643: *
19644: PRN06 MOV VRNXT(XR),XR POINT TO NEXT VRBLK ON HASH CHAIN
19645: *
19646: * MERGE HERE FIRST TIME TO CHECK BLOCK WE FOUND LAST TIME
19647: *
19648: PRN07 MOV XR,WC COPY VRBLK POINTER
19649: BZE WC,PRN09 JUMP IF CHAIN END (OR PRNMV ZERO)
19650: EJC
19651: *
19652: * PRTNM (CONTINUED)
19653: *
19654: * LOOP TO FIND VALUE (CHASE DOWN POSSIBLE TRBLK CHAIN)
19655: *
19656: PRN08 MOV VRVAL(XR),XR LOAD VALUE
19657: BEQ (XR),=B$TRT,PRN08 LOOP IF THAT WAS A TRBLK
19658: *
19659: * NOW WE HAVE THE VALUE, IS THIS THE BLOCK WE WANT
19660: *
19661: BEQ XR,XL,PRN10 JUMP IF THIS MATCHES THE NAME BASE
19662: MOV WC,XR ELSE POINT BACK TO THAT VRBLK
19663: BRN PRN06 AND LOOP BACK
19664: *
19665: * HERE TO MOVE TO NEXT HASH SLOT
19666: *
19667: PRN09 BLT WA,HSHTE,PRN05 LOOP BACK IF MORE TO GO
19668: MOV XL,XR ELSE NOT FOUND, COPY VALUE POINTER
19669: JSR PRTVL PRINT VALUE
19670: BRN PRN11 AND MERGE AHEAD
19671: *
19672: * HERE WHEN WE FIND A MATCHING ENTRY
19673: *
19674: PRN10 MOV WC,XR COPY VRBLK POINTER
19675: MOV XR,PRNMV SAVE FOR NEXT TIME IN
19676: JSR PRTVN PRINT VARIABLE NAME
19677: *
19678: * MERGE HERE IF NO ENTRY FOUND
19679: *
19680: PRN11 MOV (XL),WC LOAD FIRST WORD OF NAME BASE
19681: BNE WC,=B$PDT,PRN13 JUMP IF NOT PROGRAM DEFINED
19682: *
19683: * FOR PROGRAM DEFINED DATATYPE, ADD RIGHT PAREN AND EXIT
19684: *
19685: MOV =CH$RP,WA LOAD RIGHT PAREN, MERGE
19686: *
19687: * MERGE HERE TO PRINT FINAL RIGHT PAREN OR BRACKET
19688: *
19689: PRN12 JSR PRTCH PRINT FINAL CHARACTER
19690: MOV WB,WA RESTORE NAME OFFSET
19691: BRN PRN01 MERGE BACK TO EXIT
19692: EJC
19693: *
19694: * PRTNM (CONTINUED)
19695: *
19696: * HERE FOR ARRAY OR TABLE
19697: *
19698: PRN13 MOV =CH$BB,WA LOAD LEFT BRACKET
19699: JSR PRTCH AND PRINT IT
19700: MOV (XS),XL RESTORE BLOCK POINTER
19701: MOV (XL),WC LOAD TYPE WORD AGAIN
19702: BNE WC,=B$TET,PRN15 JUMP IF NOT TABLE
19703: *
19704: * HERE FOR TABLE, PRINT SUBSCRIPT VALUE
19705: *
19706: MOV TESUB(XL),XR LOAD SUBSCRIPT VALUE
19707: MOV WB,XL SAVE NAME OFFSET
19708: JSR PRTVL PRINT SUBSCRIPT VALUE
19709: MOV XL,WB RESTORE NAME OFFSET
19710: *
19711: * MERGE HERE FROM ARRAY CASE TO PRINT RIGHT BRACKET
19712: *
19713: PRN14 MOV =CH$RB,WA LOAD RIGHT BRACKET
19714: BRN PRN12 MERGE BACK TO PRINT IT
19715: *
19716: * HERE FOR ARRAY OR VECTOR, TO PRINT SUBSCRIPT(S)
19717: *
19718: PRN15 MOV WB,WA COPY NAME OFFSET
19719: BTW WA CONVERT TO WORDS
19720: BEQ WC,=B$ART,PRN16 JUMP IF ARBLK
19721: *
19722: * HERE FOR VECTOR
19723: *
19724: SUB =VCVLB,WA ADJUST FOR STANDARD FIELDS
19725: MTI WA MOVE TO INTEGER ACCUM
19726: JSR PRTIN PRINT LINEAR SUBSCRIPT
19727: BRN PRN14 MERGE BACK FOR RIGHT BRACKET
19728: EJC
19729: *
19730: * PRTNM (CONTINUED)
19731: *
19732: * HERE FOR ARRAY. FIRST CALCULATE ABSOLUTE SUBSCRIPT
19733: * OFFSETS BY SUCCESSIVE DIVISIONS BY THE DIMENSION VALUES.
19734: * THIS MUST BE DONE RIGHT TO LEFT SINCE THE ELEMENTS ARE
19735: * STORED ROW-WISE. THE SUBSCRIPTS ARE STACKED AS INTEGERS.
19736: *
19737: PRN16 MOV AROFS(XL),WC LOAD LENGTH OF BOUNDS INFO
19738: ICA WC ADJUST FOR ARPRO FIELD
19739: BTW WC CONVERT TO WORDS
19740: SUB WC,WA GET LINEAR ZERO-ORIGIN SUBSCRIPT
19741: MTI WA GET INTEGER VALUE
19742: LCT WA,ARNDM(XL) SET NUM OF DIMENSIONS AS LOOP COUNT
19743: ADD AROFS(XL),XL POINT PAST BOUNDS INFORMATION
19744: SUB *ARLBD,XL SET OK OFFSET FOR PROPER PTR LATER
19745: *
19746: * LOOP TO STACK SUBSCRIPT OFFSETS
19747: *
19748: PRN17 SUB *ARDMS,XL POINT TO NEXT SET OF BOUNDS
19749: STI PRNSI SAVE CURRENT OFFSET
19750: RMI ARDIM(XL) GET REMAINDER ON DIVIDING BY DIMENS
19751: MFI -(XS) STORE ON STACK (ONE WORD)
19752: LDI PRNSI RELOAD ARGUMENT
19753: DVI ARDIM(XL) DIVIDE TO GET QUOTIENT
19754: BCT WA,PRN17 LOOP TILL ALL STACKED
19755: ZER XR SET OFFSET TO FIRST SET OF BOUNDS
19756: LCT WB,ARNDM(XL) LOAD COUNT OF DIMS TO CONTROL LOOP
19757: BRN PRN19 JUMP INTO PRINT LOOP
19758: *
19759: * LOOP TO PRINT SUBSCRIPTS FROM STACK ADJUSTING BY ADDING
19760: * THE APPROPRIATE LOW BOUND VALUE FROM THE ARBLK
19761: *
19762: PRN18 MOV =CH$CM,WA LOAD A COMMA
19763: JSR PRTCH PRINT IT
19764: *
19765: * MERGE HERE FIRST TIME IN (NO COMMA REQUIRED)
19766: *
19767: PRN19 MTI (XS)+ LOAD SUBSCRIPT OFFSET AS INTEGER
19768: ADD XR,XL POINT TO CURRENT LBD
19769: ADI ARLBD(XL) ADD LBD TO GET SIGNED SUBSCRIPT
19770: SUB XR,XL POINT BACK TO START OF ARBLK
19771: JSR PRTIN PRINT SUBSCRIPT
19772: ADD *ARDMS,XR BUMP OFFSET TO NEXT BOUNDS
19773: BCT WB,PRN18 LOOP BACK TILL ALL PRINTED
19774: BRN PRN14 MERGE BACK TO PRINT RIGHT BRACKET
19775: ENP END PROCEDURE PRTNM
19776: EJC
19777: *
19778: * PRTNV -- PRINT NAME VALUE
19779: *
19780: * PRTNV IS USED BY THE TRACE AND DUMP ROUTINES TO PRINT
19781: * A LINE OF THE FORM
19782: *
19783: * NAME = VALUE
19784: *
19785: * NOTE THAT THE NAME INVOLVED CAN NEVER BE A PSEUDO-VAR
19786: *
19787: * (XL) NAME BASE
19788: * (WA) NAME OFFSET
19789: * JSR PRTNV CALL TO PRINT NAME = VALUE
19790: * (WB,WC,RA) DESTROYED
19791: *
19792: PRTNV PRC E,0 ENTRY POINT
19793: JSR PRTNM PRINT ARGUMENT NAME
19794: MOV XR,-(XS) SAVE ENTRY XR
19795: MOV WA,-(XS) SAVE NAME OFFSET (COLLECTABLE)
19796: MOV =TMBEB,XR POINT TO BLANK EQUAL BLANK
19797: JSR PRTST PRINT IT
19798: MOV XL,XR COPY NAME BASE
19799: ADD WA,XR POINT TO VALUE
19800: MOV (XR),XR LOAD VALUE POINTER
19801: JSR PRTVL PRINT VALUE
19802: JSR PRTNL TERMINATE LINE
19803: MOV (XS)+,WA RESTORE NAME OFFSET
19804: MOV (XS)+,XR RESTORE ENTRY XR
19805: EXI RETURN TO CALLER
19806: ENP END PROCEDURE PRTNV
19807: EJC
19808: *
19809: * PRTPG -- PRINT A PAGE THROW
19810: *
19811: * PRINTS A PAGE THROW OR A FEW BLANK LINES ON THE STANDARD
19812: * LISTING CHANNEL DEPENDING ON THE LISTING OPTIONS CHOSEN.
19813: *
19814: * JSR PRTPG CALL FOR PAGE EJECT
19815: *
19816: PRTPG PRC E,0 ENTRY POINT
19817: BEQ STAGE,=STGXT,PRP01 JUMP IF EXECUTION TIME
19818: BZE LSTLC,PRP06 RETURN IF TOP OF PAGE ALREADY
19819: ZER LSTLC CLEAR LINE COUNT
19820: *
19821: * CHECK TYPE OF LISTING
19822: *
19823: PRP01 MOV XR,-(XS) PRESERVE XR
19824: BNZ PRSTD,PRP02 EJECT IF FLAG SET
19825: BNZ PRICH,PRP03 JUMP IF INTERACTIVE LISTING CHANNEL
19826: BZE PRECL,PRP03 JUMP IF COMPACT LISTING
19827: *
19828: * PERFORM AN EJECT
19829: *
19830: PRP02 JSR SYSEP EJECT
19831: BRN PRP04 MERGE
19832: *
19833: * COMPACT OR INTERACTIVE CHANNEL LISTING. CANT PRINT
19834: * BLANKS UNTIL CHECK MADE FOR HEADERS PRINTED AND FLAG SET.
19835: *
19836: *
19837: PRP03 MOV HEADP,XR REMEMBER HEADP
19838: MNZ HEADP SET TO AVOID REPEATED PRTPG CALLS
19839: JSR PRTNL PRINT BLANK LINE
19840: JSR PRTNL PRINT BLANK LINE
19841: JSR PRTNL PRINT BLANK LINE
19842: MOV =NUM03,LSTLC COUNT BLANK LINES
19843: MOV XR,HEADP RESTORE HEADER FLAG
19844: EJC
19845: *
19846: * PRPTG (CONTINUED)
19847: *
19848: * PRINT THE HEADING
19849: *
19850: PRP04 BNZ HEADP,PRP05 JUMP IF HEADER LISTED
19851: MNZ HEADP MARK HEADERS PRINTED
19852: MOV XL,-(XS) KEEP XL
19853: MOV =HEADR,XR POINT TO LISTING HEADER
19854: JSR PRTST PLACE IT
19855: JSR SYSID GET SYSTEM IDENTIFICATION
19856: JSR PRTST APPEND EXTRA CHARS
19857: JSR PRTNL PRINT IT
19858: MOV XL,XR EXTRA HEADER LINE
19859: JSR PRTST PLACE IT
19860: JSR PRTNL PRINT IT
19861: JSR PRTNL PRINT A BLANK
19862: JSR PRTNL AND ANOTHER
19863: ADD =NUM04,LSTLC FOUR HEADER LINES PRINTED
19864: MOV (XS)+,XL RESTORE XL
19865: *
19866: * MERGE IF HEADER NOT PRINTED
19867: *
19868: PRP05 MOV (XS)+,XR RESTORE XR
19869: *
19870: * RETURN
19871: *
19872: PRP06 EXI RETURN
19873: ENP END PROCEDURE PRTPG
19874: EJC
19875: *
19876: * PRTPS - PRINT PAGE WITH TEST FOR STANDARD LISTING OPTION
19877: *
19878: * IF THE STANDARD LISTING OPTION IS SELECTED, INSIST THAT
19879: * AN EJECT BE DONE
19880: *
19881: * JSR PRTPS CALL FOR EJECT
19882: *
19883: PRTPS PRC E,0 ENTRY POINT
19884: MOV PRSTO,PRSTD COPY OPTION FLAG
19885: JSR PRTPG PRINT PAGE
19886: ZER PRSTD CLEAR FLAG
19887: EXI RETURN
19888: ENP END PROCEDURE PRTPS
19889: EJC
19890: *
19891: * PRTSN -- PRINT STATEMENT NUMBER
19892: *
19893: * PRTSN IS USED TO INITIATE A PRINT TRACE LINE BY PRINTING
19894: * ASTERISKS AND THE CURRENT STATEMENT NUMBER. THE ACTUAL
19895: * FORMAT OF THE OUTPUT GENERATED IS.
19896: *
19897: * ***NNNNN**** III.....IIII
19898: *
19899: * NNNNN IS THE STATEMENT NUMBER WITH LEADING ZEROS REPLACED
19900: * BY ASTERISKS (E.G. *******9****)
19901: *
19902: * III...III REPRESENTS A VARIABLE LENGTH OUTPUT CONSISTING
19903: * OF A NUMBER OF LETTER I CHARACTERS EQUAL TO FNCLEVEL.
19904: *
19905: * JSR PRTSN CALL TO PRINT STATEMENT NUMBER
19906: * (WC) DESTROYED
19907: *
19908: PRTSN PRC E,0 ENTRY POINT
19909: MOV XR,-(XS) SAVE ENTRY XR
19910: MOV WA,PRSNA SAVE ENTRY WA
19911: MOV =TMASB,XR POINT TO ASTERISKS
19912: JSR PRTST PRINT ASTERISKS
19913: MOV =NUM04,PROFS POINT INTO MIDDLE OF ASTERISKS
19914: MTI KVSTN LOAD STATEMENT NUMBER AS INTEGER
19915: JSR PRTIN PRINT INTEGER STATEMENT NUMBER
19916: MOV =PRSNF,PROFS POINT PAST ASTERISKS PLUS BLANK
19917: MOV KVFNC,XR GET FNCLEVEL
19918: MOV =CH$LI,WA SET LETTER I
19919: *
19920: * LOOP TO GENERATE LETTER I FNCLEVEL TIMES
19921: *
19922: PRSN1 BZE XR,PRSN2 JUMP IF ALL SET
19923: JSR PRTCH ELSE PRINT AN I
19924: DCV XR DECREMENT COUNTER
19925: BRN PRSN1 LOOP BACK
19926: *
19927: * MERRE WITH ALL LETTER I CHARACTERS GENERATED
19928: *
19929: PRSN2 MOV =CH$BL,WA GET BLANK
19930: JSR PRTCH PRINT BLANK
19931: MOV PRSNA,WA RESTORE ENTRY WA
19932: MOV (XS)+,XR RESTORE ENTRY XR
19933: EXI RETURN TO PRTSN CALLER
19934: ENP END PROCEDURE PRTSN
19935: EJC
19936: *
19937: * PRTST -- PRINT STRING
19938: *
19939: * PRTST PLACES A STRING OF CHARACTERS IN THE PRINT BUFFER
19940: *
19941: * SEE PRTNL FOR GLOBAL LOCATIONS USED
19942: *
19943: * NOTE THAT THE FIRST WORD OF THE BLOCK (NORMALLY B$SCL)
19944: * IS NOT USED AND NEED NOT BE SET CORRECTLY (SEE PRTVN)
19945: *
19946: * (XR) STRING TO BE PRINTED
19947: * JSR PRTST CALL TO PRINT STRING
19948: * (PROFS) UPDATED PAST CHARS PLACED
19949: *
19950: PRTST PRC R,0 ENTRY POINT
19951: BNZ HEADP,PRST0 WERE HEADERS PRINTED
19952: JSR PRTPS NO - PRINT THEM
19953: *
19954: * CALL SYSPR
19955: *
19956: PRST0 MOV WA,PRSVA SAVE WA
19957: MOV WB,PRSVB SAVE WB
19958: ZER WB SET CHARS PRINTED COUNT TO ZERO
19959: *
19960: * LOOP TO PRINT SUCCESSIVE LINES FOR LONG STRING
19961: *
19962: PRST1 MOV SCLEN(XR),WA LOAD STRING LENGTH
19963: SUB WB,WA SUBTRACT COUNT OF CHARS ALREADY OUT
19964: BZE WA,PRST4 JUMP TO EXIT IF NONE LEFT
19965: MOV XL,-(XS) ELSE STACK ENTRY XL
19966: MOV XR,-(XS) SAVE ARGUMENT
19967: MOV XR,XL COPY FOR EVENTUAL MOVE
19968: MOV PRLEN,XR LOAD PRINT BUFFER LENGTH
19969: SUB PROFS,XR GET CHARS LEFT IN PRINT BUFFER
19970: BNZ XR,PRST2 SKIP IF ROOM LEFT ON THIS LINE
19971: JSR PRTNL ELSE PRINT THIS LINE
19972: MOV PRLEN,XR AND SET FULL WIDTH AVAILABLE
19973: EJC
19974: *
19975: * PRTST (CONTINUED)
19976: *
19977: * HERE WITH CHARS TO PRINT AND SOME ROOM IN BUFFER
19978: *
19979: PRST2 BLO WA,XR,PRST3 JUMP IF ROOM FOR REST OF STRING
19980: MOV XR,WA ELSE SET TO FILL LINE
19981: *
19982: * MERGE HERE WITH CHARACTER COUNT IN WA
19983: *
19984: PRST3 MOV PRBUF,XR POINT TO PRINT BUFFER
19985: PLC XL,WB POINT TO LOCATION IN STRING
19986: PSC XR,PROFS POINT TO LOCATION IN BUFFER
19987: ADD WA,WB BUMP STRING CHARS COUNT
19988: ADD WA,PROFS BUMP BUFFER POINTER
19989: MOV WB,PRSVC PRESERVE CHAR COUNTER
19990: MVC MOVE CHARACTERS TO BUFFER
19991: MOV PRSVC,WB RECOVER CHAR COUNTER
19992: MOV (XS)+,XR RESTORE ARGUMENT POINTER
19993: MOV (XS)+,XL RESTORE ENTRY XL
19994: BRN PRST1 LOOP BACK TO TEST FOR MORE
19995: *
19996: * HERE TO EXIT AFTER PRINTING STRING
19997: *
19998: PRST4 MOV PRSVB,WB RESTORE ENTRY WB
19999: MOV PRSVA,WA RESTORE ENTRY WA
20000: EXI RETURN TO PRTST CALLER
20001: ENP END PROCEDURE PRTST
20002: EJC
20003: *
20004: * PRTTR -- PRINT TO TERMINAL
20005: *
20006: * CALLED TO PRINT CONTENTS OF STANDARD PRINT BUFFER TO
20007: * ONLINE TERMINAL. CLEARS BUFFER DOWN AND RESETS PROFS.
20008: *
20009: * JSR PRTTR CALL FOR PRINT
20010: * (WA,WB) DESTROYED
20011: *
20012: PRTTR PRC E,0 ENTRY POINT
20013: MOV XR,-(XS) SAVE XR
20014: JSR PRTIC PRINT BUFFER CONTENTS
20015: MOV PRBUF,XR POINT TO PRINT BFR TO CLEAR IT
20016: LCT WA,PRLNW GET BUFFER LENGTH
20017: ADD *SCHAR,XR POINT PAST SCBLK HEADER
20018: MOV NULLW,WB GET BLANKS
20019: *
20020: * LOOP TO CLEAR BUFFER
20021: *
20022: PRTT1 MOV WB,(XR)+ CLEAR A WORD
20023: BCT WA,PRTT1 LOOP
20024: ZER PROFS RESET PROFS
20025: MOV (XS)+,XR RESTORE XR
20026: EXI RETURN
20027: ENP END PROCEDURE PRTTR
20028: EJC
20029: *
20030: * PRTVL -- PRINT A VALUE
20031: *
20032: * PRTVL PLACES AN APPROPRIATE CHARACTER REPRESENTATION OF
20033: * A DATA VALUE IN THE PRINT BUFFER FOR DUMP/TRACE USE.
20034: *
20035: * (XR) VALUE TO BE PRINTED
20036: * JSR PRTVL CALL TO PRINT VALUE
20037: * (WA,WB,WC,RA) DESTROYED
20038: *
20039: PRTVL PRC R,0 ENTRY POINT, RECURSIVE
20040: MOV XL,-(XS) SAVE ENTRY XL
20041: MOV XR,-(XS) SAVE ARGUMENT
20042: CHK CHECK FOR STACK OVERFLOW
20043: *
20044: * LOOP BACK HERE AFTER FINDING A TRAP BLOCK (TRBLK)
20045: *
20046: PRV01 MOV IDVAL(XR),PRVSI COPY IDVAL (IF ANY)
20047: MOV (XR),XL LOAD FIRST WORD OF BLOCK
20048: LEI XL LOAD ENTRY POINT ID
20049: BSW XL,BL$$T,PRV02 SWITCH ON BLOCK TYPE
20050: IFF BL$TR,PRV04 TRBLK
20051: IFF BL$AR,PRV05 ARBLK
20052: IFF BL$IC,PRV08 ICBLK
20053: IFF BL$NM,PRV09 NMBLK
20054: IFF BL$PD,PRV10 PDBLK
20055: IFF BL$RC,PRV08 RCBLK
20056: IFF BL$SC,PRV11 SCBLK
20057: IFF BL$SE,PRV12 SEBLK
20058: IFF BL$TB,PRV13 TBBLK
20059: IFF BL$VC,PRV13 VCBLK
20060: IFF BL$BC,PRV15 BCBLK
20061: ESW END OF SWITCH ON BLOCK TYPE
20062: *
20063: * HERE FOR BLOCKS FOR WHICH WE JUST PRINT DATATYPE NAME
20064: *
20065: PRV02 JSR DTYPE GET DATATYPE NAME
20066: JSR PRTST PRINT DATATYPE NAME
20067: *
20068: * COMMON EXIT POINT
20069: *
20070: PRV03 MOV (XS)+,XR RELOAD ARGUMENT
20071: MOV (XS)+,XL RESTORE XL
20072: EXI RETURN TO PRTVL CALLER
20073: *
20074: * HERE FOR TRBLK
20075: *
20076: PRV04 MOV TRVAL(XR),XR LOAD REAL VALUE
20077: BRN PRV01 AND LOOP BACK
20078: EJC
20079: *
20080: * PRTVL (CONTINUED)
20081: *
20082: * HERE FOR ARRAY (ARBLK)
20083: *
20084: * PRINT ARRAY ( PROTOTYPE ) BLANK NUMBER IDVAL
20085: *
20086: PRV05 MOV XR,XL PRESERVE ARGUMENT
20087: MOV =SCARR,XR POINT TO DATATYPE NAME (ARRAY)
20088: JSR PRTST PRINT IT
20089: MOV =CH$PP,WA LOAD LEFT PAREN
20090: JSR PRTCH PRINT LEFT PAREN
20091: ADD AROFS(XL),XL POINT TO PROTOTYPE
20092: MOV (XL),XR LOAD PROTOTYPE
20093: JSR PRTST PRINT PROTOTYPE
20094: *
20095: * VCBLK, TBBLK, BCBLK MERGE HERE FOR ) BLANK NUMBER IDVAL
20096: *
20097: PRV06 MOV =CH$RP,WA LOAD RIGHT PAREN
20098: JSR PRTCH PRINT RIGHT PAREN
20099: *
20100: * PDBLK MERGES HERE TO PRINT BLANK NUMBER IDVAL
20101: *
20102: PRV07 MOV =CH$BL,WA LOAD BLANK
20103: JSR PRTCH PRINT IT
20104: MOV =CH$NM,WA LOAD NUMBER SIGN
20105: JSR PRTCH PRINT IT
20106: MTI PRVSI GET IDVAL
20107: JSR PRTIN PRINT ID NUMBER
20108: BRN PRV03 BACK TO EXIT
20109: *
20110: * HERE FOR INTEGER (ICBLK), REAL (RCBLK)
20111: *
20112: * PRINT CHARACTER REPRESENTATION OF VALUE
20113: *
20114: PRV08 MOV XR,-(XS) STACK ARGUMENT FOR GTSTG
20115: JSR GTSTG CONVERT TO STRING
20116: PPM ERROR RETURN IS IMPOSSIBLE
20117: JSR PRTST PRINT THE STRING
20118: MOV XR,DNAMP DELETE GARBAGE STRING FROM STORAGE
20119: BRN PRV03 BACK TO EXIT
20120: EJC
20121: *
20122: * PRTVL (CONTINUED)
20123: *
20124: * NAME (NMBLK)
20125: *
20126: * FOR PSEUDO-VARIABLE, JUST PRINT DATATYPE NAME (NAME)
20127: * FOR ALL OTHER NAMES, PRINT DOT FOLLOWED BY NAME REP
20128: *
20129: PRV09 MOV NMBAS(XR),XL LOAD NAME BASE
20130: MOV (XL),WA LOAD FIRST WORD OF BLOCK
20131: BEQ WA,=B$KVT,PRV02 JUST PRINT NAME IF KEYWORD
20132: BEQ WA,=B$EVT,PRV02 JUST PRINT NAME IF EXPRESSION VAR
20133: MOV =CH$DT,WA ELSE GET DOT
20134: JSR PRTCH AND PRINT IT
20135: MOV NMOFS(XR),WA LOAD NAME OFFSET
20136: JSR PRTNM PRINT NAME
20137: BRN PRV03 BACK TO EXIT
20138: *
20139: * PROGRAM DATATYPE (PDBLK)
20140: *
20141: * PRINT DATATYPE NAME CH$BL CH$NM IDVAL
20142: *
20143: PRV10 JSR DTYPE GET DATATYPE NAME
20144: JSR PRTST PRINT DATATYPE NAME
20145: BRN PRV07 MERGE BACK TO PRINT ID
20146: *
20147: * HERE FOR STRING (SCBLK)
20148: *
20149: * PRINT QUOTE STRING-CHARACTERS QUOTE
20150: *
20151: PRV11 MOV =CH$SQ,WA LOAD SINGLE QUOTE
20152: JSR PRTCH PRINT QUOTE
20153: JSR PRTST PRINT STRING VALUE
20154: JSR PRTCH PRINT ANOTHER QUOTE
20155: BRN PRV03 BACK TO EXIT
20156: EJC
20157: *
20158: * PRTVL (CONTINUED)
20159: *
20160: * HERE FOR SIMPLE EXPRESSION (SEBLK)
20161: *
20162: * PRINT ASTERISK VARIABLE-NAME
20163: *
20164: PRV12 MOV =CH$AS,WA LOAD ASTERISK
20165: JSR PRTCH PRINT ASTERISK
20166: MOV SEVAR(XR),XR LOAD VARIABLE POINTER
20167: JSR PRTVN PRINT VARIABLE NAME
20168: BRN PRV03 JUMP BACK TO EXIT
20169: *
20170: * HERE FOR TABLE (TBBLK) AND ARRAY (VCBLK)
20171: *
20172: * PRINT DATATYPE ( PROTOTYPE ) BLANK NUMBER IDVAL
20173: *
20174: PRV13 MOV XR,XL PRESERVE ARGUMENT
20175: JSR DTYPE GET DATATYPE NAME
20176: JSR PRTST PRINT DATATYPE NAME
20177: MOV =CH$PP,WA LOAD LEFT PAREN
20178: JSR PRTCH PRINT LEFT PAREN
20179: MOV TBLEN(XL),WA LOAD LENGTH OF BLOCK (=VCLEN)
20180: BTW WA CONVERT TO WORD COUNT
20181: SUB =TBSI$,WA ALLOW FOR STANDARD FIELDS
20182: BEQ (XL),=B$TBT,PRV14 JUMP IF TABLE
20183: ADD =VCTBD,WA FOR VCBLK, ADJUST SIZE
20184: *
20185: * PRINT PROTOTYPE
20186: *
20187: PRV14 MTI WA MOVE AS INTEGER
20188: JSR PRTIN PRINT INTEGER PROTOTYPE
20189: BRN PRV06 MERGE BACK FOR REST
20190: EJC
20191: *
20192: * PRTVL (CONTINUED)
20193: *
20194: * HERE FOR BUFFER (BCBLK)
20195: *
20196: PRV15 MOV XR,XL PRESERVE ARGUMENT
20197: MOV =SCBUF,XR POINT TO DATATYPE NAME (BUFFER)
20198: JSR PRTST PRINT IT
20199: MOV =CH$PP,WA LOAD LEFT PAREN
20200: JSR PRTCH PRINT LEFT PAREN
20201: MOV BCBUF(XL),XR POINT TO BFBLK
20202: MTI BFALC(XR) LOAD ALLOCATION SIZE
20203: JSR PRTIN PRINT IT
20204: MOV =CH$CM,WA LOAD COMMA
20205: JSR PRTCH PRINT IT
20206: MTI BCLEN(XL) LOAD DEFINED LENGTH
20207: JSR PRTIN PRINT IT
20208: BRN PRV06 MERGE TO FINISH UP
20209: ENP END PROCEDURE PRTVL
20210: EJC
20211: *
20212: * PRTVN -- PRINT NATURAL VARIABLE NAME
20213: *
20214: * PRTVN PRINTS THE NAME OF A NATURAL VARIABLE
20215: *
20216: * (XR) POINTER TO VRBLK
20217: * JSR PRTVN CALL TO PRINT VARIABLE NAME
20218: *
20219: PRTVN PRC E,0 ENTRY POINT
20220: MOV XR,-(XS) STACK VRBLK POINTER
20221: ADD *VRSOF,XR POINT TO POSSIBLE STRING NAME
20222: BNZ SCLEN(XR),PRVN1 JUMP IF NOT SYSTEM VARIABLE
20223: MOV VRSVO(XR),XR POINT TO SVBLK WITH NAME
20224: *
20225: * MERGE HERE WITH DUMMY SCBLK POINTER IN XR
20226: *
20227: PRVN1 JSR PRTST PRINT STRING NAME OF VARIABLE
20228: MOV (XS)+,XR RESTORE VRBLK POINTER
20229: EXI RETURN TO PRTVN CALLER
20230: ENP END PROCEDURE PRTVN
20231: EJC
20232: *
20233: * RCBLD -- BUILD A REAL BLOCK
20234: *
20235: * (RA) REAL VALUE FOR RCBLK
20236: * JSR RCBLD CALL TO BUILD REAL BLOCK
20237: * (XR) POINTER TO RESULT RCBLK
20238: * (WA) DESTROYED
20239: *
20240: RCBLD PRC E,0 ENTRY POINT
20241: MOV DNAMP,XR LOAD POINTER TO NEXT AVAILABLE LOC
20242: ADD *RCSI$,XR POINT PAST NEW RCBLK
20243: BLO XR,DNAME,RCBL1 JUMP IF THERE IS ROOM
20244: MOV *RCSI$,WA ELSE LOAD RCBLK LENGTH
20245: JSR ALLOC USE STANDARD ALLOCATOR TO GET BLOCK
20246: ADD WA,XR POINT PAST BLOCK TO MERGE
20247: *
20248: * MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED
20249: *
20250: RCBL1 MOV XR,DNAMP SET NEW POINTER
20251: SUB *RCSI$,XR POINT BACK TO START OF BLOCK
20252: MOV =B$RCL,(XR) STORE TYPE WORD
20253: STR RCVAL(XR) STORE REAL VALUE IN RCBLK
20254: EXI RETURN TO RCBLD CALLER
20255: ENP END PROCEDURE RCBLD
20256: EJC
20257: *
20258: * READR -- READ NEXT SOURCE IMAGE AT COMPILE TIME
20259: *
20260: * READR IS USED TO READ THE NEXT SOURCE IMAGE. TO PROCESS
20261: * CONTINUATION CARDS PROPERLY, THE COMPILER MUST READ ONE
20262: * LINE AHEAD. THUS READR DOES NOT DESTROY THE CURRENT IMAGE
20263: * SEE ALSO THE NEXTS ROUTINE WHICH ACTUALLY GETS THE IMAGE.
20264: *
20265: * JSR READR CALL TO READ NEXT IMAGE
20266: * (XR) PTR TO NEXT IMAGE (0 IF NONE)
20267: * (R$CNI) COPY OF POINTER
20268: * (WA,WB,WC,XL) DESTROYED
20269: *
20270: READR PRC E,0 ENTRY POINT
20271: MOV R$CNI,XR GET PTR TO NEXT IMAGE
20272: BNZ XR,READ3 EXIT IF ALREADY READ
20273: BNE STAGE,=STGIC,READ3 EXIT IF NOT INITIAL COMPILE
20274: MOV CSWIN,WA MAX READ LENGTH
20275: JSR ALOCS ALLOCATE BUFFER
20276: JSR SYSRD READ INPUT IMAGE
20277: PPM READ4 JUMP IF END OF FILE
20278: MNZ WB SET TRIMR TO PERFORM TRIM
20279: BLE SCLEN(XR),CSWIN,READ1 USE SMALLER OF STRING LNTH ..
20280: MOV CSWIN,SCLEN(XR) ... AND XXX OF -INXXX
20281: *
20282: * PERFORM THE TRIM
20283: *
20284: READ1 JSR TRIMR TRIM TRAILING BLANKS
20285: *
20286: * MERGE HERE AFTER READ
20287: *
20288: READ2 MOV XR,R$CNI STORE COPY OF POINTER
20289: *
20290: * MERGE HERE IF NO READ ATTEMPTED
20291: *
20292: READ3 EXI RETURN TO READR CALLER
20293: *
20294: * HERE ON END OF FILE
20295: *
20296: READ4 MOV XR,DNAMP POP UNUSED SCBLK
20297: ZER XR ZERO PTR AS RESULT
20298: BRN READ2 MERGE
20299: ENP END PROCEDURE READR
20300: EJC
20301: *
20302: * SBSTR -- BUILD A SUBSTRING
20303: *
20304: * (XL) PTR TO SCBLK/BFBLK WITH CHARS
20305: * (WA) NUMBER OF CHARS IN SUBSTRING
20306: * (WB) OFFSET TO FIRST CHAR IN SCBLK
20307: * JSR SBSTR CALL TO BUILD SUBSTRING
20308: * (XR) PTR TO NEW SCBLK WITH SUBSTRING
20309: * (XL) ZERO
20310: * (WA,WB,WC,XL,IA) DESTROYED
20311: *
20312: * NOTE THAT SBSTR IS CALLED WITH A DUMMY STRING POINTER
20313: * (POINTING INTO A VRBLK OR SVBLK) TO COPY THE NAME OF A
20314: * VARIABLE AS A STANDARD STRING VALUE.
20315: *
20316: SBSTR PRC E,0 ENTRY POINT
20317: BZE WA,SBST2 JUMP IF NULL SUBSTRING
20318: JSR ALOCS ELSE ALLOCATE SCBLK
20319: MOV WC,WA MOVE NUMBER OF CHARACTERS
20320: MOV XR,WC SAVE PTR TO NEW SCBLK
20321: PLC XL,WB PREPARE TO LOAD CHARS FROM OLD BLK
20322: PSC XR PREPARE TO STORE CHARS IN NEW BLK
20323: MVC MOVE CHARACTERS TO NEW STRING
20324: MOV WC,XR THEN RESTORE SCBLK POINTER
20325: *
20326: * RETURN POINT
20327: *
20328: SBST1 ZER XL CLEAR GARBAGE POINTER IN XL
20329: EXI RETURN TO SBSTR CALLER
20330: *
20331: * HERE FOR NULL SUBSTRING
20332: *
20333: SBST2 MOV =NULLS,XR SET NULL STRING AS RESULT
20334: BRN SBST1 RETURN
20335: ENP END PROCEDURE SBSTR
20336: EJC
20337: *
20338: * SCANE -- SCAN AN ELEMENT
20339: *
20340: * SCANE IS CALLED AT COMPILE TIME (BY EXPAN ,CMPIL,CNCRD)
20341: * TO SCAN ONE ELEMENT FROM THE INPUT IMAGE.
20342: *
20343: * (SCNCC) NON-ZERO IF CALLED FROM CNCRD
20344: * JSR SCANE CALL TO SCAN ELEMENT
20345: * (XR) RESULT POINTER (SEE BELOW)
20346: * (XL) SYNTAX TYPE CODE (T$XXX)
20347: *
20348: * THE FOLLOWING GLOBAL LOCATIONS ARE USED.
20349: *
20350: * R$CIM POINTER TO STRING BLOCK (SCBLK)
20351: * FOR CURRENT INPUT IMAGE.
20352: *
20353: * R$CNI POINTER TO NEXT INPUT IMAGE STRING
20354: * POINTER (ZERO IF NONE).
20355: *
20356: * R$SCP SAVE POINTER (EXIT XR) FROM LAST
20357: * CALL IN CASE RESCAN IS SET.
20358: *
20359: * SCNBL THIS LOCATION IS SET NON-ZERO ON
20360: * EXIT IF SCANE SCANNED PAST BLANKS
20361: * BEFORE LOCATING THE CURRENT ELEMENT
20362: * THE END OF A LINE COUNTS AS BLANKS.
20363: *
20364: * SCNCC CNCRD SETS THIS NON-ZERO TO SCAN
20365: * CONTROL CARD NAMES AND CLEARS IT
20366: * ON RETURN
20367: *
20368: * SCNIL LENGTH OF CURRENT INPUT IMAGE
20369: *
20370: * SCNGO IF SET NON-ZERO ON ENTRY, F AND S
20371: * ARE RETURNED AS SEPARATE SYNTAX
20372: * TYPES (NOT LETTERS) (GOTO PRO-
20373: * CESSING). SCNGO IS RESET ON EXIT.
20374: *
20375: * SCNPT OFFSET TO CURRENT LOC IN R$CIM
20376: *
20377: * SCNRS IF SET NON-ZERO ON ENTRY, SCANE
20378: * RETURNS THE SAME RESULT AS ON THE
20379: * LAST CALL (RESCAN). SCNRS IS RESET
20380: * ON EXIT FROM ANY CALL TO SCANE.
20381: *
20382: * SCNTP SAVE SYNTAX TYPE FROM LAST
20383: * CALL (IN CASE RESCAN IS SET).
20384: EJC
20385: *
20386: * SCANE (CONTINUED)
20387: *
20388: *
20389: *
20390: * ELEMENT SCANNED XL XR
20391: * --------------- -- --
20392: *
20393: * CONTROL CARD NAME 0 POINTER TO SCBLK FOR NAME
20394: *
20395: * UNARY OPERATOR T$UOP PTR TO OPERATOR DVBLK
20396: *
20397: * LEFT PAREN T$LPR T$LPR
20398: *
20399: * LEFT BRACKET T$LBR T$LBR
20400: *
20401: * COMMA T$CMA T$CMA
20402: *
20403: * FUNCTION CALL T$FNC PTR TO FUNCTION VRBLK
20404: *
20405: * VARIABLE T$VAR PTR TO VRBLK
20406: *
20407: * STRING CONSTANT T$CON PTR TO SCBLK
20408: *
20409: * INTEGER CONSTANT T$CON PTR TO ICBLK
20410: *
20411: * REAL CONSTANT T$CON PTR TO RCBLK
20412: *
20413: * BINARY OPERATOR T$BOP PTR TO OPERATOR DVBLK
20414: *
20415: * RIGHT PAREN T$RPR T$RPR
20416: *
20417: * RIGHT BRACKET T$RBR T$RBR
20418: *
20419: * COLON T$COL T$COL
20420: *
20421: * SEMI-COLON T$SMC T$SMC
20422: *
20423: * F (SCNGO NE 0) T$FGO T$FGO
20424: *
20425: * S (SCNGO NE 0) T$SGO T$SGO
20426: EJC
20427: *
20428: * SCANE (CONTINUED)
20429: *
20430: * ENTRY POINT
20431: *
20432: SCANE PRC E,0 ENTRY POINT
20433: ZER SCNBL RESET BLANKS FLAG
20434: MOV WA,SCNSA SAVE WA
20435: MOV WB,SCNSB SAVE WB
20436: MOV WC,SCNSC SAVE WC
20437: BZE SCNRS,SCN03 JUMP IF NO RESCAN
20438: *
20439: * HERE FOR RESCAN REQUEST
20440: *
20441: MOV SCNTP,XL SET PREVIOUS RETURNED SCAN TYPE
20442: MOV R$SCP,XR SET PREVIOUS RETURNED POINTER
20443: ZER SCNRS RESET RESCAN SWITCH
20444: BRN SCN13 JUMP TO EXIT
20445: *
20446: * COME HERE TO READ NEW IMAGE TO TEST FOR CONTINUATION
20447: *
20448: SCN01 JSR READR READ NEXT IMAGE
20449: MOV *DVUBS,WB SET WB FOR NOT READING NAME
20450: BZE XR,SCN30 TREAT AS SEMI-COLON IF NONE
20451: PLC XR ELSE POINT TO FIRST CHARACTER
20452: LCH WC,(XR) LOAD FIRST CHARACTER
20453: BEQ WC,=CH$DT,SCN02 JUMP IF DOT FOR CONTINUATION
20454: BNE WC,=CH$PL,SCN30 ELSE TREAT AS SEMICOLON UNLESS PLUS
20455: *
20456: * HERE FOR CONTINUATION LINE
20457: *
20458: SCN02 JSR NEXTS ACQUIRE NEXT SOURCE IMAGE
20459: MOV =NUM01,SCNPT SET SCAN POINTER PAST CONTINUATION
20460: MNZ SCNBL SET BLANKS FLAG
20461: EJC
20462: *
20463: * SCANE (CONTINUED)
20464: *
20465: * MERGE HERE TO SCAN NEXT ELEMENT ON CURRENT LINE
20466: *
20467: SCN03 MOV SCNPT,WA LOAD CURRENT OFFSET
20468: BEQ WA,SCNIL,SCN01 CHECK CONTINUATION IF END
20469: MOV R$CIM,XL POINT TO CURRENT LINE
20470: PLC XL,WA POINT TO CURRENT CHARACTER
20471: MOV WA,SCNSE SET START OF ELEMENT LOCATION
20472: MOV =OPDVS,WC POINT TO OPERATOR DV LIST
20473: MOV *DVUBS,WB SET CONSTANT FOR OPERATOR CIRCUIT
20474: BRN SCN06 START SCANNING
20475: *
20476: * LOOP HERE TO IGNORE LEADING BLANKS AND TABS
20477: *
20478: SCN05 BZE WB,SCN10 JUMP IF TRAILING
20479: ICV SCNSE INCREMENT START OF ELEMENT
20480: BEQ WA,SCNIL,SCN01 JUMP IF END OF IMAGE
20481: MNZ SCNBL NOTE BLANKS SEEN
20482: *
20483: * THE FOLLOWING JUMP IS USED REPEATEDLY FOR SCANNING OUT
20484: * THE CHARACTERS OF A NUMERIC CONSTANT OR VARIABLE NAME.
20485: * THE REGISTERS ARE USED AS FOLLOWS.
20486: *
20487: * (XR) SCRATCH
20488: * (XL) PTR TO NEXT CHARACTER
20489: * (WA) CURRENT SCAN OFFSET
20490: * (WB) *DVUBS (0 IF SCANNING NAME,CONST)
20491: * (WC) =OPDVS (0 IF SCANNING CONSTANT)
20492: *
20493: SCN06 LCH XR,(XL)+ GET NEXT CHARACTER
20494: ICV WA BUMP SCAN OFFSET
20495: MOV WA,SCNPT STORE OFFSET PAST CHAR SCANNED
20496: BLO =CFP$U,XR,SCN07 QUICK CHECK FOR OTHER CHAR
20497: BSW XR,CFP$U,SCN07 SWITCH ON SCANNED CHARACTER
20498: *
20499: * SWITCH TABLE FOR SWITCH ON CHARACTER
20500: *
20501: IFF CH$BL,SCN05 BLANK
20502: IFF CH$HT,SCN05 HORIZONTAL TAB
20503: IFF CH$D0,SCN08 DIGIT 0
20504: IFF CH$D1,SCN08 DIGIT 1
20505: IFF CH$D2,SCN08 DIGIT 2
20506: IFF CH$D3,SCN08 DIGIT 3
20507: IFF CH$D4,SCN08 DIGIT 4
20508: IFF CH$D5,SCN08 DIGIT 5
20509: IFF CH$D6,SCN08 DIGIT 6
20510: IFF CH$D7,SCN08 DIGIT 7
20511: IFF CH$D8,SCN08 DIGIT 8
20512: IFF CH$D9,SCN08 DIGIT 9
20513: EJC
20514: *
20515: * SCANE (CONTINUED)
20516: *
20517: IFF CH$LA,SCN09 LETTER A
20518: IFF CH$LB,SCN09 LETTER B
20519: IFF CH$LC,SCN09 LETTER C
20520: IFF CH$LD,SCN09 LETTER D
20521: IFF CH$LE,SCN09 LETTER E
20522: IFF CH$LG,SCN09 LETTER G
20523: IFF CH$LH,SCN09 LETTER H
20524: IFF CH$LI,SCN09 LETTER I
20525: IFF CH$LJ,SCN09 LETTER J
20526: IFF CH$LK,SCN09 LETTER K
20527: IFF CH$LL,SCN09 LETTER L
20528: IFF CH$LM,SCN09 LETTER M
20529: IFF CH$LN,SCN09 LETTER N
20530: IFF CH$LO,SCN09 LETTER O
20531: IFF CH$LP,SCN09 LETTER P
20532: IFF CH$LQ,SCN09 LETTER Q
20533: IFF CH$LR,SCN09 LETTER R
20534: IFF CH$LT,SCN09 LETTER T
20535: IFF CH$LU,SCN09 LETTER U
20536: IFF CH$LV,SCN09 LETTER V
20537: IFF CH$LW,SCN09 LETTER W
20538: IFF CH$LX,SCN09 LETTER X
20539: IFF CH$LY,SCN09 LETTER Y
20540: IFF CH$L$,SCN09 LETTER Z
20541: IFF CH$$A,SCN09 SHIFTED A
20542: IFF CH$$B,SCN09 SHIFTED B
20543: IFF CH$$C,SCN09 SHIFTED C
20544: IFF CH$$D,SCN09 SHIFTED D
20545: IFF CH$$E,SCN09 SHIFTED E
20546: IFF CH$$F,SCN20 SHIFTED F
20547: IFF CH$$G,SCN09 SHIFTED G
20548: IFF CH$$H,SCN09 SHIFTED H
20549: IFF CH$$I,SCN09 SHIFTED I
20550: IFF CH$$J,SCN09 SHIFTED J
20551: IFF CH$$K,SCN09 SHIFTED K
20552: IFF CH$$L,SCN09 SHIFTED L
20553: IFF CH$$M,SCN09 SHIFTED M
20554: IFF CH$$N,SCN09 SHIFTED N
20555: IFF CH$$O,SCN09 SHIFTED O
20556: IFF CH$$P,SCN09 SHIFTED P
20557: IFF CH$$Q,SCN09 SHIFTED Q
20558: IFF CH$$R,SCN09 SHIFTED R
20559: IFF CH$$S,SCN21 SHIFTED S
20560: IFF CH$$T,SCN09 SHIFTED T
20561: IFF CH$$U,SCN09 SHIFTED U
20562: IFF CH$$V,SCN09 SHIFTED V
20563: IFF CH$$W,SCN09 SHIFTED W
20564: IFF CH$$X,SCN09 SHIFTED X
20565: IFF CH$$Y,SCN09 SHIFTED Y
20566: IFF CH$$$,SCN09 SHIFTED Z
20567: EJC
20568: *
20569: * SCANE (CONTINUED)
20570: *
20571: IFF CH$SQ,SCN16 SINGLE QUOTE
20572: IFF CH$DQ,SCN17 DOUBLE QUOTE
20573: IFF CH$LF,SCN20 LETTER F
20574: IFF CH$LS,SCN21 LETTER S
20575: IFF CH$UN,SCN24 UNDERLINE
20576: IFF CH$PP,SCN25 LEFT PAREN
20577: IFF CH$RP,SCN26 RIGHT PAREN
20578: IFF CH$RB,SCN27 RIGHT BRACKET
20579: IFF CH$BB,SCN28 LEFT BRACKET
20580: IFF CH$CB,SCN27 RIGHT BRACKET
20581: IFF CH$OB,SCN28 LEFT BRACKET
20582: IFF CH$CL,SCN29 COLON
20583: IFF CH$SM,SCN30 SEMI-COLON
20584: IFF CH$CM,SCN31 COMMA
20585: IFF CH$DT,SCN32 DOT
20586: IFF CH$PL,SCN33 PLUS
20587: IFF CH$MN,SCN34 MINUS
20588: IFF CH$NT,SCN35 NOT
20589: IFF CH$DL,SCN36 DOLLAR
20590: IFF CH$EX,SCN37 EXCLAMATION MARK
20591: IFF CH$PC,SCN38 PERCENT
20592: IFF CH$SL,SCN40 SLASH
20593: IFF CH$NM,SCN41 NUMBER SIGN
20594: IFF CH$AT,SCN42 AT
20595: IFF CH$BR,SCN43 VERTICAL BAR
20596: IFF CH$AM,SCN44 AMPERSAND
20597: IFF CH$QU,SCN45 QUESTION MARK
20598: IFF CH$EQ,SCN46 EQUAL
20599: IFF CH$AS,SCN49 ASTERISK
20600: ESW END SWITCH ON CHARACTER
20601: *
20602: * HERE FOR ILLEGAL CHARACTER (UNDERLINE MERGES)
20603: *
20604: SCN07 BZE WB,SCN10 JUMP IF SCANNING NAME OR CONSTANT
20605: ERB 230,SYNTAX ERROR. ILLEGAL CHARACTER
20606: EJC
20607: *
20608: * SCANE (CONTINUED)
20609: *
20610: * HERE FOR DIGITS 0-9
20611: *
20612: SCN08 BZE WB,SCN09 KEEP SCANNING IF NAME/CONSTANT
20613: ZER WC ELSE SET FLAG FOR SCANNING CONSTANT
20614: *
20615: * HERE FOR LETTER. LOOP HERE WHEN SCANNING NAME/CONSTANT
20616: *
20617: SCN09 BEQ WA,SCNIL,SCN11 JUMP IF END OF IMAGE
20618: ZER WB SET FLAG FOR SCANNING NAME/CONST
20619: BRN SCN06 MERGE BACK TO CONTINUE SCAN
20620: *
20621: * COME HERE FOR DELIMITER ENDING NAME OR CONSTANT
20622: *
20623: SCN10 DCV WA RESET OFFSET TO POINT TO DELIMITER
20624: *
20625: * COME HERE AFTER FINISHING SCAN OF NAME OR CONSTANT
20626: *
20627: SCN11 MOV WA,SCNPT STORE UPDATED SCAN OFFSET
20628: MOV SCNSE,WB POINT TO START OF ELEMENT
20629: SUB WB,WA GET NUMBER OF CHARACTERS
20630: MOV R$CIM,XL POINT TO LINE IMAGE
20631: BNZ WC,SCN15 JUMP IF NAME
20632: *
20633: * HERE AFTER SCANNING OUT NUMERIC CONSTANT
20634: *
20635: JSR SBSTR GET STRING FOR CONSTANT
20636: MOV XR,DNAMP DELETE FROM STORAGE (NOT NEEDED)
20637: JSR GTNUM CONVERT TO NUMERIC
20638: PPM SCN14 JUMP IF CONVERSION FAILURE
20639: *
20640: * MERGE HERE TO EXIT WITH CONSTANT
20641: *
20642: SCN12 MOV =T$CON,XL SET RESULT TYPE OF CONSTANT
20643: EJC
20644: *
20645: * SCANE (CONTINUED)
20646: *
20647: * COMMON EXIT POINT (XR,XL) SET
20648: *
20649: SCN13 MOV SCNSA,WA RESTORE WA
20650: MOV SCNSB,WB RESTORE WB
20651: MOV SCNSC,WC RESTORE WC
20652: MOV XR,R$SCP SAVE XR IN CASE RESCAN
20653: MOV XL,SCNTP SAVE XL IN CASE RESCAN
20654: ZER SCNGO RESET POSSIBLE GOTO FLAG
20655: EXI RETURN TO SCANE CALLER
20656: *
20657: * HERE IF CONVERSION ERROR ON NUMERIC ITEM
20658: *
20659: SCN14 ERB 231,SYNTAX ERROR. INVALID NUMERIC ITEM
20660: *
20661: * HERE AFTER SCANNING OUT VARIABLE NAME
20662: *
20663: SCN15 JSR SBSTR BUILD STRING NAME OF VARIABLE
20664: BNZ SCNCC,SCN13 RETURN IF CNCRD CALL
20665: JSR GTNVR LOCATE/BUILD VRBLK
20666: PPM DUMMY (UNUSED) ERROR RETURN
20667: MOV =T$VAR,XL SET TYPE AS VARIABLE
20668: BRN SCN13 BACK TO EXIT
20669: *
20670: * HERE FOR SINGLE QUOTE (START OF STRING CONSTANT)
20671: *
20672: SCN16 BZE WB,SCN10 TERMINATOR IF SCANNING NAME OR CNST
20673: MOV =CH$SQ,WB SET TERMINATOR AS SINGLE QUOTE
20674: BRN SCN18 MERGE
20675: *
20676: * HERE FOR DOUBLE QUOTE (START OF STRING CONSTANT)
20677: *
20678: SCN17 BZE WB,SCN10 TERMINATOR IF SCANNING NAME OR CNST
20679: MOV =CH$DQ,WB SET DOUBLE QUOTE TERMINATOR, MERGE
20680: *
20681: * LOOP TO SCAN OUT STRING CONSTANT
20682: *
20683: SCN18 BEQ WA,SCNIL,SCN19 ERROR IF END OF IMAGE
20684: LCH WC,(XL)+ ELSE LOAD NEXT CHARACTER
20685: ICV WA BUMP OFFSET
20686: BNE WC,WB,SCN18 LOOP BACK IF NOT TERMINATOR
20687: EJC
20688: *
20689: * SCANE (CONTINUED)
20690: *
20691: * HERE AFTER SCANNING OUT STRING CONSTANT
20692: *
20693: MOV SCNPT,WB POINT TO FIRST CHARACTER
20694: MOV WA,SCNPT SAVE OFFSET PAST FINAL QUOTE
20695: DCV WA POINT BACK PAST LAST CHARACTER
20696: SUB WB,WA GET NUMBER OF CHARACTERS
20697: MOV R$CIM,XL POINT TO INPUT IMAGE
20698: JSR SBSTR BUILD SUBSTRING VALUE
20699: BRN SCN12 BACK TO EXIT WITH CONSTANT RESULT
20700: *
20701: * HERE IF NO MATCHING QUOTE FOUND
20702: *
20703: SCN19 MOV WA,SCNPT SET UPDATED SCAN POINTER
20704: ERB 232,SYNTAX ERROR. UNMATCHED STRING QUOTE
20705: *
20706: * HERE FOR F (POSSIBLE FAILURE GOTO)
20707: *
20708: SCN20 MOV =T$FGO,XR SET RETURN CODE FOR FAIL GOTO
20709: BRN SCN22 JUMP TO MERGE
20710: *
20711: * HERE FOR S (POSSIBLE SUCCESS GOTO)
20712: *
20713: SCN21 MOV =T$SGO,XR SET SUCCESS GOTO AS RETURN CODE
20714: *
20715: * SPECIAL GOTO CASES MERGE HERE
20716: *
20717: SCN22 BZE SCNGO,SCN09 TREAT AS NORMAL LETTER IF NOT GOTO
20718: *
20719: * MERGE HERE FOR SPECIAL CHARACTER EXIT
20720: *
20721: SCN23 BZE WB,SCN10 JUMP IF END OF NAME/CONSTANT
20722: MOV XR,XL ELSE COPY CODE
20723: BRN SCN13 AND JUMP TO EXIT
20724: *
20725: * HERE FOR UNDERLINE
20726: *
20727: SCN24 BZE WB,SCN09 PART OF NAME IF SCANNING NAME
20728: BRN SCN07 ELSE ILLEGAL
20729: EJC
20730: *
20731: * SCANE (CONTINUED)
20732: *
20733: * HERE FOR LEFT PAREN
20734: *
20735: SCN25 MOV =T$LPR,XR SET LEFT PAREN RETURN CODE
20736: BNZ WB,SCN23 RETURN LEFT PAREN UNLESS NAME
20737: BZE WC,SCN10 DELIMITER IF SCANNING CONSTANT
20738: *
20739: * HERE FOR LEFT PAREN AFTER NAME (FUNCTION CALL)
20740: *
20741: MOV SCNSE,WB POINT TO START OF NAME
20742: MOV WA,SCNPT SET POINTER PAST LEFT PAREN
20743: DCV WA POINT BACK PAST LAST CHAR OF NAME
20744: SUB WB,WA GET NAME LENGTH
20745: MOV R$CIM,XL POINT TO INPUT IMAGE
20746: JSR SBSTR GET STRING NAME FOR FUNCTION
20747: JSR GTNVR LOCATE/BUILD VRBLK
20748: PPM DUMMY (UNUSED) ERROR RETURN
20749: MOV =T$FNC,XL SET CODE FOR FUNCTION CALL
20750: BRN SCN13 BACK TO EXIT
20751: *
20752: * PROCESSING FOR SPECIAL CHARACTERS
20753: *
20754: SCN26 MOV =T$RPR,XR RIGHT PAREN, SET CODE
20755: BRN SCN23 TAKE SPECIAL CHARACTER EXIT
20756: *
20757: SCN27 MOV =T$RBR,XR RIGHT BRACKET, SET CODE
20758: BRN SCN23 TAKE SPECIAL CHARACTER EXIT
20759: *
20760: SCN28 MOV =T$LBR,XR LEFT BRACKET, SET CODE
20761: BRN SCN23 TAKE SPECIAL CHARACTER EXIT
20762: *
20763: SCN29 MOV =T$COL,XR COLON, SET CODE
20764: BRN SCN23 TAKE SPECIAL CHARACTER EXIT
20765: *
20766: SCN30 MOV =T$SMC,XR SEMI-COLON, SET CODE
20767: BRN SCN23 TAKE SPECIAL CHARACTER EXIT
20768: *
20769: SCN31 MOV =T$CMA,XR COMMA, SET CODE
20770: BRN SCN23 TAKE SPECIAL CHARACTER EXIT
20771: EJC
20772: *
20773: * SCANE (CONTINUED)
20774: *
20775: * HERE FOR OPERATORS. ON ENTRY, WC POINTS TO THE TABLE OF
20776: * OPERATOR DOPE VECTORS AND WB IS THE INCREMENT TO STEP
20777: * TO THE NEXT PAIR (BINARY/UNARY) OF DOPE VECTORS IN THE
20778: * LIST. ON REACHING SCN46, THE POINTER HAS BEEN ADJUSTED TO
20779: * POINT TO THE APPROPRIATE PAIR OF DOPE VECTORS.
20780: * THE FIRST THREE ENTRIES ARE SPECIAL SINCE THEY CAN OCCUR
20781: * AS PART OF A VARIABLE NAME (.) OR CONSTANT (.+-).
20782: *
20783: SCN32 BZE WB,SCN09 DOT CAN BE PART OF NAME OR CONSTANT
20784: ADD WB,WC ELSE BUMP POINTER
20785: *
20786: SCN33 BZE WC,SCN09 PLUS CAN BE PART OF CONSTANT
20787: BZE WB,SCN48 PLUS CANNOT BE PART OF NAME
20788: ADD WB,WC ELSE BUMP POINTER
20789: *
20790: SCN34 BZE WC,SCN09 MINUS CAN BE PART OF CONSTANT
20791: BZE WB,SCN48 MINUS CANNOT BE PART OF NAME
20792: ADD WB,WC ELSE BUMP POINTER
20793: *
20794: SCN35 ADD WB,WC NOT
20795: SCN36 ADD WB,WC DOLLAR
20796: SCN37 ADD WB,WC EXCLAMATION
20797: SCN38 ADD WB,WC PERCENT
20798: SCN39 ADD WB,WC ASTERISK
20799: SCN40 ADD WB,WC SLASH
20800: SCN41 ADD WB,WC NUMBER SIGN
20801: SCN42 ADD WB,WC AT SIGN
20802: SCN43 ADD WB,WC VERTICAL BAR
20803: SCN44 ADD WB,WC AMPERSAND
20804: SCN45 ADD WB,WC QUESTION MARK
20805: *
20806: * ALL OPERATORS COME HERE (EQUAL MERGES DIRECTLY)
20807: * (WC) POINTS TO THE BINARY/UNARY PAIR OF OPERATOR DVBLKS.
20808: *
20809: SCN46 BZE WB,SCN10 OPERATOR TERMINATES NAME/CONSTANT
20810: MOV WC,XR ELSE COPY DV POINTER
20811: LCH WC,(XL) LOAD NEXT CHARACTER
20812: MOV =T$BOP,XL SET BINARY OP IN CASE
20813: BEQ WA,SCNIL,SCN47 SHOULD BE BINARY IF IMAGE END
20814: BEQ WC,=CH$BL,SCN47 SHOULD BE BINARY IF FOLLOWED BY BLK
20815: BEQ WC,=CH$HT,SCN47 JUMP IF HORIZONTAL TAB
20816: BEQ WC,=CH$SM,SCN47 SEMICOLON CAN IMMEDIATELY FOLLOW =
20817: *
20818: * HERE FOR UNARY OPERATOR
20819: *
20820: ADD *DVBS$,XR POINT TO DV FOR UNARY OP
20821: MOV =T$UOP,XL SET TYPE FOR UNARY OPERATOR
20822: BLE SCNTP,=T$UOK,SCN13 OK UNARY IF OK PRECEDING ELEMENT
20823: EJC
20824: *
20825: * SCANE (CONTINUED)
20826: *
20827: * MERGE HERE TO REQUIRE PRECEDING BLANKS
20828: *
20829: SCN47 BNZ SCNBL,SCN13 ALL OK IF PRECEDING BLANKS, EXIT
20830: *
20831: * FAIL OPERATOR IN THIS POSITION
20832: *
20833: SCN48 ERB 233,SYNTAX ERROR. INVALID USE OF OPERATOR
20834: *
20835: * HERE FOR ASTERISK, COULD BE ** SUBSTITUTE FOR EXCLAMATION
20836: *
20837: SCN49 BZE WB,SCN10 END OF NAME IF SCANNING NAME
20838: BEQ WA,SCNIL,SCN39 NOT ** IF * AT IMAGE END
20839: MOV WA,XR ELSE SAVE OFFSET PAST FIRST *
20840: MOV WA,SCNOF SAVE ANOTHER COPY
20841: LCH WA,(XL)+ LOAD NEXT CHARACTER
20842: BNE WA,=CH$AS,SCN50 NOT ** IF NEXT CHAR NOT *
20843: ICV XR ELSE STEP OFFSET PAST SECOND *
20844: BEQ XR,SCNIL,SCN51 OK EXCLAM IF END OF IMAGE
20845: LCH WA,(XL) ELSE LOAD NEXT CHARACTER
20846: BEQ WA,=CH$BL,SCN51 EXCLAMATION IF BLANK
20847: BEQ WA,=CH$HT,SCN51 EXCLAMATION IF HORIZONTAL TAB
20848: *
20849: * UNARY *
20850: *
20851: SCN50 MOV SCNOF,WA RECOVER STORED OFFSET
20852: MOV R$CIM,XL POINT TO LINE AGAIN
20853: PLC XL,WA POINT TO CURRENT CHAR
20854: BRN SCN39 MERGE WITH UNARY *
20855: *
20856: * HERE FOR ** AS SUBSTITUTE FOR EXCLAMATION
20857: *
20858: SCN51 MOV XR,SCNPT SAVE SCAN POINTER PAST 2ND *
20859: MOV XR,WA COPY SCAN POINTER
20860: BRN SCN37 MERGE WITH EXCLAMATION
20861: ENP END PROCEDURE SCANE
20862: EJC
20863: *
20864: * SCNGF -- SCAN GOTO FIELD
20865: *
20866: * SCNGF IS CALLED FROM CMPIL TO SCAN AND ANALYZE A GOTO
20867: * FIELD INCLUDING THE SURROUNDING BRACKETS OR PARENTHESES.
20868: * FOR A NORMAL GOTO, THE RESULT RETURNED IS EITHER A VRBLK
20869: * POINTER FOR A SIMPLE LABEL OPERAND, OR A POINTER TO AN
20870: * EXPRESSION TREE WITH A SPECIAL OUTER UNARY OPERATOR
20871: * (O$GOC). FOR A DIRECT GOTO, THE RESULT RETURNED IS A
20872: * POINTER TO AN EXPRESSION TREE WITH THE SPECIAL OUTER
20873: * UNARY OPERATOR O$GOD.
20874: *
20875: * JSR SCNGF CALL TO SCAN GOTO FIELD
20876: * (XR) RESULT (SEE ABOVE)
20877: * (XL,WA,WB,WC) DESTROYED
20878: *
20879: SCNGF PRC E,0 ENTRY POINT
20880: JSR SCANE SCAN INITIAL ELEMENT
20881: BEQ XL,=T$LPR,SCNG1 SKIP IF LEFT PAREN (NORMAL GOTO)
20882: BEQ XL,=T$LBR,SCNG2 SKIP IF LEFT BRACKET (DIRECT GOTO)
20883: ERB 234,SYNTAX ERROR. GOTO FIELD INCORRECT
20884: *
20885: * HERE FOR LEFT PAREN (NORMAL GOTO)
20886: *
20887: SCNG1 MOV =NUM01,WB SET EXPAN FLAG FOR NORMAL GOTO
20888: JSR EXPAN ANALYZE GOTO FIELD
20889: MOV =OPDVN,WA POINT TO OPDV FOR COMPLEX GOTO
20890: BLE XR,STATB,SCNG3 JUMP IF NOT IN STATIC (SGD15)
20891: BLO XR,STATE,SCNG4 JUMP TO EXIT IF SIMPLE LABEL NAME
20892: BRN SCNG3 COMPLEX GOTO - MERGE
20893: *
20894: * HERE FOR LEFT BRACKET (DIRECT GOTO)
20895: *
20896: SCNG2 MOV =NUM02,WB SET EXPAN FLAG FOR DIRECT GOTO
20897: JSR EXPAN SCAN GOTO FIELD
20898: MOV =OPDVD,WA SET OPDV POINTER FOR DIRECT GOTO
20899: EJC
20900: *
20901: * SCNGF (CONTINUED)
20902: *
20903: * MERGE HERE TO BUILD OUTER UNARY OPERATOR BLOCK
20904: *
20905: SCNG3 MOV WA,-(XS) STACK OPERATOR DV POINTER
20906: MOV XR,-(XS) STACK POINTER TO EXPRESSION TREE
20907: JSR EXPOP POP OPERATOR OFF
20908: MOV (XS)+,XR RELOAD NEW EXPRESSION TREE POINTER
20909: *
20910: * COMMON EXIT POINT
20911: *
20912: SCNG4 EXI RETURN TO CALLER
20913: ENP END PROCEDURE SCNGF
20914: EJC
20915: *
20916: * SETVR -- SET VRGET,VRSTO FIELDS OF VRBLK
20917: *
20918: * SETVR SETS THE PROPER VALUES IN THE VRGET AND VRSTO
20919: * FIELDS OF A VRBLK. IT IS CALLED WHENEVER TRBLKS ARE
20920: * ADDED OR SUBTRACTED (TRACE,STOPTR,INPUT,OUTPUT,DETACH)
20921: *
20922: * (XR) POINTER TO VRBLK
20923: * JSR SETVR CALL TO SET FIELDS
20924: * (XL,WA) DESTROYED
20925: *
20926: * NOTE THAT SETVR IGNORES THE CALL IF XR DOES NOT POINT
20927: * INTO THE STATIC REGION (I.E. IS SOME OTHER NAME BASE)
20928: *
20929: SETVR PRC E,0 ENTRY POINT
20930: BHI XR,STATE,SETV1 EXIT IF NOT NATURAL VARIABLE
20931: *
20932: * HERE IF WE HAVE A VRBLK
20933: *
20934: MOV XR,XL COPY VRBLK POINTER
20935: MOV =B$VRL,VRGET(XR) STORE NORMAL GET VALUE
20936: BEQ VRSTO(XR),=B$VRE,SETV1 SKIP IF PROTECTED VARIABLE
20937: MOV =B$VRS,VRSTO(XR) STORE NORMAL STORE VALUE
20938: MOV VRVAL(XL),XL POINT TO NEXT ENTRY ON CHAIN
20939: BNE (XL),=B$TRT,SETV1 JUMP IF END OF TRBLK CHAIN
20940: MOV =B$VRA,VRGET(XR) STORE TRAPPED ROUTINE ADDRESS
20941: MOV =B$VRV,VRSTO(XR) SET TRAPPED ROUTINE ADDRESS
20942: *
20943: * MERGE HERE TO EXIT TO CALLER
20944: *
20945: SETV1 EXI RETURN TO SETVR CALLER
20946: ENP END PROCEDURE SETVR
20947: EJC
20948: *
20949: * SORTA -- SORT ARRAY
20950: *
20951: * ROUTINE TO SORT AN ARRAY OR TABLE ON SAME BASIS AS IN
20952: * SITBOL. A TABLE IS CONVERTED TO AN ARRAY, LEAVING TWO
20953: * DIMENSIONAL ARRAYS AND VECTORS AS CASES TO BE CONSIDERED.
20954: * WHOLE ROWS OF ARRAYS ARE PERMUTED ACCORDING TO THE
20955: * ORDERING OF THE KEYS THEY CONTAIN, AND THE STRIDE
20956: * REFERRED TO, IS THE THE LENGTH OF A ROW. IT IS ONE
20957: * FOR A VECTOR.
20958: * THE SORT USED IS HEAPSORT, FUNDAMENTALS OF DATA STRUCTURE
20959: * HOROWITZ AND SAHNI, PITMAN 1977, PAGE 347.
20960: * IT IS AN ORDER N*LOG(N) ALGORITHM. IN ORDER
20961: * TO MAKE IT STABLE, COMPARANDS MAY NOT COMPARE EQUAL. THIS
20962: * IS ACHIEVED BY SORTING A COPY ARRAY (REFERRED TO AS THE
20963: * SORT ARRAY) CONTAINING AT ITS HIGH ADDRESS END, BYTE
20964: * OFFSETS TO THE ROWS TO BE SORTED HELD IN THE ORIGINAL
20965: * ARRAY (REFERRED TO AS THE KEY ARRAY). SORTC, THE
20966: * COMPARISON ROUTINE, ACCESSES THE KEYS THROUGH THESE
20967: * OFFSETS AND IN THE CASE OF EQUALITY, RESOLVES IT BY
20968: * COMPARING THE OFFSETS THEMSELVES. THE SORT PERMUTES THE
20969: * OFFSETS WHICH ARE THEN USED IN A FINAL OPERATION TO COPY
20970: * THE ACTUAL ITEMS INTO THE NEW ARRAY IN SORTED ORDER.
20971: * REFERENCES TO ZEROTH ITEM ARE TO NOTIONAL ITEM
20972: * PRECEDING FIRST ACTUAL ITEM.
20973: * REVERSE SORTING FOR RSORT IS DONE BY HAVING THE LESS THAN
20974: * TEST FOR KEYS EFFECTIVELY BE REPLACED BY A
20975: * GREATER THAN TEST.
20976: *
20977: * 1(XS) FIRST ARG - ARRAY OR TABLE
20978: * 0(XS) 2ND ARG - INDEX OR PDTYPE NAME
20979: * (WA) 0 , NON-ZERO FOR SORT , RSORT
20980: * JSR SORTA CALL TO SORT ARRAY
20981: * (XR) SORTED ARRAY
20982: * (XL,WA,WB,WC) DESTROYED
20983: EJC
20984: *
20985: * SORTA (CONTINUED)
20986: *
20987: SORTA PRC N,0 ENTRY POINT
20988: MOV WA,SRTSR SORT/RSORT INDICATOR
20989: MOV *NUM01,SRTST DEFAULT STRIDE OF 1
20990: ZER SRTOF DEFAULT ZERO OFFSET TO SORT KEY
20991: MOV =NULLS,SRTDF CLEAR DATATYPE FIELD NAME
20992: MOV (XS)+,R$SXR UNSTACK ARGUMENT 2
20993: MOV (XS)+,XR GET FIRST ARGUMENT
20994: JSR GTARR CONVERT TO ARRAY
20995: PPM SRT16 FAIL
20996: MOV XR,-(XS) STACK PTR TO RESULTING KEY ARRAY
20997: MOV XR,-(XS) ANOTHER COPY FOR COPYB
20998: JSR COPYB GET COPY ARRAY FOR SORTING INTO
20999: PPM CANT FAIL
21000: MOV XR,-(XS) STACK POINTER TO SORT ARRAY
21001: MOV R$SXR,XR GET SECOND ARG
21002: MOV 1(XS),XL GET PTR TO KEY ARRAY
21003: BNE (XL),=B$VCT,SRT02 JUMP IF ARBLK
21004: BEQ XR,=NULLS,SRT01 JUMP IF NULL SECOND ARG
21005: JSR GTNVR GET VRBLK PTR FOR IT
21006: ERR 257,ERRONEOUS 2ND ARG IN SORT/RSORT OF VECTOR
21007: MOV XR,SRTDF STORE DATATYPE FIELD NAME VRBLK
21008: *
21009: * COMPUTE N AND OFFSET TO ITEM A(0) IN VECTOR CASE
21010: *
21011: SRT01 MOV *VCLEN,WC OFFSET TO A(0)
21012: MOV *VCVLS,WB OFFSET TO FIRST ITEM
21013: MOV VCLEN(XL),WA GET BLOCK LENGTH
21014: SUB *VCSI$,WA GET NO. OF ENTRIES, N (IN BYTES)
21015: BRN SRT04 MERGE
21016: *
21017: * HERE FOR ARRAY
21018: *
21019: SRT02 LDI ARDIM(XL) GET POSSIBLE DIMENSION
21020: MFI WA CONVERT TO SHORT INTEGER
21021: WTB WA FURTHER CONVERT TO BAUS
21022: MOV *ARVLS,WB OFFSET TO FIRST VALUE IF ONE
21023: MOV *ARPRO,WC OFFSET BEFORE VALUES IF ONE DIM.
21024: BEQ ARNDM(XL),=NUM01,SRT04 JUMP IN FACT IF ONE DIM.
21025: BNE ARNDM(XL),=NUM02,SRT16 FAIL UNLESS TWO DIMENS
21026: LDI ARLB2(XL) GET LOWER BOUND 2 AS DEFAULT
21027: BEQ XR,=NULLS,SRT03 JUMP IF DEFAULT SECOND ARG
21028: JSR GTINT CONVERT TO INTEGER
21029: PPM SRT17 FAIL
21030: LDI ICVAL(XR) GET ACTUAL INTEGER VALUE
21031: EJC
21032: *
21033: * SORTA (CONTINUED)
21034: *
21035: * HERE WITH SORT COLUMN INDEX IN IA IN ARRAY CASE
21036: *
21037: SRT03 SBI ARLB2(XL) SUBTRACT LOW BOUND
21038: IOV SRT17 FAIL IF OVERFLOW
21039: ILT SRT17 FAIL IF BELOW LOW BOUND
21040: SBI ARDM2(XL) CHECK AGAINST DIMENSION
21041: IGE SRT17 FAIL IF TOO LARGE
21042: ADI ARDM2(XL) RESTORE VALUE
21043: MFI WA GET AS SMALL INTEGER
21044: WTB WA OFFSET WITHIN ROW TO KEY
21045: MOV WA,SRTOF KEEP OFFSET
21046: LDI ARDM2(XL) SECOND DIMENSION IS ROW LENGTH
21047: MFI WA CONVERT TO SHORT INTEGER
21048: MOV WA,XR COPY ROW LENGTH
21049: WTB WA CONVERT TO BYTES
21050: MOV WA,SRTST STORE AS STRIDE
21051: LDI ARDIM(XL) GET NUMBER OF ROWS
21052: MFI WA AS A SHORT INTEGER
21053: WTB WA CONVERT N TO BAUS
21054: MOV ARLEN(XL),WC OFFSET PAST ARRAY END
21055: SUB WA,WC ADJUST, GIVING SPACE FOR N OFFSETS
21056: DCA WC POINT TO A(0)
21057: MOV AROFS(XL),WB OFFSET TO WORD BEFORE FIRST ITEM
21058: ICA WB OFFSET TO FIRST ITEM
21059: *
21060: * SEPARATE PRE-PROCESSING FOR ARRAYS AND VECTORS DONE.
21061: * TO SIMPLIFY LATER KEY COMPARISONS, REMOVAL OF ANY TRBLK
21062: * TRAP BLOCKS FROM ENTRIES IN KEY ARRAY IS EFFECTED.
21063: *
21064: * (XL) = 1(XS) = POINTER TO KEY ARRAY
21065: * (XS) = POINTER TO SORT ARRAY
21066: * WA = NUMBER OF ITEMS, N (CONVERTED TO BYTES).
21067: * WB = OFFSET TO FIRST ITEM OF ARRAYS.
21068: * WC = OFFSET TO A(0)
21069: *
21070: SRT04 BLE WA,*NUM01,SRT15 RETURN IF ONLY A SINGLE ITEM
21071: MOV WA,SRTSN STORE NUMBER OF ITEMS (IN BAUS)
21072: MOV WC,SRTSO STORE OFFSET TO A(0)
21073: MOV ARLEN(XL),WC LENGTH OF ARRAY OR VEC (=VCLEN)
21074: ADD XL,WC POINT PAST END OF ARRAY OR VECTOR
21075: MOV WB,SRTSF STORE OFFSET TO FIRST ROW
21076: ADD WB,XL POINT TO FIRST ITEM IN KEY ARRAY
21077: *
21078: * LOOP THROUGH ARRAY
21079: *
21080: SRT05 MOV (XL),XR GET AN ENTRY
21081: *
21082: * HUNT ALONG TRBLK CHAIN
21083: *
21084: SRT06 BNE (XR),=B$TRT,SRT07 JUMP OUT IF NOT TRBLK
21085: MOV TRVAL(XR),XR GET VALUE FIELD
21086: BRN SRT06 LOOP
21087: EJC
21088: *
21089: * SORTA (CONTINUED)
21090: *
21091: * XR IS VALUE FROM END OF CHAIN
21092: *
21093: SRT07 MOV XR,(XL)+ STORE AS ARRAY ENTRY
21094: BLT XL,WC,SRT05 LOOP IF NOT DONE
21095: MOV (XS),XL GET ADRS OF SORT ARRAY
21096: MOV SRTSF,XR INITIAL OFFSET TO FIRST KEY
21097: MOV SRTST,WB GET STRIDE
21098: ADD SRTSO,XL OFFSET TO A(0)
21099: ICA XL POINT TO A(1)
21100: MOV SRTSN,WC GET N
21101: BTW WC CONVERT FROM BYTES
21102: MOV WC,SRTNR STORE AS ROW COUNT
21103: LCT WC,WC LOOP COUNTER
21104: *
21105: * STORE KEY OFFSETS AT TOP OF SORT ARRAY
21106: *
21107: SRT08 MOV XR,(XL)+ STORE AN OFFSET
21108: ADD WB,XR BUMP OFFSET BY STRIDE
21109: BCT WC,SRT08 LOOP THROUGH ROWS
21110: *
21111: * PERFORM THE SORT ON OFFSETS IN SORT ARRAY.
21112: *
21113: * (SRTSN) NUMBER OF ITEMS TO SORT, N (BYTES)
21114: * (SRTSO) OFFSET TO A(0)
21115: *
21116: SRT09 MOV SRTSN,WA GET N
21117: MOV SRTNR,WC GET NUMBER OF ROWS
21118: RSH WC,1 I = N / 2 (WC=I, INDEX INTO ARRAY)
21119: WTB WC CONVERT BACK TO BYTES
21120: *
21121: * LOOP TO FORM INITIAL HEAP
21122: *
21123: SRT10 JSR SORTH SORTH(I,N)
21124: DCA WC I = I - 1
21125: BNZ WC,SRT10 LOOP IF I GT 0
21126: MOV WA,WC I = N
21127: *
21128: * SORTING LOOP. AT THIS POINT, A(1) IS THE LARGEST
21129: * ITEM, SINCE ALGORITHM INITIALISES IT AS, AND THEN MAINTAI
21130: * IT AS, ROOT OF TREE.
21131: *
21132: SRT11 DCA WC I = I - 1 (N - 1 INITIALLY)
21133: BZE WC,SRT12 JUMP IF DONE
21134: MOV (XS),XR GET SORT ARRAY ADDRESS
21135: ADD SRTSO,XR POINT TO A(0)
21136: MOV XR,XL A(0) ADDRESS
21137: ADD WC,XL A(I) ADDRESS
21138: MOV 1(XL),WB COPY A(I+1)
21139: MOV 1(XR),1(XL) MOVE A(1) TO A(I+1)
21140: MOV WB,1(XR) COMPLETE EXCHANGE OF A(1), A(I+1)
21141: MOV WC,WA N = I FOR SORTH
21142: MOV *NUM01,WC I = 1 FOR SORTH
21143: JSR SORTH SORTH(1,N)
21144: MOV WA,WC RESTORE WC
21145: BRN SRT11 LOOP
21146: EJC
21147: *
21148: * SORTA (CONTINUED)
21149: *
21150: * OFFSETS HAVE BEEN PERMUTED INTO REQUIRED ORDER BY SORT.
21151: * COPY ARRAY ELEMENTS OVER THEM.
21152: *
21153: SRT12 MOV (XS),XL BASE ADRS OF KEY ARRAY
21154: MOV XL,WC COPY IT
21155: ADD SRTSO,WC OFFSET OF A(0)
21156: ADD SRTSF,XL ADRS OF FIRST ROW OF SORT ARRAY
21157: MOV SRTST,WB GET STRIDE
21158: BTW WB CONVERT TO WORDS
21159: *
21160: * COPYING LOOP FOR SUCCESSIVE ITEMS. SORTED OFFSETS ARE
21161: * HELD AT END OF SORT ARRAY.
21162: *
21163: SRT13 ICA WC ADRS OF NEXT OF SORTED OFFSETS
21164: MOV WC,XR COPY IT FOR ACCESS
21165: MOV (XR),XR GET OFFSET
21166: ADD 1(XS),XR ADD KEY ARRAY BASE ADRS
21167: LCT WA,WB GET COUNT OF WORDS IN ROW
21168: *
21169: * COPY A COMPLETE ROW
21170: *
21171: SRT14 MOV (XR)+,(XL)+ MOVE A WORD
21172: BCT WA,SRT14 LOOP
21173: DCV SRTNR DECREMENT ROW COUNT
21174: BNZ SRTNR,SRT13 REPEAT TILL ALL ROWS DONE
21175: *
21176: * RETURN POINT
21177: *
21178: SRT15 MOV (XS)+,XR POP RESULT ARRAY PTR
21179: ICA XS POP KEY ARRAY PTR
21180: ZER R$SXL CLEAR JUNK
21181: ZER R$SXR CLEAR JUNK
21182: EXI RETURN
21183: *
21184: * ERROR POINT
21185: *
21186: SRT16 ERB 256,SORT/RSORT 1ST ARG NOT SUITABLE ARRAY OR TABLE
21187: SRT17 ERB 258,SORT/RSORT 2ND ARG OUT OF RANGE OR NON-INTEGER
21188: ENP END PROCUDURE SORTA
21189: EJC
21190: *
21191: * SORTC -- COMPARE SORT KEYS
21192: *
21193: * COMPARE TWO SORT KEYS GIVEN THEIR OFFSETS. IF
21194: * EQUAL, COMPARE KEY OFFSETS TO GIVE STABLE SORT.
21195: * NOTE THAT IF SRTSR IS NON-ZERO (REQUEST FOR REVERSE
21196: * SORT), THE QUOTED RETURNS ARE INVERTED.
21197: * FOR OBJECTS OF DIFFERING DATATYPES, THE ENTRY POINT
21198: * IDENTIFICATIONS ARE COMPARED.
21199: *
21200: * (XL) BASE ADRS FOR KEYS
21201: * (WA) OFFSET TO KEY 1 ITEM
21202: * (WB) OFFSET TO KEY 2 ITEM
21203: * (SRTSR) ZERO/NON-ZERO FOR SORT/RSORT
21204: * (SRTOF) OFFSET WITHIN ROW TO COMPARANDS
21205: * JSR SORTC CALL TO COMPARE KEYS
21206: * PPM LOC KEY1 LESS THAN KEY2
21207: * NORMAL RETURN, KEY1 GT THAN KEY2
21208: * (XL,XR,WA,WB) DESTROYED
21209: *
21210: SORTC PRC E,1 ENTRY POINT
21211: MOV WA,SRTS1 SAVE OFFSET 1
21212: MOV WB,SRTS2 SAVE OFFSET 2
21213: MOV WC,SRTSC SAVE WC
21214: ADD SRTOF,XL ADD OFFSET TO COMPARAND FIELD
21215: MOV XL,XR COPY BASE + OFFSET
21216: ADD WA,XL ADD KEY1 OFFSET
21217: ADD WB,XR ADD KEY2 OFFSET
21218: MOV (XL),XL GET KEY1
21219: MOV (XR),XR GET KEY2
21220: BNE SRTDF,=NULLS,SRC11 JUMP IF DATATYPE FIELD NAME USED
21221: EJC
21222: *
21223: * SORTC (CONTINUED)
21224: *
21225: * MERGE AFTER DEALING WITH FIELD NAME. TRY FOR STRINGS.
21226: *
21227: SRC01 MOV (XL),WC GET TYPE CODE
21228: BNE WC,(XR),SRC02 SKIP IF NOT SAME DATATYPE
21229: BEQ WC,=B$SCL,SRC09 JUMP IF BOTH STRINGS
21230: *
21231: * NOW TRY FOR NUMERIC
21232: *
21233: SRC02 MOV XL,R$SXL KEEP ARG1
21234: MOV XR,R$SXR KEEP ARG2
21235: MOV XL,-(XS) STACK
21236: MOV XR,-(XS) ARGS
21237: JSR ACOMP COMPARE OBJECTS
21238: PPM SRC10 NOT NUMERIC
21239: PPM SRC10 NOT NUMERIC
21240: PPM SRC03 KEY1 LESS
21241: PPM SRC08 KEYS EQUAL
21242: PPM SRC05 KEY1 GREATER
21243: *
21244: * RETURN IF KEY1 SMALLER (SORT), GREATER (RSORT)
21245: *
21246: SRC03 BNZ SRTSR,SRC06 JUMP IF RSORT
21247: *
21248: SRC04 MOV SRTSC,WC RESTORE WC
21249: EXI 1 RETURN
21250: *
21251: * RETURN IF KEY1 GREATER (SORT), SMALLER (RSORT)
21252: *
21253: SRC05 BNZ SRTSR,SRC04 JUMP IF RSORT
21254: *
21255: SRC06 MOV SRTSC,WC RESTORE WC
21256: EXI RETURN
21257: *
21258: * KEYS ARE OF SAME DATATYPE
21259: *
21260: SRC07 BLT XL,XR,SRC03 ITEM FIRST CREATED IS LESS
21261: BGT XL,XR,SRC05 ADDRESSES RISE IN ORDER OF CREATION
21262: *
21263: * DROP THROUGH OR MERGE FOR IDENTICAL OR EQUAL OBJECTS
21264: *
21265: SRC08 BLT SRTS1,SRTS2,SRC04 TEST OFFSETS OR KEY ADDRSS INSTEAD
21266: BRN SRC06 OFFSET 1 GREATER
21267: EJC
21268: *
21269: * SORTC (CONTINUED)
21270: *
21271: * STRINGS
21272: *
21273: SRC09 MOV XL,-(XS) STACK
21274: MOV XR,-(XS) ARGS
21275: JSR LCOMP COMPARE OBJECTS
21276: PPM CANT
21277: PPM FAIL
21278: PPM SRC03 KEY1 LESS
21279: PPM SRC08 KEYS EQUAL
21280: PPM SRC05 KEY1 GREATER
21281: *
21282: * ARITHMETIC COMPARISON FAILED - RECOVER ARGS
21283: *
21284: SRC10 MOV R$SXL,XL GET ARG1
21285: MOV R$SXR,XR GET ARG2
21286: MOV (XL),WC GET TYPE OF KEY1
21287: BEQ WC,(XR),SRC07 JUMP IF KEYS OF SAME TYPE
21288: MOV WC,XL GET BLOCK TYPE WORD
21289: MOV (XR),XR GET BLOCK TYPE WORD
21290: LEI XL ENTRY POINT ID FOR KEY1
21291: LEI XR ENTRY POINT ID FOR KEY2
21292: BGT XL,XR,SRC05 JUMP IF KEY1 GT KEY2
21293: BRN SRC03 KEY1 LT KEY2
21294: *
21295: * DATATYPE FIELD NAME USED
21296: *
21297: SRC11 JSR SORTF CALL ROUTINE TO FIND FIELD 1
21298: MOV XL,-(XS) STACK ITEM POINTER
21299: MOV XR,XL GET KEY2
21300: JSR SORTF FIND FIELD 2
21301: MOV XL,XR PLACE AS KEY2
21302: MOV (XS)+,XL RECOVER KEY1
21303: BRN SRC01 MERGE
21304: ENP PROCEDURE SORTC
21305: EJC
21306: *
21307: * SORTF -- FIND FIELD FOR SORTC
21308: *
21309: * ROUTINE USED BY SORTC TO OBTAIN ITEM CORRESPONDING
21310: * TO A GIVEN FIELD NAME, IF THIS EXISTS, IN A PROGRAMMER
21311: * DEFINED OBJECT PASSED AS ARGUMENT.
21312: * IF SUCH A MATCH OCCURS, RECORD IS KEPT OF DATATYPE
21313: * NAME, FIELD NAME AND OFFSET TO FIELD IN ORDER TO
21314: * SHORT-CIRCUIT LATER SEARCHES ON SAME TYPE. NOTE THAT
21315: * DFBLKS ARE STORED IN STATIC AND HENCE CANNOT BE MOVED.
21316: *
21317: * (SRTDF) VRBLK POINTER OF FIELD NAME
21318: * (XL) POSSIBLE PDBLK POINTER
21319: * JSR SORTF CALL TO SEARCH FOR FIELD NAME
21320: * (XL) ITEM FOUND OR ORIGINAL PDBLK PTR
21321: * (WC) DESTROYED
21322: *
21323: SORTF PRC E,0 ENTRY POINT
21324: BNE (XL),=B$PDT,SRTF3 RETURN IF NOT PDBLK
21325: MOV XR,-(XS) KEEP XR
21326: MOV SRTFD,XR GET POSSIBLE FORMER DFBLK PTR
21327: BZE XR,SRTF4 JUMP IF NOT
21328: BNE XR,PDDFP(XL),SRTF4 JUMP IF NOT RIGHT DATATYPE
21329: BNE SRTDF,SRTFF,SRTF4 JUMP IF NOT RIGHT FIELD NAME
21330: ADD SRTFO,XL ADD OFFSET TO REQUIRED FIELD
21331: *
21332: * HERE WITH XL POINTING TO FOUND FIELD
21333: *
21334: SRTF1 MOV (XL),XL GET ITEM FROM FIELD
21335: *
21336: * RETURN POINT
21337: *
21338: SRTF2 MOV (XS)+,XR RESTORE XR
21339: *
21340: SRTF3 EXI RETURN
21341: EJC
21342: *
21343: * SORTF (CONTINUED)
21344: *
21345: * CONDUCT A SEARCH
21346: *
21347: SRTF4 MOV XL,XR COPY ORIGINAL POINTER
21348: MOV PDDFP(XR),XR POINT TO DFBLK
21349: MOV XR,SRTFD KEEP A COPY
21350: MOV FARGS(XR),WC GET NUMBER OF FIELDS
21351: WTB WC CONVERT TO BYTES
21352: ADD DFLEN(XR),XR POINT PAST LAST FIELD
21353: *
21354: * LOOP TO FIND NAME IN PDFBLK
21355: *
21356: SRTF5 DCA WC COUNT DOWN
21357: DCA XR POINT IN FRONT
21358: BEQ (XR),SRTDF,SRTF6 SKIP OUT IF FOUND
21359: BNZ WC,SRTF5 LOOP
21360: BRN SRTF2 RETURN - NOT FOUND
21361: *
21362: * FOUND
21363: *
21364: SRTF6 MOV (XR),SRTFF KEEP FIELD NAME PTR
21365: ADD *PDFLD,WC ADD OFFSET TO FIRST FIELD
21366: MOV WC,SRTFO STORE AS FIELD OFFSET
21367: ADD WC,XL POINT TO FIELD
21368: BRN SRTF1 RETURN
21369: ENP PROCEDURE SORTF
21370: EJC
21371: *
21372: * SORTH -- HEAP ROUTINE FOR SORTA
21373: *
21374: * THIS ROUTINE CONSTRUCTS A HEAP FROM ELEMENTS OF ARRAY, A.
21375: * IN THIS APPLICATION, THE ELEMENTS ARE OFFSETS TO KEYS IN
21376: * A KEY ARRAY.
21377: *
21378: * (XS) POINTER TO SORT ARRAY BASE
21379: * 1(XS) POINTER TO KEY ARRAY BASE
21380: * (WA) MAX ARRAY INDEX, N (IN BYTES)
21381: * (WC) OFFSET J IN A TO ROOT (IN *1 TO *N)
21382: * JSR SORTH CALL SORTH(J,N) TO MAKE HEAP
21383: * (XL,XR,WB) DESTROYED
21384: *
21385: SORTH PRC N,0 ENTRY POINT
21386: MOV WA,SRTSN SAVE N
21387: MOV WC,SRTWC KEEP WC
21388: MOV (XS),XL SORT ARRAY BASE ADRS
21389: ADD SRTSO,XL ADD OFFSET TO A(0)
21390: ADD WC,XL POINT TO A(J)
21391: MOV (XL),SRTRT GET OFFSET TO ROOT
21392: ADD WC,WC DOUBLE J - CANT EXCEED N
21393: *
21394: * LOOP TO MOVE DOWN TREE USING DOUBLED INDEX J
21395: *
21396: SRH01 BGT WC,SRTSN,SRH03 DONE IF J GT N
21397: BEQ WC,SRTSN,SRH02 SKIP IF J EQUALS N
21398: MOV (XS),XR SORT ARRAY BASE ADRS
21399: MOV 1(XS),XL KEY ARRAY BASE ADRS
21400: ADD SRTSO,XR POINT TO A(0)
21401: ADD WC,XR ADRS OF A(J)
21402: MOV 1(XR),WA GET A(J+1)
21403: MOV (XR),WB GET A(J)
21404: *
21405: * COMPARE SONS. (WA) RIGHT SON, (WB) LEFT SON
21406: *
21407: JSR SORTC COMPARE KEYS - LT(A(J+1),A(J))
21408: PPM SRH02 A(J+1) LT A(J)
21409: ICA WC POINT TO GREATER SON, A(J+1)
21410: EJC
21411: *
21412: * SORTH (CONTINUED)
21413: *
21414: * COMPARE ROOT WITH GREATER SON
21415: *
21416: SRH02 MOV 1(XS),XL KEY ARRAY BASE ADRS
21417: MOV (XS),XR GET SORT ARRAY ADDRESS
21418: ADD SRTSO,XR ADRS OF A(0)
21419: MOV XR,WB COPY THIS ADRS
21420: ADD WC,XR ADRS OF GREATER SON, A(J)
21421: MOV (XR),WA GET A(J)
21422: MOV WB,XR POINT BACK TO A(0)
21423: MOV SRTRT,WB GET ROOT
21424: JSR SORTC COMPARE THEM - LT(A(J),ROOT)
21425: PPM SRH03 FATHER EXCEEDS SONS - DONE
21426: MOV (XS),XR GET SORT ARRAY ADRS
21427: ADD SRTSO,XR POINT TO A(0)
21428: MOV XR,XL COPY IT
21429: MOV WC,WA COPY J
21430: BTW WC CONVERT TO WORDS
21431: RSH WC,1 GET J/2
21432: WTB WC CONVERT BACK TO BYTES
21433: ADD WA,XL POINT TO A(J)
21434: ADD WC,XR ADRS OF A(J/2)
21435: MOV (XL),(XR) A(J/2) = A(J)
21436: MOV WA,WC RECOVER J
21437: AOV WC,WC,SRH03 J = J*2. DONE IF TOO BIG
21438: BRN SRH01 LOOP
21439: *
21440: * FINISH BY COPYING ROOT OFFSET BACK INTO ARRAY
21441: *
21442: SRH03 BTW WC CONVERT TO WORDS
21443: RSH WC,1 J = J/2
21444: WTB WC CONVERT BACK TO BYTES
21445: MOV (XS),XR SORT ARRAY ADRS
21446: ADD SRTSO,XR ADRS OF A(0)
21447: ADD WC,XR ADRS OF A(J/2)
21448: MOV SRTRT,(XR) A(J/2) = ROOT
21449: MOV SRTSN,WA RESTORE WA
21450: MOV SRTWC,WC RESTORE WC
21451: EXI RETURN
21452: ENP END PROCEDURE SORTH
21453: EJC
21454: EJC
21455: *
21456: * TFIND -- LOCATE TABLE ELEMENT
21457: *
21458: * (XR) SUBSCRIPT VALUE FOR ELEMENT
21459: * (XL) POINTER TO TABLE
21460: * (WB) ZERO BY VALUE, NON-ZERO BY NAME
21461: * JSR TFIND CALL TO LOCATE ELEMENT
21462: * PPM LOC TRANSFER LOCATION IF ACCESS FAILS
21463: * (XR) ELEMENT VALUE (IF BY VALUE)
21464: * (XR) DESTROYED (IF BY NAME)
21465: * (XL,WA) TEBLK NAME (IF BY NAME)
21466: * (XL,WA) DESTROYED (IF BY VALUE)
21467: * (WC,RA) DESTROYED
21468: *
21469: * NOTE THAT IF A CALL BY VALUE SPECIFIES A NON-EXISTENT
21470: * SUBSCRIPT, NULL IS RETURNED WITHOUT BUILDING A NEW TEBLK.
21471: *
21472: TFIND PRC E,1 ENTRY POINT
21473: MOV WB,-(XS) SAVE NAME/VALUE INDICATOR
21474: MOV XR,-(XS) SAVE SUBSCRIPT VALUE
21475: MOV XL,-(XS) SAVE TABLE POINTER
21476: MOV TBLEN(XL),WA LOAD LENGTH OF TBBLK
21477: BTW WA CONVERT TO WORD COUNT
21478: SUB =TBBUK,WA GET NUMBER OF BUCKETS
21479: MTI WA CONVERT TO INTEGER VALUE
21480: STI TFNSI SAVE FOR LATER
21481: MOV (XR),XL LOAD FIRST WORD OF SUBSCRIPT
21482: LEI XL LOAD BLOCK ENTRY ID (BL$XX)
21483: BSW XL,BL$$D,TFN00 SWITCH ON BLOCK TYPE
21484: IFF BL$IC,TFN02 JUMP IF INTEGER
21485: IFF BL$RC,TFN02 REAL
21486: IFF BL$P0,TFN03 JUMP IF PATTERN
21487: IFF BL$P1,TFN03 JUMP IF PATTERN
21488: IFF BL$P2,TFN03 JUMP IF PATTERN
21489: IFF BL$NM,TFN04 JUMP IF NAME
21490: IFF BL$SC,TFN05 JUMP IF STRING
21491: ESW END SWITCH ON BLOCK TYPE
21492: *
21493: * HERE FOR BLOCKS FOR WHICH WE USE THE SECOND WORD OF THE
21494: * BLOCK AS THE HASH SOURCE (SEE BLOCK FORMATS FOR DETAILS).
21495: *
21496: TFN00 MOV 1(XR),WA LOAD SECOND WORD
21497: *
21498: * MERGE HERE WITH ONE WORD HASH SOURCE IN WA
21499: *
21500: TFN01 MTI WA CONVERT TO INTEGER
21501: BRN TFN06 JUMP TO MERGE
21502: EJC
21503: *
21504: * TFIND (CONTINUED)
21505: *
21506: * HERE FOR INTEGER OR REAL
21507: *
21508: TFN02 LDI 1(XR) LOAD VALUE AS HASH SOURCE
21509: IGE TFN06 OK IF POSITIVE OR ZERO
21510: NGI MAKE POSITIVE
21511: IOV TFN06 CLEAR POSSIBLE OVERFLOW
21512: BRN TFN06 MERGE
21513: *
21514: * FOR PATTERN, USE FIRST WORD (PCODE) AS SOURCE
21515: *
21516: TFN03 MOV (XR),WA LOAD FIRST WORD AS HASH SOURCE
21517: BRN TFN01 MERGE BACK
21518: *
21519: * FOR NAME, USE OFFSET AS HASH SOURCE
21520: *
21521: TFN04 MOV NMOFS(XR),WA LOAD OFFSET AS HASH SOURCE
21522: BRN TFN01 MERGE BACK
21523: *
21524: * HERE FOR STRING
21525: *
21526: TFN05 JSR HASHS CALL ROUTINE TO COMPUTE HASH
21527: *
21528: * MERGE HERE WITH HASH SOURCE IN (IA)
21529: *
21530: TFN06 RMI TFNSI COMPUTE HASH INDEX BY REMAINDERING
21531: MFI WC GET AS ONE WORD INTEGER
21532: WTB WC CONVERT TO BYTE OFFSET
21533: MOV (XS),XL GET TABLE PTR AGAIN
21534: ADD WC,XL POINT TO PROPER BUCKET
21535: MOV TBBUK(XL),XR LOAD FIRST TEBLK POINTER
21536: BEQ XR,(XS),TFN10 JUMP IF NO TEBLKS ON CHAIN
21537: *
21538: * LOOP THROUGH TEBLKS ON HASH CHAIN
21539: *
21540: TFN07 MOV XR,WB SAVE TEBLK POINTER
21541: MOV TESUB(XR),XR LOAD SUBSCRIPT VALUE
21542: MOV 1(XS),XL LOAD INPUT ARGUMENT SUBSCRIPT VAL
21543: JSR IDENT COMPARE THEM
21544: PPM TFN08 JUMP IF EQUAL (IDENT)
21545: *
21546: * HERE IF NO MATCH WITH THAT TEBLK
21547: *
21548: MOV WB,XL RESTORE TEBLK POINTER
21549: MOV TENXT(XL),XR POINT TO NEXT TEBLK ON CHAIN
21550: BNE XR,(XS),TFN07 JUMP IF THERE IS ONE
21551: *
21552: * HERE IF NO MATCH WITH ANY TEBLK ON CHAIN
21553: *
21554: MOV *TENXT,WC SET OFFSET TO LINK FIELD (XL BASE)
21555: BRN TFN11 JUMP TO MERGE
21556: EJC
21557: *
21558: * TFIND (CONTINUED)
21559: *
21560: * HERE WE HAVE FOUND A MATCHING ELEMENT
21561: *
21562: TFN08 MOV WB,XL RESTORE TEBLK POINTER
21563: MOV *TEVAL,WA SET TEBLK NAME OFFSET
21564: MOV 2(XS),WB RESTORE NAME/VALUE INDICATOR
21565: BNZ WB,TFN09 JUMP IF CALLED BY NAME
21566: JSR ACESS ELSE GET VALUE
21567: PPM TFN12 JUMP IF REFERENCE FAILS
21568: ZER WB RESTORE NAME/VALUE INDICATOR
21569: *
21570: * COMMON EXIT FOR ENTRY FOUND
21571: *
21572: TFN09 ADD *NUM03,XS POP STACK ENTRIES
21573: EXI RETURN TO TFIND CALLER
21574: *
21575: * HERE IF NO TEBLKS ON THE HASH CHAIN
21576: *
21577: TFN10 ADD *TBBUK,WC GET OFFSET TO BUCKET PTR
21578: MOV (XS),XL SET TBBLK PTR AS BASE
21579: *
21580: * MERGE HERE WITH (XL,WC) BASE,OFFSET OF FINAL LINK
21581: *
21582: TFN11 MOV (XS),XR TBBLK POINTER
21583: MOV TBINV(XR),XR LOAD DEFAULT VALUE IN CASE
21584: MOV 2(XS),WB LOAD NAME/VALUE INDICATOR
21585: BZE WB,TFN09 EXIT WITH DEFAULT IF VALUE CALL
21586: *
21587: * HERE WE MUST BUILD A NEW TEBLK
21588: *
21589: MOV *TESI$,WA SET SIZE OF TEBLK
21590: JSR ALLOC ALLOCATE TEBLK
21591: ADD WC,XL POINT TO HASH LINK
21592: MOV XR,(XL) LINK NEW TEBLK AT END OF CHAIN
21593: MOV =B$TET,(XR) STORE TYPE WORD
21594: MOV =NULLS,TEVAL(XR) SET NULL AS INITIAL VALUE
21595: MOV (XS)+,TENXT(XR) SET TBBLK PTR TO MARK END OF CHAIN
21596: MOV (XS)+,TESUB(XR) STORE SUBSCRIPT VALUE
21597: ICA XS POP PAST NAME/VALUE INDICATOR
21598: MOV XR,XL COPY TEBLK POINTER (NAME BASE)
21599: MOV *TEVAL,WA SET OFFSET
21600: EXI RETURN TO CALLER WITH NEW TEBLK
21601: *
21602: * ACESS FAIL RETURN
21603: *
21604: TFN12 EXI 1 ALTERNATIVE RETURN
21605: ENP END PROCEDURE TFIND
21606: EJC
21607: *
21608: * TRACE -- SET/RESET A TRACE ASSOCIATION
21609: *
21610: * THIS PROCEDURE IS SHARED BY TRACE AND STOPTR TO
21611: * EITHER INITIATE OR STOP A TRACE RESPECTIVELY.
21612: *
21613: * (XL) TRBLK PTR (TRACE) OR ZERO (STOPTR)
21614: * 1(XS) FIRST ARGUMENT (NAME)
21615: * 0(XS) SECOND ARGUMENT (TRACE TYPE)
21616: * JSR TRACE CALL TO SET/RESET TRACE
21617: * PPM LOC TRANSFER LOC IF 1ST ARG IS BAD NAME
21618: * PPM LOC TRANSFER LOC IF 2ND ARG IS BAD TYPE
21619: * (XS) POPPED
21620: * (XL,XR,WA,WB,WC,IA) DESTROYED
21621: *
21622: TRACE PRC N,2 ENTRY POINT
21623: JSR GTSTG GET TRACE TYPE STRING
21624: PPM TRC15 JUMP IF NOT STRING
21625: PLC XR ELSE POINT TO STRING
21626: LCH WA,(XR) LOAD FIRST CHARACTER
21627: FLC WA FOLD TO UPPER CASE
21628: MOV (XS),XR LOAD NAME ARGUMENT
21629: MOV XL,(XS) STACK TRBLK PTR OR ZERO
21630: MOV =TRTAC,WC SET TRTYP FOR ACCESS TRACE
21631: BEQ WA,=CH$LA,TRC10 JUMP IF A (ACCESS)
21632: MOV =TRTVL,WC SET TRTYP FOR VALUE TRACE
21633: BEQ WA,=CH$LV,TRC10 JUMP IF V (VALUE)
21634: BZE WA,TRC10 JUMP IF BLANK (VALUE)
21635: *
21636: * HERE FOR L,K,F,C,R
21637: *
21638: BEQ WA,=CH$LF,TRC01 JUMP IF F (FUNCTION)
21639: BEQ WA,=CH$LR,TRC01 JUMP IF R (RETURN)
21640: BEQ WA,=CH$LL,TRC03 JUMP IF L (LABEL)
21641: BEQ WA,=CH$LK,TRC06 JUMP IF K (KEYWORD)
21642: BNE WA,=CH$LC,TRC15 ELSE ERROR IF NOT C (CALL)
21643: *
21644: * HERE FOR F,C,R
21645: *
21646: TRC01 JSR GTNVR POINT TO VRBLK FOR NAME
21647: PPM TRC16 JUMP IF BAD NAME
21648: ICA XS POP STACK
21649: MOV VRFNC(XR),XR POINT TO FUNCTION BLOCK
21650: BNE (XR),=B$PFC,TRC17 ERROR IF NOT PROGRAM FUNCTION
21651: BEQ WA,=CH$LR,TRC02 JUMP IF R (RETURN)
21652: EJC
21653: *
21654: * TRACE (CONTINUED)
21655: *
21656: * HERE FOR F,C TO SET/RESET CALL TRACE
21657: *
21658: MOV XL,PFCTR(XR) SET/RESET CALL TRACE
21659: BEQ WA,=CH$LC,EXNUL EXIT WITH NULL IF C (CALL)
21660: *
21661: * HERE FOR F,R TO SET/RESET RETURN TRACE
21662: *
21663: TRC02 MOV XL,PFRTR(XR) SET/RESET RETURN TRACE
21664: EXI RETURN
21665: *
21666: * HERE FOR L TO SET/RESET LABEL TRACE
21667: *
21668: TRC03 JSR GTNVR POINT TO VRBLK
21669: PPM TRC16 JUMP IF BAD NAME
21670: MOV VRLBL(XR),XL LOAD LABEL POINTER
21671: BNE (XL),=B$TRT,TRC04 JUMP IF NO OLD TRACE
21672: MOV TRLBL(XL),XL ELSE DELETE OLD TRACE ASSOCIATION
21673: *
21674: * HERE WITH OLD LABEL TRACE ASSOCIATION DELETED
21675: *
21676: TRC04 BEQ XL,=STNDL,TRC16 ERROR IF UNDEFINED LABEL
21677: MOV (XS)+,WB GET TRBLK PTR AGAIN
21678: BZE WB,TRC05 JUMP IF STOPTR CASE
21679: MOV WB,VRLBL(XR) ELSE SET NEW TRBLK POINTER
21680: MOV =B$VRT,VRTRA(XR) SET LABEL TRACE ROUTINE ADDRESS
21681: MOV WB,XR COPY TRBLK POINTER
21682: MOV XL,TRLBL(XR) STORE REAL LABEL IN TRBLK
21683: EXI RETURN
21684: *
21685: * HERE FOR STOPTR CASE FOR LABEL
21686: *
21687: TRC05 MOV XL,VRLBL(XR) STORE LABEL PTR BACK IN VRBLK
21688: MOV =B$VRG,VRTRA(XR) STORE NORMAL TRANSFER ADDRESS
21689: EXI RETURN
21690: EJC
21691: *
21692: * TRACE (CONTINUED)
21693: *
21694: * HERE FOR K (KEYWORD)
21695: *
21696: TRC06 JSR GTNVR POINT TO VRBLK
21697: PPM TRC16 ERROR IF NOT NATURAL VAR
21698: BNZ VRLEN(XR),TRC16 ERROR IF NOT SYSTEM VAR
21699: ICA XS POP STACK
21700: BZE XL,TRC07 JUMP IF STOPTR CASE
21701: MOV XR,TRKVR(XL) STORE VRBLK PTR IN TRBLK FOR KTREX
21702: *
21703: * MERGE HERE WITH TRBLK SET UP IN WB (OR ZERO)
21704: *
21705: TRC07 MOV VRSVP(XR),XR POINT TO SVBLK
21706: BEQ XR,=V$ERT,TRC08 JUMP IF ERRTYPE
21707: BEQ XR,=V$STC,TRC09 JUMP IF STCOUNT
21708: BNE XR,=V$FNC,TRC17 ELSE ERROR IF NOT FNCLEVEL
21709: *
21710: * FNCLEVEL
21711: *
21712: MOV XL,R$FNC SET/RESET FNCLEVEL TRACE
21713: EXI RETURN
21714: *
21715: * ERRTYPE
21716: *
21717: TRC08 MOV XL,R$ERT SET/RESET ERRTYPE TRACE
21718: EXI RETURN
21719: *
21720: * STCOUNT
21721: *
21722: TRC09 MOV XL,R$STC SET/RESET STCOUNT TRACE
21723: EXI RETURN
21724: EJC
21725: *
21726: * TRACE (CONTINUED)
21727: *
21728: * A,V MERGE HERE WITH TRTYP VALUE IN WC
21729: *
21730: TRC10 JSR GTVAR LOCATE VARIABLE
21731: PPM TRC16 ERROR IF NOT APPROPRIATE NAME
21732: MOV (XS)+,WB GET NEW TRBLK PTR AGAIN
21733: ADD XL,WA POINT TO VARIABLE LOCATION
21734: MOV WA,XR COPY VARIABLE POINTER
21735: *
21736: * LOOP TO SEARCH TRBLK CHAIN
21737: *
21738: TRC11 MOV (XR),XL POINT TO NEXT ENTRY
21739: BNE (XL),=B$TRT,TRC13 JUMP IF NOT TRBLK
21740: BLT WC,TRTYP(XL),TRC13 JUMP IF TOO FAR OUT ON CHAIN
21741: BEQ WC,TRTYP(XL),TRC12 JUMP IF THIS MATCHES OUR TYPE
21742: ADD *TRNXT,XL ELSE POINT TO LINK FIELD
21743: MOV XL,XR COPY POINTER
21744: BRN TRC11 AND LOOP BACK
21745: *
21746: * HERE TO DELETE AN OLD TRBLK OF THE TYPE WE WERE GIVEN
21747: *
21748: TRC12 MOV TRNXT(XL),XL GET PTR TO NEXT BLOCK OR VALUE
21749: MOV XL,(XR) STORE TO DELETE THIS TRBLK
21750: *
21751: * HERE AFTER DELETING ANY OLD ASSOCIATION OF THIS TYPE
21752: *
21753: TRC13 BZE WB,TRC14 JUMP IF STOPTR CASE
21754: MOV WB,(XR) ELSE LINK NEW TRBLK IN
21755: MOV WB,XR COPY TRBLK POINTER
21756: MOV XL,TRNXT(XR) STORE FORWARD POINTER
21757: MOV WC,TRTYP(XR) STORE APPROPRIATE TRAP TYPE CODE
21758: *
21759: * HERE TO MAKE SURE VRGET,VRSTO ARE SET PROPERLY
21760: *
21761: TRC14 MOV WA,XR RECALL POSSIBLE VRBLK POINTER
21762: SUB *VRVAL,XR POINT BACK TO VRBLK
21763: JSR SETVR SET FIELDS IF VRBLK
21764: EXI RETURN
21765: *
21766: * HERE FOR BAD TRACE TYPE
21767: *
21768: TRC15 EXI 2 TAKE BAD TRACE TYPE ERROR EXIT
21769: *
21770: * POP STACK BEFORE FAILING
21771: *
21772: TRC16 ICA XS POP STACK
21773: *
21774: * HERE FOR BAD NAME ARGUMENT
21775: *
21776: TRC17 EXI 1 TAKE BAD NAME ERROR EXIT
21777: ENP END PROCEDURE TRACE
21778: EJC
21779: *
21780: * TRBLD -- BUILD TRBLK
21781: *
21782: * TRBLK IS USED BY THE INPUT, OUTPUT AND TRACE FUNCTIONS
21783: * TO CONSTRUCT A TRBLK (TRAP BLOCK)
21784: *
21785: * (XR) TRTAG OR TRTER
21786: * (XL) TRFNC OR TRFPT
21787: * (WB) TRTYP
21788: * JSR TRBLD CALL TO BUILD TRBLK
21789: * (XR) POINTER TO TRBLK
21790: * (WA) DESTROYED
21791: *
21792: TRBLD PRC E,0 ENTRY POINT
21793: MOV XR,-(XS) STACK TRTAG (OR TRFNM)
21794: MOV *TRSI$,WA SET SIZE OF TRBLK
21795: JSR ALLOC ALLOCATE TRBLK
21796: MOV =B$TRT,(XR) STORE FIRST WORD
21797: MOV XL,TRFNC(XR) STORE TRFNC (OR TRFPT)
21798: MOV (XS)+,TRTAG(XR) STORE TRTAG (OR TRFNM)
21799: MOV WB,TRTYP(XR) STORE TYPE
21800: MOV =NULLS,TRVAL(XR) FOR NOW, A NULL VALUE
21801: EXI RETURN TO CALLER
21802: ENP END PROCEDURE TRBLD
21803: EJC
21804: *
21805: * TRIMR -- TRIM TRAILING BLANKS
21806: *
21807: * TRIMR IS PASSED A POINTER TO AN SCBLK WHICH MUST BE THE
21808: * LAST BLOCK IN DYNAMIC STORAGE. TRAILING BLANKS ARE
21809: * TRIMMED OFF AND THE DYNAMIC STORAGE POINTER RESET TO
21810: * THE END OF THE (POSSIBLY) SHORTENED BLOCK.
21811: *
21812: * (WB) NON-ZERO TO TRIM TRAILING BLANKS
21813: * (XR) POINTER TO STRING TO TRIM
21814: * JSR TRIMR CALL TO TRIM STRING
21815: * (XR) POINTER TO TRIMMED STRING
21816: * (XL,WA,WB,WC) DESTROYED
21817: *
21818: * THE CALL WITH WB ZERO STILL PERFORMS THE END ZERO PAD
21819: * AND DNAMP READJUSTMENT. IT IS USED FROM ACESS IF KVTRM=0.
21820: *
21821: TRIMR PRC E,0 ENTRY POINT
21822: MOV XR,XL COPY STRING POINTER
21823: MOV SCLEN(XR),WA LOAD STRING LENGTH
21824: BZE WA,TRIM2 JUMP IF NULL INPUT
21825: PLC XL,WA ELSE POINT PAST LAST CHARACTER
21826: BZE WB,TRIM3 JUMP IF NO TRIM
21827: MOV =CH$BL,WC LOAD BLANK CHARACTER
21828: *
21829: * LOOP THROUGH CHARACTERS FROM RIGHT TO LEFT
21830: *
21831: TRIM0 LCH WB,-(XL) LOAD NEXT CHARACTER
21832: BEQ WB,=CH$HT,TRIM1 JUMP IF HORIZONTAL TAB
21833: BNE WB,WC,TRIM3 JUMP IF NON-BLANK FOUND
21834: TRIM1 DCV WA ELSE DECREMENT CHARACTER COUNT
21835: BNZ WA,TRIM0 LOOP BACK IF MORE TO CHECK
21836: *
21837: * HERE IF RESULT IS NULL (NULL OR ALL-BLANK INPUT)
21838: *
21839: TRIM2 MOV XR,DNAMP WIPE OUT INPUT STRING BLOCK
21840: MOV =NULLS,XR LOAD NULL RESULT
21841: BRN TRIM5 MERGE TO EXIT
21842: EJC
21843: *
21844: * TRIMR (CONTINUED)
21845: *
21846: * HERE WITH NON-BLANK FOUND (MERGE FOR NO TRIM)
21847: *
21848: TRIM3 MOV WA,SCLEN(XR) SET NEW LENGTH
21849: MOV XR,XL COPY STRING POINTER
21850: PSC XL,WA READY FOR STORING BLANKS
21851: CTB WA,SCHAR GET LENGTH OF BLOCK IN BYTES
21852: ADD XR,WA POINT PAST NEW BLOCK
21853: MOV WA,DNAMP SET NEW TOP OF STORAGE POINTER
21854: LCT WA,=CFP$C GET COUNT OF CHARS IN WORD
21855: ZER WC SET BLANK CHAR
21856: *
21857: * LOOP TO ZERO PAD LAST WORD OF CHARACTERS
21858: *
21859: TRIM4 SCH WC,(XL)+ STORE ZERO CHARACTER
21860: BCT WA,TRIM4 LOOP BACK TILL ALL STORED
21861: CSC XL COMPLETE STORE CHARACTERS
21862: *
21863: * COMMON EXIT POINT
21864: *
21865: TRIM5 ZER XL CLEAR GARBAGE XL POINTER
21866: EXI RETURN TO CALLER
21867: ENP END PROCEDURE TRIMR
21868: EJC
21869: *
21870: * TRXEQ -- EXECUTE FUNCTION TYPE TRACE
21871: *
21872: * TRXEQ IS USED TO EXECUTE A TRACE WHEN A FOURTH ARGUMENT
21873: * HAS BEEN SUPPLIED. TRACE HAS ALREADY BEEN DECREMENTED.
21874: *
21875: * (XR) POINTER TO TRBLK
21876: * (XL,WA) NAME BASE,OFFSET FOR VARIABLE
21877: * JSR TRXEQ CALL TO EXECUTE TRACE
21878: * (WB,WC,RA) DESTROYED
21879: *
21880: * THE FOLLOWING STACK ENTRIES ARE MADE BEFORE PASSING
21881: * CONTROL TO THE TRACE FUNCTION USING THE CFUNC ROUTINE.
21882: *
21883: * TRXEQ RETURN POINT WORD(S)
21884: * SAVED VALUE OF TRACE KEYWORD
21885: * TRBLK POINTER
21886: * NAME BASE
21887: * NAME OFFSET
21888: * SAVED VALUE OF R$COD
21889: * SAVED CODE PTR (-R$COD)
21890: * SAVED VALUE OF FLPTR
21891: * FLPTR --------------- ZERO (DUMMY FAIL OFFSET)
21892: * NMBLK FOR VARIABLE NAME
21893: * XS ------------------ TRACE TAG
21894: *
21895: * R$COD AND THE CODE PTR ARE SET TO DUMMY VALUES WHICH
21896: * CAUSE CONTROL TO RETURN TO THE TRXEQ PROCEDURE ON SUCCESS
21897: * OR FAILURE (TRXEQ IGNORES A FAILURE CONDITION).
21898: *
21899: TRXEQ PRC R,0 ENTRY POINT (RECURSIVE)
21900: MOV R$COD,WC LOAD CODE BLOCK POINTER
21901: SCP WB GET CURRENT CODE POINTER
21902: SUB WC,WB MAKE CODE POINTER INTO OFFSET
21903: MOV KVTRA,-(XS) STACK TRACE KEYWORD VALUE
21904: MOV XR,-(XS) STACK TRBLK POINTER
21905: MOV XL,-(XS) STACK NAME BASE
21906: MOV WA,-(XS) STACK NAME OFFSET
21907: MOV WC,-(XS) STACK CODE BLOCK POINTER
21908: MOV WB,-(XS) STACK CODE POINTER OFFSET
21909: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER
21910: ZER -(XS) SET DUMMY FAIL OFFSET
21911: MOV XS,FLPTR SET NEW FAILURE POINTER
21912: ZER KVTRA RESET TRACE KEYWORD TO ZERO
21913: MOV =TRXDC,WC LOAD NEW (DUMMY) CODE BLK POINTER
21914: MOV WC,R$COD SET AS CODE BLOCK POINTER
21915: LCP WC AND NEW CODE POINTER
21916: EJC
21917: *
21918: * TRXEQ (CONTINUED)
21919: *
21920: * NOW PREPARE ARGUMENTS FOR FUNCTION
21921: *
21922: MOV WA,WB SAVE NAME OFFSET
21923: MOV *NMSI$,WA LOAD NMBLK SIZE
21924: JSR ALLOC ALLOCATE SPACE FOR NMBLK
21925: MOV =B$NML,(XR) SET TYPE WORD
21926: MOV XL,NMBAS(XR) STORE NAME BASE
21927: MOV WB,NMOFS(XR) STORE NAME OFFSET
21928: MOV 6(XS),XL RELOAD POINTER TO TRBLK
21929: MOV XR,-(XS) STACK NMBLK POINTER (1ST ARGUMENT)
21930: MOV TRTAG(XL),-(XS) STACK TRACE TAG (2ND ARGUMENT)
21931: MOV TRFNC(XL),XL LOAD TRACE FUNCTION POINTER
21932: MOV =NUM02,WA SET NUMBER OF ARGUMENTS TO TWO
21933: BRN CFUNC JUMP TO CALL FUNCTION
21934: *
21935: * SEE O$TXR FOR DETAILS OF RETURN TO THIS POINT
21936: *
21937: TRXQ1 MOV FLPTR,XS POINT BACK TO OUR STACK ENTRIES
21938: ICA XS POP OFF GARBAGE FAIL OFFSET
21939: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER
21940: MOV (XS)+,WB RELOAD CODE OFFSET
21941: MOV (XS)+,WC LOAD OLD CODE BASE POINTER
21942: MOV WC,XR COPY CDBLK POINTER
21943: MOV CDSTM(XR),KVSTN RESTORE STMNT NO
21944: MOV (XS)+,WA RELOAD NAME OFFSET
21945: MOV (XS)+,XL RELOAD NAME BASE
21946: MOV (XS)+,XR RELOAD TRBLK POINTER
21947: MOV (XS)+,KVTRA RESTORE TRACE KEYWORD VALUE
21948: ADD WC,WB RECOMPUTE ABSOLUTE CODE POINTER
21949: LCP WB RESTORE CODE POINTER
21950: MOV WC,R$COD AND CODE BLOCK POINTER
21951: EXI RETURN TO TRXEQ CALLER
21952: ENP END PROCEDURE TRXEQ
21953: EJC
21954: *
21955: * XSCAN -- EXECUTION FUNCTION ARGUMENT SCAN
21956: *
21957: * XSCAN SCANS OUT ONE TOKEN IN A PROTOTYPE ARGUMENT IN
21958: * ARRAY,CLEAR,DATA,DEFINE,LOAD FUNCTION CALLS. XSCAN
21959: * CALLS MUST BE PRECEDED BY A CALL TO THE INITIALIZATION
21960: * PROCEDURE XSCNI. THE FOLLOWING VARIABLES ARE USED.
21961: *
21962: * R$XSC POINTER TO SCBLK FOR FUNCTION ARG
21963: * XSOFS OFFSET (NUM CHARS SCANNED SO FAR)
21964: *
21965: * (WC) DELIMITER ONE (CH$XX)
21966: * (XL) DELIMITER TWO (CH$XX)
21967: * JSR XSCAN CALL TO SCAN NEXT ITEM
21968: * (XR) POINTER TO SCBLK FOR TOKEN SCANNED
21969: * (WA) COMPLETION CODE (SEE BELOW)
21970: * (WC,XL) DESTROYED
21971: *
21972: * THE SCAN STARTS FROM THE CURRENT POSITION AND CONTINUES
21973: * UNTIL ONE OF THE FOLLOWING THREE CONDITIONS OCCURS.
21974: *
21975: * 1) DELIMITER ONE IS ENCOUNTERED (WA SET TO 1)
21976: *
21977: * 2) DELIMITER TWO ENCOUNTERED (WA SET TO 2)
21978: *
21979: * 3) END OF STRING ENCOUNTERED (WA SET TO 0)
21980: *
21981: * THE RESULT IS A STRING CONTAINING ALL CHARACTERS SCANNED
21982: * UP TO BUT NOT INCLUDING ANY DELIMITER CHARACTER.
21983: * THE POINTER IS LEFT POINTING PAST THE DELIMITER.
21984: *
21985: * IF ONLY ONE DELIMITER IS TO BE DETECTED, DELIMITER ONE
21986: * AND DELIMITER TWO SHOULD BE SET TO THE SAME VALUE.
21987: *
21988: * IN THE CASE WHERE THE END OF STRING IS ENCOUNTERED, THE
21989: * STRING INCLUDES ALL THE CHARACTERS TO THE END OF THE
21990: * STRING. NO FURTHER CALLS CAN BE MADE TO XSCAN UNTIL
21991: * XSCNI IS CALLED TO INITIALIZE A NEW ARGUMENT SCAN
21992: EJC
21993: *
21994: * XSCAN (CONTINUED)
21995: *
21996: XSCAN PRC E,0 ENTRY POINT
21997: MOV WB,XSCWB PRESERVE WB
21998: MOV R$XSC,XR POINT TO ARGUMENT STRING
21999: MOV SCLEN(XR),WA LOAD STRING LENGTH
22000: MOV XSOFS,WB LOAD CURRENT OFFSET
22001: SUB WB,WA GET NUMBER OF REMAINING CHARACTERS
22002: BZE WA,XSCN2 JUMP IF NO CHARACTERS LEFT
22003: PLC XR,WB POINT TO CURRENT CHARACTER
22004: *
22005: * LOOP TO SEARCH FOR DELIMITER
22006: *
22007: XSCN1 LCH WB,(XR)+ LOAD NEXT CHARACTER
22008: BEQ WB,WC,XSCN3 JUMP IF DELIMITER ONE FOUND
22009: BEQ WB,XL,XSCN4 JUMP IF DELIMITER TWO FOUND
22010: DCV WA DECREMENT COUNT OF CHARS LEFT
22011: BNZ WA,XSCN1 LOOP BACK IF MORE CHARS TO GO
22012: *
22013: * HERE FOR RUNOUT
22014: *
22015: XSCN2 MOV R$XSC,XL POINT TO STRING BLOCK
22016: MOV SCLEN(XL),WA GET STRING LENGTH
22017: MOV XSOFS,WB LOAD OFFSET
22018: SUB WB,WA GET SUBSTRING LENGTH
22019: ZER R$XSC CLEAR STRING PTR FOR COLLECTOR
22020: ZER XSCRT SET ZERO (RUNOUT) RETURN CODE
22021: BRN XSCN6 JUMP TO EXIT
22022: EJC
22023: *
22024: * XSCAN (CONTINUED)
22025: *
22026: * HERE IF DELIMITER ONE FOUND
22027: *
22028: XSCN3 MOV =NUM01,XSCRT SET RETURN CODE
22029: BRN XSCN5 JUMP TO MERGE
22030: *
22031: * HERE IF DELIMITER TWO FOUND
22032: *
22033: XSCN4 MOV =NUM02,XSCRT SET RETURN CODE
22034: *
22035: * MERGE HERE AFTER DETECTING A DELIMITER
22036: *
22037: XSCN5 MOV R$XSC,XL RELOAD POINTER TO STRING
22038: MOV SCLEN(XL),WC GET ORIGINAL LENGTH OF STRING
22039: SUB WA,WC MINUS CHARS LEFT = CHARS SCANNED
22040: MOV WC,WA MOVE TO REG FOR SBSTR
22041: MOV XSOFS,WB SET OFFSET
22042: SUB WB,WA COMPUTE LENGTH FOR SBSTR
22043: ICV WC ADJUST NEW CURSOR PAST DELIMITER
22044: MOV WC,XSOFS STORE NEW OFFSET
22045: *
22046: * COMMON EXIT POINT
22047: *
22048: XSCN6 ZER XR CLEAR GARBAGE CHARACTER PTR IN XR
22049: JSR SBSTR BUILD SUB-STRING
22050: MOV XSCRT,WA LOAD RETURN CODE
22051: MOV XSCWB,WB RESTORE WB
22052: EXI RETURN TO XSCAN CALLER
22053: ENP END PROCEDURE XSCAN
22054: EJC
22055: *
22056: * XSCNI -- EXECUTION FUNCTION ARGUMENT SCAN
22057: *
22058: * XSCNI INITIALIZES THE SCAN USED FOR PROTOTYPE ARGUMENTS
22059: * IN THE CLEAR, DEFINE, LOAD, DATA, ARRAY FUNCTIONS. SEE
22060: * XSCAN FOR THE PROCEDURE WHICH IS USED AFTER THIS CALL.
22061: *
22062: * -(XS) ARGUMENT TO BE SCANNED (ON STACK)
22063: * JSR XSCNI CALL TO SCAN ARGUMENT
22064: * PPM LOC TRANSFER LOC IF ARG IS NOT STRING
22065: * PPM LOC TRANSFER LOC IF ARGUMENT IS NULL
22066: * (XS) POPPED
22067: * (XR,R$XSC) ARGUMENT (SCBLK PTR)
22068: * (WA) ARGUMENT LENGTH
22069: * (IA,RA) DESTROYED
22070: *
22071: XSCNI PRC N,2 ENTRY POINT
22072: JSR GTSTG FETCH ARGUMENT AS STRING
22073: PPM XSCI1 JUMP IF NOT CONVERTIBLE
22074: MOV XR,R$XSC ELSE STORE SCBLK PTR FOR XSCAN
22075: ZER XSOFS SET OFFSET TO ZERO
22076: BZE WA,XSCI2 JUMP IF NULL STRING
22077: EXI RETURN TO XSCNI CALLER
22078: *
22079: * HERE IF ARGUMENT IS NOT A STRING
22080: *
22081: XSCI1 EXI 1 TAKE NOT-STRING ERROR EXIT
22082: *
22083: * HERE FOR NULL STRING
22084: *
22085: XSCI2 EXI 2 TAKE NULL-STRING ERROR EXIT
22086: ENP END PROCEDURE XSCNI
22087: TTL S P I T B O L -- UTILITY ROUTINES
22088: *
22089: * THE FOLLOWING SECTION CONTAINS UTILITY ROUTINES USED FOR
22090: * VARIOUS PURPOSES THROUGHOUT THE SYSTEM. THESE DIFFER
22091: * FROM THE PROCEDURES IN THE UTILITY PROCEDURES SECTION IN
22092: * THEY ARE NOT IN PROCEDURE FORM AND THEY DO NOT RETURN
22093: * TO THEIR CALLERS. THEY ARE ACCESSED WITH A BRANCH TYPE
22094: * INSTRUCTION AFTER SETTING THE REGISTERS TO APPROPRIATE
22095: * PARAMETER VALUES.
22096: *
22097: * THE REGISTER VALUES REQUIRED FOR EACH ROUTINE ARE
22098: * DOCUMENTED AT THE START OF EACH ROUTINE. REGISTERS NOT
22099: * MENTIONED MAY CONTAIN ANY VALUES EXCEPT THAT XR,XL
22100: * CAN ONLY CONTAIN PROPER COLLECTABLE POINTERS.
22101: *
22102: * SOME OF THESE ROUTINES WILL TOLERATE GARBAGE POINTERS
22103: * IN XL,XR ON ENTRY. THIS IS ALWAYS DOCUMENTED AND IN
22104: * EACH CASE, THE ROUTINE CLEARS THESE GARBAGE VALUES BEFORE
22105: * EXITING AFTER COMPLETING ITS TASK.
22106: *
22107: * THE ROUTINES HAVE NAMES CONSISTING OF FIVE LETTERS
22108: * AND ARE ASSEMBLED IN ALPHABETICAL ORDER.
22109: EJC
22110: * ARREF -- ARRAY REFERENCE
22111: *
22112: * (XL) MAY BE NON-COLLECTABLE
22113: * (XR) NUMBER OF SUBSCRIPTS
22114: * (WB) SET ZERO/NONZERO FOR VALUE/NAME
22115: * THE VALUE IN WB MUST BE COLLECTABLE
22116: * STACK SUBSCRIPTS AND ARRAY OPERAND
22117: * BRN ARREF JUMP TO CALL FUNCTION
22118: *
22119: * ARREF CONTINUES BY EXECUTING THE NEXT CODE WORD WITH
22120: * THE RESULT NAME OR VALUE PLACED ON TOP OF THE STACK.
22121: * TO DEAL WITH THE PROBLEM OF ACCESSING SUBSCRIPTS IN THE
22122: * ORDER OF STACKING, XL IS USED AS A SUBSCRIPT POINTER
22123: * WORKING BELOW THE STACK POINTER.
22124: *
22125: ARREF RTN
22126: MOV XR,WA COPY NUMBER OF SUBSCRIPTS
22127: MOV XS,XT POINT TO STACK FRONT
22128: WTB XR CONVERT TO BYTE OFFSET
22129: ADD XR,XT POINT TO ARRAY OPERAND ON STACK
22130: ICA XT FINAL VALUE FOR STACK POPPING
22131: MOV XT,ARFXS KEEP FOR LATER
22132: MOV -(XT),XR LOAD ARRAY OPERAND POINTER
22133: MOV XR,R$ARF KEEP ARRAY POINTER
22134: MOV XT,XR SAVE POINTER TO SUBSCRIPTS
22135: MOV R$ARF,XL POINT XL TO POSSIBLE VCBLK OR TBBLK
22136: MOV (XL),WC LOAD FIRST WORD
22137: BEQ WC,=B$ART,ARF01 JUMP IF ARBLK
22138: BEQ WC,=B$VCT,ARF07 JUMP IF VCBLK
22139: BEQ WC,=B$TBT,ARF10 JUMP IF TBBLK
22140: ERB 235,SUBSCRIPTED OPERAND IS NOT TABLE OR ARRAY
22141: *
22142: * HERE FOR ARRAY (ARBLK)
22143: *
22144: ARF01 BNE WA,ARNDM(XL),ARF09 JUMP IF WRONG NUMBER OF DIMS
22145: LDI INTV0 GET INITIAL SUBSCRIPT OF ZERO
22146: MOV XR,XT POINT BEFORE SUBSCRIPTS
22147: ZER WA INITIAL OFFSET TO BOUNDS
22148: BRN ARF03 JUMP INTO LOOP
22149: *
22150: * LOOP TO COMPUTE SUBSCRIPTS BY MULTIPLICATIONS
22151: *
22152: ARF02 MLI ARDM2(XR) MULTIPLY TOTAL BY NEXT DIMENSION
22153: *
22154: * MERGE HERE FIRST TIME
22155: *
22156: ARF03 MOV -(XT),XR LOAD NEXT SUBSCRIPT
22157: STI ARFSI SAVE CURRENT SUBSCRIPT
22158: LDI ICVAL(XR) LOAD INTEGER VALUE IN CASE
22159: BEQ (XR),=B$ICL,ARF04 JUMP IF IT WAS AN INTEGER
22160: EJC
22161: *
22162: * ARREF (CONTINUED)
22163: *
22164: *
22165: JSR GTINT CONVERT TO INTEGER
22166: PPM ARF12 JUMP IF NOT INTEGER
22167: LDI ICVAL(XR) IF OK, LOAD INTEGER VALUE
22168: *
22169: * HERE WITH INTEGER SUBSCRIPT IN (IA)
22170: *
22171: ARF04 MOV R$ARF,XR POINT TO ARRAY
22172: ADD WA,XR OFFSET TO NEXT BOUNDS
22173: SBI ARLBD(XR) SUBTRACT LOW BOUND TO COMPARE
22174: IOV ARF13 OUT OF RANGE FAIL IF OVERFLOW
22175: ILT ARF13 OUT OF RANGE FAIL IF TOO SMALL
22176: SBI ARDIM(XR) SUBTRACT DIMENSION
22177: IGE ARF13 OUT OF RANGE FAIL IF TOO LARGE
22178: ADI ARDIM(XR) ELSE RESTORE SUBSCRIPT OFFSET
22179: ADI ARFSI ADD TO CURRENT TOTAL
22180: ADD *ARDMS,WA POINT TO NEXT BOUNDS
22181: BNE XT,XS,ARF02 LOOP BACK IF MORE TO GO
22182: *
22183: * HERE WITH INTEGER SUBSCRIPT COMPUTED
22184: *
22185: MFI WA GET AS ONE WORD INTEGER
22186: WTB WA CONVERT TO OFFSET
22187: MOV R$ARF,XL POINT TO ARBLK
22188: ADD AROFS(XL),WA ADD OFFSET PAST BOUNDS
22189: ICA WA ADJUST FOR ARPRO FIELD
22190: BNZ WB,ARF08 EXIT WITH NAME IF NAME CALL
22191: *
22192: * MERGE HERE TO GET VALUE FOR VALUE CALL
22193: *
22194: ARF05 JSR ACESS GET VALUE
22195: PPM ARF13 FAIL IF ACESS FAILS
22196: *
22197: * RETURN VALUE
22198: *
22199: ARF06 MOV ARFXS,XS POP STACK ENTRIES
22200: ZER R$ARF FINISHED WITH ARRAY POINTER
22201: BRN EXIXR EXIT WITH VALUE IN XR
22202: EJC
22203: *
22204: * ARREF (CONTINUED)
22205: *
22206: * HERE FOR VECTOR
22207: *
22208: ARF07 BNE WA,=NUM01,ARF09 ERROR IF MORE THAN 1 SUBSCRIPT
22209: MOV (XS),XR ELSE LOAD SUBSCRIPT
22210: JSR GTINT CONVERT TO INTEGER
22211: PPM ARF12 ERROR IF NOT INTEGER
22212: LDI ICVAL(XR) ELSE LOAD INTEGER VALUE
22213: SBI INTV1 SUBTRACT FOR ONES OFFSET
22214: MFI WA,ARF13 GET SUBSCRIPT AS ONE WORD
22215: ADD =VCVLS,WA ADD OFFSET FOR STANDARD FIELDS
22216: WTB WA CONVERT OFFSET TO BYTES
22217: BGE WA,VCLEN(XL),ARF13 FAIL IF OUT OF RANGE SUBSCRIPT
22218: BZE WB,ARF05 BACK TO GET VALUE IF VALUE CALL
22219: *
22220: * RETURN NAME
22221: *
22222: ARF08 MOV ARFXS,XS POP STACK ENTRIES
22223: ZER R$ARF FINISHED WITH ARRAY POINTER
22224: BRN EXNAM ELSE EXIT WITH NAME
22225: *
22226: * HERE IF SUBSCRIPT COUNT IS WRONG
22227: *
22228: ARF09 ERB 236,ARRAY REFERENCED WITH WRONG NUMBER OF SUBSCRIPTS
22229: *
22230: * TABLE
22231: *
22232: ARF10 BNE WA,=NUM01,ARF11 ERROR IF MORE THAN 1 SUBSCRIPT
22233: MOV (XS),XR ELSE LOAD SUBSCRIPT
22234: JSR TFIND CALL TABLE SEARCH ROUTINE
22235: PPM ARF13 FAIL IF FAILED
22236: BNZ WB,ARF08 EXIT WITH NAME IF NAME CALL
22237: BRN ARF06 ELSE EXIT WITH VALUE
22238: *
22239: * HERE FOR BAD TABLE REFERENCE
22240: *
22241: ARF11 ERB 237,TABLE REFERENCED WITH MORE THAN ONE SUBSCRIPT
22242: *
22243: * HERE FOR BAD SUBSCRIPT
22244: *
22245: ARF12 ERB 238,ARRAY SUBSCRIPT IS NOT INTEGER
22246: *
22247: * HERE TO SIGNAL FAILURE
22248: *
22249: ARF13 ZER R$ARF FINISHED WITH ARRAY POINTER
22250: BRN EXFAL FAIL
22251: EJC
22252: *
22253: * CFUNC -- CALL A FUNCTION
22254: *
22255: * CFUNC IS USED TO CALL A SNOBOL LEVEL FUNCTION. IT IS
22256: * USED BY THE APPLY FUNCTION (S$APP), THE FUNCTION
22257: * TRACE ROUTINE (TRXEQ) AND THE MAIN FUNCTION CALL ENTRY
22258: * (O$FNC, O$FNS). IN THE LATTER CASES, CFUNC IS USED ONLY
22259: * IF THE NUMBER OF ARGUMENTS IS INCORRECT.
22260: *
22261: * (XL) POINTER TO FUNCTION BLOCK
22262: * (WA) ACTUAL NUMBER OF ARGUMENTS
22263: * (XS) POINTS TO STACKED ARGUMENTS
22264: * BRN CFUNC JUMP TO CALL FUNCTION
22265: *
22266: * CFUNC CONTINUES BY EXECUTING THE FUNCTION
22267: *
22268: CFUNC RTN
22269: BLT WA,FARGS(XL),CFNC1 JUMP IF TOO FEW ARGUMENTS
22270: BEQ WA,FARGS(XL),CFNC3 JUMP IF CORRECT NUMBER OF ARGS
22271: *
22272: * HERE IF TOO MANY ARGUMENTS SUPPLIED, POP THEM OFF
22273: *
22274: MOV WA,WB COPY ACTUAL NUMBER
22275: SUB FARGS(XL),WB GET NUMBER OF EXTRA ARGS
22276: WTB WB CONVERT TO BYTES
22277: ADD WB,XS POP OFF UNWANTED ARGUMENTS
22278: BRN CFNC3 JUMP TO GO OFF TO FUNCTION
22279: *
22280: * HERE IF TOO FEW ARGUMENTS
22281: *
22282: CFNC1 MOV FARGS(XL),WB LOAD REQUIRED NUMBER OF ARGUMENTS
22283: BEQ WB,=NINI9,CFNC3 JUMP IF CASE OF VAR NUM OF ARGS
22284: SUB WA,WB CALCULATE NUMBER MISSING
22285: LCT WB,WB SET COUNTER TO CONTROL LOOP
22286: *
22287: * LOOP TO SUPPLY EXTRA NULL ARGUMENTS
22288: *
22289: CFNC2 MOV =NULLS,-(XS) STACK A NULL ARGUMENT
22290: BCT WB,CFNC2 LOOP TILL PROPER NUMBER STACKED
22291: *
22292: * MERGE HERE TO JUMP TO FUNCTION
22293: *
22294: CFNC3 BRI (XL) JUMP THROUGH FCODE FIELD
22295: EJC
22296: *
22297: * EXFAL -- EXIT SIGNALLING SNOBOL FAILURE
22298: *
22299: * (XL,XR) MAY BE NON-COLLECTABLE
22300: * BRN EXFAL JUMP TO FAIL
22301: *
22302: * EXFAL CONTINUES BY EXECUTING THE APPROPRIATE FAIL GOTO
22303: *
22304: EXFAL RTN
22305: MOV FLPTR,XS POP STACK
22306: MOV (XS),XR LOAD FAILURE OFFSET
22307: ADD R$COD,XR POINT TO FAILURE CODE LOCATION
22308: LCP XR SET CODE POINTER
22309: BRN EXITS DO NEXT CODE WORD
22310: EJC
22311: *
22312: * EXINT -- EXIT WITH INTEGER RESULT
22313: *
22314: * (XL,XR) MAY BE NONCOLLECTABLE
22315: * (IA) INTEGER VALUE
22316: * BRN EXINT JUMP TO EXIT WITH INTEGER
22317: *
22318: * EXINT CONTINUES BY EXECUTING THE NEXT CODE WORD
22319: * WHICH IT DOES BY FALLING THROUGH TO EXIXR
22320: *
22321: EXINT RTN
22322: JSR ICBLD BUILD ICBLK
22323: EJC
22324: * EXIXR -- EXIT WITH RESULT IN (XR)
22325: *
22326: * (XR) RESULT
22327: * (XL) MAY BE NON-COLLECTABLE
22328: * BRN EXIXR JUMP TO EXIT WITH RESULT IN (XR)
22329: *
22330: * EXIXR CONTINUES BY EXECUTING THE NEXT CODE WORD
22331: * WHICH IT DOES BY FALLING THROUGH TO EXITS.
22332: EXIXR RTN
22333: *
22334: MOV XR,-(XS) STACK RESULT
22335: *
22336: *
22337: * EXITS -- EXIT WITH RESULT IF ANY STACKED
22338: *
22339: * (XR,XL) MAY BE NON-COLLECTABLE
22340: *
22341: * BRN EXITS ENTER EXITS ROUTINE
22342: *
22343: EXITS RTN
22344: LCW XR LOAD NEXT CODE WORD
22345: MOV (XR),XL LOAD ENTRY ADDRESS
22346: BRI XL JUMP TO EXECUTE NEXT CODE WORD
22347: EJC
22348: *
22349: * EXNAM -- EXIT WITH NAME IN (XL,WA)
22350: *
22351: * (XL) NAME BASE
22352: * (WA) NAME OFFSET
22353: * (XR) MAY BE NON-COLLECTABLE
22354: * BRN EXNAM JUMP TO EXIT WITH NAME IN (XL,WA)
22355: *
22356: * EXNAM CONTINUES BY EXECUTING THE NEXT CODE WORD
22357: *
22358: EXNAM RTN
22359: MOV XL,-(XS) STACK NAME BASE
22360: MOV WA,-(XS) STACK NAME OFFSET
22361: BRN EXITS DO NEXT CODE WORD
22362: EJC
22363: *
22364: * EXNUL -- EXIT WITH NULL RESULT
22365: *
22366: * (XL,XR) MAY BE NON-COLLECTABLE
22367: * BRN EXNUL JUMP TO EXIT WITH NULL VALUE
22368: *
22369: * EXNUL CONTINUES BY EXECUTING THE NEXT CODE WORD
22370: *
22371: EXNUL RTN
22372: MOV =NULLS,-(XS) STACK NULL VALUE
22373: BRN EXITS DO NEXT CODE WORD
22374: EJC
22375: *
22376: * EXREA -- EXIT WITH REAL RESULT
22377: *
22378: * (XL,XR) MAY BE NON-COLLECTABLE
22379: * (RA) REAL VALUE
22380: * BRN EXREA JUMP TO EXIT WITH REAL VALUE
22381: *
22382: * EXREA CONTINUES BY EXECUTING THE NEXT CODE WORD
22383: *
22384: EXREA RTN
22385: JSR RCBLD BUILD RCBLK
22386: BRN EXIXR JUMP TO EXIT WITH RESULT IN XR
22387: EJC
22388: *
22389: * EXSID -- EXIT SETTING ID FIELD
22390: *
22391: * EXSID IS USED TO EXIT AFTER BUILDING ANY OF THE FOLLOWING
22392: * BLOCKS (ARBLK, TBBLK, PDBLK, VCBLK). IT SETS THE IDVAL.
22393: *
22394: * (XR) PTR TO BLOCK WITH IDVAL FIELD
22395: * (XL) MAY BE NON-COLLECTABLE
22396: * BRN EXSID JUMP TO EXIT AFTER SETTING ID FIELD
22397: *
22398: * EXSID CONTINUES BY EXECUTING THE NEXT CODE WORD
22399: *
22400: EXSID RTN
22401: MOV CURID,WA LOAD CURRENT ID VALUE
22402: BNE WA,=CFP$M,EXSI1 JUMP IF NO OVERFLOW
22403: ZER WA ELSE RESET FOR WRAPAROUND
22404: *
22405: * HERE WITH OLD IDVAL IN WA
22406: *
22407: EXSI1 ICV WA BUMP ID VALUE
22408: MOV WA,CURID STORE FOR NEXT TIME
22409: MOV WA,IDVAL(XR) STORE ID VALUE
22410: BRN EXIXR EXIT WITH RESULT IN (XR)
22411: EJC
22412: *
22413: * EXVNM -- EXIT WITH NAME OF VARIABLE
22414: *
22415: * EXVNM EXITS AFTER STACKING A VALUE WHICH IS A NMBLK
22416: * REFERENCING THE NAME OF A GIVEN NATURAL VARIABLE.
22417: *
22418: * (XR) VRBLK POINTER
22419: * (XL) MAY BE NON-COLLECTABLE
22420: * BRN EXVNM EXIT WITH VRBLK POINTER IN XR
22421: *
22422: EXVNM RTN
22423: MOV XR,XL COPY NAME BASE POINTER
22424: MOV *NMSI$,WA SET SIZE OF NMBLK
22425: JSR ALLOC ALLOCATE NMBLK
22426: MOV =B$NML,(XR) STORE TYPE WORD
22427: MOV XL,NMBAS(XR) STORE NAME BASE
22428: MOV *VRVAL,NMOFS(XR) STORE NAME OFFSET
22429: BRN EXIXR EXIT WITH RESULT IN XR
22430: EJC
22431: *
22432: * FLPOP -- FAIL AND POP IN PATTERN MATCHING
22433: *
22434: * FLPOP POPS THE NODE AND CURSOR ON THE STACK AND THEN
22435: * DROPS THROUGH INTO FAILP TO CAUSE PATTERN FAILURE
22436: *
22437: * (XL,XR) MAY BE NON-COLLECTABLE
22438: * BRN FLPOP JUMP TO FAIL AND POP STACK
22439: *
22440: FLPOP RTN
22441: ADD *NUM02,XS POP TWO ENTRIES OFF STACK
22442: EJC
22443: *
22444: * FAILP -- FAILURE IN MATCHING PATTERN NODE
22445: *
22446: * FAILP IS USED AFTER FAILING TO MATCH A PATTERN NODE.
22447: * SEE PATTERN MATCH ROUTINES FOR DETAILS OF USE.
22448: *
22449: * (XL,XR) MAY BE NON-COLLECTABLE
22450: * BRN FAILP SIGNAL FAILURE TO MATCH
22451: *
22452: * FAILP CONTINUES BY MATCHING AN ALTERNATIVE FROM THE STACK
22453: *
22454: FAILP RTN
22455: MOV (XS)+,XR LOAD ALTERNATIVE NODE POINTER
22456: MOV (XS)+,WB RESTORE OLD CURSOR
22457: MOV (XR),XL LOAD PCODE ENTRY POINTER
22458: BRI XL JUMP TO EXECUTE CODE FOR NODE
22459: EJC
22460: *
22461: * INDIR -- COMPUTE INDIRECT REFERENCE
22462: *
22463: * (WB) NONZERO/ZERO FOR BY NAME/VALUE
22464: * BRN INDIR JUMP TO GET INDIRECT REF ON STACK
22465: *
22466: * INDIR CONTINUES BY EXECUTING THE NEXT CODE WORD
22467: *
22468: INDIR RTN
22469: MOV (XS)+,XR LOAD ARGUMENT
22470: BEQ (XR),=B$NML,INDR2 JUMP IF A NAME
22471: JSR GTNVR ELSE CONVERT TO VARIABLE
22472: ERR 239,INDIRECTION OPERAND IS NOT NAME
22473: BZE WB,INDR1 SKIP IF BY VALUE
22474: MOV XR,-(XS) ELSE STACK VRBLK PTR
22475: MOV *VRVAL,-(XS) STACK NAME OFFSET
22476: BRN EXITS EXIT WITH RESULT ON STACK
22477: *
22478: * HERE TO GET VALUE OF NATURAL VARIABLE
22479: *
22480: INDR1 BRI (XR) JUMP THROUGH VRGET FIELD OF VRBLK
22481: *
22482: * HERE IF OPERAND IS A NAME
22483: *
22484: INDR2 MOV NMBAS(XR),XL LOAD NAME BASE
22485: MOV NMOFS(XR),WA LOAD NAME OFFSET
22486: BNZ WB,EXNAM EXIT IF CALLED BY NAME
22487: JSR ACESS ELSE GET VALUE FIRST
22488: PPM EXFAL FAIL IF ACCESS FAILS
22489: BRN EXIXR ELSE RETURN WITH VALUE IN XR
22490: EJC
22491: *
22492: * MATCH -- INITIATE PATTERN MATCH
22493: *
22494: * (WB) MATCH TYPE CODE
22495: * BRN MATCH JUMP TO INITIATE PATTERN MATCH
22496: *
22497: * MATCH CONTINUES BY EXECUTING THE PATTERN MATCH. SEE
22498: * PATTERN MATCH ROUTINES (P$XXX) FOR FULL DETAILS.
22499: *
22500: MATCH RTN
22501: MOV (XS)+,XR LOAD PATTERN OPERAND
22502: JSR GTPAT CONVERT TO PATTERN
22503: ERR 240,PATTERN MATCH RIGHT OPERAND IS NOT PATTERN
22504: MOV XR,XL IF OK, SAVE PATTERN POINTER
22505: BNZ WB,MTCH1 JUMP IF NOT MATCH BY NAME
22506: MOV (XS),WA ELSE LOAD NAME OFFSET
22507: MOV XL,-(XS) SAVE PATTERN POINTER
22508: MOV 2(XS),XL LOAD NAME BASE
22509: JSR ACESS ACCESS SUBJECT VALUE
22510: PPM EXFAL FAIL IF ACCESS FAILS
22511: MOV (XS),XL RESTORE PATTERN POINTER
22512: MOV XR,(XS) STACK SUBJECT STRING VAL FOR MERGE
22513: ZER WB RESTORE TYPE CODE
22514: *
22515: * MERGE HERE WITH SUBJECT VALUE ON STACK
22516: *
22517: MTCH1 MOV (XS),XR LOAD SUBJECT VALUE
22518: ZER R$PMB ASSUME NOT A BUFFER
22519: BNE (XR),=B$BCT,MTCHA BRANCH IF NOT
22520: ICA XS ELSE POP VALUE
22521: MOV XR,R$PMB SAVE POINTER
22522: MOV BCLEN(XR),WA GET DEFINED LENGTH
22523: MOV BCBUF(XR),XR POINT TO BFBLK
22524: BRN MTCHB
22525: *
22526: * HERE IF NOT BUFFER TO CONVERT TO STRING
22527: *
22528: MTCHA JSR GTSTG NOT BUFFER - CONVERT TO STRING
22529: ERR 241,PATTERN MATCH LEFT OPERAND IS NOT STRING
22530: *
22531: * MERGE WITH BUFFER OR STRING
22532: *
22533: MTCHB MOV XR,R$PMS IF OK, STORE SUBJECT STRING POINTER
22534: MOV WA,PMSSL AND LENGTH
22535: MOV WB,-(XS) STACK MATCH TYPE CODE
22536: ZER -(XS) STACK INITIAL CURSOR (ZERO)
22537: ZER WB SET INITIAL CURSOR
22538: MOV XS,PMHBS SET HISTORY STACK BASE PTR
22539: ZER PMDFL RESET PATTERN ASSIGNMENT FLAG
22540: MOV XL,XR SET INITIAL NODE POINTER
22541: BNZ KVANC,MTCH2 JUMP IF ANCHORED
22542: *
22543: * HERE FOR UNANCHORED
22544: *
22545: MOV XR,-(XS) STACK INITIAL NODE POINTER
22546: MOV =NDUNA,-(XS) STACK POINTER TO ANCHOR MOVE NODE
22547: BRI (XR) START MATCH OF FIRST NODE
22548: *
22549: * HERE IN ANCHORED MODE
22550: *
22551: MTCH2 ZER -(XS) DUMMY CURSOR VALUE
22552: MOV =NDABO,-(XS) STACK POINTER TO ABORT NODE
22553: BRI (XR) START MATCH OF FIRST NODE
22554: EJC
22555: *
22556: * RETRN -- RETURN FROM FUNCTION
22557: *
22558: * (WA) STRING POINTER FOR RETURN TYPE
22559: * BRN RETRN JUMP TO RETURN FROM (SNOBOL) FUNC
22560: *
22561: * RETRN CONTINUES BY EXECUTING THE CODE AT THE RETURN POINT
22562: * THE STACK IS CLEANED OF ANY GARBAGE LEFT BY OTHER
22563: * ROUTINES WHICH MAY HAVE ALTERED FLPTR SINCE FUNCTION
22564: * ENTRY BY USING FLPRT, RESERVED FOR USE ONLY BY
22565: * FUNCTION CALL AND RETURN.
22566: *
22567: RETRN RTN
22568: BNZ KVFNC,RTN01 JUMP IF NOT LEVEL ZERO
22569: ERB 242,FUNCTION RETURN FROM LEVEL ZERO
22570: *
22571: * HERE IF NOT LEVEL ZERO RETURN
22572: *
22573: RTN01 MOV FLPRT,XS POP STACK
22574: ICA XS REMOVE FAILURE OFFSET
22575: MOV (XS)+,XR POP PFBLK POINTER
22576: MOV (XS)+,FLPTR POP FAILURE POINTER
22577: MOV (XS)+,FLPRT POP OLD FLPRT
22578: MOV (XS)+,WB POP CODE POINTER OFFSET
22579: MOV (XS)+,WC POP OLD CODE BLOCK POINTER
22580: ADD WC,WB MAKE OLD CODE POINTER ABSOLUTE
22581: LCP WB RESTORE OLD CODE POINTER
22582: MOV WC,R$COD RESTORE OLD CODE BLOCK POINTER
22583: DCV KVFNC DECREMENT FUNCTION LEVEL
22584: MOV KVTRA,WB LOAD TRACE
22585: ADD KVFTR,WB ADD FTRACE
22586: BZE WB,RTN06 JUMP IF NO TRACING POSSIBLE
22587: *
22588: * HERE IF THERE MAY BE A TRACE
22589: *
22590: MOV WA,-(XS) SAVE FUNCTION RETURN TYPE
22591: MOV XR,-(XS) SAVE PFBLK POINTER
22592: MOV WA,KVRTN SET RTNTYPE FOR TRACE FUNCTION
22593: MOV R$FNC,XL LOAD FNCLEVEL TRBLK PTR (IF ANY)
22594: JSR KTREX EXECUTE POSSIBLE FNCLEVEL TRACE
22595: MOV PFVBL(XR),XL LOAD VRBLK PTR (SGD13)
22596: BZE KVTRA,RTN02 JUMP IF TRACE IS OFF
22597: MOV PFRTR(XR),XR ELSE LOAD RETURN TRACE TRBLK PTR
22598: BZE XR,RTN02 JUMP IF NOT RETURN TRACED
22599: DCV KVTRA ELSE DECREMENT TRACE COUNT
22600: BZE TRFNC(XR),RTN03 JUMP IF PRINT TRACE
22601: MOV *VRVAL,WA ELSE SET NAME OFFSET
22602: MOV 1(XS),KVRTN MAKE SURE RTNTYPE IS SET RIGHT
22603: JSR TRXEQ EXECUTE FULL TRACE
22604: EJC
22605: *
22606: * RETRN (CONTINUED)
22607: *
22608: * HERE TO TEST FOR FTRACE
22609: *
22610: RTN02 BZE KVFTR,RTN05 JUMP IF FTRACE IS OFF
22611: DCV KVFTR ELSE DECREMENT FTRACE
22612: *
22613: * HERE FOR PRINT TRACE OF FUNCTION RETURN
22614: *
22615: RTN03 JSR PRTSN PRINT STATEMENT NUMBER
22616: MOV 1(XS),XR LOAD RETURN TYPE
22617: JSR PRTST PRINT IT
22618: MOV =CH$BL,WA LOAD BLANK
22619: JSR PRTCH PRINT IT
22620: MOV 0(XS),XL LOAD PFBLK PTR
22621: MOV PFVBL(XL),XL LOAD FUNCTION VRBLK PTR
22622: MOV *VRVAL,WA SET VRBLK NAME OFFSET
22623: BNE XR,=SCFRT,RTN04 JUMP IF NOT FRETURN CASE
22624: *
22625: * FOR FRETURN, JUST PRINT FUNCTION NAME
22626: *
22627: JSR PRTNM PRINT NAME
22628: JSR PRTNL TERMINATE PRINT LINE
22629: BRN RTN05 MERGE
22630: *
22631: * HERE FOR RETURN OR NRETURN, PRINT FUNCTION NAME = VALUE
22632: *
22633: RTN04 JSR PRTNV PRINT NAME = VALUE
22634: *
22635: * HERE AFTER COMPLETING TRACE
22636: *
22637: RTN05 MOV (XS)+,XR POP PFBLK POINTER
22638: MOV (XS)+,WA POP RETURN TYPE STRING
22639: *
22640: * MERGE HERE IF NO TRACE REQUIRED
22641: *
22642: RTN06 MOV WA,KVRTN SET RTNTYPE KEYWORD
22643: MOV PFVBL(XR),XL LOAD POINTER TO FN VRBLK
22644: EJC
22645: * RETRN (CONTINUED)
22646: *
22647: * GET VALUE OF FUNCTION
22648: *
22649: RTN07 MOV XL,RTNBP SAVE BLOCK POINTER
22650: MOV VRVAL(XL),XL LOAD VALUE
22651: BEQ (XL),=B$TRT,RTN07 LOOP BACK IF TRAPPED
22652: MOV XL,RTNFV ELSE SAVE FUNCTION RESULT VALUE
22653: MOV (XS)+,RTNSV SAVE ORIGINAL FUNCTION VALUE
22654: MOV (XS)+,XL POP SAVED POINTER
22655: BZE XL,RTN7C NO ACTION IF NONE
22656: BZE KVPFL,RTN7C JUMP IF NO PROFILING
22657: JSR PRFLU ELSE PROFILE LAST FUNC STMT
22658: BEQ KVPFL,=NUM02,RTN7A BRANCH ON VALUE OF PROFILE KEYWD
22659: *
22660: * HERE IF &PROFILE = 1. START TIME MUST BE FRIGGED TO
22661: * APPEAR EARLIER THAN IT ACTUALLY IS, BY AMOUNT USED BEFORE
22662: * THE CALL.
22663: *
22664: LDI PFSTM LOAD CURRENT TIME
22665: SBI ICVAL(XL) FRIG BY SUBTRACTING SAVED AMOUNT
22666: BRN RTN7B AND MERGE
22667: *
22668: * HERE IF &PROFILE = 2
22669: *
22670: RTN7A LDI ICVAL(XL) LOAD SAVED TIME
22671: *
22672: * BOTH PROFILE TYPES MERGE HERE
22673: *
22674: RTN7B STI PFSTM STORE BACK CORRECT START TIME
22675: *
22676: * MERGE HERE IF NO PROFILING
22677: *
22678: RTN7C MOV FARGS(XR),WB GET NUMBER OF ARGS
22679: ADD PFNLO(XR),WB ADD NUMBER OF LOCALS
22680: BZE WB,RTN10 JUMP IF NO ARGS/LOCALS
22681: LCT WB,WB ELSE SET LOOP COUNTER
22682: ADD PFLEN(XR),XR AND POINT TO END OF PFBLK
22683: *
22684: * LOOP TO RESTORE FUNCTIONS AND LOCALS
22685: *
22686: RTN08 MOV -(XR),XL LOAD NEXT VRBLK POINTER
22687: *
22688: * LOOP TO FIND VALUE BLOCK
22689: *
22690: RTN09 MOV XL,WA SAVE BLOCK POINTER
22691: MOV VRVAL(XL),XL LOAD POINTER TO NEXT VALUE
22692: BEQ (XL),=B$TRT,RTN09 LOOP BACK IF TRAPPED
22693: MOV WA,XL ELSE RESTORE LAST BLOCK POINTER
22694: MOV (XS)+,VRVAL(XL) RESTORE OLD VARIABLE VALUE
22695: BCT WB,RTN08 LOOP TILL ALL PROCESSED
22696: *
22697: * NOW RESTORE FUNCTION VALUE AND EXIT
22698: *
22699: RTN10 MOV RTNBP,XL RESTORE PTR TO LAST FUNCTION BLOCK
22700: MOV RTNSV,VRVAL(XL) RESTORE OLD FUNCTION VALUE
22701: MOV RTNFV,XR RELOAD FUNCTION RESULT
22702: MOV R$COD,XL POINT TO NEW CODE BLOCK
22703: MOV KVSTN,KVLST SET LASTNO FROM STNO
22704: MOV CDSTM(XL),KVSTN RESET PROPER STNO VALUE
22705: MOV KVRTN,WA LOAD RETURN TYPE
22706: BEQ WA,=SCRTN,EXIXR EXIT WITH RESULT IN XR IF RETURN
22707: BEQ WA,=SCFRT,EXFAL FAIL IF FRETURN
22708: EJC
22709: *
22710: * RETRN (CONTINUED)
22711: *
22712: * HERE FOR NRETURN
22713: *
22714: BEQ (XR),=B$NML,RTN11 JUMP IF IS A NAME
22715: JSR GTNVR ELSE TRY CONVERT TO VARIABLE NAME
22716: ERR 243,FUNCTION RESULT IN NRETURN IS NOT NAME
22717: MOV XR,XL IF OK, COPY VRBLK (NAME BASE) PTR
22718: MOV *VRVAL,WA SET NAME OFFSET
22719: BRN RTN12 AND MERGE
22720: *
22721: * HERE IF RETURNED RESULT IS A NAME
22722: *
22723: RTN11 MOV NMBAS(XR),XL LOAD NAME BASE
22724: MOV NMOFS(XR),WA LOAD NAME OFFSET
22725: *
22726: * MERGE HERE WITH RETURNED NAME IN (XL,WA)
22727: *
22728: RTN12 MOV XL,XR PRESERVE XL
22729: LCW WB LOAD NEXT WORD
22730: MOV XR,XL RESTORE XL
22731: BEQ WB,=OFNE$,EXNAM EXIT IF CALLED BY NAME
22732: MOV WB,-(XS) ELSE SAVE CODE WORD
22733: JSR ACESS GET VALUE
22734: PPM EXFAL FAIL IF ACCESS FAILS
22735: MOV XR,XL IF OK, COPY RESULT
22736: MOV (XS),XR RELOAD NEXT CODE WORD
22737: MOV XL,(XS) STORE RESULT ON STACK
22738: MOV (XR),XL LOAD ROUTINE ADDRESS
22739: BRI XL JUMP TO EXECUTE NEXT CODE WORD
22740: EJC
22741: *
22742: * STCOV -- SIGNAL STATEMENT COUNTER OVERFLOW
22743: *
22744: * BRN STCOV JUMP TO SIGNAL STATEMENT COUNT OFLO
22745: *
22746: * PERMIT UP TO 10 MORE STATEMENTS TO BE OBEYED SO THAT
22747: * SETEXIT TRAP CAN REGAIN CONTROL.
22748: * STCOV CONTINUES BY ISSUING THE ERROR MESSAGE
22749: *
22750: STCOV RTN
22751: ICV ERRFT FATAL ERROR
22752: LDI INTVT GET 10
22753: ADI KVSTL ADD TO FORMER LIMIT
22754: STI KVSTL STORE AS NEW STLIMIT
22755: LDI INTVT GET 10
22756: STI KVSTC SET AS NEW COUNT
22757: ERB 244,STATEMENT COUNT EXCEEDS VALUE OF STLIMIT KEYWORD
22758: EJC
22759: *
22760: * STMGO -- START EXECUTION OF NEW STATEMENT
22761: *
22762: * (XR) POINTER TO CDBLK FOR NEW STATEMENT
22763: * BRN STMGO JUMP TO EXECUTE NEW STATEMENT
22764: *
22765: * STMGO CONTINUES BY EXECUTING THE NEXT STATEMENT
22766: *
22767: STMGO RTN
22768: MOV XR,R$COD SET NEW CODE BLOCK POINTER
22769: BZE KVPFL,STGO1 SKIP IF NO PROFILING
22770: JSR PRFLU ELSE PROFILE THE STATEMENT
22771: STGO1 MOV KVSTN,KVLST SET LASTNO
22772: MOV CDSTM(XR),KVSTN SET STNO
22773: ADD *CDCOD,XR POINT TO FIRST CODE WORD
22774: LCP XR SET CODE POINTER
22775: LDI KVSTC GET STMT COUNT
22776: ILT EXITS OMIT COUNTING IF NEGATIVE
22777: IEQ STCOV FAIL IF STLIMIT REACHED
22778: SBI INTV1 DECREMENT
22779: STI KVSTC REPLACE IT
22780: BZE R$STC,EXITS EXIT IF NO STCOUNT TRACE
22781: *
22782: * HERE FOR STCOUNT TRACE
22783: *
22784: ZER XR CLEAR GARBAGE VALUE IN XR
22785: MOV R$STC,XL LOAD POINTER TO STCOUNT TRBLK
22786: JSR KTREX EXECUTE KEYWORD TRACE
22787: BRN EXITS AND THEN EXIT FOR NEXT CODE WORD
22788: EJC
22789: *
22790: * STOPR -- TERMINATE RUN
22791: *
22792: * (XR) POINTS TO ENDING MESSAGE
22793: * BRN STOPR JUMP TO TERMINATE RUN
22794: *
22795: * TERMINATE RUN AND PRINT STATISTICS. ON ENTRY XR POINTS
22796: * TO ENDING MESSAGE OR IS ZERO IF MESSAGE PRINTED ALREADY.
22797: *
22798: STOPR RTN
22799: BZE XR,STPRA SKIP IF SYSAX ALREADY CALLED (REG04)
22800: JSR SYSAX CALL AFTER EXECUTION PROC
22801: STPRA ADD RSMEM,DNAME USE THE RESERVE MEMORY
22802: BNE XR,=ENDMS,STPR0 SKIP IF NOT NORMAL END MESSAGE
22803: BNZ EXSTS,STPR3 SKIP IF EXEC STATS SUPPRESSED
22804: ZER ERICH CLEAR ERRORS TO INT.CH. FLAG
22805: *
22806: * LOOK TO SEE IF AN ENDING MESSAGE IS SUPPLIED
22807: *
22808: STPR0 JSR PRTPG EJECT PRINTER
22809: BZE XR,STPR1 SKIP IF NO MESSAGE
22810: JSR PRTST PRINT MESSAGE
22811: *
22812: * MERGE HERE IF NO MESSAGE TO PRINT
22813: *
22814: STPR1 JSR PRTIS PRINT BLANK LINE
22815: MTI KVSTN GET STATEMENT NUMBER
22816: MOV =STPM1,XR POINT TO MESSAGE /IN STATEMENT XXX/
22817: JSR PRTMX PRINT IT
22818: JSR SYSTM GET CURRENT TIME
22819: SBI TIMSX MINUS START TIME = ELAPSED EXEC TIM
22820: STI STPTI SAVE FOR LATER
22821: MOV =STPM3,XR POINT TO MSG /EXECUTION TIME MSEC /
22822: JSR PRTMX PRINT IT
22823: LDI KVSTL GET STATEMENT LIMIT
22824: ILT STPR2 SKIP IF NEGATIVE
22825: SBI KVSTC MINUS COUNTER = COUNT
22826: STI STPSI SAVE
22827: MOV =STPM2,XR POINT TO MESSAGE /STMTS EXECUTED/
22828: JSR PRTMX PRINT IT
22829: LDI STPTI RELOAD ELAPSED TIME
22830: MLI INTTH *1000 (MICROSECS)
22831: IOV STPR2 JUMP IF WE CANNOT COMPUTE
22832: DVI STPSI DIVIDE BY STATEMENT COUNT
22833: IOV STPR2 JUMP IF OVERFLOW
22834: MOV =STPM4,XR POINT TO MSG (MCSEC PER STATEMENT /
22835: JSR PRTMX PRINT IT
22836: EJC
22837: *
22838: * STOPR (CONTINUED)
22839: *
22840: * MERGE TO SKIP MESSAGE (OVERFLOW OR NEGATIVE STLIMIT)
22841: *
22842: STPR2 MTI GBCNT LOAD COUNT OF COLLECTIONS
22843: MOV =STPM5,XR POINT TO MESSAGE /REGENERATIONS /
22844: JSR PRTMX PRINT IT
22845: JSR PRTIS ONE MORE BLANK FOR LUCK
22846: *
22847: * CHECK IF DUMP REQUESTED
22848: *
22849: STPR3 JSR PRFLR PRINT PROFILE IF WANTED
22850: *
22851: MOV KVDMP,XR LOAD DUMP KEYWORD
22852: JSR DUMPR EXECUTE DUMP IF REQUESTED
22853: MOV R$FCB,XL GET FCBLK CHAIN HEAD
22854: MOV KVABE,WA LOAD ABEND VALUE
22855: MOV KVCOD,WB LOAD CODE VALUE
22856: JSR SYSEJ EXIT TO SYSTEM
22857: EJC
22858: *
22859: * SUCCP -- SIGNAL SUCCESSFUL MATCH OF A PATTERN NODE
22860: *
22861: * SEE PATTERN MATCH ROUTINES FOR DETAILS
22862: *
22863: * (XR) CURRENT NODE
22864: * (WB) CURRENT CURSOR
22865: * (XL) MAY BE NON-COLLECTABLE
22866: * BRN SUCCP SIGNAL SUCCESSFUL PATTERN MATCH
22867: *
22868: * SUCCP CONTINUES BY MATCHING THE SUCCESSOR NODE
22869: *
22870: SUCCP RTN
22871: MOV PTHEN(XR),XR LOAD SUCCESSOR NODE
22872: MOV (XR),XL LOAD NODE CODE ENTRY ADDRESS
22873: BRI XL JUMP TO MATCH SUCCESSOR NODE
22874: EJC
22875: *
22876: * SYSAB -- PRINT /ABNORMAL END/ AND TERMINATE
22877: *
22878: SYSAB RTN
22879: MOV =ENDAB,XR POINT TO MESSAGE
22880: MOV =NUM01,KVABE SET ABEND FLAG
22881: JSR PRTNL SKIP TO NEW LINE
22882: BRN STOPR JUMP TO PACK UP
22883: EJC
22884: *
22885: * SYSTU -- PRINT /TIME UP/ AND TERMINATE
22886: *
22887: SYSTU RTN
22888: MOV =ENDTU,XR POINT TO MESSAGE
22889: MOV STRTU,WA GET CHARS /TU/
22890: MOV WA,KVCOD PUT IN KVCOD
22891: MOV TIMUP,WA CHECK STATE OF TIMEUP SWITCH
22892: MNZ TIMUP SET SWITCH
22893: BNZ WA,STOPR STOP RUN IF ALREADY SET
22894: ERB 245,TRANSLATION/EXECUTION TIME EXPIRED
22895: TTL S P I T B O L -- STACK OVERFLOW SECTION
22896: *
22897: * CONTROL COMES HERE IF THE MAIN STACK OVERFLOWS
22898: *
22899: SEC START OF STACK OVERFLOW SECTION
22900: *
22901: ICV ERRFT FATAL ERROR
22902: MOV FLPTR,XS POP STACK TO AVOID MORE FAILS
22903: BNZ GBCFL,STAK1 JUMP IF GARBAGE COLLECTING
22904: ERB 246,STACK OVERFLOW
22905: *
22906: * NO CHANCE OF RECOVERY IN MID GARBAGE COLLECTION
22907: *
22908: STAK1 MOV =ENDSO,XR POINT TO MESSAGE
22909: ZER KVDMP MEMORY IS UNDUMPABLE
22910: BRN STOPR GIVE UP
22911: TTL S P I T B O L -- ERROR SECTION
22912: *
22913: * THIS SECTION OF CODE IS ENTERED WHENEVER A PROCEDURE
22914: * RETURN VIA AN ERR PARAMETER OR AN ERB OPCODE IS OBEYED.
22915: *
22916: * (WA) IS THE ERROR CODE
22917: *
22918: * THE GLOBAL VARIABLE STAGE INDICATES THE POINT AT WHICH
22919: * THE ERROR OCCURED AS FOLLOWS.
22920: *
22921: * STAGE=STGIC ERROR DURING INITIAL COMPILE
22922: *
22923: * STAGE=STGXC ERROR DURING COMPILE AT EXECUTE
22924: * TIME (CODE, CONVERT FUNCTION CALLS)
22925: *
22926: * STAGE=STGEV ERROR DURING COMPILATION OF
22927: * EXPRESSION AT EXECUTION TIME
22928: * (EVAL, CONVERT FUNCTION CALL).
22929: *
22930: * STAGE=STGXT ERROR AT EXECUTE TIME. COMPILER
22931: * NOT ACTIVE.
22932: *
22933: * STAGE=STGCE ERROR DURING INITIAL COMPILE AFTER
22934: * SCANNING OUT THE END LINE.
22935: *
22936: * STAGE=STGXE ERROR DURING COMPILE AT EXECUTE
22937: * TIME AFTER SCANNING END LINE.
22938: *
22939: * STAGE=STGEE ERROR DURING EXPRESSION EVALUATION
22940: *
22941: SEC START OF ERROR SECTION
22942: *
22943: ERROR BEQ R$CIM,=CMLAB,CMPLE JUMP IF ERROR IN SCANNING LABEL
22944: MOV WA,KVERT SAVE ERROR CODE
22945: ZER SCNRS RESET RESCAN SWITCH FOR SCANE
22946: ZER SCNGO RESET GOTO SWITCH FOR SCANE
22947: MOV STAGE,XR LOAD CURRENT STAGE
22948: BSW XR,STGNO JUMP TO APPROPRIATE ERROR CIRCUIT
22949: IFF STGIC,ERR01 INITIAL COMPILE
22950: IFF STGXC,ERR04 EXECUTE TIME COMPILE
22951: IFF STGEV,ERR04 EVAL COMPILING EXPR.
22952: IFF STGEE,ERR04 EVAL EVALUATING EXPR
22953: IFF STGXT,ERR05 EXECUTE TIME
22954: IFF STGCE,ERR01 COMPILE - AFTER END
22955: IFF STGXE,ERR04 XEQ COMPILE-PAST END
22956: ESW END SWITCH ON ERROR TYPE
22957: EJC
22958: *
22959: * ERROR DURING INITIAL COMPILE
22960: *
22961: * THE ERROR MESSAGE IS PRINTED AS PART OF THE COMPILER
22962: * OUTPUT. THIS PRINTOUT INCLUDES THE OFFENDING LINE (IF NOT
22963: * PRINTED ALREADY) AND AN ERROR FLAG UNDER THE APPROPRIATE
22964: * COLUMN AS INDICATED BY SCNSE UNLESS SCNSE IS SET TO ZERO.
22965: *
22966: * AFTER PRINTING THE MESSAGE, THE GENERATED CODE IS
22967: * MODIFIED TO AN ERROR CALL AND CONTROL IS RETURNED TO
22968: * THE CMPIL PROCEDURE AFTER RESETTING THE STACK POINTER.
22969: *
22970: * IF THE ERROR OCCURS AFTER THE END LINE, CONTROL RETURNS
22971: * IN A SLIGHTLY DIFFERENT MANNER TO ENSURE PROPER CLEANUP.
22972: *
22973: ERR01 MOV CMPXS,XS RESET STACK POINTER
22974: SSL CMPSS RESTORE S-R STACK PTR FOR CMPIL
22975: BNZ ERRSP,ERR03 JUMP IF ERROR SUPPRESS FLAG SET
22976: MOV ERICH,ERLST SET FLAG FOR LISTR
22977: JSR LISTR LIST LINE
22978: JSR PRTIS TERMINATE LISTING
22979: ZER ERLST CLEAR LISTR FLAG
22980: MOV SCNSE,WA LOAD SCAN ELEMENT OFFSET
22981: BZE WA,ERR02 SKIP IF NOT SET
22982: LCT WB,WA LOOP COUNTER
22983: ICV WA INCREASE FOR CH$EX
22984: JSR ALOCS STRING BLOCK FOR ERROR FLAG
22985: MOV XR,WA REMEMBER STRING PTR
22986: PSC XR READY FOR CHARACTER STORING
22987: MOV R$CIM,XL POINT TO BAD STATEMENT
22988: PLC XL READY TO GET CHARS
22989: *
22990: * LOOP TO REPLACE ALL CHARS BUT TABS BY BLANKS
22991: *
22992: ERRA1 LCH WC,(XL)+ GET NEXT CHAR
22993: BEQ WC,=CH$HT,ERRA2 SKIP IF TAB
22994: MOV =CH$BL,WC GET A BLANK
22995: EJC
22996: *
22997: * MERGE TO STORE BLANK OR TAB IN ERROR LINE
22998: *
22999: ERRA2 SCH WC,(XR)+ STORE CHAR
23000: BCT WB,ERRA1 LOOP
23001: MOV =CH$EX,XL EXCLAMATION MARK
23002: SCH XL,(XR) STORE AT END OF ERROR LINE
23003: CSC XR END OF SCH LOOP
23004: MOV =STNPD,PROFS ALLOW FOR STATEMENT NUMBER
23005: MOV WA,XR POINT TO ERROR LINE
23006: JSR PRTST PRINT ERROR LINE
23007: *
23008: * HERE AFTER PLACING ERROR FLAG AS REQUIRED
23009: *
23010: ERR02 JSR ERMSG GENERATE FLAG AND ERROR MESSAGE
23011: ADD =NUM03,LSTLC BUMP PAGE CTR FOR BLANK, ERROR, BLK
23012: ZER XR IN CASE OF FATAL ERROR
23013: BHI ERRFT,=NUM03,STOPR PACK UP IF SEVERAL FATALS
23014: *
23015: * COUNT ERROR, INHIBIT EXECUTION IF REQUIRED
23016: *
23017: ICV CMERC BUMP ERROR COUNT
23018: ADD CSWER,NOXEQ INHIBIT XEQ IF -NOERRORS
23019: BNE STAGE,=STGIC,CMP10 SPECIAL RETURN IF AFTER END LINE
23020: EJC
23021: *
23022: * LOOP TO SCAN TO END OF STATEMENT
23023: *
23024: ERR03 MOV R$CIM,XR POINT TO START OF IMAGE
23025: PLC XR POINT TO FIRST CHAR
23026: LCH XR,(XR) GET FIRST CHAR
23027: BEQ XR,=CH$MN,CMPCE JUMP IF ERROR IN CONTROL CARD
23028: ZER SCNRS CLEAR RESCAN FLAG
23029: MNZ ERRSP SET ERROR SUPPRESS FLAG
23030: JSR SCANE SCAN NEXT ELEMENT
23031: BNE XL,=T$SMC,ERR03 LOOP BACK IF NOT STATEMENT END
23032: ZER ERRSP CLEAR ERROR SUPPRESS FLAG
23033: *
23034: * GENERATE ERROR CALL IN CODE AND RETURN TO CMPIL
23035: *
23036: MOV *CDCOD,CWCOF RESET OFFSET IN CCBLK
23037: MOV =OCER$,WA LOAD COMPILE ERROR CALL
23038: JSR CDWRD GENERATE IT
23039: MOV CWCOF,CMSOC(XS) SET SUCCESS FILL IN OFFSET
23040: MNZ CMFFC(XS) SET FAILURE FILL IN FLAG
23041: JSR CDWRD GENERATE SUCC. FILL IN WORD
23042: BRN CMPSE MERGE TO GENERATE ERROR AS CDFAL
23043: *
23044: * ERROR DURING EXECUTE TIME COMPILE OR EXPRESSION EVALUATIO
23045: *
23046: * EXECUTE TIME COMPILATION IS INITIATED THROUGH GTCOD OR
23047: * GTEXP WHICH ARE CALLED BY COMPILE, CODE OR EVAL.
23048: * BEFORE CAUSING STATEMENT FAILURE THROUGH EXFAL IT IS
23049: * HELPFUL TO SET KEYWORD ERRTEXT AND FOR GENERALITY
23050: * THESE ERRORS MAY BE HANDLED BY THE SETEXIT MECHANISM.
23051: *
23052: ERR04 ZER R$CCB FORGET GARBAGE CODE BLOCK
23053: SSL INISS RESTORE MAIN PROG S-R STACK PTR
23054: JSR ERTEX GET FAIL MESSAGE TEXT
23055: DCA XS ENSURE STACK OK ON LOOP START
23056: *
23057: * POP STACK UNTIL FIND FLPTR FOR MOST DEEPLY NESTED PROG.
23058: * DEFINED FUNCTION CALL OR CALL OF EVAL / CODE.
23059: *
23060: ERRA4 ICA XS POP STACK
23061: BEQ XS,FLPRT,ERRC4 JUMP IF PROG DEFINED FN CALL FOUND
23062: BNE XS,GTCEF,ERRA4 LOOP IF NOT EVAL OR CODE CALL YET
23063: MOV =STGXT,STAGE RE-SET STAGE FOR EXECUTE
23064: MOV R$GTC,R$COD RECOVER CODE PTR
23065: MOV XS,FLPTR RESTORE FAIL POINTER
23066: ZER R$CIM FORGET POSSIBLE IMAGE
23067: *
23068: * TEST ERRLIMIT
23069: *
23070: ERRB4 BNZ KVERL,ERR07 JUMP IF ERRLIMIT NON-ZERO
23071: BRN EXFAL FAIL
23072: *
23073: * RETURN FROM PROG. DEFINED FUNCTION IS OUTSTANDING
23074: *
23075: ERRC4 MOV FLPTR,XS RESTORE STACK FROM FLPTR
23076: BRN ERRB4 MERGE
23077: EJC
23078: *
23079: * ERROR AT EXECUTE TIME.
23080: *
23081: * THE ACTION TAKEN ON AN ERROR IS AS FOLLOWS.
23082: *
23083: * IF ERRLIMIT KEYWORD IS ZERO, AN ABORT IS SIGNALLED,
23084: * SEE CODING FOR SYSTEM LABEL ABORT AT L$ABO.
23085: *
23086: * OTHERWISE, ERRLIMIT IS DECREMENTED AND AN ERRTYPE TRACE
23087: * GENERATED IF REQUIRED. CONTROL RETURNS EITHER VIA A JUMP
23088: * TO CONTINUE (TO TAKE THE FAILURE EXIT) OR A SPECIFIED
23089: * SETEXIT TRAP IS EXECUTED AND CONTROL PASSES TO THE TRAP.
23090: * IF 3 OR MORE FATAL ERRORS OCCUR AN ABORT IS SIGNALLED
23091: * REGARDLESS OF ERRLIMIT AND SETEXIT - LOOPING IS ALL TOO
23092: * PROBABLE OTHERWISE. FATAL ERRORS INCLUDE STACK OVERFLOW
23093: * AND EXCEEDING STLIMIT.
23094: *
23095: ERR05 SSL INISS RESTORE MAIN PROG S-R STACK PTR
23096: BNZ DMVCH,ERR08 JUMP IF IN MID-DUMP
23097: *
23098: * MERGE HERE FROM ERR08
23099: *
23100: ERR06 BZE KVERL,LABO1 ABORT IF ERRLIMIT IS ZERO
23101: JSR ERTEX GET FAIL MESSAGE TEXT
23102: *
23103: * MERGE FROM ERR04
23104: *
23105: ERR07 BGE ERRFT,=NUM03,LABO1 ABORT IF TOO MANY FATAL ERRORS
23106: DCV KVERL DECREMENT ERRLIMIT
23107: MOV R$ERT,XL LOAD ERRTYPE TRACE POINTER
23108: JSR KTREX GENERATE ERRTYPE TRACE IF REQUIRED
23109: MOV R$COD,R$CNT SET CDBLK PTR FOR CONTINUATION
23110: MOV FLPTR,XR SET PTR TO FAILURE OFFSET
23111: MOV (XR),STXOF SAVE FAILURE OFFSET FOR CONTINUE
23112: MOV R$SXC,XR LOAD SETEXIT CDBLK POINTER
23113: BZE XR,LCNT1 CONTINUE IF NO SETEXIT TRAP
23114: ZER R$SXC ELSE RESET TRAP
23115: MOV =NULLS,STXVR RESET SETEXIT ARG TO NULL
23116: MOV (XR),XL LOAD PTR TO CODE BLOCK ROUTINE
23117: BRI XL EXECUTE FIRST TRAP STATEMENT
23118: *
23119: * INTERRUPTED PARTLY THROUGH A DUMP WHILST STORE IS IN A
23120: * MESS SO DO A TIDY UP OPERATION. SEE DUMPR FOR DETAILS.
23121: *
23122: ERR08 MOV DMVCH,XR CHAIN HEAD FOR AFFECTED VRBLKS
23123: BZE XR,ERR06 DONE IF ZERO
23124: MOV (XR),DMVCH SET NEXT LINK AS CHAIN HEAD
23125: JSR SETVR RESTORE VRGET FIELD
23126: BRN ERR08 LOOP THROUGH CHAIN
23127: TTL S P I T B O L -- HERE ENDETH THE CODE
23128: *
23129: * END OF ASSEMBLY
23130: *
23131: END END MACRO-SPITBOL ASSEMBLY
23132:
23133:
23134:
23135:
23136:
23137:
23138:
23139:
23140:
23141:
23142:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.