![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to spitv43.min CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / spitbol / 4.3|
Return to spitv43.min CVS log | Up to [Research Unix] / researchv10no / cmd / spitbol / 4.3 |
1.1 root 1: * CHANGES [SGD]
2: * -------------
3: * 1. COMMENTED OUT DEFAULT .DEF, .UNDEF AS THESE MACHINE-
4: * DEPENDENT. I SUGGEST AGAIN THAT THESE DO NOT BELONG
5: * IN MINIMAL SOURCE, UNLESS SOMETHING OF THE FORM .*DEF
6: * IS TO BE INCORPORTATED INTO MINIMAL LANGUAGE DEFN.
7: *
8: * 2. NOTED THAT DESCRIPTION OF BEV, BOD MISSING FROM
9: * SBL42.CMT MINIMAL DESCRIPTION, AND DISCUSSION OF
10: * "ODD"/"EVEN" AND REQUIREMENTS PERTAINING THERETO
11: * SEEMS INSUFFICIENT.
12: *
13: * 3. PERMIT CODE KEYWORD TO CONTAIN ANY INTEGER VALUE.
14: * THIS CONSISTS OF REMOVING THE ENFORCED RESTRICTION
15: * IN ASIGN (SEE ASG24), SINCE CODE CONTAINS NO RELOC.
16: * USE OF KEYWORD VALUE (AS IT SHOULDNT). SBL DOC.
17: * MUST BE UPDATED. ADDRESS OF CODE VALUE NOW PASSED TO
18: * OSINT (KVCOD), INSTEAD OF VALUE ITSELF. HENCE OSINT
19: * DOCUMENTATION MUST LIKEWISE BE REVISED. CHANGES
20: * MADE IN KEYWORD DEFINITION TABLES, PROCEDURES ACESS
21: * AND ASIGN SINCE CODE NOW SPECIAL KEYWORD.
22: *
23: * EROSI RETURNS NOW CONTAIN NEW CODE KEYWORD VALUE IN
24: * IA. OSINT DOCUMENTATION MUST BE REVISED.
25: *
26: * INTERESTINGLY, THIS SHOULD PERMIT THE SPITBOL PROGRAM
27: * TO INTERROGATE THE CODE KEYWORD AT THE START OF
28: * EXECUTION TO DETERMINE IF COMPILATION ERRORS
29: * OCCURRED.
30: *
31: * 4. ADD -COPY "FILETAG" CONTROL CARD. -COPY PERMITTED IN
32: * CODE STRINGS. NESTING IS PERMITTED TO ANY LEVEL,
33: * THOUGH OSINT IS FREE TO RESTRICT THE MAXIMUM LEVEL.
34: * NOTE REQUIREMENT FOR FILETAG SPECIFIED AS
35: * STRING CONSTANT SINCE FILETAGS MAY CONTAIN SEMICOLONS.
36: * I HAVE TRIED TO MAKE THIS ENHANCEMENT WITH MINIMUM
37: * (MINIMAL?) AMOUNT OF NEW CODE, SO THE FEATURE IS
38: * NOT CONDITIONALIZED. THE SOLUTION
39: * REQUIRED THE ADDITION OF A NEW BLOCK TYPE (COBLK) TO
40: * BUILD THE INPUT CONTEXT SAVE STACK AS A CHAIN OF
41: * COBLKS. A RECUSIVE SOLUTION ON CMPIL/READR/NEXTS
42: * WOULD HAVE REQUIRED EXTENSIVE MODIFICATIONS AND
43: * SUBSTANTIAL NEW CODE. NOTE THAT FORMS SUCH AS
44: * CODE('-COPY "FILE.SBL"') ARE ACCEPTABLE, WHICH IS
45: * VIEWED AS SIGNIFICANT ENHANCEMENT IN ADDITION TO
46: * COMPILE-TIME INCLUDE.
47: *
48: * TO SUPPORT THIS FEATURE, TWO NEW OSINT ROUTINES ARE
49: * DEFINED, SYSSC (START COPY) AND SYSEC (END COPY) WITH
50: * LOGICS DESCRIBED IN THE .CMT FILE.
51: *
52: * BECAUSE OF ANNOYANCE FACTOR, SOURCE LISTING OF
53: * CODE() INFO VIA -LIST, INCLUDING -COPY INPUT, IS
54: * NO LONGER POSSIBLE. IF THIS IS PERMITTED, THEN
55: * ONE FINDS -COPY INPUT BEING PRINTED ON STD.
56: * OUTPUT CHANNEL (DEPENDING ON STATE OF -LIST),
57: * UNLESS EXPLICIT -NOLIST IS GIVEN.
58: *
59: * 5. THE DOCUMENTATION FOR SYSIO IS INCONSISTENT. IT
60: * SHOWS 0,1,2,3 BEING POSSIBLE INPUTS DEPENDING ON
61: * INPUT/OUTPUT, STD/NONSTD. HOWEVER, IT ALSO APPEARS
62: * (AND IS STATED) THAT SYSIO IS NOT CALLED FOR STD
63: * INPUT/OUTPUT.
64: *
65: * 6. SINCE -PRINT,-NOPRINT REMOVED IN V4, I HAVE
66: * REINSTATED THE CIRCUIT IN NEXTS TO AVOID LISTING
67: * CONTROL CARDS (-COPY FORCES LIST IN CNCRD THOUGH).
68: *
69: * 7. WA NOW CONTAINS THE INITIAL VALUE OF &CODE ON ENTRY
70: * TO SPITBOL.
71: *
72: * 8. ADDED DDC (DEFINE DISPLAY CONSTANT). IS IDENTICAL
73: * TO DTC EXCEPT THAT ON SYSTEMS SUPPORTING LOWER CASE,
74: * THE DISPLAY TEXT CAN BE TRANSLATED WITH A
75: * CASE MIX. FOR EXAMPLE, CAPITALIZE ONLY THE FIRST
76: * LETTER, OR THE FIRST LETTER OF EVERY WORD, OR NO
77: * UPPER CASE (FOR EUNICHS), ETC.
78: *
79: * 9. FIX MINOR OVERSIGHT IN FAILING TO CLEAR R$PMB AT
80: * END OF PATTERN MATCH, THUS LEAVING PTR TO BCBLK
81: * THAT CANNOT BE COLLECTED.
82: *
83: * 10. AFTER CONSULTATION WITH DAVE SHIELDS, IT WAS AGREED
84: * TO REINSTATE ARG,FIELD,ITEM AND LOCAL FUNCTIONS.
85: * COMMENTS WERE RECEIVED THAT REMOVING THEM BREAKS
86: * EXISTING CODE IN DIFFICULT-TO-FIX WAYS, INCLUDING
87: * A NUMBER OF THE UTILITY ROUTINES IN GIMPELS BOOK.
88: * IN ANY EVENT, THESE ARE SNOBOL4 COMPATIBILITY
89: * FUNCTIONS THAT TAKE LITTLE CODE SPACE. AS A
90: * RESULT OF THIS, AND -COPY, ERROR NUMBERS HAVE
91: * BEEN PUSHED BACK OVER THE 255 THRESHOLD, WHICH
92: * SEEMS UNAVOIDABLE UNLESS MAJOR SURGERY IS DONE.
93: *
94: * 11. VERSION ID CHANGED TO V4.3 DUE TO SUBSTANTIAL
95: * CHANGES.
96: *
97: * 12. PERMIT DOLLAR SIGN IN VARIABLE NAMES. MINOR
98: * CHANGE TO OPERATOR TABLE AND SCANE.
99: *
100: * 13. PERMIT BUFFER TYPE FOR LOAD SPECIFICATION. AS
101: * A SIDE-EFFECT, THE CODE FOR BUFFER CONVERSION HAS
102: * BEEN CENTRALIZED IN GTBUF. ALSO FIXED PADDING
103: * BUG IN INSBF RELATED TO ZERO PADDING.
104: *
105: * 14. DOCUMENT THAT SYSIL MUST NEVER REQUEST ZERO BYTES.
106: * DOING SO CAUSES ACESS TO POTENTIALLY CREATE
107: * INVALID MEMORY CAUSING LATER GARBAGE COLLECTOR
108: * PROBLEMS OR MISADJUSTMENTS OF DNAMP, ETC.
109: *
110: * 15. VDIFFER FUNCTION ADDED. VDIFFER(X,Y) RETURNS X
111: * IF DIFFERENT FROM Y. IN MOST CASES IT IS EXPECTED
112: * THAT Y WOULD BE NULL.
113: *
114: SEC FORMAL START OF PROCEDURES SECTION
115: EJC
116: *
117: * SPITBOL CONDITIONAL ASSEMBLY SYMBOLS
118: * ------------------------------------
119: *
120: * IN THE SPITBOL TRANSLATOR, THE FOLLOWING CONDITIONAL
121: * ASSEMBLY SYMBOLS ARE REFERRED TO.
122: * A PARTICULAR SET OF DEFAULT SETTINGS IS GIVEN IN THIS
123: * SOURCE BY USE OF .DEF AND .UNDEF PSEUDO OPS.
124: * A DIFFERENT SELECTION MAY BE MADE BY VARYING THE
125: * DEFINITIONS. AS AN ALTERNATIVE, THIS SECTION MAY BE
126: * COMMENTED OUT AND THE MINIMAL TRANSLATOR PRELOADED WITH
127: * THE SELECTED DEFINITIONS, THUS ALLOWING A MORE DYNAMIC
128: * CHOICE TO BE MADE.
129: * SOME OF THE CONDITIONAL FEATURES CHOOSE AMONGST A VARIETY
130: * OF OPTIONS. OTHERS ARE DEFINED PRINCIPALLY TO ALLOW
131: * OMISSION OF A FEATURE WHICH IS NOT WANTED IN ORDER TO
132: * SAVE MEMORY OR BECAUSE IT CANNOT BE SUPPORTED.
133: * NOTE THAT IF .CPLC OPTION IS CHOSEN, TRANSLATION OF DTC,
134: * ERR, ERB ARGUMENTS SHOULD BE TO LOWER CASE.
135: *
136: *.DEF .CAHT DEFINE TO INCLUDE HORIZONTAL TAB
137: *.DEF .CASL DEFINE TO INCLUDE 26 SHIFTED LETTRS
138: *.DEF .CAVT DEFINE TO INCLUDE VERTICAL TAB
139: *.UNDEF .CEPP DEFINE FOR ODD PARITY ENTRY POINTS
140: *.UNDEF .CNBF DEFINE TO OMIT BUFFER EXTENSION
141: *.UNDEF .CNBT DEFINE TO OMIT BATCH INITIALISATION
142: *.UNDEF .CNEX DEFINE TO OMIT EXIT() CODE
143: *.UNDEF .CNFN DEFINE TO OMIT FENCE() CODE
144: *.UNDEF .CNLD DEFINE TO OMIT LOAD() CODE
145: *.UNDEF .CNPF DEFINE TO OMIT PROFILE CODE
146: *.UNDEF .CNRA DEFINE TO OMIT ALL REAL ARITHMETIC
147: *.UNDEF .CNSR DEFINE TO OMIT SORT, RSORT CODE
148: *.DEF .CPLC DEFINE IF HOST PREFERS LOWER CASE
149: *.UNDEF .CRPP DEFINE FOR ODD PARITY RETURN POINTS
150: *.UNDEF .CS16 DEFINE TO INITIALIZE STLIM TO 32767
151: *.UNDEF .CSAX DEFINE IF SYSAX IS TO BE CALLED
152: *.UNDEF .CSCI DEFINE TO ENABLE SYSCI ROUTINE
153: *.UNDEF .CSCV DEFINE FOR CLU, CUL CASE CONVERSION
154: *.DEF .CSIG DEFINE TO IGNORE CASE OF LETTERS
155: *.UNDEF .CSN6 DEFINE TO PAD STMT NOS TO 6 CHARS
156: *.DEF .CSN8 DEFINE TO PAD STMT NOS TO 8 CHARS
157: *.UNDEF .CTMD DEFINE IF SYSTM UNIT IS DECISECOND
158: .IF .CASL
159: .ELSE
160: .UNDEF .CSIG .CSIG USELESS WITHOUT LC LETTERS
161: .UNDEF .CPLC .CPLC ERRONEOUS WITHOUT LC LETTERS
162: .FI
163: EJC
164: *
165: * ACTUAL PROCESSABLE EXP PROCEDURE DEFINITIONS
166: *
167: .IF .CSAX
168: SYSAX EXP E,0
169: .ELSE
170: .FI
171: SYSBX EXP E,0
172: .IF .CSCI
173: SYSCI EXP E,0
174: .FI
175: SYSDT EXP E,0
176: SYSEC EXP E,2
177: SYSEF EXP E,2
178: SYSEJ EXP E,0
179: SYSEM EXP E,0
180: SYSEN EXP E,2
181: SYSEP EXP E,2
182: .IF .CNLD
183: .ELSE
184: SYSEX EXP E,1
185: .FI
186: SYSHS EXP E,2
187: SYSID EXP E,0
188: SYSIL EXP E,0
189: SYSIN EXP E,2
190: SYSIO EXP E,2
191: .IF .CNLD
192: .ELSE
193: SYSLD EXP E,2
194: .FI
195: SYSMM EXP E,0
196: SYSMX EXP E,0
197: SYSOU EXP E,2
198: SYSPI EXP E,2
199: SYSPP EXP E,0
200: SYSPR EXP E,2
201: SYSRD EXP E,2
202: SYSRI EXP E,2
203: SYSSC EXP E,2
204: .IF .CUST
205: SYSST EXP E,2
206: .FI
207: SYSTM EXP E,0
208: SYSTT EXP E,0
209: .IF .CNLD
210: .ELSE
211: SYSUL EXP E,0
212: .FI
213: .IF .CNEX
214: .ELSE
215: SYSXI EXP E,2
216: .FI
217: EJC
218: * NAME GLOBAL LABELS, INTERNAL PROCEDURES AND ROUTINES.
219: *
220: CMPCE GLB
221: CMPEL GLB
222: CMPLE GLB
223: CMPSE GLB
224: EVLXF GLB
225: EVLXN GLB
226: EVLXV GLB
227: LCNXE GLB
228: TRXQR GLB
229: ACESS INP R,1
230: ACOMP INP N,5
231: ALLOC INP E,0
232: .IF .CNBF
233: .ELSE
234: ALOBF INP E,0
235: .FI
236: ALOCS INP E,0
237: ALOST INP E,0
238: .IF .CNRA
239: ARITH INP N,2
240: .ELSE
241: ARITH INP N,3
242: .FI
243: ASIGN INP R,1
244: ASINP INP R,1
245: BLKLN INP E,0
246: CBLCK INP N,1
247: CDGCG INP E,0
248: CDGEX INP R,0
249: CDGNM INP R,0
250: CDGVL INP R,0
251: CDWRD INP E,0
252: CMGEN INP R,0
253: CMPIL INP E,0
254: CNCRD INP E,0
255: COPND INP E,0
256: DFFNC INP E,0
257: DTYPE INP E,0
258: DUMPR INP E,0
259: ERMSG INP E,0
260: ERTEX INP E,0
261: EVALI INP R,3
262: EVALP INP R,1
263: EVALS INP R,2
264: EVALX INP R,1
265: EXBLD INP E,0
266: EXPAN INP E,0
267: EXPAP INP E,1
268: EXPDM INP N,0
269: EXPOP INP N,0
270: GBCOL INP E,0
271: GBCPF INP E,0
272: GTARR INP E,1
273: .IF .CNBF
274: .ELSE
275: GTBUF INP E,1
276: .FI
277: EJC
278: GTCOD INP E,1
279: GTEXP INP E,1
280: GTINT INP E,1
281: GTNUM INP E,1
282: GTNVR INP E,1
283: GTPAT INP E,1
284: .IF .CNRA
285: .ELSE
286: GTREA INP E,1
287: .FI
288: GTSMI INP N,2
289: GTSTG INP N,1
290: GTVAR INP E,1
291: HASHS INP E,0
292: ICBLD INP E,0
293: IDENT INP E,1
294: INOUT INP E,0
295: .IF .CNBF
296: .ELSE
297: INSBF INP E,2
298: .FI
299: IOFTG INP N,1
300: IOPUT INP N,4
301: KTREX INP R,0
302: KWNAM INP N,0
303: LCOMP INP N,5
304: LISTR INP E,0
305: LISTT INP E,0
306: NEXTS INP E,0
307: PATIN INP N,2
308: PATST INP N,1
309: PBILD INP E,0
310: PCONC INP E,0
311: PCOPY INP N,0
312: .IF .CNPF
313: .ELSE
314: PRFLR INP E,0
315: PRFLU INP E,0
316: .FI
317: PRPAR INP E,0
318: PRTCF INP E,0
319: PRTCH INP E,0
320: PRTFB INP E,0
321: PRTFH INP R,0
322: PRTIN INP E,0
323: PRTMI INP E,0
324: PRTNM INP R,0
325: PRTNV INP E,0
326: PRTPG INP E,0
327: PRTPS INP E,0
328: PRTSF INP E,0
329: PRTSN INP E,0
330: PRTST INP R,0
331: EJC
332: PRTVF INP E,0
333: PRTVL INP R,0
334: PRTVN INP E,0
335: PTTFH INP E,0
336: PTTST INP E,0
337: .IF .CNRA
338: .ELSE
339: RCBLD INP E,0
340: .FI
341: READR INP E,0
342: .IF .CASL
343: SBSCC INP E,0
344: SBSTG INP E,0
345: .FI
346: SBSTR INP E,0
347: SCANE INP E,0
348: SCNGF INP E,0
349: SETVR INP E,0
350: .IF .CNSR
351: .ELSE
352: SORTA INP N,1
353: SORTC INP E,1
354: SORTF INP E,0
355: SORTH INP N,0
356: .FI
357: TFIND INP E,1
358: TRACE INP N,3
359: TRBLD INP E,0
360: TRCHN INP E,1
361: TRIMR INP E,0
362: TRXEQ INP R,0
363: XSCAN INP E,0
364: XSCNI INP N,2
365: ARREF INR
366: CFUNC INR
367: EROSI INR
368: ERROR INR
369: EXFAL INR
370: EXINT INR
371: EXITS INR
372: EXIXR INR
373: EXNAM INR
374: EXNUL INR
375: .IF .CNRA
376: .ELSE
377: EXREA INR
378: .FI
379: EXSID INR
380: EXVNM INR
381: FAILP INR
382: FLPOP INR
383: INDIR INR
384: INITL INR
385: MATCH INR
386: RETRN INR
387: STAKV INR
388: STCOV INR
389: STMGO INR
390: STOPR INR
391: SUCCP INR
392: TTL S P I T B O L -- DEFINITIONS AND DATA STRUCTURES
393: * THIS SECTION CONTAINS ALL SYMBOL DEFINITIONS AND ALSO
394: * PICTURES OF ALL DATA STRUCTURES USED IN THE SYSTEM.
395: *
396: SEC START OF DEFINITIONS SECTION
397: *
398: * DEFINITIONS OF MACHINE PARAMETERS
399: *
400: * THE MINIMAL TRANSLATOR SHOULD SUPPLY APPROPRIATE VALUES
401: * FOR THE PARTICULAR TARGET MACHINE FOR ALL THE
402: * EQU *
403: * DEFINITIONS GIVEN AT THE START OF THIS SECTION.
404: * NOTE THAT EVEN IF CONDITIONAL ASSEMBLY IS USED TO OMIT
405: * SOME FEATURE (E.G. REAL ARITHMETIC) A FULL SET OF CFP$-
406: * VALUES MUST BE SUPPLIED. USE DUMMY VALUES IF GENUINE
407: * ONES ARE NOT NEEDED.
408: *
409: CFP$A EQU * NUMBER OF CHARACTERS IN ALPHABET
410: *
411: CFP$B EQU * BAUS/WORD ADDRESSING FACTOR
412: *
413: CFP$C EQU * NUMBER OF CHARACTERS PER WORD
414: *
415: CFP$F EQU * OFFSET IN BAUS TO CHARS IN
416: * SCBLK. SEE SCBLK FORMAT.
417: *
418: CFP$I EQU * NUMBER OF WORDS IN INTEGER CONSTANT
419: *
420: CFP$M EQU * MAX POSITIVE INTEGER IN ONE WORD
421: *
422: CFP$N EQU * NUMBER OF BITS IN ONE WORD
423: *
424: CFP$R EQU * NUMBER OF WORDS IN REAL CONSTANT
425: *
426: CFP$S EQU * NUMBER OF SIG DIGS FOR REAL OUTPUT
427: *
428: * THE FOLLOWING DEFINITION FOR CFP$U SUPPLIES A REALISTIC
429: * UPPER BOUND ON THE SIZE OF THE ALPHABET. CFP$U IS USED
430: * TO SAVE SPACE IN THE SCANE BSW-IFF-ESW TABLE AND TO EASE
431: * TRANSLATION STORAGE REQUIREMENTS.
432: *
433: CFP$U EQU * REALISTIC UPPER BOUND ON ALPHABET
434: *
435: CFP$X EQU * MAX DIGITS IN REAL EXPONENT
436: *
437: MXDGS EQU CFP$S+CFP$X MAX DIGITS IN REAL NUMBER
438: *
439: NSTMX EQU MXDGS+5 MAX SPACE FOR REAL (FOR +0.E+)
440: EJC
441: *
442: * ENVIRONMENT PARAMETERS
443: *
444: * THE SPITBOL PROGRAM IS ESSENTIALLY INDEPENDENT OF
445: * THE DEFINITIONS OF THESE PARAMETERS. HOWEVER, THE
446: * EFFICIENCY OF THE SYSTEM MAY BE AFFECTED. CONSEQUENTLY,
447: * THESE PARAMETERS MAY REQUIRE TUNING FOR A GIVEN VERSION
448: * THE VALUES GIVEN IN COMMENTS HAVE BEEN SUCCESSFULLY USED.
449: *
450: * E$SRS IS THE NUMBER OF WORDS TO RESERVE AT THE END OF
451: * STORAGE FOR END OF RUN PROCESSING. IT SHOULD BE
452: * SET AS SMALL AS POSSIBLE WITHOUT CAUSING MEMORY OVERFLOW
453: * IN CRITICAL SITUATIONS (E.G. MEMORY OVERFLOW TERMINATION)
454: * AND SHOULD THUS RESERVE SUFFICIENT SPACE AT LEAST FOR
455: * AN SCBLK CONTAINING SAY 30 CHARACTERS.
456: *
457: E$SRS EQU * 30 WORDS
458: *
459: * E$STS IS THE NUMBER OF WORDS GRABBED IN A CHUNK WHEN
460: * STORAGE IS ALLOCATED IN THE STATIC REGION. THE MINIMUM
461: * PERMITTED VALUE IS 256/CFP$B. LARGER VALUES WILL LEAD
462: * TO INCREASED EFFICIENCY AT THE COST OF WASTING MEMORY.
463: *
464: E$STS EQU * 500 WORDS
465: *
466: * E$CBS IS THE SIZE OF CODE BLOCK ALLOCATED INITIALLY AND
467: * THE EXPANSION INCREMENT IF OVERFLOW OCCURS. IF THIS VALUE
468: * IS TOO SMALL OR TOO LARGE, EXCESSIVE GARBAGE COLLECTIONS
469: * WILL OCCUR DURING COMPILATION AND MEMORY MAY BE LOST
470: * IN THE CASE OF A TOO LARGE VALUE.
471: *
472: E$CBS EQU * 500 WORDS
473: *
474: * E$HNB IS THE NUMBER OF BUCKET HEADERS IN THE VARIABLE
475: * HASH TABLE. IT SHOULD ALWAYS BE ODD. LARGER VALUES WILL
476: * SPEED UP COMPILATION AND INDIRECT REFERENCES AT THE
477: * EXPENSE OF ADDITIONAL STORAGE FOR THE HASH TABLE ITSELF.
478: *
479: E$HNB EQU * 127 BUCKET HEADERS
480: *
481: * E$HNW IS THE MAXIMUM NUMBER OF WORDS OF A STRING
482: * NAME WHICH PARTICIPATE IN THE STRING HASH ALGORITHM.
483: * LARGER VALUES GIVE A BETTER HASH AT THE EXPENSE OF TAKING
484: * LONGER TO COMPUTE THE HASH. THERE IS SOME OPTIMAL VALUE.
485: *
486: E$HNW EQU * 6 WORDS
487: *
488: * E$FSP . IF THE AMOUNT OF FREE SPACE LEFT AFTER A GARBAGE
489: * COLLECTION IS SMALL COMPARED TO THE TOTAL AMOUNT OF SPACE
490: * IN USE GARBAGE COLLECTOR THRASHING IS LIKELY TO OCCUR AS
491: * THIS SPACE IS USED UP. E$FSP IS A MEASURE OF THE
492: * MINIMUM PERCENTAGE OF DYNAMIC MEMORY LEFT AS FREE SPACE
493: * BEFORE THE SYSTEM ROUTINE SYSMM IS CALLED TO TRY TO
494: * OBTAIN MORE MEMORY.
495: *
496: E$FSP EQU * 15 PERCENT
497: EJC
498: *
499: * DEFINITIONS OF CODES FOR LETTERS
500: *
501: CH$LA EQU * LETTER A
502: CH$LB EQU * LETTER B
503: CH$LC EQU * LETTER C
504: CH$LD EQU * LETTER D
505: CH$LE EQU * LETTER E
506: CH$LF EQU * LETTER F
507: CH$LG EQU * LETTER G
508: CH$LH EQU * LETTER H
509: CH$LI EQU * LETTER I
510: CH$LJ EQU * LETTER J
511: CH$LK EQU * LETTER K
512: CH$LL EQU * LETTER L
513: CH$LM EQU * LETTER M
514: CH$LN EQU * LETTER N
515: CH$LO EQU * LETTER O
516: CH$LP EQU * LETTER P
517: CH$LQ EQU * LETTER Q
518: CH$LR EQU * LETTER R
519: CH$LS EQU * LETTER S
520: CH$LT EQU * LETTER T
521: CH$LU EQU * LETTER U
522: CH$LV EQU * LETTER V
523: CH$LW EQU * LETTER W
524: CH$LX EQU * LETTER X
525: CH$LY EQU * LETTER Y
526: CH$L$ EQU * LETTER Z
527: *
528: * DEFINITIONS OF CODES FOR DIGITS
529: *
530: CH$D0 EQU * DIGIT 0
531: CH$D1 EQU * DIGIT 1
532: CH$D2 EQU * DIGIT 2
533: CH$D3 EQU * DIGIT 3
534: CH$D4 EQU * DIGIT 4
535: CH$D5 EQU * DIGIT 5
536: CH$D6 EQU * DIGIT 6
537: CH$D7 EQU * DIGIT 7
538: CH$D8 EQU * DIGIT 8
539: CH$D9 EQU * DIGIT 9
540: EJC
541: *
542: * DEFINITIONS OF CODES FOR SPECIAL CHARACTERS
543: *
544: * THE NAMES OF THESE CHARACTERS ARE RELATED TO THEIR
545: * ORIGINAL REPRESENTATION IN THE EBCDIC SET CORRESPONDING
546: * TO THE DESCRIPTION IN STANDARD SNOBOL4 MANUALS AND TEXTS.
547: *
548: CH$AM EQU * KEYWORD OPERATOR (AMPERSAND)
549: CH$AS EQU * MULTIPLICATION SYMBOL (ASTERISK)
550: CH$AT EQU * CURSOR POSITION OPERATOR (AT)
551: CH$BB EQU * LEFT ARRAY BRACKET (LESS THAN)
552: CH$BL EQU * BLANK
553: CH$BR EQU * ALTERNATION OPERATOR (VERTICAL BAR)
554: CH$CL EQU * GOTO SYMBOL (COLON)
555: CH$CM EQU * COMMA
556: CH$DL EQU * INDIRECTION OPERATOR (DOLLAR)
557: CH$DT EQU * NAME OPERATOR (DOT)
558: CH$DQ EQU * DOUBLE QUOTE
559: CH$EQ EQU * EQUAL SIGN
560: CH$EX EQU * EXPONENTIATION OPERATOR (EXCLM)
561: CH$MN EQU * MINUS SIGN
562: CH$NM EQU * NUMBER SIGN
563: CH$NT EQU * NEGATION OPERATOR (NOT)
564: CH$PC EQU * PERCENT
565: CH$PL EQU * PLUS SIGN
566: CH$PP EQU * LEFT PARENTHESIS
567: CH$RB EQU * RIGHT ARRAY BRACKET (GRTR THAN)
568: CH$RP EQU * RIGHT PARENTHESIS
569: CH$QU EQU * INTERROGATION OPERATOR (QUESTION)
570: CH$SL EQU * SLASH
571: CH$SM EQU * SEMICOLON
572: CH$SQ EQU * SINGLE QUOTE
573: CH$UN EQU * SPECIAL IDENTIFIER CHAR (UNDERLINE)
574: CH$OB EQU * OPENING BRACKET
575: CH$CB EQU * CLOSING BRACKET
576: EJC
577: *
578: * REMAINING CHARS ARE OPTIONAL ADDITIONS TO THE STANDARDS.
579: * THEY ARE ALL UNDER CONDITIONAL ASSEMBLY.
580: .IF .CAHT
581: *
582: * TAB CHARACTERS - SYNTACTICALLY EQUIVALENT TO BLANK
583: *
584: CH$HT EQU * HORIZONTAL TAB
585: .FI
586: .IF .CAVT
587: CH$VT EQU * VERTICAL TAB
588: .FI
589: .IF .CASL
590: *
591: * LOWER CASE OR SHIFTED CASE ALPHABETIC CHARS
592: *
593: CH$$A EQU * SHIFTED A
594: CH$$B EQU * SHIFTED B
595: CH$$C EQU * SHIFTED C
596: CH$$D EQU * SHIFTED D
597: CH$$E EQU * SHIFTED E
598: CH$$F EQU * SHIFTED F
599: CH$$G EQU * SHIFTED G
600: CH$$H EQU * SHIFTED H
601: CH$$I EQU * SHIFTED I
602: CH$$J EQU * SHIFTED J
603: CH$$K EQU * SHIFTED K
604: CH$$L EQU * SHIFTED L
605: CH$$M EQU * SHIFTED M
606: CH$$N EQU * SHIFTED N
607: CH$$O EQU * SHIFTED O
608: CH$$P EQU * SHIFTED P
609: CH$$Q EQU * SHIFTED Q
610: CH$$R EQU * SHIFTED R
611: CH$$S EQU * SHIFTED S
612: CH$$T EQU * SHIFTED T
613: CH$$U EQU * SHIFTED U
614: CH$$V EQU * SHIFTED V
615: CH$$W EQU * SHIFTED W
616: CH$$X EQU * SHIFTED X
617: CH$$Y EQU * SHIFTED Y
618: CH$$$ EQU * SHIFTED Z
619: .IF .CASL
620: DFA$A EQU CH$$A-CH$LA DIFF BETWEEN LC AND UC LETTERS
621: .FI
622: .FI
623: EJC
624: *
625: * DATA BLOCK FORMATS AND DEFINITIONS
626: *
627: * THE FOLLOWING SECTIONS DESCRIBE THE DETAILED FORMAT OF
628: * ALL POSSIBLE DATA BLOCKS IN STATIC AND DYNAMIC MEMORY.
629: *
630: * EVERY BLOCK HAS A NAME OF THE FORM XXBLK WHERE XX IS A
631: * UNIQUE TWO CHARACTER IDENTIFIER. THE FIRST WORD OF EVERY
632: * BLOCK MUST CONTAIN A POINTER TO A PROGRAM LOCATION IN THE
633: * INTERPRETOR WHICH IS IMMEDIATELY PRECEDED BY AN ADDRESS
634: * CONSTANT CONTAINING THE VALUE BL$XX WHERE XX IS THE BLOCK
635: * IDENTIFIER. THIS PROVIDES A UNIFORM MECHANISM FOR
636: * DISTINGUISHING BETWEEN THE VARIOUS BLOCK TYPES.
637: *
638: * IN SOME CASES, THE CONTENTS OF THE FIRST WORD IS CONSTANT
639: * FOR A GIVEN BLOCK TYPE AND MERELY SERVES AS A POINTER
640: * TO THE IDENTIFYING ADDRESS CONSTANT. HOWEVER, IN OTHER
641: * CASES THERE ARE SEVERAL POSSIBILITIES FOR THE FIRST
642: * WORD IN WHICH CASE EACH OF THE SEVERAL PROGRAM ENTRY
643: * POINTS MUST BE PRECEDED BY THE APPROPRIATE CONSTANT.
644: *
645: * IN EACH BLOCK, SOME OF THE FIELDS ARE RELOCATABLE. THIS
646: * MEANS THAT THEY MAY CONTAIN A POINTER TO ANOTHER BLOCK
647: * IN THE DYNAMIC AREA. (TO BE MORE PRECISE, IF THEY CONTAIN
648: * A POINTER WITHIN THE DYNAMIC AREA, THEN IT IS A POINTER
649: * TO A BLOCK). SUCH FIELDS MUST BE MODIFIED BY THE GARBAGE
650: * COLLECTOR (PROCEDURE GBCOL) WHENEVER BLOCKS ARE COMPACTED
651: * IN THE DYNAMIC REGION. THE GARBAGE COLLECTOR (ACTUALLY
652: * PROCEDURE GBCPF) REQUIRES THAT ALL SUCH RELOCATABLE
653: * FIELDS IN A BLOCK MUST BE CONTIGUOUS.
654: EJC
655: *
656: * THE DESCRIPTION FORMAT USES THE FOLLOWING SCHEME.
657: *
658: * 1) BLOCK TITLE AND TWO CHARACTER IDENTIFIER
659: *
660: * 2) DESCRIPTION OF BASIC USE OF BLOCK AND INDICATION
661: * OF CIRCUMSTANCES UNDER WHICH IT IS CONSTRUCTED.
662: *
663: * 3) PICTURE OF THE BLOCK FORMAT. IN THESE PICTURES LOW
664: * MEMORY ADDRESSES ARE AT THE TOP OF THE PAGE. FIXED
665: * LENGTH FIELDS ARE SURROUNDED BY I (LETTER I). FIELDS
666: * WHICH ARE FIXED LENGTH BUT WHOSE LENGTH IS DEPENDENT
667: * ON A CONFIGURATION PARAMETER ARE SURROUNDED BY *
668: * (ASTERISK). VARIABLE LENGTH FIELDS ARE SURROUNDED
669: * BY / (SLASH).
670: *
671: * 4) DEFINITION OF SYMBOLIC OFFSETS TO FIELDS IN
672: * BLOCK AND OF THE SIZE OF THE BLOCK IF FIXED LENGTH
673: * OR OF THE SIZE OF THE FIXED LENGTH FIELDS IF THE
674: * BLOCK IS VARIABLE LENGTH.
675: * NOTE THAT SOME ROUTINES SUCH AS GBCPF ASSUME
676: * CERTAIN OFFSETS ARE EQUAL. THE DEFINITIONS
677: * GIVEN HERE ENFORCE THIS. MAKE CHANGES TO
678: * THEM ONLY WITH DUE CARE.
679: *
680: * DEFINITIONS OF COMMON OFFSETS
681: *
682: OFFS1 EQU 1
683: OFFS2 EQU 2
684: OFFS3 EQU 3
685: *
686: * 5) DETAILED COMMENTS ON THE SIGNIFICANCE AND FORMATS
687: * OF THE VARIOUS FIELDS.
688: *
689: * THE ORDER IS ALPHABETICAL BY IDENTIFICATION CODE.
690: EJC
691: *
692: * DEFINITIONS OF BLOCK CODES
693: *
694: * THIS TABLE PROVIDES A UNIQUE IDENTIFICATION CODE FOR
695: * EACH SEPARATE BLOCK TYPE. THE FIRST WORD OF A BLOCK IN
696: * THE DYNAMIC AREA ALWAYS CONTAINS THE ADDRESS OF A PROGRAM
697: * ENTRY POINT. THE BLOCK CODE IS USED AS THE ENTRY POINT ID
698: * THE ORDER OF THESE CODES DICTATES THE ORDER OF THE TABLE
699: * USED BY THE DATATYPE FUNCTION (SCNMT IN THE CONSTANT SEC)
700: *
701: * BLOCK CODES FOR ACCESSIBLE DATATYPES
702: *
703: BL$AR EQU 0 ARBLK ARRAY
704: .IF .CNBF
705: BL$CD EQU BL$AR+1 CDBLK CODE
706: .ELSE
707: BL$BC EQU BL$AR+1 BCBLK BUFFER
708: BL$CD EQU BL$BC+1 CDBLK CODE
709: .FI
710: BL$EX EQU BL$CD+1 EXBLK EXPRESSION
711: BL$IC EQU BL$EX+1 ICBLK INTEGER
712: BL$NM EQU BL$IC+1 NMBLK NAME
713: BL$P0 EQU BL$NM+1 P0BLK PATTERN
714: BL$P1 EQU BL$P0+1 P1BLK PATTERN
715: BL$P2 EQU BL$P1+1 P2BLK PATTERN
716: .IF .CNRA
717: BL$SC EQU BL$P2+1 SCBLK STRING
718: .ELSE
719: BL$RC EQU BL$P2+1 RCBLK REAL
720: BL$SC EQU BL$RC+1 SCBLK STRING
721: .FI
722: BL$SE EQU BL$SC+1 SEBLK EXPRESSION
723: BL$TB EQU BL$SE+1 TBBLK TABLE
724: BL$VC EQU BL$TB+1 VCBLK ARRAY
725: BL$XN EQU BL$VC+1 XNBLK EXTERNAL
726: BL$XR EQU BL$XN+1 XRBLK EXTERNAL
727: BL$PD EQU BL$XR+1 PDBLK PROGRAM DEFINED DATATYPE
728: *
729: BL$$D EQU BL$PD+1 NUMBER OF BLOCK CODES FOR DATA
730: *
731: * OTHER BLOCK CODES
732: *
733: BL$TR EQU BL$PD+1 TRBLK
734: .IF .CNBF
735: BL$CC EQU BL$TR+1 CCBLK
736: .ELSE
737: BL$BF EQU BL$TR+1 BFBLK
738: BL$CC EQU BL$BF+1 CCBLK
739: .FI
740: BL$CM EQU BL$CC+1 CMBLK
741: BL$CO EQU BL$CM+1 COBLK
742: BL$CT EQU BL$CO+1 CTBLK
743: BL$DF EQU BL$CT+1 DFBLK
744: BL$EF EQU BL$DF+1 EFBLK
745: BL$EV EQU BL$EF+1 EVBLK
746: BL$FF EQU BL$EV+1 FFBLK
747: BL$KV EQU BL$FF+1 KVBLK
748: BL$PF EQU BL$KV+1 PFBLK
749: BL$TE EQU BL$PF+1 TEBLK
750: *
751: BL$$I EQU 0 DEFAULT IDENTIFICATION CODE
752: BL$$T EQU BL$TR+1 CODE FOR DATA OR TRACE BLOCK
753: BL$$$ EQU BL$TE+1 NUMBER OF BLOCK CODES
754: EJC
755: *
756: * FIELD REFERENCES
757: *
758: * REFERENCES TO THE FIELDS OF DATA BLOCKS ARE SYMBOLIC
759: * (I.E. USE THE SYMBOLIC OFFSETS) WITH THE FOLLOWING
760: * EXCEPTIONS.
761: *
762: * 1) REFERENCES TO THE FIRST WORD ARE USUALLY NOT
763: * SYMBOLIC SINCE THEY USE THE (X) OPERAND FORMAT.
764: *
765: * 2) THE CODE WHICH CONSTRUCTS A BLOCK IS OFTEN NOT
766: * SYMBOLIC AND SHOULD BE CHANGED IF THE CORRESPONDING
767: * BLOCK FORMAT IS MODIFIED.
768: *
769: * 3) THE PLC AND PSC INSTRUCTIONS IMPLY AN OFFSET
770: * CORRESPONDING TO THE DEFINITION OF CFP$F.
771: *
772: * 4) THERE ARE NON-SYMBOLIC REFERENCES (EASILY CHANGED)
773: * IN THE GARBAGE COLLECTOR (PROCEDURES GBCPF, BLKLN).
774: *
775: * 5) THE FIELDS IDVAL, FARGS APPEAR IN SEVERAL BLOCKS
776: * AND ANY CHANGES MUST BE MADE IN PARALLEL TO ALL
777: * BLOCKS CONTAINING THE FIELDS. THE ACTUAL REFERENCES
778: * TO THESE FIELDS ARE SYMBOLIC WITH THE ABOVE
779: * LISTED EXCEPTIONS.
780: *
781: * 6) SEVERAL SPOTS IN THE CODE ASSUME THAT THE
782: * DEFINITIONS OF THE FIELDS VRVAL, TEVAL, TRNXT ARE
783: * THE SAME (THESE ARE SECTIONS OF CODE WHICH SEARCH
784: * OUT ALONG A TRBLK CHAIN FROM A VARIABLE).
785: *
786: * 7) REFERENCES TO THE FIELDS OF AN ARRAY BLOCK IN THE
787: * ARRAY REFERENCE ROUTINE ARREF ARE NON-SYMBOLIC.
788: *
789: * APART FROM THE EXCEPTIONS LISTED, REFERENCES ARE SYMBOLIC
790: * AS FAR AS POSSIBLE AND MODIFYING THE ORDER OR NUMBER
791: * OF FIELDS WILL NOT REQUIRE CHANGES.
792: EJC
793: *
794: * COMMON FIELDS FOR FUNCTION BLOCKS
795: *
796: * BLOCKS WHICH REPRESENT CALLABLE FUNCTIONS HAVE TWO
797: * COMMON FIELDS AT THE START OF THE BLOCK AS FOLLOWS.
798: *
799: * +------------------------------------+
800: * I FCODE I
801: * +------------------------------------+
802: * I FARGS I
803: * +------------------------------------+
804: * / /
805: * / REST OF FUNCTION BLOCK /
806: * / /
807: * +------------------------------------+
808: *
809: FCODE EQU 0 POINTER TO CODE FOR FUNCTION
810: FARGS EQU 1 NUMBER OF ARGUMENTS
811: *
812: * FCODE IS A POINTER TO THE LOCATION IN THE INTERPRETOR
813: * PROGRAM WHICH PROCESSES THIS TYPE OF FUNCTION CALL.
814: *
815: * FARGS IS THE EXPECTED NUMBER OF ARGUMENTS. THE ACTUAL
816: * NUMBER OF ARGUMENTS IS ADJUSTED TO THIS AMOUNT BY
817: * DELETING EXTRA ARGUMENTS OR SUPPLYING TRAILING NULLS
818: * FOR MISSING ONES BEFORE TRANSFERRING THOUGH FCODE.
819: * A VALUE OF 999 MAY BE USED IN THIS FIELD TO INDICATE A
820: * VARIABLE NUMBER OF ARGUMENTS (SEE SVBLK FIELD SVNAR).
821: *
822: * THE BLOCK TYPES WHICH FOLLOW THIS SCHEME ARE.
823: *
824: * FFBLK FIELD FUNCTION
825: * DFBLK DATATYPE FUNCTION
826: * PFBLK PROGRAM DEFINED FUNCTION
827: * EFBLK EXTERNAL LOADED FUNCTION
828: EJC
829: *
830: * IDENTIFICATION FIELD
831: *
832: *
833: * ID FIELD
834: *
835: * CERTAIN PROGRAM ACCESSIBLE OBJECTS (THOSE WHICH CONTAIN
836: * OTHER DATA VALUES AND CAN BE COPIED) ARE GIVEN A UNIQUE
837: * IDENTIFICATION NUMBER (SEE EXSID). THIS ID VALUE IS AN
838: * ADDRESS INTEGER VALUE WHICH IS ALWAYS STORED IN WORD TWO.
839: *
840: IDVAL EQU 1 ID VALUE FIELD
841: *
842: * THE BLOCKS CONTAINING AN IDVAL FIELD ARE.
843: *
844: * ARBLK ARRAY
845: * PDBLK PROGRAM DEFINED DATATYPE
846: * TBBLK TABLE
847: * VCBLK VECTOR BLOCK (ARRAY)
848: *
849: * NOTE THAT A ZERO IDVAL MEANS THAT THE BLOCK IS ONLY
850: * HALF BUILT AND SHOULD NOT BE DUMPED (SEE DUMPR).
851: EJC
852: *
853: * ARRAY BLOCK (ARBLK)
854: *
855: * AN ARRAY BLOCK REPRESENTS AN ARRAY VALUE OTHER THAN ONE
856: * WITH ONE DIMENSION WHOSE LOWER BOUND IS ONE (SEE VCBLK).
857: * AN ARBLK IS BUILT WITH A CALL TO THE FUNCTIONS CONVERT
858: * (S$CNV) OR ARRAY (S$ARR).
859: *
860: * +------------------------------------+
861: * I ARTYP I
862: * +------------------------------------+
863: * I IDVAL I
864: * +------------------------------------+
865: * I ARLEN I
866: * +------------------------------------+
867: * I AROFS I
868: * +------------------------------------+
869: * I ARNDM I
870: * +------------------------------------+
871: * * ARLBD *
872: * +------------------------------------+
873: * * ARDIM *
874: * +------------------------------------+
875: * * *
876: * * ABOVE 2 FLDS REPEATED FOR EACH DIM *
877: * * *
878: * +------------------------------------+
879: * I ARPRO I
880: * +------------------------------------+
881: * / /
882: * / ARVLS /
883: * / /
884: * +------------------------------------+
885: EJC
886: *
887: * ARRAY BLOCK (CONTINUED)
888: *
889: ARTYP EQU 0 POINTER TO DUMMY ROUTINE B$ART
890: ARLEN EQU IDVAL+1 LENGTH OF ARBLK IN BAUS
891: AROFS EQU ARLEN+1 OFFSET IN ARBLK TO ARPRO FIELD
892: ARNDM EQU AROFS+1 NUMBER OF DIMENSIONS
893: ARLBD EQU ARNDM+1 LOW BOUND (FIRST SUBSCRIPT)
894: ARDIM EQU ARLBD+CFP$I DIMENSION (FIRST SUBSCRIPT)
895: ARLB2 EQU ARDIM+CFP$I LOW BOUND (SECOND SUBSCRIPT)
896: ARDM2 EQU ARLB2+CFP$I DIMENSION (SECOND SUBSCRIPT)
897: ARPRO EQU ARDIM+CFP$I ARRAY PROTOTYPE (ONE DIMENSION)
898: ARVLS EQU ARPRO+1 START OF VALUES (ONE DIMENSION)
899: ARPR2 EQU ARDM2+CFP$I ARRAY PROTOTYPE (TWO DIMENSIONS)
900: ARVL2 EQU ARPR2+1 START OF VALUES (TWO DIMENSIONS)
901: ARSI$ EQU ARLBD NUMBER OF STANDARD FIELDS IN BLOCK
902: ARDMS EQU ARLB2-ARLBD SIZE OF INFO FOR ONE SET OF BOUNDS
903: *
904: * THE BOUNDS AND DIMENSION FIELDS ARE SIGNED INTEGER
905: * VALUES AND EACH OCCUPY CFP$I WORDS IN THE ARBLK.
906: *
907: * THE LENGTH OF AN ARBLK IN BAUS MAY NOT EXCEED MXLEN.
908: * THIS IS REQUIRED TO KEEP NAME OFFSETS GARBAGE COLLECTABLE
909: *
910: * THE ACTUAL VALUES ARE ARRANGED IN ROW-WISE ORDER AND
911: * CAN CONTAIN A DATA POINTER OR A POINTER TO A TRBLK.
912: .IF .CNBF
913: .ELSE
914: EJC
915: * BUFFER CONTROL BLOCK (BCBLK)
916: *
917: * A BCBLK IS BUILT FOR EVERY BFBLK.
918: *
919: * +------------------------------------+
920: * I BCTYP I
921: * +------------------------------------+
922: * I IDVAL I
923: * +------------------------------------+
924: * I BCLEN I
925: * +------------------------------------+
926: * I BCBUF I
927: * +------------------------------------+
928: *
929: BCTYP EQU 0 PTR TO DUMMY ROUTINE B$BCT
930: BCLEN EQU IDVAL+1 DEFINED BUFFER LENGTH
931: BCBUF EQU BCLEN+1 PTR TO BFBLK
932: BCSI$ EQU BCBUF+1 SIZE OF BCBLK
933: *
934: * A BCBLK IS AN INDIRECT CONTROL HEADER FOR BFBLK.
935: * THE REASON FOR NOT STORING THIS DATA DIRECTLY
936: * IN THE RELATED BFBLK IS SO THAT THE BFBLK CAN
937: * MAINTAIN THE SAME SKELETAL STRUCTURE AS AN SCBLK
938: * THUS FACILITATING TRANSPARENT STRING OPERATIONS
939: * (FOR THE MOST PART). SPECIFICALLY, CFP$F IS THE
940: * SAME FOR A BFBLK AS FOR AN SCBLK. BY CONVENTION,
941: * WHEREEVER A BUFFER VALUE IS EMPLOYED, THE BCBLK
942: * IS POINTED TO.
943: *
944: * THE CORRESPONDING BFBLK IS POINTED TO BY THE
945: * BCBUF POINTER IN THE BCBLK.
946: *
947: * BCLEN IS THE CURRENT DEFINED SIZE OF THE CHARACTER
948: * ARRAY IN THE BFBLK. CHARACTERS FOLLOWING THE OFFSET
949: * OF BCLEN ARE UNDEFINED.
950: *
951: EJC
952: *
953: * STRING BUFFER BLOCK (BFBLK)
954: *
955: * A BFBLK IS BUILT BY A CALL TO BUFFER(...)
956: *
957: * +------------------------------------+
958: * I BFTYP I
959: * +------------------------------------+
960: * I BFALC I
961: * +------------------------------------+
962: * / /
963: * / BFCHR /
964: * / /
965: * +------------------------------------+
966: *
967: BFTYP EQU 0 PTR TO DUMMY ROUTINE B$BFT
968: BFALC EQU BFTYP+1 ALLOCATED SIZE OF BUFFER
969: BFCHR EQU BFALC+1 CHARACTERS OF STRING
970: BFSI$ EQU BFCHR SIZE OF STANDARD FIELDS IN BFBLK
971: *
972: * THE CHARACTERS IN THE BUFFER ARE STORED LEFT JUSTIFIED.
973: * THE FINAL WORD OF DEFINED CHARACTERS IS ALWAYS ZERO
974: * (CHARACTER) PADDED. ANY TRAILING ALLOCATION PAST THE
975: * WORD CONTAINING THE LAST CHARACTER CONTAINS
976: * UNPREDICTABLE CONTENTS AND IS NEVER REFERENCED.
977: *
978: * NOTE THAT THE OFFSET TO THE CHARACTERS OF THE STRING
979: * IS GIVEN BY CFP$F, AS WITH AN SCBLK. HOWEVER, THE
980: * OFFSET WHICH IS OCCUPIED BY THE LENGTH FOR AN SCBLK
981: * IS THE TOTAL CHAR SPACE FOR BFBLKS, AND ROUTINES WHICH
982: * DEAL WITH BOTH MUST ACCOUNT FOR THIS DIFFERENCE.
983: *
984: * THE VALUE OF BFALC MAY NOT EXCEED MXLEN. THE VALUE OF
985: * BCLEN IS ALWAYS LESS THAN OR EQUAL TO BFALC.
986: *
987: .FI
988: EJC
989: *
990: * CODE CONSTRUCTION BLOCK (CCBLK)
991: *
992: * AT ANY ONE MOMENT THERE IS AT MOST ONE CCBLK INTO
993: * WHICH THE COMPILER IS CURRENTLY STORING CODE (CDWRD).
994: *
995: * +------------------------------------+
996: * I CCTYP I
997: * +------------------------------------+
998: * I CCLEN I
999: * +------------------------------------+
1000: * I CCUSE I
1001: * +------------------------------------+
1002: * / /
1003: * / CCCOD /
1004: * / /
1005: * +------------------------------------+
1006: *
1007: CCTYP EQU 0 POINTER TO DUMMY ROUTINE B$CCT
1008: CCLEN EQU CCTYP+1 LENGTH OF CCBLK IN BAUS
1009: CCUSE EQU CCLEN+1 OFFSET PAST LAST USED WORD (BAUS)
1010: CCCOD EQU CCUSE+1 START OF GENERATED CODE IN BLOCK
1011: *
1012: * THE REASON THAT THE CCBLK IS A SEPARATE BLOCK TYPE FROM
1013: * THE USUAL CDBLK IS THAT THE GARBAGE COLLECTOR MUST
1014: * ONLY PROCESS THOSE FIELDS WHICH HAVE BEEN SET (SEE GBCPF)
1015: EJC
1016: *
1017: * CODE BLOCK (CDBLK)
1018: *
1019: * A CODE BLOCK IS BUILT FOR EACH STATEMENT COMPILED DURING
1020: * THE INITIAL COMPILATION OR BY SUBSEQUENT CALLS TO CODE.
1021: *
1022: * +------------------------------------+
1023: * I CDJMP I
1024: * +------------------------------------+
1025: * I CDSTM I
1026: * +------------------------------------+
1027: * I CDLEN I
1028: * +------------------------------------+
1029: * I CDFAL I
1030: * +------------------------------------+
1031: * / /
1032: * / CDCOD /
1033: * / /
1034: * +------------------------------------+
1035: *
1036: CDJMP EQU 0 PTR TO ROUTINE TO EXECUTE STATEMENT
1037: CDSTM EQU CDJMP+1 STATEMENT NUMBER
1038: CDLEN EQU OFFS2 LENGTH OF CDBLK IN BAUS
1039: CDFAL EQU OFFS3 FAILURE EXIT (SEE BELOW)
1040: CDCOD EQU CDFAL+1 EXECUTABLE PSEUDO-CODE
1041: CDSI$ EQU CDCOD NUMBER OF STANDARD FIELDS IN CDBLK
1042: *
1043: * CDSTM IS THE STATEMENT NUMBER OF THE CURRENT STATEMENT.
1044: *
1045: * CDJMP, CDFAL ARE SET AS FOLLOWS.
1046: *
1047: * 1) IF THE FAILURE EXIT IS THE NEXT STATEMENT
1048: *
1049: * CDJMP = B$CDS
1050: * CDFAL = PTR TO CDBLK FOR NEXT STATEMENT
1051: *
1052: * 2) IF THE FAILURE EXIT IS A SIMPLE LABEL NAME
1053: *
1054: * CDJMP = B$CDS
1055: * CDFAL IS A PTR TO THE VRTRA FIELD OF THE VRBLK
1056: *
1057: * 3) IF THERE IS NO FAILURE EXIT (-NOFAIL MODE)
1058: *
1059: * CDJMP = B$CDS
1060: * CDFAL = O$UNF
1061: *
1062: * 4) IF THE FAILURE EXIT IS COMPLEX OR DIRECT
1063: *
1064: * CDJMP = B$CDC
1065: * CDFAL IS THE OFFSET TO THE O$GOF WORD
1066: EJC
1067: *
1068: * CODE BLOCK (CONTINUED)
1069: *
1070: * CDCOD IS THE START OF THE ACTUAL CODE. FIRST WE DESCRIBE
1071: * THE CODE GENERATED FOR AN EXPRESSION. IN AN EXPRESSION,
1072: * ELEMENTS ARE FETCHED BY NAME OR BY VALUE. FOR EXAMPLE,
1073: * THE BINARY EQUAL OPERATOR FETCHES ITS LEFT ARGUMENT
1074: * BY NAME AND ITS RIGHT ARGUMENT BY VALUE. THESE TWO
1075: * CASES GENERATE QUITE DIFFERENT CODE AND ARE DESCRIBED
1076: * SEPARATELY. FIRST WE CONSIDER THE CODE BY VALUE CASE.
1077: *
1078: * GENERATION OF CODE BY VALUE FOR EXPRESSIONS ELEMENTS.
1079: *
1080: * EXPRESSION POINTER TO EXBLK OR SEBLK
1081: *
1082: * INTEGER CONSTANT POINTER TO ICBLK
1083: *
1084: * NULL CONSTANT POINTER TO NULLS
1085: *
1086: * PATTERN (RESULTING FROM PREEVALUATION)
1087: * =O$LPT
1088: * POINTER TO P0BLK,P1BLK OR P2BLK
1089: *
1090: * REAL CONSTANT POINTER TO RCBLK
1091: *
1092: * STRING CONSTANT POINTER TO SCBLK
1093: *
1094: * VARIABLE POINTER TO VRGET FIELD OF VRBLK
1095: *
1096: * ADDITION VALUE CODE FOR LEFT OPERAND
1097: * VALUE CODE FOR RIGHT OPERAND
1098: * =O$ADD
1099: *
1100: * AFFIRMATION VALUE CODE FOR OPERAND
1101: * =O$AFF
1102: *
1103: * ALTERNATION VALUE CODE FOR LEFT OPERAND
1104: * VALUE CODE FOR RIGHT OPERAND
1105: * =O$ALT
1106: *
1107: * ARRAY REFERENCE (CASE OF ONE SUBSCRIPT)
1108: * VALUE CODE FOR ARRAY OPERAND
1109: * VALUE CODE FOR SUBSCRIPT OPERAND
1110: * =O$AOV
1111: *
1112: * (CASE OF MORE THAN ONE SUBSCRIPT)
1113: * VALUE CODE FOR ARRAY OPERAND
1114: * VALUE CODE FOR FIRST SUBSCRIPT
1115: * VALUE CODE FOR SECOND SUBSCRIPT
1116: * ...
1117: * VALUE CODE FOR LAST SUBSCRIPT
1118: * =O$AMV
1119: * NUMBER OF SUBSCRIPTS
1120: EJC
1121: *
1122: * CODE BLOCK (CONTINUED)
1123: *
1124: * ASSIGNMENT (TO NATURAL VARIABLE)
1125: * VALUE CODE FOR RIGHT OPERAND
1126: * POINTER TO VRSTO FIELD OF VRBLK
1127: *
1128: * (TO ANY OTHER VARIABLE)
1129: * NAME CODE FOR LEFT OPERAND
1130: * VALUE CODE FOR RIGHT OPERAND
1131: * =O$ASS
1132: *
1133: * COMPILE ERROR =O$CER
1134: *
1135: *
1136: * COMPLEMENTATION VALUE CODE FOR OPERAND
1137: * =O$COM
1138: *
1139: * CONCATENATION (CASE OF PRED FUNC LEFT OPERAND)
1140: * VALUE CODE FOR LEFT OPERAND
1141: * =O$POP
1142: * VALUE CODE FOR RIGHT OPERAND
1143: *
1144: * (ALL OTHER CASES)
1145: * VALUE CODE FOR LEFT OPERAND
1146: * VALUE CODE FOR RIGHT OPERAND
1147: * =O$CNC
1148: *
1149: * CURSOR ASSIGNMENT NAME CODE FOR OPERAND
1150: * =O$CAS
1151: *
1152: * DIVISION VALUE CODE FOR LEFT OPERAND
1153: * VALUE CODE FOR RIGHT OPERAND
1154: * =O$DVD
1155: *
1156: * EXPONENTIATION VALUE CODE FOR LEFT OPERAND
1157: * VALUE CODE FOR RIGHT OPERAND
1158: * =O$EXP
1159: *
1160: * FUNCTION CALL (CASE OF CALL TO SYSTEM FUNCTION)
1161: * VALUE CODE FOR FIRST ARGUMENT
1162: * VALUE CODE FOR SECOND ARGUMENT
1163: * ...
1164: * VALUE CODE FOR LAST ARGUMENT
1165: * POINTER TO SVFNC FIELD OF SVBLK
1166: *
1167: EJC
1168: *
1169: * CODE BLOCK (CONTINUED)
1170: *
1171: * FUNCTION CALL (CASE OF NON-SYSTEM FUNCTION 1 ARG)
1172: * VALUE CODE FOR ARGUMENT
1173: * =O$FNS
1174: * POINTER TO VRBLK FOR FUNCTION
1175: *
1176: * (NON-SYSTEM FUNCTION, GT 1 ARG)
1177: * VALUE CODE FOR FIRST ARGUMENT
1178: * VALUE CODE FOR SECOND ARGUMENT
1179: * ...
1180: * VALUE CODE FOR LAST ARGUMENT
1181: * =O$FNC
1182: * NUMBER OF ARGUMENTS
1183: * POINTER TO VRBLK FOR FUNCTION
1184: *
1185: * IMMEDIATE ASSIGNMENT VALUE CODE FOR LEFT OPERAND
1186: * NAME CODE FOR RIGHT OPERAND
1187: * =O$IMA
1188: *
1189: * INDIRECTION VALUE CODE FOR OPERAND
1190: * =O$INV
1191: *
1192: * INTERROGATION VALUE CODE FOR OPERAND
1193: * =O$INT
1194: *
1195: * KEYWORD REFERENCE NAME CODE FOR OPERAND
1196: * =O$KWV
1197: *
1198: * MULTIPLICATION VALUE CODE FOR LEFT OPERAND
1199: * VALUE CODE FOR RIGHT OPERAND
1200: * =O$MLT
1201: *
1202: * NAME REFERENCE (NATURAL VARIABLE CASE)
1203: * POINTER TO NMBLK FOR NAME
1204: *
1205: * (ALL OTHER CASES)
1206: * NAME CODE FOR OPERAND
1207: * =O$NAM
1208: *
1209: * NEGATION =O$NTA
1210: * CDBLK OFFSET OF O$NTC WORD
1211: * VALUE CODE FOR OPERAND
1212: * =O$NTB
1213: * =O$NTC
1214: EJC
1215: *
1216: * CODE BLOCK (CONTINUED)
1217: *
1218: * PATTERN ASSIGNMENT VALUE CODE FOR LEFT OPERAND
1219: * NAME CODE FOR RIGHT OPERAND
1220: * =O$PAS
1221: *
1222: * PATTERN MATCH VALUE CODE FOR LEFT OPERAND
1223: * VALUE CODE FOR RIGHT OPERAND
1224: * =O$PMV
1225: *
1226: * PATTERN REPLACEMENT NAME CODE FOR SUBJECT
1227: * VALUE CODE FOR PATTERN
1228: * =O$PMN
1229: * VALUE CODE FOR REPLACEMENT
1230: * =O$RPL
1231: *
1232: * SELECTION (FOR FIRST ALTERNATIVE)
1233: * =O$SLA
1234: * CDBLK OFFSET TO NEXT O$SLC WORD
1235: * VALUE CODE FOR FIRST ALTERNATIVE
1236: * =O$SLB
1237: * CDBLK OFFSET PAST ALTERNATIVES
1238: *
1239: * (FOR SUBSEQUENT ALTERNATIVES)
1240: * =O$SLC
1241: * CDBLK OFFSET TO NEXT O$SLC,O$SLD
1242: * VALUE CODE FOR ALTERNATIVE
1243: * =O$SLB
1244: * OFFSET IN CDBLK PAST ALTERNATIVES
1245: *
1246: * (FOR LAST ALTERNATIVE)
1247: * =O$SLD
1248: * VALUE CODE FOR LAST ALTERNATIVE
1249: *
1250: * SUBTRACTION VALUE CODE FOR LEFT OPERAND
1251: * VALUE CODE FOR RIGHT OPERAND
1252: * =O$SUB
1253: EJC
1254: *
1255: * CODE BLOCK (CONTINUED)
1256: *
1257: * GENERATION OF CODE BY NAME FOR EXPRESSION ELEMENTS.
1258: *
1259: * VARIABLE =O$LVN
1260: * POINTER TO VRBLK
1261: *
1262: * EXPRESSION (CASE OF *NATURAL VARIABLE)
1263: * =O$LVN
1264: * POINTER TO VRBLK
1265: *
1266: * (ALL OTHER CASES)
1267: * =O$LEX
1268: * POINTER TO EXBLK
1269: *
1270: *
1271: * ARRAY REFERENCE (CASE OF ONE SUBSCRIPT)
1272: * VALUE CODE FOR ARRAY OPERAND
1273: * VALUE CODE FOR SUBSCRIPT OPERAND
1274: * =O$AON
1275: *
1276: * (CASE OF MORE THAN ONE SUBSCRIPT)
1277: * VALUE CODE FOR ARRAY OPERAND
1278: * VALUE CODE FOR FIRST SUBSCRIPT
1279: * VALUE CODE FOR SECOND SUBSCRIPT
1280: * ...
1281: * VALUE CODE FOR LAST SUBSCRIPT
1282: * =O$AMN
1283: * NUMBER OF SUBSCRIPTS
1284: *
1285: * COMPILE ERROR =O$CER
1286: *
1287: * FUNCTION CALL (SAME CODE AS FOR VALUE CALL)
1288: * =O$FNE
1289: *
1290: * INDIRECTION VALUE CODE FOR OPERAND
1291: * =O$INN
1292: *
1293: * KEYWORD REFERENCE NAME CODE FOR OPERAND
1294: * =O$KWN
1295: *
1296: * ANY OTHER OPERAND IS AN ERROR IN A NAME POSITION
1297: *
1298: * NOTE THAT IN THIS DESCRIPTION, =O$XXX REFERS TO THE
1299: * GENERATION OF A WORD CONTAINING THE ADDRESS OF ANOTHER
1300: * WORD WHICH CONTAINS THE ENTRY POINT ADDRESS O$XXX.
1301: EJC
1302: *
1303: * CODE BLOCK (CONTINUED)
1304: *
1305: * NOW WE CONSIDER THE OVERALL STRUCTURE OF THE CODE BLOCK
1306: * FOR A STATEMENT WITH POSSIBLE GOTO FIELDS.
1307: *
1308: * FIRST COMES THE CODE FOR THE STATEMENT BODY.
1309: * THE STATEMENT BODY IS AN EXPRESSION TO BE EVALUATED
1310: * BY VALUE ALTHOUGH THE VALUE IS NOT ACTUALLY REQUIRED.
1311: * NORMAL VALUE CODE IS GENERATED FOR THE BODY OF THE
1312: * STATEMENT EXCEPT IN THE CASE OF A PATTERN MATCH BY
1313: * VALUE, IN WHICH CASE THE FOLLOWING IS GENERATED.
1314: *
1315: * VALUE CODE FOR LEFT OPERAND
1316: * VALUE CODE FOR RIGHT OPERAND
1317: * =O$PMS
1318: *
1319: * NEXT WE HAVE THE CODE FOR THE SUCCESS GOTO. THERE ARE
1320: * SEVERAL CASES AS FOLLOWS.
1321: *
1322: * 1) NO SUCCESS GOTO PTR TO CDBLK FOR NEXT STATEMENT
1323: *
1324: * 2) SIMPLE LABEL PTR TO VRTRA FIELD OF VRBLK
1325: *
1326: * 3) COMPLEX GOTO (CODE BY NAME FOR GOTO OPERAND)
1327: * =O$GOC
1328: *
1329: * 4) DIRECT GOTO (CODE BY VALUE FOR GOTO OPERAND)
1330: * =O$GOD
1331: *
1332: * FOLLOWING THIS WE GENERATE CODE FOR THE FAILURE GOTO IF
1333: * IT IS DIRECT OR IF IT IS COMPLEX, SIMPLE FAILURE GOTOS
1334: * HAVING BEEN HANDLED BY AN APPROPRIATE SETTING OF THE
1335: * CDFAL FIELD OF THE CDBLK. THE GENERATED CODE IS ONE
1336: * OF THE FOLLOWING.
1337: *
1338: * 1) COMPLEX FGOTO =O$FIF
1339: * =O$GOF
1340: * NAME CODE FOR GOTO OPERAND
1341: * =O$GOC
1342: *
1343: * 2) DIRECT FGOTO =O$FIF
1344: * =O$GOF
1345: * VALUE CODE FOR GOTO OPERAND
1346: * =O$GOD
1347: *
1348: * AN OPTIMIZATION OCCURS IF THE SUCCESS AND FAILURE GOTOS
1349: * ARE IDENTICAL AND EITHER COMPLEX OR DIRECT. IN THIS CASE,
1350: * NO CODE IS GENERATED FOR THE SUCCESS GOTO AND CONTROL
1351: * IS ALLOWED TO FALL INTO THE FAILURE GOTO ON SUCCESS.
1352: EJC
1353: *
1354: * COMPILER BLOCK (CMBLK)
1355: *
1356: * A COMPILER BLOCK (CMBLK) IS BUILT BY EXPAN TO REPRESENT
1357: * ONE NODE OF A TREE STRUCTURED EXPRESSION REPRESENTATION.
1358: *
1359: * +------------------------------------+
1360: * I CMIDN I
1361: * +------------------------------------+
1362: * I CMLEN I
1363: * +------------------------------------+
1364: * I CMTYP I
1365: * +------------------------------------+
1366: * I CMOPN I
1367: * +------------------------------------+
1368: * / CMVLS OR CMROP /
1369: * / /
1370: * / CMLOP /
1371: * / /
1372: * +------------------------------------+
1373: *
1374: CMIDN EQU 0 POINTER TO DUMMY ROUTINE B$CMT
1375: CMLEN EQU CMIDN+1 LENGTH OF CMBLK IN BAUS
1376: CMTYP EQU CMLEN+1 TYPE (C$XXX, SEE LIST BELOW)
1377: CMOPN EQU CMTYP+1 OPERAND POINTER (SEE BELOW)
1378: CMVLS EQU CMOPN+1 OPERAND VALUE POINTERS (SEE BELOW)
1379: CMROP EQU CMVLS RIGHT (ONLY) OPERATOR OPERAND
1380: CMLOP EQU CMVLS+1 LEFT OPERATOR OPERAND
1381: CMSI$ EQU CMVLS NUMBER OF STANDARD FIELDS IN CMBLK
1382: CMUS$ EQU CMSI$+1 SIZE OF UNARY OPERATOR CMBLK
1383: CMBS$ EQU CMSI$+2 SIZE OF BINARY OPERATOR CMBLK
1384: CMAR1 EQU CMVLS+1 ARRAY SUBSCRIPT POINTERS
1385: *
1386: * THE CMOPN AND CMVLS FIELDS ARE SET AS FOLLOWS
1387: *
1388: * ARRAY REFERENCE CMOPN = PTR TO ARRAY OPERAND
1389: * CMVLS = PTRS TO SUBSCRIPT OPERANDS
1390: *
1391: * FUNCTION CALL CMOPN = PTR TO VRBLK FOR FUNCTION
1392: * CMVLS = PTRS TO ARGUMENT OPERANDS
1393: *
1394: * SELECTION CMOPN = ZERO
1395: * CMVLS = PTRS TO ALTERNATE OPERANDS
1396: *
1397: * UNARY OPERATOR CMOPN = PTR TO OPERATOR DVBLK
1398: * CMROP = PTR TO OPERAND
1399: *
1400: * BINARY OPERATOR CMOPN = PTR TO OPERATOR DVBLK
1401: * CMROP = PTR TO RIGHT OPERAND
1402: * CMLOP = PTR TO LEFT OPERAND
1403: EJC
1404: *
1405: * CMTYP IS SET TO INDICATE THE TYPE OF EXPRESSION ELEMENT
1406: * AS SHOWN BY THE FOLLOWING TABLE OF DEFINITIONS.
1407: *
1408: C$ARR EQU 0 ARRAY REFERENCE
1409: C$FNC EQU C$ARR+1 FUNCTION CALL
1410: C$DEF EQU C$FNC+1 DEFERRED EXPRESSION (UNARY *)
1411: C$IND EQU C$DEF+1 INDIRECTION (UNARY $)
1412: C$KEY EQU C$IND+1 KEYWORD REFERENCE (UNARY AMPERSAND)
1413: C$UBO EQU C$KEY+1 UNDEFINED BINARY OPERATOR
1414: C$UUO EQU C$UBO+1 UNDEFINED UNARY OPERATOR
1415: C$UO$ EQU C$UUO+1 TEST VALUE (=C$UUO+1=C$UBO+2)
1416: C$$NM EQU C$UUO+1 NUMBER OF CODES FOR NAME OPERANDS
1417: *
1418: * THE REMAINING TYPES INDICATE EXPRESSION ELEMENTS WHICH
1419: * CAN ONLY BE EVALUATED BY VALUE (NOT BY NAME).
1420: *
1421: C$BVL EQU C$UUO+1 BINARY OP WITH VALUE OPERANDS
1422: C$UVL EQU C$BVL+1 UNARY OPERATOR WITH VALUE OPERAND
1423: C$ALT EQU C$UVL+1 ALTERNATION (BINARY BAR)
1424: C$CNC EQU C$ALT+1 CONCATENATION
1425: C$CNP EQU C$CNC+1 CONCATENATION, NOT PATTERN MATCH
1426: C$UNM EQU C$CNP+1 UNARY OP WITH NAME OPERAND
1427: C$BVN EQU C$UNM+1 BINARY OP (OPERANDS BY VALUE, NAME)
1428: C$ASS EQU C$BVN+1 ASSIGNMENT
1429: C$INT EQU C$ASS+1 INTERROGATION
1430: C$NEG EQU C$INT+1 NEGATION (UNARY NOT)
1431: C$SEL EQU C$NEG+1 SELECTION
1432: C$PMT EQU C$SEL+1 PATTERN MATCH
1433: *
1434: C$PR$ EQU C$BVN LAST PREEVALUABLE CODE
1435: C$$NV EQU C$PMT+1 NUMBER OF DIFFERENT CMBLK TYPES
1436: EJC
1437: *
1438: * COPY FILE BLOCK (COBLK)
1439: *
1440: * A CHAIN STACK OF COPY BLOCKS IS BUILT FOR EVERY NESTED
1441: * -COPY CONTROL CARD. THE CONTROL BLOCK IS USED TO PRESERVE
1442: * THE INPUT CONTEXT OF THE FILE CONTAINING THE -COPY.
1443: * AS -COPYS ARE ENDED, THESE BLOCKS ARE POPPED OFF THE CHAIN
1444: * AND THE STATE RESTORED. SEE ROUTINES CNCRD, COPND.
1445: *
1446: * +------------------------------------+
1447: * I COTYP I
1448: * +------------------------------------+
1449: * I CONXT I
1450: * +------------------------------------+
1451: * I COIOT I
1452: * +------------------------------------+
1453: * I COTTI I
1454: * +------------------------------------+
1455: * I COCIM I
1456: * +------------------------------------+
1457: * I COSPT I
1458: * +------------------------------------+
1459: * I COSLS I
1460: * +------------------------------------+
1461: * I COSIN I
1462: * +------------------------------------+
1463: * I COSTL I
1464: * +------------------------------------+
1465: *
1466: COTYP EQU 0 POINTER TO DUMMY ROUTINE B$COP
1467: CONXT EQU COTYP+1 POINT TO NEXT (OUTER -COPY) COBLK
1468: COIOT EQU CONXT+1 RECORD IOTAG FOR OSINT
1469: COTTI EQU COIOT+1 RECORD TTINS FLAG
1470: COCIM EQU COTTI+1 RECORD R$CIM COMPILER IMAGE
1471: COSPT EQU COCIM+1 RECORD SCNPT SCAN POINTER
1472: COSLS EQU COSPT+1 RECORD CSWLS LISTING FLAG
1473: COSIN EQU COSLS+1 RECORD CSWIN -INXXX VALUE
1474: COSTL EQU COSIN+1 RECORD R$STL -STITL STRING PTR
1475: COSI$ EQU COSTL+1 SIZE OF COBLK
1476: EJC
1477: *
1478: * CHARACTER TABLE BLOCK (CTBLK)
1479: *
1480: * A CHARACTER TABLE BLOCK IS USED TO HOLD LOGICAL CHARACTER
1481: * TABLES FOR USE WITH ANY,NOTANY,SPAN,BREAK,BREAKX
1482: * PATTERNS. EACH CHARACTER TABLE CAN BE USED TO STORE
1483: * CFP$N DISTINCT TABLES AS BIT COLUMNS. A BIT COLUMN
1484: * ALLOCATED FOR EACH ARGUMENT OF MORE THAN ONE CHARACTER
1485: * IN LENGTH TO ONE OF THE ABOVE LISTED PATTERN PRIMITIVES.
1486: *
1487: * +------------------------------------+
1488: * I CTTYP I
1489: * +------------------------------------+
1490: * * *
1491: * * *
1492: * * CTCHS *
1493: * * *
1494: * * *
1495: * +------------------------------------+
1496: *
1497: CTTYP EQU 0 POINTER TO DUMMY ROUTINE B$CTT
1498: CTCHS EQU CTTYP+1 START OF CHARACTER TABLE WORDS
1499: CTSI$ EQU CTCHS+CFP$A NUMBER OF WORDS IN CTBLK
1500: *
1501: * CTCHS IS CFP$A WORDS LONG AND CONSISTS OF A ONE WORD
1502: * BIT STRING VALUE FOR EACH POSSIBLE CHARACTER IN THE
1503: * INTERNAL ALPHABET. EACH OF THE CFP$N POSSIBLE BITS IN
1504: * A BITSTRING IS USED TO FORM A COLUMN OF BIT INDICATORS.
1505: * A BIT IS SET ON IF THE CHARACTER IS IN THE TABLE AND OFF
1506: * IF THE CHARACTER IS NOT PRESENT.
1507: EJC
1508: *
1509: * DATATYPE FUNCTION BLOCK (DFBLK)
1510: *
1511: * A DATATYPE FUNCTION IS USED TO CONTROL THE CONSTRUCTION
1512: * OF A PROGRAM DEFINED DATATYPE OBJECT. A CALL TO THE
1513: * SYSTEM FUNCTION DATA BUILDS A DFBLK FOR THE DATATYPE NAME
1514: *
1515: * NOTE THAT THESE BLOCKS ARE BUILT IN STATIC BECAUSE PDBLK
1516: * LENGTH IS GOT FROM DFLEN FIELD. IF DFBLK WAS IN DYNAMIC
1517: * STORE THIS WOULD CAUSE TROUBLE DURING PASS TWO OF GARBAGE
1518: * COLLECTION. SCBLK REFERRED TO BY DFNAM FIELD IS ALSO PUT
1519: * IN STATIC SO THAT THERE ARE NO RELOC. FIELDS. THIS CUTS
1520: * GARBAGE COLLECTION TASK APPRECIABLY FOR PDBLKS WHICH ARE
1521: * LIKELY TO BE PRESENT IN LARGE NUMBERS.
1522: *
1523: * +------------------------------------+
1524: * I FCODE I
1525: * +------------------------------------+
1526: * I FARGS I
1527: * +------------------------------------+
1528: * I DFLEN I
1529: * +------------------------------------+
1530: * I DFPDL I
1531: * +------------------------------------+
1532: * I DFNAM I
1533: * +------------------------------------+
1534: * / /
1535: * / DFFLD /
1536: * / /
1537: * +------------------------------------+
1538: *
1539: DFLEN EQU FARGS+1 LENGTH OF DFBLK IN BAUS
1540: DFPDL EQU DFLEN+1 LENGTH OF CORRESPONDING PDBLK
1541: DFNAM EQU DFPDL+1 POINTER TO SCBLK FOR DATATYPE NAME
1542: DFFLD EQU DFNAM+1 START OF VRBLK PTRS FOR FIELD NAMES
1543: DFFLB EQU DFFLD-1 OFFSET BEHIND DFFLD FOR FIELD FUNC
1544: DFSI$ EQU DFFLD NUMBER OF STANDARD FIELDS IN DFBLK
1545: *
1546: * THE FCODE FIELD POINTS TO THE ROUTINE B$DFC
1547: *
1548: * FARGS (THE NUMBER OF ARGUMENTS) IS THE NUMBER OF FIELDS.
1549: EJC
1550: *
1551: * DOPE VECTOR BLOCK (DVBLK)
1552: *
1553: * A DOPE VECTOR IS ASSEMBLED FOR EACH POSSIBLE OPERATOR IN
1554: * THE SNOBOL4 LANGUAGE AS PART OF THE CONSTANT SECTION.
1555: *
1556: * +------------------------------------+
1557: * I DVOPN I
1558: * +------------------------------------+
1559: * I DVTYP I
1560: * +------------------------------------+
1561: * I DVLPR I
1562: * +------------------------------------+
1563: * I DVRPR I
1564: * +------------------------------------+
1565: *
1566: DVOPN EQU 0 ENTRY ADDRESS (PTR TO O$XXX)
1567: DVTYP EQU DVOPN+1 TYPE CODE (C$XXX, SEE CMBLK)
1568: DVLPR EQU DVTYP+1 LEFT PRECEDENCE (LLXXX, SEE BELOW)
1569: DVRPR EQU DVLPR+1 RIGHT PRECEDENCE (RRXXX, SEE BELOW)
1570: DVUS$ EQU DVLPR+1 SIZE OF UNARY OPERATOR DV
1571: DVBS$ EQU DVRPR+1 SIZE OF BINARY OPERATOR DV
1572: DVUBS EQU DVUS$+DVBS$ SIZE OF UNOP + BINOP (SEE SCANE)
1573: *
1574: * THE CONTENTS OF THE DVTYP FIELD IS COPIED INTO THE CMTYP
1575: * FIELD OF THE CMBLK FOR THE OPERATOR IF IT IS USED.
1576: *
1577: * THE CMOPN FIELD OF AN OPERATOR CMBLK POINTS TO THE DVBLK
1578: * ITSELF, PROVIDING THE REQUIRED ENTRY ADDRESS POINTER PTR.
1579: *
1580: * FOR NORMALLY UNDEFINED OPERATORS, THE DVOPN (AND CMOPN)
1581: * FIELDS CONTAIN A WORD OFFSET FROM R$UBA OF THE FUNCTION
1582: * BLOCK POINTER FOR THE OPERATOR (INSTEAD OF O$XXX PTR).
1583: * FOR CERTAIN SPECIAL OPERATORS, THE DVOPN FIELD IS NOT
1584: * REQUIRED AT ALL AND IS ASSEMBLED AS ZERO.
1585: *
1586: * THE LEFT PRECEDENCE IS USED IN COMPARING AN OPERATOR TO
1587: * THE LEFT OF SOME OTHER OPERATOR. IT THEREFORE GOVERNS THE
1588: * PRECEDENCE OF THE OPERATOR TOWARDS ITS RIGHT OPERAND.
1589: *
1590: * THE RIGHT PRECEDENCE IS USED IN COMPARING AN OPERATOR TO
1591: * THE RIGHT OF SOME OTHER OPERATOR. IT THEREFORE GOVERNS
1592: * THE PRECEDENCE OF THE OPERATOR TOWARDS ITS LEFT OPERAND.
1593: *
1594: * HIGHER PRECEDENCE VALUES CORRESPOND TO A TIGHTER BINDING
1595: * CAPABILITY. THUS WE HAVE THE LEFT PRECEDENCE LOWER
1596: * (HIGHER) THAN THE RIGHT PRECEDENCE FOR RIGHT (LEFT)
1597: * ASSOCIATIVE BINARY OPERATORS.
1598: *
1599: * THE LEFT PRECEDENCE OF UNARY OPERATORS IS SET TO AN
1600: * ARBITRARY HIGH VALUE. THE RIGHT VALUE IS NOT REQUIRED AND
1601: * CONSEQUENTLY THE DVRPR FIELD IS OMITTED FOR UNARY OPS.
1602: EJC
1603: *
1604: * TABLE OF OPERATOR PRECEDENCE VALUES
1605: *
1606: RRASS EQU 10 RIGHT EQUAL
1607: LLASS EQU 00 LEFT EQUAL
1608: RRPMT EQU 20 RIGHT QUESTION MARK
1609: LLPMT EQU 30 LEFT QUESTION MARK
1610: RRAMP EQU 40 RIGHT AMPERSAND
1611: LLAMP EQU 50 LEFT AMPERSAND
1612: RRALT EQU 70 RIGHT VERTICAL BAR
1613: LLALT EQU 60 LEFT VERTICAL BAR
1614: RRCNC EQU 90 RIGHT BLANK
1615: LLCNC EQU 80 LEFT BLANK
1616: RRATS EQU 110 RIGHT AT
1617: LLATS EQU 100 LEFT AT
1618: RRPLM EQU 120 RIGHT PLUS, MINUS
1619: LLPLM EQU 130 LEFT PLUS, MINUS
1620: RRNUM EQU 140 RIGHT NUMBER
1621: LLNUM EQU 150 LEFT NUMBER
1622: RRDVD EQU 160 RIGHT SLASH
1623: LLDVD EQU 170 LEFT SLASH
1624: RRMLT EQU 180 RIGHT ASTERISK
1625: LLMLT EQU 190 LEFT ASTERISK
1626: RRPCT EQU 200 RIGHT PERCENT
1627: LLPCT EQU 210 LEFT PERCENT
1628: RREXP EQU 230 RIGHT EXCLAMATION
1629: LLEXP EQU 220 LEFT EXCLAMATION
1630: RRDLD EQU 240 RIGHT DOLLAR, DOT
1631: LLDLD EQU 250 LEFT DOLLAR, DOT
1632: RRNOT EQU 270 RIGHT NOT
1633: LLNOT EQU 260 LEFT NOT
1634: LLUNO EQU 999 LEFT ALL UNARY OPERATORS
1635: *
1636: * PRECEDENCES ARE THE SAME AS IN BTL SNOBOL4 WITH THE
1637: * FOLLOWING EXCEPTIONS.
1638: *
1639: * 1) BINARY QUESTION MARK IS LOWERED AND MADE LEFT ASSOC-
1640: * IATIVE TO REFLECT ITS NEW USE FOR PATTERN MATCHING.
1641: *
1642: * 2) ALTERNATION AND CONCATENATION ARE MADE RIGHT
1643: * ASSOCIATIVE FOR GREATER EFFICIENCY IN PATTERN
1644: * CONSTRUCTION AND MATCHING RESPECTIVELY. THIS CHANGE
1645: * IS TRANSPARENT TO THE SNOBOL4 PROGRAMMER.
1646: *
1647: * 3) THE EQUAL SIGN HAS BEEN ADDED AS A LOW PRECEDENCE
1648: * OPERATOR WHICH IS RIGHT ASSOCIATIVE TO REFLECT ITS
1649: * MORE GENERAL USAGE IN THIS VERSION OF SNOBOL4.
1650: .IF .CNLD
1651: .ELSE
1652: EJC
1653: *
1654: * EXTERNAL FUNCTION BLOCK (EFBLK)
1655: *
1656: * AN EXTERNAL FUNCTION BLOCK IS USED TO CONTROL THE CALLING
1657: * OF AN EXTERNAL FUNCTION. IT IS BUILT BY A CALL TO LOAD.
1658: *
1659: * +------------------------------------+
1660: * I FCODE I
1661: * +------------------------------------+
1662: * I FARGS I
1663: * +------------------------------------+
1664: * I EFLEN I
1665: * +------------------------------------+
1666: * I EFUSE I
1667: * +------------------------------------+
1668: * I EFCOD I
1669: * +------------------------------------+
1670: * I EFVAR I
1671: * +------------------------------------+
1672: * I EFRSL I
1673: * +------------------------------------+
1674: * / /
1675: * / EFTAR /
1676: * / /
1677: * +------------------------------------+
1678: *
1679: EFLEN EQU FARGS+1 LENGTH OF EFBLK IN BAUS
1680: EFUSE EQU EFLEN+1 USE COUNT (FOR OPSYN)
1681: EFCOD EQU EFUSE+1 PTR TO CODE (FROM SYSLD)
1682: EFVAR EQU EFCOD+1 PTR TO ASSOCIATED VRBLK
1683: EFRSL EQU EFVAR+1 RESULT TYPE (SEE BELOW)
1684: EFTAR EQU EFRSL+1 ARGUMENT TYPES (SEE BELOW)
1685: EFSI$ EQU EFTAR NUMBER OF STANDARD FIELDS IN EFBLK
1686: *
1687: * THE FCODE FIELD POINTS TO THE ROUTINE B$EFC.
1688: *
1689: * EFUSE IS USED TO KEEP TRACK OF MULTIPLE USE WHEN OPSYN
1690: * IS EMPLOYED. THE FUNCTION IS AUTOMATICALLY UNLOADED
1691: * WHEN THERE ARE NO MORE REFERENCES TO THE FUNCTION.
1692: *
1693: * EFRSL AND EFTAR ARE TYPE CODES AS FOLLOWS.
1694: *
1695: * 0 TYPE IS UNCONVERTED
1696: * 1 TYPE IS STRING
1697: * 2 TYPE IS INTEGER
1698: * 3 TYPE IS REAL
1699: * 4 TYPE IS BUFFER
1700: .FI
1701: EJC
1702: *
1703: * EXPRESSION VARIABLE BLOCK (EVBLK)
1704: *
1705: * IN THIS VERSION OF SPITBOL, AN EXPRESSION CAN BE USED IN
1706: * ANY POSITION WHICH WOULD NORMALLY EXPECT A NAME (FOR
1707: * EXAMPLE ON THE LEFT SIDE OF EQUALS OR AS THE RIGHT
1708: * ARGUMENT OF BINARY DOT). THIS CORRESPONDS TO THE CREATION
1709: * OF A PSEUDO-VARIABLE WHICH IS REPRESENTED BY A POINTER TO
1710: * AN EXPRESSION VARIABLE BLOCK AS FOLLOWS.
1711: *
1712: * +------------------------------------+
1713: * I EVTYP I
1714: * +------------------------------------+
1715: * I EVEXP I
1716: * +------------------------------------+
1717: * I EVVAR I
1718: * +------------------------------------+
1719: *
1720: EVTYP EQU 0 POINTER TO DUMMY ROUTINE B$EVT
1721: EVEXP EQU EVTYP+1 POINTER TO EXBLK FOR EXPRESSION
1722: EVVAR EQU EVEXP+1 POINTER TO TRBEV DUMMY TRBLK
1723: EVSI$ EQU EVVAR+1 SIZE OF EVBLK
1724: *
1725: * THE NAME OF AN EXPRESSION VARIABLE IS REPRESENTED BY A
1726: * BASE POINTER TO THE EVBLK AND AN OFFSET OF EVVAR. THIS
1727: * VALUE APPEARS TO BE TRAPPED BY THE DUMMY TRBEV BLOCK.
1728: *
1729: * NOTE THAT THERE IS NO NEED TO ALLOW FOR THE CASE OF AN
1730: * EXPRESSION VARIABLE WHICH REFERENCES AN SEBLK SINCE A
1731: * VARIABLE WHICH IS OF THE FORM *VAR IS EQUIVALENT TO VAR.
1732: EJC
1733: *
1734: * EXPRESSION BLOCK (EXBLK)
1735: *
1736: * AN EXPRESSION BLOCK IS BUILT FOR EACH EXPRESSION
1737: * REFERENCED IN A PROGRAM OR CREATED BY EVAL OR CONVERT
1738: * DURING EXECUTION OF A PROGRAM.
1739: *
1740: * +------------------------------------+
1741: * I EXTYP I
1742: * +------------------------------------+
1743: * I EXSTM I
1744: * +------------------------------------+
1745: * I EXLEN I
1746: * +------------------------------------+
1747: * I EXFLC I
1748: * +------------------------------------+
1749: * / /
1750: * / EXCOD /
1751: * / /
1752: * +------------------------------------+
1753: *
1754: EXTYP EQU 0 PTR TO ROUTINE B$EXL TO LOAD EXPR
1755: EXSTM EQU CDSTM STORES STMNT NO. DURING EVALUATION
1756: EXLEN EQU EXSTM+1 LENGTH OF EXBLK IN BAUS
1757: EXFLC EQU EXLEN+1 FAILURE CODE (=O$FEX)
1758: EXCOD EQU EXFLC+1 PSEUDO-CODE FOR EXPRESSION
1759: EXSI$ EQU EXCOD NUMBER OF STANDARD FIELDS IN EXBLK
1760: *
1761: * THERE ARE TWO CASES FOR EXCOD DEPENDING ON WHETHER THE
1762: * EXPRESSION CAN BE EVALUATED BY NAME (SEE DESCRIPTION
1763: * OF CDBLK FOR DETAILS OF CODE FOR EXPRESSIONS).
1764: *
1765: * IF THE EXPRESSION CAN BE EVALUATED BY NAME WE HAVE.
1766: *
1767: * (CODE FOR EXPR BY NAME)
1768: * =O$RNM
1769: *
1770: * IF THE EXPRESSION CAN ONLY BE EVALUATED BY VALUE.
1771: *
1772: * (CODE FOR EXPR BY VALUE)
1773: * =O$RVL
1774: EJC
1775: *
1776: * FIELD FUNCTION BLOCK (FFBLK)
1777: *
1778: * A FIELD FUNCTION BLOCK IS USED TO CONTROL THE SELECTION
1779: * OF A FIELD FROM A PROGRAM DEFINED DATATYPE BLOCK.
1780: * A CALL TO DATA CREATES AN FFBLK FOR EACH FIELD.
1781: *
1782: * +------------------------------------+
1783: * I FCODE I
1784: * +------------------------------------+
1785: * I FARGS I
1786: * +------------------------------------+
1787: * I FFDFP I
1788: * +------------------------------------+
1789: * I FFNXT I
1790: * +------------------------------------+
1791: * I FFOFS I
1792: * +------------------------------------+
1793: *
1794: FFDFP EQU FARGS+1 POINTER TO ASSOCIATED DFBLK
1795: FFNXT EQU FFDFP+1 PTR TO NEXT FFBLK ON CHAIN OR ZERO
1796: FFOFS EQU FFNXT+1 OFFSET (BAUS) TO FIELD IN PDBLK
1797: FFSI$ EQU FFOFS+1 SIZE OF FFBLK IN WORDS
1798: *
1799: * THE FCODE FIELD POINTS TO THE ROUTINE B$FFC.
1800: *
1801: * FARGS ALWAYS CONTAINS ONE.
1802: *
1803: * FFDFP IS USED TO VERIFY THAT THE CORRECT PROGRAM DEFINED
1804: * DATATYPE IS BEING ACCESSED BY THIS CALL.
1805: * FFDFP IS NON-RELOC. BECAUSE DFBLK IS IN STATIC
1806: *
1807: * FFOFS IS USED TO SELECT THE APPROPRIATE FIELD. NOTE THAT
1808: * IT IS AN ACTUAL OFFSET (NOT A FIELD NUMBER)
1809: *
1810: * FFNXT IS USED TO POINT TO THE NEXT FFBLK OF THE SAME NAME
1811: * IN THE CASE WHERE THERE ARE SEVERAL FIELDS OF THE SAME
1812: * NAME FOR DIFFERENT DATATYPES. ZERO MARKS THE END OF CHAIN
1813: EJC
1814: *
1815: * INTEGER CONSTANT BLOCK (ICBLK)
1816: *
1817: * AN ICBLK IS CREATED FOR EVERY INTEGER REFERENCED OR
1818: * CREATED BY A PROGRAM. NOTE HOWEVER THAT CERTAIN INTERNAL
1819: * INTEGER VALUES ARE STORED AS ADDRESSES (E.G. THE LENGTH
1820: * FIELD IN A STRING CONSTANT BLOCK)
1821: *
1822: * +------------------------------------+
1823: * I ICGET I
1824: * +------------------------------------+
1825: * * ICVAL *
1826: * +------------------------------------+
1827: *
1828: ICGET EQU 0 PTR TO ROUTINE B$ICL TO LOAD INT
1829: ICVAL EQU ICGET+1 INTEGER VALUE
1830: ICSI$ EQU ICVAL+CFP$I SIZE OF ICBLK
1831: *
1832: * THE LENGTH OF THE ICVAL FIELD IS CFP$I.
1833: EJC
1834: *
1835: * KEYWORD VARIABLE BLOCK (KVBLK)
1836: *
1837: * A KVBLK IS USED TO REPRESENT A KEYWORD PSEUDO-VARIABLE.
1838: * A KVBLK IS BUILT FOR EACH KEYWORD REFERENCE (KWNAM).
1839: *
1840: * +------------------------------------+
1841: * I KVTYP I
1842: * +------------------------------------+
1843: * I KVVAR I
1844: * +------------------------------------+
1845: * I KVNUM I
1846: * +------------------------------------+
1847: *
1848: KVTYP EQU 0 POINTER TO DUMMY ROUTINE B$KVT
1849: KVVAR EQU KVTYP+1 POINTER TO DUMMY BLOCK TRBKV
1850: KVNUM EQU KVVAR+1 KEYWORD NUMBER
1851: KVSI$ EQU KVNUM+1 SIZE OF KVBLK
1852: *
1853: * THE NAME OF A KEYWORD VARIABLE IS REPRESENTED BY A
1854: * BASE POINTER TO THE KVBLK AND AN OFFSET OF KVVAR. THE
1855: * VALUE APPEARS TO BE TRAPPED BY THE POINTER TO TRBKV.
1856: EJC
1857: *
1858: * NAME BLOCK (NMBLK)
1859: *
1860: * A NAME BLOCK IS USED WHEREVER A NAME MUST BE STORED AS
1861: * A VALUE FOLLOWING USE OF THE UNARY DOT OPERATOR.
1862: *
1863: * +------------------------------------+
1864: * I NMTYP I
1865: * +------------------------------------+
1866: * I NMBAS I
1867: * +------------------------------------+
1868: * I NMOFS I
1869: * +------------------------------------+
1870: *
1871: NMTYP EQU 0 PTR TO ROUTINE B$NML TO LOAD NAME
1872: NMBAS EQU NMTYP+1 BASE POINTER FOR VARIABLE
1873: NMOFS EQU NMBAS+1 OFFSET FOR VARIABLE
1874: NMSI$ EQU NMOFS+1 SIZE OF NMBLK
1875: *
1876: * THE ACTUAL FIELD REPRESENTING THE CONTENTS OF THE NAME
1877: * IS FOUND NMOFS BAUS PAST THE ADDRESS IN NMBAS.
1878: *
1879: * THE NAME IS SPLIT INTO BASE AND OFFSET FORM TO AVOID
1880: * CREATION OF A POINTER INTO THE MIDDLE OF A BLOCK WHICH
1881: * COULD NOT BE HANDLED PROPERLY BY THE GARBAGE COLLECTOR.
1882: *
1883: * A NAME MAY BE BUILT FOR ANY VARIABLE (SEE SECTION ON
1884: * REPRESENTATIONS OF VARIABLES) THIS INCLUDES THE
1885: * CASES OF PSEUDO-VARIABLES.
1886: EJC
1887: *
1888: * PATTERN BLOCK, NO PARAMETERS (P0BLK)
1889: *
1890: * A P0BLK IS USED TO REPRESENT PATTERN NODES WHICH DO
1891: * NOT REQUIRE THE USE OF ANY PARAMETER VALUES.
1892: *
1893: * +------------------------------------+
1894: * I PCODE I
1895: * +------------------------------------+
1896: * I PTHEN I
1897: * +------------------------------------+
1898: *
1899: PCODE EQU 0 PTR TO MATCH ROUTINE (P$XXX)
1900: PTHEN EQU PCODE+1 POINTER TO SUBSEQUENT NODE
1901: PASI$ EQU PTHEN+1 SIZE OF P0BLK
1902: *
1903: * PTHEN POINTS TO THE PATTERN BLOCK FOR THE SUBSEQUENT
1904: * NODE TO BE MATCHED. THIS IS A POINTER TO THE PATTERN
1905: * BLOCK NDNTH IF THERE IS NO SUBSEQUENT (END OF PATTERN)
1906: *
1907: * PCODE IS A POINTER TO THE MATCH ROUTINE FOR THE NODE.
1908: EJC
1909: *
1910: * PATTERN BLOCK (ONE PARAMETER)
1911: *
1912: * A P1BLK IS USED TO REPRESENT PATTERN NODES WHICH
1913: * REQUIRE ONE PARAMETER VALUE.
1914: *
1915: * +------------------------------------+
1916: * I PCODE I
1917: * +------------------------------------+
1918: * I PTHEN I
1919: * +------------------------------------+
1920: * I PARM1 I
1921: * +------------------------------------+
1922: *
1923: PARM1 EQU PTHEN+1 FIRST PARAMETER VALUE
1924: PBSI$ EQU PARM1+1 SIZE OF P1BLK IN WORDS
1925: *
1926: * SEE P0BLK FOR DEFINITIONS OF PCODE, PTHEN
1927: *
1928: * PARM1 CONTAINS A PARAMETER VALUE USED IN MATCHING THE
1929: * NODE. FOR EXAMPLE, IN A LEN PATTERN, IT IS THE INTEGER
1930: * ARGUMENT TO LEN. THE DETAILS OF THE USE OF THE PARAMETER
1931: * FIELD ARE INCLUDED IN THE DESCRIPTION OF THE INDIVIDUAL
1932: * MATCH ROUTINES. PARM1 IS ALWAYS AN ADDRESS POINTER WHICH
1933: * IS PROCESSED BY THE GARBAGE COLLECTOR.
1934: EJC
1935: *
1936: * PATTERN BLOCK (TWO PARAMETERS)
1937: *
1938: * A P2BLK IS USED TO REPRESENT PATTERN NODES WHICH
1939: * REQUIRE TWO PARAMETER VALUES.
1940: *
1941: * +------------------------------------+
1942: * I PCODE I
1943: * +------------------------------------+
1944: * I PTHEN I
1945: * +------------------------------------+
1946: * I PARM1 I
1947: * +------------------------------------+
1948: * I PARM2 I
1949: * +------------------------------------+
1950: *
1951: PARM2 EQU PARM1+1 SECOND PARAMETER VALUE
1952: PCSI$ EQU PARM2+1 SIZE OF P2BLK IN WORDS
1953: *
1954: * SEE P1BLK FOR DEFINITIONS OF PCODE, PTHEN, PARM1
1955: *
1956: * PARM2 IS A PARAMETER WHICH PERFORMS THE SAME SORT OF
1957: * FUNCTION AS PARM1 (SEE DESCRIPTION OF P1BLK).
1958: *
1959: * PARM2 IS A NON-RELOCATABLE FIELD AND IS NOT
1960: * PROCESSED BY THE GARBAGE COLLECTOR. ACCORDINGLY, IT MAY
1961: * NOT CONTAIN A POINTER TO A BLOCK IN DYNAMIC MEMORY.
1962: EJC
1963: *
1964: * PROGRAM-DEFINED DATATYPE BLOCK
1965: *
1966: * A PDBLK REPRESENTS THE DATA ITEM FORMED BY A CALL TO A
1967: * DATATYPE FUNCTION AS DEFINED BY THE SYSTEM FUNCTION DATA.
1968: *
1969: * +------------------------------------+
1970: * I PDTYP I
1971: * +------------------------------------+
1972: * I IDVAL I
1973: * +------------------------------------+
1974: * I PDDFP I
1975: * +------------------------------------+
1976: * / /
1977: * / PDFLD /
1978: * / /
1979: * +------------------------------------+
1980: *
1981: PDTYP EQU 0 PTR TO DUMMY ROUTINE B$PDT
1982: PDDFP EQU IDVAL+1 PTR TO ASSOCIATED DFBLK
1983: PDFLD EQU PDDFP+1 START OF FIELD VALUE POINTERS
1984: PDFOF EQU DFFLD-PDFLD DIFFERENCE IN OFFSET TO FIELD PTRS
1985: PDSI$ EQU PDFLD SIZE OF STANDARD FIELDS IN PDBLK
1986: PDDFS EQU DFSI$-PDSI$ DIFFERENCE IN DFBLK, PDBLK SIZES
1987: *
1988: * THE PDDFP POINTER MAY BE USED TO DETERMINE THE DATATYPE
1989: * AND THE NAMES OF THE FIELDS IF REQUIRED. THE DFBLK ALSO
1990: * CONTAINS THE LENGTH OF THE PDBLK IN BAUS (FIELD DFPDL).
1991: * PDDFP IS NON-RELOC. BECAUSE DFBLK IS IN STATIC
1992: *
1993: * PDFLD VALUES ARE STORED IN ORDER FROM LEFT TO RIGHT.
1994: * THEY CONTAIN VALUES OR POINTERS TO TRBLK CHAINS.
1995: EJC
1996: *
1997: * PROGRAM DEFINED FUNCTION BLOCK (PFBLK)
1998: *
1999: * A PFBLK IS CREATED FOR EACH CALL TO THE DEFINE FUNCTION
2000: * AND A POINTER TO THE PFBLK PLACED IN THE PROPER VRBLK.
2001: *
2002: * +------------------------------------+
2003: * I FCODE I
2004: * +------------------------------------+
2005: * I FARGS I
2006: * +------------------------------------+
2007: * I PFLEN I
2008: * +------------------------------------+
2009: * I PFVBL I
2010: * +------------------------------------+
2011: * I PFNLO I
2012: * +------------------------------------+
2013: * I PFCOD I
2014: * +------------------------------------+
2015: * I PFCTR I
2016: * +------------------------------------+
2017: * I PFRTR I
2018: * +------------------------------------+
2019: * / /
2020: * / PFARG /
2021: * / /
2022: * +------------------------------------+
2023: *
2024: PFLEN EQU FARGS+1 LENGTH OF PFBLK IN BAUS
2025: PFVBL EQU PFLEN+1 POINTER TO VRBLK FOR FUNCTION NAME
2026: PFNLO EQU PFVBL+1 NUMBER OF LOCALS
2027: PFCOD EQU PFNLO+1 PTR TO CDBLK FOR FIRST STATEMENT
2028: PFCTR EQU PFCOD+1 TRBLK PTR IF CALL TRACED ELSE 0
2029: PFRTR EQU PFCTR+1 TRBLK PTR IF RETURN TRACED ELSE 0
2030: PFARG EQU PFRTR+1 VRBLK PTRS FOR ARGUMENTS AND LOCALS
2031: PFAGB EQU PFARG-1 OFFSET BEHIND PFARG FOR ARG,LOCAL
2032: PFSI$ EQU PFARG NUMBER OF STANDARD FIELDS IN PFBLK
2033: *
2034: * THE FCODE FIELD POINTS TO THE ROUTINE B$PFC.
2035: *
2036: * PFARG IS STORED IN THE FOLLOWING ORDER.
2037: *
2038: * ARGUMENTS (LEFT TO RIGHT)
2039: * LOCALS (LEFT TO RIGHT)
2040: .IF .CNRA
2041: .ELSE
2042: EJC
2043: *
2044: * REAL CONSTANT BLOCK (RCBLK)
2045: *
2046: * AN RCBLK IS CREATED FOR EVERY REAL REFERENCED OR
2047: * CREATED BY A PROGRAM.
2048: *
2049: * +------------------------------------+
2050: * I RCGET I
2051: * +------------------------------------+
2052: * * RCVAL *
2053: * +------------------------------------+
2054: *
2055: RCGET EQU 0 PTR TO ROUTINE B$RCL TO LOAD REAL
2056: RCVAL EQU RCGET+1 REAL VALUE
2057: RCSI$ EQU RCVAL+CFP$R SIZE OF RCBLK
2058: *
2059: * THE LENGTH OF THE RCVAL FIELD IS CFP$R.
2060: .FI
2061: EJC
2062: *
2063: * STRING CONSTANT BLOCK (SCBLK)
2064: *
2065: * AN SCBLK IS BUILT FOR EVERY STRING REFERENCED OR CREATED
2066: * BY A PROGRAM.
2067: *
2068: * +------------------------------------+
2069: * I SCGET I
2070: * +------------------------------------+
2071: * I SCLEN I
2072: * +------------------------------------+
2073: * / /
2074: * / SCHAR /
2075: * / /
2076: * +------------------------------------+
2077: *
2078: SCGET EQU 0 PTR TO ROUTINE B$SCL TO LOAD STRING
2079: SCLEN EQU SCGET+1 LENGTH OF STRING IN CHARACTERS
2080: SCHAR EQU SCLEN+1 CHARACTERS OF STRING
2081: SCSI$ EQU SCHAR SIZE OF STANDARD FIELDS IN SCBLK
2082: *
2083: * THE CHARACTERS OF THE STRING ARE STORED LEFT JUSTIFIED.
2084: * THE FINAL WORD IS PADDED ON THE RIGHT WITH ZEROS.
2085: * (I.E. THE CHARACTER WHOSE INTERNAL CODE IS ZERO).
2086: *
2087: * THE VALUE OF SCLEN MAY NOT EXCEED MXLEN. THIS ENSURES
2088: * THAT CHARACTER OFFSETS (E.G. THE PATTERN MATCH CURSOR)
2089: * CAN BE CORRECTLY PROCESSED BY THE GARBAGE COLLECTOR.
2090: *
2091: * NOTE THAT THE OFFSET TO THE CHARACTERS OF THE STRING
2092: * IS GIVEN IN BAUS BY CFP$F AND THAT THIS VALUE IS
2093: * AUTOMATICALLY ALLOWED FOR IN PLC, PSC.
2094: * NOTE THAT FOR A SPITBOL SCBLK, THE VALUE OF CFP$F
2095: * IS GIVEN BY CFP$B*SCHAR.
2096: EJC
2097: *
2098: * SIMPLE EXPRESSION BLOCK (SEBLK)
2099: *
2100: * AN SEBLK IS USED TO REPRESENT AN EXPRESSION OF THE FORM
2101: * *(NATURAL VARIABLE). ALL OTHER EXPRESSIONS ARE EXBLKS.
2102: *
2103: * +------------------------------------+
2104: * I SETYP I
2105: * +------------------------------------+
2106: * I SEVAR I
2107: * +------------------------------------+
2108: *
2109: SETYP EQU 0 PTR TO ROUTINE B$SEL TO LOAD EXPR
2110: SEVAR EQU SETYP+1 PTR TO VRBLK FOR VARIABLE
2111: SESI$ EQU SEVAR+1 LENGTH OF SEBLK IN WORDS
2112: EJC
2113: *
2114: * STANDARD VARIABLE BLOCK (SVBLK)
2115: *
2116: * AN SVBLK IS ASSEMBLED IN THE CONSTANT SECTION FOR EACH
2117: * VARIABLE WHICH SATISFIES ONE OF THE FOLLOWING CONDITIONS.
2118: *
2119: * 1) IT IS THE NAME OF A SYSTEM FUNCTION
2120: * 2) IT HAS AN INITIAL VALUE
2121: * 3) IT HAS A KEYWORD ASSOCIATION
2122: * 4) IT HAS A STANDARD I/O ASSOCIATION
2123: * 6) IT HAS A STANDARD LABEL ASSOCIATION
2124: *
2125: * IF VRBLKS ARE CONSTRUCTED FOR ANY OF THESE VARIABLES,
2126: * THEN THE VRSVP FIELD POINTS TO THE SVBLK (SEE VRBLK)
2127: *
2128: * +------------------------------------+
2129: * I SVBIT I
2130: * +------------------------------------+
2131: * I SVLEN I
2132: * +------------------------------------+
2133: * / SVCHS /
2134: * +------------------------------------+
2135: * I SVKNM I
2136: * +------------------------------------+
2137: * I SVFNC I
2138: * +------------------------------------+
2139: * I SVNAR I
2140: * +------------------------------------+
2141: * I SVLBL I
2142: * +------------------------------------+
2143: * I SVVAL I
2144: * +------------------------------------+
2145: EJC
2146: *
2147: * STANDARD VARIABLE BLOCK (CONTINUED)
2148: *
2149: SVBIT EQU 0 BIT STRING INDICATING ATTRIBUTES
2150: SVLEN EQU 1 (=SCLEN) LENGTH OF NAME IN CHARS
2151: SVCHS EQU 2 (=SCHAR) CHARACTERS OF NAME
2152: SVSI$ EQU 2 NUMBER OF STANDARD FIELDS IN SVBLK
2153: SVPRE EQU 1 SET IF PREEVALUATION PERMITTED
2154: SVFFC EQU SVPRE+SVPRE SET ON IF FAST CALL PERMITTED
2155: SVCKW EQU SVFFC+SVFFC SET ON IF KEYWORD VALUE CONSTANT
2156: SVPRD EQU SVCKW+SVCKW SET ON IF PREDICATE FUNCTION
2157: SVNBT EQU 4 NUMBER OF BITS TO RIGHT OF SVKNM
2158: SVKNM EQU SVPRD+SVPRD SET ON IF KEYWORD ASSOCIATION
2159: SVFNC EQU SVKNM+SVKNM SET ON IF SYSTEM FUNCTION
2160: SVNAR EQU SVFNC+SVFNC SET ON IF SYSTEM FUNCTION
2161: SVLBL EQU SVNAR+SVNAR SET ON IF SYSTEM LABEL
2162: SVVAL EQU SVLBL+SVLBL SET ON IF PREDEFINED VALUE
2163: *
2164: * NOTE THAT THE LAST FIVE BITS CORRESPOND IN ORDER
2165: * TO THE FIELDS WHICH ARE PRESENT (SEE PROCEDURE GTNVR).
2166: *
2167: * THE FOLLOWING DEFINITIONS ARE USED IN THE SVBLK TABLE
2168: *
2169: SVFNF EQU SVFNC+SVNAR FUNCTION WITH NO FAST CALL
2170: SVFNN EQU SVFNF+SVFFC FUNCTION WITH FAST CALL, NO PREEVAL
2171: SVFNP EQU SVFNN+SVPRE FUNCTION ALLOWING PREEVALUATION
2172: SVFPR EQU SVFNN+SVPRD PREDICATE FUNCTION
2173: SVFNK EQU SVFNN+SVKNM NO PREEVAL FUNC + KEYWORD
2174: SVKWV EQU SVKNM+SVVAL KEYWORD + VALUE
2175: SVKWC EQU SVCKW+SVKNM KEYWORD WITH CONSTANT VALUE
2176: SVKVC EQU SVKWV+SVCKW CONSTANT KEYWORD + VALUE
2177: SVKVL EQU SVKVC+SVLBL CONSTANT KEYWORD + VALUE + LABEL
2178: .IF .CNFN
2179: .ELSE
2180: SVFPK EQU SVFNP+SVKVC PREEVAL FUNC + CONST KEYWD+VAL
2181: .FI
2182: *
2183: * THE SVPRE BIT ALLOWS THE COMPILER TO PREEVALUATE A CALL
2184: * TO THE ASSOCIATED SYSTEM FUNCTION IF ALL THE ARGUMENTS
2185: * ARE THEMSELVES CONSTANTS. FUNCTIONS IN THIS CATEGORY
2186: * MUST HAVE NO SIDE EFFECTS AND MUST NEVER CAUSE FAILURE.
2187: * THE CALL MAY GENERATE AN ERROR CONDITION.
2188: *
2189: * THE SVFFC BIT ALLOWS THE COMPILER TO GENERATE THE SPECIAL
2190: * FAST CALL AFTER ADJUSTING THE NUMBER OF ARGUMENTS. ONLY
2191: * THE APPLY FUNCTION FALLS OUTSIDE THIS CATEGORY.
2192: *
2193: * THE SVCKW BIT IS SET IF THE ASSOCIATED KEYWORD VALUE IS
2194: * A CONSTANT, THUS ALLOWING PREEVALUATION FOR A VALUE CALL.
2195: *
2196: * THE SVPRD BIT IS SET ON FOR ALL PREDICATE FUNCTIONS TO
2197: * ENABLE THE SPECIAL CONCATENATION CODE OPTIMIZATION.
2198: EJC
2199: *
2200: * SVBLK (CONTINUED)
2201: *
2202: * SVKNM KEYWORD NUMBER
2203: *
2204: * SVKNM IS PRESENT ONLY FOR A STANDARD KEYWORD ASSOC.
2205: * IT CONTAINS A KEYWORD NUMBER AS DEFINED BY THE
2206: * KEYWORD NUMBER TABLE GIVEN LATER ON.
2207: *
2208: * SVFNC SYSTEM FUNCTION POINTER
2209: *
2210: * SVFNC IS PRESENT ONLY FOR A SYSTEM FUNCTION ASSOC.
2211: * IT IS A POINTER TO THE ACTUAL CODE FOR THE SYSTEM
2212: * FUNCTION. THE GENERATED CODE FOR A FAST CALL IS A
2213: * POINTER TO THE SVFNC FIELD OF THE SVBLK FOR THE
2214: * FUNCTION. THE VRFNC FIELD OF THE VRBLK POINTS TO
2215: * THIS SAME FIELD, IN WHICH CASE, IT SERVES AS THE
2216: * FCODE FIELD FOR THE FUNCTION CALL.
2217: *
2218: * SVNAR NUMBER OF FUNCTION ARGUMENTS
2219: *
2220: * SVNAR IS PRESENT ONLY FOR A SYSTEM FUNCTION ASSOC.
2221: * IT IS THE NUMBER OF ARGUMENTS REQUIRED FOR A CALL
2222: * TO THE SYSTEM FUNCTION. THE COMPILER USES THIS
2223: * VALUE TO ADJUST THE NUMBER OF ARGUMENTS IN A FAST
2224: * CALL AND IN THE CASE OF A FUNCTION CALLED THROUGH
2225: * THE VRFNC FIELD OF THE VRBLK, THE SVNAR FIELD
2226: * SERVES AS THE FARGS FIELD FOR O$FNC. A SPECIAL
2227: * CASE OCCURS IF THIS VALUE IS SET TO 999. THIS IS
2228: * USED TO INDICATE THAT THE FUNCTION HAS A VARIABLE
2229: * NUMBER OF ARGUMENTS AND CAUSES O$FNC TO PASS CONTROL
2230: * WITHOUT ADJUSTING THE ARGUMENT COUNT. THE ONLY
2231: * PREDEFINED FUNCTION USING THIS IS APPLY.
2232: *
2233: * SVLBL SYSTEM LABEL POINTER
2234: *
2235: * SVLBL IS PRESENT ONLY FOR A STANDARD LABEL ASSOC.
2236: * IT IS A POINTER TO A SYSTEM LABEL ROUTINE (L$XXX).
2237: * THE VRLBL FIELD OF THE CORRESPONDING VRBLK POINTS TO
2238: * THE SVLBL FIELD OF THE SVBLK.
2239: *
2240: * SVVAL SYSTEM VALUE POINTER
2241: *
2242: * SVVAL IS PRESENT ONLY FOR A STANDARD VALUE.
2243: * IT IS A POINTER TO THE PATTERN NODE (NDXXX) WHICH
2244: * IS THE STANDARD INITIAL VALUE OF THE VARIABLE.
2245: * THIS VALUE IS COPIED TO THE VRVAL FIELD OF THE VRBLK
2246: EJC
2247: *
2248: * SVBLK (CONTINUED)
2249: *
2250: * KEYWORD NUMBER TABLE
2251: *
2252: * THE FOLLOWING TABLE GIVES SYMBOLIC NAMES FOR KEYWORD
2253: * NUMBERS. THESE VALUES ARE STORED IN THE SVKNM FIELD OF
2254: * SVBLKS AND IN THE KVNUM FIELD OF KVBLKS. SEE ALSO
2255: * PROCEDURES ASIGN, ACESS AND KWNAM.
2256: *
2257: * UNPROTECTED KEYWORDS WITH ONE WORD INTEGER VALUES
2258: *
2259: K$ANC EQU 0 ANCHOR
2260: K$DMP EQU K$ANC+CFP$B DUMP
2261: K$ERL EQU K$DMP+CFP$B ERRLIMIT
2262: K$ERT EQU K$ERL+CFP$B ERRTYPE
2263: K$FTR EQU K$ERT+CFP$B FTRACE
2264: K$INP EQU K$FTR+CFP$B INPUT
2265: K$MXL EQU K$INP+CFP$B MAXLENGTH
2266: K$OUP EQU K$MXL+CFP$B OUTPUT
2267: .IF .CNPF
2268: K$TRA EQU K$OUP+CFP$B TRACE
2269: .ELSE
2270: K$PFL EQU K$OUP+CFP$B PROFILE
2271: K$TRA EQU K$PFL+CFP$B TRACE
2272: .FI
2273: K$TRM EQU K$TRA+CFP$B TRIM
2274: *
2275: * PROTECTED KEYWORDS WITH ONE WORD INTEGER VALUES
2276: *
2277: K$FNC EQU K$TRM+CFP$B FNCLEVEL
2278: K$LST EQU K$FNC+CFP$B LASTNO
2279: K$STN EQU K$LST+CFP$B STNO
2280: *
2281: * KEYWORDS WITH CONSTANT PATTERN VALUES
2282: *
2283: K$ABO EQU K$STN+CFP$B ABORT
2284: K$ARB EQU K$ABO+PASI$ ARB
2285: K$BAL EQU K$ARB+PASI$ BAL
2286: K$FAL EQU K$BAL+PASI$ FAIL
2287: K$FEN EQU K$FAL+PASI$ FENCE
2288: K$REM EQU K$FEN+PASI$ REM
2289: K$SUC EQU K$REM+PASI$ SUCCEED
2290: EJC
2291: *
2292: * KEYWORD NUMBER TABLE (CONTINUED)
2293: *
2294: * SPECIAL KEYWORDS
2295: *
2296: K$ALP EQU K$SUC+1 ALPHABET
2297: K$RTN EQU K$ALP+1 RTNTYPE
2298: K$COD EQU K$RTN+1 CODE
2299: K$STC EQU K$COD+1 STCOUNT
2300: K$ETX EQU K$STC+1 ERRTEXT
2301: K$STL EQU K$ETX+1 STLIMIT
2302: *
2303: * RELATIVE OFFSETS OF SPECIAL KEYWORDS
2304: *
2305: K$$AL EQU K$ALP-K$ALP ALPHABET
2306: K$$RT EQU K$RTN-K$ALP RTNTYPE
2307: K$$CD EQU K$COD-K$ALP CODE
2308: K$$SC EQU K$STC-K$ALP STCOUNT
2309: K$$ET EQU K$ETX-K$ALP ERRTEXT
2310: K$$SL EQU K$STL-K$ALP STLIMIT
2311: *
2312: * SYMBOLS USED IN ASIGN AND ACESS PROCEDURES
2313: *
2314: K$P$$ EQU K$FNC FIRST PROTECTED KEYWORD
2315: K$V$$ EQU K$ABO FIRST KEYWORD WITH CONSTANT VALUE
2316: K$S$$ EQU K$ALP FIRST KEYWORD WITH SPECIAL ACESS
2317: EJC
2318: *
2319: * FORMAT OF A TABLE BLOCK (TBBLK)
2320: *
2321: * A TABLE BLOCK IS USED TO REPRESENT A TABLE VALUE.
2322: * IT IS BUILT BY A CALL TO THE TABLE OR CONVERT FUNCTIONS.
2323: *
2324: * +------------------------------------+
2325: * I TBTYP I
2326: * +------------------------------------+
2327: * I IDVAL I
2328: * +------------------------------------+
2329: * I TBLEN I
2330: * +------------------------------------+
2331: * I TBINV I
2332: * +------------------------------------+
2333: * / /
2334: * / TBBUK /
2335: * / /
2336: * +------------------------------------+
2337: *
2338: TBTYP EQU 0 POINTER TO DUMMY ROUTINE B$TBT
2339: TBLEN EQU OFFS2 LENGTH OF TBBLK IN BAUS
2340: TBINV EQU OFFS3 DEFAULT INITIAL LOOKUP VALUE
2341: TBBUK EQU TBINV+1 START OF HASH BUCKET POINTERS
2342: TBSI$ EQU TBBUK SIZE OF STANDARD FIELDS IN TBBLK
2343: TBNBK EQU 11 DEFAULT NO. OF BUCKETS
2344: *
2345: * THE TABLE BLOCK IS A HASH TABLE WHICH POINTS TO CHAINS
2346: * OF TABLE ELEMENT BLOCKS REPRESENTING THE ELEMENTS
2347: * IN THE TABLE WHICH HASH INTO THE SAME BUCKET.
2348: *
2349: * TBBUK ENTRIES EITHER POINT TO THE FIRST TEBLK ON THE
2350: * CHAIN OR THEY POINT TO THE TBBLK ITSELF TO INDICATE THE
2351: * END OF THE CHAIN.
2352: EJC
2353: *
2354: * TABLE ELEMENT BLOCK (TEBLK)
2355: *
2356: * A TABLE ELEMENT IS USED TO REPRESENT A SINGLE ENTRY IN
2357: * A TABLE (SEE DESCRIPTION OF TBBLK FORMAT FOR HASH TABLE)
2358: *
2359: * +------------------------------------+
2360: * I TETYP I
2361: * +------------------------------------+
2362: * I TESUB I
2363: * +------------------------------------+
2364: * I TEVAL I
2365: * +------------------------------------+
2366: * I TENXT I
2367: * +------------------------------------+
2368: *
2369: TETYP EQU 0 POINTER TO DUMMY ROUTINE B$TET
2370: TESUB EQU TETYP+1 SUBSCRIPT VALUE
2371: TEVAL EQU TESUB+1 (=VRVAL) TABLE ELEMENT VALUE
2372: TENXT EQU TEVAL+1 LINK TO NEXT TEBLK
2373: * SEE S$CNV WHERE RELATION IS ASSUMED WITH TENXT AND TBBUK
2374: TESI$ EQU TENXT+1 SIZE OF TEBLK IN WORDS
2375: *
2376: * TENXT POINTS TO THE NEXT TEBLK ON THE HASH CHAIN FROM THE
2377: * TBBUK CHAIN FOR THIS HASH INDEX. AT THE END OF THE CHAIN,
2378: * TENXT POINTS BACK TO THE START OF THE TBBLK.
2379: *
2380: * TEVAL CONTAINS A DATA POINTER OR A TRBLK POINTER.
2381: *
2382: * TESUB CONTAINS A DATA POINTER.
2383: EJC
2384: *
2385: * TRAP BLOCK (TRBLK)
2386: *
2387: * A TRAP BLOCK IS USED TO REPRESENT A TRACE OR INPUT OR
2388: * OUTPUT ASSOCIATION IN RESPONSE TO A CALL TO THE TRACE
2389: * INPUT OR OUTPUT SYSTEM FUNCTIONS. SEE BELOW FOR DETAILS
2390: *
2391: * +------------------------------------+
2392: * I TRIDN I
2393: * +------------------------------------+
2394: * I TRTYP I
2395: * +------------------------------------+
2396: * I TRVAL OR TRLBL OR TRNXT OR TRKVR I
2397: * +------------------------------------+
2398: * I TRTAG OR TRTER I
2399: * +------------------------------------+
2400: * I TRFNC OR TRTRI I
2401: * +------------------------------------+
2402: *
2403: TRIDN EQU 0 POINTER TO DUMMY ROUTINE B$TRT
2404: TRTYP EQU TRIDN+1 TRAP TYPE CODE
2405: TRVAL EQU TRTYP+1 VALUE OF TRAPPED VARIABLE (=VRVAL)
2406: TRNXT EQU TRVAL PTR TO NEXT TRBLK ON TRBLK CHAIN
2407: TRLBL EQU TRVAL PTR TO ACTUAL LABEL (TRACED LABEL)
2408: TRKVR EQU TRVAL VRBLK POINTER FOR KEYWORD TRACE
2409: TRTAG EQU TRVAL+1 TRACE TAG OR IOTAG
2410: TRTER EQU TRTAG PTR TO TERMINAL VRBLK OR NULL
2411: TRFNC EQU TRTAG+1 TRACE FUNCTION VRBLK (ZERO IF NONE)
2412: TRTRI EQU TRFNC PTR TO TRACE BLOCK HOLDING IOTAG
2413: TRSI$ EQU TRFNC+1 NUMBER OF WORDS IN TRBLK
2414: *
2415: TRTIN EQU 0 TRACE TYPE FOR INPUT ASSOCIATION
2416: TRTAC EQU TRTIN+1 TRACE TYPE FOR ACCESS TRACE
2417: TRTVL EQU TRTAC+1 TRACE TYPE FOR VALUE TRACE
2418: TRTIO EQU TRTVL+1 TRACE TYPE FOR IOTAG TRACE BLOCK
2419: TRTOU EQU TRTIO+1 TRACE TYPE FOR OUTPUT ASSOCIATION
2420: EJC
2421: *
2422: * TRAP BLOCK (CONTINUED)
2423: *
2424: * VARIABLE INPUT ASSOCIATION
2425: *
2426: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
2427: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
2428: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
2429: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
2430: *
2431: * TRTYP IS SET TO TRTIN
2432: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
2433: * TRTER IS A POINTER TO SVBLK IF ASSOCIATION IS
2434: * FOR INPUT, TERMINAL, ELSE IT IS NULL.
2435: * TRTRI IS A PTR TO IOTAG TRBLK FROM SYSIO OR ZERO.
2436: *
2437: * VARIABLE ACCESS TRACE ASSOCIATION
2438: *
2439: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
2440: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
2441: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
2442: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
2443: *
2444: * TRTYP IS SET TO TRTAC
2445: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
2446: * TRTAG IS THE TRACE TAG (0 IF NONE)
2447: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
2448: *
2449: * VARIABLE VALUE TRACE ASSOCIATION
2450: *
2451: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
2452: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
2453: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
2454: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
2455: *
2456: * TRTYP IS SET TO TRTVL
2457: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
2458: * TRTAG IS THE TRACE TAG (0 IF NONE)
2459: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
2460: EJC
2461: * TRAP BLOCK (CONTINUED)
2462: *
2463: * VARIABLE OUTPUT ASSOCIATION
2464: *
2465: * THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
2466: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
2467: * OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
2468: * CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
2469: *
2470: * TRTYP IS SET TO TRTOU
2471: * TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
2472: * TRTER IS A POINTER TO SVBLK IF ASSOCIATION IS
2473: * FOR OUTPUT, TERMINAL, ELSE IT IS NULL.
2474: * TRTRI IS A PTR TO IOTAG TRBLK FROM SYSIO OR ZERO.
2475: *
2476: * FUNCTION CALL TRACE
2477: *
2478: * THE PFCTR FIELD OF THE CORRESPONDING PFBLK IS SET
2479: * TO POINT TO A TRBLK.
2480: *
2481: * TRTYP IS SET TO TRTIN
2482: * TRNXT IS ZERO
2483: * TRTAG IS THE TRACE TAG (0 IF NONE)
2484: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
2485: *
2486: * FUNCTION RETURN TRACE
2487: *
2488: * THE PFRTR FIELD OF THE CORRESPONDING PFBLK IS SET
2489: * TO POINT TO A TRBLK
2490: *
2491: * TRTYP IS SET TO TRTIN
2492: * TRNXT IS ZERO
2493: * TRTAG IS THE TRACE TAG (0 IF NONE)
2494: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
2495: *
2496: * LABEL TRACE
2497: *
2498: * THE VRLBL OF THE VRBLK FOR THE LABEL IS
2499: * CHANGED TO POINT TO A TRBLK AND THE VRTRA FIELD IS
2500: * SET TO B$VRT TO ACTIVATE THE CHECK.
2501: *
2502: * TRTYP IS SET TO TRTIN
2503: * TRLBL POINTS TO THE ACTUAL LABEL (CDBLK) VALUE
2504: * TRTAG IS THE TRACE TAG (0 IF NONE)
2505: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
2506: EJC
2507: *
2508: * TRAP BLOCK (CONTINUED)
2509: *
2510: * KEYWORD TRACE
2511: *
2512: * KEYWORDS WHICH CAN BE TRACED POSSESS A UNIQUE
2513: * LOCATION WHICH IS ZERO IF THERE IS NO TRACE AND
2514: * POINTS TO A TRBLK IF THERE IS A TRACE. THE LOCATIONS
2515: * ARE AS FOLLOWS.
2516: *
2517: * R$ERT ERRTYPE
2518: * R$FNC FNCLEVEL
2519: * R$STC STCOUNT
2520: *
2521: * THE FORMAT OF THE TRBLK IS AS FOLLOWS.
2522: *
2523: * TRTYP IS SET TO TRTIN
2524: * TRKVR IS A POINTER TO THE VRBLK FOR THE KEYWORD
2525: * TRTAG IS THE TRACE TAG (0 IF NONE)
2526: * TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
2527: *
2528: * INPUT/OUTPUT FILETAG TRAP BLOCK (TRTIO)
2529: *
2530: * THE VALUE FIELD OF THE FILETAG VBL POINTS TO A TRBLK
2531: * INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE OF
2532: * A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
2533: * CONTAIN =B$VRA AND =B$VRV. THIS TRAP BLOCK IS USED
2534: * TO HOLD THE IOTAG RETURNED BY A SYSIO CALL
2535: *
2536: * TRTYP IS SET TO TRTIO
2537: * TRNXT POINTS TO NEXT TRBLK OR TRVAL IS VARIABLE VAL
2538: * TRTAG HOLDS THE IOTAG.
2539: *
2540: * NOTE THAT WHEN MULTIPLE TRAPS ARE SET ON A VARIABLE
2541: * THE ORDER IS IN ASCENDING VALUE OF TRTYP FIELD.
2542: *
2543: * INPUT ASSOCIATION (IF PRESENT)
2544: * ACCESS TRACE (IF PRESENT)
2545: * VALUE TRACE (IF PRESENT)
2546: * FILETAG ASSOCIATION (IF PRESENT)
2547: * OUTPUT ASSOCIATION (IF PRESENT)
2548: *
2549: * THE ACTUAL VALUE OF THE VARIABLE IS STORED IN THE TRVAL
2550: * FIELD OF THE LAST TRBLK ON THE CHAIN.
2551: *
2552: * THIS IMPLEMENTATION DOES NOT PERMIT TRACE OR I/O
2553: * ASSOCIATIONS TO ANY OF THE PSEUDO-VARIABLES.
2554: EJC
2555: *
2556: * VECTOR BLOCK (VCBLK)
2557: *
2558: * A VCBLK IS USED TO REPRESENT AN ARRAY VALUE WHICH HAS
2559: * ONE DIMENSION WHOSE LOWER BOUND IS ONE. ALL OTHER ARRAYS
2560: * ARE REPRESENTED BY ARBLKS. A VCBLK IS CREATED BY THE
2561: * SYSTEM FUNCTION ARRAY (S$ARR) WHEN PASSED AN INTEGER ARG.
2562: *
2563: * +------------------------------------+
2564: * I VCTYP I
2565: * +------------------------------------+
2566: * I IDVAL I
2567: * +------------------------------------+
2568: * I VCLEN I
2569: * +------------------------------------+
2570: * I VCVLS I
2571: * +------------------------------------+
2572: *
2573: VCTYP EQU 0 POINTER TO DUMMY ROUTINE B$VCT
2574: VCLEN EQU OFFS2 LENGTH OF VCBLK IN BAUS
2575: VCVLS EQU OFFS3 START OF VECTOR VALUES
2576: VCSI$ EQU VCVLS SIZE OF STANDARD FIELDS IN VCBLK
2577: VCVLB EQU VCVLS-1 OFFSET ONE WORD BEHIND VCVLS
2578: VCTBD EQU TBSI$-VCSI$ DIFFERENCE IN SIZES - SEE PRTVL
2579: *
2580: * VCVLS ARE EITHER DATA POINTERS OR TRBLK POINTERS
2581: *
2582: * THE DIMENSION CAN BE DEDUCED FROM VCLEN.
2583: EJC
2584: *
2585: * VARIABLE BLOCK (VRBLK)
2586: *
2587: * A VARIABLE BLOCK IS BUILT IN THE STATIC MEMORY AREA
2588: * FOR EVERY VARIABLE REFERENCED OR CREATED BY A PROGRAM.
2589: *
2590: * NOTE THAT SINCE THESE BLOCKS ONLY OCCUR IN THE STATIC
2591: * REGION, IT IS PERMISSIBLE TO POINT TO ANY WORD IN
2592: * THE BLOCK AND THIS IS USED TO PROVIDE THREE DISTINCT
2593: * ACCESS POINTS FROM THE GENERATED CODE AS FOLLOWS.
2594: *
2595: * 1) POINT TO VRGET (FIRST WORD OF VRBLK) TO LOAD THE
2596: * VALUE OF THE VARIABLE ONTO THE MAIN STACK.
2597: *
2598: * 2) POINT TO VRSTO (SECOND WORD OF VRBLK) TO STORE THE
2599: * TOP STACK ELEMENT AS THE VALUE OF THE VARIABLE.
2600: *
2601: * 3) POINT TO VRTRA (FOURTH WORD OF VRBLK) TO JUMP TO
2602: * THE LABEL ASSOCIATED WITH THE VARIABLE NAME.
2603: *
2604: * +------------------------------------+
2605: * I VRGET I
2606: * +------------------------------------+
2607: * I VRSTO I
2608: * +------------------------------------+
2609: * I VRVAL I
2610: * +------------------------------------+
2611: * I VRTRA I
2612: * +------------------------------------+
2613: * I VRLBL I
2614: * +------------------------------------+
2615: * I VRFNC I
2616: * +------------------------------------+
2617: * I VRNXT I
2618: * +------------------------------------+
2619: * I VRLEN I
2620: * +------------------------------------+
2621: * / /
2622: * / VRCHS = VRSVP /
2623: * / /
2624: * +------------------------------------+
2625: EJC
2626: *
2627: * VARIABLE BLOCK (CONTINUED)
2628: *
2629: VRGET EQU 0 POINTER TO ROUTINE TO LOAD VALUE
2630: VRSTO EQU VRGET+1 POINTER TO ROUTINE TO STORE VALUE
2631: VRVAL EQU VRSTO+1 VARIABLE VALUE
2632: VRVLO EQU VRVAL-VRSTO OFFSET TO VALUE FROM STORE FIELD
2633: VRTRA EQU VRVAL+1 POINTER TO ROUTINE TO JUMP TO LABEL
2634: VRLBL EQU VRTRA+1 POINTER TO CODE FOR LABEL
2635: VRLBO EQU VRLBL-VRTRA OFFSET TO LABEL FROM TRANSFER FIELD
2636: VRFNC EQU VRLBL+1 POINTER TO FUNCTION BLOCK
2637: VRNXT EQU VRFNC+1 POINTER TO NEXT VRBLK ON HASH CHAIN
2638: VRLEN EQU VRNXT+1 LENGTH OF NAME (OR ZERO)
2639: VRCHS EQU VRLEN+1 CHARACTERS OF NAME (VRLEN GT 0)
2640: VRSVP EQU VRLEN+1 PTR TO SVBLK (VRLEN EQ 0)
2641: VRSI$ EQU VRCHS+1 NUMBER OF STANDARD FIELDS IN VRBLK
2642: VRSOF EQU VRLEN-SCLEN OFFSET TO DUMMY SCBLK FOR NAME
2643: VRSVO EQU VRSVP-VRSOF PSEUDO-OFFSET TO VRSVP FIELD
2644: *
2645: * VRGET = B$VRL IF NOT INPUT ASSOCIATED OR ACCESS TRACED
2646: * VRGET = B$VRA IF INPUT ASSOCIATED OR ACCESS TRACED
2647: *
2648: * VRSTO = B$VRS IF NOT OUTPUT ASSOCIATED OR VALUE TRACED
2649: * VRSTO = B$VRV IF OUTPUT ASSOCIATED OR VALUE TRACED
2650: * VRSTO = B$VRE IF VALUE IS PROTECTED PATTERN VALUE
2651: *
2652: * VRVAL POINTS TO THE APPROPRIATE VALUE UNLESS THE
2653: * VARIABLE IS I/O/TRACE ASSOCIATED IN WHICH CASE, VRVAL
2654: * POINTS TO AN APPROPRIATE TRBLK (TRAP BLOCK) CHAIN.
2655: *
2656: * VRTRA = B$VRG IF THE LABEL IS NOT TRACED
2657: * VRTRA = B$VRT IF THE LABEL IS TRACED
2658: *
2659: * VRLBL POINTS TO A CDBLK IF THERE IS A LABEL
2660: * VRLBL POINTS TO THE SVBLK SVLBL FIELD FOR A SYSTEM LABEL
2661: * VRLBL POINTS TO STNDL FOR AN UNDEFINED LABEL
2662: * VRLBL POINTS TO A TRBLK IF THE LABEL IS TRACED
2663: *
2664: * VRFNC POINTS TO A FFBLK FOR A FIELD FUNCTION
2665: * VRFNC POINTS TO A DFBLK FOR A DATATYPE FUNCTION
2666: * VRFNC POINTS TO A PFBLK FOR A PROGRAM DEFINED FUNCTION
2667: * VRFNC POINTS TO A EFBLK FOR AN EXTERNAL LOADED FUNCTION
2668: * VRFNC POINTS TO SVFNC (SVBLK) FOR A SYSTEM FUNCTION
2669: * VRFNC POINTS TO STNDF IF THE FUNCTION IS UNDEFINED
2670: *
2671: * VRNXT POINTS TO THE NEXT VRBLK ON THIS CHAIN UNLESS
2672: * THIS IS THE END OF THE CHAIN IN WHICH CASE IT IS ZERO.
2673: *
2674: * VRLEN IS THE NAME LENGTH FOR A NON-SYSTEM VARIABLE.
2675: * VRLEN IS ZERO FOR A SYSTEM VARIABLE.
2676: *
2677: * VRCHS IS THE NAME IF VRLEN IS NON-ZERO.
2678: * VRSVP IS A PTR TO THE SVBLK IF VRLEN IS ZERO.
2679: EJC
2680: *
2681: * FORMAT OF A NON-RELOCATABLE EXTERNAL BLOCK (XNBLK)
2682: *
2683: * AN XNBLK IS A BLOCK REPRESENTING AN UNKNOWN (EXTERNAL)
2684: * DATA VALUE. THE BLOCK CONTAINS NO POINTERS TO OTHER
2685: * RELOCATABLE BLOCKS. AN XNBLK IS USED BY EXTERNAL FUNCTION
2686: * PROCESSING OR POSSIBLY FOR SYSTEM I/O ROUTINES ETC.
2687: * THE MACRO-SYSTEM ITSELF DOES NOT USE XNBLKS.
2688: *
2689: * +------------------------------------+
2690: * I XNTYP I
2691: * +------------------------------------+
2692: * I XNLEN I
2693: * +------------------------------------+
2694: * / /
2695: * / XNDTA /
2696: * / /
2697: * +------------------------------------+
2698: *
2699: XNTYP EQU 0 POINTER TO DUMMY ROUTINE B$XNT
2700: XNLEN EQU XNTYP+1 LENGTH OF XNBLK IN BAUS
2701: XNDTA EQU XNLEN+1 DATA WORDS
2702: XNSI$ EQU XNDTA SIZE OF STANDARD FIELDS IN XNBLK
2703: *
2704: * NOTE THAT THE TERM NON-RELOCATABLE REFERS TO THE CONTENTS
2705: * AND NOT THE BLOCK ITSELF. AN XNBLK CAN BE MOVED AROUND IF
2706: * IT IS BUILT IN THE DYNAMIC MEMORY AREA.
2707: EJC
2708: *
2709: * RELOCATABLE EXTERNAL BLOCK (XRBLK)
2710: *
2711: * AN XRBLK IS A BLOCK REPRESENTING AN UNKNOWN (EXTERNAL)
2712: * DATA VALUE. THE DATA AREA IN THIS BLOCK CONSISTS ONLY
2713: * OF ADDRESS VALUES AND ANY ADDRESSES POINTING INTO THE
2714: * DYNAMIC MEMORY AREA MUST POINT TO THE START OF OTHER
2715: * DATA BLOCKS. SEE ALSO DESCRIPTION OF XNBLK.
2716: *
2717: * +------------------------------------+
2718: * I XRTYP I
2719: * +------------------------------------+
2720: * I XRLEN I
2721: * +------------------------------------+
2722: * / /
2723: * / XRPTR /
2724: * / /
2725: * +------------------------------------+
2726: *
2727: XRTYP EQU 0 POINTER TO DUMMY ROUTINE B$XRT
2728: XRLEN EQU XRTYP+1 LENGTH OF XRBLK IN BAUS
2729: XRPTR EQU XRLEN+1 START OF ADDRESS POINTERS
2730: XRSI$ EQU XRPTR SIZE OF STANDARD FIELDS IN XRBLK
2731: EJC
2732: *
2733: * S$CNV (CONVERT) FUNCTION SWITCH CONSTANTS. THE VALUES
2734: * ARE TIED TO THE ORDER OF THE ENTRIES IN THE SVCTB TABLE
2735: * AND HENCE TO THE BRANCH TABLE IN S$CNV.
2736: *
2737: CNVST EQU 8 MAX STANDARD TYPE CODE FOR CONVERT
2738: .IF .CNRA
2739: CNVRT EQU CNVST NO REALS - SAME AS STANDARD TYPES
2740: .ELSE
2741: CNVRT EQU CNVST+1 CONVERT CODE FOR REALS
2742: .FI
2743: .IF .CNBF
2744: CNVBT EQU CNVRT NO BUFFERS - SAME AS REAL CODE
2745: .ELSE
2746: CNVBT EQU CNVRT+1 CONVERT CODE FOR BUFFER
2747: .FI
2748: CNVTT EQU CNVBT+1 BSW CODE FOR CONVERT
2749: *
2750: * INPUT IMAGE LENGTH
2751: *
2752: INILN EQU 160 DEFAULT IMAGE LENGTH FOR COMPILER
2753: *
2754: * IN GENERAL, MEANINGFUL MNEMONICS SHOULD BE USED FOR
2755: * OFFSETS. HOWEVER FOR SMALL INTEGERS USED OFTEN IN
2756: * LITERALS THE FOLLOWING GENERAL DEFINITIONS ARE PROVIDED.
2757: *
2758: NUM01 EQU 1
2759: NUM02 EQU 2
2760: NUM03 EQU 3
2761: NUM04 EQU 4
2762: NUM05 EQU 5
2763: NUM06 EQU 6
2764: NUM07 EQU 7
2765: NUM08 EQU 8
2766: NUM09 EQU 9
2767: NUM10 EQU 10
2768: NINI9 EQU 999
2769: THSND EQU 1000
2770: *
2771: * NUMBERS OF UNDEFINED SPITBOL OPERATORS
2772: *
2773: OPBUN EQU 5 NO. OF BINARY UNDEFINED OPS
2774: OPUUN EQU 6 NO OF UNARY UNDEFINED OPS
2775: *
2776: * OFFSETS USED IN PRTSN, PRTMI AND ACESS
2777: *
2778: PRSNF EQU 13 OFFSET USED IN PRTSN
2779: PRTMF EQU 15 OFFSET TO COL 15 (PRTMI)
2780: RILEN EQU 160 BUFFER LENGTH FOR SYSRI
2781: *
2782: * CODES FOR STAGES OF PROCESSING
2783: *
2784: STGIC EQU 0 INITIAL COMPILE
2785: STGXC EQU STGIC+1 EXECUTION COMPILE (CODE)
2786: STGEV EQU STGXC+1 EXPRESSION EVAL DURING EXECUTION
2787: STGXT EQU STGEV+1 EXECUTION TIME
2788: STGCE EQU STGXT+1 INITIAL COMPILE AFTER END LINE
2789: STGXE EQU STGCE+1 EXEC. COMPILE AFTER END LINE
2790: STGND EQU STGCE-STGIC DIFFERENCE IN STAGE AFTER END
2791: STGEE EQU STGXE+1 EVAL EVALUATING EXPRESSION
2792: STGNO EQU STGEE+1 NUMBER OF CODES
2793: EJC
2794: *
2795: *
2796: * STATEMENT NUMBER PAD COUNT FOR LISTR
2797: *
2798: .DEF .CSN5
2799: .IF .CSN6
2800: STNPD EQU 6 STATEMENT NO. PAD COUNT
2801: .UNDEF .CSN5
2802: .FI
2803: .IF .CSN8
2804: STNPD EQU 8 STATEMENT NO. PAD COUNT
2805: .UNDEF .CSN5
2806: .FI
2807: .IF .CSN5
2808: STNPD EQU 5 STATEMENT NO. PAD COUNT
2809: .FI
2810: *
2811: * SYNTAX TYPE CODES
2812: *
2813: * THESE CODES ARE RETURNED FROM THE SCANE PROCEDURE.
2814: *
2815: * THEY ARE SPACED 3 APART FOR THE BENEFIT OF EXPAN.
2816: *
2817: T$UOP EQU 0 UNARY OPERATOR
2818: T$LPR EQU T$UOP+3 LEFT PAREN
2819: T$LBR EQU T$LPR+3 LEFT BRACKET
2820: T$CMA EQU T$LBR+3 COMMA
2821: T$FNC EQU T$CMA+3 FUNCTION CALL
2822: T$VAR EQU T$FNC+3 VARIABLE
2823: T$CON EQU T$VAR+3 CONSTANT
2824: T$BOP EQU T$CON+3 BINARY OPERATOR
2825: T$RPR EQU T$BOP+3 RIGHT PAREN
2826: T$RBR EQU T$RPR+3 RIGHT BRACKET
2827: T$COL EQU T$RBR+3 COLON
2828: T$SMC EQU T$COL+3 SEMI-COLON
2829: *
2830: * THE FOLLOWING DEFINITIONS ARE USED ONLY IN THE GOTO FIELD
2831: *
2832: T$FGO EQU T$SMC+1 FAILURE GOTO
2833: T$SGO EQU T$FGO+1 SUCCESS GOTO
2834: *
2835: * THE ABOVE CODES ARE GROUPED SO THAT CODES FOR ELEMENTS
2836: * WHICH CAN LEGITIMATELY IMMEDIATELY PRECEDE A UNARY
2837: * OPERATOR COME FIRST TO FACILITATE OPERATOR SYNTAX CHECK.
2838: *
2839: T$UOK EQU T$FNC LAST CODE OK BEFORE UNARY OPERATOR
2840: EJC
2841: *
2842: * DEFINITIONS OF VALUES FOR EXPAN JUMP TABLE
2843: *
2844: T$UO0 EQU T$UOP+0 UNARY OPERATOR, STATE ZERO
2845: T$UO1 EQU T$UOP+1 UNARY OPERATOR, STATE ONE
2846: T$UO2 EQU T$UOP+2 UNARY OPERATOR, STATE TWO
2847: T$LP0 EQU T$LPR+0 LEFT PAREN, STATE ZERO
2848: T$LP1 EQU T$LPR+1 LEFT PAREN, STATE ONE
2849: T$LP2 EQU T$LPR+2 LEFT PAREN, STATE TWO
2850: T$LB0 EQU T$LBR+0 LEFT BRACKET, STATE ZERO
2851: T$LB1 EQU T$LBR+1 LEFT BRACKET, STATE ONE
2852: T$LB2 EQU T$LBR+2 LEFT BRACKET, STATE TWO
2853: T$CM0 EQU T$CMA+0 COMMA, STATE ZERO
2854: T$CM1 EQU T$CMA+1 COMMA, STATE ONE
2855: T$CM2 EQU T$CMA+2 COMMA, STATE TWO
2856: T$FN0 EQU T$FNC+0 FUNCTION CALL, STATE ZERO
2857: T$FN1 EQU T$FNC+1 FUNCTION CALL, STATE ONE
2858: T$FN2 EQU T$FNC+2 FUNCTION CALL, STATE TWO
2859: T$VA0 EQU T$VAR+0 VARIABLE, STATE ZERO
2860: T$VA1 EQU T$VAR+1 VARIABLE, STATE ONE
2861: T$VA2 EQU T$VAR+2 VARIABLE, STATE TWO
2862: T$CO0 EQU T$CON+0 CONSTANT, STATE ZERO
2863: T$CO1 EQU T$CON+1 CONSTANT, STATE ONE
2864: T$CO2 EQU T$CON+2 CONSTANT, STATE TWO
2865: T$BO0 EQU T$BOP+0 BINARY OPERATOR, STATE ZERO
2866: T$BO1 EQU T$BOP+1 BINARY OPERATOR, STATE ONE
2867: T$BO2 EQU T$BOP+2 BINARY OPERATOR, STATE TWO
2868: T$RP0 EQU T$RPR+0 RIGHT PAREN, STATE ZERO
2869: T$RP1 EQU T$RPR+1 RIGHT PAREN, STATE ONE
2870: T$RP2 EQU T$RPR+2 RIGHT PAREN, STATE TWO
2871: T$RB0 EQU T$RBR+0 RIGHT BRACKET, STATE ZERO
2872: T$RB1 EQU T$RBR+1 RIGHT BRACKET, STATE ONE
2873: T$RB2 EQU T$RBR+2 RIGHT BRACKET, STATE TWO
2874: T$CL0 EQU T$COL+0 COLON, STATE ZERO
2875: T$CL1 EQU T$COL+1 COLON, STATE ONE
2876: T$CL2 EQU T$COL+2 COLON, STATE TWO
2877: T$SM0 EQU T$SMC+0 SEMICOLON, STATE ZERO
2878: T$SM1 EQU T$SMC+1 SEMICOLON, STATE ONE
2879: T$SM2 EQU T$SMC+2 SEMICOLON, STATE TWO
2880: *
2881: T$NES EQU T$SM2+1 NUMBER OF ENTRIES IN BRANCH TABLE
2882: EJC
2883: *
2884: * DEFINITION OF OFFSETS USED IN CONTROL CARD PROCESSING
2885: *
2886: .IF .CASL
2887: CC$CI EQU 0 -CASEIG
2888: CC$CO EQU CC$CI+1 -COPY
2889: .ELSE
2890: CC$CO EQU 0 -COPY
2891: .FI
2892: CC$EJ EQU CC$CO+1 -EJECT
2893: CC$FA EQU CC$EJ+1 -FAIL
2894: CC$LI EQU CC$FA+1 -LIST
2895: .IF .CASL
2896: CC$NC EQU CC$LI+1 -NOCASEIG
2897: CC$NF EQU CC$NC+1 -NOFAIL
2898: .ELSE
2899: CC$NF EQU CC$LI+1 -NOFAIL
2900: .FI
2901: CC$NL EQU CC$NF+1 -NOLIST
2902: CC$ST EQU CC$NL+1 -STITL
2903: CC$TI EQU CC$ST+1 -TITLE
2904: CC$TR EQU CC$TI+1 -TRACE
2905: CC$CT EQU CC$TR+1 NUMBER OF CONTROL CARDS
2906: CCNOC EQU 4 NO. OF CHARS INCLUDED IN MATCH
2907: CCOFS EQU 7 OFFSET TO START OF TITLE/SUBTITLE
2908: *
2909: * DEFINITIONS OF STACK OFFSETS USED IN CMPIL PROCEDURE
2910: *
2911: * SEE DESCRIPTION AT START OF CMPIL PROCEDURE FOR DETAILS
2912: * OF USE OF THESE LOCATIONS ON THE STACK.
2913: *
2914: CMSTM EQU 0 TREE FOR STATEMENT BODY
2915: CMSGO EQU CMSTM+1 TREE FOR SUCCESS GOTO
2916: CMFGO EQU CMSGO+1 TREE FOR FAIL GOTO
2917: CMCGO EQU CMFGO+1 CONDITIONAL GOTO FLAG
2918: CMPCD EQU CMCGO+1 PREVIOUS CDBLK POINTER
2919: CMFFP EQU CMPCD+1 FAILURE FILL IN FLAG FOR PREVIOUS
2920: CMFFC EQU CMFFP+1 FAILURE FILL IN FLAG FOR CURRENT
2921: CMSOP EQU CMFFC+1 SUCCESS FILL IN OFFSET FOR PREVIOUS
2922: CMSOC EQU CMSOP+1 SUCCESS FILL IN OFFSET FOR CURRENT
2923: CMLBL EQU CMSOC+1 PTR TO VRBLK FOR CURRENT LABEL
2924: CMTRA EQU CMLBL+1 PTR TO ENTRY CDBLK
2925: *
2926: CMNEN EQU CMTRA+1 COUNT OF STACK ENTRIES FOR CMPIL
2927: .IF .CNPF
2928: .ELSE
2929: *
2930: * A FEW CONSTANTS USED BY THE PROFILER
2931: PFPD1 EQU 8 PAD POSITIONS ...
2932: PFPD2 EQU 20 ... FOR PROFILE ...
2933: PFPD3 EQU 32 ... PRINTOUT
2934: PF$I2 EQU CFP$I+CFP$I SIZE OF TABLE ENTRY (2 INTS)
2935: .FI
2936: TTL S P I T B O L -- CONSTANT SECTION
2937: *
2938: * THIS SECTION CONSISTS ENTIRELY OF ASSEMBLED CONSTANTS.
2939: *
2940: * ALL LABEL NAMES ARE FIVE LETTERS. THE ORDER IS
2941: * APPROXIMATELY ALPHABETICAL, BUT IN SOME CASES (ALWAYS
2942: * DOCUMENTED), CONSTANTS MUST BE PLACED IN SOME SPECIAL
2943: * ORDER WHICH MUST NOT BE DISTURBED.
2944: *
2945: * IT MUST ALSO BE REMEMBERED THAT THERE IS A REQUIREMENT
2946: * FOR NO FORWARD REFERENCES WHICH ALSO DISTURBS THE
2947: * ALPHABETICAL ORDER IN SOME CASES.
2948: *
2949: SEC START OF CONSTANT SECTION
2950: *
2951: * FREE STORE PERCENTAGE (USED BY ALLOC)
2952: *
2953: ALFSP DAC E$FSP FREE STORE PERCENTAGE
2954: *
2955: * BIT CONSTANTS FOR GENERAL USE
2956: *
2957: BITS0 DBC 0 ALL ZERO BITS
2958: BITS1 DBC 1 ONE BIT IN LOW ORDER POSITION
2959: BITS2 DBC 2 BIT IN POSITION 2
2960: BITS3 DBC 4 BIT IN POSITION 3
2961: BITS4 DBC 8 BIT IN POSITION 4
2962: BITS5 DBC 16 BIT IN POSITION 5
2963: BITS6 DBC 32 BIT IN POSITION 6
2964: BITS7 DBC 64 BIT IN POSITION 7
2965: BITS8 DBC 128 BIT IN POSITION 8
2966: BITS9 DBC 256 BIT IN POSITION 9
2967: BIT10 DBC 512 BIT IN POSITION 10
2968: BITSM DBC CFP$M MASK FOR MAX INTEGER
2969: *
2970: * BIT CONSTANTS FOR SVBLK (SVBIT FIELD) TESTS
2971: *
2972: BTFNC DBC SVFNC BIT TO TEST FOR FUNCTION
2973: BTKNM DBC SVKNM BIT TO TEST FOR KEYWORD NUMBER
2974: BTLBL DBC SVLBL BIT TO TEST FOR LABEL
2975: BTFFC DBC SVFFC BIT TO TEST FOR FAST CALL
2976: BTCKW DBC SVCKW BIT TO TEST FOR CONSTANT KEYWORD
2977: BTPRD DBC SVPRD BIT TO TEST FOR PREDICATE FUNCTION
2978: BTPRE DBC SVPRE BIT TO TEST FOR PREEVALUATION
2979: BTVAL DBC SVVAL BIT TO TEST FOR VALUE
2980: EJC
2981: *
2982: * LIST OF NAMES USED FOR CONTROL CARD PROCESSING
2983: *
2984: .IF .CASL
2985: CCNMS DTC /CASE/
2986: DTC /COPY/
2987: .ELSE
2988: CCNMS DTC /COPY/
2989: .FI
2990: DTC /EJEC/
2991: DTC /FAIL/
2992: DTC /LIST/
2993: .IF .CASL
2994: DTC /NOCA/
2995: .FI
2996: DTC /NOFA/
2997: DTC /NOLI/
2998: DTC /STIT/
2999: DTC /TITL/
3000: DTC /TRAC/
3001: *
3002: * HEADER MESSAGES FOR DUMPR PROCEDURE (SCBLK FORMAT)
3003: *
3004: DMHDK DAC B$SCL
3005: DAC 22
3006: DDC /DUMP OF KEYWORD VALUES/
3007: *
3008: DMHDV DAC B$SCL
3009: DAC 25
3010: DDC /DUMP OF NATURAL VARIABLES/
3011: *
3012: * MESSAGE TEXT FOR COMPILATION STATISTICS
3013: *
3014: ENCM1 DAC B$SCL
3015: DAC 10
3016: DDC /STORE USED/
3017: *
3018: ENCM2 DAC B$SCL
3019: DAC 10
3020: DDC /STORE LEFT/
3021: *
3022: ENCM3 DAC B$SCL
3023: DAC 11
3024: DDC /COMP ERRORS/
3025: *
3026: ENCM4 DAC B$SCL
3027: DAC 14
3028: .IF .CTMD
3029: DDC /COMP TIME-DSEC/
3030: .ELSE
3031: DDC /COMP TIME-MSEC/
3032: .FI
3033: *
3034: ENCM5 DAC B$SCL
3035: DAC 20
3036: DDC /EXECUTION SUPPRESSED/
3037: EJC
3038: *
3039: * FOR TERMINATION IN COMPILATION
3040: *
3041: ENDIC DAC B$SCL
3042: DAC 14
3043: DDC /IN COMPILATION/
3044: *
3045: * MEMORY OVERFLOW DURING INITIALISATION
3046: *
3047: ENDMO DAC B$SCL
3048: ENDML DAC 15
3049: DDC /MEMORY OVERFLOW/
3050: *
3051: * STRING CONSTANT FOR MESSAGE ISSUED BY L$END
3052: *
3053: ENDMS DAC B$SCL
3054: DAC 10
3055: DDC /NORMAL END/
3056: *
3057: * FAIL MESSAGE FOR STACK FAIL SECTION
3058: *
3059: ENDSO DAC B$SCL
3060: DAC 36
3061: DDC /STACK OVERFLOW IN GARBAGE COLLECTION/
3062: EJC
3063: *
3064: * STRING CONSTANT FOR ERROR MESSAGE (ERROR SECTION)
3065: *
3066: ERMMS DAC B$SCL
3067: DAC 5
3068: DDC /ERROR/
3069: *
3070: ERMNS DAC B$SCL
3071: DAC 4
3072: DTC / -- /
3073: *
3074: *
3075: ERRTF DAC 251 FATAL ERROR CODE - SEE LABEL ERRAF
3076: *
3077: * STRING CONSTANT FOR PAGE NUMBERING
3078: *
3079: LSTMS DAC B$SCL
3080: DAC 5
3081: DDC /PAGE /
3082: *
3083: * LISTING HEADER MESSAGE
3084: *
3085: HEADR DAC B$SCL
3086: DAC 25
3087: DDC /MACRO SPITBOL VERSION 4.3/
3088: *
3089: HEADV DAC B$SCL FOR EXIT() VERSION NO. CHECK
3090: DAC 3
3091: DTC /4.3/
3092: *
3093: * INTEGER CONSTANTS FOR GENERAL USE
3094: * ICBLD OPTIMISATION USES THE FIRST THREE.
3095: *
3096: INT$R DAC B$ICL
3097: INTV0 DIC +0 0
3098: INTON DAC B$ICL
3099: INTV1 DIC +1 1
3100: INTTW DAC B$ICL
3101: INTV2 DIC +2 2
3102: INTVT DIC +10 10
3103: INTVH DIC +100 100
3104: INTTH DIC +1000 1000
3105: *
3106: * TABLE USED IN ICBLD OPTIMISATION
3107: *
3108: INTAB DAC INT$R POINTER TO 0
3109: DAC INTON POINTER TO 1
3110: DAC INTTW POINTER TO 2
3111: EJC
3112: *
3113: * SPECIAL PATTERN NODES. THE FOLLOWING PATTERN NODES
3114: * CONSIST SIMPLY OF A PCODE POINTER, SEE MATCH ROUTINES
3115: * (P$XXX) FOR FULL DETAILS OF THEIR USE AND FORMAT).
3116: *
3117: NDABB DAC P$ABB ARBNO
3118: NDABD DAC P$ABD ARBNO
3119: NDARC DAC P$ARC ARB
3120: NDEXB DAC P$EXB EXPRESSION
3121: NDEXC DAC P$EXC EXPRESSION
3122: .IF .CNFN
3123: .ELSE
3124: NDFNB DAC P$FNB FENCE()
3125: NDFND DAC P$FND FENCE()
3126: .FI
3127: NDIMB DAC P$IMB IMMEDIATE ASSIGNMENT
3128: NDIMD DAC P$IMD IMMEDIATE ASSIGNMENT
3129: NDNTH DAC P$NTH PATTERN END (NULL PATTERN)
3130: NDPAB DAC P$PAB PATTERN ASSIGNMENT
3131: NDPAD DAC P$PAD PATTERN ASSIGNMENT
3132: NDUNA DAC P$UNA ANCHOR POINT MOVEMENT
3133: *
3134: * KEYWORD CONSTANT PATTERN NODES. THE FOLLOWING NODES ARE
3135: * USED AS THE VALUES OF PATTERN KEYWORDS AND THE INITIAL
3136: * VALUES OF THE CORRESPONDING NATURAL VARIABLES. ALL
3137: * NODES ARE IN P0BLK FORMAT AND THE ORDER IS TIED TO THE
3138: * DEFINITIONS OF CORRESPONDING K$XXX SYMBOLS.
3139: *
3140: NDABO DAC P$ABO ABORT
3141: DAC NDNTH
3142: NDARB DAC P$ARB ARB
3143: DAC NDNTH
3144: NDBAL DAC P$BAL BAL
3145: DAC NDNTH
3146: NDFAL DAC P$FAL FAIL
3147: DAC NDNTH
3148: NDFEN DAC P$FEN FENCE
3149: DAC NDNTH
3150: NDREM DAC P$REM REM
3151: DAC NDNTH
3152: NDSUC DAC P$SUC SUCCEED
3153: DAC NDNTH
3154: *
3155: * NULL STRING. ALL NULL VALUES POINT TO THIS STRING. THE
3156: * SVCHS FIELD CONTAINS A BLANK TO PROVIDE FOR EASY DEFAULT
3157: * PROCESSING IN TRACE, STOPTR, LPAD AND RPAD.
3158: * NULLW CONTAINS 10 BLANKS WHICH ENSURES AN ALL BLANK WORD
3159: * BUT FOR VERY EXCEPTIONAL MACHINES.
3160: *
3161: NULLS DAC B$SCL NULL STRING VALUE
3162: DAC 0 SCLEN = 0
3163: NULLW DTC / /
3164: EJC
3165: *
3166: * OPERATOR DOPE VECTORS (SEE DVBLK FORMAT)
3167: *
3168: OPDVC DAC O$CNC CONCATENATION
3169: DAC C$CNC
3170: DAC LLCNC
3171: DAC RRCNC
3172: *
3173: * OPDVP IS USED WHEN SCANNING BELOW TOP LEVEL TO ENSURE
3174: * THE CONCATENATION WILL NOT LATER BE MISTAKEN FOR
3175: * PATTERN MATCHING
3176: *
3177: OPDVP DAC O$CNC PROVEN CONCATENATION
3178: DAC C$CNP
3179: DAC LLCNC
3180: DAC RRCNC
3181: *
3182: * NOTE THAT THE ORDER OF THE REMAINING ENTRIES IS TIED TO
3183: * THE ORDER OF THE CODING IN THE SCANE PROCEDURE.
3184: *
3185: OPDVS DAC O$ASS ASSIGNMENT
3186: DAC C$ASS
3187: DAC LLASS
3188: DAC RRASS
3189: *
3190: DAC 6 UNARY EQUAL
3191: DAC C$UUO
3192: DAC LLUNO
3193: *
3194: DAC O$PMV PATTERN MATCH
3195: DAC C$PMT
3196: DAC LLPMT
3197: DAC RRPMT
3198: *
3199: DAC O$INT INTERROGATION
3200: DAC C$UVL
3201: DAC LLUNO
3202: *
3203: DAC 1 BINARY AMPERSAND
3204: DAC C$UBO
3205: DAC LLAMP
3206: DAC RRAMP
3207: *
3208: DAC O$KWV KEYWORD REFERENCE
3209: DAC C$KEY
3210: DAC LLUNO
3211: *
3212: DAC O$ALT ALTERNATION
3213: DAC C$ALT
3214: DAC LLALT
3215: DAC RRALT
3216: EJC
3217: *
3218: * OPERATOR DOPE VECTORS (CONTINUED)
3219: *
3220: DAC 5 UNARY VERTICAL BAR
3221: DAC C$UUO
3222: DAC LLUNO
3223: *
3224: DAC 0 BINARY AT
3225: DAC C$UBO
3226: DAC LLATS
3227: DAC RRATS
3228: *
3229: DAC O$CAS CURSOR ASSIGNMENT
3230: DAC C$UNM
3231: DAC LLUNO
3232: *
3233: DAC 2 BINARY NUMBER SIGN
3234: DAC C$UBO
3235: DAC LLNUM
3236: DAC RRNUM
3237: *
3238: DAC 7 UNARY NUMBER SIGN
3239: DAC C$UUO
3240: DAC LLUNO
3241: *
3242: DAC O$DVD DIVISION
3243: DAC C$BVL
3244: DAC LLDVD
3245: DAC RRDVD
3246: *
3247: DAC 9 UNARY SLASH
3248: DAC C$UUO
3249: DAC LLUNO
3250: *
3251: DAC O$MLT MULTIPLICATION
3252: DAC C$BVL
3253: DAC LLMLT
3254: DAC RRMLT
3255: EJC
3256: *
3257: * OPERATOR DOPE VECTORS (CONTINUED)
3258: *
3259: DAC 0 DEFERRED EXPRESSION
3260: DAC C$DEF
3261: DAC LLUNO
3262: *
3263: DAC 3 BINARY PERCENT
3264: DAC C$UBO
3265: DAC LLPCT
3266: DAC RRPCT
3267: *
3268: DAC 8 UNARY PERCENT
3269: DAC C$UUO
3270: DAC LLUNO
3271: *
3272: DAC O$EXP EXPONENTIATION
3273: DAC C$BVL
3274: DAC LLEXP
3275: DAC RREXP
3276: *
3277: DAC 10 UNARY EXCLAMATION
3278: DAC C$UUO
3279: DAC LLUNO
3280: *
3281: DAC 4 BINARY NOT
3282: DAC C$UBO
3283: DAC LLNOT
3284: DAC RRNOT
3285: *
3286: DAC 0 NEGATION
3287: DAC C$NEG
3288: DAC LLUNO
3289: EJC
3290: *
3291: * OPERATOR DOPE VECTORS (CONTINUED)
3292: *
3293: DAC O$SUB SUBTRACTION
3294: DAC C$BVL
3295: DAC LLPLM
3296: DAC RRPLM
3297: *
3298: DAC O$COM COMPLEMENTATION
3299: DAC C$UVL
3300: DAC LLUNO
3301: *
3302: DAC O$ADD ADDITION
3303: DAC C$BVL
3304: DAC LLPLM
3305: DAC RRPLM
3306: *
3307: DAC O$AFF AFFIRMATION
3308: DAC C$UVL
3309: DAC LLUNO
3310: *
3311: DAC O$IMA IMMEDIATE ASSIGNMENT
3312: DAC C$BVN
3313: DAC LLDLD
3314: DAC RRDLD
3315: *
3316: DAC O$INV INDIRECTION
3317: DAC C$IND
3318: DAC LLUNO
3319: *
3320: DAC O$PAS PATTERN ASSIGNMENT
3321: DAC C$BVN
3322: DAC LLDLD
3323: DAC RRDLD
3324: *
3325: DAC O$NAM NAME REFERENCE
3326: DAC C$UNM
3327: DAC LLUNO
3328: *
3329: * SPECIAL DVS FOR GOTO OPERATORS (SEE PROCEDURE SCNGF)
3330: *
3331: OPDVD DAC O$GOD DIRECT GOTO
3332: DAC C$UVL
3333: DAC LLUNO
3334: *
3335: OPDVN DAC O$GOC COMPLEX NORMAL GOTO
3336: DAC C$UNM
3337: DAC LLUNO
3338: EJC
3339: *
3340: * OPERATOR ENTRY ADDRESS POINTERS, USED IN CODE
3341: *
3342: OAMN$ DAC O$AMN ARRAY REF (MULTI-SUBS BY VALUE)
3343: OAMV$ DAC O$AMV ARRAY REF (MULTI-SUBS BY VALUE)
3344: OAON$ DAC O$AON ARRAY REF (ONE SUB BY NAME)
3345: OAOV$ DAC O$AOV ARRAY REF (ONE SUB BY VALUE)
3346: OCER$ DAC O$CER COMPILATION ERROR
3347: OFEX$ DAC O$FEX FAILURE IN EXPRESSION EVALUATION
3348: OFIF$ DAC O$FIF FAILURE DURING GOTO EVALUATION
3349: OFNC$ DAC O$FNC FUNCTION CALL (MORE THAN ONE ARG)
3350: OFNE$ DAC O$FNE FUNCTION NAME ERROR
3351: OFNS$ DAC O$FNS FUNCTION CALL (SINGLE ARGUMENT)
3352: OGOF$ DAC O$GOF SET GOTO FAILURE TRAP
3353: OINN$ DAC O$INN INDIRECTION BY NAME
3354: OKWN$ DAC O$KWN KEYWORD REFERENCE BY NAME
3355: OLEX$ DAC O$LEX LOAD EXPRESSION BY NAME
3356: OLPT$ DAC O$LPT LOAD PATTERN
3357: OLVN$ DAC O$LVN LOAD VARIABLE NAME
3358: ONTA$ DAC O$NTA NEGATION, FIRST ENTRY
3359: ONTB$ DAC O$NTB NEGATION, SECOND ENTRY
3360: ONTC$ DAC O$NTC NEGATION, THIRD ENTRY
3361: OPMN$ DAC O$PMN PATTERN MATCH BY NAME
3362: OPMS$ DAC O$PMS PATTERN MATCH (STATEMENT)
3363: OPOP$ DAC O$POP POP TOP STACK ITEM
3364: ORNM$ DAC O$RNM RETURN NAME FROM EXPRESSION
3365: ORPL$ DAC O$RPL PATTERN REPLACEMENT
3366: ORVL$ DAC O$RVL RETURN VALUE FROM EXPRESSION
3367: OSLA$ DAC O$SLA SELECTION, FIRST ENTRY
3368: OSLB$ DAC O$SLB SELECTION, SECOND ENTRY
3369: OSLC$ DAC O$SLC SELECTION, THIRD ENTRY
3370: OSLD$ DAC O$SLD SELECTION, FOURTH ENTRY
3371: OSTP$ DAC O$STP STOP EXECUTION
3372: OUNF$ DAC O$UNF UNEXPECTED FAILURE
3373: EJC
3374: *
3375: * TABLE OF NAMES OF UNDEFINED BINARY OPERATORS FOR OPSYN
3376: *
3377: OPSNB DAC CH$AT AT
3378: DAC CH$AM AMPERSAND
3379: DAC CH$NM NUMBER
3380: DAC CH$PC PERCENT
3381: DAC CH$NT NOT
3382: *
3383: * TABLE OF NAMES OF UNDEFINED UNARY OPERATORS FOR OPSYN
3384: *
3385: OPNSU DAC CH$BR VERTICAL BAR
3386: DAC CH$EQ EQUAL
3387: DAC CH$NM NUMBER
3388: DAC CH$PC PERCENT
3389: DAC CH$SL SLASH
3390: DAC CH$EX EXCLAMATION
3391: .IF .CNPF
3392: .ELSE
3393: *
3394: * ADDRESS CONST CONTAINING PROFILE TABLE ENTRY SIZE
3395: *
3396: PFI2A DAC PF$I2
3397: *
3398: * PROFILER MESSAGE STRINGS
3399: *
3400: PFMS1 DAC B$SCL
3401: DAC 15
3402: DDC /PROGRAM PROFILE/
3403: PFMS2 DAC B$SCL
3404: DAC 42
3405: DDC /STMT NUMBER OF -- EXECUTION TIME --/
3406: PFMS3 DAC B$SCL
3407: DAC 47
3408: DDC /NUMBER EXECUTIONS TOTAL(MSEC) PER EXCN(MCSEC)/
3409: .FI
3410: .IF .CNRA
3411: .ELSE
3412: *
3413: * REAL CONSTANTS FOR GENERAL USE. NOTE THAT THE CONSTANTS
3414: * STARTING AT REAV1 FORM A POWERS OF TEN TABLE (GTSTG)
3415: *
3416: REAV0 DRC +0.0 0.0
3417: REAP1 DRC +0.1 0.1
3418: REAP5 DRC +0.5 0.5
3419: REAV1 DRC +1.0 10**0
3420: REAVT DRC +1.0E+1 10**1
3421: DRC +1.0E+2 10**2
3422: DRC +1.0E+3 10**3
3423: DRC +1.0E+4 10**4
3424: DRC +1.0E+5 10**5
3425: DRC +1.0E+6 10**6
3426: DRC +1.0E+7 10**7
3427: DRC +1.0E+8 10**8
3428: DRC +1.0E+9 10**9
3429: REATT DRC +1.0E+10 10**10
3430: .FI
3431: EJC
3432: *
3433: * STRING CONSTANTS (SCBLK FORMAT) FOR DTYPE PROCEDURE
3434: *
3435: SCARR DAC B$SCL ARRAY
3436: DAC 5
3437: DTC /ARRAY/
3438: .IF .CNBF
3439: .ELSE
3440: *
3441: SCBUF DAC B$SCL
3442: DAC 6
3443: DTC /BUFFER/
3444: .FI
3445: *
3446: SCCOD DAC B$SCL CODE
3447: DAC 4
3448: DTC /CODE/
3449: *
3450: SCEXP DAC B$SCL EXPRESSION
3451: DAC 10
3452: DTC /EXPRESSION/
3453: *
3454: SCEXT DAC B$SCL EXTERNAL
3455: DAC 8
3456: DTC /EXTERNAL/
3457: *
3458: SCINT DAC B$SCL INTEGER
3459: DAC 7
3460: DTC /INTEGER/
3461: *
3462: SCNAM DAC B$SCL NAME
3463: DAC 4
3464: DTC /NAME/
3465: *
3466: SCNUM DAC B$SCL NUMERIC
3467: DAC 7
3468: DTC /NUMERIC/
3469: *
3470: SCPAT DAC B$SCL PATTERN
3471: DAC 7
3472: DTC /PATTERN/
3473: .IF .CNRA
3474: .ELSE
3475: *
3476: SCREA DAC B$SCL REAL
3477: DAC 4
3478: DTC /REAL/
3479: .FI
3480: *
3481: SCSTR DAC B$SCL STRING
3482: DAC 6
3483: DTC /STRING/
3484: *
3485: SCTAB DAC B$SCL TABLE
3486: DAC 5
3487: DTC /TABLE/
3488: EJC
3489: *
3490: * STRING CONSTANTS (SCBLK FORMAT) FOR KVRTN (SEE RETRN)
3491: *
3492: SCFRT DAC B$SCL FRETURN
3493: DAC 7
3494: DTC /FRETURN/
3495: *
3496: SCNRT DAC B$SCL NRETURN
3497: DAC 7
3498: DTC /NRETURN/
3499: *
3500: SCRTN DAC B$SCL RETURN
3501: DAC 6
3502: DTC /RETURN/
3503: *
3504: * DATATYPE NAME TABLE FOR DTYPE PROCEDURE. THE ORDER OF
3505: * THESE ENTRIES IS TIED TO THE B$XXX DEFINITIONS FOR BLOCKS
3506: *
3507: SCNMT DAC SCARR ARBLK ARRAY
3508: .IF .CNBF
3509: .ELSE
3510: DAC SCBUF BFBLK BUFFER
3511: .FI
3512: DAC SCCOD CDBLK CODE
3513: DAC SCEXP EXBLK EXPRESSION
3514: DAC SCINT ICBLK INTEGER
3515: DAC SCNAM NMBLK NAME
3516: DAC SCPAT P0BLK PATTERN
3517: DAC SCPAT P1BLK PATTERN
3518: DAC SCPAT P2BLK PATTERN
3519: .IF .CNRA
3520: .ELSE
3521: DAC SCREA RCBLK REAL
3522: .FI
3523: DAC SCSTR SCBLK STRING
3524: DAC SCEXP SEBLK EXPRESSION
3525: DAC SCTAB TBBLK TABLE
3526: DAC SCARR VCBLK ARRAY
3527: DAC SCEXT XNBLK EXTERNAL
3528: DAC SCEXT XRBLK EXTERNAL
3529: *
3530: .IF .CNRA
3531: .ELSE
3532: * STRING CONSTANT FOR REAL ZERO
3533: *
3534: SCRE0 DAC B$SCL
3535: DAC 2
3536: DTC /0./
3537: .FI
3538: EJC
3539: *
3540: * USED TO RE-INITIALISE KVSTL
3541: *
3542: .IF .CS16
3543: STLIM DIC +32767 DEFAULT STATEMENT LIMIT
3544: .ELSE
3545: STLIM DIC +50000 DEFAULT STATEMENT LIMIT
3546: .FI
3547: *
3548: * DUMMY FUNCTION BLOCK USED FOR UNDEFINED FUNCTIONS
3549: *
3550: STNDF DAC O$FUN PTR TO UNDEFINED FUNCTION ERR CALL
3551: DAC 0 DUMMY FARGS COUNT FOR CALL CIRCUIT
3552: *
3553: * DUMMY CODE BLOCK USED FOR UNDEFINED LABELS
3554: *
3555: STNDL DAC L$UND CODE PTR POINTS TO UNDEFINED LBL
3556: *
3557: * DUMMY OPERATOR BLOCK USED FOR UNDEFINED OPERATORS
3558: *
3559: STNDO DAC O$OUN PTR TO UNDEFINED OPERATOR ERR CALL
3560: DAC 0 DUMMY FARGS COUNT FOR CALL CIRCUIT
3561: *
3562: * STANDARD VARIABLE BLOCK. THIS BLOCK IS USED TO INITIALIZE
3563: * THE FIRST SEVEN FIELDS OF A NEWLY CONSTRUCTED VRBLK.
3564: * ITS FORMAT IS TIED TO THE VRBLK DEFINITIONS (SEE GTNVR).
3565: *
3566: STNVR DAC B$VRL VRGET
3567: DAC B$VRS VRSTO
3568: DAC NULLS VRVAL
3569: DAC B$VRG VRTRA
3570: DAC STNDL VRLBL
3571: DAC STNDF VRFNC
3572: DAC 0 VRNXT
3573: EJC
3574: *
3575: * MESSAGES USED IN END OF RUN PROCESSING (STOPR)
3576: *
3577: STPM1 DAC B$SCL
3578: DAC 12
3579: DDC /IN STATEMENT/
3580: *
3581: STPM2 DAC B$SCL
3582: DAC 14
3583: DDC /STMTS EXECUTED/
3584: *
3585: STPM3 DAC B$SCL
3586: DAC 13
3587: .IF .CTMD
3588: DDC /RUN TIME-DSEC/
3589: .ELSE
3590: DDC /RUN TIME-MSEC/
3591: .FI
3592: *
3593: STPM4 DAC B$SCL
3594: DAC 12
3595: DDC $MCSEC / STMT$
3596: *
3597: STPM5 DAC B$SCL
3598: DAC 13
3599: DDC /REGENERATIONS/
3600: *
3601: * TABLE USED BY CONVERT FUNCTION TO CHECK DATATYPE NAME
3602: * THE ENTRIES ARE ORDERED TO CORRESPOND TO BRANCH TABLE
3603: * IN S$CNV
3604: *
3605: SVCTB DAC SCSTR STRING
3606: DAC SCINT INTEGER
3607: DAC SCNAM NAME
3608: DAC SCPAT PATTERN
3609: DAC SCARR ARRAY
3610: DAC SCTAB TABLE
3611: DAC SCEXP EXPRESSION
3612: DAC SCCOD CODE
3613: DAC SCNUM NUMERIC
3614: .IF .CNRA
3615: .ELSE
3616: DAC SCREA REAL
3617: .FI
3618: .IF .CNBF
3619: .ELSE
3620: DAC SCBUF BUFFER
3621: .FI
3622: DAC 0 ZERO MARKS END OF LIST
3623: EJC
3624: *
3625: * MESSAGES (SCBLK FORMAT) USED BY TRACE PROCEDURES
3626: *
3627: *
3628: TMASB DAC B$SCL
3629: DAC 13
3630: DTC /************ /
3631: *
3632: TMBEB DAC B$SCL
3633: DAC 3
3634: DTC / = /
3635: *
3636: * DUMMY TRBLK FOR EXPRESSION VARIABLE
3637: *
3638: TRBEV DAC B$TRT DUMMY TRBLK
3639: *
3640: * DUMMY TRBLK FOR KEYWORD VARIABLE
3641: *
3642: TRBKV DAC B$TRT DUMMY TRBLK
3643: *
3644: * DUMMY CODE BLOCK TO RETURN CONTROL TO TRXEQ PROCEDURE
3645: *
3646: TRXDR DAC O$TXR BLOCK POINTS TO RETURN ROUTINE
3647: TRXDC DAC TRXDR POINTER TO BLOCK
3648: EJC
3649: *
3650: * STANDARD VARIABLE BLOCKS
3651: *
3652: * SEE SVBLK FORMAT FOR FULL DETAILS OF THE FORMAT. THE
3653: * VRBLKS ARE ORDERED BY LENGTH AND WITHIN EACH LENGTH THE
3654: * ORDER IS ALPHABETICAL BY NAME OF THE VARIABLE.
3655: *
3656: V$EQF DBC SVFPR EQ
3657: DAC 2
3658: DTC /EQ/
3659: DAC S$EQF
3660: DAC 2
3661: *
3662: V$GEF DBC SVFPR GE
3663: DAC 2
3664: DTC /GE/
3665: DAC S$GEF
3666: DAC 2
3667: *
3668: V$GTF DBC SVFPR GT
3669: DAC 2
3670: DTC /GT/
3671: DAC S$GTF
3672: DAC 2
3673: *
3674: V$LEF DBC SVFPR LE
3675: DAC 2
3676: DTC /LE/
3677: DAC S$LEF
3678: DAC 2
3679: *
3680: V$LTF DBC SVFPR LT
3681: DAC 2
3682: DTC /LT/
3683: DAC S$LTF
3684: DAC 2
3685: *
3686: V$NEF DBC SVFPR NE
3687: DAC 2
3688: DTC /NE/
3689: DAC S$NEF
3690: DAC 2
3691: *
3692: V$ANY DBC SVFNP ANY
3693: DAC 3
3694: DTC /ANY/
3695: DAC S$ANY
3696: DAC 1
3697: *
3698: V$ARB DBC SVKVC ARB
3699: DAC 3
3700: DTC /ARB/
3701: DAC K$ARB
3702: DAC NDARB
3703: EJC
3704: *
3705: * STANDARD VARIABLE BLOCKS (CONTINUED)
3706: *
3707: V$ARG DBC SVFNN ARG
3708: DAC 3
3709: DTC /ARG/
3710: DAC S$ARG
3711: DAC 2
3712: *
3713: V$BAL DBC SVKVC BAL
3714: DAC 3
3715: DTC /BAL/
3716: DAC K$BAL
3717: DAC NDBAL
3718: *
3719: V$CTI DBC SVFNP CTI
3720: DAC 3
3721: DTC /CTI/
3722: DAC S$CTI
3723: DAC 1
3724: *
3725: V$END DBC SVLBL END
3726: DAC 3
3727: DTC /END/
3728: DAC L$END
3729: *
3730: V$ITC DBC SVFNN ITC
3731: DAC 3
3732: DTC /ITC/
3733: DAC S$ITC
3734: DAC 1
3735: *
3736: V$LEN DBC SVFNP LEN
3737: DAC 3
3738: DTC /LEN/
3739: DAC S$LEN
3740: DAC 1
3741: *
3742: V$LEQ DBC SVFPR LEQ
3743: DAC 3
3744: DTC /LEQ/
3745: DAC S$LEQ
3746: DAC 2
3747: *
3748: V$LGE DBC SVFPR LGE
3749: DAC 3
3750: DTC /LGE/
3751: DAC S$LGE
3752: DAC 2
3753: *
3754: V$LGT DBC SVFPR LGT
3755: DAC 3
3756: DTC /LGT/
3757: DAC S$LGT
3758: DAC 2
3759: *
3760: V$LLE DBC SVFPR LLE
3761: DAC 3
3762: DTC /LLE/
3763: DAC S$LLE
3764: DAC 2
3765: EJC
3766: *
3767: * STANDARD VARIABLE BLOCKS (CONTINUED)
3768: *
3769: V$LLT DBC SVFPR LLT
3770: DAC 3
3771: DTC /LLT/
3772: DAC S$LLT
3773: DAC 2
3774: *
3775: V$LNE DBC SVFPR LNE
3776: DAC 3
3777: DTC /LNE/
3778: DAC S$LNE
3779: DAC 2
3780: *
3781: V$POS DBC SVFNP POS
3782: DAC 3
3783: DTC /POS/
3784: DAC S$POS
3785: DAC 1
3786: *
3787: V$REM DBC SVKVC REM
3788: DAC 3
3789: DTC /REM/
3790: DAC K$REM
3791: DAC NDREM
3792: .IF .CUST
3793: *
3794: V$SET DBC SVFNN SET
3795: DAC 3
3796: DTC /SET/
3797: DAC S$SET
3798: DAC 3
3799: .FI
3800: *
3801: V$TAB DBC SVFNP TAB
3802: DAC 3
3803: DTC /TAB/
3804: DAC S$TAB
3805: DAC 1
3806: *
3807: V$COD DBC SVFNK CODE
3808: DAC 4
3809: DTC /CODE/
3810: DAC K$COD
3811: DAC S$COD
3812: DAC 1
3813: *
3814: V$COP DBC SVFNN COPY
3815: DAC 4
3816: DTC /COPY/
3817: DAC S$COP
3818: DAC 1
3819: EJC
3820: *
3821: * STANDARD VARIABLE BLOCKS (CONTINUED)
3822: *
3823: V$DAT DBC SVFNN DATA
3824: DAC 4
3825: DTC /DATA/
3826: DAC S$DAT
3827: DAC 1
3828: *
3829: V$DTE DBC SVFNN DATE
3830: DAC 4
3831: DTC /DATE/
3832: DAC S$DTE
3833: DAC 0
3834: *
3835: V$DMP DBC SVFNK DUMP
3836: DAC 4
3837: DTC /DUMP/
3838: DAC K$DMP
3839: DAC S$DMP
3840: DAC 1
3841: *
3842: V$DUP DBC SVFNN DUPL
3843: DAC 4
3844: DTC /DUPL/
3845: DAC S$DUP
3846: DAC 2
3847: *
3848: V$EVL DBC SVFNN EVAL
3849: DAC 4
3850: DTC /EVAL/
3851: DAC S$EVL
3852: DAC 1
3853: .IF .CNEX
3854: .ELSE
3855: *
3856: V$EXT DBC SVFNN EXIT
3857: DAC 4
3858: DTC /EXIT/
3859: DAC S$EXT
3860: DAC 1
3861: .FI
3862: *
3863: V$FAL DBC SVKVC FAIL
3864: DAC 4
3865: DTC /FAIL/
3866: DAC K$FAL
3867: DAC NDFAL
3868: *
3869: V$HST DBC SVFNN HOST
3870: DAC 4
3871: DTC /HOST/
3872: DAC S$HST
3873: DAC 3
3874: EJC
3875: *
3876: * STANDARD VARIABLE BLOCKS (CONTINUED)
3877: *
3878: V$ITM DBC SVFNF ITEM
3879: DAC 4
3880: DTC /ITEM/
3881: DAC S$ITM
3882: DAC 999
3883: .IF .CNLD
3884: .ELSE
3885: *
3886: V$LOD DBC SVFNN LOAD
3887: DAC 4
3888: DTC /LOAD/
3889: DAC S$LOD
3890: DAC 2
3891: .FI
3892: *
3893: V$LPD DBC SVFNP LPAD
3894: DAC 4
3895: DTC /LPAD/
3896: DAC S$LPD
3897: DAC 3
3898: *
3899: V$RPD DBC SVFNP RPAD
3900: DAC 4
3901: DTC /RPAD/
3902: DAC S$RPD
3903: DAC 3
3904: EJC
3905: *
3906: * STANDARD VARIABLE BLOCKS (CONTINUED)
3907: *
3908: *
3909: V$RPS DBC SVFNP RPOS
3910: DAC 4
3911: DTC /RPOS/
3912: DAC S$RPS
3913: DAC 1
3914: *
3915: V$RTB DBC SVFNP RTAB
3916: DAC 4
3917: DTC /RTAB/
3918: DAC S$RTB
3919: DAC 1
3920: *
3921: V$SI$ DBC SVFNP SIZE
3922: DAC 4
3923: DTC /SIZE/
3924: DAC S$SI$
3925: DAC 1
3926: *
3927: .IF .CNSR
3928: .ELSE
3929: *
3930: V$SRT DBC SVFNN SORT
3931: DAC 4
3932: DTC /SORT/
3933: DAC S$SRT
3934: DAC 2
3935: .FI
3936: V$SPN DBC SVFNP SPAN
3937: DAC 4
3938: DTC /SPAN/
3939: DAC S$SPN
3940: DAC 1
3941: EJC
3942: *
3943: * STANDARD VARIABLE BLOCKS (CONTINUED)
3944: *
3945: V$STN DBC SVKNM STNO
3946: DAC 4
3947: DTC /STNO/
3948: DAC K$STN
3949: *
3950: V$TIM DBC SVFNN TIME
3951: DAC 4
3952: DTC /TIME/
3953: DAC S$TIM
3954: DAC 0
3955: *
3956: V$TRM DBC SVFNK TRIM
3957: DAC 4
3958: DTC /TRIM/
3959: DAC K$TRM
3960: DAC S$TRM
3961: DAC 1
3962: *
3963: V$ABO DBC SVKVL ABORT
3964: DAC 5
3965: DTC /ABORT/
3966: DAC K$ABO
3967: DAC L$ABO
3968: DAC NDABO
3969: *
3970: V$APP DBC SVFNF APPLY
3971: DAC 5
3972: DTC /APPLY/
3973: DAC S$APP
3974: DAC 999
3975: *
3976: V$ABN DBC SVFNP ARBNO
3977: DAC 5
3978: DTC /ARBNO/
3979: DAC S$ABN
3980: DAC 1
3981: *
3982: V$ARR DBC SVFNN ARRAY
3983: DAC 5
3984: DTC /ARRAY/
3985: DAC S$ARR
3986: DAC 2
3987: EJC
3988: *
3989: * STANDARD VARIABLE BLOCKS (CONTINUED)
3990: *
3991: V$BRK DBC SVFNP BREAK
3992: DAC 5
3993: DTC /BREAK/
3994: DAC S$BRK
3995: DAC 1
3996: *
3997: V$CLR DBC SVFNN CLEAR
3998: DAC 5
3999: DTC /CLEAR/
4000: DAC S$CLR
4001: DAC 1
4002: *
4003: V$EJC DBC SVFNN EJECT
4004: DAC 5
4005: DTC /EJECT/
4006: DAC S$EJC
4007: DAC 1
4008: *
4009: .IF .CNFN
4010: V$FEN DBC SVKVC FENCE
4011: .ELSE
4012: V$FEN DBC SVFPK FENCE
4013: .FI
4014: DAC 5
4015: DTC /FENCE/
4016: DAC K$FEN
4017: .IF .CNFN
4018: .ELSE
4019: DAC S$FNC
4020: DAC 1
4021: .FI
4022: DAC NDFEN
4023: *
4024: V$FLD DBC SVFNN FIELD
4025: DAC 5
4026: DTC /FIELD/
4027: DAC S$FLD
4028: DAC 2
4029: *
4030: V$IDN DBC SVFPR IDENT
4031: DAC 5
4032: DTC /IDENT/
4033: DAC S$IDN
4034: DAC 2
4035: *
4036: V$INP DBC SVFNK INPUT
4037: DAC 5
4038: DTC /INPUT/
4039: DAC K$INP
4040: DAC S$INP
4041: DAC 3
4042: *
4043: V$LOC DBC SVFNN LOCAL
4044: DAC 5
4045: DTC /LOCAL/
4046: DAC S$LOC
4047: DAC 2
4048: EJC
4049: * STANDARD VARIABLE BLOCKS (CONTINUED)
4050: *
4051: V$OPS DBC SVFNN OPSYN
4052: DAC 5
4053: DTC /OPSYN/
4054: DAC S$OPS
4055: DAC 3
4056: *
4057: V$RMD DBC SVFNP REMDR
4058: DAC 5
4059: DTC /REMDR/
4060: DAC S$RMD
4061: DAC 2
4062: .IF .CNSR
4063: .ELSE
4064: *
4065: V$RSR DBC SVFNN RSORT
4066: DAC 5
4067: DTC /RSORT/
4068: DAC S$RSR
4069: DAC 2
4070: .FI
4071: *
4072: V$TBL DBC SVFNN TABLE
4073: DAC 5
4074: DTC /TABLE/
4075: DAC S$TBL
4076: DAC 3
4077: *
4078: V$TRA DBC SVFNK TRACE
4079: DAC 5
4080: DTC /TRACE/
4081: DAC K$TRA
4082: DAC S$TRA
4083: DAC 4
4084: *
4085: V$ANC DBC SVKNM ANCHOR
4086: DAC 6
4087: DTC /ANCHOR/
4088: DAC K$ANC
4089: EJC
4090: *
4091: * STANDARD VARIABLE BLOCKS (CONTINUED)
4092: *
4093: .IF .CNBF
4094: .ELSE
4095: V$APN DBC SVFNN APPEND
4096: DAC 6
4097: DTC /APPEND/
4098: DAC S$APN
4099: DAC 2
4100: .FI
4101: *
4102: V$BKX DBC SVFNP BREAKX
4103: DAC 6
4104: DTC /BREAKX/
4105: DAC S$BKX
4106: DAC 1
4107: .IF .CNBF
4108: .ELSE
4109: V$BUF DBC SVFNN BUFFER
4110: DAC 6
4111: DTC /BUFFER/
4112: DAC S$BUF
4113: DAC 2
4114: .FI
4115: *
4116: V$DEF DBC SVFNN DEFINE
4117: DAC 6
4118: DTC /DEFINE/
4119: DAC S$DFN
4120: DAC 2
4121: *
4122: V$DET DBC SVFNN DETACH
4123: DAC 6
4124: DTC /DETACH/
4125: DAC S$DET
4126: DAC 1
4127: *
4128: V$DIF DBC SVFPR DIFFER
4129: DAC 6
4130: DTC /DIFFER/
4131: DAC S$DIF
4132: DAC 2
4133: *
4134: V$FTR DBC SVKNM FTRACE
4135: DAC 6
4136: DTC /FTRACE/
4137: DAC K$FTR
4138: EJC
4139: .IF .CNBF
4140: .ELSE
4141: *
4142: V$INS DBC SVFNN INSERT
4143: DAC 6
4144: DTC /INSERT/
4145: DAC S$INS
4146: DAC 4
4147: .FI
4148: *
4149: V$LST DBC SVKNM LASTNO
4150: DAC 6
4151: DTC /LASTNO/
4152: DAC K$LST
4153: *
4154: V$NAY DBC SVFNP NOTANY
4155: DAC 6
4156: DTC /NOTANY/
4157: DAC S$NAY
4158: DAC 1
4159: *
4160: V$OUP DBC SVFNK OUTPUT
4161: DAC 6
4162: DTC /OUTPUT/
4163: DAC K$OUP
4164: DAC S$OUP
4165: DAC 3
4166: *
4167: V$RET DBC SVLBL RETURN
4168: DAC 6
4169: DTC /RETURN/
4170: DAC L$RTN
4171: *
4172: V$STT DBC SVFNN STOPTR
4173: DAC 6
4174: DTC /STOPTR/
4175: DAC S$STT
4176: DAC 2
4177: EJC
4178: *
4179: * STANDARD VARIABLE BLOCKS (CONTINUED)
4180: *
4181: V$SUB DBC SVFNN SUBSTR
4182: DAC 6
4183: DTC /SUBSTR/
4184: DAC S$SUB
4185: DAC 3
4186: *
4187: V$UNL DBC SVFNN UNLOAD
4188: DAC 6
4189: DTC /UNLOAD/
4190: DAC S$UNL
4191: DAC 1
4192: *
4193: V$COL DBC SVFNN COLLECT
4194: DAC 7
4195: DTC /COLLECT/
4196: DAC S$COL
4197: DAC 1
4198: *
4199: V$CNV DBC SVFNN CONVERT
4200: DAC 7
4201: DTC /CONVERT/
4202: DAC S$CVT
4203: DAC 2
4204: *
4205: V$ENF DBC SVFNN ENDFILE
4206: DAC 7
4207: DTC /ENDFILE/
4208: DAC S$ENF
4209: DAC 2
4210: *
4211: V$ETX DBC SVKNM ERRTEXT
4212: DAC 7
4213: DTC /ERRTEXT/
4214: DAC K$ETX
4215: *
4216: V$ERT DBC SVKNM ERRTYPE
4217: DAC 7
4218: DTC /ERRTYPE/
4219: DAC K$ERT
4220: *
4221: V$FRT DBC SVLBL FRETURN
4222: DAC 7
4223: DTC /FRETURN/
4224: DAC L$FRT
4225: *
4226: V$INT DBC SVFPR INTEGER
4227: DAC 7
4228: DTC /INTEGER/
4229: DAC S$INT
4230: DAC 1
4231: *
4232: V$NRT DBC SVLBL NRETURN
4233: DAC 7
4234: DTC /NRETURN/
4235: DAC L$NRT
4236: EJC
4237: *
4238: * STANDARD VARIABLE BLOCKS (CONTINUED)
4239: .IF .CNPF
4240: .ELSE
4241: *
4242: V$PFL DBC SVKNM PROFILE
4243: DAC 7
4244: DTC /PROFILE/
4245: DAC K$PFL
4246: .FI
4247: *
4248: *
4249: V$RPL DBC SVFNP REPLACE
4250: DAC 7
4251: DTC /REPLACE/
4252: DAC S$RPL
4253: DAC 3
4254: *
4255: V$RVS DBC SVFNP REVERSE
4256: DAC 7
4257: DTC /REVERSE/
4258: DAC S$RVS
4259: DAC 1
4260: *
4261: V$RTN DBC SVKNM RTNTYPE
4262: DAC 7
4263: DTC /RTNTYPE/
4264: DAC K$RTN
4265: *
4266: V$STX DBC SVFNN SETEXIT
4267: DAC 7
4268: DTC /SETEXIT/
4269: DAC S$STX
4270: DAC 1
4271: *
4272: V$STC DBC SVKNM STCOUNT
4273: DAC 7
4274: DTC /STCOUNT/
4275: DAC K$STC
4276: *
4277: V$STL DBC SVKNM STLIMIT
4278: DAC 7
4279: DTC /STLIMIT/
4280: DAC K$STL
4281: *
4282: V$SUC DBC SVKVC SUCCEED
4283: DAC 7
4284: DTC /SUCCEED/
4285: DAC K$SUC
4286: DAC NDSUC
4287: *
4288: V$VDF DBC SVFPR VDIFFER
4289: DAC 7
4290: DTC /VDIFFER/
4291: DAC S$VDF
4292: DAC 2
4293: *
4294: V$ALP DBC SVKWC ALPHABET
4295: DAC 8
4296: DTC /ALPHABET/
4297: DAC K$ALP
4298: EJC
4299: *
4300: * STANDARD VARIABLE BLOCKS (CONTINUED)
4301: *
4302: V$CNT DBC SVLBL CONTINUE
4303: DAC 8
4304: DTC /CONTINUE/
4305: DAC L$CNT
4306: *
4307: V$DTP DBC SVFNP DATATYPE
4308: DAC 8
4309: DTC /DATATYPE/
4310: DAC S$DTP
4311: DAC 1
4312: *
4313: V$ERL DBC SVKNM ERRLIMIT
4314: DAC 8
4315: DTC /ERRLIMIT/
4316: DAC K$ERL
4317: *
4318: V$FNC DBC SVKNM FNCLEVEL
4319: DAC 8
4320: DTC /FNCLEVEL/
4321: DAC K$FNC
4322: *
4323: V$MXL DBC SVKNM MAXLNGTH
4324: DAC 8
4325: DTC /MAXLNGTH/
4326: DAC K$MXL
4327: *
4328: V$TER DBC 0 TERMINAL
4329: DAC 8
4330: DTC /TERMINAL/
4331: DAC 0
4332: *
4333: V$PRO DBC SVFNN PROTOTYPE
4334: DAC 9
4335: DTC /PROTOTYPE/
4336: DAC S$PRO
4337: DAC 1
4338: *
4339: DBC 0 DUMMY ENTRY TO END LIST
4340: DAC 10 LENGTH GT 9 (PROTOTYPE)
4341: EJC
4342: *
4343: * LIST OF SVBLK POINTERS FOR KEYWORDS TO BE DUMPED. THE
4344: * LIST IS IN THE ORDER WHICH APPEARS ON THE DUMP OUTPUT.
4345: *
4346: VDMKW DAC V$ANC ANCHOR
4347: DAC V$COD CODE
4348: DAC V$DMP DUMP
4349: DAC V$ERL ERRLIMIT
4350: DAC V$ETX ERRTEXT
4351: DAC V$ERT ERRTYPE
4352: DAC V$FNC FNCLEVEL
4353: DAC V$FTR FTRACE
4354: DAC V$INP INPUT
4355: DAC V$LST LASTNO
4356: DAC V$MXL MAXLENGTH
4357: DAC V$OUP OUTPUT
4358: .IF .CNPF
4359: .ELSE
4360: DAC V$PFL PROFILE
4361: .FI
4362: DAC V$RTN RTNTYPE
4363: DAC V$STC STCOUNT
4364: DAC V$STL STLIMIT
4365: DAC V$STN STNO
4366: DAC V$TRA TRACE
4367: DAC V$TRM TRIM
4368: DAC 0 END OF LIST
4369: *
4370: * TABLE USED BY GTNVR TO SEARCH SVBLK LISTS
4371: *
4372: VSRCH DAC 0 DUMMY ENTRY TO GET PROPER INDEXING
4373: DAC V$EQF START OF 1 CHAR VARIABLES (NONE)
4374: DAC V$EQF START OF 2 CHAR VARIABLES
4375: DAC V$ANY START OF 3 CHAR VARIABLES
4376: DAC V$COD START OF 4 CHAR VARIABLES
4377: DAC V$ABO START OF 5 CHAR VARIABLES
4378: DAC V$ANC START OF 6 CHAR VARIABLES
4379: DAC V$COL START OF 7 CHAR VARIABLES
4380: DAC V$ALP START OF 8 CHAR VARIABLES
4381: DAC V$PRO START OF 9 CHAR VARIABLES
4382: TTL S P I T B O L -- WORKING STORAGE SECTION
4383: *
4384: * THE WORKING STORAGE SECTION CONTAINS AREAS WHICH ARE
4385: * CHANGED DURING EXECUTION OF THE PROGRAM. THE VALUE
4386: * ASSEMBLED IS THE INITIAL VALUE BEFORE EXECUTION STARTS.
4387: *
4388: * ALL THESE AREAS ARE FIXED LENGTH AREAS. VARIABLE LENGTH
4389: * DATA IS STORED IN THE STATIC OR DYNAMIC REGIONS OF THE
4390: * ALLOCATED DATA AREAS.
4391: *
4392: * THE VALUES IN THIS AREA ARE DESCRIBED EITHER AS WORK
4393: * AREAS OR AS GLOBAL VALUES. A WORK AREA IS USED IN AN
4394: * EPHEMERAL MANNER AND THE VALUE IS NOT SAVED FROM ONE
4395: * ENTRY INTO A ROUTINE TO ANOTHER. A GLOBAL VALUE IS A
4396: * LESS TEMPORARY LOCATION WHOSE VALUE IS SAVED FROM ONE
4397: * CALL TO ANOTHER.
4398: *
4399: * A GENERAL PART OF THE APPROACH IN THIS PROGRAM IS NOT
4400: * TO OVERLAP WORK AREAS BETWEEN PROCEDURES EVEN THOUGH A
4401: * SMALL AMOUNT OF SPACE COULD BE SAVED. SUCH OVERLAP IS
4402: * CONSIDERED A SOURCE OF PROGRAM ERRORS AND DECREASES THE
4403: * INFORMATION LEFT BEHIND AFTER A SYSTEM CRASH OF ANY KIND.
4404: *
4405: * THE NAMES OF THESE LOCATIONS ARE LABELS WITH FIVE LETTER
4406: * (A-Y,$) NAMES. AS FAR AS POSSIBLE THE ORDER IS KEPT
4407: * ALPHABETICAL BY THESE NAMES BUT IN SOME CASES THERE
4408: * ARE SLIGHT DEPARTURES CAUSED BY OTHER ORDER REQUIREMENTS.
4409: *
4410: * UNLESS OTHERWISE DOCUMENTED, THE ORDER OF WORK AREAS
4411: * DOES NOT AFFECT THE EXECUTION OF THE SPITBOL PROGRAM.
4412: *
4413: SEC START OF WORKING STORAGE SECTION
4414: EJC
4415: *
4416: * THIS AREA IS NOT CLEARED BY INITIAL CODE
4417: *
4418: CMLAB DAC B$SCL STRING USED TO CHECK LABEL LEGALITY
4419: DAC 2
4420: DTC / /
4421: *
4422: * LABEL TO MARK START OF WORK AREA WHICH IS CLEARED
4423: *
4424: AAAAA DAC 0
4425: *
4426: * WORK AREAS FOR ALLOC PROCEDURE
4427: *
4428: ALDYN DAC 0 AMOUNT OF DYNAMIC STORE
4429: ALFSF DIC +0 FACTOR IN FREE STORE PCNTAGE CHECK
4430: ALLIA DIC +0 DUMP IA
4431: ALLSV DAC 0 SAVE WB IN ALLOC
4432: *
4433: * WORK AREAS FOR ALOST PROCEDURE
4434: *
4435: ALSTA DAC 0 SAVE WA IN ALOST
4436: *
4437: * SAVE AREAS FOR ARRAY FUNCTION (S$ARR)
4438: *
4439: ARCDM DAC 0 COUNT DIMENSIONS
4440: ARNEL DIC +0 COUNT ELEMENTS
4441: ARPTR DAC 0 OFFSET PTR INTO ARBLK
4442: ARSVL DIC +0 SAVE INTEGER LOW BOUND
4443: EJC
4444: * WORK AREAS FOR ARREF ROUTINE
4445: *
4446: ARFSI DIC +0 SAVE CURRENT EVOLVING SUBSCRIPT
4447: ARFXS DAC 0 SAVE BASE STACK POINTER
4448: *
4449: * WORK AREAS FOR B$EFC BLOCK ROUTINE
4450: *
4451: BEFOF DAC 0 SAVE OFFSET PTR INTO EFBLK
4452: *
4453: * WORK AREAS FOR B$PFC BLOCK ROUTINE
4454: *
4455: BPFPF DAC 0 SAVE PFBLK POINTER
4456: BPFSV DAC 0 SAVE OLD FUNCTION VALUE
4457: BPFXT DAC 0 POINTER TO STACKED ARGUMENTS
4458: *
4459: * SAVE AREAS FOR COLLECT FUNCTION (S$COL)
4460: *
4461: CLSVI DIC +0 SAVE INTEGER ARGUMENT
4462: *
4463: * GLOBAL VALUES FOR CMPIL PROCEDURE
4464: *
4465: CMERC DAC 0 COUNT OF INITIAL COMPILE ERRORS
4466: CMPXS DAC 0 SAVE STACK PTR IN CASE OF ERRORS
4467: CMPSN DAC 1 NUMBER OF NEXT STATEMENT TO COMPILE
4468: CMPSS DAC 0 SAVE SUBROUTINE STACK PTR
4469: *
4470: * WORK AREA FOR CNCRD
4471: *
4472: CNSCC DAC 0 POINTER TO CONTROL CARD STRING
4473: CNSWC DAC 0 WORD COUNT
4474: CNR$T DAC 0 POINTER TO R$TTL OR R$STL
4475: CNTTL DAC 0 FLAG FOR -TITLE, -STITL
4476: *
4477: * WORK AREAS FOR CONVERT FUNCTION (S$CNV)
4478: *
4479: CNVTP DAC 0 SAVE PTR INTO SCVTB
4480: *
4481: * FLAG FOR SUPPRESSION OF COMPILATION STATISTICS.
4482: *
4483: CPSTS DAC 0 SUPPRESS COMP. STATS IF NON ZERO
4484: *
4485: * GLOBAL VALUES FOR CONTROL CARD SWITCHES
4486: *
4487: .IF .CASL
4488: CSWCI DAC 0 0/1 FOR -NOCASEIG/CASEIG
4489: .FI
4490: CSWFL DAC 1 0/1 FOR -NOFAIL/-FAIL
4491: CSWIN DAC INILN XXX FOR -INXXX
4492: CSWLS DAC 1 0/1 FOR -NOLIST/-LIST
4493: EJC
4494: *
4495: * GLOBAL LOCATION USED BY PATST PROCEDURE
4496: *
4497: CTMSK DBC 0 LAST BIT POSITION USED IN R$CTP
4498: CURID DAC 0 CURRENT ID VALUE
4499: *
4500: * GLOBAL VALUE FOR CDWRD PROCEDURE
4501: *
4502: CWCOF DAC 0 NEXT WORD OFFSET IN CURRENT CCBLK
4503: *
4504: * WORK AREAS FOR DATA FUNCTION (S$DAT)
4505: *
4506: DATDV DAC 0 SAVE VRBLK PTR FOR DATATYPE NAME
4507: DATXS DAC 0 SAVE INITIAL STACK POINTER
4508: *
4509: * WORK AREAS FOR DEFINE FUNCTION (S$DEF)
4510: *
4511: DEFLB DAC 0 SAVE VRBLK PTR FOR LABEL
4512: DEFNA DAC 0 COUNT FUNCTION ARGUMENTS
4513: DEFVR DAC 0 SAVE VRBLK PTR FOR FUNCTION NAME
4514: DEFXS DAC 0 SAVE INITIAL STACK POINTER
4515: *
4516: * WORK AREAS FOR DUMPR PROCEDURE
4517: *
4518: DMARG DAC 0 DUMP ARGUMENT
4519: DMPKB DAC B$KVT DUMMY KVBLK FOR USE IN DUMPR
4520: DMPKT DAC TRBKV KVVAR TRBLK POINTER
4521: DMPKN DAC 0 KEYWORD NUMBER (MUST FOLLOW DMPKB)
4522: DMPSA DAC 0 PRESERVE WA OVER PRTVL CALL
4523: DMPSV DAC 0 GENERAL SCRATCH SAVE
4524: DMVCH DAC 0 CHAIN POINTER FOR VARIABLE BLOCKS
4525: DMPCH DAC 0 SAVE SORTED VRBLK CHAIN POINTER
4526: *
4527: * GLOBAL LOCATIONS FOR DYNAMIC STORAGE POINTERS
4528: *
4529: DNAMB DAC 0 START OF DYNAMIC AREA
4530: DNAMP DAC 0 NEXT AVAILABLE LOC IN DYNAMIC AREA
4531: DNAME DAC 0 END OF AVAILABLE DYNAMIC AREA
4532: *
4533: * WORK AREAS FOR DUPL FUNCTION (S$DUP)
4534: *
4535: DUPSI DIC +0 STORE INTEGER STRING LENGTH
4536: *
4537: * WORK AREA FOR ENDFILE (S$ENF)
4538: *
4539: ENFCH DAC 0 FOR IOCHN CHAIN HEAD
4540: *
4541: * WORK AREA FOR ERROR PROCESSING.
4542: *
4543: EROSN DAC 0 FLAG FOR SPECIAL EROSI RETURN
4544: ERRFT DAC 0 FATAL ERROR FLAG
4545: ERRSP DAC 0 ERROR SUPPRESSION FLAG
4546: EJC
4547: *
4548: * DUMP AREA FOR ERTEX
4549: *
4550: ERTWA DAC 0 SAVE WA
4551: ERTWB DAC 0 SAVE WB
4552: *
4553: * GLOBAL VALUES FOR EVALI
4554: *
4555: EVLIN DAC P$LEN DUMMY PATTERN BLOCK PCODE
4556: EVLIS DAC 0 POINTER TO SUBSEQUENT NODE
4557: EVLIV DAC 0 VALUE OF PARAMETER
4558: *
4559: * WORK AREA FOR EXPAN
4560: *
4561: EXPSV DAC 0 SAVE OP DOPE VECTOR POINTER
4562: *
4563: * FLAG FOR SUPPRESSION OF EXECUTION STATS
4564: *
4565: EXSTS DAC 0 SUPPRESS EXEC STATS IF SET
4566: *
4567: * GLOBAL VALUES FOR EXFAL AND RETURN
4568: *
4569: FLPRT DAC 0 LOCATION OF FAIL OFFSET FOR RETURN
4570: FLPTR DAC 0 LOCATION OF FAILURE OFFSET ON STACK
4571: *
4572: * WORK AREAS FOR GBCOL PROCEDURE
4573: *
4574: GBCFL DAC 0 GARBAGE COLLECTOR ACTIVE FLAG
4575: GBCLM DAC 0 POINTER TO LAST MOVE BLOCK (PASS 3)
4576: GBCNM DAC 0 DUMMY FIRST MOVE BLOCK
4577: GBCNS DAC 0 REST OF DUMMY BLOCK (FOLLOWS GBCNM)
4578: GBSVA DAC 0 SAVE WA
4579: GBSVB DAC 0 SAVE WB
4580: GBSVC DAC 0 SAVE WC
4581: *
4582: * GLOBAL LOCATION TO COUNT GARBAGE COLLECTIONS (GBCOL)
4583: *
4584: GBCNT DAC 0 COUNT OF GARBAGE COLLECTIONS
4585: *
4586: * WORK AREAS FOR GTNVR PROCEDURE
4587: *
4588: GNVHE DAC 0 PTR TO END OF HASH CHAIN
4589: GNVNW DAC 0 NUMBER OF WORDS IN STRING NAME
4590: GNVSA DAC 0 SAVE WA
4591: GNVSB DAC 0 SAVE WB
4592: GNVSP DAC 0 POINTER INTO VSRCH TABLE
4593: GNVST DAC 0 POINTER TO CHARS OF STRING
4594: *
4595: * GLOBAL VALUE FOR GTCOD AND GTEXP
4596: *
4597: GTCEF DAC 0 SAVE FAIL PTR IN CASE OF ERROR
4598: *
4599: * WORK AREAS FOR GTINT
4600: *
4601: GTINA DAC 0 SAVE WA
4602: GTINB DAC 0 SAVE WB
4603: EJC
4604: *
4605: * WORK AREAS FOR GTNUM PROCEDURE
4606: *
4607: GTNNF DAC 0 ZERO/NONZERO FOR RESULT +/-
4608: GTNSI DIC +0 GENERAL INTEGER SAVE
4609: .IF .CNRA
4610: .ELSE
4611: GTNDF DAC 0 0/1 FOR DEC POINT SO FAR NO/YES
4612: GTNES DAC 0 ZERO/NONZERO EXPONENT +/-
4613: GTNEX DIC +0 REAL EXPONENT
4614: GTNSC DAC 0 SCALE (PLACES AFTER POINT)
4615: GTNSR DRC +0.0 GENERAL REAL SAVE
4616: GTNSV DIC +0 SAVE IA
4617: GTNRD DAC 0 FLAG FOR OK REAL NUMBER
4618: .FI
4619: *
4620: * WORK AREAS FOR GTPAT PROCEDURE
4621: *
4622: GTPSB DAC 0 SAVE WB
4623: *
4624: * WORK AREAS FOR GTSTG PROCEDURE
4625: *
4626: GTSSF DAC 0 0/1 FOR RESULT +/-
4627: GTSVC DAC 0 SAVE WC
4628: GTSVB DAC 0 SAVE WB
4629: GTSWK DAC 0 PTR TO WORK AREA FOR GTSTG
4630: .IF .CNRA
4631: .ELSE
4632: GTSES DAC 0 CHAR + OR - FOR EXPONENT +/-
4633: GTSRS DRC +0.0 GENERAL REAL SAVE
4634: *
4635: * GLOBAL LOCATIONS (CONSTANTS) FOR GTSTG PROCEDURE
4636: *
4637: GTSRN DRC +0.0 ROUNDING FACTOR 0.5*10**-CFP$S
4638: GTSSC DRC +0.0 SCALING VALUE 10**CFP$S
4639: .FI
4640: EJC
4641: *
4642: * WORK AREAS FOR GTVAR PROCEDURE
4643: *
4644: GTVRC DAC 0 SAVE WC
4645: *
4646: * FLAGS FOR HEADER PRINTING
4647: *
4648: HEADN DAC 0 NON-ZERO IF HDRS NOT TO BE PRINTED
4649: HEADP DAC 0 HEADER PRINTED FLAG
4650: *
4651: * GLOBAL VALUES FOR VARIABLE HASH TABLE
4652: *
4653: HSHNB DIC +0 NUMBER OF HASH BUCKETS
4654: HSHTB DAC 0 POINTER TO START OF VRBLK HASH TABL
4655: HSHTE DAC 0 POINTER PAST END OF VRBLK HASH TABL
4656: *
4657: * WORK AREA FOR INIT
4658: *
4659: INICD DIC +0 CODE KWD VAL (NEEDED FOR BATCH)
4660: INISS DAC 0 SAVE SUBROUTINE STACK PTR
4661: INITR DAC 0 SAVE TERMINAL FLAG
4662: .IF .CNBF
4663: .ELSE
4664: *
4665: * SAVE AREA FOR INSBF
4666: *
4667: INSAB DAC 0 ENTRY WA PLUS ENTRY WB
4668: INSBB DAC 0 BFBLK POINTER
4669: INSBC DAC 0 BCBLK POINTER
4670: INSSA DAC 0 SAVE ENTRY WA
4671: INSSB DAC 0 SAVE ENTRY WB
4672: .FI
4673: *
4674: * WORK AREAS FOR IOPUT
4675: *
4676: IOPNF DAC 0 NAME OFFSET
4677: IOPVR DAC 0 FILETAG VRBLK
4678: IOPWA DAC 0 KEEP WA
4679: IOPWB DAC 0 KEEP WB
4680: IOPWC DAC 0 KEEP WC
4681: EJC
4682: *
4683: * GLOBAL VALUES FOR KEYWORD VALUES WHICH ARE STORED AS ONE
4684: * WORD INTEGERS. THESE VALUES MUST BE ASSEMBLED IN THE
4685: * FOLLOWING ORDER (AS DICTATED BY K$XXX DEFINITION VALUES).
4686: *
4687: KVANC DAC 0 ANCHOR
4688: KVDMP DAC 0 DUMP
4689: KVERL DAC 0 ERRLIMIT
4690: KVERT DAC 0 ERRTYPE
4691: KVFTR DAC 0 FTRACE
4692: KVINP DAC 1 INPUT
4693: KVMXL DAC 5000 MAXLENGTH
4694: KVOUP DAC 1 OUTPUT
4695: .IF .CNPF
4696: .ELSE
4697: KVPFL DAC 0 PROFILE
4698: .FI
4699: KVTRA DAC 0 TRACE
4700: KVTRM DAC 0 TRIM
4701: KVFNC DAC 0 FNCLEVEL
4702: KVLST DAC 0 LASTNO
4703: KVSTN DAC 0 STNO
4704: *
4705: * GLOBAL VALUES FOR OTHER KEYWORDS
4706: *
4707: KVALP DAC 0 ALPHABET
4708: KVRTN DAC NULLS RTNTYPE (SCBLK POINTER)
4709: KVCOD DIC 0 CODE
4710: .IF .CS16
4711: KVSTL DIC +32767 STLIMIT
4712: KVSTC DIC +32767 STCOUNT (COUNTS DOWN FROM STLIMIT)
4713: .ELSE
4714: KVSTL DIC +50000 STLIMIT
4715: KVSTC DIC +50000 STCOUNT (COUNTS DOWN FROM STLIMIT)
4716: .FI
4717: .IF .CNLD
4718: .ELSE
4719: *
4720: * WORK AREAS FOR LOAD FUNCTION
4721: *
4722: LODFN DAC 0 POINTER TO VRBLK FOR FUNC NAME
4723: LODNA DAC 0 COUNT NUMBER OF ARGUMENTS
4724: .FI
4725: EJC
4726: *
4727: * GLOBAL VALUES FOR LISTR PROCEDURE
4728: *
4729: LSTLC DAC 0 COUNT LINES ON SOURCE LIST PAGE
4730: LSTNP DAC 0 MAX NUMBER OF LINES ON PAGE
4731: LSTPF DAC 1 SET NONZERO IF CURRENT IMAGE LISTED
4732: LSTPG DAC 0 CURRENT SOURCE LIST PAGE NUMBER
4733: LSTPO DAC 0 OFFSET TO PAGE NNN MESSAGE
4734: LSTSN DAC 0 REMEMBER LAST STMNUM LISTED
4735: *
4736: * MAXIMUM SIZE OF SPITBOL OBJECTS
4737: *
4738: MXLEN DAC 0 INITIALISED BY SYSMX CALL
4739: *
4740: * EXECUTION CONTROL VARIABLE
4741: *
4742: NOXEQ DAC 0 SET NON-ZERO TO INHIBIT EXECUTION
4743: .IF .CNPF
4744: .ELSE
4745: *
4746: * PROFILER GLOBAL VALUES AND WORK LOCATIONS
4747: *
4748: PFDMP DAC 0 SET NON-0 IF PROFILE SET NON-0
4749: PFFNC DAC 0 SET NON-0 IF FUNCT JUST ENTERED
4750: PFSTM DIC +0 TO STORE STARTING TIME OF STMT
4751: PFETM DIC +0 TO STORE ENDING TIME OF STMT
4752: PFSVW DAC 0 TO SAVE A W-REG
4753: PFTBL DAC 0 GETS ADRS OF (IMAG) TABLE BASE
4754: PFNTE DAC 0 NR OF TABLE ENTRIES
4755: PFSTE DIC +0 TABLE ENTRY SIZE IN BAUS
4756: .FI
4757: EJC
4758: *
4759: * GLOBAL VALUES USED IN PATTERN MATCH ROUTINES
4760: *
4761: PMDFL DAC 0 PATTERN ASSIGNMENT FLAG
4762: PMHBS DAC 0 HISTORY STACK BASE POINTER
4763: PMSSL DAC 0 LENGTH OF SUBJECT STRING IN CHARS
4764: *
4765: * GLOBAL VALUE FOR PRTNM PROCEDURE
4766: *
4767: PRNMV DAC 0 VRBLK PTR FROM LAST NAME SEARCH
4768: *
4769: * WORK AREAS FOR PRTNM PROCEDURE
4770: *
4771: PRNSI DIC +0 SCRATCH INTEGER LOC
4772: *
4773: * WORK AREAS FOR PRTSN PROCEDURE
4774: *
4775: PRSNA DAC 0 SAVE WA
4776: *
4777: * GLOBAL VALUES FOR PRINT PROCEDURES
4778: *
4779: PRAVL DAC 0 SET IF PRINT FILE AVAILABLE
4780: PRBLK DAC 0 ADDRESS OF BUFFER BLANKING STRING
4781: PRBUF DAC 0 PTR TO PRINT BFR IN STATIC
4782: PRCHS DAC 0 ADDRESS OF CHARS IN PRINT BUFFER
4783: PRCMV DAC 0 NO. OF BAUS TO MOVE IN BFR CLEARING
4784: PRECL DAC 0 EXTENDED/COMPACT LISTING FLAG
4785: PRLEN DAC 0 LENGTH OF PRINT BUFFER IN CHARS
4786: PROFS DAC 0 OFFSET TO NEXT LOCATION IN PRBUF
4787: PRPUT DAC 0 SET IF CHARS TO BE PUT IN BFR
4788: PRSTD DAC 0 TESTED BY PRTPG
4789: PRSTO DAC 0 STANDARD LISTING OPTION FLAG
4790: PRTEF DAC 0 ENDFILE FLAG
4791: *
4792: * WORK AREAS FOR PRTST, PTTST PROCEDURES
4793: *
4794: PRSVA DAC 0 SAVE WA
4795: PRSVB DAC 0 SAVE WB
4796: PRTVA DAC 0 SAVE WA
4797: PRTVB DAC 0 SAVE WB
4798: *
4799: * WORK AREA FOR PRTVL
4800: *
4801: PRVSI DAC 0 SAVE IDVAL
4802: *
4803: * WORK AREAS FOR PATTERN MATCH ROUTINES
4804: *
4805: PSAVE DAC 0 TEMPORARY SAVE FOR CURRENT NODE PTR
4806: PSAVC DAC 0 SAVE CURSOR IN P$SPN, P$STR
4807: EJC
4808: *
4809: * FLAG TO TELL ERROR THAT WE ARE READING SOURCE LINE
4810: *
4811: RDRER DAC 0 READ-SOURCE-LINE IN PROGRESS FLAG
4812: *
4813: * AMOUNT OF MEMORY RESERVED FOR END OF EXECUTION
4814: *
4815: RSMEM DAC 0 RESERVE MEMORY
4816: *
4817: * WORK AREAS FOR RETRN ROUTINE
4818: *
4819: RTNBP DAC 0 TO SAVE A BLOCK POINTER
4820: RTNFV DAC 0 NEW FUNCTION VALUE (RESULT)
4821: RTNSV DAC 0 OLD FUNCTION VALUE (SAVED VALUE)
4822: *
4823: * RELOCATABLE GLOBAL VALUES
4824: *
4825: * ALL THE POINTERS IN THIS SECTION CAN POINT TO BLOCKS IN
4826: * THE DYNAMIC STORAGE AREA AND MUST BE RELOCATED BY THE
4827: * GARBAGE COLLECTOR. THEY ARE IDENTIFIED BY R$XXX NAMES.
4828: *
4829: R$AAA DAC 0 START OF RELOCATABLE VALUES
4830: R$ARF DAC 0 ARRAY BLOCK POINTER FOR ARREF
4831: R$CCB DAC 0 PTR TO CCBLK BEING BUILT (CDWRD)
4832: R$CIM DAC 0 PTR TO CURRENT COMPILER INPUT STR
4833: R$CMP DAC 0 COPY OF R$CIM USED IN CMPIL
4834: R$CNI DAC 0 PTR TO NEXT COMPILER INPUT STRING
4835: R$CNT DAC 0 CDBLK POINTER FOR SETEXIT CONTINUE
4836: R$COD DAC 0 POINTER TO CURRENT CDBLK OR EXBLK
4837: R$COP DAC 0 PTR TO -COPY CHAIN STACK
4838: R$CTP DAC 0 PTR TO CURRENT CTBLK FOR PATST
4839: R$ERT DAC 0 TRBLK POINTER FOR ERRTYPE TRACE
4840: R$ETX DAC NULLS POINTER TO ERRTEXT STRING
4841: R$EXS DAC 0 = SAVE XL IN EXPDM
4842: R$FNC DAC 0 TRBLK POINTER FOR FNCLEVEL TRACE
4843: R$GTC DAC 0 KEEP CODE PTR FOR GTCOD,GTEXP
4844: R$IO1 DAC 0 FIRST ARGUMENT
4845: R$IOL DAC 0 SECOND ARGUMENT (FILETAG) SCBLK PTR
4846: R$IOR DAC 0 FILEPROPS SCBLK PTR
4847: R$IOT DAC 0 TRTIO TRACE BLK PTR
4848: .IF .CNBF
4849: .ELSE
4850: R$PMB DAC 0 BUFFER PTR IN PATTERN MATCH
4851: .FI
4852: R$PMS DAC 0 SUBJECT STRING PTR IN PATTERN MATCH
4853: R$RA2 DAC 0 REPLACE SECOND ARGUMENT LAST TIME
4854: R$RA3 DAC 0 REPLACE THIRD ARGUMENT LAST TIME
4855: R$RPT DAC 0 PTR TO CTBLK REPLACE TABLE LAST USD
4856: R$SCP DAC 0 SAVE POINTER FROM LAST SCANE CALL
4857: R$SXL DAC 0 PRESERVE XL IN SORTC
4858: R$SXR DAC 0 PRESERVE XR IN SORTA/SORTC
4859: R$STC DAC 0 TRBLK POINTER FOR STCOUNT TRACE
4860: R$STL DAC 0 SOURCE LISTING SUB-TITLE
4861: R$SXC DAC 0 CODE (CDBLK) PTR FOR SETEXIT TRAP
4862: R$TTL DAC NULLS SOURCE LISTING TITLE
4863: R$XSC DAC 0 STRING POINTER FOR XSCAN
4864: EJC
4865: *
4866: * THE REMAINING POINTERS IN THIS LIST ARE USED TO POINT
4867: * TO FUNCTION BLOCKS FOR NORMALLY UNDEFINED OPERATORS.
4868: *
4869: R$UBA DAC STNDO BINARY AT
4870: R$UBM DAC STNDO BINARY AMPERSAND
4871: R$UBN DAC STNDO BINARY NUMBER SIGN
4872: R$UBP DAC STNDO BINARY PERCENT
4873: R$UBT DAC STNDO BINARY NOT
4874: R$UUB DAC STNDO UNARY VERTICAL BAR
4875: R$UUE DAC STNDO UNARY EQUAL
4876: R$UUN DAC STNDO UNARY NUMBER SIGN
4877: R$UUP DAC STNDO UNARY PERCENT
4878: R$UUS DAC STNDO UNARY SLASH
4879: R$UUX DAC STNDO UNARY EXCLAMATION
4880: R$YYY DAC 0 LAST RELOCATABLE LOCATION
4881: *
4882: * WORK AREAS FOR SUBSTR FUNCTION (S$SUB)
4883: *
4884: SBSSV DAC 0 SAVE THIRD ARGUMENT
4885: *
4886: * GLOBAL LOCATIONS USED IN SCAN PROCEDURE
4887: *
4888: SCNBL DAC 0 SET NON-ZERO IF SCANNED PAST BLANKS
4889: SCNCC DAC 0 NON-ZERO TO SCAN CONTROL CARD NAME
4890: SCNGO DAC 0 SET NON-ZERO TO SCAN GOTO FIELD
4891: SCNIL DAC 0 LENGTH OF CURRENT INPUT IMAGE
4892: SCNPT DAC 0 POINTER TO NEXT LOCATION IN R$CIM
4893: SCNRS DAC 0 SET NON-ZERO TO SIGNAL RESCAN
4894: SCNTP DAC 0 SAVE SYNTAX TYPE FROM LAST CALL
4895: *
4896: * WORK AREAS FOR SCAN PROCEDURE
4897: *
4898: SCNSA DAC 0 SAVE WA
4899: SCNSB DAC 0 SAVE WB
4900: SCNSC DAC 0 SAVE WC
4901: SCNSE DAC 0 START OF CURRENT ELEMENT
4902: SCNOF DAC 0 SAVE OFFSET
4903: *
4904: * WORK AREA FOR DETACH PROCEDURE
4905: *
4906: SDETF DAC 0 TRACE BLOCK FLAG
4907: *
4908: * WORK AREA FOR ENDFILE PROCEDURE
4909: *
4910: SENFR DAC 0 SAVE XR
4911: .IF .CNSR
4912: .ELSE
4913: EJC
4914: *
4915: * WORK AREA USED BY SORTA, SORTC, SORTF, SORTH
4916: *
4917: SRTDF DAC 0 DATATYPE FIELD NAME
4918: SRTFD DAC 0 FOUND DFBLK ADDRESS
4919: SRTFF DAC 0 FOUND FIELD NAME
4920: SRTFO DAC 0 OFFSET TO FIELD NAME
4921: SRTNR DAC 0 NUMBER OF ROWS
4922: SRTOF DAC 0 OFFSET WITHIN ROW TO SORT KEY
4923: SRTRT DAC 0 ROOT OFFSET
4924: SRTS1 DAC 0 SAVE OFFSET 1
4925: SRTS2 DAC 0 SAVE OFFSET 2
4926: SRTSC DAC 0 SAVE WC
4927: SRTSF DAC 0 SORT ARRAY FIRST ROW OFFSET
4928: SRTSN DAC 0 SAVE N
4929: SRTSO DAC 0 OFFSET TO A(0)
4930: SRTSR DAC 0 0 , NON-ZERO FOR SORT, RSORT
4931: SRTST DAC 0 STRIDE FROM ONE ROW TO NEXT
4932: SRTWC DAC 0 DUMP WC
4933: .FI
4934: *
4935: * VALUES FOR INDICATING COMPILATION/EXECUTION STAGE
4936: *
4937: STAGE DAC 0 INITIAL VALUE = INITIAL COMPILE
4938: STAGX DAC 0 NON-ZERO IF EXECUTING
4939: *
4940: * GLOBAL VALUES DEFINING EXTENT OF STATIC AREA (ALOST)
4941: *
4942: STATB DAC 0 START OF STATIC AREA
4943: STATE DAC 0 END OF STATIC AREA
4944: EJC
4945: *
4946: * GLOBAL STACK POINTER
4947: *
4948: STBAS DAC 0 POINTER PAST STACK BASE
4949: *
4950: * WORK AREAS FOR STOPR ROUTINE
4951: *
4952: STPSI DIC +0 SAVE VALUE OF STCOUNT
4953: STPTI DIC +0 SAVE TIME ELAPSED
4954: STPXR DAC 0 SAVE XR
4955: *
4956: * GLOBAL VALUES FOR SETEXIT FUNCTION (S$STX)
4957: *
4958: STXOF DAC 0 FAILURE OFFSET
4959: STXVR DAC NULLS VRBLK POINTER OR NULL
4960: *
4961: * WORK AREAS FOR TFIND PROCEDURE
4962: *
4963: TFNSI DIC +0 NUMBER OF HEADERS
4964: *
4965: * GLOBAL VALUE FOR TIME KEEPING
4966: *
4967: TIMSX DIC +0 TIME AT START OF EXECUTION
4968: *
4969: * TERMINAL BUFFER ADDRESSES, FLAGS ETC
4970: *
4971: TTBLK DAC 0 BLANKING STRING ADRS
4972: TTBUF DAC 0 BUFFER ADRS
4973: TTCHS DAC 0 START OF BUFFER CHARACTERS
4974: TTCMV DAC 0 COUNT OF BLANKING CHARS TO MOVE
4975: TTERL DAC 0 ERROR FLAG
4976: TTINS DAC 0 NON-ZERO IF STD INPUT FROM TERML
4977: TTLEN DAC 0 LENGTH OF TERMINAL BUFFER
4978: TTLST DAC 0 COPY STD O/P TO TERML IF SET
4979: TTOFS DAC 0 OFFSET TO POSITION IN TERML BFR
4980: TTOUS DAC 0 SET IF STD OUTPUT TO TERMINAL
4981: *
4982: * WORK AREAS FOR XSCAN PROCEDURE
4983: *
4984: XSCBL DAC 0 COUNT OF TRAILING BLANKS
4985: XSCNB DAC 0 NON-ZERO IF NON-BLANKS SEEN
4986: XSCRT DAC 0 SAVE RETURN CODE
4987: XSCWB DAC 0 SAVE REGISTER WB
4988: *
4989: * GLOBAL VALUES FOR XSCAN AND XSCNI PROCEDURES
4990: *
4991: XSOFS DAC 0 OFFSET TO CURRENT LOCATION IN R$XSC
4992: *
4993: * LABEL TO MARK END OF WORK AREA
4994: *
4995: YYYYY DAC 0
4996: TTL S P I T B O L -- INITIALIZATION
4997: *
4998: * INITIALISATION
4999: * THE FOLLOWING SECTION RECEIVES CONTROL FROM THE SYSTEM
5000: * AT THE START OF A RUN WITH THE REGISTERS SET AS FOLLOWS.
5001: *
5002: * (XS) POINTS PAST STACK BASE
5003: * (XR) POINTS TO FIRST WORD OF DATA AREA
5004: * (XL) POINTS TO LAST WORD OF DATA AREA
5005: * (WA) INITIAL &CODE VALUE
5006: *
5007: SEC START OF PROGRAM SECTION
5008: *
5009: INITL RTN INITIALISATION CODE
5010: MOV WA,INICD SAVE INITIAL CODE KYWD VALUE
5011: .IF .CNBT
5012: MOV XR,STATB START ADDRESS OF STATIC
5013: .ELSE
5014: *
5015: * INITIALISE WORK AREA (ESSENTIAL FOR BATCHED RUNS)
5016: *
5017: MOV XR,WB PRESERVE XR
5018: MOV =YYYYY,WA POINT TO END OF WORK AREA
5019: SUB =AAAAA,WA GET LENGTH OF WORK AREA
5020: BTW WA CONVERT TO WORDS
5021: LCT WA,WA COUNT FOR LOOP
5022: MOV =AAAAA,XR SET UP INDEX REGISTER
5023: *
5024: * CLEAR WORK SPACE
5025: *
5026: INI01 ZER (XR)+ CLEAR A WORD
5027: BCT WA,INI01 LOOP TILL DONE
5028: MOV =STNDO,WA UNDEFINED OPERATORS POINTER
5029: MOV =R$YYY,WC POINT TO TABLE END
5030: SUB =R$UBA,WC LENGTH OF UNDEF. OPERATORS TABLE
5031: BTW WC CONVERT TO WORDS
5032: LCT WC,WC LOOP COUNTER
5033: MOV =R$UBA,XR SET UP XR
5034: *
5035: * SET CORRECT VALUE INTO UNDEFINED OPERATORS TABLE
5036: *
5037: INI02 MOV WA,(XR)+ STORE VALUE
5038: BCT WC,INI02 LOOP TILL ALL DONE
5039: MOV =NUM01,WA GET A 1
5040: MOV WA,CMPSN STATEMENT NO
5041: MOV WA,CSWFL NOFAIL
5042: MOV WA,CSWLS LIST
5043: MOV WA,KVINP INPUT
5044: MOV WA,KVOUP OUTPUT
5045: MOV WA,LSTPF NOTHING FOR LISTR YET
5046: MOV =INILN,WA INPUT IMAGE LENGTH
5047: MOV WA,CSWIN STORE FOR LATER USE
5048: MOV =B$KVT,DMPKB DUMP
5049: MOV =TRBKV,DMPKT DUMP
5050: MOV =P$LEN,EVLIN EVAL
5051: EJC
5052: MOV =NULLS,WA GET NULLSTRING POINTER
5053: MOV WA,KVRTN RETURN
5054: MOV WA,R$ETX ERRTEXT
5055: MOV WA,R$TTL TITLE FOR LISTING
5056: MOV WA,STXVR SETEXIT
5057: LDI STLIM GET DEFAULT STLIMIT
5058: STI KVSTL STATEMENT LIMIT
5059: STI KVSTC STATEMENT COUNT
5060: MOV WB,STATB STORE START ADRS OF STATIC
5061: .FI
5062: .IF .CSIG
5063: MNZ CSWCI -CASEIG
5064: .FI
5065: JSR SYSTM INITIALISE TIMER
5066: STI TIMSX STORE TIME
5067: LDI INICD LOAD INITIAL CODE KWD VALUE
5068: STI KVCOD STORE
5069: MOV *E$SRS,RSMEM RESERVE MEMORY
5070: MOV XS,STBAS STORE STACK BASE
5071: SSS INISS SAVE S-R STACK PTR
5072: *
5073: * NOW CONVERT FREE STORE PERCENTAGE TO A SUITABLE FACTOR
5074: * FOR EASY TESTING IN ALLOC ROUTINE.
5075: *
5076: LDI INTVH GET 100
5077: DVI ALFSP FORM 100 / ALFSP
5078: STI ALFSF STORE THE FACTOR
5079: .IF .CNRA
5080: .ELSE
5081: *
5082: * INITIALIZE VALUES FOR REAL CONVERSION ROUTINE
5083: *
5084: LCT WB,=CFP$S LOAD COUNTER FOR SIGNIFICANT DIGITS
5085: LDR REAV1 LOAD 1.0
5086: *
5087: * LOOP TO COMPUTE 10**(MAX NUMBER SIGNIFICANT DIGITS)
5088: *
5089: INI03 MLR REAVT * 10.0
5090: BCT WB,INI03 LOOP TILL DONE
5091: STR GTSSC STORE 10**(MAX SIG DIGITS)
5092: LDR REAP5 LOAD 0.5
5093: DVR GTSSC COMPUTE 0.5*10**(MAX SIG DIGITS)
5094: STR GTSRN STORE AS ROUNDING BIAS
5095: .FI
5096: ZER WC SET TO READ PARAMETERS
5097: JSR PRPAR READ THEM
5098: EJC
5099: *
5100: * NOW COMPUTE STARTING ADDRESS FOR DYNAMIC STORE AND IF
5101: * NECESSARY REQUEST MORE MEMORY.
5102: *
5103: SUB *E$SRS,XL ALLOW FOR RESERVE MEMORY
5104: MOV PRLEN,WA GET PRINT BUFFER LENGTH
5105: ADD TTLEN,WA ADD TERMINAL BUFFER LENGTH
5106: ADD WA,WA ALLOW FOR EQUALLY BIG BLANK STRINGS
5107: ADD =CFP$A,WA ADD NO. OF CHARS IN ALPHABET
5108: ADD =NSTMX,WA ADD CHARS FOR GTSTG BFR
5109: CTB WA,8 CONVERT TO BAUS, ALLOWING A MARGIN
5110: MOV STATB,XR POINT TO STATIC BASE
5111: ADD WA,XR INCREMENT FOR ABOVE BUFFERS
5112: ADD *E$HNB,XR INCREMENT FOR HASH TABLE
5113: ADD *E$STS,XR BUMP FOR INITIAL STATIC BLOCK
5114: JSR SYSMX GET MXLEN
5115: MOV WA,KVMXL PROVISIONALLY STORE AS MAXLNGTH
5116: MOV WA,MXLEN AND AS MXLEN
5117: BGT XR,WA,INI05 SKIP IF STATIC HI EXCEEDS MXLEN
5118: MOV WA,XR USE MXLEN INSTEAD
5119: ICA XR MAKE BIGGER THAN MXLEN
5120: *
5121: * HERE TO STORE VALUES WHICH MARK INITIAL DIVISION
5122: * OF DATA AREA INTO STATIC AND DYNAMIC
5123: *
5124: INI05 MOV XR,DNAMB DYNAMIC BASE ADRS
5125: MOV XR,DNAMP DYNAMIC PTR
5126: BNZ WA,INI06 SKIP IF NON-ZERO MXLEN
5127: DCA XR POINT A WORD IN FRONT
5128: MOV XR,KVMXL USE AS MAXLNGTH
5129: MOV XR,MXLEN AND AS MXLEN
5130: *
5131: * LOOP HERE IF NECESSARY TILL ENOUGH MEMORY OBTAINED
5132: * SO THAT DNAME IS ABOVE DNAMB
5133: *
5134: INI06 MOV XL,DNAME STORE DYNAMIC END ADDRESS
5135: BLT DNAMB,XL,INI08 SKIP IF HIGH ENOUGH
5136: JSR SYSMM REQUEST MORE MEMORY
5137: WTB XR CONVERT TO BAUS
5138: ADD XR,XL BUMP BY AMOUNT OBTAINED
5139: BNZ XR,INI06 TRY AGAIN
5140: MOV =ENDMO,XR POINT TO FAILURE MESSAGE
5141: MOV ENDML,WC MESSAGE LENGTH
5142: JSR SYSPR PRINT IT (PRTST NOT YET USABLE)
5143: PPM INI07
5144: PPM INI07
5145: *
5146: * EMERGENCY SHUTDOWN
5147: *
5148: INI07 MOV =KVCOD,WA CODE KEYWORD
5149: JSR SYSEJ PACK UP (STOPR NOT YET USABLE)
5150: EJC
5151: *
5152: * INITIALISE PRINT BUFFER WITH BLANK WORDS
5153: *
5154: INI08 MOV PRLEN,WA NO. OF CHARS IN PRINT BFR
5155: MOV STATB,XR POINT TO STATIC AGAIN
5156: MOV XR,PRBUF PRINT BFR IS PUT AT STATIC START
5157: MOV =B$SCL,(XR)+ STORE STRING TYPE CODE
5158: MOV WA,(XR)+ AND STRING LENGTH
5159: MOV XR,PRCHS KEEP ADRS OF BUFFER PROPER
5160: MOV XR,XL COPY IT
5161: CTB WA,0 WORDS NEEDED EXPRESSED IN BAUS
5162: MOV WA,PRCMV KEEP FOR CLEARING BUFFER
5163: MOV XR,PRBLK CONSTRUCT ADRS OF BLANKING STRING
5164: ADD WA,PRBLK ADD OFFSET TO BLANKING STRING
5165: ADD WA,WA CLEAR BOTH BFR AND BLANKING STRING
5166: MOV NULLW,(XR)+ CLEAR FIRST WORD
5167: BZE WA,INI09 SKIP IF NO PRINT BUFFER
5168: DCA WA ADJUST FOR FIRST WORD
5169: MVW PERFORM BLANKING
5170: *
5171: * SET UP TERMINAL BUFFER
5172: *
5173: INI09 MOV TTLEN,WA LENGTH OF TERMINAL BUFFER
5174: MOV XR,TTBUF ADRS OF TERMINAL STRING BUFFER
5175: MOV =B$SCL,(XR)+ STRING TYPE CODE
5176: MOV WA,(XR)+ STRING LENGTH
5177: MOV XR,TTCHS KEEP ADRS OF BUFFER PROPER
5178: MOV XR,XL COPY IT
5179: CTB WA,0 WORDS NEEDED EXPRESSED IN BAUS
5180: MOV WA,TTCMV KEEP FOR CLEARING BUFFER
5181: MOV XR,TTBLK CONSTRUCT ADRS OF BLANKING STRING
5182: ADD WA,TTBLK ADD OFFSET TO BLANKING STRING
5183: ADD WA,WA CLEAR BOTH BFR AND BLANKING STRING
5184: MOV NULLW,(XR)+ CLEAR FIRST WORD
5185: BZE WA,INI10 SKIP IF NO PRINT BUFFER
5186: DCA WA ADJUST FOR FIRST WORD
5187: MVW PERFORM BLANKING
5188: *
5189: * INITIALIZE NUMBER OF HASH HEADERS
5190: *
5191: INI10 MOV =E$HNB,WA GET NUMBER OF HASH HEADERS
5192: MTI WA CONVERT TO INTEGER
5193: STI HSHNB STORE FOR USE BY GTNVR PROCEDURE
5194: LCT WA,WA COUNTER FOR CLEARING HASH TABLE
5195: MOV XR,HSHTB POINTER TO HASH TABLE
5196: *
5197: * LOOP TO CLEAR HASH TABLE
5198: *
5199: INI11 ZER (XR)+ BLANK A WORD
5200: BCT WA,INI11 LOOP
5201: MOV XR,HSHTE END OF HASH TABLE ADRS IS KEPT
5202: *
5203: * ALLOCATE WORK AREA FOR GTSTG CONVERSION PROCEDURE
5204: *
5205: MOV =NSTMX,WA GET MAX NUM CHARS IN OUTPUT NUMBER
5206: CTB WA,SCSI$ NO OF BAUS NEEDED
5207: MOV XR,GTSWK STORE BFR ADRS
5208: ADD WA,XR BUMP FOR WORK BFR
5209: EJC
5210: *
5211: * BUILD ALPHABET STRING FOR ALPHABET KEYWORD AND REPLACE
5212: *
5213: MOV XR,KVALP SAVE ALPHABET POINTER
5214: MOV =B$SCL,(XR) STRING BLK TYPE
5215: MOV =CFP$A,WC NO OF CHARS IN ALPHABET
5216: MOV WC,SCLEN(XR) STORE AS STRING LENGTH
5217: MOV WC,WB COPY CHAR COUNT
5218: CTB WB,SCSI$ NO. OF BAUS NEEDED
5219: ADD XR,WB CURRENT END ADDRESS FOR STATIC
5220: MOV WB,STATE STORE STATIC END ADRS
5221: LCT WC,WC LOOP COUNTER
5222: PSC XR POINT TO CHARS OF STRING
5223: ZER WB SET INITIAL CHARACTER VALUE
5224: *
5225: * LOOP TO ENTER CHARACTER CODES IN ORDER
5226: *
5227: INI12 SCH WB,(XR)+ STORE NEXT CODE
5228: ICV WB BUMP CODE VALUE
5229: BCT WC,INI12 LOOP TILL ALL STORED
5230: CSC XR COMPLETE STORE CHARACTERS
5231: *
5232: * INITIALIZE VARIABLE BLOCKS FOR INPUT OUTPUT TERMINAL
5233: *
5234: MOV =V$INP,XL POINT TO STRING /INPUT/
5235: MOV =TRTIN,WB TRBLK TYPE FOR INPUT
5236: JSR INOUT PERFORM INPUT ASSOCIATION
5237: MOV =V$OUP,XL POINT TO STRING /OUTPUT/
5238: MOV =TRTOU,WB TRBLK TYPE FOR OUTPUT
5239: JSR INOUT PERFORM OUTPUT ASSOCIATION
5240: BZE TTLEN,INI13 SKIP IF NO TERMINAL I/O
5241: MOV =V$TER,XL POINT TO STRING /TERMINAL/
5242: MOV =TRTOU,WB TRTYP FOR OUTPUT
5243: JSR INOUT PERFORM ASSOCIATION
5244: MOV =V$TER,XL
5245: MOV =TRTIN,WB TRTYP FOR INPUT
5246: JSR INOUT PERFORM ASSOCIATION
5247: EJC
5248: *
5249: *
5250: * PREPARE FOR COMPILATION
5251: *
5252: INI13 MOV XS,FLPTR IN CASE STACK OVERFLOWS IN COMPILER
5253: *
5254: * NOW COMPILE SOURCE INPUT CODE
5255: *
5256: JSR CMPIL CALL COMPILER
5257: MOV XR,R$COD SET PTR TO FIRST CODE BLOCK
5258: MOV =NULLS,R$TTL FORGET TITLE
5259: MOV =NULLS,R$STL FORGET SUB-TITLE
5260: ZER R$CIM FORGET COMPILER INPUT IMAGE
5261: ZER XL CLEAR DUD VALUE
5262: ZER WB DONT SHIFT DYNAMIC STORE UP
5263: JSR GBCOL CLEAR GARBAGE LEFT FROM COMPILE
5264: BNZ CPSTS,INIX1 SKIP IF NO LISTING OF COMP STATS
5265: JSR PRTPG EJECT PAGE
5266: *
5267: * PRINT COMPILE STATISTICS
5268: *
5269: MOV DNAMP,WA NEXT AVAILABLE LOC
5270: SUB STATB,WA MINUS START
5271: BTW WA CONVERT TO WORDS
5272: MTI WA CONVERT TO INTEGER
5273: MOV =ENCM1,XR POINT TO /MEMORY USED (WORDS)/
5274: JSR PRTMI PRINT MESSAGE
5275: MOV DNAME,WA END OF MEMORY
5276: SUB DNAMP,WA MINUS NEXT AVAILABLE LOC
5277: BTW WA CONVERT TO WORDS
5278: MTI WA CONVERT TO INTEGER
5279: MOV =ENCM2,XR POINT TO /MEMORY AVAILABLE (WORDS)/
5280: JSR PRTMI PRINT LINE
5281: MTI CMERC GET COUNT OF ERRORS AS INTEGER
5282: MOV =ENCM3,XR POINT TO /COMPILE ERRORS/
5283: JSR PRTMI PRINT IT
5284: MTI GBCNT GARBAGE COLLECTION COUNT
5285: SBI INTV1 ADJUST FOR UNAVOIDABLE COLLECT
5286: MOV =STPM5,XR POINT TO /STORAGE REGENERATIONS/
5287: JSR PRTMI PRINT GBCOL COUNT
5288: JSR SYSTM GET TIME
5289: SBI TIMSX GET COMPILATION TIME
5290: MOV =ENCM4,XR POINT TO COMPILATION TIME (MSEC)/
5291: JSR PRTMI PRINT MESSAGE
5292: ADD =NUM05,LSTLC BUMP LINE COUNT
5293: EJC
5294: *
5295: * PREPARE NOW TO START EXECUTION
5296: *
5297: *
5298: * CHECK FOR NOEXECUTE
5299: *
5300: INIX1 BNZ NOXEQ,INIX3 JUMP IF EXECUTION SUPPRESSED
5301: ZER GBCNT INITIALISE COLLECT COUNT
5302: BZE HEADP,INIX2 SKIP IF NO PRTPG CALLS IN COMPILN
5303: JSR PRTPG EJECT STANDARD PRINTER FILE
5304: *
5305: * INFORM OSINT OF STAGE
5306: *
5307: INIX2 JSR SYSBX CALL BEFORE STARTING EXECUTION
5308: ZER -(XS) SET FAILURE LOCATION ON STACK
5309: MOV XS,FLPTR SAVE PTR TO FAILURE OFFSET WORD
5310: MOV R$COD,XR LOAD PTR TO ENTRY CODE BLOCK
5311: MOV =STGXT,STAGE SET STAGE FOR EXECUTE TIME
5312: JSR SYSTM GET TIME
5313: STI TIMSX STORE FOR END RUN PROCESSING
5314: .IF .CNPF
5315: .ELSE
5316: STI PFSTM STORE TIME FOR PROFILER
5317: MOV CMPSN,PFNTE COPY STATEMENTS COMPILED COUNT
5318: .FI
5319: BRI (XR) START XEQ WITH FIRST STATEMENT
5320: *
5321: * HERE IF EXECUTION IS SUPPRESSED
5322: *
5323: INIX3 JSR PRTFH PRINT A BLANK LINE
5324: MOV =ENCM5,XR POINT TO /EXECUTION SUPPRESSED/
5325: MOV TTERL,TTLST TO FORCE MSG TO TERMINAL
5326: JSR PRTSF PRINT NOEXECUTE MESSAGE
5327: MOV =KVCOD,WA ENDING CODE
5328: JSR SYSEJ END OF JOB, EXIT TO SYSTEM
5329: TTL S P I T B O L -- SNOBOL4 OPERATOR ROUTINES
5330: *
5331: * THIS SECTION INCLUDES ALL ROUTINES WHICH CAN BE ACCESSED
5332: * DIRECTLY FROM THE GENERATED CODE EXCEPT SYSTEM FUNCTIONS.
5333: *
5334: * ALL ROUTINES IN THIS SECTION START WITH A LABEL OF THE
5335: * FORM O$XXX WHERE XXX IS THREE LETTERS. THE GENERATED CODE
5336: * CONTAINS A POINTER TO THE APPROPRIATE ENTRY LABEL.
5337: *
5338: * SINCE THE GENERAL FORM OF THE GENERATED CODE CONSISTS OF
5339: * POINTERS TO BLOCKS WHOSE FIRST WORD IS THE ADDRESS OF THE
5340: * ACTUAL ENTRY POINT LABEL (O$XXX).
5341: *
5342: * THESE ROUTINES ARE IN ALPHABETICAL ORDER BY THEIR
5343: * ENTRY LABEL NAMES (I.E. BY THE XXX OF THE O$XXX NAME)
5344: *
5345: * THESE ROUTINES RECEIVE CONTROL AS FOLLOWS
5346: *
5347: * (CP) POINTER TO NEXT CODE WORD
5348: * (XS) CURRENT STACK POINTER
5349: EJC
5350: *
5351: * BINARY PLUS (ADDITION)
5352: *
5353: O$ADD ENT ENTRY POINT
5354: JSR ARITH FETCH ARITHMETIC OPERANDS
5355: ERR 001,ADDITION LEFT OPERAND IS NOT NUMERIC
5356: ERR 002,ADDITION RIGHT OPERAND IS NOT NUMERIC
5357: .IF .CNRA
5358: .ELSE
5359: PPM OADD1 JUMP IF REAL OPERANDS
5360: .FI
5361: *
5362: * HERE TO ADD TWO INTEGERS
5363: *
5364: ADI ICVAL(XL) ADD RIGHT OPERAND TO LEFT
5365: INO EXINT RETURN INTEGER IF NO OVERFLOW
5366: ERB 003,ADDITION CAUSED INTEGER OVERFLOW
5367: .IF .CNRA
5368: .ELSE
5369: *
5370: * HERE TO ADD TWO REALS
5371: *
5372: OADD1 ADR RCVAL(XL) ADD RIGHT OPERAND TO LEFT
5373: RNO EXREA RETURN REAL IF NO OVERFLOW
5374: ERB 004,ADDITION CAUSED REAL OVERFLOW
5375: .FI
5376: EJC
5377: *
5378: * UNARY PLUS (AFFIRMATION)
5379: *
5380: O$AFF ENT ENTRY POINT
5381: MOV (XS)+,XR LOAD OPERAND
5382: JSR GTNUM CONVERT TO NUMERIC
5383: ERR 005,AFFIRMATION OPERAND IS NOT NUMERIC
5384: BRN EXIXR RETURN IF CONVERTED TO NUMERIC
5385: EJC
5386: *
5387: * BINARY BAR (ALTERNATION)
5388: *
5389: O$ALT ENT ENTRY POINT
5390: MOV (XS)+,XR LOAD RIGHT OPERAND
5391: JSR GTPAT CONVERT TO PATTERN
5392: ERR 006,ALTERNATION RIGHT OPERAND IS NOT PATTERN
5393: *
5394: * MERGE HERE FROM SPECIAL (LEFT ALTERNATION) CASE
5395: *
5396: OALT1 MOV =P$ALT,WB SET PCODE FOR ALTERNATIVE NODE
5397: JSR PBILD BUILD ALTERNATIVE NODE
5398: MOV XR,XL SAVE ADDRESS OF ALTERNATIVE NODE
5399: MOV (XS)+,XR LOAD LEFT OPERAND
5400: JSR GTPAT CONVERT TO PATTERN
5401: ERR 007,ALTERNATION LEFT OPERAND IS NOT PATTERN
5402: BEQ XR,=P$ALT,OALT2 JUMP IF LEFT ARG IS ALTERNATION
5403: MOV XR,PTHEN(XL) SET LEFT OPERAND AS SUCCESSOR
5404: MOV XL,XR MOVE RESULT TO PROPER REGISTER
5405: BRN EXIXR JUMP FOR NEXT CODE WORD
5406: *
5407: * COME HERE IF LEFT ARGUMENT IS ITSELF AN ALTERNATION
5408: *
5409: * THE RESULT IS MORE EFFICIENT IF WE MAKE THE REPLACEMENT
5410: *
5411: * (A / B) / C = A / (B / C)
5412: *
5413: OALT2 MOV PARM1(XR),PTHEN(XL) BUILD THE (B / C) NODE
5414: MOV PTHEN(XR),-(XS) SET A AS NEW LEFT ARG
5415: MOV XL,XR SET (B / C) AS NEW RIGHT ARG
5416: BRN OALT1 MERGE BACK TO BUILD A / (B / C)
5417: EJC
5418: *
5419: * ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY NAME)
5420: *
5421: O$AMN ENT ENTRY POINT
5422: LCW XR LOAD NUMBER OF SUBSCRIPTS
5423: MOV XR,WB SET FLAG FOR BY NAME
5424: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE
5425: *
5426: * ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY VALUE)
5427: *
5428: O$AMV ENT ENTRY POINT
5429: LCW XR LOAD NUMBER OF SUBSCRIPTS
5430: ZER WB SET FLAG FOR BY VALUE
5431: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE
5432: *
5433: * ARRAY REFERENCE (ONE SUBSCRIPT, BY NAME)
5434: *
5435: O$AON ENT ENTRY POINT
5436: MOV (XS),XR LOAD SUBSCRIPT VALUE
5437: MOV 1(XS),XL LOAD ARRAY VALUE
5438: MOV (XL),WA LOAD FIRST WORD OF ARRAY OPERAND
5439: BEQ WA,=B$VCT,OAON2 JUMP IF VECTOR REFERENCE
5440: BEQ WA,=B$TBT,OAON3 JUMP IF TABLE REFERENCE
5441: *
5442: * HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE
5443: *
5444: OAON1 MOV =NUM01,XR SET NUMBER OF SUBSCRIPTS TO ONE
5445: MOV XR,WB SET FLAG FOR BY NAME
5446: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE
5447: *
5448: * HERE IF WE HAVE A VECTOR REFERENCE
5449: *
5450: OAON2 BNE (XR),=B$ICL,OAON1 USE LONG ROUTINE IF NOT INTEGER
5451: LDI ICVAL(XR) LOAD INTEGER SUBSCRIPT VALUE
5452: MFI WA,EXFAL COPY AS ADDRESS INT, FAIL IF OVFLO
5453: BZE WA,EXFAL FAIL IF ZERO
5454: ADD =VCVLB,WA COMPUTE OFFSET IN WORDS
5455: WTB WA CONVERT TO BAUS
5456: MOV WA,(XS) COMPLETE NAME ON STACK
5457: BLT WA,VCLEN(XL),EXITS EXIT IF SUBSCRIPT NOT TOO LARGE
5458: BRN EXFAL ELSE FAIL
5459: *
5460: * HERE FOR TABLE REFERENCE
5461: *
5462: OAON3 MNZ WB SET FLAG FOR NAME REFERENCE
5463: JSR TFIND LOCATE/CREATE TABLE ELEMENT
5464: PPM EXFAL FAIL IF ACCESS FAILS
5465: MOV XL,1(XS) STORE NAME BASE ON STACK
5466: MOV WA,(XS) STORE NAME OFFSET ON STACK
5467: BRN EXITS EXIT WITH RESULT ON STACK
5468: EJC
5469: *
5470: * ARRAY REFERENCE (ONE SUBSCRIPT, BY VALUE)
5471: *
5472: O$AOV ENT ENTRY POINT
5473: MOV (XS)+,XR LOAD SUBSCRIPT VALUE
5474: MOV (XS)+,XL LOAD ARRAY VALUE
5475: MOV (XL),WA LOAD FIRST WORD OF ARRAY OPERAND
5476: BEQ WA,=B$VCT,OAOV2 JUMP IF VECTOR REFERENCE
5477: BEQ WA,=B$TBT,OAOV3 JUMP IF TABLE REFERENCE
5478: *
5479: * HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE
5480: *
5481: OAOV1 MOV XL,-(XS) RESTACK ARRAY VALUE
5482: MOV XR,-(XS) RESTACK SUBSCRIPT
5483: MOV =NUM01,XR SET NUMBER OF SUBSCRIPTS TO ONE
5484: ZER WB SET FLAG FOR VALUE CALL
5485: BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE
5486: *
5487: * HERE IF WE HAVE A VECTOR REFERENCE
5488: *
5489: OAOV2 BNE (XR),=B$ICL,OAOV1 USE LONG ROUTINE IF NOT INTEGER
5490: LDI ICVAL(XR) LOAD INTEGER SUBSCRIPT VALUE
5491: MFI WA,EXFAL MOVE AS ONE WORD INT, FAIL IF OVFLO
5492: BZE WA,EXFAL FAIL IF ZERO
5493: ADD =VCVLB,WA COMPUTE OFFSET IN WORDS
5494: WTB WA CONVERT TO BAUS
5495: BGE WA,VCLEN(XL),EXFAL FAIL IF SUBSCRIPT TOO LARGE
5496: JSR ACESS ACCESS VALUE
5497: PPM EXFAL FAIL IF ACCESS FAILS
5498: BRN EXIXR ELSE RETURN VALUE TO CALLER
5499: *
5500: * HERE FOR TABLE REFERENCE BY VALUE
5501: *
5502: OAOV3 ZER WB SET FLAG FOR VALUE REFERENCE
5503: JSR TFIND CALL TABLE SEARCH ROUTINE
5504: PPM EXFAL FAIL IF ACCESS FAILS
5505: BRN EXIXR EXIT WITH RESULT IN XR
5506: EJC
5507: *
5508: * ASSIGNMENT (O$RPL MERGES)
5509: *
5510: O$ASS ENT ENTRY POINT
5511: MOV (XS)+,WB LOAD VALUE TO BE ASSIGNED
5512: MOV (XS)+,WA LOAD NAME OFFSET
5513: MOV (XS),XL LOAD NAME BASE
5514: MOV WB,(XS) STORE ASSIGNED VALUE AS RESULT
5515: JSR ASIGN PERFORM ASSIGNMENT
5516: PPM EXFAL FAIL IF ASSIGNMENT FAILS
5517: BRN EXITS EXIT WITH RESULT ON STACK
5518: *
5519: * COMPILATION ERROR
5520: *
5521: O$CER ENT ENTRY POINT
5522: ERB 008,COMPILATION ERROR ENCOUNTERED DURING EXECUTION
5523: *
5524: * UNARY AT (CURSOR ASSIGNMENT)
5525: *
5526: O$CAS ENT ENTRY POINT
5527: MOV (XS)+,WC LOAD NAME OFFSET (PARM2)
5528: MOV (XS)+,XR LOAD NAME BASE (PARM1)
5529: MOV =P$CAS,WB SET PCODE FOR CURSOR ASSIGNMENT
5530: JSR PBILD BUILD NODE
5531: BRN EXIXR JUMP FOR NEXT CODE WORD
5532: EJC
5533: *
5534: * CONCATENATION
5535: *
5536: O$CNC ENT ENTRY POINT
5537: MOV (XS),XR LOAD RIGHT ARGUMENT
5538: BEQ XR,=NULLS,OCNC3 JUMP IF RIGHT ARG IS NULL
5539: MOV 1(XS),XL LOAD LEFT ARGUMENT
5540: BEQ XL,=NULLS,OCNC4 JUMP IF LEFT ARGUMENT IS NULL
5541: MOV =B$SCL,WA GET CONSTANT TO TEST FOR STRING
5542: BNE WA,(XL),OCNC2 JUMP IF LEFT ARG NOT A STRING
5543: BNE WA,(XR),OCNC2 JUMP IF RIGHT ARG NOT A STRING
5544: *
5545: * MERGE HERE TO CONCATENATE TWO STRINGS
5546: *
5547: OCNC1 MOV SCLEN(XL),WA LOAD LEFT ARGUMENT LENGTH
5548: ADD SCLEN(XR),WA COMPUTE RESULT LENGTH
5549: JSR ALOCS ALLOCATE SCBLK FOR RESULT
5550: MOV XR,1(XS) STORE RESULT PTR OVER LEFT ARGUMENT
5551: PSC XR PREPARE TO STORE CHARS OF RESULT
5552: MOV SCLEN(XL),WA GET NUMBER OF CHARS IN LEFT ARG
5553: PLC XL PREPARE TO LOAD LEFT ARG CHARS
5554: MVC MOVE CHARACTERS OF LEFT ARGUMENT
5555: MOV (XS)+,XL LOAD RIGHT ARG POINTER, POP STACK
5556: MOV SCLEN(XL),WA LOAD NUMBER OF CHARS IN RIGHT ARG
5557: PLC XL PREPARE TO LOAD RIGHT ARG CHARS
5558: MVC MOVE CHARACTERS OF RIGHT ARGUMENT
5559: BRN EXITS EXIT WITH RESULT ON STACK
5560: *
5561: * COME HERE IF ARGUMENTS ARE NOT BOTH STRINGS
5562: *
5563: OCNC2 JSR GTSTG CONVERT RIGHT ARG TO STRING
5564: PPM OCNC5 JUMP IF RIGHT ARG IS NOT STRING
5565: MOV XR,XL SAVE RIGHT ARG PTR
5566: JSR GTSTG CONVERT LEFT ARG TO STRING
5567: PPM OCNC6 JUMP IF LEFT ARG IS NOT A STRING
5568: MOV XR,-(XS) STACK LEFT ARGUMENT
5569: MOV XL,-(XS) STACK RIGHT ARGUMENT
5570: MOV XR,XL MOVE LEFT ARG TO PROPER REG
5571: MOV (XS),XR MOVE RIGHT ARG TO PROPER REG
5572: BRN OCNC1 MERGE BACK TO CONCATENATE STRINGS
5573: EJC
5574: *
5575: * CONCATENATION (CONTINUED)
5576: *
5577: * COME HERE FOR NULL RIGHT ARGUMENT
5578: *
5579: OCNC3 ICA XS REMOVE RIGHT ARG FROM STACK
5580: BRN EXITS RETURN WITH LEFT ARGUMENT ON STACK
5581: *
5582: * HERE FOR NULL LEFT ARGUMENT
5583: *
5584: OCNC4 ICA XS UNSTACK ONE ARGUMENT
5585: MOV XR,(XS) STORE RIGHT ARGUMENT
5586: BRN EXITS EXIT WITH RESULT ON STACK
5587: *
5588: * HERE IF RIGHT ARGUMENT IS NOT A STRING
5589: *
5590: OCNC5 MOV XR,XL MOVE RIGHT ARGUMENT PTR
5591: MOV (XS)+,XR LOAD LEFT ARG POINTER
5592: *
5593: * MERGE HERE WHEN LEFT ARGUMENT IS NOT A STRING
5594: *
5595: OCNC6 JSR GTPAT CONVERT LEFT ARG TO PATTERN
5596: ERR 009,CONCATENATION LEFT OPND IS NOT STRING OR PATTERN
5597: MOV XR,-(XS) SAVE RESULT ON STACK
5598: MOV XL,XR POINT TO RIGHT OPERAND
5599: JSR GTPAT CONVERT TO PATTERN
5600: ERR 010,CONCATENATION RIGHT OPD IS NOT STRING OR PATTERN
5601: MOV XR,XL MOVE FOR PCONC
5602: MOV (XS)+,XR RELOAD LEFT OPERAND PTR
5603: JSR PCONC CONCATENATE PATTERNS
5604: BRN EXIXR EXIT WITH RESULT IN XR
5605: EJC
5606: *
5607: * COMPLEMENTATION
5608: *
5609: O$COM ENT ENTRY POINT
5610: MOV (XS)+,XR LOAD OPERAND
5611: MOV (XR),WA LOAD TYPE WORD
5612: *
5613: * MERGE BACK HERE AFTER CONVERSION
5614: *
5615: OCOM1 BEQ WA,=B$ICL,OCOM2 JUMP IF INTEGER
5616: .IF .CNRA
5617: .ELSE
5618: BEQ WA,=B$RCL,OCOM3 JUMP IF REAL
5619: .FI
5620: JSR GTNUM ELSE CONVERT TO NUMERIC
5621: ERR 011,COMPLEMENTATION OPERAND IS NOT NUMERIC
5622: BRN OCOM1 BACK TO CHECK CASES
5623: *
5624: * HERE TO COMPLEMENT INTEGER
5625: *
5626: OCOM2 LDI ICVAL(XR) LOAD INTEGER VALUE
5627: NGI NEGATE
5628: INO EXINT RETURN INTEGER IF NO OVERFLOW
5629: ERB 012,COMPLEMENTATION CAUSED INTEGER OVERFLOW
5630: .IF .CNRA
5631: .ELSE
5632: *
5633: * HERE TO COMPLEMENT REAL
5634: *
5635: OCOM3 LDR RCVAL(XR) LOAD REAL VALUE
5636: NGR NEGATE
5637: BRN EXREA RETURN REAL RESULT
5638: .FI
5639: EJC
5640: *
5641: * BINARY SLASH (DIVISION)
5642: *
5643: O$DVD ENT ENTRY POINT
5644: JSR ARITH FETCH ARITHMETIC OPERANDS
5645: ERR 013,DIVISION LEFT OPERAND IS NOT NUMERIC
5646: ERR 014,DIVISION RIGHT OPERAND IS NOT NUMERIC
5647: .IF .CNRA
5648: .ELSE
5649: PPM ODVD2 JUMP IF REAL OPERANDS
5650: .FI
5651: *
5652: * HERE TO DIVIDE TWO INTEGERS
5653: *
5654: DVI ICVAL(XL) DIVIDE LEFT OPERAND BY RIGHT
5655: INO EXINT RESULT OK IF NO OVERFLOW
5656: ERB 015,DIVISION CAUSED INTEGER OVERFLOW
5657: .IF .CNRA
5658: .ELSE
5659: *
5660: * HERE TO DIVIDE TWO REALS
5661: *
5662: ODVD2 DVR RCVAL(XL) DIVIDE LEFT OPERAND BY RIGHT
5663: RNO EXREA RETURN REAL IF NO OVERFLOW
5664: ERB 016,DIVISION CAUSED REAL OVERFLOW
5665: .FI
5666: EJC
5667: *
5668: * EXPONENTIATION
5669: *
5670: O$EXP ENT ENTRY POINT
5671: MOV (XS)+,XR LOAD EXPONENT
5672: JSR GTNUM CONVERT TO NUMBER
5673: ERR 017,EXPONENTIATION RIGHT OPERAND IS NOT NUMERIC
5674: .IF .CNRA
5675: .ELSE
5676: BNE WA,=B$ICL,OEXP7 JUMP IF REAL
5677: .FI
5678: MOV XR,XL MOVE EXPONENT
5679: MOV (XS)+,XR LOAD BASE
5680: JSR GTNUM CONVERT TO NUMERIC
5681: ERR 018,EXPONENTIATION LEFT OPERAND IS NOT NUMERIC
5682: LDI ICVAL(XL) LOAD EXPONENT
5683: ILT OEXP8 ERROR IF NEGATIVE EXPONENT
5684: .IF .CNRA
5685: .ELSE
5686: BEQ WA,=B$RCL,OEXP3 JUMP IF BASE IS REAL
5687: .FI
5688: *
5689: * HERE TO EXPONENTIATE AN INTEGER
5690: *
5691: MFI WA,OEXP2 CONVERT EXPONENT TO 1 WORD INTEGER
5692: LCT WA,WA SET LOOP COUNTER
5693: LDI INTV1 LOAD INITIAL VALUE OF 1
5694: BNZ WA,OEXP1 JUMP IF NON-ZERO EXPONENT
5695: INE EXINT GIVE ZERO AS RESULT FOR NONZERO**0
5696: BRN OEXP4 ELSE ERROR OF 0**0
5697: *
5698: * LOOP TO PERFORM EXPONENTIATION
5699: *
5700: OEXP1 MLI ICVAL(XR) MULTIPLY BY BASE
5701: IOV OEXP2 JUMP IF OVERFLOW
5702: BCT WA,OEXP1 LOOP BACK TILL COMPUTATION COMPLETE
5703: BRN EXINT THEN RETURN INTEGER RESULT
5704: *
5705: * HERE IF INTEGER OVERFLOW
5706: *
5707: OEXP2 ERB 019,EXPONENTIATION CAUSED INTEGER OVERFLOW
5708: EJC
5709: *
5710: * EXPONENTIATION (CONTINUED)
5711: .IF .CNRA
5712: .ELSE
5713: *
5714: * HERE TO EXPONENTIATE A REAL
5715: *
5716: OEXP3 MFI WA,OEXP6 CONVERT EXPONENT TO ONE WORD
5717: LCT WA,WA SET LOOP COUNTER
5718: LDR REAV1 LOAD 1.0 AS INITIAL VALUE
5719: BNZ WA,OEXP5 JUMP IF NON-ZERO EXPONENT
5720: RNE EXREA RETURN 1.0 IF NONZERO**ZERO
5721: .FI
5722: *
5723: * HERE FOR ERROR OF 0**0 OR 0.0**0
5724: *
5725: OEXP4 ERB 020,EXPONENTIATION RESULT IS UNDEFINED
5726: .IF .CNRA
5727: .ELSE
5728: *
5729: * LOOP TO PERFORM EXPONENTIATION
5730: *
5731: OEXP5 MLR RCVAL(XR) MULTIPLY BY BASE
5732: ROV OEXP6 JUMP IF OVERFLOW
5733: BCT WA,OEXP5 LOOP TILL COMPUTATION COMPLETE
5734: BRN EXREA THEN RETURN REAL RESULT
5735: *
5736: * HERE IF REAL OVERFLOW
5737: *
5738: OEXP6 ERB 021,EXPONENTIATION CAUSED REAL OVERFLOW
5739: *
5740: * HERE IF REAL EXPONENT
5741: *
5742: OEXP7 ERB 022,EXPONENTIATION RIGHT OPERAND IS REAL NOT INTEGER
5743: .FI
5744: *
5745: * HERE FOR NEGATIVE EXPONENT
5746: *
5747: OEXP8 ERB 023,EXPONENTIATION RIGHT OPERAND IS NEGATIVE
5748: EJC
5749: *
5750: * FAILURE IN EXPRESSION EVALUATION
5751: *
5752: * THIS ENTRY POINT IS USED IF THE EVALUATION OF AN
5753: * EXPRESSION, INITIATED BY THE EVALX PROCEDURE, FAILS.
5754: * CONTROL IS RETURNED TO AN APPROPRIATE POINT IN EVALX.
5755: *
5756: O$FEX ENT ENTRY POINT
5757: JMG EVLXF JUMP TO FAILURE LOC IN EVALX
5758: *
5759: * FAILURE DURING EVALUATION OF A COMPLEX OR DIRECT GOTO
5760: *
5761: O$FIF ENT ENTRY POINT
5762: ERB 024,GOTO EVALUATION FAILURE
5763: *
5764: * FUNCTION CALL (MORE THAN ONE ARGUMENT)
5765: *
5766: O$FNC ENT ENTRY POINT
5767: LCW WA LOAD NUMBER OF ARGUMENTS
5768: LCW XR LOAD FUNCTION VRBLK POINTER
5769: MOV VRFNC(XR),XL LOAD FUNCTION POINTER
5770: BNE WA,FARGS(XL),CFUNC USE CENTRAL ROUTINE IF WRONG NUM
5771: BRI (XL) JUMP TO FUNCTION IF ARG COUNT OK
5772: *
5773: * FUNCTION NAME ERROR
5774: *
5775: O$FNE ENT ENTRY POINT
5776: LCW WA GET NEXT CODE WORD
5777: BNE WA,=ORNM$,OFNE1 FAIL IF NOT EVALUATING EXPRESSION
5778: BNZ 2(XS),OFNE1 FAIL UNLESS EXPRN WANTED BY VALUE
5779: JMG EVLXV JOIN EXPRESSION BY VALUE CODE
5780: *
5781: * HERE FOR ERROR
5782: *
5783: OFNE1 ERB 025,FUNCTION CALLED BY NAME RETURNED A VALUE
5784: *
5785: * FUNCTION CALL (SINGLE ARGUMENT)
5786: *
5787: O$FNS ENT ENTRY POINT
5788: LCW XR LOAD FUNCTION VRBLK POINTER
5789: MOV =NUM01,WA SET NUMBER OF ARGUMENTS TO ONE
5790: MOV VRFNC(XR),XL LOAD FUNCTION POINTER
5791: BNE WA,FARGS(XL),CFUNC USE CENTRAL ROUTINE IF WRONG NUM
5792: BRI (XL) JUMP TO FUNCTION IF ARG COUNT OK
5793: EJC
5794: * CALL TO UNDEFINED FUNCTION
5795: *
5796: O$FUN ENT ENTRY POINT
5797: ERB 026,UNDEFINED FUNCTION CALLED
5798: *
5799: * EXECUTE COMPLEX GOTO
5800: *
5801: O$GOC ENT ENTRY POINT
5802: MOV 1(XS),XR LOAD NAME BASE POINTER
5803: BHI XR,STATE,OGOC1 JUMP IF NOT NATURAL VARIABLE
5804: ADD *VRTRA,XR ELSE POINT TO VRTRA FIELD
5805: BRI (XR) AND JUMP THROUGH IT
5806: *
5807: * HERE IF GOTO OPERAND IS NOT NATURAL VARIABLE
5808: *
5809: OGOC1 ERB 027,GOTO OPERAND IS NOT A NATURAL VARIABLE
5810: *
5811: * EXECUTE DIRECT GOTO
5812: *
5813: O$GOD ENT ENTRY POINT
5814: MOV (XS),XR LOAD OPERAND
5815: MOV (XR),WA LOAD FIRST WORD
5816: BEQ WA,=B$CDC,OGOD1 JUMP IF CODE BLOCK
5817: BEQ WA,=B$CDS,OGOD2 JUMP IF CODE BLOCK
5818: ERB 028,GOTO OPERAND IN DIRECT GOTO IS NOT CODE
5819: *
5820: * CASE OF COMPLEX FAILURE CODE
5821: *
5822: OGOD1 MOV FLPTR,XS POP GARBAGE OFF STACK
5823: MOV CDFAL(XR),(XS) SET NEW FAILURE OFFSET
5824: BRN STMGO JUMP TO EXECUTE CODE
5825: *
5826: * CASE OF SIMPLE FAILURE CODE
5827: *
5828: OGOD2 MOV FLPTR,XS POP GARBAGE OFF STACK
5829: MOV *CDFAL,(XS) SET NEW FAILURE OFFSET
5830: BRN STMGO JUMP TO EXECUTE CODE
5831: *
5832: * SET GOTO FAILURE TRAP
5833: *
5834: * THIS ROUTINE IS EXECUTED AT THE START OF A COMPLEX OR
5835: * DIRECT FAILURE GOTO TO TRAP A SUBSEQUENT FAIL (SEE EXFAL)
5836: *
5837: O$GOF ENT ENTRY POINT
5838: MOV FLPTR,XR POINT TO FAIL OFFSET ON STACK
5839: ICA (XR) POINT FAILURE TO O$FIF WORD
5840: ICP POINT TO NEXT CODE WORD
5841: BRN EXITS EXIT TO CONTINUE
5842: EJC
5843: *
5844: * BINARY DOLLAR (IMMEDIATE ASSIGNMENT)
5845: *
5846: * THE PATTERN BUILT BY BINARY DOLLAR IS A COMPOUND PATTERN.
5847: * SEE DESCRIPTION AT START OF PATTERN MATCH SECTION FOR
5848: * DETAILS OF THE STRUCTURE WHICH IS CONSTRUCTED.
5849: *
5850: O$IMA ENT ENTRY POINT
5851: MOV =P$IMC,WB SET PCODE FOR LAST NODE
5852: MOV (XS)+,WC POP NAME OFFSET (PARM2)
5853: MOV (XS)+,XR POP NAME BASE (PARM1)
5854: JSR PBILD BUILD P$IMC NODE
5855: MOV XR,XL SAVE PTR TO NODE
5856: MOV (XS),XR LOAD LEFT ARGUMENT
5857: JSR GTPAT CONVERT TO PATTERN
5858: ERR 029,IMMEDIATE ASSIGNMENT LEFT OPERAND IS NOT PATTERN
5859: MOV XR,(XS) SAVE PTR TO LEFT OPERAND PATTERN
5860: MOV =P$IMA,WB SET PCODE FOR FIRST NODE
5861: JSR PBILD BUILD P$IMA NODE
5862: MOV (XS)+,PTHEN(XR) SET LEFT OPERAND AS P$IMA SUCCESSOR
5863: JSR PCONC CONCATENATE TO FORM FINAL PATTERN
5864: BRN EXIXR ALL DONE
5865: *
5866: * INDIRECTION (BY NAME)
5867: *
5868: O$INN ENT ENTRY POINT
5869: MNZ WB SET FLAG FOR RESULT BY NAME
5870: BRN INDIR JUMP TO COMMON ROUTINE
5871: *
5872: * INTERROGATION
5873: *
5874: O$INT ENT ENTRY POINT
5875: MOV =NULLS,(XS) REPLACE OPERAND WITH NULL
5876: BRN EXITS EXIT FOR NEXT CODE WORD
5877: *
5878: * INDIRECTION (BY VALUE)
5879: *
5880: O$INV ENT ENTRY POINT
5881: ZER WB SET FLAG FOR BY VALUE
5882: BRN INDIR JUMP TO COMMON ROUTINE
5883: EJC
5884: *
5885: * KEYWORD REFERENCE (BY NAME)
5886: *
5887: O$KWN ENT ENTRY POINT
5888: JSR KWNAM GET KEYWORD NAME
5889: BRN EXNAM EXIT WITH RESULT NAME
5890: *
5891: * KEYWORD REFERENCE (BY VALUE)
5892: *
5893: O$KWV ENT ENTRY POINT
5894: JSR KWNAM GET KEYWORD NAME
5895: MOV XR,DNAMP DELETE KVBLK
5896: JSR ACESS ACCESS VALUE
5897: PPM EXNUL DUMMY (UNUSED) FAILURE RETURN
5898: BRN EXIXR JUMP WITH VALUE IN XR
5899: *
5900: * LOAD EXPRESSION BY NAME
5901: *
5902: O$LEX ENT ENTRY POINT
5903: MOV *EVSI$,WA SET SIZE OF EVBLK
5904: JSR ALLOC ALLOCATE SPACE FOR EVBLK
5905: MOV =B$EVT,(XR) SET TYPE WORD
5906: MOV =TRBEV,EVVAR(XR) SET DUMMY TRBLK POINTER
5907: LCW WA LOAD EXBLK POINTER
5908: MOV WA,EVEXP(XR) SET EXBLK POINTER
5909: MOV XR,XL MOVE NAME BASE TO PROPER REG
5910: MOV *EVVAR,WA SET NAME OFFSET = ZERO
5911: BRN EXNAM EXIT WITH NAME IN (XL,WA)
5912: *
5913: * LOAD PATTERN VALUE
5914: *
5915: O$LPT ENT ENTRY POINT
5916: LCW XR LOAD PATTERN POINTER
5917: BRN EXIXR STACK PTR AND OBEY NEXT CODE WORD
5918: EJC
5919: *
5920: * LOAD VARIABLE NAME
5921: *
5922: O$LVN ENT ENTRY POINT
5923: LCW WA LOAD VRBLK POINTER
5924: MOV WA,-(XS) STACK VRBLK PTR (NAME BASE)
5925: MOV *VRVAL,-(XS) STACK NAME OFFSET
5926: BRN EXITS EXIT WITH RESULT ON STACK
5927: *
5928: * BINARY ASTERISK (MULTIPLICATION)
5929: *
5930: O$MLT ENT ENTRY POINT
5931: JSR ARITH FETCH ARITHMETIC OPERANDS
5932: ERR 030,MULTIPLICATION LEFT OPERAND IS NOT NUMERIC
5933: ERR 031,MULTIPLICATION RIGHT OPERAND IS NOT NUMERIC
5934: .IF .CNRA
5935: .ELSE
5936: PPM OMLT1 JUMP IF REAL OPERANDS
5937: .FI
5938: *
5939: * HERE TO MULTIPLY TWO INTEGERS
5940: *
5941: MLI ICVAL(XL) MULTIPLY LEFT OPERAND BY RIGHT
5942: INO EXINT RETURN INTEGER IF NO OVERFLOW
5943: ERB 032,MULTIPLICATION CAUSED INTEGER OVERFLOW
5944: .IF .CNRA
5945: .ELSE
5946: *
5947: * HERE TO MULTIPLY TWO REALS
5948: *
5949: OMLT1 MLR RCVAL(XL) MULTIPLY LEFT OPERAND BY RIGHT
5950: RNO EXREA RETURN REAL IF NO OVERFLOW
5951: ERB 033,MULTIPLICATION CAUSED REAL OVERFLOW
5952: .FI
5953: *
5954: * NAME REFERENCE
5955: *
5956: O$NAM ENT ENTRY POINT
5957: MOV *NMSI$,WA SET LENGTH OF NMBLK
5958: JSR ALLOC ALLOCATE NMBLK
5959: MOV =B$NML,(XR) SET NAME BLOCK CODE
5960: MOV (XS)+,NMOFS(XR) SET NAME OFFSET FROM OPERAND
5961: MOV (XS)+,NMBAS(XR) SET NAME BASE FROM OPERAND
5962: BRN EXIXR EXIT WITH RESULT IN XR
5963: EJC
5964: *
5965: * NEGATION
5966: *
5967: * INITIAL ENTRY
5968: *
5969: O$NTA ENT ENTRY POINT
5970: LCW WA LOAD NEW FAILURE OFFSET
5971: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER
5972: MOV WA,-(XS) STACK NEW FAILURE OFFSET
5973: MOV XS,FLPTR SET NEW FAILURE POINTER
5974: BRN EXITS JUMP TO CONTINUE EXECUTION
5975: *
5976: * ENTRY AFTER SUCCESSFUL EVALUATION OF OPERAND
5977: *
5978: O$NTB ENT ENTRY POINT
5979: MOV 2(XS),FLPTR RESTORE OLD FAILURE POINTER
5980: BRN EXFAL AND FAIL
5981: *
5982: * ENTRY FOR FAILURE DURING OPERAND EVALUATION
5983: *
5984: O$NTC ENT ENTRY POINT
5985: ICA XS POP FAILURE OFFSET
5986: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER
5987: BRN EXNUL EXIT GIVING NULL RESULT
5988: *
5989: * USE OF UNDEFINED OPERATOR
5990: *
5991: O$OUN ENT ENTRY POINT
5992: ERB 034,UNDEFINED OPERATOR REFERENCED
5993: *
5994: * BINARY DOT (PATTERN ASSIGNMENT)
5995: *
5996: * THE PATTERN BUILT BY BINARY DOT IS A COMPOUND PATTERN.
5997: * SEE DESCRIPTION AT START OF PATTERN MATCH SECTION FOR
5998: * DETAILS OF THE STRUCTURE WHICH IS CONSTRUCTED.
5999: *
6000: O$PAS ENT ENTRY POINT
6001: MOV =P$PAC,WB LOAD PCODE FOR P$PAC NODE
6002: MOV (XS)+,WC LOAD NAME OFFSET (PARM2)
6003: MOV (XS)+,XR LOAD NAME BASE (PARM1)
6004: JSR PBILD BUILD P$PAC NODE
6005: MOV XR,XL SAVE PTR TO NODE
6006: MOV (XS),XR LOAD LEFT OPERAND
6007: JSR GTPAT CONVERT TO PATTERN
6008: ERR 035,PATTERN ASSIGNMENT LEFT OPERAND IS NOT PATTERN
6009: MOV XR,(XS) SAVE PTR TO LEFT OPERAND PATTERN
6010: MOV =P$PAA,WB SET PCODE FOR P$PAA NODE
6011: JSR PBILD BUILD P$PAA NODE
6012: MOV (XS)+,PTHEN(XR) SET LEFT OPERAND AS P$PAA SUCCESSOR
6013: JSR PCONC CONCATENATE TO FORM FINAL PATTERN
6014: BRN EXIXR JUMP FOR NEXT CODE WORD
6015: EJC
6016: *
6017: * PATTERN MATCH (BY NAME, FOR REPLACEMENT)
6018: *
6019: O$PMN ENT ENTRY POINT
6020: ZER WB SET TYPE CODE FOR MATCH BY NAME
6021: BRN MATCH JUMP TO ROUTINE TO START MATCH
6022: *
6023: * PATTERN MATCH (STATEMENT)
6024: *
6025: * O$PMS IS USED IN PLACE OF O$PMV WHEN THE PATTERN MATCH
6026: * OCCURS AT THE OUTER (STATEMENT) LEVEL SINCE IN THIS
6027: * CASE THE SUBSTRING VALUE NEED NOT BE CONSTRUCTED.
6028: *
6029: O$PMS ENT ENTRY POINT
6030: MOV =NUM02,WB SET FLAG FOR STATEMENT TO MATCH
6031: BRN MATCH JUMP TO ROUTINE TO START MATCH
6032: *
6033: * PATTERN MATCH (BY VALUE)
6034: *
6035: O$PMV ENT ENTRY POINT
6036: MOV =NUM01,WB SET TYPE CODE FOR VALUE MATCH
6037: BRN MATCH JUMP TO ROUTINE TO START MATCH
6038: *
6039: * POP TOP ITEM ON STACK
6040: *
6041: O$POP ENT ENTRY POINT
6042: ICA XS POP TOP STACK ENTRY
6043: BRN EXITS OBEY NEXT CODE WORD
6044: *
6045: * TERMINATE EXECUTION (CODE COMPILED FOR END STATEMENT)
6046: *
6047: O$STP ENT ENTRY POINT
6048: MOV =ENDMS,XR ENDING MESSAGE
6049: ZER WA NO ERROR CODE
6050: BRN STOPR STOP THE RUN
6051: *
6052: * RETURN NAME FROM EXPRESSION
6053: * THIS ENTRY POINTS IS USED IF THE EVALUATION OF AN
6054: * EXPRESSION, INITIATED BY THE EVALX PROCEDURE, RETURNS
6055: * A NAME. CONTROL IS RETURNED TO THE PROPER POINT IN EVALX.
6056: *
6057: O$RNM ENT ENTRY POINT
6058: JMG EVLXN RETURN TO EVALX PROCEDURE
6059: EJC
6060: *
6061: * PATTERN REPLACEMENT
6062: *
6063: * WHEN THIS ROUTINE GETS CONTROL, THE FOLLOWING STACK
6064: * ENTRIES HAVE BEEN MADE (SEE END OF MATCH ROUTINE P$NTH)
6065: *
6066: * SUBJECT NAME BASE
6067: * SUBJECT NAME OFFSET
6068: * INITIAL CURSOR VALUE
6069: * FINAL CURSOR VALUE
6070: * SUBJECT STRING POINTER
6071: * (XS) ---------------- REPLACEMENT VALUE
6072: *
6073: O$RPL ENT ENTRY POINT
6074: JSR GTSTG CONVERT REPLACEMENT VAL TO STRING
6075: ERR 036,PATTERN REPLACEMENT RIGHT OPERAND IS NOT STRING
6076: *
6077: * GET RESULT LENGTH AND ALLOCATE RESULT SCBLK
6078: *
6079: MOV (XS),XL LOAD SUBJECT STRING POINTER
6080: .IF .CNBF
6081: .ELSE
6082: BEQ (XL),=B$BCT,ORPL5 BRANCH IF BUFFER ASSIGNMENT
6083: .FI
6084: ADD SCLEN(XL),WA ADD SUBJECT STRING LENGTH
6085: ADD 2(XS),WA ADD STARTING CURSOR
6086: SUB 1(XS),WA MINUS FINAL CURSOR = TOTAL LENGTH
6087: BZE WA,ORPL3 JUMP IF RESULT IS NULL
6088: MOV XR,-(XS) RESTACK REPLACEMENT STRING
6089: JSR ALOCS ALLOCATE SCBLK FOR RESULT
6090: MOV 3(XS),WA GET INITIAL CURSOR (PART 1 LEN)
6091: MOV XR,3(XS) STACK RESULT POINTER
6092: PSC XR POINT TO CHARACTERS OF RESULT
6093: *
6094: * MOVE PART 1 (START OF SUBJECT) TO RESULT
6095: *
6096: BZE WA,ORPL1 JUMP IF FIRST PART IS NULL
6097: MOV 1(XS),XL ELSE POINT TO SUBJECT STRING
6098: PLC XL POINT TO SUBJECT STRING CHARS
6099: MVC MOVE FIRST PART TO RESULT
6100: EJC
6101: * PATTERN REPLACEMENT (CONTINUED)
6102: *
6103: * NOW MOVE IN REPLACEMENT VALUE
6104: *
6105: ORPL1 MOV (XS)+,XL LOAD REPLACEMENT STRING, POP
6106: MOV SCLEN(XL),WA LOAD LENGTH
6107: BZE WA,ORPL2 JUMP IF NULL REPLACEMENT
6108: PLC XL ELSE POINT TO CHARS OF REPLACEMENT
6109: MVC MOVE IN CHARS (PART 2)
6110: *
6111: * NOW MOVE IN REMAINDER OF STRING (PART 3)
6112: *
6113: ORPL2 MOV (XS)+,XL LOAD SUBJECT STRING POINTER, POP
6114: MOV (XS)+,WC LOAD FINAL CURSOR, POP
6115: MOV SCLEN(XL),WA LOAD SUBJECT STRING LENGTH
6116: SUB WC,WA MINUS FINAL CURSOR = PART 3 LENGTH
6117: BZE WA,ORPL4 JUMP TO ASSIGN IF PART 3 IS NULL
6118: PLC XL,WC ELSE POINT TO LAST PART OF STRING
6119: MVC MOVE PART 3 TO RESULT
6120: BRN ORPL4 JUMP TO PERFORM ASSIGNMENT
6121: *
6122: * HERE IF RESULT IS NULL
6123: *
6124: ORPL3 ADD *NUM02,XS POP SUBJECT STR PTR, FINAL CURSOR
6125: MOV =NULLS,(XS) SET NULL RESULT
6126: *
6127: * MERGE WITH ASSIGNMENT ROUTINE
6128: *
6129: ORPL4 MOV =O$ASS,XL CONTINUATION ROUTINE
6130: BRI XL ENTER ROUTINE
6131: .IF .CNBF
6132: .ELSE
6133: *
6134: * HERE FOR BUFFER SUBSTRING ASSIGNMENT
6135: *
6136: ORPL5 MOV XR,XL COPY SCBLK REPLACEMENT PTR
6137: MOV (XS)+,XR UNSTACK BCBLK PTR
6138: MOV (XS)+,WB GET FINAL CURSOR VALUE
6139: MOV (XS)+,WA GET INITIAL CURSOR
6140: SUB WA,WB GET LENGTH IN WB
6141: ADD *NUM02,XS GET RID OF NAME BASE/OFFSET
6142: JSR INSBF INSERT SUBSTRING
6143: PPM CONVERT FAIL IMPOSSIBLE
6144: PPM EXFAL FAIL IF INSERT FAILS
6145: BRN EXNUL ELSE NULL RESULT
6146: .FI
6147: EJC
6148: *
6149: * RETURN VALUE FROM EXPRESSION
6150: *
6151: * THIS ENTRY POINTS IS USED IF THE EVALUATION OF AN
6152: * EXPRESSION, INITIATED BY THE EVALX PROCEDURE, RETURNS
6153: * A VALUE. CONTROL IS RETURNED TO THE PROPER POINT IN EVALX
6154: *
6155: O$RVL ENT ENTRY POINT
6156: BRN EVLXV RETURN TO EVALX PROCEDURE
6157: EJC
6158: *
6159: * SELECTION
6160: *
6161: * INITIAL ENTRY
6162: *
6163: O$SLA ENT ENTRY POINT
6164: LCW WA LOAD NEW FAILURE OFFSET
6165: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER
6166: MOV WA,-(XS) STACK NEW FAILURE OFFSET
6167: MOV XS,FLPTR SET NEW FAILURE POINTER
6168: BRN EXITS JUMP TO EXECUTE FIRST ALTERNATIVE
6169: *
6170: * ENTRY AFTER SUCCESSFUL EVALUATION OF ALTERNATIVE
6171: *
6172: O$SLB ENT ENTRY POINT
6173: MOV (XS)+,XR LOAD RESULT
6174: ICA XS POP FAIL OFFSET
6175: MOV (XS),FLPTR RESTORE OLD FAILURE POINTER
6176: MOV XR,(XS) RESTACK RESULT
6177: LCW WA LOAD NEW CODE OFFSET
6178: ADD R$COD,WA POINT TO ABSOLUTE CODE LOCATION
6179: LCP WA SET NEW CODE POINTER
6180: BRN EXITS JUMP TO CONTINUE PAST SELECTION
6181: *
6182: * ENTRY AT START OF SUBSEQUENT ALTERNATIVES
6183: *
6184: O$SLC ENT ENTRY POINT
6185: LCW WA LOAD NEW FAIL OFFSET
6186: MOV WA,(XS) STORE NEW FAIL OFFSET
6187: BRN EXITS JUMP TO EXECUTE NEXT ALTERNATIVE
6188: *
6189: * ENTRY AT START OF LAST ALTERNATIVE
6190: *
6191: O$SLD ENT ENTRY POINT
6192: ICA XS POP FAILURE OFFSET
6193: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER
6194: BRN EXITS JUMP TO EXECUTE LAST ALTERNATIVE
6195: EJC
6196: *
6197: * BINARY MINUS (SUBTRACTION)
6198: *
6199: O$SUB ENT ENTRY POINT
6200: JSR ARITH FETCH ARITHMETIC OPERANDS
6201: ERR 037,SUBTRACTION LEFT OPERAND IS NOT NUMERIC
6202: ERR 038,SUBTRACTION RIGHT OPERAND IS NOT NUMERIC
6203: .IF .CNRA
6204: .ELSE
6205: PPM OSUB1 JUMP IF REAL OPERANDS
6206: .FI
6207: *
6208: * HERE TO SUBTRACT TWO INTEGERS
6209: *
6210: SBI ICVAL(XL) SUBTRACT RIGHT OPERAND FROM LEFT
6211: INO EXINT RETURN INTEGER IF NO OVERFLOW
6212: ERB 039,SUBTRACTION CAUSED INTEGER OVERFLOW
6213: .IF .CNRA
6214: .ELSE
6215: *
6216: * HERE TO SUBTRACT TWO REALS
6217: *
6218: OSUB1 SBR RCVAL(XL) SUBTRACT RIGHT OPERAND FROM LEFT
6219: RNO EXREA RETURN REAL IF NO OVERFLOW
6220: ERB 040,SUBTRACTION CAUSED REAL OVERFLOW
6221: .FI
6222: *
6223: * DUMMY OPERATOR TO RETURN CONTROL TO TRXEQ PROCEDURE
6224: *
6225: O$TXR ENT ENTRY POINT
6226: JMG TRXQR JUMP INTO TRXEQ PROCEDURE
6227: *
6228: * UNEXPECTED FAILURE
6229: *
6230: * NOTE THAT IF A SETEXIT TRAP IS OPERATING THEN
6231: * TRANSFER TO SYSTEM LABEL CONTINUE
6232: * WILL RESULT IN LOOPING HERE. DIFFICULT TO AVOID EXCEPT
6233: * WITH A CONSIDERABLE OVERHEAD WHICH IS NOT WORTHWHILE OR
6234: * ELSE BY A TECHNIQUE SUCH AS SETTING KVERL TO ZERO.
6235: *
6236: O$UNF ENT ENTRY POINT
6237: ERB 041,UNEXPECTED FAILURE IN -NOFAIL MODE
6238: TTL S P I T B O L -- SNOBOL4 BUILTIN LABEL ROUTINES
6239: *
6240: * THE FOLLOWING SECTION CONTAINS THE ROUTINES FOR LABELS
6241: * WHICH HAVE A PREDEFINED MEANING IN SNOBOL4.
6242: *
6243: * CONTROL IS PASSED DIRECTLY TO THE LABEL NAME ENTRY POINT.
6244: *
6245: * ENTRY NAMES ARE OF THE FORM L$XXX WHERE XXX IS THE THREE
6246: * LETTER VARIABLE NAME IDENTIFIER.
6247: *
6248: * ENTRIES ARE IN ALPHABETICAL ORDER
6249: *
6250: * ABORT
6251: *
6252: L$ABO ENT ENTRY POINT
6253: MOV KVERT,WA LOAD ERROR CODE
6254: ZER XR INDICATE NO ENDING MESSAGE
6255: BNZ WA,STOPR STOP RUN
6256: *
6257: *
6258: * FAIL IF NO ERROR HAD OCCURED
6259: *
6260: ERB 042,GOTO ABORT WITH NO PRECEDING ERROR
6261: *
6262: * CONTINUE
6263: *
6264: L$CNT ENT ENTRY POINT
6265: *
6266: * MERGE HERE AFTER EXECUTION ERROR
6267: *
6268: LCNXE MOV R$CNT,XR LOAD CONTINUATION CODE BLOCK PTR
6269: BZE XR,LCNT1 JUMP IF NO PREVIOUS ERROR
6270: ZER R$CNT CLEAR FLAG
6271: MOV XR,R$COD ELSE STORE AS NEW CODE BLOCK PTR
6272: ADD STXOF,XR ADD FAILURE OFFSET
6273: LCP XR LOAD CODE POINTER
6274: MOV FLPTR,XS RESET STACK POINTER
6275: BRN EXITS JUMP TO TAKE INDICATED FAILURE
6276: *
6277: * HERE IF NO PREVIOUS ERROR
6278: *
6279: LCNT1 ERB 043,GOTO CONTINUE WITH NO PRECEDING ERROR
6280: EJC
6281: *
6282: * END
6283: *
6284: L$END ENT ENTRY POINT
6285: MOV =ENDMS,XR POINT TO MESSAGE /NORMAL TERM../
6286: ZER WA NO ERROR CODE
6287: BRN STOPR JUMP TO ROUTINE TO STOP RUN
6288: *
6289: * FRETURN
6290: *
6291: L$FRT ENT ENTRY POINT
6292: MOV =SCFRT,WA POINT TO STRING /FRETURN/
6293: BRN RETRN JUMP TO COMMON RETURN ROUTINE
6294: *
6295: * NRETURN
6296: *
6297: L$NRT ENT ENTRY POINT
6298: MOV =SCNRT,WA POINT TO STRING /NRETURN/
6299: BRN RETRN JUMP TO COMMON RETURN ROUTINE
6300: *
6301: * RETURN
6302: *
6303: L$RTN ENT ENTRY POINT
6304: MOV =SCRTN,WA POINT TO STRING /RETURN/
6305: BRN RETRN JUMP TO COMMON RETURN ROUTINE
6306: *
6307: * UNDEFINED LABEL
6308: *
6309: L$UND ENT ENTRY POINT
6310: ERB 044,GOTO UNDEFINED LABEL
6311: TTL S P I T B O L -- BLOCK ACTION ROUTINES
6312: *
6313: * THE FIRST WORD OF EVERY BLOCK IN DYNAMIC STORAGE AND THE
6314: * VRGET, VRSTO AND VRTRA FIELDS OF A VRBLK CONTAIN A
6315: * POINTER TO AN ENTRY POINT IN THE PROGRAM. ALL SUCH ENTRY
6316: * POINTS ARE IN THE FOLLOWING SECTION EXCEPT THOSE FOR
6317: * PATTERN BLOCKS WHICH ARE IN THE PATTERN MATCHING SEGMENT
6318: * LATER ON (LABELS OF THE FORM P$XXX), AND DOPE VECTORS
6319: * (D$XXX) WHICH ARE IN THE DOPE VECTOR SECTION FOLLOWING
6320: * THE PATTERN ROUTINES (DOPE VECTORS ARE USED FOR CMBLKS).
6321: *
6322: * THE ENTRY POINTS IN THIS SECTION HAVE LABELS OF THE
6323: * FORM B$XXY WHERE XX IS THE TWO CHARACTER BLOCK TYPE FOR
6324: * THE CORRESPONDING BLOCK AND Y IS ANY LETTER.
6325: *
6326: * IN SOME CASES, THE POINTERS SERVE NO OTHER PURPOSE THAN
6327: * TO IDENTIFY THE BLOCK TYPE. IN THIS CASE THE ROUTINE
6328: * IS NEVER EXECUTED AND THUS NO CODE IS ASSEMBLED.
6329: *
6330: * FOR EACH OF THESE ENTRY POINTS CORRESPONDING TO A BLOCK
6331: * AN ENTRY POINT IDENTIFICATION IS ASSEMBLED (BL$XX).
6332: *
6333: * THE EXACT ENTRY CONDITIONS DEPEND ON THE MANNER IN
6334: * WHICH THE ROUTINE IS ACCESSED AND ARE DOCUMENTED WITH
6335: * THE INDIVIDUAL ROUTINES AS REQUIRED.
6336: *
6337: * THE ORDER OF THESE ROUTINES IS ALPHABETICAL WITH THE
6338: * FOLLOWING EXCEPTIONS.
6339: *
6340: * THE ROUTINES FOR SEBLK AND EXBLK ENTRIES OCCUR FIRST SO
6341: * THAT EXPRESSIONS CAN BE QUICKLY IDENTIFIED FROM THE FACT
6342: * THAT THEIR ROUTINES LIE BEFORE THE SYMBOL B$E$$.
6343: *
6344: * THESE ARE IMMEDIATELY FOLLOWED BY THE ROUTINE FOR A TRBLK
6345: * SO THAT THE TEST AGAINST THE SYMBOL B$T$$ CHECKS FOR
6346: * TRAPPED VALUES OR EXPRESSION VALUES (SEE PROCEDURE EVALP)
6347: *
6348: * THE PATTERN ROUTINES LIE AFTER THIS SECTION SO THAT
6349: * PATTERNS ARE IDENTIFIED WITH ROUTINES STARTING AT OR
6350: * AFTER THE INITIAL INSTRUCTION IN THESE ROUTINES (P$AAA).
6351: *
6352: * THE SYMBOL B$AAA DEFINES THE FIRST LOCATION FOR BLOCK
6353: * ROUTINES AND THE SYMBOL P$YYY (AT THE END OF THE PATTERN
6354: * MATCH ROUTINES SECTION) DEFINES THE LAST SUCH ENTRY POINT
6355: *
6356: B$AAA ENT BL$$I ENTRY POINT OF FIRST BLOCK ROUTINE
6357: EJC
6358: *
6359: * EXBLK
6360: *
6361: * THE ROUTINE FOR AN EXBLK LOADS THE EXPRESSION ONTO
6362: * THE STACK AS A VALUE.
6363: *
6364: * (XR) POINTER TO EXBLK
6365: *
6366: B$EXL ENT BL$EX ENTRY POINT (EXBLK)
6367: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
6368: *
6369: * SEBLK
6370: *
6371: * THE ROUTINE FOR SEBLK IS ACCESSED FROM THE GENERATED
6372: * CODE TO LOAD THE EXPRESSION VALUE ONTO THE STACK.
6373: *
6374: B$SEL ENT BL$SE ENTRY POINT (SEBLK)
6375: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
6376: *
6377: * DEFINE SYMBOL WHICH MARKS END OF ENTRIES FOR EXPRESSIONS
6378: *
6379: B$E$$ ENT BL$$I ENTRY POINT
6380: *
6381: * TRBLK
6382: *
6383: * THE ROUTINE FOR A TRBLK IS NEVER EXECUTED
6384: *
6385: B$TRT ENT BL$TR ENTRY POINT (TRBLK)
6386: *
6387: * DEFINE SYMBOL MARKING END OF TRAP AND EXPRESSION BLOCKS
6388: *
6389: B$T$$ ENT BL$$I END OF TRBLK,SEBLK,EXBLK ENTRIES
6390: *
6391: * ARBLK
6392: *
6393: * THE ROUTINE FOR ARBLK IS NEVER EXECUTED
6394: *
6395: B$ART ENT BL$AR ENTRY POINT (ARBLK)
6396: EJC
6397: .IF .CNBF
6398: .ELSE
6399: *
6400: * BCBLK
6401: *
6402: * THE ROUTINE FOR A BCBLK IS NEVER EXECUTED
6403: *
6404: * (XR) POINTER TO BCBLK
6405: *
6406: B$BCT ENT BL$BC ENTRY POINT (BCBLK)
6407: *
6408: * BFBLK
6409: *
6410: * THE ROUTINE FOR A BFBLK IS NEVER EXECUTED
6411: *
6412: * (XR) POINTER TO BFBLK
6413: *
6414: B$BFT ENT BL$BF ENTRY POINT (BFBLK)
6415: EJC
6416: .FI
6417: *
6418: * CCBLK
6419: *
6420: * THE ROUTINE FOR CCBLK IS NEVER ENTERED
6421: *
6422: B$CCT ENT BL$CC ENTRY POINT (CCBLK)
6423: *
6424: * CDBLK
6425: *
6426: * THE CDBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE.
6427: * THERE ARE TWO CASES DEPENDING ON THE FORM OF CDFAL.
6428: *
6429: * ENTRY FOR COMPLEX FAILURE CODE AT CDFAL
6430: *
6431: * (XR) POINTER TO CDBLK
6432: *
6433: B$CDC ENT BL$CD ENTRY POINT (CDBLK)
6434: MOV FLPTR,XS POP GARBAGE OFF STACK
6435: MOV CDFAL(XR),(XS) SET FAILURE OFFSET
6436: BRN STMGO ENTER STMT
6437: *
6438: * ENTRY FOR SIMPLE FAILURE CODE AT CDFAL
6439: *
6440: * (XR) POINTER TO CDBLK
6441: *
6442: B$CDS ENT BL$CD ENTRY POINT (CDBLK)
6443: MOV FLPTR,XS POP GARBAGE OFF STACK
6444: MOV *CDFAL,(XS) SET FAILURE OFFSET
6445: BRN STMGO ENTER STMT
6446: *
6447: * CMBLK
6448: *
6449: * THE ROUTINE FOR A CMBLK IS NEVER EXECUTED
6450: *
6451: B$CMT ENT BL$CM ENTRY POINT (CMBLK)
6452: *
6453: * COBLK
6454: *
6455: * THE ROUTINE FOR A COBLK IS NEVER EXECUTED
6456: *
6457: B$COP ENT BL$CO ENTRY POINT (COBLK)
6458: *
6459: * CTBLK
6460: *
6461: * THE ROUTINE FOR A CTBLK IS NEVER EXECUTED
6462: *
6463: B$CTT ENT BL$CT ENTRY POINT (CTBLK)
6464: EJC
6465: *
6466: * DFBLK
6467: *
6468: * THE ROUTINE FOR A DFBLK IS ACCESSED FROM THE O$FNC ENTRY
6469: * TO CALL A DATATYPE FUNCTION AND BUILD A PDBLK.
6470: *
6471: * (XL) POINTER TO DFBLK
6472: *
6473: B$DFC ENT BL$DF ENTRY POINT
6474: MOV DFPDL(XL),WA LOAD LENGTH OF PDBLK
6475: JSR ALLOC ALLOCATE PDBLK
6476: MOV =B$PDT,(XR) STORE TYPE WORD
6477: MOV XL,PDDFP(XR) STORE DFBLK POINTER
6478: MOV XR,WC SAVE POINTER TO PDBLK
6479: ADD WA,XR POINT PAST PDBLK
6480: LCT WA,FARGS(XL) SET TO COUNT FIELDS
6481: *
6482: * LOOP TO ACQUIRE FIELD VALUES FROM STACK
6483: *
6484: BDFC1 MOV (XS)+,-(XR) MOVE A FIELD VALUE
6485: BCT WA,BDFC1 LOOP TILL ALL MOVED
6486: MOV WC,XR RECALL POINTER TO PDBLK
6487: BRN EXSID EXIT SETTING ID FIELD
6488: .IF .CNLD
6489: .ELSE
6490: EJC
6491: *
6492: * EFBLK
6493: *
6494: * THE ROUTINE FOR AN EFBLK IS PASSED CONTROL FORM THE O$FNC
6495: * ENTRY TO CALL AN EXTERNAL FUNCTION.
6496: *
6497: * (XL) POINTER TO EFBLK
6498: *
6499: B$EFC ENT BL$EF ENTRY POINT (EFBLK)
6500: MOV FARGS(XL),WC LOAD NUMBER OF ARGUMENTS
6501: WTB WC CONVERT TO OFFSET
6502: MOV XL,-(XS) SAVE POINTER TO EFBLK
6503: MOV XS,XT COPY POINTER TO ARGUMENTS
6504: *
6505: * LOOP TO CONVERT ARGUMENTS
6506: *
6507: BEFC1 ICA XT POINT TO NEXT ENTRY
6508: MOV (XS),XR LOAD POINTER TO EFBLK
6509: DCA WC DECREMENT EFTAR OFFSET
6510: ADD WC,XR POINT TO NEXT EFTAR ENTRY
6511: MOV EFTAR(XR),XR LOAD EFTAR ENTRY
6512: BSW XR,5,BEFC7 SWITCH ON EFTAR TYPE
6513: IFF 1,BEFC2 STRING
6514: IFF 2,BEFC3 INTEGER
6515: .IF .CNRA
6516: .ELSE
6517: IFF 3,BEFC4 REAL
6518: .FI
6519: .IF .CNBF
6520: .ELSE
6521: IFF 4,BEFCA BUFFER
6522: .FI
6523: ESW END OF SWITCH ON TYPE
6524: *
6525: * HERE TO CONVERT TO STRING
6526: *
6527: BEFC2 MOV (XT),-(XS) STACK ARG PTR
6528: JSR GTSTG CONVERT ARGUMENT TO STRING
6529: ERR 045,EXTERNAL FUNCTION ARGUMENT IS NOT STRING
6530: BRN BEFC6 JUMP TO MERGE
6531: EJC
6532: *
6533: * EFBLK (CONTINUED)
6534: *
6535: * HERE TO CONVERT AN INTEGER
6536: *
6537: BEFC3 MOV (XT),XR LOAD NEXT ARGUMENT
6538: MOV WC,BEFOF SAVE OFFSET
6539: JSR GTINT CONVERT TO INTEGER
6540: ERR 046,EXTERNAL FUNCTION ARGUMENT IS NOT INTEGER
6541: .IF .CNRA
6542: .ELSE
6543: BRN BEFC5 MERGE WITH REAL CASE
6544: *
6545: * HERE TO CONVERT A REAL
6546: *
6547: BEFC4 MOV (XT),XR LOAD NEXT ARGUMENT
6548: MOV WC,BEFOF SAVE OFFSET
6549: JSR GTREA CONVERT TO REAL
6550: ERR 047,EXTERNAL FUNCTION ARGUMENT IS NOT REAL
6551: *
6552: * INTEGER CASE MERGES HERE
6553: *
6554: .FI
6555: .IF .CNBF
6556: .ELSE
6557: BRN BEFC5 MERGE
6558: *
6559: * HERE TO CONVERT BUFFER
6560: *
6561: BEFCA MOV (XT),XR LOAD ARGUMENT
6562: MOV WC,BEFOF SAVE OFFSET
6563: MOV XL,-(XS) SAVE EFBLK PTR
6564: JSR GTBUF GET A BUFFER
6565: ERR 259,EXTERNAL FUNCTION ARGUMENT IS NOT BUFFER
6566: MOV (XS)+,XL RESTORE EFBLK PTR
6567: *
6568: * INTEGER AND REAL CASE MERGES HERE
6569: *
6570: .FI
6571: BEFC5 MOV BEFOF,WC RESTORE OFFSET
6572: *
6573: * STRING MERGES HERE
6574: *
6575: BEFC6 MOV XR,(XT) STORE CONVERTED RESULT
6576: *
6577: * NO CONVERSION MERGES HERE
6578: *
6579: BEFC7 BNZ WC,BEFC1 LOOP BACK IF MORE TO GO
6580: *
6581: * HERE AFTER CONVERTING ALL THE ARGUMENTS
6582: *
6583: MOV (XS)+,XL RESTORE EFBLK POINTER
6584: MOV FARGS(XL),WA GET NUMBER OF ARGS
6585: JSR SYSEX CALL ROUTINE TO CALL EXTERNAL FNC
6586: PPM EXFAL FAIL IF FAILURE
6587: EJC
6588: *
6589: * EFBLK (CONTINUED)
6590: *
6591: * RETURN HERE WITH RESULT IN XR
6592: *
6593: * FIRST DEFEND AGAINST NON-STANDARD NULL STRING RETURNED
6594: *
6595: MOV EFRSL(XL),WB GET RESULT TYPE
6596: BNZ WB,BEFA8 BRANCH IF NOT UNCONVERTED
6597: BNE (XR),=B$SCL,BEFC8 JUMP IF NOT A STRING
6598: BZE SCLEN(XR),EXNUL RETURN NULL IF NULL
6599: *
6600: * HERE IF CONVERTED RESULT TO CHECK FOR NULL STRING
6601: *
6602: BEFA8 BNE WB,=NUM01,BEFC8 JUMP IF NOT A STRING
6603: BZE SCLEN(XR),EXNUL RETURN NULL IF NULL
6604: *
6605: * RETURN IF RESULT IS IN DYNAMIC STORAGE
6606: *
6607: BEFC8 BLT XR,DNAMB,BEFC9 JUMP IF NOT IN DYNAMIC STORAGE
6608: BLE XR,DNAMP,EXIXR RETURN RESULT IF ALREADY DYNAMIC
6609: *
6610: * HERE WE COPY A RESULT INTO THE DYNAMIC REGION
6611: *
6612: BEFC9 MOV (XR),WA GET POSSIBLE TYPE WORD
6613: BZE WB,BEF11 JUMP IF UNCONVERTED RESULT
6614: MOV =B$SCL,WA STRING
6615: BEQ WB,=NUM01,BEF10 YES JUMP
6616: MOV =B$ICL,WA INTEGER
6617: BEQ WB,=NUM02,BEF10 YES JUMP
6618: .IF .CNRA
6619: .ELSE
6620: MOV =B$RCL,WA REAL
6621: BEQ WB,=NUM03,BEF10 YES JUMP
6622: .FI
6623: .IF .CNBF
6624: .ELSE
6625: MOV =B$BCT,WA BUFFER
6626: BEQ WB,=NUM04,BEF10 YES JUMP
6627: .FI
6628: *
6629: * STORE TYPE WORD IN RESULT
6630: *
6631: BEF10 MOV WA,(XR) STORED BEFORE COPYING TO DYNAMIC
6632: *
6633: * MERGE FOR UNCONVERTED RESULT
6634: *
6635: BEF11 JSR BLKLN GET LENGTH OF BLOCK
6636: MOV XR,XL COPY ADDRESS OF OLD BLOCK
6637: JSR ALLOC ALLOCATE DYNAMIC BLOCK SAME SIZE
6638: MOV XR,-(XS) SET POINTER TO NEW BLOCK AS RESULT
6639: MVW COPY OLD BLOCK TO DYNAMIC BLOCK
6640: BRN EXITS EXIT WITH RESULT ON STACK
6641: .FI
6642: *
6643: * EVBLK
6644: *
6645: * THE ROUTINE FOR AN EVBLK IS NEVER EXECUTED
6646: *
6647: B$EVT ENT BL$EV ENTRY POINT (EVBLK)
6648: EJC
6649: *
6650: * FFBLK
6651: *
6652: * THE ROUTINE FOR AN FFBLK IS EXECUTED FROM THE O$FNC ENTRY
6653: * TO CALL A FIELD FUNCTION AND EXTRACT A FIELD VALUE/NAME.
6654: *
6655: * (XL) POINTER TO FFBLK
6656: *
6657: B$FFC ENT BL$FF ENTRY POINT (FFBLK)
6658: MOV XL,XR COPY FFBLK POINTER
6659: LCW WC LOAD NEXT CODE WORD
6660: MOV (XS),XL LOAD PDBLK POINTER
6661: BNE (XL),=B$PDT,BFFC2 JUMP IF NOT PDBLK AT ALL
6662: MOV PDDFP(XL),WA LOAD DFBLK POINTER FROM PDBLK
6663: *
6664: * LOOP TO FIND CORRECT FFBLK FOR THIS PDBLK
6665: *
6666: BFFC1 BEQ WA,FFDFP(XR),BFFC3 JUMP IF THIS IS THE CORRECT FFBLK
6667: MOV FFNXT(XR),XR ELSE LINK TO NEXT FFBLK ON CHAIN
6668: BNZ XR,BFFC1 LOOP BACK IF ANOTHER ENTRY TO CHECK
6669: *
6670: * HERE FOR BAD ARGUMENT
6671: *
6672: BFFC2 ERB 048,FIELD FUNCTION ARGUMENT IS WRONG DATATYPE
6673: *
6674: * HERE AFTER LOCATING CORRECT FFBLK
6675: *
6676: BFFC3 MOV FFOFS(XR),WA LOAD FIELD OFFSET
6677: BEQ WC,=OFNE$,BFFC5 JUMP IF CALLED BY NAME
6678: ADD WA,XL ELSE POINT TO VALUE FIELD
6679: MOV (XL),XR LOAD VALUE
6680: BNE (XR),=B$TRT,BFFC4 JUMP IF NOT TRAPPED
6681: SUB WA,XL ELSE RESTORE NAME BASE,OFFSET
6682: MOV WC,(XS) SAVE NEXT CODE WORD OVER PDBLK PTR
6683: JSR ACESS ACCESS VALUE
6684: PPM EXFAL FAIL IF ACCESS FAILS
6685: MOV (XS),WC RESTORE NEXT CODE WORD
6686: *
6687: * HERE AFTER GETTING VALUE IN (XR)
6688: *
6689: BFFC4 MOV XR,(XS) STORE VALUE ON STACK (OVER PDBLK)
6690: MOV WC,XR COPY NEXT CODE WORD
6691: MOV (XR),XL LOAD ENTRY ADDRESS
6692: BRI XL JUMP TO ROUTINE FOR NEXT CODE WORD
6693: *
6694: * HERE IF CALLED BY NAME
6695: *
6696: BFFC5 MOV WA,-(XS) STORE NAME OFFSET (BASE IS SET)
6697: BRN EXITS EXIT WITH NAME ON STACK
6698: EJC
6699: *
6700: * ICBLK
6701: *
6702: * THE ROUTINE FOR ICBLK IS EXECUTED FROM THE GENERATED
6703: * CODE TO LOAD AN INTEGER VALUE ONTO THE STACK.
6704: *
6705: * (XR) POINTER TO ICBLK
6706: *
6707: B$ICL ENT BL$IC ENTRY POINT (ICBLK)
6708: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
6709: *
6710: * KVBLK
6711: *
6712: * THE ROUTINE FOR A KVBLK IS NEVER EXECUTED.
6713: *
6714: B$KVT ENT BL$KV ENTRY POINT (KVBLK)
6715: *
6716: * NMBLK
6717: *
6718: * THE ROUTINE FOR A NMBLK IS EXECUTED FROM THE GENERATED
6719: * CODE FOR THE CASE OF LOADING A NAME ONTO THE STACK
6720: * WHERE THE NAME IS THAT OF A NATURAL VARIABLE WHICH CAN
6721: * BE PREEVALUATED AT COMPILE TIME.
6722: *
6723: * (XR) POINTER TO NMBLK
6724: *
6725: B$NML ENT BL$NM ENTRY POINT (NMBLK)
6726: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
6727: *
6728: * PDBLK
6729: *
6730: * THE ROUTINE FOR A PDBLK IS NEVER EXECUTED
6731: *
6732: B$PDT ENT BL$PD ENTRY POINT (PDBLK)
6733: EJC
6734: *
6735: * PFBLK
6736: *
6737: * THE ROUTINE FOR A PFBLK IS EXECUTED FROM THE ENTRY O$FNC
6738: * TO CALL A PROGRAM DEFINED FUNCTION.
6739: *
6740: * (XL) POINTER TO PFBLK
6741: *
6742: * THE FOLLOWING STACK ENTRIES ARE MADE BEFORE PASSING
6743: * CONTROL TO THE PROGRAM DEFINED FUNCTION.
6744: *
6745: * SAVED VALUE OF FIRST ARGUMENT
6746: * .
6747: * SAVED VALUE OF LAST ARGUMENT
6748: * SAVED VALUE OF FIRST LOCAL
6749: * .
6750: * SAVED VALUE OF LAST LOCAL
6751: * SAVED VALUE OF FUNCTION NAME
6752: * SAVED CODE BLOCK PTR (R$COD)
6753: * SAVED CODE POINTER (-R$COD)
6754: * SAVED VALUE OF FLPRT
6755: * SAVED VALUE OF FLPTR
6756: * POINTER TO PFBLK
6757: * FLPTR --------------- ZERO (TO BE OVERWRITTEN WITH OFFS)
6758: *
6759: B$PFC ENT BL$PF ENTRY POINT (PFBLK)
6760: MOV XL,BPFPF SAVE PFBLK PTR (NEED NOT BE RELOC)
6761: MOV XL,XR COPY FOR THE MOMENT
6762: MOV PFVBL(XR),XL POINT TO VRBLK FOR FUNCTION
6763: *
6764: * LOOP TO FIND OLD VALUE OF FUNCTION
6765: *
6766: BPF01 MOV XL,WB SAVE POINTER
6767: MOV VRVAL(XL),XL LOAD VALUE
6768: BEQ (XL),=B$TRT,BPF01 LOOP IF TRBLK
6769: *
6770: * SET VALUE TO NULL AND SAVE OLD FUNCTION VALUE
6771: *
6772: MOV XL,BPFSV SAVE OLD VALUE
6773: MOV WB,XL POINT BACK TO BLOCK WITH VALUE
6774: MOV =NULLS,VRVAL(XL) SET VALUE TO NULL
6775: MOV FARGS(XR),WA LOAD NUMBER OF ARGUMENTS
6776: ADD *PFARG,XR POINT TO PFARG ENTRIES
6777: BZE WA,BPF04 JUMP IF NO ARGUMENTS
6778: MOV XS,XT PTR TO LAST ARG
6779: WTB WA CONVERT NO. OF ARGS TO BAUS OFFSET
6780: ADD WA,XT POINT BEFORE FIRST ARG
6781: MOV XT,BPFXT REMEMBER ARG POINTER
6782: EJC
6783: *
6784: * PFBLK (CONTINUED)
6785: *
6786: * LOOP TO SAVE OLD ARGUMENT VALUES AND SET NEW ONES
6787: *
6788: BPF02 MOV (XR)+,XL LOAD VRBLK PTR FOR NEXT ARGUMENT
6789: *
6790: * LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE
6791: *
6792: BPF03 MOV XL,WC SAVE POINTER
6793: MOV VRVAL(XL),XL LOAD NEXT VALUE
6794: BEQ (XL),=B$TRT,BPF03 LOOP BACK IF TRBLK
6795: *
6796: * SAVE OLD VALUE AND GET NEW VALUE
6797: *
6798: MOV XL,WA KEEP OLD VALUE
6799: MOV BPFXT,XT POINT BEFORE NEXT STACKED ARG
6800: MOV -(XT),WB LOAD ARGUMENT (NEW VALUE)
6801: MOV WA,(XT) SAVE OLD VALUE
6802: MOV XT,BPFXT KEEP ARG PTR FOR NEXT TIME
6803: MOV WC,XL POINT BACK TO BLOCK WITH VALUE
6804: MOV WB,VRVAL(XL) SET NEW VALUE
6805: BNE XS,BPFXT,BPF02 LOOP IF NOT ALL DONE
6806: *
6807: * NOW PROCESS LOCALS
6808: *
6809: BPF04 MOV BPFPF,XL RESTORE PFBLK POINTER
6810: MOV PFNLO(XL),WA LOAD NUMBER OF LOCALS
6811: BZE WA,BPF07 JUMP IF NO LOCALS
6812: MOV =NULLS,WB GET NULL CONSTANT
6813: LCT WA,WA SET LOCAL COUNTER
6814: *
6815: * LOOP TO PROCESS LOCALS
6816: *
6817: BPF05 MOV (XR)+,XL LOAD VRBLK PTR FOR NEXT LOCAL
6818: *
6819: * LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE
6820: *
6821: BPF06 MOV XL,WC SAVE POINTER
6822: MOV VRVAL(XL),XL LOAD NEXT VALUE
6823: BEQ (XL),=B$TRT,BPF06 LOOP BACK IF TRBLK
6824: *
6825: * SAVE OLD VALUE AND SET NULL AS NEW VALUE
6826: *
6827: MOV XL,-(XS) STACK OLD VALUE
6828: MOV WC,XL POINT BACK TO BLOCK WITH VALUE
6829: MOV WB,VRVAL(XL) SET NULL AS NEW VALUE
6830: BCT WA,BPF05 LOOP TILL ALL LOCALS PROCESSED
6831: EJC
6832: *
6833: * PFBLK (CONTINUED)
6834: *
6835: * HERE AFTER PROCESSING ARGUMENTS AND LOCALS
6836: *
6837: .IF .CNPF
6838: BPF07 MOV R$COD,WA LOAD OLD CODE BLOCK POINTER
6839: .ELSE
6840: BPF07 ZER XR ZERO REG XR IN CASE
6841: BZE KVPFL,BPF7C SKIP IF PROFILING IS OFF
6842: BEQ KVPFL,=NUM02,BPF7A BRANCH ON TYPE OF PROFILE
6843: *
6844: * HERE IF PROFILE = 1
6845: *
6846: JSR SYSTM GET CURRENT TIME
6847: STI PFETM SAVE FOR A SEC
6848: SBI PFSTM FIND TIME USED BY CALLER
6849: JSR ICBLD BUILD INTO AN ICBLK
6850: LDI PFETM RELOAD CURRENT TIME
6851: BRN BPF7B MERGE
6852: *
6853: * HERE IF PROFILE = 2
6854: *
6855: BPF7A LDI PFSTM GET START TIME OF CALLING STMT
6856: JSR ICBLD ASSEMBLE AN ICBLK ROUND IT
6857: JSR SYSTM GET NOW TIME
6858: *
6859: * BOTH TYPES OF PROFILE MERGE HERE
6860: *
6861: BPF7B STI PFSTM SET START TIME OF 1ST FUNC STMT
6862: MNZ PFFNC FLAG FUNCTION ENTRY
6863: EJC
6864: *
6865: * PFBLK (CONTINUED)
6866: *
6867: * NO PROFILING MERGES HERE
6868: *
6869: BPF7C MOV XR,-(XS) STACK ICBLK PTR (OR ZERO)
6870: MOV R$COD,WA LOAD OLD CODE BLOCK POINTER
6871: .FI
6872: SCP WB GET CODE POINTER
6873: SUB WA,WB MAKE CODE POINTER INTO OFFSET
6874: MOV BPFPF,XL RECALL PFBLK POINTER
6875: MOV BPFSV,-(XS) STACK OLD VALUE OF FUNCTION NAME
6876: MOV WA,-(XS) STACK CODE BLOCK POINTER
6877: MOV WB,-(XS) STACK CODE OFFSET
6878: MOV FLPRT,-(XS) STACK OLD FLPRT
6879: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER
6880: MOV XL,-(XS) STACK POINTER TO PFBLK
6881: ZER -(XS) DUMMY ZERO ENTRY FOR FAIL RETURN
6882: CHK CHECK FOR STACK OVERFLOW
6883: MOV XS,FLPTR SET NEW FAIL RETURN VALUE
6884: MOV XS,FLPRT SET NEW FLPRT
6885: MOV KVTRA,WA LOAD TRACE VALUE
6886: ADD KVFTR,WA ADD FTRACE VALUE
6887: BNZ WA,BPF09 JUMP IF TRACING POSSIBLE
6888: ICV KVFNC ELSE BUMP FNCLEVEL
6889: *
6890: * HERE TO ACTUALLY JUMP TO FUNCTION
6891: *
6892: BPF08 MOV PFCOD(XL),XR POINT TO CODE
6893: BRI (XR) OFF TO EXECUTE FUNCTION
6894: *
6895: * HERE IF TRACING IS POSSIBLE
6896: *
6897: BPF09 MOV PFCTR(XL),XR LOAD POSSIBLE CALL TRACE TRBLK
6898: MOV PFVBL(XL),XL LOAD VRBLK POINTER FOR FUNCTION
6899: MOV *VRVAL,WA SET NAME OFFSET FOR VARIABLE
6900: BZE KVTRA,BPF10 JUMP IF TRACE MODE IS OFF
6901: BZE XR,BPF10 OR IF THERE IS NO CALL TRACE
6902: *
6903: * HERE IF CALL TRACED
6904: *
6905: DCV KVTRA DECREMENT TRACE COUNT
6906: BZE TRFNC(XR),BPF11 JUMP IF PRINT TRACE
6907: JSR TRXEQ EXECUTE FUNCTION TYPE TRACE
6908: EJC
6909: *
6910: * PFBLK (CONTINUED)
6911: *
6912: * HERE TO TEST FOR FTRACE TRACE
6913: *
6914: BPF10 BZE KVFTR,BPF16 JUMP IF FTRACE IS OFF
6915: DCV KVFTR ELSE DECREMENT FTRACE
6916: *
6917: * HERE FOR PRINT TRACE
6918: *
6919: BPF11 JSR PRTSN PRINT STATEMENT NUMBER
6920: JSR PRTNM PRINT FUNCTION NAME
6921: MOV =CH$PP,WA LOAD LEFT PAREN
6922: JSR PRTCH PRINT LEFT PAREN
6923: MOV 1(XS),XL RECOVER PFBLK POINTER
6924: BZE FARGS(XL),BPF15 SKIP IF NO ARGUMENTS
6925: ZER WB ELSE SET ARGUMENT COUNTER
6926: BRN BPF13 JUMP INTO LOOP
6927: *
6928: * LOOP TO PRINT ARGUMENT VALUES
6929: *
6930: BPF12 MOV =CH$CM,WA LOAD COMMA
6931: JSR PRTCH PRINT TO SEPARATE FROM LAST ARG
6932: *
6933: * MERGE HERE FIRST TIME (NO COMMA REQUIRED)
6934: *
6935: BPF13 MOV WB,(XS) SAVE ARG CTR (OVER FAILOFFS IS OK)
6936: WTB WB CONVERT TO BAU OFFSET
6937: ADD WB,XL POINT TO NEXT ARGUMENT POINTER
6938: MOV PFARG(XL),XR LOAD NEXT ARGUMENT VRBLK PTR
6939: SUB WB,XL RESTORE PFBLK POINTER
6940: MOV VRVAL(XR),XR LOAD NEXT VALUE
6941: JSR PRTVL PRINT ARGUMENT VALUE
6942: EJC
6943: *
6944: * HERE AFTER DEALING WITH ONE ARGUMENT
6945: *
6946: MOV (XS),WB RESTORE ARGUMENT COUNTER
6947: ICV WB INCREMENT ARGUMENT COUNTER
6948: BLT WB,FARGS(XL),BPF12 LOOP IF MORE TO PRINT
6949: *
6950: * MERGE HERE IN NO ARGS CASE TO PRINT PAREN
6951: *
6952: BPF15 MOV =CH$RP,WA LOAD RIGHT PAREN
6953: JSR PRTCF PRINT TO TERMINATE OUTPUT
6954: *
6955: * MERGE HERE TO EXIT WITH TEST FOR FNCLEVEL TRACE
6956: *
6957: BPF16 ICV KVFNC INCREMENT FNCLEVEL
6958: MOV R$FNC,XL LOAD PTR TO POSSIBLE TRBLK
6959: JSR KTREX CALL KEYWORD TRACE ROUTINE
6960: *
6961: * CALL FUNCTION AFTER TRACE TESTS COMPLETE
6962: *
6963: MOV 1(XS),XL RESTORE PFBLK POINTER
6964: BRN BPF08 JUMP BACK TO EXECUTE FUNCTION
6965: .IF .CNRA
6966: .ELSE
6967: EJC
6968: *
6969: * RCBLK
6970: *
6971: * THE ROUTINE FOR AN RCBLK IS EXECUTED FROM THE GENERATED
6972: * CODE TO LOAD A REAL VALUE ONTO THE STACK.
6973: *
6974: * (XR) POINTER TO RCBLK
6975: *
6976: B$RCL ENT BL$RC ENTRY POINT (RCBLK)
6977: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
6978: .FI
6979: *
6980: * SCBLK
6981: *
6982: * THE ROUTINE FOR AN SCBLK IS EXECUTED FROM THE GENERATED
6983: * CODE TO LOAD A STRING VALUE ONTO THE STACK.
6984: *
6985: * (XR) POINTER TO SCBLK
6986: *
6987: B$SCL ENT BL$SC ENTRY POINT (SCBLK)
6988: BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
6989: *
6990: * TBBLK
6991: *
6992: * THE ROUTINE FOR A TBBLK IS NEVER EXECUTED
6993: *
6994: B$TBT ENT BL$TB ENTRY POINT (TBBLK)
6995: *
6996: * TEBLK
6997: *
6998: * THE ROUTINE FOR A TEBLK IS NEVER EXECUTED
6999: *
7000: B$TET ENT BL$TE ENTRY POINT (TEBLK)
7001: *
7002: * VCBLK
7003: *
7004: * THE ROUTINE FOR A VCBLK IS NEVER EXECUTED
7005: *
7006: B$VCT ENT BL$VC ENTRY POINT (VCBLK)
7007: EJC
7008: *
7009: * VRBLK
7010: *
7011: * THE VRBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE.
7012: * THERE ARE SIX ENTRIES FOR VRBLK COVERING VARIOUS CASES
7013: *
7014: B$VR$ ENT BL$$I MARK START OF VRBLK ENTRY POINTS
7015: *
7016: * ENTRY FOR VRGET (TRAPPED CASE). THIS ROUTINE IS CALLED
7017: * FROM THE GENERATED CODE TO LOAD THE VALUE OF A VARIABLE.
7018: * THIS ENTRY POINT IS USED IF AN ACCESS TRACE OR INPUT
7019: * ASSOCIATION IS CURRENTLY ACTIVE.
7020: *
7021: * (XR) POINTER TO VRGET FIELD OF VRBLK
7022: *
7023: B$VRA ENT BL$$I ENTRY POINT
7024: MOV XR,XL COPY NAME BASE (VRGET = 0)
7025: MOV *VRVAL,WA SET NAME OFFSET
7026: JSR ACESS ACCESS VALUE
7027: PPM EXFAL FAIL IF ACCESS FAILS
7028: BRN EXIXR ELSE EXIT WITH RESULT IN XR
7029: *
7030: * ENTRY FOR VRSTO (ERROR CASE. THIS ROUTINE IS CALLED FROM
7031: * THE EXECUTED CODE FOR AN ATTEMPT TO MODIFY THE VALUE
7032: * OF A PROTECTED (PATTERN VALUED) NATURAL VARIABLE.
7033: *
7034: B$VRE ENT ENTRY POINT
7035: ERB 049,ATTEMPT TO CHANGE VALUE OF PROTECTED VARIABLE
7036: *
7037: * ENTRY FOR VRTRA (UNTRAPPED CASE). THIS ROUTINE IS CALLED
7038: * FROM THE EXECUTED CODE TO TRANSFER TO A LABEL.
7039: *
7040: * (XR) POINTER TO VRTRA FIELD OF VRBLK
7041: *
7042: B$VRG ENT ENTRY POINT
7043: MOV VRLBO(XR),XR LOAD CODE POINTER
7044: MOV (XR),XL LOAD ENTRY ADDRESS
7045: BRI XL JUMP TO ROUTINE FOR NEXT CODE WORD
7046: *
7047: * ENTRY FOR VRGET (UNTRAPPED CASE). THIS ROUTINE IS CALLED
7048: * FROM THE GENERATED CODE TO LOAD THE VALUE OF A VARIABLE.
7049: *
7050: * (XR) POINTS TO VRGET FIELD OF VRBLK
7051: *
7052: B$VRL ENT ENTRY POINT
7053: MOV VRVAL(XR),-(XS) LOAD VALUE ONTO STACK (VRGET = 0)
7054: BRN EXITS OBEY NEXT CODE WORD
7055: EJC
7056: *
7057: * VRBLK (CONTINUED)
7058: *
7059: * ENTRY FOR VRSTO (UNTRAPPED CASE). THIS ROUTINE IS CALLED
7060: * FROM THE GENERATED CODE TO STORE THE VALUE OF A VARIABLE.
7061: *
7062: * (XR) POINTER TO VRSTO FIELD OF VRBLK
7063: *
7064: B$VRS ENT ENTRY POINT
7065: MOV (XS),VRVLO(XR) STORE VALUE, LEAVE ON STACK
7066: BRN EXITS OBEY NEXT CODE WORD
7067: *
7068: * VRTRA (TRAPPED CASE). THIS ROUTINE IS CALLED FROM THE
7069: * GENERATED CODE TO TRANSFER TO A LABEL WHEN A LABEL
7070: * TRACE IS CURRENTLY ACTIVE.
7071: *
7072: B$VRT ENT ENTRY POINT
7073: SUB *VRTRA,XR POINT BACK TO START OF VRBLK
7074: MOV XR,XL COPY VRBLK POINTER
7075: MOV *VRVAL,WA SET NAME OFFSET
7076: MOV VRLBL(XL),XR LOAD POINTER TO TRBLK
7077: BZE KVTRA,BVRT2 JUMP IF TRACE IS OFF
7078: DCV KVTRA ELSE DECREMENT TRACE COUNT
7079: BZE TRFNC(XR),BVRT1 JUMP IF PRINT TRACE CASE
7080: JSR TRXEQ ELSE EXECUTE FULL TRACE
7081: BRN BVRT2 MERGE TO JUMP TO LABEL
7082: *
7083: * HERE FOR PRINT TRACE -- PRINT COLON ( LABEL NAME )
7084: *
7085: BVRT1 JSR PRTSN PRINT STATEMENT NUMBER
7086: MOV XL,XR COPY VRBLK POINTER
7087: MOV =CH$CL,WA COLON
7088: JSR PRTCH PRINT IT
7089: MOV =CH$PP,WA LEFT PAREN
7090: JSR PRTCH PRINT IT
7091: JSR PRTVN PRINT LABEL NAME
7092: MOV =CH$RP,WA RIGHT PAREN
7093: JSR PRTCF PRINT IT
7094: MOV VRLBL(XL),XR POINT BACK TO TRBLK
7095: *
7096: * MERGE HERE TO JUMP TO LABEL
7097: *
7098: BVRT2 MOV TRLBL(XR),XR LOAD POINTER TO ACTUAL CODE
7099: BRI (XR) EXECUTE STATEMENT AT LABEL
7100: EJC
7101: *
7102: * VRBLK (CONTINUED)
7103: *
7104: * ENTRY FOR VRSTO (TRAPPED CASE). THIS ROUTINE IS CALLED
7105: * FROM THE GENERATED CODE TO STORE THE VALUE OF A VARIABLE.
7106: * THIS ENTRY IS USED WHEN A VALUE TRACE OR OUTPUT
7107: * ASSOCIATION IS CURRENTLY ACTIVE.
7108: *
7109: * (XR) POINTER TO VRSTO FIELD OF VRBLK
7110: *
7111: B$VRV ENT ENTRY POINT
7112: MOV (XS),WB LOAD VALUE (LEAVE COPY ON STACK)
7113: SUB *VRSTO,XR POINT TO VRBLK
7114: MOV XR,XL COPY VRBLK POINTER
7115: MOV *VRVAL,WA SET OFFSET
7116: JSR ASIGN CALL ASSIGNMENT ROUTINE
7117: PPM EXFAL FAIL IF ASSIGNMENT FAILS
7118: BRN EXITS ELSE RETURN WITH RESULT ON STACK
7119: EJC
7120: *
7121: * XNBLK
7122: *
7123: * THE ROUTINE FOR AN XNBLK IS NEVER EXECUTED
7124: *
7125: B$XNT ENT BL$XN ENTRY POINT (XNBLK)
7126: *
7127: * XRBLK
7128: *
7129: * THE ROUTINE FOR AN XRBLK IS NEVER EXECUTED
7130: *
7131: B$XRT ENT BL$XR ENTRY POINT (XRBLK)
7132: *
7133: * MARK ENTRY ADDRESS PAST LAST BLOCK ACTION ROUTINE
7134: *
7135: B$YYY ENT BL$$I LAST BLOCK ROUTINE ENTRY POINT
7136: TTL S P I T B O L -- PATTERN MATCHING ROUTINES
7137: *
7138: * THE FOLLOWING SECTION CONSISTS OF THE PATTERN MATCHING
7139: * ROUTINES. ALL PATTERN NODES CONTAIN A POINTER (PCODE)
7140: * TO ONE OF THE ROUTINES IN THIS SECTION (P$XXX).
7141: *
7142: * NOTE THAT THIS SECTION FOLLOWS THE B$XXX ROUTINES TO
7143: * ENABLE A FAST TEST FOR THE PATTERN DATATYPE.
7144: *
7145: P$AAA ENT BL$$I ENTRY TO MARK FIRST PATTERN
7146: *
7147: *
7148: * THE ENTRY CONDITIONS TO THE MATCH ROUTINE ARE AS FOLLOWS
7149: * (SEE O$PMN, O$PMV, O$PMS AND PROCEDURE MATCH).
7150: *
7151: * STACK CONTENTS.
7152: *
7153: * NAME BASE (O$PMN ONLY)
7154: * NAME OFFSET (O$PMN ONLY)
7155: * TYPE (0-O$PMN, 1-O$PMV, 2-O$PMS)
7156: * PMHBS --------------- INITIAL CURSOR (ZERO)
7157: * INITIAL NODE POINTER
7158: * XS ------------------ =NDABO (ANCHORED), =NDUNA (UNANCH)
7159: *
7160: * REGISTER VALUES.
7161: *
7162: * (XS) SET AS SHOWN IN STACK DIAGRAM
7163: * (XR) POINTER TO INITIAL PATTERN NODE
7164: * (WB) INITIAL CURSOR (ZERO)
7165: *
7166: * GLOBAL PATTERN VALUES
7167: *
7168: * R$PMS POINTER TO SUBJECT STRING SCBLK
7169: * PMSSL LENGTH OF SUBJECT STRING IN CHARS
7170: * PMDFL DOT FLAG, INITIALLY ZERO
7171: * PMHBS SET AS SHOWN IN STACK DIAGRAM
7172: *
7173: * CONTROL IS PASSED BY BRANCHING THROUGH THE PCODE
7174: * FIELD OF THE INITIAL PATTERN NODE (BRI (XR)).
7175: EJC
7176: *
7177: * DESCRIPTION OF ALGORITHM
7178: *
7179: * A PATTERN STRUCTURE IS REPRESENTED AS A LINKED GRAPH
7180: * OF NODES WITH THE FOLLOWING STRUCTURE.
7181: *
7182: * +------------------------------------+
7183: * I PCODE I
7184: * +------------------------------------+
7185: * I PTHEN I
7186: * +------------------------------------+
7187: * I PARM1 I
7188: * +------------------------------------+
7189: * I PARM2 I
7190: * +------------------------------------+
7191: *
7192: * PCODE IS A POINTER TO THE ROUTINE WHICH WILL PERFORM
7193: * THE MATCH OF THIS PARTICULAR NODE TYPE.
7194: *
7195: * PTHEN IS A POINTER TO THE SUCCESSOR NODE. I.E. THE NODE
7196: * TO BE MATCHED IF THE ATTEMPT TO MATCH THIS NODE SUCCEEDS.
7197: * IF THIS IS THE LAST NODE OF THE PATTERN PTHEN POINTS
7198: * TO THE DUMMY NODE NDNTH WHICH INITIATES PATTERN EXIT.
7199: *
7200: * PARM1, PARM2 ARE PARAMETERS WHOSE USE VARIES WITH THE
7201: * PARTICULAR NODE. THEY ARE ONLY PRESENT IF REQUIRED.
7202: *
7203: * ALTERNATIVES ARE HANDLED WITH THE SPECIAL ALTERNATIVE
7204: * NODE WHOSE PARAMETER POINTS TO THE NODE TO BE MATCHED
7205: * IF THERE IS A FAILURE ON THE SUCCESSOR PATH.
7206: *
7207: * THE FOLLOWING EXAMPLE ILLUSTRATES THE MANNER IN WHICH
7208: * THE STRUCTURE IS BUILT UP. THE PATTERN IS
7209: *
7210: * (A / B / C) (D / E) WHERE / IS ALTERNATION
7211: *
7212: * IN THE DIAGRAM, THE NODE MARKED + REPRESENTS AN
7213: * ALTERNATIVE NODE AND THE DOTTED LINE FROM A + NODE
7214: * REPRESENTS THE PARAMETER POINTER TO THE ALTERNATIVE.
7215: *
7216: * +---+ +---+ +---+ +---+
7217: * I + I-----I A I-----I + I-----I D I-----
7218: * +---+ +---+ I +---+ +---+
7219: * . I .
7220: * . I .
7221: * +---+ +---+ I +---+
7222: * I + I-----I B I--I I E I-----
7223: * +---+ +---+ I +---+
7224: * . I
7225: * . I
7226: * +---+ I
7227: * I C I------------I
7228: * +---+
7229: EJC
7230: *
7231: * DURING THE MATCH, THE REGISTERS ARE USED AS FOLLOWS.
7232: *
7233: * (XR) POINTS TO THE CURRENT NODE
7234: * (XL) SCRATCH
7235: * (XS) MAIN STACK POINTER
7236: * (WB) CURSOR (NUMBER OF CHARS MATCHED)
7237: * (WA,WC) SCRATCH
7238: *
7239: * TO KEEP TRACK OF ALTERNATIVES, THE MAIN STACK IS USED AS
7240: * A HISTORY STACK AND CONTAINS TWO WORD ENTRIES.
7241: *
7242: * WORD 1 SAVED CURSOR VALUE
7243: * WORD 2 NODE TO MATCH ON FAILURE
7244: *
7245: * WHEN A FAILURE OCCURS, THE MOST RECENT ENTRY ON THIS
7246: * STACK IS POPPED OFF TO RESTORE THE CURSOR AND POINT
7247: * TO THE NODE TO BE MATCHED AS AN ALTERNATIVE. THE ENTRY
7248: * AT THE BOTTOM OF THE STACK POINTS TO THE FOLLOWING
7249: * SPECIAL NODES DEPENDING ON THE SCAN MODE.
7250: *
7251: * ANCHORED MODE THE BOTTOM ENTRY POINTS TO THE
7252: * SPECIAL NODE NDABO WHICH CAUSES AN
7253: * ABORT. THE CURSOR VALUE STORED
7254: * WITH THIS ENTRY IS ALWAYS ZERO.
7255: *
7256: * UNANCHORED MODE THE BOTTOM ENTRY POINTS TO THE
7257: * SPECIAL NODE NDUNA WHICH MOVES THE
7258: * ANCHOR POINT AND RESTARTS THE MATCH
7259: * THE CURSOR SAVED WITH THIS ENTRY
7260: * IS THE NUMBER OF CHARACTERS WHICH
7261: * LIE BEFORE THE INITIAL ANCHOR POINT
7262: * (I.E. THE NUMBER OF ANCHOR MOVES).
7263: * THIS ENTRY IS THREE WORDS LONG AND
7264: * ALSO CONTAINS THE INITIAL PATTERN.
7265: *
7266: * ENTRIES ARE MADE ON THIS HISTORY STACK BY ALTERNATIVE
7267: * NODES AND BY SOME SPECIAL COMPOUD PATTERNS AS DESCRIBED
7268: * LATER ON. THE FOLLOWING GLOBAL LOCATIONS ARE USED DURING
7269: * PATTERN MATCHING.
7270: *
7271: * R$PMS POINTER TO SUBJECT STRING
7272: * PMSSL LENGTH OF SUBJECT STRING
7273: * PMDFL FLAG SET NON-ZERO FOR DOT PATTERNS
7274: * PMHBS BASE PTR FOR CURRENT HISTORY STACK
7275: *
7276: * THE FOLLOWING EXIT POINTS ARE AVAILABLE TO MATCH ROUTINES
7277: *
7278: * SUCCP SUCCESS IN MATCHING CURRENT NODE
7279: * FAILP FAILURE IN MATCHING CURRENT NODE
7280: EJC
7281: *
7282: * COMPOUND PATTERNS
7283: *
7284: * SOME PATTERNS HAVE IMPLICIT ALTERNATIVES AND THEIR
7285: * REPRESENTATION IN THE PATTERN STRUCTURE CONSISTS OF A
7286: * LINKED SET OF NODES AS INDICATED BY THESE DIAGRAMS.
7287: *
7288: * AS BEFORE, THE + REPRESENTS AN ALTERNATIVE NODE AND
7289: * THE DOTTED LINE FROM A + NODE IS THE PARAMETER POINTER
7290: * TO THE ALTERNATIVE PATTERN.
7291: *
7292: * ARB
7293: * ---
7294: *
7295: * +---+ THIS NODE (P$ARB) MATCHES NULL
7296: * I B I----- AND STACKS CURSOR, SUCCESSOR PTR,
7297: * +---+ CURSOR (COPY) AND A PTR TO NDARC.
7298: *
7299: *
7300: *
7301: *
7302: * BAL
7303: * ---
7304: *
7305: * +---+ THE P$BAL NODE SCANS A BALANCED
7306: * I B I----- STRING AND THEN STACKS A POINTER
7307: * +---+ TO ITSELF ON THE HISTORY STACK.
7308: EJC
7309: *
7310: * COMPOUND PATTERN STRUCTURES (CONTINUED)
7311: *
7312: *
7313: * ARBNO
7314: * -----
7315: *
7316: * +---+ THIS ALTERNATIVE NODE MATCHES NULL
7317: * +----I + I----- THE FIRST TIME AND STACKS A POINTER
7318: * I +---+ TO THE ARGUMENT PATTERN X.
7319: * I .
7320: * I .
7321: * I +---+ NODE (P$ABA) TO STACK CURSOR
7322: * I I A I AND HISTORY STACK BASE PTR.
7323: * I +---+
7324: * I I
7325: * I I
7326: * I +---+ THIS IS THE ARGUMENT PATTERN. AS
7327: * I I X I INDICATED, THE SUCCESSOR OF THE
7328: * I +---+ PATTERN IS THE P$ABC NODE
7329: * I I
7330: * I I
7331: * I +---+ THIS NODE (P$ABC) POPS PMHBS,
7332: * +----I C I STACKS OLD PMHBS AND PTR TO NDABD
7333: * +---+ (UNLESS OPTIMISATION HAS OCCURRED)
7334: *
7335: * STRUCTURE AND EXECUTION OF THIS PATTERN RESEMBLE THOSE OF
7336: * RECURSIVE PATTERN MATCHING AND IMMEDIATE ASSIGNMENT.
7337: * THE ALTERNATIVE NODE AT THE HEAD OF THE STRUCTURE MATCHES
7338: * NULL INITIALLY BUT ON SUBSEQUENT FAILURE ENSURES ATTEMPT
7339: * TO MATCH THE ARGUMENT. BEFORE THE ARGUMENT IS MATCHED
7340: * P$ABA STACKS THE CURSOR,PMHBS AND A PTR TO P$ABB. IF
7341: * THE ARGUMENT CANT BE MATCHED , P$ABB REMOVES THIS SPECIAL
7342: * STACK ENTRY AND FAILS.
7343: * IF ARGUMENT IS MATCHED , P$ABC RESTORES THE OUTER PMHBS
7344: * VALUE (SAVED BY P$ABA) . THEN IF THE ARGUMENT HAS LEFT
7345: * ALTERNATIVES ON STACK IT STACKS THE INNER VALUE OF PMHBS
7346: * AND A PTR TO NDABD. IF ARGUMENT LEFT NOTHING ON THE STACK
7347: * IT OPTIMISES BY REMOVING ITEMS STACKED BY P$ABA. FINALLY
7348: * A CHECK IS MADE THAT ARGUMENT MATCHED MORE THAN THE NULL
7349: * STRING (CHECK IS INTENDED TO PREVENT USELESS LOOPING).
7350: * IF SO THE SUCCESSOR IS AGAIN THE ALTERNATIVE NODE AT THE
7351: * HEAD OF THE STRUCTURE , ENSURING A POSSIBLE EXTRA ATTEMPT
7352: * TO MATCH THE ARG IF NECESSARY. IF NOT , THE SUCCESSOR TO
7353: * ALTERNATIVE IS TAKEN SO AS TO TERMINATE THE LOOP. P$ABD
7354: * RESTORES INNER PMHBS PTR AND FAILS , THUS TRYING TO MATCH
7355: * ALTERNATIVES LEFT BY THE ARBNO ARGUMENT.
7356: EJC
7357: *
7358: * COMPOUND PATTERN STRUCTURES (CONTINUED)
7359: *
7360: * BREAKX
7361: * ------
7362: *
7363: * +---+ THIS NODE IS A BREAK NODE FOR
7364: * +----I B I THE ARGUMENT TO BREAKX, IDENTICAL
7365: * I +---+ TO AN ORDINARY BREAK NODE.
7366: * I I
7367: * I I
7368: * I +---+ THIS ALTERNATIVE NODE STACKS A
7369: * I I + I----- POINTER TO THE BREAKX NODE TO
7370: * I +---+ ALLOW FOR SUBSEQUENT FAILURE
7371: * I .
7372: * I .
7373: * I +---+ THIS IS THE BREAKX NODE ITSELF. IT
7374: * +----I X I MATCHES ONE CHARACTER AND THEN
7375: * +---+ PROCEEDS BACK TO THE BREAK NODE.
7376: *
7377: *
7378: *
7379: *
7380: * FENCE
7381: * -----
7382: *
7383: * +---+ THE FENCE NODE MATCHES NULL AND
7384: * I F I----- STACKS A POINTER TO NODE NDABO TO
7385: * +---+ ABORT ON A SUBSEQUENT REMATCH
7386: *
7387: *
7388: *
7389: *
7390: * SUCCEED
7391: * -------
7392: *
7393: * +---+ THE NODE FOR SUCCEED MATCHES NULL
7394: * I S I----- AND STACKS A POINTER TO ITSELF
7395: * +---+ TO REPEAT THE MATCH ON A FAILURE.
7396: EJC
7397: *
7398: * COMPOUND PATTERNS (CONTINUED)
7399: *
7400: * BINARY DOT (PATTERN ASSIGNMENT)
7401: * -------------------------------
7402: *
7403: * +---+ THIS NODE (P$PAA) SAVES THE CURRENT
7404: * I A I CURSOR AND A POINTER TO THE
7405: * +---+ SPECIAL NODE NDPAB ON THE STACK.
7406: * I
7407: * I
7408: * +---+ THIS IS THE STRUCTURE FOR THE
7409: * I X I PATTERN LEFT ARGUMENT OF THE
7410: * +---+ PATTERN ASSIGNMENT CALL.
7411: * I
7412: * I
7413: * +---+ THIS NODE (P$PAC) SAVES THE CURSOR,
7414: * I C I----- A PTR TO ITSELF, THE CURSOR (COPY)
7415: * +---+ AND A PTR TO NDPAD ON THE STACK.
7416: *
7417: *
7418: * THE FUNCTION OF THE MATCH ROUTINE FOR NDPAB (P$PAB)
7419: * IS SIMPLY TO UNSTACK ITSELF AND FAIL BACK ONTO THE STACK.
7420: *
7421: * THE MATCH ROUTINE FOR P$PAC ALSO SETS THE GLOBAL PATTERN
7422: * FLAG PMDFL NON-ZERO TO INDICATE THAT PATTERN ASSIGNMENTS
7423: * MAY HAVE OCCURED IN THE PATTERN MATCH
7424: *
7425: * IF PMDFL IS SET AT THE END OF THE MATCH (SEE P$NTH), THE
7426: * HISTORY STACK IS SCANNED FOR MATCHING NDPAB-NDPAD PAIRS
7427: * AND THE CORRESPONDING PATTERN ASSIGNMENTS ARE EXECUTED.
7428: *
7429: * THE FUNCTION OF THE MATCH ROUTINE FOR NDPAD (P$PAD)
7430: * IS SIMPLY TO REMOVE ITS ENTRY FROM THE STACK AND FAIL.
7431: * THIS INCLUDES REMOVING THE SPECIAL NODE POINTER STORED
7432: * IN ADDITION TO THE STANDARD TWO ENTRIES ON THE STACK.
7433: .IF .CNFN
7434: .ELSE
7435: EJC
7436: *
7437: * FENCE (FUNCTION)
7438: * ----------------
7439: *
7440: * +---+ THIS NODE (P$FNA) SAVES THE
7441: * I A I CURRENT HISTORY STACK AND A
7442: * +---+ POINTER TO NDFNB ON THE STACK.
7443: * I
7444: * I
7445: * +---+ THIS IS THE PATTERN STRUCTURE
7446: * I X I GIVEN AS THE ARGUMENT TO THE
7447: * +---+ FENCE FUNCTION.
7448: * I
7449: * I
7450: * +---+ THIS NODE P$FNC RESTORES THE OUTER
7451: * I C I HISTORY STACK PTR SAVED IN P$FNA,
7452: * +---+ AND STACKS THE INNER STACK BASE
7453: * PTR AND A POINTER TO NDFND ON THE
7454: * STACK.
7455: *
7456: * NDFNB (F$FNB) SIMPLY IS THE FAILURE EXIT FOR PATTERN
7457: * ARGUMENT FAILURE, AND IT POPS ITSELF AND FAILS ONTO THE
7458: * STACK.
7459: *
7460: * THE MATCH ROUTINE P$FNC ALLOWS FOR AN OPTIMIZATION WHEN
7461: * THE FENCE PATTERN LEAVES NO ALTERNATIVES. IN THIS CASE,
7462: * THE NDFNB ENTRY IS POPPED, AND THE MATCH CONTINUES.
7463: *
7464: * NDFND (P$FND) IS ENTERED WHEN THE PATTERN FAILS AFTER
7465: * GOING THROUGH A NON-OPTIMIZED P$FNC, AND IT POPS THE
7466: * STACK BACK PAST THE INNER STACK BASE CREATED BY P$FNA
7467: .FI
7468: EJC
7469: *
7470: * COMPOUND PATTERNS (CONTINUED)
7471: *
7472: * EXPRESSION PATTERNS (RECURSIVE PATTERN MATCHES)
7473: * -----------------------------------------------
7474: *
7475: * INITIAL ENTRY FOR A PATTERN NODE IS TO THE ROUTINE P$EXA.
7476: * IF THE EVALUATED RESULT OF THE EXPRESSION IS ITSELF A
7477: * PATTERN, THEN THE FOLLOWING STEPS ARE TAKEN TO ARRANGE
7478: * FOR PROPER RECURSIVE PROCESSING.
7479: *
7480: * 1) A POINTER TO THE CURRENT NODE (THE P$EXA NODE) IS
7481: * STORED ON THE HISTORY STACK WITH A DUMMY CURSOR.
7482: *
7483: * 2) A SPECIAL HISTORY STACK ENTRY IS MADE IN WHICH THE
7484: * NODE POINTER POINTS TO NDEXB, AND THE CURSOR VALUE
7485: * IS THE SAVED VALUE OF PMHBS ON ENTRY TO THIS NODE.
7486: * THE MATCH ROUTINE FOR NDEXB (P$EXB) RESTORES PMHBS
7487: * FROM THIS CURSOR ENTRY, POPS OFF THE P$EXA NODE
7488: * POINTER AND FAILS.
7489: *
7490: * 3) THE RESULTING HISTORY STACK POINTER IS SAVED IN
7491: * PMHBS TO ESTABLISH A NEW LEVEL OF HISTORY STACK.
7492: *
7493: * AFTER MATCHING A PATTERN, THE END OF MATCH ROUTINE GETS
7494: * CONTROL (P$NTH). THIS ROUTINE PROCEEDS AS FOLLOWS.
7495: *
7496: * 1) LOAD THE CURRENT VALUE OF PMHBS AND RECOGNIZE THE
7497: * OUTER LEVEL CASE BY THE FACT THAT THE ASSOCIATED
7498: * CURSOR IN THIS CASE IS THE PATTERN MATCH TYPE CODE
7499: * WHICH IS LESS THAN 3. TERMINATE THE MATCH IN THIS
7500: * CASE AND CONTINUE EXECUTION OF THE PROGRAM.
7501: *
7502: * 2) OTHERWISE MAKE A SPECIAL HISTORY STACK ENTRY IN
7503: * WHICH THE NODE POINTER POINTS TO THE SPECIAL NODE
7504: * NDEXC AND THE CURSOR IS THE CURRENT VALUE OF PMHBS.
7505: * THE MATCH ROUTINE FOR NDEXC (P$EXC) RESETS PMHBS TO
7506: * THIS (INNER) VALUE AND AND THEN FAILS.
7507: *
7508: * 3) USING THE HISTORY STACK ENTRY MADE ON STARTING THE
7509: * EXPRESSION (ACCESSIBLE WITH THE CURRENT VALUE OF
7510: * PMHBS), RESTORE THE P$EXA NODE POINTER AND THE OLD
7511: * PMHBS SETTING. TAKE THE SUCCESSOR AND CONTINUE.
7512: *
7513: * AN OPTIMIZATION IS POSSIBLE IF THE EXPRESSION PATTERN
7514: * MAKES NO ENTRIES ON THE HISTORY STACK. IN THIS CASE,
7515: * INSTEAD OF BUILDING THE P$EXC NODE IN STEP 2, IT IS MORE
7516: * EFFICIENT TO SIMPLY POP OFF THE P$EXB ENTRY AND ITS
7517: * ASSOCIATED NODE POINTER. THE EFFECT IS THE SAME.
7518: EJC
7519: *
7520: * COMPOUND PATTERNS (CONTINUED)
7521: *
7522: * BINARY DOLLAR (IMMEDIATE ASSIGNMENT)
7523: * ------------------------------------
7524: *
7525: * +---+ THIS NODE (P$IMA) STACKS THE CURSOR
7526: * I A I PMHBS AND A PTR TO NDIMB AND RESETS
7527: * +---+ THE STACK PTR PMHBS.
7528: * I
7529: * I
7530: * +---+ THIS IS THE LEFT STRUCTURE FOR THE
7531: * I X I PATTERN LEFT ARGUMENT OF THE
7532: * +---+ IMMEDIATE ASSIGNMENT CALL.
7533: * I
7534: * I
7535: * +---+ THIS NODE (P$IMC) PERFORMS THE
7536: * I C I----- ASSIGNMENT, POPS PMHBS AND STACKS
7537: * +---+ THE OLD PMHBS AND A PTR TO NDIMD.
7538: *
7539: *
7540: * THE STRUCTURE AND EXECUTION OF THIS PATTERN ARE SIMILAR
7541: * TO THOSE OF THE RECURSIVE EXPRESSION PATTERN MATCHING.
7542: *
7543: * THE MATCH ROUTINE FOR NDIMB (P$IMB) RESTORES THE OUTER
7544: * LEVEL VALUE OF PMHBS, UNSTACKS THE SAVED CURSOR AND FAILS
7545: *
7546: * THE MATCH ROUTINE P$IMC USES THE CURRENT VALUE OF PMHBS
7547: * TO LOCATE THE P$IMB ENTRY. THIS ENTRY IS USED TO MAKE
7548: * THE ASSIGNMENT AND RESTORE THE OUTER LEVEL VALUE OF
7549: * PMHBS. FINALLY, THE INNER LEVEL VALUE OF PMHBS AND A
7550: * POINTER TO THE SPECIAL NODE NDIMD ARE STACKED.
7551: *
7552: * THE MATCH ROUTINE FOR NDIMD (P$IMD) RESTORES THE INNER
7553: * LEVEL VALUE OF PMHBS AND FAILS BACK INTO THE STACK.
7554: *
7555: * AN OPTIMIZATION OCCURS IF THE INNER PATTERN MAKES NO
7556: * ENTRIES ON THE HISTORY STACK. IN THIS CASE, P$IMC POPS
7557: * THE P$IMB ENTRY INSTEAD OF MAKING A P$IMD ENTRY.
7558: EJC
7559: *
7560: * ARBNO
7561: *
7562: * SEE COMPOUND PATTERNS SECTION FOR STUCTURE AND
7563: * ALGORITHM FOR MATCHING THIS NODE TYPE.
7564: *
7565: * NO PARAMETERS
7566: *
7567: P$ABA ENT BL$P0 P0BLK
7568: MOV WB,-(XS) STACK CURSOR
7569: MOV XR,-(XS) STACK DUMMY NODE PTR
7570: MOV PMHBS,-(XS) STACK OLD STACK BASE PTR
7571: MOV =NDABB,-(XS) STACK PTR TO NODE NDABB
7572: MOV XS,PMHBS STORE NEW STACK BASE PTR
7573: BRN SUCCP SUCCEED
7574: *
7575: * ARBNO (REMOVE P$ABA SPECIAL STACK ENTRY)
7576: *
7577: * NO PARAMETERS (DUMMY PATTERN)
7578: *
7579: P$ABB ENT ENTRY POINT
7580: MOV WB,PMHBS RESTORE HISTORY STACK BASE PTR
7581: BRN FLPOP FAIL AND POP DUMMY NODE PTR
7582: *
7583: * ARBNO (CHECK IF ARG MATCHED NULL STRING)
7584: *
7585: * NO PARAMETERS (DUMMY PATTERN)
7586: *
7587: P$ABC ENT BL$P0 P0BLK
7588: MOV PMHBS,XT KEEP P$ABB STACK BASE
7589: MOV 3(XT),WA LOAD INITIAL CURSOR
7590: MOV 1(XT),PMHBS RESTORE OUTER STACK BASE PTR
7591: BEQ XT,XS,PABC1 JUMP IF NO HISTORY STACK ENTRIES
7592: MOV XT,-(XS) ELSE SAVE INNER PMHBS ENTRY
7593: MOV =NDABD,-(XS) STACK PTR TO SPECIAL NODE NDABD
7594: BRN PABC2 MERGE
7595: *
7596: * OPTIMISE CASE OF NO EXTRA ENTRIES ON STACK FROM ARBNO ARG
7597: *
7598: PABC1 ADD *NUM04,XS REMOVE NDABB ENTRY AND CURSOR
7599: *
7600: * MERGE TO CHECK FOR MATCHING OF NULL STRING
7601: *
7602: PABC2 BNE WA,WB,SUCCP ALLOW FURTHER ATTEMPT IF NON-NULL
7603: MOV PTHEN(XR),XR BYPASS ALTERNATIVE NODE SO AS TO ..
7604: BRN SUCCP ... REFUSE FURTHER MATCH ATTEMPTS
7605: *
7606: * ARBNO (TRY FOR ALTERNATIVES IN ARBNO ARGUMENT)
7607: *
7608: * NO PARAMETERS (DUMMY PATTERN)
7609: *
7610: P$ABD ENT ENTRY POINT
7611: MOV WB,PMHBS RESTORE INNER STACK BASE PTR
7612: BRN FAILP AND FAIL
7613: EJC
7614: *
7615: * ABORT
7616: *
7617: * NO PARAMETERS
7618: *
7619: P$ABO ENT BL$P0 P0BLK
7620: BRN EXFAL SIGNAL STATEMENT FAILURE
7621: *
7622: * ALTERNATION
7623: *
7624: * PARM1 ALTERNATIVE NODE
7625: *
7626: P$ALT ENT BL$P1 P1BLK
7627: MOV WB,-(XS) STACK CURSOR
7628: MOV PARM1(XR),-(XS) STACK POINTER TO ALTERNATIVE
7629: CHK CHECK FOR STACK OVERFLOW
7630: BRN SUCCP IF ALL OK, THEN SUCCEED
7631: EJC
7632: *
7633: * ANY (ONE CHARACTER ARGUMENT) (1-CHAR STRING ALSO)
7634: *
7635: * PARM1 CHARACTER ARGUMENT
7636: *
7637: P$ANS ENT BL$P1 P1BLK
7638: BEQ WB,PMSSL,FAILP FAIL IF NO CHARS LEFT
7639: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
7640: PLC XL,WB POINT TO CURRENT CHARACTER
7641: LCH WA,(XL) LOAD CURRENT CHARACTER
7642: BNE WA,PARM1(XR),FAILP FAIL IF NO MATCH
7643: ICV WB ELSE BUMP CURSOR
7644: BRN SUCCP AND SUCCEED
7645: *
7646: * ANY (MULTI-CHARACTER ARGUMENT CASE)
7647: * EXPRESSION ARGUMENT CASE MERGES
7648: *
7649: * PARM1 POINTER TO CTBLK
7650: * PARM2 BIT MASK TO SELECT BIT IN CTBLK
7651: *
7652: P$ANY ENT BL$P2 P2BLK
7653: BEQ WB,PMSSL,FAILP FAIL IF NO CHARACTERS LEFT
7654: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
7655: PLC XL,WB GET CHAR PTR TO CURRENT CHARACTER
7656: LCH WA,(XL) LOAD CURRENT CHARACTER
7657: MOV PARM1(XR),XL POINT TO CTBLK
7658: WTB WA CHANGE TO BAU OFFSET
7659: ADD WA,XL POINT TO ENTRY IN CTBLK
7660: MOV CTCHS(XL),WA LOAD WORD FROM CTBLK
7661: ANB PARM2(XR),WA AND WITH SELECTED BIT
7662: ZRB WA,FAILP FAIL IF NO MATCH
7663: ICV WB ELSE BUMP CURSOR
7664: BRN SUCCP AND SUCCEED
7665: *
7666: * ANY (EXPRESSION ARGUMENT)
7667: *
7668: * PARM1 EXPRESSION POINTER
7669: *
7670: P$AYD ENT BL$P1 P1BLK
7671: MOV =P$ANY,WA PCODE FOR NEW NODE
7672: JSR EVALS EVALUATE STRING ARGUMENT
7673: ERR 050,ANY EVALUATED ARGUMENT IS NOT STRING
7674: PPM FAILP FAIL IF EVALUATION FAILURE
7675: BRI XL MERGE MULTI-CHAR CASE IF OK
7676: EJC
7677: *
7678: * P$ARB INITIAL ARB MATCH
7679: *
7680: * NO PARAMETERS
7681: *
7682: * THE P$ARB NODE IS PART OF A COMPOUND PATTERN STRUCTURE
7683: * FOR AN ARB PATTERN (SEE DESCRIPTION OF COMPOUND PATTERNS)
7684: *
7685: P$ARB ENT BL$P0 P0BLK
7686: MOV PTHEN(XR),XR LOAD SUCCESSOR POINTER
7687: MOV WB,-(XS) STACK DUMMY CURSOR
7688: MOV XR,-(XS) STACK SUCCESSOR POINTER
7689: MOV WB,-(XS) STACK CURSOR
7690: MOV =NDARC,-(XS) STACK PTR TO SPECIAL NODE NDARC
7691: BRI (XR) EXECUTE NEXT NODE MATCHING NULL
7692: *
7693: * P$ARC EXTEND ARB MATCH
7694: *
7695: * NO PARAMETERS (DUMMY PATTERN)
7696: *
7697: P$ARC ENT ENTRY POINT
7698: BEQ WB,PMSSL,FLPOP FAIL AND POP STACK TO SUCCESSOR
7699: ICV WB ELSE BUMP CURSOR
7700: MOV WB,-(XS) STACK UPDATED CURSOR
7701: MOV XR,-(XS) RESTACK POINTER TO NDARC NODE
7702: MOV 2(XS),XR LOAD SUCCESSOR POINTER
7703: BRI (XR) OFF TO REEXECUTE SUCCESSOR NODE
7704: EJC
7705: *
7706: * BAL
7707: *
7708: * NO PARAMETERS
7709: *
7710: * THE P$BAL NODE IS PART OF THE COMPOUND STRUCTURE BUILT
7711: * FOR BAL (SEE SECTION ON COMPOUND PATTERNS).
7712: *
7713: P$BAL ENT BL$P0 P0BLK
7714: ZER WC ZERO PARENTHESES LEVEL COUNTER
7715: MOV R$PMS,XL POINT TO SUBJECT STRING
7716: PLC XL,WB POINT TO CURRENT CHARACTER
7717: BRN PBAL2 JUMP INTO SCAN LOOP
7718: *
7719: * LOOP TO SCAN OUT CHARACTERS
7720: *
7721: PBAL1 LCH WA,(XL)+ LOAD NEXT CHARACTER, BUMP POINTER
7722: ICV WB PUSH CURSOR FOR CHARACTER
7723: BEQ WA,=CH$PP,PBAL3 JUMP IF LEFT PAREN
7724: BEQ WA,=CH$RP,PBAL4 JUMP IF RIGHT PAREN
7725: BZE WC,PBAL5 ELSE SUCCEED IF AT OUTER LEVEL
7726: *
7727: * HERE AFTER PROCESSING ONE CHARACTER
7728: *
7729: PBAL2 BNE WB,PMSSL,PBAL1 LOOP BACK UNLESS END OF STRING
7730: BRN FAILP IN WHICH CASE, FAIL
7731: *
7732: * HERE ON LEFT PAREN
7733: *
7734: PBAL3 ICV WC BUMP PAREN LEVEL
7735: BRN PBAL2 LOOP BACK TO CHECK END OF STRING
7736: *
7737: * HERE FOR RIGHT PAREN
7738: *
7739: PBAL4 BZE WC,FAILP FAIL IF NO MATCHING LEFT PAREN
7740: DCV WC ELSE DECREMENT LEVEL COUNTER
7741: BNZ WC,PBAL2 LOOP BACK IF NOT AT OUTER LEVEL
7742: *
7743: * HERE AFTER SUCCESSFULLY SCANNING A BALANCED STRING
7744: *
7745: PBAL5 MOV WB,-(XS) STACK CURSOR
7746: MOV XR,-(XS) STACK PTR TO BAL NODE FOR EXTEND
7747: BRN SUCCP AND SUCCEED
7748: EJC
7749: *
7750: * BREAK (EXPRESSION ARGUMENT)
7751: *
7752: * PARM1 EXPRESSION POINTER
7753: *
7754: P$BKD ENT BL$P1 P1BLK
7755: MOV =P$BRK,WA PCODE FOR NEW NODE
7756: JSR EVALS EVALUATE STRING EXPRESSION
7757: ERR 051,BREAK EVALUATED ARGUMENT IS NOT STRING
7758: PPM FAILP FAIL IF EVALUATION FAILS
7759: BRI XL MERGE WITH MULTI-CHAR CASE IF OK
7760: *
7761: * BREAK (ONE CHARACTER ARGUMENT)
7762: *
7763: * PARM1 CHARACTER ARGUMENT
7764: *
7765: P$BKS ENT BL$P1 P1BLK
7766: MOV PMSSL,WC GET SUBJECT STRING LENGTH
7767: SUB WB,WC GET NUMBER OF CHARACTERS LEFT
7768: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT
7769: LCT WC,WC SET COUNTER FOR CHARS LEFT
7770: MOV R$PMS,XL POINT TO SUBJECT STRING
7771: PLC XL,WB POINT TO CURRENT CHARACTER
7772: *
7773: * LOOP TO SCAN TILL BREAK CHARACTER FOUND
7774: *
7775: PBKS1 LCH WA,(XL)+ LOAD NEXT CHAR, BUMP POINTER
7776: BEQ WA,PARM1(XR),SUCCP SUCCEED IF BREAK CHARACTER FOUND
7777: ICV WB ELSE PUSH CURSOR
7778: BCT WC,PBKS1 LOOP BACK IF MORE TO GO
7779: BRN FAILP FAIL IF END OF STRING, NO BREAK CHR
7780: EJC
7781: *
7782: * BREAK (MULTI-CHARACTER ARGUMENT)
7783: * EXPRESSION ARGUMENT CASE MERGES
7784: *
7785: * PARM1 POINTER TO CTBLK
7786: * PARM2 BIT MASK TO SELECT BIT COLUMN
7787: *
7788: P$BRK ENT BL$P2 P2BLK
7789: MOV PMSSL,WC LOAD SUBJECT STRING LENGTH
7790: SUB WB,WC GET NUMBER OF CHARACTERS LEFT
7791: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT
7792: LCT WC,WC SET COUNTER FOR CHARACTERS LEFT
7793: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
7794: PLC XL,WB POINT TO CURRENT CHARACTER
7795: MOV XR,PSAVE SAVE NODE POINTER
7796: *
7797: * LOOP TO SEARCH FOR BREAK CHARACTER
7798: *
7799: PBRK2 LCH WA,(XL)+ LOAD NEXT CHAR, BUMP POINTER
7800: MOV PARM1(XR),XR LOAD POINTER TO CTBLK
7801: WTB WA CONVERT TO BAU OFFSET
7802: ADD WA,XR POINT TO CTBLK ENTRY
7803: MOV CTCHS(XR),WA LOAD CTBLK WORD
7804: MOV PSAVE,XR RESTORE NODE POINTER
7805: ANB PARM2(XR),WA AND WITH SELECTED BIT
7806: NZB WA,SUCCP SUCCEED IF BREAK CHARACTER FOUND
7807: ICV WB ELSE PUSH CURSOR
7808: BCT WC,PBRK2 LOOP BACK UNLESS END OF STRING
7809: BRN FAILP FAIL IF END OF STRING, NO BREAK CHR
7810: EJC
7811: *
7812: * BREAKX (EXTENSION)
7813: *
7814: * THIS IS THE ENTRY WHICH CAUSES AN EXTENSION OF A BREAKX
7815: * MATCH WHEN FAILURE OCCURS. SEE SECTION ON COMPOUND
7816: * PATTERNS FOR FULL DETAILS OF BREAKX MATCHING.
7817: *
7818: * NO PARAMETERS
7819: *
7820: P$BKX ENT BL$P0 P0BLK
7821: ICV WB STEP CURSOR PAST PREVIOUS BREAK CHR
7822: BRN SUCCP SUCCEED TO REMATCH BREAK
7823: *
7824: * BREAKX (EXPRESSION ARGUMENT)
7825: *
7826: * SEE SECTION ON COMPOUND PATTERNS FOR FULL STRUCTURE OF
7827: * BREAKX PATTERN. THE ACTUAL CHARACTER MATCHING USES A
7828: * BREAK NODE. HOWEVER, THE ENTRY FOR THE EXPRESSION
7829: * ARGUMENT CASE IS SEPARATED TO GET PROPER ERROR MESSAGES.
7830: *
7831: * PARM1 EXPRESSION POINTER
7832: *
7833: P$BXD ENT BL$P1 P1BLK
7834: MOV =P$BRK,WA PCODE FOR NEW NODE
7835: JSR EVALS EVALUATE STRING ARGUMENT
7836: ERR 052,BREAKX EVALUATED ARGUMENT IS NOT STRING
7837: PPM FAILP FAIL IF EVALUATION FAILS
7838: BRI XL MERGE WITH BREAK IF ALL OK
7839: *
7840: * CURSOR ASSIGNMENT
7841: *
7842: * PARM1 NAME BASE
7843: * PARM2 NAME OFFSET
7844: *
7845: P$CAS ENT BL$P2 P2BLK
7846: MOV XR,-(XS) SAVE NODE POINTER
7847: MOV WB,-(XS) SAVE CURSOR
7848: MOV PARM1(XR),XL LOAD NAME BASE
7849: MTI WB LOAD CURSOR AS INTEGER
7850: MOV PARM2(XR),WB LOAD NAME OFFSET
7851: JSR ICBLD GET ICBLK FOR CURSOR VALUE
7852: MOV WB,WA MOVE NAME OFFSET
7853: MOV XR,WB MOVE VALUE TO ASSIGN
7854: JSR ASINP PERFORM ASSIGNMENT
7855: PPM FLPOP FAIL ON ASSIGNMENT FAILURE
7856: MOV (XS)+,WB ELSE RESTORE CURSOR
7857: MOV (XS)+,XR RESTORE NODE POINTER
7858: BRN SUCCP AND SUCCEED MATCHING NULL
7859: EJC
7860: *
7861: * EXPRESSION NODE (P$EXA, INITIAL ENTRY)
7862: *
7863: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
7864: * ALGORITHMS FOR HANDLING EXPRESSION NODES.
7865: *
7866: * PARM1 EXPRESSION POINTER
7867: *
7868: P$EXA ENT BL$P1 P1BLK
7869: JSR EVALP EVALUATE EXPRESSION
7870: PPM FAILP FAIL IF EVALUATION FAILS
7871: BLO WA,=P$AAA,PEXA1 JUMP IF RESULT IS NOT A PATTERN
7872: *
7873: * HERE IF RESULT OF EXPRESSION IS A PATTERN
7874: *
7875: MOV WB,-(XS) STACK DUMMY CURSOR
7876: MOV XR,-(XS) STACK PTR TO P$EXA NODE
7877: MOV PMHBS,-(XS) STACK HISTORY STACK BASE PTR
7878: MOV =NDEXB,-(XS) STACK PTR TO SPECIAL NODE NDEXB
7879: MOV XS,PMHBS STORE NEW STACK BASE POINTER
7880: MOV XL,XR COPY NODE POINTER
7881: BRI (XR) MATCH FIRST NODE IN EXPRESSION PAT
7882: *
7883: * HERE IF RESULT OF EXPRESSION IS NOT A PATTERN
7884: *
7885: PEXA1 BEQ WA,=B$SCL,PEXA2 JUMP IF IT IS ALREADY A STRING
7886: MOV XL,-(XS) ELSE STACK RESULT
7887: MOV XR,XL SAVE NODE POINTER
7888: JSR GTSTG CONVERT RESULT TO STRING
7889: ERR 053,EXPRESSION DOES NOT EVALUATE TO PATTERN
7890: MOV XR,WC COPY STRING POINTER
7891: MOV XL,XR RESTORE NODE POINTER
7892: MOV WC,XL COPY STRING POINTER AGAIN
7893: *
7894: * MERGE HERE WITH STRING POINTER IN XL
7895: *
7896: PEXA2 BZE SCLEN(XL),SUCCP JUST SUCCEED IF NULL STRING
7897: MOV XR,PSAVE SAVE NODE PTR
7898: MOV R$PMS,XR LOAD SUBJECT STRING PTR
7899: PLC XR,WB POINT TO CURRENT CHAR
7900: ADD SCLEN(XL),WB COMPUTE NEW CURSOR POSITION
7901: BGT WB,PMSSL,FAILP FAIL IF PAST END OF STRING
7902: MOV WB,PSAVC SAVE UPDATED CURSOR
7903: MOV SCLEN(XL),WA NUMBER OF CHARS TO COMPARE
7904: PLC XL POINT TO TEST STRING CHARS
7905: CMC FAILP,FAILP COMPARE, FAIL IF UNEQUAL
7906: MOV PSAVE,XR IF ALL MATCHED, RESTORE NODE PTR
7907: MOV PSAVC,WB RESTORE UPDATED CURSOR
7908: BRN SUCCP AND SUCCEED
7909: EJC
7910: *
7911: * EXPRESSION NODE (P$EXB, REMOVE NDEXB ENTRY)
7912: *
7913: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
7914: * ALGORITHMS FOR HANDLING EXPRESSION NODES.
7915: *
7916: * NO PARAMETERS (DUMMY PATTERN)
7917: *
7918: P$EXB ENT ENTRY POINT
7919: MOV WB,PMHBS RESTORE OUTER LEVEL STACK POINTER
7920: BRN FLPOP FAIL AND POP P$EXA NODE PTR
7921: EJC
7922: *
7923: * EXPRESSION NODE (P$EXC, REMOVE NDEXC ENTRY)
7924: *
7925: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
7926: * ALGORITHMS FOR HANDLING EXPRESSION NODES.
7927: *
7928: * NO PARAMETERS (DUMMY PATTERN)
7929: *
7930: P$EXC ENT ENTRY POINT
7931: MOV WB,PMHBS RESTORE INNER STACK BASE POINTER
7932: BRN FAILP AND FAIL INTO EXPR PATTERN ALTERNVS
7933: *
7934: * FAIL
7935: *
7936: * NO PARAMETERS
7937: *
7938: P$FAL ENT BL$P0 P0BLK
7939: BRN FAILP JUST SIGNAL FAILURE
7940: EJC
7941: * FENCE
7942: *
7943: * SEE COMPOUND PATTERNS SECTION FOR THE STRUCTURE AND
7944: * ALGORITHM FOR MATCHING THIS NODE TYPE.
7945: *
7946: * NO PARAMETERS
7947: *
7948: P$FEN ENT BL$P0 P0BLK
7949: MOV WB,-(XS) STACK DUMMY CURSOR
7950: MOV =NDABO,-(XS) STACK PTR TO ABORT NODE
7951: BRN SUCCP AND SUCCEED MATCHING NULL
7952: .IF .CNFN
7953: .ELSE
7954: *
7955: * FENCE (FUNCTION)
7956: *
7957: * SEE COMPOUND PATTERNS COMMENTS AT START OF THIS SECTION
7958: * FOR DETAILS OF SCHEME
7959: *
7960: * NO PARAMETERS
7961: *
7962: P$FNA ENT BL$P0 P0BLK
7963: MOV PMHBS,-(XS) STACK CURRENT HISTORY STACK BASE
7964: MOV =NDFNB,-(XS) STACK INDIR PTR TO P$FNB (FAILURE)
7965: MOV XS,PMHBS BEGIN NEW HISTORY STACK
7966: BRN SUCCP SUCCEED
7967: *
7968: * FENCE (FUNCTION) (RESET HISTORY STACK AND FAIL)
7969: *
7970: * NO PARAMETERS (DUMMY PATTERN)
7971: *
7972: P$FNB ENT BL$P0 P0BLK
7973: MOV WB,PMHBS RESTORE OUTER PMHBS STACK BASE
7974: BRN FAILP ...AND FAIL
7975: *
7976: * FENCE (FUNCTION) (MAKE FENCE TRAP ENTRY ON STACK)
7977: *
7978: * NO PARAMETERS (DUMMY PATTERN)
7979: *
7980: P$FNC ENT BL$P0 P0BLK
7981: MOV PMHBS,XT GET INNER STACK BASE PTR
7982: MOV NUM01(XT),PMHBS RESTORE OUTER STACK BASE
7983: BEQ XT,XS,PFNC1 OPTIMIZE IF NO ALTERNATIVES
7984: MOV XT,-(XS) ELSE STACK INNER STACK BASE
7985: MOV =NDFND,-(XS) STACK PTR TO NDFND
7986: BRN SUCCP SUCCEED
7987: *
7988: * HERE WHEN FENCE FUNCTION LEFT NOTHING ON THE STACK
7989: *
7990: PFNC1 ADD *NUM02,XS POP OFF P$FNB ENTRY
7991: BRN SUCCP SUCCEED
7992: *
7993: * FENCE (FUNCTION) (SKIP PAST ALTERNATIVES ON FAILURE)
7994: *
7995: * NO PARAMETERS (DUMMY PATTERN)
7996: *
7997: P$FND ENT BL$P0 P0BLK
7998: MOV WB,XS POP STACK TO FENCE() HISTORY BASE
7999: BRN FLPOP POP BASE ENTRY AND FAIL
8000: .FI
8001: EJC
8002: *
8003: * IMMEDIATE ASSIGNMENT (INITIAL ENTRY, SAVE CURRENT CURSOR)
8004: *
8005: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
8006: * STRUCTURE AND ALGORITHM FOR MATCHING THIS NODE TYPE.
8007: *
8008: * NO PARAMETERS
8009: *
8010: P$IMA ENT BL$P0 P0BLK
8011: MOV WB,-(XS) STACK CURSOR
8012: MOV XR,-(XS) STACK DUMMY NODE POINTER
8013: MOV PMHBS,-(XS) STACK OLD STACK BASE POINTER
8014: MOV =NDIMB,-(XS) STACK PTR TO SPECIAL NODE NDIMB
8015: MOV XS,PMHBS STORE NEW STACK BASE POINTER
8016: BRN SUCCP AND SUCCEED
8017: *
8018: * IMMEDIATE ASSIGNMENT (REMOVE CURSOR MARK ENTRY)
8019: *
8020: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
8021: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE.
8022: *
8023: * NO PARAMETERS (DUMMY PATTERN)
8024: *
8025: P$IMB ENT ENTRY POINT
8026: MOV WB,PMHBS RESTORE HISTORY STACK BASE PTR
8027: BRN FLPOP FAIL AND POP DUMMY NODE PTR
8028: EJC
8029: *
8030: * IMMEDIATE ASSIGNMENT (PERFORM ACTUAL ASSIGNMENT)
8031: *
8032: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
8033: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE.
8034: *
8035: * PARM1 NAME BASE OF VARIABLE
8036: * PARM2 NAME OFFSET OF VARIABLE
8037: *
8038: P$IMC ENT BL$P2 P2BLK
8039: MOV PMHBS,XT LOAD POINTER TO P$IMB ENTRY
8040: MOV WB,WA COPY FINAL CURSOR
8041: MOV 3(XT),WB LOAD INITIAL CURSOR
8042: MOV 1(XT),PMHBS RESTORE OUTER STACK BASE POINTER
8043: BEQ XT,XS,PIMC1 JUMP IF NO HISTORY STACK ENTRIES
8044: MOV XT,-(XS) ELSE SAVE INNER PMHBS POINTER
8045: MOV =NDIMD,-(XS) AND A PTR TO SPECIAL NODE NDIMD
8046: BRN PIMC2 MERGE
8047: *
8048: * HERE IF NO ENTRIES MADE ON HISTORY STACK
8049: *
8050: PIMC1 ADD *NUM04,XS REMOVE NDIMB ENTRY AND CURSOR
8051: *
8052: * MERGE HERE TO PERFORM ASSIGNMENT
8053: *
8054: PIMC2 MOV WA,-(XS) SAVE CURRENT (FINAL) CURSOR
8055: MOV XR,-(XS) SAVE CURRENT NODE POINTER
8056: MOV R$PMS,XL POINT TO SUBJECT STRING
8057: SUB WB,WA COMPUTE SUBSTRING LENGTH
8058: JSR SBSTR BUILD SUBSTRING
8059: MOV XR,WB MOVE RESULT
8060: MOV (XS),XR RELOAD NODE POINTER
8061: MOV PARM1(XR),XL LOAD NAME BASE
8062: MOV PARM2(XR),WA LOAD NAME OFFSET
8063: JSR ASINP PERFORM ASSIGNMENT
8064: PPM FLPOP FAIL IF ASSIGNMENT FAILS
8065: MOV (XS)+,XR ELSE RESTORE NODE POINTER
8066: MOV (XS)+,WB RESTORE CURSOR
8067: BRN SUCCP AND SUCCEED
8068: *
8069: * IMMEDIATE ASSIGNMENT (REMOVE NDIMD ENTRY ON FAILURE)
8070: *
8071: * SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
8072: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE.
8073: *
8074: * NO PARAMETERS (DUMMY PATTERN)
8075: *
8076: P$IMD ENT ENTRY POINT
8077: MOV WB,PMHBS RESTORE INNER STACK BASE POINTER
8078: BRN FAILP AND FAIL
8079: EJC
8080: *
8081: * LEN (INTEGER ARGUMENT)
8082: *
8083: * PARM1 INTEGER ARGUMENT
8084: *
8085: P$LEN ENT BL$P1 P1BLK
8086: ADD PARM1(XR),WB PUSH CURSOR INDICATED AMOUNT
8087: BLE WB,PMSSL,SUCCP SUCCEED IF NOT OFF END
8088: BRN FAILP ELSE FAIL
8089: *
8090: * LEN (EXPRESSION ARGUMENT)
8091: *
8092: * PARM1 EXPRESSION POINTER
8093: *
8094: P$LND ENT BL$P1 P1BLK
8095: JSR EVALI EVALUATE INTEGER ARGUMENT
8096: ERR 054,LEN EVALUATED ARGUMENT IS NOT INTEGER
8097: ERR 055,LEN EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
8098: PPM FAILP FAIL IF EVALUATION FAILS
8099: ADD PARM1(XR),WB PUSH CURSOR INDICATED AMOUNT
8100: BLE WB,PMSSL,SUCCP SUCCEED IF NOT OFF END
8101: BRN FAILP ELSE FAIL
8102: EJC
8103: *
8104: * NOTANY (EXPRESSION ARGUMENT)
8105: *
8106: * PARM1 EXPRESSION POINTER
8107: *
8108: P$NAD ENT BL$P1 P1BLK
8109: MOV =P$NAY,WA PCODE FOR NEW NODE
8110: JSR EVALS EVALUATE STRING ARGUMENT
8111: ERR 056,NOTANY EVALUATED ARGUMENT IS NOT STRING
8112: PPM FAILP FAIL IF EVALUATION FAILS
8113: BRI XL MERGE WITH MULTI-CHAR CASE IF OK
8114: EJC
8115: *
8116: * NOTANY (ONE CHARACTER ARGUMENT)
8117: *
8118: * PARM1 CHARACTER ARGUMENT
8119: *
8120: P$NAS ENT BL$P1 ENTRY POINT
8121: BEQ WB,PMSSL,FAILP FAIL IF NO CHARS LEFT
8122: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
8123: PLC XL,WB POINT TO CURRENT CHARACTER IN STRIN
8124: LCH WA,(XL) LOAD CURRENT CHARACTER
8125: BEQ WA,PARM1(XR),FAILP FAIL IF MATCH
8126: ICV WB ELSE BUMP CURSOR
8127: BRN SUCCP AND SUCCEED
8128: EJC
8129: *
8130: * NOTANY (MULTI-CHARACTER STRING ARGUMENT)
8131: * EXPRESSION ARGUMENT CASE MERGES
8132: *
8133: * PARM1 POINTER TO CTBLK
8134: * PARM2 BIT MASK TO SELECT BIT COLUMN
8135: *
8136: P$NAY ENT BL$P2 P2BLK
8137: BEQ WB,PMSSL,FAILP FAIL IF NO CHARACTERS LEFT
8138: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
8139: PLC XL,WB POINT TO CURRENT CHARACTER
8140: LCH WA,(XL) LOAD CURRENT CHARACTER
8141: WTB WA CONVERT TO BAU OFFSET
8142: MOV PARM1(XR),XL LOAD POINTER TO CTBLK
8143: ADD WA,XL POINT TO ENTRY IN CTBLK
8144: MOV CTCHS(XL),WA LOAD ENTRY FROM CTBLK
8145: ANB PARM2(XR),WA AND WITH SELECTED BIT
8146: NZB WA,FAILP FAIL IF CHARACTER IS MATCHED
8147: ICV WB ELSE BUMP CURSOR
8148: BRN SUCCP AND SUCCEED
8149: EJC
8150: *
8151: * END OF PATTERN MATCH
8152: *
8153: * THIS ROUTINE IS ENTERED ON SUCCESSFUL COMPLETION.
8154: * SEE DESCRIPTION OF EXPRESSION PATTERNS IN COMPOUND
8155: * PATTERN SECTION FOR HANDLING OF RECURSION IN MATCHING.
8156: *
8157: * NO PARAMETERS (DUMMY PATTERN)
8158: *
8159: P$NTH ENT ENTRY POINT
8160: MOV PMHBS,XT LOAD POINTER TO BASE OF STACK
8161: MOV 1(XT),WA LOAD SAVED PMHBS (OR PATTERN TYPE)
8162: BLE WA,=NUM02,PNTH2 JUMP IF OUTER LEVEL (PATTERN TYPE)
8163: *
8164: * HERE WE ARE AT THE END OF MATCHING AN EXPRESSION PATTERN
8165: *
8166: MOV WA,PMHBS RESTORE OUTER STACK BASE POINTER
8167: MOV 2(XT),XR RESTORE POINTER TO P$EXA NODE
8168: BEQ XT,XS,PNTH1 JUMP IF NO HISTORY STACK ENTRIES
8169: MOV XT,-(XS) ELSE STACK INNER STACK BASE PTR
8170: MOV =NDEXC,-(XS) STACK PTR TO SPECIAL NODE NDEXC
8171: BRN SUCCP AND SUCCEED
8172: *
8173: * HERE IF NO HISTORY STACK ENTRIES DURING PATTERN
8174: *
8175: PNTH1 ADD *NUM04,XS REMOVE P$EXB ENTRY AND NODE PTR
8176: BRN SUCCP AND SUCCEED
8177: *
8178: * HERE IF END OF MATCH AT OUTER LEVEL
8179: *
8180: PNTH2 MOV WB,PMSSL SAVE FINAL CURSOR IN SAFE PLACE
8181: BZE PMDFL,PNTH6 JUMP IF NO PATTERN ASSIGNMENTS
8182: EJC
8183: *
8184: * END OF PATTERN MATCH (CONTINUED)
8185: *
8186: * NOW WE MUST PERFORM PATTERN ASSIGNMENTS. THIS IS DONE BY
8187: * SCANNING THE HISTORY STACK FOR MATCHING NDPAB-NDPAD PAIRS
8188: *
8189: PNTH3 DCA XT POINT PAST CURSOR ENTRY
8190: MOV -(XT),WA LOAD NODE POINTER
8191: BEQ WA,=NDPAD,PNTH4 JUMP IF NDPAD ENTRY
8192: BNE WA,=NDPAB,PNTH5 JUMP IF NOT NDPAB ENTRY
8193: *
8194: * HERE FOR NDPAB ENTRY, STACK INITIAL CURSOR
8195: * NOTE THAT THERE MUST BE MORE ENTRIES ON THE STACK.
8196: *
8197: MOV 1(XT),-(XS) STACK INITIAL CURSOR
8198: CHK CHECK FOR STACK OVERFLOW
8199: BRN PNTH3 LOOP BACK IF OK
8200: *
8201: * HERE FOR NDPAD ENTRY. THE STARTING CURSOR FROM THE
8202: * MATCHING NDPAD ENTRY IS NOW THE TOP STACK ENTRY.
8203: *
8204: PNTH4 MOV 1(XT),WA LOAD FINAL CURSOR
8205: MOV (XS),WB LOAD INITIAL CURSOR FROM STACK
8206: MOV XT,(XS) SAVE HISTORY STACK SCAN PTR
8207: SUB WB,WA COMPUTE LENGTH OF STRING
8208: *
8209: * BUILD SUBSTRING AND PERFORM ASSIGNMENT
8210: *
8211: MOV R$PMS,XL POINT TO SUBJECT STRING
8212: JSR SBSTR CONSTRUCT SUBSTRING
8213: MOV XR,WB COPY SUBSTRING POINTER
8214: MOV (XS),XT RELOAD HISTORY STACK SCAN PTR
8215: MOV 2(XT),XL LOAD POINTER TO P$PAC NODE WITH NAM
8216: MOV PARM2(XL),WA LOAD NAME OFFSET
8217: MOV PARM1(XL),XL LOAD NAME BASE
8218: JSR ASINP PERFORM ASSIGNMENT
8219: PPM EXFAL MATCH FAILS IF NAME EVAL FAILS
8220: MOV (XS)+,XT ELSE RESTORE HISTORY STACK PTR
8221: EJC
8222: *
8223: * END OF PATTERN MATCH (CONTINUED)
8224: *
8225: * HERE CHECK FOR END OF ENTRIES
8226: *
8227: PNTH5 BNE XT,XS,PNTH3 LOOP IF MORE ENTRIES TO SCAN
8228: *
8229: * HERE AFTER DEALING WITH PATTERN ASSIGNMENTS
8230: *
8231: PNTH6 MOV PMHBS,XS WIPE OUT HISTORY STACK
8232: MOV (XS)+,WB LOAD INITIAL CURSOR
8233: MOV (XS)+,WC LOAD MATCH TYPE CODE
8234: MOV PMSSL,WA LOAD FINAL CURSOR VALUE
8235: MOV R$PMS,XL POINT TO SUBJECT STRING
8236: ZER R$PMS CLEAR SUBJECT STRING PTR FOR GBCOL
8237: BZE WC,PNTH7 JUMP IF CALL BY NAME
8238: ZER R$PMB CLEAR POSSIBLE BCBLK PTR FOR GBCOL
8239: BEQ WC,=NUM02,EXITS EXIT IF STATEMENT LEVEL CALL
8240: *
8241: * HERE WE HAVE A CALL BY VALUE, BUILD SUBSTRING
8242: *
8243: SUB WB,WA COMPUTE LENGTH OF STRING
8244: JSR SBSTR BUILD SUBSTRING
8245: BRN EXIXR AND EXIT WITH SUBSTRING VALUE
8246: *
8247: * HERE FOR CALL BY NAME, MAKE STACK ENTRIES FOR O$RPL
8248: *
8249: PNTH7 MOV WB,-(XS) STACK INITIAL CURSOR
8250: MOV WA,-(XS) STACK FINAL CURSOR
8251: .IF .CNBF
8252: MOV XL,-(XS) STACK SUBJECT STRING POINTER
8253: .ELSE
8254: BZE R$PMB,PNTH8 SKIP IF SUBJECT NOT BUFFER
8255: MOV R$PMB,XL ELSE GET PTR TO BCBLK INSTEAD
8256: ZER R$PMB CLEAR BCBLK PTR FOR GBCOL
8257: *
8258: * HERE WITH XL POINTING TO SCBLK OR BCBLK
8259: *
8260: PNTH8 MOV XL,-(XS) STACK SUBJECT POINTER
8261: .FI
8262: BRN EXITS EXIT WITH SPECIAL ENTRY ON STACK
8263: EJC
8264: *
8265: * POS (INTEGER ARGUMENT)
8266: *
8267: * PARM1 INTEGER ARGUMENT
8268: *
8269: P$POS ENT BL$P1 P1BLK
8270: BEQ WB,PARM1(XR),SUCCP SUCCEED IF AT RIGHT LOCATION
8271: BRN FAILP ELSE FAIL
8272: *
8273: * POS (EXPRESSION ARGUMENT)
8274: *
8275: * PARM1 EXPRESSION POINTER
8276: *
8277: P$PSD ENT BL$P1 P1BLK
8278: JSR EVALI EVALUATE INTEGER ARGUMENT
8279: ERR 057,POS EVALUATED ARGUMENT IS NOT INTEGER
8280: ERR 058,POS EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
8281: PPM FAILP FAIL IF EVALUATION FAILS
8282: BEQ WB,PARM1(XR),SUCCP SUCCEED IF AT RIGHT LOCATION
8283: BRN FAILP ELSE FAIL
8284: EJC
8285: *
8286: * PATTERN ASSIGNMENT (INITIAL ENTRY, SAVE CURSOR)
8287: *
8288: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
8289: * ALGORITHMS FOR MATCHING THIS NODE TYPE.
8290: *
8291: * NO PARAMETERS
8292: *
8293: P$PAA ENT BL$P0 P0BLK
8294: MOV WB,-(XS) STACK INITIAL CURSOR
8295: MOV =NDPAB,-(XS) STACK PTR TO NDPAB SPECIAL NODE
8296: BRN SUCCP AND SUCCEED MATCHING NULL
8297: *
8298: * PATTERN ASSIGNMENT (REMOVE SAVED CURSOR)
8299: *
8300: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
8301: * ALGORITHMS FOR MATCHING THIS NODE TYPE.
8302: *
8303: * NO PARAMETERS (DUMMY PATTERN)
8304: *
8305: P$PAB ENT ENTRY POINT
8306: BRN FAILP JUST FAIL (ENTRY IS ALREADY POPPED)
8307: *
8308: * PATTERN ASSIGNMENT (END OF MATCH, MAKE ASSIGN ENTRY)
8309: *
8310: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
8311: * ALGORITHMS FOR MATCHING THIS NODE TYPE.
8312: *
8313: * PARM1 NAME BASE OF VARIABLE
8314: * PARM2 NAME OFFSET OF VARIABLE
8315: *
8316: P$PAC ENT BL$P2 P2BLK
8317: MOV WB,-(XS) STACK DUMMY CURSOR VALUE
8318: MOV XR,-(XS) STACK POINTER TO P$PAC NODE
8319: MOV WB,-(XS) STACK FINAL CURSOR
8320: MOV =NDPAD,-(XS) STACK PTR TO SPECIAL NDPAD NODE
8321: MNZ PMDFL SET DOT FLAG NON-ZERO
8322: BRN SUCCP AND SUCCEED
8323: *
8324: * PATTERN ASSIGNMENT (REMOVE ASSIGN ENTRY)
8325: *
8326: * SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
8327: * ALGORITHMS FOR MATCHING THIS NODE TYPE.
8328: *
8329: * NO PARAMETERS (DUMMY NODE)
8330: *
8331: P$PAD ENT ENTRY POINT
8332: BRN FLPOP FAIL AND REMOVE P$PAC NODE
8333: EJC
8334: *
8335: * REM
8336: *
8337: * NO PARAMETERS
8338: *
8339: P$REM ENT BL$P0 P0BLK
8340: MOV PMSSL,WB POINT CURSOR TO END OF STRING
8341: BRN SUCCP AND SUCCEED
8342: *
8343: * RPOS (EXPRESSION ARGUMENT)
8344: *
8345: * PARM1 EXPRESSION POINTER
8346: *
8347: P$RPD ENT BL$P1 P1BLK
8348: JSR EVALI EVALUATE INTEGER ARGUMENT
8349: ERR 059,RPOS EVALUATED ARGUMENT IS NOT INTEGER
8350: ERR 060,RPOS EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
8351: PPM FAILP FAIL IF EVALUATION FAILS
8352: MOV =P$RPS,XL CONTINUATION ROUTINE
8353: BRI XL ENTER ROUTINE
8354: *
8355: * RPOS (INTEGER ARGUMENT)
8356: * EXPRESSION ARGUMENT CASE MERGES
8357: *
8358: * PARM1 INTEGER ARGUMENT
8359: *
8360: P$RPS ENT BL$P1 P1BLK
8361: MOV PMSSL,WC GET LENGTH OF STRING
8362: SUB WB,WC GET NUMBER OF CHARACTERS REMAINING
8363: BEQ WC,PARM1(XR),SUCCP SUCCEED IF AT RIGHT LOCATION
8364: BRN FAILP ELSE FAIL
8365: EJC
8366: *
8367: * RTAB (INTEGER ARGUMENT)
8368: * EXPRESSION ARGUMENT CASE MERGES
8369: *
8370: * PARM1 INTEGER ARGUMENT
8371: *
8372: P$RTB ENT BL$P1 P1BLK
8373: MOV WB,WC SAVE INITIAL CURSOR
8374: MOV PMSSL,WB POINT TO END OF STRING
8375: BLT WB,PARM1(XR),FAILP FAIL IF STRING NOT LONG ENOUGH
8376: SUB PARM1(XR),WB ELSE SET NEW CURSOR
8377: BGE WB,WC,SUCCP AND SUCCEED IF NOT TOO FAR ALREADY
8378: BRN FAILP IN WHICH CASE, FAIL
8379: *
8380: * RTAB (EXPRESSION ARGUMENT)
8381: *
8382: * PARM1 EXPRESSION POINTER
8383: *
8384: P$RTD ENT BL$P1 P1BLK
8385: JSR EVALI EVALUATE INTEGER ARGUMENT
8386: ERR 061,RTAB EVALUATED ARGUMENT IS NOT INTEGER
8387: ERR 062,RTAB EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
8388: PPM FAILP FAIL IF EVALUATION FAILS
8389: MOV =P$RTB,XL CONTINUATION ROUTINE
8390: BRI XL ENTER ROUTINE
8391: EJC
8392: *
8393: * SPAN (EXPRESSION ARGUMENT)
8394: *
8395: * PARM1 EXPRESSION POINTER
8396: *
8397: P$SPD ENT BL$P1 P1BLK
8398: MOV =P$SPN,WA PCODE FOR NEW NODE
8399: JSR EVALS EVALUATE STRING ARGUMENT
8400: ERR 063,SPAN EVALUATED ARGUMENT IS NOT STRING
8401: PPM FAILP FAIL IF EVALUATION FAILS
8402: BRI XL MERGE WITH MULTI-CHAR CASE IF OK
8403: *
8404: * SPAN (MULTI-CHARACTER ARGUMENT CASE)
8405: * EXPRESSION ARGUMENT CASE MERGES
8406: *
8407: * PARM1 POINTER TO CTBLK
8408: * PARM2 BIT MASK TO SELECT BIT COLUMN
8409: *
8410: P$SPN ENT BL$P2 P2BLK
8411: MOV PMSSL,WC COPY SUBJECT STRING LENGTH
8412: SUB WB,WC CALCULATE NUMBER OF CHARACTERS LEFT
8413: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT
8414: MOV R$PMS,XL POINT TO SUBJECT STRING
8415: PLC XL,WB POINT TO CURRENT CHARACTER
8416: MOV WB,PSAVC SAVE INITIAL CURSOR
8417: MOV XR,PSAVE SAVE NODE POINTER
8418: LCT WC,WC SET COUNTER FOR CHARS LEFT
8419: *
8420: * LOOP TO SCAN MATCHING CHARACTERS
8421: *
8422: PSPN2 LCH WA,(XL)+ LOAD NEXT CHARACTER, BUMP POINTER
8423: WTB WA CONVERT TO BAU OFFSET
8424: MOV PARM1(XR),XR POINT TO CTBLK
8425: ADD WA,XR POINT TO CTBLK ENTRY
8426: MOV CTCHS(XR),WA LOAD CTBLK ENTRY
8427: MOV PSAVE,XR RESTORE NODE POINTER
8428: ANB PARM2(XR),WA AND WITH SELECTED BIT
8429: ZRB WA,PSPN3 JUMP IF NO MATCH
8430: ICV WB ELSE PUSH CURSOR
8431: BCT WC,PSPN2 LOOP BACK UNLESS END OF STRING
8432: *
8433: * HERE AFTER SCANNING MATCHING CHARACTERS
8434: *
8435: PSPN3 BNE WB,PSAVC,SUCCP SUCCEED IF CHARS MATCHED
8436: BRN FAILP ELSE FAIL IF NULL STRING MATCHED
8437: EJC
8438: *
8439: * SPAN (ONE CHARACTER ARGUMENT)
8440: *
8441: * PARM1 CHARACTER ARGUMENT
8442: *
8443: P$SPS ENT BL$P1 P1BLK
8444: MOV PMSSL,WC GET SUBJECT STRING LENGTH
8445: SUB WB,WC CALCULATE NUMBER OF CHARACTERS LEFT
8446: BZE WC,FAILP FAIL IF NO CHARACTERS LEFT
8447: MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
8448: PLC XL,WB POINT TO CURRENT CHARACTER
8449: MOV WB,PSAVC SAVE INITIAL CURSOR
8450: LCT WC,WC SET COUNTER FOR CHARACTERS LEFT
8451: *
8452: * LOOP TO SCAN MATCHING CHARACTERS
8453: *
8454: PSPS1 LCH WA,(XL)+ LOAD NEXT CHARACTER, BUMP POINTER
8455: BNE WA,PARM1(XR),PSPS2 JUMP IF NO MATCH
8456: ICV WB ELSE PUSH CURSOR
8457: BCT WC,PSPS1 AND LOOP UNLESS END OF STRING
8458: *
8459: * HERE AFTER SCANNING MATCHING CHARACTERS
8460: *
8461: PSPS2 BNE WB,PSAVC,SUCCP SUCCEED IF CHARS MATCHED
8462: BRN FAILP FAIL IF NULL STRING MATCHED
8463: *
8464: * MULTI-CHARACTER STRING (MERGE FROM P$EXA)
8465: *
8466: * NOTE THAT ONE CHARACTER STRINGS USE THE CIRCUIT FOR
8467: * ONE CHARACTER ANY ARGUMENTS (P$AN1).
8468: *
8469: * PARM1 POINTER TO SCBLK FOR STRING ARG
8470: *
8471: P$STR ENT BL$P1 P1BLK
8472: MOV PARM1(XR),XL GET POINTER TO STRING
8473: MOV XR,PSAVE SAVE NODE POINTER
8474: MOV R$PMS,XR LOAD SUBJECT STRING POINTER
8475: PLC XR,WB POINT TO CURRENT CHARACTER
8476: ADD SCLEN(XL),WB COMPUTE NEW CURSOR POSITION
8477: BGT WB,PMSSL,FAILP FAIL IF PAST END OF STRING
8478: MOV WB,PSAVC SAVE UPDATED CURSOR
8479: MOV SCLEN(XL),WA GET NUMBER OF CHARS TO COMPARE
8480: PLC XL POINT TO CHARS OF TEST STRING
8481: CMC FAILP,FAILP COMPARE, FAIL IF NOT EQUAL
8482: MOV PSAVE,XR IF ALL MATCHED, RESTORE NODE PTR
8483: MOV PSAVC,WB RESTORE UPDATED CURSOR
8484: BRN SUCCP AND SUCCEED
8485: EJC
8486: *
8487: * SUCCEED
8488: *
8489: * SEE SECTION ON COMPOUND PATTERNS FOR DETAILS OF THE
8490: * STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE
8491: *
8492: * NO PARAMETERS
8493: *
8494: P$SUC ENT BL$P0 P0BLK
8495: MOV WB,-(XS) STACK CURSOR
8496: MOV XR,-(XS) STACK POINTER TO THIS NODE
8497: BRN SUCCP SUCCEED MATCHING NULL
8498: EJC
8499: *
8500: * TAB (INTEGER ARGUMENT)
8501: * EXPRESSION CASE MERGES
8502: *
8503: * PARM1 INTEGER ARGUMENT
8504: *
8505: P$TAB ENT BL$P1 P1BLK
8506: BGT WB,PARM1(XR),FAILP FAIL IF TOO FAR ALREADY
8507: MOV PARM1(XR),WB ELSE SET NEW CURSOR POSITION
8508: BLE WB,PMSSL,SUCCP SUCCEED IF NOT OFF END
8509: BRN FAILP ELSE FAIL
8510: *
8511: * TAB (EXPRESSION ARGUMENT)
8512: *
8513: * PARM1 EXPRESSION POINTER
8514: *
8515: P$TBD ENT BL$P1 P1BLK
8516: JSR EVALI EVALUATE INTEGER ARGUMENT
8517: ERR 064,TAB EVALUATED ARGUMENT IS NOT INTEGER
8518: ERR 065,TAB EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
8519: PPM FAILP FAIL IF EVALUATION FAILS
8520: MOV =P$TAB,XL CONTINUATION ROUTINE
8521: BRI XL ENTER ROUTINE
8522: *
8523: * ANCHOR MOVEMENT
8524: *
8525: * NO PARAMETERS (DUMMY NODE)
8526: *
8527: P$UNA ENT ENTRY POINT
8528: MOV WB,XR COPY INITIAL PATTERN NODE POINTER
8529: MOV (XS),WB GET INITIAL CURSOR
8530: BEQ WB,PMSSL,EXFAL MATCH FAILS IF AT END OF STRING
8531: ICV WB ELSE INCREMENT CURSOR
8532: MOV WB,(XS) STORE INCREMENTED CURSOR
8533: MOV XR,-(XS) RESTACK INITIAL NODE PTR
8534: MOV =NDUNA,-(XS) RESTACK UNANCHORED NODE
8535: BRI (XR) REMATCH FIRST NODE
8536: *
8537: * END OF PATTERN MATCH ROUTINES
8538: *
8539: * THE FOLLOWING ENTRY POINT MARKS THE END OF THE PATTERN
8540: * MATCHING ROUTINES AND ALSO THE END OF THE ENTRY POINTS
8541: * REFERENCED FROM THE FIRST WORD OF BLOCKS IN DYNAMIC STORE
8542: *
8543: P$YYY ENT BL$$I MARK LAST ENTRY IN PATTERN SECTION
8544: TTL S P I T B O L -- PREDEFINED SNOBOL4 FUNCTIONS
8545: *
8546: * THE FOLLOWING SECTION CONTAINS CODING FOR FUNCTIONS
8547: * WHICH ARE PREDEFINED AND AVAILABLE AT THE SNOBOL LEVEL.
8548: *
8549: * THESE ROUTINES RECEIVE CONTROL DIRECTLY FROM THE CODE OR
8550: * INDIRECTLY THROUGH THE O$FNC, O$FNS OR CFUNC ROUTINES.
8551: * IN BOTH CASES THE CONDITIONS ON ENTRY ARE AS FOLLOWS
8552: *
8553: * THE ARGUMENTS ARE ON THE STACK. THE NUMBER OF ARGUMENTS
8554: * HAS BEEN ADJUSTED TO CORRESPOND TO THE SVBLK SVNAR FIELD.
8555: *
8556: * IN CERTAIN FUNCTIONS THE DIRECT CALL IS NOT PERMITTED
8557: * AND IN THESE INSTANCES WE ALSO HAVE.
8558: *
8559: * (WA) ACTUAL NUMBER OF ARGUMENTS IN CALL
8560: *
8561: * CONTROL RETURNS BY PLACING THE FUNCTION RESULT VALUE ON
8562: * ON THE STACK AND CONTINUING EXECUTION WITH THE NEXT
8563: * WORD FROM THE GENERATED CODE.
8564: *
8565: * THE NAMES OF THE ENTRY POINTS OF THESE FUNCTIONS ARE OF
8566: * THE FORM S$XXX WHERE XXX IS THE THREE LETTER CODE FOR
8567: * THE SYSTEM VARIABLE NAME. THE FUNCTIONS ARE IN ORDER
8568: * ALPHABETICALLY BY THEIR ENTRY NAMES.
8569: EJC
8570: *
8571: * ANY
8572: *
8573: S$ANY ENT ENTRY POINT
8574: MOV =P$ANS,WB SET PCODE FOR SINGLE CHAR CASE
8575: MOV =P$ANY,XL PCODE FOR MULTI-CHAR CASE
8576: MOV =P$AYD,WC PCODE FOR EXPRESSION CASE
8577: JSR PATST CALL COMMON ROUTINE TO BUILD NODE
8578: ERR 066,ANY ARGUMENT IS NOT STRING OR EXPRESSION
8579: BRN EXIXR JUMP FOR NEXT CODE WORD
8580: .IF .CNBF
8581: .ELSE
8582: EJC
8583: *
8584: * APPEND
8585: *
8586: S$APN ENT ENTRY POINT
8587: MOV (XS)+,XL GET APPEND ARGUMENT
8588: MOV (XS)+,XR GET BCBLK
8589: BEQ (XR),=B$BCT,SAPN1 OK IF FIRST ARG IS BCBLK
8590: ERB 067,APPEND FIRST ARGUMENT IS NOT BUFFER
8591: *
8592: * HERE TO DO THE APPEND
8593: *
8594: SAPN1 MOV BCLEN(XR),WA OFFSET TO BUFFER END
8595: ZER WB NO CHARS TO BE REPLACED
8596: JSR INSBF DO THE APPEND
8597: ERR 068,APPEND SECOND ARGUMENT IS NOT STRING
8598: PPM EXFAL NO ROOM - FAIL
8599: BRN EXNUL EXIT WITH NULL RESULT
8600: .FI
8601: EJC
8602: *
8603: * APPLY
8604: *
8605: * APPLY DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT
8606: * WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED.
8607: *
8608: S$APP ENT ENTRY POINT
8609: BZE WA,SAPP3 JUMP IF NO ARGUMENTS
8610: DCV WA ELSE GET APPLIED FUNC ARG COUNT
8611: MOV WA,WB COPY
8612: WTB WB CONVERT TO BAUS
8613: MOV XS,XT COPY STACK POINTER
8614: ADD WB,XT POINT TO FUNCTION ARGUMENT ON STACK
8615: MOV (XT),XR LOAD FUNCTION PTR (APPLY 1ST ARG)
8616: BZE WA,SAPP2 JUMP IF NO ARGS FOR APPLIED FUNC
8617: LCT WB,WA ELSE SET COUNTER FOR LOOP
8618: *
8619: * LOOP TO MOVE ARGUMENTS UP ON STACK
8620: *
8621: SAPP1 DCA XT POINT TO NEXT ARGUMENT
8622: MOV (XT),1(XT) MOVE ARGUMENT UP
8623: BCT WB,SAPP1 LOOP TILL ALL MOVED
8624: *
8625: * MERGE HERE TO CALL FUNCTION (WA = NUMBER OF ARGUMENTS)
8626: *
8627: SAPP2 ICA XS ADJUST STACK PTR FOR APPLY 1ST ARG
8628: JSR GTNVR GET VARIABLE BLOCK ADDR FOR FUNC
8629: PPM SAPP3 JUMP IF NOT NATURAL VARIABLE
8630: MOV VRFNC(XR),XL ELSE POINT TO FUNCTION BLOCK
8631: BRN CFUNC GO CALL APPLIED FUNCTION
8632: *
8633: * HERE FOR INVALID FIRST ARGUMENT
8634: *
8635: SAPP3 ERB 069,APPLY FIRST ARG IS NOT NATURAL VARIABLE NAME
8636: EJC
8637: *
8638: * ARBNO
8639: *
8640: * ARBNO BUILDS A COMPOUND PATTERN. SEE DESCRIPTION AT
8641: * START OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED.
8642: *
8643: S$ABN ENT ENTRY POINT
8644: ZER XR SET PARM1 = 0 FOR THE MOMENT
8645: MOV =P$ALT,WB SET PCODE FOR ALTERNATIVE NODE
8646: JSR PBILD BUILD ALTERNATIVE NODE
8647: MOV XR,XL SAVE PTR TO ALTERNATIVE PATTERN
8648: MOV =P$ABC,WB PCODE FOR P$ABC
8649: ZER XR P0BLK
8650: JSR PBILD BUILD P$ABC NODE
8651: MOV XL,PTHEN(XR) PUT ALTERNATIVE NODE AS SUCCESSOR
8652: MOV XL,WA REMEMBER ALTERNATIVE NODE POINTER
8653: MOV XR,XL COPY P$ABC NODE PTR
8654: MOV (XS),XR LOAD ARBNO ARGUMENT
8655: MOV WA,(XS) STACK ALTERNATIVE NODE POINTER
8656: JSR GTPAT GET ARBNO ARGUMENT AS PATTERN
8657: ERR 070,ARBNO ARGUMENT IS NOT PATTERN
8658: JSR PCONC CONCAT ARG WITH P$ABC NODE
8659: MOV XR,XL REMEMBER PTR TO CONCD PATTERNS
8660: MOV =P$ABA,WB PCODE FOR P$ABA
8661: ZER XR P0BLK
8662: JSR PBILD BUILD P$ABA NODE
8663: MOV XL,PTHEN(XR) CONCATENATE NODES
8664: MOV (XS),XL RECALL PTR TO ALTERNATIVE NODE
8665: MOV XR,PARM1(XL) POINT ALTERNATIVE BACK TO ARGUMENT
8666: BRN EXITS JUMP FOR NEXT CODE WORD
8667: EJC
8668: *
8669: * ARG
8670: *
8671: S$ARG ENT ENTRY POINT
8672: JSR GTSMI GET SECOND ARG AS SMALL INTEGER
8673: ERR 253,ARG SECOND ARGUMENT IS NOT INTEGER
8674: PPM EXFAL FAIL IF OUT OF RANGE OR NEGATIVE
8675: MOV XR,WA SAVE ARGUMENT NUMBER
8676: MOV (XS)+,XR LOAD FIRST ARGUMENT
8677: JSR GTNVR LOCATE VRBLK
8678: PPM SARG1 JUMP IF NOT NATURAL VARIABLE
8679: MOV VRFNC(XR),XR ELSE LOAD FUNCTION BLOCK POINTER
8680: BNE (XR),=B$PFC,SARG1 JUMP IF NOT PROGRAM DEFINED
8681: BZE WA,EXFAL FAIL IF ARG NUMBER IS ZERO
8682: BGT WA,FARGS(XR),EXFAL FAIL IF ARG NUMBER IS TOO LARGE
8683: WTB WA ELSE CONVERT TO BYTE OFFSET
8684: ADD WA,XR POINT TO ARGUMENT SELECTED
8685: MOV PFAGB(XR),XR LOAD ARGUMENT VRBLK POINTER
8686: BRN EXVNM EXIT TO BUILD NMBLK
8687: *
8688: * HERE IF 1ST ARGUMENT IS BAD
8689: *
8690: SARG1 ERB 252,ARG FIRST ARGUMENT IS NOT PROGRAM FUNCTION NAME
8691: EJC
8692: *
8693: * ARRAY
8694: *
8695: S$ARR ENT ENTRY POINT
8696: MOV (XS)+,XL LOAD INITIAL ELEMENT VALUE
8697: MOV (XS)+,XR LOAD FIRST ARGUMENT
8698: JSR GTINT CONVERT FIRST ARG TO INTEGER
8699: PPM SAR02 JUMP IF NOT INTEGER
8700: *
8701: * HERE FOR INTEGER FIRST ARGUMENT, BUILD VCBLK
8702: *
8703: LDI ICVAL(XR) LOAD INTEGER VALUE
8704: ILE SAR10 JUMP IF ZERO OR NEG (BAD DIMENSION)
8705: MFI WA,SAR11 ELSE CONVERT TO ONE WORD, TEST OVFL
8706: LCT WB,WA COPY ELEMENTS FOR LOOP LATER ON
8707: ADD =VCSI$,WA ADD SPACE FOR STANDARD FIELDS
8708: WTB WA CONVERT LENGTH TO BAUS
8709: BGE WA,MXLEN,SAR11 FAIL IF TOO LARGE
8710: JSR ALLOC ALLOCATE SPACE FOR VCBLK
8711: MOV =B$VCT,(XR) STORE TYPE WORD
8712: MOV WA,VCLEN(XR) SET LENGTH
8713: MOV XL,WC COPY DEFAULT VALUE
8714: MOV XR,XL COPY VCBLK POINTER
8715: ADD *VCVLS,XL POINT TO FIRST ELEMENT VALUE
8716: *
8717: * LOOP TO SET VECTOR ELEMENTS TO DEFAULT VALUE
8718: *
8719: SAR01 MOV WC,(XL)+ STORE ONE VALUE
8720: BCT WB,SAR01 LOOP TILL ALL STORED
8721: BRN EXSID EXIT SETTING IDVAL
8722: EJC
8723: *
8724: * ARRAY (CONTINUED)
8725: *
8726: * HERE IF FIRST ARGUMENT IS NOT AN INTEGER
8727: *
8728: SAR02 MOV XR,-(XS) REPLACE ARGUMENT ON STACK
8729: JSR XSCNI INITIALIZE SCAN OF FIRST ARGUMENT
8730: ERR 071,ARRAY FIRST ARGUMENT IS NOT INTEGER OR STRING
8731: PPM EXNUL DUMMY (UNUSED) NULL STRING EXIT
8732: MOV R$XSC,-(XS) SAVE PROTOTYPE POINTER
8733: MOV XL,-(XS) SAVE DEFAULT VALUE
8734: ZER ARCDM ZERO COUNT OF DIMENSIONS
8735: ZER ARPTR ZERO OFFSET TO INDICATE PASS ONE
8736: LDI INTV1 LOAD INTEGER ONE
8737: STI ARNEL INITIALIZE ELEMENT COUNT
8738: *
8739: * THE FOLLOWING CODE IS EXECUTED TWICE. THE FIRST TIME
8740: * (ARPTR EQ 0), IT IS USED TO COUNT THE NUMBER OF ELEMENTS
8741: * AND NUMBER OF DIMENSIONS. THE SECOND TIME (ARPTR GT 0) IS
8742: * USED TO ACTUALLY FILL IN THE DIM,LBD FIELDS OF THE ARBLK.
8743: *
8744: SAR03 LDI INTV1 LOAD ONE AS DEFAULT LOW BOUND
8745: STI ARSVL SAVE AS LOW BOUND
8746: MOV =CH$CL,WC SET DELIMITER ONE = COLON
8747: MOV =CH$CM,XL SET DELIMITER TWO = COMMA
8748: JSR XSCAN SCAN NEXT BOUND
8749: BNE WA,=NUM01,SAR04 JUMP IF NOT COLON
8750: *
8751: * HERE WE HAVE A COLON ENDING A LOW BOUND
8752: *
8753: JSR GTINT CONVERT LOW BOUND
8754: ERR 072,ARRAY FIRST ARGUMENT LOWER BOUND IS NOT INTEGER
8755: LDI ICVAL(XR) LOAD VALUE OF LOW BOUND
8756: STI ARSVL STORE LOW BOUND VALUE
8757: MOV =CH$CM,WC SET DELIMITER ONE = COMMA
8758: MOV WC,XL AND DELIMITER TWO = COMMA
8759: JSR XSCAN SCAN HIGH BOUND
8760: EJC
8761: *
8762: * ARRAY (CONTINUED)
8763: *
8764: * MERGE HERE TO PROCESS UPPER BOUND
8765: *
8766: SAR04 BNZ WA,SAR4A SKIP IF DELIMITER 1 OR 2
8767: BNZ XSCNB,SAR10 JUMP IF ILLEGALLY PLACED BLANK
8768: *
8769: * CHECK FOR INTEGER BOUND
8770: *
8771: SAR4A JSR GTINT CONVERT HIGH BOUND TO INTEGER
8772: ERR 073,ARRAY FIRST ARGUMENT UPPER BOUND IS NOT INTEGER
8773: LDI ICVAL(XR) GET HIGH BOUND
8774: SBI ARSVL SUBTRACT LOWER BOUND
8775: IOV SAR10 BAD DIMENSION IF OVERFLOW
8776: ILT SAR10 BAD DIMENSION IF NEGATIVE
8777: ADI INTV1 ADD 1 TO GET DIMENSION
8778: IOV SAR10 BAD DIMENSION IF OVERFLOW
8779: MOV ARPTR,XL LOAD OFFSET (ALSO PASS INDICATOR)
8780: BZE XL,SAR05 JUMP IF FIRST PASS
8781: *
8782: * HERE IN SECOND PASS TO STORE LBD AND DIM IN ARBLK
8783: *
8784: ADD (XS),XL POINT TO CURRENT LOCATION IN ARBLK
8785: STI CFP$I(XL) STORE DIMENSION
8786: LDI ARSVL LOAD LOW BOUND
8787: STI (XL) STORE LOW BOUND
8788: ADD *ARDMS,ARPTR BUMP OFFSET TO NEXT BOUNDS
8789: BRN SAR06 JUMP TO CHECK FOR END OF BOUNDS
8790: *
8791: * HERE IN PASS 1
8792: *
8793: SAR05 ICV ARCDM BUMP DIMENSION COUNT
8794: MLI ARNEL MULTIPLY DIMENSION BY COUNT SO FAR
8795: IOV SAR11 TOO LARGE IF OVERFLOW
8796: STI ARNEL ELSE STORE UPDATED ELEMENT COUNT
8797: *
8798: * MERGE HERE AFTER PROCESSING ONE SET OF BOUNDS
8799: *
8800: SAR06 BNZ WA,SAR03 LOOP BACK UNLESS END OF BOUNDS
8801: BNZ ARPTR,SAR09 JUMP IF END OF PASS 2
8802: EJC
8803: *
8804: * ARRAY (CONTINUED)
8805: *
8806: * HERE AT END OF PASS ONE, BUILD ARBLK
8807: *
8808: LDI ARNEL GET NUMBER OF ELEMENTS
8809: MFI WB,SAR11 GET AS ADDR INTEGER, TEST OVFLO
8810: WTB WB ELSE CONVERT TO LENGTH IN BAUS
8811: MOV *ARSI$,WA SET SIZE OF STANDARD FIELDS
8812: LCT WC,ARCDM SET DIMENSION COUNT TO CONTROL LOOP
8813: *
8814: * LOOP TO ALLOW SPACE FOR DIMENSIONS
8815: *
8816: SAR07 ADD *ARDMS,WA ALLOW SPACE FOR ONE SET OF BOUNDS
8817: BCT WC,SAR07 LOOP BACK TILL ALL ACCOUNTED FOR
8818: MOV WA,XL SAVE SIZE (=AROFS)
8819: *
8820: * NOW ALLOCATE SPACE FOR ARBLK
8821: *
8822: ADD WB,WA ADD SPACE FOR ELEMENTS
8823: ICA WA ALLOW FOR ARPRO PROTOTYPE FIELD
8824: BGE WA,MXLEN,SAR11 FAIL IF TOO LARGE
8825: JSR ALLOC ELSE ALLOCATE ARBLK
8826: MOV (XS),WB LOAD DEFAULT VALUE
8827: MOV XR,(XS) SAVE ARBLK POINTER
8828: MOV WA,WC SAVE LENGTH IN BAUS
8829: BTW WA CONVERT LENGTH BACK TO WORDS
8830: LCT WA,WA SET COUNTER TO CONTROL LOOP
8831: *
8832: * LOOP TO CLEAR ENTIRE ARBLK TO DEFAULT VALUE
8833: *
8834: SAR08 MOV WB,(XR)+ SET ONE WORD
8835: BCT WA,SAR08 LOOP TILL ALL SET
8836: EJC
8837: *
8838: * ARRAY (CONTINUED)
8839: *
8840: * NOW SET INITIAL FIELDS OF ARBLK
8841: *
8842: MOV (XS)+,XR RELOAD ARBLK POINTER
8843: MOV (XS),WB LOAD PROTOTYPE
8844: MOV =B$ART,(XR) SET TYPE WORD
8845: MOV WC,ARLEN(XR) STORE LENGTH IN BAUS
8846: ZER IDVAL(XR) ZERO ID TILL WE GET IT BUILT
8847: MOV XL,AROFS(XR) SET PROTOTYPE FIELD PTR
8848: MOV ARCDM,ARNDM(XR) SET NUMBER OF DIMENSIONS
8849: MOV XR,WC SAVE ARBLK POINTER
8850: ADD XL,XR POINT TO PROTOTYPE FIELD
8851: MOV WB,(XR) STORE PROTOTYPE PTR IN ARBLK
8852: MOV *ARLBD,ARPTR SET OFFSET FOR PASS 2 BOUNDS SCAN
8853: MOV WB,R$XSC RESET STRING POINTER FOR XSCAN
8854: MOV WC,(XS) STORE ARBLK POINTER ON STACK
8855: ZER XSOFS RESET OFFSET PTR TO START OF STRING
8856: BRN SAR03 JUMP BACK TO RESCAN BOUNDS
8857: *
8858: * HERE AFTER FILLING IN BOUNDS INFORMATION (END PASS TWO)
8859: *
8860: SAR09 MOV (XS)+,XR RELOAD POINTER TO ARBLK
8861: BRN EXSID EXIT SETTING IDVAL
8862: *
8863: * HERE FOR BAD DIMENSION
8864: *
8865: SAR10 ERB 074,BAD DIMENSION, ZERO, NEGATIVE OR OUT OF RANGE
8866: *
8867: * HERE IF ARRAY IS TOO LARGE
8868: *
8869: SAR11 ERB 075,ARRAY SIZE EXCEEDS MAXIMUM PERMITTED
8870: EJC
8871: *
8872: * BREAK
8873: *
8874: S$BRK ENT ENTRY POINT
8875: MOV =P$BKS,WB SET PCODE FOR SINGLE CHAR CASE
8876: MOV =P$BRK,XL PCODE FOR MULTI-CHAR CASE
8877: MOV =P$BKD,WC PCODE FOR EXPRESSION CASE
8878: JSR PATST CALL COMMON ROUTINE TO BUILD NODE
8879: ERR 076,BREAK ARGUMENT IS NOT STRING OR EXPRESSION
8880: BRN EXIXR JUMP FOR NEXT CODE WORD
8881: EJC
8882: *
8883: * BREAKX
8884: *
8885: * BREAKX IS A COMPOUND PATTERN. SEE DESCRIPTION AT START
8886: * OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED.
8887: *
8888: S$BKX ENT ENTRY POINT
8889: MOV =P$BKS,WB PCODE FOR SINGLE CHAR ARGUMENT
8890: MOV =P$BRK,XL PCODE FOR MULTI-CHAR ARGUMENT
8891: MOV =P$BXD,WC PCODE FOR EXPRESSION CASE
8892: JSR PATST CALL COMMON ROUTINE TO BUILD NODE
8893: ERR 077,BREAKX ARGUMENT IS NOT STRING OR EXPRESSION
8894: *
8895: * NOW HOOK BREAKX NODE ON AT FRONT END
8896: *
8897: MOV XR,-(XS) SAVE PTR TO BREAK NODE
8898: MOV =P$BKX,WB SET PCODE FOR BREAKX NODE
8899: JSR PBILD BUILD IT
8900: MOV (XS),PTHEN(XR) SET BREAK NODE AS SUCCESSOR
8901: MOV =P$ALT,WB SET PCODE FOR ALTERNATION NODE
8902: JSR PBILD BUILD (PARM1=ALT=BREAKX NODE)
8903: MOV XR,WA SAVE PTR TO ALTERNATION NODE
8904: MOV (XS),XR POINT TO BREAK NODE
8905: MOV WA,PTHEN(XR) SET ALTERNATE NODE AS SUCCESSOR
8906: BRN EXITS EXIT WITH RESULT ON STACK
8907: .IF .CNBF
8908: .ELSE
8909: EJC
8910: *
8911: * BUFFER
8912: *
8913: S$BUF ENT ENTRY POINT
8914: MOV (XS)+,XL GET INITIAL STRING
8915: JSR GTSMI CONVERT MEMORY REQUEST TO INTEGER
8916: ERR 078,BUFFER FIRST ARGUMENT IS NOT INTEGER
8917: PPM SBF01 FAIL IF OUT OF RANGE
8918: MOV WC,WA MOVE LENGTH TO CORRECT REGISTER
8919: JSR ALOBF ALLOCATE THE BUFFER
8920: JSR INSBF COPY INITIAL ARG IN
8921: ERR 079,BUFFER SECOND ARGUMENT IS NOT STRING OR BUFFER
8922: ERR 080,BUFFER INITIAL VALUE TOO BIG FOR ALLOCATION
8923: BRN EXSID EXIT SETTING IDVAL
8924: *
8925: * HERE FOR INVALID ALLOCATION SIZE
8926: *
8927: SBF01 ERB 081,BUFFER FIRST ARGUMENT IS OUT OF RANGE
8928: .FI
8929: EJC
8930: *
8931: * CLEAR
8932: *
8933: S$CLR ENT ENTRY POINT
8934: JSR XSCNI INITIALIZE TO SCAN ARGUMENT
8935: ERR 082,CLEAR ARGUMENT IS NOT STRING
8936: PPM SCLR2 JUMP IF NULL
8937: *
8938: * LOOP TO SCAN OUT NAMES IN FIRST ARGUMENT. VARIABLES IN
8939: * THE LIST ARE FLAGGED BY SETTING VRGET OF VRBLK TO ZERO.
8940: *
8941: SCLR1 MOV =CH$CM,WC SET DELIMITER ONE = COMMA
8942: MOV WC,XL DELIMITER TWO = COMMA
8943: JSR XSCAN SCAN NEXT VARIABLE NAME
8944: JSR GTNVR LOCATE VRBLK
8945: PPM SCLR7 ERRONEOUS NAME
8946: ZER VRGET(XR) ELSE FLAG BY ZEROING VRGET FIELD
8947: BNZ WA,SCLR1 LOOP BACK IF STOPPED BY COMMA
8948: BNZ XSCNB,SCLR7 BADLY PLACED BLANK
8949: *
8950: * HERE AFTER FLAGGING VARIABLES IN ARGUMENT LIST
8951: *
8952: SCLR2 MOV HSHTB,WB POINT TO START OF HASH TABLE
8953: *
8954: * LOOP THROUGH SLOTS IN HASH TABLE
8955: *
8956: SCLR3 BEQ WB,HSHTE,EXNUL EXIT RETURNING NULL IF NONE LEFT
8957: MOV WB,XR ELSE COPY SLOT POINTER
8958: ICA WB BUMP SLOT POINTER
8959: SUB *VRNXT,XR SET OFFSET TO MERGE INTO LOOP
8960: *
8961: * LOOP THROUGH VRBLKS ON ONE HASH CHAIN
8962: *
8963: SCLR4 MOV VRNXT(XR),XR POINT TO NEXT VRBLK ON CHAIN
8964: BZE XR,SCLR3 JUMP FOR NEXT BUCKET IF CHAIN END
8965: BNZ VRGET(XR),SCLR5 JUMP IF NOT FLAGGED
8966: EJC
8967: *
8968: * CLEAR (CONTINUED)
8969: *
8970: * HERE FOR FLAGGED VARIABLE, DO NOT SET VALUE TO NULL
8971: *
8972: JSR SETVR FOR FLAGGED VAR, RESTORE VRGET
8973: BRN SCLR4 AND LOOP BACK FOR NEXT VRBLK
8974: *
8975: * HERE TO SET VALUE OF A VARIABLE TO NULL
8976: * PROTECTED VARIABLES (ARB ETC) ARE EXEMPT
8977: *
8978: SCLR5 BEQ VRSTO(XR),=B$VRE,SCLR4 CHECK FOR PROTECTED VARIABLE
8979: MOV XR,XL COPY VRBLK POINTER
8980: *
8981: * LOOP TO LOCATE VALUE AT END OF POSSIBLE TRBLK CHAIN
8982: *
8983: SCLR6 MOV XL,WA SAVE BLOCK POINTER
8984: MOV VRVAL(XL),XL LOAD NEXT VALUE FIELD
8985: BEQ (XL),=B$TRT,SCLR6 LOOP BACK IF TRAPPED
8986: *
8987: * NOW STORE THE NULL VALUE
8988: *
8989: MOV WA,XL RESTORE BLOCK POINTER
8990: MOV =NULLS,VRVAL(XL) STORE NULL CONSTANT VALUE
8991: BRN SCLR4 LOOP BACK FOR NEXT VRBLK
8992: *
8993: * ERROR POINT
8994: *
8995: SCLR7 ERB 083,NULL VARIABLE NAME OR ILLEGAL BLANK IN CLEAR ARG
8996: EJC
8997: *
8998: * CODE
8999: *
9000: S$COD ENT ENTRY POINT
9001: MOV (XS)+,XR LOAD ARGUMENT
9002: JSR GTCOD CONVERT TO CODE
9003: PPM EXFAL FAIL IF CONVERSION IS IMPOSSIBLE
9004: BRN EXIXR ELSE RETURN CODE AS RESULT
9005: EJC
9006: *
9007: * COLLECT
9008: *
9009: S$COL ENT ENTRY POINT
9010: MOV (XS)+,XR LOAD ARGUMENT
9011: JSR GTINT CONVERT TO INTEGER
9012: ERR 084,COLLECT ARGUMENT IS NOT INTEGER
9013: LDI ICVAL(XR) LOAD COLLECT ARGUMENT
9014: STI CLSVI SAVE COLLECT ARGUMENT
9015: ZER WB SET NO MOVE UP
9016: JSR GBCOL PERFORM GARBAGE COLLECTION
9017: MOV DNAME,WA POINT TO END OF MEMORY
9018: SUB DNAMP,WA SUBTRACT NEXT LOCATION
9019: BTW WA CONVERT BAUS TO WORDS
9020: MTI WA CONVERT WORDS AVAILABLE AS INTEGER
9021: SBI CLSVI SUBTRACT ARGUMENT
9022: IOV EXFAL FAIL IF OVERFLOW
9023: ILT EXFAL FAIL IF NOT ENOUGH
9024: ADI CLSVI ELSE RECOMPUTE AVAILABLE
9025: BRN EXINT AND EXIT WITH INTEGER RESULT
9026: EJC
9027: *
9028: * CONVERT
9029: *
9030: S$CVT ENT ENTRY POINT
9031: JSR GTSTG CONVERT SECOND ARGUMENT TO STRING
9032: ERR 085,CONVERT SECOND ARGUMENT IS NOT STRING
9033: .IF .CASL
9034: MOV XR,XL COPY STRING PTR TO XL
9035: ZER WB ZERO OFFSET
9036: JSR SBSTG CONVERT CASE OF ARG IF NECESSARY
9037: .FI
9038: MOV (XS),XL LOAD FIRST ARGUMENT
9039: BNE (XL),=B$PDT,SCV01 JUMP IF NOT PROGRAM DEFINED
9040: *
9041: * HERE FOR PROGRAM DEFINED DATATYPE
9042: *
9043: MOV PDDFP(XL),XL POINT TO DFBLK
9044: MOV DFNAM(XL),XL LOAD DATATYPE NAME
9045: JSR IDENT COMPARE WITH SECOND ARG
9046: PPM EXITS EXIT IF IDENT WITH ARG AS RESULT
9047: BRN EXFAL ELSE FAIL
9048: *
9049: * HERE IF NOT PROGRAM DEFINED DATATYPE
9050: *
9051: SCV01 MOV XR,-(XS) SAVE STRING ARGUMENT
9052: MOV =SVCTB,XL POINT TO TABLE OF NAMES TO COMPARE
9053: ZER WB INITIALIZE COUNTER
9054: MOV SCLEN(XR),WC SAVE LENGTH OF ARGUMENT STRING
9055: *
9056: * LOOP THROUGH TABLE ENTRIES
9057: *
9058: SCV02 MOV (XL)+,XR LOAD NEXT TABLE ENTRY, BUMP POINTER
9059: BZE XR,EXFAL FAIL IF ZERO MARKING END OF LIST
9060: BNE WC,SCLEN(XR),SCV05 JUMP IF WRONG LENGTH
9061: MOV XL,CNVTP ELSE STORE TABLE POINTER
9062: PLC XR POINT TO CHARS OF TABLE ENTRY
9063: MOV (XS),XL LOAD POINTER TO STRING ARGUMENT
9064: PLC XL POINT TO CHARS OF STRING ARG
9065: MOV WC,WA SET NUMBER OF CHARS TO COMPARE
9066: CMC SCV04,SCV04 COMPARE, JUMP IF NO MATCH
9067: EJC
9068: *
9069: * CONVERT (CONTINUED)
9070: *
9071: * HERE WE HAVE A MATCH
9072: *
9073: SCV03 MOV WB,XL COPY ENTRY NUMBER
9074: ICA XS POP STRING ARG OFF STACK
9075: MOV (XS)+,XR LOAD FIRST ARGUMENT
9076: BSW XL,CNVTT JUMP TO APPROPRIATE ROUTINE
9077: IFF 0,SCV06 STRING
9078: IFF 1,SCV07 INTEGER
9079: IFF 2,SCV09 NAME
9080: IFF 3,SCV10 PATTERN
9081: IFF 4,SCV11 ARRAY
9082: IFF 5,SCV19 TABLE
9083: IFF 6,SCV25 EXPRESSION
9084: IFF 7,SCV26 CODE
9085: IFF 8,SCV27 NUMERIC
9086: .IF .CNRA
9087: .ELSE
9088: IFF 9,SCV08 REAL
9089: .FI
9090: .IF .CNBF
9091: .ELSE
9092: IFF CNVBT,SCV28 BUFFER
9093: .FI
9094: ESW END OF SWITCH TABLE
9095: *
9096: * HERE IF NO MATCH WITH TABLE ENTRY
9097: *
9098: SCV04 MOV CNVTP,XL RESTORE TABLE POINTER, MERGE
9099: *
9100: * MERGE HERE IF LENGTHS DID NOT MATCH
9101: *
9102: SCV05 ICV WB BUMP ENTRY NUMBER
9103: BRN SCV02 LOOP BACK TO CHECK NEXT ENTRY
9104: *
9105: * HERE TO CONVERT TO STRING
9106: *
9107: SCV06 MOV XR,-(XS) REPLACE STRING ARGUMENT ON STACK
9108: JSR GTSTG CONVERT TO STRING
9109: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
9110: BRN EXIXR ELSE RETURN STRING
9111: EJC
9112: *
9113: * CONVERT (CONTINUED)
9114: *
9115: * HERE TO CONVERT TO INTEGER
9116: *
9117: SCV07 JSR GTINT CONVERT TO INTEGER
9118: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
9119: BRN EXIXR ELSE RETURN INTEGER
9120: .IF .CNRA
9121: .ELSE
9122: *
9123: * HERE TO CONVERT TO REAL
9124: *
9125: SCV08 JSR GTREA CONVERT TO REAL
9126: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
9127: BRN EXIXR ELSE RETURN REAL
9128: .FI
9129: *
9130: * HERE TO CONVERT TO NAME
9131: *
9132: SCV09 BEQ (XR),=B$NML,EXIXR RETURN IF ALREADY A NAME
9133: JSR GTNVR ELSE TRY STRING TO NAME CONVERT
9134: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
9135: BRN EXVNM ELSE EXIT BUILDING NMBLK FOR VRBLK
9136: *
9137: * HERE TO CONVERT TO PATTERN
9138: *
9139: SCV10 JSR GTPAT CONVERT TO PATTERN
9140: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
9141: BRN EXIXR ELSE RETURN PATTERN
9142: *
9143: * CONVERT TO ARRAY
9144: *
9145: SCV11 JSR GTARR GET AN ARRAY
9146: PPM EXFAL FAIL IF NOT CONVERTIBLE
9147: BRN EXSID EXIT SETTING ID FIELD
9148: *
9149: * CONVERT TO TABLE
9150: *
9151: SCV19 MOV (XR),WA LOAD FIRST WORD OF BLOCK
9152: MOV XR,-(XS) REPLACE ARBLK POINTER ON STACK
9153: BEQ WA,=B$TBT,EXITS RETURN ARG IF ALREADY A TABLE
9154: BNE WA,=B$ART,EXFAL ELSE FAIL IF NOT AN ARRAY
9155: EJC
9156: *
9157: * CONVERT (CONTINUED)
9158: *
9159: * HERE TO CONVERT AN ARRAY TO TABLE
9160: *
9161: BNE ARNDM(XR),=NUM02,EXFAL FAIL IF NOT 2-DIM ARRAY
9162: LDI ARDM2(XR) LOAD DIM 2
9163: SBI INTV2 SUBTRACT 2 TO COMPARE
9164: INE EXFAL FAIL IF DIM2 NOT 2
9165: *
9166: * HERE WE HAVE AN ARBLK OF THE RIGHT SHAPE
9167: *
9168: LDI ARDIM(XR) LOAD DIM 1 (NUMBER OF ELEMENTS)
9169: MFI WA GET AS ONE WORD INTEGER
9170: LCT WB,WA COPY TO CONTROL LOOP
9171: ADD =TBSI$,WA ADD SPACE FOR STANDARD FIELDS
9172: WTB WA CONVERT LENGTH TO BAUS
9173: JSR ALLOC ALLOCATE SPACE FOR TBBLK
9174: MOV XR,WC COPY TBBLK POINTER
9175: MOV XR,-(XS) SAVE TBBLK POINTER
9176: MOV =B$TBT,(XR)+ STORE TYPE WORD
9177: ZER (XR)+ STORE ZERO FOR IDVAL FOR NOW
9178: MOV WA,(XR)+ STORE LENGTH
9179: MOV =NULLS,(XR)+ NULL INITIAL LOOKUP VALUE
9180: *
9181: * LOOP TO INITIALIZE BUCKET PTRS TO POINT TO TABLE
9182: *
9183: SCV20 MOV WC,(XR)+ SET BUCKET PTR TO POINT TO TBBLK
9184: BCT WB,SCV20 LOOP TILL ALL INITIALIZED
9185: MOV *ARVL2,WB SET OFFSET TO FIRST ARBLK ELEMENT
9186: *
9187: * LOOP TO COPY ELEMENTS FROM ARRAY TO TABLE
9188: *
9189: SCV21 MOV 1(XS),XL POINT TO ARBLK
9190: BEQ WB,ARLEN(XL),SCV24 JUMP IF ALL MOVED
9191: ADD WB,XL ELSE POINT TO CURRENT LOCATION
9192: ADD *NUM02,WB BUMP OFFSET
9193: MOV (XL),XR LOAD SUBSCRIPT NAME
9194: DCA XL ADJUST PTR TO MERGE (TRVAL=1+1)
9195: EJC
9196: *
9197: * CONVERT (CONTINUED)
9198: *
9199: * LOOP TO CHASE DOWN TRBLK CHAIN FOR VALUE
9200: *
9201: SCV22 MOV TRVAL(XL),XL POINT TO NEXT VALUE
9202: BEQ (XL),=B$TRT,SCV22 LOOP BACK IF TRAPPED
9203: *
9204: * HERE WITH NAME IN XR, VALUE IN XL
9205: *
9206: SCV23 MOV XL,-(XS) STACK VALUE
9207: MOV 1(XS),XL LOAD TBBLK POINTER
9208: JSR TFIND BUILD TEBLK (NOTE WB GT 0 BY NAME)
9209: PPM EXFAL FAIL IF ACESS FAILS
9210: MOV (XS)+,TEVAL(XL) STORE VALUE IN TEBLK
9211: BRN SCV21 LOOP BACK FOR NEXT ELEMENT
9212: *
9213: * HERE AFTER MOVING ALL ELEMENTS TO TBBLK
9214: *
9215: SCV24 MOV (XS)+,XR LOAD TBBLK POINTER
9216: ICA XS POP ARBLK POINTER
9217: BRN EXSID EXIT SETTING IDVAL
9218: *
9219: * CONVERT TO EXPRESSION
9220: *
9221: SCV25 JSR GTEXP CONVERT TO EXPRESSION
9222: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
9223: BRN EXIXR ELSE RETURN EXPRESSION
9224: *
9225: * CONVERT TO CODE
9226: *
9227: SCV26 JSR GTCOD CONVERT TO CODE
9228: PPM EXFAL FAIL IF CONVERSION IS NOT POSSIBLE
9229: BRN EXIXR ELSE RETURN CODE
9230: *
9231: * CONVERT TO NUMERIC
9232: *
9233: SCV27 JSR GTNUM CONVERT TO NUMERIC
9234: PPM EXFAL FAIL IF UNCONVERTIBLE
9235: BRN EXIXR RETURN NUMBER
9236: EJC
9237: .IF .CNBF
9238: .ELSE
9239: *
9240: * CONVERT TO BUFFER
9241: *
9242: SCV28 JSR GTBUF CONVERT TO BUFFER
9243: PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
9244: BRN EXSID EXIT SETTING IDVAL FIELD
9245: .FI
9246: EJC
9247: *
9248: * COPY
9249: *
9250: S$COP ENT ENTRY POINT
9251: JSR CBLCK COPY THE BLOCK
9252: PPM EXITS RETURN IF NO IDVAL FIELD
9253: BRN EXSID EXIT SETTING ID VALUE
9254: *
9255: * CTI
9256: *
9257: S$CTI ENT
9258: LDI INTV0 ZERO IN CASE NULL STRING
9259: JSR GTSTG GET ARG AS A STRING
9260: ERR 086,CTI ARGUMENT IS NOT A STRING
9261: BZE WA,SCT01 SKIP IF NULL
9262: PLC XR PREPARE TO READ THE CHARACTER
9263: LCH WB,(XR) GET THE CHARACTER
9264: MTI WB CONVERT TO INTEGER
9265: ZER XR CLEAR GARBAGE
9266: *
9267: * MAKE ICBLK AND RETURN
9268: *
9269: SCT01 JSR ICBLD BUILD ICBLK
9270: BRN EXIXR RETURN INTEGER RESULT
9271: EJC
9272: *
9273: * DATA
9274: *
9275: S$DAT ENT ENTRY POINT
9276: JSR XSCNI PREPARE TO SCAN ARGUMENT
9277: ERR 087,DATA ARGUMENT IS NOT STRING
9278: ERR 088,DATA ARGUMENT IS NULL
9279: *
9280: * SCAN OUT DATATYPE NAME
9281: *
9282: MOV =CH$PP,WC DELIMITER ONE = LEFT PAREN
9283: MOV WC,XL DELIMITER TWO = LEFT PAREN
9284: JSR XSCAN SCAN DATATYPE NAME
9285: BNZ WA,SDAT1 SKIP IF LEFT PAREN FOUND
9286: ERB 089,DATA ARGUMENT IS MISSING A LEFT PAREN
9287: *
9288: * HERE AFTER SCANNING DATATYPE NAME
9289: *
9290: SDAT1 MOV XR,XL SAVE NAME PTR
9291: MOV SCLEN(XR),WA GET LENGTH
9292: CTB WA,SCSI$ COMPUTE SPACE NEEDED
9293: JSR ALOST REQUEST STATIC STORE FOR NAME
9294: MOV XR,-(XS) SAVE DATATYPE NAME
9295: MVW COPY NAME TO STATIC
9296: MOV (XS),XR GET NAME PTR
9297: ZER XL SCRUB DUD REGISTER
9298: JSR GTNVR LOCATE VRBLK FOR DATATYPE NAME
9299: ERR 090,DATA ARGUMENT HAS NULL DATATYPE NAME
9300: MOV XR,DATDV SAVE VRBLK POINTER FOR DATATYPE
9301: MOV XS,DATXS STORE STARTING STACK VALUE
9302: ZER WB ZERO COUNT OF FIELD NAMES
9303: *
9304: * LOOP TO SCAN FIELD NAMES AND STACK VRBLK POINTERS
9305: *
9306: SDAT2 MOV =CH$RP,WC DELIMITER ONE = RIGHT PAREN
9307: MOV =CH$CM,XL DELIMITER TWO = COMMA
9308: JSR XSCAN SCAN NEXT FIELD NAME
9309: BNZ WA,SDAT3 JUMP IF DELIMITER FOUND
9310: ERB 091,BAD BLANK OR MISSING RIGHT PAREN IN DATA ARG
9311: *
9312: * HERE AFTER SCANNING OUT ONE FIELD NAME
9313: *
9314: SDAT3 JSR GTNVR LOCATE VRBLK FOR FIELD NAME
9315: ERR 092,DATA ARGUMENT HAS NULL FIELD NAME
9316: MOV XR,-(XS) STACK VRBLK POINTER
9317: ICV WB INCREMENT COUNTER
9318: BEQ WA,=NUM02,SDAT2 LOOP BACK IF STOPPED BY COMMA
9319: EJC
9320: *
9321: * DATA (CONTINUED)
9322: *
9323: * NOW BUILD THE DFBLK
9324: *
9325: MOV =DFSI$,WA SET SIZE OF DFBLK STANDARD FIELDS
9326: ADD WB,WA ADD NUMBER OF FIELDS
9327: WTB WA CONVERT LENGTH TO BAUS
9328: MOV WB,WC PRESERVE NO. OF FIELDS
9329: JSR ALOST ALLOCATE SPACE FOR DFBLK
9330: MOV WC,WB GET NO OF FIELDS
9331: MOV DATXS,XT POINT TO START OF STACK
9332: MOV (XT),WC LOAD DATATYPE NAME
9333: MOV XR,(XT) SAVE DFBLK POINTER ON STACK
9334: MOV =B$DFC,(XR)+ STORE TYPE WORD
9335: MOV WB,(XR)+ STORE NUMBER OF FIELDS (FARGS)
9336: MOV WA,(XR)+ STORE LENGTH (DFLEN)
9337: SUB *PDDFS,WA COMPUTE PDBLK LENGTH (FOR DFPDL)
9338: MOV WA,(XR)+ STORE PDBLK LENGTH (DFPDL)
9339: MOV WC,(XR)+ STORE DATATYPE NAME (DFNAM)
9340: LCT WC,WB COPY NUMBER OF FIELDS
9341: *
9342: * LOOP TO MOVE FIELD NAME VRBLK POINTERS TO DFBLK
9343: *
9344: SDAT4 MOV -(XT),(XR)+ MOVE ONE FIELD NAME VRBLK POINTER
9345: BCT WC,SDAT4 LOOP TILL ALL MOVED
9346: *
9347: * NOW DEFINE THE DATATYPE FUNCTION
9348: *
9349: MOV WA,WC COPY LENGTH OF PDBLK FOR LATER LOOP
9350: MOV DATDV,XR POINT TO VRBLK
9351: MOV DATXS,XT POINT BACK ON STACK
9352: MOV (XT),XL LOAD DFBLK POINTER
9353: JSR DFFNC DEFINE FUNCTION
9354: EJC
9355: *
9356: * DATA (CONTINUED)
9357: *
9358: * LOOP TO BUILD FFBLKS
9359: *
9360: *
9361: * NOTICE THAT THE FFBLKS ARE CONSTRUCTED IN REVERSE ORDER
9362: * SO THAT THE REQUIRED OFFSETS CAN BE OBTAINED FROM
9363: * SUCCESSIVE DECREMENTATION OF THE PDBLK LENGTH (IN WC).
9364: *
9365: SDAT5 MOV *FFSI$,WA SET LENGTH OF FFBLK
9366: JSR ALLOC ALLOCATE SPACE FOR FFBLK
9367: MOV =B$FFC,(XR) SET TYPE WORD
9368: MOV =NUM01,FARGS(XR) STORE FARGS (ALWAYS ONE)
9369: MOV DATXS,XT POINT BACK ON STACK
9370: MOV (XT),FFDFP(XR) COPY DFBLK PTR TO FFBLK
9371: DCA WC DECREMENT OLD DFPDL TO GET NEXT OFS
9372: MOV WC,FFOFS(XR) SET OFFSET TO THIS FIELD
9373: ZER FFNXT(XR) TENTATIVELY SET ZERO FORWARD PTR
9374: MOV XR,XL COPY FFBLK POINTER FOR DFFNC
9375: MOV (XS),XR LOAD VRBLK POINTER FOR FIELD
9376: MOV VRFNC(XR),XR LOAD CURRENT FUNCTION POINTER
9377: BNE (XR),=B$FFC,SDAT6 SKIP IF NOT CURRENTLY A FIELD FUNC
9378: *
9379: * HERE WE MUST CHAIN AN OLD FFBLK PTR TO PRESERVE IT IN THE
9380: * CASE OF MULTIPLE FIELD FUNCTIONS WITH THE SAME NAME
9381: *
9382: MOV XR,FFNXT(XL) LINK NEW FFBLK TO PREVIOUS CHAIN
9383: *
9384: * MERGE HERE TO DEFINE FIELD FUNCTION
9385: *
9386: SDAT6 MOV (XS)+,XR LOAD VRBLK POINTER
9387: JSR DFFNC DEFINE FIELD FUNCTION
9388: BNE XS,DATXS,SDAT5 LOOP BACK TILL ALL DONE
9389: ICA XS POP DFBLK POINTER
9390: BRN EXNUL RETURN WITH NULL RESULT
9391: EJC
9392: *
9393: * DATATYPE
9394: *
9395: S$DTP ENT ENTRY POINT
9396: MOV (XS)+,XR LOAD ARGUMENT
9397: JSR DTYPE GET DATATYPE
9398: BRN EXIXR AND RETURN IT AS RESULT
9399: EJC
9400: *
9401: * DATE
9402: *
9403: S$DTE ENT ENTRY POINT
9404: JSR SYSDT CALL SYSTEM DATE ROUTINE
9405: MOV 1(XL),WA LOAD LENGTH FOR SBSTR
9406: BZE WA,EXNUL RETURN NULL IF LENGTH IS ZERO
9407: ZER WB SET ZERO OFFSET
9408: JSR SBSTR USE SBSTR TO BUILD SCBLK
9409: BRN EXIXR RETURN DATE STRING
9410: EJC
9411: *
9412: * DEFINE
9413: *
9414: S$DFN ENT ENTRY POINT
9415: MOV (XS)+,XR LOAD SECOND ARGUMENT
9416: ZER DEFLB ZERO LABEL POINTER IN CASE NULL
9417: BEQ XR,=NULLS,SDF01 JUMP IF NULL SECOND ARGUMENT
9418: JSR GTNVR ELSE FIND VRBLK FOR LABEL
9419: PPM SDF13 JUMP IF NOT A VARIABLE NAME
9420: MOV XR,DEFLB ELSE SET SPECIFIED ENTRY
9421: *
9422: * SCAN FUNCTION NAME
9423: *
9424: SDF01 JSR XSCNI PREPARE TO SCAN FIRST ARGUMENT
9425: ERR 093,DEFINE FIRST ARGUMENT IS NOT STRING
9426: ERR 094,DEFINE FIRST ARGUMENT IS NULL
9427: MOV =CH$PP,WC DELIMITER ONE = LEFT PAREN
9428: MOV WC,XL DELIMITER TWO = LEFT PAREN
9429: JSR XSCAN SCAN OUT FUNCTION NAME
9430: BNZ WA,SDF02 JUMP IF LEFT PAREN FOUND
9431: ERB 095,DEFINE FIRST ARGUMENT IS MISSING A LEFT PAREN
9432: *
9433: * HERE AFTER SCANNING OUT FUNCTION NAME
9434: *
9435: SDF02 JSR GTNVR GET VARIABLE NAME
9436: ERR 096,DEFINE FIRST ARGUMENT HAS NULL FUNCTION NAME
9437: MOV XR,DEFVR SAVE VRBLK POINTER FOR FUNCTION NAM
9438: ZER WB ZERO COUNT OF ARGUMENTS
9439: MOV XS,DEFXS SAVE INITIAL STACK POINTER
9440: BNZ DEFLB,SDF03 JUMP IF SECOND ARGUMENT GIVEN
9441: MOV XR,DEFLB ELSE DEFAULT IS FUNCTION NAME
9442: *
9443: * LOOP TO SCAN ARGUMENT NAMES AND STACK VRBLK POINTERS
9444: *
9445: SDF03 MOV =CH$RP,WC DELIMITER ONE = RIGHT PAREN
9446: MOV =CH$CM,XL DELIMITER TWO = COMMA
9447: JSR XSCAN SCAN OUT NEXT ARGUMENT NAME
9448: BZE WA,SDF14 FAIL IF RUNOUT
9449: JSR GTNVR GET VRBLK POINTER
9450: PPM SDF04 IGNORE NULL NAME
9451: MOV XR,-(XS) STACK ARGUMENT VRBLK POINTER
9452: ICV WB INCREMENT COUNTER
9453: BEQ WA,=NUM02,SDF03 LOOP BACK IF STOPPED BY A COMMA
9454: BRN SDF05 JUMP FOR RIGHT PAREN
9455: EJC
9456: *
9457: * DEFINE (CONTINUED)
9458: *
9459: * NULL ARG FOUND. CONTINUE IF STOPPED BY COMMA
9460: *
9461: SDF04 BEQ WA,=NUM02,SDF03 LOOP IF COMMA
9462: *
9463: * HERE AFTER SCANNING OUT FUNCTION ARGUMENT NAMES
9464: *
9465: SDF05 MOV WB,DEFNA SAVE NUMBER OF ARGUMENTS
9466: ZER WB ZERO COUNT OF LOCALS
9467: *
9468: * LOOP TO SCAN LOCAL NAMES AND STACK VRBLK POINTERS
9469: *
9470: SDF06 MOV =CH$CM,WC SET DELIMITER ONE = COMMA
9471: MOV WC,XL SET DELIMITER TWO = COMMA
9472: JSR XSCAN SCAN OUT NEXT LOCAL NAME
9473: BNZ WA,SDF07 SKIP IF COMMA FOUND
9474: BNZ XSCNB,SDF14 FAIL IF BAD BLANK, OK IF LAST LOC
9475: *
9476: * HERE AFTER SCANNING OUT A LOCAL NAME
9477: *
9478: SDF07 JSR GTNVR GET VRBLK POINTER
9479: PPM SDF08 IGNORE NULL NAME
9480: ICV WB IF OK, INCREMENT COUNT
9481: MOV XR,-(XS) STACK VRBLK POINTER
9482: BNZ WA,SDF06 LOOP BACK IF STOPPED BY A COMMA
9483: BRN SDF09 JUMP FOR END OF STRING
9484: *
9485: * NULL LOCAL
9486: *
9487: SDF08 BNZ WA,SDF06 LOOP IF COMMA AFTER NULL LOCAL
9488: EJC
9489: *
9490: * DEFINE (CONTINUED)
9491: *
9492: * HERE AFTER SCANNING LOCALS, BUILD PFBLK
9493: *
9494: SDF09 MOV WB,WA COPY COUNT OF LOCALS
9495: ADD DEFNA,WA ADD NUMBER OF ARGUMENTS
9496: MOV WA,WC SET SUM ARGS+LOCALS AS LOOP COUNT
9497: ADD =PFSI$,WA ADD SPACE FOR STANDARD FIELDS
9498: WTB WA CONVERT LENGTH TO BAUS
9499: JSR ALLOC ALLOCATE SPACE FOR PFBLK
9500: MOV XR,XL SAVE POINTER TO PFBLK
9501: MOV =B$PFC,(XR)+ STORE FIRST WORD
9502: MOV DEFNA,(XR)+ STORE NUMBER OF ARGUMENTS
9503: MOV WA,(XR)+ STORE LENGTH (PFLEN)
9504: MOV DEFVR,(XR)+ STORE VRBLK PTR FOR FUNCTION NAME
9505: MOV WB,(XR)+ STORE NUMBER OF LOCALS
9506: ZER (XR)+ DEAL WITH LABEL LATER
9507: ZER (XR)+ ZERO PFCTR
9508: ZER (XR)+ ZERO PFRTR
9509: BZE WC,SDF11 SKIP IF NO ARGS OR LOCALS
9510: MOV XL,WA KEEP PFBLK POINTER
9511: MOV DEFXS,XT POINT BEFORE ARGUMENTS
9512: LCT WC,WC GET COUNT OF ARGS+LOCALS FOR LOOP
9513: *
9514: * LOOP TO MOVE LOCALS AND ARGS TO PFBLK
9515: *
9516: SDF10 MOV -(XT),(XR)+ STORE ONE ENTRY AND BUMP POINTERS
9517: BCT WC,SDF10 LOOP TILL ALL STORED
9518: MOV WA,XL RECOVER PFBLK POINTER
9519: EJC
9520: *
9521: * DEFINE (CONTINUED)
9522: *
9523: * NOW DEAL WITH LABEL
9524: *
9525: SDF11 MOV DEFXS,XS POP STACK
9526: MOV DEFLB,XR POINT TO VRBLK FOR LABEL
9527: MOV VRLBL(XR),XR LOAD LABEL POINTER
9528: BNE (XR),=B$TRT,SDF12 SKIP IF NOT TRAPPED
9529: MOV TRLBL(XR),XR ELSE POINT TO REAL LABEL
9530: *
9531: * HERE AFTER LOCATING REAL LABEL POINTER
9532: *
9533: SDF12 BEQ XR,=STNDL,SDF13 JUMP IF LABEL IS NOT DEFINED
9534: MOV XR,PFCOD(XL) ELSE STORE LABEL POINTER
9535: MOV DEFVR,XR POINT BACK TO VRBLK FOR FUNCTION
9536: JSR DFFNC DEFINE FUNCTION
9537: BRN EXNUL AND EXIT RETURNING NULL
9538: *
9539: * HERE FOR ERRONEOUS LABEL
9540: *
9541: SDF13 ERB 097,DEFINE FUNCTION ENTRY POINT IS NOT DEFINED LABEL
9542: *
9543: * ERRONEOUS ARG OR LOCAL
9544: *
9545: SDF14 ERB 098,BAD BLANK OR MISSING RIGHT PAREN IN DEFINE ARG
9546: EJC
9547: *
9548: * DETACH
9549: *
9550: S$DET ENT ENTRY POINT
9551: MOV (XS)+,XR LOAD ARGUMENT
9552: JSR GTVAR LOCATE VARIABLE
9553: ERR 099,DETACH ARGUMENT IS NOT APPROPRIATE NAME
9554: MOV WA,-(XS) KEEP OFFSET
9555: ZER SDETF CLEAR FAIL FLAG
9556: MOV =TRTIN,WB TRACE TYPE
9557: ZER XR REMOVE TRBLK
9558: JSR TRCHN REMOVE ANY INPUT ASSOCIATION
9559: PPM SDET1 SKIP IF NO INPUT TRBLK
9560: MNZ SDETF NOTE TRBLK REMOVED
9561: *
9562: * REPEAT FOR OUTPUT TRBLK
9563: *
9564: SDET1 MOV (XS)+,WA RECOVER OFFSET
9565: MOV =TRTOU,WB TRTYP
9566: JSR TRCHN REMOVE ANY OUTPUT ASSOCIATION
9567: PPM SDET2 SKIP IF NO TRBLK
9568: BRN EXNUL SUCCEED
9569: *
9570: * CHECK AT LEAST ONE TRBLK REMOVED
9571: *
9572: SDET2 BNZ SDETF,EXNUL SUCCEED IF SO
9573: BRN EXFAL ELSE FAIL
9574: EJC
9575: *
9576: * DIFFER
9577: *
9578: S$DIF ENT ENTRY POINT
9579: MOV (XS)+,XR LOAD SECOND ARGUMENT
9580: MOV (XS)+,XL LOAD FIRST ARGUMENT
9581: JSR IDENT CALL IDENT COMPARISON ROUTINE
9582: PPM EXFAL FAIL IF IDENT
9583: BRN EXNUL RETURN NULL IF DIFFER
9584: EJC
9585: *
9586: * DUMP
9587: *
9588: S$DMP ENT ENTRY POINT
9589: JSR GTSMI LOAD DUMP ARG AS SMALL INTEGER
9590: ERR 100,DUMP ARGUMENT IS NOT INTEGER
9591: ERR 101,DUMP ARGUMENT IS NEGATIVE OR TOO LARGE
9592: JSR DUMPR ELSE CALL DUMP ROUTINE
9593: BRN EXNUL AND RETURN NULL AS RESULT
9594: EJC
9595: *
9596: * DUPL
9597: *
9598: S$DUP ENT ENTRY POINT
9599: JSR GTSMI GET SECOND ARGUMENT AS SMALL INTEGE
9600: ERR 102,DUPL SECOND ARGUMENT IS NOT INTEGER
9601: PPM SDUP7 JUMP IF NEGATIVE OT TOO BIG
9602: MOV XR,WB SAVE DUPLICATION FACTOR
9603: JSR GTSTG GET FIRST ARG AS STRING
9604: PPM SDUP4 JUMP IF NOT A STRING
9605: *
9606: * HERE FOR CASE OF DUPLICATION OF A STRING
9607: *
9608: MTI WA ACQUIRE LENGTH AS INTEGER
9609: STI DUPSI SAVE FOR THE MOMENT
9610: MTI WB GET DUPLICATION FACTOR AS INTEGER
9611: MLI DUPSI FORM PRODUCT
9612: IOV SDUP3 JUMP IF OVERFLOW
9613: IEQ EXNUL RETURN NULL IF RESULT LENGTH = 0
9614: MFI WA,SDUP3 GET AS ADDR INTEGER, CHECK OVFLO
9615: *
9616: * MERGE HERE WITH RESULT LENGTH IN WA
9617: *
9618: SDUP1 MOV XR,XL SAVE STRING POINTER
9619: JSR ALOCS ALLOCATE SPACE FOR STRING
9620: MOV XR,-(XS) SAVE AS RESULT POINTER
9621: MOV XL,WC SAVE POINTER TO ARGUMENT STRING
9622: PSC XR PREPARE TO STORE CHARS OF RESULT
9623: LCT WB,WB SET COUNTER TO CONTROL LOOP
9624: *
9625: * LOOP THROUGH DUPLICATIONS
9626: *
9627: SDUP2 MOV WC,XL POINT BACK TO ARGUMENT STRING
9628: MOV SCLEN(XL),WA GET NUMBER OF CHARACTERS
9629: PLC XL POINT TO CHARS IN ARGUMENT STRING
9630: MVC MOVE CHARACTERS TO RESULT STRING
9631: BCT WB,SDUP2 LOOP TILL ALL DUPLICATIONS DONE
9632: BRN EXITS THEN EXIT FOR NEXT CODE WORD
9633: EJC
9634: *
9635: * DUPL (CONTINUED)
9636: *
9637: * HERE IF TOO LARGE, SET MAX LENGTH AND LET ALOCS CATCH IT
9638: *
9639: SDUP3 MOV DNAME,WA SET IMPOSSIBLE LENGTH FOR ALOCS
9640: BRN SDUP1 MERGE BACK
9641: *
9642: * HERE IF NOT A STRING
9643: *
9644: SDUP4 JSR GTPAT CONVERT ARGUMENT TO PATTERN
9645: ERR 103,DUPL FIRST ARGUMENT IS NOT STRING OR PATTERN
9646: *
9647: * HERE TO DUPLICATE A PATTERN ARGUMENT
9648: *
9649: MOV XR,-(XS) STORE PATTERN ON STACK
9650: MOV =NDNTH,XR START OFF WITH NULL PATTERN
9651: BZE WB,SDUP6 NULL PATTERN IS RESULT IF DUPFAC=0
9652: MOV WB,-(XS) PRESERVE LOOP COUNT
9653: *
9654: * LOOP TO DUPLICATE BY SUCCESSIVE CONCATENATION
9655: *
9656: SDUP5 MOV XR,XL COPY CURRENT VALUE AS RIGHT ARGUMNT
9657: MOV 1(XS),XR GET A NEW COPY OF LEFT
9658: JSR PCONC CONCATENATE
9659: DCV (XS) COUNT DOWN
9660: BNZ (XS),SDUP5 LOOP
9661: ICA XS POP LOOP COUNT
9662: *
9663: * HERE TO EXIT AFTER CONSTRUCTING PATTERN
9664: *
9665: SDUP6 MOV XR,(XS) STORE RESULT ON STACK
9666: BRN EXITS EXIT WITH RESULT ON STACK
9667: *
9668: * FAIL IF SECOND ARG IS OUT OF RANGE
9669: *
9670: SDUP7 ICA XS POP FIRST ARGUMENT
9671: BRN EXFAL FAIL
9672: EJC
9673: *
9674: * EJECT
9675: *
9676: S$EJC ENT ENTRY POINT
9677: MOV (XS)+,WB GET ARGUMENT
9678: MOV WB,-(XS) RESTACK IT
9679: JSR GTSTG CONVERT TO STRING
9680: PPM SEJC2 FAIL IF CANT
9681: BZE WA,SEJC1 SKIP IF NULL STRING
9682: MOV WB,-(XS) RESTACK ORIGINAL ARG
9683: JSR IOFTG CALL FILETAG ROUTINE
9684: PPM SEJC2 FAIL
9685: BZE WA,EXFAL FAIL IF NOT ASSOCIATED
9686: JSR SYSEF CALL EJECT FILE FUNCTION
9687: PPM EXFAL FAIL RETURN
9688: PPM EROSI ERROR RETURN
9689: BRN EXNUL RETURN NULL AS RESULT
9690: *
9691: * HERE TO EJECT STANDARD OUTPUT FILE
9692: *
9693: SEJC1 JSR SYSEP CALL ROUTINE TO EJECT PRINTER
9694: PPM EXFAL FAIL RETURN
9695: PPM EROSI ERROR RETURN
9696: BRN EXNUL EXIT WITH NULL RESULT
9697: *
9698: * ERROR POINT
9699: *
9700: SEJC2 ERB 104,EJECT ARGUMENT IS NOT A SUITABLE FILETAG
9701: EJC
9702: *
9703: * ENDFILE
9704: *
9705: S$ENF ENT ENTRY POINT
9706: JSR GTSTG CONVERT SECOND ARG TO STRING
9707: ERR 105,ENDFILE SECOND ARGUMENT IS NOT A STRING
9708: BNZ WA,SENF1 SKIP IF NON NULL SECOND ARG
9709: ZER XR 0 IF NULL
9710: *
9711: * NOW PROCESS FILETAG
9712: *
9713: SENF1 MOV XR,SENFR KEEP SECOND ARG
9714: JSR IOFTG CALL FILETAG PROC (WB = VRBLK PTR)
9715: ERR 106,ENDFILE FIRST ARGUMENT IS NOT A SUITABLE FILETAG
9716: BZE WA,EXFAL FAIL IF NO IOTAG
9717: MOV SENFR,XR RECOVER SECOND ARG
9718: JSR SYSEN CALL ENDFILE ROUTINE
9719: PPM EXFAL FAIL RETURN
9720: PPM EROSI ERROR RETURN
9721: BNZ WA,EXNUL RETURN NULL IF NO FILE CLOSURE
9722: MOV WB,XL POINT TO FILETAG VRBLK
9723: MOV *VRVAL,WA OFFSET TO VALUE FIELD
9724: ZER XR FOR TRBLK REMOVAL
9725: MOV =TRTIO,WB TRTYP
9726: JSR TRCHN REMOVE TRBLK
9727: PPM EXFAL (CANT FAIL HERE)
9728: BRN EXNUL RETURN NULL
9729: EJC
9730: *
9731: * EQ
9732: *
9733: S$EQF ENT ENTRY POINT
9734: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
9735: ERR 107,EQ FIRST ARGUMENT IS NOT NUMERIC
9736: ERR 108,EQ SECOND ARGUMENT IS NOT NUMERIC
9737: PPM EXFAL FAIL IF LT
9738: PPM EXNUL RETURN NULL IF EQ
9739: PPM EXFAL FAIL IF GT
9740: EJC
9741: *
9742: * EVAL
9743: *
9744: S$EVL ENT ENTRY POINT
9745: MOV (XS)+,XR LOAD ARGUMENT
9746: JSR GTEXP CONVERT TO EXPRESSION
9747: ERR 109,EVAL ARGUMENT IS NOT EXPRESSION
9748: LCW WC LOAD NEXT CODE WORD
9749: BNE WC,=OFNE$,SEVL1 JUMP IF CALLED BY VALUE
9750: SCP XL COPY CODE POINTER
9751: MOV (XL),WA GET NEXT CODE WORD
9752: BNE WA,=ORNM$,SEVL2 BY NAME UNLESS EXPRESSION
9753: BNZ 1(XS),SEVL2 JUMP IF BY NAME
9754: *
9755: * HERE IF CALLED BY VALUE
9756: *
9757: SEVL1 ZER WB SET FLAG FOR BY VALUE
9758: MOV WC,-(XS) SAVE CODE WORD
9759: JSR EVALX EVALUATE EXPRESSION BY VALUE
9760: PPM EXFAL FAIL IF EVALUATION FAILS
9761: MOV XR,XL COPY RESULT
9762: MOV (XS),XR RELOAD NEXT CODE WORD
9763: MOV XL,(XS) STACK RESULT
9764: BRI (XR) JUMP TO EXECUTE NEXT CODE WORD
9765: *
9766: * HERE IF CALLED BY NAME
9767: *
9768: SEVL2 MOV =NUM01,WB SET FLAG FOR BY NAME
9769: JSR EVALX EVALUATE EXPRESSION BY NAME
9770: PPM EXFAL FAIL IF EVALUATION FAILS
9771: BRN EXNAM EXIT WITH NAME
9772: .IF .CNEX
9773: .ELSE
9774: EJC
9775: *
9776: * EXIT
9777: *
9778: S$EXT ENT ENTRY POINT
9779: ZER WB CLEAR AMOUNT OF STATIC SHIFT
9780: JSR GBCOL COMPACT MEMORY BY COLLECTING
9781: JSR GTSTG CONVERT ARG TO STRING
9782: ERR 110,EXIT ARGUMENT IS NOT SUITABLE INTEGER OR STRING
9783: MOV XR,XL COPY STRING PTR
9784: JSR GTINT CHECK IT IS INTEGER
9785: PPM SEXT1 SKIP IF UNCONVERTIBLE
9786: ZER XL NOTE IT IS INTEGER
9787: LDI ICVAL(XR) GET INTEGER ARG
9788: *
9789: * MERGE TO CALL OSINT EXIT ROUTINE
9790: *
9791: SEXT1 MOV =HEADV,XR POINT TO V.V STRING
9792: MOV =KVCOD,WA VALUE OF CODE KEYWORD
9793: JSR SYSXI CALL EXTERNAL ROUTINE
9794: PPM EXFAL FAIL RETURN
9795: PPM EROSI ERROR RETURN
9796: IEQ EXNUL RETURN IF ARGUMENT 0
9797: ZER GBCNT RESUMING EXECUTION SO.
9798: IGT SEXT2 SKIP IF POSITIVE
9799: NGI MAKE POSITIVE
9800: *
9801: * CHECK FOR OPTION RESPECIFICATION
9802: *
9803: SEXT2 MFI WC GET VALUE IN WORK REGISTER
9804: BEQ WC,=NUM03,SEXT3 SKIP IF WAS 3
9805: MOV WC,-(XS) SAVE VALUE
9806: ZER WC SET TO READ OPTIONS
9807: JSR PRPAR READ SYSPP OPTIONS
9808: MOV (XS)+,WA RESTORE VALUE
9809: *
9810: * DEAL WITH HEADER OPTIONS (FIDDLED BY PRPAR)
9811: *
9812: SEXT3 MNZ HEADP ASSUME NO HEADERS
9813: BNE WC,=NUM01,SEXT4 SKIP IF NOT 1
9814: ZER HEADP REQUEST HEADER PRINTING
9815: *
9816: * ALMOST READY TO RESUME RUNNING
9817: *
9818: SEXT4 JSR SYSTM GET RECOMMENCEMENT TIME
9819: STI TIMSX SAVE AS INITIAL TIME
9820: LDI KVSTC RESET TO ENSURE ...
9821: STI KVSTL ... CORRECT EXECUTION STATS
9822: BRN EXNUL RESUME EXECUTION
9823: .FI
9824: .IF .CNFN
9825: .ELSE
9826: EJC
9827: *
9828: * FENCE
9829: *
9830: S$FNC ENT ENTRY POINT
9831: MOV =P$FNC,WB SET PCODE FOR P$FNC
9832: ZER XR P0BLK
9833: JSR PBILD BUILD P$FNC NODE
9834: MOV XR,XL SAVE POINTER TO IT
9835: MOV (XS)+,XR GET ARGUMENT
9836: JSR GTPAT CONVERT TO PATTERN
9837: ERR 180,FENCE ARGUMENT IS NOT PATTERN
9838: JSR PCONC CONCATENATE TO P$FNC NODE
9839: MOV XR,XL SAVE PTR TO CONCATENATED PATTERN
9840: MOV =P$FNA,WB SET FOR P$FNA PCODE
9841: ZER XR P0BLK
9842: JSR PBILD CONSTRUCT P$FNA NODE
9843: MOV XL,PTHEN(XR) SET PATTERN AS PTHEN
9844: MOV XR,-(XS) SET AS RESULT
9845: BRN EXITS DO NEXT CODE WORD
9846: EJC
9847: .FI
9848: *
9849: * FIELD
9850: *
9851: S$FLD ENT ENTRY POINT
9852: JSR GTSMI GET SECOND ARGUMENT (FIELD NUMBER)
9853: ERR 255,FIELD SECOND ARGUMENT IS NOT INTEGER
9854: PPM EXFAL FAIL IF OUT OF RANGE
9855: MOV XR,WB ELSE SAVE INTEGER VALUE
9856: MOV (XS)+,XR LOAD FIRST ARGUMENT
9857: JSR GTNVR POINT TO VRBLK
9858: PPM SFLD1 JUMP (ERROR) IF NOT VARIABLE NAME
9859: MOV VRFNC(XR),XR ELSE POINT TO FUNCTION BLOCK
9860: BNE (XR),=B$DFC,SFLD1 ERROR IF NOT DATATYPE FUNCTION
9861: *
9862: * HERE IF FIRST ARGUMENT IS A DATATYPE FUNCTION NAME
9863: *
9864: BZE WB,EXFAL FAIL IF ARGUMENT NUMBER IS ZERO
9865: BGT WB,FARGS(XR),EXFAL FAIL IF TOO LARGE
9866: WTB WB ELSE CONVERT TO BYTE OFFSET
9867: ADD WB,XR POINT TO FIELD NAME
9868: MOV DFFLB(XR),XR LOAD VRBLK POINTER
9869: BRN EXVNM EXIT TO BUILD NMBLK
9870: *
9871: * HERE FOR BAD FIRST ARGUMENT
9872: *
9873: SFLD1 ERB 254,FIELD FIRST ARGUMENT IS NOT DATATYPE NAME
9874: EJC
9875: *
9876: * GE
9877: *
9878: S$GEF ENT ENTRY POINT
9879: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
9880: ERR 111,GE FIRST ARGUMENT IS NOT NUMERIC
9881: ERR 112,GE SECOND ARGUMENT IS NOT NUMERIC
9882: PPM EXFAL FAIL IF LT
9883: PPM EXNUL RETURN NULL IF EQ
9884: PPM EXNUL RETURN NULL IF GT
9885: *
9886: * GT
9887: *
9888: S$GTF ENT ENTRY POINT
9889: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
9890: ERR 113,GT FIRST ARGUMENT IS NOT NUMERIC
9891: ERR 114,GT SECOND ARGUMENT IS NOT NUMERIC
9892: PPM EXFAL FAIL IF LT
9893: PPM EXFAL FAIL IF EQ
9894: PPM EXNUL RETURN NULL IF GT
9895: EJC
9896: *
9897: * HOST
9898: *
9899: S$HST ENT ENTRY POINT
9900: JSR GTSTG CONVERT ARG TO STRING
9901: ERR 115,ERRONEOUS THIRD ARGUMENT FOR HOST
9902: MOV WA,WB KEEP LENGTH
9903: MOV XR,WC KEEP THIRD ARG
9904: JSR GTSTG CONVERT ARG TO STRING
9905: ERR 116,ERRONEOUS SECOND ARGUMENT FOR HOST
9906: ORB WA,WB NON ZERO UNLESS TWO ARGS NULL
9907: MOV XR,XL KEEP SECOND ARG
9908: JSR GTSTG CONVERT ARG TO STRING
9909: ERR 117,ERRONEOUS FIRST ARGUMENT FOR HOST
9910: ORB WA,WB NON ZERO UNLESS ALL ARGS NULL
9911: MOV XR,WA KEEP FIRST ARG
9912: MOV WC,XR GET THIRD ARG
9913: JSR SYSHS CALL SYSHS ROUTINE
9914: PPM EXFAL FAIL RETURN
9915: PPM EROSI ERROR RETURN
9916: MOV SCLEN(XL),WA LENGTH OF RETURNED STRING
9917: ZER WB ZERO OFFSET
9918: JSR SBSTR BUILD COPY OF STRING
9919: MOV XR,-(XS) STACK THE RESULT
9920: BRN EXITS RETURN RESULT ON STACK
9921: EJC
9922: *
9923: * IDENT
9924: *
9925: S$IDN ENT ENTRY POINT
9926: MOV (XS)+,XR LOAD SECOND ARGUMENT
9927: MOV (XS)+,XL LOAD FIRST ARGUMENT
9928: JSR IDENT CALL IDENT COMPARISON ROUTINE
9929: PPM EXNUL RETURN NULL IF IDENT
9930: BRN EXFAL FAIL IF DIFFER
9931: EJC
9932: *
9933: * INPUT
9934: *
9935: S$INP ENT ENTRY POINT
9936: ZER WB INPUT FLAG
9937: JSR IOPUT CALL INPUT/OUTPUT ASSOC. ROUTINE
9938: ERR 118,INPUT THIRD ARGUMENT (FILEPROPS) IS NOT A STRING
9939: ERR 119,INAPPROPRIATE SECOND ARGUMENT (FILETAG) FOR INPUT
9940: ERR 120,INAPPROPRIATE FIRST ARGUMENT FOR INPUT
9941: PPM EXFAL FAIL RETURN
9942: BRN EXNUL RETURN NULL STRING
9943: .IF .CNBF
9944: .ELSE
9945: EJC
9946: *
9947: * INSERT
9948: *
9949: S$INS ENT ENTRY POINT
9950: MOV (XS)+,XL GET STRING ARG
9951: JSR GTSMI GET REPLACE LENGTH
9952: ERR 121,INSERT THIRD ARGUMENT NOT INTEGER
9953: PPM EXFAL FAIL IF OUT OF RANGE
9954: MOV WC,WB COPY TO PROPER REG
9955: JSR GTSMI GET REPLACE POSITION
9956: ERR 122,INSERT SECOND ARGUMENT NOT INTEGER
9957: PPM EXFAL FAIL IF OUT OF RANGE
9958: BZE WC,EXFAL FAIL IF ZERO
9959: DCV WC DECREMENT TO GET OFFSET
9960: MOV WC,WA PUT IN PROPER REGISTER
9961: MOV (XS)+,XR GET BUFFER
9962: BEQ (XR),=B$BCT,SINS1 PRESS ON IF TYPE OK
9963: ERB 123,INSERT FIRST ARGUMENT NOT BUFFER
9964: *
9965: * HERE WHEN EVERYTHING LOADED UP
9966: *
9967: SINS1 JSR INSBF CALL TO INSERT
9968: ERR 124,INSERT FOURTH ARGUMENT NOT A STRING
9969: PPM EXFAL FAIL IF OUT OF RANGE
9970: BRN EXNUL ELSE OK - EXIT WITH NULL
9971: .FI
9972: EJC
9973: *
9974: * INTEGER
9975: *
9976: S$INT ENT ENTRY POINT
9977: MOV (XS)+,XR LOAD ARGUMENT
9978: JSR GTNUM CONVERT TO NUMERIC
9979: PPM EXFAL FAIL IF NON-NUMERIC
9980: BEQ WA,=B$ICL,EXNUL RETURN NULL IF INTEGER
9981: BRN EXFAL FAIL IF REAL
9982: EJC
9983: *
9984: * ITC
9985: *
9986: S$ITC ENT
9987: JSR GTSMI OBTAIN ARG AS AN INTEGER
9988: ERR 125,ITC ARGUMENT IS NOT A SMALL INTEGER
9989: PPM EXFAL FAIL IF OUT OF RANGE
9990: BGE WC,=CFP$A,EXFAL FURTHER RANGE CHECK
9991: MOV WC,WB PRESERVE WC
9992: MOV =NUM01,WA FOR SCBLK REQUEST
9993: JSR ALOCS BUILD STRING BLOCK
9994: MOV XR,XL COPY STRING PTR
9995: PSC XL READY TO STORE CHAR
9996: SCH WB,(XL) STORE IT
9997: ZER XL CLEAR GARBAGE
9998: BRN EXIXR RETURN STRING RESULT
9999: EJC
10000: *
10001: * ITEM
10002: *
10003: * ITEM DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT
10004: * WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED.
10005: *
10006: S$ITM ENT ENTRY POINT
10007: *
10008: * DEAL WITH CASE OF NO ARGS
10009: *
10010: BNZ WA,SITM1 JUMP IF AT LEAST ONE ARG
10011: MOV =NULLS,-(XS) ELSE SUPPLY GARBAGE NULL ARG
10012: MOV =NUM01,WA AND FIX ARGUMENT COUNT
10013: *
10014: * CHECK FOR NAME/VALUE CASES
10015: *
10016: SITM1 SCP XR GET CURRENT CODE POINTER
10017: MOV (XR),XL LOAD NEXT CODE WORD
10018: DCV WA GET NUMBER OF SUBSCRIPTS
10019: MOV WA,XR COPY FOR ARREF
10020: BEQ XL,=OFNE$,SITM2 JUMP IF CALLED BY NAME
10021: *
10022: * HERE IF CALLED BY VALUE
10023: *
10024: ZER WB SET CODE FOR CALL BY VALUE
10025: BRN ARREF OFF TO ARRAY REFERENCE ROUTINE
10026: *
10027: * HERE FOR CALL BY NAME
10028: *
10029: SITM2 MNZ WB SET CODE FOR CALL BY NAME
10030: LCW WA LOAD AND IGNORE OFNE$ CALL
10031: BRN ARREF OFF TO ARRAY REFERENCE ROUTINE
10032: EJC
10033: *
10034: * LE
10035: *
10036: S$LEF ENT ENTRY POINT
10037: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
10038: ERR 126,LE FIRST ARGUMENT IS NOT NUMERIC
10039: ERR 127,LE SECOND ARGUMENT IS NOT NUMERIC
10040: PPM EXNUL RETURN NULL IF LT
10041: PPM EXNUL RETURN NULL IF EQ
10042: PPM EXFAL FAIL IF GT
10043: EJC
10044: *
10045: * LEN
10046: *
10047: S$LEN ENT ENTRY POINT
10048: MOV =P$LEN,WB SET PCODE FOR INTEGER ARG CASE
10049: MOV =P$LND,WA SET PCODE FOR EXPR ARG CASE
10050: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE
10051: ERR 128,LEN ARGUMENT IS NOT INTEGER OR EXPRESSION
10052: ERR 129,LEN ARGUMENT IS NEGATIVE OR TOO LARGE
10053: BRN EXIXR RETURN PATTERN NODE
10054: EJC
10055: *
10056: * LEQ
10057: *
10058: S$LEQ ENT ENTRY POINT
10059: JSR LCOMP CALL STRING COMPARISON ROUTINE
10060: ERR 130,LEQ FIRST ARGUMENT IS NOT STRING
10061: ERR 131,LEQ SECOND ARGUMENT IS NOT STRING
10062: PPM EXFAL FAIL IF LLT
10063: PPM EXNUL RETURN NULL IF LEQ
10064: PPM EXFAL FAIL IF LGT
10065: EJC
10066: *
10067: * LGE
10068: *
10069: S$LGE ENT ENTRY POINT
10070: JSR LCOMP CALL STRING COMPARISON ROUTINE
10071: ERR 132,LGE FIRST ARGUMENT IS NOT STRING
10072: ERR 133,LGE SECOND ARGUMENT IS NOT STRING
10073: PPM EXFAL FAIL IF LLT
10074: PPM EXNUL RETURN NULL IF LEQ
10075: PPM EXNUL RETURN NULL IF LGT
10076: EJC
10077: *
10078: * LGT
10079: *
10080: S$LGT ENT ENTRY POINT
10081: JSR LCOMP CALL STRING COMPARISON ROUTINE
10082: ERR 134,LGT FIRST ARGUMENT IS NOT STRING
10083: ERR 135,LGT SECOND ARGUMENT IS NOT STRING
10084: PPM EXFAL FAIL IF LLT
10085: PPM EXFAL FAIL IF LEQ
10086: PPM EXNUL RETURN NULL IF LGT
10087: EJC
10088: *
10089: * LLE
10090: *
10091: S$LLE ENT ENTRY POINT
10092: JSR LCOMP CALL STRING COMPARISON ROUTINE
10093: ERR 136,LLE FIRST ARGUMENT IS NOT STRING
10094: ERR 137,LLE SECOND ARGUMENT IS NOT STRING
10095: PPM EXNUL RETURN NULL IF LLT
10096: PPM EXNUL RETURN NULL IF LEQ
10097: PPM EXFAL FAIL IF LGT
10098: EJC
10099: *
10100: * LLT
10101: *
10102: S$LLT ENT ENTRY POINT
10103: JSR LCOMP CALL STRING COMPARISON ROUTINE
10104: ERR 138,LLT FIRST ARGUMENT IS NOT STRING
10105: ERR 139,LLT SECOND ARGUMENT IS NOT STRING
10106: PPM EXNUL RETURN NULL IF LLT
10107: PPM EXFAL FAIL IF LEQ
10108: PPM EXFAL FAIL IF LGT
10109: EJC
10110: *
10111: * LNE
10112: *
10113: S$LNE ENT ENTRY POINT
10114: JSR LCOMP CALL STRING COMPARISON ROUTINE
10115: ERR 140,LNE FIRST ARGUMENT IS NOT STRING
10116: ERR 141,LNE SECOND ARGUMENT IS NOT STRING
10117: PPM EXNUL RETURN NULL IF LLT
10118: PPM EXFAL FAIL IF LEQ
10119: PPM EXNUL RETURN NULL IF LGT
10120: .IF .CNLD
10121: .ELSE
10122: EJC
10123: *
10124: * LOAD
10125: *
10126: S$LOD ENT ENTRY POINT
10127: JSR GTSTG LOAD LIBRARY NAME
10128: ERR 142,LOAD SECOND ARGUMENT IS NOT STRING
10129: MOV XR,XL SAVE LIBRARY NAME
10130: JSR XSCNI PREPARE TO SCAN FIRST ARGUMENT
10131: ERR 143,LOAD FIRST ARGUMENT IS NOT STRING
10132: ERR 144,LOAD FIRST ARGUMENT IS NULL
10133: MOV XL,-(XS) STACK LIBRARY NAME
10134: MOV =CH$PP,WC SET DELIMITER ONE = LEFT PAREN
10135: MOV WC,XL SET DELIMITER TWO = LEFT PAREN
10136: JSR XSCAN SCAN FUNCTION NAME
10137: MOV XR,-(XS) SAVE PTR TO FUNCTION NAME
10138: BNZ WA,SLOD1 JUMP IF LEFT PAREN FOUND
10139: ERB 145,LOAD FIRST ARGUMENT IS MISSING A LEFT PAREN
10140: *
10141: * HERE AFTER SUCCESSFULLY SCANNING FUNCTION NAME
10142: *
10143: SLOD1 JSR GTNVR LOCATE VRBLK
10144: ERR 146,LOAD FIRST ARGUMENT HAS NULL FUNCTION NAME
10145: MOV XR,LODFN SAVE VRBLK POINTER
10146: ZER LODNA ZERO COUNT OF ARGUMENTS
10147: *
10148: * LOOP TO SCAN ARGUMENT DATATYPE NAMES
10149: *
10150: SLOD2 MOV =CH$RP,WC DELIMITER ONE IS RIGHT PAREN
10151: MOV =CH$CM,XL DELIMITER TWO IS COMMA
10152: JSR XSCAN SCAN NEXT ARGUMENT NAME
10153: ICV LODNA BUMP ARGUMENT COUNT
10154: BNZ WA,SLOD3 JUMP IF OK DELIMITER WAS FOUND
10155: ERB 147,BAD BLANK OR MISSING RIGHT PAREN IN LOAD ARG
10156: EJC
10157: *
10158: * LOAD (CONTINUED)
10159: *
10160: * COME HERE TO ANALYZE THE DATATYPE POINTER IN (XR). THIS
10161: * CODE IS USED BOTH FOR ARGUMENTS (WA=1,2) AND FOR THE
10162: * RESULT DATATYPE (WITH WA SET TO ZERO).
10163: *
10164: SLOD3 MOV XR,-(XS) STACK DATATYPE NAME POINTER
10165: MOV =NUM01,WB SET STRING CODE IN CASE (1)
10166: MOV =SCSTR,XL POINT TO /STRING/
10167: JSR IDENT CHECK FOR MATCH
10168: PPM SLOD4 JUMP IF MATCH
10169: MOV (XS),XR ELSE RELOAD NAME
10170: ADD WB,WB SET CODE FOR INTEGER (2)
10171: MOV =SCINT,XL POINT TO /INTEGER/
10172: JSR IDENT CHECK FOR MATCH
10173: PPM SLOD4 JUMP IF MATCH
10174: ICV WB ELSE SET CODE FOR REAL (3)
10175: .IF .CNRA
10176: .ELSE
10177: MOV (XS),XR RELOAD STRING POINTER
10178: MOV =SCREA,XL POINT TO /REAL/
10179: JSR IDENT CHECK FOR MATCH
10180: PPM SLOD4 JUMP IF MATCH
10181: .FI
10182: ICV WB SET CODE FOR BUFFER (4)
10183: .IF .CNBF
10184: .ELSE
10185: MOV (XS),XR RELOAD STRING POINTER
10186: MOV =SCBUF,XL POINT TO /BUFFER/
10187: JSR IDENT CHECK FOR MATCH
10188: PPM SLOD4 JUMP IF MATCH
10189: .FI
10190: ZER WB ELSE GET CODE FOR NO CONVERT
10191: *
10192: * MERGE HERE WITH PROPER DATATYPE CODE IN WB
10193: *
10194: SLOD4 MOV WB,(XS) STORE CODE ON STACK
10195: BEQ WA,=NUM02,SLOD2 LOOP BACK IF ARG STOPPED BY COMMA
10196: BZE WA,SLOD5 JUMP IF THAT WAS THE RESULT TYPE
10197: *
10198: * HERE WE SCAN OUT THE RESULT TYPE (ARG STOPPED BY ) )
10199: *
10200: MOV MXLEN,WC SET DUMMY (IMPOSSIBLE) DELIMITER 1
10201: MOV WC,XL AND DELIMITER TWO
10202: JSR XSCAN SCAN RESULT NAME
10203: ZER WA SET CODE FOR PROCESSING RESULT
10204: BRN SLOD3 JUMP BACK TO PROCESS RESULT NAME
10205: EJC
10206: *
10207: * LOAD (CONTINUED)
10208: *
10209: * HERE AFTER PROCESSING ALL ARGS AND RESULT
10210: *
10211: SLOD5 MOV LODNA,WA GET NUMBER OF ARGUMENTS
10212: MOV WA,WC COPY FOR LATER
10213: WTB WA CONVERT LENGTH TO BAUS
10214: ADD *EFSI$,WA ADD SPACE FOR STANDARD FIELDS
10215: JSR ALLOC ALLOCATE EFBLK
10216: MOV =B$EFC,(XR) SET TYPE WORD
10217: MOV WC,FARGS(XR) SET NUMBER OF ARGUMENTS
10218: ZER EFUSE(XR) SET USE COUNT (DFFNC WILL SET TO 1)
10219: ZER EFCOD(XR) ZERO CODE POINTER FOR NOW
10220: MOV (XS)+,EFRSL(XR) STORE RESULT TYPE CODE
10221: MOV LODFN,EFVAR(XR) STORE FUNCTION VRBLK POINTER
10222: MOV WA,EFLEN(XR) STORE EFBLK LENGTH
10223: MOV XR,WB SAVE EFBLK POINTER
10224: ADD WA,XR POINT PAST END OF EFBLK
10225: LCT WC,WC SET NUMBER OF ARGUMENTS FOR LOOP
10226: *
10227: * LOOP TO SET ARGUMENT TYPE CODES FROM STACK
10228: *
10229: SLOD6 MOV (XS)+,-(XR) STORE ONE TYPE CODE FROM STACK
10230: BCT WC,SLOD6 LOOP TILL ALL STORED
10231: *
10232: * NOW LOAD THE EXTERNAL FUNCTION AND PERFORM DEFINITION
10233: *
10234: MOV (XS)+,XR LOAD FUNCTION STRING NAME
10235: MOV (XS),XL LOAD LIBRARY NAME
10236: MOV WB,(XS) STORE EFBLK POINTER
10237: JSR SYSLD CALL FUNCTION TO LOAD EXTERNAL FUNC
10238: PPM EXFAL FAIL RETURN
10239: PPM EROSI ERROR RETURN
10240: MOV (XS)+,XL RECALL EFBLK POINTER
10241: MOV XR,EFCOD(XL) STORE CODE POINTER
10242: MOV LODFN,XR POINT TO VRBLK FOR FUNCTION
10243: JSR DFFNC PERFORM FUNCTION DEFINITION
10244: BRN EXNUL RETURN NULL RESULT
10245: .FI
10246: EJC
10247: *
10248: * LOCAL
10249: *
10250: S$LOC ENT ENTRY POINT
10251: JSR GTSMI GET SECOND ARGUMENT (LOCAL NUMBER)
10252: ERR 256,LOCAL SECOND ARGUMENT IS NOT INTEGER
10253: PPM EXFAL FAIL IF OUT OF RANGE
10254: MOV XR,WB SAVE LOCAL NUMBER
10255: MOV (XS)+,XR LOAD FIRST ARGUMENT
10256: JSR GTNVR POINT TO VRBLK
10257: PPM SLOC1 JUMP IF NOT VARIABLE NAME
10258: MOV VRFNC(XR),XR ELSE LOAD FUNCTION POINTER
10259: BNE (XR),=B$PFC,SLOC1 JUMP IF NOT PROGRAM DEFINED
10260: *
10261: * HERE IF WE HAVE A PROGRAM DEFINED FUNCTION NAME
10262: *
10263: BZE WB,EXFAL FAIL IF SECOND ARG IS ZERO
10264: BGT WB,PFNLO(XR),EXFAL OR TOO LARGE
10265: ADD FARGS(XR),WB ELSE ADJUST OFFSET TO INCLUDE ARGS
10266: WTB WB CONVERT TO BYTES
10267: ADD WB,XR POINT TO LOCAL POINTER
10268: MOV PFAGB(XR),XR LOAD VRBLK POINTER
10269: BRN EXVNM EXIT BUILDING NMBLK
10270: *
10271: * HERE IF FIRST ARGUMENT IS NO GOOD
10272: *
10273: SLOC1 ERB 257,LOCAL FIRST ARG IS NOT A PROGRAM FUNCTION NAME
10274: EJC
10275: *
10276: * LPAD
10277: *
10278: S$LPD ENT ENTRY POINT
10279: JSR GTSTG GET PAD CHARACTER
10280: ERR 148,LPAD THIRD ARGUMENT NOT A STRING
10281: PLC XR POINT TO CHARACTER (NULL IS BLANK)
10282: LCH WB,(XR) LOAD PAD CHARACTER
10283: JSR GTSMI GET PAD LENGTH
10284: ERR 149,LPAD SECOND ARGUMENT IS NOT INTEGER
10285: PPM SLPD3 SKIP IF NEGATIVE OR LARGE
10286: *
10287: * MERGE TO CHECK FIRST ARG
10288: *
10289: SLPD1 JSR GTSTG GET FIRST ARGUMENT (STRING TO PAD)
10290: ERR 150,LPAD FIRST ARGUMENT IS NOT STRING
10291: BGE WA,WC,EXIXR RETURN 1ST ARG IF TOO LONG TO PAD
10292: MOV XR,XL ELSE MOVE PTR TO STRING TO PAD
10293: *
10294: * NOW WE ARE READY FOR THE PAD
10295: *
10296: * (XL) POINTER TO STRING TO PAD
10297: * (WB) PAD CHARACTER
10298: * (WC) LENGTH TO PAD STRING TO
10299: *
10300: MOV WC,WA COPY LENGTH
10301: JSR ALOCS ALLOCATE SCBLK FOR NEW STRING
10302: MOV XR,-(XS) SAVE AS RESULT
10303: MOV SCLEN(XL),WA LOAD LENGTH OF ARGUMENT
10304: SUB WA,WC CALCULATE NUMBER OF PAD CHARACTERS
10305: PSC XR POINT TO CHARS IN RESULT STRING
10306: LCT WC,WC SET COUNTER FOR PAD LOOP
10307: *
10308: * LOOP TO PERFORM PAD
10309: *
10310: SLPD2 SCH WB,(XR)+ STORE PAD CHARACTER, BUMP PTR
10311: BCT WC,SLPD2 LOOP TILL ALL PAD CHARS STORED
10312: CSC XR COMPLETE STORE CHARACTERS
10313: *
10314: * NOW COPY STRING
10315: *
10316: BZE WA,EXITS EXIT IF NULL STRING
10317: PLC XL ELSE POINT TO CHARS IN ARGUMENT
10318: MVC MOVE CHARACTERS TO RESULT STRING
10319: BRN EXITS JUMP FOR NEXT CODE WORD
10320: *
10321: * HERE IF 2ND ARG IS NEGATIVE OR LARGE
10322: *
10323: SLPD3 ZER WC ZERO PAD COUNT
10324: BRN SLPD1 MERGE
10325: EJC
10326: *
10327: * LT
10328: *
10329: S$LTF ENT ENTRY POINT
10330: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
10331: ERR 151,LT FIRST ARGUMENT IS NOT NUMERIC
10332: ERR 152,LT SECOND ARGUMENT IS NOT NUMERIC
10333: PPM EXNUL RETURN NULL IF LT
10334: PPM EXFAL FAIL IF EQ
10335: PPM EXFAL FAIL IF GT
10336: EJC
10337: *
10338: * NE
10339: *
10340: S$NEF ENT ENTRY POINT
10341: JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
10342: ERR 153,NE FIRST ARGUMENT IS NOT NUMERIC
10343: ERR 154,NE SECOND ARGUMENT IS NOT NUMERIC
10344: PPM EXNUL RETURN NULL IF LT
10345: PPM EXFAL FAIL IF EQ
10346: PPM EXNUL RETURN NULL IF GT
10347: EJC
10348: *
10349: * NOTANY
10350: *
10351: S$NAY ENT ENTRY POINT
10352: MOV =P$NAS,WB SET PCODE FOR SINGLE CHAR ARG
10353: MOV =P$NAY,XL PCODE FOR MULTI-CHAR ARG
10354: MOV =P$NAD,WC SET PCODE FOR EXPR ARG
10355: JSR PATST CALL COMMON ROUTINE TO BUILD NODE
10356: ERR 155,NOTANY ARGUMENT IS NOT STRING OR EXPRESSION
10357: BRN EXIXR JUMP FOR NEXT CODE WORD
10358: EJC
10359: *
10360: * OPSYN
10361: *
10362: S$OPS ENT ENTRY POINT
10363: JSR GTSMI LOAD THIRD ARGUMENT
10364: ERR 156,OPSYN THIRD ARGUMENT IS NOT INTEGER
10365: ERR 157,OPSYN THIRD ARGUMENT IS NEGATIVE OR TOO LARGE
10366: MOV WC,WB IF OK, SAVE THIRD ARGUMNET
10367: MOV (XS)+,XR LOAD SECOND ARGUMENT
10368: JSR GTNVR LOCATE VARIABLE BLOCK
10369: ERR 158,OPSYN SECOND ARG IS NOT NATURAL VARIABLE NAME
10370: MOV VRFNC(XR),XL IF OK, LOAD FUNCTION BLOCK POINTER
10371: BNZ WB,SOPS2 JUMP IF OPERATOR OPSYN CASE
10372: *
10373: * HERE FOR FUNCTION OPSYN (THIRD ARG ZERO)
10374: *
10375: MOV (XS)+,XR LOAD FIRST ARGUMENT
10376: JSR GTNVR GET VRBLK POINTER
10377: ERR 159,OPSYN FIRST ARG IS NOT NATURAL VARIABLE NAME
10378: *
10379: * MERGE HERE TO PERFORM FUNCTION DEFINITION
10380: *
10381: SOPS1 JSR DFFNC CALL FUNCTION DEFINER
10382: BRN EXNUL EXIT WITH NULL RESULT
10383: *
10384: * HERE FOR OPERATOR OPSYN (THIRD ARG NON-ZERO)
10385: *
10386: SOPS2 JSR GTSTG GET OPERATOR NAME
10387: PPM SOPS5 JUMP IF NOT STRING
10388: BNE WA,=NUM01,SOPS5 ERROR IF NOT ONE CHAR LONG
10389: PLC XR ELSE POINT TO CHARACTER
10390: LCH WC,(XR) LOAD CHARACTER NAME
10391: EJC
10392: *
10393: * OPSYN (CONTINUED)
10394: *
10395: * NOW SET TO SEARCH FOR MATCHING UNARY OR BINARY OPERATOR
10396: * NAME AS APPROPRIATE. NOTE THAT THERE ARE =OPBUN UNDEFINED
10397: * BINARY OPERATORS AND =OPUUN UNDEFINED UNARY OPERATORS.
10398: *
10399: MOV =R$UUB,WA POINT TO UNOP POINTERS IN CASE
10400: MOV =OPNSU,XR POINT TO NAMES OF UNARY OPERATORS
10401: ADD =OPBUN,WB ADD NO. OF UNDEFINED BINARY OPS
10402: BEQ WB,=OPUUN,SOPS3 JUMP IF UNOP (THIRD ARG WAS 1)
10403: MOV =R$UBA,WA ELSE POINT TO BINARY OPERATOR PTRS
10404: MOV =OPSNB,XR POINT TO NAMES OF BINARY OPERATORS
10405: MOV =OPBUN,WB SET NUMBER OF UNDEFINED BINOPS
10406: *
10407: * MERGE HERE TO CHECK LIST (WB = NUMBER TO CHECK)
10408: *
10409: SOPS3 LCT WB,WB SET COUNTER TO CONTROL LOOP
10410: *
10411: * LOOP TO SEARCH FOR NAME MATCH
10412: *
10413: SOPS4 BEQ WC,(XR),SOPS6 JUMP IF NAMES MATCH
10414: ICA WA ELSE PUSH POINTER TO FUNCTION PTR
10415: ICA XR BUMP POINTER
10416: BCT WB,SOPS4 LOOP BACK TILL ALL CHECKED
10417: *
10418: * HERE IF BAD OPERATOR NAME
10419: *
10420: SOPS5 ERB 160,OPSYN FIRST ARG IS NOT CORRECT OPERATOR NAME
10421: *
10422: * COME HERE ON FINDING A MATCH IN THE OPERATOR NAME TABLE
10423: *
10424: SOPS6 MOV WA,XR COPY POINTER TO FUNCTION BLOCK PTR
10425: SUB *VRFNC,XR MAKE IT LOOK LIKE DUMMY VRBLK
10426: BRN SOPS1 MERGE BACK TO DEFINE OPERATOR
10427: EJC
10428: *
10429: * OUTPUT
10430: *
10431: S$OUP ENT ENTRY POINT
10432: MOV =NUM02,WB OUTPUT FLAG
10433: JSR IOPUT CALL INPUT/OUTPUT ASSOC. ROUTINE
10434: ERR 161,OUTPUT THIRD ARGUMENT (FILEPROPS) IS NOT A STRING
10435: ERR 162,INAPPROPRIATE SECOND ARGUMENT (FILETAG) FOR OUTPUT
10436: ERR 163,INAPPROPRIATE FIRST ARGUMENT FOR OUTPUT
10437: PPM EXFAL FAIL RETURN
10438: BRN EXNUL RETURN NULL STRING
10439: EJC
10440: *
10441: * POS
10442: *
10443: S$POS ENT ENTRY POINT
10444: MOV =P$POS,WB SET PCODE FOR INTEGER ARG CASE
10445: MOV =P$PSD,WA SET PCODE FOR EXPRESSION ARG CASE
10446: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE
10447: ERR 164,POS ARGUMENT IS NOT INTEGER OR EXPRESSION
10448: ERR 165,POS ARGUMENT IS NEGATIVE OR TOO LARGE
10449: BRN EXIXR RETURN PATTERN NODE
10450: EJC
10451: *
10452: * PROTOTYPE
10453: *
10454: S$PRO ENT ENTRY POINT
10455: MOV (XS)+,XR LOAD ARGUMENT
10456: MOV TBLEN(XR),WB LENGTH IF TABLE, VECTOR (=VCLEN)
10457: BTW WB CONVERT TO WORDS
10458: MOV (XR),WA LOAD TYPE WORD OF ARGUMENT BLOCK
10459: BEQ WA,=B$ART,SPRO4 JUMP IF ARRAY
10460: BEQ WA,=B$TBT,SPRO1 JUMP IF TABLE
10461: BEQ WA,=B$VCT,SPRO3 JUMP IF VECTOR
10462: .IF .CNBF
10463: .ELSE
10464: BEQ WA,=B$BCT,SPR05 JUMP IF BUFFER
10465: .FI
10466: ERB 166,PROTOTYPE ARGUMENT IS NOT TABLE OR ARRAY
10467: *
10468: * HERE FOR TABLE
10469: *
10470: SPRO1 SUB =TBSI$,WB SUBTRACT STANDARD FIELDS
10471: *
10472: * MERGE FOR VECTOR
10473: *
10474: SPRO2 MTI WB CONVERT TO INTEGER
10475: BRN EXINT EXIT WITH INTEGER RESULT
10476: *
10477: * HERE FOR VECTOR
10478: *
10479: SPRO3 SUB =VCSI$,WB SUBTRACT STANDARD FIELDS
10480: BRN SPRO2 MERGE
10481: *
10482: * HERE FOR ARRAY
10483: *
10484: SPRO4 ADD AROFS(XR),XR POINT TO PROTOTYPE FIELD
10485: MOV (XR),XR LOAD PROTOTYPE
10486: BRN EXIXR RETURN PROTOTYPE AS RESULT
10487: .IF .CNBF
10488: .ELSE
10489: *
10490: * HERE FOR BUFFER
10491: *
10492: SPR05 MOV BCBUF(XR),XR POINT TO BFBLK
10493: MTI BFALC(XR) LOAD ALLOCATED LENGTH
10494: BRN EXINT EXIT WITH INTEGER ALLOCATION
10495: .FI
10496: EJC
10497: *
10498: * REMDR
10499: *
10500: S$RMD ENT ENTRY POINT
10501: ZER WB SET POSITIVE FLAG
10502: MOV (XS),XR LOAD SECOND ARGUMENT
10503: JSR GTINT CONVERT TO INTEGER
10504: ERR 167,REMDR SECOND ARGUMENT IS NOT INTEGER
10505: JSR ARITH CONVERT ARGS
10506: PPM SRM01 FIRST ARG NOT INTEGER
10507: PPM SECOND ARG CHECKED ABOVE
10508: .IF .CNRA
10509: .ELSE
10510: PPM SRM01 FIRST ARG REAL
10511: .FI
10512: LDI ICVAL(XR) LOAD LEFT ARGUMENT VALUE
10513: RMI ICVAL(XL) GET REMAINDER
10514: INO EXINT JUMP IF NO OVERFLOW
10515: ERB 168,REMDR CAUSED INTEGER OVERFLOW
10516: *
10517: * FAIL FIRST ARGUMENT
10518: *
10519: SRM01 ERB 169,REMDR FIRST ARGUMENT IS NOT INTEGER
10520: EJC
10521: *
10522: * REPLACE
10523: *
10524: * THE ACTUAL REPLACE OPERATION USES AN SCBLK WHOSE CFP$A
10525: * CHARS CONTAIN THE TRANSLATED VERSIONS OF ALL THE CHARS.
10526: * THE TABLE POINTER IS REMEMBERED FROM CALL TO CALL AND
10527: * THE TABLE IS ONLY BUILT WHEN THE ARGUMENTS CHANGE.
10528: *
10529: S$RPL ENT ENTRY POINT
10530: JSR GTSTG LOAD THIRD ARGUMENT AS STRING
10531: ERR 170,REPLACE THIRD ARGUMENT IS NOT STRING
10532: MOV XR,XL SAVE THIRD ARG PTR
10533: JSR GTSTG GET SECOND ARGUMENT
10534: ERR 171,REPLACE SECOND ARGUMENT IS NOT STRING
10535: *
10536: * CHECK TO SEE IF THIS IS THE SAME TABLE AS LAST TIME
10537: *
10538: BNE XR,R$RA2,SRPL1 JUMP IF 2ND ARGUMENT DIFFERENT
10539: BEQ XL,R$RA3,SRPL4 JUMP IF ARGS SAME AS LAST TIME
10540: *
10541: * HERE WE BUILD A NEW REPLACE TABLE (NOTE WA = 2ND ARG LEN)
10542: *
10543: SRPL1 MOV SCLEN(XL),WB LOAD 3RD ARGUMENT LENGTH
10544: BNE WA,WB,SRPL5 JUMP IF ARGUMENTS NOT SAME LENGTH
10545: BZE WB,SRPL5 JUMP IF NULL 2ND ARGUMENT
10546: MOV XL,R$RA3 SAVE THIRD ARG FOR NEXT TIME IN
10547: MOV XR,R$RA2 SAVE SECOND ARG FOR NEXT TIME IN
10548: MOV KVALP,XL POINT TO ALPHABET STRING
10549: MOV SCLEN(XL),WA LOAD ALPHABET SCBLK LENGTH
10550: MOV R$RPT,XR POINT TO CURRENT TABLE (IF ANY)
10551: BNZ XR,SRPL2 JUMP IF WE ALREADY HAVE A TABLE
10552: *
10553: * HERE WE ALLOCATE A NEW TABLE
10554: *
10555: JSR ALOCS ALLOCATE NEW TABLE
10556: MOV WC,WA KEEP SCBLK LENGTH
10557: MOV XR,R$RPT SAVE TABLE POINTER FOR NEXT TIME
10558: *
10559: * MERGE HERE WITH POINTER TO NEW TABLE BLOCK IN (XR)
10560: *
10561: SRPL2 CTB WA,SCSI$ COMPUTE LENGTH OF SCBLK
10562: MVW COPY TO GET INITIAL TABLE VALUES
10563: EJC
10564: *
10565: * REPLACE (CONTINUED)
10566: *
10567: * NOW WE MUST PLUG SELECTED ENTRIES AS REQUIRED. NOTE THAT
10568: * WE ARE SHORT OF INDEX REGISTERS FOR THE FOLLOWING LOOP.
10569: * HENCE THE NEED TO REPEATEDLY RE-INITIALISE CHAR PTR XL
10570: *
10571: MOV R$RA2,XL POINT TO SECOND ARGUMENT
10572: LCT WB,WB NUMBER OF CHARS TO PLUG
10573: ZER WC ZERO CHAR OFFSET
10574: MOV R$RA3,XR POINT TO 3RD ARG
10575: PLC XR GET CHAR PTR FOR 3RD ARG
10576: *
10577: * LOOP TO PLUG CHARS
10578: *
10579: SRPL3 MOV R$RA2,XL POINT TO 2ND ARG
10580: PLC XL,WC POINT TO NEXT CHAR
10581: ICV WC INCREMENT OFFSET
10582: LCH WA,(XL) GET NEXT CHAR
10583: MOV R$RPT,XL POINT TO TRANSLATE TABLE
10584: PSC XL,WA CONVERT CHAR TO OFFSET INTO TABLE
10585: LCH WA,(XR)+ GET TRANSLATED CHAR
10586: SCH WA,(XL) STORE IN TABLE
10587: CSC XL COMPLETE STORE CHARACTERS
10588: BCT WB,SRPL3 LOOP TILL DONE
10589: EJC
10590: *
10591: * REPLACE (CONTINUED)
10592: *
10593: * HERE TO PERFORM TRANSLATE
10594: *
10595: SRPL4 JSR GTSTG GET FIRST ARGUMENT
10596: ERR 172,REPLACE FIRST ARGUMENT IS NOT STRING
10597: BZE WA,EXNUL RETURN NULL IF NULL ARGUMENT
10598: MOV XR,XL COPY POINTER
10599: MOV WA,WC SAVE LENGTH
10600: CTB WA,SCHAR GET SCBLK LENGTH
10601: JSR ALLOC ALLOCATE SPACE FOR COPY
10602: MOV XR,WB SAVE ADDRESS OF COPY
10603: MVW MOVE SCBLK CONTENTS TO COPY
10604: MOV R$RPT,XR POINT TO REPLACE TABLE
10605: PLC XR POINT TO CHARS OF TABLE
10606: MOV WB,XL POINT TO STRING TO TRANSLATE
10607: PLC XL POINT TO CHARS OF STRING
10608: MOV WC,WA SET NUMBER OF CHARS TO TRANSLATE
10609: TRC PERFORM TRANSLATION
10610: MOV WB,-(XS) STACK NEW STRING AS RESULT
10611: BRN EXITS RETURN WITH RESULT ON STACK
10612: *
10613: * ERROR POINT
10614: *
10615: SRPL5 ERB 173,NULL OR UNEQUALLY LONG 2ND, 3RD ARGS TO REPLACE
10616: EJC
10617: *
10618: * REVERSE
10619: *
10620: S$RVS ENT ENTRY POINT
10621: JSR GTSTG LOAD STRING ARGUMENT
10622: ERR 174,REVERSE ARGUMENT IS NOT STRING
10623: BZE WA,EXIXR RETURN ARGUMENT IF NULL
10624: MOV XR,XL ELSE SAVE POINTER TO STRING ARG
10625: JSR ALOCS ALLOCATE SPACE FOR NEW SCBLK
10626: MOV XR,-(XS) STORE SCBLK PTR ON STACK AS RESULT
10627: PSC XR PREPARE TO STORE IN NEW SCBLK
10628: PLC XL,WC POINT PAST LAST CHAR IN ARGUMENT
10629: LCT WC,WC SET LOOP COUNTER
10630: *
10631: * LOOP TO MOVE CHARS IN REVERSE ORDER
10632: *
10633: SRVS1 LCH WB,-(XL) LOAD NEXT CHAR FROM ARGUMENT
10634: SCH WB,(XR)+ STORE IN RESULT
10635: BCT WC,SRVS1 LOOP TILL ALL MOVED
10636: CSC XR COMPLETE STORE CHARACTERS
10637: BRN EXITS AND THEN JUMP FOR NEXT CODE WORD
10638: EJC
10639: *
10640: * RPAD
10641: *
10642: S$RPD ENT ENTRY POINT
10643: JSR GTSTG GET PAD CHARACTER
10644: ERR 175,RPAD THIRD ARGUMENT IS NOT STRING
10645: PLC XR POINT TO CHARACTER (NULL IS BLANK)
10646: LCH WB,(XR) LOAD PAD CHARACTER
10647: JSR GTSMI GET PAD LENGTH
10648: ERR 176,RPAD SECOND ARGUMENT IS NOT INTEGER
10649: PPM SRPD3 SKIP IF NEGATIVE OR LARGE
10650: *
10651: * MERGE TO CHECK FIRST ARG.
10652: *
10653: SRPD1 JSR GTSTG GET FIRST ARGUMENT (STRING TO PAD)
10654: ERR 177,RPAD FIRST ARGUMENT IS NOT STRING
10655: BGE WA,WC,EXIXR RETURN 1ST ARG IF TOO LONG TO PAD
10656: MOV XR,XL ELSE MOVE PTR TO STRING TO PAD
10657: *
10658: * NOW WE ARE READY FOR THE PAD
10659: *
10660: * (XL) POINTER TO STRING TO PAD
10661: * (WB) PAD CHARACTER
10662: * (WC) LENGTH TO PAD STRING TO
10663: *
10664: MOV WC,WA COPY LENGTH
10665: JSR ALOCS ALLOCATE SCBLK FOR NEW STRING
10666: MOV XR,-(XS) SAVE AS RESULT
10667: MOV SCLEN(XL),WA LOAD LENGTH OF ARGUMENT
10668: SUB WA,WC CALCULATE NUMBER OF PAD CHARACTERS
10669: PSC XR POINT TO CHARS IN RESULT STRING
10670: LCT WC,WC SET COUNTER FOR PAD LOOP
10671: *
10672: * COPY ARGUMENT STRING
10673: *
10674: BZE WA,SRPD2 JUMP IF ARGUMENT IS NULL
10675: PLC XL ELSE POINT TO ARGUMENT CHARS
10676: MVC MOVE CHARACTERS TO RESULT STRING
10677: *
10678: * LOOP TO SUPPLY PAD CHARACTERS
10679: *
10680: SRPD2 SCH WB,(XR)+ STORE PAD CHARACTER, BUMP PTR
10681: BCT WC,SRPD2 LOOP TILL ALL PAD CHARS STORED
10682: CSC XR COMPLETE CHARACTER STORING
10683: BRN EXITS AND EXIT FOR NEXT WORD
10684: *
10685: * HERE IF 2ND ARG IS NEGATIVE OR LARGE
10686: *
10687: SRPD3 ZER WC ZERO PAD COUNT
10688: BRN SRPD1 MERGE
10689: EJC
10690: *
10691: * RTAB
10692: *
10693: S$RTB ENT ENTRY POINT
10694: MOV =P$RTB,WB SET PCODE FOR INTEGER ARG CASE
10695: MOV =P$RTD,WA SET PCODE FOR EXPRESSION ARG CASE
10696: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE
10697: ERR 178,RTAB ARGUMENT IS NOT INTEGER OR EXPRESSION
10698: ERR 179,RTAB ARGUMENT IS NEGATIVE OR TOO LARGE
10699: BRN EXIXR RETURN PATTERN NODE
10700: EJC
10701: .IF .CUST
10702: *
10703: * SET
10704: *
10705: S$SET ENT ENTRY POINT
10706: MOV (XS)+,R$IOL SAVE THIRD ARG
10707: MOV (XS)+,R$IO1 SAVE SECOND ARG
10708: JSR IOFTG CALL IOTAG ROUTINE
10709: ERR 180,SET FIRST ARGUMENT IS NOT A SUITABLE NAME
10710: BZE WA,EXFAL FAIL IF NO IOTAG
10711: MOV R$IO1,WB LOAD SECOND ARG
10712: MOV R$IOL,WC LOAD THIRD ARG
10713: JSR SYSST CALL SYSTEM SET ROUTINE
10714: PPM EXFAL FAILURE RETURN
10715: PPM EROSI ERROR RETURN
10716: BRN EXNUL OTHERWISE RETURN NULL
10717: EJC
10718: .FI
10719: *
10720: * RPOS
10721: *
10722: S$RPS ENT ENTRY POINT
10723: MOV =P$RPS,WB SET PCODE FOR INTEGER ARG CASE
10724: MOV =P$RPD,WA SET PCODE FOR EXPRESSION ARG CASE
10725: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE
10726: ERR 181,RPOS ARGUMENT IS NOT INTEGER OR EXPRESSION
10727: ERR 182,RPOS ARGUMENT IS NEGATIVE OR TOO LARGE
10728: BRN EXIXR RETURN PATTERN NODE
10729: .IF .CNSR
10730: .ELSE
10731: EJC
10732: *
10733: * RSORT
10734: *
10735: S$RSR ENT ENTRY POINT
10736: MNZ WA MARK AS RSORT
10737: JSR SORTA CALL SORT ROUTINE
10738: PPM EXFAL FAIL EMPTY TABLE
10739: BRN EXSID RETURN, SETTING IDVAL
10740: .FI
10741: EJC
10742: *
10743: * SETEXIT
10744: *
10745: S$STX ENT ENTRY POINT
10746: MOV (XS)+,XR LOAD ARGUMENT
10747: MOV STXVR,WA LOAD OLD VRBLK POINTER
10748: ZER XL LOAD ZERO IN CASE NULL ARG
10749: BEQ XR,=NULLS,SSTX1 JUMP IF NULL ARGUMENT (RESET CALL)
10750: JSR GTNVR ELSE GET SPECIFIED VRBLK
10751: PPM SSTX2 JUMP IF NOT NATURAL VARIABLE
10752: MOV VRLBL(XR),XL ELSE LOAD LABEL
10753: BEQ XL,=STNDL,SSTX2 JUMP IF LABEL IS NOT DEFINED
10754: BNE (XL),=B$TRT,SSTX1 JUMP IF NOT TRAPPED
10755: MOV TRLBL(XL),XL ELSE LOAD PTR TO REAL LABEL CODE
10756: *
10757: * HERE TO SET/RESET SETEXIT TRAP
10758: *
10759: SSTX1 MOV XR,STXVR STORE NEW VRBLK POINTER (OR NULL)
10760: MOV XL,R$SXC STORE NEW CODE PTR (OR ZERO)
10761: BEQ WA,=NULLS,EXNUL RETURN NULL IF NULL RESULT
10762: MOV WA,XR ELSE COPY VRBLK POINTER
10763: BRN EXVNM AND RETURN BUILDING NMBLK
10764: *
10765: * HERE IF BAD ARGUMENT
10766: *
10767: SSTX2 ERB 183,SETEXIT ARGUMENT IS NOT LABEL NAME OR NULL
10768: .IF .CNSR
10769: .ELSE
10770: EJC
10771: *
10772: * SORT
10773: *
10774: S$SRT ENT ENTRY POINT
10775: ZER WA MARK AS SORT
10776: JSR SORTA CALL SORT ROUTINE
10777: PPM EXFAL FAIL EMPTY TABLE
10778: BRN EXSID RETURN, SETTING IDVAL
10779: .FI
10780: EJC
10781: *
10782: * SPAN
10783: *
10784: S$SPN ENT ENTRY POINT
10785: MOV =P$SPS,WB SET PCODE FOR SINGLE CHAR ARG
10786: MOV =P$SPN,XL SET PCODE FOR MULTI-CHAR ARG
10787: MOV =P$SPD,WC SET PCODE FOR EXPRESSION ARG
10788: JSR PATST CALL COMMON ROUTINE TO BUILD NODE
10789: ERR 184,SPAN ARGUMENT IS NOT STRING OR EXPRESSION
10790: BRN EXIXR JUMP FOR NEXT CODE WORD
10791: EJC
10792: *
10793: * SIZE
10794: *
10795: S$SI$ ENT ENTRY POINT
10796: .IF .CNBF
10797: JSR GTSTG LOAD STRING ARGUMENT
10798: .ELSE
10799: MOV (XS),XR LOAD ARGUMENT
10800: BNE (XR),=B$BCT,SSI$1 BRANCH IF NOT BUFFER
10801: ICA XS ELSE POP ARGUMENT
10802: MTI BCLEN(XR) LOAD DEFINED LENGTH
10803: BRN EXINT EXIT WITH INTEGER
10804: *
10805: * HERE IF NOT BUFFER
10806: *
10807: SSI$1 JSR GTSTG LOAD STRING ARGUMENT
10808: .FI
10809: ERR 185,SIZE ARGUMENT IS NOT STRING
10810: MTI WA LOAD LENGTH AS INTEGER
10811: BRN EXINT EXIT WITH INTEGER RESULT
10812: EJC
10813: *
10814: * STOPTR
10815: *
10816: S$STT ENT ENTRY POINT
10817: ZER XL INDICATE STOPTR CASE
10818: JSR TRACE CALL TRACE PROCEDURE
10819: ERR 186,STOPTR FIRST ARGUMENT IS NOT APPROPRIATE NAME
10820: ERR 187,STOPTR SECOND ARGUMENT IS NOT TRACE TYPE
10821: PPM EXFAL FAIL RETURN
10822: BRN EXNUL RETURN NULL
10823: EJC
10824: *
10825: * SUBSTR
10826: *
10827: S$SUB ENT ENTRY POINT
10828: JSR GTSMI LOAD THIRD ARGUMENT
10829: ERR 188,SUBSTR THIRD ARGUMENT IS NOT INTEGER
10830: PPM EXFAL JUMP IF NEGATIVE OR TOO LARGE
10831: MOV XR,SBSSV SAVE THIRD ARGUMENT
10832: JSR GTSMI LOAD SECOND ARGUMENT
10833: ERR 189,SUBSTR SECOND ARGUMENT IS NOT INTEGER
10834: PPM EXFAL JUMP IF OUT OF RANGE
10835: MOV XR,WB SAVE SECOND ARGUMENT
10836: BZE WB,EXFAL JUMP IF SECOND ARGUMENT ZERO
10837: DCV WB ELSE DECREMENT FOR ONES ORIGIN
10838: .IF .CNBF
10839: JSR GTSTG LOAD FIRST ARGUMENT
10840: .ELSE
10841: MOV (XS),XL GET FIRST ARG PTR
10842: BNE (XL),=B$BCT,SSUBA BRANCH IF NOT BUFFER
10843: MOV BCBUF(XL),XR GET BFBLK PTR
10844: MOV BCLEN(XL),WA GET LENGTH
10845: BRN SSUBB MERGE
10846: *
10847: * HERE IF NOT BUFFER TO GET STRING
10848: *
10849: SSUBA JSR GTSTG LOAD FIRST ARGUMENT
10850: .FI
10851: ERR 190,SUBSTR FIRST ARGUMENT IS NOT STRING
10852: MOV XR,XL COPY POINTER TO FIRST ARG
10853: .IF .CNBF
10854: MOV SBSSV,WC RELOAD THIRD ARGUMENT
10855: .ELSE
10856: *
10857: * MERGE WITH BFBLK OR SCBLK IN XR, LENGTH IN WA
10858: *
10859: SSUBB MOV SBSSV,WC RELOAD THIRD ARGUMENT
10860: .FI
10861: BNZ WC,SSUB1 SKIP IF THIRD ARG GIVEN
10862: MOV SCLEN(XL),WC ELSE GET STRING LENGTH
10863: BGT WB,WC,EXFAL FAIL IF IMPROPER
10864: SUB WB,WC REDUCE BY OFFSET TO START
10865: *
10866: * MERGE
10867: *
10868: SSUB1 MOV WC,WA SET LENGTH OF SUBSTRING
10869: ADD WB,WC ADD 2ND ARG TO 3RD ARG
10870: BGT WC,SCLEN(XL),EXFAL JUMP IF IMPROPER SUBSTRING
10871: JSR SBSTR BUILD SUBSTRING
10872: BRN EXIXR AND JUMP FOR NEXT CODE WORD
10873: EJC
10874: *
10875: * TAB
10876: *
10877: S$TAB ENT ENTRY POINT
10878: MOV =P$TAB,WB SET PCODE FOR INTEGER ARG CASE
10879: MOV =P$TBD,WA SET PCODE FOR EXPRESSION ARG CASE
10880: JSR PATIN CALL COMMON ROUTINE TO BUILD NODE
10881: ERR 191,TAB ARGUMENT IS NOT INTEGER OR EXPRESSION
10882: ERR 192,TAB ARGUMENT IS NEGATIVE OR TOO LARGE
10883: BRN EXIXR RETURN PATTERN NODE
10884: EJC
10885: *
10886: * TABLE
10887: *
10888: S$TBL ENT ENTRY POINT
10889: MOV (XS)+,XL GET INITIAL LOOKUP VALUE
10890: ICA XS POP SECOND ARGUMENT
10891: JSR GTSMI LOAD ARGUMENT
10892: ERR 193,TABLE ARGUMENT IS NOT INTEGER
10893: ERR 194,TABLE ARGUMENT IS OUT OF RANGE
10894: BNZ WC,STBL1 JUMP IF NON-ZERO
10895: MOV =TBNBK,WC ELSE SUPPLY DEFAULT VALUE
10896: *
10897: * MERGE HERE WITH NUMBER OF HEADERS IN WA
10898: *
10899: STBL1 MOV WC,WA COPY NUMBER OF HEADERS
10900: ADD =TBSI$,WA ADJUST FOR STANDARD FIELDS
10901: WTB WA CONVERT LENGTH TO BAUS
10902: JSR ALLOC ALLOCATE SPACE FOR TBBLK
10903: MOV XR,WB COPY POINTER TO TBBLK
10904: MOV =B$TBT,(XR)+ STORE TYPE WORD
10905: ZER (XR)+ ZERO ID FOR THE MOMENT
10906: MOV WA,(XR)+ STORE LENGTH (TBLEN)
10907: MOV XL,(XR)+ STORE INITIAL LOOKUP VALUE
10908: LCT WC,WC SET LOOP COUNTER (NUM HEADERS)
10909: *
10910: * LOOP TO INITIALIZE ALL BUCKET POINTERS
10911: *
10912: STBL2 MOV WB,(XR)+ STORE TBBLK PTR IN BUCKET HEADER
10913: BCT WC,STBL2 LOOP TILL ALL STORED
10914: MOV WB,XR RECALL POINTER TO TBBLK
10915: BRN EXSID EXIT SETTING IDVAL
10916: EJC
10917: *
10918: * TIME
10919: *
10920: S$TIM ENT ENTRY POINT
10921: JSR SYSTM GET TIMER VALUE
10922: SBI TIMSX SUBTRACT STARTING TIME
10923: BRN EXINT EXIT WITH INTEGER VALUE
10924: EJC
10925: *
10926: * TRACE
10927: *
10928: S$TRA ENT ENTRY POINT
10929: BEQ 3(XS),=NULLS,STR03 JUMP IF FIRST ARGUMENT IS NULL
10930: MOV (XS)+,XR LOAD FOURTH ARGUMENT
10931: ZER XL TENTATIVELY SET ZERO POINTER
10932: BEQ XR,=NULLS,STR02 JUMP IF 4TH ARGUMENT IS NULL
10933: JSR GTNVR ELSE POINT TO VRBLK
10934: PPM STR01 JUMP IF NOT VARIABLE NAME
10935: MOV VRFNC(XR),XL ELSE LOAD FUNCTION POINTER
10936: BNE XL,=STNDF,STR02 JUMP IF FUNCTION IS DEFINED
10937: *
10938: * HERE FOR BAD FOURTH ARGUMENT
10939: *
10940: STR01 ERB 195,TRACE FOURTH ARG IS NOT FUNCTION NAME OR NULL
10941: *
10942: * HERE WITH FUNCTION POINTER IN XL
10943: *
10944: STR02 MOV (XS)+,XR LOAD THIRD ARGUMENT (TAG)
10945: ZER WB SET ZERO AS TRTYP VALUE FOR NOW
10946: JSR TRBLD BUILD TRBLK FOR TRACE CALL
10947: MOV XR,XL MOVE TRBLK POINTER FOR TRACE
10948: JSR TRACE CALL TRACE PROCEDURE
10949: ERR 196,TRACE FIRST ARGUMENT IS NOT APPROPRIATE NAME
10950: ERR 197,TRACE SECOND ARGUMENT IS NOT TRACE TYPE
10951: PPM UNUSED RETURN
10952: BRN EXNUL RETURN NULL
10953: *
10954: * HERE TO CALL SYSTEM TRACE TOGGLE ROUTINE
10955: *
10956: STR03 JSR SYSTT CALL IT
10957: ADD *NUM04,XS POP TRACE ARGUMENTS
10958: BRN EXNUL RETURN
10959: EJC
10960: *
10961: * TRIM
10962: *
10963: S$TRM ENT ENTRY POINT
10964: JSR GTSTG LOAD ARGUMENT AS STRING
10965: ERR 198,TRIM ARGUMENT IS NOT STRING
10966: BZE WA,EXNUL RETURN NULL IF ARGUMENT IS NULL
10967: MOV XR,XL COPY STRING POINTER
10968: CTB WA,SCHAR GET BLOCK LENGTH
10969: JSR ALLOC ALLOCATE COPY SAME SIZE
10970: MOV XR,WB SAVE POINTER TO COPY
10971: MVW COPY OLD STRING BLOCK TO NEW
10972: MOV WB,XR RESTORE PTR TO NEW BLOCK
10973: JSR TRIMR TRIM BLANKS (WB IS NON-ZERO)
10974: BRN EXIXR EXIT WITH RESULT IN XR
10975: EJC
10976: *
10977: * UNLOAD
10978: *
10979: S$UNL ENT ENTRY POINT
10980: MOV (XS)+,XR LOAD ARGUMENT
10981: JSR GTNVR POINT TO VRBLK
10982: ERR 199,UNLOAD ARGUMENT IS NOT NATURAL VARIABLE NAME
10983: MOV =STNDF,XL GET PTR TO UNDEFINED FUNCTION
10984: JSR DFFNC UNDEFINE NAMED FUNCTION
10985: BRN EXNUL RETURN NULL AS RESULT
10986: EJC
10987: *
10988: * VDIFFER
10989: *
10990: S$VDF ENT ENTRY POINT
10991: MOV (XS)+,XR LOAD SECOND ARGUMENT
10992: MOV (XS),XL LOAD FIRST ARGUMENT
10993: JSR IDENT CALL IDENT COMPARISON ROUTINE
10994: PPM EXFAL FAIL IF IDENT
10995: BRN EXITS RETURN FIRST ARG IF DIFFER
10996: TTL S P I T B O L -- UTILITY PROCEDURES
10997: *
10998: * THE FOLLOWING SECTION CONTAINS PROCEDURES WHICH ARE
10999: * USED FOR VARIOUS PURPOSES THROUGHOUT THE SYSTEM.
11000: *
11001: * EACH PROCEDURE IS PRECEDED BY A DESCRIPTION OF THE
11002: * CALLING SEQUENCE. USUALLY THE ARGUMENTS ARE IN REGISTERS
11003: * BUT ARGUMENTS CAN ALSO OCCUR ON THE STACK AND AS
11004: * PARAMETERS ASSEMBLED AFTER THE JSR INSTRUCTION.
11005: *
11006: * THE FOLLOWING CONSIDERATIONS APPLY TO THESE DESCRIPTIONS.
11007: *
11008: * 1) THE STACK POINTER (XS) IS NOT CHANGED UNLESS THE
11009: * CHANGE IS EXPLICITLY DOCUMENTED IN THE CALL.
11010: *
11011: * 2) REGISTERS WHOSE ENTRY VALUES ARE NOT MENTIONED
11012: * MAY CONTAIN ANY VALUE EXCEPT THAT XL,XR MAY ONLY
11013: * CONTAIN PROPER (COLLECTABLE) POINTER VALUES.
11014: * THIS CONDITION ON XR MEANS THAT THE CALLED ROUTINE
11015: * MAY IF IT CHOOSES PRESERVE XR BY STACKING.
11016: *
11017: * 3) REGISTERS NOT MENTIONED ON EXIT CONTAIN THE SAME
11018: * VALUES AS THEY DID ON ENTRY EXCEPT THAT VALUES IN
11019: * XR,XL MAY HAVE BEEN RELOCATED BY THE COLLECTOR.
11020: *
11021: * 4) REGISTERS WHICH ARE DESTROYED ON EXIT MAY CONTAIN
11022: * ANY VALUE EXCEPT THAT VALUES IN XL,XR ARE PROPER
11023: * (COLLECTABLE) POINTERS.
11024: *
11025: * 5) THE CODE POINTER REGISTER POINTS TO THE CURRENT
11026: * CODE LOCATION ON ENTRY AND IS UNCHANGED ON EXIT.
11027: *
11028: * IN THE ABOVE DESCRIPTION, A COLLECTABLE POINTER IS ONE
11029: * WHICH EITHER POINTS OUTSIDE THE DYNAMIC REGION OR
11030: * POINTS TO THE START OF A BLOCK IN THE DYNAMIC REGION.
11031: *
11032: * IN THOSE CASES WHERE THE CALLING SEQUENCE CONTAINS
11033: * PARAMETERS WHICH ARE USED AS ALTERNATE RETURN POINTS,
11034: * THESE PARAMETERS MAY BE REPLACED BY ERROR CODES
11035: * ASSEMBLED WITH THE ERR INSTRUCTION. THIS WILL RESULT
11036: * IN THE POSTING OF THE ERROR IF THE RETURN IS TAKEN.
11037: *
11038: * THE PROCEDURES ALL HAVE NAMES CONSISTING OF FIVE LETTERS
11039: * AND ARE IN ALPHABETICAL ORDER BY THEIR NAMES.
11040: EJC
11041: *
11042: * ACESS - ACCESS VARIABLE VALUE WITH TRACE/INPUT CHECKS
11043: *
11044: * ACESS LOADS THE VALUE OF A VARIABLE. TRACE AND INPUT
11045: * ASSOCIATIONS ARE TESTED FOR AND EXECUTED AS REQUIRED.
11046: * ACESS ALSO HANDLES THE SPECIAL CASES OF PSEUDO-VARIABLES.
11047: *
11048: * (XL) VARIABLE NAME BASE
11049: * (WA) VARIABLE NAME OFFSET
11050: * JSR ACESS CALL TO ACCESS VALUE
11051: * PPM LOC TRANSFER LOC IF ACCESS FAILURE
11052: * (XR) VARIABLE VALUE
11053: * (WA,WB,WC) DESTROYED
11054: * (XL,RA) DESTROYED
11055: *
11056: * FAILURE CAN OCCUR IF AN INPUT ASSOCIATION CAUSES AN END
11057: * OF FILE CONDITION OR IF THE EVALUATION OF AN EXPRESSION
11058: * ASSOCIATED WITH AN EXPRESSION VARIABLE FAILS.
11059: *
11060: ACESS PRC R,1 ENTRY POINT (RECURSIVE)
11061: MOV XL,XR COPY NAME BASE
11062: ADD WA,XR POINT TO VARIABLE LOCATION
11063: MOV (XR),XR LOAD VARIABLE VALUE
11064: *
11065: * LOOP HERE TO CHECK FOR SUCCESSIVE TRBLKS
11066: *
11067: ACS02 BNE (XR),=B$TRT,ACS18 JUMP IF NOT TRAPPED
11068: *
11069: * HERE IF TRAPPED
11070: *
11071: BEQ XR,=TRBKV,ACS12 JUMP IF KEYWORD VARIABLE
11072: BNE XR,=TRBEV,ACS05 JUMP IF NOT EXPRESSION VARIABLE
11073: *
11074: * HERE FOR EXPRESSION VARIABLE, EVALUATE VARIABLE
11075: *
11076: MOV EVEXP(XL),XR LOAD EXPRESSION POINTER
11077: ZER WB EVALUATE BY VALUE
11078: JSR EVALX EVALUATE EXPRESSION
11079: PPM ACS04 JUMP IF EVALUATION FAILURE
11080: BRN ACS02 CHECK VALUE FOR MORE TRBLKS
11081: EJC
11082: *
11083: * ACESS (CONTINUED)
11084: *
11085: * HERE ON READING END OF FILE
11086: *
11087: ACS03 ADD *NUM03,XS POP TRBLK PTR, NAME BASE AND OFFSET
11088: MOV XR,DNAMP POP UNUSED SCBLK
11089: *
11090: * MERGE HERE WHEN EVALUATION OF EXPRESSION FAILS
11091: *
11092: ACS04 EXI 1 TAKE ALTERNATE (FAILURE) RETURN
11093: *
11094: * HERE IF NOT KEYWORD OR EXPRESSION VARIABLE
11095: *
11096: ACS05 MOV TRTYP(XR),WB LOAD TRAP TYPE CODE
11097: BNZ WB,ACS10 JUMP IF NOT INPUT ASSOCIATION
11098: BZE KVINP,ACS09 IGNORE INPUT ASSOC IF INPUT IS OFF
11099: *
11100: * HERE FOR INPUT ASSOCIATION
11101: *
11102: MOV XL,-(XS) STACK NAME BASE
11103: MOV WA,-(XS) STACK NAME OFFSET
11104: MOV XR,-(XS) STACK TRBLK POINTER
11105: MOV TRTRI(XR),XL GET TRTIO BLOCK PTR OR 0
11106: BNZ XL,ACS06 JUMP IF NOT STANDARD INPUT FILE
11107: BEQ TRTER(XR),=V$TER,ACS21 JUMP IF TERMINAL
11108: *
11109: * HERE TO READ FROM STANDARD INPUT FILE
11110: *
11111: MOV CSWIN,WA LENGTH FOR READ BUFFER
11112: JSR ALOCS BUILD STRING OF APPROPRIATE LENGTH
11113: BZE TTINS,ACSA5 SKIP IF NOT TERML STD INPUT
11114: JSR SYSRI READ FROM TERMINAL
11115: PPM ACS03 END FILE
11116: PPM EROSI ERROR
11117: BRN ACS07 MERGE
11118: *
11119: * GENUINE STD INPUT FILE
11120: *
11121: ACSA5 JSR SYSRD READ NEXT STANDARD INPUT IMAGE
11122: PPM ACS03 JUMP TO FAIL EXIT IF END OF FILE
11123: PPM EROSI ERROR RETURN
11124: BRN ACS07 ELSE MERGE WITH OTHER FILE CASE
11125: *
11126: * HERE FOR INPUT FROM OTHER THAN STANDARD INPUT FILE
11127: *
11128: ACS06 MOV TRTAG(XL),WA OBTAIN IOTAG
11129: BZE WA,ACS03 FAIL IF ENDFILE DONE
11130: JSR SYSIL GET INPUT RECORD MAX LENGTH (TO WA)
11131: JSR ALOCS ALLOCATE STRING OF CORRECT SIZE
11132: MOV TRTAG(XL),WA GET IOTAG
11133: JSR SYSIN CALL SYSTEM INPUT ROUTINE
11134: PPM ACS03 JUMP TO FAIL EXIT IF END OF FILE
11135: PPM ACS22 ERROR RETURN
11136: EJC
11137: *
11138: * ACESS (CONTINUED)
11139: *
11140: * MERGE HERE AFTER OBTAINING INPUT RECORD
11141: *
11142: ACS07 MOV KVTRM,WB LOAD TRIM INDICATOR
11143: JSR TRIMR TRIM RECORD AS REQUIRED
11144: MOV XR,WB COPY RESULT POINTER
11145: MOV (XS),XR RELOAD POINTER TO TRBLK
11146: *
11147: * LOOP TO CHASE TO END OF TRBLK CHAIN AND STORE VALUE
11148: *
11149: ACS08 MOV XR,XL SAVE POINTER TO THIS TRBLK
11150: MOV TRNXT(XR),XR LOAD FORWARD POINTER
11151: BEQ (XR),=B$TRT,ACS08 LOOP IF THIS IS ANOTHER TRBLK
11152: MOV WB,TRNXT(XL) ELSE STORE RESULT AT END OF CHAIN
11153: MOV (XS)+,XR RESTORE INITIAL TRBLK POINTER
11154: MOV (XS)+,WA RESTORE NAME OFFSET
11155: MOV (XS)+,XL RESTORE NAME BASE POINTER
11156: *
11157: * COME HERE TO MOVE TO NEXT TRBLK
11158: *
11159: ACS09 MOV TRNXT(XR),XR LOAD FORWARD PTR TO NEXT VALUE
11160: BRN ACS02 BACK TO CHECK IF TRAPPED
11161: *
11162: * HERE TO CHECK FOR ACCESS TRACE TRBLK
11163: *
11164: ACS10 BNE WB,=TRTAC,ACS09 LOOP BACK IF NOT ACCESS TRACE
11165: BZE KVTRA,ACS09 IGNORE ACCESS TRACE IF TRACE OFF
11166: DCV KVTRA ELSE DECREMENT TRACE COUNT
11167: BZE TRFNC(XR),ACS11 JUMP IF PRINT TRACE
11168: EJC
11169: *
11170: * ACESS (CONTINUED)
11171: *
11172: * HERE FOR FULL FUNCTION TRACE
11173: *
11174: JSR TRXEQ CALL ROUTINE TO EXECUTE TRACE
11175: BRN ACS09 JUMP FOR NEXT TRBLK
11176: *
11177: * HERE FOR CASE OF PRINT TRACE
11178: *
11179: ACS11 JSR PRTSN PRINT STATEMENT NUMBER
11180: JSR PRTNV PRINT NAME = VALUE
11181: BRN ACS09 JUMP BACK FOR NEXT TRBLK
11182: *
11183: * HERE FOR KEYWORD VARIABLE
11184: *
11185: ACS12 MOV KVNUM(XL),XR LOAD KEYWORD NUMBER
11186: BGE XR,=K$V$$,ACS14 JUMP IF NOT ONE WORD VALUE
11187: MTI KVANC(XR) ELSE LOAD VALUE AS INTEGER
11188: *
11189: * COMMON EXIT WITH KEYWORD VALUE AS INTEGER IN (IA)
11190: *
11191: ACS13 JSR ICBLD BUILD ICBLK
11192: BRN ACS18 JUMP TO EXIT
11193: *
11194: * HERE IF NOT ONE WORD KEYWORD VALUE
11195: *
11196: ACS14 BGE XR,=K$S$$,ACS15 JUMP IF SPECIAL CASE
11197: SUB =K$V$$,XR ELSE GET OFFSET
11198: WTB XR CONVERT TO OFFSET IN BAUS
11199: ADD =NDABO,XR POINT TO PATTERN VALUE
11200: BRN ACS18 JUMP TO EXIT
11201: *
11202: * HERE IF SPECIAL KEYWORD CASE
11203: *
11204: ACS15 MOV KVRTN,XL LOAD RTNTYPE IN CASE
11205: LDI KVSTL LOAD STLIMIT IN CASE
11206: SUB =K$S$$,XR GET CASE NUMBER
11207: BSW XR,6 SWITCH ON KEYWORD NUMBER
11208: IFF K$$AL,ACS16 JUMP IF ALPHABET
11209: IFF K$$RT,ACS17 RTNTYPE
11210: IFF K$$CD,ACS23 CODE
11211: IFF K$$SC,ACS19 STCOUNT
11212: IFF K$$SL,ACS13 STLIMIT
11213: IFF K$$ET,ACS20 ERRTEXT
11214: ESW END SWITCH ON KEYWORD NUMBER
11215: EJC
11216: *
11217: * ACESS (CONTINUED)
11218: *
11219: * ALPHABET
11220: *
11221: ACS16 MOV KVALP,XL LOAD POINTER TO ALPHABET STRING
11222: *
11223: * RTNTYPE MERGES HERE
11224: *
11225: ACS17 MOV XL,XR COPY STRING PTR TO PROPER REG
11226: *
11227: * COMMON RETURN POINT
11228: *
11229: ACS18 EXI RETURN TO ACESS CALLER
11230: *
11231: * HERE FOR STCOUNT (IA HAS STLIMIT)
11232: *
11233: ACS19 SBI KVSTC STCOUNT = LIMIT - LEFT
11234: BRN ACS13 MERGE BACK WITH INTEGER RESULT
11235: *
11236: * ERRTEXT
11237: *
11238: ACS20 MOV R$ETX,XR GET ERRTEXT STRING
11239: BRN ACS18 MERGE WITH RESULT
11240: *
11241: * HERE TO READ A RECORD FROM TERMINAL
11242: *
11243: ACS21 MOV =RILEN,WA BUFFER LENGTH
11244: JSR ALOCS ALLOCATE BUFFER
11245: JSR SYSRI READ RECORD
11246: PPM ACS03 ENDFILE
11247: PPM EROSI ERROR RETURN
11248: BRN ACS07 MERGE WITH RECORD READ
11249: *
11250: * ERROR RETURN
11251: *
11252: ACS22 MOV XR,DNAMP POP UNUSED SCBLK
11253: BRN EROSI GENERATE ERROR MESSAGE
11254: *
11255: * ACCESS CODE KEYWORD
11256: *
11257: ACS23 LDI KVCOD GET CODE VALUE
11258: BRN ACS13 EXIT
11259: ENP END PROCEDURE ACESS
11260: EJC
11261: *
11262: * ACOMP -- COMPARE TWO ARITHMETIC VALUES
11263: *
11264: * 1(XS) FIRST ARGUMENT
11265: * 0(XS) SECOND ARGUMENT
11266: * JSR ACOMP CALL TO COMPARE VALUES
11267: * PPM LOC TRANSFER LOC IF ARG1 IS NON-NUMERIC
11268: * PPM LOC TRANSFER LOC IF ARG2 IS NON-NUMERIC
11269: * PPM LOC TRANSFER LOC FOR ARG1 LT ARG2
11270: * PPM LOC TRANSFER LOC FOR ARG1 EQ ARG2
11271: * PPM LOC TRANSFER LOC FOR ARG1 GT ARG2
11272: * (NORMAL RETURN IS NEVER GIVEN)
11273: * (WA,WB,WC,IA,RA) DESTROYED
11274: * (XL,XR) DESTROYED
11275: *
11276: ACOMP PRC N,5 ENTRY POINT
11277: JSR ARITH LOAD ARITHMETIC OPERANDS
11278: PPM ACMP7 JUMP IF FIRST ARG NON-NUMERIC
11279: PPM ACMP8 JUMP IF SECOND ARG NON-NUMERIC
11280: .IF .CNRA
11281: .ELSE
11282: PPM ACMP4 JUMP IF REAL ARGUMENTS
11283: .FI
11284: *
11285: * HERE FOR INTEGER ARGUMENTS
11286: *
11287: SBI ICVAL(XL) SUBTRACT TO COMPARE
11288: IOV ACMP3 JUMP IF OVERFLOW
11289: ILT ACMP5 ELSE JUMP IF ARG1 LT ARG2
11290: IEQ ACMP2 JUMP IF ARG1 EQ ARG2
11291: *
11292: * HERE IF ARG1 GT ARG2
11293: *
11294: ACMP1 EXI 5 TAKE GT EXIT
11295: *
11296: * HERE IF ARG1 EQ ARG2
11297: *
11298: ACMP2 EXI 4 TAKE EQ EXIT
11299: EJC
11300: *
11301: * ACOMP (CONTINUED)
11302: *
11303: * HERE FOR INTEGER OVERFLOW ON SUBTRACT
11304: *
11305: ACMP3 LDI ICVAL(XL) LOAD SECOND ARGUMENT
11306: ILT ACMP1 GT IF NEGATIVE
11307: BRN ACMP5 ELSE LT
11308: .IF .CNRA
11309: .ELSE
11310: *
11311: * HERE FOR REAL OPERANDS
11312: *
11313: ACMP4 SBR RCVAL(XL) SUBTRACT TO COMPARE
11314: ROV ACMP6 JUMP IF OVERFLOW
11315: RGT ACMP1 ELSE JUMP IF ARG1 GT
11316: REQ ACMP2 JUMP IF ARG1 EQ ARG2
11317: .FI
11318: *
11319: * HERE IF ARG1 LT ARG2
11320: *
11321: ACMP5 EXI 3 TAKE LT EXIT
11322: .IF .CNRA
11323: .ELSE
11324: *
11325: * HERE IF OVERFLOW ON REAL SUBTRACTION
11326: *
11327: ACMP6 LDR RCVAL(XL) RELOAD ARG2
11328: RLT ACMP1 GT IF NEGATIVE
11329: BRN ACMP5 ELSE LT
11330: .FI
11331: *
11332: * HERE IF ARG1 NON-NUMERIC
11333: *
11334: ACMP7 EXI 1 TAKE ERROR EXIT
11335: *
11336: * HERE IF ARG2 NON-NUMERIC
11337: *
11338: ACMP8 EXI 2 TAKE ERROR EXIT
11339: ENP END PROCEDURE ACOMP
11340: EJC
11341: *
11342: * ALLOC ALLOCATE BLOCK OF DYNAMIC STORAGE
11343: *
11344: * (WA) LENGTH REQUIRED IN BAUS
11345: * JSR ALLOC CALL TO ALLOCATE BLOCK
11346: * (XR) POINTER TO ALLOCATED BLOCK
11347: *
11348: * A POSSIBLE ALTERNATIVE TO AOV .. AND FOLLOWING STMT IS -
11349: * MOV DNAME,XR . SUB WA,XR . BLO XR,DNAMP,ALOC2 .
11350: * MOV DNAMP,XR . ADD WA,XR
11351: *
11352: ALLOC PRC E,0 ENTRY POINT
11353: *
11354: * COMMON EXIT POINT
11355: *
11356: ALOC1 MOV DNAMP,XR POINT TO NEXT AVAILABLE LOC
11357: AOV WA,XR,ALOC2 POINT PAST ALLOCATED BLOCK
11358: BGT XR,DNAME,ALOC2 JUMP IF NOT ENOUGH ROOM
11359: MOV XR,DNAMP STORE NEW POINTER
11360: SUB WA,XR POINT BACK TO START OF ALLOCATED BK
11361: EXI RETURN TO CALLER
11362: *
11363: * HERE IF INSUFFICIENT ROOM, TRY A GARBAGE COLLECTION
11364: *
11365: ALOC2 MOV WB,ALLSV SAVE WB
11366: ZER WB SET NO UPWARD MOVE FOR GBCOL
11367: JSR GBCOL GARBAGE COLLECT
11368: *
11369: * SEE IF ROOM AFTER GBCOL OR SYSMM CALL
11370: *
11371: ALOC3 MOV DNAMP,XR POINT TO FIRST AVAILABLE LOC
11372: AOV WA,XR,ALC3A POINT PAST NEW BLOCK
11373: BLO XR,DNAME,ALOC4 JUMP IF THERE IS ROOM NOW
11374: *
11375: * FAILED AGAIN, SEE IF WE CAN GET MORE CORE
11376: *
11377: ALC3A JSR SYSMM TRY TO GET MORE MEMORY
11378: WTB XR CONVERT TO BAUS
11379: ADD XR,DNAME BUMP PTR BY AMOUNT OBTAINED
11380: BNZ XR,ALOC3 JUMP IF GOT MORE CORE
11381: ADD RSMEM,DNAME GET THE RESERVE MEMORY
11382: ZER RSMEM ONLY PERMISSIBLE ONCE
11383: ICV ERRFT FATAL ERROR
11384: ERB 200,MEMORY OVERFLOW
11385: EJC
11386: *
11387: * HERE AFTER SUCCESSFUL GARBAGE COLLECTION
11388: *
11389: ALOC4 STI ALLIA SAVE IA
11390: MOV DNAME,WB GET DYNAMIC END ADRS
11391: SUB DNAMP,WB COMPUTE FREE STORE
11392: BTW WB CONVERT BAUS TO WORDS
11393: MTI WB PUT FREE STORE IN IA
11394: MLI ALFSF MULTIPLY BY FREE STORE FACTOR
11395: IOV ALOC5 JUMP IF OVERFLOWED
11396: MOV DNAME,WB DYNAMIC END ADRS
11397: SUB DNAMB,WB COMPUTE TOTAL AMOUNT OF DYNAMIC
11398: BTW WB CONVERT TO WORDS
11399: MOV WB,ALDYN STORE IT
11400: SBI ALDYN SUBTRACT FROM SCALED UP FREE STORE
11401: IGT ALOC5 JUMP IF SUFFICIENT FREE STORE
11402: JSR SYSMM TRY TO GET MORE STORE
11403: WTB XR CONVERT TO BAUS
11404: ADD XR,DNAME ADJUST DYNAMIC END ADRS
11405: *
11406: * MERGE TO RESTORE IA AND WB
11407: *
11408: ALOC5 LDI ALLIA RECOVER IA
11409: MOV ALLSV,WB RESTORE WB
11410: BRN ALOC1 JUMP BACK TO EXIT
11411: ENP END PROCEDURE ALLOC
11412: EJC
11413: .IF .CNBF
11414: .ELSE
11415: *
11416: * ALOBF -- ALLOCATE BUFFER
11417: *
11418: * THIS ROUTINES ALLOCATES A NEW BUFFER. AS THE BFBLK
11419: * AND BCBLK COME IN PAIRS, BOTH ARE ALLOCATED HERE,
11420: * AND XR POINTS TO THE BCBLK ON RETURN. THE BFBLK
11421: * AND BCBLK ARE SET TO THE NULL BUFFER, AND THE IDVAL
11422: * IS ZERO ON RETURN.
11423: *
11424: * (WA) BUFFER SIZE IN CHARACTERS
11425: * JSR ALOBF CALL TO CREATE BUFFER
11426: * (WA) 0 (INITIAL OFFSET TO BFBLK CHARS)
11427: * (WB) 0 (INITIAL BCLEN)
11428: * (XR) BCBLK PTR
11429: *
11430: ALOBF PRC E,0 ENTRY POINT
11431: MOV WA,WB HANG ONTO ALLOCATION SIZE
11432: CTB WA,BFSI$ GET TOTAL BLOCK SIZE
11433: BGE WA,MXLEN,ALB01 CHECK FOR MAXLEN EXCEEDED
11434: ADD *BCSI$,WA ADD IN ALLOCATION FOR BCBLK
11435: JSR ALLOC ALLOCATE FRAME
11436: MOV =B$BCT,(XR) SET TYPE
11437: ZER IDVAL(XR) NO ID YET
11438: ZER BCLEN(XR) NO DEFINED LENGTH
11439: MOV XL,WA SAVE XL
11440: MOV XR,XL COPY BCBLK PTR
11441: ADD *BCSI$,XL BIAS PAST PARTIALLY BUILT BCBLK
11442: MOV =B$BFT,(XL) SET BFBLK TYPE WORD
11443: MOV WB,BFALC(XL) SET ALLOCATED SIZE
11444: MOV XL,BCBUF(XR) SET POINTER IN BCBLK
11445: ZER WB CLEAR FOR RETURN
11446: MOV WB,BFCHR(XL) CLEAR FIRST WORD (NULL PAD)
11447: MOV WA,XL RESTORE ENTRY XL
11448: ZER WA CLEAR FOR RETURN
11449: EXI RETURN TO CALLER
11450: *
11451: * HERE FOR MXLEN EXCEEDED
11452: *
11453: ALB01 ERB 201,REQUESTED BUFFER ALLOCATION EXCEEDS MAXLNGTH
11454: ENP END PROCEDURE ALOBF
11455: EJC
11456: .FI
11457: *
11458: * ALOCS -- ALLOCATE STRING BLOCK
11459: *
11460: * ALOCS IS USED TO BUILD A FRAME FOR A STRING BLOCK INTO
11461: * WHICH THE ACTUAL CHARACTERS ARE PLACED BY THE CALLER.
11462: * ALL STRINGS ARE CREATED WITH A CALL TO ALOCS (THE
11463: * EXCEPTIONS OCCUR IN TRIMR AND S$RPL PROCEDURES).
11464: *
11465: * (WA) LENGTH OF STRING TO BE ALLOCATED
11466: * JSR ALOCS CALL TO ALLOCATE SCBLK
11467: * (XR) POINTER TO RESULTING SCBLK
11468: * (WA) DESTROYED
11469: * (WC) CHARACTER COUNT (ENTRY VALUE OF WA)
11470: *
11471: * THE RESULTING SCBLK HAS THE TYPE WORD AND THE LENGTH
11472: * FILLED IN AND THE LAST WORD IS CLEARED TO ZERO CHARACTERS
11473: * TO ENSURE CORRECT RIGHT PADDING OF THE FINAL WORD.
11474: *
11475: ALOCS PRC E,0 ENTRY POINT
11476: BGT WA,KVMXL,ALCS2 JUMP IF LENGTH EXCEEEDS MAXLENGTH
11477: MOV WA,WC ELSE COPY LENGTH
11478: CTB WA,SCSI$ COMPUTE LENGTH OF SCBLK IN BAUS
11479: MOV DNAMP,XR POINT TO NEXT AVAILABLE LOCATION
11480: AOV WA,XR,ALCS0 POINT PAST BLOCK
11481: BLO XR,DNAME,ALCS1 JUMP IF THERE IS ROOM
11482: *
11483: * INSUFFICIENT MEMORY
11484: *
11485: ALCS0 ZER XR ELSE CLEAR GARBAGE XR VALUE
11486: JSR ALLOC AND USE STANDARD ALLOCATOR
11487: ADD WA,XR POINT PAST END OF BLOCK TO MERGE
11488: *
11489: * MERGE HERE WITH XR POINTING BEYOND NEW BLOCK
11490: *
11491: ALCS1 MOV XR,DNAMP SET UPDATED STORAGE POINTER
11492: ZER -(XR) STORE ZERO CHARS IN LAST WORD
11493: DCA WA DECREMENT LENGTH
11494: SUB WA,XR POINT BACK TO START OF BLOCK
11495: MOV =B$SCL,(XR) SET TYPE WORD
11496: MOV WC,SCLEN(XR) STORE LENGTH IN CHARS
11497: EXI RETURN TO ALOCS CALLER
11498: *
11499: * COME HERE IF STRING IS TOO LONG
11500: *
11501: ALCS2 ERB 202,STRING LENGTH EXCEEDS VALUE OF MAXLNGTH KEYWORD
11502: ENP END PROCEDURE ALOCS
11503: EJC
11504: *
11505: * ALOST -- ALLOCATE SPACE IN STATIC REGION
11506: *
11507: * (WA) LENGTH REQUIRED IN BAUS
11508: * JSR ALOST CALL TO ALLOCATE SPACE
11509: * (XR) POINTER TO ALLOCATED BLOCK
11510: * (WB) DESTROYED
11511: *
11512: * NOTE THAT THE CODING ENSURES THAT THE RESULTING VALUE
11513: * OF STATE IS ALWAYS LESS THAN DNAMB. THIS FACT IS USED
11514: * IN TESTING A VARIABLE NAME FOR BEING IN THE STATIC REGION
11515: *
11516: ALOST PRC E,0 ENTRY POINT
11517: *
11518: * MERGE BACK HERE AFTER ALLOCATING NEW CHUNK
11519: *
11520: ALST1 MOV STATE,XR POINT TO CURRENT END OF AREA
11521: AOV WA,XR,ALST2 POINT BEYOND PROPOSED BLOCK
11522: BGE XR,DNAMB,ALST2 JUMP IF OVERLAP WITH DYNAMIC AREA
11523: MOV XR,STATE ELSE STORE NEW POINTER
11524: SUB WA,XR POINT BACK TO START OF BLOCK
11525: EXI RETURN TO ALOST CALLER
11526: *
11527: * HERE IF NO ROOM, PREPARE TO MOVE DYNAMIC STORAGE UP
11528: *
11529: ALST2 MOV WA,ALSTA SAVE WA
11530: BGE WA,*E$STS,ALST3 SKIP IF REQUESTED CHUNK IS LARGE
11531: MOV *E$STS,WA ELSE SET TO GET LARGE ENOUGH CHUNK
11532: *
11533: * HERE WITH AMOUNT TO MOVE UP IN WA
11534: *
11535: ALST3 JSR ALLOC ALLOCATE BLOCK TO ENSURE ROOM
11536: MOV XR,DNAMP AND DELETE IT
11537: MOV WA,WB COPY MOVE UP AMOUNT
11538: JSR GBCOL CALL GBCOL TO MOVE DYNAMIC AREA UP
11539: MOV ALSTA,WA RESTORE WA
11540: BRN ALST1 LOOP BACK TO TRY AGAIN
11541: ENP END PROCEDURE ALOST
11542: EJC
11543: *
11544: * ARITH -- FETCH ARITHMETIC OPERANDS
11545: *
11546: * ARITH IS USED BY FUNCTIONS AND OPERATORS WHICH EXPECT
11547: * TWO NUMERIC ARGUMENTS (OPERANDS) WHICH MUST BOTH BE
11548: * INTEGER OR BOTH BE REAL. ARITH FETCHES TWO ARGUMENTS FROM
11549: * THE STACK AND PERFORMS ANY NECESSARY CONVERSIONS.
11550: *
11551: * 1(XS) FIRST ARGUMENT (LEFT OPERAND)
11552: * 0(XS) SECOND ARGUMENT (RIGHT OPERAND)
11553: * JSR ARITH CALL TO FETCH NUMERIC ARGUMENTS
11554: * PPM LOC TRANSFER LOC FOR OPND 1 NON-NUMERIC
11555: * PPM LOC TRANSFER LOC FOR OPND 2 NON-NUMERIC
11556: .IF .CNRA
11557: .ELSE
11558: * PPM LOC TRANSFER LOC FOR REAL OPERANDS
11559: .FI
11560: *
11561: * FOR INTEGER ARGS, CONTROL RETURNS PAST THE PARAMETERS
11562: *
11563: * (IA) LEFT OPERAND VALUE
11564: * (XR) PTR TO ICBLK FOR LEFT OPERAND
11565: * (XL) PTR TO ICBLK FOR RIGHT OPERAND
11566: * (XS) POPPED TWICE
11567: * (WA,WB,RA) DESTROYED
11568: .IF .CNRA
11569: .ELSE
11570: *
11571: * FOR REAL ARGUMENTS, CONTROL RETURNS TO THE LOCATION
11572: * SPECIFIED BY THE THIRD PARAMETER.
11573: *
11574: * (RA) LEFT OPERAND VALUE
11575: * (XR) PTR TO RCBLK FOR LEFT OPERAND
11576: * (XL) PTR TO RCBLK FOR RIGHT OPERAND
11577: * (WA,WB,WC) DESTROYED
11578: * (XS) POPPED TWICE
11579: .FI
11580: EJC
11581: *
11582: * ARITH (CONTINUED)
11583: *
11584: * ENTRY POINT
11585: *
11586: .IF .CNRA
11587: ARITH PRC N,2 ENTRY POINT
11588: .ELSE
11589: ARITH PRC N,3 ENTRY POINT
11590: .FI
11591: MOV (XS)+,XL LOAD RIGHT OPERAND
11592: MOV (XS)+,XR LOAD LEFT OPERAND
11593: MOV (XL),WA GET RIGHT OPERAND TYPE WORD
11594: BEQ WA,=B$ICL,ARTH1 JUMP IF INTEGER
11595: .IF .CNRA
11596: .ELSE
11597: BEQ WA,=B$RCL,ARTH4 JUMP IF REAL
11598: .FI
11599: MOV XR,-(XS) ELSE REPLACE LEFT ARG ON STACK
11600: MOV XL,XR COPY LEFT ARG POINTER
11601: JSR GTNUM CONVERT TO NUMERIC
11602: PPM ARTH6 JUMP IF UNCONVERTIBLE
11603: MOV XR,XL ELSE COPY CONVERTED RESULT
11604: MOV (XL),WA GET RIGHT OPERAND TYPE WORD
11605: MOV (XS)+,XR RELOAD LEFT ARGUMENT
11606: .IF .CNRA
11607: .ELSE
11608: BEQ WA,=B$RCL,ARTH4 JUMP IF RIGHT ARG IS REAL
11609: .FI
11610: *
11611: * HERE IF RIGHT ARG IS AN INTEGER
11612: *
11613: ARTH1 BNE (XR),=B$ICL,ARTH3 JUMP IF LEFT ARG NOT INTEGER
11614: *
11615: * EXIT FOR INTEGER CASE
11616: *
11617: ARTH2 LDI ICVAL(XR) LOAD LEFT OPERAND VALUE
11618: EXI RETURN TO ARITH CALLER
11619: *
11620: * HERE FOR RIGHT OPERAND INTEGER, LEFT OPERAND NOT
11621: *
11622: ARTH3 JSR GTNUM CONVERT LEFT ARG TO NUMERIC
11623: PPM ARTH7 JUMP IF NOT CONVERTIBLE
11624: BEQ WA,=B$ICL,ARTH2 JUMP BACK IF INTEGER-INTEGER
11625: .IF .CNRA
11626: .ELSE
11627: *
11628: * HERE WE MUST CONVERT REAL-INTEGER TO REAL-REAL
11629: *
11630: MOV XR,-(XS) PUT LEFT ARG BACK ON STACK
11631: LDI ICVAL(XL) LOAD RIGHT ARGUMENT VALUE
11632: ITR CONVERT TO REAL
11633: JSR RCBLD GET REAL BLOCK FOR RIGHT ARG, MERGE
11634: MOV XR,XL COPY RIGHT ARG PTR
11635: MOV (XS)+,XR LOAD LEFT ARGUMENT
11636: BRN ARTH5 MERGE FOR REAL-REAL CASE
11637: EJC
11638: *
11639: * ARITH (CONTINUED)
11640: *
11641: * HERE IF RIGHT ARGUMENT IS REAL
11642: *
11643: ARTH4 BEQ (XR),=B$RCL,ARTH5 JUMP IF LEFT ARG REAL
11644: JSR GTREA ELSE CONVERT TO REAL
11645: PPM ARTH7 ERROR IF UNCONVERTIBLE
11646: *
11647: * HERE FOR REAL-REAL
11648: *
11649: ARTH5 LDR RCVAL(XR) LOAD LEFT OPERAND VALUE
11650: EXI 3 TAKE REAL-REAL EXIT
11651: .FI
11652: *
11653: * HERE FOR ERROR CONVERTING RIGHT ARGUMENT
11654: *
11655: ARTH6 ICA XS POP UNWANTED LEFT ARG
11656: EXI 2 TAKE APPROPRIATE ERROR EXIT
11657: *
11658: * HERE FOR ERROR CONVERTING LEFT OPERAND
11659: *
11660: ARTH7 EXI 1 TAKE APPROPRIATE ERROR RETURN
11661: ENP END PROCEDURE ARITH
11662: EJC
11663: *
11664: * ASIGN -- PERFORM ASSIGNMENT
11665: *
11666: * ASIGN PERFORMS THE ASSIGNMENT OF A VALUE TO A VARIABLE
11667: * WITH APPROPRIATE CHECKS FOR OUTPUT ASSOCIATIONS AND
11668: * VALUE TRACE ASSOCIATIONS WHICH ARE EXECUTED AS REQUIRED.
11669: * ASIGN ALSO HANDLES THE SPECIAL CASES OF ASSIGNMENT TO
11670: * PATTERN AND EXPRESSION VARIABLES.
11671: *
11672: * (WB) VALUE TO BE ASSIGNED
11673: * (XL) BASE POINTER FOR VARIABLE
11674: * (WA) OFFSET FOR VARIABLE
11675: * JSR ASIGN CALL TO ASSIGN VALUE TO VARIABLE
11676: * PPM LOC TRANSFER LOC FOR FAILURE
11677: * (XR,XL,WA,WB,WC) DESTROYED
11678: * (RA) DESTROYED
11679: *
11680: * FAILURE OCCURS IF THE EVALUATION OF AN EXPRESSION
11681: * ASSOCIATED WITH AN EXPRESSION VARIABLE FAILS.
11682: *
11683: ASIGN PRC R,1 ENTRY POINT (RECURSIVE)
11684: *
11685: * MERGE BACK HERE TO ASSIGN RESULT TO EXPRESSION VARIABLE.
11686: *
11687: ASG01 ADD WA,XL POINT TO VARIABLE VALUE
11688: MOV (XL),XR LOAD VARIABLE VALUE
11689: BEQ (XR),=B$TRT,ASG02 JUMP IF TRAPPED
11690: MOV WB,(XL) ELSE PERFORM ASSIGNMENT
11691: ZER XL CLEAR GARBAGE VALUE IN XL
11692: EXI AND RETURN TO ASIGN CALLER
11693: *
11694: * HERE IF VALUE IS TRAPPED
11695: *
11696: ASG02 SUB WA,XL RESTORE NAME BASE
11697: BEQ XR,=TRBKV,ASG14 JUMP IF KEYWORD VARIABLE
11698: BNE XR,=TRBEV,ASG04 JUMP IF NOT EXPRESSION VARIABLE
11699: *
11700: * HERE FOR ASSIGNMENT TO EXPRESSION VARIABLE
11701: *
11702: MOV EVEXP(XL),XR POINT TO EXPRESSION
11703: MOV WB,-(XS) STORE VALUE TO ASSIGN ON STACK
11704: MOV =NUM01,WB SET FOR EVALUATION BY NAME
11705: JSR EVALX EVALUATE EXPRESSION BY NAME
11706: PPM ASG03 JUMP IF EVALUATION FAILS
11707: MOV (XS)+,WB ELSE RELOAD VALUE TO ASSIGN
11708: BRN ASG01 LOOP BACK TO PERFORM ASSIGNMENT
11709: EJC
11710: *
11711: * ASIGN (CONTINUED)
11712: *
11713: * HERE FOR FAILURE RETURNS
11714: *
11715: ASG03 ICA XS REMOVE STACKED VALUE ENTRY
11716: *
11717: ASG3A EXI 1 TAKE FAILURE EXIT
11718: *
11719: * HERE IF NOT KEYWORD OR EXPRESSION VARIABLE
11720: *
11721: ASG04 MOV XR,-(XS) SAVE PTR TO FIRST TRBLK
11722: *
11723: * LOOP TO CHASE DOWN TRBLK CHAIN AND ASSIGN VALUE AT END
11724: *
11725: ASG05 MOV XR,WC SAVE PTR TO THIS TRBLK
11726: MOV TRNXT(XR),XR POINT TO NEXT TRBLK
11727: BEQ (XR),=B$TRT,ASG05 LOOP BACK IF ANOTHER TRBLK
11728: MOV WC,XR ELSE POINT BACK TO LAST TRBLK
11729: MOV WB,TRVAL(XR) STORE VALUE AT END OF CHAIN
11730: MOV (XS)+,XR RESTORE PTR TO FIRST TRBLK
11731: *
11732: * LOOP TO PROCESS TRBLK ENTRIES ON CHAIN
11733: *
11734: ASG06 MOV TRTYP(XR),WB LOAD TYPE CODE OF TRBLK
11735: BEQ WB,=TRTVL,ASG08 JUMP IF VALUE TRACE
11736: BEQ WB,=TRTOU,ASG10 JUMP IF OUTPUT ASSOCIATION
11737: *
11738: * HERE TO MOVE TO NEXT TRBLK ON CHAIN
11739: *
11740: ASG07 MOV TRNXT(XR),XR POINT TO NEXT TRBLK ON CHAIN
11741: BEQ (XR),=B$TRT,ASG06 LOOP BACK IF ANOTHER TRBLK
11742: EXI ELSE END OF CHAIN, RETURN TO CALLER
11743: *
11744: * HERE TO PROCESS VALUE TRACE
11745: *
11746: ASG08 BZE KVTRA,ASG07 IGNORE VALUE TRACE IF TRACE OFF
11747: DCV KVTRA ELSE DECREMENT TRACE COUNT
11748: BZE TRFNC(XR),ASG09 JUMP IF PRINT TRACE
11749: JSR TRXEQ ELSE EXECUTE FUNCTION TRACE
11750: BRN ASG07 AND LOOP BACK
11751: EJC
11752: *
11753: * ASIGN (CONTINUED)
11754: *
11755: * HERE FOR PRINT TRACE
11756: *
11757: ASG09 JSR PRTSN PRINT STATEMENT NUMBER
11758: JSR PRTNV PRINT NAME = VALUE
11759: BRN ASG07 LOOP BACK FOR NEXT TRBLK
11760: *
11761: * HERE FOR OUTPUT ASSOCIATION
11762: *
11763: ASG10 BZE KVOUP,ASG07 IGNORE OUTPUT ASSOC IF OUTPUT OFF
11764: MOV XR,XL ELSE COPY TRBLK POINTER
11765: MOV TRVAL(XR),-(XS) STACK VALUE TO OUTPUT
11766: JSR GTSTG CONVERT TO STRING
11767: PPM ASG12 GET DATATYPE NAME IF UNCONVERTIBLE
11768: *
11769: * MERGE WITH STRING FOR OUTPUT
11770: *
11771: ASG11 MOV TRTRI(XL),WA TRTIO BLK PTR
11772: BZE WA,ASG13 JUMP IF STANDARD OUTPUT FILE
11773: *
11774: * HERE FOR OUTPUT TO NON-STANDARD OUTPUT FILE
11775: *
11776: MOV WA,XL COPY TRTIO BLOCK PTR TO XL
11777: MOV TRTAG(XL),WA GET IOTAG
11778: BZE WA,ASG3A FAIL IF ENDFILE DONE
11779: MOV SCLEN(XR),WC STRING LENGTH
11780: JSR SYSOU CALL SYSTEM OUTPUT ROUTINE
11781: PPM ASG3A FAIL RETURN
11782: PPM EROSI ERROR RETURN
11783: EXI ELSE ALL DONE, RETURN TO CALLER
11784: *
11785: * IF NOT PRINTABLE, GET DATATYPE NAME INSTEAD
11786: *
11787: ASG12 JSR DTYPE CALL DATATYPE ROUTINE
11788: BRN ASG11 MERGE
11789: *
11790: * HERE TO PRINT A STRING
11791: *
11792: ASG13 BEQ TRTER(XL),=V$TER,ASG20 JUMP IF TERMINAL OUTPUT
11793: JSR PRTSF PRINT STRING AND FLUSH BUFFER
11794: EXI RETURN TO CALLER
11795: EJC
11796: *
11797: * ASIGN (CONTINUED)
11798: *
11799: * HERE FOR KEYWORD ASSIGNMENT
11800: *
11801: ASG14 MOV KVNUM(XL),XL LOAD KEYWORD NUMBER
11802: BEQ XL,=K$ETX,ASG19 JUMP IF ERRTEXT
11803: MOV WB,XR COPY VALUE TO BE ASSIGNED
11804: JSR GTINT CONVERT TO INTEGER
11805: ERR 203,KEYWORD VALUE ASSIGNED IS NOT INTEGER
11806: LDI ICVAL(XR) ELSE LOAD VALUE
11807: BEQ XL,=K$STL,ASG16 JUMP IF SPECIAL CASE OF STLIMIT
11808: BEQ XL,=K$COD,ASG24 JUMP IF SPECIAL CASE OF CODE
11809: MFI WA,ASG18 ELSE GET ADDR INTEGER, TEST OVFLOW
11810: BGE WA,MXLEN,ASG18 FAIL IF TOO LARGE
11811: BEQ XL,=K$ERT,ASG17 JUMP IF SPECIAL CASE OF ERRTYPE
11812: .IF .CNPF
11813: .ELSE
11814: BEQ XL,=K$PFL,ASG21 JUMP IF SPECIAL CASE OF PROFILE
11815: .FI
11816: BLT XL,=K$P$$,ASG15 JUMP UNLESS PROTECTED
11817: ERB 204,KEYWORD IN ASSIGNMENT IS PROTECTED
11818: *
11819: * HERE TO DO ASSIGNMENT IF NOT PROTECTED
11820: *
11821: ASG15 MOV WA,KVANC(XL) STORE NEW VALUE
11822: EXI RETURN TO ASIGN CALLER
11823: *
11824: * HERE FOR SPECIAL CASE OF STLIMIT
11825: *
11826: * SINCE STCOUNT IS MAINTAINED AS (STLIMIT-STCOUNT)
11827: * IT IS ALSO NECESSARY TO MODIFY STCOUNT APPROPRIATELY.
11828: *
11829: ASG16 SBI KVSTL SUBTRACT OLD LIMIT
11830: ADI KVSTC ADD OLD COUNTER
11831: STI KVSTC STORE NEW COUNTER VALUE
11832: LDI ICVAL(XR) RELOAD NEW LIMIT VALUE
11833: STI KVSTL STORE NEW LIMIT VALUE
11834: EXI RETURN TO ASIGN CALLER
11835: EJC
11836: *
11837: * ASIGN (CONTINUED)
11838: *
11839: * HERE FOR SPECIAL CASE OF ERRTYPE
11840: *
11841: ASG17 BLE WA,=NINI9,ERROR OK TO SIGNAL IF IN RANGE
11842: *
11843: * HERE IF VALUE ASSIGNED IS OUT OF RANGE
11844: *
11845: ASG18 ERB 205,KEYWORD VALUE ASSIGNED IS NEGATIVE OR TOO LARGE
11846: *
11847: * HERE FOR SPECIAL CASE OF ERRTEXT
11848: *
11849: ASG19 MOV WB,-(XS) STACK VALUE
11850: JSR GTSTG CONVERT TO STRING
11851: ERR 206,VALUE ASSIGNED TO KEYWORD ERRTEXT NOT A STRING
11852: MOV XR,R$ETX MAKE ASSIGNMENT
11853: EXI RETURN TO CALLER
11854: *
11855: * PRINT STRING TO TERMINAL
11856: *
11857: ASG20 JSR PTTST PRINT STRING TO TERMINAL
11858: JSR PTTFH FLUSH TERMINAL BUFFER
11859: EXI RETURN
11860: .IF .CNPF
11861: .ELSE
11862: * HERE FOR KEYWORD PROFILE
11863: *
11864: ASG21 BGT WA,=NUM02,ASG18 MOAN IF NOT 0,1, OR 2
11865: BZE WA,ASG15 JUST ASSIGN IF ZERO
11866: BZE PFDMP,ASG22 BRANCH IF FIRST ASSIGNMENT
11867: BEQ WA,PFDMP,ASG23 ALSO IF SAME VALUE AS BEFORE
11868: ERB 207,INCONSISTENT VALUE ASSIGNED TO KEYWORD PROFILE
11869: *
11870: ASG22 MOV WA,PFDMP NOTE VALUE ON FIRST ASSIGNMENT
11871: ASG23 JSR SYSTM GET THE TIME
11872: STI PFSTM FUDGE SOME KIND OF START TIME
11873: BRN ASG15 AND GO ASSIGN
11874: .FI
11875: *
11876: * HERE FOR KEYWORD ASSIGNMENT TO CODE
11877: *
11878: ASG24 STI KVCOD STORE VALUE
11879: EXI RETURN TO CALLER
11880: ENP END PROCEDURE ASIGN
11881: EJC
11882: *
11883: * ASINP -- ASSIGN DURING PATTERN MATCH
11884: *
11885: * ASINP IS LIKE ASIGN AND HAS A SIMILAR CALLING SEQUENCE
11886: * AND EFFECT. THE DIFFERENCE IS THAT THE GLOBAL PATTERN
11887: * VARIABLES ARE SAVED AND RESTORED IF REQUIRED.
11888: *
11889: * (XL) BASE POINTER FOR VARIABLE
11890: * (WA) OFFSET FOR VARIABLE
11891: * (WB) VALUE TO BE ASSIGNED
11892: * JSR ASINP CALL TO ASSIGN VALUE TO VARIABLE
11893: * PPM LOC TRANSFER LOC IF FAILURE
11894: * (XR,XL) DESTROYED
11895: * (WA,WB,WC,RA) DESTROYED
11896: *
11897: ASINP PRC R,1 ENTRY POINT, RECURSIVE
11898: ADD WA,XL POINT TO VARIABLE
11899: MOV (XL),XR LOAD CURRENT CONTENTS
11900: BEQ (XR),=B$TRT,ASNP1 JUMP IF TRAPPED
11901: MOV WB,(XL) ELSE PERFORM ASSIGNMENT
11902: ZER XL CLEAR GARBAGE VALUE IN XL
11903: EXI RETURN TO ASINP CALLER
11904: *
11905: * HERE IF VARIABLE IS TRAPPED
11906: *
11907: ASNP1 SUB WA,XL RESTORE BASE POINTER
11908: MOV PMSSL,-(XS) STACK SUBJECT STRING LENGTH
11909: MOV PMHBS,-(XS) STACK HISTORY STACK BASE PTR
11910: MOV R$PMS,-(XS) STACK SUBJECT STRING POINTER
11911: MOV PMDFL,-(XS) STACK DOT FLAG
11912: JSR ASIGN CALL FULL-BLOWN ASSIGNMENT ROUTINE
11913: PPM ASNP2 JUMP IF FAILURE
11914: MOV (XS)+,PMDFL RESTORE DOT FLAG
11915: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER
11916: MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER
11917: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH
11918: EXI RETURN TO ASINP CALLER
11919: *
11920: * HERE IF FAILURE IN ASIGN CALL
11921: *
11922: ASNP2 MOV (XS)+,PMDFL RESTORE DOT FLAG
11923: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER
11924: MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER
11925: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH
11926: EXI 1 TAKE FAILURE EXIT
11927: ENP END PROCEDURE ASINP
11928: EJC
11929: *
11930: * BLKLN -- DETERMINE LENGTH OF BLOCK
11931: *
11932: * BLKLN DETERMINES THE LENGTH OF A BLOCK IN DYNAMIC STORE.
11933: *
11934: * (WA) FIRST WORD OF BLOCK
11935: * (XR) POINTER TO BLOCK
11936: * JSR BLKLN CALL TO GET BLOCK LENGTH
11937: * (WA) LENGTH OF BLOCK IN BAUS
11938: * (XL) DESTROYED
11939: *
11940: * BLKLN IS USED BY THE GARBAGE COLLECTOR AND IS NOT
11941: * PERMITTED TO CALL GBCOL DIRECTLY OR INDIRECTLY.
11942: *
11943: * THE FIRST WORD STORED IN THE BLOCK (I.E. AT XR) MAY
11944: * BE ANYTHING, BUT THE CONTENTS OF WA MUST BE CORRECT.
11945: *
11946: BLKLN PRC E,0 ENTRY POINT
11947: MOV WA,XL COPY FIRST WORD
11948: LEI XL GET ENTRY ID (BL$XX)
11949: BSW XL,BL$$$,BLN00 SWITCH ON BLOCK TYPE
11950: IFF BL$AR,BLN01 ARBLK
11951: IFF BL$CD,BLN01 CDBLK
11952: IFF BL$CO,BLN12 COBLK
11953: IFF BL$DF,BLN01 DFBLK
11954: IFF BL$EF,BLN01 EFBLK
11955: IFF BL$EX,BLN01 EXBLK
11956: IFF BL$PF,BLN01 PFBLK
11957: IFF BL$TB,BLN01 TBBLK
11958: IFF BL$VC,BLN01 VCBLK
11959: IFF BL$EV,BLN03 EVBLK
11960: IFF BL$KV,BLN03 KVBLK
11961: IFF BL$P0,BLN02 P0BLK
11962: IFF BL$SE,BLN02 SEBLK
11963: IFF BL$NM,BLN03 NMBLK
11964: IFF BL$P1,BLN03 P1BLK
11965: IFF BL$P2,BLN04 P2BLK
11966: IFF BL$TE,BLN04 TEBLK
11967: IFF BL$FF,BLN05 FFBLK
11968: IFF BL$TR,BLN05 TRBLK
11969: IFF BL$CT,BLN06 CTBLK
11970: IFF BL$IC,BLN07 ICBLK
11971: IFF BL$PD,BLN08 PDBLK
11972: .IF .CNBF
11973: .ELSE
11974: IFF BL$BC,BLN04 BCBLK
11975: IFF BL$BF,BLN11 BFBLK
11976: .FI
11977: .IF .CNRA
11978: .ELSE
11979: IFF BL$RC,BLN09 RCBLK
11980: .FI
11981: IFF BL$SC,BLN10 SCBLK
11982: ESW END OF JUMP TABLE ON BLOCK TYPE
11983: EJC
11984: *
11985: * BLKLN (CONTINUED)
11986: *
11987: * HERE FOR BLOCKS WITH LENGTH IN SECOND WORD
11988: *
11989: BLN00 MOV 1(XR),WA LOAD LENGTH
11990: EXI RETURN TO BLKLN CALLER
11991: *
11992: * HERE FOR LENGTH IN THIRD WORD (AR,CD,DF,EF,EX,PF,TB,VC)
11993: *
11994: BLN01 MOV 2(XR),WA LOAD LENGTH FROM THIRD WORD
11995: EXI RETURN TO BLKLN CALLER
11996: *
11997: * HERE FOR TWO WORD BLOCKS (P0,SE)
11998: *
11999: BLN02 MOV *NUM02,WA LOAD LENGTH (TWO WORDS)
12000: EXI RETURN TO BLKLN CALLER
12001: *
12002: * HERE FOR THREE WORD BLOCKS (NM,P1,EV,KV)
12003: *
12004: BLN03 MOV *NUM03,WA LOAD LENGTH (THREE WORDS)
12005: EXI RETURN TO BLKLN CALLER
12006: *
12007: * HERE FOR FOUR WORD BLOCKS (P2,TE)
12008: *
12009: BLN04 MOV *NUM04,WA LOAD LENGTH (FOUR WORDS)
12010: EXI RETURN TO BLKLN CALLER
12011: *
12012: * HERE FOR FIVE WORD BLOCKS (FF,TR)
12013: *
12014: BLN05 MOV *NUM05,WA LOAD LENGTH
12015: EXI RETURN TO BLKLN CALLER
12016: EJC
12017: *
12018: * BLKLN (CONTINUED)
12019: *
12020: * HERE FOR CTBLK
12021: *
12022: BLN06 MOV *CTSI$,WA SET SIZE OF CTBLK
12023: EXI RETURN TO BLKLN CALLER
12024: *
12025: * HERE FOR ICBLK
12026: *
12027: BLN07 MOV *ICSI$,WA SET SIZE OF ICBLK
12028: EXI RETURN TO BLKLN CALLER
12029: *
12030: * HERE FOR PDBLK
12031: *
12032: BLN08 MOV PDDFP(XR),XL POINT TO DFBLK
12033: MOV DFPDL(XL),WA LOAD PDBLK LENGTH FROM DFBLK
12034: EXI RETURN TO BLKLN CALLER
12035: .IF .CNRA
12036: .ELSE
12037: *
12038: * HERE FOR RCBLK
12039: *
12040: BLN09 MOV *RCSI$,WA SET SIZE OF RCBLK
12041: EXI RETURN TO BLKLN CALLER
12042: .FI
12043: *
12044: * HERE FOR SCBLK
12045: *
12046: BLN10 MOV SCLEN(XR),WA LOAD LENGTH IN CHARACTERS
12047: CTB WA,SCSI$ CALCULATE LENGTH IN BAUS
12048: EXI RETURN TO BLKLN CALLER
12049: .IF .CNBF
12050: .ELSE
12051: *
12052: * HERE FOR BFBLK
12053: *
12054: BLN11 MOV BFALC(XR),WA GET ALLOCATION IN BAUS
12055: CTB WA,BFSI$ CALCULATE LENGTH IN BAUS
12056: EXI RETURN TO BLKLN CALLER
12057: .FI
12058: *
12059: * HERE FOR COBLK
12060: *
12061: BLN12 MOV *COSI$,WA GET SIZE IN BAUS
12062: EXI RETURN TO BLKLN CALLER
12063: ENP END PROCEDURE BLKLN
12064: EJC
12065: *
12066: * CBLCK -- COPY A BLOCK
12067: *
12068: * (XS) BLOCK TO BE COPIED
12069: * JSR CBLCK CALL TO COPY BLOCK
12070: * PPM LOC RETURN IF BLOCK HAS NO IDVAL FIELD
12071: * NORMAL RETURN IF IDVAL FIELD
12072: * (XR) COPY OF BLOCK
12073: * (XS) POPPED
12074: * (XL,WA,WB,WC) DESTROYED
12075: *
12076: CBLCK PRC N,1 ENTRY POINT
12077: MOV (XS),XR LOAD ARGUMENT
12078: BEQ XR,=NULLS,CBL10 RETURN ARGUMENT IF IT IS NULL
12079: MOV (XR),WA ELSE LOAD TYPE WORD
12080: MOV WA,WB COPY TYPE WORD
12081: JSR BLKLN GET LENGTH OF ARGUMENT BLOCK
12082: MOV XR,XL COPY POINTER
12083: JSR ALLOC ALLOCATE BLOCK OF SAME SIZE
12084: MOV XR,(XS) STORE POINTER TO COPY
12085: MVW COPY CONTENTS OF OLD BLOCK TO NEW
12086: MOV (XS),XR RELOAD POINTER TO START OF COPY
12087: BEQ WB,=B$TBT,CBL05 JUMP IF TABLE
12088: BEQ WB,=B$VCT,CBL01 JUMP IF VECTOR
12089: BEQ WB,=B$PDT,CBL01 JUMP IF PROGRAM DEFINED
12090: .IF .CNBF
12091: .ELSE
12092: BEQ WB,=B$BCT,CBL11 JUMP IF BUFFER
12093: .FI
12094: BNE WB,=B$ART,CBL10 RETURN COPY IF NOT ARRAY
12095: *
12096: * HERE FOR ARRAY (ARBLK)
12097: *
12098: ADD AROFS(XR),XR POINT TO PROTOTYPE FIELD
12099: BRN CBL02 JUMP TO MERGE
12100: *
12101: * HERE FOR VECTOR, PROGRAM DEFINED
12102: *
12103: CBL01 ADD *PDFLD,XR POINT TO PDFLD = VCVLS
12104: *
12105: * MERGE HERE FOR ARBLK, VCBLK, PDBLK TO DELETE TRAP
12106: * BLOCKS FROM ALL VALUE FIELDS (THE COPY IS UNTRAPPED)
12107: *
12108: CBL02 MOV (XR),XL LOAD NEXT POINTER
12109: *
12110: * LOOP TO GET VALUE AT END OF TRBLK CHAIN
12111: *
12112: CBL03 BNE (XL),=B$TRT,CBL04 JUMP IF NOT TRAPPED
12113: MOV TRVAL(XL),XL ELSE POINT TO NEXT VALUE
12114: BRN CBL03 AND LOOP BACK
12115: EJC
12116: *
12117: * CBLCK (CONTINUED)
12118: *
12119: * HERE WITH UNTRAPPED VALUE IN XL
12120: *
12121: CBL04 MOV XL,(XR)+ STORE REAL VALUE, BUMP POINTER
12122: BNE XR,DNAMP,CBL02 LOOP BACK IF MORE TO GO
12123: BRN CBL09 ELSE JUMP TO EXIT
12124: *
12125: * HERE TO COPY A TABLE
12126: *
12127: CBL05 ZER IDVAL(XR) ZERO ID TO STOP DUMP BLOWING UP
12128: MOV *TESI$,WA SET SIZE OF TEBLK
12129: MOV *TBBUK,WC SET INITIAL OFFSET
12130: *
12131: * LOOP THROUGH BUCKETS IN TABLE
12132: *
12133: CBL06 MOV (XS),XR LOAD TABLE POINTER
12134: BEQ WC,TBLEN(XR),CBL09 JUMP TO EXIT IF ALL DONE
12135: ADD WC,XR ELSE POINT TO NEXT BUCKET HEADER
12136: ICA WC BUMP OFFSET
12137: SUB *TENXT,XR SUBTRACT LINK OFFSET TO MERGE
12138: *
12139: * LOOP THROUGH TEBLKS ON ONE CHAIN
12140: *
12141: CBL07 MOV TENXT(XR),XL LOAD POINTER TO NEXT TEBLK
12142: MOV (XS),TENXT(XR) SET END OF CHAIN POINTER IN CASE
12143: BEQ (XL),=B$TBT,CBL06 BACK FOR NEXT BUCKET IF CHAIN END
12144: MOV XR,-(XS) ELSE STACK PTR TO PREVIOUS BLOCK
12145: MOV *TESI$,WA SET SIZE OF TEBLK
12146: JSR ALLOC ALLOCATE NEW TEBLK
12147: MOV XR,WB SAVE PTR TO NEW TEBLK
12148: MVW COPY OLD TEBLK TO NEW TEBLK
12149: MOV WB,XR RESTORE POINTER TO NEW TEBLK
12150: MOV (XS)+,XL RESTORE POINTER TO PREVIOUS BLOCK
12151: MOV XR,TENXT(XL) LINK NEW BLOCK TO PREVIOUS
12152: MOV XR,XL COPY POINTER TO NEW BLOCK
12153: *
12154: * LOOP TO SET REAL VALUE AFTER REMOVING TRAP CHAIN
12155: *
12156: CBL08 MOV TEVAL(XL),XL LOAD VALUE
12157: BEQ (XL),=B$TRT,CBL08 LOOP BACK IF TRAPPED
12158: MOV XL,TEVAL(XR) STORE UNTRAPPED VALUE IN TEBLK
12159: BRN CBL07 BACK FOR NEXT TEBLK
12160: *
12161: * COMMON EXIT POINT
12162: *
12163: CBL09 MOV (XS)+,XR LOAD POINTER TO BLOCK
12164: EXI RETURN
12165: *
12166: * ALTERNATIVE RETURN
12167: *
12168: CBL10 EXI 1 RETURN
12169: .IF .CNBF
12170: .ELSE
12171: EJC
12172: *
12173: * HERE TO COPY BUFFER
12174: *
12175: CBL11 MOV BCBUF(XR),XL GET BFBLK PTR
12176: MOV BFALC(XL),WA GET ALLOCATION
12177: CTB WA,BFSI$ SET TOTAL SIZE
12178: MOV XR,XL SAVE BCBLK PTR
12179: JSR ALLOC ALLOCATE BFBLK
12180: MOV BCBUF(XL),WB GET OLD BFBLK
12181: MOV XR,BCBUF(XL) SET POINTER TO NEW BFBLK
12182: MOV WB,XL POINT TO OLD BFBLK
12183: MVW COPY BFBLK TOO
12184: ZER XL CLEAR RUBBISH PTR
12185: BRN CBL09 BRANCH TO EXIT
12186: .FI
12187: ENP END PROCEDURE CBLCK
12188: EJC
12189: *
12190: * CDGCG -- GENERATE CODE FOR COMPLEX GOTO
12191: *
12192: * USED BY CMPIL TO PROCESS COMPLEX GOTO TREE
12193: *
12194: * (WB) MUST BE COLLECTABLE
12195: * (XR) EXPRESSION POINTER
12196: * JSR CDGCG CALL TO GENERATE COMPLEX GOTO
12197: * (XL,XR,WA) DESTROYED
12198: *
12199: CDGCG PRC E,0 ENTRY POINT
12200: MOV CMOPN(XR),XL GET UNARY GOTO OPERATOR
12201: MOV CMROP(XR),XR POINT TO GOTO OPERAND
12202: BEQ XL,=OPDVD,CDGC2 JUMP IF DIRECT GOTO
12203: JSR CDGNM GENERATE OPND BY NAME IF NOT DIRECT
12204: *
12205: * RETURN POINT
12206: *
12207: CDGC1 MOV XL,WA GOTO OPERATOR
12208: JSR CDWRD GENERATE IT
12209: EXI RETURN TO CALLER
12210: *
12211: * DIRECT GOTO
12212: *
12213: CDGC2 JSR CDGVL GENERATE OPERAND BY VALUE
12214: BRN CDGC1 MERGE TO RETURN
12215: ENP END PROCEDURE CDGCG
12216: EJC
12217: *
12218: * CDGEX -- BUILD EXPRESSION BLOCK
12219: *
12220: * CDGEX IS PASSED A POINTER TO AN EXPRESSION TREE (SEE
12221: * EXPAN) AND RETURNS AN EXPRESSION (SEBLK OR EXBLK).
12222: *
12223: * (WC) SOME COLLECTABLE VALUE
12224: * (WB) INTEGER IN RANGE 0 LE X LE MXLEN
12225: * (XL) PTR TO EXPRESSION TREE
12226: * JSR CDGEX CALL TO BUILD EXPRESSION
12227: * (XR) PTR TO SEBLK OR EXBLK
12228: * (XL,WA,WB) DESTROYED
12229: *
12230: CDGEX PRC R,0 ENTRY POINT, RECURSIVE
12231: BLO (XL),=B$VR$,CDGX1 JUMP IF NOT VARIABLE
12232: *
12233: * HERE FOR NATURAL VARIABLE, BUILD SEBLK
12234: *
12235: MOV *SESI$,WA SET SIZE OF SEBLK
12236: JSR ALLOC ALLOCATE SPACE FOR SEBLK
12237: MOV =B$SEL,(XR) SET TYPE WORD
12238: MOV XL,SEVAR(XR) STORE VRBLK POINTER
12239: EXI RETURN TO CDGEX CALLER
12240: *
12241: * HERE IF NOT VARIABLE, BUILD EXBLK
12242: *
12243: CDGX1 MOV XL,XR COPY TREE POINTER
12244: MOV WC,-(XS) SAVE WC
12245: MOV CWCOF,XL SAVE CURRENT OFFSET
12246: MOV (XR),WA GET TYPE WORD
12247: BNE WA,=B$CMT,CDGX2 CALL BY VALUE IF NOT CMBLK
12248: BGE CMTYP(XR),=C$$NM,CDGX2 JUMP IF CMBLK ONLY BY VALUE
12249: EJC
12250: *
12251: * CDGEX (CONTINUED)
12252: *
12253: * HERE IF EXPRESSION CAN BE EVALUATED BY NAME
12254: *
12255: JSR CDGNM GENERATE CODE BY NAME
12256: MOV =ORNM$,WA LOAD RETURN BY NAME WORD
12257: BRN CDGX3 MERGE WITH VALUE CASE
12258: *
12259: * HERE IF EXPRESSION CAN ONLY BE EVALUATED BY VALUE
12260: *
12261: CDGX2 JSR CDGVL GENERATE CODE BY VALUE
12262: MOV =ORVL$,WA LOAD RETURN BY VALUE WORD
12263: *
12264: * MERGE HERE TO CONSTRUCT EXBLK
12265: *
12266: CDGX3 JSR CDWRD GENERATE RETURN WORD
12267: JSR EXBLD BUILD EXBLK
12268: MOV (XS)+,WC RESTORE WC
12269: EXI RETURN TO CDGEX CALLER
12270: ENP END PROCEDURE CDGEX
12271: EJC
12272: *
12273: * CDGNM -- GENERATE CODE BY NAME
12274: *
12275: * CDGNM IS CALLED DURING THE COMPILATION PROCESS TO
12276: * GENERATE CODE BY NAME FOR AN EXPRESSION. SEE CDBLK
12277: * DESCRIPTION FOR DETAILS OF CODE GENERATED. THE INPUT
12278: * TO CDGNM IS AN EXPRESSION TREE AS GENERATED BY EXPAN.
12279: *
12280: * CDGNM IS A RECURSIVE PROCEDURE WHICH PROCEEDS BY MAKING
12281: * RECURSIVE CALLS TO GENERATE CODE FOR OPERANDS.
12282: *
12283: * (WB) INTEGER IN RANGE 0 LE N LE DNAMB
12284: * (XR) PTR TO TREE GENERATED BY EXPAN
12285: * (WC) CONSTANT FLAG (SEE BELOW)
12286: * JSR CDGNM CALL TO GENERATE CODE BY NAME
12287: * (XR,WA) DESTROYED
12288: * (WC) SET NON-ZERO IF NON-CONSTANT
12289: *
12290: * WC IS SET TO A NON-ZERO (COLLECTABLE) VALUE IF THE
12291: * EXPRESSION FOR WHICH CODE IS GENERATED CANNOT BE
12292: * EVALUATED AT COMPILE TIME, OTHERWISE WC IS UNCHANGED.
12293: *
12294: * THE CODE IS GENERATED IN THE CURRENT CCBLK (SEE CDWRD).
12295: *
12296: CDGNM PRC R,0 ENTRY POINT, RECURSIVE
12297: MOV XL,-(XS) SAVE ENTRY XL
12298: MOV WB,-(XS) SAVE ENTRY WB
12299: CHK CHECK FOR STACK OVERFLOW
12300: MOV (XR),WA LOAD TYPE WORD
12301: BEQ WA,=B$CMT,CGN04 JUMP IF CMBLK
12302: BHI WA,=B$VR$,CGN02 JUMP IF SIMPLE VARIABLE
12303: *
12304: * MERGE HERE FOR OPERAND YIELDING VALUE (E.G. CONSTANT)
12305: *
12306: CGN01 ERB 208,SYNTAX ERROR. VALUE USED WHERE NAME IS REQUIRED
12307: *
12308: * HERE FOR NATURAL VARIABLE REFERENCE
12309: *
12310: CGN02 MOV =OLVN$,WA LOAD VARIABLE LOAD CALL
12311: JSR CDWRD GENERATE IT
12312: MOV XR,WA COPY VRBLK POINTER
12313: JSR CDWRD GENERATE VRBLK POINTER
12314: EJC
12315: *
12316: * CDGNM (CONTINUED)
12317: *
12318: * HERE TO EXIT WITH WC SET CORRECTLY
12319: *
12320: CGN03 MOV (XS)+,WB RESTORE ENTRY WB
12321: MOV (XS)+,XL RESTORE ENTRY XL
12322: EXI RETURN TO CDGNM CALLER
12323: *
12324: * HERE FOR CMBLK
12325: *
12326: CGN04 MOV XR,XL COPY CMBLK POINTER
12327: MOV CMTYP(XR),XR LOAD CMBLK TYPE
12328: BGE XR,=C$$NM,CGN01 ERROR IF NOT NAME OPERAND
12329: BSW XR,C$$NM ELSE SWITCH ON TYPE
12330: IFF C$ARR,CGN05 ARRAY REFERENCE
12331: IFF C$FNC,CGN08 FUNCTION CALL
12332: IFF C$DEF,CGN09 DEFERRED EXPRESSION
12333: IFF C$IND,CGN10 INDIRECT REFERENCE
12334: IFF C$KEY,CGN11 KEYWORD REFERENCE
12335: IFF C$UBO,CGN08 UNDEFINED BINARY OP
12336: IFF C$UUO,CGN08 UNDEFINED UNARY OP
12337: ESW END SWITCH ON CMBLK TYPE
12338: *
12339: * HERE TO GENERATE CODE FOR ARRAY REFERENCE
12340: *
12341: CGN05 MOV *CMOPN,WB POINT TO ARRAY OPERAND
12342: *
12343: * LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS
12344: *
12345: CGN06 JSR CMGEN GENERATE CODE FOR NEXT OPERAND
12346: MOV CMLEN(XL),WC LOAD LENGTH OF CMBLK
12347: BLT WB,WC,CGN06 LOOP TILL ALL GENERATED
12348: *
12349: * GENERATE APPROPRIATE ARRAY CALL
12350: *
12351: MOV =OAON$,WA LOAD ONE-SUBSCRIPT CASE CALL
12352: BEQ WC,*CMAR1,CGN07 JUMP TO EXIT IF ONE SUBSCRIPT CASE
12353: MOV =OAMN$,WA ELSE LOAD MULTI-SUBSCRIPT CASE CALL
12354: JSR CDWRD GENERATE CALL
12355: MOV WC,WA COPY CMBLK LENGTH
12356: BTW WA CONVERT TO WORDS
12357: SUB =CMVLS,WA CALCULATE NUMBER OF SUBSCRIPTS
12358: EJC
12359: *
12360: * CDGNM (CONTINUED)
12361: *
12362: * HERE TO EXIT GENERATING WORD (NON-CONSTANT)
12363: *
12364: CGN07 MNZ WC SET RESULT NON-CONSTANT
12365: JSR CDWRD GENERATE WORD
12366: BRN CGN03 BACK TO EXIT
12367: *
12368: * HERE TO GENERATE CODE FOR FUNCTIONS AND UNDEFINED OPRS
12369: *
12370: CGN08 MOV XL,XR COPY CMBLK POINTER
12371: JSR CDGVL GEN CODE BY VALUE FOR CALL
12372: MOV =OFNE$,WA GET EXTRA CALL FOR BY NAME
12373: BRN CGN07 BACK TO GENERATE AND EXIT
12374: *
12375: * HERE TO GENERATE CODE FOR DEFERED EXPRESSION
12376: *
12377: CGN09 MOV CMROP(XL),XR CHECK IF VARIABLE
12378: BHI (XR),=B$VR$,CGN02 TREAT *VARIABLE AS SIMPLE VAR
12379: MOV XR,XL COPY PTR TO EXPRESSION TREE
12380: JSR CDGEX ELSE BUILD EXBLK
12381: MOV =OLEX$,WA SET CALL TO LOAD EXPR BY NAME
12382: JSR CDWRD GENERATE IT
12383: MOV XR,WA COPY EXBLK POINTER
12384: JSR CDWRD GENERATE EXBLK POINTER
12385: BRN CGN03 BACK TO EXIT
12386: *
12387: * HERE TO GENERATE CODE FOR INDIRECT REFERENCE
12388: *
12389: CGN10 MOV CMROP(XL),XR GET OPERAND
12390: JSR CDGVL GENERATE CODE BY VALUE FOR IT
12391: MOV =OINN$,WA LOAD CALL FOR INDIRECT BY NAME
12392: BRN CGN12 MERGE
12393: *
12394: * HERE TO GENERATE CODE FOR KEYWORD REFERENCE
12395: *
12396: CGN11 MOV CMROP(XL),XR GET OPERAND
12397: JSR CDGNM GENERATE CODE BY NAME FOR IT
12398: MOV =OKWN$,WA LOAD CALL FOR KEYWORD BY NAME
12399: *
12400: * KEYWORD, INDIRECT MERGE HERE
12401: *
12402: CGN12 JSR CDWRD GENERATE CODE FOR OPERATOR
12403: BRN CGN03 EXIT
12404: ENP END PROCEDURE CDGNM
12405: EJC
12406: *
12407: * CDGVL -- GENERATE CODE BY VALUE
12408: *
12409: * CDGVL IS CALLED DURING THE COMPILATION PROCESS TO
12410: * GENERATE CODE BY VALUE FOR AN EXPRESSION. SEE CDBLK
12411: * DESCRIPTION FOR DETAILS OF THE CODE GENERATED. THE INPUT
12412: * TO CDGVL IS AN EXPRESSION TREE AS GENERATED BY EXPAN.
12413: *
12414: * CDGVL IS A RECURSIVE PROCEDURE WHICH PROCEEDS BY MAKING
12415: * RECURSIVE CALLS TO GENERATE CODE FOR OPERANDS.
12416: *
12417: * (WB) INTEGER IN RANGE 0 LE N LE DNAMB
12418: * (XR) PTR TO TREE GENERATED BY EXPAN
12419: * (WC) CONSTANT FLAG (SEE BELOW)
12420: * JSR CDGVL CALL TO GENERATE CODE BY VALUE
12421: * (XR,WA) DESTROYED
12422: * (WC) SET NON-ZERO IF NON-CONSTANT
12423: *
12424: * WC IS SET TO A NON-ZERO (COLLECTABLE) VALUE IF THE
12425: * EXPRESSION FOR WHICH CODE IS GENERATED CANNOT BE
12426: * EVALUATED AT COMPILE TIME, OTHERWISE WC IS UNCHANGED.
12427: *
12428: * IF WC IS NON-ZERO ON ENTRY, THEN PREEVALUATION IS NOT
12429: * ALLOWED REGARDLESS OF THE NATURE OF THE OPERAND.
12430: *
12431: * THE CODE IS GENERATED IN THE CURRENT CCBLK (SEE CDWRD).
12432: *
12433: CDGVL PRC R,0 ENTRY POINT, RECURSIVE
12434: MOV (XR),WA LOAD TYPE WORD
12435: BEQ WA,=B$CMT,CGV01 JUMP IF CMBLK
12436: BLT WA,=B$VRA,CGV00 JUMP IF ICBLK, RCBLK, SCBLK
12437: *
12438: * HERE FOR VARIABLE VALUE REFERENCE
12439: *
12440: CGVL0 MNZ WC INDICATE NON-CONSTANT VALUE
12441: *
12442: * MERGE HERE FOR SIMPLE CONSTANT (ICBLK,RCBLK,SCBLK)
12443: * AND FOR VARIABLES CORRESPONDING TO CONSTANT KEYWORDS.
12444: *
12445: CGV00 MOV XR,WA COPY PTR TO VAR OR CONSTANT
12446: JSR CDWRD GENERATE AS CODE WORD
12447: EXI RETURN TO CALLER
12448: EJC
12449: *
12450: * CDGVL (CONTINUED)
12451: *
12452: * HERE FOR TREE NODE (CMBLK)
12453: *
12454: CGV01 MOV WB,-(XS) SAVE ENTRY WB
12455: MOV XL,-(XS) SAVE ENTRY XL
12456: MOV WC,-(XS) SAVE ENTRY CONSTANT FLAG
12457: MOV CWCOF,-(XS) SAVE INITIAL CODE OFFSET
12458: CHK CHECK FOR STACK OVERFLOW
12459: *
12460: * PREPARE TO GENERATE CODE FOR CMBLK. WC IS CLEARED TO
12461: * START WITH AND IS RESET NON-ZERO FOR ANY NON-CONSTANT
12462: * CODE GENERATED. IF IT IS STILL ZERO AFTER GENERATING ALL
12463: * THE CMBLK CODE, THEN ITS VALUE IS COMPUTED AS THE RESULT.
12464: *
12465: MOV XR,XL COPY CMBLK POINTER
12466: MOV CMTYP(XR),XR LOAD CMBLK TYPE
12467: ZER WC CLEAR OPTIMISE FLAG
12468: BLE XR,=C$PR$,CGV02 JUMP IF NOT PREDICATE VALUE
12469: MNZ WC ELSE FORCE NON-CONSTANT CASE
12470: *
12471: * HERE WITH WC SET APPROPRIATELY
12472: *
12473: CGV02 BSW XR,C$$NV SWITCH TO APPROPRIATE GENERATOR
12474: IFF C$ARR,CGV03 ARRAY REFERENCE
12475: IFF C$FNC,CGV05 FUNCTION CALL
12476: IFF C$DEF,CGV14 DEFERRED EXPRESSION
12477: IFF C$SEL,CGV15 SELECTION
12478: IFF C$IND,CGV31 INDIRECT REFERENCE
12479: IFF C$KEY,CGV27 KEYWORD REFERENCE
12480: IFF C$UBO,CGV29 UNDEFINED BINOP
12481: IFF C$UUO,CGV30 UNDEFINED UNOP
12482: IFF C$BVL,CGV18 BINOPS WITH VAL OPDS
12483: IFF C$ALT,CGV18 ALTERNATION
12484: IFF C$UVL,CGV19 UNOPS WITH VALU OPND
12485: IFF C$ASS,CGV21 ASSIGNMENT
12486: IFF C$CNC,CGV24 CONCATENATION
12487: IFF C$UNM,CGV27 UNOPS WITH NAME OPND
12488: IFF C$CNP,CGV24 CONCAT. NOT PATTERN
12489: IFF C$BVN,CGV26 BINARY $ AND .
12490: IFF C$INT,CGV31 INTERROGATION
12491: IFF C$NEG,CGV28 NEGATION
12492: IFF C$PMT,CGV18 PATTERN MATCH
12493: ESW END SWITCH ON CMBLK TYPE
12494: EJC
12495: *
12496: * CDGVL (CONTINUED)
12497: *
12498: * HERE TO GENERATE CODE FOR ARRAY REFERENCE
12499: *
12500: CGV03 MOV *CMOPN,WB SET OFFSET TO ARRAY OPERAND
12501: *
12502: * LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS
12503: *
12504: CGV04 JSR CMGEN GEN VALUE CODE FOR NEXT OPERAND
12505: MOV CMLEN(XL),WC LOAD CMBLK LENGTH
12506: BLT WB,WC,CGV04 LOOP BACK IF MORE TO GO
12507: *
12508: * GENERATE CALL TO APPROPRIATE ARRAY REFERENCE ROUTINE
12509: *
12510: MOV =OAOV$,WA SET ONE SUBSCRIPT CALL IN CASE
12511: BEQ WC,*CMAR1,CGV32 JUMP TO EXIT IF 1-SUB CASE
12512: MOV =OAMV$,WA ELSE SET CALL FOR MULTI-SUBSCRIPTS
12513: JSR CDWRD GENERATE CALL
12514: MOV WC,WA COPY LENGTH OF CMBLK
12515: SUB *CMVLS,WA SUBTRACT STANDARD LENGTH
12516: BTW WA GET NUMBER OF WORDS
12517: BRN CGV32 JUMP TO GENERATE SUBSCRIPT COUNT
12518: *
12519: * HERE TO GENERATE CODE FOR FUNCTION CALL
12520: *
12521: CGV05 MOV *CMVLS,WB SET OFFSET TO FIRST ARGUMENT
12522: *
12523: * LOOP TO GENERATE CODE FOR ARGUMENTS
12524: *
12525: CGV06 BEQ WB,CMLEN(XL),CGV07 JUMP IF ALL GENERATED
12526: JSR CMGEN ELSE GEN VALUE CODE FOR NEXT ARG
12527: BRN CGV06 BACK TO GENERATE NEXT ARGUMENT
12528: *
12529: * HERE TO GENERATE ACTUAL FUNCTION CALL
12530: *
12531: CGV07 SUB *CMVLS,WB GET NUMBER OF ARG PTRS (BAUS)
12532: BTW WB CONVERT BAUS TO WORDS
12533: MOV CMOPN(XL),XR LOAD FUNCTION VRBLK POINTER
12534: BNZ VRLEN(XR),CGV12 JUMP IF NOT SYSTEM FUNCTION
12535: MOV VRSVP(XR),XL LOAD SVBLK PTR IF SYSTEM VAR
12536: MOV SVBIT(XL),WA LOAD BIT MASK
12537: ANB BTFFC,WA TEST FOR FAST FUNCTION CALL ALLOWED
12538: ZRB WA,CGV12 JUMP IF NOT
12539: EJC
12540: *
12541: * CDGVL (CONTINUED)
12542: *
12543: * HERE IF FAST FUNCTION CALL IS ALLOWED
12544: *
12545: MOV SVBIT(XL),WA RELOAD BIT INDICATORS
12546: ANB BTPRE,WA TEST FOR PREEVALUATION OK
12547: NZB WA,CGV08 JUMP IF PREEVALUATION PERMITTED
12548: MNZ WC ELSE SET RESULT NON-CONSTANT
12549: *
12550: * TEST FOR CORRECT NUMBER OF ARGS FOR FAST CALL
12551: *
12552: CGV08 MOV VRFNC(XR),XL LOAD PTR TO SVFNC FIELD
12553: MOV FARGS(XL),WA LOAD SVNAR FIELD VALUE
12554: BEQ WA,WB,CGV11 JUMP IF ARGUMENT COUNT IS CORRECT
12555: BHI WA,WB,CGV09 JUMP IF TOO FEW ARGUMENTS GIVEN
12556: *
12557: * HERE IF TOO MANY ARGUMENTS, PREPARE TO GENERATE O$POPS
12558: *
12559: SUB WA,WB GET NUMBER OF EXTRA ARGS
12560: LCT WB,WB SET AS COUNT TO CONTROL LOOP
12561: MOV =OPOP$,WA SET POP CALL
12562: BRN CGV10 JUMP TO COMMON LOOP
12563: *
12564: * HERE IF TOO FEW ARGUMENTS, PREPARE TO GENERATE NULLS
12565: *
12566: CGV09 SUB WB,WA GET NUMBER OF MISSING ARGUMENTS
12567: LCT WB,WA LOAD AS COUNT TO CONTROL LOOP
12568: MOV =NULLS,WA LOAD PTR TO NULL CONSTANT
12569: *
12570: * LOOP TO GENERATE CALLS TO FIX ARGUMENT COUNT
12571: *
12572: CGV10 JSR CDWRD GENERATE ONE CALL
12573: BCT WB,CGV10 LOOP TILL ALL GENERATED
12574: *
12575: * HERE AFTER ADJUSTING ARG COUNT AS REQUIRED
12576: *
12577: CGV11 MOV XL,WA COPY POINTER TO SVFNC FIELD
12578: BRN CGV36 JUMP TO GENERATE CALL
12579: EJC
12580: *
12581: * CDGVL (CONTINUED)
12582: *
12583: * COME HERE IF FAST CALL IS NOT PERMITTED
12584: *
12585: CGV12 MOV =OFNS$,WA SET ONE ARG CALL IN CASE
12586: BEQ WB,=NUM01,CGV13 JUMP IF ONE ARG CASE
12587: MOV =OFNC$,WA ELSE LOAD CALL FOR MORE THAN 1 ARG
12588: JSR CDWRD GENERATE IT
12589: MOV WB,WA COPY ARGUMENT COUNT
12590: *
12591: * ONE ARG CASE MERGES HERE
12592: *
12593: CGV13 JSR CDWRD GENERATE =O$FNS OR ARG COUNT
12594: MOV XR,WA COPY VRBLK POINTER
12595: BRN CGV32 JUMP TO GENERATE VRBLK PTR
12596: *
12597: * HERE FOR DEFERRED EXPRESSION
12598: *
12599: CGV14 MOV CMROP(XL),XL POINT TO EXPRESSION TREE
12600: JSR CDGEX BUILD EXBLK OR SEBLK
12601: MOV XR,WA COPY BLOCK PTR
12602: JSR CDWRD GENERATE PTR TO EXBLK OR SEBLK
12603: BRN CGV34 JUMP TO EXIT, CONSTANT TEST
12604: *
12605: * HERE TO GENERATE CODE FOR SELECTION
12606: *
12607: CGV15 ZER -(XS) ZERO PTR TO CHAIN OF FORWARD JUMPS
12608: ZER -(XS) ZERO PTR TO PREV O$SLC FORWARD PTR
12609: MOV *CMVLS,WB POINT TO FIRST ALTERNATIVE
12610: MOV =OSLA$,WA SET INITIAL CODE WORD
12611: *
12612: * 0(XS) IS THE OFFSET TO THE PREVIOUS WORD
12613: * WHICH REQUIRES FILLING IN WITH AN
12614: * OFFSET TO THE FOLLOWING O$SLC,O$SLD
12615: *
12616: * 1(XS) IS THE HEAD OF A CHAIN OF OFFSET
12617: * POINTERS INDICATING THOSE LOCATIONS
12618: * TO BE FILLED WITH OFFSETS PAST
12619: * THE END OF ALL THE ALTERNATIVES
12620: *
12621: CGV16 JSR CDWRD GENERATE O$SLC (O$SLA FIRST TIME)
12622: MOV CWCOF,(XS) SET CURRENT LOC AS PTR TO FILL IN
12623: JSR CDWRD GENERATE GARBAGE WORD THERE FOR NOW
12624: JSR CMGEN GEN VALUE CODE FOR ALTERNATIVE
12625: MOV =OSLB$,WA LOAD O$SLB POINTER
12626: JSR CDWRD GENERATE O$SLB CALL
12627: MOV 1(XS),WA LOAD OLD CHAIN PTR
12628: MOV CWCOF,1(XS) SET CURRENT LOC AS NEW CHAIN HEAD
12629: JSR CDWRD GENERATE FORWARD CHAIN LINK
12630: EJC
12631: *
12632: * CDGVL (CONTINUED)
12633: *
12634: * NOW TO FILL IN THE SKIP OFFSET TO O$SLC,O$SLD
12635: *
12636: MOV (XS),XR LOAD OFFSET TO WORD TO PLUG
12637: ADD R$CCB,XR POINT TO ACTUAL LOCATION TO PLUG
12638: MOV CWCOF,(XR) PLUG PROPER OFFSET IN
12639: MOV =OSLC$,WA LOAD O$SLC PTR FOR NEXT ALTERNATIVE
12640: MOV WB,XR COPY OFFSET (DESTROY GARBAGE XR)
12641: ICA XR BUMP EXTRA TIME FOR TEST
12642: BLT XR,CMLEN(XL),CGV16 LOOP BACK IF NOT LAST ALTERNATIVE
12643: *
12644: * HERE TO GENERATE CODE FOR LAST ALTERNATIVE
12645: *
12646: MOV =OSLD$,WA GET HEADER CALL
12647: JSR CDWRD GENERATE O$SLD CALL
12648: JSR CMGEN GENERATE CODE FOR LAST ALTERNATIVE
12649: ICA XS POP OFFSET PTR
12650: MOV (XS)+,XR LOAD CHAIN PTR
12651: *
12652: * LOOP TO PLUG OFFSETS PAST STRUCTURE
12653: *
12654: CGV17 ADD R$CCB,XR MAKE NEXT PTR ABSOLUTE
12655: MOV (XR),WA LOAD FORWARD PTR
12656: MOV CWCOF,(XR) PLUG REQUIRED OFFSET
12657: MOV WA,XR COPY FORWARD PTR
12658: BNZ WA,CGV17 LOOP BACK IF MORE TO GO
12659: BRN CGV33 ELSE JUMP TO EXIT (NOT CONSTANT)
12660: *
12661: * HERE FOR BINARY OPS WITH VALUE OPERANDS
12662: *
12663: CGV18 MOV CMLOP(XL),XR LOAD LEFT OPERAND POINTER
12664: JSR CDGVL GEN VALUE CODE FOR LEFT OPERAND
12665: *
12666: * HERE FOR UNARY OPS WITH VALUE OPERAND (BINOPS MERGE)
12667: *
12668: CGV19 MOV CMROP(XL),XR LOAD RIGHT (ONLY) OPERAND PTR
12669: JSR CDGVL GEN CODE BY VALUE
12670: EJC
12671: *
12672: * CDGVL (CONTINUED)
12673: *
12674: * MERGE HERE TO GENERATE OPERATOR CALL FROM CMOPN FIELD
12675: *
12676: CGV20 MOV CMOPN(XL),WA LOAD OPERATOR CALL POINTER
12677: BRN CGV36 JUMP TO GENERATE IT WITH CONS TEST
12678: *
12679: * HERE FOR ASSIGNMENT
12680: *
12681: CGV21 MOV CMLOP(XL),XR LOAD LEFT OPERAND POINTER
12682: BLO (XR),=B$VR$,CGV22 JUMP IF NOT VARIABLE
12683: *
12684: * HERE FOR ASSIGNMENT TO SIMPLE VARIABLE
12685: *
12686: MOV CMROP(XL),XR LOAD RIGHT OPERAND PTR
12687: JSR CDGVL GENERATE CODE BY VALUE
12688: MOV CMLOP(XL),WA RELOAD LEFT OPERAND VRBLK PTR
12689: ADD *VRSTO,WA POINT TO VRSTO FIELD
12690: BRN CGV32 JUMP TO GENERATE STORE PTR
12691: *
12692: * HERE IF NOT SIMPLE VARIABLE ASSIGNMENT
12693: *
12694: CGV22 JSR EXPAP TEST FOR PATTERN MATCH ON LEFT SIDE
12695: PPM CGV23 JUMP IF NOT PATTERN MATCH
12696: *
12697: * HERE FOR PATTERN REPLACEMENT
12698: *
12699: MOV CMROP(XR),CMLOP(XL) SAVE PATTERN PTR IN SAFE PLACE
12700: MOV CMLOP(XR),XR LOAD SUBJECT PTR
12701: JSR CDGNM GEN CODE BY NAME FOR SUBJECT
12702: MOV CMLOP(XL),XR LOAD PATTERN PTR
12703: JSR CDGVL GEN CODE BY VALUE FOR PATTERN
12704: MOV =OPMN$,WA LOAD MATCH BY NAME CALL
12705: JSR CDWRD GENERATE IT
12706: MOV CMROP(XL),XR LOAD REPLACEMENT VALUE PTR
12707: JSR CDGVL GEN CODE BY VALUE
12708: MOV =ORPL$,WA LOAD REPLACE CALL
12709: BRN CGV32 JUMP TO GEN AND EXIT (NOT CONSTANT)
12710: *
12711: * HERE FOR ASSIGNMENT TO COMPLEX VARIABLE
12712: *
12713: CGV23 MNZ WC INHIBIT PRE-EVALUATION
12714: JSR CDGNM GEN CODE BY NAME FOR LEFT SIDE
12715: BRN CGV31 MERGE WITH UNOP CIRCUIT
12716: EJC
12717: *
12718: * CDGVL (CONTINUED)
12719: *
12720: * HERE FOR CONCATENATION
12721: *
12722: CGV24 MOV CMLOP(XL),XR LOAD LEFT OPERAND PTR
12723: BNE (XR),=B$CMT,CGV18 ORDINARY BINOP IF NOT CMBLK
12724: MOV CMTYP(XR),WB LOAD CMBLK TYPE CODE
12725: BEQ WB,=C$INT,CGV25 SPECIAL CASE IF INTERROGATION
12726: BEQ WB,=C$NEG,CGV25 OR NEGATION
12727: BNE WB,=C$FNC,CGV18 ELSE ORDINARY BINOP IF NOT FUNCTION
12728: MOV CMOPN(XR),XR ELSE LOAD FUNCTION VRBLK PTR
12729: BNZ VRLEN(XR),CGV18 ORDINARY BINOP IF NOT SYSTEM VAR
12730: MOV VRSVP(XR),XR ELSE POINT TO SVBLK
12731: MOV SVBIT(XR),WA LOAD BIT INDICATORS
12732: ANB BTPRD,WA TEST FOR PREDICATE FUNCTION
12733: ZRB WA,CGV18 ORDINARY BINOP IF NOT
12734: *
12735: * HERE IF LEFT ARG OF CONCATENATION IS PREDICATE FUNCTION
12736: *
12737: CGV25 MOV CMLOP(XL),XR RELOAD LEFT ARG
12738: JSR CDGVL GEN CODE BY VALUE
12739: MOV =OPOP$,WA LOAD POP CALL
12740: JSR CDWRD GENERATE IT
12741: MOV CMROP(XL),XR LOAD RIGHT OPERAND
12742: JSR CDGVL GEN CODE BY VALUE AS RESULT CODE
12743: BRN CGV33 EXIT (NOT CONSTANT)
12744: *
12745: * HERE TO GENERATE CODE FOR PATTERN, IMMEDIATE ASSIGNMENT
12746: *
12747: CGV26 MOV CMLOP(XL),XR LOAD LEFT OPERAND
12748: JSR CDGVL GEN CODE BY VALUE, MERGE
12749: *
12750: * HERE FOR UNOPS WITH ARG BY NAME (BINARY $ . MERGE)
12751: *
12752: CGV27 MOV CMROP(XL),XR LOAD RIGHT OPERAND PTR
12753: JSR CDGNM GEN CODE BY NAME FOR RIGHT ARG
12754: MOV CMOPN(XL),XR GET OPERATOR CODE WORD
12755: BNE (XR),=O$KWV,CGV20 GEN CALL UNLESS KEYWORD VALUE
12756: EJC
12757: *
12758: * CDGVL (CONTINUED)
12759: *
12760: * HERE FOR KEYWORD BY VALUE. THIS IS CONSTANT ONLY IF
12761: * THE OPERAND IS ONE OF THE SPECIAL SYSTEM VARIABLES WITH
12762: * THE SVCKW BIT SET TO INDICATE A CONSTANT KEYWORD VALUE.
12763: * NOTE THAT THE ONLY CONSTANT OPERAND BY NAME IS A VARIABLE
12764: *
12765: BNZ WC,CGV20 GEN CALL IF NON-CONSTANT (NOT VAR)
12766: MNZ WC ELSE SET NON-CONSTANT IN CASE
12767: MOV CMROP(XL),XR LOAD PTR TO OPERAND VRBLK
12768: BNZ VRLEN(XR),CGV20 GEN (NON-CONSTANT) IF NOT SYS VAR
12769: MOV VRSVP(XR),XR ELSE LOAD PTR TO SVBLK
12770: MOV SVBIT(XR),WA LOAD BIT MASK
12771: ANB BTCKW,WA TEST FOR CONSTANT KEYWORD
12772: ZRB WA,CGV20 GO GEN IF NOT CONSTANT
12773: ZER WC ELSE SET RESULT CONSTANT
12774: BRN CGV20 AND JUMP BACK TO GENERATE CALL
12775: *
12776: * HERE TO GENERATE CODE FOR NEGATION
12777: *
12778: CGV28 MOV =ONTA$,WA GET INITIAL WORD
12779: JSR CDWRD GENERATE IT
12780: MOV CWCOF,WB SAVE NEXT OFFSET
12781: JSR CDWRD GENERATE GUNK WORD FOR NOW
12782: MOV CMROP(XL),XR LOAD RIGHT OPERAND PTR
12783: JSR CDGVL GEN CODE BY VALUE
12784: MOV =ONTB$,WA LOAD END OF EVALUATION CALL
12785: JSR CDWRD GENERATE IT
12786: MOV WB,XR COPY OFFSET TO WORD TO PLUG
12787: ADD R$CCB,XR POINT TO ACTUAL WORD TO PLUG
12788: MOV CWCOF,(XR) PLUG WORD WITH CURRENT OFFSET
12789: MOV =ONTC$,WA LOAD FINAL CALL
12790: BRN CGV32 JUMP TO GENERATE IT (NOT CONSTANT)
12791: *
12792: * HERE TO GENERATE CODE FOR UNDEFINED BINARY OPERATOR
12793: *
12794: CGV29 MOV CMLOP(XL),XR LOAD LEFT OPERAND PTR
12795: JSR CDGVL GENERATE CODE BY VALUE
12796: EJC
12797: *
12798: * CDGVL (CONTINUED)
12799: *
12800: * HERE TO GENERATE CODE FOR UNDEFINED UNARY OPERATOR
12801: *
12802: CGV30 MOV =C$UO$,WB SET UNOP CODE + 1
12803: SUB CMTYP(XL),WB SET NUMBER OF ARGS (1 OR 2)
12804: *
12805: * MERGE HERE FOR UNDEFINED OPERATORS
12806: *
12807: MOV CMROP(XL),XR LOAD RIGHT (ONLY) OPERAND POINTER
12808: JSR CDGVL GEN VALUE CODE FOR RIGHT OPERAND
12809: MOV CMOPN(XL),XR LOAD POINTER TO OPERATOR DV
12810: MOV DVOPN(XR),XR LOAD POINTER OFFSET
12811: WTB XR CONVERT WORD OFFSET TO BAUS
12812: ADD =R$UBA,XR POINT TO PROPER FUNCTION PTR
12813: SUB *VRFNC,XR SET STANDARD FUNCTION OFFSET
12814: BRN CGV12 MERGE WITH FUNCTION CALL CIRCUIT
12815: *
12816: * HERE TO GENERATE CODE FOR INTERROGATION, INDIRECTION
12817: *
12818: CGV31 MNZ WC SET NON CONSTANT
12819: BRN CGV19 MERGE
12820: *
12821: * HERE TO EXIT GENERATING A WORD, RESULT NOT CONSTANT
12822: *
12823: CGV32 JSR CDWRD GENERATE WORD, MERGE
12824: *
12825: * HERE TO EXIT WITH NO WORD GENERATED, NOT CONSTANT
12826: *
12827: CGV33 MNZ WC INDICATE RESULT IS NOT CONSTANT
12828: *
12829: * COMMON EXIT POINT
12830: *
12831: CGV34 ICA XS POP INITIAL CODE OFFSET
12832: MOV (XS)+,WA RESTORE OLD CONSTANT FLAG
12833: MOV (XS)+,XL RESTORE ENTRY XL
12834: MOV (XS)+,WB RESTORE ENTRY WB
12835: BNZ WC,CGV35 JUMP IF NOT CONSTANT
12836: MOV WA,WC ELSE RESTORE ENTRY CONSTANT FLAG
12837: *
12838: * HERE TO RETURN AFTER DEALING WITH WC SETTING
12839: *
12840: CGV35 EXI RETURN TO CDGVL CALLER
12841: *
12842: * EXIT HERE TO GENERATE WORD AND TEST FOR CONSTANT
12843: *
12844: CGV36 JSR CDWRD GENERATE WORD
12845: BNZ WC,CGV34 JUMP TO EXIT IF NOT CONSTANT
12846: EJC
12847: *
12848: * CDGVL (CONTINUED)
12849: *
12850: * HERE TO PREEVALUATE CONSTANT SUB-EXPRESSION
12851: *
12852: MOV =ORVL$,WA LOAD CALL TO RETURN VALUE
12853: JSR CDWRD GENERATE IT
12854: MOV (XS),XL LOAD INITIAL CODE OFFSET
12855: JSR EXBLD BUILD EXBLK FOR EXPRESSION
12856: ZER WB SET TO EVALUATE BY VALUE
12857: JSR EVALX EVALUATE EXPRESSION
12858: PPM SHOULD NOT FAIL
12859: MOV (XR),WA LOAD TYPE WORD OF RESULT
12860: BLO WA,=P$AAA,CGV37 JUMP IF NOT PATTERN
12861: MOV =OLPT$,WA ELSE LOAD SPECIAL PATTERN LOAD CALL
12862: JSR CDWRD GENERATE IT
12863: *
12864: * MERGE HERE TO GENERATE POINTER TO RESULTING CONSTANT
12865: *
12866: CGV37 MOV XR,WA COPY CONSTANT POINTER
12867: JSR CDWRD GENERATE PTR
12868: ZER WC SET RESULT CONSTANT
12869: BRN CGV34 JUMP BACK TO EXIT
12870: ENP END PROCEDURE CDGVL
12871: EJC
12872: *
12873: * CDWRD -- GENERATE ONE WORD OF CODE
12874: *
12875: * CDWRD WRITES ONE WORD INTO THE CURRENT CODE BLOCK UNDER
12876: * CONSTRUCTION. A NEW, LARGER, BLOCK IS ALLOCATED IF THERE
12877: * IS INSUFFICIENT ROOM IN THE CURRENT BLOCK. CDWRD ENSURES
12878: * THAT THERE ARE AT LEAST THREE WORDS LEFT IN THE BLOCK
12879: * AFTER ENTERING THE NEW WORD. THIS GUARANTEES THAT ANY
12880: * EXTRA SPACE AT THE END CAN BE SPLIT OFF AS A CCBLK.
12881: *
12882: * (WA) WORD TO BE GENERATED
12883: * JSR CDWRD CALL TO GENERATE WORD
12884: *
12885: CDWRD PRC E,0 ENTRY POINT
12886: MOV XR,-(XS) SAVE ENTRY XR
12887: MOV WA,-(XS) SAVE CODE WORD TO BE GENERATED
12888: *
12889: * MERGE BACK HERE AFTER ALLOCATING LARGER BLOCK
12890: *
12891: CDWD1 MOV R$CCB,XR LOAD PTR TO CCBLK BEING BUILT
12892: BNZ XR,CDWD2 JUMP IF BLOCK ALLOCATED
12893: *
12894: * HERE WE ALLOCATE AN ENTIRELY FRESH BLOCK
12895: *
12896: MOV *E$CBS,WA LOAD INITIAL LENGTH
12897: JSR ALLOC ALLOCATE CCBLK
12898: MOV =B$CCT,(XR) STORE TYPE WORD
12899: MOV *CCCOD,CWCOF SET INITIAL OFFSET
12900: MOV WA,CCLEN(XR) STORE BLOCK LENGTH
12901: MOV XR,R$CCB STORE PTR TO NEW BLOCK
12902: *
12903: * HERE WE HAVE A BLOCK WE CAN USE
12904: *
12905: CDWD2 MOV CWCOF,WA LOAD CURRENT OFFSET
12906: ADD *NUM04,WA ADJUST FOR TEST (FOUR WORDS)
12907: BLO WA,CCLEN(XR),CDWD4 JUMP IF ROOM IN THIS BLOCK
12908: *
12909: * HERE IF NO ROOM IN CURRENT BLOCK
12910: *
12911: BGE WA,MXLEN,CDWD5 JUMP IF ALREADY AT MAX SIZE
12912: ADD *E$CBS,WA ELSE GET NEW SIZE
12913: MOV XL,-(XS) SAVE ENTRY XL
12914: MOV XR,XL COPY POINTER
12915: BLT WA,MXLEN,CDWD3 JUMP IF NOT TOO LARGE
12916: MOV MXLEN,WA ELSE RESET TO MAX ALLOWED SIZE
12917: EJC
12918: *
12919: * CDWRD (CONTINUED)
12920: *
12921: * HERE WITH NEW BLOCK SIZE IN WA
12922: *
12923: CDWD3 JSR ALLOC ALLOCATE NEW BLOCK
12924: MOV XR,R$CCB STORE POINTER TO NEW BLOCK
12925: MOV =B$CCT,(XR)+ STORE TYPE WORD IN NEW BLOCK
12926: MOV WA,(XR)+ STORE BLOCK LENGTH
12927: ADD *CCUSE,XL POINT TO CCUSE,CCCOD FIELDS IN OLD
12928: MOV (XL),WA LOAD CCUSE VALUE
12929: MVW COPY USEFUL WORDS FROM OLD BLOCK
12930: MOV (XS)+,XL RESTORE XL
12931: BRN CDWD1 MERGE BACK TO TRY AGAIN
12932: *
12933: * HERE WITH ROOM IN CURRENT BLOCK
12934: *
12935: CDWD4 MOV CWCOF,WA LOAD CURRENT OFFSET
12936: ICA WA GET NEW OFFSET
12937: MOV WA,CWCOF STORE NEW OFFSET
12938: MOV WA,CCUSE(XR) STORE IN CCBLK FOR GBCOL
12939: DCA WA RESTORE PTR TO THIS WORD
12940: ADD WA,XR POINT TO CURRENT ENTRY
12941: MOV (XS)+,WA RELOAD WORD TO GENERATE
12942: MOV WA,(XR) STORE WORD IN BLOCK
12943: MOV (XS)+,XR RESTORE ENTRY XR
12944: EXI RETURN TO CALLER
12945: *
12946: * HERE IF COMPILED CODE IS TOO LONG FOR CDBLK
12947: *
12948: CDWD5 ERB 209,SYNTAX ERROR. STATEMENT IS TOO COMPLICATED.
12949: ENP END PROCEDURE CDWRD
12950: EJC
12951: *
12952: * CMGEN -- GENERATE CODE FOR CMBLK PTR
12953: *
12954: * CMGEN IS A SUBSIDIARY PROCEDURE USED TO GENERATE VALUE
12955: * CODE FOR A CMBLK PTR FROM THE MAIN CODE GENERATORS.
12956: *
12957: * (XL) CMBLK POINTER
12958: * (WB) OFFSET TO POINTER IN CMBLK
12959: * JSR CMGEN CALL TO GENERATE CODE
12960: * (XR,WA) DESTROYED
12961: * (WB) BUMPED BY ONE WORD
12962: *
12963: CMGEN PRC R,0 ENTRY POINT, RECURSIVE
12964: MOV XL,XR COPY CMBLK POINTER
12965: ADD WB,XR POINT TO CMBLK POINTER
12966: MOV (XR),XR LOAD CMBLK POINTER
12967: JSR CDGVL GENERATE CODE BY VALUE
12968: ICA WB BUMP OFFSET
12969: EXI RETURN TO CALLER
12970: ENP END PROCEDURE CMGEN
12971: EJC
12972: *
12973: * CMPIL (COMPILE SOURCE CODE)
12974: *
12975: * CMPIL IS USED TO CONVERT SNOBOL4 SOURCE CODE TO INTERNAL
12976: * FORM (SEE CDBLK FORMAT). IT IS USED BOTH FOR THE INITIAL
12977: * COMPILE AND AT RUN TIME BY THE CODE AND CONVERT FUNCTIONS
12978: * THIS PROCEDURE HAS CONTROL FOR THE ENTIRE DURATION OF
12979: * INITIAL COMPILATION. AN ERROR IN ANY PROCEDURE CALLED
12980: * DURING COMPILATION WILL LEAD FIRST TO THE ERROR SECTION
12981: * AND ULTIMATELY BACK HERE FOR RESUMED COMPILATION. THE
12982: * RE-ENTRY POINTS AFTER AN ERROR ARE SPECIALLY LABELLED -
12983: *
12984: * CMPCE RESUME AFTER CONTROL CARD ERROR
12985: * CMPLE RESUME AFTER LABEL ERROR
12986: * CMPSE RESUME AFTER STATEMENT ERROR
12987: *
12988: * JSR CMPIL CALL TO COMPILE CODE
12989: * (XR) PTR TO CDBLK FOR ENTRY STATEMENT
12990: * (XL,WA,WB,WC,RA) DESTROYED
12991: *
12992: * THE FOLLOWING GLOBAL VARIABLES ARE REFERENCED
12993: *
12994: * CMPSN NUMBER OF NEXT STATEMENT
12995: * TO BE COMPILED.
12996: *
12997: * CSWXX CONTROL CARD SWITCH VALUES ARE
12998: * CHANGED WHEN RELEVANT CONTROL
12999: * CARDS ARE MET.
13000: *
13001: * CWCOF OFFSET TO NEXT WORD IN CODE BLOCK
13002: * BEING BUILT (SEE CDWRD).
13003: *
13004: * LSTSN NUMBER OF STATEMENT MOST RECENTLY
13005: * COMPILED (INITIALLY SET TO ZERO).
13006: *
13007: * R$CIM CURRENT (INITIAL) COMPILER IMAGE
13008: * (ZERO FOR INITIAL COMPILE CALL)
13009: *
13010: * R$CNI USED TO POINT TO FOLLOWING IMAGE.
13011: * (SEE READR PROCEDURE).
13012: *
13013: * SCNGO GOTO SWITCH FOR SCANE PROCEDURE
13014: *
13015: * SCNIL LENGTH OF CURRENT IMAGE EXCLUDING
13016: * CHARACTERS REMOVED BY -INPUT.
13017: *
13018: * SCNPT CURRENT SCAN OFFSET, SEE SCANE.
13019: *
13020: * SCNRS RESCAN SWITCH FOR SCANE PROCEDURE.
13021: *
13022: * SCNSE OFFSET (IN R$CIM) OF MOST RECENTLY
13023: * SCANNED ELEMENT. SET ZERO IF NOT
13024: * CURRENTLY SCANNING ITEMS
13025: EJC
13026: *
13027: * CMPIL (CONTINUED)
13028: *
13029: * STAGE STGIC INITIAL COMPILE IN PROGRESS
13030: * STGXC CODE/CONVERT COMPILE
13031: * STGEV BUILDING EXBLK FOR EVAL
13032: * STGXT EXECUTE TIME (OUTSIDE COMPILE)
13033: * STGCE INITIAL COMPILE AFTER END LINE
13034: * STGXE EXECUTE COMPILE AFTER END LINE
13035: *
13036: * CMPIL ALSO USES A FIXED NUMBER OF LOCATIONS ON THE
13037: * MAIN STACK AS FOLLOWS. (THE DEFINITIONS OF THE ACTUAL
13038: * OFFSETS ARE IN THE DEFINITIONS SECTION).
13039: *
13040: * CMSTM(XS) POINTER TO EXPAN TREE FOR BODY OF
13041: * STATEMENT (SEE EXPAN PROCEDURE).
13042: *
13043: * CMSGO(XS) POINTER TO TREE REPRESENTATION OF
13044: * SUCCESS GOTO (SEE PROCEDURE SCNGO)9
13045: * ZERO IF NO SUCCESS GOTO IS GIVEN
13046: *
13047: * CMFGO(XS) LIKE CMSGO FOR FAILURE GOTO.
13048: *
13049: * CMCGO(XS) SET NON-ZERO ONLY IF THERE IS A
13050: * CONDITIONAL GOTO. USED FOR -FAIL,
13051: * -NOFAIL CODE GENERATION.
13052: *
13053: * CMPCD(XS) POINTER TO CDBLK FOR PREVIOUS
13054: * STATEMENT. ZERO FOR 1ST STATEMENT.
13055: *
13056: * CMFFP(XS) SET NON-ZERO IF CDFAL IN PREVIOUS
13057: * CDBLK NEEDS FILLING WITH FORWARD
13058: * POINTER, ELSE SET TO ZERO.
13059: *
13060: * CMFFC(XS) SAME AS CMFFP FOR CURRENT CDBLK
13061: *
13062: * CMSOP(XS) OFFSET TO WORD IN PREVIOUS CDBLK
13063: * TO BE FILLED IN WITH FORWARD PTR
13064: * TO NEXT CDBLK FOR SUCCESS GOTO.
13065: * ZERO IF NO FILL IN IS REQUIRED.
13066: *
13067: * CMSOC(XS) SAME AS CMSOP FOR CURRENT CDBLK.
13068: *
13069: * CMLBL(XS) POINTER TO VRBLK FOR LABEL OF
13070: * CURRENT STATEMENT. ZERO IF NO LABEL
13071: *
13072: * CMTRA(XS) POINTER TO CDBLK FOR ENTRY STMNT.
13073: EJC
13074: *
13075: * CMPIL (CONTINUED)
13076: *
13077: * ENTRY POINT
13078: *
13079: CMPIL PRC E,0 ENTRY POINT
13080: LCT WB,=CMNEN SET NUMBER OF STACK WORK LOCATIONS
13081: *
13082: * LOOP TO INITIALIZE STACK WORKING LOCATIONS
13083: *
13084: CMP00 ZER -(XS) STORE A ZERO, MAKE ONE ENTRY
13085: BCT WB,CMP00 LOOP BACK UNTIL ALL SET
13086: MOV XS,CMPXS SAVE STACK POINTER FOR ERROR SEC
13087: SSS CMPSS SAVE S-R STACK POINTER IF ANY
13088: *
13089: * LOOP THROUGH STATEMENTS
13090: *
13091: CMP01 MOV SCNPT,WB SET SCAN POINTER OFFSET
13092: MOV WB,SCNSE SET START OF ELEMENT LOCATION
13093: MOV =OCER$,WA POINT TO COMPILE ERROR CALL
13094: JSR CDWRD GENERATE AS TEMPORARY CDFAL
13095: BLT WB,SCNIL,CMP04 JUMP IF CHARS LEFT ON THIS IMAGE
13096: *
13097: * LOOP HERE AFTER COMMENT OR CONTROL CARD
13098: * ALSO SPECIAL ENTRY AFTER CONTROL CARD ERROR
13099: *
13100: CMPCE ZER XR CLEAR POSSIBLE GARBAGE XR VALUE
13101: BEQ STAGE,=STGIC,CMPC1 READ IF INITIAL COMPILE
13102: BZE R$COP,CMP02 ELSE SKIP IF NO -COPY IN FORCE
13103: *
13104: * HERE TO ATTEMPT READ (STGIC OR -COPY)
13105: *
13106: CMPC1 JSR READR READ NEXT INPUT IMAGE
13107: BZE XR,CMPC2 JUMP IF NO INPUT AVAILABLE
13108: JSR NEXTS ACQUIRE NEXT SOURCE IMAGE
13109: MOV CMPSN,LSTSN STORE STMT NO FOR USE BY LISTR
13110: ZER SCNPT RESET SCAN POINTER
13111: BRN CMP04 GO PROCESS IMAGE
13112: *
13113: * HERE IF READR HAD NOTHING TO RETURN. IF NOT DURING
13114: * INITIAL COMPILE, THEN MUST BE AT OUTER LEVEL OF -COPY
13115: * IN CODE(). R$CIM HAS BEEN RESTORED TO CODE STRING
13116: * BY COPND SO WE CONTINUE FROM THE -COPY STMT.
13117: *
13118: CMPC2 BEQ STAGE,=STGIC,CMP09 JUMP IF INITIAL COMPILE
13119: *
13120: * FOR EXECUTE TIME COMPILE, PERMIT EMBEDDED CONTROL CARDS
13121: * AND COMMENTS (BY SKIPPING TO NEXT SEMI-COLON)
13122: *
13123: CMP02 MOV R$CIM,XR GET CURRENT IMAGE
13124: MOV SCNPT,WB GET CURRENT OFFSET
13125: PLC XR,WB PREPARE TO GET CHARS
13126: *
13127: * SKIP TO SEMI-COLON
13128: *
13129: CMP03 LCH WC,(XR)+ GET CHAR
13130: ICV SCNPT ADVANCE OFFSET
13131: BEQ WC,=CH$SM,CMP04 SKIP IF SEMI-COLON FOUND
13132: BLT SCNPT,SCNIL,CMP03 LOOP IF MORE CHARS
13133: ZER XR CLEAR GARBAGE XR VALUE
13134: BRN CMP09 END OF IMAGE
13135: EJC
13136: *
13137: * CMPIL (CONTINUED)
13138: *
13139: * HERE WITH IMAGE AVAILABLE TO SCAN. NOTE THAT IF THE INPUT
13140: * STRING IS NULL, THEN EVERYTHING IS OK SINCE NULL IS
13141: * ACTUALLY ASSEMBLED AS A WORD OF BLANKS.
13142: *
13143: CMP04 MOV R$CIM,XR POINT TO CURRENT IMAGE
13144: MOV SCNPT,WB LOAD CURRENT OFFSET
13145: MOV WB,WA COPY FOR LABEL SCAN
13146: PLC XR,WB POINT TO FIRST CHARACTER
13147: LCH WC,(XR)+ LOAD FIRST CHARACTER
13148: BEQ WC,=CH$SM,CMP12 NO LABEL IF SEMICOLON
13149: BEQ WC,=CH$AS,CMPCE LOOP BACK IF COMMENT CARD
13150: BEQ WC,=CH$MN,CMP33 JUMP IF CONTROL CARD
13151: MOV R$CIM,R$CMP ABOUT TO DESTROY R$CIM
13152: MOV =CMLAB,XL POINT TO LABEL WORK STRING
13153: MOV XL,R$CIM SCANE IS TO SCAN WORK STRING
13154: PSC XL POINT TO FIRST CHARACTER POSITION
13155: SCH WC,(XL)+ STORE CHAR JUST LOADED
13156: MOV =CH$SM,WC GET A SEMICOLON
13157: SCH WC,(XL) STORE AFTER FIRST CHAR
13158: CSC XL FINISHED CHARACTER STORING
13159: ZER XL CLEAR POINTER
13160: ZER SCNPT START AT FIRST CHARACTER
13161: MOV SCNIL,-(XS) PRESERVE IMAGE LENGTH
13162: MOV =NUM02,SCNIL READ 2 CHARS AT MOST
13163: JSR SCANE SCAN FIRST CHAR FOR TYPE
13164: MOV (XS)+,SCNIL RESTORE IMAGE LENGTH
13165: MOV XL,WC NOTE RETURN CODE
13166: MOV R$CMP,XL GET OLD R$CIM
13167: MOV XL,R$CIM PUT IT BACK
13168: MOV WB,SCNPT REINSTATE OFFSET
13169: BNZ SCNBL,CMP12 BLANK SEEN - CANT BE LABEL
13170: MOV XL,XR POINT TO CURRENT IMAGE
13171: PLC XR,WB POINT TO FIRST CHAR AGAIN
13172: BEQ WC,=T$VAR,CMP06 OK IF LETTER
13173: BEQ WC,=T$CON,CMP06 OK IF DIGIT
13174: *
13175: * DROP IN OR JUMP FROM ERROR SECTION IF SCANE FAILED
13176: *
13177: CMPLE MOV R$CMP,R$CIM POINT TO BAD LINE
13178: ERB 210,BAD LABEL OR MISPLACED CONTINUATION LINE
13179: *
13180: * LOOP TO SCAN LABEL
13181: *
13182: CMP05 BEQ WC,=CH$SM,CMP07 SKIP IF SEMICOLON
13183: ICV WA BUMP OFFSET
13184: BEQ WA,SCNIL,CMP07 JUMP IF END OF IMAGE (LABEL END)
13185: EJC
13186: *
13187: * CMPIL (CONTINUED)
13188: *
13189: * ENTER LOOP AT THIS POINT
13190: *
13191: CMP06 LCH WC,(XR)+ ELSE LOAD NEXT CHARACTER
13192: .IF .CAHT
13193: BEQ WC,=CH$HT,CMP07 JUMP IF HORIZONTAL TAB
13194: .FI
13195: .IF .CAVT
13196: BEQ WC,=CH$VT,CMP07 JUMP IF VERTICAL TAB
13197: .FI
13198: BNE WC,=CH$BL,CMP05 LOOP BACK IF NON-BLANK
13199: *
13200: * HERE AFTER SCANNING OUT LABEL
13201: *
13202: CMP07 MOV WA,SCNPT SAVE UPDATED SCAN OFFSET
13203: SUB WB,WA GET LENGTH OF LABEL
13204: BZE WA,CMP12 SKIP IF LABEL LENGTH ZERO
13205: ZER XR CLEAR GARBAGE XR VALUE
13206: JSR SBSTR BUILD SCBLK FOR LABEL NAME
13207: JSR GTNVR LOCATE/CONTRUCT VRBLK
13208: PPM DUMMY (IMPOSSIBLE) ERROR RETURN
13209: MOV XR,CMLBL(XS) STORE LABEL POINTER
13210: BNZ VRLEN(XR),CMP11 JUMP IF NOT SYSTEM LABEL
13211: BNE VRSVP(XR),=V$END,CMP11 JUMP IF NOT END LABEL
13212: *
13213: * HERE FOR END LABEL SCANNED OUT
13214: *
13215: ADD =STGND,STAGE ADJUST STAGE APPROPRIATELY
13216: JSR SCANE SCAN OUT NEXT ELEMENT
13217: BEQ XL,=T$SMC,CMPEE JUMP IF END OF IMAGE
13218: BNE XL,=T$VAR,CMP08 ELSE ERROR IF NOT VARIABLE
13219: *
13220: * HERE CHECK FOR VALID INITIAL TRANSFER
13221: *
13222: BEQ VRLBL(XR),=STNDL,CMP08 JUMP IF NOT DEFINED (ERROR)
13223: MOV VRLBL(XR),CMTRA(XS) ELSE SET INITIAL ENTRY POINTER
13224: JSR SCANE SCAN NEXT ELEMENT
13225: BEQ XL,=T$SMC,CMPEE JUMP IF OK (END OF IMAGE)
13226: *
13227: * HERE FOR BAD TRANSFER LABEL
13228: *
13229: CMP08 ERB 211,SYNTAX ERROR. UNDEFINED OR ERRONEOUS ENTRY LABEL
13230: *
13231: * HERE FOR END OF INPUT (NO END LABEL DETECTED)
13232: *
13233: CMP09 ADD =STGND,STAGE ADJUST STAGE APPROPRIATELY
13234: BEQ STAGE,=STGXE,CMPEE JUMP IF CODE CALL (OK)
13235: ERB 212,SYNTAX ERROR. MISSING END LINE
13236: *
13237: * HERE AFTER PROCESSING END LINE (MERGE HERE ON END ERROR)
13238: *
13239: CMPEE MOV =OSTP$,WA SET STOP CALL POINTER
13240: JSR CDWRD GENERATE AS STATEMENT CALL
13241: BRN CMPSE JUMP TO GENERATE AS FAILURE
13242: EJC
13243: *
13244: * CMPIL (CONTINUED)
13245: *
13246: * HERE AFTER PROCESSING LABEL OTHER THAN END
13247: *
13248: CMP11 BNE STAGE,=STGIC,CMP12 JUMP IF CODE CALL - REDEF. OK
13249: BEQ VRLBL(XR),=STNDL,CMP12 ELSE CHECK FOR REDEFINITION
13250: ZER CMLBL(XS) LEAVE FIRST LABEL DECLN UNDISTURBED
13251: ERB 213,SYNTAX ERROR. DUPLICATE LABEL
13252: *
13253: * HERE AFTER DEALING WITH LABEL
13254: *
13255: CMP12 ZER WB SET FLAG FOR STATEMENT BODY
13256: JSR EXPAN GET TREE FOR STATEMENT BODY
13257: MOV XR,CMSTM(XS) STORE FOR LATER USE
13258: ZER CMSGO(XS) CLEAR SUCCESS GOTO POINTER
13259: ZER CMFGO(XS) CLEAR FAILURE GOTO POINTER
13260: ZER CMCGO(XS) CLEAR CONDITIONAL GOTO FLAG
13261: JSR SCANE SCAN NEXT ELEMENT
13262: BNE XL,=T$COL,CMP18 JUMP IT NOT COLON (NO GOTO)
13263: *
13264: * LOOP TO PROCESS GOTO FIELDS
13265: *
13266: CMP13 MNZ SCNGO SET GOTO FLAG
13267: JSR SCANE SCAN NEXT ELEMENT
13268: BEQ XL,=T$SMC,CMP32 JUMP IF NO FIELDS LEFT
13269: BEQ XL,=T$SGO,CMP14 JUMP IF S FOR SUCCESS GOTO
13270: BEQ XL,=T$FGO,CMP16 JUMP IF F FOR FAILURE GOTO
13271: *
13272: * HERE FOR UNCONDITIONAL GOTO (I.E. NOT F OR S)
13273: *
13274: MNZ SCNRS SET TO RESCAN ELEMENT NOT F,S
13275: JSR SCNGF SCAN OUT GOTO FIELD
13276: BNZ CMFGO(XS),CMP17 ERROR IF FGOTO ALREADY
13277: MOV XR,CMFGO(XS) ELSE SET AS FGOTO
13278: BRN CMP15 MERGE WITH SGOTO CIRCUIT
13279: *
13280: * HERE FOR SUCCESS GOTO
13281: *
13282: CMP14 JSR SCNGF SCAN SUCCESS GOTO FIELD
13283: MOV =NUM01,CMCGO(XS) SET CONDITIONAL GOTO FLAG
13284: *
13285: * UNCONTIONAL GOTO MERGES HERE
13286: *
13287: CMP15 BNZ CMSGO(XS),CMP17 ERROR IF SGOTO ALREADY GIVEN
13288: MOV XR,CMSGO(XS) ELSE SET SGOTO
13289: BRN CMP13 LOOP BACK FOR NEXT GOTO FIELD
13290: *
13291: * HERE FOR FAILURE GOTO
13292: *
13293: CMP16 JSR SCNGF SCAN GOTO FIELD
13294: MOV =NUM01,CMCGO(XS) SET CONDITONAL GOTO FLAG
13295: BNZ CMFGO(XS),CMP17 ERROR IF FGOTO ALREADY GIVEN
13296: MOV XR,CMFGO(XS) ELSE STORE FGOTO POINTER
13297: BRN CMP13 LOOP BACK FOR NEXT FIELD
13298: EJC
13299: *
13300: * CMPIL (CONTINUED)
13301: *
13302: * HERE FOR DUPLICATED GOTO FIELD
13303: *
13304: CMP17 ERB 214,SYNTAX ERROR. DUPLICATED GOTO FIELD
13305: *
13306: * HERE TO GENERATE CODE
13307: *
13308: CMP18 ZER SCNSE STOP POSITIONAL ERROR FLAGS
13309: MOV CMSTM(XS),XR LOAD TREE PTR FOR STATEMENT BODY
13310: ZER WB COLLECTABLE VALUE FOR WB FOR CDGVL
13311: ZER WC RESET CONSTANT FLAG FOR CDGVL
13312: JSR EXPAP TEST FOR PATTERN MATCH
13313: PPM CMP19 JUMP IF NOT PATTERN MATCH
13314: MOV =OPMS$,CMOPN(XR) ELSE SET PATTERN MATCH POINTER
13315: MOV =C$PMT,CMTYP(XR)
13316: *
13317: * HERE AFTER DEALING WITH SPECIAL PATTERN MATCH CASE
13318: *
13319: CMP19 JSR CDGVL GENERATE CODE FOR BODY OF STATEMENT
13320: MOV CMSGO(XS),XR LOAD SGOTO POINTER
13321: MOV XR,WA COPY IT
13322: BZE XR,CMP21 JUMP IF NO SUCCESS GOTO
13323: ZER CMSOC(XS) CLEAR SUCCESS OFFSET FILLIN PTR
13324: BHI XR,STATE,CMP20 JUMP IF COMPLEX GOTO
13325: *
13326: * HERE FOR SIMPLE SUCCESS GOTO (LABEL)
13327: *
13328: ADD *VRTRA,WA POINT TO VRTRA FIELD AS REQUIRED
13329: JSR CDWRD GENERATE SUCCESS GOTO
13330: BRN CMP22 JUMP TO DEAL WITH FGOTO
13331: *
13332: * HERE FOR COMPLEX SUCCESS GOTO
13333: *
13334: CMP20 BEQ XR,CMFGO(XS),CMP22 NO CODE IF SAME AS FGOTO
13335: ZER WB ELSE SET OK VALUE FOR CDGVL IN WB
13336: JSR CDGCG GENERATE CODE FOR SUCCESS GOTO
13337: BRN CMP22 JUMP TO DEAL WITH FGOTO
13338: *
13339: * HERE FOR NO SUCCESS GOTO
13340: *
13341: CMP21 MOV CWCOF,CMSOC(XS) SET SUCCESS FILL IN OFFSET
13342: MOV =OCER$,WA POINT TO COMPILE ERROR CALL
13343: JSR CDWRD GENERATE AS TEMPORARY VALUE
13344: EJC
13345: *
13346: * CMPIL (CONTINUED)
13347: *
13348: * HERE TO DEAL WITH FAILURE GOTO
13349: *
13350: CMP22 MOV CMFGO(XS),XR LOAD FAILURE GOTO POINTER
13351: MOV XR,WA COPY IT
13352: ZER CMFFC(XS) SET NO FILL IN REQUIRED YET
13353: BZE XR,CMP23 JUMP IF NO FAILURE GOTO GIVEN
13354: ADD *VRTRA,WA POINT TO VRTRA FIELD IN CASE
13355: BLO XR,STATE,CMPSE JUMP TO GEN IF SIMPLE FGOTO
13356: *
13357: * HERE FOR COMPLEX FAILURE GOTO
13358: *
13359: MOV CWCOF,WB SAVE OFFSET TO O$GOF CALL
13360: MOV =OGOF$,WA POINT TO FAILURE GOTO CALL
13361: JSR CDWRD GENERATE
13362: MOV =OFIF$,WA POINT TO FAIL IN FAIL WORD
13363: JSR CDWRD GENERATE
13364: JSR CDGCG GENERATE CODE FOR FAILURE GOTO
13365: MOV WB,WA COPY OFFSET TO O$GOF FOR CDFAL
13366: MOV =B$CDC,WB SET COMPLEX CASE CDTYP
13367: BRN CMP25 JUMP TO BUILD CDBLK
13368: *
13369: * HERE IF NO FAILURE GOTO GIVEN
13370: *
13371: CMP23 MOV =OUNF$,WA LOAD UNEXPECTED FAILURE CALL IN CAS
13372: MOV CSWFL,WC GET -NOFAIL FLAG
13373: ORB CMCGO(XS),WC CHECK IF CONDITIONAL GOTO
13374: ZRB WC,CMPSE JUMP IF -NOFAIL AND NO COND. GOTO
13375: MNZ CMFFC(XS) ELSE SET FILL IN FLAG
13376: MOV =OCER$,WA AND SET COMPILE ERROR FOR TEMPORARY
13377: *
13378: * MERGE HERE WITH CDFAL VALUE IN WA, SIMPLE CDBLK
13379: * ALSO SPECIAL ENTRY AFTER STATEMENT ERROR
13380: *
13381: CMPSE MOV =B$CDS,WB SET CDTYP FOR SIMPLE CASE
13382: EJC
13383: *
13384: * CMPIL (CONTINUED)
13385: *
13386: * MERGE HERE TO BUILD CDBLK
13387: *
13388: * (WA) CDFAL VALUE TO BE GENERATED
13389: * (WB) CDTYP VALUE TO BE GENERATED
13390: *
13391: * AT THIS STAGE, WE CHOP OFF AN APPROPRIATE CHUNK OF THE
13392: * CURRENT CCBLK AND CONVERT IT INTO A CDBLK. THE REMAINDER
13393: * OF THE CCBLK IS REFORMATTED TO BE THE NEW CCBLK.
13394: *
13395: CMP25 MOV R$CCB,XR POINT TO CCBLK
13396: MOV CMLBL(XS),XL GET POSSIBLE LABEL POINTER
13397: BZE XL,CMP26 SKIP IF NO LABEL
13398: ZER CMLBL(XS) CLEAR FLAG FOR NEXT STATEMENT
13399: MOV XR,VRLBL(XL) PUT CDBLK PTR IN VRBLK LABEL FIELD
13400: *
13401: * MERGE AFTER DOING LABEL
13402: *
13403: CMP26 MOV WB,(XR) SET TYPE WORD FOR NEW CDBLK
13404: MOV WA,CDFAL(XR) SET FAILURE WORD
13405: MOV XR,XL COPY POINTER TO CCBLK
13406: MOV CCUSE(XR),WB LOAD LENGTH GEN (= NEW CDLEN)
13407: MOV CCLEN(XR),WC LOAD TOTAL CCBLK LENGTH
13408: ADD WB,XL POINT PAST CDBLK
13409: SUB WB,WC GET LENGTH LEFT FOR CHOP OFF
13410: MOV =B$CCT,(XL) SET TYPE CODE FOR NEW CCBLK AT END
13411: MOV *CCCOD,CCUSE(XL) SET INITIAL CODE OFFSET
13412: MOV *CCCOD,CWCOF REINITIALISE CWCOF
13413: MOV WC,CCLEN(XL) SET NEW LENGTH
13414: MOV XL,R$CCB SET NEW CCBLK POINTER
13415: MOV CMPSN,CDSTM(XR) SET STATEMENT NUMBER
13416: ICV CMPSN BUMP STATEMENT NUMBER
13417: *
13418: * SET POINTERS IN PREVIOUS CODE BLOCK AS REQUIRED
13419: *
13420: MOV CMPCD(XS),XL LOAD PTR TO PREVIOUS CDBLK
13421: BZE CMFFP(XS),CMP27 JUMP IF NO FAILURE FILL IN REQUIRED
13422: MOV XR,CDFAL(XL) ELSE SET FAILURE PTR IN PREVIOUS
13423: *
13424: * HERE TO DEAL WITH SUCCESS FORWARD POINTER
13425: *
13426: CMP27 MOV CMSOP(XS),WA LOAD SUCCESS OFFSET
13427: BZE WA,CMP28 JUMP IF NO FILL IN REQUIRED
13428: ADD WA,XL ELSE POINT TO FILL IN LOCATION
13429: MOV XR,(XL) STORE FORWARD POINTER
13430: ZER XL CLEAR GARBAGE XL VALUE
13431: EJC
13432: *
13433: * CMPIL (CONTINUED)
13434: *
13435: * NOW SET FILL IN POINTERS FOR THIS STATEMENT
13436: *
13437: CMP28 MOV CMFFC(XS),CMFFP(XS) COPY FAILURE FILL IN FLAG
13438: MOV CMSOC(XS),CMSOP(XS) COPY SUCCESS FILL IN OFFSET
13439: MOV XR,CMPCD(XS) SAVE PTR TO THIS CDBLK
13440: BNZ CMTRA(XS),CMP29 JUMP IF INITIAL ENTRY ALREADY SET
13441: MOV XR,CMTRA(XS) ELSE SET PTR HERE AS DEFAULT
13442: *
13443: * HERE AFTER COMPILING ONE STATEMENT
13444: *
13445: CMP29 BLT STAGE,=STGCE,CMP01 JUMP IF NOT END LINE JUST DONE
13446: BZE CSWLS,CMP30 SKIP IF -NOLIST
13447: JSR LISTR LIST LAST LINE
13448: *
13449: * RETURN
13450: *
13451: CMP30 MOV CMTRA(XS),XR LOAD INITIAL ENTRY CDBLK POINTER
13452: ADD *CMNEN,XS POP WORK LOCATIONS OFF STACK
13453: *
13454: * LOOP TO UNNEST ANY OUTSTANDING -COPY LEVELS
13455: *
13456: CMP31 JSR COPND CALL TO UNNEST -COPY
13457: BNZ R$COP,CMP31 LOOP IF NOT ALL -COPYS CLOSED
13458: EXI RETURN TO CMPIL CALLER
13459: *
13460: * HERE AT END OF GOTO FIELD
13461: *
13462: CMP32 MOV CMFGO(XS),WB GET FAIL GOTO
13463: ORB CMSGO(XS),WB OR IN SUCCESS GOTO
13464: BNZ WB,CMP18 OK IF NON-NULL FIELD
13465: ERB 215,SYNTAX ERROR. EMPTY GOTO FIELD
13466: *
13467: * CONTROL CARD FOUND
13468: *
13469: CMP33 ICV WB POINT PAST CH$MN
13470: JSR CNCRD PROCESS CONTROL CARD
13471: ZER SCNSE CLEAR START OF ELEMENT LOC.
13472: BRN CMPCE LOOP FOR NEXT STATEMENT
13473: ENP END PROCEDURE CMPIL
13474: EJC
13475: *
13476: * CNCRD -- CONTROL CARD PROCESSOR
13477: *
13478: * CALLED TO DEAL WITH CONTROL CARDS
13479: *
13480: * R$CIM POINTS TO CURRENT IMAGE
13481: * (WB) OFFSET TO 1ST CHAR OF CONTROL CARD
13482: * JSR CNCRD CALL TO PROCESS CONTROL CARDS
13483: * (XL,XR,WA,WB,WC,IA) DESTROYED
13484: *
13485: CNCRD PRC E,0 ENTRY POINT
13486: MOV WB,SCNPT OFFSET FOR CONTROL CARD SCAN
13487: MOV =CCNOC,WA NUMBER OF CHARS FOR COMPARISON
13488: CTW WA,0 CONVERT TO WORD COUNT
13489: MOV WA,CNSWC SAVE WORD COUNT
13490: *
13491: * LOOP HERE IF MORE THAN ONE CONTROL CARD
13492: *
13493: CNC01 BGE SCNPT,SCNIL,CNC10 RETURN IF END OF IMAGE
13494: MOV R$CIM,XR POINT TO IMAGE
13495: PLC XR,SCNPT CHAR PTR FOR FIRST CHAR
13496: LCH WA,(XR)+ GET FIRST CHAR
13497: BEQ WA,=CH$LI,CNC07 SPECIAL CASE OF -INXXX
13498: .IF .CASL
13499: BEQ WA,=CH$$I,CNC07 DITTO (LC)
13500: .FI
13501: MNZ SCNCC SET FLAG FOR SCANE
13502: JSR SCANE SCAN CARD NAME
13503: ZER SCNCC CLEAR SCANE FLAG
13504: BNZ XL,CNC06 FAIL UNLESS CONTROL CARD NAME
13505: MOV =CCNOC,WA NO. OF CHARS TO BE COMPARED
13506: BLT SCLEN(XR),WA,CNC06 FAIL IF TOO FEW CHARS
13507: MOV XR,XL POINT TO CONTROL CARD NAME
13508: ZER WB ZERO OFFSET FOR SUBSTRING
13509: .IF .CASL
13510: JSR SBSCC CONVERT CASE BEFORE COMPARISON
13511: .ELSE
13512: JSR SBSTR EXTRACT SUBSTRING FOR COMPARISON
13513: .FI
13514: MOV XR,CNSCC KEEP CONTROL CARD SUBSTRING PTR
13515: MOV =CCNMS,XR POINT TO LIST OF STANDARD NAMES
13516: ZER WB INITIALISE NAME OFFSET
13517: LCT WC,=CC$CT NUMBER OF STANDARD NAMES
13518: *
13519: * TRY TO MATCH NAME
13520: *
13521: CNC02 MOV CNSCC,XL POINT TO NAME
13522: LCT WA,CNSWC COUNTER FOR INNER LOOP
13523: BRN CNC04 JUMP INTO LOOP
13524: *
13525: * INNER LOOP TO MATCH CARD NAME CHARS
13526: *
13527: CNC03 ICA XR BUMP STANDARD NAMES PTR
13528: ICA XL BUMP NAME POINTER
13529: *
13530: * HERE TO INITIATE THE LOOP
13531: *
13532: CNC04 CNE SCHAR(XL),(XR),CNC05 COMP. UP TO CFP$C CHARS AT ONCE
13533: BCT WA,CNC03 LOOP IF MORE WORDS TO COMPARE
13534: EJC
13535: *
13536: * CNCRD (CONTINUED)
13537: *
13538: * MATCHED - BRANCH ON CARD OFFSET
13539: *
13540: MOV WB,XL GET NAME OFFSET
13541: BSW XL,CC$CT SWITCH
13542: .IF .CASL
13543: IFF CC$CI,CNC11 -CASEIG
13544: .FI
13545: IFF CC$CO,CNC23 -COPY
13546: IFF CC$EJ,CNC12 -EJECT
13547: IFF CC$FA,CNC13 -FAIL
13548: IFF CC$LI,CNC14 -LIST
13549: .IF .CASL
13550: IFF CC$NC,CNC15 -NOCASEIG
13551: .FI
13552: IFF CC$NF,CNC16 -NOFAIL
13553: IFF CC$NL,CNC17 -NOLIST
13554: IFF CC$ST,CNC18 -STITLE
13555: IFF CC$TI,CNC19 -TITLE
13556: IFF CC$TR,CNC22 -TRACE
13557: ESW END SWITCH
13558: *
13559: * NOT MATCHED YET. ALIGN STD NAMES PTR AND TRY AGAIN
13560: *
13561: CNC05 ICA XR BUMP STANDARD NAMES PTR
13562: BCT WA,CNC05 LOOP
13563: ICV WB BUMP NAMES OFFSET
13564: BCT WC,CNC02 CONTINUE IF MORE NAMES
13565: *
13566: * INVALID CONTROL CARD NAME
13567: *
13568: CNC06 ERB 216,INVALID CONTROL CARD
13569: *
13570: * SPECIAL PROCESSING FOR -INXXX
13571: *
13572: CNC07 LCH WA,(XR) GET NEXT CHAR
13573: .IF .CASL
13574: BEQ WA,=CH$$N,CNC08 SKIP IF LC N
13575: .FI
13576: BNE WA,=CH$LN,CNC06 FAIL IF NOT LETTER N
13577: .IF .CASL
13578: CNC08 ADD =NUM02,SCNPT BUMP OFFSET PAST -IN
13579: .ELSE
13580: ADD =NUM02,SCNPT BUMP OFFSET PAST -IN
13581: .FI
13582: JSR SCANE SCAN INTEGER AFTER -IN
13583: MOV XR,-(XS) STACK SCANNED ITEM
13584: JSR GTSMI CHECK IF INTEGER
13585: PPM CNC06 FAIL IF NOT INTEGER
13586: PPM CNC06 FAIL IF NEGATIVE OR LARGE
13587: MOV XR,CSWIN KEEP INTEGER
13588: EJC
13589: *
13590: * CNCRD (CONTINUED)
13591: *
13592: * CHECK FOR MORE CONTROL CARDS BEFORE RETURNING
13593: *
13594: CNC09 MOV SCNPT,WA PRESERVE IN CASE XEQ TIME COMPILE
13595: JSR SCANE LOOK FOR COMMA
13596: BEQ XL,=T$CMA,CNC01 LOOP IF COMMA FOUND
13597: MOV WA,SCNPT RESTORE SCNPT IN CASE XEQ TIME
13598: *
13599: * RETURN POINT
13600: *
13601: CNC10 EXI RETURN
13602: .IF .CASL
13603: *
13604: * -CASEIG
13605: *
13606: CNC11 MNZ CSWCI SET SWITCH
13607: BRN CNC09 MERGE
13608: .FI
13609: *
13610: * -EJECT
13611: *
13612: CNC12 BZE CSWLS,CNC10 RETURN IF -NOLIST
13613: JSR PRTPS EJECT
13614: JSR LISTT LIST TITLE
13615: BRN CNC10 FINISHED
13616: *
13617: * -FAIL
13618: *
13619: CNC13 MNZ CSWFL SET SWITCH
13620: BRN CNC09 MERGE
13621: *
13622: * -LIST
13623: *
13624: CNC14 MNZ CSWLS SET SWITCH
13625: BRN CNC09 MERGE
13626: .IF .CASL
13627: *
13628: * -NOCASEIG
13629: *
13630: CNC15 ZER CSWCI CLEAR SWITCH
13631: BRN CNC09 MERGE
13632: .FI
13633: *
13634: * -NOFAIL
13635: *
13636: CNC16 ZER CSWFL CLEAR SWITCH
13637: BRN CNC09 MERGE
13638: EJC
13639: *
13640: * CNCRD (CONTINUED)
13641: *
13642: * -NOLIST
13643: *
13644: CNC17 ZER CSWLS CLEAR SWITCH
13645: BRN CNC09 MERGE
13646: *
13647: * -STITL
13648: *
13649: CNC18 MOV =R$STL,CNR$T PTR TO R$STL
13650: BRN CNC20 MERGE
13651: *
13652: * -TITLE
13653: *
13654: CNC19 MOV =NULLS,R$STL CLEAR SUBTITLE
13655: MOV =R$TTL,CNR$T PTR TO R$TTL
13656: *
13657: * COMMON PROCESSING FOR -TITLE, -STITL
13658: *
13659: CNC20 MOV =NULLS,XR NULL IN CASE NEEDED
13660: MNZ CNTTL SET FLAG FOR NEXT LISTR CALL
13661: MOV =CCOFS,WB OFFSET TO TITLE/SUBTITLE
13662: MOV SCNIL,WA INPUT IMAGE LENGTH
13663: BLO WA,WB,CNC21 JUMP IF NO CHARS LEFT
13664: SUB WB,WA NO OF CHARS TO EXTRACT
13665: MOV R$CIM,XL POINT TO IMAGE
13666: JSR SBSTR GET TITLE/SUBTITLE
13667: *
13668: * STORE TITLE/SUBTITLE
13669: *
13670: CNC21 MOV CNR$T,XL POINT TO STORAGE LOCATION
13671: MOV XR,(XL) STORE TITLE/SUBTITLE
13672: BRN CNC10 RETURN
13673: *
13674: * -TRACE
13675: *
13676: * PROVIDED FOR SYSTEM DEBUGGING. TOGGLES THE SYSTEM LABEL
13677: * TRACE SWITCH AT COMPILE TIME
13678: *
13679: CNC22 JSR SYSTT TOGGLE SWITCH
13680: BRN CNC09 MERGE
13681: *
13682: * -COPY
13683: *
13684: * GET FILETAG AND NOTIFY OSINT THAT WE ARE NESTING
13685: *
13686: CNC23 JSR SCANE GET FILETAG
13687: BNE =T$CON,XL,CNC06 ERR IF NOT CONSTANT
13688: BNE =B$SCL,(XR),CNC06 ERR IF NOT SCBLK
13689: JSR SYSSC CALL TO START COPY
13690: ERR 258,COPY FILE DOES NOT EXIST
13691: PPM EROSI ERROR RETURN (ALWAYS)
13692: MOV WA,WB SAVE IOTAG FROM OSINT
13693: MOV *COSI$,WA GET SIZE OF COPY BLOCK
13694: JSR ALLOC ALLOCATE
13695: MOV =B$COP,COTYP(XR) SET TYPE
13696: MOV R$COP,CONXT(XR) PLACE AT FRONT OF STACK CHN
13697: MOV XR,R$COP SPLICE IT IN
13698: MOV WB,COIOT(XR) SAVE OSINT IOTAG
13699: MOV TTINS,COTTI(XR) SAVE TTINS
13700: ZER TTINS INPUT NOT FROM TERMINAL NOW
13701: MOV R$CIM,COCIM(XR) SAVE R$CIM IN CASE EXEC TIME
13702: MOV SCNPT,COSPT(XR) SAVE SCNPT IN CASE EXEC TIME
13703: MOV CSWLS,COSLS(XR) SAVE LIST FLAG
13704: MOV CSWIN,COSIN(XR) SAVE -INXXX VALUE
13705: MOV R$STL,COSTL(XR) SAVE SUBTITLE
13706: BZE CSWLS,CNC10 NO LIST -COPY IF -NOLIST
13707: JSR LISTR LIST -COPY CARD
13708: BRN CNC10 EXIT
13709: ENP END PROCEDURE CNCRD
13710: EJC
13711: *
13712: * COPND -- END -COPY NESTING
13713: *
13714: * COPND IS CALLED FROM CMPIL AND READR IN ORDER TO
13715: * UNNEST ONE LEVEL OF -COPY AND RESTORE THE PREVIOUS
13716: * INPUT COMPILE STRING. THE COPY BLOCK IS REMOVED
13717: * FROM THE CHAIN AND THE STATE RESTORED FROM IT.
13718: *
13719: * JSR COPND CALL TO END -COPY AT CUR. LEVEL
13720: * (XL,WA,WB,WC) DESTROYED
13721: *
13722: COPND PRC E,0 ENTRY POINT
13723: MOV R$COP,XL GET POINTER TO CURRENT COBLK
13724: BZE XL,COP02 EXIT IF NONE
13725: MOV CONXT(XL),R$COP TAKE OFF CHAIN
13726: MOV COIOT(XL),WA GET IOTAG FOR OSINT
13727: JSR SYSEC CALL TO END COPY
13728: PPM DO NOT USE
13729: PPM EROSI ERROR EXIT
13730: BZE CSWLS,COP01 SKIP LISTING IF -NOLIST
13731: JSR LISTR LIST CURRENT IMAGE
13732: *
13733: * MERGE AFTER POSSIBLE LISTING OF CURRENT IMAGE
13734: *
13735: COP01 MOV COTTI(XL),TTINS RESTORE TERMINAL INPUT FLAG
13736: MOV COSLS(XL),CSWLS RESTORE LISTING STATE
13737: MOV COSPT(XL),SCNPT GET OLD SCAN POINTER
13738: MOV COSIN(XL),CSWIN OLD INPUT IMAGE LENGTH
13739: MOV COSTL(XL),R$STL RESTORE SUBTITLE STRING
13740: MNZ LSTPF THIS IMAGE LISTED IN CNCRD
13741: MOV COCIM(XL),XL GET OLD COMPILER IMAGE SCBLK
13742: MOV XL,R$CIM RESTORE IT
13743: MOV SCLEN(XL),SCNIL SET INPUT IMAGE LENGTH TOO
13744: *
13745: * MERGE TO EXIT
13746: *
13747: COP02 EXI RETURN TO CALLER
13748: ENP END PROCEDURE COPND
13749: EJC
13750: *
13751: * DFFNC -- DEFINE FUNCTION
13752: *
13753: * DFFNC IS CALLED WHENEVER A NEW FUNCTION IS ASSIGNED TO
13754: * A VARIABLE. IT DEALS WITH EXTERNAL FUNCTION USE COUNTS.
13755: *
13756: * (XR) POINTER TO VRBLK
13757: * (XL) POINTER TO NEW FUNCTION BLOCK
13758: * JSR DFFNC CALL TO DEFINE FUNCTION
13759: * (WA,WB) DESTROYED
13760: *
13761: DFFNC PRC E,0 ENTRY POINT
13762: .IF .CNLD
13763: .ELSE
13764: BNE (XL),=B$EFC,DFFN1 SKIP IF NEW FUNCTION NOT EXTERNAL
13765: ICV EFUSE(XL) ELSE INCREMENT ITS USE COUNT
13766: *
13767: * HERE AFTER DEALING WITH NEW FUNCTION USE COUNT
13768: *
13769: DFFN1 MOV XR,WA SAVE VRBLK POINTER
13770: MOV VRFNC(XR),XR LOAD OLD FUNCTION POINTER
13771: BNE (XR),=B$EFC,DFFN2 JUMP IF OLD FUNCTION NOT EXTERNAL
13772: MOV EFUSE(XR),WB ELSE GET USE COUNT
13773: DCV WB DECREMENT
13774: MOV WB,EFUSE(XR) STORE DECREMENTED VALUE
13775: BNZ WB,DFFN2 JUMP IF USE COUNT STILL NON-ZERO
13776: JSR SYSUL ELSE CALL SYSTEM UNLOAD FUNCTION
13777: *
13778: * HERE AFTER DEALING WITH OLD FUNCTION USE COUNT
13779: *
13780: DFFN2 MOV WA,XR RESTORE VRBLK POINTER
13781: .FI
13782: MOV XL,WA COPY FUNCTION BLOCK PTR
13783: BLT XR,=R$YYY,DFFN3 SKIP CHECKS IF OPSYN OP DEFINITION
13784: BNZ VRLEN(XR),DFFN3 JUMP IF NOT SYSTEM VARIABLE
13785: *
13786: * FOR SYSTEM VARIABLE, CHECK FOR ILLEGAL REDEFINITION
13787: *
13788: MOV VRSVP(XR),XL POINT TO SVBLK
13789: MOV SVBIT(XL),WB LOAD BIT INDICATORS
13790: ANB BTFNC,WB IS IT A SYSTEM FUNCTION
13791: ZRB WB,DFFN3 REDEF OK IF NOT
13792: ERB 217,ATTEMPTED REDEFINITION OF SYSTEM FUNCTION
13793: *
13794: * HERE IF REDEFINITION IS PERMITTED
13795: *
13796: DFFN3 MOV WA,VRFNC(XR) STORE NEW FUNCTION POINTER
13797: MOV WA,XL RESTORE FUNCTION BLOCK POINTER
13798: EXI RETURN TO DFFNC CALLER
13799: ENP END PROCEDURE DFFNC
13800: EJC
13801: *
13802: * DTYPE -- GET DATATYPE NAME
13803: *
13804: * (XR) OBJECT WHOSE DATATYPE IS REQUIRED
13805: * JSR DTYPE CALL TO GET DATATYPE
13806: * (XR) RESULT DATATYPE
13807: *
13808: DTYPE PRC E,0 ENTRY POINT
13809: BEQ (XR),=B$PDT,DTYP1 JUMP IF PROG.DEFINED
13810: MOV (XR),XR LOAD TYPE WORD
13811: LEI XR GET ENTRY POINT ID (BLOCK CODE)
13812: WTB XR CONVERT TO BAU OFFSET
13813: MOV SCNMT(XR),XR LOAD TABLE ENTRY
13814: EXI EXIT TO DTYPE CALLER
13815: *
13816: * HERE IF PROGRAM DEFINED
13817: *
13818: DTYP1 MOV PDDFP(XR),XR POINT TO DFBLK
13819: MOV DFNAM(XR),XR GET DATATYPE NAME FROM DFBLK
13820: EXI RETURN TO DTYPE CALLER
13821: ENP END PROCEDURE DTYPE
13822: EJC
13823: *
13824: * DUMPR -- PRINT DUMP OF STORAGE
13825: *
13826: * (XR) DUMP ARGUMENT (SEE BELOW)
13827: * JSR DUMPR CALL TO PRINT DUMP
13828: * (XR,XL) DESTROYED
13829: * (WA,WB,WC,RA) DESTROYED
13830: *
13831: * THE DUMP ARGUMENT HAS THE FOLLOWING SIGNIFICANCE
13832: *
13833: * DMARG = 0 NO DUMP PRINTED
13834: * DMARG = 1 PARTIAL DUMP (NAT VARS, KEYWORDS)
13835: * DMARG GE 2 FULL DUMP (INCL ARRAYS ETC.)
13836: *
13837: * SINCE DUMPR SCRAMBLES STORE, IT IS NOT PERMISSIBLE TO
13838: * COLLECT IN MID-DUMP. HENCE A COLLECT IS DONE INITIALLY
13839: * AND THEN IF STORE RUNS OUT AN ERROR MESSAGE IS PRODUCED.
13840: *
13841: DUMPR PRC E,0 ENTRY POINT
13842: BZE XR,DMP28 SKIP DUMP IF ARGUMENT IS ZERO
13843: ZER XL CLEAR XL
13844: ZER WB ZERO MOVE OFFSET
13845: MOV XR,DMARG SAVE DUMP ARGUMENT
13846: JSR GBCOL COLLECT GARBAGE
13847: JSR PRTPG EJECT PRINTER
13848: MOV =DMHDV,XR POINT TO HEADING FOR VARIABLES
13849: JSR PRTFB PRINT IT
13850: *
13851: * FIRST ALL NATURAL VARIABLE BLOCKS (VRBLK) WHOSE VALUES
13852: * ARE NON-NULL ARE LINKED IN LEXICAL ORDER USING DMVCH AS
13853: * THE CHAIN HEAD AND CHAINING THROUGH THE VRGET FIELDS.
13854: * NOTE THAT THIS SCRAMBLES STORE IF THE PROCESS IS
13855: * INTERRUPTED BEFORE COMPLETION E.G. BY EXCEEDING TIME OR
13856: * PRINT LIMITS. SINCE THE SUBSEQUENT CORE DUMPS AND
13857: * FAILURES IF EXECUTION IS RESUMED ARE VERY CONFUSING, THE
13858: * EXECUTION TIME ERROR ROUTINE CHECKS FOR THIS EVENT AND
13859: * ATTEMPTS AN UNSCRAMBLE. SIMILAR PRECAUTIONS SHOULD BE
13860: * OBSERVED IF TRANSLATE TIME DUMPING IS IMPLEMENTED.
13861: *
13862: ZER DMVCH SET NULL CHAIN TO START
13863: MOV HSHTB,WA POINT TO HASH TABLE
13864: *
13865: * LOOP THROUGH HEADERS IN HASH TABLE
13866: *
13867: DMP00 MOV WA,XR COPY HASH BUCKET POINTER
13868: ICA WA BUMP POINTER
13869: SUB *VRNXT,XR SET OFFSET TO MERGE
13870: *
13871: * LOOP THROUGH VRBLKS ON ONE CHAIN
13872: *
13873: DMP01 MOV VRNXT(XR),XR POINT TO NEXT VRBLK ON CHAIN
13874: BZE XR,DMP09 JUMP IF END OF THIS HASH CHAIN
13875: MOV XR,XL ELSE COPY VRBLK POINTER
13876: EJC
13877: *
13878: * DUMPR (CONTINUED)
13879: *
13880: * LOOP TO FIND VALUE AND SKIP IF NULL
13881: *
13882: DMP02 MOV VRVAL(XL),XL LOAD VALUE
13883: BEQ XL,=NULLS,DMP01 LOOP FOR NEXT VRBLK IF NULL VALUE
13884: BEQ (XL),=B$TRT,DMP02 LOOP BACK IF VALUE IS TRAPPED
13885: *
13886: * NON-NULL VALUE, PREPARE TO SEARCH CHAIN
13887: *
13888: MOV XR,WC SAVE VRBLK POINTER
13889: ADD *VRSOF,XR ADJUST PTR TO BE LIKE SCBLK PTR
13890: BNZ SCLEN(XR),DMP03 JUMP IF NON-SYSTEM VARIABLE
13891: MOV VRSVO(XR),XR ELSE LOAD PTR TO NAME IN SVBLK
13892: *
13893: * HERE WITH NAME POINTER FOR NEW BLOCK IN XR
13894: *
13895: DMP03 MOV XR,WB SAVE POINTER TO CHARS
13896: MOV WA,DMPSV SAVE HASH BUCKET POINTER
13897: MOV =DMVCH,WA POINT TO CHAIN HEAD
13898: *
13899: * LOOP TO SEARCH CHAIN FOR CORRECT INSERTION POINT
13900: *
13901: DMP04 MOV WA,DMPCH SAVE CHAIN POINTER
13902: MOV WA,XL COPY IT
13903: MOV (XL),XR LOAD POINTER TO NEXT ENTRY
13904: BZE XR,DMP08 JUMP IF END OF CHAIN TO INSERT
13905: ADD *VRSOF,XR ELSE GET NAME PTR FOR CHAINED VRBLK
13906: BNZ SCLEN(XR),DMP05 JUMP IF NOT SYSTEM VARIABLE
13907: MOV VRSVO(XR),XR ELSE POINT TO NAME IN SVBLK
13908: *
13909: * HERE PREPARE TO COMPARE THE NAMES
13910: *
13911: * (WA) SCRATCH
13912: * (WB) POINTER TO STRING OF ENTERING VRBLK
13913: * (WC) POINTER TO ENTERING VRBLK
13914: * (XR) POINTER TO STRING OF CURRENT BLOCK
13915: * (XL) SCRATCH
13916: *
13917: DMP05 MOV WB,XL POINT TO ENTERING VRBLK STRING
13918: MOV SCLEN(XL),WA LOAD ITS LENGTH
13919: PLC XL POINT TO CHARS OF ENTERING STRING
13920: BHI WA,SCLEN(XR),DMP06 JUMP IF ENTERING LENGTH HIGH
13921: PLC XR ELSE POINT TO CHARS OF OLD STRING
13922: CMC DMP08,DMP07 COMPARE, INSERT IF NEW IS LLT OLD
13923: BRN DMP08 OR IF LEQ (WE HAD SHORTER LENGTH)
13924: *
13925: * HERE WHEN NEW LENGTH IS LONGER THAN OLD LENGTH
13926: *
13927: DMP06 MOV SCLEN(XR),WA LOAD SHORTER LENGTH
13928: PLC XR POINT TO CHARS OF OLD STRING
13929: CMC DMP08,DMP07 COMPARE, INSERT IF NEW ONE LOW
13930: EJC
13931: *
13932: * DUMPR (CONTINUED)
13933: *
13934: * HERE WE MOVE OUT ON THE CHAIN
13935: *
13936: DMP07 MOV DMPCH,XL COPY CHAIN POINTER
13937: MOV (XL),WA MOVE TO NEXT ENTRY ON CHAIN
13938: BRN DMP04 LOOP BACK
13939: *
13940: * HERE AFTER LOCATING THE PROPER INSERTION POINT
13941: *
13942: DMP08 MOV DMPCH,XL COPY CHAIN POINTER
13943: MOV DMPSV,WA RESTORE HASH BUCKET POINTER
13944: MOV WC,XR RESTORE VRBLK POINTER
13945: MOV (XL),VRGET(XR) LINK VRBLK TO REST OF CHAIN
13946: MOV XR,(XL) LINK VRBLK INTO CURRENT CHAIN LOC
13947: BRN DMP01 LOOP BACK FOR NEXT VRBLK
13948: *
13949: * HERE AFTER PROCESSING ALL VRBLKS ON ONE CHAIN
13950: *
13951: DMP09 BNE WA,HSHTE,DMP00 LOOP BACK IF MORE BUCKETS TO GO
13952: *
13953: * LOOP TO GENERATE DUMP OF NATURAL VARIABLE VALUES
13954: *
13955: DMP10 MOV DMVCH,XR LOAD POINTER TO NEXT ENTRY ON CHAIN
13956: BZE XR,DMP11 JUMP IF END OF CHAIN
13957: MOV (XR),DMVCH ELSE UPDATE CHAIN PTR TO NEXT ENTRY
13958: JSR SETVR RESTORE VRGET FIELD
13959: MOV XR,XL COPY VRBLK POINTER (NAME BASE)
13960: MOV *VRVAL,WA SET OFFSET FOR VRBLK NAME
13961: JSR PRTNV PRINT NAME = VALUE
13962: BRN DMP10 LOOP BACK TILL ALL PRINTED
13963: *
13964: * PREPARE TO PRINT KEYWORDS
13965: *
13966: DMP11 JSR PRTFH PRINT BLANK LINE
13967: JSR PRTFH AND ANOTHER
13968: MOV =DMHDK,XR POINT TO KEYWORD HEADING
13969: JSR PRTFB PRINT HEADING
13970: MOV =VDMKW,XL POINT TO LIST OF KEYWORD SVBLK PTRS
13971: EJC
13972: *
13973: * DUMPR (CONTINUED)
13974: *
13975: * LOOP TO DUMP KEYWORD VALUES
13976: *
13977: DMP12 MOV (XL)+,XR LOAD NEXT SVBLK PTR FROM TABLE
13978: BZE XR,DMP13 JUMP IF END OF LIST
13979: MOV =CH$AM,WA LOAD AMPERSAND
13980: JSR PRTCH PRINT AMPERSAND
13981: JSR PRTST PRINT KEYWORD NAME
13982: MOV SVLEN(XR),WA LOAD NAME LENGTH FROM SVBLK
13983: CTB WA,SVCHS GET LENGTH OF NAME
13984: ADD WA,XR POINT TO SVKNM FIELD
13985: MOV (XR),DMPKN STORE IN DUMMY KVBLK
13986: MOV =TMBEB,XR POINT TO BLANK-EQUAL-BLANK
13987: JSR PRTST PRINT IT
13988: MOV XL,DMPSV SAVE TABLE POINTER
13989: MOV =DMPKB,XL POINT TO DUMMY KVBLK
13990: MOV *KVVAR,WA SET ZERO OFFSET
13991: JSR ACESS GET KEYWORD VALUE
13992: PPM FAILURE IS IMPOSSIBLE
13993: JSR PRTVF PRINT KEYWORD VALUE
13994: MOV DMPSV,XL RESTORE TABLE POINTER
13995: BRN DMP12 LOOP BACK TILL ALL PRINTED
13996: *
13997: * HERE AFTER COMPLETING PARTIAL DUMP
13998: *
13999: DMP13 BEQ DMARG,=NUM01,DMP27 EXIT IF PARTIAL DUMP COMPLETE
14000: MOV DNAMB,XR ELSE POINT TO FIRST DYNAMIC BLOCK
14001: *
14002: * LOOP THROUGH BLOCKS IN DYNAMIC STORAGE
14003: *
14004: DMP14 BEQ XR,DNAMP,DMP27 JUMP IF END OF USED REGION
14005: MOV (XR),WA ELSE LOAD FIRST WORD OF BLOCK
14006: BEQ WA,=B$VCT,DMP16 JUMP IF VECTOR
14007: BEQ WA,=B$ART,DMP17 JUMP IF ARRAY
14008: BEQ WA,=B$PDT,DMP18 JUMP IF PROGRAM DEFINED
14009: BEQ WA,=B$TBT,DMP19 JUMP IF TABLE
14010: .IF .CNBF
14011: .ELSE
14012: BEQ WA,=B$BCT,DMP29 JUMP IF BUFFER
14013: .FI
14014: *
14015: * MERGE HERE TO MOVE TO NEXT BLOCK
14016: *
14017: DMP15 JSR BLKLN GET LENGTH OF BLOCK
14018: ADD WA,XR POINT PAST THIS BLOCK
14019: BRN DMP14 LOOP BACK FOR NEXT BLOCK
14020: EJC
14021: *
14022: * DUMPR (CONTINUED)
14023: *
14024: * HERE FOR VECTOR
14025: *
14026: DMP16 MOV *VCVLS,WB SET OFFSET TO FIRST VALUE
14027: BRN DMP19 JUMP TO MERGE
14028: *
14029: * HERE FOR ARRAY
14030: *
14031: DMP17 MOV AROFS(XR),WB SET OFFSET TO ARPRO FIELD
14032: ICA WB BUMP TO GET OFFSET TO VALUES
14033: BRN DMP19 JUMP TO MERGE
14034: *
14035: * HERE FOR PROGRAM DEFINED
14036: *
14037: DMP18 MOV *PDFLD,WB POINT TO VALUES, MERGE
14038: *
14039: * HERE FOR TABLE (OTHERS MERGE)
14040: *
14041: DMP19 BZE IDVAL(XR),DMP15 IGNORE BLOCK IF ZERO ID VALUE
14042: JSR BLKLN ELSE GET BLOCK LENGTH
14043: MOV XR,XL COPY BLOCK POINTER
14044: MOV WA,DMPSV SAVE LENGTH
14045: MOV WB,WA COPY OFFSET TO FIRST VALUE
14046: JSR PRTFH PRINT BLANK LINE
14047: MOV WA,DMPSA PRESERVE OFFSET
14048: JSR PRTVF PRINT BLOCK VALUE (FOR TITLE)
14049: MOV DMPSA,WA RECOVER OFFSET
14050: BEQ (XR),=B$TBT,DMP22 JUMP IF TABLE
14051: DCA WA POINT BEFORE FIRST WORD
14052: *
14053: * LOOP TO PRINT CONTENTS OF ARRAY, VECTOR, OR PROGRAM DEF
14054: *
14055: DMP20 MOV XL,XR COPY BLOCK POINTER
14056: ICA WA BUMP OFFSET
14057: ADD WA,XR POINT TO NEXT VALUE
14058: BEQ WA,DMPSV,DMP14 EXIT IF END (XR PAST BLOCK)
14059: SUB *VRVAL,XR SUBTRACT OFFSET TO MERGE INTO LOOP
14060: *
14061: * LOOP TO FIND VALUE AND IGNORE NULLS
14062: *
14063: DMP21 MOV VRVAL(XR),XR LOAD NEXT VALUE
14064: BEQ XR,=NULLS,DMP20 LOOP BACK IF NULL VALUE
14065: BEQ (XR),=B$TRT,DMP21 LOOP BACK IF TRAPPED
14066: JSR PRTNV ELSE PRINT NAME = VALUE
14067: BRN DMP20 LOOP BACK FOR NEXT FIELD
14068: EJC
14069: *
14070: * DUMPR (CONTINUED)
14071: *
14072: * HERE TO DUMP A TABLE
14073: *
14074: DMP22 MOV *TBBUK,WC SET OFFSET TO FIRST BUCKET
14075: MOV *TEVAL,WA SET NAME OFFSET FOR ALL TEBLKS
14076: *
14077: * LOOP THROUGH TABLE BUCKETS
14078: *
14079: DMP23 MOV XL,-(XS) SAVE TBBLK POINTER
14080: ADD WC,XL POINT TO NEXT BUCKET HEADER
14081: ICA WC BUMP BUCKET OFFSET
14082: SUB *TENXT,XL SUBTRACT OFFSET TO MERGE INTO LOOP
14083: *
14084: * LOOP TO PROCESS TEBLKS ON ONE CHAIN
14085: *
14086: DMP24 MOV TENXT(XL),XL POINT TO NEXT TEBLK
14087: BEQ XL,(XS),DMP26 JUMP IF END OF CHAIN
14088: MOV XL,XR ELSE COPY TEBLK POINTER
14089: *
14090: * LOOP TO FIND VALUE AND IGNORE IF NULL
14091: *
14092: DMP25 MOV TEVAL(XR),XR LOAD NEXT VALUE
14093: BEQ XR,=NULLS,DMP24 IGNORE IF NULL VALUE
14094: BEQ (XR),=B$TRT,DMP25 LOOP BACK IF TRAPPED
14095: MOV WC,DMPSV ELSE SAVE OFFSET POINTER
14096: JSR PRTNV PRINT NAME = VALUE
14097: MOV DMPSV,WC RELOAD OFFSET
14098: BRN DMP24 LOOP BACK FOR NEXT TEBLK
14099: *
14100: * HERE TO MOVE TO NEXT HASH CHAIN
14101: *
14102: DMP26 MOV (XS)+,XL RESTORE TBBLK POINTER
14103: BNE WC,TBLEN(XL),DMP23 LOOP BACK IF MORE BUCKETS TO GO
14104: MOV XL,XR ELSE COPY TABLE POINTER
14105: ADD WC,XR POINT TO FOLLOWING BLOCK
14106: BRN DMP14 LOOP BACK TO PROCESS NEXT BLOCK
14107: *
14108: * HERE AFTER COMPLETING DUMP
14109: *
14110: DMP27 JSR PRTPG EJECT PRINTER
14111: *
14112: * MERGE HERE IF NO DUMP GIVEN (DMARG=0)
14113: *
14114: DMP28 EXI RETURN TO DUMP CALLER
14115: .IF .CNBF
14116: .ELSE
14117: EJC
14118: *
14119: * DUMPR (CONTINUED)
14120: *
14121: * HERE TO DUMP BUFFER BLOCK
14122: *
14123: DMP29 JSR PRTFH PRINT BLANK LINE
14124: JSR PRTVF PRINT VALUE ID FOR TITLE
14125: MOV =CH$DQ,WA LOAD DOUBLE QUOTE
14126: JSR PRTCH PRINT IT
14127: MOV BCLEN(XR),WC LOAD DEFINED LENGTH
14128: BZE WC,DMP32 SKIP CHARACTERS IF NONE
14129: LCT WC,WC LOAD COUNT FOR LOOP
14130: MOV XR,WB SAVE BCBLK PTR
14131: MOV BCBUF(XR),XR POINT TO BFBLK
14132: PLC XR GET SET TO LOAD CHARACTERS
14133: *
14134: * LOOP HERE STUFFING CHARACTERS IN OUTPUT STREAM
14135: *
14136: DMP31 LCH WA,(XR)+ GET NEXT CHARACTER
14137: JSR PRTCH STUFF IT
14138: BCT WC,DMP31 BRANCH FOR NEXT ONE
14139: MOV WB,XR RESTORE BCBLK POINTER
14140: *
14141: * MERGE TO STUFF CLOSING QUOTE MARK
14142: *
14143: DMP32 MOV =CH$DQ,WA STUFF QUOTE
14144: JSR PRTCF PRINT IT
14145: MOV (XR),WA GET FIRST WD FOR BLKLN
14146: BRN DMP15 MERGE TO GET NEXT BLOCK
14147: .FI
14148: ENP END PROCEDURE DUMPR
14149: EJC
14150: *
14151: * ERMSG -- PRINT ERROR CODE AND ERROR MESSAGE
14152: *
14153: * KVERT ERROR CODE
14154: * JSR ERMSG CALL TO PRINT MESSAGE
14155: * (XR,XL,WA,WB,WC,IA) DESTROYED
14156: *
14157: ERMSG PRC E,0 ENTRY POINT
14158: JSR PRTFH PRINT ERROR PTR OR BLANK LINE
14159: MOV KVERT,WA LOAD ERROR CODE
14160: MOV =ERMMS,XR POINT TO ERROR MESSAGE /ERROR/
14161: JSR PRTST PRINT IT
14162: JSR ERTEX GET ERROR MESSAGE TEXT
14163: ADD =THSND,WA BUMP ERROR CODE FOR PRINT
14164: MTI WA FAIL CODE IN INT ACC
14165: JSR PRTIN PRINT CODE (NOW HAVE ERROR1XXX)
14166: MOV PRBUF,XL POINT TO PRINT BUFFER
14167: PSC XL,=NUM05 POINT TO THE 1
14168: MOV =CH$BL,WA LOAD A BLANK
14169: SCH WA,(XL) STORE BLANK OVER 1 (ERROR XXX)
14170: CSC XL COMPLETE STORE CHARACTERS
14171: ZER XL CLEAR GARBAGE POINTER IN XL
14172: MOV XR,WA KEEP ERROR TEXT
14173: MOV =ERMNS,XR POINT TO / -- /
14174: JSR PRTST PRINT IT
14175: MOV WA,XR GET ERROR TEXT AGAIN
14176: JSR PRTFB PRINT ERROR MESSAGE TEXT
14177: EXI RETURN TO ERMSG CALLER
14178: ENP END PROCEDURE ERMSG
14179: EJC
14180: *
14181: * ERTEX -- GET ERROR MESSAGE TEXT
14182: *
14183: * (WA) ERROR CODE
14184: * JSR ERTEX CALL TO GET ERROR TEXT
14185: * (XR) PTR TO ERROR TEXT IN DYNAMIC
14186: * (R$ETX) COPY OF PTR TO ERROR TEXT
14187: * (XL,WC,IA) DESTROYED
14188: *
14189: ERTEX PRC E,0 ENTRY POINT
14190: MOV WA,ERTWA SAVE WA
14191: MOV WB,ERTWB SAVE WB
14192: BNZ EROSN,ERT03 SKIP IF SPECIAL EROSI RETURN
14193: JSR SYSEM GET FAILURE MESSAGE TEXT
14194: MOV XR,XL COPY POINTER TO IT
14195: MOV SCLEN(XR),WA GET LENGTH OF STRING
14196: BZE WA,ERT02 JUMP IF NULL
14197: ZER WB OFFSET OF ZERO
14198: JSR SBSTR COPY INTO DYNAMIC STORE
14199: MOV XR,R$ETX STORE FOR RELOCATION
14200: *
14201: * RETURN
14202: *
14203: ERT01 MOV ERTWB,WB RESTORE WB
14204: MOV ERTWA,WA RESTORE WA
14205: EXI RETURN TO CALLER
14206: *
14207: * RETURN ERRTEXT CONTENTS INSTEAD OF NULL
14208: *
14209: ERT02 MOV R$ETX,XR GET ERRTEXT
14210: BRN ERT01 RETURN
14211: *
14212: * SPECIAL CASE SET UP BY EROSI RETURN TO AVOID SYSEM CALL
14213: *
14214: ERT03 ZER EROSN CLEAR FLAG
14215: MOV R$ETX,XR GET ERROR MESSAGE TEXT
14216: BRN ERT01 RETURN WITHOUT MAKING SYSEM CALL
14217: ENP
14218: EJC
14219: *
14220: * EVALI -- EVALUATE INTEGER ARGUMENT
14221: *
14222: * EVALI IS USED BY PATTERN PRIMITIVES LEN,TAB,RTAB,POS,RPOS
14223: * WHEN THEIR ARGUMENT IS AN EXPRESSION VALUE.
14224: *
14225: * (XR) NODE POINTER
14226: * (WB) CURSOR
14227: * JSR EVALI CALL TO EVALUATE INTEGER
14228: * PPM LOC TRANSFER LOC FOR NON-INTEGER ARG
14229: * PPM LOC TRANSFER LOC FOR OUT OF RANGE ARG
14230: * PPM LOC TRANSFER LOC FOR EVALUATION FAILURE
14231: * (XR) PTR TO NODE WITH INTEGER ARGUMENT
14232: * (WC,XL,RA) DESTROYED
14233: *
14234: * ON RETURN, THE NODE POINTED TO HAS THE INTEGER ARGUMENT
14235: * IN PARM1 AND THE PROPER SUCCESSOR POINTER IN PTHEN.
14236: * THIS ALLOWS MERGING WITH THE NORMAL (INTEGER ARG) CASE.
14237: *
14238: EVALI PRC R,3 ENTRY POINT (RECURSIVE)
14239: JSR EVALP EVALUATE EXPRESSION
14240: PPM EVLI1 JUMP ON FAILURE
14241: MOV XL,-(XS) STACK RESULT FOR GTSMI
14242: MOV PTHEN(XR),XL LOAD SUCCESSOR POINTER
14243: JSR GTSMI CONVERT ARG TO SMALL INTEGER
14244: PPM EVLI2 JUMP IF NOT INTEGER
14245: PPM EVLI3 JUMP IF OUT OF RANGE
14246: MOV XR,EVLIV STORE RESULT IN SPECIAL DUMMY NODE
14247: MOV XL,EVLIS STORE SUCCESSOR POINTER
14248: MOV =EVLIN,XR POINT TO DUMMY NODE WITH RESULT
14249: EXI SUCCESSFUL RETURN
14250: *
14251: * HERE IF EVALUATION FAILS
14252: *
14253: EVLI1 EXI 3 TAKE FAILURE RETURN
14254: *
14255: * HERE IF ARGUMENT IS NOT INTEGER
14256: *
14257: EVLI2 EXI 1 TAKE NON-INTEGER ERROR EXIT
14258: *
14259: * HERE IF ARGUMENT IS OUT OF RANGE
14260: *
14261: EVLI3 EXI 2 TAKE OUT-OF-RANGE ERROR EXIT
14262: ENP END PROCEDURE EVALI
14263: EJC
14264: *
14265: * EVALP -- EVALUATE EXPRESSION DURING PATTERN MATCH
14266: *
14267: * EVALP IS USED TO EVALUATE AN EXPRESSION (BY VALUE) DURING
14268: * A PATTERN MATCH. THE EFFECT IS LIKE EVALX, BUT PATTERN
14269: * VARIABLES ARE STACKED AND RESTORED IF NECESSARY.
14270: *
14271: * EVALP ALSO DIFFERS FROM EVALX IN THAT IF THE RESULT IS
14272: * AN EXPRESSION IT IS REEVALUATED. THIS OCCURS REPEATEDLY.
14273: *
14274: * (XR) NODE POINTER
14275: * (WB) PATTERN MATCH CURSOR
14276: * JSR EVALP CALL TO EVALUATE EXPRESSION
14277: * PPM LOC TRANSFER LOC IF EVALUATION FAILS
14278: * (XL) RESULT
14279: * (WA) FIRST WORD OF RESULT BLOCK
14280: * (XR,WB) DESTROYED (FAILURE CASE ONLY)
14281: * (WC,RA) DESTROYED
14282: *
14283: * THE EXPRESSION POINTER IS STORED IN PARM1 OF THE NODE
14284: *
14285: * CONTROL RETURNS TO FAILP ON FAILURE OF EVALUATION
14286: *
14287: EVALP PRC R,1 ENTRY POINT (RECURSIVE)
14288: MOV PARM1(XR),XL LOAD EXPRESSION POINTER
14289: BEQ (XL),=B$EXL,EVLP1 JUMP IF EXBLK CASE
14290: *
14291: * HERE FOR CASE OF SEBLK
14292: *
14293: * WE CAN GIVE A FAST RETURN IF THE VALUE OF THE VRBLK IS
14294: * NOT AN EXPRESSION AND IS NOT TRAPPED.
14295: *
14296: MOV SEVAR(XL),XL LOAD VRBLK POINTER
14297: MOV VRVAL(XL),XL LOAD VALUE OF VRBLK
14298: MOV (XL),WA LOAD FIRST WORD OF VALUE
14299: BHI WA,=B$T$$,EVLP3 JUMP IF NOT SEBLK, TRBLK OR EXBLK
14300: *
14301: * HERE FOR EXBLK OR SEBLK WITH EXPR VALUE OR TRAPPED VALUE
14302: *
14303: EVLP1 MOV XR,-(XS) STACK NODE POINTER
14304: MOV WB,-(XS) STACK CURSOR
14305: MOV R$PMS,-(XS) STACK SUBJECT STRING POINTER
14306: MOV PMSSL,-(XS) STACK SUBJECT STRING LENGTH
14307: MOV PMDFL,-(XS) STACK DOT FLAG
14308: MOV PMHBS,-(XS) STACK HISTORY STACK BASE POINTER
14309: MOV PARM1(XR),XR LOAD EXPRESSION POINTER
14310: EJC
14311: *
14312: * EVALP (CONTINUED)
14313: *
14314: * LOOP BACK HERE TO REEVALUATE EXPRESSION RESULT
14315: *
14316: EVLP2 ZER WB SET FLAG FOR BY VALUE
14317: JSR EVALX EVALUATE EXPRESSION
14318: PPM EVLP4 JUMP ON FAILURE
14319: MOV (XR),WA ELSE LOAD FIRST WORD OF VALUE
14320: BLO WA,=B$E$$,EVLP2 LOOP BACK TO REEVALUATE EXPRESSION
14321: *
14322: * HERE TO RESTORE PATTERN VALUES AFTER SUCCESSFUL EVAL
14323: *
14324: MOV XR,XL COPY RESULT POINTER
14325: MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER
14326: MOV (XS)+,PMDFL RESTORE DOT FLAG
14327: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH
14328: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER
14329: MOV (XS)+,WB RESTORE CURSOR
14330: MOV (XS)+,XR RESTORE NODE POINTER
14331: *
14332: * COMMON EXIT POINT
14333: *
14334: EVLP3 EXI RETURN TO EVALP CALLER
14335: *
14336: * HERE FOR FAILURE DURING EVALUATION
14337: *
14338: EVLP4 MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER
14339: MOV (XS)+,PMDFL RESTORE DOT FLAG
14340: MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH
14341: MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER
14342: ADD *NUM02,XS REMOVE NODE PTR, CURSOR
14343: EXI 1 TAKE FAILURE EXIT
14344: ENP END PROCEDURE EVALP
14345: EJC
14346: *
14347: * EVALS -- EVALUATE STRING ARGUMENT
14348: *
14349: * EVALS IS USED BY SPAN, ANY, NOTANY, BREAK, BREAKX WHEN
14350: * THEY ARE PASSED AN EXPRESSION ARGUMENT.
14351: *
14352: * (XR) NODE POINTER
14353: * (WA) APPROPRIATE MULTI CHARACTER PCODE
14354: * (WB) CURSOR
14355: * JSR EVALS CALL TO EVALUATE STRING
14356: * PPM LOC TRANSFER LOC FOR NON-STRING ARG
14357: * PPM LOC TRANSFER LOC FOR EVALUATION FAILURE
14358: * (XL) PCODE OF NEW NODE (ENTRY WA)
14359: * (XR) PTR TO NODE WITH PARMS SET
14360: * (WA,WC,RA) DESTROYED
14361: *
14362: * ON RETURN, THE NODE POINTED TO HAS A CHARACTER TABLE
14363: * POINTER IN PARM1 AND A BIT MASK IN PARM2. THE PROPER
14364: * SUCCESSOR IS STORED IN PTHEN OF THIS NODE. THUS IT IS
14365: * OK FOR MERGING WITH THE NORMAL (MULTI-CHAR STRING) CASE.
14366: * THIS IS DONE BY THE USUAL INDIRECT BRANCH THROUGH THE
14367: * PCODE PASSED IN WA.
14368: *
14369: EVALS PRC R,2 ENTRY POINT (RECURSIVE)
14370: MOV WA,-(XS) KEEP PCODE
14371: JSR EVALP EVALUATE EXPRESSION
14372: PPM EVLS1 JUMP IF EVALUATION FAILS
14373: MOV (XS)+,WA RECOVER PCODE
14374: MOV PTHEN(XR),-(XS) SAVE SUCCESSOR POINTER
14375: MOV WB,-(XS) SAVE CURSOR
14376: MOV XL,-(XS) STACK RESULT PTR FOR PATST
14377: ZER WB DUMMY PCODE FOR ONE CHAR STRING
14378: ZER WC DUMMY PCODE FOR EXPRESSION ARG
14379: MOV WA,XL APPROPRIATE PCODE FOR OUR USE
14380: JSR PATST CALL ROUTINE TO BUILD NODE
14381: PPM EVLS2 JUMP IF NOT STRING
14382: MOV (XS)+,WB RESTORE CURSOR
14383: MOV (XS)+,PTHEN(XR) STORE SUCCESSOR POINTER
14384: MOV (XR),XL GET PCODE
14385: EXI TAKE SUCCESS RETURN
14386: *
14387: * HERE IF EVALUATION FAILS
14388: *
14389: EVLS1 MOV (XS)+,WA POP STACK
14390: EXI 2 TAKE FAILURE RETURN
14391: *
14392: * HERE IF ARGUMENT IS NOT STRING
14393: *
14394: EVLS2 ADD *NUM02,XS POP SUCCESSOR AND CURSOR
14395: EXI 1 TAKE NON-STRING ERROR EXIT
14396: ENP END PROCEDURE EVALS
14397: EJC
14398: *
14399: * EVALX -- EVALUATE EXPRESSION
14400: *
14401: * EVALX IS CALLED TO EVALUATE AN EXPRESSION
14402: *
14403: * (XR) POINTER TO EXBLK OR SEBLK
14404: * (WB) 0 IF BY VALUE, 1 IF BY NAME
14405: * JSR EVALX CALL TO EVALUATE EXPRESSION
14406: * PPM LOC TRANSFER LOC IF EVALUATION FAILS
14407: * (XR) RESULT IF CALLED BY VALUE
14408: * (XL,WA) RESULT NAME BASE,OFFSET IF BY NAME
14409: * (XR) DESTROYED (NAME CASE ONLY)
14410: * (XL,WA) DESTROYED (VALUE CASE ONLY)
14411: * (WB,WC,RA) DESTROYED
14412: *
14413: EVALX PRC R,1 ENTRY POINT, RECURSIVE
14414: BEQ (XR),=B$EXL,EVLX2 JUMP IF EXBLK CASE
14415: *
14416: * HERE FOR SEBLK
14417: *
14418: MOV SEVAR(XR),XL LOAD VRBLK POINTER (NAME BASE)
14419: MOV *VRVAL,WA SET NAME OFFSET
14420: BNZ WB,EVLX1 JUMP IF CALLED BY NAME
14421: JSR ACESS CALL ROUTINE TO ACCESS VALUE
14422: PPM EVLX9 JUMP IF FAILURE ON ACCESS
14423: *
14424: * MERGE HERE TO EXIT FOR SEBLK CASE
14425: *
14426: EVLX1 EXI RETURN TO EVALX CALLER
14427: EJC
14428: *
14429: * EVALX (CONTINUED)
14430: *
14431: * HERE FOR FULL EXPRESSION (EXBLK) CASE
14432: *
14433: * IF AN ERROR OCCURS IN THE EXPRESSION CODE AT EXECUTION
14434: * TIME, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL
14435: * WITHOUT RETURNING TO THIS ROUTINE.
14436: * THE FOLLOWING ENTRIES ARE MADE ON THE STACK BEFORE
14437: * GIVING CONTROL TO THE EXPRESSION CODE
14438: *
14439: * EVALX RETURN POINT
14440: * SAVED VALUE OF R$COD
14441: * CODE POINTER (-R$COD)
14442: * SAVED VALUE OF FLPTR
14443: * 0 IF BY VALUE, 1 IF BY NAME
14444: * FLPTR --------------- *EXFLC, FAIL OFFSET IN EXBLK
14445: *
14446: EVLX2 SCP WC GET CODE POINTER
14447: MOV R$COD,WA LOAD CODE BLOCK POINTER
14448: SUB WA,WC GET CODE POINTER AS OFFSET
14449: MOV WA,-(XS) STACK OLD CODE BLOCK POINTER
14450: MOV WC,-(XS) STACK RELATIVE CODE OFFSET
14451: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER
14452: MOV WB,-(XS) STACK NAME/VALUE INDICATOR
14453: MOV *EXFLC,-(XS) STACK NEW FAIL OFFSET
14454: MOV FLPTR,GTCEF KEEP IN CASE OF ERROR
14455: MOV R$COD,R$GTC KEEP CODE BLOCK POINTER SIMILARLY
14456: MOV XS,FLPTR SET NEW FAILURE POINTER
14457: MOV XR,R$COD SET NEW CODE BLOCK POINTER
14458: MOV KVSTN,EXSTM(XR) REMEMBER STMNT NUMBER
14459: ADD *EXCOD,XR POINT TO FIRST CODE WORD
14460: LCP XR SET CODE POINTER
14461: BNE STAGE,=STGXT,EXITS JUMP IF NOT EXECUTION TIME
14462: MOV =STGEE,STAGE EVALUATING EXPRESSION
14463: BRN EXITS JUMP TO EXECUTE FIRST CODE WORD
14464: EJC
14465: *
14466: * EVALX (CONTINUED)
14467: *
14468: * COME HERE IF SUCCESSFUL RETURN BY VALUE (SEE O$RVL)
14469: *
14470: EVLXV MOV (XS)+,XR LOAD VALUE
14471: BZE 1(XS),EVLX5 JUMP IF CALLED BY VALUE
14472: ERB 218,EXPRESSION EVALUATED BY NAME RETURNED VALUE
14473: *
14474: * HERE FOR EXPRESSION RETURNING BY NAME (SEE O$RNM)
14475: *
14476: EVLXN MOV (XS)+,WA LOAD NAME OFFSET
14477: MOV (XS)+,XL LOAD NAME BASE
14478: BNZ 1(XS),EVLX5 JUMP IF CALLED BY NAME
14479: JSR ACESS ELSE ACCESS VALUE FIRST
14480: PPM EVLXF JUMP IF FAILURE DURING ACCESS
14481: *
14482: * HERE AFTER LOADING CORRECT RESULT INTO XR OR XL,WA
14483: *
14484: EVLX5 ZER WB NOTE SUCCESSFUL
14485: BRN EVLX7 MERGE
14486: *
14487: * HERE FOR FAILURE IN EXPRESSION EVALUATION (SEE O$FEX)
14488: *
14489: EVLXF MNZ WB NOTE UNSUCCESSFUL
14490: *
14491: * RESTORE ENVIRONMENT
14492: *
14493: EVLX7 BNE STAGE,=STGEE,EVLX8 SKIP IF WAS NOT PREVIOUSLY XT
14494: MOV =STGXT,STAGE EXECUTE TIME
14495: *
14496: * MERGE WITH STAGE SET UP
14497: *
14498: EVLX8 ADD *NUM02,XS POP NAME/VALUE INDICATOR, *EXFAL
14499: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER
14500: MOV (XS)+,WC LOAD CODE OFFSET
14501: ADD (XS),WC MAKE CODE POINTER ABSOLUTE
14502: MOV (XS)+,R$COD RESTORE OLD CODE BLOCK POINTER
14503: LCP WC RESTORE OLD CODE POINTER
14504: BZE WB,EVLX1 JUMP FOR SUCCESSFUL RETURN
14505: *
14506: * MERGE HERE FOR FAILURE IN SEBLK CASE
14507: *
14508: EVLX9 EXI 1 TAKE FAILURE EXIT
14509: ENP END OF PROCEDURE EVALX
14510: EJC
14511: *
14512: * EXBLD -- BUILD EXBLK
14513: *
14514: * EXBLD IS USED TO BUILD AN EXPRESSION BLOCK FROM THE
14515: * CODE COMPILED MOST RECENTLY IN THE CURRENT CCBLK.
14516: *
14517: * (XL) OFFSET IN CCBLK TO START OF CODE
14518: * (WB) INTEGER IN RANGE 0 LE N LE MXLEN
14519: * JSR EXBLD CALL TO BUILD EXBLK
14520: * (XR) PTR TO CONSTRUCTED EXBLK
14521: * (WA,WB,XL) DESTROYED
14522: *
14523: EXBLD PRC E,0 ENTRY POINT
14524: MOV XL,WA COPY OFFSET TO START OF CODE
14525: SUB *EXCOD,WA CALC REDUCTION IN OFFSET IN EXBLK
14526: MOV WA,-(XS) STACK FOR LATER
14527: MOV CWCOF,WA LOAD FINAL OFFSET
14528: SUB XL,WA COMPUTE LENGTH OF CODE
14529: ADD *EXSI$,WA ADD SPACE FOR STANDARD FIELDS
14530: JSR ALLOC ALLOCATE SPACE FOR EXBLK
14531: MOV XR,-(XS) SAVE POINTER TO EXBLK
14532: MOV =B$EXL,EXTYP(XR) STORE TYPE WORD
14533: ZER EXSTM(XR) ZEROISE STMNT NUMBER FIELD
14534: MOV WA,EXLEN(XR) STORE LENGTH
14535: MOV =OFEX$,EXFLC(XR) STORE FAILURE WORD
14536: ADD *EXSI$,XR SET XR FOR SYSMW
14537: MOV XL,CWCOF RESET OFFSET TO START OF CODE
14538: ADD R$CCB,XL POINT TO START OF CODE
14539: SUB *EXSI$,WA LENGTH OF CODE TO MOVE
14540: MOV WA,-(XS) STACK LENGTH OF CODE
14541: MVW MOVE CODE TO EXBLK
14542: MOV (XS)+,WA GET LENGTH OF CODE
14543: BTW WA CONVERT BAU COUNT TO WORD COUNT
14544: LCT WA,WA PREPARE COUNTER FOR LOOP
14545: MOV (XS),XL COPY EXBLK PTR, DONT UNSTACK
14546: ADD *EXCOD,XL POINT TO CODE ITSELF
14547: MOV 1(XS),WB GET REDUCTION IN OFFSET
14548: *
14549: * THIS LOOP SEARCHES FOR NEGATION AND SELECTION CODE SO
14550: * THAT THE OFFSETS COMPUTED WHILST CODE WAS IN CODE BLOCK
14551: * CAN BE TRANSFORMED TO REDUCED VALUES APPLICABLE IN AN
14552: * EXBLK.
14553: *
14554: EXBL1 MOV (XL)+,XR GET NEXT CODE WORD
14555: BEQ XR,=OSLA$,EXBL3 JUMP IF SELECTION FOUND
14556: BEQ XR,=ONTA$,EXBL3 JUMP IF NEGATION FOUND
14557: BCT WA,EXBL1 LOOP TO END OF CODE
14558: *
14559: * NO SELECTION FOUND OR MERGE TO EXIT ON TERMINATION
14560: *
14561: EXBL2 MOV (XS)+,XR POP EXBLK PTR INTO XR
14562: MOV (XS)+,XL POP REDUCTION CONSTANT
14563: EXI RETURN TO CALLER
14564: EJC
14565: *
14566: * EXBLD (CONTINUED)
14567: *
14568: * SELECTION OR NEGATION FOUND
14569: * REDUCE THE OFFSETS AS NEEDED. OFFSETS OCCUR IN WORDS
14570: * FOLLOWING CODE WORDS -
14571: * =ONTA$, =OSLA$, =OSLB$, =OSLC$
14572: *
14573: EXBL3 SUB WB,(XL)+ ADJUST OFFSET
14574: BCT WA,EXBL4 DECREMENT COUNT
14575: *
14576: EXBL4 BCT WA,EXBL5 DECREMENT COUNT
14577: *
14578: * CONTINUE SEARCH FOR MORE OFFSETS
14579: *
14580: EXBL5 MOV (XL)+,XR GET NEXT CODE WORD
14581: BEQ XR,=OSLA$,EXBL3 JUMP IF OFFSET FOUND
14582: BEQ XR,=OSLB$,EXBL3 JUMP IF OFFSET FOUND
14583: BEQ XR,=OSLC$,EXBL3 JUMP IF OFFSET FOUND
14584: BEQ XR,=ONTA$,EXBL3 JUMP IF OFFSET FOUND
14585: BCT WA,EXBL5 LOOP
14586: BRN EXBL2 MERGE TO RETURN
14587: ENP END PROCEDURE EXBLD
14588: EJC
14589: *
14590: * EXPAN -- ANALYZE EXPRESSION
14591: *
14592: * THE EXPRESSION ANALYZER (EXPAN) PROCEDURE IS USED TO SCAN
14593: * AN EXPRESSION AND CONVERT IT INTO A TREE REPRESENTATION.
14594: * SEE DESCRIPTIONS OF CMBLK, CUBLK, CBBLK IN THE STRUCTURES
14595: * SECTION FOR DETAILED FORMAT OF TREE BLOCKS.
14596: *
14597: * THE ANALYZER USES A SIMPLE PRECEDENCE SCHEME IN WHICH
14598: * OPERANDS AND OPERATORS ARE PLACED ON A SINGLE STACK
14599: * AND CONDENSATIONS ARE MADE WHEN LOW PRECEDENCE OPERATORS
14600: * ARE STACKED AFTER A HIGHER PRECEDENCE OPERATOR. A GLOBAL
14601: * VARIABLE (IN WB) KEEPS TRACK OF THE LEVEL AS FOLLOWS.
14602: *
14603: * 0 SCANNING OUTER LEVEL OF STATEMENT OR EXPRESSION
14604: * 1 SCANNING OUTER LEVEL OF NORMAL GOTO
14605: * 2 SCANNING OUTER LEVEL OF DIRECT GOTO
14606: * 3 SCANNING INSIDE ARRAY BRACKETS
14607: * 4 SCANNING INSIDE GROUPING PARENTHESES
14608: * 5 SCANNING INSIDE FUNCTION PARENTHESES
14609: *
14610: * THIS VARIABLE IS SAVED ON THE STACK ON ENCOUNTERING A
14611: * GROUPING AND RESTORED AT THE END OF THE GROUPING.
14612: *
14613: * ANOTHER GLOBAL VARIABLE (IN WC) COUNTS THE NUMBER OF
14614: * ITEMS AT ONE GROUPING LEVEL AND IS INCREMENTED FOR EACH
14615: * COMMA ENCOUNTERED. IT IS STACKED WITH THE LEVEL INDICATOR
14616: *
14617: * THE SCAN IS CONTROLLED BY A THREE STATE FINITE MACHINE.
14618: * A GLOBAL VARIABLE STORED IN WA IS THE CURRENT STATE.
14619: *
14620: * WA=0 NOTHING SCANNED AT THIS LEVEL
14621: * WA=1 OPERAND EXPECTED
14622: * WA=2 OPERATOR EXPECTED
14623: *
14624: * (WB) CALL TYPE (SEE BELOW)
14625: * JSR EXPAN CALL TO ANALYZE EXPRESSION
14626: * (XR) POINTER TO RESULTING TREE
14627: * (XL,WA,WB,WC,RA) DESTROYED
14628: *
14629: * THE ENTRY VALUE OF WB INDICATES THE CALL TYPE AS FOLLOWS.
14630: *
14631: * 0 SCANNING EITHER THE MAIN BODY OF A STATEMENT OR THE
14632: * TEXT OF AN EXPRESSION (FROM EVAL CALL). VALID
14633: * TERMINATORS ARE COLON, SEMICOLON. THE RESCAN FLAG IS
14634: * SET TO RETURN THE TERMINATOR ON THE NEXT SCANE CALL.
14635: *
14636: * 1 SCANNING A NORMAL GOTO. THE ONLY VALID
14637: * TERMINATOR IS A RIGHT PAREN.
14638: *
14639: * 2 SCANNING A DIRECT GOTO. THE ONLY VALID
14640: * TERMINATOR IS A RIGHT BRACKET.
14641: EJC
14642: *
14643: * EXPAN (CONTINUED)
14644: *
14645: * ENTRY POINT
14646: *
14647: EXPAN PRC E,0 ENTRY POINT
14648: ZER -(XS) SET TOP OF STACK INDICATOR
14649: ZER WA SET INITIAL STATE TO ZERO
14650: ZER WC ZERO COUNTER VALUE
14651: *
14652: * LOOP HERE FOR SUCCESSIVE ENTRIES
14653: *
14654: EXP01 JSR SCANE SCAN NEXT ELEMENT
14655: ADD WA,XL ADD STATE TO SYNTAX CODE
14656: BSW XL,T$NES SWITCH ON ELEMENT TYPE/STATE
14657: IFF T$VA0,EXP03 VARIABLE, S=0
14658: IFF T$VA1,EXP03 VARIABLE, STATE ONE
14659: IFF T$VA2,EXP04 VARIABLE, S=2
14660: IFF T$CO0,EXP03 CONSTANT, S=0
14661: IFF T$CO1,EXP03 CONSTANT, S=1
14662: IFF T$CO2,EXP04 CONSTANT, S=2
14663: IFF T$LP0,EXP06 LEFT PAREN, S=0
14664: IFF T$LP1,EXP06 LEFT PAREN, S=1
14665: IFF T$LP2,EXP04 LEFT PAREN, S=2
14666: IFF T$FN0,EXP10 FUNCTION, S=0
14667: IFF T$FN1,EXP10 FUNCTION, S=1
14668: IFF T$FN2,EXP04 FUNCTION, S=2
14669: IFF T$RP0,EXP02 RIGHT PAREN, S=0
14670: IFF T$RP1,EXP05 RIGHT PAREN, S=1
14671: IFF T$RP2,EXP12 RIGHT PAREN, S=2
14672: IFF T$LB0,EXP08 LEFT BRKT, S=0
14673: IFF T$LB1,EXP08 LEFT BRKT, S=1
14674: IFF T$LB2,EXP09 LEFT BRKT, S=2
14675: IFF T$RB0,EXP02 RIGHT BRKT, S=0
14676: IFF T$RB1,EXP05 RIGHT BRKT, S=1
14677: IFF T$RB2,EXP18 RIGHT BRKT, S=2
14678: IFF T$UO0,EXP27 UNOP, S=0
14679: IFF T$UO1,EXP27 UNOP, S=1
14680: IFF T$UO2,EXP04 UNOP, S=2
14681: IFF T$BO0,EXP05 BINOP, S=0
14682: IFF T$BO1,EXP05 BINOP, S=1
14683: IFF T$BO2,EXP26 BINOP, S=2
14684: IFF T$CM0,EXP02 COMMA, S=0
14685: IFF T$CM1,EXP05 COMMA, S=1
14686: IFF T$CM2,EXP11 COMMA, S=2
14687: IFF T$CL0,EXP02 COLON, S=0
14688: IFF T$CL1,EXP05 COLON, S=1
14689: IFF T$CL2,EXP19 COLON, S=2
14690: IFF T$SM0,EXP02 SEMICOLON, S=0
14691: IFF T$SM1,EXP05 SEMICOLON, S=1
14692: IFF T$SM2,EXP19 SEMICOLON, S=2
14693: ESW END SWITCH ON ELEMENT TYPE/STATE
14694: EJC
14695: *
14696: * EXPAN (CONTINUED)
14697: *
14698: * HERE FOR RBR,RPR,COL,SMC,CMA IN STATE 0
14699: *
14700: * SET TO RESCAN THE TERMINATOR ENCOUNTERED AND CREATE
14701: * A NULL CONSTANT (CASE OF OMITTED NULL)
14702: *
14703: EXP02 MNZ SCNRS SET TO RESCAN ELEMENT
14704: MOV =NULLS,XR POINT TO NULL, MERGE
14705: *
14706: * HERE FOR VAR OR CON IN STATES 0,1
14707: *
14708: * STACK THE VARIABLE/CONSTANT AND SET STATE=2
14709: *
14710: EXP03 MOV XR,-(XS) STACK POINTER TO OPERAND
14711: MOV =NUM02,WA SET STATE 2
14712: BRN EXP01 JUMP FOR NEXT ELEMENT
14713: *
14714: * HERE FOR VAR,CON,LPR,FNC,UOP IN STATE 2
14715: *
14716: * WE RESCAN THE ELEMENT AND CREATE A CONCATENATION OPERATOR
14717: * THIS IS THE CASE OF THE BLANK CONCATENATION OPERATOR.
14718: *
14719: EXP04 MNZ SCNRS SET TO RESCAN ELEMENT
14720: MOV =OPDVC,XR POINT TO CONCAT OPERATOR DV
14721: BZE WB,EXP4A OK IF AT TOP LEVEL
14722: MOV =OPDVP,XR ELSE POINT TO UNMISTAKEABLE CONCAT
14723: *
14724: * MERGE WITH CORRECT CONCATENATION DVBLK IN XR
14725: *
14726: EXP4A BNZ SCNBL,EXP26 MERGE BOP IF BLANKS, ELSE ERROR
14727: DCV SCNSE ADJUST START OF ELEMENT LOCATION
14728: ERB 219,SYNTAX ERROR. MISSING OPERATOR
14729: *
14730: * HERE FOR CMA,RPR,RBR,COL,SMC,BOP(S=1) BOP(S=0)
14731: *
14732: * THIS IS AN ERRONOUS CONTRUCTION
14733: *
14734: EXP05 DCV SCNSE ADJUST START OF ELEMENT LOCATION
14735: ERB 220,SYNTAX ERROR. MISSING OPERAND
14736: *
14737: * HERE FOR LPR (S=0,1)
14738: *
14739: EXP06 MOV =NUM04,XL SET NEW LEVEL INDICATOR
14740: ZER XR SET ZERO VALUE FOR CMOPN
14741: EJC
14742: *
14743: * EXPAN (CONTINUED)
14744: *
14745: * MERGE HERE TO STORE OLD LEVEL ON STACK AND START NEW ONE
14746: *
14747: EXP07 MOV XR,-(XS) STACK CMOPN VALUE
14748: MOV WC,-(XS) STACK OLD COUNTER
14749: MOV WB,-(XS) STACK OLD LEVEL INDICATOR
14750: CHK CHECK FOR STACK OVERFLOW
14751: ZER WA SET NEW STATE TO ZERO
14752: MOV XL,WB SET NEW LEVEL INDICATOR
14753: MOV =NUM01,WC INITIALIZE NEW COUNTER
14754: BRN EXP01 JUMP TO SCAN NEXT ELEMENT
14755: *
14756: * HERE FOR LBR (S=0,1)
14757: *
14758: * THIS IS AN ILLEGAL USE OF LEFT BRACKET
14759: *
14760: EXP08 ERB 221,SYNTAX ERROR. INVALID USE OF LEFT BRACKET
14761: *
14762: * HERE FOR LBR (S=2)
14763: *
14764: * SET NEW LEVEL AND START TO SCAN SUBSCRIPTS
14765: *
14766: EXP09 MOV (XS)+,XR LOAD ARRAY PTR FOR CMOPN
14767: MOV =NUM03,XL SET NEW LEVEL INDICATOR
14768: BRN EXP07 JUMP TO STACK OLD AND START NEW
14769: *
14770: * HERE FOR FNC (S=0,1)
14771: *
14772: * STACK OLD LEVEL AND START TO SCAN ARGUMENTS
14773: *
14774: EXP10 MOV =NUM05,XL SET NEW LEV INDIC (XR=VRBLK=CMOPN)
14775: BRN EXP07 JUMP TO STACK OLD AND START NEW
14776: *
14777: * HERE FOR CMA (S=2)
14778: *
14779: * INCREMENT ARGUMENT COUNT AND CONTINUE
14780: *
14781: EXP11 ICV WC INCREMENT COUNTER
14782: JSR EXPDM DUMP OPERATORS AT THIS LEVEL
14783: ZER -(XS) SET NEW LEVEL FOR PARAMETER
14784: ZER WA SET NEW STATE
14785: BGT WB,=NUM02,EXP01 LOOP BACK UNLESS OUTER LEVEL
14786: ERB 222,SYNTAX ERROR. INVALID USE OF COMMA
14787: EJC
14788: *
14789: * EXPAN (CONTINUED)
14790: *
14791: * HERE FOR RPR (S=2)
14792: *
14793: * AT OUTER LEVEL IN A NORMAL GOTO THIS IS A TERMINATOR
14794: * OTHERWISE IT MUST TERMINATE A FUNCTION OR GROUPING
14795: *
14796: EXP12 BEQ WB,=NUM01,EXP20 END OF NORMAL GOTO
14797: BEQ WB,=NUM05,EXP13 END OF FUNCTION ARGUMENTS
14798: BEQ WB,=NUM04,EXP14 END OF GROUPING / SELECTION
14799: ERB 223,SYNTAX ERROR. UNBALANCED RIGHT PARENTHESIS
14800: *
14801: * HERE AT END OF FUNCTION ARGUMENTS
14802: *
14803: EXP13 MOV =C$FNC,XL SET CMTYP VALUE FOR FUNCTION
14804: BRN EXP15 JUMP TO BUILD CMBLK
14805: *
14806: * HERE FOR END OF GROUPING
14807: *
14808: EXP14 BEQ WC,=NUM01,EXP17 JUMP IF END OF GROUPING
14809: MOV =C$SEL,XL ELSE SET CMTYP FOR SELECTION
14810: *
14811: * MERGE HERE TO BUILD CMBLK FOR LEVEL JUST SCANNED AND
14812: * TO POP UP TO THE PREVIOUS SCAN LEVEL BEFORE CONTINUING.
14813: *
14814: EXP15 JSR EXPDM DUMP OPERATORS AT THIS LEVEL
14815: MOV WC,WA COPY COUNT
14816: ADD =CMVLS,WA ADD FOR STANDARD FIELDS AT START
14817: WTB WA CONVERT LENGTH TO BAUS
14818: JSR ALLOC ALLOCATE SPACE FOR CMBLK
14819: MOV =B$CMT,(XR) STORE TYPE CODE FOR CMBLK
14820: MOV XL,CMTYP(XR) STORE CMBLK NODE TYPE INDICATOR
14821: MOV WA,CMLEN(XR) STORE LENGTH
14822: ADD WA,XR POINT PAST END OF BLOCK
14823: LCT WC,WC SET LOOP COUNTER
14824: *
14825: * LOOP TO MOVE REMAINING WORDS TO CMBLK
14826: *
14827: EXP16 MOV (XS)+,-(XR) MOVE ONE OPERAND PTR FROM STACK
14828: MOV (XS)+,WB POP TO OLD LEVEL INDICATOR
14829: BCT WC,EXP16 LOOP TILL ALL MOVED
14830: EJC
14831: *
14832: * EXPAN (CONTINUED)
14833: *
14834: * COMPLETE CMBLK AND STACK POINTER TO IT ON STACK
14835: *
14836: SUB *CMVLS,XR POINT BACK TO START OF BLOCK
14837: MOV (XS)+,WC RESTORE OLD COUNTER
14838: MOV (XS),CMOPN(XR) STORE OPERAND PTR IN CMBLK
14839: MOV XR,(XS) STACK CMBLK POINTER
14840: MOV =NUM02,WA SET NEW STATE
14841: BRN EXP01 BACK FOR NEXT ELEMENT
14842: *
14843: * HERE AT END OF A PARENTHESIZED EXPRESSION
14844: *
14845: EXP17 JSR EXPDM DUMP OPERATORS AT THIS LEVEL
14846: MOV (XS)+,XR RESTORE XR
14847: MOV (XS)+,WB RESTORE OUTER LEVEL
14848: MOV (XS)+,WC RESTORE OUTER COUNT
14849: MOV XR,(XS) STORE OPND OVER UNUSED CMOPN VAL
14850: MOV =NUM02,WA SET NEW STATE
14851: BRN EXP01 BACK FOR NEXT ELE8ENT
14852: *
14853: * HERE FOR RBR (S=2)
14854: *
14855: * AT OUTER LEVEL IN A DIRECT GOTO, THIS IS A TERMINATOR.
14856: * OTHERWISE IT MUST TERMINATE A SUBSCRIPT LIST.
14857: *
14858: EXP18 MOV =C$ARR,XL SET CMTYP FOR ARRAY REFERENCE
14859: BEQ WB,=NUM03,EXP15 JUMP TO BUILD CMBLK IF END ARRAYREF
14860: BEQ WB,=NUM02,EXP20 JUMP IF END OF DIRECT GOTO
14861: ERB 224,SYNTAX ERROR. UNBALANCED RIGHT BRACKET
14862: EJC
14863: *
14864: * EXPAN (CONTINUED)
14865: *
14866: * HERE FOR COL,SMC (S=2)
14867: *
14868: * ERROR UNLESS TERMINATING STATEMENT BODY AT OUTER LEVEL
14869: *
14870: EXP19 MNZ SCNRS RESCAN TERMINATOR
14871: MOV WB,XL COPY LEVEL INDICATOR
14872: BSW XL,6 SWITCH ON LEVEL INDICATOR
14873: IFF 0,EXP20 NORMAL OUTER LEVEL
14874: IFF 1,EXP22 FAIL IF NORMAL GOTO
14875: IFF 2,EXP23 FAIL IF DIRECT GOTO
14876: IFF 3,EXP24 FAIL ARRAY BRACKETS
14877: IFF 4,EXP21 FAIL IF IN GROUPING
14878: IFF 5,EXP21 FAIL FUNCTION ARGS
14879: ESW END SWITCH ON LEVEL
14880: *
14881: * HERE AT NORMAL END OF EXPRESSION
14882: *
14883: EXP20 JSR EXPDM DUMP REMAINING OPERATORS
14884: MOV (XS)+,XR LOAD TREE POINTER
14885: ICA XS POP OFF BOTTOM OF STACK MARKER
14886: EXI RETURN TO EXPAN CALLER
14887: *
14888: * MISSING RIGHT PAREN
14889: *
14890: EXP21 ERB 225,SYNTAX ERROR. MISSING RIGHT PAREN
14891: *
14892: * MISSING RIGHT PAREN IN GOTO FIELD
14893: *
14894: EXP22 ERB 226,SYNTAX ERROR. RIGHT PAREN MISSING FROM GOTO
14895: *
14896: * MISSING BRACKET IN GOTO
14897: *
14898: EXP23 ERB 227,SYNTAX ERROR. RIGHT BRACKET MISSING FROM GOTO
14899: *
14900: * MISSING ARRAY BRACKET
14901: *
14902: EXP24 ERB 228,SYNTAX ERROR. MISSING RIGHT ARRAY BRACKET
14903: EJC
14904: *
14905: * EXPAN (CONTINUED)
14906: *
14907: * LOOP HERE WHEN AN OPERATOR CAUSES AN OPERATOR DUMP
14908: *
14909: EXP25 MOV XR,EXPSV
14910: JSR EXPOP POP ONE OPERATOR
14911: MOV EXPSV,XR RESTORE OP DV POINTER AND MERGE
14912: *
14913: * HERE FOR BOP (S=2)
14914: *
14915: * REMOVE OPERATORS (CONDENSE) FROM STACK UNTIL NO MORE
14916: * LEFT AT THIS LEVEL OR TOP ONE HAS LOWER PRECEDENCE.
14917: * LOOP HERE TILL THIS CONDITION IS MET.
14918: *
14919: EXP26 MOV 1(XS),XL LOAD OPERATOR DVPTR FROM STACK
14920: BLE XL,=NUM05,EXP27 JUMP IF BOTTOM OF STACK LEVEL
14921: BLT DVRPR(XR),DVLPR(XL),EXP25 ELSE POP IF NEW PREC IS LO
14922: *
14923: * HERE FOR UOP (S=0,1)
14924: *
14925: * BINARY OPERATOR MERGES AFTER PRECEDENCE CHECK
14926: *
14927: * THE OPERATOR DV IS STORED ON THE STACK AND THE SCAN
14928: * CONTINUES AFTER SETTING THE SCAN STATE TO ONE.
14929: *
14930: EXP27 MOV XR,-(XS) STACK OPERATOR DVPTR ON STACK
14931: CHK CHECK FOR STACK OVERFLOW
14932: MOV =NUM01,WA SET NEW STATE
14933: BNE XR,=OPDVS,EXP01 BACK FOR NEXT ELEMENT UNLESS =
14934: *
14935: * HERE FOR SPECIAL CASE OF BINARY =. THE SYNTAX ALLOWS A
14936: * NULL RIGHT ARGUMENT FOR THIS OPERATOR TO BE LEFT
14937: * OUT. ACCORDINGLY WE RESET TO STATE ZERO TO GET PROPER
14938: * ACTION ON A TERMINATOR (SUPPLY A NULL CONSTANT).
14939: *
14940: ZER WA SET STATE ZERO
14941: BRN EXP01 JUMP FOR NEXT ELEMENT
14942: ENP END PROCEDURE EXPAN
14943: EJC
14944: *
14945: * EXPAP -- TEST FOR PATTERN MATCH TREE
14946: *
14947: * EXPAP IS PASSED AN EXPRESSION TREE TO DETERMINE IF IT
14948: * IS A PATTERN MATCH. THE FOLLOWING ARE RECOGIZED AS
14949: * MATCHES IN THE CONTEXT OF THIS CALL.
14950: *
14951: * 1) AN EXPLICIT USE OF BINARY QUESTION MARK
14952: * 2) A CONCATENATION
14953: * 3) AN ALTERNATION WHOSE LEFT OPERAND IS A CONCATENATION
14954: *
14955: * (XR) PTR TO EXPAN TREE
14956: * JSR EXPAP CALL TO TEST FOR PATTERN MATCH
14957: * PPM LOC TRANSFER LOC IF NOT A PATTERN MATCH
14958: * (WA) DESTROYED
14959: * (XR) UNCHANGED (IF NOT MATCH)
14960: * (XR) PTR TO BINARY OPERATOR BLK IF MATCH
14961: *
14962: EXPAP PRC E,1 ENTRY POINT
14963: MOV XL,-(XS) SAVE XL
14964: BNE (XR),=B$CMT,EXPP2 NO MATCH IF NOT COMPLEX
14965: MOV CMTYP(XR),WA ELSE LOAD TYPE CODE
14966: BEQ WA,=C$CNC,EXPP1 CONCATENATION IS A MATCH
14967: BEQ WA,=C$PMT,EXPP1 BINARY QUESTION MARK IS A MATCH
14968: BNE WA,=C$ALT,EXPP2 ELSE NOT MATCH UNLESS ALTERNATION
14969: *
14970: * HERE FOR ALTERNATION. CHANGE (A B) / C TO A QM (B / C)
14971: *
14972: MOV CMLOP(XR),XL LOAD LEFT OPERAND POINTER
14973: BNE (XL),=B$CMT,EXPP2 NOT MATCH IF LEFT OPND NOT COMPLEX
14974: BNE CMTYP(XL),=C$CNC,EXPP2 NOT MATCH IF LEFT OP NOT CONC
14975: MOV CMROP(XL),CMLOP(XR) XR POINTS TO (B / C)
14976: MOV XR,CMROP(XL) SET XL OPNDS TO A, (B / C)
14977: MOV XL,XR POINT TO THIS ALTERED NODE
14978: *
14979: * EXIT HERE FOR PATTERN MATCH
14980: *
14981: EXPP1 MOV (XS)+,XL RESTORE ENTRY XL
14982: EXI GIVE PATTERN MATCH RETURN
14983: *
14984: * EXIT HERE IF NOT PATTERN MATCH
14985: *
14986: EXPP2 MOV (XS)+,XL RESTORE ENTRY XL
14987: EXI 1 GIVE NON-MATCH RETURN
14988: ENP END PROCEDURE EXPAP
14989: EJC
14990: *
14991: * EXPDM -- DUMP OPERATORS AT CURRENT LEVEL (FOR EXPAN)
14992: *
14993: * EXPDM USES EXPOP TO CONDENSE ALL OPERATORS AT THIS SYNTAX
14994: * LEVEL. THE STACK BOTTOM IS RECOGNIZED FROM THE LEVEL
14995: * VALUE WHICH IS SAVED ON THE TOP OF THE STACK.
14996: *
14997: * JSR EXPDM CALL TO DUMP OPERATORS
14998: * (XS) POPPED AS REQUIRED
14999: * (XR,WA) DESTROYED
15000: *
15001: EXPDM PRC N,0 ENTRY POINT
15002: MOV XL,R$EXS SAVE XL VALUE
15003: *
15004: * LOOP TO DUMP OPERATORS
15005: *
15006: EXDM1 BLE 1(XS),=NUM05,EXDM2 JUMP IF STACK BOTTOM (SAVED LEVEL)
15007: JSR EXPOP ELSE POP ONE OPERATOR
15008: BRN EXDM1 AND LOOP BACK
15009: *
15010: * HERE AFTER POPPING ALL OPERATORS
15011: *
15012: EXDM2 MOV R$EXS,XL RESTORE XL
15013: ZER R$EXS RELEASE SAVE LOCATION
15014: EXI RETURN TO EXPDM CALLER
15015: ENP END PROCEDURE EXPDM
15016: EJC
15017: *
15018: * EXPOP-- POP OPERATOR (FOR EXPAN)
15019: *
15020: * EXPOP IS USED BY THE EXPAN ROUTINE TO CONDENSE ONE
15021: * OPERATOR FROM THE TOP OF THE SYNTAX STACK. AN APPROPRIATE
15022: * CMBLK IS BUILT FOR THE OPERATOR (UNARY OR BINARY) AND A
15023: * POINTER TO THIS CMBLK IS STACKED.
15024: *
15025: * EXPOP IS ALSO USED BY SCNGF (GOTO FIELD SCAN) PROCEDURE
15026: *
15027: * JSR EXPOP CALL TO POP OPERATOR
15028: * (XS) POPPED APPROPRIATELY
15029: * (XR,XL,WA) DESTROYED
15030: *
15031: EXPOP PRC N,0 ENTRY POINT
15032: MOV 1(XS),XR LOAD OPERATOR DV POINTER
15033: BEQ DVLPR(XR),=LLUNO,EXPO2 JUMP IF UNARY
15034: *
15035: * HERE FOR BINARY OPERATOR
15036: *
15037: MOV *CMBS$,WA SET SIZE OF BINARY OPERATOR CMBLK
15038: JSR ALLOC ALLOCATE SPACE FOR CMBLK
15039: MOV (XS)+,CMROP(XR) POP AND STORE RIGHT OPERAND PTR
15040: MOV (XS)+,XL POP AND LOAD OPERATOR DV PTR
15041: MOV (XS),CMLOP(XR) STORE LEFT OPERAND POINTER
15042: *
15043: * COMMON EXIT POINT
15044: *
15045: EXPO1 MOV =B$CMT,(XR) STORE TYPE CODE FOR CMBLK
15046: MOV DVTYP(XL),CMTYP(XR) STORE CMBLK NODE TYPE CODE
15047: MOV XL,CMOPN(XR) STORE DVPTR (=PTR TO DAC O$XXX)
15048: MOV WA,CMLEN(XR) STORE CMBLK LENGTH
15049: MOV XR,(XS) STORE RESULTING NODE PTR ON STACK
15050: EXI RETURN TO EXPOP CALLER
15051: *
15052: * HERE FOR UNARY OPERATOR
15053: *
15054: EXPO2 MOV *CMUS$,WA SET SIZE OF UNARY OPERATOR CMBLK
15055: JSR ALLOC ALLOCATE SPACE FOR CMBLK
15056: MOV (XS)+,CMROP(XR) POP AND STORE OPERAND POINTER
15057: MOV (XS),XL LOAD OPERATOR DV POINTER
15058: BRN EXPO1 MERGE BACK TO EXIT
15059: ENP END PROCEDURE EXPOP
15060: EJC
15061: *
15062: * GBCOL -- PERFORM GARBAGE COLLECTION
15063: *
15064: * GBCOL PERFORMS A GARBAGE COLLECTION ON THE DYNAMIC REGION
15065: * ALL BLOCKS WHICH ARE NO LONGER IN USE ARE ELIMINATED
15066: * BY MOVING BLOCKS WHICH ARE IN USE DOWN AND RESETTING
15067: * DNAMP, THE POINTER TO THE NEXT AVAILABLE LOCATION.
15068: *
15069: * (WB) MOVE OFFSET (SEE BELOW)
15070: * JSR GBCOL CALL TO COLLECT GARBAGE
15071: * (XR) DESTROYED
15072: *
15073: * THE FOLLOWING CONDITIONS MUST BE MET AT THE TIME WHEN
15074: * GBCOL IS CALLED.
15075: *
15076: * 1) ALL POINTERS TO BLOCKS IN THE DYNAMIC AREA MUST BE
15077: * ACCESSIBLE TO THE GARBAGE COLLECTOR. THIS MEANS
15078: * THAT THEY MUST OCCUR IN ONE OF THE FOLLOWING.
15079: *
15080: * A) MAIN STACK, WITH CURRENT TOP
15081: * ELEMENT BEING INDICATED BY XS
15082: *
15083: * B) IN RELOCATABLE FIELDS OF VRBLKS.
15084: *
15085: * C) IN REGISTER XL AT THE TIME OF CALL
15086: *
15087: * E) IN THE SPECIAL REGION OF WORKING
15088: * STORAGE WHERE NAMES BEGIN WITH R$.
15089: *
15090: * 2) ALL POINTERS MUST POINT TO THE START OF BLOCKS WITH
15091: * THE SOLE EXCEPTION OF THE CONTENTS OF THE CODE
15092: * POINTER REGISTER WHICH POINTS INTO THE R$COD BLOCK.
15093: *
15094: * 3) NO LOCATION WHICH APPEARS TO CONTAIN A POINTER
15095: * INTO THE DYNAMIC REGION MAY OCCUR UNLESS IT IS IN
15096: * FACT A POINTER TO THE START OF THE BLOCK. HOWEVER
15097: * POINTERS OUTSIDE THIS AREA MAY OCCUR AND WILL
15098: * NOT BE CHANGED BY THE GARBAGE COLLECTOR.
15099: * IT IS ESPECIALLY IMPORTANT TO MAKE SURE THAT XL
15100: * DOES NOT CONTAIN A GARBAGE VALUE FROM SOME PROCESS
15101: * CARRIED OUT BEFORE THE CALL TO THE COLLECTOR.
15102: *
15103: * GBCOL HAS THE CAPABILITY OF MOVING THE FINAL COMPACTED
15104: * RESULT UP IN MEMORY (WITH ADDRESSES ADJUSTED ACCORDINGLY)
15105: * THIS IS USED TO ADD SPACE TO THE STATIC REGION. THE
15106: * ENTRY VALUE OF WB IS THE NUMBER OF BAUS TO MOVE UP.
15107: * THE CALLER MUST GUARANTEE THAT THERE IS ENOUGH ROOM.
15108: * FURTHERMORE THE VALUE IN WB IF IT IS NON-ZERO, MUST BE AT
15109: * LEAST 256 SO THAT THE MWB INSTRUCTION CONDITIONS ARE MET.
15110: EJC
15111: *
15112: * GBCOL (CONTINUED)
15113: *
15114: * THE ALGORITHM, WHICH IS A MODIFICATION OF THE LISP-2
15115: * GARBAGE COLLECTOR DEVISED BY R.DEWAR AND K.BELCHER
15116: * TAKES THREE PASSES AS FOLLOWS.
15117: *
15118: * 1) ALL POINTERS IN MEMORY ARE SCANNED AND BLOCKS IN USE
15119: * DETERMINED FROM THIS SCAN. NOTE THAT THIS PROCEDURE
15120: * IS RECURSIVE AND USES THE MAIN STACK FOR LINKAGE.
15121: * THE MARKING PROCESS IS THUS SIMILAR TO THAT USED IN
15122: * A STANDARD LISP COLLECTOR. HOWEVER THE METHOD OF
15123: * ACTUALLY MARKING THE BLOCKS IS DIFFERENT.
15124: *
15125: * THE FIRST FIELD OF A BLOCK NORMALLY CONTAINS A
15126: * CODE ENTRY POINT POINTER. SUCH AN ENTRY POINTER
15127: * CAN BE DISTINGUISHED FROM THE ADDRESS OF ANY POINTER
15128: * TO BE PROCESSED BY THE COLLECTOR. DURING GARBAGE
15129: * COLLECTION, THIS WORD IS USED TO BUILD A BACK CHAIN
15130: * OF POINTERS THROUGH FIELDS WHICH POINT TO THE BLOCK.
15131: * THE END OF THE CHAIN IS MARKED BY THE OCCURENCE
15132: * OF THE WORD WHICH USED TO BE IN THE FIRST WORD OF
15133: * THE BLOCK. THIS BACKCHAIN SERVES BOTH AS A MARK
15134: * INDICATING THAT THE BLOCK IS IN USE AND AS A LIST OF
15135: * REFERENCES FOR THE RELOCATION PHASE.
15136: *
15137: * 2) STORAGE IS SCANNED SEQUENTIALLY TO DISCOVER WHICH
15138: * BLOCKS ARE CURRENTLY IN USE AS INDICATED BY THE
15139: * PRESENCE OF A BACKCHAIN. TWO POINTERS ARE MAINTAINED
15140: * ONE SCANS THROUGH LOOKING AT EACH BLOCK. THE OTHER
15141: * IS INCREMENTED ONLY FOR BLOCKS FOUND TO BE IN USE.
15142: * IN THIS WAY, THE EVENTUAL LOCATION OF EACH BLOCK CAN
15143: * BE DETERMINED WITHOUT ACTUALLY MOVING ANY BLOCKS.
15144: * AS EACH BLOCK WHICH IS IN USE IS PROCESSED, THE BACK
15145: * CHAIN IS USED TO RESET ALL POINTERS WHICH POINT TO
15146: * THIS BLOCK TO CONTAIN ITS NEW ADDRESS, I.E. THE
15147: * ADDRESS IT WILL OCCUPY AFTER THE BLOCKS ARE MOVED.
15148: * THE FIRST WORD OF THE BLOCK, TAKEN FROM THE END OF
15149: * THE CHAIN IS RESTORED AT THIS POINT.
15150: *
15151: * DURING PASS 2, THE COLLECTOR BUILDS BLOCKS WHICH
15152: * DESCRIBE THE REGIONS OF STORAGE WHICH ARE TO BE
15153: * MOVED IN THE THIRD PASS. THERE IS ONE DESCRIPTOR FOR
15154: * EACH CONTIGUOUS SET OF GOOD BLOCKS. THE DESCRIPTOR
15155: * IS BUILT JUST BEHIND THE BLOCK TO BE MOVED AND
15156: * CONTAINS A POINTER TO THE NEXT BLOCK AND THE NUMBER
15157: * OF WORDS TO BE MOVED.
15158: *
15159: * 3) IN THE THIRD AND FINAL PASS, THE MOVE DESCRIPTOR
15160: * BLOCKS BUILT IN PASS TWO ARE USED TO ACTUALLY MOVE
15161: * THE BLOCKS DOWN TO THE BOTTOM OF THE DYNAMIC REGION.
15162: * THE COLLECTION IS THEN COMPLETE AND THE NEXT
15163: * AVAILABLE LOCATION POINTER IS RESET.
15164: EJC
15165: *
15166: * GBCOL (CONTINUED)
15167: *
15168: GBCOL PRC E,0 ENTRY POINT
15169: BNZ DMVCH,GBC14 FAIL IF IN MID-DUMP
15170: MNZ GBCFL NOTE GBCOL ENTERED
15171: MOV WA,GBSVA SAVE ENTRY WA
15172: MOV WB,GBSVB SAVE ENTRY WB
15173: MOV WC,GBSVC SAVE ENTRY WC
15174: MOV XL,-(XS) SAVE ENTRY XL
15175: SCP WA GET CODE POINTER VALUE
15176: SUB R$COD,WA MAKE RELATIVE
15177: LCP WA AND RESTORE
15178: *
15179: * PROCESS STACK ENTRIES
15180: *
15181: MOV XS,XR POINT TO STACK FRONT
15182: MOV STBAS,XL POINT PAST END OF STACK
15183: BGE XL,XR,GBC00 OK IF D-STACK
15184: MOV XL,XR REVERSE IF ...
15185: MOV XS,XL ... U-STACK
15186: *
15187: * PROCESS THE STACK
15188: *
15189: GBC00 JSR GBCPF PROCESS POINTERS ON STACK
15190: *
15191: * PROCESS SPECIAL WORK LOCATIONS
15192: *
15193: MOV =R$AAA,XR POINT TO START OF RELOCATABLE LOCS
15194: MOV =R$YYY,XL POINT PAST END OF RELOCATABLE LOCS
15195: JSR GBCPF PROCESS WORK FIELDS
15196: *
15197: * PREPARE TO PROCESS VARIABLE BLOCKS
15198: *
15199: MOV HSHTB,WA POINT TO FIRST HASH SLOT POINTER
15200: *
15201: * LOOP THROUGH HASH SLOTS
15202: *
15203: GBC01 MOV WA,XL POINT TO NEXT SLOT
15204: ICA WA BUMP BUCKET POINTER
15205: MOV WA,GBCNM SAVE BUCKET POINTER
15206: EJC
15207: *
15208: * GBCOL (CONTINUED)
15209: *
15210: * LOOP THROUGH VARIABLES ON ONE HASH CHAIN
15211: *
15212: GBC02 MOV (XL),XR LOAD PTR TO NEXT VRBLK
15213: BZE XR,GBC03 JUMP IF END OF CHAIN
15214: MOV XR,XL ELSE COPY VRBLK POINTER
15215: ADD *VRVAL,XR POINT TO FIRST RELOC FLD
15216: ADD *VRNXT,XL POINT PAST LAST (AND TO LINK PTR)
15217: JSR GBCPF PROCESS RELOC FIELDS IN VRBLK
15218: BRN GBC02 LOOP BACK FOR NEXT BLOCK
15219: *
15220: * HERE AT END OF ONE HASH CHAIN
15221: *
15222: GBC03 MOV GBCNM,WA RESTORE BUCKET POINTER
15223: BNE WA,HSHTE,GBC01 LOOP BACK IF MORE BUCKETS TO GO
15224: EJC
15225: *
15226: * GBCOL (CONTINUED)
15227: *
15228: * NOW WE ARE READY TO START PASS TWO. REGISTERS ARE USED
15229: * AS FOLLOWS IN PASS TWO.
15230: *
15231: * (XR) SCANS THROUGH ALL BLOCKS
15232: * (WC) POINTER TO EVENTUAL LOCATION
15233: *
15234: * THE MOVE DESCRIPTION BLOCKS BUILT IN THIS PASS HAVE
15235: * THE FOLLOWING FORMAT.
15236: *
15237: * WORD 1 POINTER TO NEXT MOVE BLOCK,
15238: * ZERO IF END OF CHAIN OF BLOCKS
15239: *
15240: * WORD 2 LENGTH OF BLOCKS TO BE MOVED IN
15241: * BAUS. SET TO THE ADDRESS OF THE
15242: * FIRST BAU WHILE ACTUALLY SCANNING
15243: * THE BLOCKS.
15244: *
15245: * THE FIRST ENTRY ON THIS CHAIN IS A SPECIAL ENTRY
15246: * CONSISTING OF THE TWO WORDS GBCNM AND GBCNS. AFTER
15247: * BUILDING THE CHAIN OF MOVE DESCRIPTORS, GBCNM POINTS TO
15248: * THE FIRST REAL MOVE BLOCK, AND GBCNS IS THE LENGTH OF
15249: * BLOCKS IN USE AT THE START OF STORAGE WHICH NEED NOT
15250: * BE MOVED SINCE THEY ARE IN THE CORRECT POSITION.
15251: *
15252: GBC04 MOV DNAMB,XR POINT TO FIRST BLOCK
15253: MOV XR,WC SET AS FIRST EVENTUAL LOCATION
15254: ADD GBSVB,WC ADD OFFSET FOR EVENTUAL MOVE UP
15255: ZER GBCNM CLEAR INITIAL FORWARD POINTER
15256: MOV =GBCNM,GBCLM INITIALIZE PTR TO LAST MOVE BLOCK
15257: MOV XR,GBCNS INITIALIZE FIRST ADDRESS
15258: *
15259: * LOOP THROUGH A SERIES OF BLOCKS IN USE
15260: *
15261: GBC05 BEQ XR,DNAMP,GBC07 JUMP IF END OF USED REGION
15262: MOV (XR),WA ELSE GET FIRST WORD
15263: .IF .CEPP
15264: BOD WA,GBC07 JUMP IF ENTRY POINTER (UNUSED)
15265: .ELSE
15266: BHI WA,=P$YYY,GBC06 SKIP IF NOT ENTRY PTR (IN USE)
15267: BHI WA,=B$AAA,GBC07 JUMP IF ENTRY POINTER (UNUSED)
15268: .FI
15269: *
15270: * HERE FOR BLOCK IN USE, LOOP TO RELOCATE REFERENCES
15271: *
15272: GBC06 MOV WA,XL COPY POINTER
15273: MOV (XL),WA LOAD FORWARD POINTER
15274: MOV WC,(XL) RELOCATE REFERENCE
15275: .IF .CEPP
15276: BEV WA,GBC06 LOOP BACK IF NOT END OF CHAIN
15277: .ELSE
15278: BHI WA,=P$YYY,GBC06 LOOP BACK IF NOT END OF CHAIN
15279: BLO WA,=B$AAA,GBC06 LOOP BACK IF NOT END OF CHAIN
15280: .FI
15281: EJC
15282: *
15283: * GBCOL (CONTINUED)
15284: *
15285: * AT END OF CHAIN, RESTORE FIRST WORD AND BUMP PAST
15286: *
15287: MOV WA,(XR) RESTORE FIRST WORD
15288: JSR BLKLN GET LENGTH OF THIS BLOCK
15289: ADD WA,XR BUMP ACTUAL POINTER
15290: ADD WA,WC BUMP EVENTUAL POINTER
15291: BRN GBC05 LOOP BACK FOR NEXT BLOCK
15292: *
15293: * HERE AT END OF A SERIES OF BLOCKS IN USE
15294: *
15295: GBC07 MOV XR,WA COPY POINTER PAST LAST BLOCK
15296: MOV GBCLM,XL POINT TO PREVIOUS MOVE BLOCK
15297: SUB 1(XL),WA SUBTRACT STARTING ADDRESS
15298: MOV WA,1(XL) STORE LENGTH OF BLOCK TO BE MOVED
15299: *
15300: * LOOP THROUGH A SERIES OF BLOCKS NOT IN USE
15301: *
15302: GBC08 BEQ XR,DNAMP,GBC10 JUMP IF END OF USED REGION
15303: MOV (XR),WA ELSE LOAD FIRST WORD OF NEXT BLOCK
15304: .IF .CEPP
15305: BEV WA,GBC09 JUMP IF IN USE
15306: .ELSE
15307: BHI WA,=P$YYY,GBC09 JUMP IF IN USE
15308: BLO WA,=B$AAA,GBC09 JUMP IF IN USE
15309: .FI
15310: JSR BLKLN ELSE GET LENGTH OF NEXT BLOCK
15311: ADD WA,XR PUSH POINTER
15312: BRN GBC08 AND LOOP BACK
15313: *
15314: * HERE FOR A BLOCK IN USE AFTER PROCESSING A SERIES OF
15315: * BLOCKS WHICH WERE NOT IN USE, BUILD NEW MOVE BLOCK.
15316: *
15317: GBC09 SUB *NUM02,XR POINT 2 WORDS BEHIND FOR MOVE BLOCK
15318: MOV GBCLM,XL POINT TO PREVIOUS MOVE BLOCK
15319: MOV XR,(XL) SET FORWARD PTR IN PREVIOUS BLOCK
15320: ZER (XR) ZERO FORWARD PTR OF NEW BLOCK
15321: MOV XR,GBCLM REMEMBER ADDRESS OF THIS BLOCK
15322: MOV XR,XL COPY PTR TO MOVE BLOCK
15323: ADD *NUM02,XR POINT BACK TO BLOCK IN USE
15324: MOV XR,1(XL) STORE STARTING ADDRESS
15325: BRN GBC06 JUMP TO PROCESS BLOCK IN USE
15326: EJC
15327: *
15328: * GBCOL (CONTINUED)
15329: *
15330: * HERE FOR PASS THREE -- ACTUALLY MOVE THE BLOCKS DOWN
15331: *
15332: * (XL) POINTER TO OLD LOCATION
15333: * (XR) POINTER TO NEW LOCATION
15334: *
15335: GBC10 MOV DNAMB,XR POINT TO START OF STORAGE
15336: ADD GBCNS,XR BUMP PAST UNMOVED BLOCKS AT START
15337: *
15338: * LOOP THROUGH MOVE DESCRIPTORS
15339: *
15340: GBC11 MOV GBCNM,XL POINT TO NEXT MOVE BLOCK
15341: BZE XL,GBC12 JUMP IF END OF CHAIN
15342: MOV (XL)+,GBCNM MOVE POINTER DOWN CHAIN
15343: MOV (XL)+,WA GET LENGTH TO MOVE
15344: MVW PERFORM MOVE
15345: BRN GBC11 LOOP BACK
15346: *
15347: * NOW TEST FOR MOVE UP
15348: *
15349: GBC12 MOV XR,DNAMP SET NEXT AVAILABLE LOC PTR
15350: MOV GBSVB,WB RELOAD MOVE OFFSET
15351: BZE WB,GBC13 JUMP IF NO MOVE REQUIRED
15352: MOV XR,XL ELSE COPY OLD TOP OF CORE
15353: ADD WB,XR POINT TO NEW TOP OF CORE
15354: MOV XR,DNAMP SAVE NEW TOP OF CORE POINTER
15355: MOV XL,WA COPY OLD TOP
15356: SUB DNAMB,WA MINUS OLD BOTTOM = LENGTH
15357: ADD WB,DNAMB BUMP BOTTOM TO GET NEW VALUE
15358: MWB PERFORM MOVE (BACKWARDS)
15359: *
15360: * MERGE HERE TO EXIT
15361: *
15362: GBC13 MOV GBSVA,WA RESTORE WA
15363: SCP WC GET CODE POINTER
15364: ADD R$COD,WC MAKE ABSOLUTE AGAIN
15365: LCP WC AND REPLACE ABSOLUTE VALUE
15366: MOV GBSVC,WC RESTORE WC
15367: MOV (XS)+,XL RESTORE ENTRY XL
15368: ICV GBCNT INCREMENT COUNT OF COLLECTIONS
15369: ZER XR CLEAR GARBAGE VALUE IN XR
15370: ZER GBCFL NOTE EXIT FROM GBCOL
15371: EXI EXIT TO GBCOL CALLER
15372: *
15373: * GARBAGE COLLECTION NOT ALLOWED WHILST DUMPING
15374: *
15375: GBC14 ICV ERRFT FATAL ERROR
15376: ERB 229,INSUFFICIENT MEMORY TO COMPLETE DUMP
15377: ENP END PROCEDURE GBCOL
15378: EJC
15379: *
15380: * GBCPF -- PROCESS FIELDS FOR GARBAGE COLLECTOR
15381: *
15382: * THIS PROCEDURE IS USED BY THE GARBAGE COLLECTOR TO
15383: * PROCESS FIELDS IN PASS ONE. SEE GBCOL FOR FULL DETAILS.
15384: *
15385: * (XR) PTR TO FIRST LOCATION TO PROCESS
15386: * (XL) PTR PAST LAST LOCATION TO PROCESS
15387: * JSR GBCPF CALL TO PROCESS FIELDS
15388: * (XR,WA,WB,WC,IA) DESTROYED
15389: *
15390: * NOTE THAT ALTHOUGH THIS PROCEDURE USES A RECURSIVE
15391: * APPROACH, IT CONTROLS ITS OWN STACK AND IS NOT RECURSIVE.
15392: *
15393: GBCPF PRC E,0 ENTRY POINT
15394: ZER -(XS) SET ZERO TO MARK BOTTOM OF STACK
15395: MOV XL,-(XS) SAVE END POINTER
15396: *
15397: * MERGE HERE TO GO DOWN A LEVEL AND START A NEW LOOP
15398: *
15399: * 1(XS) NEXT LVL FIELD PTR (0 AT OUTER LVL)
15400: * 0(XS) PTR PAST LAST FIELD TO PROCESS
15401: * (XR) PTR TO FIRST FIELD TO PROCESS
15402: *
15403: * LOOP TO PROCESS SUCCESSIVE FIELDS
15404: *
15405: GPF01 MOV (XR),XL LOAD FIELD CONTENTS
15406: MOV XR,WC SAVE FIELD POINTER
15407: .IF .CRPP
15408: BOD XL,GPF02 JUMP IF NOT PTR INTO DYNAMIC AREA
15409: .ELSE
15410: .FI
15411: BLT XL,DNAMB,GPF02 JUMP IF NOT PTR INTO DYNAMIC AREA
15412: BGE XL,DNAMP,GPF02 JUMP IF NOT PTR INTO DYNAMIC AREA
15413: *
15414: * HERE WE HAVE A PTR TO A BLOCK IN THE DYNAMIC AREA.
15415: * LINK THIS FIELD ONTO THE REFERENCE BACKCHAIN.
15416: *
15417: MOV (XL),WA LOAD PTR TO CHAIN (OR ENTRY PTR)
15418: MOV XR,(XL) SET THIS FIELD AS NEW HEAD OF CHAIN
15419: MOV WA,(XR) SET FORWARD POINTER
15420: *
15421: * NOW SEE IF THIS BLOCK HAS BEEN PROCESSED BEFORE
15422: *
15423: .IF .CEPP
15424: BOD WA,GPF03 JUMP IF NOT ALREADY PROCESSED
15425: .ELSE
15426: BHI WA,=P$YYY,GPF02 JUMP IF ALREADY PROCESSED
15427: BHI WA,=B$AAA,GPF03 JUMP IF NOT ALREADY PROCESSED
15428: .FI
15429: *
15430: * HERE TO MOVE TO NEXT FIELD
15431: *
15432: GPF02 MOV WC,XR RESTORE FIELD POINTER
15433: ICA XR BUMP TO NEXT FIELD
15434: BNE XR,(XS),GPF01 LOOP BACK IF MORE TO GO
15435: EJC
15436: *
15437: * GBCPF (CONTINUED)
15438: *
15439: * HERE WE POP UP A LEVEL AFTER FINISHING A BLOCK
15440: *
15441: MOV (XS)+,XL RESTORE POINTER PAST END
15442: MOV (XS)+,WC RESTORE BLOCK POINTER
15443: BNZ WC,GPF02 CONTINUE LOOP UNLESS OUTER LEVL
15444: EXI RETURN TO CALLER IF OUTER LEVEL
15445: *
15446: * HERE TO PROCESS AN ACTIVE BLOCK WHICH HAS NOT BEEN DONE
15447: *
15448: GPF03 MOV XL,XR COPY BLOCK POINTER
15449: MOV WA,XL COPY FIRST WORD OF BLOCK
15450: LEI XL LOAD ENTRY POINT ID (BL$XX)
15451: *
15452: * BLOCK TYPE SWITCH. NOTE THAT BLOCKS WITH NO RELOCATABLE
15453: * FIELDS JUST RETURN TO GPF02 HERE TO CONTINE TO NEXT FLD.
15454: *
15455: BSW XL,BL$$$ SWITCH ON BLOCK TYPE
15456: IFF BL$AR,GPF06 ARBLK
15457: .IF .CNBF
15458: .ELSE
15459: IFF BL$BC,GPF18 BCBLK
15460: IFF BL$BF,GPF02 BFBLK
15461: .FI
15462: IFF BL$CC,GPF07 CCBLK
15463: IFF BL$CD,GPF08 CDBLK
15464: IFF BL$CM,GPF04 CMBLK
15465: IFF BL$CO,GPF19 COBLK
15466: IFF BL$DF,GPF02 DFBLK
15467: IFF BL$EV,GPF10 EVBLK
15468: IFF BL$EX,GPF17 EXBLK
15469: IFF BL$FF,GPF11 FFBLK
15470: IFF BL$NM,GPF10 NMBLK
15471: IFF BL$P0,GPF10 P0BLK
15472: IFF BL$P1,GPF12 P1BLK
15473: IFF BL$P2,GPF12 P2BLK
15474: IFF BL$PD,GPF13 PDBLK
15475: IFF BL$PF,GPF14 PFBLK
15476: IFF BL$TB,GPF08 TBBLK
15477: IFF BL$TE,GPF15 TEBLK
15478: IFF BL$TR,GPF16 TRBLK
15479: IFF BL$VC,GPF08 VCBLK
15480: IFF BL$XR,GPF09 XRBLK
15481: IFF BL$CT,GPF02 CTBLK
15482: IFF BL$EF,GPF02 EFBLK
15483: IFF BL$IC,GPF02 ICBLK
15484: IFF BL$KV,GPF02 KVBLK
15485: .IF .CNRA
15486: .ELSE
15487: IFF BL$RC,GPF02 RCBLK
15488: .FI
15489: IFF BL$SC,GPF02 SCBLK
15490: IFF BL$SE,GPF02 SEBLK
15491: IFF BL$XN,GPF02 XNBLK
15492: ESW END OF JUMP TABLE
15493: EJC
15494: *
15495: * GBCPF (CONTINUED)
15496: *
15497: * CMBLK
15498: *
15499: GPF04 MOV CMLEN(XR),WA LOAD LENGTH
15500: MOV *CMTYP,WB SET OFFSET
15501: *
15502: * HERE TO PUSH DOWN TO NEW LEVEL
15503: *
15504: * (WC) FIELD PTR AT PREVIOUS LEVEL
15505: * (XR) PTR TO NEW BLOCK
15506: * (WA) LENGTH (RELOC FLDS + FLDS AT START)
15507: * (WB) OFFSET TO FIRST RELOC FIELD
15508: *
15509: GPF05 ADD XR,WA POINT PAST LAST RELOC FIELD
15510: ADD WB,XR POINT TO FIRST RELOC FIELD
15511: MOV WC,-(XS) STACK OLD FIELD POINTER
15512: MOV WA,-(XS) STACK NEW LIMIT POINTER
15513: CHK CHECK FOR STACK OVERFLOW
15514: BRN GPF01 IF OK, BACK TO PROCESS
15515: *
15516: * ARBLK
15517: *
15518: GPF06 MOV ARLEN(XR),WA LOAD LENGTH
15519: MOV AROFS(XR),WB SET OFFSET TO 1ST RELOC FLD (ARPRO)
15520: BRN GPF05 ALL SET
15521: *
15522: * CCBLK
15523: *
15524: GPF07 MOV CCUSE(XR),WA SET LENGTH IN USE
15525: MOV *CCUSE,WB 1ST WORD (MAKE SURE AT LEAST ONE)
15526: BRN GPF05 ALL SET
15527: EJC
15528: *
15529: * GBCPF (CONTINUED)
15530: *
15531: * CDBLK, TBBLK, VCBLK
15532: *
15533: GPF08 MOV OFFS2(XR),WA LOAD LENGTH
15534: MOV *OFFS3,WB SET OFFSET
15535: BRN GPF05 JUMP BACK
15536: *
15537: * XRBLK
15538: *
15539: GPF09 MOV XRLEN(XR),WA LOAD LENGTH
15540: MOV *XRPTR,WB SET OFFSET
15541: BRN GPF05 JUMP BACK
15542: *
15543: * EVBLK, NMBLK, P0BLK
15544: *
15545: GPF10 MOV *OFFS2,WA POINT PAST SECOND FIELD
15546: MOV *OFFS1,WB OFFSET IS ONE (ONLY RELOC FLD IS 2)
15547: BRN GPF05 ALL SET
15548: *
15549: * FFBLK
15550: *
15551: GPF11 MOV *FFOFS,WA SET LENGTH
15552: MOV *FFNXT,WB SET OFFSET
15553: BRN GPF05 ALL SET
15554: *
15555: * P1BLK, P2BLK
15556: *
15557: GPF12 MOV *PARM2,WA LENGTH (PARM2 IS NON-RELOCATABLE)
15558: MOV *PTHEN,WB SET OFFSET
15559: BRN GPF05 ALL SET
15560: EJC
15561: *
15562: * GBCPF (CONTINUED)
15563: *
15564: * PDBLK
15565: *
15566: GPF13 MOV PDDFP(XR),XL LOAD PTR TO DFBLK
15567: MOV DFPDL(XL),WA GET PDBLK LENGTH
15568: MOV *PDFLD,WB SET OFFSET
15569: BRN GPF05 ALL SET
15570: *
15571: * PFBLK
15572: *
15573: GPF14 MOV *PFARG,WA LENGTH PAST LAST RELOC
15574: MOV *PFCOD,WB OFFSET TO FIRST RELOC
15575: BRN GPF05 ALL SET
15576: *
15577: * TEBLK
15578: *
15579: GPF15 MOV *TESI$,WA SET LENGTH
15580: MOV *TESUB,WB AND OFFSET
15581: BRN GPF05 ALL SET
15582: *
15583: * TRBLK
15584: *
15585: GPF16 MOV *TRSI$,WA SET LENGTH
15586: MOV *TRVAL,WB AND OFFSET
15587: BRN GPF05 ALL SET
15588: *
15589: * EXBLK
15590: *
15591: GPF17 MOV EXLEN(XR),WA LOAD LENGTH
15592: MOV *EXFLC,WB SET OFFSET
15593: BRN GPF05 JUMP BACK
15594: .IF .CNBF
15595: .ELSE
15596: *
15597: * BCBLK
15598: *
15599: GPF18 MOV *BCSI$,WA SET LENGTH
15600: MOV *BCBUF,WB AND OFFSET
15601: BRN GPF05 ALL SET
15602: .FI
15603: *
15604: * COBLK
15605: *
15606: GPF19 MOV *COSI$,WA SET LENGTH
15607: MOV *CONXT,WB AND OFFSET
15608: BRN GPF05 ALL SET
15609: ENP END PROCEDURE GBCPF
15610: .IF .CNBF
15611: .ELSE
15612: EJC
15613: *
15614: * GTBUF -- GET BUFFER
15615: *
15616: * GTBUF IS PASSED AN OBJECT AND RETURNS A BUFFER IF
15617: * POSSIBLE. UNLESS THE OBJECT IS ALREADY A BUFFER,
15618: * THIS INVOLVES A CONVERSION TO STRING AND THEN
15619: * STRING TO BUFFER.
15620: *
15621: * (XR) OBJECT TO BE CONVERTED
15622: * JSR GTBUF CALL TO GET BUFFER
15623: * PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE
15624: * (XR) RESULTING BUFFER
15625: * (XL,WA,WB,WC) DESTROYED
15626: *
15627: GTBUF PRC E,1 ENTRY POINT
15628: BEQ (XR),=B$BCT,GTB01 EXIT IF ALREADY BUFFER
15629: MOV XR,-(XS) STACK TO CONVERT TO STRING
15630: JSR GTSTG CONVERT TO STRING
15631: PPM GTB02 CONVERSION ERROR
15632: MOV XR,XL SAVE STRING POINTER
15633: JSR ALOBF ALLOCATE BUFFER OF SAME SIZE
15634: JSR INSBF COPY IN THE STRING
15635: PPM ALREADY STRING - CANT FAIL TO CNV
15636: PPM MUST BE ENOUGH ROOM
15637: *
15638: * MERGE TO EXIT WITH BUFFER CONTROL BLK IN (XR)
15639: *
15640: GTB01 EXI RETURN TO CALLER
15641: *
15642: * HERE ON CONVERSION FAILURE
15643: *
15644: GTB02 EXI 1 TAKE FAILURE EXIT
15645: ENP
15646: .FI
15647: EJC
15648: *
15649: * GTARR -- GET ARRAY
15650: *
15651: * GTARR IS PASSED AN OBJECT AND RETURNS AN ARRAY IF POSSIBLE
15652: *
15653: * (XR) VALUE TO BE CONVERTED
15654: * JSR GTARR CALL TO GET ARRAY
15655: * PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE
15656: * (XR) RESULTING ARRAY
15657: * (XL,WA,WB,WC) DESTROYED
15658: *
15659: GTARR PRC E,1 ENTRY POINT
15660: MOV (XR),WA LOAD TYPE WORD
15661: BEQ WA,=B$ART,GTAR8 EXIT IF ALREADY AN ARRAY
15662: BEQ WA,=B$VCT,GTAR8 EXIT IF ALREADY AN ARRAY
15663: MOV XR,-(XS) PLACE POSSIBLE TBBLK PTR ON STACK
15664: BNE WA,=B$TBT,GTAR9 ELSE FAIL IF NOT A TABLE
15665: *
15666: * HERE WE CONVERT A TABLE TO AN ARRAY
15667: *
15668: ZER XR SIGNAL FIRST PASS
15669: ZER WB ZERO NON-NULL ELEMENT COUNT
15670: *
15671: * THE FOLLOWING CODE IS EXECUTED TWICE. ON THE FIRST PASS,
15672: * SIGNALLED BY XR=0, THE NUMBER OF NON-NULL ELEMENTS IN
15673: * THE TABLE IS COUNTED IN WB. IN THE SECOND PASS, WHERE
15674: * XR IS A POINTER INTO THE ARBLK, THE NAME AND VALUE ARE
15675: * ENTERED INTO THE CURRENT ARBLK LOCATION.
15676: *
15677: GTAR1 MOV (XS),XL POINT TO TABLE
15678: ADD TBLEN(XL),XL POINT PAST LAST BUCKET
15679: SUB *TBBUK,XL SET FIRST BUCKET OFFSET
15680: MOV XL,WA COPY ADJUSTED POINTER
15681: *
15682: * LOOP THROUGH BUCKETS IN TABLE BLOCK
15683: * NEXT THREE LINES OF CODE RELY ON TENXT HAVING A VALUE
15684: * 1 LESS THAN TBBUK.
15685: *
15686: GTAR2 MOV WA,XL COPY BUCKET POINTER
15687: DCA WA DECREMENT BUCKET POINTER
15688: *
15689: * LOOP THROUGH TEBLKS ON ONE BUCKET CHAIN
15690: *
15691: GTAR3 MOV TENXT(XL),XL POINT TO NEXT TEBLK
15692: BEQ XL,(XS),GTAR6 JUMP IF CHAIN END (TBBLK PTR)
15693: MOV XL,CNVTP ELSE SAVE TEBLK POINTER
15694: *
15695: * LOOP TO FIND VALUE DOWN TRBLK CHAIN
15696: *
15697: GTAR4 MOV TEVAL(XL),XL LOAD VALUE
15698: BEQ (XL),=B$TRT,GTAR4 LOOP TILL VALUE FOUND
15699: MOV XL,WC COPY VALUE
15700: MOV CNVTP,XL RESTORE TEBLK POINTER
15701: EJC
15702: *
15703: * GTARR (CONTINUED)
15704: *
15705: * NOW CHECK FOR NULL AND TEST CASES
15706: *
15707: BEQ WC,=NULLS,GTAR3 LOOP BACK TO IGNORE NULL VALUE
15708: BNZ XR,GTAR5 JUMP IF SECOND PASS
15709: ICV WB FOR THE FIRST PASS, BUMP COUNT
15710: BRN GTAR3 AND LOOP BACK FOR NEXT TEBLK
15711: *
15712: * HERE IN SECOND PASS
15713: *
15714: GTAR5 MOV TESUB(XL),(XR)+ STORE SUBSCRIPT NAME
15715: MOV WC,(XR)+ STORE VALUE IN ARBLK
15716: BRN GTAR3 LOOP BACK FOR NEXT TEBLK
15717: *
15718: * HERE AFTER SCANNING TEBLKS ON ONE CHAIN
15719: *
15720: GTAR6 BNE WA,(XS),GTAR2 LOOP BACK IF MORE BUCKETS TO GO
15721: BNZ XR,GTAR7 ELSE JUMP IF SECOND PASS
15722: *
15723: * HERE AFTER COUNTING NON-NULL ELEMENTS
15724: *
15725: BZE WB,GTAR9 FAIL IF NO NON-NULL ELEMENTS
15726: MOV WB,WA ELSE COPY COUNT
15727: ADD WB,WA DOUBLE (TWO WORDS/ELEMENT)
15728: ADD =ARVL2,WA ADD SPACE FOR STANDARD FIELDS
15729: WTB WA CONVERT LENGTH TO BAUS
15730: BGE WA,MXLEN,GTAR9 FAIL IF TOO LONG FOR ARRAY
15731: JSR ALLOC ELSE ALLOCATE SPACE FOR ARBLK
15732: MOV =B$ART,(XR) STORE TYPE WORD
15733: ZER IDVAL(XR) ZERO ID FOR THE MOMENT
15734: MOV WA,ARLEN(XR) STORE LENGTH
15735: MOV =NUM02,ARNDM(XR) SET DIMENSIONS = 2
15736: LDI INTV1 GET INTEGER ONE
15737: STI ARLBD(XR) STORE AS LBD 1
15738: STI ARLB2(XR) STORE AS LBD 2
15739: LDI INTV2 LOAD INTEGER TWO
15740: STI ARDM2(XR) STORE AS DIM 2
15741: MTI WB GET ELEMENT COUNT AS INTEGER
15742: STI ARDIM(XR) STORE AS DIM 1
15743: ZER ARPR2(XR) ZERO PROTOTYPE FIELD FOR NOW
15744: MOV *ARPR2,AROFS(XR) SET OFFSET FIELD (SIGNAL PASS 2)
15745: MOV XR,WB SAVE ARBLK POINTER
15746: ADD *ARVL2,XR POINT TO FIRST ELEMENT LOCATION
15747: BRN GTAR1 JUMP BACK TO FILL IN ELEMENTS
15748: EJC
15749: *
15750: * GTARR (CONTINUED)
15751: *
15752: * HERE AFTER FILLING IN ELEMENT VALUES
15753: *
15754: GTAR7 MOV WB,XR RESTORE ARBLK POINTER
15755: MOV WB,(XS) STORE AS RESULT
15756: *
15757: * NOW WE NEED THE ARRAY PROTOTYPE WHICH IS OF THE FORM NN,2
15758: * THIS IS OBTAINED BY BUILDING THE STRING FOR NN02 AND
15759: * CHANGING THE ZERO TO A COMMA BEFORE STORING IT.
15760: *
15761: LDI ARDIM(XR) GET NUMBER OF ELEMENTS (NN)
15762: MLI INTVH MULTIPLY BY 100
15763: ADI INTV2 ADD 2 (NN02)
15764: JSR ICBLD BUILD INTEGER
15765: MOV XR,-(XS) STORE PTR FOR GTSTG
15766: JSR GTSTG CONVERT TO STRING
15767: PPM CONVERT FAIL IS IMPOSSIBLE
15768: MOV XR,XL COPY STRING POINTER
15769: MOV (XS)+,XR RELOAD ARBLK POINTER
15770: MOV XL,ARPR2(XR) STORE PROTOTYPE PTR (NN02)
15771: SUB =NUM02,WA ADJUST LENGTH TO POINT TO ZERO
15772: PSC XL,WA POINT TO ZERO
15773: MOV =CH$CM,WB LOAD A COMMA
15774: SCH WB,(XL) STORE A COMMA OVER THE ZERO
15775: CSC XL COMPLETE STORE CHARACTERS
15776: *
15777: * NORMAL RETURN
15778: *
15779: GTAR8 EXI RETURN TO CALLER
15780: *
15781: * NON-CONVERSION RETURN
15782: *
15783: GTAR9 MOV (XS)+,XR CLEAR UP STACK
15784: EXI 1 RETURN
15785: ENP PROCEDURE GTARR
15786: EJC
15787: *
15788: * GTCOD -- CONVERT TO CODE
15789: *
15790: * (XR) OBJECT TO BE CONVERTED
15791: * JSR GTCOD CALL TO CONVERT TO CODE
15792: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
15793: * (XR) POINTER TO RESULTING CDBLK
15794: * (XL,WA,WB,WC,RA) DESTROYED
15795: *
15796: * IF A SPITBOL ERROR OCCURS DURING COMPILATION OR PRE-
15797: * EVALUATION, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL
15798: * WITHOUT RETURNING TO THIS ROUTINE.
15799: *
15800: GTCOD PRC E,1 ENTRY POINT
15801: BEQ (XR),=B$CDS,GTCD1 JUMP IF ALREADY CODE
15802: BEQ (XR),=B$CDC,GTCD1 JUMP IF ALREADY CODE
15803: *
15804: * HERE WE MUST GENERATE A CDBLK BY COMPILATION
15805: *
15806: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG
15807: JSR GTSTG CONVERT ARGUMENT TO STRING
15808: PPM GTCD2 JUMP IF NON-CONVERTIBLE
15809: MOV FLPTR,GTCEF SAVE FAIL PTR IN CASE OF ERROR
15810: MOV R$COD,R$GTC ALSO SAVE CODE PTR
15811: MOV XR,R$CIM ELSE SET IMAGE POINTER
15812: MOV WA,SCNIL SET IMAGE LENGTH
15813: ZER SCNPT SET SCAN POINTER
15814: MOV =STGXC,STAGE SET STAGE FOR EXECUTE COMPILE
15815: MOV CMPSN,LSTSN IN CASE LISTR CALLED
15816: JSR CMPIL COMPILE STRING
15817: MOV =STGXT,STAGE RESET STAGE FOR EXECUTE TIME
15818: ZER R$CIM CLEAR IMAGE
15819: *
15820: * MERGE HERE IF NO CONVERT REQUIRED
15821: *
15822: GTCD1 EXI GIVE NORMAL GTCOD RETURN
15823: *
15824: * HERE IF UNCONVERTIBLE
15825: *
15826: GTCD2 EXI 1 GIVE ERROR RETURN
15827: ENP END PROCEDURE GTCOD
15828: EJC
15829: *
15830: * GTEXP -- CONVERT TO EXPRESSION
15831: *
15832: * (XR) INPUT VALUE TO BE CONVERTED
15833: * JSR GTEXP CALL TO CONVERT TO EXPRESSION
15834: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
15835: * (XR) POINTER TO RESULT EXBLK OR SEBLK
15836: * (XL,WA,WB,WC,RA) DESTROYED
15837: *
15838: * IF A SPITBOL ERROR OCCURS DURING COMPILATION OR PRE-
15839: * EVALUATION, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL
15840: * WITHOUT RETURNING TO THIS ROUTINE.
15841: *
15842: GTEXP PRC E,1 ENTRY POINT
15843: BLO (XR),=B$E$$,GTEX1 JUMP IF ALREADY AN EXPRESSION
15844: MOV XR,-(XS) STORE ARGUMENT FOR GTSTG
15845: JSR GTSTG CONVERT ARGUMENT TO STRING
15846: PPM GTEX2 JUMP IF UNCONVERTIBLE
15847: *
15848: * CHECK THE LAST CHAR OF STRING FOR COLON OR
15849: * SEMICOLON. THEY CAN LEGITIMATELY END AN EXPRESSION
15850: * IN OPEN CODE, SO EXPAN WILL NOT FAIL THEM BUT THEY ARE
15851: * INVALID AS TERMINATORS FOR A STRING WHICH IS TO BE
15852: * CONVERTED TO EXPRESSION FORM.
15853: *
15854: MOV XR,XL COPY ARGUMENT STRING
15855: PLC XL,WA POINT PAST STRING END
15856: LCH XL,-(XL) GET LAST CHAR
15857: BEQ XL,=CH$CL,GTEX2 FAIL IF COLON
15858: BEQ XL,=CH$SM,GTEX2 FAIL IF SEMICOLON
15859: *
15860: * HERE WE CONVERT A STRING BY COMPILATION
15861: *
15862: MOV XR,R$CIM SET INPUT IMAGE POINTER
15863: ZER SCNPT SET SCAN POINTER
15864: MOV WA,SCNIL SET INPUT IMAGE LENGTH
15865: ZER WB SET CODE FOR NORMAL SCAN
15866: MOV FLPTR,GTCEF SAVE FAIL PTR IN CASE OF ERROR
15867: MOV R$COD,R$GTC ALSO SAVE CODE PTR
15868: MOV =STGEV,STAGE ADJUST STAGE FOR COMPILE
15869: MOV =T$UOK,SCNTP INDICATE UNARY OPERATOR ACCEPTABLE
15870: JSR EXPAN BUILD TREE FOR EXPRESSION
15871: ZER SCNRS RESET RESCAN FLAG
15872: BNE SCNPT,SCNIL,GTEX2 ERROR IF NOT END OF IMAGE
15873: ZER WB SET OK VALUE FOR CDGEX CALL
15874: MOV XR,XL COPY TREE POINTER
15875: JSR CDGEX BUILD EXPRESSION BLOCK
15876: ZER R$CIM CLEAR POINTER
15877: MOV =STGXT,STAGE RESTORE STAGE FOR EXECUTE TIME
15878: *
15879: * MERGE HERE IF NO CONVERSION REQUIRED
15880: *
15881: GTEX1 EXI RETURN TO GTEXP CALLER
15882: *
15883: * HERE IF UNCONVERTIBLE
15884: *
15885: GTEX2 EXI 1 TAKE ERROR EXIT
15886: ENP END PROCEDURE GTEXP
15887: EJC
15888: *
15889: * GTINT -- GET INTEGER VALUE
15890: *
15891: * GTINT IS PASSED AN OBJECT AND RETURNS AN INTEGER AFTER
15892: * PERFORMING ANY NECESSARY CONVERSIONS.
15893: *
15894: * (XR) VALUE TO BE CONVERTED
15895: * JSR GTINT CALL TO CONVERT TO INTEGER
15896: * PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE
15897: * (XR) RESULTING INTEGER
15898: * (WC,RA) DESTROYED
15899: * (WA,WB) DESTROYED (ONLY ON CONVERSION ERR)
15900: * (XR) UNCHANGED (ON CONVERT ERROR)
15901: *
15902: GTINT PRC E,1 ENTRY POINT
15903: BEQ (XR),=B$ICL,GTIN2 JUMP IF ALREADY AN INTEGER
15904: MOV WA,GTINA ELSE SAVE WA
15905: MOV WB,GTINB SAVE WB
15906: JSR GTNUM CONVERT TO NUMERIC
15907: PPM GTIN3 JUMP IF UNCONVERTIBLE
15908: .IF .CNRA
15909: .ELSE
15910: BEQ WA,=B$ICL,GTIN1 JUMP IF INTEGER
15911: *
15912: * HERE WE CONVERT A REAL TO INTEGER
15913: *
15914: LDR RCVAL(XR) LOAD REAL VALUE
15915: RTI GTIN3 CONVERT TO INTEGER (ERR IF OVFLOW)
15916: JSR ICBLD IF OK BUILD ICBLK
15917: .FI
15918: *
15919: * HERE AFTER SUCCESSFUL CONVERSION TO INTEGER
15920: *
15921: GTIN1 MOV GTINA,WA RESTORE WA
15922: MOV GTINB,WB RESTORE WB
15923: *
15924: * COMMON EXIT POINT
15925: *
15926: GTIN2 EXI RETURN TO GTINT CALLER
15927: *
15928: * HERE ON CONVERSION ERROR
15929: *
15930: GTIN3 EXI 1 TAKE CONVERT ERROR EXIT
15931: ENP END PROCEDURE GTINT
15932: EJC
15933: *
15934: * GTNUM -- GET NUMERIC VALUE
15935: *
15936: * GTNUM IS GIVEN AN OBJECT AND RETURNS EITHER AN INTEGER
15937: * OR A REAL, PERFORMING ANY NECESSARY CONVERSIONS.
15938: *
15939: * (XR) OBJECT TO BE CONVERTED
15940: * JSR GTNUM CALL TO CONVERT TO NUMERIC
15941: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
15942: * (XR) POINTER TO RESULT (INT OR REAL)
15943: * (WA) FIRST WORD OF RESULT BLOCK
15944: * (WB,WC,RA) DESTROYED
15945: * (XR) UNCHANGED (ON CONVERT ERROR)
15946: *
15947: GTNUM PRC E,1 ENTRY POINT
15948: MOV (XR),WA LOAD FIRST WORD OF BLOCK
15949: BEQ WA,=B$ICL,GTN3A JUMP IF INTEGER (NO CONVERSION)
15950: .IF .CNRA
15951: .ELSE
15952: BEQ WA,=B$RCL,GTN3A JUMP IF REAL (NO CONVERSION)
15953: .FI
15954: *
15955: * AT THIS POINT THE ONLY POSSIBILITY IS TO CONVERT A STRING
15956: * TO AN INTEGER OR REAL AS APPROPRIATE.
15957: *
15958: STI GTNSV SAVE IA
15959: MOV XR,-(XS) STACK ARGUMENT IN CASE CONVERT ERR
15960: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG
15961: JSR GTSTG CONVERT ARGUMENT TO STRING
15962: PPM GTN36 JUMP IF UNCONVERTIBLE
15963: *
15964: * INITIALIZE NUMERIC CONVERSION
15965: *
15966: LDI INTV0 INITIALIZE INTEGER RESULT TO ZERO
15967: BZE WA,GTN32 JUMP TO EXIT WITH ZERO IF NULL
15968: LCT WA,WA SET BCT COUNTER FOR FOLLOWING LOOPS
15969: ZER GTNNF TENTATIVELY INDICATE RESULT +
15970: .IF .CNRA
15971: .ELSE
15972: STI GTNEX INITIALISE EXPONENT TO ZERO
15973: ZER GTNSC ZERO SCALE IN CASE REAL
15974: ZER GTNDF RESET FLAG FOR DEC POINT FOUND
15975: ZER GTNRD RESET FLAG FOR DIGITS FOUND
15976: LDR REAV0 ZERO REAL ACCUM IN CASE REAL
15977: .FI
15978: PLC XR POINT TO ARGUMENT CHARACTERS
15979: *
15980: * MERGE BACK HERE AFTER IGNORING LEADING BLANK
15981: *
15982: GTN01 LCH WB,(XR)+ LOAD FIRST CHARACTER
15983: BLT WB,=CH$D0,GTN02 JUMP IF NOT DIGIT
15984: BLE WB,=CH$D9,GTN06 JUMP IF FIRST CHAR IS A DIGIT
15985: EJC
15986: *
15987: * GTNUM (CONTINUED)
15988: *
15989: * HERE IF FIRST DIGIT IS NON-DIGIT
15990: *
15991: GTN02 BNE WB,=CH$BL,GTN03 JUMP IF NON-BLANK
15992: GTNA2 BCT WA,GTN01 ELSE DECR COUNT AND LOOP BACK
15993: BRN GTN07 JUMP TO RETURN ZERO IF ALL BLANKS
15994: *
15995: * HERE FOR FIRST CHARACTER NON-BLANK, NON-DIGIT
15996: *
15997: GTN03 BEQ WB,=CH$PL,GTN04 JUMP IF PLUS SIGN
15998: .IF .CAHT
15999: BEQ WB,=CH$HT,GTNA2 HORIZONTAL TAB EQUIV TO BLANK
16000: .FI
16001: .IF .CAVT
16002: BEQ WB,=CH$VT,GTNA2 VERTICAL TAB EQUIV TO BLANK
16003: .FI
16004: .IF .CNRA
16005: BNE WB,=CH$MN,GTN36 ELSE FAIL
16006: .ELSE
16007: BNE WB,=CH$MN,GTN12 JUMP IF NOT MINUS (MAY BE REAL)
16008: .FI
16009: MNZ GTNNF IF MINUS SIGN, SET NEGATIVE FLAG
16010: *
16011: * MERGE HERE AFTER PROCESSING SIGN
16012: *
16013: GTN04 BCT WA,GTN05 JUMP IF CHARS LEFT
16014: BRN GTN36 ELSE ERROR
16015: *
16016: * LOOP TO FETCH CHARACTERS OF AN INTEGER
16017: *
16018: GTN05 LCH WB,(XR)+ LOAD NEXT CHARACTER
16019: BLT WB,=CH$D0,GTN08 JUMP IF NOT A DIGIT
16020: BGT WB,=CH$D9,GTN08 JUMP IF NOT A DIGIT
16021: *
16022: * MERGE HERE FOR FIRST DIGIT
16023: *
16024: GTN06 STI GTNSI SAVE CURRENT VALUE
16025: .IF .CNRA
16026: CVM GTN36 CURRENT*10-(NEW DIG) JUMP IF OVFLOW
16027: .ELSE
16028: CVM GTN35 CURRENT*10-(NEW DIG) JUMP IF OVFLOW
16029: MNZ GTNRD SET DIGIT READ FLAG
16030: .FI
16031: BCT WA,GTN05 ELSE LOOP BACK IF MORE CHARS
16032: *
16033: * HERE TO EXIT WITH CONVERTED INTEGER VALUE
16034: *
16035: GTN07 BNZ GTNNF,GTN32 JUMP IF NEGATIVE (ALL SET)
16036: NGI ELSE NEGATE
16037: INO GTN32 JUMP IF NO OVERFLOW
16038: BRN GTN36 ELSE SIGNAL ERROR
16039: EJC
16040: *
16041: * GTNUM (CONTINUED)
16042: *
16043: * HERE FOR A NON-DIGIT CHARACTER WHILE ATTEMPTING TO
16044: * CONVERT AN INTEGER, CHECK FOR TRAILING BLANKS OR REAL.
16045: *
16046: GTN08 BEQ WB,=CH$BL,GTNA9 JUMP IF A BLANK
16047: .IF .CAHT
16048: BEQ WB,=CH$HT,GTNA9 JUMP IF HORIZONTAL TAB
16049: .FI
16050: .IF .CAVT
16051: BEQ WB,=CH$VT,GTNA9 JUMP IF VERTICAL TAB
16052: .FI
16053: .IF .CNRA
16054: BRN GTN36 ERROR
16055: .ELSE
16056: ITR ELSE CONVERT INTEGER TO REAL
16057: NGR NEGATE TO GET POSITIVE VALUE
16058: BRN GTN12 JUMP TO TRY FOR REAL
16059: .FI
16060: *
16061: * HERE WE SCAN OUT BLANKS TO END OF STRING
16062: *
16063: GTN09 LCH WB,(XR)+ GET NEXT CHAR
16064: .IF .CAHT
16065: BEQ WB,=CH$HT,GTNA9 JUMP IF HORIZONTAL TAB
16066: .FI
16067: .IF .CAVT
16068: BEQ WB,=CH$VT,GTNA9 JUMP IF VERTICAL TAB
16069: .FI
16070: BNE WB,=CH$BL,GTN36 ERROR IF NON-BLANK
16071: GTNA9 BCT WA,GTN09 LOOP BACK IF MORE CHARS TO CHECK
16072: BRN GTN07 RETURN INTEGER IF ALL BLANKS
16073: .IF .CNRA
16074: .ELSE
16075: *
16076: * LOOP TO COLLECT MANTISSA OF REAL
16077: *
16078: GTN10 LCH WB,(XR)+ LOAD NEXT CHARACTER
16079: BLT WB,=CH$D0,GTN12 JUMP IF NON-NUMERIC
16080: BGT WB,=CH$D9,GTN12 JUMP IF NON-NUMERIC
16081: *
16082: * MERGE HERE TO COLLECT FIRST REAL DIGIT
16083: *
16084: GTN11 SUB =CH$D0,WB CONVERT DIGIT TO NUMBER
16085: MLR REAVT MULTIPLY REAL BY 10.0
16086: ROV GTN36 CONVERT ERROR IF OVERFLOW
16087: STR GTNSR SAVE RESULT
16088: MTI WB GET NEW DIGIT AS INTEGER
16089: ITR CONVERT NEW DIGIT TO REAL
16090: ADR GTNSR ADD TO GET NEW TOTAL
16091: ADD GTNDF,GTNSC INCREMENT SCALE IF AFTER DEC POINT
16092: MNZ GTNRD SET DIGIT FOUND FLAG
16093: BCT WA,GTN10 LOOP BACK IF MORE CHARS
16094: BRN GTN22 ELSE JUMP TO SCALE
16095: EJC
16096: *
16097: * GTNUM (CONTINUED)
16098: *
16099: * HERE IF NON-DIGIT FOUND WHILE COLLECTING A REAL
16100: *
16101: GTN12 BNE WB,=CH$DT,GTN13 JUMP IF NOT DEC POINT
16102: BNZ GTNDF,GTN36 IF DEC POINT, ERROR IF ONE ALREADY
16103: MOV =NUM01,GTNDF ELSE SET FLAG FOR DEC POINT
16104: BCT WA,GTN10 LOOP BACK IF MORE CHARS
16105: BRN GTN22 ELSE JUMP TO SCALE
16106: *
16107: * HERE IF NOT DECIMAL POINT
16108: *
16109: GTN13 BEQ WB,=CH$LE,GTN15 JUMP IF E FOR EXPONENT
16110: BEQ WB,=CH$LD,GTN15 JUMP IF D FOR EXPONENT
16111: .IF .CASL
16112: BEQ WB,=CH$$E,GTN15 JUMP FOR EXPT
16113: BEQ WB,=CH$$D,GTN15 JUMP FOR EXPT
16114: .FI
16115: *
16116: * HERE CHECK FOR TRAILING BLANKS
16117: *
16118: GTN14 BEQ WB,=CH$BL,GTNB4 JUMP IF BLANK
16119: .IF .CAHT
16120: BEQ WB,=CH$HT,GTNB4 JUMP IF HORIZONTAL TAB
16121: .FI
16122: .IF .CAVT
16123: BEQ WB,=CH$VT,GTNB4 JUMP IF VERTICAL TAB
16124: .FI
16125: BRN GTN36 ERROR IF NON-BLANK
16126: *
16127: GTNB4 LCH WB,(XR)+ GET NEXT CHARACTER
16128: BCT WA,GTN14 LOOP BACK TO CHECK IF MORE
16129: BRN GTN22 ELSE JUMP TO SCALE
16130: *
16131: * HERE TO READ AND PROCESS AN EXPONENT
16132: *
16133: GTN15 ZER GTNES SET EXPONENT SIGN POSITIVE
16134: LDI INTV0 INITIALIZE EXPONENT TO ZERO
16135: MNZ GTNDF RESET NO DEC POINT INDICATION
16136: BCT WA,GTN16 JUMP SKIPPING PAST E OR D
16137: BRN GTN36 ERROR IF NULL EXPONENT
16138: *
16139: * CHECK FOR EXPONENT SIGN
16140: *
16141: GTN16 LCH WB,(XR)+ LOAD FIRST EXPONENT CHARACTER
16142: BEQ WB,=CH$PL,GTN17 JUMP IF PLUS SIGN
16143: BNE WB,=CH$MN,GTN19 ELSE JUMP IF NOT MINUS SIGN
16144: MNZ GTNES SET SIGN NEGATIVE IF MINUS SIGN
16145: *
16146: * MERGE HERE AFTER PROCESSING EXPONENT SIGN
16147: *
16148: GTN17 BCT WA,GTN18 JUMP IF CHARS LEFT
16149: BRN GTN36 ELSE ERROR
16150: *
16151: * LOOP TO CONVERT EXPONENT DIGITS
16152: *
16153: GTN18 LCH WB,(XR)+ LOAD NEXT CHARACTER
16154: EJC
16155: *
16156: * GTNUM (CONTINUED)
16157: *
16158: * MERGE HERE FOR FIRST EXPONENT DIGIT
16159: *
16160: GTN19 BLT WB,=CH$D0,GTN20 JUMP IF NOT DIGIT
16161: BGT WB,=CH$D9,GTN20 JUMP IF NOT DIGIT
16162: CVM GTN36 ELSE CURRENT*10, SUBTRACT NEW DIGIT
16163: BCT WA,GTN18 LOOP BACK IF MORE CHARS
16164: BRN GTN21 JUMP IF EXPONENT FIELD IS EXHAUSTED
16165: *
16166: * HERE TO CHECK FOR TRAILING BLANKS AFTER EXPONENT
16167: *
16168: GTN20 BEQ WB,=CH$BL,GTNC0 JUMP IF BLANK
16169: .IF .CAHT
16170: BEQ WB,=CH$HT,GTNC0 JUMP IF HORIZONTAL TAB
16171: .FI
16172: .IF .CAVT
16173: BEQ WC,=CH$VT,GTNC0 JUMP IF VERTICAL TAB
16174: .FI
16175: BRN GTN36 ERROR IF NON-BLANK
16176: *
16177: GTNC0 LCH WB,(XR)+ GET NEXT CHARACTER
16178: BCT WA,GTN20 LOOP BACK TILL ALL BLANKS SCANNED
16179: *
16180: * MERGE HERE AFTER COLLECTING EXPONENT
16181: *
16182: GTN21 STI GTNEX SAVE COLLECTED EXPONENT
16183: BNZ GTNES,GTN22 JUMP IF IT WAS NEGATIVE
16184: NGI ELSE COMPLEMENT
16185: IOV GTN36 ERROR IF OVERFLOW
16186: STI GTNEX AND STORE POSITIVE EXPONENT
16187: *
16188: * MERGE HERE WITH EXPONENT (0 IF NONE GIVEN)
16189: *
16190: GTN22 BZE GTNRD,GTN36 ERROR IF NOT DIGITS COLLECTED
16191: BZE GTNDF,GTN36 ERROR IF NO EXPONENT OR DEC POINT
16192: MTI GTNSC ELSE LOAD SCALE AS INTEGER
16193: SBI GTNEX SUBTRACT EXPONENT
16194: IOV GTN36 ERROR IF OVERFLOW
16195: ILT GTN26 JUMP IF WE MUST SCALE UP
16196: *
16197: * HERE WE HAVE A NEGATIVE EXPONENT, SO SCALE DOWN
16198: *
16199: MFI WA,GTN36 LOAD SCALE FACTOR, ERR IF OVFLOW
16200: *
16201: * LOOP TO SCALE DOWN IN STEPS OF 10**10
16202: *
16203: GTN23 BLE WA,=NUM10,GTN24 JUMP IF 10 OR LESS TO GO
16204: DVR REATT ELSE DIVIDE BY 10**10
16205: SUB =NUM10,WA DECREMENT SCALE
16206: BRN GTN23 AND LOOP BACK
16207: EJC
16208: *
16209: * GTNUM (CONTINUED)
16210: *
16211: * HERE SCALE REST OF WAY FROM POWERS OF TEN TABLE
16212: *
16213: GTN24 BZE WA,GTN30 JUMP IF SCALED
16214: LCT WB,=CFP$R ELSE GET INDEXING FACTOR
16215: MOV =REAV1,XR POINT TO POWERS OF TEN TABLE
16216: WTB WA CONVERT REMAINING SCALE TO BAU OFS
16217: *
16218: * LOOP TO POINT TO POWERS OF TEN TABLE ENTRY
16219: *
16220: GTN25 ADD WA,XR BUMP POINTER
16221: BCT WB,GTN25 ONCE FOR EACH VALUE WORD
16222: DVR (XR) SCALE DOWN AS REQUIRED
16223: BRN GTN30 AND JUMP
16224: *
16225: * COME HERE TO SCALE RESULT UP (POSITIVE EXPONENT)
16226: *
16227: GTN26 NGI GET ABSOLUTE VALUE OF EXPONENT
16228: IOV GTN36 ERROR IF OVERFLOW
16229: MFI WA,GTN36 ACQUIRE SCALE, ERROR IF OVFLOW
16230: *
16231: * LOOP TO SCALE UP IN STEPS OF 10**10
16232: *
16233: GTN27 BLE WA,=NUM10,GTN28 JUMP IF 10 OR LESS TO GO
16234: MLR REATT ELSE MULTIPLY BY 10**10
16235: ROV GTN36 ERROR IF OVERFLOW
16236: SUB =NUM10,WA ELSE DECREMENT SCALE
16237: BRN GTN27 AND LOOP BACK
16238: *
16239: * HERE TO SCALE UP REST OF WAY WITH TABLE
16240: *
16241: GTN28 BZE WA,GTN30 JUMP IF SCALED
16242: LCT WB,=CFP$R ELSE GET INDEXING FACTOR
16243: MOV =REAV1,XR POINT TO POWERS OF TEN TABLE
16244: WTB WA CONVERT REMAINING SCALE TO BAU OFS
16245: *
16246: * LOOP TO POINT TO PROPER ENTRY IN POWERS OF TEN TABLE
16247: *
16248: GTN29 ADD WA,XR BUMP POINTER
16249: BCT WB,GTN29 ONCE FOR EACH WORD IN VALUE
16250: MLR (XR) SCALE UP
16251: ROV GTN36 ERROR IF OVERFLOW
16252: EJC
16253: *
16254: * GTNUM (CONTINUED)
16255: *
16256: * HERE WITH REAL VALUE SCALED AND READY EXCEPT FOR SIGN
16257: *
16258: GTN30 BZE GTNNF,GTN31 JUMP IF POSITIVE
16259: NGR ELSE NEGATE
16260: *
16261: * HERE WITH PROPERLY SIGNED REAL VALUE IN (RA)
16262: *
16263: GTN31 JSR RCBLD BUILD REAL BLOCK
16264: BRN GTN33 MERGE TO EXIT
16265: .FI
16266: *
16267: * HERE WITH PROPERLY SIGNED INTEGER VALUE IN (IA)
16268: *
16269: GTN32 JSR ICBLD BUILD ICBLK
16270: *
16271: * REAL MERGES HERE
16272: *
16273: GTN33 MOV (XR),WA LOAD FIRST WORD OF RESULT BLOCK
16274: ICA XS POP ARGUMENT OFF STACK
16275: *
16276: * COMMON EXIT POINT
16277: *
16278: GTN34 LDI GTNSV RECOVER IA
16279: GTN3A EXI RETURN TO GTNUM CALLER
16280: .IF .CNRA
16281: .ELSE
16282: *
16283: * COME HERE IF OVERFLOW OCCURS DURING COLLECTION OF INTEGER
16284: *
16285: GTN35 LDI GTNSI RELOAD INTEGER SO FAR
16286: ITR CONVERT TO REAL
16287: NGR MAKE VALUE POSITIVE
16288: BRN GTN11 MERGE WITH REAL CIRCUIT
16289: .FI
16290: *
16291: * HERE FOR UNCONVERTIBLE TO STRING OR CONVERSION ERROR
16292: *
16293: GTN36 MOV (XS)+,XR RELOAD ORIGINAL ARGUMENT
16294: LDI GTNSV RECOVER IA
16295: EXI 1 TAKE CONVERT-ERROR EXIT
16296: ENP END PROCEDURE GTNUM
16297: EJC
16298: *
16299: * GTNVR -- CONVERT TO NATURAL VARIABLE
16300: *
16301: * GTNVR LOCATES A VARIABLE BLOCK (VRBLK) GIVEN EITHER AN
16302: * APPROPRIATE NAME (NMBLK) OR A NON-NULL STRING (SCBLK).
16303: *
16304: * (XR) ARGUMENT
16305: * JSR GTNVR CALL TO CONVERT TO NATURAL VARIABLE
16306: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
16307: * (XR) POINTER TO VRBLK
16308: * (WC) DESTROYED
16309: *
16310: GTNVR PRC E,1 ENTRY POINT
16311: BNE (XR),=B$NML,GNV02 JUMP IF NOT NAME
16312: MOV NMBAS(XR),XR ELSE LOAD NAME BASE IF NAME
16313: BLO XR,STATE,GNV07 SKIP IF VRBLK (IN STATIC REGION)
16314: BRN GNV01 FAIL
16315: *
16316: * RESTORE REGS AND FAIL
16317: *
16318: GNV00 MOV GNVSA,WA RESTORE REGS
16319: MOV GNVSB,WB
16320: *
16321: * COMMON ERROR EXIT
16322: *
16323: GNV01 EXI 1 TAKE CONVERT-ERROR EXIT
16324: *
16325: * HERE IF NOT NAME
16326: *
16327: GNV02 MOV WA,GNVSA SAVE WA
16328: MOV WB,GNVSB SAVE WB
16329: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG
16330: JSR GTSTG CONVERT ARGUMENT TO STRING
16331: PPM GNV00 JUMP IF CONVERSION ERROR
16332: BZE WA,GNV00 NULL STRING IS AN ERROR
16333: MOV XL,-(XS) SAVE XL
16334: .IF .CASL
16335: MOV XR,XL COPY STRING POINTER
16336: ZER WB ZERO OFFSET
16337: JSR SBSTG CONVERT TO PREFERRED CASE
16338: MOV SCLEN(XR),WA RECOVER STRING LENGTH
16339: .FI
16340: MOV XR,-(XS) STACK STRING PTR FOR LATER
16341: MOV XR,WB COPY STRING POINTER
16342: ADD *SCHAR,WB POINT TO CHARACTERS OF STRING
16343: MOV WB,GNVST SAVE POINTER TO CHARACTERS
16344: MOV WA,WB COPY LENGTH
16345: CTW WB,0 GET NUMBER OF WORDS IN NAME
16346: MOV WB,GNVNW SAVE FOR LATER
16347: JSR HASHS COMPUTE HASH INDEX FOR STRING
16348: RMI HSHNB COMPUTE HASH OFFSET BY TAKING MOD
16349: MFI WC GET AS OFFSET
16350: WTB WC CONVERT OFFSET TO BAUS
16351: ADD HSHTB,WC POINT TO PROPER HASH CHAIN
16352: SUB *VRNXT,WC SUBTRACT OFFSET TO MERGE INTO LOOP
16353: EJC
16354: *
16355: * GTNVR (CONTINUED)
16356: *
16357: * LOOP TO SEARCH HASH CHAIN
16358: *
16359: GNV03 MOV WC,XL COPY HASH CHAIN POINTER
16360: MOV VRNXT(XL),XL POINT TO NEXT VRBLK ON CHAIN
16361: BZE XL,GNV08 JUMP IF END OF CHAIN
16362: MOV XL,WC SAVE POINTER TO THIS VRBLK
16363: BNZ VRLEN(XL),GNV04 JUMP IF NOT SYSTEM VARIABLE
16364: MOV VRSVP(XL),XL ELSE POINT TO SVBLK
16365: SUB *VRSOF,XL ADJUST OFFSET FOR MERGE
16366: *
16367: * MERGE HERE WITH STRING PTR (LIKE VRBLK) IN XL
16368: *
16369: GNV04 BNE WA,VRLEN(XL),GNV03 BACK FOR NEXT VRBLK IF LENGTHS NE
16370: ADD *VRCHS,XL ELSE POINT TO CHARS OF CHAIN ENTRY
16371: LCT WB,GNVNW GET WORD COUNTER TO CONTROL LOOP
16372: MOV GNVST,XR POINT TO CHARS OF NEW NAME
16373: *
16374: * LOOP TO COMPARE CHARACTERS OF THE TWO NAMES
16375: *
16376: GNV05 CNE (XR),(XL),GNV03 JUMP IF NO MATCH FOR NEXT VRBLK
16377: ICA XR BUMP NEW NAME POINTER
16378: ICA XL BUMP VRBLK IN CHAIN NAME POINTER
16379: BCT WB,GNV05 ELSE LOOP TILL ALL COMPARED
16380: MOV WC,XR WE HAVE FOUND A MATCH, GET VRBLK
16381: *
16382: * EXIT POINT AFTER FINDING VRBLK OR BUILDING NEW ONE
16383: *
16384: GNV06 MOV GNVSA,WA RESTORE WA
16385: MOV GNVSB,WB RESTORE WB
16386: ICA XS POP STRING POINTER
16387: MOV (XS)+,XL RESTORE XL
16388: *
16389: * COMMON EXIT POINT
16390: *
16391: GNV07 EXI RETURN TO GTNVR CALLER
16392: *
16393: * NOT FOUND, PREPARE TO SEARCH SYSTEM VARIABLE TABLE
16394: *
16395: GNV08 ZER XR CLEAR GARBAGE XR POINTER
16396: MOV WC,GNVHE SAVE PTR TO END OF HASH CHAIN
16397: BGT WA,=NUM09,GNV14 CANNOT BE SYSTEM VAR IF LENGTH GT 9
16398: MOV WA,XL ELSE COPY LENGTH
16399: WTB XL CONVERT TO BAU OFFSET
16400: MOV VSRCH(XL),XL POINT TO FIRST SVBLK OF THIS LENGTH
16401: EJC
16402: *
16403: * GTNVR (CONTINUED)
16404: *
16405: * LOOP TO SEARCH ENTRIES IN STANDARD VARIABLE TABLE
16406: *
16407: GNV09 MOV XL,GNVSP SAVE TABLE POINTER
16408: MOV (XL)+,WC LOAD SVBIT BIT STRING
16409: MOV (XL)+,WB LOAD LENGTH FROM TABLE ENTRY
16410: BNE WA,WB,GNV14 JUMP IF END OF RIGHT LENGTH ENTIRES
16411: LCT WB,GNVNW GET WORD COUNTER TO CONTROL LOOP
16412: MOV GNVST,XR POINT TO CHARS OF NEW NAME
16413: *
16414: * LOOP TO CHECK FOR MATCHING NAMES
16415: *
16416: GNV10 CNE (XR),(XL),GNV11 JUMP IF NAME MISMATCH
16417: ICA XR ELSE BUMP NEW NAME POINTER
16418: ICA XL BUMP SVBLK POINTER
16419: BCT WB,GNV10 ELSE LOOP UNTIL ALL CHECKED
16420: *
16421: * HERE WE HAVE A MATCH IN THE STANDARD VARIABLE TABLE
16422: *
16423: ZER WC SET VRLEN VALUE ZERO
16424: MOV *VRSI$,WA SET STANDARD SIZE
16425: BRN GNV15 JUMP TO BUILD VRBLK
16426: *
16427: * HERE IF NO MATCH WITH TABLE ENTRY IN SVBLKS TABLE
16428: *
16429: GNV11 ICA XL BUMP PAST WORD OF CHARS
16430: BCT WB,GNV11 LOOP BACK IF MORE TO GO
16431: RSH WC,SVNBT REMOVE UNINTERESTING BITS
16432: *
16433: * LOOP TO BUMP TABLE PTR FOR EACH FLAGGED WORD
16434: *
16435: GNV12 MOV BITS1,WB LOAD BIT TO TEST
16436: ANB WC,WB TEST FOR WORD PRESENT
16437: ZRB WB,GNV13 JUMP IF NOT PRESENT
16438: ICA XL ELSE BUMP TABLE POINTER
16439: *
16440: * HERE AFTER DEALING WITH ONE WORD (ONE BIT)
16441: *
16442: GNV13 RSH WC,1 REMOVE BIT ALREADY PROCESSED
16443: NZB WC,GNV12 LOOP BACK IF MORE BITS TO TEST
16444: BRN GNV09 ELSE LOOP BACK FOR NEXT SVBLK
16445: *
16446: * HERE IF NOT SYSTEM VARIABLE
16447: *
16448: GNV14 MOV WA,WC COPY VRLEN VALUE
16449: MOV =VRCHS,WA LOAD STANDARD SIZE -CHARS
16450: ADD GNVNW,WA ADJUST FOR CHARS OF NAME
16451: WTB WA CONVERT LENGTH TO BAUS
16452: EJC
16453: *
16454: * GTNVR (CONTINUED)
16455: *
16456: * MERGE HERE TO BUILD VRBLK
16457: *
16458: GNV15 JSR ALOST ALLOCATE SPACE FOR VRBLK (STATIC)
16459: MOV XR,WB SAVE VRBLK POINTER
16460: MOV =STNVR,XL POINT TO MODEL VARIABLE BLOCK
16461: MOV *VRLEN,WA SET LENGTH OF STANDARD FIELDS
16462: MVW SET INITIAL FIELDS OF NEW BLOCK
16463: MOV GNVHE,XL LOAD POINTER TO END OF HASH CHAIN
16464: MOV WB,VRNXT(XL) ADD NEW BLOCK TO END OF CHAIN
16465: MOV WC,(XR)+ SET VRLEN FIELD, BUMP PTR
16466: MOV GNVNW,WA GET LENGTH IN WORDS
16467: WTB WA CONVERT TO LENGTH IN BAUS
16468: BZE WC,GNV16 JUMP IF SYSTEM VARIABLE
16469: *
16470: * HERE FOR NON-SYSTEM VARIABLE -- SET CHARS OF NAME
16471: *
16472: MOV (XS),XL POINT BACK TO STRING NAME
16473: ADD *SCHAR,XL POINT TO CHARS OF NAME
16474: MVW MOVE CHARACTERS INTO PLACE
16475: MOV WB,XR RESTORE VRBLK POINTER
16476: BRN GNV06 JUMP BACK TO EXIT
16477: *
16478: * HERE FOR SYSTEM VARIABLE CASE TO FILL IN FIELDS WHERE
16479: * NECESSARY FROM THE FIELDS PRESENT IN THE SVBLK.
16480: *
16481: GNV16 MOV GNVSP,XL LOAD POINTER TO SVBLK
16482: MOV XL,(XR) SET SVBLK PTR IN VRBLK
16483: MOV WB,XR RESTORE VRBLK POINTER
16484: MOV SVBIT(XL),WB LOAD BIT INDICATORS
16485: ADD *SVCHS,XL POINT TO CHARACTERS OF NAME
16486: ADD WA,XL POINT PAST CHARACTERS
16487: *
16488: * SKIP PAST KEYWORD NUMBER (SVKNM) IF PRESENT
16489: *
16490: MOV BTKNM,WC LOAD TEST BIT
16491: ANB WB,WC AND TO TEST
16492: ZRB WC,GNV17 JUMP IF NO KEYWORD NUMBER
16493: ICA XL ELSE BUMP POINTER
16494: EJC
16495: *
16496: * GTNVR (CONTINUED)
16497: *
16498: * HERE TEST FOR FUNCTION (SVFNC AND SVNAR)
16499: *
16500: GNV17 MOV BTFNC,WC GET TEST BIT
16501: ANB WB,WC AND TO TEST
16502: ZRB WC,GNV18 SKIP IF NO SYSTEM FUNCTION
16503: MOV XL,VRFNC(XR) ELSE POINT VRFNC TO SVFNC FIELD
16504: ADD *NUM02,XL AND BUMP PAST SVFNC, SVNAR FIELDS
16505: *
16506: * NOW TEST FOR LABEL (SVLBL)
16507: *
16508: GNV18 MOV BTLBL,WC GET TEST BIT
16509: ANB WB,WC AND TO TEST
16510: ZRB WC,GNV19 JUMP IF BIT IS OFF (NO SYSTEM LABL)
16511: MOV XL,VRLBL(XR) ELSE POINT VRLBL TO SVLBL FIELD
16512: ICA XL BUMP PAST SVLBL FIELD
16513: *
16514: * NOW TEST FOR VALUE (SVVAL)
16515: *
16516: GNV19 MOV BTVAL,WC LOAD TEST BIT
16517: ANB WB,WC AND TO TEST
16518: ZRB WC,GNV06 ALL DONE IF NO VALUE
16519: MOV (XL),VRVAL(XR) ELSE SET INITIAL VALUE
16520: MOV =B$VRE,VRSTO(XR) SET ERROR STORE ACCESS
16521: BRN GNV06 MERGE BACK TO EXIT TO CALLER
16522: ENP END PROCEDURE GTNVR
16523: EJC
16524: *
16525: * GTPAT -- GET PATTERN
16526: *
16527: * GTPAT IS PASSED AN OBJECT IN (XR) AND RETURNS A
16528: * PATTERN AFTER PERFORMING ANY NECESSARY CONVERSIONS
16529: *
16530: * (XR) INPUT ARGUMENT
16531: * JSR GTPAT CALL TO CONVERT TO PATTERN
16532: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
16533: * (XR) RESULTING PATTERN
16534: * (WA) DESTROYED
16535: * (WB) DESTROYED (ONLY ON CONVERT ERROR)
16536: * (XR) UNCHANGED (ONLY ON CONVERT ERROR)
16537: *
16538: GTPAT PRC E,1 ENTRY POINT
16539: BHI (XR),=P$AAA,GTPT5 JUMP IF PATTERN ALREADY
16540: *
16541: * HERE IF NOT PATTERN, TRY FOR STRING
16542: *
16543: MOV WB,GTPSB SAVE WB
16544: MOV XR,-(XS) STACK ARGUMENT FOR GTSTG
16545: JSR GTSTG CONVERT ARGUMENT TO STRING
16546: PPM GTPT2 JUMP IF IMPOSSIBLE
16547: *
16548: * HERE WE HAVE A STRING
16549: *
16550: BNZ WA,GTPT1 JUMP IF NON-NULL
16551: *
16552: * HERE FOR NULL STRING. GENERATE POINTER TO NULL PATTERN.
16553: *
16554: MOV =NDNTH,XR POINT TO NOTHEN NODE
16555: BRN GTPT4 JUMP TO EXIT
16556: EJC
16557: *
16558: * GTPAT (CONTINUED)
16559: *
16560: * HERE FOR NON-NULL STRING
16561: *
16562: GTPT1 MOV =P$STR,WB LOAD PCODE FOR MULTI-CHAR STRING
16563: BNE WA,=NUM01,GTPT3 JUMP IF MULTI-CHAR STRING
16564: *
16565: * HERE FOR ONE CHARACTER STRING, SHARE ONE CHARACTER ANY
16566: *
16567: PLC XR POINT TO CHARACTER
16568: LCH WA,(XR) LOAD CHARACTER
16569: MOV WA,XR SET AS PARM1
16570: MOV =P$ANS,WB POINT TO PCODE FOR 1-CHAR ANY
16571: BRN GTPT3 JUMP TO BUILD NODE
16572: *
16573: * HERE IF ARGUMENT IS NOT CONVERTIBLE TO STRING
16574: *
16575: GTPT2 MOV =P$EXA,WB SET PCODE FOR EXPRESSION IN CASE
16576: BLO (XR),=B$E$$,GTPT3 JUMP TO BUILD NODE IF EXPRESSION
16577: *
16578: * HERE WE HAVE AN ERROR (CONVERSION IMPOSSIBLE)
16579: *
16580: EXI 1 TAKE CONVERT ERROR EXIT
16581: *
16582: * MERGE HERE TO BUILD NODE FOR STRING OR EXPRESSION
16583: *
16584: GTPT3 JSR PBILD CALL ROUTINE TO BUILD PATTERN NODE
16585: *
16586: * COMMON EXIT AFTER SUCCESSFUL CONVERSION
16587: *
16588: GTPT4 MOV GTPSB,WB RESTORE WB
16589: *
16590: * MERGE HERE TO EXIT IF NO CONVERSION REQUIRED
16591: *
16592: GTPT5 EXI RETURN TO GTPAT CALLER
16593: ENP END PROCEDURE GTPAT
16594: .IF .CNRA
16595: .ELSE
16596: EJC
16597: *
16598: * GTREA -- GET REAL VALUE
16599: *
16600: * GTREA IS PASSED AN OBJECT AND RETURNS A REAL VALUE
16601: * PERFORMING ANY NECESSARY CONVERSIONS.
16602: *
16603: * (XR) OBJECT TO BE CONVERTED
16604: * JSR GTREA CALL TO CONVERT OBJECT TO REAL
16605: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
16606: * (XR) POINTER TO RESULTING REAL
16607: * (WA,WB,WC,RA) DESTROYED
16608: * (XR) UNCHANGED (CONVERT ERROR ONLY)
16609: *
16610: GTREA PRC E,1 ENTRY POINT
16611: MOV (XR),WA GET FIRST WORD OF BLOCK
16612: BEQ WA,=B$RCL,GTRE2 JUMP IF REAL
16613: JSR GTNUM ELSE CONVERT ARGUMENT TO NUMERIC
16614: PPM GTRE3 JUMP IF UNCONVERTIBLE
16615: BEQ WA,=B$RCL,GTRE2 JUMP IF REAL WAS RETURNED
16616: *
16617: * HERE FOR CASE OF AN INTEGER TO CONVERT TO REAL
16618: *
16619: GTRE1 LDI ICVAL(XR) LOAD INTEGER
16620: ITR CONVERT TO REAL
16621: JSR RCBLD BUILD RCBLK
16622: *
16623: * EXIT WITH REAL
16624: *
16625: GTRE2 EXI RETURN TO GTREA CALLER
16626: *
16627: * HERE ON CONVERSION ERROR
16628: *
16629: GTRE3 EXI 1 TAKE CONVERT ERROR EXIT
16630: ENP END PROCEDURE GTREA
16631: .FI
16632: EJC
16633: *
16634: * GTSMI -- GET SMALL INTEGER
16635: *
16636: * GTSMI IS PASSED A SNOBOL OBJECT AND RETURNS AN ADDRESS
16637: * INTEGER IN THE RANGE (0 LE N LE DNAMB). SUCH A VALUE CAN
16638: * ONLY BE DERIVED FROM AN INTEGER IN THE APPROPRIATE RANGE.
16639: * SMALL INTEGERS NEVER APPEAR AS SNOBOL VALUES. HOWEVER,
16640: * THEY ARE USED INTERNALLY FOR A VARIETY OF PURPOSES.
16641: *
16642: * -(XS) ARGUMENT TO CONVERT (ON STACK)
16643: * JSR GTSMI CALL TO CONVERT TO SMALL INTEGER
16644: * PPM LOC TRANSFER LOC FOR NOT INTEGER
16645: * PPM LOC TRANSFER LOC FOR LT 0, GT DNAMB
16646: * (XR,WC) RESULTING SMALL INT (TWO COPIES)
16647: * (XS) POPPED
16648: * (RA) DESTROYED
16649: * (WA,WB) DESTROYED (ON CONVERT ERROR ONLY)
16650: * (XR) INPUT ARG (CONVERT ERROR ONLY)
16651: *
16652: GTSMI PRC N,2 ENTRY POINT
16653: MOV (XS)+,XR LOAD ARGUMENT
16654: BEQ (XR),=B$ICL,GTSM1 SKIP IF ALREADY AN INTEGER
16655: *
16656: * HERE IF NOT AN INTEGER
16657: *
16658: JSR GTINT CONVERT ARGUMENT TO INTEGER
16659: PPM GTSM2 JUMP IF CONVERT IS IMPOSSIBLE
16660: *
16661: * MERGE HERE WITH INTEGER
16662: *
16663: GTSM1 LDI ICVAL(XR) LOAD INTEGER VALUE
16664: MFI WC,GTSM3 MOVE AS ONE WORD, JUMP IF OVFLOW
16665: BGT WC,MXLEN,GTSM3 OR IF TOO LARGE
16666: MOV WC,XR COPY RESULT TO XR
16667: EXI RETURN TO GTSMI CALLER
16668: *
16669: * HERE IF UNCONVERTIBLE TO INTEGER
16670: *
16671: GTSM2 EXI 1 TAKE NON-INTEGER ERROR EXIT
16672: *
16673: * HERE IF OUT OF RANGE
16674: *
16675: GTSM3 EXI 2 TAKE OUT-OF-RANGE ERROR EXIT
16676: ENP END PROCEDURE GTSMI
16677: EJC
16678: *
16679: * GTSTG -- GET STRING
16680: *
16681: * GTSTG IS PASSED AN OBJECT AND RETURNS A STRING WITH
16682: * ANY NECESSARY CONVERSIONS PERFORMED.
16683: *
16684: * -(XS) INPUT ARGUMENT (ON STACK)
16685: * JSR GTSTG CALL TO CONVERT TO STRING
16686: * PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
16687: * (XR) POINTER TO RESULTING STRING
16688: * (WA) LENGTH OF STRING IN CHARACTERS
16689: * (XS) POPPED
16690: * (RA) DESTROYED
16691: * (XR) INPUT ARG (CONVERT ERROR ONLY)
16692: *
16693: GTSTG PRC N,1 ENTRY POINT
16694: MOV (XS)+,XR LOAD ARGUMENT, POP STACK
16695: BEQ (XR),=B$SCL,GTS30 JUMP IF ALREADY A STRING
16696: *
16697: * HERE IF NOT A STRING ALREADY
16698: *
16699: GTS01 MOV XR,-(XS) RESTACK ARGUMENT IN CASE ERROR
16700: MOV XL,-(XS) SAVE XL
16701: MOV WB,GTSVB SAVE WB
16702: MOV WC,GTSVC SAVE WC
16703: MOV (XR),WA LOAD FIRST WORD OF BLOCK
16704: BEQ WA,=B$ICL,GTS05 JUMP TO CONVERT INTEGER
16705: .IF .CNRA
16706: .ELSE
16707: BEQ WA,=B$RCL,GTS10 JUMP TO CONVERT REAL
16708: .FI
16709: BEQ WA,=B$NML,GTS03 JUMP TO CONVERT NAME
16710: .IF .CNBF
16711: .ELSE
16712: BEQ WA,=B$BCT,GTS32 JUMP TO CONVERT BUFFER
16713: .FI
16714: *
16715: * HERE ON CONVERSION ERROR
16716: *
16717: GTS02 MOV (XS)+,XL RESTORE XL
16718: MOV (XS)+,XR RELOAD INPUT ARGUMENT
16719: EXI 1 TAKE CONVERT ERROR EXIT
16720: EJC
16721: *
16722: * GTSTG (CONTINUED)
16723: *
16724: * HERE TO CONVERT A NAME (ONLY POSSIBLE IF NATURAL VAR)
16725: *
16726: GTS03 MOV NMBAS(XR),XL LOAD NAME BASE
16727: BHI XL,STATE,GTS02 ERROR IF NOT NATURAL VAR (STATIC)
16728: ADD *VRSOF,XL ELSE POINT TO POSSIBLE STRING NAME
16729: MOV SCLEN(XL),WA LOAD LENGTH
16730: BNZ WA,GTS04 JUMP IF NOT SYSTEM VARIABLE
16731: MOV VRSVO(XL),XL ELSE POINT TO SVBLK
16732: MOV SVLEN(XL),WA AND LOAD NAME LENGTH
16733: *
16734: * MERGE HERE WITH STRING IN XR, LENGTH IN WA
16735: *
16736: GTS04 ZER WB SET OFFSET TO ZERO
16737: JSR SBSTR USE SBSTR TO COPY STRING
16738: BRN GTS29 JUMP TO EXIT
16739: *
16740: * COME HERE TO CONVERT AN INTEGER
16741: *
16742: GTS05 LDI ICVAL(XR) LOAD INTEGER VALUE
16743: .IF .CSCI
16744: JSR SYSCI CONVERT INTEGER
16745: MOV SCLEN(XL),WA GET LENGTH
16746: ZER WB ZERO OFFSET FOR SBSTR
16747: JSR SBSTR COPY IN RESULT FROM SYSCI
16748: BRN GTS29 EXIT
16749: .ELSE
16750: MOV =NUM01,GTSSF SET SIGN FLAG NEGATIVE
16751: ILT GTS06 SKIP IF INTEGER IS NEGATIVE
16752: NGI ELSE NEGATE INTEGER
16753: ZER GTSSF AND RESET NEGATIVE FLAG
16754: EJC
16755: *
16756: * GTSTG (CONTINUED)
16757: *
16758: * HERE WITH SIGN FLAG SET AND SIGN FORCED NEGATIVE AS
16759: * REQUIRED BY THE CVD INSTRUCTION.
16760: *
16761: GTS06 MOV GTSWK,XR POINT TO RESULT WORK AREA
16762: MOV =NSTMX,WB INITIALIZE COUNTER TO MAX LENGTH
16763: PSC XR,WB PREPARE TO STORE (RIGHT-LEFT)
16764: *
16765: * LOOP TO CONVERT DIGITS INTO WORK AREA
16766: *
16767: GTS07 CVD CONVERT ONE DIGIT INTO WA
16768: SCH WA,-(XR) STORE IN WORK AREA
16769: DCV WB DECREMENT COUNTER
16770: INE GTS07 LOOP IF MORE DIGITS TO GO
16771: CSC XR COMPLETE STORE CHARACTERS
16772: *
16773: * MERGE HERE AFTER CONVERTING INTEGER OR REAL INTO WORK
16774: * AREA. WB IS SET TO NSTMX - (NUMBER OF CHARS IN RESULT).
16775: *
16776: GTS08 MOV =NSTMX,WA GET MAX NUMBER OF CHARACTERS
16777: SUB WB,WA COMPUTE LENGTH OF RESULT
16778: MOV WA,XL REMEMBER LENGTH FOR MOVE LATER ON
16779: ADD GTSSF,WA ADD ONE FOR NEGATIVE SIGN IF NEEDED
16780: JSR ALOCS ALLOCATE STRING FOR RESULT
16781: MOV XR,WC SAVE RESULT POINTER FOR THE MOMENT
16782: PSC XR POINT TO CHARS OF RESULT BLOCK
16783: BZE GTSSF,GTS09 SKIP IF POSITIVE
16784: MOV =CH$MN,WA ELSE LOAD NEGATIVE SIGN
16785: SCH WA,(XR)+ AND STORE IT
16786: CSC XR COMPLETE STORE CHARACTERS
16787: .FI
16788: *
16789: * HERE AFTER DEALING WITH SIGN
16790: *
16791: GTS09 MOV XL,WA RECALL LENGTH TO MOVE
16792: MOV GTSWK,XL POINT TO RESULT WORK AREA
16793: PLC XL,WB POINT TO FIRST RESULT CHARACTER
16794: MVC MOVE CHARS TO RESULT STRING
16795: MOV WC,XR RESTORE RESULT POINTER
16796: .IF .CNRA
16797: .ELSE
16798: BRN GTS29 JUMP TO EXIT
16799: EJC
16800: *
16801: * GTSTG (CONTINUED)
16802: *
16803: * HERE TO CONVERT A REAL
16804: *
16805: GTS10 LDR RCVAL(XR) LOAD REAL
16806: ZER GTSSF RESET NEGATIVE FLAG
16807: REQ GTS31 SKIP IF ZERO
16808: RGE GTS11 JUMP IF REAL IS POSITIVE
16809: MOV =NUM01,GTSSF ELSE SET NEGATIVE FLAG
16810: NGR AND GET ABSOLUTE VALUE OF REAL
16811: *
16812: * NOW SCALE THE REAL TO THE RANGE (0.1 LE X LT 1.0)
16813: *
16814: GTS11 LDI INTV0 INITIALIZE EXPONENT TO ZERO
16815: *
16816: * LOOP TO SCALE UP IN STEPS OF 10**10
16817: *
16818: GTS12 STR GTSRS SAVE REAL VALUE
16819: SBR REAP1 SUBTRACT 0.1 TO COMPARE
16820: RGE GTS13 JUMP IF SCALE UP NOT REQUIRED
16821: LDR GTSRS ELSE RELOAD VALUE
16822: MLR REATT MULTIPLY BY 10**10
16823: SBI INTVT DECREMENT EXPONENT BY 10
16824: BRN GTS12 LOOP BACK TO TEST AGAIN
16825: *
16826: * TEST FOR SCALE DOWN REQUIRED
16827: *
16828: GTS13 LDR GTSRS RELOAD VALUE
16829: SBR REAV1 SUBTRACT 1.0
16830: RLT GTS17 JUMP IF NO SCALE DOWN REQUIRED
16831: LDR GTSRS ELSE RELOAD VALUE
16832: *
16833: * LOOP TO SCALE DOWN IN STEPS OF 10**10
16834: *
16835: GTS14 SBR REATT SUBTRACT 10**10 TO COMPARE
16836: RLT GTS15 JUMP IF LARGE STEP NOT REQUIRED
16837: LDR GTSRS ELSE RESTORE VALUE
16838: DVR REATT DIVIDE BY 10**10
16839: STR GTSRS STORE NEW VALUE
16840: ADI INTVT INCREMENT EXPONENT BY 10
16841: BRN GTS14 LOOP BACK
16842: EJC
16843: *
16844: * GTSTG (CONTINUED)
16845: *
16846: * AT THIS POINT WE HAVE (1.0 LE X LT 10**10)
16847: * COMPLETE SCALING WITH POWERS OF TEN TABLE
16848: *
16849: GTS15 MOV =REAV1,XR POINT TO POWERS OF TEN TABLE
16850: *
16851: * LOOP TO LOCATE CORRECT ENTRY IN TABLE
16852: *
16853: GTS16 LDR GTSRS RELOAD VALUE
16854: ADI INTV1 INCREMENT EXPONENT
16855: ADD *CFP$R,XR POINT TO NEXT ENTRY IN TABLE
16856: SBR (XR) SUBTRACT IT TO COMPARE
16857: RGE GTS16 LOOP TILL WE FIND A LARGER ENTRY
16858: LDR GTSRS THEN RELOAD THE VALUE
16859: DVR (XR) AND COMPLETE SCALING
16860: STR GTSRS STORE VALUE
16861: *
16862: * WE ARE NOW SCALED, SO ROUND BY ADDING 0.5 * 10**(-CFP$S)
16863: *
16864: GTS17 LDR GTSRS GET VALUE AGAIN
16865: ADR GTSRN ADD ROUNDING FACTOR
16866: STR GTSRS STORE RESULT
16867: *
16868: * THE ROUNDING OPERATION MAY HAVE PUSHED US UP PAST
16869: * 1.0 AGAIN, SO CHECK ONE MORE TIME.
16870: *
16871: SBR REAV1 SUBTRACT 1.0 TO COMPARE
16872: RLT GTS18 SKIP IF OK
16873: ADI INTV1 ELSE INCREMENT EXPONENT
16874: LDR GTSRS RELOAD VALUE
16875: DVR REAVT DIVIDE BY 10.0 TO RESCALE
16876: BRN GTS19 JUMP TO MERGE
16877: *
16878: * HERE IF ROUNDING DID NOT MUCK UP SCALING
16879: *
16880: GTS18 LDR GTSRS RELOAD ROUNDED VALUE
16881: EJC
16882: *
16883: * GTSTG (CONTINUED)
16884: *
16885: * NOW WE HAVE COMPLETED THE SCALING AS FOLLOWS
16886: *
16887: * (IA) SIGNED EXPONENT
16888: * (RA) SCALED REAL (ABSOLUTE VALUE)
16889: *
16890: * IF THE EXPONENT IS NEGATIVE OR GREATER THAN CFP$S, THEN
16891: * WE CONVERT THE NUMBER IN THE FORM.
16892: *
16893: * (NEG SIGN) 0 . (CPF$S DIGITS) E (EXP SIGN) (EXP DIGITS)
16894: *
16895: * IF THE EXPONENT IS POSITIVE AND LESS THAN OR EQUAL TO
16896: * CFP$S, THE NUMBER IS CONVERTED IN THE FORM.
16897: *
16898: * (NEG SIGN) (EXPONENT DIGITS) . (CFP$S-EXPONENT DIGITS)
16899: *
16900: * IN BOTH CASES, THE FORMATS OBTAINED FROM THE ABOVE
16901: * RULES ARE MODIFIED BY DELETING TRAILING ZEROS AFTER THE
16902: * DECIMAL POINT. THERE ARE NO LEADING ZEROS IN THE EXPONENT
16903: * AND THE EXPONENT SIGN IS ALWAYS PRESENT.
16904: *
16905: GTS19 MOV =CFP$S,XL SET NUM DEC DIGITS = CFP$S
16906: MOV =CH$MN,GTSES SET EXPONENT SIGN NEGATIVE
16907: ILT GTS21 ALL SET IF EXPONENT IS NEGATIVE
16908: MFI WA ELSE FETCH EXPONENT
16909: BLE WA,=CFP$S,GTS20 SKIP IF WE CAN USE SPECIAL FORMAT
16910: MTI WA ELSE RESTORE EXPONENT
16911: NGI SET NEGATIVE FOR CVD
16912: MOV =CH$PL,GTSES SET PLUS SIGN FOR EXPONENT SIGN
16913: BRN GTS21 JUMP TO GENERATE EXPONENT
16914: *
16915: * HERE IF WE CAN USE THE FORMAT WITHOUT AN EXPONENT
16916: *
16917: GTS20 SUB WA,XL COMPUTE DIGITS AFTER DECIMAL POINT
16918: LDI INTV0 RESET EXPONENT TO ZERO
16919: EJC
16920: *
16921: * GTSTG (CONTINUED)
16922: *
16923: * MERGE HERE AS FOLLOWS
16924: *
16925: * (IA) EXPONENT ABSOLUTE VALUE
16926: * GTSES CHARACTER FOR EXPONENT SIGN
16927: * (RA) POSITIVE FRACTION
16928: * (XL) NUMBER OF DIGITS AFTER DEC POINT
16929: *
16930: GTS21 MOV GTSWK,XR POINT TO WORK AREA
16931: MOV =NSTMX,WB SET CHARACTER CTR TO MAX LENGTH
16932: PSC XR,WB PREPARE TO STORE (RIGHT TO LEFT)
16933: IEQ GTS23 SKIP EXPONENT IF IT IS ZERO
16934: *
16935: * LOOP TO GENERATE DIGITS OF EXPONENT
16936: *
16937: GTS22 CVD CONVERT A DIGIT INTO WA
16938: SCH WA,-(XR) STORE IN WORK AREA
16939: DCV WB DECREMENT COUNTER
16940: INE GTS22 LOOP BACK IF MORE DIGITS TO GO
16941: *
16942: * HERE GENERATE EXPONENT SIGN AND E
16943: *
16944: MOV GTSES,WA LOAD EXPONENT SIGN
16945: SCH WA,-(XR) STORE IN WORK AREA
16946: .IF .CPLC
16947: MOV =CH$$E,WA GET CHAR LETTER E
16948: .ELSE
16949: MOV =CH$LE,WA GET CHARACTER LETTER E
16950: .FI
16951: SCH WA,-(XR) STORE IN WORK AREA
16952: SUB =NUM02,WB DECREMENT COUNTER FOR SIGN AND E
16953: *
16954: * HERE TO GENERATE THE FRACTION
16955: *
16956: GTS23 MLR GTSSC CONVERT REAL TO INTEGER (10**CFP$S)
16957: RTI GET INTEGER (OVERFLOW IMPOSSIBLE)
16958: NGI NEGATE AS REQUIRED BY CVD
16959: *
16960: * LOOP TO SUPPRESS TRAILING ZEROS
16961: *
16962: GTS24 BZE XL,GTS27 JUMP IF NO DIGITS LEFT TO DO
16963: CVD ELSE CONVERT ONE DIGIT
16964: BNE WA,=CH$D0,GTS26 JUMP IF NOT A ZERO
16965: DCV XL DECREMENT COUNTER
16966: BRN GTS24 LOOP BACK FOR NEXT DIGIT
16967: EJC
16968: *
16969: * GTSTG (CONTINUED)
16970: *
16971: * LOOP TO GENERATE DIGITS AFTER DECIMAL POINT
16972: *
16973: GTS25 CVD CONVERT A DIGIT INTO WA
16974: *
16975: * MERGE HERE FIRST TIME
16976: *
16977: GTS26 SCH WA,-(XR) STORE DIGIT
16978: DCV WB DECREMENT COUNTER
16979: DCV XL DECREMENT COUNTER
16980: BNZ XL,GTS25 LOOP BACK IF MORE TO GO
16981: *
16982: * HERE GENERATE THE DECIMAL POINT
16983: *
16984: GTS27 MOV =CH$DT,WA LOAD DECIMAL POINT
16985: SCH WA,-(XR) STORE IN WORK AREA
16986: DCV WB DECREMENT COUNTER
16987: *
16988: * HERE GENERATE THE DIGITS BEFORE THE DECIMAL POINT
16989: *
16990: GTS28 CVD CONVERT A DIGIT INTO WA
16991: SCH WA,-(XR) STORE IN WORK AREA
16992: DCV WB DECREMENT COUNTER
16993: INE GTS28 LOOP BACK IF MORE TO GO
16994: CSC XR COMPLETE STORE CHARACTERS
16995: BRN GTS08 ELSE JUMP BACK TO EXIT
16996: .FI
16997: *
16998: * EXIT POINT AFTER SUCCESSFUL CONVERSION
16999: *
17000: GTS29 MOV (XS)+,XL RESTORE XL
17001: ICA XS POP ARGUMENT
17002: MOV GTSVB,WB RESTORE WB
17003: MOV GTSVC,WC RESTORE WC
17004: *
17005: * MERGE HERE IF NO CONVERSION REQUIRED
17006: *
17007: GTS30 MOV SCLEN(XR),WA LOAD STRING LENGTH
17008: EXI RETURN TO CALLER
17009: .IF .CNRA
17010: .ELSE
17011: *
17012: * HERE TO RETURN STRING FOR REAL ZERO
17013: *
17014: GTS31 MOV =SCRE0,XL POINT TO STRING
17015: MOV =NUM02,WA 2 CHARS
17016: ZER WB ZERO OFFSET
17017: JSR SBSTR COPY STRING
17018: BRN GTS29 RETURN
17019: .FI
17020: .IF .CNBF
17021: .ELSE
17022: EJC
17023: *
17024: * HERE TO CONVERT A BUFFER BLOCK
17025: *
17026: GTS32 MOV XR,XL COPY ARG PTR
17027: MOV BCLEN(XL),WA GET SIZE TO ALLOCATE
17028: BZE WA,GTS33 IF NULL THEN RETURN NULL
17029: JSR ALOCS ALLOCATE STRING FRAME
17030: MOV XR,WB SAVE STRING PTR
17031: MOV SCLEN(XR),WA GET LENGTH TO MOVE
17032: CTB WA,0 GET AS MULTIPLE OF WORD SIZE
17033: MOV BCBUF(XL),XL POINT TOBFBLK
17034: ADD *SCSI$,XR POINT TO START OF CHARACTER AREA
17035: ADD *BFSI$,XL POINT TO START OF BUFFER CHARS
17036: MVW COPY WORDS
17037: MOV WB,XR RESTORE SCBLK PTR
17038: BRN GTS29 EXIT WITH SCBLK
17039: *
17040: * HERE WHEN NULL BUFFER IS BEING CONVERTED
17041: *
17042: GTS33 MOV =NULLS,XR POINT TO NULL
17043: BRN GTS29 EXIT WITH NULL
17044: .FI
17045: ENP END PROCEDURE GTSTG
17046: EJC
17047: *
17048: * GTVAR -- GET VARIABLE FOR I/O/TRACE ASSOCIATION
17049: *
17050: * GTVAR IS USED TO POINT TO AN ACTUAL VARIABLE LOCATION
17051: * FOR THE DETACH,INPUT,OUTPUT,TRACE,STOPTR SYSTEM FUNCTIONS
17052: *
17053: * (XR) ARGUMENT TO FUNCTION
17054: * JSR GTVAR CALL TO LOCATE VARIABLE POINTER
17055: * PPM LOC TRANSFER LOC IF NOT OK VARIABLE
17056: * (XL,WA) NAME BASE,OFFSET OF VARIABLE
17057: * (XR,RA) DESTROYED
17058: * (WB,WC) DESTROYED (CONVERT ERROR ONLY)
17059: * (XR) INPUT ARG (CONVERT ERROR ONLY)
17060: *
17061: GTVAR PRC E,1 ENTRY POINT
17062: BNE (XR),=B$NML,GTVR2 JUMP IF NOT A NAME
17063: MOV NMOFS(XR),WA ELSE LOAD NAME OFFSET
17064: MOV NMBAS(XR),XL LOAD NAME BASE
17065: BEQ (XL),=B$EVT,GTVR1 ERROR IF EXPRESSION VARIABLE
17066: BNE (XL),=B$KVT,GTVR3 ALL OK IF NOT KEYWORD VARIABLE
17067: *
17068: * HERE ON CONVERSION ERROR
17069: *
17070: GTVR1 EXI 1 TAKE CONVERT ERROR EXIT
17071: *
17072: * HERE IF NOT A NAME, TRY CONVERT TO NATURAL VARIABLE
17073: *
17074: GTVR2 MOV WC,GTVRC SAVE WC
17075: JSR GTNVR LOCATE VRBLK IF POSSIBLE
17076: PPM GTVR1 JUMP IF CONVERT ERROR
17077: MOV XR,XL ELSE COPY VRBLK NAME BASE
17078: MOV *VRVAL,WA AND SET OFFSET
17079: MOV GTVRC,WC RESTORE WC
17080: *
17081: * HERE FOR NAME OBTAINED
17082: *
17083: GTVR3 BHI XL,STATE,GTVR4 ALL OK IF NOT NATURAL VARIABLE
17084: BEQ VRSTO(XL),=B$VRE,GTVR1 ERROR IF PROTECTED VARIABLE
17085: *
17086: * COMMON EXIT POINT
17087: *
17088: GTVR4 EXI RETURN TO CALLER
17089: ENP END PROCEDURE GTVAR
17090: EJC
17091: *
17092: * HASHS -- COMPUTE HASH INDEX FOR STRING
17093: *
17094: * HASHS REPRODUCIBLY MAPS A STRING TO AN INTEGER
17095: * VALUE. THE RESULTING HASH VALUE IS A POSITIVE INTEGER
17096: * IN THE RANGE 0 TO CFP$M
17097: *
17098: * (XR) STRING TO BE HASHED
17099: * JSR HASHS CALL TO HASH STRING
17100: * (IA) HASH VALUE
17101: * (XR,WB,WC) DESTROYED
17102: *
17103: * THE HASH FUNCTION USED IS AS FOLLOWS.
17104: *
17105: * START WITH THE LENGTH OF THE STRING
17106: *
17107: * TAKE THE FIRST E$HNW WORDS OF THE CHARACTERS FROM
17108: * THE STRING OR ALL THE WORDS IF FEWER THAN E$HNW.
17109: *
17110: * COMPUTE THE EXCLUSIVE OR OF ALL THESE WORDS TREATING
17111: * THEM AS ONE WORD BIT STRING VALUES.
17112: *
17113: * MOVE THE RESULT AS AN INTEGER WITH THE MTI INSTRUCTION.
17114: *
17115: HASHS PRC E,0 ENTRY POINT
17116: MOV SCLEN(XR),WC LOAD STRING LENGTH IN CHARACTERS
17117: MOV WC,WB INITIALIZE WITH LENGTH
17118: BZE WC,HSHS3 JUMP IF NULL STRING
17119: CTW WC,0 ELSE GET NUMBER OF WORDS OF CHARS
17120: ADD *SCHAR,XR POINT TO CHARACTERS OF STRING
17121: BLO WC,=E$HNW,HSHS1 USE WHOLE STRING IF SHORT
17122: MOV =E$HNW,WC ELSE SET TO INVOLVE FIRST E$HNW WDS
17123: *
17124: * HERE WITH COUNT OF WORDS TO CHECK IN WC
17125: *
17126: HSHS1 LCT WC,WC SET COUNTER TO CONTROL LOOP
17127: *
17128: * LOOP TO COMPUTE EXCLUSIVE OR
17129: *
17130: HSHS2 XOB (XR)+,WB EXCLUSIVE OR NEXT WORD OF CHARS
17131: BCT WC,HSHS2 LOOP TILL ALL PROCESSED
17132: *
17133: * MERGE HERE WITH EXCLUSIVE OR IN WB
17134: *
17135: HSHS3 ZGB WB ZEROISE UNDEFINED BITS
17136: ANB BITSM,WB ENSURE IN RANGE 0 TO CFP$M
17137: MTI WB MOVE RESULT AS INTEGER
17138: ZER XR CLEAR GARBAGE VALUE IN XR
17139: EXI RETURN TO HASHS CALLER
17140: ENP END PROCEDURE HASHS
17141: EJC
17142: *
17143: * ICBLD -- BUILD INTEGER BLOCK
17144: *
17145: * (IA) INTEGER VALUE FOR ICBLK
17146: * JSR ICBLD CALL TO BUILD INTEGER BLOCK
17147: * (XR) POINTER TO RESULT ICBLK
17148: * (WA) DESTROYED
17149: *
17150: ICBLD PRC E,0 ENTRY POINT
17151: ILT ICBL1 SKIP IF NEGATIVE
17152: SBI INTV2 REDUCE BY TWO
17153: ILE ICBL3 JUMP IF 0 , 1 OR 2
17154: ADI INTV2 RESTORE VALUE
17155: *
17156: * CONSTRUCT ICBLK
17157: *
17158: ICBL1 MOV DNAMP,XR LOAD POINTER TO NEXT AVAILABLE LOC
17159: ADD *ICSI$,XR POINT PAST NEW ICBLK
17160: BLO XR,DNAME,ICBL2 JUMP IF THERE IS ROOM
17161: MOV *ICSI$,WA ELSE LOAD LENGTH OF ICBLK
17162: JSR ALLOC USE STANDARD ALLOCATOR TO GET BLOCK
17163: ADD WA,XR POINT PAST BLOCK TO MERGE
17164: *
17165: * MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED
17166: *
17167: ICBL2 MOV XR,DNAMP SET NEW POINTER
17168: SUB *ICSI$,XR POINT BACK TO START OF BLOCK
17169: MOV =B$ICL,(XR) STORE TYPE WORD
17170: STI ICVAL(XR) STORE INTEGER VALUE IN ICBLK
17171: EXI RETURN TO ICBLD CALLER
17172: *
17173: * OPTIMISE BY NOT BUILDING ICBLKS FOR SMALL INTEGERS
17174: *
17175: ICBL3 ADI INTV2 RESTORE VALUE
17176: MFI XR CONVERT TO SHORT INTEGER
17177: WTB XR CONVERT INTEGER TO OFFSET
17178: MOV INTAB(XR),XR POINT TO PRE-BUILT ICBLK
17179: EXI RETURN
17180: ENP END PROCEDURE ICBLD
17181: EJC
17182: *
17183: * IDENT -- COMPARE TWO VALUES
17184: *
17185: * IDENT COMPARES TWO VALUES IN THE SENSE OF THE IDENT
17186: * DIFFER FUNCTIONS AVAILABLE AT THE SNOBOL LEVEL.
17187: *
17188: * (XR) FIRST ARGUMENT
17189: * (XL) SECOND ARGUMENT
17190: * JSR IDENT CALL TO COMPARE ARGUMENTS
17191: * PPM LOC TRANSFER LOC IF IDENT
17192: * (NORMAL RETURN IF DIFFER)
17193: * (XR,XL,WC,RA) DESTROYED
17194: *
17195: IDENT PRC E,1 ENTRY POINT
17196: BEQ XR,XL,IDEN7 JUMP IF SAME POINTER (IDENT)
17197: MOV (XR),WC ELSE LOAD ARG 1 TYPE WORD
17198: BNE WC,(XL),IDEN1 DIFFER IF ARG 2 TYPE WORD DIFFER
17199: BEQ WC,=B$SCL,IDEN2 JUMP IF STRINGS
17200: BEQ WC,=B$ICL,IDEN4 JUMP IF INTEGERS
17201: .IF .CNRA
17202: .ELSE
17203: BEQ WC,=B$RCL,IDEN5 JUMP IF REALS
17204: .FI
17205: BEQ WC,=B$NML,IDEN6 JUMP IF NAMES
17206: *
17207: * FOR ALL OTHER DATATYPES, MUST BE DIFFER IF XR NE XL
17208: *
17209: * MERGE HERE FOR DIFFER
17210: *
17211: IDEN1 EXI TAKE DIFFER EXIT
17212: *
17213: * HERE FOR STRINGS, IDENT ONLY IF LENGTHS AND CHARS SAME
17214: *
17215: IDEN2 MOV SCLEN(XR),WC LOAD ARG 1 LENGTH
17216: BNE WC,SCLEN(XL),IDEN1 DIFFER IF LENGTHS DIFFER
17217: CTW WC,0 GET NUMBER OF WORDS IN STRINGS
17218: ADD *SCHAR,XR POINT TO CHARS OF ARG 1
17219: ADD *SCHAR,XL POINT TO CHARS OF ARG 2
17220: LCT WC,WC SET LOOP COUNTER
17221: *
17222: * LOOP TO COMPARE CHARACTERS. NOTE THAT WA CANNOT BE ZERO
17223: * SINCE ALL NULL STRINGS POINT TO NULLS AND GIVE XL=XR.
17224: *
17225: IDEN3 CNE (XR),(XL),IDEN8 DIFFER IF CHARS DO NOT MATCH
17226: ICA XR ELSE BUMP ARG ONE POINTER
17227: ICA XL BUMP ARG TWO POINTER
17228: BCT WC,IDEN3 LOOP BACK TILL ALL CHECKED
17229: EJC
17230: *
17231: * IDENT (CONTINUED)
17232: *
17233: * HERE TO EXIT FOR CASE OF TWO IDENT STRINGS
17234: *
17235: ZER XL CLEAR GARBAGE VALUE IN XL
17236: ZER XR CLEAR GARBAGE VALUE IN XR
17237: EXI 1 TAKE IDENT EXIT
17238: *
17239: * HERE FOR INTEGERS, IDENT IF SAME VALUES
17240: *
17241: IDEN4 LDI ICVAL(XR) LOAD ARG 1
17242: SBI ICVAL(XL) SUBTRACT ARG 2 TO COMPARE
17243: IOV IDEN1 DIFFER IF OVERFLOW
17244: INE IDEN1 DIFFER IF RESULT IS NOT ZERO
17245: EXI 1 TAKE IDENT EXIT
17246: .IF .CNRA
17247: .ELSE
17248: *
17249: * HERE FOR REALS, IDENT IF SAME VALUES
17250: *
17251: IDEN5 LDR RCVAL(XR) LOAD ARG 1
17252: SBR RCVAL(XL) SUBTRACT ARG 2 TO COMPARE
17253: ROV IDEN1 DIFFER IF OVERFLOW
17254: RNE IDEN1 DIFFER IF RESULT IS NOT ZERO
17255: EXI 1 TAKE IDENT EXIT
17256: .FI
17257: *
17258: * HERE FOR NAMES, IDENT IF BASES AND OFFSETS SAME
17259: *
17260: IDEN6 BNE NMOFS(XR),NMOFS(XL),IDEN1 DIFFER IF DIFFERENT OFFSET
17261: BNE NMBAS(XR),NMBAS(XL),IDEN1 DIFFER IF DIFFERENT BASE
17262: *
17263: * MERGE HERE TO SIGNAL IDENT FOR IDENTICAL POINTERS
17264: *
17265: IDEN7 EXI 1 TAKE IDENT EXIT
17266: *
17267: * HERE FOR DIFFER STRINGS
17268: *
17269: IDEN8 ZER XR CLEAR GARBAGE PTR IN XR
17270: ZER XL CLEAR GARBAGE PTR IN XL
17271: EXI RETURN TO CALLER (DIFFER)
17272: ENP END PROCEDURE IDENT
17273: EJC
17274: *
17275: * INOUT - USED TO INITIALISE .INPUT .OUTPUT .TERMINAL
17276: *
17277: * (XL) POINTER TO VBL NAME STRING
17278: * (WB) TRBLK TYPE (TRTYP FIELD)
17279: * JSR INOUT CALL TO PERFORM INITIALISATION
17280: * (WA,WC) DESTROYED
17281: *
17282: * NOTE THAT TRTER (= TRTRF) FIELD OF STANDARD I/O VARIABLES
17283: * POINTS TO CORRESPONDING SVBLK NOT TO A TRBLK AS IS THE
17284: * CASE FOR ORDINARY VARIABLES.
17285: *
17286: INOUT PRC E,0 ENTRY POINT
17287: MOV WB,-(XS) STACK TRBLK TYPE
17288: MOV SCLEN(XL),WA GET NAME LENGTH
17289: ZER WB POINT TO START OF NAME
17290: JSR SBSTR BUILD A PROPER SCBLK
17291: JSR GTNVR FIND OR BUILD VRBLK
17292: PPM NO ERROR RETURN
17293: MOV XR,WC SAVE VRBLK POINTER
17294: MOV (XS)+,WB GET TRTYP FIELD
17295: ZER XL ZERO TRTRI
17296: MOV VRSVP(XR),XR GET SVBLK POINTER
17297: JSR TRBLD BUILD TRBLK
17298: MOV WC,XL RECALL VRBLK POINTER
17299: MOV *VRVAL,WA OFFSET TO VALUE FIELD
17300: JSR TRCHN PUT TRBLK IN TRACE CHAIN
17301: PPM CANT FAIL
17302: EXI RETURN TO CALLER
17303: ENP END PROCEDURE INOUT
17304: EJC
17305: .IF .CNBF
17306: .ELSE
17307: *
17308: * INSBF -- INSERT STRING IN BUFFER
17309: *
17310: * THIS ROUTINE WILL REPLACE A SECTION OF A BUFFER WITH THE
17311: * CONTENTS OF A GIVEN STRING. IF THE LENGTH OF THE
17312: * SECTION TO BE REPLACED DIFFERS FROM THAT OF THE
17313: * GIVEN STRING, AND THE REPLACEMENT IS NOT AN APPEND,
17314: * THEN THE UPPER SECTION OF THE BUFFER IS SHIFTED UP OR
17315: * DOWN TO CREATE THE PROPER SPACE FOR THE INSERT.
17316: *
17317: * (XR) POINTER TO BCBLK
17318: * (XL) OBJECT WHICH IS STRING CONVERTIBLE
17319: * (WA) OFFSET OF START OF INSERT IN (XR)
17320: * (WB) LENGTH OF SECTION IN (XR) REPLACED
17321: * JSR INSBF CALL TO INSERT CHARACTERS IN BUFFER
17322: * PPM LOC ERROR IF (XR) NOT CONVERTIBLE
17323: * PPM LOC FAIL IF INSERT NOT POSSIBLE
17324: * (XL,WA,WB,WC) DESTROYED
17325: *
17326: * THE SECOND ALTERNATE EXIT IS TAKEN IF THE INSERT WOULD
17327: * OVERFLOW THE BUFFER, OR IF THE INSERT IS OUT PAST THE
17328: * DEFINED END OF THE BUFFER AS GIVEN.
17329: *
17330: INSBF PRC E,2 ENTRY POINT
17331: MOV WA,INSSA SAVE ENTRY WA
17332: MOV WB,INSSB SAVE ENTRY WB
17333: ADD WB,WA ADD TO GET OFFSET PAST REPLACE PART
17334: MOV WA,INSAB SAVE WA+WB
17335: MOV BCLEN(XR),WC GET CURRENT DEFINED LENGTH
17336: BGT INSSA,WC,INS07 FAIL IF START OFFSET TOO BIG
17337: BGT WA,WC,INS07 FAIL IF FINAL OFFSET TOO BIG
17338: MOV XR,-(XS) SAVE BCBLK PTR
17339: MOV XL,-(XS) STACK STRING POINTER FOR GTSTG
17340: JSR GTSTG CALL TO CONVERT TO STRING
17341: PPM INS06 TAKE STRING CONVERT ERR EXIT
17342: MOV XR,XL SAVE STRING PTR
17343: MOV (XS)+,XR RESTORE BCBLK PTR
17344: MOV XR,INSBC BCBLK PTR - NO DANGER OF GARB COLLN
17345: MOV BCBUF(XR),XR POINT TO BFBLK
17346: MOV XR,INSBB BFBLK PTR - NO DANGER OF GARB COLLN
17347: ADD WC,WA ADD BUFFER LEN TO STRING LEN
17348: SUB INSSB,WA BIAS OUT COMPONENT BEING REPLACED
17349: BGT WA,BFALC(XR),INS07 FAIL IF RESULT EXCEEDS ALLOCATION
17350: MOV INSBC,XR RESTORE BCBLK PTR
17351: MOV WC,WA GET BUFFER LENGTH
17352: SUB INSAB,WA SUBTRACT TO GET SHIFT LENGTH
17353: ADD SCLEN(XL),WC ADD LENGTH OF NEW
17354: SUB INSSB,WC SUBTRACT OLD TO GET TOTAL NEW LEN
17355: MOV BCLEN(XR),WB GET OLD BCLEN
17356: MOV WC,BCLEN(XR) STUFF NEW LENGTH
17357: MOV INSBB,XR POINT TO BFBLK
17358: MOV XL,-(XS) SAVE SCBLK PTR
17359: BZE WA,INS02 SKIP SHIFT IF NOTHING TO DO
17360: BEQ INSSB,SCLEN(XL),INS02 SKIP SHIFT IF LENGTHS MATCH
17361: BLO INSSB,SCLEN(XL),INS01 BRN IF SHIFT IS FOR MORE ROOM
17362: EJC
17363: *
17364: * INSBF (CONTINUED)
17365: *
17366: * WE ARE SHIFTING THE UPPER SEGMENT DOWN TO COMPACT
17367: * THE BUFFER. (THE STRING LENGTH IS SMALLER THAN THE
17368: * SEGMENT BEING REPLACED). REGISTERS ARE SET AS -
17369: *
17370: * (WA) MOVE (SHIFT DOWN) LENGTH
17371: * (WB) OLD BCLEN
17372: * (WC) NEW BCLEN
17373: * (XR) BFBLK PTR
17374: * (XL),(XS) SCBLK PTR
17375: *
17376: MOV INSSA,WB GET OFFSET TO INSERT
17377: ADD SCLEN(XL),WB ADD INSERT LENGTH TO GET DEST OFF
17378: MOV XR,XL MAKE COPY
17379: PLC XL,INSAB PREPARE SOURCE FOR MOVE
17380: PSC XR,WB PREPARE DESTINATION REG FOR MOVE
17381: MVC MOVE EM OUT
17382: BRN INS02 BRANCH TO PAD
17383: *
17384: * WE ARE SHIFTING THE UPPER SEGMENT UP TO EXPAND
17385: * THE BUFFER. (THE STRING LENGTH IS LARGER THAN THE
17386: * SEGMENT BEING REPLACED.)
17387: *
17388: INS01 MOV XR,XL COPY BFBLK PTR
17389: PLC XL,WB SET SOURCE REG FOR MOVE BACKWARDS
17390: PSC XR,WC SET DESTINATION PTR FOR MOVE
17391: MCB MOVE BACKWARDS (POSSIBLE OVERLAP)
17392: *
17393: * MERGE HERE AFTER POSSIBLE MOVE TO ADJUST ZERO FILL AT END
17394: *
17395: INS02 MOV (XS)+,XL RESTORE SCBLK PTR
17396: MOV WC,WA COPY NEW BUFFER END
17397: CTB WA,0 ROUND OUT
17398: BTC WA CONVERT TO CHAR COUNT
17399: SUB WC,WA SUBTRACT TO GET REMAINDER
17400: BZE WA,INS04 NO PAD IF ALREADY EVEN BOUNDARY
17401: MOV INSBB,XR POINT TO BFBLK
17402: PSC XR,WC PREPARE TO PAD
17403: ZER WB CLEAR WB
17404: LCT WA,WA LOAD LOOP COUNT
17405: EJC
17406: *
17407: * INSBF (CONTINUED)
17408: *
17409: * LOOP HERE TO STUFF PAD CHARACTERS
17410: *
17411: INS03 SCH WB,(XR)+ STUFF ZERO PAD
17412: BCT WA,INS03 BRANCH FOR MORE
17413: *
17414: * MERGE HERE WHEN PADDING OK. NOW COPY IN THE INSERT
17415: * STRING TO THE HOLE.
17416: *
17417: INS04 MOV INSBB,XR POINT TO BFBLK
17418: MOV SCLEN(XL),WA GET MOVE LENGTH
17419: BZE WA,INS05 SKIP IF NO CHARS TO INSERT
17420: PLC XL PREPARE TO COPY FROM FIRST CHAR
17421: PSC XR,INSSA PREPARE TO STORE IN HOLE
17422: MVC COPY THE CHARACTERS
17423: *
17424: * SUCCESSFUL RETURN
17425: *
17426: INS05 MOV INSBC,XR RESTORE ENTRY XR
17427: ZER XL CLEAR GARBAGE CHAR POINTER
17428: EXI RETURN TO CALLER
17429: *
17430: * HERE TO TAKE STRING CONVERT ERROR EXIT
17431: *
17432: INS06 ICA XS DISCARD UNWANTED STACK TOP
17433: EXI 1 ALTERNATE EXIT
17434: *
17435: * HERE FOR INVALID OFFSET OR LENGTH
17436: *
17437: INS07 EXI 2 ALTERNATE EXIT
17438: ENP END PROCEDURE INSBF
17439: EJC
17440: .FI
17441: * IOFTG -- GET IOTAG
17442: *
17443: * USED TO FIND THE IOTAG (IF ANY) CORRESPONDING TO THE
17444: * FILETAG ARGUMENT.
17445: *
17446: * -(XS) FILETAG ARGUMENT
17447: * JSR IOFTG CALL TO FIND IOTAG
17448: * PPM LOC ARG IS AN UNSUITABLE FILETAG
17449: * (XS) POPPED
17450: * (XL) PTR TO FILETAG SCBLK
17451: * (XR) PTR TO TRTIO TRACE BLK OR ZERO
17452: * (WA) IOTAG OR ZERO
17453: * (WB) PTR TO FILETAG VRBLK
17454: * (WC) VALUE/0 FOR INTEGER/STRING FILETAG
17455: *
17456: IOFTG PRC N,1 ENTRY POINT
17457: JSR GTSTG GET ARG AS STRING
17458: PPM IOFT4 FAIL
17459: MOV XR,XL COPY STRING PTR
17460: MOV XR,-(XS) STACK STRING
17461: JSR GTSMI TRY CONVERSION TO INTEGER
17462: PPM IOFT5 SKIP IF CANT
17463: PPM IOFT5 SKIP IF CANT
17464: *
17465: * MERGE WITH WC SET UP
17466: *
17467: IOFT1 MOV WC,WB KEEP INTEGER OR ZERO
17468: MOV XL,XR FILETAG STRING TO XR FOR GTNVR CALL
17469: JSR GTNVR FIND VRBLK
17470: PPM IOFT4 SKIP IF NULL STRING
17471: MOV XL,-(XS) KEEP SCBLK PTR
17472: ZER XL IN CASE NO TRTIO BLK FOUND
17473: MOV WB,WC KEEP INTEGER OR ZERO
17474: MOV XR,WB COPY VRBLK PTR FOR RETURN
17475: ZER WA IN CASE NO TRBLK FOUND
17476: *
17477: * LOOP TO FIND FILE ARG1 TRBLK
17478: *
17479: IOFT2 MOV VRVAL(XR),XR GET POSSIBLE TRBLK PTR
17480: BNE (XR),=B$TRT,IOFT3 SKIP IF END OF CHAIN
17481: BNE TRTYP(XR),=TRTIO,IOFT2 LOOP IF NOT FILETAG TRBLK
17482: MOV TRTAG(XR),WA GET IOTAG OR 0
17483: MOV XR,XL TRTIO BLK PTR
17484: *
17485: * RETURN POINT
17486: *
17487: IOFT3 MOV XL,XR TRTIO BLK PTR OR 0
17488: MOV (XS)+,XL RECOVER SCBLK PTR
17489: EXI SUCCESSFUL RETURN
17490: *
17491: * FAIL RETURN
17492: *
17493: IOFT4 EXI 1 FAIL
17494: EJC
17495: *
17496: * NON NUMERIC FILETAG
17497: *
17498: IOFT5 ZER WC NOTE NON NUMERIC
17499: BRN IOFT1 MERGE
17500: ENP END PROCEDURE IOFTG
17501: EJC
17502: *
17503: * IOPUT -- PROCESS INPUT AND OUTPUT ARGUMENTS
17504: *
17505: * IOPUT CHECKS THE ARGUMENTS OF INPUT AND OUTPUT CALLS,
17506: * SETS UP THE REQUIRED ASSOCIATIONS AND CALLS SYSIO TO
17507: * OPEN THE REQUESTED FILES.
17508: *
17509: * -(XS) 1ST ARG (VBL TO BE ASSOCIATED)
17510: * -(XS) 2ND ARG (FILETAG)
17511: * -(XS) 3RD ARG (FILEPROPS)
17512: * (WB) 0 FOR INPUT, 2 FOR OUTPUT ASSOC.
17513: * JSR IOPUT CALL FOR INPUT/OUTPUT ASSOCIATION
17514: * PPM LOC 3RD ARG NOT A STRING
17515: * PPM LOC 2ND ARG NOT A SUITABLE FILETAG
17516: * PPM LOC 1ST ARG NOT A SUITABLE NAME
17517: * PPM LOC FAIL RETURN
17518: * (XS) POPPED
17519: * (XL,XR,WA,WB,WC) DESTROYED
17520: *
17521: EJC
17522: * FIRST ARG NAME
17523: * I I
17524: * +------+
17525: * I I-----+
17526: * +------+ V
17527: * I I +----------------+
17528: * I =B$TRT I
17529: * +----------------+
17530: * I =TRTIN/=TRTOU I
17531: * +----------------+
17532: * I VALUE OR TRCHN +
17533: * +----------------+
17534: * TRTER I I-----+
17535: * +----------------+ V
17536: * TRTRI I 0 I +------+
17537: * +----------------+ I I SVBLK
17538: * I/O TRACE BLOCK +------+
17539: *
17540: * 1. ASSOCIATION TO STANDARD FILES.
17541: *
17542: * FIRST ARG NAME FILETAG VRBLK
17543: * I I I I
17544: * +------+ LK1 +------+ LK2
17545: * I I---+ +---+ I I---+
17546: * +------+ V I V +------+ V
17547: * I I +----------------+ I +----------------+
17548: * I =B$TRT I I I =B$TRT I
17549: * +----------------+ I +----------------+
17550: * I =TRTIN/=TRTOU I I I =TRTIO I
17551: * +----------------+ I +----------------+
17552: * I VALUE OR TRCHN I I I VALUE OR TRCHN I
17553: * +----------------+ I +----------------+
17554: * TRTER I 0 I I I 0 OR IOTAG I TRTAG
17555: * +----------------+ I +----------------+
17556: * TRTRI I I--+ I 0 I TRTRI
17557: * +----------------+ +----------------+
17558: * I/O TRACE BLOCK TRTIO BLOCK
17559: *
17560: * 2. REGULAR CASE.
17561: *
17562: * THE STRUCTURES BUILT FOR I/O ASSOCIATIONS ARE AS SHOWN
17563: * ABOVE. A TRACE BLOCK CHAIN (TRCHN) MAY HOLD ANY OR ALL
17564: * OF THE TYPES, =TRTIN, =TRTOU, =TRTIO, BUT NOT MORE THAN
17565: * ONE BLOCK OF ANY GIVEN TYPE. CASES ARE -
17566: * 1. NO FILETAG OR IOTAG IS USED FOR ASSOCIATING STANDARD
17567: * FILES (SYSRD, SYSPR, TERMINAL). THE I/O TRACE BLOCK
17568: * IS DISTINGUISHED BY A NON-NULL TRTER FIELD POINTING
17569: * TO THE RELEVANT SVBLK (V$INP, V$OUP, V$TER) AND A
17570: * ZERO TRTRI FIELD. FOR TERMINAL, TRBLKS OF BOTH
17571: * INPUT AND OUTPUT TYPE ARE CHAINED FROM THE FIRST ARG
17572: * VIA THE TRCHN FIELD.
17573: * 2. THE I/O TRACE BLOCK FOR THE REGULAR CASE HAS A ZERO
17574: * TRTER FIELD AND A POINTER TO A TRTIO BLOCK IS IN
17575: * THE TRTRI FIELD. THE FILETAG MUST BE A NATURAL
17576: * VARIABLE AND THE TRTIO TRACE BLOCK ATTACHED TO IT
17577: * HOLDS THE IOTAG.
17578: * THE EFFECT OF ENDFILE() IS TO CLEAR IOTAG AND BREAK LK2.
17579: * THE EFFECT OF DETACH() IS TO BREAK LK1.
17580: EJC
17581: IOPUT PRC N,4 ENTRY POINT
17582: MOV WB,IOPWB KEEP ASSOCIATION TYPE FLAG
17583: JSR GTSTG CONVERT THIRD ARG TO STRING
17584: PPM IOP12 FAIL THIRD ARG
17585: BNZ WA,IOP01 SKIP IF NON NULL
17586: ZER XR NOTE NULL ARG
17587: *
17588: * PROCESS SECOND ARG
17589: *
17590: IOP01 MOV XR,R$IOR KEEP FILEPROPS STRING PTR
17591: JSR IOFTG CHECK SECOND ARG
17592: PPM IOP07 FAIL SECOND ARG
17593: MOV XL,R$IOL KEEP SCBLK FOR FILETAG
17594: MOV XR,R$IOT KEEP TRTIO BLK PTR
17595: MOV WA,IOPWA KEEP IOTAG
17596: MOV WB,IOPVR KEEP FILETAG VRBLK PTR
17597: MOV WC,IOPWC KEEP FILETAG VALUE
17598: MOV (XS)+,XR GET FIRST ARG OFF STACK
17599: JSR GTVAR CONVERT TO NAME
17600: PPM IOP13 FAIL FIRST ARG
17601: MOV XL,R$IO1 SAVE FIRST ARG NAME BASE ADRS
17602: MOV WA,IOPNF SAVE FIRST ARG NAME OFFSET
17603: MOV WB,XR FILETAG VRBLK PTR
17604: BNZ VRLEN(XR),IOP02 NOT SPECIAL CASE IF NOT SYS NAME
17605: MOV VRSVP(XR),WC GET SVBLK PTR
17606: MOV =TRTIN,WB IN CASE .INPUT
17607: BEQ WC,=V$INP,IOP06 JUMP IF .INPUT
17608: MOV =TRTOU,WB IN CASE .OUTPUT OR .TERMINAL
17609: BEQ WC,=V$OUP,IOP08 JUMP IF .OUTPUT
17610: BEQ WC,=V$TER,IOP09 JUMP IF .TERMINAL
17611: EJC
17612: *
17613: * NORMAL CASE
17614: *
17615: IOP02 BNZ R$IOT,IOP03 SKIP IF TRTIO BLK EXISTS ALREADY
17616: MOV =TRTIO,WB TRACE BLOCK TYPE WORD
17617: ZER XR ZERO IOTAG WORD
17618: ZER XL ZERO TRTRI FIELD
17619: JSR TRBLD BUILD TRTIO TRBLK
17620: MOV XR,R$IOT SAVE TRTIO BLK PTR
17621: MOV IOPVR,XL GET FILETAG VRBLK
17622: MOV *VRVAL,WA OFFSET TO VALUE FIELD
17623: JSR TRCHN PLACE IN TRBLK CHAIN FOR FILETAG
17624: PPM UNUSED RETURN
17625: *
17626: * MERGE TO BUILD TRBLK FOR FIRST ARG
17627: *
17628: IOP03 MOV =TRTIN,WB IN CASE INPUT
17629: BZE IOPWB,IOP04 SKIP IF SO
17630: MOV =TRTOU,WB IN CASE OUTPUT
17631: *
17632: * BUILD TRACE BLOCK
17633: *
17634: IOP04 ICV IOPWB NOTE NOT STANDARD I/O FILE
17635: MOV R$IOT,XL TRTIO BLK PTR TO TRTRI FIELD
17636: ZER XR ZERO TRTER FIELD
17637: JSR TRBLD BUILD I/O TRACE BLOCK
17638: MOV R$IO1,XL ASSOCIATED VBL NAME BASE
17639: MOV IOPNF,WA NAME OFFSET
17640: JSR TRCHN UPDATE TRACE CHAIN FOR FIRST ARG
17641: PPM UNUSED RETURN
17642: *
17643: * PREPARE FOR AND MAKE SYSIO CALL
17644: *
17645: IOP05 MOV R$IOL,XL FILETAG SCBLK PTR
17646: MOV R$IOR,XR FILEPROPS SCBLK PTR
17647: MOV IOPWA,WA IOTAG OR ZERO
17648: MOV IOPWB,WB ASSOCIATION TYPE NUMBER
17649: MOV IOPWC,WC POSSIBLE FILETAG VALUE
17650: JSR SYSIO CALL SYSTEM ROUTINE TO OPEN FILE
17651: PPM IOP14 FAIL RETURN
17652: PPM EROSI ERROR RETURN
17653: MOV R$IOT,XL TRTIO POINTER
17654: BZE XL,IOP11 DONE IF ZERO
17655: MOV WA,TRTAG(XL) STORE RETURNED IOTAG
17656: BRN IOP11 SUCCEED
17657: EJC
17658: *
17659: * SPECIAL CASE OF .INPUT
17660: *
17661: IOP06 BZE IOPWB,IOP09 FAIL OUTPUT(.X,.INPUT)
17662: *
17663: * BAD FILETAG
17664: *
17665: IOP07 EXI 2 ERRONEOUS SECOND ARG
17666: *
17667: * SPECIAL CASE OF .OUTPUT
17668: *
17669: IOP08 BZE IOPWB,IOP07 FAIL INPUT(.X,.OUTPUT)
17670: *
17671: * SPECIAL CASE OF .TERMINAL AND MERGE FOR OTHERS
17672: *
17673: IOP09 ZER R$IOT NOTE NO TRTIO BLOCK
17674: MOV WC,XR SVBLK PTR FOR TRTER FIELD
17675: ZER XL ZERO TRTRI FIELD
17676: JSR TRBLD BUILD TRBLK
17677: MOV R$IO1,XL ASSOCIATED VBL NAME BASE
17678: MOV IOPNF,WA NAME OFFSET
17679: JSR TRCHN UPDATE TRACE CHAIN FOR ARG 1
17680: PPM UNUSED RETURN
17681: BNE TRTER(XR),=V$TER,IOP10 DONE UNLESS TERMINAL
17682: BNE TRTYP(XR),=TRTOU,IOP10 DONE IF TERM. 2ND TIME ROUND
17683: MOV =V$TER,WC TRTER FIELD
17684: MOV =TRTIN,WB TRTYP FIELD
17685: BRN IOP09 REPEAT LOOP FOR TERMINAL
17686: *
17687: * CHECK SPECIAL CASES FOR NON-NULL THIRD ARGS
17688: *
17689: IOP10 ZER IOPWA NO IOTAG
17690: BNZ R$IOR,IOP05 MERGE ONLY IF FILEPROPS NON-NULL
17691: *
17692: * SUCCESS RETURN
17693: *
17694: IOP11 ZER R$IO1 CLEAR GARBAGE
17695: ZER R$IOL
17696: ZER R$IOR
17697: ZER R$IOT
17698: EXI RETURN TO CALLER
17699: *
17700: * ERROR RETURNS
17701: *
17702: IOP12 EXI 1 ERRONEOUS THIRD ARG
17703: *
17704: IOP13 EXI 3 ERRONEOUS FIRST ARG
17705: *
17706: IOP14 EXI 4 FAIL RETURN FROM SYSIO
17707: ENP END PROCEDURE IOPUT
17708: EJC
17709: *
17710: * KTREX -- EXECUTE KEYWORD TRACE
17711: *
17712: * KTREX IS USED TO EXECUTE A POSSIBLE KEYWORD TRACE. IT
17713: * INCLUDES THE TEST ON TRACE AND TESTS FOR TRACE ACTIVE.
17714: *
17715: * (XL) PTR TO TRBLK (OR 0 IF UNTRACED)
17716: * JSR KTREX CALL TO EXECUTE KEYWORD TRACE
17717: * (XL,WA,WB,WC) DESTROYED
17718: * (RA) DESTROYED
17719: *
17720: KTREX PRC R,0 ENTRY POINT (RECURSIVE)
17721: BZE XL,KTRX3 IMMEDIATE EXIT IF KEYWORD UNTRACED
17722: BZE KVTRA,KTRX3 IMMEDIATE EXIT IF TRACE = 0
17723: DCV KVTRA ELSE DECREMENT TRACE
17724: MOV XR,-(XS) SAVE XR
17725: MOV XL,XR COPY TRBLK POINTER
17726: MOV TRKVR(XR),XL LOAD VRBLK POINTER (NMBAS)
17727: MOV *VRVAL,WA SET NAME OFFSET
17728: BZE TRFNC(XR),KTRX1 JUMP IF PRINT TRACE
17729: JSR TRXEQ ELSE EXECUTE FULL TRACE
17730: BRN KTRX2 AND JUMP TO EXIT
17731: *
17732: * HERE FOR PRINT TRACE
17733: *
17734: KTRX1 MOV XL,-(XS) STACK VRBLK PTR FOR KWNAM
17735: MOV WA,-(XS) STACK OFFSET FOR KWNAM
17736: JSR PRTSN PRINT STATEMENT NUMBER
17737: MOV =CH$AM,WA LOAD AMPERSAND
17738: JSR PRTCH PRINT AMPERSAND
17739: JSR PRTNM PRINT KEYWORD NAME
17740: MOV =TMBEB,XR POINT TO BLANK-EQUAL-BLANK
17741: JSR PRTST PRINT BLANK-EQUAL-BLANK
17742: JSR KWNAM GET KEYWORD PSEUDO-VARIABLE NAME
17743: MOV XR,DNAMP RESET PTR TO DELETE KVBLK
17744: JSR ACESS GET KEYWORD VALUE
17745: PPM FAILURE IS IMPOSSIBLE
17746: JSR PRTVF PRINT KEYWORD VALUE
17747: *
17748: * HERE TO EXIT AFTER COMPLETING TRACE
17749: *
17750: KTRX2 MOV (XS)+,XR RESTORE ENTRY XR
17751: *
17752: * MERGE HERE TO EXIT IF NO TRACE REQUIRED
17753: *
17754: KTRX3 EXI RETURN TO KTREX CALLER
17755: ENP END PROCEDURE KTREX
17756: EJC
17757: *
17758: * KWNAM -- GET PSEUDO-VARIABLE NAME FOR KEYWORD
17759: *
17760: * 1(XS) NAME BASE FOR VRBLK
17761: * 0(XS) OFFSET (SHOULD BE *VRVAL)
17762: * JSR KWNAM CALL TO GET PSEUDO-VARIABLE NAME
17763: * (XS) POPPED TWICE
17764: * (XL,WA) RESULTING PSEUDO-VARIABLE NAME
17765: * (XR,WA,WB) DESTROYED
17766: *
17767: KWNAM PRC N,0 ENTRY POINT
17768: ICA XS IGNORE NAME OFFSET
17769: MOV (XS)+,XR LOAD NAME BASE
17770: BGE XR,STATE,KWNM1 JUMP IF NOT NATURAL VARIABLE NAME
17771: BNZ VRLEN(XR),KWNM1 ERROR IF NOT SYSTEM VARIABLE
17772: MOV VRSVP(XR),XR ELSE POINT TO SVBLK
17773: MOV SVBIT(XR),WA LOAD BIT MASK
17774: ANB BTKNM,WA AND WITH KEYWORD BIT
17775: ZRB WA,KWNM1 ERROR IF NO KEYWORD ASSOCIATION
17776: MOV SVLEN(XR),WA ELSE LOAD NAME LENGTH IN CHARACTERS
17777: CTB WA,SVCHS COMPUTE OFFSET TO FIELD WE WANT
17778: ADD WA,XR POINT TO SVKNM FIELD
17779: MOV (XR),WB LOAD SVKNM VALUE
17780: MOV *KVSI$,WA SET SIZE OF KVBLK
17781: JSR ALLOC ALLOCATE KVBLK
17782: MOV =B$KVT,(XR) STORE TYPE WORD
17783: MOV WB,KVNUM(XR) STORE KEYWORD NUMBER
17784: MOV =TRBKV,KVVAR(XR) SET DUMMY TRBLK POINTER
17785: MOV XR,XL COPY KVBLK POINTER
17786: MOV *KVVAR,WA SET PROPER OFFSET
17787: EXI RETURN TO KVNAM CALLER
17788: *
17789: * HERE IF NOT KEYWORD NAME
17790: *
17791: KWNM1 ERB 230,KEYWORD OPERAND IS NOT NAME OF DEFINED KEYWORD
17792: ENP END PROCEDURE KWNAM
17793: EJC
17794: *
17795: * LCOMP-- COMPARE TWO STRINGS LEXICALLY
17796: *
17797: * 1(XS) FIRST ARGUMENT
17798: * 0(XS) SECOND ARGUMENT
17799: * JSR LCOMP CALL TO COMPARE ARUMENTS
17800: * PPM LOC TRANSFER LOC FOR ARG1 NOT STRING
17801: * PPM LOC TRANSFER LOC FOR ARG2 NOT STRING
17802: * PPM LOC TRANSFER LOC IF ARG1 LLT ARG2
17803: * PPM LOC TRANSFER LOC IF ARG1 LEQ ARG2
17804: * PPM LOC TRANSFER LOC IF ARG1 LGT ARG2
17805: * (THE NORMAL RETURN IS NEVER TAKEN)
17806: * (XS) POPPED TWICE
17807: * (XR,XL) DESTROYED
17808: * (WA,WB,WC,RA) DESTROYED
17809: *
17810: LCOMP PRC N,5 ENTRY POINT
17811: JSR GTSTG CONVERT SECOND ARG TO STRING
17812: PPM LCMP6 JUMP IF SECOND ARG NOT STRING
17813: MOV XR,XL ELSE SAVE POINTER
17814: MOV WA,WB AND LENGTH
17815: JSR GTSTG CONVERT FIRST ARGUMENT TO STRING
17816: PPM LCMP5 JUMP IF NOT STRING
17817: MOV WA,WC SAVE ARG 1 LENGTH
17818: PLC XR POINT TO CHARS OF ARG 1
17819: PLC XL POINT TO CHARS OF ARG 2
17820: BLO WA,WB,LCMP0 JUMP IF ARG 1 LENGTH IS SMALLER
17821: MOV WB,WA ELSE SET ARG 2 LENGTH AS SMALLER
17822: *
17823: * HERE WITH SMALLER LENGTH IN (WA)
17824: *
17825: LCMP0 BZE WA,LCMP1 SKIP IF A NULL ARG
17826: CMC LCMP4,LCMP3 COMPARE STRINGS, JUMP IF UNEQUAL
17827: *
17828: * EQUAL STRINGS OR AT LEAST ONE NULL ARG
17829: *
17830: LCMP1 BNE WB,WC,LCMP2 IF EQUAL, JUMP IF LENGTHS UNEQUAL
17831: EXI 4 ELSE IDENTICAL STRINGS, LEQ EXIT
17832: EJC
17833: *
17834: * LCOMP (CONTINUED)
17835: *
17836: * HERE IF INITIAL STRINGS IDENTICAL, BUT LENGTHS UNEQUAL
17837: *
17838: LCMP2 BHI WC,WB,LCMP4 JUMP IF ARG 1 LENGTH GT ARG 2 LENG
17839: *
17840: * HERE IF FIRST ARG LLT SECOND ARG
17841: *
17842: LCMP3 EXI 3 TAKE LLT EXIT
17843: *
17844: * HERE IF FIRST ARG LGT SECOND ARG
17845: *
17846: LCMP4 EXI 5 TAKE LGT EXIT
17847: *
17848: * HERE IF FIRST ARG IS NOT A STRING
17849: *
17850: LCMP5 EXI 1 TAKE BAD FIRST ARG EXIT
17851: *
17852: * HERE FOR SECOND ARG NOT A STRING
17853: *
17854: LCMP6 EXI 2 TAKE BAD SECOND ARG ERROR EXIT
17855: ENP END PROCEDURE LCOMP
17856: EJC
17857: *
17858: * LISTR -- LIST SOURCE LINE
17859: *
17860: * LISTR IS USED TO LIST A SOURCE LINE DURING THE INITIAL
17861: * COMPILATION. IT IS CALLED FROM SCANE AND SCANL.
17862: *
17863: * JSR LISTR CALL TO LIST LINE
17864: * (XR,XL,WA,WB,WC) DESTROYED
17865: *
17866: * GLOBAL LOCATIONS USED BY LISTR
17867: *
17868: * ERLST IF LISTING ON ACCOUNT OF AN ERROR
17869: *
17870: * LSTLC COUNT LINES ON CURRENT PAGE
17871: *
17872: * LSTNP MAX NUMBER OF LINES/PAGE
17873: *
17874: * LSTPF SET NON-ZERO IF THE CURRENT SOURCE
17875: * LINE HAS BEEN LISTED, ELSE ZERO.
17876: *
17877: * LSTPG COMPILER LISTING PAGE NUMBER
17878: *
17879: * LSTSN SET IF STMNT NUM TO BE LISTED
17880: *
17881: * R$CIM POINTER TO CURRENT INPUT LINE.
17882: *
17883: * R$TTL TITLE FOR SOURCE LISTING
17884: *
17885: * R$STL PTR TO SUB-TITLE STRING
17886: *
17887: * ENTRY POINT
17888: *
17889: LISTR PRC E,0 ENTRY POINT
17890: MOV STAGE,WA GET COMPILER STAGE
17891: BEQ WA,=STGIC,LIST0 LIST OK IF INITIAL COMPILE
17892: BEQ WA,=STGCE,LIST0 LIST OK IF END LINE
17893: BRN LIST4 ELSE NO LISTING OF SOURCE
17894: *
17895: * HERE WHEN STAGE IS OK TO LIST
17896: *
17897: LIST0 BNZ CNTTL,LIST5 JUMP IF -TITLE OR -STITL
17898: BNZ LSTPF,LIST4 IMMEDIATE EXIT IF ALREADY LISTED
17899: BGE LSTLC,LSTNP,LIST6 JUMP IF NO ROOM
17900: *
17901: * HERE AFTER PRINTING TITLE (IF NEEDED)
17902: *
17903: LIST1 MOV R$CIM,XR LOAD POINTER TO CURRENT IMAGE
17904: PLC XR POINT TO CHARACTERS
17905: LCH WA,(XR) LOAD FIRST CHARACTER
17906: MOV LSTSN,XR LOAD STATEMENT NUMBER
17907: BZE XR,LIST2 JUMP IF NO STATEMENT NUMBER
17908: MTI XR ELSE GET STMNT NUMBER AS INTEGER
17909: BEQ WA,=CH$AS,LIST2 NO STMNT NUMBER LIST IF COMMENT
17910: BEQ WA,=CH$MN,LIST2 NO STMNT NO. IF CONTROL CARD
17911: JSR PRTIN ELSE PRINT STATEMENT NUMBER
17912: ZER LSTSN AND CLEAR FOR NEXT TIME IN
17913: EJC
17914: *
17915: * LISTR (CONTINUED)
17916: *
17917: * MERGE HERE AFTER PRINTING STATEMENT NUMBER (IF REQUIRED)
17918: *
17919: LIST2 MOV =STNPD,PROFS POINT PAST STATEMENT NUMBER
17920: MOV R$CIM,XR LOAD POINTER TO CURRENT IMAGE
17921: JSR PRTSF PRINT IT
17922: ICV LSTLC BUMP LINE COUNTER
17923: MNZ LSTPF SET FLAG FOR LINE PRINTED
17924: *
17925: * MERGE HERE TO EXIT
17926: *
17927: LIST4 EXI RETURN TO LISTR CALLER
17928: *
17929: * PRINT TITLE AFTER -TITLE OR -STITL CARD
17930: *
17931: LIST5 ZER CNTTL CLEAR FLAG
17932: *
17933: * EJECT TO NEW PAGE AND LIST TITLE
17934: *
17935: LIST6 JSR PRTPS EJECT
17936: BNZ PRLEN,LIST7 SKIP IF LISTING TO REGULAR PRINTER
17937: BEQ R$TTL,=NULLS,LIST1 TERMINAL LISTING OMITS NULL TITLE
17938: *
17939: * LIST TITLE
17940: *
17941: LIST7 JSR LISTT LIST TITLE
17942: BRN LIST1 MERGE
17943: ENP END PROCEDURE LISTR
17944: EJC
17945: *
17946: * LISTT -- LIST TITLE AND SUBTITLE
17947: *
17948: * USED DURING COMPILATION TO PRINT PAGE HEADING
17949: *
17950: * JSR LISTT CALL TO LIST TITLE
17951: * (XR,WA) DESTROYED
17952: *
17953: LISTT PRC E,0 ENTRY POINT
17954: MOV R$TTL,XR POINT TO SOURCE LISTING TITLE
17955: JSR PRTST PRINT TITLE
17956: MOV LSTPO,PROFS SET OFFSET
17957: MOV =LSTMS,XR SET PAGE MESSAGE
17958: JSR PRTST PRINT PAGE MESSAGE
17959: ICV LSTPG BUMP PAGE NUMBER
17960: MTI LSTPG LOAD PAGE NUMBER AS INTEGER
17961: JSR PRTIN PRINT PAGE NUMBER
17962: JSR PRTFH TERMINATE TITLE LINE
17963: ADD =NUM02,LSTLC COUNT TITLE LINE AND BLANK LINE
17964: *
17965: * PRINT SUB-TITLE (IF ANY)
17966: *
17967: MOV R$STL,XR LOAD POINTER TO SUB-TITLE
17968: BZE XR,LSTT1 JUMP IF NO SUB-TITLE
17969: JSR PRTSF ELSE PRINT SUB-TITLE
17970: ICV LSTLC BUMP LINE COUNT
17971: *
17972: * RETURN POINT
17973: *
17974: LSTT1 JSR PRTFH PRINT A BLANK LINE
17975: EXI RETURN TO CALLER
17976: ENP END PROCEDURE LISTT
17977: EJC
17978: *
17979: * NEXTS -- ACQUIRE NEXT SOURCE IMAGE
17980: *
17981: * NEXTS IS USED TO ACQUIRE THE NEXT SOURCE IMAGE AT COMPILE
17982: * TIME. IT ASSUMES THAT A PRIOR CALL TO READR HAS INPUT
17983: * A LINE IMAGE (SEE PROCEDURE READR). BEFORE THE CURRENT
17984: * IMAGE IS FINALLY LOST IT MAY BE LISTED HERE.
17985: *
17986: * JSR NEXTS CALL TO ACQUIRE NEXT INPUT LINE
17987: * (XR,XL,WA,WB,WC) DESTROYED
17988: *
17989: * GLOBAL VALUES AFFECTED
17990: *
17991: * R$CNI ON INPUT, NEXT IMAGE. ON
17992: * EXIT RESET TO ZERO
17993: *
17994: * R$CIM ON EXIT, SET TO POINT TO IMAGE
17995: *
17996: * SCNIL INPUT IMAGE LENGTH ON EXIT
17997: *
17998: * SCNSE RESET TO ZERO ON EXIT
17999: *
18000: * LSTPF SET ON EXIT IF LINE IS LISTED
18001: *
18002: NEXTS PRC E,0 ENTRY POINT
18003: BZE CSWLS,NXTS1 JUMP IF -NOLIST
18004: MOV R$CIM,XR POINT TO IMAGE
18005: BZE XR,NXTS1 JUMP IF NO IMAGE
18006: PLC XR GET CHAR PTR
18007: LCH WA,(XR) GET FIRST CHAR
18008: BEQ WA,=CH$MN,NXTS1 SKIP LISTING IF CONTROL CARD
18009: JSR LISTR LIST LINE
18010: *
18011: * HERE AFTER POSSIBLE LISTING
18012: *
18013: NXTS1 MOV R$CNI,XR POINT TO NEXT IMAGE
18014: MOV XR,R$CIM SET AS NEXT IMAGE
18015: ZER R$CNI CLEAR NEXT IMAGE POINTER
18016: MOV SCLEN(XR),WA GET INPUT IMAGE LENGTH
18017: MOV CSWIN,WB GET MAX ALLOWABLE LENGTH
18018: BLO WA,WB,NXTS2 SKIP IF NOT TOO LONG
18019: MOV WB,WA ELSE TRUNCATE
18020: *
18021: * HERE WITH LENGTH IN (WA)
18022: *
18023: NXTS2 MOV WA,SCNIL USE AS RECORD LENGTH
18024: ZER SCNSE RESET SCNSE
18025: ZER LSTPF SET LINE NOT LISTED YET
18026: EXI RETURN TO NEXTS CALLER
18027: ENP END PROCEDURE NEXTS
18028: EJC
18029: *
18030: * PATIN -- PATTERN CONSTRUCTION FOR LEN,POS,RPOS,TAB,RTAB
18031: *
18032: * THESE PATTERN TYPES ALL GENERATE A SIMILAR NODE TYPE. SO
18033: * THE CONSTRUCTION CODE IS SHARED. SEE FUNCTIONS SECTION
18034: * FOR ACTUAL ENTRY POINTS FOR THESE FIVE FUNCTIONS.
18035: *
18036: * (WA) PCODE FOR EXPRESSION ARG CASE
18037: * (WB) PCODE FOR INTEGER ARG CASE
18038: * JSR PATIN CALL TO BUILD PATTERN NODE
18039: * PPM LOC TRANSFER LOC FOR NOT INTEGER OR EXP
18040: * PPM LOC TRANSFER LOC FOR INT OUT OF RANGE
18041: * (XR) POINTER TO CONSTRUCTED NODE
18042: * (XL,WA,WB,WC,IA) DESTROYED
18043: *
18044: PATIN PRC N,2 ENTRY POINT
18045: MOV WA,XL PRESERVE EXPRESSION ARG PCODE
18046: JSR GTSMI TRY TO CONVERT ARG AS SMALL INTEGER
18047: PPM PTIN2 JUMP IF NOT INTEGER
18048: PPM PTIN3 JUMP IF OUT OF RANGE
18049: *
18050: * COMMON SUCCESSFUL EXIT POINT
18051: *
18052: PTIN1 JSR PBILD BUILD PATTERN NODE
18053: EXI RETURN TO CALLER
18054: *
18055: * HERE IF ARGUMENT IS NOT AN INTEGER
18056: *
18057: PTIN2 MOV XL,WB COPY EXPR ARG CASE PCODE
18058: BLO (XR),=B$E$$,PTIN1 ALL OK IF EXPRESSION ARG
18059: EXI 1 ELSE TAKE ERROR EXIT FOR WRONG TYPE
18060: *
18061: * HERE FOR ERROR OF OUT OF RANGE INTEGER ARGUMENT
18062: *
18063: PTIN3 EXI 2 TAKE OUT-OF-RANGE ERROR EXIT
18064: ENP END PROCEDURE PATIN
18065: EJC
18066: *
18067: * PATST -- PATTERN CONSTRUCTION FOR ANY,NOTANY,
18068: * BREAK,SPAN AND BREAKX PATTERN FUNCTIONS.
18069: *
18070: * THESE PATTERN FUNCTIONS BUILD SIMILAR TYPES OF NODES AND
18071: * THE CONSTRUCTION CODE IS SHARED. SEE FUNCTIONS SECTION
18072: * FOR ACTUAL ENTRY POINTS FOR THESE FIVE PATTERN FUNCTIONS.
18073: *
18074: * 0(XS) STRING ARGUMENT
18075: * (WB) PCODE FOR ONE CHAR ARGUMENT
18076: * (XL) PCODE FOR MULTI-CHAR ARGUMENT
18077: * (WC) PCODE FOR EXPRESSION ARGUMENT
18078: * JSR PATST CALL TO BUILD NODE
18079: * PPM LOC TRANSFER LOC IF NOT STRING OR EXPR
18080: * (XS) POPPED PAST STRING ARGUMENT
18081: * (XR) POINTER TO CONSTRUCTED NODE
18082: * (XL) DESTROYED
18083: * (WA,WB,WC,RA) DESTROYED
18084: *
18085: * NOTE THAT THERE IS A SPECIAL CALL TO PATST IN THE EVALS
18086: * PROCEDURE WITH A SLIGHTLY DIFFERENT FORM. SEE EVALS
18087: * FOR DETAILS OF THE FORM OF THIS CALL.
18088: *
18089: PATST PRC N,1 ENTRY POINT
18090: JSR GTSTG CONVERT ARGUMENT AS STRING
18091: PPM PATS7 JUMP IF NOT STRING
18092: BNE WA,=NUM01,PATS2 JUMP IF NOT ONE CHAR STRING
18093: *
18094: * HERE FOR ONE CHAR STRING CASE
18095: *
18096: BZE WB,PATS2 TREAT AS MULTI-CHAR IF EVALS CALL
18097: PLC XR POINT TO CHARACTER
18098: LCH XR,(XR) LOAD CHARACTER
18099: *
18100: * COMMON EXIT POINT AFTER SUCCESSFUL CONSTRUCTION
18101: *
18102: PATS1 JSR PBILD CALL ROUTINE TO BUILD NODE
18103: EXI RETURN TO PATST CALLER
18104: EJC
18105: *
18106: * PATST (CONTINUED)
18107: *
18108: * HERE FOR MULTI-CHARACTER STRING CASE
18109: *
18110: PATS2 MOV XL,-(XS) SAVE MULTI-CHAR PCODE
18111: MOV XR,-(XS) SAVE STRING POINTER
18112: MOV CTMSK,WC LOAD CURRENT MASK BIT
18113: LSH WC,1 SHIFT TO NEXT POSITION
18114: NZB WC,PATS4 SKIP IF POSITION LEFT IN THIS TBL
18115: *
18116: * HERE WE MUST ALLOCATE A NEW CHARACTER TABLE
18117: *
18118: MOV *CTSI$,WA SET SIZE OF CTBLK
18119: JSR ALLOC ALLOCATE CTBLK
18120: MOV XR,R$CTP STORE PTR TO NEW CTBLK
18121: MOV =B$CTT,(XR)+ STORE TYPE CODE, BUMP PTR
18122: LCT WB,=CFP$A SET NUMBER OF WORDS TO CLEAR
18123: MOV BITS0,WC LOAD ALL ZERO BITS
18124: *
18125: * LOOP TO CLEAR ALL BITS IN TABLE TO ZEROS
18126: *
18127: PATS3 MOV WC,(XR)+ MOVE WORD OF ZERO BITS
18128: BCT WB,PATS3 LOOP TILL ALL CLEARED
18129: MOV BITS1,WC SET INITIAL BIT POSITION
18130: *
18131: * MERGE HERE WITH BIT POSITION AVAILABLE
18132: *
18133: PATS4 MOV WC,CTMSK SAVE PARM2 (NEW BIT POSITION)
18134: MOV (XS)+,XL RESTORE POINTER TO ARGUMENT STRING
18135: MOV SCLEN(XL),WB LOAD STRING LENGTH
18136: BZE WB,PATS6 JUMP IF NULL STRING CASE
18137: LCT WB,WB ELSE SET LOOP COUNTER
18138: PLC XL POINT TO CHARACTERS IN ARGUMENT
18139: EJC
18140: *
18141: * PATST (CONTINUED)
18142: *
18143: * LOOP TO SET BITS IN COLUMN OF TABLE
18144: *
18145: PATS5 LCH WA,(XL)+ LOAD NEXT CHARACTER
18146: WTB WA CONVERT TO BAU OFFSET
18147: MOV R$CTP,XR POINT TO CTBLK
18148: ADD WA,XR POINT TO CTBLK ENTRY
18149: MOV WC,WA COPY BIT MASK
18150: ORB CTCHS(XR),WA OR IN BITS ALREADY SET
18151: MOV WA,CTCHS(XR) STORE RESULTING BIT STRING
18152: BCT WB,PATS5 LOOP TILL ALL BITS SET
18153: *
18154: * COMPLETE PROCESSING FOR MUTI-CHAR STRING CASE
18155: *
18156: PATS6 MOV R$CTP,XR LOAD CTBLK PTR AS PARM1 FOR PBILD
18157: ZER XL CLEAR GARBAGE PTR IN XL
18158: MOV (XS)+,WB LOAD PCODE FOR MULTI-CHAR STR CASE
18159: BRN PATS1 BACK TO EXIT (WC=BITSTRING=PARM2)
18160: *
18161: * HERE IF ARGUMENT IS NOT A STRING
18162: *
18163: * NOTE THAT THE CALL FROM EVALS CANNOT PASS AN EXPRESSION
18164: * SINCE EVALP ALWAYS REEVALUATES EXPRESSIONS.
18165: *
18166: PATS7 MOV WC,WB SET PCODE FOR EXPRESSION ARGUMENT
18167: BLO (XR),=B$E$$,PATS1 JUMP TO EXIT IF EXPRESSION ARG
18168: EXI 1 ELSE TAKE WRONG TYPE ERROR EXIT
18169: ENP END PROCEDURE PATST
18170: EJC
18171: *
18172: * PBILD -- BUILD PATTERN NODE
18173: *
18174: * (XR) PARM1 (ONLY IF REQUIRED)
18175: * (WB) PCODE FOR NODE
18176: * (WC) PARM2 (ONLY IF REQUIRED)
18177: * JSR PBILD CALL TO BUILD NODE
18178: * (XR) POINTER TO CONSTRUCTED NODE
18179: * (WA) DESTROYED
18180: *
18181: PBILD PRC E,0 ENTRY POINT
18182: MOV XR,-(XS) STACK POSSIBLE PARM1
18183: MOV WB,XR COPY PCODE
18184: LEI XR LOAD ENTRY POINT ID (BL$PX)
18185: BEQ XR,=BL$P1,PBLD1 JUMP IF ONE PARAMETER
18186: BEQ XR,=BL$P0,PBLD3 JUMP IF NO PARAMETERS
18187: *
18188: * HERE FOR TWO PARAMETER CASE
18189: *
18190: MOV *PCSI$,WA SET SIZE OF P2BLK
18191: JSR ALLOC ALLOCATE BLOCK
18192: MOV WC,PARM2(XR) STORE SECOND PARAMETER
18193: BRN PBLD2 MERGE WITH ONE PARM CASE
18194: *
18195: * HERE FOR ONE PARAMETER CASE
18196: *
18197: PBLD1 MOV *PBSI$,WA SET SIZE OF P1BLK
18198: JSR ALLOC ALLOCATE NODE
18199: *
18200: * MERGE HERE FROM TWO PARM CASE
18201: *
18202: PBLD2 MOV (XS),PARM1(XR) STORE FIRST PARAMETER
18203: BRN PBLD4 MERGE WITH NO PARAMETER CASE
18204: *
18205: * HERE FOR CASE OF NO PARAMETERS
18206: *
18207: PBLD3 MOV *PASI$,WA SET SIZE OF P0BLK
18208: JSR ALLOC ALLOCATE NODE
18209: *
18210: * MERGE HERE FROM OTHER CASES
18211: *
18212: PBLD4 MOV WB,(XR) STORE PCODE
18213: ICA XS POP FIRST PARAMETER
18214: MOV =NDNTH,PTHEN(XR) SET NOTHEN SUCCESSOR POINTER
18215: EXI RETURN TO PBILD CALLER
18216: ENP END PROCEDURE PBILD
18217: EJC
18218: *
18219: * PCONC -- CONCATENATE TWO PATTERNS
18220: *
18221: * (XL) PTR TO RIGHT PATTERN
18222: * (XR) PTR TO LEFT PATTERN
18223: * JSR PCONC CALL TO CONCATENATE PATTERNS
18224: * (XR) PTR TO CONCATENATED PATTERN
18225: * (XL,WA,WB,WC) DESTROYED
18226: *
18227: *
18228: * TO CONCATENATE TWO PATTERNS, ALL SUCCESSORS IN THE LEFT
18229: * PATTERN WHICH POINT TO THE NOTHEN NODE MUST BE CHANGED TO
18230: * POINT TO THE RIGHT PATTERN. HOWEVER, THIS MODIFICATION
18231: * MUST BE PERFORMED ON A COPY OF THE LEFT ARGUMENT RATHER
18232: * THAN THE LEFT ARGUMENT ITSELF, SINCE THE LEFT ARGUMENT
18233: * MAY BE POINTED TO BY SOME OTHER VARIABLE VALUE.
18234: *
18235: * ACCORDINGLY, IT IS NECESSARY TO COPY THE LEFT ARGUMENT.
18236: * THIS IS NOT A TRIVIAL PROCESS SINCE WE MUST AVOID COPYING
18237: * NODES MORE THAN ONCE AND THE PATTERN IS A GRAPH STRUCTURE
18238: * THE FOLLOWING ALGORITHM IS EMPLOYED.
18239: *
18240: * THE STACK IS USED TO STORE A LIST OF NODES WHICH
18241: * HAVE ALREADY BEEN COPIED. THE FORMAT OF THE ENTRIES ON
18242: * THIS LIST CONSISTS OF A TWO WORD BLOCK. THE FIRST WORD
18243: * IS THE OLD ADDRESS AND THE SECOND WORD IS THE ADDRESS
18244: * OF THE COPY. THIS LIST IS SEARCHED BY THE PCOPY
18245: * ROUTINE TO AVOID MAKING DUPLICATE COPIES. A TRICK IS
18246: * USED TO ACCOMPLISH THE CONCATENATION AT THE SAME TIME.
18247: * A SPECIAL ENTRY IS MADE TO START WITH ON THE STACK. THIS
18248: * ENTRY RECORDS THAT THE NOTHEN NODE HAS BEEN COPIED
18249: * ALREADY AND THE ADDRESS OF ITS COPY IS THE RIGHT PATTERN.
18250: * THIS AUTOMATICALLY PERFORMS THE CORRECT REPLACEMENTS.
18251: *
18252: PCONC PRC E,0 ENTRY POINT
18253: ZER -(XS) MAKE ROOM FOR ONE ENTRY AT BOTTOM
18254: MOV XS,WC STORE POINTER TO START OF LIST
18255: MOV =NDNTH,-(XS) STACK NOTHEN NODE AS OLD NODE
18256: MOV XL,-(XS) STORE RIGHT ARG AS COPY OF NOTHEN
18257: MOV XS,XT INITIALIZE POINTER TO STACK ENTRIES
18258: JSR PCOPY COPY FIRST NODE OF LEFT ARG
18259: MOV WA,2(XT) STORE AS RESULT UNDER LIST
18260: EJC
18261: *
18262: * PCONC (CONTINUED)
18263: *
18264: * THE FOLLOWING LOOP SCANS ENTRIES IN THE LIST AND MAKES
18265: * SURE THAT THEIR SUCCESSORS HAVE BEEN COPIED.
18266: *
18267: PCNC1 BEQ XT,XS,PCNC2 JUMP IF ALL ENTRIES PROCESSED
18268: MOV -(XT),XR ELSE LOAD NEXT OLD ADDRESS
18269: MOV PTHEN(XR),XR LOAD POINTER TO SUCCESSOR
18270: JSR PCOPY COPY SUCCESSOR NODE
18271: MOV -(XT),XR LOAD POINTER TO NEW NODE (COPY)
18272: MOV WA,PTHEN(XR) STORE PTR TO NEW SUCCESSOR
18273: *
18274: * NOW CHECK FOR SPECIAL CASE OF ALTERNATION NODE WHERE
18275: * PARM1 POINTS TO A NODE AND MUST BE COPIED LIKE PTHEN.
18276: *
18277: BNE (XR),=P$ALT,PCNC1 LOOP BACK IF NOT
18278: MOV PARM1(XR),XR ELSE LOAD POINTER TO ALTERNATIVE
18279: JSR PCOPY COPY IT
18280: MOV (XT),XR RESTORE PTR TO NEW NODE
18281: MOV WA,PARM1(XR) STORE PTR TO COPIED ALTERNATIVE
18282: BRN PCNC1 LOOP BACK FOR NEXT ENTRY
18283: *
18284: * HERE AT END OF COPY PROCESS
18285: *
18286: PCNC2 MOV WC,XS RESTORE STACK POINTER
18287: MOV (XS)+,XR LOAD POINTER TO COPY
18288: EXI RETURN TO PCONC CALLER
18289: ENP END PROCEDURE PCONC
18290: EJC
18291: *
18292: * PCOPY -- COPY A PATTERN NODE
18293: *
18294: * PCOPY IS CALLED FROM THE PCONC PROCEDURE TO COPY A SINGLE
18295: * PATTERN NODE. THE COPY IS ONLY CARRIED OUT IF THE NODE
18296: * HAS NOT BEEN COPIED ALREADY.
18297: *
18298: * (XR) POINTER TO NODE TO BE COPIED
18299: * (XT) PTR TO CURRENT LOC IN COPY LIST
18300: * (WC) POINTER TO LIST OF COPIED NODES
18301: * JSR PCOPY CALL TO COPY A NODE
18302: * (WA) POINTER TO COPY
18303: * (WB,XR) DESTROYED
18304: *
18305: PCOPY PRC N,0 ENTRY POINT
18306: MOV XT,WB SAVE XT
18307: MOV WC,XT POINT TO START OF LIST
18308: *
18309: * LOOP TO SEARCH LIST OF NODES COPIED ALREADY
18310: *
18311: PCOP1 DCA XT POINT TO NEXT ENTRY ON LIST
18312: BEQ XR,(XT),PCOP2 JUMP IF MATCH
18313: DCA XT ELSE SKIP OVER COPIED ADDRESS
18314: BNE XT,XS,PCOP1 LOOP BACK IF MORE TO TEST
18315: *
18316: * HERE IF NOT IN LIST, PERFORM COPY
18317: *
18318: MOV (XR),WA LOAD FIRST WORD OF BLOCK
18319: JSR BLKLN GET LENGTH OF BLOCK
18320: MOV XR,XL SAVE POINTER TO OLD NODE
18321: JSR ALLOC ALLOCATE SPACE FOR COPY
18322: MOV XL,-(XS) STORE OLD ADDRESS ON LIST
18323: MOV XR,-(XS) STORE NEW ADDRESS ON LIST
18324: CHK CHECK FOR STACK OVERFLOW
18325: MVW MOVE WORDS FROM OLD BLOCK TO COPY
18326: MOV (XS),WA LOAD POINTER TO COPY
18327: BRN PCOP3 JUMP TO EXIT
18328: *
18329: * HERE IF WE FIND ENTRY IN LIST
18330: *
18331: PCOP2 MOV -(XT),WA LOAD ADDRESS OF COPY FROM LIST
18332: *
18333: * COMMON EXIT POINT
18334: *
18335: PCOP3 MOV WB,XT RESTORE XT
18336: EXI RETURN TO PCOPY CALLER
18337: ENP END PROCEDURE PCOPY
18338: .IF .CNPF
18339: .ELSE
18340: EJC
18341: *
18342: * PRFLR -- PRINT PROFILE
18343: * PRFLR IS CALLED TO PRINT THE CONTENTS OF THE PROFILE
18344: * TABLE IN A FAIRLY READABLE TABULAR FORMAT.
18345: *
18346: * JSR PRFLR CALL TO PRINT PROFILE
18347: * (WA,IA) DESTROYED
18348: *
18349: PRFLR PRC E,0
18350: BZE PFDMP,PRFL4 NO PRINTING IF NO PROFILING DONE
18351: MOV XR,-(XS) PRESERVE ENTRY XR
18352: MOV WB,PFSVW AND ALSO WB
18353: JSR PRTPG EJECT
18354: MOV =PFMS1,XR LOAD MSG /PROGRAM PROFILE/
18355: JSR PRTFB AND PRINT IT
18356: MOV =PFMS2,XR POINT TO FIRST HDR
18357: JSR PRTSF PRINT IT
18358: MOV =PFMS3,XR SECOND HDR
18359: JSR PRTFB
18360: ZER WB INITIAL STMT COUNT
18361: MOV PFTBL,XR POINT TO TABLE ORIGIN
18362: ADD *NUM02,XR BIASS PAST XNBLK HEADER
18363: EJC
18364: *
18365: * PRFLR (CONTINUED)
18366: *
18367: * LOOP FOR PRINTING TABLE ENTRIES
18368: *
18369: PRFL1 ICV WB BUMP STMT NR
18370: LDI (XR) LOAD NR OF EXECUTIONS
18371: IEQ PRFL3 NO PRINTING IF ZERO
18372: MOV =PFPD1,PROFS POINT WHERE TO PRINT
18373: JSR PRTIN AND PRINT IT
18374: ZER PROFS BACK TO START OF LINE
18375: MTI WB LOAD STMT NR
18376: JSR PRTIN PRINT IT THERE
18377: MOV =PFPD2,PROFS AND PAD PAST COUNT
18378: LDI CFP$I(XR) LOAD TOTAL EXEC TIME
18379: JSR PRTIN PRINT THAT TOO
18380: LDI CFP$I(XR) RELOAD TIME
18381: MLI INTTH CONVERT TO MICROSEC
18382: IOV PRFL2 OMIT NEXT BIT IF OVERFLOW
18383: DVI (XR) DIVIDE BY EXECUTIONS
18384: MOV =PFPD3,PROFS PAD LAST PRINT
18385: JSR PRTIN AND PRINT MCSEC/EXECN
18386: *
18387: * PRINT A BLANK
18388: *
18389: PRFL2 JSR PRTFH THATS ANOTHER LINE
18390: *
18391: * TEST TO SEE IF LOOP FINISHED
18392: *
18393: PRFL3 ADD *PF$I2,XR BUMP INDEX POINTER
18394: BLT WB,PFNTE,PRFL1 LOOP IF MORE STMTS
18395: MOV (XS)+,XR RESTORE CALLERS XR
18396: MOV PFSVW,WB AND WB TOO
18397: *
18398: * RETURN POINT
18399: *
18400: PRFL4 EXI RETURN
18401: ENP END OF PRFLR
18402: EJC
18403: *
18404: * PRFLU -- UPDATE AN ENTRY IN THE PROFILE TABLE
18405: *
18406: * ON ENTRY, KVSTN CONTAINS NR OF STMT TO PROFILE
18407: *
18408: * JSR PRFLU CALL TO UPDATE ENTRY
18409: * (IA) DESTROYED
18410: *
18411: PRFLU PRC E,0
18412: BNZ PFFNC,PFLU4 SKIP IF JUST ENTERED FUNCTION
18413: MOV XR,-(XS) PRESERVE ENTRY XR
18414: MOV WA,PFSVW SAVE WA
18415: BNZ PFTBL,PFLU2 BRANCH IF TABLE ALLOCATED
18416: *
18417: * HERE IF SPACE FOR PROFILE TABLE NOT YET ALLOCATED.
18418: * CALCULATE SIZE NEEDED, ALLOCATE A STATIC XNBLK, AND
18419: * INITIALIZE IT ALL TO ZERO.
18420: * THE TIME TAKEN FOR THIS WILL BE ATTRIBUTED TO THE CURRENT
18421: * STATEMENT (ASSIGNMENT TO KEYWD PROFILE), BUT SINCE THE
18422: * TIMING FOR THIS STATEMENT IS UP THE POLE ANYWAY, THIS
18423: * DOESNT REALLY MATTER...
18424: *
18425: SUB =NUM01,PFNTE ADJUST FOR EXTRA COUNT
18426: MTI PFI2A CONVRT ENTRY SIZE TO INT
18427: STI PFSTE AND STORE SAFELY FOR LATER
18428: MTI PFNTE LOAD TABLE LENGTH AS INTEGER
18429: MLI PFSTE MULTIPLY BY ENTRY SIZE
18430: MFI WA GET BACK ADDRESS-STYLE
18431: ADD =NUM02,WA ADD ON 2 WORD OVERHEAD
18432: WTB WA CONVERT THE WHOLE LOT TO BYTES
18433: JSR ALOST GIMME THE SPACE
18434: MOV XR,PFTBL SAVE BLOCK POINTER
18435: MOV =B$XNT,(XR)+ PUT BLOCK TYPE AND ...
18436: MOV WA,(XR)+ ... LENGTH INTO HEADER
18437: MFI WA GET BACK NR OF WDS IN DATA AREA
18438: LCT WA,WA LOAD THE COUNTER
18439: *
18440: * LOOP HERE TO ZERO THE BLOCK DATA
18441: *
18442: PFLU1 ZER (XR)+ BLANK A WORD
18443: BCT WA,PFLU1 AND ALL THE REST
18444: EJC
18445: *
18446: * PRFLU (CONTINUED)
18447: *
18448: * END OF ALLOCATION. MERGE BACK INTO ROUTINE
18449: *
18450: PFLU2 MTI KVSTN LOAD NR OF STMT JUST ENDED
18451: SBI INTV1 MAKE INTO INDEX OFFSET
18452: MLI PFSTE MAKE OFFSET OF TABLE ENTRY
18453: MFI WA CONVERT TO ADDRESS
18454: WTB WA GET AS BAUS
18455: ADD *NUM02,WA OFFSET INCLUDES TABLE HEADER
18456: MOV PFTBL,XR GET TABLE START
18457: BGE WA,NUM01(XR),PFLU3 IF OUT OF TABLE, SKIP IT
18458: ADD WA,XR ELSE POINT TO ENTRY
18459: LDI (XR) GET NR OF EXECUTIONS SO FAR
18460: ADI INTV1 NUDGE UP ONE
18461: STI (XR) AND PUT BACK
18462: JSR SYSTM GET TIME NOW
18463: STI PFETM STASH ENDING TIME
18464: SBI PFSTM SUBTRACT START TIME
18465: ADI CFP$I(XR) ADD CUMULATIVE TIME SO FAR
18466: STI CFP$I(XR) AND PUT BACK NEW TOTAL
18467: LDI PFETM LOAD END TIME OF THIS STMT ...
18468: STI PFSTM ... WHICH IS START TIME OF NEXT
18469: *
18470: * RETURN POINT
18471: *
18472: PFLU3 MOV (XS)+,XR RESTORE CALLERS XR
18473: MOV PFSVW,WA RESTORE WA
18474: EXI AND RETURN
18475: *
18476: * HERE IF PROFILE IS SUPPRESSED BECAUSE A PROGRAM DEFINED
18477: * FUNCTION IS ABOUT TO BE ENTERED, AND SO THE CURRENT STMT
18478: * HAS NOT YET FINISHED
18479: *
18480: PFLU4 ZER PFFNC RESET THE CONDITION FLAG
18481: EXI AND IMMEDIATE RETURN
18482: ENP END OF PROCEDURE PRFLU
18483: .FI
18484: EJC
18485: *
18486: * PRPAR -- PROCESS PRINT PARAMETERS
18487: *
18488: * JSR PRPAR CALL TO PROCESS PRINT PARAMETERS
18489: * (XR,WA,WB,WC) DESTROYED
18490: *
18491: PRPAR PRC E,0 ENTRY POINT
18492: MOV XL,-(XS) SAVE XL
18493: JSR SYSPP GET PRINT PARAMETERS
18494: BNZ WB,PRPA1 JUMP IF LINES/PAGE SPECIFIED
18495: MOV =CFP$M,WB ELSE USE A LARGE VALUE
18496: RSH WB,1 BUT NOT TOO LARGE
18497: *
18498: * STORE LINE COUNT/PAGE
18499: *
18500: PRPA1 MOV WB,LSTNP STORE NUMBER OF LINES/PAGE
18501: MOV WB,LSTLC PRETEND PAGE IS FULL INITIALLY
18502: ZER LSTPG CLEAR PAGE NUMBER
18503: BZE PRLEN,PRPA2 SKIP IF NOT SYSXI RESUMPTION
18504: BHI WA,PRLEN,PRPA3 SKIP IF BIGGER THAN PRIOR BFRS
18505: *
18506: * STORE PRINT BUFFER LENGTH
18507: *
18508: PRPA2 MOV WA,PRLEN STORE VALUE
18509: *
18510: * CHECK TERMINAL BUFFER SIZE
18511: *
18512: PRPA3 BZE TTLEN,PRPA4 SKIP IF NOT SYSXI RESUMPTION
18513: BHI XL,TTLEN,PRPA5 SKIP IF TOO BIG
18514: *
18515: * STORE TERMINAL BUFFER LENGTH
18516: *
18517: PRPA4 MOV XL,TTLEN BFR LENGTH
18518: *
18519: * PROCESS BITS OPTIONS
18520: *
18521: PRPA5 MOV BITS1,WB BIT 1 MASK
18522: ANB WC,WB GET BIT
18523: MOV WB,TTINS INPUT FROM TERMINAL FLAG
18524: MOV BITS2,WB BIT 2 MASK
18525: ANB WC,WB GET BIT
18526: MOV WB,TTOUS STD OUTPUT TO TERMINAL FLAG
18527: MOV TTLEN,TTERL ERRORS TO TERML IF AVAILABLE
18528: MOV PRLEN,PRAVL NOTE IF A PRINT FILE IS AVAILABLE
18529: ZRB WB,PRPA6 IF FLAG SET, CLEAR TTERL SINCE ...
18530: ZER TTERL ... TERML GETS ALL OUTPUT ALREADY
18531: MOV TTLEN,TTOUS REGULAR O/P TO TERML IF AVAILABLE
18532: MOV TTLEN,PRLEN REVISED PRINT BUFFER LENGTH
18533: ZER TTLEN DONT NEED SEPARATE TERML BUFFER
18534: EJC
18535: *
18536: * PRPAR (CONTINUED)
18537: *
18538: * GET OFFSET TO /PAGE NN/ PART OF HEADER
18539: *
18540: PRPA6 MOV PRLEN,WA STD BFR LENGTH
18541: BNZ WA,PRPA7 USE IF NON-ZERO
18542: MOV TTLEN,WA ELSE TRY TERMINAL
18543: BZE WA,PRPA8 GIVE UP IF ZERO ALSO
18544: *
18545: * GET OFFSET
18546: *
18547: PRPA7 MOV WA,PRLEN STORE AS BUFFER LENGTH
18548: SUB =NUM08,WA JUST BEFORE END OF LINE
18549: MOV WA,LSTPO KEEP IT
18550: MOV TTOUS,WB CONSTRUCT VALUE FOR ...
18551: ORB PRAVL,WB ... USE IN DECIDING WHETHER TO ...
18552: MOV WB,PRPUT ... PUT STRINGS IN OUTPUT BUFFER
18553: *
18554: * MORE BITS
18555: *
18556: PRPA8 MOV BITS3,WB BIT 3 MASK
18557: ANB WC,WB GET -NOLIST BIT
18558: ZRB WB,PRPA9 SKIP IF CLEAR
18559: ZER CSWLS SET -NOLIST
18560: *
18561: * MORE BITS
18562: *
18563: PRPA9 MOV BITS4,WB BIT 4 MASK
18564: ANB WC,WB GET BIT
18565: MOV WB,CPSTS FLAG FOR COMPILE STATS SUPPRESSN.
18566: MOV BITS5,WB BIT 5 MASK
18567: ANB WC,WB GET BIT
18568: MOV WB,EXSTS FLAG FOR EXEC STATS SUPPRESSION
18569: MOV BITS6,WB BIT 6 MASK
18570: ANB WC,WB GET BIT
18571: MOV WB,NOXEQ SET NOEXECUTE IF NON-ZERO
18572: MOV BITS7,WB BIT 7 MASK
18573: ANB WC,WB GET BIT
18574: ZRB WB,PRP10 SKIP IF NOT SET
18575: ZER TTERL CLEAR ERRORS TO TERML IF SET
18576: *
18577: * MORE BITS
18578: *
18579: PRP10 MOV BITS8,WB BIT 8 MASK
18580: ANB WC,WB GET BIT
18581: MOV WB,HEADN SYSID HEADERS INCLUDE/OMIT FLAG
18582: MOV BITS9,WB BIT 9 MASK
18583: ANB WC,WB GET BIT
18584: MOV WB,PRSTO STANDARD LISTING FLAG
18585: MOV BIT10,WB BIT 10 MASK
18586: ANB WC,WB GET BIT
18587: MOV WB,PRECL EXTENDED LISTING OPTION
18588: MOV (XS)+,XL RESTORE XL
18589: EXI RETURN
18590: ENP END PROCEDURE PRPAR
18591: EJC
18592: *
18593: * PRTCF -- PRINT CHAR TO STD PRINTER AND FLUSH BFR
18594: *
18595: * (WA) CHAR TO PRINT
18596: * JSR PRTCF CALL TO PRINT AND FLUSH
18597: *
18598: PRTCF PRC E,0 ENTRY POINT
18599: JSR PRTCH PRINT CHARACTER
18600: JSR PRTFH FLUSH BUFFER
18601: EXI RETURN TO CALLER
18602: ENP END PROCEDURE PRTCF
18603: *
18604: * PRTCH -- PRINT A CHARACTER ON STANDARD PRINTER
18605: *
18606: * PRTCH IS USED TO PRINT A SINGLE CHARACTER
18607: *
18608: * (WA) CHARACTER TO BE PRINTED
18609: * JSR PRTCH CALL TO PRINT CHARACTER
18610: *
18611: PRTCH PRC E,0 ENTRY POINT
18612: BZE PRLEN,PTCH2 SKIP IF NO PRINT FILE
18613: MOV XR,-(XS) SAVE XR
18614: BNE PROFS,PRLEN,PTCH1 JUMP IF ROOM IN BUFFER
18615: JSR PRTFH ELSE PRINT THIS LINE
18616: *
18617: * HERE AFTER MAKING SURE WE HAVE ROOM
18618: *
18619: PTCH1 MOV PRBUF,XR POINT TO PRINT BUFFER
18620: PSC XR,PROFS POINT TO NEXT CHARACTER LOCATION
18621: SCH WA,(XR) STORE NEW CHARACTER
18622: CSC XR COMPLETE STORE CHARACTERS
18623: ICV PROFS BUMP POINTER
18624: MOV (XS)+,XR RESTORE ENTRY XR
18625: *
18626: * RETURN POINT
18627: *
18628: PTCH2 EXI RETURN TO PRTCH CALLER
18629: ENP END PROCEDURE PRTCH
18630: *
18631: * PRTFB -- PRINT STRING, FLUSH BFR AND PRINT BLANK LINE
18632: *
18633: * (XR) STRING TO PRINT
18634: * JSR PRTFB CALL FOR PRINT FLUSH AND BLANK
18635: *
18636: PRTFB PRC E,0 ENTRY POINT
18637: JSR PRTSF PRINT AND FLUSH
18638: JSR PRTFH PRINT BLANK
18639: EXI RETURN TO CALLER
18640: ENP END PROCEDURE PRTFB
18641: EJC
18642: *
18643: * PRTFH -- FLUSH STANDARD PRINT BUFFER
18644: *
18645: * PRTFH PRINTS THE CONTENTS OF THE PRINT BUFFER, RESETS
18646: * THE BUFFER TO ALL BLANKS AND RESETS THE PRINT POINTER.
18647: * ON ITS FIRST CALL IT MAY PRINT LISTING HEADERS.
18648: * IF TTLST IS NON-ZERO, IT COPIES PRINT BUFFER TO
18649: * TERMINAL AND FLUSHES THIS ALSO.
18650: *
18651: * JSR PRTFH CALL TO FLUSH BUFFER
18652: *
18653: PRTFH PRC R,0 ENTRY POINT
18654: BNZ HEADP,PTFH1 WERE HEADERS PRINTED
18655: JSR PRTPS NO - PRINT THEM
18656: *
18657: * HEADERS DONE
18658: *
18659: PTFH1 BZE PRLEN,PTFH4 SKIP IF NO OUTPUT POSSIBLE
18660: MOV XL,-(XS) SAVE XL
18661: MOV XR,-(XS) SAVE XR
18662: MOV WA,-(XS) SAVE WA
18663: MOV WC,-(XS) SAVE WC
18664: MOV PRBUF,XR LOAD POINTER TO BUFFER
18665: MOV PROFS,WC LOAD NUMBER OF CHARS IN BUFFER
18666: BNZ PRAVL,PTFH5 SKIP IF PRINT FILE AVAILABLE
18667: BNZ TTOUS,PTFH2 SKIP IF STD OUTPUT TO TERML
18668: BZE TTLST,PTFH3 LAST POSSIBILITY IS ERROR TO TERML
18669: *
18670: * SEND TO TERMINAL
18671: *
18672: PTFH2 JSR SYSPI PRINT TO TERMINAL
18673: PPM PTFH6 FAIL
18674: PPM EROSI ERROR
18675: EJC
18676: * PRTFH (CONTINUED)
18677: *
18678: * BLANK BUFFER
18679: *
18680: PTFH3 MOV PRBLK,XL POINT TO BLANKING STRING
18681: MOV PRCHS,XR POINT TO BUFFER
18682: MOV PRCMV,WA COUNT OF BAUS TO MOVE
18683: MVW MOVE BLANKS INTO BUFFER
18684: ZER PROFS RESET OFFSET
18685: MOV (XS)+,WC RESTORE WC
18686: MOV (XS)+,WA RECOVER WA
18687: MOV (XS)+,XR RESTORE XR
18688: MOV (XS)+,XL RESTORE XL
18689: *
18690: * RETURN POINT
18691: *
18692: PTFH4 EXI RETURN TO CALLER
18693: *
18694: * HERE FOR REGULAR PRINT FILE
18695: *
18696: PTFH5 JSR SYSPR CALL SYSTEM PRINT ROUTINE
18697: PPM PTFH6 JUMP IF FAILED
18698: PPM EROSI STOP IF ERROR
18699: BZE TTLST,PTFH3 SKIP IF NO COPY TO TERMINAL
18700: MOV PROFS,SCLEN(XR) SET STRING LENGTH FOR PTTST
18701: JSR PTTST COPY STD BUFFER TO TERML BFR
18702: JSR PTTFH FLUSH IT
18703: MOV PRLEN,SCLEN(XR) RESTORE BUFFER LENGTH
18704: BRN PTFH3 MERGE
18705: *
18706: * A FAILURE SUCH AS FILE OVERFILLED OCCURRED
18707: *
18708: PTFH6 BZE STAGX,PTFH3 IGNORE IF COMPILE TIME
18709: BRN EXFAL ELSE CAUSE STMT FAILURE
18710: ENP END PROCEDURE PRTFH
18711: EJC
18712: *
18713: * PRTIN -- PRINT AN INTEGER
18714: *
18715: * PRTIN PRINTS THE INTEGER VALUE WHICH IS IN THE INTEGER
18716: * ACCUMULATOR. BLOCKS BUILT IN DYNAMIC STORAGE
18717: * DURING THIS PROCESS ARE IMMEDIATELY DELETED.
18718: *
18719: * (IA) INTEGER VALUE TO BE PRINTED
18720: * JSR PRTIN CALL TO PRINT INTEGER
18721: * (IA,RA) DESTROYED
18722: *
18723: PRTIN PRC E,0 ENTRY POINT
18724: MOV XR,-(XS) SAVE XR
18725: JSR ICBLD BUILD INTEGER BLOCK
18726: BLO XR,DNAMB,PRTI1 JUMP IF ICBLK BELOW DYNAMIC
18727: BHI XR,DNAMP,PRTI1 JUMP IF ABOVE DYNAMIC
18728: MOV XR,DNAMP IMMEDIATELY DELETE IT
18729: *
18730: * DELETE ICBLK FROM DYNAMIC STORE
18731: *
18732: PRTI1 MOV XR,-(XS) STACK PTR FOR GTSTG
18733: JSR GTSTG CONVERT TO STRING
18734: PPM CONVERT ERROR IS IMPOSSIBLE
18735: MOV XR,DNAMP RESET POINTER TO DELETE SCBLK
18736: JSR PRTST PRINT INTEGER STRING
18737: MOV (XS)+,XR RESTORE ENTRY XR
18738: EXI RETURN TO PRTIN CALLER
18739: ENP END PROCEDURE PRTIN
18740: *
18741: * PRTMI -- PRINT MESSAGE AND INTEGER
18742: *
18743: * PRTMI IS USED TO PRINT MESSAGES TOGETHER WITH AN INTEGER
18744: * VALUE STARTING IN COLUMN 15 (USED BY THE ROUTINES AT
18745: * THE END OF COMPILATION).
18746: *
18747: * JSR PRTMI CALL TO PRINT MESSAGE AND INTEGER
18748: *
18749: PRTMI PRC E,0 ENTRY POINT
18750: JSR PRTST PRINT STRING MESSAGE
18751: MOV =PRTMF,PROFS SET OFFSET TO COL 15
18752: JSR PRTIN PRINT INTEGER
18753: JSR PRTFH PRINT LINE
18754: EXI RETURN TO PRTMI CALLER
18755: ENP END PROCEDURE PRTMI
18756: EJC
18757: *
18758: * PRTNM -- PRINT VARIABLE NAME
18759: *
18760: * PRTNM IS USED TO PRINT A CHARACTER REPRESENTATION OF THE
18761: * NAME OF A VARIABLE (NOT A VALUE OF DATATYPE NAME)
18762: * NAMES OF PSEUDO-VARIABLES MAY NOT BE PASSED TO PRTNM.
18763: *
18764: * (XL) NAME BASE
18765: * (WA) NAME OFFSET
18766: * JSR PRTNM CALL TO PRINT NAME
18767: * (WB,WC,RA) DESTROYED
18768: *
18769: PRTNM PRC R,0 ENTRY POINT (RECURSIVE, SEE PRTVL)
18770: MOV WA,-(XS) SAVE WA (OFFSET IS COLLECTABLE)
18771: MOV XR,-(XS) SAVE ENTRY XR
18772: MOV XL,-(XS) SAVE NAME BASE
18773: BHI XL,STATE,PRN02 JUMP IF NOT NATURAL VARIABLE
18774: *
18775: * HERE FOR NATURAL VARIABLE NAME, RECOGNIZED BY THE FACT
18776: * THAT THE NAME BASE POINTS INTO THE STATIC AREA.
18777: *
18778: MOV XL,XR POINT TO VRBLK
18779: JSR PRTVN PRINT NAME OF VARIABLE
18780: *
18781: * COMMON EXIT POINT
18782: *
18783: PRN01 MOV (XS)+,XL RESTORE NAME BASE
18784: MOV (XS)+,XR RESTORE ENTRY VALUE OF XR
18785: MOV (XS)+,WA RESTORE WA
18786: EXI RETURN TO PRTNM CALLER
18787: *
18788: * HERE FOR CASE OF NON-NATURAL VARIABLE
18789: *
18790: PRN02 MOV WA,WB COPY NAME OFFSET
18791: BNE (XL),=B$PDT,PRN03 JUMP IF ARRAY OR TABLE
18792: *
18793: * FOR PROGRAM DEFINED DATATYPE, PRT FLD NAME, LEFT PAREN
18794: *
18795: MOV PDDFP(XL),XR LOAD POINTER TO DFBLK
18796: ADD WA,XR ADD NAME OFFSET
18797: MOV PDFOF(XR),XR LOAD VRBLK POINTER FOR FIELD
18798: JSR PRTVN PRINT FIELD NAME
18799: MOV =CH$PP,WA LOAD LEFT PAREN
18800: JSR PRTCH PRINT CHARACTER
18801: EJC
18802: *
18803: * PRTNM (CONTINUED)
18804: *
18805: * NOW WE PRINT AN IDENTIFYING NAME FOR THE OBJECT IF ONE
18806: * CAN BE FOUND. THE FOLLOWING CODE SEARCHES FOR A NATURAL
18807: * VARIABLE WHICH CONTAINS THIS OBJECT AS VALUE. IF SUCH A
18808: * VARIABLE IS FOUND, ITS NAME IS PRINTED, ELSE THE VALUE
18809: * OF THE OBJECT (AS PRINTED BY PRTVL) IS USED INSTEAD.
18810: *
18811: * FIRST WE POINT TO THE PARENT TBBLK IF THIS IS THE CASE OF
18812: * A TABLE ELEMENT. TO DO THIS, CHASE DOWN THE TRNXT CHAIN.
18813: *
18814: PRN03 BNE (XL),=B$TET,PRN04 JUMP IF WE GOT THERE (OR NOT TE)
18815: MOV TENXT(XL),XL ELSE MOVE OUT ON CHAIN
18816: BRN PRN03 AND LOOP BACK
18817: *
18818: * NOW WE ARE READY FOR THE SEARCH. TO SPEED THINGS UP IN
18819: * THE CASE OF CALLS FROM DUMP WHERE THE SAME NAME BASE
18820: * WILL OCCUR REPEATEDLY WHILE DUMPING AN ARRAY OR TABLE,
18821: * WE REMEMBER THE LAST VRBLK POINTER FOUND IN PRNMV. SO
18822: * FIRST CHECK TO SEE IF WE HAVE THIS ONE AGAIN.
18823: *
18824: PRN04 MOV PRNMV,XR POINT TO VRBLK WE FOUND LAST TIME
18825: MOV HSHTB,WA POINT TO HASH TABLE IN CASE NOT
18826: BRN PRN07 JUMP INTO SEARCH FOR SPECIAL CHECK
18827: *
18828: * LOOP THROUGH HASH SLOTS
18829: *
18830: PRN05 MOV WA,XR COPY SLOT POINTER
18831: ICA WA BUMP SLOT POINTER
18832: SUB *VRNXT,XR INTRODUCE STANDARD VRBLK OFFSET
18833: *
18834: * LOOP THROUGH VRBLKS ON ONE HASH CHAIN
18835: *
18836: PRN06 MOV VRNXT(XR),XR POINT TO NEXT VRBLK ON HASH CHAIN
18837: *
18838: * MERGE HERE FIRST TIME TO CHECK BLOCK WE FOUND LAST TIME
18839: *
18840: PRN07 MOV XR,WC COPY VRBLK POINTER
18841: BZE WC,PRN09 JUMP IF CHAIN END (OR PRNMV ZERO)
18842: EJC
18843: *
18844: * PRTNM (CONTINUED)
18845: *
18846: * LOOP TO FIND VALUE (CHASE DOWN POSSIBLE TRBLK CHAIN)
18847: *
18848: PRN08 MOV VRVAL(XR),XR LOAD VALUE
18849: BEQ (XR),=B$TRT,PRN08 LOOP IF THAT WAS A TRBLK
18850: *
18851: * NOW WE HAVE THE VALUE, IS THIS THE BLOCK WE WANT
18852: *
18853: BEQ XR,XL,PRN10 JUMP IF THIS MATCHES THE NAME BASE
18854: MOV WC,XR ELSE POINT BACK TO THAT VRBLK
18855: BRN PRN06 AND LOOP BACK
18856: *
18857: * HERE TO MOVE TO NEXT HASH SLOT
18858: *
18859: PRN09 BLT WA,HSHTE,PRN05 LOOP BACK IF MORE TO GO
18860: MOV XL,XR ELSE NOT FOUND, COPY VALUE POINTER
18861: JSR PRTVL PRINT VALUE
18862: BRN PRN11 AND MERGE AHEAD
18863: *
18864: * HERE WHEN WE FIND A MATCHING ENTRY
18865: *
18866: PRN10 MOV WC,XR COPY VRBLK POINTER
18867: MOV XR,PRNMV SAVE FOR NEXT TIME IN
18868: JSR PRTVN PRINT VARIABLE NAME
18869: *
18870: * MERGE HERE IF NO ENTRY FOUND
18871: *
18872: PRN11 MOV (XL),WC LOAD FIRST WORD OF NAME BASE
18873: BNE WC,=B$PDT,PRN13 JUMP IF NOT PROGRAM DEFINED
18874: *
18875: * FOR PROGRAM DEFINED DATATYPE, ADD RIGHT PAREN AND EXIT
18876: *
18877: MOV =CH$RP,WA LOAD RIGHT PAREN, MERGE
18878: *
18879: * MERGE HERE TO PRINT FINAL RIGHT PAREN OR BRACKET
18880: *
18881: PRN12 JSR PRTCH PRINT FINAL CHARACTER
18882: MOV WB,WA RESTORE NAME OFFSET
18883: BRN PRN01 MERGE BACK TO EXIT
18884: EJC
18885: *
18886: * PRTNM (CONTINUED)
18887: *
18888: * HERE FOR ARRAY OR TABLE
18889: *
18890: PRN13 MOV =CH$BB,WA LOAD LEFT BRACKET
18891: JSR PRTCH AND PRINT IT
18892: MOV (XS),XL RESTORE BLOCK POINTER
18893: MOV (XL),WC LOAD TYPE WORD AGAIN
18894: BNE WC,=B$TET,PRN15 JUMP IF NOT TABLE
18895: *
18896: * HERE FOR TABLE, PRINT SUBSCRIPT VALUE
18897: *
18898: MOV TESUB(XL),XR LOAD SUBSCRIPT VALUE
18899: MOV WB,XL SAVE NAME OFFSET
18900: JSR PRTVL PRINT SUBSCRIPT VALUE
18901: MOV XL,WB RESTORE NAME OFFSET
18902: *
18903: * MERGE HERE FROM ARRAY CASE TO PRINT RIGHT BRACKET
18904: *
18905: PRN14 MOV =CH$RB,WA LOAD RIGHT BRACKET
18906: BRN PRN12 MERGE BACK TO PRINT IT
18907: *
18908: * HERE FOR ARRAY OR VECTOR, TO PRINT SUBSCRIPT(S)
18909: *
18910: PRN15 MOV WB,WA COPY NAME OFFSET
18911: BTW WA CONVERT TO WORDS
18912: BEQ WC,=B$ART,PRN16 JUMP IF ARBLK
18913: *
18914: * HERE FOR VECTOR
18915: *
18916: SUB =VCVLB,WA ADJUST FOR STANDARD FIELDS
18917: MTI WA MOVE TO INTEGER ACCUM
18918: JSR PRTIN PRINT LINEAR SUBSCRIPT
18919: BRN PRN14 MERGE BACK FOR RIGHT BRACKET
18920: EJC
18921: *
18922: * PRTNM (CONTINUED)
18923: *
18924: * HERE FOR ARRAY. FIRST CALCULATE ABSOLUTE SUBSCRIPT
18925: * OFFSETS BY SUCCESSIVE DIVISIONS BY THE DIMENSION VALUES.
18926: * THIS MUST BE DONE RIGHT TO LEFT SINCE THE ELEMENTS ARE
18927: * STORED ROW-WISE. THE SUBSCRIPTS ARE STACKED AS INTEGERS.
18928: *
18929: PRN16 MOV AROFS(XL),WC LOAD LENGTH OF BOUNDS INFO
18930: ICA WC ADJUST FOR ARPRO FIELD
18931: BTW WC CONVERT TO WORDS
18932: SUB WC,WA GET LINEAR ZERO-ORIGIN SUBSCRIPT
18933: MTI WA GET INTEGER VALUE
18934: LCT WA,ARNDM(XL) SET NUM OF DIMENSIONS AS LOOP COUNT
18935: ADD AROFS(XL),XL POINT PAST BOUNDS INFORMATION
18936: SUB *ARLBD,XL SET OK OFFSET FOR PROPER PTR LATER
18937: *
18938: * LOOP TO STACK SUBSCRIPT OFFSETS
18939: *
18940: PRN17 SUB *ARDMS,XL POINT TO NEXT SET OF BOUNDS
18941: STI PRNSI SAVE CURRENT OFFSET
18942: RMI ARDIM(XL) GET REMAINDER ON DIVIDING BY DIMENS
18943: MFI -(XS) STORE ON STACK (ONE WORD)
18944: LDI PRNSI RELOAD ARGUMENT
18945: DVI ARDIM(XL) DIVIDE TO GET QUOTIENT
18946: BCT WA,PRN17 LOOP TILL ALL STACKED
18947: ZER XR SET OFFSET TO FIRST SET OF BOUNDS
18948: LCT WB,ARNDM(XL) LOAD COUNT OF DIMS TO CONTROL LOOP
18949: BRN PRN19 JUMP INTO PRINT LOOP
18950: *
18951: * LOOP TO PRINT SUBSCRIPTS FROM STACK ADJUSTING BY ADDING
18952: * THE APPROPRIATE LOW BOUND VALUE FROM THE ARBLK
18953: *
18954: PRN18 MOV =CH$CM,WA LOAD A COMMA
18955: JSR PRTCH PRINT IT
18956: *
18957: * MERGE HERE FIRST TIME IN (NO COMMA REQUIRED)
18958: *
18959: PRN19 MTI (XS)+ LOAD SUBSCRIPT OFFSET AS INTEGER
18960: ADD XR,XL POINT TO CURRENT LBD
18961: ADI ARLBD(XL) ADD LBD TO GET SIGNED SUBSCRIPT
18962: SUB XR,XL POINT BACK TO START OF ARBLK
18963: JSR PRTIN PRINT SUBSCRIPT
18964: ADD *ARDMS,XR BUMP OFFSET TO NEXT BOUNDS
18965: BCT WB,PRN18 LOOP BACK TILL ALL PRINTED
18966: BRN PRN14 MERGE BACK TO PRINT RIGHT BRACKET
18967: ENP END PROCEDURE PRTNM
18968: EJC
18969: *
18970: * PRTNV -- PRINT NAME VALUE
18971: *
18972: * PRTNV IS USED BY THE TRACE AND DUMP ROUTINES TO PRINT
18973: * A LINE OF THE FORM
18974: *
18975: * NAME = VALUE
18976: *
18977: * NOTE THAT THE NAME INVOLVED CAN NEVER BE A PSEUDO-VAR
18978: *
18979: * (XL) NAME BASE
18980: * (WA) NAME OFFSET
18981: * JSR PRTNV CALL TO PRINT NAME = VALUE
18982: * (WB,WC,RA) DESTROYED
18983: *
18984: PRTNV PRC E,0 ENTRY POINT
18985: JSR PRTNM PRINT ARGUMENT NAME
18986: MOV XR,-(XS) SAVE ENTRY XR
18987: MOV WA,-(XS) SAVE NAME OFFSET (COLLECTABLE)
18988: MOV =TMBEB,XR POINT TO BLANK EQUAL BLANK
18989: JSR PRTST PRINT IT
18990: MOV XL,XR COPY NAME BASE
18991: ADD WA,XR POINT TO VALUE
18992: MOV (XR),XR LOAD VALUE POINTER
18993: JSR PRTVF PRINT VALUE
18994: MOV (XS)+,WA RESTORE NAME OFFSET
18995: MOV (XS)+,XR RESTORE ENTRY XR
18996: EXI RETURN TO CALLER
18997: ENP END PROCEDURE PRTNV
18998: EJC
18999: *
19000: * PRTPG -- PRINT A PAGE THROW
19001: *
19002: * PRINTS A PAGE THROW OR A FEW BLANK LINES ON THE STANDARD
19003: * LISTING FILE DEPENDING ON THE LISTING OPTIONS CHOSEN.
19004: *
19005: * JSR PRTPG CALL FOR PAGE EJECT
19006: *
19007: PRTPG PRC E,0 ENTRY POINT
19008: BNZ STAGX,PTPG1 SKIP IF EXECUTION TIME
19009: BZE LSTLC,PTPG6 RETURN IF TOP OF PAGE ALREADY
19010: ZER LSTLC CLEAR LINE COUNT
19011: *
19012: * CHECK TYPE OF LISTING
19013: *
19014: PTPG1 MOV XR,-(XS) PRESERVE XR
19015: BNZ PRECL,PTPG2 EJECT IF EXTENDED LISTING
19016: BZE PRSTD,PTPG3 SKIP IF COMPACT LISTING
19017: BNZ TTOUS,PTPG3 SKIP IF LISTING TO TERMINAL
19018: *
19019: * PERFORM AN EJECT
19020: *
19021: PTPG2 JSR SYSEP EJECT
19022: PPM PTPG4 IGNORE FAILURE
19023: PPM EROSI ERROR
19024: BRN PTPG4 MERGE
19025: *
19026: * COMPACT LISTING.
19027: *
19028: PTPG3 BNZ HEADN,PTPG4 SKIP IF HEADERS OMITTED
19029: MOV HEADP,XR REMEMBER HEADP
19030: MNZ HEADP SET TO AVOID RECURSIVE PRTPG CALLS
19031: JSR PRTFH PRINT BLANK LINE
19032: JSR PRTFH PRINT BLANK LINE
19033: JSR PRTFH PRINT BLANK LINE
19034: MOV =NUM03,LSTLC COUNT BLANK LINES
19035: MOV XR,HEADP RESTORE HEADER FLAG
19036: EJC
19037: *
19038: * PRPTG (CONTINUED)
19039: *
19040: * PRINT THE HEADING
19041: *
19042: PTPG4 BNZ HEADP,PTPG5 JUMP IF HEADER LISTED
19043: MNZ HEADP MARK HEADERS PRINTED
19044: BNZ HEADN,PTPG5 SKIP IF HEADERS OMITTED
19045: MOV XL,-(XS) KEEP XL
19046: MOV =HEADR,XR POINT TO LISTING HEADER
19047: JSR PRTST PLACE IT
19048: JSR SYSID GET SYSTEM IDENTIFICATION
19049: JSR PRTSF APPEND EXTRA CHARS AND PRINT
19050: MOV XL,XR EXTRA HEADER LINE
19051: JSR PRTFB PLACE IT AND A BLANK
19052: JSR PRTFH AND ANOTHER
19053: ADD =NUM04,LSTLC FOUR HEADER LINES PRINTED
19054: MOV (XS)+,XL RESTORE XL
19055: *
19056: * MERGE IF HEADER NOT PRINTED
19057: *
19058: PTPG5 MOV (XS)+,XR RESTORE XR
19059: *
19060: * RETURN
19061: *
19062: PTPG6 EXI RETURN
19063: ENP END PROCEDURE PRTPG
19064: EJC
19065: *
19066: * PRTPS -- PRINT PAGE WITH TEST FOR STANDARD LISTING OPTION
19067: *
19068: * IF THE STANDARD LISTING OPTION IS SELECTED, INSIST THAT
19069: * AN EJECT BE DONE
19070: *
19071: * JSR PRTPS CALL FOR EJECT
19072: *
19073: PRTPS PRC E,0 ENTRY POINT
19074: MOV PRSTO,PRSTD COPY OPTION FLAG
19075: JSR PRTPG PRINT PAGE
19076: ZER PRSTD CLEAR FLAG
19077: EXI RETURN
19078: ENP END PROCEDURE PRTPS
19079: *
19080: * PRTSF -- PRINT STRING TO STD PRINTER AND FLUSH BFR
19081: *
19082: * (XR) STRING TO PRINT
19083: * JSR PRTSF CALL TO PRINT AND FLUSH
19084: *
19085: PRTSF PRC E,0 ENTRY POINT
19086: JSR PRTST PRINT STRING
19087: JSR PRTFH FLUSH BUFFER
19088: EXI RETURN TO CALLER
19089: ENP END PROCEDURE PRTSF
19090: EJC
19091: *
19092: * PRTSN -- PRINT STATEMENT NUMBER
19093: *
19094: * PRTSN IS USED TO INITIATE A PRINT TRACE LINE BY PRINTING
19095: * ASTERISKS AND THE CURRENT STATEMENT NUMBER. THE ACTUAL
19096: * FORMAT OF THE OUTPUT GENERATED IS.
19097: *
19098: * ***NNNNN**** III.....IIII
19099: *
19100: * NNNNN IS THE STATEMENT NUMBER WITH LEADING ZEROS REPLACED
19101: * BY ASTERISKS (E.G. *******9****)
19102: *
19103: * III...III REPRESENTS A VARIABLE LENGTH OUTPUT CONSISTING
19104: * OF A NUMBER OF LETTER I CHARACTERS EQUAL TO FNCLEVEL.
19105: *
19106: * JSR PRTSN CALL TO PRINT STATEMENT NUMBER
19107: * (WC) DESTROYED
19108: *
19109: PRTSN PRC E,0 ENTRY POINT
19110: MOV XR,-(XS) SAVE ENTRY XR
19111: MOV WA,PRSNA SAVE ENTRY WA
19112: MOV =TMASB,XR POINT TO ASTERISKS
19113: JSR PRTST PRINT ASTERISKS
19114: MOV =NUM04,PROFS POINT INTO MIDDLE OF ASTERISKS
19115: MTI KVSTN LOAD STATEMENT NUMBER AS INTEGER
19116: JSR PRTIN PRINT INTEGER STATEMENT NUMBER
19117: MOV =PRSNF,PROFS POINT PAST ASTERISKS PLUS BLANK
19118: MOV KVFNC,XR GET FNCLEVEL
19119: MOV =CH$LI,WA SET LETTER I
19120: *
19121: * LOOP TO GENERATE LETTER I FNCLEVEL TIMES
19122: *
19123: PRSN1 BZE XR,PRSN2 JUMP IF ALL SET
19124: JSR PRTCH ELSE PRINT AN I
19125: DCV XR DECREMENT COUNTER
19126: BRN PRSN1 LOOP BACK
19127: *
19128: * MERRE WITH ALL LETTER I CHARACTERS GENERATED
19129: *
19130: PRSN2 MOV =CH$BL,WA GET BLANK
19131: JSR PRTCH PRINT BLANK
19132: MOV PRSNA,WA RESTORE ENTRY WA
19133: MOV (XS)+,XR RESTORE ENTRY XR
19134: EXI RETURN TO PRTSN CALLER
19135: ENP END PROCEDURE PRTSN
19136: EJC
19137: *
19138: * PRTST -- PRINT STRING TO STANDARD FILE
19139: *
19140: * PLACE A STRING OF CHARACTERS IN THE STANDARD PRINT BUFFER
19141: *
19142: * NOTE THAT THE FIRST WORD OF THE BLOCK (NORMALLY B$SCL)
19143: * IS NOT USED AND NEED NOT BE SET CORRECTLY (SEE PRTVN)
19144: * IF GLOBAL TTOUS IS NON-ZERO, STRING IS SENT TO TERMINAL
19145: * INSTEAD OF STANDARD OUTPUT FILE.
19146: * IF GLOBAL TTLST IS NON-ZERO, STRING IS SENT TO
19147: * TERMINAL AS WELL AS STANDARD OUTPUT FILE
19148: *
19149: * (XR) STRING TO BE PRINTED
19150: * JSR PRTST CALL TO PRINT STRING
19151: * (PROFS) UPDATED PAST CHARS PLACED
19152: *
19153: PRTST PRC R,0 ENTRY POINT
19154: BNZ HEADP,PTST1 WERE HEADERS PRINTED
19155: JSR PRTPS NO - PRINT THEM
19156: *
19157: * HEADERS DEALT WITH
19158: *
19159: PTST1 BZE PRLEN,PTST7 SKIP IF NO O/P POSSIBLE
19160: BNZ PRPUT,PTST2 SKIP IF PUTTING IS OK
19161: BZE TTLST,PTST7 SKIP OUT IF NOT ERROR TO TERML
19162: *
19163: * KEEP REGISTERS
19164: *
19165: PTST2 MOV WA,PRSVA SAVE WA
19166: MOV WB,PRSVB SAVE WB
19167: ZER WB SET CHARS PRINTED COUNT TO ZERO
19168: *
19169: * LOOP TO PRINT SUCCESSIVE LINES FOR LONG STRING
19170: *
19171: PTST3 MOV SCLEN(XR),WA LOAD STRING LENGTH
19172: SUB WB,WA SUBTRACT COUNT OF CHARS ALREADY OUT
19173: BZE WA,PTST6 JUMP TO EXIT IF NONE LEFT
19174: MOV XL,-(XS) ELSE STACK ENTRY XL
19175: MOV XR,-(XS) SAVE ARGUMENT
19176: MOV XR,XL COPY FOR EVENTUAL MOVE
19177: MOV PRLEN,XR LOAD PRINT BUFFER LENGTH
19178: SUB PROFS,XR GET CHARS LEFT IN PRINT BUFFER
19179: BNZ XR,PTST4 SKIP IF ROOM LEFT ON THIS LINE
19180: JSR PRTFH PRINT THIS LINE
19181: MOV PRLEN,XR AND SET FULL WIDTH AVAILABLE
19182: EJC
19183: *
19184: * PRTST (CONTINUED)
19185: *
19186: * HERE WITH CHARS TO PRINT AND SOME ROOM IN BUFFER
19187: *
19188: PTST4 BLO WA,XR,PTST5 JUMP IF ROOM FOR REST OF STRING
19189: MOV XR,WA ELSE SET TO FILL LINE
19190: *
19191: * MERGE HERE WITH CHARACTER COUNT IN WA
19192: *
19193: PTST5 MOV PRBUF,XR POINT TO PRINT BUFFER
19194: PLC XL,WB POINT TO LOCATION IN STRING
19195: PSC XR,PROFS POINT TO LOCATION IN BUFFER
19196: ADD WA,WB BUMP STRING CHARS COUNT
19197: ADD WA,PROFS BUMP BUFFER POINTER
19198: MVC MOVE CHARACTERS TO BUFFER
19199: MOV (XS)+,XR RESTORE ARGUMENT POINTER
19200: MOV (XS)+,XL RESTORE ENTRY XL
19201: BRN PTST3 LOOP BACK TO TEST FOR MORE
19202: *
19203: * HERE TO EXIT AFTER PRINTING STRING
19204: *
19205: PTST6 MOV PRSVB,WB RESTORE ENTRY WB
19206: MOV PRSVA,WA RESTORE ENTRY WA
19207: *
19208: * RETURN POINT
19209: *
19210: PTST7 EXI RETURN TO PRTST CALLER
19211: ENP END PROCEDURE PRTST
19212: *
19213: * PRTVF -- PLACE A VALUE AND FLUSH STANDARD BUFFER
19214: *
19215: * (XR) VALUE TO PRINT
19216: * JSR PRTVF CALL TO PRINT AND FLUSH
19217: *
19218: PRTVF PRC E,0 ENTRY POINT
19219: JSR PRTVL PLACE VALUE
19220: JSR PRTFH FLUSH BUFFER
19221: EXI RETURN TO CALLER
19222: ENP END PROCEDURE PRTVF
19223: EJC
19224: *
19225: * PRTVL -- PRINT A VALUE
19226: *
19227: * PRTVL PLACES AN APPROPRIATE CHARACTER REPRESENTATION OF
19228: * A DATA VALUE IN THE PRINT BUFFER FOR DUMP/TRACE USE.
19229: *
19230: * (XR) VALUE TO BE PRINTED
19231: * JSR PRTVL CALL TO PRINT VALUE
19232: * (WA,WB,WC,RA) DESTROYED
19233: *
19234: PRTVL PRC R,0 ENTRY POINT, RECURSIVE
19235: MOV XL,-(XS) SAVE ENTRY XL
19236: MOV XR,-(XS) SAVE ARGUMENT
19237: CHK CHECK FOR STACK OVERFLOW
19238: *
19239: * LOOP BACK HERE AFTER FINDING A TRAP BLOCK (TRBLK)
19240: *
19241: PRV01 MOV IDVAL(XR),PRVSI COPY IDVAL (IF ANY)
19242: MOV (XR),XL LOAD FIRST WORD OF BLOCK
19243: LEI XL LOAD ENTRY POINT ID
19244: BSW XL,BL$$T,PRV02 SWITCH ON BLOCK TYPE
19245: IFF BL$TR,PRV04 TRBLK
19246: IFF BL$AR,PRV05 ARBLK
19247: IFF BL$IC,PRV08 ICBLK
19248: IFF BL$NM,PRV09 NMBLK
19249: IFF BL$PD,PRV10 PDBLK
19250: .IF .CNRA
19251: .ELSE
19252: IFF BL$RC,PRV08 RCBLK
19253: .FI
19254: IFF BL$SC,PRV11 SCBLK
19255: IFF BL$SE,PRV12 SEBLK
19256: IFF BL$TB,PRV13 TBBLK
19257: IFF BL$VC,PRV13 VCBLK
19258: .IF .CNBF
19259: .ELSE
19260: IFF BL$BC,PRV15 BCBLK
19261: .FI
19262: ESW END OF SWITCH ON BLOCK TYPE
19263: *
19264: * HERE FOR BLOCKS FOR WHICH WE JUST PRINT DATATYPE NAME
19265: *
19266: PRV02 JSR DTYPE GET DATATYPE NAME
19267: JSR PRTST PRINT DATATYPE NAME
19268: *
19269: * COMMON EXIT POINT
19270: *
19271: PRV03 MOV (XS)+,XR RELOAD ARGUMENT
19272: MOV (XS)+,XL RESTORE XL
19273: EXI RETURN TO PRTVL CALLER
19274: *
19275: * HERE FOR TRBLK
19276: *
19277: PRV04 MOV TRVAL(XR),XR LOAD REAL VALUE
19278: BRN PRV01 AND LOOP BACK
19279: EJC
19280: *
19281: * PRTVL (CONTINUED)
19282: *
19283: * HERE FOR ARRAY (ARBLK)
19284: *
19285: * PRINT ARRAY ( PROTOTYPE ) BLANK NUMBER IDVAL
19286: *
19287: PRV05 MOV XR,XL PRESERVE ARGUMENT
19288: MOV =SCARR,XR POINT TO DATATYPE NAME (ARRAY)
19289: JSR PRTST PRINT IT
19290: MOV =CH$PP,WA LOAD LEFT PAREN
19291: JSR PRTCH PRINT LEFT PAREN
19292: ADD AROFS(XL),XL POINT TO PROTOTYPE
19293: MOV (XL),XR LOAD PROTOTYPE
19294: JSR PRTST PRINT PROTOTYPE
19295: *
19296: * VCBLK, TBBLK MERGE HERE FOR ) BLANK NUMBER IDVAL
19297: *
19298: PRV06 MOV =CH$RP,WA LOAD RIGHT PAREN
19299: JSR PRTCH PRINT RIGHT PAREN
19300: *
19301: * PDBLK MERGES HERE TO PRINT BLANK NUMBER IDVAL
19302: *
19303: PRV07 MOV =CH$BL,WA LOAD BLANK
19304: JSR PRTCH PRINT IT
19305: MOV =CH$NM,WA LOAD NUMBER SIGN
19306: JSR PRTCH PRINT IT
19307: MTI PRVSI GET IDVAL
19308: JSR PRTIN PRINT ID NUMBER
19309: BRN PRV03 BACK TO EXIT
19310: *
19311: * HERE FOR INTEGER (ICBLK), REAL (RCBLK)
19312: *
19313: * PRINT CHARACTER REPRESENTATION OF VALUE
19314: *
19315: PRV08 MOV XR,-(XS) STACK ARGUMENT FOR GTSTG
19316: JSR GTSTG CONVERT TO STRING
19317: PPM ERROR RETURN IS IMPOSSIBLE
19318: JSR PRTST PRINT THE STRING
19319: MOV XR,DNAMP DELETE GARBAGE STRING FROM STORAGE
19320: BRN PRV03 BACK TO EXIT
19321: EJC
19322: *
19323: * PRTVL (CONTINUED)
19324: *
19325: * NAME (NMBLK)
19326: *
19327: * FOR PSEUDO-VARIABLE, JUST PRINT DATATYPE NAME (NAME)
19328: * FOR ALL OTHER NAMES, PRINT DOT FOLLOWED BY NAME REP
19329: *
19330: PRV09 MOV NMBAS(XR),XL LOAD NAME BASE
19331: MOV (XL),WA LOAD FIRST WORD OF BLOCK
19332: BEQ WA,=B$KVT,PRV02 JUST PRINT NAME IF KEYWORD
19333: BEQ WA,=B$EVT,PRV02 JUST PRINT NAME IF EXPRESSION VAR
19334: MOV =CH$DT,WA ELSE GET DOT
19335: JSR PRTCH AND PRINT IT
19336: MOV NMOFS(XR),WA LOAD NAME OFFSET
19337: JSR PRTNM PRINT NAME
19338: BRN PRV03 BACK TO EXIT
19339: *
19340: * PROGRAM DATATYPE (PDBLK)
19341: *
19342: * PRINT DATATYPE NAME CH$BL CH$NM IDVAL
19343: *
19344: PRV10 JSR DTYPE GET DATATYPE NAME
19345: JSR PRTST PRINT DATATYPE NAME
19346: BRN PRV07 MERGE BACK TO PRINT ID
19347: *
19348: * HERE FOR STRING (SCBLK)
19349: *
19350: * PRINT QUOTE STRING-CHARACTERS QUOTE
19351: *
19352: PRV11 MOV =CH$SQ,WA LOAD SINGLE QUOTE
19353: JSR PRTCH PRINT QUOTE
19354: JSR PRTST PRINT STRING VALUE
19355: JSR PRTCH PRINT ANOTHER QUOTE
19356: BRN PRV03 BACK TO EXIT
19357: EJC
19358: *
19359: * PRTVL (CONTINUED)
19360: *
19361: * HERE FOR SIMPLE EXPRESSION (SEBLK)
19362: *
19363: * PRINT ASTERISK VARIABLE-NAME
19364: *
19365: PRV12 MOV =CH$AS,WA LOAD ASTERISK
19366: JSR PRTCH PRINT ASTERISK
19367: MOV SEVAR(XR),XR LOAD VARIABLE POINTER
19368: JSR PRTVN PRINT VARIABLE NAME
19369: BRN PRV03 JUMP BACK TO EXIT
19370: *
19371: * HERE FOR TABLE (TBBLK) AND ARRAY (VCBLK)
19372: *
19373: * PRINT DATATYPE ( PROTOTYPE ) BLANK NUMBER IDVAL
19374: *
19375: PRV13 MOV XR,XL PRESERVE ARGUMENT
19376: JSR DTYPE GET DATATYPE NAME
19377: JSR PRTST PRINT DATATYPE NAME
19378: MOV =CH$PP,WA LOAD LEFT PAREN
19379: JSR PRTCH PRINT LEFT PAREN
19380: MOV TBLEN(XL),WA LOAD LENGTH OF BLOCK (=VCLEN)
19381: BTW WA CONVERT TO WORD COUNT
19382: SUB =TBSI$,WA ALLOW FOR STANDARD FIELDS
19383: BEQ (XL),=B$TBT,PRV14 JUMP IF TABLE
19384: ADD =VCTBD,WA FOR VCBLK, ADJUST SIZE
19385: *
19386: * PRINT PROTOTYPE
19387: *
19388: PRV14 MTI WA MOVE AS INTEGER
19389: JSR PRTIN PRINT INTEGER PROTOTYPE
19390: BRN PRV06 MERGE BACK FOR REST
19391: .IF .CNBF
19392: .ELSE
19393: EJC
19394: *
19395: * PRTVL (CONTINUED)
19396: *
19397: * HERE FOR BUFFER (BCBLK)
19398: *
19399: PRV15 MOV XR,XL PRESERVE ARGUMENT
19400: MOV =SCBUF,XR POINT TO DATATYPE NAME (BUFFER)
19401: JSR PRTST PRINT IT
19402: MOV =CH$PP,WA LOAD LEFT PAREN
19403: JSR PRTCH PRINT LEFT PAREN
19404: MOV BCBUF(XL),XR POINT TO BFBLK
19405: MTI BFALC(XR) LOAD ALLOCATION SIZE
19406: JSR PRTIN PRINT IT
19407: MOV =CH$CM,WA LOAD COMMA
19408: JSR PRTCH PRINT IT
19409: MTI BCLEN(XL) LOAD DEFINED LENGTH
19410: JSR PRTIN PRINT IT
19411: BRN PRV06 MERGE TO FINISH UP
19412: .FI
19413: ENP END PROCEDURE PRTVL
19414: EJC
19415: *
19416: * PRTVN -- PRINT NATURAL VARIABLE NAME
19417: *
19418: * PRTVN PRINTS THE NAME OF A NATURAL VARIABLE
19419: *
19420: * (XR) POINTER TO VRBLK
19421: * JSR PRTVN CALL TO PRINT VARIABLE NAME
19422: *
19423: PRTVN PRC E,0 ENTRY POINT
19424: MOV XR,-(XS) STACK VRBLK POINTER
19425: ADD *VRSOF,XR POINT TO POSSIBLE STRING NAME
19426: BNZ SCLEN(XR),PRVN1 JUMP IF NOT SYSTEM VARIABLE
19427: MOV VRSVO(XR),XR POINT TO SVBLK WITH NAME
19428: *
19429: * MERGE HERE WITH DUMMY SCBLK POINTER IN XR
19430: *
19431: PRVN1 JSR PRTST PRINT STRING NAME OF VARIABLE
19432: MOV (XS)+,XR RESTORE VRBLK POINTER
19433: EXI RETURN TO PRTVN CALLER
19434: ENP END PROCEDURE PRTVN
19435: EJC
19436: *
19437: * PTTFH -- FLUSH TERMINAL BUFFER
19438: *
19439: * PRINTS THE CONTENTS OF THE TTY BUFFER, RESETS
19440: * THE BUFFER TO ALL BLANKS AND RESETS THE POINTER.
19441: *
19442: * JSR PTTFH CALL TO FLUSH BUFFER
19443: *
19444: PTTFH PRC E,0 ENTRY POINT
19445: BZE TTLEN,PTTF2 SKIP IF NO TERMINAL
19446: MOV XL,-(XS) SAVE XL
19447: MOV XR,-(XS) SAVE XR
19448: MOV WA,-(XS) SAVE WA
19449: MOV WC,-(XS) SAVE WC
19450: MOV TTBUF,XR LOAD POINTER TO BUFFER
19451: MOV TTOFS,WC LOAD NUMBER OF CHARS IN BUFFER
19452: JSR SYSPI CALL SYSTEM PRINT ROUTINE
19453: PPM PTTF3 JUMP IF FAILED
19454: PPM EROSI STOP IF ERROR
19455: *
19456: * BLANK BUFFER
19457: *
19458: PTTF1 MOV TTBLK,XL POINT TO BLANKING STRING
19459: MOV TTCHS,XR POINT TO BUFFER
19460: MOV TTCMV,WA COUNT OF BAUS TO MOVE
19461: MVW MOVE BLANKS INTO BUFFER
19462: ZER TTOFS RESET OFFSET
19463: MOV (XS)+,WC RESTORE WC
19464: MOV (XS)+,WA RECOVER WA
19465: MOV (XS)+,XR RESTORE XR
19466: MOV (XS)+,XL RESTORE XL
19467: *
19468: * RETURN POINT
19469: *
19470: PTTF2 EXI RETURN TO CALLER
19471: *
19472: * A FAILURE SUCH AS FILE OVERFILLED OCCURRED
19473: *
19474: PTTF3 BZE STAGX,PTTF1 IGNORE IF COMPILE TIME
19475: BRN EXFAL ELSE CAUSE STMT FAILURE
19476: ENP END PROCEDURE
19477: EJC
19478: *
19479: * PTTST -- PRINT STRING TO TERMINAL
19480: *
19481: * PLACE A STRING OF CHARACTERS IN THE TERMINAL BUFFER
19482: *
19483: * NOTE THAT THE FIRST WORD OF THE BLOCK (NORMALLY B$SCL)
19484: * IS NOT USED AND NEED NOT BE SET CORRECTLY (SEE PRTVN)
19485: *
19486: * (XR) STRING TO BE PRINTED
19487: * JSR PTTST CALL TO PRINT STRING
19488: * (TTOFS) UPDATED PAST CHARS PLACED
19489: *
19490: PTTST PRC E,0 ENTRY POINT
19491: BZE TTLEN,PTTS5 SKIP IF NO TERMINAL
19492: MOV WA,PRTVA SAVE WA
19493: MOV WB,PRTVB SAVE WB
19494: ZER WB SET CHARS PRINTED COUNT TO ZERO
19495: *
19496: * LOOP TO PRINT SUCCESSIVE LINES FOR LONG STRING
19497: *
19498: PTTS1 MOV SCLEN(XR),WA LOAD STRING LENGTH
19499: SUB WB,WA SUBTRACT COUNT OF CHARS ALREADY OUT
19500: BZE WA,PTTS4 JUMP TO EXIT IF NONE LEFT
19501: MOV XL,-(XS) ELSE STACK ENTRY XL
19502: MOV XR,-(XS) SAVE ARGUMENT
19503: MOV XR,XL COPY FOR EVENTUAL MOVE
19504: MOV TTLEN,XR LOAD BUFFER LENGTH
19505: SUB TTOFS,XR GET CHARS LEFT IN BUFFER
19506: BNZ XR,PTTS2 SKIP IF ROOM LEFT ON THIS LINE
19507: JSR PTTFH ELSE PRINT THIS LINE
19508: MOV TTLEN,XR AND SET FULL WIDTH AVAILABLE
19509: *
19510: * HERE WITH CHARS TO PRINT AND SOME ROOM IN BUFFER
19511: *
19512: PTTS2 BLO WA,XR,PTTS3 JUMP IF ROOM FOR REST OF STRING
19513: MOV XR,WA ELSE SET TO FILL LINE
19514: *
19515: * MERGE HERE WITH CHARACTER COUNT IN WA
19516: *
19517: PTTS3 MOV TTBUF,XR POINT TO PRINT BUFFER
19518: PLC XL,WB POINT TO LOCATION IN STRING
19519: PSC XR,TTOFS POINT TO LOCATION IN BUFFER
19520: ADD WA,WB BUMP STRING CHARS COUNT
19521: ADD WA,TTOFS BUMP BUFFER POINTER
19522: MVC MOVE CHARACTERS TO BUFFER
19523: MOV (XS)+,XR RESTORE ARGUMENT POINTER
19524: MOV (XS)+,XL RESTORE ENTRY XL
19525: BRN PTTS1 LOOP BACK TO TEST FOR MORE
19526: EJC
19527: *
19528: * HERE TO EXIT AFTER PRINTING STRING
19529: *
19530: PTTS4 MOV PRTVB,WB RESTORE ENTRY WB
19531: MOV PRTVA,WA RESTORE ENTRY WA
19532: *
19533: * RETURN POINT
19534: *
19535: PTTS5 EXI RETURN TO PTTST CALLER
19536: ENP END PROCEDURE PTTST
19537: .IF .CNRA
19538: .ELSE
19539: EJC
19540: *
19541: * RCBLD -- BUILD A REAL BLOCK
19542: *
19543: * (RA) REAL VALUE FOR RCBLK
19544: * JSR RCBLD CALL TO BUILD REAL BLOCK
19545: * (XR) POINTER TO RESULT RCBLK
19546: * (WA) DESTROYED
19547: *
19548: RCBLD PRC E,0 ENTRY POINT
19549: MOV DNAMP,XR LOAD POINTER TO NEXT AVAILABLE LOC
19550: ADD *RCSI$,XR POINT PAST NEW RCBLK
19551: BLO XR,DNAME,RCBL1 JUMP IF THERE IS ROOM
19552: MOV *RCSI$,WA ELSE LOAD RCBLK LENGTH
19553: JSR ALLOC USE STANDARD ALLOCATOR TO GET BLOCK
19554: ADD WA,XR POINT PAST BLOCK TO MERGE
19555: *
19556: * MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED
19557: *
19558: RCBL1 MOV XR,DNAMP SET NEW POINTER
19559: SUB *RCSI$,XR POINT BACK TO START OF BLOCK
19560: MOV =B$RCL,(XR) STORE TYPE WORD
19561: STR RCVAL(XR) STORE REAL VALUE IN RCBLK
19562: EXI RETURN TO RCBLD CALLER
19563: ENP END PROCEDURE RCBLD
19564: .FI
19565: EJC
19566: *
19567: * READR -- READ NEXT SOURCE IMAGE AT COMPILE TIME
19568: *
19569: * READR IS USED TO READ THE NEXT SOURCE IMAGE. TO PROCESS
19570: * CONTINUATION CARDS PROPERLY, THE COMPILER MUST READ ONE
19571: * LINE AHEAD. THUS READR DOES NOT DESTROY THE CURRENT IMAGE
19572: * SEE ALSO THE NEXTS ROUTINE WHICH ACTUALLY GETS THE IMAGE.
19573: *
19574: * THE GLOBAL FLAG RDRER IS SET JUST BEFORE THE READ, AND
19575: * CLEARED AFTER IT. THIS IS SO THAT IN THE EVENT SYSRD
19576: * OR SYSRI TAKE AN EROSI EXIT, THE ERROR APPENDAGE CAN
19577: * RECOGNIZE THE SITUATION AND TAKE APPROPRIATE ACTION.
19578: *
19579: * JSR READR CALL TO READ NEXT IMAGE
19580: * (XR) PTR TO NEXT IMAGE (0 IF NONE)
19581: * (R$CNI) COPY OF POINTER
19582: * (WA,WB,WC,XL) DESTROYED
19583: *
19584: READR PRC E,0 ENTRY POINT
19585: MOV R$CNI,XR GET PTR TO NEXT IMAGE
19586: BNZ XR,READ5 EXIT IF ALREADY READ
19587: *
19588: * MERGE FROM -COPY EOF TO TRY READ
19589: *
19590: READ0 BEQ STAGE,=STGIC,READ1 READ IF INITIAL COMPILE
19591: BZE R$COP,READ6 ELSE EXIT IF NO -COPY IN FORCE
19592: *
19593: * ATTEMPT READ
19594: *
19595: READ1 MOV CSWIN,WA MAX READ LENGTH
19596: MNZ RDRER NOTE IN-READR IN CASE EROSI
19597: JSR ALOCS ALLOCATE BUFFER
19598: BZE TTINS,READ2 SKIP IF STANDARD INPUT FILE
19599: JSR SYSRI READ FROM TERMINAL
19600: PPM READ7 FAIL
19601: PPM EROSI ERROR
19602: BRN READ3 MERGE
19603: *
19604: * READ FROM STANDARD FILE
19605: *
19606: READ2 JSR SYSRD READ INPUT IMAGE
19607: PPM READ7 JUMP IF END OF FILE
19608: PPM EROSI ERROR RETURN
19609: *
19610: * MERGE
19611: *
19612: READ3 ZER RDRER NOTE NOT-IN-READR FOR ERROR RTN
19613: MNZ WB SET TRIMR TO PERFORM TRIM
19614: BLE SCLEN(XR),CSWIN,READ4 USE SMALLER OF STRING LNTH..
19615: MOV CSWIN,SCLEN(XR) ... AND XXX OF -INXXX
19616: *
19617: * PERFORM THE TRIM
19618: *
19619: READ4 JSR TRIMR TRIM TRAILING BLANKS
19620: *
19621: * MERGE HERE AFTER READ
19622: *
19623: READ5 MOV XR,R$CNI STORE COPY OF POINTER
19624: *
19625: * MERGE HERE IF NO READ ATTEMPTED
19626: *
19627: READ6 EXI RETURN TO READR CALLER
19628: *
19629: * HERE ON END OF FILE
19630: *
19631: READ7 ZER RDRER NOTE NOT-IN-READR FOR ERR
19632: MOV XR,DNAMP POP UNUSED SCBLK
19633: ZER XR ZERO PTR AS RESULT
19634: BZE R$COP,READ5 SKIP IF NO -COPY IN FORCE
19635: JSR COPND CALL TO END THIS -COPY (EOF)
19636: BRN READ0 TRY AGAIN
19637: ENP END PROCEDURE READR
19638: .IF .CASL
19639: EJC
19640: *
19641: * SBSCC -- BUILD SUBSTRING WITH CASE CONVERSION
19642: *
19643: * (XL) PTR TO SCBLK CONTAINING CHARS
19644: * (WA) CHAR COUNT
19645: * (WB) OFFSET TO FIRST CHAR IN SCBLK
19646: * JSR SBSCC CALL TO BUILD SUBSTRING
19647: * (XR) PTR TO NEW SCBLK WITH SUBSTRING
19648: * (WA,WB,WC,XL,IA) DESTROYED
19649: *
19650: * IF OPTION .CPLC IS SELECTED (PREFER LOWER CASE), TARGET
19651: * CASE IS LOWER CASE, OTHERWISE IT IS UPPER CASE.
19652: *
19653: SBSCC PRC E,0 ENTRY POINT
19654: BZE WA,SBSC4 JUMP IF NULL SUBSTRING
19655: JSR ALOCS ELSE ALLOCATE SCBLK
19656: MOV WC,WA MOVE NUMBER OF CHARACTERS
19657: MOV XR,WC SAVE PTR TO NEW SCBLK
19658: PLC XL,WB PREPARE TO LOAD CHARS FROM OLD BLK
19659: PSC XR PREPARE TO STORE CHARS IN NEW BLK
19660: LCT WA,WA TO COUNT ROUND LOOP
19661: *
19662: * LOOP TO COPY AND TRANSLATE CHARS
19663: *
19664: SBSC1 LCH WB,(XL)+ GET CHAR
19665: .IF .CPLC
19666: BGT WB,=CH$L$,SBSC2 SKIP IF NOT UC LETTER
19667: BLT WB,=CH$LA,SBSC2 SKIP IF NOT UC LETTER
19668: .IF .CSCV
19669: CUL WB CONVERT FROM UC TO LC
19670: .ELSE
19671: ADD =DFA$A,WB CONVERT FROM UC TO LC
19672: .FI
19673: .ELSE
19674: BGT WB,=CH$$$,SBSC2 SKIP IF NOT A LC LETTER
19675: BLT WB,=CH$$A,SBSC2 SKIP IF NOT A LC LETTER
19676: .IF .CSCV
19677: CLU WB CONVERT FROM LC TO UC
19678: .ELSE
19679: SUB =DFA$A,WB CONVERT FROM LC TO UC
19680: .FI
19681: .FI
19682: *
19683: * STORE CHAR IN NEW SUBSTRING
19684: *
19685: SBSC2 SCH WB,(XR)+ STORE CHAR
19686: BCT WA,SBSC1 LOOP
19687: MOV WC,XR RESTORE SCBLK POINTER
19688: *
19689: * RETURN POINT
19690: *
19691: SBSC3 ZER XL CLEAR GARBAGE POINTER IN XL
19692: EXI RETURN TO SBSCC CALLER
19693: *
19694: * HERE FOR NULL SUBSTRING
19695: *
19696: SBSC4 MOV =NULLS,XR SET NULL STRING AS RESULT
19697: BRN SBSC3 RETURN
19698: ENP END PROCEDURE SBSCC
19699: EJC
19700: *
19701: * SBSTG -- BUILD SUBSTRING POSSIBLY CONVERTING CASE
19702: *
19703: * (XL) PTR TO SCBLK CONTAINING CHARS
19704: * (WA) CHAR COUNT
19705: * (WB) OFFSET TO FIRST CHAR IN SCBLK
19706: * JSR SBSTG CALL TO BUILD SUBSTRING
19707: * (XR) PTR TO NEW SCBLK WITH SUBSTRING
19708: * (WA,WB,WC,XL,IA) DESTROYED
19709: *
19710: * IF CASE IS TO BE IGNORED (-CASEIG OR .CSIG), SUBSTRING
19711: * IS CONVERTED TO PREFERRED CASE (DEFAULT UPPER),
19712: * OTHERWISE CASE IS LEFT ALONE.
19713: *
19714: SBSTG PRC E,0 ENTRY POINT
19715: BZE CSWCI,SBSG1 SKIP IF CASE NOT IGNORED
19716: JSR SBSCC CONVERT TO IGNORE CASE
19717: EXI RETURN TO CALLER
19718: *
19719: SBSG1 JSR SBSTR READ SUBSTRING IN MIXED CASE
19720: EXI RETURN TO CALLER
19721: ENP END PROCEDURE SBSTG
19722: .FI
19723: EJC
19724: *
19725: * SBSTR -- BUILD A SUBSTRING
19726: *
19727: * (XL) PTR TO SCBLK CONTAINING CHARS
19728: * (WA) NUMBER OF CHARS IN SUBSTRING
19729: * (WB) OFFSET TO FIRST CHAR IN SCBLK
19730: * JSR SBSTR CALL TO BUILD SUBSTRING
19731: * (XR) PTR TO NEW SCBLK WITH SUBSTRING
19732: * (WA,WB,WC,XL,IA) DESTROYED
19733: *
19734: * NOTE THAT SBSTR IS CALLED WITH A DUMMY STRING POINTER
19735: * (POINTING INTO A VRBLK OR SVBLK) TO COPY THE NAME OF A
19736: * VARIABLE AS A STANDARD STRING VALUE.
19737: *
19738: SBSTR PRC E,0 ENTRY POINT
19739: BZE WA,SBST2 JUMP IF NULL SUBSTRING
19740: JSR ALOCS ELSE ALLOCATE SCBLK
19741: MOV WC,WA MOVE NUMBER OF CHARACTERS
19742: MOV XR,WC SAVE PTR TO NEW SCBLK
19743: PLC XL,WB PREPARE TO LOAD CHARS FROM OLD BLK
19744: PSC XR PREPARE TO STORE CHARS IN NEW BLK
19745: MVC MOVE CHARACTERS TO NEW STRING
19746: MOV WC,XR THEN RESTORE SCBLK POINTER
19747: *
19748: * RETURN POINT
19749: *
19750: SBST1 ZER XL CLEAR GARBAGE POINTER IN XL
19751: EXI RETURN TO SBSTR CALLER
19752: *
19753: * HERE FOR NULL SUBSTRING
19754: *
19755: SBST2 MOV =NULLS,XR SET NULL STRING AS RESULT
19756: BRN SBST1 RETURN
19757: ENP END PROCEDURE SBSTR
19758: EJC
19759: *
19760: * SCANE -- SCAN AN ELEMENT
19761: *
19762: * SCANE IS CALLED AT COMPILE TIME (BY EXPAN ,CMPIL,CNCRD)
19763: * TO SCAN ONE ELEMENT FROM THE INPUT IMAGE.
19764: *
19765: * (SCNCC) NON-ZERO IF CALLED FROM CNCRD
19766: * JSR SCANE CALL TO SCAN ELEMENT
19767: * (XR) RESULT POINTER (SEE BELOW)
19768: * (XL) SYNTAX TYPE CODE (T$XXX)
19769: *
19770: * THE FOLLOWING GLOBAL LOCATIONS ARE USED.
19771: *
19772: * R$CIM POINTER TO STRING BLOCK (SCBLK)
19773: * FOR CURRENT INPUT IMAGE.
19774: *
19775: * R$CNI POINTER TO NEXT INPUT IMAGE STRING
19776: * POINTER (ZERO IF NONE).
19777: *
19778: * R$SCP SAVE POINTER (EXIT XR) FROM LAST
19779: * CALL IN CASE RESCAN IS SET.
19780: *
19781: * SCNBL THIS LOCATION IS SET NON-ZERO ON
19782: * EXIT IF SCANE SCANNED PAST BLANKS
19783: * BEFORE LOCATING THE CURRENT ELEMENT
19784: * THE END OF A LINE COUNTS AS BLANKS.
19785: *
19786: * SCNCC CNCRD SETS THIS NON-ZERO TO SCAN
19787: * CONTROL CARD NAMES AND CLEARS IT
19788: * ON RETURN
19789: *
19790: * SCNIL LENGTH OF CURRENT INPUT IMAGE
19791: *
19792: * SCNGO IF SET NON-ZERO ON ENTRY, F AND S
19793: * ARE RETURNED AS SEPARATE SYNTAX
19794: * TYPES (NOT LETTERS) (GOTO PRO-
19795: * CESSING). SCNGO IS RESET ON EXIT.
19796: *
19797: * SCNPT OFFSET TO CURRENT LOC IN R$CIM
19798: *
19799: * SCNRS IF SET NON-ZERO ON ENTRY, SCANE
19800: * RETURNS THE SAME RESULT AS ON THE
19801: * LAST CALL (RESCAN). SCNRS IS RESET
19802: * ON EXIT FROM ANY CALL TO SCANE.
19803: *
19804: * SCNTP SAVE SYNTAX TYPE FROM LAST
19805: * CALL (IN CASE RESCAN IS SET).
19806: EJC
19807: *
19808: * SCANE (CONTINUED)
19809: *
19810: *
19811: *
19812: * ELEMENT SCANNED XL XR
19813: * --------------- -- --
19814: *
19815: * CONTROL CARD NAME 0 POINTER TO SCBLK FOR NAME
19816: *
19817: * UNARY OPERATOR T$UOP PTR TO OPERATOR DVBLK
19818: *
19819: * LEFT PAREN T$LPR T$LPR
19820: *
19821: * LEFT BRACKET T$LBR T$LBR
19822: *
19823: * COMMA T$CMA T$CMA
19824: *
19825: * FUNCTION CALL T$FNC PTR TO FUNCTION VRBLK
19826: *
19827: * VARIABLE T$VAR PTR TO VRBLK
19828: *
19829: * STRING CONSTANT T$CON PTR TO SCBLK
19830: *
19831: * INTEGER CONSTANT T$CON PTR TO ICBLK
19832: *
19833: .IF .CNRA
19834: .ELSE
19835: * REAL CONSTANT T$CON PTR TO RCBLK
19836: *
19837: .FI
19838: * BINARY OPERATOR T$BOP PTR TO OPERATOR DVBLK
19839: *
19840: * RIGHT PAREN T$RPR T$RPR
19841: *
19842: * RIGHT BRACKET T$RBR T$RBR
19843: *
19844: * COLON T$COL T$COL
19845: *
19846: * SEMI-COLON T$SMC T$SMC
19847: *
19848: * F (SCNGO NE 0) T$FGO T$FGO
19849: *
19850: * S (SCNGO NE 0) T$SGO T$SGO
19851: EJC
19852: *
19853: * SCANE (CONTINUED)
19854: *
19855: * ENTRY POINT
19856: *
19857: SCANE PRC E,0 ENTRY POINT
19858: ZER SCNBL RESET BLANKS FLAG
19859: MOV WA,SCNSA SAVE WA
19860: MOV WB,SCNSB SAVE WB
19861: MOV WC,SCNSC SAVE WC
19862: BZE SCNRS,SCN03 JUMP IF NO RESCAN
19863: *
19864: * HERE FOR RESCAN REQUEST
19865: *
19866: MOV SCNTP,XL SET PREVIOUS RETURNED SCAN TYPE
19867: MOV R$SCP,XR SET PREVIOUS RETURNED POINTER
19868: ZER SCNRS RESET RESCAN SWITCH
19869: BRN SCN13 JUMP TO EXIT
19870: *
19871: * COME HERE TO READ NEW IMAGE TO TEST FOR CONTINUATION
19872: *
19873: SCN01 JSR READR READ NEXT IMAGE
19874: MOV *DVUBS,WB SET WB FOR NOT READING NAME
19875: BZE XR,SCN30 TREAT AS SEMI-COLON IF NONE
19876: PLC XR ELSE POINT TO FIRST CHARACTER
19877: LCH WC,(XR) LOAD FIRST CHARACTER
19878: BEQ WC,=CH$DT,SCN02 JUMP IF DOT FOR CONTINUATION
19879: BNE WC,=CH$PL,SCN30 ELSE TREAT AS SEMICOLON UNLESS PLUS
19880: *
19881: * HERE FOR CONTINUATION LINE
19882: *
19883: SCN02 JSR NEXTS ACQUIRE NEXT SOURCE IMAGE
19884: MOV =NUM01,SCNPT SET SCAN POINTER PAST CONTINUATION
19885: MNZ SCNBL SET BLANKS FLAG
19886: EJC
19887: *
19888: * SCANE (CONTINUED)
19889: *
19890: * MERGE HERE TO SCAN NEXT ELEMENT ON CURRENT LINE
19891: *
19892: SCN03 MOV SCNPT,WA LOAD CURRENT OFFSET
19893: BEQ WA,SCNIL,SCN01 CHECK CONTINUATION IF END
19894: MOV R$CIM,XL POINT TO CURRENT LINE
19895: PLC XL,WA POINT TO CURRENT CHARACTER
19896: MOV WA,SCNSE SET START OF ELEMENT LOCATION
19897: MOV =OPDVS,WC POINT TO OPERATOR DV LIST
19898: MOV *DVUBS,WB SET CONSTANT FOR OPERATOR CIRCUIT
19899: BRN SCN06 START SCANNING
19900: *
19901: * LOOP HERE TO IGNORE LEADING BLANKS AND TABS
19902: *
19903: SCN05 BZE WB,SCN10 JUMP IF TRAILING
19904: ICV SCNSE INCREMENT START OF ELEMENT
19905: BEQ WA,SCNIL,SCN01 JUMP IF END OF IMAGE
19906: MNZ SCNBL NOTE BLANKS SEEN
19907: *
19908: * THE FOLLOWING JUMP IS USED REPEATEDLY FOR SCANNING OUT
19909: * THE CHARACTERS OF A NUMERIC CONSTANT OR VARIABLE NAME.
19910: * THE REGISTERS ARE USED AS FOLLOWS.
19911: *
19912: * (XR) SCRATCH
19913: * (XL) PTR TO NEXT CHARACTER
19914: * (WA) CURRENT SCAN OFFSET
19915: * (WB) *DVUBS (0 IF SCANNING NAME,CONST)
19916: * (WC) =OPDVS (0 IF SCANNING CONSTANT)
19917: *
19918: SCN06 LCH XR,(XL)+ GET NEXT CHARACTER
19919: ICV WA BUMP SCAN OFFSET
19920: MOV WA,SCNPT STORE OFFSET PAST CHAR SCANNED
19921: BGE XR,=CFP$U,SCN07 QUICK CHECK FOR OTHER CHAR
19922: BSW XR,CFP$U,SCN07 SWITCH ON SCANNED CHARACTER
19923: *
19924: * SWITCH TABLE FOR SWITCH ON CHARACTER
19925: *
19926: IFF CH$BL,SCN05 BLANK
19927: .IF .CAHT
19928: IFF CH$HT,SCN05 HORIZONTAL TAB
19929: .FI
19930: .IF .CAVT
19931: IFF CH$VT,SCN05 VERTICAL TAB
19932: .FI
19933: IFF CH$D0,SCN08 DIGIT 0
19934: IFF CH$D1,SCN08 DIGIT 1
19935: IFF CH$D2,SCN08 DIGIT 2
19936: IFF CH$D3,SCN08 DIGIT 3
19937: IFF CH$D4,SCN08 DIGIT 4
19938: IFF CH$D5,SCN08 DIGIT 5
19939: IFF CH$D6,SCN08 DIGIT 6
19940: IFF CH$D7,SCN08 DIGIT 7
19941: IFF CH$D8,SCN08 DIGIT 8
19942: IFF CH$D9,SCN08 DIGIT 9
19943: EJC
19944: *
19945: * SCANE (CONTINUED)
19946: *
19947: IFF CH$LA,SCN09 LETTER A
19948: IFF CH$LB,SCN09 LETTER B
19949: IFF CH$LC,SCN09 LETTER C
19950: IFF CH$LD,SCN09 LETTER D
19951: IFF CH$LE,SCN09 LETTER E
19952: IFF CH$LG,SCN09 LETTER G
19953: IFF CH$LH,SCN09 LETTER H
19954: IFF CH$LI,SCN09 LETTER I
19955: IFF CH$LJ,SCN09 LETTER J
19956: IFF CH$LK,SCN09 LETTER K
19957: IFF CH$LL,SCN09 LETTER L
19958: IFF CH$LM,SCN09 LETTER M
19959: IFF CH$LN,SCN09 LETTER N
19960: IFF CH$LO,SCN09 LETTER O
19961: IFF CH$LP,SCN09 LETTER P
19962: IFF CH$LQ,SCN09 LETTER Q
19963: IFF CH$LR,SCN09 LETTER R
19964: IFF CH$LT,SCN09 LETTER T
19965: IFF CH$LU,SCN09 LETTER U
19966: IFF CH$LV,SCN09 LETTER V
19967: IFF CH$LW,SCN09 LETTER W
19968: IFF CH$LX,SCN09 LETTER X
19969: IFF CH$LY,SCN09 LETTER Y
19970: IFF CH$L$,SCN09 LETTER Z
19971: .IF .CASL
19972: IFF CH$$A,SCN09 SHIFTED A
19973: IFF CH$$B,SCN09 SHIFTED B
19974: IFF CH$$C,SCN09 SHIFTED C
19975: IFF CH$$D,SCN09 SHIFTED D
19976: IFF CH$$E,SCN09 SHIFTED E
19977: IFF CH$$F,SCN20 SHIFTED F
19978: IFF CH$$G,SCN09 SHIFTED G
19979: IFF CH$$H,SCN09 SHIFTED H
19980: IFF CH$$I,SCN09 SHIFTED I
19981: IFF CH$$J,SCN09 SHIFTED J
19982: IFF CH$$K,SCN09 SHIFTED K
19983: IFF CH$$L,SCN09 SHIFTED L
19984: IFF CH$$M,SCN09 SHIFTED M
19985: IFF CH$$N,SCN09 SHIFTED N
19986: IFF CH$$O,SCN09 SHIFTED O
19987: IFF CH$$P,SCN09 SHIFTED P
19988: IFF CH$$Q,SCN09 SHIFTED Q
19989: IFF CH$$R,SCN09 SHIFTED R
19990: IFF CH$$S,SCN21 SHIFTED S
19991: IFF CH$$T,SCN09 SHIFTED T
19992: IFF CH$$U,SCN09 SHIFTED U
19993: IFF CH$$V,SCN09 SHIFTED V
19994: IFF CH$$W,SCN09 SHIFTED W
19995: IFF CH$$X,SCN09 SHIFTED X
19996: IFF CH$$Y,SCN09 SHIFTED Y
19997: IFF CH$$$,SCN09 SHIFTED Z
19998: .FI
19999: EJC
20000: *
20001: * SCANE (CONTINUED)
20002: *
20003: IFF CH$SQ,SCN16 SINGLE QUOTE
20004: IFF CH$DQ,SCN17 DOUBLE QUOTE
20005: IFF CH$LF,SCN20 LETTER F
20006: IFF CH$LS,SCN21 LETTER S
20007: IFF CH$UN,SCN24 UNDERLINE
20008: IFF CH$PP,SCN25 LEFT PAREN
20009: IFF CH$RP,SCN26 RIGHT PAREN
20010: IFF CH$RB,SCN27 RIGHT BRACKET
20011: IFF CH$BB,SCN28 LEFT BRACKET
20012: IFF CH$CB,SCN27 RIGHT BRACKET
20013: IFF CH$OB,SCN28 LEFT BRACKET
20014: IFF CH$CL,SCN29 COLON
20015: IFF CH$SM,SCN30 SEMI-COLON
20016: IFF CH$CM,SCN31 COMMA
20017: IFF CH$DT,SCN32 DOT
20018: IFF CH$PL,SCN34 PLUS
20019: IFF CH$MN,SCN35 MINUS
20020: IFF CH$NT,SCN36 NOT
20021: IFF CH$DL,SCN33 DOLLAR
20022: IFF CH$EX,SCN37 EXCLAMATION MARK
20023: IFF CH$PC,SCN38 PERCENT
20024: IFF CH$SL,SCN40 SLASH
20025: IFF CH$NM,SCN41 NUMBER SIGN
20026: IFF CH$AT,SCN42 AT
20027: IFF CH$BR,SCN43 VERTICAL BAR
20028: IFF CH$AM,SCN44 AMPERSAND
20029: IFF CH$QU,SCN45 QUESTION MARK
20030: IFF CH$EQ,SCN46 EQUAL
20031: IFF CH$AS,SCN49 ASTERISK
20032: ESW END SWITCH ON CHARACTER
20033: *
20034: * HERE FOR ILLEGAL CHARACTER (UNDERLINE MERGES)
20035: *
20036: SCN07 BZE WB,SCN10 JUMP IF SCANNING NAME OR CONSTANT
20037: ERB 232,SYNTAX ERROR. ILLEGAL CHARACTER
20038: EJC
20039: *
20040: * SCANE (CONTINUED)
20041: *
20042: * HERE FOR DIGITS 0-9
20043: *
20044: SCN08 BZE WB,SCN09 KEEP SCANNING IF NAME/CONSTANT
20045: ZER WC ELSE SET FLAG FOR SCANNING CONSTANT
20046: *
20047: * HERE FOR LETTER. LOOP HERE WHEN SCANNING NAME/CONSTANT
20048: *
20049: SCN09 BEQ WA,SCNIL,SCN11 JUMP IF END OF IMAGE
20050: ZER WB SET FLAG FOR SCANNING NAME/CONST
20051: BRN SCN06 MERGE BACK TO CONTINUE SCAN
20052: *
20053: * COME HERE FOR DELIMITER ENDING NAME OR CONSTANT
20054: *
20055: SCN10 DCV WA RESET OFFSET TO POINT TO DELIMITER
20056: *
20057: * COME HERE AFTER FINISHING SCAN OF NAME OR CONSTANT
20058: *
20059: SCN11 MOV WA,SCNPT STORE UPDATED SCAN OFFSET
20060: MOV SCNSE,WB POINT TO START OF ELEMENT
20061: SUB WB,WA GET NUMBER OF CHARACTERS
20062: MOV R$CIM,XL POINT TO LINE IMAGE
20063: BNZ WC,SCN15 JUMP IF NAME
20064: *
20065: * HERE AFTER SCANNING OUT NUMERIC CONSTANT
20066: *
20067: JSR SBSTR GET STRING FOR CONSTANT
20068: MOV XR,DNAMP DELETE FROM STORAGE (NOT NEEDED)
20069: JSR GTNUM CONVERT TO NUMERIC
20070: PPM SCN14 JUMP IF CONVERSION FAILURE
20071: *
20072: * MERGE HERE TO EXIT WITH CONSTANT
20073: *
20074: SCN12 MOV =T$CON,XL SET RESULT TYPE OF CONSTANT
20075: EJC
20076: *
20077: * SCANE (CONTINUED)
20078: *
20079: * COMMON EXIT POINT (XR,XL) SET
20080: *
20081: SCN13 MOV SCNSA,WA RESTORE WA
20082: MOV SCNSB,WB RESTORE WB
20083: MOV SCNSC,WC RESTORE WC
20084: MOV XR,R$SCP SAVE XR IN CASE RESCAN
20085: MOV XL,SCNTP SAVE XL IN CASE RESCAN
20086: ZER SCNGO RESET POSSIBLE GOTO FLAG
20087: EXI RETURN TO SCANE CALLER
20088: *
20089: * HERE IF CONVERSION ERROR ON NUMERIC ITEM
20090: *
20091: SCN14 ERB 233,SYNTAX ERROR. INVALID NUMERIC ITEM
20092: *
20093: * HERE AFTER SCANNING OUT VARIABLE NAME
20094: *
20095: .IF .CASL
20096: SCN15 JSR SBSTG BUILD STRING NAME OF VARIABLE
20097: .ELSE
20098: SCN15 JSR SBSTR BUILD STRING NAME OF VARIABLE
20099: .FI
20100: BNZ SCNCC,SCN13 RETURN IF CNCRD CALL
20101: JSR GTNVR LOCATE/BUILD VRBLK
20102: PPM DUMMY (UNUSED) ERROR RETURN
20103: MOV =T$VAR,XL SET TYPE AS VARIABLE
20104: BRN SCN13 BACK TO EXIT
20105: *
20106: * HERE FOR SINGLE QUOTE (START OF STRING CONSTANT)
20107: *
20108: SCN16 BZE WB,SCN10 TERMINATOR IF SCANNING NAME OR CNST
20109: MOV =CH$SQ,WB SET TERMINATOR AS SINGLE QUOTE
20110: BRN SCN18 MERGE
20111: *
20112: * HERE FOR DOUBLE QUOTE (START OF STRING CONSTANT)
20113: *
20114: SCN17 BZE WB,SCN10 TERMINATOR IF SCANNING NAME OR CNST
20115: MOV =CH$DQ,WB SET DOUBLE QUOTE TERMINATOR, MERGE
20116: *
20117: * LOOP TO SCAN OUT STRING CONSTANT
20118: *
20119: SCN18 BEQ WA,SCNIL,SCN19 ERROR IF END OF IMAGE
20120: LCH WC,(XL)+ ELSE LOAD NEXT CHARACTER
20121: ICV WA BUMP OFFSET
20122: BNE WC,WB,SCN18 LOOP BACK IF NOT TERMINATOR
20123: EJC
20124: *
20125: * SCANE (CONTINUED)
20126: *
20127: * HERE AFTER SCANNING OUT STRING CONSTANT
20128: *
20129: MOV SCNPT,WB POINT TO FIRST CHARACTER
20130: MOV WA,SCNPT SAVE OFFSET PAST FINAL QUOTE
20131: DCV WA POINT BACK PAST LAST CHARACTER
20132: SUB WB,WA GET NUMBER OF CHARACTERS
20133: MOV R$CIM,XL POINT TO INPUT IMAGE
20134: JSR SBSTR BUILD SUBSTRING VALUE
20135: BRN SCN12 BACK TO EXIT WITH CONSTANT RESULT
20136: *
20137: * HERE IF NO MATCHING QUOTE FOUND
20138: *
20139: SCN19 MOV WA,SCNPT SET UPDATED SCAN POINTER
20140: ERB 234,SYNTAX ERROR. UNMATCHED STRING QUOTE
20141: *
20142: * HERE FOR F (POSSIBLE FAILURE GOTO)
20143: *
20144: SCN20 MOV =T$FGO,XR SET RETURN CODE FOR FAIL GOTO
20145: BRN SCN22 JUMP TO MERGE
20146: *
20147: * HERE FOR S (POSSIBLE SUCCESS GOTO)
20148: *
20149: SCN21 MOV =T$SGO,XR SET SUCCESS GOTO AS RETURN CODE
20150: *
20151: * SPECIAL GOTO CASES MERGE HERE
20152: *
20153: SCN22 BZE SCNGO,SCN09 TREAT AS NORMAL LETTER IF NOT GOTO
20154: *
20155: * MERGE HERE FOR SPECIAL CHARACTER EXIT
20156: *
20157: SCN23 BZE WB,SCN10 JUMP IF END OF NAME/CONSTANT
20158: MOV XR,XL ELSE COPY CODE
20159: BRN SCN13 AND JUMP TO EXIT
20160: *
20161: * HERE FOR UNDERLINE
20162: *
20163: SCN24 BZE WB,SCN09 PART OF NAME IF SCANNING NAME
20164: BRN SCN07 ELSE ILLEGAL
20165: EJC
20166: *
20167: * SCANE (CONTINUED)
20168: *
20169: * HERE FOR LEFT PAREN
20170: *
20171: SCN25 MOV =T$LPR,XR SET LEFT PAREN RETURN CODE
20172: BNZ WB,SCN23 RETURN LEFT PAREN UNLESS NAME
20173: BZE WC,SCN10 DELIMITER IF SCANNING CONSTANT
20174: *
20175: * HERE FOR LEFT PAREN AFTER NAME (FUNCTION CALL)
20176: *
20177: MOV SCNSE,WB POINT TO START OF NAME
20178: MOV WA,SCNPT SET POINTER PAST LEFT PAREN
20179: DCV WA POINT BACK PAST LAST CHAR OF NAME
20180: SUB WB,WA GET NAME LENGTH
20181: MOV R$CIM,XL POINT TO INPUT IMAGE
20182: JSR SBSTR GET STRING NAME FOR FUNCTION
20183: JSR GTNVR LOCATE/BUILD VRBLK
20184: PPM DUMMY (UNUSED) ERROR RETURN
20185: MOV =T$FNC,XL SET CODE FOR FUNCTION CALL
20186: BRN SCN13 BACK TO EXIT
20187: *
20188: * PROCESSING FOR SPECIAL CHARACTERS
20189: *
20190: SCN26 MOV =T$RPR,XR RIGHT PAREN, SET CODE
20191: BRN SCN23 TAKE SPECIAL CHARACTER EXIT
20192: *
20193: SCN27 MOV =T$RBR,XR RIGHT BRACKET, SET CODE
20194: BRN SCN23 TAKE SPECIAL CHARACTER EXIT
20195: *
20196: SCN28 MOV =T$LBR,XR LEFT BRACKET, SET CODE
20197: BRN SCN23 TAKE SPECIAL CHARACTER EXIT
20198: *
20199: SCN29 MOV =T$COL,XR COLON, SET CODE
20200: BRN SCN23 TAKE SPECIAL CHARACTER EXIT
20201: *
20202: SCN30 MOV =T$SMC,XR SEMI-COLON, SET CODE
20203: BRN SCN23 TAKE SPECIAL CHARACTER EXIT
20204: *
20205: SCN31 MOV =T$CMA,XR COMMA, SET CODE
20206: BRN SCN23 TAKE SPECIAL CHARACTER EXIT
20207: EJC
20208: *
20209: * SCANE (CONTINUED)
20210: *
20211: * HERE FOR OPERATORS. ON ENTRY, WC POINTS TO THE TABLE OF
20212: * OPERATOR DOPE VECTORS AND WB IS THE INCREMENT TO STEP
20213: * TO THE NEXT PAIR (BINARY/UNARY) OF DOPE VECTORS IN THE
20214: * LIST. ON REACHING SCN46, THE POINTER HAS BEEN ADJUSTED TO
20215: * POINT TO THE APPROPRIATE PAIR OF DOPE VECTORS.
20216: * THE FIRST FOUR ENTRIES ARE SPECIAL SINCE THEY CAN OCCUR
20217: * AS PART OF A VARIABLE NAME (.$) OR CONSTANT (.+-).
20218: *
20219: SCN32 BZE WB,SCN09 DOT CAN BE PART OF NAME OR CONSTANT
20220: ADD WB,WC ELSE BUMP POINTER
20221: *
20222: SCN33 BZE WB,SCN09 DOLLAR CAN BE PART OF NAME
20223: ADD WB,WC ELSE BUMP POINTER
20224: *
20225: SCN34 BZE WC,SCN09 PLUS CAN BE PART OF CONSTANT
20226: BZE WB,SCN48 PLUS CANNOT BE PART OF NAME
20227: ADD WB,WC ELSE BUMP POINTER
20228: *
20229: SCN35 BZE WC,SCN09 MINUS CAN BE PART OF CONSTANT
20230: BZE WB,SCN48 MINUS CANNOT BE PART OF NAME
20231: ADD WB,WC ELSE BUMP POINTER
20232: LCH XR,(XL) GET NEXT CHARACTER
20233: BLT XR,=CH$D0,SCN36 SKIP IF NOT DIGIT
20234: BLE XR,=CH$D9,SCN08 JUMP IF DIGIT
20235: *
20236: SCN36 ADD WB,WC NOT
20237: SCN37 ADD WB,WC EXCLAMATION
20238: SCN38 ADD WB,WC PERCENT
20239: SCN39 ADD WB,WC ASTERISK
20240: SCN40 ADD WB,WC SLASH
20241: SCN41 ADD WB,WC NUMBER SIGN
20242: SCN42 ADD WB,WC AT SIGN
20243: SCN43 ADD WB,WC VERTICAL BAR
20244: SCN44 ADD WB,WC AMPERSAND
20245: SCN45 ADD WB,WC QUESTION MARK
20246: EJC
20247: *
20248: * SCANE (CONTINUED)
20249: *
20250: * ALL OPERATORS COME HERE (EQUAL MERGES DIRECTLY)
20251: * (WC) POINTS TO THE BINARY/UNARY PAIR OF OPERATOR DVBLKS.
20252: *
20253: SCN46 BZE WB,SCN10 OPERATOR TERMINATES NAME/CONSTANT
20254: MOV WC,XR ELSE COPY DV POINTER
20255: LCH WC,(XL) LOAD NEXT CHARACTER
20256: MOV =T$BOP,XL SET BINARY OP IN CASE
20257: BEQ WA,SCNIL,SCN47 SHOULD BE BINARY IF IMAGE END
20258: BEQ WC,=CH$BL,SCN47 SHOULD BE BINARY IF FOLLOWED BY BLK
20259: .IF .CAHT
20260: BEQ WC,=CH$HT,SCN47 JUMP IF HORIZONTAL TAB
20261: .FI
20262: .IF .CAVT
20263: BEQ WC,=CH$VT,SCN47 JUMP IF VERTICAL TAB
20264: .FI
20265: BEQ WC,=CH$SM,SCN47 SEMICOLON CAN IMMEDIATELY FOLLOW =
20266: *
20267: * HERE FOR UNARY OPERATOR
20268: *
20269: ADD *DVBS$,XR POINT TO DV FOR UNARY OP
20270: MOV =T$UOP,XL SET TYPE FOR UNARY OPERATOR
20271: BLE SCNTP,=T$UOK,SCN13 OK UNARY IF OK PRECEDING ELEMENT
20272: EJC
20273: *
20274: * SCANE (CONTINUED)
20275: *
20276: * MERGE HERE TO REQUIRE PRECEDING BLANKS
20277: *
20278: SCN47 BNZ SCNBL,SCN13 ALL OK IF PRECEDING BLANKS, EXIT
20279: *
20280: * FAIL OPERATOR IN THIS POSITION
20281: *
20282: SCN48 ERB 235,SYNTAX ERROR. INVALID USE OF OPERATOR
20283: *
20284: * HERE FOR ASTERISK, COULD BE ** SUBSTITUTE FOR EXCLAMATION
20285: *
20286: SCN49 BZE WB,SCN10 END OF NAME IF SCANNING NAME
20287: BEQ WA,SCNIL,SCN39 NOT ** IF * AT IMAGE END
20288: MOV WA,XR ELSE SAVE OFFSET PAST FIRST *
20289: MOV WA,SCNOF SAVE ANOTHER COPY
20290: LCH WA,(XL)+ LOAD NEXT CHARACTER
20291: BNE WA,=CH$AS,SCN50 NOT ** IF NEXT CHAR NOT *
20292: ICV XR ELSE STEP OFFSET PAST SECOND *
20293: BEQ XR,SCNIL,SCN51 OK EXCLAM IF END OF IMAGE
20294: LCH WA,(XL) ELSE LOAD NEXT CHARACTER
20295: BEQ WA,=CH$BL,SCN51 EXCLAMATION IF BLANK
20296: .IF .CAHT
20297: BEQ WA,=CH$HT,SCN51 EXCLAMATION IF HORIZONTAL TAB
20298: .FI
20299: .IF .CAVT
20300: BEQ WA,=CH$VT,SCN51 EXCLAMATION IF VERTICAL TAB
20301: .FI
20302: *
20303: * UNARY *
20304: *
20305: SCN50 MOV SCNOF,WA RECOVER STORED OFFSET
20306: MOV R$CIM,XL POINT TO LINE AGAIN
20307: PLC XL,WA POINT TO CURRENT CHAR
20308: BRN SCN39 MERGE WITH UNARY *
20309: *
20310: * HERE FOR ** AS SUBSTITUTE FOR EXCLAMATION
20311: *
20312: SCN51 MOV XR,SCNPT SAVE SCAN POINTER PAST 2ND *
20313: MOV XR,WA COPY SCAN POINTER
20314: BRN SCN37 MERGE WITH EXCLAMATION
20315: ENP END PROCEDURE SCANE
20316: EJC
20317: *
20318: * SCNGF -- SCAN GOTO FIELD
20319: *
20320: * SCNGF IS CALLED FROM CMPIL TO SCAN AND ANALYZE A GOTO
20321: * FIELD INCLUDING THE SURROUNDING BRACKETS OR PARENTHESES.
20322: * FOR A NORMAL GOTO, THE RESULT RETURNED IS EITHER A VRBLK
20323: * POINTER FOR A SIMPLE LABEL OPERAND, OR A POINTER TO AN
20324: * EXPRESSION TREE WITH A SPECIAL OUTER UNARY OPERATOR
20325: * (O$GOC). FOR A DIRECT GOTO, THE RESULT RETURNED IS A
20326: * POINTER TO AN EXPRESSION TREE WITH THE SPECIAL OUTER
20327: * UNARY OPERATOR O$GOD.
20328: *
20329: * JSR SCNGF CALL TO SCAN GOTO FIELD
20330: * (XR) RESULT (SEE ABOVE)
20331: * (XL,WA,WB,WC) DESTROYED
20332: *
20333: SCNGF PRC E,0 ENTRY POINT
20334: JSR SCANE SCAN INITIAL ELEMENT
20335: BEQ XL,=T$LPR,SCNG1 SKIP IF LEFT PAREN (NORMAL GOTO)
20336: BEQ XL,=T$LBR,SCNG2 SKIP IF LEFT BRACKET (DIRECT GOTO)
20337: ERB 236,SYNTAX ERROR. GOTO FIELD INCORRECT
20338: *
20339: * HERE FOR LEFT PAREN (NORMAL GOTO)
20340: *
20341: SCNG1 MOV =NUM01,WB SET EXPAN FLAG FOR NORMAL GOTO
20342: JSR EXPAN ANALYZE GOTO FIELD
20343: MOV =OPDVN,WA ELSE POINT TO OPDV FOR COMPLEX GOTO
20344: BLE XR,STATB,SCNG3 JUMP IF NOT IN STATIC
20345: BLO XR,STATE,SCNG4 JUMP TO EXIT IF SIMPLE LABEL NAME
20346: BRN SCNG3 AND MERGE
20347: *
20348: * HERE FOR LEFT BRACKET (DIRECT GOTO)
20349: *
20350: SCNG2 MOV =NUM02,WB SET EXPAN FLAG FOR DIRECT GOTO
20351: JSR EXPAN SCAN GOTO FIELD
20352: MOV =OPDVD,WA SET OPDV POINTER FOR DIRECT GOTO
20353: EJC
20354: *
20355: * SCNGF (CONTINUED)
20356: *
20357: * MERGE HERE TO BUILD OUTER UNARY OPERATOR BLOCK
20358: *
20359: SCNG3 MOV WA,-(XS) STACK OPERATOR DV POINTER
20360: MOV XR,-(XS) STACK POINTER TO EXPRESSION TREE
20361: JSR EXPOP POP OPERATOR OFF
20362: MOV (XS)+,XR RELOAD NEW EXPRESSION TREE POINTER
20363: *
20364: * COMMON EXIT POINT
20365: *
20366: SCNG4 EXI RETURN TO CALLER
20367: ENP END PROCEDURE SCNGF
20368: EJC
20369: *
20370: * SETVR -- SET VRGET,VRSTO FIELDS OF VRBLK
20371: *
20372: * SETVR SETS THE PROPER VALUES IN THE VRGET AND VRSTO
20373: * FIELDS OF A VRBLK. IT IS CALLED WHENEVER TRBLKS ARE
20374: * ADDED OR SUBTRACTED (TRACE,STOPTR,INPUT,OUTPUT,DETACH)
20375: *
20376: * (XR) POINTER TO VRBLK
20377: * JSR SETVR CALL TO SET FIELDS
20378: * (XL,WA) DESTROYED
20379: *
20380: * NOTE THAT SETVR IGNORES THE CALL IF XR DOES NOT POINT
20381: * INTO THE STATIC REGION (I.E. IS SOME OTHER NAME BASE)
20382: *
20383: SETVR PRC E,0 ENTRY POINT
20384: BHI XR,STATE,SETV1 EXIT IF NOT NATURAL VARIABLE
20385: *
20386: * HERE IF WE HAVE A VRBLK
20387: *
20388: MOV XR,XL COPY VRBLK POINTER
20389: MOV =B$VRL,VRGET(XR) STORE NORMAL GET VALUE
20390: BEQ VRSTO(XR),=B$VRE,SETV1 SKIP IF PROTECTED VARIABLE
20391: MOV =B$VRS,VRSTO(XR) STORE NORMAL STORE VALUE
20392: MOV VRVAL(XL),XL POINT TO NEXT ENTRY ON CHAIN
20393: BNE (XL),=B$TRT,SETV1 JUMP IF END OF TRBLK CHAIN
20394: MOV =B$VRA,VRGET(XR) STORE TRAPPED ROUTINE ADDRESS
20395: MOV =B$VRV,VRSTO(XR) SET TRAPPED ROUTINE ADDRESS
20396: *
20397: * MERGE HERE TO EXIT TO CALLER
20398: *
20399: SETV1 EXI RETURN TO SETVR CALLER
20400: ENP END PROCEDURE SETVR
20401: .IF .CNSR
20402: .ELSE
20403: EJC
20404: *
20405: * SORTA -- SORT ARRAY
20406: *
20407: * ROUTINE TO SORT AN ARRAY OR TABLE ON SAME BASIS AS IN
20408: * SITBOL. A TABLE IS CONVERTED TO AN ARRAY, LEAVING TWO
20409: * DIMENSIONAL ARRAYS AND VECTORS AS CASES TO BE CONSIDERED.
20410: * WHOLE ROWS OF ARRAYS ARE PERMUTED ACCORDING TO THE
20411: * ORDERING OF THE KEYS THEY CONTAIN, AND THE STRIDE
20412: * REFERRED TO, IS THE THE LENGTH OF A ROW. IT IS ONE
20413: * FOR A VECTOR.
20414: * THE SORT USED IS HEAPSORT, FUNDAMENTALS OF DATA STRUCTURES,
20415: * HOROWITZ AND SAHNI, PITMAN 1977, PAGE 347.
20416: * IT IS AN ORDER N*LOG(N) ALGORITHM. IN ORDER
20417: * TO MAKE IT STABLE, COMPARANDS MAY NOT COMPARE EQUAL. THIS
20418: * IS ACHIEVED BY SORTING A COPY ARRAY (REFERRED TO AS THE
20419: * SORT ARRAY) CONTAINING AT ITS HIGH ADDRESS END, BAU
20420: * OFFSETS TO THE ROWS TO BE SORTED HELD IN THE ORIGINAL
20421: * ARRAY (REFERRED TO AS THE KEY ARRAY). SORTC, THE
20422: * COMPARISON ROUTINE, ACCESSES THE KEYS THROUGH THESE
20423: * OFFSETS AND IN THE CASE OF EQUALITY, RESOLVES IT BY
20424: * COMPARING THE OFFSETS THEMSELVES. THE SORT PERMUTES THE
20425: * OFFSETS WHICH ARE THEN USED IN A FINAL OPERATION TO COPY
20426: * THE ACTUAL ITEMS INTO THE NEW ARRAY IN SORTED ORDER.
20427: * REFERENCES TO ZEROTH ITEM ARE TO NOTIONAL ITEM
20428: * PRECEDING FIRST ACTUAL ITEM.
20429: * REVERSE SORTING FOR RSORT IS DONE BY HAVING THE LESS THAN
20430: * TEST FOR KEYS EFFECTIVELY BE REPLACED BY A
20431: * GREATER THAN TEST.
20432: * GIVES ERROR MESSAGES FOR INCORRECT ARGS, RETURNS EXI 1
20433: * FOR EMPTY TABLE.
20434: *
20435: * 1(XS) FIRST ARG - ARRAY OR TABLE
20436: * 0(XS) 2ND ARG - INDEX OR PDTYPE NAME
20437: * (WA) 0 , NON-ZERO FOR SORT , RSORT
20438: * JSR SORTA CALL TO SORT ARRAY
20439: * PPM LOC FAIL RETURN FOR EMPTY TABLE
20440: * (XR) SORTED ARRAY
20441: * (XL,WA,WB,WC) DESTROYED
20442: EJC
20443: *
20444: * SORTA (CONTINUED)
20445: *
20446: SORTA PRC N,1 ENTRY POINT
20447: MOV WA,SRTSR SORT/RSORT INDICATOR
20448: MOV *NUM01,SRTST DEFAULT STRIDE OF 1
20449: ZER SRTOF DEFAULT ZERO OFFSET TO SORT KEY
20450: MOV =NULLS,SRTDF CLEAR DATATYPE FIELD NAME
20451: MOV (XS)+,R$SXR UNSTACK ARGUMENT 2
20452: MOV (XS)+,XR GET FIRST ARGUMENT
20453: MOV (XR),WA GET ARG TYPE
20454: BEQ WA,=B$ART,SRT00 SKIP IF ARRAY
20455: BNE WA,=B$TBT,SRT16 ERROR IF NOT TABLE
20456: JSR GTARR CONVERT TO ARRAY
20457: PPM SRT18 FAIL
20458: *
20459: * MAKE COPY OF ARRAY
20460: *
20461: SRT00 MOV XR,-(XS) STACK PTR TO RESULTING KEY ARRAY
20462: MOV XR,-(XS) ANOTHER COPY FOR CBLCK
20463: JSR CBLCK GET COPY ARRAY FOR SORTING INTO
20464: PPM CANT FAIL
20465: MOV XR,-(XS) STACK POINTER TO SORT ARRAY
20466: MOV R$SXR,XR GET SECOND ARG
20467: MOV 1(XS),XL GET PTR TO KEY ARRAY
20468: BNE (XL),=B$VCT,SRT02 JUMP IF ARBLK
20469: BEQ XR,=NULLS,SRT01 JUMP IF NULL SECOND ARG
20470: JSR GTNVR GET VRBLK PTR FOR IT
20471: ERR 237,ERRONEOUS 2ND ARG IN SORT/RSORT OF VECTOR
20472: MOV XR,SRTDF STORE DATATYPE FIELD NAME VRBLK
20473: *
20474: * COMPUTE N AND OFFSET TO ITEM A(0) IN VECTOR CASE
20475: *
20476: SRT01 MOV *VCLEN,WC OFFSET TO A(0)
20477: MOV *VCVLS,WB OFFSET TO FIRST ITEM
20478: MOV VCLEN(XL),WA GET BLOCK LENGTH
20479: SUB *VCSI$,WA GET NO. OF ENTRIES, N (IN BAUS)
20480: BRN SRT04 MERGE
20481: *
20482: * HERE FOR ARRAY
20483: *
20484: SRT02 LDI ARDIM(XL) GET POSSIBLE DIMENSION
20485: MFI WA CONVERT TO SHORT INTEGER
20486: WTB WA FURTHER CONVERT TO BAUS
20487: MOV *ARVLS,WB OFFSET TO FIRST VALUE IF ONE DIM.
20488: MOV *ARPRO,WC OFFSET BEFORE VALUES IF ONE DIM.
20489: BEQ ARNDM(XL),=NUM01,SRT04 JUMP IF IN FACT ONE DIMENSION
20490: BNE ARNDM(XL),=NUM02,SRT16 FAIL UNLESS TWO DIMENSIONAL
20491: LDI ARLB2(XL) GET LOWER BOUND 2 AS DEFAULT COLUMN
20492: BEQ XR,=NULLS,SRT03 JUMP IF DEFAULT SECOND ARG
20493: JSR GTINT CONVERT TO INTEGER
20494: PPM SRT17 FAIL
20495: LDI ICVAL(XR) GET ACTUAL INTEGER VALUE
20496: EJC
20497: *
20498: * SORTA (CONTINUED)
20499: *
20500: * HERE WITH SORT COLUMN INDEX IN IA IN ARRAY CASE
20501: *
20502: SRT03 SBI ARLB2(XL) SUBTRACT LOW BOUND
20503: IOV SRT17 FAIL IF OVERFLOW
20504: ILT SRT17 FAIL IF BELOW LOW BOUND
20505: SBI ARDM2(XL) CHECK AGAINST DIMENSION
20506: IGE SRT17 FAIL IF TOO LARGE
20507: ADI ARDM2(XL) RESTORE VALUE
20508: MFI WA GET AS SMALL INTEGER
20509: WTB WA OFFSET WITHIN ROW TO KEY
20510: MOV WA,SRTOF KEEP OFFSET
20511: LDI ARDM2(XL) SECOND DIMENSION IS ROW LENGTH
20512: MFI WA CONVERT TO SHORT INTEGER
20513: MOV WA,XR COPY ROW LENGTH
20514: WTB WA CONVERT TO BAUS
20515: MOV WA,SRTST STORE AS STRIDE
20516: LDI ARDIM(XL) GET NUMBER OF ROWS
20517: MFI WA AS A SHORT INTEGER
20518: WTB WA CONVERT N TO BAUS
20519: MOV ARLEN(XL),WC OFFSET PAST ARRAY END
20520: SUB WA,WC ADJUST, GIVING SPACE FOR N OFFSETS
20521: DCA WC POINT TO A(0)
20522: MOV AROFS(XL),WB OFFSET TO WORD BEFORE FIRST ITEM
20523: ICA WB OFFSET TO FIRST ITEM
20524: *
20525: * SEPARATE PRE-PROCESSING FOR ARRAYS AND VECTORS DONE.
20526: * TO SIMPLIFY LATER KEY COMPARISONS, REMOVAL OF ANY TRBLK
20527: * TRAP BLOCKS FROM ENTRIES IN KEY ARRAY IS EFFECTED.
20528: *
20529: * (XL) = 1(XS) = POINTER TO KEY ARRAY
20530: * (XS) = POINTER TO SORT ARRAY
20531: * WA = NUMBER OF ITEMS, N (CONVERTED TO BAUS).
20532: * WB = OFFSET TO FIRST ITEM OF ARRAYS.
20533: * WC = OFFSET TO A(0)
20534: *
20535: SRT04 BLE WA,*NUM01,SRT15 RETURN IF ONLY A SINGLE ITEM
20536: MOV WA,SRTSN STORE NUMBER OF ITEMS (IN BAUS)
20537: MOV WC,SRTSO STORE OFFSET TO A(0)
20538: MOV ARLEN(XL),WC LENGTH OF ARRAY OR VEC (=VCLEN)
20539: ADD XL,WC POINT PAST END OF ARRAY OR VECTOR
20540: MOV WB,SRTSF STORE OFFSET TO FIRST ROW
20541: ADD WB,XL POINT TO FIRST ITEM IN KEY ARRAY
20542: *
20543: * LOOP THROUGH ARRAY
20544: *
20545: SRT05 MOV (XL),XR GET AN ENTRY
20546: *
20547: * HUNT ALONG TRBLK CHAIN
20548: *
20549: SRT06 BNE (XR),=B$TRT,SRT07 JUMP OUT IF NOT TRBLK
20550: MOV TRVAL(XR),XR GET VALUE FIELD
20551: BRN SRT06 LOOP
20552: EJC
20553: *
20554: * SORTA (CONTINUED)
20555: *
20556: * XR IS VALUE FROM END OF CHAIN
20557: *
20558: SRT07 MOV XR,(XL)+ STORE AS ARRAY ENTRY
20559: BLT XL,WC,SRT05 LOOP IF NOT DONE
20560: MOV (XS),XL GET ADRS OF SORT ARRAY
20561: MOV SRTSF,XR INITIAL OFFSET TO FIRST KEY
20562: MOV SRTST,WB GET STRIDE
20563: ADD SRTSO,XL OFFSET TO A(0)
20564: ICA XL POINT TO A(1)
20565: MOV SRTSN,WC GET N
20566: BTW WC CONVERT FROM BAUS
20567: MOV WC,SRTNR STORE AS ROW COUNT
20568: LCT WC,WC LOOP COUNTER
20569: *
20570: * STORE KEY OFFSETS AT TOP OF SORT ARRAY
20571: *
20572: SRT08 MOV XR,(XL)+ STORE AN OFFSET
20573: ADD WB,XR BUMP OFFSET BY STRIDE
20574: BCT WC,SRT08 LOOP THROUGH ROWS
20575: *
20576: * PERFORM THE SORT ON OFFSETS IN SORT ARRAY.
20577: *
20578: * (SRTSN) NUMBER OF ITEMS TO SORT, N (BAUS)
20579: * (SRTSO) OFFSET TO A(0)
20580: *
20581: SRT09 MOV SRTSN,WA GET N
20582: MOV SRTNR,WC GET NUMBER OF ROWS
20583: RSH WC,1 I = N / 2 (WC=I, INDEX INTO ARRAY)
20584: WTB WC CONVERT BACK TO BAUS
20585: *
20586: * LOOP TO FORM INITIAL HEAP
20587: *
20588: SRT10 JSR SORTH SORTH(I,N)
20589: DCA WC I = I - 1
20590: BNZ WC,SRT10 LOOP IF I GT 0
20591: MOV WA,WC I = N
20592: *
20593: * SORTING LOOP. AT THIS POINT, A(1) IS THE LARGEST
20594: * ITEM, SINCE ALGORITHM INITIALISES IT AS, AND THEN MAINTAINS
20595: * IT AS, ROOT OF TREE.
20596: *
20597: SRT11 DCA WC I = I - 1 (N - 1 INITIALLY)
20598: BZE WC,SRT12 JUMP IF DONE
20599: MOV (XS),XR GET SORT ARRAY ADDRESS
20600: ADD SRTSO,XR POINT TO A(0)
20601: MOV XR,XL A(0) ADDRESS
20602: ADD WC,XL A(I) ADDRESS
20603: MOV 1(XL),WB COPY A(I+1)
20604: MOV 1(XR),1(XL) MOVE A(1) TO A(I+1)
20605: MOV WB,1(XR) COMPLETE EXCHANGE OF A(1), A(I+1)
20606: MOV WC,WA N = I FOR SORTH
20607: MOV *NUM01,WC I = 1 FOR SORTH
20608: JSR SORTH SORTH(1,N)
20609: MOV WA,WC RESTORE WC
20610: BRN SRT11 LOOP
20611: EJC
20612: *
20613: * SORTA (CONTINUED)
20614: *
20615: * OFFSETS HAVE BEEN PERMUTED INTO REQUIRED ORDER BY SORT.
20616: * COPY ARRAY ELEMENTS OVER THEM.
20617: *
20618: SRT12 MOV (XS),XL BASE ADRS OF KEY ARRAY
20619: MOV XL,WC COPY IT
20620: ADD SRTSO,WC OFFSET OF A(0)
20621: ADD SRTSF,XL ADRS OF FIRST ROW OF SORT ARRAY
20622: MOV SRTST,WB GET STRIDE
20623: BTW WB CONVERT TO WORDS
20624: *
20625: * COPYING LOOP FOR SUCCESSIVE ITEMS. SORTED OFFSETS ARE
20626: * HELD AT END OF SORT ARRAY.
20627: *
20628: SRT13 ICA WC ADRS OF NEXT OF SORTED OFFSETS
20629: MOV WC,XR COPY IT FOR ACCESS
20630: MOV (XR),XR GET OFFSET
20631: ADD 1(XS),XR ADD KEY ARRAY BASE ADRS
20632: LCT WA,WB GET COUNT OF WORDS IN ROW
20633: *
20634: * COPY A COMPLETE ROW
20635: *
20636: SRT14 MOV (XR)+,(XL)+ MOVE A WORD
20637: BCT WA,SRT14 LOOP
20638: DCV SRTNR DECREMENT ROW COUNT
20639: BNZ SRTNR,SRT13 REPEAT TILL ALL ROWS DONE
20640: *
20641: * RETURN POINT
20642: *
20643: SRT15 MOV (XS)+,XR POP RESULT ARRAY PTR
20644: ICA XS POP KEY ARRAY PTR
20645: ZER R$SXL CLEAR JUNK
20646: ZER R$SXR CLEAR JUNK
20647: EXI RETURN
20648: *
20649: * ERROR POINT
20650: *
20651: SRT16 ERB 238,SORT/RSORT 1ST ARG NOT SUITABLE ARRAY OR TABLE
20652: SRT17 ERB 239,SORT/RSORT 2ND ARG OUT OF RANGE OR NON-INTEGER
20653: *
20654: * SOFT FAIL RETURN
20655: *
20656: SRT18 EXI 1 RETURN
20657: ENP END PROCUDURE SORTA
20658: EJC
20659: *
20660: * SORTC -- COMPARE SORT KEYS
20661: *
20662: * COMPARE TWO SORT KEYS GIVEN THEIR OFFSETS. IF
20663: * EQUAL, COMPARE KEY OFFSETS TO GIVE STABLE SORT.
20664: * NOTE THAT IF SRTSR IS NON-ZERO (REQUEST FOR REVERSE
20665: * SORT), THE QUOTED RETURNS ARE INVERTED.
20666: * FOR OBJECTS OF DIFFERING DATATYPES, THE ENTRY POINT
20667: * IDENTIFICATIONS ARE COMPARED.
20668: *
20669: * (XL) BASE ADRS FOR KEYS
20670: * (WA) OFFSET TO KEY 1 ITEM
20671: * (WB) OFFSET TO KEY 2 ITEM
20672: * (SRTSR) ZERO/NON-ZERO FOR SORT/RSORT
20673: * (SRTOF) OFFSET WITHIN ROW TO COMPARANDS
20674: * JSR SORTC CALL TO COMPARE KEYS
20675: * PPM LOC KEY1 LESS THAN KEY2
20676: * NORMAL RETURN, KEY1 GT THAN KEY2
20677: * (XL,XR,WA,WB) DESTROYED
20678: *
20679: SORTC PRC E,1 ENTRY POINT
20680: MOV WA,SRTS1 SAVE OFFSET 1
20681: MOV WB,SRTS2 SAVE OFFSET 2
20682: MOV WC,SRTSC SAVE WC
20683: ADD SRTOF,XL ADD OFFSET TO COMPARAND FIELD
20684: MOV XL,XR COPY BASE + OFFSET
20685: ADD WA,XL ADD KEY1 OFFSET
20686: ADD WB,XR ADD KEY2 OFFSET
20687: MOV (XL),XL GET KEY1
20688: MOV (XR),XR GET KEY2
20689: BNE SRTDF,=NULLS,SRC11 JUMP IF DATATYPE FIELD NAME USED
20690: EJC
20691: *
20692: * SORTC (CONTINUED)
20693: *
20694: * MERGE AFTER DEALING WITH FIELD NAME. TRY FOR STRINGS.
20695: *
20696: SRC01 MOV (XL),WC GET TYPE CODE
20697: BNE WC,(XR),SRC02 SKIP IF NOT SAME DATATYPE
20698: BEQ WC,=B$SCL,SRC09 JUMP IF BOTH STRINGS
20699: *
20700: * NOW TRY FOR NUMERIC
20701: *
20702: SRC02 MOV XL,R$SXL KEEP ARG1
20703: MOV XR,R$SXR KEEP ARG2
20704: MOV XL,-(XS) STACK
20705: MOV XR,-(XS) ARGS
20706: JSR ACOMP COMPARE OBJECTS
20707: PPM SRC10 NOT NUMERIC
20708: PPM SRC10 NOT NUMERIC
20709: PPM SRC03 KEY1 LESS
20710: PPM SRC08 KEYS EQUAL
20711: PPM SRC05 KEY1 GREATER
20712: *
20713: * RETURN IF KEY1 SMALLER (SORT), GREATER (RSORT)
20714: *
20715: SRC03 BNZ SRTSR,SRC06 JUMP IF RSORT
20716: *
20717: SRC04 MOV SRTSC,WC RESTORE WC
20718: EXI 1 RETURN
20719: *
20720: * RETURN IF KEY1 GREATER (SORT), SMALLER (RSORT)
20721: *
20722: SRC05 BNZ SRTSR,SRC04 JUMP IF RSORT
20723: *
20724: SRC06 MOV SRTSC,WC RESTORE WC
20725: EXI RETURN
20726: *
20727: * KEYS ARE OF SAME DATATYPE
20728: *
20729: SRC07 BLT XL,XR,SRC03 ITEM FIRST CREATED IS LESS
20730: BGT XL,XR,SRC05 ADDRESSES RISE IN ORDER OF CREATION
20731: *
20732: * DROP THROUGH OR MERGE FOR IDENTICAL OR EQUAL OBJECTS
20733: *
20734: SRC08 BLT SRTS1,SRTS2,SRC04 TEST OFFSETS OR KEY ADDRSS INSTEAD
20735: BRN SRC06 OFFSET 1 GREATER
20736: EJC
20737: *
20738: * SORTC (CONTINUED)
20739: *
20740: * STRINGS
20741: *
20742: SRC09 MOV XL,-(XS) STACK
20743: MOV XR,-(XS) ARGS
20744: JSR LCOMP COMPARE OBJECTS
20745: PPM CANT
20746: PPM FAIL
20747: PPM SRC03 KEY1 LESS
20748: PPM SRC08 KEYS EQUAL
20749: PPM SRC05 KEY1 GREATER
20750: *
20751: * ARITHMETIC COMPARISON FAILED - RECOVER ARGS
20752: *
20753: SRC10 MOV R$SXL,XL GET ARG1
20754: MOV R$SXR,XR GET ARG2
20755: MOV (XL),WC GET TYPE OF KEY1
20756: BEQ WC,(XR),SRC07 JUMP IF KEYS OF SAME TYPE
20757: MOV WC,XL GET BLOCK TYPE WORD
20758: MOV (XR),XR GET BLOCK TYPE WORD
20759: LEI XL ENTRY POINT ID FOR KEY1
20760: LEI XR ENTRY POINT ID FOR KEY2
20761: BGT XL,XR,SRC05 JUMP IF KEY1 GT KEY2
20762: BRN SRC03 KEY1 LT KEY2
20763: *
20764: * DATATYPE FIELD NAME USED
20765: *
20766: SRC11 JSR SORTF CALL ROUTINE TO FIND FIELD 1
20767: MOV XL,-(XS) STACK ITEM POINTER
20768: MOV XR,XL GET KEY2
20769: JSR SORTF FIND FIELD 2
20770: MOV XL,XR PLACE AS KEY2
20771: MOV (XS)+,XL RECOVER KEY1
20772: BRN SRC01 MERGE
20773: ENP PROCEDURE SORTC
20774: EJC
20775: *
20776: * SORTF -- FIND FIELD FOR SORTC
20777: *
20778: * ROUTINE USED BY SORTC TO OBTAIN ITEM CORRESPONDING
20779: * TO A GIVEN FIELD NAME, IF THIS EXISTS, IN A PROGRAMMER
20780: * DEFINED OBJECT PASSED AS ARGUMENT.
20781: * IF SUCH A MATCH OCCURS, RECORD IS KEPT OF DATATYPE
20782: * NAME, FIELD NAME AND OFFSET TO FIELD IN ORDER TO
20783: * SHORT-CIRCUIT LATER SEARCHES ON SAME TYPE. NOTE THAT
20784: * DFBLKS ARE STORED IN STATIC AND HENCE CANNOT BE MOVED.
20785: *
20786: * (SRTDF) VRBLK POINTER OF FIELD NAME
20787: * (XL) POSSIBLE PDBLK POINTER
20788: * JSR SORTF CALL TO SEARCH FOR FIELD NAME
20789: * (XL) ITEM FOUND OR ORIGINAL PDBLK PTR
20790: * (WC) DESTROYED
20791: *
20792: SORTF PRC E,0 ENTRY POINT
20793: BNE (XL),=B$PDT,SRTF3 RETURN IF NOT PDBLK
20794: MOV XR,-(XS) KEEP XR
20795: MOV SRTFD,XR GET POSSIBLE FORMER DFBLK PTR
20796: BZE XR,SRTF4 JUMP IF NOT
20797: BNE XR,PDDFP(XL),SRTF4 JUMP IF NOT RIGHT DATATYPE
20798: BNE SRTDF,SRTFF,SRTF4 JUMP IF NOT RIGHT FIELD NAME
20799: ADD SRTFO,XL ADD OFFSET TO REQUIRED FIELD
20800: *
20801: * HERE WITH XL POINTING TO FOUND FIELD
20802: *
20803: SRTF1 MOV (XL),XL GET ITEM FROM FIELD
20804: *
20805: * RETURN POINT
20806: *
20807: SRTF2 MOV (XS)+,XR RESTORE XR
20808: *
20809: SRTF3 EXI RETURN
20810: EJC
20811: *
20812: * SORTF (CONTINUED)
20813: *
20814: * CONDUCT A SEARCH
20815: *
20816: SRTF4 MOV XL,XR COPY ORIGINAL POINTER
20817: MOV PDDFP(XR),XR POINT TO DFBLK
20818: MOV XR,SRTFD KEEP A COPY
20819: MOV FARGS(XR),WC GET NUMBER OF FIELDS
20820: WTB WC CONVERT TO BAUS
20821: ADD DFLEN(XR),XR POINT PAST LAST FIELD
20822: *
20823: * LOOP TO FIND NAME IN PDFBLK
20824: *
20825: SRTF5 DCA WC COUNT DOWN
20826: DCA XR POINT IN FRONT
20827: BEQ (XR),SRTDF,SRTF6 SKIP OUT IF FOUND
20828: BNZ WC,SRTF5 LOOP
20829: BRN SRTF2 RETURN - NOT FOUND
20830: *
20831: * FOUND
20832: *
20833: SRTF6 MOV (XR),SRTFF KEEP FIELD NAME PTR
20834: ADD *PDFLD,WC ADD OFFSET TO FIRST FIELD
20835: MOV WC,SRTFO STORE AS FIELD OFFSET
20836: ADD WC,XL POINT TO FIELD
20837: BRN SRTF1 RETURN
20838: ENP PROCEDURE SORTF
20839: EJC
20840: *
20841: * SORTH -- HEAP ROUTINE FOR SORTA
20842: *
20843: * THIS ROUTINE CONSTRUCTS A HEAP FROM ELEMENTS OF ARRAY, A.
20844: * IN THIS APPLICATION, THE ELEMENTS ARE OFFSETS TO KEYS IN
20845: * A KEY ARRAY.
20846: *
20847: * (XS) POINTER TO SORT ARRAY BASE
20848: * 1(XS) POINTER TO KEY ARRAY BASE
20849: * (WA) MAX ARRAY INDEX, N (IN BAUS)
20850: * (WC) OFFSET J IN A TO ROOT (IN *1 TO *N)
20851: * JSR SORTH CALL SORTH(J,N) TO MAKE HEAP
20852: * (XL,XR,WB) DESTROYED
20853: *
20854: SORTH PRC N,0 ENTRY POINT
20855: MOV WA,SRTSN SAVE N
20856: MOV WC,SRTWC KEEP WC
20857: MOV (XS),XL SORT ARRAY BASE ADRS
20858: ADD SRTSO,XL ADD OFFSET TO A(0)
20859: ADD WC,XL POINT TO A(J)
20860: MOV (XL),SRTRT GET OFFSET TO ROOT
20861: ADD WC,WC DOUBLE J - CANT EXCEED N
20862: *
20863: * LOOP TO MOVE DOWN TREE USING DOUBLED INDEX J
20864: *
20865: SRH01 BGT WC,SRTSN,SRH03 DONE IF J GT N
20866: BEQ WC,SRTSN,SRH02 SKIP IF J EQUALS N
20867: MOV (XS),XR SORT ARRAY BASE ADRS
20868: MOV 1(XS),XL KEY ARRAY BASE ADRS
20869: ADD SRTSO,XR POINT TO A(0)
20870: ADD WC,XR ADRS OF A(J)
20871: MOV 1(XR),WA GET A(J+1)
20872: MOV (XR),WB GET A(J)
20873: *
20874: * COMPARE SONS. (WA) RIGHT SON, (WB) LEFT SON
20875: *
20876: JSR SORTC COMPARE KEYS - LT(A(J+1),A(J))
20877: PPM SRH02 A(J+1) LT A(J)
20878: ICA WC POINT TO GREATER SON, A(J+1)
20879: EJC
20880: *
20881: * SORTH (CONTINUED)
20882: *
20883: * COMPARE ROOT WITH GREATER SON
20884: *
20885: SRH02 MOV 1(XS),XL KEY ARRAY BASE ADRS
20886: MOV (XS),XR GET SORT ARRAY ADDRESS
20887: ADD SRTSO,XR ADRS OF A(0)
20888: MOV XR,WB COPY THIS ADRS
20889: ADD WC,XR ADRS OF GREATER SON, A(J)
20890: MOV (XR),WA GET A(J)
20891: MOV WB,XR POINT BACK TO A(0)
20892: MOV SRTRT,WB GET ROOT
20893: JSR SORTC COMPARE THEM - LT(A(J),ROOT)
20894: PPM SRH03 FATHER EXCEEDS SONS - DONE
20895: MOV (XS),XR GET SORT ARRAY ADRS
20896: ADD SRTSO,XR POINT TO A(0)
20897: MOV XR,XL COPY IT
20898: MOV WC,WA COPY J
20899: BTW WC CONVERT TO WORDS
20900: RSH WC,1 GET J/2
20901: WTB WC CONVERT BACK TO BAUS
20902: ADD WA,XL POINT TO A(J)
20903: ADD WC,XR ADRS OF A(J/2)
20904: MOV (XL),(XR) A(J/2) = A(J)
20905: MOV WA,WC RECOVER J
20906: AOV WC,WC,SRH03 J = J*2. DONE IF TOO BIG
20907: BRN SRH01 LOOP
20908: *
20909: * FINISH BY COPYING ROOT OFFSET BACK INTO ARRAY
20910: *
20911: SRH03 BTW WC CONVERT TO WORDS
20912: RSH WC,1 J = J/2
20913: WTB WC CONVERT BACK TO BAUS
20914: MOV (XS),XR SORT ARRAY ADRS
20915: ADD SRTSO,XR ADRS OF A(0)
20916: ADD WC,XR ADRS OF A(J/2)
20917: MOV SRTRT,(XR) A(J/2) = ROOT
20918: MOV SRTSN,WA RESTORE WA
20919: MOV SRTWC,WC RESTORE WC
20920: EXI RETURN
20921: ENP END PROCEDURE SORTH
20922: EJC
20923: .FI
20924: EJC
20925: *
20926: * TFIND -- LOCATE TABLE ELEMENT
20927: *
20928: * (XR) SUBSCRIPT VALUE FOR ELEMENT
20929: * (XL) POINTER TO TABLE
20930: * (WB) ZERO BY VALUE, NON-ZERO BY NAME
20931: * JSR TFIND CALL TO LOCATE ELEMENT
20932: * PPM LOC TRANSFER LOCATION IF ACCESS FAILS
20933: * (XR) ELEMENT VALUE (IF BY VALUE)
20934: * (XR) DESTROYED (IF BY NAME)
20935: * (XL,WA) TEBLK NAME (IF BY NAME)
20936: * (XL,WA) DESTROYED (IF BY VALUE)
20937: * (WC,RA) DESTROYED
20938: *
20939: * NOTE THAT IF A CALL BY VALUE SPECIFIES A NON-EXISTENT
20940: * SUBSCRIPT, NULL IS RETURNED WITHOUT BUILDING A NEW TEBLK.
20941: *
20942: TFIND PRC E,1 ENTRY POINT
20943: MOV WB,-(XS) SAVE NAME/VALUE INDICATOR
20944: MOV XR,-(XS) SAVE SUBSCRIPT VALUE
20945: MOV XL,-(XS) SAVE TABLE POINTER
20946: MOV TBLEN(XL),WA LOAD LENGTH OF TBBLK
20947: BTW WA CONVERT TO WORD COUNT
20948: SUB =TBBUK,WA GET NUMBER OF BUCKETS
20949: MTI WA CONVERT TO INTEGER VALUE
20950: STI TFNSI SAVE FOR LATER
20951: MOV (XR),XL LOAD FIRST WORD OF SUBSCRIPT
20952: LEI XL LOAD BLOCK ENTRY ID (BL$XX)
20953: BSW XL,BL$$D,TFN00 SWITCH ON BLOCK TYPE
20954: IFF BL$IC,TFN02 JUMP IF INTEGER
20955: .IF .CNRA
20956: .ELSE
20957: IFF BL$RC,TFN02 REAL
20958: .FI
20959: IFF BL$P0,TFN03 JUMP IF PATTERN
20960: IFF BL$P1,TFN03 JUMP IF PATTERN
20961: IFF BL$P2,TFN03 JUMP IF PATTERN
20962: IFF BL$NM,TFN04 JUMP IF NAME
20963: IFF BL$SC,TFN05 JUMP IF STRING
20964: ESW END SWITCH ON BLOCK TYPE
20965: *
20966: * HERE FOR BLOCKS FOR WHICH WE USE THE SECOND WORD OF THE
20967: * BLOCK AS THE HASH SOURCE (SEE BLOCK FORMATS FOR DETAILS).
20968: *
20969: TFN00 MOV 1(XR),WA LOAD SECOND WORD
20970: *
20971: * MERGE HERE WITH ONE WORD HASH SOURCE IN WA
20972: *
20973: TFN01 MTI WA CONVERT TO INTEGER
20974: BRN TFN06 JUMP TO MERGE
20975: EJC
20976: *
20977: * TFIND (CONTINUED)
20978: *
20979: * HERE FOR INTEGER OR REAL
20980: * POSSIBILITY OF OVERFLOW EXIST ON TWOS COMPLEMENT
20981: * MACHINE IF HASH SOURCE IS MOST NEGATIVE INTEGER OR IS
20982: * A REAL HAVING THE SAME BIT PATTERN.
20983: *
20984: TFN02 LDI 1(XR) LOAD VALUE AS HASH SOURCE
20985: IGE TFN06 OK IF POSITIVE OR ZERO
20986: NGI MAKE POSITIVE
20987: IOV TFN06 CLEAR POSSIBLE OVERFLOW
20988: BRN TFN06 MERGE
20989: *
20990: * FOR PATTERN, USE FIRST WORD (PCODE) AS SOURCE
20991: *
20992: TFN03 MOV (XR),WA LOAD FIRST WORD AS HASH SOURCE
20993: BRN TFN01 MERGE BACK
20994: *
20995: * FOR NAME, USE OFFSET AS HASH SOURCE
20996: *
20997: TFN04 MOV NMOFS(XR),WA LOAD OFFSET AS HASH SOURCE
20998: BRN TFN01 MERGE BACK
20999: *
21000: * HERE FOR STRING
21001: *
21002: TFN05 JSR HASHS CALL ROUTINE TO COMPUTE HASH
21003: *
21004: * MERGE HERE WITH HASH SOURCE IN (IA)
21005: *
21006: TFN06 RMI TFNSI COMPUTE HASH INDEX BY REMAINDERING
21007: MFI WC GET AS ONE WORD INTEGER
21008: WTB WC CONVERT TO BAU OFFSET
21009: MOV (XS),XL GET TABLE PTR AGAIN
21010: ADD WC,XL POINT TO PROPER BUCKET
21011: MOV TBBUK(XL),XR LOAD FIRST TEBLK POINTER
21012: BEQ XR,(XS),TFN10 JUMP IF NO TEBLKS ON CHAIN
21013: *
21014: * LOOP THROUGH TEBLKS ON HASH CHAIN
21015: *
21016: TFN07 MOV XR,WB SAVE TEBLK POINTER
21017: MOV TESUB(XR),XR LOAD SUBSCRIPT VALUE
21018: MOV 1(XS),XL LOAD INPUT ARGUMENT SUBSCRIPT VAL
21019: JSR IDENT COMPARE THEM
21020: PPM TFN08 JUMP IF EQUAL (IDENT)
21021: *
21022: * HERE IF NO MATCH WITH THAT TEBLK
21023: *
21024: MOV WB,XL RESTORE TEBLK POINTER
21025: MOV TENXT(XL),XR POINT TO NEXT TEBLK ON CHAIN
21026: BNE XR,(XS),TFN07 JUMP IF THERE IS ONE
21027: *
21028: * HERE IF NO MATCH WITH ANY TEBLK ON CHAIN
21029: *
21030: MOV *TENXT,WC SET OFFSET TO LINK FIELD (XL BASE)
21031: BRN TFN11 JUMP TO MERGE
21032: EJC
21033: *
21034: * TFIND (CONTINUED)
21035: *
21036: * HERE WE HAVE FOUND A MATCHING ELEMENT
21037: *
21038: TFN08 MOV WB,XL RESTORE TEBLK POINTER
21039: MOV *TEVAL,WA SET TEBLK NAME OFFSET
21040: MOV 2(XS),WB RESTORE NAME/VALUE INDICATOR
21041: BNZ WB,TFN09 JUMP IF CALLED BY NAME
21042: JSR ACESS ELSE GET VALUE
21043: PPM TFN12 JUMP IF REFERENCE FAILS
21044: ZER WB RESTORE NAME/VALUE INDICATOR
21045: *
21046: * COMMON EXIT FOR ENTRY FOUND
21047: *
21048: TFN09 ADD *NUM03,XS POP STACK ENTRIES
21049: EXI RETURN TO TFIND CALLER
21050: *
21051: * HERE IF NO TEBLKS ON THE HASH CHAIN
21052: *
21053: TFN10 ADD *TBBUK,WC GET OFFSET TO BUCKET PTR
21054: MOV (XS),XL SET TBBLK PTR AS BASE
21055: *
21056: * MERGE HERE WITH (XL,WC) BASE,OFFSET OF FINAL LINK
21057: *
21058: TFN11 MOV (XS),XR TBBLK POINTER
21059: MOV TBINV(XR),XR LOAD DEFAULT VALUE IN CASE
21060: MOV 2(XS),WB LOAD NAME/VALUE INDICATOR
21061: BZE WB,TFN09 EXIT WITH DEFAULT IF VALUE CALL
21062: MOV XR,WB COPY DEFAULT VALUE
21063: *
21064: * HERE WE MUST BUILD A NEW TEBLK
21065: *
21066: MOV *TESI$,WA SET SIZE OF TEBLK
21067: JSR ALLOC ALLOCATE TEBLK
21068: ADD WC,XL POINT TO HASH LINK
21069: MOV XR,(XL) LINK NEW TEBLK AT END OF CHAIN
21070: MOV =B$TET,(XR) STORE TYPE WORD
21071: MOV WB,TEVAL(XR) SET DEFAULT AS INITIAL VALUE
21072: MOV (XS)+,TENXT(XR) SET TBBLK PTR TO MARK END OF CHAIN
21073: MOV (XS)+,TESUB(XR) STORE SUBSCRIPT VALUE
21074: MOV (XS)+,WB RESTORE NAME/VALUE INDICATOR
21075: MOV XR,XL COPY TEBLK POINTER (NAME BASE)
21076: MOV *TEVAL,WA SET OFFSET
21077: EXI RETURN TO CALLER WITH NEW TEBLK
21078: *
21079: * ACESS FAIL RETURN
21080: *
21081: TFN12 EXI 1 ALTERNATIVE RETURN
21082: ENP END PROCEDURE TFIND
21083: EJC
21084: *
21085: * TRACE -- SET/RESET A TRACE ASSOCIATION
21086: *
21087: * THIS PROCEDURE IS SHARED BY TRACE AND STOPTR TO
21088: * EITHER INITIATE OR STOP A TRACE RESPECTIVELY.
21089: *
21090: * (XL) TRBLK PTR (TRACE) OR ZERO (STOPTR)
21091: * 1(XS) FIRST ARGUMENT (NAME)
21092: * 0(XS) SECOND ARGUMENT (TRACE TYPE)
21093: * JSR TRACE CALL TO SET/RESET TRACE
21094: * PPM LOC TRANSFER LOC IF 1ST ARG IS BAD NAME
21095: * PPM LOC TRANSFER LOC IF 2ND ARG IS BAD TYPE
21096: * PPM LOC FAIL STOPTR IF NON-EXISTENT TRACE
21097: * (XS) POPPED
21098: * (XL,XR,WA,WB,WC,IA) DESTROYED
21099: *
21100: TRACE PRC N,3 ENTRY POINT
21101: JSR GTSTG GET TRACE TYPE STRING
21102: PPM TRC15 JUMP IF NOT STRING
21103: PLC XR ELSE POINT TO STRING
21104: LCH WA,(XR) LOAD FIRST CHARACTER
21105: .IF .CASL
21106: BLT WA,=CH$$A,TRC00 SKIP IF NOT LOWER CASE
21107: SUB =DFA$A,WA CONVERT LOWER TO UPPER CASE
21108: *
21109: * HERE WITH UPPER CASE TRACE TYPE CODE
21110: *
21111: TRC00 MOV (XS),XR LOAD NAME ARGUMENT
21112: .ELSE
21113: MOV (XS),XR LOAD NAME ARGUMENT
21114: .FI
21115: MOV XL,(XS) STACK TRBLK PTR OR ZERO
21116: MOV =TRTAC,WC SET TRTYP FOR ACCESS TRACE
21117: BEQ WA,=CH$LA,TRC10 JUMP IF A (ACCESS)
21118: MOV =TRTVL,WC SET TRTYP FOR VALUE TRACE
21119: BEQ WA,=CH$LV,TRC10 JUMP IF V (VALUE)
21120: BEQ WA,=CH$BL,TRC10 JUMP IF BLANK (VALUE)
21121: *
21122: * HERE FOR L,K,F,C,R
21123: *
21124: BEQ WA,=CH$LF,TRC01 JUMP IF F (FUNCTION)
21125: BEQ WA,=CH$LR,TRC01 JUMP IF R (RETURN)
21126: BEQ WA,=CH$LL,TRC03 JUMP IF L (LABEL)
21127: BEQ WA,=CH$LK,TRC06 JUMP IF K (KEYWORD)
21128: BNE WA,=CH$LC,TRC15 ELSE ERROR IF NOT C (CALL)
21129: *
21130: * HERE FOR F,C,R
21131: *
21132: TRC01 JSR GTNVR POINT TO VRBLK FOR NAME
21133: PPM TRC16 JUMP IF BAD NAME
21134: ICA XS POP STACK
21135: MOV VRFNC(XR),XR POINT TO FUNCTION BLOCK
21136: BNE (XR),=B$PFC,TRC17 ERROR IF NOT PROGRAM FUNCTION
21137: MOV XL,WB COPY TRBLK PTR OR 0
21138: BEQ WA,=CH$LR,TRC02 JUMP IF R (RETURN)
21139: EJC
21140: *
21141: * TRACE (CONTINUED)
21142: *
21143: * HERE FOR F,C TO SET/RESET CALL TRACE
21144: *
21145: ORB PFCTR(XR),WB STOPTR FAIL CHECK
21146: MOV XL,PFCTR(XR) SET/RESET CALL TRACE
21147: BEQ WA,=CH$LC,TRC11 RETURN IF LETTER C
21148: *
21149: * HERE FOR F,R TO SET/RESET RETURN TRACE
21150: *
21151: TRC02 ORB PFRTR(XR),WB STOPTR FAIL CHECK
21152: MOV XL,PFRTR(XR) SET/RESET RETURN TRACE
21153: BRN TRC11 RETURN
21154: *
21155: * HERE FOR L TO SET/RESET LABEL TRACE
21156: *
21157: TRC03 JSR GTNVR POINT TO VRBLK
21158: PPM TRC16 JUMP IF BAD NAME
21159: MOV (XS)+,WB GET TRBLK OR ZERO
21160: MOV VRLBL(XR),XL LOAD LABEL POINTER
21161: BNE (XL),=B$TRT,TRC04 JUMP IF NO OLD TRACE
21162: MOV TRLBL(XL),XL ELSE DELETE OLD TRACE ASSOCIATION
21163: BRN TRCA4 MERGE
21164: *
21165: * HERE WITH OLD LABEL TRACE ASSOCIATION DELETED
21166: *
21167: TRC04 BZE WB,TRC12 FAIL IF STOPTR OF UNTRACED LABEL
21168: *
21169: * TEST FOR UNDEFINED LABEL
21170: *
21171: TRCA4 BEQ XL,=STNDL,TRC17 ERROR IF UNDEFINED LABEL
21172: BZE WB,TRC05 JUMP IF STOPTR CASE
21173: MOV WB,VRLBL(XR) ELSE SET NEW TRBLK POINTER
21174: MOV =B$VRT,VRTRA(XR) SET LABEL TRACE ROUTINE ADDRESS
21175: MOV WB,XR COPY TRBLK POINTER
21176: MOV XL,TRLBL(XR) STORE REAL LABEL IN TRBLK
21177: EXI RETURN
21178: *
21179: * HERE FOR STOPTR CASE FOR LABEL
21180: *
21181: TRC05 MOV XL,VRLBL(XR) STORE LABEL PTR BACK IN VRBLK
21182: MOV =B$VRG,VRTRA(XR) STORE NORMAL TRANSFER ADDRESS
21183: EXI RETURN
21184: EJC
21185: *
21186: * TRACE (CONTINUED)
21187: *
21188: * HERE FOR K (KEYWORD)
21189: *
21190: TRC06 JSR GTNVR POINT TO VRBLK
21191: PPM TRC16 ERROR IF NOT NATURAL VAR
21192: BNZ VRLEN(XR),TRC16 ERROR IF NOT SYSTEM VAR
21193: ICA XS POP STACK
21194: BZE XL,TRC07 JUMP IF STOPTR CASE
21195: MOV XR,TRKVR(XL) STORE VRBLK PTR IN TRBLK FOR KTREX
21196: *
21197: * MERGE HERE WITH TRBLK SET UP IN XL (OR ZERO)
21198: *
21199: TRC07 MOV VRSVP(XR),XR POINT TO SVBLK
21200: MOV XL,WB COPY TRBLK PR OR 0
21201: BEQ XR,=V$ERT,TRC08 JUMP IF ERRTYPE
21202: BEQ XR,=V$STC,TRC09 JUMP IF STCOUNT
21203: BNE XR,=V$FNC,TRC17 ELSE ERROR IF NOT FNCLEVEL
21204: *
21205: * FNCLEVEL
21206: *
21207: ORB R$FNC,WB STOPTR FAIL CHECK
21208: MOV XL,R$FNC SET/RESET FNCLEVEL TRACE
21209: BRN TRC11 RETURN
21210: *
21211: * ERRTYPE
21212: *
21213: TRC08 ORB R$ERT,WB STOPTR FAIL CHECK
21214: MOV XL,R$ERT SET/RESET ERRTYPE TRACE
21215: BRN TRC11 RETURN
21216: *
21217: * STCOUNT
21218: *
21219: TRC09 ORB R$STC,WB STOPTR FAIL CHECK
21220: MOV XL,R$STC SET/RESET STCOUNT TRACE
21221: BRN TRC11 RETURN
21222: EJC
21223: *
21224: * TRACE (CONTINUED)
21225: *
21226: * A,V MERGE HERE WITH TRTYP VALUE IN WC
21227: *
21228: TRC10 JSR GTVAR LOCATE VARIABLE
21229: PPM TRC16 ERROR IF NOT APPROPRIATE NAME
21230: MOV (XS)+,XR GET NEW TRBLK PTR AGAIN
21231: MOV WC,WB COPY TRACE TYPE
21232: JSR TRCHN UPDATE TRACE CHAIN
21233: PPM TRC12 FAIL
21234: EXI RETURN
21235: *
21236: * RETURN AFTER CHECKING STOPTR FAIL CONDITION (WB = 0)
21237: *
21238: TRC11 ZRB WB,TRC12 FAIL IF NECESSARY
21239: EXI ELSE RETURN
21240: *
21241: * FAIL STOPTR
21242: *
21243: TRC12 EXI 3 FAIL RETURN
21244: *
21245: * HERE FOR BAD TRACE TYPE
21246: *
21247: TRC15 EXI 2 TAKE BAD TRACE TYPE ERROR EXIT
21248: *
21249: * POP STACK BEFORE FAILING
21250: *
21251: TRC16 ICA XS POP STACK
21252: *
21253: * HERE FOR BAD NAME ARGUMENT
21254: *
21255: TRC17 EXI 1 TAKE BAD NAME ERROR EXIT
21256: ENP END PROCEDURE TRACE
21257: EJC
21258: *
21259: * TRBLD -- BUILD TRBLK
21260: *
21261: * TRBLK IS USED BY THE INPUT, OUTPUT AND TRACE FUNCTIONS
21262: * TO CONSTRUCT A TRBLK (TRAP BLOCK)
21263: *
21264: * (XR) TRTAG OR TRTER
21265: * (XL) TRFNC OR TRTRI
21266: * (WB) TRTYP
21267: * JSR TRBLD CALL TO BUILD TRBLK
21268: * (XR) POINTER TO TRBLK
21269: * (WA) DESTROYED
21270: *
21271: TRBLD PRC E,0 ENTRY POINT
21272: MOV XR,-(XS) STACK TRTAG (OR TRFNM)
21273: MOV *TRSI$,WA SET SIZE OF TRBLK
21274: JSR ALLOC ALLOCATE TRBLK
21275: MOV =B$TRT,(XR) STORE FIRST WORD
21276: MOV XL,TRFNC(XR) STORE TRFNC (OR TRTRI)
21277: MOV (XS)+,TRTAG(XR) STORE TRTAG (OR TRTER)
21278: MOV WB,TRTYP(XR) STORE TYPE
21279: MOV =NULLS,TRVAL(XR) FOR NOW, A NULL VALUE
21280: EXI RETURN TO CALLER
21281: ENP END PROCEDURE TRBLD
21282: EJC
21283: *
21284: * TRCHN -- UPDATE TRACE BLOCK CHAIN
21285: *
21286: * CALLED WHEN A TRACE BLOCK CHAIN IS TO BE UPDATED BY
21287: * ADDITION OR REMOVAL OF A TRBLK.
21288: * IF A TRBLK OF THE SAME TYPE AS AN ADDITION IS ALREADY
21289: * PRESENT IT IS DELETED. THE TRTAG FIELD OF ANY DELETED
21290: * TRBLK IS CLEARED AS REQUIRED BY S$ENF.
21291: *
21292: * (XL,WA) POINTER, OFFSET TO TRACED VARIABLE
21293: * (XR) PTR TO NEW TRBLK OR 0 FOR REMOVAL
21294: * (WB) TRACE TYPE (TRTYP)
21295: * JSR TRCHN CALL TO UPDATE TRACE CHAIN
21296: * PPM LOC NO TRACE BLK OF REQD DELETION TYPE
21297: * (WA,WC) DESTROYED
21298: *
21299: TRCHN PRC E,1 ENTRY POINT
21300: ADD XL,WA KEEP POINTER TO TRACED LOCATION
21301: MOV WA,XL COPY POINTER
21302: SUB *TRNXT,XL ADJUST OFFSET BEFORE ENTERING LOOP
21303: MOV XR,WC COPY TRBLK PTR
21304: *
21305: * LOOP TO FIND TRACE BLOCK
21306: *
21307: TRCH1 MOV XL,XR COPY SO XR POINTS TO PREDECESSOR
21308: MOV TRNXT(XL),XL POINT TO POSSIBLE TRACE BLOCK
21309: BNE (XL),=B$TRT,TRCH2 SKIP OUT AT CHAIN END
21310: BLT WB,TRTYP(XL),TRCH2 SKIP IF TOO FAR OUT ON CHAIN
21311: BNE WB,TRTYP(XL),TRCH1 LOOP UNLESS TYPE MATCHES
21312: MOV TRNXT(XL),TRNXT(XR) REMOVE LINK TO OLD TRBLK
21313: ZER TRTAG(XL) CLEAR IOTAG FIELD OF DELETED BLOCK
21314: BZE WC,TRCH3 DONE IF NO NEW TRBLK
21315: *
21316: * OLD TRBLK REMOVED AND/OR END OF CHAIN REACHED
21317: *
21318: TRCH2 BZE WC,TRCH4 FAIL IF REQD BLOCK TYPE NOT FOUND
21319: MOV WC,XL POINT TO NEW TRBLK
21320: MOV TRNXT(XR),TRNXT(XL) ATTACH TAIL OF CHAIN TO IT
21321: MOV WC,TRNXT(XR) LINK NEW BLOCK IN
21322: MOV WB,TRTYP(XL) ENSURE TRTYP FIELD SET UP
21323: *
21324: * UPDATE ACCESS FIELDS OF NAME IF IT IS A VRBLK
21325: *
21326: TRCH3 MOV WA,XR POINT TO VBL
21327: SUB *VRVAL,XR ADJUST TO POSSIBLE VRBLK NAME BASE
21328: JSR SETVR UPDATE ACCESS FIELDS
21329: MOV WA,XL RECOVER XL
21330: MOV WC,XR RECOVER XR
21331: EXI RETURN TO CALLER
21332: *
21333: * FAIL RETURN
21334: *
21335: TRCH4 MOV WA,XL RECOVER XL
21336: MOV WC,XR RECOVER XR
21337: EXI 1 FAIL
21338: ENP END PROCEDURE TRCHN
21339: EJC
21340: *
21341: * TRIMR -- TRIM TRAILING BLANKS
21342: *
21343: * TRIMR IS PASSED A POINTER TO AN SCBLK WHICH MUST BE THE
21344: * LAST BLOCK IN DYNAMIC STORAGE. TRAILING BLANKS ARE
21345: * TRIMMED OFF AND THE DYNAMIC STORAGE POINTER RESET TO
21346: * THE END OF THE (POSSIBLY) SHORTENED BLOCK.
21347: *
21348: * (WB) NON-ZERO TO TRIM TRAILING BLANKS
21349: * (XR) POINTER TO STRING TO TRIM
21350: * JSR TRIMR CALL TO TRIM STRING
21351: * (XR) POINTER TO TRIMMED STRING
21352: * (XL,WA,WB,WC) DESTROYED
21353: *
21354: * THE CALL WITH WB ZERO STILL PERFORMS THE END ZERO PAD
21355: * AND DNAMP READJUSTMENT. IT IS USED FROM ACESS IF KVTRM=0.
21356: *
21357: TRIMR PRC E,0 ENTRY POINT
21358: MOV XR,XL COPY STRING POINTER
21359: MOV SCLEN(XR),WA LOAD STRING LENGTH
21360: BZE WA,TRIM2 JUMP IF NULL INPUT
21361: PLC XL,WA ELSE POINT PAST LAST CHARACTER
21362: BZE WB,TRIM3 JUMP IF NO TRIM
21363: MOV =CH$BL,WC LOAD BLANK CHARACTER
21364: *
21365: * LOOP THROUGH CHARACTERS FROM RIGHT TO LEFT
21366: *
21367: TRIM0 LCH WB,-(XL) LOAD NEXT CHARACTER
21368: .IF .CAHT
21369: BEQ WB,=CH$HT,TRIM1 JUMP IF HORIZONTAL TAB
21370: .FI
21371: BNE WB,WC,TRIM3 JUMP IF NON-BLANK FOUND
21372: TRIM1 DCV WA ELSE DECREMENT CHARACTER COUNT
21373: BNZ WA,TRIM0 LOOP BACK IF MORE TO CHECK
21374: *
21375: * HERE IF RESULT IS NULL (NULL OR ALL-BLANK INPUT)
21376: *
21377: TRIM2 MOV XR,DNAMP WIPE OUT INPUT STRING BLOCK
21378: MOV =NULLS,XR LOAD NULL RESULT
21379: BRN TRIM5 MERGE TO EXIT
21380: EJC
21381: *
21382: * TRIMR (CONTINUED)
21383: *
21384: * HERE WITH NON-BLANK FOUND (MERGE FOR NO TRIM)
21385: *
21386: TRIM3 MOV WA,SCLEN(XR) SET NEW LENGTH
21387: MOV XR,XL COPY STRING POINTER
21388: PSC XL,WA READY FOR STORING ZEROES
21389: CTB WA,SCHAR GET LENGTH OF BLOCK IN BAUS
21390: ADD XR,WA POINT PAST NEW BLOCK
21391: MOV WA,DNAMP SET NEW TOP OF STORAGE POINTER
21392: LCT WA,=CFP$C GET COUNT OF CHARS IN WORD
21393: ZER WC SET ZERO CHAR
21394: *
21395: * LOOP TO ZERO PAD LAST WORD OF CHARACTERS
21396: *
21397: TRIM4 SCH WC,(XL)+ STORE ZERO CHARACTER
21398: BCT WA,TRIM4 LOOP BACK TILL ALL STORED
21399: CSC XL COMPLETE STORE CHARACTERS
21400: *
21401: * COMMON EXIT POINT
21402: *
21403: TRIM5 ZER XL CLEAR GARBAGE XL POINTER
21404: EXI RETURN TO CALLER
21405: ENP END PROCEDURE TRIMR
21406: EJC
21407: *
21408: * TRXEQ -- EXECUTE FUNCTION TYPE TRACE
21409: *
21410: * TRXEQ IS USED TO EXECUTE A TRACE WHEN A FOURTH ARGUMENT
21411: * HAS BEEN SUPPLIED. TRACE HAS ALREADY BEEN DECREMENTED.
21412: *
21413: * (XR) POINTER TO TRBLK
21414: * (XL,WA) NAME BASE,OFFSET FOR VARIABLE
21415: * JSR TRXEQ CALL TO EXECUTE TRACE
21416: * (WB,WC,RA) DESTROYED
21417: *
21418: * THE FOLLOWING STACK ENTRIES ARE MADE BEFORE PASSING
21419: * CONTROL TO THE TRACE FUNCTION USING THE CFUNC ROUTINE.
21420: *
21421: * TRXEQ RETURN POINT WORD(S)
21422: * SAVED VALUE OF TRACE KEYWORD
21423: * TRBLK POINTER
21424: * NAME BASE
21425: * NAME OFFSET
21426: * SAVED VALUE OF R$COD
21427: * SAVED CODE PTR (-R$COD)
21428: * SAVED VALUE OF FLPTR
21429: * FLPTR --------------- ZERO (DUMMY FAIL OFFSET)
21430: * NMBLK FOR VARIABLE NAME
21431: * XS ------------------ TRACE TAG
21432: *
21433: * R$COD AND THE CODE PTR ARE SET TO DUMMY VALUES WHICH
21434: * CAUSE CONTROL TO RETURN TO THE TRXEQ PROCEDURE ON SUCCESS
21435: * OR FAILURE (TRXEQ IGNORES A FAILURE CONDITION).
21436: *
21437: TRXEQ PRC R,0 ENTRY POINT (RECURSIVE)
21438: MOV R$COD,WC LOAD CODE BLOCK POINTER
21439: SCP WB GET CURRENT CODE POINTER
21440: SUB WC,WB MAKE CODE POINTER INTO OFFSET
21441: MOV KVTRA,-(XS) STACK TRACE KEYWORD VALUE
21442: MOV XR,-(XS) STACK TRBLK POINTER
21443: MOV XL,-(XS) STACK NAME BASE
21444: MOV WA,-(XS) STACK NAME OFFSET
21445: MOV WC,-(XS) STACK CODE BLOCK POINTER
21446: MOV WB,-(XS) STACK CODE POINTER OFFSET
21447: MOV FLPTR,-(XS) STACK OLD FAILURE POINTER
21448: ZER -(XS) SET DUMMY FAIL OFFSET
21449: MOV XS,FLPTR SET NEW FAILURE POINTER
21450: ZER KVTRA RESET TRACE KEYWORD TO ZERO
21451: MOV =TRXDC,WC LOAD NEW (DUMMY) CODE BLK POINTER
21452: MOV WC,R$COD SET AS CODE BLOCK POINTER
21453: LCP WC AND NEW CODE POINTER
21454: EJC
21455: *
21456: * TRXEQ (CONTINUED)
21457: *
21458: * NOW PREPARE ARGUMENTS FOR FUNCTION
21459: *
21460: MOV WA,WB SAVE NAME OFFSET
21461: MOV *NMSI$,WA LOAD NMBLK SIZE
21462: JSR ALLOC ALLOCATE SPACE FOR NMBLK
21463: MOV =B$NML,(XR) SET TYPE WORD
21464: MOV XL,NMBAS(XR) STORE NAME BASE
21465: MOV WB,NMOFS(XR) STORE NAME OFFSET
21466: MOV 6(XS),XL RELOAD POINTER TO TRBLK
21467: MOV XR,-(XS) STACK NMBLK POINTER (1ST ARGUMENT)
21468: MOV TRTAG(XL),-(XS) STACK TRACE TAG (2ND ARGUMENT)
21469: MOV TRFNC(XL),XL LOAD TRACE FUNCTION POINTER
21470: MOV =NUM02,WA SET NUMBER OF ARGUMENTS TO TWO
21471: BRN CFUNC JUMP TO CALL FUNCTION
21472: *
21473: * SEE O$TXR FOR DETAILS OF RETURN TO THIS POINT
21474: *
21475: TRXQR MOV FLPTR,XS POINT BACK TO OUR STACK ENTRIES
21476: ICA XS POP OFF GARBAGE FAIL OFFSET
21477: MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER
21478: MOV (XS)+,WB RELOAD CODE OFFSET
21479: MOV (XS)+,WC LOAD OLD CODE BASE POINTER
21480: MOV WC,XR COPY CDBLK POINTER
21481: MOV CDSTM(XR),KVSTN RESTORE STMNT NO
21482: MOV (XS)+,WA RELOAD NAME OFFSET
21483: MOV (XS)+,XL RELOAD NAME BASE
21484: MOV (XS)+,XR RELOAD TRBLK POINTER
21485: MOV (XS)+,KVTRA RESTORE TRACE KEYWORD VALUE
21486: ADD WC,WB RECOMPUTE ABSOLUTE CODE POINTER
21487: LCP WB RESTORE CODE POINTER
21488: MOV WC,R$COD AND CODE BLOCK POINTER
21489: EXI RETURN TO TRXEQ CALLER
21490: ENP END PROCEDURE TRXEQ
21491: EJC
21492: *
21493: * XSCAN -- EXECUTION FUNCTION ARGUMENT SCAN
21494: *
21495: * XSCAN SCANS OUT ONE TOKEN IN A PROTOTYPE ARGUMENT IN
21496: * ARRAY,CLEAR,DATA,DEFINE,LOAD FUNCTION CALLS. XSCAN
21497: * CALLS MUST BE PRECEDED BY A CALL TO THE INITIALIZATION
21498: * PROCEDURE XSCNI. THE FOLLOWING VARIABLES ARE USED.
21499: *
21500: * R$XSC POINTER TO SCBLK FOR FUNCTION ARG
21501: * XSOFS OFFSET (NUM CHARS SCANNED SO FAR)
21502: *
21503: * (WC) DELIMITER ONE (CH$XX)
21504: * (XL) DELIMITER TWO (CH$XX)
21505: * JSR XSCAN CALL TO SCAN NEXT ITEM
21506: * (XR) POINTER TO SCBLK FOR TOKEN SCANNED
21507: * (WA) COMPLETION CODE (SEE BELOW)
21508: * (WC,XL) DESTROYED
21509: * (XSCNB) ERROR INDICATOR - SEE 4) BELOW
21510: *
21511: * LEADING BLANKS AND TRAILING BLANKS POSITIONED BEFORE A
21512: * DELIMITER OR AT THE END OF THE ARGUMENT STRING ARE
21513: * IGNORED. OTHER BLANKS ARE ILLEGAL.
21514: * THE SCAN STARTS FROM THE CURRENT POSITION AND CONTINUES
21515: * UNTIL ONE OF THE FOLLOWING CONDITIONS OCCURS.
21516: *
21517: * 1) DELIMITER ONE IS ENCOUNTERED (WA SET TO 1)
21518: *
21519: * 2) DELIMITER TWO ENCOUNTERED (WA SET TO 2)
21520: *
21521: * 3) END OF STRING ENCOUNTERED (WA AND XSCNB SET TO 0)
21522: *
21523: * 4) ILLEGAL BLANK (WA 0, XSCNB NON-ZERO)
21524: *
21525: * THE RESULT IS A STRING CONTAINING ALL CHARACTERS SCANNED
21526: * UP TO BUT NOT INCLUDING ANY DELIMITER CHARACTER.
21527: * THE POINTER IS LEFT POINTING PAST THE DELIMITER.
21528: *
21529: * IF ONLY ONE DELIMITER IS TO BE DETECTED, DELIMITER ONE
21530: * AND DELIMITER TWO SHOULD BE SET TO THE SAME VALUE.
21531: *
21532: * IN THE CASE WHERE THE END OF STRING IS ENCOUNTERED, THE
21533: * STRING INCLUDES ALL THE CHARACTERS TO THE END OF THE
21534: * STRING. NO FURTHER CALLS CAN BE MADE TO XSCAN UNTIL
21535: * XSCNI IS CALLED TO INITIALIZE A NEW ARGUMENT SCAN
21536: EJC
21537: *
21538: * XSCAN (CONTINUED)
21539: *
21540: XSCAN PRC E,0 ENTRY POINT
21541: MOV WB,XSCWB PRESERVE WB
21542: ZER XSCBL CLEAR COUNT OF TRAILING BLANKS
21543: ZER XSCNB CLEAR NON-BLANK SEEN FLAG
21544: MOV R$XSC,XR POINT TO ARGUMENT STRING
21545: MOV SCLEN(XR),WA LOAD STRING LENGTH
21546: MOV XSOFS,WB LOAD CURRENT OFFSET
21547: SUB WB,WA GET NUMBER OF REMAINING CHARACTERS
21548: BZE WA,XSCN2 JUMP IF NO CHARACTERS LEFT
21549: PLC XR,WB POINT TO CURRENT CHARACTER
21550: *
21551: * LOOP TO SEARCH FOR DELIMITER
21552: *
21553: XSCN0 LCH WB,(XR)+ LOAD NEXT CHARACTER
21554: BEQ WB,WC,XSCN3 JUMP IF DELIMITER ONE FOUND
21555: BEQ WB,XL,XSCN4 JUMP IF DELIMITER TWO FOUND
21556: BEQ WB,=CH$BL,XSCN7 SKIP IF IT IS A BLANK
21557: .IF .CAHT
21558: BEQ WB,=CH$HT,XSCN7 SKIP IF IT IS A TAB
21559: .FI
21560: BNZ XSCBL,XSCN2 FAIL CHAR AFTER TRAILING BLANK
21561: MNZ XSCNB NOTE A NON-BLANK SEEN
21562: *
21563: * COUNT CHARS DONE
21564: *
21565: XSCN1 DCV WA DECREMENT COUNT OF CHARS LEFT
21566: BNZ WA,XSCN0 LOOP BACK IF MORE CHARS TO GO
21567: ZER XSCNB CLEAR ERRONEOUS BLANKS FLAG
21568: *
21569: * HERE FOR RUNOUT
21570: *
21571: XSCN2 MOV R$XSC,XL POINT TO STRING BLOCK
21572: MOV SCLEN(XL),WA GET STRING LENGTH
21573: MOV XSOFS,WB LOAD OFFSET
21574: SUB WB,WA GET SUBSTRING LENGTH
21575: SUB XSCBL,WA ADJUST FOR TRAILING BLANKS
21576: ZER R$XSC CLEAR STRING PTR FOR COLLECTOR
21577: ZER XSCRT SET ZERO (RUNOUT) RETURN CODE
21578: BRN XSCN6 JUMP TO EXIT
21579: EJC
21580: *
21581: * XSCAN (CONTINUED)
21582: *
21583: * HERE IF DELIMITER ONE FOUND
21584: *
21585: XSCN3 MOV =NUM01,XSCRT SET RETURN CODE
21586: BRN XSCN5 JUMP TO MERGE
21587: *
21588: * HERE IF DELIMITER TWO FOUND
21589: *
21590: XSCN4 MOV =NUM02,XSCRT SET RETURN CODE
21591: *
21592: * MERGE HERE AFTER DETECTING A DELIMITER
21593: *
21594: XSCN5 MOV R$XSC,XL RELOAD POINTER TO STRING
21595: MOV SCLEN(XL),WC GET ORIGINAL LENGTH OF STRING
21596: SUB WA,WC MINUS CHARS LEFT = CHARS SCANNED
21597: MOV WC,WA MOVE TO REG FOR SBSTR
21598: SUB XSCBL,WA ADJUST FOR TRAILING BLANKS
21599: MOV XSOFS,WB SET OFFSET
21600: SUB WB,WA COMPUTE LENGTH FOR SBSTR
21601: ICV WC ADJUST NEW CURSOR PAST DELIMITER
21602: MOV WC,XSOFS STORE NEW OFFSET
21603: *
21604: * COMMON EXIT POINT
21605: *
21606: XSCN6 ZER XR CLEAR GARBAGE CHARACTER PTR IN XR
21607: .IF .CASL
21608: JSR SBSTG BUILD SUBSTRING
21609: .ELSE
21610: JSR SBSTR BUILD SUB-STRING
21611: .FI
21612: MOV XSCRT,WA LOAD RETURN CODE
21613: MOV XSCWB,WB RESTORE WB
21614: EXI RETURN TO XSCAN CALLER
21615: *
21616: * DEAL WITH BLANK
21617: *
21618: XSCN7 BZE XSCNB,XSCN8 SKIP IF LEADING BLANK
21619: ICV XSCBL ELSE COUNT TRAILING BLANK
21620: BRN XSCN1 LOOP
21621: *
21622: * LEADING BLANK
21623: *
21624: XSCN8 ICV XSOFS PUSH OFFSET PAST BLANK
21625: BRN XSCN1 LOOP
21626: ENP END PROCEDURE XSCAN
21627: EJC
21628: *
21629: * XSCNI -- EXECUTION FUNCTION ARGUMENT SCAN
21630: *
21631: * XSCNI INITIALIZES THE SCAN USED FOR PROTOTYPE ARGUMENTS
21632: * IN THE CLEAR, DEFINE, LOAD, DATA, ARRAY FUNCTIONS. SEE
21633: * XSCAN FOR THE PROCEDURE WHICH IS USED AFTER THIS CALL.
21634: *
21635: * -(XS) ARGUMENT TO BE SCANNED (ON STACK)
21636: * JSR XSCNI CALL TO SCAN ARGUMENT
21637: * PPM LOC TRANSFER LOC IF ARG IS NOT STRING
21638: * PPM LOC TRANSFER LOC IF ARGUMENT IS NULL
21639: * (XS) POPPED
21640: * (XR,R$XSC) ARGUMENT (SCBLK PTR)
21641: * (WA) ARGUMENT LENGTH
21642: * (IA,RA) DESTROYED
21643: *
21644: XSCNI PRC N,2 ENTRY POINT
21645: JSR GTSTG FETCH ARGUMENT AS STRING
21646: PPM XSCI1 JUMP IF NOT CONVERTIBLE
21647: MOV XR,R$XSC ELSE STORE SCBLK PTR FOR XSCAN
21648: ZER XSOFS SET OFFSET TO ZERO
21649: BZE WA,XSCI2 JUMP IF NULL STRING
21650: EXI RETURN TO XSCNI CALLER
21651: *
21652: * HERE IF ARGUMENT IS NOT A STRING
21653: *
21654: XSCI1 EXI 1 TAKE NOT-STRING ERROR EXIT
21655: *
21656: * HERE FOR NULL STRING
21657: *
21658: XSCI2 EXI 2 TAKE NULL-STRING ERROR EXIT
21659: ENP END PROCEDURE XSCNI
21660: TTL S P I T B O L -- UTILITY ROUTINES
21661: *
21662: * THE FOLLOWING SECTION CONTAINS UTILITY ROUTINES USED FOR
21663: * VARIOUS PURPOSES THROUGHOUT THE SYSTEM. THESE DIFFER
21664: * FROM THE PROCEDURES IN THE UTILITY PROCEDURES SECTION IN
21665: * THEY ARE NOT IN PROCEDURE FORM AND THEY DO NOT RETURN
21666: * TO THEIR CALLERS. THEY ARE ACCESSED WITH A BRANCH TYPE
21667: * INSTRUCTION AFTER SETTING THE REGISTERS TO APPROPRIATE
21668: * PARAMETER VALUES.
21669: *
21670: * THE REGISTER VALUES REQUIRED FOR EACH ROUTINE ARE
21671: * DOCUMENTED AT THE START OF EACH ROUTINE. REGISTERS NOT
21672: * MENTIONED MAY CONTAIN ANY VALUES EXCEPT THAT XR,XL
21673: * CAN ONLY CONTAIN PROPER COLLECTABLE POINTERS.
21674: *
21675: * SOME OF THESE ROUTINES WILL TOLERATE GARBAGE POINTERS
21676: * IN XL,XR ON ENTRY. THIS IS ALWAYS DOCUMENTED AND IN
21677: * EACH CASE, THE ROUTINE CLEARS THESE GARBAGE VALUES BEFORE
21678: * EXITING AFTER COMPLETING ITS TASK.
21679: *
21680: * THE ROUTINES HAVE NAMES CONSISTING OF FIVE LETTERS
21681: * AND ARE ASSEMBLED IN ALPHABETICAL ORDER.
21682: EJC
21683: * ARREF -- ARRAY REFERENCE
21684: *
21685: * (XL) MAY BE NON-COLLECTABLE
21686: * (XR) NUMBER OF SUBSCRIPTS
21687: * (WB) SET ZERO/NONZERO FOR VALUE/NAME
21688: * THE VALUE IN WB MUST BE COLLECTABLE
21689: * STACK SUBSCRIPTS AND ARRAY OPERAND
21690: * BRN ARREF JUMP TO CALL FUNCTION
21691: *
21692: * ARREF CONTINUES BY EXECUTING THE NEXT CODE WORD WITH
21693: * THE RESULT NAME OR VALUE PLACED ON TOP OF THE STACK.
21694: * TO DEAL WITH THE PROBLEM OF ACCESSING SUBSCRIPTS IN THE
21695: * ORDER OF STACKING, XL IS USED AS A SUBSCRIPT POINTER
21696: * WORKING BELOW THE STACK POINTER.
21697: *
21698: ARREF RTN
21699: MOV XR,WA COPY NUMBER OF SUBSCRIPTS
21700: MOV XS,XT POINT TO STACK FRONT
21701: WTB XR CONVERT TO BAU OFFSET
21702: ADD XR,XT POINT TO ARRAY OPERAND ON STACK
21703: ICA XT FINAL VALUE FOR STACK POPPING
21704: MOV XT,ARFXS KEEP FOR LATER
21705: MOV -(XT),XR LOAD ARRAY OPERAND POINTER
21706: MOV XR,R$ARF KEEP ARRAY POINTER
21707: MOV XT,XR SAVE POINTER TO SUBSCRIPTS
21708: MOV R$ARF,XL POINT XL TO POSSIBLE VCBLK OR TBBLK
21709: MOV (XL),WC LOAD FIRST WORD
21710: BEQ WC,=B$ART,ARF01 JUMP IF ARBLK
21711: BEQ WC,=B$VCT,ARF07 JUMP IF VCBLK
21712: BEQ WC,=B$TBT,ARF10 JUMP IF TBBLK
21713: ERB 240,SUBSCRIPTED OPERAND IS NOT TABLE OR ARRAY
21714: *
21715: * HERE FOR ARRAY (ARBLK)
21716: *
21717: ARF01 BNE WA,ARNDM(XL),ARF09 JUMP IF WRONG NUMBER OF DIMS
21718: LDI INTV0 GET INITIAL SUBSCRIPT OF ZERO
21719: MOV XR,XT POINT BEFORE SUBSCRIPTS
21720: ZER WA INITIAL OFFSET TO BOUNDS
21721: BRN ARF03 JUMP INTO LOOP
21722: *
21723: * LOOP TO COMPUTE SUBSCRIPTS BY MULTIPLICATIONS
21724: *
21725: ARF02 MLI ARDM2(XR) MULTIPLY TOTAL BY NEXT DIMENSION
21726: *
21727: * MERGE HERE FIRST TIME
21728: *
21729: ARF03 MOV -(XT),XR LOAD NEXT SUBSCRIPT
21730: STI ARFSI SAVE CURRENT SUBSCRIPT
21731: LDI ICVAL(XR) LOAD INTEGER VALUE IN CASE
21732: BEQ (XR),=B$ICL,ARF04 JUMP IF IT WAS AN INTEGER
21733: EJC
21734: *
21735: * ARREF (CONTINUED)
21736: *
21737: *
21738: JSR GTINT CONVERT TO INTEGER
21739: PPM ARF12 JUMP IF NOT INTEGER
21740: LDI ICVAL(XR) IF OK, LOAD INTEGER VALUE
21741: *
21742: * HERE WITH INTEGER SUBSCRIPT IN (IA)
21743: *
21744: ARF04 MOV R$ARF,XR POINT TO ARRAY
21745: ADD WA,XR OFFSET TO NEXT BOUNDS
21746: SBI ARLBD(XR) SUBTRACT LOW BOUND TO COMPARE
21747: IOV ARF13 OUT OF RANGE FAIL IF OVERFLOW
21748: ILT ARF13 OUT OF RANGE FAIL IF TOO SMALL
21749: SBI ARDIM(XR) SUBTRACT DIMENSION
21750: IGE ARF13 OUT OF RANGE FAIL IF TOO LARGE
21751: ADI ARDIM(XR) ELSE RESTORE SUBSCRIPT OFFSET
21752: ADI ARFSI ADD TO CURRENT TOTAL
21753: ADD *ARDMS,WA POINT TO NEXT BOUNDS
21754: BNE XT,XS,ARF02 LOOP BACK IF MORE TO GO
21755: *
21756: * HERE WITH INTEGER SUBSCRIPT COMPUTED
21757: *
21758: MFI WA GET AS ONE WORD INTEGER
21759: WTB WA CONVERT TO OFFSET
21760: MOV R$ARF,XL POINT TO ARBLK
21761: ADD AROFS(XL),WA ADD OFFSET PAST BOUNDS
21762: ICA WA ADJUST FOR ARPRO FIELD
21763: BNZ WB,ARF08 EXIT WITH NAME IF NAME CALL
21764: *
21765: * MERGE HERE TO GET VALUE FOR VALUE CALL
21766: *
21767: ARF05 JSR ACESS GET VALUE
21768: PPM ARF13 FAIL IF ACESS FAILS
21769: *
21770: * RETURN VALUE
21771: *
21772: ARF06 MOV ARFXS,XS POP STACK ENTRIES
21773: ZER R$ARF FINISHED WITH ARRAY POINTER
21774: BRN EXIXR EXIT WITH VALUE IN XR
21775: EJC
21776: *
21777: * ARREF (CONTINUED)
21778: *
21779: * HERE FOR VECTOR
21780: *
21781: ARF07 BNE WA,=NUM01,ARF09 ERROR IF MORE THAN 1 SUBSCRIPT
21782: MOV (XS),XR ELSE LOAD SUBSCRIPT
21783: JSR GTINT CONVERT TO INTEGER
21784: PPM ARF12 ERROR IF NOT INTEGER
21785: LDI ICVAL(XR) ELSE LOAD INTEGER VALUE
21786: SBI INTV1 SUBTRACT FOR ONES OFFSET
21787: MFI WA,ARF13 GET SUBSCRIPT AS ONE WORD
21788: ADD =VCVLS,WA ADD OFFSET FOR STANDARD FIELDS
21789: WTB WA CONVERT OFFSET TO BAUS
21790: BGE WA,VCLEN(XL),ARF13 FAIL IF OUT OF RANGE SUBSCRIPT
21791: BZE WB,ARF05 BACK TO GET VALUE IF VALUE CALL
21792: *
21793: * RETURN NAME
21794: *
21795: ARF08 MOV ARFXS,XS POP STACK ENTRIES
21796: ZER R$ARF FINISHED WITH ARRAY POINTER
21797: BRN EXNAM ELSE EXIT WITH NAME
21798: *
21799: * HERE IF SUBSCRIPT COUNT IS WRONG
21800: *
21801: ARF09 ERB 241,ARRAY REFERENCED WITH WRONG NUMBER OF SUBSCRIPTS
21802: *
21803: * TABLE
21804: *
21805: ARF10 BNE WA,=NUM01,ARF11 ERROR IF MORE THAN 1 SUBSCRIPT
21806: MOV (XS),XR ELSE LOAD SUBSCRIPT
21807: JSR TFIND CALL TABLE SEARCH ROUTINE
21808: PPM ARF13 FAIL IF FAILED
21809: BNZ WB,ARF08 EXIT WITH NAME IF NAME CALL
21810: BRN ARF06 ELSE EXIT WITH VALUE
21811: *
21812: * HERE FOR BAD TABLE REFERENCE
21813: *
21814: ARF11 ERB 242,TABLE REFERENCED WITH MORE THAN ONE SUBSCRIPT
21815: *
21816: * HERE FOR BAD SUBSCRIPT
21817: *
21818: ARF12 ERB 243,ARRAY SUBSCRIPT IS NOT INTEGER
21819: *
21820: * HERE TO SIGNAL FAILURE
21821: *
21822: ARF13 ZER R$ARF FINISHED WITH ARRAY POINTER
21823: BRN EXFAL FAIL
21824: EJC
21825: *
21826: * CFUNC -- CALL A FUNCTION
21827: *
21828: * CFUNC IS USED TO CALL A SNOBOL LEVEL FUNCTION. IT IS
21829: * USED BY THE APPLY FUNCTION (S$APP), THE FUNCTION
21830: * TRACE ROUTINE (TRXEQ) AND THE MAIN FUNCTION CALL ENTRY
21831: * (O$FNC, O$FNS). IN THE LATTER CASES, CFUNC IS USED ONLY
21832: * IF THE NUMBER OF ARGUMENTS IS INCORRECT.
21833: *
21834: * (XL) POINTER TO FUNCTION BLOCK
21835: * (WA) ACTUAL NUMBER OF ARGUMENTS
21836: * (XS) POINTS TO STACKED ARGUMENTS
21837: * BRN CFUNC JUMP TO CALL FUNCTION
21838: *
21839: * CFUNC CONTINUES BY EXECUTING THE FUNCTION
21840: *
21841: CFUNC RTN
21842: BLT WA,FARGS(XL),CFNC1 JUMP IF TOO FEW ARGUMENTS
21843: BEQ WA,FARGS(XL),CFNC3 JUMP IF CORRECT NUMBER OF ARGS
21844: *
21845: * HERE IF TOO MANY ARGUMENTS SUPPLIED, POP THEM OFF
21846: *
21847: MOV WA,WB COPY ACTUAL NUMBER
21848: SUB FARGS(XL),WB GET NUMBER OF EXTRA ARGS
21849: WTB WB CONVERT TO BAUS
21850: ADD WB,XS POP OFF UNWANTED ARGUMENTS
21851: BRN CFNC3 JUMP TO GO OFF TO FUNCTION
21852: *
21853: * HERE IF TOO FEW ARGUMENTS
21854: *
21855: CFNC1 MOV FARGS(XL),WB LOAD REQUIRED NUMBER OF ARGUMENTS
21856: BEQ WB,=NINI9,CFNC3 JUMP IF CASE OF VAR NUM OF ARGS
21857: SUB WA,WB CALCULATE NUMBER MISSING
21858: LCT WB,WB SET COUNTER TO CONTROL LOOP
21859: *
21860: * LOOP TO SUPPLY EXTRA NULL ARGUMENTS
21861: *
21862: CFNC2 MOV =NULLS,-(XS) STACK A NULL ARGUMENT
21863: BCT WB,CFNC2 LOOP TILL PROPER NUMBER STACKED
21864: *
21865: * MERGE HERE TO JUMP TO FUNCTION
21866: *
21867: CFNC3 BRI (XL) JUMP THROUGH FCODE FIELD
21868: EJC
21869: *
21870: * EROSI -- PROCESS ERROR RETURN FROM OSINT
21871: *
21872: * (WA) 0 OR ERROR CODE IN 256 TO 998
21873: * (XL) 0 OR PSEUDO SCBLK FOR ERROR MESSAGE
21874: * (IA) NEW VALUE FOR CODE KEYWORD
21875: * BRN EROSI JUMP TO PROCESS ERROR
21876: *
21877: EROSI RTN
21878: STI KVCOD STORE NEW CODE KEYWORD VALUE
21879: MOV WA,KVERT STORE ERROR CODE
21880: BZE XL,ERROR FAIL AT ONCE IF NO ERROR MSG TEXT
21881: MOV SCLEN(XL),WA STRING LENGTH
21882: ZER WB ZERO OFFSET
21883: JSR SBSTR COPY ERROR MESSAGE STRING
21884: MOV XR,R$ETX AND STORE IT
21885: MNZ EROSN NOTE NO CALL OF SYSEM
21886: MOV KVERT,WA RECALL ERROR CODE
21887: BRN ERROR ENTER ERROR SECTION
21888: *
21889: * EXFAL -- EXIT SIGNALLING SNOBOL FAILURE
21890: *
21891: * (XL,XR) MAY BE NON-COLLECTABLE
21892: * BRN EXFAL JUMP TO FAIL
21893: *
21894: * EXFAL CONTINUES BY EXECUTING THE APPROPRIATE FAIL GOTO
21895: *
21896: EXFAL RTN
21897: MOV FLPTR,XS POP STACK
21898: MOV (XS),XR LOAD FAILURE OFFSET
21899: ADD R$COD,XR POINT TO FAILURE CODE LOCATION
21900: LCP XR SET CODE POINTER
21901: BRN EXITS DO NEXT CODE WORD
21902: *
21903: * EXINT -- EXIT WITH INTEGER RESULT
21904: *
21905: * (XL,XR) MAY BE NONCOLLECTABLE
21906: * (IA) INTEGER VALUE
21907: * BRN EXINT JUMP TO EXIT WITH INTEGER
21908: *
21909: * EXINT CONTINUES BY EXECUTING THE NEXT CODE WORD
21910: * WHICH IT DOES BY FALLING THROUGH TO EXIXR
21911: *
21912: EXINT RTN
21913: JSR ICBLD BUILD ICBLK
21914: EJC
21915: * EXIXR -- EXIT WITH RESULT IN (XR)
21916: *
21917: * (XR) RESULT
21918: * (XL) MAY BE NON-COLLECTABLE
21919: * BRN EXIXR JUMP TO EXIT WITH RESULT IN (XR)
21920: *
21921: * EXIXR CONTINUES BY EXECUTING THE NEXT CODE WORD
21922: * WHICH IT DOES BY FALLING THROUGH TO EXITS.
21923: EXIXR RTN
21924: *
21925: MOV XR,-(XS) STACK RESULT
21926: *
21927: *
21928: * EXITS -- EXIT WITH RESULT IF ANY STACKED
21929: *
21930: * (XR,XL) MAY BE NON-COLLECTABLE
21931: *
21932: * BRN EXITS ENTER EXITS ROUTINE
21933: *
21934: EXITS RTN
21935: LCW XR LOAD NEXT CODE WORD
21936: MOV (XR),XL LOAD ENTRY ADDRESS
21937: BRI XL JUMP TO EXECUTE NEXT CODE WORD
21938: *
21939: * EXNAM -- EXIT WITH NAME IN (XL,WA)
21940: *
21941: * (XL) NAME BASE
21942: * (WA) NAME OFFSET
21943: * (XR) MAY BE NON-COLLECTABLE
21944: * BRN EXNAM JUMP TO EXIT WITH NAME IN (XL,WA)
21945: *
21946: * EXNAM CONTINUES BY EXECUTING THE NEXT CODE WORD
21947: *
21948: EXNAM RTN
21949: MOV XL,-(XS) STACK NAME BASE
21950: MOV WA,-(XS) STACK NAME OFFSET
21951: BRN EXITS DO NEXT CODE WORD
21952: EJC
21953: *
21954: * EXNUL -- EXIT WITH NULL RESULT
21955: *
21956: * (XL,XR) MAY BE NON-COLLECTABLE
21957: * BRN EXNUL JUMP TO EXIT WITH NULL VALUE
21958: *
21959: * EXNUL CONTINUES BY EXECUTING THE NEXT CODE WORD
21960: *
21961: EXNUL RTN
21962: MOV =NULLS,-(XS) STACK NULL VALUE
21963: BRN EXITS DO NEXT CODE WORD
21964: .IF .CNRA
21965: .ELSE
21966: *
21967: * EXREA -- EXIT WITH REAL RESULT
21968: *
21969: * (XL,XR) MAY BE NON-COLLECTABLE
21970: * (RA) REAL VALUE
21971: * BRN EXREA JUMP TO EXIT WITH REAL VALUE
21972: *
21973: * EXREA CONTINUES BY EXECUTING THE NEXT CODE WORD
21974: *
21975: EXREA RTN
21976: JSR RCBLD BUILD RCBLK
21977: BRN EXIXR JUMP TO EXIT WITH RESULT IN XR
21978: .FI
21979: *
21980: * EXSID -- EXIT SETTING ID FIELD
21981: *
21982: * EXSID IS USED TO EXIT AFTER BUILDING ANY OF THE FOLLOWING
21983: * BLOCKS (ARBLK, TBBLK, PDBLK, VCBLK). IT SETS THE IDVAL.
21984: *
21985: * (XR) PTR TO BLOCK WITH IDVAL FIELD
21986: * (XL) MAY BE NON-COLLECTABLE
21987: * BRN EXSID JUMP TO EXIT AFTER SETTING ID FIELD
21988: *
21989: * EXSID CONTINUES BY EXECUTING THE NEXT CODE WORD
21990: *
21991: EXSID RTN
21992: MOV CURID,WA LOAD CURRENT ID VALUE
21993: BNE WA,=CFP$M,EXSI1 JUMP IF NO OVERFLOW
21994: ZER WA ELSE RESET FOR WRAPAROUND
21995: *
21996: * HERE WITH OLD IDVAL IN WA
21997: *
21998: EXSI1 ICV WA BUMP ID VALUE
21999: MOV WA,CURID STORE FOR NEXT TIME
22000: MOV WA,IDVAL(XR) STORE ID VALUE
22001: BRN EXIXR EXIT WITH RESULT IN (XR)
22002: EJC
22003: *
22004: * EXVNM -- EXIT WITH NAME OF VARIABLE
22005: *
22006: * EXVNM EXITS AFTER STACKING A VALUE WHICH IS A NMBLK
22007: * REFERENCING THE NAME OF A GIVEN NATURAL VARIABLE.
22008: *
22009: * (XR) VRBLK POINTER
22010: * (XL) MAY BE NON-COLLECTABLE
22011: * BRN EXVNM EXIT WITH VRBLK POINTER IN XR
22012: *
22013: EXVNM RTN
22014: MOV XR,XL COPY NAME BASE POINTER
22015: MOV *NMSI$,WA SET SIZE OF NMBLK
22016: JSR ALLOC ALLOCATE NMBLK
22017: MOV =B$NML,(XR) STORE TYPE WORD
22018: MOV XL,NMBAS(XR) STORE NAME BASE
22019: MOV *VRVAL,NMOFS(XR) STORE NAME OFFSET
22020: BRN EXIXR EXIT WITH RESULT IN XR
22021: *
22022: * FLPOP -- FAIL AND POP IN PATTERN MATCHING
22023: *
22024: * FLPOP POPS THE NODE AND CURSOR ON THE STACK AND THEN
22025: * DROPS THROUGH INTO FAILP TO CAUSE PATTERN FAILURE
22026: *
22027: * (XL,XR) MAY BE NON-COLLECTABLE
22028: * BRN FLPOP JUMP TO FAIL AND POP STACK
22029: *
22030: FLPOP RTN
22031: ADD *NUM02,XS POP TWO ENTRIES OFF STACK
22032: *
22033: * FAILP -- FAILURE IN MATCHING PATTERN NODE
22034: *
22035: * FAILP IS USED AFTER FAILING TO MATCH A PATTERN NODE.
22036: * SEE PATTERN MATCH ROUTINES FOR DETAILS OF USE.
22037: *
22038: * (XL,XR) MAY BE NON-COLLECTABLE
22039: * BRN FAILP SIGNAL FAILURE TO MATCH
22040: *
22041: * FAILP CONTINUES BY MATCHING AN ALTERNATIVE FROM THE STACK
22042: *
22043: FAILP RTN
22044: MOV (XS)+,XR LOAD ALTERNATIVE NODE POINTER
22045: MOV (XS)+,WB RESTORE OLD CURSOR
22046: MOV (XR),XL LOAD PCODE ENTRY POINTER
22047: BRI XL JUMP TO EXECUTE CODE FOR NODE
22048: EJC
22049: *
22050: * INDIR -- COMPUTE INDIRECT REFERENCE
22051: *
22052: * (WB) NONZERO/ZERO FOR BY NAME/VALUE
22053: * BRN INDIR JUMP TO GET INDIRECT REF ON STACK
22054: *
22055: * INDIR CONTINUES BY EXECUTING THE NEXT CODE WORD
22056: *
22057: INDIR RTN
22058: MOV (XS)+,XR LOAD ARGUMENT
22059: BEQ (XR),=B$NML,INDR2 JUMP IF A NAME
22060: JSR GTNVR ELSE CONVERT TO VARIABLE
22061: ERR 244,INDIRECTION OPERAND IS NOT NAME
22062: BZE WB,INDR1 SKIP IF BY VALUE
22063: MOV XR,-(XS) ELSE STACK VRBLK PTR
22064: MOV *VRVAL,-(XS) STACK NAME OFFSET
22065: BRN EXITS EXIT WITH RESULT ON STACK
22066: *
22067: * HERE TO GET VALUE OF NATURAL VARIABLE
22068: *
22069: INDR1 BRI (XR) JUMP THROUGH VRGET FIELD OF VRBLK
22070: *
22071: * HERE IF OPERAND IS A NAME
22072: *
22073: INDR2 MOV NMBAS(XR),XL LOAD NAME BASE
22074: MOV NMOFS(XR),WA LOAD NAME OFFSET
22075: BNZ WB,EXNAM EXIT IF CALLED BY NAME
22076: JSR ACESS ELSE GET VALUE FIRST
22077: PPM EXFAL FAIL IF ACCESS FAILS
22078: BRN EXIXR ELSE RETURN WITH VALUE IN XR
22079: EJC
22080: *
22081: * MATCH -- INITIATE PATTERN MATCH
22082: *
22083: * (WB) MATCH TYPE CODE
22084: * BRN MATCH JUMP TO INITIATE PATTERN MATCH
22085: *
22086: * MATCH CONTINUES BY EXECUTING THE PATTERN MATCH. SEE
22087: * PATTERN MATCH ROUTINES (P$XXX) FOR FULL DETAILS.
22088: *
22089: MATCH RTN
22090: MOV (XS)+,XR LOAD PATTERN OPERAND
22091: JSR GTPAT CONVERT TO PATTERN
22092: ERR 245,PATTERN MATCH RIGHT OPERAND IS NOT PATTERN
22093: MOV XR,XL IF OK, SAVE PATTERN POINTER
22094: BNZ WB,MTCH1 JUMP IF NOT MATCH BY NAME
22095: MOV (XS),WA ELSE LOAD NAME OFFSET
22096: MOV XL,-(XS) SAVE PATTERN POINTER
22097: MOV 2(XS),XL LOAD NAME BASE
22098: JSR ACESS ACCESS SUBJECT VALUE
22099: PPM EXFAL FAIL IF ACCESS FAILS
22100: MOV (XS),XL RESTORE PATTERN POINTER
22101: MOV XR,(XS) STACK SUBJECT STRING VAL FOR MERGE
22102: ZER WB RESTORE TYPE CODE
22103: *
22104: * MERGE HERE WITH SUBJECT VALUE ON STACK
22105: *
22106: .IF .CNBF
22107: MTCH1 JSR GTSTG CONVERT SUBJECT TO STRING
22108: .ELSE
22109: MTCH1 MOV (XS),XR LOAD SUBJECT VALUE
22110: ZER R$PMB ASSUME NOT A BUFFER
22111: BNE (XR),=B$BCT,MTCHA BRANCH IF NOT
22112: ICA XS ELSE POP VALUE
22113: MOV XR,R$PMB SAVE POINTER
22114: MOV BCLEN(XR),WA GET DEFINED LENGTH
22115: MOV BCBUF(XR),XR POINT TO BFBLK
22116: BRN MTCHB
22117: *
22118: * HERE IF NOT BUFFER TO CONVERT TO STRING
22119: *
22120: MTCHA JSR GTSTG NOT BUFFER - CONVERT TO STRING
22121: .FI
22122: ERR 246,PATTERN MATCH LEFT OPERAND IS NOT STRING
22123: .IF .CNBF
22124: MOV XR,R$PMS IF OK, STORE SUBJECT STRING POINTER
22125: .ELSE
22126: *
22127: * MERGE WITH NULL STRING OR BUFFER
22128: *
22129: MTCHB MOV XR,R$PMS IF OK, STORE SUBJECT STRING POINTER
22130: .FI
22131: MOV WA,PMSSL AND LENGTH
22132: MOV WB,-(XS) STACK MATCH TYPE CODE
22133: ZER -(XS) STACK INITIAL CURSOR (ZERO)
22134: ZER WB SET INITIAL CURSOR
22135: MOV XS,PMHBS SET HISTORY STACK BASE PTR
22136: ZER PMDFL RESET PATTERN ASSIGNMENT FLAG
22137: MOV XL,XR SET INITIAL NODE POINTER
22138: BNZ KVANC,MTCH2 JUMP IF ANCHORED
22139: EJC
22140: *
22141: * MATCH (CONTINUED)
22142: *
22143: * HERE FOR UNANCHORED
22144: *
22145: MOV XR,-(XS) STACK INITIAL NODE POINTER
22146: MOV =NDUNA,-(XS) STACK POINTER TO ANCHOR MOVE NODE
22147: BRI (XR) START MATCH OF FIRST NODE
22148: *
22149: * HERE IN ANCHORED MODE
22150: *
22151: MTCH2 ZER -(XS) DUMMY CURSOR VALUE
22152: MOV =NDABO,-(XS) STACK POINTER TO ABORT NODE
22153: BRI (XR) START MATCH OF FIRST NODE
22154: EJC
22155: *
22156: * RETRN -- RETURN FROM FUNCTION
22157: *
22158: * (WA) STRING POINTER FOR RETURN TYPE
22159: * BRN RETRN JUMP TO RETURN FROM (SNOBOL) FUNC
22160: *
22161: * RETRN CONTINUES BY EXECUTING THE CODE AT THE RETURN POINT
22162: * THE STACK IS CLEANED OF ANY GARBAGE LEFT BY OTHER
22163: * ROUTINES WHICH MAY HAVE ALTERED FLPTR SINCE FUNCTION
22164: * ENTRY BY USING FLPRT, RESERVED FOR USE ONLY BY
22165: * FUNCTION CALL AND RETURN.
22166: *
22167: RETRN RTN
22168: BNZ KVFNC,RTN01 JUMP IF NOT LEVEL ZERO
22169: ERB 247,FUNCTION RETURN FROM LEVEL ZERO
22170: *
22171: * HERE IF NOT LEVEL ZERO RETURN
22172: *
22173: RTN01 MOV FLPRT,XS POP STACK
22174: ICA XS REMOVE FAILURE OFFSET
22175: MOV (XS)+,XR POP PFBLK POINTER
22176: MOV (XS)+,FLPTR POP FAILURE POINTER
22177: MOV (XS)+,FLPRT POP OLD FLPRT
22178: MOV (XS)+,WB POP CODE POINTER OFFSET
22179: MOV (XS)+,WC POP OLD CODE BLOCK POINTER
22180: ADD WC,WB MAKE OLD CODE POINTER ABSOLUTE
22181: LCP WB RESTORE OLD CODE POINTER
22182: MOV WC,R$COD RESTORE OLD CODE BLOCK POINTER
22183: DCV KVFNC DECREMENT FUNCTION LEVEL
22184: MOV KVTRA,WB LOAD TRACE
22185: ADD KVFTR,WB ADD FTRACE
22186: BZE WB,RTN06 JUMP IF NO TRACING POSSIBLE
22187: *
22188: * HERE IF THERE MAY BE A TRACE
22189: *
22190: MOV WA,-(XS) SAVE FUNCTION RETURN TYPE
22191: MOV XR,-(XS) SAVE PFBLK POINTER
22192: MOV WA,KVRTN SET RTNTYPE FOR TRACE FUNCTION
22193: MOV R$FNC,XL LOAD FNCLEVEL TRBLK PTR (IF ANY)
22194: JSR KTREX EXECUTE POSSIBLE FNCLEVEL TRACE
22195: MOV PFVBL(XR),XL LOAD VRBLK POINTER
22196: BZE KVTRA,RTN02 JUMP IF TRACE IS OFF
22197: MOV PFRTR(XR),XR ELSE LOAD RETURN TRACE TRBLK PTR
22198: BZE XR,RTN02 JUMP IF NOT RETURN TRACED
22199: DCV KVTRA ELSE DECREMENT TRACE COUNT
22200: BZE TRFNC(XR),RTN03 JUMP IF PRINT TRACE
22201: MOV *VRVAL,WA ELSE SET NAME OFFSET
22202: MOV 1(XS),KVRTN MAKE SURE RTNTYPE IS SET RIGHT
22203: JSR TRXEQ EXECUTE FULL TRACE
22204: EJC
22205: *
22206: * RETRN (CONTINUED)
22207: *
22208: * HERE TO TEST FOR FTRACE
22209: *
22210: RTN02 BZE KVFTR,RTN05 JUMP IF FTRACE IS OFF
22211: DCV KVFTR ELSE DECREMENT FTRACE
22212: *
22213: * HERE FOR PRINT TRACE OF FUNCTION RETURN
22214: *
22215: RTN03 JSR PRTSN PRINT STATEMENT NUMBER
22216: MOV 1(XS),XR LOAD RETURN TYPE
22217: JSR PRTST PRINT IT
22218: MOV =CH$BL,WA LOAD BLANK
22219: JSR PRTCH PRINT IT
22220: MOV 0(XS),XL LOAD PFBLK PTR
22221: MOV PFVBL(XL),XL LOAD FUNCTION VRBLK PTR
22222: MOV *VRVAL,WA SET VRBLK NAME OFFSET
22223: BNE XR,=SCFRT,RTN04 JUMP IF NOT FRETURN CASE
22224: *
22225: * FOR FRETURN, JUST PRINT FUNCTION NAME
22226: *
22227: JSR PRTNM PRINT NAME
22228: JSR PRTFH TERMINATE PRINT LINE
22229: BRN RTN05 MERGE
22230: *
22231: * HERE FOR RETURN OR NRETURN, PRINT FUNCTION NAME = VALUE
22232: *
22233: RTN04 JSR PRTNV PRINT NAME = VALUE
22234: *
22235: * HERE AFTER COMPLETING TRACE
22236: *
22237: RTN05 MOV (XS)+,XR POP PFBLK POINTER
22238: MOV (XS)+,WA POP RETURN TYPE STRING
22239: *
22240: * MERGE HERE IF NO TRACE REQUIRED
22241: *
22242: RTN06 MOV WA,KVRTN SET RTNTYPE KEYWORD
22243: MOV PFVBL(XR),XL LOAD POINTER TO FN VRBLK
22244: EJC
22245: * RETRN (CONTINUED)
22246: *
22247: * GET VALUE OF FUNCTION
22248: *
22249: RTN07 MOV XL,RTNBP SAVE BLOCK POINTER
22250: MOV VRVAL(XL),XL LOAD VALUE
22251: BEQ (XL),=B$TRT,RTN07 LOOP BACK IF TRAPPED
22252: MOV XL,RTNFV ELSE SAVE FUNCTION RESULT VALUE
22253: MOV (XS)+,RTNSV SAVE ORIGINAL FUNCTION VALUE
22254: .IF .CNPF
22255: MOV FARGS(XR),WB GET NUMBER OF ARGUMENTS
22256: .ELSE
22257: MOV (XS)+,XL POP SAVED POINTER
22258: BZE XL,RTN7C NO ACTION IF NONE
22259: BZE KVPFL,RTN7C JUMP IF NO PROFILING
22260: JSR PRFLU ELSE PROFILE LAST FUNC STMT
22261: BEQ KVPFL,=NUM02,RTN7A BRANCH ON VALUE OF PROFILE KEYWD
22262: *
22263: * HERE IF PROFILE = 1. START TIME MUST BE FRIGGED TO
22264: * APPEAR EARLIER THAN IT ACTUALLY IS, BY AMOUNT USED BEFORE
22265: * THE CALL.
22266: *
22267: LDI PFSTM LOAD CURRENT TIME
22268: SBI ICVAL(XL) FRIG BY SUBTRACTING SAVED AMOUNT
22269: BRN RTN7B AND MERGE
22270: *
22271: * HERE IF PROFILE = 2
22272: *
22273: RTN7A LDI ICVAL(XL) LOAD SAVED TIME
22274: *
22275: * BOTH PROFILE TYPES MERGE HERE
22276: *
22277: RTN7B STI PFSTM STORE BACK CORRECT START TIME
22278: *
22279: * MERGE HERE IF NO PROFILING
22280: *
22281: RTN7C MOV FARGS(XR),WB GET NUMBER OF ARGS
22282: .FI
22283: ADD PFNLO(XR),WB ADD NUMBER OF LOCALS
22284: BZE WB,RTN10 JUMP IF NO ARGS/LOCALS
22285: LCT WB,WB ELSE SET LOOP COUNTER
22286: ADD PFLEN(XR),XR AND POINT TO END OF PFBLK
22287: *
22288: * LOOP TO RESTORE FUNCTIONS AND LOCALS
22289: *
22290: RTN08 MOV -(XR),XL LOAD NEXT VRBLK POINTER
22291: *
22292: * LOOP TO FIND VALUE BLOCK
22293: *
22294: RTN09 MOV XL,WA SAVE BLOCK POINTER
22295: MOV VRVAL(XL),XL LOAD POINTER TO NEXT VALUE
22296: BEQ (XL),=B$TRT,RTN09 LOOP BACK IF TRAPPED
22297: MOV WA,XL ELSE RESTORE LAST BLOCK POINTER
22298: MOV (XS)+,VRVAL(XL) RESTORE OLD VARIABLE VALUE
22299: BCT WB,RTN08 LOOP TILL ALL PROCESSED
22300: EJC
22301: *
22302: * RETRN (CONTINUED)
22303: *
22304: * NOW RESTORE FUNCTION VALUE AND EXIT
22305: *
22306: RTN10 MOV RTNBP,XL RESTORE PTR TO LAST FUNCTION BLOCK
22307: MOV RTNSV,VRVAL(XL) RESTORE OLD FUNCTION VALUE
22308: MOV RTNFV,XR RELOAD FUNCTION RESULT
22309: MOV R$COD,XL POINT TO NEW CODE BLOCK
22310: MOV KVSTN,KVLST SET LASTNO FROM STNO
22311: MOV CDSTM(XL),KVSTN RESET PROPER STNO VALUE
22312: MOV KVRTN,WA LOAD RETURN TYPE
22313: BEQ WA,=SCRTN,EXIXR EXIT WITH RESULT IN XR IF RETURN
22314: BEQ WA,=SCFRT,EXFAL FAIL IF FRETURN
22315: *
22316: * HERE FOR NRETURN
22317: *
22318: BEQ (XR),=B$NML,RTN11 JUMP IF IS A NAME
22319: JSR GTNVR ELSE TRY CONVERT TO VARIABLE NAME
22320: ERR 248,FUNCTION RESULT IN NRETURN IS NOT NAME
22321: MOV XR,XL IF OK, COPY VRBLK (NAME BASE) PTR
22322: MOV *VRVAL,WA SET NAME OFFSET
22323: BRN RTN12 AND MERGE
22324: *
22325: * HERE IF RETURNED RESULT IS A NAME
22326: *
22327: RTN11 MOV NMBAS(XR),XL LOAD NAME BASE
22328: MOV NMOFS(XR),WA LOAD NAME OFFSET
22329: *
22330: * MERGE HERE WITH RETURNED NAME IN (XL,WA)
22331: *
22332: RTN12 MOV XL,XR PRESERVE XL
22333: LCW WB LOAD NEXT WORD
22334: MOV XR,XL RESTORE XL
22335: BEQ WB,=OFNE$,EXNAM EXIT IF CALLED BY NAME
22336: MOV WB,-(XS) ELSE SAVE CODE WORD
22337: JSR ACESS GET VALUE
22338: PPM EXFAL FAIL IF ACCESS FAILS
22339: MOV XR,XL IF OK, COPY RESULT
22340: MOV (XS),XR RELOAD NEXT CODE WORD
22341: MOV XL,(XS) STORE RESULT ON STACK
22342: MOV (XR),XL LOAD ROUTINE ADDRESS
22343: BRI XL JUMP TO EXECUTE NEXT CODE WORD
22344: EJC
22345: *
22346: * STCOV -- SIGNAL STATEMENT COUNTER OVERFLOW
22347: *
22348: * BRN STCOV JUMP TO SIGNAL STATEMENT COUNT OFLO
22349: *
22350: * PERMIT UP TO 10 MORE STATEMENTS TO BE OBEYED SO THAT
22351: * SETEXIT TRAP CAN REGAIN CONTROL.
22352: * STCOV CONTINUES BY ISSUING THE ERROR MESSAGE
22353: *
22354: STCOV RTN
22355: ICV ERRFT FATAL ERROR
22356: LDI INTVT GET 10
22357: ADI KVSTL ADD TO FORMER LIMIT
22358: STI KVSTL STORE AS NEW STLIMIT
22359: LDI INTVT GET 10
22360: STI KVSTC SET AS NEW COUNT
22361: ERB 249,STATEMENT COUNT EXCEEDS VALUE OF STLIMIT KEYWORD
22362: EJC
22363: *
22364: * STMGO -- START EXECUTION OF NEW STATEMENT
22365: *
22366: * (XR) POINTER TO CDBLK FOR NEW STATEMENT
22367: * BRN STMGO JUMP TO EXECUTE NEW STATEMENT
22368: *
22369: * STMGO CONTINUES BY EXECUTING THE NEXT STATEMENT
22370: *
22371: STMGO RTN
22372: MOV XR,R$COD SET NEW CODE BLOCK POINTER
22373: .IF .CNPF
22374: MOV KVSTN,KVLST SET LASTNO
22375: .ELSE
22376: BZE KVPFL,STGO1 SKIP IF NO PROFILING
22377: JSR PRFLU ELSE PROFILE THE STATEMENT
22378: *
22379: * MERGE PROFILE, NO-PROFILE CASES
22380: *
22381: STGO1 MOV KVSTN,KVLST SET LASTNO
22382: .FI
22383: MOV CDSTM(XR),KVSTN SET STNO
22384: ADD *CDCOD,XR POINT TO FIRST CODE WORD
22385: LCP XR SET CODE POINTER
22386: LDI KVSTC GET STMT COUNT
22387: ILT EXITS OMIT COUNTING IF NEGATIVE
22388: IEQ STCOV FAIL IF STLIMIT REACHED
22389: SBI INTV1 DECREMENT
22390: STI KVSTC REPLACE IT
22391: BZE R$STC,EXITS EXIT IF NO STCOUNT TRACE
22392: *
22393: * HERE FOR STCOUNT TRACE
22394: *
22395: ZER XR CLEAR GARBAGE VALUE IN XR
22396: MOV R$STC,XL LOAD POINTER TO STCOUNT TRBLK
22397: JSR KTREX EXECUTE KEYWORD TRACE
22398: BRN EXITS AND THEN EXIT FOR NEXT CODE WORD
22399: EJC
22400: *
22401: * STOPR -- TERMINATE RUN
22402: *
22403: * (WA) 0 OR ERROR MESSAGE CODE
22404: * (XR) 0 OR ENDING MESSAGE POINTER
22405: * BRN STOPR JUMP TO TERMINATE RUN
22406: *
22407: * TERMINATE RUN AND PRINT STATISTICS. ON ENTRY XR POINTS
22408: * TO ENDING MESSAGE OR IS ZERO IF MESSAGE PRINTED ALREADY.
22409: * (WA) AND (XR) ARE BOTH NON-ZERO ONLY IN THE CASE OF FATAL
22410: * ERRORS DURING INITIAL COMPILE.
22411: *
22412: STOPR RTN
22413: .IF .CSAX
22414: JSR SYSAX CALL AFTER EXECUTION PROC
22415: .ELSE
22416: .FI
22417: ADD RSMEM,DNAME USE THE RESERVE MEMORY
22418: BZE WA,STPR1 SKIP IF NO ERROR MESSAGE
22419: MOV XR,STPXR KEEP 0 OR ENDING MESSAGE
22420: MOV TTERL,TTLST SEND ERROR AND STATS TO TERML
22421: JSR PRTPG PAGE THROW
22422: JSR ERMSG PRINT ERROR MESSAGE
22423: MOV STPXR,XR RECOVER 0 OR ENDING MESSAGE
22424: ZER EXSTS TO FORCE ENDING STATS OUT FOR ERROR
22425: *
22426: * PROCESS ENDING STATISTICS
22427: *
22428: STPR1 MTI KVSTN GET STATEMENT NUMBER
22429: IEQ STPR6 SKIP IF COMPILE TIME
22430: BNZ EXSTS,STPR4 SKIP IF NO STATS TO BE PRINTED
22431: JSR PRTPG EJECT PRINTER
22432: BZE XR,STPR2 SKIP IF NO MESSAGE
22433: JSR PRTFB PRINT MESSAGE
22434: *
22435: * MERGE HERE IF NO MESSAGE TO PRINT
22436: *
22437: STPR2 JSR PRTFH PRINT BLANK LINE
22438: MOV =STPM1,XR POINT TO MESSAGE /IN STATEMENT XXX/
22439: JSR PRTMI PRINT IT
22440: JSR SYSTM GET CURRENT TIME
22441: SBI TIMSX MINUS START TIME = ELAPSED EXEC TIM
22442: STI STPTI SAVE FOR LATER
22443: MOV =STPM3,XR POINT TO MSG /EXECUTION TIME MSEC /
22444: JSR PRTMI PRINT IT
22445: LDI KVSTL GET STATEMENT LIMIT
22446: ILT STPR3 SKIP IF NEGATIVE
22447: SBI KVSTC MINUS COUNTER = COUNT
22448: STI STPSI SAVE
22449: MOV =STPM2,XR POINT TO MESSAGE /STMTS EXECUTED/
22450: JSR PRTMI PRINT IT
22451: .IF .CTMD
22452: .ELSE
22453: LDI STPTI RELOAD ELAPSED TIME
22454: MLI INTTH *1000 (MICROSECS)
22455: IOV STPR3 JUMP IF WE CANNOT COMPUTE
22456: DVI STPSI DIVIDE BY STATEMENT COUNT
22457: IOV STPR3 JUMP IF OVERFLOW
22458: MOV =STPM4,XR POINT TO MSG (MCSEC PER STATEMENT /
22459: JSR PRTMI PRINT IT
22460: .FI
22461: EJC
22462: *
22463: * STOPR (CONTINUED)
22464: *
22465: * MERGE TO SKIP MESSAGE (OVERFLOW OR NEGATIVE STLIMIT)
22466: *
22467: STPR3 MTI GBCNT LOAD COUNT OF COLLECTIONS
22468: MOV =STPM5,XR POINT TO MESSAGE /REGENERATIONS /
22469: JSR PRTMI PRINT IT
22470: JSR PRTFH ONE MORE BLANK FOR LUCK
22471: *
22472: * CHECK IF DUMP REQUESTED
22473: *
22474: .IF .CNPF
22475: STPR4 MOV KVDMP,XR LOAD DUMP KEYWORD
22476: .ELSE
22477: STPR4 JSR PRFLR PRINT PROFILE IF WANTED
22478: MOV KVDMP,XR LOAD DUMP KEYWORD
22479: .FI
22480: JSR DUMPR EXECUTE DUMP IF REQUESTED
22481: *
22482: * MERGE TO END RUN FOR SEVERE COMPILATION ERRORS
22483: *
22484: STPR5 MOV =KVCOD,WA LOAD CODE VALUE
22485: JSR SYSEJ EXIT TO SYSTEM
22486: *
22487: * TERMINATION DURING COMPILE
22488: *
22489: STPR6 BZE XR,STPR7 SKIP IF NO MESSAGE
22490: JSR PRTSF ELSE PRINT IT
22491: *
22492: * NOTIFICATION THAT IT IS COMPILE TIME
22493: *
22494: STPR7 MOV =ENDIC,XR NOTIFY USER
22495: JSR PRTSF SEND IT
22496: BRN STPR5 END
22497: EJC
22498: *
22499: * SUCCP -- SIGNAL SUCCESSFUL MATCH OF A PATTERN NODE
22500: *
22501: * SEE PATTERN MATCH ROUTINES FOR DETAILS
22502: *
22503: * (XR) CURRENT NODE
22504: * (WB) CURRENT CURSOR
22505: * (XL) MAY BE NON-COLLECTABLE
22506: * BRN SUCCP SIGNAL SUCCESSFUL PATTERN MATCH
22507: *
22508: * SUCCP CONTINUES BY MATCHING THE SUCCESSOR NODE
22509: *
22510: SUCCP RTN
22511: MOV PTHEN(XR),XR LOAD SUCCESSOR NODE
22512: MOV (XR),XL LOAD NODE CODE ENTRY ADDRESS
22513: BRI XL JUMP TO MATCH SUCCESSOR NODE
22514: TTL S P I T B O L -- STACK OVERFLOW SECTION
22515: *
22516: * CONTROL COMES HERE IF THE MAIN STACK OVERFLOWS
22517: *
22518: SEC START OF STACK OVERFLOW SECTION
22519: *
22520: STAKV RTN ENTRY POINT FOR STACK OVERFLOW
22521: ICV ERRFT FATAL ERROR
22522: MOV FLPTR,XS POP STACK TO AVOID MORE FAILS
22523: BNZ GBCFL,STAK1 JUMP IF GARBAGE COLLECTING
22524: ERB 250,STACK OVERFLOW
22525: *
22526: * NO CHANCE OF RECOVERY IN MID GARBAGE COLLECTION
22527: *
22528: STAK1 MOV =ENDSO,XR POINT TO MESSAGE
22529: ZER KVDMP MEMORY IS UNDUMPABLE
22530: ZER WA NO ERROR MESSAGE
22531: MOV TTERL,TTLST SEND MESSAGE TO TERML IF POSSIBLE
22532: BRN STOPR GIVE UP
22533: TTL S P I T B O L -- ERROR SECTION
22534: *
22535: * THIS SECTION OF CODE IS ENTERED WHENEVER A PROCEDURE
22536: * RETURN VIA AN ERR PARAMETER OR AN ERB OPCODE IS OBEYED.
22537: *
22538: * (WA) IS THE ERROR CODE
22539: *
22540: * THE GLOBAL VARIABLE STAGE INDICATES THE POINT AT WHICH
22541: * THE ERROR OCCURED AS FOLLOWS.
22542: *
22543: * STAGE=STGIC ERROR DURING INITIAL COMPILE
22544: *
22545: * STAGE=STGXC ERROR DURING COMPILE AT EXECUTE
22546: * TIME (CODE, CONVERT FUNCTION CALLS)
22547: *
22548: * STAGE=STGEV ERROR DURING COMPILATION OF
22549: * EXPRESSION AT EXECUTION TIME
22550: * (EVAL, CONVERT FUNCTION CALL).
22551: *
22552: * STAGE=STGXT ERROR AT EXECUTE TIME. COMPILER
22553: * NOT ACTIVE.
22554: *
22555: * STAGE=STGCE ERROR DURING INITIAL COMPILE AFTER
22556: * SCANNING OUT THE END LINE.
22557: *
22558: * STAGE=STGXE ERROR DURING COMPILE AT EXECUTE
22559: * TIME AFTER SCANNING END LINE.
22560: *
22561: * STAGE=STGEE ERROR DURING EXPRESSION EVALUATION
22562: *
22563: SEC START OF ERROR SECTION
22564: *
22565: ERROR RTN ERROR CODE ENTRY POINT
22566: BGE ERRFT,=NUM03,ERR16 SKIP IF TOO MANY FATALS
22567: BEQ R$CIM,=CMLAB,ERRG1 JUMP IF ERROR IN LABEL SCAN
22568: MOV WA,KVERT SAVE ERROR CODE
22569: ZER SCNRS RESET RESCAN SWITCH FOR SCANE
22570: ZER SCNGO RESET GOTO SWITCH FOR SCANE
22571: MOV STAGE,XR LOAD CURRENT STAGE
22572: BSW XR,STGNO JUMP TO APPROPRIATE ERROR CIRCUIT
22573: IFF STGIC,ERR01 INITIAL COMPILE
22574: IFF STGXC,ERR08 EXECUTE TIME COMPILE
22575: IFF STGEV,ERR08 EVAL COMPILING EXPR.
22576: IFF STGEE,ERR08 EVAL EVALUATING EXPR
22577: IFF STGXT,ERR12 EXECUTE TIME
22578: IFF STGCE,ERR01 COMPILE - AFTER END
22579: IFF STGXE,ERR08 XEQ COMPILE-PAST END
22580: ESW END SWITCH ON ERROR TYPE
22581: *
22582: * ERROR DURING INITIAL COMPILE
22583: * THE ERROR MESSAGE IS PRINTED AS PART OF THE COMPILER
22584: * OUTPUT. THIS PRINTOUT INCLUDES THE OFFENDING LINE (IF NOT
22585: * PRINTED ALREADY) AND AN ERROR FLAG UNDER THE APPROPRIATE
22586: * COLUMN AS INDICATED BY SCNSE UNLESS SCNSE IS SET TO ZERO.
22587: * AFTER PRINTING THE MESSAGE, THE GENERATED CODE IS
22588: * MODIFIED TO AN ERROR CALL AND CONTROL IS RETURNED TO
22589: * THE CMPIL PROCEDURE AFTER RESETTING THE STACK POINTER.
22590: * IF THE ERROR OCCURS AFTER THE END LINE, CONTROL RETURNS
22591: * IN A SLIGHTLY DIFFERENT MANNER TO ENSURE PROPER CLEANUP.
22592: EJC
22593: *
22594: ERR01 MOV CMPXS,XS RESET STACK POINTER
22595: SSL CMPSS RESTORE S-R STACK PTR FOR CMPIL
22596: BNZ ERRSP,ERR06 JUMP IF ERROR SUPPRESS FLAG SET
22597: JSR PRTFH PRINT A BLANK
22598: MOV TTERL,TTLST SET FLAG FOR LISTR
22599: ADD =NUM03,LSTLC CAUSE EJECT IF BELOW 4 LINES LEFT
22600: MOV LSTLC,-(XS) KEEP LINE COUNT
22601: JSR LISTR LIST LINE
22602: JSR PRTFH TERMINATE LISTING
22603: MOV (XS)+,WA RECOVER LINE COUNT
22604: BGT LSTLC,WA,ERR02 SKIP IF NOT NEW PAGE
22605: ADD =NUM04,LSTLC BUMP FOR LINES PRINTED
22606: *
22607: * PRINT FLAG UNDER BAD ELEMENT
22608: *
22609: ERR02 MOV SCNSE,WA LOAD SCAN ELEMENT OFFSET
22610: .IF .CAHT
22611: MOV WA,WB COPY OFFSET
22612: ICV WA INCREASE FOR CH$EX
22613: JSR ALOCS STRING BLOCK FOR ERROR FLAG
22614: MOV XR,WA REMEMBER STRING PTR
22615: PSC XR READY FOR CHARACTER STORING
22616: BZE WB,ERR05 SKIP IF NO BLANKS BEFORE ERROR FLAG
22617: MOV R$CIM,XL POINT TO BAD STATEMENT
22618: PLC XL READY TO GET CHARS
22619: LCT WB,WB LOOP COUNTER
22620: *
22621: * LOOP TO REPLACE ALL CHARS BUT TABS BY BLANKS
22622: *
22623: ERR03 LCH WC,(XL)+ GET NEXT CHAR
22624: BEQ WC,=CH$HT,ERR04 SKIP IF TAB
22625: MOV =CH$BL,WC GET A BLANK
22626: EJC
22627: *
22628: * MERGE TO STORE BLANK OR TAB IN ERROR LINE
22629: *
22630: ERR04 SCH WC,(XR)+ STORE CHAR
22631: BCT WB,ERR03 LOOP
22632: EJC
22633: *
22634: * MERGE IN CASE OF NO PRECEDING BLANKS
22635: *
22636: ERR05 MOV =CH$EX,XL EXCLAMATION MARK
22637: SCH XL,(XR) STORE AT END OF ERROR LINE
22638: CSC XR END OF SCH LOOP
22639: MOV =STNPD,PROFS ALLOW FOR STATEMENT NUMBER
22640: MOV WA,XR POINT TO ERROR LINE
22641: JSR PRTST PRINT ERROR LINE
22642: .ELSE
22643: MTI PRLEN GET PRINT BUFFER LENGTH
22644: STI GTNSI STORE AS SIGNED INTEGER
22645: ADD =STNPD,WA ADJUST FOR STATEMENT NUMBER
22646: MTI WA COPY TO INTEGER ACCUMULATOR
22647: RMI GTNSI REMAINDER MODULO PRINT BFR LENGTH
22648: MFI PROFS USE AS CHARACTER OFFSET
22649: MOV =CH$EX,WA GET EXCLAMATION MARK
22650: JSR PRTCH GENERATE UNDER BAD COLUMN
22651: .FI
22652: *
22653: * HERE AFTER PLACING ERROR FLAG AS REQUIRED
22654: *
22655: JSR ERMSG GENERATE FLAG AND ERROR MESSAGE
22656: ZER TTLST REVERT TO REGULAR LISTING
22657: ZER XR IN CASE OF FATAL ERROR
22658: ICV CMERC BUMP ERROR COUNT
22659: BNE STAGE,=STGIC,ERRG2 SPECIAL RETURN IF AFTER END LINE
22660: *
22661: * IF ERROR IN READR THEN EITHER CLOSE OUT
22662: * CURRENT -COPY LEVEL, OR IF AT TOP THEN ABORT
22663: *
22664: BZE RDRER,ERR06 SKIP IF NOT ERROR WHILE READING
22665: BZE R$COP,ERR16 ABORT IF AT TOP LEVEL INPUT FILE
22666: ZER RDRER ELSE CLEAR READR ERROR FLAG
22667: JSR COPND AND CLOSE OUT THIS COPY LEVEL
22668: *
22669: * LOOP TO SCAN TO END OF STATEMENT
22670: *
22671: ERR06 MOV R$CIM,XR POINT TO START OF IMAGE
22672: BZE XR,ERR07 SKIP IF NO INPUT IMAGE
22673: PLC XR POINT TO FIRST CHAR
22674: LCH XR,(XR) GET FIRST CHAR
22675: BEQ XR,=CH$MN,ERRG3 JUMP IF ERROR IN CONTROL CARD
22676: ZER SCNRS CLEAR RESCAN FLAG
22677: MNZ ERRSP SET ERROR SUPPRESS FLAG
22678: JSR SCANE SCAN NEXT ELEMENT
22679: BNE XL,=T$SMC,ERR06 LOOP BACK IF NOT STATEMENT END
22680: ZER ERRSP CLEAR ERROR SUPPRESS FLAG
22681: EJC
22682: *
22683: * GENERATE ERROR CALL IN CODE AND RETURN TO CMPIL
22684: *
22685: ERR07 MOV *CDCOD,CWCOF RESET OFFSET IN CCBLK
22686: MOV =OCER$,WA LOAD COMPILE ERROR CALL
22687: JSR CDWRD GENERATE IT
22688: MOV CWCOF,CMSOC(XS) SET SUCCESS FILL IN OFFSET
22689: MNZ CMFFC(XS) SET FAILURE FILL IN FLAG
22690: JSR CDWRD GENERATE SUCC. FILL IN WORD
22691: JMG CMPSE MERGE TO GENERATE ERROR AS CDFAL
22692: EJC
22693: *
22694: * ERROR DURING EXECUTE TIME COMPILE OR EXPRESSION EVALUATION.
22695: *
22696: * EXECUTE TIME COMPILATION IS INITIATED THROUGH GTCOD OR
22697: * GTEXP WHICH ARE CALLED BY COMPILE, CODE OR EVAL.
22698: * BEFORE CAUSING STATEMENT FAILURE THROUGH EXFAL IT IS
22699: * HELPFUL TO SET KEYWORD ERRTEXT AND FOR GENERALITY
22700: * THESE ERRORS MAY BE HANDLED BY THE SETEXIT MECHANISM.
22701: *
22702: ERR08 JSR COPND CALL TO CLOSE OFF THIS LEVEL
22703: BNZ R$COP,ERR08 LOOP IF NOT ALL -COPYS CLOSED
22704: ZER R$CCB FORGET GARBAGE CODE BLOCK
22705: SSL INISS RESTORE MAIN PROG S-R STACK PTR
22706: JSR ERTEX GET FAIL MESSAGE TEXT
22707: DCA XS ENSURE STACK OK ON LOOP START
22708: *
22709: * POP STACK UNTIL FIND FLPTR FOR MOST DEEPLY NESTED PROG.
22710: * DEFINED FUNCTION CALL OR CALL OF EVAL / CODE.
22711: *
22712: ERR09 ICA XS POP STACK
22713: BEQ XS,FLPRT,ERR11 JUMP IF PROG DEFINED FN CALL FOUND
22714: BNE XS,GTCEF,ERR09 LOOP IF NOT EVAL OR CODE CALL YET
22715: MOV =STGXT,STAGE RE-SET STAGE FOR EXECUTE
22716: MOV R$GTC,R$COD RECOVER CODE PTR
22717: MOV XS,FLPTR RESTORE FAIL POINTER
22718: ZER R$CIM FORGET POSSIBLE IMAGE
22719: *
22720: * TEST ERRLIMIT
22721: *
22722: ERR10 BNZ KVERL,ERR14 JUMP IF ERRLIMIT NON-ZERO
22723: BRN EXFAL FAIL
22724: *
22725: * RETURN FROM PROG. DEFINED FUNCTION IS OUTSTANDING
22726: *
22727: ERR11 MOV FLPTR,XS RESTORE STACK FROM FLPTR
22728: BRN ERR10 MERGE
22729: *
22730: * ERROR AT EXECUTE TIME.
22731: *
22732: * THE ACTION TAKEN ON AN ERROR IS AS FOLLOWS.
22733: *
22734: * IF ERRLIMIT KEYWORD IS ZERO, THE RUN IS ABORTED.
22735: * OTHERWISE, ERRLIMIT IS DECREMENTED AND AN ERRTYPE TRACE
22736: * GENERATED IF REQUIRED. CONTROL RETURNS EITHER VIA A JUMP
22737: * TO CONTINUE (TO TAKE THE FAILURE EXIT) OR A SPECIFIED
22738: * SETEXIT TRAP IS EXECUTED AND CONTROL PASSES TO THE TRAP.
22739: * IF 3 OR MORE FATAL ERRORS OCCUR AN ABORT OCCURS
22740: * REGARDLESS OF ERRLIMIT AND SETEXIT - LOOPING IS ALL TOO
22741: * PROBABLE OTHERWISE. FATAL ERRORS INCLUDE STACK OVERFLOW
22742: * AND EXCEEDING STLIMIT.
22743: EJC
22744: *
22745: ERR12 SSL INISS RESTORE MAIN PROG S-R STACK PTR
22746: BNZ DMVCH,ERR15 JUMP IF IN MID-DUMP
22747: *
22748: * MERGE HERE AFTER DUMP TIDY UP
22749: *
22750: ERR13 ZER XR CLEAR XR FLAG
22751: BZE KVERL,STOPR ABORT IF ERRLIMIT IS ZERO
22752: JSR ERTEX GET FAIL MESSAGE TEXT
22753: *
22754: * MERGE AFTER ERRLIMIT TEST
22755: *
22756: ERR14 DCV KVERL DECREMENT ERRLIMIT
22757: MOV R$ERT,XL LOAD ERRTYPE TRACE POINTER
22758: JSR KTREX GENERATE ERRTYPE TRACE IF REQUIRED
22759: MOV R$COD,R$CNT SET CDBLK PTR FOR CONTINUATION
22760: MOV FLPTR,XR SET PTR TO FAILURE OFFSET
22761: MOV (XR),STXOF SAVE FAILURE OFFSET FOR CONTINUE
22762: MOV R$SXC,XR LOAD SETEXIT CDBLK POINTER
22763: BZE XR,ERRG4 CONTINUE IF NO SETEXIT TRAP
22764: ZER R$SXC ELSE RESET TRAP
22765: MOV =NULLS,STXVR RESET SETEXIT ARG TO NULL
22766: MOV (XR),XL LOAD PTR TO CODE BLOCK ROUTINE
22767: BRI XL EXECUTE FIRST TRAP STATEMENT
22768: *
22769: * INTERRUPTED PARTLY THROUGH A DUMP WHILST STORE IS IN A
22770: * MESS SO DO A TIDY UP OPERATION. SEE DUMPR FOR DETAILS.
22771: *
22772: ERR15 MOV DMVCH,XR CHAIN HEAD FOR AFFECTED VRBLKS
22773: BZE XR,ERR13 DONE IF ZERO
22774: MOV (XR),DMVCH SET NEXT LINK AS CHAIN HEAD
22775: JSR SETVR RESTORE VRGET FIELD
22776: BRN ERR15 LOOP THROUGH CHAIN
22777: *
22778: * TAKE DRACONIAN STEPS FOR REPEATED FATAL ERRORS
22779: *
22780: ERR16 MOV ERRTF,WA ERROR CODE
22781: MOV WA,KVERT PLACE ERROR CODE FOR ERMSG
22782: MNZ XR IN CASE COMPILE TIME
22783: BEQ STAGE,=STGIC,STOPR JUMP IF SO
22784: BEQ STAGE,=STGCE,STOPR ALSO COMPILE TIME
22785: ZER XR INDICATE EXECUTION
22786: BRN STOPR TERMINATE RUN
22787: *
22788: ERRAF ERB 251,TOO MANY FATAL ERRORS
22789: *
22790: * HERE FOR GLOBAL ERROR JUMPS
22791: *
22792: ERRG1 JMG CMPLE
22793: ERRG2 JMG CMPEE
22794: ERRG3 JMG CMPCE
22795: ERRG4 JMG LCNXE
22796: TTL S P I T B O L -- HERE ENDETH THE CODE
22797: *
22798: * END OF ASSEMBLY
22799: *
22800: END END MACRO-SPITBOL ASSEMBLY
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.